diff --git a/.codecov.yml b/.codecov.yml index 84e438145e..838c421f66 100644 --- a/.codecov.yml +++ b/.codecov.yml @@ -8,6 +8,6 @@ coverage: default: threshold: 100% base: parent -comment: - # This must be set to the number of test cases (TCs) - after_n_builds: 8 + +fixes: + - "MOM6/::" diff --git a/.github/actions/macos-setup/action.yml b/.github/actions/macos-setup/action.yml new file mode 100644 index 0000000000..0c1116f25b --- /dev/null +++ b/.github/actions/macos-setup/action.yml @@ -0,0 +1,37 @@ +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + +name: 'install-macos-prerequisites' + +description: 'Install prerequisites for Mac OS compilation' + +runs: + using: 'composite' + + steps: + - name: Install macOS packages + shell: bash + run: | + echo "::group::Install packages" + brew reinstall gcc + brew install automake + brew install netcdf + brew install netcdf-fortran + brew install mpich + echo "::endgroup::" + + # NOTE: Floating point exceptions are currently disabled due to an error in + # HDF5 1.4.3. They will be re-enabled when the default brew version has + # been updated to a working version. + + - name: Set compiler flags + shell: bash + run: | + cd .testing + echo "FCFLAGS_DEBUG = -g -O0 -Wextra -Wno-compare-reals -fbacktrace -fcheck=bounds" >> config.mk + echo "FCFLAGS_REPRO = -g -O1 -ffp-contract=off -fbacktrace" >> config.mk + echo "FCFLAGS_INIT = -finit-real=snan -finit-integer=2147483647 -finit-derived" >> config.mk + echo "FCFLAGS_FMS = -g -fbacktrace -O0" >> config.mk + cat config.mk + echo "::endgroup::" diff --git a/.github/actions/testing-setup/action.yml b/.github/actions/testing-setup/action.yml deleted file mode 100644 index 1ab96aa3df..0000000000 --- a/.github/actions/testing-setup/action.yml +++ /dev/null @@ -1,78 +0,0 @@ -name: 'Build-.testing-prerequisites' -description: 'Build pre-requisites for .testing including FMS and a symmetric MOM6 executable' -inputs: - build_symmetric: - description: 'If true, will build the symmetric MOM6 executable' - required: false - default: 'true' - install_python: - description: 'If true, will install the local python env needed for .testing' - required: false - default: 'true' -runs: - using: 'composite' - steps: - - name: Git info - shell: bash - run: | - echo "::group::Git commit info" - echo "git log:" - git log | head -60 - echo "::endgroup::" - - - name: Env - shell: bash - run: | - echo "::group::Environment" - env - echo "::endgroup::" - - - name: Install needed packages for compiling - shell: bash - run: | - echo "::group::Install linux packages" - sudo apt-get update - sudo apt-get install netcdf-bin libnetcdf-dev libnetcdff-dev mpich libmpich-dev - sudo apt-get install linux-tools-common - echo "::endgroup::" - - - name: Compile FMS library - shell: bash - run: | - echo "::group::Compile FMS library" - cd .testing - make deps/lib/libFMS.a -s -j - echo "::endgroup::" - - - name: Store compiler flags used in Makefile - shell: bash - run: | - echo "::group::config.mk" - cd .testing - echo "FCFLAGS_DEBUG=-g -O0 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds" >> config.mk - echo "FCFLAGS_REPRO=-g -O2 -fbacktrace" >> config.mk - echo "FCFLAGS_INIT=-finit-real=snan -finit-integer=2147483647 -finit-derived" >> config.mk - echo "FCFLAGS_COVERAGE=--coverage" >> config.mk - cat config.mk - echo "::endgroup::" - - - name: Compile MOM6 in symmetric memory mode - shell: bash - run: | - echo "::group::Compile MOM6 in symmetric memory mode" - cd .testing - test ${{ inputs.build_symmetric }} == true && make build/symmetric/MOM6 -j - echo "::endgroup::" - - - name: Install local python venv for generating input data - shell: bash - run: | - echo "::group::Create local python env for input data generation" - cd .testing - test ${{ inputs.install_python }} == true && make work/local-env - echo "::endgroup::" - - - name: Set flags - shell: bash - run: | - echo "TIMEFORMAT=... completed in %lR (user: %lU, sys: %lS)" >> $GITHUB_ENV diff --git a/.github/actions/ubuntu-setup/action.yml b/.github/actions/ubuntu-setup/action.yml new file mode 100644 index 0000000000..22d8ae897a --- /dev/null +++ b/.github/actions/ubuntu-setup/action.yml @@ -0,0 +1,35 @@ +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + +name: 'install-ubuntu-prerequisites' + +description: 'Install prerequisites for Ubuntu Linux compilation' + +runs: + using: 'composite' + steps: + - name: Install Ubuntu Linux packages + shell: bash + run: | + echo "::group::Install linux packages" + sudo apt-get update + sudo apt-get install netcdf-bin + sudo apt-get install libnetcdf-dev + sudo apt-get install libnetcdff-dev + sudo apt-get install openmpi-bin + sudo apt-get install libopenmpi-dev + sudo apt-get install linux-tools-common + echo "::endgroup::" + + - name: Store compiler flags used in Makefile + shell: bash + run: | + echo "::group::config.mk" + cd .testing + echo "FCFLAGS_DEBUG = -g -O0 -std=f2018 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds" >> config.mk + echo "FCFLAGS_REPRO = -g -O2 -fbacktrace" >> config.mk + echo "FCFLAGS_INIT = -finit-real=snan -finit-integer=2147483647 -finit-derived" >> config.mk + echo "FCFLAGS_FMS = -g -fbacktrace -O0" >> config.mk + cat config.mk + echo "::endgroup::" diff --git a/.github/workflows/coupled-api.yml b/.github/workflows/coupled-api.yml deleted file mode 100644 index 86d7262548..0000000000 --- a/.github/workflows/coupled-api.yml +++ /dev/null @@ -1,33 +0,0 @@ -name: API for coupled drivers - -on: [push, pull_request] - -jobs: - test-top-api: - - runs-on: ubuntu-latest - defaults: - run: - working-directory: .testing - - steps: - - uses: actions/checkout@v2 - with: - submodules: recursive - - - uses: ./.github/actions/testing-setup - with: - build_symmetric: 'false' - install_python: 'false' - - - name: Compile MOM6 for the GFDL coupled driver - shell: bash - run: make check_mom6_api_coupled -j - - - name: Compile MOM6 for the NUOPC driver - shell: bash - run: make check_mom6_api_nuopc -j - - - name: Compile MOM6 for the MCT driver - shell: bash - run: make check_mom6_api_mct -j diff --git a/.github/workflows/coverage.yml b/.github/workflows/coverage.yml deleted file mode 100644 index 60b85e412b..0000000000 --- a/.github/workflows/coverage.yml +++ /dev/null @@ -1,24 +0,0 @@ -name: Code coverage - -on: [push, pull_request] - -jobs: - build-test-nans: - - runs-on: ubuntu-latest - defaults: - run: - working-directory: .testing - - env: - REPORT_COVERAGE: true - - steps: - - uses: actions/checkout@v2 - with: - submodules: recursive - - - uses: ./.github/actions/testing-setup - - - name: Run and post coverage - run: make run.symmetric -k -s diff --git a/.github/workflows/documentation-and-style.yml b/.github/workflows/documentation-and-style.yml deleted file mode 100644 index c171c538d5..0000000000 --- a/.github/workflows/documentation-and-style.yml +++ /dev/null @@ -1,39 +0,0 @@ -name: Doxygen and style - -on: [push, pull_request] - -jobs: - doxygen: - - runs-on: ubuntu-latest - - steps: - - uses: actions/checkout@v2 - with: - submodules: recursive - - - name: Check white space (non-blocking) - run: | - ./.testing/trailer.py -e TEOS10 -l 120 src config_src 2>&1 | tee style_errors - continue-on-error: true - - - name: Install packages used when generating documentation - run: | - sudo apt-get update - sudo apt-get install python3-sphinx python3-lxml perl - sudo apt-get install texlive-binaries texlive-base bibtool tex-common texlive-bibtex-extra - sudo apt-get install graphviz - - - name: Build doxygen HTML - run: | - cd docs - perl -e 'print "perl version $^V" . "\n"' - mkdir _build && make nortd DOXYGEN_RELEASE=Release_1_8_13 UPDATEHTMLEQS=Y - cat _build/doxygen_warn_nortd_log.txt - - - name: Report doxygen or style errors - run: | - grep "warning:" docs/_build/doxygen_warn_nortd_log.txt | grep -v "as part of a" | tee doxy_errors - cat style_errors doxy_errors > all_errors - cat all_errors - test ! -s all_errors diff --git a/.github/workflows/expression.yml b/.github/workflows/expression.yml deleted file mode 100644 index 020d656aee..0000000000 --- a/.github/workflows/expression.yml +++ /dev/null @@ -1,27 +0,0 @@ -name: Expression verification - -on: [push, pull_request] - -jobs: - test-repro-and-dims: - - runs-on: ubuntu-latest - defaults: - run: - working-directory: .testing - - steps: - - uses: actions/checkout@v2 - with: - submodules: recursive - - - uses: ./.github/actions/testing-setup - - - name: Compile MOM6 using repro optimization - run: make build/repro/MOM6 -j - - - name: Create validation data - run: make run.symmetric -k -s - - - name: Run tests - run: make test.repro test.dim -k -s diff --git a/.github/workflows/other.yml b/.github/workflows/other.yml deleted file mode 100644 index 34239b0b7c..0000000000 --- a/.github/workflows/other.yml +++ /dev/null @@ -1,27 +0,0 @@ -name: OpenMP and Restart verification - -on: [push, pull_request] - -jobs: - test-openmp-nan-restarts: - - runs-on: ubuntu-latest - defaults: - run: - working-directory: .testing - - steps: - - uses: actions/checkout@v2 - with: - submodules: recursive - - - uses: ./.github/actions/testing-setup - - - name: Compile with openMP - run: make build/openmp/MOM6 -j - - - name: Create validation data - run: make run.symmetric -k -s - - - name: Run tests - run: make test.openmp test.nan test.restart -k -s diff --git a/.github/workflows/perfmon.yml b/.github/workflows/perfmon.yml deleted file mode 100644 index 00e645c4fd..0000000000 --- a/.github/workflows/perfmon.yml +++ /dev/null @@ -1,36 +0,0 @@ -name: Performance Monitor - -on: [pull_request] - -jobs: - build-test-perfmon: - - runs-on: ubuntu-latest - defaults: - run: - working-directory: .testing - - steps: - - uses: actions/checkout@v2 - with: - submodules: recursive - - - uses: ./.github/actions/testing-setup - - - name: Compile optimized models - run: >- - make -j build.prof - MOM_TARGET_SLUG=$GITHUB_REPOSITORY - MOM_TARGET_LOCAL_BRANCH=$GITHUB_BASE_REF - DO_REGRESSION_TESTS=true - - - name: Generate profile data - run: >- - pip install f90nml && - make profile - DO_REGRESSION_TESTS=true - - - name: Generate perf data - run: | - sudo sysctl -w kernel.perf_event_paranoid=2 - make perf DO_REGRESSION_TESTS=true diff --git a/.github/workflows/regression.yml b/.github/workflows/regression.yml deleted file mode 100644 index acc42e4720..0000000000 --- a/.github/workflows/regression.yml +++ /dev/null @@ -1,27 +0,0 @@ -name: Regression - -on: [pull_request] - -jobs: - build-test-regression: - - runs-on: ubuntu-latest - defaults: - run: - working-directory: .testing - - steps: - - uses: actions/checkout@v2 - with: - submodules: recursive - - - uses: ./.github/actions/testing-setup - - - name: Compile reference model - run: make build.regressions MOM_TARGET_SLUG=$GITHUB_REPOSITORY MOM_TARGET_LOCAL_BRANCH=$GITHUB_BASE_REF DO_REGRESSION_TESTS=true -j - - - name: Create validation data - run: make run.symmetric -k -s - - - name: Regression test - run: make test.regression DO_REGRESSION_TESTS=true -k -s diff --git a/.github/workflows/stencil.yml b/.github/workflows/stencil.yml deleted file mode 100644 index 51a0611fc4..0000000000 --- a/.github/workflows/stencil.yml +++ /dev/null @@ -1,27 +0,0 @@ -name: Stencil related verification - -on: [push, pull_request] - -jobs: - test-symmetric-layout-rotation: - - runs-on: ubuntu-latest - defaults: - run: - working-directory: .testing - - steps: - - uses: actions/checkout@v2 - with: - submodules: recursive - - - uses: ./.github/actions/testing-setup - - - name: Compile MOM6 in asymmetric memory mode - run: make build/asymmetric/MOM6 -j - - - name: Create validation data - run: make run.symmetric -k -s - - - name: Run tests - run: make test.grid test.layout test.rotate -k -s diff --git a/.github/workflows/verify-linux.yml b/.github/workflows/verify-linux.yml new file mode 100644 index 0000000000..20067aa7d5 --- /dev/null +++ b/.github/workflows/verify-linux.yml @@ -0,0 +1,794 @@ +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + +name: Linux verification + +on: [push, pull_request] + +env: + MOM_TARGET_SLUG: ${{ github.repository }} + MOM_TARGET_LOCAL_BRANCH: ${{ github.base_ref }} + +jobs: + # Documentation + + check-style-and-docstrings: + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v4 + + - name: Check white space (non-blocking) + run: | + ./.testing/trailer.py -e TEOS10 -l 120 src config_src 2>&1 | tee style_errors + continue-on-error: true + + - name: Install packages used when generating documentation + run: | + sudo apt-get update + sudo apt-get install python3-sphinx python3-lxml perl + sudo apt-get install texlive-binaries texlive-base bibtool tex-common texlive-bibtex-extra + sudo apt-get install graphviz + + - name: Build doxygen HTML + run: | + cd docs + perl -e 'print "perl version $^V" . "\n"' + mkdir _build && make nortd DOXYGEN_RELEASE=Release_1_8_13 UPDATEHTMLEQS=Y + cat _build/doxygen_warn_nortd_log.txt + + - name: Report doxygen or style errors + run: | + grep "warning:" docs/_build/doxygen_warn_nortd_log.txt | grep -v "as part of a" | tee doxy_errors + cat style_errors doxy_errors > all_errors + cat all_errors + test ! -s all_errors + + # Executables + + build-symmetric: + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/ubuntu-setup/ + + - name: Compile dependencies + run: | + make -C .testing -j build/deps/lib/libFMS.a + make -C .testing -j PKG= build/deps/lib/libgsw.a + make -C .testing -j PKG= build/deps/lib/libcvmix.a + + - name: Compile MOM6 with symmetric indexing + run: make -C .testing -j build/symmetric/MOM6 + + - name: Prepare artifact + run: tar -cf mom6-symmetric.tar .testing/build/symmetric/MOM6 + + - uses: actions/upload-artifact@v4 + with: + name: mom6-symmetric-artifact + path: mom6-symmetric.tar + retention-days: 1 + + build-asymmetric: + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/ubuntu-setup/ + + - name: Compile dependencies + run: | + make -C .testing -j build/deps/lib/libFMS.a + make -C .testing -j PKG= build/deps/lib/libgsw.a + make -C .testing -j PKG= build/deps/lib/libcvmix.a + + - name: Compile MOM6 with asymmetric indexing + run: make -C .testing -j build/asymmetric/MOM6 + + - name: Prepare artifact + run: tar -cf mom6-asymmetric.tar .testing/build/asymmetric/MOM6 + + - uses: actions/upload-artifact@v4 + with: + name: mom6-asymmetric-artifact + path: mom6-asymmetric.tar + retention-days: 1 + + build-repro: + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/ubuntu-setup/ + + - name: Compile dependencies + run: | + make -C .testing -j build/deps/lib/libFMS.a + make -C .testing -j PKG= build/deps/lib/libgsw.a + make -C .testing -j PKG= build/deps/lib/libcvmix.a + + - name: Compile MOM6 with bit-reproducible optimization + run: make -C .testing -j build/repro/MOM6 + + - name: Prepare artifact + run: tar -cf mom6-repro.tar .testing/build/repro/MOM6 + + - uses: actions/upload-artifact@v4 + with: + name: mom6-repro-artifact + path: mom6-repro.tar + retention-days: 1 + + build-openmp: + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/ubuntu-setup/ + + - name: Compile dependencies + run: | + make -C .testing -j build/deps/lib/libFMS.a + make -C .testing -j PKG= build/deps/lib/libgsw.a + make -C .testing -j PKG= build/deps/lib/libcvmix.a + + - name: Compile MOM6 supporting OpenMP + run: make -C .testing -j build/openmp/MOM6 + + - name: Prepare artifact + run: tar -cf mom6-openmp.tar .testing/build/openmp/MOM6 + + - uses: actions/upload-artifact@v4 + with: + name: mom6-openmp-artifact + path: mom6-openmp.tar + retention-days: 1 + + build-target: + if: github.event_name == 'pull_request' + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/ubuntu-setup/ + + - name: Compile target depedencies + run: | + make -C .testing \ + DO_REGRESSION_TESTS=1 \ + build/target_codebase + make -C .testing/build/target_codebase/.testing -j \ + build/deps/lib/libFMS.a + + - name: Compile target MOM6 + run: | + make -C .testing -j \ + DO_REGRESSION_TESTS=1 \ + build/target/MOM6 + + - name: Prepare artifact + run: tar -cf mom6-target.tar .testing/build/target/MOM6 + + - uses: actions/upload-artifact@v4 + with: + name: mom6-target-artifact + path: mom6-target.tar + retention-days: 1 + + build-opt: + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/ubuntu-setup/ + + - name: Compile dependencies + run: | + make -C .testing -j build/deps/lib/libFMS.a + make -C .testing -j PKG= build/deps/lib/libgsw.a + make -C .testing -j PKG= build/deps/lib/libcvmix.a + + - name: Compile MOM6 with aggressive optimization + run: make -C .testing -j build/opt/MOM6 + + - name: Compile timing tests + run: make -C .testing build.timing + + - name: Prepare artifact + run: | + tar -cf mom6-opt.tar \ + --exclude='.testing/build/timing/time_*.o' \ + .testing/build/opt/MOM6 \ + .testing/build/timing/time_* + + - uses: actions/upload-artifact@v4 + with: + name: mom6-opt-artifact + path: mom6-opt.tar + retention-days: 1 + + build-opt-target: + if: github.event_name == 'pull_request' + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/ubuntu-setup/ + + - name: Compile target dependencies + run: | + make -C .testing \ + DO_REGRESSION_TESTS=1 \ + build/target_codebase + make -C .testing/build/target_codebase/.testing -j \ + build/deps/lib/libFMS.a + + - name: Compile target MOM6 + run: | + make -C .testing -j \ + DO_REGRESSION_TESTS=1 \ + build/opt_target/MOM6 + + - name: Compile target timing tests + run: | + make -C .testing/build/target_codebase/.testing \ + DO_REGRESSION_TESTS=1 \ + build.timing + + - name: Prepare artifact + run: | + tar -cf mom6-opt-target.tar \ + --exclude='.testing/build/target_codebase/.testing/build/timing/time_*.o' \ + .testing/build/opt_target/MOM6 \ + .testing/build/target_codebase/.testing/build/timing/time_* + + - uses: actions/upload-artifact@v4 + with: + name: mom6-opt-target-artifact + path: mom6-opt-target.tar + retention-days: 1 + + build-coverage: + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/ubuntu-setup/ + + - name: Compile dependencies + run: | + make -C .testing -j build/deps/lib/libFMS.a + make -C .testing -j PKG= build/deps/lib/libgsw.a + make -C .testing -j PKG= build/deps/lib/libcvmix.a + + - name: Compile MOM6 with code coverage + run: make -C .testing -j build/cov/MOM6 + + - name: Compile MOM6 unit tests + run: | + make -C .testing -j build/unit/test_MOM_file_parser + make -C .testing -j build.unit + + - name: Prepare artifact + run: | + tar -cf mom6-coverage.tar \ + --exclude='.testing/build/unit/test_*.o' \ + .testing/build/cov/MOM6 \ + .testing/build/cov/*.gcno \ + .testing/build/unit/test_* \ + .testing/build/unit/*.gcno + + - uses: actions/upload-artifact@v4 + with: + name: mom6-coverage-artifact + path: mom6-coverage.tar + retention-days: 1 + + build-coupled-api: + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/ubuntu-setup/ + + - name: Compile dependencies + run: | + make -C .testing -j build/deps/lib/libFMS.a + make -C .testing -j PKG= build/deps/lib/libgsw.a + make -C .testing -j PKG= build/deps/lib/libcvmix.a + + - name: Compile MOM6 for the GFDL coupled driver + run: make -C .testing -j check_mom6_api_coupled + + # Tests + + test-grid: + runs-on: ubuntu-latest + needs: + - build-symmetric + - build-asymmetric + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/ubuntu-setup + + - name: Download symmetric MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + + - name: Download asymmetric MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-asymmetric-artifact + + - name: Unpack artifacts + run: | + tar -xpvf mom6-symmetric.tar + tar -xpvf mom6-asymmetric.tar + + - name: Run grid verification test + run: | + make -C .testing -j \ + -o build/symmetric/MOM6 \ + -o build/asymmetric/MOM6 \ + test.grid + + test-layout: + runs-on: ubuntu-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/ubuntu-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + + - name: Unpack artifacts + run: tar -xpvf mom6-symmetric.tar + + - name: Run layout test + run: | + make -C .testing -j \ + -o build/symmetric/MOM6 \ + test.layout + + test-rotate: + runs-on: ubuntu-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/ubuntu-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + + - name: Unpack artifacts + run: tar -xpvf mom6-symmetric.tar + + - name: Run rotation test + run: | + make -C .testing -j \ + -o build/symmetric/MOM6 \ + test.rotate + + test-restart: + runs-on: ubuntu-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/ubuntu-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + + - name: Unpack artifacts + run: tar -xpvf mom6-symmetric.tar + + - name: Run restart test + run: | + make -C .testing -j \ + -o build/symmetric/MOM6 \ + test.restart + + test-nan: + runs-on: ubuntu-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/ubuntu-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + + - name: Unpack artifacts + run: tar -xpvf mom6-symmetric.tar + + - name: Run NaN initialization test + run: | + make -C .testing -j \ + -o build/symmetric/MOM6 \ + test.nan + + test-dim: + runs-on: ubuntu-latest + needs: build-symmetric + + strategy: + matrix: + dim: + - {id: t, desc: "time"} + - {id: l, desc: "horizontal length"} + - {id: h, desc: "vertical thickness"} + - {id: z, desc: "vertical coordinate"} + - {id: q, desc: "enthalpy"} + - {id: r, desc: "density"} + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/ubuntu-setup + + - name: Download symmetric MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + + - name: Unpack artifacts + run: tar -xpvf mom6-symmetric.tar + + - name: Run ${{ matrix.dim.desc }} dimension test + run: | + make -C .testing -j \ + -o build/symmetric/MOM6 \ + test.dim.${{ matrix.dim.id }} + + test-openmp: + runs-on: ubuntu-latest + needs: + - build-symmetric + - build-openmp + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/ubuntu-setup + + - name: Download symmetric MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + + - name: Download OpenMP MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-openmp-artifact + + - name: Unpack artifacts + run: | + tar -xpvf mom6-symmetric.tar + tar -xpvf mom6-openmp.tar + + - name: Run OpenMP test + run: | + make -C .testing -j \ + -o build/symmetric/MOM6 \ + -o build/openmp/MOM6 \ + test.openmp + + test-repro: + runs-on: ubuntu-latest + needs: + - build-symmetric + - build-repro + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/ubuntu-setup + + - name: Download DEBUG MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + + - name: Download REPRO MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-repro-artifact + + - name: Unpack artifacts + run: | + tar -xpvf mom6-symmetric.tar + tar -xpvf mom6-repro.tar + + - name: Verify REPRO equivalence + run: | + make -C .testing -j \ + -o build/symmetric/MOM6 \ + -o build/repro/MOM6 \ + test.repro + + test-regression: + if: github.event_name == 'pull_request' + runs-on: ubuntu-latest + needs: + - build-symmetric + - build-target + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/ubuntu-setup + + - name: Download symmetric MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + + - name: Download target MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-target-artifact + + - name: Unpack artifacts + run: | + tar -xpvf mom6-symmetric.tar + tar -xpvf mom6-target.tar + + - name: Check for regressions + run: | + make -C .testing -j \ + -o build/symmetric/MOM6 \ + -o build/target/MOM6 \ + DO_REGRESSION_TESTS=1 \ + test.regression + + run-coverage: + runs-on: ubuntu-latest + needs: build-coverage + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/ubuntu-setup + + - name: Download unit coverage tests + uses: actions/download-artifact@v4 + with: + name: mom6-coverage-artifact + + - name: Unpack artifacts + run: | + tar -xpvf mom6-coverage.tar + find .testing/build/cov -name "*.gcno" -exec touch {} \; + find .testing/build/unit -name "*.gcno" -exec touch {} \; + + - name: Generate MOM6 coverage + run: | + make -C .testing -j \ + -o build/cov/MOM6 \ + run.cov + + - name: Generate unit test coverage + run: | + cd .testing && make -j \ + $(for f in build/unit/test_*; do echo "-o $f"; done) \ + run.cov.unit + + - name: Report coverage to CI + run: | + cd .testing && make \ + -o build/cov/MOM6 \ + $(for f in build/unit/test_*; do echo "-o $f"; done) \ + report.cov report.cov.unit + env: + CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} + + # These are most likely nonsense on a GitHub node, but someday it could work. + run-timings: + if: github.event_name != 'pull_request' + runs-on: ubuntu-latest + needs: + - build-opt + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/ubuntu-setup + + - name: Download timing tests + uses: actions/download-artifact@v4 + with: + name: mom6-opt-artifact + + - name: Unpack artifacts + run: tar -xpvf mom6-opt.tar + + - name: Run unit test timings + run: | + cd .testing && make -j \ + $(for f in build/timing/time_*; do echo "-o $f"; done) \ + run.timing + + - name: Show timing results + run: make -C .testing show.timing + + # These are most likely nonsense on a GitHub node, but someday it could work. + compare-timings: + if: github.event_name == 'pull_request' + runs-on: ubuntu-latest + needs: + - build-opt + - build-opt-target + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/ubuntu-setup + + # NOTE: This needs to occur before the artifacts are unpacked, because + # our rule for setting up `target_codebase` depends on its presence, + # rather than its contents. + # If we can improve this rule, then this can be moved after unpacking. + - name: Re-clone target directory + run: | + make -C .testing \ + DO_REGRESSION_TESTS=1 \ + build/target_codebase + + - name: Download optimized MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-opt-artifact + + - name: Download optimized target MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-opt-target-artifact + + - name: Unpack artifacts + run: | + tar -xpvf mom6-opt.tar + tar -xpvf mom6-opt-target.tar + + - name: Install preprocessor dependency + run: pip install f90nml + + - name: Profile with FMS clocks + run: | + make -C .testing -j \ + -o build/opt/MOM6 \ + -o build/opt_target/MOM6 \ + profile + + - name: Profile with perf + run: | + sudo sysctl -w kernel.perf_event_paranoid=2 + make -C .testing -j \ + -o build/opt/MOM6 \ + -o build/opt_target/MOM6 \ + perf + + - name: Run unit test timings + run: | + cd .testing && make -j \ + $(for f in build/timing/time_*; do echo "-o $f"; done) \ + run.timing + + - name: Show timing results + run: make -C .testing DO_REGRESSION_TESTS=1 show.timing + + - name: Run target timing tests + run: | + cd .testing/build/target_codebase/.testing && make -j \ + $(for f in build/timing/time_*; do echo "-o $f"; done) \ + run.timing + + - name: Compare unit test timings + run: | + make -C .testing \ + DO_REGRESSION_TESTS=1 \ + compare.timing + + # Cleanup + + cleanup-common: + runs-on: ubuntu-latest + permissions: + id-token: write + needs: + - test-grid + - test-openmp + - test-repro + - run-coverage + + steps: + - uses: geekyeggo/delete-artifact@v5 + with: + name: | + mom6-asymmetric-artifact + mom6-openmp-artifact + mom6-repro-artifact + mom6-coverage-artifact + + # NOTE: There is no way to conditionally define the elements in `needs`. + # For now, we must create separate rules for each case. + + cleanup-push: + if: github.event_name != 'pull_request' + runs-on: ubuntu-latest + permissions: + id-token: write + needs: + - test-layout + - test-rotate + - test-restart + - test-nan + - test-dim + - test-grid + - test-openmp + - test-repro + - run-timings + + steps: + - uses: geekyeggo/delete-artifact@v5 + with: + name: | + mom6-symmetric-artifact + mom6-opt-artifact + + cleanup-pr: + if: github.event_name == 'pull_request' + runs-on: ubuntu-latest + permissions: + id-token: write + needs: + - test-layout + - test-rotate + - test-restart + - test-nan + - test-dim + - test-grid + - test-openmp + - test-repro + - test-regression + - compare-timings + + steps: + - uses: geekyeggo/delete-artifact@v5 + with: + name: | + mom6-symmetric-artifact + mom6-target-artifact + mom6-opt-artifact + mom6-opt-target-artifact diff --git a/.github/workflows/verify-macos.yml b/.github/workflows/verify-macos.yml new file mode 100644 index 0000000000..feb93c53b8 --- /dev/null +++ b/.github/workflows/verify-macos.yml @@ -0,0 +1,483 @@ +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + +name: MacOS verification + +on: [push, pull_request] + +env: + CC: gcc + FC: gfortran + MOM_TARGET_SLUG: ${{ github.repository }} + MOM_TARGET_LOCAL_BRANCH: ${{ github.base_ref }} + +jobs: + # Executables + + build-symmetric: + runs-on: macOS-latest + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/macos-setup/ + + - name: Compile dependencies + run: | + make -C .testing -j build/deps/lib/libFMS.a + make -C .testing -j PKG= build/deps/lib/libgsw.a + make -C .testing -j PKG= build/deps/lib/libcvmix.a + + - name: Compile MOM6 with symmetric indexing + run: make -C .testing -j build/symmetric/MOM6 + + - name: Prepare artifact + run: tar -cf mom6-symmetric.tar .testing/build/symmetric/MOM6 + + - uses: actions/upload-artifact@v4 + with: + name: mom6-symmetric-artifact + path: mom6-symmetric.tar + retention-days: 1 + + build-asymmetric: + runs-on: macOS-latest + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/macos-setup/ + + - name: Compile dependencies + run: | + make -C .testing -j build/deps/lib/libFMS.a + make -C .testing -j PKG= build/deps/lib/libgsw.a + make -C .testing -j PKG= build/deps/lib/libcvmix.a + + - name: Compile MOM6 with asymmetric indexing + run: make -C .testing -j build/asymmetric/MOM6 + + - name: Prepare artifact + run: tar -cf mom6-asymmetric.tar .testing/build/asymmetric/MOM6 + + - uses: actions/upload-artifact@v4 + with: + name: mom6-asymmetric-artifact + path: mom6-asymmetric.tar + retention-days: 1 + + build-repro: + runs-on: macOS-latest + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/macos-setup/ + + - name: Compile dependencies + run: | + make -C .testing -j build/deps/lib/libFMS.a + make -C .testing -j PKG= build/deps/lib/libgsw.a + make -C .testing -j PKG= build/deps/lib/libcvmix.a + + - name: Compile MOM6 with bit-reproducible optimization + run: make -C .testing -j build/repro/MOM6 + + - name: Prepare artifact + run: tar -cf mom6-repro.tar .testing/build/repro/MOM6 + + - uses: actions/upload-artifact@v4 + with: + name: mom6-repro-artifact + path: mom6-repro.tar + retention-days: 1 + + build-openmp: + runs-on: macOS-latest + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/macos-setup/ + + - name: Compile dependencies + run: | + make -C .testing -j build/deps/lib/libFMS.a + make -C .testing -j PKG= build/deps/lib/libgsw.a + make -C .testing -j PKG= build/deps/lib/libcvmix.a + + - name: Compile MOM6 supporting OpenMP + run: make -C .testing -j build/openmp/MOM6 + + - name: Prepare artifact + run: tar -cf mom6-openmp.tar .testing/build/openmp/MOM6 + + - uses: actions/upload-artifact@v4 + with: + name: mom6-openmp-artifact + path: mom6-openmp.tar + retention-days: 1 + + build-target: + if: github.event_name == 'pull_request' + runs-on: macOS-latest + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/macos-setup/ + + - name: Compile target dependencies + run: | + make -C .testing \ + DO_REGRESSION_TESTS=1 \ + build/target_codebase + make -C .testing/build/target_codebase/.testing -j \ + build/deps/lib/libFMS.a + + - name: Compile target MOM6 + run: | + make -C .testing -j \ + DO_REGRESSION_TESTS=1 \ + build/target/MOM6 + + - name: Prepare artifact + run: tar -cf mom6-target.tar .testing/build/target/MOM6 + + - uses: actions/upload-artifact@v4 + with: + name: mom6-target-artifact + path: mom6-target.tar + retention-days: 1 + + # Tests + + test-grid: + runs-on: macOS-latest + needs: + - build-symmetric + - build-asymmetric + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/macos-setup + + - name: Download symmetric MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + + - name: Download asymmetric MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-asymmetric-artifact + + - name: Unpack artifacts + run: | + tar -xpvf mom6-symmetric.tar + tar -xpvf mom6-asymmetric.tar + + - name: Run grid verification test + run: | + make -C .testing -j \ + -o build/symmetric/MOM6 \ + -o build/asymmetric/MOM6 \ + test.grid + + test-layout: + runs-on: macOS-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/macos-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + + - name: Unpack artifacts + run: tar -xpvf mom6-symmetric.tar + + - name: Run layout test + run: | + make -C .testing -j \ + -o build/symmetric/MOM6 \ + test.layout + + test-rotate: + runs-on: macOS-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/macos-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + + - name: Unpack artifacts + run: tar -xpvf mom6-symmetric.tar + + - name: Run rotation test + run: | + make -C .testing -j \ + -o build/symmetric/MOM6 \ + test.rotate + + test-restart: + runs-on: macOS-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/macos-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + + - name: Unpack artifacts + run: tar -xpvf mom6-symmetric.tar + + - name: Run restart test + run: | + make -C .testing -j \ + -o build/symmetric/MOM6 \ + test.restart + + test-nan: + runs-on: macOS-latest + needs: build-symmetric + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/macos-setup + + - name: Download Artifacts + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + + - name: Unpack artifacts + run: tar -xpvf mom6-symmetric.tar + + - name: Run NaN initialization test + run: | + make -C .testing -j \ + -o build/symmetric/MOM6 \ + test.nan + + test-dim: + runs-on: macOS-latest + needs: build-symmetric + + strategy: + matrix: + dim: + - {id: t, desc: "time"} + - {id: l, desc: "horizontal length"} + - {id: h, desc: "vertical thickness"} + - {id: z, desc: "vertical coordinate"} + - {id: q, desc: "enthalpy"} + - {id: r, desc: "density"} + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/macos-setup + + - name: Download symmetric MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + + - name: Unpack artifacts + run: tar -xpvf mom6-symmetric.tar + + - name: Run ${{ matrix.dim.desc }} dimension test + run: | + make -C .testing -j \ + -o build/symmetric/MOM6 \ + test.dim.${{ matrix.dim.id }} + + test-openmp: + runs-on: macOS-latest + needs: + - build-symmetric + - build-openmp + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/macos-setup + + - name: Download symmetric MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + + - name: Download OpenMP MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-openmp-artifact + + - name: Unpack artifacts + run: | + tar -xpvf mom6-symmetric.tar + tar -xpvf mom6-openmp.tar + + - name: Run OpenMP test + run: | + make -C .testing -j \ + -o build/symmetric/MOM6 \ + -o build/openmp/MOM6 \ + test.openmp + + test-repro: + runs-on: macOS-latest + needs: + - build-symmetric + - build-repro + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/macos-setup + + - name: Download DEBUG MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + + - name: Download REPRO MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-repro-artifact + + - name: Unpack artifacts + run: | + tar -xpvf mom6-symmetric.tar + tar -xpvf mom6-repro.tar + + - name: Verify REPRO equivalence + run: | + make -C .testing -j \ + -o build/symmetric/MOM6 \ + -o build/repro/MOM6 \ + test.repro + + test-regression: + if: github.event_name == 'pull_request' + runs-on: macOS-latest + needs: + - build-symmetric + - build-target + + steps: + - uses: actions/checkout@v4 + + - uses: ./.github/actions/macos-setup + + - name: Download symmetric MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-symmetric-artifact + + - name: Download target MOM6 + uses: actions/download-artifact@v4 + with: + name: mom6-target-artifact + + - name: Unpack artifacts + run: | + tar -xpvf mom6-symmetric.tar + tar -xpvf mom6-target.tar + + - name: Check for regressions + run: | + make -C .testing -j \ + -o build/symmetric/MOM6 \ + -o build/target/MOM6 \ + DO_REGRESSION_TESTS=1 \ + test.regression + + # Cleanup + + cleanup-common: + runs-on: macOS-latest + permissions: + id-token: write + needs: + - test-grid + - test-openmp + - test-repro + + steps: + - uses: geekyeggo/delete-artifact@v5 + with: + name: | + mom6-asymmetric-artifact + mom6-openmp-artifact + mom6-repro-artifact + mom6-coverage-artifact + + # NOTE: There is no way to conditionally define the elements in `needs`. + # For now, we must create separate rules for each case. + + cleanup-push: + if: github.event_name != 'pull_request' + runs-on: macOS-latest + permissions: + id-token: write + needs: + - test-layout + - test-rotate + - test-restart + - test-nan + - test-dim + - test-grid + - test-openmp + - test-repro + + steps: + - uses: geekyeggo/delete-artifact@v5 + with: + name: | + mom6-symmetric-artifact + mom6-opt-artifact + + cleanup-pr: + if: github.event_name == 'pull_request' + runs-on: macOS-latest + permissions: + id-token: write + needs: + - test-layout + - test-rotate + - test-restart + - test-nan + - test-dim + - test-grid + - test-openmp + - test-repro + - test-regression + + steps: + - uses: geekyeggo/delete-artifact@v5 + with: + name: | + mom6-symmetric-artifact + mom6-target-artifact + mom6-opt-artifact + mom6-opt-target-artifact diff --git a/.gitignore b/.gitignore index 25f7524d1c..d246027b44 100644 --- a/.gitignore +++ b/.gitignore @@ -1,14 +1,2 @@ -# Ignore vim and emacs files -*.swp -*~ -html - - -# Autoconf output -aclocal.m4 -autom4te.cache/ -config.log -config.status -configure -/Makefile -Makefile.mkmf +# Build output +build/ diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 5e1da1c1f9..b1f7f4bf4d 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -1,91 +1,184 @@ +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + stages: + - setup - builds - run - tests - cleanup +# JOB_DIR points to a persistent working space used for most stages in this pipeline but +# that is unique to this pipeline. +# We use the "fetch" strategy to speed up the startup of stages variables: - CACHE_DIR: "/lustre/f2/scratch/oar.gfdl.ogrp-account/runner/cache/" - + JOB_DIR: "/gpfs/f5/gfdl_o/scratch/oar.gfdl.mom6-account/runner/builds/$CI_PIPELINE_ID" + GIT_STRATEGY: fetch -# Merges MOM6 with dev/gfdl. Changes directory to test directory, if it exists. -# - set cache location -# - get MOM6-examples/tools/MRS scripts by cloning Gaea-stats and then MOM6-examples -# - set working directory to MOM6-examples -# - pull down latest of dev/gfdl (MOM6-examples might be ahead of Gaea-stats) +# Always eport value of $JOB_DIR before_script: - - echo Cache directory set to $CACHE_DIR - - echo -e "\e[0Ksection_start:`date +%s`:before[collapsed=true]\r\e[0KPre-script" - - git clone https://gitlab.gfdl.noaa.gov/ogrp/Gaea-stats-MOM6-examples.git tests - - cd tests && git submodule init && git submodule update - - cd MOM6-examples && git checkout dev/gfdl && git pull - - echo -e "\e[0Ksection_end:`date +%s`:before\r\e[0K" - -# Tests that merge with dev/gfdl works. -merge: - stage: builds + - echo Job directory set to $JOB_DIR + +# Test that merge with dev/gfdl works. +p:merge: + stage: setup tags: - - ncrc4 + - mom6-ci-c5 script: - - cd $CI_PROJECT_DIR - git pull --no-edit https://github.com/NOAA-GFDL/MOM6.git dev/gfdl -# Compiles -gnu:repro: +# Setup the persistent JOB_DIR for all subsequent stages +# +# This basically setups up a complete tree much as a user would in their workflow +p:clone: + stage: setup + tags: + - 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 + - .gitlab/pipeline-ci-tool.sh create-job-dir +#.gitlab/pipeline-ci-tool.sh clean-job-dir + +# Make work spaces for running simultaneously in parallel jobs +# +# Each work space is a clone of MOM6-examples with symbolic links for the build and data directories +# so they can share executables which can run simultaneously without interfering with each other + +s:work-space:pgi: + stage: setup + tags: + - mom6-ci-c5 + needs: ["p:clone"] + script: + - .gitlab/pipeline-ci-tool.sh copy-test-space pgi + +s:work-space:intel: + stage: setup + tags: + - mom6-ci-c5 + needs: ["p:clone"] + script: + - .gitlab/pipeline-ci-tool.sh copy-test-space intel + +s:work-space:gnu: + stage: setup + tags: + - mom6-ci-c5 + needs: ["p:clone"] + script: + - .gitlab/pipeline-ci-tool.sh copy-test-space gnu + +s:work-space:gnu-restarts: + stage: setup + tags: + - mom6-ci-c5 + needs: ["p:clone"] + script: + - .gitlab/pipeline-ci-tool.sh copy-test-space gnu-rst + +# Compile executables +# +# gnu:repro, gnu:debug, intel:repro and pgi:repro are used by their respective run:* jobs +# gnu:ice-only-nolib and gnu:ocean-only-nolibs are not used but simply test that the model compiles without libraries + +compile:pgi:repro: stage: builds + needs: ["p:clone"] tags: - - ncrc4 + - mom6-ci-c5 script: - - time make -f tools/MRS/Makefile MOM6_SRC=../.. pipeline-build-repro-gnu -s -j - - time make -f tools/MRS/Makefile MOM6_SRC=../.. pipeline-build-static-gnu -s -j + - .gitlab/pipeline-ci-tool.sh mrs-compile repro_pgi -gnu:ocean-only-nolibs: +compile:intel:repro: stage: builds + needs: ["p:clone"] tags: - - ncrc4 + - mom6-ci-c5 script: - - make -f tools/MRS/Makefile pipeline-build-gnu-oceanonly-nolibs + - .gitlab/pipeline-ci-tool.sh mrs-compile repro_intel -gnu:ice-ocean-nolibs: +compile:gnu:repro: stage: builds + needs: ["p:clone"] tags: - - ncrc4 + - mom6-ci-c5 script: - - make -f tools/MRS/Makefile pipeline-build-gnu-iceocean-nolibs + - .gitlab/pipeline-ci-tool.sh mrs-compile repro_gnu mrs-compile static_gnu -intel:repro: +compile:gnu:debug: stage: builds + needs: ["p:clone"] tags: - - ncrc4 + - mom6-ci-c5 script: - - time make -f tools/MRS/Makefile MOM6_SRC=../.. pipeline-build-repro-intel -s -j + - .gitlab/pipeline-ci-tool.sh mrs-compile debug_gnu -pgi:repro: +compile:gnu:ocean-only-nolibs: stage: builds + needs: ["p:clone"] tags: - - ncrc4 + - mom6-ci-c5 script: - - time make -f tools/MRS/Makefile MOM6_SRC=../.. pipeline-build-repro-pgi -s -j + - .gitlab/pipeline-ci-tool.sh nolibs-ocean-only-compile gnu -gnu:debug: +compile:gnu:ice-ocean-nolibs: stage: builds + needs: ["p:clone"] tags: - - ncrc4 + - mom6-ci-c5 script: - - time make -f tools/MRS/Makefile MOM6_SRC=../.. pipeline-build-debug-gnu -s -j + - .gitlab/pipeline-ci-tool.sh nolibs-ocean-ice-compile gnu # Runs -run: + +run:pgi: stage: run + needs: ["s:work-space:pgi","compile:pgi:repro"] tags: - - ncrc4 + - mom6-ci-c5 script: - - make -f tools/MRS/Makefile mom6-pipeline-run + - 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 ) -gnu.testing: +run:intel: stage: run + needs: ["s:work-space:intel","compile:intel:repro"] tags: - - ncrc4 + - mom6-ci-c5 + script: + - 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: + - mom6-ci-c5 + script: + - 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: + - mom6-ci-c5 + script: + - 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) +# +# These stages replace the "before_script" and so start in the transient work-space provided by gitlab. +# We work here to avoid collisions with parallel jobs + +actions:gnu: + stage: tests + needs: [] + tags: + - 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 @@ -93,17 +186,19 @@ gnu.testing: script: - echo -e "\e[0Ksection_start:`date +%s`:compile[collapsed=true]\r\e[0KCompiling executables" - cd .testing - - module unload PrgEnv-pgi PrgEnv-intel PrgEnv-gnu darshan ; module load PrgEnv-gnu ; module unload netcdf gcc ; module load gcc/7.3.0 cray-hdf5 cray-netcdf - - make work/local-env - - make -s -j + - 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 '. ./work/local-env/bin/activate';echo 'make MPIRUN="srun -mblock --exclusive" test -s -j') > job.sh - - sbatch --clusters=c3,c4 --nodes=5 --time=0:05:00 --account=gfdl_o --qos=debug --job-name=MOM6.gnu.testing --output=log.$CI_PIPELINE_ID --wait job.sh && make test || cat log.$CI_PIPELINE_ID + - (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 + - make test.summary -intel.testing: - stage: run +actions:intel: + stage: tests + needs: [] tags: - - ncrc4 + - 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 @@ -111,104 +206,158 @@ intel.testing: script: - echo -e "\e[0Ksection_start:`date +%s`:compile[collapsed=true]\r\e[0KCompiling executables" - cd .testing - - module unload PrgEnv-pgi PrgEnv-intel PrgEnv-gnu darshan; module load PrgEnv-intel; module unload netcdf intel; module load intel/18.0.6.288 cray-hdf5 cray-netcdf - - make work/local-env - - make -s -j + - module unload darshan-runtime intel cray-mpich PrgEnv-intel ; module load PrgEnv-intel intel/2023.2.0 cray-hdf5 cray-netcdf cray-mpich ; module unload cray-libsci + - 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 '. ./work/local-env/bin/activate';echo 'make MPIRUN="srun -mblock --exclusive" test -s -j') > job.sh - - sbatch --clusters=c3,c4 --nodes=5 --time=0:05:00 --account=gfdl_o --qos=debug --job-name=MOM6.gnu.testing --output=log.$CI_PIPELINE_ID --wait job.sh && make test || cat log.$CI_PIPELINE_ID + - (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 + - make test.summary # Tests -gnu:non-symmetric: +# +# stats file tests involve comparing the check sums of the generated files against the check sums in the stats-repo +# log file tests involve comparing the check sums of the generated files against the check sums in MOM6-examples + +t:pgi:symmetric: + stage: tests + needs: ["run:pgi"] + tags: + - mom6-ci-c5 + script: + - .gitlab/pipeline-ci-tool.sh check-stats pgi S + +t:pgi:non-symmetric: + stage: tests + needs: ["run:pgi"] + tags: + - mom6-ci-c5 + script: + - .gitlab/pipeline-ci-tool.sh check-stats pgi N + +t:pgi:layout: stage: tests + needs: ["run:pgi"] tags: - - ncrc4 + - mom6-ci-c5 script: - - make -f tools/MRS/Makefile mom6-pipeline-test-gnu_non_symmetric + - .gitlab/pipeline-ci-tool.sh check-stats pgi L -gnu:symmetric: +t:pgi:params: stage: tests + needs: ["run:pgi"] tags: - - ncrc4 + - mom6-ci-c5 script: - - make -f tools/MRS/Makefile mom6-pipeline-test-gnu_symmetric + - .gitlab/pipeline-ci-tool.sh check-params pgi + allow_failure: true -gnu:memory: +t:intel:symmetric: stage: tests + needs: ["run:intel"] tags: - - ncrc4 + - mom6-ci-c5 script: - - make -f tools/MRS/Makefile mom6-pipeline-test-gnu_memory + - .gitlab/pipeline-ci-tool.sh check-stats intel S -gnu:static: +t:intel:non-symmetric: stage: tests + needs: ["run:intel"] tags: - - ncrc4 + - mom6-ci-c5 script: - - make -f tools/MRS/Makefile mom6-pipeline-test-gnu_static + - .gitlab/pipeline-ci-tool.sh check-stats intel N -gnu:restart: +t:intel:layout: stage: tests + needs: ["run:intel"] tags: - - ncrc4 + - mom6-ci-c5 script: - - make -f tools/MRS/Makefile mom6-pipeline-test-gnu_restarts + - .gitlab/pipeline-ci-tool.sh check-stats intel L -gnu:params: +t:intel:params: stage: tests + needs: ["run:intel"] tags: - - ncrc4 + - mom6-ci-c5 script: - - make -f tools/MRS/Makefile mom6-pipeline-test-params_gnu_symmetric + - .gitlab/pipeline-ci-tool.sh check-params intel allow_failure: true -intel:symmetric: +t:gnu:symmetric: + stage: tests + needs: ["run:gnu"] + tags: + - mom6-ci-c5 + script: + - .gitlab/pipeline-ci-tool.sh check-stats gnu S + +t:gnu:non-symmetric: stage: tests + needs: ["run:gnu"] tags: - - ncrc4 + - mom6-ci-c5 script: - - make -f tools/MRS/Makefile mom6-pipeline-test-intel_symmetric + - .gitlab/pipeline-ci-tool.sh check-stats gnu N -intel:non-symmetric: +t:gnu:layout: stage: tests + needs: ["run:gnu"] tags: - - ncrc4 + - mom6-ci-c5 script: - - make -f tools/MRS/Makefile mom6-pipeline-test-intel_non_symmetric + - .gitlab/pipeline-ci-tool.sh check-stats gnu L -intel:memory: +t:gnu:static: stage: tests + needs: ["run:gnu"] tags: - - ncrc4 + - mom6-ci-c5 script: - - make -f tools/MRS/Makefile mom6-pipeline-test-intel_memory + - .gitlab/pipeline-ci-tool.sh check-stats gnu T -pgi:symmetric: +t:gnu:symmetric-debug: stage: tests + needs: ["run:gnu"] tags: - - ncrc4 + - mom6-ci-c5 script: - - make -f tools/MRS/Makefile mom6-pipeline-test-pgi_symmetric + - .gitlab/pipeline-ci-tool.sh check-stats gnu D -pgi:non-symmetric: +t:gnu:restart: stage: tests + needs: ["run:gnu-restarts"] tags: - - ncrc4 + - mom6-ci-c5 script: - - make -f tools/MRS/Makefile mom6-pipeline-test-pgi_non_symmetric + - .gitlab/pipeline-ci-tool.sh check-stats gnu R -pgi:memory: +t:gnu:params: stage: tests + needs: ["run:gnu"] tags: - - ncrc4 + - mom6-ci-c5 script: - - make -f tools/MRS/Makefile mom6-pipeline-test-pgi_memory + - .gitlab/pipeline-ci-tool.sh check-params gnu + allow_failure: true + +t:gnu:diags: + stage: tests + needs: ["run:gnu"] + tags: + - mom6-ci-c5 + script: + - .gitlab/pipeline-ci-tool.sh check-diags gnu + allow_failure: true +# We cleanup ONLY if the preceding stages were completed successfully cleanup: stage: cleanup tags: - - ncrc4 + - mom6-ci-c5 before_script: - - echo Skipping submodule update + - echo Skipping usual preamble script: - - rm $CACHE_DIR/*$CI_PIPELINE_ID.tgz + - rm -rf $HOME/ci/$CI_PIPELINE_ID + - rm -rf $JOB_DIR diff --git a/.gitlab/README.md b/.gitlab/README.md new file mode 100644 index 0000000000..6e11900f9e --- /dev/null +++ b/.gitlab/README.md @@ -0,0 +1,148 @@ +# CI script pipeline-ci-tool.sh + +pipeline-ci-tool.sh contains functions corresponding to each job within the gitlab CI pipeline for MOM6 at GFDL, specifically on the gaea HPC. +Each function can be run by a parser function so that the functions can be invoked from the command line or a shell. +Some functions take arguments. +Encapsulating the job commands in a function allows us to develop/debug the pipeline by issuing the same, relatively short, commands at the command line. + +pipeline-ci-tool.sh relies on three environment variables to execute. They are mandatory. + - JOB_DIR is a scratch location that will be created and populated + - CI_PROJECT_DIR is normally set by gitlab and will point to the working directory where MOM6 is cloned + - CI_COMMIT_SHA is the commit of MOM6 to be tested + +To use pipeline-ci-tool.sh interactively from an existing MOM6 clone, you could use + `JOB_DIR=tmp CI_PROJECT_DIR=. CI_COMMIT_SHA=`git rev-parse HEAD` .gitlab/pipeline-ci-tool.sh ...` +This will use the HEAD commit in the current working dir and setup an independent test suite under tmp/. + +## Usage + `pipeline-ci-tool.sh FUNCTION [-x|+x] [-n|+n] [ARG1] [ARG2] [...]` + `pipeline-ci-tool.sh FUNCTION [-x|+x] [-n|+n] [ARG1] [ARG2] [[-x|+x] [-n|+n] FUNCTION [ARG1] [ARG2] [...]] [...]` + +FUNCTION can be one of + - `create-job-dir` : Create a "job directory" using the environment variable JOB_DIR. This is a where all the compilation and running takes place. + - `clean-job-dir` : Not used by .gitlab-ci.yml but useful for resetting an interactive session. + - `copy-test-space LABEL` : Within $JOB_DIR, clones MOM6-examples to tmp-MOM6-examples-LABEL to use as a workspace for tests + - `mrs-compile TARGET` : Invokes tools/MRS/Makefile.build to build MODE_VENDER. VENDER can be gnu, intel, or pgi. MODE can be repro, debug, static, etc. + - `nolibs-ocean-only-compile VENDER` : Compiles the "no libraries" executables. These are not used elsewhere in the CI but check we have no namespace problems. VENDER can be gnu, intel, or pgi. + - `run-suite VENDER CODE` : runs subsets of the MOM6-examples according to CODE using the VENDER executables. CODE is a string of the characters S (symmetric), N (non-symmetric), L (layout), D (debug), or R (restart), and if present executes the corresponding tests. + - `check-stats VENDER CODE` : check the stats files for the corresponding VENDOR/CODE resulting from run-suite + - `check-params VENDER CODE` : check the parameter documentation files for the corresponding VENDOR/CODE resulting from run-suite + - `check-diags VENDER CODE` : check the available diagnostics files for the corresponding VENDOR/CODE resulting from run-suite + +Options: + - `-x` : shows commands as they are executed. `+x` turns back to silent executions. You can precede each function as needed so that only commands from selected functions are shown. + - `-n` : for many function, disables all functionality and simply prints the banner that each sections was reached. `+n` turns the functions back on. + +## Correspondance to jobs in .gitlab-ci.yml + +The .gitlab-ci.yml jobs names and pipeline-ci-tool.sh commands are: + + clone: + `pipeline-ci-tool.sh create-job-dir` + + work-space:pgi: + `pipeline-ci-tool.sh copy-test-space pgi` + + work-space:intel: + `pipeline-ci-tool.sh copy-test-space intel` + + work-space:gnu: + `pipeline-ci-tool.sh copy-test-space gnu` + + work-space:gnu-restarts: + `pipeline-ci-tool.sh copy-test-space gnu-rst` + + compile:pgi:repro: + `pipeline-ci-tool.sh mrs-compile repro_pgi` + + compile:intel:repro: + `pipeline-ci-tool.sh mrs-compile repro_intel` + + compile:gnu:repro: + `pipeline-ci-tool.sh mrs-compile repro_gnu mrs-compile static_gnu` + + compile:gnu:debug: + `pipeline-ci-tool.sh mrs-compile debug_gnu` + + compile:gnu:ocean-only-nolibs: + `pipeline-ci-tool.sh nolibs-ocean-only-compile gnu` + + compile:gnu:ice-ocean-nolibs: + `pipeline-ci-tool.sh nolibs-ocean-ice-compile gnu` + + run:pgi: + `pipeline-ci-tool.sh run-suite pgi SNL` + + run:intel: + `pipeline-ci-tool.sh run-suite intel SNL` + + run:gnu: + `pipeline-ci-tool.sh run-suite gnu SNLD` + + run:gnu-restarts: + `pipeline-ci-tool.sh run-suite gnu R` + + t:pgi:symmetric: + `pipeline-ci-tool.sh check-stats pgi S` + + t:pgi:non-symmetric: + `pipeline-ci-tool.sh check-stats pgi N` + + t:pgi:layout: + `pipeline-ci-tool.sh check-stats pgi L` + + t:pgi:params: + `pipeline-ci-tool.sh check-params pgi S` + + t:intel:symmetric: + `pipeline-ci-tool.sh check-stats intel S` + + t:intel:non-symmetric: + `pipeline-ci-tool.sh check-stats intel N` + + t:intel:layout: + `pipeline-ci-tool.sh check-stats intel L` + + t:intel:params: + `pipeline-ci-tool.sh check-params intel S` + + t:gnu:symmetric: + `pipeline-ci-tool.sh check-stats gnu S` + + t:gnu:non-symmetric: + `pipeline-ci-tool.sh check-stats gnu N` + + t:gnu:layout: + `pipeline-ci-tool.sh check-stats gnu L` + + t:gnu:static: + `pipeline-ci-tool.sh check-stats gnu T` + + t:gnu:symmetric-debug: + `pipeline-ci-tool.sh check-stats gnu D` + + t:gnu:restart: + `pipeline-ci-tool.sh check-stats gnu R` + + t:gnu:params: + `pipeline-ci-tool.sh check-params gnu S` + + t:gnu:diags: + `pipeline-ci-tool.sh check-diags gnu S` + +### Duplicating the pipeline interactively + +You can run a sequence of commands as follows. The setup and compile phases of the CI pipeline can be summarized with +``` +pipeline-ci-tool.sh create-job-dir copy-test-space pgi copy-test-space intel copy-test-space gnu copy-test-space gnu-rst mrs-compile repro_pgi mrs-compile repro_intel mrs-compile repro_gnu mrs-compile static_gnu mrs-compile debug_gnu nolibs-ocean-only-compile gnu nolibs-ocean-ice-compile gnu +``` + +The run stage (works on compute nodes only) can be summarized with: +``` +pipeline-ci-tool.sh run-suite pgi SNL run-suite intel SNL run-suite gnu SNLDT run-suite gnu R +``` + +The test stage is summarized by: +``` +pipeline-ci-tool.sh check-stats pgi S check-stats pgi N check-stats pgi L check-params pgi S check-stats intel S check-stats intel N check-stats intel L check-params intel S check-stats gnu S check-stats gnu N check-stats gnu L check-stats gnu T check-stats gnu D check-stats gnu R check-params gnu S check-diags gnu S +``` diff --git a/.gitlab/mom6-ci-run-gnu-restarts-script.sh b/.gitlab/mom6-ci-run-gnu-restarts-script.sh new file mode 100644 index 0000000000..104dc40567 --- /dev/null +++ b/.gitlab/mom6-ci-run-gnu-restarts-script.sh @@ -0,0 +1,50 @@ +#!/bin/bash +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + +sect=none +clean_stats () { # fn to clean up stats files + find [oicl]* -name "*.stats.*[a-z][a-z][a-z]" -delete +} +section_start () { # fn to print fold-able banner in CI + echo -e "\e[0Ksection_start:`date +%s`:$1[collapsed=true]\r\e[0K$2" + sect=$1 +} +section_end () { # fn to close fold-able banner in CI and clean up stats + echo -e "\e[0Ksection_end:`date +%s`:$sect\r\e[0K" + clean_stats +} +check_for_core_files () { + EXIT_CODE=0 + find [oilc]* -name core | grep . && EXIT_CODE=1 + if [[ $EXIT_CODE -gt 0 ]] + then + echo "Error: core files found!" + exit 911 + fi +} + +# Make sure we have a clean start +clean_stats +find [oilc]* -name core -delete +rm -f .CI-GNU-RESTARTS-BATCH-SUCCESS + +set -e +set -v + +# Run symmetric gnu restart tests +section_start gnu_restarts "Running symmetric gnu restart tests" +time make -f tools/MRS/Makefile.restart gnu_ocean_only -s -j RESTART_STAGE=01 +time make -f tools/MRS/Makefile.restart gnu_ice_ocean_SIS2 -s -j RESTART_STAGE=01 +time make -f tools/MRS/Makefile.restart gnu_ocean_only -s -j RESTART_STAGE=02 +time make -f tools/MRS/Makefile.restart gnu_ice_ocean_SIS2 -s -j RESTART_STAGE=02 +time make -f tools/MRS/Makefile.restart gnu_ocean_only -s -j RESTART_STAGE=12 +time make -f tools/MRS/Makefile.restart gnu_ice_ocean_SIS2 -s -j RESTART_STAGE=12 +tar cf - `find [oilc]*/ -path "*/??.ignore/*" -name "ocean.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/gnu_restarts -xf - +check_for_core_files +find [oilc]* -name "*.ignore" -type d -prune -exec rm -rf {} \; +section_end + +# Indicate all went well +touch .CI-GNU-RESTARTS-BATCH-SUCCESS diff --git a/.gitlab/mom6-ci-run-gnu-script.sh b/.gitlab/mom6-ci-run-gnu-script.sh new file mode 100644 index 0000000000..13dfe00111 --- /dev/null +++ b/.gitlab/mom6-ci-run-gnu-script.sh @@ -0,0 +1,74 @@ +#!/bin/bash +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + +sect=none +clean_stats () { # fn to clean up stats files + find [oicl]* -name "*.stats.*[a-z][a-z][a-z]" -delete +} +section_start () { # fn to print fold-able banner in CI + echo -e "\e[0Ksection_start:`date +%s`:$1[collapsed=true]\r\e[0K$2" + sect=$1 +} +section_end () { # fn to close fold-able banner in CI and clean up stats + echo -e "\e[0Ksection_end:`date +%s`:$sect\r\e[0K" + clean_stats +} +check_for_core_files () { + EXIT_CODE=0 + find [oilc]* -name core | grep . && EXIT_CODE=1 + if [[ $EXIT_CODE -gt 0 ]] + then + echo "Error: core files found!" + exit 911 + fi +} + +# Make sure we have a clean start +clean_stats +find [oilc]* -name core -delete +rm -f .CI-GNU-BATCH-SUCCESS + +set -e +set -v + +# Run symmetric gnu regressions +section_start gnu_all_sym "Running symmetric gnu" +time make -f tools/MRS/Makefile.run gnu_all -s -j +tar cf - `find [oicl]* -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/gnu_all_sym -xf - +tar cf - `find [oicl]* -name "*_parameter_doc.*" -o -name "*available_diags*"` | tar --one-top-level=results/gnu_params -xf - +check_for_core_files +section_end + +# Run non-symmetric gnu regressions +section_start gnu_all_nonsym "Running nonsymmetric gnu" +time make -f tools/MRS/Makefile.run ocean_only/circle_obcs/ocean.stats.gnu +time make -f tools/MRS/Makefile.run gnu_all -s -j MEMORY=dynamic_nonsymmetric +tar cf - `find [oicl]* -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/gnu_all_nonsym -xf - +check_for_core_files +section_end + +# Run symmetric gnu regressions with alternate layout +section_start gnu_all_layout "Running symmetric gnu with alternate layouts" +time make -f tools/MRS/Makefile.run gnu_all -s -j LAYOUT=alt +tar cf - `find [oicl]* -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/gnu_all_layout -xf - +check_for_core_files +section_end + +# Run symmetric gnu regressions with debug executable +section_start gnu_ocean_only_debug "Running symmetric gnu_ocean_only with debug executable" +time make -f tools/MRS/Makefile.run gnu_ocean_only -s -j MODE=debug +tar cf - `find [oicl]* -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/gnu_ocean_only_debug -xf - +check_for_core_files +section_end + +# Run symmetric static gnu regressions +section_start gnu_all_static "Running symmetric gnu with static executable" +time make -f tools/MRS/Makefile.run gnu_static_ocean_only MEMORY=static -s -j +tar cf - `find [oicl]* -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/gnu_all_static -xf - +check_for_core_files +section_end + +# Indicate all went well +touch .CI-GNU-BATCH-SUCCESS diff --git a/.gitlab/mom6-ci-run-intel-script.sh b/.gitlab/mom6-ci-run-intel-script.sh new file mode 100644 index 0000000000..01a2888e80 --- /dev/null +++ b/.gitlab/mom6-ci-run-intel-script.sh @@ -0,0 +1,60 @@ +#!/bin/bash +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + +sect=none +clean_stats () { # fn to clean up stats files + find [oicl]* -name "*.stats.*[a-z][a-z][a-z]" -delete +} +section_start () { # fn to print fold-able banner in CI + echo -e "\e[0Ksection_start:`date +%s`:$1[collapsed=true]\r\e[0K$2" + sect=$1 +} +section_end () { # fn to close fold-able banner in CI and clean up stats + echo -e "\e[0Ksection_end:`date +%s`:$sect\r\e[0K" + clean_stats +} +check_for_core_files () { + EXIT_CODE=0 + find [oilc]* -name core | grep . && EXIT_CODE=1 + if [[ $EXIT_CODE -gt 0 ]] + then + echo "Error: core files found!" + exit 911 + fi +} + +# Make sure we have a clean start +clean_stats +find [oilc]* -name core -delete +rm -f .CI-INTEL-BATCH-SUCCESS + +set -e +set -v + +# Run symmetric intel regressions +section_start intel_all_sym "Running symmetric intel" +time make -f tools/MRS/Makefile.run intel_all -s -j +tar cf - `find [oicl]* -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/intel_all_sym -xf - +tar cf - `find [oicl]* -name "*_parameter_doc.*" -o -name "*available_diags*"` | tar --one-top-level=results/intel_params -xf - +check_for_core_files +section_end + +# Run non-symmetric intel regressions +section_start intel_all_nonsym "Running nonsymmetric intel" +time make -f tools/MRS/Makefile.run ocean_only/circle_obcs/ocean.stats.intel -s +time make -f tools/MRS/Makefile.run intel_all -s -j MEMORY=dynamic_nonsymmetric +tar cf - `find [oicl]* -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/intel_all_nonsym -xf - +check_for_core_files +section_end + +# Run symmetric intel regressions with alternate layout +section_start intel_all_layout "Running symmetric intel with alternate layouts" +time make -f tools/MRS/Makefile.run intel_all -s -j LAYOUT=alt +tar cf - `find [oicl]* -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/intel_all_layout -xf - +check_for_core_files +section_end + +# Indicate all went well +touch .CI-INTEL-BATCH-SUCCESS diff --git a/.gitlab/mom6-ci-run-pgi-script.sh b/.gitlab/mom6-ci-run-pgi-script.sh new file mode 100644 index 0000000000..4e55b5ced8 --- /dev/null +++ b/.gitlab/mom6-ci-run-pgi-script.sh @@ -0,0 +1,60 @@ +#!/bin/bash +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + +sect=none +clean_stats () { # fn to clean up stats files + find [oicl]* -name "*.stats.*[a-z][a-z][a-z]" -delete +} +section_start () { # fn to print fold-able banner in CI + echo -e "\e[0Ksection_start:`date +%s`:$1[collapsed=true]\r\e[0K$2" + sect=$1 +} +section_end () { # fn to close fold-able banner in CI and clean up stats + echo -e "\e[0Ksection_end:`date +%s`:$sect\r\e[0K" + clean_stats +} +check_for_core_files () { + EXIT_CODE=0 + find [oilc]* -name core | grep . && EXIT_CODE=1 + if [[ $EXIT_CODE -gt 0 ]] + then + echo "Error: core files found!" + exit 911 + fi +} + +# Make sure we have a clean start +clean_stats +find [oilc]* -name core -delete +rm -f .CI-PGI-BATCH-SUCCESS + +set -e +set -v + +# Run symmetric pgi regressions +section_start pgi_all_sym "Running symmetric pgi" +time make -f tools/MRS/Makefile.run pgi_all -s -j +tar cf - `find [oicl]* -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/pgi_all_sym -xf - +tar cf - `find [oicl]* -name "*_parameter_doc.*" -o -name "*available_diags*"` | tar --one-top-level=results/pgi_params -xf - +check_for_core_files +section_end + +# Run non-symmetric pgi regressions +section_start pgi_all_nonsym "Running nonsymmetric pgi" +time make -f tools/MRS/Makefile.run ocean_only/circle_obcs/ocean.stats.pgi -s +time make -f tools/MRS/Makefile.run pgi_all -s -j MEMORY=dynamic_nonsymmetric +tar cf - `find [oicl]* -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/pgi_all_nonsym -xf - +check_for_core_files +section_end + +# Run symmetric pgi regressions with alternate layout +section_start pgi_all_layout "Running symmetric pgi with alternate layouts" +time make -f tools/MRS/Makefile.run gnu_all -s -j LAYOUT=alt +tar cf - `find [oicl]* -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/pgi_all_layout -xf - +check_for_core_files +section_end + +# Indicate all went well +touch .CI-PGI-BATCH-SUCCESS diff --git a/.gitlab/pipeline-ci-tool.sh b/.gitlab/pipeline-ci-tool.sh new file mode 100755 index 0000000000..018e0e3a08 --- /dev/null +++ b/.gitlab/pipeline-ci-tool.sh @@ -0,0 +1,463 @@ +#!/bin/bash +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + +# Environment variables set by gitlab (the CI environment) +if [ -z $JOB_DIR ]; then + echo Environment variable "$"JOB_DIR should be defined to point to a unique directory for these scripts to use. + echo '$JOB_DIR is derived from $CI_PIPELINE_ID in MOM6/.gitlab-ci.yml' + echo 'To use interactively try:' + echo ' JOB_DIR=tmp' $0 $@ + exit 911 +fi +if [ -z $CI_PROJECT_DIR ]; then + echo Environment variable "$"CI_PROJECT_DIR should be defined and point to where gitlab has cloned the MOM6 repository for this pipeline. + echo 'To use interactively try:' + echo ' CI_PROJECT_DIR=.' $0 $@ + exit 911 +else + CI_PROJECT_DIR=`realpath $CI_PROJECT_DIR` +fi +if [ -z $CI_COMMIT_SHA ]; then + echo Environment variable "$"CI_COMMIT_SHA should be defined and indicate the MOM6 commit to used in this pipeline. + echo 'To use interactively try:' + echo ' CI_COMMIT_SHA=`git rev-parse HEAD`' $0 $@ + exit 911 +fi + +# Use CI=true to enable the gitlab folding + +set -e # Stop if we encounter an error + +# Environment variables that can be set outside +STATS_REPO_URL="${STATS_REPO_URL:-https://gitlab.gfdl.noaa.gov/ogrp/Gaea-stats-MOM6-examples.git}" +STATS_REPO_BRANCH="${STATS_REPO_BRANCH:-dev/gfdl}" +CONFIGS_DIR="${CONFIGS_DIR:-MOM6-examples}" +CONFIGS_REPO_BRANCH="${CONFIGS_REPO_BRANCH:-$STATS_REPO_BRANCH}" + +# Global variables derived from the above +DRYRUN= +STATS_REPO=$(basename $STATS_REPO_URL) +STATS_REPO_DIR=$(basename $STATS_REPO .git) + +# Static variables +RED=$'\033[1;31m' +GRN=$'\033[1;32m' +OFF=$'\e[m' + +# Print the start of a fold in the log +section-start () { + echo -e "\e[0Ksection_start:`date +%s`:$1[collapsed=true]\r\e[0K$2" +} + +# Print the start of a fold in the log but not collapsed +section-start-open () { + echo -e "\e[0Ksection_start:`date +%s`:$1[collapsed=false]\r\e[0K$2" +} + +# Print the end of a fold in the log +section-end () { + echo -e "\e[0Ksection_end:`date +%s`:$1\r\e[0K" +} + +# Create $JOB_DIR and clean out any prior work-spaces +# Location: run in MOM6 directory +clean-job-dir () { + section-start clean-job-dir "Cleaning $JOB_DIR directory" + if [ ! $DRYRUN ] ; then + #NOT USED? cd $CI_PROJECT_DIR + #NOT USED? git submodule init ; git submodule update + echo Job directory set to $JOB_DIR + mkdir -p $JOB_DIR + cd $JOB_DIR + test -d $STATS_REPO_DIR && rm -rf $STATS_REPO_DIR # In case we are re-running this stage + fi + section-end clean-job-dir +} + +# Create the full work space starting at the regression repository (usually Gaea-stats-MOM6-examples) +# Location: run in MOM6 directory +create-job-dir () { + section-start create-job-dir "Creating and populating $JOB_DIR" + if [ ! $DRYRUN ] ; then + mkdir -p $JOB_DIR + cd $JOB_DIR + git clone $STATS_REPO_URL $STATS_REPO_DIR + cd $STATS_REPO_DIR + git checkout $STATS_REPO_BRANCH + git submodule update --init + cd $CONFIGS_DIR + git checkout $CONFIGS_REPO_BRANCH + git submodule init + git submodule set-url src/MOM6 $CI_PROJECT_DIR/.git + git submodule update --recursive --jobs 8 + (cd src/MOM6 ; git checkout $CI_COMMIT_SHA) # Get commit to be tested + (cd src/MOM6 ; git submodule update --recursive --init) + make -f tools/MRS/Makefile.clone clone_gfdl -j # Extras and link to datasets + bash tools/MRS/generate_manifest.sh . tools/MRS/excluded-expts.txt > manifest.mk + mkdir -p results + # Temporarily move build directory to $HOME to circumvent poor F5 performance + mkdir -p $HOME/ci/$CI_PIPELINE_ID/build + ln -s $HOME/ci/$CI_PIPELINE_ID/build build + # Builds need non-mangled access to src/. + ln -s "$(pwd)"/src $HOME/ci/$CI_PIPELINE_ID/src + # Static builds need access to ocean_only/ + ln -s "$(pwd)"/ocean_only $HOME/ci/$CI_PIPELINE_ID/ocean_only + fi + section-end create-job-dir +} + +# Create a copy of the configurations working directory +# Location: run in MOM6 directory +copy-test-space () { + if [ -z $1 ]; then echo "copy-test-space needs an argument" ; exit 911 ; fi + section-start copy-test-space-$1 "Copying $CONFIGS_DIR for $1" + if [ ! $DRYRUN ] ; then + COPIED_DIR=tmp-$CONFIGS_DIR-$1 + cd $JOB_DIR/$STATS_REPO_DIR + git clone -s $CONFIGS_DIR/.git $COPIED_DIR + cd $COPIED_DIR + ln -s ../$CONFIGS_DIR/{build,results,.datasets} . + cp ../$CONFIGS_DIR/manifest.mk . + fi + section-end copy-test-space-$1 +} + +# Build a group of executables using the tools/MRS/Makefile.build template +# Location: run in MOM6 directory +mrs-compile () { + if [ -z $1 ]; then echo "mrs-compile needs an argument" ; exit 911 ; fi + section-start mrs-compile-$1 "Compiling target $1" + if [ ! $DRYRUN ] ; then + cd $JOB_DIR/$STATS_REPO_DIR/$CONFIGS_DIR + time make -f tools/MRS/Makefile.build $1 -s -j + fi + section-end mrs-compile-$1 +} + +# Build an ocean-only executable without intermediate libraries +# Location: run in MOM6 directory +nolibs-ocean-only-compile () { + if [ -z $1 ]; then echo "nolibs-ocean-only-compile needs an argument" ; exit 911 ; fi + section-start nolibs-ocean-only-compile-$1 "Compiling ocean-only $1 executable" + if [ ! $DRYRUN ] ; then + cd $JOB_DIR/$STATS_REPO_DIR/$CONFIGS_DIR + mkdir -p build-ocean-only-nolibs-$1 + cd build-ocean-only-nolibs-$1 + make -f ../tools/MRS/Makefile.build ./$1/env BUILD=. ENVIRON=../../environ -s + ../src/mkmf/bin/list_paths -l ../src/MOM6/config_src/{drivers/solo_driver,memory/dynamic_symmetric,infra/FMS1,ext*} ../src/MOM6/src ../src/FMS1 + sed -i '/FMS1\/.*\/test_/d' path_names + ../src/mkmf/bin/mkmf -t ../src/mkmf/templates/ncrc5-$1.mk -p MOM6 -c"-Duse_libMPI -Duse_netCDF" path_names + (source $1/env ; make NETCDF=3 REPRO=1 MOM6 -s -j) + fi + section-end nolibs-ocean-only-compile-$1 +} + +# Build an ocean-ice executable without intermediate libraries +# Location: run in MOM6 directory +nolibs-ocean-ice-compile () { + if [ -z $1 ]; then echo "nolibs-ocean-ice-compile needs an argument" ; exit 911 ; fi + section-start nolibs-ocean-ice-compile-$1 "Compiling ocean-ice $1 executable" + if [ ! $DRYRUN ] ; then + cd $JOB_DIR/$STATS_REPO_DIR/$CONFIGS_DIR + mkdir -p build-ocean-ice-nolibs-$1 + cd build-ocean-ice-nolibs-$1 + make -f ../tools/MRS/Makefile.build ./$1/env BUILD=. ENVIRON=../../environ -s + ../src/mkmf/bin/list_paths -l \ + ../src/MOM6/config_src/{drivers/FMS_cap,memory/dynamic_symmetric,infra/FMS1,ext*} \ + ../src/MOM6/src \ + ../src/SIS2/src \ + ../src/SIS2/config_src/dynamic_symmetric \ + ../src/SIS2/config_src/external/Icepack_interfaces \ + ../src/icebergs/src \ + ../src/{FMS1,coupler,ice_param,land_null,atmos_null} + sed -i '/FMS1\/.*\/test_/d' path_names + ../src/mkmf/bin/mkmf -t ../src/mkmf/templates/ncrc5-$1.mk -p MOM6 -c"-Duse_libMPI -Duse_netCDF -D_USE_LEGACY_LAND_ -Duse_AM3_physics" path_names + (source $1/env ; make NETCDF=3 REPRO=1 MOM6 -s -j) + fi + section-end nolibs-ocean-ice-compile-$1 +} + +# Internal function to clean up stats files +# Args: list of top level directories to scan +clean-stats () { + find $@ -name "*.stats.*[a-z][a-z][a-z]" -delete +} + +# Internal function to clean up param files +# Args: list of top level directories to scan +clean-params () { + find $@ -name "*_parameter_doc.*" -delete + find $@ -name "*available_diags*" -delete +} + +# Internal function to check for core files +# Args: list of top level directories to scan +check-for-core-files () { + EXIT_CODE=0 + find $@ -name core -type f | grep . && EXIT_CODE=1 + if [[ $EXIT_CODE -gt 0 ]] + then + echo "Error: core files found!" + exit 911 + fi +} + +# Internal function to clean up core files (needed for re-running) +# Args: list of top level directories to scan +clean-core-files () { + find $@ -name core -type f -delete +} + +# Internal function to run a sub-suite and copy results to storage +# Args: +# $1 is compiler (gnu, intel, pgi, ...) +# $2 is sub-suite (_all, _ocean_only, _static_ocean_only, ...) +# $3 is MEMORY macro (dynamic_symmetric, dynamic_nonsymmetric, static) +# $4 is MODE macro (repro, debug) +# $5 is LAYOUT macro (def, alt) +mrs-run-sub-suite () { + if [ "$#" -ne 5 ]; then echo "mrs-run-sub-suite needs 5 arguments" ; exit 911 ; fi + section-start mrs-run-sub-suite-$1-$2-$3-$4-$5 "Running target $1-$2-$3-$4-$5" + EXP_GROUPS=`grep / manifest.mk | sed 's:/.*::' | uniq` + clean-stats $EXP_GROUPS + clean-params $EXP_GROUPS + clean-core-files $EXP_GROUPS + if [[ "$3" == *"_nonsym"* ]]; then + set -e + time make -f tools/MRS/Makefile.run ocean_only/circle_obcs/ocean.stats.$1 MEMORY=${3/_nonsym/_sym} MODE=$4 LAYOUT=$5 -s -j + fi + set -e + time make -f tools/MRS/Makefile.run $1_$2 MEMORY=$3 MODE=$4 LAYOUT=$5 -s -j + tar cf - `find $EXP_GROUPS -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/$1-$2-$3-$4-$5-stats -xf - + tar cf - `find $EXP_GROUPS -name "*_parameter_doc.*" -o -name "*available_diags*"` | tar --one-top-level=results/$1-$2-$3-$4-$5-params -xf - + check-for-core-files $EXP_GROUPS + section-end mrs-run-sub-suite-$1-$2-$3-$4-$5 +} + +# Internal function to run restarts on a sub-suite and copy results to storage +# Args: +# $1 is compiler (gnu, intel, pgi, ...) +# $2 is sub-suite (_all, _ocean_only, _static_ocean_only, ...) +# $3 is MEMORY macro (dynamic_symmetric, dynamic_nonsymmetric, static) +# $4 is MODE macro (repro, debug) +# $5 is LAYOUT macro (def, alt) +mrs-run-restarts-sub-suite () { + if [ "$#" -ne 5 ]; then echo "mrs-run-restarts-sub-suite needs 5 arguments" ; exit 911 ; fi + section-start mrs-run-restarts-sub-suite-$1-$2-$3-$4-$5 "Running target $1-$2-$3-$4-$5" + clean-stats $2 + clean-core-files $2 + time make -f tools/MRS/Makefile.restart $1_$2 MEMORY=$3 MODE=$4 LAYOUT=$5 -s -j RESTART_STAGE=01 + check-for-core-files $2 + time make -f tools/MRS/Makefile.restart $1_$2 MEMORY=$3 MODE=$4 LAYOUT=$5 -s -j RESTART_STAGE=02 + check-for-core-files $2 + time make -f tools/MRS/Makefile.restart $1_$2 MEMORY=$3 MODE=$4 LAYOUT=$5 -s -j RESTART_STAGE=12 + check-for-core-files $2 + section-end mrs-run-restarts-sub-suite-$1-$2-$3-$4-$5 +} + +# Run a suite of experiments +# $1 - compiler brand +# $2 - any combination of "SNLDTR" +# S = symmetric +# N = non-symmetric +# L = layout +# D = debug +# R = restarts +run-suite () { + if [ "$#" -ne 2 ]; then echo "run-suite needs 2 arguments" ; exit 911 ; fi + section-start run-suite-$1-$2 "Running suite for $1-$2" + WORK_DIR=tmp-$CONFIGS_DIR-$1 + rm -f $JOB_DIR/CI-BATCH-SUCCESS-$1-$2 + set -e + set -v + + pushd $JOB_DIR/$STATS_REPO_DIR/$WORK_DIR > /dev/null + if [[ "$2" =~ "S" ]]; then # Symmetric + mrs-run-sub-suite $1 all dynamic_symmetric repro def + fi + if [[ "$2" =~ "N" ]]; then # Non-symmetric + mrs-run-sub-suite $1 all dynamic_nonsymmetric repro def + fi + if [[ "$2" =~ "L" ]]; then # Layout + mrs-run-sub-suite $1 all dynamic_symmetric repro alt + fi + if [[ "$2" =~ "D" ]]; then # Debug + mrs-run-sub-suite $1 ocean_only dynamic_symmetric debug def + fi + if [[ "$2" =~ "T" ]]; then # sTatic + mrs-run-sub-suite $1 static_ocean_only static repro def + fi + popd > /dev/null + if [[ "$2" =~ "R" ]]; then # Restarts + pushd $JOB_DIR/$STATS_REPO_DIR/$WORK_DIR-rst > /dev/null + mrs-run-restarts-sub-suite $1 ocean_only dynamic_symmetric repro def + mrs-run-restarts-sub-suite $1 ice_ocean_SIS2 dynamic_symmetric repro def + popd > /dev/null + fi + + # Indicate all went well + touch $JOB_DIR/CI-BATCH-SUCCESS-$1-$2 + + section-end run-suite-$1-$2 +} + +# Test the value of stats files. All files in results/ are checked for in regressions/. It is assumed +# missing files are intended and failed runs were caught earlier in the CI process. +# Args: +# $1 is path of results to test (relative to $STATS_REPO_DIR) +# $2 is path of correct results to test against (relative to $STATS_REPO_DIR) +compare-stats () { + if [ "$#" -ne 2 ]; then echo "compare-stats needs 2 arguments" ; exit 911 ; fi + section-start-open compare-stats-$1-$2-$3-$4-$5 "Checking stats for '$1' against '$2'" + # This checks that any file in the results directory is exactly the same as in regressions/ + ( cd $JOB_DIR/$STATS_REPO_DIR/$1 ; md5sum `find * -type f` ) | ( cd $JOB_DIR/$STATS_REPO_DIR/$2 ; md5sum -c ) 2>&1 | sed "s/ OK/$GRN&$OFF/;s/ FAILED/$RED&$OFF/;s/WARNING/$RED&$OFF/" + FAIL=${PIPESTATUS[1]} + if [ ! $FAIL == 0 ]; then + exit 911 + fi + section-end compare-stats-$1-$2-$3-$4-$5 +} + +# Test the value of stats files for a class of run +# $1 - compiler brand +# $2 - any combination of "SNLDTR" +# S = symmetric +# N = non-symmetric +# L = layout +# D = debug +# T = static +# R = restarts +# +# Many tests are tested against the "dynamic_symmetric repro" suite which must also have been run. +# The "dynamic_symmetric repro" tests alone are checked against the regressions. This is so that +# the pipelines might separate errors that are internally inconsistent. +check-stats () { + if [ "$#" -ne 2 ]; then echo "check-stats needs 2 arguments" ; exit 911 ; fi + + if [[ "$2" =~ "S" ]]; then # Symmetric + compare-stats $CONFIGS_DIR/results/$1-all-dynamic_symmetric-repro-def-stats regressions + fi + if [[ "$2" =~ "N" ]]; then # Non-symmetric + compare-stats $CONFIGS_DIR/results/$1-all-dynamic_nonsymmetric-repro-def-stats $CONFIGS_DIR/results/$1-all-dynamic_symmetric-repro-def-stats + fi + if [[ "$2" =~ "L" ]]; then # Layout + compare-stats $CONFIGS_DIR/results/$1-all-dynamic_symmetric-repro-alt-stats $CONFIGS_DIR/results/$1-all-dynamic_symmetric-repro-def-stats + fi + if [[ "$2" =~ "D" ]]; then # Debug + compare-stats $CONFIGS_DIR/results/$1-ocean_only-dynamic_symmetric-debug-def-stats $CONFIGS_DIR/results/$1-all-dynamic_symmetric-repro-def-stats + fi + if [[ "$2" =~ "T" ]]; then # sTatic + compare-stats $CONFIGS_DIR/results/$1-static_ocean_only-static-repro-def-stats $CONFIGS_DIR/results/$1-all-dynamic_symmetric-repro-def-stats + fi + if [[ "$2" =~ "R" ]]; then # Restarts + pushd $JOB_DIR/$STATS_REPO_DIR/tmp-$CONFIGS_DIR-$1-rst > /dev/null + make -f tools/MRS/Makefile.restart restart_$1_ocean_only restart_$1_ice_ocean_SIS2 -s -k + popd > /dev/null + fi + +} + +# Helper function to compare two files +# Args: +# $1 is source directory +# $2 is target directory +# $3- are file names that should exist relative to both $1 and $2 +# +# Operations for `compare-files src/ tgt/ file1 file2 file3`: +# 1. create the md5sum of file1, file2, and file3, in src/ and then run `md5sum-c` in tgt/ +# 2. if differences are detected, +# a. report the "OK" results first, then the "FAILED". +# b. report the "FAILED". +# c. for each failed file, show the `diff src/$f tgt/$f` +# 3. if no differences are detected, show `md5sum -c` output so the log lists all files that were checked +compare-files () { + SRC=$1 + TGT=$2 + shift; shift + FILES=$@ + ( cd $SRC ; md5sum $FILES ) | ( cd $TGT ; md5sum -c ) | sed -r "s/([A-Za-z0-9_\.\/\-]*): ([A-Z]*)/\2 \1/;s/OK /${GRN}PASS$OFF /;s/FAILED /${RED}FAILED$OFF /" + FAIL=${PIPESTATUS[1]} + if [ ! $FAIL == 0 ]; then + echo Differences follow: + # All is not well so re-order md5sum to summarize status + DFILES=$( ( cd $SRC ; md5sum $FILES ) | ( cd $TGT ; md5sum -c 2> /dev/null ) | grep ": FAILED" | sed 's/:.*//') + for f in $DFILES; do + echo diff $SRC/$f $TGT/$f | sed "s:$JOB_DIR/$STATS_REPO_DIR/::g;s:$CONFIGS_DIR/results/::" + diff $SRC/$f $TGT/$f || true + done + echo Files $DFILES had differences + exit 911 + fi +} + +# Test the value of param files. All files generated in results/ are looked for $CONFIGS_DIR +# Args: +# $1 is compiler (gnu, intel, pgi, ...) +check-params () { + if [ "$#" -ne 1 ]; then echo "check-params needs 1 argument" ; exit 911 ; fi + section-start-open check-params-$1 "Checking params for $1" + SRC=$JOB_DIR/$STATS_REPO_DIR/$CONFIGS_DIR/results/$1-all-dynamic_symmetric-repro-def-params + FILES=$( cd $SRC ; find * -name "*parameter_doc*" -type f ) + compare-files $SRC $JOB_DIR/$STATS_REPO_DIR/$CONFIGS_DIR $FILES + section-end check-params-$1 +} + +# Test the value of available_diag files. Only those recorded in $CONFIGS_DIR are checked. +# Args: +# $1 is compiler (gnu, intel, pgi, ...) +check-diags () { + if [ "$#" -ne 1 ]; then echo "check-diags needs 1 argument" ; exit 911 ; fi + section-start-open check-diags-$1 "Checking diagnostics for $1" + # This checks that any file in the results directory is exactly the same as in regressions/ + SRC=$JOB_DIR/$STATS_REPO_DIR/$CONFIGS_DIR/results/$1-all-dynamic_symmetric-repro-def-params + TGT=$JOB_DIR/$STATS_REPO_DIR/$CONFIGS_DIR + EXP_GROUPS=`grep / $TGT/manifest.mk | sed 's:/.*::' | uniq` + #FILES=$( cd $TGT ; find $EXP_GROUPS -name "*available_diags*" -type f ) + # The following option finds the intersection between all available_diags in both $TGT and $SRC because + # $SRC contains more than are recorded in $TGT but $TGT might have some that we no longer monitor + FILES=$( comm -12 <(cd $SRC; find $EXP_GROUPS -name '*available_diags*' -type f | sort) <(cd $TGT; find $EXP_GROUPS -name '*available_diags*' -type f | sort) ) + compare-files $SRC $TGT $FILES + section-end check-diags-$1 +} + +# Process command line +START_DIR=`pwd` +while [[ $# -gt 0 ]]; do # Loop through arguments + cd $START_DIR + arg=$1 + shift + case "$arg" in + -n | --norun) + DRYRUN=1; echo Dry-run enabled; continue ;; + +n | ++norun) + DRYRUN=; echo Dry-run disabled; continue ;; + -x) + set -x; continue ;; + +x) + set +x; continue ;; + clean-job-dir) + clean-job-dir; continue ;; + create-job-dir) + create-job-dir https://gitlab.gfdl.noaa.gov/ogrp/Gaea-stats-MOM6-examples.git dev/gfdl; continue ;; + copy-test-space) + copy-test-space $1; shift; continue ;; + mrs-compile) + mrs-compile $1; shift; continue ;; + nolibs-ocean-only-compile) + nolibs-ocean-only-compile $1; shift; continue ;; + nolibs-ocean-ice-compile) + nolibs-ocean-ice-compile $1; shift; continue ;; + run-suite) + run-suite $1 $2; shift; shift; continue ;; + check-stats) + check-stats $1 $2; shift; shift; continue ;; + check-params) + check-params $1; shift; continue ;; + check-diags) + check-diags $1; shift; continue ;; + *) + echo \"$arg\" is not a recognized argument! ; exit 9 ;; + esac +done diff --git a/.gitmodules b/.gitmodules index 637f1188ed..872100b62c 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,6 +1,6 @@ [submodule "pkg/CVMix-src"] path = pkg/CVMix-src - url = https://github.com/CVMix/CVMix-src.git + url = https://github.com/mom-ocean/CVMix-src.git [submodule "pkg/GSW-Fortran"] path = pkg/GSW-Fortran - url = https://github.com/TEOS-10/GSW-Fortran.git + url = https://github.com/mom-ocean/GSW-Fortran.git diff --git a/.readthedocs.yml b/.readthedocs.yml index f7ad4421b4..c48ee502d8 100644 --- a/.readthedocs.yml +++ b/.readthedocs.yml @@ -1,5 +1,18 @@ +# Read the Docs configuration file for Sphinx projects +# See https://docs.readthedocs.io/en/stable/config-file/v2.html for details + +# Required version: 2 +build: + os: ubuntu-22.04 + tools: + python: "3.11" + jobs: + build: + html: + - sphinx-build -M html docs $READTHEDOCS_OUTPUT -j auto + # Extra formats # PDF generation is failing for now; disabled on 2020-12-02 #formats: @@ -10,7 +23,5 @@ sphinx: configuration: docs/conf.py python: - # make sure we're using Python 3 - version: 3 install: - requirements: docs/requirements.txt diff --git a/.testing/Makefile b/.testing/Makefile index f330c92e3b..0550068bcf 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -1,3 +1,7 @@ +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + # MOM6 Test suite Makefile # # Usage: @@ -8,27 +12,23 @@ # Run the test suite, defined in the `tc` directores. # # make clean -# Wipe the MOM6 test executables -# (NOTE: This does not delete FMS in the `deps`) +# Delete the MOM6 test executables and dependency builds (FMS) +# +# make clean.build +# Delete only the MOM6 test executables # # # Configuration: # These settings can be provided as either command-line flags, or saved in a # `config.mk` file. # -# Experiment Configuration: -# BUILDS Executables to be built by `make` or `make all` -# CONFIGS Model configurations to test (default: `tc*`) -# TESTS Tests to run -# DIMS Dimensional scaling tests -# (NOTE: Each test will build its required executables, regardless of BUILDS) -# # General test configuration: -# FRAMEWORK Model framework (fms1 or fms2) # MPIRUN MPI job launcher (mpirun, srun, etc) # DO_REPRO_TESTS Enable production ("repro") testing equivalence # DO_REGRESSION_TESTS Enable regression tests (usually dev/gfdl) -# REPORT_COVERAGE Enable code coverage and report to codecov +# DO_COVERAGE Enable code coverage and generate .gcov reports +# DO_PROFILE Enable performance profiler comparison tests +# REQUIRE_CODECOV_UPLOAD Abort as error if upload to codecov.io fails. # # Compiler configuration: # CC C compiler @@ -43,6 +43,16 @@ # FCFLAGS_OPT Aggressive optimization compiler flags # FCFLAGS_INIT Variable initialization flags # FCFLAGS_COVERAGE Code coverage flags +# FCFLAGS_FMS FMS build flags (default: FCFLAGS_DEBUG) +# +# LDFLAGS_COVERAGE Linker coverage flags +# LDFLAGS_USER User-defined linker flags (used for all MOM/FMS builds) +# +# Experiment Configuration: +# EXECS Executables to be built by `make` or `make all` +# CONFIGS Model configurations to test (default: `tc*`) +# DIMS Dimensional scaling tests +# TESTS Tests to run # # Regression repository ("target") configuration: # MOM_TARGET_SLUG URL slug (minus domain) of the target repo @@ -50,106 +60,150 @@ # MOM_TARGET_LOCAL_BRANCH Target branch name # (NOTE: These would typically be configured by a CI.) # -#---- +# Output paths: +# BUILD Compiled executables and libraries +# DEPS Compiled dependencies +# WORK Test model output # TODO: POSIX shell compatibility SHELL = bash -# No implicit rules +# No implicit rules, suffixes, or variables +MAKEFLAGS += --no-builtin-rules +MAKEFLAGS += --no-builtin-variables + .SUFFIXES: -# No implicit variables -MAKEFLAGS += -R +# Determine the MOM6 autoconf srcdir +CODEBASE := $(dir $(abspath $(lastword $(MAKEFILE_LIST)))).. +AC_SRCDIR := $(CODEBASE)/ac # User-defined configuration -include config.mk -# Set the infra framework -FRAMEWORK ?= fms1 +# Set the FMS library +FMS_COMMIT ?= 2025.02.01 +FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git +export FMS_COMMIT +export FMS_URL # Set the MPI launcher here # TODO: This needs more automated configuration MPIRUN ?= mpirun -# Generic compiler variables are pass through to the builds +# Generic compiler variables are passed through to the builds export CC export MPICC export FC export MPIFC # Builds are distinguished by FCFLAGS -# NOTE: FMS will be built using FCFLAGS_DEBUG -FCFLAGS_DEBUG ?= -g -O0 +FCFLAGS ?= -g -O0 + +FCFLAGS_DEBUG ?= $(FCFLAGS) FCFLAGS_REPRO ?= -g -O2 FCFLAGS_OPT ?= -g -O3 -mavx -fno-omit-frame-pointer FCFLAGS_INIT ?= -FCFLAGS_COVERAGE ?= +FCFLAGS_COVERAGE ?= -g -O0 -fbacktrace --coverage +FCFLAGS_FMS ?= $(FCFLAGS) # Additional notes: # - These default values are simple, minimalist flags, supported by nearly all -# compilers which are comparable to GFDL's canonical DEBUG and REPRO builds. +# compilers, and are somewhat analogous to GFDL's DEBUG and REPRO builds. # -# - These flags should be configured outside of the Makefile, either with +# - These flags can be configured outside of the Makefile, either with # config.mk or as environment variables. -# -# - FMS cannot be built with the same aggressive initialization flags as MOM6, -# so FCFLAGS_INIT is used to provide additional MOM6 configuration. -# User-defined LDFLAGS (applied to all builds and FMS) +LDFLAGS_COVERAGE ?= --coverage LDFLAGS_USER ?= -# Set to `true` to require identical results from DEBUG and REPRO builds -# NOTE: Many compilers (Intel, GCC on ARM64) do not yet produce identical -# results across DEBUG and REPRO builds (as defined below), so we disable on -# default. +# Set to verify identical DEBUG and REPRO results DO_REPRO_TESTS ?= +# Enable profiling +DO_PROFILE ?= + +# Enable code coverage runs +DO_COVERAGE ?= + +# Enable unit tests +DO_UNIT_TESTS ?= + +# Check for regressions with target branch +DO_REGRESSION_TESTS ?= + +# Report failure if coverage report is not uploaded +REQUIRE_COVERAGE_UPLOAD ?= + +# Print logs if an error is encountered +REPORT_ERROR_LOGS ?= + # Time measurement (configurable by the CI) TIME ?= time +# Legacy external work directory +#WORKSPACE ?= +WORKSPACE ?= . + +# Set directories for build/ and work/ +BUILD ?= $(WORKSPACE)/build +DEPS ?= $(BUILD)/deps +WORK ?= $(WORKSPACE)/work + +# External tools +MAKEDEP ?= $(abspath $(AC_SRCDIR)/makedep) +PKG ?= $(abspath $(CODEBASE)/pkg) # Experiment configuration -BUILDS ?= symmetric asymmetric openmp +EXECS ?= symmetric/MOM6 asymmetric/MOM6 openmp/MOM6 CONFIGS ?= $(wildcard tc*) -TESTS ?= grid layout rotate restart openmp nan $(foreach d,$(DIMS),dim.$(d)) DIMS ?= t l h z q r +TESTS ?= grid layout rotate restart openmp nan $(foreach d,$(DIMS),dim.$(d)) +# Unit test executables +UNIT_EXECS ?= \ + $(basename $(notdir $(wildcard ../config_src/drivers/unit_tests/*.F90))) -#--- -# Dependencies -DEPS = deps - -# mkmf, list_paths (GFDL build toolchain) -LIST_PATHS := $(DEPS)/bin/list_paths -MKMF := $(DEPS)/bin/mkmf +# Timing test executables +TIMING_EXECS ?= \ + $(basename $(notdir $(wildcard ../config_src/drivers/timing_tests/*.F90))) #--- # Test configuration -# REPRO tests enable reproducibility with optimization, and often do not match -# the DEBUG results in older GCCs and vendor compilers, so we can optionally -# disable them. -ifeq ($(DO_REPRO_TESTS), true) - BUILDS += repro +# Set if either DO_COVERAGE or DO_UNIT_TESTS is set +run_unit_tests = + +# REPRO and DEBUG equivalence +ifdef DO_REPRO_TESTS + EXECS += repro/MOM6 TESTS += repro endif # Profiling -ifeq ($(DO_PROFILE), false) - BUILDS += opt opt_target +ifdef DO_PROFILE + EXECS += opt/MOM6 opt_target/MOM6 endif -# The following variables are configured by Travis: -# DO_REGRESSION_TESTS: true if $(TRAVIS_PULL_REQUEST) is a PR number -# MOM_TARGET_SLUG: TRAVIS_REPO_SLUG -# MOM_TARGET_LOCAL_BRANCH: TRAVIS_BRANCH -# These are set to true by our Travis configuration if testing a pull request -DO_REGRESSION_TESTS ?= -REPORT_COVERAGE ?= -CODECOV_UPLOADER_URL ?= https://uploader.codecov.io/latest/linux/codecov +# Coverage +ifdef DO_COVERAGE + EXECS += cov/MOM6 + run_unit_execs = yes +endif + +# Unit test executables +ifdef DO_UNIT_TESTS + run_unit_tests = yes +endif -ifeq ($(DO_REGRESSION_TESTS), true) - BUILDS += target +# If either coverage or unit tests are enabled, build the unit test execs +ifdef run_unit_tests + EXECS += $(foreach e, $(UNIT_EXECS), unit/$(e)) +endif + +# Regression testing +ifdef DO_REGRESSION_TESTS + EXECS += target/MOM6 TESTS += regression MOM_TARGET_SLUG ?= NOAA-GFDL/MOM6 @@ -158,7 +212,7 @@ ifeq ($(DO_REGRESSION_TESTS), true) MOM_TARGET_LOCAL_BRANCH ?= dev/gfdl MOM_TARGET_BRANCH := origin/$(MOM_TARGET_LOCAL_BRANCH) - TARGET_CODEBASE = build/target_codebase + TARGET_CODEBASE = $(BUILD)/target_codebase else MOM_TARGET_URL = MOM_TARGET_BRANCH = @@ -166,239 +220,205 @@ else endif +## Rules -# List of source files to link this Makefile's dependencies to model Makefiles -# Assumes a depth of two, and the following extensions: F90 inc c h -# (1): Root directory -# NOTE: extensions could be a second variable -SOURCE = \ - $(foreach ext,F90 inc c h,$(wildcard $(1)/*/*.$(ext) $(1)/*/*/*.$(ext))) +.PHONY: all +all: $(foreach b,$(EXECS),$(BUILD)/$(b)) -MOM_SOURCE = $(call SOURCE,../src) \ - $(wildcard ../config_src/infra/FMS1/*.F90) \ - $(wildcard ../config_src/drivers/solo_driver/*.F90) \ - $(wildcard ../config_src/ext*/*/*.F90) -TARGET_SOURCE = $(call SOURCE,build/target_codebase/src) \ - $(wildcard build/target_codebase/config_src/infra/FMS1/*.F90) \ - $(wildcard build/target_codebase/config_src/drivers/solo_driver/*.F90) \ - $(wildcard build/target_codebase/config_src/ext*/*.F90) -FMS_SOURCE = $(call SOURCE,$(DEPS)/fms/src) +# Executable +.PRECIOUS: $(foreach b,$(EXECS),$(BUILD)/$(b)) -#--- -# Python preprocessing environment configuration +# Compiler flags -HAS_NUMPY = $(shell python -c "import numpy" 2> /dev/null && echo "yes") -HAS_NETCDF4 = $(shell python -c "import netCDF4" 2> /dev/null && echo "yes") +# .testing dependencies +FCFLAGS_DEPS = -I$(abspath $(DEPS)/include) +LDFLAGS_DEPS = -L$(abspath $(DEPS)/lib) +PATH_DEPS = PATH="${PATH}:$(abspath $(DEPS)/bin)" -USE_VENV = -ifneq ($(HAS_NUMPY), yes) - USE_VENV = yes -endif -ifneq ($(HAS_NETCDF4), yes) - USE_VENV = yes -endif -# When disabled, activation is a null operation (`true`) -VENV_PATH = -VENV_ACTIVATE = true -ifeq ($(USE_VENV), yes) - VENV_PATH = work/local-env - VENV_ACTIVATE = . $(VENV_PATH)/bin/activate -endif +# Compiler flags +SYMMETRIC_FCFLAGS := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(FCFLAGS_DEPS)" +ASYMMETRIC_FCFLAGS := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(FCFLAGS_DEPS)" +REPRO_FCFLAGS := FCFLAGS="$(FCFLAGS_REPRO) $(FCFLAGS_DEPS)" +OPT_FCFLAGS := FCFLAGS="$(FCFLAGS_OPT) $(FCFLAGS_DEPS)" +OPENMP_FCFLAGS := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(FCFLAGS_DEPS)" +TARGET_FCFLAGS := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(FCFLAGS_DEPS)" +COV_FCFLAGS := FCFLAGS="$(FCFLAGS_COVERAGE) $(FCFLAGS_DEPS)" + +# Linker flags +MOM_LDFLAGS := LDFLAGS="$(LDFLAGS_DEPS) $(LDFLAGS_USER)" +COV_LDFLAGS := LDFLAGS="$(LDFLAGS_COVERAGE) $(LDFLAGS_DEPS) $(LDFLAGS_USER)" +# Environment variable configuration +MOM_ENV := $(PATH_FMS) +$(BUILD)/symmetric/Makefile: MOM_ENV += $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) +$(BUILD)/asymmetric/Makefile: MOM_ENV += $(ASYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) \ + MOM_MEMORY=$(AC_SRCDIR)/../config_src/memory/dynamic_nonsymmetric/MOM_memory.h +$(BUILD)/repro/Makefile: MOM_ENV += $(REPRO_FCFLAGS) $(MOM_LDFLAGS) +$(BUILD)/openmp/Makefile: MOM_ENV += $(OPENMP_FCFLAGS) $(MOM_LDFLAGS) +$(BUILD)/target/Makefile: MOM_ENV += $(TARGET_FCFLAGS) $(MOM_LDFLAGS) +$(BUILD)/opt/Makefile: MOM_ENV += $(OPT_FCFLAGS) $(MOM_LDFLAGS) +$(BUILD)/opt_target/Makefile: MOM_ENV += $(OPT_FCFLAGS) $(MOM_LDFLAGS) +$(BUILD)/coupled/Makefile: MOM_ENV += $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) +$(BUILD)/nuopc/Makefile: MOM_ENV += $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) +$(BUILD)/cov/Makefile: MOM_ENV += $(COV_FCFLAGS) $(COV_LDFLAGS) +$(BUILD)/unit/Makefile: MOM_ENV += $(COV_FCFLAGS) $(COV_LDFLAGS) +$(BUILD)/timing/Makefile: MOM_ENV += $(OPT_FCFLAGS) $(MOM_LDFLAGS) -#--- -# Rules +# Configure script flags +MOM_ACFLAGS := --with-gsw --with-cvmix +$(BUILD)/openmp/Makefile: MOM_ACFLAGS += --enable-openmp +$(BUILD)/coupled/Makefile: MOM_ACFLAGS += --with-driver=FMS_cap +$(BUILD)/nuopc/Makefile: MOM_ACFLAGS += --with-driver=nuopc_cap +$(BUILD)/unit/Makefile: MOM_ACFLAGS += --with-driver=unit_tests +$(BUILD)/timing/Makefile: MOM_ACFLAGS += --with-driver=timing_tests -.PHONY: all build.regressions build.prof -all: $(foreach b,$(BUILDS),build/$(b)/MOM6) $(VENV_PATH) -build.regressions: $(foreach b,symmetric target,build/$(b)/MOM6) -build.prof: $(foreach b,opt opt_target,build/$(b)/MOM6) -# Executable -BUILD_TARGETS = MOM6 Makefile path_names -.PRECIOUS: $(foreach b,$(BUILDS),$(foreach f,$(BUILD_TARGETS),build/$(b)/$(f))) +# Build executables +.NOTPARALLEL:$(foreach e,$(UNIT_EXECS),$(BUILD)/unit/$(e)) +$(BUILD)/unit/test_%: $(BUILD)/unit/Makefile FORCE + cd $(@D) && $(TIME) $(MAKE) $(@F) -# Compiler flags +$(BUILD)/unit/Makefile: \ + $(foreach e,$(UNIT_EXECS),../config_src/drivers/unit_tests/$(e).F90) -# Conditionally build symmetric with coverage support -COVERAGE=$(if $(REPORT_COVERAGE),$(FCFLAGS_COVERAGE),) +.NOTPARALLEL:$(foreach e,$(TIMING_EXECS),$(BUILD)/timing/$(e)) +$(BUILD)/timing/time_%: $(BUILD)/timing/Makefile FORCE + cd $(@D) && $(TIME) $(MAKE) $(@F) -# .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_FMS = -I../../$(DEPS)/include -LDFLAGS_FMS = -L../../$(DEPS)/lib -PATH_FMS = PATH="${PATH}:../../$(DEPS)/bin" +$(BUILD)/timing/Makefile: \ + $(foreach e,$(TIMING_EXECS),../config_src/drivers/timing_tests/$(e).F90) +$(BUILD)/%/MOM6: $(BUILD)/%/Makefile FORCE + cd $(@D) && $(TIME) $(MAKE) $(@F) -# Define the build targets in terms of the traditional DEBUG/REPRO/etc labels -SYMMETRIC_FCFLAGS := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(COVERAGE) $(FCFLAGS_FMS)" -ASYMMETRIC_FCFLAGS := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(FCFLAGS_FMS)" -REPRO_FCFLAGS := FCFLAGS="$(FCFLAGS_REPRO) $(FCFLAGS_FMS)" -OPT_FCFLAGS := FCFLAGS="$(FCFLAGS_OPT) $(FCFLAGS_FMS)" -OPENMP_FCFLAGS := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(FCFLAGS_FMS)" -TARGET_FCFLAGS := FCFLAGS="$(FCFLAGS_DEBUG) $(FCFLAGS_INIT) $(FCFLAGS_FMS)" +# Target codebase should use its own build system +$(BUILD)/target/MOM6: $(BUILD)/target FORCE | $(TARGET_CODEBASE) + $(MAKE) -C $(TARGET_CODEBASE)/.testing BUILD=build build/symmetric/MOM6 -MOM_LDFLAGS := LDFLAGS="$(LDFLAGS_FMS) $(LDFLAGS_USER)" -SYMMETRIC_LDFLAGS := LDFLAGS="$(COVERAGE) $(LDFLAGS_FMS) $(LDFLAGS_USER)" +$(BUILD)/target: | $(TARGET_CODEBASE) + ln -s $(abspath $(TARGET_CODEBASE))/.testing/build/symmetric $@ +$(BUILD)/opt_target/MOM6: $(BUILD)/opt_target FORCE | $(TARGET_CODEBASE) + $(MAKE) -C $(TARGET_CODEBASE)/.testing BUILD=build build/opt/MOM6 -# Environment variable configuration -build/symmetric/Makefile: MOM_ENV=$(PATH_FMS) $(SYMMETRIC_FCFLAGS) $(SYMMETRIC_LDFLAGS) -build/asymmetric/Makefile: MOM_ENV=$(PATH_FMS) $(ASYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) -build/repro/Makefile: MOM_ENV=$(PATH_FMS) $(REPRO_FCFLAGS) $(MOM_LDFLAGS) -build/openmp/Makefile: MOM_ENV=$(PATH_FMS) $(OPENMP_FCFLAGS) $(MOM_LDFLAGS) -build/target/Makefile: MOM_ENV=$(PATH_FMS) $(TARGET_FCFLAGS) $(MOM_LDFLAGS) -build/opt/Makefile: MOM_ENV=$(PATH_FMS) $(OPT_FCFLAGS) $(MOM_LDFLAGS) -build/opt_target/Makefile: MOM_ENV=$(PATH_FMS) $(OPT_FCFLAGS) $(MOM_LDFLAGS) -build/coupled/Makefile: MOM_ENV=$(PATH_FMS) $(SYMMETRIC_FCFLAGS) $(SYMMETRIC_LDFLAGS) -build/nuopc/Makefile: MOM_ENV=$(PATH_FMS) $(SYMMETRIC_FCFLAGS) $(SYMMETRIC_LDFLAGS) -build/mct/Makefile: MOM_ENV=$(PATH_FMS) $(SYMMETRIC_FCFLAGS) $(SYMMETRIC_LDFLAGS) +$(BUILD)/opt_target: | $(TARGET_CODEBASE) + ln -s $(abspath $(TARGET_CODEBASE))/.testing/build/opt $@ -# Configure script flags -build/symmetric/Makefile: MOM_ACFLAGS= -build/asymmetric/Makefile: MOM_ACFLAGS=--enable-asymmetric -build/repro/Makefile: MOM_ACFLAGS= -build/openmp/Makefile: MOM_ACFLAGS=--enable-openmp -build/target/Makefile: MOM_ACFLAGS= -build/opt/Makefile: MOM_ACFLAGS= -build/opt_target/Makefile: MOM_ACFLAGS= -build/coupled/Makefile: MOM_ACFLAGS=--with-driver=coupled_driver -build/nuopc/Makefile: MOM_ACFLAGS=--with-driver=nuopc_driver -build/mct/Makefile: MOM_ACFLAGS=--with-driver=mct_driver - -# Fetch regression target source code -build/target/Makefile: | $(TARGET_CODEBASE) -build/opt_target/Makefile: | $(TARGET_CODEBASE) - - -# Define source code dependencies -# NOTE: ./configure is too much, but Makefile is not enough! -# Ideally we would want to re-run both Makefile and mkmf, but our mkmf call -# is inside ./configure, so we must re-run ./configure as well. -$(foreach b,$(filter-out target,$(BUILDS)),build/$(b)/Makefile): $(MOM_SOURCE) -build/target_codebase/configure: $(TARGET_SOURCE) - - -# Build MOM6 -.PRECIOUS: $(foreach b,$(BUILDS),build/$(b)/MOM6) -build/%/MOM6: build/%/Makefile - cd $(@D) && $(TIME) $(MAKE) -j - - -# Use autoconf to construct the Makefile for each target -.PRECIOUS: $(foreach b,$(BUILDS),build/$(b)/Makefile) -build/%/Makefile: ../ac/configure ../ac/Makefile.in $(DEPS)/lib/libFMS.a $(MKMF) $(LIST_PATHS) - mkdir -p $(@D) - cd $(@D) \ - && $(MOM_ENV) ../../../ac/configure $(MOM_ACFLAGS) --with-framework=$(FRAMEWORK) \ - || (cat config.log && false) +.PHONY: FORCE -../ac/configure: ../ac/configure.ac ../ac/m4 - autoreconf -i $< +## Use autoconf to construct the Makefile for each target +# TODO: This could all be moved to a top-level MOM6 Makefile +.PRECIOUS: $(BUILD)/%/Makefile +.PRECIOUS: $(BUILD)/%/Makefile.in +.PRECIOUS: $(BUILD)/%/configure +.PRECIOUS: $(BUILD)/%/config.status +.PRECIOUS: $(BUILD)/%/configure.ac +.PRECIOUS: $(BUILD)/%/m4/ +$(BUILD)/%/Makefile: $(BUILD)/%/Makefile.in $(BUILD)/%/config.status + cd $(@D) && ./config.status -# Fetch the regression target codebase -build/target/Makefile build/opt_target/Makefile: \ - $(TARGET_CODEBASE)/ac/configure $(DEPS)/lib/libFMS.a $(MKMF) $(LIST_PATHS) - mkdir -p $(@D) - cd $(@D) \ - && $(MOM_ENV) ../../$(TARGET_CODEBASE)/ac/configure $(MOM_ACFLAGS) \ - || (cat config.log && false) +$(BUILD)/%/config.status: $(BUILD)/%/configure $(DEPS)/lib/libFMS.a $(DEPS)/lib/libgsw.a $(DEPS)/lib/libcvmix.a + cd $(@D) && $(MOM_ENV) ./configure -n --srcdir=$(CODEBASE) $(MOM_ACFLAGS) \ + || (cat config.log && false) + +$(BUILD)/%/Makefile.in: ../ac/Makefile.in | $(BUILD)/%/ + cp ../ac/Makefile.in $(@D) +$(BUILD)/%/configure: $(BUILD)/%/configure.ac $(BUILD)/%/m4/ + autoreconf -if $(@D) -$(TARGET_CODEBASE)/ac/configure: $(TARGET_CODEBASE) - autoreconf -i $/dev/null)" || rm -rf results/$(1) +.PRECIOUS: $(foreach b,$(3),$(WORK)/$(1)/$(b)/ocean.stats) +$(1).$(2): $(foreach b,$(3),$(WORK)/$(1)/$(b)/ocean.stats) + @test "$$(shell ls -A $(WORK)/results/$(1) 2>/dev/null)" || rm -rf $(WORK)/results/$(1) @cmp $$^ || !( \ - mkdir -p results/$(1); \ - (diff $$^ | tee results/$(1)/ocean.stats.$(2).diff | head -n 20) ; \ + mkdir -p $(WORK)/results/$(1); \ + (diff $$^ | tee $(WORK)/results/$(1)/ocean.stats.$(2).diff | head -n 20) ; \ echo -e "$(FAIL): Solutions $(1).$(2) have changed." \ ) @echo -e "$(PASS): Solutions $(1).$(2) agree." -.PRECIOUS: $(foreach b,$(3),work/$(1)/$(b)/chksum_diag) -$(1).$(2).diag: $(foreach b,$(3),work/$(1)/$(b)/chksum_diag) +.PRECIOUS: $(foreach b,$(3),$(WORK)/$(1)/$(b)/chksum_diag) +$(1).$(2).diag: $(foreach b,$(3),$(WORK)/$(1)/$(b)/chksum_diag) @cmp $$^ || !( \ - mkdir -p results/$(1); \ - (diff $$^ | tee results/$(1)/chksum_diag.$(2).diff | head -n 20) ; \ + mkdir -p $(WORK)/results/$(1); \ + (diff $$^ | tee $(WORK)/results/$(1)/chksum_diag.$(2).diff | head -n 20) ; \ echo -e "$(FAIL): Diagnostics $(1).$(2).diag have changed." \ ) @echo -e "$(PASS): Diagnostics $(1).$(2).diag agree." @@ -493,16 +514,17 @@ $(foreach d,$(DIMS),$(eval $(call CMP_RULE,$(1),dim.$(d),symmetric dim.$(d)))) endef $(foreach c,$(CONFIGS),$(eval $(call CONFIG_DIM_RULE,$(c)))) + # Custom comparison rules # Restart tests only compare the final stat record -.PRECIOUS: $(foreach b,symmetric restart target,work/%/$(b)/ocean.stats) -%.restart: $(foreach b,symmetric restart,work/%/$(b)/ocean.stats) - @test "$(shell ls -A results/$* 2>/dev/null)" || rm -rf results/$* +.PRECIOUS: $(foreach b,symmetric restart target,$(WORK)/%/$(b)/ocean.stats) +%.restart: $(foreach b,symmetric restart,$(WORK)/%/$(b)/ocean.stats) + @test "$(shell ls -A $(WORK)/results/$* 2>/dev/null)" || rm -rf $(WORK)/results/$* @cmp $(foreach f,$^,<(tr -s ' ' < $(f) | cut -d ' ' -f3- | tail -n 1)) \ || !( \ - mkdir -p results/$*; \ - (diff $^ | tee results/$*/chksum_diag.restart.diff | head -n 20) ; \ + mkdir -p $(WORK)/results/$*; \ + (diff $^ | tee $(WORK)/results/$*/chksum_diag.restart.diff | head -n 20) ; \ echo -e "$(FAIL): Solutions $*.restart have changed." \ ) @echo -e "$(PASS): Solutions $*.restart agree." @@ -510,34 +532,47 @@ $(foreach c,$(CONFIGS),$(eval $(call CONFIG_DIM_RULE,$(c)))) # TODO: chksum_diag parsing of restart files # stats rule is unchanged, but we cannot use CMP_RULE to generate it. -%.regression: $(foreach b,symmetric target,work/%/$(b)/ocean.stats) - @test "$(shell ls -A results/$* 2>/dev/null)" || rm -rf results/$* +%.regression: $(foreach b,symmetric target,$(WORK)/%/$(b)/ocean.stats) + @test "$(shell ls -A $(WORK)/results/$* 2>/dev/null)" || rm -rf $(WORK)/results/$* @cmp $^ || !( \ - mkdir -p results/$*; \ - (diff $^ | tee results/$*/ocean.stats.regression.diff | head -n 20) ; \ + mkdir -p $(WORK)/results/$*; \ + (diff $^ | tee $(WORK)/results/$*/ocean.stats.regression.diff | head -n 20) ; \ echo -e "$(FAIL): Solutions $*.regression have changed." \ ) @echo -e "$(PASS): Solutions $*.regression agree." # Regression testing only checks for changes in existing diagnostics -%.regression.diag: $(foreach b,symmetric target,work/%/$(b)/chksum_diag) - @! diff $^ | grep "^[<>]" | grep "^>" > /dev/null \ - || ! (\ - mkdir -p results/$*; \ - (diff $^ | tee results/$*/chksum_diag.regression.diff | head -n 20) ; \ +.PRECIOUS: $(WORK)/%/target/chksum_diag +%.regression.diag: $(foreach b,symmetric target,$(WORK)/%/$(b)/chksum_diag) + @tools/diff_diag.sh $^ || ! (\ echo -e "$(FAIL): Diagnostics $*.regression.diag have changed." \ ) - @cmp $^ || ( \ - diff $^ | head -n 20; \ + @tools/cmp_diag.sh $^ || ( \ echo -e "$(WARN): New diagnostics in $<" \ ) @echo -e "$(PASS): Diagnostics $*.regression.diag agree." +#--- +# Preprocessing +# NOTE: This only support tc4, but can be generalized over all tests. +.PHONY: preproc +preproc: tc4/Makefile + cd tc4 && $(MAKE) LAUNCHER="$(MPIRUN)" +preproc-compile: tc4/Makefile + cd tc4 && $(MAKE) executables + +tc4/Makefile: tc4/configure tc4/Makefile.in + cd $(@D) && ./configure || (cat config.log && false) + +tc4/configure: tc4/configure.ac + cd $(@D) && autoreconf -if + + #--- # Test run output files -# Rule to build work//{ocean.stats,chksum_diag}. +# Rule to build $(WORK)//{ocean.stats,chksum_diag}. # $(1): Test configuration name # $(2): Executable type # $(3): Enable coverage flag @@ -546,49 +581,61 @@ $(foreach c,$(CONFIGS),$(eval $(call CONFIG_DIM_RULE,$(c)))) # $(6): Number of MPI ranks define STAT_RULE -work/%/$(1)/ocean.stats work/%/$(1)/chksum_diag: build/$(2)/MOM6 $(VENV_PATH) +$(WORK)/%/$(1)/ocean.stats $(WORK)/%/$(1)/chksum_diag: $(BUILD)/$(2)/MOM6 | preproc @echo "Running test $$*.$(1)..." - if [ $(3) ]; then find build/$(2) -name *.gcda -exec rm -f '{}' \; ; fi mkdir -p $$(@D) cp -RL $$*/* $$(@D) - if [ -f $$(@D)/Makefile ]; then \ - $$(VENV_ACTIVATE) \ - && cd $$(@D) \ - && $(MAKE); \ - else \ - cd $$(@D); \ - fi - mkdir -p $$(@D)/RESTART echo -e "$(4)" > $$(@D)/MOM_override - rm -f results/$$*/std.$(1).{out,err} + rm -f $(WORK)/results/$$*/std.$(1).{out,err} cd $$(@D) \ - && $(TIME) $(5) $(MPIRUN) -n $(6) ../../../$$< 2> std.err > std.out \ + && $(TIME) $(5) $(MPIRUN) -n $(6) $$(abspath $$<) 2> std.err > std.out \ || !( \ mkdir -p ../../../results/$$*/ ; \ - cat std.out | tee ../../../results/$$*/std.$(1).out | tail -n 20 ; \ - cat std.err | tee ../../../results/$$*/std.$(1).err | tail -n 20 ; \ + cat std.out | tee ../../../results/$$*/std.$(1).out | tail -n 100 ; \ + cat std.err | tee ../../../results/$$*/std.$(1).err | tail -n 100 ; \ rm ocean.stats chksum_diag ; \ echo -e "$(FAIL): $$*.$(1) failed at runtime." \ ) @echo -e "$(DONE): $$*.$(1); no runtime errors." if [ $(3) ]; then \ - mkdir -p results/$$* ; \ - cd build/symmetric ; \ - gcov *.gcda > gcov.$$*.$(1).out ; \ - curl -s $(CODECOV_UPLOADER_URL) -o codecov ; \ - chmod +x codecov ; \ - ./codecov -Z -f "*.gcov" -n $$@ \ - > codecov.$$*.$(1).out \ - 2> codecov.$$*.$(1).err \ - && echo -e "${MAGENTA}Report uploaded to codecov.${RESET}"; \ + mkdir -p $(WORK)/results/$$* ; \ + cd $(BUILD)/$(2) ; \ + gcov -b *.gcda > gcov.$$*.$(1).out ; \ + find -name "*.gcov" -exec sed -i -r 's/^( *[0-9]*)\*:/ \1:/g' {} \; ; \ fi endef +# Upload coverage reports +CODECOV_UPLOADER_URL ?= https://uploader.codecov.io/latest/linux/codecov +CODECOV_TOKEN ?= + +ifdef CODECOV_TOKEN + CODECOV_TOKEN_ARG = -t $(CODECOV_TOKEN) +else + CODECOV_TOKEN_ARG = +endif + +codecov: + curl -s $(CODECOV_UPLOADER_URL) -o $@ + chmod +x codecov + +.PHONY: report.cov +report.cov: run.cov codecov + ./codecov $(CODECOV_TOKEN_ARG) -R $(BUILD)/cov -Z -f "*.gcov" \ + > $(BUILD)/cov/codecov.out \ + 2> $(BUILD)/cov/codecov.err \ + && echo -e "${MAGENTA}Report uploaded to codecov.${RESET}" \ + || { \ + cat $(BUILD)/cov/codecov.err ; \ + echo -e "${RED}Failed to upload report.${RESET}" ; \ + if [ "$(REQUIRE_COVERAGE_UPLOAD)" = true ] ; then false ; fi ; \ + } + # Define $(,) as comma escape character , := , -$(eval $(call STAT_RULE,symmetric,symmetric,$(REPORT_COVERAGE),,,1)) +$(eval $(call STAT_RULE,symmetric,symmetric,,,,1)) $(eval $(call STAT_RULE,asymmetric,asymmetric,,,,1)) $(eval $(call STAT_RULE,target,target,,,,1)) $(eval $(call STAT_RULE,repro,repro,,,,1)) @@ -602,24 +649,17 @@ $(eval $(call STAT_RULE,dim.h,symmetric,,H_RESCALE_POWER=11,,1)) $(eval $(call STAT_RULE,dim.z,symmetric,,Z_RESCALE_POWER=11,,1)) $(eval $(call STAT_RULE,dim.q,symmetric,,Q_RESCALE_POWER=11,,1)) $(eval $(call STAT_RULE,dim.r,symmetric,,R_RESCALE_POWER=11,,1)) - +$(eval $(call STAT_RULE,cov,cov,true,,,1)) # Generate the half-period input namelist as follows: # 1. Fetch DAYMAX and TIMEUNIT from MOM_input # 2. Convert DAYMAX from TIMEUNIT to seconds # 3. Apply seconds to `ocean_solo_nml` inside input.nml. # NOTE: Assumes that runtime set by DAYMAX, will fail if set by input.nml -work/%/restart/ocean.stats: build/symmetric/MOM6 $(VENV_PATH) +$(WORK)/%/restart/ocean.stats: $(BUILD)/symmetric/MOM6 | preproc rm -rf $(@D) mkdir -p $(@D) cp -RL $*/* $(@D) - if [ -f $(@D)/Makefile ]; then \ - $(VENV_ACTIVATE) \ - && cd work/$*/restart \ - && $(MAKE); \ - else \ - cd work/$*/restart; \ - fi mkdir -p $(@D)/RESTART # Set the half-period cd $(@D) \ @@ -630,12 +670,12 @@ work/%/restart/ocean.stats: build/symmetric/MOM6 $(VENV_PATH) && halfperiod=$$(awk -v t=$${daymax} -v dt=$${timeunit} 'BEGIN {printf "%.f", 0.5*t*dt}') \ && printf "\n&ocean_solo_nml\n seconds = $${halfperiod}\n/\n" >> input.nml # Remove any previous archived output - rm -f results/$*/std.restart{1,2}.{out,err} + rm -f $(WORK)/results/$*/std.restart{1,2}.{out,err} # Run the first half-period - cd $(@D) && $(TIME) $(MPIRUN) -n 1 ../../../$< 2> std1.err > std1.out \ + cd $(@D) && $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> std1.err > std1.out \ || !( \ - cat std1.out | tee ../../../results/$*/std.restart1.out | tail -n 20 ; \ - cat std1.err | tee ../../../results/$*/std.restart1.err | tail -n 20 ; \ + cat std1.out | tee ../../../results/$*/std.restart1.out | tail -n 100 ; \ + cat std1.err | tee ../../../results/$*/std.restart1.err | tail -n 100 ; \ echo -e "$(FAIL): $*.restart failed at runtime." \ ) # Setup the next inputs @@ -643,70 +683,156 @@ work/%/restart/ocean.stats: build/symmetric/MOM6 $(VENV_PATH) mkdir $(@D)/RESTART cd $(@D) && sed -i -e "s/input_filename *= *'n'/input_filename = 'r'/g" input.nml # Run the second half-period - cd $(@D) && $(TIME) $(MPIRUN) -n 1 ../../../$< 2> std2.err > std2.out \ + cd $(@D) && $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> std2.err > std2.out \ || !( \ - cat std2.out | tee ../../../results/$*/std.restart2.out | tail -n 20 ; \ - cat std2.err | tee ../../../results/$*/std.restart2.err | tail -n 20 ; \ + cat std2.out | tee ../../../results/$*/std.restart2.out | tail -n 100 ; \ + cat std2.err | tee ../../../results/$*/std.restart2.err | tail -n 100 ; \ echo -e "$(FAIL): $*.restart failed at runtime." \ ) # TODO: Restart checksum diagnostics - #--- # Not a true rule; only call this after `make test` to summarize test results. .PHONY: test.summary test.summary: - @if ls results/*/* &> /dev/null; then \ - if ls results/*/std.*.err &> /dev/null; then \ - echo "The following tests failed to complete:" ; \ - ls results/*/std.*.out \ - | awk '{split($$0,a,"/"); split(a[3],t,"."); v=t[2]; if(length(t)>3) v=v"."t[3]; print a[2],":",v}'; \ - fi; \ - if ls results/*/ocean.stats.*.diff &> /dev/null; then \ - echo "The following tests report solution regressions:" ; \ - ls results/*/ocean.stats.*.diff \ - | awk '{split($$0,a,"/"); split(a[3],t,"."); v=t[3]; if(length(t)>4) v=v"."t[4]; print a[2],":",v}'; \ - fi; \ - if ls results/*/chksum_diag.*.diff &> /dev/null; then \ - echo "The following tests report diagnostic regressions:" ; \ - ls results/*/chksum_diag.*.diff \ - | awk '{split($$0,a,"/"); split(a[3],t,"."); v=t[2]; if(length(t)>3) v=v"."t[3]; print a[2],":",v}'; \ - fi; \ - false ; \ - else \ - echo -e "$(PASS): All tests passed!"; \ - fi + ./tools/report_test_results.sh $(WORK)/results #--- -# Profiling -# XXX: This is experimental work to track, log, and report changes in runtime +# Unit test + +# NOTE: Using file parser gcov report as a proxy for test completion +.PHONY: run.cov.unit +run.cov.unit: $(foreach t,$(UNIT_EXECS),$(BUILD)/unit/$(t).F90.gcov) + +.PHONY: build.unit +.NOTPARALLEL: build.unit +build.unit: $(foreach f, $(UNIT_EXECS), $(BUILD)/unit/$(f)) + +.PHONY: run.unit +run.unit: $(foreach f, $(UNIT_EXECS), work/unit/$(f).out) + +.PHONY: build.timing +.NOTPARALLEL: build.timing +build.timing: $(foreach f, $(TIMING_EXECS), $(BUILD)/timing/$(f)) + +.PHONY: run.timing +run.timing: $(foreach f, $(TIMING_EXECS), work/timing/$(f).out) + +.PHONY: show.timing +show.timing: $(foreach f, $(TIMING_EXECS), work/timing/$(f).show) + +$(WORK)/timing/%.show: + ./tools/disp_timing.py $(@:.show=.out) + + +# Invoke the above unit/timing rules for a "target" code, e.g. +# make \ +# MOM_TARGET_URL=... \ +# MOM_TARGET_BRANCH=... \ +# TARGET_CODEBASE=$(BUILD)/target_codebase \ +# build.timing_target +# make TARGET_CODEBASE=$(BUILD)/target_codebase run.timing_target + +TIMING_TARGET_EXECS ?= \ + $(basename $(notdir $(wildcard $(TARGET_CODEBASE)/config_src/drivers/timing_tests/*.F90))) + +.PHONY: build.timing_target +build.timing_target: \ + $(foreach f, $(TIMING_TARGET_EXECS), $(TARGET_CODEBASE)/.testing/$(BUILD)/timing/$(f)) + +.PHONY: run.timing_target +run.timing_target: \ + $(foreach f, $(TIMING_TARGET_EXECS), $(TARGET_CODEBASE)/.testing/work/timing/$(f).out) + +.PHONY: compare.timing +compare.timing: \ + $(foreach f, $(filter $(TIMING_EXECS),$(TIMING_TARGET_EXECS)), work/timing/$(f).compare) +$(WORK)/timing/%.compare: \ + $(TARGET_CODEBASE) + ./tools/disp_timing.py -r $(TARGET_CODEBASE)/.testing/$(@:.compare=.out) $(@:.compare=.out) +$(TARGET_CODEBASE)/.testing/%: | $(TARGET_CODEBASE) + cd $(TARGET_CODEBASE)/.testing && make $* + + +# General rule to run a unit test executable +# Pattern is to run $(BUILD)/unit/executable and direct output to executable.out +$(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 '{}' \; ; \ + fi + mkdir -p $(@D) + cd $(@D) \ + && rm -f input.nml logfile.0000*.out *_input MOM_parameter_doc.* \ + && $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> test_MOM_file_parser.err > test_MOM_file_parser.out \ + || !( \ + cat test_MOM_file_parser.out | tail -n 100 ; \ + cat test_MOM_file_parser.err | tail -n 100 ; \ + ) + cd $(@D) \ + && $(TIME) $(MPIRUN) -n 2 $(abspath $<) 2> p2.test_MOM_file_parser.err > p2.test_MOM_file_parser.out \ + || !( \ + cat p2.test_MOM_file_parser.out | tail -n 100 ; \ + cat p2.test_MOM_file_parser.err | tail -n 100 ; \ + ) + +$(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: $(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 \ + && echo -e "${MAGENTA}Report uploaded to codecov.${RESET}" \ + || { \ + cat $(BUILD)/unit/codecov.err ; \ + echo -e "${RED}Failed to upload report.${RESET}" ; \ + if [ "$(REQUIRE_COVERAGE_UPLOAD)" = true ] ; then false ; fi ; \ + } + +$(WORK)/timing/%.out: $(BUILD)/timing/% FORCE + @mkdir -p $(@D) + @echo Running $< in $(@D) + @cd $(@D) ; $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> $*.err > $*.out + + +## Profiling based on FMS clocks + PCONFIGS = p0 .PHONY: profile profile: $(foreach p,$(PCONFIGS), prof.$(p)) .PHONY: prof.p0 -prof.p0: work/p0/opt/clocks.json work/p0/opt_target/clocks.json +prof.p0: $(WORK)/p0/opt/clocks.json $(WORK)/p0/opt_target/clocks.json python tools/compare_clocks.py $^ -work/p0/%/clocks.json: work/p0/%/std.out - python tools/parse_fms_clocks.py -d $(@D) $^ > $@ +$(WORK)/p0/%/clocks.json: $(WORK)/p0/%/std.out + python tools/parse_fms_clocks.py -d $(@D) $^ > $@ \ + || !( rm $@ ) -work/p0/opt/std.out: build/opt/MOM6 -work/p0/opt_target/std.out: build/opt_target/MOM6 +$(WORK)/p0/opt/std.out: $(BUILD)/opt/MOM6 +$(WORK)/p0/opt_target/std.out: $(BUILD)/opt_target/MOM6 -work/p0/%/std.out: +$(WORK)/p0/%/std.out: mkdir -p $(@D) cp -RL p0/* $(@D) mkdir -p $(@D)/RESTART echo -e "" > $(@D)/MOM_override cd $(@D) \ - && $(MPIRUN) -n 1 ../../../$< 2> std.err > std.out + && $(MPIRUN) -n 1 $(abspath $<) 2> std.err > std.out -#--- -# Same but with perf + +## Profiling based on perf output # TODO: This expects the -e flag, can I handle it in the command? PERF_EVENTS ?= @@ -715,16 +841,16 @@ PERF_EVENTS ?= perf: $(foreach p,$(PCONFIGS), perf.$(p)) .PHONY: prof.p0 -perf.p0: work/p0/opt/profile.json work/p0/opt_target/profile.json +perf.p0: $(WORK)/p0/opt/profile.json $(WORK)/p0/opt_target/profile.json python tools/compare_perf.py $^ -work/p0/%/profile.json: work/p0/%/perf.data +$(WORK)/p0/%/profile.json: $(WORK)/p0/%/perf.data python tools/parse_perf.py -f $< > $@ -work/p0/opt/perf.data: build/opt/MOM6 -work/p0/opt_target/perf.data: build/opt_target/MOM6 +$(WORK)/p0/opt/perf.data: $(BUILD)/opt/MOM6 +$(WORK)/p0/opt_target/perf.data: $(BUILD)/opt_target/MOM6 -work/p0/%/perf.data: +$(WORK)/p0/%/perf.data: mkdir -p $(@D) cp -RL p0/* $(@D) mkdir -p $(@D)/RESTART @@ -737,22 +863,30 @@ work/p0/%/perf.data: || cat std.perf.err -#---- +## Cleanup # NOTE: These tests assert that we are in the .testing directory. .PHONY: clean clean: clean.build clean.stats - @[ $$(basename $$(pwd)) = .testing ] - rm -rf deps + rm -rf $(BUILD) .PHONY: clean.build clean.build: @[ $$(basename $$(pwd)) = .testing ] - rm -rf build + for b in $(ALL_EXECS); do \ + rm -rf $(BUILD)/$${b}; \ + done .PHONY: clean.stats clean.stats: @[ $$(basename $$(pwd)) = .testing ] - rm -rf work results + rm -rf $(WORK) + + +.PHONY: clean.preproc +clean.preproc: + @if [ -f tc4/Makefile ] ; then \ + cd tc4 && make clean ; \ + fi diff --git a/.testing/README.md b/.testing/README.md deleted file mode 100644 index ef02bcfa09..0000000000 --- a/.testing/README.md +++ /dev/null @@ -1,277 +0,0 @@ -# .testing - -This directory contains the Makefile and test configurations used to evaluate -submissions to the MOM6 codebase. The tests are designed to run either locally -or in a CI environment such as Travis. - - -## Overview - -This section gives a very brief overview of the test suite and how to use it. - -To build and run the model tests: -``` -make -j -make -j test -``` -For new users, the default configuration should be suitable for most platforms. -If not, then the following options may need to be configured. - -`MPIRUN` (*default:* `mpirun`) - - Name of the MPI launcher. Often this is `mpirun` or `mpiexec` but may all - need to run through a scheduler, e.g. `srun` if using Slurm. - -`DO_REGRESSION_TESTS` (*default: none*) - - Set to `true` to compare output with `dev/gfdl`. - -`DO_REPRO_TESTS` (*default: none*) - - Set to `true` to compare DEBUG and REPRO builds, which typically correspond - to unoptimized and optimized builds. See TODO for more information. - -These settings can either be specified at the command line, as shown below -``` -make DO_REGRESSION_TESTS=true -make test DO_REGRESSION_TESTS=true -``` -or saved in a configuration file, `config.mk`. - -To run individual classes of tests, use the subclass name: -``` -make test.grids -make test.layouts -make DO_REGRESSION_TESTS=true test.regressions -``` -To test an individual test configuration (TC): -``` -make tc0.grid -``` -See "Tests" and "Test Configurations" for the complete list of tests. - -The rest of the document describes the test suite in more detail, including -names and descriptions of the test classes and configurations. - - -## Testing overview - -The test suite checks for numerical consistency of the model output across -different model configurations when subjected to relevant numerical and -mathematical transformations, such as grid layout or dimensional rescaling. If -the model state is unchanged after each transformation, then the test is -reported as passing. Any discrepancy in the model state causes the test to -fail. - -Model state is currently defined by the `ocean.stats` output file, which -reports the total energy (per unit mass) at machine precision alongside similar -global metrics at lower precision, such as mass or mean sea level. - -Diagnostics are based on the MOM checksum function, which includes the mean, -minimum, and maximum values, alongside a bitcount checksum, in the physical -domain, which are saved in the `chksum_diag` output file. - - -## Build configuration - -The test suite defines a DEBUG and a REPRO build, which resemble targets used -at GFDL. The DEBUG build is intended for detecting potential errors and -troubleshooting, while the REPRO build has typically been optimized for -production runs. - -Ideally, the DEBUG and REPRO runs will produce identical results, although this -is often not the case for many compilers and platforms. The `DO_REPRO_TEST` -flag is used to test DEBUG/REPRO equivalency. - -The following options are provided to configure your compiler flags. - -`FCFLAGS_DEBUG` (*default:* `-g -O0`) - - Specify the flags used in the DEBUG build. These are the flags used for all - tests excepting the REPRO builds. They are also used to build the FMS - library. - - These should be used to enable settings favorable to debugging, such as no - optimizations, backtraces, range checking, and warnings. - - For more aggressive debugging flags which cannot be used with FMS, see - `FCFLAGS_INIT`. - -`FCFLAGS_REPRO:` (*default:* `-g -O2`) - - Specify the optimized reproducible run, typically used in production runs. - - Ideally, this should consist of optimization flags which improve peformance - but do not change model output. In practice, this is difficult to achieve, - and should only used in certain environments. - -`FCFLAGS_INIT` (*default: none*) - - This flag was historically used to specify variable initialization, such as - nonzero integers or floating point values, and is still generally used for - this purpose. - - As implemented, it is used for all MOM6 builds. It is not used for FMS - builds, so can also act as a debugging flag independent of FMS. - -`FCFLAGS_COVERAGE` (*default: none*) - - This flag is used to define a build which supports some sort of code - coverage, often one which is handled by the CI. - - For many compilers, this is set to `--coverage`, and is applied to both the - compiler (`FCFLAGS`) and linker (`LDFLAGS`). - -Example values used by GFDL and Travis for the GFortran compiler are shown -below. -``` -FCFLAGS_DEBUG="-g -O0 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds" -FCFLAGS_REPRO="-g -O2 -fbacktrace" -FCFLAGS_INIT="-finit-real=snan -finit-integer=2147483647 -finit-derived" -FCFLAGS_COVERAGE="--coverage" -``` - -Note that the default values for these flags are very minimal, in order to -ensure compatibility over the largest possible range of compilers. - -Like all configuration variables, these can be specified in a `config.mk` file. - - -## Building the executables - -Run `make` to build the test executables. -``` -make -``` -This will fetch the MKMF build toolchain, fetch and compile the FMS framework -library, and compile the executables used in the test suite. The default -configuration uses the symmetric grid in the debug-compile mode, with -optimizations disabled and stronger quality controls. The following -executables will be created. - -- `build/symmetric/MOM6`: Symmetric grid configuration (i.e. extended grids - along western and/or southern boundaries for selected fields). This is the - default configuration. - -- `build/asymmetric/MOM6`: Non-symmetric grid (equal-sized grids) - -- `build/repro/MOM6`: Optimized reproducible mode - -- `build/target/MOM6`: A reference build for regression testing - -- `build/openmp/MOM6`: OpenMP-enabled build - -The `target` and `repro` builds are only created when their respective tests -are set to `true`. - - -### Regression testing - -When regression tests are enabled, the Makefile will check out a second copy of -the repository from a specified URL and branch given by `MOM_TARGET_URL` and -`MOM_TARGET_BRANCH`, respectively. The code is checked out into the -`TARGET_CODEBASE` directory. - -The default settings, with resolved values as comments, are shown below. -``` -MOM_TARGET_SLUG = NOAA-GFDL/MOM6 -MOM_TARGET_URL = https://github.com/$(MOM_TARGET_SLUG) - #= https://github.com/NOAA-GFDL/MOM6 -MOM_TARGET_LOCAL_BRANCH = dev/gfdl -MOM_TARGET_BRANCH = origin/$(MOM_TARGET_LOCAL_BRANCH) - #= origin/dev/gfdl -TARGET_CODEBASE = $(BUILD)/target_codebase -``` -These default values can be configured to target a particular development -branch. - -Currently the target can only be specifed by branch name, rather than hash. - -New diagnostics do not report as a fail, and are not tracked by any CIs, but -the test will report a warning to the user. - - -## Tests - -Using `test` will run through the full test suite. -``` -make test -``` -The tests are gathered into the following groups. - -- `test.regressions`: Regression tests relative to a code state (when enabled) -- `test.grids`: Symmetric vs nonsymmetric grids -- `test.layouts`: Domain decomposition, based on parallelization -- `test.restarts`: Resubmission by restarts -- `test.repros`: Optimized (REPRO) and unoptimized (DEBUG) compilation -- `test.nans`: NaN initialization of allocated arrays -- `test.dims`: Dimensional scaling (length, time, thickness, depth) - -Each group of tests can also be run individually, such as in the following -example. -``` -make test.grids -``` - -Each configuration is tested relative to the `symmetric` build, and reports a -fail if the answers differ from this build. - - -## Test configurations - -The following model test configurations (TCs) are supported, and are based on -configurations in the MOM6-examples repository. - -- `tc0`: Unit testing of various model components, based on `unit_tests` -- `tc1`: A low-resolution version of the `benchmark` configuration - - `tc1.a`: Use the un-split mode with Runge-Kutta 3 time integration - - `tc1.b`: Use the un-split mode with Runge-Kutta 2 time integration -- `tc2`: An ALE configuration based on tc1 with tides - - `tc2.a`: Use sigma, PPM_H4 and no tides -- `tc3`: An open-boundary condition (OBC) test based on `circle_obcs` -- `tc4`: Sponges and initialization using I/O - - -## Code coverage - -Code coverage reports the lines of code which have been tested, and can be used -to determine if a particular section is untested. - -Coverage is measured using `gcov` and is reported for TCs using the `symmetric` -executable. - -Coverage reporting is optionally uploaded to the `codecov.io` site. -``` -https://codecov.io/gh/NOAA-GFDL/MOM6 -``` -This is disabled on default, but can be enabled by the `REPORT_COVERAGE` flag. -``` -make test REPORT_COVERAGE=true -``` -Note that any uploads will require a valid CodeCov token. - - -## Running on Travis - -Whenever code is pushed to GitHub or a pull request (PR) is created, the test -suite is triggered and the code changes are tested. - -When the tests are run on Travis, the following variables are re-defined: - -- `DO_REPRO_TESTS` is set to `true` for all tests. - -- `DO_REGRESSION_TESTS` is set to `true` for a PR submission, and is unset for - code pushes. - -- `MOM_TARGET_SLUG` is set to `TRAVIS_REPO_SLUG`, the URL stub of the model to - be built. - - For submissions to NOAA-GFDL, this will be set to `NOAA-GFDL/MOM6` and the - reference URL will be `https://github.com/NOAA-GFDL/MOM6`. - -- `MOM_TARGET_LOCAL_BRANCH` is set to `TRAVIS_BRANCH`. - - For a code push, this is set to the name of the active branch at GitHub. For - a PR, this is the name of the branch which is receiving the PR. - -- `REPORT_COVERAGE` is set to `true`. diff --git a/.testing/README.rst b/.testing/README.rst new file mode 100644 index 0000000000..a84eeea80e --- /dev/null +++ b/.testing/README.rst @@ -0,0 +1,384 @@ +=============== +MOM6 Test Suite +=============== + +This directory contains test configurations used to evaluate submissions to the +MOM6 codebase. The tests are designed to run either locally or in a CI +environment. + + +Usage +===== + +``make -j`` + Build the FMS library and test executables. + +``make -j test`` + Run the test suite, defined in the ``tc`` directores. + +``make clean.build`` + Delete only the MOM6 test executables. + +``make clean`` + Delete the MOM6 test executables and dependency builds (FMS). + +``make -j build.unit`` + Build the unit test programs in config_src/drivers/unit_tests + +``make -j run.unit`` + Run the unit test programs from config_src/drivers/unit_tests in $(WORKSPACE)/work/unit + +``make -j build.timing`` + Build the timing test programs in config_src/drivers/timing_tests + +``make -j run.timing`` + Run the timing test programs from config_src/drivers/timing_tests in $(WORKSPACE)/work/timing + +Configuration +============= + +The test suite includes many configuration flags and variables which can be +configured at either the command line, or can be stored in a ``config.mk`` +file. + +Several of the following may require configuration for particular systems. + +``MPIRUN`` (*default:* ``mpirun``) + Name of the MPI launcher. Often this is ``mpirun`` or ``mpiexec`` but may + all need to run through a scheduler, e.g. ``srun`` if using Slurm. + +``FMS_COMMIT`` (*default:* ``2023.03``) + Set the FMS version, either by tag or commit (as defined in ``FMS_URL``). + +``FMS_URL`` (*default*: ``https://github.com/NOAA-GFDL/FMS.git``) + Set the URL of the FMS repository. + +``DO_REPRO_TESTS`` (*default:* *none*) + Set to ``true`` to test the REPRO build and confirm equivalence of DEBUG and + REPRO builds. + + For compilers with aggressive optimization, DEBUG and REPRO may not produce + identical results and this test should not be used. + +``DO_REGRESSION_TESTS`` (*default:* *none*) + Set to ``true`` to compare output with a defined target branch, set by + ``MOM_TARGET_LOCAL_BRANCH``. (NOTE: This defaults to ``dev/gfdl``). + +``DO_COVERAGE`` (*default:* *none*) + Set to ``true`` to enable code coverage. Currently only configured for + ``gcov``. + +``REQUIRE_COVERAGE_UPLOAD`` (*default:* *none*) + Set to ``true`` if failure to upload the coverage report to codecov.io + should result in an error. This should only be enabled if codecov.io has + already been configured for the user, or by a supporting CI. + +``DO_PROFILE`` (*default:* *none*) + Set to ``true`` to enable performance profile monitoring. Models are + compiled using ``OPT_FCFLAGS`` (see below) and performance of various + functions are reported and compared to the target branch. + + Results from these tests should only be considered if the platform has been + configure for benchmarking. + + +Build configuration +------------------- + +Compilation is controlled with the following variables. Defaults are chosen +for the widest compatibility across platforms. Users should modify these to +reflect their own needs. + +``FCFLAGS_DEBUG`` (*default:* ``-g -O0``) + The "DEBUG" build, for rapid compilation and debugging. + +``FCFLAGS_REPRO`` (*default:* ``-g -O2``) + The "REPRO" build, for reproducible production runs. + +``FCFLAGS_OPT`` (*default:* ``-g -O3``) + The "OPT" build, for aggressive optimization and profiling. + +``FCFLAGS_COVERAGE`` (*default:* ``-g -O0 -fbacktrace --coverage``) + Flags used for producing code coverage reports. Defaults are for gcc, + although ``--coverage`` is relatively common across compilers. + +``FCFLAGS_INIT`` (*default:* *none*) + A placeholder flag for aggressive initialization testing. This is appended + to existing flags (usually ``FCFLAGS_DEBUG``). + +``FCFLAGS_FMS`` (*default:* ``FCFLAGS_DEBUG``) + Compiler flags used for the supporting FMS library. In most cases, it is + sufficient to use ``FCFLAGS_DEBUG``. + +``LDFLAGS_COVERAGE`` (*default:* ``--coverage``) + Linker flags to enable coverage. + +``LDFLAGS_USER`` (*default:* *none*) + A placeholder for supplemental linker flags, such as an external library not + configured by autoconf. + +The following flags are passed as environment variables to other Makefiles. + +``FC``, ``MPIFC`` + The Fortran compiler and its MPI wrapper. + +``CC``, ``MPICC`` + The C compiler and its MPI wrapper. This is primarily used by FMS, but may + be used in some MOM6 autoconf tests. + +If unset, these will be configured by autoconf or from the user's environment +variables. + +Additional settings for particular tasks are explained below. + + +Example ``config.mk`` +--------------------- + +An example config.mk file configured for GFortran is shown below.:: + + DO_REPRO_TESTS = true + DO_REGRESSION_TESTS = true + DO_COVERAGE = true + DO_PROFILE = true + + FCFLAGS_DEBUG = -g -O0 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds + FCFLAGS_REPRO = -g -O2 -fbacktrace + FCFLAGS_OPT = -g -O3 -mavx -mfma + FCFLAGS_INIT = -finit-real=snan -finit-integer=2147483647 -finit-derived + FCFLAGS_COVERAGE = --coverage + +The file follows Makefile syntax, so quotations are generally not required and +spaces are permitted between assignment operators (``=``). + + +Builds +====== + +Run ``make`` to build the test executables.:: + + $ make + +This will fetch external dependencies, compile the FMS framework library, and +compile the executables used in the test suite. + +The following executables will be created. + +``build/symmetric/MOM6`` + Use symmetric grids for model fields, using DEBUG flags. + + A symmetric grid is one where each finite-volume cell has grid points along + all faces. Often this results in a redundant row of points along each side + of a regular domain. + + This is the recommended production configuration, and is the reference build + for all tests in the suite. + +``build/asymmetric/MOM6`` + Use asymmetric grids for model fields. + + Asymmetric grids eliminate a redundant fields along western and southern + boundaries, which reduces the total number of points. They also ensure + that center, face, and vertex field arrays are the same size. + + The disadvantages are greater computational complexity along these + boundaries. They also do not support open boundary conditions. + + Asymmetric grids were traditionally used in many legacy ocean models. + +``build/repro/MOM6`` + Optimized build for doing reproducible runs, based REPRO flags. + + This is only built if ``DO_REPRO_TESTS`` is set to ``true``. + +``build/target/MOM6`` + A reference build for regression testing. + + The reference branch is set by ``MOM_TARGET_LOCAL_BRANCH``. This would + generally be configured by a CI to a pull request's target branch. This is + only built if ``DO_REGRESSION_TESTS`` is set to ``true``. + +``build/openmp/MOM6`` + A DEBUG build with OpenMP enabled. + + +Tests +===== + +The ``test`` rule will run all of the tests.:: + + $ make test + +Tests are based on configurations which are designed to give identical output. +When the output differs, the test reports a failure. + + +Test groups +----------- + +The tests are gathered into the following groups. + +``test.grid`` + Compare symmetric and nonsymmetric grids. + +``test.regression`` + Compare the current codebase to a target branch (e.g. ``dev/gfdl``). + +``test.layout`` + Compare a serial (one domain) and a parallel (two domain) simulation. + +``test.restart`` + Compare a single run to two runs separated by a restart. + +``test.repro`` + Compare the unoptimized (DEBUG) and optimized (REPRO) builds. + +``test.nan`` + Enable NaN-initialization of allocated (heap) arrays. + + This relies on internal features of glibc and may not work on other + platforms. + +``test.dim`` + Enable dimension rescaling tests. + +Each tests uses the symmetric build for its reference state. + +These rules can be used to run individual groups of tests.:: + + $ make test.grid + + +Test experiments +---------------- + +For each group, we test each of the following configurations, which represent +idealizations of various production experiments. + +``tc0`` + Unit testing of various model components, based on ``unit_tests`` + +``tc1`` + A low-resolution version of the ``benchmark`` configuration + + ``tc1.a`` + Use the un-split mode with Runge-Kutta 3 time integration + + ``tc1.b`` + Use the un-split mode with Runge-Kutta 2 time integration + +``tc2`` + An ALE configuration based on tc1 with tides + + ``tc2.a`` + Use sigma, PPM_H4 and no tides + +``tc3`` + An open-boundary condition (OBC) test based on ``circle_obcs`` + +``tc4`` + Sponges and initialization using I/O + + +Test procedure +-------------- + +The test suite checks for numerical consistency of the model output across +different model configurations when subjected to relevant numerical and +mathematical transformations, such as grid layout or dimensional rescaling. If +the model state is unchanged after each transformation, then the test is +reported as passing. Any discrepancy in the model state causes the test to +fail. + +Model state is currently defined by the ``ocean.stats`` output file, which +reports the total energy (per unit mass) at machine precision alongside similar +global metrics at lower precision, such as mass or mean sea level. + +Diagnostics are based on the MOM checksum function, which includes the mean, +minimum, and maximum values, alongside a bitcount checksum, in the physical +domain, which are saved in the ``chksum_diag`` output file. + + +Regression testing +================== + +When ``DO_REGRESSION_TESTS`` is enabled, the Makefile will check out a second +copy of the repository from a specified URL and branch given by +``MOM_TARGET_URL`` and ``MOM_TARGET_BRANCH``, respectively. The code is +checked out into the ``TARGET_CODEBASE`` directory. + +The default settings, with resolved values as comments, are shown below.:: + + MOM_TARGET_SLUG = NOAA-GFDL/MOM6 + MOM_TARGET_URL = https://github.com/$(MOM_TARGET_SLUG) + #= https://github.com/NOAA-GFDL/MOM6 + MOM_TARGET_LOCAL_BRANCH = dev/gfdl + MOM_TARGET_BRANCH = origin/$(MOM_TARGET_LOCAL_BRANCH) + #= origin/dev/gfdl + TARGET_CODEBASE = $(BUILD)/target_codebase + +These default values can be configured to target a particular development +branch. + +Currently the target can only be specified by branch name, rather than hash. + +New diagnostics do not report as a fail, and are not tracked by any CIs, but +the test will report a warning to the user. + + +Code coverage +============= + +Code coverage reports the lines of code which have been tested, and can be used +to determine if a particular section is untested. + +To enable code coverage, set ``DO_COVERAGE`` to ``true``. + +Reports are stored in the build directories. There is one report per source +file, and each ends in the ``.gcov`` suffix. Two sets of coverage reports are +generated. + +``build/cov`` + Test suite code coverage + +``build/unit`` + Unit test code coverage + +To upload the tests to codecov.io, use the following rules.:: + + $ make report.cov # Test suite + $ make report.cov.unit # Unit test + +Note that any uploads will require a valid CodeCov token. If uploading through +the CI, this can be set up through your GitHub account. + +Pull request coverage reports for the CI can be checked at +https://codecov.io/gh/NOAA-GFDL/MOM6 + + +CI configuration +================ + +Whenever code is pushed to GitHub or a pull request (PR) is created, the test +suite is run. + +When the tests are run on the CI, the following variables are re-defined: + +- ``DO_REPRO_TESTS`` is set to ``true`` for all tests. + +- ``DO_REGRESSION_TESTS`` is set to ``true`` for a PR submission, and is unset for + code pushes. + +- ``DO_COVERAGE`` is set to ``true``. + + - For pull requests, ``REQUIRE_COVERAGE_UPLOAD`` is set to ``true``. + +- ``MOM_TARGET_SLUG`` is set to the URL stub of the model to be built. + + For submissions to NOAA-GFDL, this will be set to ``NOAA-GFDL/MOM6`` and the + reference URL will be ``https://github.com/NOAA-GFDL/MOM6``. + +- ``MOM_TARGET_LOCAL_BRANCH`` + + For a code push, this is set to the name of the active branch at GitHub. For + a PR, this is the name of the branch which is receiving the PR. diff --git a/.testing/tc0/MOM_input b/.testing/tc0/MOM_input index e4d1694e72..17f4826c8c 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 @@ -230,9 +233,11 @@ ENERGYSAVEDAYS = 1.0 DIAG_AS_CHKSUM = True DEBUG = True -GRID_ROTATION_ANGLE_BUGS = True ! [Boolean] default = True -USE_GM_WORK_BUG = True ! [Boolean] default = True -FIX_UNSPLIT_DT_VISC_BUG = False ! [Boolean] default = False + USE_LAND_MASK_FOR_HVISC = False ! [Boolean] default = False GUST_CONST = 0.02 ! [Pa] default = 0.02 -FIX_USTAR_GUSTLESS_BUG = False ! [Boolean] default = False + +! These are no longer necessary, as they are using the default value. +GRID_ROTATION_ANGLE_BUGS = False ! [Boolean] default = False +USE_GM_WORK_BUG = False ! [Boolean] default = False +USTAR_GUSTLESS_BUG = False ! [Boolean] default = False diff --git a/.testing/tc1.a/MOM_tc_variant b/.testing/tc1.a/MOM_tc_variant index 26407baf50..88a38a8fa8 100644 --- a/.testing/tc1.a/MOM_tc_variant +++ b/.testing/tc1.a/MOM_tc_variant @@ -1,2 +1,3 @@ -#override SPLIT=False -#override FIX_UNSPLIT_DT_VISC_BUG = False ! [Boolean] default = False +#override SPLIT = False +#override UNSPLIT_DT_VISC_BUG = False ! [Boolean] default = False +#override EQN_OF_STATE = "ROQUET_RHO" ! default = "WRIGHT_FULL" diff --git a/.testing/tc1.b/MOM_tc_variant b/.testing/tc1.b/MOM_tc_variant index 173196f164..7e3d0aa6bd 100644 --- a/.testing/tc1.b/MOM_tc_variant +++ b/.testing/tc1.b/MOM_tc_variant @@ -1,3 +1,7 @@ -#override SPLIT=False -#override USE_RK2=True -#override FIX_UNSPLIT_DT_VISC_BUG = False ! [Boolean] default = False +#override SPLIT = False +#override USE_RK2 = True +#override UNSPLIT_DT_VISC_BUG = False ! [Boolean] default = False + +! There may be a problem with one of these settings. +! #override EQN_OF_STATE = "ROQUET_SPV" ! default = "WRIGHT_FULL" +! #override BOUSSINESQ = FALSE diff --git a/.testing/tc1/MOM_input b/.testing/tc1/MOM_input index 151c093ff9..c7add5d5b7 100644 --- a/.testing/tc1/MOM_input +++ b/.testing/tc1/MOM_input @@ -72,6 +72,9 @@ MIXEDLAYER_RESTRAT = True ! [Boolean] default = False ! If true, a density-gradient dependent re-stratifying ! flow is imposed in the mixed layer. ! This is only used if BULKMIXEDLAYER is true. +USE_POROUS_BARRIER = False ! [Boolean] default = False + ! If true, use porous barrier to constrain the widths and face areas at the + ! edges of the grid cells. DT = 900.0 ! [s] ! The (baroclinic) dynamics time step. The time-step that ! is actually used will be an integer fraction of the @@ -278,6 +281,12 @@ BOUND_CORIOLIS = True ! [Boolean] default = False ! have no effect on the SADOURNY Coriolis scheme if it ! were possible to use centered difference thickness fluxes. +! === module MOM_PressureForce_FV === +MASS_WEIGHT_IN_PRESSURE_GRADIENT = True ! [Boolean] default = False + ! If true, use mass weighting when interpolating T/S for integrals + ! near the bathymetry in FV pressure gradient calculations. + + ! === module MOM_hor_visc === AH_VEL_SCALE = 0.05 ! [m s-1] default = 0.0 ! The velocity scale which is multiplied by the cube of @@ -575,14 +584,27 @@ ENERGYSAVEDAYS = 0.125 ! [days] default = 3600.0 DIAG_AS_CHKSUM = True DEBUG = True USE_PSURF_IN_EOS = False ! [Boolean] default = False -GRID_ROTATION_ANGLE_BUGS = True ! [Boolean] default = True INTERPOLATE_RES_FN = True ! [Boolean] default = True GILL_EQUATORIAL_LD = False ! [Boolean] default = False -USE_GM_WORK_BUG = True ! [Boolean] default = True USE_LAND_MASK_FOR_HVISC = False ! [Boolean] default = False -KAPPA_SHEAR_ITER_BUG = True ! [Boolean] default = True -KAPPA_SHEAR_ALL_LAYER_TKE_BUG = True ! [Boolean] default = True -BULKML_CONV_MOMENTUM_BUG = True ! [Boolean] default = True PEN_SW_ABSORB_MINTHICK = 0.001 ! [m] default = 0.001 GUST_CONST = 0.02 ! [Pa] default = 0.02 -FIX_USTAR_GUSTLESS_BUG = False ! [Boolean] default = False + + +! Updated defaults reflecting the model status in late 2025 +DRAG_DIFFUSIVITY_ANSWER_DATE = 20251231 +EQN_OF_STATE = "WRIGHT_FULL" ! default = "WRIGHT_FULL" +HOR_DIFF_ANSWER_DATE = 20251231 +MASS_WEIGHT_IN_PRESSURE_GRADIENT_TOP = True ! [Boolean] default = True + +! These are no longer necessary, as they are using the default value. +HOR_DIFF_LIMIT_BUG = False ! [Boolean] default = False +GRID_ROTATION_ANGLE_BUGS = False ! [Boolean] default = False +USE_GM_WORK_BUG = False ! [Boolean] default = False +USTAR_GUSTLESS_BUG = False ! [Boolean] default = False +KAPPA_SHEAR_ITER_BUG = False ! [Boolean] default = False +KAPPA_SHEAR_ALL_LAYER_TKE_BUG = False ! [Boolean] default = False +VISC_REM_BUG = False ! [Boolean] default = False +FRICTWORK_BUG = False ! [Boolean] default = False +BULKML_CONV_MOMENTUM_BUG = False ! [Boolean] default = False + diff --git a/.testing/tc2.a/MOM_tc_variant b/.testing/tc2.a/MOM_tc_variant index d48fa53507..5a85c21aed 100644 --- a/.testing/tc2.a/MOM_tc_variant +++ b/.testing/tc2.a/MOM_tc_variant @@ -1,3 +1,9 @@ #override TOPO_CONFIG = "spoon" #override REMAPPING_SCHEME = "PPM_H4" #override REGRIDDING_COORDINATE_MODE = "SIGMA" +MLE_USE_PBL_MLD = True +MLE%USE_BODNER23 = True +MLE%BLD_DECAYING_TFILTER = 86400. +MLE%MLD_DECAYING_TFILTER = 259200. +MLE%BLD_GROWING_TFILTER = 300. +MLE%MLD_GROWING_TFILTER = 3600. diff --git a/.testing/tc2/MOM_input b/.testing/tc2/MOM_input index ca84d1c382..fea7ca25d1 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 @@ -297,16 +300,21 @@ BOUND_CORIOLIS = True ! [Boolean] default = False ! v-points, and similarly at v-points. This option would ! have no effect on the SADOURNY Coriolis scheme if it ! were possible to use centered difference thickness fluxes. -PGF_STANLEY_T2_DET_COEFF = 0.5 ! [nondim] default = -1.0 +PGF_STANLEY_T2_DET_COEFF = -1.0 ! [nondim] default = -1.0 ! The coefficient correlating SGS temperature variance with the mean temperature ! gradient in the deterministic part of the Stanley form of the Brankart ! correction. Negative values disable the scheme. +! === module MOM_PressureForce_FV === +MASS_WEIGHT_IN_PRESSURE_GRADIENT = True ! [Boolean] default = False + ! If true, use mass weighting when interpolating T/S for integrals + ! near the bathymetry in FV pressure gradient calculations. + ! === module MOM_hor_visc === LAPLACIAN = True KH_VEL_SCALE = 0.05 SMAGORINSKY_KH = True ! [Boolean] default = False -SMAG_LAP_CONST = 0.06 ! [nondim] default = 0.0 +SMAG_LAP_CONST = 0.06 ! [nondim] default = 0.0 AH_VEL_SCALE = 0.05 ! [m s-1] default = 0.0 ! The velocity scale which is multiplied by the cube of ! the grid spacing to calculate the Laplacian viscosity. @@ -430,7 +438,7 @@ KHTH = 1.0 ! [m2 s-1] default = 0.0 ! The background horizontal thickness diffusivity. KHTH_MAX = 900.0 ! [m2 s-1] default = 0.0 ! The maximum horizontal thickness diffusivity. -STANLEY_PRM_DET_COEFF = 0.5 ! [nondim] default = -1.0 +STANLEY_PRM_DET_COEFF = -1.0 ! [nondim] default = -1.0 ! The coefficient correlating SGS temperature variance with the mean temperature ! gradient in the deterministic part of the Stanley parameterization. Negative ! values disable the scheme. @@ -608,14 +616,29 @@ ENERGYSAVEDAYS = 0.5 ! [days] default = 3600.0 ! energies of the run and other globally summed diagnostics. DIAG_AS_CHKSUM = True DEBUG = True -USE_GM_WORK_BUG = False + USE_PSURF_IN_EOS = False ! [Boolean] default = False -GRID_ROTATION_ANGLE_BUGS = True ! [Boolean] default = True REMAP_UV_USING_OLD_ALG = True ! [Boolean] default = True USE_LAND_MASK_FOR_HVISC = False ! [Boolean] default = False -KAPPA_SHEAR_ITER_BUG = True ! [Boolean] default = True -KAPPA_SHEAR_ALL_LAYER_TKE_BUG = True ! [Boolean] default = True USE_MLD_ITERATION = False ! [Boolean] default = False PEN_SW_ABSORB_MINTHICK = 0.001 ! [m] default = 0.001 GUST_CONST = 0.02 ! [Pa] default = 0.02 -FIX_USTAR_GUSTLESS_BUG = False ! [Boolean] default = False + +! Updated defaults reflecting the model status in late 2025 +EQN_OF_STATE = "WRIGHT" ! default = "WRIGHT_FULL" +TIDES_ANSWER_DATE = 20251231 +NDIFF_ANSWER_DATE = 20251231 +DRAG_DIFFUSIVITY_ANSWER_DATE = 20251231 +MASS_WEIGHT_IN_PRESSURE_GRADIENT_TOP = True ! [Boolean] default = True + +! These are no longer necessary, as they are using the default value. +GRID_ROTATION_ANGLE_BUGS = False ! [Boolean] default = False +USE_GM_WORK_BUG = False ! [Boolean] default = False +USTAR_GUSTLESS_BUG = False ! [Boolean] default = False +KAPPA_SHEAR_ITER_BUG = False ! [Boolean] default = False +KAPPA_SHEAR_ALL_LAYER_TKE_BUG = False ! [Boolean] default = False +VISC_REM_BUG = False ! [Boolean] default = False +FRICTWORK_BUG = False ! [Boolean] default = False + + +BACKSCATTER_UNDERBOUND = True diff --git a/.testing/tc2/MOM_tc_variant b/.testing/tc2/MOM_tc_variant index 8cdbf69de8..fd7e20784d 100644 --- a/.testing/tc2/MOM_tc_variant +++ b/.testing/tc2/MOM_tc_variant @@ -10,3 +10,6 @@ TIDE_Q1 = True TIDE_MF = True TIDE_MM = True TIDE_SAL_SCALAR_VALUE = 1. +BT_STRONG_DRAG = True ! [Boolean] default = False +RESCALE_STRONG_DRAG = True ! [Boolean] default = False + diff --git a/.testing/tc3/MOM_input b/.testing/tc3/MOM_input index a034960d1e..0c6a503db4 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 @@ -283,10 +286,10 @@ HMIX_FIXED = 20.0 ! [m] KV = 1.0E-04 ! [m2 s-1] ! The background kinematic viscosity in the interior. ! The molecular value, ~1e-6 m2 s-1, may be used. -KVML = 0.01 ! [m2 s-1] default = 1.0E-04 - ! The kinematic viscosity in the mixed layer. A typical - ! value is ~1e-2 m2 s-1. KVML is not used if - ! BULKMIXEDLAYER is true. The default is set by KV. +KV_ML_INVZ2 = 0.01 ! [m2 s-1] default = 0.0 + ! An extra kinematic viscosity in a mixed layer of thickness HMIX_FIXED, with + ! the actual viscosity scaling as 1/(z*HMIX_FIXED)^2, where z is the distance + ! from the surface, to allow for finite wind stresses to be transmitted through. HBBL = 10.0 ! [m] ! The thickness of a bottom boundary layer with a ! viscosity of KVBBL if BOTTOMDRAGLAW is not defined, or @@ -470,10 +473,18 @@ ENERGYSAVEDAYS = 3.0 ! [hours] default = 1.44E+04 DIAG_AS_CHKSUM = True DEBUG = True OBC_RADIATION_MAX = 10.0 ! [nondim] default = 10.0 -GRID_ROTATION_ANGLE_BUGS = True ! [Boolean] default = True -USE_GM_WORK_BUG = True ! [Boolean] default = True + USE_LAND_MASK_FOR_HVISC = False ! [Boolean] default = False -KAPPA_SHEAR_ITER_BUG = True ! [Boolean] default = True -KAPPA_SHEAR_ALL_LAYER_TKE_BUG = True ! [Boolean] default = True GUST_CONST = 0.02 ! [Pa] default = 0.02 -FIX_USTAR_GUSTLESS_BUG = False ! [Boolean] default = False + +! Updated defaults reflecting the model status in late 2025 +DRAG_DIFFUSIVITY_ANSWER_DATE = 20251231 + +! These are no longer necessary, as they are using the default value. +GRID_ROTATION_ANGLE_BUGS = False ! [Boolean] default = False +USE_GM_WORK_BUG = False ! [Boolean] default = False +USTAR_GUSTLESS_BUG = False ! [Boolean] default = False +KAPPA_SHEAR_ITER_BUG = False ! [Boolean] default = False +KAPPA_SHEAR_ALL_LAYER_TKE_BUG = False ! [Boolean] default = False +VISC_REM_BUG = False ! [Boolean] default = False +FRICTWORK_BUG = False ! [Boolean] default = False diff --git a/.testing/tc4/.gitignore b/.testing/tc4/.gitignore index 29f62fb208..0532a48da7 100644 --- a/.testing/tc4/.gitignore +++ b/.testing/tc4/.gitignore @@ -1,4 +1,17 @@ +# Autoconf +aclocal.m4 +autom4te.cache/ +config.log +config.status +configure +configure~ +Makefile + +# Output +gen_grid ocean_hgrid.nc +topog.nc + +gen_data sponge.nc temp_salt_ic.nc -topog.nc diff --git a/.testing/tc4/MOM_input b/.testing/tc4/MOM_input index e33bf40bf6..fc9c42298d 100644 --- a/.testing/tc4/MOM_input +++ b/.testing/tc4/MOM_input @@ -1,25 +1,28 @@ ! This file was written by the model and records the non-default parameters used at run-time. ! === module MOM === - -! === module MOM_unit_scaling === -! Parameters for doing unit scaling of variables. USE_REGRIDDING = True ! [Boolean] default = False ! If True, use the ALE algorithm (regridding/remapping). If False, use the ! layered isopycnal algorithm. -DT = 1200.0 ! [s] +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 ! or the coupling timestep in coupled mode.) -DT_THERM = 3600.0 ! [s] default = 300.0 +DT_THERM = 3600.0 ! [s] default = 1200.0 ! The thermodynamic and tracer advection time step. Ideally DT_THERM should be ! an integer multiple of DT and less than the forcing or coupling time-step, ! unless THERMO_SPANS_COUPLING is true, in which case DT_THERM can be an integer - ! multiple of the coupling timestep. By default DT_THERM is set to DT. + ! multiple of the coupling timestep. By default DT_THERM is set to DT. C_P = 3925.0 ! [J kg-1 K-1] default = 3991.86795711963 ! The heat capacity of sea water, approximated as a constant. This is only used ! if ENABLE_THERMODYNAMICS is true. The default value is from the TEOS-10 ! definition of conservative temperature. +USE_PSURF_IN_EOS = False ! [Boolean] default = True + ! If true, always include the surface pressure contributions in equation of + ! state calculations. SAVE_INITIAL_CONDS = False ! [Boolean] default = False ! If true, write the initial conditions to a file given by IC_OUTPUT_FILE. @@ -33,9 +36,6 @@ NJGLOBAL = 10 ! ! The total number of thickness grid points in the y-direction in the physical ! domain. With STATIC_MEMORY_ this is set in MOM_memory.h at compile time. -! === module MOM_hor_index === -! Sets the horizontal array index types. - ! === module MOM_verticalGrid === ! Parameters providing information about the vertical grid. NK = 2 ! [nondim] @@ -65,8 +65,9 @@ TOPO_CONFIG = "file" ! ! wall at the southern face. ! halfpipe - a zonally uniform channel with a half-sine ! profile in the meridional direction. + ! bbuilder - build topography from list of functions. ! benchmark - use the benchmark test case topography. - ! Neverland - use the Neverland test case topography. + ! Neverworld - use the Neverworld test case topography. ! DOME - use a slope and channel configuration for the ! DOME sill-overflow test case. ! ISOMIP - use a slope and channel configuration for the @@ -83,9 +84,6 @@ TOPO_CONFIG = "file" ! !MAXIMUM_DEPTH = 100.0 ! [m] ! The (diagnosed) maximum depth of the ocean. -! === module MOM_open_boundary === -! Controls where open boundaries are located, what kind of boundary condition to impose, and what data to apply, -! if any. ROTATION = "betaplane" ! default = "2omegasinlat" ! This specifies how the Coriolis parameter is specified: ! 2omegasinlat - Use twice the planetary rotation rate @@ -106,12 +104,10 @@ DRHO_DS = 0.0 ! [kg m-3 PSU-1] default = 0.8 ! When EQN_OF_STATE=LINEAR, this is the partial derivative of density with ! salinity. -! === module MOM_restart === - ! === module MOM_tracer_flow_control === ! === module MOM_coord_initialization === -COORD_CONFIG = "linear" ! +COORD_CONFIG = "linear" ! default = "none" ! This specifies how layers are to be defined: ! ALE or none - used to avoid defining layers in ALE mode ! file - read coordinate information from the file @@ -129,6 +125,10 @@ COORD_CONFIG = "linear" ! ! ts_profile - use temperature and salinity profiles ! (read from COORD_FILE) to set layer densities. ! USER - call a user modified routine. +REMAP_UV_USING_OLD_ALG = True ! [Boolean] default = False + ! If true, uses the old remapping-via-a-delta-z method for remapping u and v. If + ! false, uses the new method that remaps between grids described by an old and + ! new thickness. REGRIDDING_COORDINATE_MODE = "Z*" ! default = "LAYER" ! Coordinate mode for vertical regridding. Choose among the following ! possibilities: LAYER - Isopycnal or stacked shallow water layers @@ -137,6 +137,7 @@ REGRIDDING_COORDINATE_MODE = "Z*" ! default = "LAYER" ! SIGMA - terrain following coordinates ! RHO - continuous isopycnal ! HYCOM1 - HyCOM-like hybrid coordinate + ! HYBGEN - Hybrid coordinate from the Hycom hybgen code ! SLIGHT - stretched coordinates above continuous isopycnal ! ADAPTIVE - optimize for smooth neutral density surfaces !ALE_RESOLUTION = 2*50.0 ! [m] @@ -150,14 +151,14 @@ REMAPPING_SCHEME = "PPM_IH4" ! default = "PLM" ! variables. It can be one of the following schemes: PCM (1st-order ! accurate) ! PLM (2nd-order accurate) + ! PLM_HYBGEN (2nd-order accurate) ! PPM_H4 (3rd-order accurate) ! PPM_IH4 (3rd-order accurate) + ! PPM_HYBGEN (3rd-order accurate) + ! WENO_HYBGEN (3rd-order accurate) ! PQM_IH4IH3 (4th-order accurate) ! PQM_IH6IH5 (5th-order accurate) -! === module MOM_grid === -! Parameters providing information about the lateral grid. - ! === module MOM_state_initialization === INIT_LAYERS_FROM_Z_FILE = True ! [Boolean] default = False ! If true, initialize the layer thicknesses, temperatures, and salinities from a @@ -181,9 +182,9 @@ SPONGE_PTEMP_VAR = "ptemp" ! default = "PTEMP" ! The name of the potential temperature variable in SPONGE_STATE_FILE. SPONGE_SALT_VAR = "salt" ! default = "SALT" ! The name of the salinity variable in SPONGE_STATE_FILE. -NEW_SPONGES = True ! [of sponge restoring data.] default = False - ! Set True if using the newer sponging code which performs on-the-fly regridding - ! in lat-lon-time. +INTERPOLATE_SPONGE_TIME_SPACE = True ! [Boolean] default = False + ! If True, perform on-the-fly regridding in lat-lon-time of sponge restoring + ! data. ! === module MOM_sponge === SPONGE_DATA_ONGRID = True ! [Boolean] default = False @@ -192,8 +193,9 @@ SPONGE_DATA_ONGRID = True ! [Boolean] default = False ! The total number of columns where sponges are applied at h points. ! === module MOM_diag_mediator === - -! === module MOM_MEKE === +DIAG_AS_CHKSUM = True ! [Boolean] default = False + ! Instead of writing diagnostics to the diag manager, write a text file + ! containing the checksum (bitcount) of the array. ! === module MOM_lateral_mixing_coeffs === @@ -202,10 +204,10 @@ LINEAR_DRAG = True ! [Boolean] default = False ! If LINEAR_DRAG and BOTTOMDRAGLAW are defined the drag law is ! cdrag*DRAG_BG_VEL*u. HBBL = 10.0 ! [m] - ! The thickness of a bottom boundary layer with a viscosity of KVBBL if - ! BOTTOMDRAGLAW is not defined, or the thickness over which near-bottom - ! velocities are averaged for the drag law if BOTTOMDRAGLAW is defined but - ! LINEAR_DRAG is not. + ! The thickness of a bottom boundary layer with a viscosity increased by + ! KV_EXTRA_BBL if BOTTOMDRAGLAW is not defined, or the thickness over which + ! near-bottom velocities are averaged for the drag law if BOTTOMDRAGLAW is + ! defined but LINEAR_DRAG is not. CDRAG = 0.002 ! [nondim] default = 0.003 ! CDRAG is the drag coefficient relating the magnitude of the velocity field to ! the bottom stress. CDRAG is only used if BOTTOMDRAGLAW is defined. @@ -214,7 +216,7 @@ DRAG_BG_VEL = 0.05 ! [m s-1] default = 0.0 ! unresolved velocity that is combined with the resolved velocity to estimate ! the velocity magnitude. DRAG_BG_VEL is only used when BOTTOMDRAGLAW is ! defined. -BBL_USE_EOS = True ! [Boolean] default = False +BBL_USE_EOS = True ! [Boolean] default = True ! If true, use the equation of state in determining the properties of the bottom ! boundary layer. Otherwise use the layer target potential densities. BBL_THICK_MIN = 0.1 ! [m] default = 0.0 @@ -228,6 +230,10 @@ KV = 1.0E-04 ! [m2 s-1] ! === module MOM_thickness_diffuse === KHTH = 500.0 ! [m2 s-1] default = 0.0 ! The background horizontal thickness diffusivity. + +! === module MOM_porous_barriers === + +! === module MOM_dynamics_split_RK2 === BE = 0.7 ! [nondim] default = 0.6 ! If SPLIT is true, BE determines the relative weighting of a 2nd-order ! Runga-Kutta baroclinic time stepping scheme (0.5) and a backward Euler scheme @@ -258,7 +264,10 @@ BOUND_CORIOLIS = True ! [Boolean] default = False ! === module MOM_PressureForce === -! === module MOM_PressureForce_AFV === +! === module MOM_PressureForce_FV === +MASS_WEIGHT_IN_PRESSURE_GRADIENT = True ! [Boolean] default = False + ! If true, use mass weighting when interpolating T/S for integrals + ! near the bathymetry in FV pressure gradient calculations. RECONSTRUCT_FOR_PRESSURE = False ! [Boolean] default = True ! If True, use vertical reconstruction of T & S within the integrals of the FV ! pressure gradient calculation. If False, use the constant-by-layer algorithm. @@ -269,17 +278,25 @@ SMAGORINSKY_AH = True ! [Boolean] default = False ! If true, use a biharmonic Smagorinsky nonlinear eddy viscosity. SMAG_BI_CONST = 0.03 ! [nondim] default = 0.0 ! The nondimensional biharmonic Smagorinsky constant, typically 0.015 - 0.06. +USE_LAND_MASK_FOR_HVISC = False ! [Boolean] default = True + ! If true, use the land mask for the computation of thicknesses at velocity + ! locations. This eliminates the dependence on arbitrary values over land or + ! outside of the domain. ! === module MOM_vert_friction === DIRECT_STRESS = True ! [Boolean] default = False ! If true, the wind stress is distributed over the topmost HMIX_STRESS of fluid - ! (like in HYCOM), and KVML may be set to a very small value. + ! (like in HYCOM), and an added mixed layer viscosity or a physically based + ! boundary layer turbulence parameterization is not needed for stability. HMIX_FIXED = 20.0 ! [m] ! The prescribed depth over which the near-surface viscosity and diffusivity are ! elevated when the bulk mixed layer is not used. -KVML = 0.01 ! [m2 s-1] default = 1.0E-04 - ! The kinematic viscosity in the mixed layer. A typical value is ~1e-2 m2 s-1. - ! KVML is not used if BULKMIXEDLAYER is true. The default is set by KV. +KV_ML_INVZ2 = 0.01 ! [m2 s-1] default = 0.0 + ! An extra kinematic viscosity in a mixed layer of thickness HMIX_FIXED, with + ! the actual viscosity scaling as 1/(z*HMIX_FIXED)^2, where z is the distance + ! from the surface, to allow for finite wind stresses to be transmitted through + ! infinitesimally thin surface layers. This is an older option for numerical + ! convenience without a strong physical basis, and its use is now discouraged. MAXVEL = 10.0 ! [m s-1] default = 3.0E+08 ! The maximum velocity allowed before the velocity components are truncated. @@ -304,23 +321,11 @@ DTBT = 10.0 ! [s or nondim] default = -0.98 ! DTBT to 0 is the same as setting it to -0.98. The value of DTBT that will ! actually be used is an integer fraction of DT, rounding down. -! === module MOM_mixed_layer_restrat === +! === module MOM_diagnostics === ! === module MOM_diabatic_driver === ! The following parameters are used for diabatic processes. -! === module MOM_CVMix_KPP === -! This is the MOM wrapper to CVMix:KPP -! See http://cvmix.github.io/ - -! === module MOM_tidal_mixing === -! Vertical Tidal Mixing Parameterization - -! === module MOM_CVMix_conv === -! Parameterization of enhanced mixing due to convection via CVMix - -! === module MOM_entrain_diffusive === - ! === module MOM_set_diffusivity === BBL_EFFIC = 0.0 ! [nondim] default = 0.2 ! The efficiency with which the energy extracted by bottom drag drives BBL @@ -332,29 +337,18 @@ KD = 0.0 ! [m2 s-1] ! The background diapycnal diffusivity of density in the interior. Zero or the ! molecular value, ~1e-7 m2 s-1, may be used. -! === module MOM_kappa_shear === -! Parameterization of shear-driven turbulence following Jackson, Hallberg and Legg, JPO 2008 - -! === module MOM_CVMix_shear === -! Parameterization of shear-driven turbulence via CVMix (various options) - -! === module MOM_CVMix_ddiff === -! Parameterization of mixing due to double diffusion processes via CVMix - ! === module MOM_diabatic_aux === ! The following parameters are used for auxiliary diabatic processes. -! === module MOM_regularize_layers === - ! === module MOM_opacity === +PEN_SW_ABSORB_MINTHICK = 0.001 ! [m] default = 1.0 + ! A thickness that is used to absorb the remaining penetrating shortwave heat + ! flux when it drops below PEN_SW_FLUX_ABSORB. ! === module MOM_tracer_advect === ! === module MOM_tracer_hor_diff === -! === module MOM_neutral_diffusion === -! This module implements neutral diffusion of tracers - ! === module MOM_sum_output === MAXTRUNC = 5000 ! [truncations save_interval-1] default = 0 ! The run will be stopped, and the day set to a very large value if the velocity @@ -362,6 +356,9 @@ MAXTRUNC = 5000 ! [truncations save_interval-1] default = 0 ! to stop if there is any truncation of velocities. DATE_STAMPED_STDOUT = False ! [Boolean] default = True ! If true, use dates (not times) in messages to stdout +ENERGYSAVEDAYS = 0.125 ! [days] default = 1.0 + ! The interval in units of TIMEUNIT between saves of the energies of the run and + ! other globally summed diagnostics. ! === module MOM_surface_forcing === VARIABLE_WINDS = False ! [Boolean] default = True @@ -375,19 +372,14 @@ BUOY_CONFIG = "zero" ! WIND_CONFIG = "zero" ! ! The character string that indicates how wind forcing is specified. Valid ! options include (file), (2gyre), (1gyre), (gyres), (zero), and (USER). - -! === module MOM_restart === +GUST_CONST = 0.02 ! [Pa] default = 0.0 + ! The background gustiness in the winds. ! === module MOM_main (MOM_driver) === -DAYMAX = 0.25 ! [days] +DAYMAX = 0.25 ! [days] ! The final time of the whole simulation, in units of TIMEUNIT seconds. This ! also sets the potential end time of the present run segment if the end time is ! not set via ocean_solo_nml in input.nml. - -ENERGYSAVEDAYS = 0.125 ! [days] default = 1.44E+04 - ! The interval in units of TIMEUNIT between saves of the - ! energies of the run and other globally summed diagnostics. - RESTART_CONTROL = 3 ! default = 1 ! An integer whose bits encode which restart files are written. Add 2 (bit 1) ! for a time-stamped file, and odd (bit 0) for a non-time-stamped file. A @@ -405,21 +397,20 @@ MAXCPU = 2.88E+04 ! [wall-clock seconds] default = -1.0 ! === module MOM_file_parser === -DIAG_AS_CHKSUM = True DEBUG = True -USE_PSURF_IN_EOS = False ! [Boolean] default = False -GRID_ROTATION_ANGLE_BUGS = True ! [Boolean] default = True INTERPOLATE_RES_FN = True ! [Boolean] default = True GILL_EQUATORIAL_LD = False ! [Boolean] default = False -USE_GM_WORK_BUG = True ! [Boolean] default = True -FIX_UNSPLIT_DT_VISC_BUG = False ! [Boolean] default = False -REMAP_UV_USING_OLD_ALG = True ! [Boolean] default = True USE_LAND_MASK_FOR_HVISC = False ! [Boolean] default = False -KAPPA_SHEAR_ITER_BUG = True ! [Boolean] default = True -KAPPA_SHEAR_ALL_LAYER_TKE_BUG = True ! [Boolean] default = True USE_MLD_ITERATION = False ! [Boolean] default = False -PEN_SW_ABSORB_MINTHICK = 0.001 ! [m] default = 0.001 -GUST_CONST = 0.02 ! [Pa] default = 0.02 -FIX_USTAR_GUSTLESS_BUG = False ! [Boolean] default = False +MASS_WEIGHT_IN_PRESSURE_GRADIENT_TOP = True ! [Boolean] default = True + +! These are no longer necessary, as they are using the default value. +GRID_ROTATION_ANGLE_BUGS = False ! [Boolean] default = False +USE_GM_WORK_BUG = False ! [Boolean] default = False +USTAR_GUSTLESS_BUG = False ! [Boolean] default = False +KAPPA_SHEAR_ITER_BUG = False ! [Boolean] default = False +KAPPA_SHEAR_ALL_LAYER_TKE_BUG = False ! [Boolean] default = False +VISC_REM_BUG = False ! [Boolean] default = False +FRICTWORK_BUG = False ! [Boolean] default = False diff --git a/.testing/tc4/Makefile b/.testing/tc4/Makefile deleted file mode 100644 index a9aa395b9c..0000000000 --- a/.testing/tc4/Makefile +++ /dev/null @@ -1,8 +0,0 @@ -OUT=ocean_hgrid.nc sponge.nc temp_salt_ic.nc topog.nc - -$(OUT): - python build_grid.py - python build_data.py - -clean: - rm -rf $(OUT) diff --git a/.testing/tc4/Makefile.in b/.testing/tc4/Makefile.in new file mode 100644 index 0000000000..4d2e40a1bb --- /dev/null +++ b/.testing/tc4/Makefile.in @@ -0,0 +1,64 @@ +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + +FC = @FC@ +LD = @LD@ +FCFLAGS = @FCFLAGS@ +LDFLAGS = @LDFLAGS@ +LIBS = @LIBS@ + +LAUNCHER ?= + +OUT = ocean_hgrid.nc topog.nc temp_salt_ic.nc sponge.nc + +# Since each program generates two outputs, we can only use one to track the +# creation. The second rule is used to indirectly re-invoke the first rule. +# +# Reference: +# https://www.gnu.org/software/automake/manual/html_node/Multiple-Outputs.html + +# Program output +all: ocean_hgrid.nc temp_salt_ic.nc +executables: gen_data gen_grid + +ocean_hgrid.nc: gen_grid + $(LAUNCHER) ./gen_grid +topog.nc: ocean_hgrid.nc + @test -f $@ || rm -f $^ + @test -f $@ || $(MAKE) $^ + +temp_salt_ic.nc: gen_data ocean_hgrid.nc + $(LAUNCHER) ./gen_data +sponge.nc: temp_salt_ic.nc + @test -f $@ || rm -f $^ + @test -f $@ || $(MAKE) $^ + + +# Programs + +gen_grid: gen_grid.F90 + $(FC) $(FCFLAGS) $(LDFLAGS) -o $@ $^ $(LIBS) + +gen_data: gen_data.F90 + $(FC) $(FCFLAGS) $(LDFLAGS) -o $@ $^ $(LIBS) + + +# Support + +.PHONY: clean +clean: + rm -rf $(OUT) gen_grid gen_data + +.PHONY: distclean +distclean: clean + rm -f config.log + rm -f config.status + rm -f Makefile + +.PHONY: ac-clean +ac-clean: distclean + rm -f aclocal.m4 + rm -rf autom4te.cache + rm -f configure + rm -f configure~ diff --git a/.testing/tc4/build_data.py b/.testing/tc4/build_data.py deleted file mode 100644 index e060d05cb1..0000000000 --- a/.testing/tc4/build_data.py +++ /dev/null @@ -1,80 +0,0 @@ -import netCDF4 as nc -import numpy as np - -x = nc.Dataset('ocean_hgrid.nc').variables['x'][1::2, 1::2] -y = nc.Dataset('ocean_hgrid.nc').variables['y'][1::2, 1::2] -zbot = nc.Dataset('topog.nc').variables['depth'][:] -zbot0 = zbot.max() - - -def t_fc(x, y, z, radius=5.0, tmag=1.0): - """a radially symmetric anomaly in the center of the domain. - units are meters and degC. - """ - ny, nx = x.shape - nz = z.shape[0] - - x0 = x[int(ny/2), int(nx/2)] - y0 = y[int(ny/2), int(nx/2)] - - tl = np.zeros((nz, ny, nx)) - zb = z[-1] - if len(z) > 1: - zd = z / zb - else: - zd = [0.] - for k in np.arange(len(zd)): - r = np.sqrt((x - x0)**2 + (y - y0)**2) - tl[k, :] += (1.0 - np.minimum(r / radius, 1.0)) * tmag * (1.0 - zd[k]) - return tl - - -ny, nx = x.shape -nz = 3 -z = (np.arange(nz) * zbot0) / nz - -temp = t_fc(x, y, z) -salt = np.zeros(temp.shape)+35.0 -fl = nc.Dataset('temp_salt_ic.nc', 'w', format='NETCDF3_CLASSIC') -fl.createDimension('lon', nx) -fl.createDimension('lat', ny) -fl.createDimension('depth', nz) -fl.createDimension('Time', None) -zv = fl.createVariable('depth', 'f8', ('depth')) -lonv = fl.createVariable('lon', 'f8', ('lon')) -latv = fl.createVariable('lat', 'f8', ('lat')) -timev = fl.createVariable('Time', 'f8', ('Time')) -timev.calendar = 'noleap' -timev.units = 'days since 0001-01-01 00:00:00.0' -timev.modulo = ' ' -tv = fl.createVariable('ptemp', 'f8', ('Time', 'depth', 'lat', 'lon'), - fill_value=-1.e20) -sv = fl.createVariable('salt', 'f8', ('Time', 'depth', 'lat', 'lon'), - fill_value=-1.e20) -tv[:] = temp[np.newaxis, :] -sv[:] = salt[np.newaxis, :] -zv[:] = z -lonv[:] = x[0, :] -latv[:] = y[:, 0] -timev[0] = 0. -fl.sync() -fl.close() - - -# Make Sponge forcing file -dampTime = 20.0 # days -secDays = 8.64e4 -fl = nc.Dataset('sponge.nc', 'w', format='NETCDF3_CLASSIC') -fl.createDimension('lon', nx) -fl.createDimension('lat', ny) -lonv = fl.createVariable('lon', 'f8', ('lon')) -latv = fl.createVariable('lat', 'f8', ('lat')) -spv = fl.createVariable('Idamp', 'f8', ('lat', 'lon'), fill_value=-1.e20) -Idamp = np.zeros((ny, nx)) -if dampTime > 0.: - Idamp = 0.0 + 1.0 / (dampTime * secDays) -spv[:] = Idamp -lonv[:] = x[0, :] -latv[:] = y[:, 0] -fl.sync() -fl.close() diff --git a/.testing/tc4/build_grid.py b/.testing/tc4/build_grid.py deleted file mode 100644 index 7f1be74efd..0000000000 --- a/.testing/tc4/build_grid.py +++ /dev/null @@ -1,76 +0,0 @@ -import netCDF4 as nc -from netCDF4 import stringtochar -import numpy as np - -nx, ny = 14, 10 # Grid size -depth0 = 100. # Uniform depth -ds = 0.01 # grid resolution at the equator in degrees -Re = 6.378e6 # Radius of earth - -topo_ = np.zeros((ny, nx)) + depth0 -f_topo = nc.Dataset('topog.nc', 'w', format='NETCDF3_CLASSIC') -ny, nx = topo_.shape -f_topo.createDimension('ny', ny) -f_topo.createDimension('nx', nx) -f_topo.createDimension('ntiles', 1) -f_topo.createVariable('depth', 'f8', ('ny', 'nx')) -f_topo.createVariable('h2', 'f8', ('ny', 'nx')) -f_topo.variables['depth'][:] = topo_ -f_topo.sync() -f_topo.close() - -x_ = np.arange(0, 2*nx + 1) * ds # units are degrees E -y_ = np.arange(0, 2*ny + 1) * ds # units are degrees N -x, y = np.meshgrid(x_, y_) - -dx = np.zeros((2*ny + 1, 2*nx)) -dy = np.zeros((2*ny, 2*nx + 1)) -rad_deg = np.pi / 180. -dx[:] = (rad_deg * Re * (x[:, 1:] - x[:, 0:-1]) - * np.cos(0.5*rad_deg*(y[:, 0:-1] + y[:, 1:]))) -dy[:] = rad_deg * Re * (y[1:, :] - y[0:-1, :]) - -f_sg = nc.Dataset('ocean_hgrid.nc', 'w', format='NETCDF3_CLASSIC') -f_sg.createDimension('ny', 2*ny) -f_sg.createDimension('nx', 2*nx) -f_sg.createDimension('nyp', 2*ny + 1) -f_sg.createDimension('nxp', 2*nx + 1) -f_sg.createDimension('string', 5) -f_sg.createVariable('y', 'f8', ('nyp', 'nxp')) -f_sg.createVariable('x', 'f8', ('nyp', 'nxp')) -dyv = f_sg.createVariable('dy', 'f8', ('ny', 'nxp')) -dxv = f_sg.createVariable('dx', 'f8', ('nyp', 'nx')) -areav = f_sg.createVariable('area', 'f8', ('ny', 'nx')) -dxv.units = 'm' -dyv.units = 'm' -areav.units = 'm2' -f_sg.createVariable('angle_dx', 'f8', ('nyp', 'nxp')) -f_sg.createVariable('tile', 'S1', ('string')) -f_sg.variables['y'].units = 'degrees' -f_sg.variables['x'].units = 'degrees' -f_sg.variables['dy'].units = 'meters' -f_sg.variables['dx'].units = 'meters' -f_sg.variables['area'].units = 'm2' -f_sg.variables['angle_dx'].units = 'degrees' -f_sg.variables['y'][:] = y -f_sg.variables['x'][:] = x -f_sg.variables['dx'][:] = dx -f_sg.variables['dy'][:] = dy - -# Compute the area bounded by lines of constant -# latitude-longitud on a sphere in m2. -dlon = x_[1:] - x_[:-1] -dlon = np.tile(dlon[np.newaxis, :], (2*ny, 1)) -y1_ = y_[:-1] -y1_ = y1_[:, np.newaxis]*rad_deg -y2_ = y_[1:] -y2_ = y2_[:, np.newaxis]*rad_deg -y1_ = np.tile(y1_, (1, 2*nx)) -y2_ = np.tile(y2_, (1, 2*nx)) -area = rad_deg * Re * Re * (np.sin(y2_) - np.sin(y1_)) * dlon -f_sg.variables['area'][:] = area -f_sg.variables['angle_dx'][:] = 0. -str_ = stringtochar(np.array(['tile1'], dtype='S5')) -f_sg.variables['tile'][:] = str_ -f_sg.sync() -f_sg.close() diff --git a/.testing/tc4/configure.ac b/.testing/tc4/configure.ac new file mode 100644 index 0000000000..2ec7e2af44 --- /dev/null +++ b/.testing/tc4/configure.ac @@ -0,0 +1,80 @@ +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + +# tc4 preprocessor configuration +AC_PREREQ([2.63]) +AC_INIT([], []) + +# Validate srdcir and configure input +AC_CONFIG_SRCDIR([gen_grid.F90]) +AC_CONFIG_MACRO_DIR([../../ac/m4]) + + +# Explicitly assume free-form Fortran +AC_LANG([Fortran]) +AC_FC_SRCEXT([f90]) + +# We do not need MPI, but we want to emulate the executable used in MOM6 +AX_MPI([], [AC_MSG_ERROR([Could not find MPI launcher.])]) +AC_SUBST([FC], [$MPIFC]) +AC_SUBST([LD], [$MPILD]) + + +# netCDF configuration + +# Search for the Fortran netCDF module. +AX_FC_CHECK_MODULE([netcdf], [], [ + AS_UNSET([ax_fc_cv_mod_netcdf]) + AC_PATH_PROG([NF_CONFIG], [nf-config]) + AS_IF([test -n "$NF_CONFIG"], [ + AC_SUBST([FCFLAGS], ["$FCFLAGS -I$($NF_CONFIG --includedir)"]) + ], [AC_MSG_ERROR([Could not find nf-config.])] + ) + AX_FC_CHECK_MODULE([netcdf], [], [ + AC_MSG_ERROR([Could not find netcdf module.]) + ]) +]) + +# Confirm that the Fortran compiler can link the netCDF C library +AX_FC_CHECK_C_LIB([netcdf], [nc_create], [], [ + AS_UNSET([ax_fc_cv_c_lib_netcdf_nc_create]) + AC_PATH_PROG([NC_CONFIG], [nc-config]) + AS_IF([test -n "$NC_CONFIG"], [ + AC_SUBST([LDFLAGS], ["$LDFLAGS -L$($NC_CONFIG --libdir)"]) + ], [ + AC_MSG_ERROR([Could not find nc-config.]) + ]) + AX_FC_CHECK_C_LIB([netcdf], [nc_create], [], [ + AC_MSG_ERROR([Could not find netCDF C library.]) + ]) +]) + +# Confirm that the Fortran compiler can link to the netCDF Fortran library. +# NOTE: nf-config does not have --libdir, so we parse the --flibs output. +MOM6_FC_CHECK_LIB([netcdff], [nf90_create], [netcdf], [path,cmode,ncid], [rc], [ + character :: path + integer :: cmode, ncid, rc], + [], [ + AS_UNSET([mom6_fc_cv_lib_netcdff_nf90_create]) + AC_PATH_PROG([NF_CONFIG], [nf-config]) + AS_IF([test -n "$NF_CONFIG"], [ + AC_SUBST([LDFLAGS], + ["$LDFLAGS $($NF_CONFIG --flibs | xargs -n1 | grep "^-L" | sort -u | xargs)"] + ) + ], [ + AC_MSG_ERROR([Could not find nf-config.]) + ]) + MOM6_FC_CHECK_LIB([netcdff], [nf90_create], [netcdf], [path,cmode,ncid], [rc], [ + character :: path + integer :: cmode, ncid, rc], + [], [ + AC_MSG_ERROR([Could not find netCDF Fortran library.]) + ] + ) + ] +) + + +AC_CONFIG_FILES([Makefile]) +AC_OUTPUT diff --git a/.testing/tc4/gen_data.F90 b/.testing/tc4/gen_data.F90 new file mode 100644 index 0000000000..406d44e54a --- /dev/null +++ b/.testing/tc4/gen_data.F90 @@ -0,0 +1,193 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +use netcdf +implicit none + +integer, parameter :: dp = selected_real_kind(10, 100) + !! Double precision (8-byte) + +integer, parameter :: nz = 3 + !! Number of vertical layers +real(kind=dp), parameter :: salt0 = 35._dp + !! Background salinity +real(kind=dp), parameter :: dampTime = 20._dp + !! Sponge damping timescale [days] +real(kind=dp), parameter :: secs_per_day = 86400._dp + !! Seconds per calendar day + +integer :: ncid + +integer :: x_id, y_id +integer :: lon_dimid, lat_dimid, depth_dimid, time_dimid +integer :: lon_id, lat_id, depth_id, time_id, temp_id, salt_id, idamp_id +integer :: field_dimids(2) +integer :: nx, ny + +integer :: i, rc + +real(kind=dp), allocatable :: x(:,:), y(:,:), z(:) + !! Temperature grid positions +real(kind=dp), allocatable :: zbot(:,:) + !! Bottom topography +real(kind=dp) :: zbot0 + !! Maximum topographic depth +real(kind=dp), allocatable :: temp(:,:,:), salt(:,:,:) + !! Initial temperature and salinity fields +real(kind=dp), allocatable :: Idamp(:,:) + !! Sponge dampening rate + +! Read the domain grid +rc = nf90_open('ocean_hgrid.nc', NF90_NOWRITE, ncid) + +rc = nf90_inq_varid(ncid, 'x', x_id) +rc = nf90_inq_varid(ncid, 'y', y_id) + +rc = nf90_inquire_variable(ncid, x_id, dimids=field_dimids) +rc = nf90_inquire_dimension(ncid, field_dimids(1), len=nx) +rc = nf90_inquire_dimension(ncid, field_dimids(2), len=ny) + +! Extract center ("T") points of supergrid +nx = nx / 2 +ny = ny / 2 +allocate(x(nx, ny), y(nx, ny)) +rc = nf90_get_var(ncid, x_id, x, start=[2,2], stride=[2,2]) +rc = nf90_get_var(ncid, y_id, y, start=[2,2], stride=[2,2]) + +rc = nf90_close(ncid) + + +! Read the topographic domain +rc = nf90_open('topog.nc', NF90_NOWRITE, ncid) + +rc = nf90_inq_varid(ncid, 'depth', depth_id) +rc = nf90_inquire_variable(ncid, depth_id, dimids=field_dimids) +rc = nf90_inquire_dimension(ncid, field_dimids(1), len=nx) +rc = nf90_inquire_dimension(ncid, field_dimids(2), len=ny) + +allocate(zbot(nx, ny)) +rc = nf90_get_var(ncid, depth_id, zbot) +rc = nf90_close(ncid) + + +! Construct the vertical axis +allocate(z(nz)) +z = [(i, i=0,nz-1)] * maxval(zbot) / nz + +allocate(temp(nx, ny, nz), salt(nx, ny, nz)) +call t_fc(x, y, z, temp) +salt(:,:,:) = salt0 + + +! Write T/S initial state +rc = nf90_create('temp_salt_ic.nc', NF90_CLOBBER, ncid) + +rc = nf90_def_dim(ncid, 'lon', nx, lon_dimid) +rc = nf90_def_dim(ncid, 'lat', ny, lat_dimid) +rc = nf90_def_dim(ncid, 'depth', nz, depth_dimid) +rc = nf90_def_dim(ncid, 'Time', NF90_UNLIMITED, time_dimid) + +rc = nf90_def_var(ncid, 'depth', NF90_DOUBLE, [depth_dimid], depth_id) +rc = nf90_def_var(ncid, 'lon', NF90_DOUBLE, [lon_dimid], lon_id) +rc = nf90_def_var(ncid, 'lat', NF90_DOUBLE, [lat_dimid], lat_id) +rc = nf90_def_var(ncid, 'Time', NF90_DOUBLE, [time_dimid], time_id) + +rc = nf90_put_att(ncid, time_id, 'calendar', 'noleap') +rc = nf90_put_att(ncid, time_id, 'units', 'days since 0001-01-01 00:00:00.0') +! NOTE: nf90_put_att() truncates empty strings, so use nf90_put_att_any() +rc = nf90_put_att_any(ncid, time_id, 'modulo', NF90_CHAR, 1, ' ') + +rc = nf90_def_var(ncid, 'ptemp', NF90_DOUBLE, & + [lon_dimid, lat_dimid, depth_dimid, time_dimid], temp_id) +rc = nf90_def_var_fill(ncid, temp_id, 0, -1e20_dp) + +rc = nf90_def_var(ncid, 'salt', NF90_DOUBLE, & + [lon_dimid, lat_dimid, depth_dimid, time_dimid], salt_id) +rc = nf90_def_var_fill(ncid, salt_id, 0, -1e20_dp) + +rc = nf90_enddef(ncid) + +rc = nf90_put_var(ncid, lon_id, x(:,1)) +rc = nf90_put_var(ncid, lat_id, y(1,:)) +rc = nf90_put_var(ncid, depth_id, z) +rc = nf90_put_var(ncid, time_id, 0.) +rc = nf90_put_var(ncid, temp_id, temp) +rc = nf90_put_var(ncid, salt_id, salt) + +rc = nf90_close(ncid) + + +! Sponge file +rc = nf90_create('sponge.nc', NF90_CLOBBER, ncid) + +rc = nf90_def_dim(ncid, 'lon', nx, lon_dimid) +rc = nf90_def_dim(ncid, 'lat', ny, lat_dimid) + +rc = nf90_def_var(ncid, 'lon', NF90_DOUBLE, lon_id) +rc = nf90_def_var(ncid, 'lat', NF90_DOUBLE, lat_id) +rc = nf90_def_var(ncid, 'Idamp', NF90_DOUBLE, [lon_dimid, lat_dimid], Idamp_id) +rc = nf90_def_var_fill(ncid, Idamp_id, 0, -1e20_dp) + +rc = nf90_enddef(ncid) + +allocate(Idamp(nx, ny)) +Idamp = 0. +if (dampTime > 0.) & + Idamp(:,:) = 1. / (dampTime * secs_per_day) + +rc = nf90_put_var(ncid, Idamp_id, Idamp) +rc = nf90_put_var(ncid, lon_id, x(:,1)) +rc = nf90_put_var(ncid, lat_id, y(1,:)) + +rc = nf90_close(ncid) + +contains + +subroutine t_fc(x, y, z, tl, radius, tmag) + real(kind=dp), intent(in) :: x(:,:), y(:,:), z(:) + !! Grid positions + real(kind=dp), intent(inout) :: tl(:,:,:) + !! Temperature field on the model grid + real(kind=dp), intent(in), optional :: radius + !! Temperature anomaly radius + real(kind=dp), intent(in), optional :: tmag + !! Temperature anomaly maximum + + real(kind=dp) :: t_rad, t_max + !! Temperature field parameters (radius, max value) + real(kind=dp) :: x0, y0 + !! Center of anomaly (currently midpoint of domain) + real(kind=dp), allocatable :: r(:,:), zd(:) + !! Radial and vertical extent of anomaly + integer :: k, nz + !! Vertical level indexing + + t_rad = 5._dp + if (present(radius)) t_rad = radius + + t_max = 1._dp + if (present(tmag)) t_max = tmag + + ! Reduce supergrid size to T/S grid + allocate(zd, source=z) + + x0 = x(1 + size(x, 1)/2, 1 + size(x, 2)/2) + y0 = y(1 + size(y, 1)/2, 1 + size(y, 2)/2) + + tl(:,:,:) = 0. + nz = size(z) + if (nz > 1) then + zd(:) = z(:) / z(nz) + else + zd(:) = 0. + endif + + allocate(r, source=x) + r(:,:) = hypot(x(:,:) - x0, y(:,:) - y0) + do k = 1, nz + tl(:,:,k) = (1. - min(r(:,:) / t_rad, 1.)) * t_max * (1. - zd(k)) + enddo +end subroutine t_fc + +end diff --git a/.testing/tc4/gen_grid.F90 b/.testing/tc4/gen_grid.F90 new file mode 100644 index 0000000000..4ddabb7846 --- /dev/null +++ b/.testing/tc4/gen_grid.F90 @@ -0,0 +1,112 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +use netcdf + +implicit none + +integer, parameter :: dp = selected_real_kind(10, 100) + !! Double precision (8-byte) + +integer, parameter :: nx = 14, ny = 10 + !! Grid size +real(kind=dp), parameter :: depth0 = 100._dp + !! Uniform depth +real(kind=dp), parameter :: ds = 0.01_dp + !! Grid resolution at the equator in degrees +real(kind=dp), parameter :: Re = 6.378e6_dp + !! Radius of earth +real(kind=dp), parameter :: rad_per_deg = (4. * atan(1._dp)) / 180._dp + !! Degress to radians (= pi/180.) + +integer :: ncid +integer :: nx_id, ny_id, nxp_id, nyp_id, ntile_id, string_id +integer :: depth_id, h2_id +integer :: x_id, y_id, dx_id, dy_id, area_id, angle_id, tile_id + +! Fields on model grid +real(kind=dp) :: depth(nx, ny) + +! Grid fields (defined on supergrid) +real(kind=dp) :: xg(0:2*nx), yg(0:2*ny) +real(kind=dp) :: x(0:2*nx, 0:2*ny), y(0:2*nx, 0:2*ny) +real(kind=dp) :: dx(0:2*nx-1, 0:2*ny) +real(kind=dp) :: dy(0:2*nx, 0:2*ny-1) +real(kind=dp) :: area(0:2*nx-1, 0:2*ny-1) +real(kind=dp) :: angle_dx(0:2*nx, 0:2*ny) + +integer :: i, j, rc + + +! Topography +rc = nf90_create('topog.nc', NF90_CLOBBER, ncid) + +rc = nf90_def_dim(ncid, 'ny', ny, ny_id) +rc = nf90_def_dim(ncid, 'nx', nx, nx_id) +rc = nf90_def_dim(ncid, 'ntiles', 1, ntile_id) + +rc = nf90_def_var(ncid, 'depth', NF90_DOUBLE, [nx_id, ny_id], depth_id) +rc = nf90_def_var(ncid, 'h2', NF90_DOUBLE, [nx_id, ny_id], h2_id) + +rc = nf90_enddef(ncid) + +depth(:,:) = depth0 +rc = nf90_put_var(ncid, depth_id, depth) + +rc = nf90_close(ncid) + + +! Horizontal grid +rc = nf90_create('ocean_hgrid.nc', NF90_CLOBBER, ncid) + +rc = nf90_def_dim(ncid, 'ny', 2*ny, ny_id) +rc = nf90_def_dim(ncid, 'nx', 2*nx, nx_id) +rc = nf90_def_dim(ncid, 'nyp', 2*ny+1, nyp_id) +rc = nf90_def_dim(ncid, 'nxp', 2*nx+1, nxp_id) +rc = nf90_def_dim(ncid, 'string', 5, string_id) + +rc = nf90_def_var(ncid, 'y', NF90_DOUBLE, [nxp_id, nyp_id], y_id) +rc = nf90_def_var(ncid, 'x', NF90_DOUBLE, [nxp_id, nyp_id], x_id) +rc = nf90_def_var(ncid, 'dy', NF90_DOUBLE, [nxp_id, ny_id], dy_id) +rc = nf90_def_var(ncid, 'dx', NF90_DOUBLE, [nx_id, nyp_id], dx_id) +rc = nf90_def_var(ncid, 'area', NF90_DOUBLE, [nx_id, ny_id], area_id) +rc = nf90_def_var(ncid, 'angle_dx', NF90_DOUBLE, [nxp_id, nyp_id], angle_id) +rc = nf90_def_var(ncid, 'tile', NF90_CHAR, string_id, tile_id) + +rc = nf90_put_att(ncid, y_id, 'units', 'degrees') +rc = nf90_put_att(ncid, x_id, 'units', 'degrees') +rc = nf90_put_att(ncid, dy_id, 'units', 'meters') +rc = nf90_put_att(ncid, dx_id, 'units', 'meters') +rc = nf90_put_att(ncid, area_id, 'units', 'm2') +rc = nf90_put_att(ncid, angle_id, 'units', 'degrees') + +rc = nf90_enddef(ncid) + +xg = ds * [(i, i=0, 2*nx)] +yg = ds * [(j, j=0, 2*ny)] + +! NOTE: sin() and cos() are compiler-dependent + +x(:,:) = spread(xg(:), 2, 2*ny+1) +y(:,:) = spread(yg(:), 1, 2*nx+1) +dx(:,:) = rad_per_deg * Re * (x(1:,:) - x(:2*nx-1,:)) & + * cos(0.5 * rad_per_deg * (y(1:,:) + y(:2*nx-1,:))) +dy(:,:) = rad_per_deg * Re * (y(:,1:) - y(:,:2*ny-1)) + +area(:,:) = rad_per_deg * Re * Re & + * spread(sin(rad_per_deg * yg(1:)) - sin(rad_per_deg * yg(:2*ny-1)), 1, 2*nx) & + * spread(xg(1:) - xg(:2*nx-1), 2, 2*ny) + +angle_dx(:,:) = 0. + +rc = nf90_put_var(ncid, x_id, x) +rc = nf90_put_var(ncid, y_id, y) +rc = nf90_put_var(ncid, dx_id, dx) +rc = nf90_put_var(ncid, dy_id, dy) +rc = nf90_put_var(ncid, area_id, area) +rc = nf90_put_var(ncid, angle_id, angle_dx) +rc = nf90_put_var(ncid, tile_id, 'tile1') + +rc = nf90_close(ncid) +end diff --git a/.testing/tools/cmp_diag.sh b/.testing/tools/cmp_diag.sh new file mode 100755 index 0000000000..8bf0fd806f --- /dev/null +++ b/.testing/tools/cmp_diag.sh @@ -0,0 +1,15 @@ +#!/bin/bash +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + +for chk in $1 $2; do + awk '{print $(NF-2) " " $(NF-1) " " $(NF),$0}' ${chk} | sort > ${chk}.sorted +done + +cmp $1.sorted $2.sorted + +if [ $? -eq 1 ]; then + diff $1.sorted $2.sorted | head -n 100 + exit 1 +fi diff --git a/.testing/tools/compare_clocks.py b/.testing/tools/compare_clocks.py index 77198fda6a..09e6fe2439 100755 --- a/.testing/tools/compare_clocks.py +++ b/.testing/tools/compare_clocks.py @@ -1,4 +1,8 @@ #!/usr/bin/env python +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + import argparse import json diff --git a/.testing/tools/compare_perf.py b/.testing/tools/compare_perf.py index e4a651c709..65afc58c01 100755 --- a/.testing/tools/compare_perf.py +++ b/.testing/tools/compare_perf.py @@ -1,4 +1,8 @@ #!/usr/bin/env python +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + import argparse import json @@ -33,7 +37,9 @@ def main(): clock_cmp = {} - print('{:35s}{:8s} {:8s}'.format('', 'Profile', 'Reference')) + name_len = 60 + table_fmt = '{:' + str(name_len) + 's}{:8s} {:8s}' + print(table_fmt.format('', 'Profile', 'Reference')) print() with open(args.expt) as profile_expt, open(args.ref) as profile_ref: @@ -93,12 +99,12 @@ def main(): # Remove GCC optimization renaming sname = sname.replace('.constprop.0', '') - if len(sname) > 32: - sname = sname[:29] + '...' + if len(sname) > name_len - 3: + sname = sname[:name_len - 6] + '...' print('{}{}: {:7.3f}s, {:7.3f}s ({:.1f}%){}'.format( ansi_color, - ' ' * (32 - len(sname)) + sname, + ' ' * (name_len - 3 - len(sname)) + sname, t_expt, t_ref, 100. * dclk, diff --git a/.testing/tools/diff_diag.sh b/.testing/tools/diff_diag.sh new file mode 100755 index 0000000000..edbd0c934f --- /dev/null +++ b/.testing/tools/diff_diag.sh @@ -0,0 +1,15 @@ +#!/bin/bash +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + +for chk in $1 $2; do + awk '{print $(NF-2) " " $(NF-1) " " $(NF),$0}' ${chk} | sort > ${chk}.sorted +done + +diff $1.sorted $2.sorted | grep "^[<>]" | grep "^>" > /dev/null + +if [ $? -eq 0 ]; then + diff $1.sorted $2.sorted | head -n 100 + exit 1 +fi diff --git a/.testing/tools/disp_timing.py b/.testing/tools/disp_timing.py new file mode 100755 index 0000000000..55637abbef --- /dev/null +++ b/.testing/tools/disp_timing.py @@ -0,0 +1,161 @@ +#!/usr/bin/env python3 +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + +from __future__ import print_function + +import argparse +import json +import math + +scale = 1e6 # micro-seconds (should make this dynamic) + + +def display_timing_file(file, show_all): + """Parse a JSON file of timing results and pretty-print the results""" + + try: + with open(file, 'r') as json_file: + timing_dict = json.load(json_file) + print("(Times measured in %5.0e seconds)" % (1./scale)) + print(" Min time Module & function") + except: + stream_fms_tail_file(file) + timing_dict = {} + + for sub in timing_dict.keys(): + tmin = timing_dict[sub]['min'] * scale + print("%10.4e %s" % (tmin, sub)) + + if show_all: + tmean = timing_dict[sub]['mean'] * scale + tmax = timing_dict[sub]['max'] * scale + tstd = timing_dict[sub]['std'] * scale + nsamp = timing_dict[sub]['n_samples'] + tsstd = tstd / math.sqrt(nsamp) + print(" (" + + "mean = %10.4e " % (tmean) + + "±%7.1e, " % (tsstd) + + "max = %10.4e, " % (tmax) + + "std = %8.2e, " % (tstd) + + "# = %d)" % (nsamp)) + +def compare_timing_files(file, ref, show_all, significance_threshold): + """Read and compare two JSON files of timing results""" + + try: + with open(file) as json_file: + timing_dict = json.load(json_file) + except: + print("This timing tail sheet:") + stream_fms_tail_file(file) + timing_dict = {} + + try: + with open(ref) as json_file: + ref_dict = json.load(json_file) + print("(Times measured in %5.0e seconds)" % (1./scale)) + print(" Delta (%) Module & function") + except: + print("Reference timing tail sheet:") + stream_fms_tail_file(ref) + ref_dict = {} + + for sub in {**ref_dict, **timing_dict}.keys(): + T1 = ref_dict.get(sub) + T2 = timing_dict.get(sub) + if T1 is not None: + # stats for reference (old) + tmin1 = T1['min'] * scale + tmean1 = T1['mean'] * scale + if T2 is not None: + # stats for reference (old) + tmin2 = T2['min'] * scale + tmean2 = T2['mean'] * scale + if (T1 is not None) and (T2 is not None): + # change in actual minimum as percentage of old + dt = (tmin2 - tmin1) * 100 / tmin1 + if dt < -significance_threshold: + color = '\033[92m' + elif dt > significance_threshold: + color = '\033[91m' + else: + color = '' + print("%s%+10.4f%%\033[0m %s" % (color, dt, sub)) + else: + if T2 is None: + print(" removed %s" % (sub)) + else: + print(" added %s" % (sub)) + + if show_all: + if T2 is None: + print(" --") + else: + tmax2 = T2['max'] * scale + tstd2 = T2['std'] * scale + n2 = T2['n_samples'] + tsstd2 = tstd2 / math.sqrt(n2) + print(" %10.4e (" % (tmin2) + + "mean = %10.4e " % (tmean2) + + "±%7.1e, " % (tsstd2) + + "max=%10.4e, " % (tmax2) + + "std=%8.2e, " % (tstd2) + + "# = %d)" % (n2)) + if T1 is None: + print(" --") + else: + tmax1 = T1['max'] * scale + tstd1 = T1['std'] * scale + n1 = T1['n_samples'] + tsstd1 = tstd1 / math.sqrt(n1) + print(" %10.4e (" % (tmin1) + + "mean = %10.4e " % (tmean1) + + "±%7.1e, " % (tsstd1) + + "max=%10.4e, " % (tmax1) + + "std=%8.2e, " % (tstd1) + + "# = %d)" % (n1)) + +# Rudimentatry dump of tail sheet produced by FMS. +# This should really be handled by the parse_fms_clocks.py script +def stream_fms_tail_file(file): + silent = True + with open(file, 'r') as fms_tail_file: + for line in fms_tail_file.readlines(): + if "tfrac grain pemin pemax" in line: + silent=False + elif "high water mark" in line: + silent=True + if not silent: + print(line) + +# Parse arguments +parser = argparse.ArgumentParser( + description="Beautify timing output from MOM6 timing tests." +) +parser.add_argument( + 'file', + help="File to process." +) +parser.add_argument( + '-a', '--all', + action='store_true', + help="Display all metrics rather than just the minimum time." +) +parser.add_argument( + '-t', '--threshold', + default=6.0, type=float, + help="Significance threshold to flag (percentage)." +) +parser.add_argument( + '-r', '--reference', + help="Reference file to compare against." +) +args = parser.parse_args() + +# Do the thing +if args.reference is None: + display_timing_file(args.file, args.all) +else: + compare_timing_files(args.file, args.reference, args.all, args.threshold) diff --git a/.testing/tools/parse_fms_clocks.py b/.testing/tools/parse_fms_clocks.py index b57fc481ab..4125f09475 100755 --- a/.testing/tools/parse_fms_clocks.py +++ b/.testing/tools/parse_fms_clocks.py @@ -1,4 +1,8 @@ #!/usr/bin/env python +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + import argparse import collections import json @@ -60,23 +64,61 @@ def main(): print(json.dumps(config)) -def parse_mom6_param(param_file): +def parse_mom6_param(param_file, header=None): + """Parse a MOM6 input file and return its contents. + + param_file: Path to MOM input file. + header: Optional argument indicating current subparameter block. + """ params = {} for line in param_file: + # Remove any trailing comments from the line. + # NOTE: Exotic values containing `!` will behave unexpectedly. param_stmt = line.split('!')[0].strip() - if param_stmt: - key, val = [s.strip() for s in param_stmt.split('=')] - # TODO: Convert to equivalent Python types - if val in ('True', 'False'): - params[key] = bool(val) - else: - params[key] = val + # Skip blank lines + if not param_stmt: + continue + + if param_stmt[-1] == '%': + # Set up a subparameter block which returns its own dict. + + # Extract the (potentially nested) subparameter: [...%]param% + key = param_stmt.split('%')[-2] + + # Construct subparameter endline: %param[%...] + subheader = key + if header: + subheader = header + '%' + subheader + + # Parse the subparameter contents and return as a dict. + value = parse_mom6_param(param_file, header=subheader) + + elif header and param_stmt == '%' + header: + # Finalize the current subparameter block. + break + + else: + # Extract record from `key = value` entry + # NOTE: Exotic values containing `=` will behave unexpectedly. + key, value = [s.strip() for s in param_stmt.split('=')] + + if value in ('True', 'False'): + # Boolean values are converted into Python logicals. + params[key] = bool(value) + else: + # All other values are currently stored as strings. + params[key] = value return params def parse_clocks(log): + """Parse the FMS time stats from MOM6 output log and return as a dict. + + log: Path to file containing MOM6 stdout. + """ + clock_start_msg = 'Tabulating mpp_clock statistics across' clock_end_msg = 'MPP_STACK high water mark=' diff --git a/.testing/tools/parse_perf.py b/.testing/tools/parse_perf.py index b86b1cc106..4673022756 100755 --- a/.testing/tools/parse_perf.py +++ b/.testing/tools/parse_perf.py @@ -1,12 +1,26 @@ #!/usr/bin/env python +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + import argparse import collections import json import os +import re import shlex import subprocess import sys +perf_scanner = re.Scanner([ + (r'<', lambda scanner, token: token), + (r'>', lambda scanner, token: token), + (r'\(', lambda scanner, token: token), + (r'\)', lambda scanner, token: token), + (r'[ \t]+', lambda scanner, token: token), + (r'[^<>() \t]+', lambda scanner, token: token), +]) + def main(): desc = 'Parse perf.data and return in JSON format.' @@ -58,9 +72,56 @@ def parse_perf_report(perf_data_path): # get per-symbol count else: - tokens = line.split() - symbol = tokens[2] - period = int(tokens[3]) + tokens, remainder = perf_scanner.scan(line) + if remainder: + print('Line could not be tokenized', file=sys.stderr) + print(' line:', repr(line), file=sys.stderr) + print(' tokens:', tokens, file=sys.stderr) + print(' remainder:', remainder, file=sys.stderr) + sys.exit(os.EX_DATAERR) + + # Construct record from tokens + # (NOTE: Not a proper grammar, just dumb bracket counting) + record = [] + bracks = 0 + parens = 0 + + for tok in tokens: + if tok == '<': + bracks += 1 + + if tok == '(': + parens += 1 + + rec = record[-1] if record else None + + inside_bracket = rec and (bracks > 0 or parens > 0) + lead_rec = tok in '<(' and rec and not rec.isspace() + tail_rec = not tok.isspace() and rec and rec[-1] in '>)' + + if inside_bracket or lead_rec or tail_rec: + record[-1] += tok + else: + record.append(tok) + + if tok == '>': + bracks -= 1 + if tok == ')': + parens -= 1 + + # Strip any whitespace tokens + record = [rec for rec in record if not rec.isspace()] + + try: + symbol = record[2] + period = int(record[3]) + except: + print("parse_perf.py: Error extracting symbol count", + file=sys.stderr) + print("line:", repr(line), file=sys.stderr) + print("tokens:", tokens, file=sys.stderr) + print("record:", record, file=sys.stderr) + raise profile[event_name]['symbol'][symbol] = period diff --git a/.testing/tools/report_test_results.sh b/.testing/tools/report_test_results.sh new file mode 100755 index 0000000000..bc5376a837 --- /dev/null +++ b/.testing/tools/report_test_results.sh @@ -0,0 +1,46 @@ +#!/bin/sh +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + +RESULTS=${1:-${PWD}/results} + +GREEN="\033[0;32m" +RESET="\033[0m" +PASS="${GREEN}PASS${RESET}" + +if [ -d ${RESULTS} ]; then + if ls ${RESULTS}/*/std.*.err &> /dev/null; then + echo "The following tests failed to complete:" + ls ${RESULTS}/*/std.*.out \ + | awk '{ \ + split($$0,a,"/"); \ + split(a[length(a)],t,"."); \ + v=t[2]; \ + if(length(t)>4) v=v"."t[4]; print a[length(a)-1],":",v}' + fi + + if ls ${RESULTS}/*/ocean.stats.*.diff &> /dev/null; then + echo "The following tests report solution regressions:" + ls ${RESULTS}/*/ocean.stats.*.diff \ + | awk '{ \ + split($$0,a,"/"); \ + split(a[length(a)],t,"."); \ + v=t[3]; \ + if(length(t)>4) v=v"."t[4]; print a[length(a)-1],":",v}' + fi + + if ls ${RESULTS}/*/chksum_diag.*.diff &> /dev/null; then + echo "The following tests report diagnostic regressions:" + ls ${RESULTS}/*/chksum_diag.*.diff \ + | awk '{ \ + split($$0,a,"/"); \ + split(a[length(a)],t,"."); \ + v=t[2]; \ + if(length(t)>4) v=v"."t[4]; print a[length(a)-1],":",v}' + fi + + exit 1 +else + printf "${PASS}: All tests passed!\n" +fi diff --git a/.testing/trailer.py b/.testing/trailer.py index 64f016275f..495f1cc6e3 100755 --- a/.testing/trailer.py +++ b/.testing/trailer.py @@ -1,4 +1,8 @@ #!/usr/bin/env python +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + """Subroutines for Validating the whitespace of the source code.""" import argparse diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index c34089ddf6..0000000000 --- a/.travis.yml +++ /dev/null @@ -1,86 +0,0 @@ -# This Travis-CI file is for testing the state of the MOM6 source code. -# It does NOT test MOM6 solutions. - -# This is a not a c-language project but we use the same environment. -language: c -dist: bionic - -addons: - apt: - sources: - - ubuntu-toolchain-r-test - packages: - - tcsh pkg-config netcdf-bin libnetcdf-dev libnetcdff-dev gfortran - - mpich libmpich-dev - - graphviz flex bison cmake - - python-numpy python-netcdf4 - - python3 python3-dev python3-venv python3-pip python3-sphinx python3-lxml - - bc - - perl - - texlive-binaries texlive-base bibtool tex-common texlive-bibtex-extra - -# Environment variables -env: - global: - - TIMEFORMAT: "\"Time: %lR (user: %lU, sys: %lS)\"" - - FCFLAGS_DEBUG: "\"-g -O0 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds\"" - - FCFLAGS_REPRO: "\"-g -O2 -fbacktrace\"" - - FCFLAGS_INIT: "\"-finit-real=snan -finit-integer=2147483647 -finit-derived\"" - - FCFLAGS_COVERAGE: "\"--coverage\"" - - DO_REPRO_TESTS: true - -jobs: - include: - - env: JOB="Code compliance" - script: - # Whitespace - - ./.testing/trailer.py -e TEOS10 -l 120 src config_src - # API Documentation - - perl -e 'print "perl version $^V" . "\n"' - - cd docs && mkdir _build && make nortd DOXYGEN_RELEASE=Release_1_8_13 UPDATEHTMLEQS=Y - # We can tighten up the warnings here. Math im image captions should only generate - # \f warnings. All other latex math should be double escaped (\\) like (\\Phi) for - # html image captions. - - grep "warning:" _build/doxygen_warn_nortd_log.txt | grep -v 'Illegal command f as part of a \\image' | tee doxy_errors - - test ! -s doxy_errors - - - env: - - JOB="x86 verification testing" - - DO_REGRESSION_TESTS=false - script: - - cd .testing - - echo 'Build executables...' && echo -en 'travis_fold:start:script.1\\r' - - time make all - - echo -en 'travis_fold:end:script.1\\r' - - time make -k -s test - - make test.summary - - # NOTE: Code coverage upload is here to reduce load imbalance - # We do coverage with the regressions if part of a pull request - # otherwise as a separate job. - - if: type = pull_request - env: - - JOB="x86 Regression testing" - - DO_REGRESSION_TESTS=true - - MOM_TARGET_SLUG=${TRAVIS_REPO_SLUG} - - MOM_TARGET_LOCAL_BRANCH=${TRAVIS_BRANCH} - script: - - cd .testing - - echo 'Build executables...' && echo -en 'travis_fold:start:script.1\\r' - - time make build.regressions - - echo -en 'travis_fold:end:script.1\\r' - - time make -k -s test.regressions - - make test.summary - - - arch: arm64 - env: - - JOB="ARM64 verification testing" - - DO_REGRESSION_TESTS=false - - DO_REPRO_TESTS=false - script: - - cd .testing - - echo 'Build executables...' && echo -en 'travis_fold:start:script.1\\r' - - time make all - - echo -en 'travis_fold:end:script.1\\r' - - time make -k -s test - - make test.summary diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000000..f433b1a53f --- /dev/null +++ b/LICENSE @@ -0,0 +1,177 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS diff --git a/LICENSE.md b/LICENSE.md deleted file mode 100644 index 5528208587..0000000000 --- a/LICENSE.md +++ /dev/null @@ -1,173 +0,0 @@ -This file is part of the Modular Ocean Model, referred to as MOM, which is made -available under version 3 of the Gnu Lesser General Public License, which is -provided below. - -The intent of this license is to ensure free and unrestricted access to the MOM -software, and to pass on those rights to modified versions this software. - - - GNU LESSER GENERAL PUBLIC LICENSE - Version 3, 29 June 2007 - - Copyright (C) 2007 Free Software Foundation, Inc. - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - - This version of the GNU Lesser General Public License incorporates -the terms and conditions of version 3 of the GNU General Public -License, supplemented by the additional permissions listed below. - - 0. Additional Definitions. - - As used herein, "this License" refers to version 3 of the GNU Lesser -General Public License, and the "GNU GPL" refers to version 3 of the GNU -General Public License. - - "The Library" refers to a covered work governed by this License, -other than an Application or a Combined Work as defined below. - - An "Application" is any work that makes use of an interface provided -by the Library, but which is not otherwise based on the Library. -Defining a subclass of a class defined by the Library is deemed a mode -of using an interface provided by the Library. - - A "Combined Work" is a work produced by combining or linking an -Application with the Library. The particular version of the Library -with which the Combined Work was made is also called the "Linked -Version". - - The "Minimal Corresponding Source" for a Combined Work means the -Corresponding Source for the Combined Work, excluding any source code -for portions of the Combined Work that, considered in isolation, are -based on the Application, and not on the Linked Version. - - The "Corresponding Application Code" for a Combined Work means the -object code and/or source code for the Application, including any data -and utility programs needed for reproducing the Combined Work from the -Application, but excluding the System Libraries of the Combined Work. - - 1. Exception to Section 3 of the GNU GPL. - - You may convey a covered work under sections 3 and 4 of this License -without being bound by section 3 of the GNU GPL. - - 2. Conveying Modified Versions. - - If you modify a copy of the Library, and, in your modifications, a -facility refers to a function or data to be supplied by an Application -that uses the facility (other than as an argument passed when the -facility is invoked), then you may convey a copy of the modified -version: - - a) under this License, provided that you make a good faith effort to - ensure that, in the event an Application does not supply the - function or data, the facility still operates, and performs - whatever part of its purpose remains meaningful, or - - b) under the GNU GPL, with none of the additional permissions of - this License applicable to that copy. - - 3. Object Code Incorporating Material from Library Header Files. - - The object code form of an Application may incorporate material from -a header file that is part of the Library. You may convey such object -code under terms of your choice, provided that, if the incorporated -material is not limited to numerical parameters, data structure -layouts and accessors, or small macros, inline functions and templates -(ten or fewer lines in length), you do both of the following: - - a) Give prominent notice with each copy of the object code that the - Library is used in it and that the Library and its use are - covered by this License. - - b) Accompany the object code with a copy of the GNU GPL and this license - document. - - 4. Combined Works. - - You may convey a Combined Work under terms of your choice that, -taken together, effectively do not restrict modification of the -portions of the Library contained in the Combined Work and reverse -engineering for debugging such modifications, if you also do each of -the following: - - a) Give prominent notice with each copy of the Combined Work that - the Library is used in it and that the Library and its use are - covered by this License. - - b) Accompany the Combined Work with a copy of the GNU GPL and this license - document. - - c) For a Combined Work that displays copyright notices during - execution, include the copyright notice for the Library among - these notices, as well as a reference directing the user to the - copies of the GNU GPL and this license document. - - d) Do one of the following: - - 0) Convey the Minimal Corresponding Source under the terms of this - License, and the Corresponding Application Code in a form - suitable for, and under terms that permit, the user to - recombine or relink the Application with a modified version of - the Linked Version to produce a modified Combined Work, in the - manner specified by section 6 of the GNU GPL for conveying - Corresponding Source. - - 1) Use a suitable shared library mechanism for linking with the - Library. A suitable mechanism is one that (a) uses at run time - a copy of the Library already present on the user's computer - system, and (b) will operate properly with a modified version - of the Library that is interface-compatible with the Linked - Version. - - e) Provide Installation Information, but only if you would otherwise - be required to provide such information under section 6 of the - GNU GPL, and only to the extent that such information is - necessary to install and execute a modified version of the - Combined Work produced by recombining or relinking the - Application with a modified version of the Linked Version. (If - you use option 4d0, the Installation Information must accompany - the Minimal Corresponding Source and Corresponding Application - Code. If you use option 4d1, you must provide the Installation - Information in the manner specified by section 6 of the GNU GPL - for conveying Corresponding Source.) - - 5. Combined Libraries. - - You may place library facilities that are a work based on the -Library side by side in a single library together with other library -facilities that are not Applications and are not covered by this -License, and convey such a combined library under terms of your -choice, if you do both of the following: - - a) Accompany the combined library with a copy of the same work based - on the Library, uncombined with any other library facilities, - conveyed under the terms of this License. - - b) Give prominent notice with the combined library that part of it - is a work based on the Library, and explaining where to find the - accompanying uncombined form of the same work. - - 6. Revised Versions of the GNU Lesser General Public License. - - The Free Software Foundation may publish revised and/or new versions -of the GNU Lesser General Public License from time to time. Such new -versions will be similar in spirit to the present version, but may -differ in detail to address new problems or concerns. - - Each version is given a distinguishing version number. If the -Library as you received it specifies that a certain numbered version -of the GNU Lesser General Public License "or any later version" -applies to it, you have the option of following the terms and -conditions either of that published version or of any later version -published by the Free Software Foundation. If the Library as you -received it does not specify a version number of the GNU Lesser -General Public License, you may choose any version of the GNU Lesser -General Public License ever published by the Free Software Foundation. - - If the Library as you received it specifies that a proxy can decide -whether future versions of the GNU Lesser General Public License shall -apply, that proxy's public statement of acceptance of any version is -permanent authorization for you to choose that version for the -Library. diff --git a/README.md b/README.md index 46774baaf0..17b0a3661c 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -[![Read The Docs Status](https://readthedocs.org/projects/mom6/badge/?badge=latest)](http://mom6.readthedocs.io/) +[![Read The Docs Status](https://readthedocs.org/projects/mom6/badge/?version=main)](https://mom6.readthedocs.io/en/main/?badge=main) [![codecov](https://codecov.io/gh/NOAA-GFDL/MOM6/branch/dev/gfdl/graph/badge.svg?token=uF8SVydCdp)](https://codecov.io/gh/NOAA-GFDL/MOM6) # MOM6 diff --git a/ac/Makefile.in b/ac/Makefile.in index 7be6c5bf2b..148c2af534 100644 --- a/ac/Makefile.in +++ b/ac/Makefile.in @@ -1,60 +1,41 @@ +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + # Makefile template for MOM6 # # Compiler flags are configured by autoconf's configure script. # -# Source code dependencies are configured by mkmf and list_paths, specified in -# the `Makefile.mkmf` file. -# -# mkmf conventions are close, but not identical, to autoconf. We attempt to -# map the autoconf variables to the mkmf variables. -# -# The following variables are used by Makefiles generated by mkmf. -# -# CC C compiler -# CXX C++ compiler -# FC Fortran compiler (f77 and f90) -# LD Linker -# AR Archiver -# -# CPPDEFS Preprocessor macros -# CPPFLAGS C preprocessing flags -# CXXFLAGS C++ preprocessing flags -# FPPFLAGS Fortran preprocessing flags -# -# CFLAGS C compiler flags -# FFLAGS Fortran compiler flags -# LDFLAGS Linker flags + libraries -# ARFLAGS Archiver flags -# -# OTHERFLAGS Additional flags for all languages (C, C++, Fortran) -# OTHER_CFLAGS Optional C flags -# OTHER_CXXFLAGS Optional C++ flags -# OTHER_FFLAGS Optional Fortran flags -# TMPFILES Placeholder for `make clean` deletion (as `make neat`). -# -# -# NOTES: -# - FPPFLAGS and FFLAGS always appear as a pair, and autoconf does not use -# FPPFLAGS, so FPPFLAGS does not serve much purpose. -# -# - mkmf's FFLAGS does not distinguish between autoconf's fixed-format -# FFLAGS and free-format FCFLAGS. -# -# - LDFLAGS does not distinguish between autoconf's LDFLAGS and LIBS. -# It also places both after the executable rather than just LIBS. +# Source code dependencies are configured by makedep and saved to Makefile.dep. FC = @FC@ LD = @FC@ +PYTHON = @PYTHON@ +MAKEDEP = @MAKEDEP@ -CPPDEFS = @DEFS@ +DEFS = @DEFS@ CPPFLAGS = @CPPFLAGS@ -FFLAGS = @FCFLAGS@ -LDFLAGS = @LDFLAGS@ @LIBS@ +FCFLAGS = @FCFLAGS@ +LDFLAGS = @LDFLAGS@ +LIBS = @LIBS@ +MAKEDEP_FLAGS = @MAKEDEP_FLAGS@ + +-include Makefile.dep + +# Generate Makefile from template +Makefile: @srcdir@/ac/Makefile.in config.status + ./config.status + + +# Recursive wildcard (finds all files in $1 with suffixes in $2) +rwildcard=$(foreach d,$(wildcard $(1:=/*)),$(call rwildcard,$d,$2) $(filter $(subst *,%,$2),$d)) -# Gather modulefiles -TMPFILES = $(wildcard *.mod) -include Makefile.mkmf +# Generate dependencies +.PHONY: depend +depend: Makefile.dep +Makefile.dep: $(call rwildcard,$(SRC_DIRS),*.h *.c *.inc *.F90) + $(PYTHON) $(MAKEDEP) $(DEFS) -o Makefile.dep $(MAKEDEP_FLAGS) # Delete any files associated with configuration (including the Makefile). @@ -64,9 +45,8 @@ distclean: clean rm -f config.log rm -f config.status rm -f Makefile - # mkmf output rm -f path_names - rm -f Makefile.mkmf + rm -f Makefile.dep # This deletes all files generated by autoconf, including configure. @@ -78,3 +58,4 @@ ac-clean: distclean rm -f @srcdir@/ac/aclocal.m4 rm -rf @srcdir@/ac/autom4te.cache rm -f @srcdir@/ac/configure + rm -f @srcdir@/ac/configure~ diff --git a/ac/configure.ac b/ac/configure.ac index 3d1af81b05..c71aec6fbd 100644 --- a/ac/configure.ac +++ b/ac/configure.ac @@ -1,80 +1,86 @@ -# Autoconf configuration +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 -# NOTE: -# - We currently do not use a MOM6 version tag, but this would be one option in -# the future: -# [m4_esyscmd_s([git describe])] -# - Another option is `git rev-parse HEAD` for the full hash. -# - We would probably run this inside of a script to avoid the explicit -# dependency on git. +# Autoconf configuration AC_PREREQ([2.63]) AC_INIT( [MOM6], - [ ], + [], [https://github.com/NOAA-GFDL/MOM6/issues], [], - [https://github.com/NOAA-GFDL/MOM6]) + [https://github.com/NOAA-GFDL/MOM6] +) -#--- -# NOTE: For the autoconf-adverse, the configuration files and autoreconf output -# are kept in the `ac` directory. -# -# This breaks the convention where configure.ac resides in the top directory. -# -# As a result, $srcdir initially points to the `ac` directory, rather than the -# top directory of the codebase. -# -# In order to balance this, we up-path (../) srcdir and point AC_CONFIG_SRCDIR -# to srcdir and point AC_CONFIG_SRCDIR to the parent directory. -# -# Someday we may revert this and work from the top-level directory. But for -# now we will isolate autoconf to a subdirectory. -#--- # Validate srdcir and configure input -AC_CONFIG_SRCDIR([../src/core/MOM.F90]) +AC_CONFIG_SRCDIR([src/core/MOM.F90]) AC_CONFIG_MACRO_DIR([m4]) -srcdir=$srcdir/.. -# Default to symmetric grid -# NOTE: --enable is more properly used to add a feature, rather than to select -# a compile-time mode, so this is not exactly being used as intended. -MEM_LAYOUT=${srcdir}/config_src/memory/dynamic_symmetric -AC_ARG_ENABLE([asymmetric], - AS_HELP_STRING([--enable-asymmetric], [Use the asymmetric grid])) -AS_IF([test "$enable_asymmetric" = yes], - [MEM_LAYOUT=${srcdir}/config_src/memory/dynamic_nonsymmetric]) +# MOM6 memory layout configuration -# Default to solo_driver +AC_ARG_VAR([MOM_MEMORY], + [Path to MOM_memory.h header, describing the field memory layout: dynamic + symmetric (default), dynamic asymmetric, or static.] +) + +AS_VAR_IF([MOM_MEMORY], [], + [MOM_MEMORY=${srcdir}/config_src/memory/dynamic_symmetric/MOM_memory.h] +) + +# Confirm that MOM_MEMORY is named 'MOM_memory.h' +AS_IF([test $(basename "${MOM_MEMORY}") = "MOM_memory.h"], [], + [AC_MSG_ERROR([MOM_MEMORY header ${MOM_MEMORY} must be named 'MOM_memory.h'])] +) + +# Confirm that the file exists +AC_CHECK_FILE(["$MOM_MEMORY"], [], + [AC_MSG_ERROR([MOM_MEMORY header ${MOM_MEMORY} not found.])] +) + +MOM_MEMORY_DIR=$(AS_DIRNAME(["${MOM_MEMORY}"])) +AC_SUBST([MOM_MEMORY_DIR]) + + +# Driver configuration DRIVER_DIR=${srcdir}/config_src/drivers/solo_driver AC_ARG_WITH([driver], - AS_HELP_STRING([--with-driver=coupled_driver|solo_driver], [Select directory for driver source code])) -AS_IF([test "x$with_driver" != "x"], - [DRIVER_DIR=${srcdir}/config_src/drivers/${with_driver}]) + AS_HELP_STRING( + [--with-driver=FMS_cap|solo_driver|unit_tests], + [Select directory for driver source code] + ) +) +AS_IF([test -n "$with_driver"], + [DRIVER_DIR=${srcdir}/config_src/drivers/${with_driver}] +) + +# External library configuration +AC_ARG_WITH([gsw], + [AS_HELP_STRING( + [--with-gsw], + [use external Gibbs Sea Water library instead of linked source] + )], [], [with_gsw=no] +) + +AC_ARG_WITH([cvmix], + [AS_HELP_STRING( + [--with-cvmix], + [use external CVMix library instead of linked source] + )], [], [with_cvmix=no] +) + # TODO: Rather than point to a pre-configured header file, autoconf could be # used to configure a header based on a template. #AC_CONFIG_HEADERS(["$MEM_LAYOUT/MOM_memory.h"]) -# Select the model framework (default: FMS1) -# NOTE: We can phase this out after the FMS1 I/O has been removed from FMS and -# replace with a detection test. For now, it is a user-defined switch. -MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS1 -AC_ARG_WITH([framework], - AS_HELP_STRING([--with-framework=fms1|fms2], [Select the model framework])) -AS_CASE(["$with_framework"], - [fms1], [MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS1], - [fms2], [MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS2], - [MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS1] -) - # Explicitly assume free-form Fortran -AC_LANG(Fortran) -AC_FC_SRCEXT(f90) +AC_LANG([Fortran]) +AC_FC_SRCEXT([f90]) # Determine MPI compiler wrappers @@ -84,8 +90,9 @@ AC_FC_SRCEXT(f90) # - This can cause standard AC_PROG_FC tests to fail if FCFLAGS is configured # with flags from another compiler. # - I do not yet know how to resolve this possible issue. -AX_MPI([], - [AC_MSG_ERROR([Could not find MPI launcher.])]) +AX_MPI([], [ + AC_MSG_ERROR([Could not find MPI launcher.]) +]) # Explicitly replace FC and LD with MPI wrappers @@ -101,7 +108,7 @@ AX_FC_CHECK_MODULE([mpi], # netCDF configuration -# Search for the Fortran netCDF module, fallback to nf-config. +# Search for the Fortran netCDF module. AX_FC_CHECK_MODULE([netcdf], [], [ AS_UNSET([ax_fc_cv_mod_netcdf]) AC_PATH_PROG([NF_CONFIG], [nf-config]) @@ -114,50 +121,52 @@ AX_FC_CHECK_MODULE([netcdf], [], [ ]) ]) -# FMS may invoke netCDF C calls, so we link to libnetcdf. -AC_LANG_PUSH([C]) -AC_CHECK_LIB([netcdf], [nc_create], [], [ - AS_UNSET([ac_cv_lib_netcdf_nc_create]) +# Confirm that the Fortran compiler can link the netCDF C library +AX_FC_CHECK_C_LIB([netcdf], [nc_create], [], [ + AS_UNSET([ax_fc_cv_c_lib_netcdf_nc_create]) AC_PATH_PROG([NC_CONFIG], [nc-config]) AS_IF([test -n "$NC_CONFIG"], [ - AC_SUBST([LDFLAGS], - ["$LDFLAGS -L$($NC_CONFIG --libdir)"] - ) - ], [AC_MSG_ERROR([Could not find nc-config.])] - ) - AC_CHECK_LIB([netcdf], [nc_create], [], [ - AC_MSG_ERROR([Could not find libnetcdf.]) + AC_SUBST([LDFLAGS], ["$LDFLAGS -L$($NC_CONFIG --libdir)"]) + ], [ + AC_MSG_ERROR([Could not find nc-config.]) + ]) + AX_FC_CHECK_C_LIB([netcdf], [nc_create], [], [ + AC_MSG_ERROR([Could not find netCDF C library.]) ]) ]) -AC_LANG_POP([C]) - -# NOTE: We test for nf_create, rather than nf90_create, because AX_FC_CHECK_LIB -# is currently not yet able to properly probe inside modules. -# Testing of the nf90_* functions will require a macro update. -# NOTE: nf-config does not have a --libdir flag, so we use --prefix and assume -# that libraries are in the $prefix/lib directory. -# Link to Fortran netCDF library, netcdff -AX_FC_CHECK_LIB([netcdff], [nf_create], [], [], [ - AS_UNSET([ax_fc_cv_lib_netcdff_nf_create]) - AC_PATH_PROG([NF_CONFIG], [nf-config]) - AS_IF([test -n "$NF_CONFIG"], [ - AC_SUBST([LDFLAGS], - ["$LDFLAGS -L$($NF_CONFIG --prefix)/lib"] +# Confirm that the Fortran compiler can link to the netCDF Fortran library. +# NOTE: nf-config does not have --libdir, so we parse the --flibs output. +MOM6_FC_CHECK_LIB([netcdff], [nf90_create], [netcdf], [path,cmode,ncid], [rc], [ + character :: path + integer :: cmode, ncid, rc], + [], [ + AS_UNSET([mom6_fc_cv_lib_netcdff_nf90_create]) + AC_PATH_PROG([NF_CONFIG], [nf-config]) + AS_IF([test -n "$NF_CONFIG"], [ + AC_SUBST([LDFLAGS], + ["$LDFLAGS $($NF_CONFIG --flibs | xargs -n1 | grep "^-L" | sort -u | xargs)"] + ) + ], [ + AC_MSG_ERROR([Could not find nf-config.]) + ]) + MOM6_FC_CHECK_LIB([netcdff], [nf90_create], [netcdf], [path,cmode,ncid], [rc], [ + character :: path + integer :: cmode, ncid, rc], + [], [ + AC_MSG_ERROR([Could not find netCDF Fortran library.]) + ] ) - ], [AC_MSG_ERROR([Could not find nf-config.])] - ) - AX_FC_CHECK_LIB([netcdff], [nf_create], [], [], [ - AC_MSG_ERROR([Could not find libnetcdff.]) - ]) -]) + ] +) # Force 8-byte reals AX_FC_REAL8 AS_IF( [test "$enable_real8" != no], - [FCFLAGS="$FCFLAGS $REAL8_FCFLAGS"]) + [FCFLAGS="$FCFLAGS $REAL8_FCFLAGS"] +) # OpenMP configuration @@ -187,23 +196,25 @@ AX_FC_CHECK_MODULE([fms_mod], [], [ AX_FC_CHECK_MODULE([fms_mod], [AC_SUBST([FCFLAGS], ["-I${srcdir}/ac/deps/include $FCFLAGS"])], [AC_MSG_ERROR([Could not find fms_mod Fortran module.])], - [-I${srcdir}/ac/deps/include]) + [-I${srcdir}/ac/deps/include] + ) ]) # Test for fms_init to verify FMS library linking -AX_FC_CHECK_LIB([FMS], [fms_init], [fms_mod], +MOM6_FC_CHECK_LIB([FMS], [fms_init], [fms_mod], [], [], [], [], [ - AS_UNSET([ax_fc_cv_lib_FMS_fms_init]) - AX_FC_CHECK_LIB([FMS], [fms_init], [fms_mod], [ - AC_SUBST([LDFLAGS], ["-L${srcdir}/ac/deps/lib $LDFLAGS"]) - AC_SUBST([LIBS], ["-lFMS $LIBS"]) - ], - [AC_MSG_ERROR([Could not find FMS library.])], - [-L${srcdir}/ac/deps/lib]) + AS_UNSET([mom6_fc_cv_lib_FMS_fms_init]) + MOM6_FC_CHECK_LIB([FMS], [fms_init], [fms_mod], [], [], [], + [ + AC_SUBST([LDFLAGS], ["-L${srcdir}/ac/deps/lib $LDFLAGS"]) + AC_SUBST([LIBS], ["-lFMS $LIBS"]) + ], [ + AC_MSG_ERROR([Could not find FMS library.]) + ], [-L${srcdir}/ac/deps/lib] + ) ] ) - # Verify that FMS is at least 2019.01.02 # NOTE: 2019.01.02 introduced two changes: # - diag_axis_init supports an optional domain_position argument @@ -219,46 +230,148 @@ AC_COMPILE_IFELSE( ] ) +# Determine the FMS IO implementation. +AX_FC_CHECK_MODULE([fms2_io_mod], [ + MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS2 +],[ + MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS1 +]) -# Search for mkmf build tools -AC_PATH_PROG([LIST_PATHS], [list_paths]) -AS_IF([test -z "$LIST_PATHS"], [ - AC_PATH_PROG([LIST_PATHS], [list_paths], [], ["$PATH:${srcdir}/ac/deps/bin"]) - AS_IF([test -z "$LIST_PATHS"], - [AC_MSG_ERROR([Could not find list_paths.])], - [AC_SUBST(PATH, ["$PATH:${srcdir}/ac/deps/bin"])]) - ] + +# GSW configuration +AS_IF([test "$with_gsw" = yes], [ + AX_FC_CHECK_MODULE([gsw_mod_toolbox], [], [ + AC_MSG_ERROR([Could not find module gsw_mod_toolbox.]) + ]) + MOM6_FC_CHECK_LIB([gsw], [gsw_rho], [gsw_mod_toolbox], [sa,ct,p], [rho], [], + [], [ + AC_MSG_ERROR([Could not find gsw_rho in gsw_mod_toolbox.]) + ] + ) +]) + + +# CVMix configuration +AS_IF([test "$with_cvmix" = yes], [ + AX_FC_CHECK_MODULE([cvmix_kpp], [], [ + AC_MSG_ERROR([Could not find module cvmix_kpp.]) + ]) + MOM6_FC_CHECK_LIB([cvmix], [cvmix_init_kpp], [cvmix_kpp], [], [], [], + [], [ + AC_MSG_ERROR([Could not find cvmix_update_wrap in cvmix_utils.]) + ] + ) +]) + + +# Python configuration + +# Declare the Python interpreter variable +AC_ARG_VAR([PYTHON], [Python interpreter command]) + +# If PYTHON is set to an empty string, then unset it +AS_VAR_IF([PYTHON], [], [AS_UNSET([PYTHON])], []) + +# Now attempt to find a Python interpreter if PYTHON is unset +AS_VAR_SET_IF([PYTHON], [ + AC_PATH_PROGS([PYTHON], ["$PYTHON"], [none]) +], [ + AC_PATH_PROGS([PYTHON], [python python3 python2], [none]) +]) +AS_VAR_IF([PYTHON], [none], [ + AC_MSG_ERROR([Python interpreter not found.]) +]) + + +# Makedep configuration +AC_PATH_PROG([MAKEDEP], [makedep], [${srcdir}/ac/makedep]) +AC_SUBST([MAKEDEP]) + +# Generate Makedep source list and configure dependency command +MAKEDEP_FLAGS="-e" + +# Exclude linked source files from makedep search +AS_IF([test "$with_gsw" = yes], [ + MAKEDEP_FLAGS="${MAKEDEP_FLAGS} \\ + -s ${srcdir}/src/equation_of_state/TEOS10" +]) + +AS_IF([test "$with_cvmix" = yes], [ + MAKEDEP_FLAGS="${MAKEDEP_FLAGS} \\ + -s ${srcdir}/src/parameterizations/CVmix" +]) + +SRC_DIRS="\\ + ${srcdir}/src \\ + ${MODEL_FRAMEWORK} \\ + ${srcdir}/config_src/external \\ + ${DRIVER_DIR} \\ + ${MOM_MEMORY_DIR}" +MAKEDEP_FLAGS="${MAKEDEP_FLAGS} ${SRC_DIRS}" + +MAKEDEP_FLAGS="${MAKEDEP_FLAGS# }" +AC_SUBST([MAKEDEP_FLAGS]) + +# Add makedep to config.status +AC_CONFIG_COMMANDS(Makefile.dep, [make depend]) + + +# POSIX verification tests + +# Symbols in may be defined as macros, making them inaccessible by +# Fortran C bindings. `sigsetjmp` is known to have an internal symbol in +# glibc, so we check for this possibility. For the others, we only check for +# existence. + +# If the need arises, we may want to define these under a standalone macro. + +# Validate the setjmp symbol +AX_FC_CHECK_BIND_C([setjmp], + [SETJMP="setjmp"], [SETJMP="setjmp_missing"] ) +AC_DEFINE_UNQUOTED([SETJMP_NAME], ["${SETJMP}"]) -AC_PATH_PROG([MKMF], [mkmf]) -AS_IF([test -z "$MKMF"], [ - AC_PATH_PROG([MKMF], [mkmf], [], ["$PATH:${srcdir}/ac/deps/bin"]) - AS_IF([test -z "$MKMF"], - [AC_MSG_ERROR([Could not find mkmf.])], - [AC_SUBST(PATH, ["$PATH:${srcdir}/ac/deps/bin"])]) - ] +# Validate the longjmp symbol +AX_FC_CHECK_BIND_C([longjmp], + [LONGJMP="longjmp"], [LONGJMP="longjmp_missing"] ) +AC_DEFINE_UNQUOTED([LONGJMP_NAME], ["${LONGJMP}"]) +# Determine the sigsetjmp symbol. If missing, then point to sigsetjmp_missing. +# +# Supported symbols: +# sigsetjmp POSIX, BSD libc (MacOS) +# __sigsetjmp glibc (Linux) +SIGSETJMP="sigsetjmp_missing" +for sigsetjmp_fn in sigsetjmp __sigsetjmp; do + AX_FC_CHECK_BIND_C([${sigsetjmp_fn}], [ + SIGSETJMP=${sigsetjmp_fn} + break + ]) +done +AC_DEFINE_UNQUOTED([SIGSETJMP_NAME], ["${SIGSETJMP}"]) -# NOTE: MEM_LAYOUT unneeded if we shift to MOM_memory.h.in template -AC_CONFIG_COMMANDS([path_names], - [list_paths -l \ - ${srcdir}/src \ - ${MODEL_FRAMEWORK} \ - ${srcdir}/config_src/ext* \ - ${DRIVER_DIR} \ - ${MEM_LAYOUT}], - [MODEL_FRAMEWORK=$MODEL_FRAMEWORK - MEM_LAYOUT=$MEM_LAYOUT - DRIVER_DIR=$DRIVER_DIR] +# Validate the siglongjmp symbol +AX_FC_CHECK_BIND_C([siglongjmp], + [SIGLONGJMP="siglongjmp"], [SETJMP="siglongjmp_missing"] ) +AC_DEFINE_UNQUOTED([SIGLONGJMP_NAME], ["${SIGLONGJMP}"]) -AC_CONFIG_COMMANDS([Makefile.mkmf], - [mkmf -p MOM6 -m Makefile.mkmf path_names]) +# Verify the size of nonlocal jump buffer structs +# NOTE: This requires C compiler, but can it be done with a Fortran compiler? +AC_LANG_PUSH([C]) + +AX_MPI([], [AC_MSG_ERROR([Could not find MPI launcher.])]) +AC_SUBST([CC], [$MPICC]) + +AC_CHECK_SIZEOF([jmp_buf], [], [#include ]) +AC_CHECK_SIZEOF([sigjmp_buf], [], [#include ]) + +AC_LANG_POP([C]) # Prepare output -AC_SUBST(CPPFLAGS) -AC_CONFIG_FILES([Makefile:${srcdir}/ac/Makefile.in]) +AC_SUBST([CPPFLAGS]) +AC_CONFIG_FILES([Makefile:Makefile.in]) AC_OUTPUT diff --git a/ac/deps/.gitignore b/ac/deps/.gitignore index 8cfaa6ebcb..80256cfe1d 100644 --- a/ac/deps/.gitignore +++ b/ac/deps/.gitignore @@ -1,5 +1,7 @@ /bin/ /fms/ +/gsw/ +/cvmix/ /include/ /lib/ /mkmf/ diff --git a/ac/deps/Makefile b/ac/deps/Makefile index 0ed4fd19a7..326cc757f7 100644 --- a/ac/deps/Makefile +++ b/ac/deps/Makefile @@ -1,3 +1,7 @@ +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + SHELL = bash # Disable implicit rules @@ -6,85 +10,120 @@ SHELL = bash # Disable implicit variables MAKEFLAGS += -R - -# mkmf, list_paths (GFDL build toolchain) -MKMF_URL ?= https://github.com/NOAA-GFDL/mkmf.git -MKMF_COMMIT ?= master - # FMS framework FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git -FMS_COMMIT ?= 2019.01.03 +FMS_COMMIT ?= 2023.03 + +GSW_URL ?= https://github.com/mom-ocean/GSW-Fortran.git +GSW_COMMIT ?= 29e64d652786e1d076a05128c920f394202bfe10 + +CVMIX_URL ?= https://github.com/mom-ocean/CVMix-src.git +CVMIX_COMMIT ?= 65ef5c73bc7f5663d5688f75c3855d431da4baea # List of source files to link this Makefile's dependencies to model Makefiles # Assumes a depth of two, and the following extensions: F90 inc c h # (1): Root directory -# NOTE: extensions could be a second variable SOURCE = \ $(foreach ext,F90 inc c h,$(wildcard $(1)/*/*.$(ext) $(1)/*/*/*.$(ext))) FMS_SOURCE = $(call SOURCE,fms/src) +GSW_SOURCE = $(call SOURCE,gsw/src) +CVMIX_SOURCE = $(call SOURCE,CVMix-src/src/shared) -#--- -# Rules +# If `true`, print logs if an error is encountered. +REPORT_ERROR_LOGS ?= -.PHONY: all -all: bin/mkmf bin/list_paths lib/libFMS.a + +# If set, use the submodule repositories in pkg/ +PKG ?= $(abspath ../../pkg) +MAKEDEP ?= $(abspath ../makedep) #--- -# mkmf checkout +# Rules -bin/mkmf bin/list_paths: mkmf - mkdir -p $(@D) - cp $^/$@ $@ +.PHONY: all +all: lib/libFMS.a +all: lib/libgsw.a +all: lib/libcvmix.a -mkmf: - git clone $(MKMF_URL) $@ - git -C $@ checkout $(MKMF_COMMIT) +# Library build rules template +# +# $(1): target library +# $(2): dependency label +# $(3): library source files -#--- -# FMS build +define LIB_RULES +lib/$(1): $(2)/build/$(1) + mkdir -p $$(@D) include/ + cp $$< $$@ + cp $$(dir $$<)/*.mod include/ -# NOTE: We emulate the automake `make install` stage by storing libFMS.a to -# ${srcdir}/deps/lib and copying module files to ${srcdir}/deps/include. -# This is a flawed approach, since module files are untracked and could be -# handled more safely, but this is adequate for now. +$(2)/build/$(1): $(2)/build/Makefile + $$(MAKE) -C $$(@D) $(1) +$(2)/build/Makefile: $(2)/build/Makefile.in $(2)/build/configure + cd $$(@D) && { \ + MAKEDEP=$$(MAKEDEP) \ + ./configure --srcdir=../src \ + || { \ + if [ "$${REPORT_ERROR_LOGS}" = true ]; then cat config.log ; fi ; \ + false; \ + } \ + } -# TODO: track *.mod copy? -lib/libFMS.a: fms/build/libFMS.a fms/build/Makefile - mkdir -p {lib,include} - cp fms/build/libFMS.a lib/libFMS.a - cp fms/build/*.mod include +$(2)/build/Makefile.in: Makefile.$(2).in | $(2)/build + cp $$< $$@ +$(2)/build/configure: $(2)/build/configure.ac $(3) | $(2)/src + autoreconf $$(@D) -fms/build/libFMS.a: fms/build/Makefile - make -C fms/build libFMS.a +$(2)/build/configure.ac: configure.$(2).ac m4 | $(2)/build + cp $$< $$@ + cp -r m4 $$(@D) +$(2)/build: + mkdir -p $$@ +endef -fms/build/Makefile: Makefile.fms.in fms/src/configure bin/mkmf bin/list_paths - mkdir -p fms/build - cp Makefile.fms.in fms/src/Makefile.in - cd $(@D) && ../src/configure --srcdir=../src +$(eval $(call LIB_RULES,libFMS.a,fms,$(FMS_SOURCE))) +$(eval $(call LIB_RULES,libgsw.a,gsw,$(GSW_SOURCE))) +$(eval $(call LIB_RULES,libcvmix.a,cvmix,$(CVMIX_SOURCE))) -# TODO: Track m4 macros? -fms/src/configure: configure.fms.ac $(FMS_SOURCE) | fms/src - cp configure.fms.ac fms/src/configure.ac - cp -r m4 $(@D) - cd $(@D) && autoreconf -i +# Dependency source fms/src: git clone $(FMS_URL) $@ git -C $@ checkout $(FMS_COMMIT) +ifdef PKG +gsw/src: | gsw/build + ln -s $(PKG)/GSW-Fortran gsw/src + +cvmix/src: | cvmix/build + ln -s $(PKG)/CVMix-src cvmix/src + +else +gsw/src: + git clone $(GSW_URL) $@ + git -C $@ checkout $(GSW_COMMIT) + +cvmix/src: + git clone $(CVMIX_URL) $@ + git -C $@ checkout $(CVMIX_COMMIT) +endif + + +# Cleanup + .PHONY: clean clean: - rm -rf fms/build lib include bin + rm -rf fms/build gsw/build cvmix/build lib include .PHONY: distclean distclean: clean - rm -rf fms mkmf + rm -rf fms gsw cvmix diff --git a/ac/deps/Makefile.cvmix.in b/ac/deps/Makefile.cvmix.in new file mode 100644 index 0000000000..b8254d9b11 --- /dev/null +++ b/ac/deps/Makefile.cvmix.in @@ -0,0 +1,30 @@ +# Makefile template for CVMix +# +# Compiler flags are configured by autoconf's configure script. +# +# Source code dependencies are configured by makedep and saved to Makefile.dep. + +FC = @FC@ +LD = @FC@ +AR = @AR@ +PYTHON = @PYTHON@ +MAKEDEP = @MAKEDEP@ + +DEFS = @DEFS@ +CPPFLAGS = @CPPFLAGS@ +FCFLAGS = @FCFLAGS@ +LDFLAGS = @LDFLAGS@ +LIBS = @LIBS@ +ARFLAGS = @ARFLAGS@ + +-include Makefile.dep + +# Generate Makefile from template +Makefile: Makefile.in config.status + ./config.status + + +.PHONY: depend +depend: Makefile.dep +Makefile.dep: + $(PYTHON) $(MAKEDEP) $(DEFS) -o Makefile.dep -e -x libcvmix.a @srcdir@/src/shared diff --git a/ac/deps/Makefile.fms.in b/ac/deps/Makefile.fms.in index 0286d94b58..05680c5af1 100644 --- a/ac/deps/Makefile.fms.in +++ b/ac/deps/Makefile.fms.in @@ -1,60 +1,30 @@ -# Makefile template for autoconf builds using mkmf +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + +# Makefile template for FMS # # Compiler flags are configured by autoconf's configure script. # -# Source code dependencies are configured by mkmf and list_paths, specified in -# the `Makefile.mkmf` file. -# -# mkmf conventions are close, but not identical, to autoconf. We attempt to -# map the autoconf variables to the mkmf variables. -# -# The following variables are used by Makefiles generated by mkmf. -# -# CC C compiler -# CXX C++ compiler -# FC Fortran compiler (f77 and f90) -# LD Linker -# AR Archiver -# -# CPPDEFS Preprocessor macros -# CPPFLAGS C preprocessing flags -# CXXFLAGS C++ preprocessing flags -# FPPFLAGS Fortran preprocessing flags -# -# CFLAGS C compiler flags -# FFLAGS Fortran compiler flags -# LDFLAGS Linker flags + libraries -# ARFLAGS Archiver flags -# -# OTHERFLAGS Additional flags for all languages (C, C++, Fortran) -# OTHER_CFLAGS Optional C flags -# OTHER_CXXFLAGS Optional C++ flags -# OTHER_FFLAGS Optional Fortran flags -# TMPFILES Placeholder for `make clean` deletion (as `make neat`). -# -# -# NOTES: -# - FPPFLAGS and FFLAGS always appear as a pair, and autoconf does not use -# FPPFLAGS, so FPPFLAGS does not serve much purpose. -# -# - mkmf's FFLAGS does not distinguish between autoconf's fixed-format -# FFLAGS and free-format FCFLAGS. -# -# - LDFLAGS does not distinguish between autoconf's LDFLAGS and LIBS. -# It also places both after the executable rather than just LIBS. +# Source code dependencies are configured by makedep and saved to Makefile.dep. CC = @CC@ FC = @FC@ LD = @FC@ AR = @AR@ +PYTHON = @PYTHON@ +MAKEDEP = @MAKEDEP@ -CPPDEFS = @DEFS@ +DEFS = @DEFS@ CPPFLAGS = @CPPFLAGS@ -FFLAGS = @FCFLAGS@ +FCFLAGS = @FCFLAGS@ LDFLAGS = @LDFLAGS@ +LIBS = @LIBS@ ARFLAGS = @ARFLAGS@ -# Gather modulefiles -TMPFILES = $(wildcard *.mod) +-include Makefile.dep -include Makefile.mkmf +.PHONY: depend +depend: Makefile.dep +Makefile.dep: + $(PYTHON) $(MAKEDEP) $(DEFS) -o Makefile.dep -e -x libFMS.a -s @srcdir@/test_fms @srcdir@ diff --git a/ac/deps/Makefile.gsw.in b/ac/deps/Makefile.gsw.in new file mode 100644 index 0000000000..5cbc14bbbe --- /dev/null +++ b/ac/deps/Makefile.gsw.in @@ -0,0 +1,30 @@ +# Makefile template for GSW +# +# Compiler flags are configured by autoconf's configure script. +# +# Source code dependencies are configured by makedep and saved to Makefile.dep. + +FC = @FC@ +LD = @FC@ +AR = @AR@ +PYTHON = @PYTHON@ +MAKEDEP = @MAKEDEP@ + +DEFS = @DEFS@ +CPPFLAGS = @CPPFLAGS@ +FCFLAGS = @FCFLAGS@ +LDFLAGS = @LDFLAGS@ +LIBS = @LIBS@ +ARFLAGS = @ARFLAGS@ + +-include Makefile.dep + +# Generate Makefile from template +Makefile: Makefile.in config.status + ./config.status + + +.PHONY: depend +depend: Makefile.dep +Makefile.dep: + $(PYTHON) $(MAKEDEP) $(DEFS) -o Makefile.dep -e -x libgsw.a @srcdir@ diff --git a/ac/deps/configure.cvmix.ac b/ac/deps/configure.cvmix.ac new file mode 100644 index 0000000000..714ab803a4 --- /dev/null +++ b/ac/deps/configure.cvmix.ac @@ -0,0 +1,91 @@ +# Autoconf configuration +AC_PREREQ([2.63]) + +AC_INIT( + [GSW], + [ ], + [https://github.com/TEOS-10/GSW-Fortran/issues]) + +# Validate srdcir and configure input +AC_CONFIG_SRCDIR([src/shared/cvmix_utils.F90]) +AC_CONFIG_MACRO_DIR([m4]) + + +# Build dependencies +AC_ARG_VAR([PYTHON], [Python interpreter command]) +AC_ARG_VAR([MAKEDEP], [Makefile dependency generator]) + + +# Fortran configuration +AC_LANG([Fortran]) +AC_FC_SRCEXT([f90]) +AC_PROG_FC + + +# netCDF configuration + +# Check for netcdf.h header function declarations. +# If unavailable, then try to invoke nc-create. +AC_LANG_PUSH([C]) +AC_CHECK_HEADERS([netcdf.h], [], [ + AS_UNSET([ac_cv_header_netcdf_h]) + AC_PATH_PROG([NC_CONFIG], [nc-config]) + AS_IF([test -n "$NC_CONFIG"], [ + AC_SUBST([CPPFLAGS], ["$CPPFLAGS -I$($NC_CONFIG --includedir)"]) + ], + [AC_MSG_ERROR([Could not find nc-config.])] + ) + AC_CHECK_HEADERS([netcdf.h], [], [ + AC_MSG_ERROR([Could not find netcdf.h]) + ]) +]) +AC_LANG_POP([C]) + +# Search for the Fortran netCDF module, fallback to nf-config. +AX_FC_CHECK_MODULE([netcdf], [], [ + AS_UNSET([ax_fc_cv_mod_netcdf]) + AC_PATH_PROG([NF_CONFIG], [nf-config]) + AS_IF([test -n "$NF_CONFIG"], [ + AC_SUBST([FCFLAGS], ["$FCFLAGS -I$($NF_CONFIG --includedir)"]) + ], + [AC_MSG_ERROR([Could not find nf-config.])] + ) + AX_FC_CHECK_MODULE([netcdf], [], [ + AC_MSG_ERROR([Could not find netcdf module.]) + ]) +]) + + +# Verify that Python is available +AS_IF([test -z "$PYTHON"], [ + AC_PATH_PROGS([PYTHON], [python python3 python2]) +]) +AS_IF([test -z "$PYTHON"], [ + AC_MSG_ERROR([Could not find python.]) +]) +AC_SUBST([PYTHON]) + + +# Verify that makedep is available +AS_IF([test -z "$MAKEDEP"], [ + AC_PATH_PROG([MAKEDEP], [makedep]) +]) +AS_IF([test -z "$MAKEDEP"], [ + AC_MSG_ERROR([Could not find makedep.]) +]) +AC_SUBST([MAKEDEP]) + + +# Autoconf does not configure the archiver (ar), as it is handled by Automake. +AR=ar +ARFLAGS=rv +AC_SUBST([AR]) +AC_SUBST([ARFLAGS]) + +AC_CONFIG_COMMANDS([Makefile.dep], [make depend]) + +AC_SUBST([CPPFLAGS]) + +# Prepare output +AC_CONFIG_FILES([Makefile]) +AC_OUTPUT diff --git a/ac/deps/configure.fms.ac b/ac/deps/configure.fms.ac index bf899126cc..f00c4343e7 100644 --- a/ac/deps/configure.fms.ac +++ b/ac/deps/configure.fms.ac @@ -1,3 +1,7 @@ +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + # Autoconf configuration AC_PREREQ([2.63]) @@ -10,7 +14,21 @@ AC_INIT( AC_CONFIG_SRCDIR([fms/fms.F90]) AC_CONFIG_MACRO_DIR([m4]) + +# Build dependencies +AC_ARG_VAR([PYTHON], [Python interpreter command]) +AC_ARG_VAR([MAKEDEP], [Makefile dependency generator]) + + # C configuration + +# Autoconf assumes that LDFLAGS can be passed to CFLAGS, even though this is +# not valid in some compilers. This can cause basic CC tests to fail. +# Since we do not link with CC, we can safely disable LDFLAGS for AC_PROG_CC. +FC_LDFLAGS="$LDFLAGS" +LDFLAGS="" + +# C compiler verification AC_PROG_CC AX_MPI CC=$MPICC @@ -55,10 +73,13 @@ AC_CHECK_FUNCS([gettid], [], [ # FMS 2019.01.03 uses __APPLE__ to disable Linux CPU affinity calls. AC_CHECK_FUNCS([sched_getaffinity], [], [AC_DEFINE([__APPLE__])]) +# Restore LDFLAGS +LDFLAGS="$FC_LDFLAGS" + -# Standard Fortran configuration -AC_LANG(Fortran) -AC_FC_SRCEXT(f90) +# Fortran configuration +AC_LANG([Fortran]) +AC_FC_SRCEXT([f90]) AC_PROG_FC @@ -158,48 +179,37 @@ AX_FC_ALLOW_ARG_MISMATCH FCFLAGS="$FCFLAGS $ALLOW_ARG_MISMATCH_FCFLAGS" -# Search for mkmf build tools -AC_PATH_PROG([LIST_PATHS], [list_paths]) -AS_IF([test -z "$LIST_PATHS"], [ - AC_PATH_PROG([LIST_PATHS], [list_paths], [], ["$PATH:${srcdir}/../../bin"]) - AS_IF([test -z "$LIST_PATHS"], - [AC_MSG_ERROR([Could not find list_paths.])], - [AC_SUBST(PATH, ["$PATH:${srcdir}/../../bin"])]) - ] -) - -AC_PATH_PROG([MKMF], [mkmf]) -AS_IF([test -z "$MKMF"], [ - AC_PATH_PROG([MKMF], [mkmf], [], ["$PATH:${srcdir}/../../bin"]) - AS_IF([test -z "$MKMF"], - [AC_MSG_ERROR([Could not find mkmf.])], - [AC_SUBST(PATH, ["$PATH:${srcdir}/../../bin"])]) - ] -) - - -# MKMF commands -AC_CONFIG_COMMANDS([path_names], - [${LIST_PATHS} -l ${srcdir}], - [LIST_PATHS=${LIST_PATHS}] -) +# Verify that Python is available +AS_IF([test -z "$PYTHON"], [ + AC_PATH_PROGS([PYTHON], [python python3 python2]) +]) +AS_IF([test -z "$PYTHON"], [ + AC_MSG_ERROR([Could not find python.]) +]) +AC_SUBST([PYTHON]) -AC_CONFIG_COMMANDS([mkmf], - [${MKMF} -p libFMS.a -m Makefile.mkmf path_names], - [MKMF=${MKMF}] -) +# Verify that makedep is available +AS_IF([test -z "$MAKEDEP"], [ + AC_PATH_PROG([MAKEDEP], [makedep]) +]) +AS_IF([test -z "$MAKEDEP"], [ + AC_MSG_ERROR([Could not find makedep.]) +]) +AC_SUBST([MAKEDEP]) # Autoconf does not configure the archiver (ar), as it is handled by Automake. # TODO: Properly configure this tool. For now, we hard-set this to `ar`. AR=ar ARFLAGS=rv -AC_SUBST(AR) -AC_SUBST(ARFLAGS) +AC_SUBST([AR]) +AC_SUBST([ARFLAGS]) + +AC_CONFIG_COMMANDS([Makefile.dep], [make depend]) +AC_SUBST([CPPFLAGS]) # Prepare output -AC_SUBST(CPPFLAGS) -AC_CONFIG_FILES(Makefile) +AC_CONFIG_FILES([Makefile]) AC_OUTPUT diff --git a/ac/deps/configure.gsw.ac b/ac/deps/configure.gsw.ac new file mode 100644 index 0000000000..be61eb7040 --- /dev/null +++ b/ac/deps/configure.gsw.ac @@ -0,0 +1,90 @@ +# Autoconf configuration +AC_PREREQ([2.63]) + +AC_INIT( + [GSW], + [ ], + [https://github.com/TEOS-10/GSW-Fortran/issues]) + +# Validate srdcir and configure input +AC_CONFIG_SRCDIR([modules/gsw_mod_toolbox.f90]) +AC_CONFIG_MACRO_DIR([m4]) + +# Dependency configuration +AC_ARG_VAR([PYTHON], [Python interpreter command]) +AC_ARG_VAR([MAKEDEP], [Makefile dependency generator]) + + +# Fortran compiler test +AC_LANG([Fortran]) +AC_FC_SRCEXT([f90]) +AC_PROG_FC + + +# netCDF configuration + +# Check for netcdf.h header function declarations. +# If unavailable, then try to invoke nc-create. +AC_LANG_PUSH([C]) +AC_CHECK_HEADERS([netcdf.h], [], [ + AS_UNSET([ac_cv_header_netcdf_h]) + AC_PATH_PROG([NC_CONFIG], [nc-config]) + AS_IF([test -n "$NC_CONFIG"], [ + AC_SUBST([CPPFLAGS], ["$CPPFLAGS -I$($NC_CONFIG --includedir)"]) + ], + [AC_MSG_ERROR([Could not find nc-config.])] + ) + AC_CHECK_HEADERS([netcdf.h], [], [ + AC_MSG_ERROR([Could not find netcdf.h]) + ]) +]) +AC_LANG_POP([C]) + +# Search for the Fortran netCDF module, fallback to nf-config. +AX_FC_CHECK_MODULE([netcdf], [], [ + AS_UNSET([ax_fc_cv_mod_netcdf]) + AC_PATH_PROG([NF_CONFIG], [nf-config]) + AS_IF([test -n "$NF_CONFIG"], [ + AC_SUBST([FCFLAGS], ["$FCFLAGS -I$($NF_CONFIG --includedir)"]) + ], + [AC_MSG_ERROR([Could not find nf-config.])] + ) + AX_FC_CHECK_MODULE([netcdf], [], [ + AC_MSG_ERROR([Could not find netcdf module.]) + ]) +]) + + +# Verify that Python is available +AS_IF([test -z "$PYTHON"], [ + AC_PATH_PROGS([PYTHON], [python python3 python2]) +]) +AS_IF([test -z "$PYTHON"], [ + AC_MSG_ERROR([Could not find python.]) +]) +AC_SUBST([PYTHON]) + + +# Verify that makedep is available +AS_IF([test -z "$MAKEDEP"], [ + AC_PATH_PROG([MAKEDEP], [makedep]) +]) +AS_IF([test -z "$MAKEDEP"], [ + AC_MSG_ERROR([Could not find makedep.]) +]) +AC_SUBST([MAKEDEP]) + + +# Autoconf does not configure the archiver (ar), as it is handled by Automake. +AR=ar +ARFLAGS=rv +AC_SUBST([AR]) +AC_SUBST([ARFLAGS]) + +AC_CONFIG_COMMANDS([Makefile.dep], [make depend]) + +AC_SUBST([CPPFLAGS]) + +# Prepare output +AC_CONFIG_FILES([Makefile]) +AC_OUTPUT diff --git a/ac/deps/m4/ax_fc_allow_arg_mismatch.m4 b/ac/deps/m4/ax_fc_allow_arg_mismatch.m4 index cffa302c66..a525e4f28a 100644 --- a/ac/deps/m4/ax_fc_allow_arg_mismatch.m4 +++ b/ac/deps/m4/ax_fc_allow_arg_mismatch.m4 @@ -1,3 +1,7 @@ +dnl This file is part of MOM6, the Modular Ocean Model version 6. +dnl See the LICENSE file for licensing information. +dnl SPDX-License-Identifier: Apache-2.0 +dnl dnl Test if mismatched function arguments are permitted. dnl dnl This macro tests if a flag is required to enable mismatched functions in diff --git a/ac/deps/m4/ax_fc_allow_invalid_boz.m4 b/ac/deps/m4/ax_fc_allow_invalid_boz.m4 index 5d4521b5fb..ef2b20342f 100644 --- a/ac/deps/m4/ax_fc_allow_invalid_boz.m4 +++ b/ac/deps/m4/ax_fc_allow_invalid_boz.m4 @@ -1,3 +1,7 @@ +dnl This file is part of MOM6, the Modular Ocean Model version 6. +dnl See the LICENSE file for licensing information. +dnl SPDX-License-Identifier: Apache-2.0 +dnl dnl Test if BOZ literal assignment is supported. dnl dnl This macro tests if a flag is required to enable BOZ literal assignments diff --git a/ac/deps/m4/ax_fc_check_c_lib.m4 b/ac/deps/m4/ax_fc_check_c_lib.m4 new file mode 100644 index 0000000000..692fe722df --- /dev/null +++ b/ac/deps/m4/ax_fc_check_c_lib.m4 @@ -0,0 +1,49 @@ +dnl This file is part of MOM6, the Modular Ocean Model version 6. +dnl See the LICENSE file for licensing information. +dnl SPDX-License-Identifier: Apache-2.0 +dnl +dnl AX_FC_CHECK_C_LIB(LIBRARY, FUNCTION, +dnl [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND], +dnl [OTHER-LDFLAGS], [OTHER-LIBS]) +dnl +dnl This macro checks if a C library can be referenced by a Fortran compiler. +dnl +dnl Results are cached in `ax_fc_cv_c_lib_LIBRARY_FUNCTION`. +dnl +dnl NOTE: Might be possible to rewrite this to use `AX_FC_CHECK_BIND_C`. +dnl +AC_DEFUN([AX_FC_CHECK_C_LIB], [ + AS_VAR_PUSHDEF([ax_fc_C_Lib], [ax_fc_cv_c_lib_$1_$2]) + m4_ifval([$5], + [ax_fc_c_lib_msg_LDFLAGS=" with $5"], + [ax_fc_c_lib_msg_LDFLAGS=""] + ) + AC_CACHE_CHECK( + [for $2 in -l$1$ax_fc_c_lib_msg_LDFLAGS], [ax_fc_cv_c_lib_$1_$2], [ + ax_fc_check_c_lib_save_LDFLAGS=$LDFLAGS + LDFLAGS="$6 $LDFLAGS" + ax_fc_check_c_lib_save_LIBS=$LIBS + LIBS="-l$1 $7 $LIBS" + AC_LINK_IFELSE( + [AC_LANG_PROGRAM([],[dnl +dnl begin code block + interface + subroutine test() bind(c, name="$2") + end subroutine test + end interface + call test]) +dnl end code block + ], + [AS_VAR_SET([ax_fc_C_Lib], [yes])], + [AS_VAR_SET([ax_fc_C_Lib], [no])] + ) + LDFLAGS=$ax_fc_check_c_lib_save_LDFLAGS + LIBS=$ax_fc_check_c_lib_save_LIBS + ] + ) + AS_VAR_IF([ax_fc_C_Lib], [yes], + [m4_default([$3], [LIBS="-l$1 $LIBS"])], + [$4] + ) + AS_VAR_POPDEF([ax_fc_C_Lib]) +]) diff --git a/ac/deps/m4/ax_fc_check_lib.m4 b/ac/deps/m4/ax_fc_check_lib.m4 index c0accab6cd..4074b52e46 100644 --- a/ac/deps/m4/ax_fc_check_lib.m4 +++ b/ac/deps/m4/ax_fc_check_lib.m4 @@ -1,3 +1,7 @@ +dnl This file is part of MOM6, the Modular Ocean Model version 6. +dnl See the LICENSE file for licensing information. +dnl SPDX-License-Identifier: Apache-2.0 +dnl dnl AX_FC_CHECK_LIB(LIBRARY, FUNCTION, dnl [MODULE], [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND], dnl [OTHER-LDFLAGS], [OTHER-LIBS]) @@ -18,7 +22,7 @@ dnl library with different -L flags, or perhaps other ld configurations. dnl dnl Results are cached in the ax_fc_cv_lib_LIBRARY_FUNCTION variable. dnl -AC_DEFUN([AX_FC_CHECK_LIB],[dnl +AC_DEFUN([AX_FC_CHECK_LIB],[ AS_VAR_PUSHDEF([ax_fc_Lib], [ax_fc_cv_lib_$1_$2]) m4_ifval([$6], [ax_fc_lib_msg_LDFLAGS=" with $6"], @@ -29,14 +33,15 @@ AC_DEFUN([AX_FC_CHECK_LIB],[dnl LDFLAGS="$6 $LDFLAGS" ax_fc_check_lib_save_LIBS=$LIBS LIBS="-l$1 $7 $LIBS" - AS_IF([test -n $3], + AS_IF([test -n "$3"], [ax_fc_use_mod="use $3"], [ax_fc_use_mod=""]) - AC_LINK_IFELSE([ - AC_LANG_PROGRAM([], [dnl + AC_LINK_IFELSE([dnl +dnl Begin 7-column code block +AC_LANG_PROGRAM([], [dnl $ax_fc_use_mod - call $2]dnl - ) + call $2])dnl +dnl End code block ], [AS_VAR_SET([ax_fc_Lib], [yes])], [AS_VAR_SET([ax_fc_Lib], [no])] diff --git a/ac/deps/m4/ax_fc_check_module.m4 b/ac/deps/m4/ax_fc_check_module.m4 index 1cfd0c5a5d..e902882524 100644 --- a/ac/deps/m4/ax_fc_check_module.m4 +++ b/ac/deps/m4/ax_fc_check_module.m4 @@ -1,3 +1,7 @@ +dnl This file is part of MOM6, the Modular Ocean Model version 6. +dnl See the LICENSE file for licensing information. +dnl SPDX-License-Identifier: Apache-2.0 +dnl dnl AX_FC_CHECK_MODULE(MODULE, dnl [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND], dnl [OTHER-FCFLAGS]) diff --git a/ac/deps/m4/ax_fc_cray_pointer.m4 b/ac/deps/m4/ax_fc_cray_pointer.m4 index 57ed186afa..aef870c75d 100644 --- a/ac/deps/m4/ax_fc_cray_pointer.m4 +++ b/ac/deps/m4/ax_fc_cray_pointer.m4 @@ -1,3 +1,7 @@ +dnl This file is part of MOM6, the Modular Ocean Model version 6. +dnl See the LICENSE file for licensing information. +dnl SPDX-License-Identifier: Apache-2.0 +dnl dnl AX_FC_CRAY_POINTER([ACTION-IF-SUCCESS], [ACTION-IF-FAILURE]) dnl dnl This macro tests if any flags are required to enable Cray pointers. diff --git a/ac/deps/m4/ax_fc_line_length.m4 b/ac/deps/m4/ax_fc_line_length.m4 index 97271da1f6..90770469da 100644 --- a/ac/deps/m4/ax_fc_line_length.m4 +++ b/ac/deps/m4/ax_fc_line_length.m4 @@ -1,3 +1,7 @@ +dnl This file is part of MOM6, the Modular Ocean Model version 6. +dnl See the LICENSE file for licensing information. +dnl SPDX-License-Identifier: Apache-2.0 +dnl # AX_FC_LINE_LENGTH([LENGTH], [ACTION-IF-SUCCESS], # [ACTION-IF-FAILURE = FAILURE]) # ------------------------------------------------ diff --git a/ac/deps/m4/ax_fc_real8.m4 b/ac/deps/m4/ax_fc_real8.m4 index e914b9f39a..15f0acda22 100644 --- a/ac/deps/m4/ax_fc_real8.m4 +++ b/ac/deps/m4/ax_fc_real8.m4 @@ -1,3 +1,7 @@ +dnl This file is part of MOM6, the Modular Ocean Model version 6. +dnl See the LICENSE file for licensing information. +dnl SPDX-License-Identifier: Apache-2.0 +dnl dnl Determine the flag required to force 64-bit reals. dnl dnl Many applications do not specify the kind of its real variables, even @@ -15,12 +19,14 @@ dnl avoiding any flags with affect integers, but this should still be used with dnl some care. dnl dnl GCC -fdefault-real-8, -fdefault-double-8 +dnl AMD (flang) -fdefault-real-8 dnl [Common alias] -r8 -dnl Intel Fortran -real-kind 64 -dnl PGI Fortran -Mr8 -dnl Cray Fortran -s real64 +dnl Intel -real-kind 64 +dnl PGI/Nvidia -Mr8 +dnl Cray -s real64 dnl NAG -double dnl +dnl dnl NOTE: dnl - Many compilers accept -r8 for real and double precision sizes, but dnl several compiler-specific options are also provided. @@ -34,31 +40,28 @@ dnl dnl Neither flag describes what we actually want, but we include it here dnl as a last resort. dnl -AC_DEFUN([AX_FC_REAL8], -[ +AC_DEFUN([AX_FC_REAL8], [ REAL8_FCFLAGS= - AC_ARG_ENABLE([real8], - [AS_HELP_STRING([--disable-real-8], [do not force 8-byte reals])]) + AC_ARG_ENABLE([real8], [ + AS_HELP_STRING([--disable-real-8], [do not force 8-byte reals]) + ]) if test "$enable_real8" != no; then AC_CACHE_CHECK([for $FC option to force 8-byte reals], - [ac_cv_prog_fc_real8], - [AC_COMPILE_IFELSE( - [AC_LANG_PROGRAM([], [ - real :: x(4) - double precision :: y(4) - integer, parameter :: & - m = merge(1, 0, kind(x(1)) == selected_real_kind(15, 307)), & - n = merge(1, 0, kind(y(1)) == selected_real_kind(15, 307)) - print *, x(::m) - print *, y(::n) - ])], - [ac_cv_prog_fc_real8='none needed'], - [ac_cv_prog_fc_real8='unsupported' - for ac_option in "-fdefault-real-8 -fdefault-double-8" -r8 "-real-kind 64" -Mr8 "-s real64" -double; do - ac_save_FCFLAGS=$FCFLAGS - FCFLAGS="$FCFLAGS $ac_option" - AC_LINK_IFELSE( - [AC_LANG_PROGRAM([], [ + [ac_cv_prog_fc_real8], [ + ac_cv_prog_fc_real8='unsupported' + ac_fc_real8_FCFLAGS_save=$FCFLAGS + for ac_flag in none \ + -fdefault-real-8 \ + "-fdefault-real-8 -fdefault-double-8" \ + -r8 \ + "-real-kind 64" \ + -Mr8 \ + "-s real64" \ + -double + do + test "$ac_flag" != none && FCFLAGS="$ac_fc_real8_FCFLAGS_save $ac_flag" + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([], [ real :: x(4) double precision :: y(4) integer, parameter :: & @@ -66,21 +69,21 @@ AC_DEFUN([AX_FC_REAL8], n = merge(1, 0, kind(y(1)) == selected_real_kind(15, 307)) print *, x(::m) print *, y(::n) - ])], - [ac_cv_prog_fc_real8=$ac_option] - ) - FCFLAGS=$ac_save_FCFLAGS - if test "$ac_cv_prog_fc_real8" != unsupported; then - break - fi - done]) - ]) - case $ac_cv_prog_fc_real8 in #( - "none needed" | unsupported) - ;; #( - *) - REAL8_FCFLAGS=$ac_cv_prog_fc_real8 ;; - esac + ]) + ], [ac_cv_prog_fc_real8=$ac_flag ; break]) + done + FCFLAGS=$ac_fc_real8_FCFLAGS_save + ]) + case $ac_cv_prog_fc_real8 in #( + "none") + ac_cv_prog_fc_real8='none needed' + ;; #( + unsupported) + ;; #( + *) + REAL8_FCFLAGS=$ac_cv_prog_fc_real8 + ;; + esac fi - AC_SUBST(REAL8_FCFLAGS) + AC_SUBST([REAL8_FCFLAGS]) ]) diff --git a/ac/m4/ax_fc_check_bind_c.m4 b/ac/m4/ax_fc_check_bind_c.m4 new file mode 100644 index 0000000000..e2a42f1bfb --- /dev/null +++ b/ac/m4/ax_fc_check_bind_c.m4 @@ -0,0 +1,46 @@ +dnl This file is part of MOM6, the Modular Ocean Model version 6. +dnl See the LICENSE file for licensing information. +dnl SPDX-License-Identifier: Apache-2.0 +dnl +dnl AX_FC_CHECK_C_LIB(FUNCTION, +dnl [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND], +dnl [OTHER-LDFLAGS], [OTHER-LIBS]) +dnl +dnl This macro checks if a C binding is available to the compiler. +dnl +dnl Equivalently, it checks if the Fortran compiler can see a C function. +dnl +dnl Results are cached in `ax_fc_cv_bind_c_FUNCTION`. +dnl +AC_DEFUN([AX_FC_CHECK_BIND_C], [ + AS_VAR_PUSHDEF([ax_fc_Bind_C], [ax_fc_cv_bind_c_$1]) + m4_ifval([$4], + [ax_fc_bind_c_msg_LDFLAGS=" with $4"], + [ax_fc_bind_c_msg_LDFLAGS=""] + ) + AC_CACHE_CHECK( + [if $FC can bind $1$ax_fc_bind_c_msg_LDFLAGS], [ax_fc_cv_bind_c_$1], [ + ax_fc_check_bind_c_save_LDFLAGS=$LDFLAGS + LDFLAGS="$4 $LDFLAGS" + ax_fc_check_bind_c_save_LIBS=$LIBS + LIBS="$5 $LIBS" + AC_LINK_IFELSE( + [AC_LANG_PROGRAM([],[dnl +dnl begin code block + interface + subroutine test() bind(c, name="$1") + end subroutine test + end interface + call test]) +dnl end code block + ], + [AS_VAR_SET([ax_fc_Bind_C], [yes])], + [AS_VAR_SET([ax_fc_Bind_C], [no])] + ) + LDFLAGS=$ax_fc_check_bind_c_save_LDFLAGS + LIBS=$ax_fc_check_bind_c_save_LIBS + ] + ) + AS_VAR_IF([ax_fc_Bind_C], [yes], [$2], [$3]) + AS_VAR_POPDEF([ax_fc_Bind_C]) +]) diff --git a/ac/m4/ax_fc_check_c_lib.m4 b/ac/m4/ax_fc_check_c_lib.m4 new file mode 100644 index 0000000000..692fe722df --- /dev/null +++ b/ac/m4/ax_fc_check_c_lib.m4 @@ -0,0 +1,49 @@ +dnl This file is part of MOM6, the Modular Ocean Model version 6. +dnl See the LICENSE file for licensing information. +dnl SPDX-License-Identifier: Apache-2.0 +dnl +dnl AX_FC_CHECK_C_LIB(LIBRARY, FUNCTION, +dnl [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND], +dnl [OTHER-LDFLAGS], [OTHER-LIBS]) +dnl +dnl This macro checks if a C library can be referenced by a Fortran compiler. +dnl +dnl Results are cached in `ax_fc_cv_c_lib_LIBRARY_FUNCTION`. +dnl +dnl NOTE: Might be possible to rewrite this to use `AX_FC_CHECK_BIND_C`. +dnl +AC_DEFUN([AX_FC_CHECK_C_LIB], [ + AS_VAR_PUSHDEF([ax_fc_C_Lib], [ax_fc_cv_c_lib_$1_$2]) + m4_ifval([$5], + [ax_fc_c_lib_msg_LDFLAGS=" with $5"], + [ax_fc_c_lib_msg_LDFLAGS=""] + ) + AC_CACHE_CHECK( + [for $2 in -l$1$ax_fc_c_lib_msg_LDFLAGS], [ax_fc_cv_c_lib_$1_$2], [ + ax_fc_check_c_lib_save_LDFLAGS=$LDFLAGS + LDFLAGS="$6 $LDFLAGS" + ax_fc_check_c_lib_save_LIBS=$LIBS + LIBS="-l$1 $7 $LIBS" + AC_LINK_IFELSE( + [AC_LANG_PROGRAM([],[dnl +dnl begin code block + interface + subroutine test() bind(c, name="$2") + end subroutine test + end interface + call test]) +dnl end code block + ], + [AS_VAR_SET([ax_fc_C_Lib], [yes])], + [AS_VAR_SET([ax_fc_C_Lib], [no])] + ) + LDFLAGS=$ax_fc_check_c_lib_save_LDFLAGS + LIBS=$ax_fc_check_c_lib_save_LIBS + ] + ) + AS_VAR_IF([ax_fc_C_Lib], [yes], + [m4_default([$3], [LIBS="-l$1 $LIBS"])], + [$4] + ) + AS_VAR_POPDEF([ax_fc_C_Lib]) +]) diff --git a/ac/m4/ax_fc_check_lib.m4 b/ac/m4/ax_fc_check_lib.m4 index a7f848cd60..4074b52e46 100644 --- a/ac/m4/ax_fc_check_lib.m4 +++ b/ac/m4/ax_fc_check_lib.m4 @@ -1,3 +1,7 @@ +dnl This file is part of MOM6, the Modular Ocean Model version 6. +dnl See the LICENSE file for licensing information. +dnl SPDX-License-Identifier: Apache-2.0 +dnl dnl AX_FC_CHECK_LIB(LIBRARY, FUNCTION, dnl [MODULE], [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND], dnl [OTHER-LDFLAGS], [OTHER-LIBS]) diff --git a/ac/m4/ax_fc_check_module.m4 b/ac/m4/ax_fc_check_module.m4 index 1cfd0c5a5d..e902882524 100644 --- a/ac/m4/ax_fc_check_module.m4 +++ b/ac/m4/ax_fc_check_module.m4 @@ -1,3 +1,7 @@ +dnl This file is part of MOM6, the Modular Ocean Model version 6. +dnl See the LICENSE file for licensing information. +dnl SPDX-License-Identifier: Apache-2.0 +dnl dnl AX_FC_CHECK_MODULE(MODULE, dnl [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND], dnl [OTHER-FCFLAGS]) diff --git a/ac/m4/ax_fc_real8.m4 b/ac/m4/ax_fc_real8.m4 index e914b9f39a..15f0acda22 100644 --- a/ac/m4/ax_fc_real8.m4 +++ b/ac/m4/ax_fc_real8.m4 @@ -1,3 +1,7 @@ +dnl This file is part of MOM6, the Modular Ocean Model version 6. +dnl See the LICENSE file for licensing information. +dnl SPDX-License-Identifier: Apache-2.0 +dnl dnl Determine the flag required to force 64-bit reals. dnl dnl Many applications do not specify the kind of its real variables, even @@ -15,12 +19,14 @@ dnl avoiding any flags with affect integers, but this should still be used with dnl some care. dnl dnl GCC -fdefault-real-8, -fdefault-double-8 +dnl AMD (flang) -fdefault-real-8 dnl [Common alias] -r8 -dnl Intel Fortran -real-kind 64 -dnl PGI Fortran -Mr8 -dnl Cray Fortran -s real64 +dnl Intel -real-kind 64 +dnl PGI/Nvidia -Mr8 +dnl Cray -s real64 dnl NAG -double dnl +dnl dnl NOTE: dnl - Many compilers accept -r8 for real and double precision sizes, but dnl several compiler-specific options are also provided. @@ -34,31 +40,28 @@ dnl dnl Neither flag describes what we actually want, but we include it here dnl as a last resort. dnl -AC_DEFUN([AX_FC_REAL8], -[ +AC_DEFUN([AX_FC_REAL8], [ REAL8_FCFLAGS= - AC_ARG_ENABLE([real8], - [AS_HELP_STRING([--disable-real-8], [do not force 8-byte reals])]) + AC_ARG_ENABLE([real8], [ + AS_HELP_STRING([--disable-real-8], [do not force 8-byte reals]) + ]) if test "$enable_real8" != no; then AC_CACHE_CHECK([for $FC option to force 8-byte reals], - [ac_cv_prog_fc_real8], - [AC_COMPILE_IFELSE( - [AC_LANG_PROGRAM([], [ - real :: x(4) - double precision :: y(4) - integer, parameter :: & - m = merge(1, 0, kind(x(1)) == selected_real_kind(15, 307)), & - n = merge(1, 0, kind(y(1)) == selected_real_kind(15, 307)) - print *, x(::m) - print *, y(::n) - ])], - [ac_cv_prog_fc_real8='none needed'], - [ac_cv_prog_fc_real8='unsupported' - for ac_option in "-fdefault-real-8 -fdefault-double-8" -r8 "-real-kind 64" -Mr8 "-s real64" -double; do - ac_save_FCFLAGS=$FCFLAGS - FCFLAGS="$FCFLAGS $ac_option" - AC_LINK_IFELSE( - [AC_LANG_PROGRAM([], [ + [ac_cv_prog_fc_real8], [ + ac_cv_prog_fc_real8='unsupported' + ac_fc_real8_FCFLAGS_save=$FCFLAGS + for ac_flag in none \ + -fdefault-real-8 \ + "-fdefault-real-8 -fdefault-double-8" \ + -r8 \ + "-real-kind 64" \ + -Mr8 \ + "-s real64" \ + -double + do + test "$ac_flag" != none && FCFLAGS="$ac_fc_real8_FCFLAGS_save $ac_flag" + AC_LINK_IFELSE([ + AC_LANG_PROGRAM([], [ real :: x(4) double precision :: y(4) integer, parameter :: & @@ -66,21 +69,21 @@ AC_DEFUN([AX_FC_REAL8], n = merge(1, 0, kind(y(1)) == selected_real_kind(15, 307)) print *, x(::m) print *, y(::n) - ])], - [ac_cv_prog_fc_real8=$ac_option] - ) - FCFLAGS=$ac_save_FCFLAGS - if test "$ac_cv_prog_fc_real8" != unsupported; then - break - fi - done]) - ]) - case $ac_cv_prog_fc_real8 in #( - "none needed" | unsupported) - ;; #( - *) - REAL8_FCFLAGS=$ac_cv_prog_fc_real8 ;; - esac + ]) + ], [ac_cv_prog_fc_real8=$ac_flag ; break]) + done + FCFLAGS=$ac_fc_real8_FCFLAGS_save + ]) + case $ac_cv_prog_fc_real8 in #( + "none") + ac_cv_prog_fc_real8='none needed' + ;; #( + unsupported) + ;; #( + *) + REAL8_FCFLAGS=$ac_cv_prog_fc_real8 + ;; + esac fi - AC_SUBST(REAL8_FCFLAGS) + AC_SUBST([REAL8_FCFLAGS]) ]) diff --git a/ac/m4/mom6_fc_check_lib.m4 b/ac/m4/mom6_fc_check_lib.m4 new file mode 100644 index 0000000000..03f6496acb --- /dev/null +++ b/ac/m4/mom6_fc_check_lib.m4 @@ -0,0 +1,82 @@ +dnl MOM6_FC_CHECK_LIB(LIBRARY, PROCEDURE, +dnl [MODULE], [ARGS], [FUNC-RESULT], [DECLS], +dnl [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND], +dnl [OTHER-LDFLAGS], [OTHER-LIBS]) +dnl +dnl This macro checks if a Fortran library containing a designated function +dnl is available to the compiler. For the most part, this macro should behave +dnl like the Autoconf AC_CHECK_LIB macro. +dnl +dnl This macro differs from AC_CHECK_LIB, since it includes several additional +dnl arguments. Although the next four arguments are optional, they are +dnl required for many function tests. +dnl +dnl - MODULE specifies the Fortran module containing the procedure. +dnl +dnl - ARGS is used to specify any arguments of the procedure. +dnl +dnl - FUNC-RESULT, if set, identifies the procedure as a function rather than +dnl a subroutine, and specifies the function test result. +dnl +dnl - DECLS is used as a code block to explicitly declare variables, when +dnl implicit typing is not sufficient. +dnl +dnl The following argument has also been added. +dnl +dnl - OTHER-LDFLAGS allows specification of supplemental LDFLAGS arguments. +dnl This can be used, for example, to test for the library with different +dnl -L flags, or perhaps other ld configurations. +dnl +dnl Results are cached in the mom6_fc_cv_lib_LIBRARY_PROCEDURE variable. +dnl +AC_DEFUN([MOM6_FC_CHECK_LIB],[ + AS_VAR_PUSHDEF([mom6_fc_Lib], [mom6_fc_cv_lib_$1_$2]) + m4_ifval([$9], + [mom6_fc_lib_msg_LDFLAGS=" with $9"], + [mom6_fc_lib_msg_LDFLAGS=""] + ) + AC_CACHE_CHECK( + [for $2 in -l$1$mom6_fc_lib_msg_LDFLAGS], + [mom6_fc_Lib],[ + mom6_fc_check_lib_save_LDFLAGS=$LDFLAGS + LDFLAGS="$9 $LDFLAGS" + mom6_fc_check_lib_save_LIBS=$LIBS + LIBS="-l$1 $10 $LIBS" + AS_IF([test -n "$3"], + [mom6_fc_use_mod="use $3"], + [mom6_fc_use_mod=""] + ) + AS_IF([test -n "$5"], + [mom6_fc_proc="$5 = $2"], + [mom6_fc_proc="call $2"] + ) + AS_IF([test -n "$4"], + [mom6_fc_proc="${mom6_fc_proc}($4)"] + ) + AS_IF([test -n "$6"], + [mom6_fc_decls="$6"], + [mom6_fc_decls=""] + ) + AC_LANG_PUSH([Fortran]) + AC_LINK_IFELSE([dnl +dnl Begin 7-column code block +AC_LANG_PROGRAM([], [dnl + $mom6_fc_use_mod + $mom6_fc_decls + $mom6_fc_proc])dnl +dnl End code block + ], + [AS_VAR_SET([mom6_fc_Lib], [yes])], + [AS_VAR_SET([mom6_fc_Lib], [no])] + ) + AC_LANG_POP([Fortran]) + LIBS=$mom6_fc_check_lib_save_LIBS + LDFLAGS=$mom6_fc_check_lib_save_LDFLAGS + ] + ) + AS_VAR_IF([mom6_fc_Lib], [yes], + [m4_default([$7], [LIBS="-l$1 $LIBS"])], + [$8] + ) + AS_VAR_POPDEF([mom6_fc_Lib]) +]) diff --git a/ac/makedep b/ac/makedep new file mode 100755 index 0000000000..65a79044c0 --- /dev/null +++ b/ac/makedep @@ -0,0 +1,696 @@ +#!/usr/bin/env python3 + +from __future__ import print_function + +import argparse +import glob +import io +import os +import re +import sys + + +# Fortran tokenization + +re_module = re.compile(r"^ *module +([a-z_0-9]+)") +re_use = re.compile(r"^ *use +([a-z_0-9]+)") +re_cpp_define = re.compile(r"^ *# *define +[_a-zA-Z][_a-zA-Z0-9]") +re_cpp_undef = re.compile(r"^ *# *undef +[_a-zA-Z][_a-zA-Z0-9]") +re_cpp_ifdef = re.compile(r"^ *# *ifdef +[_a-zA-Z][_a-zA-Z0-9]") +re_cpp_ifndef = re.compile(r"^ *# *ifndef +[_a-zA-Z][_a-zA-Z0-9]") +re_cpp_if = re.compile(r"^ *# *if +") +re_cpp_else = re.compile(r"^ *# *else") +re_cpp_endif = re.compile(r"^ *# *endif") +re_cpp_include = re.compile(r"^ *# *include *[<\"']([a-zA-Z_0-9\.]+)[>\"']") +re_f90_include = re.compile(r"^ *include +[\"']([a-zA-Z_0-9\.]+)[\"']") +re_program = re.compile(r"^ *program +([a-z_0-9]+)", re.IGNORECASE) +re_end = re.compile(r"^ *end *(module|procedure) ", re.IGNORECASE) +# NOTE: This excludes comments and tokens with substrings containing `function` +# or `subroutine`, but will fail if the keywords appear in other contexts. +re_procedure = re.compile( + r"^[^!]*(?>', lambda scanner, token: token), + (r'>=', lambda scanner, token: token), + (r'>', lambda scanner, token: token), + (r'<<', lambda scanner, token: token), + (r'<=', lambda scanner, token: token), + (r'<', lambda scanner, token: token), + (r'==', lambda scanner, token: token), + (r'&&', lambda scanner, token: token), + (r'&', lambda scanner, token: token), + (r'\|\|', lambda scanner, token: token), + (r'\|', lambda scanner, token: token), + (r'^ *\# *if', None), + (r'\s+', None), +]) + + +cpp_operate = { + '(': lambda x: x, + '!': lambda x: not x, + 'defined': lambda x, y: x in y, + '*': lambda x, y: x * y, + '/': lambda x, y: x // y, + '+': lambda x, y: x + y, + '-': lambda x, y: x - y, + '>>': lambda x, y: x >> y, + '<<': lambda x, y: x << y, + '==': lambda x, y: x == y, + '>': lambda x, y: x > y, + '>=': lambda x, y: x >= y, + '<': lambda x, y: x < y, + '<=': lambda x, y: x <= y, + '&': lambda x, y: x & y, + '^': lambda x, y: x ^ y, + '|': lambda x, y: x | y, + '&&': lambda x, y: x and y, + '||': lambda x, y: x or y, +} + + +cpp_op_rank = { + '(': 13, + '!': 12, + 'defined': 12, + '*': 11, + '/': 11, + '+': 10, + '-': 10, + '>>': 9, + '<<': 9, + '>': 8, + '>=': 8, + '<': 8, + '<=': 8, + '==': 7, + '&': 6, + '^': 5, + '|': 4, + '&&': 2, + '||': 2, + ')': 1, + '$': 1, + None: 0, +} + + +def create_deps(src_dirs, skip_dirs, makefile, debug, exec_target, fc_rule, + link_externals, defines): + """Create "makefile" after scanning "src_dis".""" + + # Scan everything Fortran related + all_files = find_files(src_dirs, skip_dirs) + + # Lists of things + # ... all F90 source + F90_files = [ + f for f in all_files + if f.endswith('.f90') or f.endswith('.F90') + or f.endswith('.f') or f.endswith('.F') + ] + # ... all C source + c_files = [f for f in all_files if f.endswith('.c')] + + # Dictionaries for associating files to files + # maps basename of file to full path to file + f2F = dict(zip([os.path.basename(f) for f in all_files], all_files)) + # maps basename of file to directory + f2dir = dict(zip([os.path.basename(f) for f in all_files], + [os.path.dirname(f) for f in all_files])) + + # Check for duplicate files in search path + if not len(f2F) == len(all_files): + a = [] + for f in all_files: + if os.path.basename(f) in a: + print('Warning: File {} was found twice! One is being ignored ' + 'but which is undefined.'.format(os.path.basename(f))) + a.append(os.path.basename(f)) + + # maps object file to F90 source + o2F90 = dict(zip([object_file(f) for f in F90_files], F90_files)) + # maps object file to C source + o2c = dict(zip([object_file(f) for f in c_files], c_files)) + + o2mods, o2uses, o2h, o2inc, o2prg, prg2o, mod2o = {}, {}, {}, {}, {}, {}, {} + externals, all_modules = [], [] + for f in F90_files: + mods, used, cpp, inc, prg, has_externals = scan_fortran_file(f, defines) + # maps object file to modules produced + o2mods[object_file(f)] = mods + # maps module produced to object file + for m in mods: + mod2o[m] = object_file(f) + # maps object file to modules used + o2uses[object_file(f)] = used + # maps object file to .h files included + o2h[object_file(f)] = cpp + # maps object file to .inc files included + o2inc[object_file(f)] = inc + # maps object file to executables produced + o2prg[object_file(f)] = prg + if prg: + for p in prg: + if p in prg2o.keys(): + # raise ValueError("Files %s and %s both create the same program '%s'"%( + # f,o2F90[prg2o[p]],p)) + print("Warning: Files {} and {} both create the same " + "program '{}'".format(f, o2F90[prg2o[p]], p)) + o = prg2o[p] + del prg2o[p] + # del o2prg[o] - need to keep so modifying instead + o2prg[o] = ['[ignored %s]' % (p)] + else: + prg2o[p] = object_file(f) + if has_externals: + externals.append(object_file(f)) + all_modules += mods + + for f in c_files: + _, _, cpp, inc, _, _ = scan_fortran_file(f, defines) + # maps object file to .h files included + o2h[object_file(f)] = cpp + externals.append(object_file(f)) + + # Are we building a library, single or multiple executables? + targ_libs = [] + if exec_target: + if exec_target.endswith('.a'): + targ_libs.append(exec_target) + else: + if len(prg2o.keys()) == 1: + o = prg2o.values()[0] + del prg2o[o2prg[o][0]] + prg2o[exec_target] = o + o2prg[o] = exec_target + else: + raise ValueError("Option -x specified an executable name but " + "none or multiple programs were found") + targets = [exec_target] + else: + if len(prg2o.keys()) == 0: + print("Warning: No programs were found and -x did not specify a " + "library to build") + targets = prg2o.keys() + + # Create new makefile + with open(makefile, 'w') as file: + print("# %s created by makedep" % (makefile), file=file) + print(file=file) + print("# Invoked as", file=file) + print('# '+' '.join(sys.argv), file=file) + print(file=file) + print("all:", " ".join(targets), file=file) + + # print(file=file) + # print("# SRC_DIRS is usually set in the parent Makefile but in case is it not we", file=file) + # print("# record it here from when makedep was previously invoked.", file=file) + # print("SRC_DIRS ?= ${SRC_DIRS}", file=file) + + # print(file=file) + # print("# all_files:", ' '.join(all_files), file=file) + + # Write rule for each object from Fortran + for obj in sorted(o2F90.keys()): + found_mods = [m for m in o2uses[obj] if m in all_modules] + found_objs = [mod2o[m] for m in o2uses[obj] if m in all_modules] + found_deps = [ + dep for pair in zip(found_mods, found_objs) for dep in pair + ] + missing_mods = [m for m in o2uses[obj] if m not in all_modules] + + incs, inc_used = nested_inc(o2h[obj] + o2inc[obj], f2F, defines) + inc_mods = [ + u for u in inc_used if u not in found_mods and u in all_modules + ] + + incdeps = sorted(set([f2F[f] for f in incs if f in f2F])) + incargs = sorted(set(['-I' + os.path.dirname(f) for f in incdeps])) + + # Header + print(file=file) + if debug: + print("# Source file {} produces:".format(o2F90[obj]), file=file) + print("# object:", obj, file=file) + print("# modules:", ' '.join(o2mods[obj]), file=file) + print("# uses:", ' '.join(o2uses[obj]), file=file) + print("# found mods:", ' '.join(found_mods), file=file) + print("# found objs:", ' '.join(found_objs), file=file) + print("# missing:", ' '.join(missing_mods), file=file) + print("# includes_all:", ' '.join(incs), file=file) + print("# includes_pth:", ' '.join(incdeps), file=file) + print("# incargs:", ' '.join(incargs), file=file) + print("# program:", ' '.join(o2prg[obj]), file=file) + + # Fortran Module dependencies + if o2mods[obj]: + print(' '.join(o2mods[obj]) + ':', obj, file=file) + + # Fortran object dependencies + obj_incs = ' '.join(inc_mods + incdeps + found_deps) + print(obj + ':', o2F90[obj], obj_incs, file=file) + + # Fortran object build rule + obj_rule = ' '.join([fc_rule] + incargs + ['-c', '$<']) + print('\t' + obj_rule, file=file) + + # Write rule for each object from C + for obj in sorted(o2c.keys()): + incdeps = sorted(set([f2F[h] for h in o2h[obj] if h in f2F])) + incargs = sorted(set(['-I' + os.path.dirname(f) for f in incdeps])) + + # Header + print(file=file) + if debug: + print("# Source file %s produces:" % (o2c[obj]), file=file) + print("# object:", obj, file=file) + print("# includes_all:", ' '.join(o2h[obj]), file=file) + print("# includes_pth:", ' '.join(incdeps), file=file) + print("# incargs:", ' '.join(incargs), file=file) + + # C object dependencies + print(obj + ':', o2c[obj], ' '.join(incdeps), file=file) + + # C object build rule + c_rule = ' '.join( + ['$(CC) $(DEFS) $(CPPFLAGS) $(CFLAGS)'] + incargs + ['-c', '$<'] + ) + #print('\t' + c_rule, ' '.join(incargs), '-c', '$<', file=file) + print('\t' + c_rule, file=file) + + # Externals (so called) + if link_externals: + print(file=file) + print("# Note: The following object files are not associated with " + "modules so we assume we should link with them:", file=file) + print("# ", ' '.join(externals), file=file) + o2x = None + else: + externals = [] + + # Write rules for linking executables + for p in sorted(prg2o.keys()): + o = prg2o[p] + print(file=file) + print(p+':', ' '.join(link_obj(o, o2uses, mod2o, all_modules) + externals), file=file) + print('\t$(LD) $(LDFLAGS) -o $@ $^ $(LIBS)', file=file) + + # Write rules for building libraries + for lb in sorted(targ_libs): + print(file=file) + print(lb+':', ' '.join(list(o2F90.keys()) + list(o2c.keys())), file=file) + print('\t$(AR) $(ARFLAGS) $@ $^', file=file) + + # Write cleanup rules + print(file=file) + print("clean:", file=file) + print('\trm -f *.mod *.o', ' '.join(list(prg2o.keys()) + targ_libs), file=file) + + # Write re-generation rules + print(file=file) + print("remakedep:", file=file) + print('\t'+' '.join(sys.argv), file=file) + + +def link_obj(obj, o2uses, mod2o, all_modules): + """List of all objects needed to link "obj",""" + def recur(obj, depth=0): + if obj not in olst: + olst.append(obj) + else: + return + uses = [m for m in o2uses[obj] if m in all_modules] + if len(uses) > 0: + ouses = [mod2o[m] for m in uses] + for m in uses: + o = mod2o[m] + recur(o, depth=depth+1) + # if o not in olst: + # recur(o, depth=depth+1) + # olst.append(o) + return + return + olst = [] + recur(obj) + return sorted(set(olst)) + + +def nested_inc(inc_files, f2F, defines): + """List of all files included by "inc_files", either by #include or F90 + include.""" + hlst = [] + used_mods = set() + + def recur(hfile): + if hfile not in f2F.keys(): + return + + _, used, cpp, inc, _, _ = scan_fortran_file(f2F[hfile], defines) + + # Record any module updates inside of include files + used_mods.update(used) + + if len(cpp) + len(inc) > 0: + for h in cpp+inc: + if h not in hlst and h in f2F.keys(): + recur(h) + hlst.append(h) + return + return + + for h in inc_files: + recur(h) + + return inc_files + sorted(set(hlst)), used_mods + + +def scan_fortran_file(src_file, defines=None): + """Scan the Fortran file "src_file" and return lists of module defined, + module used, and files included.""" + module_decl, used_modules, cpp_includes, f90_includes, programs = [], [], [], [], [] + + cpp_defines = defines if defines is not None else [] + + cpp_macros = dict( + [t.split('=') if '=' in t else (t, None) for t in cpp_defines] + ) + cpp_group_stack = [] + + with io.open(src_file, 'r', errors='replace') as file: + lines = file.readlines() + + external_namespace = True + # True if we are in the external (i.e. global) namespace + + file_has_externals = False + # True if the file contains any external objects + + cpp_exclude = False + # True if the parser excludes the subsequent lines + + cpp_group_stack = [] + # Stack of condition group exclusion states + + for line in lines: + # Start of #ifdef condition group + match = re_cpp_ifdef.match(line) + if match: + cpp_group_stack.append(cpp_exclude) + + # If outer group is excluding or macro is missing, then exclude + macro = line.lstrip()[1:].split()[1] + cpp_exclude = cpp_exclude or macro not in cpp_macros + + # Start of #ifndef condition group + match = re_cpp_ifndef.match(line) + if match: + cpp_group_stack.append(cpp_exclude) + + # If outer group is excluding or macro is present, then exclude + macro = line.lstrip()[1:].split()[1] + cpp_exclude = cpp_exclude or macro in cpp_macros + + # Start of #if condition group + match = re_cpp_if.match(line) + if match: + cpp_group_stack.append(cpp_exclude) + + cpp_expr_value = cpp_expr_eval(line, cpp_macros) + + cpp_exclude = not cpp_expr_value + + # Complement #else condition group + match = re_cpp_else.match(line) + if match: + # Reverse the exclude state, if there is no outer exclude state + outer_grp_exclude = cpp_group_stack and cpp_group_stack[-1] + cpp_exclude = not cpp_exclude or outer_grp_exclude + + # Restore exclude state when exiting conditional block + match = re_cpp_endif.match(line) + if match: + cpp_exclude = cpp_group_stack.pop() + + # Skip lines inside of false condition blocks + if cpp_exclude: + continue + + # Activate a new macro (ignoring the value) + match = re_cpp_define.match(line) + if match: + # TODO: Tokenize this, don't hunt for `(` in `macro`. + tokens = line.strip()[1:].split(maxsplit=2) + macro = tokens[1] + value = tokens[2] if tokens[2:] else None + if '(' in macro: + # TODO: Actual handling of function macros + macro, arg = macro.split('(', maxsplit=1) + value = '(' + arg + value if value else '(' + arg + cpp_macros[macro] = value + + # Deactivate a macro + match = re_cpp_undef.match(line) + if match: + new_macro = line.lstrip()[1:].split()[1] + try: + cpp_macros.pop(new_macro) + except KeyError: + # C99: "[A macro] is ignored if the specified identifier is + # not currently defined as a macro name." + continue + + match = re_module.match(line.lower()) + if match: + # Avoid "module procedure" statements + if match.group(1) not in 'procedure': + module_decl.append(match.group(1)) + external_namespace = False + + match = re_use.match(line.lower()) + if match: + used_modules.append(match.group(1)) + + match = re_cpp_include.match(line) + if match: + cpp_includes.append(match.group(1)) + + match = re_f90_include.match(line) + if match: + f90_includes.append(match.group(1)) + + match = re_program.match(line) + if match: + programs.append(match.group(1)) + external_namespace = False + + match = re_end.match(line) + if match: + external_namespace = True + + # Check for any external procedures; if present, flag the file + # as a potential source of + # NOTE: This a very weak test that needs further modification + if external_namespace and not file_has_externals: + match = re_procedure.match(line) + if match: + file_has_externals = True + + used_modules = [m for m in sorted(set(used_modules)) if m not in module_decl] + return add_suff(module_decl, '.mod'), add_suff(used_modules, '.mod'), cpp_includes, f90_includes, programs, file_has_externals + # return add_suff(module_decl, '.mod'), add_suff(sorted(set(used_modules)), '.mod'), cpp_includes, f90_includes, programs + + +def object_file(src_file): + """Return the name of an object file that results from compiling + src_file.""" + return os.path.splitext(os.path.basename(src_file))[0] + '.o' + + +def find_files(src_dirs, skip_dirs): + """Return sorted list of all source files starting from each directory in + the list "src_dirs".""" + + if skip_dirs is not None: + skip = [os.path.normpath(s) for s in skip_dirs] + else: + skip = [] + + # TODO: Make this a user-defined argument + extensions = ('.f90', '.f', '.c', '.inc', '.h', '.fh') + + files = [] + + for path in src_dirs: + if not os.path.isdir(path): + raise ValueError("Directory '{}' was not found".format(path)) + for p, d, f in os.walk(os.path.normpath(path), followlinks=True): + d[:] = [s for s in d if os.path.join(p, s) not in skip] + + for file in f: + if any(file.lower().endswith(ext) for ext in extensions): + files.append(p+'/'+file) + return sorted(set(files)) + + +def add_suff(lst, suff): + """Add "suff" to each item in the list""" + return [f + suff for f in lst] + + +def cpp_expr_eval(expr, macros=None): + if macros is None: + macros = {} + + results, remainder = cpp_scanner.scan(expr.strip()) + + # Abort if any characters are not tokenized + if remainder: + print('There are untokenized characters!') + print('Expression:', repr(expr)) + print('Tokens:', results) + print('Unscanned:', remainder) + raise + + # Add an "end of line" character to force evaluation of the final tokens. + results.append('$') + + stack = [] + prior_op = None + + tokens = iter(results) + for tok in tokens: + if tok in cpp_op_rank.keys(): + while cpp_op_rank[tok] <= cpp_op_rank[prior_op]: + + # Unary operators are "look ahead" so we always skip them. + # (However, `op` below could be a unary operator.) + if tok in ('!', 'defined', '('): + break + + second = stack.pop() + op = stack.pop() + + if op == '(': + value = second + + elif op == '!': + if isinstance(second, str): + if second.isidentifier(): + second = macros.get(second, '0') + if second.isdigit(): + second = int(second) + + value = cpp_operate[op](second) + + elif op == 'defined': + value = cpp_operate[op](second, macros) + + else: + first = stack.pop() + + if isinstance(first, str): + if first.isidentifier(): + first = macros.get(first, '0') + if first.isdigit(): + first = int(first) + + if isinstance(second, str): + if second.isidentifier(): + second = macros.get(second, '0') + if second.isdigit(): + second = int(second) + + value = cpp_operate[op](first, second) + + prior_op = stack[-1] if stack else None + stack.append(value) + + # The ) "operator" has already been applied, so it can be dropped. + if tok != ')': + stack.append(tok) + prior_op = tok + + elif tok.isdigit() or tok.isidentifier(): + stack.append(tok) + + else: + print("Unsupported token:", tok) + raise + + # Remove the tail value + eol = stack.pop() + assert eol == '$' + value = stack.pop() + + return value + + +# Parse arguments +parser = argparse.ArgumentParser( + description="Generate make dependencies for F90 source code." +) +parser.add_argument( + 'path', + nargs='+', + help="Directories to search for source code." +) +parser.add_argument( + '-o', '--makefile', + default='Makefile.dep', + help="Name of Makefile to put dependencies in to. Default is Makefile.dep." +) +parser.add_argument( + '-f', '--fc_rule', + default="$(FC) $(DEFS) $(CPPFLAGS) $(FCFLAGS)", + help="String to use in the compilation rule. Default is: " + "'$(FC) $(DEFS) $(CPPFLAGS) $(FCFLAGS)'" +) +parser.add_argument( + '-x', '--exec_target', + help="Name of executable to build. Fails if more than one program is " + "found. If EXEC ends in .a then a library is built." +) +parser.add_argument( + '-e', '--link_externals', + action='store_true', + help="Always compile and link any files that do not produce modules " + "(externals)." +) +parser.add_argument( + '-d', '--debug', + action='store_true', + help="Annotate the makefile with extra information." +) +parser.add_argument( + '-s', '--skip', + action='append', + help="Skip directory in source code search." +) +parser.add_argument( + '-D', '--define', + action='append', + help="Apply preprocessor define macros (of the form -DMACRO[=value])", +) +args = parser.parse_args() + +# Do the thing +create_deps(args.path, args.skip, args.makefile, args.debug, args.exec_target, + args.fc_rule, args.link_externals, args.define) diff --git a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 index acbbc292de..cf616fce4f 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -1,6 +1,8 @@ -module MOM_surface_forcing_gfdl +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 -! This file is part of MOM6. See LICENSE.md for the license. +module MOM_surface_forcing_gfdl !#CTRL# use MOM_controlled_forcing, only : apply_ctrl_forcing, register_ctrl_forcing_restarts !#CTRL# use MOM_controlled_forcing, only : controlled_forcing_init, controlled_forcing_end @@ -17,6 +19,7 @@ module MOM_surface_forcing_gfdl use MOM_domains, only : pass_vector, pass_var, fill_symmetric_edges use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All use MOM_domains, only : To_North, To_East, Omit_Corners +use MOM_EOS, only : gsw_sr_from_sp use MOM_error_handler, only : MOM_error, WARNING, FATAL, is_root_pe, MOM_mesg use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing, mech_forcing @@ -27,7 +30,9 @@ module MOM_surface_forcing_gfdl use MOM_grid, only : ocean_grid_type use MOM_interpolate, only : init_external_field, time_interp_external use MOM_interpolate, only : time_interp_external_init +use MOM_interpolate, only : external_field use MOM_io, only : slasher, write_version_number, MOM_read_data +use MOM_io, only : read_netCDF_data use MOM_io, only : stdout_if_root use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS use MOM_restart, only : restart_init_end, save_restart, restore_state @@ -60,11 +65,12 @@ module MOM_surface_forcing_gfdl !! from MOM_domains) to indicate the staggering of !! the winds that are being provided in calls to !! update_ocean_model. - logical :: use_temperature !< If true, temp and saln used as state variables + logical :: use_temperature !< If true, temp and saln used as state variables. + logical :: nonBous !< If true, this run is fully non-Boussinesq real :: wind_stress_multiplier !< A multiplier applied to incoming wind stress [nondim]. real :: Rho0 !< Boussinesq reference density [R ~> kg m-3] - real :: area_surf = -1.0 !< Total ocean surface area [m2] + real :: area_surf = -1.0 !< Total ocean surface area [L2 ~> m2] real :: latent_heat_fusion !< Latent heat of fusion [Q ~> J kg-1] real :: latent_heat_vapor !< Latent heat of vaporization [Q ~> J kg-1] @@ -82,17 +88,17 @@ module MOM_surface_forcing_gfdl !! type without any further adjustments to drive the ocean dynamics. !! The actual net mass source may differ due to corrections. - real :: gust_const !< Constant unresolved background gustiness for ustar [R L Z T-1 ~> Pa] + real :: gust_const !< Constant unresolved background gustiness for ustar [R Z2 T-2 ~> Pa] logical :: read_gust_2d !< If true, use a 2-dimensional gustiness supplied from an input file. real, pointer, dimension(:,:) :: & - TKE_tidal => NULL() !< Turbulent kinetic energy introduced to the bottom boundary layer - !! by drag on the tidal flows [R Z3 T-3 ~> W m-2]. + BBL_tidal_dis => NULL() !< Tidal energy dissipation in the bottom boundary layer that can act as a + !! source of energy for bottom boundary layer mixing [R Z L2 T-3 ~> W m-2] real, pointer, dimension(:,:) :: & gust => NULL() !< A spatially varying unresolved background gustiness that - !! contributes to ustar [R L Z T-1 ~> Pa]. gust is used when read_gust_2d is true. + !! contributes to ustar [R Z2 T-2 ~> Pa]. gust is used when read_gust_2d is true. real, pointer, dimension(:,:) :: & ustar_tidal => NULL() !< Tidal contribution to the bottom friction velocity [Z T-1 ~> m s-1] - real :: cd_tides !< Drag coefficient that applies to the tides (nondimensional) + real :: cd_tides !< Drag coefficient that applies to the tides [nondim] real :: utide !< Constant tidal velocity to use if read_tideamp is false [Z T-1 ~> m s-1]. logical :: read_tideamp !< If true, spatially varying tidal amplitude read from a file. @@ -105,16 +111,19 @@ module MOM_surface_forcing_gfdl real :: rigid_sea_ice_mass !< A mass per unit area of sea-ice beyond which sea-ice viscosity !! becomes effective [R Z ~> kg m-2], typically of order 1000 kg m-2. logical :: allow_flux_adjustments !< If true, use data_override to obtain flux adjustments + logical :: allow_carbon_flux_exchange !< If true, allows fluxes and diagnostics of carbon in runoff. logical :: restore_salt !< If true, the coupled MOM driver adds a term to restore surface !! salinity to a specified value. logical :: restore_temp !< If true, the coupled MOM driver adds a term to restore sea !! surface temperature to a specified value. - real :: Flux_const !< Piston velocity for surface restoring [Z T-1 ~> m s-1] - real :: Flux_const_salt !< Piston velocity for surface salt restoring [Z T-1 ~> m s-1] - real :: Flux_const_temp !< Piston velocity for surface temp restoring [Z T-1 ~> m s-1] + real :: Flux_const_salt !< Piston velocity for surface salinity restoring [Z T-1 ~> m s-1] + real :: Flux_const_temp !< Piston velocity for surface temperature restoring [Z T-1 ~> m s-1] + real :: rho_restore !< The density that is used to convert piston velocities into salt + !! or heat fluxes with salinity or temperature restoring [R ~> kg m-3] logical :: trestore_SPEAR_ECDA !< If true, modify restoring data wrt local SSS - real :: SPEAR_dTf_dS !< The derivative of the freezing temperature with salinity. + real :: SPEAR_dTf_dS !< The derivative of the freezing temperature with + !! salinity [C S-1 ~> degC ppt-1]. logical :: salt_restore_as_sflux !< If true, SSS restore as salt flux instead of water flux logical :: adjust_net_srestore_to_zero !< Adjust srestore to zero (for both salt_flux or vprec) logical :: adjust_net_srestore_by_scaling !< Adjust srestore w/o moving zero contour @@ -125,13 +134,14 @@ module MOM_surface_forcing_gfdl !! for salinity restoring. real :: ice_salt_concentration !< Salt concentration for sea ice [kg/kg] logical :: mask_srestore_marginal_seas !< If true, then mask SSS restoring in marginal seas - real :: max_delta_srestore !< Maximum delta salinity used for restoring - real :: max_delta_trestore !< Maximum delta sst used for restoring - real, pointer, dimension(:,:) :: basin_mask => NULL() !< Mask for surface salinity restoring by basin - logical :: answers_2018 !< If true, use the order of arithmetic and expressions that recover - !! the answers from the end of 2018. Otherwise, use a simpler - !! expression to calculate gustiness. - logical :: fix_ustar_gustless_bug !< If true correct a bug in the time-averaging of the + real :: max_delta_srestore !< Maximum delta salinity used for restoring [S ~> ppt] + real :: max_delta_trestore !< Maximum delta sst used for restoring [C ~> degC] + real, pointer, dimension(:,:) :: basin_mask => NULL() !< Mask for surface salinity restoring by basin [nondim] + integer :: answer_date !< The vintage of the order of arithmetic and expressions in the + !! gustiness calculations. Values below 20190101 recover the answers + !! from the end of 2018, while higher values use a simpler expression + !! to calculate gustiness. + logical :: ustar_gustless_bug !< If true, include a bug in the time-averaging of the !! gustless wind friction velocity. logical :: check_no_land_fluxes !< Return warning if IOB flux over land is non-zero @@ -139,20 +149,23 @@ module MOM_surface_forcing_gfdl character(len=200) :: inputdir !< Directory where NetCDF input files are character(len=200) :: salt_restore_file !< Filename for salt restoring data character(len=30) :: salt_restore_var_name !< Name of surface salinity in salt_restore_file + logical :: salt_restore_is_practical !< Specifies that the target salinity is practical and not absolute. logical :: mask_srestore !< If true, apply a 2-dimensional mask to the surface !! salinity restoring fluxes. The masking file should be !! in inputdir/salt_restore_mask.nc and the field should !! be named 'mask' - real, pointer, dimension(:,:) :: srestore_mask => NULL() !< mask for SSS restoring + real, pointer, dimension(:,:) :: srestore_mask => NULL() !< mask for SSS restoring [nondim] character(len=200) :: temp_restore_file !< Filename for sst restoring data character(len=30) :: temp_restore_var_name !< Name of surface temperature in temp_restore_file logical :: mask_trestore !< If true, apply a 2-dimensional mask to the surface !! temperature restoring fluxes. The masking file should be !! in inputdir/temp_restore_mask.nc and the field should !! be named 'mask' - real, pointer, dimension(:,:) :: trestore_mask => NULL() !< Mask for SST restoring - integer :: id_srestore = -1 !< An id number for time_interp_external. - integer :: id_trestore = -1 !< An id number for time_interp_external. + real, pointer, dimension(:,:) :: trestore_mask => NULL() !< Mask for SST restoring [nondim] + type(external_field) :: srestore_handle + !< Handle for time-interpolated salt restoration field + type(external_field) :: trestore_handle + !< Handle for time-interpolated temperature restoration field type(forcing_diags), public :: handles !< Diagnostics handles @@ -170,6 +183,7 @@ module MOM_surface_forcing_gfdl real, pointer, dimension(:,:) :: t_flux =>NULL() !< sensible heat flux [W m-2] real, pointer, dimension(:,:) :: q_flux =>NULL() !< specific humidity flux [kg m-2 s-1] real, pointer, dimension(:,:) :: salt_flux =>NULL() !< salt flux [kg m-2 s-1] + real, pointer, dimension(:,:) :: excess_salt =>NULL() !< salt left behind by brine rejection [kg m-2 s-1] real, pointer, dimension(:,:) :: lw_flux =>NULL() !< long wave radiation [W m-2] real, pointer, dimension(:,:) :: sw_flux_vis_dir =>NULL() !< direct visible sw radiation [W m-2] real, pointer, dimension(:,:) :: sw_flux_vis_dif =>NULL() !< diffuse visible sw radiation [W m-2] @@ -178,6 +192,7 @@ module MOM_surface_forcing_gfdl real, pointer, dimension(:,:) :: lprec =>NULL() !< mass flux of liquid precip [kg m-2 s-1] real, pointer, dimension(:,:) :: fprec =>NULL() !< mass flux of frozen precip [kg m-2 s-1] real, pointer, dimension(:,:) :: runoff =>NULL() !< mass flux of liquid runoff [kg m-2 s-1] + real, pointer, dimension(:,:) :: runoff_carbon =>NULL() !< mass flux of carbon in liquid runoff [kg m-2 s-1] real, pointer, dimension(:,:) :: calving =>NULL() !< mass flux of frozen runoff [kg m-2 s-1] real, pointer, dimension(:,:) :: stress_mag =>NULL() !< The time-mean magnitude of the stress on the ocean [Pa] real, pointer, dimension(:,:) :: ustar_berg =>NULL() !< frictional velocity beneath icebergs [m s-1] @@ -192,6 +207,7 @@ module MOM_surface_forcing_gfdl !! ice-shelves, expressed as a coefficient !! for divergence damping, as determined !! outside of the ocean model [m3 s-1] + real, pointer, dimension(:,:) :: shelf_sfc_mass_flux =>NULL() !< mass flux to surface of ice sheet [kg m-2 s-1] integer :: xtype !< The type of the exchange - REGRID, REDIST or DIRECT type(coupler_2d_bc_type) :: fluxes !< A structure that may contain an array of named fields !! used for passive tracer fluxes. @@ -219,7 +235,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, type(time_type), intent(in) :: Time !< The time of the fluxes, used for interpolating the !! salinity to the right time, when it is being restored. real, intent(in) :: valid_time !< The amount of time over which these fluxes - !! should be applied [s]. + !! should be applied [T ~> s]. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a @@ -228,28 +244,28 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, !! surface state of the ocean. real, dimension(SZI_(G),SZJ_(G)) :: & - data_restore, & ! The surface value toward which to restore [ppt] or [degC] - SST_anom, & ! Instantaneous sea surface temperature anomalies from a target value [degC] - SSS_anom, & ! Instantaneous sea surface salinity anomalies from a target value [ppt] + data_restore, & ! The surface value toward which to restore [S ~> ppt] or [C ~> degC] + SST_anom, & ! Instantaneous sea surface temperature anomalies from a target value [C ~> degC] + SSS_anom, & ! Instantaneous sea surface salinity anomalies from a target value [S ~> ppt] SSS_mean, & ! A (mean?) salinity about which to normalize local salinity - ! anomalies when calculating restorative precipitation anomalies [ppt] - net_FW, & ! The area integrated net freshwater flux into the ocean [kg s-1] - net_FW2, & ! The net freshwater flux into the ocean [kg m-2 s-1] - work_sum, & ! A 2-d array that is used as the work space for global sums [m2] or [kg s-1] + ! anomalies when calculating restorative precipitation anomalies [S ~> ppt] + net_FW, & ! The area integrated net freshwater flux into the ocean [R Z L2 T-1 ~> kg s-1] + net_FW2, & ! The area averaged net freshwater flux into the ocean [R Z T-1 ~> kg m-2 s-1] + work_sum, & ! A 2-d array that is used as the work space for global sums [L2 ~> m2] or [R Z L2 T-1 ~> kg s-1] open_ocn_mask ! a binary field indicating where ice is present based on frazil criteria [nondim] integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isr, ier, jsr, jer integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd - real :: delta_sss ! temporary storage for sss diff from restoring value [ppt] - real :: delta_sst ! temporary storage for sst diff from restoring value [degC] + real :: delta_sss ! temporary storage for sss diff from restoring value [S ~> ppt] + real :: delta_sst ! temporary storage for sst diff from restoring value [C ~> degC] real :: kg_m2_s_conversion ! A combination of unit conversion factors for rescaling ! mass fluxes [R Z s m2 kg-1 T-1 ~> 1] real :: rhoXcp ! Reference density times heat capacity times unit scaling - ! factors [Q R degC-1 ~> J m-3 degC-1] - real :: sign_for_net_FW_bug ! Should be +1. but an old bug can be recovered by using -1. + ! factors [Q R C-1 ~> J m-3 degC-1] + real :: sign_for_net_FW_bug ! Should be +1. but an old bug can be recovered by using -1 [nondim] call cpu_clock_begin(id_clock_forcing) @@ -262,7 +278,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 kg_m2_s_conversion = US%kg_m2s_to_RZ_T - if (CS%restore_temp) rhoXcp = CS%Rho0 * fluxes%C_p + if (CS%restore_temp) rhoXcp = CS%rho_restore * fluxes%C_p open_ocn_mask(:,:) = 1.0 fluxes%vPrecGlobalAdj = 0.0 fluxes%vPrecGlobalScl = 0.0 @@ -274,8 +290,9 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! allocation and initialization if this is the first time that this ! flux type has been used. if (fluxes%dt_buoy_accum < 0) then - call allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.true., press=.true., & - fix_accum_bug=CS%fix_ustar_gustless_bug) + call allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.not.CS%nonBous, press=.true., & + fix_accum_bug=.not.CS%ustar_gustless_bug, tau_mag=CS%nonBous,& + carbon=CS%allow_carbon_flux_exchange) call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) @@ -293,14 +310,16 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call safe_alloc_ptr(fluxes%salt_flux,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%salt_flux_in,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%TKE_tidal,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%BBL_tidal_dis,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%ustar_tidal,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) + if (associated(IOB%excess_salt)) call safe_alloc_ptr(fluxes%salt_left_behind,isd,ied,jsd,jed) + do j=js-2,je+2 ; do i=is-2,ie+2 - fluxes%TKE_tidal(i,j) = CS%TKE_tidal(i,j) + fluxes%BBL_tidal_dis(i,j) = CS%BBL_tidal_dis(i,j) fluxes%ustar_tidal(i,j) = CS%ustar_tidal(i,j) enddo ; enddo @@ -323,15 +342,15 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! allocation and initialization on first call to this routine if (CS%area_surf < 0.0) then do j=js,je ; do i=is,ie - work_sum(i,j) = US%L_to_m**2*G%areaT(i,j) * G%mask2dT(i,j) + work_sum(i,j) = G%areaT(i,j) * G%mask2dT(i,j) enddo ; enddo - CS%area_surf = reproducing_sum(work_sum, isr, ier, jsr, jer) + CS%area_surf = reproducing_sum(work_sum, isr, ier, jsr, jer, unscale=US%L_to_m**2) endif ! endif for allocation and initialization ! Indicate that there are new unused fluxes. fluxes%fluxes_used = .false. - fluxes%dt_buoy_accum = US%s_to_T*valid_time + fluxes%dt_buoy_accum = valid_time fluxes%heat_added(:,:) = 0.0 fluxes%salt_flux_added(:,:) = 0.0 @@ -343,7 +362,15 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! Salinity restoring logic if (CS%restore_salt) then - call time_interp_external(CS%id_srestore, Time, data_restore) + call time_interp_external(CS%srestore_handle, Time, data_restore, scale=US%ppt_to_S) + if (sfc_state%S_is_absS .and. CS%salt_restore_is_practical) then + !Adjust the salt restoring data to absolute + do j=js,je + do i=is,ie + data_restore(i,j) = gsw_sr_from_sp(data_restore(i,j)) + enddo + enddo + endif ! open_ocn_mask indicates where to restore salinity (1 means restore, 0 does not) open_ocn_mask(:,:) = 1.0 if (CS%mask_srestore_under_ice) then ! Do not restore under sea-ice @@ -353,10 +380,10 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, endif if (CS%salt_restore_as_sflux) then do j=js,je ; do i=is,ie - delta_sss = data_restore(i,j)- sfc_state%SSS(i,j) - delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) - fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const_salt)* & - (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) *delta_sss ! R Z T-1 ~> kg Salt m-2 s-1 + delta_sss = data_restore(i,j) - sfc_state%SSS(i,j) + delta_sss = sign(1.0,delta_sss) * min(abs(delta_sss), CS%max_delta_srestore) + fluxes%salt_flux(i,j) = 1.e-3*US%S_to_ppt*G%mask2dT(i,j) * (CS%rho_restore*CS%Flux_const_salt)* & + (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) * delta_sss ! R Z T-1 ~> kg Salt m-2 s-1 enddo ; enddo if (CS%adjust_net_srestore_to_zero) then if (CS%adjust_net_srestore_by_scaling) then @@ -364,21 +391,21 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, unit_scale=US%RZ_T_to_kg_m2s) fluxes%saltFluxGlobalAdj = 0. else - work_sum(is:ie,js:je) = US%L_to_m**2*US%RZ_T_to_kg_m2s * & - G%areaT(is:ie,js:je)*fluxes%salt_flux(is:ie,js:je) * G%mask2dT(is:ie,js:je) - fluxes%saltFluxGlobalAdj = reproducing_sum(work_sum(:,:), isr,ier, jsr,jer)/CS%area_surf + work_sum(is:ie,js:je) = G%areaT(is:ie,js:je)*fluxes%salt_flux(is:ie,js:je) * G%mask2dT(is:ie,js:je) + fluxes%saltFluxGlobalAdj = reproducing_sum(work_sum(:,:), isr,ier, jsr,jer, unscale=US%RZL2_to_kg*US%s_to_T) & + / CS%area_surf fluxes%salt_flux(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) - & - kg_m2_s_conversion * fluxes%saltFluxGlobalAdj * G%mask2dT(is:ie,js:je) + fluxes%saltFluxGlobalAdj * G%mask2dT(is:ie,js:je) endif endif fluxes%salt_flux_added(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) ! Diagnostic else do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) - delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) + delta_sss = sign(1.0,delta_sss) * min(abs(delta_sss), CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & - (CS%Rho0*CS%Flux_const_salt) * & + (CS%rho_restore*CS%Flux_const_salt) * & delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) endif enddo ; enddo @@ -388,11 +415,11 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, unit_scale=US%RZ_T_to_kg_m2s) fluxes%vPrecGlobalAdj = 0. else - work_sum(is:ie,js:je) = US%L_to_m**2*G%areaT(is:ie,js:je) * & - US%RZ_T_to_kg_m2s*fluxes%vprec(is:ie,js:je) - fluxes%vPrecGlobalAdj = reproducing_sum(work_sum(:,:), isr, ier, jsr, jer) / CS%area_surf + work_sum(is:ie,js:je) = G%areaT(is:ie,js:je) * fluxes%vprec(is:ie,js:je) + fluxes%vPrecGlobalAdj = reproducing_sum(work_sum(:,:), isr, ier, jsr, jer, unscale=US%RZL2_to_kg*US%s_to_T) & + / CS%area_surf do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - kg_m2_s_conversion*fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) + fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) enddo ; enddo endif endif @@ -401,18 +428,18 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! SST restoring logic if (CS%restore_temp) then - call time_interp_external(CS%id_trestore, Time, data_restore) + call time_interp_external(CS%trestore_handle, Time, data_restore, scale=US%degC_to_C) if ( CS%trestore_SPEAR_ECDA ) then do j=js,je ; do i=is,ie - if (abs(data_restore(i,j)+1.8)<0.0001) then + if (abs(data_restore(i,j)+1.8*US%degC_to_C) < 0.0001*US%degC_to_C) then data_restore(i,j) = CS%SPEAR_dTf_dS*sfc_state%SSS(i,j) endif enddo ; enddo endif do j=js,je ; do i=is,ie - delta_sst = data_restore(i,j)- sfc_state%SST(i,j) - delta_sst = sign(1.0,delta_sst)*min(abs(delta_sst),CS%max_delta_trestore) + delta_sst = data_restore(i,j) - sfc_state%SST(i,j) + delta_sst = sign(1.0,delta_sst) * min(abs(delta_sst), CS%max_delta_trestore) fluxes%heat_added(i,j) = G%mask2dT(i,j) * CS%trestore_mask(i,j) * & rhoXcp * delta_sst * CS%Flux_const_temp ! [Q R Z T-1 ~> W m-2] enddo ; enddo @@ -453,6 +480,10 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call check_mask_val_consistency(IOB%calving(i-i0,j-j0), G%mask2dT(i,j), i, j, 'calving', G) endif + if (associated(IOB%shelf_sfc_mass_flux)) then + fluxes%shelf_sfc_mass_flux(i,j) = kg_m2_s_conversion * IOB%shelf_sfc_mass_flux(i-i0,j-j0) + endif + if (associated(IOB%ustar_berg)) then fluxes%ustar_berg(i,j) = US%m_to_Z*US%T_to_s * IOB%ustar_berg(i-i0,j-j0) * G%mask2dT(i,j) if (CS%check_no_land_fluxes) & @@ -477,6 +508,12 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call check_mask_val_consistency(IOB%runoff_hflx(i-i0,j-j0), G%mask2dT(i,j), i, j, 'runoff_hflx', G) endif + if (associated(IOB%runoff_carbon) .and. CS%allow_carbon_flux_exchange) then + fluxes%carbon_content_lrunoff(i,j) = US%kg_m2s_to_RZ_T * IOB%runoff_carbon(i-i0,j-j0) * G%mask2dT(i,j) + if (CS%check_no_land_fluxes) & + call check_mask_val_consistency(IOB%runoff_carbon(i-i0,j-j0), G%mask2dT(i,j), i, j, 'runoff_carbon', G) + endif + if (associated(IOB%calving_hflx)) then fluxes%heat_content_frunoff(i,j) = US%W_m2_to_QRZ_T * IOB%calving_hflx(i-i0,j-j0) * G%mask2dT(i,j) if (CS%check_no_land_fluxes) & @@ -532,7 +569,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%sw_flux_nir_dif(i-i0,j-j0), G%mask2dT(i,j), i, j, 'sw_flux_nir_dif', G) endif - if (CS%answers_2018) then + if (CS%answer_date < 20190101) then fluxes%sw(i,j) = fluxes%sw_vis_dir(i,j) + fluxes%sw_vis_dif(i,j) + & fluxes%sw_nir_dir(i,j) + fluxes%sw_nir_dif(i,j) else @@ -546,14 +583,14 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, if (associated(IOB%p)) then if (CS%max_p_surf >= 0.0) then do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%Pa_to_RL2_T2*IOB%p(i-i0,j-j0) fluxes%p_surf(i,j) = MIN(fluxes%p_surf_full(i,j),CS%max_p_surf) if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%p(i-i0,j-j0), G%mask2dT(i,j), i, j, 'p', G) enddo ; enddo else do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%Pa_to_RL2_T2*IOB%p(i-i0,j-j0) fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) if (CS%check_no_land_fluxes) & call check_mask_val_consistency(IOB%p(i-i0,j-j0), G%mask2dT(i,j), i, j, 'p', G) @@ -571,6 +608,11 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call check_mask_val_consistency(IOB%salt_flux(i-i0,j-j0), G%mask2dT(i,j), i, j, 'salt_flux', G) enddo ; enddo endif + if (associated(IOB%excess_salt)) then + do j=js,je ; do i=is,ie + fluxes%salt_left_behind(i,j) = G%mask2dT(i,j)*(kg_m2_s_conversion*IOB%excess_salt(i-i0,j-j0)) + enddo ; enddo + endif !#CTRL# if (associated(CS%ctrl_forcing_CSp)) then !#CTRL# do j=js,je ; do i=is,ie @@ -579,7 +621,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, !#CTRL# SSS_mean(i,j) = 0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j)) !#CTRL# enddo ; enddo !#CTRL# call apply_ctrl_forcing(SST_anom, SSS_anom, SSS_mean, fluxes%heat_added, & -!#CTRL# fluxes%vprec, day, US%s_to_T*valid_time, G, US, CS%ctrl_forcing_CSp) +!#CTRL# fluxes%vprec, day, valid_time, G, US, CS%ctrl_forcing_CSp) !#CTRL# endif ! adjust the NET fresh-water flux to zero, if flagged @@ -587,10 +629,9 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, sign_for_net_FW_bug = 1. if (CS%use_net_FW_adjustment_sign_bug) sign_for_net_FW_bug = -1. do j=js,je ; do i=is,ie - net_FW(i,j) = US%RZ_T_to_kg_m2s* & - (((fluxes%lprec(i,j) + fluxes%fprec(i,j)) + & - (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j))) + & - (fluxes%evap(i,j) + fluxes%vprec(i,j)) ) * US%L_to_m**2*G%areaT(i,j) + net_FW(i,j) = (((fluxes%lprec(i,j) + fluxes%fprec(i,j)) + & + (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j))) + & + (fluxes%evap(i,j) + fluxes%vprec(i,j)) ) * G%areaT(i,j) ! The following contribution appears to be calculating the volume flux of sea-ice ! melt. This calculation is clearly WRONG if either sea-ice has variable ! salinity or the sea-ice is completely fresh. @@ -598,34 +639,42 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! is constant. ! To do this correctly we will need a sea-ice melt field added to IOB. -AJA if (associated(IOB%salt_flux) .and. (CS%ice_salt_concentration>0.0)) & - net_FW(i,j) = net_FW(i,j) + sign_for_net_FW_bug * US%L_to_m**2*G%areaT(i,j) * & - (IOB%salt_flux(i-i0,j-j0) / CS%ice_salt_concentration) - net_FW2(i,j) = net_FW(i,j) / (US%L_to_m**2*G%areaT(i,j)) + net_FW(i,j) = net_FW(i,j) + sign_for_net_FW_bug * G%areaT(i,j) * & + (kg_m2_s_conversion*IOB%salt_flux(i-i0,j-j0) / CS%ice_salt_concentration) + net_FW2(i,j) = net_FW(i,j) / G%areaT(i,j) enddo ; enddo if (CS%adjust_net_fresh_water_by_scaling) then - call adjust_area_mean_to_zero(net_FW2, G, fluxes%netFWGlobalScl) + call adjust_area_mean_to_zero(net_FW2, G, fluxes%netFWGlobalScl, unscale=US%RZ_T_to_kg_m2s) do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = fluxes%vprec(i,j) + kg_m2_s_conversion * & - (net_FW2(i,j) - net_FW(i,j)/(US%L_to_m**2*G%areaT(i,j))) * G%mask2dT(i,j) + fluxes%vprec(i,j) = fluxes%vprec(i,j) + & + (net_FW2(i,j) - net_FW(i,j)/G%areaT(i,j)) * G%mask2dT(i,j) enddo ; enddo else - fluxes%netFWGlobalAdj = reproducing_sum(net_FW(:,:), isr, ier, jsr, jer) / CS%area_surf + fluxes%netFWGlobalAdj = reproducing_sum(net_FW(:,:), isr, ier, jsr, jer, unscale=US%RZL2_to_kg*US%s_to_T) / & + CS%area_surf do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - kg_m2_s_conversion * fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) + fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) enddo ; enddo endif endif ! Set the wind stresses and ustar. - if (associated(fluxes%ustar) .and. associated(fluxes%ustar_gustless)) then + if (associated(fluxes%ustar) .and. associated(fluxes%ustar_gustless) .and. associated(fluxes%tau_mag) & + .and. associated(fluxes%tau_mag_gustless) ) then call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, ustar=fluxes%ustar, & - gustless_ustar=fluxes%ustar_gustless) - elseif (associated(fluxes%ustar)) then - call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, ustar=fluxes%ustar) - elseif (associated(fluxes%ustar_gustless)) then - call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, gustless_ustar=fluxes%ustar_gustless) + mag_tau=fluxes%tau_mag, gustless_ustar=fluxes%ustar_gustless, & + gustless_mag_tau=fluxes%tau_mag_gustless) + else + if (associated(fluxes%ustar)) & + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, ustar=fluxes%ustar) + if (associated(fluxes%ustar_gustless)) & + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, gustless_ustar=fluxes%ustar_gustless) + if (associated(fluxes%tau_mag)) & + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, mag_tau=fluxes%tau_mag) + if (associated(fluxes%tau_mag_gustless)) & + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, gustless_mag_tau=fluxes%tau_mag_gustless) endif if (coupler_type_initialized(fluxes%tr_fluxes) .and. & @@ -661,7 +710,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ !! previous call to surface_forcing_init. real, optional, intent(in) :: dt_forcing !< A time interval over which to apply the !! current value of ustar as a weighted running - !! average [s], or if 0 do not average ustar. + !! average [T ~> s], or if 0 do not average ustar. !! Missing is equivalent to 0. logical, optional, intent(in) :: reset_avg !< If true, reset the time average. @@ -669,7 +718,8 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ real, dimension(SZI_(G),SZJ_(G)) :: & rigidity_at_h, & ! Ice rigidity at tracer points [L4 Z-1 T-1 ~> m3 s-1] net_mass_src, & ! A temporary of net mass sources [R Z T-1 ~> kg m-2 s-1]. - ustar_tmp ! A temporary array of ustar values [Z T-1 ~> m s-1]. + ustar_tmp, & ! A temporary array of ustar values [Z T-1 ~> m s-1]. + tau_mag_tmp ! A temporary array of surface stress magnitudes [R Z2 T-2 ~> Pa] real :: I_GEarth ! The inverse of the gravitational acceleration [T2 Z L-2 ~> s2 m-1] real :: Kv_rho_ice ! (CS%Kv_sea_ice / CS%density_sea_ice) [L4 Z-2 T-1 R-1 ~> m5 s-1 kg-1] @@ -699,8 +749,8 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ ! allocation and initialization if this is the first time that this ! mechanical forcing type has been used. if (.not.forces%initialized) then - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., & - press=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.not.CS%nonBous, & + press=.true., tau_mag=CS%nonBous) call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) @@ -753,12 +803,12 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ if (associated(IOB%p)) then if (CS%max_p_surf >= 0.0) then do j=js,je ; do i=is,ie - forces%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + forces%p_surf_full(i,j) = G%mask2dT(i,j) * US%Pa_to_RL2_T2*IOB%p(i-i0,j-j0) forces%p_surf(i,j) = MIN(forces%p_surf_full(i,j),CS%max_p_surf) enddo ; enddo else do j=js,je ; do i=is,ie - forces%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + forces%p_surf_full(i,j) = G%mask2dT(i,j) * US%Pa_to_RL2_T2*IOB%p(i-i0,j-j0) forces%p_surf(i,j) = forces%p_surf_full(i,j) enddo ; enddo endif @@ -773,13 +823,26 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ ! Set the wind stresses and ustar. if (wt1 <= 0.0) then call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux=forces%taux, tauy=forces%tauy, & - ustar=forces%ustar, tau_halo=1) + tau_halo=1) + if (associated(forces%ustar)) & + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, ustar=forces%ustar) + if (associated(forces%tau_mag)) & + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, mag_tau=forces%tau_mag) else call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux=forces%taux, tauy=forces%tauy, & - ustar=ustar_tmp, tau_halo=1) - do j=js,je ; do i=is,ie - forces%ustar(i,j) = wt1*forces%ustar(i,j) + wt2*ustar_tmp(i,j) - enddo ; enddo + tau_halo=1) + if (associated(forces%ustar)) then + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, ustar=ustar_tmp) + do j=js,je ; do i=is,ie + forces%ustar(i,j) = wt1*forces%ustar(i,j) + wt2*ustar_tmp(i,j) + enddo ; enddo + endif + if (associated(forces%tau_mag)) then + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, mag_tau=tau_mag_tmp) + do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = wt1*forces%tau_mag(i,j) + wt2*tau_mag_tmp(i,j) + enddo ; enddo + endif endif ! Find the net mass source in the input forcing without other adjustments. @@ -875,7 +938,7 @@ end subroutine convert_IOB_to_forces !! Ice_ocean_boundary_type into optional argument arrays, including changes of units, sign !! conventions, and putting the fields into arrays with MOM-standard sized halos. subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, ustar, & - gustless_ustar, tau_halo) + gustless_ustar, mag_tau, gustless_mag_tau, tau_halo) type(ice_ocean_boundary_type), & target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive !! the ocean in a coupled model @@ -895,6 +958,12 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, real, dimension(SZI_(G),SZJ_(G)), & optional, intent(out) :: gustless_ustar !< The surface friction velocity without !! any contributions from gustiness [Z T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(inout) :: mag_tau !< The magintude of the wind stress at tracer points + !! including subgridscale variability and gustiness [R Z2 T-2 ~> Pa] + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(out) :: gustless_mag_tau !< The magintude of the wind stress at tracer points + !! without any contributions from gustiness [R Z2 T-2 ~> Pa] integer, optional, intent(in) :: tau_halo !< The halo size of wind stresses to set, 0 by default. ! Local variables @@ -905,14 +974,14 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, real, dimension(SZIB_(G),SZJB_(G)) :: taux_in_B ! Zonal wind stresses [R Z L T-2 ~> Pa] at q points real, dimension(SZIB_(G),SZJB_(G)) :: tauy_in_B ! Meridional wind stresses [R Z L T-2 ~> Pa] at q points - real :: gustiness ! unresolved gustiness that contributes to ustar [R Z L T-2 ~> Pa] - real :: Irho0 ! Inverse of the mean density rescaled to [Z L-1 R-1 ~> m3 kg-1] + real :: gustiness ! unresolved gustiness that contributes to ustar [R Z2 T-2 ~> Pa] + real :: Irho0 ! Inverse of the Boussinesq mean density [R-1 ~> m3 kg-1] real :: taux2, tauy2 ! squared wind stresses [R2 Z2 L2 T-4 ~> Pa2] - real :: tau_mag ! magnitude of the wind stress [R Z L T-2 ~> Pa] - real :: Pa_conversion ! A unit conversion factor from Pa to the internal wind stress units [R Z L T-2 Pa-1 ~> 1] + real :: tau_mag ! magnitude of the wind stress [R Z2 T-2 ~> Pa] real :: stress_conversion ! A unit conversion factor from Pa times any stress multiplier [R Z L T-2 Pa-1 ~> 1] + real :: Pa_to_RZ2_T2 ! The combination of unit conversion factors used for mag_tau [R Z2 T-2 Pa-1 ~> 1] - logical :: do_ustar, do_gustless + logical :: do_ustar, do_gustless, do_tau_mag, do_gustless_tau_mag integer :: wind_stagger ! AGRID, BGRID_NE, or CGRID_NE (integers from MOM_domains) integer :: i, j, is, ie, js, je, ish, ieh, jsh, jeh, Isqh, Ieqh, Jsqh, Jeqh, i0, j0, halo @@ -922,11 +991,11 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, Isqh = G%IscB-halo ; Ieqh = G%IecB+halo ; Jsqh = G%JscB-halo ; Jeqh = G%JecB+halo i0 = is - index_bounds(1) ; j0 = js - index_bounds(3) - IRho0 = US%L_to_Z / CS%Rho0 - Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z - stress_conversion = Pa_conversion * CS%wind_stress_multiplier + IRho0 = 1.0 / CS%Rho0 + stress_conversion = US%Pa_to_RLZ_T2 * CS%wind_stress_multiplier do_ustar = present(ustar) ; do_gustless = present(gustless_ustar) + do_tau_mag = present(mag_tau) ; do_gustless_tau_mag = present(gustless_mag_tau) wind_stagger = CS%wind_stagger if ((IOB%wind_stagger == AGRID) .or. (IOB%wind_stagger == BGRID_NE) .or. & @@ -939,7 +1008,8 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, ! Set surface momentum stress related fields as a function of staggering. if (present(taux) .or. present(tauy) .or. & - ((do_ustar.or.do_gustless) .and. .not.associated(IOB%stress_mag)) ) then + ((do_ustar .or. do_tau_mag .or. do_gustless .or. do_gustless_tau_mag) & + .and. .not.associated(IOB%stress_mag)) ) then if (wind_stagger == BGRID_NE) then taux_in_B(:,:) = 0.0 ; tauy_in_B(:,:) = 0.0 @@ -956,13 +1026,13 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, if (present(taux).and.present(tauy)) then do j=jsh,jeh ; do I=Isqh,Ieqh taux(I,j) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0.0) & taux(I,j) = (G%mask2dBu(I,J)*taux_in_B(I,J) + G%mask2dBu(I,J-1)*taux_in_B(I,J-1)) / & (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) enddo ; enddo do J=Jsqh,Jeqh ; do i=ish,ieh tauy(i,J) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0.0) & tauy(i,J) = (G%mask2dBu(I,J)*tauy_in_B(I,J) + G%mask2dBu(I-1,J)*tauy_in_B(I-1,J)) / & (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) enddo ; enddo @@ -984,14 +1054,14 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, if (present(taux)) then ; do j=jsh,jeh ; do I=Isqh,Ieqh taux(I,j) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0.0) & taux(I,j) = (G%mask2dT(i,j)*taux_in_A(i,j) + G%mask2dT(i+1,j)*taux_in_A(i+1,j)) / & (G%mask2dT(i,j) + G%mask2dT(i+1,j)) enddo ; enddo ; endif if (present(tauy)) then ; do J=Jsqh,Jeqh ; do i=ish,ieh tauy(i,J) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0.0) & tauy(i,J) = (G%mask2dT(i,j)*tauy_in_A(i,j) + G%mask2dT(i,J+1)*tauy_in_A(i,j+1)) / & (G%mask2dT(i,j) + G%mask2dT(i,j+1)) enddo ; enddo ; endif @@ -1019,60 +1089,71 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, endif ! endif for extracting wind stress fields with various staggerings endif - if (do_ustar .or. do_gustless) then + if (do_ustar .or. do_tau_mag .or. do_gustless .or. do_gustless_tau_mag) then ! Set surface friction velocity directly or as a function of staggering. ! ustar is required for the bulk mixed layer formulation and other turbulent mixing ! parametizations. The background gustiness (for example with a relatively small value ! of 0.02 Pa) is intended to give reasonable behavior in regions of very weak winds. if (associated(IOB%stress_mag)) then - if (do_ustar) then ; do j=js,je ; do i=is,ie + Pa_to_RZ2_T2 = US%Pa_to_RLZ_T2 * US%L_to_Z + + if (do_ustar .or. do_tau_mag) then ; do j=js,je ; do i=is,ie gustiness = CS%gust_const if (CS%read_gust_2d) then if ((wind_stagger == CGRID_NE) .or. & - ((wind_stagger == AGRID) .and. (G%mask2dT(i,j) > 0)) .or. & + ((wind_stagger == AGRID) .and. (G%mask2dT(i,j) > 0.0)) .or. & ((wind_stagger == BGRID_NE) .and. & (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & - (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0)) ) & + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0.0)) ) & gustiness = CS%gust(i,j) endif - ustar(i,j) = sqrt(gustiness*IRho0 + IRho0*Pa_conversion*IOB%stress_mag(i-i0,j-j0)) + if (do_tau_mag) & + mag_tau(i,j) = gustiness + Pa_to_RZ2_T2*IOB%stress_mag(i-i0,j-j0) + if (do_gustless_tau_mag) & + gustless_mag_tau(i,j) = Pa_to_RZ2_T2*IOB%stress_mag(i-i0,j-j0) + if (do_ustar) & + ustar(i,j) = sqrt(gustiness*IRho0 + IRho0*Pa_to_RZ2_T2*IOB%stress_mag(i-i0,j-j0)) enddo ; enddo ; endif - if (CS%answers_2018) then + if (CS%answer_date < 20190101) then if (do_gustless) then ; do j=js,je ; do i=is,ie - gustless_ustar(i,j) = sqrt(Pa_conversion*US%L_to_Z*IOB%stress_mag(i-i0,j-j0) / CS%Rho0) + gustless_ustar(i,j) = sqrt(Pa_to_RZ2_T2*IOB%stress_mag(i-i0,j-j0) / CS%Rho0) enddo ; enddo ; endif else if (do_gustless) then ; do j=js,je ; do i=is,ie - gustless_ustar(i,j) = sqrt(IRho0 * Pa_conversion*IOB%stress_mag(i-i0,j-j0)) + gustless_ustar(i,j) = sqrt(IRho0 * Pa_to_RZ2_T2*IOB%stress_mag(i-i0,j-j0)) enddo ; enddo ; endif endif elseif (wind_stagger == BGRID_NE) then do j=js,je ; do i=is,ie tau_mag = 0.0 ; gustiness = CS%gust_const if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & - (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0) then - tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_in_B(I,J)**2 + tauy_in_B(I,J)**2) + & - G%mask2dBu(I-1,J-1)*(taux_in_B(I-1,J-1)**2 + tauy_in_B(I-1,J-1)**2)) + & - (G%mask2dBu(I,J-1)*(taux_in_B(I,J-1)**2 + tauy_in_B(I,J-1)**2) + & - G%mask2dBu(I-1,J)*(taux_in_B(I-1,J)**2 + tauy_in_B(I-1,J)**2)) ) / & + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0.0) then + tau_mag = US%L_to_Z * sqrt(((G%mask2dBu(I,J)*((taux_in_B(I,J)**2) + (tauy_in_B(I,J)**2)) + & + G%mask2dBu(I-1,J-1)*((taux_in_B(I-1,J-1)**2) + (tauy_in_B(I-1,J-1)**2))) + & + (G%mask2dBu(I,J-1)*((taux_in_B(I,J-1)**2) + (tauy_in_B(I,J-1)**2)) + & + G%mask2dBu(I-1,J)*((taux_in_B(I-1,J)**2) + (tauy_in_B(I-1,J)**2))) ) / & ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) ) if (CS%read_gust_2d) gustiness = CS%gust(i,j) endif if (do_ustar) ustar(i,j) = sqrt(gustiness*IRho0 + IRho0 * tau_mag) - if (CS%answers_2018) then - if (do_gustless) gustless_ustar(i,j) = sqrt(US%L_to_Z*tau_mag / CS%Rho0) + if (do_tau_mag) mag_tau(i,j) = gustiness + tau_mag + if (do_gustless_tau_mag) gustless_mag_tau(i,j) = tau_mag + if (CS%answer_date < 20190101) then + if (do_gustless) gustless_ustar(i,j) = sqrt(tau_mag / CS%Rho0) else if (do_gustless) gustless_ustar(i,j) = sqrt(IRho0 * tau_mag) endif enddo ; enddo elseif (wind_stagger == AGRID) then do j=js,je ; do i=is,ie - tau_mag = G%mask2dT(i,j) * sqrt(taux_in_A(i,j)**2 + tauy_in_A(i,j)**2) + tau_mag = G%mask2dT(i,j) * US%L_to_Z * sqrt((taux_in_A(i,j)**2) + (tauy_in_A(i,j)**2)) gustiness = CS%gust_const - if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) + if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0.0)) gustiness = CS%gust(i,j) if (do_ustar) ustar(i,j) = sqrt(gustiness*IRho0 + IRho0 * tau_mag) - if (CS%answers_2018) then - if (do_gustless) gustless_ustar(i,j) = sqrt(US%L_to_Z*tau_mag / CS%Rho0) + if (do_tau_mag) mag_tau(i,j) = gustiness + tau_mag + if (do_gustless_tau_mag) gustless_mag_tau(i,j) = tau_mag + if (CS%answer_date < 20190101) then + if (do_gustless) gustless_ustar(i,j) = sqrt(tau_mag / CS%Rho0) else if (do_gustless) gustless_ustar(i,j) = sqrt(IRho0 * tau_mag) endif @@ -1080,20 +1161,22 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, else ! C-grid wind stresses. do j=js,je ; do i=is,ie taux2 = 0.0 ; tauy2 = 0.0 - if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0) & - taux2 = (G%mask2dCu(I-1,j)*taux_in_C(I-1,j)**2 + G%mask2dCu(I,j)*taux_in_C(I,j)**2) / & + if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0.0) & + taux2 = (G%mask2dCu(I-1,j)*(taux_in_C(I-1,j)**2) + G%mask2dCu(I,j)*(taux_in_C(I,j)**2)) / & (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) - if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & - tauy2 = (G%mask2dCv(i,J-1)*tauy_in_C(i,J-1)**2 + G%mask2dCv(i,J)*tauy_in_C(i,J)**2) / & + if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0.0) & + tauy2 = (G%mask2dCv(i,J-1)*(tauy_in_C(i,J-1)**2) + G%mask2dCv(i,J)*(tauy_in_C(i,J)**2)) / & (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) - tau_mag = sqrt(taux2 + tauy2) + tau_mag = US%L_to_Z * sqrt(taux2 + tauy2) gustiness = CS%gust_const if (CS%read_gust_2d) gustiness = CS%gust(i,j) if (do_ustar) ustar(i,j) = sqrt(gustiness*IRho0 + IRho0 * tau_mag) - if (CS%answers_2018) then - if (do_gustless) gustless_ustar(i,j) = sqrt(US%L_to_Z*tau_mag / CS%Rho0) + if (do_tau_mag) mag_tau(i,j) = gustiness + tau_mag + if (do_gustless_tau_mag) gustless_mag_tau(i,j) = tau_mag + if (CS%answer_date < 20190101) then + if (do_gustless) gustless_ustar(i,j) = sqrt(tau_mag / CS%Rho0) else if (do_gustless) gustless_ustar(i,j) = sqrt(IRho0 * tau_mag) endif @@ -1124,7 +1207,7 @@ subroutine apply_flux_adjustments(G, US, CS, Time, fluxes) integer :: isc, iec, jsc, jec, i, j logical :: overrode_h - isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec call data_override(G%Domain, 'hflx_adj', temp_at_h, Time, override=overrode_h, & scale=US%W_m2_to_QRZ_T) @@ -1168,18 +1251,21 @@ subroutine apply_force_adjustments(G, US, CS, Time, forces) real, dimension(SZI_(G),SZJ_(G)) :: tempy_at_h ! Delta to meridional wind stress at h points [R Z L T-2 ~> Pa] integer :: isc, iec, jsc, jec, i, j - real :: dLonDx, dLonDy, rDlon, cosA, sinA, zonal_tau, merid_tau - real :: Pa_conversion ! A unit conversion factor from Pa to the internal units [R Z L T-2 Pa-1 ~> 1] + real :: dLonDx, dLonDy ! The change in longitude across the cell in the x- and y-directions [degrees_E] + real :: rDlon ! The magnitude of the change in longitude [degrees_E] and then its inverse [degrees_E-1] + real :: cosA, sinA ! The cosine and sine of the angle between the grid and true north [nondim] + real :: zonal_tau, merid_tau ! True zonal and meridional wind stresses [R Z L T-2 ~> Pa] logical :: overrode_x, overrode_y - isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec - Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec tempx_at_h(:,:) = 0.0 ; tempy_at_h(:,:) = 0.0 ! Either reads data or leaves contents unchanged overrode_x = .false. ; overrode_y = .false. - call data_override(G%Domain, 'taux_adj', tempx_at_h(isc:iec,jsc:jec), Time, override=overrode_x, scale=Pa_conversion) - call data_override(G%Domain, 'tauy_adj', tempy_at_h(isc:iec,jsc:jec), Time, override=overrode_y, scale=Pa_conversion) + call data_override(G%Domain, 'taux_adj', tempx_at_h(isc:iec,jsc:jec), Time, & + override=overrode_x, scale=US%Pa_to_RLZ_T2) + call data_override(G%Domain, 'tauy_adj', tempy_at_h(isc:iec,jsc:jec), Time, & + override=overrode_y, scale=US%Pa_to_RLZ_T2) if (overrode_x .or. overrode_y) then if (.not. (overrode_x .and. overrode_y)) call MOM_error(FATAL,"apply_flux_adjustments: "//& @@ -1242,15 +1328,29 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) !! diagnostic output type(surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module - integer, optional, intent(in) :: wind_stagger !< If present, the staggering of the winds that are - !! being provided in calls to update_ocean_model + integer, optional, intent(in) :: wind_stagger !< If present, the staggering of the winds + !! that are being provided in calls to update_ocean_model ! Local variables - real :: utide ! The RMS tidal velocity [Z T-1 ~> m s-1]. - type(directories) :: dirs - logical :: new_sim, iceberg_flux_diags - logical :: default_2018_answers + real :: utide ! The RMS tidal velocity [Z T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G)) :: & + utide_2d ! A 2d array of RMS tidal velocities [Z T-1 ~> m s-1]. + real :: Flux_const_dflt ! A default piston velocity for restoring surface properties [m day-1] + logical :: Boussinesq ! If true, this run is fully Boussinesq + logical :: semi_Boussinesq ! If true, this run is partially non-Boussinesq + real :: rho_TKE_tidal ! The constant bottom density used to translate tidal amplitudes into + ! the tidal bottom TKE input used with INT_TIDE_DISSIPATION, times the + ! factor rescaling from the units of TKE to those of mean kinetic + ! energy [R L2 Z-2 ~> kg m-3] + logical :: new_sim ! False if this simulation was started from a restart file + ! or other equivalent files. + logical :: iceberg_flux_diags ! If true, diagnostics of fluxes from icebergs are available. + logical :: fix_ustar_gustless_bug ! If false, include a bug using an older run-time parameter. + logical :: test_value ! This is used to determine whether a logical parameter is being set explicitly. + logical :: explicit_bug, explicit_fix ! These indicate which parameters are set explicitly. + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. type(time_type) :: Time_frc + type(directories) :: dirs ! A structure containing relevant directory paths and input filenames. character(len=200) :: TideAmp_file, gust_file, salt_file, temp_file ! Input file names. ! This include declares and sets the variable "version". # include "version_variable.h" @@ -1259,7 +1359,6 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) character(len=48) :: flnam character(len=240) :: basin_file integer :: i, j, isd, ied, jsd, jed - real :: unscaled_fluxconst isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -1286,12 +1385,20 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) + call get_param(param_file, mdl, "BOUSSINESQ", Boussinesq, & + "If true, make the Boussinesq approximation.", default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "SEMI_BOUSSINESQ", semi_Boussinesq, & + "If true, do non-Boussinesq pressure force calculations and use mass-based "//& + "thicknesses, but use RHO_0 to convert layer thicknesses into certain "//& + "height changes. This only applies if BOUSSINESQ is false.", & + default=.true., do_not_log=.true.) + CS%nonBous = .not.(Boussinesq .or. semi_Boussinesq) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& + "properties, or with BOUSSINESQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) ! (, do_not_log=CS%nonBous) call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & "The latent heat of fusion.", units="J/kg", default=hlf, scale=US%J_kg_to_Q) call get_param(param_file, mdl, "LATENT_HEAT_VAPORIZATION", CS%latent_heat_vapor, & @@ -1303,7 +1410,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) "limit the water that can be frozen out of the ocean and "//& "the ice-ocean heat fluxes are treated explicitly. No "//& "limit is applied if a negative value is used.", & - units="Pa", default=-1.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) + units="Pa", default=-1.0, scale=US%Pa_to_RL2_T2) call get_param(param_file, mdl, "RESTORE_SALINITY", CS%restore_salt, & "If true, the coupled driver will add a globally-balanced "//& "fresh-water flux that drives sea-surface salinity "//& @@ -1353,11 +1460,11 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) "due to internal corrections.", default=.false.) if (present(wind_stagger)) then - if (wind_stagger == AGRID) then ; stagger = 'AGRID' + if (wind_stagger == AGRID) then ; stagger = 'AGRID' elseif (wind_stagger == BGRID_NE) then ; stagger = 'BGRID_NE' elseif (wind_stagger == CGRID_NE) then ; stagger = 'CGRID_NE' else ; stagger = 'UNKNOWN' ; call MOM_error(FATAL,"surface_forcing_init: WIND_STAGGER = "// & - trim(stagger)// "is invalid."); endif + trim(stagger)// "is invalid.") ; endif call log_param(param_file, mdl, "WIND_STAGGER", stagger, & "The staggering of the input wind stress field "//& "from the coupler that is actually used.") @@ -1367,7 +1474,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) "A case-insensitive character string to indicate the "//& "staggering of the input wind stress field. Valid "//& "values are 'A', 'B', or 'C'.", default="C") - if (uppercase(stagger(1:1)) == 'A') then ; CS%wind_stagger = AGRID + if (uppercase(stagger(1:1)) == 'A') then ; CS%wind_stagger = AGRID elseif (uppercase(stagger(1:1)) == 'B') then ; CS%wind_stagger = BGRID_NE elseif (uppercase(stagger(1:1)) == 'C') then ; CS%wind_stagger = CGRID_NE else ; call MOM_error(FATAL,"surface_forcing_init: WIND_STAGGER = "// & @@ -1380,16 +1487,16 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) "production runs.", units="nondim", default=1.0) if (CS%restore_salt) then - call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & + call get_param(param_file, mdl, "FLUXCONST", Flux_const_dflt, & "The constant that relates the restoring surface fluxes to the relative "//& "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & - default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s, unscaled=unscaled_fluxconst) + units="m day-1", default=0.0) call get_param(param_file, mdl, "FLUXCONST_SALT", CS%Flux_const_salt, & "The constant that relates the restoring surface salt fluxes to the relative "//& "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & - fail_if_missing=.false.,default=unscaled_fluxconst, units="m day-1", scale=US%m_to_Z*US%T_to_s) - ! Finish converting CS%Flux_const from m day-1 to [Z T-1 ~> m s-1]. - CS%Flux_const = CS%Flux_const / 86400.0 + units="m day-1", default=Flux_const_dflt, scale=US%m_to_Z*US%T_to_s) + ! Finish converting CS%Flux_const_salt from m day-1 to [Z T-1 ~> m s-1]. Ideally this would be + ! included in the scale factors above, but doing so would change answers because a/b /= a*(1/b). CS%Flux_const_salt = CS%Flux_const_salt / 86400.0 call get_param(param_file, mdl, "SALT_RESTORE_FILE", CS%salt_restore_file, & "A file in which to find the surface salinity to use for restoring.", & @@ -1398,15 +1505,16 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) "The name of the surface salinity variable to read from "//& "SALT_RESTORE_FILE for restoring salinity.", & default="salt") - + call get_param(param_file, mdl, "SALT_RESTORE_PRACTICAL_SALINITY", CS%salt_restore_is_practical, & + "Specifies if the restoring surface salinity variable is practical salinity. If this "//& + "flag is set to false it is assumed that the salinity is absolute salinity.", default=.false.) call get_param(param_file, mdl, "SRESTORE_AS_SFLUX", CS%salt_restore_as_sflux, & "If true, the restoring of salinity is applied as a salt "//& "flux instead of as a freshwater flux.", default=.false.) call get_param(param_file, mdl, "MAX_DELTA_SRESTORE", CS%max_delta_srestore, & "The maximum salinity difference used in restoring terms.", & - units="PSU or g kg-1", default=999.0) - call get_param(param_file, mdl, "MASK_SRESTORE_UNDER_ICE", & - CS%mask_srestore_under_ice, & + units="PSU or g kg-1", default=999.0, scale=US%ppt_to_S) + call get_param(param_file, mdl, "MASK_SRESTORE_UNDER_ICE", CS%mask_srestore_under_ice, & "If true, disables SSS restoring under sea-ice based on a frazil "//& "criteria (SST<=Tf). Only used when RESTORE_SALINITY is True.", & default=.false.) @@ -1432,16 +1540,16 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) endif if (CS%restore_temp) then - call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & + call get_param(param_file, mdl, "FLUXCONST", Flux_const_dflt, & "The constant that relates the restoring surface fluxes to the relative "//& "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & - default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s,unscaled=unscaled_fluxconst) + units="m day-1", default=0.0) call get_param(param_file, mdl, "FLUXCONST_TEMP", CS%Flux_const_temp, & "The constant that relates the restoring surface temperature fluxes to the relative "//& "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & - fail_if_missing=.false.,default=unscaled_fluxconst, units="m day-1", scale=US%m_to_Z*US%T_to_s) - ! Convert CS%Flux_const from m day-1 to m s-1. - CS%Flux_const = CS%Flux_const / 86400.0 + units="m day-1", default=Flux_const_dflt, scale=US%m_to_Z*US%T_to_s) + ! Finish converting CS%Flux_const_temp from [m day-1] to [Z T-1 ~> m s-1]. Ideally this would be + ! included in the scale factors above, but doing so would change answers because a/b /= a*(1/b). CS%Flux_const_temp = CS%Flux_const_temp / 86400.0 call get_param(param_file, mdl, "SST_RESTORE_FILE", CS%temp_restore_file, & "A file in which to find the surface temperature to use for restoring.", & @@ -1453,7 +1561,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) call get_param(param_file, mdl, "MAX_DELTA_TRESTORE", CS%max_delta_trestore, & "The maximum sst difference used in restoring terms.", & - units="degC ", default=999.0) + units="degC ", default=999.0, scale=US%degC_to_C) call get_param(param_file, mdl, "MASK_TRESTORE", CS%mask_trestore, & "If true, read a file (temp_restore_mask) containing "//& "a mask for SST restoring.", default=.false.) @@ -1466,7 +1574,13 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) endif call get_param(param_file, mdl, "SPEAR_DTFREEZE_DS", CS%SPEAR_dTf_dS, & "The derivative of the freezing temperature with salinity.", & - units="deg C PSU-1", default=-0.054, do_not_log=.not.CS%trestore_SPEAR_ECDA) + units="degC ppt-1", default=-0.054, scale=US%degC_to_C*US%S_to_ppt, & + do_not_log=.not.CS%trestore_SPEAR_ECDA) + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", CS%rho_restore, & + "The density that is used to convert piston velocities into salt or heat "//& + "fluxes with RESTORE_SALINITY or RESTORE_TEMPERATURE.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=.not.(CS%restore_temp.or.CS%restore_salt)) ! Optionally read tidal amplitude from input file [Z T-1 ~> m s-1] on model grid. ! Otherwise use default tidal amplitude for bottom frictionally-generated @@ -1491,22 +1605,31 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & units="m s-1", default=0.0, scale=US%m_to_Z*US%T_to_s) endif + call get_param(param_file, mdl, "TKE_TIDAL_RHO", rho_TKE_tidal, & + "The constant bottom density used to translate tidal amplitudes into the tidal "//& + "bottom TKE input used with INT_TIDE_DISSIPATION.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R*US%Z_to_L**2, & + do_not_log=.not.(CS%read_TIDEAMP.or.(CS%utide>0.0))) - call safe_alloc_ptr(CS%TKE_tidal,isd,ied,jsd,jed) + call safe_alloc_ptr(CS%BBL_tidal_dis,isd,ied,jsd,jed) call safe_alloc_ptr(CS%ustar_tidal,isd,ied,jsd,jed) if (CS%read_TIDEAMP) then TideAmp_file = trim(CS%inputdir) // trim(TideAmp_file) - call MOM_read_data(TideAmp_file,'tideamp',CS%TKE_tidal,G%domain,timelevel=1, scale=US%m_to_Z*US%T_to_s) - do j=jsd, jed; do i=isd, ied - utide = CS%TKE_tidal(i,j) - CS%TKE_tidal(i,j) = G%mask2dT(i,j)*CS%Rho0*CS%cd_tides*(utide*utide*utide) + ! NOTE: There are certain cases where FMS is unable to read this file, so + ! we use read_netCDF_data in place of MOM_read_data. + utide_2d(:,:) = 0.0 + call read_netCDF_data(TideAmp_file, 'tideamp', utide_2d, G%Domain, & + rescale=US%m_to_Z*US%T_to_s) + do j=jsd,jed ; do i=isd,ied + utide = utide_2d(i,j) + CS%BBL_tidal_dis(i,j) = G%mask2dT(i,j)*rho_TKE_tidal*CS%cd_tides*(utide*utide*utide) CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide enddo ; enddo else - do j=jsd,jed; do i=isd,ied + do j=jsd,jed ; do i=isd,ied utide = CS%utide - CS%TKE_tidal(i,j) = CS%Rho0*CS%cd_tides*(utide*utide*utide) + CS%BBL_tidal_dis(i,j) = rho_TKE_tidal*CS%cd_tides*(utide*utide*utide) CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide enddo ; enddo endif @@ -1518,28 +1641,55 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) "If true, use a 2-dimensional gustiness supplied from "//& "an input file", default=.false.) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", & - units="Pa", default=0.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) + "The background gustiness in the winds.", & + units="Pa", default=0.0, scale=US%Pa_to_RLZ_T2*US%L_to_Z) if (CS%read_gust_2d) then call get_param(param_file, mdl, "GUST_2D_FILE", gust_file, & "The file in which the wind gustiness is found in "//& - "variable gustiness.") + "variable gustiness.", fail_if_missing=.true.) call safe_alloc_ptr(CS%gust,isd,ied,jsd,jed) gust_file = trim(CS%inputdir) // trim(gust_file) - call MOM_read_data(gust_file, 'gustiness', CS%gust, G%domain, timelevel=1, & - scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) ! units in file should be Pa + ! NOTE: There are certain cases where FMS is unable to read this file, so + ! we use read_netCDF_data in place of MOM_read_data. + call read_netCDF_data(gust_file, 'gustiness', CS%gust, G%Domain, & + rescale=US%Pa_to_RLZ_T2*US%L_to_Z) ! units in file should be [Pa] endif - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) - call get_param(param_file, mdl, "SURFACE_FORCING_2018_ANSWERS", CS%answers_2018, & - "If true, use the order of arithmetic and expressions that recover the answers "//& - "from the end of 2018. Otherwise, use a simpler expression to calculate gustiness.", & - default=default_2018_answers) - call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", CS%fix_ustar_gustless_bug, & + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "SURFACE_FORCING_ANSWER_DATE", CS%answer_date, & + "The vintage of the order of arithmetic and expressions in the gustiness "//& + "calculations. Values below 20190101 recover the answers from the end "//& + "of 2018, while higher values use a simpler expression to calculate gustiness.", & + default=default_answer_date) + + call get_param(param_file, mdl, "USTAR_GUSTLESS_BUG", CS%ustar_gustless_bug, & + "If true include a bug in the time-averaging of the gustless wind friction velocity", & + default=.false., do_not_log=.true.) + ! This is used to test whether USTAR_GUSTLESS_BUG is being actively set. + call get_param(param_file, mdl, "USTAR_GUSTLESS_BUG", test_value, default=.true., do_not_log=.true.) + explicit_bug = CS%ustar_gustless_bug .eqv. test_value + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", fix_ustar_gustless_bug, & "If true correct a bug in the time-averaging of the gustless wind friction velocity", & - default=.true.) + default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", test_value, default=.false., do_not_log=.true.) + explicit_fix = fix_ustar_gustless_bug .eqv. test_value + + if (explicit_bug .and. explicit_fix .and. (fix_ustar_gustless_bug .eqv. CS%ustar_gustless_bug)) then + ! USTAR_GUSTLESS_BUG is being explicitly set, and should not be changed. + call MOM_error(FATAL, "USTAR_GUSTLESS_BUG and FIX_USTAR_GUSTLESS_BUG are both being set "//& + "with inconsistent values. FIX_USTAR_GUSTLESS_BUG is an obsolete "//& + "parameter and should be removed.") + elseif (explicit_fix) then + call MOM_error(WARNING, "FIX_USTAR_GUSTLESS_BUG is an obsolete parameter. "//& + "Use USTAR_GUSTLESS_BUG instead (noting that it has the opposite sense).") + CS%ustar_gustless_bug = .not.fix_ustar_gustless_bug + endif + call log_param(param_file, mdl, "USTAR_GUSTLESS_BUG", CS%ustar_gustless_bug, & + "If true include a bug in the time-averaging of the gustless wind friction velocity", & + default=.false.) + ! See whether sufficiently thick sea ice should be treated as rigid. call get_param(param_file, mdl, "USE_RIGID_SEA_ICE", CS%rigid_sea_ice, & @@ -1549,7 +1699,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) if (CS%rigid_sea_ice) then call get_param(param_file, mdl, "G_EARTH", CS%g_Earth, & "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80, scale=US%Z_to_m*US%m_s_to_L_T**2) + units="m s-2", default=9.80, scale=US%Z_to_m*US%m_s_to_L_T**2) call get_param(param_file, mdl, "SEA_ICE_MEAN_DENSITY", CS%density_sea_ice, & "A typical density of sea ice, used with the kinematic "//& "viscosity, when USE_RIGID_SEA_ICE is true.", & @@ -1567,8 +1717,12 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) call get_param(param_file, mdl, "ALLOW_ICEBERG_FLUX_DIAGNOSTICS", iceberg_flux_diags, & "If true, makes available diagnostics of fluxes from icebergs "//& "as seen by MOM6.", default=.false.) + call get_param(param_file, mdl, "ALLOW_CARBON_FLUX_EXCHANGE", CS%allow_carbon_flux_exchange, & + "If true, makes available fluxes and diagnostics of carbon in runoff "//& + "within MOM6.", default=.false.) call register_forcing_type_diags(Time, diag, US, CS%use_temperature, CS%handles, & - use_berg_fluxes=iceberg_flux_diags) + use_berg_fluxes=iceberg_flux_diags, & + use_carbon_runoff=CS%allow_carbon_flux_exchange) call get_param(param_file, mdl, "ALLOW_FLUX_ADJUSTMENTS", CS%allow_flux_adjustments, & "If true, allows flux adjustments to specified via the "//& @@ -1583,8 +1737,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) if (CS%restore_salt) then salt_file = trim(CS%inputdir) // trim(CS%salt_restore_file) - CS%id_srestore = init_external_field(salt_file, CS%salt_restore_var_name, MOM_domain=G%Domain) - call safe_alloc_ptr(CS%srestore_mask,isd,ied,jsd,jed); CS%srestore_mask(:,:) = 1.0 + CS%srestore_handle = init_external_field(salt_file, CS%salt_restore_var_name, MOM_domain=G%Domain) + call safe_alloc_ptr(CS%srestore_mask,isd,ied,jsd,jed) ; CS%srestore_mask(:,:) = 1.0 if (CS%mask_srestore) then ! read a 2-d file containing a mask for restoring fluxes flnam = trim(CS%inputdir) // 'salt_restore_mask.nc' call MOM_read_data(flnam,'mask', CS%srestore_mask, G%domain, timelevel=1) @@ -1593,8 +1747,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) if (CS%restore_temp) then temp_file = trim(CS%inputdir) // trim(CS%temp_restore_file) - CS%id_trestore = init_external_field(temp_file, CS%temp_restore_var_name, MOM_domain=G%Domain) - call safe_alloc_ptr(CS%trestore_mask,isd,ied,jsd,jed); CS%trestore_mask(:,:) = 1.0 + CS%trestore_handle = init_external_field(temp_file, CS%temp_restore_var_name, MOM_domain=G%Domain) + call safe_alloc_ptr(CS%trestore_mask,isd,ied,jsd,jed) ; CS%trestore_mask(:,:) = 1.0 if (CS%mask_trestore) then ! read a 2-d file containing a mask for restoring fluxes flnam = trim(CS%inputdir) // 'temp_restore_mask.nc' call MOM_read_data(flnam, 'mask', CS%trestore_mask, G%domain, timelevel=1) @@ -1676,6 +1830,10 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) chks = field_chksum( iobt%runoff ) ; if (root) write(outunit,100) 'iobt%runoff ', chks chks = field_chksum( iobt%calving ) ; if (root) write(outunit,100) 'iobt%calving ', chks chks = field_chksum( iobt%p ) ; if (root) write(outunit,100) 'iobt%p ', chks + if (associated(iobt%shelf_sfc_mass_flux)) then + chks = field_chksum( iobt%shelf_sfc_mass_flux ) ; if (root) write(outunit,100) 'iobt%shelf_sfc_mass_flux ',& + chks + endif if (associated(iobt%ustar_berg)) then chks = field_chksum( iobt%ustar_berg ) ; if (root) write(outunit,100) 'iobt%ustar_berg ', chks endif @@ -1685,6 +1843,9 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) if (associated(iobt%mass_berg)) then chks = field_chksum( iobt%mass_berg ) ; if (root) write(outunit,100) 'iobt%mass_berg ', chks endif + if (associated(iobt%excess_salt)) then + chks = field_chksum( iobt%excess_salt ) ; if (root) write(outunit,100) 'iobt%excess_salt ', chks + endif 100 FORMAT(" CHECKSUM::",A20," = ",Z20) call coupler_type_write_chksums(iobt%fluxes, outunit, 'iobt%') @@ -1694,8 +1855,8 @@ end subroutine ice_ocn_bnd_type_chksum !> Check the values passed by IOB over land are zero subroutine check_mask_val_consistency(val, mask, i, j, varname, G) - real, intent(in) :: val !< value of flux/variable passed by IOB - real, intent(in) :: mask !< value of ocean mask + real, intent(in) :: val !< value of flux/variable passed by IOB [various] + real, intent(in) :: mask !< value of ocean mask [nondim] integer, intent(in) :: i !< model grid cell indices integer, intent(in) :: j !< model grid cell indices character(len=*), intent(in) :: varname !< variable name diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index 97fb869ad4..755d87a47a 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Top-level module for the MOM6 ocean model in coupled mode. module ocean_model_mod -! This file is part of MOM6. See LICENSE.md for the license. - ! This is the top level module for the MOM6 ocean model. It contains routines ! for initialization, termination and update of ocean model state. This ! particular version wraps all of the calls for MOM6 in the calls that had @@ -15,13 +17,14 @@ module ocean_model_mod use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized use MOM, only : get_ocean_stocks, step_offline +use MOM, only : save_MOM_restart use MOM_coms, only : field_chksum use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf use MOM_coupler_types, only : coupler_1d_bc_type, coupler_2d_bc_type use MOM_coupler_types, only : coupler_type_spawn, coupler_type_write_chksums use MOM_coupler_types, only : coupler_type_initialized, coupler_type_copy_data use MOM_coupler_types, only : coupler_type_set_diags, coupler_type_send_data -use MOM_diag_mediator, only : diag_ctrl, enable_averaging, disable_averaging +use MOM_diag_mediator, only : diag_ctrl, enable_averages, disable_averaging use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end use MOM_domains, only : MOM_domain_type, domain2d, clone_MOM_domain, get_domain_extent use MOM_domains, only : pass_var, pass_vector, AGRID, BGRID_NE, CGRID_NE, TO_ALL, Omit_Corners @@ -31,13 +34,11 @@ module ocean_model_mod use MOM_file_parser, only : get_param, log_version, close_param_file, param_file_type use MOM_forcing_type, only : forcing, mech_forcing, allocate_forcing_type use MOM_forcing_type, only : fluxes_accumulate, get_net_mass_forcing -use MOM_forcing_type, only : copy_back_forcing_fields use MOM_forcing_type, only : forcing_diagnostics, mech_forcing_diags use MOM_get_input, only : Get_MOM_Input, directories use MOM_grid, only : ocean_grid_type use MOM_io, only : write_version_number, stdout_if_root use MOM_marine_ice, only : iceberg_forces, iceberg_fluxes, marine_ice_init, marine_ice_CS -use MOM_restart, only : MOM_restart_CS, save_restart use MOM_string_functions, only : uppercase use MOM_surface_forcing_gfdl, only : surface_forcing_init, convert_IOB_to_fluxes use MOM_surface_forcing_gfdl, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum @@ -46,14 +47,16 @@ module ocean_model_mod use MOM_time_manager, only : time_type, operator(>), operator(+), operator(-) use MOM_time_manager, only : operator(*), operator(/), operator(/=) use MOM_time_manager, only : operator(<=), operator(>=), operator(<) -use MOM_time_manager, only : real_to_time, time_type_to_real +use MOM_time_manager, only : real_to_time, time_to_real use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_init use MOM_tracer_flow_control, only : call_tracer_flux_init use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type use MOM_ice_shelf, only : initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS +use MOM_ice_shelf, only : initialize_ice_shelf_fluxes, initialize_ice_shelf_forces use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart +use MOM_ice_shelf, only : ice_sheet_calving_to_ocean_sfc, adjust_ice_sheet_frazil use MOM_wave_interface, only: wave_parameters_CS, MOM_wave_interface_init use MOM_wave_interface, only: Update_Surface_Waves use iso_fortran_env, only : int64 @@ -120,7 +123,10 @@ module ocean_model_mod !! formation in the ocean. melt_potential => NULL(), & !< Instantaneous heat used to melt sea ice [J m-2]. OBLD => NULL(), & !< Ocean boundary layer depth [m]. - area => NULL() !< cell area of the ocean surface [m2]. + area => NULL(), & !< cell area of the ocean surface [m2]. + calving => NULL(), &!< The mass per unit area of the ice shelf to convert to + !! bergs [kg m-2]. + calving_hflx => NULL() !< Calving heat flux [W m-2]. type(coupler_2d_bc_type) :: fields !< A structure that may contain named !! arrays of tracer-related surface fields. integer :: avg_kount !< A count of contributions to running @@ -156,6 +162,8 @@ module ocean_model_mod !! ocean dynamics and forcing fluxes. real :: press_to_z !< A conversion factor between pressure and ocean depth, !! usually 1/(rho_0*g) [Z T2 R-1 L-2 ~> m Pa-1]. + logical :: calve_ice_shelf_bergs = .false. !< If true, bergs are initialized according to + !! ice shelf flux through the ice front real :: C_p !< The heat capacity of seawater [J degC-1 kg-1]. logical :: offline_tracer_mode = .false. !< If false, use the model in prognostic mode !! with the barotropic and baroclinic dynamics, thermodynamics, @@ -170,8 +178,8 @@ module ocean_model_mod !! If false, the two phases are advanced with !! separate calls. The default is true. ! The following 3 variables are only used here if single_step_call is false. - real :: dt !< (baroclinic) dynamics time step [s] - real :: dt_therm !< thermodynamics time step [s] + real :: dt !< (baroclinic) dynamics time step [T ~> s] + real :: dt_therm !< thermodynamics time step [T ~> s] logical :: thermo_spans_coupling !< If true, thermodynamic and tracer time !! steps can span multiple coupled time steps. logical :: diabatic_first !< If true, apply diabatic and thermodynamic @@ -208,9 +216,6 @@ module ocean_model_mod Waves => NULL() !< A pointer to the surface wave control structure type(surface_forcing_CS), pointer :: & forcing_CSp => NULL() !< A pointer to the MOM forcing control structure - type(MOM_restart_CS), pointer :: & - restart_CSp => NULL() !< A pointer set to the restart control structure - !! that will be used for MOM restart files. type(diag_ctrl), pointer :: & diag => NULL() !< A pointer to the diagnostic regulatory structure end type ocean_state_type @@ -223,7 +228,7 @@ module ocean_model_mod !! This subroutine initializes both the ocean state and the ocean surface type. !! Because of the way that indices and domains are handled, Ocean_sfc must have !! been used in a previous call to initialize_ocean_type. -subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas_fields_ocn) +subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas_fields_ocn, calve_ice_shelf_bergs) type(ocean_public_type), target, & intent(inout) :: Ocean_sfc !< A structure containing various publicly !! visible ocean surface properties after initialization, @@ -241,6 +246,8 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas !! in the calculation of additional gas or other !! tracer fluxes, and can be used to spawn related !! internal variables in the ice model. + logical, optional, intent(in) :: calve_ice_shelf_bergs !< If true, track ice shelf flux through a + !! static ice shelf, so that it can be converted into icebergs ! Local variables real :: Rho0 ! The Boussinesq ocean density [R ~> kg m-3] real :: G_Earth ! The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] @@ -249,6 +256,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas !! min(HFrz, OBLD), where OBLD is the boundary layer depth. !! If HFrz <= 0 (default), melt potential will not be computed. logical :: use_melt_pot !< If true, allocate melt_potential array + logical :: point_calving ! Equals calve_ice_shelf_bergs if calve_ice_shelf_bergs is present ! This include declares and sets the variable "version". # include "version_variable.h" @@ -274,9 +282,13 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas if (.not.OS%is_ocean_pe) return OS%Time = Time_in ; OS%Time_dyn = Time_in + ! Call initialize MOM with an optional Ice Shelf CS which, if present triggers + ! initialization of ice shelf parameters and arrays. + point_calving = .false. ; if (present(calve_ice_shelf_bergs)) point_calving = calve_ice_shelf_bergs call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & - OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & - diag_ptr=OS%diag, count_calls=.true.) + Time_in, offline_tracer_mode=OS%offline_tracer_mode, & + diag_ptr=OS%diag, count_calls=.true., ice_shelf_CSp=OS%ice_shelf_CSp, & + waves_CSp=OS%Waves, calve_ice_shelf_bergs=point_calving) call get_MOM_state_elements(OS%MOM_CSp, G=OS%grid, GV=OS%GV, US=OS%US, C_p=OS%C_p, & C_p_scaled=OS%fluxes%C_p, use_temp=use_temperature) @@ -288,16 +300,17 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas "including both dynamics and thermodynamics. If false, "//& "the two phases are advanced with separate calls.", default=.true.) call get_param(param_file, mdl, "DT", OS%dt, & - "The (baroclinic) dynamics time step. The time-step that "//& - "is actually used will be an integer fraction of the "//& - "forcing time-step.", units="s", fail_if_missing=.true.) + "The (baroclinic) dynamics time step. The time-step that is actually "//& + "used will be an integer fraction of the forcing time-step.", & + units="s", scale=OS%US%s_to_T, fail_if_missing=.true.) call get_param(param_file, mdl, "DT_THERM", OS%dt_therm, & "The thermodynamic and tracer advection time step. "//& "Ideally DT_THERM should be an integer multiple of DT "//& "and less than the forcing or coupling time-step, unless "//& "THERMO_SPANS_COUPLING is true, in which case DT_THERM "//& "can be an integer multiple of the coupling timestep. By "//& - "default DT_THERM is set to DT.", units="s", default=OS%dt) + "default DT_THERM is set to DT.", & + units="s", scale=OS%US%s_to_T, default=OS%US%T_to_s*OS%dt) call get_param(param_file, "MOM", "THERMO_SPANS_COUPLING", OS%thermo_spans_coupling, & "If true, the MOM will take thermodynamic and tracer "//& "timesteps that can be longer than the coupling timestep. "//& @@ -329,7 +342,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas call get_param(param_file, mdl, "RHO_0", Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& + "properties, or with BOUSSINESQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0, scale=OS%US%kg_m3_to_R) call get_param(param_file, mdl, "G_EARTH", G_Earth, & @@ -361,7 +374,8 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas !allocate(OS%sfc_state) call allocate_surface_state(OS%sfc_state, OS%grid, use_temperature, do_integrals=.true., & - gas_fields_ocn=gas_fields_ocn, use_meltpot=use_melt_pot) + gas_fields_ocn=gas_fields_ocn, use_meltpot=use_melt_pot, & + use_iceshelves=OS%use_ice_shelf) if (present(wind_stagger)) then call surface_forcing_init(Time_in, OS%grid, OS%US, param_file, OS%diag, & @@ -372,9 +386,10 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas endif if (OS%use_ice_shelf) then - call initialize_ice_shelf(param_file, OS%grid, OS%Time, OS%ice_shelf_CSp, & - OS%diag, OS%forces, OS%fluxes) + call initialize_ice_shelf_fluxes(OS%ice_shelf_CSp, OS%grid, OS%US, OS%fluxes) + call initialize_ice_shelf_forces(OS%ice_shelf_CSp, OS%grid, OS%US, OS%forces) endif + if (OS%icebergs_alter_ocean) then call marine_ice_init(OS%Time, OS%grid, param_file, OS%diag, OS%marine_ice_CSp) if (.not. OS%use_ice_shelf) & @@ -398,10 +413,20 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas call extract_surface_state(OS%MOM_CSp, OS%sfc_state) + if (OS%use_ice_shelf .and. allocated(OS%sfc_state%frazil)) & + call adjust_ice_sheet_frazil(OS%sfc_state, OS%fluxes, OS%Ice_shelf_CSp) + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US) endif + if (present(calve_ice_shelf_bergs)) then + if (calve_ice_shelf_bergs) then + call convert_shelf_state_to_ocean_type(Ocean_sfc, OS%Ice_shelf_CSp, OS%US) + OS%calve_ice_shelf_bergs=.true. + endif + endif + call close_param_file(param_file) call diag_mediator_close_registration(OS%diag) @@ -455,12 +480,12 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda ! internal modules. type(time_type) :: Time1 ! The value of the ocean model's time at the start of a call to step_MOM. integer :: index_bnds(4) ! The computational domain index bounds in the ice-ocean boundary type. - real :: weight ! Flux accumulation weight of the current fluxes. - real :: dt_coupling ! The coupling time step [s]. - real :: dt_therm ! A limited and quantized version of OS%dt_therm [s]. - real :: dt_dyn ! The dynamics time step [s]. - real :: dtdia ! The diabatic time step [s]. - real :: t_elapsed_seg ! The elapsed time in this update segment [s]. + real :: weight ! Flux accumulation weight of the current fluxes [nondim]. + real :: dt_coupling ! The coupling time step [T ~> s]. + real :: dt_therm ! A limited and quantized version of OS%dt_therm [T ~> s]. + real :: dt_dyn ! The dynamics time step [T ~> s]. + real :: dtdia ! The diabatic time step [T ~> s]. + real :: t_elapsed_seg ! The elapsed time in this update segment [T ~> s]. integer :: n ! The internal iteration counter. integer :: nts ! The number of baroclinic dynamics time steps in a thermodynamic step. integer :: n_max ! The number of calls to step_MOM dynamics in this call to update_ocean_model. @@ -472,7 +497,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda integer :: is, ie, js, je call callTree_enter("update_ocean_model(), ocean_model_MOM.F90") - dt_coupling = time_type_to_real(Ocean_coupling_time_step) + dt_coupling = time_to_real(Ocean_coupling_time_step, scale=OS%US%s_to_T) if (.not.associated(OS)) then call MOM_error(FATAL, "update_ocean_model called with an unassociated "// & @@ -528,7 +553,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda OS%sfc_state, dt_coupling, OS%marine_ice_CSp) #ifdef _USE_GENERIC_TRACER - call enable_averaging(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) !Is this needed? + call enable_averages(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) !Is this needed? call MOM_generic_tracer_fluxes_accumulate(OS%fluxes, 1.0) ! Here weight=1, so just store the current fluxes call disable_averaging(OS%diag) #endif @@ -540,7 +565,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda OS%grid, OS%US, OS%forcing_CSp, OS%sfc_state) if (OS%use_ice_shelf) & - call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time, dt_coupling, OS%Ice_shelf_CSp) + call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time,dt_coupling, OS%Ice_shelf_CSp) if (OS%icebergs_alter_ocean) & call iceberg_fluxes(OS%grid, OS%US, OS%flux_tmp, OS%use_ice_shelf, & OS%sfc_state, dt_coupling, OS%marine_ice_CSp) @@ -565,7 +590,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda endif if ((OS%nstep==0) .and. (OS%nstep_thermo==0)) then ! This is the first call to update_ocean_model. - call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%restart_CSp) + call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp) endif Time_thermo_start = OS%Time @@ -576,10 +601,16 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp) elseif ((.not.do_thermo) .or. (.not.do_dyn)) then ! The call sequence is being orchestrated from outside of update_ocean_model. - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & + if (present(cycle_length)) then + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=do_dyn, do_thermodynamics=do_thermo, & - start_cycle=start_cycle, end_cycle=end_cycle, cycle_length=cycle_length, & + start_cycle=start_cycle, end_cycle=end_cycle, cycle_length=OS%US%s_to_T*cycle_length, & reset_therm=Ocn_fluxes_used) + else + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & + Waves=OS%Waves, do_dynamics=do_dyn, do_thermodynamics=do_thermo, & + start_cycle=start_cycle, end_cycle=end_cycle, reset_therm=Ocn_fluxes_used) + endif elseif (OS%single_step_call) then call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) else ! Step both the dynamics and thermodynamics with separate calls. @@ -628,7 +659,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda if (step_thermo) then ! Back up Time1 to the start of the thermodynamic segment. - Time1 = Time1 - real_to_time(dtdia - dt_dyn) + Time1 = Time1 - real_to_time(dtdia - dt_dyn, unscale=OS%US%T_to_s) call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) @@ -636,7 +667,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda endif t_elapsed_seg = t_elapsed_seg + dt_dyn - Time1 = Time_seg_start + real_to_time(t_elapsed_seg) + Time1 = Time_seg_start + real_to_time(t_elapsed_seg, unscale=OS%US%T_to_s) enddo endif @@ -654,10 +685,15 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%grid, OS%US, OS%Time, OS%diag, OS%forcing_CSp%handles) endif + !only ,ale ice-shelf frazil adjustments if sfc_state%frazil was updated (do_thermo=True) + if (do_thermo .and. OS%use_ice_shelf .and. allocated(OS%sfc_state%frazil)) & + call adjust_ice_sheet_frazil(OS%sfc_state, OS%fluxes, OS%Ice_shelf_CSp) + ! Translate state into Ocean. ! call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US, & ! OS%fluxes%p_surf_full, OS%press_to_z) call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US) + if (OS%calve_ice_shelf_bergs) call convert_shelf_state_to_ocean_type(Ocean_sfc,OS%Ice_shelf_CSp, OS%US) Time1 = OS%Time ; if (do_dyn) Time1 = OS%Time_dyn call coupler_type_send_data(Ocean_sfc%fields, Time1) @@ -680,8 +716,8 @@ subroutine ocean_model_restart(OS, timestamp) "restart files can only be created after the buoyancy forcing is applied.") if (BTEST(OS%Restart_control,1)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, .true., GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, time_stamped=.true., GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir, .true.) if (OS%use_ice_shelf) then @@ -689,8 +725,8 @@ subroutine ocean_model_restart(OS, timestamp) endif endif if (BTEST(OS%Restart_control,0)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) if (OS%use_ice_shelf) then @@ -743,14 +779,13 @@ subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) if (present(directory)) then ; restart_dir = directory else ; restart_dir = OS%dirs%restart_output_dir ; endif - call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, restart_dir, Time, OS%grid, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, Time, restart_dir) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) endif - end subroutine ocean_model_save_restart !> Initialize the public ocean type @@ -780,6 +815,8 @@ subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, gas_field Ocean_sfc%u_surf (isc:iec,jsc:jec), & Ocean_sfc%v_surf (isc:iec,jsc:jec), & Ocean_sfc%sea_lev(isc:iec,jsc:jec), & + Ocean_sfc%calving(isc:iec,jsc:jec), & + Ocean_sfc%calving_hflx(isc:iec,jsc:jec), & Ocean_sfc%area (isc:iec,jsc:jec), & Ocean_sfc%melt_potential(isc:iec,jsc:jec), & Ocean_sfc%OBLD (isc:iec,jsc:jec), & @@ -790,6 +827,8 @@ subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, gas_field Ocean_sfc%u_surf(:,:) = 0.0 ! time averaged u-current (m/sec) passed to atmosphere/ice models Ocean_sfc%v_surf(:,:) = 0.0 ! time averaged v-current (m/sec) passed to atmosphere/ice models Ocean_sfc%sea_lev(:,:) = 0.0 ! time averaged thickness of top model grid cell (m) plus patm/rho0/grav + Ocean_sfc%calving(:,:) = 0.0 ! time accumulated ice sheet calving (kg m-2) passed to ice model + Ocean_sfc%calving_hflx(:,:) = 0.0 ! time accumulated ice sheet calving heat flux (W m-2) passed to ice model Ocean_sfc%frazil(:,:) = 0.0 ! time accumulated frazil (J/m^2) passed to ice model Ocean_sfc%melt_potential(:,:) = 0.0 ! time accumulated melt potential (J/m^2) passed to ice model Ocean_sfc%OBLD(:,:) = 0.0 ! ocean boundary layer depth (m) @@ -821,7 +860,6 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_ real, optional, intent(in) :: press_to_z !< A conversion factor between pressure and ocean !! depth, usually 1/(rho_0*g) [Z T2 R-1 L-2 ~> m Pa-1] ! Local variables - real :: IgR0 character(len=48) :: val_str integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd integer :: i, j, i0, j0, is, ie, js, je @@ -840,22 +878,22 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_ if (sfc_state%T_is_conT) then ! Convert the surface T from conservative T to potential T. do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%t_surf(i,j) = gsw_pt_from_ct(sfc_state%SSS(i+i0,j+j0), & - sfc_state%SST(i+i0,j+j0)) + CELSIUS_KELVIN_OFFSET + Ocean_sfc%t_surf(i,j) = gsw_pt_from_ct(US%S_to_ppt*sfc_state%SSS(i+i0,j+j0), & + US%C_to_degC*sfc_state%SST(i+i0,j+j0)) + CELSIUS_KELVIN_OFFSET enddo ; enddo else do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%t_surf(i,j) = sfc_state%SST(i+i0,j+j0) + CELSIUS_KELVIN_OFFSET + Ocean_sfc%t_surf(i,j) = US%C_to_degC*sfc_state%SST(i+i0,j+j0) + CELSIUS_KELVIN_OFFSET enddo ; enddo endif if (sfc_state%S_is_absS) then ! Convert the surface S from absolute salinity to practical salinity. do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%s_surf(i,j) = gsw_sp_from_sr(sfc_state%SSS(i+i0,j+j0)) + Ocean_sfc%s_surf(i,j) = gsw_sp_from_sr(US%S_to_ppt*sfc_state%SSS(i+i0,j+j0)) enddo ; enddo else do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%s_surf(i,j) = sfc_state%SSS(i+i0,j+j0) + Ocean_sfc%s_surf(i,j) = US%S_to_ppt*sfc_state%SSS(i+i0,j+j0) enddo ; enddo endif @@ -924,6 +962,24 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_ end subroutine convert_state_to_ocean_type +!> Converts the ice-shelf-to-ocean calving and calving_hflx variables from the ice-shelf state (ISS) type +!! to the ocean public type +subroutine convert_shelf_state_to_ocean_type(Ocean_sfc, CS, US) + type(ocean_public_type), & + target, intent(inout) :: Ocean_sfc !< A structure containing various publicly + !! visible ocean surface fields, whose elements + !! have their data set here. + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd, i, j + + call get_domain_extent(Ocean_sfc%Domain, isc_bnd, iec_bnd, jsc_bnd, jec_bnd) + + call ice_sheet_calving_to_ocean_sfc(CS,US,Ocean_sfc%calving(isc_bnd:iec_bnd,jsc_bnd:jec_bnd),& + Ocean_sfc%calving_hflx(isc_bnd:iec_bnd,jsc_bnd:jec_bnd)) + +end subroutine convert_shelf_state_to_ocean_type + !> This subroutine extracts the surface properties from the ocean's internal !! state and stores them in the ocean type returned to the calling ice model. !! It has to be separate from the ocean_initialization call because the coupler @@ -941,6 +997,9 @@ subroutine ocean_model_init_sfc(OS, Ocean_sfc) call extract_surface_state(OS%MOM_CSp, OS%sfc_state) + if (OS%use_ice_shelf .and. allocated(OS%sfc_state%frazil)) & + call adjust_ice_sheet_frazil(OS%sfc_state, OS%fluxes, OS%Ice_shelf_CSp) + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US) end subroutine ocean_model_init_sfc @@ -976,7 +1035,7 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) type(ocean_state_type), pointer :: OS !< A structure containing the internal ocean state. !! The data in OS is intent in. integer, intent(in) :: index !< The stock index for the quantity of interest. - real, intent(out) :: value !< Sum returned for the conservation quantity of interest. + real, intent(out) :: value !< Sum returned for the conservation quantity of interest [various] integer, optional, intent(in) :: time_index !< An unused optional argument, present only for !! interfacial compatibility with other models. ! Arguments: OS - A structure containing the internal ocean state. @@ -984,24 +1043,24 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) ! (in) value - Sum returned for the conservation quantity of interest. ! (in,opt) time_index - Index for time level to use if this is necessary. - real :: salt + real :: salt ! The total salt in the ocean [kg] value = 0.0 if (.not.associated(OS)) return if (.not.OS%is_ocean_pe) return select case (index) - case (ISTOCK_WATER) ! Return the mass of fresh water in the ocean in kg. + case (ISTOCK_WATER) ! Return the mass of fresh water in the ocean in [kg]. if (OS%GV%Boussinesq) then call get_ocean_stocks(OS%MOM_CSp, mass=value, on_PE_only=.true.) else ! In non-Boussinesq mode, the mass of salt needs to be subtracted. call get_ocean_stocks(OS%MOM_CSp, mass=value, salt=salt, on_PE_only=.true.) value = value - salt endif - case (ISTOCK_HEAT) ! Return the heat content of the ocean in J. + case (ISTOCK_HEAT) ! Return the heat content of the ocean in [J]. call get_ocean_stocks(OS%MOM_CSp, heat=value, on_PE_only=.true.) - case (ISTOCK_SALT) ! Return the mass of the salt in the ocean in kg. - call get_ocean_stocks(OS%MOM_CSp, salt=value, on_PE_only=.true.) + case (ISTOCK_SALT) ! Return the mass of the salt in the ocean in [kg]. + call get_ocean_stocks(OS%MOM_CSp, salt=value, on_PE_only=.true.) case default ; value = 0.0 end select ! If the FMS coupler is changed so that Ocean_stock_PE is only called on @@ -1018,10 +1077,10 @@ subroutine ocean_model_data2D_get(OS, Ocean, name, array2D, isc, jsc) type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly !! visible ocean surface fields. character(len=*) , intent(in) :: name !< The name of the field to extract - real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must - !! cover only the computational domain integer , intent(in) :: isc !< The starting i-index of array2D integer , intent(in) :: jsc !< The starting j-index of array2D + real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must + !! cover only the computational domain [various] integer :: g_isc, g_iec, g_jsc, g_jec, g_isd, g_ied, g_jsd, g_jed, i, j @@ -1079,8 +1138,8 @@ subroutine ocean_model_data1D_get(OS, Ocean, name, value) !! internal ocean state (intent in). type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly !! visible ocean surface fields. - character(len=*) , intent(in) :: name !< The name of the field to extract - real , intent(out):: value !< The value of the named field + character(len=*), intent(in) :: name !< The name of the field to extract + real, intent(out):: value !< The value of the named field [various] if (.not.associated(OS)) return if (.not.OS%is_ocean_pe) return @@ -1141,10 +1200,10 @@ subroutine ocean_model_get_UV_surf(OS, Ocean, name, array2D, isc, jsc) type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly !! visible ocean surface fields. character(len=*) , intent(in) :: name !< The name of the current (ua or va) to extract - real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must - !! cover only the computational domain integer , intent(in) :: isc !< The starting i-index of array2D integer , intent(in) :: jsc !< The starting j-index of array2D + real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must + !! cover only the computational domain [L T-1 ~> m s-1] type(ocean_grid_type) , pointer :: G !< The ocean's grid structure type(surface), pointer :: sfc_state !< A structure containing fields that @@ -1189,6 +1248,14 @@ subroutine ocean_model_get_UV_surf(OS, Ocean, name, array2D, isc, jsc) array2D(i,j) = G%mask2dBu(I+i0,J+j0) * & 0.5*(sfc_state%v(i+i0,J+j0)+sfc_state%v(i+i0+1,J+j0)) enddo ; enddo + case('uc') + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + array2D(i,j) = G%mask2dCu(I+i0,J+j0) * sfc_state%u(I+i0,j+j0) + enddo ; enddo + case('vc') + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + array2D(i,j) = G%mask2dCv(I+i0,J+j0) * sfc_state%v(i+i0,J+j0) + enddo ; enddo case default call MOM_error(FATAL,'ocean_model_get_UV_surf: unknown argument name='//name) end select diff --git a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 b/config_src/drivers/STALE_mct_cap/mom_ocean_model_mct.F90 similarity index 92% rename from config_src/drivers/mct_cap/mom_ocean_model_mct.F90 rename to config_src/drivers/STALE_mct_cap/mom_ocean_model_mct.F90 index 3bd0e1e28d..e37b3ccb89 100644 --- a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 +++ b/config_src/drivers/STALE_mct_cap/mom_ocean_model_mct.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Top-level module for the MOM6 ocean model in coupled mode. module MOM_ocean_model_mct -! This file is part of MOM6. See LICENSE.md for the license. - ! This is the top level module for the MOM6 ocean model. It contains routines ! for initialization, termination and update of ocean model state. This ! particular version wraps all of the calls for MOM6 in the calls that had @@ -15,9 +17,10 @@ module MOM_ocean_model_mct use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized use MOM, only : get_ocean_stocks, step_offline +use MOM, only : save_MOM_restart use MOM_coms, only : field_chksum use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf -use MOM_diag_mediator, only : diag_ctrl, enable_averaging, disable_averaging +use MOM_diag_mediator, only : diag_ctrl, enable_averages, disable_averaging use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end use MOM_domains, only : pass_var, pass_vector, AGRID, BGRID_NE, CGRID_NE use MOM_domains, only : TO_ALL, Omit_Corners @@ -34,7 +37,6 @@ module MOM_ocean_model_mct use MOM_grid, only : ocean_grid_type use MOM_io, only : close_file, file_exists, read_data, write_version_number use MOM_marine_ice, only : iceberg_forces, iceberg_fluxes, marine_ice_init, marine_ice_CS -use MOM_restart, only : MOM_restart_CS, save_restart use MOM_string_functions, only : uppercase use MOM_surface_forcing_mct, only : surface_forcing_init, convert_IOB_to_fluxes use MOM_surface_forcing_mct, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum @@ -51,18 +53,18 @@ module MOM_ocean_model_mct use MOM_verticalGrid, only : verticalGrid_type use MOM_ice_shelf, only : initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart -use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type -use coupler_types_mod, only : coupler_type_spawn, coupler_type_write_chksums -use coupler_types_mod, only : coupler_type_initialized, coupler_type_copy_data -use coupler_types_mod, only : coupler_type_set_diags, coupler_type_send_data +use MOM_ice_shelf, only : adjust_ice_sheet_frazil +use MOM_coupler_types, only : coupler_1d_bc_type, coupler_2d_bc_type +use MOM_coupler_types, only : coupler_type_spawn, coupler_type_write_chksums +use MOM_coupler_types, only : coupler_type_initialized, coupler_type_copy_data +use MOM_coupler_types, only : coupler_type_set_diags, coupler_type_send_data use mpp_domains_mod, only : domain2d, mpp_get_layout, mpp_get_global_domain use mpp_domains_mod, only : mpp_define_domains, mpp_get_compute_domain, mpp_get_data_domain use MOM_io, only : stdout -use mpp_mod, only : mpp_chksum use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct use MOM_wave_interface, only : wave_parameters_CS, MOM_wave_interface_init use MOM_wave_interface, only : Update_Surface_Waves -use time_interp_external_mod, only : time_interp_external_init +use MOM_interpolate, only : time_interp_external_init ! MCT specfic routines use MOM_domains, only : MOM_infra_end @@ -134,7 +136,7 @@ module MOM_ocean_model_mct !> The ocean_state_type contains all information about the state of the ocean, !! with a format that is private so it can be readily changed without disrupting !! other coupled components. -type, public :: ocean_state_type ; +type, public :: ocean_state_type ! This type is private, and can therefore vary between different ocean models. logical :: is_ocean_PE = .false. !< True if this is an ocean PE. type(time_type) :: Time !< The ocean model's time and master clock. @@ -171,8 +173,8 @@ module MOM_ocean_model_mct !! If false, the two phases are advanced with !! separate calls. The default is true. ! The following 3 variables are only used here if single_step_call is false. - real :: dt !< (baroclinic) dynamics time step (seconds) - real :: dt_therm !< thermodynamics time step (seconds) + real :: dt !< (baroclinic) dynamics time step [T ~> s] + real :: dt_therm !< thermodynamics time step [T ~> s] logical :: thermo_spans_coupling !< If true, thermodynamic and tracer time !! steps can span multiple coupled time steps. logical :: diabatic_first !< If true, apply diabatic and thermodynamic @@ -208,9 +210,6 @@ module MOM_ocean_model_mct Waves => NULL() !< A pointer to the surface wave control structure type(surface_forcing_CS), pointer :: & forcing_CSp => NULL() !< A pointer to the MOM forcing control structure - type(MOM_restart_CS), pointer :: & - restart_CSp => NULL() !< A pointer set to the restart control structure - !! that will be used for MOM restart files. type(diag_ctrl), pointer :: & diag => NULL() !< A pointer to the diagnostic regulatory structure end type ocean_state_type @@ -272,9 +271,9 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i OS%Time = Time_in call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & - OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & + Time_in, offline_tracer_mode=OS%offline_tracer_mode, & input_restart_file=input_restart_file, & - diag_ptr=OS%diag, count_calls=.true.) + diag_ptr=OS%diag, count_calls=.true., waves_CSp=OS%Waves) call get_MOM_state_elements(OS%MOM_CSp, G=OS%grid, GV=OS%GV, US=OS%US, C_p=OS%C_p, & C_p_scaled=OS%fluxes%C_p, use_temp=use_temperature) @@ -286,16 +285,17 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i "including both dynamics and thermodynamics. If false, "//& "the two phases are advanced with separate calls.", default=.true.) call get_param(param_file, mdl, "DT", OS%dt, & - "The (baroclinic) dynamics time step. The time-step that "//& - "is actually used will be an integer fraction of the "//& - "forcing time-step.", units="s", fail_if_missing=.true.) + "The (baroclinic) dynamics time step. The time-step that is actually "//& + "used will be an integer fraction of the forcing time-step.", & + units="s", scale=OS%US%s_to_T, fail_if_missing=.true.) call get_param(param_file, mdl, "DT_THERM", OS%dt_therm, & "The thermodynamic and tracer advection time step. "//& "Ideally DT_THERM should be an integer multiple of DT "//& "and less than the forcing or coupling time-step, unless "//& "THERMO_SPANS_COUPLING is true, in which case DT_THERM "//& "can be an integer multiple of the coupling timestep. By "//& - "default DT_THERM is set to DT.", units="s", default=OS%dt) + "default DT_THERM is set to DT.", & + units="s", scale=OS%US%s_to_T, default=OS%US%T_to_s*OS%dt) call get_param(param_file, "MOM", "THERMO_SPANS_COUPLING", OS%thermo_spans_coupling, & "If true, the MOM will take thermodynamic and tracer "//& "timesteps that can be longer than the coupling timestep. "//& @@ -335,7 +335,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i call get_param(param_file, mdl, "RHO_0", Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& + "properties, or with BOUSSINESQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0) call get_param(param_file, mdl, "G_EARTH", G_Earth, & @@ -365,14 +365,15 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i ! Consider using a run-time flag to determine whether to do the diagnostic ! vertical integrals, since the related 3-d sums are not negligible in cost. call allocate_surface_state(OS%sfc_state, OS%grid, use_temperature, & - do_integrals=.true., gas_fields_ocn=gas_fields_ocn, use_meltpot=use_melt_pot) + do_integrals=.true., gas_fields_ocn=gas_fields_ocn, & + use_meltpot=use_melt_pot, use_iceshelves=OS%use_ice_shelf) call surface_forcing_init(Time_in, OS%grid, OS%US, param_file, OS%diag, & OS%forcing_CSp, OS%restore_salinity, OS%restore_temp) if (OS%use_ice_shelf) then call initialize_ice_shelf(param_file, OS%grid, OS%Time, OS%ice_shelf_CSp, & - OS%diag, OS%forces, OS%fluxes) + OS%diag, Time_init, OS%dirs%output_directory, OS%forces, OS%fluxes) endif if (OS%icebergs_alter_ocean) then @@ -404,6 +405,9 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i call extract_surface_state(OS%MOM_CSp, OS%sfc_state) + if (OS%use_ice_shelf .and. allocated(OS%sfc_state%frazil)) & + call adjust_ice_sheet_frazil(OS%sfc_state, OS%fluxes, OS%Ice_shelf_CSp) + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US) endif @@ -449,13 +453,13 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & integer :: index_bnds(4) ! The computational domain index bounds in the ! ice-ocean boundary type. real :: weight ! Flux accumulation weight - real :: dt_coupling ! The coupling time step in seconds. + real :: dt_coupling ! The coupling time step [T ~> s] integer :: nts ! The number of baroclinic dynamics time steps ! within dt_coupling. - real :: dt_therm ! A limited and quantized version of OS%dt_therm (sec) - real :: dt_dyn ! The dynamics time step in sec. - real :: dtdia ! The diabatic time step in sec. - real :: t_elapsed_seg ! The elapsed time in this update segment, in s. + real :: dt_therm ! A limited and quantized version of OS%dt_therm [T ~> s] + real :: dt_dyn ! The dynamics time step [T ~> s] + real :: dtdia ! The diabatic time step [T ~> s] + real :: t_elapsed_seg ! The elapsed time in this update segment [T ~> s] integer :: n, n_max, n_last_thermo type(time_type) :: Time2 ! A temporary time. logical :: thermo_does_span_coupling ! If true, thermodynamic forcing spans @@ -468,7 +472,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call callTree_enter("update_ocean_model(), MOM_ocean_model_mct.F90") call get_time(Ocean_coupling_time_step, secs, days) - dt_coupling = 86400.0*real(days) + real(secs) + dt_coupling = OS%US%s_to_T*(86400.0*real(days) + real(secs)) if (time_start_update /= OS%Time) then call MOM_error(WARNING, "update_ocean_model: internal clock does not "//& @@ -502,7 +506,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (OS%fluxes%fluxes_used) then ! GMM, is enable_averaging needed now? - call enable_averaging(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) + call enable_averages(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) if (do_thermo) & call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, index_bnds, OS%Time, dt_coupling, & @@ -529,7 +533,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call copy_common_forcing_fields(OS%forces, OS%fluxes, OS%grid) #ifdef _USE_GENERIC_TRACER - call enable_averaging(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) !Is this needed? + call enable_averages(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) !Is this needed? call MOM_generic_tracer_fluxes_accumulate(OS%fluxes, weight) !here weight=1, just saving the current fluxes #endif @@ -575,13 +579,13 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & endif if (OS%nstep==0) then - call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%restart_CSp) + call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp) endif call disable_averaging(OS%diag) Master_time = OS%Time ; Time1 = OS%Time - if(OS%offline_tracer_mode) then + if (OS%offline_tracer_mode) then call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp) elseif ((.not.do_thermo) .or. (.not.do_dyn)) then @@ -640,7 +644,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (step_thermo) then ! Back up Time2 to the start of the thermodynamic segment. - Time2 = Time2 - set_time(int(floor((dtdia - dt_dyn) + 0.5))) + Time2 = Time2 - set_time(int(floor(OS%US%T_to_s*(dtdia - dt_dyn) + 0.5))) call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) @@ -648,7 +652,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & endif t_elapsed_seg = t_elapsed_seg + dt_dyn - Time2 = Time1 + set_time(int(floor(t_elapsed_seg + 0.5))) + Time2 = Time1 + set_time(int(floor(OS%US%T_to_s*t_elapsed_seg + 0.5))) enddo endif @@ -661,6 +665,10 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%grid, OS%US, OS%Time, OS%diag, OS%forcing_CSp%handles) endif + !only make ice-shelf frazil adjustments if sfc_state%frazil was updated (do_thermo=True) + if (do_thermo .and. OS%use_ice_shelf .and. allocated(OS%sfc_state%frazil)) & + call adjust_ice_sheet_frazil(OS%sfc_state, OS%fluxes, OS%Ice_shelf_CSp) + ! Translate state into Ocean. ! call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, & ! Ice_ocean_boundary%p, OS%press_to_z) @@ -689,34 +697,34 @@ subroutine ocean_model_restart(OS, timestamp, restartname) "restart files can only be created after the buoyancy forcing is applied.") if (present(restartname)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV, filename=restartname) - call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, GV=OS%GV, filename=restartname) + call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) ! Is this needed? - if (OS%use_ice_shelf) then - call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, & + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, & OS%dirs%restart_output_dir) - endif + endif else - if (BTEST(OS%Restart_control,1)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, .true., GV=OS%GV) - call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & - OS%dirs%restart_output_dir, .true.) - if (OS%use_ice_shelf) then - call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) - endif - endif - if (BTEST(OS%Restart_control,0)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV) - call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & - OS%dirs%restart_output_dir) - if (OS%use_ice_shelf) then - call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) - endif - endif - end if + if (BTEST(OS%Restart_control,1)) then + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, time_stamped=.true., GV=OS%GV) + call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & + OS%dirs%restart_output_dir, .true.) + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) + endif + endif + if (BTEST(OS%Restart_control,0)) then + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, GV=OS%GV) + call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & + OS%dirs%restart_output_dir) + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) + endif + endif + endif end subroutine ocean_model_restart ! NAME="ocean_model_restart" @@ -734,9 +742,11 @@ subroutine ocean_model_end(Ocean_sfc, Ocean_state, Time) call ocean_model_save_restart(Ocean_state, Time) call diag_mediator_end(Time, Ocean_state%diag, end_diag_manager=.true.) ! print time stats - call MOM_infra_end call MOM_end(Ocean_state%MOM_CSp) if (Ocean_state%use_ice_shelf) call ice_shelf_end(Ocean_state%Ice_shelf_CSp) + + ! This closes out the infrastructure, including clocks, I/O and message passing communicators. + call MOM_infra_end() end subroutine ocean_model_end !> ocean_model_save_restart causes restart files associated with the ocean to be @@ -765,7 +775,7 @@ subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) if (present(directory)) then ; restart_dir = directory else ; restart_dir = OS%dirs%restart_output_dir ; endif - call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, restart_dir, Time, OS%grid, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, Time, restart_dir) @@ -798,7 +808,7 @@ subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, maskmap, call mpp_get_layout(input_domain,layout) call mpp_get_global_domain(input_domain, xsize=xsz, ysize=ysz) - if(PRESENT(maskmap)) then + if (PRESENT(maskmap)) then call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain, maskmap=maskmap) else call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain) @@ -872,22 +882,22 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_ if (sfc_state%T_is_conT) then ! Convert the surface T from conservative T to potential T. do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%t_surf(i,j) = gsw_pt_from_ct(sfc_state%SSS(i+i0,j+j0), & - sfc_state%SST(i+i0,j+j0)) + CELSIUS_KELVIN_OFFSET + Ocean_sfc%t_surf(i,j) = gsw_pt_from_ct(US%S_to_ppt*sfc_state%SSS(i+i0,j+j0), & + US%C_to_degC*sfc_state%SST(i+i0,j+j0)) + CELSIUS_KELVIN_OFFSET enddo ; enddo else do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%t_surf(i,j) = sfc_state%SST(i+i0,j+j0) + CELSIUS_KELVIN_OFFSET + Ocean_sfc%t_surf(i,j) = US%C_to_degC*sfc_state%SST(i+i0,j+j0) + CELSIUS_KELVIN_OFFSET enddo ; enddo endif if (sfc_state%S_is_absS) then ! Convert the surface S from absolute salinity to practical salinity. do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%s_surf(i,j) = gsw_sp_from_sr(sfc_state%SSS(i+i0,j+j0)) + Ocean_sfc%s_surf(i,j) = gsw_sp_from_sr(US%S_to_ppt*sfc_state%SSS(i+i0,j+j0)) enddo ; enddo else do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%s_surf(i,j) = sfc_state%SSS(i+i0,j+j0) + Ocean_sfc%s_surf(i,j) = US%S_to_ppt*sfc_state%SSS(i+i0,j+j0) enddo ; enddo endif @@ -973,6 +983,9 @@ subroutine ocean_model_init_sfc(OS, Ocean_sfc) call extract_surface_state(OS%MOM_CSp, OS%sfc_state) + if (OS%use_ice_shelf .and. allocated(OS%sfc_state%frazil)) & + call adjust_ice_sheet_frazil(OS%sfc_state, OS%fluxes, OS%Ice_shelf_CSp) + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US) end subroutine ocean_model_init_sfc @@ -1033,7 +1046,7 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) case (ISTOCK_HEAT) ! Return the heat content of the ocean in J. call get_ocean_stocks(OS%MOM_CSp, heat=value, on_PE_only=.true.) case (ISTOCK_SALT) ! Return the mass of the salt in the ocean in kg. - call get_ocean_stocks(OS%MOM_CSp, salt=value, on_PE_only=.true.) + call get_ocean_stocks(OS%MOM_CSp, salt=value, on_PE_only=.true.) case default ; value = 0.0 end select ! If the FMS coupler is changed so that Ocean_stock_PE is only called on diff --git a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 b/config_src/drivers/STALE_mct_cap/mom_surface_forcing_mct.F90 similarity index 86% rename from config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 rename to config_src/drivers/STALE_mct_cap/mom_surface_forcing_mct.F90 index 7b32270b4c..bc193face8 100644 --- a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 +++ b/config_src/drivers/STALE_mct_cap/mom_surface_forcing_mct.F90 @@ -1,26 +1,35 @@ -module MOM_surface_forcing_mct +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 -! This file is part of MOM6. See LICENSE.md for the license. +module MOM_surface_forcing_mct use MOM_coms, only : reproducing_sum, field_chksum use MOM_constants, only : hlv, hlf +use MOM_coupler_types, only : coupler_2d_bc_type, coupler_type_write_chksums +use MOM_coupler_types, only : coupler_type_initialized, coupler_type_spawn +use MOM_coupler_types, only : coupler_type_copy_data use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_SUBCOMPONENT +use MOM_data_override, only : data_override_init, data_override use MOM_diag_mediator, only : diag_ctrl use MOM_diag_mediator, only : safe_alloc_ptr, time_type use MOM_domains, only : pass_vector, pass_var, fill_symmetric_edges -use MOM_domains, only : global_field_sum, BITWISE_EXACT_SUM use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All use MOM_domains, only : To_North, To_East, Omit_Corners use MOM_error_handler, only : MOM_error, WARNING, FATAL, is_root_pe, MOM_mesg -use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing, mech_forcing use MOM_forcing_type, only : forcing_diags, mech_forcing_diags, register_forcing_type_diags use MOM_forcing_type, only : allocate_forcing_type, deallocate_forcing_type use MOM_forcing_type, only : allocate_mech_forcing, deallocate_mech_forcing use MOM_get_input, only : Get_MOM_Input, directories use MOM_grid, only : ocean_grid_type +use MOM_interpolate, only : init_external_field, time_interp_external +use MOM_interpolate, only : time_interp_external_init +use MOM_interpolate, only : external_field use MOM_io, only : slasher, write_version_number, MOM_read_data +use MOM_io, only : stdout use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS use MOM_restart, only : restart_init_end, save_restart, restore_state use MOM_string_functions, only : uppercase @@ -29,15 +38,6 @@ module MOM_surface_forcing_mct use MOM_variables, only : surface use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init use user_revise_forcing, only : user_revise_forcing_CS - -use coupler_types_mod, only : coupler_2d_bc_type, coupler_type_write_chksums -use coupler_types_mod, only : coupler_type_initialized, coupler_type_spawn -use coupler_types_mod, only : coupler_type_copy_data -use data_override_mod, only : data_override_init, data_override -use mpp_mod, only : mpp_chksum -use time_interp_external_mod, only : init_external_field, time_interp_external -use time_interp_external_mod, only : time_interp_external_init -use MOM_io, only : stdout use iso_fortran_env, only : int64 implicit none ; private @@ -65,7 +65,7 @@ module MOM_surface_forcing_mct real :: wind_stress_multiplier!< A multiplier applied to incoming wind stress (nondim). real :: Rho0 !< Boussinesq reference density [R ~> kg m-3] - real :: area_surf = -1.0 !< total ocean surface area [m2] + real :: area_surf = -1.0 !< total ocean surface area [L2 ~> m2] real :: latent_heat_fusion !< latent heat of fusion [J kg-1] real :: latent_heat_vapor !< latent heat of vaporization [J kg-1] @@ -79,14 +79,14 @@ module MOM_surface_forcing_mct !! the correction for the atmospheric (and sea-ice) !! pressure limited by max_p_surf instead of the !! full atmospheric pressure. The default is true. - real :: gust_const !< constant unresolved background gustiness for ustar [R L Z T-1 ~> Pa] + real :: gust_const !< constant unresolved background gustiness for ustar [R L Z T-2 ~> Pa] logical :: read_gust_2d !< If true, use a 2-dimensional gustiness supplied !! from an input file. real, pointer, dimension(:,:) :: & TKE_tidal => NULL(), & !< turbulent kinetic energy introduced to the !! bottom boundary layer by drag on the tidal flows [R Z3 T-3 ~> W m-2] gust => NULL(), & !< spatially varying unresolved background - !! gustiness that contributes to ustar [R L Z T-1 ~> Pa]. + !! gustiness that contributes to ustar [R L Z T-2 ~> Pa]. !! gust is used when read_gust_2d is true. ustar_tidal => NULL() !< tidal contribution to the bottom friction velocity [Z T-1 ~> m s-1] real :: cd_tides !< drag coefficient that applies to the tides (nondimensional) @@ -116,10 +116,10 @@ module MOM_surface_forcing_mct real :: ice_salt_concentration !< salt concentration for sea ice [kg/kg] logical :: mask_srestore_marginal_seas !< if true, then mask SSS restoring in marginal seas - real :: max_delta_srestore !< maximum delta salinity used for restoring - real :: max_delta_trestore !< maximum delta sst used for restoring + real :: max_delta_srestore !< maximum delta salinity used for restoring [S ~> ppt] + real :: max_delta_trestore !< maximum delta sst used for restoring [C ~> degC] real, pointer, dimension(:,:) :: basin_mask => NULL() !< mask for SSS restoring by basin - logical :: fix_ustar_gustless_bug !< If true correct a bug in the time-averaging of the + logical :: ustar_gustless_bug !< If true, include a bug in the time-averaging of the !! gustless wind friction velocity. type(diag_ctrl), pointer :: diag !< structure to regulate diagnostic output timing character(len=200) :: inputdir !< directory where NetCDF input files are @@ -137,8 +137,10 @@ module MOM_surface_forcing_mct !! in inputdir/temp_restore_mask.nc and the field should !! be named 'mask' real, pointer, dimension(:,:) :: trestore_mask => NULL() !< mask for SST restoring - integer :: id_srestore = -1 !< id number for time_interp_external. - integer :: id_trestore = -1 !< id number for time_interp_external. + type(external_field) :: srestore_handle + !< Handle for time-interpolated salt restoration field + type(external_field) :: trestore_handle + !< Handle for time-interpolated temperature restoration field type(forcing_diags), public :: handles !< diagnostics handles type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< restart pointer @@ -209,7 +211,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, type(time_type), intent(in) :: Time !< The time of the fluxes, used for interpolating the !! salinity to the right time, when it is being restored. real, intent(in) :: valid_time !< The amount of time over which these fluxes - !! should be applied [s]. + !! should be applied [T ~> s]. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a @@ -221,17 +223,13 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! local variables real, dimension(SZI_(G),SZJ_(G)) :: & - data_restore, & !< The surface value toward which to restore [g/kg or degC] - SST_anom, & !< Instantaneous sea surface temperature anomalies from a target value [deg C] - SSS_anom, & !< Instantaneous sea surface salinity anomalies from a target value [g/kg] - SSS_mean, & !< A (mean?) salinity about which to normalize local salinity - !! anomalies when calculating restorative precipitation anomalies [g/kg] + data_restore, & !< The surface value toward which to restore [S ~> ppt] or [C ~> degC] PmE_adj, & !< The adjustment to PminusE that will cause the salinity !! to be restored toward its target value [kg/(m^2 * s)] - net_FW, & !< The area integrated net freshwater flux into the ocean [kg/s] - net_FW2, & !< The area integrated net freshwater flux into the ocean [kg/s] + net_FW, & !< The area integrated net freshwater flux into the ocean [R Z L2 T-1 ~> kg s-1] + net_FW2, & !< The area averaged net freshwater flux into the ocean [R Z T-1 ~> kg m-2 s-1] work_sum, & !< A 2-d array that is used as the work space for a global - !! sum, used with units of m2 or [kg/s] + !! sum, used with units of [L2 ~> m2] or [R Z L2 T-1 ~> kg s-1] open_ocn_mask !< a binary field indicating where ice is present based on frazil criteria integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 @@ -242,8 +240,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, !! is present, or false (no restoring) otherwise. logical :: restore_sst !< local copy of the argument restore_temp, if it !! is present, or false (no restoring) otherwise. - real :: delta_sss !< temporary storage for sss diff from restoring value - real :: delta_sst !< temporary storage for sst diff from restoring value + real :: delta_sss !< temporary storage for sss diff from restoring value [S ~> ppt] + real :: delta_sst !< temporary storage for sst diff from restoring value [C ~> degC] real :: kg_m2_s_conversion !< A combination of unit conversion factors for rescaling !! mass fluxes [R Z s m2 kg-1 T-1 ~> 1]. @@ -261,7 +259,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 kg_m2_s_conversion = US%kg_m2s_to_RZ_T - C_p = US%Q_to_J_kg*fluxes%C_p + C_p = US%Q_to_J_kg*US%degC_to_C*fluxes%C_p open_ocn_mask(:,:) = 1.0 pme_adj(:,:) = 0.0 fluxes%vPrecGlobalAdj = 0.0 @@ -280,7 +278,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! flux type has been used. if (fluxes%dt_buoy_accum < 0) then call allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.true., & - press=.true., fix_accum_bug=CS%fix_ustar_gustless_bug) + press=.true., fix_accum_bug=.not.CS%ustar_gustless_bug, tau_mag=.true.) call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) @@ -290,16 +288,16 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call safe_alloc_ptr(fluxes%p_surf,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%p_surf_full,isd,ied,jsd,jed) if (CS%use_limited_P_SSH) then - fluxes%p_surf_SSH => fluxes%p_surf + fluxes%p_surf_SSH => fluxes%p_surf else - fluxes%p_surf_SSH => fluxes%p_surf_full + fluxes%p_surf_SSH => fluxes%p_surf_full endif call safe_alloc_ptr(fluxes%salt_flux,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%salt_flux_in,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%TKE_tidal,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%BBL_tidal_dis,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%ustar_tidal,isd,ied,jsd,jed) if (CS%allow_flux_adjustments) then @@ -308,9 +306,9 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, endif do j=js-2,je+2 ; do i=is-2,ie+2 - fluxes%TKE_tidal(i,j) = CS%TKE_tidal(i,j) + fluxes%BBL_tidal_dis(i,j) = US%Z_to_L**2*CS%TKE_tidal(i,j) fluxes%ustar_tidal(i,j) = CS%ustar_tidal(i,j) - enddo; enddo + enddo ; enddo if (restore_temp) call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) @@ -333,15 +331,15 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! allocation and initialization on first call to this routine if (CS%area_surf < 0.0) then do j=js,je ; do i=is,ie - work_sum(i,j) = US%L_to_m**2*G%areaT(i,j) * G%mask2dT(i,j) - enddo; enddo - CS%area_surf = reproducing_sum(work_sum, isr, ier, jsr, jer) + work_sum(i,j) = G%areaT(i,j) * G%mask2dT(i,j) + enddo ; enddo + CS%area_surf = reproducing_sum(work_sum, isr, ier, jsr, jer, unscale=US%L_to_m**2) endif ! endif for allocation and initialization ! Indicate that there are new unused fluxes. fluxes%fluxes_used = .false. - fluxes%dt_buoy_accum = US%s_to_T*valid_time + fluxes%dt_buoy_accum = valid_time if (CS%allow_flux_adjustments) then fluxes%heat_added(:,:) = 0.0 @@ -351,60 +349,60 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, do j=js,je ; do i=is,ie fluxes%salt_flux(i,j) = 0.0 fluxes%vprec(i,j) = 0.0 - enddo; enddo + enddo ; enddo ! Salinity restoring logic if (restore_salinity) then - call time_interp_external(CS%id_srestore,Time,data_restore) + call time_interp_external(CS%srestore_handle, Time, data_restore, scale=US%ppt_to_S) ! open_ocn_mask indicates where to restore salinity (1 means restore, 0 does not) open_ocn_mask(:,:) = 1.0 if (CS%mask_srestore_under_ice) then ! Do not restore under sea-ice do j=js,je ; do i=is,ie - if (sfc_state%SST(i,j) <= -0.0539*sfc_state%SSS(i,j)) open_ocn_mask(i,j)=0.0 - enddo; enddo + if (sfc_state%SST(i,j) <= -0.0539*US%degC_to_C*US%S_to_ppt*sfc_state%SSS(i,j)) open_ocn_mask(i,j)=0.0 + enddo ; enddo endif if (CS%salt_restore_as_sflux) then do j=js,je ; do i=is,ie - delta_sss = data_restore(i,j)- sfc_state%SSS(i,j) + delta_sss = data_restore(i,j) - sfc_state%SSS(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) - fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)* & + fluxes%salt_flux(i,j) = 1.e-3*US%S_to_ppt*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)* & (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) *delta_sss ! R Z T-1 ~> kg Salt m-2 s-1 - enddo; enddo + enddo ; enddo if (CS%adjust_net_srestore_to_zero) then if (CS%adjust_net_srestore_by_scaling) then call adjust_area_mean_to_zero(fluxes%salt_flux, G, fluxes%saltFluxGlobalScl, & unit_scale=US%RZ_T_to_kg_m2s) fluxes%saltFluxGlobalAdj = 0. else - work_sum(is:ie,js:je) = US%L_to_m**2*US%RZ_T_to_kg_m2s * & - G%areaT(is:ie,js:je)*fluxes%salt_flux(is:ie,js:je) - fluxes%saltFluxGlobalAdj = reproducing_sum(work_sum(:,:), isr,ier, jsr,jer)/CS%area_surf - fluxes%salt_flux(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) - kg_m2_s_conversion * fluxes%saltFluxGlobalAdj + work_sum(is:ie,js:je) = G%areaT(is:ie,js:je) * fluxes%salt_flux(is:ie,js:je) + fluxes%saltFluxGlobalAdj = reproducing_sum(work_sum(:,:), isr,ier, jsr,jer, unscale=US%RZL2_to_kg*US%s_to_T) & + / CS%area_surf + fluxes%salt_flux(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) - fluxes%saltFluxGlobalAdj endif endif fluxes%salt_flux_added(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) ! Diagnostic else do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & (CS%Rho0*CS%Flux_const) * & delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) endif - enddo; enddo + enddo ; enddo if (CS%adjust_net_srestore_to_zero) then if (CS%adjust_net_srestore_by_scaling) then call adjust_area_mean_to_zero(fluxes%vprec, G, fluxes%vPrecGlobalScl, & unit_scale=US%RZ_T_to_kg_m2s) fluxes%vPrecGlobalAdj = 0. else - work_sum(is:ie,js:je) = US%L_to_m**2*G%areaT(is:ie,js:je) * & - US%RZ_T_to_kg_m2s*fluxes%vprec(is:ie,js:je) - fluxes%vPrecGlobalAdj = reproducing_sum(work_sum(:,:), isr, ier, jsr, jer) / CS%area_surf + work_sum(is:ie,js:je) = G%areaT(is:ie,js:je) * fluxes%vprec(is:ie,js:je) + fluxes%vPrecGlobalAdj = reproducing_sum(work_sum(:,:), isr, ier, jsr, jer, unscale=US%RZL2_to_kg*US%s_to_T) & + / CS%area_surf do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - kg_m2_s_conversion*fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) - enddo; enddo + fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) + enddo ; enddo endif endif endif @@ -412,17 +410,17 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! SST restoring logic if (restore_sst) then - call time_interp_external(CS%id_trestore,Time,data_restore) + call time_interp_external(CS%trestore_handle, Time, data_restore, scale=US%degC_to_C) do j=js,je ; do i=is,ie - delta_sst = data_restore(i,j)- sfc_state%SST(i,j) + delta_sst = data_restore(i,j) - sfc_state%SST(i,j) delta_sst = sign(1.0,delta_sst)*min(abs(delta_sst),CS%max_delta_trestore) fluxes%heat_added(i,j) = G%mask2dT(i,j) * CS%trestore_mask(i,j) * & (CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 - enddo; enddo + enddo ; enddo endif ! obtain fluxes from IOB; note the staggering of indices - i0 = 0; j0 = 0 + i0 = 0 ; j0 = 0 do j=js,je ; do i=is,ie ! liquid precipitation (rain) if (associated(IOB%lprec)) & @@ -438,26 +436,26 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! liquid runoff flux if (associated(IOB%rofl_flux)) then - fluxes%lrunoff(i,j) = kg_m2_s_conversion * IOB%rofl_flux(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%lrunoff(i,j) = kg_m2_s_conversion * IOB%rofl_flux(i-i0,j-j0) * G%mask2dT(i,j) else if (associated(IOB%runoff)) then - fluxes%lrunoff(i,j) = kg_m2_s_conversion * IOB%runoff(i-i0,j-j0) * G%mask2dT(i,j) - end if + fluxes%lrunoff(i,j) = kg_m2_s_conversion * IOB%runoff(i-i0,j-j0) * G%mask2dT(i,j) + endif ! ice runoff flux if (associated(IOB%rofi_flux)) then - fluxes%frunoff(i,j) = kg_m2_s_conversion * IOB%rofi_flux(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%frunoff(i,j) = kg_m2_s_conversion * IOB%rofi_flux(i-i0,j-j0) * G%mask2dT(i,j) else if (associated(IOB%calving)) then - fluxes%frunoff(i,j) = kg_m2_s_conversion * IOB%calving(i-i0,j-j0) * G%mask2dT(i,j) - end if + fluxes%frunoff(i,j) = kg_m2_s_conversion * IOB%calving(i-i0,j-j0) * G%mask2dT(i,j) + endif if (associated(IOB%ustar_berg)) & - fluxes%ustar_berg(i,j) = US%m_to_Z * IOB%ustar_berg(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%ustar_berg(i,j) = US%m_to_Z*US%T_to_s * IOB%ustar_berg(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%area_berg)) & - fluxes%area_berg(i,j) = IOB%area_berg(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%area_berg(i,j) = IOB%area_berg(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%mass_berg)) & - fluxes%mass_berg(i,j) = US%m_to_Z*US%kg_m3_to_R * IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%mass_berg(i,j) = US%m_to_Z*US%kg_m3_to_R * IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) ! GMM, cime does not not have an equivalent for heat_content_lrunoff and ! heat_content_frunoff. I am setting these to zero for now. @@ -479,7 +477,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! sea ice and snow melt heat flux [W/m2] if (associated(IOB%seaice_melt_heat)) & - fluxes%seaice_melt_heat(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * IOB%seaice_melt_heat(i-i0,j-j0) + fluxes%seaice_melt_heat(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * IOB%seaice_melt_heat(i-i0,j-j0) ! water flux due to sea ice and snow melt [kg/m2/s] if (associated(IOB%seaice_melt)) & @@ -523,22 +521,22 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%sw(i,j) = fluxes%sw_vis_dir(i,j) + fluxes%sw_vis_dif(i,j) + & fluxes%sw_nir_dir(i,j) + fluxes%sw_nir_dif(i,j) - enddo; enddo + enddo ; enddo ! applied surface pressure from atmosphere and cryosphere if (associated(IOB%p)) then - if (CS%max_p_surf >= 0.0) then - do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) - fluxes%p_surf(i,j) = MIN(fluxes%p_surf_full(i,j),CS%max_p_surf) - enddo; enddo - else - do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) - fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) - enddo; enddo - endif - fluxes%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. + if (CS%max_p_surf >= 0.0) then + do j=js,je ; do i=is,ie + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + fluxes%p_surf(i,j) = MIN(fluxes%p_surf_full(i,j),CS%max_p_surf) + enddo ; enddo + else + do j=js,je ; do i=is,ie + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) + enddo ; enddo + endif + fluxes%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. endif if (associated(IOB%salt_flux)) then @@ -553,25 +551,25 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, sign_for_net_FW_bug = 1. if (CS%use_net_FW_adjustment_sign_bug) sign_for_net_FW_bug = -1. do j=js,je ; do i=is,ie - net_FW(i,j) = US%RZ_T_to_kg_m2s * & - (((fluxes%lprec(i,j) + fluxes%fprec(i,j) + fluxes%seaice_melt(i,j)) + & - (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j))) + & - (fluxes%evap(i,j) + fluxes%vprec(i,j)) ) * US%L_to_m**2*G%areaT(i,j) + net_FW(i,j) = (((fluxes%lprec(i,j) + fluxes%fprec(i,j) + fluxes%seaice_melt(i,j)) + & + (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j))) + & + (fluxes%evap(i,j) + fluxes%vprec(i,j)) ) * G%areaT(i,j) - net_FW2(i,j) = net_FW(i,j) / (US%L_to_m**2*G%areaT(i,j)) - enddo; enddo + net_FW2(i,j) = net_FW(i,j) / G%areaT(i,j) + enddo ; enddo if (CS%adjust_net_fresh_water_by_scaling) then - call adjust_area_mean_to_zero(net_FW2, G, fluxes%netFWGlobalScl) + call adjust_area_mean_to_zero(net_FW2, G, fluxes%netFWGlobalScl, unscale=US%RZ_T_to_kg_m2s) do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = fluxes%vprec(i,j) + kg_m2_s_conversion * & - (net_FW2(i,j) - net_FW(i,j)/(US%L_to_m**2*G%areaT(i,j))) * G%mask2dT(i,j) - enddo; enddo + fluxes%vprec(i,j) = fluxes%vprec(i,j) + & + (net_FW2(i,j) - net_FW(i,j) / G%areaT(i,j)) * G%mask2dT(i,j) + enddo ; enddo else - fluxes%netFWGlobalAdj = reproducing_sum(net_FW(:,:), isr, ier, jsr, jer) / CS%area_surf + fluxes%netFWGlobalAdj = reproducing_sum(net_FW(:,:), isr, ier, jsr, jer, unscale=US%RZL2_to_kg*US%s_to_T) / & + CS%area_surf do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - kg_m2_s_conversion * fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) - enddo; enddo + fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) + enddo ; enddo endif endif @@ -643,7 +641,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 !i0 = is - isc_bnd ; j0 = js - jsc_bnd - i0 = 0; j0 = 0 + i0 = 0 ; j0 = 0 Irho0 = US%L_to_Z / CS%Rho0 Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z @@ -653,7 +651,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) ! mechanical forcing type has been used. if (.not.forces%initialized) then - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true., tau_mag=.true.) call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) @@ -681,9 +679,9 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) !applied surface pressure from atmosphere and cryosphere if (CS%use_limited_P_SSH) then - forces%p_surf_SSH => forces%p_surf + forces%p_surf_SSH => forces%p_surf else - forces%p_surf_SSH => forces%p_surf_full + forces%p_surf_SSH => forces%p_surf_full endif if (associated(IOB%p)) then if (CS%max_p_surf >= 0.0) then @@ -749,19 +747,19 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0.0) & forces%taux(I,j) = (G%mask2dBu(I,J)*taux_at_q(I,J) + & G%mask2dBu(I,J-1)*taux_at_q(I,J-1)) / & (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) - enddo; enddo + enddo ; enddo do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0.0) & forces%tauy(i,J) = (G%mask2dBu(I,J)*tauy_at_q(I,J) + & G%mask2dBu(I-1,J)*tauy_at_q(I-1,J)) / & (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) - enddo; enddo + enddo ; enddo ! ustar is required for the bulk mixed layer formulation. The background value ! of 0.02 Pa is a relatively small value intended to give reasonable behavior @@ -770,42 +768,44 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie tau_mag = 0.0 ; gustiness = CS%gust_const if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & - (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0) then - tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_at_q(I,J)**2 + tauy_at_q(I,J)**2) + & - G%mask2dBu(I-1,J-1)*(taux_at_q(I-1,J-1)**2 + tauy_at_q(I-1,J-1)**2)) + & - (G%mask2dBu(I,J-1)*(taux_at_q(I,J-1)**2 + tauy_at_q(I,J-1)**2) + & - G%mask2dBu(I-1,J)*(taux_at_q(I-1,J)**2 + tauy_at_q(I-1,J)**2)) ) / & + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0.0) then + tau_mag = sqrt(((G%mask2dBu(I,J)*((taux_at_q(I,J)**2) + (tauy_at_q(I,J)**2)) + & + G%mask2dBu(I-1,J-1)*((taux_at_q(I-1,J-1)**2) + (tauy_at_q(I-1,J-1)**2))) + & + (G%mask2dBu(I,J-1)*((taux_at_q(I,J-1)**2) + (tauy_at_q(I,J-1)**2)) + & + G%mask2dBu(I-1,J)*((taux_at_q(I-1,J)**2) + (tauy_at_q(I-1,J)**2))) ) / & ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) ) if (CS%read_gust_2d) gustiness = CS%gust(i,j) endif + forces%tau_mag(i,j) = US%L_to_Z*(gustiness + tau_mag) forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0*tau_mag) - enddo; enddo + enddo ; enddo elseif (wind_stagger == AGRID) then call pass_vector(taux_at_h, tauy_at_h, G%Domain, To_All+Omit_Corners, stagger=AGRID, halo=1) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0.0) & forces%taux(I,j) = (G%mask2dT(i,j)*taux_at_h(i,j) + & G%mask2dT(i+1,j)*taux_at_h(i+1,j)) / & (G%mask2dT(i,j) + G%mask2dT(i+1,j)) - enddo; enddo + enddo ; enddo do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0.0) & forces%tauy(i,J) = (G%mask2dT(i,j)*tauy_at_h(i,j) + & G%mask2dT(i,J+1)*tauy_at_h(i,j+1)) / & (G%mask2dT(i,j) + G%mask2dT(i,j+1)) - enddo; enddo + enddo ; enddo do j=js,je ; do i=is,ie gustiness = CS%gust_const - if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) + if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0.0)) gustiness = CS%gust(i,j) + forces%tau_mag(i,j) = US%L_to_Z*(gustiness + G%mask2dT(i,j) * sqrt((taux_at_h(i,j)**2) + (tauy_at_h(i,j)**2))) forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & - sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2)) - enddo; enddo + sqrt((taux_at_h(i,j)**2) + (tauy_at_h(i,j)**2))) + enddo ; enddo else ! C-grid wind stresses. if (G%symmetric) & @@ -814,21 +814,23 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie taux2 = 0.0 - if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0) & - taux2 = (G%mask2dCu(I-1,j)*forces%taux(I-1,j)**2 + & - G%mask2dCu(I,j)*forces%taux(I,j)**2) / (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) + if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0.0) & + taux2 = (G%mask2dCu(I-1,j)*(forces%taux(I-1,j)**2) + & + G%mask2dCu(I,j)*(forces%taux(I,j)**2)) / (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) tauy2 = 0.0 - if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & - tauy2 = (G%mask2dCv(i,J-1)*forces%tauy(i,J-1)**2 + & - G%mask2dCv(i,J)*forces%tauy(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) + if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0.0) & + tauy2 = (G%mask2dCv(i,J-1)*(forces%tauy(i,J-1)**2) + & + G%mask2dCv(i,J)*(forces%tauy(i,J)**2)) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) if (CS%read_gust_2d) then + forces%tau_mag(i,j) = US%L_to_Z*(CS%gust(i,j) + sqrt(taux2 + tauy2)) forces%ustar(i,j) = sqrt(CS%gust(i,j)*Irho0 + Irho0*sqrt(taux2 + tauy2)) else + forces%tau_mag(i,j) = US%L_to_Z*(CS%gust_const + sqrt(taux2 + tauy2)) forces%ustar(i,j) = sqrt(CS%gust_const*Irho0 + Irho0*sqrt(taux2 + tauy2)) endif - enddo; enddo + enddo ; enddo endif ! endif for wind related fields @@ -897,7 +899,7 @@ subroutine apply_flux_adjustments(G, US, CS, Time, fluxes) integer :: isc, iec, jsc, jec, i, j logical :: overrode_h - isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec overrode_h = .false. call data_override('OCN', 'hflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) @@ -947,7 +949,7 @@ subroutine apply_force_adjustments(G, US, CS, Time, forces) real :: Pa_conversion ! A unit conversion factor from Pa to the internal units [R Z L T-2 Pa-1 ~> 1] logical :: overrode_x, overrode_y - isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z tempx_at_h(:,:) = 0.0 ; tempy_at_h(:,:) = 0.0 @@ -1025,11 +1027,13 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, ! Local variables real :: utide ! The RMS tidal velocity [Z T-1 ~> m s-1]. type(directories) :: dirs - logical :: new_sim, iceberg_flux_diags + logical :: new_sim, iceberg_flux_diags, fix_ustar_gustless_bug + logical :: test_value ! This is used to determine whether a logical parameter is being set explicitly. + logical :: explicit_bug, explicit_fix ! These indicate which parameters are set explicitly. type(time_type) :: Time_frc character(len=200) :: TideAmp_file, gust_file, salt_file, temp_file ! Input file names. -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_surface_forcing_mct" ! This module's name. character(len=48) :: stagger character(len=48) :: flnam @@ -1064,7 +1068,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call get_param(param_file, mdl, "RHO_0", CS%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& + "properties, or with BOUSSINESQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & @@ -1126,7 +1130,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call get_param(param_file, mdl, "WIND_STRESS_MULTIPLIER", CS%wind_stress_multiplier, & "A factor multiplying the wind-stress given to the ocean by the "//& "coupler. This is used for testing and should be =1.0 for any "//& - "production runs.", default=1.0) + "production runs.", units="nondim", default=1.0) if (restore_salt) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & @@ -1146,7 +1150,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "flux instead of as a freshwater flux.", default=.false.) call get_param(param_file, mdl, "MAX_DELTA_SRESTORE", CS%max_delta_srestore, & "The maximum salinity difference used in restoring terms.", & - units="PSU or g kg-1", default=999.0) + units="PSU or g kg-1", default=999.0, scale=US%ppt_to_S) call get_param(param_file, mdl, "MASK_SRESTORE_UNDER_ICE", & CS%mask_srestore_under_ice, & "If true, disables SSS restoring under sea-ice based on a frazil "//& @@ -1188,7 +1192,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call get_param(param_file, mdl, "MAX_DELTA_TRESTORE", CS%max_delta_trestore, & "The maximum sst difference used in restoring terms.", & - units="degC ", default=999.0) + units="degC ", default=999.0, scale=US%degC_to_C) call get_param(param_file, mdl, "MASK_TRESTORE", CS%mask_trestore, & "If true, read a file (temp_restore_mask) containing "//& @@ -1223,13 +1227,13 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if (CS%read_TIDEAMP) then TideAmp_file = trim(CS%inputdir) // trim(TideAmp_file) call MOM_read_data(TideAmp_file,'tideamp',CS%TKE_tidal,G%domain,timelevel=1, scale=US%m_to_Z*US%T_to_s) - do j=jsd, jed; do i=isd, ied + do j=jsd,jed ; do i=isd,ied utide = CS%TKE_tidal(i,j) CS%TKE_tidal(i,j) = G%mask2dT(i,j)*CS%Rho0*CS%cd_tides*(utide*utide*utide) CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide enddo ; enddo else - do j=jsd,jed; do i=isd,ied + do j=jsd,jed ; do i=isd,ied utide = CS%utide CS%TKE_tidal(i,j) = CS%Rho0*CS%cd_tides*(utide*utide*utide) CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide @@ -1257,9 +1261,32 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call MOM_read_data(gust_file, 'gustiness', CS%gust, G%domain, timelevel=1, & scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) ! units in file should be Pa endif - call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", CS%fix_ustar_gustless_bug, & + + call get_param(param_file, mdl, "USTAR_GUSTLESS_BUG", CS%ustar_gustless_bug, & + "If true include a bug in the time-averaging of the gustless wind friction velocity", & + default=.false., do_not_log=.true.) + ! This is used to test whether USTAR_GUSTLESS_BUG is being actively set. + call get_param(param_file, mdl, "USTAR_GUSTLESS_BUG", test_value, default=.true., do_not_log=.true.) + explicit_bug = CS%ustar_gustless_bug .eqv. test_value + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", fix_ustar_gustless_bug, & "If true correct a bug in the time-averaging of the gustless wind friction velocity", & - default=.true.) + default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", test_value, default=.false., do_not_log=.true.) + explicit_fix = fix_ustar_gustless_bug .eqv. test_value + + if (explicit_bug .and. explicit_fix .and. (fix_ustar_gustless_bug .eqv. CS%ustar_gustless_bug)) then + ! USTAR_GUSTLESS_BUG is being explicitly set, and should not be changed. + call MOM_error(FATAL, "USTAR_GUSTLESS_BUG and FIX_USTAR_GUSTLESS_BUG are both being set "//& + "with inconsistent values. FIX_USTAR_GUSTLESS_BUG is an obsolete "//& + "parameter and should be removed.") + elseif (explicit_fix) then + call MOM_error(WARNING, "FIX_USTAR_GUSTLESS_BUG is an obsolete parameter. "//& + "Use USTAR_GUSTLESS_BUG instead (noting that it has the opposite sense).") + CS%ustar_gustless_bug = .not.fix_ustar_gustless_bug + endif + call log_param(param_file, mdl, "USTAR_GUSTLESS_BUG", CS%ustar_gustless_bug, & + "If true include a bug in the time-averaging of the gustless wind friction velocity", & + default=.false.) ! See whether sufficiently thick sea ice should be treated as rigid. call get_param(param_file, mdl, "USE_RIGID_SEA_ICE", CS%rigid_sea_ice, & @@ -1299,8 +1326,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if (present(restore_salt)) then ; if (restore_salt) then salt_file = trim(CS%inputdir) // trim(CS%salt_restore_file) - CS%id_srestore = init_external_field(salt_file, CS%salt_restore_var_name, domain=G%Domain%mpp_domain) - call safe_alloc_ptr(CS%srestore_mask,isd,ied,jsd,jed); CS%srestore_mask(:,:) = 1.0 + CS%srestore_handle = init_external_field(salt_file, CS%salt_restore_var_name, domain=G%Domain%mpp_domain) + call safe_alloc_ptr(CS%srestore_mask,isd,ied,jsd,jed) ; CS%srestore_mask(:,:) = 1.0 if (CS%mask_srestore) then ! read a 2-d file containing a mask for restoring fluxes flnam = trim(CS%inputdir) // 'salt_restore_mask.nc' call MOM_read_data(flnam,'mask', CS%srestore_mask, G%domain, timelevel=1) @@ -1309,8 +1336,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if (present(restore_temp)) then ; if (restore_temp) then temp_file = trim(CS%inputdir) // trim(CS%temp_restore_file) - CS%id_trestore = init_external_field(temp_file, CS%temp_restore_var_name, domain=G%Domain%mpp_domain) - call safe_alloc_ptr(CS%trestore_mask,isd,ied,jsd,jed); CS%trestore_mask(:,:) = 1.0 + CS%trestore_handle = init_external_field(temp_file, CS%temp_restore_var_name, domain=G%Domain%mpp_domain) + call safe_alloc_ptr(CS%trestore_mask,isd,ied,jsd,jed) ; CS%trestore_mask(:,:) = 1.0 if (CS%mask_trestore) then ! read a 2-d file containing a mask for restoring fluxes flnam = trim(CS%inputdir) // 'temp_restore_mask.nc' call MOM_read_data(flnam, 'mask', CS%trestore_mask, G%domain, timelevel=1) @@ -1376,7 +1403,7 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) chks = field_chksum( iobt%v_flux ) ; if (root) write(outunit,100) 'iobt%v_flux ', chks chks = field_chksum( iobt%t_flux ) ; if (root) write(outunit,100) 'iobt%t_flux ', chks chks = field_chksum( iobt%q_flux ) ; if (root) write(outunit,100) 'iobt%q_flux ', chks - chks = field_chksum( iobt%seaice_melt_heat); if (root) write(outunit,100) 'iobt%seaice_melt_heat', chks + chks = field_chksum( iobt%seaice_melt_heat) ; if (root) write(outunit,100) 'iobt%seaice_melt_heat', chks chks = field_chksum( iobt%seaice_melt) ; if (root) write(outunit,100) 'iobt%seaice_melt ', chks chks = field_chksum( iobt%salt_flux ) ; if (root) write(outunit,100) 'iobt%salt_flux ', chks chks = field_chksum( iobt%lw_flux ) ; if (root) write(outunit,100) 'iobt%lw_flux ', chks diff --git a/config_src/drivers/mct_cap/ocn_cap_methods.F90 b/config_src/drivers/STALE_mct_cap/ocn_cap_methods.F90 similarity index 98% rename from config_src/drivers/mct_cap/ocn_cap_methods.F90 rename to config_src/drivers/STALE_mct_cap/ocn_cap_methods.F90 index 0b7a331458..372f4f32f0 100644 --- a/config_src/drivers/mct_cap/ocn_cap_methods.F90 +++ b/config_src/drivers/STALE_mct_cap/ocn_cap_methods.F90 @@ -1,3 +1,7 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + module ocn_cap_methods use ESMF, only: ESMF_clock, ESMF_time, ESMF_ClockGet, ESMF_TimeGet @@ -40,7 +44,7 @@ subroutine ocn_import(x2o, ind, grid, ice_ocean_boundary, ocean_public, logunit, character(*), parameter :: F01 = "('(ocn_import) ',a,4(i6,2x),d21.14)" !----------------------------------------------------------------------- - isc = GRID%isc; iec = GRID%iec ; jsc = GRID%jsc; jec = GRID%jec + isc = GRID%isc ; iec = GRID%iec ; jsc = GRID%jsc ; jec = GRID%jec k = 0 do j = jsc, jec @@ -232,7 +236,7 @@ subroutine ocn_export(ind, ocn_public, grid, o2x, dt_int, ncouple_per_day) endif sshx(i,j) = slope * grid%US%m_to_L*grid%IdxT(i,j) * grid%mask2dT(i,j) if (grid%mask2dT(i,j)==0.) sshx(i,j) = 0.0 - enddo; enddo + enddo ; enddo ! d/dy ssh do j=grid%jsc, grid%jec ; do i=grid%isc,grid%iec @@ -259,7 +263,7 @@ subroutine ocn_export(ind, ocn_public, grid, o2x, dt_int, ncouple_per_day) endif sshy(i,j) = slope * grid%US%m_to_L*grid%IdyT(i,j) * grid%mask2dT(i,j) if (grid%mask2dT(i,j)==0.) sshy(i,j) = 0.0 - enddo; enddo + enddo ; enddo ! rotate ssh gradients from local coordinates to true zonal/meridional (inverse transformation) n = 0 @@ -267,7 +271,7 @@ subroutine ocn_export(ind, ocn_public, grid, o2x, dt_int, ncouple_per_day) n = n+1 o2x(ind%o2x_So_dhdx, n) = grid%cos_rot(i,j) * sshx(i,j) + grid%sin_rot(i,j) * sshy(i,j) o2x(ind%o2x_So_dhdy, n) = grid%cos_rot(i,j) * sshy(i,j) - grid%sin_rot(i,j) * sshx(i,j) - enddo; enddo + enddo ; enddo end subroutine ocn_export diff --git a/config_src/drivers/mct_cap/ocn_comp_mct.F90 b/config_src/drivers/STALE_mct_cap/ocn_comp_mct.F90 similarity index 97% rename from config_src/drivers/mct_cap/ocn_comp_mct.F90 rename to config_src/drivers/STALE_mct_cap/ocn_comp_mct.F90 index 2f7deaa716..d55d70c116 100644 --- a/config_src/drivers/mct_cap/ocn_comp_mct.F90 +++ b/config_src/drivers/STALE_mct_cap/ocn_comp_mct.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> This is the main driver for MOM6 in CIME module ocn_comp_mct -! This file is part of MOM6. See LICENSE.md for the license. - ! mct modules use ESMF, only: ESMF_clock, ESMF_time, ESMF_timeInterval use ESMF, only: ESMF_ClockGet, ESMF_TimeGet, ESMF_TimeIntervalGet @@ -29,7 +31,7 @@ module ocn_comp_mct use MOM_variables, only: surface use MOM_domains, only: MOM_infra_init use MOM_restart, only: save_restart -use MOM_ice_shelf, only: ice_shelf_save_restart +use MOM_ice_shelf, only: ice_shelf_save_restart, adjust_ice_sheet_frazil use MOM_domains, only: num_pes, root_pe, pe_here use MOM_grid, only: ocean_grid_type, get_global_grid_size use MOM_error_handler, only: MOM_error, FATAL, is_root_pe, WARNING @@ -51,18 +53,15 @@ module ocn_comp_mct use MOM_surface_forcing_mct, only: surface_forcing_CS, forcing_save_restart, ice_ocean_boundary_type use ocn_cap_methods, only: ocn_import, ocn_export -! FMS modules -use time_interp_external_mod, only : time_interp_external - ! MCT indices structure and import and export routines that access mom data use ocn_cpl_indices, only : cpl_indices_type, cpl_indices_init ! GFDL coupler modules -use coupler_types_mod, only : coupler_type_spawn -use coupler_types_mod, only : coupler_type_initialized, coupler_type_copy_data +use MOM_coupler_types, only : coupler_type_spawn +use MOM_coupler_types, only : coupler_type_initialized, coupler_type_copy_data ! By default make data private -implicit none; private +implicit none ; private #include @@ -202,7 +201,7 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) ! set the shr log io unit number call shr_file_setLogUnit(stdout) - end if + endif call set_calendar_type(NOLEAP) !TODO: confirm this @@ -281,7 +280,7 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) "Coeff. used to convert net shortwave rad. into "//& "near-IR, diffuse shortwave.", units="nondim", default=0.215) else - glb%c1 = 0.0; glb%c2 = 0.0; glb%c3 = 0.0; glb%c4 = 0.0 + glb%c1 = 0.0 ; glb%c2 = 0.0 ; glb%c3 = 0.0 ; glb%c4 = 0.0 endif ! Close param file before it gets opened by ocean_model_init again. @@ -317,13 +316,13 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) close(nu) if (is_root_pe()) then write(stdout,*) 'Reading restart file(s): ',trim(restartfiles) - end if + endif call shr_file_freeUnit(nu) call ocean_model_init(glb%ocn_public, glb%ocn_state, time0, time_start, input_restart_file=trim(restartfiles)) endif if (is_root_pe()) then write(stdout,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========' - end if + endif ! Initialize ocn_state%sfc_state out of sight call ocean_model_init_sfc(glb%ocn_state, glb%ocn_public) @@ -385,14 +384,14 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) if (mom_cpl_dt /= ocn_cpl_dt) then write(stdout,*) 'ERROR mom_cpl_dt and ocn_cpl_dt must be identical' call exit(0) - end if + endif ! send initial state to driver !TODO: ! if ( lsend_precip_fact ) then ! call seq_infodata_PutData( infodata, precip_fact=precip_fact) - ! end if + ! endif if (debug .and. root_pe().eq.pe_here()) print *, "calling ocn_export" call ocn_export(glb%ind, glb%ocn_public, glb%grid, o2x_o%rattr, mom_cpl_dt, ncouple_per_day) @@ -404,10 +403,8 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) if (debug .and. root_pe().eq.pe_here()) print *, "calling seq_infodata_putdata" - call seq_infodata_PutData( glb%infodata, & - ocn_nx = ni , ocn_ny = nj) - call seq_infodata_PutData( glb%infodata, & - ocn_prognostic=.true., ocnrof_prognostic=.true.) + call seq_infodata_PutData(glb%infodata, ocn_nx=ni, ocn_ny=nj) + call seq_infodata_PutData(glb%infodata, ocn_prognostic=.true., ocnrof_prognostic=.true.) if (debug .and. root_pe().eq.pe_here()) print *, "leaving ocean_init_mct" @@ -415,7 +412,7 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) if (is_root_pe()) then call shr_file_setLogUnit (shrlogunit) call shr_file_setLogLevel(shrloglev) - end if + endif end subroutine ocn_init_mct @@ -491,10 +488,10 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) time_start = time_start-coupling_timestep ! double the first coupling interval (to account for the missing coupling interval to due to lag) coupling_timestep = coupling_timestep*2 - end if + endif firstCall = .false. - end if + endif ! Debugging clocks if (debug .and. is_root_pe()) then @@ -529,7 +526,7 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) c1=glb%c1, c2=glb%c2, c3=glb%c3, c4=glb%c4) else call ocn_import(x2o_o%rattr, glb%ind, glb%grid, Ice_ocean_boundary, glb%ocn_public, stdout, Eclock ) - end if + endif ! Update internal ocean call update_ocean_model(ice_ocean_boundary, glb%ocn_state, glb%ocn_public, time_start, coupling_timestep) @@ -754,16 +751,16 @@ end subroutine ocn_domain_mct call seq_infodata_GetData( glb%infodata, start_type=starttype) - if ( trim(starttype) == trim(seq_infodata_start_type_start)) then - get_runtype = "initial" + if ( trim(starttype) == trim(seq_infodata_start_type_start)) then + get_runtype = "initial" else if (trim(starttype) == trim(seq_infodata_start_type_cont) ) then - get_runtype = "continue" + get_runtype = "continue" else if (trim(starttype) == trim(seq_infodata_start_type_brnch)) then - get_runtype = "branch" + get_runtype = "branch" else - write(stdout,*) 'ocn_comp_mct ERROR: unknown starttype' - call exit(0) - end if + write(stdout,*) 'ocn_comp_mct ERROR: unknown starttype' + call exit(0) + endif return end function @@ -784,6 +781,9 @@ subroutine ocean_model_init_sfc(OS, Ocean_sfc) call extract_surface_state(OS%MOM_CSp, OS%sfc_state) + if (OS%use_ice_shelf .and. allocated(OS%sfc_state%frazil)) & + call adjust_ice_sheet_frazil(OS%sfc_state, OS%fluxes, OS%Ice_shelf_CSp) + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US) end subroutine ocean_model_init_sfc diff --git a/config_src/drivers/mct_cap/ocn_cpl_indices.F90 b/config_src/drivers/STALE_mct_cap/ocn_cpl_indices.F90 similarity index 95% rename from config_src/drivers/mct_cap/ocn_cpl_indices.F90 rename to config_src/drivers/STALE_mct_cap/ocn_cpl_indices.F90 index a701083c0c..68b6537662 100644 --- a/config_src/drivers/mct_cap/ocn_cpl_indices.F90 +++ b/config_src/drivers/STALE_mct_cap/ocn_cpl_indices.F90 @@ -1,3 +1,7 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + module ocn_cpl_indices use mct_mod, only: mct_avect_init, mct_avect_indexra, mct_aVect_clean, mct_aVect @@ -172,11 +176,11 @@ subroutine cpl_indices_init(ind) ind%x2o_qsw_fracr_col(ncol) = mct_avect_indexra(x2o,'Foxx_swnet_afracr') do ncat = 1, ice_ncat - write(cncat,'(i2.2)') ncat - ncol = ncat+1 - ind%x2o_frac_col(ncol) = mct_avect_indexra(x2o,'Si_ifrac_'//cncat) - ind%x2o_fracr_col(ncol) = ind%x2o_frac_col(ncol) - ind%x2o_qsw_fracr_col(ncol) = mct_avect_indexra(x2o,'PFioi_swpen_ifrac_'//cncat) + write(cncat,'(i2.2)') ncat + ncol = ncat+1 + ind%x2o_frac_col(ncol) = mct_avect_indexra(x2o,'Si_ifrac_'//cncat) + ind%x2o_fracr_col(ncol) = ind%x2o_frac_col(ncol) + ind%x2o_qsw_fracr_col(ncol) = mct_avect_indexra(x2o,'PFioi_swpen_ifrac_'//cncat) enddo else mcog_ncols = 1 diff --git a/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90 b/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90 index 5494954398..a8e11fbe34 100644 --- a/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90 +++ b/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90 @@ -1,9 +1,11 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> A dummy version of atmos_ocean_fluxes_mod module for !! use when the vastly larger FMS package is not needed. module atmos_ocean_fluxes_mod -! This file is part of MOM6. See LICENSE.md for the license. - implicit none ; private public :: aof_set_coupler_flux @@ -13,15 +15,19 @@ module atmos_ocean_fluxes_mod !> This subroutine duplicates an interface used by the FMS coupler, but only !! returns a value of -1. None of the arguments are used for anything. function aof_set_coupler_flux(name, flux_type, implementation, atm_tr_index, & - param, flag, ice_restart_file, ocean_restart_file, & + param, flag, mol_wt, ice_restart_file, ocean_restart_file, & units, caller, verbosity) result (coupler_index) character(len=*), intent(in) :: name !< An unused argument character(len=*), intent(in) :: flux_type !< An unused argument character(len=*), intent(in) :: implementation !< An unused argument integer, optional, intent(in) :: atm_tr_index !< An unused argument - real, dimension(:), optional, intent(in) :: param !< An unused argument + real, dimension(:), optional, intent(in) :: param !< An unused argument that would be used to + !! pass parameters for flux parameterizations + !! in other contexts [various] logical, dimension(:), optional, intent(in) :: flag !< An unused argument + real, optional, intent(in) :: mol_wt !< An unused argument that would usually be + !! the tracer's molecular weight [g mol-1] character(len=*), optional, intent(in) :: ice_restart_file !< An unused argument character(len=*), optional, intent(in) :: ocean_restart_file !< An unused argument character(len=*), optional, intent(in) :: units !< An unused argument diff --git a/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 index 959e4676d0..42444878ee 100644 --- a/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 @@ -1,6 +1,8 @@ -program Shelf_main +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 -! This file is part of MOM6. See LICENSE.md for the license. +program Shelf_main !********+*********+*********+*********+*********+*********+*********+** !* * @@ -24,9 +26,9 @@ program Shelf_main use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT use MOM_debugging, only : MOM_debugging_init - use MOM_diag_mediator, only : diag_mediator_init, diag_mediator_infrastructure_init - use MOM_diag_mediator, only : enable_averaging, disable_averaging, diag_mediator_end - use MOM_diag_mediator, only : diag_ctrl, diag_mediator_close_registration + use MOM_diag_mediator, only : diag_mediator_init, diag_mediator_infrastructure_init, set_axes_info + use MOM_diag_mediator, only : diag_mediator_end, diag_ctrl, diag_mediator_close_registration + use MOM_diag_manager_infra, only : diag_manager_set_time_end_infra use MOM_domains, only : MOM_infra_init, MOM_infra_end use MOM_domains, only : MOM_domains_init, clone_MOM_domain, pass_var use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid @@ -43,9 +45,10 @@ program Shelf_main use MOM_io, only : APPEND_FILE, READONLY_FILE, SINGLE_FILE use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : save_restart + use MOM_shared_initialization, only : write_ocean_geometry_file use MOM_string_functions,only : uppercase use MOM_time_manager, only : time_type, set_date, get_date - use MOM_time_manager, only : real_to_time, time_type_to_real + use MOM_time_manager, only : real_to_time, time_to_real use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) use MOM_time_manager, only : operator(>), operator(<), operator(>=) use MOM_time_manager, only : increment_date, set_calendar_type, month_name @@ -55,6 +58,8 @@ program Shelf_main use MOM_verticalGrid, only : verticalGrid_type, verticalGridInit, verticalGridEnd use MOM_write_cputime, only : write_cputime, MOM_write_cputime_init use MOM_write_cputime, only : write_cputime_start_clock, write_cputime_CS + use MOM_forcing_type, only : forcing + use MOM_ice_shelf_initialize, only : initialize_ice_SMB use MOM_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS use MOM_ice_shelf, only : ice_shelf_save_restart, solo_step_ice_shelf @@ -76,7 +81,9 @@ program Shelf_main ! CPU time limit. nmax is determined by evaluating the CPU time used between successive calls to ! write_cputime. Initially it is set to be very large. integer :: nmax=2000000000 - + ! A structure containing pointers to the thermodynamic forcing fields + ! at the ocean surface. + type(forcing) :: fluxes ! A structure containing several relevant directory paths. type(directories) :: dirs @@ -96,16 +103,16 @@ program Shelf_main type(time_type) :: time_chg ! An amount of time to adjust the segment_start_time ! and elapsed time to avoid roundoff problems. - real :: elapsed_time = 0.0 ! Elapsed time in this run [s]. + real :: elapsed_time = 0.0 ! Elapsed time in this run [T ~> s]. logical :: elapsed_time_master ! If true, elapsed time is used to set the ! model's master clock (Time). This is needed ! if Time_step_shelf is not an exact ! representation of time_step. - real :: time_step ! The time step [s] + real :: time_step ! The time step [T ~> s] ! A pointer to a structure containing metrics and related information. - type(ocean_grid_type), pointer :: ocn_grid + type(ocean_grid_type), pointer :: ocn_grid => NULL() type(dyn_horgrid_type), pointer :: dG => NULL() ! A dynamic version of the horizontal grid type(hor_index_type), pointer :: HI => NULL() ! A hor_index_type for array extents @@ -115,7 +122,7 @@ program Shelf_main type(ocean_OBC_type), pointer :: OBC => NULL() ! A pointer to a structure containing dimensional unit scaling factors. - type(unit_scale_type), pointer :: US + type(unit_scale_type), pointer :: US => NULL() type(diag_ctrl), pointer :: & diag => NULL() ! A pointer to the diagnostic regulatory structure @@ -140,7 +147,7 @@ program Shelf_main type(param_file_type) :: param_file ! The structure indicating the file(s) ! containing all run-time parameters. character(len=9) :: month - character(len=16) :: calendar = 'julian' + character(len=16) :: calendar = 'noleap' integer :: calendar_type=-1 integer :: unit, io_status, ierr @@ -185,6 +192,8 @@ program Shelf_main endif endif + ! Get the names of the I/O directories and initialization file. + ! Also calls the subroutine that opens run-time parameter files. call Get_MOM_Input(param_file, dirs) ! Read ocean_solo restart, which can override settings from the namelist. @@ -196,11 +205,11 @@ program Shelf_main call close_file(unit) else calendar = uppercase(calendar) - if (calendar(1:6) == 'JULIAN') then ; calendar_type = JULIAN - elseif (calendar(1:9) == 'GREGORIAN') then ; calendar_type = GREGORIAN - elseif (calendar(1:6) == 'NOLEAP') then ; calendar_type = NOLEAP - elseif (calendar(1:10)=='THIRTY_DAY') then ; calendar_type = THIRTY_DAY_MONTHS - elseif (calendar(1:11)=='NO_CALENDAR') then; calendar_type = NO_CALENDAR + if (calendar(1:6) == 'JULIAN') then ; calendar_type = JULIAN + elseif (calendar(1:9) == 'GREGORIAN') then ; calendar_type = GREGORIAN + elseif (calendar(1:6) == 'NOLEAP') then ; calendar_type = NOLEAP + elseif (calendar(1:10)=='THIRTY_DAY') then ; calendar_type = THIRTY_DAY_MONTHS + elseif (calendar(1:11)=='NO_CALENDAR') then ; calendar_type = NO_CALENDAR elseif (calendar(1:1) /= ' ') then call MOM_error(FATAL,'Shelf_driver: Invalid namelist value '//trim(calendar)//' for calendar') else @@ -211,8 +220,8 @@ program Shelf_main if (sum(date_init) > 0) then - Start_time = set_date(date_init(1),date_init(2), date_init(3), & - date_init(4),date_init(5),date_init(6)) + Start_time = set_date(date_init(1), date_init(2), date_init(3), & + date_init(4), date_init(5), date_init(6)) else Start_time = real_to_time(0.0) endif @@ -232,7 +241,7 @@ program Shelf_main call get_param(param_file, mod_name, "ICE_VELOCITY_TIMESTEP", time_step, & "The time step for changing forcing, coupling with other "//& "components, or potentially writing certain diagnostics.", & - units="s", fail_if_missing=.true.) + units="s", scale=US%s_to_T, fail_if_missing=.true.) if (sum(date) >= 0) then ! In this case, the segment starts at a time fixed by ocean_solo.res @@ -253,13 +262,19 @@ program Shelf_main ! Set up the ocean model domain and grid; the ice model grid is set in initialize_ice_shelf, ! but the grids have strong commonalities in this configuration, and the ocean grid is required ! to set up the diag mediator control structure. - call MOM_domains_init(ocn_grid%domain, param_file) + allocate(ocn_grid) + call MOM_domains_init(ocn_grid%domain, param_file) !, domain_name='MOM') + allocate(HI) call hor_index_init(ocn_grid%Domain, HI, param_file) + allocate(dG) call create_dyn_horgrid(dG, HI) call clone_MOM_domain(ocn_grid%Domain, dG%Domain) ! Initialize the ocean grid and topography. - call MOM_initialize_fixed(dG, US, OBC, param_file, .true., dirs%output_directory) + call MOM_initialize_fixed(dG, US, OBC, param_file) + ! Write out all of the grid data used by this run. + call write_ocean_geometry_file(dG, param_file, dirs%output_directory, US=US) + call MOM_grid_init(ocn_grid, param_file, US, HI) call copy_dyngrid_to_MOM_grid(dG, ocn_grid, US) call destroy_dyn_horgrid(dG) @@ -267,11 +282,17 @@ program Shelf_main ! Initialize the diag mediator. The ocean's vertical grid is not really used here, but at ! present the interface to diag_mediator_init assumes the presence of ocean-specific information. call verticalGridInit(param_file, GV, US) + allocate(diag) call diag_mediator_init(ocn_grid, GV, US, GV%ke, param_file, diag, doc_file_dir=dirs%output_directory) call callTree_waypoint("returned from diag_mediator_init()") - call initialize_ice_shelf(param_file, ocn_grid, Time, ice_shelf_CSp, diag) + call set_axes_info(ocn_grid, GV, US, param_file, diag) + + call initialize_ice_shelf(param_file, ocn_grid, Time, ice_shelf_CSp, diag, & + Start_time, dirs%output_directory, fluxes_in=fluxes, solo_ice_sheet_in=.true.) + + call initialize_ice_SMB(fluxes%shelf_sfc_mass_flux, ocn_grid, US, param_file) ! This is the end of the code that is the counterpart of MOM_initialization. call callTree_waypoint("End of ice shelf initialization.") @@ -282,8 +303,8 @@ program Shelf_main segment_start_time = Time elapsed_time = 0.0 - Time_step_shelf = real_to_time(time_step) - elapsed_time_master = (abs(time_step - time_type_to_real(Time_step_shelf)) > 1.0e-12*time_step) + Time_step_shelf = real_to_time(time_step, unscale=US%T_to_s) + elapsed_time_master = (abs(time_step - time_to_real(Time_step_shelf, scale=US%s_to_T)) > 1.0e-12*time_step) if (elapsed_time_master) & call MOM_mesg("Using real elapsed time for the master clock.", 2) @@ -310,6 +331,8 @@ program Shelf_main Time_end = daymax endif + call diag_manager_set_time_end_infra (Time_end) + if (Time >= Time_end) call MOM_error(FATAL, & "Shelf_driver: The run has been started at or after the end time of the run.") @@ -379,23 +402,23 @@ program Shelf_main ! This call steps the model over a time time_step. Time1 = Master_Time ; Time = Master_Time - call solo_step_ice_shelf(ice_shelf_CSp, Time_step_shelf, ns_ice, Time) + call solo_step_ice_shelf(ice_shelf_CSp, Time_step_shelf, ns_ice, Time, fluxes_in=fluxes) ! Time = Time + Time_step_shelf ! This is here to enable fractional-second time steps. elapsed_time = elapsed_time + time_step - if (elapsed_time > 2e9) then + if (elapsed_time > 2.0e9*US%s_to_T) then ! This is here to ensure that the conversion from a real to an integer can be accurately ! represented in long runs (longer than ~63 years). It will also ensure that elapsed time ! does not lose resolution of order the timetype's resolution, provided that the timestep and ! tick are larger than 10-5 seconds. If a clock with a finer resolution is used, a smaller ! value would be required. - time_chg = real_to_time(elapsed_time) + time_chg = real_to_time(elapsed_time, unscale=US%T_to_s) segment_start_time = segment_start_time + time_chg - elapsed_time = elapsed_time - time_type_to_real(time_chg) + elapsed_time = elapsed_time - time_to_real(time_chg, scale=US%s_to_T) endif if (elapsed_time_master) then - Master_Time = segment_start_time + real_to_time(elapsed_time) + Master_Time = segment_start_time + real_to_time(elapsed_time, unscale=US%T_to_s) else Master_Time = Master_Time + Time_step_shelf endif @@ -413,6 +436,20 @@ program Shelf_main if (BTEST(Restart_control,0)) then call ice_shelf_save_restart(ice_shelf_CSp, Time, dirs%restart_output_dir) endif + ! Write ice shelf solo restart file. + if (is_root_pe())then + call open_ASCII_file(unit, trim(dirs%restart_output_dir)//'shelf.res') + write(unit, '(i6,8x,a)') calendar_type, & + '(Calendar: no_calendar=0, thirty_day_months=1, julian=2, gregorian=3, noleap=4)' + + call get_date(Start_time, yr, mon, day, hr, mins, sec) + write(unit, '(6i6,8x,a)') yr, mon, day, hr, mins, sec, & + 'Model start time: year, month, day, hour, minute, second' + call get_date(Time, yr, mon, day, hr, mins, sec) + write(unit, '(6i6,8x,a)') yr, mon, day, hr, mins, sec, & + 'Current model time: year, month, day, hour, minute, second' + call close_file(unit) + endif restart_time = restart_time + restint endif @@ -457,12 +494,11 @@ program Shelf_main endif call callTree_waypoint("End Shelf_main") + call ice_shelf_end(ice_shelf_CSp) call diag_mediator_end(Time, diag, end_diag_manager=.true.) if (cpu_steps > 0) call write_cputime(Time, ns-1, write_CPU_CSp, call_end=.true.) call cpu_clock_end(termClock) call io_infra_end ; call MOM_infra_end - call ice_shelf_end(ice_shelf_CSp) - end program Shelf_main diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 174a659f12..cb689c9d1b 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -1,32 +1,26 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> This module contains a set of subroutines that are required by NUOPC. module MOM_cap_mod -use constants_mod, only: constants_init -use diag_manager_mod, only: diag_manager_init, diag_manager_end -use field_manager_mod, only: field_manager_init, field_manager_end -use fms_mod, only: fms_init, fms_end, open_namelist_file, check_nml_error -use fms_mod, only: close_file, file_exist, uppercase -use fms_io_mod, only: fms_io_exit -use mpp_domains_mod, only: domain2d, mpp_get_compute_domain, mpp_get_compute_domains +use MOM_domains, only: get_domain_extent +use MOM_io, only: stdout, io_infra_end +use mpp_domains_mod, only: mpp_get_compute_domains use mpp_domains_mod, only: mpp_get_ntile_count, mpp_get_pelist, mpp_get_global_domain use mpp_domains_mod, only: mpp_get_domain_npes -use mpp_io_mod, only: mpp_open, MPP_RDONLY, MPP_ASCII, MPP_OVERWR, MPP_APPEND, mpp_close, MPP_SINGLE -use mpp_mod, only: stdlog, stdout, mpp_root_pe, mpp_clock_id -use mpp_mod, only: mpp_clock_begin, mpp_clock_end, MPP_CLOCK_SYNC -use mpp_mod, only: MPP_CLOCK_DETAILED, CLOCK_COMPONENT, MAXPES -use time_manager_mod, only: set_calendar_type, time_type, increment_date -use time_manager_mod, only: set_time, set_date, get_time, get_date, month_name -use time_manager_mod, only: GREGORIAN, JULIAN, NOLEAP, THIRTY_DAY_MONTHS, NO_CALENDAR -use time_manager_mod, only: operator( <= ), operator( < ), operator( >= ) -use time_manager_mod, only: operator( + ), operator( - ), operator( / ) -use time_manager_mod, only: operator( * ), operator( /= ), operator( > ) -use time_manager_mod, only: date_to_string -use time_manager_mod, only: fms_get_calendar_type => get_calendar_type -use MOM_domains, only: MOM_infra_init, num_pes, root_pe, pe_here + +use MOM_time_manager, only: set_calendar_type, time_type, set_time, set_date +use MOM_time_manager, only: GREGORIAN, JULIAN, NOLEAP +use MOM_time_manager, only: operator( <= ), operator( < ), operator( >= ) +use MOM_time_manager, only: operator( + ), operator( - ), operator( / ) +use MOM_time_manager, only: operator( * ), operator( /= ), operator( > ) +use MOM_domains, only: MOM_infra_init, MOM_infra_end use MOM_file_parser, only: get_param, log_version, param_file_type, close_param_file use MOM_get_input, only: get_MOM_input, directories -use MOM_domains, only: pass_var +use MOM_domains, only: pass_var, pe_here use MOM_error_handler, only: MOM_error, FATAL, is_root_pe use MOM_grid, only: ocean_grid_type, get_global_grid_size use MOM_ocean_model_nuopc, only: ice_ocean_boundary_type @@ -38,12 +32,16 @@ module MOM_cap_mod use MOM_cap_methods, only: mom_import, mom_export, mom_set_geomtype, mod2med_areacor use MOM_cap_methods, only: med2mod_areacor, state_diagnose use MOM_cap_methods, only: ChkErr +use MOM_ensemble_manager, only: ensemble_manager_init +use MOM_coms, only: sum_across_PEs +! stub routines for CESMCOUPLED +use mom_cap_outputlog, only: outputlog_init, outputlog_run, outputlog_restart #ifdef CESMCOUPLED -use shr_file_mod, only: shr_file_setLogUnit, shr_file_getLogUnit -use shr_mpi_mod, only : shr_mpi_min, shr_mpi_max +use shr_log_mod, only: shr_log_setLogUnit +use nuopc_shr_methods, only: get_component_instance #endif -use time_utils_mod, only: esmf2fms_time +use time_utils_mod, only: esmf2fms_time use, intrinsic :: iso_fortran_env, only: output_unit @@ -80,6 +78,7 @@ module MOM_cap_mod use ESMF, only: ESMF_AlarmGet, ESMF_AlarmIsCreated, ESMF_ALARMLIST_ALL, ESMF_AlarmIsEnabled use ESMF, only: ESMF_STATEITEM_NOTFOUND, ESMF_FieldWrite use ESMF, only: ESMF_END_ABORT, ESMF_Finalize +use ESMF, only: ESMF_REDUCE_MAX, ESMF_REDUCE_MIN, ESMF_VMAllReduce use ESMF, only: operator(==), operator(/=), operator(+), operator(-) ! TODO ESMF_GridCompGetInternalState does not have an explicit Fortran interface. @@ -98,9 +97,13 @@ module MOM_cap_mod use NUOPC_Model, only: model_label_Finalize => label_Finalize use NUOPC_Model, only: SetVM -!$use omp_lib , only : omp_set_num_threads +use mom_inline_mod, only : mom_inline_init, mom_inline_run +#ifndef CESMCOUPLED +use shr_is_restart_fh_mod, only : init_is_restart_fh, is_restart_fh, is_restart_fh_type +#endif +use mom_cap_profiling, only: cap_profiling_init, cap_profiling -implicit none; private +implicit none ; private public SetServices public SetVM @@ -123,6 +126,8 @@ module MOM_cap_mod character(len=64) :: stdname character(len=64) :: shortname character(len=64) :: transferOffer + integer :: ungridded_lbound = 0 + integer :: ungridded_ubound = 0 end type fld_list_type integer,parameter :: fldsMax = 100 @@ -137,17 +142,19 @@ module MOM_cap_mod character(len=256) :: tmpstr logical :: write_diagnostics = .false. logical :: overwrite_timeslice = .false. +logical :: write_runtimelog = .false. character(len=32) :: runtype !< run type -integer :: logunit !< stdout logging unit number logical :: profile_memory = .true. logical :: grid_attach_area = .false. logical :: use_coldstart = .true. logical :: use_mommesh = .true. +logical :: set_missing_stks_to_zero = .false. +logical :: restart_eor = .false. +logical :: use_cdeps_inline = .false. character(len=128) :: scalar_field_name = '' integer :: scalar_field_count = 0 integer :: scalar_field_idx_grid_nx = 0 integer :: scalar_field_idx_grid_ny = 0 -integer :: nthrds !< number of openmp threads per task character(len=*),parameter :: u_FILE_u = & __FILE__ @@ -157,8 +164,13 @@ module MOM_cap_mod #else logical :: cesm_coupled = .false. type(ESMF_GeomType_Flag) :: geomtype +type(is_restart_fh_type) :: restartfh_info ! For flexible restarts in UFS #endif -character(len=8) :: restart_mode = 'alarms' +character(len=8) :: restart_mode = 'alarms' +character(len=16) :: inst_suffix = '' +logical :: pointer_date = .true. ! append date to rpointer +real(8) :: timere +integer :: localPet = -1 contains @@ -176,8 +188,18 @@ subroutine SetServices(gcomp, rc) ! local variables character(len=*),parameter :: subname='(MOM_cap:SetServices)' + type(ESMF_VM) :: vm + rc = ESMF_SUCCESS + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMGet(vm, localpet=localPet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (localPet == 0) call cap_profiling_init() + if (localPet == 0) call cap_profiling("mom", "SetServices", "B") + ! the NUOPC model component will register the generic methods call NUOPC_CompDerive(gcomp, model_routine_SS, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -214,9 +236,11 @@ subroutine SetServices(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Finalize, & - specRoutine=ocean_model_finalize, rc=rc) + specRoutine=ocean_model_finalize, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (localPet == 0) call cap_profiling("mom", "SetServices", "E") + end subroutine SetServices !> First initialize subroutine called by NUOPC. The purpose @@ -242,9 +266,12 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) integer :: iostat character(len=64) :: value, logmsg character(len=*),parameter :: subname='(MOM_cap:InitializeP0)' + type(ESMF_VM) :: vm rc = ESMF_SUCCESS + if (localPet == 0) call cap_profiling("mom", "InitializeP0", "B") + ! Switch to IPDv03 by filtering all other phaseMap entries call NUOPC_CompFilterPhaseMap(gcomp, ESMF_METHOD_INITIALIZE, & acceptStringList=(/"IPDv03p"/), rc=rc) @@ -259,6 +286,14 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) write(logmsg,*) write_diagnostics call ESMF_LogWrite('MOM_cap:DumpFields = '//trim(logmsg), ESMF_LOGMSG_INFO) + write_runtimelog = .false. + call NUOPC_CompAttributeGet(gcomp, name="RunTimeLog", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) write_runtimelog=(trim(value)=="true") + write(logmsg,*) write_runtimelog + call ESMF_LogWrite('MOM_cap:RunTimeLog = '//trim(logmsg), ESMF_LOGMSG_INFO) + overwrite_timeslice = .false. call NUOPC_CompAttributeGet(gcomp, name="OverwriteSlice", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) @@ -286,8 +321,8 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) call NUOPC_CompAttributeGet(gcomp, name='dbug_flag', value=value, isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - read(value,*) dbug - end if + read(value,*) dbug + endif write(logmsg,'(i6)') dbug call ESMF_LogWrite('MOM_cap:dbug = '//trim(logmsg), ESMF_LOGMSG_INFO) @@ -296,8 +331,8 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - scalar_field_name = trim(value) - call ESMF_LogWrite('MOM_cap:ScalarFieldName = '//trim(scalar_field_name), ESMF_LOGMSG_INFO) + scalar_field_name = trim(value) + call ESMF_LogWrite('MOM_cap:ScalarFieldName = '//trim(scalar_field_name), ESMF_LOGMSG_INFO) endif scalar_field_count = 0 @@ -305,15 +340,15 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - read(value, *, iostat=iostat) scalar_field_count - if (iostat /= 0) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//": ScalarFieldCount not an integer: "//trim(value), & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return - endif - write(logmsg,*) scalar_field_count - call ESMF_LogWrite('MOM_cap:ScalarFieldCount = '//trim(logmsg), ESMF_LOGMSG_INFO) + read(value, *, iostat=iostat) scalar_field_count + if (iostat /= 0) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//": ScalarFieldCount not an integer: "//trim(value), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + write(logmsg,*) scalar_field_count + call ESMF_LogWrite('MOM_cap:ScalarFieldCount = '//trim(logmsg), ESMF_LOGMSG_INFO) endif scalar_field_idx_grid_nx = 0 @@ -321,15 +356,15 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - read(value, *, iostat=iostat) scalar_field_idx_grid_nx - if (iostat /= 0) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//": ScalarFieldIdxGridNX not an integer: "//trim(value), & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return - endif - write(logmsg,*) scalar_field_idx_grid_nx - call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNX = '//trim(logmsg), ESMF_LOGMSG_INFO) + read(value, *, iostat=iostat) scalar_field_idx_grid_nx + if (iostat /= 0) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//": ScalarFieldIdxGridNX not an integer: "//trim(value), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + write(logmsg,*) scalar_field_idx_grid_nx + call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNX = '//trim(logmsg), ESMF_LOGMSG_INFO) endif scalar_field_idx_grid_ny = 0 @@ -337,15 +372,15 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - read(value, *, iostat=iostat) scalar_field_idx_grid_ny - if (iostat /= 0) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//": ScalarFieldIdxGridNY not an integer: "//trim(value), & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return - endif - write(logmsg,*) scalar_field_idx_grid_ny - call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNY = '//trim(logmsg), ESMF_LOGMSG_INFO) + read(value, *, iostat=iostat) scalar_field_idx_grid_ny + if (iostat /= 0) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//": ScalarFieldIdxGridNY not an integer: "//trim(value), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + write(logmsg,*) scalar_field_idx_grid_ny + call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNY = '//trim(logmsg), ESMF_LOGMSG_INFO) endif use_coldstart = .true. @@ -356,6 +391,14 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) write(logmsg,*) use_coldstart call ESMF_LogWrite('MOM_cap:use_coldstart = '//trim(logmsg), ESMF_LOGMSG_INFO) + set_missing_stks_to_zero = .false. + call NUOPC_CompAttributeGet(gcomp, name="set_missing_stks_to_zero", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) set_missing_stks_to_zero=(trim(value)=="true") + write(logmsg,*) set_missing_stks_to_zero + call ESMF_LogWrite('MOM_cap:set_missing_stks_to_zero = '//trim(logmsg), ESMF_LOGMSG_INFO) + use_mommesh = .true. call NUOPC_CompAttributeGet(gcomp, name="use_mommesh", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) @@ -364,17 +407,34 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) write(logmsg,*) use_mommesh call ESMF_LogWrite('MOM_cap:use_mommesh = '//trim(logmsg), ESMF_LOGMSG_INFO) - if(use_mommesh)then + if (use_mommesh) then geomtype = ESMF_GEOMTYPE_MESH call NUOPC_CompAttributeGet(gcomp, name='mesh_ocn', isPresent=isPresent, isSet=isSet, rc=rc) - if (.not. isPresent .and. .not. isSet) then - call ESMF_LogWrite('geomtype set to mesh but mesh_ocn is not specified', ESMF_LOGMSG_INFO) - call ESMF_Finalize(endflag=ESMF_END_ABORT) - endif + if (.not. isPresent .and. .not. isSet) then + call ESMF_LogWrite('geomtype set to mesh but mesh_ocn is not specified', ESMF_LOGMSG_INFO) + call ESMF_Finalize(endflag=ESMF_END_ABORT) + endif else geomtype = ESMF_GEOMTYPE_GRID endif + call NUOPC_CompAttributeGet(gcomp, name="use_cdeps_inline", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) use_cdeps_inline=(trim(value)=="true") + write(logmsg,*) use_cdeps_inline + call ESMF_LogWrite('MOM_cap:use_cdeps_inline = '//trim(logmsg), ESMF_LOGMSG_INFO) + + ! Read end of run restart config option + call NUOPC_CompAttributeGet(gcomp, name="write_restart_at_endofrun", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + if (trim(value) .eq. '.true.') restart_eor = .true. + endif + + if (localPet == 0) call cap_profiling("mom", "InitializeP0", "E") + end subroutine !> Called by NUOPC to advertise import and export fields. "Advertise" @@ -424,8 +484,8 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) logical :: existflag logical :: use_waves ! If true, the wave modules are active. character(len=40) :: wave_method ! Wave coupling method. + logical :: use_MARBL ! If true, MARBL tracers are being used. integer :: userRc - integer :: localPet integer :: localPeCount integer :: iostat integer :: readunit @@ -434,10 +494,20 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! (same as restartfile if single restart file) character(len=*), parameter :: subname='(MOM_cap:InitializeAdvertise)' character(len=32) :: calendar + character(len=17) :: timestamp + character(len=:), allocatable :: rpointer_filename + integer :: inst_index + logical :: i2o_per_cat + logical :: found=.false. ! rpointer inquiry + real(8) :: MPI_Wtime, timeiads !-------------------------------- rc = ESMF_SUCCESS + if (localPet == 0) call cap_profiling("mom", "InitializeAdvertise", "B") + + if (write_runtimelog) timeiads = MPI_Wtime() + call ESMF_LogWrite(subname//' enter', ESMF_LOGMSG_INFO) allocate(Ice_ocean_boundary) @@ -451,7 +521,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call ESMF_VMGetCurrent(vm, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_VMGet(VM, mpiCommunicator=mpi_comm_mom, localPet=localPet, rc=rc) + call ESMF_VMGet(VM, mpiCommunicator=mpi_comm_mom, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_ClockGet(CLOCK, currTIME=MyTime, TimeStep=TINT, RC=rc) @@ -463,68 +533,96 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) CALL ESMF_TimeIntervalGet(TINT, S=DT_OCEAN, RC=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - !--------------------------------- - ! openmp threads - !--------------------------------- - - call ESMF_VMGet(vm, pet=localPet, peCount=localPeCount, rc=rc) +#ifdef CESMCOUPLED + call get_component_instance(gcomp, inst_suffix, inst_index, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ensemble_manager_init(inst_suffix) - if(localPeCount == 1) then - call NUOPC_CompAttributeGet(gcomp, name="nthreads", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - read(cvalue,*) nthrds - else - nthrds = localPeCount - endif - else - nthrds = localPeCount + ! Default to appending dates to the restart pointer unless otherwise specified in NUOPC settings + call NUOPC_CompAttributeGet(gcomp, name="restart_pointer_append_date", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) pointer_date = (trim(cvalue) .eq. ".true.") + + rpointer_filename = 'rpointer.ocn'//trim(inst_suffix) + if (pointer_date) then + write(timestamp,'(".",i4.4,"-",i2.2,"-",i2.2,"-",i5.5)')year,month,day,hour*3600+minute*60+second + inquire(file=trim(rpointer_filename//timestamp), exist=found) + ! for backward compatibility + if (found) then + rpointer_filename = trim(rpointer_filename//timestamp) + endif endif - write(logmsg,*) nthrds - call ESMF_LogWrite(trim(subname)//': nthreads = '//trim(logmsg), ESMF_LOGMSG_INFO) +#endif -!$ call omp_set_num_threads(nthrds) + ! reset shr logging to my log file + if (localPet==0) then + call NUOPC_CompAttributeGet(gcomp, name="diro", & + isPresent=isPresentDiro, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name="logfile", & + isPresent=isPresentLogfile, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresentDiro .and. isPresentLogfile) then + call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call fms_init(mpi_comm_mom) - call constants_init - call field_manager_init + if (cesm_coupled) then + ! Multiinstance logfile name needs a correction + if (len_trim(inst_suffix) > 0) then + n = index(logfile, '.') + logfile = logfile(1:n-1)//trim(inst_suffix)//logfile(n:) + endif + endif + + open(newunit=stdout,file=trim(diro)//"/"//trim(logfile)) + else + stdout = output_unit + endif + else + stdout = output_unit + endif + call shr_log_setLogUnit(stdout) + call NUOPC_CompAttributeAdd(gcomp, (/"logunit"/), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeSet(gcomp, "logunit", stdout, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call MOM_infra_init(mpi_comm_mom) ! determine the calendar if (cesm_coupled) then - call NUOPC_CompAttributeGet(gcomp, name="calendar", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - read(cvalue,*) calendar - select case (trim(calendar)) - case ("NO_LEAP") - call set_calendar_type (NOLEAP) - case ("GREGORIAN") - call set_calendar_type (GREGORIAN) - case default - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//": Calendar not supported in MOM6: "//trim(calendar), & - line=__LINE__, file=__FILE__, rcToReturn=rc) - end select - else - call set_calendar_type (NOLEAP) - endif + call NUOPC_CompAttributeGet(gcomp, name="calendar", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) calendar + select case (trim(calendar)) + case ("NO_LEAP") + call set_calendar_type (NOLEAP) + case ("GREGORIAN") + call set_calendar_type (GREGORIAN) + case default + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//": Calendar not supported in MOM6: "//trim(calendar), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + end select + else + call set_calendar_type (NOLEAP) + endif else - call set_calendar_type (JULIAN) + call set_calendar_type (JULIAN) endif - call diag_manager_init - ! this ocean connector will be driven at set interval DT = set_time (DT_OCEAN, 0) ! get current time time_start = set_date (YEAR,MONTH,DAY,HOUR,MINUTE,SECOND) if (is_root_pe()) then - write(logunit,*) subname//'current time: y,m,d-',year,month,day,'h,m,s=',hour,minute,second + write(stdout,*) subname//'current time: y,m,d-',year,month,day,'h,m,s=',hour,minute,second endif ! get start/reference time @@ -536,33 +634,36 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) time0 = set_date (YEAR,MONTH,DAY,HOUR,MINUTE,SECOND) - if (is_root_pe()) then - write(logunit,*) subname//'start time: y,m,d-',year,month,day,'h,m,s=',hour,minute,second - endif + !----------------- + ! optional input from cice columns due to ice thickness categories + !----------------- + + Ice_ocean_boundary%ice_ncat = 0 + if (cesm_coupled) then + ! Note that flds_i2o_per_cat is set by the env_run.xml variable CPL_I2O_PER_CAT + ! In CESM, this xml variable is set by MOM_interface's buildnml script and by + ! default it is false unless ICE_NCAT>0 and USE_MARBL_TRACERS=True + call NUOPC_CompAttributeGet(gcomp, name='flds_i2o_per_cat', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) i2o_per_cat + if (is_root_pe()) then + write(stdout,*) 'i2o_per_cat = ',i2o_per_cat + endif - ! rsd need to figure out how to get this without share code - !call shr_nuopc_get_component_instance(gcomp, inst_suffix, inst_index) - !inst_name = "OCN"//trim(inst_suffix) + ! Note that ice_ncat is set by the env_run.xml variable ICE_NCAT which is set + ! by the ice component (default is 1) + if (i2o_per_cat) then + call NUOPC_CompAttributeGet(gcomp, name='ice_ncat', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) Ice_ocean_boundary%ice_ncat + endif + if (is_root_pe()) then + write(stdout,*) 'ice_ncat = ', Ice_ocean_boundary%ice_ncat + endif + endif - ! reset shr logging to my log file if (is_root_pe()) then - call NUOPC_CompAttributeGet(gcomp, name="diro", & - isPresent=isPresentDiro, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeGet(gcomp, name="logfile", & - isPresent=isPresentLogfile, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresentDiro .and. isPresentLogfile) then - call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - open(newunit=logunit,file=trim(diro)//"/"//trim(logfile)) - else - logunit = output_unit - endif - else - logunit = output_unit + write(stdout,*) subname//'start time: y,m,d-',year,month,day,'h,m,s=',hour,minute,second endif starttype = "" @@ -570,28 +671,28 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - read(cvalue,*) starttype + read(cvalue,*) starttype else - call ESMF_LogWrite('MOM_cap:start_type unset - using input.nml for restart option', & - ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:start_type unset - using input.nml for restart option', & + ESMF_LOGMSG_INFO) endif runtype = "" if (trim(starttype) == trim('startup')) then - runtype = "initial" + runtype = "initial" else if (trim(starttype) == trim('continue') ) then - runtype = "continue" + runtype = "continue" else if (trim(starttype) == trim('branch')) then - runtype = "continue" + runtype = "continue" else if (len_trim(starttype) > 0) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//": unknown starttype - "//trim(starttype), & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//": unknown starttype - "//trim(starttype), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return endif if (len_trim(runtype) > 0) then - call ESMF_LogWrite('MOM_cap:startup = '//trim(runtype), ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:startup = '//trim(runtype), ESMF_LOGMSG_INFO) endif restartfile = ""; restartfiles = "" @@ -606,123 +707,132 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) else if (runtype == "continue") then ! hybrid or branch or continuos runs - if (cesm_coupled) then - call ESMF_LogWrite('MOM_cap: restart requested, using rpointer.ocn', ESMF_LOGMSG_WARNING) - call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_VMGet(vm, localPet=localPet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (cesm_coupled) then + call ESMF_LogWrite('MOM_cap: restart requested, using '//trim(rpointer_filename), ESMF_LOGMSG_WARNING) + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (localPet == 0) then - ! this hard coded for rpointer.ocn right now - open(newunit=readunit, file='rpointer.ocn', form='formatted', status='old', iostat=iostat) - if (iostat /= 0) then - call ESMF_LogSetError(ESMF_RC_FILE_OPEN, msg=subname//' ERROR opening rpointer.ocn', & - line=__LINE__, file=u_FILE_u, rcToReturn=rc) - return + if (localPet == 0) then + open(newunit=readunit, file=rpointer_filename, form='formatted', status='old', iostat=iostat) + if (iostat /= 0) then + call ESMF_LogSetError(ESMF_RC_FILE_OPEN, msg=subname//' ERROR opening '//rpointer_filename, & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + do + read(readunit,'(a)', iostat=iostat) restartfile + if (iostat /= 0) then + if (len(trim(restartfiles))>1 .and. iostat<0) then + exit ! done reading restart files list. + else + call ESMF_LogSetError(ESMF_RC_FILE_READ, msg=subname//' ERROR reading '//rpointer_filename, & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return endif - do - read(readunit,'(a)', iostat=iostat) restartfile - if (iostat /= 0) then - if (len(trim(restartfiles))>1 .and. iostat<0) then - exit ! done reading restart files list. - else - call ESMF_LogSetError(ESMF_RC_FILE_READ, msg=subname//' ERROR reading rpointer.ocn', & - line=__LINE__, file=u_FILE_u, rcToReturn=rc) - return - endif - endif - ! check if the length of restartfiles variable is sufficient: - if (len(restartfiles)-len(trim(restartfiles)) < len(trim(restartfile))) then - call MOM_error(FATAL, "Restart file name(s) too long.") - endif - restartfiles = trim(restartfiles) // " " // trim(restartfile) - enddo - close(readunit) - endif - ! broadcast attribute set on master task to all tasks - call ESMF_VMBroadcast(vm, restartfiles, count=len(restartfiles), rootPet=0, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - else - call ESMF_LogWrite('MOM_cap: restart requested, use input.nml', ESMF_LOGMSG_WARNING) - endif + endif + ! check if the length of restartfiles variable is sufficient: + if (len(restartfiles)-len(trim(restartfiles)) < len(trim(restartfile))) then + call MOM_error(FATAL, "Restart file name(s) too long.") + endif + restartfiles = trim(restartfiles) // " " // trim(restartfile) + enddo + close(readunit) + endif + ! broadcast attribute set on master task to all tasks + call ESMF_VMBroadcast(vm, restartfiles, count=len(restartfiles), rootPet=0, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call ESMF_LogWrite('MOM_cap: restart requested, use input.nml', ESMF_LOGMSG_WARNING) + endif endif ocean_public%is_ocean_pe = .true. - call ocean_model_init(ocean_public, ocean_state, time0, time_start, input_restart_file=trim(restartfiles)) + if (cesm_coupled .and. len_trim(inst_suffix)>0) then + call ocean_model_init(ocean_public, ocean_state, time0, time_start, & + input_restart_file=trim(adjustl(restartfiles)), inst_index=inst_index) + else + call ocean_model_init(ocean_public, ocean_state, time0, time_start, input_restart_file=trim(adjustl(restartfiles))) + endif - ! GMM, this call is not needed for NCAR. Check with EMC. - ! If this can be deleted, perhaps we should also delete ocean_model_flux_init + ! GMM, this call is not needed in CESM. Check with EMC if it can be deleted. call ocean_model_flux_init(ocean_state) call ocean_model_init_sfc(ocean_state, ocean_public) - call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) - - allocate ( Ice_ocean_boundary% u_flux (isc:iec,jsc:jec), & - Ice_ocean_boundary% v_flux (isc:iec,jsc:jec), & - Ice_ocean_boundary% t_flux (isc:iec,jsc:jec), & - Ice_ocean_boundary% q_flux (isc:iec,jsc:jec), & - Ice_ocean_boundary% salt_flux (isc:iec,jsc:jec), & - Ice_ocean_boundary% lw_flux (isc:iec,jsc:jec), & - Ice_ocean_boundary% sw_flux_vis_dir (isc:iec,jsc:jec), & - Ice_ocean_boundary% sw_flux_vis_dif (isc:iec,jsc:jec), & - Ice_ocean_boundary% sw_flux_nir_dir (isc:iec,jsc:jec), & - Ice_ocean_boundary% sw_flux_nir_dif (isc:iec,jsc:jec), & - Ice_ocean_boundary% lprec (isc:iec,jsc:jec), & - Ice_ocean_boundary% fprec (isc:iec,jsc:jec), & - Ice_ocean_boundary% seaice_melt_heat (isc:iec,jsc:jec),& - Ice_ocean_boundary% seaice_melt (isc:iec,jsc:jec), & - Ice_ocean_boundary% mi (isc:iec,jsc:jec), & - Ice_ocean_boundary% ice_fraction (isc:iec,jsc:jec), & - Ice_ocean_boundary% u10_sqr (isc:iec,jsc:jec), & - Ice_ocean_boundary% p (isc:iec,jsc:jec), & - Ice_ocean_boundary% lrunoff_hflx (isc:iec,jsc:jec), & - Ice_ocean_boundary% frunoff_hflx (isc:iec,jsc:jec), & - Ice_ocean_boundary% lrunoff (isc:iec,jsc:jec), & - Ice_ocean_boundary% frunoff (isc:iec,jsc:jec)) - - Ice_ocean_boundary%u_flux = 0.0 - Ice_ocean_boundary%v_flux = 0.0 - Ice_ocean_boundary%t_flux = 0.0 - Ice_ocean_boundary%q_flux = 0.0 - Ice_ocean_boundary%salt_flux = 0.0 - Ice_ocean_boundary%lw_flux = 0.0 - Ice_ocean_boundary%sw_flux_vis_dir = 0.0 - Ice_ocean_boundary%sw_flux_vis_dif = 0.0 - Ice_ocean_boundary%sw_flux_nir_dir = 0.0 - Ice_ocean_boundary%sw_flux_nir_dif = 0.0 - Ice_ocean_boundary%lprec = 0.0 - Ice_ocean_boundary%fprec = 0.0 - Ice_ocean_boundary%seaice_melt = 0.0 - Ice_ocean_boundary%seaice_melt_heat= 0.0 - Ice_ocean_boundary%mi = 0.0 - Ice_ocean_boundary%ice_fraction = 0.0 - Ice_ocean_boundary%u10_sqr = 0.0 - Ice_ocean_boundary%p = 0.0 - Ice_ocean_boundary%lrunoff_hflx = 0.0 - Ice_ocean_boundary%frunoff_hflx = 0.0 - Ice_ocean_boundary%lrunoff = 0.0 - Ice_ocean_boundary%frunoff = 0.0 - - call query_ocean_state(ocean_state, use_waves=use_waves, wave_method=wave_method) + call get_domain_extent(ocean_public%domain, isc, iec, jsc, jec) + + call query_ocean_state(ocean_state, use_waves=use_waves, wave_method=wave_method, use_MARBL=use_MARBL) + + allocate(Ice_ocean_boundary% u_flux (isc:iec,jsc:jec), & + Ice_ocean_boundary% v_flux (isc:iec,jsc:jec), & + Ice_ocean_boundary% t_flux (isc:iec,jsc:jec), & + Ice_ocean_boundary% q_flux (isc:iec,jsc:jec), & + Ice_ocean_boundary% salt_flux (isc:iec,jsc:jec), & + Ice_ocean_boundary% lw_flux (isc:iec,jsc:jec), & + Ice_ocean_boundary% sw_flux_vis_dir (isc:iec,jsc:jec), & + Ice_ocean_boundary% sw_flux_vis_dif (isc:iec,jsc:jec), & + Ice_ocean_boundary% sw_flux_nir_dir (isc:iec,jsc:jec), & + Ice_ocean_boundary% sw_flux_nir_dif (isc:iec,jsc:jec), & + Ice_ocean_boundary% lprec (isc:iec,jsc:jec), & + Ice_ocean_boundary% fprec (isc:iec,jsc:jec), & + Ice_ocean_boundary% seaice_melt_heat (isc:iec,jsc:jec),& + Ice_ocean_boundary% seaice_melt (isc:iec,jsc:jec), & + Ice_ocean_boundary% mi (isc:iec,jsc:jec), & + Ice_ocean_boundary% ice_fraction (isc:iec,jsc:jec), & + Ice_ocean_boundary% u10_sqr (isc:iec,jsc:jec), & + Ice_ocean_boundary% p (isc:iec,jsc:jec), & + Ice_ocean_boundary% lrunoff (isc:iec,jsc:jec), & + Ice_ocean_boundary% frunoff (isc:iec,jsc:jec), & + source=0.0) + + ! Allocate memory for fields coming from multiple ice categories + if (Ice_ocean_boundary%ice_ncat > 0) & + allocate(Ice_ocean_boundary% afracr(isc:iec,jsc:jec), & + Ice_ocean_boundary% swnet_afracr(isc:iec,jsc:jec), & + Ice_ocean_boundary% swpen_ifrac_n(isc:iec,jsc:jec,1:Ice_ocean_boundary%ice_ncat), & + Ice_ocean_boundary% ifrac_n(isc:iec,jsc:jec,1:Ice_ocean_boundary%ice_ncat), & + source=0.0) + + if (cesm_coupled) then + allocate(Ice_ocean_boundary% hrain (isc:iec,jsc:jec), & + Ice_ocean_boundary% hsnow (isc:iec,jsc:jec), & + Ice_ocean_boundary% hrofl (isc:iec,jsc:jec), & + Ice_ocean_boundary% hrofi (isc:iec,jsc:jec), & + Ice_ocean_boundary% hevap (isc:iec,jsc:jec), & + Ice_ocean_boundary% hcond (isc:iec,jsc:jec), & + Ice_ocean_boundary% lrunoff_glc (isc:iec,jsc:jec), & + Ice_ocean_boundary% frunoff_glc (isc:iec,jsc:jec), & + Ice_ocean_boundary% hrofl_glc (isc:iec,jsc:jec), & + Ice_ocean_boundary% hrofi_glc (isc:iec,jsc:jec), & + source=0.0) + + if (use_MARBL) then + allocate(Ice_ocean_boundary% nhx_dep (isc:iec,jsc:jec), & + Ice_ocean_boundary% noy_dep (isc:iec,jsc:jec), & + Ice_ocean_boundary% atm_fine_dust_flux (isc:iec,jsc:jec), & + Ice_ocean_boundary% atm_coarse_dust_flux (isc:iec,jsc:jec),& + Ice_ocean_boundary% seaice_dust_flux (isc:iec,jsc:jec), & + Ice_ocean_boundary% atm_bc_flux (isc:iec,jsc:jec), & + Ice_ocean_boundary% seaice_bc_flux (isc:iec,jsc:jec), & + Ice_ocean_boundary% atm_co2_prog (isc:iec,jsc:jec), & + Ice_ocean_boundary% atm_co2_diag (isc:iec,jsc:jec), & + source=0.0) + endif + endif + if (use_waves) then - call query_ocean_state(ocean_state, NumWaveBands=Ice_ocean_boundary%num_stk_bands) if (wave_method == "EFACTOR") then - allocate( Ice_ocean_boundary%lamult(isc:iec,jsc:jec) ) - Ice_ocean_boundary%lamult = 0.0 - else - allocate ( Ice_ocean_boundary% ustk0 (isc:iec,jsc:jec), & - Ice_ocean_boundary% vstk0 (isc:iec,jsc:jec), & - Ice_ocean_boundary% ustkb (isc:iec,jsc:jec,Ice_ocean_boundary%num_stk_bands), & - Ice_ocean_boundary% vstkb (isc:iec,jsc:jec,Ice_ocean_boundary%num_stk_bands), & - Ice_ocean_boundary%stk_wavenumbers (Ice_ocean_boundary%num_stk_bands)) - Ice_ocean_boundary%ustk0 = 0.0 - Ice_ocean_boundary%vstk0 = 0.0 + allocate( Ice_ocean_boundary%lamult(isc:iec,jsc:jec), source=0.0) + else if (wave_method == "SURFACE_BANDS") then + call query_ocean_state(ocean_state, NumWaveBands=Ice_ocean_boundary%num_stk_bands) + allocate(Ice_ocean_boundary%ustkb(isc:iec,jsc:jec,Ice_ocean_boundary%num_stk_bands), & + Ice_ocean_boundary%vstkb(isc:iec,jsc:jec,Ice_ocean_boundary%num_stk_bands), & + Ice_ocean_boundary%stk_wavenumbers(Ice_ocean_boundary%num_stk_bands), & + source=0.0) call query_ocean_state(ocean_state, WaveNumbers=Ice_ocean_boundary%stk_wavenumbers, unscale=.true.) - Ice_ocean_boundary%ustkb = 0.0 - Ice_ocean_boundary%vstkb = 0.0 + else + call MOM_error(FATAL, "Unsupported WAVE_METHOD encountered in NUOPC cap.") endif endif ! Consider adding this: @@ -733,60 +843,98 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (len_trim(scalar_field_name) > 0) then - call fld_list_add(fldsToOcn_num, fldsToOcn, trim(scalar_field_name), "will_provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, trim(scalar_field_name), "will_provide") - end if - + call fld_list_add(fldsToOcn_num, fldsToOcn, trim(scalar_field_name), "will_provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, trim(scalar_field_name), "will_provide") + endif !--------- import fields ------------- - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_salt_rate" , "will provide") ! from ice - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_zonal_moment_flx" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_merid_moment_flx" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_sensi_heat_flx" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_evap_rate" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_net_lw_flx" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_net_sw_vis_dir_flx" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_net_sw_vis_dif_flx" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_net_sw_ir_dir_flx" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_net_sw_ir_dif_flx" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_prec_rate" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_fprec_rate" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "inst_pres_height_surface" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_rofl" , "will provide") !-> liquid runoff - call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_rofi" , "will provide") !-> ice runoff - call fld_list_add(fldsToOcn_num, fldsToOcn, "Si_ifrac" , "will provide") !-> ice fraction - call fld_list_add(fldsToOcn_num, fldsToOcn, "So_duu10n" , "will provide") !-> wind^2 at 10m - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_fresh_water_to_ocean_rate", "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "net_heat_flx_to_ocn" , "will provide") - !These are not currently used and changing requires a nuopc dictionary change - !call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_runoff_heat_flx" , "will provide") - !call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_calving_heat_flx" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Fioi_salt" , "will provide") ! from ice + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_taux" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_tauy" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_sen" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_evap" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_lwnet" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_swnet_vdr" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_swnet_vdf" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_swnet_idr" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_swnet_idf" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Faxa_rain" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Faxa_snow" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Sa_pslv" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_rofl" , "will provide") !-> liquid runoff + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_rofi" , "will provide") !-> ice runoff + if (cesm_coupled) then + call fld_list_add(fldsToOcn_num, fldsToOcn, "Forr_rofl_glc" , "will provide") !-> liquid glc runoff + call fld_list_add(fldsToOcn_num, fldsToOcn, "Forr_rofi_glc" , "will provide") !-> frozen glc runoff + endif + call fld_list_add(fldsToOcn_num, fldsToOcn, "Si_ifrac" , "will provide") !-> ice fraction + call fld_list_add(fldsToOcn_num, fldsToOcn, "So_duu10n" , "will provide") !-> wind^2 at 10m + call fld_list_add(fldsToOcn_num, fldsToOcn, "Fioi_meltw" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Fioi_melth" , "will provide") + + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hrain" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hsnow" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hevap" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hcond" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hrofl" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hrofi" , "will provide") + if (cesm_coupled) then + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hrofl_glc" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hrofi_glc" , "will provide") + endif + + if (Ice_ocean_boundary%ice_ncat > 0) then + call fld_list_add(fldsToOcn_num, fldsToOcn, "Sf_afracr", "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_swnet_afracr", "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Fioi_swpen_ifrac_n", "will provide", & + ungridded_lbound=1, ungridded_ubound=Ice_ocean_boundary%ice_ncat) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Si_ifrac_n", "will provide", & + ungridded_lbound=1, ungridded_ubound=Ice_ocean_boundary%ice_ncat) + endif + + if (cesm_coupled .and. use_MARBL) then + ! Fields needed for MARBL + call fld_list_add(fldsToOcn_num, fldsToOcn, "Faxa_ndep" , "will provide", & !-> nitrogen deposition + ungridded_lbound=1, ungridded_ubound=2) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Faxa_dstwet" , "will provide", & + ungridded_lbound=1, ungridded_ubound=4) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Faxa_dstdry" , "will provide", & + ungridded_lbound=1, ungridded_ubound=4) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Faxa_bcph" , "will provide", & + ungridded_lbound=1, ungridded_ubound=3) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Fioi_flxdst" , "will provide") !-> ice runoff + call fld_list_add(fldsToOcn_num, fldsToOcn, "Fioi_bcphi" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Fioi_bcpho" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Sa_co2prog" , "will provide") !-> prognostic CO2 from atm + call fld_list_add(fldsToOcn_num, fldsToOcn, "Sa_co2diag" , "will provide") !-> diagnostic CO2 from atm + endif + if (use_waves) then if (wave_method == "EFACTOR") then - call fld_list_add(fldsToOcn_num, fldsToOcn, "Sw_lamult" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Sw_lamult" , "will provide") + else if (wave_method == "SURFACE_BANDS") then + call fld_list_add(fldsToOcn_num, fldsToOcn, "Sw_pstokes_x", "will provide", & + ungridded_lbound=1, ungridded_ubound=Ice_ocean_boundary%num_stk_bands) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Sw_pstokes_y", "will provide", & + ungridded_lbound=1, ungridded_ubound=Ice_ocean_boundary%num_stk_bands) else - if (Ice_ocean_boundary%num_stk_bands > 3) then - call MOM_error(FATAL, "Number of Stokes Bands > 3, NUOPC cap not set up for this") - endif - call fld_list_add(fldsToOcn_num, fldsToOcn, "eastward_partitioned_stokes_drift_1" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "northward_partitioned_stokes_drift_1", "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "eastward_partitioned_stokes_drift_2" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "northward_partitioned_stokes_drift_2", "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "eastward_partitioned_stokes_drift_3" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "northward_partitioned_stokes_drift_3", "will provide") + call MOM_error(FATAL, "Unsupported WAVE_METHOD encountered in NUOPC cap.") endif endif !--------- export fields ------------- - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "ocean_mask" , "will provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "sea_surface_temperature" , "will provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "s_surf" , "will provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "ocn_current_zonal" , "will provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "ocn_current_merid" , "will provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "sea_surface_slope_zonal" , "will provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "sea_surface_slope_merid" , "will provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "freezing_melting_potential" , "will provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_bldepth" , "will provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_omask" , "will provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_t" , "will provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_s" , "will provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_u" , "will provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_v" , "will provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_dhdx" , "will provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_dhdy" , "will provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "Fioo_q" , "will provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_bldepth" , "will provide") + if (cesm_coupled .and. use_MARBL) then + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "Faoo_fco2_ocn", "will provide") + endif do n = 1,fldsToOcn_num call NUOPC_Advertise(importState, standardName=fldsToOcn(n)%stdname, name=fldsToOcn(n)%shortname, rc=rc) @@ -797,6 +945,9 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call NUOPC_Advertise(exportState, standardName=fldsFrOcn(n)%stdname, name=fldsFrOcn(n)%shortname, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return enddo + if (write_runtimelog .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', MPI_Wtime()-timeiads + + if (localPet == 0) call cap_profiling("mom", "InitializeAdvertise", "E") end subroutine InitializeAdvertise @@ -830,6 +981,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) type(ocean_grid_type) , pointer :: ocean_grid type(ocean_internalstate_wrapper) :: ocean_internalstate integer :: npet, ntiles + integer :: npes ! number of PEs (from FMS). integer :: nxg, nyg, cnt integer :: isc,iec,jsc,jec integer, allocatable :: xb(:),xe(:),yb(:),ye(:),pe(:) @@ -851,11 +1003,12 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) real(ESMF_KIND_R8), pointer :: dataPtr_xcor(:,:) real(ESMF_KIND_R8), pointer :: dataPtr_ycor(:,:) integer :: mpicom - integer :: localPet integer :: localPeCount integer :: lsize integer :: ig,jg, ni,nj,k integer, allocatable :: gindex(:) ! global index space + integer, allocatable :: gindex_ocn(:) ! global index space for ocean cells (excl. masked cells) + integer, allocatable :: gindex_elim(:) ! global index space for eliminated cells character(len=128) :: fldname character(len=256) :: cvalue character(len=256) :: frmt ! format specifier for several error msgs @@ -874,20 +1027,26 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) real(ESMF_KIND_R8), allocatable :: mesh_areas(:) real(ESMF_KIND_R8), allocatable :: model_areas(:) real(ESMF_KIND_R8), pointer :: dataPtr_mesh_areas(:) - real(ESMF_KIND_R8) :: max_mod2med_areacor - real(ESMF_KIND_R8) :: max_med2mod_areacor - real(ESMF_KIND_R8) :: min_mod2med_areacor - real(ESMF_KIND_R8) :: min_med2mod_areacor - real(ESMF_KIND_R8) :: max_mod2med_areacor_glob - real(ESMF_KIND_R8) :: max_med2mod_areacor_glob - real(ESMF_KIND_R8) :: min_mod2med_areacor_glob - real(ESMF_KIND_R8) :: min_med2mod_areacor_glob + real(ESMF_KIND_R8) :: min_areacor(2) + real(ESMF_KIND_R8) :: max_areacor(2) + real(ESMF_KIND_R8) :: min_areacor_glob(2) + real(ESMF_KIND_R8) :: max_areacor_glob(2) character(len=*), parameter :: subname='(MOM_cap:InitializeRealize)' + integer :: niproc, njproc + integer :: ip, jp, pe_ix + integer :: num_elim_blocks ! number of blocks to be eliminated + integer :: num_elim_cells_global, num_elim_cells_local, num_elim_cells_remaining + integer, allocatable :: cell_mask(:,:) + real(8) :: MPI_Wtime, timeirls !-------------------------------- rc = ESMF_SUCCESS - call shr_file_setLogUnit (logunit) + if (localPet == 0) call cap_profiling("mom", "InitializeRealize", "B") + + if (write_runtimelog) timeirls = MPI_Wtime() + + call shr_log_setLogUnit (stdout) !---------------------------------------------------------------------------- ! Get pointers to ocean internal state @@ -907,31 +1066,9 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call ESMF_VMGetCurrent(vm, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_VMGet(vm, petCount=npet, mpiCommunicator=mpicom, localPet=localPet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - !--------------------------------- - ! openmp threads - !--------------------------------- - - call ESMF_VMGet(vm, pet=localPet, peCount=localPeCount, rc=rc) + call ESMF_VMGet(vm, petCount=npet, mpiCommunicator=mpicom, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if(localPeCount == 1) then - call NUOPC_CompAttributeGet(gcomp, name="nthreads", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - read(cvalue,*) nthrds - else - nthrds = localPeCount - endif - else - nthrds = localPeCount - endif - -!$ call omp_set_num_threads(nthrds) - !--------------------------------- ! global mom grid size !--------------------------------- @@ -949,426 +1086,517 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) rc = ESMF_FAILURE call ESMF_LogWrite(subname//' ntiles must be 1', ESMF_LOGMSG_ERROR) endif - ntiles=mpp_get_domain_npes(ocean_public%domain) - write(tmpstr,'(a,1i6)') subname//' ntiles = ',ntiles + npes = mpp_get_domain_npes(ocean_public%domain) + write(tmpstr,'(a,1i6)') subname//' npes = ',npes call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) !--------------------------------- ! get start and end indices of each tile and their PET !--------------------------------- - allocate(xb(ntiles),xe(ntiles),yb(ntiles),ye(ntiles),pe(ntiles)) + allocate(xb(npes),xe(npes),yb(npes),ye(npes),pe(npes)) call mpp_get_compute_domains(ocean_public%domain, xbegin=xb, xend=xe, ybegin=yb, yend=ye) call mpp_get_pelist(ocean_public%domain, pe) if (dbug > 1) then - do n = 1,ntiles - write(tmpstr,'(a,6i6)') subname//' tiles ',n,pe(n),xb(n),xe(n),yb(n),ye(n) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - enddo + do n = 1,npes + write(tmpstr,'(a,6i6)') subname//' tiles ',n,pe(n),xb(n),xe(n),yb(n),ye(n) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + enddo endif !--------------------------------- ! Create either a grid or a mesh !--------------------------------- - !Get the ocean grid and sizes of global and computational domains - call get_ocean_grid(ocean_state, ocean_grid) + !Get the ocean grid and sizes of global and computational domains + call get_ocean_grid(ocean_state, ocean_grid) if (geomtype == ESMF_GEOMTYPE_MESH) then - !--------------------------------- - ! Create a MOM6 mesh - !--------------------------------- + !--------------------------------- + ! Create a MOM6 mesh + !--------------------------------- + + call get_global_grid_size(ocean_grid, ni, nj) + lsize = ( ocean_grid%iec - ocean_grid%isc + 1 ) * ( ocean_grid%jec - ocean_grid%jsc + 1 ) - call get_global_grid_size(ocean_grid, ni, nj) - lsize = ( ocean_grid%iec - ocean_grid%isc + 1 ) * ( ocean_grid%jec - ocean_grid%jsc + 1 ) + num_elim_blocks = 0 + num_elim_cells_global = 0 + num_elim_cells_local = 0 + num_elim_cells_remaining = 0 - ! Create the global index space for the computational domain - allocate(gindex(lsize)) - k = 0 - do j = ocean_grid%jsc, ocean_grid%jec + ! Compute the number of eliminated blocks (specified in MOM_mask_table) + if (associated(ocean_grid%Domain%maskmap)) then + njproc = size(ocean_grid%Domain%maskmap, 1) + niproc = size(ocean_grid%Domain%maskmap, 2) + + do ip = 1, niproc + do jp = 1, njproc + if (.not. ocean_grid%Domain%maskmap(jp,ip)) then + num_elim_blocks = num_elim_blocks+1 + endif + enddo + enddo + endif + + ! Apply land block elimination to ESMF gindex + ! (Here we assume that each processor gets assigned a single tile. If multi-tile implementation is to be added + ! in MOM6 NUOPC cap in the future, below code must be updated accordingly.) + if (num_elim_blocks>0) then + + allocate(cell_mask(ni, nj), source=0) + allocate(gindex_ocn(lsize)) + k = 0 + do j = ocean_grid%jsc, ocean_grid%jec jg = j + ocean_grid%jdg_offset do i = ocean_grid%isc, ocean_grid%iec - ig = i + ocean_grid%idg_offset - k = k + 1 ! Increment position within gindex - gindex(k) = ni * (jg - 1) + ig + ig = i + ocean_grid%idg_offset + k = k + 1 ! Increment position within gindex + gindex_ocn(k) = ni * (jg - 1) + ig + cell_mask(ig, jg) = 1 enddo - enddo + enddo + call sum_across_PEs(cell_mask, ni*nj) - DistGrid = ESMF_DistGridCreate(arbSeqIndexList=gindex, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (maxval(cell_mask) /= 1 ) then + call MOM_error(FATAL, "Encountered cells shared by multiple PEs while attempting to determine masked cells.") + endif - ! read in the mesh - call NUOPC_CompAttributeGet(gcomp, name='mesh_ocn', value=cvalue, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + num_elim_cells_global = ni * nj - sum(cell_mask) + num_elim_cells_local = num_elim_cells_global / npes - EMeshTemp = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (pe_here() == pe(npes)) then + ! assign all remaining cells to the last PE. + num_elim_cells_remaining = num_elim_cells_global - num_elim_cells_local * npes + allocate(gindex_elim(num_elim_cells_local+num_elim_cells_remaining)) + else + allocate(gindex_elim(num_elim_cells_local)) + endif + + ! Zero-based PE index. + pe_ix = pe_here() - pe(1) + + k = 0 + do jg = 1, nj + do ig = 1, ni + if (cell_mask(ig, jg) == 0) then + k = k + 1 + if (k > pe_ix * num_elim_cells_local .and. & + k <= ((pe_ix+1) * num_elim_cells_local + num_elim_cells_remaining)) then + gindex_elim(k - pe_ix * num_elim_cells_local) = ni * (jg -1) + ig + endif + endif + enddo + enddo - if (localPet == 0) then - write(logunit,*)'mesh file for mom6 domain is ',trim(cvalue) - endif + allocate(gindex(lsize + num_elim_cells_local + num_elim_cells_remaining)) + do k = 1, lsize + gindex(k) = gindex_ocn(k) + enddo + do k = 1, num_elim_cells_local + num_elim_cells_remaining + gindex(k+lsize) = gindex_elim(k) + enddo - ! recreate the mesh using the above distGrid - EMesh = ESMF_MeshCreate(EMeshTemp, elementDistgrid=Distgrid, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + deallocate(cell_mask) + deallocate(gindex_ocn) + deallocate(gindex_elim) - ! Check for consistency of lat, lon and mask between mesh and mom6 grid - call ESMF_MeshGet(Emesh, spatialDim=spatialDim, numOwnedElements=numOwnedElements, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + else ! no eliminated land blocks - allocate(ownedElemCoords(spatialDim*numOwnedElements)) - allocate(lonMesh(numOwnedElements), lon(numOwnedElements)) - allocate(latMesh(numOwnedElements), lat(numOwnedElements)) - allocate(maskMesh(numOwnedElements), mask(numOwnedElements)) + ! Create the global index space for the computational domain + allocate(gindex(lsize)) + k = 0 + do j = ocean_grid%jsc, ocean_grid%jec + jg = j + ocean_grid%jdg_offset + do i = ocean_grid%isc, ocean_grid%iec + ig = i + ocean_grid%idg_offset + k = k + 1 ! Increment position within gindex + gindex(k) = ni * (jg - 1) + ig + enddo + enddo - call ESMF_MeshGet(Emesh, ownedElemCoords=ownedElemCoords, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - do n = 1,numOwnedElements - lonMesh(n) = ownedElemCoords(2*n-1) - latMesh(n) = ownedElemCoords(2*n) - end do + endif - elemMaskArray = ESMF_ArrayCreate(Distgrid, maskMesh, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_MeshGet(Emesh, elemMaskArray=elemMaskArray, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + DistGrid = ESMF_DistGridCreate(arbSeqIndexList=gindex, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) - n = 0 - do j = jsc, jec - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - ig = i + ocean_grid%isc - isc - n = n+1 - mask(n) = ocean_grid%mask2dT(ig,jg) - lon(n) = ocean_grid%geolonT(ig,jg) - lat(n) = ocean_grid%geolatT(ig,jg) - end do - end do - - eps_omesh = get_eps_omesh(ocean_state) - do n = 1,numOwnedElements - diff_lon = abs(mod(lonMesh(n) - lon(n),360.0)) - if (diff_lon > eps_omesh) then - frmt = "('ERROR: Difference between ESMF Mesh and MOM6 domain coords is "//& - "greater than parameter EPS_OMESH. n, lonMesh(n), lon(n), diff_lon, "//& - "EPS_OMESH= ',i8,2(f21.13,3x),2(d21.5))" - write(err_msg, frmt)n,lonMesh(n),lon(n), diff_lon, eps_omesh - call MOM_error(FATAL, err_msg) - end if - diff_lat = abs(latMesh(n) - lat(n)) - if (diff_lat > eps_omesh) then - frmt = "('ERROR: Difference between ESMF Mesh and MOM6 domain coords is"//& - "greater than parameter EPS_OMESH. n, latMesh(n), lat(n), diff_lat, "//& - "EPS_OMESH= ',i8,2(f21.13,3x),2(d21.5))" - write(err_msg, frmt)n,latMesh(n),lat(n), diff_lat, eps_omesh - call MOM_error(FATAL, err_msg) - end if - if (abs(maskMesh(n) - mask(n)) > 0) then - frmt = "('ERROR: ESMF mesh and MOM6 domain masks are inconsistent! - "//& - "MOM n, maskMesh(n), mask(n) = ',3(i8,2x))" - write(err_msg, frmt)n,maskMesh(n),mask(n) - call MOM_error(FATAL, err_msg) - end if - end do - - ! realize the import and export fields using the mesh - call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", mesh=Emesh, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! read in the mesh + call NUOPC_CompAttributeGet(gcomp, name='mesh_ocn', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", mesh=Emesh, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + EMeshTemp = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - !--------------------------------- - ! determine flux area correction factors - module variables in mom_cap_methods - !--------------------------------- - ! Area correction factors are ONLY valid for meshes that are read in - so do not need them for - ! grids that are calculated internally + if (localPet == 0) then + write(stdout,*)'mesh file for mom6 domain is ',trim(cvalue) + endif - ! Determine mesh areas for regridding - call ESMF_MeshGet(Emesh, numOwnedElements=numOwnedElements, spatialDim=spatialDim, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! recreate the mesh using the above distGrid + EMesh = ESMF_MeshCreate(EMeshTemp, elementDistgrid=Distgrid, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - allocate (mod2med_areacor(numOwnedElements)) - allocate (med2mod_areacor(numOwnedElements)) - mod2med_areacor(:) = 1._ESMF_KIND_R8 - med2mod_areacor(:) = 1._ESMF_KIND_R8 + ! Check for consistency of lat, lon and mask between mesh and mom6 grid + call ESMF_MeshGet(Emesh, spatialDim=spatialDim, numOwnedElements=numOwnedElements, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (lsize /= numOwnedElements - num_elim_cells_local - num_elim_cells_remaining) then + call MOM_error(FATAL, "Discrepancy detected between ESMF mesh and internal MOM6 domain sizes. Check mask table.") + endif + + allocate(ownedElemCoords(spatialDim*numOwnedElements)) + allocate(lonMesh(numOwnedElements), lon(numOwnedElements)) + allocate(latMesh(numOwnedElements), lat(numOwnedElements)) + allocate(maskMesh(numOwnedElements), mask(numOwnedElements)) + + call ESMF_MeshGet(Emesh, ownedElemCoords=ownedElemCoords, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + do n = 1,numOwnedElements + lonMesh(n) = ownedElemCoords(2*n-1) + latMesh(n) = ownedElemCoords(2*n) + enddo + + elemMaskArray = ESMF_ArrayCreate(Distgrid, maskMesh, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_MeshGet(Emesh, elemMaskArray=elemMaskArray, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call get_domain_extent(ocean_public%domain, isc, iec, jsc, jec) + n = 0 + do j = jsc, jec + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + n = n+1 + mask(n) = ocean_grid%mask2dT(ig,jg) + lon(n) = ocean_grid%geolonT(ig,jg) + lat(n) = ocean_grid%geolatT(ig,jg) + enddo + enddo + + eps_omesh = get_eps_omesh(ocean_state) + do n = 1,lsize + diff_lon = abs(mod(lonMesh(n) - lon(n),360.0)) + if (diff_lon > eps_omesh) then + frmt = "('ERROR: Difference between ESMF Mesh and MOM6 domain coords is "//& + "greater than parameter EPS_OMESH. n, lonMesh(n), lon(n), diff_lon, "//& + "EPS_OMESH= ',i8,2(f21.13,3x),2(d21.5))" + write(err_msg, frmt)n,lonMesh(n),lon(n), diff_lon, eps_omesh + call MOM_error(FATAL, err_msg) + endif + diff_lat = abs(latMesh(n) - lat(n)) + if (diff_lat > eps_omesh) then + frmt = "('ERROR: Difference between ESMF Mesh and MOM6 domain coords is"//& + "greater than parameter EPS_OMESH. n, latMesh(n), lat(n), diff_lat, "//& + "EPS_OMESH= ',i8,2(f21.13,3x),2(d21.5))" + write(err_msg, frmt)n,latMesh(n),lat(n), diff_lat, eps_omesh + call MOM_error(FATAL, err_msg) + endif + if (abs(maskMesh(n) - mask(n)) > 0) then + frmt = "('ERROR: ESMF mesh and MOM6 domain masks are inconsistent! - "//& + "MOM n, maskMesh(n), mask(n) = ',3(i8,2x))" + write(err_msg, frmt)n,maskMesh(n),mask(n) + call MOM_error(FATAL, err_msg) + endif + enddo + + ! realize the import and export fields using the mesh + call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", & + ice_ocean_boundary=Ice_ocean_boundary, mesh=Emesh, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", mesh=Emesh, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !--------------------------------- + ! determine flux area correction factors - module variables in mom_cap_methods + !--------------------------------- + ! Area correction factors are ONLY valid for meshes that are read in - so do not need them for + ! grids that are calculated internally + + ! Determine mesh areas for regridding + call ESMF_MeshGet(Emesh, numOwnedElements=numOwnedElements, spatialDim=spatialDim, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + allocate(mod2med_areacor(numOwnedElements), & + med2mod_areacor(numOwnedElements), & + source=1._ESMF_KIND_R8) #ifdef CESMCOUPLED - ! Determine model areas and flux correction factors (module variables in mom_) - call ESMF_StateGet(exportState, itemName=trim(fldsFrOcn(2)%stdname), field=lfield, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldRegridGetArea(lfield, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(lfield, farrayPtr=dataPtr_mesh_areas, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! Determine model areas and flux correction factors (module variables in mom_) + call ESMF_StateGet(exportState, itemName=trim(fldsFrOcn(2)%stdname), field=lfield, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldRegridGetArea(lfield, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, farrayPtr=dataPtr_mesh_areas, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - allocate(mesh_areas(numOwnedElements)) - allocate(model_areas(numOwnedElements)) - k = 0 - do j = ocean_grid%jsc, ocean_grid%jec - do i = ocean_grid%isc, ocean_grid%iec - k = k + 1 ! Increment position within gindex - if (mask(k) /= 0) then - mesh_areas(k) = dataPtr_mesh_areas(k) - model_areas(k) = ocean_grid%AreaT(i,j) / ocean_grid%Rad_Earth_L**2 - mod2med_areacor(k) = model_areas(k) / mesh_areas(k) - med2mod_areacor(k) = mesh_areas(k) / model_areas(k) - end if - end do - end do - deallocate(mesh_areas) - deallocate(model_areas) - - ! Write diagnostic output for correction factors - min_mod2med_areacor = minval(mod2med_areacor) - max_mod2med_areacor = maxval(mod2med_areacor) - min_med2mod_areacor = minval(med2mod_areacor) - max_med2mod_areacor = maxval(med2mod_areacor) - call shr_mpi_max(max_mod2med_areacor, max_mod2med_areacor_glob, mpicom) - call shr_mpi_min(min_mod2med_areacor, min_mod2med_areacor_glob, mpicom) - call shr_mpi_max(max_med2mod_areacor, max_med2mod_areacor_glob, mpicom) - call shr_mpi_min(min_med2mod_areacor, min_med2mod_areacor_glob, mpicom) - if (localPet == 0) then - write(logunit,'(2A,2g23.15,A )') trim(subname),' : min_mod2med_areacor, max_mod2med_areacor ',& - min_mod2med_areacor_glob, max_mod2med_areacor_glob, 'MOM6' - write(logunit,'(2A,2g23.15,A )') trim(subname),' : min_med2mod_areacor, max_med2mod_areacor ',& - min_med2mod_areacor_glob, max_med2mod_areacor_glob, 'MOM6' - end if + allocate(mesh_areas(numOwnedElements)) + allocate(model_areas(numOwnedElements)) + k = 0 + do j = ocean_grid%jsc, ocean_grid%jec + do i = ocean_grid%isc, ocean_grid%iec + k = k + 1 ! Increment position within gindex + if (mask(k) /= 0) then + mesh_areas(k) = dataPtr_mesh_areas(k) + model_areas(k) = ocean_grid%AreaT(i,j) / ocean_grid%Rad_Earth_L**2 + mod2med_areacor(k) = model_areas(k) / mesh_areas(k) + med2mod_areacor(k) = mesh_areas(k) / model_areas(k) + endif + enddo + enddo + deallocate(mesh_areas) + deallocate(model_areas) + + ! Write diagnostic output for correction factors + min_areacor(1) = minval(mod2med_areacor) + max_areacor(1) = maxval(mod2med_areacor) + min_areacor(2) = minval(med2mod_areacor) + max_areacor(2) = maxval(med2mod_areacor) + call ESMF_VMAllReduce(vm, min_areacor, min_areacor_glob, 2, ESMF_REDUCE_MIN, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMAllReduce(vm, max_areacor, max_areacor_glob, 2, ESMF_REDUCE_MAX, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (localPet == 0) then + write(stdout,'(2A,2g23.15,A )') trim(subname),' : min_mod2med_areacor, max_mod2med_areacor ',& + min_areacor_glob(1), max_areacor_glob(1), 'MOM6' + write(stdout,'(2A,2g23.15,A )') trim(subname),' : min_med2mod_areacor, max_med2mod_areacor ',& + min_areacor_glob(2), max_areacor_glob(2), 'MOM6' + endif #endif - deallocate(ownedElemCoords) - deallocate(lonMesh , lon ) - deallocate(latMesh , lat ) - deallocate(maskMesh, mask) + deallocate(ownedElemCoords) + deallocate(lonMesh , lon ) + deallocate(latMesh , lat ) + deallocate(maskMesh, mask) else if (geomtype == ESMF_GEOMTYPE_GRID) then - !--------------------------------- - ! create a MOM6 grid - !--------------------------------- - - ! generate delayout and dist_grid - - allocate(deBlockList(2,2,ntiles)) - allocate(petMap(ntiles)) - allocate(deLabelList(ntiles)) - - do n = 1, ntiles - deLabelList(n) = n - deBlockList(1,1,n) = xb(n) - deBlockList(1,2,n) = xe(n) - deBlockList(2,1,n) = yb(n) - deBlockList(2,2,n) = ye(n) - petMap(n) = pe(n) - ! write(tmpstr,'(a,3i8)') subname//' iglo = ',n,deBlockList(1,1,n),deBlockList(1,2,n) - ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - ! write(tmpstr,'(a,3i8)') subname//' jglo = ',n,deBlockList(2,1,n),deBlockList(2,2,n) - ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - ! write(tmpstr,'(a,2i8)') subname//' pe = ',n,petMap(n) - ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - !--- assume a tile with starting index of 1 has an equivalent wraparound tile on the other side - enddo - - delayout = ESMF_DELayoutCreate(petMap, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + !--------------------------------- + ! create a MOM6 grid + !--------------------------------- + + ! generate delayout and dist_grid + + allocate(deBlockList(2,2,npes)) + allocate(petMap(npes)) + allocate(deLabelList(npes)) + + do n = 1, npes + deLabelList(n) = n + deBlockList(1,1,n) = xb(n) + deBlockList(1,2,n) = xe(n) + deBlockList(2,1,n) = yb(n) + deBlockList(2,2,n) = ye(n) + petMap(n) = pe(n) + ! write(tmpstr,'(a,3i8)') subname//' iglo = ',n,deBlockList(1,1,n),deBlockList(1,2,n) + ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + ! write(tmpstr,'(a,3i8)') subname//' jglo = ',n,deBlockList(2,1,n),deBlockList(2,2,n) + ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + ! write(tmpstr,'(a,2i8)') subname//' pe = ',n,petMap(n) + ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + !--- assume a tile with starting index of 1 has an equivalent wraparound tile on the other side + enddo + + delayout = ESMF_DELayoutCreate(petMap, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! rsd this assumes tripole grid, but sometimes in CESM a bipole - ! grid is used -- need to introduce conditional logic here + ! rsd this assumes tripole grid, but sometimes in CESM a bipole + ! grid is used -- need to introduce conditional logic here - allocate(connectionList(2)) + allocate(connectionList(2)) - ! bipolar boundary condition at top row: nyg - call ESMF_DistGridConnectionSet(connectionList(1), tileIndexA=1, & - tileIndexB=1, positionVector=(/nxg+1, 2*nyg+1/), & - orientationVector=(/-1, -2/), rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! bipolar boundary condition at top row: nyg + call ESMF_DistGridConnectionSet(connectionList(1), tileIndexA=1, & + tileIndexB=1, positionVector=(/nxg+1, 2*nyg+1/), & + orientationVector=(/-1, -2/), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! periodic boundary condition along first dimension - call ESMF_DistGridConnectionSet(connectionList(2), tileIndexA=1, & - tileIndexB=1, positionVector=(/nxg, 0/), rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! periodic boundary condition along first dimension + call ESMF_DistGridConnectionSet(connectionList(2), tileIndexA=1, & + tileIndexB=1, positionVector=(/nxg, 0/), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - distgrid = ESMF_DistGridCreate(minIndex=(/1,1/), maxIndex=(/nxg,nyg/), & - ! indexflag = ESMF_INDEX_DELOCAL, & - deBlockList=deBlockList, & - ! deLabelList=deLabelList, & - delayout=delayout, & - connectionList=connectionList, & - rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + distgrid = ESMF_DistGridCreate(minIndex=(/1,1/), maxIndex=(/nxg,nyg/), & + ! indexflag = ESMF_INDEX_DELOCAL, & + deBlockList=deBlockList, & + ! deLabelList=deLabelList, & + delayout=delayout, & + connectionList=connectionList, & + rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - deallocate(xb,xe,yb,ye,pe) - deallocate(connectionList) - deallocate(deLabelList) - deallocate(deBlockList) - deallocate(petMap) + deallocate(xb,xe,yb,ye,pe) + deallocate(connectionList) + deallocate(deLabelList) + deallocate(deBlockList) + deallocate(petMap) - call ESMF_DistGridGet(distgrid=distgrid, localDE=0, elementCount=cnt, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_DistGridGet(distgrid=distgrid, localDE=0, elementCount=cnt, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - allocate(indexList(cnt)) - write(tmpstr,'(a,i8)') subname//' distgrid cnt= ',cnt - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + allocate(indexList(cnt)) + write(tmpstr,'(a,i8)') subname//' distgrid cnt= ',cnt + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - call ESMF_DistGridGet(distgrid=distgrid, localDE=0, seqIndexList=indexList, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_DistGridGet(distgrid=distgrid, localDE=0, seqIndexList=indexList, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - write(tmpstr,'(a,4i8)') subname//' distgrid list= ',& - indexList(1),indexList(cnt),minval(indexList), maxval(indexList) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + write(tmpstr,'(a,4i8)') subname//' distgrid list= ',& + indexList(1),indexList(cnt),minval(indexList), maxval(indexList) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - deallocate(IndexList) + deallocate(IndexList) - ! create grid + ! create grid - gridIn = ESMF_GridCreate(distgrid=distgrid, & - gridEdgeLWidth=(/0,0/), gridEdgeUWidth=(/0,1/), & - coordSys = ESMF_COORDSYS_SPH_DEG, & - rc = rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + gridIn = ESMF_GridCreate(distgrid=distgrid, & + gridEdgeLWidth=(/0,0/), gridEdgeUWidth=(/0,1/), & + coordSys = ESMF_COORDSYS_SPH_DEG, & + rc = rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_GridAddCoord(gridIn, staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_GridAddCoord(gridIn, staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_GridAddCoord(gridIn, staggerLoc=ESMF_STAGGERLOC_CORNER, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_GridAddCoord(gridIn, staggerLoc=ESMF_STAGGERLOC_CORNER, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_GridAddItem(gridIn, itemFlag=ESMF_GRIDITEM_MASK, itemTypeKind=ESMF_TYPEKIND_I4, & - staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_GridAddItem(gridIn, itemFlag=ESMF_GRIDITEM_MASK, itemTypeKind=ESMF_TYPEKIND_I4, & + staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! Attach area to the Grid optionally. By default the cell areas are computed. - if(grid_attach_area) then - call ESMF_GridAddItem(gridIn, itemFlag=ESMF_GRIDITEM_AREA, itemTypeKind=ESMF_TYPEKIND_R8, & - staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - endif + ! Attach area to the Grid optionally. By default the cell areas are computed. + if (grid_attach_area) then + call ESMF_GridAddItem(gridIn, itemFlag=ESMF_GRIDITEM_AREA, itemTypeKind=ESMF_TYPEKIND_R8, & + staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif - call ESMF_GridGetCoord(gridIn, coordDim=1, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=dataPtr_xcen, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_GridGetCoord(gridIn, coordDim=1, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=dataPtr_xcen, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_GridGetCoord(gridIn, coordDim=2, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=dataPtr_ycen, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_GridGetCoord(gridIn, coordDim=2, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=dataPtr_ycen, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_GridGetCoord(gridIn, coordDim=1, & - staggerloc=ESMF_STAGGERLOC_CORNER, & - farrayPtr=dataPtr_xcor, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_GridGetCoord(gridIn, coordDim=1, & + staggerloc=ESMF_STAGGERLOC_CORNER, & + farrayPtr=dataPtr_xcor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_GridGetCoord(gridIn, coordDim=2, & - staggerloc=ESMF_STAGGERLOC_CORNER, & - farrayPtr=dataPtr_ycor, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_GridGetCoord(gridIn, coordDim=2, & + staggerloc=ESMF_STAGGERLOC_CORNER, & + farrayPtr=dataPtr_ycor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_GridGetItem(gridIn, itemflag=ESMF_GRIDITEM_MASK, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=dataPtr_mask, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_GridGetItem(gridIn, itemflag=ESMF_GRIDITEM_MASK, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=dataPtr_mask, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - if(grid_attach_area) then - call ESMF_GridGetItem(gridIn, itemflag=ESMF_GRIDITEM_AREA, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=dataPtr_area, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - endif + if (grid_attach_area) then + call ESMF_GridGetItem(gridIn, itemflag=ESMF_GRIDITEM_AREA, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=dataPtr_area, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif - ! load up area, mask, center and corner values - ! area, mask, and centers should be same size in mom and esmf grid - ! corner points may not be, need to offset corner points by 1 in i and j - ! retrieve these values directly from ocean_grid, which contains halo - ! values for j=0 and wrap-around in i. on tripole seam, decomposition - ! domains are 1 larger in j; to load corner values need to loop one extra row + ! load up area, mask, center and corner values + ! area, mask, and centers should be same size in mom and esmf grid + ! corner points may not be, need to offset corner points by 1 in i and j + ! retrieve these values directly from ocean_grid, which contains halo + ! values for j=0 and wrap-around in i. on tripole seam, decomposition + ! domains are 1 larger in j; to load corner values need to loop one extra row - call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) + call get_domain_extent(ocean_public%domain, isc, iec, jsc, jec) - lbnd1 = lbound(dataPtr_mask,1) - ubnd1 = ubound(dataPtr_mask,1) - lbnd2 = lbound(dataPtr_mask,2) - ubnd2 = ubound(dataPtr_mask,2) + lbnd1 = lbound(dataPtr_mask,1) + ubnd1 = ubound(dataPtr_mask,1) + lbnd2 = lbound(dataPtr_mask,2) + ubnd2 = ubound(dataPtr_mask,2) - lbnd3 = lbound(dataPtr_xcor,1) - ubnd3 = ubound(dataPtr_xcor,1) - lbnd4 = lbound(dataPtr_xcor,2) - ubnd4 = ubound(dataPtr_xcor,2) + lbnd3 = lbound(dataPtr_xcor,1) + ubnd3 = ubound(dataPtr_xcor,1) + lbnd4 = lbound(dataPtr_xcor,2) + ubnd4 = ubound(dataPtr_xcor,2) - write(tmpstr,*) subname//' iscjsc = ',isc,iec,jsc,jec - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + write(tmpstr,*) subname//' iscjsc = ',isc,iec,jsc,jec + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - write(tmpstr,*) subname//' lbub12 = ',lbnd1,ubnd1,lbnd2,ubnd2 - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + write(tmpstr,*) subname//' lbub12 = ',lbnd1,ubnd1,lbnd2,ubnd2 + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - write(tmpstr,*) subname//' lbub34 = ',lbnd3,ubnd3,lbnd4,ubnd4 - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + write(tmpstr,*) subname//' lbub34 = ',lbnd3,ubnd3,lbnd4,ubnd4 + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - if (iec-isc /= ubnd1-lbnd1 .or. jec-jsc /= ubnd2-lbnd2) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=SUBNAME//": fld and grid do not have the same size.", & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return - endif - - do j = jsc, jec - j1 = j + lbnd2 - jsc - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - i1 = i + lbnd1 - isc - ig = i + ocean_grid%isc - isc - dataPtr_mask(i1,j1) = ocean_grid%mask2dT(ig,jg) - dataPtr_xcen(i1,j1) = ocean_grid%geolonT(ig,jg) - dataPtr_ycen(i1,j1) = ocean_grid%geolatT(ig,jg) - if(grid_attach_area) then - dataPtr_area(i1,j1) = ocean_grid%US%L_to_m**2 * ocean_grid%areaT(ig,jg) - endif - enddo - enddo - - jlast = jec - if(jec == nyg)jlast = jec+1 - - do j = jsc, jlast - j1 = j + lbnd4 - jsc - jg = j + ocean_grid%jsc - jsc - 1 - do i = isc, iec - i1 = i + lbnd3 - isc - ig = i + ocean_grid%isc - isc - 1 - dataPtr_xcor(i1,j1) = ocean_grid%geolonBu(ig,jg) - dataPtr_ycor(i1,j1) = ocean_grid%geolatBu(ig,jg) - enddo - enddo - - write(tmpstr,*) subname//' mask = ',minval(dataPtr_mask),maxval(dataPtr_mask) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - - if(grid_attach_area) then - write(tmpstr,*) subname//' area = ',minval(dataPtr_area),maxval(dataPtr_area) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - endif - - write(tmpstr,*) subname//' xcen = ',minval(dataPtr_xcen),maxval(dataPtr_xcen) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - - write(tmpstr,*) subname//' ycen = ',minval(dataPtr_ycen),maxval(dataPtr_ycen) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - - write(tmpstr,*) subname//' xcor = ',minval(dataPtr_xcor),maxval(dataPtr_xcor) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - - write(tmpstr,*) subname//' ycor = ',minval(dataPtr_ycor),maxval(dataPtr_ycor) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - - gridOut = gridIn ! for now out same as in - - call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", grid=gridIn, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (iec-isc /= ubnd1-lbnd1 .or. jec-jsc /= ubnd2-lbnd2) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=SUBNAME//": fld and grid do not have the same size.", & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif - call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", grid=gridOut, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + do j = jsc, jec + j1 = j + lbnd2 - jsc + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + i1 = i + lbnd1 - isc + ig = i + ocean_grid%isc - isc + dataPtr_mask(i1,j1) = ocean_grid%mask2dT(ig,jg) + dataPtr_xcen(i1,j1) = ocean_grid%geolonT(ig,jg) + dataPtr_ycen(i1,j1) = ocean_grid%geolatT(ig,jg) + if (grid_attach_area) then + dataPtr_area(i1,j1) = ocean_grid%US%L_to_m**2 * ocean_grid%areaT(ig,jg) + endif + enddo + enddo + + jlast = jec + if (jec == nyg)jlast = jec+1 + + do j = jsc, jlast + j1 = j + lbnd4 - jsc + jg = j + ocean_grid%jsc - jsc - 1 + do i = isc, iec + i1 = i + lbnd3 - isc + ig = i + ocean_grid%isc - isc - 1 + dataPtr_xcor(i1,j1) = ocean_grid%geolonBu(ig,jg) + dataPtr_ycor(i1,j1) = ocean_grid%geolatBu(ig,jg) + enddo + enddo + + write(tmpstr,*) subname//' mask = ',minval(dataPtr_mask),maxval(dataPtr_mask) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + if (grid_attach_area) then + write(tmpstr,*) subname//' area = ',minval(dataPtr_area),maxval(dataPtr_area) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + endif + + write(tmpstr,*) subname//' xcen = ',minval(dataPtr_xcen),maxval(dataPtr_xcen) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + write(tmpstr,*) subname//' ycen = ',minval(dataPtr_ycen),maxval(dataPtr_ycen) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + write(tmpstr,*) subname//' xcor = ',minval(dataPtr_xcor),maxval(dataPtr_xcor) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + write(tmpstr,*) subname//' ycor = ',minval(dataPtr_ycor),maxval(dataPtr_ycor) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + gridOut = gridIn ! for now out same as in + + call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", & + ice_ocean_boundary=Ice_ocean_boundary, grid=gridIn, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", grid=gridOut, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return endif !--------------------------------- @@ -1376,13 +1604,13 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) !--------------------------------- if (len_trim(scalar_field_name) > 0) then - call State_SetScalar(real(nxg,ESMF_KIND_R8),scalar_field_idx_grid_nx, exportState, localPet, & + call State_SetScalar(real(nxg,ESMF_KIND_R8),scalar_field_idx_grid_nx, exportState, localPet, & scalar_field_name, scalar_field_count, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call State_SetScalar(real(nyg,ESMF_KIND_R8),scalar_field_idx_grid_ny, exportState, localPet, & - scalar_field_name, scalar_field_count, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call State_SetScalar(real(nyg,ESMF_KIND_R8),scalar_field_idx_grid_ny, exportState, localPet, & + scalar_field_name, scalar_field_count, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return endif !--------------------------------- @@ -1390,6 +1618,11 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) !--------------------------------- call mom_set_geomtype(geomtype) + if (use_cdeps_inline) then + call mom_inline_init(gcomp, clock, eMesh, localPet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + !--------------------------------- ! write out diagnostics !--------------------------------- @@ -1398,6 +1631,11 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ! timeslice=1, relaxedFlag=.true., rc=rc) !if (ChkErr(rc,__LINE__,u_FILE_u)) return + timere = 0. + if (write_runtimelog .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', MPI_Wtime()-timeirls + + if (localPet == 0) call cap_profiling("mom", "InitializeRealize", "E") + end subroutine InitializeRealize !> TODO @@ -1426,8 +1664,13 @@ subroutine DataInitialize(gcomp, rc) type(ESMF_Field) :: field character(len=64),allocatable :: fieldNameList(:) character(len=*),parameter :: subname='(MOM_cap:DataInitialize)' + real(8) :: MPI_Wtime, timedis !-------------------------------- + if (localPet == 0) call cap_profiling("mom", "DataInitialize", "B") + + if (write_runtimelog) timedis = MPI_Wtime() + ! query the Component for its clock, importState and exportState call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, exportState=exportState, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -1471,8 +1714,8 @@ subroutine DataInitialize(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif - if(write_diagnostics) then - do n = 1,fldsFrOcn_num + if (write_diagnostics) then + do n = 1,fldsFrOcn_num fldname = fldsFrOcn(n)%shortname call ESMF_StateGet(exportState, itemName=trim(fldname), itemType=itemType, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -1485,9 +1728,13 @@ subroutine DataInitialize(gcomp, rc) timeslice=1, overwrite=overwrite_timeslice, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif - enddo + enddo endif + if (write_runtimelog .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', MPI_Wtime()-timedis + + if (localPet == 0) call cap_profiling("mom", "DataInitialize", "E") + end subroutine DataInitialize !> Called by NUOPC to advance the model a single timestep. @@ -1512,7 +1759,6 @@ subroutine ModelAdvance(gcomp, rc) integer(ESMF_KIND_I8) :: n_interval, time_elapsed_sec type(ESMF_Field) :: lfield type(ESMF_StateItem_Flag) :: itemType - character(len=64) :: timestamp type (ocean_public_type), pointer :: ocean_public => NULL() type (ocean_state_type), pointer :: ocean_state => NULL() type(ice_ocean_boundary_type), pointer :: Ice_ocean_boundary => NULL() @@ -1530,21 +1776,30 @@ subroutine ModelAdvance(gcomp, rc) character(ESMF_MAXSTR) :: casename integer :: iostat integer :: writeunit - integer :: localPet type(ESMF_VM) :: vm integer :: n, i character(240) :: import_timestr, export_timestr character(len=128) :: fldname character(len=*),parameter :: subname='(MOM_cap:ModelAdvance)' character(len=8) :: suffix + character(len=:), allocatable :: rpointer_filename + character(len=17) :: timestamp integer :: num_rest_files + real(8) :: MPI_Wtime, timers + logical :: write_restart, write_restartfh + logical :: write_restart_eor rc = ESMF_SUCCESS - if(profile_memory) call ESMF_VMLogMemInfo("Entering MOM Model_ADVANCE: ") - call shr_file_setLogUnit (logunit) + if (localPet == 0) call cap_profiling("mom", "ModelAdvance", "B") + + if (profile_memory) call ESMF_VMLogMemInfo("Entering MOM Model_ADVANCE: ") + if (write_runtimelog) then + timers = MPI_Wtime() + if (timere>0. .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time since last time step ',timers-timere + endif -!$ call omp_set_num_threads(nthrds) + call shr_log_setLogUnit (stdout) ! query the Component for its clock, importState and exportState call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, & @@ -1568,7 +1823,9 @@ subroutine ModelAdvance(gcomp, rc) call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) call ESMF_TimeGet(currTime, timestring=import_timestr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_TimeGet(currTime+timestep, timestring=export_timestr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return Time_step_coupled = esmf2fms_time(timeStep) Time = esmf2fms_time(currTime) @@ -1589,183 +1846,216 @@ subroutine ModelAdvance(gcomp, rc) endif if (do_advance) then - ! If the second cpl tstep of a startup run, step back a cpl tstep and advance for two cpl tsteps - if (currTime == startTime + timeStep) then - call ESMF_LogWrite("MOM6 - Stepping back one coupling timestep", ESMF_LOGMSG_INFO) - Time = esmf2fms_time(currTime-timeStep) ! i.e., startTime + ! If the second cpl tstep of a startup run, step back a cpl tstep and advance for two cpl tsteps + if (currTime == startTime + timeStep) then + call ESMF_LogWrite("MOM6 - Stepping back one coupling timestep", ESMF_LOGMSG_INFO) + Time = esmf2fms_time(currTime-timeStep) ! i.e., startTime - call ESMF_LogWrite("MOM6 - doubling the coupling timestep", ESMF_LOGMSG_INFO) - Time_step_coupled = 2 * esmf2fms_time(timeStep) - endif - end if + call ESMF_LogWrite("MOM6 - doubling the coupling timestep", ESMF_LOGMSG_INFO) + Time_step_coupled = 2 * esmf2fms_time(timeStep) + endif + endif endif endif if (do_advance) then - call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - Ice_ocean_boundary => ocean_internalstate%ptr%ice_ocean_boundary_type_ptr - ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr - ocean_state => ocean_internalstate%ptr%ocean_state_type_ptr + Ice_ocean_boundary => ocean_internalstate%ptr%ice_ocean_boundary_type_ptr + ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr + ocean_state => ocean_internalstate%ptr%ocean_state_type_ptr - !--------------- - ! Write diagnostics for import - !--------------- + !--------------- + ! Write diagnostics for import + !--------------- - if (write_diagnostics) then + if (write_diagnostics) then do n = 1,fldsToOcn_num - fldname = fldsToOcn(n)%shortname - call ESMF_StateGet(importState, itemName=trim(fldname), itemType=itemType, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - if (itemType /= ESMF_STATEITEM_NOTFOUND) then - call ESMF_StateGet(importState, itemName=trim(fldname), field=lfield, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call ESMF_FieldWrite(lfield, fileName='field_ocn_import_'//trim(import_timestr)//'.nc', & - timeslice=1, overwrite=overwrite_timeslice, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - endif + fldname = fldsToOcn(n)%shortname + call ESMF_StateGet(importState, itemName=trim(fldname), itemType=itemType, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (itemType /= ESMF_STATEITEM_NOTFOUND) then + call ESMF_StateGet(importState, itemName=trim(fldname), field=lfield, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_FieldWrite(lfield, fileName='field_ocn_import_'//trim(import_timestr)//'.nc', & + timeslice=1, overwrite=overwrite_timeslice, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif enddo - endif + endif - if (dbug > 0) then - call state_diagnose(importState,subname//':IS ',rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if + if (dbug > 0) then + call state_diagnose(importState,subname//':IS ',rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif - !--------------- - ! Get ocean grid - !--------------- + !--------------- + ! Get ocean grid + !--------------- - call get_ocean_grid(ocean_state, ocean_grid) + call get_ocean_grid(ocean_state, ocean_grid) - !--------------- - ! Import data - !--------------- + !--------------- + ! Import data + !--------------- - call mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, & + set_missing_stks_to_zero, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - !--------------- - ! Update MOM6 - !--------------- + if (use_cdeps_inline) then + call mom_inline_run(clock, ocean_public, ocean_grid, ice_ocean_boundary, dbug, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif - if(profile_memory) call ESMF_VMLogMemInfo("Entering MOM update_ocean_model: ") - call update_ocean_model(Ice_ocean_boundary, ocean_state, ocean_public, Time, Time_step_coupled) - if(profile_memory) call ESMF_VMLogMemInfo("Leaving MOM update_ocean_model: ") + !--------------- + ! Update MOM6 + !--------------- - !--------------- - ! Export Data - !--------------- + if (profile_memory) call ESMF_VMLogMemInfo("Entering MOM update_ocean_model: ") + call update_ocean_model(Ice_ocean_boundary, ocean_state, ocean_public, Time, Time_step_coupled, & + cesm_coupled) + if (profile_memory) call ESMF_VMLogMemInfo("Leaving MOM update_ocean_model: ") - call mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + !--------------- + ! Export Data + !--------------- - if (dbug > 0) then - call state_diagnose(exportState,subname//':ES ',rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if - endif + call mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (dbug > 0) then + call state_diagnose(exportState,subname//':ES ',rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + endif ! do_advance !--------------- ! Get the stop alarm !--------------- - - call ESMF_ClockGetAlarm(clock, alarmname='stop_alarm', alarm=stop_alarm, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockGetAlarm(clock, alarmname='stop_alarm', alarm=stop_alarm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return !--------------- ! If restart alarm exists and is ringing - write restart file !--------------- if (restart_mode == 'alarms') then - call ESMF_ClockGetAlarm(clock, alarmname='restart_alarm', alarm=restart_alarm, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockGetAlarm(clock, alarmname='restart_alarm', alarm=restart_alarm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (ESMF_AlarmIsRinging(restart_alarm, rc=rc)) then - if (ChkErr(rc,__LINE__,u_FILE_u)) return + write_restart = .false. + if (ESMF_AlarmIsRinging(restart_alarm, rc=rc)) then + if (ChkErr(rc,__LINE__,u_FILE_u)) return + write_restart = .true. + ! turn off the alarm + call ESMF_AlarmRingerOff(restart_alarm, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif - ! turn off the alarm - call ESMF_AlarmRingerOff(restart_alarm, rc=rc ) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + write_restart_eor = .false. + if (restart_eor) then + if (ESMF_AlarmIsRinging(stop_alarm, rc=rc)) then + if (ChkErr(rc,__LINE__,u_FILE_u)) return + write_restart_eor = .true. + ! turn off the alarm + call ESMF_AlarmRingerOff(stop_alarm, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + endif - ! determine restart filename - call ESMF_ClockGetNextTime(clock, MyTime, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeGet (MyTime, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc ) - if (ChkErr(rc,__LINE__,u_FILE_u)) return +#ifndef CESMCOUPLED + call is_restart_fh(clock, restartfh_info, write_restartfh) + if (write_restartfh) write_restart = .true. +#endif + + if (write_restart .or. write_restart_eor) then + ! determine restart filename + call ESMF_ClockGetNextTime(clock, MyTime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeGet (MyTime, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (cesm_coupled) then + if (cesm_coupled) then call NUOPC_CompAttributeGet(gcomp, name='case_name', value=casename, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_VMGet(vm, localPet=localPet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I5.5)') & - trim(casename), year, month, day, seconds + write(timestamp,'(".",i4.4,"-",i2.2,"-",i2.2,"-",i5.5)')year,month,day,hour*3600+minute*60+seconds + + rpointer_filename = 'rpointer.ocn'//trim(inst_suffix) + if (pointer_date) then + rpointer_filename = trim(rpointer_filename//timestamp) + endif + + write(restartname,'(A,".mom6.r",A)') & + trim(casename), timestamp call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) ! write restart file(s) call ocean_model_restart(ocean_state, restartname=restartname, num_rest_files=num_rest_files) if (localPet == 0) then ! Write name of restart file in the rpointer file - this is currently hard-coded for the ocean - open(newunit=writeunit, file='rpointer.ocn', form='formatted', status='unknown', iostat=iostat) - if (iostat /= 0) then - call ESMF_LogSetError(ESMF_RC_FILE_OPEN, & - msg=subname//' ERROR opening rpointer.ocn', line=__LINE__, file=u_FILE_u, rcToReturn=rc) - return - endif - write(writeunit,'(a)') trim(restartname)//'.nc' - - if (num_rest_files > 1) then - ! append i.th restart file name to rpointer - do i=1, num_rest_files-1 - if (i < 10) then - write(suffix,'("_",I1)') i - else - write(suffix,'("_",I2)') i - endif - write(writeunit,'(a)') trim(restartname) // trim(suffix) // '.nc' - enddo - endif - close(writeunit) - endif - else ! not cesm_coupled - ! write the final restart without a timestamp - if (ESMF_AlarmIsRinging(stop_alarm, rc=rc)) then - write(restartname,'(A)')"MOM.res" - write(stoch_restartname,'(A)')"ocn_stoch.res.nc" - else - write(restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2)') & - "MOM.res.", year, month, day, hour, minute, seconds - write(stoch_restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,A)') & - "ocn_stoch.res.", year, month, day, hour, minute, seconds,".nc" + open(newunit=writeunit, file=rpointer_filename, form='formatted', status='unknown', iostat=iostat) + if (iostat /= 0) then + call ESMF_LogSetError(ESMF_RC_FILE_OPEN, & + msg=subname//' ERROR opening '//rpointer_filename, line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return + endif + if (len_trim(inst_suffix) == 0) then + write(writeunit,'(a)') trim(restartname)//'.nc' + else + write(writeunit,'(a)') trim(restartname)//'.'//trim(inst_suffix)//'.nc' + endif + + if (num_rest_files > 1) then + ! append i.th restart file name to rpointer + do i=1, num_rest_files-1 + if (i < 10) then + write(suffix,'("_",I1)') i + else + write(suffix,'("_",I2)') i + endif + write(writeunit,'(a)') trim(restartname) // trim(suffix) // '.nc' + enddo + endif + close(writeunit) endif + else ! not cesm_coupled + write(restartname,'(i4.4,2(i2.2),A,3(i2.2),A)') year, month, day,".", hour, minute, seconds, & + ".MOM.res" + write(stoch_restartname,'(i4.4,2(i2.2),A,3(i2.2),A)') year, month, day,".", hour, minute, seconds, & + ".ocn_stoch.res.nc" call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) ! write restart file(s) call ocean_model_restart(ocean_state, restartname=restartname, & - stoch_restartname=stoch_restartname) + stoch_restartname=stoch_restartname, num_rest_files=num_rest_files) - endif + call outputlog_restart(clock, num_rest_files, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif - if (is_root_pe()) then - write(logunit,*) subname//' writing restart file ',trim(restartname) - endif - endif - end if ! restart_mode + if (is_root_pe()) then + write(stdout,*) subname//' writing restart file ',trim(restartname) + endif + endif + endif ! restart_mode + + call outputlog_run(clock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return !--------------- ! Write diagnostics !--------------- if (write_diagnostics) then - do n = 1,fldsFrOcn_num + do n = 1,fldsFrOcn_num fldname = fldsFrOcn(n)%shortname call ESMF_StateGet(exportState, itemName=trim(fldname), itemType=itemType, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -1778,10 +2068,17 @@ subroutine ModelAdvance(gcomp, rc) timeslice=1, overwrite=overwrite_timeslice, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif - enddo + enddo endif - if(profile_memory) call ESMF_VMLogMemInfo("Leaving MOM Model_ADVANCE: ") + if (write_runtimelog) then + timere = MPI_Wtime() + if (is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', timere-timers + endif + + if (profile_memory) call ESMF_VMLogMemInfo("Leaving MOM Model_ADVANCE: ") + + if (localPet == 0) call cap_profiling("mom", "ModelAdvance", "E") end subroutine ModelAdvance @@ -1800,6 +2097,7 @@ subroutine ModelSetRunClock(gcomp, rc) character(len=256) :: restart_option ! Restart option units integer :: restart_n ! Number until restart interval integer :: restart_ymd ! Restart date (YYYYMMDD) + integer :: dt_cpl type(ESMF_Alarm) :: restart_alarm type(ESMF_Alarm) :: stop_alarm logical :: isPresent, isSet @@ -1810,6 +2108,8 @@ subroutine ModelSetRunClock(gcomp, rc) rc = ESMF_SUCCESS + if (localPet == 0) call cap_profiling("mom", "ModelSetRunClock", "B") + ! query the Component for its clock, importState and exportState call NUOPC_ModelGet(gcomp, driverClock=dclock, modelClock=mclock, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -1848,103 +2148,110 @@ subroutine ModelSetRunClock(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (first_time) then - !-------------------------------- - ! set restart alarm - !-------------------------------- + !-------------------------------- + ! set restart alarm + !-------------------------------- - ! defaults - restart_n = 0 - restart_ymd = 0 + ! defaults + restart_n = 0 + restart_ymd = 0 - if (cesm_coupled) then + if (cesm_coupled) then - call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=restart_option, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=restart_option, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! If restart_option is set then must also have set either restart_n or restart_ymd - call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - read(cvalue,*) restart_n - endif - call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - read(cvalue,*) restart_ymd - endif - if (restart_n == 0 .and. restart_ymd == 0) then - call ESMF_LogSetError(ESMF_RC_VAL_WRONG, & - msg=subname//": ERROR both restart_n and restart_ymd are zero for restart_option set ", & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return - endif - call ESMF_LogWrite(subname//" Set restart option = "//restart_option, ESMF_LOGMSG_INFO) + ! If restart_option is set then must also have set either restart_n or restart_ymd + call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) restart_n + endif + call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) restart_ymd + endif + if (restart_n == 0 .and. restart_ymd == 0) then + call ESMF_LogSetError(ESMF_RC_VAL_WRONG, & + msg=subname//": ERROR both restart_n and restart_ymd are zero for restart_option set ", & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + call ESMF_LogWrite(subname//" Set restart option = "//restart_option, ESMF_LOGMSG_INFO) - else - call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! If restart_n is set and non-zero, then restart_option must be available from config - if (isPresent .and. isSet) then - call ESMF_LogWrite(subname//" Restart_n = "//trim(cvalue), ESMF_LOGMSG_INFO) - read(cvalue,*) restart_n - if(restart_n /= 0)then - call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - read(cvalue,*) restart_option - call ESMF_LogWrite(subname//" Restart_option = "//restart_option, & - ESMF_LOGMSG_INFO) - else - call ESMF_LogSetError(ESMF_RC_VAL_WRONG, & - msg=subname//": ERROR both restart_n and restart_option must be set ", & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return - endif - ! not used in nems - call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - read(cvalue,*) restart_ymd - call ESMF_LogWrite(subname//" Restart_ymd = "//trim(cvalue), ESMF_LOGMSG_INFO) - endif + ! If restart_n is set and non-zero, then restart_option must be available from config + if (isPresent .and. isSet) then + call ESMF_LogWrite(subname//" Restart_n = "//trim(cvalue), ESMF_LOGMSG_INFO) + read(cvalue,*) restart_n + if (restart_n /= 0) then + call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) restart_option + call ESMF_LogWrite(subname//" Restart_option = "//restart_option, & + ESMF_LOGMSG_INFO) else - ! restart_n is zero, restarts will be written at finalize only (no alarm control) - restart_mode = 'no_alarms' - call ESMF_LogWrite(subname//" Restarts will be written at finalize only", ESMF_LOGMSG_INFO) + call ESMF_LogSetError(ESMF_RC_VAL_WRONG, & + msg=subname//": ERROR both restart_n and restart_option must be set ", & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + ! not used in ufs + call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) restart_ymd + call ESMF_LogWrite(subname//" Restart_ymd = "//trim(cvalue), ESMF_LOGMSG_INFO) endif + else + ! restart_n is zero, restarts will be written at finalize only (no alarm control) + restart_mode = 'no_alarms' + call ESMF_LogWrite(subname//" Restarts will be written at finalize only", ESMF_LOGMSG_INFO) endif - endif - - if (restart_mode == 'alarms') then - call AlarmInit(mclock, & - alarm = restart_alarm, & - option = trim(restart_option), & - opt_n = restart_n, & - opt_ymd = restart_ymd, & - RefTime = mcurrTime, & - alarmname = 'restart_alarm', rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif +#ifndef CESMCOUPLED + call ESMF_TimeIntervalGet(dtimestep, s=dt_cpl, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call init_is_restart_fh(mcurrTime, dt_cpl, is_root_pe(), restartfh_info) +#endif + endif - call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_LogWrite(subname//" Restart alarm is Created and Set", ESMF_LOGMSG_INFO) - end if + if (restart_mode == 'alarms') then + call AlarmInit(mclock, & + alarm = restart_alarm, & + option = trim(restart_option), & + opt_n = restart_n, & + opt_ymd = restart_ymd, & + RefTime = mcurrTime, & + alarmname = 'restart_alarm', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! create a 1-shot alarm at the driver stop time - stop_alarm = ESMF_AlarmCreate(mclock, ringtime=dstopTime, name = "stop_alarm", rc=rc) - call ESMF_LogWrite(subname//" Create Stop alarm", ESMF_LOGMSG_INFO) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_LogWrite(subname//" Restart alarm is Created and Set", ESMF_LOGMSG_INFO) + endif + + ! create a 1-shot alarm at the driver stop time + stop_alarm = ESMF_AlarmCreate(mclock, ringtime=dstopTime, name = "stop_alarm", rc=rc) + call ESMF_LogWrite(subname//" Create Stop alarm", ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeGet(dstoptime, timestring=timestr, rc=rc) - call ESMF_LogWrite("Stop Alarm will ring at : "//trim(timestr), ESMF_LOGMSG_INFO) + call ESMF_TimeGet(dstoptime, timestring=timestr, rc=rc) + call ESMF_LogWrite("Stop Alarm will ring at : "//trim(timestr), ESMF_LOGMSG_INFO) - first_time = .false. + call outputlog_init(gcomp, mclock, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + first_time = .false. endif @@ -1958,6 +2265,8 @@ subroutine ModelSetRunClock(gcomp, rc) call ESMF_ClockSet(mclock, currTime=dcurrtime, timeStep=dtimestep, stopTime=mstoptime, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (localPet == 0) call cap_profiling("mom", "ModelSetRunClock", "E") + end subroutine ModelSetRunClock !=============================================================================== @@ -1980,12 +2289,17 @@ subroutine ocean_model_finalize(gcomp, rc) type(ESMF_Time) :: currTime type(ESMF_Alarm), allocatable :: alarmList(:) integer :: alarmCount - character(len=64) :: timestamp logical :: write_restart character(len=*),parameter :: subname='(MOM_cap:ocean_model_finalize)' + real(8) :: MPI_Wtime, timefs + + if (localPet == 0) call cap_profiling("mom", "ocean_model_finalize", "B") - write(*,*) 'MOM: --- finalize called ---' + if (is_root_pe()) then + write(stdout,*) 'MOM: --- finalize called ---' + endif rc = ESMF_SUCCESS + if (write_runtimelog) timefs = MPI_Wtime() call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -2002,20 +2316,27 @@ subroutine ocean_model_finalize(gcomp, rc) ! Do not write a restart unless mode is no_alarms if (restart_mode == 'no_alarms') then - write_restart = .true. + write_restart = .true. else - write_restart = .false. - end if - if (write_restart)call ESMF_LogWrite("No Restart Alarm, writing restart at Finalize ", & - ESMF_LOGMSG_INFO) + write_restart = .false. + endif + if (write_restart) call ESMF_LogWrite("No Restart Alarm, writing restart at Finalize ", & + ESMF_LOGMSG_INFO) call ocean_model_end(ocean_public, ocean_State, Time, write_restart=write_restart) - call field_manager_end() - call fms_io_exit() - call fms_end() + call io_infra_end() + call MOM_infra_end() + + ! need to call twice to force logging of last output file + call outputlog_run(clock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call outputlog_run(clock, .true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (write_runtimelog .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', MPI_Wtime()-timefs - write(*,*) 'MOM: --- completed ---' + if (localPet == 0) call cap_profiling("mom", "ocean_model_finalize", "E") end subroutine ocean_model_finalize @@ -2046,9 +2367,9 @@ subroutine State_SetScalar(value, scalar_id, State, mytask, scalar_name, scalar_ if (ChkErr(rc,__LINE__,u_FILE_u)) return if (scalar_id < 0 .or. scalar_id > scalar_count) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//": ERROR in scalar_id", line=__LINE__, file=__FILE__, rcToReturn=rc) - return + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//": ERROR in scalar_id", line=__LINE__, file=__FILE__, rcToReturn=rc) + return endif farrayptr(scalar_id,1) = value @@ -2057,16 +2378,17 @@ subroutine State_SetScalar(value, scalar_id, State, mytask, scalar_name, scalar_ end subroutine State_SetScalar !> Realize the import and export fields using either a grid or a mesh. -subroutine MOM_RealizeFields(state, nfields, field_defs, tag, grid, mesh, rc) - type(ESMF_State) , intent(inout) :: state !< ESMF_State object for - !! import/export fields. - integer , intent(in) :: nfields !< Number of fields. - type(fld_list_type) , intent(inout) :: field_defs(:) !< Structure with field's - !! information. - character(len=*) , intent(in) :: tag !< Import or export. - type(ESMF_Grid) , intent(in), optional :: grid!< ESMF grid. - type(ESMF_Mesh) , intent(in), optional :: mesh!< ESMF mesh. - integer , intent(inout) :: rc !< Return code. +subroutine MOM_RealizeFields(state, nfields, field_defs, tag, ice_ocean_boundary, grid, mesh, rc) + type(ESMF_State) , intent(inout) :: state !< ESMF_State object for + !! import/export fields. + integer , intent(in) :: nfields !< Number of fields. + type(fld_list_type) , intent(inout) :: field_defs(:) !< Structure with field's + !! information. + type(ice_ocean_boundary_type), intent(inout), optional :: ice_ocean_boundary !< May need to nullify atm_co2 + character(len=*) , intent(in) :: tag !< Import or export. + type(ESMF_Grid) , intent(in) , optional :: grid!< ESMF grid. + type(ESMF_Mesh) , intent(in) , optional :: mesh!< ESMF mesh. + integer , intent(inout) :: rc !< Return code. ! local variables integer :: i @@ -2085,7 +2407,7 @@ subroutine MOM_RealizeFields(state, nfields, field_defs, tag, grid, mesh, rc) if (field_defs(i)%shortname == scalar_field_name) then call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is connected on root pe.", & - ESMF_LOGMSG_INFO) + ESMF_LOGMSG_INFO) call SetScalarField(field, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -2093,32 +2415,48 @@ subroutine MOM_RealizeFields(state, nfields, field_defs, tag, grid, mesh, rc) else call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is connected.", & - ESMF_LOGMSG_INFO) + ESMF_LOGMSG_INFO) if (present(grid)) then - field = ESMF_FieldCreate(grid, ESMF_TYPEKIND_R8, indexflag=ESMF_INDEX_DELOCAL, & - name=field_defs(i)%shortname, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (field_defs(i)%ungridded_lbound > 0 .and. field_defs(i)%ungridded_ubound > 0) then + call ESMF_LogWrite(trim(subname)//": ERROR ungridded dimensions not supported in MOM6 nuopc cap when "//& + "ESMF_GEOMTYPE_GRID is used. Use ESMF_GEOMTYPE_MESH instead.", ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + else + field = ESMF_FieldCreate(grid, ESMF_TYPEKIND_R8, indexflag=ESMF_INDEX_DELOCAL, & + name=field_defs(i)%shortname, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! initialize fldptr to zero - call ESMF_FieldGet(field, farrayPtr=fldptr2d, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - fldptr2d(:,:) = 0.0 + ! initialize fldptr to zero + call ESMF_FieldGet(field, farrayPtr=fldptr2d, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + fldptr2d(:,:) = 0.0 + endif else if (present(mesh)) then - field = ESMF_FieldCreate(mesh=mesh, typekind=ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, & - name=field_defs(i)%shortname, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (field_defs(i)%ungridded_lbound > 0 .and. field_defs(i)%ungridded_ubound > 0) then + field = ESMF_FieldCreate(mesh=mesh, typekind=ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, & + name=field_defs(i)%shortname, ungriddedLbound=(/field_defs(i)%ungridded_lbound/), & + ungriddedUbound=(/field_defs(i)%ungridded_ubound/), gridToFieldMap=(/2/), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! initialize fldptr to zero - call ESMF_FieldGet(field, farrayPtr=fldptr1d, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - fldptr1d(:) = 0.0 + ! initialize fldptr to zero + call ESMF_FieldGet(field, farrayPtr=fldptr2d, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + fldptr2d(:,:) = 0.0 + else + field = ESMF_FieldCreate(mesh=mesh, typekind=ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, & + name=field_defs(i)%shortname, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! initialize fldptr to zero + call ESMF_FieldGet(field, farrayPtr=fldptr1d, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + fldptr1d(:) = 0.0 + endif endif - endif ! Realize connected field @@ -2130,6 +2468,18 @@ subroutine MOM_RealizeFields(state, nfields, field_defs, tag, grid, mesh, rc) call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is not connected.", & ESMF_LOGMSG_INFO) + if (present(ice_ocean_boundary)) then + if (trim(field_defs(i)%stdname) == 'Sa_co2prog') then + if (is_root_pe()) write(stdout,*) subname // tag // " Nullifying ice_ocean_boundary%atm_co2_prog" + deallocate(ice_ocean_boundary%atm_co2_prog) + nullify(ice_ocean_boundary%atm_co2_prog) + elseif (trim(field_defs(i)%stdname) == 'Sa_co2diag') then + if (is_root_pe()) write(stdout,*) subname // tag // " Nullifying ice_ocean_boundary%atm_co2_diag" + deallocate(ice_ocean_boundary%atm_co2_diag) + nullify(ice_ocean_boundary%atm_co2_diag) + endif + endif + ! remove a not connected Field from State call ESMF_StateRemove(state, (/field_defs(i)%shortname/), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -2165,6 +2515,11 @@ subroutine SetScalarField(field, rc) ungriddedLBound=(/1/), ungriddedUBound=(/scalar_field_count/), gridToFieldMap=(/2/), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! initialize fldptr to zero + call ESMF_FieldGet(field, farrayPtr=fldptr2d, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + fldptr2d(:,:) = 0.0 + end subroutine SetScalarField end subroutine MOM_RealizeFields @@ -2172,12 +2527,14 @@ end subroutine MOM_RealizeFields !=============================================================================== !> Set up list of field information -subroutine fld_list_add(num, fldlist, stdname, transferOffer, shortname) +subroutine fld_list_add(num, fldlist, stdname, transferOffer, shortname, ungridded_lbound, ungridded_ubound) integer, intent(inout) :: num type(fld_list_type), intent(inout) :: fldlist(:) character(len=*), intent(in) :: stdname character(len=*), intent(in) :: transferOffer character(len=*), optional, intent(in) :: shortname + integer, optional, intent(in) :: ungridded_lbound + integer, optional, intent(in) :: ungridded_ubound ! local variables integer :: rc @@ -2186,35 +2543,33 @@ subroutine fld_list_add(num, fldlist, stdname, transferOffer, shortname) ! fill in the new entry num = num + 1 if (num > fldsMax) then - call ESMF_LogSetError(ESMF_RC_VAL_OUTOFRANGE, & - msg=trim(subname)//": ERROR number of field exceeded fldsMax: "//trim(stdname), & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return + call ESMF_LogSetError(ESMF_RC_VAL_OUTOFRANGE, & + msg=trim(subname)//": ERROR number of field exceeded fldsMax: "//trim(stdname), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return endif fldlist(num)%stdname = trim(stdname) if (present(shortname)) then - fldlist(num)%shortname = trim(shortname) + fldlist(num)%shortname = trim(shortname) else - fldlist(num)%shortname = trim(stdname) + fldlist(num)%shortname = trim(stdname) endif fldlist(num)%transferOffer = trim(transferOffer) + if (present(ungridded_lbound) .and. present(ungridded_ubound)) then + fldlist(num)%ungridded_lbound = ungridded_lbound + fldlist(num)%ungridded_ubound = ungridded_ubound + endif end subroutine fld_list_add #ifndef CESMCOUPLED -subroutine shr_file_setLogUnit(nunit) +subroutine shr_log_setLogUnit(nunit) integer, intent(in) :: nunit ! do nothing for this stub - its just here to replace ! having cppdefs in the main program -end subroutine shr_file_setLogUnit - -subroutine shr_file_getLogUnit(nunit) - integer, intent(in) :: nunit - ! do nothing for this stub - its just here to replace - ! having cppdefs in the main program -end subroutine shr_file_getLogUnit +end subroutine shr_log_setLogUnit #endif !> @@ -2344,8 +2699,7 @@ end subroutine shr_file_getLogUnit !! @subsection Initialization Initialization !! !! During the [InitializeAdvertise] (@ref MOM_cap_mod::initializeadvertise) phase, calls are -!! made to MOM's native initialization subroutines, including `fms_init()`, `constants_init()`, -!! `field_manager_init()`, `diag_manager_init()`, and `set_calendar_type()`. The MPI communicator +!! made to MOM's native initialization subroutines. The MPI communicator !! is pulled in through the ESMF VM object for the MOM component. The dt and start time are set !! from parameters from the incoming ESMF clock with calls to `set_time()` and `set_date().` !! @@ -2356,7 +2710,7 @@ end subroutine shr_file_getLogUnit !! infrastructure when it's time for MOM to advance in time. During this subroutine, there is a !! call into the MOM update routine: !! -!! call update_ocean_model(Ice_ocean_boundary, Ocean_state, Ocean_public, Time, Time_step_coupled) +!! call update_ocean_model(Ice_ocean_boundary, Ocean_state, Ocean_public, Time, Time_step_coupled, cesm_coupled) !! !! Priori to the call to `update_ocean_model()`, the cap performs these steps !! - the `Time` and `Time_step_coupled` parameters, based on FMS types, are derived from the incoming ESMF clock @@ -2420,10 +2774,6 @@ end subroutine shr_file_getLogUnit !! procedures: !! !! call ocean_model_end (ocean_public, ocean_State, Time) -!! call diag_manager_end(Time ) -!! call field_manager_end -!! call fms_io_exit -!! call fms_end !! !! @section ModelFields Model Fields !! @@ -2439,7 +2789,7 @@ end subroutine shr_file_getLogUnit !! Description !! Notes !! -!! inst_pres_height_surface +!! Sa_pslv !! Pa !! p !! pressure of overlying sea ice and atmosphere @@ -2453,27 +2803,20 @@ end subroutine shr_file_getLogUnit !! !! !! -!! seaice_melt_heat +!! Fioi_melth !! W m-2 !! seaice_melt_heat !! sea ice and snow melt heat flux !! !! !! -!! seaice_melt +!! Fioi_meltw !! kg m-2 s-1 !! seaice_melt !! water flux due to sea ice and snow melting !! !! !! -!! mean_calving_heat_flx -!! W m-2 -!! calving_hflx -!! heat flux, relative to 0C, of frozen land water into ocean -!! -!! -!! !! mean_calving_rate !! kg m-2 s-1 !! calving @@ -2481,103 +2824,173 @@ end subroutine shr_file_getLogUnit !! !! !! -!! mean_evap_rate +!! Foxx_evap !! kg m-2 s-1 !! q_flux !! specific humidity flux !! !! !! -!! mean_fprec_rate +!! Faxa_snow !! kg m-2 s-1 !! fprec !! mass flux of frozen precip !! !! !! -!! mean_merid_moment_flx -!! Pa -!! v_flux -!! j-directed wind stress into ocean -!! [vector rotation] (@ref VectorRotations) applied - lat-lon to tripolar -!! -!! -!! mean_net_lw_flx +!! Foxx_lwnet !! W m-2 !! lw_flux !! long wave radiation !! !! !! -!! mean_net_sw_ir_dif_flx +!! Foxx_swnet_idf !! W m-2 !! sw_flux_nir_dif !! diffuse near IR shortwave radiation !! !! !! -!! mean_net_sw_ir_dir_flx +!! Foxx_swnet_idr !! W m-2 !! sw_flux_nir_dir !! direct near IR shortwave radiation !! !! !! -!! mean_net_sw_vis_dif_flx +!! Foxx_swnet_vdf !! W m-2 !! sw_flux_vis_dif !! diffuse visible shortware radiation !! !! !! -!! mean_net_sw_vis_dir_flx +!! Foxx_swnet_idr !! W m-2 !! sw_flux_vis_dir !! direct visible shortware radiation !! !! !! -!! mean_prec_rate +!! Faxa_rain !! kg m-2 s-1 !! lprec !! mass flux of liquid precip !! !! !! -!! mean_runoff_heat_flx +!! Foxx_hrain +!! W m-2 +!! hrain +!! heat content (enthalpy) of liquid water entering the ocean +!! +!! +!! +!! Foxx_hsnow !! W m-2 -!! runoff_hflx -!! heat flux, relative to 0C, of liquid land water into ocean +!! hsnow +!! heat content (enthalpy) of frozen water entering the ocean !! !! !! -!! mean_runoff_rate +!! Foxx_hevap +!! W m-2 +!! hevap +!! heat content (enthalpy) of water leaving the ocean +!! +!! +!! +!! Foxx_hcond +!! W m-2 +!! hcond +!! heat content (enthalpy) of liquid water entering the ocean due to condensation +!! +!! +!! +!! Foxx_hrofl +!! W m-2 +!! hrofl +!! heat content (enthalpy) of liquid runoff +!! +!! +!! +!! Foxx_hrofi +!! W m-2 +!! hrofi +!! heat content (enthalpy) of frozen runoff +!! +!! +!! +!! Foxx_rofl !! kg m-2 s-1 !! runoff !! mass flux of liquid runoff !! !! !! -!! mean_salt_rate +!! Foxx_rofi +!! kg m-2 s-1 +!! runoff +!! mass flux of frozen runoff +!! +!! +!! +!! Forr_rofl_glc +!! kg m-2 s-1 +!! runoff +!! mass flux of liquid glc runoff +!! +!! +!! +!! Forr_rofi_glc +!! kg m-2 s-1 +!! runoff +!! mass flux of frozen glc runoff +!! +!! +!! +!! Foxx_hrofi_glc +!! W m-2 +!! hrofi_glc +!! heat content (enthalpy) of frozen glc runoff +!! +!! +!! +!! Foxx_hrofl_glc +!! W m-2 +!! hrofl_glc +!! heat content (enthalpy) of liquid glc runoff +!! +!! +!! +!! Fioi_salt !! kg m-2 s-1 !! salt_flux !! salt flux !! !! !! -!! mean_sensi_heat_flx +!! Foxx_sen !! W m-2 !! t_flux !! sensible heat flux into ocean !! !! !! -!! mean_zonal_moment_flx +!! Foxx_taux !! Pa !! u_flux !! i-directed wind stress into ocean !! [vector rotation] (@ref VectorRotations) applied - lat-lon to tripolar !! +!! +!! Foxx_tauy +!! Pa +!! v_flux +!! j-directed wind stress into ocean +!! [vector rotation] (@ref VectorRotations) applied - lat-lon to tripolar +!! !! !! !! @subsection ExportField Export Fields @@ -2594,63 +3007,63 @@ end subroutine shr_file_getLogUnit !! Notes !! !! -!! freezing_melting_potential +!! Fioo_q !! W m-2 !! combination of frazil and melt_potential !! cap converts model units (J m-2) to (W m-2) for export !! !! !! -!! ocean_mask +!! So_omask !! !! !! ocean mask !! !! !! -!! ocn_current_merid +!! So_v !! m s-1 !! v_surf !! j-directed surface velocity on u-cell !! [vector rotation] (@ref VectorRotations) applied - tripolar to lat-lon !! !! -!! ocn_current_zonal +!! So_u !! m s-1 !! u_surf !! i-directed surface velocity on u-cell !! [vector rotation] (@ref VectorRotations) applied - tripolar to lat-lon !! !! -!! s_surf +!! So_s !! psu !! s_surf !! sea surface salinity on t-cell !! !! !! -!! sea_surface_temperature +!! So_t !! K !! t_surf !! sea surface temperature on t-cell !! !! !! -!! sea_surface_slope_zonal +!! So_dhdx !! unitless !! created from ssh !! sea surface zonal slope !! !! !! -!! sea_surface_slope_merid +!! So_dhy !! unitless !! created from ssh !! sea surface meridional slope !! !! !! -!! so_bldepth +!! So_bldepth !! m !! obld !! ocean surface boundary layer depth @@ -2684,7 +3097,7 @@ end subroutine shr_file_getLogUnit !! with incoming coupling fields from other components. These three derived types are allocated during the !! [InitializeAdvertise] (@ref MOM_cap_mod::initializeadvertise) phase. Also during that !! phase, the `ice_ocean_boundary` type members are all allocated using bounds retrieved -!! from `mpp_get_compute_domain()`. +!! from `get_domain_extent()`. !! !! During the [InitializeRealize] (@ref MOM_cap_mod::initializerealize) phase, !! `ESMF_Field`s are created for each of the coupling fields in the `ice_ocean_boundary` diff --git a/config_src/drivers/nuopc_cap/mom_cap_methods.F90 b/config_src/drivers/nuopc_cap/mom_cap_methods.F90 index bb9743bb84..a978b4906a 100644 --- a/config_src/drivers/nuopc_cap/mom_cap_methods.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap_methods.F90 @@ -1,4 +1,8 @@ -!> Contains import/export methods for both NEMS and CMEPS. +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Contains import/export methods for CMEPS. module MOM_cap_methods use ESMF, only: ESMF_Clock, ESMF_ClockGet, ESMF_time, ESMF_TimeGet @@ -23,7 +27,7 @@ module MOM_cap_methods use mpp_domains_mod, only: mpp_get_compute_domain ! By default make data private -implicit none; private +implicit none ; private ! Public member functions public :: mom_set_geomtype @@ -32,13 +36,17 @@ module MOM_cap_methods public :: state_diagnose public :: ChkErr -private :: State_getImport +interface State_getImport + module procedure State_getImport_2d + module procedure State_getImport_3d ! third dimension being an ungridded dimension +end interface + private :: State_setExport !> Get field pointer interface State_GetFldPtr - module procedure State_GetFldPtr_1d - module procedure State_GetFldPtr_2d + module procedure State_GetFldPtr_1d + module procedure State_GetFldPtr_2d end interface integer :: import_cnt = 0!< used to skip using the import state @@ -68,21 +76,27 @@ end subroutine mom_set_geomtype !> This function has a few purposes: !! (1) it imports surface fluxes using data from the mediator; and !! (2) it can apply restoring in SST and SSS. -subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, rc) - type(ocean_public_type) , intent(in) :: ocean_public !< Ocean surface state - type(ocean_grid_type) , intent(in) :: ocean_grid !< Ocean model grid - type(ESMF_State) , intent(inout) :: importState !< incoming data from mediator - type(ice_ocean_boundary_type) , intent(inout) :: ice_ocean_boundary !< Ocean boundary forcing - integer , intent(inout) :: rc !< Return code +!! (3) it can convert imported stokes drift components to zero if they are missing. +subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, & + set_missing_stks_to_zero, rc) + type(ocean_public_type) , intent(in) :: ocean_public !< Ocean surface state + type(ocean_grid_type) , intent(in) :: ocean_grid !< Ocean model grid + logical , intent(in) :: set_missing_stks_to_zero !< If true, set + !! missing stokes drift to zero + type(ESMF_State) , intent(inout) :: importState !< incoming data from mediator + type(ice_ocean_boundary_type) , intent(inout) :: ice_ocean_boundary !< Ocean boundary forcing + integer , intent(inout) :: rc !< Return code ! Local Variables - integer :: i, j, ig, jg, n + integer :: i, j, ib, ig, jg, n integer :: isc, iec, jsc, jec + integer :: esmf_ind + integer :: nsc ! number of stokes drift components character(len=128) :: fldname real(ESMF_KIND_R8), allocatable :: taux(:,:) real(ESMF_KIND_R8), allocatable :: tauy(:,:) - real(ESMF_KIND_R8), allocatable :: stkx1(:,:),stkx2(:,:),stkx3(:,:) - real(ESMF_KIND_R8), allocatable :: stky1(:,:),stky2(:,:),stky3(:,:) + real(ESMF_KIND_R8), allocatable :: stkx(:,:,:) + real(ESMF_KIND_R8), allocatable :: stky(:,:,:) character(len=*) , parameter :: subname = '(mom_import)' rc = ESMF_SUCCESS @@ -97,43 +111,42 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, !---- ! surface height pressure !---- - call state_getimport(importState, 'inst_pres_height_surface', & - isc, iec, jsc, jec, ice_ocean_boundary%p, rc=rc) + call state_getimport(importState, 'Sa_pslv', isc, iec, jsc, jec, ice_ocean_boundary%p, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! near-IR, direct shortwave (W/m2) !---- - call state_getimport(importState, 'mean_net_sw_ir_dir_flx', & - isc, iec, jsc, jec, ice_ocean_boundary%sw_flux_nir_dir, areacor=med2mod_areacor, rc=rc) + call state_getimport(importState, 'Foxx_swnet_idr', isc, iec, jsc, jec, & + ice_ocean_boundary%sw_flux_nir_dir, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! near-IR, diffuse shortwave (W/m2) !---- - call state_getimport(importState, 'mean_net_sw_ir_dif_flx', & - isc, iec, jsc, jec, ice_ocean_boundary%sw_flux_nir_dif, areacor=med2mod_areacor, rc=rc) + call state_getimport(importState, 'Foxx_swnet_idf', isc, iec, jsc, jec, & + ice_ocean_boundary%sw_flux_nir_dif, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! visible, direct shortwave (W/m2) !---- - call state_getimport(importState, 'mean_net_sw_vis_dir_flx', & - isc, iec, jsc, jec, ice_ocean_boundary%sw_flux_vis_dir, areacor=med2mod_areacor, rc=rc) + call state_getimport(importState, 'Foxx_swnet_vdr', isc, iec, jsc, jec, & + ice_ocean_boundary%sw_flux_vis_dir, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! visible, diffuse shortwave (W/m2) !---- - call state_getimport(importState, 'mean_net_sw_vis_dif_flx', & - isc, iec, jsc, jec, ice_ocean_boundary%sw_flux_vis_dif, areacor=med2mod_areacor, rc=rc) + call state_getimport(importState, 'Foxx_swnet_vdf', isc, iec, jsc, jec, & + ice_ocean_boundary%sw_flux_vis_dif, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! ------- ! Net longwave radiation (W/m2) ! ------- - call state_getimport(importState, 'mean_net_lw_flx', & - isc, iec, jsc, jec, ice_ocean_boundary%lw_flux, areacor=med2mod_areacor, rc=rc) + call state_getimport(importState, 'Foxx_lwnet', isc, iec, jsc, jec, & + ice_ocean_boundary%lw_flux, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- @@ -142,23 +155,23 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, allocate (taux(isc:iec,jsc:jec)) allocate (tauy(isc:iec,jsc:jec)) - call state_getimport(importState, 'mean_zonal_moment_flx', isc, iec, jsc, jec, taux, & + call state_getimport(importState, 'Foxx_taux', isc, iec, jsc, jec, taux, & areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'mean_merid_moment_flx', isc, iec, jsc, jec, tauy, & + call state_getimport(importState, 'Foxx_tauy', isc, iec, jsc, jec, tauy, & areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! rotate taux and tauy from true zonal/meridional to local coordinates do j = jsc, jec - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - ig = i + ocean_grid%isc - isc - ice_ocean_boundary%u_flux(i,j) = ocean_grid%cos_rot(ig,jg)*taux(i,j) & - - ocean_grid%sin_rot(ig,jg)*tauy(i,j) - ice_ocean_boundary%v_flux(i,j) = ocean_grid%cos_rot(ig,jg)*tauy(i,j) & - + ocean_grid%sin_rot(ig,jg)*taux(i,j) - enddo + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + ice_ocean_boundary%u_flux(i,j) = ocean_grid%cos_rot(ig,jg)*taux(i,j) & + - ocean_grid%sin_rot(ig,jg)*tauy(i,j) + ice_ocean_boundary%v_flux(i,j) = ocean_grid%cos_rot(ig,jg)*tauy(i,j) & + + ocean_grid%sin_rot(ig,jg)*taux(i,j) + enddo enddo deallocate(taux, tauy) @@ -166,29 +179,29 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, !---- ! sensible heat flux (W/m2) !---- - call state_getimport(importState, 'mean_sensi_heat_flx', & - isc, iec, jsc, jec, ice_ocean_boundary%t_flux, areacor=med2mod_areacor, rc=rc) + call state_getimport(importState, 'Foxx_sen', isc, iec, jsc, jec, & + ice_ocean_boundary%t_flux, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! evaporation flux (W/m2) !---- - call state_getimport(importState, 'mean_evap_rate', & - isc, iec, jsc, jec, ice_ocean_boundary%q_flux, areacor=med2mod_areacor, rc=rc) + call state_getimport(importState, 'Foxx_evap', isc, iec, jsc, jec, & + ice_ocean_boundary%q_flux, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! liquid precipitation (rain) !---- - call state_getimport(importState, 'mean_prec_rate', & - isc, iec, jsc, jec, ice_ocean_boundary%lprec, areacor=med2mod_areacor, rc=rc) + call state_getimport(importState, 'Faxa_rain', isc, iec, jsc, jec, & + ice_ocean_boundary%lprec, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! frozen precipitation (snow) !---- - call state_getimport(importState, 'mean_fprec_rate', & - isc, iec, jsc, jec, ice_ocean_boundary%fprec, areacor=med2mod_areacor, rc=rc) + call state_getimport(importState, 'Faxa_snow', isc, iec, jsc, jec, & + ice_ocean_boundary%fprec, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- @@ -209,40 +222,272 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, isc, iec, jsc, jec, ice_ocean_boundary%frunoff, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! heat content of lrunoff - ice_ocean_boundary%lrunoff_hflx(:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'mean_runoff_heat_flx', & - isc, iec, jsc, jec, ice_ocean_boundary%lrunoff_hflx, areacor=med2mod_areacor, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! liquid glc runoff + if ( associated(ice_ocean_boundary%lrunoff_glc) ) then + ice_ocean_boundary%lrunoff_glc (:,:) = 0._ESMF_KIND_R8 + call state_getimport(importState, 'Forr_rofl_glc', & + isc, iec, jsc, jec, ice_ocean_boundary%lrunoff_glc, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + ! frozen glc runoff + if ( associated(ice_ocean_boundary%frunoff_glc) ) then + ice_ocean_boundary%frunoff_glc (:,:) = 0._ESMF_KIND_R8 + call state_getimport(importState, 'Forr_rofi_glc', & + isc, iec, jsc, jec, ice_ocean_boundary%frunoff_glc, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + !---- + ! Enthalpy terms + !---- + + !---- + ! enthalpy from liquid precipitation (hrain) + !---- + if ( associated(ice_ocean_boundary%hrain) ) then + call state_getimport(importState, 'Foxx_hrain', isc, iec, jsc, jec, & + ice_ocean_boundary%hrain, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + !---- + ! enthalpy from frozen precipitation (hsnow) + !---- + if ( associated(ice_ocean_boundary%hsnow) ) then + call state_getimport(importState, 'Foxx_hsnow', isc, iec, jsc, jec, & + ice_ocean_boundary%hsnow, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + !---- + ! enthalpy from liquid runoff (hrofl) + !---- + if ( associated(ice_ocean_boundary%hrofl) ) then + call state_getimport(importState, 'Foxx_hrofl', isc, iec, jsc, jec, & + ice_ocean_boundary%hrofl, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + !---- + ! enthalpy from frozen runoff (hrofi) + !---- + if ( associated(ice_ocean_boundary%hrofi) ) then + call state_getimport(importState, 'Foxx_hrofi', isc, iec, jsc, jec, & + ice_ocean_boundary%hrofi, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + !---- + ! enthalpy from liquid glc runoff (hrofl_glc) + !---- + if ( associated(ice_ocean_boundary%hrofl_glc) ) then + call state_getimport(importState, 'Foxx_hrofl_glc', isc, iec, jsc, jec, & + ice_ocean_boundary%hrofl_glc, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + !---- + ! enthalpy from frozen glc runoff (hrofi_glc) + !---- + if ( associated(ice_ocean_boundary%hrofi_glc) ) then + call state_getimport(importState, 'Foxx_hrofi_glc', isc, iec, jsc, jec, & + ice_ocean_boundary%hrofi_glc, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + !---- + ! enthalpy from evaporation (hevap) + !---- + if ( associated(ice_ocean_boundary%hevap) ) then + call state_getimport(importState, 'Foxx_hevap', isc, iec, jsc, jec, & + ice_ocean_boundary%hevap, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + !---- + ! enthalpy from condensation (hcond) + !---- + if ( associated(ice_ocean_boundary%hcond) ) then + call state_getimport(importState, 'Foxx_hcond', isc, iec, jsc, jec, & + ice_ocean_boundary%hcond, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + !--------------! + ! MARBL fields ! + !--------------! + + ! seaice_dust_flux, nhx_dep, and noy_dep are single fields from the coupler + ! atm_fine_dust_flux, atm_coarse_dust_flux, atm_bc_flux, and seaice_bc_flux + ! are all sums of multiple fields and will be treated slightly differently + ! For those fields, we use do_sum = .true. + + !---- + ! nhx deposition + !---- + if (associated(ice_ocean_boundary%nhx_dep)) then + call state_getimport(importState, 'Faxa_ndep', & + isc, iec, jsc, jec, ice_ocean_boundary%nhx_dep(:,:), & + areacor=med2mod_areacor, esmf_ind=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + !---- + ! noy deposition + !---- + if (associated(ice_ocean_boundary%noy_dep)) then + call state_getimport(importState, 'Faxa_ndep', & + isc, iec, jsc, jec, ice_ocean_boundary%noy_dep(:,:), & + areacor=med2mod_areacor, esmf_ind=2, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif - ! heat content of frunoff - ice_ocean_boundary%frunoff_hflx(:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'mean_calving_heat_flx', & - isc, iec, jsc, jec, ice_ocean_boundary%frunoff_hflx, areacor=med2mod_areacor, rc=rc) + !---- + ! atmospheric CO2 concentration + ! might not be passed from atmosphere component, + ! in which the pointer(s) will not be associated + !---- + if (associated(ice_ocean_boundary%atm_co2_prog)) then + call state_getimport(importState, 'Sa_co2prog', & + isc, iec, jsc, jec, ice_ocean_boundary%atm_co2_prog(:,:), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + if (associated(ice_ocean_boundary%atm_co2_diag)) then + call state_getimport(importState, 'Sa_co2diag', & + isc, iec, jsc, jec, ice_ocean_boundary%atm_co2_diag(:,:), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + endif + + !---- + ! fine dust flux from atmosphere + !---- + if (associated(ice_ocean_boundary%atm_fine_dust_flux)) then + ice_ocean_boundary%atm_fine_dust_flux(:,:) = 0._ESMF_KIND_R8 + call state_getimport(importState, 'Faxa_dstwet', & + isc, iec, jsc, jec, ice_ocean_boundary%atm_fine_dust_flux(:,:), & + areacor=med2mod_areacor, do_sum=.true., esmf_ind=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport(importState, 'Faxa_dstdry', & + isc, iec, jsc, jec, ice_ocean_boundary%atm_fine_dust_flux(:,:), & + areacor=med2mod_areacor, do_sum=.true., esmf_ind=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + !---- + ! coarse dust flux from atmosphere + !---- + if (associated(ice_ocean_boundary%atm_coarse_dust_flux)) then + ice_ocean_boundary%atm_coarse_dust_flux(:,:) = 0._ESMF_KIND_R8 + do esmf_ind=2,4 + call state_getimport(importState, 'Faxa_dstwet', & + isc, iec, jsc, jec, ice_ocean_boundary%atm_coarse_dust_flux(:,:), & + areacor=med2mod_areacor, do_sum=.true., esmf_ind=esmf_ind, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport(importState, 'Faxa_dstdry', & + isc, iec, jsc, jec, ice_ocean_boundary%atm_coarse_dust_flux(:,:), & + areacor=med2mod_areacor, do_sum=.true., esmf_ind=esmf_ind, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + enddo + endif + + !---- + ! dust flux from sea ice + !---- + if (associated(ice_ocean_boundary%seaice_dust_flux)) then + call state_getimport(importState, 'Fioi_flxdst', & + isc, iec, jsc, jec, ice_ocean_boundary%seaice_dust_flux, & + areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + !---- + ! black carbon flux from atmosphere + !---- + if (associated(ice_ocean_boundary%atm_bc_flux)) then + ice_ocean_boundary%atm_bc_flux(:,:) = 0._ESMF_KIND_R8 + do esmf_ind=1,3 + call state_getimport(importState, 'Faxa_bcph', & + isc, iec, jsc, jec, ice_ocean_boundary%atm_bc_flux(:,:), & + areacor=med2mod_areacor, do_sum=.true., esmf_ind=esmf_ind, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + enddo + endif + + !---- + ! black carbon flux from sea ice + !---- + if (associated(ice_ocean_boundary%seaice_bc_flux)) then + ice_ocean_boundary%seaice_bc_flux(:,:) = 0._ESMF_KIND_R8 + call state_getimport(importState, 'Fioi_bcpho', & + isc, iec, jsc, jec, ice_ocean_boundary%seaice_bc_flux(:,:), & + areacor=med2mod_areacor, do_sum=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport(importState, 'Fioi_bcphi', & + isc, iec, jsc, jec, ice_ocean_boundary%seaice_bc_flux(:,:), & + areacor=med2mod_areacor, do_sum=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + ! Fields coming from coupler per ice category + if (ice_ocean_boundary%ice_ncat > 0) then + call state_getimport(importState, 'Sf_afracr', & + isc, iec, jsc, jec, ice_ocean_boundary%afracr(:,:), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + + call state_getimport(importState, 'Foxx_swnet_afracr', & + isc, iec, jsc, jec, ice_ocean_boundary%swnet_afracr(:,:), & + areacor=med2mod_areacor, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + + call state_getimport(importState, 'Fioi_swpen_ifrac_n', & + isc, iec, jsc, jec, 1, ice_ocean_boundary%ice_ncat, & + ice_ocean_boundary%swpen_ifrac_n(:,:,:), & + areacor=med2mod_areacor, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + + call state_getimport(importState, 'Si_ifrac_n', & + isc, iec, jsc, jec, 1, ice_ocean_boundary%ice_ncat, & + ice_ocean_boundary%ifrac_n(:,:,:), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + endif ! multiple ice categories !---- ! salt flux from ice !---- ice_ocean_boundary%salt_flux(:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'mean_salt_rate', & - isc, iec, jsc, jec, ice_ocean_boundary%salt_flux, areacor=med2mod_areacor, rc=rc) + call state_getimport(importState, 'Fioi_salt', isc, iec, jsc, jec, & + ice_ocean_boundary%salt_flux, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! snow&ice melt heat flux (W/m^2) !---- ice_ocean_boundary%seaice_melt_heat(:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'net_heat_flx_to_ocn', & - isc, iec, jsc, jec, ice_ocean_boundary%seaice_melt_heat, areacor=med2mod_areacor, rc=rc) + call state_getimport(importState, 'Fioi_melth', isc, iec, jsc, jec, & + ice_ocean_boundary%seaice_melt_heat, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! snow&ice melt water flux (W/m^2) !---- ice_ocean_boundary%seaice_melt(:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'mean_fresh_water_to_ocean_rate', & - isc, iec, jsc, jec, ice_ocean_boundary%seaice_melt, areacor=med2mod_areacor, rc=rc) + call state_getimport(importState, 'Fioi_meltw', isc, iec, jsc, jec, & + ice_ocean_boundary%seaice_melt, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- @@ -251,83 +496,81 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, ! Note - preset values to 0, if field does not exist in importState, then will simply return ! and preset value will be used ice_ocean_boundary%mi(:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'mass_of_overlying_ice', & - isc, iec, jsc, jec, ice_ocean_boundary%mi,rc=rc) + call state_getimport(importState, 'mass_of_overlying_ice', isc, iec, jsc, jec, & + ice_ocean_boundary%mi,rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! sea-ice fraction !---- ice_ocean_boundary%ice_fraction(:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'Si_ifrac', & - isc, iec, jsc, jec, ice_ocean_boundary%ice_fraction, rc=rc) + call state_getimport(importState, 'Si_ifrac', isc, iec, jsc, jec, & + ice_ocean_boundary%ice_fraction, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! 10m wind squared !---- ice_ocean_boundary%u10_sqr(:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'So_duu10n', & - isc, iec, jsc, jec, ice_ocean_boundary%u10_sqr, rc=rc) + call state_getimport(importState, 'So_duu10n', isc, iec, jsc, jec, & + ice_ocean_boundary%u10_sqr, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! Langmuir enhancement factor !---- if ( associated(ice_ocean_boundary%lamult) ) then - ice_ocean_boundary%lamult (:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'Sw_lamult', & - isc, iec, jsc, jec, ice_ocean_boundary%lamult, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - endif + ice_ocean_boundary%lamult (:,:) = 0._ESMF_KIND_R8 + call state_getimport(importState, 'Sw_lamult', isc, iec, jsc, jec, & + ice_ocean_boundary%lamult, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif !---- ! Partitioned Stokes Drift Components !---- if ( associated(ice_ocean_boundary%ustkb) ) then - allocate(stkx1(isc:iec,jsc:jec)) - allocate(stky1(isc:iec,jsc:jec)) - allocate(stkx2(isc:iec,jsc:jec)) - allocate(stky2(isc:iec,jsc:jec)) - allocate(stkx3(isc:iec,jsc:jec)) - allocate(stky3(isc:iec,jsc:jec)) - - call state_getimport(importState,'eastward_partitioned_stokes_drift_1' , isc, iec, jsc, jec, stkx1,rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState,'northward_partitioned_stokes_drift_1', isc, iec, jsc, jec, stky1,rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState,'eastward_partitioned_stokes_drift_2' , isc, iec, jsc, jec, stkx2,rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState,'northward_partitioned_stokes_drift_2', isc, iec, jsc, jec, stky2,rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState,'eastward_partitioned_stokes_drift_3' , isc, iec, jsc, jec, stkx3,rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState,'northward_partitioned_stokes_drift_3', isc, iec, jsc, jec, stky3,rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! rotate from true zonal/meridional to local coordinates - do j = jsc, jec - jg = j + ocean_grid%jsc - jsc - do i = isc, iec + nsc = Ice_ocean_boundary%num_stk_bands + allocate(stkx(isc:iec,jsc:jec,1:nsc)) + allocate(stky(isc:iec,jsc:jec,1:nsc)) + + call state_getimport(importState,'Sw_pstokes_x', isc, iec, jsc, jec, 1, nsc, stkx, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport(importState,'Sw_pstokes_y', isc, iec, jsc, jec, 1, nsc, stky, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! rotate from true zonal/meridional to local coordinates + do j = jsc, jec + jg = j + ocean_grid%jsc - jsc + do i = isc, iec ig = i + ocean_grid%isc - isc - ice_ocean_boundary%ustkb(i,j,1) = ocean_grid%cos_rot(ig,jg)*stkx1(i,j) & - - ocean_grid%sin_rot(ig,jg)*stky1(i,j) - ice_ocean_boundary%vstkb(i,j,1) = ocean_grid%cos_rot(ig,jg)*stky1(i,j) & - + ocean_grid%sin_rot(ig,jg)*stkx1(i,j) - - ice_ocean_boundary%ustkb(i,j,2) = ocean_grid%cos_rot(ig,jg)*stkx2(i,j) & - - ocean_grid%sin_rot(ig,jg)*stky2(i,j) - ice_ocean_boundary%vstkb(i,j,2) = ocean_grid%cos_rot(ig,jg)*stky2(i,j) & - + ocean_grid%sin_rot(ig,jg)*stkx2(i,j) - - ice_ocean_boundary%ustkb(i,j,3) = ocean_grid%cos_rot(ig,jg)*stkx3(i,j) & - - ocean_grid%sin_rot(ig,jg)*stky3(i,j) - ice_ocean_boundary%vstkb(i,j,3) = ocean_grid%cos_rot(ig,jg)*stky3(i,j) & - + ocean_grid%sin_rot(ig,jg)*stkx3(i,j) - enddo - enddo - - deallocate(stkx1,stkx2,stkx3,stky1,stky2,stky3) + !rotate + if (set_missing_stks_to_zero) then + do ib = 1, nsc + if ((abs(stkx(i,j,ib)-9.99E20_ESMF_KIND_R8) <= 0.01_ESMF_KIND_R8)) then + ice_ocean_boundary%ustkb(i,j,ib) = 0.0 + ice_ocean_boundary%vstkb(i,j,ib) = 0.0 + else + ice_ocean_boundary%ustkb(i,j,ib) = ocean_grid%cos_rot(ig,jg)*stkx(i,j,ib) & + - ocean_grid%sin_rot(ig,jg)*stky(i,j,ib) + ice_ocean_boundary%vstkb(i,j,ib) = ocean_grid%cos_rot(ig,jg)*stky(i,j,ib) & + + ocean_grid%sin_rot(ig,jg)*stkx(i,j,ib) + endif + enddo + else + do ib = 1, nsc + ice_ocean_boundary%ustkb(i,j,ib) = ocean_grid%cos_rot(ig,jg)*stkx(i,j,ib) & + - ocean_grid%sin_rot(ig,jg)*stky(i,j,ib) + ice_ocean_boundary%vstkb(i,j,ib) = ocean_grid%cos_rot(ig,jg)*stky(i,j,ib) & + + ocean_grid%sin_rot(ig,jg)*stkx(i,j,ib) + enddo + endif + ! apply masks + ice_ocean_boundary%ustkb(i,j,:) = ice_ocean_boundary%ustkb(i,j,:) * ocean_grid%mask2dT(ig,jg) + ice_ocean_boundary%vstkb(i,j,:) = ice_ocean_boundary%vstkb(i,j,:) * ocean_grid%mask2dT(ig,jg) + enddo + enddo + deallocate(stkx,stky) endif end subroutine mom_import @@ -374,9 +617,9 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, ! Use Adcroft's rule of reciprocals; it does the right thing here. if (real(dt_int) > 0.0) then - inv_dt_int = 1.0 / real(dt_int) + inv_dt_int = 1.0 / real(dt_int) else - inv_dt_int = 0.0 + inv_dt_int = 0.0 endif !---------------- @@ -391,15 +634,14 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, allocate(omask(isc:iec, jsc:jec)) do j = jsc, jec - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - ig = i + ocean_grid%isc - isc - omask(i,j) = nint(ocean_grid%mask2dT(ig,jg)) - enddo + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + omask(i,j) = nint(ocean_grid%mask2dT(ig,jg)) + enddo enddo - call State_SetExport(exportState, 'ocean_mask', & - isc, iec, jsc, jec, omask, ocean_grid, rc=rc) + call State_SetExport(exportState, 'So_omask', isc, iec, jsc, jec, omask, ocean_grid, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return deallocate(omask) @@ -407,15 +649,13 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, ! ------- ! Sea surface temperature ! ------- - call State_SetExport(exportState, 'sea_surface_temperature', & - isc, iec, jsc, jec, ocean_public%t_surf, ocean_grid, rc=rc) + call State_SetExport(exportState, 'So_t', isc, iec, jsc, jec, ocean_public%t_surf, ocean_grid, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! ------- ! Sea surface salinity ! ------- - call State_SetExport(exportState, 's_surf', & - isc, iec, jsc, jec, ocean_public%s_surf, ocean_grid, rc=rc) + call State_SetExport(exportState, 'So_s', isc, iec, jsc, jec, ocean_public%s_surf, ocean_grid, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! ------- @@ -431,22 +671,20 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, allocate(ocm_rot(isc:iec, jsc:jec)) do j = jsc, jec - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - ig = i + ocean_grid%isc - isc - ocz(i,j) = ocean_public%u_surf(i,j) - ocm(i,j) = ocean_public%v_surf(i,j) - ocz_rot(i,j) = ocean_grid%cos_rot(ig,jg)*ocz(i,j) + ocean_grid%sin_rot(ig,jg)*ocm(i,j) - ocm_rot(i,j) = ocean_grid%cos_rot(ig,jg)*ocm(i,j) - ocean_grid%sin_rot(ig,jg)*ocz(i,j) - enddo + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + ocz(i,j) = ocean_public%u_surf(i,j) + ocm(i,j) = ocean_public%v_surf(i,j) + ocz_rot(i,j) = ocean_grid%cos_rot(ig,jg)*ocz(i,j) + ocean_grid%sin_rot(ig,jg)*ocm(i,j) + ocm_rot(i,j) = ocean_grid%cos_rot(ig,jg)*ocm(i,j) - ocean_grid%sin_rot(ig,jg)*ocz(i,j) + enddo enddo - call State_SetExport(exportState, 'ocn_current_zonal', & - isc, iec, jsc, jec, ocz_rot, ocean_grid, rc=rc) + call State_SetExport(exportState, 'So_u', isc, iec, jsc, jec, ocz_rot, ocean_grid, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call State_SetExport(exportState, 'ocn_current_merid', & - isc, iec, jsc, jec, ocm_rot, ocean_grid, rc=rc) + call State_SetExport(exportState, 'So_v', isc, iec, jsc, jec, ocm_rot, ocean_grid, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return deallocate(ocz, ocm, ocz_rot, ocm_rot) @@ -456,9 +694,9 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, ! ------- call ESMF_StateGet(exportState, 'So_bldepth', itemFlag, rc=rc) if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then - call State_SetExport(exportState, 'So_bldepth', & - isc, iec, jsc, jec, ocean_public%obld, ocean_grid, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call State_SetExport(exportState, 'So_bldepth', isc, iec, jsc, jec, & + ocean_public%obld, ocean_grid, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return endif ! ------- @@ -470,18 +708,18 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, allocate(melt_potential(isc:iec, jsc:jec)) do j = jsc,jec - do i = isc,iec - if (ocean_public%frazil(i,j) > 0.0) then - melt_potential(i,j) = ocean_public%frazil(i,j) * inv_dt_int - else - melt_potential(i,j) = -ocean_public%melt_potential(i,j) * inv_dt_int - if (melt_potential(i,j) > 0.0) melt_potential(i,j) = 0.0 - endif - enddo + do i = isc,iec + if (ocean_public%frazil(i,j) > 0.0) then + melt_potential(i,j) = ocean_public%frazil(i,j) * inv_dt_int + else + melt_potential(i,j) = -ocean_public%melt_potential(i,j) * inv_dt_int + if (melt_potential(i,j) > 0.0) melt_potential(i,j) = 0.0 + endif + enddo enddo - call State_SetExport(exportState, 'freezing_melting_potential', & - isc, iec, jsc, jec, melt_potential, ocean_grid, areacor=mod2med_areacor, rc=rc) + call State_SetExport(exportState, 'Fioo_q', isc, iec, jsc, jec, & + melt_potential, ocean_grid, areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return deallocate(melt_potential) @@ -491,32 +729,29 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, ! ------- call ESMF_StateGet(exportState, 'sea_level', itemFlag, rc=rc) if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then - call State_SetExport(exportState, 'sea_level', & - isc, iec, jsc, jec, ocean_public%sea_lev, ocean_grid, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call State_SetExport(exportState, 'sea_level', & + isc, iec, jsc, jec, ocean_public%sea_lev, ocean_grid, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return endif !---------------- ! Sea-surface zonal and meridional slopes !---------------- - allocate(ssh(ocean_grid%isd:ocean_grid%ied,ocean_grid%jsd:ocean_grid%jed)) ! local indices with halos - allocate(dhdx(isc:iec, jsc:jec)) !global indices without halos - allocate(dhdy(isc:iec, jsc:jec)) !global indices without halos + allocate(ssh(ocean_grid%isd:ocean_grid%ied,ocean_grid%jsd:ocean_grid%jed), & ! local indices with halos + dhdx(isc:iec, jsc:jec), & !global indices without halos + dhdy(isc:iec, jsc:jec), & !global indices without halos + source=0.0_ESMF_KIND_R8) allocate(dhdx_rot(isc:iec, jsc:jec)) !global indices without halos allocate(dhdy_rot(isc:iec, jsc:jec)) !global indices without halos - ssh = 0.0_ESMF_KIND_R8 - dhdx = 0.0_ESMF_KIND_R8 - dhdy = 0.0_ESMF_KIND_R8 - ! Make a copy of ssh in order to do a halo update (ssh has local indexing with halos) do j = ocean_grid%jsc, ocean_grid%jec - jloc = j + ocean_grid%jdg_offset - do i = ocean_grid%isc,ocean_grid%iec - iloc = i + ocean_grid%idg_offset - ssh(i,j) = ocean_public%sea_lev(iloc,jloc) - enddo + jloc = j + ocean_grid%jdg_offset + do i = ocean_grid%isc,ocean_grid%iec + iloc = i + ocean_grid%idg_offset + ssh(i,j) = ocean_public%sea_lev(iloc,jloc) + enddo enddo ! Update halo of ssh so we can calculate gradients (local indexing) @@ -559,7 +794,7 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, do jglob = jsc, jec j = jglob + ocean_grid%jsc - jsc do iglob = isc,iec - i = iglob + ocean_grid%isc - isc + i = iglob + ocean_grid%isc - isc ! This is a PLM slope which might be less prone to the A-ocean_grid null mode slp_L = ssh(i,J) - ssh(i,J-1) * ocean_grid%mask2dCv(i,j-1) if (ocean_grid%mask2dCv(i,j-1)==0.) slp_L = 0. @@ -586,22 +821,30 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, ! "ocean_grid" uses has halos and uses local indexing. do j = jsc, jec - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - ig = i + ocean_grid%isc - isc - dhdx_rot(i,j) = ocean_grid%cos_rot(ig,jg)*dhdx(i,j) + ocean_grid%sin_rot(ig,jg)*dhdy(i,j) - dhdy_rot(i,j) = ocean_grid%cos_rot(ig,jg)*dhdy(i,j) - ocean_grid%sin_rot(ig,jg)*dhdx(i,j) - enddo + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + dhdx_rot(i,j) = ocean_grid%cos_rot(ig,jg)*dhdx(i,j) + ocean_grid%sin_rot(ig,jg)*dhdy(i,j) + dhdy_rot(i,j) = ocean_grid%cos_rot(ig,jg)*dhdy(i,j) - ocean_grid%sin_rot(ig,jg)*dhdx(i,j) + enddo enddo - call State_SetExport(exportState, 'sea_surface_slope_zonal', & - isc, iec, jsc, jec, dhdx_rot, ocean_grid, rc=rc) + call State_SetExport(exportState, 'So_dhdx', isc, iec, jsc, jec, dhdx_rot, ocean_grid, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call State_SetExport(exportState, 'sea_surface_slope_merid', & - isc, iec, jsc, jec, dhdy_rot, ocean_grid, rc=rc) + call State_SetExport(exportState, 'So_dhdy', isc, iec, jsc, jec, dhdy_rot, ocean_grid, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! ------- + ! CO2 Flux + ! ------- + call ESMF_StateGet(exportState, 'Faoo_fco2_ocn', itemFlag, rc=rc) + if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then + call State_SetExport(exportState, 'Faoo_fco2_ocn', isc, iec, jsc, jec, & + ocean_public%fco2_ocn, ocean_grid, areacor=mod2med_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + deallocate(ssh, dhdx, dhdy, dhdx_rot, dhdy_rot) end subroutine mom_export @@ -648,8 +891,8 @@ subroutine State_GetFldPtr_2d(State, fldname, fldptr, rc) end subroutine State_GetFldPtr_2d -!> Map import state field to output array -subroutine State_GetImport(state, fldname, isc, iec, jsc, jec, output, do_sum, areacor, rc) +!> Map 2d import state field to output array +subroutine State_GetImport_2d(state, fldname, isc, iec, jsc, jec, output, do_sum, areacor, esmf_ind, rc) type(ESMF_State) , intent(in) :: state !< ESMF state character(len=*) , intent(in) :: fldname !< Field name integer , intent(in) :: isc !< The start i-index of cell centers within @@ -664,74 +907,165 @@ subroutine State_GetImport(state, fldname, isc, iec, jsc, jec, output, do_sum, a logical, optional , intent(in) :: do_sum !< If true, sums the data real (ESMF_KIND_R8), optional, intent(in) :: areacor(:) !< flux area correction factors !! applicable to meshes + integer, optional, intent(in) :: esmf_ind integer , intent(out) :: rc !< Return code ! local variables type(ESMF_StateItem_Flag) :: itemFlag integer :: n, i, j, i1, j1 integer :: lbnd1,lbnd2 + logical :: do_sum_loc real(ESMF_KIND_R8), pointer :: dataPtr1d(:) real(ESMF_KIND_R8), pointer :: dataPtr2d(:,:) - character(len=*) , parameter :: subname='(MOM_cap_methods:state_getimport)' + character(len=*) , parameter :: subname='(MOM_cap_methods:state_getimport_2d)' ! ---------------------------------------------- rc = ESMF_SUCCESS + if (present(do_sum)) then + do_sum_loc = do_sum + else + do_sum_loc = .false. + endif call ESMF_StateGet(State, trim(fldname), itemFlag, rc=rc) if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then - if (geomtype == ESMF_GEOMTYPE_MESH) then + if (geomtype == ESMF_GEOMTYPE_MESH) then - ! get field pointer - call state_getfldptr(state, trim(fldname), dataptr1d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! get field pointer + if (present(esmf_ind)) then + call state_getfldptr(state, trim(fldname), dataptr2d, rc) + dataptr1d => dataptr2d(esmf_ind,:) + else + call state_getfldptr(state, trim(fldname), dataptr1d, rc) + endif + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! determine output array and apply area correction if present + n = 0 + do j = jsc,jec + do i = isc,iec + n = n + 1 + if (do_sum_loc) then + if (present(areacor)) then + output(i,j) = output(i,j) + dataPtr1d(n) * areacor(n) + else + output(i,j) = output(i,j) + dataPtr1d(n) + endif + else + if (present(areacor)) then + output(i,j) = dataPtr1d(n) * areacor(n) + else + output(i,j) = dataPtr1d(n) + endif + endif + enddo + enddo - ! determine output array and apply area correction if present - n = 0 - do j = jsc,jec - do i = isc,iec - n = n + 1 - if (present(do_sum)) then - if (present(areacor)) then - output(i,j) = output(i,j) + dataPtr1d(n) * areacor(n) - else - output(i,j) = output(i,j) + dataPtr1d(n) - end if - else - if (present(areacor)) then - output(i,j) = dataPtr1d(n) * areacor(n) - else - output(i,j) = dataPtr1d(n) - end if - endif - enddo + elseif (geomtype == ESMF_GEOMTYPE_GRID) then + + call state_getfldptr(state, trim(fldname), dataptr2d, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + lbnd1 = lbound(dataPtr2d,1) + lbnd2 = lbound(dataPtr2d,2) + + do j = jsc, jec + j1 = j + lbnd2 - jsc + do i = isc, iec + i1 = i + lbnd1 - isc + if (do_sum_loc) then + output(i,j) = output(i,j) + dataPtr2d(i1,j1) + else + output(i,j) = dataPtr2d(i1,j1) + endif enddo + enddo - else if (geomtype == ESMF_GEOMTYPE_GRID) then + endif + + endif + +end subroutine State_GetImport_2d + +!> Map 3d import state field to output array (where 3rd dim is an ungridded dimension) +subroutine State_GetImport_3d(state, fldname, isc, iec, jsc, jec, lbd, ubd, output, do_sum, areacor, rc) + type(ESMF_State) , intent(in) :: state !< ESMF state + character(len=*) , intent(in) :: fldname !< Field name + integer , intent(in) :: isc !< The start i-index of cell centers within + !! the computational domain + integer , intent(in) :: iec !< The end i-index of cell centers within the + !! computational domain + integer , intent(in) :: jsc !< The start j-index of cell centers within + !! the computational domain + integer , intent(in) :: jec !< The end j-index of cell centers within + !! the computational domain + integer , intent(in) :: lbd !< lower bound of ungridded dimension + integer , intent(in) :: ubd !< upper bound of ungridded dimension + real (ESMF_KIND_R8) , intent(inout) :: output(isc:iec,jsc:jec,lbd:ubd)!< Output 3D array + logical, optional , intent(in) :: do_sum !< If true, sums the data + real (ESMF_KIND_R8), optional, intent(in) :: areacor(:) !< flux area correction factors + !! applicable to meshes + integer , intent(out) :: rc !< Return code + + ! local variables + type(ESMF_StateItem_Flag) :: itemFlag + integer :: n, i, j, i1, j1, u + integer :: lbnd1,lbnd2 + logical :: do_sum_loc + real(ESMF_KIND_R8), pointer :: dataPtr2d(:,:) + character(len=*) , parameter :: subname='(MOM_cap_methods:state_getimport_3d)' + ! ---------------------------------------------- + + rc = ESMF_SUCCESS + if (present(do_sum)) then + do_sum_loc = do_sum + else + do_sum_loc = .false. + endif + call ESMF_StateGet(State, trim(fldname), itemFlag, rc=rc) + if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then + + if (geomtype == ESMF_GEOMTYPE_MESH) then + + ! get field pointer call state_getfldptr(state, trim(fldname), dataptr2d, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - lbnd1 = lbound(dataPtr2d,1) - lbnd2 = lbound(dataPtr2d,2) - - do j = jsc, jec - j1 = j + lbnd2 - jsc - do i = isc, iec - i1 = i + lbnd1 - isc - if (present(do_sum)) then - output(i,j) = output(i,j) + dataPtr2d(i1,j1) - else - output(i,j) = dataPtr2d(i1,j1) - endif + ! determine output array and apply area correction if present + do u = lbd, ubd ! ungridded dims + n = 0 + do j = jsc,jec + do i = isc,iec + n = n + 1 + if (do_sum_loc) then + if (present(areacor)) then + output(i,j,u) = output(i,j,u) + dataPtr2d(u,n) * areacor(n) + else + output(i,j,u) = output(i,j,u) + dataPtr2d(u,n) + endif + else + if (present(areacor)) then + output(i,j,u) = dataPtr2d(u,n) * areacor(n) + else + output(i,j,u) = dataPtr2d(u,n) + endif + endif + enddo enddo - enddo + enddo + else if (geomtype == ESMF_GEOMTYPE_GRID) then + call ESMF_LogWrite(trim(subname)//": ERROR ungridded dimensions not supported in MOM6 nuopc cap when "// & + "ESMF_GEOMTYPE_GRID is used. Use ESMF_GEOMTYPE_MESH instead.", ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return endif endif -end subroutine State_GetImport +end subroutine State_GetImport_3d !> Map input array to export state subroutine State_SetExport(state, fldname, isc, iec, jsc, jec, input, ocean_grid, areacor, rc) @@ -753,7 +1087,7 @@ subroutine State_SetExport(state, fldname, isc, iec, jsc, jec, input, ocean_grid ! local variables type(ESMF_StateItem_Flag) :: itemFlag - integer :: n, i, j, i1, j1, ig,jg + integer :: n, i, j, k, i1, j1, ig,jg integer :: lbnd1,lbnd2 real(ESMF_KIND_R8), pointer :: dataPtr1d(:) real(ESMF_KIND_R8), pointer :: dataPtr2d(:,:) @@ -769,45 +1103,52 @@ subroutine State_SetExport(state, fldname, isc, iec, jsc, jec, input, ocean_grid call ESMF_StateGet(State, trim(fldname), itemFlag, rc=rc) if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then - if (geomtype == ESMF_GEOMTYPE_MESH) then + if (geomtype == ESMF_GEOMTYPE_MESH) then - call state_getfldptr(state, trim(fldname), dataptr1d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(state, trim(fldname), dataptr1d, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - n = 0 - do j = jsc, jec - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - ig = i + ocean_grid%isc - isc - n = n+1 - dataPtr1d(n) = input(i,j) * ocean_grid%mask2dT(ig,jg) - enddo + n = 0 + do j = jsc, jec + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + n = n+1 + dataPtr1d(n) = input(i,j) * ocean_grid%mask2dT(ig,jg) enddo - if (present(areacor)) then - do n = 1,(size(dataPtr1d)) - dataPtr1d(n) = dataPtr1d(n) * areacor(n) - enddo - end if + enddo + if (present(areacor)) then + do n = 1,(size(dataPtr1d)) + dataPtr1d(n) = dataPtr1d(n) * areacor(n) + enddo + endif - else if (geomtype == ESMF_GEOMTYPE_GRID) then + ! if a maskmap is provided, set exports of all eliminated cells to zero. + if (associated(ocean_grid%Domain%maskmap)) then + do k = n+1, size(dataPtr1d) + dataPtr1d(k) = 0.0 + enddo + endif - call state_getfldptr(state, trim(fldname), dataptr2d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + else if (geomtype == ESMF_GEOMTYPE_GRID) then - lbnd1 = lbound(dataPtr2d,1) - lbnd2 = lbound(dataPtr2d,2) + call state_getfldptr(state, trim(fldname), dataptr2d, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - do j = jsc, jec - j1 = j + lbnd2 - jsc - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - i1 = i + lbnd1 - isc - ig = i + ocean_grid%isc - isc - dataPtr2d(i1,j1) = input(i,j) * ocean_grid%mask2dT(ig,jg) - enddo + lbnd1 = lbound(dataPtr2d,1) + lbnd2 = lbound(dataPtr2d,2) + + do j = jsc, jec + j1 = j + lbnd2 - jsc + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + i1 = i + lbnd1 - isc + ig = i + ocean_grid%isc - isc + dataPtr2d(i1,j1) = input(i,j) * ocean_grid%mask2dT(ig,jg) enddo + enddo - endif + endif endif @@ -846,34 +1187,34 @@ subroutine state_diagnose(State, string, rc) do n = 1, fieldCount - call ESMF_StateGet(state, itemName=lfieldnamelist(n), field=lfield, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call field_getfldptr(lfield, fldptr1=dataPtr1d, fldptr2=dataPtr2d, rank=lrank, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - if (lrank == 0) then - ! no local data - elseif (lrank == 1) then - if (size(dataPtr1d) > 0) then - write(msgString,'(A,3g14.7,i8)') trim(string)//': '//trim(lfieldnamelist(n)), & - minval(dataPtr1d), maxval(dataPtr1d), sum(dataPtr1d), size(dataPtr1d) - else - write(msgString,'(A,a)') trim(string)//': '//trim(lfieldnamelist(n))," no data" - endif - elseif (lrank == 2) then - if (size(dataPtr2d) > 0) then - write(msgString,'(A,3g14.7,i8)') trim(string)//': '//trim(lfieldnamelist(n)), & - minval(dataPtr2d), maxval(dataPtr2d), sum(dataPtr2d), size(dataPtr2d) - else - write(msgString,'(A,a)') trim(string)//': '//trim(lfieldnamelist(n))," no data" - endif - else - call ESMF_LogWrite(trim(subname)//": ERROR rank not supported ", ESMF_LOGMSG_ERROR) - rc = ESMF_FAILURE - return - endif - call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + call ESMF_StateGet(state, itemName=lfieldnamelist(n), field=lfield, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call field_getfldptr(lfield, fldptr1=dataPtr1d, fldptr2=dataPtr2d, rank=lrank, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (lrank == 0) then + ! no local data + elseif (lrank == 1) then + if (size(dataPtr1d) > 0) then + write(msgString,'(A,3g14.7,i8)') trim(string)//': '//trim(lfieldnamelist(n)), & + minval(dataPtr1d), maxval(dataPtr1d), sum(dataPtr1d), size(dataPtr1d) + else + write(msgString,'(A,a)') trim(string)//': '//trim(lfieldnamelist(n))," no data" + endif + elseif (lrank == 2) then + if (size(dataPtr2d) > 0) then + write(msgString,'(A,3g14.7,i8)') trim(string)//': '//trim(lfieldnamelist(n)), & + minval(dataPtr2d), maxval(dataPtr2d), sum(dataPtr2d), size(dataPtr2d) + else + write(msgString,'(A,a)') trim(string)//': '//trim(lfieldnamelist(n))," no data" + endif + else + call ESMF_LogWrite(trim(subname)//": ERROR rank not supported ", ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + endif + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) enddo deallocate(lfieldnamelist) @@ -901,17 +1242,17 @@ subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) ! ---------------------------------------------- if (.not.present(rc)) then - call ESMF_LogWrite(trim(subname)//": ERROR rc not present ", & - ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) - rc = ESMF_FAILURE - return + call ESMF_LogWrite(trim(subname)//": ERROR rc not present ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return endif rc = ESMF_SUCCESS labort = .true. if (present(abort)) then - labort = abort + labort = abort endif lrank = -99 @@ -919,69 +1260,69 @@ subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (status /= ESMF_FIELDSTATUS_COMPLETE) then - lrank = 0 - if (labort) then - call ESMF_LogWrite(trim(subname)//": ERROR data not allocated ", ESMF_LOGMSG_INFO) - rc = ESMF_FAILURE - return - else - call ESMF_LogWrite(trim(subname)//": WARNING data not allocated ", ESMF_LOGMSG_INFO) - endif + lrank = 0 + if (labort) then + call ESMF_LogWrite(trim(subname)//": ERROR data not allocated ", ESMF_LOGMSG_INFO) + rc = ESMF_FAILURE + return + else + call ESMF_LogWrite(trim(subname)//": WARNING data not allocated ", ESMF_LOGMSG_INFO) + endif else - call ESMF_FieldGet(field, geomtype=geomtype, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(field, geomtype=geomtype, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (geomtype == ESMF_GEOMTYPE_GRID) then - call ESMF_FieldGet(field, rank=lrank, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - elseif (geomtype == ESMF_GEOMTYPE_MESH) then - call ESMF_FieldGet(field, rank=lrank, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(field, mesh=lmesh, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_MeshGet(lmesh, numOwnedNodes=nnodes, numOwnedElements=nelements, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (nnodes == 0 .and. nelements == 0) lrank = 0 - else - call ESMF_LogWrite(trim(subname)//": ERROR geomtype not supported ", & - ESMF_LOGMSG_INFO) + if (geomtype == ESMF_GEOMTYPE_GRID) then + call ESMF_FieldGet(field, rank=lrank, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + elseif (geomtype == ESMF_GEOMTYPE_MESH) then + call ESMF_FieldGet(field, rank=lrank, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(field, mesh=lmesh, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_MeshGet(lmesh, numOwnedNodes=nnodes, numOwnedElements=nelements, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (nnodes == 0 .and. nelements == 0) lrank = 0 + else + call ESMF_LogWrite(trim(subname)//": ERROR geomtype not supported ", & + ESMF_LOGMSG_INFO) + rc = ESMF_FAILURE + return + endif ! geomtype + + if (lrank == 0) then + call ESMF_LogWrite(trim(subname)//": no local nodes or elements ", & + ESMF_LOGMSG_INFO) + elseif (lrank == 1) then + if (.not.present(fldptr1)) then + call ESMF_LogWrite(trim(subname)//": ERROR missing rank=1 array ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) rc = ESMF_FAILURE return - endif ! geomtype - - if (lrank == 0) then - call ESMF_LogWrite(trim(subname)//": no local nodes or elements ", & - ESMF_LOGMSG_INFO) - elseif (lrank == 1) then - if (.not.present(fldptr1)) then - call ESMF_LogWrite(trim(subname)//": ERROR missing rank=1 array ", & - ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) - rc = ESMF_FAILURE - return - endif - call ESMF_FieldGet(field, farrayPtr=fldptr1, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - elseif (lrank == 2) then - if (.not.present(fldptr2)) then - call ESMF_LogWrite(trim(subname)//": ERROR missing rank=2 array ", & - ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) - rc = ESMF_FAILURE - return - endif - call ESMF_FieldGet(field, farrayPtr=fldptr2, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - else - call ESMF_LogWrite(trim(subname)//": ERROR in rank ", & + endif + call ESMF_FieldGet(field, farrayPtr=fldptr1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + elseif (lrank == 2) then + if (.not.present(fldptr2)) then + call ESMF_LogWrite(trim(subname)//": ERROR missing rank=2 array ", & ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) rc = ESMF_FAILURE return - endif + endif + call ESMF_FieldGet(field, farrayPtr=fldptr2, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call ESMF_LogWrite(trim(subname)//": ERROR in rank ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + endif endif ! status if (present(rank)) then - rank = lrank + rank = lrank endif end subroutine field_getfldptr @@ -995,7 +1336,7 @@ logical function ChkErr(rc, line, file) ChkErr = .false. lrc = rc if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=line, file=file)) then - ChkErr = .true. + ChkErr = .true. endif end function ChkErr diff --git a/config_src/drivers/nuopc_cap/mom_cap_outputlog.F90 b/config_src/drivers/nuopc_cap/mom_cap_outputlog.F90 new file mode 100644 index 0000000000..7b9b7595bd --- /dev/null +++ b/config_src/drivers/nuopc_cap/mom_cap_outputlog.F90 @@ -0,0 +1,623 @@ +!> This module contains a set of subroutines that check if MOM restart and history files +!! have been written and closed. This file is specific to UWM operational requirements +!! and configurations (eg specific output frequencies in hours) and may break if used outside +!! the scope of intended use. +!! This module is a stub when CESMCOUPLED is defined +module MOM_cap_outputlog + +#ifdef CESMCOUPLED +use ESMF , only : ESMF_GridComp, ESMF_Clock, ESMF_SUCCESS +implicit none ; private + +public :: outputlog_init, outputlog_run, outputlog_restart +contains +subroutine outputlog_init(gcomp, mclock, rc) + type(ESMF_GridComp) :: gcomp !< an ESMF_GridComp object + type(ESMF_Clock) :: mclock !< the ESMF_clock for the model + integer, intent(out) :: rc !< return code + rc = ESMF_SUCCESS +end subroutine outputlog_init +subroutine outputlog_run(mclock, atStopTime, rc) + type(ESMF_Clock) :: mclock !< the ESMF_clock for the model + logical, intent(in), optional :: atStopTime !< if true, checks for final output file + integer, intent(out) :: rc !< return code + rc = ESMF_SUCCESS +end subroutine outputlog_run +subroutine outputlog_restart(mclock, num_rest_files, rc) + type(ESMF_Clock) :: mclock !< the ESMF_clock for the model + integer, intent(in) :: num_rest_files !< the number of restart files + integer, intent(out) :: rc !< return code + rc = ESMF_SUCCESS +end subroutine outputlog_restart +#else +use MOM_error_handler , only : is_root_pe, MOM_error, FATAL +use NUOPC , only : NUOPC_CompAttributeGet +use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_VM, ESMF_VMGet +use ESMF , only : ESMF_Time, ESMF_Clock, ESMF_ClockGet, ESMF_Alarm, ESMF_AlarmSet +use ESMF , only : ESMF_ClockGetAlarm, ESMF_AlarmIsRinging, ESMF_AlarmRingerOff +use ESMF , only : ESMF_ClockGetNextTime, ESMF_TimeGet, ESMF_TimeInterval +use ESMF , only : ESMF_AlarmGet, ESMF_TimeIntervalSet, ESMF_TimeIntervalPrint +use ESMF , only : ESMF_SUCCESS, ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_VMBroadCast +use ESMF , only : ESMF_LogSetError, ESMF_LogFoundError, ESMF_LOGERR_PASSTHRU +use ESMF , only : operator(*), operator(+), operator(-), operator(>), operator(==) +use MOM_cap_methods , only : ChkErr +use MOM_cap_time , only : AlarmInit +use shr_is_restart_fh_mod , only : log_restart_fh +use netcdf + +implicit none ; private + +public :: outputlog_init, outputlog_run, outputlog_restart + +! the allowable output frequency for MOM6 history, in hours only +integer, parameter :: n_freq = 3 +integer, parameter, dimension(n_freq) :: freq = (/3, 6, 24/) +! TODO: for multiple output freq in same run, a different known filename +! root for different freqs needs to be read in, consistent with the diag table + +! the tincrement interval (defined in minutes) is used to construct the output filename +! the file name must be set as the mid-point of the averaging period via the diagtable +! and the output filename timestrings are given by +! T - (interval * 60 * increment + interval/2 * 60 * increment ) +! where T is the time when the file is closed +! +! 00 . 03 . 06 . 09 +! 1:30 = 6 - (3 + 1:30) +! 4:30 = 9 - (3 + 1:30) +! +! 00 . 06 . 12 . 18 +! 03 = 12 - (6 + 3) +! 09 = 18 - (6 + 3) +! +! 00 . 24 . 48 . 72 +! 12 = 48 - (24 + 12) +! 36 = 72 - (24 + 12) +! +! when the model reaches the stop time, any 'pending' output file is closed, and the final +! interval output is also closed +! +! stop +! 18 . 24 . 30 +! 21 = 30 - (12 + 3) +! 03 = 30 - (3) +! +! since both the final interval and the next-to-final interval can be closed at the stop time, +! a different log file name is required for the final log file, otherwise the next-to-final +! log is overwritten +! +! Depending on configuration, the output file can have an unlimited dimension >0 at creation time. +! This necessitates checking for an additional criteria using the filesize at creation. An output file +! is declared complete either when the unlimited dimension in the file is >0 or when the unlimited +! dimension is >0 and the filesize is larger than the initial size. + +! When a file is determined to be complete, a log file is recorded containing the forecast hour, the valid +! time, the name of the output file and the last completed restart file. + +type(ESMF_VM) :: vm +type(ESMF_TimeInterval) :: tincrement +type(ESMF_Time) :: lastrestart + +type :: outputlog_type + character(len=14) :: alarm_name + integer :: opt_n + logical :: chkfile_nextAdvance + logical :: use_filesize + character(len=256) :: filename + integer :: createsize + type(ESMF_Alarm) :: alarm + type(ESMF_TimeInterval) :: fhoffset + type(ESMF_TimeInterval) :: filename_fhoffset + type(ESMF_Time) :: time_lastrestart +end type outputlog_type + +type(outputlog_type) :: olog(n_freq) + +integer :: toffset +logical :: debug +logical :: existflag +character(len=256) :: restartdir +character(len=256) :: outputdir +character(len=2) :: output_fh +character(len=*), parameter :: u_FILE_u = & + __FILE__ + +contains +!> Initialize a set of Alarms at the allowed output frequencies +!! +!! @param gcomp an ESMF_GridComp object +!! @param clock an ESMF_Clock object +!! @param rc return code +subroutine outputlog_init(gcomp, mclock, rc) + type(ESMF_GridComp) :: gcomp + type(ESMF_Clock) :: mclock + integer, intent(out) :: rc + + ! local variables + type(ESMF_Time) :: mcurrTime + type(ESMF_TimeInterval) :: alarmoffset + logical :: isPresent, isSet + integer :: n + integer :: year, month, day, hour + character(len=3) :: chour + character(len=256) :: msgString + character(len=256) :: value + character(len=256) :: subname='MOM_cap:(outputlog_init)' + !---------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call NUOPC_CompAttributeGet(gcomp, name="mom6_restart_dir", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + restartdir = trim(value) + else + restartdir = './' + endif + if (restartdir(len_trim(restartdir):len_trim(restartdir)) /= '/') then + restartdir = trim(restartdir)//'/' + endif + write(msgString,'(A)')'MOM_cap:MOM6 restart directory = '//trim(restartdir) + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + + call NUOPC_CompAttributeGet(gcomp, name="mom6_output_dir", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + outputdir = trim(value) + else + outputdir = './' + endif + if (outputdir(len_trim(outputdir):len_trim(outputdir)) /= '/') then + outputdir = trim(outputdir)//'/' + endif + write(msgString,'(A)')'MOM_cap:MOM6 output directory = '//trim(outputdir) + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + + call NUOPC_CompAttributeGet(gcomp, name="mom6_output_fh", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + if (len_trim(value) == 1) then + output_fh = '0'//trim(value) + else + output_fh = trim(value) + endif + else + output_fh = '06' + endif + write(msgString,'(A)')'MOM_cap:MOM6 output frequency = '//trim(output_fh) + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + + debug = .false. + call NUOPC_CompAttributeGet(gcomp, name="debug_outputlog", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) debug=(trim(value)=="true") + if (debug) call ESMF_LogWrite('MOM_cap:MOM6 output debug ON', ESMF_LOGMSG_INFO) + + call ESMF_ClockGet(mclock, currTime=mcurrTime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeIntervalSet(tincrement, m=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! get start hour time offset (ie, fhrot) + call ESMF_TimeGet(mcurrTime, yy=year, mm=month, dd=day, h=hour, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (mod(hour,6) /= 0) then + toffset = hour - 6 + else + toffset = 0 + endif + if (debug .and. is_root_pe()) then + print '(A,i8)',trim(subname)//' toffset = ',toffset + endif + ! initialize + lastrestart = mcurrTime + + do n = 1,n_freq + write(chour,'(I2.2,A)')freq(n),'h' + olog(n)%alarm_name = 'output_alarm'//trim(chour) + olog(n)%opt_n = freq(n) + olog(n)%chkfile_nextAdvance = .false. + olog(n)%use_filesize = .false. + olog(n)%filename = '' + olog(n)%createsize = 0 + olog(n)%time_lastrestart = lastrestart + olog(n)%fhoffset = 60*freq(n)*tincrement + olog(n)%filename_fhoffset = 90*freq(n)*tincrement + + ! the time offset in hours required to ensure the alarm rings at multiples of 6 + if (freq(n) >= 6) then + alarmoffset = toffset*60*tincrement + else + alarmoffset = 0*tincrement + endif + + call AlarmInit(mclock, & + alarm = olog(n)%alarm, & + option = 'nhours', & + opt_n = olog(n)%opt_n, & + opt_ymd = -999, & + RefTime = mcurrTime+alarmoffset, & + alarmname = olog(n)%alarm_name, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_AlarmSet(olog(n)%alarm, clock=mclock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + write(msgString,'(A)')trim(subname)//' Output alarm '//trim(olog(n)%alarm_name)//' Created & Set' + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + if (debug .and. is_root_pe()) then + call ESMF_TimeIntervalPrint(olog(n)%filename_fhoffset, options="string", rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + enddo +end subroutine outputlog_init + +!> Write a log file denoting that an output file is complete +!! +!! @param clock an ESMF_Clock object +!! @param atStopTime when present, checks for final output file +!! @param rc return code +subroutine outputlog_run(mclock, atStopTime, rc) + type(ESMF_Clock) :: mclock + logical, intent(in), optional :: atStopTime + integer, intent(out) :: rc + + ! local variables + type(ESMF_Time) :: nextTime, currTime, startTime, prevRing + logical :: lstop + logical :: filecomplete + integer :: n, nlen(1), fsize(1) + character(len=3) :: chour + character(len=40) :: importexport + character(len=16) :: timestr + character(len=256) :: fname + character(len=256) :: subname='MOM_cap:(outputlog_run)' + !---------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_ClockGet(mclock, startTime=startTime, currTime=currTime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockGetNextTime(mclock, nextTime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + importexport = get_importexport(currTime, nextTime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + lstop = .false. + if (present(atStopTime)) then + lstop = atStopTime + endif + + filecomplete = .false. + fsize(1) = nf90_fill_int + nlen(1) = nf90_fill_int + + do n = 1,n_freq + write(chour,'(I2.2,A)')freq(n),'h' + if (chour(1:2) == output_fh(1:2)) then + call ESMF_ClockGetAlarm(mclock, alarmname=trim(olog(n)%alarm_name), alarm=olog(n)%alarm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! when the alarm rings, set file check on next advance and construct the filename + if (ESMF_AlarmIsRinging(olog(n)%alarm, rc=rc)) then + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_AlarmRingerOff(olog(n)%alarm, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + olog(n)%chkfile_nextAdvance = .true. + + timestr = get_timestr(nextTime-olog(n)%filename_fhoffset, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + write(olog(n)%filename,'(A)')trim(outputdir)//'ocn_'//trim(timestr)//'.nc' + + fname = trim(olog(n)%filename) + inquire(file=fname, exist=existflag) + if (existflag) then + if (is_root_pe()) then + nlen(1) = get_unlimited_len(trim(fname)) + inquire(file=fname, size=fsize(1)) + endif + call ESMF_VMBroadCast(vm, nlen, 1, 0, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMBroadCast(vm, fsize, 1, 0, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + olog(n)%createsize = fsize(1) + + if (nlen(1) == 0) then + olog(n)%use_filesize = .false. + else + olog(n)%use_filesize = .true. + endif + endif + if (debug .and. is_root_pe()) then + print '(A,2(A,L),A,2i16)',trim(subname)//' fname '//trim(olog(n)%filename)//' '//trim(importexport), & + ' checkflag ',olog(n)%chkfile_nextAdvance,' use_filesize ',olog(n)%use_filesize, & + ' ',olog(n)%createsize,nlen(1) + endif + endif + + if (olog(n)%chkfile_nextAdvance) then + fname = trim(olog(n)%filename) + filecomplete = file_is_complete(fname, olog(n)%use_filesize, olog(n)%createsize, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (filecomplete) then + olog(n)%chkfile_nextAdvance = .false. + olog(n)%time_lastrestart = lastrestart + if (is_root_pe()) then + call log_restart_fh(currTime-olog(n)%fhoffset, startTime, 'mom6.'//chour, prefixtime=.true., & + lastrestart=olog(n)%time_lastrestart, lastoutput=olog(n)%filename, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + endif + endif + if (debug .and. is_root_pe()) call debug_info(trim(subname)//' ',trim(olog(n)%filename), & + olog(n)%chkfile_nextAdvance, olog(n)%createsize, importexport) + + if (lstop) then + ! use prevRing in place of currTime to allow for stopping between averaging intervals + ! prevring == currTime if stopping on intervals + call ESMF_AlarmGet(olog(n)%alarm, prevRingTime=prevring, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + timestr = get_timestr(prevring-30*freq(n)*tincrement, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + write(olog(n)%filename,'(A)')trim(outputdir)//'ocn_'//trim(timestr)//'.nc' + + fname = trim(olog(n)%filename) + filecomplete = file_is_complete(fname, olog(n)%use_filesize, olog(n)%createsize, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (filecomplete) then + olog(n)%chkfile_nextAdvance = .false. + olog(n)%time_lastrestart = lastrestart + if (is_root_pe()) then + call log_restart_fh(prevring, startTime, 'mom6.lstop.'//chour, prefixtime=.true., & + lastrestart=olog(n)%time_lastrestart, lastoutput=olog(n)%filename, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + endif + if (debug .and. is_root_pe()) call debug_info(trim(subname)//' lstop ',trim(olog(n)%filename), & + olog(n)%chkfile_nextAdvance, olog(n)%createsize, importexport) + + endif ! lstop + endif ! chour = output_fh + enddo +end subroutine outputlog_run + +!> Check all restart files to determine if output has been completed +!! +!! @param[in] clock an ESMF_Clock object +!! @param[in] num_rest_files the number of restart files +!! @param[out] rc return code +subroutine outputlog_restart(mclock, num_rest_files, rc) + type(ESMF_Clock) :: mclock + integer, intent(in) :: num_rest_files + integer, intent(out) :: rc + + ! local variables + type(ESMF_Time) :: startTime, currTime, nextTime + integer :: n, nlen(1) + integer :: year, month, day, hour, minute, seconds + character(len=256) :: fname + character(len=15) :: timestr + character(len=40) :: importexport + logical, allocatable :: allDone(:) + character(len=8) :: suffix + character(len=256) :: subname='MOM_cap:(outputlog_restart)' + !---------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_ClockGet(mclock, startTime=startTime, currTime=currTime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockGetNextTime(mclock, nextTime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + importexport = get_importexport(currTime, nextTime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_TimeGet(nextTime, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + write(timestr,'(I4.4,2(I2.2),A,3(I2.2))') year, month, day,".", hour, minute, seconds + + allocate(allDone(1:num_rest_files)) + allDone = .false. + + do n = 1,num_rest_files + if (n == 1) then + suffix = '' + else if (n-1 < 10) then + write(suffix,'("_",I1)') n-1 + else + write(suffix,'("_",I2)') n-1 + endif + if (len_trim(suffix) == 0) then + fname = trim(restartdir)//trim(timestr)//'.MOM.res.nc' + else + fname = trim(restartdir)//trim(timestr)//'.MOM.res'//trim(suffix)//'.nc' + endif + + ! check if file is written + inquire(file=trim(fname), exist=existflag) + if (existflag) then + if (is_root_pe())then + nlen(1) = get_unlimited_len(trim(fname)) + endif + call ESMF_VMBroadCast(vm, nlen, 1, 0, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (nlen(1) > 0) allDone(n) = .true. + if (debug .and. is_root_pe()) then + if (nlen(1) > 0) then + print '(A)',trim(subname)//' restart '//trim(fname)//' '//trim(importexport)//' complete' + else + print '(A)',trim(subname)//' restart '//trim(fname)//' '//trim(importexport)//' still 0' + endif + endif + endif + enddo ! num_rest_files + + if (all(allDone) .eqv. .true.) then + lastrestart = nextTime + if (is_root_pe()) then + call log_restart_fh(nextTime, startTime, 'mom6.res', prefixtime=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + endif +end subroutine outputlog_restart + +!> Determine if the netcdf output file is complete +!! +!! @param[in] fname the file name +!! @param[in] chk4size logical flag for check method in use +!! @param[in] createsize the filesize at creation +!! @param[out] rc return code +!! @return logical flag, true if the file is complete +logical function file_is_complete(fname, chk4size, createsize, rc) result(filecomplete) + character(len=*), intent(in) :: fname + logical, intent(in) :: chk4size + integer, intent(in) :: createsize + integer, intent(out) :: rc + + integer :: nlen(1), fsize(1) + !---------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + filecomplete = .false. + nlen(1) = nf90_fill_int + fsize(1) = nf90_fill_int + + inquire(file=fname, exist=existflag) + if (existflag) then + if (is_root_pe()) then + nlen(1) = get_unlimited_len(fname) + inquire(file=fname, size=fsize(1)) + endif + call ESMF_VMBroadCast(vm, nlen, 1, 0, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMBroadCast(vm, fsize, 1, 0, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + if (chk4size) then + filecomplete = (nlen(1) > 0 .and. fsize(1) > createsize) + else + filecomplete = (nlen(1) > 0) + endif +end function file_is_complete + +!> Return the length of the unlimited dimension +!! +!! @param[in] fname the file name +!! @return unlimited dimension length +integer function get_unlimited_len(fname) result(unlen) + character(len=*), intent(in) :: fname + + integer :: ncid, dimid + !---------------------------------------------------------------------------- + + unlen = 0 + call nf90_err(nf90_open(trim(fname), nf90_nowrite, ncid), 'nf90_open: '//trim(fname)) + call nf90_err(nf90_inquire(ncid, unlimiteddimid=dimid), 'inquire unlimiteddimid') + call nf90_err(nf90_inquire_dimension(ncid, dimid, len=unlen), 'inquire unlimited dimension') + call nf90_err(nf90_close(ncid), 'close: '//trim(fname)) +end function get_unlimited_len + +!> Convenience function to return a 16-character time string +!! +!! @param[in] MyTime an ESMF_Time object +!! @param[out] rc return code +!! @return 16-character formatted time string (YYYY_MM_DD_HH_MM) +character(len=16) function get_timestr(MyTime, rc) result(timestr) + type(ESMF_Time), intent(in) :: MyTime + integer, intent(out) :: rc + + integer :: year, month, day, hour, minute + !---------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_TimeGet(MyTime, yy=year, mm=month, dd=day, h=hour, m=minute, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + write(timestr,'(I4.4,4(A,I2.2))')year,'_',month,'_',day,'_',hour,'_',minute +end function get_timestr + +!> Convenience function to return import/export timestring +!! +!! @param[in] currTime an ESMF_Time object +!! @param[in] nextTime an ESMF_Time object +!! @param[out] rc return code +!! @return 40-character string +character(len=40) function get_importexport(currTime, nextTime, rc) result(importexport) + + type(ESMF_Time), intent(in) :: currTime, nextTime + integer, intent(out) :: rc + + character(len=19) :: import_timestr, export_timestr + !---------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + call ESMF_TimeGet(currTime, timestring=import_timestr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeGet(nextTime, timestring=export_timestr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + importexport = trim(import_timestr)//' '//trim(export_timestr) +end function get_importexport + +!> Write debug info to stdout, only called on root pe +!! +!! @param[in] tag an information tag +!! @param[in] fname the filename to check +!! @param[in] filesize the filesize at creation time +!! @param[in] chkflag logical flag for checking next Advance +!! @param[in] timestring a timestring +subroutine debug_info(tag,fname,chkflag,filesize,timestring) + character(len=*), intent(in) :: tag + character(len=*), intent(in) :: fname + integer, intent(in) :: filesize + logical, intent(in) :: chkflag + character(len=*), intent(in) :: timestring + + integer :: fsize + character(len=256) :: msgString + !---------------------------------------------------------------------------- + + inquire(file=fname, exist=existflag) + if (existflag) then + inquire(file=fname, size=fsize) + write(msgString,'(A)')tag//' '//fname//' exists '//timestring + if (chkflag) then + print '(A,L,2i16)',trim(msgString)//' not complete, chkflag ',chkflag,filesize,fsize + else + print '(A,L,2i16)',trim(msgString)//' complete, chkflag ',chkflag,filesize,fsize + endif + else + write(msgString,'(A)')tag//' '//fname//' does not exist '//timestring + print '(A)',trim(msgString) + endif +end subroutine debug_info + +!> Handle netcdf errors +!! +!! @param[in] ierr the error code +!! @param[in] string the error message +subroutine nf90_err(ierr, string) + integer, intent(in) :: ierr + character(len=*), intent(in) :: string + !---------------------------------------------------------------------------- + + if (ierr /= nf90_noerr) then + write(0, '(A)') 'FATAL ERROR: ' // trim(string)// ' : ' // trim(nf90_strerror(ierr)) + ! This fails on WCOSS2 with Intel 19 compiler. See https://community.intel.com/ + ! Search term "STOP and ERROR STOP with variable stop codes" + ! When WCOSS2 moves to Intel 2020+, uncomment the next line and remove stop 99 + !stop ierr + stop 99 + endif +end subroutine nf90_err +#endif +end module MOM_cap_outputlog diff --git a/config_src/drivers/nuopc_cap/mom_cap_profiling.F90 b/config_src/drivers/nuopc_cap/mom_cap_profiling.F90 new file mode 100644 index 0000000000..4e3e387e2d --- /dev/null +++ b/config_src/drivers/nuopc_cap/mom_cap_profiling.F90 @@ -0,0 +1,45 @@ +!> Contains wrapper routines that call the ufs tracing routines +module mom_cap_profiling + +#ifdef UFS_TRACING + use ufs_trace_mod, only: ufs_trace_init, ufs_trace, ufs_trace_finalize +#endif + + implicit none + + private + + public cap_profiling_init + public cap_profiling + public cap_profiling_finalize + +contains + +!> Wrapper routine that calls ufs_trace_init + subroutine cap_profiling_init() +#ifdef UFS_TRACING + call ufs_trace_init() +#endif + return + end subroutine cap_profiling_init + +!> Wrapper routine that calls ufs_trace + subroutine cap_profiling(component, routine, ph) + character(len=*), intent(in) :: component !< Name of the component, 'mom' + character(len=*), intent(in) :: routine !< Name of the profiled subroutine + character(len=*), intent(in) :: ph !< Duration event phase type. 'B' or 'E' for begin/end +#ifdef UFS_TRACING + call ufs_trace(component, routine, ph) +#endif + return + end subroutine cap_profiling + +!> Wrapper routine that calls ufs_trace_finalize + subroutine cap_profiling_finalize() +#ifdef UFS_TRACING + call ufs_trace_finalize() +#endif + return + end subroutine cap_profiling_finalize + +end module mom_cap_profiling diff --git a/config_src/drivers/nuopc_cap/mom_cap_time.F90 b/config_src/drivers/nuopc_cap/mom_cap_time.F90 index 7f210bda71..3f5a303cc8 100644 --- a/config_src/drivers/nuopc_cap/mom_cap_time.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap_time.F90 @@ -1,3 +1,7 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> This was originally share code in CIME, but required CIME as a !! dependency to build the MOM cap. The options here for setting !! a restart alarm are useful for all caps, so a second step is to @@ -18,7 +22,7 @@ module MOM_cap_time use ESMF , only : operator(<=), operator(>), operator(==) use MOM_cap_methods , only : ChkErr -implicit none; private +implicit none ; private public :: AlarmInit ! initialize an alarm @@ -27,32 +31,32 @@ module MOM_cap_time ! Clock and alarm options character(len=*), private, parameter :: & - optNONE = "none" , & - optNever = "never" , & - optNSteps = "nsteps" , & - optNStep = "nstep" , & - optNSeconds = "nseconds" , & - optNSecond = "nsecond" , & - optNMinutes = "nminutes" , & - optNMinute = "nminute" , & - optNHours = "nhours" , & - optNHour = "nhour" , & - optNDays = "ndays" , & - optNDay = "nday" , & - optNMonths = "nmonths" , & - optNMonth = "nmonth" , & - optNYears = "nyears" , & - optNYear = "nyear" , & - optMonthly = "monthly" , & - optYearly = "yearly" , & - optDate = "date" , & - optIfdays0 = "ifdays0" , & - optGLCCouplingPeriod = "glc_coupling_period" + optNONE = "none" , & + optNever = "never" , & + optNSteps = "nsteps" , & + optNStep = "nstep" , & + optNSeconds = "nseconds" , & + optNSecond = "nsecond" , & + optNMinutes = "nminutes" , & + optNMinute = "nminute" , & + optNHours = "nhours" , & + optNHour = "nhour" , & + optNDays = "ndays" , & + optNDay = "nday" , & + optNMonths = "nmonths" , & + optNMonth = "nmonth" , & + optNYears = "nyears" , & + optNYear = "nyear" , & + optMonthly = "monthly" , & + optYearly = "yearly" , & + optDate = "date" , & + optIfdays0 = "ifdays0" , & + optGLCCouplingPeriod = "glc_coupling_period" ! Module data integer, parameter :: SecPerDay = 86400 ! Seconds per day character(len=*), parameter :: u_FILE_u = & - __FILE__ + __FILE__ contains @@ -66,7 +70,7 @@ module MOM_cap_time !! In the logic below we set an appropriate "NextAlarm" and then !! we make sure to advance it properly based on the ring interval. subroutine AlarmInit( clock, alarm, option, & - opt_n, opt_ymd, opt_tod, RefTime, alarmname, rc) + opt_n, opt_ymd, opt_tod, RefTime, alarmname, rc) type(ESMF_Clock) , intent(inout) :: clock !< ESMF clock type(ESMF_Alarm) , intent(inout) :: alarm !< ESMF alarm character(len=*) , intent(in) :: option !< alarm option @@ -109,20 +113,20 @@ subroutine AlarmInit( clock, alarm, option, & trim(option) == optNMonths .or. trim(option) == optNMonth .or. & trim(option) == optNYears .or. trim(option) == optNYear .or. & trim(option) == optIfdays0) then - if (.not. present(opt_n)) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//trim(option)//' requires opt_n', & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return - endif - if (opt_n <= 0) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//trim(option)//' invalid opt_n', & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return - endif + if (.not. present(opt_n)) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//trim(option)//' requires opt_n', & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return + endif + if (opt_n <= 0) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//trim(option)//' invalid opt_n', & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return + endif endif call ESMF_ClockGet(clock, CurrTime=CurrTime, rc=rc) @@ -136,9 +140,9 @@ subroutine AlarmInit( clock, alarm, option, & ! initial guess of next alarm, this will be updated below if (present(RefTime)) then - NextAlarm = RefTime + NextAlarm = RefTime else - NextAlarm = CurrTime + NextAlarm = CurrTime endif ! Determine calendar @@ -149,109 +153,109 @@ subroutine AlarmInit( clock, alarm, option, & selectcase (trim(option)) case (optNONE, optNever) - call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - update_nextalarm = .false. + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .false. case (optDate) - if (.not. present(opt_ymd)) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//trim(option)//' requires opt_ymd', & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return - endif - if (lymd < 0 .or. ltod < 0) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//trim(option)//'opt_ymd, opt_tod invalid', & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return - endif - call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call TimeInit(NextAlarm, lymd, cal, tod=ltod, desc="optDate", rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - update_nextalarm = .false. + if (.not. present(opt_ymd)) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//trim(option)//' requires opt_ymd', & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return + endif + if (lymd < 0 .or. ltod < 0) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//trim(option)//'opt_ymd, opt_tod invalid', & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return + endif + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call TimeInit(NextAlarm, lymd, cal, tod=ltod, desc="optDate", rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .false. case (optIfdays0) - if (.not. present(opt_ymd)) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//trim(option)//' requires opt_ymd', & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return - endif - call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=opt_n, s=0, calendar=cal, rc=rc ) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - update_nextalarm = .true. + if (.not. present(opt_ymd)) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//trim(option)//' requires opt_ymd', & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return + endif + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=opt_n, s=0, calendar=cal, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .true. case (optNSteps, optNStep) - call ESMF_ClockGet(clock, TimeStep=AlarmInterval, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + call ESMF_ClockGet(clock, TimeStep=AlarmInterval, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optNSeconds, optNSecond) - call ESMF_TimeIntervalSet(AlarmInterval, s=1, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, s=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optNMinutes, optNMinute) - call ESMF_TimeIntervalSet(AlarmInterval, s=60, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, s=60, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optNHours, optNHour) - call ESMF_TimeIntervalSet(AlarmInterval, s=3600, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, s=3600, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optNDays, optNDay) - call ESMF_TimeIntervalSet(AlarmInterval, d=1, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, d=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optNMonths, optNMonth) - call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optMonthly) - call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=1, s=0, calendar=cal, rc=rc ) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=1, s=0, calendar=cal, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .true. case (optNYears, optNYear) - call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optYearly) - call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeSet( NextAlarm, yy=cyy, mm=1, dd=1, s=0, calendar=cal, rc=rc ) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=cyy, mm=1, dd=1, s=0, calendar=cal, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .true. case default - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//' unknown option: '//trim(option), & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//' unknown option: '//trim(option), & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return end select @@ -263,10 +267,10 @@ subroutine AlarmInit( clock, alarm, option, & ! --- most options above. go back one alarminterval just to be careful if (update_nextalarm) then - NextAlarm = NextAlarm - AlarmInterval - do while (NextAlarm <= CurrTime) - NextAlarm = NextAlarm + AlarmInterval - enddo + NextAlarm = NextAlarm - AlarmInterval + do while (NextAlarm <= CurrTime) + NextAlarm = NextAlarm + AlarmInterval + enddo endif alarm = ESMF_AlarmCreate( name=lalarmname, clock=clock, ringTime=NextAlarm, ringInterval=AlarmInterval, rc=rc) @@ -299,15 +303,15 @@ subroutine TimeInit( Time, ymd, cal, tod, desc, logunit, rc) if (present(desc)) ldesc = desc if ( (ymd < 0) .or. (ltod < 0) .or. (ltod > SecPerDay) )then - if (present(logunit)) then - write(logunit,*) subname//': ERROR yymmdd is a negative number or '// & - 'time-of-day out of bounds', ymd, ltod - endif - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//' yymmdd is negative or time-of-day out of bounds ', & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return + if (present(logunit)) then + write(logunit,*) subname//': ERROR yymmdd is a negative number or '// & + 'time-of-day out of bounds', ymd, ltod + endif + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//' yymmdd is negative or time-of-day out of bounds ', & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return endif call date2ymd (ymd,yr,mon,day) @@ -330,7 +334,7 @@ subroutine date2ymd (date, year, month, day) tdate = abs(date) year = int(tdate/10000) if (date < 0) then - year = -year + year = -year endif month = int( mod(tdate,10000)/ 100) day = mod(tdate, 100) diff --git a/config_src/drivers/nuopc_cap/mom_inline_mod.F90 b/config_src/drivers/nuopc_cap/mom_inline_mod.F90 new file mode 100644 index 0000000000..8b8b544f2f --- /dev/null +++ b/config_src/drivers/nuopc_cap/mom_inline_mod.F90 @@ -0,0 +1,218 @@ +!> This module contains a set of subroutines that enables inline CDEPS capability + +module mom_inline_mod + +use NUOPC , only: NUOPC_CompAttributeGet +use ESMF , only: ESMF_GridComp, ESMF_Mesh +use ESMF , only: ESMF_Clock, ESMF_Time, ESMF_TimeGet, ESMF_ClockGet +use ESMF , only: ESMF_KIND_R8, ESMF_SUCCESS, ESMF_LogFoundError +use ESMF , only: ESMF_LOGERR_PASSTHRU, ESMF_LOGMSG_INFO, ESMF_LOGWRITE +use ESMF , only: ESMF_END_ABORT, ESMF_Finalize, ESMF_MAXSTR +use dshr_mod , only: dshr_pio_init +use dshr_strdata_mod , only: shr_strdata_type, shr_strdata_print +use dshr_strdata_mod , only: shr_strdata_init_from_inline +use dshr_strdata_mod , only: shr_strdata_advance +use dshr_methods_mod , only: dshr_fldbun_getfldptr, dshr_fldbun_Field_diagnose +use dshr_stream_mod , only: shr_stream_init_from_esmfconfig +use MOM_cap_methods , only: ChkErr + +implicit none +private + +public mom_inline_init +public mom_inline_run + +type(shr_strdata_type), allocatable :: sdat(:) + +integer :: logunit ! the logunit on the root task +character(len=ESMF_MAXSTR) :: stream_name ! generic identifier + +character(len=*), parameter :: u_FILE_u = __FILE__ +contains + +!=============================================================================== +subroutine mom_inline_init(gcomp, model_clock, model_mesh, mytask, rc) + type(ESMF_GridComp) , intent(in) :: gcomp !< ESMF_GridComp object + type(ESMF_Clock) , intent(in) :: model_clock !< ESMF_Clock object + type(ESMF_Mesh) , intent(in) :: model_mesh !< ESMF mesh + integer , intent(in) :: mytask !< the current task + integer , intent(out) :: rc !< Return code + + ! local variables + logical :: isPresent, isSet + integer :: ns, l + integer :: nstreams, nvars + type(shr_strdata_type) :: sdatconfig !< stream data from config (xml or esmf), one or more streams + + character(len=ESMF_MAXSTR) :: value, streamfilename + character(len=ESMF_MAXSTR), allocatable :: filelist(:) + character(len=ESMF_MAXSTR), allocatable :: filevars(:,:) + + character(len=*), parameter :: subname='(mom_inline_init)' + !---------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + call NUOPC_CompAttributeGet(gcomp, name="streamfilename", value=value, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + streamfilename = value + else + call ESMF_LogWrite(trim(subname)//': streamfilename must be provided', ESMF_LOGMSG_INFO) + call ESMF_Finalize(endflag=ESMF_END_ABORT) + return + endif + +#ifndef CESMCOUPLED + if (mytask == 0) then + open (newunit=logunit, file='log.mom6.cdeps') + else + logunit = 6 + endif + + ! CMEPS Init PIO + call dshr_pio_init(gcomp, sdatconfig, logunit, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! read the available stream definitions, each data stream is one or more data_files + ! which have the same spatial and temporal coordinates + call shr_stream_init_from_esmfconfig(trim(streamfilename), sdatconfig%stream, logunit, & + sdatconfig%pio_subsystem, sdatconfig%io_type, sdatconfig%io_format, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return +#else + !TODO: CESM logunit, configuration via xml etc + !call shr_stream_init_from_xml(trim(streamfilename) .... +#endif + + nstreams = size(sdatconfig%stream) + ! allocate stream data type + if (.not. allocated(sdat)) allocate(sdat(nstreams)) + + ! set the model clock and mesh + sdat(:)%model_clock = model_clock + sdat(:)%model_mesh = model_mesh + + ! loop over streams and initialize + do ns = 1, nstreams + sdat(ns)%pio_subsystem => sdatconfig%pio_subsystem + sdat(ns)%io_type = sdatconfig%io_type + sdat(ns)%io_format = sdatconfig%io_format + + allocate(filelist(sdatconfig%stream(ns)%nfiles)) + allocate(filevars(sdatconfig%stream(ns)%nvars,2)) + + ! fill stream info + do l = 1, sdatconfig%stream(ns)%nfiles + filelist(l) = trim(sdatconfig%stream(ns)%file(l)%name) + enddo + do l = 1, sdatconfig%stream(ns)%nvars + filevars(l,1) = trim(sdatconfig%stream(ns)%varlist(l)%nameinfile) + filevars(l,2) = trim(sdatconfig%stream(ns)%varlist(l)%nameinmodel) + enddo + + write(stream_name,fmt='(a,i2.2)') 'stream_', ns + call shr_strdata_init_from_inline(sdat(ns), & + my_task = mytask, & + logunit = logunit, & + compname = 'OCN', & + model_clock = sdat(ns)%model_clock, & + model_mesh = sdat(ns)%model_mesh, & + stream_name = trim(stream_name), & + stream_meshfile = trim(sdatconfig%stream(ns)%meshfile), & + stream_filenames = filelist, & + stream_yearFirst = sdatconfig%stream(ns)%yearFirst, & + stream_yearLast = sdatconfig%stream(ns)%yearLast, & + stream_yearAlign = sdatconfig%stream(ns)%yearAlign, & + stream_fldlistFile = filevars(:,1), & + stream_fldListModel = filevars(:,2), & + stream_lev_dimname = trim(sdatconfig%stream(ns)%lev_dimname), & + stream_mapalgo = trim(sdatconfig%stream(ns)%mapalgo), & + stream_offset = sdatconfig%stream(ns)%offset, & + stream_taxmode = trim(sdatconfig%stream(ns)%taxmode), & + stream_dtlimit = sdatconfig%stream(ns)%dtlimit, & + stream_tintalgo = trim(sdatconfig%stream(ns)%tInterpAlgo), & + stream_src_mask = sdatconfig%stream(ns)%src_mask_val, & + stream_dst_mask = sdatconfig%stream(ns)%dst_mask_val, & + rc = rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + deallocate(filelist) + deallocate(filevars) + enddo + +end subroutine mom_inline_init +!=============================================================================== +subroutine mom_inline_run(clock, ocean_public, ocean_grid, ice_ocean_boundary, dbug, rc) + use MOM_ocean_model_nuopc, only: ocean_public_type + use MOM_surface_forcing_nuopc, only: ice_ocean_boundary_type + use MOM_grid, only: ocean_grid_type + use mpp_domains_mod, only: mpp_get_compute_domain + + type(ESMF_Clock) , intent(in) :: clock !< ESMF_Clock object + type(ocean_public_type) , intent(in) :: ocean_public !< Ocean surface state + type(ocean_grid_type) , intent(in) :: ocean_grid !< Ocean model grid + type(ice_ocean_boundary_type) , intent(inout) :: ice_ocean_boundary !< Ocean boundary forcing + integer , intent(in) :: dbug !< Integer debug flag + integer , intent(out) :: rc !< Return code + + ! local variables + type(ESMF_Time) :: date + integer :: nstreams, nflds + integer :: ns,nf,n,i,j + integer :: isc, iec, jsc, jec + integer :: year ! year (0, ...) for nstep+1 + integer :: mon ! month (1, ..., 12) for nstep+1 + integer :: day ! day of month (1, ..., 31) for nstep+1 + integer :: sec ! seconds into current date for nstep+1 + integer :: mcdate ! Current model date (yyyymmdd) + character(len=ESMF_MAXSTR) :: fldname + real(ESMF_KIND_R8), pointer :: dataPtr1d(:) + character(len=*), parameter :: subname='(mom_inline_run)' + !----------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + ! The following are global indices without halos + call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) + + ! Current model date + call ESMF_ClockGet( clock, currTime=date, rc=rc ) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeGet(date, yy=year, mm=mon, dd=day, s=sec, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + mcdate = year*10000 + mon*100 + day + + nstreams = size(sdat) + ! Advance the streams + do ns = 1,nstreams + write(stream_name,fmt='(a,i2.2)') 'stream_', ns + call shr_strdata_advance(sdat(ns), ymd=mcdate, tod=sec, logunit=logunit, istr=trim(stream_name),rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + nflds = size(sdat(ns)%pstrm(1)%fldlist_model) + do nf = 1,nflds + fldname = trim(sdat(ns)%pstrm(1)%fldlist_model(nf)) + + if (fldname == 'lrunoff') then + ! Get pointer for stream data that is time and spatially interpolated to model time and grid + call dshr_fldbun_getFldPtr(sdat(ns)%pstrm(1)%fldbun_model, trim(fldname), dataPtr1d, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + n = 0 + do j = jsc,jec + do i = isc,iec + n = n + 1 + ice_ocean_boundary%lrunoff(i,j) = dataPtr1d(n) + enddo + enddo + endif + + if (dbug > 1) then + call dshr_fldbun_Field_diagnose(sdat(ns)%pstrm(1)%fldbun_model, trim(fldname), 'inline_run ', rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + endif + enddo !nf + enddo !ns + +end subroutine mom_inline_run +end module mom_inline_mod diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 448f23140e..b0a849dd62 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Top-level module for the MOM6 ocean model in coupled mode. module MOM_ocean_model_nuopc -! This file is part of MOM6. See LICENSE.md for the license. - ! This is the top level module for the MOM6 ocean model. It contains routines ! for initialization, termination and update of ocean model state. This ! particular version wraps all of the calls for MOM6 in the calls that had @@ -15,9 +17,10 @@ module MOM_ocean_model_nuopc use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized use MOM, only : get_ocean_stocks, step_offline +use MOM, only : save_MOM_restart use MOM_coms, only : field_chksum use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf -use MOM_diag_mediator, only : diag_ctrl, enable_averaging, disable_averaging +use MOM_diag_mediator, only : diag_ctrl, enable_averages, disable_averaging use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end use MOM_domains, only : pass_var, pass_vector, AGRID, BGRID_NE, CGRID_NE use MOM_domains, only : TO_ALL, Omit_Corners @@ -34,27 +37,26 @@ module MOM_ocean_model_nuopc use MOM_grid, only : ocean_grid_type use MOM_io, only : close_file, file_exists, read_data, write_version_number use MOM_marine_ice, only : iceberg_forces, iceberg_fluxes, marine_ice_init, marine_ice_CS -use MOM_restart, only : MOM_restart_CS, save_restart use MOM_string_functions, only : uppercase use MOM_time_manager, only : time_type, get_time, set_time, operator(>) use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) use MOM_time_manager, only : operator(/=), operator(<=), operator(>=) use MOM_time_manager, only : operator(<), real_to_time_type, time_type_to_real -use time_interp_external_mod,only : time_interp_external_init -use MOM_tracer_flow_control, only : call_tracer_flux_init +use MOM_interpolate, only : time_interp_external_init +use MOM_tracer_flow_control, only : tracer_flow_control_CS, call_tracer_flux_init, call_tracer_set_forcing use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type use MOM_ice_shelf, only : initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart -use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type -use coupler_types_mod, only : coupler_type_spawn, coupler_type_write_chksums -use coupler_types_mod, only : coupler_type_initialized, coupler_type_copy_data -use coupler_types_mod, only : coupler_type_set_diags, coupler_type_send_data +use MOM_ice_shelf, only : adjust_ice_sheet_frazil +use MOM_coupler_types, only : coupler_1d_bc_type, coupler_2d_bc_type +use MOM_coupler_types, only : coupler_type_spawn, coupler_type_write_chksums +use MOM_coupler_types, only : coupler_type_initialized, coupler_type_copy_data +use MOM_coupler_types, only : coupler_type_set_diags, coupler_type_send_data use mpp_domains_mod, only : domain2d, mpp_get_layout, mpp_get_global_domain use mpp_domains_mod, only : mpp_define_domains, mpp_get_compute_domain, mpp_get_data_domain -use fms_mod, only : stdout -use mpp_mod, only : mpp_chksum +use MOM_io, only : stdout use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct use MOM_wave_interface, only : wave_parameters_CS, MOM_wave_interface_init use MOM_wave_interface, only : Update_Surface_Waves, query_wave_properties @@ -109,17 +111,18 @@ module MOM_ocean_model_nuopc !! a global max across ocean and non-ocean processors can be !! used to determine its value. real, pointer, dimension(:,:) :: & - t_surf => NULL(), & !< SST on t-cell (degrees Kelvin) - s_surf => NULL(), & !< SSS on t-cell (psu) - u_surf => NULL(), & !< i-velocity at the locations indicated by stagger, m/s. - v_surf => NULL(), & !< j-velocity at the locations indicated by stagger, m/s. + t_surf => NULL(), & !< SST on t-cell (degrees Kelvin) + s_surf => NULL(), & !< SSS on t-cell (psu) + u_surf => NULL(), & !< i-velocity at the locations indicated by stagger, m/s. + v_surf => NULL(), & !< j-velocity at the locations indicated by stagger, m/s. sea_lev => NULL(), & !< Sea level in m after correction for surface pressure, - !! i.e. dzt(1) + eta_t + patm/rho0/grav (m) - frazil =>NULL(), & !< Accumulated heating (in Joules/m^2) from frazil - !! formation in the ocean. + !! i.e. dzt(1) + eta_t + patm/rho0/grav (m) + frazil =>NULL(), & !< Accumulated heating (in Joules/m^2) from frazil + !! formation in the ocean. melt_potential => NULL(), & !< Instantaneous heat used to melt sea ice (in J/m^2) - area => NULL(), & !< cell area of the ocean surface, in m2. - OBLD => NULL() !< Ocean boundary layer depth, in m. + area => NULL(), & !< cell area of the ocean surface, in m2. + OBLD => NULL(), & !< Ocean boundary layer depth, in m. + fco2_ocn => NULL() !< Ocean CO2 flux, in kg CO2/m^2/s type(coupler_2d_bc_type) :: fields !< A structure that may contain named !! arrays of tracer-related surface fields. integer :: avg_kount !< A count of contributions to running @@ -148,6 +151,7 @@ module MOM_ocean_model_nuopc logical :: use_ice_shelf !< If true, the ice shelf model is enabled. logical,public :: use_waves !< If true use wave coupling. character(len=40) :: wave_method !< Wave coupling method. + logical,public :: use_MARBL !< If true, use MARBL tracers. logical :: icebergs_alter_ocean !< If true, the icebergs can change ocean the !! ocean dynamics and forcing fluxes. @@ -172,7 +176,7 @@ module MOM_ocean_model_nuopc !! separate calls. The default is true. ! The following 3 variables are only used here if single_step_call is false. real :: dt !< (baroclinic) dynamics time step (seconds) - real :: dt_therm !< thermodynamics time step (seconds) + real :: dt_therm !< thermodynamics time step [T ~> s] logical :: thermo_spans_coupling !< If true, thermodynamic and tracer time !! steps can span multiple coupled time steps. logical :: diabatic_first !< If true, apply diabatic and thermodynamic @@ -211,13 +215,12 @@ module MOM_ocean_model_nuopc type(marine_ice_CS), pointer :: & marine_ice_CSp => NULL() !< A pointer to the control structure for the !! marine ice effects module. + type(tracer_flow_control_CS), pointer :: & + tracer_flow_CSp => NULL() !< A pointer to the tracer flow control structure type(wave_parameters_CS), pointer, public :: & Waves => NULL() !< A pointer to the surface wave control structure type(surface_forcing_CS), pointer :: & forcing_CSp => NULL() !< A pointer to the MOM forcing control structure - type(MOM_restart_CS), pointer :: & - restart_CSp => NULL() !< A pointer set to the restart control structure - !! that will be used for MOM restart files. type(diag_ctrl), pointer :: & diag => NULL() !< A pointer to the diagnostic regulatory structure end type ocean_state_type @@ -230,7 +233,7 @@ module MOM_ocean_model_nuopc !! This subroutine initializes both the ocean state and the ocean surface type. !! Because of the way that indicies and domains are handled, Ocean_sfc must have !! been used in a previous call to initialize_ocean_type. -subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, input_restart_file) +subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, input_restart_file, inst_index) type(ocean_public_type), target, & intent(inout) :: Ocean_sfc !< A structure containing various publicly !! visible ocean surface properties after initialization, @@ -247,6 +250,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i !! tracer fluxes, and can be used to spawn related !! internal variables in the ice model. character(len=*), optional, intent(in) :: input_restart_file !< If present, name of restart file to read + integer, optional :: inst_index !< Ensemble index provided by the cap (instead of FMS ensemble manager) ! Local variables real :: Rho0 ! The Boussinesq ocean density, in kg m-3. @@ -256,7 +260,6 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i !! min(HFrz, OBLD), where OBLD is the boundary layer depth. !! If HFrz <= 0 (default), melt potential will not be computed. logical :: use_melt_pot !< If true, allocate melt_potential array - logical :: use_CFC !< If true, allocated arrays for surface CFCs. ! This include declares and sets the variable "version". @@ -282,9 +285,10 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i OS%Time = Time_in call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & - OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & + Time_in, offline_tracer_mode=OS%offline_tracer_mode, & input_restart_file=input_restart_file, & - diag_ptr=OS%diag, count_calls=.true.) + diag_ptr=OS%diag, count_calls=.true., tracer_flow_CSp=OS%tracer_flow_CSp, & + waves_CSp=OS%Waves, ensemble_num=inst_index) call get_MOM_state_elements(OS%MOM_CSp, G=OS%grid, GV=OS%GV, US=OS%US, C_p=OS%C_p, & C_p_scaled=OS%fluxes%C_p, use_temp=use_temperature) @@ -296,16 +300,17 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i "including both dynamics and thermodynamics. If false, "//& "the two phases are advanced with separate calls.", default=.true.) call get_param(param_file, mdl, "DT", OS%dt, & - "The (baroclinic) dynamics time step. The time-step that "//& - "is actually used will be an integer fraction of the "//& - "forcing time-step.", units="s", fail_if_missing=.true.) + "The (baroclinic) dynamics time step. The time-step that is actually "//& + "used will be an integer fraction of the forcing time-step.", & + units="s", scale=OS%US%s_to_T, fail_if_missing=.true.) call get_param(param_file, mdl, "DT_THERM", OS%dt_therm, & "The thermodynamic and tracer advection time step. "//& "Ideally DT_THERM should be an integer multiple of DT "//& "and less than the forcing or coupling time-step, unless "//& "THERMO_SPANS_COUPLING is true, in which case DT_THERM "//& "can be an integer multiple of the coupling timestep. By "//& - "default DT_THERM is set to DT.", units="s", default=OS%dt) + "default DT_THERM is set to DT.", & + units="s", default=OS%US%T_to_s*OS%dt, scale=OS%US%s_to_T) call get_param(param_file, "MOM", "THERMO_SPANS_COUPLING", OS%thermo_spans_coupling, & "If true, the MOM will take thermodynamic and tracer "//& "timesteps that can be longer than the coupling timestep. "//& @@ -349,7 +354,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i call get_param(param_file, mdl, "RHO_0", Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& + "properties, or with BOUSSINESQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0) call get_param(param_file, mdl, "G_EARTH", G_Earth, & @@ -376,21 +381,24 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i use_melt_pot=.false. endif - call get_param(param_file, mdl, "USE_CFC_CAP", use_CFC, & + call get_param(param_file, mdl, "USE_WAVES", OS%Use_Waves, & + "If true, enables surface wave modules.", default=.false.) + call get_param(param_file, mdl, "USE_MARBL_TRACERS", OS%use_MARBL, & default=.false., do_not_log=.true.) ! Consider using a run-time flag to determine whether to do the diagnostic ! vertical integrals, since the related 3-d sums are not negligible in cost. call allocate_surface_state(OS%sfc_state, OS%grid, use_temperature, & do_integrals=.true., gas_fields_ocn=gas_fields_ocn, & - use_meltpot=use_melt_pot, use_cfcs=use_CFC) + use_meltpot=use_melt_pot, use_iceshelves=OS%use_ice_shelf, & + use_marbl_tracers=OS%use_MARBL) call surface_forcing_init(Time_in, OS%grid, OS%US, param_file, OS%diag, & OS%forcing_CSp, OS%restore_salinity, OS%restore_temp, OS%use_waves) if (OS%use_ice_shelf) then call initialize_ice_shelf(param_file, OS%grid, OS%Time, OS%ice_shelf_CSp, & - OS%diag, OS%forces, OS%fluxes) + OS%diag, Time_init, OS%dirs%output_directory, OS%forces, OS%fluxes) endif if (OS%icebergs_alter_ocean) then call marine_ice_init(OS%Time, OS%grid, param_file, OS%diag, OS%marine_ice_CSp) @@ -398,12 +406,11 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i call allocate_forcing_type(OS%grid, OS%fluxes, shelf=.true.) endif - call allocate_forcing_type(OS%grid, OS%fluxes, waves=.true.) - call get_param(param_file, mdl, "USE_WAVES", OS%Use_Waves, & - "If true, enables surface wave modules.", default=.false.) if (OS%Use_Waves) then call get_param(param_file, mdl, "WAVE_METHOD", OS%wave_method, default="EMPTY", do_not_log=.true.) endif + call allocate_forcing_type(OS%grid, OS%fluxes, waves=.true., lamult=(trim(OS%wave_method)=="EFACTOR")) + ! MOM_wave_interface_init is called regardless of the value of USE_WAVES because ! it also initializes statistical waves. call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag) @@ -425,11 +432,18 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i call extract_surface_state(OS%MOM_CSp, OS%sfc_state) + if (OS%use_ice_shelf .and. allocated(OS%sfc_state%frazil)) & + call adjust_ice_sheet_frazil(OS%sfc_state, OS%fluxes, OS%Ice_shelf_CSp) + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US) endif call extract_surface_state(OS%MOM_CSp, OS%sfc_state) + + if (OS%use_ice_shelf .and. allocated(OS%sfc_state%frazil)) & + call adjust_ice_sheet_frazil(OS%sfc_state, OS%fluxes, OS%Ice_shelf_CSp) + ! get number of processors and PE list for stocasthci physics initialization call get_param(param_file, mdl, "DO_SPPT", OS%do_sppt, & "If true, then stochastically perturb the thermodynamic "//& @@ -446,7 +460,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i call diag_mediator_close_registration(OS%diag) if (is_root_pe()) & - write(*,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========' + write(stdout,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========' call callTree_leave("ocean_model_init(") end subroutine ocean_model_init @@ -458,7 +472,7 @@ end subroutine ocean_model_init !! storing the new ocean properties in Ocean_state. subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & time_start_update, Ocean_coupling_time_step, & - update_dyn, update_thermo, Ocn_fluxes_used) + cesm_coupled, update_dyn, update_thermo, Ocn_fluxes_used) type(ice_ocean_boundary_type), & intent(in) :: Ice_ocean_boundary !< A structure containing the !! various forcing fields coming from the ice. @@ -473,6 +487,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & type(time_type), intent(in) :: time_start_update !< The time at the beginning of the update step. type(time_type), intent(in) :: Ocean_coupling_time_step !< The amount of time over !! which to advance the ocean. + logical, intent(in) :: cesm_coupled !< Flag to check if coupled with cesm logical, optional, intent(in) :: update_dyn !< If present and false, do not do updates !! due to the ocean dynamics. logical, optional, intent(in) :: update_thermo !< If present and false, do not do updates @@ -488,13 +503,13 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & integer :: index_bnds(4) ! The computational domain index bounds in the ! ice-ocean boundary type. real :: weight ! Flux accumulation weight - real :: dt_coupling ! The coupling time step in seconds. + real :: dt_coupling ! The coupling time step in rescaled seconds [T ~> s]. integer :: nts ! The number of baroclinic dynamics time steps ! within dt_coupling. - real :: dt_therm ! A limited and quantized version of OS%dt_therm (sec) - real :: dt_dyn ! The dynamics time step in sec. - real :: dtdia ! The diabatic time step in sec. - real :: t_elapsed_seg ! The elapsed time in this update segment, in s. + real :: dt_therm ! A limited and quantized version of OS%dt_therm [T ~> s] + real :: dt_dyn ! The dynamics time step [T ~> s] + real :: dtdia ! The diabatic time step [T ~> s] + real :: t_elapsed_seg ! The elapsed time in this update segment [T ~> s] integer :: n, n_max, n_last_thermo type(time_type) :: Time2 ! A temporary time. logical :: thermo_does_span_coupling ! If true, thermodynamic forcing spans @@ -507,7 +522,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call callTree_enter("update_ocean_model(), MOM_ocean_model_nuopc.F90") call get_time(Ocean_coupling_time_step, secs, days) - dt_coupling = 86400.0*real(days) + real(secs) + dt_coupling = OS%US%s_to_T*(86400.0*real(days) + real(secs)) if (time_start_update /= OS%Time) then call MOM_error(WARNING, "update_ocean_model: internal clock does not "//& @@ -522,7 +537,6 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & do_dyn = .true. ; if (present(update_dyn)) do_dyn = update_dyn do_thermo = .true. ; if (present(update_thermo)) do_thermo = update_thermo - ! This is benign but not necessary if ocean_model_init_sfc was called or if ! OS%sfc_state%tr_fields was spawned in ocean_model_init. Consider removing it. is = OS%grid%isc ; ie = OS%grid%iec ; js = OS%grid%jsc ; je = OS%grid%jec @@ -539,6 +553,10 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & OS%grid, OS%US, OS%forcing_CSp) if (OS%fluxes%fluxes_used) then + + ! enable_averages() is necessary to post forcing fields to diagnostics + call enable_averages(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) + if (do_thermo) & call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, index_bnds, OS%Time, dt_coupling, & OS%grid, OS%US, OS%forcing_CSp, OS%sfc_state, & @@ -564,14 +582,14 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call copy_common_forcing_fields(OS%forces, OS%fluxes, OS%grid, skip_pres=.true.) #ifdef _USE_GENERIC_TRACER - call enable_averaging(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) !Is this needed? + call enable_averages(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) !Is this needed? call MOM_generic_tracer_fluxes_accumulate(OS%fluxes, weight) !here weight=1, just saving the current fluxes #endif else OS%flux_tmp%C_p = OS%fluxes%C_p if (do_thermo) & call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%flux_tmp, index_bnds, OS%Time, dt_coupling, & - OS%grid, OS%US, OS%forcing_CSp, OS%sfc_state, OS%restore_salinity,OS%restore_temp) + OS%grid, OS%US, OS%forcing_CSp, OS%sfc_state, OS%restore_salinity, OS%restore_temp) if (OS%use_ice_shelf) then if (do_thermo) & @@ -607,9 +625,14 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & endif if (OS%nstep==0) then - call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%restart_CSp) + call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp) endif + if (do_thermo) & + call call_tracer_set_forcing(OS%sfc_state, OS%fluxes, OS%Time, & + real_to_time_type(dt_coupling), OS%grid, OS%US, OS%GV%Rho0, & + OS%tracer_flow_CSp) + call disable_averaging(OS%diag) Master_time = OS%Time ; Time1 = OS%Time @@ -671,7 +694,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (step_thermo) then ! Back up Time2 to the start of the thermodynamic segment. - Time2 = Time2 - set_time(int(floor((dtdia - dt_dyn) + 0.5))) + Time2 = Time2 - set_time(int(floor(OS%US%T_to_s*(dtdia - dt_dyn) + 0.5))) call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) @@ -679,7 +702,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & endif t_elapsed_seg = t_elapsed_seg + dt_dyn - Time2 = Time1 + set_time(int(floor(t_elapsed_seg + 0.5))) + Time2 = Time1 + set_time(int(floor(OS%US%T_to_s*t_elapsed_seg + 0.5))) enddo endif @@ -689,9 +712,18 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call mech_forcing_diags(OS%forces, dt_coupling, OS%grid, OS%Time, OS%diag, OS%forcing_CSp%handles) if (OS%fluxes%fluxes_used) then - call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%grid, OS%US, OS%Time, OS%diag, OS%forcing_CSp%handles) + if (cesm_coupled) then + call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%grid, OS%US, OS%Time, OS%diag, & + OS%forcing_CSp%handles, enthalpy=.true.) + else + call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%grid, OS%US, OS%Time, OS%diag, OS%forcing_CSp%handles) + endif endif + !only make ice-shelf frazil adjustments if sfc_state%frazil was updated (do_thermo=True) + if (do_thermo .and. OS%use_ice_shelf .and. allocated(OS%sfc_state%frazil)) & + call adjust_ice_sheet_frazil(OS%sfc_state, OS%fluxes, OS%Ice_shelf_CSp) + ! Translate state into Ocean. ! call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, & ! Ice_ocean_boundary%p, OS%press_to_z) @@ -724,38 +756,38 @@ subroutine ocean_model_restart(OS, timestamp, restartname, stoch_restartname, nu "restart files can only be created after the buoyancy forcing is applied.") if (present(restartname)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV, filename=restartname, num_rest_files=num_rest_files) - call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & - OS%dirs%restart_output_dir) ! Is this needed? - if (OS%use_ice_shelf) then - call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, & - OS%dirs%restart_output_dir) - endif + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, GV=OS%GV, filename=restartname, num_rest_files=num_rest_files) + call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & + OS%dirs%restart_output_dir) ! Is this needed? + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, & + OS%dirs%restart_output_dir) + endif else - if (BTEST(OS%Restart_control,1)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, .true., GV=OS%GV) - call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & - OS%dirs%restart_output_dir, .true.) - if (OS%use_ice_shelf) then - call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) - endif - endif - if (BTEST(OS%Restart_control,0)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV) - call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & - OS%dirs%restart_output_dir) - if (OS%use_ice_shelf) then - call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) - endif - endif + if (BTEST(OS%Restart_control,1)) then + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, time_stamped=.true., GV=OS%GV) + call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & + OS%dirs%restart_output_dir, time_stamped=.true.) + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) + endif + endif + if (BTEST(OS%Restart_control,0)) then + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, GV=OS%GV) + call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & + OS%dirs%restart_output_dir) + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) + endif + endif endif if (present(stoch_restartname)) then - if (OS%do_sppt .OR. OS%pert_epbl) then - call write_stoch_restart_ocn('RESTART/'//trim(stoch_restartname)) - endif + if (OS%do_sppt .OR. OS%pert_epbl) then + call write_stoch_restart_ocn('RESTART/'//trim(stoch_restartname)) + endif endif end subroutine ocean_model_restart @@ -772,7 +804,7 @@ subroutine ocean_model_end(Ocean_sfc, Ocean_state, Time, write_restart) type(time_type), intent(in) :: Time !< The model time, used for writing restarts. logical, intent(in) :: write_restart !< true => write restart file - if(write_restart)call ocean_model_save_restart(Ocean_state, Time) + if (write_restart) call ocean_model_save_restart(Ocean_state, Time) call diag_mediator_end(Time, Ocean_state%diag, end_diag_manager=.true.) call MOM_end(Ocean_state%MOM_CSp) if (Ocean_state%use_ice_shelf) call ice_shelf_end(Ocean_state%Ice_shelf_CSp) @@ -804,14 +836,13 @@ subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) if (present(directory)) then ; restart_dir = directory else ; restart_dir = OS%dirs%restart_output_dir ; endif - call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, restart_dir, Time, OS%grid, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, Time, restart_dir) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) endif - end subroutine ocean_model_save_restart !> Initialize the public ocean type @@ -839,31 +870,25 @@ subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, maskmap, call mpp_get_layout(input_domain,layout) call mpp_get_global_domain(input_domain, xsize=xsz, ysize=ysz) if (PRESENT(maskmap)) then - call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain, maskmap=maskmap) + call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain, maskmap=maskmap) else - call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain) + call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain) endif call mpp_get_compute_domain(Ocean_sfc%Domain, isc, iec, jsc, jec) - allocate ( Ocean_sfc%t_surf (isc:iec,jsc:jec), & - Ocean_sfc%s_surf (isc:iec,jsc:jec), & - Ocean_sfc%u_surf (isc:iec,jsc:jec), & - Ocean_sfc%v_surf (isc:iec,jsc:jec), & - Ocean_sfc%sea_lev(isc:iec,jsc:jec), & - Ocean_sfc%area (isc:iec,jsc:jec), & - Ocean_sfc%OBLD (isc:iec,jsc:jec), & - Ocean_sfc%melt_potential(isc:iec,jsc:jec), & - Ocean_sfc%frazil (isc:iec,jsc:jec)) - - Ocean_sfc%t_surf = 0.0 ! time averaged sst (Kelvin) passed to atmosphere/ice model - Ocean_sfc%s_surf = 0.0 ! time averaged sss (psu) passed to atmosphere/ice models - Ocean_sfc%u_surf = 0.0 ! time averaged u-current (m/sec) passed to atmosphere/ice models - Ocean_sfc%v_surf = 0.0 ! time averaged v-current (m/sec) passed to atmosphere/ice models - Ocean_sfc%sea_lev = 0.0 ! time averaged thickness of top model grid cell (m) plus patm/rho0/grav - Ocean_sfc%frazil = 0.0 ! time accumulated frazil (J/m^2) passed to ice model - Ocean_sfc%melt_potential = 0.0 ! time accumulated melt potential (J/m^2) passed to ice model - Ocean_sfc%OBLD = 0.0 ! ocean boundary layer depth, in m - Ocean_sfc%area = 0.0 + allocate(Ocean_sfc%t_surf (isc:iec,jsc:jec), & ! time averaged sst (Kelvin) passed to atmosphere/ice model + Ocean_sfc%s_surf (isc:iec,jsc:jec), & ! time averaged sss (psu) passed to atmosphere/ice models + Ocean_sfc%u_surf (isc:iec,jsc:jec), & ! time averaged u-current (m/sec) passed to atmosphere/ice models + Ocean_sfc%v_surf (isc:iec,jsc:jec), & ! time averaged v-current (m/sec) passed to atmosphere/ice models + Ocean_sfc%sea_lev(isc:iec,jsc:jec), & ! time averaged thickness of top model grid cell (m) plus + ! patm/rho0/grav + Ocean_sfc%frazil (isc:iec,jsc:jec), & ! time accumulated frazil (J/m^2) passed to ice model + Ocean_sfc%melt_potential(isc:iec,jsc:jec), & ! time accumulated melt potential (J/m^2) passed to ice model + Ocean_sfc%area (isc:iec,jsc:jec), & + Ocean_sfc%OBLD (isc:iec,jsc:jec), & ! ocean boundary layer depth, in m + Ocean_sfc%fco2_ocn(isc:iec,jsc:jec), & ! time averaged co2 flux (kg/m^2/s) passed to atmosphere model + source=0.0) + Ocean_sfc%axes = diag%axesT1%handles !diag axes to be used by coupler tracer flux diagnostics if (present(gas_fields_ocn)) then @@ -911,22 +936,22 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_ if (sfc_state%T_is_conT) then ! Convert the surface T from conservative T to potential T. do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%t_surf(i,j) = gsw_pt_from_ct(sfc_state%SSS(i+i0,j+j0), & - sfc_state%SST(i+i0,j+j0)) + CELSIUS_KELVIN_OFFSET + Ocean_sfc%t_surf(i,j) = gsw_pt_from_ct(US%S_to_ppt*sfc_state%SSS(i+i0,j+j0), & + US%C_to_degC*sfc_state%SST(i+i0,j+j0)) + CELSIUS_KELVIN_OFFSET enddo ; enddo else do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%t_surf(i,j) = sfc_state%SST(i+i0,j+j0) + CELSIUS_KELVIN_OFFSET + Ocean_sfc%t_surf(i,j) = US%C_to_degC*sfc_state%SST(i+i0,j+j0) + CELSIUS_KELVIN_OFFSET enddo ; enddo endif if (sfc_state%S_is_absS) then ! Convert the surface S from absolute salinity to practical salinity. do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%s_surf(i,j) = gsw_sp_from_sr(sfc_state%SSS(i+i0,j+j0)) + Ocean_sfc%s_surf(i,j) = gsw_sp_from_sr(US%S_to_ppt*sfc_state%SSS(i+i0,j+j0)) enddo ; enddo else do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%s_surf(i,j) = sfc_state%SSS(i+i0,j+j0) + Ocean_sfc%s_surf(i,j) = US%S_to_ppt*sfc_state%SSS(i+i0,j+j0) enddo ; enddo endif @@ -960,6 +985,12 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_ enddo ; enddo endif + if (allocated(sfc_state%fco2)) then + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%fco2_ocn(i,j) = US%RZ_T_to_kg_m2s * sfc_state%fco2(i+i0,j+j0) + enddo ; enddo + endif + if (Ocean_sfc%stagger == AGRID) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd Ocean_sfc%u_surf(i,j) = G%mask2dT(i+i0,j+j0) * US%L_T_to_m_s * & @@ -1012,6 +1043,9 @@ subroutine ocean_model_init_sfc(OS, Ocean_sfc) call extract_surface_state(OS%MOM_CSp, OS%sfc_state) + if (OS%use_ice_shelf .and. allocated(OS%sfc_state%frazil)) & + call adjust_ice_sheet_frazil(OS%sfc_state, OS%fluxes, OS%Ice_shelf_CSp) + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, OS%US) end subroutine ocean_model_init_sfc @@ -1041,7 +1075,7 @@ end subroutine ocean_model_flux_init !> This interface allows certain properties that are stored in the ocean_state_type to be !! obtained. -subroutine query_ocean_state(OS, use_waves, NumWaveBands, Wavenumbers, unscale, wave_method) +subroutine query_ocean_state(OS, use_waves, NumWaveBands, Wavenumbers, unscale, wave_method, use_MARBL) type(ocean_state_type), intent(in) :: OS !< The structure with the complete ocean state logical, optional, intent(out) :: use_waves !< Indicates whether surface waves are in use integer, optional, intent(out) :: NumWaveBands !< If present, this gives the number of @@ -1051,6 +1085,7 @@ subroutine query_ocean_state(OS, use_waves, NumWaveBands, Wavenumbers, unscale, logical, optional, intent(in) :: unscale !< If present and true, undo any dimensional !! rescaling and return dimensional values in MKS units character(len=40), optional, intent(out) :: wave_method !< Wave coupling method. + logical, optional, intent(out) :: use_MARBL !< Indicates whether MARBL is in use. logical :: undo_scaling undo_scaling = .false. ; if (present(unscale)) undo_scaling = unscale @@ -1063,6 +1098,7 @@ subroutine query_ocean_state(OS, use_waves, NumWaveBands, Wavenumbers, unscale, call query_wave_properties(OS%Waves, WaveNumbers=WaveNumbers) endif if (present(wave_method)) wave_method = OS%wave_method + if (present(use_MARBL)) use_MARBL = OS%use_MARBL end subroutine query_ocean_state @@ -1099,7 +1135,7 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) case (ISTOCK_HEAT) ! Return the heat content of the ocean in J. call get_ocean_stocks(OS%MOM_CSp, heat=value, on_PE_only=.true.) case (ISTOCK_SALT) ! Return the mass of the salt in the ocean in kg. - call get_ocean_stocks(OS%MOM_CSp, salt=value, on_PE_only=.true.) + call get_ocean_stocks(OS%MOM_CSp, salt=value, on_PE_only=.true.) case default ; value = 0.0 end select ! If the FMS coupler is changed so that Ocean_stock_PE is only called on @@ -1118,20 +1154,18 @@ subroutine ocean_public_type_chksum(id, timestep, ocn) ! Local variables integer(kind=int64) :: chks ! A checksum for the field logical :: root ! True only on the root PE - integer :: outunit ! The output unit to write to - outunit = stdout() root = is_root_pe() - if (root) write(outunit,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep - chks = field_chksum(ocn%t_surf ) ; if (root) write(outunit,100) 'ocean%t_surf ', chks - chks = field_chksum(ocn%s_surf ) ; if (root) write(outunit,100) 'ocean%s_surf ', chks - chks = field_chksum(ocn%u_surf ) ; if (root) write(outunit,100) 'ocean%u_surf ', chks - chks = field_chksum(ocn%v_surf ) ; if (root) write(outunit,100) 'ocean%v_surf ', chks - chks = field_chksum(ocn%sea_lev) ; if (root) write(outunit,100) 'ocean%sea_lev ', chks - chks = field_chksum(ocn%frazil ) ; if (root) write(outunit,100) 'ocean%frazil ', chks - chks = field_chksum(ocn%melt_potential) ; if (root) write(outunit,100) 'ocean%melt_potential ', chks - call coupler_type_write_chksums(ocn%fields, outunit, 'ocean%') + if (root) write(stdout,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep + chks = field_chksum(ocn%t_surf ) ; if (root) write(stdout,100) 'ocean%t_surf ', chks + chks = field_chksum(ocn%s_surf ) ; if (root) write(stdout,100) 'ocean%s_surf ', chks + chks = field_chksum(ocn%u_surf ) ; if (root) write(stdout,100) 'ocean%u_surf ', chks + chks = field_chksum(ocn%v_surf ) ; if (root) write(stdout,100) 'ocean%v_surf ', chks + chks = field_chksum(ocn%sea_lev) ; if (root) write(stdout,100) 'ocean%sea_lev ', chks + chks = field_chksum(ocn%frazil ) ; if (root) write(stdout,100) 'ocean%frazil ', chks + chks = field_chksum(ocn%melt_potential) ; if (root) write(stdout,100) 'ocean%melt_potential ', chks + call coupler_type_write_chksums(ocn%fields, stdout, 'ocean%') 100 FORMAT(" CHECKSUM::",A20," = ",Z20) end subroutine ocean_public_type_chksum @@ -1148,7 +1182,7 @@ end subroutine get_ocean_grid !> Returns eps_omesh read from param file real function get_eps_omesh(OS) type(ocean_state_type) :: OS - get_eps_omesh = OS%eps_omesh; return + get_eps_omesh = OS%eps_omesh ; return end function end module MOM_ocean_model_nuopc diff --git a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 index c704214930..55fe016c22 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -1,27 +1,34 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Converts the input ESMF data (import data) to a MOM-specific data type (surface_forcing_CS). module MOM_surface_forcing_nuopc -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_coms, only : reproducing_sum, field_chksum use MOM_constants, only : hlv, hlf +use MOM_coupler_types, only : coupler_2d_bc_type, coupler_type_write_chksums +use MOM_coupler_types, only : coupler_type_initialized, coupler_type_spawn +use MOM_coupler_types, only : coupler_type_copy_data use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_SUBCOMPONENT +use MOM_data_override, only : data_override_init, data_override use MOM_diag_mediator, only : diag_ctrl use MOM_diag_mediator, only : safe_alloc_ptr, time_type use MOM_domains, only : pass_vector, pass_var, fill_symmetric_edges -use MOM_domains, only : global_field_sum, BITWISE_EXACT_SUM use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All use MOM_domains, only : To_North, To_East, Omit_Corners use MOM_error_handler, only : MOM_error, WARNING, FATAL, is_root_pe, MOM_mesg -use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing, mech_forcing use MOM_forcing_type, only : forcing_diags, mech_forcing_diags, register_forcing_type_diags use MOM_forcing_type, only : allocate_forcing_type, deallocate_forcing_type use MOM_forcing_type, only : allocate_mech_forcing, deallocate_mech_forcing use MOM_get_input, only : Get_MOM_Input, directories use MOM_grid, only : ocean_grid_type -use MOM_CFC_cap, only : CFC_cap_fluxes +use MOM_interpolate, only : init_external_field, time_interp_external +use MOM_interpolate, only : time_interp_external_init +use MOM_interpolate, only : external_field use MOM_io, only : slasher, write_version_number, MOM_read_data use MOM_io, only : stdout use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS @@ -32,15 +39,9 @@ module MOM_surface_forcing_nuopc use MOM_variables, only : surface use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init use user_revise_forcing, only : user_revise_forcing_CS - -use coupler_types_mod, only : coupler_2d_bc_type, coupler_type_write_chksums -use coupler_types_mod, only : coupler_type_initialized, coupler_type_spawn -use coupler_types_mod, only : coupler_type_copy_data -use data_override_mod, only : data_override_init, data_override -use mpp_mod, only : mpp_chksum -use time_interp_external_mod, only : init_external_field, time_interp_external -use time_interp_external_mod, only : time_interp_external_init -use iso_fortran_env, only : int64 +use iso_fortran_env, only : int64 +use MARBL_forcing_mod, only : marbl_forcing_CS, MARBL_forcing_init +use MARBL_forcing_mod, only : convert_driver_fields_to_forcings implicit none ; private @@ -67,7 +68,7 @@ module MOM_surface_forcing_nuopc real :: wind_stress_multiplier !< A multiplier applied to incoming wind stress (nondim). real :: Rho0 !< Boussinesq reference density [R ~> kg m-3] - real :: area_surf = -1.0 !< total ocean surface area [m^2] + real :: area_surf = -1.0 !< total ocean surface area [L2 ~> m2] real :: latent_heat_fusion !< latent heat of fusion [J/kg] real :: latent_heat_vapor !< latent heat of vaporization [J/kg] @@ -82,14 +83,17 @@ module MOM_surface_forcing_nuopc !! pressure limited by max_p_surf instead of the !! full atmospheric pressure. The default is true. logical :: use_CFC !< enables the MOM_CFC_cap tracer package. - real :: gust_const !< constant unresolved background gustiness for ustar [R L Z T-1 ~> Pa] + logical :: use_marbl_tracers !< enables the MARBL tracer package. + logical :: enthalpy_cpl !< Controls if enthalpy terms are provided by the coupler or computed + !! internally. + real :: gust_const !< constant unresolved background gustiness for ustar [R L Z T-2 ~> Pa] logical :: read_gust_2d !< If true, use a 2-dimensional gustiness supplied !! from an input file. real, pointer, dimension(:,:) :: & TKE_tidal => NULL(), & !< turbulent kinetic energy introduced to the !! bottom boundary layer by drag on the tidal flows [R Z3 T-3 ~> W m-2] gust => NULL(), & !< spatially varying unresolved background - !! gustiness that contributes to ustar [R L Z T-1 ~> Pa]. + !! gustiness that contributes to ustar [R L Z T-2 ~> Pa]. !! gust is used when read_gust_2d is true. ustar_tidal => NULL() !< tidal contribution to the bottom friction velocity [Z T-1 ~> m s-1] real :: cd_tides !< drag coefficient that applies to the tides (nondimensional) @@ -122,15 +126,14 @@ module MOM_surface_forcing_nuopc !! criteria for salinity restoring. real :: ice_salt_concentration !< salt concentration for sea ice [kg/kg] logical :: mask_srestore_marginal_seas !< if true, then mask SSS restoring in marginal seas - real :: max_delta_srestore !< maximum delta salinity used for restoring - real :: max_delta_trestore !< maximum delta sst used for restoring + real :: max_delta_srestore !< maximum delta salinity used for restoring [S ~> ppt] + real :: max_delta_trestore !< maximum delta sst used for restoring [C ~> degC] real, pointer, dimension(:,:) :: basin_mask => NULL() !< mask for SSS restoring by basin - logical :: fix_ustar_gustless_bug !< If true correct a bug in the time-averaging of the + logical :: ustar_gustless_bug !< If true, include a bug in the time-averaging of the !! gustless wind friction velocity. type(diag_ctrl), pointer :: diag !< structure to regulate diagnostic output timing character(len=200) :: inputdir !< directory where NetCDF input files are - character(len=200) :: CFC_BC_file !< filename with cfc11 and cfc12 data character(len=200) :: salt_restore_file !< filename for salt restoring data character(len=30) :: salt_restore_var_name !< name of surface salinity in salt_restore_file logical :: mask_srestore !< if true, apply a 2-dimensional mask to the surface @@ -144,62 +147,83 @@ module MOM_surface_forcing_nuopc !! temperature restoring fluxes. The masking file should be !! in inputdir/temp_restore_mask.nc and the field should !! be named 'mask' - character(len=30) :: cfc11_var_name !< name of cfc11 in CFC_BC_file - character(len=30) :: cfc12_var_name !< name of cfc11 in CFC_BC_file real, pointer, dimension(:,:) :: trestore_mask => NULL() !< mask for SST restoring - integer :: id_srestore = -1 !< id number for time_interp_external. - integer :: id_trestore = -1 !< id number for time_interp_external. - integer :: id_cfc11_atm = -1 !< id number for time_interp_external. - integer :: id_cfc12_atm = -1 !< id number for time_interp_external. - + type(external_field) :: srestore_handle + !< Handle for time-interpolated salt restoration field + type(external_field) :: trestore_handle + !< Handle for time-interpolated temperature restoration field ! Diagnostics handles type(forcing_diags), public :: handles type(MOM_restart_CS), pointer :: restart_CSp => NULL() type(user_revise_forcing_CS), pointer :: urf_CS => NULL() + + type(marbl_forcing_CS), pointer :: marbl_forcing_CSp => NULL() !< parameters for getting MARBL forcing end type surface_forcing_CS !> Structure corresponding to forcing, but with the elements, units, and conventions !! that exactly conform to the use for MOM-based coupled models. type, public :: ice_ocean_boundary_type - real, pointer, dimension(:,:) :: lrunoff =>NULL() !< liquid runoff [kg/m2/s] - real, pointer, dimension(:,:) :: frunoff =>NULL() !< ice runoff [kg/m2/s] + real, pointer, dimension(:,:) :: lrunoff =>NULL() !< liquid runoff [km m-2 s-1] + real, pointer, dimension(:,:) :: frunoff =>NULL() !< ice runoff [km m-2 s-1] + real, pointer, dimension(:,:) :: lrunoff_glc =>NULL() !< liquid glc runoff via rof [km m-2 s-1] + real, pointer, dimension(:,:) :: frunoff_glc =>NULL() !< frozen glc runoff via rof [km m-2 s-1] real, pointer, dimension(:,:) :: u_flux =>NULL() !< i-direction wind stress [Pa] real, pointer, dimension(:,:) :: v_flux =>NULL() !< j-direction wind stress [Pa] - real, pointer, dimension(:,:) :: t_flux =>NULL() !< sensible heat flux [W/m2] - real, pointer, dimension(:,:) :: q_flux =>NULL() !< specific humidity flux [kg/m2/s] - real, pointer, dimension(:,:) :: salt_flux =>NULL() !< salt flux [kg/m2/s] - real, pointer, dimension(:,:) :: seaice_melt_heat =>NULL() !< sea ice and snow melt heat flux [W/m2] - real, pointer, dimension(:,:) :: seaice_melt =>NULL() !< water flux due to sea ice and snow melting [kg/m2/s] - real, pointer, dimension(:,:) :: lw_flux =>NULL() !< long wave radiation [W/m2] - real, pointer, dimension(:,:) :: sw_flux_vis_dir =>NULL() !< direct visible sw radiation [W/m2] - real, pointer, dimension(:,:) :: sw_flux_vis_dif =>NULL() !< diffuse visible sw radiation [W/m2] - real, pointer, dimension(:,:) :: sw_flux_nir_dir =>NULL() !< direct Near InfraRed sw radiation [W/m2] - real, pointer, dimension(:,:) :: sw_flux_nir_dif =>NULL() !< diffuse Near InfraRed sw radiation [W/m2] - real, pointer, dimension(:,:) :: lprec =>NULL() !< mass flux of liquid precip [kg/m2/s] - real, pointer, dimension(:,:) :: fprec =>NULL() !< mass flux of frozen precip [kg/m2/s] - real, pointer, dimension(:,:) :: ustar_berg =>NULL() !< frictional velocity beneath icebergs [m/s] - real, pointer, dimension(:,:) :: area_berg =>NULL() !< area covered by icebergs[m2/m2] - real, pointer, dimension(:,:) :: mass_berg =>NULL() !< mass of icebergs(kg/m2) - real, pointer, dimension(:,:) :: lrunoff_hflx =>NULL() !< heat content of liquid runoff [W/m2] - real, pointer, dimension(:,:) :: frunoff_hflx =>NULL() !< heat content of frozen runoff [W/m2] + real, pointer, dimension(:,:) :: t_flux =>NULL() !< sensible heat flux [W m-2] + real, pointer, dimension(:,:) :: q_flux =>NULL() !< specific humidity flux [km m-2 s-1] + real, pointer, dimension(:,:) :: salt_flux =>NULL() !< salt flux [km m-2 s-1] + real, pointer, dimension(:,:) :: seaice_melt_heat =>NULL() !< sea ice and snow melt heat flux [W m-2] + real, pointer, dimension(:,:) :: seaice_melt =>NULL() !< water flux due to sea ice and snow melting [km m-2 s-1] + real, pointer, dimension(:,:) :: lw_flux =>NULL() !< long wave radiation [W m-2] + real, pointer, dimension(:,:) :: sw_flux_vis_dir =>NULL() !< direct visible sw radiation [W m-2] + real, pointer, dimension(:,:) :: sw_flux_vis_dif =>NULL() !< diffuse visible sw radiation [W m-2] + real, pointer, dimension(:,:) :: sw_flux_nir_dir =>NULL() !< direct Near InfraRed sw radiation [W m-2] + real, pointer, dimension(:,:) :: sw_flux_nir_dif =>NULL() !< diffuse Near InfraRed sw radiation [W m-2] + real, pointer, dimension(:,:) :: lprec =>NULL() !< mass flux of liquid precip [km m-2 s-1] + real, pointer, dimension(:,:) :: fprec =>NULL() !< mass flux of frozen precip [km m-2 s-1] + real, pointer, dimension(:,:) :: ustar_berg =>NULL() !< frictional velocity beneath icebergs [m s-1] + real, pointer, dimension(:,:) :: area_berg =>NULL() !< area covered by icebergs[m2 m-2] + real, pointer, dimension(:,:) :: mass_berg =>NULL() !< mass of icebergs(kg m-2) + real, pointer, dimension(:,:) :: hrofl =>NULL() !< heat content from liquid runoff [W m-2] + real, pointer, dimension(:,:) :: hrofi =>NULL() !< heat content from frozen runoff [W m-2] + real, pointer, dimension(:,:) :: hrofl_glc =>NULL() !< heat content from liquid glc runoff [W m-2] + real, pointer, dimension(:,:) :: hrofi_glc =>NULL() !< heat content from frozen glc runoff [W m-2] + real, pointer, dimension(:,:) :: hrain =>NULL() !< heat content from liquid precipitation [W m-2] + real, pointer, dimension(:,:) :: hsnow =>NULL() !< heat content from frozen precipitation [W m-2] + real, pointer, dimension(:,:) :: hevap =>NULL() !< heat content from evaporation [W m-2] + real, pointer, dimension(:,:) :: hcond =>NULL() !< heat content from condensation [W m-2] real, pointer, dimension(:,:) :: p =>NULL() !< pressure of overlying ice and atmosphere !< on ocean surface [Pa] - real, pointer, dimension(:,:) :: ice_fraction =>NULL() !< fractional ice area [nondim] - real, pointer, dimension(:,:) :: u10_sqr =>NULL() !< wind speed squared at 10m [m2/s2] - real, pointer, dimension(:,:) :: mi =>NULL() !< mass of ice [kg/m2] + real, pointer, dimension(:,:) :: ice_fraction =>NULL() !< fractional ice area [1] + real, pointer, dimension(:,:) :: u10_sqr =>NULL() !< wind speed squared at 10m [m2 s-2] + real, pointer, dimension(:,:) :: nhx_dep =>NULL() !< Nitrogen deposition [kg m-2 s-1] + real, pointer, dimension(:,:) :: noy_dep =>NULL() !< Nitrogen deposition [kg m-2 s-1] + real, pointer, dimension(:,:) :: atm_co2_prog =>NULL() !< Prognostic atmospheric co2 concentration [ppm] + real, pointer, dimension(:,:) :: atm_co2_diag =>NULL() !< Diagnostic atmospheric co2 concentration [ppm] + real, pointer, dimension(:,:) :: atm_fine_dust_flux =>NULL() !< Fine dust flux from atmosphere [kg m-2 s-1] + real, pointer, dimension(:,:) :: atm_coarse_dust_flux =>NULL() !< Coarse dust flux from atmosphere [kg m-2 s-1] + real, pointer, dimension(:,:) :: seaice_dust_flux =>NULL() !< Dust flux from seaice [kg m-2 s-1] + real, pointer, dimension(:,:) :: atm_bc_flux =>NULL() !< Black carbon flux from atmosphere [kg m-2 s-1] + real, pointer, dimension(:,:) :: seaice_bc_flux =>NULL() !< Black carbon flux from seaice [kg m-2 s-1] + real, pointer, dimension(:,:) :: afracr =>NULL() !< Fractional atmosphere coverage wrt ocean [1] + real, pointer, dimension(:,:) :: swnet_afracr =>NULL() !< Net shortwave radiation times atmosphere fraction + !! positive => into the ocean [W m-2] + real, pointer, dimension(:,:,:) :: swpen_ifrac_n =>NULL() !< Net shortwave radiation penetrating into ice and + !! ocean times ice fraction for thickness + !! positive => into the ocean [W m-2] + real, pointer, dimension(:,:,:) :: ifrac_n =>NULL() !< Ice fraction per category [1] + real, pointer, dimension(:,:) :: mi =>NULL() !< mass of ice [km m-2] real, pointer, dimension(:,:) :: ice_rigidity =>NULL() !< rigidity of the sea ice, sea-ice and !! ice-shelves, expressed as a coefficient !! for divergence damping, as determined - !! outside of the ocean model in [m3/s] - real, pointer, dimension(:,:) :: lamult => NULL() !< Langmuir enhancement factor [nondim] - real, pointer, dimension(:,:) :: ustk0 => NULL() !< Surface Stokes drift, zonal [m/s] - real, pointer, dimension(:,:) :: vstk0 => NULL() !< Surface Stokes drift, meridional [m/s] + !! outside of the ocean model in [m3 s-1] + real, pointer, dimension(:,:) :: lamult => NULL() !< Langmuir enhancement factor [1] real, pointer, dimension(:) :: stk_wavenumbers => NULL() !< The central wave number of Stokes bands [rad/m] - real, pointer, dimension(:,:,:) :: ustkb => NULL() !< Stokes Drift spectrum, zonal [m/s] + real, pointer, dimension(:,:,:) :: ustkb => NULL() !< Stokes Drift spectrum, zonal [m s-1] !! Horizontal - u points !! 3rd dimension - wavenumber - real, pointer, dimension(:,:,:) :: vstkb => NULL() !< Stokes Drift spectrum, meridional [m/s] + real, pointer, dimension(:,:,:) :: vstkb => NULL() !< Stokes Drift spectrum, meridional [m s-1] !! Horizontal - v points !! 3rd dimension - wavenumber integer :: num_stk_bands !< Number of Stokes drift bands passed through the coupler @@ -211,6 +235,10 @@ module MOM_surface_forcing_nuopc !! flux-exchange code, based on what the sea-ice !! model is providing. Otherwise, the value from !! the surface_forcing_CS is used. + + ! Forcing when receiving multiple ice categories from CMEPS + integer :: ice_ncat !< Number of ice categories coming from coupler + !! (1 => not using separate categories) end type ice_ocean_boundary_type integer :: id_clock_forcing @@ -232,7 +260,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, type(time_type), intent(in) :: Time !< The time of the fluxes, used for interpolating the !! salinity to the right time, when it is being restored. real, intent(in) :: valid_time !< The amount of time over which these fluxes - !! should be applied [s]. + !! should be applied [T ~> s]. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a @@ -244,19 +272,13 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! local variables real, dimension(SZI_(G),SZJ_(G)) :: & - cfc11_atm, & !< CFC11 concentration in the atmopshere [???????] - cfc12_atm, & !< CFC11 concentration in the atmopshere [???????] - data_restore, & !< The surface value toward which to restore [g/kg or degC] - SST_anom, & !< Instantaneous sea surface temperature anomalies from a target value [deg C] - SSS_anom, & !< Instantaneous sea surface salinity anomalies from a target value [g/kg] - SSS_mean, & !< A (mean?) salinity about which to normalize local salinity - !! anomalies when calculating restorative precipitation anomalies [g/kg] + data_restore, & !< The surface value toward which to restore [S ~> ppt] or [C ~> degC] PmE_adj, & !< The adjustment to PminusE that will cause the salinity !! to be restored toward its target value [kg/(m^2 * s)] - net_FW, & !< The area integrated net freshwater flux into the ocean [kg/s] - net_FW2, & !< The area integrated net freshwater flux into the ocean [kg/s] + net_FW, & !< The area integrated net freshwater flux into the ocean [R Z L2 T-1 ~> kg s-1] + net_FW2, & !< The area averaged net freshwater flux into the ocean [R Z T-1 ~> kg m-2 s-1] work_sum, & !< A 2-d array that is used as the work space for a global - !! sum, used with units of m2 or [kg/s] + !! sum, used with units of [L2 ~> m2] or [R Z L2 T-1 ~> kg s-1] open_ocn_mask !< a binary field indicating where ice is present based on frazil criteria integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 @@ -267,8 +289,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, !! is present, or false (no restoring) otherwise. logical :: restore_sst !< local copy of the argument restore_temp, if it !! is present, or false (no restoring) otherwise. - real :: delta_sss !< temporary storage for sss diff from restoring value - real :: delta_sst !< temporary storage for sst diff from restoring value + real :: delta_sss !< temporary storage for sss diff from restoring value [S ~> ppt] + real :: delta_sst !< temporary storage for sst diff from restoring value [C ~> degC] real :: kg_m2_s_conversion !< A combination of unit conversion factors for rescaling !! mass fluxes [R Z s m2 kg-1 T-1 ~> 1]. @@ -286,7 +308,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 kg_m2_s_conversion = US%kg_m2s_to_RZ_T - C_p = US%Q_to_J_kg*fluxes%C_p + C_p = US%Q_to_J_kg*US%degC_to_C*fluxes%C_p open_ocn_mask(:,:) = 1.0 pme_adj(:,:) = 0.0 fluxes%vPrecGlobalAdj = 0.0 @@ -305,9 +327,10 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! flux type has been used. if (fluxes%dt_buoy_accum < 0) then call allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.true., & - press=.true., fix_accum_bug=CS%fix_ustar_gustless_bug, & - cfc=CS%use_CFC) - + press=.true., fix_accum_bug=.not.CS%ustar_gustless_bug, & + cfc=CS%use_CFC, marbl=CS%use_marbl_tracers, hevap=CS%enthalpy_cpl, & + tau_mag=.true., ice_ncat=IOB%ice_ncat) + call safe_alloc_ptr(fluxes%omega_w2x,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_nir_dir,isd,ied,jsd,jed) @@ -316,16 +339,16 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call safe_alloc_ptr(fluxes%p_surf ,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%p_surf_full,isd,ied,jsd,jed) if (CS%use_limited_P_SSH) then - fluxes%p_surf_SSH => fluxes%p_surf + fluxes%p_surf_SSH => fluxes%p_surf else - fluxes%p_surf_SSH => fluxes%p_surf_full + fluxes%p_surf_SSH => fluxes%p_surf_full endif call safe_alloc_ptr(fluxes%salt_flux,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%salt_flux_in,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%TKE_tidal,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%BBL_tidal_dis,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%ustar_tidal,isd,ied,jsd,jed) if (CS%allow_flux_adjustments) then @@ -334,7 +357,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, endif do j=js-2,je+2 ; do i=is-2,ie+2 - fluxes%TKE_tidal(i,j) = CS%TKE_tidal(i,j) + fluxes%BBL_tidal_dis(i,j) = US%Z_to_L**2*CS%TKE_tidal(i,j) fluxes%ustar_tidal(i,j) = CS%ustar_tidal(i,j) enddo ; enddo @@ -358,15 +381,15 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! allocation and initialization on first call to this routine if (CS%area_surf < 0.0) then do j=js,je ; do i=is,ie - work_sum(i,j) = US%L_to_m**2*G%areaT(i,j) * G%mask2dT(i,j) + work_sum(i,j) = G%areaT(i,j) * G%mask2dT(i,j) enddo ; enddo - CS%area_surf = reproducing_sum(work_sum, isr, ier, jsr, jer) + CS%area_surf = reproducing_sum(work_sum, isr, ier, jsr, jer, unscale=US%L_to_m**2) endif ! endif for allocation and initialization ! Indicate that there are new unused fluxes. fluxes%fluxes_used = .false. - fluxes%dt_buoy_accum = US%s_to_T*valid_time + fluxes%dt_buoy_accum = valid_time if (CS%allow_flux_adjustments) then fluxes%heat_added(:,:)=0.0 @@ -380,19 +403,19 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! Salinity restoring logic if (restore_salinity) then - call time_interp_external(CS%id_srestore,Time,data_restore) + call time_interp_external(CS%srestore_handle, Time, data_restore, scale=US%ppt_to_S) ! open_ocn_mask indicates where to restore salinity (1 means restore, 0 does not) open_ocn_mask(:,:) = 1.0 if (CS%mask_srestore_under_ice) then ! Do not restore under sea-ice do j=js,je ; do i=is,ie - if (sfc_state%SST(i,j) <= -0.0539*sfc_state%SSS(i,j)) open_ocn_mask(i,j)=0.0 + if (sfc_state%SST(i,j) <= -0.0539*US%degC_to_C*US%S_to_ppt*sfc_state%SSS(i,j)) open_ocn_mask(i,j)=0.0 enddo ; enddo endif if (CS%salt_restore_as_sflux) then do j=js,je ; do i=is,ie - delta_sss = data_restore(i,j)- sfc_state%SSS(i,j) + delta_sss = data_restore(i,j) - sfc_state%SSS(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) - fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)* & + fluxes%salt_flux(i,j) = 1.e-3*US%S_to_ppt*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)* & (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) *delta_sss ! kg Salt m-2 s-1 enddo ; enddo if (CS%adjust_net_srestore_to_zero) then @@ -401,16 +424,16 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, unit_scale=US%RZ_T_to_kg_m2s) fluxes%saltFluxGlobalAdj = 0. else - work_sum(is:ie,js:je) = US%L_to_m**2*US%RZ_T_to_kg_m2s * & - G%areaT(is:ie,js:je)*fluxes%salt_flux(is:ie,js:je) - fluxes%saltFluxGlobalAdj = reproducing_sum(work_sum(:,:), isr,ier, jsr,jer)/CS%area_surf - fluxes%salt_flux(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) - kg_m2_s_conversion * fluxes%saltFluxGlobalAdj + work_sum(is:ie,js:je) = G%areaT(is:ie,js:je) * fluxes%salt_flux(is:ie,js:je) + fluxes%saltFluxGlobalAdj = reproducing_sum(work_sum(:,:), isr,ier, jsr,jer, unscale=US%RZL2_to_kg*US%s_to_T) & + / CS%area_surf + fluxes%salt_flux(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) - fluxes%saltFluxGlobalAdj endif endif fluxes%salt_flux_added(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) ! Diagnostic else do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & @@ -424,11 +447,11 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, unit_scale=US%RZ_T_to_kg_m2s) fluxes%vPrecGlobalAdj = 0. else - work_sum(is:ie,js:je) = US%L_to_m**2*G%areaT(is:ie,js:je) * & - US%RZ_T_to_kg_m2s*fluxes%vprec(is:ie,js:je) - fluxes%vPrecGlobalAdj = reproducing_sum(work_sum(:,:), isr, ier, jsr, jer) / CS%area_surf + work_sum(is:ie,js:je) = G%areaT(is:ie,js:je) * fluxes%vprec(is:ie,js:je) + fluxes%vPrecGlobalAdj = reproducing_sum(work_sum(:,:), isr, ier, jsr, jer, unscale=US%RZL2_to_kg*US%s_to_T) & + / CS%area_surf do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - kg_m2_s_conversion * fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) + fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) enddo ; enddo endif endif @@ -437,9 +460,9 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! SST restoring logic if (restore_sst) then - call time_interp_external(CS%id_trestore,Time,data_restore) + call time_interp_external(CS%trestore_handle, Time, data_restore, scale=US%degC_to_C) do j=js,je ; do i=is,ie - delta_sst = data_restore(i,j)- sfc_state%SST(i,j) + delta_sst = data_restore(i,j) - sfc_state%SST(i,j) delta_sst = sign(1.0,delta_sst)*min(abs(delta_sst),CS%max_delta_trestore) fluxes%heat_added(i,j) = G%mask2dT(i,j) * CS%trestore_mask(i,j) * & (CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! Q R Z T-1 ~> W m-2 @@ -454,7 +477,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, return endif if (associated(IOB%lrunoff)) then - if(CS%liquid_runoff_from_data)call data_override('OCN', 'runoff', IOB%lrunoff, Time) + if (CS%liquid_runoff_from_data) call data_override('OCN', 'runoff', IOB%lrunoff, Time) endif ! obtain fluxes from IOB; note the staggering of indices @@ -480,6 +503,16 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%frunoff(i,j) = kg_m2_s_conversion * IOB%frunoff(i-i0,j-j0) * G%mask2dT(i,j) endif + ! add liquid glc runoff flux via rof + if (associated(IOB%lrunoff_glc)) then + fluxes%lrunoff_glc(i,j) = kg_m2_s_conversion * IOB%lrunoff_glc(i-i0,j-j0) * G%mask2dT(i,j) + endif + + ! ice glc runoff flux via rof + if (associated(IOB%frunoff_glc)) then + fluxes%frunoff_glc(i,j) = kg_m2_s_conversion * IOB%frunoff_glc(i-i0,j-j0) * G%mask2dT(i,j) + endif + if (associated(IOB%ustar_berg)) & fluxes%ustar_berg(i,j) = US%m_to_Z*US%T_to_s * IOB%ustar_berg(i-i0,j-j0) * G%mask2dT(i,j) @@ -489,45 +522,45 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, if (associated(IOB%mass_berg)) & fluxes%mass_berg(i,j) = US%m_to_Z*US%kg_m3_to_R * IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) - if (associated(IOB%lrunoff_hflx)) & - fluxes%heat_content_lrunoff(i,j) = US%W_m2_to_QRZ_T * IOB%lrunoff_hflx(i-i0,j-j0) * G%mask2dT(i,j) - - if (associated(IOB%frunoff_hflx)) & - fluxes%heat_content_frunoff(i,j) = US%W_m2_to_QRZ_T * kg_m2_s_conversion * & - IOB%frunoff_hflx(i-i0,j-j0) * G%mask2dT(i,j) - if (associated(IOB%lw_flux)) & fluxes%lw(i,j) = US%W_m2_to_QRZ_T * IOB%lw_flux(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%t_flux)) & fluxes%sens(i,j) = US%W_m2_to_QRZ_T * IOB%t_flux(i-i0,j-j0) * G%mask2dT(i,j) - ! sea ice and snow melt heat flux [Q R Z T-1 ~> W/m2] + ! sea ice and snow melt heat flux [Q R Z T-1 ~> W m-2] if (associated(IOB%seaice_melt_heat)) & - fluxes%seaice_melt_heat(i,j) = US%W_m2_to_QRZ_T * G%mask2dT(i,j) * IOB%seaice_melt_heat(i-i0,j-j0) + fluxes%seaice_melt_heat(i,j) = US%W_m2_to_QRZ_T * G%mask2dT(i,j) * IOB%seaice_melt_heat(i-i0,j-j0) - ! water flux due to sea ice and snow melt [kg/m2/s] + ! water flux due to sea ice and snow melt [km m-2 s-1] if (associated(IOB%seaice_melt)) & - fluxes%seaice_melt(i,j) = kg_m2_s_conversion * G%mask2dT(i,j) * IOB%seaice_melt(i-i0,j-j0) + fluxes%seaice_melt(i,j) = kg_m2_s_conversion * G%mask2dT(i,j) * IOB%seaice_melt(i-i0,j-j0) fluxes%latent(i,j) = 0.0 ! notice minus sign since fprec is positive into the ocean if (associated(IOB%fprec)) then - fluxes%latent(i,j) = fluxes%latent(i,j) - & - IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion - fluxes%latent_fprec_diag(i,j) = - G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion + fluxes%latent(i,j) = fluxes%latent(i,j) - & + IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion + fluxes%latent_fprec_diag(i,j) = - G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion endif ! notice minus sign since frunoff is positive into the ocean if (associated(IOB%frunoff)) then - fluxes%latent(i,j) = fluxes%latent(i,j) - & - IOB%frunoff(i-i0,j-j0) * US%W_m2_to_QRZ_T * CS%latent_heat_fusion - fluxes%latent_frunoff_diag(i,j) = - G%mask2dT(i,j) * & - IOB%frunoff(i-i0,j-j0) * US%W_m2_to_QRZ_T * CS%latent_heat_fusion + fluxes%latent(i,j) = fluxes%latent(i,j) - & + IOB%frunoff(i-i0,j-j0) * US%W_m2_to_QRZ_T * CS%latent_heat_fusion + fluxes%latent_frunoff_diag(i,j) = - G%mask2dT(i,j) * & + IOB%frunoff(i-i0,j-j0) * US%W_m2_to_QRZ_T * CS%latent_heat_fusion + endif + ! notice minus sign since frunoff_glc is positive into the ocean + if (associated(IOB%frunoff_glc)) then + fluxes%latent(i,j) = fluxes%latent(i,j) - & + IOB%frunoff_glc(i-i0,j-j0) * US%W_m2_to_QRZ_T * CS%latent_heat_fusion + fluxes%latent_frunoff_glc_diag(i,j) = fluxes%latent_frunoff_glc_diag(i,j) - G%mask2dT(i,j) * & + IOB%frunoff_glc(i-i0,j-j0) * US%W_m2_to_QRZ_T * CS%latent_heat_fusion endif if (associated(IOB%q_flux)) then - fluxes%latent(i,j) = fluxes%latent(i,j) + & - IOB%q_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_vapor - fluxes%latent_evap_diag(i,j) = G%mask2dT(i,j) * IOB%q_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_vapor + fluxes%latent(i,j) = fluxes%latent(i,j) + & + IOB%q_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_vapor + fluxes%latent_evap_diag(i,j) = G%mask2dT(i,j) * IOB%q_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_vapor endif fluxes%latent(i,j) = G%mask2dT(i,j) * fluxes%latent(i,j) @@ -546,18 +579,54 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%sw(i,j) = fluxes%sw_vis_dir(i,j) + fluxes%sw_vis_dif(i,j) + & fluxes%sw_nir_dir(i,j) + fluxes%sw_nir_dif(i,j) - ! sea ice fraction [nondim] + ! enthalpy terms + if (CS%enthalpy_cpl) then + if (associated(IOB%hrofl)) & + fluxes%heat_content_lrunoff(i,j) = US%W_m2_to_QRZ_T * IOB%hrofl(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%hrofi)) & + fluxes%heat_content_frunoff(i,j) = US%W_m2_to_QRZ_T * IOB%hrofi(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%hrain)) & + fluxes%heat_content_lprec(i,j) = US%W_m2_to_QRZ_T * IOB%hrain(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%hsnow)) & + fluxes%heat_content_fprec(i,j) = US%W_m2_to_QRZ_T * IOB%hsnow(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%hevap)) & + fluxes%heat_content_evap(i,j) = US%W_m2_to_QRZ_T * IOB%hevap(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%hcond)) & + fluxes%heat_content_cond(i,j) = US%W_m2_to_QRZ_T * IOB%hcond(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%hrofl_glc)) & + fluxes%heat_content_lrunoff_glc(i,j) = US%W_m2_to_QRZ_T * IOB%hrofl_glc(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%hrofi_glc)) & + fluxes%heat_content_frunoff_glc(i,j) = US%W_m2_to_QRZ_T * IOB%hrofi_glc(i-i0,j-j0) * G%mask2dT(i,j) + endif + + ! sea ice fraction [1] if (associated(IOB%ice_fraction) .and. associated(fluxes%ice_fraction)) & - fluxes%ice_fraction(i,j) = G%mask2dT(i,j) * IOB%ice_fraction(i-i0,j-j0) - ! 10-m wind speed squared [m2/s2] + fluxes%ice_fraction(i,j) = G%mask2dT(i,j) * IOB%ice_fraction(i-i0,j-j0) + ! 10-m wind speed squared [m2 s-2] if (associated(IOB%u10_sqr) .and. associated(fluxes%u10_sqr)) & - fluxes%u10_sqr(i,j) = US%m_to_L**2 * US%T_to_s**2 * G%mask2dT(i,j) * IOB%u10_sqr(i-i0,j-j0) + fluxes%u10_sqr(i,j) = US%m_to_L**2 * US%T_to_s**2 * G%mask2dT(i,j) * IOB%u10_sqr(i-i0,j-j0) enddo ; enddo + ! Copy MARBL-specific IOB fields into fluxes; also set some MARBL-specific forcings to other values + ! (constants, values from netCDF, etc) + if (CS%use_marbl_tracers) & + call convert_driver_fields_to_forcings(IOB%atm_fine_dust_flux, IOB%atm_coarse_dust_flux, & + IOB%seaice_dust_flux, IOB%atm_bc_flux, IOB%seaice_bc_flux, & + IOB%nhx_dep, IOB%noy_dep, IOB%atm_co2_prog, IOB%atm_co2_diag, & + IOB%afracr, IOB%swnet_afracr, IOB%ifrac_n, IOB%swpen_ifrac_n, & + Time, G, US, i0, j0, fluxes, CS%marbl_forcing_CSp) + ! wave to ocean coupling if ( associated(IOB%lamult)) then - do j=js,je; do i=is,ie + do j=js,je ; do i=is,ie if (IOB%ice_fraction(i-i0,j-j0) <= 0.05 ) then fluxes%lamult(i,j) = IOB%lamult(i-i0,j-j0) else @@ -569,23 +638,18 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! applied surface pressure from atmosphere and cryosphere if (associated(IOB%p)) then - if (CS%max_p_surf >= 0.0) then - do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) - fluxes%p_surf(i,j) = MIN(fluxes%p_surf_full(i,j),CS%max_p_surf) - enddo; enddo - else - do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) - fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) - enddo; enddo - endif - fluxes%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. - endif - - ! CFCs - if (CS%use_CFC) then - call CFC_cap_fluxes(fluxes, sfc_state, G, US, CS%Rho0, Time, CS%id_cfc11_atm, CS%id_cfc11_atm) + if (CS%max_p_surf >= 0.0) then + do j=js,je ; do i=is,ie + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + fluxes%p_surf(i,j) = MIN(fluxes%p_surf_full(i,j),CS%max_p_surf) + enddo ; enddo + else + do j=js,je ; do i=is,ie + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) + enddo ; enddo + endif + fluxes%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. endif if (associated(IOB%salt_flux)) then @@ -600,23 +664,23 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, sign_for_net_FW_bug = 1. if (CS%use_net_FW_adjustment_sign_bug) sign_for_net_FW_bug = -1. do j=js,je ; do i=is,ie - net_FW(i,j) = US%RZ_T_to_kg_m2s * & - (((fluxes%lprec(i,j) + fluxes%fprec(i,j) + fluxes%seaice_melt(i,j)) + & - (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j))) + & - (fluxes%evap(i,j) + fluxes%vprec(i,j)) ) * US%L_to_m**2*G%areaT(i,j) - net_FW2(i,j) = net_FW(i,j) / (US%L_to_m**2*G%areaT(i,j)) + net_FW(i,j) = ((((fluxes%lprec(i,j) + fluxes%fprec(i,j)) + fluxes%seaice_melt(i,j)) + & + ((fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) + (fluxes%lrunoff_glc(i,j) + & + fluxes%frunoff_glc(i,j)))) + (fluxes%evap(i,j) + fluxes%vprec(i,j)) ) * & + G%areaT(i,j) + net_FW2(i,j) = net_FW(i,j) / G%areaT(i,j) enddo ; enddo if (CS%adjust_net_fresh_water_by_scaling) then - call adjust_area_mean_to_zero(net_FW2, G, fluxes%netFWGlobalScl) + call adjust_area_mean_to_zero(net_FW2, G, fluxes%netFWGlobalScl, unscale=US%RZ_T_to_kg_m2s) do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = fluxes%vprec(i,j) + US%kg_m2s_to_RZ_T * & - (net_FW2(i,j) - net_FW(i,j)/(US%L_to_m**2*G%areaT(i,j))) * G%mask2dT(i,j) + fluxes%vprec(i,j) = fluxes%vprec(i,j) + (net_FW2(i,j) - net_FW(i,j) / G%areaT(i,j)) * G%mask2dT(i,j) enddo ; enddo else - fluxes%netFWGlobalAdj = reproducing_sum(net_FW(:,:), isr, ier, jsr, jer) / CS%area_surf + fluxes%netFWGlobalAdj = reproducing_sum(net_FW(:,:), isr, ier, jsr, jer, unscale=US%RZL2_to_kg*US%s_to_T) / & + CS%area_surf do j=js,je ; do i=is,ie - fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - kg_m2_s_conversion * fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) + fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) enddo ; enddo endif @@ -656,13 +720,13 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) ! local variables real, dimension(SZIB_(G),SZJB_(G)) :: & - taux_at_q, & !< Zonal wind stresses at q points [Pa] - tauy_at_q !< Meridional wind stresses at q points [Pa] + taux_at_q, & !< Zonal wind stresses at q points [R Z L T-2 ~> Pa] + tauy_at_q !< Meridional wind stresses at q points [R Z L T-2 ~> Pa] real, dimension(SZI_(G),SZJ_(G)) :: & rigidity_at_h, & !< Ice rigidity at tracer points [L4 Z-1 T-1 ~> m3 s-1] - taux_at_h, & !< Zonal wind stresses at h points [Pa] - tauy_at_h !< Meridional wind stresses at h points [Pa] + taux_at_h, & !< Zonal wind stresses at h points [R Z L T-2 ~> Pa] + tauy_at_h !< Meridional wind stresses at h points [R Z L T-2 ~> Pa] real :: gustiness !< unresolved gustiness that contributes to ustar [R Z L T-2 ~> Pa] real :: Irho0 !< inverse of the mean density in [Z L-1 R-1 ~> m3 kg-1] @@ -699,10 +763,11 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) ! mechanical forcing type has been used. if (.not.forces%initialized) then - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true., tau_mag=.true.) call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) + call safe_alloc_ptr(forces%omega_w2x,isd,ied,jsd,jed) if (CS%rigid_sea_ice) then call safe_alloc_ptr(forces%rigidity_ice_u,IsdB,IedB,jsd,jed) @@ -734,9 +799,9 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) ! applied surface pressure from atmosphere and cryosphere if (CS%use_limited_P_SSH) then - forces%p_surf_SSH => forces%p_surf + forces%p_surf_SSH => forces%p_surf else - forces%p_surf_SSH => forces%p_surf_full + forces%p_surf_SSH => forces%p_surf_full endif if (associated(IOB%p)) then if (CS%max_p_surf >= 0.0) then @@ -758,7 +823,6 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) endif forces%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. - ! TODO: this does not seem correct for NEMS #ifdef CESMCOUPLED wind_stagger = AGRID #else @@ -806,7 +870,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0.0) & forces%taux(I,j) = (G%mask2dBu(I,J)*taux_at_q(I,J) + & G%mask2dBu(I,J-1)*taux_at_q(I,J-1)) / & (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) @@ -814,7 +878,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0.0) & forces%tauy(i,J) = (G%mask2dBu(I,J)*tauy_at_q(I,J) + & G%mask2dBu(I-1,J)*tauy_at_q(I-1,J)) / & (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) @@ -827,14 +891,15 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie tau_mag = 0.0 ; gustiness = CS%gust_const if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & - (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0) then - tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_at_q(I,J)**2 + tauy_at_q(I,J)**2) + & - G%mask2dBu(I-1,J-1)*(taux_at_q(I-1,J-1)**2 + tauy_at_q(I-1,J-1)**2)) + & - (G%mask2dBu(I,J-1)*(taux_at_q(I,J-1)**2 + tauy_at_q(I,J-1)**2) + & - G%mask2dBu(I-1,J)*(taux_at_q(I-1,J)**2 + tauy_at_q(I-1,J)**2)) ) / & + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0.0) then + tau_mag = sqrt(((G%mask2dBu(I,J)*((taux_at_q(I,J)**2) + (tauy_at_q(I,J)**2)) + & + G%mask2dBu(I-1,J-1)*((taux_at_q(I-1,J-1)**2) + (tauy_at_q(I-1,J-1)**2))) + & + (G%mask2dBu(I,J-1)*((taux_at_q(I,J-1)**2) + (tauy_at_q(I,J-1)**2)) + & + G%mask2dBu(I-1,J)*((taux_at_q(I-1,J)**2) + (tauy_at_q(I-1,J)**2))) ) / & ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) ) if (CS%read_gust_2d) gustiness = CS%gust(i,j) endif + forces%tau_mag(i,j) = US%L_to_Z*(gustiness + tau_mag) forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0*tau_mag) enddo ; enddo call pass_vector(forces%taux, forces%tauy, G%Domain, halo=1) @@ -843,7 +908,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0.0) & forces%taux(I,j) = (G%mask2dT(i,j)*taux_at_h(i,j) + & G%mask2dT(i+1,j)*taux_at_h(i+1,j)) / & (G%mask2dT(i,j) + G%mask2dT(i+1,j)) @@ -851,7 +916,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0.0) & forces%tauy(i,J) = (G%mask2dT(i,j)*tauy_at_h(i,j) + & G%mask2dT(i,J+1)*tauy_at_h(i,j+1)) / & (G%mask2dT(i,j) + G%mask2dT(i,j+1)) @@ -859,9 +924,11 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie gustiness = CS%gust_const - if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) + if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0.0)) gustiness = CS%gust(i,j) + forces%tau_mag(i,j) = US%L_to_Z*(gustiness + G%mask2dT(i,j) * sqrt((taux_at_h(i,j)**2) + (tauy_at_h(i,j)**2))) forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & - sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2)) + sqrt((taux_at_h(i,j)**2) + (tauy_at_h(i,j)**2))) + forces%omega_w2x(i,j) = atan2(tauy_at_h(i,j), taux_at_h(i,j)) enddo ; enddo call pass_vector(forces%taux, forces%tauy, G%Domain, halo=1) else ! C-grid wind stresses. @@ -871,18 +938,20 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie taux2 = 0.0 - if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0) & - taux2 = (G%mask2dCu(I-1,j)*forces%taux(I-1,j)**2 + & - G%mask2dCu(I,j)*forces%taux(I,j)**2) / (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) + if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0.0) & + taux2 = (G%mask2dCu(I-1,j)*(forces%taux(I-1,j)**2) + & + G%mask2dCu(I,j)*(forces%taux(I,j)**2)) / (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) tauy2 = 0.0 - if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & - tauy2 = (G%mask2dCv(i,J-1)*forces%tauy(i,J-1)**2 + & - G%mask2dCv(i,J)*forces%tauy(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) + if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0.0) & + tauy2 = (G%mask2dCv(i,J-1)*(forces%tauy(i,J-1)**2) + & + G%mask2dCv(i,J)*(forces%tauy(i,J)**2)) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) if (CS%read_gust_2d) then + forces%tau_mag(i,j) = US%L_to_Z*(CS%gust(i,j) + sqrt(taux2 + tauy2)) forces%ustar(i,j) = sqrt(CS%gust(i,j)*Irho0 + Irho0*sqrt(taux2 + tauy2)) else + forces%tau_mag(i,j) = US%L_to_Z*(CS%gust_const + sqrt(taux2 + tauy2)) forces%ustar(i,j) = sqrt(CS%gust_const*Irho0 + Irho0*sqrt(taux2 + tauy2)) endif enddo ; enddo @@ -892,18 +961,14 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) ! wave to ocean coupling if ( associated(IOB%ustkb) ) then - forces%stk_wavenumbers(:) = IOB%stk_wavenumbers - do j=js,je; do i=is,ie - forces%ustk0(i,j) = IOB%ustk0(i-I0,j-J0) ! How to be careful here that the domains are right? - forces%vstk0(i,j) = IOB%vstk0(i-I0,j-J0) - enddo ; enddo - call pass_vector(forces%ustk0,forces%vstk0, G%domain ) + forces%stk_wavenumbers(:) = IOB%stk_wavenumbers * US%Z_to_m do istk = 1,IOB%num_stk_bands - do j=js,je; do i=is,ie - forces%ustkb(i,j,istk) = IOB%ustkb(i-I0,j-J0,istk) - forces%vstkb(i,j,istk) = IOB%vstkb(i-I0,j-J0,istk) - enddo; enddo - call pass_vector(forces%ustkb(:,:,istk),forces%vstkb(:,:,istk), G%domain ) + do j=js,je ; do i=is,ie + forces%ustkb(i,j,istk) = IOB%ustkb(i-I0,j-J0,istk) * US%m_s_to_L_T + forces%vstkb(i,j,istk) = IOB%vstkb(i-I0,j-J0,istk) * US%m_s_to_L_T + enddo ; enddo + call pass_var(forces%ustkb(:,:,istk), G%domain ) + call pass_var(forces%vstkb(:,:,istk), G%domain ) enddo endif @@ -972,7 +1037,7 @@ subroutine apply_flux_adjustments(G, US, CS, Time, fluxes) integer :: isc, iec, jsc, jec, i, j logical :: overrode_h - isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec overrode_h = .false. call data_override('OCN', 'hflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) @@ -1021,7 +1086,7 @@ subroutine apply_force_adjustments(G, US, CS, Time, forces) real :: Pa_conversion ! A unit conversion factor from Pa to the internal units [R Z L T-2 Pa-1 ~> 1] logical :: overrode_x, overrode_y - isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec Pa_conversion = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z tempx_at_h(:,:) = 0.0 ; tempy_at_h(:,:) = 0.0 @@ -1101,11 +1166,13 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, ! Local variables real :: utide ! The RMS tidal velocity [Z T-1 ~> m s-1]. type(directories) :: dirs - logical :: new_sim, iceberg_flux_diags + logical :: new_sim, iceberg_flux_diags, glc_runoff_diags, fix_ustar_gustless_bug + logical :: test_value ! This is used to determine whether a logical parameter is being set explicitly. + logical :: explicit_bug, explicit_fix ! These indicate which parameters are set explicitly. type(time_type) :: Time_frc character(len=200) :: TideAmp_file, gust_file, salt_file, temp_file ! Input file names. -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_surface_forcing_nuopc" ! This module's name. character(len=48) :: stagger character(len=48) :: flnam @@ -1140,7 +1207,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call get_param(param_file, mdl, "RHO_0", CS%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& + "properties, or with BOUSSINESQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & @@ -1202,11 +1269,18 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call get_param(param_file, mdl, "WIND_STRESS_MULTIPLIER", CS%wind_stress_multiplier, & "A factor multiplying the wind-stress given to the ocean by the "//& "coupler. This is used for testing and should be =1.0 for any "//& - "production runs.", default=1.0) + "production runs.", units="nondim", default=1.0) call get_param(param_file, mdl, "USE_CFC_CAP", CS%use_CFC, & default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "USE_MARBL_TRACERS", CS%use_marbl_tracers, & + default=.false., do_not_log=.true.) + + call get_param(param_file, mdl, "ENTHALPY_FROM_COUPLER", CS%enthalpy_cpl, & + "If True, the heat (enthalpy) associated with mass entering/leaving the "//& + "ocean is provided via coupler.", default=.false.) + if (restore_salt) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes to the relative "//& @@ -1224,7 +1298,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "flux instead of as a freshwater flux.", default=.false.) call get_param(param_file, mdl, "MAX_DELTA_SRESTORE", CS%max_delta_srestore, & "The maximum salinity difference used in restoring terms.", & - units="PSU or g kg-1", default=999.0) + units="PSU or g kg-1", default=999.0, scale=US%ppt_to_S) call get_param(param_file, mdl, "MASK_SRESTORE_UNDER_ICE", & CS%mask_srestore_under_ice, & "If true, disables SSS restoring under sea-ice based on a frazil "//& @@ -1266,7 +1340,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call get_param(param_file, mdl, "MAX_DELTA_TRESTORE", CS%max_delta_trestore, & "The maximum sst difference used in restoring terms.", & - units="degC ", default=999.0) + units="degC ", default=999.0, scale=US%degC_to_C) call get_param(param_file, mdl, "MASK_TRESTORE", CS%mask_trestore, & "If true, read a file (temp_restore_mask) containing "//& "a mask for SST restoring.", default=.false.) @@ -1301,13 +1375,13 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if (CS%read_TIDEAMP) then TideAmp_file = trim(CS%inputdir) // trim(TideAmp_file) call MOM_read_data(TideAmp_file,'tideamp',CS%TKE_tidal,G%domain,timelevel=1, scale=US%m_to_Z*US%T_to_s) - do j=jsd, jed; do i=isd, ied + do j=jsd,jed ; do i=isd,ied utide = CS%TKE_tidal(i,j) CS%TKE_tidal(i,j) = G%mask2dT(i,j)*CS%Rho0*CS%cd_tides*(utide*utide*utide) CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide enddo ; enddo else - do j=jsd,jed; do i=isd,ied + do j=jsd,jed ; do i=isd,ied utide = CS%utide CS%TKE_tidal(i,j) = CS%Rho0*CS%cd_tides*(utide*utide*utide) CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide @@ -1336,9 +1410,32 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call MOM_read_data(gust_file, 'gustiness', CS%gust, G%domain, timelevel=1, & scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) ! units in file should be Pa endif - call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", CS%fix_ustar_gustless_bug, & + + call get_param(param_file, mdl, "USTAR_GUSTLESS_BUG", CS%ustar_gustless_bug, & + "If true include a bug in the time-averaging of the gustless wind friction velocity", & + default=.false., do_not_log=.true.) + ! This is used to test whether USTAR_GUSTLESS_BUG is being actively set. + call get_param(param_file, mdl, "USTAR_GUSTLESS_BUG", test_value, default=.true., do_not_log=.true.) + explicit_bug = CS%ustar_gustless_bug .eqv. test_value + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", fix_ustar_gustless_bug, & "If true correct a bug in the time-averaging of the gustless wind friction velocity", & - default=.true.) + default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", test_value, default=.false., do_not_log=.true.) + explicit_fix = fix_ustar_gustless_bug .eqv. test_value + + if (explicit_bug .and. explicit_fix .and. (fix_ustar_gustless_bug .eqv. CS%ustar_gustless_bug)) then + ! USTAR_GUSTLESS_BUG is being explicitly set, and should not be changed. + call MOM_error(FATAL, "USTAR_GUSTLESS_BUG and FIX_USTAR_GUSTLESS_BUG are both being set "//& + "with inconsistent values. FIX_USTAR_GUSTLESS_BUG is an obsolete "//& + "parameter and should be removed.") + elseif (explicit_fix) then + call MOM_error(WARNING, "FIX_USTAR_GUSTLESS_BUG is an obsolete parameter. "//& + "Use USTAR_GUSTLESS_BUG instead (noting that it has the opposite sense).") + CS%ustar_gustless_bug = .not.fix_ustar_gustless_bug + endif + call log_param(param_file, mdl, "USTAR_GUSTLESS_BUG", CS%ustar_gustless_bug, & + "If true include a bug in the time-averaging of the gustless wind friction velocity", & + default=.false.) ! See whether sufficiently thick sea ice should be treated as rigid. call get_param(param_file, mdl, "USE_RIGID_SEA_ICE", CS%rigid_sea_ice, & @@ -1367,8 +1464,13 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "If true, makes available diagnostics of fluxes from icebergs "//& "as seen by MOM6.", default=.false.) + call get_param(param_file, mdl, "ALLOW_GLC_RUNOFF_DIAGNOSTICS", glc_runoff_diags, & + "If true, makes available diagnostics of separate glacier runoff fluxes"//& + "as seen by MOM6.", default=.false.) + call register_forcing_type_diags(Time, diag, US, CS%use_temperature, CS%handles, & - use_berg_fluxes=iceberg_flux_diags, use_waves=use_waves, use_cfcs=CS%use_CFC) + use_berg_fluxes=iceberg_flux_diags, use_waves=use_waves, & + use_cfcs=CS%use_CFC, use_glc_runoff=glc_runoff_diags) call get_param(param_file, mdl, "ALLOW_FLUX_ADJUSTMENTS", CS%allow_flux_adjustments, & "If true, allows flux adjustments to specified via the "//& @@ -1382,10 +1484,14 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call data_override_init(Ocean_domain_in=G%Domain%mpp_domain) endif + ! Set up MARBL forcing control structure + call MARBL_forcing_init(G, US, param_file, diag, Time, CS%inputdir, CS%use_marbl_tracers, & + CS%marbl_forcing_CSp) + if (present(restore_salt)) then ; if (restore_salt) then salt_file = trim(CS%inputdir) // trim(CS%salt_restore_file) - CS%id_srestore = init_external_field(salt_file, CS%salt_restore_var_name, domain=G%Domain%mpp_domain) - call safe_alloc_ptr(CS%srestore_mask,isd,ied,jsd,jed); CS%srestore_mask(:,:) = 1.0 + CS%srestore_handle = init_external_field(salt_file, CS%salt_restore_var_name, domain=G%Domain%mpp_domain) + call safe_alloc_ptr(CS%srestore_mask,isd,ied,jsd,jed) ; CS%srestore_mask(:,:) = 1.0 if (CS%mask_srestore) then ! read a 2-d file containing a mask for restoring fluxes flnam = trim(CS%inputdir) // 'salt_restore_mask.nc' call MOM_read_data(flnam,'mask', CS%srestore_mask, G%domain, timelevel=1) @@ -1394,37 +1500,14 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if (present(restore_temp)) then ; if (restore_temp) then temp_file = trim(CS%inputdir) // trim(CS%temp_restore_file) - CS%id_trestore = init_external_field(temp_file, CS%temp_restore_var_name, domain=G%Domain%mpp_domain) - call safe_alloc_ptr(CS%trestore_mask,isd,ied,jsd,jed); CS%trestore_mask(:,:) = 1.0 + CS%trestore_handle = init_external_field(temp_file, CS%temp_restore_var_name, domain=G%Domain%mpp_domain) + call safe_alloc_ptr(CS%trestore_mask,isd,ied,jsd,jed) ; CS%trestore_mask(:,:) = 1.0 if (CS%mask_trestore) then ! read a 2-d file containing a mask for restoring fluxes flnam = trim(CS%inputdir) // 'temp_restore_mask.nc' call MOM_read_data(flnam, 'mask', CS%trestore_mask, G%domain, timelevel=1) endif endif ; endif - ! Do not log these params here since they are logged in the CFC cap module - if (CS%use_CFC) then - call get_param(param_file, mdl, "CFC_BC_FILE", CS%CFC_BC_file, & - "The file in which the CFC-11 and CFC-12 atm concentrations can be "//& - "found (units must be parts per trillion), or an empty string for "//& - "internal BC generation (TODO).", default=" ", do_not_log=.true.) - if ((len_trim(CS%CFC_BC_file) > 0) .and. (scan(CS%CFC_BC_file,'/') == 0)) then - ! Add the directory if CFC_BC_file is not already a complete path. - CS%CFC_BC_file = trim(CS%inputdir) // trim(CS%CFC_BC_file) - endif - if (len_trim(CS%CFC_BC_file) > 0) then - call get_param(param_file, mdl, "CFC11_VARIABLE", CS%cfc11_var_name, & - "The name of the variable representing CFC-11 in "//& - "CFC_BC_FILE.", default="CFC_11", do_not_log=.true.) - call get_param(param_file, mdl, "CFC12_VARIABLE", CS%cfc12_var_name, & - "The name of the variable representing CFC-12 in "//& - "CFC_BC_FILE.", default="CFC_12", do_not_log=.true.) - - CS%id_cfc11_atm = init_external_field(CS%CFC_BC_file, CS%cfc11_var_name, domain=G%Domain%mpp_domain) - CS%id_cfc12_atm = init_external_field(CS%CFC_BC_file, CS%cfc12_var_name, domain=G%Domain%mpp_domain) - endif - endif - ! Set up any restart fields associated with the forcing. call restart_init(param_file, CS%restart_CSp, "MOM_forcing.res") call restart_init_end(CS%restart_CSp) @@ -1484,7 +1567,7 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) chks = field_chksum( iobt%v_flux ) ; if (root) write(outunit,100) 'iobt%v_flux ', chks chks = field_chksum( iobt%t_flux ) ; if (root) write(outunit,100) 'iobt%t_flux ', chks chks = field_chksum( iobt%q_flux ) ; if (root) write(outunit,100) 'iobt%q_flux ', chks - chks = field_chksum( iobt%seaice_melt_heat); if (root) write(outunit,100) 'iobt%seaice_melt_heat', chks + chks = field_chksum( iobt%seaice_melt_heat) ; if (root) write(outunit,100) 'iobt%seaice_melt_heat', chks chks = field_chksum( iobt%seaice_melt) ; if (root) write(outunit,100) 'iobt%seaice_melt ', chks chks = field_chksum( iobt%salt_flux ) ; if (root) write(outunit,100) 'iobt%salt_flux ', chks chks = field_chksum( iobt%lw_flux ) ; if (root) write(outunit,100) 'iobt%lw_flux ', chks @@ -1496,6 +1579,8 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) chks = field_chksum( iobt%fprec ) ; if (root) write(outunit,100) 'iobt%fprec ', chks chks = field_chksum( iobt%lrunoff ) ; if (root) write(outunit,100) 'iobt%lrunoff ', chks chks = field_chksum( iobt%frunoff ) ; if (root) write(outunit,100) 'iobt%frunoff ', chks + chks = field_chksum( iobt%lrunoff_glc ) ; if (root) write(outunit,100) 'iobt%lrunoff_glc ', chks + chks = field_chksum( iobt%frunoff_glc ) ; if (root) write(outunit,100) 'iobt%frunoff_glc ', chks chks = field_chksum( iobt%p ) ; if (root) write(outunit,100) 'iobt%p ', chks if (associated(iobt%ice_fraction)) then chks = field_chksum( iobt%ice_fraction ) ; if (root) write(outunit,100) 'iobt%ice_fraction ', chks @@ -1513,7 +1598,88 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) chks = field_chksum( iobt%mass_berg ) ; if (root) write(outunit,100) 'iobt%mass_berg ', chks endif + ! MARBL forcing + if (associated(iobt%atm_fine_dust_flux)) then + chks = field_chksum(iobt%atm_fine_dust_flux) + if (root) write(outunit,110) 'iobt%atm_fine_dust_flux ', chks + endif + if (associated(iobt%atm_coarse_dust_flux)) then + chks = field_chksum(iobt%atm_coarse_dust_flux) + if (root) write(outunit,110) 'iobt%atm_coarse_dust_flux ', chks + endif + if (associated(iobt%seaice_dust_flux)) then + chks = field_chksum(iobt%seaice_dust_flux) + if (root) write(outunit,110) 'iobt%seaice_dust_flux ', chks + endif + if (associated(iobt%atm_bc_flux)) then + chks = field_chksum(iobt%atm_bc_flux) + if (root) write(outunit,110) 'iobt%atm_bc_flux ', chks + endif + if (associated(iobt%seaice_bc_flux)) then + chks = field_chksum(iobt%seaice_bc_flux) + if (root) write(outunit,110) 'iobt%seaice_bc_flux ', chks + endif + if (associated(iobt%nhx_dep)) then + chks = field_chksum(iobt%nhx_dep) + if (root) write(outunit,100) 'iobt%nhx_dep ', chks + endif + if (associated(iobt%noy_dep)) then + chks = field_chksum(iobt%noy_dep) + if (root) write(outunit,100) 'iobt%noy_dep ', chks + endif + if (associated(iobt%atm_co2_prog)) then + chks = field_chksum(iobt%atm_co2_prog) + if (root) write(outunit,110) 'iobt%atm_co2_prog ', chks + endif + if (associated(iobt%atm_co2_diag)) then + chks = field_chksum(iobt%atm_co2_diag) + if (root) write(outunit,110) 'iobt%atm_co2_diag ', chks + endif + if (associated(iobt%afracr)) then + chks = field_chksum(iobt%afracr) + if (root) write(outunit,100) 'iobt%afracr ', chks + endif + if (associated(iobt%swnet_afracr)) then + chks = field_chksum(iobt%swnet_afracr) + if (root) write(outunit,110) 'iobt%swnet_afracr ', chks + endif + if (associated(iobt%ifrac_n)) then + chks = field_chksum(iobt%ifrac_n) + if (root) write(outunit,100) 'iobt%ifrac_n ', chks + endif + if (associated(iobt%swpen_ifrac_n)) then + chks = field_chksum(iobt%swpen_ifrac_n) + if (root) write(outunit,110) 'iobt%swpen_ifrac_n ', chks + endif + + ! enthalpy + if (associated(iobt%hrofl)) then + chks = field_chksum( iobt%hrofl ) ; if (root) write(outunit,100) 'iobt%hrofl ', chks + endif + if (associated(iobt%hrofi)) then + chks = field_chksum( iobt%hrofi ) ; if (root) write(outunit,100) 'iobt%hrofi ', chks + endif + if (associated(iobt%hrain)) then + chks = field_chksum( iobt%hrain ) ; if (root) write(outunit,100) 'iobt%hrain ', chks + endif + if (associated(iobt%hsnow)) then + chks = field_chksum( iobt%hsnow ) ; if (root) write(outunit,100) 'iobt%hsnow ', chks + endif + if (associated(iobt%hevap)) then + chks = field_chksum( iobt%hevap ) ; if (root) write(outunit,100) 'iobt%hevap ', chks + endif + if (associated(iobt%hcond)) then + chks = field_chksum( iobt%hcond ) ; if (root) write(outunit,100) 'iobt%hcond ', chks + endif + if (associated(iobt%hrofl_glc)) then + chks = field_chksum( iobt%hrofl_glc ) ; if (root) write(outunit,100) 'iobt%hrofl_glc ', chks + endif + if (associated(iobt%hrofl_glc)) then + chks = field_chksum( iobt%hrofl_glc ) ; if (root) write(outunit,100) 'iobt%hrofl_glc ', chks + endif + 100 FORMAT(" CHECKSUM::",A20," = ",Z20) +110 FORMAT(" CHECKSUM::",A30," = ",Z20) call coupler_type_write_chksums(iobt%fluxes, outunit, 'iobt%') diff --git a/config_src/drivers/nuopc_cap/ocn_comp_NUOPC.F90 b/config_src/drivers/nuopc_cap/ocn_comp_NUOPC.F90 index 6d25b9a1ae..bb41084b65 100644 --- a/config_src/drivers/nuopc_cap/ocn_comp_NUOPC.F90 +++ b/config_src/drivers/nuopc_cap/ocn_comp_NUOPC.F90 @@ -1,3 +1,7 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + module ocn_comp_NUOPC use MOM_cap_mod end module ocn_comp_NUOPC diff --git a/config_src/drivers/nuopc_cap/time_utils.F90 b/config_src/drivers/nuopc_cap/time_utils.F90 index 81efcd2765..b7fcce8393 100644 --- a/config_src/drivers/nuopc_cap/time_utils.F90 +++ b/config_src/drivers/nuopc_cap/time_utils.F90 @@ -1,3 +1,7 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Set of time utilities for converting between FMS and ESMF time type. module time_utils_mod @@ -16,7 +20,7 @@ module time_utils_mod use ESMF, only: ESMF_TimeIntervalGet, ESMF_TimeSet, ESMF_SUCCESS use MOM_cap_methods, only: ChkErr -implicit none; private +implicit none ; private !> Converts calendar from FMS to ESMF format interface fms2esmf_cal @@ -130,7 +134,7 @@ function fms2esmf_time(time, calkind) integer :: rc - if(present(calkind)) then + if (present(calkind)) then l_calkind = calkind else l_calkind = fms2esmf_cal(fms_get_calendar_type()) @@ -154,7 +158,7 @@ function string_to_date(string, rc) ! Local variables integer :: yr,mon,day,hr,min,sec - if(present(rc)) rc = ESMF_SUCCESS + if (present(rc)) rc = ESMF_SUCCESS read(string, '(I4.4,I2.2,I2.2,".",I2.2,I2.2,I2.2)') yr, mon, day, hr, min, sec string_to_date = set_date(yr, mon, day, hr, min, sec) diff --git a/config_src/drivers/solo_driver/MESO_surface_forcing.F90 b/config_src/drivers/solo_driver/MESO_surface_forcing.F90 index 300c736802..b93a3fdb72 100644 --- a/config_src/drivers/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MESO_surface_forcing.F90 @@ -1,15 +1,17 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Sets forcing for the MESO configuration module MESO_surface_forcing -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_diag_mediator, only : post_data, query_averaging_enabled use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr use MOM_domains, only : pass_var, pass_vector, AGRID use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_forcing_type, only : forcing, mech_forcing -use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing +use MOM_forcing_type, only : allocate_forcing_type use MOM_grid, only : ocean_grid_type use MOM_io, only : file_exists, MOM_read_data, slasher use MOM_time_manager, only : time_type, operator(+), operator(/) @@ -30,11 +32,13 @@ module MESO_surface_forcing real :: Rho0 !< The density used in the Boussinesq approximation [R ~> kg m-3]. real :: G_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. real :: Flux_const !< The restoring rate at the surface [Z T-1 ~> m s-1]. + real :: rho_restore !< The density that is used to convert piston velocities into salt + !! or heat fluxes with salinity or temperature restoring [R ~> kg m-3] real :: gust_const !< A constant unresolved background gustiness - !! that contributes to ustar [R L Z T-1 ~> Pa] + !! that contributes to ustar [R L Z T-2 ~> Pa] real, dimension(:,:), pointer :: & - T_Restore(:,:) => NULL(), & !< The temperature to restore the SST toward [degC]. - S_Restore(:,:) => NULL(), & !< The salinity to restore the sea surface salnity toward [ppt] + T_Restore(:,:) => NULL(), & !< The temperature to restore the SST toward [C ~> degC]. + S_Restore(:,:) => NULL(), & !< The salinity to restore the sea surface salnity toward [S ~> ppt] PmE(:,:) => NULL(), & !< The prescribed precip minus evap [Z T-1 ~> m s-1]. Solar(:,:) => NULL() !< The shortwave forcing into the ocean [Q R Z T-1 ~> W m-2]. real, dimension(:,:), pointer :: Heat(:,:) => NULL() !< The prescribed longwave, latent and sensible @@ -77,10 +81,8 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! are in W m-2 and positive for heat going into the ocean. All fresh water ! fluxes are in kg m-2 s-1 and positive for water moving into the ocean. - real :: Temp_restore ! The temperature that is being restored toward [degC]. - real :: Salin_restore ! The salinity that is being restored toward [ppt] real :: density_restore ! The potential density that is being restored toward [R ~> kg m-3]. - real :: rhoXcp ! The mean density times the heat capacity [Q R degC-1 ~> J m-3 degC-1]. + real :: rhoXcp ! The mean density times the heat capacity [Q R C-1 ~> J m-3 degC-1]. real :: buoy_rest_const ! A constant relating density anomalies to the ! restoring buoyancy flux [L2 T-3 R-1 ~> m5 s-3 kg-1]. @@ -122,9 +124,9 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) call safe_alloc_ptr(CS%Solar, isd, ied, jsd, jed) call MOM_read_data(trim(CS%inputdir)//trim(CS%SSTrestore_file), "SST", & - CS%T_Restore(:,:), G%Domain) + CS%T_Restore(:,:), G%Domain, scale=US%degC_to_C) call MOM_read_data(trim(CS%inputdir)//trim(CS%salinityrestore_file), "SAL", & - CS%S_Restore(:,:), G%Domain) + CS%S_Restore(:,:), G%Domain, scale=US%ppt_to_S) call MOM_read_data(trim(CS%inputdir)//trim(CS%heating_file), "Heat", & CS%Heat(:,:), G%Domain, scale=US%W_m2_to_QRZ_T) call MOM_read_data(trim(CS%inputdir)//trim(CS%PmE_file), "PmE", & @@ -168,14 +170,14 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! call MOM_error(FATAL, "MESO_buoyancy_surface_forcing: " // & ! "Temperature and salinity restoring used without modification." ) - rhoXcp = CS%Rho0 * fluxes%C_p + rhoXcp = CS%rho_restore * fluxes%C_p do j=js,je ; do i=is,ie ! Set Temp_restore and Salin_restore to the temperature (in degC) and ! salinity (in ppt or PSU) that are being restored toward. - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const) - fluxes%vprec(i,j) = - (CS%Rho0 * CS%Flux_const) * & + fluxes%vprec(i,j) = - (CS%rho_restore * CS%Flux_const) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) else @@ -190,7 +192,7 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) "Buoyancy restoring used without modification." ) ! The -1 is because density has the opposite sign to buoyancy. - buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%Rho0 + buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%rho_restore do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential ! density [R ~> kg m-3] that is being restored toward. @@ -239,12 +241,12 @@ subroutine MESO_surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& + "properties, or with BOUSSINESQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & "The background gustiness in the winds.", units="Pa", default=0.0, & - scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) + scale=US%Pa_to_RLZ_T2) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& @@ -274,7 +276,11 @@ subroutine MESO_surface_forcing_init(Time, G, US, param_file, diag, CS) "variable NET_SOL.", fail_if_missing=.true.) call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, default=".") CS%inputdir = slasher(CS%inputdir) - + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", CS%rho_restore, & + "The density that is used to convert piston velocities into salt or heat "//& + "fluxes with RESTORE_SALINITY or RESTORE_TEMPERATURE.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=(CS%Flux_const==0.0).or.(.not.CS%restorebuoy)) endif end subroutine MESO_surface_forcing_init diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index ebf3e5a43d..d12c7c5e12 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -1,6 +1,8 @@ -program MOM_main +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 -! This file is part of MOM6. See LICENSE.md for the license. +program MOM6 !********+*********+*********+*********+*********+*********+*********+** !* * @@ -26,12 +28,14 @@ program MOM_main use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT - use MOM_diag_mediator, only : enable_averaging, disable_averaging, diag_mediator_end - use MOM_diag_mediator, only : diag_ctrl, diag_mediator_close_registration + use MOM_data_override, only : data_override_init + use MOM_diag_mediator, only : diag_mediator_end, diag_ctrl, diag_mediator_close_registration + use MOM_diag_manager_infra, only : diag_manager_set_time_end_infra use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end use MOM, only : extract_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized use MOM, only : step_offline + use MOM, only : save_MOM_restart use MOM_coms, only : Set_PElist use MOM_domains, only : MOM_infra_init, MOM_infra_end, set_MOM_thread_affinity use MOM_ensemble_manager, only : ensemble_manager_init, get_ensemble_size @@ -47,15 +51,16 @@ program MOM_main use MOM_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS use MOM_ice_shelf, only : shelf_calc_flux, add_shelf_forces, ice_shelf_save_restart use MOM_ice_shelf, only : initialize_ice_shelf_fluxes, initialize_ice_shelf_forces + use MOM_ice_shelf, only : ice_shelf_query, adjust_ice_sheet_frazil + use MOM_ice_shelf_initialize, only : initialize_ice_SMB use MOM_interpolate, only : time_interp_external_init use MOM_io, only : file_exists, open_ASCII_file, close_file use MOM_io, only : check_nml_error, io_infra_init, io_infra_end use MOM_io, only : APPEND_FILE, READONLY_FILE - use MOM_restart, only : MOM_restart_CS, save_restart use MOM_string_functions,only : uppercase use MOM_surface_forcing, only : set_forcing, forcing_save_restart use MOM_surface_forcing, only : surface_forcing_init, surface_forcing_CS - use MOM_time_manager, only : time_type, set_date, get_date, real_to_time, time_type_to_real + use MOM_time_manager, only : time_type, set_date, get_date, real_to_time, time_to_real use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) use MOM_time_manager, only : operator(>), operator(<), operator(>=) use MOM_time_manager, only : increment_date, set_calendar_type, month_name @@ -120,23 +125,20 @@ program MOM_main type(time_type) :: Time_step_ocean ! A time_type version of dt_forcing. logical :: segment_start_time_set ! True if segment_start_time has been set to a valid value. - real :: elapsed_time = 0.0 ! Elapsed time in this run [s]. - logical :: elapsed_time_master ! If true, elapsed time is used to set the - ! model's master clock (Time). This is needed - ! if Time_step_ocean is not an exact - ! representation of dt_forcing. - real :: dt_forcing ! The coupling time step [s]. - real :: dt ! The nominal baroclinic dynamics time step [s]. - real :: dt_off ! Offline time step [s]. - integer :: ntstep ! The number of baroclinic dynamics time steps - ! within dt_forcing. - real :: dt_therm ! The thermodynamic timestep [s] - real :: dt_dyn ! The actual dynamic timestep used [s]. The value of dt_dyn is - ! chosen so that dt_forcing is an integer multiple of dt_dyn. - real :: dtdia ! The diabatic timestep [s] - real :: t_elapsed_seg ! The elapsed time in this run segment [s] + real :: elapsed_time = 0.0 ! Elapsed time in this run [T ~> s]. + logical :: elapsed_time_master ! If true, elapsed time is used to set the model's master + ! clock (Time). This is needed if Time_step_ocean is not + ! an exact representation of dt_forcing. + real :: dt_forcing ! The coupling time step [T ~> s]. + real :: dt ! The nominal baroclinic dynamics time step [T ~> s]. + integer :: ntstep ! The number of baroclinic dynamics time steps within dt_forcing. + real :: dt_therm ! The thermodynamic timestep [T ~> s] + real :: dt_dyn ! The actual dynamic timestep used [T ~> s]. The value of dt_dyn + ! is chosen so that dt_forcing is an integer multiple of dt_dyn. + real :: dtdia ! The diabatic timestep [T ~> s] + real :: t_elapsed_seg ! The elapsed time in this run segment [T ~> s] integer :: n, ns, n_max, nts, n_last_thermo - logical :: diabatic_first, single_step_call + logical :: diabatic_first, single_step_call, initialize_smb type(time_type) :: Time2, time_chg ! Temporary time variables integer :: Restart_control ! An integer that is bit-tested to determine whether @@ -176,12 +178,11 @@ program MOM_main type(surface_forcing_CS), pointer :: surface_forcing_CSp => NULL() type(write_cputime_CS), pointer :: write_CPU_CSp => NULL() type(ice_shelf_CS), pointer :: ice_shelf_CSp => NULL() + logical :: override_shelf_fluxes !< If true, and shelf dynamics are active, + !! the data_override feature is enabled (only for MOSAIC grid types) type(wave_parameters_cs), pointer :: waves_CSp => NULL() - type(MOM_restart_CS), pointer :: & - restart_CSp => NULL() !< A pointer to the restart control structure - !! that will be used for MOM restart files. type(diag_ctrl), pointer :: & - diag => NULL() !< A pointer to the diagnostic regulatory structure + diag => NULL() !< A pointer to the diagnostic regulatory structure !----------------------------------------------------------------------- character(len=4), parameter :: vers_num = 'v2.0' @@ -253,11 +254,11 @@ program MOM_main endif else calendar = uppercase(calendar) - if (calendar(1:6) == 'JULIAN') then ; calendar_type = JULIAN - elseif (calendar(1:9) == 'GREGORIAN') then ; calendar_type = GREGORIAN - elseif (calendar(1:6) == 'NOLEAP') then ; calendar_type = NOLEAP - elseif (calendar(1:10)=='THIRTY_DAY') then ; calendar_type = THIRTY_DAY_MONTHS - elseif (calendar(1:11)=='NO_CALENDAR') then; calendar_type = NO_CALENDAR + if (calendar(1:6) == 'JULIAN') then ; calendar_type = JULIAN + elseif (calendar(1:9) == 'GREGORIAN') then ; calendar_type = GREGORIAN + elseif (calendar(1:6) == 'NOLEAP') then ; calendar_type = NOLEAP + elseif (calendar(1:10)=='THIRTY_DAY') then ; calendar_type = THIRTY_DAY_MONTHS + elseif (calendar(1:11)=='NO_CALENDAR') then ; calendar_type = NO_CALENDAR elseif (calendar(1:1) /= ' ') then call MOM_error(FATAL,'MOM_driver: Invalid namelist value '//trim(calendar)//' for calendar') else @@ -281,16 +282,17 @@ program MOM_main if (segment_start_time_set) then ! In this case, the segment starts at a time fixed by ocean_solo.res Time = segment_start_time - call initialize_MOM(Time, Start_time, param_file, dirs, MOM_CSp, restart_CSp, & + call initialize_MOM(Time, Start_time, param_file, dirs, MOM_CSp, & segment_start_time, offline_tracer_mode=offline_tracer_mode, & - diag_ptr=diag, tracer_flow_CSp=tracer_flow_CSp, ice_shelf_CSp=ice_shelf_CSp) + diag_ptr=diag, tracer_flow_CSp=tracer_flow_CSp, ice_shelf_CSp=ice_shelf_CSp, & + waves_CSp=Waves_CSp) else ! In this case, the segment starts at a time read from the MOM restart file ! or is left at Start_time by MOM_initialize. Time = Start_time - call initialize_MOM(Time, Start_time, param_file, dirs, MOM_CSp, restart_CSp, & + call initialize_MOM(Time, Start_time, param_file, dirs, MOM_CSp, & offline_tracer_mode=offline_tracer_mode, diag_ptr=diag, & - tracer_flow_CSp=tracer_flow_CSp, ice_shelf_CSp=ice_shelf_CSp) + tracer_flow_CSp=tracer_flow_CSp, ice_shelf_CSp=ice_shelf_CSp, waves_CSp=Waves_CSp) endif call get_MOM_state_elements(MOM_CSp, G=grid, GV=GV, US=US, C_p_scaled=fluxes%C_p) @@ -302,6 +304,11 @@ program MOM_main ! when using an ice shelf call initialize_ice_shelf_fluxes(ice_shelf_CSp, grid, US, fluxes) call initialize_ice_shelf_forces(ice_shelf_CSp, grid, US, forces) + call ice_shelf_query(ice_shelf_CSp, grid, data_override_shelf_fluxes=override_shelf_fluxes) + if (override_shelf_fluxes) call data_override_init(Ocean_Domain_in=grid%domain%mpp_domain) + call get_param(param_file, mod_name, "INITIALIZE_ICE_SHEET_SMB", & + initialize_smb, "Read in a constant SMB for the ice sheet", default=.false.) + if (initialize_smb) call initialize_ice_SMB(fluxes%shelf_sfc_mass_flux, grid, US, param_file) endif @@ -309,6 +316,9 @@ program MOM_main call extract_surface_state(MOM_CSp, sfc_state) + if (use_ice_shelf .and. allocated(sfc_state%frazil)) & + call adjust_ice_sheet_frazil(sfc_state, fluxes, Ice_shelf_CSp) + call surface_forcing_init(Time, grid, US, param_file, diag, & surface_forcing_CSp, tracer_flow_CSp) call callTree_waypoint("done surface_forcing_init") @@ -325,24 +335,28 @@ program MOM_main ! Read all relevant parameters and write them to the model log. call log_version(param_file, mod_name, version, "") - call get_param(param_file, mod_name, "DT", dt, fail_if_missing=.true.) + call get_param(param_file, mod_name, "DT", dt, & + units="s", scale=US%s_to_T, fail_if_missing=.true.) call get_param(param_file, mod_name, "DT_FORCING", dt_forcing, & "The time step for changing forcing, coupling with other "//& "components, or potentially writing certain diagnostics. "//& - "The default value is given by DT.", units="s", default=dt) + "The default value is given by DT.", & + units="s", default=US%T_to_s*dt, scale=US%s_to_T) if (offline_tracer_mode) then call get_param(param_file, mod_name, "DT_OFFLINE", dt_forcing, & - "Time step for the offline time step") + "Length of time between reading in of input fields", & + units="s", scale=US%s_to_T, fail_if_missing=.true.) dt = dt_forcing endif ntstep = MAX(1,ceiling(dt_forcing/dt - 0.001)) - Time_step_ocean = real_to_time(dt_forcing) - elapsed_time_master = (abs(dt_forcing - time_type_to_real(Time_step_ocean)) > 1.0e-12*dt_forcing) + Time_step_ocean = real_to_time(dt_forcing, unscale=US%T_to_s) + elapsed_time_master = (abs(dt_forcing - time_to_real(Time_step_ocean, scale=US%s_to_T)) > 1.0e-12*dt_forcing) if (elapsed_time_master) & call MOM_mesg("Using real elapsed time for the master clock.", 2) ! Determine the segment end time, either from the namelist file or parsed input file. + ! Note that Time_unit always is in [s]. call get_param(param_file, mod_name, "TIMEUNIT", Time_unit, & "The time unit for DAYMAX, ENERGYSAVEDAYS, and RESTINT.", & units="s", default=86400.0) @@ -367,6 +381,8 @@ program MOM_main Time_end = daymax endif + call diag_manager_set_time_end_infra(Time_end) + call get_param(param_file, mod_name, "SINGLE_STEPPING_CALL", single_step_call, & "If true, advance the state of MOM with a single step "//& "including both dynamics and thermodynamics. If false "//& @@ -377,7 +393,8 @@ program MOM_main "and less than the forcing or coupling time-step, unless "//& "THERMO_SPANS_COUPLING is true, in which case DT_THERM "//& "can be an integer multiple of the coupling timestep. By "//& - "default DT_THERM is set to DT.", units="s", default=dt) + "default DT_THERM is set to DT.", & + units="s", default=US%T_to_s*dt, scale=US%s_to_T) call get_param(param_file, mod_name, "DIABATIC_FIRST", diabatic_first, & "If true, apply diabatic and thermodynamic processes, "//& "including buoyancy forcing and mass gain or loss, "//& @@ -458,14 +475,14 @@ program MOM_main call add_shelf_forces(grid, US, Ice_shelf_CSp, forces, external_call=.true.) endif fluxes%fluxes_used = .false. - fluxes%dt_buoy_accum = US%s_to_T*dt_forcing + fluxes%dt_buoy_accum = dt_forcing if (use_waves) then call Update_Surface_Waves(grid, GV, US, time, time_step_ocean, waves_csp) endif if (ns==1) then - call finish_MOM_initialization(Time, dirs, MOM_CSp, restart_CSp) + call finish_MOM_initialization(Time, dirs, MOM_CSp) endif ! This call steps the model over a time dt_forcing. @@ -503,7 +520,7 @@ program MOM_main dtdia = dt_dyn*(n - n_last_thermo) ! Back up Time2 to the start of the thermodynamic segment. if (n > n_last_thermo+1) & - Time2 = Time2 - real_to_time(dtdia - dt_dyn) + Time2 = Time2 - real_to_time((dtdia - dt_dyn), unscale=US%T_to_s) call step_MOM(forces, fluxes, sfc_state, Time2, dtdia, MOM_CSp, & do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_forcing) @@ -512,25 +529,25 @@ program MOM_main endif t_elapsed_seg = t_elapsed_seg + dt_dyn - Time2 = Time1 + real_to_time(t_elapsed_seg) + Time2 = Time1 + real_to_time(t_elapsed_seg, unscale=US%T_to_s) enddo endif ! Time = Time + Time_step_ocean ! This is here to enable fractional-second time steps. elapsed_time = elapsed_time + dt_forcing - if (elapsed_time > 2e9) then + if (elapsed_time > 2.0e9*US%s_to_T) then ! This is here to ensure that the conversion from a real to an integer can be accurately ! represented in long runs (longer than ~63 years). It will also ensure that elapsed time ! does not lose resolution of order the timetype's resolution, provided that the timestep and ! tick are larger than 10-5 seconds. If a clock with a finer resolution is used, a smaller ! value would be required. - time_chg = real_to_time(elapsed_time) + time_chg = real_to_time(elapsed_time, unscale=US%T_to_s) segment_start_time = segment_start_time + time_chg - elapsed_time = elapsed_time - time_type_to_real(time_chg) + elapsed_time = elapsed_time - time_to_real(time_chg, scale=US%s_to_T) endif if (elapsed_time_master) then - Master_Time = segment_start_time + real_to_time(elapsed_time) + Master_Time = segment_start_time + real_to_time(elapsed_time, unscale=US%T_to_s) else Master_Time = Master_Time + Time_step_ocean endif @@ -556,16 +573,15 @@ program MOM_main if ((permit_incr_restart) .and. (fluxes%fluxes_used) .and. & (Time + (Time_step_ocean/2) > restart_time)) then if (BTEST(Restart_control,1)) then - call save_restart(dirs%restart_output_dir, Time, grid, & - restart_CSp, .true., GV=GV) + call save_MOM_restart(MOM_CSp, dirs%restart_output_dir, Time, grid, & + time_stamped=.true., GV=GV) call forcing_save_restart(surface_forcing_CSp, grid, Time, & dirs%restart_output_dir, .true.) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & dirs%restart_output_dir, .true.) endif if (BTEST(Restart_control,0)) then - call save_restart(dirs%restart_output_dir, Time, grid, & - restart_CSp, GV=GV) + call save_MOM_restart(MOM_CSp, dirs%restart_output_dir, Time, grid, GV=GV) call forcing_save_restart(surface_forcing_CSp, grid, Time, & dirs%restart_output_dir) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & @@ -590,9 +606,10 @@ program MOM_main "For conservation, the ocean restart files can only be "//& "created after the buoyancy forcing is applied.") - call save_restart(dirs%restart_output_dir, Time, grid, restart_CSp, GV=GV) + call save_MOM_restart(MOM_CSp, dirs%restart_output_dir, Time, grid, GV=GV) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & dirs%restart_output_dir) + ! Write the ocean solo restart file. call write_ocean_solo_res(Time, Start_time, calendar_type, & trim(dirs%restart_output_dir)//'ocean_solo.res') @@ -614,10 +631,11 @@ program MOM_main if (cpu_steps > 0) call write_cputime(Time, ns-1, write_CPU_CSp, call_end=.true.) call cpu_clock_end(termClock) - call io_infra_end ; call MOM_infra_end - call MOM_end(MOM_CSp) + ! This closes out the infrastructure, including clocks, I/O and message passing communicators. + call io_infra_end() ; call MOM_infra_end() + contains !> Write out the ocean solo restart file to the indicated path. @@ -686,4 +704,4 @@ subroutine initialize_ocean_only_ensembles() endif end subroutine initialize_ocean_only_ensembles -end program MOM_main +end program MOM6 diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index 7c26c2f194..84ee7a7472 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -1,3 +1,7 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Functions that calculate the surface wind stresses and fluxes of buoyancy !! or temperature/salinity and fresh water, in ocean-only (solo) mode. !! @@ -7,8 +11,6 @@ !! fields is controlled by surface_forcing_init, located in this file. module MOM_surface_forcing -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_constants, only : hlv, hlf use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE @@ -19,7 +21,7 @@ module MOM_surface_forcing use MOM_domains, only : fill_symmetric_edges, CGRID_NE use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave -use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_string_functions, only : uppercase use MOM_forcing_type, only : forcing, mech_forcing use MOM_forcing_type, only : set_net_mass_forcing, copy_common_forcing_fields @@ -30,12 +32,12 @@ module MOM_surface_forcing use MOM_grid, only : ocean_grid_type use MOM_get_input, only : Get_MOM_Input, directories use MOM_io, only : file_exists, MOM_read_data, MOM_read_vector, slasher -use MOM_io, only : EAST_FACE, NORTH_FACE, num_timelevels +use MOM_io, only : read_netCDF_data, EAST_FACE, NORTH_FACE, num_timelevels use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS use MOM_restart, only : restart_init_end, save_restart, restore_state -use MOM_time_manager, only : time_type, operator(+), operator(/), get_time, time_type_to_real -use MOM_tracer_flow_control, only : call_tracer_set_forcing -use MOM_tracer_flow_control, only : tracer_flow_control_CS +use MOM_time_manager, only : time_type, operator(+), operator(/), operator(*) +use MOM_time_manager, only : set_time, get_time, get_date, time_to_real +use MOM_tracer_flow_control, only : call_tracer_set_forcing, tracer_flow_control_CS use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MESO_surface_forcing, only : MESO_buoyancy_forcing @@ -44,17 +46,18 @@ module MOM_surface_forcing use user_surface_forcing, only : USER_surface_forcing_init, user_surface_forcing_CS use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init use user_revise_forcing, only : user_revise_forcing_CS -use idealized_hurricane, only : idealized_hurricane_wind_init -use idealized_hurricane, only : idealized_hurricane_wind_forcing, SCM_idealized_hurricane_wind_forcing -use idealized_hurricane, only : idealized_hurricane_CS +use idealized_hurricane, only : idealized_hurricane_wind_forcing +use idealized_hurricane, only : idealized_hurricane_wind_init, idealized_hurricane_CS use SCM_CVmix_tests, only : SCM_CVmix_tests_surface_forcing_init use SCM_CVmix_tests, only : SCM_CVmix_tests_wind_forcing use SCM_CVmix_tests, only : SCM_CVmix_tests_buoyancy_forcing use SCM_CVmix_tests, only : SCM_CVmix_tests_CS -use BFB_surface_forcing, only : BFB_buoyancy_forcing -use BFB_surface_forcing, only : BFB_surface_forcing_init, BFB_surface_forcing_CS -use dumbbell_surface_forcing, only : dumbbell_surface_forcing_init, dumbbell_surface_forcing_CS -use dumbbell_surface_forcing, only : dumbbell_buoyancy_forcing +use BFB_surface_forcing, only : BFB_buoyancy_forcing +use BFB_surface_forcing, only : BFB_surface_forcing_init, BFB_surface_forcing_CS +use dumbbell_surface_forcing, only : dumbbell_surface_forcing_init, dumbbell_surface_forcing_CS +use dumbbell_surface_forcing, only : dumbbell_buoyancy_forcing +use MARBL_forcing_mod, only : marbl_forcing_CS, MARBL_forcing_init +use MARBL_forcing_mod, only : convert_driver_fields_to_forcings implicit none ; private @@ -71,54 +74,59 @@ module MOM_surface_forcing logical :: use_temperature !< if true, temp & salinity used as state variables logical :: restorebuoy !< if true, use restoring surface buoyancy forcing logical :: adiabatic !< if true, no diapycnal mass fluxes or surface buoyancy forcing + logical :: nonBous !< If true, this run is fully non-Boussinesq logical :: variable_winds !< if true, wind stresses vary with time logical :: variable_buoyforce !< if true, buoyancy forcing varies with time. - real :: south_lat !< southern latitude of the domain - real :: len_lat !< domain length in latitude + real :: south_lat !< southern latitude of the domain [degrees_N] or [km] or [m] + real :: len_lat !< domain length in latitude [degrees_N] or [km] or [m] real :: Rho0 !< Boussinesq reference density [R ~> kg m-3] real :: G_Earth !< gravitational acceleration [L2 Z-1 T-2 ~> m s-2] - real :: Flux_const !< piston velocity for surface restoring [Z T-1 ~> m s-1] - real :: Flux_const_T !< piston velocity for surface temperature restoring [Z T-1 ~> m s-1] - real :: Flux_const_S !< piston velocity for surface salinity restoring [Z T-1 ~> m s-1] + real :: Flux_const = 0.0 !< piston velocity for surface restoring [Z T-1 ~> m s-1] + real :: Flux_const_T = 0.0 !< piston velocity for surface temperature restoring [Z T-1 ~> m s-1] + real :: Flux_const_S = 0.0 !< piston velocity for surface salinity restoring [Z T-1 ~> m s-1] + real :: rho_restore !< The density that is used to convert piston velocities into salt + !! or heat fluxes with salinity or temperature restoring [R ~> kg m-3] real :: latent_heat_fusion !< latent heat of fusion times [Q ~> J kg-1] real :: latent_heat_vapor !< latent heat of vaporization [Q ~> J kg-1] real :: tau_x0 !< Constant zonal wind stress used in the WIND_CONFIG="const" - !! forcing [R L Z T-1 ~> Pa] + !! forcing [R L Z T-2 ~> Pa] real :: tau_y0 !< Constant meridional wind stress used in the WIND_CONFIG="const" - !! forcing [R L Z T-1 ~> Pa] + !! forcing [R L Z T-2 ~> Pa] + real :: taux_mag !< Peak magnitude of the zonal wind stress for several analytic + !! profiles [R L Z T-2 ~> Pa] - real :: gust_const !< constant unresolved background gustiness for ustar [R L Z T-1 ~> Pa] + real :: gust_const !< constant unresolved background gustiness for ustar [R Z2 T-2 ~> Pa] logical :: read_gust_2d !< if true, use 2-dimensional gustiness supplied from a file - real, pointer :: gust(:,:) => NULL() !< spatially varying unresolved background gustiness [R L Z T-1 ~> Pa] + real, pointer :: gust(:,:) => NULL() !< spatially varying unresolved background gustiness [R L Z T-2 ~> Pa] !! gust is used when read_gust_2d is true. - real, pointer :: T_Restore(:,:) => NULL() !< temperature to damp (restore) the SST to [degC] - real, pointer :: S_Restore(:,:) => NULL() !< salinity to damp (restore) the SSS [ppt] + real, pointer :: T_Restore(:,:) => NULL() !< temperature to damp (restore) the SST to [C ~> degC] + real, pointer :: S_Restore(:,:) => NULL() !< salinity to damp (restore) the SSS [S ~> ppt] real, pointer :: Dens_Restore(:,:) => NULL() !< density to damp (restore) surface density [R ~> kg m-3] - integer :: buoy_last_lev_read = -1 !< The last time level read from buoyancy input files - ! if WIND_CONFIG=='gyres' then use the following as = A, B, C and n respectively for ! taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L) - real :: gyres_taux_const !< A constant wind stress [R L Z T-1 ~> Pa]. - real :: gyres_taux_sin_amp !< The amplitude of cosine wind stress gyres [R L Z T-1 ~> Pa], if WIND_CONFIG=='gyres' - real :: gyres_taux_cos_amp !< The amplitude of cosine wind stress gyres [R L Z T-1 ~> Pa], if WIND_CONFIG=='gyres' - real :: gyres_taux_n_pis !< The number of sine lobes in the basin if WIND_CONFIG=='gyres' - logical :: answers_2018 !< If true, use the order of arithmetic and expressions that recover - !! the answers from the end of 2018. Otherwise, use a form of the gyre - !! wind stresses that are rotationally invariant and more likely to be - !! the same between compilers. - logical :: fix_ustar_gustless_bug !< If true correct a bug in the time-averaging of the - !! gustless wind friction velocity. + real :: gyres_taux_const !< A constant wind stress [R L Z T-2 ~> Pa]. + real :: gyres_taux_sin_amp !< The amplitude of cosine wind stress gyres [R L Z T-2 ~> Pa], if WIND_CONFIG=='gyres' + real :: gyres_taux_cos_amp !< The amplitude of cosine wind stress gyres [R L Z T-2 ~> Pa], if WIND_CONFIG=='gyres' + real :: gyres_taux_n_pis !< The number of sine lobes in the basin if WIND_CONFIG=='gyres' [nondim] + integer :: answer_date !< This 8-digit integer gives the approximate date with which the order + !! of arithmetic and expressions were added to the code. + !! Dates before 20190101 use original answers. + !! Dates after 20190101 use a form of the gyre wind stresses that are + !! rotationally invariant and more likely to be the same between compilers. + logical :: ustar_gustless_bug !< If true, include a bug in the time-averaging of the + !! gustless wind friction velocity. + logical :: use_marbl_tracers !< If true, allocate memory for forcing needed by MARBL ! if WIND_CONFIG=='scurves' then use the following to define a piecewise scurve profile real :: scurves_ydata(20) = 90. !< Latitudes of scurve nodes [degreesN] - real :: scurves_taux(20) = 0. !< Zonal wind stress values at scurve nodes [R L Z T-1 ~> Pa] + real :: scurves_taux(20) = 0. !< Zonal wind stress values at scurve nodes [R L Z T-2 ~> Pa] - real :: T_north !< Target temperatures at north used in buoyancy_forcing_linear [degC] - real :: T_south !< Target temperatures at south used in buoyancy_forcing_linear [degC] - real :: S_north !< Target salinity at north used in buoyancy_forcing_linear [ppt] - real :: S_south !< Target salinity at south used in buoyancy_forcing_linear [ppt] + real :: T_north !< Target temperatures at north used in buoyancy_forcing_linear [C ~> degC] + real :: T_south !< Target temperatures at south used in buoyancy_forcing_linear [C ~> degC] + real :: S_north !< Target salinity at north used in buoyancy_forcing_linear [S ~> ppt] + real :: S_south !< Target salinity at south used in buoyancy_forcing_linear [S ~> ppt] logical :: first_call_set_forcing = .true. !< True until after the first call to set_forcing logical :: archaic_OMIP_file = .true. !< If true use the variable names and data fields from @@ -160,8 +168,8 @@ module MOM_surface_forcing character(len=200) :: salinityrestore_file = '' !< The file from which to read the sea surface !! salinity to restore toward - character(len=80) :: stress_x_var = '' !< X-windstress variable name in the input file - character(len=80) :: stress_y_var = '' !< Y-windstress variable name in the input file + character(len=80) :: stress_x_var = '' !< X-wind stress variable name in the input file + character(len=80) :: stress_y_var = '' !< Y-wind stress variable name in the input file character(len=80) :: ustar_var = '' !< ustar variable name in the input file character(len=80) :: LW_var = '' !< longwave heat flux variable name in the input file character(len=80) :: SW_var = '' !< shortwave heat flux variable name in the input file @@ -175,6 +183,38 @@ module MOM_surface_forcing character(len=80) :: SST_restore_var = '' !< target sea surface temperature variable name in the input file character(len=80) :: SSS_restore_var = '' !< target sea surface salinity variable name in the input file + ! These variables relate model times to time levels in the various forcing files. + integer :: wind_days_per_rec = 0 !< If positive the number of days of wind stress per forcing file time level, + !! or if negative the number of time levels per day. If 31 change forcing + !! monthly, or if 0 the model will guess the right value based on the file size. + integer :: SW_days_per_rec = 0 !< If positive the number of days shortwave heat flux per forcing file time level, + !! or if negative the number of time levels per day. If 31 change forcing + !! monthly, or if 0 the model will guess the right value based on the file size. + integer :: LW_days_per_rec = 0 !< If positive the number of days longwave heat flux per forcing file time level, + !! or if negative the number of time levels per day. If 31 change forcing + !! monthly, or if 0 the model will guess the right value based on the file size. + integer :: latent_days_per_rec = 0 !< If positive the number of days latent heat flux per forcing file time level, + !! or if negative the number of time levels per day. If 31 change forcing + !! monthly, or if 0 the model will guess the right value based on the file size. + integer :: sens_days_per_rec = 0 !< If positive the number of days sensible heat flux per forcing file time level, + !! or if negative the number of time levels per day. If 31 change forcing + !! monthly, or if 0 the model will guess the right value based on the file size. + integer :: evap_days_per_rec = 0 !< If positive the number of days evaporation per forcing file time level, + !! or if negative the number of time levels per day. If 31 change forcing + !! monthly, or if 0 the model will guess the right value based on the file size. + integer :: precip_days_per_rec = 0 !< If positive the number of days precipitation per forcing file time level, + !! or if negative the number of time levels per day. If 31 change forcing + !! monthly, or if 0 the model will guess the right value based on the file size. + integer :: runoff_days_per_rec = 0 !< If positive the number of days runoff per forcing file time level, + !! or if negative the number of time levels per day. If 31 change forcing + !! monthly, or if 0 the model will guess the right value based on the file size. + integer :: SST_days_per_rec = 0 !< If positive the number of days target SST per forcing file time level, + !! or if negative the number of time levels per day. If 31 change forcing + !! monthly, or if 0 the model will guess the right value based on the file size. + integer :: SSS_days_per_rec = 0 !< If positive the number of days target SSS per forcing file time level, + !! or if negative the number of time levels per day. If 31 change forcing + !! monthly, or if 0 the model will guess the right value based on the file size. + ! These variables give the number of time levels in the various forcing files. integer :: wind_nlev = -1 !< The number of time levels in the file of wind stress integer :: SW_nlev = -1 !< The number of time levels in the file of shortwave heat flux @@ -209,6 +249,7 @@ module MOM_surface_forcing type(MESO_surface_forcing_CS), pointer :: MESO_forcing_CSp => NULL() type(idealized_hurricane_CS), pointer :: idealized_hurricane_CSp => NULL() type(SCM_CVmix_tests_CS), pointer :: SCM_CVmix_tests_CSp => NULL() + type(marbl_forcing_CS), pointer :: marbl_forcing_CSp => NULL() !>@} end type surface_forcing_CS @@ -242,13 +283,14 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US call callTree_enter("set_forcing, MOM_surface_forcing.F90") day_center = day_start + day_interval/2 - dt = US%s_to_T * time_type_to_real(day_interval) + dt = time_to_real(day_interval, scale=US%s_to_T) if (CS%first_call_set_forcing) then ! Allocate memory for the mechanical and thermodynamic forcing fields. - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.not.CS%nonBous, press=.true., tau_mag=CS%nonBous) - call allocate_forcing_type(G, fluxes, ustar=.true., fix_accum_bug=CS%fix_ustar_gustless_bug) + call allocate_forcing_type(G, fluxes, ustar=.not.CS%nonBous, marbl=CS%use_marbl_tracers, tau_mag=CS%nonBous, & + fix_accum_bug=.not.CS%ustar_gustless_bug) if (trim(CS%buoy_config) /= "NONE") then if ( CS%use_temperature ) then call allocate_forcing_type(G, fluxes, water=.true., heat=.true., press=.true.) @@ -289,7 +331,8 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US elseif (trim(CS%wind_config) == "ideal_hurr") then call idealized_hurricane_wind_forcing(sfc_state, forces, day_center, G, US, CS%idealized_hurricane_CSp) elseif (trim(CS%wind_config) == "SCM_ideal_hurr") then - call SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day_center, G, US, CS%idealized_hurricane_CSp) + call MOM_error(FATAL, "MOM_surface_forcing (set_forcing): "//& + 'WIND_CONFIG = "SCM_ideal_hurr" is a depricated option.') elseif (trim(CS%wind_config) == "SCM_CVmix_tests") then call SCM_CVmix_tests_wind_forcing(sfc_state, forces, day_center, G, US, CS%SCM_CVmix_tests_CSp) elseif (trim(CS%wind_config) == "USER") then @@ -298,7 +341,7 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US call MOM_error(FATAL, & "MOM_surface_forcing: Variable winds defined with no wind config") else - call MOM_error(FATAL, & + call MOM_error(FATAL, & "MOM_surface_forcing:Unrecognized wind config "//trim(CS%wind_config)) endif endif @@ -338,13 +381,18 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US call MOM_error(FATAL, & "MOM_surface_forcing: Variable buoy defined with no buoy config.") else - call MOM_error(FATAL, & + call MOM_error(FATAL, & "MOM_surface_forcing: Unrecognized buoy config "//trim(CS%buoy_config)) endif endif + if (CS%use_marbl_tracers) then + call MARBL_forcing_from_data_override(fluxes, day_center, G, US, CS) + endif + if (associated(CS%tracer_flow_CSp)) then - call call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G, CS%tracer_flow_CSp) + call call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US, CS%Rho0, & + CS%tracer_flow_CSp) endif ! Allow for user-written code to alter the fluxes after all the above @@ -381,16 +429,16 @@ subroutine wind_forcing_const(sfc_state, forces, tau_x0, tau_y0, day, G, US, CS) type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables - real :: mag_tau ! Magnitude of the wind stress [R Z L T-2 ~> Pa] + real :: mag_tau ! Magnitude of the wind stress [R Z2 T-2 ~> Pa] integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq call callTree_enter("wind_forcing_const, MOM_surface_forcing.F90") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - mag_tau = sqrt( tau_x0**2 + tau_y0**2) + mag_tau = US%L_to_Z * sqrt( tau_x0**2 + tau_y0**2) - ! Set the steady surface wind stresses, in units of [R L Z T-1 ~> Pa]. + ! Set the steady surface wind stresses, in units of [R L Z T-2 ~> Pa]. do j=js,je ; do I=is-1,Ieq forces%taux(I,j) = tau_x0 enddo ; enddo @@ -401,11 +449,17 @@ subroutine wind_forcing_const(sfc_state, forces, tau_x0, tau_y0, day, G, US, CS) if (CS%read_gust_2d) then if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt( US%L_to_Z * ( mag_tau + CS%gust(i,j) ) / CS%Rho0 ) + forces%ustar(i,j) = sqrt( ( mag_tau + CS%gust(i,j) ) / CS%Rho0 ) + enddo ; enddo ; endif + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = mag_tau + CS%gust(i,j) enddo ; enddo ; endif else if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt( US%L_to_Z * ( mag_tau + CS%gust_const ) / CS%Rho0 ) + forces%ustar(i,j) = sqrt( ( mag_tau + CS%gust_const ) / CS%Rho0 ) + enddo ; enddo ; endif + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = mag_tau + CS%gust_const enddo ; enddo ; endif endif @@ -424,8 +478,6 @@ subroutine wind_forcing_2gyre(sfc_state, forces, day, G, US, CS) type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables - real :: Pa_to_RLZ_T2 ! A unit conversion factor from Pa to the internal units - ! for wind stresses [R Z L T-2 Pa-1 ~> 1] real :: PI ! A common irrational number, 3.1415926535... [nondim] integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq @@ -433,19 +485,19 @@ subroutine wind_forcing_2gyre(sfc_state, forces, day, G, US, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - Pa_to_RLZ_T2 = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z PI = 4.0*atan(1.0) - ! Set the steady surface wind stresses, in units of [R L Z T-1 ~> Pa]. + ! Set the steady surface wind stresses, in units of [R L Z T-2 ~> Pa]. do j=js,je ; do I=is-1,Ieq - forces%taux(I,j) = 0.1 * Pa_to_RLZ_T2 * & - (1.0 - cos(2.0*PI*(G%geoLatCu(I,j)-CS%South_lat) / CS%len_lat)) + forces%taux(I,j) = CS%taux_mag * (1.0 - cos(2.0*PI*(G%geoLatCu(I,j)-CS%South_lat) / CS%len_lat)) enddo ; enddo do J=js-1,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 enddo ; enddo + if (associated(forces%ustar)) call stresses_to_ustar(forces, G, US, CS) + call callTree_leave("wind_forcing_2gyre") end subroutine wind_forcing_2gyre @@ -461,8 +513,6 @@ subroutine wind_forcing_1gyre(sfc_state, forces, day, G, US, CS) type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by !! a previous surface_forcing_init call ! Local variables - real :: Pa_to_RLZ_T2 ! A unit conversion factor from Pa to the internal units - ! for wind stresses [R Z L T-2 Pa-1 ~> 1] real :: PI ! A common irrational number, 3.1415926535... [nondim] integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq @@ -471,18 +521,18 @@ subroutine wind_forcing_1gyre(sfc_state, forces, day, G, US, CS) Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB PI = 4.0*atan(1.0) - Pa_to_RLZ_T2 = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z ! Set the steady surface wind stresses, in units of [R Z L T-2 ~> Pa]. do j=js,je ; do I=is-1,Ieq - forces%taux(I,j) = -0.2 * Pa_to_RLZ_T2 * & - cos(PI*(G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat) + forces%taux(I,j) = CS%taux_mag * cos(PI*(G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat) enddo ; enddo do J=js-1,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 enddo ; enddo + if (associated(forces%ustar)) call stresses_to_ustar(forces, G, US, CS) + call callTree_leave("wind_forcing_1gyre") end subroutine wind_forcing_1gyre @@ -498,8 +548,6 @@ subroutine wind_forcing_gyres(sfc_state, forces, day, G, US, CS) !! a previous surface_forcing_init call ! Local variables real :: PI ! A common irrational number, 3.1415926535... [nondim] - real :: I_rho ! The inverse of the reference density times a ratio of scaling - ! factors [Z L-1 R-1 ~> m3 kg-1] real :: y ! The latitude relative to the south normalized by the domain extent [nondim] integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq @@ -509,7 +557,7 @@ subroutine wind_forcing_gyres(sfc_state, forces, day, G, US, CS) PI = 4.0*atan(1.0) - ! steady surface wind stresses [R L Z T-1 ~> Pa] + ! steady surface wind stresses [R L Z T-2 ~> Pa] do j=js-1,je+1 ; do I=is-1,Ieq y = (G%geoLatCu(I,j)-CS%South_lat) / CS%len_lat forces%taux(I,j) = CS%gyres_taux_const + & @@ -522,19 +570,18 @@ subroutine wind_forcing_gyres(sfc_state, forces, day, G, US, CS) enddo ; enddo ! set the friction velocity - if (CS%answers_2018) then - do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(US%L_to_Z * ((CS%gust_const/CS%Rho0) + & - sqrt(0.5*(forces%tauy(i,j-1)*forces%tauy(i,j-1) + forces%tauy(i,j)*forces%tauy(i,j) + & - forces%taux(i-1,j)*forces%taux(i-1,j) + forces%taux(i,j)*forces%taux(i,j)))/CS%Rho0) ) - enddo ; enddo + if (CS%answer_date < 20190101) then + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = CS%gust_const + US%L_to_Z * sqrt(0.5*(((forces%tauy(i,J-1)**2) + (forces%tauy(i,J)**2)) + & + ((forces%taux(I-1,j)**2) + (forces%taux(I,j)**2)))) + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + forces%ustar(i,j) = sqrt( (CS%gust_const/CS%Rho0) + & + US%L_to_Z * sqrt(0.5*((forces%tauy(i,J-1)**2) + (forces%tauy(i,J)**2) + & + (forces%taux(I-1,j)**2) + (forces%taux(I,j)**2)))/CS%Rho0 ) + enddo ; enddo ; endif else - I_rho = US%L_to_Z / CS%Rho0 - do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt( (CS%gust_const + & - sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & - (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) ) * I_rho ) - enddo ; enddo + call stresses_to_ustar(forces, G, US, CS) endif call callTree_leave("wind_forcing_gyres") @@ -554,11 +601,7 @@ subroutine Neverworld_wind_forcing(sfc_state, forces, day, G, US, CS) ! Local variables integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - real :: Pa_to_RLZ_T2 ! A unit conversion factor from Pa to the internal units - ! for wind stresses [R Z L T-2 Pa-1 ~> 1] real :: PI ! A common irrational number, 3.1415926535... [nondim] - real :: I_rho ! The inverse of the reference density times a ratio of scaling - ! factors [Z L-1 R-1 ~> m3 kg-1] real :: y ! The latitude relative to the south normalized by the domain extent [nondim] real :: tau_max ! The magnitude of the wind stress [R Z L T-2 ~> Pa] real :: off ! An offset in the relative latitude [nondim] @@ -577,9 +620,9 @@ subroutine Neverworld_wind_forcing(sfc_state, forces, day, G, US, CS) ! The i-loop extends to is-1 so that taux can be used later in the ! calculation of ustar - otherwise the lower bound would be Isq. PI = 4.0*atan(1.0) - Pa_to_RLZ_T2 = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z + forces%taux(:,:) = 0.0 - tau_max = 0.2 * Pa_to_RLZ_T2 + tau_max = CS%taux_mag off = 0.02 do j=js,je ; do I=is-1,Ieq y = (G%geoLatT(i,j)-G%south_lat)/G%len_lat @@ -601,14 +644,7 @@ subroutine Neverworld_wind_forcing(sfc_state, forces, day, G, US, CS) enddo ; enddo ! Set the surface friction velocity, in units of [Z T-1 ~> m s-1]. ustar is always positive. - if (associated(forces%ustar)) then - I_rho = US%L_to_Z / CS%Rho0 - do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt( (CS%gust_const + & - sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & - (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) ) * I_rho ) - enddo ; enddo - endif + if (associated(forces%ustar)) call stresses_to_ustar(forces, G, US, CS) end subroutine Neverworld_wind_forcing @@ -624,8 +660,6 @@ subroutine scurve_wind_forcing(sfc_state, forces, day, G, US, CS) !! a previous surface_forcing_init call ! Local variables integer :: i, j, kseg - real :: I_rho ! The inverse of the reference density times a ratio of scaling - ! factors [Z L-1 R-1 ~> m3 kg-1] real :: y_curve ! The latitude relative to the southern end of a curve segment [degreesN] real :: L_curve ! The latitudinal extent of a curve segment [degreesN] ! real :: ydata(7) = (/ -70., -45., -15., 0., 15., 45., 70. /) @@ -656,14 +690,7 @@ subroutine scurve_wind_forcing(sfc_state, forces, day, G, US, CS) enddo ; enddo ! Set the surface friction velocity, in units of [Z T-1 ~> m s-1]. ustar is always positive. - if (associated(forces%ustar)) then - I_rho = US%L_to_Z / CS%Rho0 - do j=G%jsc,G%jec ; do i=G%isc,G%iec - forces%ustar(i,j) = sqrt( (CS%gust_const + & - sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & - (forces%taux(I-1,j)**2 + forces%taux(I,j)**2))) ) * I_rho ) - enddo ; enddo - endif + if (associated(forces%ustar)) call stresses_to_ustar(forces, G, US, CS) end subroutine scurve_wind_forcing @@ -689,47 +716,20 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) !! a previous surface_forcing_init call ! Local variables character(len=200) :: filename ! The name of the input file. - real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal wind stresses at h-points [R L Z T-1 ~> Pa] - real :: temp_y(SZI_(G),SZJ_(G)) ! Pseudo-meridional wind stresses at h-points [R L Z T-1 ~> Pa] - real :: Pa_to_RLZ_T2 ! A unit conversion factor from Pa to the internal units - ! for wind stresses [R Z L T-2 Pa-1 ~> 1] - integer :: time_lev_daily ! The time levels to read for fields with - integer :: time_lev_monthly ! daily and monthly cycles. + real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal wind stresses at h-points [R L Z T-2 ~> Pa] + real :: temp_y(SZI_(G),SZJ_(G)) ! Pseudo-meridional wind stresses at h-points [R L Z T-2 ~> Pa] + real :: ustar_loc(SZI_(G),SZJ_(G)) ! The local value of ustar [Z T-1 ~> m s-1] + real :: tau_mag ! The magnitude of the wind stress including any contributions from + ! sub-gridscale variability or gustiness [R Z2 T-2 ~> Pa] integer :: time_lev ! The time level that is used for a field. - integer :: days, seconds integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq logical :: read_Ustar call callTree_enter("wind_forcing_from_file, MOM_surface_forcing.F90") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - Pa_to_RLZ_T2 = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z - - call get_time(day, seconds, days) - time_lev_daily = days - 365*floor(real(days) / 365.0) - - if (time_lev_daily < 31) then ; time_lev_monthly = 0 - elseif (time_lev_daily < 59) then ; time_lev_monthly = 1 - elseif (time_lev_daily < 90) then ; time_lev_monthly = 2 - elseif (time_lev_daily < 120) then ; time_lev_monthly = 3 - elseif (time_lev_daily < 151) then ; time_lev_monthly = 4 - elseif (time_lev_daily < 181) then ; time_lev_monthly = 5 - elseif (time_lev_daily < 212) then ; time_lev_monthly = 6 - elseif (time_lev_daily < 243) then ; time_lev_monthly = 7 - elseif (time_lev_daily < 273) then ; time_lev_monthly = 8 - elseif (time_lev_daily < 304) then ; time_lev_monthly = 9 - elseif (time_lev_daily < 334) then ; time_lev_monthly = 10 - else ; time_lev_monthly = 11 - endif - - time_lev_daily = time_lev_daily+1 - time_lev_monthly = time_lev_monthly+1 - select case (CS%wind_nlev) - case (12) ; time_lev = time_lev_monthly - case (365) ; time_lev = time_lev_daily - case default ; time_lev = 1 - end select + time_lev = get_file_time_level(day, CS%wind_nlev, CS%wind_days_per_rec) if (time_lev /= CS%wind_last_lev) then filename = trim(CS%wind_file) @@ -742,7 +742,7 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) temp_x(:,:) = 0.0 ; temp_y(:,:) = 0.0 call MOM_read_vector(filename, CS%stress_x_var, CS%stress_y_var, & temp_x(:,:), temp_y(:,:), G%Domain, stagger=AGRID, & - timelevel=time_lev, scale=Pa_to_RLZ_T2) + timelevel=time_lev, scale=US%Pa_to_RLZ_T2) call pass_vector(temp_x, temp_y, G%Domain, To_All, AGRID) do j=js,je ; do I=is-1,Ieq @@ -754,15 +754,21 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) if (.not.read_Ustar) then if (CS%read_gust_2d) then - do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt((CS%gust(i,j) + & - sqrt(temp_x(i,j)*temp_x(i,j) + temp_y(i,j)*temp_y(i,j))) * US%L_to_Z / CS%Rho0) - enddo ; enddo + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = CS%gust(i,j) + US%L_to_Z * sqrt((temp_x(i,j)**2) + (temp_y(i,j)**2)) + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + tau_mag = CS%gust(i,j) + US%L_to_Z * sqrt((temp_x(i,j)**2) + (temp_y(i,j)**2)) + forces%ustar(i,j) = sqrt(tau_mag / CS%Rho0) + enddo ; enddo ; endif else - do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(US%L_to_Z * (CS%gust_const/CS%Rho0 + & - sqrt(temp_x(i,j)*temp_x(i,j) + temp_y(i,j)*temp_y(i,j)) / CS%Rho0) ) - enddo ; enddo + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = CS%gust_const + US%L_to_Z * sqrt((temp_x(i,j)**2) + (temp_y(i,j)**2)) + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + forces%ustar(i,j) = sqrt( CS%gust_const/CS%Rho0 + & + US%L_to_Z * sqrt((temp_x(i,j)**2) + (temp_y(i,j)**2)) / CS%Rho0 ) + enddo ; enddo ; endif endif endif case ("C") @@ -776,7 +782,7 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) call MOM_read_vector(filename, CS%stress_x_var, CS%stress_y_var, & temp_x(:,:), temp_y(:,:), & G%Domain_aux, stagger=CGRID_NE, timelevel=time_lev, & - scale=Pa_to_RLZ_T2) + scale=US%Pa_to_RLZ_T2) do j=js,je ; do i=is,ie forces%taux(I,j) = CS%wind_scale * temp_x(I,j) forces%tauy(i,J) = CS%wind_scale * temp_y(i,J) @@ -786,7 +792,7 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) call MOM_read_vector(filename, CS%stress_x_var, CS%stress_y_var, & forces%taux(:,:), forces%tauy(:,:), & G%Domain, stagger=CGRID_NE, timelevel=time_lev, & - scale=Pa_to_RLZ_T2) + scale=US%Pa_to_RLZ_T2) if (CS%wind_scale /= 1.0) then do j=js,je ; do I=Isq,Ieq @@ -801,17 +807,28 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) call pass_vector(forces%taux, forces%tauy, G%Domain, To_All) if (.not.read_Ustar) then if (CS%read_gust_2d) then - do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt((CS%gust(i,j) + & - sqrt(0.5*((forces%tauy(i,j-1)**2 + forces%tauy(i,j)**2) + & - (forces%taux(i-1,j)**2 + forces%taux(i,j)**2))) ) * US%L_to_Z / CS%Rho0 ) - enddo ; enddo + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = CS%gust(i,j) + & + US%L_to_Z * sqrt(0.5*(((forces%tauy(i,J-1)**2) + (forces%tauy(i,J)**2)) + & + ((forces%taux(I-1,j)**2) + (forces%taux(I,j)**2)))) + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + tau_mag = CS%gust(i,j) + & + US%L_to_Z * sqrt(0.5*(((forces%tauy(i,J-1)**2) + (forces%tauy(i,J)**2)) + & + ((forces%taux(I-1,j)**2) + (forces%taux(I,j)**2)))) + forces%ustar(i,j) = sqrt( tau_mag / CS%Rho0 ) + enddo ; enddo ; endif else - do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt(US%L_to_Z * ( (CS%gust_const/CS%Rho0) + & - sqrt(0.5*((forces%tauy(i,j-1)**2 + forces%tauy(i,j)**2) + & - (forces%taux(i-1,j)**2 + forces%taux(i,j)**2)))/CS%Rho0)) - enddo ; enddo + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = CS%gust_const + & + US%L_to_Z * sqrt(0.5*(((forces%tauy(i,J-1)**2) + (forces%tauy(i,J)**2)) + & + ((forces%taux(I-1,j)**2) + (forces%taux(I,j)**2)))) + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + forces%ustar(i,j) = sqrt( CS%gust_const/CS%Rho0 + & + US%L_to_Z * sqrt(0.5*(((forces%tauy(i,J-1)**2) + (forces%tauy(i,J)**2)) + & + ((forces%taux(I-1,j)**2) + (forces%taux(I,j)**2))))/CS%Rho0 ) + enddo ; enddo ; endif endif endif case default @@ -820,8 +837,14 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) end select if (read_Ustar) then - call MOM_read_data(filename, CS%Ustar_var, forces%ustar(:,:), & + call MOM_read_data(filename, CS%Ustar_var, ustar_loc(:,:), & G%Domain, timelevel=time_lev, scale=US%m_to_Z*US%T_to_s) + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = CS%Rho0 * ustar_loc(i,j)**2 + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + forces%ustar(i,j) = ustar_loc(i,j) + enddo ; enddo ; endif endif CS%wind_last_lev = time_lev @@ -845,24 +868,24 @@ subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, US, CS) ! Local variables real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal wind stresses at h-points [R Z L T-2 ~> Pa]. real :: temp_y(SZI_(G),SZJ_(G)) ! Pseudo-meridional wind stresses at h-points [R Z L T-2 ~> Pa]. - real :: Pa_to_RLZ_T2 ! A unit conversion factor from Pa to the internal units - ! for wind stresses [R Z L T-2 Pa-1 ~> 1] + real :: ustar_prev(SZI_(G),SZJ_(G)) ! The pre-override value of ustar [Z T-1 ~> m s-1] + real :: ustar_loc(SZI_(G),SZJ_(G)) ! The value of ustar, perhaps altered by data override [Z T-1 ~> m s-1] + real :: tau_mag ! The magnitude of the wind stress including any contributions from + ! sub-gridscale variability or gustiness [R Z2 T-2 ~> Pa] integer :: i, j call callTree_enter("wind_forcing_by_data_override, MOM_surface_forcing.F90") if (.not.CS%dataOverrideIsInitialized) then - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.not.CS%nonBous, press=.true., tau_mag=CS%nonBous) call data_override_init(G%Domain) CS%dataOverrideIsInitialized = .True. endif - Pa_to_RLZ_T2 = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z - temp_x(:,:) = 0.0 ; temp_y(:,:) = 0.0 ! CS%wind_scale is ignored here because it is not set in this mode. - call data_override(G%Domain, 'taux', temp_x, day, scale=Pa_to_RLZ_T2) - call data_override(G%Domain, 'tauy', temp_y, day, scale=Pa_to_RLZ_T2) + call data_override(G%Domain, 'taux', temp_x, day, scale=US%Pa_to_RLZ_T2) + call data_override(G%Domain, 'tauy', temp_y, day, scale=US%Pa_to_RLZ_T2) call pass_vector(temp_x, temp_y, G%Domain, To_All, AGRID) do j=G%jsc,G%jec ; do I=G%isc-1,G%IecB forces%taux(I,j) = 0.5 * (temp_x(i,j) + temp_x(i+1,j)) @@ -872,25 +895,91 @@ subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, US, CS) enddo ; enddo if (CS%read_gust_2d) then - call data_override(G%Domain, 'gust', CS%gust, day, scale=Pa_to_RLZ_T2) + call data_override(G%Domain, 'gust', CS%gust, day, scale=US%Pa_to_RLZ_T2*US%L_to_Z) + if (associated(forces%tau_mag)) then ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + forces%tau_mag(i,j) = US%L_to_Z * sqrt((temp_x(i,j)**2) + (temp_y(i,j)**2)) + CS%gust(i,j) + enddo ; enddo ; endif do j=G%jsc,G%jec ; do i=G%isc,G%iec - forces%ustar(i,j) = sqrt((sqrt(temp_x(i,j)**2 + temp_y(i,j)**2) + & - CS%gust(i,j)) * US%L_to_Z / CS%Rho0) + tau_mag = US%L_to_Z * sqrt((temp_x(i,j)**2) + (temp_y(i,j)**2)) + CS%gust(i,j) + ustar_loc(i,j) = sqrt( tau_mag / CS%Rho0 ) enddo ; enddo else + if (associated(forces%tau_mag)) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + forces%tau_mag(i,j) = US%L_to_Z * sqrt((temp_x(i,j)**2) + (temp_y(i,j)**2)) + CS%gust_const + ! ustar_loc(i,j) = sqrt( forces%tau_mag(i,j) / CS%Rho0 ) + enddo ; enddo + endif do j=G%jsc,G%jec ; do i=G%isc,G%iec - forces%ustar(i,j) = sqrt(US%L_to_Z * (sqrt(temp_x(i,j)**2 + temp_y(i,j)**2)/CS%Rho0 + & - CS%gust_const/CS%Rho0)) + ustar_loc(i,j) = sqrt(US%L_to_Z * sqrt((temp_x(i,j)**2) + (temp_y(i,j)**2))/CS%Rho0 + & + CS%gust_const/CS%Rho0) enddo ; enddo endif + ! Give the data override the option to modify the newly calculated forces%ustar. - call data_override(G%Domain, 'ustar', forces%ustar, day, scale=US%m_to_Z*US%T_to_s) + ustar_prev(:,:) = ustar_loc(:,:) + call data_override(G%Domain, 'ustar', ustar_loc, day, scale=US%m_to_Z*US%T_to_s) + + ! Only reset values where data override of ustar has occurred + if (associated(forces%tau_mag)) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (ustar_prev(i,j) /= ustar_loc(i,j)) then + forces%tau_mag(i,j) = CS%Rho0 * ustar_loc(i,j)**2 + endif ; enddo ; enddo + endif + + if (associated(forces%ustar)) then ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + forces%ustar(i,j) = ustar_loc(i,j) + enddo ; enddo ; endif call pass_vector(forces%taux, forces%tauy, G%Domain, To_All) call callTree_leave("wind_forcing_by_data_override") end subroutine wind_forcing_by_data_override +!> Translate the wind stresses into the friction velocity, including effects of background gustiness. +subroutine stresses_to_ustar(forces, G, US, CS) + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by + !! a previous surface_forcing_init call + ! Local variables + real :: I_rho ! The inverse of the Boussinesq reference density [R-1 ~> m3 kg-1] + real :: tau_mag ! The magnitude of the wind stress including any contributions from + ! sub-gridscale variability or gustiness [R Z2 T-2 ~> Pa] + integer :: i, j, is, ie, js, je + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + I_rho = 1.0 / CS%Rho0 + + if (CS%read_gust_2d) then + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = CS%gust(i,j) + & + US%L_to_Z * sqrt(0.5*(((forces%tauy(i,J-1)**2) + (forces%tauy(i,J)**2)) + & + ((forces%taux(I-1,j)**2) + (forces%taux(I,j)**2)))) + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + tau_mag = CS%gust(i,j) + & + US%L_to_Z * sqrt(0.5*(((forces%tauy(i,J-1)**2) + (forces%tauy(i,J)**2)) + & + ((forces%taux(I-1,j)**2) + (forces%taux(I,j)**2)))) + forces%ustar(i,j) = sqrt( tau_mag * I_rho ) + enddo ; enddo ; endif + else + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = CS%gust_const + & + US%L_to_Z * sqrt(0.5*(((forces%tauy(i,J-1)**2) + (forces%tauy(i,J)**2)) + & + ((forces%taux(I-1,j)**2) + (forces%taux(I,j)**2)))) + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + tau_mag = CS%gust_const + & + US%L_to_Z * sqrt(0.5*(((forces%tauy(i,J-1)**2) + (forces%tauy(i,J)**2)) + & + ((forces%taux(I-1,j)**2) + (forces%taux(I,j)**2)))) + forces%ustar(i,j) = sqrt( tau_mag * I_rho ) + enddo ; enddo ; endif + endif + +end subroutine stresses_to_ustar !> Specifies zero surface buoyancy fluxes from input files. subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) @@ -910,57 +999,31 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) ! [R Z T-1 ~> kg m-2 s-1] !#CTRL# real, dimension(SZI_(G),SZJ_(G)) :: & !#CTRL# SST_anom, & ! Instantaneous sea surface temperature anomalies from a -!#CTRL# ! target (observed) value [degC]. +!#CTRL# ! target (observed) value [C ~> degC]. !#CTRL# SSS_anom, & ! Instantaneous sea surface salinity anomalies from a target -!#CTRL# ! (observed) value [ppt]. +!#CTRL# ! (observed) value [S ~> ppt]. !#CTRL# SSS_mean ! A (mean?) salinity about which to normalize local salinity -!#CTRL# ! anomalies when calculating restorative precipitation anomalies [ppt]. +!#CTRL# ! anomalies when calculating restorative precipitation anomalies [S ~> ppt]. - real :: rhoXcp ! reference density times heat capacity [Q R degC-1 ~> J m-3 degC-1] + real :: rhoXcp ! reference density times heat capacity [Q R C-1 ~> J m-3 degC-1] - integer :: time_lev_daily ! time levels to read for fields with daily cycle - integer :: time_lev_monthly ! time levels to read for fields with monthly cycle + logical :: fluxes_changed ! True if any of the fluxes might have been altered integer :: time_lev ! time level that for a field - integer :: days, seconds integer :: i, j, is, ie, js, je call callTree_enter("buoyancy_forcing_from_files, MOM_surface_forcing.F90") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - if (CS%use_temperature) rhoXcp = CS%Rho0 * fluxes%C_p + if (CS%use_temperature) rhoXcp = CS%rho_restore * fluxes%C_p ! Read the buoyancy forcing file - call get_time(day, seconds, days) - - time_lev_daily = days - 365*floor(real(days) / 365.0) - - if (time_lev_daily < 31) then ; time_lev_monthly = 0 - elseif (time_lev_daily < 59) then ; time_lev_monthly = 1 - elseif (time_lev_daily < 90) then ; time_lev_monthly = 2 - elseif (time_lev_daily < 120) then ; time_lev_monthly = 3 - elseif (time_lev_daily < 151) then ; time_lev_monthly = 4 - elseif (time_lev_daily < 181) then ; time_lev_monthly = 5 - elseif (time_lev_daily < 212) then ; time_lev_monthly = 6 - elseif (time_lev_daily < 243) then ; time_lev_monthly = 7 - elseif (time_lev_daily < 273) then ; time_lev_monthly = 8 - elseif (time_lev_daily < 304) then ; time_lev_monthly = 9 - elseif (time_lev_daily < 334) then ; time_lev_monthly = 10 - else ; time_lev_monthly = 11 - endif - - time_lev_daily = time_lev_daily +1 - time_lev_monthly = time_lev_monthly+1 - - if (time_lev_daily /= CS%buoy_last_lev_read) then + fluxes_changed = .false. - ! longwave - select case (CS%LW_nlev) - case (12) ; time_lev = time_lev_monthly - case (365) ; time_lev = time_lev_daily - case default ; time_lev = 1 - end select + ! longwave + time_lev = get_file_time_level(day, CS%LW_nlev, CS%LW_days_per_rec) + if (time_lev /= CS%LW_last_lev) then call MOM_read_data(CS%longwave_file, CS%LW_var, fluxes%lw(:,:), & G%Domain, timelevel=time_lev, scale=US%W_m2_to_QRZ_T) if (CS%archaic_OMIP_file) then @@ -968,14 +1031,13 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) timelevel=time_lev, scale=US%W_m2_to_QRZ_T) do j=js,je ; do i=is,ie ; fluxes%LW(i,j) = fluxes%LW(i,j) - temp(i,j) ; enddo ; enddo endif - CS%LW_last_lev = time_lev + CS%LW_last_lev = time_lev ; fluxes_changed = .true. + endif - ! evaporation - select case (CS%evap_nlev) - case (12) ; time_lev = time_lev_monthly - case (365) ; time_lev = time_lev_daily - case default ; time_lev = 1 - end select + ! evaporation + if ( (CS%evap_nlev /= CS%LW_nlev) .or. (CS%evap_days_per_rec /= CS%LW_days_per_rec) ) & + time_lev = get_file_time_level(day, CS%evap_nlev, CS%evap_days_per_rec) + if (time_lev /= CS%evap_last_lev) then if (CS%archaic_OMIP_file) then call MOM_read_data(CS%evaporation_file, CS%evap_var, fluxes%evap(:,:), & G%Domain, timelevel=time_lev, scale=-US%kg_m2s_to_RZ_T) @@ -987,13 +1049,12 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) call MOM_read_data(CS%evaporation_file, CS%evap_var, fluxes%evap(:,:), & G%Domain, timelevel=time_lev, scale=US%kg_m2s_to_RZ_T) endif - CS%evap_last_lev = time_lev + CS%evap_last_lev = time_lev ; fluxes_changed = .true. + endif - select case (CS%latent_nlev) - case (12) ; time_lev = time_lev_monthly - case (365) ; time_lev = time_lev_daily - case default ; time_lev = 1 - end select + if ( (CS%latent_nlev /= CS%evap_nlev) .or. (CS%latent_days_per_rec /= CS%evap_days_per_rec) ) & + time_lev = get_file_time_level(day, CS%latent_nlev, CS%latent_days_per_rec) + if (time_lev /= CS%latent_last_lev) then if (.not.CS%archaic_OMIP_file) then call MOM_read_data(CS%latentheat_file, CS%latent_var, fluxes%latent(:,:), & G%Domain, timelevel=time_lev, scale=US%W_m2_to_QRZ_T) @@ -1001,13 +1062,12 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) enddo ; enddo endif - CS%latent_last_lev = time_lev + CS%latent_last_lev = time_lev ; fluxes_changed = .true. + endif - select case (CS%sens_nlev) - case (12) ; time_lev = time_lev_monthly - case (365) ; time_lev = time_lev_daily - case default ; time_lev = 1 - end select + if ( (CS%sens_nlev /= CS%latent_nlev) .or. (CS%sens_days_per_rec /= CS%latent_days_per_rec) ) & + time_lev = get_file_time_level(day, CS%sens_nlev, CS%sens_days_per_rec) + if (time_lev /= CS%sens_last_lev) then if (CS%archaic_OMIP_file) then call MOM_read_data(CS%sensibleheat_file, CS%sens_var, fluxes%sens(:,:), & G%Domain, timelevel=time_lev, scale=-US%W_m2_to_QRZ_T) @@ -1015,13 +1075,12 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) call MOM_read_data(CS%sensibleheat_file, CS%sens_var, fluxes%sens(:,:), & G%Domain, timelevel=time_lev, scale=US%W_m2_to_QRZ_T) endif - CS%sens_last_lev = time_lev + CS%sens_last_lev = time_lev ; fluxes_changed = .true. + endif - select case (CS%SW_nlev) - case (12) ; time_lev = time_lev_monthly - case (365) ; time_lev = time_lev_daily - case default ; time_lev = 1 - end select + if ( (CS%SW_nlev /= CS%sens_nlev) .or. (CS%SW_days_per_rec /= CS%sens_days_per_rec) ) & + time_lev = get_file_time_level(day, CS%SW_nlev, CS%SW_days_per_rec) + if (time_lev /= CS%SW_last_lev) then call MOM_read_data(CS%shortwave_file, CS%SW_var, fluxes%sw(:,:), G%Domain, & timelevel=time_lev, scale=US%W_m2_to_QRZ_T) if (CS%archaic_OMIP_file) then @@ -1031,13 +1090,12 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) fluxes%sw(i,j) = fluxes%sw(i,j) - temp(i,j) enddo ; enddo endif - CS%SW_last_lev = time_lev + CS%SW_last_lev = time_lev ; fluxes_changed = .true. + endif - select case (CS%precip_nlev) - case (12) ; time_lev = time_lev_monthly - case (365) ; time_lev = time_lev_daily - case default ; time_lev = 1 - end select + if ( (CS%precip_nlev /= CS%SW_nlev) .or. (CS%precip_days_per_rec /= CS%SW_days_per_rec) ) & + time_lev = get_file_time_level(day, CS%precip_nlev, CS%precip_days_per_rec) + if (time_lev /= CS%precip_last_lev) then call MOM_read_data(CS%snow_file, CS%snow_var, & fluxes%fprec(:,:), G%Domain, timelevel=time_lev, scale=US%kg_m2s_to_RZ_T) call MOM_read_data(CS%rain_file, CS%rain_var, & @@ -1047,13 +1105,12 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) fluxes%lprec(i,j) = fluxes%lprec(i,j) - fluxes%fprec(i,j) enddo ; enddo endif - CS%precip_last_lev = time_lev + CS%precip_last_lev = time_lev ; fluxes_changed = .true. + endif - select case (CS%runoff_nlev) - case (12) ; time_lev = time_lev_monthly - case (365) ; time_lev = time_lev_daily - case default ; time_lev = 1 - end select + if ( (CS%runoff_nlev /= CS%precip_nlev) .or. (CS%runoff_days_per_rec /= CS%precip_days_per_rec) ) & + time_lev = get_file_time_level(day, CS%runoff_nlev, CS%runoff_days_per_rec) + if (time_lev /= CS%runoff_last_lev) then if (CS%archaic_OMIP_file) then call MOM_read_data(CS%runoff_file, CS%lrunoff_var, temp(:,:), & G%Domain, timelevel=time_lev, scale=US%kg_m2s_to_RZ_T*US%m_to_L**2) @@ -1071,30 +1128,28 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) call MOM_read_data(CS%runoff_file, CS%frunoff_var, fluxes%frunoff(:,:), & G%Domain, timelevel=time_lev, scale=US%kg_m2s_to_RZ_T) endif - CS%runoff_last_lev = time_lev + CS%runoff_last_lev = time_lev ; fluxes_changed = .true. + endif -! Read the SST and SSS fields for damping. - if (CS%restorebuoy) then !#CTRL# .or. associated(CS%ctrl_forcing_CSp)) then - select case (CS%SST_nlev) - case (12) ; time_lev = time_lev_monthly - case (365) ; time_lev = time_lev_daily - case default ; time_lev = 1 - end select + ! Read the SST and SSS fields for damping. + if (CS%restorebuoy) then !#CTRL# .or. associated(CS%ctrl_forcing_CSp)) then + time_lev = get_file_time_level(day, CS%SST_nlev, CS%SST_days_per_rec) + if (time_lev /= CS%SST_last_lev) then call MOM_read_data(CS%SSTrestore_file, CS%SST_restore_var, & - CS%T_Restore(:,:), G%Domain, timelevel=time_lev) + CS%T_Restore(:,:), G%Domain, timelevel=time_lev, scale=US%degC_to_C) CS%SST_last_lev = time_lev + endif - select case (CS%SSS_nlev) - case (12) ; time_lev = time_lev_monthly - case (365) ; time_lev = time_lev_daily - case default ; time_lev = 1 - end select + if ( (CS%SSS_nlev /= CS%SST_nlev) .or. (CS%SSS_days_per_rec /= CS%SST_days_per_rec) ) & + time_lev = get_file_time_level(day, CS%SSS_nlev, CS%SSS_days_per_rec) + if (time_lev /= CS%SSS_last_lev) then call MOM_read_data(CS%salinityrestore_file, CS%SSS_restore_var, & - CS%S_Restore(:,:), G%Domain, timelevel=time_lev) + CS%S_Restore(:,:), G%Domain, timelevel=time_lev, scale=US%ppt_to_S) CS%SSS_last_lev = time_lev endif - CS%buoy_last_lev_read = time_lev_daily + endif + if (fluxes_changed) then ! mask out land points and compute heat content of water fluxes ! assume liquid precipitation enters ocean at SST ! assume frozen precipitation enters ocean at 0degC @@ -1116,8 +1171,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) fluxes%latent_fprec_diag(i,j) = -fluxes%fprec(i,j)*CS%latent_heat_fusion fluxes%latent_frunoff_diag(i,j) = -fluxes%frunoff(i,j)*CS%latent_heat_fusion enddo ; enddo - - endif ! time_lev /= CS%buoy_last_lev_read + endif ! fluxes have changed and need to be masked ! restoring surface boundary fluxes @@ -1125,10 +1179,10 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) if (CS%use_temperature) then do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const_T) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const_S) * & + fluxes%vprec(i,j) = - (CS%rho_restore*CS%Flux_const_S) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) else @@ -1138,9 +1192,9 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) enddo ; enddo else do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - (CS%G_Earth * CS%Flux_const / CS%Rho0) + (CS%G_Earth * CS%Flux_const / CS%rho_restore) else fluxes%buoy(i,j) = 0.0 endif @@ -1183,12 +1237,12 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US ! Local variables !#CTRL# real, dimension(SZI_(G),SZJ_(G)) :: & !#CTRL# SST_anom, & ! Instantaneous sea surface temperature anomalies from a -!#CTRL# ! target (observed) value [degC]. +!#CTRL# ! target (observed) value [C ~> degC]. !#CTRL# SSS_anom, & ! Instantaneous sea surface salinity anomalies from a target -!#CTRL# ! (observed) value [ppt]. +!#CTRL# ! (observed) value [S ~> ppt]. !#CTRL# SSS_mean ! A (mean?) salinity about which to normalize local salinity -!#CTRL# ! anomalies when calculating restorative precipitation anomalies [ppt]. - real :: rhoXcp ! The mean density times the heat capacity [Q R degC-1 ~> J m-3 degC-1]. +!#CTRL# ! anomalies when calculating restorative precipitation anomalies [S ~> ppt]. + real :: rhoXcp ! The mean density times the heat capacity [Q R C-1 ~> J m-3 degC-1]. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed call callTree_enter("buoyancy_forcing_from_data_override, MOM_surface_forcing.F90") @@ -1196,7 +1250,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - if (CS%use_temperature) rhoXcp = CS%Rho0 * fluxes%C_p + if (CS%use_temperature) rhoXcp = CS%rho_restore * fluxes%C_p if (.not.CS%dataOverrideIsInitialized) then call data_override_init(G%Domain) @@ -1223,18 +1277,18 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US ! Read the SST and SSS fields for damping. if (CS%restorebuoy) then !#CTRL# .or. associated(CS%ctrl_forcing_CSp)) then - call data_override(G%Domain, 'SST_restore', CS%T_restore, day) - call data_override(G%Domain, 'SSS_restore', CS%S_restore, day) + call data_override(G%Domain, 'SST_restore', CS%T_restore, day, scale=US%degC_to_C) + call data_override(G%Domain, 'SSS_restore', CS%S_restore, day, scale=US%ppt_to_S) endif ! restoring boundary fluxes if (CS%restorebuoy) then if (CS%use_temperature) then do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const_T) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const_S) * & + fluxes%vprec(i,j) = - (CS%rho_restore*CS%Flux_const_S) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) else @@ -1244,9 +1298,9 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US enddo ; enddo else do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - (CS%G_Earth * CS%Flux_const / CS%Rho0) + (CS%G_Earth * CS%Flux_const / CS%rho_restore) else fluxes%buoy(i,j) = 0.0 endif @@ -1289,7 +1343,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US !#CTRL# SSS_mean(i,j) = 0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j)) !#CTRL# enddo ; enddo !#CTRL# call apply_ctrl_forcing(SST_anom, SSS_anom, SSS_mean, fluxes%heat_added, & -!#CTRL# fluxes%vprec, day, US%T_to_s*dt, G, US, CS%ctrl_forcing_CSp) +!#CTRL# fluxes%vprec, day, dt, G, US, CS%ctrl_forcing_CSp) !#CTRL# endif call callTree_leave("buoyancy_forcing_from_data_override") @@ -1395,8 +1449,8 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) !! a previous surface_forcing_init call ! Local variables real :: y ! The latitude relative to the south normalized by the domain extent [nondim] - real :: T_restore ! The temperature towards which to restore [degC] - real :: S_restore ! The salinity towards which to restore [ppt] + real :: T_restore ! The temperature towards which to restore [C ~> degC] + real :: S_restore ! The salinity towards which to restore [S ~> ppt] integer :: i, j, is, ie, js, je call callTree_enter("buoyancy_forcing_linear, MOM_surface_forcing.F90") @@ -1431,10 +1485,10 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) y = (G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat T_restore = CS%T_south + (CS%T_north-CS%T_south)*y S_restore = CS%S_south + (CS%S_north-CS%S_south)*y - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & - ((T_Restore - sfc_state%SST(i,j)) * ((CS%Rho0 * fluxes%C_p) * CS%Flux_const)) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & + ((T_Restore - sfc_state%SST(i,j)) * ((CS%rho_restore * fluxes%C_p) * CS%Flux_const)) + fluxes%vprec(i,j) = - (CS%rho_restore*CS%Flux_const) * & (S_Restore - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + S_Restore)) else @@ -1446,9 +1500,9 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) call MOM_error(FATAL, "buoyancy_forcing_linear in MOM_surface_forcing: "// & "RESTOREBUOY to linear not written yet.") !do j=js,je ; do i=is,ie - ! if (G%mask2dT(i,j) > 0) then + ! if (G%mask2dT(i,j) > 0.0) then ! fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - ! (CS%G_Earth * CS%Flux_const / CS%Rho0) + ! (CS%G_Earth * CS%Flux_const / CS%rho_restore) ! else ! fluxes%buoy(i,j) = 0.0 ! endif @@ -1464,6 +1518,147 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) call callTree_leave("buoyancy_forcing_linear") end subroutine buoyancy_forcing_linear +!> Return a time record to read from a file based on the model time, the number of time records in +!! that file and the number of time records per model day. +function get_file_time_level(Time, nlev_file, days_per_rec) result (time_lev) + type(time_type), intent(in) :: Time !< The time of the fluxes + integer , intent(in) :: nlev_file !< The number of time records in a forcing file + integer , intent(in) :: days_per_rec !< If positive, the number of days spanned by each + !! time record in a file, if negative the number + !! time records per day, or if 0 determine this + !! by guessing based on the number of records in + !! the file. If this is 31, the time levels will + !! be based on the months of the calendar. + !! Setting this larger than 1000000 will always + !! cause the time level to be set to 1. + integer :: time_lev !< The time level in a file that will be read. + + ! Local variables + integer :: days, seconds ! The number of days and seconds since the start of the calendar + integer :: year, month, day, hour, minute, second ! The components of the model time + integer :: recs_per_day ! The number of file time records per day + integer :: recs ! The number of time levels into the file to read without + ! taking the periodicity of the file into account. + + if ( (days_per_rec >= 1000000) .or. & + ( (days_per_rec == 0) .and. .not.((nlev_file == 12) .or. (nlev_file == 365)) ) ) then + ! The second condition above is to recreate the existing behavior, but it should perhaps be + ! phased out. + time_lev = 1 + elseif ( (days_per_rec == 31) .or. ((days_per_rec == 0) .and. (nlev_file == 12)) ) then + call get_date(Time, year, month, day, hour, minute, second) + time_lev = month + else + call get_time(Time, seconds, days) + if ( (days_per_rec == 0) .or. (abs(days_per_rec) == 1) ) then + recs = days + elseif (days_per_rec < 0) then + recs_per_day = -days_per_rec + recs = days * recs_per_day + ( (recs_per_day*set_time(seconds, 0)) / set_time(0, 1) ) + ! When integer rounding in the time-type arithmetic is considered, the line above is equivalent to: + ! seconds_per_day = set_time(0, 1) / set_time(1, 0) + ! recs = days * recs_per_day + floor(real(recs_per_day*seconds) / real(seconds_per_day)) + else + recs = days / days_per_rec + endif + time_lev = recs - nlev_file*floor(real(recs) / real(nlev_file)) + 1 + endif + +end function get_file_time_level + +!> Sets the necessary MARBL forcings via the data override facility. +subroutine MARBL_forcing_from_data_override(fluxes, day, G, US, CS) + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< The time of the fluxes + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by + !! a previous surface_forcing_init call + ! Local variables + real, pointer, dimension(:,:) :: atm_co2_prog =>NULL() !< Prognostic atmospheric CO2 concentration [ppm] + real, pointer, dimension(:,:) :: atm_co2_diag =>NULL() !< Diagnostic atmospheric CO2 concentration [ppm] + real, pointer, dimension(:,:) :: atm_fine_dust_flux =>NULL() !< Fine dust flux from atmosphere + !! [R Z T-1 ~> kg m-2 s-1] + real, pointer, dimension(:,:) :: atm_coarse_dust_flux =>NULL() !< Coarse dust flux from atmosphere + !! [R Z T-1 ~> kg m-2 s-1] + real, pointer, dimension(:,:) :: seaice_dust_flux =>NULL() !< Dust flux from seaice + !! [R Z T-1 ~> kg m-2 s-1] + real, pointer, dimension(:,:) :: atm_bc_flux =>NULL() !< Black carbon flux from atmosphere + !! [R Z T-1 ~> kg m-2 s-1] + real, pointer, dimension(:,:) :: seaice_bc_flux =>NULL() !< Black carbon flux from seaice + !! [R Z T-1 ~> kg m-2 s-1] + real, pointer, dimension(:,:) :: nhx_dep =>NULL() !< Nitrogen deposition + !! [R Z T-1 ~> kg m-2 s-1] + real, pointer, dimension(:,:) :: noy_dep =>NULL() !< Nitrogen deposition + !! [R Z T-1 ~> kg m-2 s-1] + integer :: isc, iec, jsc, jec + + ! Necessary null pointers for arguments to convert_driver_fields_to_forcings() + ! Since they are null, MARBL will not use multiple ice categories + real, pointer, dimension(:,:) :: afracr =>NULL() + real, pointer, dimension(:,:) :: swnet_afracr =>NULL() + real, pointer, dimension(:,:,:) :: swpen_ifrac_n =>NULL() + real, pointer, dimension(:,:,:) :: ifrac_n =>NULL() + + call callTree_enter("MARBL_forcing_from_data_override, MOM_surface_forcing.F90") + + if (.not.CS%dataOverrideIsInitialized) then + call data_override_init(G%Domain) + CS%dataOverrideIsInitialized = .True. + endif + + ! Allocate memory for pointers + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + allocate ( atm_co2_prog (isc:iec,jsc:jec), & + atm_co2_diag (isc:iec,jsc:jec), & + atm_fine_dust_flux (isc:iec,jsc:jec), & + atm_coarse_dust_flux (isc:iec,jsc:jec), & + seaice_dust_flux (isc:iec,jsc:jec), & + atm_bc_flux (isc:iec,jsc:jec), & + seaice_bc_flux (isc:iec,jsc:jec), & + nhx_dep (isc:iec,jsc:jec), & + noy_dep (isc:iec,jsc:jec), & + source=0.0) + + + ! fluxes used directly as MARBL inputs + ! (should be scaled) + call data_override(G%Domain, 'ice_fraction', fluxes%ice_fraction, day) + call data_override(G%Domain, 'u10_sqr', fluxes%u10_sqr, day, scale=US%m_s_to_L_T**2) + + ! fluxes used to compute MARBL inputs + ! These are kept in physical units, and will be scaled appropriately in + ! convert_driver_fields_to_forcings() + call data_override(G%Domain, 'atm_co2_prog', atm_co2_prog, day) + call data_override(G%Domain, 'atm_co2_diag', atm_co2_diag, day) + call data_override(G%Domain, 'atm_fine_dust_flux', atm_fine_dust_flux, day) + call data_override(G%Domain, 'atm_coarse_dust_flux', atm_coarse_dust_flux, day) + call data_override(G%Domain, 'atm_bc_flux', atm_bc_flux, day) + call data_override(G%Domain, 'seaice_dust_flux', seaice_dust_flux, day) + call data_override(G%Domain, 'seaice_bc_flux', seaice_bc_flux, day) + call data_override(G%Domain, 'nhx_dep', nhx_dep, day) + call data_override(G%Domain, 'noy_dep', noy_dep, day) + + call convert_driver_fields_to_forcings(atm_fine_dust_flux, atm_coarse_dust_flux, & + seaice_dust_flux, atm_bc_flux, seaice_bc_flux, & + nhx_dep, noy_dep, atm_co2_prog, atm_co2_diag, & + afracr, swnet_afracr, ifrac_n, swpen_ifrac_n, & + day, G, US, 0, 0, fluxes, CS%marbl_forcing_CSp) + + deallocate ( atm_co2_prog, & + atm_co2_diag, & + atm_fine_dust_flux, & + atm_coarse_dust_flux, & + seaice_dust_flux, & + atm_bc_flux, & + seaice_bc_flux, & + nhx_dep, & + noy_dep) + + call callTree_leave("MARBL_forcing_from_data_override") + +end subroutine MARBL_forcing_from_data_override + !> Save a restart file for the forcing fields subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & filename_suffix) @@ -1502,9 +1697,12 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C ! This include declares and sets the variable "version". # include "version_variable.h" real :: flux_const_default ! The unscaled value of FLUXCONST [m day-1] - real :: Pa_to_RLZ_T2 ! A unit conversion factor from Pa to the internal units - ! for wind stresses [R Z L T-2 Pa-1 ~> 1] - logical :: default_2018_answers + logical :: Boussinesq ! If true, this run is fully Boussinesq + logical :: semi_Boussinesq ! If true, this run is partially non-Boussinesq + logical :: fix_ustar_gustless_bug ! If false, include a bug using an older run-time parameter. + logical :: test_value ! This is used to determine whether a logical parameter is being set explicitly. + logical :: explicit_bug, explicit_fix ! These indicate which parameters are set explicitly. + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. character(len=40) :: mdl = "MOM_surface_forcing" ! This module's name. character(len=200) :: filename, gust_file ! The name of the gustiness input file. @@ -1521,13 +1719,19 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C CS%diag => diag if (associated(tracer_flow_CSp)) CS%tracer_flow_CSp => tracer_flow_CSp - Pa_to_RLZ_T2 = US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z - ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, '') call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) + call get_param(param_file, "MOM", "BOUSSINESQ", Boussinesq, & + "If true, make the Boussinesq approximation.", default=.true., do_not_log=.true.) + call get_param(param_file, "MOM", "SEMI_BOUSSINESQ", semi_Boussinesq, & + "If true, do non-Boussinesq pressure force calculations and use mass-based "//& + "thicknesses, but use RHO_0 to convert layer thicknesses into certain "//& + "height changes. This only applies if BOUSSINESQ is false.", & + default=.true., do_not_log=.true.) + CS%nonBous = .not.(Boussinesq .or. semi_Boussinesq) call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, & "The directory in which all input files are found.", & default=".") @@ -1545,6 +1749,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "If true, the buoyancy forcing varies in time after the "//& "initialization of the model.", default=.true.) + ! Determine parameters related to the buoyancy forcing. call get_param(param_file, mdl, "BUOY_CONFIG", CS%buoy_config, & "The character string that indicates how buoyancy forcing is specified. Valid "//& "options include (file), (data_override), (zero), (const), (linear), (MESO), "//& @@ -1586,9 +1791,9 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C ! These variable names are hard-coded, per the archaic OMIP conventions. CS%latentheat_file = CS%evaporation_file ; CS%latent_var = "evap" - CS%LW_var = "lwdn_sfc"; CS%SW_var = "swdn_sfc"; CS%sens_var = "shflx" - CS%evap_var = "evap"; CS%rain_var = "precip"; CS%snow_var = "snow" - CS%lrunoff_var = "disch_w"; CS%frunoff_var = "disch_s" + CS%LW_var = "lwdn_sfc" ; CS%SW_var = "swdn_sfc" ; CS%sens_var = "shflx" + CS%evap_var = "evap" ; CS%rain_var = "precip" ; CS%snow_var = "snow" + CS%lrunoff_var = "disch_w" ; CS%frunoff_var = "disch_s" else call get_param(param_file, mdl, "LONGWAVE_FILE", CS%longwave_file, & @@ -1596,12 +1801,22 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "given by LONGWAVE_FORCING_VAR.", fail_if_missing=.true.) call get_param(param_file, mdl, "LONGWAVE_FORCING_VAR", CS%LW_var, & "The variable with the longwave forcing field.", default="LW") + call get_param(param_file, mdl, "LONGWAVE_FILE_DAYS_PER_RECORD", CS%LW_days_per_rec, & + "If positive the number of days of longwave fluxes per time level in LONGWAVE_FILE, "//& + "or if negative the number of time levels per day. If 31 change forcing monthly, "//& + "or if 0 the model will guess the right value based on the file size.", & + default=0) call get_param(param_file, mdl, "SHORTWAVE_FILE", CS%shortwave_file, & "The file with the shortwave heat flux, in the variable "//& "given by SHORTWAVE_FORCING_VAR.", fail_if_missing=.true.) call get_param(param_file, mdl, "SHORTWAVE_FORCING_VAR", CS%SW_var, & "The variable with the shortwave forcing field.", default="SW") + call get_param(param_file, mdl, "SHORTWAVE_FILE_DAYS_PER_RECORD", CS%SW_days_per_rec, & + "If positive the number of days of shortwave fluxes per time level in SHORTWAVE_FILE, "//& + "or if negative the number of time levels per day. If 31 change forcing monthly, "//& + "or if 0 the model will guess the right value based on the file size.", & + default=CS%LW_days_per_rec) call get_param(param_file, mdl, "EVAPORATION_FILE", CS%evaporation_file, & "The file with the evaporative moisture flux, in the "//& @@ -1609,18 +1824,33 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "EVAP_FORCING_VAR", CS%evap_var, & "The variable with the evaporative moisture flux.", & default="evap") + call get_param(param_file, mdl, "EVAPORATION_FILE_DAYS_PER_RECORD", CS%evap_days_per_rec, & + "If positive the number of days of evaporation per time level in EVAPORATION_FILE, "//& + "or if negative the number of time levels per day. If 31 change forcing monthly, "//& + "or if 0 the model will guess the right value based on the file size.", & + default=CS%LW_days_per_rec) call get_param(param_file, mdl, "LATENTHEAT_FILE", CS%latentheat_file, & "The file with the latent heat flux, in the variable "//& "given by LATENT_FORCING_VAR.", fail_if_missing=.true.) call get_param(param_file, mdl, "LATENT_FORCING_VAR", CS%latent_var, & "The variable with the latent heat flux.", default="latent") + call get_param(param_file, mdl, "LATENTHEAT_FILE_DAYS_PER_RECORD", CS%latent_days_per_rec, & + "If positive the number of days of latent heat fluxes per time level in LATENTHEAT_FILE, "//& + "or if negative the number of time levels per day. If 31 change forcing monthly, "//& + "or if 0 the model will guess the right value based on the file size.", & + default=CS%LW_days_per_rec) call get_param(param_file, mdl, "SENSIBLEHEAT_FILE", CS%sensibleheat_file, & "The file with the sensible heat flux, in the variable "//& "given by SENSIBLE_FORCING_VAR.", fail_if_missing=.true.) call get_param(param_file, mdl, "SENSIBLE_FORCING_VAR", CS%sens_var, & "The variable with the sensible heat flux.", default="sensible") + call get_param(param_file, mdl, "SENSIBLEHEAT_FILE_DAYS_PER_RECORD", CS%sens_days_per_rec, & + "If positive the number of days of sensible heat fluxes per time level in SENSIBLEHEAT_FILE, "//& + "or if negative the number of time levels per day. If 31 change forcing monthly, "//& + "or if 0 the model will guess the right value based on the file size.", & + default=CS%LW_days_per_rec) call get_param(param_file, mdl, "RAIN_FILE", CS%rain_file, & "The file with the liquid precipitation flux, in the "//& @@ -1628,12 +1858,22 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "RAIN_FORCING_VAR", CS%rain_var, & "The variable with the liquid precipitation flux.", & default="liq_precip") + call get_param(param_file, mdl, "RAIN_FILE_DAYS_PER_RECORD", CS%precip_days_per_rec, & + "If positive the number of days of rain fluxes per time level in RAIN_FILE, "//& + "or if negative the number of time levels per day. If 31 change forcing monthly, "//& + "or if 0 the model will guess the right value based on the file size.", & + default=CS%LW_days_per_rec) call get_param(param_file, mdl, "SNOW_FILE", CS%snow_file, & "The file with the frozen precipitation flux, in the "//& "variable given by SNOW_FORCING_VAR.", fail_if_missing=.true.) call get_param(param_file, mdl, "SNOW_FORCING_VAR", CS%snow_var, & "The variable with the frozen precipitation flux.", & default="froz_precip") + call get_param(param_file, mdl, "SHORTWAVE_FILE_DAYS_PER_RECORD", CS%SW_days_per_rec, & + "If positive the number of days of shortwave fluxes per time level in SHORTWAVE_FILE, "//& + "or if negative the number of time levels per day. If 31 change forcing monthly, "//& + "or if 0 the model will guess the right value based on the file size.", & + default=CS%LW_days_per_rec) call get_param(param_file, mdl, "RUNOFF_FILE", CS%runoff_file, & "The file with the fresh and frozen runoff/calving "//& @@ -1645,6 +1885,11 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "FROZ_RUNOFF_FORCING_VAR", CS%frunoff_var, & "The variable with the frozen runoff flux.", & default="froz_runoff") + call get_param(param_file, mdl, "RUNOFF_FILE_DAYS_PER_RECORD", CS%SW_days_per_rec, & + "If positive the number of days of runoff per time level in RUNOFF_FILE, "//& + "or if negative the number of time levels per day. If 31 change forcing monthly, "//& + "or if 0 the model will guess the right value based on the file size.", & + default=0) endif call get_param(param_file, mdl, "SSTRESTORE_FILE", CS%SSTrestore_file, & @@ -1654,16 +1899,25 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "The file with the surface salinity toward which to "//& "restore in the variable given by SSS_RESTORE_VAR.", & fail_if_missing=.true.) - if (CS%archaic_OMIP_file) then CS%SST_restore_var = "TEMP" ; CS%SSS_restore_var = "SALT" else call get_param(param_file, mdl, "SST_RESTORE_VAR", CS%SST_restore_var, & "The variable with the SST toward which to restore.", & default="SST") + call get_param(param_file, mdl, "SSTRESTORE_FILE_DAYS_PER_RECORD", CS%SST_days_per_rec, & + "If positive the number of days of SST per time level in SSTRESTORE_FILE, "//& + "or if negative the number of time levels per day. If 31 change forcing monthly, "//& + "or if 0 the model will guess the right value based on the file size.", & + default=0) call get_param(param_file, mdl, "SSS_RESTORE_VAR", CS%SSS_restore_var, & "The variable with the SSS toward which to restore.", & default="SSS") + call get_param(param_file, mdl, "SALINITYRESTORE_FILE_DAYS_PER_RECORD", CS%SSS_days_per_rec, & + "If positive the number of days of salinity per time level in SALINITYRESTORE_FILE, "//& + "or if negative the number of time levels per day. If 31 change forcing monthly, "//& + "or if 0 the model will guess the right value based on the file size.", & + default=CS%SST_days_per_rec) endif ! Add inputdir to the file names. @@ -1687,11 +1941,13 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "through the sensible heat flux field. ", & units='W/m2', scale=US%W_m2_to_QRZ_T, fail_if_missing=.true.) endif + + ! Determine parameters related to the wind forcing. call get_param(param_file, mdl, "WIND_CONFIG", CS%wind_config, & "The character string that indicates how wind forcing is specified. Valid "//& "options include (file), (data_override), (2gyre), (1gyre), (gyres), (zero), "//& - "(const), (Neverworld), (scurves), (ideal_hurr), (SCM_ideal_hurr), "//& - "(SCM_CVmix_tests) and (USER).", default="zero") + "(const), (Neverworld), (scurves), (ideal_hurr), (SCM_CVmix_tests) and (USER).", & + default="zero") if (trim(CS%wind_config) == "file") then call get_param(param_file, mdl, "WIND_FILE", CS%wind_file, & "The file in which the wind stresses are found in "//& @@ -1712,40 +1968,46 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "USTAR_FORCING_VAR", CS%ustar_var, & "The name of the friction velocity variable in WIND_FILE "//& "or blank to get ustar from the wind stresses plus the "//& - "gustiness.", default=" ", units="nondim") + "gustiness.", default=" ") CS%wind_file = trim(CS%inputdir) // trim(CS%wind_file) + call get_param(param_file, mdl, "WIND_FILE_DAYS_PER_RECORD", CS%wind_days_per_rec, & + "If positive the number of days of wind stress per time level in WIND_FILE, "//& + "or if negative the number of time levels per day. If 31 change forcing monthly, "//& + "or if 0 the model will guess the right value based on the file size.", & + default=0) endif if (trim(CS%wind_config) == "gyres") then call get_param(param_file, mdl, "TAUX_CONST", CS%gyres_taux_const, & "With the gyres wind_config, the constant offset in the "//& "zonal wind stress profile: "//& " A in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="Pa", default=0.0, scale=Pa_to_RLZ_T2) + units="Pa", default=0.0, scale=US%Pa_to_RLZ_T2) call get_param(param_file, mdl, "TAUX_SIN_AMP", CS%gyres_taux_sin_amp, & "With the gyres wind_config, the sine amplitude in the "//& "zonal wind stress profile: "//& " B in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="Pa", default=0.0, scale=Pa_to_RLZ_T2) + units="Pa", default=0.0, scale=US%Pa_to_RLZ_T2) call get_param(param_file, mdl, "TAUX_COS_AMP", CS%gyres_taux_cos_amp, & "With the gyres wind_config, the cosine amplitude in "//& "the zonal wind stress profile: "//& " C in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & - units="Pa", default=0.0, scale=Pa_to_RLZ_T2) + units="Pa", default=0.0, scale=US%Pa_to_RLZ_T2) call get_param(param_file, mdl, "TAUX_N_PIS",CS%gyres_taux_n_pis, & "With the gyres wind_config, the number of gyres in "//& "the zonal wind stress profile: "//& " n in taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L).", & units="nondim", default=0.0) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) - call get_param(param_file, mdl, "WIND_GYRES_2018_ANSWERS", CS%answers_2018, & - "If true, use the order of arithmetic and expressions that recover the answers "//& - "from the end of 2018. Otherwise, use expressions for the gyre friction velocities "//& - "that are rotationally invariant and more likely to be the same between compilers.", & - default=default_2018_answers) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "WIND_GYRES_ANSWER_DATE", CS%answer_date, & + "The vintage of the expressions used to set gyre wind stresses. "//& + "Values below 20190101 recover the answers from the end of 2018, "//& + "while higher values use a form of the gyre wind stresses that are "//& + "rotationally invariant and more likely to be the same between compilers.", & + default=default_answer_date) else - CS%answers_2018 = .false. + CS%answer_date = 20190101 endif if (trim(CS%wind_config) == "scurves") then call get_param(param_file, mdl, "WIND_SCURVES_LATS", CS%scurves_ydata, & @@ -1755,8 +2017,24 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "WIND_SCURVES_TAUX", CS%scurves_taux, & "A list of zonal wind stress values at latitudes "//& "WIND_SCURVES_LATS defining a piecewise scurve profile.", & - units="Pa", scale=Pa_to_RLZ_T2, fail_if_missing=.true.) + units="Pa", scale=US%Pa_to_RLZ_T2, fail_if_missing=.true.) + endif + if (trim(CS%wind_config) == "2gyre") then + call get_param(param_file, mdl, "TAUX_MAGNITUDE", CS%taux_mag, & + "The peak zonal wind stress when WIND_CONFIG = 2gyre.", & + units="Pa", default=0.1, scale=US%Pa_to_RLZ_T2) + endif + if (trim(CS%wind_config) == "1gyre") then + call get_param(param_file, mdl, "TAUX_MAGNITUDE", CS%taux_mag, & + "The peak zonal wind stress when WIND_CONFIG = 1gyre.", & + units="Pa", default=-0.2, scale=US%Pa_to_RLZ_T2) endif + if (trim(CS%wind_config) == "Neverworld" .or. trim(CS%wind_config) == "Neverland") then + call get_param(param_file, mdl, "TAUX_MAGNITUDE", CS%taux_mag, & + "The peak zonal wind stress when WIND_CONFIG = Neverworld.", & + units="Pa", default=0.2, scale=US%Pa_to_RLZ_T2) + endif + if ((trim(CS%wind_config) == "2gyre") .or. & (trim(CS%wind_config) == "1gyre") .or. & (trim(CS%wind_config) == "gyres") .or. & @@ -1768,13 +2046,12 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "RHO_0", CS%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& + "properties, or with BOUSSINESQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) ! (, do_not_log=CS%nonBous) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back "//& - "toward some specified surface state with a rate "//& - "given by FLUXCONST.", default= .false.) + "If true, the buoyancy fluxes drive the model back toward some "//& + "specified surface state with a rate given by FLUXCONST.", default=.false.) call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & "The latent heat of fusion.", default=hlf, & units="J/kg", scale=US%J_kg_to_Q) @@ -1785,53 +2062,80 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes to the relative "//& "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & - default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, & - unscaled=flux_const_default) + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0) if (CS%use_temperature) then + call get_param(param_file, mdl, "FLUXCONST", flux_const_default, & + default=0.0, units="m day-1", do_not_log=.true.) call get_param(param_file, mdl, "FLUXCONST_T", CS%Flux_const_T, & - "The constant that relates the restoring surface temperature "//& - "flux to the relative surface anomaly (akin to a piston "//& - "velocity). Note the non-MKS units.", & - units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, & - default=flux_const_default) + "The constant that relates the restoring surface temperature flux to the "//& + "relative surface anomaly (akin to a piston velocity). Note the non-MKS units.", & + units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, default=flux_const_default) call get_param(param_file, mdl, "FLUXCONST_S", CS%Flux_const_S, & - "The constant that relates the restoring surface salinity "//& - "flux to the relative surface anomaly (akin to a piston "//& - "velocity). Note the non-MKS units.", & - units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, & - default=flux_const_default) + "The constant that relates the restoring surface salinity flux to the "//& + "relative surface anomaly (akin to a piston velocity). Note the non-MKS units.", & + units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, default=flux_const_default) endif if (trim(CS%buoy_config) == "linear") then call get_param(param_file, mdl, "SST_NORTH", CS%T_north, & "With buoy_config linear, the sea surface temperature "//& "at the northern end of the domain toward which to "//& - "to restore.", units="deg C", default=0.0) + "to restore.", units="degC", default=0.0, scale=US%degC_to_C) call get_param(param_file, mdl, "SST_SOUTH", CS%T_south, & "With buoy_config linear, the sea surface temperature "//& "at the southern end of the domain toward which to "//& - "to restore.", units="deg C", default=0.0) + "to restore.", units="degC", default=0.0, scale=US%degC_to_C) call get_param(param_file, mdl, "SSS_NORTH", CS%S_north, & "With buoy_config linear, the sea surface salinity "//& "at the northern end of the domain toward which to "//& - "to restore.", units="PSU", default=35.0) + "to restore.", units="ppt", default=35.0, scale=US%ppt_to_S) call get_param(param_file, mdl, "SSS_SOUTH", CS%S_south, & "With buoy_config linear, the sea surface salinity "//& "at the southern end of the domain toward which to "//& - "to restore.", units="PSU", default=35.0) + "to restore.", units="ppt", default=35.0, scale=US%ppt_to_S) endif + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", CS%rho_restore, & + "The density that is used to convert piston velocities into salt or heat "//& + "fluxes with RESTORE_SALINITY or RESTORE_TEMPERATURE.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=(((CS%Flux_const==0.0).and.(CS%Flux_const_T==0.0).and.(CS%Flux_const_S==0.0))& + .or.(.not.CS%restorebuoy))) endif call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) + units="m s-2", default=9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & "The background gustiness in the winds.", & - units="Pa", default=0.0, scale=Pa_to_RLZ_T2) - call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", CS%fix_ustar_gustless_bug, & + units="Pa", default=0.0, scale=US%Pa_to_RLZ_T2*US%L_to_Z) + + call get_param(param_file, mdl, "USTAR_GUSTLESS_BUG", CS%ustar_gustless_bug, & + "If true include a bug in the time-averaging of the gustless wind friction velocity", & + default=.false., do_not_log=.true.) + ! This is used to test whether USTAR_GUSTLESS_BUG is being actively set. + call get_param(param_file, mdl, "USTAR_GUSTLESS_BUG", test_value, default=.true., do_not_log=.true.) + explicit_bug = CS%ustar_gustless_bug .eqv. test_value + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", fix_ustar_gustless_bug, & "If true correct a bug in the time-averaging of the gustless wind friction velocity", & - default=.true.) + default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", test_value, default=.false., do_not_log=.true.) + explicit_fix = fix_ustar_gustless_bug .eqv. test_value + + if (explicit_bug .and. explicit_fix .and. (fix_ustar_gustless_bug .eqv. CS%ustar_gustless_bug)) then + ! USTAR_GUSTLESS_BUG is being explicitly set, and should not be changed. + call MOM_error(FATAL, "USTAR_GUSTLESS_BUG and FIX_USTAR_GUSTLESS_BUG are both being set "//& + "with inconsistent values. FIX_USTAR_GUSTLESS_BUG is an obsolete "//& + "parameter and should be removed.") + elseif (explicit_fix) then + call MOM_error(WARNING, "FIX_USTAR_GUSTLESS_BUG is an obsolete parameter. "//& + "Use USTAR_GUSTLESS_BUG instead (noting that it has the opposite sense).") + CS%ustar_gustless_bug = .not.fix_ustar_gustless_bug + endif + call log_param(param_file, mdl, "USTAR_GUSTLESS_BUG", CS%ustar_gustless_bug, & + "If true include a bug in the time-averaging of the gustless wind friction velocity", & + default=.false.) + call get_param(param_file, mdl, "READ_GUST_2D", CS%read_gust_2d, & "If true, use a 2-dimensional gustiness supplied from "//& "an input file", default=.false.) @@ -1841,9 +2145,13 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "variable gustiness.", fail_if_missing=.true.) call safe_alloc_ptr(CS%gust,G%isd,G%ied,G%jsd,G%jed) filename = trim(CS%inputdir) // trim(gust_file) - call MOM_read_data(filename,'gustiness',CS%gust,G%domain, timelevel=1, & - scale=Pa_to_RLZ_T2) ! units in file should be Pa + ! NOTE: There are certain cases where FMS is unable to read this file, so + ! we use read_netCDF_data in place of MOM_read_data. + call read_netCDF_data(filename, 'gustiness', CS%gust, G%Domain, & + rescale=US%Pa_to_RLZ_T2*US%L_to_Z) ! units in file should be [Pa] endif + call get_param(param_file, mdl, "USE_MARBL_TRACERS", CS%use_marbl_tracers, & + default=.false., do_not_log=.true.) ! All parameter settings are now known. @@ -1855,21 +2163,29 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS%dumbbell_forcing_CSp) elseif (trim(CS%wind_config) == "MESO" .or. trim(CS%buoy_config) == "MESO" ) then call MESO_surface_forcing_init(Time, G, US, param_file, diag, CS%MESO_forcing_CSp) - elseif (trim(CS%wind_config) == "ideal_hurr" .or.& - trim(CS%wind_config) == "SCM_ideal_hurr") then + elseif (trim(CS%wind_config) == "ideal_hurr") then call idealized_hurricane_wind_init(Time, G, US, param_file, CS%idealized_hurricane_CSp) + elseif (trim(CS%wind_config) == "SCM_ideal_hurr") then + call MOM_error(FATAL, "MOM_surface_forcing (surface_forcing_init): "//& + 'WIND_CONFIG = "SCM_ideal_hurr" is a depricated option. '//& + 'To obtain mathematically equivalent results set '//& + 'WIND_CONFIG = "ideal_hurr", IDL_HURR_SCM = True and IDL_HURR_X0 = 6.48e+05.') elseif (trim(CS%wind_config) == "const") then call get_param(param_file, mdl, "CONST_WIND_TAUX", CS%tau_x0, & "With wind_config const, this is the constant zonal wind-stress", & - units="Pa", scale=Pa_to_RLZ_T2, fail_if_missing=.true.) + units="Pa", scale=US%Pa_to_RLZ_T2, fail_if_missing=.true.) call get_param(param_file, mdl, "CONST_WIND_TAUY", CS%tau_y0, & "With wind_config const, this is the constant meridional wind-stress", & - units="Pa", scale=Pa_to_RLZ_T2, fail_if_missing=.true.) + units="Pa", scale=US%Pa_to_RLZ_T2, fail_if_missing=.true.) elseif (trim(CS%wind_config) == "SCM_CVmix_tests" .or. & trim(CS%buoy_config) == "SCM_CVmix_tests") then call SCM_CVmix_tests_surface_forcing_init(Time, G, param_file, CS%SCM_CVmix_tests_CSp) endif + ! Set up MARBL forcing control structure + call MARBL_forcing_init(G, US, param_file, diag, Time, CS%inputdir, CS%use_marbl_tracers, & + CS%marbl_forcing_CSp) + call register_forcing_type_diags(Time, diag, US, CS%use_temperature, CS%handles) ! Set up any restart fields associated with the forcing. @@ -1929,6 +2245,7 @@ subroutine surface_forcing_end(CS, fluxes) if (associated(CS)) deallocate(CS) CS => NULL() + call callTree_leave("MARBL_forcing_from_data_override, MOM_surface_forcing.F90") end subroutine surface_forcing_end end module MOM_surface_forcing diff --git a/config_src/drivers/solo_driver/atmos_ocean_fluxes.F90 b/config_src/drivers/solo_driver/atmos_ocean_fluxes.F90 index 4a4ddf6da3..a8e11fbe34 100644 --- a/config_src/drivers/solo_driver/atmos_ocean_fluxes.F90 +++ b/config_src/drivers/solo_driver/atmos_ocean_fluxes.F90 @@ -1,9 +1,11 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> A dummy version of atmos_ocean_fluxes_mod module for !! use when the vastly larger FMS package is not needed. module atmos_ocean_fluxes_mod -! This file is part of MOM6. See LICENSE.md for the license. - implicit none ; private public :: aof_set_coupler_flux @@ -20,9 +22,12 @@ function aof_set_coupler_flux(name, flux_type, implementation, atm_tr_index, character(len=*), intent(in) :: flux_type !< An unused argument character(len=*), intent(in) :: implementation !< An unused argument integer, optional, intent(in) :: atm_tr_index !< An unused argument - real, dimension(:), optional, intent(in) :: param !< An unused argument + real, dimension(:), optional, intent(in) :: param !< An unused argument that would be used to + !! pass parameters for flux parameterizations + !! in other contexts [various] logical, dimension(:), optional, intent(in) :: flag !< An unused argument - real, optional, intent(in) :: mol_wt !< An unused argument + real, optional, intent(in) :: mol_wt !< An unused argument that would usually be + !! the tracer's molecular weight [g mol-1] character(len=*), optional, intent(in) :: ice_restart_file !< An unused argument character(len=*), optional, intent(in) :: ocean_restart_file !< An unused argument character(len=*), optional, intent(in) :: units !< An unused argument diff --git a/config_src/drivers/solo_driver/user_surface_forcing.F90 b/config_src/drivers/solo_driver/user_surface_forcing.F90 index 0af6b126e1..5caee49d57 100644 --- a/config_src/drivers/solo_driver/user_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/user_surface_forcing.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Template for user to code up surface forcing. module user_surface_forcing -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_diag_mediator, only : post_data, query_averaging_enabled use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr use MOM_domains, only : pass_var, pass_vector, AGRID @@ -33,10 +35,12 @@ module user_surface_forcing logical :: use_temperature !< If true, temperature and salinity are used as state variables. logical :: restorebuoy !< If true, use restoring surface buoyancy forcing. real :: Rho0 !< The density used in the Boussinesq approximation [R ~> kg m-3]. - real :: G_Earth !< The gravitational acceleration [L2 Z-1 s-2 ~> m s-2]. + real :: G_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. real :: Flux_const !< The restoring rate at the surface [Z T-1 ~> m s-1]. + real :: rho_restore !< The density that is used to convert piston velocities into salt + !! or heat fluxes with salinity or temperature restoring [R ~> kg m-3] real :: gust_const !< A constant unresolved background gustiness - !! that contributes to ustar [R L Z T-1 ~> Pa]. + !! that contributes to ustar [R Z2 T-2 ~> Pa]. type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. @@ -69,16 +73,16 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ! Allocate the forcing arrays, if necessary. - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., tau_mag=.true.) - ! Set the surface wind stresses, in units of [R L Z T-1 ~> Pa]. A positive taux + ! Set the surface wind stresses, in units of [R L Z T-2 ~> Pa]. A positive taux ! accelerates the ocean to the (pseudo-)east. ! The i-loop extends to is-1 so that taux can be used later in the ! calculation of ustar - otherwise the lower bound would be Isq. do j=js,je ; do I=is-1,Ieq ! Change this to the desired expression. - forces%taux(I,j) = G%mask2dCu(I,j) * 0.0*US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z + forces%taux(I,j) = G%mask2dCu(I,j) * 0.0*US%Pa_to_RLZ_T2 enddo ; enddo do J=js-1,Jeq ; do i=is,ie forces%tauy(i,J) = G%mask2dCv(i,J) * 0.0 ! Change this to the desired expression. @@ -88,9 +92,11 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) ! is always positive. if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie ! This expression can be changed if desired, but need not be. - forces%ustar(i,j) = G%mask2dT(i,j) * sqrt((CS%gust_const + & - sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & - 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))) * (US%L_to_Z/CS%Rho0)) + forces%tau_mag(i,j) = G%mask2dT(i,j) * (CS%gust_const + & + US%L_to_Z*sqrt(0.5*((forces%taux(I-1,j)**2) + (forces%taux(I,j)**2)) + & + 0.5*((forces%tauy(i,J-1)**2) + (forces%tauy(i,J)**2)))) + if (associated(forces%ustar)) & + forces%ustar(i,j) = G%mask2dT(i,j) * sqrt(forces%tau_mag(i,j) * (1.0/CS%Rho0)) enddo ; enddo ; endif end subroutine USER_wind_forcing @@ -125,13 +131,13 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! fluxes are in [R Z T-1 ~> kg m-2 s-1] and positive for water moving into the ocean. ! Local variables - real :: Temp_restore ! The temperature that is being restored toward [degC]. - real :: Salin_restore ! The salinity that is being restored toward [ppt] + real :: Temp_restore ! The temperature that is being restored toward [C ~> degC]. + real :: Salin_restore ! The salinity that is being restored toward [S ~> ppt] real :: density_restore ! The potential density that is being restored ! toward [R ~> kg m-3]. - real :: rhoXcp ! The mean density times the heat capacity [Q R degC-1 ~> J m-3 degC-1]. + real :: rhoXcp ! The mean density times the heat capacity [Q R C-1 ~> J m-3 degC-1]. real :: buoy_rest_const ! A constant relating density anomalies to the - ! restoring buoyancy flux [L2 m3 T-3 kg-1 ~> m5 s-3 kg-1]. + ! restoring buoyancy flux [L2 T-3 R-1 ~> m5 s-3 kg-1]. integer :: i, j, is, ie, js, je integer :: isd, ied, jsd, jed @@ -199,16 +205,16 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & "Temperature and salinity restoring used without modification." ) - rhoXcp = CS%Rho0 * fluxes%C_p + rhoXcp = CS%rho_restore * fluxes%C_p do j=js,je ; do i=is,ie - ! Set Temp_restore and Salin_restore to the temperature (in degC) and - ! salinity (in PSU or ppt) that are being restored toward. + ! Set Temp_restore and Salin_restore to the temperature (in [C ~> degC]) and + ! salinity (in [S ~> ppt]) that are being restored toward. Temp_restore = 0.0 Salin_restore = 0.0 fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & (Temp_restore - sfc_state%SST(i,j)) - fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & + fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%rho_restore*CS%Flux_const)) * & ((Salin_restore - sfc_state%SSS(i,j)) / (0.5 * (Salin_restore + sfc_state%SSS(i,j)))) enddo ; enddo else @@ -218,7 +224,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) "Buoyancy restoring used without modification." ) ! The -1 is because density has the opposite sign to buoyancy. - buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%Rho0 + buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%rho_restore do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential ! density [R ~> kg m-3] that is being restored toward. @@ -266,12 +272,12 @@ subroutine USER_surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& + "properties, or with BOUSSINESQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & "The background gustiness in the winds.", & - units="Pa", default=0.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) + units="Pa", default=0.0, scale=US%Pa_to_RLZ_T2*US%L_to_Z) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& @@ -283,6 +289,11 @@ subroutine USER_surface_forcing_init(Time, G, US, param_file, diag, CS) "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & default=0.0, units="m day-1", scale=US%m_to_Z/(86400.0*US%s_to_T)) endif + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", CS%rho_restore, & + "The density that is used to convert piston velocities into salt or heat "//& + "fluxes with RESTORE_SALINITY or RESTORE_TEMPERATURE.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=(CS%Flux_const==0.0).or.(.not.CS%restorebuoy)) end subroutine USER_surface_forcing_init diff --git a/config_src/drivers/timing_tests/time_MOM_ANN.F90 b/config_src/drivers/timing_tests/time_MOM_ANN.F90 new file mode 100644 index 0000000000..dc7839a78f --- /dev/null +++ b/config_src/drivers/timing_tests/time_MOM_ANN.F90 @@ -0,0 +1,191 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +program time_MOM_ANN + +use MOM_ANN, only : ANN_CS +use MOM_ANN, only : ANN_allocate, ANN_apply, ANN_end +use MOM_ANN, only : ANN_apply_vector_orig, ANN_apply_vector_oi +use MOM_ANN, only : ANN_apply_array_sio +use MOM_ANN, only : ANN_random + +implicit none + +! Command line options +integer :: nargs ! Number of command line arguments +character(len=12) :: cmd_ln_arg !< Command line argument (if any) + +! ANN parameters +integer :: nlayers ! Number of layers +integer :: nin ! Number of inputs +integer :: layer_width ! Width of hidden layers +integer :: nout ! Number of outputs +! Timing parameters +integer :: nsamp ! Number of measurements +integer :: nits ! Number of calls to time +integer :: nxy ! Spatial dimension + +nlayers = 7 ; nin = 4 ; layer_width = 16 ; nout = 1 ! Deep network +!nlayers = 4 ; nin = 4 ; layer_width = 48 ; nout = 1 ! Shallow-wide network +!nlayers = 3 ; nin = 4 ; layer_width = 20 ; nout = 1 ! Small network + +nsamp = 100 +nits = 20000 +!nits = 300000 ! Needed for robust measurements on small networks +nxy = 100 ! larger array +!nxy = 10 ! small array + +! Optionally grab ANN and timing parameters from the command line +nargs = command_argument_count() +if (nargs==7) then + call get_command_argument(1, cmd_ln_arg) + read(cmd_ln_arg,*) nlayers + call get_command_argument(2, cmd_ln_arg) + read(cmd_ln_arg,*) nin + call get_command_argument(3, cmd_ln_arg) + read(cmd_ln_arg,*) layer_width + call get_command_argument(4, cmd_ln_arg) + read(cmd_ln_arg,*) nout + call get_command_argument(5, cmd_ln_arg) + read(cmd_ln_arg,*) nsamp + call get_command_argument(6, cmd_ln_arg) + read(cmd_ln_arg,*) nits + call get_command_argument(7, cmd_ln_arg) + read(cmd_ln_arg,*) nxy +endif + +! Fastest variants on Intel Xeon W-2223 CPU @ 3.60GHz (gfortran-13.2 -O3) +! | vector(nxy=1) | nxy = 10 | nxy = 100 +! ---------------------------------------------------------------------------- +! Small ANN | vector_oi | array_soi | array_sio +! Shallow-wide ANN | vector_oi | array_ois | array_sio +! Deep ANN | vector_oi | array_ois | array_sio + +write(*,'(a)') "{" + +call time_ANN(nlayers, nin, layer_width, nout, nsamp, nits, nxy, & + 0, "MOM_ANN:ANN_apply(vector)") +write(*,"(',')") +call time_ANN(nlayers, nin, layer_width, nout, nsamp, nits, nxy, & + 1, "MOM_ANN:ANN_apply_vector_orig(array)") +write(*,"(',')") +call time_ANN(nlayers, nin, layer_width, nout, nsamp, nits, nxy, & + 2, "MOM_ANN:ANN_apply_vector_oi(array)") +write(*,"(',')") +call time_ANN(nlayers, nin, layer_width, nout, nsamp, nits, nxy, & + 12, "MOM_ANN:ANN_apply_array_sio(array)") +write(*,"()") + +write(*,'(a)') "}" + +contains + +!> Time ANN inference. +!! +!! Times are measured over the "nits effective calls" and appropriately scaled to the +!! time per call per single vector of input features. For array inputs, the number of +!! actual calls is reduced by the size of the array. The timing measurement is repeated +!! "nsamp" times, to check the statistics of the timing measurement. +subroutine time_ANN(nlayers, nin, width, nout, nsamp, nits, nxy, impl, label) + integer, intent(in) :: nlayers !< Number of layers + integer, intent(in) :: nin !< Number of inputs + integer, intent(in) :: width !< Width of hidden layers + integer, intent(in) :: nout !< Number of outputs + integer, intent(in) :: nsamp !< Number of measurements + integer, intent(in) :: nits !< Number of calls to time + integer, intent(in) :: nxy !< Spatial dimension + integer, intent(in) :: impl !< Implementation to time + character(len=*), intent(in) :: label !< Label for YAML output + ! Local variables + type(ANN_CS) :: ANN ! ANN + integer :: widths(nlayers) ! Width of each layer + real :: x_s(nin) ! Inputs (just features) [nondim] + real :: y_s(nin) ! Outputs (just features) [nondim] + real :: x_fs(nin,nxy) ! Inputs (feature, space) [nondim] + real :: y_fs(nin,nxy) ! Outputs (feature, space) [nondim] + real :: x_sf(nin,nxy) ! Inputs (space, feature) [nondim] + real :: y_sf(nin,nxy) ! Outputs (space, feature) [nondim] + integer :: iter, samp ! Loop counters + integer :: ij ! Horizontal loop index + real :: start, finish, timing ! CPU times [s] + real :: tmin, tmax, tmean, tstd ! Min, max, mean, and standard deviation, of CPU times [s] + integer :: asamp ! Actual samples of timings + integer :: aits ! Actual iterations + real :: words_per_sec ! Operations per sec estimated from parameters [# s-1] + + widths(:) = width + widths(1) = nin + widths(nlayers) = nout + + call ANN_random(ANN, nlayers, widths) + call random_number(x_fs) + call random_number(x_sf) + + + tmin = 1e9 + tmax = 0. + tmean = 0. + tstd = 0. + asamp = nits ! Most cases below use this + aits = nits / nxy ! Most cases below use this + + do samp = 1, nsamp + select case (impl) + case (0) + aits = nits + call cpu_time(start) + do iter = 1, nits ! Make many passes to reduce sampling error + call ANN_apply(x_s, y_s, ANN) + enddo + call cpu_time(finish) + case (1) + call cpu_time(start) + do iter = 1, aits ! Make many passes to reduce sampling error + do ij = 1, nxy + call ANN_apply_vector_orig(x_fs(:,ij), y_fs(:,ij), ANN) + enddo + enddo + call cpu_time(finish) + case (2) + call cpu_time(start) + do iter = 1, aits ! Make many passes to reduce sampling error + do ij = 1, nxy + call ANN_apply_vector_oi(x_fs(:,ij), y_fs(:,ij), ANN) + enddo + enddo + call cpu_time(finish) + case (12) + call cpu_time(start) + do iter = 1, aits ! Make many passes to reduce sampling error + call ANN_apply_array_sio(nxy, x_sf(:,:), y_sf(:,:), ANN) + enddo + call cpu_time(finish) + asamp = nsamp * aits ! Account for working on whole arrays + end select + + timing = ( finish - start ) / real(nits) ! Average time per call + + tmin = min( tmin, timing ) + tmax = max( tmax, timing ) + tmean = tmean + timing + tstd = tstd + timing**2 + enddo + + tmean = tmean / real(nsamp) + tstd = tstd / real(nsamp) ! convert to mean of squares + tstd = tstd - tmean**2 ! convert to variance + tstd = sqrt( tstd * real(nsamp) / real(nsamp-1) ) ! convert to standard deviation + words_per_sec = ANN%parameters / ( tmean * 1024 * 1024 ) + + write(*,"(2x,3a)") '"', trim(label), '": {' + write(*,"(4x,a,1pe11.4,',')") '"min": ', tmin + write(*,"(4x,a,1pe11.4,',')") '"mean":', tmean + write(*,"(4x,a,1pe11.4,',')") '"std": ', tstd + write(*,"(4x,a,i0,',')") '"n_samples": ', asamp + write(*,"(4x,a,1pe11.4,',')") '"max": ', tmax + write(*,"(4x,a,1pe11.4,'}')", advance="no") '"MBps": ', words_per_sec + +end subroutine time_ANN + +end program time_MOM_ANN diff --git a/config_src/drivers/timing_tests/time_MOM_EOS.F90 b/config_src/drivers/timing_tests/time_MOM_EOS.F90 new file mode 100644 index 0000000000..b8a3f5d27d --- /dev/null +++ b/config_src/drivers/timing_tests/time_MOM_EOS.F90 @@ -0,0 +1,215 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +program time_MOM_EOS + +use MOM_EOS, only : EOS_type +use MOM_EOS, only : EOS_manual_init +use MOM_EOS, only : calculate_density, calculate_spec_vol +use MOM_EOS, only : list_of_eos, get_EOS_name + +implicit none + +! This macro is used to write out timings of a single test rather than conduct +! a suite of tests. It is not meant for general consumption. +#undef PDF_ONLY + +integer, parameter :: n_fns = 4 +character(len=40) :: fn_labels(n_fns) + +! Testing parameters: +! nic is number of elements to compute density for (array size), per call +! halo is data on either end of the array that should not be used +! nits is how many times to repeat the call between turning the timer on/off +! to overcome limited resolution of the timer +! nsamp repeats the timing to collect statistics on the measurement +#ifdef PDF_ONLY +integer, parameter :: nic=26, halo=4, nits=10000, nsamp=400 +#else +integer, parameter :: nic=23, halo=4, nits=1000, nsamp=400 +#endif + +real :: times(nsamp) ! CPU times for observing the PDF [seconds] + +! Arrays to hold timings in [seconds]: +! first axis corresponds to the form of EOS +! second axis corresponds to the function being timed +real, dimension(:,:), allocatable :: timings, tmean, tstd, tmin, tmax +integer :: n_eos, i, j + +n_eos = size(list_of_eos) +allocate( timings(n_eos,n_fns), tmean(n_eos,n_fns) ) +allocate( tstd(n_eos,n_fns), tmin(n_eos,n_fns), tmax(n_eos,n_fns) ) + +fn_labels(1) = 'calculate_density_scalar()' +fn_labels(2) = 'calculate_density_array()' +fn_labels(3) = 'calculate_spec_vol_scalar()' +fn_labels(4) = 'calculate_spec_vol_array()' + +tmean(:,:) = 0. +tstd(:,:) = 0. +tmin(:,:) = 1.e9 +tmax(:,:) = 0. +do i = 1, nsamp +#ifdef PDF_ONLY + call run_one(list_of_EOS, nic, halo, nits, times(i)) +#else + call run_suite(list_of_EOS, nic, halo, nits, timings) + tmean(:,:) = tmean(:,:) + timings(:,:) + tstd(:,:) = tstd(:,:) + timings(:,:)**2 ! tstd contains sum or squares here + tmin(:,:) = min( tmin(:,:), timings(:,:) ) + tmax(:,:) = max( tmax(:,:), timings(:,:) ) +#endif +enddo +tmean(:,:) = tmean(:,:) / real(nsamp) +tstd(:,:) = tstd(:,:) / real(nsamp) ! convert to mean of squares +tstd(:,:) = tstd(:,:) - tmean(:,:)**2 ! convert to variance +tstd(:,:) = sqrt( tstd(:,:) * ( real(nsamp) / real(nsamp-1) ) ) ! Standard deviation + +#ifdef PDF_ONLY +open(newunit=i, file='times.txt', status='replace', action='write') +write(i,'(1pE9.3)') times(:) +close(i) +#else + +! Display results in YAML +write(*,'(a)') "{" +do i = 1, n_eos + do j = 1, n_fns + write(*,"(2x,5a)") '"MOM_EOS_', trim(get_EOS_name(list_of_EOS(i))), & + ' ', trim(fn_labels(j)), '": {' + write(*,"(4x,a,1pe11.4,',')") '"min": ',tmin(i,j) + write(*,"(4x,a,1pe11.4,',')") '"mean":',tmean(i,j) + write(*,"(4x,a,1pe11.4,',')") '"std": ',tstd(i,j) + write(*,"(4x,a,i7,',')") '"n_samples": ',nsamp + if (i*j.ne.n_eos*n_fns) then + write(*,"(4x,a,1pe11.4,'},')") '"max": ',tmax(i,j) + else + write(*,"(4x,a,1pe11.4,'}')") '"max": ',tmax(i,j) + endif + enddo +enddo +write(*,'(a)') "}" +#endif + +contains + +subroutine run_suite(EOS_list, nic, halo, nits, timings) + integer, intent(in) :: EOS_list(n_eos) !< IDs of EOS forms to loop over + integer, intent(in) :: nic !< Width of computational domain + integer, intent(in) :: halo !< Width of halo to add on either end + integer, intent(in) :: nits !< Number of calls to sample + !! (large enough that the CPU timers can resolve + !! the loop) + real, intent(out) :: timings(n_eos,n_fns) !< The average time taken for nits calls [seconds] + !! First index corresponds to EOS + !! Second index: 1 = scalar args, + !! 2 = array args without halo, + !! 3 = array args with halo and "dom". + type(EOS_type) :: EOS + integer :: e, i, dom(2) + real :: start, finish ! CPU times [seconds] + real :: T ! A potential or conservative temperature [degC] + real :: S ! A practical salinity or absolute salinity [ppt] + real :: P ! A pressure [Pa] + real :: rho ! A density [kg m-3] or specific volume [m3 kg-1] + real, dimension(nic+2*halo) :: T1, S1, P1, rho1 + + T = 10. + S = 35. + P = 2000.e4 + + ! Time the scalar interface + do e = 1, n_eos + call EOS_manual_init(EOS, form_of_EOS=EOS_list(e), & + Rho_T0_S0=1030., dRho_dT=0.2, dRho_dS=-0.7) + + call cpu_time(start) + do i = 1, nits*nic ! Calling nic* to make similar cost to array call + call calculate_density(T, S, P, rho, EOS) + enddo + call cpu_time(finish) + timings(e,1) = (finish - start) / real(nits) + + call cpu_time(start) + do i = 1, nits*nic ! Calling nic* to make similar cost to array call + call calculate_spec_vol(T, S, P, rho, EOS) + enddo + call cpu_time(finish) + timings(e,2) = (finish - start) / real(nits) + + enddo + + ! Time the "dom" interface, 1D array + halos + T1(:) = T + S1(:) = S + P1(:) = P + dom(:) = [1+halo,nic+halo] + + do e = 1, n_eos + call EOS_manual_init(EOS, form_of_EOS=EOS_list(e), & + Rho_T0_S0=1030., dRho_dT=0.2, dRho_dS=-0.7) + + call cpu_time(start) + do i = 1, nits + call calculate_density(T1, S1, P1, rho1, EOS, dom) + enddo + call cpu_time(finish) + timings(e,3) = (finish - start) / real(nits) + + call cpu_time(start) + do i = 1, nits + call calculate_spec_vol(T1, S1, P1, rho1, EOS, dom) + enddo + call cpu_time(finish) + timings(e,4) = (finish - start) / real(nits) + + enddo + +end subroutine run_suite + +!> Return timing for just one fixed call to explore the PDF +subroutine run_one(EOS_list, nic, halo, nits, timing) + integer, intent(in) :: EOS_list(n_eos) !< IDs of EOS forms to loop over + integer, intent(in) :: nic !< Width of computational domain + integer, intent(in) :: halo !< Width of halo to add on either end + integer, intent(in) :: nits !< Number of calls to sample + !! (large enough that the CPU timers can resolve + !! the loop) + real, intent(out) :: timing !< The average time taken for nits calls [seconds] + !! First index corresponds to EOS + !! Second index: 1 = scalar args, + !! 2 = array args without halo, + !! 3 = array args with halo and "dom". + type(EOS_type) :: EOS + integer :: i, dom(2) + real :: start, finish ! CPU times [seconds] + real, dimension(nic+2*halo) :: T1 ! Potential or conservative temperatures [degC] + real, dimension(nic+2*halo) :: S1 ! A practical salinities or absolute salinities [ppt] + real, dimension(nic+2*halo) :: P1 ! Pressures [Pa] + real, dimension(nic+2*halo) :: rho1 ! Densities [kg m-3] or specific volumes [m3 kg-1] + + ! Time the scalar interface + call EOS_manual_init(EOS, form_of_EOS=EOS_list(5), & + Rho_T0_S0=1030., dRho_dT=0.2, dRho_dS=-0.7) + + ! Time the "dom" interface, 1D array + halos + T1(:) = 10. + S1(:) = 35. + P1(:) = 2000.e4 + dom(:) = [1+halo,nic+halo] + + call EOS_manual_init(EOS, form_of_EOS=EOS_list(5), & + Rho_T0_S0=1030., dRho_dT=0.2, dRho_dS=-0.7) + + call cpu_time(start) + do i = 1, nits + call calculate_density(T1, S1, P1, rho1, EOS, dom) + enddo + call cpu_time(finish) + timing = (finish-start)/real(nits) + +end subroutine run_one + +end program time_MOM_EOS diff --git a/config_src/drivers/timing_tests/time_MOM_remapping.F90 b/config_src/drivers/timing_tests/time_MOM_remapping.F90 new file mode 100644 index 0000000000..684abe2e2c --- /dev/null +++ b/config_src/drivers/timing_tests/time_MOM_remapping.F90 @@ -0,0 +1,124 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +program time_MOM_remapping + +use MOM_remapping, only : remapping_CS +use MOM_remapping, only : initialize_remapping +use MOM_remapping, only : remapping_core_h + +implicit none + +type(remapping_CS) :: CS +integer, parameter :: nk=75, nij=20*20, nits=10, nsamp=100, nschemes = 22 +character(len=16) :: scheme_labels(nschemes) = [ character(len=16) :: & + 'PCM', & + 'C_PCM', & + 'PLM', & + 'C_MPLM_WA', & + 'C_EMPLM_WA', & + 'C_PLM_HYBGEN', & + 'C_PLM_CW', & + 'C_PLM_CWK', & + 'C_MPLM_WA_POLY', & + 'C_EMPLM_WA_POLY', & + 'C_MPLM_CWK', & + 'PPM_H4', & + 'PPM_IH4', & + 'PQM_IH4IH3', & + 'PPM_CW', & + 'PPM_HYBGEN', & + 'C_PPM_H4_2018', & + 'C_PPM_H4_2019', & + 'C_PPM_HYBGEN', & + 'C_PPM_CW', & + 'C_PPM_CWK', & + 'C_EPPM_CWK' ] +real, dimension(nschemes) :: timings ! Time for nits of nij calls for each scheme [s] +real, dimension(nschemes) :: tmean ! Mean time for a call [s] +real, dimension(nschemes) :: tstd ! Standard deviation of time for a call [s] +real, dimension(nschemes) :: tmin ! Shortest time for a call [s] +real, dimension(nschemes) :: tmax ! Longest time for a call [s] +real, dimension(:,:), allocatable :: u0, u1 ! Source/target values [arbitrary but same units as each other] +real, dimension(:,:), allocatable :: h0, h1 ! Source target thicknesses [0..1] [nondim] +real :: start, finish ! Times [s] +real :: h_neglect ! A negligible thickness [nondim] +real :: h0sum, h1sum ! Totals of h0 and h1 [nondim] +integer :: ij, k, isamp, iter, ischeme ! Indices and counters +integer :: seed_size ! Number of integers used by seed +integer, allocatable :: seed(:) ! Random number seed + +! Set seed for random numbers +call random_seed(size=seed_size) +allocate( seed(seed_Size) ) +seed(:) = 102030405 +call random_seed(put=seed) + +! Set up some test data (note: using k,i indexing rather than i,k) +allocate( u0(nk,nij), h0(nk,nij), u1(nk,nij), h1(nk,nij) ) +call random_number(u0) ! In range 0-1 +call random_number(h0) ! In range 0-1 +call random_number(h1) ! In range 0-1 +do ij = 1, nij + h0(:,ij) = max(0., h0(:,ij) - 0.05) ! Make 5% of values equal to zero + h1(:,ij) = max(0., h1(:,ij) - 0.05) ! Make 5% of values equal to zero + h0sum = h0(1,ij) + h1sum = h1(1,ij) + do k = 2, nk + h0sum = h0sum + h0(k,ij) + h1sum = h1sum + h1(k,ij) + enddo + h0(:,ij) = h0(:,ij) / h0sum + h1(:,ij) = h1(:,ij) / h1sum +enddo +h_neglect = 1.0-30 + +! Loop over many samples of timing loop to collect statistics +tmean(:) = 0. +tstd(:) = 0. +tmin(:) = 1.e9 +tmax(:) = 0. +do isamp = 1, nsamp + ! Time reconstruction + remapping + do ischeme = 1, nschemes + call initialize_remapping(CS, remapping_scheme=trim(scheme_labels(ischeme)), nk=nk, & + h_neglect=h_neglect, h_neglect_edge=h_neglect) + call cpu_time(start) + do iter = 1, nits ! Make many passes to reduce sampling error + do ij = 1, nij ! Calling nij times to make similar to cost in MOM_ALE() + call remapping_core_h(CS, nk, h0(:,ij), u0(:,ij), nk, h1(:,ij), u1(:,ij)) + enddo + enddo + call cpu_time(finish) + timings(ischeme) = (finish-start)/real(nits*nij) ! Average time per call + enddo + tmean(:) = tmean(:) + timings(:) + tstd(:) = tstd(:) + timings(:)**2 ! tstd contains sum of squares here + tmin(:) = min( tmin(:), timings(:) ) + tmax(:) = max( tmax(:), timings(:) ) +enddo +tmean(:) = tmean(:) / real(nsamp) ! convert to mean +tstd(:) = tstd(:) / real(nsamp) ! convert to mean of squares +tstd(:) = tstd(:) - tmean(:)**2 ! convert to variance +tstd(:) = sqrt( tstd(:) * real(nsamp) / real(nsamp-1) ) ! convert to standard deviation + + +! Display results in YAML +write(*,'(a)') "{" +do ischeme = 1, nschemes + write(*,"(2x,5a)") '"MOM_remapping remapping_core_h(remapping_scheme=', & + trim(scheme_labels(ischeme)), ')": {' + write(*,"(4x,a,1pe11.4,',')") '"min": ',tmin(ischeme) + write(*,"(4x,a,1pe11.4,',')") '"mean":',tmean(ischeme) + write(*,"(4x,a,1pe11.4,',')") '"std": ',tstd(ischeme) + write(*,"(4x,a,i7,',')") '"n_samples": ',nsamp + if (ischeme.ne.nschemes) then + write(*,"(4x,a,1pe11.4,'},')") '"max": ',tmax(ischeme) + else + write(*,"(4x,a,1pe11.4,'}')") '"max": ',tmax(ischeme) + endif +enddo +write(*,'(a)') "}" + +end program time_MOM_remapping diff --git a/config_src/drivers/timing_tests/time_reproducing_sum.F90 b/config_src/drivers/timing_tests/time_reproducing_sum.F90 new file mode 100644 index 0000000000..2851550d21 --- /dev/null +++ b/config_src/drivers/timing_tests/time_reproducing_sum.F90 @@ -0,0 +1,137 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +program time_reproducing_sum + +use MOM_coms, only : PE_here, root_PE, num_PEs, reproducing_sum +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_domains, only : MOM_domain_type, create_MOM_domain, MOM_infra_init, MOM_infra_end +use MOM_domains, only : MOM_define_layout +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, MOM_set_verbosity +use MOM_hor_index, only : hor_index_type, hor_index_init + + implicit none + + type(MOM_domain_type), pointer :: Domain => NULL() ! Ocean model domain + type(hor_index_type) :: HI ! A hor_index_type for array extents + real, allocatable, dimension(:) :: depth_tot_R, depth_tot_std, depth_tot_fastR ! Various sums of depths [m] + real, allocatable :: array(:,:) ! An array with values to sum over [m] + character(len=200) :: mesg ! String for messages + integer :: num_sums ! Number of times to repeat the sum call + integer :: n ! Loop counter + integer :: io_unit ! i/o unit for creating input.nml (sigh) + integer :: reproClock, fastreproClock, stdClock, initClock ! Clocks for each sum + integer :: n_global(2) ! Global i-, j- dimensions of domain (h-points) + integer :: layout(2) ! PE count in i-, j- directions + integer :: PEs_used ! Number of PEs available to executable + + ! FMS requires the file "input.nml" to exist ... + open(newunit=io_unit, file="input.nml", status="replace", action="write") + close(io_unit) ! ... but an empty input.nml is sufficient + + call MOM_infra_init() + + ! These clocks are on the global pelist. + initClock = cpu_clock_id( 'Initialization' ) + stdClock = cpu_clock_id( 'Standard Sums' ) + reproClock = cpu_clock_id( 'Reproducing Sums' ) + fastreproClock = cpu_clock_id( 'Fast Reproducing Sums' ) + num_sums = 100 + + call cpu_clock_begin(initClock) + ! Optionally use command-line to change size of the problem + ! Usage: ./executable [tile-size] [number-of-calls] + n = command_argument_count() + if (n==2) then + call get_command_argument(1, mesg) + read(mesg,*) n_global(1) + n_global(2) = n_global(1) + call get_command_argument(2, mesg) + read(mesg,*) num_sums + elseif (n==1) then + call get_command_argument(1, mesg) + read(mesg,*) n_global(1) + n_global(2) = n_global(1) + else + n_global = (/500, 300/) ! Fallback value if no argument provided + endif + + call MOM_mesg('======== Unit test being driven by MOM_sum_driver ========', 2) + call MOM_set_verbosity(2) + + ! Setup distributed domain + PEs_used = num_PEs() + call MOM_define_layout(n_global, PEs_used, layout) + call create_MOM_domain(Domain, n_global, (/2,2/), (/.false.,.false./), .false., layout) + call hor_index_init(Domain, HI) + + allocate( array(HI%isd:HI%ied,HI%jsd:HI%jed), source=0. ) + allocate( depth_tot_std(num_sums), source=0. ) + allocate( depth_tot_R(num_sums), source=0. ) + allocate( depth_tot_fastR(num_sums), source=0. ) + + ! Set up an array of values to sum + call generate_array_of_values(array, HI, n_global) + + call cpu_clock_end(initClock) !end initialization + call MOM_mesg("Done with initialization.", 5) + + call MOM_mesg('==== Standard Non-reproducing Sum ===', 2) + do n=1,num_sums + call cpu_clock_begin(stdClock) + depth_tot_std(n) = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec, reproducing=.false.) + call cpu_clock_end(stdClock) + enddo + + call MOM_mesg('==== Reproducing Fixed Point Sum ===', 2) + do n=1,num_sums + call cpu_clock_begin(reproClock) + depth_tot_R(n) = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec) + call cpu_clock_end(reproClock) + enddo + + call MOM_mesg('==== No Error Handling Reproducing Fixed Point Sum ===', 2) + do n=1,num_sums + call cpu_clock_begin(fastreproClock) + depth_tot_fastR(n) = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec, overflow_check=.false.) + call cpu_clock_end(fastreproClock) + enddo + + ! Cleanup the "input.nml" file created to boot FMS + if (PE_here() == root_PE()) then ! Can only delete the file once (i.e. on root PE) + open(newunit=io_unit, file="input.nml", status="replace", action="write") + close(io_unit, status="delete") ! we could leave this in place but that would be untidy + endif + + call MOM_infra_end + +contains + +!> Generate some "spatial" data, reminiscent of benchmark topography +subroutine generate_array_of_values(D, HI, n_global) + type(hor_index_type), intent(in) :: HI !< The horizontal index type + real, intent(out) :: D(HI%isd:HI%ied,HI%jsd:HI%jed) !< Ocean bottom depth in [m] + integer, intent(in) :: n_global(2) !< Global i-, j- dimensions of domain (h-points) + ! Local variables + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] + real :: x ! A fractional position in the x-direction [nondim] + real :: y ! A fractional position in the y-direction [nondim] + integer :: i, j ! Loop indices + + PI = 4.0*atan(1.0) + + ! Calculate the depth of the bottom. + do concurrent( j=HI%jsc:HI%jec, i=HI%isc:HI%iec ) + x = real( i + HI%idg_offset ) / real( n_global(1) ) + y = real( j + HI%idg_offset ) / real( n_global(2) ) + D(i,j) = -3000.0 * ( y*(1.0 + 0.6*cos(4.0*PI*x)) & + + 0.75*exp(-6.0*y) & + + 0.05*cos(10.0*PI*x) - 0.7 ) + if (D(i,j) > 3000.0) D(i,j) = 3000.0 + if (D(i,j) < 1.) D(i,j) = 0. + enddo + +end subroutine generate_array_of_values + +end program time_reproducing_sum diff --git a/config_src/drivers/unit_drivers/MOM_sum_driver.F90 b/config_src/drivers/unit_drivers/MOM_sum_driver.F90 deleted file mode 100644 index 9f3950ac7f..0000000000 --- a/config_src/drivers/unit_drivers/MOM_sum_driver.F90 +++ /dev/null @@ -1,218 +0,0 @@ -program MOM_main - -! This file is part of MOM6. See LICENSE.md for the license. - -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* The Modular Ocean Model * -!* MOM * -!* * -!* By Robert Hallberg * -!* * -!* This file is a simple driver for unit testing the distributed * -!* sums code. * -!* * -!********+*********+*********+*********+*********+*********+*********+** - - use MOM_coms, only : sum_across_PEs, PE_here, root_PE, num_PEs, reproducing_sum - use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=), EFP_to_real, real_to_EFP - use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end - use MOM_cpu_clock, only : CLOCK_COMPONENT - use MOM_domains, only : MOM_domain_type, MOM_domains_init, MOM_infra_init, MOM_infra_end - use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid - use MOM_error_handler, only : MOM_error, MOM_mesg, WARNING, FATAL, is_root_pe - use MOM_error_handler, only : MOM_set_verbosity - use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type - use MOM_file_parser, only : open_param_file, close_param_file - use MOM_grid_initialize, only : set_grid_metrics - use MOM_hor_index, only : hor_index_type, hor_index_init - use MOM_io, only : MOM_io_init, file_exists, open_file, close_file - use MOM_io, only : check_nml_error, io_infra_init, io_infra_end - use MOM_io, only : APPEND_FILE, ASCII_FILE, READONLY_FILE, SINGLE_FILE - use MOM_unit_scaling, only : unit_scale_type, unit_no_scaling_init, unit_scaling_end - - implicit none - -#include - - type(MOM_domain_type), pointer :: Domain => NULL() !< Ocean model domain - type(dyn_horgrid_type), pointer :: grid => NULL() ! A structure containing metrics and grid info - type(hor_index_type) :: HI ! A hor_index_type for array extents - type(param_file_type) :: param_file ! The structure indicating the file(s) - ! containing all run-time parameters. - type(unit_scale_type), pointer :: US => NULL() !< A structure containing various unit - ! conversion factors, but in this case all are 1. - real :: max_depth ! The maximum ocean depth [m] - integer :: verbosity - integer :: num_sums - integer :: n, i, j, is, ie, js, je, isd, ied, jsd, jed - - integer :: unit, io_status, ierr - logical :: unit_in_use - - real, allocatable, dimension(:) :: & - depth_tot_R, depth_tot_std, depth_tot_fastR - integer :: reproClock, fastreproClock, stdClock, initClock - - !----------------------------------------------------------------------- - - character(len=4), parameter :: vers_num = 'v2.0' - ! This include declares and sets the variable "version". -# include "version_variable.h" - character(len=40) :: mdl = "MOM_main (MOM_sum_driver)" ! This module's name. - character(len=200) :: mesg - - !======================================================================= - - call MOM_infra_init() ; call io_infra_init() - - ! These clocks are on the global pelist. - initClock = cpu_clock_id( 'Initialization' ) - reproClock = cpu_clock_id( 'Reproducing Sums' ) - fastreproClock = cpu_clock_id( 'Fast Reproducing Sums' ) - stdClock = cpu_clock_id( 'Standard Sums' ) - - call cpu_clock_begin(initClock) - - call MOM_mesg('======== Unit test being driven by MOM_sum_driver ========', 2) - - call open_param_file("./MOM_input", param_file) - - verbosity = 2 ; call read_param(param_file, "VERBOSITY", verbosity) - call MOM_set_verbosity(verbosity) - - call MOM_domains_init(Domain, param_file) - - call MOM_io_init(param_file) -! call diag_mediator_init(param_file) - call hor_index_init(Domain, HI, param_file) - call create_dyn_horgrid(grid, HI) - grid%Domain => Domain - - is = HI%isc ; ie = HI%iec ; js = HI%jsc ; je = HI%jec - isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed - - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, "MOM", version, "") - call get_param(param_file, "MOM", "VERBOSITY", verbosity, & - "Integer controlling level of messaging\n" // & - "\t0 = Only FATAL messages\n" // & - "\t2 = Only FATAL, WARNING, NOTE [default]\n" // & - "\t9 = All)", default=2) - call get_param(param_file, "MOM", "NUMBER_OF_SUMS", num_sums, & - "The number of times to do the global sums.", default=1) - - allocate(depth_tot_R(num_sums)) ; depth_tot_R(:) = 0.0 - allocate(depth_tot_std(num_sums)) ; depth_tot_std(:) = 0.0 - allocate(depth_tot_fastR(num_sums)) ; depth_tot_fastR(:) = 0.0 - -! Set up the parameters of the physical grid - call unit_no_scaling_init(US) - call set_grid_metrics(grid, param_file, US) - -! Set up the bottom depth, grid%bathyT either analytically or from file - call get_param(param_file, "MOM", "MAXIMUM_DEPTH", max_depth, & - "The maximum depth of the ocean.", units="m", default=4000.0) - call benchmark_init_topog_local(grid%bathyT, grid, param_file, max_depth) - - ! Close the param_file. No further parsing of input is possible after this. - call close_param_file(param_file) - - call cpu_clock_end(initClock) !end initialization - call MOM_mesg("Done with initialization.", 5) - - call MOM_mesg('==== Reproducing Fixed Point Sum ===', 2) - - call cpu_clock_begin(reproClock) - do n=1,num_sums - depth_tot_R(n) = reproducing_sum(grid%bathyT, is, ie, js, je) - enddo - call cpu_clock_end(reproClock) - - call MOM_mesg('==== Standard Non-reproducing Sum ===', 2) - - call cpu_clock_begin(stdClock) -! do n=1,num_sums -! do j=js,je ; do i=is,ie -! depth_tot_std(n) = depth_tot_std(n) + grid%bathyT(i,j) -! enddo ; enddo -! call sum_across_PEs(depth_tot_std(n:),1) -! enddo - do n=1,num_sums - depth_tot_fastR(n) = reproducing_sum(grid%bathyT, is, ie, js, je, reproducing=.false.) - enddo - call cpu_clock_end(stdClock) - - call MOM_mesg('==== No Error Handling Reproducing Fixed Point Sum ===', 2) - - call cpu_clock_begin(fastreproClock) - do n=1,num_sums - depth_tot_fastR(n) = reproducing_sum(grid%bathyT, is, ie, js, je, overflow_check=.false.) - enddo - call cpu_clock_end(fastreproClock) - - do n=1,num_sums - if ((depth_tot_std(n) - depth_tot_R(n)) > 1e-15*depth_tot_R(n)) then - write(mesg,'("Mismatch between standard and reproducing sum.",2ES13.5)') & - depth_tot_std(n) - depth_tot_R(n), depth_tot_R(n) - call MOM_mesg(mesg) ; exit - endif - if ((depth_tot_fastR(n) - depth_tot_R(n)) > 1e-15*depth_tot_R(n)) then - write(mesg,'("Mismatch between reproducing and fast reproducing sums.",2ES13.5)') & - depth_tot_fastR(n) - depth_tot_R(n), depth_tot_R(n) - call MOM_mesg(mesg) ; exit -! call MOM_mesg("Mismatch between reproducing and fast reproducing sums.") - endif - enddo - - call destroy_dyn_horgrid(grid) - call unit_scaling_end(US) - call io_infra_end ; call MOM_infra_end - -contains - -!> This subroutine sets up the benchmark test case topography for debugging -subroutine benchmark_init_topog_local(D, G, param_file, max_depth) - type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type - real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth in m or [Z ~> m] if US is present - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - real, intent(in) :: max_depth !< The maximum ocean depth [m] - - real :: min_depth ! The minimum ocean depth in m. - real :: PI ! 3.1415926... calculated as 4*atan(1) - real :: D0 ! A constant to make the maximum ! - ! basin depth MAXIMUM_DEPTH. ! - real :: m_to_Z ! A dimensional rescaling factor. - real :: x, y - ! This include declares and sets the variable "version". -# include "version_variable.h" - character(len=40) :: mdl = "benchmark_init_topog_local" ! This subroutine's name. - integer :: i, j, is, ie, js, je, isd, ied, jsd, jed - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - m_to_Z = 1.0 ! ; if (present(US)) m_to_Z = US%m_to_Z - - call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & - "The minimum depth of the ocean.", units="m", default=0.0, scale=m_to_Z) - - PI = 4.0*atan(1.0) - D0 = max_depth / 0.5 - -! Calculate the depth of the bottom. - do i=is,ie ; do j=js,je - x=(G%geoLonT(i,j)-G%west_lon)/G%len_lon - y=(G%geoLatT(i,j)-G%south_lat)/G%len_lat -! This sets topography that has a reentrant channel to the south. - D(i,j) = -D0 * ( y*(1.0 + 0.6*cos(4.0*PI*x)) & - + 0.75*exp(-6.0*y) & - + 0.05*cos(10.0*PI*x) - 0.7 ) - if (D(i,j) > max_depth) D(i,j) = max_depth - if (D(i,j) < min_depth) D(i,j) = 0. - enddo ; enddo - -end subroutine benchmark_init_topog_local - -end program MOM_main diff --git a/config_src/drivers/unit_tests/test_MOM_ANN.F90 b/config_src/drivers/unit_tests/test_MOM_ANN.F90 new file mode 100644 index 0000000000..345b6ee6e9 --- /dev/null +++ b/config_src/drivers/unit_tests/test_MOM_ANN.F90 @@ -0,0 +1,14 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +program test_MOM_ANN + +use MOM_ANN, only : ANN_unit_tests +use MOM_error_handler, only : set_skip_mpi + +call set_skip_mpi(.true.) ! This unit tests is not expecting MPI to be used + +if ( ANN_unit_tests(.true.) ) stop 1 + +end program test_MOM_ANN diff --git a/config_src/drivers/unit_tests/test_MOM_EOS.F90 b/config_src/drivers/unit_tests/test_MOM_EOS.F90 new file mode 100644 index 0000000000..90fe5b95e0 --- /dev/null +++ b/config_src/drivers/unit_tests/test_MOM_EOS.F90 @@ -0,0 +1,14 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +program test_MOM_EOS + +use MOM_EOS, only : EOS_unit_tests +use MOM_error_handler, only : set_skip_mpi + +call set_skip_mpi(.true.) ! This unit tests is not expecting MPI to be used + +if ( EOS_unit_tests(.true.) ) stop 1 + +end program test_MOM_EOS diff --git a/config_src/drivers/unit_tests/test_MOM_array_transform.F90 b/config_src/drivers/unit_tests/test_MOM_array_transform.F90 new file mode 100644 index 0000000000..e0926f8f3a --- /dev/null +++ b/config_src/drivers/unit_tests/test_MOM_array_transform.F90 @@ -0,0 +1,11 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +program test_MOM_array_transform + +use MOM_array_transform, only : symmetric_sum_unit_tests + +if ( symmetric_sum_unit_tests(.true.) ) stop 1 + +end program test_MOM_array_transform diff --git a/config_src/drivers/unit_tests/test_MOM_file_parser.F90 b/config_src/drivers/unit_tests/test_MOM_file_parser.F90 new file mode 100644 index 0000000000..1b3e52259c --- /dev/null +++ b/config_src/drivers/unit_tests/test_MOM_file_parser.F90 @@ -0,0 +1,69 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +program test_MOM_file_parser + +use MPI +use MOM_domains, only : MOM_infra_init +use MOM_domains, only : MOM_infra_end +use MOM_file_parser_tests, only : run_file_parser_tests + +implicit none + +integer, parameter :: comm = MPI_COMM_WORLD +integer, parameter :: root = 0 +integer :: rank +logical :: file_exists_on_rank +logical :: input_nml_exists, MOM_input_exists +integer :: io_unit +logical :: is_open, is_file +integer :: rc + +! NOTE: Bootstrapping requires external MPI configuration. +! - FMS initialization requires the presence of input.nml +! - MOM initialization requires MOM_input (if unspecificed by input.nml) +! - Any MPI-based I/O prior to MOM and FMS init will MPI initialization +! Thus, we need to do some minimal MPI setup. +call MPI_Init(rc) +call MPI_Comm_rank(comm, rank, rc) + +inquire(file='input.nml', exist=file_exists_on_rank) +call MPI_Reduce(file_exists_on_rank, input_nml_exists, 1, MPI_LOGICAL, & + MPI_LOR, root, comm, rc) + +inquire(file='MOM_input', exist=file_exists_on_rank) +call MPI_Reduce(file_exists_on_rank, MOM_input_exists, 1, MPI_LOGICAL, & + MPI_LOR, root, comm, rc) + +if (rank == root) then + ! Abort if at least one rank sees either input.nml or MOM_input + if (input_nml_exists) error stop "Remove existing 'input.nml' file." + if (MOM_input_exists) error stop "Remove existing 'MOM_input' file." + + ! Otherwise, create the (empty) files + open(newunit=io_unit, file='input.nml', status='replace') + write(io_unit, '(a)') "&fms2_io_nml /" + close(io_unit) + + open(newunit=io_unit, file='MOM_input', status='replace') + close(io_unit) +endif + +call MOM_infra_init(comm) + +! Run tests +call run_file_parser_tests + +! Cleanup +call MOM_infra_end + +if (rank == root) then + open(newunit=io_unit, file='MOM_input') + close(io_unit, status='delete') + + open(newunit=io_unit, file='input.nml') + close(io_unit, status='delete') +endif + +end program test_MOM_file_parser diff --git a/config_src/drivers/unit_tests/test_MOM_mixedlayer_restrat.F90 b/config_src/drivers/unit_tests/test_MOM_mixedlayer_restrat.F90 new file mode 100644 index 0000000000..60c6e72de4 --- /dev/null +++ b/config_src/drivers/unit_tests/test_MOM_mixedlayer_restrat.F90 @@ -0,0 +1,14 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +program test_MOM_mixedlayer_restrat + +use MOM_mixed_layer_restrat, only : mixedlayer_restrat_unit_tests +use MOM_error_handler, only : set_skip_mpi + +call set_skip_mpi(.true.) ! This unit tests is not expecting MPI to be used + +if ( mixedlayer_restrat_unit_tests(.true.) ) stop 1 + +end program test_MOM_mixedlayer_restrat diff --git a/config_src/drivers/unit_tests/test_MOM_remapping.F90 b/config_src/drivers/unit_tests/test_MOM_remapping.F90 new file mode 100644 index 0000000000..4869e57965 --- /dev/null +++ b/config_src/drivers/unit_tests/test_MOM_remapping.F90 @@ -0,0 +1,23 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +program test_MOM_remapping + +use MOM_remapping, only : remapping_unit_tests + +integer :: n !< Number of arguments, or tests +character(len=12) :: cmd_ln_arg !< Command line argument (if any) + +n = command_argument_count() + +if (n==1) then + call get_command_argument(1, cmd_ln_arg) + read(cmd_ln_arg,*) n +else + n = 3000 ! Fallback value if no argument provided +endif + +if (remapping_unit_tests(.true., num_comp_samp=n)) stop 1 + +end program test_MOM_remapping diff --git a/config_src/drivers/unit_tests/test_MOM_string_functions.F90 b/config_src/drivers/unit_tests/test_MOM_string_functions.F90 new file mode 100644 index 0000000000..47da9d0411 --- /dev/null +++ b/config_src/drivers/unit_tests/test_MOM_string_functions.F90 @@ -0,0 +1,14 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +program test_MOM_string_functions + +use MOM_string_functions, only : string_functions_unit_tests +use MOM_error_handler, only : set_skip_mpi + +call set_skip_mpi(.true.) ! This unit tests is not expecting MPI to be used + +if ( string_functions_unit_tests(.true.) ) stop 1 + +end program test_MOM_string_functions diff --git a/config_src/drivers/unit_tests/test_numerical_testing_type.F90 b/config_src/drivers/unit_tests/test_numerical_testing_type.F90 new file mode 100644 index 0000000000..532d7ca960 --- /dev/null +++ b/config_src/drivers/unit_tests/test_numerical_testing_type.F90 @@ -0,0 +1,11 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +program test_numerical_testing_type + +use numerical_testing_type, only : numerical_testing_type_unit_tests + +if (numerical_testing_type_unit_tests(.true.)) stop 1 + +end program test_numerical_testing_type diff --git a/config_src/drivers/unit_tests/test_reproducing_sum.F90 b/config_src/drivers/unit_tests/test_reproducing_sum.F90 new file mode 100644 index 0000000000..2a9af42538 --- /dev/null +++ b/config_src/drivers/unit_tests/test_reproducing_sum.F90 @@ -0,0 +1,211 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +program test_reproducing_sum + +use MOM_coms, only : PE_here, root_PE, num_PEs, reproducing_sum +use MOM_coms, only : sum_across_PEs, max_across_PEs, max_count_prec +use MOM_domains, only : MOM_domain_type, create_MOM_domain, MOM_infra_init, MOM_infra_end +use MOM_domains, only : MOM_define_layout +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, MOM_set_verbosity +use MOM_hor_index, only : hor_index_type, hor_index_init + + implicit none + + type(MOM_domain_type), pointer :: Domain => NULL() ! Ocean model domain + type(hor_index_type) :: HI ! A hor_index_type for array extents + real, allocatable :: array(:,:) ! An array with values to sum over [A] + real :: tot_R, tot_std, tot_fastR ! Sums via different methods [A] + real :: error_bound, likely_error ! Errors via different methods [A] + character(len=200) :: mesg ! String for messages + integer :: n_repeat ! Number of times to repeat the sum call + integer :: n ! Loop counter + integer :: io_unit ! i/o unit for creating input.nml (sigh) + integer :: n_global(2) ! Global i-, j- dimensions of domain (h-points) + integer :: layout(2) ! PE count in i-, j- directions + integer :: PEs_used ! Number of PEs available to executable + logical :: tests_failed ! True if a fail is encountered + integer :: i, j, ig, jg ! Spatial indices + + ! FMS requires the file "input.nml" to exist ... + open(newunit=io_unit, file="input.nml", status="replace", action="write") + close(io_unit) ! ... but an empty input.nml is sufficient + + call MOM_infra_init() + + n_repeat = 100 + + ! Optionally use command-line to change size of the problem + ! Usage: ./executable [tile-size] [number-of-calls] + n = command_argument_count() + if (n==2) then + call get_command_argument(1, mesg) + read(mesg,*) n_global(1) + n_global(2) = n_global(1) + call get_command_argument(2, mesg) + read(mesg,*) n_repeat + elseif (n==1) then + call get_command_argument(1, mesg) + read(mesg,*) n_global(1) + n_global(2) = n_global(1) + else + n_global = (/200, 300/) ! Fallback value if no argument provided + endif + + tests_failed = .false. + call MOM_set_verbosity(2) + + ! Setup distributed domain + PEs_used = num_PEs() + call MOM_define_layout(n_global, PEs_used, layout) + call create_MOM_domain(Domain, n_global, (/2,2/), (/.false.,.false./), .false., layout) + call hor_index_init(Domain, HI) + + allocate( array(HI%isd:HI%ied,HI%jsd:HI%jed), source=0. ) + + ! Set up an array of values to sum + call generate_array_of_values(array, HI, n_global) + + ! This estimates the maximum possible accumulated round off error, and likely error + ! from a random walk of round off errors + error_bound = 0. + tot_std = 0. + do j = HI%jsc, HI%jec ; do i = HI%isc, HI%iec + ! Actual round off error for adding tot_std + array(i,j) + error_bound = error_bound + max( abs(tot_std), abs(array(i,j)) ) * epsilon(error_bound) + tot_std = tot_std + array(i,j) + enddo ; enddo + call sum_across_PEs( error_bound ) + call sum_across_PEs( tot_std ) + N = n_global(1) * n_global(2) + likely_error = tot_std * epsilon(tot_std) * sqrt( real( N ) ) + if (likely_error > error_bound) call MOM_error(FATAL, 'Something went wrong in error estimate!') + + tot_std = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec, reproducing=.false.) + tot_R = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec) + tot_fastR = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec, overflow_check=.false.) + + ! tot_std and tot_R should differ only by round off, if at all + if (abs(tot_std - tot_R) > likely_error) then + write(mesg,'("Mismatch between standard and reproducing sum.",4ES13.5)') & + tot_std, tot_R, tot_std - tot_R, ( tot_std - tot_R ) / tot_R + call MOM_mesg(mesg) + tests_failed = tests_failed .or. .true. + endif + ! tot_fastR and tot_R should be identical unless too many values are summed + if (abs(tot_fastR - tot_R) > 0.) then + if (n < max_count_prec) then + write(mesg,'("Mismatch between reproducing and fast reproducing sums.",4ES13.5)') & + tot_fastR, tot_R, tot_fastR - tot_R, ( tot_fastR - tot_R ) / tot_R + tests_failed = tests_failed .or. .true. + else + write(mesg,'("Too many values were summed for the fast reproducing sum to work.")') + endif + call MOM_mesg(mesg) + endif + + ! Now check the reproducing sums give the exact answer for known sets of values + + ! Fill array with values 1, 2, ..., Ni*Nj whose sum is N ( N + 1 ) / 2 where N + Ni*Nj + do j = HI%jsc, HI%jec ; do i = HI%isc, HI%iec + jg = j + HI%jdg_offset - 1 ! 0 .. Nj-1 + ig = i + HI%idg_offset - 1 ! 0 .. Ni-1 + array(i,j) = 1 + ig + n_global(1) * jg + enddo ; enddo + tot_std = 0.5 * real(N) * real(N + 1) ! tot_std will contain analytic solution + tot_R = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec) + if (abs(tot_R - tot_std) > 0.) then + write(mesg,'("Sum_k=1^N k != N(N+1)/2",2ES13.5)') tot_R, tot_std + call MOM_mesg(mesg) + tests_failed = tests_failed .or. .true. + endif + + ! Change the order of values in the arrya to check the sum is truly order invariant + do i = 1, n_repeat + call randomly_swap_elements(HI, array) + tot_R = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec) + if (abs(tot_R - tot_std) > 0.) then + write(mesg,'("Reordered list changed sum",2ES13.5)') tot_R, tot_std + call MOM_mesg(mesg) + tests_failed = tests_failed .or. .true. + endif + enddo + + call random_number( array ) ! This will also fill the halos but they will be ignored + tot_std = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec) ! Use this as the true value + ! Change the order of values in the arrya to check the sum is truly order invariant + do i = 1, n_repeat + call randomly_swap_elements(HI, array) + tot_R = reproducing_sum(array, HI%isc, HI%iec, HI%jsc, HI%jec) + if (abs(tot_R - tot_std) > 0.) then + write(mesg,'("Reordered list of random numbers changed sum",2ES13.5)') tot_R, tot_std + call MOM_mesg(mesg) + tests_failed = tests_failed .or. .true. + endif + enddo + + ! Cleanup the "input.nml" file created to boot FMS + if (PE_here() == root_PE()) then ! Can only delete the file once (i.e. on root PE) + open(newunit=io_unit, file="input.nml", status="replace", action="write") + close(io_unit, status="delete") ! we could leave this in place but that would be untidy + endif + + call MOM_infra_end + if (tests_failed) stop 1 + +contains + +!> Randomly swap elements within the computational domain of an array +subroutine randomly_swap_elements(HI, array) + type(hor_index_type), intent(in) :: HI !< The horizontal index type + real, intent(inout) :: array(HI%isd:HI%ied,HI%jsd:HI%jed) !< Array of values to play with [A] + ! Local variables + integer :: n_swaps !< Number of swaps to perform + integer :: i0, j0, i1, j1, iter ! Indices and counter + real :: r(4) ! Random numbers [nondim] + real :: v ! Value being swapped + + n_swaps = ( HI%iec - HI%isc ) * ( HI%jec - HI%jsc ) + do iter = 1, n_swaps + do + call random_number( r ) ! Random numbers 0..1 + i0 = HI%isc + int( r(1) * real( HI%iec - HI%isc ) ) + j0 = HI%jsc + int( r(2) * real( HI%jec - HI%jsc ) ) + i1 = HI%isc + int( r(3) * real( HI%iec - HI%isc ) ) + j1 = HI%jsc + int( r(4) * real( HI%jec - HI%jsc ) ) + if (i0 /= i1 .and. j0 /= j1) exit ! Repeat dice roll if points are the same + enddo + v = array(i0,j0) + array(i0,j0) = array(i1,j1) + array(i1,j1) = v + enddo +end subroutine randomly_swap_elements + +!> Generate some "spatial" data, reminiscent of benchmark topography +subroutine generate_array_of_values(D, HI, n_global) + type(hor_index_type), intent(in) :: HI !< The horizontal index type + real, intent(out) :: D(HI%isd:HI%ied,HI%jsd:HI%jed) !< Ocean bottom depth in [m] + integer, intent(in) :: n_global(2) !< Global i-, j- dimensions of domain (h-points) + ! Local variables + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] + real :: x ! A fractional position in the x-direction [nondim] + real :: y ! A fractional position in the y-direction [nondim] + integer :: i, j ! Loop indices + + PI = 4.0*atan(1.0) + + ! Calculate the depth of the bottom. + do concurrent( j=HI%jsc:HI%jec, i=HI%isc:HI%iec ) + x = real( i + HI%idg_offset ) / real( n_global(1) ) + y = real( j + HI%idg_offset ) / real( n_global(2) ) + D(i,j) = -3000.0 * ( y*(1.0 + 0.6*cos(4.0*PI*x)) & + + 0.75*exp(-6.0*y) & + + 0.05*cos(10.0*PI*x) - 0.7 ) + if (D(i,j) > 3000.0) D(i,j) = 3000.0 + if (D(i,j) < 1.) D(i,j) = 0. + enddo + +end subroutine generate_array_of_values + +end program test_reproducing_sum diff --git a/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 b/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 deleted file mode 100644 index e50f2ccf0b..0000000000 --- a/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 +++ /dev/null @@ -1,43 +0,0 @@ -module FMS_coupler_util - -use coupler_types_mod, only : coupler_2d_bc_type - -implicit none ; private - -public :: extract_coupler_values, set_coupler_values - -contains - -!> Get element and index of a boundary condition -subroutine extract_coupler_values(BC_struc, BC_index, BC_element, array_out, ilb, jlb, & - is, ie, js, je, conversion) - real, dimension(ilb:,jlb:),intent(out) :: array_out !< The array being filled with the input values - integer, intent(in) :: ilb !< Lower bounds - integer, intent(in) :: jlb !< Lower bounds - type(coupler_2d_bc_type), intent(in) :: BC_struc !< The type from which the data is being extracted - integer, intent(in) :: BC_index !< The boundary condition number being extracted - integer, intent(in) :: BC_element !< The element of the boundary condition being extracted - integer, optional, intent(in) :: is !< The i- limits of array_out to be filled - integer, optional, intent(in) :: ie !< The i- limits of array_out to be filled - integer, optional, intent(in) :: js !< The j- limits of array_out to be filled - integer, optional, intent(in) :: je !< The j- limits of array_out to be filled - real, optional, intent(in) :: conversion !< A number that every element is multiplied by -end subroutine extract_coupler_values - -!> Set element and index of a boundary condition -subroutine set_coupler_values(array_in, BC_struc, BC_index, BC_element, ilb, jlb,& - is, ie, js, je, conversion) - real, dimension(ilb:,jlb:), intent(in) :: array_in !< The array containing the values to load into the BC - integer, intent(in) :: ilb !< Lower bounds - integer, intent(in) :: jlb !< Lower bounds - type(coupler_2d_bc_type), intent(inout) :: BC_struc !< The type into which the data is being loaded - integer, intent(in) :: BC_index !< The boundary condition number being set - integer, intent(in) :: BC_element !< The element of the boundary condition being set - integer, optional, intent(in) :: is !< The i- limits of array_out to be filled - integer, optional, intent(in) :: ie !< The i- limits of array_out to be filled - integer, optional, intent(in) :: js !< The j- limits of array_out to be filled - integer, optional, intent(in) :: je !< The j- limits of array_out to be filled - real, optional, intent(in) :: conversion !< A number that every element is multiplied by -end subroutine set_coupler_values - -end module FMS_coupler_util diff --git a/config_src/external/GFDL_ocean_BGC/MOM_generic_tracer.F90 b/config_src/external/GFDL_ocean_BGC/MOM_generic_tracer.F90 new file mode 100644 index 0000000000..4111bf020f --- /dev/null +++ b/config_src/external/GFDL_ocean_BGC/MOM_generic_tracer.F90 @@ -0,0 +1,320 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Drives the generic version of tracers TOPAZ and CFC and other GFDL BGC components +module MOM_generic_tracer + +#include + +! The following macro is usually defined in but since MOM6 should not directly +! include files from FMS we replicate the macro lines here: +#ifdef NO_F2000 +#define _ALLOCATED associated +#else +#define _ALLOCATED allocated +#endif + +! ### These imports should not reach into FMS directly ### + +use MOM_ALE_sponge, only : ALE_sponge_CS +use MOM_coms, only : EFP_type, real_to_EFP +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL +use MOM_file_parser, only : param_file_type +use MOM_forcing_type, only : forcing, optics_type +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : MOM_restart_CS +use MOM_sponge, only : sponge_CS +use MOM_time_manager, only : time_type +use MOM_tracer_registry, only : tracer_registry_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +!> A state hidden in module data that is very much not allowed in MOM6 +! ### This needs to be fixed +logical :: g_registered = .false. + +public register_MOM_generic_tracer, initialize_MOM_generic_tracer +public MOM_generic_tracer_column_physics, MOM_generic_tracer_surface_state +public end_MOM_generic_tracer, MOM_generic_tracer_get +public MOM_generic_tracer_stock +public MOM_generic_flux_init +public MOM_generic_tracer_min_max +public MOM_generic_tracer_fluxes_accumulate +public register_MOM_generic_tracer_segments + +!> Control structure for generic tracers +type, public :: MOM_generic_tracer_CS ; private + character(len = 200) :: IC_file !< The file in which the generic tracer initial values can + !! be found, or an empty string for internal initialization. + logical :: Z_IC_file !< If true, the generic_tracer IC_file is in Z-space. The default is false. + real :: tracer_IC_val = 0.0 !< The initial value assigned to tracers, in + !! concentration units [conc] + real :: tracer_land_val = -1.0 !< The values of tracers used where land is masked out, in + !! concentration units [conc] + logical :: tracers_may_reinit !< If true, tracers may go through the + !! initialization code if they are not found in the restart files. + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< Restart control structure + type(ocean_OBC_type), pointer :: OBC => NULL() ! Pointer to the first element of the linked list of generic tracers. + !type(g_tracer_type), pointer :: g_tracer_list => NULL() + +end type MOM_generic_tracer_CS + +contains + +!> Initializes the generic tracer packages and adds their tracers to the list +!! Adds the tracers in the list of generic tracers to the set of MOM tracers (i.e., MOM-register them) +!! Register these tracers for restart +function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) +!subroutine register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) + type(hor_index_type), intent(in) :: HI !< Horizontal index ranges + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module + type(tracer_registry_type), pointer :: tr_Reg !< Pointer to the control structure for the tracer + !! advection and diffusion module. + type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control struct + + logical :: register_MOM_generic_tracer + + register_MOM_generic_tracer = .false. + + call MOM_error(FATAL, "register_MOM_generic_tracer should not be called with the stub code "// & + "in MOM6/config_src/external, as it does nothing. Recompile using the full MOM_generic_tracer package.") + +end function register_MOM_generic_tracer + +!> Register OBC segments for generic tracers +subroutine register_MOM_generic_tracer_segments(CS, GV, OBC, tr_Reg, param_file) + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies whether, + !! where, and what open boundary conditions are used. + type(tracer_registry_type), pointer :: tr_Reg !< Pointer to the control structure for the tracer + !! advection and diffusion module. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + +end subroutine register_MOM_generic_tracer_segments + +!> Initialize phase II: Initialize required variables for generic tracers +!! There are some steps of initialization that cannot be done in register_MOM_generic_tracer +!! This is the place and time to do them: +!! Set the grid mask and initial time for all generic tracers. +!! Diag_register them. +!! Z_diag_register them. +!! +!! This subroutine initializes the NTR tracer fields in tr(:,:,:,:) +!! and it sets up the tracer output. +subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, tv, param_file, diag, OBC, & + CS, sponge_CSp, ALE_sponge_CSp) + logical, intent(in) :: restart !< .true. if the fields have already been + !! read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic + !! variables + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(diag_ctrl), target, intent(in) :: diag !< Regulates diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies whether, + !! where, and what open boundary conditions are used. + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. + type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< Pointer to the control structure for the + !! ALE sponges. + +end subroutine initialize_MOM_generic_tracer + +!> Column physics for generic tracers. +!! Get the coupler values for generic tracers that exchange with atmosphere +!! Update generic tracer concentration fields from sources and sinks. +!! Vertically diffuse generic tracer concentration fields. +!! Update generic tracers from bottom and their bottom reservoir. +!! +!! This subroutine applies diapycnal diffusion and any other column +!! tracer physics or chemistry to the tracers from this file. +!! CFCs are relatively simple, as they are passive tracers. with only a surface +!! flux as a source. +subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, US, CS, tv, optics, & + evap_CFL_limit, minimum_forcing_depth) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new !< Layer thickness after entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: ea !< The amount of fluid entrained from the layer + !! above during this call [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: eb !< The amount of fluid entrained from the layer + !! below during this call [H ~> m or kg m-2]. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Hml !< Mixed layer depth [Z ~> m] + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + type(optics_type), intent(in) :: optics !< The structure containing optical properties. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep [nondim] + ! Stored previously in diabatic CS. + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which fluxes + !! can be applied [H ~> m or kg m-2] + ! Stored previously in diabatic CS. + +end subroutine MOM_generic_tracer_column_physics + +!> This subroutine calculates mass-weighted integral on the PE either +!! of all available tracer concentrations, or of a tracer that is +!! being requested specifically, returning the number of stocks it has +!! calculated. If the stock_index is present, only the stock corresponding +!! to that coded index is returned. +function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_index) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< The coded index of a specific stock + !! being sought. + integer :: MOM_generic_tracer_stock !< Return value, the + !! number of stocks calculated here. + + integer :: m + MOM_generic_tracer_stock = 0 + + ! These should never be used, but they are set to avoid compile-time warnings + do m=1,size(names) ; names(m) = "" ; enddo + do m=1,size(units) ; units(m) = "" ; enddo + do m=1,size(stocks) ; stocks(m) = real_to_EFP(0.0) ; enddo + +end function MOM_generic_tracer_stock + +!> This subroutine finds the global min and max of either of all available +!! tracer concentrations, or of a tracer that is being requested specifically, +!! returning the number of tracers it has evaluated. +!! It also optionally returns the locations of the extrema. +function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, G, CS, names, units, & + xgmin, ygmin, zgmin, xgmax, ygmax, zgmax) + integer, intent(in) :: ind_start !< The index of the tracer to start with + logical, dimension(:), intent(out) :: got_minmax !< Indicates whether the global min and + !! max are found for each tracer + real, dimension(:), intent(out) :: gmin !< Global minimum of each tracer [conc] + real, dimension(:), intent(out) :: gmax !< Global maximum of each tracer [conc] + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. + real, dimension(:), optional, intent(out) :: xgmin !< The x-position of the global minimum in the + !! units of G%geoLonT, often [degrees_E] or [km] or [m] + real, dimension(:), optional, intent(out) :: ygmin !< The y-position of the global minimum in the + !! units of G%geoLatT, often [degrees_N] or [km] or [m] + real, dimension(:), optional, intent(out) :: zgmin !< The z-position of the global minimum [layer] + real, dimension(:), optional, intent(out) :: xgmax !< The x-position of the global maximum in the + !! units of G%geoLonT, often [degrees_E] or [km] or [m] + real, dimension(:), optional, intent(out) :: ygmax !< The y-position of the global maximum in the + !! units of G%geoLatT, often [degrees_N] or [km] or [m] + real, dimension(:), optional, intent(out) :: zgmax !< The z-position of the global maximum [layer] + integer :: MOM_generic_tracer_min_max !< Return value, the + !! number of tracers done here. + + integer :: m + + MOM_generic_tracer_min_max = 0 + + ! These should never be used, but they are set to avoid compile-time warnings. Note that the minimum values + ! are delibarately set to be larger than the maximum values. + got_minmax(:) = .false. + gmax(:) = -huge(gmax) + gmin(:) = huge(gmin) + do m=1,size(names) ; names(m) = "" ; enddo + do m=1,size(units) ; units(m) = "" ; enddo + if (present(xgmin)) xgmin(:) = 0.0 + if (present(ygmin)) ygmin(:) = 0.0 + if (present(zgmin)) zgmin(:) = 0.0 + if (present(xgmax)) xgmax(:) = 0.0 + if (present(ygmax)) ygmax(:) = 0.0 + if (present(zgmax)) zgmax(:) = 0.0 + +end function MOM_generic_tracer_min_max + +!> This subroutine calculates the surface state and sets coupler values for +!! those generic tracers that have flux exchange with atmosphere. +!! +!! This subroutine sets up the fields that the coupler needs to calculate the +!! CFC fluxes between the ocean and atmosphere. +subroutine MOM_generic_tracer_surface_state(sfc_state, h, G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + +end subroutine MOM_generic_tracer_surface_state + +!ALL PE subroutine on Ocean! Due to otpm design the fluxes should be initialized like this on ALL PE's! +subroutine MOM_generic_flux_init(verbosity) + integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity. + +end subroutine MOM_generic_flux_init + +subroutine MOM_generic_tracer_fluxes_accumulate(flux_tmp, weight) + type(forcing), intent(in) :: flux_tmp !< A structure containing pointers to + !! thermodynamic and tracer forcing fields. + real, intent(in) :: weight !< A weight for accumulating this flux [nondim] + +end subroutine MOM_generic_tracer_fluxes_accumulate + +!> Copy the requested tracer into an array. +subroutine MOM_generic_tracer_get(name,member,array, CS) + character(len=*), intent(in) :: name !< Name of requested tracer. + character(len=*), intent(in) :: member !< The tracer element to return. + real, dimension(:,:,:), intent(out) :: array !< Array filled by this routine, in arbitrary units [A] + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + + ! Local variables + real, dimension(:,:,:), pointer :: array_ptr ! The tracer in the generic tracer structures, in + ! arbitrary units [A] + character(len=128), parameter :: sub_name = 'MOM_generic_tracer_get' + + array(:,:,:) = huge(array) + +end subroutine MOM_generic_tracer_get + +!> This subroutine deallocates the memory owned by this module. +subroutine end_MOM_generic_tracer(CS) + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + +end subroutine end_MOM_generic_tracer + +!---------------------------------------------------------------- +! Niki Zadeh +! +! +! William Cooke +! +! +! +! This module drives the generic version of tracers TOPAZ and CFC +! +!---------------------------------------------------------------- + +end module MOM_generic_tracer diff --git a/config_src/external/GFDL_ocean_BGC/generic_tracer.F90 b/config_src/external/GFDL_ocean_BGC/generic_tracer.F90 deleted file mode 100644 index 6bd445ae8b..0000000000 --- a/config_src/external/GFDL_ocean_BGC/generic_tracer.F90 +++ /dev/null @@ -1,149 +0,0 @@ -!> A non-functioning template of the GFDL ocean BGC -module generic_tracer - - use time_manager_mod, only : time_type - use coupler_types_mod, only : coupler_2d_bc_type - - use g_tracer_utils, only : g_tracer_type, g_diag_type - - implicit none ; private - - public generic_tracer_register - public generic_tracer_init - public generic_tracer_register_diag - public generic_tracer_source - public generic_tracer_update_from_bottom - public generic_tracer_coupler_get - public generic_tracer_coupler_set - public generic_tracer_end - public generic_tracer_get_list - public do_generic_tracer - public generic_tracer_vertdiff_G - public generic_tracer_get_diag_list - public generic_tracer_coupler_accumulate - - !> Turn on generic tracers (note dangerous use of module data) - logical :: do_generic_tracer = .true. - -contains - - !> Unknown - subroutine generic_tracer_register - end subroutine generic_tracer_register - - !> Initialize generic tracers - subroutine generic_tracer_init(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,axes,grid_tmask,grid_kmt,init_time) - integer, intent(in) :: isc !< Computation start index in i direction - integer, intent(in) :: iec !< Computation end index in i direction - integer, intent(in) :: jsc !< Computation start index in j direction - integer, intent(in) :: jec !< Computation end index in j direction - integer, intent(in) :: isd !< Data start index in i direction - integer, intent(in) :: ied !< Data end index in i direction - integer, intent(in) :: jsd !< Data start index in j direction - integer, intent(in) :: jed !< Data end index in j direction - integer, intent(in) :: nk !< Number of levels in k direction - integer, intent(in) :: ntau !< The number of tracer time levels (always 1 for MOM6) - integer, intent(in) :: axes(3) !< Domain axes? - type(time_type), intent(in) :: init_time !< Time - real, dimension(:,:,:),target, intent(in) :: grid_tmask !< Mask - integer, dimension(:,:) , intent(in) :: grid_kmt !< Number of wet cells in column - end subroutine generic_tracer_init - - !> Unknown - subroutine generic_tracer_register_diag - end subroutine generic_tracer_register_diag - - !> Get coupler values - subroutine generic_tracer_coupler_get(IOB_struc) - type(coupler_2d_bc_type), intent(in) :: IOB_struc !< Ice Ocean Boundary flux structure - end subroutine generic_tracer_coupler_get - - !> Unknown - subroutine generic_tracer_coupler_accumulate(IOB_struc, weight, model_time) - type(coupler_2d_bc_type), intent(in) :: IOB_struc !< Ice Ocean Boundary flux structure - real, intent(in) :: weight !< A weight for accumulating these fluxes - type(time_type), optional,intent(in) :: model_time !< Time - end subroutine generic_tracer_coupler_accumulate - - !> Calls the corresponding generic_X_update_from_source routine for each package X - subroutine generic_tracer_source(Temp,Salt,rho_dzt,dzt,hblt_depth,ilb,jlb,tau,dtts,& - grid_dat,model_time,nbands,max_wavelength_band,sw_pen_band,opacity_band,internal_heat,& - frunoff,grid_ht, current_wave_stress, sosga) - real, dimension(ilb:,jlb:,:), intent(in) :: Temp !< Potential temperature [deg C] - real, dimension(ilb:,jlb:,:), intent(in) :: Salt !< Salinity [psu] - real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt !< Mass per unit area of each layer [kg m-2] - real, dimension(ilb:,jlb:,:), intent(in) :: dzt !< Ocean layer thickness [m] - real, dimension(ilb:,jlb:), intent(in) :: hblt_depth !< Boundary layer depth [m] - integer, intent(in) :: ilb !< Lower bounds of x extent of input arrays on data domain - integer, intent(in) :: jlb !< Lower bounds of y extent of input arrays on data domain - integer, intent(in) :: tau !< Time step index of %field - real, intent(in) :: dtts !< The time step for this call [s] - real, dimension(ilb:,jlb:), intent(in) :: grid_dat !< Grid cell areas [m2] - type(time_type), intent(in) :: model_time !< Time - integer, intent(in) :: nbands !< The number of bands of penetrating shortwave radiation - real, dimension(:), intent(in) :: max_wavelength_band !< The maximum wavelength in each band - !! of penetrating shortwave radiation [nm] - real, dimension(:,ilb:,jlb:), intent(in) :: sw_pen_band !< Penetrating shortwave radiation per band [W m-2]. - !! The wavelength or angular direction band is the first index. - real, dimension(:,ilb:,jlb:,:), intent(in) :: opacity_band !< Opacity of seawater averaged over each band [m-1]. - !! The wavelength or angular direction band is the first index. - real, dimension(ilb:,jlb:),optional, intent(in) :: internal_heat !< Any internal or geothermal heat - !! sources that are applied to the ocean integrated - !! over this timestep [degC kg m-2] - real, dimension(ilb:,jlb:),optional, intent(in) :: frunoff !< Rate of iceberg calving [kg m-2 s-1] - real, dimension(ilb:,jlb:),optional, intent(in) :: grid_ht !< Unknown, and presently unused by MOM6 - real, dimension(ilb:,jlb:),optional , intent(in) :: current_wave_stress !< Unknown, and presently unused by MOM6 - real, optional , intent(in) :: sosga !< Global average sea surface salinity [ppt] - end subroutine generic_tracer_source - - !> Update the tracers from bottom fluxes - subroutine generic_tracer_update_from_bottom(dt, tau, model_time) - real, intent(in) :: dt !< Time step increment [s] - integer, intent(in) :: tau !< Time step index used for the concentration field - type(time_type), intent(in) :: model_time !< Time - end subroutine generic_tracer_update_from_bottom - - !> Vertically diffuse all generic tracers for GOLD ocean - subroutine generic_tracer_vertdiff_G(h_old, ea, eb, dt, kg_m2_to_H, m_to_H, tau) - real, dimension(:,:,:), intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2] - real, dimension(:,:,:), intent(in) :: ea !< The amount of fluid entrained from the layer - !! above during this call [H ~> m or kg m-2] - real, dimension(:,:,:), intent(in) :: eb !< The amount of fluid entrained from the layer - !! below during this call [H ~> m or kg m-2] - real, intent(in) :: dt !< The amount of time covered by this call [s] - real, intent(in) :: kg_m2_to_H !< A unit conversion factor from mass per unit - !! area to thickness units [H m2 kg-1 ~> m3 kg-1 or 1] - real, intent(in) :: m_to_H !< A unit conversion factor from heights to - !! thickness units [H m-1 ~> 1 or kg m-3] - integer, intent(in) :: tau !< The time level to work on (always 1 for MOM6) - end subroutine generic_tracer_vertdiff_G - - !> Set the coupler values for each generic tracer - subroutine generic_tracer_coupler_set(IOB_struc, ST,SS,rho,ilb,jlb,tau, dzt, sosga,model_time) - type(coupler_2d_bc_type), intent(inout) :: IOB_struc !< Ice Ocean Boundary flux structure - integer, intent(in) :: ilb !< Lower bounds of x extent of input arrays on data domain - integer, intent(in) :: jlb !< Lower bounds of y extent of input arrays on data domain - integer, intent(in) :: tau !< Time step index of %field - real, dimension(ilb:,jlb:), intent(in) :: ST !< Sea surface temperature [degC] - real, dimension(ilb:,jlb:), intent(in) :: SS !< Sea surface salinity [ppt] - real, dimension(ilb:,jlb:,:,:), intent(in) :: rho !< Ocean density [kg m-3] - real, dimension(ilb:,jlb:,:), optional, intent(in) :: dzt !< Layer thickness [m] - real, optional, intent(in) :: sosga !< Global mean sea surface salinity [ppt] - type(time_type),optional, intent(in) :: model_time !< Time - end subroutine generic_tracer_coupler_set - - !> End this module by calling the corresponding generic_X_end for each package X - subroutine generic_tracer_end - end subroutine generic_tracer_end - - !> Get a pointer to the head of the generic tracers list - subroutine generic_tracer_get_list(list) - type(g_tracer_type), pointer :: list !< Pointer to head of the linked list - end subroutine generic_tracer_get_list - - !> Unknown - subroutine generic_tracer_get_diag_list(list) - type(g_diag_type), pointer :: list !< Pointer to head of the linked list - end subroutine generic_tracer_get_diag_list - -end module generic_tracer diff --git a/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 deleted file mode 100644 index de513a7f11..0000000000 --- a/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 +++ /dev/null @@ -1,312 +0,0 @@ -!> g_tracer_utils module consists of core utility subroutines to be used by -!! all generic tracer modules. These include the lowest level functions -!! for adding, allocating memory, and record keeping of individual generic -!! tracers irrespective of their physical/chemical nature. -module g_tracer_utils - - use coupler_types_mod, only: coupler_2d_bc_type - use time_manager_mod, only : time_type - use field_manager_mod, only: fm_string_len - use MOM_diag_mediator, only : g_diag_ctrl=>diag_ctrl - -implicit none ; private - - !> Each generic tracer node is an instant of a FORTRAN type with the following member variables. - !! These member fields are supposed to uniquely define an individual tracer. - !! One such type shall be instantiated for EACH individual tracer. - type g_tracer_type - !> Tracer concentration field in space (and time) - !! MOM keeps the prognostic tracer fields at 3 time levels, hence 4D. - real, pointer, dimension(:,:,:,:) :: field => NULL() - !> Tracer concentration in river runoff - real, allocatable, dimension(:,:) :: trunoff - logical :: requires_restart = .true. !< Unknown - character(len=fm_string_len) :: src_file !< Tracer source filename - character(len=fm_string_len) :: src_var_name !< Tracer source variable name - character(len=fm_string_len) :: src_var_unit !< Tracer source variable units - character(len=fm_string_len) :: src_var_gridspec !< Tracer source grid file name - integer :: src_var_record !< Unknown - logical :: requires_src_info = .false. !< Unknown - real :: src_var_unit_conversion = 1.0 !< This factor depends on the tracer. Ask Jasmin - real :: src_var_valid_min = 0.0 !< Unknown - end type g_tracer_type - - !> Unknown - type g_diag_type - integer :: dummy !< A dummy member, not part of the API - end type g_diag_type - - !> The following type fields are common to ALL generic tracers and hence has to be instantiated only once - type g_tracer_common -! type(g_diag_ctrl) :: diag_CS !< Unknown - !> Domain extents - integer :: isd !< Start index of the data domain in the i-direction - integer :: jsd !< Start index of the data domain in the j-direction - end type g_tracer_common - - !> Unknown dangerous module data! - type(g_tracer_common), target, save :: g_tracer_com - - public :: g_tracer_type - public :: g_tracer_flux_init - public :: g_tracer_set_values - public :: g_tracer_get_values - public :: g_tracer_get_pointer - public :: g_tracer_get_common - public :: g_tracer_set_common - public :: g_tracer_set_csdiag - public :: g_tracer_send_diag - public :: g_tracer_get_name - public :: g_tracer_get_alias - public :: g_tracer_get_next - public :: g_tracer_is_prog - public :: g_diag_type - - !> Set the values of various (array) members of the tracer node g_tracer_type - !! - !! This function is overloaded to set the values of the following member variables - interface g_tracer_set_values - module procedure g_tracer_set_real - module procedure g_tracer_set_2D - module procedure g_tracer_set_3D - module procedure g_tracer_set_4D - end interface - - !> Reverse of interface g_tracer_set_values for getting the tracer member arrays in the argument value - !! - !! This means "get the values of array %field_name for tracer tracer_name and put them in argument array_out" - interface g_tracer_get_values - module procedure g_tracer_get_4D_val - module procedure g_tracer_get_3D_val - module procedure g_tracer_get_2D_val - module procedure g_tracer_get_real - module procedure g_tracer_get_string - end interface - - !> Return the pointer to the requested field of a particular tracer - !! - !! This means "get the pointer of array %field_name for tracer tracer_name in argument array_ptr" - interface g_tracer_get_pointer - module procedure g_tracer_get_4D - module procedure g_tracer_get_3D - module procedure g_tracer_get_2D - end interface - -contains - - !> Unknown - subroutine g_tracer_flux_init(g_tracer) - type(g_tracer_type), pointer :: g_tracer !< Pointer to this tracer node - end subroutine g_tracer_flux_init - - !> Unknown - subroutine g_tracer_set_csdiag(diag_CS) - type(g_diag_ctrl), target,intent(in) :: diag_CS !< Unknown - end subroutine g_tracer_set_csdiag - - subroutine g_tracer_set_common(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,axes,grid_tmask,grid_kmt,init_time) - integer, intent(in) :: isc !< Computation start index in i direction - integer, intent(in) :: iec !< Computation end index in i direction - integer, intent(in) :: jsc !< Computation start index in j direction - integer, intent(in) :: jec !< Computation end index in j direction - integer, intent(in) :: isd !< Data start index in i direction - integer, intent(in) :: ied !< Data end index in i direction - integer, intent(in) :: jsd !< Data start index in j direction - integer, intent(in) :: jed !< Data end index in j direction - integer, intent(in) :: nk !< Number of levels in k direction - integer, intent(in) :: ntau !< Unknown - integer, intent(in) :: axes(3) !< Domain axes? - real, dimension(isd:,jsd:,:),intent(in) :: grid_tmask !< Unknown - integer,dimension(isd:,jsd:),intent(in) :: grid_kmt !< Unknown - type(time_type), intent(in) :: init_time !< Unknown - end subroutine g_tracer_set_common - - subroutine g_tracer_get_common(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,& - axes,grid_tmask,grid_mask_coast,grid_kmt,init_time,diag_CS) - integer, intent(out) :: isc !< Computation start index in i direction - integer, intent(out) :: iec !< Computation end index in i direction - integer, intent(out) :: jsc !< Computation start index in j direction - integer, intent(out) :: jec !< Computation end index in j direction - integer, intent(out) :: isd !< Data start index in i direction - integer, intent(out) :: ied !< Data end index in i direction - integer, intent(out) :: jsd !< Data start index in j direction - integer, intent(out) :: jed !< Data end index in j direction - integer, intent(out) :: nk !< Number of levels in k direction - integer, intent(out) :: ntau !< Unknown - integer, optional, intent(out) :: axes(3) !< Unknown - type(time_type), optional, intent(out) :: init_time !< Unknown - real, optional, dimension(:,:,:), pointer :: grid_tmask !< Unknown - integer, optional, dimension(:,:), pointer :: grid_mask_coast !< Unknown - integer, optional, dimension(:,:), pointer :: grid_kmt !< Unknown - type(g_diag_ctrl), optional, pointer :: diag_CS !< Unknown - end subroutine g_tracer_get_common - - !> Unknown - subroutine g_tracer_get_4D(g_tracer_list,name,member,array_ptr) - character(len=*), intent(in) :: name !< Unknown - character(len=*), intent(in) :: member !< Unknown - type(g_tracer_type), pointer :: g_tracer_list !< Unknown - real, dimension(:,:,:,:), pointer :: array_ptr !< Unknown - end subroutine g_tracer_get_4D - - !> Unknown - subroutine g_tracer_get_3D(g_tracer_list,name,member,array_ptr) - character(len=*), intent(in) :: name !< Unknown - character(len=*), intent(in) :: member !< Unknown - type(g_tracer_type), pointer :: g_tracer_list !< Unknown - real, dimension(:,:,:), pointer :: array_ptr !< Unknown - end subroutine g_tracer_get_3D - - !> Unknown - subroutine g_tracer_get_2D(g_tracer_list,name,member,array_ptr) - character(len=*), intent(in) :: name !< Unknown - character(len=*), intent(in) :: member !< Unknown - type(g_tracer_type), pointer :: g_tracer_list !< Unknown - real, dimension(:,:), pointer :: array_ptr !< Unknown - end subroutine g_tracer_get_2D - - !> Unknown - subroutine g_tracer_get_4D_val(g_tracer_list,name,member,array,isd,jsd) - character(len=*), intent(in) :: name !< Unknown - character(len=*), intent(in) :: member !< Unknown - type(g_tracer_type), pointer :: g_tracer_list !< Unknown - integer, intent(in) :: isd !< Unknown - integer, intent(in) :: jsd !< Unknown - real, dimension(isd:,jsd:,:,:), intent(out):: array !< Unknown - end subroutine g_tracer_get_4D_val - - !> Unknown - subroutine g_tracer_get_3D_val(g_tracer_list,name,member,array,isd,jsd,ntau,positive) - character(len=*), intent(in) :: name !< Unknown - character(len=*), intent(in) :: member !< Unknown - type(g_tracer_type), pointer :: g_tracer_list !< Unknown - integer, intent(in) :: isd !< Unknown - integer, intent(in) :: jsd !< Unknown - integer, optional, intent(in) :: ntau !< Unknown - logical, optional, intent(in) :: positive !< Unknown - real, dimension(isd:,jsd:,:), intent(out):: array !< Unknown - integer :: tau - character(len=fm_string_len), parameter :: sub_name = 'g_tracer_get_3D_val' - end subroutine g_tracer_get_3D_val - - !> Unknown - subroutine g_tracer_get_2D_val(g_tracer_list,name,member,array,isd,jsd) - character(len=*), intent(in) :: name !< Unknown - character(len=*), intent(in) :: member !< Unknown - type(g_tracer_type), pointer :: g_tracer_list !< Unknown - integer, intent(in) :: isd !< Unknown - integer, intent(in) :: jsd !< Unknown - real, dimension(isd:,jsd:), intent(out):: array !< Unknown - end subroutine g_tracer_get_2D_val - - !> Unknown - subroutine g_tracer_get_real(g_tracer_list,name,member,value) - character(len=*), intent(in) :: name !< Unknown - character(len=*), intent(in) :: member !< Unknown - type(g_tracer_type), pointer :: g_tracer_list !< Unknown - real, intent(out):: value !< Unknown - end subroutine g_tracer_get_real - - !> Unknown - subroutine g_tracer_get_string(g_tracer_list,name,member,string) - character(len=*), intent(in) :: name !< Unknown - character(len=*), intent(in) :: member !< Unknown - type(g_tracer_type), pointer :: g_tracer_list !< Unknown - character(len=fm_string_len), intent(out) :: string !< Unknown - end subroutine g_tracer_get_string - - !> Unknown - subroutine g_tracer_set_2D(g_tracer_list,name,member,array,isd,jsd,weight) - character(len=*), intent(in) :: name !< Unknown - character(len=*), intent(in) :: member !< Unknown - type(g_tracer_type), pointer :: g_tracer_list !< Unknown - integer, intent(in) :: isd !< Unknown - integer, intent(in) :: jsd !< Unknown - real, dimension(isd:,jsd:),intent(in) :: array !< Unknown - real, optional ,intent(in) :: weight !< Unknown - end subroutine g_tracer_set_2D - - !> Unknown - subroutine g_tracer_set_3D(g_tracer_list,name,member,array,isd,jsd,ntau) - character(len=*), intent(in) :: name !< Unknown - character(len=*), intent(in) :: member !< Unknown - type(g_tracer_type), pointer :: g_tracer_list !< Unknown - integer, intent(in) :: isd !< Unknown - integer, intent(in) :: jsd !< Unknown - integer, optional, intent(in) :: ntau !< Unknown - real, dimension(isd:,jsd:,:), intent(in) :: array !< Unknown - end subroutine g_tracer_set_3D - - !> Unknown - subroutine g_tracer_set_4D(g_tracer_list,name,member,array,isd,jsd) - character(len=*), intent(in) :: name !< Unknown - character(len=*), intent(in) :: member !< Unknown - type(g_tracer_type), pointer :: g_tracer_list !< Unknown - integer, intent(in) :: isd !< Unknown - integer, intent(in) :: jsd !< Unknown - real, dimension(isd:,jsd:,:,:), intent(in) :: array !< Unknown - end subroutine g_tracer_set_4D - - !> Unknown - subroutine g_tracer_set_real(g_tracer_list,name,member,value) - character(len=*), intent(in) :: name !< Unknown - character(len=*), intent(in) :: member !< Unknown - type(g_tracer_type), pointer :: g_tracer_list !< Unknown - real, intent(in) :: value !< Unknown - end subroutine g_tracer_set_real - - subroutine g_tracer_send_diag(g_tracer_list,model_time,tau) - type(g_tracer_type), pointer :: g_tracer_list !< pointer to the head of the generic tracer list - type(g_tracer_type), pointer :: g_tracer !< Pointer to tracer node - type(time_type), intent(in) :: model_time !< Time - integer, intent(in) :: tau !< The time step for the %field 4D field to be reported - end subroutine g_tracer_send_diag - - !> Unknown - subroutine g_tracer_get_name(g_tracer,string) - type(g_tracer_type), pointer :: g_tracer !< Unknown - character(len=*), intent(out) :: string !< Unknown - end subroutine g_tracer_get_name - - !> Unknown - subroutine g_tracer_get_alias(g_tracer,string) - type(g_tracer_type), pointer :: g_tracer !< Unknown - character(len=*), intent(out) :: string !< Unknown - end subroutine g_tracer_get_alias - - !> Is the tracer prognostic? - function g_tracer_is_prog(g_tracer) - logical :: g_tracer_is_prog - type(g_tracer_type), pointer :: g_tracer !< Pointer to tracer node - end function g_tracer_is_prog - - !> get the next tracer in the list - subroutine g_tracer_get_next(g_tracer,g_tracer_next) - type(g_tracer_type), pointer :: g_tracer !< Pointer to tracer node - type(g_tracer_type), pointer :: g_tracer_next !< Pointer to the next tracer node in the list - end subroutine g_tracer_get_next - - !>Vertical Diffusion of a tracer node - !! - !! This subroutine solves a tridiagonal equation to find and set values of vertically diffused field - !! for a tracer node.This is ported from GOLD (vertdiff) and simplified - !! Since the surface flux from the atmosphere (%stf) has the units of mol/m^2/sec the resulting - !! tracer concentration has units of mol/Kg - subroutine g_tracer_vertdiff_G(g_tracer, h_old, ea, eb, dt, kg_m2_to_H, m_to_H, tau, mom) - type(g_tracer_type), pointer :: g_tracer !< Unknown - !> Layer thickness before entrainment, in m or kg m-2. - real, dimension(g_tracer_com%isd:,g_tracer_com%jsd:,:), intent(in) :: h_old - !> The amount of fluid entrained from the layer above, in H. - real, dimension(g_tracer_com%isd:,g_tracer_com%jsd:,:), intent(in) :: ea - !> The amount of fluid entrained from the layer below, in H. - real, dimension(g_tracer_com%isd:,g_tracer_com%jsd:,:), intent(in) :: eb - real, intent(in) :: dt !< The amount of time covered by this call, in s. - real, intent(in) :: kg_m2_to_H !< A conversion factor that translates kg m-2 into - !! the units of h_old (H) - real, intent(in) :: m_to_H !< A conversion factor that translates m into the units - !! of h_old (H). - integer, intent(in) :: tau !< Unknown - logical, intent(in), optional :: mom !< Unknown - end subroutine g_tracer_vertdiff_G - -end module g_tracer_utils diff --git a/config_src/external/MARBL/README.md b/config_src/external/MARBL/README.md new file mode 100644 index 0000000000..f19f76dec8 --- /dev/null +++ b/config_src/external/MARBL/README.md @@ -0,0 +1,6 @@ +MARBL +===== + +These APIs reflect those for the MARBL library available at https://github.com/marbl-ecosys/MARBL + +The modules in this directory do not do any computations. They simply reflect the APIs of the above package. diff --git a/config_src/external/MARBL/marbl_constants_mod.F90 b/config_src/external/MARBL/marbl_constants_mod.F90 new file mode 100644 index 0000000000..1181a50e31 --- /dev/null +++ b/config_src/external/MARBL/marbl_constants_mod.F90 @@ -0,0 +1,15 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> A non-functioning template of the MARBL constants module +module marbl_constants_mod + + implicit none + private + + !> Molecular weight of iron + real, public, parameter :: molw_Fe = 55.845 + +end module marbl_constants_mod + diff --git a/config_src/external/MARBL/marbl_interface.F90 b/config_src/external/MARBL/marbl_interface.F90 new file mode 100644 index 0000000000..4b57472798 --- /dev/null +++ b/config_src/external/MARBL/marbl_interface.F90 @@ -0,0 +1,149 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> A non-functioning template of the MARBL interface +module marbl_interface + + use MOM_error_handler, only : MOM_error, FATAL + use marbl_logging, only : marbl_log_type + use marbl_interface_public_types, only : marbl_forcing_fields_type + use marbl_interface_public_types, only : marbl_tracer_metadata_type + use marbl_interface_public_types, only : marbl_saved_state_type + use marbl_interface_public_types, only : marbl_diagnostics_type + use marbl_interface_public_types, only : marbl_domain_type + use marbl_interface_public_types, only : marbl_output_for_GCM_type + implicit none + private ! Only want marbl_interface_class to be public, not supporting functions + + !> A non-functioning template of the MARBL_interface class + !! + !> All variables are dummy representations of actual members of the real marbl_interface_class + !! that are used in the MARBL tracer routines. + type, public :: marbl_interface_class + type(marbl_log_type) :: StatusLog !< dummy log + type(marbl_forcing_fields_type), allocatable :: surface_flux_forcings(:) !< dummy forcing array + type(marbl_forcing_fields_type), allocatable :: interior_tendency_forcings(:) !< dummy forcing array + type(marbl_tracer_metadata_type), allocatable :: tracer_metadata(:) !< dummy metadata array + type(marbl_domain_type) :: domain !< dummy domain + type(marbl_saved_state_type) :: surface_flux_saved_state !< dummy saved state + type(marbl_saved_state_type) :: interior_tendency_saved_state !< dummy saved state + type(marbl_diagnostics_type) :: surface_flux_diags !< dummy diagnostics + type(marbl_diagnostics_type) :: interior_tendency_diags !< dummy diagnostics + type(marbl_output_for_GCM_type) :: surface_flux_output !< dummy output + type(marbl_output_for_GCM_type) :: interior_tendency_output !< dummy output + real, allocatable :: tracers(:,:) !< dummy tracer array + real, allocatable :: tracers_at_surface(:,:) !< dummy tracer surface array + real, allocatable :: bot_flux_to_tend(:) !< dummy array for bot flux to tendency wgts + real, allocatable :: surface_fluxes(:,:) !< dummy fluxes + real, allocatable :: interior_tendencies(:,:) !< dummy tendencies + contains + procedure, public :: put_setting !< dummy put_setting routine + procedure, public :: get_setting !< dummy get_setting routine + procedure, public :: init !< dummy init routine + procedure, public :: compute_totChl !< dummy routine to compute total Chlorophyll + procedure, public :: surface_flux_compute !< dummy surface flux routine + procedure, public :: interior_tendency_compute !< dummy interior tendency routine + procedure, public :: add_output_for_GCM !< dummy add_output_for_GCM routine + procedure, public :: shutdown !< dummy shutdown routine + end type marbl_interface_class + + !> Error message that appears if the dummy interface is called + character(len=*), parameter :: error_msg = "MOM6 built the MARBL stubs rather than the full library" + +contains + + !> Dummy version of MARBL's put_setting() function + subroutine put_setting(self, str_in) + class(marbl_interface_class), intent(in) :: self + character(len=*), intent(in) :: str_in + + call MOM_error(FATAL, error_msg) + end subroutine put_setting + + !> Dummy version of MARBL's get_setting() function + subroutine get_setting(self, str_in, log_out) + class(marbl_interface_class), intent(in) :: self + character(len=*), intent(in) :: str_in + logical, intent(out) :: log_out + + log_out = .false. + call MOM_error(FATAL, error_msg) + end subroutine get_setting + + !> Dummy version of MARBL's init() function + subroutine init(self, & + gcm_num_levels, & + gcm_num_PAR_subcols, & + gcm_num_elements_surface_flux, & + gcm_delta_z, & + gcm_zw, & + gcm_zt, & + unit_system_opt, & + lgcm_has_global_ops) + + class(marbl_interface_class), intent(inout) :: self + integer, intent(in) :: gcm_num_levels + integer, intent(in) :: gcm_num_PAR_subcols + integer, intent(in) :: gcm_num_elements_surface_flux + real, intent(in) :: gcm_delta_z(gcm_num_levels) + real, intent(in) :: gcm_zw(gcm_num_levels) + real, intent(in) :: gcm_zt(gcm_num_levels) + character(len=*), intent(in) :: unit_system_opt + logical, intent(in) :: lgcm_has_global_ops + + call MOM_error(FATAL, error_msg) + end subroutine init + + !> Dummy version of MARBL's compute_totChl() function + subroutine compute_totChl(self) + + class(marbl_interface_class), intent(inout) :: self + + call MOM_error(FATAL, error_msg) + + end subroutine compute_totChl + + !> Dummy version of MARBL's surface_flux_compute() function + subroutine surface_flux_compute(self) + + class(marbl_interface_class), intent(inout) :: self + + call MOM_error(FATAL, error_msg) + + end subroutine surface_flux_compute + + !> Dummy version of MARBL's interior_tendency_compute() function + subroutine interior_tendency_compute(self) + + class(marbl_interface_class), intent(inout) :: self + + call MOM_error(FATAL, error_msg) + + end subroutine interior_tendency_compute + + !> Dummy version of MARBL's add_output_for_GCM() function + subroutine add_output_for_GCM(self, num_elements, field_name, output_id, field_source, num_levels) + + class (marbl_interface_class), intent(inout) :: self + integer, intent(in) :: num_elements + character(len=*), intent(in) :: field_name + integer, intent(out) :: output_id + character(len=*), intent(out) :: field_source + integer, optional, intent(in) :: num_levels + + output_id = 0 + field_source = "" + + end subroutine add_output_for_GCM + + !> Dummy version of MARBL's shutdown() function + subroutine shutdown(self) + + class(marbl_interface_class), intent(inout) :: self + + call MOM_error(FATAL, error_msg) + + end subroutine shutdown + +end module marbl_interface diff --git a/config_src/external/MARBL/marbl_interface_public_types.F90 b/config_src/external/MARBL/marbl_interface_public_types.F90 new file mode 100644 index 0000000000..98f83b529b --- /dev/null +++ b/config_src/external/MARBL/marbl_interface_public_types.F90 @@ -0,0 +1,94 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> A non-functioning template of the public structures provided through MARBL interface +module marbl_interface_public_types + + use marbl_logging, only : marbl_log_type + + implicit none + private ! Only want a few types to be public + + !> A non-functioning template of MARBL diagnostic type + type :: marbl_single_diagnostic_type + character(len=0) :: long_name !< dummy name + character(len=0) :: short_name !< dummy name + character(len=0) :: units !< dummy units + character(len=0) :: vertical_grid !< dummy grid + logical :: compute_now !< dummy flag + logical :: ltruncated_vertical_extent !< dummy flag + integer :: ref_depth !< dummy depth + real, allocatable, dimension(:) :: field_2d !< dummy field + real, allocatable, dimension(:,:) :: field_3d !< dummy field + end type marbl_single_diagnostic_type + + !> A non-functioning template of MARBL diagnostic type + type, public :: marbl_diagnostics_type + type(marbl_single_diagnostic_type), dimension(:), pointer :: diags => NULL() !< dummy point + end type marbl_diagnostics_type + + !> A non-functioning template of MARBL saved state type + type :: marbl_single_saved_state_type + integer :: rank !< dummy rank + character(len=0) :: short_name !< dummy name + character(len=0) :: units !< dummy units + character(len=0) :: vertical_grid !< dummy grid + real, allocatable :: field_2d(:) !< dummy field + real, allocatable :: field_3d(:,:) !< dummy field + end type marbl_single_saved_state_type + + !> A non-functioning template of MARBL saved state type + type, public :: marbl_saved_state_type + integer :: saved_state_cnt !< dummy counter + type(marbl_single_saved_state_type), dimension(:), pointer :: state => NULL() !< dummy pointer + end type marbl_saved_state_type + + !> A non-functioning template of MARBL forcing metadata type + type :: marbl_forcing_fields_metadata_type + character(len=0) :: varname !< dummy name + end type marbl_forcing_fields_metadata_type + + !> A non-functioning template of MARBL forcing type + type, public :: marbl_forcing_fields_type + type(marbl_forcing_fields_metadata_type) :: metadata !< dummy metadata + real, pointer :: field_0d(:) => NULL() !< dummy pointer + real, pointer :: field_1d(:,:) => NULL() !< dummy pointer + end type marbl_forcing_fields_type + + !> A non-functioning template of MARBL tracer metadata type + type, public :: marbl_tracer_metadata_type + character(len=0) :: short_name !< dummy name + character(len=0) :: long_name !< dummy name + character(len=0) :: units !< dummy units + end type marbl_tracer_metadata_type + + !> A non-functioning template of MARBL domain type + type, public :: marbl_domain_type + integer :: kmt !< dummy index + integer :: km !< dummy index + real, allocatable :: zt(:) !< dummy depths + real, allocatable :: zw(:) !< dummy depths + real, allocatable :: delta_z(:) !< dummy thicknesses + end type marbl_domain_type + + !> A non-functioning template of MARBL single output type + type, public :: marbl_single_output_type + ! marbl_single_output : + ! a private type, this contains both the metadata and + ! the actual data for a single field computed in either + ! surface_flux_compute() or interior_tendency_compute() + ! that needs to be passed to the GCM / flux coupler. + ! Data must be accessed via the marbl_output_for_GCM_type + ! data structure. + character(len=0) :: short_name !< dummy name + real, allocatable, dimension(:) :: forcing_field_0d !< dummy forcing_field_0d + real, allocatable, dimension(:,:) :: forcing_field_1d !< forcing_field_1d + end type marbl_single_output_type + + !> A non-functioning template of MARBL output for GCM type + type, public :: marbl_output_for_GCM_type + type(marbl_single_output_type), dimension(:), pointer :: outputs_for_GCM => NULL() !< dummy outputs_for_GCM + end type marbl_output_for_GCM_type + +end module marbl_interface_public_types diff --git a/config_src/external/MARBL/marbl_logging.F90 b/config_src/external/MARBL/marbl_logging.F90 new file mode 100644 index 0000000000..8310d3746b --- /dev/null +++ b/config_src/external/MARBL/marbl_logging.F90 @@ -0,0 +1,42 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> A non-functioning template of the MARBL logging module +module marbl_logging + + implicit none + private + + !> A non-functioning template of the marbl status log type + type, public :: marbl_status_log_entry_type + integer :: ElementInd !< dummy index + logical :: lonly_master_writes !< dummy flag + character(len=0) :: LogMessage !< dummy message + type(marbl_status_log_entry_type), pointer :: next !< dummy pointer + end type marbl_status_log_entry_type + + !> A non-functioning template of the marbl status log type + type, public :: marbl_log_type + logical, public :: labort_marbl !< dummy flag + type(marbl_status_log_entry_type), pointer :: FullLog !< dummy pointer + contains + procedure, public :: log_error_trace !< dummy trace routine + procedure, public :: erase !< dummy erase routine + end type marbl_log_type + +contains + + !> dummy trace routine + subroutine log_error_trace(self, RoutineName, CodeLoc, ElemInd) + class(marbl_log_type), intent(inout) :: self + character(len=*), intent(in) :: RoutineName, CodeLoc + integer, optional, intent(in) :: ElemInd + end subroutine log_error_trace + + !> dummy erase routine + subroutine erase(self) + class(marbl_log_type), intent(inout) :: self + end subroutine erase + +end module marbl_logging diff --git a/config_src/external/ODA_hooks/kdtree.f90 b/config_src/external/ODA_hooks/kdtree.f90 index a27716dde1..75558c94fa 100644 --- a/config_src/external/ODA_hooks/kdtree.f90 +++ b/config_src/external/ODA_hooks/kdtree.f90 @@ -1,3 +1,7 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> A null version of K-d tree from geoKdTree module kdtree implicit none diff --git a/config_src/external/ODA_hooks/ocean_da_core.F90 b/config_src/external/ODA_hooks/ocean_da_core.F90 index 769e44b2aa..a2fba2b7b0 100644 --- a/config_src/external/ODA_hooks/ocean_da_core.F90 +++ b/config_src/external/ODA_hooks/ocean_da_core.F90 @@ -1,3 +1,7 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> A set of dummy interfaces for compiling the MOM6 DA driver code. module ocean_da_core_mod ! MOM modules diff --git a/config_src/external/ODA_hooks/ocean_da_types.F90 b/config_src/external/ODA_hooks/ocean_da_types.F90 index e71c76a048..82e1a28e6e 100644 --- a/config_src/external/ODA_hooks/ocean_da_types.F90 +++ b/config_src/external/ODA_hooks/ocean_da_types.F90 @@ -1,90 +1,92 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Dummy aata structures and methods for ocean data assimilation. module ocean_da_types_mod - use MOM_time_manager, only : time_type - - implicit none +use MOM_time_manager, only : time_type - private +implicit none ; private - !> Example type for ocean ensemble DA state - type, public :: OCEAN_CONTROL_STRUCT - integer :: ensemble_size !< ensemble size - real, pointer, dimension(:,:,:) :: SSH=>NULL() !NULL() !NULL() !NULL() !NULL() !NULL() ! Example type for ocean ensemble DA state +type, public :: OCEAN_CONTROL_STRUCT + integer :: ensemble_size !< ensemble size + real, pointer, dimension(:,:,:) :: SSH => NULL() !< sea surface height across ensembles [m] + real, pointer, dimension(:,:,:,:) :: h => NULL() !< layer thicknesses across ensembles [m or kg m-2] + real, pointer, dimension(:,:,:,:) :: T => NULL() !< layer potential temperature across ensembles [degC] + real, pointer, dimension(:,:,:,:) :: S => NULL() !< layer salinity across ensembles [ppt] + real, pointer, dimension(:,:,:,:) :: U => NULL() !< layer zonal velocity across ensembles [m s-1] + real, pointer, dimension(:,:,:,:) :: V => NULL() !< layer meridional velocity across ensembles [m s-1] +end type OCEAN_CONTROL_STRUCT - !> Example of a profile type - type, public :: ocean_profile_type - integer :: inst_type !< A numeric code indicating the type of instrument (e.g. ARGO drifter, CTD, ...) - logical :: initialized !< a True value indicates that this profile has been allocated for use - logical :: colocated !< a True value indicated that the measurements of (num_variables) data are - !! co-located in space-time - integer :: ensemble_size !< size of the ensemble of model states used in association with this profile - integer :: num_variables !< number of measurement types associated with this profile. - integer, pointer, dimension(:) :: var_id !< variable ids are defined by the ocean_types module - integer :: platform !< platform types are defined by platform class (e.g. MOORING, DROP, etc.) - !! and instrument type (XBT, CDT, etc.) - integer :: levels !< number of levels in the current profile - integer :: basin_mask !< 1:Southern Ocean, 2:Atlantic Ocean, 3:Pacific Ocean, - !! 4:Arctic Ocean, 5:Indian Ocean, 6:Mediterranean Sea, 7:Black Sea, - !! 8:Hudson Bay, 9:Baltic Sea, 10:Red Sea, 11:Persian Gulf - integer :: profile_flag !< an overall flag for the profile - real :: lat !< latitude [degrees_N] - real :: lon !< longitude [degrees_E] - logical :: accepted !< logical flag to disable a profile - type(time_type) :: time_window !< The time window associated with this profile [s] - real, pointer, dimension(:) :: obs_error !< The observation error by variable - real :: loc_dist !< The impact radius of this observation (m) - type(ocean_profile_type), pointer :: next=>NULL() !< all profiles are stored as linked list. - type(ocean_profile_type), pointer :: prev=>NULL() !< previous - type(ocean_profile_type), pointer :: cnext=>NULL() !< current profiles are stored as linked list. - type(ocean_profile_type), pointer :: cprev=>NULL() !< previous - integer :: nbr_xi !< x nearest neighbor model gridpoint for the profile - integer :: nbr_yi !< y nearest neighbor model gridpoint for the profile - real :: nbr_dist !< distance to nearest neighbor model gridpoint - logical :: compute !< profile is within current compute domain - real, dimension(:,:), pointer :: depth => NULL() !< depth of measurement [m] - real, dimension(:,:), pointer :: data => NULL() !< data by variable type - integer, dimension(:,:), pointer :: flag => NULL() !< flag by depth and variable type - real, dimension(:,:,:), pointer :: forecast => NULL() !< ensemble member first guess - real, dimension(:,:,:), pointer :: analysis => NULL() !< ensemble member analysis - type(forward_operator_type), pointer :: obs_def => NULL() !< observation forward operator - type(time_type) :: time !< profile time type - real :: i_index !< model longitude indices respectively - real :: j_index !< model latitude indices respectively - real, dimension(:,:), pointer :: k_index !< model depth indices - type(time_type) :: tdiff !< difference between model time and observation time - character(len=128) :: filename !< a filename - end type ocean_profile_type +!> Example of a profile type +type, public :: ocean_profile_type + integer :: inst_type !< A numeric code indicating the type of instrument (e.g. ARGO drifter, CTD, ...) + logical :: initialized !< a True value indicates that this profile has been allocated for use + logical :: colocated !< a True value indicated that the measurements of (num_variables) data are + !! co-located in space-time + integer :: ensemble_size !< size of the ensemble of model states used in association with this profile + integer :: num_variables !< number of measurement types associated with this profile. + integer, pointer, dimension(:) :: var_id !< variable ids are defined by the ocean_types module + integer :: platform !< platform types are defined by platform class (e.g. MOORING, DROP, etc.) + !! and instrument type (XBT, CDT, etc.) + integer :: levels !< number of levels in the current profile + integer :: basin_mask !< 1:Southern Ocean, 2:Atlantic Ocean, 3:Pacific Ocean, + !! 4:Arctic Ocean, 5:Indian Ocean, 6:Mediterranean Sea, 7:Black Sea, + !! 8:Hudson Bay, 9:Baltic Sea, 10:Red Sea, 11:Persian Gulf + integer :: profile_flag !< an overall flag for the profile + real :: lat !< latitude [degrees_N] + real :: lon !< longitude [degrees_E] + logical :: accepted !< logical flag to disable a profile + type(time_type) :: time_window !< The time window associated with this profile + real, pointer, dimension(:) :: obs_error !< The observation error by variable [various units] + real :: loc_dist !< The impact radius of this observation [m] + type(ocean_profile_type), pointer :: next => NULL() !< all profiles are stored as linked list. + type(ocean_profile_type), pointer :: prev => NULL() !< previous + type(ocean_profile_type), pointer :: cnext => NULL() !< current profiles are stored as linked list. + type(ocean_profile_type), pointer :: cprev => NULL() !< previous + integer :: nbr_xi !< x nearest neighbor model gridpoint for the profile + integer :: nbr_yi !< y nearest neighbor model gridpoint for the profile + real :: nbr_dist !< distance to nearest neighbor model gridpoint [m] + logical :: compute !< profile is within current compute domain + real, dimension(:,:), pointer :: depth => NULL() !< depth of measurement [m] + real, dimension(:,:), pointer :: data => NULL() !< data by variable type [various units] + integer, dimension(:,:), pointer :: flag => NULL() !< flag by depth and variable type + real, dimension(:,:,:), pointer :: forecast => NULL() !< ensemble member first guess + real, dimension(:,:,:), pointer :: analysis => NULL() !< ensemble member analysis + type(forward_operator_type), pointer :: obs_def => NULL() !< observation forward operator + type(time_type) :: time !< profile time type + real :: i_index !< model longitude indices respectively + real :: j_index !< model latitude indices respectively + real, dimension(:,:), pointer :: k_index !< model depth indices + type(time_type) :: tdiff !< difference between model time and observation time + character(len=128) :: filename !< a filename +end type ocean_profile_type - !> Example forward operator type. - type, public :: forward_operator_type - integer :: num !< how many? - integer, dimension(2) :: state_size !< for - integer, dimension(:), pointer :: state_var_index !< for flattened data - integer, dimension(:), pointer :: i_index !< i-dimension index - integer, dimension(:), pointer :: j_index !< j-dimension index - real, dimension(:), pointer :: coef !< coefficient - end type forward_operator_type +!> Example forward operator type. +type, public :: forward_operator_type + integer :: num !< how many? + integer, dimension(2) :: state_size !< for + integer, dimension(:), pointer :: state_var_index !< for flattened data + integer, dimension(:), pointer :: i_index !< i-dimension index + integer, dimension(:), pointer :: j_index !< j-dimension index + real, dimension(:), pointer :: coef !< coefficient +end type forward_operator_type - !> Grid type for DA - type, public :: grid_type - real, pointer, dimension(:,:) :: x=>NULL() !< x - real, pointer, dimension(:,:) :: y=>NULL() !< y - real, pointer, dimension(:,:,:) :: z=>NULL() !< z - real, pointer, dimension(:,:,:) :: h=>NULL() !< h - real, pointer, dimension(:,:) :: basin_mask => NULL() !< basin mask - real, pointer, dimension(:,:,:) :: mask => NULL() !< land mask? - real, pointer, dimension(:,:) :: bathyT => NULL() !< bathymetry at T points - logical :: tripolar_N !< True for tripolar grids - integer :: ni !< ni - integer :: nj !< nj - integer :: nk !< nk - end type grid_type +!> Grid type for DA +type, public :: grid_type + real, pointer, dimension(:,:) :: x => NULL() !< x + real, pointer, dimension(:,:) :: y => NULL() !< y + real, pointer, dimension(:,:,:) :: z => NULL() !< z + real, pointer, dimension(:,:,:) :: h => NULL() !< h + real, pointer, dimension(:,:) :: basin_mask => NULL() !< basin mask + real, pointer, dimension(:,:,:) :: mask => NULL() !< land mask? + real, pointer, dimension(:,:) :: bathyT => NULL() !< bathymetry at T points [m] + logical :: tripolar_N !< True for tripolar grids + integer :: ni !< ni + integer :: nj !< nj + integer :: nk !< nk +end type grid_type end module ocean_da_types_mod diff --git a/config_src/external/ODA_hooks/write_ocean_obs.F90 b/config_src/external/ODA_hooks/write_ocean_obs.F90 index da4a404d3d..6766a391ca 100644 --- a/config_src/external/ODA_hooks/write_ocean_obs.F90 +++ b/config_src/external/ODA_hooks/write_ocean_obs.F90 @@ -1,16 +1,16 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Dummy interfaces for writing ODA data module write_ocean_obs_mod +use ocean_da_types_mod, only : ocean_profile_type +use MOM_time_manager, only : time_type, get_time, set_date - use ocean_da_types_mod, only : ocean_profile_type - use MOM_time_manager, only : time_type, get_time, set_date - - implicit none - - private +implicit none ; private - public :: open_profile_file, write_profile, close_profile_file, & - write_ocean_obs_init +public :: open_profile_file, write_profile, close_profile_file, write_ocean_obs_init contains diff --git a/config_src/external/database_comms/MOM_database_comms.F90 b/config_src/external/database_comms/MOM_database_comms.F90 new file mode 100644 index 0000000000..4832b95e52 --- /dev/null +++ b/config_src/external/database_comms/MOM_database_comms.F90 @@ -0,0 +1,40 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Contains routines necessary to initialize communication with a database +module MOM_database_comms +use MOM_file_parser, only : param_file_type +use MOM_error_handler, only : MOM_error, WARNING +use database_client_interface, only : dbclient_type + +implicit none ; private + +!> Control structure to store Database communication related parameters and objects +type, public :: dbcomms_CS_type + type(dbclient_type) :: client !< The Database client itself + logical :: use_dbclient !< If True, use Database within MOM6 + logical :: colocated !< If True, the orchestrator was setup in 'co-located' mode + logical :: cluster !< If True, the orchestrator has three shards or more + integer :: colocated_stride !< Sets which ranks will load the model from the file + !! e.g. mod(rank,colocated_stride) == 0 +end type dbcomms_CS_type + +public :: database_comms_init +public :: dbclient_type + +contains + +subroutine database_comms_init(param_file, CS, client_in) + type(param_file_type), intent(in ) :: param_file !< Parameter file structure + type(dbcomms_CS_type), intent(inout) :: CS !< Control structure for Database + type(dbclient_type), optional, intent(in ) :: client_in !< If present, use a previously initialized + !! Database client + + call MOM_error(WARNING,"dbcomms_init was compiled using the dummy module. If this was\n"//& + "a mistake, please follow the instructions in:\n"//& + "MOM6/config_src/external/dbclient/README.md") +end subroutine database_comms_init + +end module MOM_database_comms + diff --git a/config_src/external/database_comms/README.md b/config_src/external/database_comms/README.md new file mode 100644 index 0000000000..05f1f07259 --- /dev/null +++ b/config_src/external/database_comms/README.md @@ -0,0 +1,25 @@ +# Overview +This module is designed to be used in conjunction with the SmartSim and +SmartRedis libraries found at https://github.com/CrayLabs/. These +libraries are used to perform machine-learning inference and online +analysis using a Redis-based database. + +An earlier implementation of these routines was used in Partee et al. [2022]: +"Using Machine Learning at scale in numerical simulations with SmartSim: +An application to ocean climate modeling" (doi.org/10.1016/j.jocs.2022.101707) +to predict eddy kinetic energy for use in the MEKE module. The additional +scripts and installation instructions for compiling MOM6 for this case can +be found at: https://github.com/CrayLabs/NCAR_ML_EKE/. The substantive +code in the new implementation is part of `MOM_MEKE.F90`. + +# File description + +- `MOM_database_comms` contains just method signatures and elements of the + control structure that are imported elsewhere within the primary MOM6 + code. This includes: `dbcomms_CS_type`, `dbclient_type`, and `database_comms_init` + +- `database_client_interface.F90` contains the methods for a communication client + to transfer data and/or commands between MOM6 and a remote database. This is + roughly based on the SmartRedis library, though only the methods that are most + likely to be used with MOM6 are retained. This is to ensure that the API can be + tested without requiring MOM6 users to compile in the the full library. diff --git a/config_src/external/database_comms/database_client_interface.F90 b/config_src/external/database_comms/database_client_interface.F90 new file mode 100644 index 0000000000..a20db2b2cb --- /dev/null +++ b/config_src/external/database_comms/database_client_interface.F90 @@ -0,0 +1,836 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +module database_client_interface + + use iso_fortran_env, only : int8, int16, int32, int64, real32, real64 + + implicit none ; private + + !> Dummy type for dataset + type, public :: dataset_type + private + end type dataset_type + + !> Stores all data and methods associated with the communication client that is used to communicate with the database + type, public :: dbclient_type + private + + contains + + ! Public procedures + !> Puts a tensor into the database for a variety of datatypes + generic :: put_tensor => put_tensor_float_1d, put_tensor_float_2d, put_tensor_float_3d, put_tensor_float_4d, & + put_tensor_double_1d, put_tensor_double_2d, put_tensor_double_3d, put_tensor_double_4d, & + put_tensor_int32_1d, put_tensor_int32_2d, put_tensor_int32_3d, put_tensor_int32_4d + !> Retrieve the tensor in the database into already allocated memory for a variety of datatypesm + generic :: unpack_tensor => unpack_tensor_float_1d, unpack_tensor_float_2d, & + unpack_tensor_float_3d, unpack_tensor_float_4d, & + unpack_tensor_double_1d, unpack_tensor_double_2d, & + unpack_tensor_double_3d, unpack_tensor_double_4d, & + unpack_tensor_int32_1d, unpack_tensor_int32_2d, & + unpack_tensor_int32_3d, unpack_tensor_int32_4d + + !> Decode a response code from an API function + procedure :: SR_error_parser + !> Initializes a new instance of the communication client + procedure :: initialize => initialize_client + !> Check if a communication client has been initialized + procedure :: isinitialized + !> Destructs a new instance of the communication client + procedure :: destructor + !> Rename a tensor within the database + procedure :: rename_tensor + !> Delete a tensor from the database + procedure :: delete_tensor + !> Copy a tensor within the database to a new name + procedure :: copy_tensor + !> Set a model from a file + procedure :: set_model_from_file + !> Set a model from a file on a system with multiple GPUs + procedure :: set_model_from_file_multigpu + !> Set a model from a byte string that has been loaded within the application + procedure :: set_model + !> Set a model from a byte string that has been loaded within the application on a system with multiple GPUs + procedure :: set_model_multigpu + !> Retrieve the model as a byte string + procedure :: get_model + !> Set a script from a specified file + procedure :: set_script_from_file + !> Set a script from a specified file on a system with multiple GPUS + procedure :: set_script_from_file_multigpu + !> Set a script as a byte or text string + procedure :: set_script + !> Set a script as a byte or text string on a system with multiple GPUs + procedure :: set_script_multigpu + !> Retrieve the script from the database + procedure :: get_script + !> Run a script that has already been stored in the database + procedure :: run_script + !> Run a script that has already been stored in the database with multiple GPUs + procedure :: run_script_multigpu + !> Run a model that has already been stored in the database + procedure :: run_model + !> Run a model that has already been stored in the database with multiple GPUs + procedure :: run_model_multigpu + !> Remove a script from the database + procedure :: delete_script + !> Remove a script from the database with multiple GPUs + procedure :: delete_script_multigpu + !> Remove a model from the database + procedure :: delete_model + !> Remove a model from the database with multiple GPUs + procedure :: delete_model_multigpu + !> Put a communication dataset into the database + procedure :: put_dataset + !> Retrieve a communication dataset from the database + procedure :: get_dataset + !> Rename the dataset within the database + procedure :: rename_dataset + !> Copy a dataset stored in the database into another name + procedure :: copy_dataset + !> Delete the dataset from the database + procedure :: delete_dataset + + ! Private procedures + !> Put a 1d, 32-bit real tensor into database + procedure, private :: put_tensor_float_1d + !> Put a 2d, 32-bit real tensor into database + procedure, private :: put_tensor_float_2d + !> Put a 3d, 32-bit real tensor into database + procedure, private :: put_tensor_float_3d + !> Put a 4d, 32-bit real tensor into database + procedure, private :: put_tensor_float_4d + !> Put a 1d, 64-bit real tensor into database + procedure, private :: put_tensor_double_1d + !> Put a 2d, 64-bit real tensor into database + procedure, private :: put_tensor_double_2d + !> Put a 3d, 64-bit real tensor into database + procedure, private :: put_tensor_double_3d + !> Put a 4d, 64-bit real tensor into database + procedure, private :: put_tensor_double_4d + !> Put a 1d, 32-bit integer tensor into database + procedure, private :: put_tensor_int32_1d + !> Put a 2d, 32-bit integer tensor into database + procedure, private :: put_tensor_int32_2d + !> Put a 3d, 32-bit integer tensor into database + procedure, private :: put_tensor_int32_3d + !> Put a 4d, 32-bit integer tensor into database + procedure, private :: put_tensor_int32_4d + !> Unpack a 1d, 32-bit real tensor from the database + procedure, private :: unpack_tensor_float_1d + !> Unpack a 2d, 32-bit real tensor from the database + procedure, private :: unpack_tensor_float_2d + !> Unpack a 3d, 32-bit real tensor from the database + procedure, private :: unpack_tensor_float_3d + !> Unpack a 4d, 32-bit real tensor from the database + procedure, private :: unpack_tensor_float_4d + !> Unpack a 1d, 64-bit real tensor from the database + procedure, private :: unpack_tensor_double_1d + !> Unpack a 2d, 64-bit real tensor from the database + procedure, private :: unpack_tensor_double_2d + !> Unpack a 3d, 64-bit real tensor from the database + procedure, private :: unpack_tensor_double_3d + !> Unpack a 4d, 64-bit real tensor from the database + procedure, private :: unpack_tensor_double_4d + !> Unpack a 1d, 32-bit integer tensor from the database + procedure, private :: unpack_tensor_int32_1d + !> Unpack a 2d, 32-bit integer tensor from the database + procedure, private :: unpack_tensor_int32_2d + !> Unpack a 3d, 32-bit integer tensor from the database + procedure, private :: unpack_tensor_int32_3d + !> Unpack a 4d, 32-bit integer tensor from the database + procedure, private :: unpack_tensor_int32_4d + + end type dbclient_type + + contains + + !> Decode a response code from an API function + function SR_error_parser(self, response_code) result(is_error) + class(dbclient_type), intent(in) :: self !< Receives the initialized client + integer, intent(in) :: response_code !< The response code to decode + logical :: is_error !< Indicates whether this is an error response + + is_error = .true. + end function SR_error_parser + + !> Initializes a new instance of a communication client + function initialize_client(self, cluster) + integer :: initialize_client + class(dbclient_type), intent(inout) :: self !< Receives the initialized client + logical, optional, intent(in ) :: cluster !< If true, client uses a database cluster (Default: .false.) + + initialize_client = -1 + end function initialize_client + + !> Check whether the client has been initialized + logical function isinitialized(this) + class(dbclient_type) :: this + isinitialized = .false. + end function isinitialized + + !> A destructor for the communication client + function destructor(self) + integer :: destructor + class(dbclient_type), intent(inout) :: self + + destructor = -1 + end function destructor + + !> Put a 32-bit real 1d tensor into the database + function put_tensor_float_1d(self, name, data, dims) result(code) + real(kind=real32), dimension(:), intent(in) :: data !< Data to be sent + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + end function put_tensor_float_1d + + !> Put a 32-bit real 2d tensor into the database + function put_tensor_float_2d(self, name, data, dims) result(code) + real(kind=real32), dimension(:,:), intent(in) :: data !< Data to be sent + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + end function put_tensor_float_2d + + !> Put a 32-bit real 3d tensor into the database + function put_tensor_float_3d(self, name, data, dims) result(code) + real(kind=real32), dimension(:,:,:), intent(in) :: data !< Data to be sent + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + end function put_tensor_float_3d + + !> Put a 32-bit real 4d tensor into the database + function put_tensor_float_4d(self, name, data, dims) result(code) + real(kind=real32), dimension(:,:,:,:), intent(in) :: data !< Data to be sent + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + end function put_tensor_float_4d + + !> Put a 64-bit real 1d tensor into the database + function put_tensor_double_1d(self, name, data, dims) result(code) + real(kind=real64), dimension(:), intent(in) :: data !< Data to be sent + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + end function put_tensor_double_1d + + !> Put a 64-bit real 2d tensor into the database + function put_tensor_double_2d(self, name, data, dims) result(code) + real(kind=real64), dimension(:,:), intent(in) :: data !< Data to be sent + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + end function put_tensor_double_2d + + !> Put a 64-bit real 3d tensor into the database + function put_tensor_double_3d(self, name, data, dims) result(code) + real(kind=real64), dimension(:,:,:), intent(in) :: data !< Data to be sent + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + end function put_tensor_double_3d + + !> Put a 64-bit real 4d tensor into the database + function put_tensor_double_4d(self, name, data, dims) result(code) + real(kind=real64), dimension(:,:,:,:), intent(in) :: data !< Data to be sent + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + end function put_tensor_double_4d + + !> Put a 32-bit integer 1d tensor into the database + function put_tensor_int32_1d(self, name, data, dims) result(code) + integer(kind=int32), dimension(:), intent(in) :: data !< Data to be sent + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + end function put_tensor_int32_1d + + !> Put a 32-bit integer 2d tensor into the database + function put_tensor_int32_2d(self, name, data, dims) result(code) + integer(kind=int32), dimension(:,:), intent(in) :: data !< Data to be sent + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + end function put_tensor_int32_2d + + !> Put a 32-bit integer 3d tensor into the database + function put_tensor_int32_3d(self, name, data, dims) result(code) + integer(kind=int32), dimension(:,:,:), intent(in) :: data !< Data to be sent + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + end function put_tensor_int32_3d + + !> Put a 32-bit integer 4d tensor into the database + function put_tensor_int32_4d(self, name, data, dims) result(code) + integer(kind=int32), dimension(:,:,:,:), intent(in) :: data !< Data to be sent + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + end function put_tensor_int32_4d + + !> Unpack a 32-bit real 1d tensor from the database + function unpack_tensor_float_1d(self, name, data, dims) result(code) + real(kind=real32), dimension(:), intent( out) :: data !< Data to be received + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + data(:) = -1. + end function unpack_tensor_float_1d + + !> Unpack a 32-bit real 2d tensor from the database + function unpack_tensor_float_2d(self, name, data, dims) result(code) + real(kind=real32), dimension(:,:), intent( out) :: data !< Data to be received + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + data(:,:) = -1. + end function unpack_tensor_float_2d + + !> Unpack a 32-bit real 3d tensor from the database + function unpack_tensor_float_3d(self, name, data, dims) result(code) + real(kind=real32), dimension(:,:,:), intent( out) :: data !< Data to be received + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + data(:,:,:) = -1. + end function unpack_tensor_float_3d + + !> Unpack a 32-bit real 4d tensor from the database + function unpack_tensor_float_4d(self, name, data, dims) result(code) + real(kind=real32), dimension(:,:,:,:), intent( out) :: data !< Data to be received + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + data(:,:,:,:) = -1. + end function unpack_tensor_float_4d + + !> Unpack a 64-bit real 1d tensor from the database + function unpack_tensor_double_1d(self, name, data, dims) result(code) + real(kind=real64), dimension(:), intent( out) :: data !< Data to be received + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + data(:) = -1. + end function unpack_tensor_double_1d + + !> Unpack a 64-bit real 2d tensor from the database + function unpack_tensor_double_2d(self, name, data, dims) result(code) + real(kind=real64), dimension(:,:), intent( out) :: data !< Data to be received + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + data(:,:) = -1. + end function unpack_tensor_double_2d + + !> Unpack a 64-bit real 3d tensor from the database + function unpack_tensor_double_3d(self, name, data, dims) result(code) + real(kind=real64), dimension(:,:,:), intent( out) :: data !< Data to be received + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + data(:,:,:) = -1. + end function unpack_tensor_double_3d + + !> Unpack a 64-bit real 4d tensor from the database + function unpack_tensor_double_4d(self, name, data, dims) result(code) + real(kind=real64), dimension(:,:,:,:), intent( out) :: data !< Data to be received + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + data(:,:,:,:) = -1. + end function unpack_tensor_double_4d + + !> Unpack a 32-bit integer 1d tensor from the database + function unpack_tensor_int32_1d(self, name, data, dims) result(code) + integer(kind=int32), dimension(:), intent( out) :: data !< Data to be received + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + data(:) = -1_int32 + end function unpack_tensor_int32_1d + + !> Unpack a 32-bit integer 2d tensor from the database + function unpack_tensor_int32_2d(self, name, data, dims) result(code) + integer(kind=int32), dimension(:,:), intent( out) :: data !< Data to be received + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + data(:,:) = -1_int32 + end function unpack_tensor_int32_2d + + !> Unpack a 32-bit integer 3d tensor from the database + function unpack_tensor_int32_3d(self, name, data, dims) result(code) + integer(kind=int32), dimension(:,:,:), intent( out) :: data !< Data to be received + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + data(:,:,:) = -1_int32 + end function unpack_tensor_int32_3d + + !> Unpack a 32-bit integer 4d tensor from the database + function unpack_tensor_int32_4d(self, name, data, dims) result(code) + integer(kind=int32), dimension(:,:,:,:), intent( out) :: data !< Data to be received + class(dbclient_type), intent(in) :: self !< Fortran communication client + character(len=*), intent(in) :: name !< The unique name used to store in the database + integer, dimension(:), intent(in) :: dims !< The length of each dimension + integer :: code + + code = -1 + data(:,:,:,:) = -1_int32 + end function unpack_tensor_int32_4d + + !> Move a tensor to a new name + function rename_tensor(self, old_name, new_name) result(code) + class(dbclient_type), intent(in) :: self !< The initialized Fortran communication client + character(len=*), intent(in) :: old_name !< The current name for the tensor + !! excluding null terminating character + character(len=*), intent(in) :: new_name !< The new tensor name + integer :: code + + code = -1 + end function rename_tensor + + !> Delete a tensor + function delete_tensor(self, name) result(code) + class(dbclient_type), intent(in) :: self !< The initialized Fortran communication client + character(len=*), intent(in) :: name !< The name associated with the tensor + integer :: code + + code = -1 + end function delete_tensor + + !> Copy a tensor to the destination name + function copy_tensor(self, src_name, dest_name) result(code) + class(dbclient_type), intent(in) :: self !< The initialized Fortran communication client + character(len=*), intent(in) :: src_name !< The name associated with the tensor + !! excluding null terminating character + character(len=*), intent(in) :: dest_name !< The new tensor name + integer :: code + + code = -1 + end function copy_tensor + + !> Retrieve the model from the database + function get_model(self, name, model) result(code) + class(dbclient_type), intent(in ) :: self !< An initialized communication client + character(len=*), intent(in ) :: name !< The name associated with the model + character(len=*), intent( out) :: model !< The model as a continuous buffer + integer :: code + + code = -1 + model = "" + end function get_model + + !> Load the machine learning model from a file and set the configuration + function set_model_from_file(self, name, model_file, backend, device, batch_size, min_batch_size, tag, & + inputs, outputs) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to place the model + character(len=*), intent(in) :: model_file !< The file storing the model + character(len=*), intent(in) :: backend !< The name of the backend + !! (TF, TFLITE, TORCH, ONNX) + character(len=*), intent(in) :: device !< The name of the device + !! (CPU, GPU, GPU:0, GPU:1...) + integer, optional, intent(in) :: batch_size !< The batch size for model execution + integer, optional, intent(in) :: min_batch_size !< The minimum batch size for model execution + character(len=*), optional, intent(in) :: tag !< A tag to attach to the model for + !! information purposes + character(len=*), dimension(:), optional, intent(in) :: inputs !< One or more names of model + !! input nodes (TF models) + character(len=*), dimension(:), optional, intent(in) :: outputs !< One or more names of model + !! output nodes (TF models) + integer :: code + + code = -1 + end function set_model_from_file + + !> Load the machine learning model from a file and set the configuration for use in multi-GPU systems + function set_model_from_file_multigpu(self, name, model_file, backend, first_gpu, num_gpus, batch_size, & + min_batch_size, tag, inputs, outputs) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to place the model + character(len=*), intent(in) :: model_file !< The file storing the model + character(len=*), intent(in) :: backend !< The name of the backend + !! (TF, TFLITE, TORCH, ONNX) + integer, intent(in) :: first_gpu !< The first GPU (zero-based) + !! to use with the model + integer, intent(in) :: num_gpus !< The number of GPUs to use with the model + integer, optional, intent(in) :: batch_size !< The batch size for model execution + integer, optional, intent(in) :: min_batch_size !< The minimum batch size for model execution + character(len=*), optional, intent(in) :: tag !< A tag to attach to the model for + !! information purposes + character(len=*), dimension(:), optional, intent(in) :: inputs !< One or more names of model + !! input nodes (TF models) + character(len=*), dimension(:), optional, intent(in) :: outputs !< One or more names of model + !! output nodes (TF models) + integer :: code + + code = -1 + end function set_model_from_file_multigpu + + !> Establish a model to run + function set_model(self, name, model, backend, device, batch_size, min_batch_size, tag, & + inputs, outputs) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to place the model + character(len=*), intent(in) :: model !< The binary representation of the model + character(len=*), intent(in) :: backend !< The name of the backend (TF, TFLITE, TORCH, ONNX) + character(len=*), intent(in) :: device !< The name of the device (CPU, GPU, GPU:0, GPU:1...) + integer, intent(in) :: batch_size !< The batch size for model execution + integer, intent(in) :: min_batch_size !< The minimum batch size for model execution + character(len=*), intent(in) :: tag !< A tag to attach to the model for + !! information purposes + character(len=*), dimension(:), intent(in) :: inputs !< One or more names of model input nodes (TF models) + character(len=*), dimension(:), intent(in) :: outputs !< One or more names of model output nodes (TF models) + integer :: code + + code = -1 + end function set_model + + !> Set a model from a byte string to run on a system with multiple GPUs + function set_model_multigpu(self, name, model, backend, first_gpu, num_gpus, batch_size, min_batch_size, tag, & + inputs, outputs) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to place the model + character(len=*), intent(in) :: model !< The binary representation of the model + character(len=*), intent(in) :: backend !< The name of the backend (TF, TFLITE, TORCH, ONNX) + integer, intent(in) :: first_gpu !< The first GPU (zero-based) to use with the model + integer, intent(in) :: num_gpus !< The number of GPUs to use with the model + integer, intent(in) :: batch_size !< The batch size for model execution + integer, intent(in) :: min_batch_size !< The minimum batch size for model execution + character(len=*), intent(in) :: tag !< A tag to attach to the model for + !! information purposes + character(len=*), dimension(:), intent(in) :: inputs !< One or more names of model input nodes (TF models) + character(len=*), dimension(:), intent(in) :: outputs !< One or more names of model output nodes (TF models) + integer :: code + + code = -1 + end function set_model_multigpu + + !> Run a model in the database using the specified input and output tensors + function run_model(self, name, inputs, outputs) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to place the model + character(len=*), dimension(:), intent(in) :: inputs !< One or more names of model input nodes (TF models) + character(len=*), dimension(:), intent(in) :: outputs !< One or more names of model output nodes (TF models) + integer :: code + + code = -1 + end function run_model + + !> Run a model in the database using the specified input and output tensors in a multi-GPU system + function run_model_multigpu(self, name, inputs, outputs, offset, first_gpu, num_gpus) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to place the model + character(len=*), dimension(:), intent(in) :: inputs !< One or more names of model input nodes (TF models) + character(len=*), dimension(:), intent(in) :: outputs !< One or more names of model output nodes (TF models) + integer, intent(in) :: offset !< Index of the current image, such as a processor ID + !! or MPI rank + integer, intent(in) :: first_gpu !< The first GPU (zero-based) to use with the model + integer, intent(in) :: num_gpus !< The number of GPUs to use with the model + integer :: code + + code = -1 + end function run_model_multigpu + + !> Remove a model from the database + function delete_model(self, name) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to remove the model + integer :: code + + code = -1 + end function delete_model + + !> Remove a model from the database + function delete_model_multigpu(self, name, first_gpu, num_gpus) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to remove the model + integer, intent(in) :: first_gpu !< The first GPU (zero-based) to use with the model + integer, intent(in) :: num_gpus !< The number of GPUs to use with the model + integer :: code + + code = -1 + end function delete_model_multigpu + + !> Retrieve the script from the database + function get_script(self, name, script) result(code) + class(dbclient_type), intent(in ) :: self !< An initialized communication client + character(len=*), intent(in ) :: name !< The name to use to place the script + character(len=*), intent( out) :: script !< The script as a continuous buffer + integer :: code + + code = -1 + script = "" + end function get_script + + !> Set a script (from file) in the database for future execution + function set_script_from_file(self, name, device, script_file) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to place the script + character(len=*), intent(in) :: device !< The name of the device (CPU, GPU, GPU:0, GPU:1...) + character(len=*), intent(in) :: script_file !< The file storing the script + integer :: code + + code = -1 + end function set_script_from_file + + !> Set a script (from file) in the database for future execution in a multi-GPU system + function set_script_from_file_multigpu(self, name, script_file, first_gpu, num_gpus) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to place the script + character(len=*), intent(in) :: script_file !< The file storing the script + integer, intent(in) :: first_gpu !< The first GPU (zero-based) to use with the model + integer, intent(in) :: num_gpus !< The number of GPUs to use with the model + integer :: code + + code = -1 + end function set_script_from_file_multigpu + + !> Set a script (from buffer) in the database for future execution + function set_script(self, name, device, script) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to place the script + character(len=*), intent(in) :: device !< The name of the device (CPU, GPU, GPU:0, GPU:1...) + character(len=*), intent(in) :: script !< The file storing the script + integer :: code + + code = -1 + end function set_script + + !> Set a script (from buffer) in the database for future execution in a multi-GPU system + function set_script_multigpu(self, name, script, first_gpu, num_gpus) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to place the script + character(len=*), intent(in) :: script !< The file storing the script + integer, intent(in) :: first_gpu !< The first GPU (zero-based) to use with the model + integer, intent(in) :: num_gpus !< The number of GPUs to use with the model + integer :: code + + code = -1 + end function set_script_multigpu + + function run_script(self, name, func, inputs, outputs) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to place the script + character(len=*), intent(in) :: func !< The name of the function in the script to call + character(len=*), dimension(:), intent(in) :: inputs !< One or more names of script + !! input nodes (TF scripts) + character(len=*), dimension(:), intent(in) :: outputs !< One or more names of script + !! output nodes (TF scripts) + integer :: code + + code = -1 + end function run_script + + function run_script_multigpu(self, name, func, inputs, outputs, offset, first_gpu, num_gpus) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to place the script + character(len=*), intent(in) :: func !< The name of the function in the script to call + character(len=*), dimension(:), intent(in) :: inputs !< One or more names of script + !! input nodes (TF scripts) + character(len=*), dimension(:), intent(in) :: outputs !< One or more names of script + !! output nodes (TF scripts) + integer, intent(in) :: offset !< Index of the current image, such as a processor ID + !! or MPI rank + integer, intent(in) :: first_gpu !< The first GPU (zero-based) to use with the model + integer, intent(in) :: num_gpus !< The number of GPUs to use with the model + integer :: code + + code = -1 + end function run_script_multigpu + + !> Remove a script from the database + function delete_script(self, name) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to delete the script + integer :: code + + code = -1 + end function delete_script + + !> Remove a script_multigpu from the database + function delete_script_multigpu(self, name, first_gpu, num_gpus) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< The name to use to delete the script_multigpu + integer, intent(in) :: first_gpu !< The first GPU (zero-based) to use with the model + integer, intent(in) :: num_gpus !< The number of GPUs to use with the model + integer :: code + + code = -1 + end function delete_script_multigpu + + !> Store a dataset in the database + function put_dataset(self, dataset) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + type(dataset_type), intent(in) :: dataset !< Dataset to store in the dataset + integer :: code + + code = -1 + end function put_dataset + + !> Retrieve a dataset from the database + function get_dataset(self, name, dataset) result(code) + class(dbclient_type), intent(in ) :: self !< An initialized communication client + character(len=*), intent(in ) :: name !< Name of the dataset to get + type(dataset_type), intent( out) :: dataset !< receives the dataset + integer :: code + + type(dataset_type) :: dataset_out + ! Placeholder dataset to prevent compiler warnings + ! Since dataset_type contains no data, any declared instance should work. + + code = -1 + dataset = dataset_out + end function get_dataset + + !> Rename a dataset stored in the database + function rename_dataset(self, name, new_name) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< Original name of the dataset + character(len=*), intent(in) :: new_name !< New name of the dataset + integer :: code + + code = -1 + end function rename_dataset + + !> Copy a dataset within the database to a new name + function copy_dataset(self, name, new_name) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< Source name of the dataset + character(len=*), intent(in) :: new_name !< Name of the new dataset + integer :: code + + code = -1 + end function copy_dataset + + !> Delete a dataset stored within a database + function delete_dataset(self, name) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: name !< Name of the dataset to delete + integer :: code + + code = -1 + end function delete_dataset + + !> Appends a dataset to the aggregation list When appending a dataset to an aggregation list, the list will + !! automatically be created if it does not exist (i.e. this is the first entry in the list). Aggregation + !! lists work by referencing the dataset by storing its key, so appending a dataset to an aggregation list + !! does not create a copy of the dataset. Also, for this reason, the dataset must have been previously + !! placed into the database with a separate call to put_dataset(). + function append_to_list(self, list_name, dataset) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: list_name !< Name of the dataset to get + type(dataset_type), intent(in) :: dataset !< Dataset to append to the list + integer :: code + + code = -1 + end function append_to_list + + !> Delete an aggregation list + function delete_list(self, list_name) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: list_name !< Name of the aggregated dataset list to delete + integer :: code + + code = -1 + end function delete_list + + !> Copy an aggregation list + function copy_list(self, src_name, dest_name) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: src_name !< Name of the dataset to copy + character(len=*), intent(in) :: dest_name !< The new list name + integer :: code + + code = -1 + end function copy_list + + !> Rename an aggregation list + function rename_list(self, src_name, dest_name) result(code) + class(dbclient_type), intent(in) :: self !< An initialized communication client + character(len=*), intent(in) :: src_name !< Name of the dataset to rename + character(len=*), intent(in) :: dest_name !< The new list name + integer :: code + + code = -1 + end function rename_list + + end module database_client_interface + diff --git a/config_src/external/drifters/MOM_particles.F90 b/config_src/external/drifters/MOM_particles.F90 index 135f5d284c..543efeaf1d 100644 --- a/config_src/external/drifters/MOM_particles.F90 +++ b/config_src/external/drifters/MOM_particles.F90 @@ -1,59 +1,87 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> A set of dummy interfaces for compiling the MOM6 drifters code module MOM_particles_mod use MOM_grid, only : ocean_grid_type use MOM_time_manager, only : time_type, get_date, operator(-) use MOM_variables, only : thermo_var_ptrs +use particles_types_mod, only : particles, particles_gridded +implicit none ; private -use particles_types_mod, only: particles, particles_gridded - -public particles_run, particles_init, particles_save_restart, particles_end +public particles, particles_run, particles_init, particles_save_restart, particles_end +public particles_to_k_space, particles_to_z_space contains !> Initializes particles container "parts" -subroutine particles_init(parts, Grid, Time, dt, u, v) +subroutine particles_init(parts, Grid, Time, dt, u, v, h) ! Arguments - type(particles), pointer, intent(out) :: parts !< Container for all types and memory - type(ocean_grid_type), target, intent(in) :: Grid !< Grid type from parent model - type(time_type), intent(in) :: Time !< Time type from parent model - real, intent(in) :: dt !< particle timestep in seconds - real, dimension(:,:,:),intent(in) :: u !< Zonal velocity field - real, dimension(:,:,:),intent(in) :: v !< Meridional velocity field - + type(particles), pointer, intent(out) :: parts !< Container for all types and memory + type(ocean_grid_type), target, intent(in) :: Grid !< Grid type from parent model + type(time_type), intent(in) :: Time !< Time type from parent model + real, intent(in) :: dt !< particle timestep in seconds [T ~> s] + real, dimension(:,:,:),intent(in) :: u !< Zonal velocity field [L T-1 ~> m s-1] + real, dimension(:,:,:),intent(in) :: v !< Meridional velocity field [L T-1 ~> m s-1] + real, dimension(:,:,:),intent(in) :: h !< Thickness of each layer [H ~> m or kg m-2] end subroutine particles_init !> The main driver the steps updates particles -subroutine particles_run(parts, time, uo, vo, ho, tv, stagger) +subroutine particles_run(parts, time, uo, vo, ho, tv, dt_adv, use_uh) ! Arguments type(particles), pointer :: parts !< Container for all types and memory type(time_type), intent(in) :: time !< Model time - real, dimension(:,:,:),intent(in) :: uo !< Ocean zonal velocity (m/s) - real, dimension(:,:,:),intent(in) :: vo !< Ocean meridional velocity (m/s) - real, dimension(:,:,:),intent(in) :: ho !< Ocean layer thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(in) :: tv !< structure containing pointers to available thermodynamic fields - integer, optional, intent(in) :: stagger !< Flag for whether velocities are staggered + real, dimension(:,:,:), intent(in) :: uo !< If use_uh is false, ocean zonal velocity [L T-1 ~>m s-1]. + !! If use_uh is true, accumulated zonal thickness fluxes + !! that are used to advect tracers [H L2 ~> m3 or kg] + real, dimension(:,:,:), intent(in) :: vo !< If use_uh is false, ocean meridional velocity [L T-1 ~>m s-1]. + !! If use_uh is true, accumulated meridional thickness fluxes + !! that are used to advect tracers [H L2 ~> m3 or kg] + real, dimension(:,:,:), intent(in) :: ho !< Ocean layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< structure containing pointers to available thermodynamic fields + real, intent(in) :: dt_adv !< timestep for advecting particles [s] + logical :: use_uh !< Flag for whether u and v are weighted by thickness end subroutine particles_run !>Save particle locations (and sometimes other vars) to restart file -subroutine particles_save_restart(parts,temp,salt) -! Arguments -type(particles), pointer :: parts !< Container for all types and memory -real,dimension(:,:,:),optional,intent(in) :: temp !< Optional container for temperature -real,dimension(:,:,:),optional,intent(in) :: salt !< Optional container for salinity +subroutine particles_save_restart(parts, h, directory, time, time_stamped) + ! Arguments + type(particles), pointer :: parts !< Container for all types and memory + real, dimension(:,:,:),intent(in) :: h !< Thickness of each layer [H ~> m or kg m-2] + character(len=*), intent(in) :: directory !< The directory where the restart files are to be written + type(time_type), intent(in) :: time !< The current model time + logical, optional, intent(in) :: time_stamped !< If present and true, add time-stamp to the restart file names end subroutine particles_save_restart !> Deallocate all memory and disassociated pointer -subroutine particles_end(parts,temp,salt) -! Arguments -type(particles), pointer :: parts !< Container for all types and memory -real,dimension(:,:,:),optional,intent(in) :: temp !< Optional container for temperature -real,dimension(:,:,:),optional,intent(in) :: salt !< Optional container for salinity +subroutine particles_end(parts, h, temp, salt) + ! Arguments + type(particles), pointer :: parts !< Container for all types and memory + real, dimension(:,:,:),intent(in) :: h !< Thickness of each layer [H ~> m or kg m-2] + real, dimension(:,:,:), optional, intent(in) :: temp !< Optional container for temperature [C ~> degC] + real, dimension(:,:,:), optional, intent(in) :: salt !< Optional container for salinity [S ~> ppt] end subroutine particles_end +subroutine particles_to_k_space(parts, h) + ! Arguments + type(particles), pointer :: parts !< Container for all types and memory + real, dimension(:,:,:),intent(in) :: h !< Thickness of layers [H ~> m or kg m-2] + +end subroutine particles_to_k_space + + +subroutine particles_to_z_space(parts, h) + ! Arguments + type(particles), pointer :: parts !< Container for all types and memory + real, dimension(:,:,:),intent(in) :: h !< Thickness of layers [H ~> m or kg m-2] + +end subroutine particles_to_z_space + end module MOM_particles_mod diff --git a/config_src/external/drifters/MOM_particles_types.F90 b/config_src/external/drifters/MOM_particles_types.F90 index b7bc01acb9..ffa9158e69 100644 --- a/config_src/external/drifters/MOM_particles_types.F90 +++ b/config_src/external/drifters/MOM_particles_types.F90 @@ -1,12 +1,18 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Dummy data structures and methods for drifters package module particles_types_mod +use, intrinsic :: iso_fortran_env, only : int64 use MOM_grid, only : ocean_grid_type -use mpp_domains_mod, only: domain2D +use MOM_domains, only: domain2D +implicit none ; private !> Container for gridded fields -type :: particles_gridded +type, public :: particles_gridded type(domain2D), pointer :: domain !< MPP parallel domain integer :: halo !< Nominal halo width integer :: isc !< Start i-index of computational domain @@ -60,7 +66,7 @@ module particles_types_mod !>xyt is a data structure containing particle position and velocity fields. -type :: xyt +type, public :: xyt real :: lon !< Longitude of particle (degree N or unit of grid coordinate) real :: lat !< Latitude of particle (degree N or unit of grid coordinate) real :: day !< Day of this record (days) @@ -72,12 +78,12 @@ module particles_types_mod real :: vvel_old !< Previous meridional velocity component (m/s) integer :: year !< Year of this record integer :: particle_num !< Current particle number - integer(kind=8) :: id = -1 !< Particle Identifier + integer(kind=int64) :: id = -1 !< Particle Identifier type(xyt), pointer :: next=>null() !< Pointer to the next position in the list end type xyt !>particle types are data structures describing a tracked particle -type :: particle +type, public :: particle type(particle), pointer :: prev=>null() !< Previous link in list type(particle), pointer :: next=>null() !< Next link in list ! State variables (specific to the particles, needed for restarts) @@ -95,8 +101,8 @@ module particles_types_mod real :: start_day !< origination position (degrees) and day integer :: start_year !< origination year real :: halo_part !< equal to zero for particles on the computational domain, and 1 for particles on the halo - integer(kind=8) :: id !< particle identifier - integer(kind=8) :: drifter_num !< particle identifier + integer(kind=int64) :: id !< particle identifier + integer(kind=int64) :: drifter_num !< particle identifier integer :: ine !< nearest i-index in NE direction (for convenience) integer :: jne !< nearest j-index in NE direction (for convenience) real :: xi !< non-dimensional x-coordinate within current cell (0..1) @@ -109,19 +115,19 @@ module particles_types_mod !>A buffer structure for message passing -type :: buffer +type, public :: buffer integer :: size=0 !< Size of buffer real, dimension(:,:), pointer :: data !< Buffer memory end type buffer !> A wrapper for the particle linked list (since an array of pointers is not allowed) -type :: linked_list +type, public :: linked_list type(particle), pointer :: first=>null() !< Pointer to the beginning of a linked list of parts end type linked_list !> A grand data structure for the particles in the local MOM domain -type :: particles !; private +type, public :: particles !; private type(particles_gridded) :: grd !< Container with all gridded data type(linked_list), dimension(:,:), allocatable :: list !< Linked list of particles type(xyt), pointer :: trajectories=>null() !< A linked list for detached segments of trajectories @@ -144,7 +150,7 @@ module particles_types_mod logical :: ignore_traj=.False. !< If true, then model does not write trajectory data at all logical :: use_new_predictive_corrective =.False. !< Flag to use Bob's predictive corrective particle scheme !Added by Alon - integer(kind=8) :: debug_particle_with_id = -1 !< If positive, monitors a part with this id + integer(kind=int64) :: debug_particle_with_id = -1 !< If positive, monitors a part with this id type(buffer), pointer :: obuffer_n=>null() !< Buffer for outgoing parts to the north type(buffer), pointer :: ibuffer_n=>null() !< Buffer for incoming parts from the north type(buffer), pointer :: obuffer_s=>null() !< Buffer for outgoing parts to the south diff --git a/config_src/external/stochastic_physics/get_stochy_pattern.F90 b/config_src/external/stochastic_physics/get_stochy_pattern.F90 new file mode 100644 index 0000000000..4d4c5c9bec --- /dev/null +++ b/config_src/external/stochastic_physics/get_stochy_pattern.F90 @@ -0,0 +1,24 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +! The are stubs for ocean stochastic physics +! the fully functional code is available at +! http://github.com/noaa-psd/stochastic_physics +module get_stochy_pattern_mod + +implicit none ; private + +public :: write_stoch_restart_ocn + +contains + +!> Write the restart file for the stochastic physics perturbations. +subroutine write_stoch_restart_ocn(sfile) + character(len=*) :: sfile !< name of restart file + + ! This stub function does not actually do anything. + return +end subroutine write_stoch_restart_ocn + +end module get_stochy_pattern_mod diff --git a/config_src/external/stochastic_physics/stochastic_physics.F90 b/config_src/external/stochastic_physics/stochastic_physics.F90 index df62aa1591..40f9cf9fa8 100644 --- a/config_src/external/stochastic_physics/stochastic_physics.F90 +++ b/config_src/external/stochastic_physics/stochastic_physics.F90 @@ -1,68 +1,73 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + ! The are stubs for ocean stochastic physics ! the fully functional code is available at ! http://github.com/noaa-psd/stochastic_physics module stochastic_physics -implicit none +use MOM_error_handler, only : MOM_error, WARNING -private +implicit none ; private public :: init_stochastic_physics_ocn public :: run_stochastic_physics_ocn contains -!!!!!!!!!!!!!!!!!!!! -subroutine init_stochastic_physics_ocn(delt,geoLonT,geoLatT,nx,ny,nz,pert_epbl_in,do_sppt_in, & - mpiroot, mpicomm, iret) -implicit none -real,intent(in) :: delt !< timestep in seconds between calls to run_stochastic_physics_ocn -integer,intent(in) :: nx !< number of gridpoints in the x-direction of the compute grid -integer,intent(in) :: ny !< number of gridpoints in the y-direction of the compute grid -integer,intent(in) :: nz !< number of gridpoints in the z-direction of the compute grid -real,intent(in) :: geoLonT(nx,ny) !< Longitude in degrees -real,intent(in) :: geoLatT(nx,ny) !< Latitude in degrees -logical,intent(in) :: pert_epbl_in !< logical flag, if true generate random pattern for ePBL perturbations -logical,intent(in) :: do_sppt_in !< logical flag, if true generate random pattern for SPPT perturbations -integer,intent(in) :: mpiroot !< root processor -integer,intent(in) :: mpicomm !< mpi communicator -integer, intent(out) :: iret !< return code - -iret=0 -if (pert_epbl_in .EQV. .true. ) then - print*,'pert_epbl needs to be false if using the stub' - iret=-1 -endif -if (do_sppt_in.EQV. .true. ) then - print*,'do_sppt needs to be false if using the stub' - iret=-1 -endif -return -end subroutine init_stochastic_physics_ocn - -subroutine run_stochastic_physics_ocn(sppt_wts,t_rp1,t_rp2) -implicit none -real, intent(inout) :: sppt_wts(:,:) !< array containing random weights for SPPT range [0,2] -real, intent(inout) :: t_rp1(:,:) !< array containing random weights for ePBL - !! perturbations (KE generation) range [0,2] -real, intent(inout) :: t_rp2(:,:) !< array containing random weights for ePBL - !! perturbations (KE dissipation) range [0,2] -return -end subroutine run_stochastic_physics_ocn +!> Initializes the stochastic physics perturbations. +subroutine init_stochastic_physics_ocn(delt, geoLonT, geoLatT, nxT, nyT, nz, & + geoLonB, geoLatB, nxB, nyB, & + pert_epbl_in, do_sppt_in, & + do_skeb_in, mpiroot, mpicomm, iret) + real, intent(in) :: delt !< timestep in seconds between calls to run_stochastic_physics_ocn [s] + integer, intent(in) :: nxT !< number of T gridpoints in the x-direction of the compute grid + integer, intent(in) :: nyT !< number of T gridpoints in the y-direction of the compute grid + integer, intent(in) :: nz !< number of gridpoints in the z-direction of the compute grid + real, intent(in) :: geoLonT(nxT,nyT) !< Longitude of T points in degrees + real, intent(in) :: geoLatT(nxT,nyT) !< Latitude of T points in degrees + integer, intent(in) :: nxB !< number of B gridpoints in the x-direction of the compute grid + integer, intent(in) :: nyB !< number of B gridpoints in the y-direction of the compute grid + real, intent(in) :: geoLonB(nxB,nyB) !< Longitude of B points in degrees + real, intent(in) :: geoLatB(nxB,nyB) !< Latitude of B points in degrees + logical, intent(in) :: pert_epbl_in !< logical flag, if true generate random pattern for ePBL perturbations + logical, intent(in) :: do_sppt_in !< logical flag, if true generate random pattern for SPPT perturbations + logical, intent(in) :: do_skeb_in !< logical flag, if true generate random pattern for SKEB perturbations + integer, intent(in) :: mpiroot !< root processor + integer, intent(in) :: mpicomm !< mpi communicator + integer, intent(out) :: iret !< return code -end module stochastic_physics + iret=0 + if (pert_epbl_in) then + call MOM_error(WARNING, 'init_stochastic_physics_ocn: pert_epbl needs to be false if using the stub') + iret=-1 + endif + if (do_sppt_in) then + call MOM_error(WARNING, 'init_stochastic_physics_ocn: do_sppt needs to be false if using the stub') + iret=-1 + endif + if (do_skeb_in) then + call MOM_error(WARNING, 'init_stochastic_physics_ocn: do_skeb needs to be false if using the stub') + iret=-1 + endif -module get_stochy_pattern_mod - -private + ! This stub function does not actually do anything. + return +end subroutine init_stochastic_physics_ocn -public :: write_stoch_restart_ocn -contains -subroutine write_stoch_restart_ocn(sfile) +!> Determines the stochastic physics perturbations. +subroutine run_stochastic_physics_ocn(sppt_wts, skeb_wts, t_rp1, t_rp2) + real, intent(inout) :: sppt_wts(:,:) !< array containing random weights for SPPT range [0,2] + real, intent(inout) :: skeb_wts(:,:) !< array containing random weights for SKEB + real, intent(inout) :: t_rp1(:,:) !< array containing random weights for ePBL + !! perturbations (KE generation) range [0,2] + real, intent(inout) :: t_rp2(:,:) !< array containing random weights for ePBL + !! perturbations (KE dissipation) range [0,2] -character(len=*) :: sfile !< name of restart file -return -end subroutine write_stoch_restart_ocn + ! This stub function does not actually do anything. + return +end subroutine run_stochastic_physics_ocn -end module get_stochy_pattern_mod +end module stochastic_physics diff --git a/config_src/infra/FMS1/MOM_coms_infra.F90 b/config_src/infra/FMS1/MOM_coms_infra.F90 index 555b4df119..a9395440bd 100644 --- a/config_src/infra/FMS1/MOM_coms_infra.F90 +++ b/config_src/infra/FMS1/MOM_coms_infra.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Thin interfaces to non-domain-oriented mpp communication subroutines module MOM_coms_infra -! This file is part of MOM6. See LICENSE.md for the license. - use iso_fortran_env, only : int32, int64 use mpp_mod, only : mpp_pe, mpp_root_pe, mpp_npes, mpp_set_root_pe @@ -14,8 +16,9 @@ module MOM_coms_infra implicit none ; private -public :: PE_here, root_PE, num_PEs, set_rootPE, Set_PElist, Get_PElist +public :: PE_here, root_PE, num_PEs, set_rootPE, Set_PElist, Get_PElist, sync_PEs public :: broadcast, sum_across_PEs, min_across_PEs, max_across_PEs +public :: any_across_PEs, all_across_PEs public :: field_chksum, MOM_infra_init, MOM_infra_end ! This module provides interfaces to the non-domain-oriented communication @@ -24,7 +27,7 @@ module MOM_coms_infra !> Communicate an array, string or scalar from one PE to others interface broadcast module procedure broadcast_char, broadcast_int32_0D, broadcast_int64_0D, broadcast_int1D - module procedure broadcast_real0D, broadcast_real1D, broadcast_real2D + module procedure broadcast_real0D, broadcast_real1D, broadcast_real2D, broadcast_real3D end interface broadcast !> Compute a checksum for a field distributed over a PE list. If no PE list is @@ -107,6 +110,13 @@ subroutine Get_PEList(pelist, name, commID) call mpp_get_current_pelist(pelist, name, commiD) end subroutine Get_PEList +!> Sync the PEs at a defined point in the model +subroutine sync_PEs(pelist) + integer, optional, intent(in) :: pelist(:) !< The list of PEs to be synced + + call mpp_sync(pelist) +end subroutine sync_PEs + !> Communicate a 1-D array of character strings from one PE to others subroutine broadcast_char(dat, length, from_PE, PElist, blocking) character(len=*), intent(inout) :: dat(:) !< The data to communicate and destination @@ -252,6 +262,28 @@ subroutine broadcast_real2D(dat, length, from_PE, PElist, blocking) end subroutine broadcast_real2D + +!> Communicate a 3-D array of reals from one PE to others +subroutine broadcast_real3D(dat, length, from_PE, PElist, blocking) + real, dimension(:,:,:), intent(inout) :: dat !< The data to communicate and destination + integer, intent(in) :: length !< The total number of data elements + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, length, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_real3D + ! field_chksum wrappers !> Compute a checksum for a field distributed over a PE list. If no PE list is @@ -438,6 +470,36 @@ subroutine min_across_PEs_real_1d(field, length, pelist) call mpp_min(field, length, pelist) end subroutine min_across_PEs_real_1d +!> Implementation of any() intrinsic across PEs +function any_across_PEs(field, pelist) + logical, intent(in) :: field !< Local PE value + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + logical :: any_across_PEs + + integer :: field_flag + + ! FMS1 does not support logical collectives, so integer flags are used. + field_flag = 0 + if (field) field_flag = 1 + call max_across_PEs(field_flag, pelist) + any_across_PEs = (field_flag > 0) +end function any_across_PEs + +!> Implementation of all() intrinsic across PEs +function all_across_PEs(field, pelist) + logical, intent(in) :: field !< Local PE value + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + logical :: all_across_PEs + + integer :: field_flag + + ! FMS1 does not support logical collectives, so integer flags are used. + field_flag = 0 + if (field) field_flag = 1 + call min_across_PEs(field_flag, pelist) + all_across_PEs = (field_flag > 0) +end function all_across_PEs + !> Initialize the model framework, including PE communication over a designated communicator. !! If no communicator ID is provided, the framework's default communicator is used. subroutine MOM_infra_init(localcomm) diff --git a/config_src/infra/FMS1/MOM_constants.F90 b/config_src/infra/FMS1/MOM_constants.F90 index 2db177e08c..ad44ba4f85 100644 --- a/config_src/infra/FMS1/MOM_constants.F90 +++ b/config_src/infra/FMS1/MOM_constants.F90 @@ -1,14 +1,20 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Provides a few physical constants module MOM_constants -! This file is part of MOM6. See LICENSE.md for the license. - -use constants_mod, only : HLV, HLF +use constants_mod, only : FMS_HLV => HLV +use constants_mod, only : FMS_HLF => HLF implicit none ; private -!> The constant offset for converting temperatures in Kelvin to Celsius real, public, parameter :: CELSIUS_KELVIN_OFFSET = 273.15 -public :: HLV, HLF + !< The constant offset for converting temperatures in Kelvin to Celsius [K] +real, public, parameter :: HLV = real(FMS_HLV, kind=kind(1.0)) + !< Latent heat of vaporization [J kg-1] +real, public, parameter :: HLF = real(FMS_HLF, kind=kind(1.0)) + !< Latent heat of fusion [J kg-1] end module MOM_constants diff --git a/config_src/infra/FMS1/MOM_couplertype_infra.F90 b/config_src/infra/FMS1/MOM_couplertype_infra.F90 index 3bcccc1dc7..e196b7e147 100644 --- a/config_src/infra/FMS1/MOM_couplertype_infra.F90 +++ b/config_src/infra/FMS1/MOM_couplertype_infra.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> This module wraps the FMS coupler types module module MOM_couplertype_infra -! This file is part of MOM6. See LICENSE.md for the license. - use coupler_types_mod, only : coupler_type_spawn, coupler_type_initialized, coupler_type_destructor use coupler_types_mod, only : coupler_type_set_diags, coupler_type_send_data, coupler_type_copy_data use coupler_types_mod, only : coupler_type_write_chksums, coupler_type_redistribute_data @@ -409,8 +411,6 @@ subroutine CT_set_data(array_in, bc_index, field_index, var, & !! the second dimension of the output array !! in a non-decreasing list - integer :: subfield ! An integer indicating which field to set. - call coupler_type_set_data(array_in, bc_index, field_index, var, scale_factor, halo_size, idim, jdim) end subroutine CT_set_data diff --git a/config_src/infra/FMS1/MOM_cpu_clock_infra.F90 b/config_src/infra/FMS1/MOM_cpu_clock_infra.F90 index 0c42c577b4..aeca65b863 100644 --- a/config_src/infra/FMS1/MOM_cpu_clock_infra.F90 +++ b/config_src/infra/FMS1/MOM_cpu_clock_infra.F90 @@ -1,10 +1,12 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Wraps the MPP cpu clock functions !! !! The functions and constants should be accessed via mom_cpu_clock module MOM_cpu_clock_infra -! This file is part of MOM6. See LICENSE.md for the license. - ! These interfaces and constants from MPP/FMS will not be directly exposed outside of this module use fms_mod, only : clock_flag_default use mpp_mod, only : mpp_clock_begin diff --git a/config_src/infra/FMS1/MOM_data_override_infra.F90 b/config_src/infra/FMS1/MOM_data_override_infra.F90 index 1484f0c128..57311710c8 100644 --- a/config_src/infra/FMS1/MOM_data_override_infra.F90 +++ b/config_src/infra/FMS1/MOM_data_override_infra.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> These interfaces allow for ocean or sea-ice variables to be replaced with data. module MOM_data_override_infra -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_domain_infra, only : MOM_domain_type, domain2d use MOM_domain_infra, only : get_simple_array_i_ind, get_simple_array_j_ind use MOM_time_manager, only : time_type diff --git a/config_src/infra/FMS1/MOM_diag_manager_infra.F90 b/config_src/infra/FMS1/MOM_diag_manager_infra.F90 index 18c80cf24c..2031487389 100644 --- a/config_src/infra/FMS1/MOM_diag_manager_infra.F90 +++ b/config_src/infra/FMS1/MOM_diag_manager_infra.F90 @@ -1,3 +1,7 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> A wrapper for the FMS diag_manager routines. This module should be the !! only MOM6 module which imports the FMS shared infrastructure for !! diagnostics. Pass through interfaces are being documented @@ -6,8 +10,7 @@ !! those APIs would be applied here). module MOM_diag_manager_infra -! This file is part of MOM6. See LICENSE.md for the license. - +use, intrinsic :: iso_fortran_env, only : real64 use diag_axis_mod, only : fms_axis_init=>diag_axis_init use diag_axis_mod, only : fms_get_diag_axis_name => get_diag_axis_name use diag_axis_mod, only : EAST, NORTH @@ -57,6 +60,8 @@ module MOM_diag_manager_infra public MOM_diag_manager_init public MOM_diag_manager_end public send_data_infra +public diag_send_complete_infra +public diag_manager_set_time_end_infra public MOM_diag_field_add_attribute public register_diag_field_infra public register_static_field_infra @@ -72,36 +77,36 @@ module MOM_diag_manager_infra !> Initialize a diagnostic axis integer function MOM_diag_axis_init(name, data, units, cart_name, long_name, MOM_domain, position, & & direction, edges, set_name, coarsen, null_axis) - character(len=*), intent(in) :: name !< The name of this axis - real, dimension(:), intent(in) :: data !< The array of coordinate values - character(len=*), intent(in) :: units !< The units for the axis data - character(len=*), intent(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", or "N" for none) - character(len=*), & - optional, intent(in) :: long_name !< The long name of this axis - type(MOM_domain_type), & - optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition - integer, optional, intent(in) :: position !< This indicates the relative position of this - !! axis. The default is CENTER, but EAST and NORTH - !! are common options. - integer, optional, intent(in) :: direction !< This indicates the direction along which this - !! axis increases: 1 for upward, -1 for downward, or - !! 0 for non-vertical axes (the default) - integer, optional, intent(in) :: edges !< The axis_id of the complementary axis that - !! describes the edges of this axis - character(len=*), & - optional, intent(in) :: set_name !< A name to use for this set of axes. - integer, optional, intent(in) :: coarsen !< An optional degree of coarsening for the grid, 1 - !! by default. - logical, optional, intent(in) :: null_axis !< If present and true, return the special null axis - !! id for use with scalars. - - integer :: coarsening ! The degree of grid coarsening - - if (present(null_axis)) then ; if (null_axis) then - ! Return the special null axis id for scalars - MOM_diag_axis_init = null_axis_id - return - endif ; endif + character(len=*), intent(in) :: name !< The name of this axis + real, dimension(:), intent(in) :: data !< The array of coordinate values + character(len=*), intent(in) :: units !< The units for the axis data + character(len=*), intent(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", or "N" for none) + character(len=*), & + optional, intent(in) :: long_name !< The long name of this axis + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + integer, optional, intent(in) :: position !< This indicates the relative position of this + !! axis. The default is CENTER, but EAST and NORTH + !! are common options. + integer, optional, intent(in) :: direction !< This indicates the direction along which this + !! axis increases: 1 for upward, -1 for downward, or + !! 0 for non-vertical axes (the default) + integer, optional, intent(in) :: edges !< The axis_id of the complementary axis that + !! describes the edges of this axis + character(len=*), & + optional, intent(in) :: set_name !< A name to use for this set of axes. + integer, optional, intent(in) :: coarsen !< An optional degree of coarsening for the grid, 1 + !! by default. + logical, optional, intent(in) :: null_axis !< If present and true, return the special null axis + !! id for use with scalars. + + integer :: coarsening ! The degree of grid coarsening + + if (present(null_axis)) then ; if (null_axis) then + ! Return the special null axis id for scalars + MOM_diag_axis_init = null_axis_id + return + endif ; endif if (present(MOM_domain)) then coarsening = 1 ; if (present(coarsen)) coarsening = coarsen @@ -236,9 +241,15 @@ integer function register_static_field_infra(module_name, field_name, axes, long integer, optional, intent(in) :: area !< Diagnostic ID of the field containing the area attribute integer, optional, intent(in) :: volume !< Diagnostic ID of the field containing the volume attribute - register_static_field_infra = register_static_field_fms(module_name, field_name, axes, long_name, units,& - & missing_value, range, mask_variant, standard_name, dynamic=.false.,do_not_log=do_not_log, & + if(present(missing_value) .or. present(range)) then + register_static_field_infra = register_static_field_fms(module_name, field_name, axes, long_name, units,& + & missing_value, range, mask_variant=mask_variant, standard_name=standard_name, dynamic=.false.,& + do_not_log=do_not_log, interp_method=interp_method,tile_count=tile_count, area=area, volume=volume) + else + register_static_field_infra = register_static_field_fms(module_name, field_name, axes, long_name, units,& + & mask_variant=mask_variant, standard_name=standard_name, dynamic=.false.,do_not_log=do_not_log, & interp_method=interp_method,tile_count=tile_count, area=area, volume=volume) + endif end function register_static_field_infra !> Returns true if the argument data are successfully passed to a diagnostic manager @@ -267,7 +278,20 @@ logical function send_data_infra_1d(diag_field_id, field, is_in, ie_in, time, ma character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon !! returning to the calling routine - send_data_infra_1d = send_data_fms(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg) + if(present(rmask) .or. present(weight)) then + if(present(rmask) .and. present(weight)) then + send_data_infra_1d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, mask=mask, rmask=rmask, ie_in=ie_in,& + weight=weight, err_msg=err_msg) + elseif(present(rmask)) then + send_data_infra_1d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, mask=mask, rmask=rmask, ie_in=ie_in,& + err_msg=err_msg) + elseif(present(weight)) then + send_data_infra_1d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, ie_in=ie_in, weight=weight,& + err_msg=err_msg) + endif + else + send_data_infra_1d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, ie_in=ie_in, err_msg=err_msg) + endif end function send_data_infra_1d @@ -289,9 +313,21 @@ logical function send_data_infra_2d(diag_field_id, field, is_in, ie_in, js_in, j character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon !! returning to the calling routine - send_data_infra_2d = send_data_fms(diag_field_id, field, time, is_in, js_in, mask, & - rmask, ie_in, je_in, weight, err_msg) - + if(present(rmask) .or. present(weight)) then + if(present(rmask) .and. present(weight)) then + send_data_infra_2d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, mask=mask, & + rmask=rmask, ie_in=ie_in, je_in=je_in, weight=weight, err_msg=err_msg) + elseif(present(rmask)) then + send_data_infra_2d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, mask=mask, & + rmask=rmask, ie_in=ie_in, je_in=je_in, err_msg=err_msg) + elseif(present(weight)) then + send_data_infra_2d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, mask=mask, & + ie_in=ie_in, je_in=je_in, weight=weight, err_msg=err_msg) + endif + else + send_data_infra_2d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, mask=mask, & + ie_in=ie_in, je_in=je_in, err_msg=err_msg) + endif end function send_data_infra_2d !> Returns true if the argument data are successfully passed to a diagnostic manager @@ -326,7 +362,7 @@ end function send_data_infra_3d logical function send_data_infra_2d_r8(diag_field_id, field, is_in, ie_in, js_in, je_in, & time, mask, rmask, weight, err_msg) integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field - real(kind=8), dimension(:,:), intent(in) :: field !< A 2-d array of values being recorded + real(kind=real64), dimension(:,:), intent(in) :: field !< A 2-d array of values being recorded integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded @@ -349,7 +385,7 @@ end function send_data_infra_2d_r8 logical function send_data_infra_3d_r8(diag_field_id, field, is_in, ie_in, js_in, je_in, ks_in, ke_in, & time, mask, rmask, weight, err_msg) integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field - real(kind=8), dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded + real(kind=real64), dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded @@ -420,4 +456,13 @@ subroutine MOM_diag_field_add_attribute_i1d(diag_field_id, att_name, att_value) end subroutine MOM_diag_field_add_attribute_i1d +!> Needed for backwards compatibility, does nothing +subroutine diag_send_complete_infra () +end subroutine diag_send_complete_infra + +!> Needed for backwards compatibility, does nothing +subroutine diag_manager_set_time_end_infra(time) + type(time_type), intent(in) :: time !< The model time that simulation ends +end subroutine diag_manager_set_time_end_infra + end module MOM_diag_manager_infra diff --git a/config_src/infra/FMS1/MOM_domain_infra.F90 b/config_src/infra/FMS1/MOM_domain_infra.F90 index 7eff4597f3..5a8c4d7894 100644 --- a/config_src/infra/FMS1/MOM_domain_infra.F90 +++ b/config_src/infra/FMS1/MOM_domain_infra.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Describes the decomposed MOM domain and has routines for communications across PEs module MOM_domain_infra -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_coms_infra, only : PE_here, root_PE, num_PEs use MOM_cpu_clock_infra, only : cpu_clock_begin, cpu_clock_end use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, WARNING, FATAL @@ -16,18 +18,21 @@ module MOM_domain_infra use mpp_domains_mod, only : mpp_create_group_update, mpp_do_group_update use mpp_domains_mod, only : mpp_reset_group_update_field, mpp_group_update_initialized use mpp_domains_mod, only : mpp_start_group_update, mpp_complete_group_update -use mpp_domains_mod, only : mpp_compute_block_extent +use mpp_domains_mod, only : mpp_compute_block_extent, mpp_compute_extent use mpp_domains_mod, only : mpp_broadcast_domain, mpp_redistribute, mpp_global_field use mpp_domains_mod, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM -use mpp_domains_mod, only : CYCLIC_GLOBAL_DOMAIN, FOLD_NORTH_EDGE +use mpp_domains_mod, only : CYCLIC_GLOBAL_DOMAIN +use mpp_domains_mod, only : FOLD_NORTH_EDGE, FOLD_SOUTH_EDGE, FOLD_EAST_EDGE, FOLD_WEST_EDGE use mpp_domains_mod, only : To_East => WUPDATE, To_West => EUPDATE, Omit_Corners => EDGEUPDATE use mpp_domains_mod, only : To_North => SUPDATE, To_South => NUPDATE use mpp_domains_mod, only : CENTER, CORNER, NORTH_FACE => NORTH, EAST_FACE => EAST use fms_io_mod, only : file_exist, parse_mask_table +use fms_io_mod, only : fms_set_domain => set_domain +use fms_io_mod, only : fms_nullify_domain => nullify_domain use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set, fms_affinity_get ! This subroutine is not in MOM6/src but may be required by legacy drivers -use mpp_domains_mod, only : global_field_sum => mpp_global_sum +! use mpp_domains_mod, only : global_field_sum => mpp_global_sum ! The `group_pass_type` fields are never accessed, so we keep it as an FMS type use mpp_domains_mod, only : group_pass_type => mpp_group_update_type @@ -38,20 +43,21 @@ module MOM_domain_infra public :: domain2D, domain1D, group_pass_type ! These interfaces are actually implemented or have explicit interfaces in this file. public :: create_MOM_domain, clone_MOM_domain, get_domain_components, get_domain_extent -public :: deallocate_MOM_domain, get_global_shape, compute_block_extent +public :: deallocate_MOM_domain, get_global_shape, compute_block_extent, compute_extent public :: pass_var, pass_vector, fill_symmetric_edges, rescale_comp_data public :: pass_var_start, pass_var_complete, pass_vector_start, pass_vector_complete public :: create_group_pass, do_group_pass, start_group_pass, complete_group_pass public :: redistribute_array, broadcast_domain, same_domain, global_field public :: get_simple_array_i_ind, get_simple_array_j_ind public :: MOM_thread_affinity_set, set_MOM_thread_affinity -! These are encoding constant parmeters. +! These are encoding constant parmeters with self-explanatory names. public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR public :: CORNER, CENTER, NORTH_FACE, EAST_FACE +public :: set_domain, nullify_domain ! These are no longer used by MOM6 because the reproducing sum works so well, but they are ! still referenced by some of the non-GFDL couplers. -public :: global_field_sum, BITWISE_EXACT_SUM +! public :: global_field_sum, BITWISE_EXACT_SUM !> Do a halo update on an array interface pass_var @@ -241,8 +247,8 @@ subroutine pass_var_2d(array, MOM_dom, sideflag, complete, position, halo, inner ! Local variables real, allocatable, dimension(:,:) :: tmp integer :: pos, i_halo, j_halo - integer :: isc, iec, jsc, jec, isd, ied, jsd, jed, IscB, IecB, JscB, JecB - integer :: inner, i, j, isfw, iefw, isfe, iefe, jsfs, jefs, jsfn, jefn + integer :: isc, iec, jsc, jec, isd, ied, jsd, jed + integer :: i, j, isfw, iefw, isfe, iefe, jsfs, jefs, jsfn, jefn integer :: dirflag logical :: block_til_complete @@ -593,7 +599,6 @@ subroutine fill_vector_symmetric_edges_2d(u_cmpt, v_cmpt, MOM_dom, stagger, scal integer :: dirflag integer :: i, j, isc, iec, jsc, jec, isd, ied, jsd, jed, IscB, IecB, JscB, JecB real, allocatable, dimension(:) :: sbuff_x, sbuff_y, wbuff_x, wbuff_y - logical :: block_til_complete if (.not. MOM_dom%symmetric) then return @@ -1210,7 +1215,7 @@ subroutine redistribute_array_2d(Domain1, array1, Domain2, array2, complete) ! Local variables logical :: do_complete - do_complete=.true.;if (PRESENT(complete)) do_complete = complete + do_complete=.true. ; if (PRESENT(complete)) do_complete = complete call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete) @@ -1229,7 +1234,7 @@ subroutine redistribute_array_3d(Domain1, array1, Domain2, array2, complete) ! Local variables logical :: do_complete - do_complete=.true.;if (PRESENT(complete)) do_complete = complete + do_complete=.true. ; if (PRESENT(complete)) do_complete = complete call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete) @@ -1248,7 +1253,7 @@ subroutine redistribute_array_4d(Domain1, array1, Domain2, array2, complete) ! Local variables logical :: do_complete - do_complete=.true.;if (PRESENT(complete)) do_complete = complete + do_complete=.true. ; if (PRESENT(complete)) do_complete = complete call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete) @@ -1256,53 +1261,89 @@ end subroutine redistribute_array_4d !> Rescale the values of a 4-D array in its computational domain by a constant factor -subroutine rescale_comp_data_4d(domain, array, scale) +subroutine rescale_comp_data_4d(domain, array, scale, zero_zeros) type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information real, dimension(:,:,:,:), intent(inout) :: array !< The array which is having the data in its !! computational domain rescaled real, intent(in) :: scale !< A scaling factor by which to multiply the !! values in the computational domain of array - integer :: is, ie, js, je + logical, optional, intent(in) :: zero_zeros !< If present and true, convert negative zeros + !! into ordinary signless zeros. + logical :: unsign_zeros ! If true, convert negative zeros into ordinary signless zeros. + integer :: is, ie, js, je, i, j, k, m + + unsign_zeros = .false. ; if (present(zero_zeros)) unsign_zeros = zero_zeros - if (scale == 1.0) return + if ((scale == 1.0) .and. (.not.unsign_zeros)) return call get_simple_array_i_ind(domain, size(array,1), is, ie) call get_simple_array_j_ind(domain, size(array,2), js, je) - array(is:ie,js:je,:,:) = scale*array(is:ie,js:je,:,:) + if (scale /= 1.0) & + array(is:ie,js:je,:,:) = scale*array(is:ie,js:je,:,:) + + if (unsign_zeros) then ! Convert negative zeros into zeros + do m=1,size(array,4) ; do k=1,size(array,3) ; do j=js,je ; do i=is,ie + if (array(i,j,k,m) == 0.0) array(i,j,k,m) = 0.0 + enddo ; enddo ; enddo ; enddo + endif end subroutine rescale_comp_data_4d !> Rescale the values of a 3-D array in its computational domain by a constant factor -subroutine rescale_comp_data_3d(domain, array, scale) +subroutine rescale_comp_data_3d(domain, array, scale, zero_zeros) type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information real, dimension(:,:,:), intent(inout) :: array !< The array which is having the data in its !! computational domain rescaled real, intent(in) :: scale !< A scaling factor by which to multiply the !! values in the computational domain of array - integer :: is, ie, js, je + logical, optional, intent(in) :: zero_zeros !< If present and true, convert negative zeros + !! into ordinary signless zeros. + logical :: unsign_zeros ! If true, convert negative zeros into ordinary signless zeros. + integer :: is, ie, js, je, i, j, k - if (scale == 1.0) return + unsign_zeros = .false. ; if (present(zero_zeros)) unsign_zeros = zero_zeros + + if ((scale == 1.0) .and. (.not.unsign_zeros)) return call get_simple_array_i_ind(domain, size(array,1), is, ie) call get_simple_array_j_ind(domain, size(array,2), js, je) - array(is:ie,js:je,:) = scale*array(is:ie,js:je,:) + if (scale /= 1.0) & + array(is:ie,js:je,:) = scale*array(is:ie,js:je,:) + + if (unsign_zeros) then ! Convert negative zeros into zeros + do k=1,size(array,3) ; do j=js,je ; do i=is,ie + if (array(i,j,k) == 0.0) array(i,j,k) = 0.0 + enddo ; enddo ; enddo + endif end subroutine rescale_comp_data_3d !> Rescale the values of a 2-D array in its computational domain by a constant factor -subroutine rescale_comp_data_2d(domain, array, scale) +subroutine rescale_comp_data_2d(domain, array, scale, zero_zeros) type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information real, dimension(:,:), intent(inout) :: array !< The array which is having the data in its !! computational domain rescaled real, intent(in) :: scale !< A scaling factor by which to multiply the !! values in the computational domain of array - integer :: is, ie, js, je + logical, optional, intent(in) :: zero_zeros !< If present and true, convert negative zeros + !! into ordinary signless zeros. + logical :: unsign_zeros ! If true, convert negative zeros into ordinary signless zeros. + integer :: is, ie, js, je, i, j + + unsign_zeros = .false. ; if (present(zero_zeros)) unsign_zeros = zero_zeros - if (scale == 1.0) return + if ((scale == 1.0) .and. (.not.unsign_zeros)) return call get_simple_array_i_ind(domain, size(array,1), is, ie) call get_simple_array_j_ind(domain, size(array,2), js, je) - array(is:ie,js:je) = scale*array(is:ie,js:je) + if (scale /= 1.0) & + array(is:ie,js:je) = scale*array(is:ie,js:je) + + if (unsign_zeros) then ! Convert negative zeros into zeros + do j=js,je ; do i=is,ie + if (array(i,j) == 0.0) array(i,j) = 0.0 + enddo ; enddo + endif end subroutine rescale_comp_data_2d @@ -1328,10 +1369,8 @@ subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, l !! nonblocking halo updates, or false if missing. ! local variables - integer, dimension(4) :: global_indices ! The lower and upper global i- and j-index bounds integer :: X_FLAGS ! A combination of integers encoding the x-direction grid connectivity. integer :: Y_FLAGS ! A combination of integers encoding the y-direction grid connectivity. - integer :: xhalo_d2, yhalo_d2 character(len=200) :: mesg ! A string for use in error messages logical :: mask_table_exists ! Mask_table is present and the file it points to exists @@ -1352,8 +1391,10 @@ subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, l "TRIPOLAR_N and REENTRANT_Y may not be used together.") endif - MOM_dom%nonblocking_updates = nonblocking - MOM_dom%thin_halo_updates = thin_halos + MOM_dom%nonblocking_updates = .false. + if (present(nonblocking)) MOM_dom%nonblocking_updates = nonblocking + MOM_dom%thin_halo_updates = .false. + if (present(thin_halos)) MOM_dom%thin_halo_updates = thin_halos MOM_dom%symmetric = .true. ; if (present(symmetric)) MOM_dom%symmetric = symmetric MOM_dom%niglobal = n_global(1) ; MOM_dom%njglobal = n_global(2) MOM_dom%nihalo = n_halo(1) ; MOM_dom%njhalo = n_halo(2) @@ -1492,7 +1533,7 @@ end subroutine get_domain_components_d2D !> clone_MD_to_MD copies one MOM_domain_type into another, while allowing !! some properties of the new type to differ from the original one. subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain_name, & - turns, refine, extra_halo) + turns, refine, extra_halo, io_layout) type(MOM_domain_type), target, intent(in) :: MD_in !< An existing MOM_domain type(MOM_domain_type), pointer :: MOM_dom !< A pointer to a MOM_domain that will be @@ -1515,8 +1556,9 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain integer, optional, intent(in) :: refine !< A factor by which to enhance the grid resolution. integer, optional, intent(in) :: extra_halo !< An extra number of points in the halos !! compared with MD_in + integer, optional, intent(in) :: io_layout(2) + !< A user-defined IO layout to replace the domain's IO layout - integer :: global_indices(4) logical :: mask_table_exists integer, dimension(:), allocatable :: exni ! The extents of the grid for each i-row of the layout. ! The sum of exni must equal MOM_dom%niglobal. @@ -1524,10 +1566,17 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain ! The sum of exni must equal MOM_dom%niglobal. integer :: qturns ! The number of quarter turns, restricted to the range of 0 to 3. integer :: i, j, nl1, nl2 + integer :: io_layout_in(2) qturns = 0 if (present(turns)) qturns = modulo(turns, 4) + if (present(io_layout)) then + io_layout_in(:) = io_layout(:) + else + io_layout_in(:) = MD_in%io_layout(:) + endif + if (.not.associated(MOM_dom)) then allocate(MOM_dom) allocate(MOM_dom%mpp_domain) @@ -1545,19 +1594,40 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain call get_layout_extents(MD_in, exnj, exni) MOM_dom%X_FLAGS = MD_in%Y_FLAGS ; MOM_dom%Y_FLAGS = MD_in%X_FLAGS + ! Correct the position of a tripolar grid, assuming that flags are not additive. + if (qturns == 1) then + if (MD_in%Y_FLAGS == FOLD_NORTH_EDGE) MOM_dom%X_FLAGS = FOLD_EAST_EDGE + if (MD_in%Y_FLAGS == FOLD_SOUTH_EDGE) MOM_dom%X_FLAGS = FOLD_WEST_EDGE + if (MD_in%X_FLAGS == FOLD_EAST_EDGE) MOM_dom%Y_FLAGS = FOLD_SOUTH_EDGE + if (MD_in%X_FLAGS == FOLD_WEST_EDGE) MOM_dom%Y_FLAGS = FOLD_NORTH_EDGE + elseif (qturns == 3) then + if (MD_in%Y_FLAGS == FOLD_NORTH_EDGE) MOM_dom%X_FLAGS = FOLD_WEST_EDGE + if (MD_in%Y_FLAGS == FOLD_SOUTH_EDGE) MOM_dom%X_FLAGS = FOLD_EAST_EDGE + if (MD_in%X_FLAGS == FOLD_EAST_EDGE) MOM_dom%Y_FLAGS = FOLD_NORTH_EDGE + if (MD_in%X_FLAGS == FOLD_WEST_EDGE) MOM_dom%Y_FLAGS = FOLD_SOUTH_EDGE + endif + MOM_dom%layout(:) = MD_in%layout(2:1:-1) - MOM_dom%io_layout(:) = MD_in%io_layout(2:1:-1) + MOM_dom%io_layout(:) = io_layout_in(2:1:-1) else MOM_dom%niglobal = MD_in%niglobal ; MOM_dom%njglobal = MD_in%njglobal MOM_dom%nihalo = MD_in%nihalo ; MOM_dom%njhalo = MD_in%njhalo call get_layout_extents(MD_in, exni, exnj) MOM_dom%X_FLAGS = MD_in%X_FLAGS ; MOM_dom%Y_FLAGS = MD_in%Y_FLAGS + ! Correct the position of a tripolar grid, assuming that flags are not additive. + if (qturns == 2) then + if (MD_in%Y_FLAGS == FOLD_NORTH_EDGE) MOM_dom%Y_FLAGS = FOLD_SOUTH_EDGE + if (MD_in%Y_FLAGS == FOLD_SOUTH_EDGE) MOM_dom%Y_FLAGS = FOLD_NORTH_EDGE + if (MD_in%X_FLAGS == FOLD_EAST_EDGE) MOM_dom%X_FLAGS = FOLD_WEST_EDGE + if (MD_in%X_FLAGS == FOLD_WEST_EDGE) MOM_dom%X_FLAGS = FOLD_EAST_EDGE + endif + MOM_dom%layout(:) = MD_in%layout(:) - MOM_dom%io_layout(:) = MD_in%io_layout(:) + MOM_dom%io_layout(:) = io_layout_in(:) endif - ! Ensure that the points per processor are the same on the source and densitation grids. + ! Ensure that the points per processor are the same on the source and destination grids. select case (qturns) case (1) ; call invert(exni) case (2) ; call invert(exni) ; call invert(exnj) @@ -1819,7 +1889,7 @@ subroutine get_domain_extent_d2D(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed) integer, optional, intent(out) :: jed !< The end j-index of the data domain ! Local variables - integer :: isd_, ied_, jsd_, jed_, jsg_, jeg_, isg_, ieg_ + integer :: isd_, ied_, jsd_, jed_ call mpp_get_compute_domain(Domain, isc, iec, jsc, jec) call mpp_get_data_domain(Domain, isd_, ied_, jsd_, jed_) @@ -1906,14 +1976,14 @@ end subroutine get_simple_array_j_ind !> Invert the contents of a 1-d array subroutine invert(array) - integer, dimension(:), intent(inout) :: array !< The 1-d array to invert - integer :: i, ni, swap - ni = size(array) - do i=1,ni - swap = array(i) - array(i) = array(ni+1-i) - array(ni+1-i) = swap - enddo + integer, dimension(:), intent(inout) :: array !< The 1-d array to invert + integer :: i, ni, swap + ni = size(array) + do i=1,ni + swap = array(i) + array(i) = array(ni+1-i) + array(ni+1-i) = swap + enddo end subroutine invert !> Returns the global shape of h-point arrays @@ -1937,6 +2007,17 @@ subroutine compute_block_extent(isg, ieg, ndivs, ibegin, iend) call mpp_compute_block_extent(isg, ieg, ndivs, ibegin, iend) end subroutine compute_block_extent +!> Get the array ranges in one dimension for the divisions of a global index space +subroutine compute_extent(isg, ieg, ndivs, ibegin, iend) + integer, intent(in) :: isg !< The starting index of the global index space + integer, intent(in) :: ieg !< The ending index of the global index space + integer, intent(in) :: ndivs !< The number of divisions + integer, dimension(:), intent(out) :: ibegin !< The starting index of each division + integer, dimension(:), intent(out) :: iend !< The ending index of each division + + call mpp_compute_extent(isg, ieg, ndivs, ibegin, iend) +end subroutine compute_extent + !> Broadcast a 2-d domain from the root PE to the other PEs subroutine broadcast_domain(domain) type(domain2d), intent(inout) :: domain !< The domain2d type that will be shared across PEs. @@ -1993,4 +2074,17 @@ subroutine get_layout_extents(Domain, extent_i, extent_j) call mpp_get_domain_extents(domain%mpp_domain, extent_i, extent_j) end subroutine get_layout_extents +!> Set the associated domain for internal FMS I/O operations. +subroutine set_domain(Domain) + type(MOM_domain_type), intent(in) :: Domain + !< MOM domain to be designated as the internal FMS I/O domain + + call fms_set_domain(Domain%mpp_domain) +end subroutine set_domain + +!> Free the associated domain for internal FMS I/O operations. +subroutine nullify_domain + call fms_nullify_domain +end subroutine nullify_domain + end module MOM_domain_infra diff --git a/config_src/infra/FMS1/MOM_ensemble_manager_infra.F90 b/config_src/infra/FMS1/MOM_ensemble_manager_infra.F90 index 66bbb86e2f..436cf28654 100644 --- a/config_src/infra/FMS1/MOM_ensemble_manager_infra.F90 +++ b/config_src/infra/FMS1/MOM_ensemble_manager_infra.F90 @@ -1,14 +1,17 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> A simple (very thin) wrapper for managing ensemble member layout information module MOM_ensemble_manager_infra -! This file is part of MOM6. See LICENSE.md for the license. - use ensemble_manager_mod, only : FMS_ensemble_manager_init => ensemble_manager_init use ensemble_manager_mod, only : FMS_ensemble_pelist_setup => ensemble_pelist_setup use ensemble_manager_mod, only : FMS_get_ensemble_id => get_ensemble_id use ensemble_manager_mod, only : FMS_get_ensemble_size => get_ensemble_size use ensemble_manager_mod, only : FMS_get_ensemble_pelist => get_ensemble_pelist use ensemble_manager_mod, only : FMS_get_ensemble_filter_pelist => get_ensemble_filter_pelist +use fms_io_mod, only : fms_io_set_filename_appendix=>set_filename_appendix implicit none ; private @@ -20,9 +23,15 @@ module MOM_ensemble_manager_infra !> Initializes the ensemble manager which divides available resources !! in order to concurrently execute an ensemble of model realizations. -subroutine ensemble_manager_init() - - call FMS_ensemble_manager_init() +subroutine ensemble_manager_init(ensemble_suffix) + character(len=*), optional, intent(in) :: ensemble_suffix !> Ensemble suffix provided by the cap. This may be + !! provided to bypass FMS ensemble manager. + + if (present(ensemble_suffix)) then + call fms_io_set_filename_appendix(trim(ensemble_suffix)) + else + call FMS_ensemble_manager_init() + endif end subroutine ensemble_manager_init diff --git a/config_src/infra/FMS1/MOM_error_infra.F90 b/config_src/infra/FMS1/MOM_error_infra.F90 index e5a8b8dc68..7db14bc127 100644 --- a/config_src/infra/FMS1/MOM_error_infra.F90 +++ b/config_src/infra/FMS1/MOM_error_infra.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Routines for error handling and I/O management module MOM_error_infra -! This file is part of MOM6. See LICENSE.md for the license. - use mpp_mod, only : mpp_error, mpp_pe, mpp_root_pe, mpp_stdlog=>stdlog, mpp_stdout=>stdout use mpp_mod, only : NOTE, WARNING, FATAL diff --git a/config_src/infra/FMS1/MOM_interp_infra.F90 b/config_src/infra/FMS1/MOM_interp_infra.F90 index 774f6a67d2..3ce0834534 100644 --- a/config_src/infra/FMS1/MOM_interp_infra.F90 +++ b/config_src/infra/FMS1/MOM_interp_infra.F90 @@ -1,23 +1,38 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> This module wraps the FMS temporal and spatial interpolation routines module MOM_interp_infra -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_domain_infra, only : MOM_domain_type, domain2d use MOM_time_manager, only : time_type use horiz_interp_mod, only : horiz_interp_new, horiz_interp, horiz_interp_init, horiz_interp_type -use mpp_io_mod, only : axistype, mpp_get_axis_data +use mpp_io_mod, only : axistype, mpp_get_axis_data, mpp_get_atts use time_interp_external_mod, only : time_interp_external use time_interp_external_mod, only : init_external_field, time_interp_external_init use time_interp_external_mod, only : get_external_field_size -use time_interp_external_mod, only : get_external_field_axes, get_external_field_missing +use time_interp_external_mod, only : get_external_field_axes +use time_interp_external_mod, only : get_external_field_missing implicit none ; private -public :: horiz_interp_type, horiz_interp_init -public :: time_interp_extern, init_extern_field, time_interp_external_init +public :: horiz_interp_type, horizontal_interp_init +public :: time_interp_extern, init_extern_field, time_interp_extern_init public :: get_external_field_info, axistype, get_axis_data public :: run_horiz_interp, build_horiz_interp_weights +public :: external_field + +!< Handle of an external field for interpolation +type :: external_field + private + integer :: id + !< FMS ID for the interpolated field + character(len=:), allocatable :: filename + !< Filename containing the field values + character(len=:), allocatable :: label + !< Field name in the file +end type external_field !> Read a field based on model time, and rotate to the model domain. interface time_interp_extern @@ -39,6 +54,16 @@ module MOM_interp_infra contains +!> Do any initialization for the horizontal interpolation +subroutine horizontal_interp_init() + call horiz_interp_init() +end subroutine horizontal_interp_init + +!> Do any initialization for the time and space interpolation infrastructure +subroutine time_interp_extern_init() + call time_interp_external_init() +end subroutine time_interp_extern_init + !> perform horizontal interpolation of a 2d field using pre-computed weights !! source and destination coordinates are 2d subroutine horiz_interp_from_weights_field2d(Interp, data_in, data_out, verbose, mask_in, mask_out, & @@ -134,14 +159,13 @@ function get_extern_field_size(index) end function get_extern_field_size -!> get axes of an external field from field index +!> get size of an external field from field index function get_extern_field_axes(index) - integer, intent(in) :: index !< field index - type(axistype), dimension(4) :: get_extern_field_axes !< field axes + integer, intent(in) :: index !< field index + type(axistype) :: get_extern_field_axes(4) !< field size get_extern_field_axes = get_external_field_axes(index) - end function get_extern_field_axes @@ -157,46 +181,46 @@ end function get_extern_field_missing !> Get information about the external fields. -subroutine get_external_field_info(field_id, size, axes, missing) - integer, intent(in) :: field_id !< The integer index of the external - !! field returned from a previous - !! call to init_external_field() - integer, dimension(4), optional, intent(inout) :: size !< Dimension sizes for the input data - type(axistype), dimension(4), optional, intent(inout) :: axes !< Axis types for the input data - real, optional, intent(inout) :: missing !< Missing value for the input data +subroutine get_external_field_info(field, size, axes, missing) + type(external_field), intent(in) :: field + !< Handle for time interpolated external field returned from a previous + !! call to init_external_field() + integer, optional, intent(inout) :: size(4) + !< Dimension sizes for the input data + type(axistype), optional, intent(inout) :: axes(4) + !< Axis types for the input data + real, optional, intent(inout) :: missing + !< Missing value for the input data if (present(size)) then - size(1:4) = get_extern_field_size(field_id) + size(:) = get_extern_field_size(field%id) endif if (present(axes)) then - axes(1:4) = get_extern_field_axes(field_id) + axes(:) = get_extern_field_axes(field%id) endif if (present(missing)) then - missing = get_extern_field_missing(field_id) + missing = get_extern_field_missing(field%id) endif - end subroutine get_external_field_info !> Read a scalar field based on model time. -subroutine time_interp_extern_0d(field_id, time, data_in, verbose) - integer, intent(in) :: field_id !< The integer index of the external field returned - !! from a previous call to init_external_field() +subroutine time_interp_extern_0d(field, time, data_in, verbose) + type(external_field), intent(in) :: field !< Handle for time interpolated field type(time_type), intent(in) :: time !< The target time for the data real, intent(inout) :: data_in !< The interpolated value logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging - call time_interp_external(field_id, time, data_in, verbose=verbose) + call time_interp_external(field%id, time, data_in, verbose=verbose) end subroutine time_interp_extern_0d !> Read a 2d field from an external based on model time, potentially including horizontal !! interpolation and rotation of the data -subroutine time_interp_extern_2d(field_id, time, data_in, interp, verbose, horz_interp, mask_out) - integer, intent(in) :: field_id !< The integer index of the external field returned - !! from a previous call to init_external_field() +subroutine time_interp_extern_2d(field, time, data_in, interp, verbose, horz_interp, mask_out) + type(external_field), intent(in) :: field !< Handle for time interpolated field type(time_type), intent(in) :: time !< The target time for the data real, dimension(:,:), intent(inout) :: data_in !< The array in which to store the interpolated values integer, optional, intent(in) :: interp !< A flag indicating the temporal interpolation method @@ -206,15 +230,14 @@ subroutine time_interp_extern_2d(field_id, time, data_in, interp, verbose, horz_ logical, dimension(:,:), & optional, intent(out) :: mask_out !< An array that is true where there is valid data - call time_interp_external(field_id, time, data_in, interp=interp, verbose=verbose, & + call time_interp_external(field%id, time, data_in, interp=interp, verbose=verbose, & horz_interp=horz_interp, mask_out=mask_out) end subroutine time_interp_extern_2d !> Read a 3d field based on model time, and rotate to the model grid -subroutine time_interp_extern_3d(field_id, time, data_in, interp, verbose, horz_interp, mask_out) - integer, intent(in) :: field_id !< The integer index of the external field returned - !! from a previous call to init_external_field() +subroutine time_interp_extern_3d(field, time, data_in, interp, verbose, horz_interp, mask_out) + type(external_field), intent(in) :: field !< Handle for time interpolated field type(time_type), intent(in) :: time !< The target time for the data real, dimension(:,:,:), intent(inout) :: data_in !< The array in which to store the interpolated values integer, optional, intent(in) :: interp !< A flag indicating the temporal interpolation method @@ -224,14 +247,15 @@ subroutine time_interp_extern_3d(field_id, time, data_in, interp, verbose, horz_ logical, dimension(:,:,:), & optional, intent(out) :: mask_out !< An array that is true where there is valid data - call time_interp_external(field_id, time, data_in, interp=interp, verbose=verbose, & + call time_interp_external(field%id, time, data_in, interp=interp, verbose=verbose, & horz_interp=horz_interp, mask_out=mask_out) end subroutine time_interp_extern_3d !> initialize an external field -integer function init_extern_field(file, fieldname, MOM_domain, domain, verbose, & - threading, ierr, ignore_axis_atts, correct_leap_year_inconsistency ) +function init_extern_field(file, fieldname, MOM_domain, domain, verbose, & + threading, ierr, ignore_axis_atts, correct_leap_year_inconsistency) & + result(field) character(len=*), intent(in) :: file !< The name of the file to read character(len=*), intent(in) :: fieldname !< The name of the field in the file @@ -251,17 +275,17 @@ integer function init_extern_field(file, fieldname, MOM_domain, domain, verbose, !! is in use, and (2) the modulo time period of the !! data is an integer number of years, then map !! a model date of Feb 29. onto a common year on Feb. 28. + type(external_field) :: field !< Handle to external field if (present(MOM_Domain)) then - init_extern_field = init_external_field(file, fieldname, domain=MOM_domain%mpp_domain, & + field%id = init_external_field(file, fieldname, domain=MOM_domain%mpp_domain, & verbose=verbose, threading=threading, ierr=ierr, ignore_axis_atts=ignore_axis_atts, & correct_leap_year_inconsistency=correct_leap_year_inconsistency) else - init_extern_field = init_external_field(file, fieldname, domain=domain, & + field%id = init_external_field(file, fieldname, domain=domain, & verbose=verbose, threading=threading, ierr=ierr, ignore_axis_atts=ignore_axis_atts, & correct_leap_year_inconsistency=correct_leap_year_inconsistency) endif - end function init_extern_field end module MOM_interp_infra diff --git a/config_src/infra/FMS1/MOM_io_infra.F90 b/config_src/infra/FMS1/MOM_io_infra.F90 index f956f9fa51..e765918f9e 100644 --- a/config_src/infra/FMS1/MOM_io_infra.F90 +++ b/config_src/infra/FMS1/MOM_io_infra.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> This module contains a thin inteface to mpp and fms I/O code module MOM_io_infra -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_domain_infra, only : MOM_domain_type, rescale_comp_data, AGRID, BGRID_NE, CGRID_NE use MOM_domain_infra, only : domain2d, domain1d, CENTER, CORNER, NORTH_FACE, EAST_FACE use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, FATAL, WARNING @@ -14,6 +16,7 @@ module MOM_io_infra use mpp_io_mod, only : mpp_write_meta, mpp_write, mpp_read use mpp_io_mod, only : mpp_get_atts, mpp_attribute_exist use mpp_io_mod, only : mpp_get_axes, axistype, mpp_get_axis_data +use mpp_io_mod, only : mpp_get_axis_length use mpp_io_mod, only : mpp_get_fields, fieldtype use mpp_io_mod, only : mpp_get_info, mpp_get_times use mpp_io_mod, only : mpp_io_init @@ -32,7 +35,8 @@ module MOM_io_infra public :: open_file, open_ASCII_file, file_is_open, close_file, flush_file, file_exists public :: get_file_info, get_file_fields, get_file_times, get_filename_suffix public :: read_field, read_vector, write_metadata, write_field -public :: field_exists, get_field_atts, get_field_size, get_axis_data, read_field_chksum +public :: field_exists, get_field_atts, get_field_size, read_field_chksum +public :: get_axis_size, get_axis_data, set_axis_data public :: io_infra_init, io_infra_end, MOM_namelist_file, check_namelist_error, write_version public :: stdout_if_root ! These types are inherited from underlying infrastructure code, to act as containers for @@ -57,7 +61,7 @@ module MOM_io_infra !> Read a data field from a file interface read_field module procedure read_field_4d - module procedure read_field_3d + module procedure read_field_3d, read_field_3d_region module procedure read_field_2d, read_field_2d_region module procedure read_field_1d, read_field_1d_int module procedure read_field_0d, read_field_0d_int @@ -403,14 +407,47 @@ subroutine get_field_size(filename, fieldname, sizes, field_found, no_domain) end subroutine get_field_size -!> Extracts and returns the axis data stored in an axistype. -subroutine get_axis_data( axis, dat ) - type(axistype), intent(in) :: axis !< An axis type - real, dimension(:), intent(out) :: dat !< The data in the axis variable - call mpp_get_axis_data( axis, dat ) +!> Get the size of the axis +function get_axis_size(axis) result(axis_size) + type(axistype), intent(in) :: axis + !< Infra axis + integer :: axis_size + !< Axis size + + axis_size = mpp_get_axis_length(axis) +end function get_axis_size + + +!> Extracts and returns the axis data stored in an axistype. +subroutine get_axis_data(axis, axis_name, axis_data) + type(axistype), intent(in) :: axis + !< Infra axis + character(len=256), intent(out) :: axis_name + !< Axis name + real, dimension(:), intent(out) :: axis_data + !< Axis points + + call mpp_get_atts(axis, name=axis_name) + call mpp_get_axis_data(axis, axis_data) end subroutine get_axis_data + +! NOTE: Unused, but provided to match the FMS2 API + +!> Return a new axistype based on axis specs +subroutine set_axis_data(axis, axis_name, axis_data) + type(axistype), intent(inout) :: axis + !< Target axis + character(len=256), intent(in) :: axis_name + !< Target axis name + real, intent(in) :: axis_data(:) + !< Target axis values + + call MOM_error(FATAL, "set_axis_data in FMS1 is not yet implemented.") +end subroutine set_axis_data + + !> This routine uses the fms_io subroutine read_data to read a scalar named !! "fieldname" from a single or domain-decomposed file "filename". subroutine read_field_0d(filename, fieldname, data, timelevel, scale, MOM_Domain, & @@ -696,6 +733,45 @@ subroutine read_field_3d(filename, fieldname, data, MOM_Domain, & endif ; endif end subroutine read_field_3d +!> This routine uses the fms_io subroutine read_data to read a region from a distributed or +!! global 3-D data field named "fieldname" from file "filename". +subroutine read_field_3d_region(filename, fieldname, data, start, nread, MOM_domain, & + no_domain, scale) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:,:), intent(inout) :: data !< The 3-dimensional array into which the data + !! should be read + integer, dimension(:), intent(in) :: start !< The starting index to read in each of 4 + !! dimensions. For this 3-d read, the + !! 4th values are always 1. + integer, dimension(:), intent(in) :: nread !< The number of points to read in each of 4 + !! dimensions. For this 3-d read, the + !! 4th values are always 1. + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, optional, intent(in) :: no_domain !< If present and true, this variable does not + !! use domain decomposion. + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + + if (present(MOM_Domain)) then + call read_data(filename, fieldname, data, start, nread, domain=MOM_Domain%mpp_domain, & + no_domain=no_domain) + else + call read_data(filename, fieldname, data, start, nread, no_domain=no_domain) + endif + + if (present(scale)) then ; if (scale /= 1.0) then + if (present(MOM_Domain)) then + call rescale_comp_data(MOM_Domain, data, scale) + else + ! Dangerously rescale the whole array + data(:,:,:) = scale*data(:,:,:) + endif + endif ; endif +end subroutine read_field_3d_region + + !> This routine uses the fms_io subroutine read_data to read a distributed !! 4-D data field named "fieldname" from file "filename". Valid values for !! "position" include CORNER, CENTER, EAST_FACE and NORTH_FACE. @@ -715,9 +791,8 @@ subroutine read_field_4d(filename, fieldname, data, MOM_Domain, & ! Local variables character(len=80) :: varname ! The name of a variable in the file type(fieldtype), allocatable :: fields(:) ! An array of types describing all the variables in the file - logical :: use_fms_read_data, file_is_global + logical :: file_is_global integer :: n, unit, ndim, nvar, natt, ntime - integer :: is, ie, js, je ! This single call does not work for a 4-d array due to FMS limitations, so multiple calls are ! needed. diff --git a/config_src/infra/FMS1/MOM_time_manager.F90 b/config_src/infra/FMS1/MOM_time_manager.F90 index 5f3279b713..c03390a4bf 100644 --- a/config_src/infra/FMS1/MOM_time_manager.F90 +++ b/config_src/infra/FMS1/MOM_time_manager.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Wraps the FMS time manager functions module MOM_time_manager -! This file is part of MOM6. See LICENSE.md for the license. - use time_manager_mod, only : time_type, get_time, set_time use time_manager_mod, only : time_type_to_real, real_to_time_type use time_manager_mod, only : operator(+), operator(-), operator(*), operator(/) @@ -17,8 +19,9 @@ module MOM_time_manager implicit none ; private +! FMS re-exports public :: time_type, get_time, set_time -public :: time_type_to_real, real_to_time_type, real_to_time +public :: time_type_to_real, real_to_time_type public :: set_ticks_per_second, get_ticks_per_second public :: operator(+), operator(-), operator(*), operator(/) public :: operator(>), operator(<), operator(>=), operator(<=) @@ -26,6 +29,8 @@ module MOM_time_manager public :: get_date, set_date, increment_date, month_name, days_in_month public :: JULIAN, NOLEAP, THIRTY_DAY_MONTHS, GREGORIAN, NO_CALENDAR public :: set_calendar_type, get_calendar_type +! Module functions +public :: real_to_time, time_minus_signed, time_to_real contains @@ -34,14 +39,19 @@ module MOM_time_manager !! signed integers, this version should work over the entire valid range (2^31 days or ~5.8835 !! million years) of time_types, whereas the standard version in the FMS time_manager stops working !! for conversions of times greater than 2^31 seconds, or ~68.1 years. -type(time_type) function real_to_time(x, err_msg) +type(time_type) function real_to_time(time_in, err_msg, unscale) ! type(time_type) :: real_to_time !< The output time as a time_type - real, intent(in) :: x !< The input time in real seconds. + real, intent(in) :: time_in !< The input time in [s] or [T ~> s] character(len=*), optional, intent(out) :: err_msg !< An optional returned error message. + real, optional, intent(in) :: unscale !< A scaling factor that the input time is + !! multiplied by, often in [s T-1 ~> nondim] ! Local variables + real :: x ! The time in real seconds [s] + real :: real_subsecond_remainder ! The fractional seconds from time_in [s] integer :: seconds, days, ticks - real :: real_subsecond_remainder + + x = time_in ; if (present(unscale)) x = unscale*time_in days = floor(x/86400.) seconds = floor(x - 86400.*days) @@ -49,6 +59,41 @@ type(time_type) function real_to_time(x, err_msg) ticks = nint(real_subsecond_remainder * get_ticks_per_second()) real_to_time = set_time(seconds=seconds, days=days, ticks=ticks, err_msg=err_msg) + end function real_to_time +!> Returns the real number of seconds encoded in the time type [s] or the rescaled +!! amount of time in other units, often [T ~> s] +real function time_to_real(time, scale) + type(time_type), intent(in) :: time !< The time to be converted. + real, optional, intent(in) :: scale !< A scaling factor that returned the time is + !! multiplied by, often in [T s-1 ~> nondim] + + time_to_real = time_type_to_real(time) + if (present(scale)) time_to_real = scale * time_to_real + +end function time_to_real + +!> Returns a real number representing time_a - time_b in [s] or [T ~> s] if scale is present. +!! The FMS - operator for time types returns a new time type representing +!! a difference that is always >= 0. +!! In contrast, this function returns a negative real number if time_b > time_a, +!! and a positive real otherwise, as would be expected for subtraction. +real function time_minus_signed(time_a, time_b, scale) + type(time_type), intent(in) :: time_a, time_b !< Two times for calculating time_a - time_b + real, optional, intent(in) :: scale !< A scaling factor that returned the time is + !! multiplied by, often in [T s-1 ~> nondim] + + ! Local variables + real :: abs_diff ! The absolute value of the difference in times [s] or [T ~> s] + + ! Do FMS time subtraction, which will always be >= 0, + ! and convert to a real number. + abs_diff = time_to_real(time_a - time_b, scale) + + ! Add the sign back by comparing time_a and time_b + time_minus_signed = merge(abs_diff, -abs_diff, time_a >= time_b) + +end function time_minus_signed + end module MOM_time_manager diff --git a/config_src/infra/FMS2/MOM_coms_infra.F90 b/config_src/infra/FMS2/MOM_coms_infra.F90 index 555b4df119..1112f932d2 100644 --- a/config_src/infra/FMS2/MOM_coms_infra.F90 +++ b/config_src/infra/FMS2/MOM_coms_infra.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Thin interfaces to non-domain-oriented mpp communication subroutines module MOM_coms_infra -! This file is part of MOM6. See LICENSE.md for the license. - use iso_fortran_env, only : int32, int64 use mpp_mod, only : mpp_pe, mpp_root_pe, mpp_npes, mpp_set_root_pe @@ -14,8 +16,9 @@ module MOM_coms_infra implicit none ; private -public :: PE_here, root_PE, num_PEs, set_rootPE, Set_PElist, Get_PElist +public :: PE_here, root_PE, num_PEs, set_rootPE, Set_PElist, Get_PElist, sync_PEs public :: broadcast, sum_across_PEs, min_across_PEs, max_across_PEs +public :: any_across_PEs, all_across_PEs public :: field_chksum, MOM_infra_init, MOM_infra_end ! This module provides interfaces to the non-domain-oriented communication @@ -24,7 +27,7 @@ module MOM_coms_infra !> Communicate an array, string or scalar from one PE to others interface broadcast module procedure broadcast_char, broadcast_int32_0D, broadcast_int64_0D, broadcast_int1D - module procedure broadcast_real0D, broadcast_real1D, broadcast_real2D + module procedure broadcast_real0D, broadcast_real1D, broadcast_real2D, broadcast_real3D end interface broadcast !> Compute a checksum for a field distributed over a PE list. If no PE list is @@ -41,6 +44,7 @@ module MOM_coms_infra interface sum_across_PEs module procedure sum_across_PEs_int4_0d module procedure sum_across_PEs_int4_1d + module procedure sum_across_PEs_int4_2d module procedure sum_across_PEs_int8_0d module procedure sum_across_PEs_int8_1d module procedure sum_across_PEs_int8_2d @@ -107,6 +111,13 @@ subroutine Get_PEList(pelist, name, commID) call mpp_get_current_pelist(pelist, name, commiD) end subroutine Get_PEList +!> Sync the PEs at a defined point in the model +subroutine sync_PEs(pelist) + integer, optional, intent(in) :: pelist(:) !< The list of PEs to be synced + + call mpp_sync(pelist) +end subroutine sync_PEs + !> Communicate a 1-D array of character strings from one PE to others subroutine broadcast_char(dat, length, from_PE, PElist, blocking) character(len=*), intent(inout) :: dat(:) !< The data to communicate and destination @@ -252,6 +263,27 @@ subroutine broadcast_real2D(dat, length, from_PE, PElist, blocking) end subroutine broadcast_real2D +!> Communicate a 3-D array of reals from one PE to others +subroutine broadcast_real3D(dat, length, from_PE, PElist, blocking) + real, dimension(:,:,:), intent(inout) :: dat !< The data to communicate and destination + integer, intent(in) :: length !< The total number of data elements + integer, optional, intent(in) :: from_PE !< The source PE, by default the root PE + integer, optional, intent(in) :: PElist(:) !< The list of participating PEs, by default the + !! active PE set as previously set via Set_PElist. + logical, optional, intent(in) :: blocking !< If true, barriers are added around the call + + integer :: src_PE ! The processor that is sending the data + logical :: do_block ! If true add synchronizing barriers + + do_block = .false. ; if (present(blocking)) do_block = blocking + if (present(from_PE)) then ; src_PE = from_PE ; else ; src_PE = root_PE() ; endif + + if (do_block) call mpp_sync(PElist) + call mpp_broadcast(dat, length, src_PE, PElist) + if (do_block) call mpp_sync_self(PElist) + +end subroutine broadcast_real3D + ! field_chksum wrappers !> Compute a checksum for a field distributed over a PE list. If no PE list is @@ -328,6 +360,15 @@ subroutine sum_across_PEs_int4_1d(field, length, pelist) call mpp_sum(field, length, pelist) end subroutine sum_across_PEs_int4_1d +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. +subroutine sum_across_PEs_int4_2d(field, length, pelist) + integer(kind=int32), dimension(:,:), intent(inout) :: field !< The values to add, the sums upon return + integer, intent(in) :: length !< Number of elements in field to add + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_int4_2d + !> Find the sum of field across PEs, and return this sum in field. subroutine sum_across_PEs_int8_0d(field, pelist) integer(kind=int64), intent(inout) :: field !< Value on this PE, and the sum across PEs upon return @@ -438,6 +479,36 @@ subroutine min_across_PEs_real_1d(field, length, pelist) call mpp_min(field, length, pelist) end subroutine min_across_PEs_real_1d +!> Implementation of any() intrinsic across PEs +function any_across_PEs(field, pelist) + logical, intent(in) :: field !< Local PE value + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + logical :: any_across_PEs + + integer :: field_flag + + ! FMS1 does not support logical collectives, so integer flags are used. + field_flag = 0 + if (field) field_flag = 1 + call max_across_PEs(field_flag, pelist) + any_across_PEs = (field_flag > 0) +end function any_across_PEs + +!> Implementation of all() intrinsic across PEs +function all_across_PEs(field, pelist) + logical, intent(in) :: field !< Local PE value + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + logical :: all_across_PEs + + integer :: field_flag + + ! FMS1 does not support logical collectives, so integer flags are used. + field_flag = 0 + if (field) field_flag = 1 + call min_across_PEs(field_flag, pelist) + all_across_PEs = (field_flag > 0) +end function all_across_PEs + !> Initialize the model framework, including PE communication over a designated communicator. !! If no communicator ID is provided, the framework's default communicator is used. subroutine MOM_infra_init(localcomm) diff --git a/config_src/infra/FMS2/MOM_constants.F90 b/config_src/infra/FMS2/MOM_constants.F90 index 2db177e08c..ad44ba4f85 100644 --- a/config_src/infra/FMS2/MOM_constants.F90 +++ b/config_src/infra/FMS2/MOM_constants.F90 @@ -1,14 +1,20 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Provides a few physical constants module MOM_constants -! This file is part of MOM6. See LICENSE.md for the license. - -use constants_mod, only : HLV, HLF +use constants_mod, only : FMS_HLV => HLV +use constants_mod, only : FMS_HLF => HLF implicit none ; private -!> The constant offset for converting temperatures in Kelvin to Celsius real, public, parameter :: CELSIUS_KELVIN_OFFSET = 273.15 -public :: HLV, HLF + !< The constant offset for converting temperatures in Kelvin to Celsius [K] +real, public, parameter :: HLV = real(FMS_HLV, kind=kind(1.0)) + !< Latent heat of vaporization [J kg-1] +real, public, parameter :: HLF = real(FMS_HLF, kind=kind(1.0)) + !< Latent heat of fusion [J kg-1] end module MOM_constants diff --git a/config_src/infra/FMS2/MOM_couplertype_infra.F90 b/config_src/infra/FMS2/MOM_couplertype_infra.F90 index 3bcccc1dc7..b8dbc1be82 100644 --- a/config_src/infra/FMS2/MOM_couplertype_infra.F90 +++ b/config_src/infra/FMS2/MOM_couplertype_infra.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> This module wraps the FMS coupler types module module MOM_couplertype_infra -! This file is part of MOM6. See LICENSE.md for the license. - use coupler_types_mod, only : coupler_type_spawn, coupler_type_initialized, coupler_type_destructor use coupler_types_mod, only : coupler_type_set_diags, coupler_type_send_data, coupler_type_copy_data use coupler_types_mod, only : coupler_type_write_chksums, coupler_type_redistribute_data diff --git a/config_src/infra/FMS2/MOM_cpu_clock_infra.F90 b/config_src/infra/FMS2/MOM_cpu_clock_infra.F90 index 0c42c577b4..aeca65b863 100644 --- a/config_src/infra/FMS2/MOM_cpu_clock_infra.F90 +++ b/config_src/infra/FMS2/MOM_cpu_clock_infra.F90 @@ -1,10 +1,12 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Wraps the MPP cpu clock functions !! !! The functions and constants should be accessed via mom_cpu_clock module MOM_cpu_clock_infra -! This file is part of MOM6. See LICENSE.md for the license. - ! These interfaces and constants from MPP/FMS will not be directly exposed outside of this module use fms_mod, only : clock_flag_default use mpp_mod, only : mpp_clock_begin diff --git a/config_src/infra/FMS2/MOM_data_override_infra.F90 b/config_src/infra/FMS2/MOM_data_override_infra.F90 index 1484f0c128..57311710c8 100644 --- a/config_src/infra/FMS2/MOM_data_override_infra.F90 +++ b/config_src/infra/FMS2/MOM_data_override_infra.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> These interfaces allow for ocean or sea-ice variables to be replaced with data. module MOM_data_override_infra -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_domain_infra, only : MOM_domain_type, domain2d use MOM_domain_infra, only : get_simple_array_i_ind, get_simple_array_j_ind use MOM_time_manager, only : time_type diff --git a/config_src/infra/FMS2/MOM_diag_manager_infra.F90 b/config_src/infra/FMS2/MOM_diag_manager_infra.F90 index 18c80cf24c..2648900493 100644 --- a/config_src/infra/FMS2/MOM_diag_manager_infra.F90 +++ b/config_src/infra/FMS2/MOM_diag_manager_infra.F90 @@ -1,3 +1,7 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> A wrapper for the FMS diag_manager routines. This module should be the !! only MOM6 module which imports the FMS shared infrastructure for !! diagnostics. Pass through interfaces are being documented @@ -6,21 +10,22 @@ !! those APIs would be applied here). module MOM_diag_manager_infra -! This file is part of MOM6. See LICENSE.md for the license. - +use, intrinsic :: iso_fortran_env, only : real64 use diag_axis_mod, only : fms_axis_init=>diag_axis_init use diag_axis_mod, only : fms_get_diag_axis_name => get_diag_axis_name use diag_axis_mod, only : EAST, NORTH use diag_data_mod, only : null_axis_id use diag_manager_mod, only : fms_diag_manager_init => diag_manager_init use diag_manager_mod, only : fms_diag_manager_end => diag_manager_end +use diag_manager_mod, only : diag_send_complete +use diag_manager_mod, only : diag_manager_set_time_end use diag_manager_mod, only : send_data_fms => send_data use diag_manager_mod, only : fms_diag_field_add_attribute => diag_field_add_attribute use diag_manager_mod, only : DIAG_FIELD_NOT_FOUND use diag_manager_mod, only : register_diag_field_fms => register_diag_field use diag_manager_mod, only : register_static_field_fms => register_static_field use diag_manager_mod, only : get_diag_field_id_fms => get_diag_field_id -use MOM_time_manager, only : time_type +use MOM_time_manager, only : time_type, set_time use MOM_domain_infra, only : MOM_domain_type use MOM_error_infra, only : MOM_error => MOM_err, FATAL, WARNING @@ -57,6 +62,8 @@ module MOM_diag_manager_infra public MOM_diag_manager_init public MOM_diag_manager_end public send_data_infra +public diag_send_complete_infra +public diag_manager_set_time_end_infra public MOM_diag_field_add_attribute public register_diag_field_infra public register_static_field_infra @@ -72,36 +79,36 @@ module MOM_diag_manager_infra !> Initialize a diagnostic axis integer function MOM_diag_axis_init(name, data, units, cart_name, long_name, MOM_domain, position, & & direction, edges, set_name, coarsen, null_axis) - character(len=*), intent(in) :: name !< The name of this axis - real, dimension(:), intent(in) :: data !< The array of coordinate values - character(len=*), intent(in) :: units !< The units for the axis data - character(len=*), intent(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", or "N" for none) - character(len=*), & - optional, intent(in) :: long_name !< The long name of this axis - type(MOM_domain_type), & - optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition - integer, optional, intent(in) :: position !< This indicates the relative position of this - !! axis. The default is CENTER, but EAST and NORTH - !! are common options. - integer, optional, intent(in) :: direction !< This indicates the direction along which this - !! axis increases: 1 for upward, -1 for downward, or - !! 0 for non-vertical axes (the default) - integer, optional, intent(in) :: edges !< The axis_id of the complementary axis that - !! describes the edges of this axis - character(len=*), & - optional, intent(in) :: set_name !< A name to use for this set of axes. - integer, optional, intent(in) :: coarsen !< An optional degree of coarsening for the grid, 1 - !! by default. - logical, optional, intent(in) :: null_axis !< If present and true, return the special null axis - !! id for use with scalars. - - integer :: coarsening ! The degree of grid coarsening - - if (present(null_axis)) then ; if (null_axis) then - ! Return the special null axis id for scalars - MOM_diag_axis_init = null_axis_id - return - endif ; endif + character(len=*), intent(in) :: name !< The name of this axis + real, dimension(:), intent(in) :: data !< The array of coordinate values + character(len=*), intent(in) :: units !< The units for the axis data + character(len=*), intent(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", or "N" for none) + character(len=*), & + optional, intent(in) :: long_name !< The long name of this axis + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + integer, optional, intent(in) :: position !< This indicates the relative position of this + !! axis. The default is CENTER, but EAST and NORTH + !! are common options. + integer, optional, intent(in) :: direction !< This indicates the direction along which this + !! axis increases: 1 for upward, -1 for downward, or + !! 0 for non-vertical axes (the default) + integer, optional, intent(in) :: edges !< The axis_id of the complementary axis that + !! describes the edges of this axis + character(len=*), & + optional, intent(in) :: set_name !< A name to use for this set of axes. + integer, optional, intent(in) :: coarsen !< An optional degree of coarsening for the grid, 1 + !! by default. + logical, optional, intent(in) :: null_axis !< If present and true, return the special null axis + !! id for use with scalars. + + integer :: coarsening ! The degree of grid coarsening + + if (present(null_axis)) then ; if (null_axis) then + ! Return the special null axis id for scalars + MOM_diag_axis_init = null_axis_id + return + endif ; endif if (present(MOM_domain)) then coarsening = 1 ; if (present(coarsen)) coarsening = coarsen @@ -236,9 +243,15 @@ integer function register_static_field_infra(module_name, field_name, axes, long integer, optional, intent(in) :: area !< Diagnostic ID of the field containing the area attribute integer, optional, intent(in) :: volume !< Diagnostic ID of the field containing the volume attribute - register_static_field_infra = register_static_field_fms(module_name, field_name, axes, long_name, units,& - & missing_value, range, mask_variant, standard_name, dynamic=.false.,do_not_log=do_not_log, & + if(present(missing_value) .or. present(range)) then + register_static_field_infra = register_static_field_fms(module_name, field_name, axes, long_name, units,& + & missing_value, range, mask_variant=mask_variant, standard_name=standard_name, dynamic=.false.,& + do_not_log=do_not_log, interp_method=interp_method,tile_count=tile_count, area=area, volume=volume) + else + register_static_field_infra = register_static_field_fms(module_name, field_name, axes, long_name, units,& + & mask_variant=mask_variant, standard_name=standard_name, dynamic=.false.,do_not_log=do_not_log, & interp_method=interp_method,tile_count=tile_count, area=area, volume=volume) + endif end function register_static_field_infra !> Returns true if the argument data are successfully passed to a diagnostic manager @@ -267,7 +280,20 @@ logical function send_data_infra_1d(diag_field_id, field, is_in, ie_in, time, ma character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon !! returning to the calling routine - send_data_infra_1d = send_data_fms(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg) + if(present(rmask) .or. present(weight)) then + if(present(rmask) .and. present(weight)) then + send_data_infra_1d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, mask=mask, rmask=rmask, ie_in=ie_in,& + weight=weight, err_msg=err_msg) + elseif(present(rmask)) then + send_data_infra_1d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, mask=mask, rmask=rmask, ie_in=ie_in,& + err_msg=err_msg) + elseif(present(weight)) then + send_data_infra_1d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, ie_in=ie_in, weight=weight,& + err_msg=err_msg) + endif + else + send_data_infra_1d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, ie_in=ie_in, err_msg=err_msg) + endif end function send_data_infra_1d @@ -289,9 +315,21 @@ logical function send_data_infra_2d(diag_field_id, field, is_in, ie_in, js_in, j character(len=*), optional, intent(out) :: err_msg !< A log indicating the status of the post upon !! returning to the calling routine - send_data_infra_2d = send_data_fms(diag_field_id, field, time, is_in, js_in, mask, & - rmask, ie_in, je_in, weight, err_msg) - + if(present(rmask) .or. present(weight)) then + if(present(rmask) .and. present(weight)) then + send_data_infra_2d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, mask=mask, & + rmask=rmask, ie_in=ie_in, je_in=je_in, weight=weight, err_msg=err_msg) + elseif(present(rmask)) then + send_data_infra_2d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, mask=mask, & + rmask=rmask, ie_in=ie_in, je_in=je_in, err_msg=err_msg) + elseif(present(weight)) then + send_data_infra_2d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, mask=mask, & + ie_in=ie_in, je_in=je_in, weight=weight, err_msg=err_msg) + endif + else + send_data_infra_2d = send_data_fms(diag_field_id, field, time=time, is_in=is_in, js_in=js_in, mask=mask, & + ie_in=ie_in, je_in=je_in, err_msg=err_msg) + endif end function send_data_infra_2d !> Returns true if the argument data are successfully passed to a diagnostic manager @@ -326,7 +364,7 @@ end function send_data_infra_3d logical function send_data_infra_2d_r8(diag_field_id, field, is_in, ie_in, js_in, je_in, & time, mask, rmask, weight, err_msg) integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field - real(kind=8), dimension(:,:), intent(in) :: field !< A 2-d array of values being recorded + real(kind=real64), dimension(:,:), intent(in) :: field !< A 2-d array of values being recorded integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded @@ -349,7 +387,7 @@ end function send_data_infra_2d_r8 logical function send_data_infra_3d_r8(diag_field_id, field, is_in, ie_in, js_in, je_in, ks_in, ke_in, & time, mask, rmask, weight, err_msg) integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field - real(kind=8), dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded + real(kind=real64), dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded @@ -420,4 +458,19 @@ subroutine MOM_diag_field_add_attribute_i1d(diag_field_id, att_name, att_value) end subroutine MOM_diag_field_add_attribute_i1d +!> Finishes the diag manager reduction methods as needed for the time_step +subroutine diag_send_complete_infra () + !! The time_step in the diag_send_complete call is a dummy argument, needed for backwards compatibility + !! It won't be used at all when diag_manager_nml::use_modern_diag=.true. + !! It won't have any impact when diag_manager_nml::use_modern_diag=.false. + call diag_send_complete (set_time(0)) +end subroutine diag_send_complete_infra + +!> Sets the time that the simulation ends in the diag manager +subroutine diag_manager_set_time_end_infra(time) + type(time_type), optional, intent(in) :: time !< The time the simulation ends + + call diag_manager_set_time_end(time) +end subroutine diag_manager_set_time_end_infra + end module MOM_diag_manager_infra diff --git a/config_src/infra/FMS2/MOM_domain_infra.F90 b/config_src/infra/FMS2/MOM_domain_infra.F90 index 5f8d5fb20b..6029b3c6f9 100644 --- a/config_src/infra/FMS2/MOM_domain_infra.F90 +++ b/config_src/infra/FMS2/MOM_domain_infra.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Describes the decomposed MOM domain and has routines for communications across PEs module MOM_domain_infra -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_coms_infra, only : PE_here, root_PE, num_PEs use MOM_cpu_clock_infra, only : cpu_clock_begin, cpu_clock_end use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, WARNING, FATAL @@ -16,18 +18,19 @@ module MOM_domain_infra use mpp_domains_mod, only : mpp_create_group_update, mpp_do_group_update use mpp_domains_mod, only : mpp_reset_group_update_field, mpp_group_update_initialized use mpp_domains_mod, only : mpp_start_group_update, mpp_complete_group_update -use mpp_domains_mod, only : mpp_compute_block_extent +use mpp_domains_mod, only : mpp_compute_block_extent, mpp_compute_extent use mpp_domains_mod, only : mpp_broadcast_domain, mpp_redistribute, mpp_global_field use mpp_domains_mod, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM -use mpp_domains_mod, only : CYCLIC_GLOBAL_DOMAIN, FOLD_NORTH_EDGE +use mpp_domains_mod, only : CYCLIC_GLOBAL_DOMAIN +use mpp_domains_mod, only : FOLD_NORTH_EDGE, FOLD_SOUTH_EDGE, FOLD_EAST_EDGE, FOLD_WEST_EDGE use mpp_domains_mod, only : To_East => WUPDATE, To_West => EUPDATE, Omit_Corners => EDGEUPDATE use mpp_domains_mod, only : To_North => SUPDATE, To_South => NUPDATE use mpp_domains_mod, only : CENTER, CORNER, NORTH_FACE => NORTH, EAST_FACE => EAST -use fms_io_mod, only : file_exist, parse_mask_table +use fms_io_utils_mod, only : file_exists, parse_mask_table use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set, fms_affinity_get ! This subroutine is not in MOM6/src but may be required by legacy drivers -use mpp_domains_mod, only : global_field_sum => mpp_global_sum +! use mpp_domains_mod, only : global_field_sum => mpp_global_sum ! The `group_pass_type` fields are never accessed, so we keep it as an FMS type use mpp_domains_mod, only : group_pass_type => mpp_group_update_type @@ -38,20 +41,21 @@ module MOM_domain_infra public :: domain2D, domain1D, group_pass_type ! These interfaces are actually implemented or have explicit interfaces in this file. public :: create_MOM_domain, clone_MOM_domain, get_domain_components, get_domain_extent -public :: deallocate_MOM_domain, get_global_shape, compute_block_extent +public :: deallocate_MOM_domain, get_global_shape, compute_block_extent, compute_extent public :: pass_var, pass_vector, fill_symmetric_edges, rescale_comp_data public :: pass_var_start, pass_var_complete, pass_vector_start, pass_vector_complete public :: create_group_pass, do_group_pass, start_group_pass, complete_group_pass public :: redistribute_array, broadcast_domain, same_domain, global_field public :: get_simple_array_i_ind, get_simple_array_j_ind public :: MOM_thread_affinity_set, set_MOM_thread_affinity -! These are encoding constant parmeters. +! These are encoding constant parmeters with self-explanatory names. public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR public :: CORNER, CENTER, NORTH_FACE, EAST_FACE +public :: set_domain, nullify_domain ! These are no longer used by MOM6 because the reproducing sum works so well, but they are ! still referenced by some of the non-GFDL couplers. -public :: global_field_sum, BITWISE_EXACT_SUM +! public :: global_field_sum, BITWISE_EXACT_SUM !> Do a halo update on an array interface pass_var @@ -1210,7 +1214,7 @@ subroutine redistribute_array_2d(Domain1, array1, Domain2, array2, complete) ! Local variables logical :: do_complete - do_complete=.true.;if (PRESENT(complete)) do_complete = complete + do_complete=.true. ; if (PRESENT(complete)) do_complete = complete call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete) @@ -1229,7 +1233,7 @@ subroutine redistribute_array_3d(Domain1, array1, Domain2, array2, complete) ! Local variables logical :: do_complete - do_complete=.true.;if (PRESENT(complete)) do_complete = complete + do_complete=.true. ; if (PRESENT(complete)) do_complete = complete call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete) @@ -1248,7 +1252,7 @@ subroutine redistribute_array_4d(Domain1, array1, Domain2, array2, complete) ! Local variables logical :: do_complete - do_complete=.true.;if (PRESENT(complete)) do_complete = complete + do_complete=.true. ; if (PRESENT(complete)) do_complete = complete call mpp_redistribute(Domain1, array1, Domain2, array2, do_complete) @@ -1256,53 +1260,89 @@ end subroutine redistribute_array_4d !> Rescale the values of a 4-D array in its computational domain by a constant factor -subroutine rescale_comp_data_4d(domain, array, scale) +subroutine rescale_comp_data_4d(domain, array, scale, zero_zeros) type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information real, dimension(:,:,:,:), intent(inout) :: array !< The array which is having the data in its !! computational domain rescaled real, intent(in) :: scale !< A scaling factor by which to multiply the !! values in the computational domain of array - integer :: is, ie, js, je + logical, optional, intent(in) :: zero_zeros !< If present and true, convert negative zeros + !! into ordinary signless zeros. + logical :: unsign_zeros ! If true, convert negative zeros into ordinary signless zeros. + integer :: is, ie, js, je, i, j, k, m - if (scale == 1.0) return + unsign_zeros = .false. ; if (present(zero_zeros)) unsign_zeros = zero_zeros + + if ((scale == 1.0) .and. (.not.unsign_zeros)) return call get_simple_array_i_ind(domain, size(array,1), is, ie) call get_simple_array_j_ind(domain, size(array,2), js, je) - array(is:ie,js:je,:,:) = scale*array(is:ie,js:je,:,:) + if (scale /= 1.0) & + array(is:ie,js:je,:,:) = scale*array(is:ie,js:je,:,:) + + if (unsign_zeros) then ! Convert negative zeros into zeros + do m=1,size(array,4) ; do k=1,size(array,3) ; do j=js,je ; do i=is,ie + if (array(i,j,k,m) == 0.0) array(i,j,k,m) = 0.0 + enddo ; enddo ; enddo ; enddo + endif end subroutine rescale_comp_data_4d !> Rescale the values of a 3-D array in its computational domain by a constant factor -subroutine rescale_comp_data_3d(domain, array, scale) +subroutine rescale_comp_data_3d(domain, array, scale, zero_zeros) type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information real, dimension(:,:,:), intent(inout) :: array !< The array which is having the data in its !! computational domain rescaled real, intent(in) :: scale !< A scaling factor by which to multiply the !! values in the computational domain of array - integer :: is, ie, js, je + logical, optional, intent(in) :: zero_zeros !< If present and true, convert negative zeros + !! into ordinary signless zeros. + logical :: unsign_zeros ! If true, convert negative zeros into ordinary signless zeros. + integer :: is, ie, js, je, i, j, k + + unsign_zeros = .false. ; if (present(zero_zeros)) unsign_zeros = zero_zeros - if (scale == 1.0) return + if ((scale == 1.0) .and. (.not.unsign_zeros)) return call get_simple_array_i_ind(domain, size(array,1), is, ie) call get_simple_array_j_ind(domain, size(array,2), js, je) - array(is:ie,js:je,:) = scale*array(is:ie,js:je,:) + if (scale /= 1.0) & + array(is:ie,js:je,:) = scale*array(is:ie,js:je,:) + + if (unsign_zeros) then ! Convert negative zeros into zeros + do k=1,size(array,3) ; do j=js,je ; do i=is,ie + if (array(i,j,k) == 0.0) array(i,j,k) = 0.0 + enddo ; enddo ; enddo + endif end subroutine rescale_comp_data_3d !> Rescale the values of a 2-D array in its computational domain by a constant factor -subroutine rescale_comp_data_2d(domain, array, scale) +subroutine rescale_comp_data_2d(domain, array, scale, zero_zeros) type(MOM_domain_type), intent(in) :: domain !< MOM domain from which to extract information real, dimension(:,:), intent(inout) :: array !< The array which is having the data in its !! computational domain rescaled real, intent(in) :: scale !< A scaling factor by which to multiply the !! values in the computational domain of array - integer :: is, ie, js, je + logical, optional, intent(in) :: zero_zeros !< If present and true, convert negative zeros + !! into ordinary signless zeros. + logical :: unsign_zeros ! If true, convert negative zeros into ordinary signless zeros. + integer :: is, ie, js, je, i, j - if (scale == 1.0) return + unsign_zeros = .false. ; if (present(zero_zeros)) unsign_zeros = zero_zeros + + if ((scale == 1.0) .and. (.not.unsign_zeros)) return call get_simple_array_i_ind(domain, size(array,1), is, ie) call get_simple_array_j_ind(domain, size(array,2), js, je) - array(is:ie,js:je) = scale*array(is:ie,js:je) + if (scale /= 1.0) & + array(is:ie,js:je) = scale*array(is:ie,js:je) + + if (unsign_zeros) then ! Convert negative zeros into zeros + do j=js,je ; do i=is,ie + if (array(i,j) == 0.0) array(i,j) = 0.0 + enddo ; enddo + endif end subroutine rescale_comp_data_2d @@ -1352,8 +1392,10 @@ subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, l "TRIPOLAR_N and REENTRANT_Y may not be used together.") endif - MOM_dom%nonblocking_updates = nonblocking - MOM_dom%thin_halo_updates = thin_halos + MOM_dom%nonblocking_updates = .false. + if (present(nonblocking)) MOM_dom%nonblocking_updates = nonblocking + MOM_dom%thin_halo_updates = .false. + if (present(thin_halos)) MOM_dom%thin_halo_updates = thin_halos MOM_dom%symmetric = .true. ; if (present(symmetric)) MOM_dom%symmetric = symmetric MOM_dom%niglobal = n_global(1) ; MOM_dom%njglobal = n_global(2) MOM_dom%nihalo = n_halo(1) ; MOM_dom%njhalo = n_halo(2) @@ -1390,7 +1432,7 @@ subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, l endif if (present(mask_table)) then - mask_table_exists = file_exist(mask_table) + mask_table_exists = file_exists(mask_table) if (mask_table_exists) then allocate(MOM_dom%maskmap(layout(1), layout(2))) call parse_mask_table(mask_table, MOM_dom%maskmap, MOM_dom%name) @@ -1491,7 +1533,7 @@ end subroutine get_domain_components_d2D !> clone_MD_to_MD copies one MOM_domain_type into another, while allowing !! some properties of the new type to differ from the original one. subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain_name, & - turns, refine, extra_halo) + turns, refine, extra_halo, io_layout) type(MOM_domain_type), target, intent(in) :: MD_in !< An existing MOM_domain type(MOM_domain_type), pointer :: MOM_dom !< A pointer to a MOM_domain that will be @@ -1514,6 +1556,9 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain integer, optional, intent(in) :: refine !< A factor by which to enhance the grid resolution. integer, optional, intent(in) :: extra_halo !< An extra number of points in the halos !! compared with MD_in + integer, optional, intent(in) :: io_layout(2) + !< A user-defined IO layout to replace the domain's IO layout + integer :: global_indices(4) logical :: mask_table_exists @@ -1523,10 +1568,17 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain ! The sum of exni must equal MOM_dom%niglobal. integer :: qturns ! The number of quarter turns, restricted to the range of 0 to 3. integer :: i, j, nl1, nl2 + integer :: io_layout_in(2) qturns = 0 if (present(turns)) qturns = modulo(turns, 4) + if (present(io_layout)) then + io_layout_in(:) = io_layout(:) + else + io_layout_in(:) = MD_in%io_layout(:) + endif + if (.not.associated(MOM_dom)) then allocate(MOM_dom) allocate(MOM_dom%mpp_domain) @@ -1544,19 +1596,40 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain call get_layout_extents(MD_in, exnj, exni) MOM_dom%X_FLAGS = MD_in%Y_FLAGS ; MOM_dom%Y_FLAGS = MD_in%X_FLAGS + ! Correct the position of a tripolar grid, assuming that flags are not additive. + if (modulo(qturns, 4) == 1) then + if (MD_in%Y_FLAGS == FOLD_NORTH_EDGE) MOM_dom%X_FLAGS = FOLD_EAST_EDGE + if (MD_in%Y_FLAGS == FOLD_SOUTH_EDGE) MOM_dom%X_FLAGS = FOLD_WEST_EDGE + if (MD_in%X_FLAGS == FOLD_EAST_EDGE) MOM_dom%Y_FLAGS = FOLD_SOUTH_EDGE + if (MD_in%X_FLAGS == FOLD_WEST_EDGE) MOM_dom%Y_FLAGS = FOLD_NORTH_EDGE + elseif (modulo(qturns, 4) == 3) then + if (MD_in%Y_FLAGS == FOLD_NORTH_EDGE) MOM_dom%X_FLAGS = FOLD_WEST_EDGE + if (MD_in%Y_FLAGS == FOLD_SOUTH_EDGE) MOM_dom%X_FLAGS = FOLD_EAST_EDGE + if (MD_in%X_FLAGS == FOLD_EAST_EDGE) MOM_dom%Y_FLAGS = FOLD_NORTH_EDGE + if (MD_in%X_FLAGS == FOLD_WEST_EDGE) MOM_dom%Y_FLAGS = FOLD_SOUTH_EDGE + endif + MOM_dom%layout(:) = MD_in%layout(2:1:-1) - MOM_dom%io_layout(:) = MD_in%io_layout(2:1:-1) + MOM_dom%io_layout(:) = io_layout_in(2:1:-1) else MOM_dom%niglobal = MD_in%niglobal ; MOM_dom%njglobal = MD_in%njglobal MOM_dom%nihalo = MD_in%nihalo ; MOM_dom%njhalo = MD_in%njhalo call get_layout_extents(MD_in, exni, exnj) MOM_dom%X_FLAGS = MD_in%X_FLAGS ; MOM_dom%Y_FLAGS = MD_in%Y_FLAGS + ! Correct the position of a tripolar grid, assuming that flags are not additive. + if (modulo(qturns, 4) == 2) then + if (MD_in%Y_FLAGS == FOLD_NORTH_EDGE) MOM_dom%Y_FLAGS = FOLD_SOUTH_EDGE + if (MD_in%Y_FLAGS == FOLD_SOUTH_EDGE) MOM_dom%Y_FLAGS = FOLD_NORTH_EDGE + if (MD_in%X_FLAGS == FOLD_EAST_EDGE) MOM_dom%X_FLAGS = FOLD_WEST_EDGE + if (MD_in%X_FLAGS == FOLD_WEST_EDGE) MOM_dom%X_FLAGS = FOLD_EAST_EDGE + endif + MOM_dom%layout(:) = MD_in%layout(:) - MOM_dom%io_layout(:) = MD_in%io_layout(:) + MOM_dom%io_layout(:) = io_layout_in(:) endif - ! Ensure that the points per processor are the same on the source and densitation grids. + ! Ensure that the points per processor are the same on the source and destination grids. select case (qturns) case (1) ; call invert(exni) case (2) ; call invert(exni) ; call invert(exnj) @@ -1905,14 +1978,14 @@ end subroutine get_simple_array_j_ind !> Invert the contents of a 1-d array subroutine invert(array) - integer, dimension(:), intent(inout) :: array !< The 1-d array to invert - integer :: i, ni, swap - ni = size(array) - do i=1,ni - swap = array(i) - array(i) = array(ni+1-i) - array(ni+1-i) = swap - enddo + integer, dimension(:), intent(inout) :: array !< The 1-d array to invert + integer :: i, ni, swap + ni = size(array) + do i=1,ni + swap = array(i) + array(i) = array(ni+1-i) + array(ni+1-i) = swap + enddo end subroutine invert !> Returns the global shape of h-point arrays @@ -1925,7 +1998,7 @@ subroutine get_global_shape(domain, niglobal, njglobal) njglobal = domain%njglobal end subroutine get_global_shape -!> Get the array ranges in one dimension for the divisions of a global index space +!> Get the array ranges in one dimension for the divisions of a global index space (alternative to compute_extent) subroutine compute_block_extent(isg, ieg, ndivs, ibegin, iend) integer, intent(in) :: isg !< The starting index of the global index space integer, intent(in) :: ieg !< The ending index of the global index space @@ -1936,6 +2009,17 @@ subroutine compute_block_extent(isg, ieg, ndivs, ibegin, iend) call mpp_compute_block_extent(isg, ieg, ndivs, ibegin, iend) end subroutine compute_block_extent +!> Get the array ranges in one dimension for the divisions of a global index space +subroutine compute_extent(isg, ieg, ndivs, ibegin, iend) + integer, intent(in) :: isg !< The starting index of the global index space + integer, intent(in) :: ieg !< The ending index of the global index space + integer, intent(in) :: ndivs !< The number of divisions + integer, dimension(:), intent(out) :: ibegin !< The starting index of each division + integer, dimension(:), intent(out) :: iend !< The ending index of each division + + call mpp_compute_extent(isg, ieg, ndivs, ibegin, iend) +end subroutine compute_extent + !> Broadcast a 2-d domain from the root PE to the other PEs subroutine broadcast_domain(domain) type(domain2d), intent(inout) :: domain !< The domain2d type that will be shared across PEs. @@ -1992,4 +2076,17 @@ subroutine get_layout_extents(Domain, extent_i, extent_j) call mpp_get_domain_extents(domain%mpp_domain, extent_i, extent_j) end subroutine get_layout_extents +!> Set the associated domain for internal FMS I/O operations. +subroutine set_domain(Domain) + type(MOM_domain_type), intent(in) :: Domain + !< MOM domain to be designated as the internal FMS I/O domain + + ! FMS2 does not have domain-based internal FMS I/O operations, so this + ! function does nothing. +end subroutine set_domain + +subroutine nullify_domain + ! No internal FMS I/O domain can be assigned, so this function does nothing. +end subroutine nullify_domain + end module MOM_domain_infra diff --git a/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 b/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 index 66bbb86e2f..8285eefd57 100644 --- a/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 +++ b/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 @@ -1,14 +1,17 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> A simple (very thin) wrapper for managing ensemble member layout information module MOM_ensemble_manager_infra -! This file is part of MOM6. See LICENSE.md for the license. - use ensemble_manager_mod, only : FMS_ensemble_manager_init => ensemble_manager_init use ensemble_manager_mod, only : FMS_ensemble_pelist_setup => ensemble_pelist_setup use ensemble_manager_mod, only : FMS_get_ensemble_id => get_ensemble_id use ensemble_manager_mod, only : FMS_get_ensemble_size => get_ensemble_size use ensemble_manager_mod, only : FMS_get_ensemble_pelist => get_ensemble_pelist use ensemble_manager_mod, only : FMS_get_ensemble_filter_pelist => get_ensemble_filter_pelist +use fms2_io_mod, only : fms2_io_set_filename_appendix=>set_filename_appendix implicit none ; private @@ -20,9 +23,15 @@ module MOM_ensemble_manager_infra !> Initializes the ensemble manager which divides available resources !! in order to concurrently execute an ensemble of model realizations. -subroutine ensemble_manager_init() - - call FMS_ensemble_manager_init() +subroutine ensemble_manager_init(ensemble_suffix) + character(len=*), optional, intent(in) :: ensemble_suffix !> Ensemble suffix provided by the cap. This may be + !! provided to bypass FMS ensemble manager. + + if (present(ensemble_suffix)) then + call fms2_io_set_filename_appendix(trim(ensemble_suffix)) + else + call FMS_ensemble_manager_init() + endif end subroutine ensemble_manager_init diff --git a/config_src/infra/FMS2/MOM_error_infra.F90 b/config_src/infra/FMS2/MOM_error_infra.F90 index e5a8b8dc68..7db14bc127 100644 --- a/config_src/infra/FMS2/MOM_error_infra.F90 +++ b/config_src/infra/FMS2/MOM_error_infra.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Routines for error handling and I/O management module MOM_error_infra -! This file is part of MOM6. See LICENSE.md for the license. - use mpp_mod, only : mpp_error, mpp_pe, mpp_root_pe, mpp_stdlog=>stdlog, mpp_stdout=>stdout use mpp_mod, only : NOTE, WARNING, FATAL diff --git a/config_src/infra/FMS2/MOM_interp_infra.F90 b/config_src/infra/FMS2/MOM_interp_infra.F90 index b02beca313..3645e1db3a 100644 --- a/config_src/infra/FMS2/MOM_interp_infra.F90 +++ b/config_src/infra/FMS2/MOM_interp_infra.F90 @@ -1,23 +1,53 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> This module wraps the FMS temporal and spatial interpolation routines module MOM_interp_infra -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_domain_infra, only : MOM_domain_type, domain2d +use MOM_io_infra, only : axistype +use MOM_io_infra, only : set_axis_data use MOM_time_manager, only : time_type -use horiz_interp_mod, only : horiz_interp_new, horiz_interp, horiz_interp_init, horiz_interp_type -use mpp_io_mod, only : axistype, mpp_get_axis_data -use time_interp_external_mod, only : time_interp_external -use time_interp_external_mod, only : init_external_field, time_interp_external_init -use time_interp_external_mod, only : get_external_field_size -use time_interp_external_mod, only : get_external_field_axes, get_external_field_missing +use MOM_error_infra, only : MOM_error => MOM_err, FATAL +use MOM_string_functions, only : lowercase +use horiz_interp_mod, only : horiz_interp_new, horiz_interp, horiz_interp_init, horiz_interp_type +use netcdf_io_mod, only : FmsNetcdfFile_t, netcdf_file_open, netcdf_file_close +use netcdf_io_mod, only : get_num_variables, get_variable_names +use time_interp_external2_mod, only : time_interp_external +use time_interp_external2_mod, only : init_external_field, time_interp_external_init +use time_interp_external2_mod, only : get_external_field_size +use time_interp_external2_mod, only : get_external_field_missing + +! Use primitive netCDF, to replicate get_var_axes_info() +use netcdf, only : nf90_open +use netcdf, only : nf90_close +use netcdf, only : nf90_inq_varid +use netcdf, only : nf90_inquire_variable +use netcdf, only : nf90_inquire_dimension +use netcdf, only : nf90_get_var +use netcdf, only : NF90_NOWRITE +use netcdf, only : NF90_NOERR + implicit none ; private -public :: horiz_interp_type, horiz_interp_init -public :: time_interp_extern, init_extern_field, time_interp_external_init -public :: get_external_field_info, axistype, get_axis_data +public :: horiz_interp_type, horizontal_interp_init +public :: time_interp_extern, init_extern_field, time_interp_extern_init +public :: get_external_field_info public :: run_horiz_interp, build_horiz_interp_weights +public :: external_field + +!< Handle of an external field for interpolation +type :: external_field + private + integer :: id + !< FMS ID for the interpolated field + character(len=:), allocatable :: filename + !< Filename containing the field values + character(len=:), allocatable :: label + !< Field name in the file +end type external_field !> Read a field based on model time, and rotate to the model domain. interface time_interp_extern @@ -39,6 +69,16 @@ module MOM_interp_infra contains +!> Do any initialization for the horizontal interpolation +subroutine horizontal_interp_init() + call horiz_interp_init() +end subroutine horizontal_interp_init + +!> Do any initialization for the time and space interpolation infrastructure +subroutine time_interp_extern_init() + call time_interp_external_init() +end subroutine time_interp_extern_init + !> perform horizontal interpolation of a 2d field using pre-computed weights !! source and destination coordinates are 2d subroutine horiz_interp_from_weights_field2d(Interp, data_in, data_out, verbose, mask_in, mask_out, & @@ -61,7 +101,6 @@ subroutine horiz_interp_from_weights_field2d(Interp, data_in, data_out, verbose, end subroutine horiz_interp_from_weights_field2d - !> perform horizontal interpolation of a 3d field using pre-computed weights !! source and destination coordinates are 2d subroutine horiz_interp_from_weights_field3d(Interp, data_in, data_out, verbose, mask_in, mask_out, & @@ -114,15 +153,6 @@ subroutine build_horiz_interp_weights_2d_to_2d(Interp, lon_in, lat_in, lon_out, end subroutine build_horiz_interp_weights_2d_to_2d -!> Extracts and returns the axis data stored in an axistype. -subroutine get_axis_data( axis, dat ) - type(axistype), intent(in) :: axis !< An axis type - real, dimension(:), intent(out) :: dat !< The data in the axis variable - - call mpp_get_axis_data( axis, dat ) -end subroutine get_axis_data - - !> get size of an external field from field index function get_extern_field_size(index) @@ -135,12 +165,115 @@ end function get_extern_field_size !> get axes of an external field from field index -function get_extern_field_axes(index) - - integer, intent(in) :: index !< field index - type(axistype), dimension(4) :: get_extern_field_axes !< field axes - - get_extern_field_axes = get_external_field_axes(index) +function get_extern_field_axes(field) result(axes) + type(external_field), intent(in) :: field + !< Field handle + type(axistype), dimension(4) :: axes + !< Field axes + + integer :: ndims + ! Number of variable dimensions + integer, allocatable :: dims(:) + ! netCDF dimension IDs of variable + character(len=256) :: dim_name + ! Dimension name + integer :: dim_len + ! Dimension length + integer :: var_dim + ! netCDF ID of the variable associated with dimension of the same name + real, allocatable :: axis_points(:) + ! Axis values + + integer :: ncid + ! netCDF file ID + integer :: varid + ! netCDF variable ID + integer :: rc + ! netCDF return code + + ! netCDF requires the following to be length-1 arrays + integer :: nc_start(1) + ! netCDF start index + integer :: nc_count(1) + ! netCDF index count + + integer :: d + ! Dimension index + character(len=2) :: d_str + ! Display string of d + + ! This is a reimplementation of get_var_axes_info(), maybe it can be used + ! by the existing get_var_axes_info() ? + + ! Open field%filename + rc = nf90_open(trim(field%filename), NF90_NOWRITE, ncid) + if (rc /= NF90_NOERR) & + call MOM_error(FATAL, "Error opening file " // trim(field%filename) // ".") + + ! Use field%label to get the netCDF varid + rc = nf90_inq_varid(ncid, trim(field%label), varid) + if (rc /= NF90_NOERR) & + call MOM_error(FATAL, "Error finding variable " // trim(field%label) & + // " in " // trim(field%filename) // ".") + + ! Use the varid to get the number of dims (ndims) and their IDs (dims(:)) + ! Verify that ndims >= 3 + rc = nf90_inquire_variable(ncid, varid, ndims=ndims) + if (rc /= NF90_NOERR) & + call MOM_error(FATAL, "Error querying variable " // trim(field%label) & + // " in " // trim(field%filename) // ".") + + if (ndims < 3) & + call MOM_error(FATAL, trim(field%label) // " in " // trim(field%filename) & + // " has too few dimensions to be read as a 3D array.") + + allocate(dims(ndims)) + + rc = nf90_inquire_variable(ncid, varid, dimids=dims) + if (rc /= NF90_NOERR) & + call MOM_error(FATAL, "Error querying variable " // trim(field%label) & + // " in " // trim(field%filename) // ".") + + do d=1,ndims + ! Determine the name of each dimension + rc = nf90_inquire_dimension(ncid, dims(d), dim_name, len=dim_len) + if (rc /= NF90_NOERR) then + write(d_str, '(i0)') d + call MOM_error(FATAL, "Error querying dimension " // trim(d_str) & + // " of " // trim(field%label) // " in " // trim(field%filename) & + // ".") + endif + + ! Now locate a variable with the same name as the dimension (e.g. "x") + rc = nf90_inq_varid(ncid, dim_name, var_dim) + if (rc /= NF90_NOERR) & + call MOM_error(FATAL, "Error finding dimension variable " & + // trim(dim_name) // " of " // trim(field%label) // " in " & + // trim(field%filename)) + + allocate(axis_points(dim_len)) + + ! Get the dimensional axis values + nc_start(1) = 1 + nc_count(1) = dim_len + rc = nf90_get_var(ncid, var_dim, axis_points, nc_start, nc_count) + if (rc /= NF90_NOERR) & + call MOM_error(FATAL, "Error reading dimension " // trim(dim_name) & + // " axis data of " // trim(field%label) // " in " & + // trim(field%filename)) + + ! write via set_axis_info() equivalent for axistype + call set_axis_data(axes(d), dim_name, axis_points) + + deallocate(axis_points) + enddo + + deallocate(dims) + + ! Close external file + rc = nf90_close(ncid) + if (rc /= NF90_NOERR) & + call MOM_error(FATAL, "Error closing file "//trim(field%filename)//".") end function get_extern_field_axes @@ -157,46 +290,46 @@ end function get_extern_field_missing !> Get information about the external fields. -subroutine get_external_field_info(field_id, size, axes, missing) - integer, intent(in) :: field_id !< The integer index of the external - !! field returned from a previous - !! call to init_external_field() - integer, dimension(4), optional, intent(inout) :: size !< Dimension sizes for the input data - type(axistype), dimension(4), optional, intent(inout) :: axes !< Axis types for the input data - real, optional, intent(inout) :: missing !< Missing value for the input data +subroutine get_external_field_info(field, size, axes, missing) + type(external_field), intent(in) :: field + !< handle for time interpolated external field returned from a previous + !! call to init_external_field() + integer, optional, intent(inout) :: size(4) + !< Dimension sizes for the input data + type(axistype), optional, intent(inout) :: axes(4) + !< Axis types for the input data + real, optional, intent(inout) :: missing + !< Missing value for the input data if (present(size)) then - size(1:4) = get_extern_field_size(field_id) + size(:) = get_extern_field_size(field%id) endif if (present(axes)) then - axes(1:4) = get_extern_field_axes(field_id) + axes(:) = get_extern_field_axes(field) endif if (present(missing)) then - missing = get_extern_field_missing(field_id) + missing = get_extern_field_missing(field%id) endif - end subroutine get_external_field_info !> Read a scalar field based on model time. -subroutine time_interp_extern_0d(field_id, time, data_in, verbose) - integer, intent(in) :: field_id !< The integer index of the external field returned - !! from a previous call to init_external_field() +subroutine time_interp_extern_0d(field, time, data_in, verbose) + type(external_field), intent(in) :: field !< Handle for time interpolated field type(time_type), intent(in) :: time !< The target time for the data real, intent(inout) :: data_in !< The interpolated value logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging - call time_interp_external(field_id, time, data_in, verbose=verbose) + call time_interp_external(field%id, time, data_in, verbose=verbose) end subroutine time_interp_extern_0d !> Read a 2d field from an external based on model time, potentially including horizontal !! interpolation and rotation of the data -subroutine time_interp_extern_2d(field_id, time, data_in, interp, verbose, horz_interp, mask_out) - integer, intent(in) :: field_id !< The integer index of the external field returned - !! from a previous call to init_external_field() +subroutine time_interp_extern_2d(field, time, data_in, interp, verbose, horz_interp, mask_out) + type(external_field), intent(in) :: field !< Handle for time interpolated field type(time_type), intent(in) :: time !< The target time for the data real, dimension(:,:), intent(inout) :: data_in !< The array in which to store the interpolated values integer, optional, intent(in) :: interp !< A flag indicating the temporal interpolation method @@ -206,15 +339,14 @@ subroutine time_interp_extern_2d(field_id, time, data_in, interp, verbose, horz_ logical, dimension(:,:), & optional, intent(out) :: mask_out !< An array that is true where there is valid data - call time_interp_external(field_id, time, data_in, interp=interp, verbose=verbose, & + call time_interp_external(field%id, time, data_in, interp=interp, verbose=verbose, & horz_interp=horz_interp, mask_out=mask_out) end subroutine time_interp_extern_2d !> Read a 3d field based on model time, and rotate to the model grid -subroutine time_interp_extern_3d(field_id, time, data_in, interp, verbose, horz_interp, mask_out) - integer, intent(in) :: field_id !< The integer index of the external field returned - !! from a previous call to init_external_field() +subroutine time_interp_extern_3d(field, time, data_in, interp, verbose, horz_interp, mask_out) + type(external_field), intent(in) :: field !< Handle for time interpolated field type(time_type), intent(in) :: time !< The target time for the data real, dimension(:,:,:), intent(inout) :: data_in !< The array in which to store the interpolated values integer, optional, intent(in) :: interp !< A flag indicating the temporal interpolation method @@ -224,14 +356,15 @@ subroutine time_interp_extern_3d(field_id, time, data_in, interp, verbose, horz_ logical, dimension(:,:,:), & optional, intent(out) :: mask_out !< An array that is true where there is valid data - call time_interp_external(field_id, time, data_in, interp=interp, verbose=verbose, & + call time_interp_external(field%id, time, data_in, interp=interp, verbose=verbose, & horz_interp=horz_interp, mask_out=mask_out) end subroutine time_interp_extern_3d !> initialize an external field -integer function init_extern_field(file, fieldname, MOM_domain, domain, verbose, & - threading, ierr, ignore_axis_atts, correct_leap_year_inconsistency ) +function init_extern_field(file, fieldname, MOM_domain, domain, verbose, & + threading, ierr, ignore_axis_atts, correct_leap_year_inconsistency) & + result(field) character(len=*), intent(in) :: file !< The name of the file to read character(len=*), intent(in) :: fieldname !< The name of the field in the file @@ -251,19 +384,70 @@ integer function init_extern_field(file, fieldname, MOM_domain, domain, verbose, !! is in use, and (2) the modulo time period of the !! data is an integer number of years, then map !! a model date of Feb 29. onto a common year on Feb. 28. + type(external_field) :: field !< Handle to external field + + type(FmsNetcdfFile_t) :: extern_file + ! Local instance of netCDF file used to locate case-insensitive field name + integer :: num_fields + ! Number of fields in external file + character(len=256), allocatable :: extern_fieldnames(:) + ! List of field names in file + ! NOTE: length should NF90_MAX_NAME, but I don't know how to read it + character(len=:), allocatable :: label + ! Case-insensitive match to fieldname in file + logical :: rc + ! Return status + integer :: i + ! Loop index + + field%filename = file + + ! FMS2's init_external_field is case sensitive, so we must replicate the + ! case-insensitivity of FMS1. This requires opening the file twice. + + rc = netcdf_file_open(extern_file, file, 'read') + if (.not. rc) then + call MOM_error(FATAL, 'init_extern_file: file ' // trim(file) & + // ' could not be opened.') + endif + + ! TODO: broadcast = .false.? + num_fields = get_num_variables(extern_file) + + allocate(extern_fieldnames(num_fields)) + call get_variable_names(extern_file, extern_fieldnames) + do i = 1, num_fields + if (lowercase(extern_fieldnames(i)) == lowercase(fieldname)) then + field%label = extern_fieldnames(i) + exit + endif + enddo + call netcdf_file_close(extern_file) + + if (.not. allocated(field%label)) then + call MOM_error(FATAL, 'init_extern_field: field ' // trim(fieldname) & + // ' not found in ' // trim(file) // '.') + endif + + ! Pass to FMS2 implementation of init_external_field + + ! NOTE: external fields are currently assumed to be on-grid, which holds + ! across the current codebase. In the future, we may need to either enforce + ! this or somehow relax this requirement. if (present(MOM_Domain)) then - init_extern_field = init_external_field(file, fieldname, domain=MOM_domain%mpp_domain, & - verbose=verbose, threading=threading, ierr=ierr, ignore_axis_atts=ignore_axis_atts, & - correct_leap_year_inconsistency=correct_leap_year_inconsistency) + field%id = init_external_field(file, field%label, domain=MOM_domain%mpp_domain, & + verbose=verbose, ierr=ierr, ignore_axis_atts=ignore_axis_atts, & + correct_leap_year_inconsistency=correct_leap_year_inconsistency, & + ongrid=.true.) else - init_extern_field = init_external_field(file, fieldname, domain=domain, & - verbose=verbose, threading=threading, ierr=ierr, ignore_axis_atts=ignore_axis_atts, & - correct_leap_year_inconsistency=correct_leap_year_inconsistency) + field%id = init_external_field(file, field%label, domain=domain, & + verbose=verbose, ierr=ierr, ignore_axis_atts=ignore_axis_atts, & + correct_leap_year_inconsistency=correct_leap_year_inconsistency, & + ongrid=.true.) endif - end function init_extern_field end module MOM_interp_infra diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index 62a43ab99b..c16e34e2e3 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -1,14 +1,15 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> This module contains a thin inteface to mpp and fms I/O code module MOM_io_infra -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_domain_infra, only : MOM_domain_type, rescale_comp_data, AGRID, BGRID_NE, CGRID_NE use MOM_domain_infra, only : domain2d, domain1d, CENTER, CORNER, NORTH_FACE, EAST_FACE use MOM_error_infra, only : MOM_error=>MOM_err, NOTE, FATAL, WARNING, is_root_PE -use MOM_string_functions, only : lowercase - use fms2_io_mod, only : fms2_open_file => open_file, check_if_open, fms2_close_file => close_file +use fms2_io_mod, only : fms2_flush_file => flush_file use fms2_io_mod, only : FmsNetcdfDomainFile_t, FmsNetcdfFile_t, fms2_read_data => read_data use fms2_io_mod, only : get_unlimited_dimension_name, get_num_dimensions, get_num_variables use fms2_io_mod, only : get_variable_names, variable_exists, get_variable_size, get_variable_units @@ -16,35 +17,37 @@ module MOM_io_infra use fms2_io_mod, only : variable_att_exists, get_variable_attribute, get_variable_num_dimensions use fms2_io_mod, only : get_variable_dimension_names, is_dimension_registered, get_dimension_size use fms2_io_mod, only : is_dimension_unlimited, register_axis, unlimited +use fms2_io_mod, only : get_dimension_names use fms2_io_mod, only : get_global_io_domain_indices use fms_io_utils_mod, only : fms2_file_exist => file_exists +use fms_io_utils_mod, only : get_filename_appendix -use fms_mod, only : write_version_number, open_namelist_file, check_nml_error -use fms_io_mod, only : file_exist, field_exist, field_size, read_data -use fms_io_mod, only : fms_io_exit, get_filename_appendix +use fms_mod, only : write_version_number, check_nml_error use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_global_domain -use mpp_io_mod, only : mpp_open, mpp_close, mpp_flush -use mpp_io_mod, only : mpp_write_meta, mpp_write -use mpp_io_mod, only : mpp_get_atts, mpp_attribute_exist -use mpp_io_mod, only : mpp_get_axes, mpp_axistype=>axistype, mpp_get_axis_data -use mpp_io_mod, only : mpp_get_fields, mpp_fieldtype=>fieldtype -use mpp_io_mod, only : mpp_get_info, mpp_get_times -use mpp_io_mod, only : mpp_io_init use mpp_mod, only : stdout_if_root=>stdout -! These are encoding constants. -use mpp_io_mod, only : APPEND_FILE=>MPP_APPEND, WRITEONLY_FILE=>MPP_WRONLY -use mpp_io_mod, only : OVERWRITE_FILE=>MPP_OVERWR, READONLY_FILE=>MPP_RDONLY -use mpp_io_mod, only : NETCDF_FILE=>MPP_NETCDF, ASCII_FILE=>MPP_ASCII -use mpp_io_mod, only : MULTIPLE=>MPP_MULTI, SINGLE_FILE=>MPP_SINGLE +use mpp_mod, only : mpp_pe, mpp_root_pe, mpp_npes +use mpp_mod, only : mpp_get_current_pelist_name use iso_fortran_env, only : int64 implicit none ; private +! Duplication of FMS1 parameter values +! NOTE: Only kept to emulate FMS1 behavior, and may be removed in the future. +integer, parameter :: WRITEONLY_FILE = 100 +integer, parameter :: READONLY_FILE = 101 +integer, parameter :: APPEND_FILE = 102 +integer, parameter :: OVERWRITE_FILE = 103 +integer, parameter :: ASCII_FILE = 200 +integer, parameter :: NETCDF_FILE = 203 +integer, parameter :: SINGLE_FILE = 400 +integer, parameter :: MULTIPLE = 401 + ! These interfaces are actually implemented or have explicit interfaces in this file. public :: open_file, open_ASCII_file, file_is_open, close_file, flush_file, file_exists public :: get_file_info, get_file_fields, get_file_times, get_filename_suffix public :: read_field, read_vector, write_metadata, write_field -public :: field_exists, get_field_atts, get_field_size, get_axis_data, read_field_chksum +public :: field_exists, get_field_atts, get_field_size, read_field_chksum +public :: get_axis_size, get_axis_data, set_axis_data public :: io_infra_init, io_infra_end, MOM_namelist_file, check_namelist_error, write_version public :: stdout_if_root ! These types act as containers for information about files, fields and axes, respectively, @@ -61,15 +64,10 @@ module MOM_io_infra module procedure MOM_file_exists end interface -!> Open a file (or fileset) for parallel or single-file I/O. -interface open_file - module procedure open_file_type, open_file_unit -end interface open_file - !> Read a data field from a file interface read_field module procedure read_field_4d - module procedure read_field_3d + module procedure read_field_3d, read_field_3d_region module procedure read_field_2d, read_field_2d_region module procedure read_field_1d, read_field_1d_int module procedure read_field_0d, read_field_0d_int @@ -102,11 +100,6 @@ module MOM_io_infra module procedure close_file_type, close_file_unit end interface close_file -!> Ensure that the output stream associated with a file handle is fully sent to disk -interface flush_file - module procedure flush_file_type, flush_file_unit -end interface flush_file - !> Type for holding a handle to an open file and related information type :: file_type ; private integer :: unit = -1 !< The framework identfier or netCDF unit number of an output file @@ -117,32 +110,24 @@ module MOM_io_infra logical :: open_to_write = .false. !< If true, this file or fileset can be written to integer :: num_times !< The number of time levels in this file real :: file_time !< The time of the latest entry in the file. - logical :: FMS2_file !< If true, this file-type is to be used with FMS2 interfaces. end type file_type !> This type is a container for information about a variable in a file. type :: fieldtype ; private character(len=256) :: name !< The name of this field in the files. - type(mpp_fieldtype) :: FT !< The FMS1 field-type that this type wraps character(len=:), allocatable :: longname !< The long name for this field character(len=:), allocatable :: units !< The units for this field integer(kind=int64) :: chksum_read !< A checksum that has been read from a file logical :: valid_chksum !< If true, this field has a valid checksum value. - logical :: FMS2_field !< If true, this field-type should be used with FMS2 interfaces. end type fieldtype !> This type is a container for information about an axis in a file. type :: axistype ; private character(len=256) :: name !< The name of this axis in the files. - type(mpp_axistype) :: AT !< The FMS1 axis-type that this type wraps real, allocatable, dimension(:) :: ax_data !< The values of the data on the axis. logical :: domain_decomposed = .false. !< True if axis is domain-decomposed end type axistype -!> For now, these module-variables are hard-coded to exercise the new FMS2 interfaces. -logical :: FMS2_reads = .true. -logical :: FMS2_writes = .true. - contains !> Reads the checksum value for a field that was recorded in a file, along with a flag indicating @@ -163,11 +148,10 @@ logical function MOM_file_exists(filename, MOM_Domain) character(len=*), intent(in) :: filename !< The name of the file being inquired about type(MOM_domain_type), intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition -! This function uses the fms_io function file_exist to determine whether -! a named file (or its decomposed variant) exists. - - MOM_file_exists = file_exist(filename, MOM_Domain%mpp_domain) + type(FmsNetcdfDomainFile_t) :: fileobj + MOM_file_exists = fms2_open_file(fileobj, filename, "read", MOM_Domain%mpp_domain) + if (MOM_file_exists) call fms2_close_file(fileobj) end function MOM_file_exists !> Returns true if the named file or its domain-decomposed variant exists. @@ -194,58 +178,74 @@ subroutine close_file_type(IO_handle) if (associated(IO_handle%fileobj)) then call fms2_close_file(IO_handle%fileobj) deallocate(IO_handle%fileobj) - else - call mpp_close(IO_handle%unit) endif if (allocated(IO_handle%filename)) deallocate(IO_handle%filename) IO_handle%open_to_read = .false. ; IO_handle%open_to_write = .false. IO_handle%num_times = 0 ; IO_handle%file_time = 0.0 - IO_handle%FMS2_file = .false. end subroutine close_file_type +! TODO: close_file_unit is only used for ASCII files, which are opened outside +! of the framework, so this could probably be removed, and those calls could +! just be replaced with close(unit). + !> closes a file. If the unit does not point to an open file, !! close_file_unit simply returns without doing anything. -subroutine close_file_unit(unit) - integer, intent(inout) :: unit !< The I/O unit for the file to be closed +subroutine close_file_unit(iounit) + integer, intent(inout) :: iounit !< The I/O unit for the file to be closed - call mpp_close(unit) + logical :: unit_is_open + + inquire(iounit, opened=unit_is_open) + if (unit_is_open) close(iounit) end subroutine close_file_unit !> Ensure that the output stream associated with a file handle is fully sent to disk. -subroutine flush_file_type(IO_handle) +subroutine flush_file(IO_handle) type(file_type), intent(in) :: IO_handle !< The I/O handle for the file to flush if (associated(IO_handle%fileobj)) then - ! There does not appear to be an fms2 flush call. - else - call mpp_flush(IO_handle%unit) + call fms2_flush_file(IO_handle%fileobj) endif -end subroutine flush_file_type - -!> Ensure that the output stream associated with a unit is fully sent to disk. -subroutine flush_file_unit(unit) - integer, intent(in) :: unit !< The I/O unit for the file to flush - - call mpp_flush(unit) -end subroutine flush_file_unit +end subroutine flush_file !> Initialize the underlying I/O infrastructure subroutine io_infra_init(maxunits) integer, optional, intent(in) :: maxunits !< An optional maximum number of file !! unit numbers that can be used. - call mpp_io_init(maxunit=maxunits) + + ! FMS2 requires no explicit initialization, so this is a null function. end subroutine io_infra_init !> Gracefully close out and terminate the underlying I/O infrastructure subroutine io_infra_end() - call fms_io_exit() + ! FMS2 requires no explicit finalization, so this is a null function. end subroutine io_infra_end !> Open a single namelist file that is potentially readable by all PEs. -function MOM_namelist_file(file) result(unit) - character(len=*), optional, intent(in) :: file !< The file to open, by default "input.nml". - integer :: unit !< The opened unit number of the namelist file - unit = open_namelist_file(file) +function MOM_namelist_file(filepath) result(iounit) + character(len=*), optional, intent(in) :: filepath + !< The file to open, by default "input.nml". + integer :: iounit + !< The opened unit number of the namelist file + + character(len=:), allocatable :: nmlpath + ! Namelist path + character(len=:), allocatable :: nmlpath_pe + ! Hypothetical namelist path exclusive to the current PE list + + if (present(filepath)) then + nmlpath = trim(filepath) + else + ! FMS1 first checks for a namelist unique to the PE list, `input_{}.nml`. + ! If not found, it defaults to `input.nml`. + nmlpath_pe = 'input_' // trim(mpp_get_current_pelist_name()) // '.nml' + if (file_exists(nmlpath_pe)) then + nmlpath = nmlpath_pe + else + nmlpath = 'input.nml' + endif + endif + call open_ASCII_file(iounit, nmlpath, action=READONLY_FILE) end function MOM_namelist_file !> Checks the iostat argument that is returned after reading a namelist variable and writes a @@ -267,35 +267,7 @@ subroutine write_version(version, tag, unit) end subroutine write_version !> open_file opens a file for parallel or single-file I/O. -subroutine open_file_unit(unit, filename, action, form, threading, fileset, nohdrs, domain, MOM_domain) - integer, intent(out) :: unit !< The I/O unit for the opened file - character(len=*), intent(in) :: filename !< The name of the file being opened - integer, optional, intent(in) :: action !< A flag indicating whether the file can be read - !! or written to and how to handle existing files. - integer, optional, intent(in) :: form !< A flag indicating the format of a new file. The - !! default is ASCII_FILE, but NETCDF_FILE is also common. - integer, optional, intent(in) :: threading !< A flag indicating whether one (SINGLE_FILE) - !! or multiple PEs (MULTIPLE) participate in I/O. - !! With the default, the root PE does I/O. - integer, optional, intent(in) :: fileset !< A flag indicating whether multiple PEs doing I/O due - !! to threading=MULTIPLE write to the same file (SINGLE_FILE) - !! or to one file per PE (MULTIPLE, the default). - logical, optional, intent(in) :: nohdrs !< If nohdrs is .TRUE., headers are not written to - !! ASCII files. The default is .false. - type(domain2d), optional, intent(in) :: domain !< A domain2d type that describes the decomposition - type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition - - if (present(MOM_Domain)) then - call mpp_open(unit, filename, action=action, form=form, threading=threading, fileset=fileset, & - nohdrs=nohdrs, domain=MOM_Domain%mpp_domain) - else - call mpp_open(unit, filename, action=action, form=form, threading=threading, fileset=fileset, & - nohdrs=nohdrs, domain=domain) - endif -end subroutine open_file_unit - -!> open_file opens a file for parallel or single-file I/O. -subroutine open_file_type(IO_handle, filename, action, MOM_domain, threading, fileset) +subroutine open_file(IO_handle, filename, action, MOM_domain, threading, fileset) type(file_type), intent(inout) :: IO_handle !< The handle for the opened file character(len=*), intent(in) :: filename !< The path name of the file being opened integer, optional, intent(in) :: action !< A flag indicating whether the file can be read @@ -323,63 +295,59 @@ subroutine open_file_type(IO_handle, filename, action, MOM_domain, threading, fi integer :: index_nc if (IO_handle%open_to_write) then - call MOM_error(WARNING, "open_file_type called for file "//trim(filename)//& + call MOM_error(WARNING, "open_file called for file "//trim(filename)//& " with an IO_handle that is already open to to write.") return endif if (IO_handle%open_to_read) then - call MOM_error(FATAL, "open_file_type called for file "//trim(filename)//& + call MOM_error(FATAL, "open_file called for file "//trim(filename)//& " with an IO_handle that is already open to to read.") endif file_mode = WRITEONLY_FILE ; if (present(action)) file_mode = action - if (FMS2_writes .and. present(MOM_Domain)) then - if (.not.associated(IO_handle%fileobj)) allocate (IO_handle%fileobj) - - ! The FMS1 interface automatically appends .nc if necessary, but FMS2 interface does not. - index_nc = index(trim(filename), ".nc") - if (index_nc > 0) then - filename_tmp = trim(filename) - else - filename_tmp = trim(filename)//".nc" - if (is_root_PE()) call MOM_error(WARNING, "Open_file is appending .nc to the filename "//trim(filename)) - endif + ! Domains are currently required to use FMS I/O. + ! NOTE: We restrict FMS2 IO usage to domain-based files due to issues with + ! string-based attributes in certain compilers. + ! But we may relax this requirement in the future. + if (.not. present(MOM_Domain)) & + call MOM_error(FATAL, 'open_file: FMS I/O requires a domain input.') - if (file_mode == WRITEONLY_FILE) then ; mode = "write" - elseif (file_mode == APPEND_FILE) then ; mode = "append" - elseif (file_mode == OVERWRITE_FILE) then ; mode = "overwrite" - elseif (file_mode == READONLY_FILE) then ; mode = "read" - else - call MOM_error(FATAL, "open_file_type called with unrecognized action.") - endif + if (.not.associated(IO_handle%fileobj)) allocate (IO_handle%fileobj) - IO_handle%num_times = 0 - IO_handle%file_time = 0.0 - if ((file_mode == APPEND_FILE) .and. file_exists(filename_tmp, MOM_Domain)) then - ! Determine the latest file time and number of records so far. - success = fms2_open_file(fileObj_read, trim(filename_tmp), "read", MOM_domain%mpp_domain) - call get_unlimited_dimension_name(fileObj_read, dim_unlim_name) - if (len_trim(dim_unlim_name) > 0) & - call get_dimension_size(fileObj_read, trim(dim_unlim_name), IO_handle%num_times) - if (IO_handle%num_times > 0) & - call fms2_read_data(fileObj_read, trim(dim_unlim_name), IO_handle%file_time, & - unlim_dim_level=IO_handle%num_times) - call fms2_close_file(fileObj_read) - endif + ! The FMS1 interface automatically appends .nc if necessary, but FMS2 interface does not. + index_nc = index(trim(filename), ".nc") + if (index_nc > 0) then + filename_tmp = trim(filename) + else + filename_tmp = trim(filename)//".nc" + if (is_root_PE()) call MOM_error(WARNING, "Open_file is appending .nc to the filename "//trim(filename)) + endif - success = fms2_open_file(IO_handle%fileobj, trim(filename_tmp), trim(mode), MOM_domain%mpp_domain) - if (.not.success) call MOM_error(FATAL, "Unable to open file "//trim(filename_tmp)) - IO_handle%FMS2_file = .true. - elseif (present(MOM_Domain)) then - call mpp_open(IO_handle%unit, filename, action=file_mode, form=NETCDF_FILE, threading=threading, & - fileset=fileset, domain=MOM_Domain%mpp_domain) - IO_handle%FMS2_file = .false. + if (file_mode == WRITEONLY_FILE) then ; mode = "write" + elseif (file_mode == APPEND_FILE) then ; mode = "append" + elseif (file_mode == OVERWRITE_FILE) then ; mode = "overwrite" + elseif (file_mode == READONLY_FILE) then ; mode = "read" else - call mpp_open(IO_handle%unit, filename, action=file_mode, form=NETCDF_FILE, threading=threading, & - fileset=fileset) - IO_handle%FMS2_file = .false. + call MOM_error(FATAL, "open_file called with unrecognized action.") endif + + IO_handle%num_times = 0 + IO_handle%file_time = 0.0 + if ((file_mode == APPEND_FILE) .and. file_exists(filename_tmp, MOM_Domain)) then + ! Determine the latest file time and number of records so far. + success = fms2_open_file(fileObj_read, trim(filename_tmp), "read", MOM_domain%mpp_domain) + dim_unlim_name = find_unlimited_dimension_name(fileObj_read) + if (len_trim(dim_unlim_name) > 0) & + call get_dimension_size(fileObj_read, trim(dim_unlim_name), IO_handle%num_times) + if (IO_handle%num_times > 0) & + call fms2_read_data(fileObj_read, trim(dim_unlim_name), IO_handle%file_time, & + unlim_dim_level=IO_handle%num_times) + call fms2_close_file(fileObj_read) + endif + + success = fms2_open_file(IO_handle%fileobj, trim(filename_tmp), trim(mode), MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Unable to open file "//trim(filename_tmp)) IO_handle%filename = trim(filename) if (file_mode == READONLY_FILE) then @@ -388,7 +356,7 @@ subroutine open_file_type(IO_handle, filename, action, MOM_domain, threading, fi IO_handle%open_to_read = .false. ; IO_handle%open_to_write = .true. endif -end subroutine open_file_type +end subroutine open_file !> open_file opens an ascii file for parallel or single-file I/O using Fortran read and write calls. subroutine open_ASCII_file(unit, file, action, threading, fileset) @@ -403,9 +371,87 @@ subroutine open_ASCII_file(unit, file, action, threading, fileset) !! to threading=MULTIPLE write to the same file (SINGLE_FILE) !! or to one file per PE (MULTIPLE, the default). - call mpp_open(unit, file, action=action, form=ASCII_FILE, threading=threading, fileset=fileset, & - nohdrs=.true.) + integer :: action_flag + integer :: threading_flag + integer :: fileset_flag + logical :: exists + logical :: is_open + character(len=6) :: action_arg, position_arg + character(len=:), allocatable :: filename + + ! NOTE: This function is written to emulate the original behavior of mpp_open + ! from the FMS1 library, on which the MOM API is still based. Much of this + ! can be removed if we choose to drop this compatibility, but for now we + ! try to retain as much as possible. + + ! NOTE: Default FMS1 I/O settings are summarized below. + ! + ! access: Fortran and mpp_open default to SEQUENTIAL. + ! form: The Fortran and mpp_open default (for MPP_ASCII) is FORMATTED. + ! recl: mpp_open uses Fortran defaults when unset, so can be ignored. + ! ios: FMS1 allowed this to be caught, but we do not support it. + ! action/position: In mpp_open, these are inferred from `action`. + ! + ! MOM flag FMS1 flag action position + ! -------- -------- ------ -------- + ! READONLY_FILE MPP_RDONLY READ REWIND + ! WRITEONLY_FILE MPP_WRONLY WRITE REWIND + ! OVERWRITE_FILE MPP_OVERWR WRITE REWIND + ! APPEND_FILE MPP_APPEND WRITE APPEND + ! + ! From this, we can omit `access`, `form`, and `recl`, and can construct + ! `action` and `position` from the input arguments. + + ! I/O configuration + + action_flag = WRITEONLY_FILE + if (present(action)) action_flag = action + + action_arg = 'write' + if (action_flag == READONLY_FILE) action_arg = 'read' + + position_arg = 'rewind' + if (action_flag == APPEND_FILE) position_arg = 'append' + + ! Threading configuration + + threading_flag = SINGLE_FILE + if (present(threading)) threading_flag = threading + + fileset_flag = MULTIPLE + if (present(fileset)) fileset_flag = fileset + + ! Force fileset to be consistent with threading (as in FMS1) + if (threading_flag == SINGLE_FILE) fileset_flag = SINGLE_FILE + + ! Construct the distributed filename, if needed + filename = file + if (fileset_flag == MULTIPLE) then + if (mpp_npes() > 10000) then + write(filename, '(a,".",i6.6)') trim(filename), mpp_pe() - mpp_root_pe() + else + write(filename, '(a,".",i4.4)') trim(filename), mpp_pe() - mpp_root_pe() + endif + endif + + inquire(file=filename, exist=exists) + if (exists .and. action_flag == WRITEONLY_FILE) & + call MOM_error(WARNING, 'open_ASCII_file: File ' // trim(filename) // & + ' opened WRITEONLY already exists!') + + open(newunit=unit, file=filename, action=trim(action_arg), & + position=trim(position_arg)) + ! This checks if open() failed but did not raise a runtime error. + inquire(unit, opened=is_open) + if (.not. is_open) & + call MOM_error(FATAL, & + 'open_ASCII_file: File "' // trim(filename) // '" failed to open.') + + ! NOTE: There are two possible mpp_write_meta functions in FMS1: + ! - call mpp_write_meta( unit, 'filename', cval=mpp_file(unit)%name) + ! - call mpp_write_meta( unit, 'NumFilesInSet', ival=nfiles) + ! I'm not convinced we actually want these, but note them here in case. end subroutine open_ASCII_file @@ -429,23 +475,14 @@ subroutine get_file_info(IO_handle, ndim, nvar, ntime) character(len=256) :: dim_unlim_name ! name of the unlimited dimension in the file integer :: ndims, nvars, natts, ntimes - if (IO_handle%FMS2_file) then - if (present(ndim)) ndim = get_num_dimensions(IO_handle%fileobj) - if (present(nvar)) nvar = get_num_variables(IO_handle%fileobj) - if (present(ntime)) then - ntime = 0 - call get_unlimited_dimension_name(IO_handle%fileobj, dim_unlim_name) - if (len_trim(dim_unlim_name) > 0) & - call get_dimension_size(IO_handle%fileobj, trim(dim_unlim_name), ntime) - endif - else - call mpp_get_info(IO_handle%unit, ndims, nvars, natts, ntimes ) - - if (present(ndim)) ndim = ndims - if (present(nvar)) nvar = nvars - if (present(ntime)) ntime = ntimes + if (present(ndim)) ndim = get_num_dimensions(IO_handle%fileobj) + if (present(nvar)) nvar = get_num_variables(IO_handle%fileobj) + if (present(ntime)) then + ntime = 0 + dim_unlim_name = find_unlimited_dimension_name(IO_handle%fileobj) + if (len_trim(dim_unlim_name) > 0) & + call get_dimension_size(IO_handle%fileobj, trim(dim_unlim_name), ntime) endif - end subroutine get_file_info @@ -465,12 +502,9 @@ subroutine get_file_times(IO_handle, time_values, ntime) if (present(ntime)) ntime = ntimes if (ntimes > 0) then allocate(time_values(ntimes)) - if (IO_handle%FMS2_file) then - call get_unlimited_dimension_name(IO_handle%fileobj, dim_unlim_name) + dim_unlim_name = find_unlimited_dimension_name(IO_handle%fileobj) + if (len_trim(dim_unlim_name) > 0) & call fms2_read_data(IO_handle%fileobj, trim(dim_unlim_name), time_values) - else - call mpp_get_times(IO_handle%unit, time_values) - endif endif end subroutine get_file_times @@ -480,7 +514,6 @@ subroutine get_file_fields(IO_handle, fields) type(file_type), intent(in) :: IO_handle !< Handle for a file that is open for I/O type(fieldtype), dimension(:), intent(inout) :: fields !< Field-type descriptions of all of !! the variables in a file. - type(mpp_fieldtype), dimension(size(fields)) :: mpp_fields ! Fieldtype structures for the variables character(len=256), dimension(size(fields)) :: var_names ! The names of all variables character(len=256) :: units ! The units of a variable as recorded in the file character(len=2048) :: longname ! The long-name of a variable as recorded in the file @@ -491,39 +524,25 @@ subroutine get_file_fields(IO_handle, fields) nvar = size(fields) ! Local variables - if (IO_handle%FMS2_file) then - call get_variable_names(IO_handle%fileobj, var_names) - do i=1,nvar - fields(i)%name = trim(var_names(i)) - longname = "" - if (variable_att_exists(IO_handle%fileobj, var_names(i), "long_name")) & - call get_variable_attribute(IO_handle%fileobj, var_names(i), "long_name", longname) - fields(i)%longname = trim(longname) - units = "" - if (variable_att_exists(IO_handle%fileobj, var_names(i), "units")) & - call get_variable_attribute(IO_handle%fileobj, var_names(i), "units", units) - fields(i)%units = trim(units) - - fields(i)%valid_chksum = variable_att_exists(IO_handle%fileobj, var_names(i), "checksum") - if (fields(i)%valid_chksum) then - call get_variable_attribute(IO_handle%fileobj, var_names(i), 'checksum', checksum_char) - ! If there are problems, there might need to be code added to handle commas. - read (checksum_char(1:16), '(Z16)') fields(i)%chksum_read - endif - enddo - else - call mpp_get_fields(IO_handle%unit, mpp_fields) - do i=1,nvar - fields(i)%FT = mpp_fields(i) - call mpp_get_atts(fields(i)%FT, name=fields(i)%name, units=units, longname=longname, & - checksum=checksum_file) - fields(i)%longname = trim(longname) - fields(i)%units = trim(units) - fields(i)%valid_chksum = mpp_attribute_exist(fields(i)%FT, "checksum") - if (fields(i)%valid_chksum) fields(i)%chksum_read = checksum_file(1) - enddo - endif - + call get_variable_names(IO_handle%fileobj, var_names) + do i=1,nvar + fields(i)%name = trim(var_names(i)) + longname = "" + if (variable_att_exists(IO_handle%fileobj, var_names(i), "long_name")) & + call get_variable_attribute(IO_handle%fileobj, var_names(i), "long_name", longname) + fields(i)%longname = trim(longname) + units = "" + if (variable_att_exists(IO_handle%fileobj, var_names(i), "units")) & + call get_variable_attribute(IO_handle%fileobj, var_names(i), "units", units) + fields(i)%units = trim(units) + + fields(i)%valid_chksum = variable_att_exists(IO_handle%fileobj, var_names(i), "checksum") + if (fields(i)%valid_chksum) then + call get_variable_attribute(IO_handle%fileobj, var_names(i), 'checksum', checksum_char) + ! If there are problems, there might need to be code added to handle commas. + read (checksum_char(1:16), '(Z16)') fields(i)%chksum_read + endif + enddo end subroutine get_file_fields !> Extract information from a field type, as stored or as found in a file @@ -568,33 +587,26 @@ function field_exists(filename, field_name, domain, no_domain, MOM_domain) domainless = no_domain endif - if (FMS2_reads) then - field_exists = .false. - if (file_exists(filename)) then - if (domainless) then - success = fms2_open_file(fileObj_simple, trim(filename), "read") - if (success) then - field_exists = variable_exists(fileObj_simple, field_name) - call fms2_close_file(fileObj_simple) - endif + field_exists = .false. + if (file_exists(filename)) then + if (domainless) then + success = fms2_open_file(fileObj_simple, trim(filename), "read") + if (success) then + field_exists = variable_exists(fileObj_simple, field_name) + call fms2_close_file(fileObj_simple) + endif + else + if (present(MOM_domain)) then + success = fms2_open_file(fileObj_dd, trim(filename), "read", MOM_domain%mpp_domain) else - if (present(MOM_domain)) then - success = fms2_open_file(fileObj_dd, trim(filename), "read", MOM_domain%mpp_domain) - else - success = fms2_open_file(fileObj_dd, trim(filename), "read", domain) - endif - if (success) then - field_exists = variable_exists(fileobj_dd, field_name) - call fms2_close_file(fileObj_dd) - endif + success = fms2_open_file(fileObj_dd, trim(filename), "read", domain) + endif + if (success) then + field_exists = variable_exists(fileobj_dd, field_name) + call fms2_close_file(fileObj_dd) endif endif - elseif (present(MOM_domain)) then - field_exists = field_exist(filename, field_name, domain=MOM_domain%mpp_domain, no_domain=no_domain) - else - field_exists = field_exist(filename, field_name, domain=domain, no_domain=no_domain) endif - end function field_exists !> Given filename and fieldname, this subroutine returns the size of the field in the file @@ -607,54 +619,159 @@ subroutine get_field_size(filename, fieldname, sizes, field_found, no_domain) !! is a fatal error if the field is not found. logical, optional, intent(in) :: no_domain !< If present and true, do not check for file !! names with an appended tile number - ! Local variables type(FmsNetcdfFile_t) :: fileobj_read ! A handle to a non-domain-decomposed file for obtaining information - ! about the exiting time axis entries in append mode. + ! about the exiting time axis entries in append mode. logical :: success ! If true, the file was opened successfully logical :: field_exists ! True if filename exists and field_name is in filename integer :: i, ndims - - if (FMS2_reads) then - field_exists = .false. - if (file_exists(filename)) then - success = fms2_open_file(fileObj_read, trim(filename), "read") - if (success) then - field_exists = variable_exists(fileobj_read, fieldname) - if (field_exists) then - ndims = get_variable_num_dimensions(fileobj_read, fieldname) - if (ndims > size(sizes)) call MOM_error(FATAL, & - "get_field_size called with too few sizes for "//trim(fieldname)//" in "//trim(filename)) - call get_variable_size(fileobj_read, fieldname, sizes(1:ndims)) - do i=ndims+1,size(sizes) ; sizes(i) = 0 ; enddo + character(len=512), allocatable :: dimnames(:) ! Field dimension names + logical, allocatable :: is_x(:), is_y(:), is_t(:) ! True if index matches axis type + integer :: size_indices(4) ! Mapping of size index to FMS1 convention + integer :: idx, swap + + field_exists = .false. + if (file_exists(filename)) then + success = fms2_open_file(fileObj_read, trim(filename), "read") + if (success) then + field_exists = variable_exists(fileobj_read, fieldname) + if (field_exists) then + ndims = get_variable_num_dimensions(fileobj_read, fieldname) + if (ndims > size(sizes)) call MOM_error(FATAL, & + "get_field_size called with too few sizes for "//trim(fieldname)//" in "//trim(filename)) + call get_variable_size(fileobj_read, fieldname, sizes(1:ndims)) + + do i=ndims+1,size(sizes) ; sizes(i) = 0 ; enddo + + ! If sizes exceeds ndims, then we fallback to the FMS1 convention + ! where sizes has at least 4 dimension, and try to position values. + if (size(sizes) > ndims) then + ! Assume FMS1 positioning rules: (nx, ny, nz, nt, ...) + if (size(sizes) < 4) & + call MOM_error(FATAL, "If sizes(:) exceeds field dimensions, "& + &"then its length must be at least 4.") + + ! Fall back to the FMS1 default values of 1 (from mpp field%size) + sizes(ndims+1:) = 1 + + ! Gather the field dimension names + allocate(dimnames(ndims)) + dimnames(:) = "" + call get_variable_dimension_names(fileObj_read, trim(fieldname), & + dimnames) + + ! Test the dimensions against standard (x,y,t) names and attributes + allocate(is_x(ndims), is_y(ndims), is_t(ndims)) + is_x(:) = .false. + is_y(:) = .false. + is_t(:) = .false. + call categorize_axes(fileObj_read, filename, ndims, dimnames, & + is_x, is_y, is_t) + + ! Currently no z-test is supported, so disable assignment with 0 + size_indices = [ & + find_index(is_x), & + find_index(is_y), & + 0, & + find_index(is_t) & + ] + + do i = 1, size(size_indices) + idx = size_indices(i) + if (idx > 0) then + swap = sizes(i) + sizes(i) = sizes(idx) + sizes(idx) = swap + endif + enddo + + deallocate(is_x, is_y, is_t) + deallocate(dimnames) endif endif endif - if (present(field_found)) field_found = field_exists - else - call field_size(filename, fieldname, sizes, field_found=field_found, no_domain=no_domain) endif - + if (present(field_found)) field_found = field_exists end subroutine get_field_size + +!> Return the index of the first True element of a logical array. +!! +!! If all elements are false, return zero. +function find_index(vec) result(loc) + ! NOTE: This function acts as a replacement for findloc() F2008 intrinsic, + ! which is not available on some compilers, or may not support logicals. + logical, intent(in) :: vec(:) + integer :: loc + + integer :: i + + loc = 0 + do i = 1, size(vec) + if (vec(i)) then + loc = i + exit + endif + enddo +end function find_index + + +!> Get the axis size from an axistype +function get_axis_size(axis) result(axis_size) + type(axistype), intent(in) :: axis + !< Infra axis + integer :: axis_size + !< Axis size + + axis_size = size(axis%ax_data) +end function get_axis_size + + !> Extracts and returns the axis data stored in an axistype. -subroutine get_axis_data( axis, dat ) - type(axistype), intent(in) :: axis !< An axis type - real, dimension(:), intent(out) :: dat !< The data in the axis variable +subroutine get_axis_data(axis, axis_name, axis_data) + type(axistype), intent(in) :: axis + !< Infra axis + character(len=256), intent(out) :: axis_name + !< Axis name + real, dimension(:), intent(out) :: axis_data + !< Axis points integer :: i - ! This routine might not be needed for MOM6. if (allocated(axis%ax_data)) then - if (size(axis%ax_data) > size(dat)) call MOM_error(FATAL, & - "get_axis_data called with too small of an output data array for "//trim(axis%name)) - do i=1,size(axis%ax_data) ; dat(i) = axis%ax_data(i) ; enddo - elseif (.not.FMS2_writes) then - call mpp_get_axis_data( axis%AT, dat ) + if (size(axis%ax_data) > size(axis_data)) & + call MOM_error(FATAL, "get_axis_data called with too small of an " & + // "output data array for " // trim(axis%name) // ".") + do i=1,size(axis%ax_data) + axis_data(i) = axis%ax_data(i) + enddo endif + axis_name = axis%name end subroutine get_axis_data + +!> Return a new axistype based on axis specs +subroutine set_axis_data(axis, axis_name, axis_data) + type(axistype), intent(inout) :: axis + !< Target axis + character(len=256), intent(in) :: axis_name + !< Target axis name + real, intent(in) :: axis_data(:) + !< Target axis values + + axis%name = axis_name + + if (allocated(axis%ax_data)) deallocate(axis%ax_data) + allocate(axis%ax_data(size(axis_data))) + + axis%ax_data(:) = axis_data(:) + + ! NOTE: We do not yet consider domain-decomposed axes. + axis%domain_decomposed = .false. +end subroutine set_axis_data + + !> This routine uses the fms_io subroutine read_data to read a scalar named !! "fieldname" from a single or domain-decomposed file "filename". subroutine read_field_0d(filename, fieldname, data, timelevel, scale, MOM_Domain, & @@ -678,7 +795,7 @@ subroutine read_field_0d(filename, fieldname, data, timelevel, scale, MOM_Domain logical :: has_time_dim ! True if the variable has an unlimited time axis. logical :: success ! True if the file was successfully opened - if (present(MOM_Domain) .and. FMS2_reads) then + if (present(MOM_Domain)) then ! Open the FMS2 file-set. success = fms2_open_file(fileobj_DD, filename, "read", MOM_domain%mpp_domain) if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) @@ -696,7 +813,7 @@ subroutine read_field_0d(filename, fieldname, data, timelevel, scale, MOM_Domain ! Close the file-set. if (check_if_open(fileobj_DD)) call fms2_close_file(fileobj_DD) - elseif (FMS2_reads) then + else ! Open the FMS2 file-set. success = fms2_open_file(fileObj, trim(filename), "read") if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) @@ -715,10 +832,6 @@ subroutine read_field_0d(filename, fieldname, data, timelevel, scale, MOM_Domain ! Close the file-set. if (check_if_open(fileobj)) call fms2_close_file(fileobj) - elseif (present(MOM_Domain)) then ! Read the variable using the FMS-1 interface. - call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, timelevel=timelevel) - else - call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) endif if (present(scale)) then ; if (scale /= 1.0) then @@ -750,7 +863,7 @@ subroutine read_field_1d(filename, fieldname, data, timelevel, scale, MOM_Domain logical :: has_time_dim ! True if the variable has an unlimited time axis. logical :: success ! True if the file was successfully opened - if (present(MOM_Domain) .and. FMS2_reads) then + if (present(MOM_Domain)) then ! Open the FMS2 file-set. success = fms2_open_file(fileobj_DD, filename, "read", MOM_domain%mpp_domain) if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) @@ -768,7 +881,7 @@ subroutine read_field_1d(filename, fieldname, data, timelevel, scale, MOM_Domain ! Close the file-set. if (check_if_open(fileobj_DD)) call fms2_close_file(fileobj_DD) - elseif (FMS2_reads) then + else ! Open the FMS2 file-set. success = fms2_open_file(fileObj, trim(filename), "read") if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) @@ -787,10 +900,6 @@ subroutine read_field_1d(filename, fieldname, data, timelevel, scale, MOM_Domain ! Close the file-set. if (check_if_open(fileobj)) call fms2_close_file(fileobj) - elseif (present(MOM_Domain)) then ! Read the variable using the FMS-1 interface. - call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, timelevel=timelevel) - else - call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) endif if (present(scale)) then ; if (scale /= 1.0) then @@ -823,29 +932,24 @@ subroutine read_field_2d(filename, fieldname, data, MOM_Domain, & logical :: has_time_dim ! True if the variable has an unlimited time axis. logical :: success ! True if the file was successfully opened - if (FMS2_reads) then - ! Open the FMS2 file-set. - success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) - if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) - - ! Find the matching case-insensitive variable name in the file and prepare to read it. - call prepare_to_read_var(fileobj, fieldname, "read_field_2d: ", filename, & - var_to_read, has_time_dim, timelevel, position) + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) - ! Read the data. - if (present(timelevel) .and. has_time_dim) then - call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) - else - call fms2_read_data(fileobj, var_to_read, data) - endif + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj, fieldname, "read_field_2d: ", filename, & + var_to_read, has_time_dim, timelevel, position) - ! Close the file-set. - if (check_if_open(fileobj)) call fms2_close_file(fileobj) - else ! Read the variable using the FMS-1 interface. - call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=position) + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) endif + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + if (present(scale)) then ; if (scale /= 1.0) then call rescale_comp_data(MOM_Domain, data, scale) endif ; endif @@ -879,7 +983,7 @@ subroutine read_field_2d_region(filename, fieldname, data, start, nread, MOM_dom character(len=96) :: var_to_read ! Name of variable to read from the netcdf file logical :: success ! True if the file was successfully opened - if (present(MOM_Domain) .and. FMS2_reads) then + if (present(MOM_Domain)) then ! Open the FMS2 file-set. success = fms2_open_file(fileobj_DD, filename, "read", MOM_domain%mpp_domain) if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) @@ -893,7 +997,7 @@ subroutine read_field_2d_region(filename, fieldname, data, start, nread, MOM_dom ! Close the file-set. if (check_if_open(fileobj_DD)) call fms2_close_file(fileobj_DD) - elseif (FMS2_reads) then + else ! Open the FMS2 file-set. success = fms2_open_file(fileObj, trim(filename), "read") if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) @@ -907,11 +1011,6 @@ subroutine read_field_2d_region(filename, fieldname, data, start, nread, MOM_dom ! Close the file-set. if (check_if_open(fileobj)) call fms2_close_file(fileobj) - elseif (present(MOM_Domain)) then ! Read the variable using the FMS-1 interface. - call read_data(filename, fieldname, data, start, nread, domain=MOM_Domain%mpp_domain, & - no_domain=no_domain) - else - call read_data(filename, fieldname, data, start, nread, no_domain=no_domain) endif if (present(scale)) then ; if (scale /= 1.0) then @@ -949,34 +1048,97 @@ subroutine read_field_3d(filename, fieldname, data, MOM_Domain, & logical :: has_time_dim ! True if the variable has an unlimited time axis. logical :: success ! True if the file was successfully opened - if (FMS2_reads) then + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj, fieldname, "read_field_3d: ", filename, & + var_to_read, has_time_dim, timelevel, position) + + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) + endif + + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + + if (present(scale)) then ; if (scale /= 1.0) then + call rescale_comp_data(MOM_Domain, data, scale) + endif ; endif + +end subroutine read_field_3d + +!> This routine uses the fms_io subroutine read_data to read a region from a distributed or +!! global 3-D data field named "fieldname" from file "filename". +subroutine read_field_3d_region(filename, fieldname, data, start, nread, MOM_domain, & + no_domain, scale) + character(len=*), intent(in) :: filename !< The name of the file to read + character(len=*), intent(in) :: fieldname !< The variable name of the data in the file + real, dimension(:,:,:), intent(inout) :: data !< The 3-dimensional array into which the data + !! should be read + integer, dimension(:), intent(in) :: start !< The starting index to read in each of 3 + !! dimensions. For this 3-d read, the + !! 4th value is always 1. + integer, dimension(:), intent(in) :: nread !< The number of points to read in each of 4 + !! dimensions. For this 3-d read, the + !! 4th values are always 1. + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< The MOM_Domain that describes the decomposition + logical, optional, intent(in) :: no_domain !< If present and true, this variable does not + !! use domain decomposion. + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied + !! by before it is returned. + + ! Local variables + type(FmsNetcdfFile_t) :: fileObj ! A handle to a non-domain-decomposed file + type(FmsNetcdfDomainFile_t) :: fileobj_DD ! A handle to a domain-decomposed file object + character(len=96) :: var_to_read ! Name of variable to read from the netcdf file + logical :: success ! True if the file was successfully opened + + if (present(MOM_Domain)) then ! Open the FMS2 file-set. - success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) + success = fms2_open_file(fileobj_DD, filename, "read", MOM_domain%mpp_domain) if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) ! Find the matching case-insensitive variable name in the file and prepare to read it. - call prepare_to_read_var(fileobj, fieldname, "read_field_3d: ", filename, & - var_to_read, has_time_dim, timelevel, position) + call prepare_to_read_var(fileobj_DD, fieldname, "read_field_2d_region: ", & + filename, var_to_read) ! Read the data. - if (present(timelevel) .and. has_time_dim) then - call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) - else - call fms2_read_data(fileobj, var_to_read, data) - endif + call fms2_read_data(fileobj_DD, var_to_read, data, corner=start(1:3), edge_lengths=nread(1:3)) + + ! Close the file-set. + if (check_if_open(fileobj_DD)) call fms2_close_file(fileobj_DD) + else + ! Open the FMS2 file-set. + success = fms2_open_file(fileObj, trim(filename), "read") + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive variable name in the file, and determine whether it + ! has a time dimension. + call find_varname_in_file(fileObj, fieldname, "read_field_2d_region: ", filename, var_to_read) + + ! Read the data. + call fms2_read_data(fileobj, var_to_read, data, corner=start(1:3), edge_lengths=nread(1:3)) ! Close the file-set. if (check_if_open(fileobj)) call fms2_close_file(fileobj) - else ! Read the variable using the FMS-1 interface. - call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=position) endif if (present(scale)) then ; if (scale /= 1.0) then - call rescale_comp_data(MOM_Domain, data, scale) + if (present(MOM_Domain)) then + call rescale_comp_data(MOM_Domain, data, scale) + else + ! Dangerously rescale the whole array + data(:,:,:) = scale*data(:,:,:) + endif endif ; endif -end subroutine read_field_3d +end subroutine read_field_3d_region !> This routine uses the fms_io subroutine read_data to read a distributed !! 4-D data field named "fieldname" from file "filename". Valid values for @@ -1001,29 +1163,24 @@ subroutine read_field_4d(filename, fieldname, data, MOM_Domain, & character(len=96) :: var_to_read ! Name of variable to read from the netcdf file logical :: success ! True if the file was successfully opened - if (FMS2_reads) then - ! Open the FMS2 file-set. - success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) - if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) - - ! Find the matching case-insensitive variable name in the file and prepare to read it. - call prepare_to_read_var(fileobj, fieldname, "read_field_4d: ", filename, & - var_to_read, has_time_dim, timelevel, position) + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) - ! Read the data. - if (present(timelevel) .and. has_time_dim) then - call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) - else - call fms2_read_data(fileobj, var_to_read, data) - endif + ! Find the matching case-insensitive variable name in the file and prepare to read it. + call prepare_to_read_var(fileobj, fieldname, "read_field_4d: ", filename, & + var_to_read, has_time_dim, timelevel, position) - ! Close the file-set. - if (check_if_open(fileobj)) call fms2_close_file(fileobj) - else ! Read the variable using the FMS-1 interface. - call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=position) + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, var_to_read, data) endif + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + if (present(scale)) then ; if (scale /= 1.0) then call rescale_comp_data(MOM_Domain, data, scale) endif ; endif @@ -1045,29 +1202,25 @@ subroutine read_field_0d_int(filename, fieldname, data, timelevel) logical :: success ! If true, the file was opened successfully ! This routine might not be needed for MOM6. - if (FMS2_reads) then - ! Open the FMS2 file-set. - success = fms2_open_file(fileObj, trim(filename), "read") - if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) - ! Find the matching case-insensitive variable name in the file, and determine whether it - ! has a time dimension. - call find_varname_in_file(fileObj, fieldname, "read_field_0d_int: ", filename, & - var_to_read, has_time_dim, timelevel) + ! Open the FMS2 file-set. + success = fms2_open_file(fileObj, trim(filename), "read") + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) - ! Read the data. - if (present(timelevel) .and. has_time_dim) then - call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) - else - call fms2_read_data(fileobj, var_to_read, data) - endif + ! Find the matching case-insensitive variable name in the file, and determine whether it + ! has a time dimension. + call find_varname_in_file(fileObj, fieldname, "read_field_0d_int: ", filename, & + var_to_read, has_time_dim, timelevel) - ! Close the file-set. - if (check_if_open(fileobj)) call fms2_close_file(fileobj) + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) else - call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) + call fms2_read_data(fileobj, var_to_read, data) endif + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) end subroutine read_field_0d_int !> This routine uses the fms_io subroutine read_data to read a 1-D integer @@ -1086,29 +1239,25 @@ subroutine read_field_1d_int(filename, fieldname, data, timelevel) logical :: success ! If true, the file was opened successfully ! This routine might not be needed for MOM6. - if (FMS2_reads) then - ! Open the FMS2 file-set. - success = fms2_open_file(fileObj, trim(filename), "read") - if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) - ! Find the matching case-insensitive variable name in the file, and determine whether it - ! has a time dimension. - call find_varname_in_file(fileObj, fieldname, "read_field_1d_int: ", filename, & - var_to_read, has_time_dim, timelevel) + ! Open the FMS2 file-set. + success = fms2_open_file(fileObj, trim(filename), "read") + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) - ! Read the data. - if (present(timelevel) .and. has_time_dim) then - call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) - else - call fms2_read_data(fileobj, var_to_read, data) - endif + ! Find the matching case-insensitive variable name in the file, and determine whether it + ! has a time dimension. + call find_varname_in_file(fileObj, fieldname, "read_field_1d_int: ", filename, & + var_to_read, has_time_dim, timelevel) - ! Close the file-set. - if (check_if_open(fileobj)) call fms2_close_file(fileobj) + ! Read the data. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, var_to_read, data, unlim_dim_level=timelevel) else - call read_data(filename, fieldname, data, timelevel=timelevel, no_domain=.true.) + call fms2_read_data(fileobj, var_to_read, data) endif + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) end subroutine read_field_1d_int @@ -1144,36 +1293,29 @@ subroutine read_vector_2d(filename, u_fieldname, v_fieldname, u_data, v_data, MO elseif (stagger == AGRID) then ; u_pos = CENTER ; v_pos = CENTER ; endif endif - if (FMS2_reads) then - ! Open the FMS2 file-set. - success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) - if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) - - ! Find the matching case-insensitive u- and v-variable names in the file and prepare to read them. - call prepare_to_read_var(fileobj, u_fieldname, "read_vector_2d: ", filename, & - u_var, has_time_dim, timelevel, position=u_pos) - call prepare_to_read_var(fileobj, v_fieldname, "read_vector_2d: ", filename, & - v_var, has_time_dim, timelevel, position=v_pos) - - ! Read the u-data and v-data. There would already been an error message for one - ! of the variables if they are inconsistent in having an unlimited dimension. - if (present(timelevel) .and. has_time_dim) then - call fms2_read_data(fileobj, u_var, u_data, unlim_dim_level=timelevel) - call fms2_read_data(fileobj, v_var, v_data, unlim_dim_level=timelevel) - else - call fms2_read_data(fileobj, u_var, u_data) - call fms2_read_data(fileobj, v_var, v_data) - endif - - ! Close the file-set. - if (check_if_open(fileobj)) call fms2_close_file(fileobj) - else ! Read the variable using the FMS-1 interface. - call read_data(filename, u_fieldname, u_data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=u_pos) - call read_data(filename, v_fieldname, v_data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=v_pos) + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive u- and v-variable names in the file and prepare to read them. + call prepare_to_read_var(fileobj, u_fieldname, "read_vector_2d: ", filename, & + u_var, has_time_dim, timelevel, position=u_pos) + call prepare_to_read_var(fileobj, v_fieldname, "read_vector_2d: ", filename, & + v_var, has_time_dim, timelevel, position=v_pos) + + ! Read the u-data and v-data. There would already been an error message for one + ! of the variables if they are inconsistent in having an unlimited dimension. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, u_var, u_data, unlim_dim_level=timelevel) + call fms2_read_data(fileobj, v_var, v_data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, u_var, u_data) + call fms2_read_data(fileobj, v_var, v_data) endif + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + if (present(scale)) then ; if (scale /= 1.0) then call rescale_comp_data(MOM_Domain, u_data, scale) call rescale_comp_data(MOM_Domain, v_data, scale) @@ -1214,36 +1356,29 @@ subroutine read_vector_3d(filename, u_fieldname, v_fieldname, u_data, v_data, MO elseif (stagger == AGRID) then ; u_pos = CENTER ; v_pos = CENTER ; endif endif - if (FMS2_reads) then - ! Open the FMS2 file-set. - success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) - if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) - - ! Find the matching case-insensitive u- and v-variable names in the file and prepare to read them. - call prepare_to_read_var(fileobj, u_fieldname, "read_vector_3d: ", filename, & - u_var, has_time_dim, timelevel, position=u_pos) - call prepare_to_read_var(fileobj, v_fieldname, "read_vector_3d: ", filename, & - v_var, has_time_dim, timelevel, position=v_pos) - - ! Read the u-data and v-data, dangerously assuming either both or neither have time dimensions. - ! There would already been an error message for one of the variables if they are inconsistent. - if (present(timelevel) .and. has_time_dim) then - call fms2_read_data(fileobj, u_var, u_data, unlim_dim_level=timelevel) - call fms2_read_data(fileobj, v_var, v_data, unlim_dim_level=timelevel) - else - call fms2_read_data(fileobj, u_var, u_data) - call fms2_read_data(fileobj, v_var, v_data) - endif - - ! Close the file-set. - if (check_if_open(fileobj)) call fms2_close_file(fileobj) - else ! Read the variable using the FMS-1 interface. - call read_data(filename, u_fieldname, u_data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=u_pos) - call read_data(filename, v_fieldname, v_data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=v_pos) + ! Open the FMS2 file-set. + success = fms2_open_file(fileobj, filename, "read", MOM_domain%mpp_domain) + if (.not.success) call MOM_error(FATAL, "Failed to open "//trim(filename)) + + ! Find the matching case-insensitive u- and v-variable names in the file and prepare to read them. + call prepare_to_read_var(fileobj, u_fieldname, "read_vector_3d: ", filename, & + u_var, has_time_dim, timelevel, position=u_pos) + call prepare_to_read_var(fileobj, v_fieldname, "read_vector_3d: ", filename, & + v_var, has_time_dim, timelevel, position=v_pos) + + ! Read the u-data and v-data, dangerously assuming either both or neither have time dimensions. + ! There would already been an error message for one of the variables if they are inconsistent. + if (present(timelevel) .and. has_time_dim) then + call fms2_read_data(fileobj, u_var, u_data, unlim_dim_level=timelevel) + call fms2_read_data(fileobj, v_var, v_data, unlim_dim_level=timelevel) + else + call fms2_read_data(fileobj, u_var, u_data) + call fms2_read_data(fileobj, v_var, v_data) endif + ! Close the file-set. + if (check_if_open(fileobj)) call fms2_close_file(fileobj) + if (present(scale)) then ; if (scale /= 1.0) then call rescale_comp_data(MOM_Domain, u_data, scale) call rescale_comp_data(MOM_Domain, v_data, scale) @@ -1477,7 +1612,7 @@ end subroutine MOM_register_variable_axes !> Determine whether a variable's axes are associated with x-, y- or time-dimensions. Other !! unlimited dimensions are also labeled as time axes for these purposes. subroutine categorize_axes(fileObj, filename, ndims, dim_names, is_x, is_y, is_t) - type(FmsNetcdfDomainFile_t), intent(in) :: fileObj !< Handle to an open FMS2 netCDF file object + class(FmsNetcdfFile_t), intent(in) :: fileObj !< Handle to an open FMS2 netCDF file object character(len=*), intent(in) :: filename !< The name of the file to read integer, intent(in) :: ndims !< The number of dimensions associated with a variable character(len=*), dimension(ndims), intent(in) :: dim_names !< Names of the dimensions associated with a variable @@ -1499,13 +1634,16 @@ subroutine categorize_axes(fileObj, filename, ndims, dim_names, is_x, is_y, is_t ! First look for indicative variable attributes if (.not.is_t(i)) then if (variable_exists(fileobj, trim(dim_names(i)))) then + cartesian = "" if (variable_att_exists(fileobj, trim(dim_names(i)), "cartesian_axis")) then - call get_variable_attribute(fileobj, trim(dim_names(i)), "cartesian_axis", cartesian) - cartesian = adjustl(cartesian) - if ((index(cartesian, "X") == 1) .or. (index(cartesian, "x") == 1)) is_x(i) = .true. - if ((index(cartesian, "Y") == 1) .or. (index(cartesian, "y") == 1)) is_y(i) = .true. - if ((index(cartesian, "T") == 1) .or. (index(cartesian, "t") == 1)) is_t(i) = .true. + call get_variable_attribute(fileobj, trim(dim_names(i)), "cartesian_axis", cartesian(1:1)) + elseif (variable_att_exists(fileobj, trim(dim_names(i)), "axis")) then + call get_variable_attribute(fileobj, trim(dim_names(i)), "axis", cartesian(1:1)) endif + cartesian = adjustl(cartesian) + if ((index(cartesian, "X") == 1) .or. (index(cartesian, "x") == 1)) is_x(i) = .true. + if ((index(cartesian, "Y") == 1) .or. (index(cartesian, "y") == 1)) is_y(i) = .true. + if ((index(cartesian, "T") == 1) .or. (index(cartesian, "t") == 1)) is_t(i) = .true. endif endif if (is_x(i)) x_found = .true. @@ -1524,8 +1662,10 @@ subroutine categorize_axes(fileObj, filename, ndims, dim_names, is_x, is_y, is_t if (.not.(x_found .and. y_found)) then ! Look for hints from CF-compliant axis units for uncharacterized axes do i=1,ndims ; if (.not.(is_x(i) .or. is_y(i) .or. is_t(i))) then - call get_variable_units(fileobj, trim(dim_names(i)), units) - call categorize_axis_from_units(units, is_x(i), is_y(i)) + if (variable_exists(fileobj, trim(dim_names(i)))) then + call get_variable_units(fileobj, trim(dim_names(i)), units) + call categorize_axis_from_units(units, is_x(i), is_y(i)) + endif if (is_x(i)) x_found = .true. if (is_y(i)) y_found = .true. endif ; enddo @@ -1621,14 +1761,11 @@ subroutine write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_c ! Local variables integer :: time_index - if (IO_handle%FMS2_file .and. present(tstamp)) then + if (present(tstamp)) then time_index = write_time_if_later(IO_handle, tstamp) call write_data(IO_handle%fileobj, trim(field_md%name), field, unlim_dim_level=time_index) - elseif (IO_handle%FMS2_file) then - call write_data(IO_handle%fileobj, trim(field_md%name), field) else - call mpp_write(IO_handle%unit, field_md%FT, MOM_domain%mpp_domain, field, tstamp=tstamp, & - tile_count=tile_count, default_data=fill_value) + call write_data(IO_handle%fileobj, trim(field_md%name), field) endif end subroutine write_field_4d @@ -1645,14 +1782,11 @@ subroutine write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_c ! Local variables integer :: time_index - if (IO_handle%FMS2_file .and. present(tstamp)) then + if (present(tstamp)) then time_index = write_time_if_later(IO_handle, tstamp) call write_data(IO_handle%fileobj, trim(field_md%name), field, unlim_dim_level=time_index) - elseif (IO_handle%FMS2_file) then - call write_data(IO_handle%fileobj, trim(field_md%name), field) else - call mpp_write(IO_handle%unit, field_md%FT, MOM_domain%mpp_domain, field, tstamp=tstamp, & - tile_count=tile_count, default_data=fill_value) + call write_data(IO_handle%fileobj, trim(field_md%name), field) endif end subroutine write_field_3d @@ -1669,14 +1803,11 @@ subroutine write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_c ! Local variables integer :: time_index - if (IO_handle%FMS2_file .and. present(tstamp)) then + if (present(tstamp)) then time_index = write_time_if_later(IO_handle, tstamp) call write_data(IO_handle%fileobj, trim(field_md%name), field, unlim_dim_level=time_index) - elseif (IO_handle%FMS2_file) then - call write_data(IO_handle%fileobj, trim(field_md%name), field) else - call mpp_write(IO_handle%unit, field_md%FT, MOM_domain%mpp_domain, field, tstamp=tstamp, & - tile_count=tile_count, default_data=fill_value) + call write_data(IO_handle%fileobj, trim(field_md%name), field) endif end subroutine write_field_2d @@ -1690,13 +1821,11 @@ subroutine write_field_1d(IO_handle, field_md, field, tstamp) ! Local variables integer :: time_index - if (IO_handle%FMS2_file .and. present(tstamp)) then + if (present(tstamp)) then time_index = write_time_if_later(IO_handle, tstamp) call write_data(IO_handle%fileobj, trim(field_md%name), field, unlim_dim_level=time_index) - elseif (IO_handle%FMS2_file) then - call write_data(IO_handle%fileobj, trim(field_md%name), field) else - call mpp_write(IO_handle%unit, field_md%FT, field, tstamp=tstamp) + call write_data(IO_handle%fileobj, trim(field_md%name), field) endif end subroutine write_field_1d @@ -1710,13 +1839,11 @@ subroutine write_field_0d(IO_handle, field_md, field, tstamp) ! Local variables integer :: time_index - if (IO_handle%FMS2_file .and. present(tstamp)) then + if (present(tstamp)) then time_index = write_time_if_later(IO_handle, tstamp) call write_data(IO_handle%fileobj, trim(field_md%name), field, unlim_dim_level=time_index) - elseif (IO_handle%FMS2_file) then - call write_data(IO_handle%fileobj, trim(field_md%name), field) else - call mpp_write(IO_handle%unit, field_md%FT, field, tstamp=tstamp) + call write_data(IO_handle%fileobj, trim(field_md%name), field) endif end subroutine write_field_0d @@ -1732,11 +1859,10 @@ integer function write_time_if_later(IO_handle, field_time) if ((field_time > IO_handle%file_time) .or. (IO_handle%num_times == 0)) then IO_handle%file_time = field_time IO_handle%num_times = IO_handle%num_times + 1 - if (IO_handle%FMS2_file) then - call get_unlimited_dimension_name(IO_handle%fileobj, dim_unlim_name) - call write_data(IO_handle%fileobj, trim(dim_unlim_name), (/field_time/), & - corner=(/IO_handle%num_times/), edge_lengths=(/1/)) - endif + dim_unlim_name = find_unlimited_dimension_name(IO_handle%fileobj) + if (len_trim(dim_unlim_name) > 0) & + call write_data(IO_handle%fileobj, trim(dim_unlim_name), [field_time], & + corner=[IO_handle%num_times], edge_lengths=[1]) endif write_time_if_later = IO_handle%num_times @@ -1749,18 +1875,13 @@ subroutine MOM_write_axis(IO_handle, axis) integer :: is, ie - if (IO_handle%FMS2_file) then - if (axis%domain_decomposed) then - ! FMS2 does not domain-decompose 1d arrays, so we explicitly slice it - call get_global_io_domain_indices(IO_handle%fileobj, trim(axis%name), is, ie) - call write_data(IO_handle%fileobj, trim(axis%name), axis%ax_data(is:ie)) - else - call write_data(IO_handle%fileobj, trim(axis%name), axis%ax_data) - endif + if (axis%domain_decomposed) then + ! FMS2 does not domain-decompose 1d arrays, so we explicitly slice it + call get_global_io_domain_indices(IO_handle%fileobj, trim(axis%name), is, ie) + call write_data(IO_handle%fileobj, trim(axis%name), axis%ax_data(is:ie)) else - call mpp_write(IO_handle%unit, axis%AT) + call write_data(IO_handle%fileobj, trim(axis%name), axis%ax_data) endif - end subroutine MOM_write_axis !> Store information about an axis in a previously defined axistype and write this @@ -1787,12 +1908,10 @@ subroutine write_metadata_axis(IO_handle, axis, name, units, longname, cartesian integer :: position ! A flag indicating the axis staggering position. integer :: i, isc, iec, global_size - if (IO_handle%FMS2_file) then - if (is_dimension_registered(IO_handle%fileobj, trim(name))) then - call MOM_error(FATAL, "write_metadata_axis was called more than once for axis "//trim(name)//& - " in file "//trim(IO_handle%filename)) - return - endif + if (is_dimension_registered(IO_handle%fileobj, trim(name))) then + call MOM_error(FATAL, "write_metadata_axis was called more than once for axis "//trim(name)//& + " in file "//trim(IO_handle%filename)) + return endif axis%name = trim(name) @@ -1800,82 +1919,73 @@ subroutine write_metadata_axis(IO_handle, axis, name, units, longname, cartesian "Data is already allocated in a call to write_metadata_axis for axis "//& trim(name)//" in file "//trim(IO_handle%filename)) - if (IO_handle%FMS2_file) then - is_x = .false. ; is_y = .false. ; is_t = .false. - position = CENTER - if (present(cartesian)) then - cart = trim(adjustl(cartesian)) - if ((index(cart, "X") == 1) .or. (index(cart, "x") == 1)) is_x = .true. - if ((index(cart, "Y") == 1) .or. (index(cart, "y") == 1)) is_y = .true. - if ((index(cart, "T") == 1) .or. (index(cart, "t") == 1)) is_t = .true. - endif - - ! For now, we assume that all horizontal axes are domain-decomposed. - if (is_x .or. is_y) & - axis%domain_decomposed = .true. - - if (is_x) then - if (present(edge_axis)) then ; if (edge_axis) position = EAST_FACE ; endif - call register_axis(IO_handle%fileobj, trim(name), 'x', domain_position=position) - elseif (is_y) then - if (present(edge_axis)) then ; if (edge_axis) position = NORTH_FACE ; endif - call register_axis(IO_handle%fileobj, trim(name), 'y', domain_position=position) - elseif (is_t .and. .not.present(data)) then - ! This is the unlimited (time) dimension. - call register_axis(IO_handle%fileobj, trim(name), unlimited) - else - if (.not.present(data)) call MOM_error(FATAL,"MOM_io:register_diagnostic_axis: "//& - "An axis_length argument is required to register the axis "//trim(name)) - call register_axis(IO_handle%fileobj, trim(name), size(data)) - endif + is_x = .false. ; is_y = .false. ; is_t = .false. + position = CENTER + if (present(cartesian)) then + cart = trim(adjustl(cartesian)) + if ((index(cart, "X") == 1) .or. (index(cart, "x") == 1)) is_x = .true. + if ((index(cart, "Y") == 1) .or. (index(cart, "y") == 1)) is_y = .true. + if ((index(cart, "T") == 1) .or. (index(cart, "t") == 1)) is_t = .true. + endif - if (present(data)) then - ! With FMS2, the data for the axis labels has to match the computational domain on this PE. - if (present(domain)) then - ! The commented-out code on the next ~11 lines runs but there is missing data in the output file - ! call mpp_get_compute_domain(domain, isc, iec) - ! call mpp_get_global_domain(domain, size=global_size) - ! if (size(data) == global_size) then - ! allocate(axis%ax_data(iec+1-isc)) ; axis%ax_data(:) = data(isc:iec) - ! ! A simpler set of labels: do i=1,iec-isc ; axis%ax_data(i) = real(isc + i) - 1.0 ; enddo - ! elseif (size(data) == global_size+1) then - ! ! This is an edge axis. Note the effective SW indexing convention here. - ! allocate(axis%ax_data(iec+2-isc)) ; axis%ax_data(:) = data(isc:iec+1) - ! ! A simpler set of labels: do i=1,iec+1-isc ; axis%ax_data(i) = real(isc + i) - 1.5 ; enddo - ! else - ! call MOM_error(FATAL, "Unexpected size of data for "//trim(name)//" in write_metadata_axis.") - ! endif - - ! This works for a simple 1x1 IO layout, but gives errors for nontrivial IO layouts - allocate(axis%ax_data(size(data))) ; axis%ax_data(:) = data(:) - - else ! Store the entire array of axis labels. - allocate(axis%ax_data(size(data))) ; axis%ax_data(:) = data(:) - endif - endif + ! For now, we assume that all horizontal axes are domain-decomposed. + if (is_x .or. is_y) & + axis%domain_decomposed = .true. + + if (is_x) then + if (present(edge_axis)) then ; if (edge_axis) position = EAST_FACE ; endif + call register_axis(IO_handle%fileobj, trim(name), 'x', domain_position=position) + elseif (is_y) then + if (present(edge_axis)) then ; if (edge_axis) position = NORTH_FACE ; endif + call register_axis(IO_handle%fileobj, trim(name), 'y', domain_position=position) + elseif (is_t .and. .not.present(data)) then + ! This is the unlimited (time) dimension. + call register_axis(IO_handle%fileobj, trim(name), unlimited) + else + if (.not.present(data)) call MOM_error(FATAL,"MOM_io:register_diagnostic_axis: "//& + "An axis_length argument is required to register the axis "//trim(name)) + call register_axis(IO_handle%fileobj, trim(name), size(data)) + endif + if (present(data)) then + ! With FMS2, the data for the axis labels has to match the computational domain on this PE. + if (present(domain)) then + ! The commented-out code on the next ~11 lines runs but there is missing data in the output file + ! call mpp_get_compute_domain(domain, isc, iec) + ! call mpp_get_global_domain(domain, size=global_size) + ! if (size(data) == global_size) then + ! allocate(axis%ax_data(iec+1-isc)) ; axis%ax_data(:) = data(isc:iec) + ! ! A simpler set of labels: do i=1,iec-isc ; axis%ax_data(i) = real(isc + i) - 1.0 ; enddo + ! elseif (size(data) == global_size+1) then + ! ! This is an edge axis. Note the effective SW indexing convention here. + ! allocate(axis%ax_data(iec+2-isc)) ; axis%ax_data(:) = data(isc:iec+1) + ! ! A simpler set of labels: do i=1,iec+1-isc ; axis%ax_data(i) = real(isc + i) - 1.5 ; enddo + ! else + ! call MOM_error(FATAL, "Unexpected size of data for "//trim(name)//" in write_metadata_axis.") + ! endif + + ! This works for a simple 1x1 IO layout, but gives errors for nontrivial IO layouts + allocate(axis%ax_data(size(data))) ; axis%ax_data(:) = data(:) - ! Now create the variable that describes this axis. - call register_field(IO_handle%fileobj, trim(name), "double", dimensions=(/name/)) - if (len_trim(longname) > 0) & - call register_variable_attribute(IO_handle%fileobj, trim(name), 'long_name', & - trim(longname), len_trim(longname)) - if (len_trim(units) > 0) & - call register_variable_attribute(IO_handle%fileobj, trim(name), 'units', & - trim(units), len_trim(units)) - if (present(cartesian)) & - call register_variable_attribute(IO_handle%fileobj, trim(name), 'cartesian_axis', & - trim(cartesian), len_trim(cartesian)) - if (present(sense)) & - call register_variable_attribute(IO_handle%fileobj, trim(name), 'sense', sense) - else - if (present(data)) then + else ! Store the entire array of axis labels. allocate(axis%ax_data(size(data))) ; axis%ax_data(:) = data(:) endif - - call mpp_write_meta(IO_handle%unit, axis%AT, name, units, longname, cartesian=cartesian, sense=sense, & - domain=domain, data=data, calendar=calendar) endif + + + ! Now create the variable that describes this axis. + call register_field(IO_handle%fileobj, trim(name), "double", dimensions=(/name/)) + if (len_trim(longname) > 0) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'long_name', & + trim(longname), len_trim(longname)) + if (len_trim(units) > 0) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'units', & + trim(units), len_trim(units)) + if (present(cartesian)) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'cartesian_axis', & + trim(cartesian), len_trim(cartesian)) + if (present(sense)) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'sense', sense) end subroutine write_metadata_axis !> Store information about an output variable in a previously defined fieldtype and write this @@ -1897,35 +2007,27 @@ subroutine write_metadata_field(IO_handle, field, axes, name, units, longname, & ! Local variables character(len=256), dimension(size(axes)) :: dim_names ! The names of the dimensions - type(mpp_axistype), dimension(size(axes)) :: mpp_axes ! The array of mpp_axistypes for this variable character(len=16) :: prec_string ! A string specifying the precision with which to save this variable character(len=64) :: checksum_string ! checksum character array created from checksum argument integer :: i, ndims ndims = size(axes) - if (IO_handle%FMS2_file) then - do i=1,ndims ; dim_names(i) = trim(axes(i)%name) ; enddo - prec_string = "double" ; if (present(pack)) then ; if (pack > 1) prec_string = "float" ; endif - call register_field(IO_handle%fileobj, trim(name), trim(prec_string), dimensions=dim_names) - if (len_trim(longname) > 0) & - call register_variable_attribute(IO_handle%fileobj, trim(name), 'long_name', & - trim(longname), len_trim(longname)) - if (len_trim(units) > 0) & - call register_variable_attribute(IO_handle%fileobj, trim(name), 'units', & - trim(units), len_trim(units)) - if (present(standard_name)) & - call register_variable_attribute(IO_handle%fileobj, trim(name), 'standard_name', & - trim(standard_name), len_trim(standard_name)) - if (present(checksum)) then - write (checksum_string,'(Z16)') checksum(1) ! Z16 is the hexadecimal format code - call register_variable_attribute(IO_handle%fileobj, trim(name), "checksum", & - trim(checksum_string), len_trim(checksum_string)) - endif - else - do i=1,ndims ; mpp_axes(i) = axes(i)%AT ; enddo - call mpp_write_meta(IO_handle%unit, field%FT, mpp_axes, name, units, longname, & - pack=pack, standard_name=standard_name, checksum=checksum) - ! unused opt. args: min=min, max=max, fill=fill, scale=scale, add=add, & + do i=1,ndims ; dim_names(i) = trim(axes(i)%name) ; enddo + prec_string = "double" ; if (present(pack)) then ; if (pack > 1) prec_string = "float" ; endif + call register_field(IO_handle%fileobj, trim(name), trim(prec_string), dimensions=dim_names) + if (len_trim(longname) > 0) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'long_name', & + trim(longname), len_trim(longname)) + if (len_trim(units) > 0) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'units', & + trim(units), len_trim(units)) + if (present(standard_name)) & + call register_variable_attribute(IO_handle%fileobj, trim(name), 'standard_name', & + trim(standard_name), len_trim(standard_name)) + if (present(checksum)) then + write (checksum_string,'(Z16)') checksum(1) ! Z16 is the hexadecimal format code + call register_variable_attribute(IO_handle%fileobj, trim(name), "checksum", & + trim(checksum_string), len_trim(checksum_string)) endif ! Store information in the field-type, regardless of which interfaces are used. @@ -1943,12 +2045,58 @@ subroutine write_metadata_global(IO_handle, name, attribute) character(len=*), intent(in) :: name !< The name in the file of this global attribute character(len=*), intent(in) :: attribute !< The value of this attribute - if (IO_handle%FMS2_file) then - call register_global_attribute(IO_handle%fileobj, name, attribute, len_trim(attribute)) - else - call mpp_write_meta(IO_handle%unit, name, cval=attribute) - endif - + call register_global_attribute(IO_handle%fileobj, name, attribute, len_trim(attribute)) end subroutine write_metadata_global +!> Return unlimited dimension name in file, or empty string if none exists. +function find_unlimited_dimension_name(fileobj) result(label) + type(FmsNetcdfDomainFile_t), intent(in) :: fileobj + !< File handle + character(len=:), allocatable :: label + !< Unlimited dimension name, or empty string if none exists + + integer :: ndims + !< Number of dimensions + character(len=256), allocatable :: dim_names(:) + !< File handle dimension names + integer :: i + !< Loop index + + ndims = get_num_dimensions(fileobj) + allocate(dim_names(ndims)) + call get_dimension_names(fileobj, dim_names) + + do i = 1, ndims + if (is_dimension_unlimited(fileobj, dim_names(i))) then + label = trim(dim_names(i)) + exit + endif + enddo + deallocate(dim_names) + + if (.not. allocated(label)) & + label = '' +end function find_unlimited_dimension_name + +! NOTE: `lowercase is duplicated from `src/framework/MOM_string_functions.F90` +! in order to avoid any dependency of the infra on the framework. + +!> Return a string in which all uppercase letters have been replaced by +!! their lowercase counterparts. +function lowercase(input_string) + character(len=*), intent(in) :: input_string !< The string to modify + character(len=len(input_string)) :: lowercase !< The modified output string +! This function returns a string in which all uppercase letters have been +! replaced by their lowercase counterparts. It is loosely based on the +! lowercase function in mpp_util.F90. + integer, parameter :: co=iachar('a')-iachar('A') ! case offset + integer :: k + + lowercase = input_string + do k=1, len_trim(input_string) + if (lowercase(k:k) >= 'A' .and. lowercase(k:k) <= 'Z') & + lowercase(k:k) = achar(ichar(lowercase(k:k))+co) + enddo +end function lowercase + end module MOM_io_infra diff --git a/config_src/infra/FMS2/MOM_time_manager.F90 b/config_src/infra/FMS2/MOM_time_manager.F90 index 5f3279b713..c03390a4bf 100644 --- a/config_src/infra/FMS2/MOM_time_manager.F90 +++ b/config_src/infra/FMS2/MOM_time_manager.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Wraps the FMS time manager functions module MOM_time_manager -! This file is part of MOM6. See LICENSE.md for the license. - use time_manager_mod, only : time_type, get_time, set_time use time_manager_mod, only : time_type_to_real, real_to_time_type use time_manager_mod, only : operator(+), operator(-), operator(*), operator(/) @@ -17,8 +19,9 @@ module MOM_time_manager implicit none ; private +! FMS re-exports public :: time_type, get_time, set_time -public :: time_type_to_real, real_to_time_type, real_to_time +public :: time_type_to_real, real_to_time_type public :: set_ticks_per_second, get_ticks_per_second public :: operator(+), operator(-), operator(*), operator(/) public :: operator(>), operator(<), operator(>=), operator(<=) @@ -26,6 +29,8 @@ module MOM_time_manager public :: get_date, set_date, increment_date, month_name, days_in_month public :: JULIAN, NOLEAP, THIRTY_DAY_MONTHS, GREGORIAN, NO_CALENDAR public :: set_calendar_type, get_calendar_type +! Module functions +public :: real_to_time, time_minus_signed, time_to_real contains @@ -34,14 +39,19 @@ module MOM_time_manager !! signed integers, this version should work over the entire valid range (2^31 days or ~5.8835 !! million years) of time_types, whereas the standard version in the FMS time_manager stops working !! for conversions of times greater than 2^31 seconds, or ~68.1 years. -type(time_type) function real_to_time(x, err_msg) +type(time_type) function real_to_time(time_in, err_msg, unscale) ! type(time_type) :: real_to_time !< The output time as a time_type - real, intent(in) :: x !< The input time in real seconds. + real, intent(in) :: time_in !< The input time in [s] or [T ~> s] character(len=*), optional, intent(out) :: err_msg !< An optional returned error message. + real, optional, intent(in) :: unscale !< A scaling factor that the input time is + !! multiplied by, often in [s T-1 ~> nondim] ! Local variables + real :: x ! The time in real seconds [s] + real :: real_subsecond_remainder ! The fractional seconds from time_in [s] integer :: seconds, days, ticks - real :: real_subsecond_remainder + + x = time_in ; if (present(unscale)) x = unscale*time_in days = floor(x/86400.) seconds = floor(x - 86400.*days) @@ -49,6 +59,41 @@ type(time_type) function real_to_time(x, err_msg) ticks = nint(real_subsecond_remainder * get_ticks_per_second()) real_to_time = set_time(seconds=seconds, days=days, ticks=ticks, err_msg=err_msg) + end function real_to_time +!> Returns the real number of seconds encoded in the time type [s] or the rescaled +!! amount of time in other units, often [T ~> s] +real function time_to_real(time, scale) + type(time_type), intent(in) :: time !< The time to be converted. + real, optional, intent(in) :: scale !< A scaling factor that returned the time is + !! multiplied by, often in [T s-1 ~> nondim] + + time_to_real = time_type_to_real(time) + if (present(scale)) time_to_real = scale * time_to_real + +end function time_to_real + +!> Returns a real number representing time_a - time_b in [s] or [T ~> s] if scale is present. +!! The FMS - operator for time types returns a new time type representing +!! a difference that is always >= 0. +!! In contrast, this function returns a negative real number if time_b > time_a, +!! and a positive real otherwise, as would be expected for subtraction. +real function time_minus_signed(time_a, time_b, scale) + type(time_type), intent(in) :: time_a, time_b !< Two times for calculating time_a - time_b + real, optional, intent(in) :: scale !< A scaling factor that returned the time is + !! multiplied by, often in [T s-1 ~> nondim] + + ! Local variables + real :: abs_diff ! The absolute value of the difference in times [s] or [T ~> s] + + ! Do FMS time subtraction, which will always be >= 0, + ! and convert to a real number. + abs_diff = time_to_real(time_a - time_b, scale) + + ! Add the sign back by comparing time_a and time_b + time_minus_signed = merge(abs_diff, -abs_diff, time_a >= time_b) + +end function time_minus_signed + end module MOM_time_manager diff --git a/config_src/memory/dynamic_nonsymmetric/MOM_memory.h b/config_src/memory/dynamic_nonsymmetric/MOM_memory.h index c3385b8b9a..0d5f44d6be 100644 --- a/config_src/memory/dynamic_nonsymmetric/MOM_memory.h +++ b/config_src/memory/dynamic_nonsymmetric/MOM_memory.h @@ -1,3 +1,7 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !/// \brief Compile-time memory settings !/// \details This include file determines the compile-time memory settings. !/// There are several variants of this file and only one should be in the search path for compilation. diff --git a/config_src/memory/dynamic_symmetric/MOM_memory.h b/config_src/memory/dynamic_symmetric/MOM_memory.h index 4188663a2c..e1557b6ac7 100644 --- a/config_src/memory/dynamic_symmetric/MOM_memory.h +++ b/config_src/memory/dynamic_symmetric/MOM_memory.h @@ -1,3 +1,7 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !/// \brief Compile-time memory settings !/// \details This include file determines the compile-time memory settings. !/// There are several variants of this file and only one should be in the search path for compilation. diff --git a/docs/.gitignore b/docs/.gitignore index e8b6a0513b..a9246f1e36 100644 --- a/docs/.gitignore +++ b/docs/.gitignore @@ -16,3 +16,8 @@ xml # Citation output bib*.aux citelist.doc* + + +# Python bytecode cache from the vendored _ext/autodoc_doxygen extension +__pycache__ +*.pyc diff --git a/docs/Doxyfile_rtd b/docs/Doxyfile_rtd index 479c03e1b4..b7c217769d 100644 --- a/docs/Doxyfile_rtd +++ b/docs/Doxyfile_rtd @@ -872,7 +872,8 @@ RECURSIVE = YES # Note that relative paths are relative to the directory from which doxygen is # run. -EXCLUDE = ../src/equation_of_state/TEOS10 +EXCLUDE = ../src/equation_of_state/TEOS10 \ + ../src/parameterizations/CVmix # The EXCLUDE_SYMLINKS tag can be used to select whether or not files or # directories that are symbolic links (a Unix file system feature) are excluded @@ -1954,7 +1955,7 @@ XML_OUTPUT = xml # The default value is: YES. # This tag requires that the tag GENERATE_XML is set to YES. -XML_PROGRAMLISTING = NO +XML_PROGRAMLISTING = YES #--------------------------------------------------------------------------- # Configuration options related to the DOCBOOK output diff --git a/docs/Makefile b/docs/Makefile index 98d5fe66bd..69f4fddf1c 100644 --- a/docs/Makefile +++ b/docs/Makefile @@ -25,7 +25,7 @@ endif # Internal variables. PAPEROPT_a4 = -D latex_paper_size=a4 PAPEROPT_letter = -D latex_paper_size=letter -ALLSPHINXOPTS = -d $(BUILDDIR)/doctrees $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) . +ALLSPHINXOPTS = -d $(BUILDDIR)/doctrees $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) # the i18n builder cannot share the environment and doctrees with the others I18NSPHINXOPTS = $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) . @@ -65,38 +65,45 @@ $(BUILDDIR): mkdir -p $@ html: $(DOXYGENBIN) $(BUILDDIR) - $(SPHINXBUILD) -b html $(ALLSPHINXOPTS) $(BUILDDIR)/html + $(SPHINXBUILD) -M html . $(BUILDDIR) $(ALLSPHINXOPTS) -j auto +# Optional equation post-processing (was a patch in jr3cermak/sphinx@v3.2.1mom6.4 +# applied to sphinx/cmd/build.py); now invoked from the Makefile so we can run +# against stock upstream Sphinx. The nortd target below has the same hook. +ifeq ($(UPDATEHTMLEQS), Y) + @echo "Post processing equations." + @python3 ./postProcessEquations.py -d $(BUILDDIR) -p html -b sphinx -s index.html $(UPDATEHTMLEQSVERBOSE) +endif @echo @echo "Build finished. The HTML pages are in $(BUILDDIR)/html." dirhtml: - $(SPHINXBUILD) -b dirhtml $(ALLSPHINXOPTS) $(BUILDDIR)/dirhtml + $(SPHINXBUILD) -M dirhtml . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished. The HTML pages are in $(BUILDDIR)/dirhtml." singlehtml: - $(SPHINXBUILD) -b singlehtml $(ALLSPHINXOPTS) $(BUILDDIR)/singlehtml + $(SPHINXBUILD) -M singlehtml . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished. The HTML page is in $(BUILDDIR)/singlehtml." pickle: - $(SPHINXBUILD) -b pickle $(ALLSPHINXOPTS) $(BUILDDIR)/pickle + $(SPHINXBUILD) -M pickle . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished; now you can process the pickle files." json: - $(SPHINXBUILD) -b json $(ALLSPHINXOPTS) $(BUILDDIR)/json + $(SPHINXBUILD) -M json . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished; now you can process the JSON files." htmlhelp: - $(SPHINXBUILD) -b htmlhelp $(ALLSPHINXOPTS) $(BUILDDIR)/htmlhelp + $(SPHINXBUILD) -M htmlhelp . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished; now you can run HTML Help Workshop with the" \ ".hhp project file in $(BUILDDIR)/htmlhelp." qthelp: - $(SPHINXBUILD) -b qthelp $(ALLSPHINXOPTS) $(BUILDDIR)/qthelp + $(SPHINXBUILD) -M qthelp . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished; now you can run "qcollectiongenerator" with the" \ ".qhcp project file in $(BUILDDIR)/qthelp, like this:" @@ -105,7 +112,7 @@ qthelp: @echo "# assistant -collectionFile $(BUILDDIR)/qthelp/MOM6.qhc" devhelp: - $(SPHINXBUILD) -b devhelp $(ALLSPHINXOPTS) $(BUILDDIR)/devhelp + $(SPHINXBUILD) -M devhelp . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished." @echo "To view the help file:" @@ -114,48 +121,48 @@ devhelp: @echo "# devhelp" epub: - $(SPHINXBUILD) -b epub $(ALLSPHINXOPTS) $(BUILDDIR)/epub + $(SPHINXBUILD) -M epub . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished. The epub file is in $(BUILDDIR)/epub." latex: $(DOXYGENBIN) $(BUILDDIR) - $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex + $(SPHINXBUILD) -M latex . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished; the LaTeX files are in $(BUILDDIR)/latex." @echo "Run \`make' in that directory to run these through (pdf)latex" \ "(use \`make latexpdf' here to do that automatically)." latexpdf: $(DOXYGENBIN) $(BUILDDIR) - $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex + $(SPHINXBUILD) -M latex . $(BUILDDIR) $(ALLSPHINXOPTS) @echo "Running LaTeX files through pdflatex..." $(MAKE) -C $(BUILDDIR)/latex LATEXMKOPTS="-f -silent" all-pdf @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex." latexpdfja: - $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex + $(SPHINXBUILD) -M latex . $(BUILDDIR) $(ALLSPHINXOPTS) @echo "Running LaTeX files through platex and dvipdfmx..." $(MAKE) -C $(BUILDDIR)/latex all-pdf-ja @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex." text: - $(SPHINXBUILD) -b text $(ALLSPHINXOPTS) $(BUILDDIR)/text + $(SPHINXBUILD) -M text . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished. The text files are in $(BUILDDIR)/text." man: - $(SPHINXBUILD) -b man $(ALLSPHINXOPTS) $(BUILDDIR)/man + $(SPHINXBUILD) -M man . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished. The manual pages are in $(BUILDDIR)/man." texinfo: - $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo + $(SPHINXBUILD) -M texinfo . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished. The Texinfo files are in $(BUILDDIR)/texinfo." @echo "Run \`make' in that directory to run these through makeinfo" \ "(use \`make info' here to do that automatically)." info: - $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo + $(SPHINXBUILD) -M texinfo . $(BUILDDIR) $(ALLSPHINXOPTS) @echo "Running Texinfo files through makeinfo..." make -C $(BUILDDIR)/texinfo info @echo "makeinfo finished; the Info files are in $(BUILDDIR)/texinfo." @@ -166,28 +173,28 @@ gettext: @echo "Build finished. The message catalogs are in $(BUILDDIR)/locale." changes: - $(SPHINXBUILD) -b changes $(ALLSPHINXOPTS) $(BUILDDIR)/changes + $(SPHINXBUILD) -M changes . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "The overview file is in $(BUILDDIR)/changes." linkcheck: - $(SPHINXBUILD) -b linkcheck $(ALLSPHINXOPTS) $(BUILDDIR)/linkcheck + $(SPHINXBUILD) -M linkcheck . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Link check complete; look for any errors in the above output " \ "or in $(BUILDDIR)/linkcheck/output.txt." doctest: - $(SPHINXBUILD) -b doctest $(ALLSPHINXOPTS) $(BUILDDIR)/doctest + $(SPHINXBUILD) -M doctest . $(BUILDDIR) $(ALLSPHINXOPTS) @echo "Testing of doctests in the sources finished, look at the " \ "results in $(BUILDDIR)/doctest/output.txt." xml: - $(SPHINXBUILD) -b xml $(ALLSPHINXOPTS) $(BUILDDIR)/xml + $(SPHINXBUILD) -M xml . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished. The XML files are in $(BUILDDIR)/xml." pseudoxml: - $(SPHINXBUILD) -b pseudoxml $(ALLSPHINXOPTS) $(BUILDDIR)/pseudoxml + $(SPHINXBUILD) -M pseudoxml . $(BUILDDIR) $(ALLSPHINXOPTS) @echo @echo "Build finished. The pseudo-XML files are in $(BUILDDIR)/pseudoxml." @@ -195,8 +202,8 @@ doxygen: git clone -b $(DOXYGEN_RELEASE) --depth 1 https://github.com/doxygen/doxygen doxygen/bin/doxygen: doxygen - (cd $(<); cmake -G "Unix Makefiles" .) - (cd $(<); make) + (cd $(<); cmake -DCMAKE_POLICY_VERSION_MINIMUM=3.5 -G "Unix Makefiles" .) + (cd $(<); $(MAKE)) nortd: $(DOXYGENBIN) $(BUILDDIR) ifdef DOXYGEN_CONF diff --git a/docs/README.md b/docs/README.md index 1bec91f288..8ccf773aad 100644 --- a/docs/README.md +++ b/docs/README.md @@ -249,9 +249,11 @@ added to the RTD administrative interface if you want to trigger post processing If `UPDATEHTMLEQSVERBOSE` is set to `-v` this will turn on verbose printing for the post processor. -NOTE: These options affect solo doxygen html processing only for the `make nortd` option. For sphinx, they are -utilized in the sphinx python module to handle post processing and are not part of the Makefile. This was done -as RTD runs sphinx processing directly using `sphinx-build` and not the Makefile. +The post-processing hook is invoked from the `Makefile` for both the +`make nortd` (doxygen html) and `make html` (sphinx html) targets. RTD, +which runs `sphinx-build` directly without using this Makefile, will not +trigger the hook automatically; if equation post-processing is desired +on RTD it must be run as a separate step from the RTD build configuration. ##### PAPER @@ -316,18 +318,27 @@ pip install -r requirements.txt You may need to use `pip3` to install requirements for python3. -Requirements: -- sphinx -- sphinx-rtd-theme -- sphinx-bibtex -- sphinx-fortran -- sphinxcontrib\_autodox-doxygen -- flint -- lxml -- numpy -- future - -For machines that need to build future, numpy or lxml, these packages are required: +The full pinned set lives in `requirements.txt`. The current toolchain +uses stock upstream Sphinx 8.x from PyPI: + +- `sphinx>=8,<9` +- `sphinx-rtd-theme` +- `sphinxcontrib-bibtex` +- `lxml` (used by the vendored `_ext/autodoc_doxygen` extension to + parse the Doxygen XML output) +- `numpy` +- `sphinx-fortran` from the upstream `VACUMM/sphinx-fortran` repository, + pinned to a specific commit (upstream has not cut a PyPI release past + 1.1.1 but the master branch has continued fixes) +- `six`, still required at module load time by the pinned `sphinx-fortran` + commit + +The `sphinxcontrib-autodoc_doxygen` Sphinx extension that was previously +pulled in as a separate fork is now vendored in-tree under +`docs/_ext/autodoc_doxygen/`; nothing extra needs to be installed for it. + +For machines that need to build numpy or lxml from source, these packages +are required: - Cython - wheel @@ -342,8 +353,8 @@ PDF generation requires the following packages ### doxygen You may choose to download the [source](https://www.doxygen.nl/download.html). - -Latest is `doxygen-1.8.20.src.tar.gz`. +The example below uses `1.8.20` but you can substitute any compatible +release tarball. ```bash tar xzf doxygen-1.8.20.src.tar.gz @@ -356,15 +367,17 @@ sudo make install ``` The makefile for doxygen attempts to install the compiled version into /usr/local/bin. -You can link to a specific executable within the virtual environment. At this point we -also recommend renaming `doxygen` to `doxygen-1.8.20` within `/usr/local/bin`. +You can link to a specific executable within the virtual environment. -NOTE: The makefile for the documentation framework will attempt to compile a local doxygen -binary of version 1.8.13 if a binary cannot be found in the `$PATH`. +NOTE: If a doxygen binary is not found in `$PATH`, the documentation Makefile +will attempt to clone and compile its own copy of doxygen from source. The +default release pulled in this fallback path is set by `DOXYGEN_RELEASE` in +the Makefile (currently `Release_1_8_13`); pass a different value to override. #### Testing -A lot of manual testing has been completed using the following versions: +The toolchain is known to work with doxygen versions in the 1.8.x and 1.9.x +series. Older manual testing was performed against: * 1.8.13 * 1.8.14 * 1.8.19 @@ -376,7 +389,9 @@ The [Read the Docs](https://readthedocs.org/) (RTD) site uses a virtual machine (VM) for processing documentation. The VM architecture is type x86\_64. The default version for doxygen is 1.8.13 on the RTD VM. -NOTE: Using modified python modules on RTD is possible through careful crafting of the requirements.txt file. It is impossible to replace system binaries or compile code on RTD. It is possible to ship replacement binaries that can be run from the repo. For security reasons, a binary cannot be included in the MOM6 repository. +NOTE: It is impossible to replace system binaries or compile code on RTD. +It is possible to ship replacement binaries that can be run from the repo. +For security reasons, a binary cannot be included in the MOM6 repository. #### Logfiles @@ -387,19 +402,37 @@ Most websites force download of `*.log` files. # Credits +## 2026 +The documentation toolchain was modernized to run against stock upstream +Sphinx 8.x. The four-fork chain that the build had been carrying since +2020 was reduced to: + +- A vendored copy of the Doxygen-to-Sphinx bridge under + `docs/_ext/autodoc_doxygen/`, originally derived from the `0.7.13` + release of `jr3cermak/sphinxcontrib-autodoc_doxygen`. The vendored + version is ported to the Sphinx 8 API and lives in-tree where it can + be debugged and edited like any other project source. +- A pinned commit of upstream `VACUMM/sphinx-fortran` master. +- A small monkey-patch in `conf.py` for `sphinx.util.math.wrap_displaymath` + that suppresses Sphinx's default outer wrapping when the source already + supplies its own LaTeX environment, replacing the only functional change + the previous Sphinx fork carried. +- A small monkey-patch in `conf.py` for + `sphinxfortran.fortran_domain.FortranDomain.merge_domaindata` to fix a + parallel-build bug in upstream sphinx-fortran. To be removed when + upstream merges a fix. + +The `flint` dependency (formerly used to patch Doxygen's incomplete +parsing of Fortran functions with `result()` clauses) was dropped after +verifying empirically that nothing in the build pipeline references it. + ## 2020 -The documentation pipeline was upgraded by [Rob Cermak](https://github.com/jr3cermak) and [Marshall Ward](https://github.com/marshallward). Four modified python modules are required -to process the MOM6 documentation. The versions are tagged and placed into the production version of `requirements.txt`. Development versions may be found in the respective `dev` branches. - -| Source | Modified | Version | Development | -| ------ | -------- | ------- | ----------- | -| [sphinx](https://github.com/sphinx-doc/sphinx) | [sphinx-3.2.1mom6.4](https://github.com/jr3cermak/sphinx) | B:3.2.1mom6.4 | B:dev | -| [sphinxcontrib-autodoc-doxygen](https://github.com/rmcgibbo/sphinxcontrib-autodoc_doxygen) | [sphinxcontrib-autodoc-doxygen](https://github.com/jr3cermak/sphinxcontrib-autodoc_doxygen) | T:0.7.13 | B:dev | -| [sphinx-fortran](https://github.com/VACUMM/sphinx-fortran) | [sphinx-fortran](https://github.com/jr3cermak/sphinx-fortran) | T:1.2.2 | B:dev | -| [flint](https://github.com/marshallward/flint) | [flint](https://github.com/jr3cermak/flint) | T:0.0.1 | B:dev | -| [MOM6](https://github.com/NOAA-GFDL/MOM6) | [esmg-docs](https://github.com/ESMG/MOM6/tree/esmg-docs) | [esmg-docs](https://github.com/ESMG/MOM6/tree/esmg-docs) | B:[esmg-test](https://github.com/jr3cermak/MOM6/tree/esmg-test) | - -T: tag B: branch +The documentation pipeline was upgraded by [Rob Cermak](https://github.com/jr3cermak) +and [Marshall Ward](https://github.com/marshallward). The pipeline at that time +required four modified Python modules (`sphinx`, `sphinxcontrib-autodoc_doxygen`, +`sphinx-fortran`, `flint`), all forked under the `jr3cermak` GitHub account. +That toolchain was retired during the 2026 modernization above; this entry +is retained as historical context. ## 2017 The sphinx documentation of MOM6 is made possible by modifications by [Angus Gibson](https://github.com/angus-g) to two packages, [sphinx-fortran](https://github.com/angus-g/sphinx-fortran) and [autodoc\_doxygen](https://github.com/angus-g/sphinxcontrib-autodoc_doxygen). diff --git a/docs/_ext/autodoc_doxygen/__init__.py b/docs/_ext/autodoc_doxygen/__init__.py new file mode 100644 index 0000000000..7c4a3afc80 --- /dev/null +++ b/docs/_ext/autodoc_doxygen/__init__.py @@ -0,0 +1,101 @@ +import os.path +from lxml import etree as ET +from sphinx.errors import ExtensionError + + +def set_doxygen_xml(app): + """Load all doxygen XML files from the app config variable + `app.config.doxygen_xml` which should be a path to a directory + containing doxygen xml output. If the configured path is relative, + it is resolved against `app.confdir` rather than the current working + directory -- Sphinx may have any cwd by the time builder-inited fires, + and in particular RTD runs sphinx-build from the repo root. + """ + doxygen_xml = app.config.doxygen_xml + if not os.path.isabs(doxygen_xml): + doxygen_xml = os.path.join(app.confdir, doxygen_xml) + + err = ExtensionError( + '[autodoc_doxygen] No doxygen ' + 'xml output found in doxygen_xml="%s"' % doxygen_xml) + + if not os.path.isdir(doxygen_xml): + raise err + + files = [os.path.join(doxygen_xml, f) + for f in os.listdir(doxygen_xml) + if f.lower().endswith('.xml') and not f.startswith('._')] + if len(files) == 0: + raise err + + setup.DOXYGEN_ROOT = ET.ElementTree(ET.Element('root')).getroot() + for file in files: + root = ET.parse(file).getroot() + for node in root: + setup.DOXYGEN_ROOT.append(node) + + +def get_doxygen_root(): + """Get the root element of the doxygen XML document. + """ + if not hasattr(setup, 'DOXYGEN_ROOT'): + setup.DOXYGEN_ROOT = ET.Element("root") # dummy + return setup.DOXYGEN_ROOT + + +def get_doxygen_id_index(): + """Return a dict mapping every ``@id`` in the merged doxygen tree to + the element that owns it. Built lazily on first use and memoized + on the :func:`setup` function object. + + Profiling a serial build at full MOM6 input (XML_PROGRAMLISTING=YES, + 109 MB merged tree) showed ``xmlutils.visit_ref`` burning 250 s of + self time -- 27% of total wall clock -- in a single ``findall('.//* + [@id=X]')`` call that linearly scanned the entire merged tree once + per ```` in prose. This index turns that scan into an O(1) + dict lookup. Same shape of fix as the scanNode `//` -> `.//` patch + in commit 8a217135e. + """ + if not hasattr(setup, 'DOXYGEN_ID_INDEX'): + root = get_doxygen_root() + index = {} + for el in root.iter(): + eid = el.get('id') + if eid is not None: + index[eid] = el + setup.DOXYGEN_ID_INDEX = index + return setup.DOXYGEN_ID_INDEX + + +def setup(app): + import sphinx + from .autodoc import ( + DoxygenMethodDocumenter, + DoxygenTypeDocumenter, + DoxygenModuleDocumenter, + ) + from .autosummary import DoxygenAutosummary, DoxygenAutoEnum + from .autosummary.generate import process_generate_options + from .autodoxysource import AutoDoxySourceDirective + + app.connect("builder-inited", set_doxygen_xml) + app.connect("builder-inited", process_generate_options) + + app.setup_extension('sphinx.ext.autodoc') + app.setup_extension('sphinx.ext.autosummary') + + app.add_autodocumenter(DoxygenModuleDocumenter) + app.add_autodocumenter(DoxygenMethodDocumenter) + app.add_autodocumenter(DoxygenTypeDocumenter) + + app.add_config_value("doxygen_xml", "", 'env') + # Used in autodoc_doxygen/autosummary/generate.py + app.add_config_value('autosummary_toctree', '', 'html') + + app.add_directive('autodoxysummary', DoxygenAutosummary) + app.add_directive('autodoxyenum', DoxygenAutoEnum) + app.add_directive('autodoxysource', AutoDoxySourceDirective) + + app.add_css_file('autodoxysource.css') + + return {'version': sphinx.__display_version__, 'parallel_read_safe': True} diff --git a/docs/_ext/autodoc_doxygen/autodoc.py b/docs/_ext/autodoc_doxygen/autodoc.py new file mode 100644 index 0000000000..1b62eeca47 --- /dev/null +++ b/docs/_ext/autodoc_doxygen/autodoc.py @@ -0,0 +1,610 @@ +import re + +from docutils.parsers.rst import directives +from lxml import etree as ET +from sphinx.ext.autodoc import Documenter, members_option, ALL +from sphinx.errors import ExtensionError +from sphinx.util import logging + +from . import get_doxygen_root +from .autodoxysource import get_source_link +from .xmlutils import format_xml_paragraph, flatten + +logger = logging.getLogger(__name__) + + +class DoxygenDocumenter(Documenter): + # Variables to store the names of the object being documented. modname and fullname are redundant, + # and objpath is always the empty list. This is inelegant, but we need to work with the superclass. + + fullname = None # example: "OpenMM::NonbondedForce" or "OpenMM::NonbondedForce::methodName"" + modname = None # example: "OpenMM::NonbondedForce" or "OpenMM::NonbondedForce::methodName"" + objname = None # example: "NonbondedForce" or "methodName" + objpath = [] # always the empty list + object = None # the xml node for the object + # This allows section headers in autogenerated content + titles_allowed = True + + option_spec = { + 'members': members_option, + } + + # original + #def __init__(self, directive, name, indent=u'', id=None): + # super(DoxygenDocumenter, self).__init__(directive, name, indent) + # if id is not None: + # self.parse_id(id) + # new + def __init__(self, directive, name, indent=u'', id=None, brief=False, parent=None): + super().__init__(directive, name, indent) + + self.parent = parent + if id is not None: + self.parse_id(id) + self.brief = brief + + def parse_id(self, id): + return False + + def parse_name(self): + """Determine what module to import and what attribute to document. + Returns True and sets *self.modname*, *self.objname*, *self.fullname*, + if parsing and resolving was successful. + """ + # To view the context and order in which all of these methods get called, + # See, Documenter.generate(). That's the main "entry point" that first + # calls parse_name(), follwed by import_object(), format_signature(), + # add_directive_header(), and then add_content() (which calls get_doc()) + + # methods in the superclass sometimes use '.' to join namespace/class + # names with method names, and we don't want that. + self.name = self.name.replace('.', '::') + self.fullname = self.name + self.modname = self.fullname + self.objpath = [] + + if '::' in self.name: + parts = self.name.split('::') + self.objname = parts[-1] + else: + self.objname = self.name + + return True + + def document_members(self, all_members=False): + """Generate reST for member documentation. + If *all_members* is True, do all members, else those given by + *self.options.members*. + """ + want_all = all_members or self.options.inherited_members or \ + self.options.members is ALL + # new + members = all_members + # find out which members are documentable + # removed + #members_check_module, members = self.get_object_members(want_all) + + # remove members given by exclude-members + if self.options.exclude_members: + members = [(membername, member) for (membername, member) in members + if membername not in self.options.exclude_members] + + # document non-skipped members + memberdocumenters = [] + for (mname, member, isattr) in self.filter_members(members, want_all): + classes = [cls for cls in self.env.app.registry.documenters.values() + if cls.can_document_member(member, mname, isattr, self)] + if not classes: + # don't know how to document this member + continue + + # prefer the documenter with the highest priority + classes.sort(key=lambda cls: cls.priority) + + # change + #documenter = classes[-1](self.directive, mname, indent=self.indent, id=member.get('id')) + documenter = classes[-1](self.directive, mname, indent=self.indent, + id=member.get('id'), brief=self.brief, + parent=self.object) + memberdocumenters.append((documenter, isattr)) + + for documenter, isattr in memberdocumenters: + documenter.generate( + all_members=True, real_modname=self.real_modname, + #check_module=members_check_module and not isattr) + # modified + check_module=False and not isattr) + + # reset current objects + self.env.temp_data['autodoc:module'] = None + self.env.temp_data['autodoc:class'] = None + +# Copy of DoxygenClassDocumenter -> DoxygenModuleDocumenter +class DoxygenModuleDocumenter(DoxygenDocumenter): + # change + #objtype = 'doxyclass' + #directivetype = 'class' + #domain = 'cpp' + objtype = 'doxymodule' + directivetype = 'module' + domain = 'f' + priority = 100 + + option_spec = { + 'members': members_option, + 'methods': directives.flag, + 'types': directives.flag, + } + + @classmethod + def can_document_member(cls, member, membername, isattr, parent): + # this method is only called from Documenter.document_members + # when a higher level documenter (module or namespace) is trying + # to choose the appropriate documenter for each of its lower-level + # members. Currently not implemented since we don't have a higher-level + # doumenter like a DoxygenNamespaceDocumenter. + return False + + def import_object(self): + """Import the object and set it as *self.object*. In the call sequence, this + is executed right after parse_name(), so it can use *self.fullname*, *self.objname*, + and *self.modname*. + + Returns True if successful, False if an error occurred. + """ + # change + #xpath_query = './/compoundname[text()="%s"]/..' % self.fullname + xpath_query = './compounddef/compoundname[text()="%s"]/..' % self.fullname + match = get_doxygen_root().xpath(xpath_query) + if len(match) != 1: + # change + #raise ExtensionError('[autodoc_doxygen] could not find class (fullname="%s"). I tried' + raise ExtensionError('[autodoc_doxygen] could not find module (fullname="%s"). I tried' + 'the following xpath: "%s"' % (self.fullname, xpath_query)) + + self.object = match[0] + if self.env.app.verbosity > 0: print("[debug] xpath(%s) match(%s)" % (xpath_query,match[0].items())) + return True + + # todo: typo: report upstream + #def format_signaure(self): + def format_signature(self): + if self.env.app.verbosity > 0: print("[debug] DoxygenModuleDocumenter format_signature called") + #return '' + + def format_name(self): + return self.fullname + + # change + #def get_doc(self): + # detaileddescription = self.object.find('detaileddescription') + # doc = [format_xml_paragraph(detaileddescription)] + # encoding depricated? + # called via add_content + #def get_doc(self, encoding): + def get_doc(self): + if self.brief: + description = self.object.find('briefdescription') + else: + description = self.object.find('detaileddescription') + # use the brief description if there's no content in the + # detailed description + if not len(description) and not description.text.strip(): + description = self.object.find('briefdescription') + + #if self.env.app.verbosity > 0: print("[debug] get_doc(%s)(%s)" % (self.brief, description.items())) + doc = [format_xml_paragraph(description, self.env.config.sphinx_build_mode, + verbosity=self.env.app.verbosity)] + + #if self.env.app.verbosity > 0: + # if self.name == 'mom_ice_shelf': + + if not any(len(d.strip()) for d in doc[0]): + doc.append(['', '']) + + if self.brief: + # More references need to be unique across all pages + doc.append(['`More... `_' % (self.name), '']) + + return doc + + def get_object_members(self, want_all): + # change + pass + #all_members = self.object.xpath('.//sectiondef[@kind="public-func" ' + # 'or @kind="public-static-func"]/memberdef[@kind="function"]') + # + #if want_all: + # return False, ((m.find('name').text, m) for m in all_members) + #else: + # if not self.options.members: + # return False, [] + # else: + # return False, ((m.find('name').text, m) for m in all_members + # if m.find('name').text in self.options.members) + + def filter_members(self, members, want_all): + ret = [] + for (membername, member) in members: + ret.append((membername, member, False)) + return ret + + # change function arguments + #def document_members(self, all_members=False): + def document_members(self, member_type, all_members=False): + if member_type == 'func': + all_members = self.object.xpath('./sectiondef[@kind="func" ' + 'or @kind="public-static-func"]/memberdef[@kind="function"]') + + members = [(m.find('name').text, m) for m in all_members] + + elif member_type == 'type': + classes = self.object.findall('./innerclass') + members = [] + for c in classes: + + class_obj = get_doxygen_root().find('./compounddef[@id="%s"]' % c.get('refid')) + if class_obj.get('kind') == 'type': + members.append((class_obj.find('compoundname').text, class_obj)) + + if self.env.app.verbosity > 0: print("[debug] members(%s)" % (members)) + # Calls the plain DoxygenDocumenter to generate the rst + super().document_members(all_members=members) + # change + # super(DoxygenClassDocumenter, self).document_members(all_members=all_members) + # Uncomment to view the generated rst for the class. + # print('\n'.join(self.directive.result)) + + # added functions + + def add_title(self, title, char='='): + sourcename = self.get_sourcename() + + self.add_line(u'', sourcename) + self.add_line(char * len(title), sourcename) + self.add_line(title, sourcename) + self.add_line(char * len(title), sourcename) + self.add_line(u'', sourcename) + + # This generates the autogenerated content for all the module + # functions + def generate(self, more_content=None, real_modname=None, + check_module=False, all_members=False): + if not self.parse_name(): + logger.warning("don't know which module to import for autodocumenting %r" % self.name) + return + + if not self.import_object(): + return + + self.real_modname = real_modname or self.get_real_modname() + + # we can't import anything, since we're not Python + self.analyzer = None + + if check_module and not self.check_module(): + return + + sourcename = self.get_sourcename() + + # add title + title = '%s module reference' % self.format_name() + if self.env.app.verbosity > 0: + print("[debug] add_title:%s" % (title)) + self.add_title(title, char='=') + + # module directive + self.add_line(u'.. f:module:: %s' % self.format_name(), sourcename) + self.add_line(u'', sourcename) + + # brief description + self.brief = True + self.add_content(more_content) + + # we want a brief description of types/functions here + + # detailed description + #self.add_line(u'.. _`More...`:', sourcename) + self.add_line('','') + self.add_line(u'.. _DETA%s:' % (self.name), '') + self.add_title('Detailed Description', char='-') + self.brief = False + self.add_content(None) + + if 'types' in self.options: + self.add_title('Type Documentation', char='-') + self.document_members('type', all_members) + + # member doc + if 'methods' in self.options: + self.add_title('Function/Subroutine Documentation', char='-') + self.document_members('func', all_members) + + # [source] link at the bottom of the module page + src = get_source_link(self.object) + if src: + docname, line = src + file_id = docname.rsplit('/', 1)[-1] + self.add_line(u'', sourcename) + self.add_line( + u'`[source] <../source/%s.html#L%s>`__' % (file_id, line), + sourcename) + + if self.env.app.verbosity > 0: + if self.real_modname == 'mom_eos': + # Result: self.directive.result.data + pass + +class DoxygenMethodDocumenter(DoxygenDocumenter): + objtype = 'doxymethod' + directivetype = 'function' + # See if this can be modified to work for cpp and f? + # Put a breakpoint here + #domain = 'cpp' + domain = 'f' + priority = 100 + + @classmethod + def can_document_member(cls, member, membername, isattr, parent): + if ET.iselement(member) and member.tag == 'memberdef' and member.get('kind') == 'function': + return True + return False + + # add function + def add_directive_header(self, sig): + """Add the directive header and options to the generated content.""" + domain = self.domain + # use the field, without other information (e.g. public) + # functions are badly formed out of this function + if self.env.app.verbosity > 0: + print("[debug] add_directive_header sig(%s)" % (sig)) + if sig is not None and sig.find('adv_dyn') >= 0: + pass + name = self.format_name() + sourcename = self.get_sourcename() + + # determine which directive to use from the typefield + typefield = self.get_typefield() + if 'subroutine' in typefield: + directive = 'subroutine' + else: + directive = 'function' + + if self.env.app.verbosity > 0: + print("[debug] DoxygenMethodDocumenter directive(%s) name(%s)" % (directive,name)) + if name.find('eos_domain') >= 0 or name.find('mom_state_is') >= 0: + pass + + self.add_line(u'.. %s:%s:: %s%s' % (domain, directive, name, sig), + sourcename) + + def parse_id(self, id): + # added + # try to search our parent node instead of the entire tree + parent = self.parent + if parent is None: + parent = get_doxygen_root() + + xp = './/*[@id="%s"]' % id + # original + #match = get_doxygen_root().xpath(xp) + match = parent.xpath(xp) + if len(match) > 0: + match = match[0] + self.fullname = match.find('./definition').text.split()[-1] + self.modname = self.fullname + self.objname = match.find('./name').text + self.object = match + return False + + def import_object(self): + if ET.iselement(self.object): + # self.object already set from DoxygenDocumenter.parse_name(), + # caused by passing in the `id` of the node instead of just a + # classname or method name + return True + + return False + # original + xpath_query = ('.//compoundname[text()="%s"]/../sectiondef[@kind="public-func"]' + '/memberdef[@kind="function"]/name[text()="%s"]/..') % tuple(self.fullname.rsplit('::', 1)) + match = get_doxygen_root().xpath(xpath_query) + if len(match) == 0: + raise ExtensionError('[autodoc_doxygen] could not find method (modname="%s", objname="%s"). I tried ' + 'the following xpath: "%s"' % (tuple(self.fullname.rsplit('::', 1)) + (xpath_query,))) + self.object = match[0] + + def get_doc(self): + doc = [format_xml_paragraph(self.object.find('briefdescription'), self.env.config.sphinx_build_mode, + verbosity=self.env.app.verbosity)] + # debug + if self.object.find('name').text == 'eos_domain': + pass + #detaileddescription = self.object.find('detaileddescription') + #doc = [format_xml_paragraph(detaileddescription,self.env.config.sphinx_build_mode)] + + # add parameter documentation (in detaileddescription) for main function documentation + if not self.brief: + doc += [format_xml_paragraph(self.object.find('detaileddescription'), self.env.config.sphinx_build_mode, + verbosity=self.env.app.verbosity)] + + if self.object.find('name').text == 'eos_domain': + pass + # File location + # ffile = self.object.find('location').get('file') + # add references/referencedby + references = self.object.findall('references') + for ref in references: + name = ref.text + doc.append([':callto: :f:func:`%s <%s>`' % (name, name.split('::')[-1])]) + referencedby = self.object.findall('referencedby') + for ref in referencedby: + name = ref.text + doc.append([':calledfrom: :f:func:`%s <%s>`' % (name, name.split('::')[-1])]) + + # If a document returns a string with :return: that is our signal to use flint to + # repair the documentation a bit. Doxygen cannot parse functions of this syntax: + #!> This subroutine returns a two point integer array indicating the domain of i-indices + #!! to work on in EOS calls based on information from a hor_index type + #function EOS_domain(HI, halo) result(EOSdom) + # type(hor_index_type), intent(in) :: HI !< The horizontal index structure + # integer, optional, intent(in) :: halo !< The halo size to work on; missing is equivalent to 0. + # integer, dimension(2) :: EOSdom !< The index domain that the EOS will work on, taking into account + # !! that the arrays inside the EOS routines will start at 1. + # + # ! Local variables + # integer :: halo_sz + # + # halo_sz = 0 ; if (present(halo)) halo_sz = halo + # + # EOSdom(1) = HI%isc - (HI%isd-1) - halo_sz + # EOSdom(2) = HI%iec - (HI%isd-1) + halo_sz + # + #end function EOS_domain + #if self.object.find('name').text == 'eos_domain': + + if not self.brief: + src = get_source_link(self.object) + if src: + docname, line = src + file_id = docname.rsplit('/', 1)[-1] + doc.append(['`[source] <../source/%s.html#L%s>`__' % (file_id, line)]) + + return doc + + # added function + def get_typefield(self): + return ' '.join(self.object.find('definition').text.split()[:-1]) + + def format_name(self): + #def text(el): + # if el.text is not None: + # return el.text + # return '' + + #def tail(el): + # if el.tail is not None: + # return el.tail + # return '' + + #rtype_el = self.object.find('type') + #rtype_el_ref = rtype_el.find('ref') + #if rtype_el_ref is not None: + # rtype = text(rtype_el) + text(rtype_el_ref) + tail(rtype_el_ref) + #else: + # rtype = rtype_el.text + + # replaced above with + + # we just want to get the bare part of the "type" field + # i.e. subroutine or function + typefield = self.get_typefield() + + if typefield is None: + rtype = None + elif 'function' in typefield: + # Don't include the return type in the directive name. + # sphinx-fortran's f_sig_re regex only matches + # "function name(args)" or bare "name(args)"; a return + # type prefix like "real name(args)" causes the regex + # to fail, leaving the function unregistered and + # unclickable. The f:function directive already labels + # the entry as "function". + rtype = None + else: + rtype = 'subroutine' if 'subroutine' in typefield else 'unknown' + + signame = (rtype and (rtype + ' ') or '') + self.objname + return self.format_template_name() + signame + + def format_template_name(self): + types = [e.text for e in self.object.findall('templateparamlist/param/type')] + if len(types) == 0: + return '' + return 'template <%s>\n' % ','.join(types) + + def format_signature(self): + args = self.object.find('argsstring').text + if self.env.app.verbosity > 0: + print("[debug] DoxygenMethodDocumenter format_signature called (%s)" % (args)) + if args is not None and args.find('adv_dyn')>=0: + pass + return args + + def document_members(self, all_members=False): + pass + +# add class + +class DoxygenTypeDocumenter(DoxygenDocumenter): + objtype = 'doxytype' + directivetype = 'type' + domain = 'f' + priority = 100 + + @classmethod + def can_document_member(cls, member, membername, isattr, parent): + if ET.iselement(member) and member.tag == 'compounddef' and member.get('kind') == 'type': + return True + return False + + def import_object(self): + if ET.iselement(self.object): + return True + return False + + def parse_id(self, id): + self.object = get_doxygen_root().find('./compounddef[@id="%s"]' % id) + self.fullname = self.object.find('compoundname').text + self.modname, self.objname = self.fullname.rsplit('::') + + return False + + def format_name(self): + return self.objname + + def add_directive_header(self, sig): + """Add the directive header and options to the generated content.""" + domain = self.domain + directive = 'type' + name = self.format_name() + sourcename = self.get_sourcename() + + self.add_line(u'.. %s:%s:: %s' % (domain, directive, name), + sourcename) + + def get_doc(self): + desc = [format_xml_paragraph(self.object.find('briefdescription'), + self.env.config.sphinx_build_mode, verbosity=self.env.app.verbosity)] + + for member in self.object.findall('./sectiondef/memberdef'): + name = member.find('name').text + type_el = member.find('type') + full_type = ''.join(type_el.itertext()).strip() if type_el is not None else '' + + if member.get('prot') == 'private': + if full_type: + full_type += ', private' + else: + full_type = 'private' + + field = ':typefield %s:' % name + if full_type: + field += ' ``%s``' % full_type + + brief = member.find('briefdescription/para') + if brief is not None: + field += ' ' + brief.text + + desc.append([field]) + + src = get_source_link(self.object) + if src: + docname, line = src + file_id = docname.rsplit('/', 1)[-1] + desc.append(['`[source] <../source/%s.html#L%s>`__' % (file_id, line)]) + + return desc + + def document_members(self, all_members=False): + pass diff --git a/docs/_ext/autodoc_doxygen/autodoxysource.py b/docs/_ext/autodoc_doxygen/autodoxysource.py new file mode 100644 index 0000000000..a12af14b11 --- /dev/null +++ b/docs/_ext/autodoc_doxygen/autodoxysource.py @@ -0,0 +1,231 @@ +"""autodoxysource directive: render doxygen as +syntax-highlighted source with clickable cross-references.""" + +from docutils import nodes +from docutils.parsers.rst import Directive +from sphinx import addnodes +from sphinx.util import logging + +from . import get_doxygen_root + +logger = logging.getLogger(__name__) + +# Map doxygen highlight classes to CSS classes for the source listing. +_HL_CSS = { + 'comment': 'f-hl-comment', + 'normal': 'f-hl-normal', + 'keyword': 'f-hl-keyword', + 'keywordtype': 'f-hl-keywordtype', + 'keywordflow': 'f-hl-keywordflow', + 'stringliteral': 'f-hl-stringliteral', + 'preprocessor': 'f-hl-preprocessor', +} + +# Lazily-built index: doxygen refid -> (refdomain, reftype, reftarget) +_REFID_INDEX = None + +# Index: absolute file path -> doxygen file-ID (for [source] links) +_FILE_PATH_INDEX = None + + +def _build_refid_index(): + """Walk the merged doxygen tree once, building refid -> xref info.""" + global _REFID_INDEX + _REFID_INDEX = {} + root = get_doxygen_root() + + for cd in root.findall('./compounddef'): + cid = cd.get('id') + kind = cd.get('kind') + cn = cd.find('compoundname') + if cn is None or cn.text is None: + continue + name = cn.text + + if kind == 'namespace': + _REFID_INDEX[cid] = ('f', 'mod', name) + elif kind in ('type', 'struct'): + # compoundname is "parent::typename" -> "parent/typename" + _REFID_INDEX[cid] = ('f', 'type', name.replace('::', '/')) + elif kind == 'interface': + _REFID_INDEX[cid] = ('f', 'func', name.replace('::', '/')) + # kind='file' / 'page' / 'dir' -> no xref + + # Index memberdefs inside this compound + for md in cd.iter('memberdef'): + mid = md.get('id') + mk = md.get('kind') + mn_el = md.find('name') + if mn_el is None or mn_el.text is None: + continue + qualified = name + '/' + mn_el.text + if mk == 'function': + _REFID_INDEX[mid] = ('f', 'func', qualified) + # variables / enums aren't useful xref targets here + + +def _resolve_ref(refid): + """O(1) lookup of a doxygen refid to (refdomain, reftype, reftarget).""" + global _REFID_INDEX + if _REFID_INDEX is None: + _build_refid_index() + return _REFID_INDEX.get(refid) + + +def _build_file_path_index(): + """Build filepath -> file_id index from compounddef[@kind='file'].""" + global _FILE_PATH_INDEX + _FILE_PATH_INDEX = {} + root = get_doxygen_root() + for cd in root.findall('./compounddef[@kind="file"]'): + fid = cd.get('id') + loc = cd.find('location') + if loc is not None and loc.get('file'): + _FILE_PATH_INDEX[loc.get('file')] = fid + + +def get_source_link(xml_node): + """Given a doxygen XML node (compounddef or memberdef), return + (docname, line) for a [source] link, or None if unavailable. + + *docname* is the Sphinx document name (e.g. 'api/generated/source/MOM_8F90'). + *line* is the source line number string. + """ + global _FILE_PATH_INDEX + if _FILE_PATH_INDEX is None: + _build_file_path_index() + + loc = xml_node.find('location') + if loc is None: + return None + + filepath = loc.get('file') + line = loc.get('line', '1') + if not filepath: + return None + + file_id = _FILE_PATH_INDEX.get(filepath) + if file_id is None: + return None + + docname = 'api/generated/source/' + file_id + return (docname, line) + + +class AutoDoxySourceDirective(Directive): + """.. autodoxysource:: + + Render the source listing for a doxygen file compound, with + per-line anchors, syntax highlighting, and clickable identifiers + that link to the Sphinx API documentation. + """ + required_arguments = 1 + optional_arguments = 0 + has_content = False + + def run(self): + file_id = self.arguments[0] + root = get_doxygen_root() + + compounddef = root.find('./compounddef[@id="%s"]' % file_id) + if compounddef is None: + logger.warning('autodoxysource: compounddef not found for %s', + file_id) + return [nodes.paragraph('', 'Source listing not available.')] + + programlisting = compounddef.find('.//programlisting') + if programlisting is None: + logger.warning('autodoxysource: no programlisting in %s', file_id) + return [nodes.paragraph('', 'Source listing not available.')] + + # Outer wrapper. support_smartquotes=False propagates to all + # descendants via sphinx.util.nodes.is_smartquotable, so every + # text node inside the listing is skipped by the smartquotes + # transform -- a meaningful speedup on 329 large source pages. + table = nodes.container(classes=['autodoxysource']) + table['support_smartquotes'] = False + + for codeline in programlisting.findall('codeline'): + lineno = codeline.get('lineno', '') + + # Per-line container carries the #L anchor via ``ids``; + # the previous standalone ``target`` node was dropped to + # cut a node per line. The inner ``source-code`` inline + # wrapper is kept because Sphinx's HTML writer asserts + # that ``reference`` nodes (produced when pending_xrefs + # resolve) have a ``TextElement`` parent. + line_node = nodes.container(classes=['source-line']) + if lineno: + line_node['ids'] = ['L' + lineno] + + line_node += nodes.inline(lineno, lineno, + classes=['source-lineno']) + + code_node = nodes.inline(classes=['source-code']) + for hl in codeline: + if hl.tag != 'highlight': + continue + css = _HL_CSS.get(hl.get('class', 'normal'), 'f-hl-normal') + _walk_highlight(hl, css, code_node) + line_node += code_node + + table += line_node + + return [table] + + +def _walk_highlight(hl, css_class, parent): + """Walk mixed content of a element, appending nodes to + *parent*. + + Text fragments are coalesced: consecutive characters with the same + CSS class (including ```` expansions and tail text) are + flushed as a single ``inline`` node rather than one per fragment. + Before coalescing, a typical line emitted 10-30 nodes; after, it + emits closer to 3-5. Node count drives pickling, transform walks, + and HTML writing cost linearly for the source-listing pages. + """ + buf = [] + + def flush(): + if buf: + text = ''.join(buf) + parent.append(nodes.inline(text, text, classes=[css_class])) + buf.clear() + + if hl.text: + buf.append(hl.text) + + for child in hl: + if child.tag == 'sp': + buf.append(' ') + elif child.tag == 'ref': + flush() + _emit_ref(child, css_class, parent) + elif child.text: + buf.append(child.text) + + if child.tail: + buf.append(child.tail) + + flush() + + +def _emit_ref(ref_el, css_class, parent): + """Emit a pending_xref (or plain text fallback) for a element.""" + ref_text = ref_el.text or '' + refid = ref_el.get('refid', '') + + resolved = _resolve_ref(refid) + if resolved: + refdomain, reftype, reftarget = resolved + inner = nodes.inline(ref_text, ref_text, classes=[css_class]) + xref = addnodes.pending_xref( + '', inner, + refdomain=refdomain, + reftype=reftype, + reftarget=reftarget, + ) + parent += xref + else: + parent += nodes.inline(ref_text, ref_text, classes=[css_class]) diff --git a/docs/_ext/autodoc_doxygen/autosummary/__init__.py b/docs/_ext/autodoc_doxygen/autosummary/__init__.py new file mode 100644 index 0000000000..fec98be964 --- /dev/null +++ b/docs/_ext/autodoc_doxygen/autosummary/__init__.py @@ -0,0 +1,260 @@ +import re +import operator +from functools import reduce +from itertools import count, groupby + +from docutils import nodes +from docutils.parsers.rst import directives +from docutils.statemachine import StringList, ViewList +from sphinx import addnodes +from sphinx.ext.autosummary import Autosummary, autosummary_table +from sphinx.util import logging + +from .. import get_doxygen_root +from ..autodoc import DoxygenMethodDocumenter, DoxygenModuleDocumenter +from ..xmlutils import format_xml_paragraph + +logger = logging.getLogger(__name__) + + +def import_by_name(name, env=None, prefixes=None, i=0): + """Get xml documentation for a class/method with a given name. + If there are multiple classes or methods with that name, you + can use the `i` kwarg to pick which one. + """ + if prefixes is None: + prefixes = [None] + + # angus + if env is not None: + parent = env.ref_context.get('cpp:parent_symbol') + parent_symbols = [] + while parent is not None and parent.identifier is not None: + parent_symbols.insert(0, str(parent.identifier)) + parent = parent.parent + prefixes.append('::'.join(parent_symbols)) + + # orig + if env is not None: + #if env.ref_context != None and env.ref_context != {}: + # print("[debug] parents: %s" % env.ref_context) + parents = env.ref_context.get('cpp:parent_key') + if parents is not None: + parent_symbols = [p[0].get_display_string() for p in parents] + prefixes.append('::'.join(parent_symbols)) + + # unmodified + tried = [] + for prefix in prefixes: + try: + if prefix: + prefixed_name = '::'.join([prefix, name]) + else: + prefixed_name = name + return _import_by_name(prefixed_name, i=i) + except ImportError: + tried.append(prefixed_name) + raise ImportError('no module named %s' % ' or '.join(tried)) + +def _import_by_name(name, i=0): + root = get_doxygen_root() + name = name.replace('.', '::') + + if '::' in name: + xpath_query = ( + './compounddef/compoundname[text()="%s"]/../' + 'sectiondef[@kind="func"]/memberdef[@kind="function"]/' + 'name[text()="%s"]/..') % tuple(name.rsplit('::', 1)) + m = root.xpath(xpath_query) + if len(m) > 0: + obj = m[i] + full_name = '.'.join(name.rsplit('::', 1)) + return full_name, obj, full_name, '' + + xpath_query = ('./compounddef/compoundname[text()="%s"]/..' % name) + m = root.xpath(xpath_query) + if len(m) > 0: + obj = m[i] + return (name, obj, name, '') + + raise ImportError() + +def get_documenter(obj, full_name): + if obj.tag == 'memberdef' and obj.get('kind') == 'function': + return DoxygenMethodDocumenter + elif obj.tag == 'compounddef': + return DoxygenModuleDocumenter + + raise NotImplementedError(obj.tag) + + +class DoxygenAutosummary(Autosummary): + # add + option_spec = { + 'toctree': directives.unchanged, + 'nosignatures': directives.flag, + 'template': directives.unchanged, + 'kind': directives.unchanged, + 'generate': directives.flag, + } + + def get_items(self, names): + """Try to import the given names, and return a list of + ``[(name, signature, summary_string, real_name), ...]``. + """ + env = self.state.document.settings.env + items = [] + + # Add "generate" directive + if 'generate' in self.options: + # don't generate a summary for pages + if self.options['kind'] == 'page': + return [] + + modules = get_doxygen_root().xpath('./compound[@kind="namespace"]') + names = [m.find('name').text for m in modules] + + # TODO: silently fail when there are no fortran files provided? + try: + names_and_counts = reduce(operator.add, + [tuple(zip(g, count())) for _, g in groupby(names)]) # type: List[(Str, Int)] + except: + return items + + for name, i in names_and_counts: + display_name = name + if name.startswith('~'): + name = name[1:] + display_name = name.split('::')[-1] + + try: + real_name, obj, parent, modname = import_by_name(name, env=env, i=i) + except ImportError: + logger.warning('failed to import %s' % name) + items.append((name, '', '', name)) + continue + + self.bridge.result = StringList() # initialize for each documenter + documenter = get_documenter(obj, parent)(self.bridge, real_name, + id=obj.get('id'), + brief=True, + parent=obj.find('..')) + if not documenter.parse_name(): + logger.warning('failed to parse name %s' % real_name) + items.append((display_name, '', '', real_name)) + continue + if not documenter.import_object(): + logger.warning('failed to import object %s' % real_name) + items.append((display_name, '', '', real_name)) + continue + if documenter.options.members and not documenter.check_module(): + continue + # -- Grab the signature + sig = documenter.format_signature() + + # -- Grab the summary + documenter.add_content(None) + doc = list(documenter.process_doc([self.bridge.result.data])) + + while doc and not doc[0].strip(): + doc.pop(0) + + # If there's a blank line, then we can assume the first sentence / + # paragraph has ended, so anything after shouldn't be part of the + # summary + for i, piece in enumerate(doc): + if not piece.strip(): + doc = doc[:i] + break + + # Try to find the "first sentence", which may span multiple lines + m = re.search(r"^([A-Z].*?\.)(?:\s|$)", " ".join(doc).strip()) + if m: + summary = m.group(1).strip() + elif doc: + summary = doc[0].strip() + else: + summary = '' + + items.append((display_name, sig, summary, real_name)) + + return items + + def get_tablespec(self): + table_spec = addnodes.tabular_col_spec() + table_spec['spec'] = 'll' + + table = autosummary_table('') + real_table = nodes.table('', classes=['longtable']) + table.append(real_table) + group = nodes.tgroup('', cols=2) + real_table.append(group) + group.append(nodes.colspec('', colwidth=10)) + group.append(nodes.colspec('', colwidth=90)) + body = nodes.tbody('') + group.append(body) + + def append_row(*column_texts): + row = nodes.row('') + for text in column_texts: + node = nodes.paragraph('') + vl = ViewList() + vl.append(text, '') + self.state.nested_parse(vl, 0, node) + try: + if isinstance(node[0], nodes.paragraph): + node = node[0] + except IndexError: + pass + row.append(nodes.entry('', node)) + body.append(row) + return table, table_spec, append_row + + def get_table(self, items): + """Generate a proper list of table nodes for autosummary:: directive. + + *items* is a list produced by :meth:`get_items`. + """ + table, table_spec, append_row = self.get_tablespec() + for name, sig, summary, real_name in items: + # required for cpp autolink + # original + #qualifier = 'cpp:any' + #full_name = real_name.replace('.', '::') + kind = self.options['kind'] + qualifier = 'f:' + kind + # modified + #col1 = ':%s:`%s <%s>`' % (qualifier, name, full_name) + col1 = ':%s:`%s`' % (qualifier, name) + col2 = summary + append_row(col1, col2) + + # RemovedInSphinx40Warning: Autosummary.result is deprecated + # debug: find alternative + #self.result.append(' .. rubric: sdsf', 0) + # removed + #self.bridge.result.append(' .. rubric: sdsf', 0) + # debug + return [table_spec, table] + + +class DoxygenAutoEnum(DoxygenAutosummary): + + def get_items(self, names): + env = self.state.document.settings.env + self.name = names[0] + + real_name, obj, parent, modname = import_by_name(self.name, env=env) + names = [n.text for n in obj.findall('./enumvalue/name')] + descriptions = [format_xml_paragraph(d) for d in obj.findall('./enumvalue/detaileddescription')] + return zip(names, descriptions) + + def get_table(self, items): + table, table_spec, append_row = self.get_tablespec() + for name, description in items: + col1 = ':strong:`' + name + '`' + while description and not description[0].strip(): + description.pop(0) + col2 = ' '.join(description) + append_row(col1, col2) + return [nodes.rubric('', 'Enum: %s' % self.name), table] diff --git a/docs/_ext/autodoc_doxygen/autosummary/generate.py b/docs/_ext/autodoc_doxygen/autosummary/generate.py new file mode 100644 index 0000000000..41d0453c03 --- /dev/null +++ b/docs/_ext/autodoc_doxygen/autosummary/generate.py @@ -0,0 +1,391 @@ +import codecs +import os +import re +import sys + +from jinja2 import FileSystemLoader +from jinja2.sandbox import SandboxedEnvironment +from sphinx.jinja2glue import BuiltinTemplateLoader +from sphinx.util.osutil import ensuredir + +from . import import_by_name, get_doxygen_root +from ..xmlutils import format_xml_paragraph + + +def is_type(node): + def_node = get_doxygen_root().find('./compounddef[@id="%s"]' % node.get('refid')) + return def_node.get('kind') == 'type' + +def generate_autosummary_docs(sources, output_dir=None, suffix='.rst', + #base_path=None, builder=None, template_dir=None): + # add toctree argument + base_path=None, builder=None, template_dir=None, toctree=None, + build_mode=None): + + showed_sources = list(sorted(sources)) + if len(showed_sources) > 20: + showed_sources = showed_sources[:10] + ['...'] + showed_sources[-10:] + print('[autosummary] generating autosummary for: %s' % + ', '.join(showed_sources)) + + if output_dir: + print('[autosummary] writing to %s' % output_dir) + + if base_path is not None: + sources = [os.path.join(base_path, filename) for filename in sources] + + # create our own templating environment + template_dirs = [os.path.join(os.path.dirname(__file__), 'templates')] + + if builder is not None: + # allow the user to override the templates + template_loader = BuiltinTemplateLoader() + template_loader.init(builder, dirs=template_dirs) + else: + if template_dir: + template_dirs.insert(0, template_dir) + template_loader = FileSystemLoader(template_dirs) + #template_env = SandboxedEnvironment(loader=template_loader) + # modified + template_env = SandboxedEnvironment(loader=template_loader, + trim_blocks=True, lstrip_blocks=True) + + # read + items = find_autosummary_in_files(sources) + + # keep track of new files + new_files = [] + + for name, path, template_name in sorted(set(items), key=str): + # replace + path = path or output_dir or os.path.abspath(toctree) + # debug + + # this is extra? + #if path is None: + # # The corresponding autosummary:: directive did not have + # # a :toctree: option + # print("[debug] directive did not have a :toctree: option") + # continue + + #path = output_dir or os.path.abspath(path) + if builder.app.verbosity > 0: + print("[debug] checking path: %s" % (path)) + ensuredir(path) + + try: + name, obj, parent, mod_name = import_by_name(name) + except ImportError as e: + print('WARNING [autosummary] failed to import %r: %s' % (name, e), file=sys.stderr) + continue + + fn = os.path.join(path, name + suffix).replace('::', '.') + + # skip it if it exists + if os.path.isfile(fn): + continue + + # removed? + #new_files.append(fn) + + if template_name is None: + if obj.tag == 'compounddef' and obj.get('kind') in ['namespace', 'module']: + template_name = 'doxymodule.rst' + elif obj.tag == 'compounddef' and obj.get('kind') == 'page': + template_name = 'doxypage.rst' + else: + raise NotImplementedError('No template for %s (%s %s)' % (obj.items(), obj.tag, obj.get('kind'))) + + if builder.app.verbosity > 0: + print("[debug] template:%s kind: %s obj.items():%s" % (template_name, obj.get('kind'), obj.items())) + with open(fn, 'w') as f: + template = template_env.get_template(template_name) + # The ns keys feed into the template + ns = {} + if obj.tag == 'compounddef' and obj.get('kind') == 'namespace': + ns['methods'] = [e.text for e in obj.findall('./sectiondef[@kind="func"]/memberdef[@kind="function"]/name')] + ns['types'] = [e.text for e in obj.findall('./innerclass') if is_type(e)] + ns['objtype'] = 'namespace' + elif obj.tag == 'compounddef' and obj.get('kind') == 'page': + if builder.app.verbosity > 0: + print("[debug] xml parsing for %s" % (obj.get('id'))) + ns['title'] = obj.find('title').text + ns['underline'] = len(ns['title']) * '=' + #ns['text'] = format_xml_paragraph(obj.find('detaileddescription'),build_mode) + ns = format_xml_paragraph(obj.find('detaileddescription'), build_mode, nsOrig=ns, verbosity=builder.app.verbosity) + #if obj.get('id') == 'Specifics': + else: + raise NotImplementedError(obj) + + parts = name.split('::') + mod_name, obj_name = '::'.join(parts[:-1]), parts[-1] + + ns['fullname'] = name + ns['module'] = mod_name + ns['objname'] = obj_name + ns['name'] = parts[-1] + if not('underline' in ns): + ns['underline'] = len(name) * '=' + + rendered = template.render(**ns) + f.write(rendered) + # debug: date/time caching hack + # f.write('\n..\n {}'.format(datetime.datetime.now())) + + # descend recursively to new files + if new_files: + generate_autosummary_docs(new_files, output_dir=output_dir, + suffix=suffix, base_path=base_path, builder=builder, + #template_dir=template_dir) + # add toctree argument + template_dir=template_dir, toctree=toctree) + + +def find_autosummary_in_files(filenames): + """Find out what items are documented in source/*.rst. + + See `find_autosummary_in_lines`. + """ + # todo: break when this doesn't exist + # look for modules and standalone documentation pages, but *not* the index page + # itself (which it links to from itself for some reason...) + documented = [] + for filename in filenames: + with codecs.open(filename, 'r', encoding='utf-8', errors='ignore') as f: + lines = f.read().splitlines() + documented.extend(find_autosummary_in_lines(lines, filename=filename)) + + return documented + + +def find_autosummary_in_lines(lines, module=None, filename=None): + """Find out what items appear in autosummary:: directives in the + given lines. + + Returns a list of (name, toctree, template) where *name* is a name + of an object and *toctree* the :toctree: path of the corresponding + autosummary directive (relative to the root of the file name), and + *template* the value of the :template: option. *toctree* and + *template* ``None`` if the directive does not have the + corresponding options set. + """ + + # add generate_arg_re + autosummary_re = re.compile(r'^(\s*)\.\.\s+autodoxysummary::\s*') + toctree_arg_re = re.compile(r'^\s+:toctree:\s*(.*?)\s*$') + template_arg_re = re.compile(r'^\s+:template:\s*(.*?)\s*$') + kind_arg_re = re.compile(r'^\s+:kind:\s*(.*?)\s*$') + generate_arg_re = re.compile(r'^\s+:generate:\s*$') + autosummary_item_re = re.compile(r'^\s+(~?[_a-zA-Z][a-zA-Z0-9_.:]*)\s*.*?') + + documented = [] + + toctree = None + template = None + in_autosummary = False + generate = False + base_indent = "" + + for line in lines: + if in_autosummary: + m = toctree_arg_re.match(line) + if m: + toctree = m.group(1) + if filename: + toctree = os.path.join(os.path.dirname(filename), + toctree) + continue + + m = template_arg_re.match(line) + if m: + template = m.group(1).strip() + continue + + # add + + m = generate_arg_re.match(line) + if m: + generate = True + continue + + m = kind_arg_re.match(line) + if m and generate: + kind = m.group(1).strip() + xpath = None + if kind == 'mod': + xpath = './compound[@kind="namespace"]' + elif kind == 'page': + xpath = './compound[@kind="page" and not(@refid="indexpage")]' + + if xpath is not None: + results = get_doxygen_root().xpath(xpath) + for result in results: + documented.append((result.find('name').text, toctree, template)) + + continue + + # end add + + if line.strip().startswith(':'): + continue # skip options + + m = autosummary_item_re.match(line) + if m: + name = m.group(1).strip() + if name.startswith('~'): + name = name[1:] + documented.append((name, toctree, template)) + continue + + if not line.strip() or line.startswith(base_indent + " "): + continue + + in_autosummary = False + + m = autosummary_re.match(line) + if m: + in_autosummary = True + base_indent = m.group(1) + toctree = None + template = None + # add + generate = False + continue + + return documented + + +def _generate_source_stubs(app): + """Generate one :orphan: stub per doxygen file compound under + api/generated/source/, each invoking ``.. autodoxysource::``.""" + root = get_doxygen_root() + source_dir = os.path.join(app.srcdir, 'api', 'generated', 'source') + ensuredir(source_dir) + + template_dirs = [os.path.join(os.path.dirname(__file__), 'templates')] + template_loader = FileSystemLoader(template_dirs) + template_env = SandboxedEnvironment(loader=template_loader, + trim_blocks=True, lstrip_blocks=True) + template = template_env.get_template('doxysource.rst') + + files = root.findall('./compounddef[@kind="file"]') + count = 0 + for cd in files: + file_id = cd.get('id') + if file_id is None: + continue + # Only generate if there is a programlisting + if cd.find('.//programlisting') is None: + continue + + fn = os.path.join(source_dir, file_id + '.rst') + if os.path.isfile(fn): + continue + + # Title from the location filename, or fall back to file_id + loc = cd.find('location') + if loc is not None and loc.get('file'): + title = os.path.basename(loc.get('file')) + else: + title = file_id + + rendered = template.render( + title=title, + underline='=' * len(title), + file_id=file_id, + ) + with open(fn, 'w') as f: + f.write(rendered) + count += 1 + + if count: + print('[autodoxysource] generated %d source stubs in %s' % + (count, source_dir)) + + +def _generate_function_index(app): + """Generate api/functions.rst listing every function/subroutine + across all namespace compounds, with cross-reference links to + the function's entry on its module page.""" + root = get_doxygen_root() + fn = os.path.join(app.srcdir, 'api', 'functions.rst') + if os.path.isfile(fn): + return + + entries = [] + for cd in root.findall('./compounddef[@kind="namespace"]'): + modname = cd.find('compoundname') + if modname is None or modname.text is None: + continue + mod = modname.text + for md in cd.findall('.//sectiondef[@kind="func"]/memberdef[@kind="function"]'): + name_el = md.find('name') + if name_el is None or name_el.text is None: + continue + name = name_el.text + brief_el = md.find('briefdescription/para') + brief = '' + if brief_el is not None and brief_el.text: + brief = brief_el.text.strip().replace('|', r'\|') + qualified = '%s/%s' % (mod, name) + entries.append((name, mod, qualified, brief)) + + entries.sort(key=lambda e: e[0].lower()) + + lines = [ + '.. _Functions:', + '', + '=========', + 'Functions', + '=========', + '', + '.. list-table::', + ' :widths: 30 30 40', + ' :header-rows: 1', + '', + ' * - Name', + ' - Module', + ' - Description', + ] + for name, mod, qualified, brief in entries: + lines.append(' * - :f:func:`%s <%s>`' % (name, qualified)) + lines.append(' - :f:mod:`%s`' % mod) + lines.append(' - %s' % brief) + + lines.append('') + + with open(fn, 'w') as f: + f.write('\n'.join(lines)) + print('[autodoxysource] generated function index with %d entries at %s' % + (len(entries), fn)) + + +def process_generate_options(app): + genfiles = app.config.autosummary_generate + # add + toctree = app.config.autosummary_toctree + # This is important to handle \htmlonly and \latexonly directives + sphinx_build_mode = app.config.sphinx_build_mode + + if genfiles and not hasattr(genfiles, '__len__'): + env = app.builder.env + genfiles = [os.fspath(env.doc2path(x, base=None)) for x in env.found_docs + if os.path.isfile(env.doc2path(x))] + + if not genfiles: + return + + ext = list(app.config.source_suffix)[0] + genfiles = [genfile + (not genfile.endswith(ext) and ext or '') + for genfile in genfiles] + + generate_autosummary_docs(genfiles, builder=app.builder, + # add toctree argument + # suffix=ext, base_path=app.srcdir) + suffix=ext, base_path=app.srcdir, toctree=toctree, build_mode=sphinx_build_mode) + + # Generate source browser stubs + _generate_source_stubs(app) + + # Generate function index + _generate_function_index(app) diff --git a/docs/_ext/autodoc_doxygen/autosummary/templates/doxymodule.rst b/docs/_ext/autodoc_doxygen/autosummary/templates/doxymodule.rst new file mode 100644 index 0000000000..2c89736453 --- /dev/null +++ b/docs/_ext/autodoc_doxygen/autosummary/templates/doxymodule.rst @@ -0,0 +1,34 @@ +.. autodoxymodule:: {{ fullname }} + :members: + {% if methods %} + :methods: + {% endif %} + {% if types %} + :types: + {% endif %} + + {% if types %} + ---------- + Data Types + ---------- + + .. autodoxysummary:: + :kind: type + + {% for item in types %} + ~{{ item }} + {% endfor %} + {% endif %} + + {% if methods %} + --------------------- + Functions/Subroutines + --------------------- + + .. autodoxysummary:: + :kind: func + + {% for item in methods %} + ~{{ fullname }}::{{ item }} + {% endfor %} + {% endif %} diff --git a/docs/_ext/autodoc_doxygen/autosummary/templates/doxypage.rst b/docs/_ext/autodoc_doxygen/autosummary/templates/doxypage.rst new file mode 100644 index 0000000000..96320dc499 --- /dev/null +++ b/docs/_ext/autodoc_doxygen/autosummary/templates/doxypage.rst @@ -0,0 +1,21 @@ +.. _{{ name }}: +{# comment +When the name is provided, we get "(INFO/1) Duplicate implicit target name:" +without this, we get undefined reference. This needs to be fixed later. +#} + +{{ underline }} +{{ title }} +{{ underline }} + +{% for line in text %} +{{ line }} +{% endfor %} +{% if footnotes %} + +.. rubric:: Footnotes + +{% for line in footnotes %} +.. [#] {{ line }} +{% endfor %} +{% endif %} diff --git a/docs/_ext/autodoc_doxygen/autosummary/templates/doxysource.rst b/docs/_ext/autodoc_doxygen/autosummary/templates/doxysource.rst new file mode 100644 index 0000000000..cef1c4cab7 --- /dev/null +++ b/docs/_ext/autodoc_doxygen/autosummary/templates/doxysource.rst @@ -0,0 +1,6 @@ +:orphan: + +{{ title }} +{{ underline }} + +.. autodoxysource:: {{ file_id }} diff --git a/docs/_ext/autodoc_doxygen/xmlutils.py b/docs/_ext/autodoc_doxygen/xmlutils.py new file mode 100644 index 0000000000..98459f5da9 --- /dev/null +++ b/docs/_ext/autodoc_doxygen/xmlutils.py @@ -0,0 +1,997 @@ +import re + +from . import get_doxygen_root, get_doxygen_id_index + + +def flatten(xmlnode): + # this.textchild0.textchild0.tail... + + t = '' + + # text of this node + if xmlnode.text is not None: + t += xmlnode.text + + # process all children recursively + for n in xmlnode: + t += ' ' + t += flatten(n) + if n.tail is not None: + t += ' ' + t += n.tail + + return t + +def format_xml_paragraph(xmlnode,build_mode,nsOrig=None,verbosity=0): + """Format an Doxygen XML segment (principally a detaileddescription) + as a paragraph for inclusion in the rst document + + Parameters + ---------- + xmlnode + + Returns + ------- + lines + A list of lines. + """ + # Here we are operating on the entire document for the template + # This helps support \footnotes{} + if nsOrig is not None: + xmlParagraphFormatter = _DoxygenXmlParagraphFormatter() + xmlParagraphFormatter.setNS(nsOrig) + xmlParagraphFormatter.setVerbosity(verbosity) + xmlParagraphFormatter.generic_visit(xmlnode,build_mode=build_mode) + xmlParagraphFormatter.ns['text'] = [l.rstrip() for l in xmlParagraphFormatter.lines] + return xmlParagraphFormatter.ns + else: + # Return processing for typically ns['text'] only + # Expand to allow setting of options + xmlParagraphFormatter = _DoxygenXmlParagraphFormatter() + xmlParagraphFormatter.setVerbosity(verbosity) + xmlParagraphFormatter.generic_visit(xmlnode,build_mode=build_mode) + return [l.rstrip() for l in xmlParagraphFormatter.lines] + +class _DoxygenXmlParagraphFormatter(object): + # This class follows the model of the stdlib's ast.NodeVisitor for tree traversal + # where you dispatch on the element type to a different method for each node + # during the traverse. + + # It's supposed to handle paragraphs, references, preformatted text (code blocks), and lists. + + def __init__(self): + self.ns = {} + self.lines = [''] + self.continue_line = False + # We need to track specified math labels and place them prior to the ".. math::" blocks + self.math_labels = [] + self.build_mode = None + self.verbosity = 0 + self.indent = -1 + self.options = [] + + # new + def setNS(self, ns): + self.ns = ns + + def setVerbosity(self, verbosity): + self.verbosity = verbosity + if self.verbosity > 0: print("[debug] verbosity = %s" % (self.verbosity)) + + def visit_latexonly(self, node): + if not(self.build_mode in ('latexpdf','latex')): + return + + text = node.text + if text == None: + return + + # Convert \\ref{tag} to :ref:` ` and the sphinx latex processor + # converts it to a proper label reference. + ref_match = re.search('\\\\ref{(.*?)}', text) + if ref_match is not None: + tag_string = ref_match.groups()[0] + #val = [' :ref:`%s`' % tag_string] + val = [':latex:`\\ref{%s}`' % tag_string] + #self.lines[-1] += ''.join(val) + self.concat_text(val[0]) + return + + # If we have then skip DoxyImage provided material + if 'skipDoxyImage' in self.options: + if text.find('DoxyImage') >= 0: + return + + # At this point, just pass everything through to latex + self.concat_text(':latex:`%s`' % (text)) + + return + + # new + # Newer versions of doxygen utilize tag in XML + # Doxygen 1.8.13 leaves all this in see: para_eqref + def visit_htmlonly(self, node): + if self.build_mode != 'html': + return + + text = node.text + if text == None: + return + + # Check for \eqref2{tag,txt} and convert to :ref:`tag`_ + eqref_match = re.search('\\\\eqref2{(.*?)}', text) + if eqref_match is not None: + tag_string = eqref_match.groups()[0] + if tag_string.find(',') >= 0: + fc = tag_string.find(',') + val = [':math:numref:`%s` - %s' % (tag_string[0:fc],tag_string[fc+1:])] + else: + val = [':math:numref:`%s`' % tag_string] + #self.lines[-1] += ''.join(val) + self.concat_text(val[0]) + return + + # This supports \footnotes{} + if text.find('title=') >= 0: + text = text.replace('\n',' ') + title_match = re.search('title="(.*)"', text) + if title_match: + title_string = title_match.groups()[0] + # Recover \cite that have been converted to @cite to :cite:`%s` + if title_string.find('@cite') >= 0: + citeCommand = '@cite ([\w\-\_]+)' + m = re.search(citeCommand, title_string) + while m: + replStr = title_string[m.start():m.end()] + newStr = ':cite:`%s`' % (m.groups()[0]) + title_string = title_string.replace(replStr, newStr) + m = re.search(citeCommand, title_string) + if 'footnotes' in self.ns: + self.ns['footnotes'].append(title_string) + else: + self.ns['footnotes'] = [title_string] + + val = ["[#]_"] + #self.lines[-1] += ''.join(val) + self.concat_text(val[0]) + return + + # Check for \eqref{ replace with :ref:`tag`_ + # Post processing of equations will place a link into the HTML + eqref_match = re.search('\\\\eqref{(.*?)}', text) + if eqref_match is not None: + tag_string = eqref_match.groups()[0] + val = [':math:numref:`%s`' % tag_string] + #self.lines[-1] += ''.join(val) + self.concat_text(val[0]) + return + + # undefined + if self.verbosity > 0: + print("[debug] WARNING: Uncaptured htmlonly string (%s)" % text) + + # new + # reStructured text only permits one label per math:: block + def emit_math_labels(self): + if len(self.math_labels) == 0: + return + + if self.verbosity > 0: print("[debug] inserting math labels") + + math_block_idx = -1 + for idx in range(len(self.lines)-1,0,-1): + if self.lines[idx].startswith('.. math::'): + math_block_idx = idx + break + + # Add new label right after the math:: block + if math_block_idx >=0: + new_lines = self.lines[0:math_block_idx+1] + new_label = " :label: %s" % (self.math_labels[0]) + new_lines.append(new_label) + #new_lines.append('') + self.blank_line() + new_lines = new_lines + self.lines[math_block_idx+1:] + self.lines = new_lines + + self.math_labels = [] + + # Add appropriate implicit labels from anchors + def visit_anchor(self, node): + if self.verbosity > 0: + print("[debug] anchor id(%s)" % (node.get('id'))) + citeID = node.get('id') + if citeID.find('_1CITE') == 0: + citeID = "citeref_%s" % (citeID) + implicitLink = '.. _%s:' % (citeID) + self.lines.append(implicitLink) + #self.lines.append('') + self.blank_line() + + # Original + def visit(self, node): + method = 'visit_' + node.tag + if self.verbosity > 0: print("[debug] method=%s" % (method)) + if len(self.math_labels) > 0 and node.tag != 'formula': + self.emit_math_labels() + visitor = getattr(self, method, self.generic_visit) + return visitor(node) + + def generic_visit(self, node, build_mode=None): + if build_mode: + if self.verbosity > 2: print("[debug] Setting build mode: %s" % (build_mode)) + self.build_mode = build_mode + # Perform a scan for htmlonly or latexonly to prevent double processing of + # references + if not('scanned' in self.options): + self.options.append('scanned') + self.scanNode(node) + for child in node.getchildren(): + self.visit(child) + return self + + # Scan the node and set appropriate options + def scanNode(self, node): + # NOTE: these XPath expressions must use './/' rather than '//'. + # In XPath, '//foo' is an abbreviation for /descendant-or-self::node()/foo + # starting from the *document root*, not from `node`. Because our + # autodoc_doxygen extension concatenates every doxygen XML file into a + # single merged tree (see set_doxygen_xml), every `node` passed here is + # a small subtree (e.g. a single ) whose owner + # document is the *entire* MOM6 doxygen output. Using '//' here + # therefore scans the whole merged tree on every call, which made + # scanNode the dominant cost of `make html` -- 75% of single-threaded + # build time at full MOM6 input scale, quadratic in the tree size. + # Using './/' scans only descendants of the actual node, which is what + # was intended and makes each call O(local subtree size). + xp = node.xpath('.//latexonly') + if len(xp) > 0: + self.options.append('latexonly') + xp = node.xpath('.//htmlonly') + if len(xp) > 0: + self.options.append('htmlonly') + + if 'latexonly' in self.options: + xp = node.xpath('.//image[@type="latex"]') + if len(xp) > 0: + self.options.append('skipDoxyImage') + + def visit_ref(self, node): + refid = node.get('refid') + name_node = None + ream_name = None + kind = None + + # O(1) lookup via the lazily-built id -> element index. + # The previous findall('.//*[@id=X]') on the merged tree was the + # single largest cost in `make html` under XML_PROGRAMLISTING=YES + # -- see docs/REMAINING_TASKS.md / profile notes. + hit = get_doxygen_id_index().get(refid) + if self.verbosity > 0: print("[debug] refid(%s) kindref(%s) ref(%s)" % + (refid, node.get('kindref'), hit)) + if hit is not None: + ref = hit + kind = ref.get('kind') + if self.verbosity > 0: print("[debug] ref(%s)" % ref.items()) + if ref.tag == 'memberdef': + parent = ref.xpath('./ancestor::compounddef/compoundname')[0].text + name = ref.find('./name').text + real_name = parent + '::' + name + elif ref.tag in ('compounddef', 'enumvalue'): + if kind == 'page': + # :ref: works, but requires an explicit tag placed at the top of pages + # that generates an INFO message. FIX LATER. + val = [':ref:`%s`' % ref.get('id')] + #self.lines[-1] += ''.join(val) + self.concat_text(val[0]) + return + name_node = ref.find('./name') + real_name = name_node.text if name_node is not None else '' + elif ref.tag in ('anchor','sect1','sect2','sect3','sect4'): + # If _1CITEREF_ this is a doxygen processed citation + if refid.find('_1CITEREF_') >= 0: + citation = refid[18:] + val = [':cite:`%s`' % (citation)] + #self.lines[-1] += ''.join(val) + self.concat_text(val[0]) + return + # Capture sectional links + + # Treat the rest of these as general links + if refid.find('_1') >= 0: + reftext = node.text + reftext = reftext.strip() + refid2 = refid[refid.find('_1')+2:] + if reftext != '' and reftext != refid2: + if self.verbosity > 0: print("[debug] refid2(%s) reftext(%s)" % (refid2,reftext)) + val = [':ref:`%s<%s>`' % (reftext,refid)] + else: + if self.verbosity > 0: print("[debug] refid(%s)" % (refid)) + val = [':ref:`%s`' % refid] + #self.lines[-1] += ''.join(val) + self.concat_text(val[0]) + return + else: + print('[error] Unimplemented anchor tag: %s' % (ref.tag)) + raise NotImplementedError(ref.tag) + else: + print('[error] Unimplemented tag: %s' % (ref.tag)) + raise NotImplementedError(ref.tag) + else: + real_name = None + + + # Older doxygen support 1.8.13 for citation references + if node.get('kindref') == 'member' and refid.find('_1CITEREF_') >= 0: + citation = refid[18:] + val = [':cite:`%s`' % (citation)] + #self.lines[-1] += ''.join(val) + self.concat_text(val[0]) + return + + # if kind='file' treat as file references + if kind == 'file': + # for now treat these as text + # TODO: references to code + val = ['``%s``' % node.text] + #self.lines[-1] += ''.join(val) + self.concat_text(val[0]) + return + + #debug + code_type = 'f' + if code_type == 'f': + val = [':%s:func:`%s' % (code_type, node.text)] + else: + val = [':%s:any:`' % code_type, node.text] + if real_name: + val.extend((' <%s>`' % (real_name))) + else: + val.append('`') + if node.tail is not None: + val.append(node.tail) + + if self.verbosity > 0: print("[debug] kind(%s) real_name(%s) node_name(%s)" % + (kind, real_name, name_node)) + #self.lines[-1] += ''.join(val) + self.concat_text(''.join(val)) + + # add visit_ulink + def visit_ulink(self, node): + self.para_text('`%s <%s>`_' % (node.text, node.get('url'))) + + # add visit_emphasis + def visit_emphasis(self, node): + self.para_text('*%s*' % node.text) + + # add role_text + def role_text(self, node, role): + # Is this even used? + if self.verbosity > 0: + print("[debug] role_text") + # XXX we should probably escape preceeding whitespace... + # but there's no backward equivalent of `tail` + text = ' :%s:`%s`' % (role, node.text) + + if node.tail is not None and not node.tail.startswith(' '): + # escape following whitespace + text += '\\' + + text += ' ' # interpretered text needs surrounding whitespace + self.para_text(text) + + # add visit_image + def visit_image(self, node): + + # Filter activity based on build type and type of image + image_type = node.get('type') + if image_type == 'html' and self.build_mode != 'html': + return + if image_type == 'latex' and not(self.build_mode in ('latexpdf','latex')): + return + + if self.verbosity > 0: + print("[debug] image type(%s) mode(%s)" % (image_type, self.build_mode)) + + # node.text is None for an empty element (no caption text); + # treat that the same as an empty caption and emit `.. image::` rather + # than `.. figure::`. The fork's original code crashed with + # AttributeError on these. Doxygen produces empty elements for + # cases like an image referenced from a `\image` command with no caption. + if node.text and node.text.strip(): + type = 'figure' + else: + type = 'image' + + self.lines.append('.. %s:: /images/%s' % (type, node.get('name'))) + + if type in 'figure': + # NOTE: Escaped math equations do not play nicely with "literal strings" in python! + + caption = node.text + + # Detect simple math commands and replace them with sphinx :math: directives + mathCommand = '\\\\f\$(.*?)\\\\f\$' + m = re.search(mathCommand, caption) + while m: + replStr = caption[m.start():m.end()] + newStr = ':math:`%s`' % (m.groups()[0]) + caption = caption.replace(replStr, newStr) + m = re.search(mathCommand, caption) + + # Only html needs to be double escaped + if image_type == 'html': + caption = node.text.replace('\\','\\\\') + + #if caption.find('Phi') >= 0: + + # Search for $[math]$ and convert to \([math]\) for html + # Use :math: for latex + mathCommand = '\$(.*?)\$' + m = re.search(mathCommand, caption) + while m: + replStr = caption[m.start():m.end()] + if image_type == 'html': + newStr = '\\\\(%s\\\\)' % (m.groups()[0]) + else: + newStr = ':math:`%s`' % (m.groups()[0]) + caption = caption.replace(replStr, newStr) + m = re.search(mathCommand, caption) + + # For html, scan for \\f and remove that too + if image_type == 'html': + caption = caption.replace('\\f','') + + if self.verbosity > 0: + # For math we have to double the number of escapes so we pass an + # escape from RST to HTML. + print("[debug] caption text(%s)" % (caption)) + self.lines.extend(['', " %s" % (caption), '']) + + # add visit_superscript + def visit_superscript(self, node): + self.role_text(node, 'superscript') + + # add visit_subscript + def visit_subscript(self, node): + self.role_text(node, 'subscript') + + # add visit_sup + # Support for doxygen 1.8.13 as it passes everything to + # Support for doxygen \footnote{} + def visit_sup(self, node): + + # Skip if we detect htmlonly or latexonly + if self.para_ignore(): + return + + title_string = node.get('title') + if title_string: + citeCommand = '@cite ([\w\-\_]+)' + m = re.search(citeCommand, title_string) + while m: + replStr = title_string[m.start():m.end()] + newStr = ':cite:`%s`' % (m.groups()[0]) + title_string = title_string.replace(replStr, newStr) + m = re.search(citeCommand, title_string) + + if 'footnotes' in self.ns: + self.ns['footnotes'].append(title_string) + else: + self.ns['footnotes'] = [title_string] + + val = ["[#]_"] + #self.lines[-1] += ''.join(val) + self.concat_text(val[0]) + + # Ignore duplicates provided by xmlonly if we detect latexonly or htmlonly + def para_ignore(self): + + if 'latexonly' in self.options or 'htmlonly' in self.options: + return True + return False + + # add replace any references of \eqref, \eqref2, \eqref4 + # Doxygen 1.8.13 + # html: use eqref2; remove eqref4 + # latex: use eqref4; remove eqref2 + # with appropriate replacements + # Remove duplicates here if latexonly or htmlonly is detected + def para_eqref(self, text): + + chg = True + while text.find('\\\\eqref2') >= 0 and chg: + chg = False + m = re.search('\\\\eqref2{(.*?)}', text) + if m: + ref = m.groups()[0] + fullRef = '\\\\eqref2{%s}' % (ref) + if ref.find(',') >= 0: + i = ref.find(',') + sphinxRef = ':math:numref:`%s` - %s' % (ref[0:i],ref[i+1:]) + if self.build_mode in ('latexpdf','latex'): + sphinxRef = '' + if self.para_ignore(): + sphinxRef = '' + text = text.replace(fullRef, sphinxRef) + chg = True + + chg = True + while text.find('\\\\eqref') >= 0 and chg: + chg = False + m = re.search('\\\\eqref{(.*?)}', text) + if m: + ref = m.groups()[0] + fullRef = '\\\\eqref{%s}' % (ref) + if self.build_mode in ('latexpdf','latex'): + sphinxRef = ':latex:`\\ref{%s}`' % ref + else: + sphinxRef = ':math:numref:`%s`' % (ref) + if self.para_ignore(): + sphinxRef = '' + text = text.replace(fullRef, sphinxRef) + chg = True + + chg = True + while text.find('\\\\eqref4') >= 0 and chg: + chg = False + m = re.search('\\\\eqref4{(.*?)}', text) + if m: + ref = m.groups()[0] + fullRef = '\\\\eqref4{%s}' % (ref) + sphinxRef = ':latex:`\\ref{%s}`' % (ref) + if self.build_mode in ('html'): + sphinxRef = '' + if self.para_ignore(): + sphinxRef = '' + text = text.replace(fullRef, sphinxRef) + chg = True + + return text + + # Assistant for ensuring there is blank lines between directives + # It makes sure we do not overly add blank lines + def blank_line(self): + if len(self.lines) == 0: + return + + if self.lines[-1] == '': + return + + self.lines.append('') + + # Assistant for putting sentences together + def concat_text(self, text): + if len(self.lines) == 0: + self.lines.append(text) + return + + lastLine = self.lines[-1] + + if len(lastLine) == 0: + self.lines[-1] = text + return + + lastChar = lastLine[-1] + newText = text + if len(newText) == 0: + return + + firstChar = newText[0] + + # Emphasis + if lastChar == "*" or firstChar == "*": + newText = " %s" % (newText) + firstChar = " " + + # whitespace after :cite:`tag` + if lastChar == '`': + if (firstChar >= 'a' and firstChar <= 'z') or (firstChar >= 'A' and firstChar <= 'Z') or firstChar in ['(','[','{']: + newText = " %s" % (newText) + firstChar = " " + + # whitespace before :commands: + if firstChar == ':': + if (lastChar >= 'a' and lastChar <= 'z') or (lastChar >= 'A' and lastChar <= 'Z') or lastChar in [',','.','=']: + newText = " %s" % (newText) + firstChar = " " + + # Footnotes and any items that end with _ + if newText == '[#]_': + newText = " %s" % (newText) + if lastChar == '_': + if len(lastLine) > 3: + if lastLine[-4:] == "[#]_" and firstChar != '.': + newText = " %s" % (newText) + firstChar = " " + else: + newText = " %s" % (newText) + + # Inline text check for space before (``) + if len(newText) >= 2: + if newText[0:2] == "``" and lastChar != ' ': + newText = " %s" % (newText) + firstChar = " " + + self.lines[-1] += newText + return + + # add para_text parser + # Doxygen 1.8.13 support for \eqref \eqref2 + def para_text(self, text): + + if text is not None: + if text.find('Some time later') >= 0: + a = 0 + + if text.find('eqref') >= 0: + text = self.para_eqref(text) + if self.continue_line: + if len(self.lines) >= 1: + # If we are in a continue_line situation but already + # have a linefeed, do an append instead + if self.lines[-1] == '': + self.lines.append(text) + return + self.concat_text(text) + else: + self.lines.append(text) + + def visit_para(self, node): + + self.para_text(node.text) + + # visit children and append tail + for child in node.getchildren(): + self.visit(child) + self.continue_line = True + + if child.tail is not None: + self.para_text(child.tail.lstrip()) + + # replaced + #if node.text is not None: + # if self.continue_line: + # self.lines[-1] += node.text + # else: + # self.lines.append(node.text) + #self.generic_visit(node) + + self.continue_line = False + #self.lines.append('') + self.blank_line() + + # add visit_formula + def visit_formula(self, node): + text = node.text + + # Remove the faked link for pdf version + if self.build_mode in ('latexpdf','latex'): + label_match = re.search(' \\\\label{(html:.*?)}.*?\\\\\\\\', text) + if label_match: + replace_string = label_match.group() + text = text.replace(replace_string,'') + + # detect inline or block math + if text.startswith('\\[') or not text.startswith('$'): + if text.startswith('\\['): + text = text[2:-2] + + # if we are emitting a math block and we have + # pending math labels, go back and emit those + # first. + if len(self.math_labels) > 0: + self.emit_math_labels() + + self.blank_line() + if '\n' in text: + self.lines.append('.. math::') + self.lines.append('') + for mathline in text.split('\n'): + self.lines.append(' ' + mathline) + else: + self.lines.append('.. math:: ' + text) + self.blank_line() + # Math blocks require an explicit blank line as well? + #self.lines.append('') + self.continue_line = False + else: + inline = ':math:`' + node.text.strip()[1:-1].strip() + '`' + if self.continue_line: + #self.lines[-1] += inline + self.concat_text(inline) + else: + self.lines.append(inline) + + self.continue_line = True + + # detect \label{html:tag} blocks + if text.find('\\label') >= 0: + # If we have a big block of equations, supply one label + label_matches = re.findall('\\\label{html:(.*?)?}',text) + if len(label_matches) > 0: + [self.math_labels.append(i) for i in label_matches] + else: + label_matches = re.findall('\\\label{(.*?)?}',text) + if len(label_matches) > 0: + [self.math_labels.append(i) for i in label_matches] + if self.verbosity > 0: + # For math we have to double the number of escapes so we pass an + # escape from RST to HTML. + print("[debug] math_labels(%s)" % (label_matches)) + + def visit_parametername(self, node): + if 'direction' in node.attrib: + direction = '[%s] ' % node.get('direction') + else: + direction = '' + + param_name = node.text or '' + + # Look up the parameter's Fortran type from the parent + # memberdef's elements. The inside + # only carries names and descriptions; + # the types live on the siblings of . + param_type = '' + memberdefs = node.xpath('./ancestor::memberdef') + if memberdefs: + for p in memberdefs[0].findall('param'): + defname = p.find('defname') + if defname is not None and defname.text == param_name: + type_el = p.find('type') + if type_el is not None: + param_type = ''.join(type_el.itertext()).strip() + break + + # Prepend the type as literal text in the description rather + # than using :param type name: (sphinx-fortran's regex can't + # handle commas in the type) or :type name: (sphinx-fortran's + # xref resolver crashes on % in dimension expressions). + if param_type: + self.lines.append(':param %s: ``%s`` %s' % (param_name, param_type, direction)) + else: + self.lines.append(':param %s: %s' % (param_name, direction)) + self.continue_line = True + + def visit_parameterlist(self, node): + lines = [l for l in type(self)().generic_visit(node).lines if l != ''] + # replaced + #self.lines.extend([':parameters:', ''] + ['* %s' % l for l in lines] + ['']) + self.lines.extend([''] + lines + ['']) + + # TODO: Doxygen generates a simplesect for functions with + # a specified return argument. For now, we leave as + # :returns undefined: + # marker so we can fix up the document using flint. + # Supports doxygen /sa or /see command + def visit_simplesect(self, node): + if self.verbosity > 0: + print("[debug] simplesect kind(%s)" % (node.get('kind'))) + + # Do nothing for \note for now + + # fortran function handling + if node.get('kind') == 'return': + self.lines.append(':returns undefined: ') + self.continue_line = True + self.generic_visit(node) + + # Add bold text psudo section for \see, \sa roughly acts like doxygen + if node.get('kind') in ('see', 'sa'): + see_also_label = "See also" + #self.lines.append('') + self.blank_line() + self.lines.append('**%s**' % (see_also_label)) + #self.lines.append('') + self.blank_line() + #self.lines.append('') + self.generic_visit(node) + # add + + def visit_sect(self, node, char): + """Generic visit section""" + title_node = node.find('title') + if title_node is not None: + title = title_node.text + # Filter html data (possibly if we see a <, / and >) + if self.verbosity > 0: + print("[debug] visit_sect id(%s) title(%s)" % (node.get('id'),title)) + if title.find('<') >=0 and title.find('>') >=0 and title.find('/') >=0: + html_match = False + # Filter => `` + if title.find("") >= 0: + title = title.replace('','``') + title = title.replace('','`` ') + html_match = True + if not(html_match) and self.verbosity > 0: + print("[debug] unmatched html (%s)" % (title)) + # Add a implicit lable for the sections + implicitLink = '.. _%s:' % (node.get('id')) + self.lines.append(implicitLink) + #self.lines.append('') + self.blank_line() + self.lines.append(title) + self.lines.append(len(title) * char) + #self.lines.append('') + self.blank_line() + + self.generic_visit(node) + + def visit_sect1(self, node): + self.visit_sect(node, '=') + + def visit_sect2(self, node): + self.visit_sect(node, '-') + + def visit_sect3(self, node): + self.visit_sect(node, '^') + + def visit_sect4(self, node): + self.visit_sect(node, '"') + + # add end + + # allows us to handle nested ordered lists + def visit_orderedlist(self, node): + self.indent = self.indent + 1 + self.generic_visit(node) + #self.lines.append('') + self.blank_line() + self.indent = self.indent - 1 + + # allows us to handle nested itemized lists + def visit_itemizedlist(self, node): + self.indent = self.indent + 1 + self.generic_visit(node) + #self.lines.append('') + self.blank_line() + self.indent = self.indent - 1 + + # Source of citation and numbering + def visit_listitem(self, node): + #char = '*' if node.getparent().tag == 'itemizedlist' else '#.' + if node.getparent().tag == 'itemizedlist': + #self.lines.append('') + char = '*' + else: + char = '#.' + if self.verbosity > 1: print("[debug] listitem indent = %s" % (self.indent)) + self.lines.append(' '*(self.indent*2) + char + ' ') + # replaced + #self.lines.append(' - ') + self.continue_line = True + # recursion + self.generic_visit(node) + + # add + def preformat_text(self, lines): + self.lines.extend(('::', '')) + self.lines.extend([' ' + l for l in lines]) + #self.lines.append('') + self.blank_line() + + def visit_preformatted(self, node): + segment = [node.text if node.text is not None else ''] + for n in node.getchildren(): + segment.append(n.text) + if n.tail is not None: + segment.append(n.tail) + + lines = ''.join(segment).split('\n') + # add line + self.preformat_text(lines) + # extra? no effect + #self.lines.extend(('.. code-block:: C++', '')) + #self.lines.extend([' ' + l for l in lines]) + + # add + def visit_programlisting(self, node): + lines = [] + for n in node.getchildren(): + lines.append(flatten(n)) + self.preformat_text(lines) + + #add + def visit_verbatim(self, node): + self.visit_preformatted(node) + + def visit_computeroutput(self, node): + c = node.find('preformatted') + if c is not None: + return self.visit_preformatted(c) + # add + # I don't think we can put links inside + # computeroutput text... + #self.lines[-1] += '``' + flatten(node) + '`` ' + self.concat_text('``' + flatten(node) + '``') + # omitted + #return self.visit_preformatted(node) + + def visit_xrefsect(self, node): + if node.find('xreftitle').text == 'Deprecated': + sublines = type(self)().generic_visit(node).lines + self.lines.extend(['.. admonition:: Deprecated'] + [' ' + s for s in sublines]) + return + # add - if not depricated + title = node.find('xreftitle').text + sublines = type(self)().generic_visit(node).lines + self.lines.extend(['.. admonition:: %s' % title] + [' ' + s for s in sublines]) + #else: + # raise ValueError(node) + + def visit_subscript(self, node): + #self.lines[-1] += '\ :sub:`%s` %s' % (node.text, node.tail) + self.concat_text(':sub:`%s` %s' % (node.text, node.tail)) + + def visit_table(self, node): + # save the number of columns + cols = int(node.get('cols')) + table = [] + # save the current output + lines = self.lines + + # get width of each column + widths = [0] * cols + + # build up the table contents + for row_node in node.findall('row'): + row = [] + for i, entry in enumerate(row_node.getchildren()): + self.lines = [''] + self.generic_visit(entry) + row.append(self.lines) + + # find width of this entry (including leading and trailing space) + widths[i] = max(widths[i], max([len(line) for line in self.lines]) + 2) + + table.append(row) + + def append_row(row): + # find number of lines in row + num_lines = max([len(e) for e in row]) + lines = [] + + for k in range(num_lines): + line = '|' + for i, e in enumerate(row): + if k < len(e): + # this is a valid line + line += ' ' + e[k] + # pad rest of line + line += ' ' * (widths[i] - len(e[k]) - 1) + else: + # invalid line, just fill with spaces + line += ' ' * widths[i] + + line += '|' + + lines.append(line) + + return lines + + self.lines = lines + # start with a blank + #self.lines.append('') + self.blank_line() + + # usual separator line + sep = '+' + for width in widths: + sep += '-' * width + sep += '+' + + self.lines.append(sep) + + # header row + self.lines.extend(append_row(table[0])) + # header separator uses '=' instead of '-' + self.lines.append(sep.replace('-', '=')) + + # loop over body rows + for row in table[1:]: + self.lines.extend(append_row(row)) + self.lines.append(sep) + + # end with a blank + #self.lines.append('') + self.blank_line() diff --git a/docs/_static/autodoxysource.css b/docs/_static/autodoxysource.css new file mode 100644 index 0000000000..81f42425a9 --- /dev/null +++ b/docs/_static/autodoxysource.css @@ -0,0 +1,94 @@ +/* Source browser styling for autodoxysource directive. + Font stack and sizes match the sphinx_rtd_theme's code-block rules + so source listings look consistent with fenced code blocks. */ + +.autodoxysource { + font-family: SFMono-Regular, Menlo, Monaco, Consolas, "Liberation Mono", + "Courier New", Courier, monospace; + font-size: 12px; + line-height: 1.2; + background: #f8f8f8; + border: 1px solid #e1e4e5; + border-radius: 4px; + padding: 12px 0; + overflow-x: auto; + min-width: fit-content; + max-width: calc(6.5em + 120ch + 24px); +} + +.autodoxysource .source-line { + display: block; + white-space: nowrap; + margin: 0; + padding: 0 12px 0 0; + line-height: 1.2; +} + +.autodoxysource .source-code { + white-space: pre; +} + +.autodoxysource .source-line:target { + background-color: #ffffcc; +} + +.autodoxysource .source-lineno { + display: inline-block; + width: 4.5em; + text-align: right; + padding-right: 0.8em; + margin-right: 0.8em; + color: #858585; + border-right: 1px solid #e6e9ea; + text-decoration: none; + -webkit-user-select: none; + user-select: none; +} + +.autodoxysource .source-lineno:hover { + color: #333; +} + +/* Doxygen highlight classes */ +.f-hl-comment { + color: #408080; + font-style: italic; +} + +.f-hl-keyword { + color: #008000; + font-weight: bold; +} + +.f-hl-keywordtype { + color: #b00040; +} + +.f-hl-keywordflow { + color: #008000; + font-weight: bold; +} + +.f-hl-stringliteral { + color: #ba2121; +} + +.f-hl-preprocessor { + color: #bc7a00; +} + +.f-hl-normal { + color: #333; +} + +/* Make xref links within source subtle */ +.autodoxysource a.reference { + color: inherit; + text-decoration: none; + border-bottom: 1px dotted #999; +} + +.autodoxysource a.reference:hover { + border-bottom: 1px solid #333; + color: #2980b9; +} diff --git a/docs/api/files.rst b/docs/api/files.rst new file mode 100644 index 0000000000..b90fd69b86 --- /dev/null +++ b/docs/api/files.rst @@ -0,0 +1,11 @@ +.. _Files: + +============ +Source Files +============ + +.. toctree:: + :maxdepth: 1 + :glob: + + generated/source/* diff --git a/docs/apiref.rst b/docs/apiref.rst index 7f94e1c4b9..2e884ab1a6 100644 --- a/docs/apiref.rst +++ b/docs/apiref.rst @@ -11,3 +11,5 @@ The complete API documentation is generated with doxygen and can be found at htt :maxdepth: 1 api/modules + api/functions + api/files diff --git a/docs/conf.py b/docs/conf.py index 5d84b3c37a..50bb5a9e52 100644 --- a/docs/conf.py +++ b/docs/conf.py @@ -20,11 +20,144 @@ # If extensions (or modules to document with autodoc) are in another directory, # add these directories to sys.path here. If the directory is relative to the # documentation root, use os.path.abspath to make it absolute, like shown here. -#sys.path.insert(0, os.path.abspath('.')) +sys.path.insert(0, os.path.abspath('_ext')) # -- Custom configuration values and roles ----------------------------------- from docutils import nodes +# -- Monkey-patch: fix sphinx-fortran's broken parallel-build merge ---------- +# +# Upstream VACUMM/sphinx-fortran (as of commit reachable from master, 2025-10) +# ships a FortranDomain.merge_domaindata() that has two bugs which together +# cause every f-domain object to be lost when sphinx-build is run with -j > 1: +# +# 1. The function references a name `outNames` that does not exist +# (typo for `ourNames`); accessing it raises NameError, which Sphinx's +# parallel worker error path swallows silently. +# +# 2. Even with the typo fixed, the unpack `for name, docname in +# otherdata['modules'].items()` is wrong, because `modules` values are +# 4-tuples `(docname, synopsis, platform, deprecated)` and `objects` +# values are 2-tuples `(docname, type)`, not bare docnames. +# +# Symptom: with `make html` (which passes -j 4), env.domaindata['f'] ends up +# with 0 modules and 0 objects, every :f:func:/:f:type:/:f:mod: cross- +# reference fails to resolve, and pages like f-modindex.html disappear. +# +# We patch this in-process so the existing -j 4 build still works. The fix +# is small and obvious; once it lands upstream we should pin sphinx-fortran +# to a post-fix commit and remove this patch. +# +# TODO(piece-2): submit upstream PR to VACUMM/sphinx-fortran with this fix, +# then drop this monkey-patch and pin requirements.txt to a +# post-fix commit. +def _patch_sphinx_fortran_merge_domaindata(): + try: + from sphinxfortran.fortran_domain import FortranDomain + except ImportError: + return + def merge_domaindata(self, docnames, otherdata): + ourNames = self.data['modules'] + for name, data in otherdata['modules'].items(): + # data == (docname, synopsis, platform, deprecated) + if data[0] in docnames and name not in ourNames: + ourNames[name] = data + ourNames = self.data['objects'] + for name, data in otherdata['objects'].items(): + # data == (docname, type) + if data[0] in docnames and name not in ourNames: + ourNames[name] = data + FortranDomain.merge_domaindata = merge_domaindata +_patch_sphinx_fortran_merge_domaindata() + +# -- Monkey-patch: stop sphinx.util.math.wrap_displaymath from double-wrapping +# LaTeX environments that the source already provides -------------------- +# +# MOM6's documentation contains a lot of math written directly with explicit +# LaTeX environments (`\begin{equation}`, `\begin{eqnarray}`, `\begin{align}`) +# inside `.. math::` directives. By default, Sphinx's wrap_displaymath() takes +# the body of a single-part `.. math::` directive and wraps it in +# `\begin{split}...\end{split}` and then again in `\begin{equation}` (or the +# starred unnumbered form). When the body already contains its own +# `\begin{equation}` etc., that produces nested LaTeX environments and +# pdflatex chokes. +# +# Sphinx's official workaround is the `:nowrap:` option on every affected +# `.. math::` directive, which would mean editing every math directive +# upstream in the MOM6 source tree. The jr3cermak/sphinx fork that the docs +# build previously depended on instead patched wrap_displaymath() so that any +# part containing one of these begin-environments is emitted verbatim and the +# outer wrapping is suppressed. We replicate that behavior here as a +# function-level monkey-patch on stock upstream Sphinx, so we can build +# against unmodified Sphinx 8.x. +# +# The detection is intentionally a plain substring search, matching the +# fork's behavior — `begin{equation`, `begin{eqnarray`, and `begin{align` all +# also match their starred and `aligned`/`equation*` variants. This is the +# same heuristic the fork shipped and what the existing MOM6 sources expect. +# +# Sphinx upstream issue tracking the same problem has been open since 2017 +# (sphinx-doc/sphinx#3785). A faithful upstream PR would be the right +# long-term fix, but that conversation is much older than this MOM6 upgrade +# work, so we are not blocking on it. +# +# TODO(piece-3): consider submitting a cleaner version upstream and dropping +# this patch when/if it lands. +def _patch_sphinx_wrap_displaymath(): + import sphinx.util.math as _sm + + def wrap_displaymath(text, label, numbering): + def is_equation(part): + return part.strip() + + if label is None: + labeldef = '' + else: + labeldef = r'\label{%s}' % label + numbering = True + + parts = list(filter(is_equation, text.split('\n\n'))) + + # Detect parts that already supply their own LaTeX environment. + nowrap = any( + ('begin{equation' in p) or + ('begin{eqnarray' in p) or + ('begin{align' in p) + for p in parts + ) + + equations = [] + if len(parts) == 0: + return '' + elif len(parts) == 1: + if numbering: + begin = r'\begin{equation}' + labeldef + end = r'\end{equation}' + else: + begin = r'\begin{equation*}' + labeldef + end = r'\end{equation*}' + if nowrap: + equations.append('%s\n' % parts[0]) + else: + equations.append('\\begin{split}%s\\end{split}\n' % parts[0]) + else: + if numbering: + begin = r'\begin{align}%s\!\begin{aligned}' % labeldef + end = r'\end{aligned}\end{align}' + else: + begin = r'\begin{align*}%s\!\begin{aligned}' % labeldef + end = r'\end{aligned}\end{align*}' + equations.extend('%s\\\\\n' % part.strip() for part in parts) + + if nowrap: + begin = '' + end = '' + + return '%s\n%s%s' % (begin, ''.join(equations), end) + + _sm.wrap_displaymath = wrap_displaymath +_patch_sphinx_wrap_displaymath() + def setup(app): app.add_config_value('sphinx_build_mode', '', 'env') app.add_role('latex', latexPassthru) @@ -137,13 +270,18 @@ def latexPassthru(name, rawtext, text, lineno, inliner, options={}, content=[]): extensions = [ 'sphinxcontrib.bibtex', 'sphinx.ext.ifconfig', - 'sphinxcontrib.autodoc_doxygen', + 'autodoc_doxygen', 'sphinxfortran.fortran_domain', ] bibtex_bibfiles = ['ocean.bib', 'references.bib', 'zotero.bib'] autosummary_generate = ['api/modules.rst', 'api/pages.rst'] -doxygen_xml = 'xml' +# Absolute path so the autodoc_doxygen extension can find the doxygen XML +# output regardless of what cwd Sphinx has at builder-inited time. This +# previously broke on RTD, where `sphinx-build -M html docs ...` runs from +# the repo root rather than from `docs/`, and the extension's os.path.isdir +# check resolved "xml" against the wrong directory. +doxygen_xml = os.path.join(os.path.dirname(os.path.abspath(__file__)), 'xml') # Add any paths that contain templates here, relative to this directory. templates_path = ['_templates'] @@ -159,7 +297,7 @@ def latexPassthru(name, rawtext, text, lineno, inliner, options={}, content=[]): # General information about the project. project = u'MOM6' -copyright = u'2017-2021, MOM6 developers' +copyright = u'2017-2022, MOM6 developers' # The version info for the project you're documenting, acts as replacement for # |version| and |release|, also used in various other places throughout the @@ -182,7 +320,17 @@ def latexPassthru(name, rawtext, text, lineno, inliner, options={}, content=[]): # List of patterns, relative to source directory, that match files and # directories to ignore when looking for source files. -exclude_patterns = ['_build', 'details', 'src', 'Thumbs.db', '.DS_Store'] +exclude_patterns = [ + '_build', '_build.*', + 'details', 'src', 'Thumbs.db', '.DS_Store', + # Local virtualenvs that may sit alongside the docs source. Sphinx walks + # the entire source tree by default and otherwise picks up LICENSE.rst, + # README.rst, autosummary template files, etc. from inside site-packages + # and reports them as "isn't included in any toctree". + 'venv', 'venv.*', 'venv-*', + # Vendored extension's Jinja2 templates are not real .rst documents. + '_ext/*/templates', '_ext/*/*/templates', +] # The reST default role (used for this markup: `text`) to use for all # documents. @@ -241,7 +389,7 @@ def latexPassthru(name, rawtext, text, lineno, inliner, options={}, content=[]): # Add any paths that contain custom static files (such as style sheets) here, # relative to this directory. They are copied after the builtin static files, # so a file named "default.css" will overwrite the builtin "default.css". -#html_static_path = ['_static'] +html_static_path = ['_static'] # Add any extra paths that contain custom files (such as robots.txt or # .htaccess) here, relative to this directory. These files are copied diff --git a/docs/discrete_space.rst b/docs/discrete_space.rst index 08a41a5f2d..64a3ad36c7 100644 --- a/docs/discrete_space.rst +++ b/docs/discrete_space.rst @@ -17,4 +17,5 @@ algorithm. api/generated/pages/Discrete_Coriolis api/generated/pages/Discrete_PG api/generated/pages/Energetic_Consistency + api/generated/pages/Vertical_Reconstruction api/generated/pages/Discrete_OBC diff --git a/docs/equations.rst b/docs/equations.rst index 9d15050927..f90a8f4181 100644 --- a/docs/equations.rst +++ b/docs/equations.rst @@ -6,8 +6,9 @@ hydrostatic primitive equations (either Boussinesq or non-Boussinesq). We present the equations starting from the hydrostatic Boussinesq equation in height coordinates and progress through vector-invariant and -general-coordinate equations to the final equations used in the A.L.E. -algorithm, taken from :cite:`Adcroft2019`. +general-coordinate equations to the final equations used in the +vertical Lagrangian algorithm, taken from +:cite:`Adcroft2019` and :cite:`Griffies_Adcroft_Hallberg2020`. .. toctree:: :maxdepth: 2 diff --git a/docs/forcing.rst b/docs/forcing.rst index 911f708b68..21539d46d0 100644 --- a/docs/forcing.rst +++ b/docs/forcing.rst @@ -1,5 +1,33 @@ Forcing ======= +Data Override +------------- +When running MOM6 with the Flexible Modelling System (FMS) coupler, forcing can be specified by a `data_table` file. This is particularly useful when running MOM6 with a data atmosphere, as paths to the relevent atmospheric forcing products (eg. JRA55-do or ERA5) can be provided here. Each item in the data table must be separated by a new line, and contains the following information: + +| ``gridname``: The component of the model this data applies to. eg. `atm` `ocn` `lnd` `ice`. +| ``fieldname_code``: The field name according to the model component. eg. `salt` +| ``fieldname_file``: The name of the field within the source file. +| ``file_name``: Path to the source file. +| ``interpol_method``: Interpolation method eg. `bilinear` +| ``factor``: A scalar by which to multiply the field ahead of passing it onto the model. This is a quick way to do unit conversions for example. +| + +The data table is commonly formatted by specifying each of the fields in the order listed above, with a new line for each entry. + +Example Format: + "ATM", "t_bot", "t2m", "./INPUT/2t_ERA5.nc", "bilinear", 1.0 + +A `yaml` format is also possible if you prefer. This is outlined in the `FMS data override `_ github page, along with other details. + +Speficying a constant value: + Rather than overriding with data from a file, one can also set a field to constant. To do this, pass empty strings to `fieldname_file` and `file_name`. The `factor` now corresponds to the override value. For example, the following sets the temperature at the bottom of the atmosphere to 290 Kelvin. + + + "ATM", "t_bot", "", "", "bilinear", 290.0 + +Which units do I need? + For configurations using SIS2 and MOM, a list of available surface flux variables along with the expected units can be found in the `flux_exchange `_ file. + .. toctree:: :maxdepth: 2 diff --git a/docs/images/ALE_general_schematic.png b/docs/images/ALE_general_schematic.png new file mode 100644 index 0000000000..3f492ed56d Binary files /dev/null and b/docs/images/ALE_general_schematic.png differ diff --git a/docs/images/channel_drag.png b/docs/images/channel_drag.png new file mode 100644 index 0000000000..a665034ff0 Binary files /dev/null and b/docs/images/channel_drag.png differ diff --git a/docs/ocean.bib b/docs/ocean.bib index 2297f25354..33107fbae1 100644 --- a/docs/ocean.bib +++ b/docs/ocean.bib @@ -10,18 +10,6 @@ @article{Adcroft2004 journal = {Ocean Modelling} } -@article{Adcroft2019, - doi = {10.1029/2019ms001726}, - year = 2019, - publisher = {American Geophysical Union ({AGU})}, - volume = {11}, - number = {10}, - pages = {3167--3211}, - author = {A. Adcroft and W. Anderson and V. Balaji and C. Blanton and M. Bushuk and C. O. Dufour and J. P. Dunne and S. M. Griffies and R. Hallberg and M. J. Harrison and I. M. Held and M. F. Jansen and J. G. John and J. P. Krasting and A. R. Langenhorst and S. Legg and Z. Liang and C. McHugh and A. Radhakrishnan and B. G. Reichl and T. Rosati and B. L. Samuels and A. Shao and R. Stouffer and M. Winton and A. T. Wittenberg and B. Xiang and N. Zadeh and R. Zhang}, - title = {The {GFDL} Global Ocean and Sea Ice Model {OM}4.0: Model Description and Simulation Features}, - journal = {J. Adv. Mod. Earth Sys.} -} - @article{Campin2004, doi = {10.1016/s1463-5003(03)00009-x}, year = 2004, @@ -70,3 +58,63 @@ @article{Kasahara1974 title = {Various Vertical Coordinate Systems Used for Numerical Weather Prediction}, journal = {Monthly Weather Rev.} } + +@Article{Griffies_Adcroft_Hallberg2020, +author = "S.M. Griffies and A. Adcroft and R.W. Hallberg", +title = "A primer on the vertical Lagrangian-remap method in + ocean models based on finite volume generalized vertical coordinates", +journal = "Journal of Advances in Modeling Earth Systems", +year = "2020", +volume = "12", +doi = "10.1029/2019MS001954", +} + +@Article{Shao_etal_2020, +author = "A. Shao and A.J. Adcroft and R.W. Hallberg and S.M. Griffies", +title = "A general-coordinate, nonlocal neutral diffusion operator", +journal = "Journal of Advances in Modeling Earth Systems", +year = "2020", +volume = "12", +doi = "10.1029/2019MS001992", +} + +@Article{GM95, +author = "P. R. Gent and J. Willebrand and T. J. McDougall and J. C. McWilliams", +title = "Parameterizing eddy-induced tracer transports in ocean circulation models", +journal = "Journal of Physical Oceanography", +year = "1995", +volume = "25", +pages = "463--474", +doi = "10.1175/1520-0485(1995)025<0463:PEITTI>2.0.CO;2", +} + +@Article{foxkemper_etal2008, +author = "Baylor Fox-Kemper and Raffaele Ferrari and Robert Hallberg", +title = "Parameterization of mixed layer eddies. {I}: {T}heory and diagnosis", +journal = "Journal of Physical Oceanography", +year = "2008", +volume = "38", +pages = "1145--1165", +doi = "10.1175/2007JPO3792.1", +} + +@Article{McDougall_etal_2021, +author = "T. J. McDougall and P.M.\ Barker and R.M.\ Holmes and R.\ Pawlowicz and S.M.\ Grif\/f\/ies and P.J.\ Durack", +title = "The interpretation of temperature and salinity variables in numerical ocean model output, + and the calculation of heat fluxes and heat content", +journal = "Geoscientific Model Development", +year = "2021", +volume = "14", +pages = "6445--6466", +doi = "10.5194/gmd-14-6445-2021", +} + +@article{Young2010, +author = "W. R. Young", +year = "2010", +title = "Dynamic Enthalpy, {Conservative Temperature}, and the Seawater {Boussinesq} Approximation", +journal = "Journal of Physical Oceanography", +volume = "40", +pages = "394--400", +doi = "10.1175/2009JPO4294.1", +} diff --git a/docs/parameterizations_lateral.rst b/docs/parameterizations_lateral.rst index 3a3266a2bb..d175c7e8bb 100644 --- a/docs/parameterizations_lateral.rst +++ b/docs/parameterizations_lateral.rst @@ -8,6 +8,8 @@ Lateral viscosity Laplacian and bi-harmonic viscosities with linear and Smagorinsky options are implemented in MOM_hor_visc. + :ref:`namespacemom__hor__visc_1section_horizontal_viscosity` + Gent-McWilliams/TEM/isopycnal height diffusion ---------------------------------------------- @@ -20,7 +22,7 @@ scaling. A model of sub-grid scale Mesoscale Eddy Kinetic Energy (MEKE) is implement in MOM_MEKE and the associated diffusivity added in MOM_thickness_diffuse. See :cite:`jansen2015` and :cite:`marshall2010`. - :ref:`namespacemom__meke_1section_MEKE` + :ref:`namespacemom__meke_1section_MEKE` Backscatter ----------- @@ -32,17 +34,43 @@ Mixed layer restratification by sub-mesoscale eddies ---------------------------------------------------- Mixed layer restratification from :cite:`fox-kemper2008` and -:cite:`fox-kemper2008-2` is implemented in MOM_mixed_layer_restrat. +:cite:`fox-kemper2008-2` is implemented in MOM_mixed_layer_restrat, +which now also contains the mixed layer restratication comes from :cite: Bodner2023. + + :ref:`namespacemom__mixed__layer__restrat_1section_mle` + +Interface filtering +------------------- + +For layer mode, one can filter the interface thicknesses: + + :ref:`namespacemom__interface__filter_1section_interface_filter` Lateral diffusion ----------------- See :ref:`Horizontal_Diffusion`. +See also :ref:`namespacemom__lateral__mixing__coeffs_1section_Resolution_Function` + Tidal forcing ------------- -Astronomical tidal forcings and self-attraction and loading are implement in MOM_tidal_forcing. -Tides can also be added via an open boundary tidal specification, -see [OBC wiki page](https://github.com/NOAA-GFDL/MOM6-examples/wiki/Open-Boundary-Conditions). +Astronomical tidal forcings and self-attraction and loading are implement in + + :ref:`namespacetidal__forcing_1section_tides` +The Love numbers are stored internally in MOM_load_love_numbers: + + :ref:`namespacemom__load__love__numbers_1section_Love_numbers` + +while the self attraction and loading is computed in MOM_self_attr_load: + + :ref:`namespaceself__attr__load_1section_SAL` + +The self attraction and loading needs spherical harmonics, computed in MOM_spherical_harmonics: + + :ref:`namespacemom__spherical__harmonics_1section_spherical_harmonics` + +Tides can also be added via an open boundary tidal specification, +see `OBC wiki page `_. diff --git a/docs/postProcessEquations.py b/docs/postProcessEquations.py index 396c41b507..59bceb15d0 100644 --- a/docs/postProcessEquations.py +++ b/docs/postProcessEquations.py @@ -1,3 +1,7 @@ +# This file is part of MOM6, the Modular Ocean Model version 6. +# See the LICENSE file for licensing information. +# SPDX-License-Identifier: Apache-2.0 + import os, sys, pathlib, re import itertools from lxml import html diff --git a/docs/requirements.txt b/docs/requirements.txt index 52fcf95bc0..ef24c6989b 100644 --- a/docs/requirements.txt +++ b/docs/requirements.txt @@ -1,10 +1,16 @@ -git+https://github.com/jr3cermak/sphinx.git@v3.2.1mom6.4 -git+https://github.com/jr3cermak/sphinxcontrib-autodoc_doxygen.git@0.7.13#egg=sphinxcontrib-autodoc_doxygen -git+https://github.com/jr3cermak/sphinx-fortran.git@1.2.2#egg=sphinx-fortran -git+https://github.com/jr3cermak/flint.git@0.0.1#egg=flint +sphinx>=8,<9 sphinx-rtd-theme sphinxcontrib-bibtex -# requirements.txt not working from sphinx-fortran +# lxml is required by the vendored docs/_ext/autodoc_doxygen extension +# (used to parse Doxygen XML output). +lxml numpy + +# Upstream VACUMM/sphinx-fortran has not cut a PyPI release past 1.1.1 but +# its master branch has had continued fixes through 2025. Pinned to a +# specific commit for reproducibility. See Notes-sphinx-upgrade.md (piece 2). +# NB: this commit contains a broken FortranDomain.merge_domaindata that we +# monkey-patch in conf.py to keep parallel builds (-j > 1) working. sphinx- +# fortran also still imports `six` at module load time on this commit. +git+https://github.com/VACUMM/sphinx-fortran.git@b14f438c1cc74d1dbcd5acd9a330c3b509caab56#egg=sphinx-fortran six -future diff --git a/docs/zotero.bib b/docs/zotero.bib index c0c7ee3bd9..01fe2c6185 100644 --- a/docs/zotero.bib +++ b/docs/zotero.bib @@ -967,7 +967,7 @@ @article{bitz1999 pages = {15669--15677} } -@inproceedings{briegleb2007, +@incollection{briegleb2007, series = {Technical {Note}}, title = {A {Delta}-{Eddington} {Mutiple} {Scattering} {Parameterization} for {Solar} {Radiation} in the {Sea} {Ice} {Component} of the {Community} {Climate} {System} {Model} {\textbar} {OpenSky} {Repository}}, url = {http://opensky.ucar.edu/islandora/object/technotes:484}, @@ -2447,7 +2447,7 @@ @article{russell1981 doi = {10.1175/1520-0450(1981)020<1483:ANFDSF>2.0.CO;2} } -@inproceedings{huynh1997, +@incollection{huynh1997, title = {Schemes and constraints for advection}, booktitle = {Fifteenth International Conference on Numerical Methods in Fluid Dynamics}, @@ -2524,7 +2524,7 @@ @article{visbeck1997 } @article{visbeck1996, - author = {Viscbeck, M. and J.C. Marshall and H. Jones}, + author = {Visbeck, M. and J.C. Marshall and H. Jones}, year = {1996}, title = {Dynamics of isolated convective regions in the ocean}, journal = {J. Phys. Oceanogr.}, @@ -2564,7 +2564,7 @@ @article{marshall2010 doi = {10.1016/j.ocemod.2010.02.001} } -@inproceedings{millero1978, +@incollection{millero1978, author = {Millero, F.J.}, title = {Freezing point of seawater}, note = {Annex 6}, @@ -2738,3 +2738,225 @@ @article{kraus1967 journal = {Tellus} } +@article{Nguyen2009, + doi = {10.1029/2008JC005121}, + year = {2009}, + journal = {JGR Oceans}, + volume = {114}, + author = {A. T. Nguyen and D. Menemenlis and R. Kwok}, + title = {Improved modeling of the Arctic halocline with a subgrid-scale brine rejection parameterization}, + pages = {C11014} +} + +@article{Adcroft2019, + doi = {10.1029/2019ms001726}, + year = 2019, + publisher = {American Geophysical Union ({AGU})}, + volume = {11}, + number = {10}, + pages = {3167--3211}, + author = {A. Adcroft and W. Anderson and V. Balaji and C. Blanton and M. Bushuk and C. O. Dufour and J. P. Dunne and S. M. Griffies and R. Hallberg and M. J. Harrison and I. M. Held and M. F. Jansen and J. G. John and J. P. Krasting and A. R. Langenhorst and S. Legg and Z. Liang and C. McHugh and A. Radhakrishnan and B. G. Reichl and T. Rosati and B. L. Samuels and A. Shao and R. Stouffer and M. Winton and A. T. Wittenberg and B. Xiang and N. Zadeh and R. Zhang}, + title = {The {GFDL} Global Ocean and Sea Ice Model {OM}4.0: Model Description and Simulation Features}, + journal = {J. Adv. Mod. Earth Sys.} +} + +@article{Bodner2023, + title={Modifying the Mixed Layer Eddy Parameterization to Include Frontogenesis Arrest by Boundary Layer Turbulence}, + volume={53}, + ISSN={1520-0485}, + url={http://dx.doi.org/10.1175/JPO-D-21-0297.1}, + DOI={10.1175/jpo-d-21-0297.1}, + number={1}, + journal={Journal of Physical Oceanography}, + publisher={American Meteorological Society}, + author={Bodner, Abigail S. and Fox-Kemper, Baylor and Johnson, Leah and Van Roekel, Luke P. and McWilliams, James C. and Sullivan, Peter P. and Hall, Paul S. and Dong, Jihai}, + year={2023}, + month=jan, + pages={323-–339} +} + +@article{Oberhuber1993a, + title={Simulation of the Atlantic Circulation with a Coupled Sea Ice-Mixed Layer-Isopycnal General Circulation Model. Part I: Model Description}, + volume={23}, + ISSN={1520-0485}, + url={http://dx.doi.org/10.1175/1520-0485(1993)023<0808:SOTACW>2.0.CO;2}, + DOI={10.1175/1520-0485(1993)023<0808:sotacw>2.0.co;2}, + number={5}, + journal={Journal of Physical Oceanography}, + publisher={American Meteorological Society}, + author={Oberhuber, Josef M.}, + year={1993}, + month=may, + pages={808–829} +} + +@article{Smith2003, + title={Anisotropic horizontal viscosity for ocean models}, + volume={5}, + ISSN={1463-5003}, + url={http://dx.doi.org/10.1016/s1463-5003(02)00016-1}, + DOI={10.1016/s1463-5003(02)00016-1}, + number={2}, + journal={Ocean Modelling}, + publisher={Elsevier BV}, + author={Smith, Richard D. and McWilliams, James C.}, + year={2003}, + month=jan, + pages={129–156} +} + +@article{Large2001, + title={Equatorial Circulation of a Global Ocean Climate Model with Anisotropic Horizontal Viscosity}, + volume={31}, + ISSN={1520-0485}, + url={http://dx.doi.org/10.1175/1520-0485(2001)031<0518:ECOAGO>2.0.CO;2}, + DOI={10.1175/1520-0485(2001)031<0518:ecoago>2.0.co;2}, + number={2}, + journal={Journal of Physical Oceanography}, + publisher={American Meteorological Society}, + author={Large, William G. and Danabasoglu, Gokhan and McWilliams, James C. and Gent, Peter R. and Bryan, Frank O.}, + year={2001}, + month=feb, + pages={518–536} +} + +@incollection{Smagorinsky1993, + author={Joseph Smagorinsky}, + year={1993}, + title={Some historical remarks on the use of non-linear viscosities}, + booktitle={Large Eddy Simulation of Complex Engineering and Geophysical Flows}, + note={Proceedings of an International Workshop in Large Eddy Simulation}, + address={Cambridge, UK}, + publisher={Cambridge University Press}, + pages={1--34} +} + +@article{Barton2022, + title={Global Barotropic Tide Modeling Using Inline Self‐Attraction and Loading in MPAS‐Ocean}, + volume={14}, + ISSN={1942-2466}, + url={http://dx.doi.org/10.1029/2022MS003207}, + DOI={10.1029/2022ms003207}, + number={11}, + journal={Journal of Advances in Modeling Earth Systems}, + publisher={American Geophysical Union (AGU)}, + author={Barton, Kristin N. and Pal, Nairita and Brus, Steven R. and Petersen, Mark R. and Arbic, Brian K. and Engwirda, Darren and Roberts, Andrew F. and Westerink, Joannes J. and Wirasaet, Damrongsak and Schindelegger, Michael}, + year={2022}, + month=nov +} + +@article{Brus2023, + title={Scalable self attraction and loading calculations for unstructured ocean tide models}, + volume={182}, + ISSN={1463-5003}, + url={http://dx.doi.org/10.1016/j.ocemod.2023.102160}, + DOI={10.1016/j.ocemod.2023.102160}, + journal={Ocean Modelling}, + publisher={Elsevier BV}, + author={Brus, Steven R. and Barton, Kristin N. and Pal, Nairita and Roberts, Andrew F. and Engwirda, Darren and Petersen, Mark R. and Arbic, Brian K. and Wirasaet, Damrongsak and Westerink, Joannes J. and Schindelegger, Michael}, + year={2023}, + month=apr, + pages={102160} +} + +@article{Blewitt2003, + title={Self‐consistency in reference frames, geocenter definition, and surface loading of the solid Earth}, + volume={108}, + ISSN={0148-0227}, + url={http://dx.doi.org/10.1029/2002JB002082}, + DOI={10.1029/2002jb002082}, + number={B2}, + journal={Journal of Geophysical Research: Solid Earth}, + publisher={American Geophysical Union (AGU)}, + author={Blewitt, Geoffrey}, + year={2003}, + month=feb +} + +@article{Wang2012-2, + author={Wang, H. and Xiang, L. and Jia, L. and Jiang, L. and Wang, Z. and Hu, B. + and Gao, P.}, + year={2012}, + title={Load Love numbers and Green's functions +for elastic Earth models PREM, iasp91, ak135, and modified models with refined crustal structure from Crust 2.0}, + journal={Computers & Geosciences}, + volume={49}, + pages={190--199} +} + +@incollection{Hallberg2003, + title={The ability of large-scale ocean models to accept parameterizations of boundary mixing, and a description of a refined bulk mixed-layer model}, + author={Robert Hallberg}, + year={2003}, + booktitle={Internal Gravity Waves and Small-Scale Turbulence: Proc.‘Aha Huliko ‘a Hawaiian Winter Workshop}, + pages={187--203} +} + +@article{Accad1978, + volume={290}, + ISSN={2054-0272}, + url={http://dx.doi.org/10.1098/rsta.1978.0083}, + DOI={10.1098/rsta.1978.0083}, + number={1368}, + journal={Philosophical Transactions of the Royal Society of London. Series A, Mathematical and Physical Sciences}, + publisher={The Royal Society}, + year={1978}, + month=nov, + pages={235-–266}, + author={Accad, Y. and Pekeris, C.L.}, + title={Solution of the tidal equations for the M2 and S2 tides in the world oceans from a + knowledge of the tidal potential alone} +} + +@article{Arbic2004, + title={The accuracy of surface elevations in forward global barotropic and baroclinic tide models}, + volume={51}, + ISSN={0967-0645}, + url={http://dx.doi.org/10.1016/j.dsr2.2004.09.014}, + DOI={10.1016/j.dsr2.2004.09.014}, + number={25–26}, + journal={Deep Sea Research Part II: Topical Studies in Oceanography}, + publisher={Elsevier BV}, + author={Arbic, Brian K. and Garner, Stephen T. and Hallberg, Robert W. and Simmons, Harper L.}, + year={2004}, + month=dec, + pages={3069-–3101} +} + +@article{Schaeffer2013, + title={Efficient spherical harmonic transforms aimed at pseudospectral numerical simulations}, + volume={14}, + ISSN={1525-2027}, + url={http://dx.doi.org/10.1002/ggge.20071}, + DOI={10.1002/ggge.20071}, + number={3}, + journal={Geochemistry, Geophysics, Geosystems}, + publisher={American Geophysical Union (AGU)}, + author={Schaeffer, Nathanaël}, + year={2013}, + month=mar, + pages={751-–758} +} + +@article{Young1994, + author={Young, W.}, + title={The subinertial mixed layer approximation}, + journal={J. Phys. Oceanogr.}, + volume={24}, + pages={1812--1826}, + year={1994} +} + +@article{van_leer_1977, + title = {Towards the ultimate conservative difference scheme. {IV}. {A} new approach to numerical convection}, + volume = {23}, + issn = {0021-9991}, + doi = {10.1016/0021-9991(77)90095-X}, + number = {3}, + journal = {Journal of Computational Physics}, + author = {Van Leer, Bram}, + month = mar, + year = {1977}, + pages = {276--299}, +} + diff --git a/pkg/CVMix-src b/pkg/CVMix-src index 9423197f89..c38ddb7ebd 160000 --- a/pkg/CVMix-src +++ b/pkg/CVMix-src @@ -1 +1 @@ -Subproject commit 9423197f894112edfcb1502245f7d7b873d551f9 +Subproject commit c38ddb7ebdd2d58c517b63a99bbdc8e348732db2 diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 70e152932c..e8bde7791d 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -1,3 +1,7 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> This module contains the main regridding routines. !! !! Regridding comprises two steps: @@ -8,40 +12,37 @@ !! Original module written by Laurent White, 2008.06.09 module MOM_ALE -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_debugging, only : check_column_integrals use MOM_diag_mediator, only : register_diag_field, post_data, diag_ctrl -use MOM_diag_mediator, only : time_type, diag_update_remap_grids -use MOM_diag_vkernels, only : interpolate_column, reintegrate_column -use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type -use MOM_EOS, only : calculate_density +use MOM_diag_mediator, only : time_type, diag_update_remap_grids, query_averaging_enabled use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_error_handler, only : callTree_showQuery use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint +use MOM_hybgen_unmix, only : hybgen_unmix, init_hybgen_unmix, end_hybgen_unmix, hybgen_unmix_CS +use MOM_hybgen_regrid, only : hybgen_regrid_CS use MOM_file_parser, only : get_param, param_file_type, log_param -use MOM_io, only : vardesc, var_desc, fieldtype, SINGLE_FILE -use MOM_io, only : create_file, write_field, close_file, file_type -use MOM_interface_heights,only : find_eta +use MOM_interface_heights,only : find_eta, calc_derived_thermo use MOM_open_boundary, only : ocean_OBC_type, OBC_DIRECTION_E, OBC_DIRECTION_W use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S use MOM_regridding, only : initialize_regridding, regridding_main, end_regridding use MOM_regridding, only : uniformResolution use MOM_regridding, only : inflate_vanished_layers_old +use MOM_regridding, only : regridding_preadjust_reqs, convective_adjustment use MOM_regridding, only : set_target_densities_from_GV, set_target_densities use MOM_regridding, only : regriddingCoordinateModeDoc, DEFAULT_COORDINATE_MODE use MOM_regridding, only : regriddingInterpSchemeDoc, regriddingDefaultInterpScheme use MOM_regridding, only : regriddingDefaultBoundaryExtrapolation use MOM_regridding, only : regriddingDefaultMinThickness -use MOM_regridding, only : regridding_CS, set_regrid_params -use MOM_regridding, only : getCoordinateInterfaces, getCoordinateResolution +use MOM_regridding, only : regridding_CS, set_regrid_params, write_regrid_file +use MOM_regridding, only : getCoordinateInterfaces use MOM_regridding, only : getCoordinateUnits, getCoordinateShortName use MOM_regridding, only : getStaticThickness use MOM_remapping, only : initialize_remapping, end_remapping use MOM_remapping, only : remapping_core_h, remapping_core_w use MOM_remapping, only : remappingSchemesDoc, remappingDefaultScheme -use MOM_remapping, only : remapping_CS, dzFromH1H2 +use MOM_remapping, only : interpolate_column, reintegrate_column +use MOM_remapping, only : remapping_CS, dzFromH1H2, remapping_set_param use MOM_string_functions, only : uppercase, extractWord, extract_integer use MOM_tracer_registry, only : tracer_registry_type, tracer_type, MOM_tracer_chkinv use MOM_unit_scaling, only : unit_scale_type @@ -54,6 +55,7 @@ module MOM_ALE use PLM_functions, only : PLM_reconstruction, PLM_boundary_extrapolation use PLM_functions, only : PLM_extrapolate_slope, PLM_monotonized_slope, PLM_slope_wa use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation +use Recon1d_PLM_WLS, only : PLM_WLS implicit none ; private #include @@ -64,21 +66,44 @@ module MOM_ALE logical :: remap_uv_using_old_alg !< If true, uses the old "remapping via a delta z" !! method. If False, uses the new method that !! remaps between grids described by h. + logical :: partial_cell_vel_remap !< If true, use partial cell thicknesses at velocity points + !! that are masked out where they extend below the shallower + !! of the neighboring bathymetry for remapping velocity. real :: regrid_time_scale !< The time-scale used in blending between the current (old) grid !! and the target (new) grid [T ~> s] type(regridding_CS) :: regridCS !< Regridding parameters and work arrays type(remapping_CS) :: remapCS !< Remapping parameters and work arrays + type(remapping_CS) :: vel_remapCS !< Remapping parameters for velocities and work arrays + + type(hybgen_unmix_CS), pointer :: hybgen_unmixCS => NULL() !< Parameters for hybgen remapping + + logical :: use_hybgen_unmix !< If true, use the hybgen unmixing code before regridding + logical :: do_conv_adj !< If true, do convective adjustment before regridding integer :: nk !< Used only for queries, not directly by this module + real :: BBL_h_vel_mask !< The thickness of a bottom boundary layer within which velocities in + !! thin layers are zeroed out after remapping, following practice with + !! Hybgen remapping, or a negative value to avoid such filtering + !! altogether, in [H ~> m or kg m-2]. + real :: h_vel_mask !< A thickness at velocity points below which near-bottom layers are + !! zeroed out after remapping, following the practice with Hybgen + !! remapping, or a negative value to avoid such filtering altogether, + !! in [H ~> m or kg m-2]. logical :: remap_after_initialization !< Indicates whether to regrid/remap after initializing the state. - logical :: answers_2018 !< If true, use the order of arithmetic and expressions for remapping - !! that recover the answers from the end of 2018. Otherwise, use more - !! robust and accurate forms of mathematically equivalent expressions. + integer :: answer_date !< The vintage of the expressions and order of arithmetic to use for + !! remapping. Values below 20190101 result in the use of older, less + !! accurate expressions 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. + + logical :: conserve_ke !< Apply a correction to the baroclinic velocity after remapping to + !! conserve KE. + logical :: debug !< If true, write verbose checksums for debugging purposes. logical :: show_call_tree !< For debugging ! for diagnostics @@ -98,22 +123,27 @@ module MOM_ALE integer :: id_e_preale = -1 !< diagnostic id for interface heights before ALE. integer :: id_vert_remap_h = -1 !< diagnostic id for layer thicknesses used for remapping integer :: id_vert_remap_h_tendency = -1 !< diagnostic id for layer thickness tendency due to ALE + integer :: id_remap_delta_integ_u2 = -1 !< Change in depth-integrated rho0*u**2/2 + integer :: id_remap_delta_integ_v2 = -1 !< Change in depth-integrated rho0*v**2/2 end type ! Publicly available functions public ALE_init public ALE_end -public ALE_main -public ALE_main_offline +public ALE_regrid public ALE_offline_inputs -public ALE_offline_tracer_final -public ALE_build_grid public ALE_regrid_accelerated public ALE_remap_scalar +public ALE_remap_tracers +public ALE_remap_velocities +public ALE_remap_set_h_vel, ALE_remap_set_h_vel_via_dz +public ALE_remap_interface_vals +public ALE_remap_vertex_vals public ALE_PLM_edge_values public TS_PLM_edge_values public TS_PPM_edge_values +public TS_PLM_WLS_edge_values public adjustGridForIntegrity public ALE_initRegridding public ALE_getCoordinate @@ -122,8 +152,11 @@ module MOM_ALE public ALE_updateVerticalGridType public ALE_initThicknessToCoord public ALE_update_regrid_weights +public pre_ALE_diagnostics +public pre_ALE_adjustments public ALE_remap_init_conds public ALE_register_diags +public ALE_set_extrap_boundaries ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -136,24 +169,29 @@ module MOM_ALE !! before the main time integration loop to initialize the regridding stuff. !! We read the MOM_input file to register the values of different !! regridding/remapping parameters. -subroutine ALE_init( param_file, GV, US, max_depth, CS) +subroutine ALE_init( param_file, G, GV, US, max_depth, CS) type(param_file_type), intent(in) :: param_file !< Parameter file + type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(in) :: max_depth !< The maximum depth of the ocean [Z ~> m]. type(ALE_CS), pointer :: CS !< Module control structure ! Local variables - real, dimension(:), allocatable :: dz - character(len=40) :: mdl = "MOM_ALE" ! This module's name. - character(len=80) :: string ! Temporary strings - real :: filter_shallow_depth, filter_deep_depth - logical :: default_2018_answers - logical :: check_reconstruction - logical :: check_remapping - logical :: force_bounds_in_subcell - logical :: local_logical - logical :: remap_boundary_extrap + character(len=40) :: mdl = "MOM_ALE" ! This module's name. + character(len=80) :: string, vel_string ! Temporary strings + real :: filter_shallow_depth, filter_deep_depth ! Depth ranges of filtering [H ~> m or kg m-2] + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: check_reconstruction + logical :: check_remapping + logical :: force_bounds_in_subcell + logical :: local_logical + logical :: remap_boundary_extrap + logical :: init_boundary_extrap + logical :: om4_remap_via_sub_cells + type(hybgen_regrid_CS), pointer :: hybgen_regridCS => NULL() ! Control structure for hybgen regridding + ! for sharing parameters. + real :: h_neglect, h_neglect_edge ! small thicknesses [H ~> m or kg m-2] if (associated(CS)) then call MOM_error(WARNING, "ALE_init called with an associated "// & @@ -172,14 +210,21 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) default=.false.) ! Initialize and configure regridding - call ALE_initRegridding(GV, US, max_depth, param_file, mdl, CS%regridCS) + call ALE_initRegridding(G, GV, US, max_depth, param_file, mdl, CS%regridCS) + call regridding_preadjust_reqs(CS%regridCS, CS%do_conv_adj, CS%use_hybgen_unmix, & + hybgen_CS=hybgen_regridCS) - ! Initialize and configure remapping + ! Initialize and configure remapping that is orchestrated by ALE. call get_param(param_file, mdl, "REMAPPING_SCHEME", string, & "This sets the reconstruction scheme used "//& "for vertical remapping for all variables. "//& - "It can be one of the following schemes: "//& + "It can be one of the following schemes: \n"//& trim(remappingSchemesDoc), default=remappingDefaultScheme) + call get_param(param_file, mdl, "VELOCITY_REMAPPING_SCHEME", vel_string, & + "This sets the reconstruction scheme used for vertical remapping "//& + "of velocities. By default it is the same as REMAPPING_SCHEME. "//& + "It can be one of the following schemes: \n"//& + trim(remappingSchemesDoc), default=trim(string)) call get_param(param_file, mdl, "FATAL_CHECK_RECONSTRUCTIONS", check_reconstruction, & "If true, cell-by-cell reconstructions are checked for "//& "consistency and if non-monotonicity or an inconsistency is "//& @@ -195,19 +240,55 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) call get_param(param_file, mdl, "REMAP_BOUNDARY_EXTRAP", remap_boundary_extrap, & "If true, values at the interfaces of boundary cells are "//& "extrapolated instead of piecewise constant", default=.false.) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", CS%answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) - call initialize_remapping( CS%remapCS, string, & - boundary_extrapolation=remap_boundary_extrap, & + call get_param(param_file, mdl, "INIT_BOUNDARY_EXTRAP", init_boundary_extrap, & + "If true, values at the interfaces of boundary cells are "//& + "extrapolated instead of piecewise constant during initialization. "//& + "Defaults to REMAP_BOUNDARY_EXTRAP.", default=remap_boundary_extrap) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "This selects the remapping algorithm used in OM4 that does not use "//& + "the full reconstruction for the top- and lower-most sub-layers, but instead "//& + "assumes they are always vanished (untrue) and so just uses their edge values. "//& + "We recommend setting this option to false.", default=.true.) + call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%answer_date, & + "The vintage of the expressions and order of arithmetic to use for remapping. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + 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, nk=GV%ke, & + 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, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping( CS%vel_remapCS, vel_string, nk=GV%ke, & + boundary_extrapolation=init_boundary_extrap, & check_reconstruction=check_reconstruction, & check_remapping=check_remapping, & force_bounds_in_subcell=force_bounds_in_subcell, & - answers_2018=CS%answers_2018) + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & + answer_date=CS%answer_date, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + + call get_param(param_file, mdl, "PARTIAL_CELL_VELOCITY_REMAP", CS%partial_cell_vel_remap, & + "If true, use partial cell thicknesses at velocity points that are masked out "//& + "where they extend below the shallower of the neighboring bathymetry for "//& + "remapping velocity.", default=.false.) call get_param(param_file, mdl, "REMAP_AFTER_INITIALIZATION", CS%remap_after_initialization, & "If true, applies regridding and remapping immediately after "//& @@ -215,6 +296,13 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) "legacy step and should not be needed if the initialization is "//& "consistent with the coordinate mode.", default=.true.) + call get_param(param_file, mdl, "REGRID_USE_DEPTH_BASED_TIME_FILTER", local_logical, & + "If true, always uses depth-based time filtering code that updates the "//& + "generated grid using REGRID_TIME_SCALE, REGRID_FILTER_SHALLOW_DEPTH, "//& + "REGRID_FILTER_DEEP_DEPTH parameters. Setting to True always uses "//& + "filtering but setting to False bypasses calculations when filter times = 0.", & + default=.true.) + call set_regrid_params(CS%regridCS, use_depth_based_time_filter=local_logical) call get_param(param_file, mdl, "REGRID_TIME_SCALE", CS%regrid_time_scale, & "The time-scale used in blending between the current (old) grid "//& "and the target (new) grid. A short time-scale favors the target "//& @@ -228,23 +316,73 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) call get_param(param_file, mdl, "REGRID_FILTER_DEEP_DEPTH", filter_deep_depth, & "The depth below which full time-filtering is applied with time-scale "//& "REGRID_TIME_SCALE. Between depths REGRID_FILTER_SHALLOW_DEPTH and "//& - "REGRID_FILTER_SHALLOW_DEPTH the filter weights adopt a cubic profile.", & + "REGRID_FILTER_DEEP_DEPTH the filter weights adopt a cubic profile.", & units="m", default=0., scale=GV%m_to_H) call set_regrid_params(CS%regridCS, depth_of_time_filter_shallow=filter_shallow_depth, & depth_of_time_filter_deep=filter_deep_depth) call get_param(param_file, mdl, "REGRID_USE_OLD_DIRECTION", local_logical, & - "If true, the regridding ntegrates upwards from the bottom for "//& + "If true, the regridding integrates upwards from the bottom for "//& "interface positions, much as the main model does. If false "//& - "regridding integrates downward, consistant with the remapping "//& - "code.", default=.true., do_not_log=.true.) + "regridding integrates downward, consistent with the remapping code.", & + default=.true., do_not_log=.true.) call set_regrid_params(CS%regridCS, integrate_downward_for_e=.not.local_logical) + call get_param(param_file, mdl, "REMAP_VEL_MASK_BBL_THICK", CS%BBL_h_vel_mask, & + "A thickness of a bottom boundary layer below which velocities in thin layers "//& + "are zeroed out after remapping, following practice with Hybgen remapping, "//& + "or a negative value to avoid such filtering altogether.", & + default=-0.001, units="m", scale=GV%m_to_H) + call get_param(param_file, mdl, "REMAP_VEL_MASK_H_THIN", CS%h_vel_mask, & + "A thickness at velocity points below which near-bottom layers are zeroed out "//& + "after remapping, following practice with Hybgen remapping, "//& + "or a negative value to avoid such filtering altogether.", & + default=1.0e-6, units="m", scale=GV%m_to_H, do_not_log=(CS%BBL_h_vel_mask<=0.0)) + + if (CS%use_hybgen_unmix) & + call init_hybgen_unmix(CS%hybgen_unmixCS, GV, US, param_file, hybgen_regridCS) + + call get_param(param_file, mdl, "REMAP_VEL_CONSERVE_KE", CS%conserve_ke, & + "If true, a correction is applied to the baroclinic component of velocity "//& + "after remapping so that total KE is conserved. KE may not be conserved "//& + "when (CS%BBL_h_vel_mask > 0.0) .and. (CS%h_vel_mask > 0.0)", & + default=.false.) + call get_param(param_file, "MOM", "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + ! Keep a record of values for subsequent queries CS%nk = GV%ke if (CS%show_call_tree) call callTree_leave("ALE_init()") end subroutine ALE_init +!> Sets the boundary extrapolation set for the remapping type. +subroutine ALE_set_extrap_boundaries( param_file, CS) + type(param_file_type), intent(in) :: param_file !< Parameter file + type(ALE_CS), pointer :: CS !< Module control structure + + logical :: remap_boundary_extrap + call get_param(param_file, "MOM_ALE", "REMAP_BOUNDARY_EXTRAP", remap_boundary_extrap, & + "If true, values at the interfaces of boundary cells are "//& + "extrapolated instead of piecewise constant", default=.false.) + call remapping_set_param(CS%remapCS, boundary_extrapolation=remap_boundary_extrap) +end subroutine ALE_set_extrap_boundaries + +!> Sets the remapping algorithm to that of OM4 +!! +!! The remapping aglorithm used in OM4 made poor assumptions about the reconstructions +!! in the top/bottom layers, namely that they were always vanished and could be +!! represented solely by their upper/lower edge value respectively. +!! Passing .false. here uses the full reconstruction of those top and bottom layers +!! and properly sample those layers. +subroutine ALE_set_OM4_remap_algorithm( CS, om4_remap_via_sub_cells ) + type(ALE_CS), pointer :: CS !< Module control structure + logical, intent(in) :: om4_remap_via_sub_cells !< If true, use OM4 remapping algorithm + + call remapping_set_param(CS%remapCS, om4_remap_via_sub_cells=om4_remap_via_sub_cells ) + +end subroutine ALE_set_OM4_remap_algorithm + !> Initialize diagnostics for the ALE module. subroutine ALE_register_diags(Time, G, GV, US, diag, CS) type(time_type),target, intent(in) :: Time !< Time structure @@ -254,7 +392,11 @@ subroutine ALE_register_diags(Time, G, GV, US, diag, CS) type(diag_ctrl), target, intent(in) :: diag !< Diagnostics control structure type(ALE_CS), pointer :: CS !< Module control structure + ! Local variables + character(len=48) :: thickness_units + CS%diag => diag + thickness_units = get_thickness_units(GV) ! These diagnostics of the state variables before ALE are useful for ! debugging the ALE code. @@ -263,23 +405,34 @@ subroutine ALE_register_diags(Time, G, GV, US, diag, CS) CS%id_v_preale = register_diag_field('ocean_model', 'v_preale', diag%axesCvL, Time, & 'Meridional velocity before remapping', 'm s-1', conversion=US%L_T_to_m_s) CS%id_h_preale = register_diag_field('ocean_model', 'h_preale', diag%axesTL, Time, & - 'Layer Thickness before remapping', get_thickness_units(GV), conversion=GV%H_to_MKS, & + 'Layer Thickness before remapping', thickness_units, conversion=GV%H_to_MKS, & v_extensive=.true.) CS%id_T_preale = register_diag_field('ocean_model', 'T_preale', diag%axesTL, Time, & - 'Temperature before remapping', 'degC') + 'Temperature before remapping', 'degC', conversion=US%C_to_degC) CS%id_S_preale = register_diag_field('ocean_model', 'S_preale', diag%axesTL, Time, & - 'Salinity before remapping', 'PSU') + 'Salinity before remapping', 'PSU', conversion=US%S_to_ppt) CS%id_e_preale = register_diag_field('ocean_model', 'e_preale', diag%axesTi, Time, & 'Interface Heights before remapping', 'm', conversion=US%Z_to_m) - CS%id_dzRegrid = register_diag_field('ocean_model','dzRegrid',diag%axesTi,Time, & + CS%id_dzRegrid = register_diag_field('ocean_model', 'dzRegrid', diag%axesTi, Time, & 'Change in interface height due to ALE regridding', 'm', conversion=GV%H_to_m) - cs%id_vert_remap_h = register_diag_field('ocean_model', 'vert_remap_h', & - diag%axestl, time, 'layer thicknesses after ALE regridding and remapping', & - 'm', conversion=GV%H_to_m, v_extensive=.true.) - cs%id_vert_remap_h_tendency = register_diag_field('ocean_model','vert_remap_h_tendency',diag%axestl,time, & + CS%id_vert_remap_h = register_diag_field('ocean_model', 'vert_remap_h', diag%axestl, Time, & + 'layer thicknesses after ALE regridding and remapping', & + thickness_units, conversion=GV%H_to_MKS, v_extensive=.true.) + CS%id_vert_remap_h_tendency = register_diag_field('ocean_model', & + 'vert_remap_h_tendency', diag%axestl, Time, & 'Layer thicknesses tendency due to ALE regridding and remapping', & - 'm s-1', conversion=GV%H_to_m*US%s_to_T, v_extensive = .true.) + trim(thickness_units)//" s-1", conversion=GV%H_to_MKS*US%s_to_T, v_extensive=.true.) + CS%id_remap_delta_integ_u2 = register_diag_field('ocean_model', 'ale_u2', diag%axesCu1, Time, & + 'Rate of change in half rho0 times depth integral of squared zonal '//& + 'velocity by remapping. If REMAP_VEL_CONSERVE_KE is .true. then '//& + 'this measures the change before the KE-conserving correction is applied.', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2*GV%H_to_RZ*US%L_to_Z**2) + CS%id_remap_delta_integ_v2 = register_diag_field('ocean_model', 'ale_v2', diag%axesCv1, Time, & + 'Rate of change in half rho0 times depth integral of squared meridional '//& + 'velocity by remapping. If REMAP_VEL_CONSERVE_KE is .true. then '//& + 'this measures the change before the KE-conserving correction is applied.', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2*GV%H_to_RZ*US%L_to_Z**2) end subroutine ALE_register_diags @@ -289,7 +442,7 @@ end subroutine ALE_register_diags !! We read the MOM_input file to register the values of different !! regridding/remapping parameters. subroutine adjustGridForIntegrity( CS, G, GV, h ) - type(ALE_CS), pointer :: CS !< Regridding parameters and options + type(ALE_CS), intent(in) :: CS !< Regridding parameters and options type(ocean_grid_type), intent(in) :: G !< Ocean grid informations type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Current 3D grid thickness that @@ -307,17 +460,17 @@ subroutine ALE_end(CS) ! Deallocate memory used for the regridding call end_remapping( CS%remapCS ) + + if (CS%use_hybgen_unmix) call end_hybgen_unmix( CS%hybgen_unmixCS ) call end_regridding( CS%regridCS ) deallocate(CS) end subroutine ALE_end -!> Takes care of (1) building a new grid and (2) remapping all variables between -!! the old grid and the new grid. The creation of the new grid can be based -!! on z coordinates, target interface densities, sigma coordinates or any -!! arbitrary coordinate system. -subroutine ALE_main( G, GV, US, h, u, v, tv, Reg, CS, OBC, dt, frac_shelf_h) +!> Save any diagnostics of the state before ALE remapping. These diagnostics are +!! mostly used for debugging. +subroutine pre_ALE_diagnostics(G, GV, US, h, u, v, tv, CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid informations type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -326,25 +479,11 @@ subroutine ALE_main( G, GV, US, h, u, v, tv, Reg, CS, OBC, dt, frac_shelf_h) real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< Zonal velocity field [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< Meridional velocity field [L T-1 ~> m s-1] type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variable structure - type(tracer_registry_type), pointer :: Reg !< Tracer registry structure type(ALE_CS), pointer :: CS !< Regridding parameters and options - type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - real, optional, intent(in) :: dt !< Time step between calls to ALE_main [T ~> s] - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: frac_shelf_h !< Fractional ice shelf coverage [nondim] - ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: dzRegrid ! The change in grid interface positions - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: eta_preale - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_new ! New 3D grid obtained after last time step [H ~> m or kg m-2] - integer :: nk, i, j, k, isc, iec, jsc, jec - logical :: ice_shelf - - nk = GV%ke; isc = G%isc; iec = G%iec; jsc = G%jsc; jec = G%jec - ice_shelf = present(frac_shelf_h) - - if (CS%show_call_tree) call callTree_enter("ALE_main(), MOM_ALE.F90") + ! Local variables + real :: eta_preale(SZI_(G),SZJ_(G),SZK_(GV)+1) ! Interface heights before remapping [Z ~> m] - ! These diagnostics of the state before ALE is applied are mostly used for debugging. if (CS%id_u_preale > 0) call post_data(CS%id_u_preale, u, CS%diag) if (CS%id_v_preale > 0) call post_data(CS%id_v_preale, v, CS%diag) if (CS%id_h_preale > 0) call post_data(CS%id_h_preale, h, CS%diag) @@ -355,127 +494,104 @@ subroutine ALE_main( G, GV, US, h, u, v, tv, Reg, CS, OBC, dt, frac_shelf_h) call post_data(CS%id_e_preale, eta_preale, CS%diag) endif - if (present(dt)) then - call ALE_update_regrid_weights( dt, CS ) - endif - dzRegrid(:,:,:) = 0.0 +end subroutine pre_ALE_diagnostics - ! Build new grid. The new grid is stored in h_new. The old grid is h. - ! Both are needed for the subsequent remapping of variables. - if (ice_shelf) then - call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid, frac_shelf_h) - else - call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid) - endif - - call check_grid( G, GV, h, 0. ) - if (CS%show_call_tree) call callTree_waypoint("new grid generated (ALE_main)") - - ! The presence of dt is used for expediency to distinguish whether ALE_main is being called during init - ! or in the main loop. Tendency diagnostics in remap_all_state_vars also rely on this logic. - if (present(dt)) then - call diag_update_remap_grids(CS%diag) - endif - ! Remap all variables from old grid h onto new grid h_new - call remap_all_state_vars( CS%remapCS, CS, G, GV, h, h_new, Reg, OBC, -dzRegrid, & - u, v, CS%show_call_tree, dt ) - - if (CS%show_call_tree) call callTree_waypoint("state remapped (ALE_main)") - - ! Override old grid with new one. The new grid 'h_new' is built in - ! one of the 'build_...' routines above. - !$OMP parallel do default(shared) - do k = 1,nk ; do j = jsc-1,jec+1 ; do i = isc-1,iec+1 - h(i,j,k) = h_new(i,j,k) - enddo ; enddo ; enddo - - if (CS%show_call_tree) call callTree_leave("ALE_main()") - - if (CS%id_dzRegrid>0 .and. present(dt)) call post_data(CS%id_dzRegrid, dzRegrid, CS%diag) - - -end subroutine ALE_main - -!> Takes care of (1) building a new grid and (2) remapping all variables between -!! the old grid and the new grid. The creation of the new grid can be based -!! on z coordinates, target interface densities, sigma coordinates or any -!! arbitrary coordinate system. -subroutine ALE_main_offline( G, GV, h, tv, Reg, CS, OBC, dt) +!> Potentially do some preparatory work, such as convective adjustment, to clean up the model +!! state before regridding. +subroutine pre_ALE_adjustments(G, GV, US, h, tv, Reg, CS, u, v) type(ocean_grid_type), intent(in) :: G !< Ocean grid informations type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after the !! last time step [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variable structure type(tracer_registry_type), pointer :: Reg !< Tracer registry structure type(ALE_CS), pointer :: CS !< Regridding parameters and options - type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - real, optional, intent(in) :: dt !< Time step between calls to ALE_main [T ~> s] - ! Local variables - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)+1) :: dzRegrid ! The change in grid interface positions - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_new ! New 3D grid obtained after last time step [H ~> m or kg m-2] - integer :: nk, i, j, k, isc, iec, jsc, jec + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + optional, intent(inout) :: u !< Zonal velocity field [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + optional, intent(inout) :: v !< Meridional velocity field [L T-1 ~> m s-1] - nk = GV%ke; isc = G%isc; iec = G%iec; jsc = G%jsc; jec = G%jec + integer :: ntr - if (CS%show_call_tree) call callTree_enter("ALE_main_offline(), MOM_ALE.F90") + ! Do column-wise convective adjustment. + ! Tracers and velocities should probably also undergo consistent adjustments. + if (CS%do_conv_adj) call convective_adjustment(G, GV, h, tv) - if (present(dt)) then - call ALE_update_regrid_weights( dt, CS ) + if (CS%use_hybgen_unmix) then + ntr = 0 ; if (associated(Reg)) ntr = Reg%ntr + call hybgen_unmix(G, GV, US, CS%hybgen_unmixCS, tv, Reg, ntr, h) endif - dzRegrid(:,:,:) = 0.0 - ! Build new grid. The new grid is stored in h_new. The old grid is h. - ! Both are needed for the subsequent remapping of variables. - call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid ) +end subroutine pre_ALE_adjustments - call check_grid( G, GV, h, 0. ) +!> Takes care of building a new grid. The creation of the new grid can be based on z coordinates, +!! target interface densities, sigma coordinates or any arbitrary coordinate system. +subroutine ALE_regrid( G, GV, US, h, h_new, dzRegrid, tv, CS, frac_shelf_h, PCM_cell) + type(ocean_grid_type), intent(in) :: G !< Ocean grid informations + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses in 3D grid before + !! regridding [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: h_new !< Layer thicknesses in 3D grid after + !! regridding [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(out) :: dzRegrid !< The change in grid interface positions + !! due to regridding, in the same units as + !! thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variable structure + type(ALE_CS), pointer :: CS !< Regridding parameters and options + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: frac_shelf_h !< Fractional ice shelf coverage [nondim] + logical, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(out) :: PCM_cell !< If true, use PCM remapping in a cell. - if (CS%show_call_tree) call callTree_waypoint("new grid generated (ALE_main)") + ! Local variables + logical :: showCallTree - ! Remap all variables from old grid h onto new grid h_new + showCallTree = callTree_showQuery() - call remap_all_state_vars(CS%remapCS, CS, G, GV, h, h_new, Reg, OBC, & - debug=CS%show_call_tree, dt=dt ) + if (showCallTree) call callTree_enter("ALE_regrid(), MOM_ALE.F90") - if (CS%show_call_tree) call callTree_waypoint("state remapped (ALE_main)") + ! Build the new grid and store it in h_new. The old grid is retained as h. + ! Both are needed for the subsequent remapping of variables. + dzRegrid(:,:,:) = 0.0 + call regridding_main( CS%remapCS, CS%regridCS, G, GV, US, h, tv, h_new, dzRegrid, & + frac_shelf_h=frac_shelf_h, PCM_cell=PCM_cell) - ! Override old grid with new one. The new grid 'h_new' is built in - ! one of the 'build_...' routines above. - !$OMP parallel do default(shared) - do k = 1,nk ; do j = jsc-1,jec+1 ; do i = isc-1,iec+1 - h(i,j,k) = h_new(i,j,k) - enddo ; enddo ; enddo + if (CS%id_dzRegrid>0) then ; if (query_averaging_enabled(CS%diag)) then + call post_data(CS%id_dzRegrid, dzRegrid, CS%diag, alt_h=h_new) + endif ; endif - if (CS%show_call_tree) call callTree_leave("ALE_main()") - if (CS%id_dzRegrid>0 .and. present(dt)) call post_data(CS%id_dzRegrid, dzRegrid, CS%diag) + if (showCallTree) call callTree_leave("ALE_regrid()") -end subroutine ALE_main_offline +end subroutine ALE_regrid !> Regrid/remap stored fields used for offline tracer integrations. These input fields are assumed to have !! the same layer thicknesses at the end of the last offline interval (which should be a Zstar grid). This !! routine builds a grid on the runtime specified vertical coordinate -subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug, OBC) +subroutine ALE_offline_inputs(CS, G, GV, US, h, tv, Reg, uhtr, vhtr, Kd, debug, OBC) type(ALE_CS), pointer :: CS !< Regridding parameters and options type(ocean_grid_type), intent(in ) :: G !< Ocean grid informations type(verticalGrid_type), intent(in ) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thicknesses + type(unit_scale_type), intent(in ) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variable structure type(tracer_registry_type), pointer :: Reg !< Tracer registry structure - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uhtr !< Zonal mass fluxes - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vhtr !< Meridional mass fluxes - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kd !< Input diffusivites + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uhtr !< Zonal mass fluxes [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vhtr !< Meridional mass fluxes [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kd !< Input diffusivities + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] logical, intent(in ) :: debug !< If true, then turn checksums type(ocean_OBC_type), pointer :: OBC !< Open boundary structure ! Local variables integer :: nk, i, j, k, isc, iec, jsc, jec - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: h_new ! Layer thicknesses after regridding - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)+1) :: dzRegrid ! The change in grid interface positions - real, dimension(SZK_(GV)) :: h_src - real, dimension(SZK_(GV)) :: h_dest, uh_dest - real, dimension(SZK_(GV)) :: temp_vec + real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: h_new ! Layer thicknesses after regridding [H ~> m or kg m-2] + real, dimension(SZI_(G), SZJ_(G), SZK_(GV)+1) :: dzRegrid ! The change in grid interface positions [H ~> m or kg m-2] + real, dimension(SZK_(GV)) :: h_src ! Source grid thicknesses at velocity points [H ~> m or kg m-2] + real, dimension(SZK_(GV)) :: h_dest ! Destination grid thicknesses at velocity points [H ~> m or kg m-2] + real, dimension(SZK_(GV)) :: temp_vec ! Transports on the destination grid [H L2 ~> m3 or kg] - nk = GV%ke; isc = G%isc; iec = G%iec; jsc = G%jsc; jec = G%jec + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = GV%ke dzRegrid(:,:,:) = 0.0 h_new(:,:,:) = 0.0 @@ -484,12 +600,12 @@ subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug, OBC) ! Build new grid from the Zstar state onto the requested vertical coordinate. The new grid is stored ! in h_new. The old grid is h. Both are needed for the subsequent remapping of variables. Convective ! adjustment right now is not used because it is unclear what to do with vanished layers - call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid, conv_adjust = .false. ) - call check_grid( G, GV, h_new, 0. ) + call regridding_main( CS%remapCS, CS%regridCS, G, GV, US, h, tv, h_new, dzRegrid) if (CS%show_call_tree) call callTree_waypoint("new grid generated (ALE_offline_inputs)") ! Remap all variables from old grid h onto new grid h_new - call remap_all_state_vars( CS%remapCS, CS, G, GV, h, h_new, Reg, OBC, debug=CS%show_call_tree ) + call ALE_remap_tracers(CS, G, GV, h, h_new, Reg, debug=CS%show_call_tree) + if (allocated(tv%SpV_avg)) tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. if (CS%show_call_tree) call callTree_waypoint("state remapped (ALE_inputs)") ! Reintegrate mass transports from Zstar to the offline vertical coordinate @@ -497,7 +613,7 @@ subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug, OBC) if (G%mask2dCu(i,j)>0.) then h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) h_dest(:) = 0.5 * (h_new(i,j,:) + h_new(i+1,j,:)) - call reintegrate_column(nk, h_src, uhtr(I,j,:), nk, h_dest, 0., temp_vec) + call reintegrate_column(nk, h_src, uhtr(I,j,:), nk, h_dest, temp_vec) uhtr(I,j,:) = temp_vec endif enddo ; enddo @@ -505,158 +621,48 @@ subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug, OBC) if (G%mask2dCv(i,j)>0.) then h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) h_dest(:) = 0.5 * (h_new(i,j,:) + h_new(i,j+1,:)) - call reintegrate_column(nk, h_src, vhtr(I,j,:), nk, h_dest, 0., temp_vec) + call reintegrate_column(nk, h_src, vhtr(I,j,:), nk, h_dest, temp_vec) vhtr(I,j,:) = temp_vec endif enddo ; enddo - do j = jsc,jec ; do i=isc,iec + do j=jsc,jec ; do i=isc,iec if (G%mask2dT(i,j)>0.) then if (check_column_integrals(nk, h_src, nk, h_dest)) then call MOM_error(FATAL, "ALE_offline_inputs: Kd interpolation columns do not match") endif - call interpolate_column(nk, h(i,j,:), Kd(i,j,:), nk, h_new(i,j,:), 0., Kd(i,j,:)) + call interpolate_column(nk, h(i,j,:), Kd(i,j,:), nk, h_new(i,j,:), Kd(i,j,:), .true.) endif enddo ; enddo - call ALE_remap_scalar(CS%remapCS, G, GV, nk, h, tv%T, h_new, tv%T, answers_2018=CS%answers_2018) - call ALE_remap_scalar(CS%remapCS, G, GV, nk, h, tv%S, h_new, tv%S, answers_2018=CS%answers_2018) + 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) ! Copy over the new layer thicknesses do k = 1,nk ; do j = jsc-1,jec+1 ; do i = isc-1,iec+1 - h(i,j,k) = h_new(i,j,k) + h(i,j,k) = h_new(i,j,k) enddo ; enddo ; enddo + if (allocated(tv%SpV_avg)) tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. + if (CS%show_call_tree) call callTree_leave("ALE_offline_inputs()") end subroutine ALE_offline_inputs -!> Remaps all tracers from h onto h_target. This is intended to be called when tracers -!! are done offline. In the case where transports don't quite conserve, we still want to -!! make sure that layer thicknesses offline do not drift too far away from the online model -subroutine ALE_offline_tracer_final( G, GV, h, tv, h_target, Reg, CS, OBC) - type(ocean_grid_type), intent(in) :: G !< Ocean grid informations - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after the - !! last time step [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variable structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h_target !< Current 3D grid obtained after - !! last time step [H ~> m or kg m-2] - type(tracer_registry_type), pointer :: Reg !< Tracer registry structure - type(ALE_CS), pointer :: CS !< Regridding parameters and options - type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - ! Local variables - - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)+1) :: dzRegrid !< The change in grid interface positions - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: h_new !< Regridded target thicknesses - integer :: nk, i, j, k, isc, iec, jsc, jec - - nk = GV%ke; isc = G%isc; iec = G%iec; jsc = G%jsc; jec = G%jec - - if (CS%show_call_tree) call callTree_enter("ALE_offline_tracer_final(), MOM_ALE.F90") - ! Need to make sure that h_target is consistent with the current offline ALE confiuration - call regridding_main( CS%remapCS, CS%regridCS, G, GV, h_target, tv, h_new, dzRegrid ) - call check_grid( G, GV, h_target, 0. ) - - - if (CS%show_call_tree) call callTree_waypoint("Source and target grids checked (ALE_offline_tracer_final)") - - ! Remap all variables from old grid h onto new grid h_new - - call remap_all_state_vars( CS%remapCS, CS, G, GV, h, h_new, Reg, OBC, debug=CS%show_call_tree ) - - if (CS%show_call_tree) call callTree_waypoint("state remapped (ALE_offline_tracer_final)") - - ! Override old grid with new one. The new grid 'h_new' is built in - ! one of the 'build_...' routines above. - !$OMP parallel do default(shared) - do k = 1,nk - do j = jsc-1,jec+1 ; do i = isc-1,iec+1 - h(i,j,k) = h_new(i,j,k) - enddo ; enddo - enddo - if (CS%show_call_tree) call callTree_leave("ALE_offline_tracer_final()") -end subroutine ALE_offline_tracer_final - -!> Check grid for negative thicknesses -subroutine check_grid( G, GV, h, threshold ) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Current 3D grid obtained after the - !! last time step [H ~> m or kg m-2] - real, intent(in) :: threshold !< Value below which to flag issues, - !! [H ~> m or kg m-2] - ! Local variables - integer :: i, j - - do j = G%jsc,G%jec ; do i = G%isc,G%iec - if (G%mask2dT(i,j)>0.) then - if (minval(h(i,j,:)) < threshold) then - write(0,*) 'check_grid: i,j=',i,j,'h(i,j,:)=',h(i,j,:) - if (threshold <= 0.) then - call MOM_error(FATAL,"MOM_ALE, check_grid: negative thickness encountered.") - else - call MOM_error(FATAL,"MOM_ALE, check_grid: too tiny thickness encountered.") - endif - endif - endif - enddo ; enddo - - -end subroutine check_grid - -!> Generates new grid -subroutine ALE_build_grid( G, GV, regridCS, remapCS, h, tv, debug, frac_shelf_h ) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - type(regridding_CS), intent(in) :: regridCS !< Regridding parameters and options - type(remapping_CS), intent(in) :: remapCS !< Remapping parameters and options - type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamical variable structure - real, dimension(SZI_(G),SZJ_(G), SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after the - !! last time step [H ~> m or kg m-2] - logical, optional, intent(in) :: debug !< If true, show the call tree - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in):: frac_shelf_h !< Fractional ice shelf coverage [nondim] - ! Local variables - integer :: nk, i, j, k - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)+1) :: dzRegrid ! The change in grid interface positions - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: h_new ! The new grid thicknesses - logical :: show_call_tree, use_ice_shelf - - show_call_tree = .false. - if (present(debug)) show_call_tree = debug - if (show_call_tree) call callTree_enter("ALE_build_grid(), MOM_ALE.F90") - use_ice_shelf = present(frac_shelf_h) - - ! Build new grid. The new grid is stored in h_new. The old grid is h. - ! Both are needed for the subsequent remapping of variables. - if (use_ice_shelf) then - call regridding_main( remapCS, regridCS, G, GV, h, tv, h_new, dzRegrid, frac_shelf_h ) - else - call regridding_main( remapCS, regridCS, G, GV, h, tv, h_new, dzRegrid ) - endif - - ! Override old grid with new one. The new grid 'h_new' is built in - ! one of the 'build_...' routines above. -!$OMP parallel do default(none) shared(G,h,h_new) - do j = G%jsc,G%jec ; do i = G%isc,G%iec - if (G%mask2dT(i,j)>0.) h(i,j,:) = h_new(i,j,:) - enddo ; enddo - - if (show_call_tree) call callTree_leave("ALE_build_grid()") -end subroutine ALE_build_grid - !> For a state-based coordinate, accelerate the process of regridding by !! repeatedly applying the grid calculation algorithm -subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzRegrid, initial) +subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, dt, & + dzRegrid, initial) type(ALE_CS), pointer :: CS !< ALE control structure type(ocean_grid_type), intent(inout) :: G !< Ocean grid type(verticalGrid_type), intent(in) :: GV !< Vertical grid + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Original thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< Thermo vars (T/S/EOS) - integer, intent(in) :: n !< Number of times to regrid + integer, intent(in) :: n_itt !< Number of times to regrid real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: u !< Zonal velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & @@ -666,24 +672,38 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzReg optional, pointer :: Reg !< Tracer registry to remap onto new grid real, optional, intent(in) :: dt !< Model timestep to provide a timescale for regridding [T ~> s] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & - optional, intent(inout) :: dzRegrid !< Final change in interface positions + optional, intent(inout) :: dzRegrid !< Final change in interface positions [H ~> m or kg m-2] logical, optional, intent(in) :: initial !< Whether we're being called from an initialization !! routine (and expect diagnostics to work) ! Local variables - integer :: i, j, k, nz + integer :: i, j, itt, nz type(thermo_var_ptrs) :: tv_local ! local/intermediate temp/salt type(group_pass_type) :: pass_T_S_h ! group pass if the coordinate has a stencil - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_loc, h_orig ! A working copy of layer thicknesses - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: T, S ! local temporary state + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_loc ! A working copy of layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_orig ! The original layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: T ! local temporary temperatures [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: S ! local temporary salinities [S ~> ppt] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: h_old_u ! Source grid thickness at zonal + ! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: h_old_v ! Source grid thickness at meridional + ! velocity points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: h_new_u ! Destination grid thickness at zonal + ! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: h_new_v ! Destination grid thickness at meridional + ! velocity points [H ~> m or kg m-2] + ! we have to keep track of the total dzInterface if for some reason ! we're using the old remapping algorithm for u/v - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: dzInterface, dzIntTotal + 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] nz = GV%ke ! initial total interface displacement due to successive regridding - dzIntTotal(:,:,:) = 0. + if (CS%remap_uv_using_old_alg) & + dzIntTotal(:,:,:) = 0. call create_group_pass(pass_T_S_h, T, G%domain) call create_group_pass(pass_T_S_h, S, G%domain) @@ -702,19 +722,28 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzReg ! Apply timescale to regridding (for e.g. filtered_grid_motion) if (present(dt)) & - call ALE_update_regrid_weights(dt, CS) + call ALE_update_regrid_weights(dt, CS) + + do itt = 1, n_itt - do k = 1, n call do_group_pass(pass_T_S_h, G%domain) ! generate new grid - call regridding_main(CS%remapCS, CS%regridCS, G, GV, h_loc, tv_local, h, dzInterface) - dzIntTotal(:,:,:) = dzIntTotal(:,:,:) + dzInterface(:,:,:) + if (CS%do_conv_adj) call convective_adjustment(G, GV, h_loc, tv_local) + + ! Update the layer specific volumes if necessary + if (allocated(tv_local%SpV_avg)) call calc_derived_thermo(tv_local, h, G, GV, US, halo=1) + + call regridding_main(CS%remapCS, CS%regridCS, G, GV, US, h_loc, tv_local, h, dzInterface) + if (CS%remap_uv_using_old_alg) & + dzIntTotal(:,:,:) = dzIntTotal(:,:,:) + dzInterface(:,:,:) ! 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,:)) - call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%T(i,j,:), nz, h(i,j,:), tv_local%T(i,j,:)) + 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 @@ -722,22 +751,30 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzReg enddo ! remap all state variables (including those that weren't needed for regridding) - call remap_all_state_vars(CS%remapCS, CS, G, GV, h_orig, h, Reg, OBC, dzIntTotal, u, v) + call ALE_remap_tracers(CS, G, GV, h_orig, h, Reg) + + call ALE_remap_set_h_vel(CS, G, GV, h_orig, h_old_u, h_old_v, OBC) + if (CS%remap_uv_using_old_alg) then + call ALE_remap_set_h_vel_via_dz(CS, G, GV, h, h_new_u, h_new_v, OBC, h_orig, dzIntTotal) + else + call ALE_remap_set_h_vel(CS, G, GV, h, h_new_u, h_new_v, OBC) + endif + + call ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u, v) ! save total dzregrid for diags if needed? if (present(dzRegrid)) dzRegrid(:,:,:) = dzIntTotal(:,:,:) + + if (allocated(tv%SpV_avg)) tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. + end subroutine ALE_regrid_accelerated -!> This routine takes care of remapping all variable between the old and the -!! new grids. When velocity components need to be remapped, thicknesses at -!! velocity points are taken to be arithmetic averages of tracer thicknesses. -!! This routine is called during initialization of the model at time=0, to -!! remap initiali conditions to the model grid. It is also called during a +!> This routine takes care of remapping all tracer variables between the old and the +!! new grids. This routine is called during initialization of the model at time=0, to +!! remap initial conditions to the model grid. It is also called during a !! time step to update the state. -subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, OBC, & - dxInterface, u, v, debug, dt) - type(remapping_CS), intent(in) :: CS_remapping !< Remapping control structure - type(ALE_CS), intent(in) :: CS_ALE !< ALE control structure +subroutine ALE_remap_tracers(CS, G, GV, h_old, h_new, Reg, debug, dt, PCM_cell) + type(ALE_CS), intent(in) :: CS !< ALE control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_old !< Thickness of source grid @@ -745,52 +782,33 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness of destination grid !! [H ~> m or kg m-2] type(tracer_registry_type), pointer :: Reg !< Tracer registry structure - type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & - optional, intent(in) :: dxInterface !< Change in interface position - !! [H ~> m or kg m-2] - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - optional, intent(inout) :: u !< Zonal velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - optional, intent(inout) :: v !< Meridional velocity [L T-1 ~> m s-1] logical, optional, intent(in) :: debug !< If true, show the call tree real, optional, intent(in) :: dt !< time step for diagnostics [T ~> s] + logical, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: PCM_cell !< Use PCM remapping in cells where true + ! Local variables - integer :: i, j, k, m - integer :: nz, ntr - real, dimension(GV%ke+1) :: dx - real, dimension(GV%ke) :: h1, u_column - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: work_conc - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: work_cont - real, dimension(SZI_(G), SZJ_(G)) :: work_2d - real :: Idt ! The inverse of the timestep [T-1 ~> s-1] - real :: ppt2mks - real, dimension(GV%ke) :: h2 - real :: h_neglect, h_neglect_edge - logical :: show_call_tree - type(tracer_type), pointer :: Tr => NULL() + real :: tr_column(GV%ke) ! A column of updated tracer concentrations [CU ~> Conc] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: work_conc ! The rate of change of concentrations [Conc T-1 ~> Conc s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: work_cont ! The rate of change of cell-integrated tracer + ! content [Conc H T-1 ~> Conc m s-1 or Conc kg m-2 s-1] or + ! cell thickness [H T-1 ~> m s-1 or kg m-2 s-1] + real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! The rate of change of column-integrated tracer + ! content [Conc H T-1 ~> Conc m s-1 or Conc kg m-2 s-1] + logical :: PCM(GV%ke) ! If true, do PCM remapping from a 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] + logical :: show_call_tree + type(tracer_type), pointer :: Tr => NULL() + integer :: i, j, k, m, nz, ntr show_call_tree = .false. if (present(debug)) show_call_tree = debug - if (show_call_tree) call callTree_enter("remap_all_state_vars(), MOM_ALE.F90") - ! If remap_uv_using_old_alg is .true. and u or v is requested, then we must have dxInterface. Otherwise, - ! u and v can be remapped without dxInterface - if ( .not. present(dxInterface) .and. (CS_ALE%remap_uv_using_old_alg .and. (present(u) .or. present(v))) ) then - call MOM_error(FATAL, "remap_all_state_vars: dxInterface must be present if using old algorithm "// & - "and u/v are to be remapped") - endif + if (show_call_tree) call callTree_enter("ALE_remap_tracers(), MOM_ALE.F90") - if (.not.CS_ALE%answers_2018) then - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - elseif (GV%Boussinesq) then - h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 - else - h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 - endif - - nz = GV%ke - ppt2mks = 0.001 + nz = GV%ke ntr = 0 ; if (associated(Reg)) ntr = Reg%ntr @@ -800,44 +818,55 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, work_cont(:,:,:) = 0.0 endif - ! Remap tracer + ! Remap all registered tracers, including temperature and salinity. if (ntr>0) then - if (show_call_tree) call callTree_waypoint("remapping tracers (remap_all_state_vars)") - !$OMP parallel do default(shared) private(h1,h2,u_column,Tr) + if (show_call_tree) call callTree_waypoint("remapping tracers (ALE_remap_tracers)") + !$OMP parallel do default(shared) private(h1,h2,tr_column,Tr,PCM,work_conc,work_cont,work_2d) do m=1,ntr ! For each tracer Tr => Reg%Tr(m) do j = G%jsc,G%jec ; do i = G%isc,G%iec ; if (G%mask2dT(i,j)>0.) then ! Build the start and final grids h1(:) = h_old(i,j,:) h2(:) = h_new(i,j,:) - call remapping_core_h(CS_remapping, nz, h1, Tr%t(i,j,:), nz, h2, & - u_column, h_neglect, h_neglect_edge) + 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, PCM_cell=PCM) + else + 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! + if (Tr%conc_underflow > 0.0) then ; do k=1,GV%ke + if (abs(tr_column(k)) < Tr%conc_underflow) tr_column(k) = 0.0 + enddo ; endif ! Intermediate steps for tendency of tracer concentration and tracer content. if (present(dt)) then if (Tr%id_remap_conc > 0) then do k=1,GV%ke - work_conc(i,j,k) = (u_column(k) - Tr%t(i,j,k)) * Idt + work_conc(i,j,k) = (tr_column(k) - Tr%t(i,j,k)) * Idt enddo endif if (Tr%id_remap_cont > 0 .or. Tr%id_remap_cont_2d > 0) then do k=1,GV%ke - work_cont(i,j,k) = (u_column(k)*h2(k) - Tr%t(i,j,k)*h1(k)) * Idt + work_cont(i,j,k) = (tr_column(k)*h2(k) - Tr%t(i,j,k)*h1(k)) * Idt enddo endif endif + ! update tracer concentration - Tr%t(i,j,:) = u_column(:) + Tr%t(i,j,:) = tr_column(:) endif ; enddo ; enddo ! tendency diagnostics. if (present(dt)) then if (Tr%id_remap_conc > 0) then - call post_data(Tr%id_remap_conc, work_conc, CS_ALE%diag) + call post_data(Tr%id_remap_conc, work_conc, CS%diag) endif if (Tr%id_remap_cont > 0) then - call post_data(Tr%id_remap_cont, work_cont, CS_ALE%diag) + call post_data(Tr%id_remap_cont, work_cont, CS%diag) endif + if (Tr%id_remap_cont_2d > 0) then do j = G%jsc,G%jec ; do i = G%isc,G%iec work_2d(i,j) = 0.0 @@ -845,135 +874,612 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, work_2d(i,j) = work_2d(i,j) + work_cont(i,j,k) enddo enddo ; enddo - call post_data(Tr%id_remap_cont_2d, work_2d, CS_ALE%diag) + call post_data(Tr%id_remap_cont_2d, work_2d, CS%diag) endif endif enddo ! m=1,ntr - endif ! endif for ntr > 0 + endif ! endif for ntr > 0 - if (show_call_tree) call callTree_waypoint("tracers remapped (remap_all_state_vars)") - ! Remap u velocity component - if ( present(u) ) then - !$OMP parallel do default(shared) private(h1,h2,dx,u_column) - do j = G%jsc,G%jec ; do I = G%iscB,G%iecB ; if (G%mask2dCu(I,j)>0.) then - ! Build the start and final grids - h1(:) = 0.5 * ( h_old(i,j,:) + h_old(i+1,j,:) ) - if (CS_ALE%remap_uv_using_old_alg) then - dx(:) = 0.5 * ( dxInterface(i,j,:) + dxInterface(i+1,j,:) ) - do k = 1, nz - h2(k) = max( 0., h1(k) + ( dx(k+1) - dx(k) ) ) - enddo - else - h2(:) = 0.5 * ( h_new(i,j,:) + h_new(i+1,j,:) ) - endif - if (associated(OBC)) then - if (OBC%segnum_u(I,j) .ne. 0) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - h1(:) = h_old(i,j,:) - h2(:) = h_new(i,j,:) - else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) - h1(:) = h_old(i+1,j,:) - h2(:) = h_new(i+1,j,:) - endif - endif - endif - call remapping_core_h(CS_remapping, nz, h1, u(I,j,:), nz, h2, & - u_column, h_neglect, h_neglect_edge) - u(I,j,:) = u_column(:) + if (CS%id_vert_remap_h > 0) call post_data(CS%id_vert_remap_h, h_old, CS%diag) + if ((CS%id_vert_remap_h_tendency > 0) .and. present(dt)) then + do k = 1, nz ; do j = G%jsc,G%jec ; do i = G%isc,G%iec + work_cont(i,j,k) = (h_new(i,j,k) - h_old(i,j,k))*Idt + enddo ; enddo ; enddo + call post_data(CS%id_vert_remap_h_tendency, work_cont, CS%diag) + endif + + if (show_call_tree) call callTree_leave("ALE_remap_tracers(), MOM_ALE.F90") + +end subroutine ALE_remap_tracers + +!> This routine sets the thicknesses at velocity points used for vertical remapping. +subroutine ALE_remap_set_h_vel(CS, G, GV, h_new, h_u, h_v, OBC, debug) + type(ALE_CS), intent(in) :: CS !< ALE control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness at tracer points of the + !! grid being interpolated to velocity + !! points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_u !< Grid thickness at zonal velocity + !! points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: h_v !< Grid thickness at meridional velocity + !! points [H ~> m or kg m-2] + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + logical, optional, intent(in) :: debug !< If true, show the call tree + + ! Local variables + logical :: show_call_tree + integer :: i, j, k + + show_call_tree = .false. + if (present(debug)) show_call_tree = debug + if (show_call_tree) call callTree_enter("ALE_remap_set_h_vel()") + + ! Build the u- and v-velocity grid thicknesses for remapping. + + !$OMP parallel do default(shared) + do k=1,GV%ke ; do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (G%mask2dCu(I,j)>0.) then + h_u(I,j,k) = 0.5*(h_new(i,j,k) + h_new(i+1,j,k)) + endif ; enddo ; enddo ; enddo + !$OMP parallel do default(shared) + do k=1,GV%ke ; do J=G%JscB,G%JecB ; do i=G%isc,G%iec ; if (G%mask2dCv(i,J)>0.) then + h_v(i,J,k) = 0.5*(h_new(i,j,k) + h_new(i,j+1,k)) + endif ; enddo ; enddo ; enddo + + ! Mask out blocked portions of velocity cells. + if (CS%partial_cell_vel_remap) call ALE_remap_set_h_vel_partial(CS, G, GV, h_new, h_u, h_v) + + ! Take open boundary conditions into account. + if (associated(OBC)) call ALE_remap_set_h_vel_OBC(G, GV, h_new, h_u, h_v, OBC) + + if (show_call_tree) call callTree_leave("ALE_remap_set_h_vel()") + +end subroutine ALE_remap_set_h_vel + +!> This routine sets the thicknesses at velocity points used for vertical remapping using a +!! combination of the old grid and interface movements. +subroutine ALE_remap_set_h_vel_via_dz(CS, G, GV, h_new, h_u, h_v, OBC, h_old, dzInterface, debug) + type(ALE_CS), intent(in) :: CS !< ALE control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness at tracer points of the + !! grid being interpolated to velocity + !! points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_u !< Grid thickness at zonal velocity + !! points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: h_v !< Grid thickness at meridional velocity + !! points [H ~> m or kg m-2] + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old !< Thickness of source grid when generating + !! the destination grid via the old + !! algorithm [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(in) :: dzInterface !< Change in interface position + !! [H ~> m or kg m-2] + logical, optional, intent(in) :: debug !< If true, show the call tree + + ! Local variables + logical :: show_call_tree + integer :: i, j, k + + show_call_tree = .false. + if (present(debug)) show_call_tree = debug + if (show_call_tree) call callTree_enter("ALE_remap_set_h_vel()") + + ! Build the u- and v-velocity grid thicknesses for remapping using the old grid and interface movement. + + !$OMP parallel do default(shared) + do k=1,GV%ke ; do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (G%mask2dCu(I,j)>0.) then + h_u(I,j,k) = max( 0., 0.5*(h_old(i,j,k) + h_old(i+1,j,k)) + & + 0.5 * (( dzInterface(i,j,k) + dzInterface(i+1,j,k) ) - & + ( dzInterface(i,j,k+1) + dzInterface(i+1,j,k+1) )) ) + endif ; enddo ; enddo ; enddo + + !$OMP parallel do default(shared) + do k=1,GV%ke ; do J=G%JscB,G%JecB ; do i=G%isc,G%iec ; if (G%mask2dCv(i,J)>0.) then + h_v(i,J,k) = max( 0., 0.5*(h_old(i,j,k) + h_old(i,j+1,k)) + & + 0.5 * (( dzInterface(i,j,k) + dzInterface(i,j+1,k) ) - & + ( dzInterface(i,j,k+1) + dzInterface(i,j+1,k+1) )) ) + endif ; enddo ; enddo ; enddo + + ! Mask out blocked portions of velocity cells. + if (CS%partial_cell_vel_remap) call ALE_remap_set_h_vel_partial(CS, G, GV, h_old, h_u, h_v) + + ! Take open boundary conditions into account. + if (associated(OBC)) call ALE_remap_set_h_vel_OBC(G, GV, h_new, h_u, h_v, OBC) + + if (show_call_tree) call callTree_leave("ALE_remap_set_h_vel()") + +end subroutine ALE_remap_set_h_vel_via_dz + +!> Mask out the thicknesses at velocity points where they are below the minimum depth +!! at adjacent tracer points +subroutine ALE_remap_set_h_vel_partial(CS, G, GV, h_mask, h_u, h_v) + type(ALE_CS), intent(in) :: CS !< ALE control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_mask !< Thickness at tracer points + !! used to apply the partial + !! cell masking [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_u !< Grid thickness at zonal velocity + !! points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: h_v !< Grid thickness at meridional velocity + !! points [H ~> m or kg m-2] + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: h_tot ! The vertically summed thicknesses [H ~> m or kg m-2] + real :: h_mask_vel ! A depth below which the thicknesses at a velocity point are masked out [H ~> m or kg m-2] + integer :: i, j, k + + h_tot(:,:) = 0.0 + do k=1,GV%ke ; do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + h_tot(i,j) = h_tot(i,j) + h_mask(i,j,k) + enddo ; enddo ; enddo + + !$OMP parallel do default(shared) private(h_mask_vel) + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (G%mask2dCu(I,j)>0.) then + h_mask_vel = min(h_tot(i,j), h_tot(i+1,j)) + call apply_partial_cell_mask(h_u(I,j,:), h_mask_vel) + endif ; enddo ; enddo + + !$OMP parallel do default(shared) private(h_mask_vel) + do J=G%JscB,G%JecB ; do i=G%isc,G%iec ; if (G%mask2dCv(i,J)>0.) then + h_mask_vel = min(h_tot(i,j), h_tot(i,j+1)) + call apply_partial_cell_mask(h_v(i,J,:), h_mask_vel) + endif ; enddo ; enddo + +end subroutine ALE_remap_set_h_vel_partial + +! Reset thicknesses at velocity points on open boundary condition segments +subroutine ALE_remap_set_h_vel_OBC(G, GV, h_new, h_u, h_v, OBC) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness at tracer points of the + !! grid being interpolated to velocity + !! points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_u !< Grid thickness at zonal velocity + !! points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: h_v !< Grid thickness at meridional velocity + !! points [H ~> m or kg m-2] + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + + ! Local variables + integer :: i, j, k, nz, is_OBC, ie_OBC, js_OBC, je_OBC + + if (.not.associated(OBC)) return + + nz = GV%ke + + ! Take open boundary conditions into account. + if (OBC%u_E_OBCs_on_PE) then + js_OBC = max(G%jsc, OBC%js_u_E_obc) ; je_OBC = min(G%jec, OBC%je_u_E_obc) + Is_OBC = max(G%IscB, OBC%Is_u_E_obc) ; Ie_OBC = min(G%IecB, OBC%Ie_u_E_obc) + !$OMP parallel do default(shared) + do j=js_OBC,je_OBC ; do I=Is_OBC,Ie_OBC ; if (OBC%segnum_u(I,j) > 0) then ! OBC_DIRECTION_E + do k=1,nz ; h_u(I,j,k) = h_new(i,j,k) ; enddo + endif ; enddo ; enddo + endif + if (OBC%u_W_OBCs_on_PE) then + js_OBC = max(G%jsc, OBC%js_u_W_obc) ; je_OBC = min(G%jec, OBC%je_u_W_obc) + Is_OBC = max(G%IscB, OBC%Is_u_W_obc) ; Ie_OBC = min(G%IecB, OBC%Ie_u_W_obc) + !$OMP parallel do default(shared) + do j=js_OBC,je_OBC ; do I=Is_OBC,Ie_OBC ; if (OBC%segnum_u(I,j) < 0) then ! OBC_DIRECTION_W + do k=1,nz ; h_u(I,j,k) = h_new(i+1,j,k) ; enddo endif ; enddo ; enddo endif - if (show_call_tree) call callTree_waypoint("u remapped (remap_all_state_vars)") - - ! Remap v velocity component - if ( present(v) ) then - !$OMP parallel do default(shared) private(h1,h2,dx,u_column) - do J = G%jscB,G%jecB ; do i = G%isc,G%iec ; if (G%mask2dCv(i,j)>0.) then - ! Build the start and final grids - h1(:) = 0.5 * ( h_old(i,j,:) + h_old(i,j+1,:) ) - if (CS_ALE%remap_uv_using_old_alg) then - dx(:) = 0.5 * ( dxInterface(i,j,:) + dxInterface(i,j+1,:) ) - do k = 1, nz - h2(k) = max( 0., h1(k) + ( dx(k+1) - dx(k) ) ) - enddo + if (OBC%v_N_OBCs_on_PE) then + Js_OBC = max(G%JscB, OBC%Js_v_N_obc) ; Je_OBC = min(G%JecB, OBC%Je_v_N_obc) + is_OBC = max(G%isc, OBC%is_v_N_obc) ; ie_OBC = min(G%iec, OBC%ie_v_N_obc) + !$OMP parallel do default(shared) + do J=Js_OBC,Je_OBC ; do i=is_OBC,ie_OBC ; if (OBC%segnum_v(i,J) > 0) then ! OBC_DIRECTION_N + do k=1,nz ; h_v(i,J,k) = h_new(i,j,k) ; enddo + endif ; enddo ; enddo + endif + if (OBC%v_S_OBCs_on_PE) then + Js_OBC = max(G%JscB, OBC%Js_v_S_obc) ; Je_OBC = min(G%JecB, OBC%Je_v_S_obc) + is_OBC = max(G%isc, OBC%is_v_S_obc) ; ie_OBC = min(G%iec, OBC%ie_v_S_obc) + !$OMP parallel do default(shared) + do J=Js_OBC,Je_OBC ; do i=is_OBC,ie_OBC ; if (OBC%segnum_v(i,J) < 0) then ! OBC_DIRECTION_S + do k=1,nz ; h_v(i,J,k) = h_new(i,j+1,k) ; enddo + endif ; enddo ; enddo + endif + +end subroutine ALE_remap_set_h_vel_OBC + +!> This routine remaps velocity components between the old and the new grids, +!! with thicknesses at velocity points taken to be arithmetic averages of tracer thicknesses. +!! This routine may be called during initialization of the model at time=0, to +!! remap initial conditions to the model grid. It is also called during a +!! time step to update the state. +subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u, v, debug, & + dt, allow_preserve_variance) + type(ALE_CS), intent(in) :: CS !< ALE control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old_u !< Source grid thickness at zonal + !! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: h_old_v !< Source grid thickness at meridional + !! velocity points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new_u !< Destination grid thickness at zonal + !! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: h_new_v !< Destination grid thickness at meridional + !! velocity points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: u !< Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: v !< Meridional velocity [L T-1 ~> m s-1] + logical, optional, intent(in) :: debug !< If true, show the call tree + real, optional, intent(in) :: dt !< time step for diagnostics [T ~> s] + logical, optional, intent(in) :: allow_preserve_variance !< If true, enables ke-conserving + !! correction + + ! Local variables + real :: h_mask_vel ! A depth below which the thicknesses at a velocity point are masked out [H ~> m or kg m-2] + real :: u_src(GV%ke) ! A column of u-velocities on the source grid [L T-1 ~> m s-1] + real :: u_tgt(GV%ke) ! A column of u-velocities on the target grid [L T-1 ~> m s-1] + real :: v_src(GV%ke) ! A column of v-velocities on the source grid [L T-1 ~> m s-1] + 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 :: rescale_coef ! Factor that scales the baroclinic velocity to conserve ke [nondim] + real :: u_bt, v_bt ! Depth-averaged velocity components [L T-1 ~> m s-1] + real :: ke_c_src, ke_c_tgt ! \int [u_c or v_c]^2 dz on src and tgt grids [H L2 T-2 ~> m3 s-2] + real, dimension(SZIB_(G),SZJ_(G)) :: du2h_tot ! The rate of change of vertically integrated + ! 0.5 * rho0 * u**2 [R Z L2 T-3 ~> W m-2] + real, dimension(SZI_(G),SZJB_(G)) :: dv2h_tot ! The rate of change of vertically integrated + ! 0.5 * rho0 * v**2 [R Z L2 T-3 ~> W m-2] + real :: u2h_tot, v2h_tot ! The vertically integrated u**2 and v**2 [H L2 T-2 ~> m3 s-2 or kg s-2] + real :: I_dt ! 1 / dt [T-1 ~> s-1] + logical :: variance_option ! Contains the value of allow_preserve_variance when present, else false + logical :: show_call_tree + integer :: i, j, k, nz + + show_call_tree = .false. + if (present(debug)) show_call_tree = debug + if (show_call_tree) call callTree_enter("ALE_remap_velocities()") + + ! Setup related to KE conservation + variance_option = .false. + if (present(allow_preserve_variance)) variance_option=allow_preserve_variance + if (present(dt)) I_dt = 1.0 / dt + + if (CS%id_remap_delta_integ_u2>0) du2h_tot(:,:) = 0. + if (CS%id_remap_delta_integ_v2>0) dv2h_tot(:,:) = 0. + + if (((CS%id_remap_delta_integ_u2>0) .or. (CS%id_remap_delta_integ_v2>0)) .and. .not.present(dt))& + call MOM_error(FATAL, "ALE KE diagnostics requires passing dt into ALE_remap_velocities") + + nz = GV%ke + + ! --- Remap u profiles from the source vertical grid onto the new target grid. + + !$OMP parallel do default(shared) private(h1,h2,u_src,h_mask_vel,u_tgt, & + !$OMP u_bt,ke_c_src,ke_c_tgt,rescale_coef, & + !$OMP u2h_tot,v2h_tot) + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (G%mask2dCu(I,j)>0.) then + ! Make a 1-d copy of the start and final grids and the source velocity + do k=1,nz + h1(k) = h_old_u(I,j,k) + h2(k) = h_new_u(I,j,k) + u_src(k) = u(I,j,k) + enddo + + if (CS%id_remap_delta_integ_u2>0) then + u2h_tot = 0. + do k=1,nz + u2h_tot = u2h_tot - h1(k) * (u_src(k)**2) + enddo + endif + + call remapping_core_h(CS%vel_remapCS, nz, h1, u_src, nz, h2, u_tgt) + + if (variance_option .and. CS%conserve_ke) then + ! Conserve ke_u by correcting baroclinic component. + ! Assumes total depth doesn't change during remap, and + ! that \int u(z) dz doesn't change during remap. + ! First get barotropic component + u_bt = 0.0 + do k=1,nz + u_bt = u_bt + h2(k) * u_tgt(k) ! Dimensions [H L T-1 ~> m2 s-1 or kg m-1 s-1] + enddo + u_bt = u_bt / (sum(h2(1:nz)) + GV%H_subroundoff) ! Dimensions return to [L T-1 ~> m s-1] + ! Next get baroclinic ke = \int (u-u_bt)^2 from source and target + ke_c_src = 0.0 + ke_c_tgt = 0.0 + do k=1,nz + ke_c_src = ke_c_src + h1(k) * (u_src(k) - u_bt)**2 + ke_c_tgt = ke_c_tgt + h2(k) * (u_tgt(k) - u_bt)**2 + enddo + ! Next rescale baroclinic component on target grid to conserve ke + ! The values 1.5625 = 1.25**2 and 1.25 below mean that the KE-conserving + ! correction cannot amplify the baroclinic part of velocity by more + ! than 25%. This threshold is somewhat arbitrary. It was added to + ! prevent unstable behavior when the amplification factor is large. + if (ke_c_src < 1.5625 * ke_c_tgt) then + rescale_coef = sqrt(ke_c_src / ke_c_tgt) else - h2(:) = 0.5 * ( h_new(i,j,:) + h_new(i,j+1,:) ) + rescale_coef = 1.25 endif - if (associated(OBC)) then - if (OBC%segnum_v(i,J) .ne. 0) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - h1(:) = h_old(i,j,:) - h2(:) = h_new(i,j,:) - else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) - h1(:) = h_old(i,j+1,:) - h2(:) = h_new(i,j+1,:) - endif - endif + do k=1,nz + u_tgt(k) = u_bt + rescale_coef * (u_tgt(k) - u_bt) + enddo + endif + + if (CS%id_remap_delta_integ_u2>0) then + do k=1,nz + u2h_tot = u2h_tot + h2(k) * (u_tgt(k)**2) + enddo + du2h_tot(I,j) = u2h_tot * I_dt + endif + + 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) + + ! Copy the column of new velocities back to the 3-d array + do k=1,nz + u(I,j,k) = u_tgt(k) + enddo !k + endif ; enddo ; enddo + + if (CS%id_remap_delta_integ_u2>0) call post_data(CS%id_remap_delta_integ_u2, du2h_tot, CS%diag) + + if (show_call_tree) call callTree_waypoint("u remapped (ALE_remap_velocities)") + + + ! --- Remap v profiles from the source vertical grid onto the new target grid. + + !$OMP parallel do default(shared) private(h1,h2,v_src,h_mask_vel,v_tgt, & + !$OMP v_bt,ke_c_src,ke_c_tgt,rescale_coef, & + !$OMP u2h_tot,v2h_tot) + do J=G%JscB,G%JecB ; do i=G%isc,G%iec ; if (G%mask2dCv(i,J)>0.) then + + do k=1,nz + h1(k) = h_old_v(i,J,k) + h2(k) = h_new_v(i,J,k) + v_src(k) = v(i,J,k) + enddo + + if (CS%id_remap_delta_integ_v2>0) then + v2h_tot = 0. + do k=1,nz + v2h_tot = v2h_tot - h1(k) * (v_src(k)**2) + enddo + endif + + call remapping_core_h(CS%vel_remapCS, nz, h1, v_src, nz, h2, v_tgt) + + if (variance_option .and. CS%conserve_ke) then + ! Conserve ke_v by correcting baroclinic component. + ! Assumes total depth doesn't change during remap, and + ! that \int v(z) dz doesn't change during remap. + ! First get barotropic component + v_bt = 0.0 + do k=1,nz + v_bt = v_bt + h2(k) * v_tgt(k) ! Dimensions [H L T-1 ~> m2 s-1 or kg m-1 s-1] + enddo + v_bt = v_bt / (sum(h2(1:nz)) + GV%H_subroundoff) ! Dimensions return to [L T-1 ~> m s-1] + ! Next get baroclinic ke = \int (u-u_bt)^2 from source and target + ke_c_src = 0.0 + ke_c_tgt = 0.0 + do k=1,nz + ke_c_src = ke_c_src + h1(k) * (v_src(k) - v_bt)**2 + ke_c_tgt = ke_c_tgt + h2(k) * (v_tgt(k) - v_bt)**2 + enddo + ! Next rescale baroclinic component on target grid to conserve ke + if (ke_c_src < 1.5625 * ke_c_tgt) then + rescale_coef = sqrt(ke_c_src / ke_c_tgt) + else + rescale_coef = 1.25 endif - call remapping_core_h(CS_remapping, nz, h1, v(i,J,:), nz, h2, & - u_column, h_neglect, h_neglect_edge) - v(i,J,:) = u_column(:) - endif ; enddo ; enddo - endif + do k=1,nz + v_tgt(k) = v_bt + rescale_coef * (v_tgt(k) - v_bt) + enddo + endif - if (CS_ALE%id_vert_remap_h > 0) call post_data(CS_ALE%id_vert_remap_h, h_old, CS_ALE%diag) - if ((CS_ALE%id_vert_remap_h_tendency > 0) .and. present(dt)) then - do k = 1, nz ; do j = G%jsc,G%jec ; do i = G%isc,G%iec - work_cont(i,j,k) = (h_new(i,j,k) - h_old(i,j,k))*Idt - enddo ; enddo ; enddo - call post_data(CS_ALE%id_vert_remap_h_tendency, work_cont, CS_ALE%diag) - endif - if (show_call_tree) call callTree_waypoint("v remapped (remap_all_state_vars)") - if (show_call_tree) call callTree_leave("remap_all_state_vars()") + if (CS%id_remap_delta_integ_v2>0) then + do k=1,nz + v2h_tot = v2h_tot + h2(k) * (v_tgt(k)**2) + enddo + dv2h_tot(I,j) = v2h_tot * I_dt + endif + + 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) + endif + + ! Copy the column of new velocities back to the 3-d array + do k=1,nz + v(i,J,k) = v_tgt(k) + enddo !k + endif ; enddo ; enddo + + if (CS%id_remap_delta_integ_v2>0) call post_data(CS%id_remap_delta_integ_v2, dv2h_tot, CS%diag) + + if (show_call_tree) call callTree_waypoint("v remapped (ALE_remap_velocities)") + if (show_call_tree) call callTree_leave("ALE_remap_velocities()") + +end subroutine ALE_remap_velocities + +!> Interpolate to find an updated array of values at interfaces after remapping. +subroutine ALE_remap_interface_vals(CS, G, GV, h_old, h_new, int_val) + type(ALE_CS), intent(in) :: CS !< ALE control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_old !< Thickness of source grid + !! [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness of destination grid + !! [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(inout) :: int_val !< The interface values to interpolate [A] + + real :: val_src(GV%ke+1) ! A column of interface values on the source grid [A] + real :: val_tgt(GV%ke+1) ! A column of interface values on the target grid [A] + real :: h_src(GV%ke) ! A column of source grid layer thicknesses [H ~> m or kg m-2] + real :: h_tgt(GV%ke) ! A column of target grid layer thicknesses [H ~> m or kg m-2] + integer :: i, j, k, nz + + nz = GV%ke + + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (G%mask2dT(i,j)>0.) then + do k=1,nz + h_src(k) = h_old(i,j,k) + h_tgt(k) = h_new(i,j,k) + enddo + + do K=1,nz+1 + val_src(K) = int_val(i,j,K) + enddo + + call interpolate_column(nz, h_src, val_src, nz, h_tgt, val_tgt, .false.) + + do K=1,nz+1 + int_val(i,j,K) = val_tgt(K) + enddo + endif ; enddo ; enddo + +end subroutine ALE_remap_interface_vals + +!> Interpolate to find an updated array of values at vertices of tracer cells after remapping. +subroutine ALE_remap_vertex_vals(CS, G, GV, h_old, h_new, vert_val) + type(ALE_CS), intent(in) :: CS !< ALE control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_old !< Thickness of source grid + !! [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness of destination grid + !! [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)+1), & + intent(inout) :: vert_val !< The interface values to interpolate [A] + + real :: val_src(GV%ke+1) ! A column of interface values on the source grid [A] + real :: val_tgt(GV%ke+1) ! A column of interface values on the target grid [A] + real :: h_src(GV%ke) ! A column of source grid layer thicknesses [H ~> m or kg m-2] + real :: h_tgt(GV%ke) ! A column of target grid layer thicknesses [H ~> m or kg m-2] + real :: I_mask_sum ! The inverse of the tracer point masks surrounding a corner [nondim] + integer :: i, j, k, nz + + nz = GV%ke + + do J=G%JscB,G%JecB ; do I=G%IscB,G%IecB + if ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + (G%mask2dT(i+1,j) + G%mask2dT(i,j+1)) > 0.0 ) then + I_mask_sum = 1.0 / ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + & + (G%mask2dT(i+1,j) + G%mask2dT(i,j+1))) + + do k=1,nz + h_src(k) = ((G%mask2dT(i,j) * h_old(i,j,k) + G%mask2dT(i+1,j+1) * h_old(i+1,j+1,k)) + & + (G%mask2dT(i+1,j) * h_old(i+1,j,k) + G%mask2dT(i,j+1) * h_old(i,j+1,k)) ) * I_mask_sum + h_tgt(k) = ((G%mask2dT(i,j) * h_new(i,j,k) + G%mask2dT(i+1,j+1) * h_new(i+1,j+1,k)) + & + (G%mask2dT(i+1,j) * h_new(i+1,j,k) + G%mask2dT(i,j+1) * h_new(i,j+1,k)) ) * I_mask_sum + enddo + + do K=1,nz+1 + val_src(K) = vert_val(I,J,K) + enddo + + call interpolate_column(nz, h_src, val_src, nz, h_tgt, val_tgt, .false.) + + do K=1,nz+1 + vert_val(I,J,K) = val_tgt(K) + enddo + endif ; enddo ; enddo -end subroutine remap_all_state_vars +end subroutine ALE_remap_vertex_vals + +!> Mask out thicknesses to 0 when their running sum exceeds a specified value. +subroutine apply_partial_cell_mask(h1, h_mask) + real, dimension(:), intent(inout) :: h1 !< A column of thicknesses to be masked out after their + !! running vertical sum exceeds h_mask [H ~> m or kg m-2] + real, intent(in) :: h_mask !< The depth after which the thicknesses in h1 are + !! masked out [H ~> m or kg m-2] + ! Local variables + real :: h1_rsum ! The running sum of h1 [H ~> m or kg m-2] + integer :: k + + h1_rsum = 0.0 + do k=1,size(h1) + if (h1(k) > h_mask - h1_rsum) then + ! This thickness is reduced because it extends below the shallower neighboring bathymetry. + h1(k) = max(h_mask - h1_rsum, 0.0) + h1_rsum = h_mask + else + h1_rsum = h1_rsum + h1(k) + endif + enddo +end subroutine apply_partial_cell_mask + + +!> Zero out velocities in a column in very thin layers near the seafloor +subroutine mask_near_bottom_vel(vel, h, h_BBL, h_thin, nk) + integer, intent(in) :: nk !< The number of layers in this column + real, intent(inout) :: vel(nk) !< The velocity component being zeroed out [L T-1 ~> m s-1] + real, intent(in) :: h(nk) !< The layer thicknesses at velocity points [H ~> m or kg m-2] + real, intent(in) :: h_BBL !< The thickness of the near-bottom region over which to apply + !! the filtering [H ~> m or kg m-2] + real, intent(in) :: h_thin !< A layer thickness below which the filtering is applied [H ~> m or kg m-2] + + ! Local variables + real :: h_from_bot ! The distance between the top of a layer and the seafloor [H ~> m or kg m-2] + integer :: k + + if ((h_BBL < 0.0) .or. (h_thin < 0.0)) return + + h_from_bot = 0.0 + do k=nk,1,-1 + h_from_bot = h_from_bot + h(k) + if (h_from_bot > h_BBL) return + ! Set the velocity to zero in thin, near-bottom layers. + if (h(k) <= h_thin) vel(k) = 0.0 + enddo !k + +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 ) +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 integer, intent(in) :: nk_src !< Number of levels on source grid real, dimension(SZI_(G),SZJ_(G),nk_src), intent(in) :: h_src !< Level thickness of source grid - !! [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),nk_src), intent(in) :: s_src !< Scalar on source grid - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)),intent(in) :: h_dst !< Level thickness of destination grid - !! [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)),intent(inout) :: s_dst !< Scalar on destination grid + !! [H ~> m or kg m-2] or other units + !! if H_neglect is provided + real, dimension(SZI_(G),SZJ_(G),nk_src), intent(in) :: s_src !< Scalar on source grid, in arbitrary units [A] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)),intent(in) :: h_dst !< Level thickness of destination grid in the + !! same units as h_src, often [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)),intent(inout) :: s_dst !< Scalar on destination grid, in the same + !! arbitrary units as s_src [A] logical, optional, intent(in) :: all_cells !< If false, only reconstruct for !! non-vanished cells. Use all vanished !! 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. - ! Local variables + ! Local variables integer :: i, j, k, n_points - real :: dx(GV%ke+1) - real :: h_neglect, h_neglect_edge - logical :: ignore_vanished_layers, use_remapping_core_w, use_2018_remap + real :: dx(GV%ke+1) ! Change in interface position [H ~> m or kg m-2] + 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 (.not.use_2018_remap) 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 !$OMP parallel do default(shared) firstprivate(n_points,dx) do j = G%jsc,G%jec ; do i = G%isc,G%iec @@ -988,10 +1494,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_neglect, h_neglect_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_neglect, h_neglect_edge) + GV%ke, h_dst(i,j,:), s_dst(i,j,:)) endif else s_dst(i,j,:) = 0. @@ -1008,13 +1514,13 @@ subroutine TS_PLM_edge_values( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(ALE_CS), intent(inout) :: CS !< module control structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: S_t !< Salinity at the top edge of each layer + intent(inout) :: S_t !< Salinity at the top edge of each layer [S ~> ppt] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: S_b !< Salinity at the bottom edge of each layer + intent(inout) :: S_b !< Salinity at the bottom edge of each layer [S ~> ppt] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: T_t !< Temperature at the top edge of each layer + intent(inout) :: T_t !< Temperature at the top edge of each layer [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: T_b !< Temperature at the bottom edge of each layer + intent(inout) :: T_b !< Temperature at the bottom edge of each layer [C ~> degC] type(thermo_var_ptrs), intent(in) :: tv !< thermodynamics structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< layer thickness [H ~> m or kg m-2] @@ -1035,20 +1541,20 @@ subroutine ALE_PLM_edge_values( CS, G, GV, h, Q, bdry_extrap, Q_t, Q_b ) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< layer thickness [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: Q !< 3d scalar array + intent(in) :: Q !< 3d scalar array, in arbitrary units [A] logical, intent(in) :: bdry_extrap !< If true, use high-order boundary !! extrapolation within boundary cells real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: Q_t !< Scalar at the top edge of each layer + intent(inout) :: Q_t !< Scalar at the top edge of each layer [A] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: Q_b !< Scalar at the bottom edge of each layer + intent(inout) :: Q_b !< Scalar at the bottom edge of each layer [A] ! Local variables integer :: i, j, k - real :: slp(GV%ke) - real :: mslp - real :: h_neglect + real :: slp(GV%ke) ! Tracer slope times the cell width [A] + real :: mslp ! Monotonized tracer slope times the cell width [A] + real :: h_neglect ! Tiny thicknesses used in remapping [H ~> m or kg m-2] - if (.not.CS%answers_2018) then + if (CS%answer_date >= 20190101) then h_neglect = GV%H_subroundoff elseif (GV%Boussinesq) then h_neglect = GV%m_to_H*1.0e-30 @@ -1060,7 +1566,8 @@ subroutine ALE_PLM_edge_values( CS, G, GV, h, Q, bdry_extrap, Q_t, Q_b ) do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 slp(1) = 0. do k = 2, GV%ke-1 - slp(k) = PLM_slope_wa(h(i,j,k-1), h(i,j,k), h(i,j,k+1), h_neglect, Q(i,j,k-1), Q(i,j,k), Q(i,j,k+1)) + slp(k) = PLM_slope_wa(h(i,j,k-1), h(i,j,k), h(i,j,k+1), h_neglect, & + Q(i,j,k-1), Q(i,j,k), Q(i,j,k+1)) enddo slp(GV%ke) = 0. @@ -1073,7 +1580,8 @@ subroutine ALE_PLM_edge_values( CS, G, GV, h, Q, bdry_extrap, Q_t, Q_b ) mslp = - PLM_extrapolate_slope(h(i,j,2), h(i,j,1), h_neglect, Q(i,j,2), Q(i,j,1)) Q_t(i,j,1) = Q(i,j,1) - 0.5 * mslp Q_b(i,j,1) = Q(i,j,1) + 0.5 * mslp - mslp = PLM_extrapolate_slope(h(i,j,GV%ke-1), h(i,j,GV%ke), h_neglect, Q(i,j,GV%ke-1), Q(i,j,GV%ke)) + mslp = PLM_extrapolate_slope(h(i,j,GV%ke-1), h(i,j,GV%ke), h_neglect, & + Q(i,j,GV%ke-1), Q(i,j,GV%ke)) Q_t(i,j,GV%ke) = Q(i,j,GV%ke) - 0.5 * mslp Q_b(i,j,GV%ke) = Q(i,j,GV%ke) + 0.5 * mslp else @@ -1094,13 +1602,13 @@ subroutine TS_PPM_edge_values( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(ALE_CS), intent(inout) :: CS !< module control structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: S_t !< Salinity at the top edge of each layer + intent(inout) :: S_t !< Salinity at the top edge of each layer [S ~> ppt] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: S_b !< Salinity at the bottom edge of each layer + intent(inout) :: S_b !< Salinity at the bottom edge of each layer [S ~> ppt] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: T_t !< Temperature at the top edge of each layer + intent(inout) :: T_t !< Temperature at the top edge of each layer [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: T_b !< Temperature at the bottom edge of each layer + intent(inout) :: T_b !< Temperature at the bottom edge of each layer [C ~> degC] type(thermo_var_ptrs), intent(in) :: tv !< thermodynamics structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< layer thicknesses [H ~> m or kg m-2] @@ -1110,14 +1618,14 @@ subroutine TS_PPM_edge_values( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap ! Local variables integer :: i, j, k real :: hTmp(GV%ke) ! A 1-d copy of h [H ~> m or kg m-2] - real :: tmp(GV%ke) ! A 1-d copy of a column of temperature [degC] or salinity [ppt] + real :: tmp(GV%ke) ! A 1-d copy of a column of temperature [C ~> degC] or salinity [S ~> ppt] real, dimension(CS%nk,2) :: & - ppol_E ! Edge value of polynomial in [degC] or [ppt] + ppol_E ! Edge value of polynomial in [C ~> degC] or [S ~> ppt] real, dimension(CS%nk,3) :: & - ppol_coefs ! Coefficients of polynomial, all in [degC] or [ppt] + ppol_coefs ! Coefficients of polynomial, all in [C ~> degC] or [S ~> ppt] real :: h_neglect, h_neglect_edge ! Tiny thicknesses [H ~> m or kg m-2] - if (.not.CS%answers_2018) then + 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 @@ -1137,11 +1645,11 @@ subroutine TS_PPM_edge_values( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap ppol_E(:,:) = 0.0 ppol_coefs(:,:) = 0.0 call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppol_E, h_neglect=h_neglect_edge, & - answers_2018=CS%answers_2018 ) + answer_date=CS%answer_date ) call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect, & - answers_2018=CS%answers_2018 ) + answer_date=CS%answer_date ) if (bdry_extrap) & - call PPM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + call PPM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) do k = 1,GV%ke S_t(i,j,k) = ppol_E(k,1) @@ -1152,17 +1660,17 @@ subroutine TS_PPM_edge_values( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap ppol_E(:,:) = 0.0 ppol_coefs(:,:) = 0.0 tmp(:) = tv%T(i,j,:) - if (CS%answers_2018) then + if (CS%answer_date < 20190101) then call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppol_E, h_neglect=1.0e-10*GV%m_to_H, & - answers_2018=CS%answers_2018 ) + answer_date=CS%answer_date ) else call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppol_E, h_neglect=GV%H_subroundoff, & - answers_2018=CS%answers_2018 ) + answer_date=CS%answer_date ) endif call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect, & - answers_2018=CS%answers_2018 ) + answer_date=CS%answer_date ) if (bdry_extrap) & - call PPM_boundary_extrapolation(GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + call PPM_boundary_extrapolation(GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) do k = 1,GV%ke T_t(i,j,k) = ppol_E(k,1) @@ -1173,9 +1681,49 @@ subroutine TS_PPM_edge_values( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap end subroutine TS_PPM_edge_values +!> Calculate edge values (top and bottom of layer) for T and S consistent with a PLM reconstruction +!! in the vertical direction that uses weighted least squares for the slope. +subroutine TS_PLM_WLS_edge_values(CS, S_t, S_b, T_t, T_b, G, GV, tv, h) + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(ALE_CS), intent(inout) :: CS !< module control structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: S_t !< Salinity at the top edge of each layer [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: S_b !< Salinity at the bottom edge of each layer [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: T_t !< Temperature at the top edge of each layer [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: T_b !< Temperature at the bottom edge of each layer [C ~> degC] + type(thermo_var_ptrs), intent(in) :: tv !< thermodynamics structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< layer thickness [H ~> m or kg m-2] + ! Local variables + integer :: i, j, k + type(PLM_WLS) :: recon !< A PLM-WLS reconstruction + + call recon%init(GV%ke, h_neglect=GV%H_subroundoff) + + !$OMP parallel do default(shared) firstprivate(recon) + do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 + + call recon%reconstruct(h(i,j,:), tv%T(i,j,:)) + T_t(i,j,:) = recon%ul(:) + T_b(i,j,:) = recon%ur(:) + + call recon%reconstruct(h(i,j,:), tv%S(i,j,:)) + S_t(i,j,:) = recon%ul(:) + S_b(i,j,:) = recon%ur(:) + + enddo ; enddo + + call recon%destroy() + +end subroutine TS_PLM_WLS_edge_values !> Initializes regridding for the main ALE algorithm -subroutine ALE_initRegridding(GV, US, max_depth, param_file, mdl, regridCS) +subroutine ALE_initRegridding(G, GV, US, max_depth, param_file, mdl, regridCS) + type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(in) :: max_depth !< The maximum depth of the ocean [Z ~> m]. @@ -1191,7 +1739,7 @@ subroutine ALE_initRegridding(GV, US, max_depth, param_file, mdl, regridCS) trim(regriddingCoordinateModeDoc), & default=DEFAULT_COORDINATE_MODE, fail_if_missing=.true.) - call initialize_regridding(regridCS, GV, US, max_depth, param_file, mdl, coord_mode, '', '') + call initialize_regridding(regridCS, G, GV, US, max_depth, param_file, mdl, coord_mode, '', '') end subroutine ALE_initRegridding @@ -1199,7 +1747,9 @@ end subroutine ALE_initRegridding function ALE_getCoordinate( CS ) type(ALE_CS), pointer :: CS !< module control structure - real, dimension(CS%nk+1) :: ALE_getCoordinate + real, dimension(CS%nk+1) :: ALE_getCoordinate !< The coordinate positions, in the appropriate units + !! of the target coordinate, e.g. [Z ~> m] for z*, + !! non-dimensional for sigma, etc. ALE_getCoordinate(:) = getCoordinateInterfaces( CS%regridCS, undo_scaling=.true. ) end function ALE_getCoordinate @@ -1229,7 +1779,7 @@ subroutine ALE_update_regrid_weights( dt, CS ) real, intent(in) :: dt !< Time-step used between ALE calls [T ~> s] type(ALE_CS), pointer :: CS !< ALE control structure ! Local variables - real :: w ! An implicit weighting estimate. + real :: w ! An implicit weighting estimate [nondim] if (associated(CS)) then w = 0.0 @@ -1256,7 +1806,7 @@ subroutine ALE_updateVerticalGridType(CS, GV) GV%zAxisUnits = getCoordinateUnits( CS%regridCS ) GV%zAxisLongName = getCoordinateShortName( CS%regridCS ) GV%direction = -1 ! Because of ferret in z* mode. Need method to set - ! as function of coordinae mode. + ! as function of coordinate mode. end subroutine ALE_updateVerticalGridType @@ -1270,41 +1820,31 @@ subroutine ALE_writeCoordinateFile( CS, GV, directory ) character(len=*), intent(in) :: directory !< directory for writing grid info character(len=240) :: filepath - type(vardesc) :: vars(2) - type(fieldtype) :: fields(2) - type(file_type) :: IO_handle ! The I/O handle of the fileset - real :: ds(GV%ke), dsi(GV%ke+1) - - filepath = trim(directory) // trim("Vertical_coordinate") - ds(:) = getCoordinateResolution( CS%regridCS, undo_scaling=.true. ) - dsi(1) = 0.5*ds(1) - dsi(2:GV%ke) = 0.5*( ds(1:GV%ke-1) + ds(2:GV%ke) ) - dsi(GV%ke+1) = 0.5*ds(GV%ke) - - vars(1) = var_desc('ds', getCoordinateUnits( CS%regridCS ), & - 'Layer Coordinate Thickness','1','L','1') - vars(2) = var_desc('ds_interface', getCoordinateUnits( CS%regridCS ), & - 'Layer Center Coordinate Separation','1','i','1') - - call create_file(IO_handle, trim(filepath), vars, 2, fields, SINGLE_FILE, GV=GV) - call write_field(IO_handle, fields(1), ds) - call write_field(IO_handle, fields(2), dsi) - call close_file(IO_handle) + + filepath = trim(directory) // trim("Vertical_coordinate.nc") + + call write_regrid_file(CS%regridCS, GV, filepath) end subroutine ALE_writeCoordinateFile !> Set h to coordinate values for fixed coordinate systems -subroutine ALE_initThicknessToCoord( CS, G, GV, h ) +subroutine ALE_initThicknessToCoord( CS, G, GV, h, height_units ) type(ALE_CS), intent(inout) :: CS !< module control structure type(ocean_grid_type), intent(in) :: G !< module grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: h !< layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: h !< layer thickness in thickness units + !! [H ~> m or kg m-2] or height units [Z ~> m] + logical, optional, intent(in) :: height_units !< If present and true, the + !! thicknesses are in height units ! Local variables - integer :: i, j, k + real :: scale ! A scaling value for the thicknesses [nondim] or [H Z-1 ~> nondim or kg m-3] + integer :: i, j + scale = GV%Z_to_H + if (present(height_units)) then ; if (height_units) scale = 1.0 ; endif do j = G%jsd,G%jed ; do i = G%isd,G%ied - h(i,j,:) = GV%Z_to_H * getStaticThickness( CS%regridCS, 0., G%bathyT(i,j)+G%Z_ref ) + h(i,j,:) = scale * getStaticThickness( CS%regridCS, 0., max(G%meanSL(i,j)+G%bathyT(i,j), 0.0) ) enddo ; enddo end subroutine ALE_initThicknessToCoord diff --git a/src/ALE/MOM_hybgen_regrid.F90 b/src/ALE/MOM_hybgen_regrid.F90 new file mode 100644 index 0000000000..0ac424b2d0 --- /dev/null +++ b/src/ALE/MOM_hybgen_regrid.F90 @@ -0,0 +1,1015 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> This module contains the hybgen regridding routines from HYCOM, with minor +!! modifications to follow the MOM6 coding conventions +module MOM_hybgen_regrid + +use MOM_EOS, only : EOS_type, calculate_density +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, assert +use MOM_file_parser, only : get_param, param_file_type, log_param +use MOM_io, only : create_MOM_file, file_exists +use MOM_io, only : MOM_infra_file, MOM_field +use MOM_io, only : MOM_read_data, MOM_write_field, vardesc, var_desc, SINGLE_FILE +use MOM_string_functions, only : slasher +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : ocean_grid_type, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +!> Control structure containing required parameters for the hybgen coordinate generator +type, public :: hybgen_regrid_CS ; private + + real :: min_thickness !< Minimum thickness allowed for layers [H ~> m or kg m-2] + + integer :: nk !< Number of layers on the target grid + + !> Reference pressure for density calculations [R L2 T-2 ~> Pa] + real :: ref_pressure + + !> Hybgen uses PCM if layer is within hybiso of target density [R ~> kg m-3] + real :: hybiso + !> Number of sigma levels used by HYBGEN + integer :: nsigma + + real :: dp00i !< Deep isopycnal spacing minimum thickness [H ~> m or kg m-2] + real :: qhybrlx !< Fractional relaxation within a regridding step [nondim] + + real, allocatable, dimension(:) :: & + dp0k, & !< minimum deep z-layer separation [H ~> m or kg m-2] + ds0k !< minimum shallow z-layer separation [H ~> m or kg m-2] + + real :: coord_scale = 1.0 !< A scaling factor to restores the depth coordinates to + !! values in m [m H-1 ~> 1 or m3 kg-1] + real :: Rho_coord_scale = 1.0 !< A scaling factor to restores the denesity coordinates to + !! values in kg m-3 [kg m-3 R-1 ~> 1] + + real :: dpns !< depth to start terrain following [H ~> m or kg m-2] + real :: dsns !< depth to stop terrain following [H ~> m or kg m-2] + real :: min_dilate !< The minimum amount of dilation that is permitted when converting target + !! coordinates from z to z* [nondim]. This limit applies when wetting occurs. + real :: max_dilate !< The maximum amount of dilation that is permitted when converting target + !! coordinates from z to z* [nondim]. This limit applies when drying occurs. + + real :: thkbot !< Thickness of a bottom boundary layer, within which hybgen does + !! something different. [H ~> m or kg m-2] + + !> Shallowest depth for isopycnal layers [H ~> m or kg m-2] + real :: topiso_const + ! real, dimension(:,:), allocatable :: topiso + + !> Nominal density of interfaces [R ~> kg m-3] + real, allocatable, dimension(:) :: target_density + + real :: dp_far_from_sfc !< A distance that determines when an interface is suffiently far from + !! the surface that certain adjustments can be made in the Hybgen regridding + !! code [H ~> m or kg m-2]. In Hycom, this is set to tenm (nominally 10 m). + real :: dp_far_from_bot !< A distance that determines when an interface is suffiently far from + !! the bottom that certain adjustments can be made in the Hybgen regridding + !! code [H ~> m or kg m-2]. In Hycom, this is set to onem (nominally 1 m). + real :: h_thin !< A layer thickness below which a layer is considered to be too thin for + !! certain adjustments to be made in the Hybgen regridding code [H ~> m or kg m-2]. + !! In Hycom, this is set to onemm (nominally 0.001 m). + + real :: rho_eps !< A small nonzero density that is used to prevent division by zero + !! in several expressions in the Hybgen regridding code [R ~> kg m-3]. + + real :: onem !< Nominally one m in thickness units [H ~> m or kg m-2], used only in + !! certain debugging tests. + +end type hybgen_regrid_CS + + +public hybgen_regrid, init_hybgen_regrid, end_hybgen_regrid +public hybgen_column_init, get_hybgen_regrid_params, write_Hybgen_coord_file + +contains + +!> Initialise a hybgen_regrid_CS control structure and store its parameters +subroutine init_hybgen_regrid(CS, GV, US, param_file) + type(hybgen_regrid_CS), pointer :: CS !< Unassociated pointer to hold the control structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file + + character(len=40) :: mdl = "MOM_hybgen_regrid" ! This module's name. + real :: hybrlx ! The number of remappings over which to move toward the target coordinate [timesteps] + character(len=40) :: dp0_coord_var, ds0_coord_var, rho_coord_var + character(len=200) :: filename, coord_file, inputdir ! Strings for file/path + logical :: use_coord_file + integer :: k + + if (associated(CS)) call MOM_error(FATAL, "init_hybgen_regrid: CS already associated!") + allocate(CS) + + CS%nk = GV%ke + + allocate(CS%target_density(CS%nk)) + allocate(CS%dp0k(CS%nk), source=0.0) ! minimum deep z-layer separation + allocate(CS%ds0k(CS%nk), source=0.0) ! minimum shallow z-layer separation + + do k=1,CS%nk ; CS%target_density(k) = GV%Rlay(k) ; enddo + + call get_param(param_file, mdl, "P_REF", CS%ref_pressure, & + "The pressure that is used for calculating the coordinate "//& + "density. (1 Pa = 1e4 dbar, so 2e7 is commonly used.) "//& + "This is only used if USE_EOS and ENABLE_THERMODYNAMICS are true.", & + units="Pa", default=2.0e7, scale=US%Pa_to_RL2_T2) + + call get_param(param_file, mdl, "HYBGEN_MIN_THICKNESS", CS%min_thickness, & + "The minimum layer thickness allowed when regridding with Hybgen.", & + units="m", default=0.0, scale=GV%m_to_H ) + + call get_param(param_file, mdl, "HYBGEN_N_SIGMA", CS%nsigma, & + "The number of sigma-coordinate (terrain-following) layers with Hybgen regridding.", & + default=0) + call get_param(param_file, mdl, "HYBGEN_COORD_FILE", coord_file, & + "The file from which the Hybgen profile is read, or blank to use a list of "//& + "real input parameters from the MOM_input file.", default="") + + use_coord_file = (len_trim(coord_file) > 0) + call get_param(param_file, mdl, "HYBGEN_DEEP_DZ_PR0FILE", CS%dp0k, & + "The layerwise list of deep z-level minimum thicknesses for Hybgen (dp0k in Hycom).", & + units="m", default=0.0, scale=GV%m_to_H, do_not_log=use_coord_file) + call get_param(param_file, mdl, "HYBGEN_SHALLOW_DZ_PR0FILE", CS%ds0k, & + "The layerwise list of shallow z-level minimum thicknesses for Hybgen (ds0k in Hycom).", & + units="m", default=0.0, scale=GV%m_to_H, do_not_log=use_coord_file) + + if (use_coord_file) then + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + filename = trim(inputdir)//trim(coord_file) + call log_param(param_file, mdl, "INPUTDIR/HYBGEN_COORD_FILE", filename) + if (.not.file_exists(filename)) call MOM_error(FATAL, & + " set_coord_from_file: Unable to open "//trim(filename)) + + call get_param(param_file, mdl, "HYBGEN_DEEP_DZ_VAR", dp0_coord_var, & + "The variable in HYBGEN_COORD_FILE that is to be used for the "//& + "deep z-level minimum thicknesses for Hybgen (dp0k in Hycom).", & + default="dp0") + call get_param(param_file, mdl, "HYBGEN_SHALLOW_DZ_VAR", ds0_coord_var, & + "The variable in HYBGEN_COORD_FILE that is to be used for the "//& + "shallow z-level minimum thicknesses for Hybgen (ds0k in Hycom).", & + default="ds0") + call get_param(param_file, mdl, "HYBGEN_TGT_DENSITY_VAR", rho_coord_var, & + "The variable in HYBGEN_COORD_FILE that is to be used for the Hybgen "//& + "target layer densities, or blank to reuse the values in GV%Rlay.", & + default="") + + call MOM_read_data(filename, dp0_coord_var, CS%dp0k, scale=GV%m_to_H) + + call MOM_read_data(filename, ds0_coord_var, CS%ds0k, scale=GV%m_to_H) + + if (len_trim(rho_coord_var) > 0) & + call MOM_read_data(filename, rho_coord_var, CS%target_density, scale=US%kg_m3_to_R) + endif + + call get_param(param_file, mdl, "HYBGEN_ISOPYCNAL_DZ_MIN", CS%dp00i, & + "The Hybgen deep isopycnal spacing minimum thickness (dp00i in Hycom)", & + units="m", default=0.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "HYBGEN_MIN_ISO_DEPTH", CS%topiso_const, & + "The Hybgen shallowest depth for isopycnal layers (isotop in Hycom)", & + units="m", default=0.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "HYBGEN_RELAX_PERIOD", hybrlx, & + "The Hybgen coordinate relaxation period in timesteps, or 1 to move to "//& + "the new target coordinates in a single step. This must be >= 1.", & + units="timesteps", default=1.0) + if (hybrlx < 1.0) call MOM_error(FATAL, "init_hybgen_regrid: HYBGEN_RELAX_PERIOD must be at least 1.") + CS%qhybrlx = 1.0 / hybrlx + call get_param(param_file, mdl, "HYBGEN_BBL_THICKNESS", CS%thkbot, & + "A bottom boundary layer thickness within which Hybgen is able to move "//& + "overlying layers upward to match a target density.", & + units="m", default=0.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "HYBGEN_FAR_FROM_SURFACE", CS%dp_far_from_sfc, & + "A distance that determines when an interface is suffiently far "//& + "from the surface that certain adjustments can be made in the Hybgen "//& + "regridding code. In Hycom, this is set to tenm (nominally 10 m).", & + units="m", default=10.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "HYBGEN_FAR_FROM_BOTTOM", CS%dp_far_from_bot, & + "A distance that determines when an interface is suffiently far "//& + "from the bottom that certain adjustments can be made in the Hybgen "//& + "regridding code. In Hycom, this is set to onem (nominally 1 m).", & + units="m", default=1.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "HYBGEN_H_THIN", CS%h_thin, & + "A layer thickness below which a layer is considered to be too thin for "//& + "certain adjustments to be made in the Hybgen regridding code. "//& + "In Hycom, this is set to onemm (nominally 0.001 m).", & + units="m", default=0.001, scale=GV%m_to_H) + + call get_param(param_file, mdl, "HYBGEN_DENSITY_EPSILON", CS%rho_eps, & + "A small nonzero density that is used to prevent division by zero "//& + "in several expressions in the Hybgen regridding code.", & + units="kg m-3", default=1e-11, scale=US%kg_m3_to_R) + + + call get_param(param_file, mdl, "HYBGEN_REMAP_DENSITY_MATCH", CS%hybiso, & + "A tolerance between the layer densities and their target, within which "//& + "Hybgen determines that remapping uses PCM for a layer.", & + units="kg m-3", default=0.0, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "HYBGEN_REMAP_MIN_ZSTAR_DILATE", CS%min_dilate, & + "The maximum amount of dilation that is permitted when converting target "//& + "coordinates from z to z* [nondim]. This limit applies when drying occurs.", & + units="nondim", default=0.5) + call get_param(param_file, mdl, "HYBGEN_REMAP_MAX_ZSTAR_DILATE", CS%max_dilate, & + "The maximum amount of dilation that is permitted when converting target "//& + "coordinates from z to z* [nondim]. This limit applies when drying occurs.", & + units="nondim", default=2.0) + + CS%onem = 1.0 * GV%m_to_H + + do k=1,CS%nk ; CS%dp0k(k) = max(CS%dp0k(k), CS%min_thickness) ; enddo + CS%dp00i = max(CS%dp00i, CS%min_thickness) + + ! Determine the depth range over which to use a sigma (terrain-following) coordinate. + ! --- terrain following starts at depth dpns and ends at depth dsns + if (CS%nsigma == 0) then + CS%dpns = CS%dp0k(1) + CS%dsns = 0.0 + else + CS%dpns = 0.0 + CS%dsns = 0.0 + do k=1,CS%nsigma + CS%dpns = CS%dpns + CS%dp0k(k) + CS%dsns = CS%dsns + CS%ds0k(k) + enddo !k + endif !nsigma + + CS%coord_scale = GV%H_to_m + CS%Rho_coord_scale = US%R_to_kg_m3 + +end subroutine init_hybgen_regrid + +!> Writes out a file containing any available data related +!! to the vertical grid used by the MOM ocean model. +subroutine write_Hybgen_coord_file(GV, CS, filepath) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(hybgen_regrid_CS), intent(in) :: CS !< Control structure for this module + character(len=*), intent(in) :: filepath !< The full path to the file to write + ! Local variables + type(vardesc) :: vars(3) + type(MOM_field) :: fields(3) + type(MOM_infra_file) :: IO_handle ! The I/O handle of the fileset + + vars(1) = var_desc("dp0", "meter", "Deep z-level minimum thicknesses for Hybgen", '1', 'L', '1') + vars(2) = var_desc("ds0", "meter", "Shallow z-level minimum thicknesses for Hybgen", '1', 'L', '1') + vars(3) = var_desc("Rho_tgt", "kg m-3", "Target coordinate potential densities for Hybgen", '1', 'L', '1') + call create_MOM_file(IO_handle, trim(filepath), vars, 3, fields, & + SINGLE_FILE, GV=GV) + + call MOM_write_field(IO_handle, fields(1), CS%dp0k, unscale=CS%coord_scale) + call MOM_write_field(IO_handle, fields(2), CS%ds0k, unscale=CS%coord_scale) + call MOM_write_field(IO_handle, fields(3), CS%target_density, unscale=CS%Rho_coord_scale) + + call IO_handle%close() +end subroutine write_Hybgen_coord_file + +!> This subroutine deallocates memory in the control structure for the hybgen module +subroutine end_hybgen_regrid(CS) + type(hybgen_regrid_CS), pointer :: CS !< Coordinate control structure + + ! nothing to do + if (.not. associated(CS)) return + + deallocate(CS%target_density) + deallocate(CS%dp0k, CS%ds0k) + deallocate(CS) +end subroutine end_hybgen_regrid + +!> This subroutine can be used to retrieve the parameters for the hybgen regrid module +subroutine get_hybgen_regrid_params(CS, nk, ref_pressure, hybiso, nsigma, dp00i, qhybrlx, & + dp0k, ds0k, dpns, dsns, min_dilate, max_dilate, & + thkbot, topiso_const, target_density) + type(hybgen_regrid_CS), pointer :: CS !< Coordinate regridding control structure + integer, optional, intent(out) :: nk !< Number of layers on the target grid + real, optional, intent(out) :: ref_pressure !< Reference pressure for density calculations [R L2 T-2 ~> Pa] + real, optional, intent(out) :: hybiso !< Hybgen uses PCM if layer is within hybiso of target density [R ~> kg m-3] + integer, optional, intent(out) :: nsigma !< Number of sigma levels used by HYBGEN + real, optional, intent(out) :: dp00i !< Deep isopycnal spacing minimum thickness [H ~> m or kg m-2] + real, optional, intent(out) :: qhybrlx !< Fractional relaxation amount per timestep, 0 < qyhbrlx <= 1 [nondim] + real, optional, intent(out) :: dp0k(:) !< minimum deep z-layer separation [H ~> m or kg m-2] + real, optional, intent(out) :: ds0k(:) !< minimum shallow z-layer separation [H ~> m or kg m-2] + real, optional, intent(out) :: dpns !< depth to start terrain following [H ~> m or kg m-2] + real, optional, intent(out) :: dsns !< depth to stop terrain following [H ~> m or kg m-2] + real, optional, intent(out) :: min_dilate !< The minimum amount of dilation that is permitted when + !! converting target coordinates from z to z* [nondim]. + !! This limit applies when wetting occurs. + real, optional, intent(out) :: max_dilate !< The maximum amount of dilation that is permitted when + !! converting target coordinates from z to z* [nondim]. + !! This limit applies when drying occurs. + real, optional, intent(out) :: thkbot !< Thickness of a bottom boundary layer, within which + !! hybgen does something different. [H ~> m or kg m-2] + real, optional, intent(out) :: topiso_const !< Shallowest depth for isopycnal layers [H ~> m or kg m-2] + ! real, dimension(:,:), allocatable :: topiso + real, optional, intent(out) :: target_density(:) !< Nominal density of interfaces [R ~> kg m-3] + + if (.not. associated(CS)) call MOM_error(FATAL, "get_hybgen_params: CS not associated") + + if (present(nk)) nk = CS%nk + if (present(ref_pressure)) ref_pressure = CS%ref_pressure + if (present(hybiso)) hybiso = CS%hybiso + if (present(nsigma)) nsigma = CS%nsigma + if (present(dp00i)) dp00i = CS%dp00i + if (present(qhybrlx)) qhybrlx = CS%qhybrlx + if (present(dp0k)) then + if (size(dp0k) < CS%nk) call MOM_error(FATAL, "get_hybgen_regrid_params: "//& + "The dp0k argument is not allocated with enough space.") + dp0k(1:CS%nk) = CS%dp0k(1:CS%nk) + endif + if (present(ds0k)) then + if (size(ds0k) < CS%nk) call MOM_error(FATAL, "get_hybgen_regrid_params: "//& + "The ds0k argument is not allocated with enough space.") + ds0k(1:CS%nk) = CS%ds0k(1:CS%nk) + endif + if (present(dpns)) dpns = CS%dpns + if (present(dsns)) dsns = CS%dsns + if (present(min_dilate)) min_dilate = CS%min_dilate + if (present(max_dilate)) max_dilate = CS%max_dilate + if (present(thkbot)) thkbot = CS%thkbot + if (present(topiso_const)) topiso_const = CS%topiso_const + if (present(target_density)) then + if (size(target_density) < CS%nk) call MOM_error(FATAL, "get_hybgen_regrid_params: "//& + "The target_density argument is not allocated with enough space.") + target_density(1:CS%nk) = CS%target_density(1:CS%nk) + endif + +end subroutine get_hybgen_regrid_params + + +!> Modify the input grid to give a new vertical grid based on the HYCOM hybgen code. +subroutine hybgen_regrid(G, GV, US, dp, nom_depth_H, tv, CS, dzInterface, PCM_cell) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean 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) :: dp !< Source grid layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + type(hybgen_regrid_CS), intent(in) :: CS !< hybgen control structure + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), & + intent(inout) :: dzInterface !< The change in height of each interface, + !! using a sign convention opposite to the change + !! in pressure [H ~> m or kg m-2] + logical, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(inout) :: PCM_cell !< If true, PCM remapping should be used in a cell. + !! This is effectively intent out, but values in wide + !! halo regions and land points are reused. + + ! --- ------------------------------------- + ! --- hybrid grid generator from HYCOM + ! --- ------------------------------------- + + ! These notes on the parameters for the hybrid grid generator are inhereted from the + ! Hycom source code for these algorithms. + ! + ! From blkdat.input (units may have changed from m to pressure): + ! + ! --- 'nsigma' = number of sigma levels + ! --- 'dp0k ' = layer k deep z-level spacing minimum thickness (m) + ! --- k=1,nk + ! --- 'ds0k ' = layer k shallow z-level spacing minimum thickness (m) + ! --- k=1,nsigma + ! --- 'dp00i' = deep isopycnal spacing minimum thickness (m) + ! --- 'isotop' = shallowest depth for isopycnal layers (m) + ! now in topiso(:,:) + ! --- 'sigma ' = isopycnal layer target densities (sigma units) + ! --- now in theta(:,:,1:nk) + ! + ! --- the above specifies a vertical coord. that is isopycnal or: + ! --- near surface z in deep water, based on dp0k + ! --- near surface z in shallow water, based on ds0k and nsigma + ! --- terrain-following between them, based on ds0k and nsigma + ! + ! --- terrain following starts at depth dpns=sum(dp0k(k),k=1,nsigma) and + ! --- ends at depth dsns=sum(ds0k(k),k=1,nsigma), and the depth of the + ! --- k-th layer interface varies linearly with total depth between + ! --- these two reference depths, i.e. a z-sigma-z fixed coordinate. + ! + ! --- near the surface (i.e. shallower than isotop), layers are always + ! --- fixed depth (z or sigma). + ! -- layer 1 is always fixed, so isotop=0.0 is not realizable. + ! --- near surface layers can also be forced to be fixed depth + ! --- by setting target densities (sigma(k)) very small. + ! + ! --- away from the surface, the minimum layer thickness is dp00i. + ! + ! --- for fixed depth targets to be: + ! --- z-only set nsigma=0, + ! --- sigma-z (shallow-deep) use a very small ds0k(:), + ! --- sigma-only set nsigma=nk, dp0k large, and ds0k small. + + ! These arrays work with the input column + real :: p_col(GV%ke) ! A column of reference pressures [R L2 T-2 ~> Pa] + real :: temp_in(GV%ke) ! A column of input potential temperatures [C ~> degC] + real :: saln_in(GV%ke) ! A column of input layer salinities [S ~> ppt] + real :: Rcv_in(GV%ke) ! An input column of coordinate potential density [R ~> kg m-3] + real :: dp_in(GV%ke) ! The input column of layer thicknesses [H ~> m or kg m-2] + logical :: PCM_lay(GV%ke) ! If true for a layer, use PCM remapping for that layer + + ! These arrays are on the target grid. + real :: Rcv_tgt(CS%nk) ! Target potential density [R ~> kg m-3] + real :: Rcv(CS%nk) ! Initial values of coordinate potential density on the target grid [R ~> kg m-3] + real :: h_col(CS%nk) ! A column of layer thicknesses [H ~> m or kg m-2] + real :: dz_int(CS%nk+1) ! The change in interface height due to remapping [H ~> m or kg m-2] + real :: Rcv_integral ! Integrated coordinate potential density in a layer [R H ~> kg m-2 or kg2 m-5] + + real :: qhrlx(CS%nk+1) ! Fractional relaxation within a timestep (between 0 and 1) [nondim] + real :: dp0ij(CS%nk) ! minimum layer thickness [H ~> m or kg m-2] + real :: dp0cum(CS%nk+1) ! minimum interface depth [H ~> m or kg m-2] + + real :: h_tot ! Total thickness of the water column [H ~> m or kg m-2] + real :: nominalDepth ! Depth of ocean bottom (positive downward) [H ~> m or kg m-2] + real :: dilate ! A factor by which to dilate the target positions from z to z* [nondim] + integer :: fixlay ! Deepest fixed coordinate layer + integer, dimension(0:CS%nk) :: k_end ! The index of the deepest source layer that contributes to + ! each target layer, in the unusual case where the input grid is + ! larger than the new grid. This situation only occurs during certain + ! types of initialization or when generating output diagnostics. + integer :: i, j, k, nk, k2, nk_in + + nk = CS%nk + + p_col(:) = CS%ref_pressure + + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 ; if (G%mask2dT(i,j)>0.) then + + ! Store one-dimensional arrays of thicknesses for the 'old' vertical grid before regridding + h_tot = 0.0 + do K=1,GV%ke + temp_in(k) = tv%T(i,j,k) + saln_in(k) = tv%S(i,j,k) + dp_in(k) = dp(i,j,k) + h_tot = h_tot + dp_in(k) + enddo + + ! This sets the input column's coordinate potential density from T and S. + call calculate_density(temp_in, saln_in, p_col, Rcv_in, tv%eqn_of_state) + + ! Set the initial properties on the new grid from the old grid. + nk_in = GV%ke + if (GV%ke > CS%nk) then ; do k=GV%ke,CS%nk+1,-1 + ! Remove any excess massless layers from the bottom of the input column. + if (dp_in(k) > 0.0) exit + nk_in = k-1 + enddo ; endif + + if (CS%nk >= nk_in) then + ! Simply copy over the common layers. This is the usual case. + do k=1,min(CS%nk,GV%ke) + h_col(k) = dp_in(k) + Rcv(k) = Rcv_in(k) + enddo + if (CS%nk > GV%ke) then + ! Pad out the input column with additional massless layers with the bottom properties. + ! This case only occurs during initialization or perhaps when writing diagnostics. + do k=GV%ke+1,CS%nk + Rcv(k) = Rcv_in(GV%ke) + h_col(k) = 0.0 + enddo + endif + else ! (CS%nk < nk_in) + ! The input column has more data than the output. For now, combine layers to + ! make them the same size, but there may be better approaches that should be taken. + ! This case only occurs during initialization or perhaps when writing diagnostics. + ! This case was not handled by the original Hycom code in hybgen.F90. + do k=0,CS%nk ; k_end(k) = (k * nk_in) / CS%nk ; enddo + do k=1,CS%nk + h_col(k) = 0.0 ; Rcv_integral = 0.0 + do k2=k_end(k-1) + 1,k_end(k) + h_col(k) = h_col(k) + dp_in(k2) + Rcv_integral = Rcv_integral + dp_in(k2)*Rcv_in(k2) + enddo + if (h_col(k) > GV%H_subroundoff) then + ! Take the volume-weighted average properties. + Rcv(k) = Rcv_integral / h_col(k) + else ! Take the properties of the topmost source layer that contributes. + Rcv(k) = Rcv_in(k_end(k-1) + 1) + endif + enddo + endif + + ! Set the target densities for the new layers. + do k=1,CS%nk + ! Rcv_tgt(k) = theta(i,j,k) ! If a 3-d target density were set up in theta, use that here. + Rcv_tgt(k) = CS%target_density(k) ! MOM6 does not yet support 3-d target densities. + enddo + + ! The following block of code is used to trigger z* stretching of the targets heights. + nominalDepth = nom_depth_H(i,j) + if (h_tot <= CS%min_dilate*nominalDepth) then + dilate = CS%min_dilate + elseif (h_tot >= CS%max_dilate*nominalDepth) then + dilate = CS%max_dilate + else + dilate = h_tot / nominalDepth + endif + + ! Convert the regridding parameters into specific constraints for this column. + call hybgen_column_init(nk, CS%nsigma, CS%dp0k, CS%ds0k, CS%dp00i, & + CS%topiso_const, CS%qhybrlx, CS%dpns, CS%dsns, h_tot, dilate, & + h_col, fixlay, qhrlx, dp0ij, dp0cum) + + ! Determine whether to require the use of PCM remapping from each source layer. + do k=1,GV%ke + if (CS%hybiso > 0.0) then + ! --- thin or isopycnal source layers are remapped with PCM. + PCM_lay(k) = (k > fixlay) .and. (abs(Rcv(k) - Rcv_tgt(k)) < CS%hybiso) + else ! hybiso==0.0, so purely isopycnal layers use PCM + PCM_lay(k) = .false. + endif ! hybiso + enddo !k + + ! Determine the new layer thicknesses. + call hybgen_column_regrid(CS, nk, CS%thkbot, Rcv_tgt, fixlay, qhrlx, dp0ij, & + dp0cum, Rcv, h_col, dz_int) + + ! Store the output from hybgenaij_regrid in 3-d arrays. + if (present(PCM_cell)) then ; do k=1,GV%ke + PCM_cell(i,j,k) = PCM_lay(k) + enddo ; endif + + do K=1,nk+1 + ! Note that dzInterface uses the opposite sign convention from the change in p. + dzInterface(i,j,K) = -dz_int(K) + enddo + + else + if (present(PCM_cell)) then ; do k=1,GV%ke + PCM_cell(i,j,k) = .false. + enddo ; endif + do k=1,CS%nk+1 ; dzInterface(i,j,k) = 0.0 ; enddo + endif ; enddo ; enddo !i & j. + +end subroutine hybgen_regrid + +!> Initialize some of the variables that are used for regridding or unmixing, including the +!! stretched contraits on where the new interfaces can be. +subroutine hybgen_column_init(nk, nsigma, dp0k, ds0k, dp00i, topiso_i_j, & + qhybrlx, dpns, dsns, h_tot, dilate, h_col, & + fixlay, qhrlx, dp0ij, dp0cum) + integer, intent(in) :: nk !< The number of layers in the new grid + integer, intent(in) :: nsigma !< The number of sigma levels + real, intent(in) :: dp0k(nk) !< Layer deep z-level spacing minimum thicknesses [H ~> m or kg m-2] + real, intent(in) :: ds0k(nsigma) !< Layer shallow z-level spacing minimum thicknesses [H ~> m or kg m-2] + real, intent(in) :: dp00i !< Deep isopycnal spacing minimum thickness [H ~> m or kg m-2] + real, intent(in) :: topiso_i_j !< Shallowest depth for isopycnal layers [H ~> m or kg m-2] + real, intent(in) :: qhybrlx !< Fractional relaxation amount per timestep, 0 < qyhbrlx <= 1 [nondim] + real, intent(in) :: h_tot !< The sum of the initial layer thicknesses [H ~> m or kg m-2] + real, intent(in) :: dilate !< A factor by which to dilate the target positions + !! from z to z* [nondim] + real, intent(in) :: h_col(nk) !< Initial layer thicknesses [H ~> m or kg m-2] + real, intent(in) :: dpns !< Vertical sum of dp0k [H ~> m or kg m-2] + real, intent(in) :: dsns !< Vertical sum of ds0k [H ~> m or kg m-2] + integer, intent(out) :: fixlay !< Deepest fixed coordinate layer + real, intent(out) :: qhrlx(nk+1) !< Fractional relaxation within a timestep (between 0 and 1) [nondim] + real, intent(out) :: dp0ij(nk) !< minimum layer thickness [H ~> m or kg m-2] + real, intent(out) :: dp0cum(nk+1) !< minimum interface depth [H ~> m or kg m-2] + + ! --- -------------------------------------------------------------- + ! --- hybrid grid generator, single column - initialization. + ! --- -------------------------------------------------------------- + + ! Local variables + real :: qdep ! Total water column thickness as a fraction of dp0k (vs ds0k) [nondim] + real :: q ! A portion of the thickness that contributes to the new cell [H ~> m or kg m-2] + real :: p_int(nk+1) ! Interface depths [H ~> m or kg m-2] + integer :: k, fixall + + ! --- dpns = sum(dp0k(k),k=1,nsigma) + ! --- dsns = sum(ds0k(k),k=1,nsigma) + ! --- terrain following starts (on the deep side) at depth dpns and ends (on the + ! --- shallow side) at depth dsns and the depth of the k-th layer interface varies + ! --- linearly with total depth between these two reference depths. + if ((h_tot >= dilate * dpns) .or. (dpns <= dsns)) then + qdep = 1.0 ! Not terrain following - this column is too thick or terrain following is disabled. + elseif (h_tot <= dilate * dsns) then + qdep = 0.0 ! Not terrain following - this column is too thin + else + qdep = (h_tot - dilate * dsns) / (dilate * (dpns - dsns)) + endif + + if (qdep < 1.0) then + ! Terrain following or shallow fixed coordinates, qhrlx=1 and ignore dp00 + p_int( 1) = 0.0 + dp0cum(1) = 0.0 + qhrlx( 1) = 1.0 + dp0ij( 1) = dilate * (qdep*dp0k(1) + (1.0-qdep)*ds0k(1)) + + dp0cum(2) = dp0cum(1) + dp0ij(1) + qhrlx( 2) = 1.0 + p_int( 2) = p_int(1) + h_col(1) + do k=2,nk + qhrlx( k+1) = 1.0 + dp0ij( k) = dilate * (qdep*dp0k(k) + (1.0-qdep)*ds0k(k)) + dp0cum(k+1) = dp0cum(k) + dp0ij(k) + p_int( k+1) = p_int(k) + h_col(k) + enddo !k + else + ! Not terrain following + p_int( 1) = 0.0 + dp0cum(1) = 0.0 + qhrlx( 1) = 1.0 !no relaxation in top layer + dp0ij( 1) = dilate * dp0k(1) + + dp0cum(2) = dp0cum(1) + dp0ij(1) + qhrlx( 2) = 1.0 !no relaxation in top layer + p_int( 2) = p_int(1) + h_col(1) + do k=2,nk + if ((dp0k(k) <= dp00i) .or. (dilate * dp0k(k) >= p_int(k) - dp0cum(k))) then + ! This layer is in fixed surface coordinates. + dp0ij(k) = dp0k(k) + qhrlx(k+1) = 1.0 + else + q = dp0k(k) * (dilate * dp0k(k) / ( p_int(k) - dp0cum(k)) ) ! A fraction between 0 and 1 of dp0 to use here. + if (dp00i >= q) then + ! This layer is much deeper than the fixed surface coordinates. + dp0ij(k) = dp00i + qhrlx(k+1) = qhybrlx + else + ! This layer spans the margins of the fixed surface coordinates. + ! In this case dp00i < q < dp0k. + dp0ij(k) = dilate * q + qhrlx(k+1) = qhybrlx * (dp0k(k) - dp00i) / & + ((dp0k(k) - q) + (q - dp00i)*qhybrlx) ! 1 at dp0k, qhybrlx at dp00i + endif + + ! The old equivalent code is: + ! hybrlx = 1.0 / qhybrlx + ! q = max( dp00i, dp0k(k) * (dp0k(k) / max(dp0k( k), p_int(k) - dp0cum(k)) ) ) + ! qts = 1.0 - (q-dp00i) / (dp0k(k) - dp00i) !0 at q = dp0k, 1 at q=dp00i + ! qhrlx( k+1) = 1.0 / (1.0 + qts*(hybrlx-1.0)) !1 at dp0k, qhybrlx at dp00i + endif + dp0cum(k+1) = dp0cum(k) + dp0ij(k) + p_int(k+1) = p_int(k) + h_col(k) + enddo !k + endif !qdep<1:else + + ! Identify the current fixed coordinate layers + fixlay = 1 !layer 1 always fixed + do k=2,nk + if (dp0cum(k) >= dilate * topiso_i_j) then + exit !layers k to nk might be isopycnal + endif + ! Top of layer is above topiso, i.e. always fixed coordinate layer + qhrlx(k+1) = 1.0 !no relaxation in fixed layers + fixlay = fixlay+1 + enddo !k + + fixall = fixlay + do k=fixall+1,nk + if (p_int(k+1) > dp0cum(k+1) + 0.1*dp0ij(k)) then + if ( (fixlay > fixall) .and. (p_int(k) > dp0cum(k)) ) then + ! --- The previous layer should remain fixed. + fixlay = fixlay-1 + endif + exit !layers k to nk might be isopycnal + endif + ! Sometimes fixed coordinate layer + qhrlx(k) = 1.0 !no relaxation in fixed layers + fixlay = fixlay+1 + enddo !k + +end subroutine hybgen_column_init + +!> The cushion function from Bleck & Benjamin, 1992, which returns a smoothly varying +!! but limited value that goes between dp0 and delp +real function cushn(delp, dp0) + real, intent(in) :: delp ! A thickness change [H ~> m or kg m-2] + real, intent(in) :: dp0 ! A non-negative reference thickness [H ~> m or kg m-2] + + ! These are the nondimensional parameters that define the cushion function. + real, parameter :: qqmn=-4.0, qqmx=2.0 ! shifted range for cushn [nondim] +! real, parameter :: qqmn=-2.0, qqmx=4.0 ! traditional range for cushn [nondim] +! real, parameter :: qqmn=-4.0, qqmx=6.0 ! somewhat wider range for cushn [nondim] + ! These are derivative nondimensional parameters. + ! real, parameter :: cusha = qqmn**2 * (qqmx-1.0) / (qqmx-qqmn)**2 + ! real, parameter :: I_qqmn = 1.0 / qqmn + real, parameter :: qq_scale = (qqmx-1.0) / (qqmx-qqmn)**2 ! A scaling factor based on qqmn and qqmx [nondim] + real, parameter :: I_qqmx = 1.0 / qqmx ! The inverse of qqmx [nondim] + + ! --- if delp >= qqmx*dp0 >> dp0, cushn returns delp. + ! --- if delp <= qqmn*dp0 << -dp0, cushn returns dp0. + + ! This is the original version from Hycom. + ! qq = max(qqmn, min(qqmx, delp/dp0)) + ! cushn = dp0 * (1.0 + cusha * (1.0-I_qqmn*qq)**2) * max(1.0, delp/(dp0*qqmx)) + + ! This is mathematically equivalent, has one fewer divide, and works as intended even if dp0 = 0. + if (delp >= qqmx*dp0) then + cushn = delp + elseif (delp < qqmn*dp0) then + cushn = max(dp0, delp * I_qqmx) + else + cushn = max(dp0, delp * I_qqmx) * (1.0 + qq_scale * ((delp / dp0) - qqmn)**2) + endif + +end function cushn + +!> Create a new grid for a column of water using the Hybgen algorithm. +subroutine hybgen_column_regrid(CS, nk, thkbot, Rcv_tgt, & + fixlay, qhrlx, dp0ij, dp0cum, Rcv, h_in, dp_int) + type(hybgen_regrid_CS), intent(in) :: CS !< hybgen regridding control structure + integer, intent(in) :: nk !< number of layers + real, intent(in) :: thkbot !< thickness of bottom boundary layer [H ~> m or kg m-2] + real, intent(in) :: Rcv_tgt(nk) !< Target potential density [R ~> kg m-3] + integer, intent(in) :: fixlay !< deepest fixed coordinate layer + real, intent(in) :: qhrlx( nk+1) !< relaxation coefficient per timestep [nondim] + real, intent(in) :: dp0ij( nk) !< minimum layer thickness [H ~> m or kg m-2] + real, intent(in) :: dp0cum(nk+1) !< minimum interface depth [H ~> m or kg m-2] + real, intent(in) :: Rcv(nk) !< Coordinate potential density [R ~> kg m-3] + real, intent(in) :: h_in(nk) !< Layer thicknesses [H ~> m or kg m-2] + real, intent(out) :: dp_int(nk+1) !< The change in interface positions [H ~> m or kg m-2] + + ! --- ------------------------------------------------------ + ! --- hybrid grid generator, single column - regrid. + ! --- ------------------------------------------------------ + + ! Local variables + real :: p_new ! A new interface position [H ~> m or kg m-2] + real :: pres_in(nk+1) ! layer interface positions [H ~> m or kg m-2] + real :: p_int(nk+1) ! layer interface positions [H ~> m or kg m-2] + real :: h_col(nk) ! Updated layer thicknesses [H ~> m or kg m-2] + real :: q_frac ! A fraction of a layer to entrain [nondim] + real :: h_min ! The minimum layer thickness [H ~> m or kg m-2] + real :: h_hat3 ! Thickness movement upward across the interface between layers k-2 and k-3 [H ~> m or kg m-2] + real :: h_hat2 ! Thickness movement upward across the interface between layers k-1 and k-2 [H ~> m or kg m-2] + real :: h_hat ! Thickness movement upward across the interface between layers k and k-1 [H ~> m or kg m-2] + real :: h_hat0 ! A first guess at thickness movement upward across the interface + ! between layers k and k-1 [H ~> m or kg m-2] + real :: dh_cor ! Thickness changes [H ~> m or kg m-2] + logical :: trap_errors + integer :: k + character(len=256) :: mesg ! A string for output messages + + ! This line needs to be consistent with the parameters set in cushn(). + real, parameter :: qqmn=-4.0, qqmx=2.0 ! shifted range for cushn [nondim] +! real, parameter :: qqmn=-2.0, qqmx=4.0 ! traditional range for cushn [nondim] +! real, parameter :: qqmn=-4.0, qqmx=6.0 ! somewhat wider range for cushn [nondim] + + trap_errors = .true. + + do K=1,nk+1 ; dp_int(K) = 0.0 ; enddo + + p_int(1) = 0.0 + do k=1,nk + h_col(k) = max(h_in(k), 0.0) + p_int(K+1) = p_int(K) + h_col(k) + enddo + h_min = min( CS%min_thickness, p_int(nk+1)/real(CS%nk) ) + + if (trap_errors) then + do K=1,nk+1 ; pres_in(K) = p_int(K) ; enddo + endif + + ! Try to restore isopycnic conditions by moving layer interfaces + ! qhrlx(k) are relaxation amounts per timestep. + + ! Maintain prescribed thickness in layer k <= fixlay + ! There may be massless layers at the bottom, so work upwards. + do k=min(nk-1,fixlay),1,-1 + p_new = min(dp0cum(k+1), p_int(nk+1) - (nk-k)*h_min) ! This could be positive or negative. + dh_cor = p_new - p_int(K+1) + if (k= h_min) exit ! usually get here quickly + dh_cor = h_min - h_col(k) ! This is positive. + h_col(k) = h_min ! = h_col(k) + dh_cor + h_col(k+1) = h_col(k+1) - dh_cor + dp_int(k+1) = dp_int(k+1) + dh_cor + p_int(k+1) = p_int(fixlay+1) + enddo + if (h_col(nk) < h_min) then ! This should be uncommon, and should only arise at the level of roundoff. + do k=nk,2,-1 + if (h_col(k) >= h_min) exit + dh_cor = h_col(k) - h_min ! dh_cor is negative. + h_col(k-1) = h_col(k-1) + dh_cor + h_col(k) = h_min ! = h_col(k) - dh_cor + dp_int(k) = dp_int(k) + dh_cor + p_int(k) = p_int(k) + dh_cor + enddo + endif + + ! Remap the non-fixed layers. + + ! In the Hycom version, this loop was fused with the loop correcting water that is + ! too light, and it ran down the water column, but if there are a set of layers + ! that are very dense, that structure can lead to all of the water being remapped + ! into a single thick layer. Splitting the loops and running the loop upwards + ! (as is done here) avoids that catastrophic problem for layers that are far from + ! their targets. However, this code is still prone to a thin-thick-thin null mode. + do k=nk,fixlay+2,-1 + ! This is how the Hycom code would do this loop: do k=fixlay+1,nk ; if (k>fixlay+1) then + + if ((Rcv(k) > Rcv_tgt(k) + CS%rho_eps)) then + ! Water in layer k is too dense, so try to dilute with water from layer k-1 + ! Do not move interface if k = fixlay + 1 + + if ((Rcv(k-1) >= Rcv_tgt(k-1)) .or. & + (p_int(k) <= dp0cum(k) + CS%dp_far_from_bot) .or. & + (h_col(k) <= h_col(k-1))) then + ! If layer k-1 is too light, there is a conflict in the direction the + ! inteface between them should move, so thicken the thinner of the two. + + if ((Rcv_tgt(k) - Rcv(k-1)) <= CS%rho_eps) then + ! layer k-1 is far too dense, take the entire layer + ! If this code is working downward and this branch is repeated in a series + ! of successive layers, it can accumulate into a very thick homogenous layers. + h_hat0 = 0.0 ! This line was not in the Hycom version of hybgen.F90. + h_hat = dp0ij(k-1) - h_col(k-1) + else + ! Entrain enough from the layer above to bring layer k to its target density. + q_frac = (Rcv_tgt(k) - Rcv(k)) / (Rcv_tgt(k) - Rcv(k-1)) ! -1 <= q_frac < 0 + h_hat0 = q_frac*h_col(k) ! -h_col(k-1) <= h_hat0 < 0 + if (k == fixlay+2) then + ! Treat layer k-1 as fixed. + h_hat = max(h_hat0, dp0ij(k-1) - h_col(k-1)) + else + ! Maintain the minimum thickess of layer k-1. + h_hat = cushn(h_hat0 + h_col(k-1), dp0ij(k-1)) - h_col(k-1) + endif !fixlay+2:else + endif + ! h_hat is usually negative, so this check may be unnecessary if the values of + ! dp0ij are limited to not be below the seafloor? + h_hat = min(h_hat, p_int(nk+1) - p_int(k)) + + ! If isopycnic conditions cannot be achieved because of a blocking + ! layer (thinner than its minimum thickness) in the interior ocean, + ! move interface k-1 (and k-2 if necessary) upward + ! Only work on layers that are sufficiently far from the fixed near-surface layers. + if ((h_hat >= 0.0) .and. (k > fixlay+2) .and. (p_int(k-1) > dp0cum(k-1) + CS%dp_far_from_sfc)) then + + ! Only act if interface k-1 is near the bottom or layer k-2 could donate water. + if ( (p_int(nk+1) - p_int(k-1) < thkbot) .or. & + (h_col(k-2) > qqmx*dp0ij(k-2)) ) then + ! Determine how much water layer k-2 could supply without becoming too thin. + if (k == fixlay+3) then + ! Treat layer k-2 as fixed. + h_hat2 = max(h_hat0 - h_hat, dp0ij(k-2) - h_col(k-2)) + else + ! Maintain minimum thickess of layer k-2. + h_hat2 = cushn(h_col(k-2) + (h_hat0 - h_hat), dp0ij(k-2)) - h_col(k-2) + endif !fixlay+3:else + + if (h_hat2 < -CS%h_thin) then + dh_cor = qhrlx(k-1) * max(h_hat2, -h_hat - h_col(k-1)) + h_col(k-2) = h_col(k-2) + dh_cor + h_col(k-1) = h_col(k-1) - dh_cor + dp_int(k-1) = dp_int(k-1) + dh_cor + p_int(k-1) = p_int(k-1) + dh_cor + ! Recalculate how much layer k-1 could donate to layer k. + h_hat = cushn(h_hat0 + h_col(k-1), dp0ij(k-1)) - h_col(k-1) + elseif (k <= fixlay+3) then + ! Do nothing. + elseif ( (p_int(k-2) > dp0cum(k-2) + CS%dp_far_from_sfc) .and. & + ( (p_int(nk+1) - p_int(k-2) < thkbot) .or. & + (h_col(k-3) > qqmx*dp0ij(k-3)) ) ) then + + ! Determine how much water layer k-3 could supply without becoming too thin. + if (k == fixlay+4) then + ! Treat layer k-3 as fixed. + h_hat3 = max(h_hat0 - h_hat, dp0ij(k-3) - h_col(k-3)) + else + ! Maintain minimum thickess of layer k-3. + h_hat3 = cushn(h_col(k-3) + (h_hat0 - h_hat), dp0ij(k-3)) - h_col(k-3) + endif !fixlay+4:else + if (h_hat3 < -CS%h_thin) then + ! Water is moved from layer k-3 to k-2, but do not dilute layer k-2 too much. + dh_cor = qhrlx(k-2) * max(h_hat3, -h_col(k-2)) + h_col(k-3) = h_col(k-3) + dh_cor + h_col(k-2) = h_col(k-2) - dh_cor + dp_int(k-2) = dp_int(k-2) + dh_cor + p_int(k-2) = p_int(k-2) + dh_cor + + ! Now layer k-2 might be able donate to layer k-1. + h_hat2 = cushn(h_col(k-2) + (h_hat0 - h_hat), dp0ij(k-2)) - h_col(k-2) + if (h_hat2 < -CS%h_thin) then + dh_cor = qhrlx(k-1) * (max(h_hat2, -h_hat - h_col(k-1)) ) + h_col(k-2) = h_col(k-2) + dh_cor + h_col(k-1) = h_col(k-1) - dh_cor + dp_int(k-1) = dp_int(k-1) + dh_cor + p_int(k-1) = p_int(k-1) + dh_cor + ! Recalculate how much layer k-1 could donate to layer k. + h_hat = cushn(h_hat0 + h_col(k-1), dp0ij(k-1)) - h_col(k-1) + endif !h_hat2 + endif !h_hat3 + endif !h_hat2:blocking + endif ! Layer k-2 could move. + endif ! blocking, i.e., h_hat >= 0, and far enough from the fixed layers to permit a change. + + if (h_hat < 0.0) then + ! entrain layer k-1 water into layer k, move interface up. + dh_cor = qhrlx(k) * h_hat + h_col(k-1) = h_col(k-1) + dh_cor + h_col(k) = h_col(k) - dh_cor + dp_int(k) = dp_int(k) + dh_cor + p_int(k) = p_int(k) + dh_cor + endif !entrain + + endif !too-dense adjustment + endif + + ! In the original Hycom version, there is not a break between these two loops. + enddo + + do k=fixlay+1,nk + if (Rcv(k) < Rcv_tgt(k) - CS%rho_eps) then ! layer too light + ! Water in layer k is too light, so try to dilute with water from layer k+1. + ! Entrainment is not possible if layer k touches the bottom. + if (p_int(k+1) < p_int(nk+1)) then ! k dp0ij(k) + dp0ij(k+1)) then + h_hat = h_col(k+1) - cushn(h_col(k+1) - h_hat, dp0ij(k+1)) + endif + ! Try to bring layer layer k up to its minimum thickness. + h_hat = max(h_hat, dp0ij(k) - h_col(k)) + ! Do not drive layer k+1 below its minimum thickness or take more than half of it. + h_hat = min(h_hat, max(0.5*h_col(k+1), h_col(k+1) - dp0ij(k+1)) ) + else + ! Layers that touch the bottom can lose their entire contents. + h_hat = min(h_col(k+1), h_hat) + endif !p.k+2 0.0) then + ! Entrain layer k+1 water into layer k. + dh_cor = qhrlx(k+1) * h_hat + h_col(k) = h_col(k) + dh_cor + h_col(k+1) = h_col(k+1) - dh_cor + dp_int(k+1) = dp_int(k+1) + dh_cor + p_int(k+1) = p_int(k+1) + dh_cor + endif !entrain + + endif !too-light adjustment + endif !above bottom + endif !too light + + ! If layer above is still too thin, move interface down. + dh_cor = min(qhrlx(k-1) * min(dp0ij(k-1) - h_col(k-1), p_int(nk+1) - p_int(k)), h_col(k)) + if (dh_cor > 0.0) then + h_col(k-1) = h_col(k-1) + dh_cor + h_col(k) = h_col(k) - dh_cor + dp_int(k) = dp_int(k) + dh_cor + p_int(k) = p_int(k) + dh_cor + endif + + enddo !k Hybrid vertical coordinate relocation moving interface downward + + if (trap_errors) then + ! Verify that everything is consistent. + do k=1,nk + if (abs((h_col(k) - h_in(k)) + (dp_int(K) - dp_int(K+1))) > 1.0e-13*max(p_int(nk+1), CS%onem)) then + write(mesg, '("k ",I0," h ",es13.4," h_in ",es13.4, " dp ",2es13.4," err ",es13.4)') & + k, h_col(k), h_in(k), dp_int(K), dp_int(K+1), (h_col(k) - h_in(k)) + (dp_int(K) - dp_int(K+1)) + call MOM_error(FATAL, "Mismatched thickness changes in hybgen_regrid: "//trim(mesg)) + endif + if (h_col(k) < 0.0) then ! Could instead do: -1.0e-15*max(p_int(nk+1), CS%onem)) then + write(mesg, '("k ",I0," h ",es13.4," h_in ",es13.4, " dp ",2es13.4, " fixlay ",I0)') & + k, h_col(k), h_in(k), dp_int(K), dp_int(K+1), fixlay + call MOM_error(FATAL, "Significantly negative final thickness in hybgen_regrid: "//trim(mesg)) + endif + enddo + do K=1,nk+1 + if (abs(dp_int(K) - (p_int(K) - pres_in(K))) > 1.0e-13*max(p_int(nk+1), CS%onem)) then + call MOM_error(FATAL, "Mismatched interface height changes in hybgen_regrid.") + endif + enddo + endif + +end subroutine hybgen_column_regrid + +end module MOM_hybgen_regrid + +! This code was translated in 2022 from the HYCOM hybgen code, which was primarily developed +! between 2000 and 2015, with some minor subsequent changes and bug fixes. diff --git a/src/ALE/MOM_hybgen_remap.F90 b/src/ALE/MOM_hybgen_remap.F90 new file mode 100644 index 0000000000..921ccecccc --- /dev/null +++ b/src/ALE/MOM_hybgen_remap.F90 @@ -0,0 +1,392 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> This module contains the hybgen remapping routines from HYCOM, with minor +!! modifications to follow the MOM6 coding conventions +module MOM_hybgen_remap + +implicit none ; private + +public hybgen_plm_coefs, hybgen_ppm_coefs, hybgen_weno_coefs + +contains + +!> Set up the coefficients for PLM remapping of a set of scalars +subroutine hybgen_plm_coefs(si, dpi, slope, nk, ns, thin, PCM_lay) + integer, intent(in) :: nk !< The number of input layers + integer, intent(in) :: ns !< The number of scalar fields to work on + real, intent(in) :: si(nk,ns) !< The cell-averaged input scalar fields [A] + real, intent(in) :: dpi(nk) !< The input grid layer thicknesses [H ~> m or kg m-2] + real, intent(out) :: slope(nk,ns) !< The PLM slope times cell width [A] + real, intent(in) :: thin !< A negligible layer thickness that can be ignored [H ~> m or kg m-2] + logical, optional, intent(in) :: PCM_lay(nk) !< If true for a layer, use PCM remapping for that layer + +!----------------------------------------------------------------------- +! 1) coefficients for remapping from one set of vertical cells to another. +! method: piecewise linear across each input cell with +! monotonized central-difference limiter. +! +! van Leer, B., 1977, J. Comp. Phys., 23 276-299. +! +! 2) input arguments: +! si - initial scalar fields in pi-layer space +! dpi - initial layer thicknesses (dpi(k) = pi(k+1)-pi(k)) +! nk - number of layers +! ns - number of fields +! thin - layer thickness (>0) that can be ignored +! PCM_lay - use PCM for selected layers (optional) +! +! 3) output arguments: +! slope - coefficients for hybgen_plm_remap +! profile(y) = si+slope*(y-1), -0.5 <= y <= 0.5 +! +! 4) Tim Campbell, Mississippi State University, October 2002. +! Alan J. Wallcraft, Naval Research Laboratory, Aug. 2007. +!----------------------------------------------------------------------- +! + real :: qcen ! A layer's thickness divided by the distance between the centers + ! of the adjacent cells, usually ~0.5, but always <= 1 [nondim] + real :: zbot, zcen, ztop ! Tracer slopes times the layer thickness [A] + integer :: i, k + + do i=1,ns + slope(1, i) = 0.0 + slope(nk,i) = 0.0 + enddo !i + do k= 2,nk-1 + if (dpi(k) <= thin) then !use PCM + do i=1,ns ; slope(k,i) = 0.0 ; enddo + else +! --- use qcen in place of 0.5 to allow for non-uniform grid + qcen = dpi(k) / (dpi(k)+0.5*(dpi(k-1)+dpi(k+1))) !dpi(k)>thin + do i=1,ns +! --- PLM (non-zero slope, but no new extrema) +! --- layer value is si-0.5*slope at top interface, +! --- and si+0.5*slope at bottom interface. +! +! --- monotonized central-difference limiter (van Leer, 1977, +! --- JCP 23 pp 276-299). For a discussion of PLM limiters, see +! --- Finite Volume Methods for Hyperbolic Problems by R.J. Leveque. + ztop = 2.0*(si(k, i)-si(k-1,i)) + zbot = 2.0*(si(k+1,i)-si(k, i)) + zcen = qcen*(si(k+1,i)-si(k-1,i)) + if (ztop*zbot > 0.0) then !ztop,zbot are the same sign + slope(k,i) = sign(min(abs(zcen),abs(zbot),abs(ztop)), zbot) + else + slope(k,i) = 0.0 !local extrema, so no slope + endif + enddo !i + endif !PCM:PLM + enddo !k + + if (present(PCM_lay)) then + do k=1,nk ; if (PCM_lay(k)) then + do i=1,ns ; slope(k,i) = 0.0 ; enddo + endif ; enddo + endif + +end subroutine hybgen_plm_coefs + + +!> Set up the coefficients for PPM remapping of a set of scalars +subroutine hybgen_ppm_coefs(s, h_src, edges, nk, ns, thin, PCM_lay) + integer, intent(in) :: nk !< The number of input layers + integer, intent(in) :: ns !< The scalar fields to work on + real, intent(in) :: s(nk,ns) !< The input scalar fields [A] + real, intent(in) :: h_src(nk) !< The input grid layer thicknesses [H ~> m or kg m-2] + real, intent(out) :: edges(nk,2,ns) !< The PPM interpolation edge values of the scalar fields [A] + real, intent(in) :: thin !< A negligible layer thickness that can be ignored [H ~> m or kg m-2] + logical, optional, intent(in) :: PCM_lay(nk) !< If true for a layer, use PCM remapping for that layer + +!----------------------------------------------------------------------- +! 1) coefficients for remapping from one set of vertical cells to another. +! method: monotonic piecewise parabolic across each input cell +! +! Colella, P. & P.R. Woodward, 1984, J. Comp. Phys., 54, 174-201. +! +! 2) input arguments: +! s - initial scalar fields in pi-layer space +! h_src - initial layer thicknesses (>=0) +! nk - number of layers +! ns - number of fields +! thin - layer thickness (>0) that can be ignored +! PCM_lay - use PCM for selected layers (optional) +! +! 3) output arguments: +! edges - cell edge scalar values for the PPM reconstruction +! edges.1 is value at interface above +! edges.2 is value at interface below +! +! 4) Tim Campbell, Mississippi State University, October 2002. +! Alan J. Wallcraft, Naval Research Laboratory, Aug. 2007. +!----------------------------------------------------------------------- +! + real :: dp(nk) ! Input grid layer thicknesses, but with a minimum thickness given by thin [H ~> m or kg m-2] + logical :: PCM_layer(nk) ! True for layers that should use PCM remapping, either because they are + ! very thin, or because this is specified by PCM_lay. + 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] + real :: sck ! Scalar differences across a cell [A] + real :: as(nk) ! Scalar field difference across each cell [A] + real :: al(nk), ar(nk) ! Scalar field at the left and right edges of a cell [A] + real :: h112(nk+1), h122(nk+1) ! Combinations of thicknesses [H ~> m or kg m-2] + real :: I_h12(nk+1) ! Inverses of combinations of thickesses [H-1 ~> m-1 or m2 kg-1] + real :: h2_h123(nk) ! A ratio of a layer thickness of the sum of 3 adjacent thicknesses [nondim] + real :: I_h0123(nk) ! Inverse of the sum of 4 adjacent thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: h01_h112(nk+1) ! A ratio of sums of adjacent thicknesses [nondim], 2/3 in the limit of uniform thicknesses. + real :: h23_h122(nk+1) ! A ratio of sums of adjacent thicknesses [nondim], 2/3 in the limit of uniform thicknesses. + integer :: k, i + + ! This PPM remapper is not currently written to work with massless layers, so set + ! the thicknesses for very thin layers to some minimum value. + do k=1,nk ; dp(k) = max(h_src(k), thin) ; enddo + + ! Specify the layers that will use PCM remapping. + if (present(PCM_lay)) then + do k=1,nk ; PCM_layer(k) = (PCM_lay(k) .or. dp(k) <= thin) ; enddo + else + do k=1,nk ; PCM_layer(k) = (dp(k) <= thin) ; enddo + endif + + !compute grid metrics + do k=2,nk + h112(K) = 2.*dp(k-1) + dp(k) + h122(K) = dp(k-1) + 2.*dp(k) + I_h12(K) = 1.0 / (dp(k-1) + dp(k)) + enddo !k + do k=2,nk-1 + h2_h123(k) = dp(k) / (dp(k) + (dp(k-1)+dp(k+1))) + enddo + do K=3,nk-1 + I_h0123(K) = 1.0 / ((dp(k-2) + dp(k-1)) + (dp(k) + dp(k+1))) + + h01_h112(K) = (dp(k-2) + dp(k-1)) / (2.0*dp(k-1) + dp(k)) + h23_h122(K) = (dp(k) + dp(k+1)) / (dp(k-1) + 2.0*dp(k)) + enddo + + do i=1,ns + !Compute average slopes: Colella, Eq. (1.8) + as(1) = 0. + do k=2,nk-1 + if (PCM_layer(k)) then !use PCM + as(k) = 0.0 + else + slk = s(k, i)-s(k-1,i) + srk = s(k+1,i)-s(k, i) + if (slk*srk > 0.) then + sck = h2_h123(k)*( h112(K)*srk*I_h12(K+1) + h122(K+1)*slk*I_h12(K) ) + as(k) = sign(min(abs(2.0*slk), abs(sck), abs(2.0*srk)), sck) + else + as(k) = 0. + endif + endif !PCM:PPM + enddo !k + as(nk) = 0. + !Compute "first guess" edge values: Colella, Eq. (1.6) + al(1) = s(1,i) ! 1st layer PCM + ar(1) = s(1,i) ! 1st layer PCM + al(2) = s(1,i) ! 1st layer PCM + do K=3,nk-1 + ! This is a 4th order explicit edge value estimate. + al(k) = (dp(k)*s(k-1,i) + dp(k-1)*s(k,i)) * I_h12(K) & + + I_h0123(K)*( 2.*dp(k)*dp(k-1)*I_h12(K)*(s(k,i)-s(k-1,i)) * & + ( h01_h112(K) - h23_h122(K) ) & + + (dp(k)*as(k-1)*h23_h122(K) - dp(k-1)*as(k)*h01_h112(K)) ) + ar(k-1) = al(k) + enddo !k + ar(nk-1) = s(nk,i) ! last layer PCM + al(nk) = s(nk,i) ! last layer PCM + ar(nk) = s(nk,i) ! last layer PCM + !Impose monotonicity: Colella, Eq. (1.10) + do k=2,nk-1 + if ((PCM_layer(k)) .or. ((s(k+1,i)-s(k,i))*(s(k,i)-s(k-1,i)) <= 0.)) then !local extremum + al(k) = s(k,i) + ar(k) = s(k,i) + else + da = ar(k)-al(k) + a6 = 6.0*s(k,i) - 3.0*(al(k)+ar(k)) + if (da*a6 > da*da) then !peak in right half of zone + al(k) = 3.0*s(k,i) - 2.0*ar(k) + elseif (da*a6 < -da*da) then !peak in left half of zone + ar(k) = 3.0*s(k,i) - 2.0*al(k) + endif + endif + enddo !k + !Set coefficients + do k=1,nk + edges(k,1,i) = al(k) + edges(k,2,i) = ar(k) + enddo !k + enddo !i + +end subroutine hybgen_ppm_coefs + + +!> Set up the coefficients for PPM remapping of a set of scalars +subroutine hybgen_weno_coefs(s, h_src, edges, nk, ns, thin, PCM_lay) + integer, intent(in) :: nk !< The number of input layers + integer, intent(in) :: ns !< The number of scalar fields to work on + real, intent(in) :: s(nk,ns) !< The input scalar fields [A] + real, intent(in) :: h_src(nk) !< The input grid layer thicknesses [H ~> m or kg m-2] + real, intent(out) :: edges(nk,2,ns) !< The WENO interpolation edge values of the scalar fields [A] + real, intent(in) :: thin !< A negligible layer thickness that can be ignored [H ~> m or kg m-2] + logical, optional, intent(in) :: PCM_lay(nk) !< If true for a layer, use PCM remapping for that layer + +!----------------------------------------------------------------------- +! 1) coefficients for remapping from one set of vertical cells to another. +! method: monotonic WENO-like alternative to PPM across each input cell +! a second order polynomial approximation of the profiles +! using a WENO reconciliation of the slopes to compute the +! interfacial values +! +! This scheme might have ben developed by Shchepetkin. A.F., personal communication. +! See also Engwirda, D., and M. Kelley, A WENO-type slope-limiter for a family of piecewise +! polynomial methods, arXive:1606.08188v1, 27 June 2016. +! +! 2) input arguments: +! s - initial scalar fields in pi-layer space +! h_src - initial layer thicknesses (>=0) +! nk - number of layers +! ns - number of fields +! thin - layer thickness (>0) that can be ignored +! PCM_lay - use PCM for selected layers (optional) +! +! 3) output arguments: +! edges - cell edge scalar values for the WENO reconstruction +! edges.1 is value at interface above +! edges.2 is value at interface below +! +! 4) Laurent Debreu, Grenoble. +! Alan J. Wallcraft, Naval Research Laboratory, July 2008. +!----------------------------------------------------------------------- +! +! real, parameter :: dsmll=1.0e-8 ! This has units of [A2], and hence can not be a parameter. +! + real :: curv_cell ! An estimate of the tracer curvature centered on a cell times the grid + ! spacing [A H-1 ~> A m-1 or A m2 kg-1] + real :: seh1, seh2 ! Tracer slopes at the cell edges times the cell grid spacing [A] + real :: q01, q02 ! Various tracer differences between a cell average and the edge values [A] + real :: q001, q002 ! Tracer slopes at the cell edges times the cell grid spacing [A] + logical :: PCM_layer(nk) ! True for layers that should use PCM remapping, either because they are + ! very thin, or because this is specified by PCM_lay. + real :: dp(nk) ! Input grid layer thicknesses, but with a minimum thickness given by thin [H ~> m or kg m-2] + real :: qdpkm(nk) ! Inverse of the sum of two adjacent thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: qdpkmkp(nk) ! Inverse of the sum of three adjacent thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: dpkm2kp(nk) ! Twice the distance between the centers of the layers two apart [H ~> m or kg m-2] + real :: zw(nk,2) ! Squared combinations of the differences between the cell average tracer + ! concentrations and the left and right edges [A2] + real :: min_ratio ! The minimum ratio of the values of zw used to interpolate the edge values [nondim] + real :: wt1 ! The weight of the upper layer in the interpolated shared edge value [nondim] + real :: slope_edge(nk+1) ! Tracer slopes at the edges [A H-1 ~> A m-1 or A m2 kg-1] + real :: val_edge(nk+1) ! A weighted average edge concentration [A] + integer :: i, k + + min_ratio = 1.0e-8 + + ! The WENO remapper is not currently written to work with massless layers, so set + ! the thicknesses for very thin layers to some minimum value. + do k=1,nk ; dp(k) = max(h_src(k), thin) ; enddo + + ! Specify the layers that will use PCM remapping. + if (present(PCM_lay)) then + do k=1,nk ; PCM_layer(k) = (PCM_lay(k) .or. dp(k) <= thin) ; enddo + else + do k=1,nk ; PCM_layer(k) = (dp(k) <= thin) ; enddo + endif + + !compute grid metrics + do k=2,nk-1 + qdpkm( K) = 1.0 / (dp(k-1) + dp(k)) + qdpkmkp(k) = 1.0 / (dp(k-1) + dp(k) + dp(k+1)) + dpkm2kp(k) = dp(k-1) + 2.0*dp(k) + dp(k+1) + enddo !k + qdpkm(nk) = 1.0 / (dp(nk-1) + dp(nk)) + + do i=1,ns + do K=2,nk + slope_edge(K) = qdpkm(K) * (s(k,i)-s(k-1,i)) + enddo !k + k = 1 !PCM first layer + edges(k,1,i) = s(k,i) + edges(k,2,i) = s(k,i) + zw(k,1) = 0.0 + zw(k,2) = 0.0 + do k=2,nk-1 + if ((slope_edge(K)*slope_edge(K+1) < 0.0) .or. PCM_layer(k)) then !use PCM + edges(k,1,i) = s(k,i) + edges(k,2,i) = s(k,i) + zw(k,1) = 0.0 + zw(k,2) = 0.0 + else + seh1 = dp(k)*slope_edge(K+1) + seh2 = dp(k)*slope_edge(K) + q01 = dpkm2kp(k)*slope_edge(K+1) + q02 = dpkm2kp(k)*slope_edge(K) + if (abs(seh1) > abs(q02)) then + seh1 = q02 + endif + if (abs(seh2) > abs(q01)) then + seh2 = q01 + endif + curv_cell = (seh1 - seh2) * qdpkmkp(k) + q001 = seh1 - curv_cell*dp(k+1) + q002 = seh2 + curv_cell*dp(k-1) + ! q001 = (seh1 * (dp(k-1) + dp(k)) + seh2 * dp(k+1)) * qdpkmkp(k) + ! q002 = (seh2 * (dp(k+1) + dp(k)) + seh1 * dp(k-1)) * qdpkmkp(k) + + edges(k,2,i) = s(k,i) + q001 + edges(k,1,i) = s(k,i) - q002 + zw(k,1) = (2.0*q001 - q002)**2 + zw(k,2) = (2.0*q002 - q001)**2 + endif !PCM:WENO + enddo !k + k = nk !PCM last layer + edges(k,1,i) = s(k,i) + edges(k,2,i) = s(k,i) + zw(k, 1) = 0.0 + zw(k, 2) = 0.0 + + do k=2,nk + ! This was the original code based on that in Hycom, but because zw has + ! dimensions of [A2], it can not use a constant (hard coded) value of dsmll. + ! ds2a = max(zw(k-1,2), dsmll) + ! ds2b = max(zw(k, 1), dsmll) + ! val_edge(K) = (ds2b*edges(k-1,2,i)+ds2a*edges(k,1,i)) / (ds2b+ds2a) + ! Use a weighted average of the two layers' estimated edge values as the actual edge value. + if (zw(k,1) + zw(k-1,2) <= 0.0) then + wt1 = 0.5 + elseif (zw(k,1) <= min_ratio * (zw(k,1) + zw(k-1,2))) then + wt1 = min_ratio + elseif (zw(k-1,2) <= min_ratio * (zw(k,1) + zw(k-1,2))) then + wt1 = (1.0 - min_ratio) + else + wt1 = zw(k,1) / (zw(k,1) + zw(k-1,2)) + endif + val_edge(k) = wt1*edges(k-1,2,i) + (1.0-wt1)*edges(k,1,i) + enddo !k + val_edge( 1) = 2.0*s( 1,i)-val_edge( 2) !not used? + val_edge(nk+1) = 2.0*s(nk,i)-val_edge(nk) !not used? + + do k=2,nk-1 + if (.not.PCM_layer(k)) then !don't use PCM + q01 = val_edge(K+1) - s(k,i) + q02 = s(k,i) - val_edge(K) + if (q01*q02 < 0.0) then + q01 = 0.0 + q02 = 0.0 + elseif (abs(q01) > abs(2.0*q02)) then + q01 = 2.0*q02 + elseif (abs(q02) > abs(2.0*q01)) then + q02 = 2.0*q01 + endif + edges(k,1,i) = s(k,i) - q02 + edges(k,2,i) = s(k,i) + q01 + endif ! PCM:WENO + enddo !k + enddo !i + +end subroutine hybgen_weno_coefs + +end module MOM_hybgen_remap diff --git a/src/ALE/MOM_hybgen_unmix.F90 b/src/ALE/MOM_hybgen_unmix.F90 new file mode 100644 index 0000000000..dee62ef47c --- /dev/null +++ b/src/ALE/MOM_hybgen_unmix.F90 @@ -0,0 +1,529 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> This module contains the hybgen unmixing routines from HYCOM, with +!! modifications to follow the MOM6 coding conventions and several bugs fixed +module MOM_hybgen_unmix + +use MOM_EOS, only : EOS_type, calculate_density, calculate_density_derivs +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, param_file_type, log_param +use MOM_hybgen_regrid, only : hybgen_column_init +use MOM_hybgen_regrid, only : hybgen_regrid_CS, get_hybgen_regrid_params +use MOM_interface_heights, only : calc_derived_thermo +use MOM_tracer_registry, only : tracer_registry_type, tracer_type, MOM_tracer_chkinv +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : ocean_grid_type, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +!> Control structure containing required parameters for the hybgen coordinate generator +type, public :: hybgen_unmix_CS ; private + + integer :: nsigma !< Number of sigma levels used by HYBGEN + real :: hybiso !< Hybgen uses PCM if layer is within hybiso of target density [R ~> kg m-3] + + real :: dp00i !< Deep isopycnal spacing minimum thickness [H ~> m or kg m-2] + real :: qhybrlx !< Hybgen relaxation amount per thermodynamic time steps [nondim] + + real, allocatable, dimension(:) :: & + dp0k, & !< minimum deep z-layer separation [H ~> m or kg m-2] + ds0k !< minimum shallow z-layer separation [H ~> m or kg m-2] + + real :: dpns !< depth to start terrain following [H ~> m or kg m-2] + real :: dsns !< depth to stop terrain following [H ~> m or kg m-2] + real :: min_dilate !< The minimum amount of dilation that is permitted when converting target + !! coordinates from z to z* [nondim]. This limit applies when wetting occurs. + real :: max_dilate !< The maximum amount of dilation that is permitted when converting target + !! coordinates from z to z* [nondim]. This limit applies when drying occurs. + + real :: topiso_const !< Shallowest depth for isopycnal layers [H ~> m or kg m-2] + ! real, dimension(:,:), allocatable :: topiso + + real :: ref_pressure !< Reference pressure for density calculations [R L2 T-2 ~> Pa] + real, allocatable, dimension(:) :: target_density !< Nominal density of interfaces [R ~> kg m-3] + +end type hybgen_unmix_CS + +public hybgen_unmix, init_hybgen_unmix, end_hybgen_unmix +public set_hybgen_unmix_params + +contains + +!> Initialise a hybgen_unmix_CS control structure and store its parameters +subroutine init_hybgen_unmix(CS, GV, US, param_file, hybgen_regridCS) + type(hybgen_unmix_CS), pointer :: CS !< Unassociated pointer to hold the control structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file + type(hybgen_regrid_CS), pointer :: hybgen_regridCS !< Control structure for hybgen + !! regridding for sharing parameters. + integer :: k + + if (associated(CS)) call MOM_error(FATAL, "init_hybgen_unmix: CS already associated!") + allocate(CS) + allocate(CS%target_density(GV%ke)) + + allocate(CS%dp0k(GV%ke), source=0.0) ! minimum deep z-layer separation + allocate(CS%ds0k(GV%ke), source=0.0) ! minimum shallow z-layer separation + + ! Set the parameters for the hybgen unmixing from a hybgen regridding control structure. + call get_hybgen_regrid_params(hybgen_regridCS, ref_pressure=CS%ref_pressure, & + nsigma=CS%nsigma, dp0k=CS%dp0k, ds0k=CS%ds0k, & + dp00i=CS%dp00i, topiso_const=CS%topiso_const, qhybrlx=CS%qhybrlx, & + hybiso=CS%hybiso, min_dilate=CS%min_dilate, max_dilate=CS%max_dilate, & + target_density=CS%target_density) + + ! Determine the depth range over which to use a sigma (terrain-following) coordinate. + ! --- terrain following starts at depth dpns and ends at depth dsns + if (CS%nsigma == 0) then + CS%dpns = CS%dp0k(1) + CS%dsns = 0.0 + else + CS%dpns = 0.0 + CS%dsns = 0.0 + do k=1,CS%nsigma + CS%dpns = CS%dpns + CS%dp0k(k) + CS%dsns = CS%dsns + CS%ds0k(k) + enddo !k + endif !nsigma + +end subroutine init_hybgen_unmix + +!> This subroutine deallocates memory in the control structure for the hybgen unmixing module +subroutine end_hybgen_unmix(CS) + type(hybgen_unmix_CS), pointer :: CS !< Coordinate control structure + + ! nothing to do + if (.not. associated(CS)) return + + deallocate(CS%target_density) + deallocate(CS%dp0k, CS%ds0k) + deallocate(CS) +end subroutine end_hybgen_unmix + +!> This subroutine can be used to set the parameters for the hybgen module +subroutine set_hybgen_unmix_params(CS, min_thickness) + type(hybgen_unmix_CS), pointer :: CS !< Coordinate unmixing control structure + real, optional, intent(in) :: min_thickness !< Minimum allowed thickness [H ~> m or kg m-2] + + if (.not. associated(CS)) call MOM_error(FATAL, "set_hybgen_params: CS not associated") + +! if (present(min_thickness)) CS%min_thickness = min_thickness +end subroutine set_hybgen_unmix_params + + +!> Unmix the properties in the lowest layer with mass if it is too light, and make +!! any other changes to the water column to prepare for regridding. +subroutine hybgen_unmix(G, GV, US, CS, tv, Reg, ntr, h) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(hybgen_unmix_CS), intent(in) :: CS !< hybgen control structure + type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure + type(tracer_registry_type), pointer :: Reg !< Tracer registry structure + integer, intent(in) :: ntr !< The number of tracers in the registry, or + !! 0 if the registry is not in use. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + +! --- -------------------------------------------- +! --- hybrid grid generator, single j-row (part A). +! --- -------------------------------------------- + + character(len=256) :: mesg ! A string for output messages + integer :: fixlay ! deepest fixed coordinate layer + real :: qhrlx( GV%ke+1) ! relaxation coefficient per timestep [nondim] + real :: dp0ij( GV%ke) ! minimum layer thickness [H ~> m or kg m-2] + real :: dp0cum(GV%ke+1) ! minimum interface depth [H ~> m or kg m-2] + + real :: Rcv_tgt(GV%ke) ! Target potential density [R ~> kg m-3] + real :: temp(GV%ke) ! A column of potential temperature [C ~> degC] + real :: saln(GV%ke) ! A column of salinity [S ~> ppt] + real :: Rcv(GV%ke) ! A column of coordinate potential density [R ~> kg m-3] + real :: h_col(GV%ke) ! A column of layer thicknesses [H ~> m or kg m-2] + real :: p_col(GV%ke) ! A column of reference pressures [R L2 T-2 ~> Pa] + real :: tracer(GV%ke,max(ntr,1)) ! Columns of each tracer [Conc] + real :: h_tot ! Total thickness of the water column [H ~> m or kg m-2] + real :: dz_tot ! Vertical distance between the top and bottom of the water column [Z ~> m] + real :: nominalDepth ! Depth of ocean bottom in thickness units (positive downward) [H ~> m or kg m-2] + real :: h_thin ! A negligibly small thickness to identify essentially + ! vanished layers [H ~> m or kg m-2] + real :: dilate ! A factor by which to dilate the target positions from z to z* [nondim] + + real :: Th_tot_in, Th_tot_out ! Column integrated temperature [C H ~> degC m or degC kg m-2] + real :: Sh_tot_in, Sh_tot_out ! Column integrated salinity [S H ~> ppt m or ppt kg m-2] + real :: Trh_tot_in(max(ntr,1)) ! Initial column integrated tracer amounts [conc H ~> conc m or conc kg m-2] + real :: Trh_tot_out(max(ntr,1)) ! Final column integrated tracer amounts [conc H ~> conc m or conc kg m-2] + + logical :: debug_conservation ! If true, test for non-conservation. + logical :: terrain_following ! True if this column is terrain following. + integer :: trcflg(max(ntr,1)) ! Hycom tracer type flag for each tracer + integer :: i, j, k, nk, m + + nk = GV%ke + + ! Set all tracers to be passive. Setting this to 2 treats a tracer like temperature. + trcflg(:) = 3 + + h_thin = 1e-6*GV%m_to_H + debug_conservation = .false. ! Set this to true for debugging + + if ((allocated(tv%SpV_avg)) .and. (tv%valid_SpV_halo < 1)) then + if (tv%valid_SpV_halo < 0) then + mesg = "invalid values of SpV_avg." + else + mesg = "insufficiently large SpV_avg halos of width 0 but 1 is needed." + endif + call MOM_error(FATAL, "hybgen_unmix called in fully non-Boussinesq mode with "//trim(mesg)) + endif + + p_col(:) = CS%ref_pressure + + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 ; if (G%mask2dT(i,j)>0.) then + + h_tot = 0.0 + do k=1,nk + ! Rcv_tgt(k) = theta(i,j,k) ! If a 3-d target density were set up in theta, use that here. + Rcv_tgt(k) = CS%target_density(k) ! MOM6 does not yet support 3-d target densities. + h_col(k) = h(i,j,k) + h_tot = h_tot + h_col(k) + temp(k) = tv%T(i,j,k) + saln(k) = tv%S(i,j,k) + enddo + + ! This sets the potential density from T and S. + call calculate_density(temp, saln, p_col, Rcv, tv%eqn_of_state) + + do m=1,ntr ; do k=1,nk + tracer(k,m) = Reg%Tr(m)%t(i,j,k) + enddo ; enddo + + ! Store original amounts to test for conservation of temperature, salinity, and tracers. + if (debug_conservation) then + Th_tot_in = 0.0 ; Sh_tot_in = 0.0 ; Trh_tot_in(:) = 0.0 + do k=1,nk + Sh_tot_in = Sh_tot_in + h_col(k)*saln(k) + Th_tot_in = Th_tot_in + h_col(k)*temp(k) + enddo + do m=1,ntr ; do k=1,nk + Trh_tot_in(m) = Trh_tot_in(m) + h_col(k)*tracer(k,m) + enddo ; enddo + endif + + ! The following block of code is used to trigger z* stretching of the targets heights. + if (allocated(tv%SpV_avg)) then ! This is the fully non-Boussinesq version + dz_tot = 0.0 + do k=1,nk + dz_tot = dz_tot + GV%H_to_RZ * tv%SpV_avg(i,j,k) * h_col(k) + enddo + if (dz_tot <= CS%min_dilate * (G%meanSL(i,j) + G%bathyT(i,j))) then + dilate = CS%min_dilate + elseif (dz_tot >= CS%max_dilate * (G%meanSL(i,j) + G%bathyT(i,j))) then + dilate = CS%max_dilate + else + dilate = dz_tot / (G%meanSL(i,j) + G%bathyT(i,j)) + endif + else + nominalDepth = (G%meanSL(i,j) + G%bathyT(i,j)) * GV%Z_to_H + if (h_tot <= CS%min_dilate * nominalDepth) then + dilate = CS%min_dilate + elseif (h_tot >= CS%max_dilate * nominalDepth) then + dilate = CS%max_dilate + else + dilate = h_tot / nominalDepth + endif + endif + + terrain_following = (h_tot < dilate*CS%dpns) .and. (CS%dpns >= CS%dsns) + + ! Convert the regridding parameters into specific constraints for this column. + call hybgen_column_init(nk, CS%nsigma, CS%dp0k, CS%ds0k, CS%dp00i, & + CS%topiso_const, CS%qhybrlx, CS%dpns, CS%dsns, h_tot, dilate, & + h_col, fixlay, qhrlx, dp0ij, dp0cum) + + ! Do any unmixing of the column that is needed to move the layer properties toward their targets. + call hybgen_column_unmix(CS, nk, Rcv_tgt, temp, saln, Rcv, tv%eqn_of_state, & + ntr, tracer, trcflg, fixlay, qhrlx, h_col, & + terrain_following, h_thin) + + ! Store the output from hybgen_unmix in the 3-d arrays. + do k=1,nk + h(i,j,k) = h_col(k) + enddo + ! Note that temperature and salinity are among the tracers unmixed here. + do m=1,ntr ; do k=1,nk + Reg%Tr(m)%t(i,j,k) = tracer(k,m) + enddo ; enddo + ! However, temperature and salinity may have been treated differently from other tracers. + do k=1,nk + tv%T(i,j,k) = temp(k) + tv%S(i,j,k) = saln(k) + enddo + + ! Test for conservation of temperature, salinity, and tracers. + if (debug_conservation) then + Th_tot_out = 0.0 ; Sh_tot_out = 0.0 ; Trh_tot_out(:) = 0.0 + do k=1,nk + Sh_tot_out = Sh_tot_out + h_col(k)*saln(k) + Th_tot_out = Th_tot_out + h_col(k)*temp(k) + enddo + do m=1,ntr ; do k=1,nk + Trh_tot_out(m) = Trh_tot_out(m) + h_col(k)*tracer(k,m) + enddo ; enddo + if (abs(Sh_tot_in - Sh_tot_out) > 1.e-15*(abs(Sh_tot_in) + abs(Sh_tot_out))) then + write(mesg, '("i,j=",I0,",",I0," Sh_tot = ",2es17.8," err = ",es13.4)') & + i, j, Sh_tot_in, Sh_tot_out, (Sh_tot_in - Sh_tot_out) + call MOM_error(FATAL, "Mismatched column salinity in hybgen_unmix: "//trim(mesg)) + endif + if (abs(Th_tot_in - Th_tot_out) > 1.e-10*(abs(Th_tot_in) + abs(Th_tot_out))) then + write(mesg, '("i,j=",I0,",",I0," Th_tot = ",2es17.8," err = ",es13.4)') & + i, j, Th_tot_in, Th_tot_out, (Th_tot_in - Th_tot_out) + call MOM_error(FATAL, "Mismatched column temperature in hybgen_unmix: "//trim(mesg)) + endif + do m=1,ntr + if (abs(Trh_tot_in(m) - Trh_tot_out(m)) > 1.e-10*(abs(Trh_tot_in(m)) + abs(Trh_tot_out(m)))) then + write(mesg, '("i,j=",I0,",",I0," Trh_tot(",i0,") = ",2es17.8," err = ",es13.4)') & + i, j, m, Trh_tot_in(m), Trh_tot_out(m), (Trh_tot_in(m) - Trh_tot_out(m)) + call MOM_error(FATAL, "Mismatched column tracer in hybgen_unmix: "//trim(mesg)) + endif + enddo + endif + endif ; enddo ; enddo !i & j. + + ! Update the layer properties + if (allocated(tv%SpV_avg)) call calc_derived_thermo(tv, h, G, GV, US, halo=1) + +end subroutine hybgen_unmix + + +!> Unmix the properties in the lowest layer if it is too light. +subroutine hybgen_column_unmix(CS, nk, Rcv_tgt, temp, saln, Rcv, eqn_of_state, & + ntr, tracer, trcflg, fixlay, qhrlx, h_col, & + terrain_following, h_thin) + type(hybgen_unmix_CS), intent(in) :: CS !< hybgen unmixing control structure + integer, intent(in) :: nk !< The number of layers + integer, intent(in) :: fixlay !< deepest fixed coordinate layer + real, intent(in) :: qhrlx(nk+1) !< Relaxation fraction per timestep [nondim], < 1. + real, intent(in) :: Rcv_tgt(nk) !< Target potential density [R ~> kg m-3] + real, intent(inout) :: temp(nk) !< A column of potential temperature [C ~> degC] + real, intent(inout) :: saln(nk) !< A column of salinity [S ~> ppt] + real, intent(inout) :: Rcv(nk) !< Coordinate potential density [R ~> kg m-3] + type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure + integer, intent(in) :: ntr !< The number of registered passive tracers + real, intent(inout) :: tracer(nk, max(ntr,1)) !< Columns of the passive tracers [Conc] + integer, intent(in) :: trcflg(max(ntr,1)) !< Hycom tracer type flag for each tracer + real, intent(inout) :: h_col(nk+1) !< Layer thicknesses [H ~> m or kg m-2] + logical, intent(in) :: terrain_following !< True if this column is terrain following + real, intent(in) :: h_thin !< A negligibly small thickness to identify + !! essentially vanished layers [H ~> m or kg m-2] + +! +! --- ------------------------------------------------------------------ +! --- hybrid grid generator, single column - ummix lowest massive layer. +! --- ------------------------------------------------------------------ +! + ! Local variables + real :: h_hat ! A portion of a layer to move across an interface [H ~> m or kg m-2] + real :: delt, deltm ! Temperature differences between successive layers [C ~> degC] + real :: dels, delsm ! Salinity differences between successive layers [S ~> ppt] + real :: abs_dRdT ! The absolute value of the derivative of the coordinate density + ! with temperature [R C-1 ~> kg m-3 degC-1] + real :: abs_dRdS ! The absolute value of the derivative of the coordinate density + ! with salinity [R S-1 ~> kg m-3 ppt-1] + real :: q, qts ! Nondimensional fractions in the range of 0 to 1 [nondim] + real :: frac_dts ! The fraction of the temperature or salinity difference between successive + ! layers by which the source layer's property changes by the loss of water + ! that matches the destination layers properties via unmixing [nondim]. + real :: qtr ! The fraction of the water that will come from the layer below, + ! used for updating the concentration of passive tracers [nondim] + real :: swap_T ! A swap variable for temperature [C ~> degC] + real :: swap_S ! A swap variable for salinity [S ~> ppt] + real :: swap_tr ! A temporary swap variable for the tracers [conc] + logical, parameter :: lunmix=.true. ! unmix a too light deepest layer + integer :: k, ka, kp, kt, m + + ! --- identify the deepest layer kp with significant thickness (> h_thin) + kp = 2 !minimum allowed value + do k=nk,3,-1 + if (h_col(k) >= h_thin) then + kp = k + exit + endif + enddo !k + + k = kp !at least 2 + ka = max(k-2,1) !k might be 2 +! + if ( ((k > fixlay+1) .and. (.not.terrain_following)) .and. & ! layer not fixed depth + (h_col(k-1) >= h_thin) .and. & ! layer above not too thin + (Rcv_tgt(k) > Rcv(k)) .and. & ! layer is lighter than its target + ((Rcv(k-1) > Rcv(k)) .and. (Rcv(ka) > Rcv(k))) ) then +! +! --- water in the deepest inflated layer with significant thickness +! --- (kp) is too light, and it is lighter than the two layers above. +! --- +! --- this should only occur when relaxing or nudging layer thickness +! --- and is a bug (bad interaction with tsadvc) even in those cases +! --- +! --- entrain the entire layer into the one above +!--- note the double negative in T=T-q*(T-T'), equiv. to T=T+q*(T'-T) + q = h_col(k) / (h_col(k) + h_col(k-1)) + temp(k-1) = temp(k-1) - q*(temp(k-1) - temp(k)) + saln(k-1) = saln(k-1) - q*(saln(k-1) - saln(k)) + call calculate_density(temp(k-1), saln(k-1), CS%ref_pressure, Rcv(k-1), eqn_of_state) + + do m=1,ntr + tracer(k-1,m) = tracer(k-1,m) - q*(tracer(k-1,m) - tracer(k,m) ) + enddo !m +! --- entrained the entire layer into the one above, so now kp=kp-1 + h_col(k-1) = h_col(k-1) + h_col(k) + h_col(k) = 0.0 + kp = k-1 + elseif ( ((k > fixlay+1) .and. (.not.terrain_following)) .and. & ! layer not fixed depth + (h_col(k-1) >= h_thin) .and. & ! layer above not too thin + (Rcv_tgt(k) > Rcv(k)) .and. & ! layer is lighter than its target + (Rcv(k-1) > Rcv(k)) ) then +! --- water in the deepest inflated layer with significant thickness +! --- (kp) is too light, and it is lighter than the layer above, but not the layer two above. +! --- +! --- swap the entire layer with the one above. + if (h_col(k) <= h_col(k-1)) then + ! The bottom layer is thinner; swap the entire bottom layer with a portion of the layer above. + q = h_col(k) / h_col(k-1) !<=1.0 + + swap_T = temp(k-1) + temp(k-1) = temp(k-1) + q*(temp(k) - temp(k-1)) + temp(k) = swap_T + + swap_S = saln(k-1) + saln(k-1) = saln(k-1) + q*(saln(k) - saln(k-1)) + saln(k) = swap_S + + Rcv(k) = Rcv(k-1) + call calculate_density(temp(k-1), saln(k-1), CS%ref_pressure, Rcv(k-1), eqn_of_state) + + do m=1,ntr + swap_tr = tracer(k-1,m) + tracer(k-1,m) = tracer(k-1,m) - q * (tracer(k-1,m) - tracer(k,m)) + tracer(k,m) = swap_tr + enddo !m + else + ! The bottom layer is thicker; swap the entire layer above with a portion of the bottom layer. + q = h_col(k-1) / h_col(k) !<1.0 + + swap_T = temp(k) + temp(k) = temp(k) + q*(temp(k-1) - temp(k)) + temp(k-1) = swap_T + + swap_S = saln(k) + saln(k) = saln(k) + q*(saln(k-1) - saln(k)) + saln(k-1) = swap_S + + Rcv(k-1) = Rcv(k) + call calculate_density(temp(k), saln(k), CS%ref_pressure, Rcv(k), eqn_of_state) + + do m=1,ntr + swap_tr = tracer(k,m) + tracer(k,m) = tracer(k,m) + q * (tracer(k-1,m) - tracer(k,m)) + tracer(k-1,m) = swap_tr + enddo !m + endif !bottom too light + endif + + k = kp !at least 2 + ka = max(k-2,1) !k might be 2 + + if ( lunmix .and. & ! usually .true. + ((k > fixlay+1) .and. (.not.terrain_following)) .and. & ! layer not fixed depth + (h_col(k-1) >= h_thin) .and. & ! layer above not too thin + (Rcv(k) < Rcv_tgt(k)) .and. & ! layer is lighter than its target + (Rcv(k) > Rcv_tgt(k-1)) .and. & ! layer is denser than the target above + (abs(Rcv_tgt(k-1) - Rcv(k-1)) < CS%hybiso) .and. & ! layer above is near its target + (Rcv(k) - Rcv(k-1) > 0.001*(Rcv_tgt(k) - Rcv_tgt(k-1))) ) then +! +! --- water in the deepest inflated layer with significant thickness (kp) is too +! --- light but denser than the layer above, with the layer above near-isopycnal +! --- +! --- split layer into 2 sublayers, one near the desired density +! --- and one exactly matching the T&S properties of layer k-1. +! --- To prevent "runaway" T or S, the result satisfies either +! --- abs(T.k - T.k-1) <= abs(T.k-N - T.k-1) or +! --- abs(S.k - S.k-1) <= abs(S.k-N - S.k-1) where +! --- Rcv.k-1 - Rcv.k-N is at least Rcv_tgt(k-1) - Rcv_tgt(k-2) +! --- It is also limited to a 50% change in layer thickness. + + ka = 1 + do kt=k-2,2,-1 + if ( Rcv(k-1) - Rcv(kt) >= Rcv_tgt(k-1) - Rcv_tgt(k-2) ) then + ka = kt !usually k-2 + exit + endif + enddo + + delsm = abs(saln(ka) - saln(k-1)) + dels = abs(saln(k-1) - saln(k)) + deltm = abs(temp(ka) - temp(k-1)) + delt = abs(temp(k-1) - temp(k)) + + call calculate_density_derivs(temp(k-1), saln(k-1), CS%ref_pressure, abs_dRdT, abs_dRdS, eqn_of_state) + ! Bound deltm and delsm based on the equation of state and density differences between layers. + abs_dRdT = abs(abs_dRdT) ; abs_dRdS = abs(abs_dRdS) + if (abs_dRdT * deltm > Rcv_tgt(k)-Rcv_tgt(k-1)) deltm = (Rcv_tgt(k)-Rcv_tgt(k-1)) / abs_dRdT + if (abs_dRdS * delsm > Rcv_tgt(k)-Rcv_tgt(k-1)) delsm = (Rcv_tgt(k)-Rcv_tgt(k-1)) / abs_dRdS + + qts = 0.0 + if (qts*dels < min(delsm-dels, dels)) qts = min(delsm-dels, dels) / dels + if (qts*delt < min(deltm-delt, delt)) qts = min(deltm-delt, delt) / delt + + ! Note that Rcv_tgt(k) > Rcv(k) > Rcv(k-1), and 0 <= qts <= 1. + ! qhrlx is relaxation coefficient (inverse baroclinic time steps), 0 <= qhrlx <= 1. + ! This takes the minimum of the two estimates. + if ((1.0+qts) * (Rcv_tgt(k)-Rcv(k)) < qts * (Rcv_tgt(k)-Rcv(k-1))) then + q = qhrlx(k) * ((Rcv_tgt(k)-Rcv(k)) / (Rcv_tgt(k)-Rcv(k-1))) + else + q = qhrlx(k) * (qts / (1.0+qts)) ! upper sublayer <= 50% of total + endif + frac_dts = q / (1.0-q) ! 0 <= q <= 0.5, so 0 <= frac_dts <= 1 + + h_hat = q * h_col(k) + h_col(k-1) = h_col(k-1) + h_hat + h_col(k) = h_col(k) - h_hat + + temp(k) = temp(k) + frac_dts * (temp(k) - temp(k-1)) + saln(k) = saln(k) + frac_dts * (saln(k) - saln(k-1)) + call calculate_density(temp(k), saln(k), CS%ref_pressure, Rcv(k), eqn_of_state) + + if ((ntr > 0) .and. (h_hat /= 0.0)) then + ! qtr is the fraction of the new upper layer from the old lower layer. + ! The nonconservative original from Hycom: qtr = h_hat / max(h_hat, h_col(k)) !between 0 and 1 + qtr = h_hat / h_col(k-1) ! Between 0 and 1, noting the h_col(k-1) = h_col(k-1) + h_hat above. + do m=1,ntr + if (trcflg(m) == 2) then !temperature tracer + tracer(k,m) = tracer(k,m) + frac_dts * (tracer(k,m) - tracer(k-1,m)) + else !standard tracer - not split into two sub-layers + tracer(k-1,m) = tracer(k-1,m) + qtr * (tracer(k,m) - tracer(k-1,m)) + endif !trcflg + enddo !m + endif !tracers + endif !too light + +! ! Fill properties of massless or near-massless (thickness < h_thin) layers +! ! This was in the Hycom verion, but it appears to be unnecessary in MOM6. +! do k=kp+1,nk +! ! --- fill thin and massless layers on sea floor with fluid from above +! Rcv(k) = Rcv(k-1) +! do m=1,ntr +! tracer(k,m) = tracer(k-1,m) +! enddo !m +! saln(k) = saln(k-1) +! temp(k) = temp(k-1) +! enddo !k + +end subroutine hybgen_column_unmix + +end module MOM_hybgen_unmix diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 94d7852851..59ec8d4d7d 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -1,16 +1,23 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Generates vertical grids as part of the ALE algorithm module MOM_regridding -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE, assert use MOM_file_parser, only : param_file_type, get_param, log_param use MOM_io, only : file_exists, field_exists, field_size, MOM_read_data +use MOM_io, only : read_variable +use MOM_io, only : vardesc, var_desc, SINGLE_FILE +use MOM_io, only : MOM_netCDF_file, MOM_field +use MOM_io, only : create_MOM_file, MOM_write_field use MOM_io, only : verify_variable_units, slasher use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : ocean_grid_type, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : EOS_type, calculate_density +use MOM_domains, only : max_across_PEs, pass_var use MOM_string_functions, only : uppercase, extractWord, extract_integer, extract_real use MOM_remapping, only : remapping_CS @@ -19,16 +26,23 @@ module MOM_regridding use regrid_consts, only : REGRIDDING_LAYER, REGRIDDING_ZSTAR use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA use regrid_consts, only : REGRIDDING_ARBITRARY, REGRIDDING_SIGMA_SHELF_ZSTAR -use regrid_consts, only : REGRIDDING_HYCOM1, REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE -use regrid_interp, only : interp_CS_type, set_interp_scheme, set_interp_extrap - -use coord_zlike, only : init_coord_zlike, zlike_CS, set_zlike_params, build_zstar_column, end_coord_zlike -use coord_sigma, only : init_coord_sigma, sigma_CS, set_sigma_params, build_sigma_column, end_coord_sigma +use regrid_consts, only : REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, REGRIDDING_ADAPTIVE +use regrid_interp, only : interp_CS_type +use regrid_interp, only : set_interp_scheme, set_interp_extrap, set_interp_answer_date + +use coord_zlike, only : zlike_CS +use coord_zlike, only : init_coord_zlike, set_zlike_params, build_zstar_column, end_coord_zlike +use coord_sigma, only : sigma_CS +use coord_sigma, only : init_coord_sigma, set_sigma_params, build_sigma_column, end_coord_sigma use coord_rho, only : init_coord_rho, rho_CS, set_rho_params, build_rho_column, end_coord_rho use coord_rho, only : old_inflate_layers_1d -use coord_hycom, only : init_coord_hycom, hycom_CS, set_hycom_params, build_hycom1_column, end_coord_hycom -use coord_slight, only : init_coord_slight, slight_CS, set_slight_params, build_slight_column, end_coord_slight -use coord_adapt, only : init_coord_adapt, adapt_CS, set_adapt_params, build_adapt_column, end_coord_adapt +use coord_hycom, only : hycom_CS +use coord_hycom, only : init_coord_hycom, set_hycom_params, build_hycom1_column, end_coord_hycom +use coord_hycom, only : init_3d_coord_hycom +use coord_adapt, only : adapt_CS +use coord_adapt, only : init_coord_adapt, set_adapt_params, build_adapt_column, end_coord_adapt +use MOM_hybgen_regrid, only : hybgen_regrid, hybgen_regrid_CS, init_hybgen_regrid, end_hybgen_regrid +use MOM_hybgen_regrid, only : write_Hybgen_coord_file implicit none ; private @@ -45,23 +59,29 @@ module MOM_regridding !> This array is set by function setCoordinateResolution() !! It contains the "resolution" or delta coordinate of the target !! coordinate. It has the units of the target coordinate, e.g. - !! [Z ~> m] for z*, non-dimensional for sigma, etc. + !! [Z ~> m] for z*, [nondim] for sigma, etc. real, dimension(:), allocatable :: coordinateResolution !> This is a scaling factor that restores coordinateResolution to values in - !! the natural units for output. + !! the natural units for output, perhaps [nondim] real :: coord_scale = 1.0 !> This array is set by function set_target_densities() !! This array is the nominal coordinate of interfaces and is the !! running sum of coordinateResolution, in [R ~> kg m-3]. i.e. !! target_density(k+1) = coordinateResolution(k) + coordinateResolution(k) - !! It is only used in "rho", "SLight" or "Hycom" mode. + !! It is only used in "rho" or "Hycom" mode. real, dimension(:), allocatable :: target_density !> A flag to indicate that the target_density arrays has been filled with data. logical :: target_density_set = .false. + !> Nominal HYCOM1 3D near-surface resolution [Z ~> m] + real, allocatable, dimension(:,:,:) :: coordinateResolution_3d + + !> Nominal HYCOM1 3D density of interfaces [R ~> kg m-3] + real, allocatable, dimension(:,:,:) :: target_density_3d + !> This array is set by function set_regrid_max_depths() !! It specifies the maximum depth that every interface is allowed to take [H ~> m or kg m-2]. real, dimension(:), allocatable :: max_interface_depths @@ -82,9 +102,16 @@ module MOM_regridding !> Minimum thickness allowed when building the new grid through regridding [H ~> m or kg m-2]. real :: min_thickness + !> If true, call adjust_interface_motion() after initial grid generation + logical :: use_adjust_interface_motion + !> Reference pressure for potential density calculations [R L2 T-2 ~> Pa] real :: ref_pressure = 2.e7 + !> If true, always pass through the depth-based time filtering that uses CS%old_grid_weight + !! If false, allows bypassing of the call if CS%old_grid_weight==0 + logical :: use_depth_based_time_filter + !> Weight given to old coordinate when blending between new and old grids [nondim] !! Used only below depth_of_time_filter_shallow, with a cubic variation !! from zero to full effect between depth_of_time_filter_shallow and @@ -98,45 +125,45 @@ module MOM_regridding real :: depth_of_time_filter_deep = 0. !> Fraction (between 0 and 1) of compressibility to add to potential density - !! profiles when interpolating for target grid positions. [nondim] + !! profiles when interpolating for target grid positions [nondim] real :: compressibility_fraction = 0. !> If true, each interface is given a maximum depth based on a rescaling of !! the indexing of coordinateResolution. logical :: set_maximum_depths = .false. - !> A scaling factor (> 1) of the rate at which the coordinateResolution list - !! is traversed to set the minimum depth of interfaces. - real :: max_depth_index_scale = 2.0 - !> If true, integrate for interface positions from the top downward. !! If false, integrate from the bottom upward, as does the rest of the model. logical :: integrate_downward_for_e = .true. - !> If true, use the order of arithmetic and expressions that recover the remapping answers from 2018. - !! If false, use more robust forms of the same remapping expressions. - logical :: remap_answers_2018 = .true. + !> The vintage of the order of arithmetic and expressions to use for remapping. + !! Values below 20190101 recover the remapping answers from 2018. + !! Higher values use more robust forms of the same remapping expressions. + integer :: remap_answer_date = 99991231 + + logical :: use_hybgen_unmix = .false. !< If true, use the hybgen unmixing code before remapping type(zlike_CS), pointer :: zlike_CS => null() !< Control structure for z-like coordinate generator type(sigma_CS), pointer :: sigma_CS => null() !< Control structure for sigma coordinate generator type(rho_CS), pointer :: rho_CS => null() !< Control structure for rho coordinate generator type(hycom_CS), pointer :: hycom_CS => null() !< Control structure for hybrid coordinate generator - type(slight_CS), pointer :: slight_CS => null() !< Control structure for Slight-coordinate generator type(adapt_CS), pointer :: adapt_CS => null() !< Control structure for adaptive coordinate generator + type(hybgen_regrid_CS), pointer :: hybgen_CS => NULL() !< Control structure for hybgen regridding end type ! The following routines are visible to the outside world public initialize_regridding, end_regridding, regridding_main -public inflate_vanished_layers_old, check_remapping_grid, check_grid_column -public set_regrid_params, get_regrid_size +public regridding_preadjust_reqs, convective_adjustment +public inflate_vanished_layers_old, check_grid_column +public set_regrid_params, get_regrid_size, write_regrid_file public uniformResolution, setCoordinateResolution -public build_rho_column public set_target_densities_from_GV, set_target_densities public set_regrid_max_depths, set_regrid_max_thickness public getCoordinateResolution, getCoordinateInterfaces public getCoordinateUnits, getCoordinateShortName, getStaticThickness public DEFAULT_COORDINATE_MODE +public set_h_neglect, set_dz_neglect public get_zlike_CS, get_sigma_CS, get_rho_CS !> Documentation for coordinate options @@ -147,7 +174,7 @@ module MOM_regridding " SIGMA - terrain following coordinates\n"//& " RHO - continuous isopycnal\n"//& " HYCOM1 - HyCOM-like hybrid coordinate\n"//& - " SLIGHT - stretched coordinates above continuous isopycnal\n"//& + " HYBGEN - Hybrid coordinate from the Hycom hybgen code\n"//& " ADAPTIVE - optimize for smooth neutral density surfaces" !> Documentation for regridding interpolation schemes @@ -156,6 +183,7 @@ module MOM_regridding " P1M_H4 (2nd-order accurate)\n"//& " P1M_IH4 (2nd-order accurate)\n"//& " PLM (2nd-order accurate)\n"//& + " PPM_CW (3rd-order accurate)\n"//& " PPM_H4 (3rd-order accurate)\n"//& " PPM_IH4 (3rd-order accurate)\n"//& " P3M_IH4IH3 (4th-order accurate)\n"//& @@ -167,16 +195,21 @@ module MOM_regridding character(len=*), parameter, public :: regriddingDefaultInterpScheme = "P1M_H2" !> Default mode for boundary extrapolation logical, parameter, public :: regriddingDefaultBoundaryExtrapolation = .false. -!> Default minimum thickness for some coordinate generation modes +!> Default minimum thickness for some coordinate generation modes [m] real, parameter, public :: regriddingDefaultMinThickness = 1.e-3 +!> Maximum length of parameters +integer, parameter :: MAX_PARAM_LENGTH = 120 + #undef __DO_SAFETY_CHECKS__ contains !> Initialization and configures a regridding control structure based on customizable run-time parameters -subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_mode, param_prefix, param_suffix) +subroutine initialize_regridding(CS, G, GV, US, max_depth, param_file, mdl, & + coord_mode, param_prefix, param_suffix) type(regridding_CS), intent(inout) :: CS !< Regridding control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(in) :: max_depth !< The maximum depth of the ocean [Z ~> m]. @@ -189,42 +222,92 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m ! Local variables integer :: ke ! Number of levels + integer :: n_sigma ! Number of shallow dz's, for HYBRID_MAP or HYBRID_3D + integer :: np ! Number of profiles, for HYBRID_MAP + integer :: nceiling ! ceiling of map index, for HYBRID_MAP + integer :: nfloor ! floor of map index, for HYBRID_MAP + real :: nfrac ! fraction of map index, for HYBRID_MAP [nondim] character(len=80) :: string, string2, varName ! Temporary strings - character(len=40) :: coord_units, param_name, coord_res_param ! Temporary strings - character(len=200) :: inputdir, fileName + character(len=40) :: coord_units, coord_res_param ! Temporary strings + character(len=MAX_PARAM_LENGTH) :: param_name + character(len=200) :: inputdir, fileName, longString character(len=320) :: message ! Temporary strings character(len=12) :: expected_units, alt_units ! Temporary strings - logical :: tmpLogical, fix_haloclines, set_max, do_sum, main_parameters + logical :: tmpLogical, do_sum, main_parameters logical :: coord_is_state_dependent, ierr - logical :: default_2018_answers, remap_answers_2018 - real :: filt_len, strat_tol, index_scale, tmpReal, P_Ref + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + integer :: remap_answer_date ! The vintage of the remapping expressions to use. + integer :: regrid_answer_date ! The vintage of the regridding expressions to use. + real :: tmpReal ! A temporary variable used in setting other variables [various] + real :: P_Ref ! The coordinate variable reference pression [R L2 T-2 ~> Pa] real :: maximum_depth ! The maximum depth of the ocean [m] (not in Z). - real :: dz_fixed_sfc, Rho_avg_depth, nlay_sfc_int - real :: adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha + real :: dz_extra ! The thickness of an added layer to append to the woa09_dz profile when + ! maximum_depth is large [m] (not in Z). + real :: nominalDepth ! Depth of ocean bottom in thickness units (positive downward) [H ~> m or kg m-2] + real :: depth_q ! A depth scale factor [nondim] + real :: depth_s ! The end of the shallow Z regime [m] + real :: depth_d ! The start of the deep Z regime [m] + real :: adaptTimeRatio, adaptZoomCoeff ! Temporary variables for input parameters [nondim] + real :: adaptBuoyCoeff, adaptAlpha ! Temporary variables for input parameters [nondim] + real :: adaptZoom ! The thickness of the near-surface zooming region with the adaptive coordinate [H ~> m or kg m-2] real :: adaptDrho0 ! Reference density difference for stratification-dependent diffusion. [R ~> kg m-3] - integer :: nz_fixed_sfc, k, nzf(4) + integer :: i, j, k, nzf(4) real, dimension(:), allocatable :: dz ! Resolution (thickness) in units of coordinate, which may be [m] ! or [Z ~> m] or [H ~> m or kg m-2] or [R ~> kg m-3] or other units. + real, dimension(:,:), allocatable :: dz_2d ! 2D resolution (thickness) in units of coordinate, which may be [m] + ! or [Z ~> m] or [H ~> m or kg m-2] or [R ~> kg m-3] or other units. + real, dimension(:,:,:), allocatable :: dz_3d ! 3D resolution (thickness) in units of coordinate, which may be [m] + ! or [Z ~> m] or [H ~> m or kg m-2] or [R ~> kg m-3] or other units. + real, dimension(:), allocatable :: dz_shallow ! Shallow resolution (thickness), for HYBRID_MAP or HYBRID_3D [m] + real, dimension(:,:), allocatable :: rho_target_2d ! 2D target density used in HYBRID mode [kg m-3] + real, dimension(:,:,:), allocatable :: rho_target_3d ! 3D target density used in HYBRID mode [kg m-3] + real, dimension(:,:), allocatable :: index_map ! Region array of indexes for HYBRID_MAP [nondim] real, dimension(:), allocatable :: h_max ! Maximum layer thicknesses [H ~> m or kg m-2] real, dimension(:), allocatable :: z_max ! Maximum interface depths [H ~> m or kg m-2] or other ! units depending on the coordinate real, dimension(:), allocatable :: dz_max ! Thicknesses used to find maximum interface depths ! [H ~> m or kg m-2] or other units real, dimension(:), allocatable :: rho_target ! Target density used in HYBRID mode [kg m-3] - ! Thicknesses [m] that give level centers corresponding to table 2 of WOA09 - real, dimension(40) :: woa09_dz = (/ 5., 10., 10., 15., 22.5, 25., 25., 25., & - 37.5, 50., 50., 75., 100., 100., 100., 100., & - 100., 100., 100., 100., 100., 100., 100., 175., & - 250., 375., 500., 500., 500., 500., 500., 500., & - 500., 500., 500., 500., 500., 500., 500., 500. /) + ! Thicknesses [m] that give level centers approximately corresponding to table 2 of WOA09 + ! These are approximate because the WOA09 depths are not smoothly spaced. Levels + ! 1, 4, 5, 9, 12, 24, and 36 are 2.5, 2.5, 1.25 12.5, 37.5 and 62.5 m deeper than WOA09 + ! but all others are identical. + real, dimension(40) :: woa09_dz_approx = (/ 5., 10., 10., 15., 22.5, 25., 25., 25., & + 37.5, 50., 50., 75., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100., 100., 175., & + 250., 375., 500., 500., 500., 500., 500., 500., & + 500., 500., 500., 500., 500., 500., 500., 500. /) + ! These are the actual spacings [m] between WOA09 depths which, if used for layer thickness, places + ! the interfaces at the WOA09 depths. + real, dimension(39) :: woa09_dzi = (/ 10., 10., 10., 20., 25., 25., 25., 25., & + 50., 50., 50., 100., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100., 100., 250., & + 250., 500., 500., 500., 500., 500., 500., 500., & + 500., 500., 500., 500., 500., 500., 500. /) + ! These are the spacings [m] between WOA23 depths from table 3 of + ! https://www.ncei.noaa.gov/data/oceans/woa/WOA13/DOC/woa13documentation.pdf + real, dimension(136) :: woa23_dzi = (/ 5., 5., 5., 5., 5., 5., 5., 5., 5., 5., & + 5., 5., 5., 5., 5., 5., 5., 5., 5., 5., & + 25., 25., 25., 25., 25., 25., 25., 25., 25., 25., & + 25., 25., 25., 25., 25., 25., 50., 50., 50., 50., & + 50., 50., 50., 50., 50., 50., 50., 50., 50., 50., & + 50., 50., 50., 50., 50., 50., 50., 50., 50., 50., & + 50., 50., 50., 50., 50., 50., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100., 100., 100., 100., 100., & + 100., 100., 100., 100., 100., 100. /) call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) main_parameters=.false. if (len_trim(param_prefix)==0) main_parameters=.true. - if (main_parameters .and. len_trim(param_suffix)>0) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & - 'Suffix provided without prefix for parameter names!') + if (main_parameters .and. len_trim(param_suffix)>0) call MOM_error(FATAL,trim(mdl)//& + ' initialize_regridding: Suffix provided without prefix for parameter names!') CS%nk = 0 CS%regridding_scheme = coordinateMode(coord_mode) @@ -244,26 +327,37 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m param_name = "INTERPOLATION_SCHEME" string2 = regriddingDefaultInterpScheme else - param_name = trim(param_prefix)//"_INTERP_SCHEME_"//trim(param_suffix) + param_name = create_coord_param(param_prefix, "INTERP_SCHEME", param_suffix) string2 = 'PPM_H4' ! Default for diagnostics endif - call get_param(param_file, mdl, "INTERPOLATION_SCHEME", string, & + call get_param(param_file, mdl, param_name, string, & "This sets the interpolation scheme to use to "//& "determine the new grid. These parameters are "//& "only relevant when REGRIDDING_COORDINATE_MODE is "//& "set to a function of state. Otherwise, it is not "//& - "used. It can be one of the following schemes: "//& + "used. It can be one of the following schemes: \n"//& trim(regriddingInterpSchemeDoc), default=trim(string2)) call set_regrid_params(CS, interp_scheme=string) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) - call set_regrid_params(CS, remap_answers_2018=remap_answers_2018) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & + "The vintage of the expressions and order of arithmetic to use for remapping. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) + call set_regrid_params(CS, remap_answer_date=remap_answer_date) + call get_param(param_file, mdl, "REGRIDDING_ANSWER_DATE", regrid_answer_date, & + "The vintage of the expressions and order of arithmetic to use for regridding. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) regrid_answer_date = max(regrid_answer_date, 20230701) + call set_regrid_params(CS, regrid_answer_date=regrid_answer_date) endif if (main_parameters .and. coord_is_state_dependent) then @@ -284,10 +378,10 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m coord_res_param = "ALE_RESOLUTION" string2 = 'UNIFORM' else - param_name = trim(param_prefix)//"_DEF_"//trim(param_suffix) - coord_res_param = trim(param_prefix)//"_RES_"//trim(param_suffix) + param_name = create_coord_param(param_prefix, "DEF", param_suffix) + coord_res_param = create_coord_param(param_prefix, "RES", param_suffix) string2 = 'UNIFORM' - if (maximum_depth>3000.) string2='WOA09' ! For convenience + if ((maximum_depth>3000.) .and. (maximum_depth<9250.)) string2='WOA09' ! For convenience endif call get_param(param_file, mdl, param_name, string, & "Determines how to specify the coordinate "//& @@ -299,11 +393,28 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m " by a comma or space, e.g. FILE:lev.nc,dz\n"//& " or FILE:lev.nc,interfaces=zw\n"//& " WOA09[:N] - the WOA09 vertical grid (approximately)\n"//& + " WOA09INT[:N] - layers spanned by the WOA09 depths\n"//& + " WOA23INT[:N] - layers spanned by the WOA23 depths\n"//& " FNC1:string - FNC1:dz_min,H_total,power,precision\n"//& " HYBRID:string - read from a file. The string specifies\n"//& " the filename and two variable names, separated\n"//& - " by a comma or space, for sigma-2 and dz. e.g.\n"//& - " HYBRID:vgrid.nc,sigma2,dz",& + " by a comma or space, for sigma-2 and dz.\n"//& + " e.g. HYBRID:vgrid.nc,sigma2,dz\n"//& + " HYBRID_3D:string - read from a file. The string specifies\n"//& + " the filename and two 3D variable names, separated\n"//& + " by a comma or space, for sigma-2 and dz. The\n"//& + " latter can be FNC1:string which is used everywhere.\n"//& + " e.g. HYBRID_3D:vgrid.nc,sigma2,dz\n"//& + " HYBRID_MAP:string - read from a file. The string specifies\n"//& + " the filename and three variable names, separated\n"//& + " by a comma or space, for map, sigma-2 and dz.\n"//& + " Map is a spatial index array with, maxval(map)=N,\n"//& + " and the others are 2D arrays containing N profiles.\n"//& + " Map typically contains integer values, but it can\n"//& + " contain real values, I+w, which imply using\n"//& + " the weighted sum of profiles I and I+1.\n"//& + " Dz can be FNC1:string which is used everywhere.\n"//& + " e.g. HYBRID_MAP:vgrid.nc,map,sigma2,dz",& default=trim(string2)) message = "The distribution of vertical resolution for the target\n"//& "grid used for Eulerian-like coordinates. For example,\n"//& @@ -324,14 +435,22 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m endif allocate(dz(ke)) dz(:) = uniformResolution(ke, coord_mode, tmpReal, & - US%R_to_kg_m3*(GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(min(2,ke)))), & - US%R_to_kg_m3*(GV%Rlay(ke) + 0.5*(GV%Rlay(ke)-GV%Rlay(max(ke-1,1)))) ) + US%R_to_kg_m3*(GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(min(2,ke)))), & + US%R_to_kg_m3*(GV%Rlay(ke) + 0.5*(GV%Rlay(ke)-GV%Rlay(max(ke-1,1)))) ) if (main_parameters) call log_param(param_file, mdl, "!"//coord_res_param, dz, & trim(message), units=trim(coord_units)) elseif (trim(string)=='PARAM') then ! Read coordinate resolution (main model = ALE_RESOLUTION) - ke = GV%ke ! Use model nk by default - allocate(dz(ke)) + allocate(dz(1001)) + dz(:) = -1. ! Setting to <0 allows detection of unset elements + call get_param(param_file, mdl, coord_res_param, dz, "Scan", units="", do_not_log=.true.) + if (dz(1001)>=0.) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & + "PARAM specification is limited to 1000 values. Hack the code to use more!") + do ke=1,1000 ! Find number of defined levels + if (dz(ke+1)<0.) exit + enddo + deallocate(dz) + allocate(dz(ke)) ! Allocate with the correct number of levels, and re-read thicknesses call get_param(param_file, mdl, coord_res_param, dz, & trim(message), units=trim(coord_units), fail_if_missing=.true.) elseif (index(trim(string),'FILE:')==1) then @@ -349,9 +468,9 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m varName = trim( extractWord(trim(string(6:)), 2) ) if (len_trim(varName)==0) then - if (field_exists(fileName,'dz')) then; varName = 'dz' - elseif (field_exists(fileName,'dsigma')) then; varName = 'dsigma' - elseif (field_exists(fileName,'ztest')) then; varName = 'ztest' + if (field_exists(fileName,'dz')) then ; varName = 'dz' + elseif (field_exists(fileName,'dsigma')) then ; varName = 'dsigma' + elseif (field_exists(fileName,'ztest')) then ; varName = 'ztest' else ; call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & "Coordinate variable not specified and none could be guessed.") endif @@ -370,11 +489,13 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m varName=trim(varName(12:)) call verify_variable_units(filename, varName, expected_units, message, ierr, alt_units) if (ierr) call MOM_error(FATAL, trim(mdl)//", initialize_regridding: "//& - "Unsupported format in grid definition '"//trim(filename)//"'. Error message "//trim(message)) + "Unsupported format in grid definition '"//trim(filename)//& + "'. Error message "//trim(message)) call field_size(trim(fileName), trim(varName), nzf) ke = nzf(1)-1 - if (ke < 1) call MOM_error(FATAL, trim(mdl)//" initialize_regridding via Var "//trim(varName)//& - "in FILE "//trim(filename)//" requires at least 2 target interface values.") + if (ke < 1) call MOM_error(FATAL, trim(mdl)//" initialize_regridding via Var "//& + trim(varName)//"in FILE "//trim(filename)//& + " requires at least 2 target interface values.") if (CS%regridding_scheme == REGRIDDING_RHO) then allocate(rho_target(ke+1)) call MOM_read_data(trim(fileName), trim(varName), rho_target) @@ -399,7 +520,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m if (main_parameters) call log_param(param_file, mdl, "!"//coord_res_param, dz, & trim(message), units=coordinateUnits(coord_mode)) elseif (index(trim(string),'FNC1:')==1) then - ke = GV%ke; allocate(dz(ke)) + ke = GV%ke ; allocate(dz(ke)) call dz_function1( trim(string(6:)), dz ) if (main_parameters) call log_param(param_file, mdl, "!"//coord_res_param, dz, & trim(message), units=coordinateUnits(coord_mode)) @@ -407,88 +528,414 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m ! Function used for set target interface densities ke = rho_function1( trim(string(7:)), rho_target ) elseif (index(trim(string),'HYBRID:')==1) then - ke = GV%ke; allocate(dz(ke)) - ! The following assumes the FILE: syntax of above but without "FILE:" in the string + ke = GV%ke + allocate(dz(ke)) allocate(rho_target(ke+1)) + ! The following assumes the FILE: syntax of above but without "FILE:" in the string + varName = trim( extractWord(trim(string(8:)), 3) ) + if (varname == " ") call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID "// & + "Too few arguments in ("//trim(string)//")") fileName = trim( extractWord(trim(string(8:)), 1) ) if (fileName(1:1)/='.' .and. filename(1:1)/='/') fileName = trim(inputdir) // trim( fileName ) - if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: HYBRID "// & - "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")") + if (.not. file_exists(fileName)) call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID "// & + "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")") varName = trim( extractWord(trim(string(8:)), 2) ) - if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: HYBRID "// & - "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") + if (.not. field_exists(fileName,varName)) call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID "// & + "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") call MOM_read_data(trim(fileName), trim(varName), rho_target) varName = trim( extractWord(trim(string(8:)), 3) ) if (varName(1:5) == 'FNC1:') then ! Use FNC1 to calculate dz call dz_function1( trim(string((index(trim(string),'FNC1:')+5):)), dz ) else ! Read dz from file - if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: HYBRID "// & - "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") + if (.not. field_exists(fileName,varName)) call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID "// & + "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") call MOM_read_data(trim(fileName), trim(varName), dz) endif if (main_parameters) then call log_param(param_file, mdl, "!"//coord_res_param, dz, & trim(message), units=coordinateUnits(coord_mode)) call log_param(param_file, mdl, "!TARGET_DENSITIES", rho_target, & - 'HYBRID target densities for interfaces', units=coordinateUnits(coord_mode)) + 'HYBRID target densities for interfaces', units="kg m-3") + endif + elseif (index(trim(string),'HYBRID_3D:')==1) then + ke = GV%ke + allocate(dz_3d(SZI_(G),SZJ_(G),ke), source=0.0) + allocate(rho_target_3d(SZI_(G),SZJ_(G),ke+1), source=0.0) + ! The following assumes the FILE: syntax of above but without "FILE:" in the string + varName = trim( extractWord(trim(string(11:)), 3) ) + if (varname == " ") call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID_3D "// & + "Too few arguments in ("//trim(string)//")") + fileName = trim( extractWord(trim(string(11:)), 1) ) + if (fileName(1:1)/='.' .and. filename(1:1)/='/') fileName = trim(inputdir) // trim( fileName ) + if (.not. file_exists(fileName)) call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID_3D "// & + "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")") + varName = trim( extractWord(trim(string(11:)), 2) ) + if (.not. field_exists(fileName,varName)) call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID_3D "// & + "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") + call MOM_read_data(trim(fileName), trim(varName), rho_target_3d, G%Domain) + call pass_var(rho_target_3d, G%Domain, halo=1) + varName = trim( extractWord(trim(string(11:)), 3) ) + if (varName(1:5) == 'FNC1:') then ! Use FNC1 to calculate dz_3d + allocate(dz(ke)) + call dz_function1( trim(string((index(trim(string),'FNC1:')+5):)), dz ) + ! Adjust target grid to be consistent with maximum_depth + tmpReal = sum( dz(:) ) + if (tmpReal < maximum_depth) then + dz(ke) = dz(ke) + ( maximum_depth - tmpReal ) + endif + do i=G%isc-1,G%iec+1 ; do j=G%jsc-1,G%jec+1 + if (G%mask2dT(i,j)>0.) then + do k=1,ke + dz_3d(i,j,k) = dz(k) + enddo + endif !mask2dT + enddo ; enddo + if (main_parameters) then + call log_param(param_file, mdl, "!"//coord_res_param, dz, & + trim(message), units=coordinateUnits(coord_mode)) + endif + else ! Read dz from file + if (.not. field_exists(fileName,varName)) call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID_3D "// & + "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") + call MOM_read_data(trim(fileName), trim(varName), dz_3d, G%Domain) + call pass_var(dz_3d, G%Domain, halo=1) + ! set nominal 1-d dz to UNIFORM + allocate(dz(ke)) + dz(:) = uniformResolution(ke, coord_mode, maximum_depth, & + US%R_to_kg_m3*(GV%Rlay(1) + 0.5*(GV%Rlay(1)-GV%Rlay(min(2,ke)))), & + US%R_to_kg_m3*(GV%Rlay(ke) + 0.5*(GV%Rlay(ke)-GV%Rlay(max(ke-1,1)))) ) + endif !dz + elseif (index(trim(string),'HYBRID_MAP:')==1) then + ke = GV%ke + allocate(dz_3d(SZI_(G),SZJ_(G),ke), source=0.0) + allocate(rho_target_3d(SZI_(G),SZJ_(G),ke+1), source=0.0) + allocate(index_map(SZI_(G),SZJ_(G)), source=1.0) + ! The following assumes the FILE: syntax of above but without "FILE:" in the string + varName = trim( extractWord(trim(string(12:)), 4) ) + if (varname == " ") call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID_3D "// & + "Too few arguments in ("//trim(string)//")") + fileName = trim( extractWord(trim(string(12:)), 1) ) + if (fileName(1:1)/='.' .and. filename(1:1)/='/') fileName = trim(inputdir) // trim( fileName ) + if (.not. file_exists(fileName)) call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID_MAP "// & + "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")") + varName = trim( extractWord(trim(string(12:)), 2) ) + if (.not. field_exists(fileName,varName)) call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID_MAP "// & + "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") + call MOM_read_data(trim(fileName), trim(varName), index_map, G%Domain) + call pass_var(index_map, G%Domain, halo=1) + !find maximum index + np = 1 + do j=G%jsc, G%jec ; do i=G%isc, G%iec + np = max(np,ceiling(index_map(i,j))) + enddo ; enddo + call max_across_PEs(np) + write(string2,"(i3)") np + call MOM_error(NOTE, & + trim(mdl)//", initialize_regridding: HYBRID_MAP NP="//trim(string2)) + if (np<1) call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID_MAP to small NP from "//trim(varName)) + allocate(dz_2d(ke,np)) + allocate(rho_target_2d(ke+1,np)) + varName = trim( extractWord(trim(string(12:)), 3) ) + if (.not. field_exists(fileName,varName)) call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID_MAP "// & + "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") + ! MOM_read_data can't handle this array + call read_variable(trim(fileName), trim(varName), rho_target_2d) + if (main_parameters) then + call log_param(param_file, mdl, "!TARGET_DENSITIES", rho_target_2d(:,1), & + 'HYBRID target densities for interfaces', units="kg m-3") + endif + do i=G%isc-1,G%iec+1 ; do j=G%jsc-1,G%jec+1 + if (G%mask2dT(i,j)>0.) then + nfloor = floor(index_map(i,j)) + nceiling = ceiling(index_map(i,j)) + if (nfloor<1 .or. nceiling>np) then + write(0,'(a,2i5,a,g20.6)') 'HYBRID_MAP: i,j=',i,j,'index_map(i,j)=', index_map(i,j) + call MOM_error(FATAL, trim(mdl)//", initialize_regridding: HYBRID_MAP "// & + "index_map out of range") + endif + if (nfloor == nceiling) then + do k=1,ke+1 + rho_target_3d(i,j,k) = rho_target_2d(k,nfloor) + enddo + else + nfrac = index_map(i,j) - nfloor !between 0.0 and 1.0 + do k=1,ke+1 + rho_target_3d(i,j,k) = (1.0-nfrac)*rho_target_2d(k,nfloor) + & + nfrac *rho_target_2d(k,nceiling) + enddo + endif !integer:else + endif !mask2dT + enddo ; enddo + varName = trim( extractWord(trim(string(12:)), 4) ) + if (varName(1:5) == 'FNC1:') then ! Use FNC1 to calculate dz_3d + allocate(dz(ke)) + call dz_function1( trim(string((index(trim(string),'FNC1:')+5):)), dz ) + ! Adjust target grid to be consistent with maximum_depth + tmpReal = sum( dz(:) ) + if (tmpReal < maximum_depth) then + dz(ke) = dz(ke) + ( maximum_depth - tmpReal ) + endif + do i=G%isc-1,G%iec+1 ; do j=G%jsc-1,G%jec+1 + if (G%mask2dT(i,j)>0.) then + do k=1,ke + dz_3d(i,j,k) = dz(k) + enddo + endif !mask2dT + enddo ; enddo + if (main_parameters) then + call log_param(param_file, mdl, "!"//coord_res_param, dz, & + trim(message), units=coordinateUnits(coord_mode)) + endif + else ! Read dz from file + if (.not. field_exists(fileName,varName)) call MOM_error(FATAL, & + trim(mdl)//", initialize_regridding: HYBRID_MAP "// & + "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") + ! MOM_read_data can't handle this array + call read_variable(trim(fileName), trim(varName), dz_2d) + if (main_parameters) then + call log_param(param_file, mdl, "!"//coord_res_param, dz_2d(:,1), & + trim(message), units=coordinateUnits(coord_mode)) + endif + do i=1,np + tmpReal = sum( dz_2d(:,i) ) + if (tmpReal < maximum_depth) then + dz_2d(ke,i) = dz_2d(ke,i) + ( maximum_depth - tmpReal ) + endif + enddo + allocate(dz(ke)) + dz(:) = dz_2d(:,1) + if (main_parameters) then + call log_param(param_file, mdl, "!"//coord_res_param, dz, & + trim(message), units=coordinateUnits(coord_mode)) + endif + do i=G%isc-1,G%iec+1 ; do j=G%jsc-1,G%jec+1 + if (G%mask2dT(i,j)>0.) then + nfloor = floor(index_map(i,j)) + nceiling = ceiling(index_map(i,j)) + if (nfloor == nceiling) then + do k=1,ke + dz_3d(i,j,k) = dz_2d(k,nfloor) + enddo + else + nfrac = index_map(i,j) - nfloor !between 0.0 and 1.0 + do k=1,ke + dz_3d(i,j,k) = (1.0-nfrac)*dz_2d(k,nfloor) + & + nfrac *dz_2d(k,nceiling) + enddo + endif !integer:else + endif !mask2dT + enddo ; enddo + endif !dz + deallocate(index_map) + deallocate(rho_target_2d) + deallocate(dz_2d) + elseif (index(trim(string),'WOA09INT')==1) then + if (len_trim(string)==8) then ! string=='WOA09INT' + tmpReal = 0. ; ke = 0 ; dz_extra = 0. + do while (tmpReal size(woa09_dzi)) then + dz_extra = maximum_depth - tmpReal + exit + endif + tmpReal = tmpReal + woa09_dzi(ke) + enddo + elseif (index(trim(string),'WOA09INT:')==1) then ! string starts with 'WOA09INT:' + if (len_trim(string)==9) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & + 'Expected string of form "WOA09INT:N" but got "'//trim(string)//'".') + ke = extract_integer(string(10:len_trim(string)),'',1) + if (ke>39 .or. ke<1) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & + 'For "WOA05INT:N" N must 0 size(woa09_dzi)) dz(ke) = dz_extra + elseif (index(trim(string),'WOA23INT')==1) then + if (len_trim(string)==8) then ! string=='WOA23INT' + tmpReal = 0. ; ke = 0 ; dz_extra = 0. + do while (tmpReal size(woa23_dzi)) then + dz_extra = maximum_depth - tmpReal + exit + endif + tmpReal = tmpReal + woa23_dzi(ke) + enddo + elseif (index(trim(string),'WOA23INT:')==1) then ! string starts with 'WOA23INT:' + if (len_trim(string)==9) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & + 'Expected string of form "WOA23INT:N" but got "'//trim(string)//'".') + ke = extract_integer(string(10:len_trim(string)),'',1) + if (ke>39 .or. ke<1) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & + 'For "WOA05INT:N" N must 0 size(woa23_dzi)) dz(ke) = dz_extra elseif (index(trim(string),'WOA09')==1) then - if (len_trim(string)==5) then - tmpReal = 0. ; ke = 0 + if (len_trim(string)==5) then ! string=='WOA09' + tmpReal = 0. ; ke = 0 ; dz_extra = 0. do while (tmpReal size(woa09_dz_approx)) then + dz_extra = maximum_depth - tmpReal + exit + endif + tmpReal = tmpReal + woa09_dz_approx(ke) enddo - elseif (index(trim(string),'WOA09:')==1) then + elseif (index(trim(string),'WOA09:')==1) then ! string starts with 'WOA09:' if (len_trim(string)==6) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & 'Expected string of form "WOA09:N" but got "'//trim(string)//'".') ke = extract_integer(string(7:len_trim(string)),'',1) + if (ke>40 .or. ke<1) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & + 'For "WOA05:N" N must 040 .or. ke<1) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & - 'For "WOA05:N" N must 0 size(woa09_dz_approx)) dz(ke) = dz_extra else call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & - "Unrecognized coordinate configuration"//trim(string)) + "Unrecognized coordinate configuration"//trim(string)) endif if (main_parameters) then ! This is a work around to apparently needed to work with the from_Z initialization... ??? if (coordinateMode(coord_mode) == REGRIDDING_ZSTAR .or. & coordinateMode(coord_mode) == REGRIDDING_HYCOM1 .or. & - coordinateMode(coord_mode) == REGRIDDING_SLIGHT .or. & + coordinateMode(coord_mode) == REGRIDDING_HYBGEN .or. & coordinateMode(coord_mode) == REGRIDDING_ADAPTIVE) then - ! Adjust target grid to be consistent with maximum_depth - tmpReal = sum( dz(:) ) - if (tmpReal < maximum_depth) then - dz(ke) = dz(ke) + ( maximum_depth - tmpReal ) - elseif (tmpReal > maximum_depth) then - if ( dz(ke) + ( maximum_depth - tmpReal ) > 0. ) then + if (allocated(dz)) then + ! Adjust target grid to be consistent with maximum_depth + tmpReal = sum( dz(:) ) + if (tmpReal < maximum_depth) then dz(ke) = dz(ke) + ( maximum_depth - tmpReal ) - else - call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & - "MAXIMUM_DEPTH was too shallow to adjust bottom layer of DZ!"//trim(string)) + elseif (tmpReal > maximum_depth) then + if ( dz(ke) + ( maximum_depth - tmpReal ) > 0. ) then + dz(ke) = dz(ke) + ( maximum_depth - tmpReal ) + else + call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & + "MAXIMUM_DEPTH was too shallow to adjust bottom layer of DZ!"//trim(string)) + endif endif - endif + endif !allocated(dz) endif endif + if (coordinateMode(coord_mode) == REGRIDDING_HYCOM1) then + allocate(dz_shallow(ke)) + call get_param(param_file, mdl, "SHALLOW_"//trim(coord_res_param), dz_shallow, & + "HYBGEN-style Z-sigma-Z near surface fixed coordinate. "//& + "The default of all zeros turns this option off. "//& + "Let N_SIGMA be the number of consecutive non-zero entries, typically < NK. "//& + "Use SHALLOW_"//trim(coord_res_param)//" when rest depth is shallower than "//& + "SUM(SHALLOW_"//trim(coord_res_param)//"(1:N_SIGMA)). "//& + "Use "//trim(coord_res_param)//" when rest depth is deeper than "//& + "SUM("//trim(coord_res_param)//"(1:N_SIGMA)). "//& + "Otherwise use a linear sum of the two weighted by rest depth.",& + units="m", default=0.0) + n_sigma = ke + depth_s = 0.0 + do k= 1,ke + depth_s = depth_s + dz_shallow(k) + if (dz_shallow(k) == 0.0) then + n_sigma = k-1 + exit + endif + enddo + if (n_sigma > 0) then + if (main_parameters) call log_param(param_file, mdl, "!N_SIGMA", n_sigma, & + "Number of consecutive non-zero entries in SHALLOW_"//& + trim(coord_res_param)//".") + if (.not.allocated(dz_3d)) then + allocate(dz_3d(SZI_(G),SZJ_(G),ke), source=0.0) + allocate(rho_target_3d(SZI_(G),SZJ_(G),ke+1), source=0.0) + do i=G%isc-1,G%iec+1 ; do j=G%jsc-1,G%jec+1 + if (G%mask2dT(i,j)>0.) then + do k=1,ke + dz_3d(i,j,k) = dz(k) + enddo + do k=1,ke+1 + rho_target_3d(i,j,k) = rho_target(k) + enddo + endif !mask2dT + enddo ; enddo + endif + do i=G%isc-1,G%iec+1 ; do j=G%jsc-1,G%jec+1 + if (G%mask2dT(i,j)>0.) then + nominalDepth = max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) * US%Z_to_m + if (nominalDepth <= depth_s) then + do k= 1,n_sigma + dz_3d(i,j,k) = dz_shallow(k) + enddo + do k= n_sigma+1,ke + dz_3d(i,j,k) = dz_shallow(n_sigma) + enddo + else ! >depth_s + depth_d = 0.0 + do k= 1,n_sigma + depth_d = depth_d + dz_3d(i,j,k) + enddo + ! do nothing if nominalDepth >= depth_d + if (nominalDepth < depth_d) then + depth_q = (nominalDepth - depth_s) / (depth_d - depth_s) + do k= 1,n_sigma + dz_3d(i,j,k) = (1.0-depth_q)*dz_shallow(k) + depth_q*dz_3d(i,j,k) + enddo + do k= n_sigma+1,ke + dz_3d(i,j,k) = (1.0-depth_q)*dz_shallow(n_sigma) + depth_q*dz_3d(i,j,k) + enddo + endif !depth_s + endif !nominalDepth + endif !mask2dT + enddo ; enddo + endif !n_sigma + deallocate(dz_shallow) + endif !REGRIDDING_HYCOM1 + CS%nk=ke ! Target resolution (for fixed coordinates) - allocate( CS%coordinateResolution(CS%nk), source=-1.E30 ) - if (state_dependent(CS%regridding_scheme)) then - ! Target values - allocate( CS%target_density(CS%nk+1), source=-1.E30*US%kg_m3_to_R ) + if (allocated(dz_3d)) then + allocate( CS%coordinateResolution(CS%nk), source=-1.E30 ) + allocate( CS%coordinateResolution_3d(SZI_(G),SZJ_(G),CS%nk), source=-1.E30 ) + allocate( CS%target_density_3d(SZI_(G),SZJ_(G),CS%nk+1), source=-1.E30*US%kg_m3_to_R ) + else + allocate( CS%coordinateResolution(CS%nk), source=-1.E30 ) + if (state_dependent(CS%regridding_scheme)) then + ! Target values + allocate( CS%target_density(CS%nk+1), source=-1.E30*US%kg_m3_to_R ) + endif endif - if (allocated(dz)) then + if (allocated(dz_3d)) then + ! set both 1d and 3d fields + call setCoordinateResolution(dz, CS, scale=US%m_to_Z) + call setCoordinateResolution_3d(dz_3d, CS, scale=US%m_to_Z) + CS%coord_scale = US%Z_to_m + deallocate(dz_3d) + elseif (allocated(dz)) then if (coordinateMode(coord_mode) == REGRIDDING_SIGMA) then call setCoordinateResolution(dz, CS, scale=1.0) elseif (coordinateMode(coord_mode) == REGRIDDING_RHO) then call setCoordinateResolution(dz, CS, scale=US%kg_m3_to_R) - CS%coord_scale = US%R_to_kg_m3 elseif (coordinateMode(coord_mode) == REGRIDDING_ADAPTIVE) then call setCoordinateResolution(dz, CS, scale=GV%m_to_H) CS%coord_scale = GV%H_to_m @@ -498,30 +945,50 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m endif endif - if (allocated(rho_target)) then + ! set coord_scale for RHO regridding independent of allocation status of dz + if (coordinateMode(coord_mode) == REGRIDDING_RHO) then + CS%coord_scale = US%R_to_kg_m3 + endif + + ! ensure CS%ref_pressure is rescaled properly + CS%ref_pressure = US%Pa_to_RL2_T2 * CS%ref_pressure + + if (allocated(rho_target_3d)) then + call set_target_densities_3d(CS, G, US%kg_m3_to_R, rho_target_3d) + deallocate(rho_target_3d) + elseif (allocated(rho_target)) then call set_target_densities(CS, US%kg_m3_to_R*rho_target) deallocate(rho_target) - - ! \todo This line looks like it would overwrite the target densities set just above? elseif (coordinateMode(coord_mode) == REGRIDDING_RHO) then call set_target_densities_from_GV(GV, US, CS) call log_param(param_file, mdl, "!TARGET_DENSITIES", US%R_to_kg_m3*CS%target_density(:), & - 'RHO target densities for interfaces', units=coordinateUnits(coord_mode)) + 'RHO target densities for interfaces', "kg m-3") endif ! initialise coordinate-specific control structure - call initCoord(CS, GV, US, coord_mode) + call initCoord(CS, G, GV, US, coord_mode, param_file) - if (main_parameters .and. coord_is_state_dependent) then - call get_param(param_file, mdl, "P_REF", P_Ref, & - "The pressure that is used for calculating the coordinate "//& - "density. (1 Pa = 1e4 dbar, so 2e7 is commonly used.) "//& - "This is only used if USE_EOS and ENABLE_THERMODYNAMICS are true.", & - units="Pa", default=2.0e7, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) - call get_param(param_file, mdl, "REGRID_COMPRESSIBILITY_FRACTION", tmpReal, & - "When interpolating potential density profiles we can add "//& - "some artificial compressibility solely to make homogeneous "//& - "regions appear stratified.", units="nondim", default=0.) + if (coord_is_state_dependent) then + if (main_parameters) then + call get_param(param_file, mdl, create_coord_param(param_prefix, "P_REF", param_suffix), & + P_Ref, & + "The pressure that is used for calculating the coordinate "//& + "density. (1 Pa = 1e4 dbar, so 2e7 is commonly used.) "//& + "This is only used if USE_EOS and ENABLE_THERMODYNAMICS are true.", & + units="Pa", default=2.0e7, scale=US%Pa_to_RL2_T2) + else + call get_param(param_file, mdl, create_coord_param(param_prefix, "P_REF", param_suffix), & + P_Ref, & + "The pressure that is used for calculating the diagnostic coordinate "//& + "density. (1 Pa = 1e4 dbar, so 2e7 is commonly used.) "//& + "This is only used for the RHO coordinate.", & + units="Pa", default=2.0e7, scale=US%Pa_to_RL2_T2) + endif + call get_param(param_file, mdl, create_coord_param(param_prefix, & + "REGRID_COMPRESSIBILITY_FRACTION", param_suffix), tmpReal, & + "When interpolating potential density profiles we can add "//& + "some artificial compressibility solely to make homogeneous "//& + "regions appear stratified.", units="nondim", default=0.) call set_regrid_params(CS, compress_fraction=tmpReal, ref_pressure=P_Ref) endif @@ -531,51 +998,28 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m "thickness allowed.", units="m", scale=GV%m_to_H, & default=regriddingDefaultMinThickness ) call set_regrid_params(CS, min_thickness=tmpReal) + call get_param(param_file, mdl, "USE_ADJUST_INTERFACE_MOTION", tmpLogical, & + "When regridding, after the primary grid generation, call a function that ensures "//& + "positive layer thicknesses. Historically, this was required.", default=.true.) + call set_regrid_params(CS, use_adjust_interface_motion=tmpLogical) else call set_regrid_params(CS, min_thickness=0.) + call set_regrid_params(CS, use_adjust_interface_motion=.true.) + call set_regrid_params(CS, use_depth_based_time_filter=.true.) endif - if (coordinateMode(coord_mode) == REGRIDDING_SLIGHT) then - ! Set SLight-specific regridding parameters. - call get_param(param_file, mdl, "SLIGHT_DZ_SURFACE", dz_fixed_sfc, & - "The nominal thickness of fixed thickness near-surface "//& - "layers with the SLight coordinate.", units="m", default=1.0, scale=GV%m_to_H) - call get_param(param_file, mdl, "SLIGHT_NZ_SURFACE_FIXED", nz_fixed_sfc, & - "The number of fixed-depth surface layers with the SLight "//& - "coordinate.", units="nondimensional", default=2) - call get_param(param_file, mdl, "SLIGHT_SURFACE_AVG_DEPTH", Rho_avg_depth, & - "The thickness of the surface region over which to average "//& - "when calculating the density to use to define the interior "//& - "with the SLight coordinate.", units="m", default=1.0, scale=GV%m_to_H) - call get_param(param_file, mdl, "SLIGHT_NLAY_TO_INTERIOR", nlay_sfc_int, & - "The number of layers to offset the surface density when "//& - "defining where the interior ocean starts with SLight.", & - units="nondimensional", default=2.0) - call get_param(param_file, mdl, "SLIGHT_FIX_HALOCLINES", fix_haloclines, & - "If true, identify regions above the reference pressure "//& - "where the reference pressure systematically underestimates "//& - "the stratification and use this in the definition of the "//& - "interior with the SLight coordinate.", default=.false.) - - call set_regrid_params(CS, dz_min_surface=dz_fixed_sfc, & - nz_fixed_surface=nz_fixed_sfc, Rho_ML_avg_depth=Rho_avg_depth, & - nlay_ML_to_interior=nlay_sfc_int, fix_haloclines=fix_haloclines) - if (fix_haloclines) then - ! Set additional parameters related to SLIGHT_FIX_HALOCLINES. - call get_param(param_file, mdl, "HALOCLINE_FILTER_LENGTH", filt_len, & - "A length scale over which to smooth the temperature and "//& - "salinity before identifying erroneously unstable haloclines.", & - units="m", default=2.0, scale=GV%m_to_H) - call get_param(param_file, mdl, "HALOCLINE_STRAT_TOL", strat_tol, & - "A tolerance for the ratio of the stratification of the "//& - "apparent coordinate stratification to the actual value "//& - "that is used to identify erroneously unstable haloclines. "//& - "This ratio is 1 when they are equal, and sensible values "//& - "are between 0 and 0.5.", units="nondimensional", default=0.2) - call set_regrid_params(CS, halocline_filt_len=filt_len, & - halocline_strat_tol=strat_tol) - endif + if (main_parameters .and. coordinateMode(coord_mode) == REGRIDDING_HYCOM1) then + call get_param(param_file, mdl, "HYCOM1_ONLY_IMPROVES", tmpLogical, & + "When regridding, an interface is only moved if this improves "//& + "the fit to the target density.", default=.false.) + call set_hycom_params(CS%hycom_CS, only_improves=tmpLogical) + endif + CS%use_hybgen_unmix = .false. + if (coordinateMode(coord_mode) == REGRIDDING_HYBGEN) then + call get_param(param_file, mdl, "USE_HYBGEN_UNMIX", CS%use_hybgen_unmix, & + "If true, use hybgen unmixing code before regridding.", & + default=.false.) endif if (coordinateMode(coord_mode) == REGRIDDING_ADAPTIVE) then @@ -630,19 +1074,21 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m ! Otherwise assume we should look for the file in INPUTDIR fileName = trim(inputdir) // trim( extractWord(trim(string(6:80)), 1) ) endif - if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & - "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")") + if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mdl)// & + ", initialize_regridding: "// & + "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")") do_sum = .false. varName = trim( extractWord(trim(string(6:)), 2) ) - if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & - "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") + if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)// & + ", initialize_regridding: "// & + "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") if (len_trim(varName)==0) then - if (field_exists(fileName,'z_max')) then; varName = 'z_max' - elseif (field_exists(fileName,'dz')) then; varName = 'dz' ; do_sum = .true. - elseif (field_exists(fileName,'dz_max')) then; varName = 'dz_max' ; do_sum = .true. + if (field_exists(fileName,'z_max')) then ; varName = 'z_max' + elseif (field_exists(fileName,'dz')) then ; varName = 'dz' ; do_sum = .true. + elseif (field_exists(fileName,'dz_max')) then ; varName = 'dz_max' ; do_sum = .true. else ; call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & - "MAXIMUM_INT_DEPTHS variable not specified and none could be guessed.") + "MAXIMUM_INT_DEPTHS variable not specified and none could be guessed.") endif endif if (do_sum) then @@ -656,24 +1102,20 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m call set_regrid_max_depths(CS, z_max, GV%m_to_H) elseif (index(trim(string),'FNC1:')==1) then call dz_function1( trim(string(6:)), dz_max ) - if ((coordinateMode(coord_mode) == REGRIDDING_SLIGHT) .and. & - (dz_fixed_sfc > 0.0)) then - do k=1,nz_fixed_sfc ; dz_max(k) = dz_fixed_sfc ; enddo - endif z_max(1) = 0.0 ; do K=1,ke ; z_max(K+1) = z_max(K) + dz_max(K) ; enddo call log_param(param_file, mdl, "!MAXIMUM_INT_DEPTHS", z_max, & trim(message), units=coordinateUnits(coord_mode)) call set_regrid_max_depths(CS, z_max, GV%m_to_H) else call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & - "Unrecognized MAXIMUM_INT_DEPTH_CONFIG "//trim(string)) + "Unrecognized MAXIMUM_INT_DEPTH_CONFIG "//trim(string)) endif deallocate(z_max) deallocate(dz_max) ! Optionally specify maximum thicknesses for each layer, enforced by moving ! the interface below a layer downward. - call get_param(param_file, mdl, "MAX_LAYER_THICKNESS_CONFIG", string, & + call get_param(param_file, mdl, "MAX_LAYER_THICKNESS_CONFIG", longString, & "Determines how to specify the maximum layer thicknesses.\n"//& "Valid options are:\n"//& " NONE - there are no maximum layer thicknesses\n"//& @@ -685,45 +1127,47 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m default='NONE') message = "The list of maximum thickness for each layer." allocate(h_max(ke)) - if ( trim(string) == "NONE") then + if ( trim(longString) == "NONE") then ! Do nothing. - elseif ( trim(string) == "PARAM") then + elseif ( trim(longString) == "PARAM") then call get_param(param_file, mdl, "MAX_LAYER_THICKNESS", h_max, & trim(message), units="m", fail_if_missing=.true., scale=GV%m_to_H) call set_regrid_max_thickness(CS, h_max) - elseif (index(trim(string),'FILE:')==1) then - if (string(6:6)=='.' .or. string(6:6)=='/') then + elseif (index(trim(longString),'FILE:')==1) then + if (longString(6:6)=='.' .or. longString(6:6)=='/') then ! If we specified "FILE:./xyz" or "FILE:/xyz" then we have a relative or absolute path - fileName = trim( extractWord(trim(string(6:80)), 1) ) + fileName = trim( extractWord(trim(longString(6:200)), 1) ) else ! Otherwise assume we should look for the file in INPUTDIR - fileName = trim(inputdir) // trim( extractWord(trim(string(6:80)), 1) ) + fileName = trim(inputdir) // trim( extractWord(trim(longString(6:200)), 1) ) endif - if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & - "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")") - - varName = trim( extractWord(trim(string(6:)), 2) ) - if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & - "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") + if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mdl)// & + ", initialize_regridding: "// & + "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(longString)//")") + + varName = trim( extractWord(trim(longString(6:)), 2) ) + if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)// & + ", initialize_regridding: "// & + "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(longString)//")") if (len_trim(varName)==0) then - if (field_exists(fileName,'h_max')) then; varName = 'h_max' - elseif (field_exists(fileName,'dz_max')) then; varName = 'dz_max' + if (field_exists(fileName,'h_max')) then ; varName = 'h_max' + elseif (field_exists(fileName,'dz_max')) then ; varName = 'dz_max' else ; call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & - "MAXIMUM_INT_DEPTHS variable not specified and none could be guessed.") + "MAXIMUM_INT_DEPTHS variable not specified and none could be guessed.") endif endif call MOM_read_data(trim(fileName), trim(varName), h_max) call log_param(param_file, mdl, "!MAX_LAYER_THICKNESS", h_max, & trim(message), units=coordinateUnits(coord_mode)) call set_regrid_max_thickness(CS, h_max, GV%m_to_H) - elseif (index(trim(string),'FNC1:')==1) then - call dz_function1( trim(string(6:)), h_max ) + elseif (index(trim(longString),'FNC1:')==1) then + call dz_function1( trim(longString(6:)), h_max ) call log_param(param_file, mdl, "!MAX_LAYER_THICKNESS", h_max, & trim(message), units=coordinateUnits(coord_mode)) call set_regrid_max_thickness(CS, h_max, GV%m_to_H) else call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & - "Unrecognized MAX_LAYER_THICKNESS_CONFIG "//trim(string)) + "Unrecognized MAX_LAYER_THICKNESS_CONFIG "//trim(longString)) endif deallocate(h_max) endif @@ -741,10 +1185,12 @@ subroutine end_regridding(CS) if (associated(CS%sigma_CS)) call end_coord_sigma(CS%sigma_CS) if (associated(CS%rho_CS)) call end_coord_rho(CS%rho_CS) if (associated(CS%hycom_CS)) call end_coord_hycom(CS%hycom_CS) - if (associated(CS%slight_CS)) call end_coord_slight(CS%slight_CS) if (associated(CS%adapt_CS)) call end_coord_adapt(CS%adapt_CS) + if (associated(CS%hybgen_CS)) call end_hybgen_regrid(CS%hybgen_CS) deallocate( CS%coordinateResolution ) + if (allocated(CS%coordinateResolution_3d)) deallocate( CS%coordinateResolution_3d ) + if (allocated(CS%target_density_3d)) deallocate( CS%target_density_3d ) if (allocated(CS%target_density)) deallocate( CS%target_density ) if (allocated(CS%max_interface_depths) ) deallocate( CS%max_interface_depths ) if (allocated(CS%max_layer_thickness) ) deallocate( CS%max_layer_thickness ) @@ -753,7 +1199,8 @@ end subroutine end_regridding !------------------------------------------------------------------------------ !> Dispatching regridding routine for orchestrating regridding & remapping -subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_shelf_h, conv_adjust) +subroutine regridding_main( remapCS, CS, G, GV, US, h, tv, h_new, dzInterface, & + frac_shelf_h, PCM_cell) !------------------------------------------------------------------------------ ! This routine takes care of (1) building a new grid and (2) remapping between ! the old grid and the new grid. The creation of the new grid can be based @@ -776,50 +1223,88 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_ type(regridding_CS), intent(in) :: CS !< Regridding control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G), SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after - !! the last time step - type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamical variables (T, S, ...) - real, dimension(SZI_(G),SZJ_(G), CS%nk), intent(inout) :: h_new !< New 3D grid consistent with target coordinate - real, dimension(SZI_(G),SZJ_(G), CS%nk+1), intent(inout) :: dzInterface !< The change in position of each interface - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in ) :: frac_shelf_h !< Fractional ice shelf coverage - logical, optional, intent(in ) :: conv_adjust !< If true, do convective adjustment + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Current 3D grid obtained after + !! the last time step [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamical variables (T, S, ...) + real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New 3D grid consistent with target + !! coordinate [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in position of each + !! interface [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in ) :: frac_shelf_h !< Fractional ice shelf coverage [nondim] + logical, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(out ) :: PCM_cell !< Use PCM remapping in cells where true + ! Local variables - real :: trickGnuCompiler - logical :: use_ice_shelf - logical :: do_convective_adjustment + real :: nom_depth_H(SZI_(G),SZJ_(G)) !< The nominal ocean depth at each point in thickness units [H ~> m or kg m-2] + real :: tot_h(SZI_(G),SZJ_(G)) !< The total thickness of the water column [H ~> m or kg m-2] + real :: tot_dz(SZI_(G),SZJ_(G)) !< The total distance between the top and bottom of the water column [Z ~> m] + real :: Z_to_H ! A conversion factor used by some routines to convert coordinate + ! parameters to depth units [H Z-1 ~> nondim or kg m-3] + character(len=128) :: mesg ! A string for error messages + integer :: i, j, k - do_convective_adjustment = .true. - if (present(conv_adjust)) do_convective_adjustment = conv_adjust + if (present(PCM_cell)) PCM_cell(:,:,:) = .false. - use_ice_shelf = present(frac_shelf_h) + Z_to_H = US%Z_to_m * GV%m_to_H ! Often this is equivalent to GV%Z_to_H. + + if ((allocated(tv%SpV_avg)) .and. (tv%valid_SpV_halo < 1)) then + if (tv%valid_SpV_halo < 0) then + mesg = "invalid values of SpV_avg." + else + mesg = "insufficiently large SpV_avg halos of width 0 but 1 is needed." + endif + call MOM_error(FATAL, "Regridding_main called in fully non-Boussinesq mode with "//trim(mesg)) + endif + + if (allocated(tv%SpV_avg)) then ! This is the fully non-Boussinesq case + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + tot_h(i,j) = 0.0 ; tot_dz(i,j) = 0.0 + enddo ; enddo + do k=1,GV%ke ; do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + tot_h(i,j) = tot_h(i,j) + h(i,j,k) + tot_dz(i,j) = tot_dz(i,j) + GV%H_to_RZ * tv%SpV_avg(i,j,k) * h(i,j,k) + enddo ; enddo ; enddo + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + if (tot_dz(i,j) > 0.0) then + nom_depth_H(i,j) = max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) * (tot_h(i,j) / tot_dz(i,j)) + else + nom_depth_H(i,j) = 0.0 + endif + enddo ; enddo + else + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + nom_depth_H(i,j) = max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) * Z_to_H + enddo ; enddo + endif select case ( CS%regridding_scheme ) case ( REGRIDDING_ZSTAR ) - call build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h ) + call build_zstar_grid( CS, G, GV, h, nom_depth_H, dzInterface, frac_shelf_h, zScale=Z_to_H ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_SIGMA_SHELF_ZSTAR) - call build_zstar_grid( CS, G, GV, h, dzInterface ) + call build_zstar_grid( CS, G, GV, h, nom_depth_H, dzInterface, zScale=Z_to_H ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_SIGMA ) - call build_sigma_grid( CS, G, GV, h, dzInterface ) + call build_sigma_grid( CS, G, GV, h, nom_depth_H, dzInterface ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_RHO ) - if (do_convective_adjustment) call convective_adjustment(G, GV, h, tv) - call build_rho_grid( G, GV, G%US, h, tv, dzInterface, remapCS, CS, frac_shelf_h ) - call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) - case ( REGRIDDING_ARBITRARY ) - call build_grid_arbitrary( G, GV, h, dzInterface, trickGnuCompiler, CS ) + call build_rho_grid( G, GV, G%US, h, nom_depth_H, tv, dzInterface, remapCS, CS, frac_shelf_h ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_HYCOM1 ) - call build_grid_HyCOM1( G, GV, G%US, h, tv, h_new, dzInterface, CS, frac_shelf_h ) - case ( REGRIDDING_SLIGHT ) - call build_grid_SLight( G, GV, G%US, h, tv, dzInterface, CS ) + call build_grid_HyCOM1( G, GV, G%US, h, nom_depth_H, tv, h_new, dzInterface, remapCS, CS, & + frac_shelf_h, zScale=Z_to_H ) + case ( REGRIDDING_HYBGEN ) + call hybgen_regrid(G, GV, G%US, h, nom_depth_H, tv, CS%hybgen_CS, dzInterface, PCM_cell) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_ADAPTIVE ) - call build_grid_adaptive(G, GV, G%US, h, tv, dzInterface, remapCS, CS) + call build_grid_adaptive(G, GV, G%US, h, nom_depth_H, tv, dzInterface, remapCS, CS) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) + case ( REGRIDDING_ARBITRARY ) + call MOM_error(FATAL,'MOM_regridding, regridding_main: '//& + 'Regridding mode "ARB" is not implemented.') case default call MOM_error(FATAL,'MOM_regridding, regridding_main: '//& 'Unknown regridding scheme selected!') @@ -827,19 +1312,65 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_ end select ! type of grid #ifdef __DO_SAFETY_CHECKS__ - call check_remapping_grid(G, GV, h, dzInterface,'in regridding_main') + if (CS%nk == GV%ke) then + do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 ; if (G%mask2dT(i,j)>0.) then + call check_grid_column( GV%ke, h(i,j,:), dzInterface(i,j,:), 'in regridding_main') + endif ; enddo ; enddo + endif #endif + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (G%mask2dT(i,j) > 0.) then + if (minval(h(i,j,:)) < 0.0) then + write(0,*) 'regridding_main check_grid: i,j=', i, j, 'h_new(i,j,:)=', h_new(i,j,:) + call MOM_error(FATAL, "regridding_main: negative thickness encountered.") + endif + endif ; enddo ; enddo end subroutine regridding_main +!------------------------------------------------------------------------------ +!> This routine returns flags indicating which pre-remapping state adjustments +!! are needed depending on the coordinate mode in use. +subroutine regridding_preadjust_reqs(CS, do_conv_adj, do_hybgen_unmix, hybgen_CS) + + ! Arguments + type(regridding_CS), intent(in) :: CS !< Regridding control structure + logical, intent(out) :: do_conv_adj !< Convective adjustment should be done + logical, intent(out) :: do_hybgen_unmix !< Hybgen unmixing should be done + type(hybgen_regrid_CS), pointer, & + optional, intent(out) :: hybgen_CS !< Control structure for hybgen regridding for sharing parameters. + + + do_conv_adj = .false. ; do_hybgen_unmix = .false. + select case ( CS%regridding_scheme ) + + case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_SIGMA, REGRIDDING_ARBITRARY, & + REGRIDDING_HYCOM1, REGRIDDING_ADAPTIVE ) + do_conv_adj = .false. ; do_hybgen_unmix = .false. + case ( REGRIDDING_RHO ) + do_conv_adj = .true. ; do_hybgen_unmix = .false. + case ( REGRIDDING_HYBGEN ) + do_conv_adj = .false. ; do_hybgen_unmix = CS%use_hybgen_unmix + case default + call MOM_error(FATAL,'MOM_regridding, regridding_preadjust_reqs: '//& + 'Unknown regridding scheme selected!') + end select ! type of grid + + if (present(hybgen_CS) .and. do_hybgen_unmix) hybgen_CS => CS%hybgen_CS + +end subroutine regridding_preadjust_reqs + + !> Calculates h_new from h + delta_k dzInterface subroutine calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) type(regridding_CS), intent(in) :: CS !< Regridding control structure type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Old layer thicknesses (arbitrary units) - real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(in) :: dzInterface !< Change in interface positions (same as h) - real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New layer thicknesses (same as h) + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Old layer thicknesses [H ~> m or kg m-2] + !! or other units + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(in) :: dzInterface !< Change in interface positions + !! in the same units as h [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New layer thicknesses in the same + !! units as h [H ~> m or kg m-2] ! Local variables integer :: i, j, k, nki @@ -867,33 +1398,19 @@ subroutine calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) end subroutine calc_h_new_by_dz -!> Check that the total thickness of two grids match -subroutine check_remapping_grid( G, GV, h, dzInterface, msg ) - type(ocean_grid_type), intent(in) :: G !< Grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: dzInterface !< Change in interface positions - !! [H ~> m or kg m-2] - character(len=*), intent(in) :: msg !< Message to append to errors - ! Local variables - integer :: i, j - - !$OMP parallel do default(shared) - do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 - if (G%mask2dT(i,j)>0.) call check_grid_column( GV%ke, h(i,j,:), dzInterface(i,j,:), msg ) - enddo ; enddo - -end subroutine check_remapping_grid !> Check that the total thickness of new and old grids are consistent subroutine check_grid_column( nk, h, dzInterface, msg ) integer, intent(in) :: nk !< Number of cells real, dimension(nk), intent(in) :: h !< Cell thicknesses [Z ~> m] or arbitrary units - real, dimension(nk+1), intent(in) :: dzInterface !< Change in interface positions (same units as h) + real, dimension(nk+1), intent(in) :: dzInterface !< Change in interface positions (same units as h), often [Z ~> m] character(len=*), intent(in) :: msg !< Message to append to errors ! Local variables integer :: k - real :: eps, total_h_old, total_h_new, h_new + real :: eps ! A tiny relative thickness [nondim] + real :: total_h_old ! The total thickness in the old column, in [Z ~> m] or arbitrary units + real :: total_h_new ! The total thickness in the updated column, in [Z ~> m] or arbitrary units + real :: h_new ! A thickness in the updated column, in [Z ~> m] or arbitrary units eps =1. ; eps = epsilon(eps) @@ -910,7 +1427,7 @@ subroutine check_grid_column( nk, h, dzInterface, msg ) write(0,*) 'k,h,hnew=',k,h(k),h_new write(0,*) 'dzI(k+1),dzI(k)=',dzInterface(k+1),dzInterface(k) call MOM_error( FATAL, 'MOM_regridding, check_grid_column: '//& - 'Negative layer thickness implied by re-gridding, '//trim(msg)) + 'Negative layer thickness implied by re-gridding, '//trim(msg)) endif total_h_new = total_h_new + h_new @@ -925,14 +1442,14 @@ subroutine check_grid_column( nk, h, dzInterface, msg ) write(0,*) 'Hold,Hnew,Hnew-Hold=',total_h_old,total_h_new,total_h_new-total_h_old write(0,*) 'eps,(n)/2*eps*H=',eps,real(nk-1)*0.5*(total_h_old+total_h_new)*eps call MOM_error( FATAL, 'MOM_regridding, check_grid_column: '//& - 'Re-gridding did NOT conserve total thickness to within roundoff '//trim(msg)) + 'Re-gridding did NOT conserve total thickness to within roundoff '//trim(msg)) endif ! Check that the top and bottom are intentionally moving if (dzInterface(1) /= 0.) call MOM_error( FATAL, & - 'MOM_regridding, check_grid_column: Non-zero dzInterface at surface! '//trim(msg)) + 'MOM_regridding, check_grid_column: Non-zero dzInterface at surface! '//trim(msg)) if (dzInterface(nk+1) /= 0.) call MOM_error( FATAL, & - 'MOM_regridding, check_grid_column: Non-zero dzInterface at bottom! '//trim(msg)) + 'MOM_regridding, check_grid_column: Non-zero dzInterface at bottom! '//trim(msg)) end subroutine check_grid_column @@ -945,17 +1462,31 @@ subroutine filtered_grid_motion( CS, nk, z_old, z_new, dz_g ) type(regridding_CS), intent(in) :: CS !< Regridding control structure integer, intent(in) :: nk !< Number of cells in source grid real, dimension(nk+1), intent(in) :: z_old !< Old grid position [H ~> m or kg m-2] - real, dimension(CS%nk+1), intent(in) :: z_new !< New grid position [H ~> m or kg m-2] - real, dimension(CS%nk+1), intent(inout) :: dz_g !< Change in interface positions [H ~> m or kg m-2] + real, dimension(CS%nk+1), intent(in) :: z_new !< New grid position before filtering [H ~> m or kg m-2] + real, dimension(CS%nk+1), intent(inout) :: dz_g !< Change in interface positions including + !! the effects of filtering [H ~> m or kg m-2] ! Local variables - real :: sgn ! The sign convention for downward. - real :: dz_tgt, zr1, z_old_k - real :: Aq, Bq, dz0, z0, F0 - real :: zs, zd, dzwt, Idzwt - real :: wtd, Iwtd - real :: Int_zs, Int_zd, dInt_zs_zd + real :: sgn ! The sign convention for downward [nondim]. + real :: dz_tgt ! The target grid movement of the unfiltered grid [H ~> m or kg m-2] + real :: zr1 ! The old grid position of an interface relative to the surface [H ~> m or kg m-2] + real :: z_old_k ! The corrected position of the old grid [H ~> m or kg m-2] + real :: Aq ! A temporary variable related to the grid weights [nondim] + real :: Bq ! A temporary variable used in the linear term in the quadratic expression for the + ! filtered grid movement [H ~> m or kg m-2] + real :: z0, dz0 ! Together these give the position of an interface relative to a reference hieght + ! that may be adjusted for numerical accuracy in a solver [H ~> m or kg m-2] + real :: F0 ! An estimated grid movement [H ~> m or kg m-2] + real :: zs ! The depth at which the shallow filtering timescale applies [H ~> m or kg m-2] + real :: zd ! The depth at which the deep filtering timescale applies [H ~> m or kg m-2] + real :: dzwt ! The depth range over which the transition in the filtering timescale occurs [H ~> m or kg m-2] + real :: Idzwt ! The Adcroft reciprocal of dzwt [H-1 ~> m-1 or m2 kg-1] + real :: wtd ! The weight given to the new grid when time filtering [nondim] + real :: Iwtd ! The inverse of wtd [nondim] + real :: Int_zs ! A depth integral of the weights in [H ~> m or kg m-2] + real :: Int_zd ! A depth integral of the weights in [H ~> m or kg m-2] + real :: dInt_zs_zd ! The depth integral of the weights between the deep and shallow depths in [H ~> m or kg m-2] ! For debugging: - real, dimension(nk+1) :: z_act + real, dimension(nk+1) :: z_act ! The final grid positions after the filtered movement [H ~> m or kg m-2] ! real, dimension(nk+1) :: ddz_g_s, ddz_g_d logical :: debug = .false. integer :: k @@ -974,11 +1505,11 @@ subroutine filtered_grid_motion( CS, nk, z_old, z_new, dz_g ) if (debug) then do k=2,CS%nk+1 if (sgn*(z_new(k)-z_new(k-1)) < -5e-16*(abs(z_new(k))+abs(z_new(k-1))) ) & - call MOM_error(FATAL, "filtered_grid_motion: z_new is tangled.") + call MOM_error(FATAL, "filtered_grid_motion: z_new is tangled.") enddo do k=2,nk+1 if (sgn*(z_old(k)-z_old(k-1)) < -5e-16*(abs(z_old(k))+abs(z_old(k-1))) ) & - call MOM_error(FATAL, "filtered_grid_motion: z_old is tangled.") + call MOM_error(FATAL, "filtered_grid_motion: z_old is tangled.") enddo ! ddz_g_s(:) = 0.0 ; ddz_g_d(:) = 0.0 endif @@ -1052,9 +1583,9 @@ subroutine filtered_grid_motion( CS, nk, z_old, z_new, dz_g ) ! ddz_g_d(k) = sgn * (dz0 + 2.0*F0*dzwt / (Bq + sqrt(Bq**2 + 4.0*Aq*F0*dzwt) )) - dz_g(k) ! ! if (abs(ddz_g_s(k)) > 1e-12*(abs(dz_g(k)) + abs(dz_g(k)+ddz_g_s(k)))) & -! call MOM_error(WARNING, "filtered_grid_motion: Expect z_output to be tangled (sc).") +! call MOM_error(WARNING, "filtered_grid_motion: Expect z_output to be tangled (sc).") ! if (abs(ddz_g_d(k) - ddz_g_s(k)) > 1e-12*(abs(dz_g(k)+ddz_g_d(k)) + abs(dz_g(k)+ddz_g_s(k)))) & -! call MOM_error(WARNING, "filtered_grid_motion: Expect z_output to be tangled.") +! call MOM_error(WARNING, "filtered_grid_motion: Expect z_output to be tangled.") ! endif endif @@ -1070,7 +1601,7 @@ subroutine filtered_grid_motion( CS, nk, z_old, z_new, dz_g ) enddo do k=2,CS%nk+1 if (sgn*((z_act(k))-z_act(k-1)) < -1e-15*(abs(z_act(k))+abs(z_act(k-1))) ) & - call MOM_error(FATAL, "filtered_grid_motion: z_output is tangled.") + call MOM_error(FATAL, "filtered_grid_motion: z_output is tangled.") enddo endif @@ -1079,20 +1610,32 @@ end subroutine filtered_grid_motion !> Builds a z*-coordinate grid with partial steps (Adcroft and Campin, 2004). !! z* is defined as !! z* = (z-eta)/(H+eta)*H s.t. z*=0 when z=eta and z*=-H when z=-H . -subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) +subroutine build_zstar_grid( CS, G, GV, h, nom_depth_H, dzInterface, frac_shelf_h, zScale) ! Arguments type(regridding_CS), intent(in) :: CS !< Regridding control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G), CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth !! [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G)), optional,intent(in) :: frac_shelf_h !< Fractional !! ice shelf coverage [nondim]. + real, optional, intent(in) :: zScale !< Scaling factor from the target coordinate + !! resolution in Z to desired units for zInterface, + !! usually Z_to_H in which case it is in + !! units of [H Z-1 ~> nondim or kg m-3] ! Local variables - real :: nominalDepth, minThickness, totalThickness, dh ! Depths and thicknesses [H ~> m or kg m-2] - real, dimension(SZK_(GV)+1) :: zOld, zNew ! Coordinate interface heights [H ~> m or kg m-2] + real :: nominalDepth, minThickness, totalThickness ! Depths and thicknesses [H ~> m or kg m-2] +#ifdef __DO_SAFETY_CHECKS__ + real :: dh ! The larger of the total column thickness or bathymetric depth [H ~> m or kg m-2] +#endif + real, dimension(SZK_(GV)+1) :: zOld ! Previous coordinate interface heights [H ~> m or kg m-2] + real, dimension(CS%nk+1) :: zNew ! New coordinate interface heights [H ~> m or kg m-2] integer :: i, j, k, nz logical :: ice_shelf @@ -1100,10 +1643,13 @@ subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) minThickness = CS%min_thickness ice_shelf = present(frac_shelf_h) -!$OMP parallel do default(none) shared(G,GV,dzInterface,CS,nz,h,frac_shelf_h, & -!$OMP ice_shelf,minThickness) & -!$OMP private(nominalDepth,totalThickness, & -!$OMP zNew,dh,zOld) + !$OMP parallel do default(none) shared(G,GV,dzInterface,CS,nz,h,frac_shelf_h, & + !$OMP ice_shelf,minThickness,zScale,nom_depth_H) & + !$OMP private(nominalDepth,totalThickness, & +#ifdef __DO_SAFETY_CHECKS__ + !$OMP dh, & +#endif + !$OMP zNew,zOld) do j = G%jsc-1,G%jec+1 do i = G%isc-1,G%iec+1 @@ -1112,8 +1658,8 @@ subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) cycle endif - ! Local depth (G%bathyT is positive downward) - nominalDepth = (G%bathyT(i,j)+G%Z_ref)*GV%Z_to_H + ! Local depth (positive downward) + nominalDepth = nom_depth_H(i,j) ! Determine water column thickness totalThickness = 0.0 @@ -1121,46 +1667,56 @@ subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) totalThickness = totalThickness + h(i,j,k) enddo + ! if (GV%Boussinesq) then zOld(nz+1) = - nominalDepth do k = nz,1,-1 zOld(k) = zOld(k+1) + h(i,j,k) enddo + ! else ! Work downward? + ! endif if (ice_shelf) then if (frac_shelf_h(i,j) > 0.) then ! under ice shelf call build_zstar_column(CS%zlike_CS, nominalDepth, totalThickness, zNew, & - z_rigid_top = totalThickness-nominalDepth, & - eta_orig=zOld(1), zScale=GV%Z_to_H) + z_rigid_top=totalThickness-nominalDepth, & + eta_orig=zOld(1), zScale=zScale) else call build_zstar_column(CS%zlike_CS, nominalDepth, totalThickness, & - zNew, zScale=GV%Z_to_H) + zNew, zScale=zScale) endif else call build_zstar_column(CS%zlike_CS, nominalDepth, totalThickness, & - zNew, zScale=GV%Z_to_H) + zNew, zScale=zScale) endif ! Calculate the final change in grid position after blending new and old grids - call filtered_grid_motion( CS, nz, zOld, zNew, dzInterface(i,j,:) ) + if (CS%use_depth_based_time_filter .or. CS%old_grid_weight>0.) & + call filtered_grid_motion(CS, nz, zOld, zNew, dzInterface(i,j,:)) #ifdef __DO_SAFETY_CHECKS__ - dh=max(nominalDepth,totalThickness) - if (abs(zNew(1)-zOld(1))>(nz-1)*0.5*epsilon(dh)*dh) then + dh = max(nominalDepth,totalThickness) + if (abs(zNew(1)-zOld(1)) > (nz-1)*0.5*epsilon(dh)*dh) then write(0,*) 'min_thickness=',CS%min_thickness write(0,*) 'nominalDepth=',nominalDepth,'totalThickness=',totalThickness - write(0,*) 'dzInterface(1) = ',dzInterface(i,j,1),epsilon(dh),nz - do k=1,nz+1 + write(0,*) 'dzInterface(1) = ', dzInterface(i,j,1), epsilon(dh), nz, CS%nk + do k=1,min(nz,CS%nk)+1 write(0,*) k,zOld(k),zNew(k) enddo - do k=1,nz + do k=min(nz,CS%nk)+2,CS%nk+1 + write(0,*) k,zOld(nz+1),zNew(k) + enddo + do k=1,min(nz,CS%nk) write(0,*) k,h(i,j,k),zNew(k)-zNew(k+1),CS%coordinateResolution(k) enddo + do k=min(nz,CS%nk)+1,CS%nk + write(0,*) k, 0.0, zNew(k)-zNew(k+1), CS%coordinateResolution(k) + enddo call MOM_error( FATAL, & 'MOM_regridding, build_zstar_grid(): top surface has moved!!!' ) endif #endif - call adjust_interface_motion( CS, nz, h(i,j,:), dzInterface(i,j,:) ) + if (CS%use_adjust_interface_motion) call adjust_interface_motion( CS, nz, h(i,j,:), dzInterface(i,j,:) ) enddo enddo @@ -1170,7 +1726,7 @@ end subroutine build_zstar_grid !------------------------------------------------------------------------------ ! Build sigma grid !> This routine builds a grid based on terrain-following coordinates. -subroutine build_sigma_grid( CS, G, GV, h, dzInterface ) +subroutine build_sigma_grid( CS, G, GV, h, nom_depth_H, dzInterface ) !------------------------------------------------------------------------------ ! This routine builds a grid based on terrain-following coordinates. ! The module parameter coordinateResolution(:) determines the resolution in @@ -1183,14 +1739,22 @@ subroutine build_sigma_grid( CS, G, GV, h, dzInterface ) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G), CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth !! [H ~> m or kg m-2] ! Local variables - integer :: i, j, k - integer :: nz - real :: nominalDepth, totalThickness, dh - real, dimension(SZK_(GV)+1) :: zOld, zNew + real :: nominalDepth ! The nominal depth of the sea-floor in thickness units [H ~> m or kg m-2] + real :: totalThickness ! The total thickness of the water column [H ~> m or kg m-2] +#ifdef __DO_SAFETY_CHECKS__ + real :: dh ! The larger of the total column thickness or bathymetric depth [H ~> m or kg m-2] +#endif + real, dimension(SZK_(GV)+1) :: zOld ! Previous coordinate interface heights [H ~> m or kg m-2] + real, dimension(CS%nk+1) :: zNew ! New coordinate interface heights [H ~> m or kg m-2] + integer :: i, j, k, nz nz = GV%ke @@ -1202,36 +1766,52 @@ subroutine build_sigma_grid( CS, G, GV, h, dzInterface ) cycle endif - ! The rest of the model defines grids integrating up from the bottom - nominalDepth = (G%bathyT(i,j)+G%Z_ref)*GV%Z_to_H - ! Determine water column height totalThickness = 0.0 do k = 1,nz totalThickness = totalThickness + h(i,j,k) enddo + ! In sigma coordinates, the bathymetric depth is only used as an arbitrary offset that + ! cancels out when determining coordinate motion, so referencing the column postions to + ! the surface is perfectly acceptable, but for preservation of previous answers the + ! referencing is done relative to the bottom when in Boussinesq or semi-Boussinesq mode. + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + nominalDepth = nom_depth_H(i,j) + else + nominalDepth = totalThickness + endif + call build_sigma_column(CS%sigma_CS, nominalDepth, totalThickness, zNew) ! Calculate the final change in grid position after blending new and old grids zOld(nz+1) = -nominalDepth do k = nz,1,-1 - zOld(k) = zOld(k+1) + h(i, j, k) + zOld(k) = zOld(k+1) + h(i,j,k) enddo - call filtered_grid_motion( CS, nz, zOld, zNew, dzInterface(i,j,:) ) + if (CS%use_depth_based_time_filter .or. CS%old_grid_weight>0.) & + call filtered_grid_motion(CS, nz, zOld, zNew, dzInterface(i,j,:)) #ifdef __DO_SAFETY_CHECKS__ - dh=max(nominalDepth,totalThickness) - if (abs(zNew(1)-zOld(1))>(CS%nk-1)*0.5*epsilon(dh)*dh) then + dh = max(nominalDepth,totalThickness) + if (abs(zNew(1)-zOld(1)) > (CS%nk-1)*0.5*epsilon(dh)*dh) then write(0,*) 'min_thickness=',CS%min_thickness write(0,*) 'nominalDepth=',nominalDepth,'totalThickness=',totalThickness write(0,*) 'dzInterface(1) = ',dzInterface(i,j,1),epsilon(dh),nz,CS%nk - do k=1,nz+1 + do k=1,min(nz,CS%nk)+1 write(0,*) k,zOld(k),zNew(k) enddo - do k=1,CS%nk - write(0,*) k,h(i,j,k),zNew(k)-zNew(k+1),totalThickness*CS%coordinateResolution(k),CS%coordinateResolution(k) + do k=min(nz,CS%nk)+2,CS%nk+1 + write(0,*) k,zOld(nz+1),zNew(k) + enddo + do k=1,min(nz,CS%nk) + write(0,*) k,h(i,j,k),zNew(k)-zNew(k+1),totalThickness*CS%coordinateResolution(k), & + CS%coordinateResolution(k) + enddo + do k=min(nz,CS%nk)+1,CS%nk + write(0,*) k,0.0,zNew(k)-zNew(k+1),totalThickness*CS%coordinateResolution(k), & + CS%coordinateResolution(k) enddo call MOM_error( FATAL, & 'MOM_regridding, build_sigma_grid: top surface has moved!!!' ) @@ -1249,11 +1829,11 @@ end subroutine build_sigma_grid ! Build grid based on target interface densities !------------------------------------------------------------------------------ !> This routine builds a new grid based on a given set of target interface densities. -subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS, frac_shelf_h ) +subroutine build_rho_grid( G, GV, US, h, nom_depth_H, tv, dzInterface, remapCS, CS, frac_shelf_h ) !------------------------------------------------------------------------------ ! This routine builds a new grid based on a given set of target interface ! densities (these target densities are computed by taking the mean value -! of given layer densities). The algorithn operates as follows within each +! of given layer densities). The algorithm operates as follows within each ! column: ! 1. Given T & S within each layer, the layer densities are computed. ! 2. Based on these layer densities, a global density profile is reconstructed @@ -1266,36 +1846,35 @@ subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS, frac_shel !------------------------------------------------------------------------------ ! Arguments - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - real, dimension(SZI_(G),SZJ_(G), SZK_(GV)+1), intent(inout) :: dzInterface !< The change in interface depth - !! [H ~> m or kg m-2] - type(remapping_CS), intent(in) :: remapCS !< The remapping control structure - type(regridding_CS), intent(in) :: CS !< Regridding control structure - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: frac_shelf_h !< Fractional ice - !! shelf coverage [nondim] + type(regridding_CS), intent(in) :: CS !< Regridding control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth + !! [H ~> m or kg m-2] + type(remapping_CS), intent(in) :: remapCS !< The remapping control structure + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: frac_shelf_h !< Fractional ice + !! shelf coverage [nondim] ! Local variables - integer :: nz + integer :: nz ! The number of layers in the input grid integer :: i, j, k real :: nominalDepth ! Depth of the bottom of the ocean, positive downward [H ~> m or kg m-2] - real, dimension(SZK_(GV)+1) :: zOld, zNew ! Old and new interface heights [H ~> m or kg m-2] + real, dimension(SZK_(GV)+1) :: zOld ! Previous coordinate interface heights [H ~> m or kg m-2] + real, dimension(CS%nk+1) :: zNew ! New coordinate interface heights [H ~> m or kg m-2] real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] real :: totalThickness ! Total thicknesses [H ~> m or kg m-2] #ifdef __DO_SAFETY_CHECKS__ - real :: dh + real :: dh ! The larger of the total column thickness or bathymetric depth [H ~> m or kg m-2] #endif logical :: ice_shelf - if (.not.CS%remap_answers_2018) then - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - elseif (GV%Boussinesq) then - h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 - else - h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 - endif + h_neglect = set_h_neglect(GV, CS%remap_answer_date, h_neglect_edge) nz = GV%ke ice_shelf = present(frac_shelf_h) @@ -1312,15 +1891,22 @@ subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS, frac_shel cycle endif - - ! Local depth (G%bathyT is positive downward) - nominalDepth = (G%bathyT(i,j)+G%Z_ref)*GV%Z_to_H - ! Determine total water column thickness totalThickness = 0.0 do k=1,nz totalThickness = totalThickness + h(i,j,k) enddo + + ! In rho coordinates, the bathymetric depth is only used as an arbitrary offset that + ! cancels out when determining coordinate motion, so referencing the column postions to + ! the surface is perfectly acceptable, but for preservation of previous answers the + ! referencing is done relative to the bottom when in Boussinesq or semi-Boussinesq mode. + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + nominalDepth = nom_depth_H(i,j) + else + nominalDepth = totalThickness + endif + ! Determine absolute interface positions zOld(nz+1) = - nominalDepth do k = nz,1,-1 @@ -1328,13 +1914,13 @@ subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS, frac_shel enddo if (ice_shelf) then - call build_rho_column(CS%rho_CS, nz, nominalDepth, h(i, j, :), & - tv%T(i, j, :), tv%S(i, j, :), tv%eqn_of_state, zNew, & - z_rigid_top = totalThickness - nominalDepth, eta_orig = zOld(1), & + call build_rho_column(CS%rho_CS, nz, nominalDepth, h(i,j,:), & + tv%T(i,j,:), tv%S(i,j,:), tv%eqn_of_state, zNew, & + z_rigid_top=totalThickness - nominalDepth, eta_orig = zOld(1), & h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) else - call build_rho_column(CS%rho_CS, nz, nominalDepth, h(i, j, :), & - tv%T(i, j, :), tv%S(i, j, :), tv%eqn_of_state, zNew, & + call build_rho_column(CS%rho_CS, nz, nominalDepth, h(i,j,:), & + tv%T(i,j,:), tv%S(i,j,:), tv%eqn_of_state, zNew, & h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) endif @@ -1352,10 +1938,11 @@ subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS, frac_shel endif ! Calculate the final change in grid position after blending new and old grids - call filtered_grid_motion( CS, nz, zOld, zNew, dzInterface(i,j,:) ) + if (CS%use_depth_based_time_filter .or. CS%old_grid_weight>0.) & + call filtered_grid_motion(CS, nz, zOld, zNew, dzInterface(i,j,:)) #ifdef __DO_SAFETY_CHECKS__ - do k = 2,nz + do k=2,CS%nk if (zNew(k) > zOld(1)) then write(0,*) 'zOld=',zOld write(0,*) 'zNew=',zNew @@ -1375,17 +1962,23 @@ subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS, frac_shel totalThickness = totalThickness + h(i,j,k) enddo - dh=max(nominalDepth,totalThickness) - if (abs(zNew(1)-zOld(1))>(nz-1)*0.5*epsilon(dh)*dh) then + dh = max(nominalDepth, totalThickness) + if (abs(zNew(1)-zOld(1)) > (nz-1)*0.5*epsilon(dh)*dh) then write(0,*) 'min_thickness=',CS%min_thickness write(0,*) 'nominalDepth=',nominalDepth,'totalThickness=',totalThickness write(0,*) 'zNew(1)-zOld(1) = ',zNew(1)-zOld(1),epsilon(dh),nz - do k=1,nz+1 + do k=1,min(nz,CS%nk)+1 write(0,*) k,zOld(k),zNew(k) enddo + do k=min(nz,CS%nk)+2,CS%nk+1 + write(0,*) k,zOld(nz+1),zNew(k) + enddo do k=1,nz write(0,*) k,h(i,j,k),zNew(k)-zNew(k+1) enddo + do k=min(nz,CS%nk)+1,CS%nk + write(0,*) k, 0.0, zNew(k)-zNew(k+1), CS%coordinateResolution(k) + enddo call MOM_error( FATAL, & 'MOM_regridding, build_rho_grid: top surface has moved!!!' ) endif @@ -1403,36 +1996,43 @@ end subroutine build_rho_grid !! \remark { Based on Bleck, 2002: An ocean-ice general circulation model framed in !! hybrid isopycnic-Cartesian coordinates, Ocean Modelling 37, 55-88. !! http://dx.doi.org/10.1016/S1463-5003(01)00012-9 } -subroutine build_grid_HyCOM1( G, GV, US, h, tv, h_new, dzInterface, CS, frac_shelf_h ) +subroutine build_grid_HyCOM1( G, GV, US, h, nom_depth_H, tv, h_new, dzInterface, remapCS, CS, & + frac_shelf_h, zScale ) type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean 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 !< Existing model thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + type(remapping_CS), intent(in) :: remapCS !< The remapping control structure type(regridding_CS), intent(in) :: CS !< Regridding control structure real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< Changes in interface position + !! in thickness units [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: frac_shelf_h !< Fractional ice shelf - !! coverage [nondim] + !! coverage [nondim] + real, optional, intent(in) :: zScale !< Scaling factor from the target coordinate + !! resolution in Z to desired units for zInterface, + !! usually Z_to_H in which case it is in + !! units of [H Z-1 ~> nondim or kg m-3] ! Local variables - real, dimension(SZK_(GV)+1) :: z_col ! Source interface positions relative to the surface [H ~> m or kg m-2] + real, dimension(SZK_(GV)+1) :: z_col ! Source interface positions relative to the surface [H ~> m or kg m-2] + real, dimension(SZK_(GV)) :: p_col ! Layer center pressure in the input column [R L2 T-2 ~> Pa] real, dimension(CS%nk+1) :: z_col_new ! New interface positions relative to the surface [H ~> m or kg m-2] - real, dimension(SZK_(GV)+1) :: dz_col ! The realized change in z_col [H ~> m or kg m-2] - real, dimension(SZK_(GV)) :: p_col ! Layer center pressure [R L2 T-2 ~> Pa] - integer :: i, j, k, nki - real :: depth, nominalDepth - real :: h_neglect, h_neglect_edge - real :: z_top_col, totalThickness + real, dimension(CS%nk+1) :: dz_col ! The realized change in z_col [H ~> m or kg m-2] + real :: nominalDepth ! The nominal depth of the seafloor in thickness units [H ~> m or kg m-2] + real :: h_neglect, h_neglect_edge ! Negligible thicknesses used for remapping [H ~> m or kg m-2] + real :: z_top_col ! The nominal height of the sea surface or ice-ocean interface + ! in thickness units [H ~> m or kg m-2] + real :: totalThickness ! The total thickness of the water column [H ~> m or kg m-2] logical :: ice_shelf + integer :: i, j, k, nki - if (.not.CS%remap_answers_2018) then - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - elseif (GV%Boussinesq) then - h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 - else - h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 - endif + h_neglect = set_h_neglect(GV, CS%remap_answer_date, h_neglect_edge) if (.not.CS%target_density_set) call MOM_error(FATAL, "build_grid_HyCOM1 : "//& "Target densities must be set before build_grid_HyCOM1 is called.") @@ -1444,12 +2044,12 @@ subroutine build_grid_HyCOM1( G, GV, US, h, tv, h_new, dzInterface, CS, frac_she do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 if (G%mask2dT(i,j)>0.) then - nominalDepth = (G%bathyT(i,j)+G%Z_ref) * GV%Z_to_H + nominalDepth = nom_depth_H(i,j) if (ice_shelf) then totalThickness = 0.0 do k=1,GV%ke - totalThickness = totalThickness + h(i,j,k) * GV%Z_to_H + totalThickness = totalThickness + h(i,j,k) enddo z_top_col = max(nominalDepth-totalThickness,0.0) else @@ -1463,17 +2063,18 @@ subroutine build_grid_HyCOM1( G, GV, US, h, tv, h_new, dzInterface, CS, frac_she ( 0.5 * ( z_col(K) + z_col(K+1) ) * (GV%H_to_RZ*GV%g_Earth) - tv%P_Ref ) enddo - call build_hycom1_column(CS%hycom_CS, tv%eqn_of_state, GV%ke, nominalDepth, & + call build_hycom1_column(CS%hycom_CS, remapCS, tv%eqn_of_state, GV%ke, i, j, nominalDepth, & h(i,j,:), tv%T(i,j,:), tv%S(i,j,:), p_col, & - z_col, z_col_new, zScale=GV%Z_to_H, & + z_col, z_col_new, zScale=zScale, & h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) ! Calculate the final change in grid position after blending new and old grids - call filtered_grid_motion( CS, GV%ke, z_col, z_col_new, dz_col ) + if (CS%use_depth_based_time_filter .or. CS%old_grid_weight>0.) & + call filtered_grid_motion( CS, GV%ke, z_col, z_col_new, dz_col ) ! This adjusts things robust to round-off errors dz_col(:) = -dz_col(:) - call adjust_interface_motion( CS, GV%ke, h(i,j,:), dz_col(:) ) + if (CS%use_adjust_interface_motion) call adjust_interface_motion( CS, GV%ke, h(i,j,:), dz_col(:) ) dzInterface(i,j,1:nki+1) = dz_col(1:nki+1) if (nki This subroutine builds an adaptive grid that follows density surfaces where !! possible, subject to constraints on the smoothness of interface heights. -subroutine build_grid_adaptive(G, GV, US, h, tv, dzInterface, remapCS, CS) +subroutine build_grid_adaptive(G, GV, US, h, nom_depth_H, tv, dzInterface, remapCS, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: dzInterface !< The change in interface depth + type(regridding_CS), intent(in) :: CS !< Regridding control structure + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth !! [H ~> m or kg m-2] type(remapping_CS), intent(in) :: remapCS !< The remapping control structure - type(regridding_CS), intent(in) :: CS !< Regridding control structure ! local variables integer :: i, j, k, nz ! indices and dimension lengths - ! temperature, salinity and pressure on interfaces - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: tInt, sInt + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: tInt ! Temperature on interfaces [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: sInt ! Salinity on interfaces [S ~> ppt] ! current interface positions and after tendency term is applied ! positive downward real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: zInt ! Interface depths [H ~> m or kg m-2] @@ -1512,6 +2117,9 @@ subroutine build_grid_adaptive(G, GV, US, h, tv, dzInterface, remapCS, CS) nz = GV%ke + call assert((GV%ke == CS%nk), "build_grid_adaptive is only written to work "//& + "with the same number of input and target layers.") + ! position surface at z = 0. zInt(:,:,1) = 0. @@ -1538,100 +2146,31 @@ subroutine build_grid_adaptive(G, GV, US, h, tv, dzInterface, remapCS, CS) cycle endif - call build_adapt_column(CS%adapt_CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNext) + call build_adapt_column(CS%adapt_CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, & + nom_depth_H, zNext) - call filtered_grid_motion(CS, nz, zInt(i,j,:), zNext, dzInterface(i,j,:)) + if (CS%use_depth_based_time_filter .or. CS%old_grid_weight>0.) & + call filtered_grid_motion(CS, nz, zInt(i,j,:), zNext, dzInterface(i,j,:)) ! convert from depth to z do K = 1, nz+1 ; dzInterface(i,j,K) = -dzInterface(i,j,K) ; enddo - call adjust_interface_motion(CS, nz, h(i,j,:), dzInterface(i,j,:)) + if (CS%use_adjust_interface_motion) call adjust_interface_motion(CS, nz, h(i,j,:), dzInterface(i,j,:)) enddo ; enddo end subroutine build_grid_adaptive -!> Builds a grid that tracks density interfaces for water that is denser than -!! the surface density plus an increment of some number of layers, and uses all -!! lighter layers uniformly above this location. Note that this amounts to -!! interpolating to find the depth of an arbitrary (non-integer) interface index -!! which should make the results vary smoothly in space to the extent that the -!! surface density and interior stratification vary smoothly in space. Over -!! shallow topography, this will tend to give a uniform sigma-like coordinate. -!! For sufficiently shallow water, a minimum grid spacing is used to avoid -!! certain instabilities. -subroutine build_grid_SLight(G, GV, US, h, tv, dzInterface, CS) - type(ocean_grid_type), intent(in) :: G !< Grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean 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 !< Existing model thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: dzInterface !< Changes in interface position - type(regridding_CS), intent(in) :: CS !< Regridding control structure - - real, dimension(SZK_(GV)+1) :: z_col ! Interface positions relative to the surface [H ~> m or kg m-2] - real, dimension(SZK_(GV)+1) :: z_col_new ! Interface positions relative to the surface [H ~> m or kg m-2] - real, dimension(SZK_(GV)+1) :: dz_col ! The realized change in z_col [H ~> m or kg m-2] - real, dimension(SZK_(GV)) :: p_col ! Layer center pressure [R L2 T-2 ~> Pa] - - ! Local variables - real :: depth ! Depth of the ocean relative to the mean sea surface height in thickness units [H ~> m or kg m-2] - integer :: i, j, k, nz - real :: h_neglect, h_neglect_edge - - if (.not.CS%remap_answers_2018) then - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - elseif (GV%Boussinesq) then - h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 - else - h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 - endif - - nz = GV%ke - - if (.not.CS%target_density_set) call MOM_error(FATAL, "build_grid_SLight : "//& - "Target densities must be set before build_grid_SLight is called.") - - ! Build grid based on target interface densities - do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 - if (G%mask2dT(i,j)>0.) then - - depth = (G%bathyT(i,j)+G%Z_ref) * GV%Z_to_H - z_col(1) = 0. ! Work downward rather than bottom up - do K=1,nz - z_col(K+1) = z_col(K) + h(i,j,k) - p_col(k) = tv%P_Ref + CS%compressibility_fraction * & - ( 0.5 * ( z_col(K) + z_col(K+1) ) * (GV%H_to_RZ*GV%g_Earth) - tv%P_Ref ) - enddo - - call build_slight_column(CS%slight_CS, tv%eqn_of_state, GV%H_to_RZ*GV%g_Earth, & - GV%H_subroundoff, nz, depth, h(i, j, :), & - tv%T(i, j, :), tv%S(i, j, :), p_col, z_col, z_col_new, & - h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) - - ! Calculate the final change in grid position after blending new and old grids - call filtered_grid_motion( CS, nz, z_col, z_col_new, dz_col ) - do K=1,nz+1 ; dzInterface(i,j,K) = -dz_col(K) ; enddo -#ifdef __DO_SAFETY_CHECKS__ - if (dzInterface(i,j,1) /= 0.) stop 'build_grid_SLight: Surface moved?!' - if (dzInterface(i,j,nz+1) /= 0.) stop 'build_grid_SLight: Bottom moved?!' -#endif - - ! This adjusts things robust to round-off errors - call adjust_interface_motion( CS, nz, h(i,j,:), dzInterface(i,j,:) ) - - else ! on land - dzInterface(i,j,:) = 0. - endif ! mask2dT - enddo ; enddo ! i,j - -end subroutine build_grid_SLight - !> Adjust dz_Interface to ensure non-negative future thicknesses subroutine adjust_interface_motion( CS, nk, h_old, dz_int ) type(regridding_CS), intent(in) :: CS !< Regridding control structure integer, intent(in) :: nk !< Number of layers in h_old - real, dimension(nk), intent(in) :: h_old !< Minimum allowed thickness of h [H ~> m or kg m-2] - real, dimension(CS%nk+1), intent(inout) :: dz_int !< Minimum allowed thickness of h [H ~> m or kg m-2] + real, dimension(nk), intent(in) :: h_old !< Layer thicknesses on the old grid [H ~> m or kg m-2] + real, dimension(CS%nk+1), intent(inout) :: dz_int !< Interface movements, adjusted to keep the thicknesses + !! thicker than their minimum value [H ~> m or kg m-2] ! Local variables + real :: h_new ! A layer thickness on the new grid [H ~> m or kg m-2] + real :: eps ! A tiny relative thickness [nondim] + real :: h_total ! The total thickness of the old grid [H ~> m or kg m-2] + real :: h_err ! An error tolerance that use used to flag unacceptably large negative layer thicknesses + ! that can not be explained by roundoff errors [H ~> m or kg m-2] integer :: k - real :: h_new, eps, h_total, h_err eps = 1. ; eps = epsilon(eps) @@ -1642,8 +2181,8 @@ subroutine adjust_interface_motion( CS, nk, h_old, dz_int ) h_new = h_old(k) + ( dz_int(k) - dz_int(k+1) ) if (h_new < -3.0*h_err) then write(0,*) 'h<0 at k=',k,'h_old=',h_old(k), & - 'wup=',dz_int(k),'wdn=',dz_int(k+1),'dw_dz=',dz_int(k) - dz_int(k+1), & - 'h_new=',h_new,'h_err=',h_err + 'wup=',dz_int(k),'wdn=',dz_int(k+1),'dw_dz=',dz_int(k) - dz_int(k+1), & + 'h_new=',h_new,'h_err=',h_err call MOM_error( FATAL, 'MOM_regridding: adjust_interface_motion() - '//& 'implied h<0 is larger than roundoff!') endif @@ -1654,8 +2193,8 @@ subroutine adjust_interface_motion( CS, nk, h_old, dz_int ) h_new = ( dz_int(k) - dz_int(k+1) ) if (h_new < -3.0*h_err) then write(0,*) 'h<0 at k=',k,'h_old was empty',& - 'wup=',dz_int(k),'wdn=',dz_int(k+1),'dw_dz=',dz_int(k) - dz_int(k+1), & - 'h_new=',h_new,'h_err=',h_err + 'wup=',dz_int(k),'wdn=',dz_int(k+1),'dw_dz=',dz_int(k) - dz_int(k+1), & + 'h_new=',h_new,'h_err=',h_err call MOM_error( FATAL, 'MOM_regridding: adjust_interface_motion() - '//& 'implied h<0 is larger than roundoff!') endif @@ -1664,14 +2203,14 @@ subroutine adjust_interface_motion( CS, nk, h_old, dz_int ) do k = min(CS%nk,nk),2,-1 h_new = h_old(k) + ( dz_int(k) - dz_int(k+1) ) if (h_new m or kg m-2] - real, dimension(SZI_(G),SZJ_(G), SZK_(GV)+1), intent(inout) :: dzInterface !< The change in interface - !! depth [H ~> m or kg m-2] - real, intent(inout) :: h_new !< New layer thicknesses [H ~> m or kg m-2] - type(regridding_CS), intent(in) :: CS !< Regridding control structure - - ! Local variables - integer :: i, j, k - integer :: nz - real :: z_inter(SZK_(GV)+1) - real :: total_height - real :: delta_h - real :: max_depth - real :: eta ! local elevation [H ~> m or kg m-2] - real :: local_depth ! The local ocean depth relative to mean sea level in thickness units [H ~> m or kg m-2] - real :: x1, y1, x2, y2 - real :: x, t - - nz = GV%ke - max_depth = G%max_depth*GV%Z_to_H - - do j = G%jsc-1,G%jec+1 - do i = G%isc-1,G%iec+1 - - ! Local depth - local_depth = (G%bathyT(i,j)+G%Z_ref)*GV%Z_to_H - - ! Determine water column height - total_height = 0.0 - do k = 1,nz - total_height = total_height + h(i,j,k) - enddo - - eta = total_height - local_depth - - ! Compute new thicknesses based on stretched water column - delta_h = (max_depth + eta) / nz - - ! Define interfaces - z_inter(1) = eta - do k = 1,nz - z_inter(k+1) = z_inter(k) - delta_h - enddo - - ! Refine grid in the middle - do k = 1,nz+1 - x1 = 0.35; y1 = 0.45; x2 = 0.65; y2 = 0.55 - - x = - ( z_inter(k) - eta ) / max_depth - - if ( x <= x1 ) then - t = y1*x/x1 - elseif ( (x > x1 ) .and. ( x < x2 )) then - t = y1 + (y2-y1) * (x-x1) / (x2-x1) - else - t = y2 + (1.0-y2) * (x-x2) / (1.0-x2) - endif - - z_inter(k) = -t * max_depth + eta - - enddo - - ! Modify interface heights to account for topography - z_inter(nz+1) = - local_depth - - ! Modify interface heights to avoid layers of zero thicknesses - do k = nz,1,-1 - if ( z_inter(k) < (z_inter(k+1) + CS%min_thickness) ) then - z_inter(k) = z_inter(k+1) + CS%min_thickness - endif - enddo - - ! Change in interface position - x = 0. ! Left boundary at x=0 - dzInterface(i,j,1) = 0. - do k = 2,nz - x = x + h(i,j,k) - dzInterface(i,j,k) = z_inter(k) - x - enddo - dzInterface(i,j,nz+1) = 0. - - enddo - enddo - -stop 'OOOOOOPS' ! For some reason the gnu compiler will not let me delete this - ! routine???? - -end subroutine build_grid_arbitrary - - !------------------------------------------------------------------------------ -! Check grid integrity -!------------------------------------------------------------------------------ +!> make sure all layers are at least as thick as the minimum thickness allowed +!! for regridding purposes by inflating thin layers. This breaks mass conservation +!! and adds mass to the model when there are excessively thin layers. subroutine inflate_vanished_layers_old( CS, G, GV, h ) !------------------------------------------------------------------------------ ! This routine is called when initializing the regridding options. The @@ -1797,14 +2236,14 @@ subroutine inflate_vanished_layers_old( CS, G, GV, h ) !------------------------------------------------------------------------------ ! Arguments - type(regridding_CS), intent(in) :: CS !< Regridding control structure - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G), SZK_(GV)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(regridding_CS), intent(in) :: CS !< Regridding control structure + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] ! Local variables integer :: i, j, k - real :: hTmp(GV%ke) + real :: hTmp(GV%ke) ! A copy of a 1-d column of h [H ~> m or kg m-2] do i = G%isc-1,G%iec+1 do j = G%jsc-1,G%jec+1 @@ -1840,21 +2279,24 @@ subroutine convective_adjustment(G, GV, h, tv) !------------------------------------------------------------------------------ ! Local variables - integer :: i, j, k - real :: T0, T1 ! temperatures - real :: S0, S1 ! salinities - real :: r0, r1 ! densities - real :: h0, h1 + real :: T0, T1 ! temperatures of two layers [C ~> degC] + real :: S0, S1 ! salinities of two layers [S ~> ppt] + real :: r0, r1 ! densities of two layers [R ~> kg m-3] + real :: h0, h1 ! Layer thicknesses [H ~> m or kg m-2] + real, dimension(GV%ke) :: p_col ! A column of zero pressures [R L2 T-2 ~> Pa] + real, dimension(GV%ke) :: densities ! Densities in the column [R ~> kg m-3] logical :: stratified - real, dimension(GV%ke) :: p_col, densities + integer :: i, j, k + !### Doing convective adjustment based on potential densities with zero pressure seems + ! questionable, although it does avoid ambiguous sorting. -RWH p_col(:) = 0. ! Loop on columns do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 ! Compute densities within current water column - call calculate_density( tv%T(i,j,:), tv%S(i,j,:), p_col, densities, tv%eqn_of_state) + call calculate_density(tv%T(i,j,:), tv%S(i,j,:), p_col, densities, tv%eqn_of_state) ! Repeat restratification until complete do @@ -1873,9 +2315,12 @@ subroutine convective_adjustment(G, GV, h, tv) tv%S(i,j,k) = S1 ; tv%S(i,j,k+1) = S0 h(i,j,k) = h1 ; h(i,j,k+1) = h0 ! Recompute densities at levels k and k+1 - call calculate_density( tv%T(i,j,k), tv%S(i,j,k), p_col(k), densities(k), tv%eqn_of_state) - call calculate_density( tv%T(i,j,k+1), tv%S(i,j,k+1), p_col(k+1), & + call calculate_density(tv%T(i,j,k), tv%S(i,j,k), p_col(k), & + densities(k), tv%eqn_of_state) + call calculate_density(tv%T(i,j,k+1), tv%S(i,j,k+1), p_col(k+1), & densities(k+1), tv%eqn_of_state ) + ! Because p_col is has uniform values, these calculate_density calls are equivalent to + ! densities(k) = r1 ; densities(k+1) = r0 stratified = .false. endif enddo ! k @@ -1899,11 +2344,15 @@ function uniformResolution(nk,coordMode,maxDepth,rhoLight,rhoHeavy) character(len=*), intent(in) :: coordMode !< A string indicating the coordinate mode. !! See the documentation for regrid_consts !! for the recognized values. - real, intent(in) :: maxDepth !< The range of the grid values in some modes - real, intent(in) :: rhoLight !< The minimum value of the grid in RHO mode - real, intent(in) :: rhoHeavy !< The maximum value of the grid in RHO mode + real, intent(in) :: maxDepth !< The range of the grid values in some modes, in coordinate + !! dependent units that might be [m] or [kg m-3] or [nondim] + !! or something else. + real, intent(in) :: rhoLight !< The minimum value of the grid in RHO mode [kg m-3] + real, intent(in) :: rhoHeavy !< The maximum value of the grid in RHO mode [kg m-3] - real :: uniformResolution(nk) !< The returned uniform resolution grid. + real :: uniformResolution(nk) !< The returned uniform resolution grid, in + !! coordinate dependent units that might be [m] or + !! [kg m-3] or [nondim] or something else. ! Local variables integer :: scheme @@ -1911,8 +2360,8 @@ function uniformResolution(nk,coordMode,maxDepth,rhoLight,rhoHeavy) scheme = coordinateMode(coordMode) select case ( scheme ) - case ( REGRIDDING_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_SLIGHT, REGRIDDING_SIGMA_SHELF_ZSTAR, & - REGRIDDING_ADAPTIVE ) + case ( REGRIDDING_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, & + REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_ADAPTIVE ) uniformResolution(:) = maxDepth / real(nk) case ( REGRIDDING_RHO ) @@ -1923,7 +2372,7 @@ function uniformResolution(nk,coordMode,maxDepth,rhoLight,rhoHeavy) case default call MOM_error(FATAL, "MOM_regridding, uniformResolution: "//& - "Unrecognized choice for coordinate mode ("//trim(coordMode)//").") + "Unrecognized choice for coordinate mode ("//trim(coordMode)//").") end select ! type of grid @@ -1931,13 +2380,15 @@ end function uniformResolution !> Initialize the coordinate resolutions by calling the appropriate initialization !! routine for the specified coordinate mode. -subroutine initCoord(CS, GV, US, coord_mode) +subroutine initCoord(CS, G, GV, US, coord_mode, param_file) type(regridding_CS), intent(inout) :: CS !< Regridding control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type character(len=*), intent(in) :: coord_mode !< A string indicating the coordinate mode. !! See the documentation for regrid_consts !! for the recognized values. - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file select case (coordinateMode(coord_mode)) case (REGRIDDING_ZSTAR) @@ -1949,11 +2400,16 @@ subroutine initCoord(CS, GV, US, coord_mode) case (REGRIDDING_RHO) call init_coord_rho(CS%rho_CS, CS%nk, CS%ref_pressure, CS%target_density, CS%interp_CS) case (REGRIDDING_HYCOM1) - call init_coord_hycom(CS%hycom_CS, CS%nk, CS%coordinateResolution, CS%target_density, & - CS%interp_CS) - case (REGRIDDING_SLIGHT) - call init_coord_slight(CS%slight_CS, CS%nk, CS%ref_pressure, CS%target_density, & - CS%interp_CS, GV%m_to_H) + if (allocated(CS%coordinateResolution_3d)) then + call init_3d_coord_hycom(CS%hycom_CS, G, CS%nk, & + CS%coordinateResolution_3d, CS%target_density_3d, & + CS%interp_CS) + else + call init_coord_hycom(CS%hycom_CS, CS%nk, CS%coordinateResolution, CS%target_density, & + CS%interp_CS) + endif + case (REGRIDDING_HYBGEN) + call init_hybgen_regrid(CS%hybgen_CS, GV, US, param_file) case (REGRIDDING_ADAPTIVE) call init_coord_adapt(CS%adapt_CS, CS%nk, CS%coordinateResolution, GV%m_to_H, US%kg_m3_to_R) end select @@ -1962,9 +2418,14 @@ end subroutine initCoord !------------------------------------------------------------------------------ !> Set the fixed resolution data subroutine setCoordinateResolution( dz, CS, scale ) - real, dimension(:), intent(in) :: dz !< A vector of vertical grid spacings + real, dimension(:), intent(in) :: dz !< A vector of vertical grid spacings, in arbitrary coordinate + !! dependent units, such as [m] for a z-coordinate or [kg m-3] + !! for a density coordinate. type(regridding_CS), intent(inout) :: CS !< Regridding control structure - real, optional, intent(in) :: scale !< A scaling factor converting dz to coordRes + real, optional, intent(in) :: scale !< A scaling factor converting dz to the internal represetation + !! of coordRes, in various units that depend on the coordinate, + !! such as [Z m-1 ~> 1] for a z-coordinate or [R m3 kg-1 ~> 1] for + !! a density coordinate. if (size(dz)/=CS%nk) call MOM_error( FATAL, & 'setCoordinateResolution: inconsistent number of levels' ) @@ -1977,6 +2438,26 @@ subroutine setCoordinateResolution( dz, CS, scale ) end subroutine setCoordinateResolution +!> Set the 3d fixed resolution data +subroutine setCoordinateResolution_3d( dz_3d, CS, scale ) + real, dimension(:,:,:), intent(in) :: dz_3d !< A vector of vertical grid spacings, in arbitrary coordinate + !! dependent units, such as [m] for a z-coordinate or [kg m-3] + !! for a density coordinate. + type(regridding_CS), intent(inout) :: CS !< Regridding control structure + real, optional, intent(in) :: scale !< A scaling factor converting dz to coordRes [Z m-1 ~> 1] + + if (.not.allocated(CS%coordinateResolution_3d)) & + call MOM_error(FATAL,'setCoordinateResolution_3d: '//& + 'CS%coordinateResolution_3d not allocated.') + + if (present(scale)) then + CS%coordinateResolution_3d(:,:,:) = scale*dz_3d(:,:,:) + else + CS%coordinateResolution_3d(:,:,:) = dz_3d(:,:,:) + endif + +end subroutine setCoordinateResolution_3d + !> Set target densities based on the old Rlay variable subroutine set_target_densities_from_GV( GV, US, CS ) type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure @@ -2000,6 +2481,22 @@ subroutine set_target_densities_from_GV( GV, US, CS ) end subroutine set_target_densities_from_GV +!> Set target densities based on vector of interface values +subroutine set_target_densities_3d( CS, G, scale, rho_int_3d ) + type(regridding_CS), intent(inout) :: CS !< Regridding control structure + type(ocean_grid_type),intent(in) :: G !< Ocean grid structure + real, intent(in) :: scale !< A scaling factor converting densities [R m3 kg-1 ~> 1] + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(in) :: rho_int_3d !< Interface densities [kg m-3] + + if (.not.allocated(CS%target_density_3d)) & + call MOM_error(FATAL,'set_target_densities_3d: '//& + 'CS%target_density_3d not allocated.') + + CS%target_density_3d(:,:,:) = scale * rho_int_3d(:,:,:) + CS%target_density_set = .true. + +end subroutine set_target_densities_3d + !> Set target densities based on vector of interface values subroutine set_target_densities( CS, rho_int ) type(regridding_CS), intent(inout) :: CS !< Regridding control structure @@ -2017,10 +2514,12 @@ end subroutine set_target_densities !> Set maximum interface depths based on a vector of input values. subroutine set_regrid_max_depths( CS, max_depths, units_to_H ) type(regridding_CS), intent(inout) :: CS !< Regridding control structure - real, dimension(CS%nk+1), intent(in) :: max_depths !< Maximum interface depths, in arbitrary units - real, optional, intent(in) :: units_to_H !< A conversion factor for max_depths into H units + real, dimension(CS%nk+1), intent(in) :: max_depths !< Maximum interface depths, in arbitrary units, often [m] + real, optional, intent(in) :: units_to_H !< A conversion factor for max_depths into H units, + !! often in [H m-1 ~> 1 or kg m-3] ! Local variables - real :: val_to_H + real :: val_to_H ! A conversion factor from the units for max_depths into H units, often [H m-1 ~> 1 or kg m-3] + ! if units_to_H is present, or [nondim] if it is absent. integer :: K if (.not.allocated(CS%max_interface_depths)) allocate(CS%max_interface_depths(1:CS%nk+1)) @@ -2030,12 +2529,14 @@ subroutine set_regrid_max_depths( CS, max_depths, units_to_H ) ! Check for sign reversals in the depths. if (max_depths(CS%nk+1) < max_depths(1)) then - do K=1,CS%nk ; if (max_depths(K+1) > max_depths(K)) & - call MOM_error(FATAL, "Unordered list of maximum depths sent to set_regrid_max_depths!") + do K=1,CS%nk + if (max_depths(K+1) > max_depths(K)) & + call MOM_error(FATAL, "Unordered list of maximum depths sent to set_regrid_max_depths!") enddo else - do K=1,CS%nk ; if (max_depths(K+1) < max_depths(K)) & - call MOM_error(FATAL, "Unordered list of maximum depths sent to set_regrid_max_depths.") + do K=1,CS%nk + if (max_depths(K+1) < max_depths(K)) & + call MOM_error(FATAL, "Unordered list of maximum depths sent to set_regrid_max_depths.") enddo endif @@ -2047,19 +2548,19 @@ subroutine set_regrid_max_depths( CS, max_depths, units_to_H ) select case (CS%regridding_scheme) case (REGRIDDING_HYCOM1) call set_hycom_params(CS%hycom_CS, max_interface_depths=CS%max_interface_depths) - case (REGRIDDING_SLIGHT) - call set_slight_params(CS%slight_CS, max_interface_depths=CS%max_interface_depths) end select end subroutine set_regrid_max_depths !> Set maximum layer thicknesses based on a vector of input values. subroutine set_regrid_max_thickness( CS, max_h, units_to_H ) type(regridding_CS), intent(inout) :: CS !< Regridding control structure - real, dimension(CS%nk+1), intent(in) :: max_h !< Maximum interface depths, in arbitrary units - real, optional, intent(in) :: units_to_H !< A conversion factor for max_h into H units + real, dimension(CS%nk+1), intent(in) :: max_h !< Maximum layer thicknesses, in arbitrary units, often [m] + real, optional, intent(in) :: units_to_H !< A conversion factor for max_h into H units, + !! often [H m-1 ~> 1 or kg m-3] ! Local variables - real :: val_to_H - integer :: K + real :: val_to_H ! A conversion factor from the units for max_h into H units, often [H m-1 ~> 1 or kg m-3] + ! if units_to_H is present, or [nondim] if it is absent. + integer :: k if (.not.allocated(CS%max_layer_thickness)) allocate(CS%max_layer_thickness(1:CS%nk)) @@ -2073,19 +2574,100 @@ subroutine set_regrid_max_thickness( CS, max_h, units_to_H ) select case (CS%regridding_scheme) case (REGRIDDING_HYCOM1) call set_hycom_params(CS%hycom_CS, max_layer_thickness=CS%max_layer_thickness) - case (REGRIDDING_SLIGHT) - call set_slight_params(CS%slight_CS, max_layer_thickness=CS%max_layer_thickness) end select end subroutine set_regrid_max_thickness +!> Write the vertical coordinate information into a file. +!! This subroutine writes out a file containing any available data related +!! to the vertical grid used by the MOM ocean model when in ALE mode. +subroutine write_regrid_file( CS, GV, filepath ) + type(regridding_CS), intent(in) :: CS !< Regridding control structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + character(len=*), intent(in) :: filepath !< The full path to the file to write + + type(vardesc) :: vars(2) + type(MOM_field) :: fields(2) + type(MOM_netCDF_file) :: IO_handle ! The I/O handle of the fileset + real :: ds(GV%ke), dsi(GV%ke+1) ! The labeling layer and interface coordinates for output + ! in axes in files, in coordinate-dependent units that can + ! be obtained from getCoordinateUnits [various] + + if (CS%regridding_scheme == REGRIDDING_HYBGEN) then + call write_Hybgen_coord_file(GV, CS%hybgen_CS, filepath) + return + endif + + ds(:) = CS%coord_scale * CS%coordinateResolution(:) + dsi(1) = 0.5*ds(1) + dsi(2:GV%ke) = 0.5*( ds(1:GV%ke-1) + ds(2:GV%ke) ) + dsi(GV%ke+1) = 0.5*ds(GV%ke) + + vars(1) = var_desc('ds', getCoordinateUnits( CS ), & + 'Layer Coordinate Thickness', '1', 'L', '1') + vars(2) = var_desc('ds_interface', getCoordinateUnits( CS ), & + 'Layer Center Coordinate Separation', '1', 'i', '1') + + call create_MOM_file(IO_handle, trim(filepath), vars, 2, fields, & + SINGLE_FILE, GV=GV) + call MOM_write_field(IO_handle, fields(1), ds) + call MOM_write_field(IO_handle, fields(2), dsi) + call IO_handle%close() + +end subroutine write_regrid_file + +!> Set appropriate values for the negligible thicknesses used for remapping based on an answer date. +function set_h_neglect(GV, remap_answer_date, h_neglect_edge) result(h_neglect) + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + integer, intent(in) :: remap_answer_date !< The vintage of the expressions to use + !! for remapping. Values below 20190101 recover the + !! remapping answers from 2018. Higher values use more + !! robust forms of the same remapping algorithms. + real, intent(out) :: h_neglect_edge !< A negligibly small thickness used in + !! remapping edge value calculations [H ~> m or kg m-2] + real :: h_neglect !< A negligibly small thickness used in + !! remapping cell reconstructions [H ~> m or kg m-2] + + if (remap_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 +end function set_h_neglect + +!> Set appropriate values for the negligible vertical layer extents used for remapping based on an answer date. +function set_dz_neglect(GV, US, remap_answer_date, dz_neglect_edge) result(dz_neglect) + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: remap_answer_date !< The vintage of the expressions to use + !! for remapping. Values below 20190101 recover the + !! remapping answers from 2018. Higher values use more + !! robust forms of the same remapping algorithms. + real, intent(out) :: dz_neglect_edge !< A negligibly small vertical layer extent + !! used in remapping edge value calculations [Z ~> m] + real :: dz_neglect !< A negligibly small vertical layer extent + !! used in remapping cell reconstructions [Z ~> m] + + if (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 + else + dz_neglect = GV%kg_m2_to_H * (GV%H_to_m*US%m_to_Z) * 1.0e-30 + dz_neglect_edge = GV%kg_m2_to_H * (GV%H_to_m*US%m_to_Z) * 1.0e-10 + endif +end function set_dz_neglect + !------------------------------------------------------------------------------ !> Query the fixed resolution data function getCoordinateResolution( CS, undo_scaling ) type(regridding_CS), intent(in) :: CS !< Regridding control structure logical, optional, intent(in) :: undo_scaling !< If present and true, undo any internal !! rescaling of the resolution data. - real, dimension(CS%nk) :: getCoordinateResolution + real, dimension(CS%nk) :: getCoordinateResolution !< The resolution or delta of the target coordinate, + !! in units that depend on the coordinate [various] logical :: unscale unscale = .false. ; if (present(undo_scaling)) unscale = undo_scaling @@ -2103,7 +2685,8 @@ function getCoordinateInterfaces( CS, undo_scaling ) type(regridding_CS), intent(in) :: CS !< Regridding control structure logical, optional, intent(in) :: undo_scaling !< If present and true, undo any internal !! rescaling of the resolution data. - real, dimension(CS%nk+1) :: getCoordinateInterfaces !< Interface positions in target coordinate + real, dimension(CS%nk+1) :: getCoordinateInterfaces !< Interface positions in target coordinate, + !! in units that depend on the coordinate [various] integer :: k logical :: unscale @@ -2113,8 +2696,8 @@ function getCoordinateInterfaces( CS, undo_scaling ) ! densities, rather than computing the interfaces based on resolution if (CS%regridding_scheme == REGRIDDING_RHO) then if (.not. CS%target_density_set) & - call MOM_error(FATAL, 'MOM_regridding, getCoordinateInterfaces: '//& - 'target densities not set!') + call MOM_error(FATAL, 'MOM_regridding, getCoordinateInterfaces: '//& + 'target densities not set!') if (unscale) then getCoordinateInterfaces(:) = CS%coord_scale * CS%target_density(:) @@ -2149,7 +2732,8 @@ function getCoordinateUnits( CS ) character(len=20) :: getCoordinateUnits select case ( CS%regridding_scheme ) - case ( REGRIDDING_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE ) + case ( REGRIDDING_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, & + REGRIDDING_ADAPTIVE ) getCoordinateUnits = 'meter' case ( REGRIDDING_SIGMA_SHELF_ZSTAR ) getCoordinateUnits = 'meter/fraction' @@ -2187,8 +2771,8 @@ function getCoordinateShortName( CS ) getCoordinateShortName = 'coordinate' case ( REGRIDDING_HYCOM1 ) getCoordinateShortName = 'z-rho' - case ( REGRIDDING_SLIGHT ) - getCoordinateShortName = 's-rho' + case ( REGRIDDING_HYBGEN ) + getCoordinateShortName = 'hybrid' case ( REGRIDDING_ADAPTIVE ) getCoordinateShortName = 'adaptive' case default @@ -2200,39 +2784,31 @@ end function getCoordinateShortName !> Can be used to set any of the parameters for MOM_regridding. subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_grid_weight, & - interp_scheme, depth_of_time_filter_shallow, depth_of_time_filter_deep, & - compress_fraction, ref_pressure, dz_min_surface, nz_fixed_surface, Rho_ML_avg_depth, & - nlay_ML_to_interior, fix_haloclines, halocline_filt_len, & - halocline_strat_tol, integrate_downward_for_e, remap_answers_2018, & - adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha, adaptDoMin, adaptDrho0) + use_depth_based_time_filter, depth_of_time_filter_shallow, depth_of_time_filter_deep, & + interp_scheme, use_adjust_interface_motion, compress_fraction, ref_pressure, & + integrate_downward_for_e, remap_answers_2018, remap_answer_date, regrid_answer_date, & + adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, & + adaptAlpha, adaptDoMin, adaptDrho0) type(regridding_CS), intent(inout) :: CS !< Regridding control structure logical, optional, intent(in) :: boundary_extrapolation !< Extrapolate in boundary cells real, optional, intent(in) :: min_thickness !< Minimum thickness allowed when building the !! new grid [H ~> m or kg m-2] - real, optional, intent(in) :: old_grid_weight !< Weight given to old coordinate when time-filtering grid - character(len=*), optional, intent(in) :: interp_scheme !< Interpolation method for state-dependent coordinates + real, optional, intent(in) :: old_grid_weight !< Weight given to old coordinate when time-filtering grid [nondim] + logical, optional, intent(in) :: use_depth_based_time_filter !< Allow depth-based time filtering real, optional, intent(in) :: depth_of_time_filter_shallow !< Depth to start cubic [H ~> m or kg m-2] real, optional, intent(in) :: depth_of_time_filter_deep !< Depth to end cubic [H ~> m or kg m-2] + character(len=*), optional, intent(in) :: interp_scheme !< Interpolation method for state-dependent coordinates + logical, optional, intent(in) :: use_adjust_interface_motion !< Call adjust_interface_motion() real, optional, intent(in) :: compress_fraction !< Fraction of compressibility to add to potential density [nondim] real, optional, intent(in) :: ref_pressure !< The reference pressure for density-dependent !! coordinates [R L2 T-2 ~> Pa] - real, optional, intent(in) :: dz_min_surface !< The fixed resolution in the topmost - !! SLight_nkml_min layers [H ~> m or kg m-2] - integer, optional, intent(in) :: nz_fixed_surface !< The number of fixed-thickness layers at the top of the model - real, optional, intent(in) :: Rho_ml_avg_depth !< Averaging depth over which to determine mixed layer potential - !! density [H ~> m or kg m-2] - real, optional, intent(in) :: nlay_ML_to_interior !< Number of layers to offset the mixed layer density to find - !! resolved stratification [nondim] - logical, optional, intent(in) :: fix_haloclines !< Detect regions with much weaker stratification in the coordinate - real, optional, intent(in) :: halocline_filt_len !< Length scale over which to filter T & S when looking for - !! spuriously unstable water mass profiles [H ~> m or kg m-2] - real, optional, intent(in) :: halocline_strat_tol !< Value of the stratification ratio that defines a problematic - !! halocline region. logical, optional, intent(in) :: integrate_downward_for_e !< If true, integrate for interface positions downward !! from the top. logical, optional, intent(in) :: remap_answers_2018 !< If true, use the order of arithmetic and expressions !! that recover the remapping answers from 2018. Otherwise !! use more robust but mathematically equivalent expressions. + integer, optional, intent(in) :: remap_answer_date !< The vintage of the expressions to use for remapping + integer, optional, intent(in) :: regrid_answer_date !< The vintage of the expressions to use for regridding real, optional, intent(in) :: adaptTimeRatio !< Ratio of the ALE timestep to the grid timescale [nondim]. real, optional, intent(in) :: adaptZoom !< Depth of near-surface zooming region [H ~> m or kg m-2]. real, optional, intent(in) :: adaptZoomCoeff !< Coefficient of near-surface zooming diffusivity [nondim]. @@ -2246,24 +2822,38 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri if (present(interp_scheme)) call set_interp_scheme(CS%interp_CS, interp_scheme) if (present(boundary_extrapolation)) call set_interp_extrap(CS%interp_CS, boundary_extrapolation) + if (present(regrid_answer_date)) call set_interp_answer_date(CS%interp_CS, regrid_answer_date) if (present(old_grid_weight)) then if (old_grid_weight<0. .or. old_grid_weight>1.) & call MOM_error(FATAL,'MOM_regridding, set_regrid_params: Weight is out side the range 0..1!') CS%old_grid_weight = old_grid_weight endif - if (present(depth_of_time_filter_shallow)) CS%depth_of_time_filter_shallow = depth_of_time_filter_shallow - if (present(depth_of_time_filter_deep)) CS%depth_of_time_filter_deep = depth_of_time_filter_deep + if (present(use_depth_based_time_filter)) CS%use_depth_based_time_filter = & + use_depth_based_time_filter + if (present(depth_of_time_filter_shallow)) CS%depth_of_time_filter_shallow = & + depth_of_time_filter_shallow + if (present(depth_of_time_filter_deep)) CS%depth_of_time_filter_deep = & + depth_of_time_filter_deep if (present(depth_of_time_filter_shallow) .or. present(depth_of_time_filter_deep)) then - if (CS%depth_of_time_filter_deep Return coordinate-derived thicknesses for fixed coordinate systems function getStaticThickness( CS, SSH, depth ) type(regridding_CS), intent(in) :: CS !< Regridding control structure - real, intent(in) :: SSH !< The sea surface height, in the same units as depth + real, intent(in) :: SSH !< The sea surface height, in the same units as depth, often [Z ~> m] real, intent(in) :: depth !< The maximum depth of the grid, often [Z ~> m] - real, dimension(CS%nk) :: getStaticThickness !< The returned thicknesses in the units of depth + real, dimension(CS%nk) :: getStaticThickness !< The returned thicknesses in the units of + !! depth, often [Z ~> m] ! Local integer :: k - real :: z, dz + real :: z, dz ! Vertical positions and grid spacing [Z ~> m] select case ( CS%regridding_scheme ) - case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE ) + case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_HYCOM1, & + REGRIDDING_HYBGEN, REGRIDDING_ADAPTIVE ) if (depth>0.) then z = ssh do k = 1, CS%nk @@ -2379,10 +2964,13 @@ end function getStaticThickness subroutine dz_function1( string, dz ) character(len=*), intent(in) :: string !< String with list of parameters in form !! dz_min, H_total, power, precision - real, dimension(:), intent(inout) :: dz !< Profile of nominal thicknesses + real, dimension(:), intent(inout) :: dz !< Profile of nominal thicknesses [m] or other units ! Local variables integer :: nk, k - real :: dz_min, power, prec, H_total + real :: dz_min ! minimum grid spacing [m] or other units + real :: power ! A power to raise the relative position in index space [nondim] + real :: prec ! The precision with which positions are returned [m] or other units + real :: H_total ! The sum of the nominal thicknesses [m] or other units nk = size(dz) ! Number of cells prec = -1024. @@ -2403,6 +2991,29 @@ subroutine dz_function1( string, dz ) end subroutine dz_function1 +!> Construct the name of a parameter for a specific coordinate based on param_prefix and param_suffix. For the main, +!! prognostic coordinate this will simply return the parameter name (e.g. P_REF) +function create_coord_param(param_prefix, param_name, param_suffix) result(coord_param) + character(len=*) :: param_name !< The base name of the parameter (e.g. the one used for the main coordinate) + character(len=*) :: param_prefix !< String to prefix to parameter names. + character(len=*) :: param_suffix !< String to append to parameter names. + character(len=MAX_PARAM_LENGTH) :: coord_param !< Parameter name prepended by param_prefix + !! and appended with param_suffix + integer :: out_length + + if (len_trim(param_prefix) + len_trim(param_suffix) == 0) then + coord_param = param_name + else + ! Note the +2 is because of two underscores + out_length = len_trim(param_name)+len_trim(param_prefix)+len_trim(param_suffix)+2 + if (out_length > MAX_PARAM_LENGTH) then + call MOM_error(FATAL,"Coordinate parameter is too long; increase MAX_PARAM_LENGTH") + endif + coord_param = TRIM(param_prefix)//"_"//TRIM(param_name)//"_"//TRIM(param_suffix) + endif + +end function create_coord_param + !> Parses a string and generates a rho_target(:) profile with refined resolution downward !! and returns the number of levels integer function rho_function1( string, rho_target ) @@ -2411,7 +3022,14 @@ integer function rho_function1( string, rho_target ) real, dimension(:), allocatable, intent(inout) :: rho_target !< Profile of interface densities [kg m-3] ! Local variables integer :: nki, k, nk - real :: ddx, dx, rho_1, rho_2, rho_3, drho, rho_4, drho_min + real :: dx ! Fractional distance from interface nki [nondim] + real :: ddx ! Change in dx between interfaces [nondim] + real :: rho_1, rho_2 ! Density of the top two layers in a profile [kg m-3] + real :: rho_3 ! Density in the third layer, below which the density increase linearly + ! in subsequent layers [kg m-3] + real :: drho ! Change in density over the linear region [kg m-3] + real :: rho_4 ! The densest density in this profile [kg m-3], which might be very large. + real :: drho_min ! A minimal fractional density difference [nondim]? read( string, *) nk, rho_1, rho_2, rho_3, drho, rho_4, drho_min allocate(rho_target(nk+1)) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 1b3c5884de..d32b957717 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -1,27 +1,49 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Provides column-wise vertical remapping functions module MOM_remapping -! This file is part of MOM6. See LICENSE.md for the license. ! Original module written by Laurent White, 2008.06.09 use MOM_error_handler, only : MOM_error, FATAL use MOM_string_functions, only : uppercase +use numerical_testing_type, only : testing use regrid_edge_values, only : edge_values_explicit_h4, edge_values_implicit_h4 +use regrid_edge_values, only : edge_values_explicit_h4cw use regrid_edge_values, only : edge_values_implicit_h4, edge_values_implicit_h6 use regrid_edge_values, only : edge_slopes_implicit_h3, edge_slopes_implicit_h5 use PCM_functions, only : PCM_reconstruction use PLM_functions, only : PLM_reconstruction, PLM_boundary_extrapolation use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation +use PPM_functions, only : PPM_monotonicity use PQM_functions, only : PQM_reconstruction, PQM_boundary_extrapolation_v1 -use MOM_io, only : stdout, stderr +use MOM_hybgen_remap, only : hybgen_plm_coefs, hybgen_ppm_coefs, hybgen_weno_coefs + +use Recon1d_type, only : Recon1d +use Recon1d_PCM, only : PCM +use Recon1d_PLM_CW, only : PLM_CW +use Recon1d_PLM_hybgen, only : PLM_hybgen +use Recon1d_PLM_CWK, only : PLM_CWK +use Recon1d_MPLM_CWK, only : MPLM_CWK +use Recon1d_EMPLM_CWK, only : EMPLM_CWK +use Recon1d_MPLM_WA, only : MPLM_WA +use Recon1d_EMPLM_WA, only : EMPLM_WA +use Recon1d_MPLM_WA_poly, only : MPLM_WA_poly +use Recon1d_EMPLM_WA_poly, only : EMPLM_WA_poly +use Recon1d_PPM_CW, only : PPM_CW +use Recon1d_PPM_hybgen, only : PPM_hybgen +use Recon1d_PPM_CWK, only : PPM_CWK +use Recon1d_EPPM_CWK, only : EPPM_CWK +use Recon1d_PPM_H4_2019, only : PPM_H4_2019 +use Recon1d_PPM_H4_2018, only : PPM_H4_2018 +use Recon1d_PLM_WLS, only : PLM_WLS implicit none ; private -#include - !> Container for remapping parameters -type, public :: remapping_CS - private +type, public :: remapping_CS ; private !> Determines which reconstruction to use integer :: remapping_scheme = -911 !> Degree of polynomial reconstruction @@ -34,70 +56,108 @@ module MOM_remapping logical :: check_remapping = .false. !> If true, the intermediate values used in remapping are forced to be bounded. logical :: force_bounds_in_subcell = .false. - !> If true use older, less acccurate expressions. - logical :: answers_2018 = .true. + !> If true, impose bounds on the remapping from sub-cells to target grid + logical :: force_bounds_in_target = .true. + !> If true, impose bounds on the remapping from non-vanished sub-cells to target grid + logical :: better_force_bounds_in_target = .false. + !> If true, calculate and use an offset when summing sub-cells to the target grid + logical :: offset_tgt_summation = .false. + !> The vintage of the expressions to use for remapping. Values below 20190101 result + !! in the use of older, less accurate expressions. + integer :: answer_date = 99991231 + !> If true, use the OM4 version of the remapping algorithm that makes poor assumptions + !! about the reconstructions in top and bottom layers of the source grid + logical :: om4_remap_via_sub_cells = .false. + + !> A negligibly small width for the purpose of cell reconstructions in the same units + !! as the h0 argument to remapping_core_h [H] + real :: h_neglect + !> A negligibly small width for the purpose of edge value calculations in the same units + !! as the h0 argument to remapping_core_h [H] + real :: h_neglect_edge + + !> If true, do some debugging as operations proceed + logical :: debug = .false. + + !> The instance of the actual equation of state + class(Recon1d), pointer :: reconstruction => Null() end type ! The following routines are visible to the outside world public remapping_core_h, remapping_core_w public initialize_remapping, end_remapping, remapping_set_param, extract_member_remapping_CS public remapping_unit_tests, build_reconstructions_1d, average_value_ppoly -public dzFromH1H2 +public interpolate_column, reintegrate_column, dzFromH1H2 ! The following are private parameter constants integer, parameter :: REMAPPING_PCM = 0 !< O(h^1) remapping scheme -integer, parameter :: REMAPPING_PLM = 1 !< O(h^2) remapping scheme -integer, parameter :: REMAPPING_PPM_H4 = 2 !< O(h^3) remapping scheme -integer, parameter :: REMAPPING_PPM_IH4 = 3 !< O(h^3) remapping scheme -integer, parameter :: REMAPPING_PQM_IH4IH3 = 4 !< O(h^4) remapping scheme -integer, parameter :: REMAPPING_PQM_IH6IH5 = 5 !< O(h^5) remapping scheme +integer, parameter :: REMAPPING_PLM = 2 !< O(h^2) remapping scheme +integer, parameter :: REMAPPING_PLM_HYBGEN = 3 !< O(h^2) remapping scheme +integer, parameter :: REMAPPING_PPM_CW =10 !< O(h^3) remapping scheme +integer, parameter :: REMAPPING_PPM_H4 = 4 !< O(h^3) remapping scheme +integer, parameter :: REMAPPING_PPM_IH4 = 5 !< O(h^3) remapping scheme +integer, parameter :: REMAPPING_PPM_HYBGEN = 6 !< O(h^3) remapping scheme +integer, parameter :: REMAPPING_WENO_HYBGEN= 7 !< O(h^3) remapping scheme +integer, parameter :: REMAPPING_PQM_IH4IH3 = 8 !< O(h^4) remapping scheme +integer, parameter :: REMAPPING_PQM_IH6IH5 = 9 !< O(h^5) remapping scheme +integer, parameter :: REMAPPING_VIA_CLASS =99 !< Scheme is controlled by Recon1d class integer, parameter :: INTEGRATION_PCM = 0 !< Piecewise Constant Method integer, parameter :: INTEGRATION_PLM = 1 !< Piecewise Linear Method integer, parameter :: INTEGRATION_PPM = 3 !< Piecewise Parabolic Method integer, parameter :: INTEGRATION_PQM = 5 !< Piecewise Quartic Method -character(len=40) :: mdl = "MOM_remapping" !< This module's name. - !> Documentation for external callers -character(len=256), public :: remappingSchemesDoc = & +character(len=360), public :: remappingSchemesDoc = & "PCM (1st-order accurate)\n"//& "PLM (2nd-order accurate)\n"//& + "PLM_HYBGEN (2nd-order accurate)\n"//& "PPM_H4 (3rd-order accurate)\n"//& "PPM_IH4 (3rd-order accurate)\n"//& + "PPM_HYBGEN (3rd-order accurate)\n"//& + "WENO_HYBGEN (3rd-order accurate)\n"//& "PQM_IH4IH3 (4th-order accurate)\n"//& "PQM_IH6IH5 (5th-order accurate)\n" character(len=3), public :: remappingDefaultScheme = "PLM" !< Default remapping method -! This CPP macro turns on/off bounding of integrations limits so that they are -! always within the cell. Roundoff can lead to the non-dimensional bounds being -! 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. - -logical, parameter :: old_algorithm = .false. !< Use the old "broken" algorithm. - !! This is a temporary measure to assist - !! debugging until we delete the old algorithm. - contains !> Set parameters within remapping object subroutine remapping_set_param(CS, remapping_scheme, boundary_extrapolation, & - check_reconstruction, check_remapping, force_bounds_in_subcell, answers_2018) + check_reconstruction, check_remapping, force_bounds_in_subcell, & + force_bounds_in_target, better_force_bounds_in_target, offset_tgt_summation, & + om4_remap_via_sub_cells, answers_2018, answer_date, nk, & + h_neglect, h_neglect_edge) type(remapping_CS), intent(inout) :: CS !< Remapping control structure character(len=*), optional, intent(in) :: remapping_scheme !< Remapping scheme to use logical, optional, intent(in) :: boundary_extrapolation !< Indicate to extrapolate in boundary cells logical, optional, intent(in) :: check_reconstruction !< Indicate to check reconstructions logical, optional, intent(in) :: check_remapping !< Indicate to check results of remapping logical, optional, intent(in) :: force_bounds_in_subcell !< Force subcells values to be bounded - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + logical, optional, intent(in) :: force_bounds_in_target !< Force target values to be bounded + logical, optional, intent(in) :: better_force_bounds_in_target !< Force target values to be bounded + logical, optional, intent(in) :: offset_tgt_summation !< Use an offset when summing sub-cells + 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] + integer, optional, intent(in) :: nk !< Number of levels to initialize reconstruction class with if (present(remapping_scheme)) then call setReconstructionType( remapping_scheme, CS ) + if (index(trim(remapping_scheme),'C_')>0) then + if (present(nk)) then + call CS%reconstruction%init(nk, h_neglect=h_neglect) + else + call MOM_error( FATAL, 'MOM_remapping, remapping_set_param: '//& + 'Using the Recon1d class for remapping requires nk to be passed' ) + endif + endif endif if (present(boundary_extrapolation)) then CS%boundary_extrapolation = boundary_extrapolation @@ -111,13 +171,40 @@ subroutine remapping_set_param(CS, remapping_scheme, boundary_extrapolation, & if (present(force_bounds_in_subcell)) then CS%force_bounds_in_subcell = force_bounds_in_subcell endif + if (present(force_bounds_in_target)) then + CS%force_bounds_in_target = force_bounds_in_target + endif + if (present(better_force_bounds_in_target)) then + CS%better_force_bounds_in_target = better_force_bounds_in_target + endif + if (present(offset_tgt_summation)) then + CS%offset_tgt_summation = offset_tgt_summation + endif + if (present(om4_remap_via_sub_cells)) then + CS%om4_remap_via_sub_cells = om4_remap_via_sub_cells + endif if (present(answers_2018)) then - CS%answers_2018 = answers_2018 + if (answers_2018) then + CS%answer_date = 20181231 + else + CS%answer_date = 20190101 + endif + endif + 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 subroutine extract_member_remapping_CS(CS, remapping_scheme, degree, boundary_extrapolation, check_reconstruction, & - check_remapping, force_bounds_in_subcell) + check_remapping, force_bounds_in_subcell, force_bounds_in_target, & + better_force_bounds_in_target, offset_tgt_summation) type(remapping_CS), intent(in) :: CS !< Control structure for remapping module integer, optional, intent(out) :: remapping_scheme !< Determines which reconstruction scheme to use integer, optional, intent(out) :: degree !< Degree of polynomial reconstruction @@ -127,6 +214,9 @@ subroutine extract_member_remapping_CS(CS, remapping_scheme, degree, boundary_ex !! for conservation and bounds. logical, optional, intent(out) :: force_bounds_in_subcell !< If true, the intermediate values used in !! remapping are forced to be bounded. + logical, optional, intent(out) :: force_bounds_in_target !< Force target values to be bounded + logical, optional, intent(out) :: better_force_bounds_in_target !< Force target values to be bounded + logical, optional, intent(out) :: offset_tgt_summation !< Use an offset when summing sub-cells if (present(remapping_scheme)) remapping_scheme = CS%remapping_scheme if (present(degree)) degree = CS%degree @@ -134,168 +224,157 @@ subroutine extract_member_remapping_CS(CS, remapping_scheme, degree, boundary_ex if (present(check_reconstruction)) check_reconstruction = CS%check_reconstruction if (present(check_remapping)) check_remapping = CS%check_remapping if (present(force_bounds_in_subcell)) force_bounds_in_subcell = CS%force_bounds_in_subcell + if (present(force_bounds_in_target)) force_bounds_in_target = CS%force_bounds_in_target + if (present(better_force_bounds_in_target)) better_force_bounds_in_target = CS%better_force_bounds_in_target + if (present(offset_tgt_summation)) offset_tgt_summation = CS%offset_tgt_summation end subroutine extract_member_remapping_CS -!> Calculate edge coordinate x from cell width h -subroutine buildGridFromH(nz, h, x) - integer, intent(in) :: nz !< Number of cells - real, dimension(nz), intent(in) :: h !< Cell widths - real, dimension(nz+1), intent(inout) :: x !< Edge coordiantes starting at x(1)=0 - ! Local variables - integer :: k - - x(1) = 0.0 - do k = 1,nz - x(k+1) = x(k) + h(k) - enddo - -end subroutine buildGridFromH - -!> Compare two summation estimates of positive data and judge if due to more -!! than round-off. -!! When two sums are calculated from different vectors that should add up to -!! the same value, the results can differ by round off. The round off error -!! can be bounded to be proportional to the number of operations. -!! This function returns true if the difference between sum1 and sum2 is -!! larger than than the estimated round off bound. -!! \note This estimate/function is only valid for summation of positive data. -function isPosSumErrSignificant(n1, sum1, n2, sum2) - integer, intent(in) :: n1 !< Number of values in sum1 - integer, intent(in) :: n2 !< Number of values in sum2 - real, intent(in) :: sum1 !< Sum of n1 values - real, intent(in) :: sum2 !< Sum of n2 values - logical :: isPosSumErrSignificant !< True if difference in sums is large - ! Local variables - real :: sumErr, allowedErr, eps - - if (sum1<0.) call MOM_error(FATAL,'isPosSumErrSignificant: sum1<0 is not allowed!') - if (sum2<0.) call MOM_error(FATAL,'isPosSumErrSignificant: sum2<0 is not allowed!') - sumErr = abs(sum1-sum2) - eps = epsilon(sum1) - allowedErr = eps*0.5*(real(n1-1)*sum1+real(n2-1)*sum2) - if (sumErr>allowedErr) then - write(0,*) 'isPosSumErrSignificant: sum1,sum2=',sum1,sum2 - write(0,*) 'isPosSumErrSignificant: eps=',eps - write(0,*) 'isPosSumErrSignificant: err,n*eps=',sumErr,allowedErr - write(0,*) 'isPosSumErrSignificant: err/eps,n1,n2,n1+n2=',sumErr/eps,n1,n2,n1+n2 - isPosSumErrSignificant = .true. - else - isPosSumErrSignificant = .false. - endif -end function isPosSumErrSignificant -!> Remaps column of values u0 on grid h0 to grid h1 assuming the top edge is aligned. -subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edge) +!> Remaps column of values u0 on grid h0 to grid h1 assuming the top edge is aligned and using the OM4 +!! reconstruction methods +!! +!! \todo Remove h_neglect argument by moving into remapping_CS +!! \todo Remove PCM_cell argument by adding new method in Recon1D class +subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, net_err, PCM_cell) type(remapping_CS), intent(in) :: CS !< Remapping control structure integer, intent(in) :: n0 !< Number of cells on source grid - real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid - real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid + real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid [H] + real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid [A] integer, intent(in) :: n1 !< Number of cells on target grid - real, dimension(n1), intent(in) :: h1 !< Cell widths on target grid - real, dimension(n1), intent(out) :: u1 !< Cell averages on target grid - real, optional, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h0. - real, optional, intent(in) :: h_neglect_edge !< A negligibly small width - !! for the purpose of edge value - !! calculations in the same units as h0. + 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(out) :: net_err !< Error in total column [A H] + logical, dimension(n0), optional, intent(in) :: PCM_cell !< If present, use PCM remapping for + !! cells in the source grid where this is true. ! Local variables - integer :: iMethod - real, dimension(n0,2) :: ppoly_r_E !Edge value of polynomial - real, dimension(n0,2) :: ppoly_r_S !Edge slope of polynomial - real, dimension(n0,CS%degree+1) :: ppoly_r_coefs !Coefficients of polynomial - integer :: k - real :: eps, h0tot, h0err, h1tot, h1err, u0tot, u0err, u0min, u0max, u1tot, u1err, u1min, u1max, uh_err - real :: hNeglect, hNeglect_edge + real, dimension(n0+n1+1) :: h_sub ! Width of each each sub-cell [H] + real, dimension(n0+n1+1) :: uh_sub ! Integral of u*h over each sub-cell [A H] + real, dimension(n0+n1+1) :: u_sub ! Average of u over each sub-cell [A] + integer, dimension(n0+n1+1) :: isub_src ! Index of source cell for each sub-cell + integer, dimension(n0) :: isrc_start ! Index of first sub-cell within each source cell + integer, dimension(n0) :: isrc_end ! Index of last sub-cell within each source cell + integer, dimension(n0) :: isrc_max ! Index of thickest sub-cell within each source cell + real, dimension(n0) :: h0_eff ! Effective thickness of source cells [H] + integer, dimension(n1) :: itgt_start ! Index of first sub-cell within each target cell + integer, dimension(n1) :: itgt_end ! Index of last sub-cell within each target cell + ! For error checking/debugging + real :: u02_err ! Integrated reconstruction error estimates [H A] + real, dimension(n0,2) :: ppoly_r_E ! Edge value of polynomial [A] + real, dimension(n0,2) :: ppoly_r_S ! Edge slope of polynomial [A H-1] + real, dimension(n0,CS%degree+1) :: ppoly_r_coefs ! Coefficients of polynomial reconstructions [A] + real :: uh_err ! A bound on the error in the sum of u*h, as estimated by the remapping code [A H] + 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 + ! Calculate sub-layer thicknesses and indices connecting sub-layers to source and target grids + ! Sets: h_sub, h0_eff, isrc_start, isrc_end, isrc_max, isub_src, itgt_start, itgt_end + call intersect_src_tgt_grids(n0, h0, n1, h1, h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src) - call build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, ppoly_r_E, ppoly_r_S, iMethod, & - hNeglect, hNeglect_edge ) + if (CS%remapping_scheme == REMAPPING_VIA_CLASS) then + +! if (CS%debug) call CS%reconstruction%set_debug() ! Sets an internal flag + + call CS%reconstruction%reconstruct(h0, u0) + + ! Adjust h_sub so that the Hallberg conservation trick works properly +! call adjust_h_sub( n0, h0, n1, isrc_start, isrc_end, isrc_max, h_sub ) + + ! Loop over each sub-cell to calculate average/integral values within each sub-cell. + ! Uses: h_sub, isrc_start, isrc_end, isrc_max, isub_src + ! Sets: u_sub, uh_sub + call CS%reconstruction%remap_to_sub_grid(h0, u0, n1, h_sub, & + isrc_start, isrc_end, isrc_max, isub_src, & + u_sub, uh_sub, u02_err) + + ! Loop over each target cell summing the integrals from sub-cells within the target cell. + ! Uses: itgt_start, itgt_end, h1, h_sub, uh_sub, u_sub + ! Sets: u1, uh_err + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + CS%force_bounds_in_target, CS%offset_tgt_summation, & + CS%better_force_bounds_in_target, u1, uh_err) + + ! Include the error remapping from source to sub-cells in the estimate of total remapping error + uh_err = uh_err + u02_err + + else ! Uses the OM4-era reconstruction functions + + call build_reconstructions_1d(CS, n0, h0, u0, ppoly_r_coefs, ppoly_r_E, ppoly_r_S, iMethod, & + CS%h_neglect, CS%h_neglect_edge, PCM_cell, debug=CS%debug) + + if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & + CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E) + + ! Loop over each sub-cell to calculate average/integral values within each sub-cell. + ! Uses: h_sub, h0_eff, isub_src + ! Sets: u_sub, uh_sub + if (CS%om4_remap_via_sub_cells) then ! Uses the version from OM4 with a bug at the bottom + + call remap_src_to_sub_grid_om4(n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h_sub, & + h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + iMethod, CS%force_bounds_in_subcell, u_sub, uh_sub, u02_err) + + else ! i.e. if (CS%om4_remap_via_sub_cells == .false.) + + call remap_src_to_sub_grid(n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h_sub, & + isrc_start, isrc_end, isrc_max, isub_src, & + iMethod, CS%force_bounds_in_subcell, u_sub, uh_sub, u02_err) - if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & - CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E, ppoly_r_S) - - - call remap_via_sub_cells( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h1, iMethod, & - CS%force_bounds_in_subcell, u1, uh_err ) - - if (CS%check_remapping) then - ! Check errors and bounds - call measure_input_bounds( n0, h0, u0, ppoly_r_E, h0tot, h0err, u0tot, u0err, u0min, u0max ) - call measure_output_bounds( n1, h1, u1, h1tot, h1err, u1tot, u1err, u1min, u1max ) - if (iMethod<5) then ! We except PQM until we've debugged it - if ( (abs(u1tot-u0tot)>(u0err+u1err)+uh_err .and. abs(h1tot-h0tot)u0max) ) then - write(0,*) 'iMethod = ',iMethod - write(0,*) 'H: h0tot=',h0tot,'h1tot=',h1tot,'dh=',h1tot-h0tot,'h0err=',h0err,'h1err=',h1err - if (abs(h1tot-h0tot)>h0err+h1err) & - write(0,*) 'H non-conservation difference=',h1tot-h0tot,'allowed err=',h0err+h1err,' <-----!' - write(0,*) 'UH: u0tot=',u0tot,'u1tot=',u1tot,'duh=',u1tot-u0tot,'u0err=',u0err,'u1err=',u1err,'uh_err=',uh_err - if (abs(u1tot-u0tot)>(u0err+u1err)+uh_err) & - write(0,*) 'U non-conservation difference=',u1tot-u0tot,'allowed err=',u0err+u1err+uh_err,' <-----!' - write(0,*) 'U: u0min=',u0min,'u1min=',u1min - if (u1minn0) then - write(0,'(i3,96x,1p2e24.16)') k,h1(k),u1(k) - else - write(0,'(i3,1p4e24.16)') k,h0(k),ppoly_r_E(k,1),u0(k),ppoly_r_E(k,2) - endif - enddo - write(0,'(a3,2a24)') 'k','u0','Polynomial coefficients' - do k = 1, n0 - write(0,'(i3,1p6e24.16)') k,u0(k),ppoly_r_coefs(k,:) - enddo - call MOM_error( FATAL, 'MOM_remapping, remapping_core_h: '//& - 'Remapping result is inconsistent!' ) endif - endif ! method<5 + + ! Loop over each target cell summing the integrals from sub-cells within the target cell. + ! Uses: itgt_start, itgt_end, h1, h_sub, uh_sub, u_sub + ! Sets: u1, uh_err + call remap_sub_to_tgt_grid_om4(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + CS%force_bounds_in_target, u1, uh_err) + ! Include the error remapping from source to sub-cells in the estimate of total remapping error + uh_err = uh_err + u02_err + + if (CS%check_remapping) call check_remapped_values(n0, h0, u0, ppoly_r_E, CS%degree, ppoly_r_coefs, & + n1, h1, u1, iMethod, uh_err, "remapping_core_h") + endif + if (present(net_err)) net_err = uh_err + end subroutine remapping_core_h !> Remaps column of values u0 on grid h0 to implied grid h1 !! where the interfaces of h1 differ from those of h0 by dx. -subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_edge ) - 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 - real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid - integer, intent(in) :: n1 !< Number of cells on target grid - real, dimension(n1+1), intent(in) :: dx !< Cell widths on target grid - real, dimension(n1), intent(out) :: u1 !< Cell averages on target grid - real, optional, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h0. - real, optional, intent(in) :: h_neglect_edge !< A negligibly small width - !! for the purpose of edge value - !! calculations in the same units as h0. +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] + real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid [A] + 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] + ! Local variables - integer :: iMethod - real, dimension(n0,2) :: ppoly_r_E !Edge value of polynomial - real, dimension(n0,2) :: ppoly_r_S !Edge slope of polynomial - real, dimension(n0,CS%degree+1) :: ppoly_r_coefs !Coefficients of polynomial + real, dimension(n0+n1+1) :: h_sub ! Width of each each sub-cell [H] + real, dimension(n0+n1+1) :: uh_sub ! Integral of u*h over each sub-cell [A H] + real, dimension(n0+n1+1) :: u_sub ! Average of u over each sub-cell [A] + integer, dimension(n0+n1+1) :: isub_src ! Index of source cell for each sub-cell + integer, dimension(n0) :: isrc_start ! Index of first sub-cell within each source cell + integer, dimension(n0) :: isrc_end ! Index of last sub-cell within each source cell + integer, dimension(n0) :: isrc_max ! Index of thickest sub-cell within each source cell + real, dimension(n0) :: h0_eff ! Effective thickness of source cells [H] + integer, dimension(n1) :: itgt_start ! Index of first sub-cell within each target cell + integer, dimension(n1) :: itgt_end ! Index of last sub-cell within each target cell + ! For error checking/debugging + real :: u02_err ! Integrated reconstruction error estimates [H A] + real, dimension(n0,2) :: ppoly_r_E ! Edge value of polynomial [A] + real, dimension(n0,2) :: ppoly_r_S ! Edge slope of polynomial [A H-1] + real, dimension(n0,CS%degree+1) :: ppoly_r_coefs ! Coefficients of polynomial reconstructions [A] + real, dimension(n1) :: h1 !< Cell widths on target grid [H] + real :: uh_err ! A bound on the error in the sum of u*h, as estimated by the remapping code [A H] + integer :: iMethod ! An integer indicating the integration method used integer :: k - real :: eps, h0tot, h0err, h1tot, h1err - real :: u0tot, u0err, u0min, u0max, u1tot, u1err, u1min, u1max, uh_err - real, dimension(n1) :: h1 !< Cell widths on target grid - real :: hNeglect, hNeglect_edge - - hNeglect = 1.0e-30 ; if (present(h_neglect)) hNeglect = h_neglect - hNeglect_edge = 1.0e-10 ; if (present(h_neglect_edge)) hNeglect_edge = h_neglect_edge call build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, ppoly_r_E, ppoly_r_S, iMethod,& - hNeglect, hNeglect_edge ) + CS%h_neglect, CS%h_neglect_edge ) if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & - CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E, ppoly_r_S) + CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E) ! This is a temporary step prior to switching to remapping_core_h() do k = 1, n1 @@ -305,74 +384,65 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_ed h1(k) = max( 0., dx(k+1) - dx(k) ) endif enddo - call remap_via_sub_cells( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h1, iMethod, & - CS%force_bounds_in_subcell,u1, uh_err ) -! call remapByDeltaZ( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, dx, iMethod, u1, hNeglect ) -! call remapByProjection( n0, h0, u0, CS%ppoly_r, n1, h1, iMethod, u1, hNeglect ) - - if (CS%check_remapping) then - ! Check errors and bounds - call measure_input_bounds( n0, h0, u0, ppoly_r_E, h0tot, h0err, u0tot, u0err, u0min, u0max ) - call measure_output_bounds( n1, h1, u1, h1tot, h1err, u1tot, u1err, u1min, u1max ) - if (iMethod<5) then ! We except PQM until we've debugged it - if ( (abs(u1tot-u0tot)>(u0err+u1err)+uh_err .and. abs(h1tot-h0tot)u0max) ) then - write(0,*) 'iMethod = ',iMethod - write(0,*) 'H: h0tot=',h0tot,'h1tot=',h1tot,'dh=',h1tot-h0tot,'h0err=',h0err,'h1err=',h1err - if (abs(h1tot-h0tot)>h0err+h1err) & - write(0,*) 'H non-conservation difference=',h1tot-h0tot,'allowed err=',h0err+h1err,' <-----!' - write(0,*) 'UH: u0tot=',u0tot,'u1tot=',u1tot,'duh=',u1tot-u0tot,'u0err=',u0err,'u1err=',u1err,'uh_err=',uh_err - if (abs(u1tot-u0tot)>(u0err+u1err)+uh_err) & - write(0,*) 'U non-conservation difference=',u1tot-u0tot,'allowed err=',u0err+u1err+uh_err,' <-----!' - write(0,*) 'U: u0min=',u0min,'u1min=',u1min - if (u1minn0) then - write(0,'(i3,96x,1p2e24.16)') k,h1(k),u1(k) - else - write(0,'(i3,1p4e24.16)') k,h0(k),ppoly_r_E(k,1),u0(k),ppoly_r_E(k,2) - endif - enddo - write(0,'(a3,2a24)') 'k','u0','Polynomial coefficients' - do k = 1, n0 - write(0,'(i3,1p6e24.16)') k,u0(k),ppoly_r_coefs(k,:) - enddo - call MOM_error( FATAL, 'MOM_remapping, remapping_core_w: '//& - 'Remapping result is inconsistent!' ) - endif - endif ! method<5 - endif + + ! Calculate sub-layer thicknesses and indices connecting sub-layers to source and target grids + call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + + ! Loop over each sub-cell to calculate average/integral values within each sub-cell. + ! Uses: h_sub, h0_eff, isub_src + ! Sets: u_sub, uh_sub + call remap_src_to_sub_grid_om4(n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h_sub, & + h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + iMethod, CS%force_bounds_in_subcell, u_sub, uh_sub, u02_err) + + ! Loop over each target cell summing the integrals from sub-cells within the target cell. + ! Uses: itgt_start, itgt_end, h1, h_sub, uh_sub, u_sub + ! Sets: u1, uh_err + call remap_sub_to_tgt_grid_om4(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + CS%force_bounds_in_target, u1, uh_err) + + ! Include the error remapping from source to sub-cells in the estimate of total remapping error + uh_err = uh_err + u02_err + + if (CS%check_remapping) call check_remapped_values(n0, h0, u0, ppoly_r_E, CS%degree, ppoly_r_coefs, & + n1, h1, u1, iMethod, uh_err, "remapping_core_w") end subroutine remapping_core_w !> Creates polynomial reconstructions of u0 on the source grid h0. subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & ppoly_r_E, ppoly_r_S, iMethod, h_neglect, & - h_neglect_edge ) + h_neglect_edge, PCM_cell, debug ) 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 - real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid + real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid [H] + real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid [A] real, dimension(n0,CS%degree+1), & - intent(out) :: ppoly_r_coefs !< Coefficients of polynomial - real, dimension(n0,2), intent(out) :: ppoly_r_E !< Edge value of polynomial - real, dimension(n0,2), intent(out) :: ppoly_r_S !< Edge slope of polynomial + intent(out) :: ppoly_r_coefs !< Coefficients of polynomial [A] + 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. - real, optional, intent(in) :: h_neglect_edge !< A negligibly small width - !! for the purpose of edge value - !! calculations in the same units as h0. + !! 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. + logical, optional, intent(in) :: debug !< If true, enable debugging + ! 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 :: remapping_scheme !< Remapping scheme - logical :: boundary_extrapolation !< Extrapolate at boundaries if true + integer :: k, n + logical :: deb ! Do debugging + + deb = .false. ; if (present(debug)) deb = debug + + h_neg_edge = h_neglect ; if (present(h_neglect_edge)) h_neg_edge = h_neglect_edge ! Reset polynomial ppoly_r_E(:,:) = 0.0 @@ -385,7 +455,7 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & local_remapping_scheme = REMAPPING_PCM elseif (n0<=3) then local_remapping_scheme = min( local_remapping_scheme, REMAPPING_PLM ) - elseif (n0<=4) then + elseif (n0<=4 .and. local_remapping_scheme /= REMAPPING_PPM_CW ) then local_remapping_scheme = min( local_remapping_scheme, REMAPPING_PPM_H4 ) endif select case ( local_remapping_scheme ) @@ -398,62 +468,105 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & call PLM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect) endif iMethod = INTEGRATION_PLM + case ( REMAPPING_PLM_HYBGEN ) + call hybgen_PLM_coefs(u0, h0, ppoly_r_coefs(:,2), n0, 1, h_neglect) + do k=1,n0 + ppoly_r_E(k,1) = u0(k) - 0.5 * ppoly_r_coefs(k,2) ! Left edge value of cell k + ppoly_r_E(k,2) = u0(k) + 0.5 * ppoly_r_coefs(k,2) ! Right edge value of cell k + ppoly_r_coefs(k,1) = ppoly_r_E(k,1) + enddo + if ( CS%boundary_extrapolation ) & + call PLM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) + iMethod = INTEGRATION_PLM + case ( REMAPPING_PPM_CW ) + ! identical to REMAPPING_PPM_HYBGEN + 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 + call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) + endif + iMethod = INTEGRATION_PPM case ( REMAPPING_PPM_H4 ) - call edge_values_explicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge, answers_2018=CS%answers_2018 ) - call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answers_2018=CS%answers_2018 ) + 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, answers_2018=CS%answers_2018 ) - call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answers_2018=CS%answers_2018 ) + 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 ) endif iMethod = INTEGRATION_PPM + case ( REMAPPING_PPM_HYBGEN ) + call hybgen_PPM_coefs(u0, h0, ppoly_r_E, n0, 1, h_neglect) + call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answer_date=99991231 ) + if ( CS%boundary_extrapolation ) & + call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) + iMethod = INTEGRATION_PPM + case ( REMAPPING_WENO_HYBGEN ) + call hybgen_weno_coefs(u0, h0, ppoly_r_E, n0, 1, h_neglect) + call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answer_date=99991231 ) + if ( CS%boundary_extrapolation ) & + 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, answers_2018=CS%answers_2018 ) - call edge_slopes_implicit_h3( n0, h0, u0, ppoly_r_S, h_neglect, answers_2018=CS%answers_2018 ) + 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, & - answers_2018=CS%answers_2018 ) + answer_date=CS%answer_date ) if ( CS%boundary_extrapolation ) then call PQM_boundary_extrapolation_v1( n0, h0, u0, ppoly_r_E, ppoly_r_S, & ppoly_r_coefs, h_neglect ) endif iMethod = INTEGRATION_PQM case ( REMAPPING_PQM_IH6IH5 ) - call edge_values_implicit_h6( n0, h0, u0, ppoly_r_E, h_neglect_edge, answers_2018=CS%answers_2018 ) - call edge_slopes_implicit_h5( n0, h0, u0, ppoly_r_S, h_neglect, answers_2018=CS%answers_2018 ) + 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, & - answers_2018=CS%answers_2018 ) + answer_date=CS%answer_date ) if ( CS%boundary_extrapolation ) then call PQM_boundary_extrapolation_v1( n0, h0, u0, ppoly_r_E, ppoly_r_S, & ppoly_r_coefs, h_neglect ) endif iMethod = INTEGRATION_PQM + case ( REMAPPING_VIA_CLASS ) + call MOM_error( FATAL, 'MOM_remapping, build_reconstructions_1d: '//& + 'Should not reach this point if using Recon1d class for remapping' ) case default call MOM_error( FATAL, 'MOM_remapping, build_reconstructions_1d: '//& 'The selected remapping method is invalid' ) end select + if (present(PCM_cell)) then + ! Change the coefficients to those for the piecewise constant method in indicated cells. + do k=1,n0 ; if (PCM_cell(k)) then + ppoly_r_coefs(k,1) = u0(k) + ppoly_r_E(k,1:2) = u0(k) + ppoly_r_S(k,1:2) = 0.0 + do n=2,CS%degree+1 ; ppoly_r_coefs(k,n) = 0.0 ; enddo + endif ; enddo + endif + end subroutine build_reconstructions_1d !> Checks that edge values and reconstructions satisfy bounds subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, & - ppoly_r_coefs, ppoly_r_E, ppoly_r_S) + ppoly_r_coefs, ppoly_r_E) integer, intent(in) :: n0 !< Number of cells on source grid - real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid - real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid + real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid [H] + real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid [A] integer, intent(in) :: deg !< Degree of polynomial reconstruction logical, intent(in) :: boundary_extrapolation !< Extrapolate at boundaries if true - real, dimension(n0,deg+1),intent(out) :: ppoly_r_coefs !< Coefficients of polynomial - real, dimension(n0,2), intent(out) :: ppoly_r_E !< Edge value of polynomial - real, dimension(n0,2), intent(out) :: ppoly_r_S !< Edge slope of polynomial + real, dimension(n0,deg+1),intent(in) :: ppoly_r_coefs !< Coefficients of polynomial [A] + real, dimension(n0,2), intent(in) :: ppoly_r_E !< Edge value of polynomial [A] ! Local variables integer :: i0, n - real :: u_l, u_c, u_r ! Cell averages - real :: u_min, u_max + real :: u_l, u_c, u_r ! Cell averages [A] + real :: u_min, u_max ! Cell extrema [A] logical :: problem_detected problem_detected = .false. @@ -465,13 +578,13 @@ subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, & u_min = min(u_l, u_c) u_max = max(u_l, u_c) if (ppoly_r_E(i0,1) < u_min) then - write(0,'(a,i4,5(x,a,1pe24.16))') 'Left edge undershoot at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & - 'edge=',ppoly_r_E(i0,1),'err=',ppoly_r_E(i0,1)-u_min + write(0,'(a,I0,5(1x,a,1pe24.16))') 'Left edge undershoot at ',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & + 'edge=',ppoly_r_E(i0,1),'err=',ppoly_r_E(i0,1)-u_min problem_detected = .true. endif if (ppoly_r_E(i0,1) > u_max) then - write(0,'(a,i4,5(x,a,1pe24.16))') 'Left edge overshoot at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & - 'edge=',ppoly_r_E(i0,1),'err=',ppoly_r_E(i0,1)-u_max + write(0,'(a,I0,5(1x,a,1pe24.16))') 'Left edge overshoot at ',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & + 'edge=',ppoly_r_E(i0,1),'err=',ppoly_r_E(i0,1)-u_max problem_detected = .true. endif endif @@ -479,30 +592,30 @@ subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, & u_min = min(u_c, u_r) u_max = max(u_c, u_r) if (ppoly_r_E(i0,2) < u_min) then - write(0,'(a,i4,5(x,a,1pe24.16))') 'Right edge undershoot at',i0,'u(i0)=',u_c,'u(i0+1)=',u_r, & - 'edge=',ppoly_r_E(i0,2),'err=',ppoly_r_E(i0,2)-u_min + write(0,'(a,I0,5(1x,a,1pe24.16))') 'Right edge undershoot at ',i0,'u(i0)=',u_c,'u(i0+1)=',u_r, & + 'edge=',ppoly_r_E(i0,2),'err=',ppoly_r_E(i0,2)-u_min problem_detected = .true. endif if (ppoly_r_E(i0,2) > u_max) then - write(0,'(a,i4,5(x,a,1pe24.16))') 'Right edge overshoot at',i0,'u(i0)=',u_c,'u(i0+1)=',u_r, & - 'edge=',ppoly_r_E(i0,2),'err=',ppoly_r_E(i0,2)-u_max + write(0,'(a,I0,5(1x,a,1pe24.16))') 'Right edge overshoot at ',i0,'u(i0)=',u_c,'u(i0+1)=',u_r, & + 'edge=',ppoly_r_E(i0,2),'err=',ppoly_r_E(i0,2)-u_max problem_detected = .true. endif endif if (i0 > 1) then if ( (u_c-u_l)*(ppoly_r_E(i0,1)-ppoly_r_E(i0-1,2)) < 0.) then - write(0,'(a,i4,5(x,a,1pe24.16))') 'Non-monotonic edges at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & - 'right edge=',ppoly_r_E(i0-1,2),'left edge=',ppoly_r_E(i0,1) - write(0,'(5(a,1pe24.16,x))') 'u(i0)-u(i0-1)',u_c-u_l,'edge diff=',ppoly_r_E(i0,1)-ppoly_r_E(i0-1,2) + write(0,'(a,I0,5(1x,a,1pe24.16))') 'Non-monotonic edges at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & + 'right edge=',ppoly_r_E(i0-1,2),'left edge=',ppoly_r_E(i0,1) + write(0,'(5(a,1pe24.16,1x))') 'u(i0)-u(i0-1)',u_c-u_l,'edge diff=',ppoly_r_E(i0,1)-ppoly_r_E(i0-1,2) problem_detected = .true. endif endif if (problem_detected) then write(0,'(a,1p9e24.16)') 'Polynomial coeffs:',ppoly_r_coefs(i0,:) - write(0,'(3(a,1pe24.16,x))') 'u_l=',u_l,'u_c=',u_c,'u_r=',u_r + write(0,'(3(a,1pe24.16,1x))') 'u_l=',u_l,'u_c=',u_c,'u_r=',u_r write(0,'(a4,10a24)') 'i0','h0(i0)','u0(i0)','left edge','right edge','Polynomial coefficients' do n = 1, n0 - write(0,'(i4,1p10e24.16)') n,h0(n),u0(n),ppoly_r_E(n,1),ppoly_r_E(n,2),ppoly_r_coefs(n,:) + write(0,'(I0,1p10e24.16)') n,h0(n),u0(n),ppoly_r_E(n,1),ppoly_r_E(n,2),ppoly_r_coefs(n,:) enddo call MOM_error(FATAL, 'MOM_remapping, check_reconstructions_1d: '// & 'Edge values or polynomial coefficients were inconsistent!') @@ -511,26 +624,39 @@ subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, & end subroutine check_reconstructions_1d -!> Remaps column of n0 values u0 on grid h0 to grid h1 with n1 cells by calculating -!! the n0+n1+1 sub-integrals of the intersection of h0 and h1, and the summing the -!! appropriate integrals into the h1*u1 values. h0 and h1 must have the same units. -subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, method, & - force_bounds_in_subcell, u1, uh_err, ah_sub, aisub_src, aiss, aise ) - integer, intent(in) :: n0 !< Number of cells in source grid - real, intent(in) :: h0(n0) !< Source grid widths (size n0) - real, intent(in) :: u0(n0) !< Source cell averages (size n0) - real, intent(in) :: ppoly0_E(n0,2) !< Edge value of polynomial - real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial - integer, intent(in) :: n1 !< Number of cells in target grid - real, intent(in) :: h1(n1) !< Target grid widths (size n1) - integer, intent(in) :: method !< Remapping scheme to use - logical, intent(in) :: force_bounds_in_subcell !< Force sub-cell values to be bounded - real, intent(out) :: u1(n1) !< Target cell averages (size n1) - real, intent(out) :: uh_err !< Estimate of bound on error in sum of u*h - real, optional, intent(out) :: ah_sub(n0+n1+1) !< h_sub - integer, optional, intent(out) :: aisub_src(n0+n1+1) !< i_sub_src - integer, optional, intent(out) :: aiss(n0) !< isrc_start - integer, optional, intent(out) :: aise(n0) !< isrc_ens +!> Returns the intersection of source and targets grids along with and auxiliary lists or indices. +!! +!! For source grid with thicknesses h0(1:n0) and target grid with thicknesses h1(1:n1) the intersection +!! or "subgrid" has thicknesses h_sub(1:n0+n1+1). +!! h0 and h1 must have the same units. h_sub will return with the same units as h0 and h1. +!! +!! Notes on the algorithm: +!! Internally, grids are defined by the interfaces (although we describe grids via thicknesses for accuracy). +!! The intersection or union of two grids is thus defined by the super set of both lists of interfaces. +!! Because both source and target grids can contain vanished cells, we do not eliminate repeated +!! interfaces from the union. +!! That is, the total number of interfaces of the sub-cells is equal to the total numer of interfaces of +!! the source grid (n0+1) plus the total number of interfaces of the target grid (n1+1), i.e. n0+n1+2. +!! Whenever target and source interfaces align, then the retention of identical interfaces leads to a +!! vanished subcell. +!! The remapping uses a common point of reference to the left (top) so there is always a vanished subcell +!! at the left (top). +!! If the total column thicknesses are the same, then the right (bottom) interfaces are also aligned and +!! so the last subcell will also be vanished. +subroutine intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + integer, intent(in) :: n0 !< Number of cells in source grid + real, intent(in) :: h0(n0) !< Source grid widths (size n0) [H] + integer, intent(in) :: n1 !< Number of cells in target grid + real, intent(in) :: h1(n1) !< Target grid widths (size n1) [H] + real, intent(out) :: h_sub(n0+n1+1) !< Overlapping sub-cell thicknesses, h_sub [H] + real, intent(out) :: h0_eff(n0) !< Effective thickness of source cells [H] + integer, intent(out) :: isrc_start(n0) !< Index of first sub-cell within each source cell + integer, intent(out) :: isrc_end(n0) !< Index of last sub-cell within each source cell + integer, intent(out) :: isrc_max(n0) !< Index of thickest sub-cell within each source cell + integer, intent(out) :: itgt_start(n1) !< Index of first sub-cell within each target cell + integer, intent(out) :: itgt_end(n1) !< Index of last sub-cell within each target cell + integer, intent(out) :: isub_src(n0+n1+1) !< Index of source cell for each sub-cell ! Local variables integer :: i_sub ! Index of sub-cell integer :: i0 ! Index into h0(1:n0), source column @@ -538,43 +664,14 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth integer :: i_start0 ! Used to record which sub-cells map to source cells integer :: i_start1 ! Used to record which sub-cells map to target cells integer :: i_max ! Used to record which sub-cell is the largest contribution of a source cell - real :: dh_max ! Used to record which sub-cell is the largest contribution of a source cell - real, dimension(n0+n1+1) :: h_sub ! Width of each each sub-cell - real, dimension(n0+n1+1) :: uh_sub ! Integral of u*h over each sub-cell - real, dimension(n0+n1+1) :: u_sub ! Average of u over each sub-cell - integer, dimension(n0+n1+1) :: isub_src ! Index of source cell for each sub-cell - integer, dimension(n0) :: isrc_start ! Index of first sub-cell within each source cell - integer, dimension(n0) :: isrc_end ! Index of last sub-cell within each source cell - integer, dimension(n0) :: isrc_max ! Index of thickest sub-cell within each source cell - real, dimension(n0) :: h0_eff ! Effective thickness of source cells - real, dimension(n0) :: u0_min ! Minimum value of reconstructions in source cell - real, dimension(n0) :: u0_max ! Minimum value of reconstructions in source cell - integer, dimension(n1) :: itgt_start ! Index of first sub-cell within each target cell - integer, dimension(n1) :: itgt_end ! Index of last sub-cell within each target cell - real :: xa, xb ! Non-dimensional position within a source cell (0..1) - real :: h0_supply, h1_supply ! The amount of width available for constructing sub-cells - real :: dh ! The width of the sub-cell - real :: duh ! The total amount of accumulated stuff (u*h) - real :: dh0_eff ! Running sum of source cell thickness + real :: dh_max ! Used to record which sub-cell is the largest contribution of a source cell [H] + real :: h0_supply, h1_supply ! The amount of width available for constructing sub-cells [H] + real :: dh ! The width of the sub-cell [H] + real :: dh0_eff ! Running sum of source cell thickness [H] ! For error checking/debugging - logical, parameter :: force_bounds_in_target = .true. ! To fix round-off issues - logical, parameter :: adjust_thickest_subcell = .true. ! To fix round-off conservation issues - logical, parameter :: debug_bounds = .false. ! For debugging overshoots etc. - integer :: k, i0_last_thick_cell - real :: h0tot, h0err, h1tot, h1err, h2tot, h2err, u02_err - real :: u0tot, u0err, u0min, u0max, u1tot, u1err, u1min, u1max, u2tot, u2err, u2min, u2max, u_orig logical :: src_has_volume !< True if h0 has not been consumed logical :: tgt_has_volume !< True if h1 has not been consumed - if (old_algorithm) isrc_max(:)=1 - - i0_last_thick_cell = 0 - do i0 = 1, n0 - u0_min(i0) = min(ppoly0_E(i0,1), ppoly0_E(i0,2)) - u0_max(i0) = max(ppoly0_E(i0,1), ppoly0_E(i0,2)) - if (h0(i0)>0.) i0_last_thick_cell = i0 - enddo - ! Initialize algorithm h0_supply = h0(1) h1_supply = h1(1) @@ -635,28 +732,13 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth ! Record the source cell thickness found by summing the sub-cell thicknesses. h0_eff(i0) = dh0_eff ! Move the source index. - if (old_algorithm) then - if (i0 < i0_last_thick_cell) then - i0 = i0 + 1 - h0_supply = h0(i0) - dh0_eff = 0. - do while (h0_supply==0. .and. i0= h1_supply .and. tgt_has_volume) then ! h1_supply is smaller than h0_supply) so we consume h1_supply and increment the @@ -672,12 +754,8 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth i1 = i1 + 1 h1_supply = h1(i1) else - if (old_algorithm) then - h1_supply = 1.E30 - else - h1_supply = 0. - tgt_has_volume = .false. - endif + h1_supply = 0. + tgt_has_volume = .false. endif elseif (src_has_volume) then ! We ran out of target volume but still have source cells to consume @@ -716,12 +794,103 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth tgt_has_volume = .false. endif else - stop 'remap_via_sub_cells: THIS SHOULD NEVER HAPPEN!' + stop 'intersect_src_tgt_grids: THIS SHOULD NEVER HAPPEN!' endif enddo +end subroutine intersect_src_tgt_grids + +!> Adjust h_sub to ensure accurate conservation +!! +!! Loop over each source cell substituting the thickest sub-cell (within the source cell) with the +!! residual of the source cell thickness minus the sum of other sub-cells +!! aka a genius algorithm for accurate conservation when remapping from Robert Hallberg (\@Hallberg-NOAA). +!subroutine adjust_h_sub( n0, h0, n1, isrc_start, isrc_end, isrc_max, h_sub ) +! integer, intent(in) :: n0 !< Number of cells in source grid +! real, intent(in) :: h0(n0) !< Source grid widths (size n0) [H] +! integer, intent(in) :: n1 !< Number of cells in target grid +! integer, intent(in) :: isrc_start(n0) !< Index of first sub-cell within each source cell +! integer, intent(in) :: isrc_end(n0) !< Index of last sub-cell within each source cell +! integer, intent(in) :: isrc_max(n0) !< Index of thickest sub-cell within each source cell +! real, intent(inout) :: h_sub(n0+n1+1) !< Overlapping sub-cell thicknesses, h_sub [H] +! ! Local variables +! integer :: i_sub ! Index of sub-cell +! integer :: i0 ! Index into h0(1:n0), source column +! integer :: i_max ! Used to record which sub-cell is the largest contribution of a source cell +! real :: dh_max ! Used to record which sub-cell is the largest contribution of a source cell [H] +! real :: dh ! The width of the sub-cell [H] +! integer :: i0_last_thick_cell ! Last h0 cell with finite thickness +! +! i0_last_thick_cell = 0 +! do i0 = 1, n0 +! if (h0(i0)>0.) i0_last_thick_cell = i0 +! enddo +! +! do i0 = 1, i0_last_thick_cell +! i_max = isrc_max(i0) +! dh_max = h_sub(i_max) +! if (dh_max > 0.) then +! ! dh will be the sum of sub-cell thicknesses within the source cell except for the thickest sub-cell. +! dh = 0. +! do i_sub = isrc_start(i0), isrc_end(i0) +! if (i_sub /= i_max) dh = dh + h_sub(i_sub) +! enddo +! h_sub(i_max) = h0(i0) - dh +! endif +! enddo +! +!end subroutine adjust_h_sub + +!> Remaps column of n0 values u0 on grid h0 to subgrid h_sub +!! +!! This includes an error for the scenario where the source grid is much thicker than +!! the target grid and extrapolation is needed. +subroutine remap_src_to_sub_grid_om4(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, & + h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + method, force_bounds_in_subcell, u_sub, uh_sub, u02_err) + integer, intent(in) :: n0 !< Number of cells in source grid + real, intent(in) :: h0(n0) !< Source grid widths (size n0) [H] + real, intent(in) :: u0(n0) !< Source grid widths (size n0) [H] + real, intent(in) :: ppoly0_E(n0,2) !< Edge value of polynomial [A] + real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial [A] + integer, intent(in) :: n1 !< Number of cells in target grid + real, intent(in) :: h_sub(n0+n1+1) !< Overlapping sub-cell thicknesses, h_sub [H] + real, intent(in) :: h0_eff(n0) !< Effective thickness of source cells [H] + integer, intent(in) :: isrc_start(n0) !< Index of first sub-cell within each source cell + integer, intent(in) :: isrc_end(n0) !< Index of last sub-cell within each source cell + integer, intent(in) :: isrc_max(n0) !< Index of thickest sub-cell within each source cell + integer, intent(in) :: isub_src(n0+n1+1) !< Index of source cell for each sub-cell + integer, intent(in) :: method !< Remapping scheme to use + logical, intent(in) :: force_bounds_in_subcell !< Force sub-cell values to be bounded + real, intent(out) :: u_sub(n0+n1+1) !< Sub-cell cell averages (size n1) [A] + real, intent(out) :: uh_sub(n0+n1+1) !< Sub-cell cell integrals (size n1) [A H] + real, intent(out) :: u02_err !< Integrated reconstruction error estimates [A H] + ! Local variables + integer :: i_sub ! Index of sub-cell + integer :: i0 ! Index into h0(1:n0), source column + integer :: i_max ! Used to record which sub-cell is the largest contribution of a source cell + real :: dh_max ! Used to record which sub-cell is the largest contribution of a source cell [H] + real :: xa, xb ! Non-dimensional position within a source cell (0..1) [nondim] + real :: dh ! The width of the sub-cell [H] + real :: duh ! The total amount of accumulated stuff (u*h) [A H] + real :: dh0_eff ! Running sum of source cell thickness [H] + real :: u0_min(n0), u0_max(n0) !< Min/max of u0 for each source cell [A] + ! For error checking/debugging + logical, parameter :: adjust_thickest_subcell = .true. ! To fix round-off conservation issues + integer :: i0_last_thick_cell + real :: u_orig ! The original value of the reconstruction in a cell [A] + + i0_last_thick_cell = 0 + do i0 = 1, n0 + u0_min(i0) = min(ppoly0_E(i0,1), ppoly0_E(i0,2)) + u0_max(i0) = max(ppoly0_E(i0,1), ppoly0_E(i0,2)) + if (h0(i0)>0.) i0_last_thick_cell = i0 + enddo + ! Loop over each sub-cell to calculate average/integral values within each sub-cell. + ! Uses: h_sub, isub_src, h0_eff + ! Sets: u_sub, uh_sub xa = 0. dh0_eff = 0. uh_sub(1) = 0. @@ -747,19 +916,6 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth xb = 1. u_sub(i_sub) = u0(i0) endif - if (debug_bounds) then - if (method<5 .and.(u_sub(i_sub)u0_max(i0))) then - write(0,*) 'Sub cell average is out of bounds',i_sub,'method=',method - write(0,*) 'xa,xb: ',xa,xb - write(0,*) 'Edge values: ',ppoly0_E(i0,:),'mean',u0(i0) - write(0,*) 'a_c: ',(u0(i0)-ppoly0_E(i0,1))+(u0(i0)-ppoly0_E(i0,2)) - write(0,*) 'Polynomial coeffs: ',ppoly0_coefs(i0,:) - write(0,*) 'Bounds min=',u0_min(i0),'max=',u0_max(i0) - write(0,*) 'Average: ',u_sub(i_sub),'rel to min=',u_sub(i_sub)-u0_min(i0),'rel to max=',u_sub(i_sub)-u0_max(i0) - call MOM_error( FATAL, 'MOM_remapping, remap_via_sub_cells: '//& - 'Sub-cell average is out of bounds!' ) - endif - endif if (force_bounds_in_subcell) then ! These next two lines should not be needed but when using PQM we found roundoff ! can lead to overshoots. These lines sweep issues under the rug which need to be @@ -786,7 +942,9 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth if (adjust_thickest_subcell) then ! Loop over each source cell substituting the integral/average for the thickest sub-cell (within ! the source cell) with the residual of the source cell integral minus the other sub-cell integrals - ! aka a genius algorithm for accurate conservation when remapping from Robert Hallberg (@Hallberg-NOAA). + ! aka a genius algorithm for accurate conservation when remapping from Robert Hallberg (\@Hallberg-NOAA). + ! Uses: i0_last_thick_cell, isrc_max, h_sub, isrc_start, isrc_end, uh_sub, u0, h0 + ! Updates: uh_sub, u_sub do i0 = 1, i0_last_thick_cell i_max = isrc_max(i0) dh_max = h_sub(i_max) @@ -802,7 +960,177 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth enddo endif +end subroutine remap_src_to_sub_grid_om4 + +!> Remaps column of n0 values u0 on grid h0 to subgrid h_sub +subroutine remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, & + isrc_start, isrc_end, isrc_max, isub_src, & + method, force_bounds_in_subcell, u_sub, uh_sub, u02_err) + integer, intent(in) :: n0 !< Number of cells in source grid + real, intent(in) :: h0(n0) !< Source grid widths (size n0) [H] + real, intent(in) :: u0(n0) !< Source grid widths (size n0) [H] + real, intent(in) :: ppoly0_E(n0,2) !< Edge value of polynomial [A] + real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial [A] + integer, intent(in) :: n1 !< Number of cells in target grid + real, intent(in) :: h_sub(n0+n1+1) !< Overlapping sub-cell thicknesses, h_sub [H] + integer, intent(in) :: isrc_start(n0) !< Index of first sub-cell within each source cell + integer, intent(in) :: isrc_end(n0) !< Index of last sub-cell within each source cell + integer, intent(in) :: isrc_max(n0) !< Index of thickest sub-cell within each source cell + integer, intent(in) :: isub_src(n0+n1+1) !< Index of source cell for each sub-cell + integer, intent(in) :: method !< Remapping scheme to use + logical, intent(in) :: force_bounds_in_subcell !< Force sub-cell values to be bounded + real, intent(out) :: u_sub(n0+n1+1) !< Sub-cell cell averages (size n1) [A] + real, intent(out) :: uh_sub(n0+n1+1) !< Sub-cell cell integrals (size n1) [A H] + real, intent(out) :: u02_err !< Integrated reconstruction error estimates [A H] + ! Local variables + integer :: i_sub ! Index of sub-cell + integer :: i0 ! Index into h0(1:n0), source column + integer :: i_max ! Used to record which sub-cell is the largest contribution of a source cell + real :: dh_max ! Used to record which sub-cell is the largest contribution of a source cell [H] + real :: xa, xb ! Non-dimensional position within a source cell (0..1) [nondim] + real :: dh ! The width of the sub-cell [H] + real :: duh ! The total amount of accumulated stuff (u*h) [A H] + real :: dh0_eff ! Running sum of source cell thickness [H] + real :: u0_min(n0), u0_max(n0) ! Min/max of u0 for each source cell [A] + ! For error checking/debugging + logical, parameter :: adjust_thickest_subcell = .true. ! To fix round-off conservation issues + integer :: i0_last_thick_cell + real :: u_orig ! The original value of the reconstruction in a cell [A] + + i0_last_thick_cell = 0 + do i0 = 1, n0 + u0_min(i0) = min(ppoly0_E(i0,1), ppoly0_E(i0,2)) + u0_max(i0) = max(ppoly0_E(i0,1), ppoly0_E(i0,2)) + if (h0(i0)>0.) i0_last_thick_cell = i0 + enddo + + ! Loop over each sub-cell to calculate average/integral values within each sub-cell. + ! Uses: h_sub, isub_src, h0_eff + ! Sets: u_sub, uh_sub + xa = 0. + dh0_eff = 0. + u02_err = 0. + do i_sub = 1, n0+n1 + + ! Sub-cell thickness from loop above + dh = h_sub(i_sub) + + ! Source cell + i0 = isub_src(i_sub) + + ! Evaluate average and integral for sub-cell i_sub. + ! Integral is over distance dh but expressed in terms of non-dimensional + ! positions with source cell from xa to xb (0 <= xa <= xb <= 1). + dh0_eff = dh0_eff + dh ! Cumulative thickness within the source cell + if (h0(i0)>0.) then + xb = dh0_eff / h0(i0) ! This expression yields xa <= xb <= 1.0 + xb = min(1., xb) ! This is only needed when the total target column is wider than the source column + u_sub(i_sub) = average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, xa, xb) + else ! Vanished cell + xb = 1. + u_sub(i_sub) = u0(i0) + endif + if (force_bounds_in_subcell) then + ! These next two lines should not be needed but when using PQM we found roundoff + ! can lead to overshoots. These lines sweep issues under the rug which need to be + ! properly .. later. -AJA + u_orig = u_sub(i_sub) + u_sub(i_sub) = max( u_sub(i_sub), u0_min(i0) ) + u_sub(i_sub) = min( u_sub(i_sub), u0_max(i0) ) + u02_err = u02_err + dh*abs( u_sub(i_sub) - u_orig ) + endif + uh_sub(i_sub) = dh * u_sub(i_sub) + + if (isub_src(i_sub+1) /= i0) then + ! If the next sub-cell is in a different source cell, reset the position counters + dh0_eff = 0. + xa = 0. + else + xa = xb ! Next integral will start at end of last + endif + + enddo + i_sub = n0+n1+1 + ! Sub-cell thickness from loop above + dh = h_sub(i_sub) + ! Source cell + i0 = isub_src(i_sub) + + ! Evaluate average and integral for sub-cell i_sub. + ! Integral is over distance dh but expressed in terms of non-dimensional + ! positions with source cell from xa to xb (0 <= xa <= xb <= 1). + dh0_eff = dh0_eff + dh ! Cumulative thickness within the source cell + if (h0(i0)>0.) then + xb = dh0_eff / h0(i0) ! This expression yields xa <= xb <= 1.0 + xb = min(1., xb) ! This is only needed when the total target column is wider than the source column + u_sub(i_sub) = average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, xa, xb) + else ! Vanished cell + xb = 1. + u_sub(i_sub) = u0(i0) + endif + if (force_bounds_in_subcell) then + ! These next two lines should not be needed but when using PQM we found roundoff + ! can lead to overshoots. These lines sweep issues under the rug which need to be + ! properly .. later. -AJA + u_orig = u_sub(i_sub) + u_sub(i_sub) = max( u_sub(i_sub), u0_min(i0) ) + u_sub(i_sub) = min( u_sub(i_sub), u0_max(i0) ) + u02_err = u02_err + dh*abs( u_sub(i_sub) - u_orig ) + endif + uh_sub(i_sub) = dh * u_sub(i_sub) + + if (adjust_thickest_subcell) then + ! Loop over each source cell substituting the integral/average for the thickest sub-cell (within + ! the source cell) with the residual of the source cell integral minus the other sub-cell integrals + ! aka a genius algorithm for accurate conservation when remapping from Robert Hallberg (\@Hallberg-NOAA). + ! Uses: i0_last_thick_cell, isrc_max, h_sub, isrc_start, isrc_end, uh_sub, u0, h0 + ! Updates: uh_sub + do i0 = 1, i0_last_thick_cell + i_max = isrc_max(i0) + dh_max = h_sub(i_max) + if (dh_max > 0.) then + ! duh will be the sum of sub-cell integrals within the source cell except for the thickest sub-cell. + duh = 0. + do i_sub = isrc_start(i0), isrc_end(i0) + if (i_sub /= i_max) duh = duh + uh_sub(i_sub) + enddo + uh_sub(i_max) = u0(i0)*h0(i0) - duh + u02_err = u02_err + max( abs(uh_sub(i_max)), abs(u0(i0)*h0(i0)), abs(duh) ) + endif + enddo + endif + +end subroutine remap_src_to_sub_grid + +!> Remaps column of n0+n1+1 values usub on sub-grid h_sub to targets on grid h1 +!! using the OM4-era algorithm +subroutine remap_sub_to_tgt_grid_om4(n0, n1, h1, h_sub, u_sub, uh_sub, & + itgt_start, itgt_end, force_bounds_in_target, u1, uh_err) + integer, intent(in) :: n0 !< Number of cells in source grid + integer, intent(in) :: n1 !< Number of cells in target grid + real, intent(in) :: h1(n1) !< Target grid widths (size n1) [H] + real, intent(in) :: h_sub(n0+n1+1) !< Overlapping sub-cell thicknesses, h_sub [H] + real, intent(in) :: u_sub(n0+n1+1) !< Sub-cell cell averages (size n1) [A] + real, intent(in) :: uh_sub(n0+n1+1) !< Sub-cell cell integrals (size n1) [A H] + integer, intent(in) :: itgt_start(n1) !< Index of first sub-cell within each target cell + integer, intent(in) :: itgt_end(n1) !< Index of last sub-cell within each target cell + logical, intent(in) :: force_bounds_in_target !< Force sub-cell values to be bounded + real, intent(out) :: u1(n1) !< Target cell averages (size n1) [A] + real, intent(out) :: uh_err !< Estimate of bound on error in sum of u*h [A H] + ! Local variables + integer :: i1 ! tgt loop index + integer :: i_sub ! index to sub-layer + real :: dh ! The width of the sub-cell [H] + real :: duh ! The total amount of accumulated stuff (u*h) [A H] + real :: u1min, u1max ! Minimum and maximum values of reconstructions [A] + real :: u_orig ! The original value of the reconstruction in a cell prior to bounding [A] + + u1min = 0. ! Not necessary, but avoids an overzealous compiler ... + u1max = 0. ! ... warning about uninitialized variables + ! Loop over each target cell summing the integrals from sub-cells within the target cell. + ! Uses: itgt_start, itgt_end, h_sub, uh_sub, u_sub + ! Sets: u1, uh_err uh_err = 0. do i1 = 1, n1 if (h1(i1) > 0.) then @@ -836,110 +1164,253 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth endif enddo - ! Check errors and bounds - if (debug_bounds) then - call measure_input_bounds( n0, h0, u0, ppoly0_E, h0tot, h0err, u0tot, u0err, u0min, u0max ) - call measure_output_bounds( n1, h1, u1, h1tot, h1err, u1tot, u1err, u1min, u1max ) - call measure_output_bounds( n0+n1+1, h_sub, u_sub, h2tot, h2err, u2tot, u2err, u2min, u2max ) - if (method<5) then ! We except PQM until we've debugged it - if ( (abs(u1tot-u0tot)>(u0err+u1err)+uh_err+u02_err .and. abs(h1tot-h0tot)u0err+u2err+u02_err .and. abs(h2tot-h0tot)u0max) ) then - write(0,*) 'method = ',method - write(0,*) 'Source to sub-cells:' - write(0,*) 'H: h0tot=',h0tot,'h2tot=',h2tot,'dh=',h2tot-h0tot,'h0err=',h0err,'h2err=',h2err - if (abs(h2tot-h0tot)>h0err+h2err) & - write(0,*) 'H non-conservation difference=',h2tot-h0tot,'allowed err=',h0err+h2err,' <-----!' - write(0,*) 'UH: u0tot=',u0tot,'u2tot=',u2tot,'duh=',u2tot-u0tot,'u0err=',u0err,'u2err=',u2err,& - 'adjustment err=',u02_err - if (abs(u2tot-u0tot)>u0err+u2err) & - write(0,*) 'U non-conservation difference=',u2tot-u0tot,'allowed err=',u0err+u2err,' <-----!' - write(0,*) 'Sub-cells to target:' - write(0,*) 'H: h2tot=',h2tot,'h1tot=',h1tot,'dh=',h1tot-h2tot,'h2err=',h2err,'h1err=',h1err - if (abs(h1tot-h2tot)>h2err+h1err) & - write(0,*) 'H non-conservation difference=',h1tot-h2tot,'allowed err=',h2err+h1err,' <-----!' - write(0,*) 'UH: u2tot=',u2tot,'u1tot=',u1tot,'duh=',u1tot-u2tot,'u2err=',u2err,'u1err=',u1err,'uh_err=',uh_err - if (abs(u1tot-u2tot)>u2err+u1err) & - write(0,*) 'U non-conservation difference=',u1tot-u2tot,'allowed err=',u2err+u1err,' <-----!' - write(0,*) 'Source to target:' - write(0,*) 'H: h0tot=',h0tot,'h1tot=',h1tot,'dh=',h1tot-h0tot,'h0err=',h0err,'h1err=',h1err - if (abs(h1tot-h0tot)>h0err+h1err) & - write(0,*) 'H non-conservation difference=',h1tot-h0tot,'allowed err=',h0err+h1err,' <-----!' - write(0,*) 'UH: u0tot=',u0tot,'u1tot=',u1tot,'duh=',u1tot-u0tot,'u0err=',u0err,'u1err=',u1err,'uh_err=',uh_err - if (abs(u1tot-u0tot)>(u0err+u1err)+uh_err) & - write(0,*) 'U non-conservation difference=',u1tot-u0tot,'allowed err=',u0err+u1err+uh_err,' <-----!' - write(0,*) 'U: u0min=',u0min,'u1min=',u1min,'u2min=',u2min - if (u1minu0max) write(0,*) 'U2 maximum overshoot=',u2max-u0max,' <-----!' - write(0,'(a3,6a24,2a3)') 'k','h0','left edge','u0','right edge','h1','u1','is','ie' - do k = 1, max(n0,n1) - if (k<=min(n0,n1)) then - write(0,'(i3,1p6e24.16,2i3)') k,h0(k),ppoly0_E(k,1),u0(k),ppoly0_E(k,2),h1(k),u1(k),itgt_start(k),itgt_end(k) - elseif (k>n0) then - write(0,'(i3,96x,1p2e24.16,2i3)') k,h1(k),u1(k),itgt_start(k),itgt_end(k) - else - write(0,'(i3,1p4e24.16)') k,h0(k),ppoly0_E(k,1),u0(k),ppoly0_E(k,2) - endif - enddo - write(0,'(a3,2a24)') 'k','u0','Polynomial coefficients' - do k = 1, n0 - write(0,'(i3,1p6e24.16)') k,u0(k),ppoly0_coefs(k,:) - enddo - write(0,'(a3,3a24,a3,2a24)') 'k','Sub-cell h','Sub-cell u','Sub-cell hu','i0','xa','xb' - xa = 0. - dh0_eff = 0. - do k = 1, n0+n1+1 - dh = h_sub(k) - i0 = isub_src(k) - dh0_eff = dh0_eff + dh ! Cumulative thickness within the source cell - xb = dh0_eff / h0_eff(i0) ! This expression yields xa <= xb <= 1.0 - xb = min(1., xb) ! This is only needed when the total target column is wider than the source column - write(0,'(i3,1p3e24.16,i3,1p2e24.16)') k,h_sub(k),u_sub(k),uh_sub(k),i0,xa,xb - if (k<=n0+n1) then - if (isub_src(k+1) /= i0) then - dh0_eff = 0.; xa = 0. - else - xa = xb +end subroutine remap_sub_to_tgt_grid_om4 + +!> Remaps column of n0+n1+1 values usub on sub-grid h_sub to targets on grid h1 +subroutine remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, & + itgt_start, itgt_end, force_bounds_in_target, & + better_force_bounds_in_target, offset_summation, u1, uh_err) + integer, intent(in) :: n0 !< Number of cells in source grid + integer, intent(in) :: n1 !< Number of cells in target grid + real, intent(in) :: h1(n1) !< Target grid widths (size n1) [H] + real, intent(in) :: h_sub(n0+n1+1) !< Overlapping sub-cell thicknesses, h_sub [H] + real, intent(in) :: u_sub(n0+n1+1) !< Sub-cell cell averages (size n1) [A] + real, intent(in) :: uh_sub(n0+n1+1) !< Sub-cell cell integrals (size n1) [A H] + integer, intent(in) :: itgt_start(n1) !< Index of first sub-cell within each target cell + integer, intent(in) :: itgt_end(n1) !< Index of last sub-cell within each target cell + logical, intent(in) :: force_bounds_in_target !< Force sub-cell values to be bounded + logical, intent(in) :: better_force_bounds_in_target !< Force sub-cell values to be bounded + logical, intent(in) :: offset_summation !< Offset values in summation for accuracy + real, intent(out) :: u1(n1) !< Target cell averages (size n1) [A] + real, intent(out) :: uh_err !< Estimate of bound on error in sum of u*h [A H] + ! Local variables + integer :: i1 ! tgt loop index + integer :: i_sub ! index to sub-layer + real :: dh ! The width of the sub-cell [H] + real :: duh ! The total amount of accumulated stuff (u*h) [A H] + real :: u1min, u1max ! Minimum and maximum values of reconstructions [A] + real :: u_orig ! The original value of the reconstruction in a cell prior to bounding [A] + real :: u_ref ! A value to offest the summation to gain accuracy [A] + real :: h_max ! Thickest cell encountered [H] + + u1min = 0. ! Not necessary, but avoids an overzealous compiler ... + u1max = 0. ! ... warning about uninitialized variables + u_ref = 0. ! An offset of 0. should do no harm + h_max = 0. + + ! Loop over each target cell summing the integrals from sub-cells within the target cell. + ! Uses: itgt_start, itgt_end, h_sub, uh_sub, u_sub + ! Sets: u1, uh_err + uh_err = 0. + do i1 = 1, n1 + if (h1(i1) > 0.) then + duh = 0. ; dh = 0. + i_sub = itgt_start(i1) + if (force_bounds_in_target) then + u1min = u_sub(i_sub) + u1max = u_sub(i_sub) + endif + if (offset_summation) then + u_ref = 0. ! An offset of 0. should do no harm + h_max = 0. + do i_sub = itgt_start(i1), itgt_end(i1) + if (h_sub(i_sub) > h_max) then + u_ref = u_sub(i_sub) + h_max = h_sub(i_sub) endif + enddo + endif + do i_sub = itgt_start(i1), itgt_end(i1) + if (force_bounds_in_target .or. better_force_bounds_in_target .and. h_sub(i_sub)>0.) then + u1min = min(u1min, u_sub(i_sub)) + u1max = max(u1max, u_sub(i_sub)) endif + dh = dh + h_sub(i_sub) + ! Ideally u_ref would be already be substracted in uh_sub + duh = duh + ( uh_sub(i_sub) - h_sub(i_sub) * u_ref ) + ! This accumulates the contribution to the error bound for the sum of u*h + uh_err = uh_err + max(abs(duh),abs(uh_sub(i_sub)))*epsilon(duh) enddo - call MOM_error( FATAL, 'MOM_remapping, remap_via_sub_cells: '//& - 'Remapping result is inconsistent!' ) + u1(i1) = duh / dh + u_ref + ! This is the contribution from the division to the error bound for the sum of u*h + uh_err = uh_err + abs(duh)*epsilon(duh) + if (force_bounds_in_target) then + u_orig = u1(i1) + u1(i1) = max(u1min, min(u1max, u1(i1))) + ! Adjusting to be bounded contributes to the error for the sum of u*h + uh_err = uh_err + dh*abs( u1(i1)-u_orig ) + endif + else + u1(i1) = u_sub(itgt_start(i1)) endif - endif ! method<5 - endif ! debug_bounds + enddo - ! Include the error remapping from source to sub-cells in the estimate of total remapping error - uh_err = uh_err + u02_err +end subroutine remap_sub_to_tgt_grid + +!> Linearly interpolate interface data, u_src, from grid h_src to a grid h_dest +subroutine interpolate_column(nsrc, h_src, u_src, ndest, h_dest, u_dest, mask_edges) + integer, intent(in) :: nsrc !< Number of source cells + real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] + real, dimension(nsrc+1), intent(in) :: u_src !< Values at source cell interfaces [A] + integer, intent(in) :: ndest !< Number of destination cells + real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] + real, dimension(ndest+1), intent(inout) :: u_dest !< Interpolated value at destination cell interfaces [A] + logical, intent(in) :: mask_edges !< If true, mask the values outside of massless + !! layers at the top and bottom of the column. + + ! Local variables + real :: x_dest ! Relative position of target interface [H] + real :: dh ! Source cell thickness [H] + real :: frac_pos(ndest+1) ! Fractional position of the destination interface + ! within the source layer [nondim], 0 <= frac_pos <= 1. + integer :: k_src(ndest+1) ! Source grid layer index of destination interface, 1 <= k_src <= ndest. + integer :: ks, k_dest ! Index of cell in src and dest columns + + ! The following forces the "do while" loop to do one cycle that will set u1, u2, dh. + ks = 0 + dh = 0. + x_dest = 0. + + ! Find the layer index and fractional position of the interfaces of the target + ! grid on the source grid. + do k_dest=1,ndest+1 + do while (dh<=x_dest .and. ks0.) then + frac_pos(k_dest) = max(0., min(1., x_dest / dh)) ! Weight of u2 + else ! For a vanished source layer we need to do something reasonable... + frac_pos(k_dest) = 0.5 + endif + + if (k_dest <= ndest) then + x_dest = x_dest + h_dest(k_dest) ! Position of interface k_dest+1 + endif + enddo + + do k_dest=1,ndest+1 + ! Linear interpolation between surrounding edge values. + ks = k_src(k_dest) + u_dest(k_dest) = (1.0 - frac_pos(k_dest)) * u_src(ks) + frac_pos(k_dest) * u_src(ks+1) + enddo - if (present(ah_sub)) ah_sub(1:n0+n1+1) = h_sub(1:n0+n1+1) - if (present(aisub_src)) aisub_src(1:n0+n1+1) = isub_src(1:n0+n1+1) - if (present(aiss)) aiss(1:n0) = isrc_start(1:n0) - if (present(aise)) aise(1:n0) = isrc_end(1:n0) + if (mask_edges) then + ! Mask vanished layers at the surface which would be under an ice-shelf. + ! When the layer k_dest is vanished and all layers above are also vanished, + ! the k_dest interface value should be missing. + do k_dest=1,ndest + if (h_dest(k_dest) > 0.) exit + u_dest(k_dest) = 0.0 + enddo + + ! Mask interfaces below vanished layers at the bottom + do k_dest=ndest,1,-1 + if (h_dest(k_dest) > 0.) exit + u_dest(k_dest+1) = 0.0 + enddo + endif + +end subroutine interpolate_column + +!> Conservatively calculate integrated data, uh_dest, on grid h_dest, from layer-integrated data, uh_src, on grid h_src +subroutine reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, uh_dest) + integer, intent(in) :: nsrc !< Number of source cells + real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] + real, dimension(nsrc), intent(in) :: uh_src !< Values at source cell interfaces [A H] + integer, intent(in) :: ndest !< Number of destination cells + real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] + real, dimension(ndest), intent(inout) :: uh_dest !< Interpolated value at destination cell interfaces [A H] + + ! Local variables + real :: h_src_rem, h_dest_rem, dh ! Incremental thicknesses [H] + real :: uh_src_rem, duh ! Incremental amounts of stuff [A H] + integer :: k_src, k_dest ! Index of cell in src and dest columns + logical :: src_ran_out + + uh_dest(:) = 0.0 + + k_src = 0 + k_dest = 0 + h_dest_rem = 0. + h_src_rem = 0. + uh_src_rem = 0. + src_ran_out = .false. + + do while(.true.) + if (h_src_rem==0. .and. k_src0.) duh = uh_src_rem + h_src_rem = 0. + uh_src_rem = 0. + h_dest_rem = max(0., h_dest_rem - dh) + elseif (h_src_rem>h_dest_rem) then + ! Only part of the source cell can be used up + dh = h_dest_rem + duh = (dh / h_src_rem) * uh_src_rem + h_src_rem = max(0., h_src_rem - dh) + uh_src_rem = uh_src_rem - duh + h_dest_rem = 0. + else ! h_src_rem==h_dest_rem + ! The source cell exactly fits the destination cell + duh = uh_src_rem + h_src_rem = 0. + uh_src_rem = 0. + h_dest_rem = 0. + endif + uh_dest(k_dest) = uh_dest(k_dest) + duh + if (k_dest==ndest .and. (k_src==nsrc .or. h_dest_rem==0.)) exit + enddo -end subroutine remap_via_sub_cells +end subroutine reintegrate_column !> Returns the average value of a reconstruction within a single source cell, i0, !! between the non-dimensional positions xa and xb (xa<=xb) with dimensional !! separation dh. real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, xa, xb) integer, intent(in) :: n0 !< Number of cells in source grid - real, intent(in) :: u0(:) !< Cell means - real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial - real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial + real, intent(in) :: u0(n0) !< Cell means [A] + real, intent(in) :: ppoly0_E(n0,2) !< Edge value of polynomial [A] + real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial [A] integer, intent(in) :: method !< Remapping scheme to use integer, intent(in) :: i0 !< Source cell index - real, intent(in) :: xa !< Non-dimensional start position within source cell - real, intent(in) :: xb !< Non-dimensional end position within source cell + real, intent(in) :: xa !< Non-dimensional start position within source cell [nondim] + real, intent(in) :: xb !< Non-dimensional end position within source cell [nondim] ! Local variables - real :: u_ave, xa_2, xb_2, xa2pxb2, xapxb - real, parameter :: r_3 = 1.0/3.0 ! Used in evaluation of integrated polynomials - - real :: mx, a_L, a_R, u_c, Ya, Yb, my, xa2b2ab, Ya2b2ab, a_c - + real :: u_ave ! The average value of the polynomial over the specified range [A] + real :: xapxb ! A sum of fracional positions [nondim] + real :: mx, Ya, Yb, my ! Various fractional positions [nondim] + real :: xa_2, xb_2 ! Squared fractional positions [nondim] + real :: xa2pxb2, xa2b2ab, Ya2b2ab ! Sums of squared fractional positions [nondim] + real :: a_L, a_R, u_c, a_c ! Values of the polynomial at various locations [A] + real, parameter :: r_3 = 1.0/3.0 ! Used in evaluation of integrated polynomials [nondim] + + u_ave = 0. ! Avoids warnings about "potentially unset values"; u_ave is always calculated for legitimate schemes if (xb > xa) then select case ( method ) case ( INTEGRATION_PCM ) @@ -1018,6 +1489,7 @@ real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, x + xa * ( ppoly0_coefs(i0,4) & + xa * ppoly0_coefs(i0,5) ) ) ) case default + u_ave = 0. call MOM_error( FATAL,'The selected integration method is invalid' ) end select endif @@ -1025,21 +1497,87 @@ real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, x end function average_value_ppoly +!> This subroutine checks for sufficient consistence in the extrema and total amounts on the old +!! and new grids. +subroutine check_remapped_values(n0, h0, u0, ppoly_r_E, deg, ppoly_r_coefs, & + n1, h1, u1, iMethod, uh_err, caller) + integer, intent(in) :: n0 !< Number of cells on source grid + real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid [H] + real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid [A] + real, dimension(n0,2), intent(in) :: ppoly_r_E !< Edge values of polynomial fits [A] + integer, intent(in) :: deg !< Degree of the piecewise polynomial reconstrution + real, dimension(n0,deg+1), intent(in) :: ppoly_r_coefs !< Coefficients of the piecewise + !! polynomial reconstructions [A] + 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(in) :: u1 !< Cell averages on target grid [A] + integer, intent(in) :: iMethod !< An integer indicating the integration method used + real, intent(in) :: uh_err !< A bound on the error in the sum of u*h as + !! estimated by the remapping code [H A] + character(len=*), intent(in) :: caller !< The name of the calling routine. + + ! Local variables + real :: h0tot, h0err ! Sum of source cell widths and round-off error in this sum [H] + real :: h1tot, h1err ! Sum of target cell widths and round-off error in this sum [H] + real :: u0tot, u0err ! Integrated values on the source grid and round-off error in this sum [H A] + real :: u1tot, u1err ! Integrated values on the target grid and round-off error in this sum [H A] + real :: u0min, u0max, u1min, u1max ! Extrema of values on the two grids [A] + integer :: k + + ! Check errors and bounds + call measure_input_bounds( n0, h0, u0, ppoly_r_E, h0tot, h0err, u0tot, u0err, u0min, u0max ) + call measure_output_bounds( n1, h1, u1, h1tot, h1err, u1tot, u1err, u1min, u1max ) + + if (iMethod<5) return ! We except PQM until we've debugged it + + if ( (abs(u1tot-u0tot)>(u0err+u1err)+uh_err .and. abs(h1tot-h0tot)u0max) ) then + write(0,*) 'iMethod = ',iMethod + write(0,*) 'H: h0tot=',h0tot,'h1tot=',h1tot,'dh=',h1tot-h0tot,'h0err=',h0err,'h1err=',h1err + if (abs(h1tot-h0tot)>h0err+h1err) & + write(0,*) 'H non-conservation difference=',h1tot-h0tot,'allowed err=',h0err+h1err,' <-----!' + write(0,*) 'UH: u0tot=',u0tot,'u1tot=',u1tot,'duh=',u1tot-u0tot,'u0err=',u0err,'u1err=',u1err,'uh_err=',uh_err + if (abs(u1tot-u0tot)>(u0err+u1err)+uh_err) & + write(0,*) 'U non-conservation difference=',u1tot-u0tot,'allowed err=',u0err+u1err+uh_err,' <-----!' + write(0,*) 'U: u0min=',u0min,'u1min=',u1min + if (u1minn0) then + write(0,'(i3,96x,1p2e24.16)') k,h1(k),u1(k) + else + write(0,'(i3,1p4e24.16)') k,h0(k),ppoly_r_E(k,1),u0(k),ppoly_r_E(k,2) + endif + enddo + write(0,'(a3,2a24)') 'k','u0','Polynomial coefficients' + do k = 1, n0 + write(0,'(i3,1p6e24.16)') k,u0(k),ppoly_r_coefs(k,:) + enddo + call MOM_error( FATAL, 'MOM_remapping, '//trim(caller)//': '//& + 'Remapping result is inconsistent!' ) + endif + +end subroutine check_remapped_values + !> Measure totals and bounds on source grid subroutine measure_input_bounds( n0, h0, u0, edge_values, h0tot, h0err, u0tot, u0err, u0min, u0max ) integer, intent(in) :: n0 !< Number of cells on source grid - real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid - real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid - real, dimension(n0,2), intent(in) :: edge_values !< Cell edge values on source grid - real, intent(out) :: h0tot !< Sum of cell widths - real, intent(out) :: h0err !< Magnitude of round-off error in h0tot - real, intent(out) :: u0tot !< Sum of cell widths times values - real, intent(out) :: u0err !< Magnitude of round-off error in u0tot - real, intent(out) :: u0min !< Minimum value in reconstructions of u0 - real, intent(out) :: u0max !< Maximum value in reconstructions of u0 + real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid [H] + real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid [A] + real, dimension(n0,2), intent(in) :: edge_values !< Cell edge values on source grid [A] + real, intent(out) :: h0tot !< Sum of cell widths [H] + real, intent(out) :: h0err !< Magnitude of round-off error in h0tot [H] + real, intent(out) :: u0tot !< Sum of cell widths times values [H A] + real, intent(out) :: u0err !< Magnitude of round-off error in u0tot [H A] + real, intent(out) :: u0min !< Minimum value in reconstructions of u0 [A] + real, intent(out) :: u0max !< Maximum value in reconstructions of u0 [A] ! Local variables + real :: eps ! The smallest representable fraction of a number [nondim] integer :: k - real :: eps eps = epsilon(h0(1)) h0tot = h0(1) @@ -1062,17 +1600,17 @@ end subroutine measure_input_bounds !> Measure totals and bounds on destination grid subroutine measure_output_bounds( n1, h1, u1, h1tot, h1err, u1tot, u1err, u1min, u1max ) integer, intent(in) :: n1 !< Number of cells on destination grid - real, dimension(n1), intent(in) :: h1 !< Cell widths on destination grid - real, dimension(n1), intent(in) :: u1 !< Cell averages on destination grid - real, intent(out) :: h1tot !< Sum of cell widths - real, intent(out) :: h1err !< Magnitude of round-off error in h1tot - real, intent(out) :: u1tot !< Sum of cell widths times values - real, intent(out) :: u1err !< Magnitude of round-off error in u1tot - real, intent(out) :: u1min !< Minimum value in reconstructions of u1 - real, intent(out) :: u1max !< Maximum value in reconstructions of u1 + real, dimension(n1), intent(in) :: h1 !< Cell widths on destination grid [H] + real, dimension(n1), intent(in) :: u1 !< Cell averages on destination grid [A] + real, intent(out) :: h1tot !< Sum of cell widths [H] + real, intent(out) :: h1err !< Magnitude of round-off error in h1tot [H] + real, intent(out) :: u1tot !< Sum of cell widths times values [H A] + real, intent(out) :: u1err !< Magnitude of round-off error in u1tot [H A] + real, intent(out) :: u1min !< Minimum value in reconstructions of u1 [A] + real, intent(out) :: u1max !< Maximum value in reconstructions of u1 [A] ! Local variables + real :: eps ! The smallest representable fraction of a number [nondim] integer :: k - real :: eps eps = epsilon(h1(1)) h1tot = h1(1) @@ -1092,444 +1630,16 @@ subroutine measure_output_bounds( n1, h1, u1, h1tot, h1err, u1tot, u1err, u1min, end subroutine measure_output_bounds -!> Remaps column of values u0 on grid h0 to grid h1 by integrating -!! over the projection of each h1 cell onto the h0 grid. -subroutine remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefs, & - n1, h1, method, u1, h_neglect ) - integer, intent(in) :: n0 !< Number of cells in source grid - real, intent(in) :: h0(:) !< Source grid widths (size n0) - real, intent(in) :: u0(:) !< Source cell averages (size n0) - real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial - real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial - integer, intent(in) :: n1 !< Number of cells in target grid - real, intent(in) :: h1(:) !< Target grid widths (size n1) - integer, intent(in) :: method !< Remapping scheme to use - real, intent(out) :: u1(:) !< Target cell averages (size n1) - real, optional, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h. - ! Local variables - integer :: iTarget - real :: xL, xR ! coordinates of target cell edges - integer :: jStart ! Used by integrateReconOnInterval() - real :: xStart ! Used by integrateReconOnInterval() - - ! Loop on cells in target grid (grid1). For each target cell, we need to find - ! in which source cells the target cell edges lie. The associated indexes are - ! noted j0 and j1. - xR = 0. ! Left boundary is at x=0 - jStart = 1 - xStart = 0. - do iTarget = 1,n1 - ! Determine the coordinates of the target cell edges - xL = xR - xR = xL + h1(iTarget) - - call integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & - xL, xR, h1(iTarget), u1(iTarget), jStart, xStart, h_neglect ) - - enddo ! end iTarget loop on target grid cells - -end subroutine remapByProjection - - -!> Remaps column of values u0 on grid h0 to implied grid h1 -!! where the interfaces of h1 differ from those of h0 by dx. -!! The new grid is defined relative to the original grid by change -!! dx1(:) = xNew(:) - xOld(:) -!! and the remapping calculated so that -!! hNew(k) qNew(k) = hOld(k) qOld(k) + F(k+1) - F(k) -!! where -!! F(k) = dx1(k) qAverage -!! and where qAverage is the average qOld in the region zOld(k) to zNew(k). -subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, dx1, & - method, u1, h1, h_neglect ) - integer, intent(in) :: n0 !< Number of cells in source grid - real, dimension(:), intent(in) :: h0 !< Source grid sizes (size n0) - real, dimension(:), intent(in) :: u0 !< Source cell averages (size n0) - real, dimension(:,:), intent(in) :: ppoly0_E !< Edge value of polynomial - real, dimension(:,:), intent(in) :: ppoly0_coefs !< Coefficients of polynomial - integer, intent(in) :: n1 !< Number of cells in target grid - real, dimension(:), intent(in) :: dx1 !< Target grid edge positions (size n1+1) - integer, intent(in) :: method !< Remapping scheme to use - real, dimension(:), intent(out) :: u1 !< Target cell averages (size n1) - real, dimension(:), & - optional, intent(out) :: h1 !< Target grid widths (size n1) - real, optional, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h. - ! Local variables - integer :: iTarget - real :: xL, xR ! coordinates of target cell edges - real :: xOld, hOld, uOld - real :: xNew, hNew, h_err - real :: uhNew, hFlux, uAve, fluxL, fluxR - integer :: jStart ! Used by integrateReconOnInterval() - real :: xStart ! Used by integrateReconOnInterval() - - ! Loop on cells in target grid. For each cell, iTarget, the left flux is - ! the right flux of the cell to the left, iTarget-1. - ! The left flux is initialized by started at iTarget=0 to calculate the - ! right flux which can take into account the target left boundary being - ! in the interior of the source domain. - fluxR = 0. - h_err = 0. ! For measuring round-off error - jStart = 1 - xStart = 0. - do iTarget = 0,n1 - fluxL = fluxR ! This does nothing for iTarget=0 - - if (iTarget == 0) then - xOld = 0. ! Left boundary is at x=0 - hOld = -1.E30 ! Should not be used for iTarget = 0 - uOld = -1.E30 ! Should not be used for iTarget = 0 - elseif (iTarget <= n0) then - xOld = xOld + h0(iTarget) ! Position of right edge of cell - hOld = h0(iTarget) - uOld = u0(iTarget) - h_err = h_err + epsilon(hOld) * max(hOld, xOld) - else - hOld = 0. ! as if for layers>n0, they were vanished - uOld = 1.E30 ! and the initial value should not matter - endif - xNew = xOld + dx1(iTarget+1) - xL = min( xOld, xNew ) - xR = max( xOld, xNew ) - - ! 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 ) - ! uAve is the average value of u, independent of sign of dx1 - fluxR = dx1(iTarget+1)*uAve ! Includes sign of dx1 - - if (iTarget>0) then - hNew = hOld + ( dx1(iTarget+1) - dx1(iTarget) ) - hNew = max( 0., hNew ) - uhNew = ( uOld * hOld ) + ( fluxR - fluxL ) - if (hNew>0.) then - u1(iTarget) = uhNew / hNew - else - u1(iTarget) = uAve - endif - if (present(h1)) h1(iTarget) = hNew - endif - - enddo ! end iTarget loop on target grid cells - -end subroutine remapByDeltaZ - - -!> Integrate the reconstructed column profile over a single cell -subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & - xL, xR, hC, uAve, jStart, xStart, h_neglect ) - integer, intent(in) :: n0 !< Number of cells in source grid - real, dimension(:), intent(in) :: h0 !< Source grid sizes (size n0) - real, dimension(:), intent(in) :: u0 !< Source cell averages - real, dimension(:,:), intent(in) :: ppoly0_E !< Edge value of polynomial - real, dimension(:,:), intent(in) :: ppoly0_coefs !< Coefficients of polynomial - integer, intent(in) :: method !< Remapping scheme to use - real, intent(in) :: xL !< Left edges of target cell - real, intent(in) :: xR !< Right edges of target cell - real, intent(in) :: hC !< Cell width hC = xR - xL - real, intent(out) :: uAve !< Average value on target cell - integer, intent(inout) :: jStart !< The index of the cell to start searching from - !< On exit, contains index of last cell used - real, intent(inout) :: xStart !< The left edge position of cell jStart - !< On first entry should be 0. - real, optional, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h. - ! Local variables - integer :: j, k - integer :: jL, jR ! indexes of source cells containing target - ! cell edges - real :: q ! complete integration - real :: xi0, xi1 ! interval of integration (local -- normalized - ! -- coordinates) - real :: x0jLl, x0jLr ! Left/right position of cell jL - real :: x0jRl, x0jRr ! Left/right position of cell jR - real :: hAct ! The distance actually used in the integration - ! (notionally xR - xL) which differs due to roundoff. - real :: x0_2, x1_2, x02px12, x0px1 ! Used in evaluation of integrated polynomials - real :: hNeglect ! A negligible thicness in the same units as h. - real, parameter :: r_3 = 1.0/3.0 ! Used in evaluation of integrated polynomials - - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - - q = -1.E30 - x0jLl = -1.E30 - x0jRl = -1.E30 - - ! Find the left most cell in source grid spanned by the target cell - jL = -1 - x0jLr = xStart - do j = jStart, n0 - x0jLl = x0jLr - x0jLr = x0jLl + h0(j) - ! Left edge is found in cell j - if ( ( xL >= x0jLl ) .AND. ( xL <= x0jLr ) ) then - jL = j - exit ! once target grid cell is found, exit loop - endif - enddo - jStart = jL - xStart = x0jLl - -! ! HACK to handle round-off problems. Need only at j=n0. -! ! This moves the effective cell boundary outwards a smidgen. -! if (xL>x0jLr) x0jLr = xL - - ! If, at this point, jL is equal to -1, it means the vanished - ! cell lies outside the source grid. In other words, it means that - ! the source and target grids do not cover the same physical domain - ! and there is something very wrong ! - if ( jL == -1 ) call MOM_error(FATAL, & - 'MOM_remapping, integrateReconOnInterval: '//& - 'The location of the left-most cell could not be found') - - - ! ============================================================ - ! Check whether target cell is vanished. If it is, the cell - ! average is simply the interpolated value at the location - ! of the vanished cell. If it isn't, we need to integrate the - ! quantity within the cell and divide by the cell width to - ! determine the cell average. - ! ============================================================ - ! 1. Cell is vanished - !if ( abs(xR - xL) <= epsilon(xR)*max(abs(xR),abs(xL)) ) then - if ( abs(xR - xL) == 0.0 ) then - - ! We check whether the source cell (i.e. the cell in which the - ! vanished target cell lies) is vanished. If it is, the interpolated - ! value is set to be mean of the edge values (which should be the same). - ! If it isn't, we simply interpolate. - if ( h0(jL) == 0.0 ) then - 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 ) - - select case ( method ) - case ( INTEGRATION_PCM ) - uAve = ppoly0_coefs(jL,1) - case ( INTEGRATION_PLM ) - uAve = ppoly0_coefs(jL,1) & - + xi0 * ppoly0_coefs(jL,2) - case ( INTEGRATION_PPM ) - uAve = ppoly0_coefs(jL,1) & - + xi0 * ( ppoly0_coefs(jL,2) & - + xi0 * ppoly0_coefs(jL,3) ) - case ( INTEGRATION_PQM ) - uAve = ppoly0_coefs(jL,1) & - + xi0 * ( ppoly0_coefs(jL,2) & - + xi0 * ( ppoly0_coefs(jL,3) & - + xi0 * ( ppoly0_coefs(jL,4) & - + xi0 * ppoly0_coefs(jL,5) ) ) ) - case default - call MOM_error( FATAL,'The selected integration method is invalid' ) - end select - - endif ! end checking whether source cell is vanished - - ! 2. Cell is not vanished - else - - ! Find the right most cell in source grid spanned by the target cell - jR = -1 - x0jRr = xStart - do j = jStart,n0 - x0jRl = x0jRr - x0jRr = x0jRl + h0(j) - ! Right edge is found in cell j - if ( ( xR >= x0jRl ) .AND. ( xR <= x0jRr ) ) then - jR = j - exit ! once target grid cell is found, exit loop - endif - enddo ! end loop on source grid cells - - ! If xR>x0jRr then the previous loop reached j=n0 and the target - ! position, xR, was beyond the right edge of the source grid (h0). - ! This can happen due to roundoff, in which case we set jR=n0. - if (xR>x0jRr) jR = n0 - - ! To integrate, two cases must be considered: (1) the target cell is - ! entirely contained within a cell of the source grid and (2) the target - ! cell spans at least two cells of the source grid. - - if ( jL == jR ) then - ! The target cell is entirely contained within a cell of the source - ! grid. This situation is represented by the following schematic, where - ! the cell in which xL and xR are located has index jL=jR : - ! - ! ----|-----o--------o----------|------------- - ! xL xR - ! - ! 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 ) ) ) -#else - xi0 = xL / h0(jL) - x0jLl / ( h0(jL) + hNeglect ) - xi1 = xR / h0(jL) - x0jLl / ( h0(jL) + hNeglect ) -#endif - - hAct = h0(jL) * ( xi1 - xi0 ) - - ! Depending on which polynomial is used, integrate quantity - ! between xi0 and xi1. Integration is carried out in normalized - ! coordinates, hence: \int_xL^xR p(x) dx = h \int_xi0^xi1 p(xi) dxi - select case ( method ) - case ( INTEGRATION_PCM ) - q = ( xR - xL ) * ppoly0_coefs(jL,1) - case ( INTEGRATION_PLM ) - q = ( xR - xL ) * ( & - ppoly0_coefs(jL,1) & - + ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) ) - case ( INTEGRATION_PPM ) - q = ( xR - xL ) * ( & - ppoly0_coefs(jL,1) & - + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & - + ppoly0_coefs(jL,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) - case ( INTEGRATION_PQM ) - x0_2 = xi0*xi0 - x1_2 = xi1*xi1 - x02px12 = x0_2 + x1_2 - x0px1 = xi1 + xi0 - q = ( xR - xL ) * ( & - ppoly0_coefs(jL,1) & - + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & - + ( ppoly0_coefs(jL,3) * r_3 * ( x02px12 + xi0*xi1 ) & - + ppoly0_coefs(jL,4) * 0.25* ( x02px12 * x0px1 ) & - + ppoly0_coefs(jL,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) - case default - call MOM_error( FATAL,'The selected integration method is invalid' ) - end select - - else - ! The target cell spans at least two cells of the source grid. - ! This situation is represented by the following schematic, where - ! the cells in which xL and xR are located have indexes jL and jR, - ! respectively : - ! - ! ----|-----o---|--- ... --|---o----------|------------- - ! xL xR - ! - ! We first integrate from xL up to the right boundary of cell jL, then - ! add the integrated amounts of cells located between jL and jR and then - ! integrate from the left boundary of cell jR up to xR - - q = 0.0 - - ! 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 ) ) ) -#else - xi0 = (xL - x0jLl) / ( h0(jL) + hNeglect ) -#endif - xi1 = 1.0 - - hAct = h0(jL) * ( xi1 - xi0 ) - - select case ( method ) - case ( INTEGRATION_PCM ) - q = q + ( x0jLr - xL ) * ppoly0_coefs(jL,1) - case ( INTEGRATION_PLM ) - q = q + ( x0jLr - xL ) * ( & - ppoly0_coefs(jL,1) & - + ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) ) - case ( INTEGRATION_PPM ) - q = q + ( x0jLr - xL ) * ( & - ppoly0_coefs(jL,1) & - + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & - + ppoly0_coefs(jL,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) - case ( INTEGRATION_PQM ) - x0_2 = xi0*xi0 - x1_2 = xi1*xi1 - x02px12 = x0_2 + x1_2 - x0px1 = xi1 + xi0 - q = q + ( x0jLr - xL ) * ( & - ppoly0_coefs(jL,1) & - + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & - + ( ppoly0_coefs(jL,3) * r_3 * ( x02px12 + xi0*xi1 ) & - + ppoly0_coefs(jL,4) * 0.25* ( x02px12 * x0px1 ) & - + ppoly0_coefs(jL,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) - case default - call MOM_error( FATAL, 'The selected integration method is invalid' ) - end select - - ! Integrate contents within cells strictly comprised between jL and jR - if ( jR > (jL+1) ) then - do k = jL+1,jR-1 - q = q + h0(k) * u0(k) - hAct = hAct + h0(k) - enddo - endif - - ! 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 ) ) ) -#else - xi1 = (xR - x0jRl) / ( h0(jR) + hNeglect ) -#endif - - hAct = hAct + h0(jR) * ( xi1 - xi0 ) - - select case ( method ) - case ( INTEGRATION_PCM ) - q = q + ( xR - x0jRl ) * ppoly0_coefs(jR,1) - case ( INTEGRATION_PLM ) - q = q + ( xR - x0jRl ) * ( & - ppoly0_coefs(jR,1) & - + ppoly0_coefs(jR,2) * 0.5 * ( xi1 + xi0 ) ) - case ( INTEGRATION_PPM ) - q = q + ( xR - x0jRl ) * ( & - ppoly0_coefs(jR,1) & - + ( ppoly0_coefs(jR,2) * 0.5 * ( xi1 + xi0 ) & - + ppoly0_coefs(jR,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) - case ( INTEGRATION_PQM ) - x0_2 = xi0*xi0 - x1_2 = xi1*xi1 - x02px12 = x0_2 + x1_2 - x0px1 = xi1 + xi0 - q = q + ( xR - x0jRl ) * ( & - ppoly0_coefs(jR,1) & - + ( ppoly0_coefs(jR,2) * 0.5 * ( xi1 + xi0 ) & - + ( ppoly0_coefs(jR,3) * r_3 * ( x02px12 + xi0*xi1 ) & - + ppoly0_coefs(jR,4) * 0.25* ( x02px12 * x0px1 ) & - + ppoly0_coefs(jR,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) - case default - call MOM_error( FATAL,'The selected integration method is invalid' ) - end select - - endif ! end integration for non-vanished cells - - ! The cell average is the integrated value divided by the cell width -#ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ -if (hAct==0.) then - uAve = ppoly0_coefs(jL,1) -else - uAve = q / hAct -endif -#else - uAve = q / hC -#endif - - endif ! endif clause to check if cell is vanished - -end subroutine integrateReconOnInterval - !> Calculates the change in interface positions based on h1 and h2 subroutine dzFromH1H2( n1, h1, n2, h2, dx ) integer, intent(in) :: n1 !< Number of cells on source grid - real, dimension(:), intent(in) :: h1 !< Cell widths of source grid (size n1) + real, dimension(:), intent(in) :: h1 !< Cell widths of source grid (size n1) [H] integer, intent(in) :: n2 !< Number of cells on target grid - real, dimension(:), intent(in) :: h2 !< Cell widths of target grid (size n2) - real, dimension(:), intent(out) :: dx !< Change in interface position (size n2+1) + real, dimension(:), intent(in) :: h2 !< Cell widths of target grid (size n2) [H] + real, dimension(:), intent(out) :: dx !< Change in interface position (size n2+1) [H] ! Local variables integer :: k - real :: x1, x2 + real :: x1, x2 ! Interface positions [H] x1 = 0. x2 = 0. @@ -1546,7 +1656,10 @@ end subroutine dzFromH1H2 !> Constructor for remapping control structure subroutine initialize_remapping( CS, remapping_scheme, boundary_extrapolation, & - check_reconstruction, check_remapping, force_bounds_in_subcell, answers_2018) + check_reconstruction, check_remapping, force_bounds_in_subcell, & + force_bounds_in_target, better_force_bounds_in_target, offset_tgt_summation, & + om4_remap_via_sub_cells, answers_2018, answer_date, nk, & + 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 @@ -1554,12 +1667,34 @@ subroutine initialize_remapping( CS, remapping_scheme, boundary_extrapolation, & logical, optional, intent(in) :: check_reconstruction !< Indicate to check reconstructions logical, optional, intent(in) :: check_remapping !< Indicate to check results of remapping logical, optional, intent(in) :: force_bounds_in_subcell !< Force subcells values to be bounded - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + logical, optional, intent(in) :: force_bounds_in_target !< Force target values to be bounded + logical, optional, intent(in) :: better_force_bounds_in_target !< Force target values to be bounded + logical, optional, intent(in) :: offset_tgt_summation !< Use an offset when summing sub-cells + 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]. + integer, optional, intent(in) :: nk !< Number of levels to initialize reconstruction class with ! Note that remapping_scheme is mandatory for initialize_remapping() - call remapping_set_param(CS, remapping_scheme=remapping_scheme, boundary_extrapolation=boundary_extrapolation, & - check_reconstruction=check_reconstruction, check_remapping=check_remapping, & - force_bounds_in_subcell=force_bounds_in_subcell, answers_2018=answers_2018) + 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, & + force_bounds_in_target=force_bounds_in_target, & + better_force_bounds_in_target=better_force_bounds_in_target, & + offset_tgt_summation=offset_tgt_summation, & + answers_2018=answers_2018, & + answer_date=answer_date, & + nk=nk, & + h_neglect=h_neglect, & + h_neglect_edge=h_neglect_edge) end subroutine initialize_remapping @@ -1573,6 +1708,15 @@ subroutine setReconstructionType(string,CS) ! Local variables integer :: degree degree = -99 + if (associated(CS%reconstruction)) then + ! We have a choice of being careless and allowing easy re-use (e.g. when testing) + CS%remapping_scheme = -911 + call CS%reconstruction%destroy() + deallocate( CS%reconstruction ) + ! or being careful and make sure we've properly clean up... + ! call MOM_error(FATAL, "setReconstructionType: "//& + ! "Recon1d type is already associated when initializing.") + endif select case ( uppercase(trim(string)) ) case ("PCM") CS%remapping_scheme = REMAPPING_PCM @@ -1580,18 +1724,81 @@ subroutine setReconstructionType(string,CS) case ("PLM") CS%remapping_scheme = REMAPPING_PLM degree = 1 + case ("PLM_HYBGEN") + CS%remapping_scheme = REMAPPING_PLM_HYBGEN + degree = 1 + case ("PPM_CW") + CS%remapping_scheme = REMAPPING_PPM_CW + degree = 2 case ("PPM_H4") CS%remapping_scheme = REMAPPING_PPM_H4 degree = 2 case ("PPM_IH4") CS%remapping_scheme = REMAPPING_PPM_IH4 degree = 2 + case ("PPM_HYBGEN") + CS%remapping_scheme = REMAPPING_PPM_HYBGEN + degree = 2 + case ("WENO_HYBGEN") + CS%remapping_scheme = REMAPPING_WENO_HYBGEN + degree = 2 case ("PQM_IH4IH3") CS%remapping_scheme = REMAPPING_PQM_IH4IH3 degree = 4 case ("PQM_IH6IH5") CS%remapping_scheme = REMAPPING_PQM_IH6IH5 degree = 4 + case ("C_PCM") + allocate( PCM :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_PLM_CW") + allocate( PLM_CW :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_PLM_HYBGEN") + allocate( PLM_hybgen :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_MPLM_WA") + allocate( MPLM_WA :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_EMPLM_WA") + allocate( EMPLM_WA :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_MPLM_WA_POLY") + allocate( MPLM_WA_poly :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_EMPLM_WA_POLY") + allocate( EMPLM_WA_poly :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_PLM_CWK") + allocate( PLM_CWK :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_MPLM_CWK") + allocate( MPLM_CWK :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_EMPLM_CWK") + allocate( EMPLM_CWK :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_PPM_CW") + allocate( PPM_CW :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_PPM_HYBGEN") + allocate( PPM_hybgen :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_PPM_CWK") + allocate( PPM_CWK :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_EPPM_CWK") + allocate( EPPM_CWK :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_PPM_H4_2019") + allocate( PPM_H4_2019 :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_PPM_H4_2018") + allocate( PPM_H4_2018 :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_PLM_WLS") + allocate( PLM_WLS :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS case default call MOM_error(FATAL, "setReconstructionType: "//& "Unrecognized choice for REMAPPING_SCHEME ("//trim(string)//").") @@ -1609,322 +1816,1142 @@ subroutine end_remapping(CS) end subroutine end_remapping -!> Runs unit tests on remapping functions. -!! Should only be called from a single/root thread -!! Returns True if a test fails, otherwise False -logical function remapping_unit_tests(verbose) - logical, intent(in) :: verbose !< If true, write results to stdout +!> Test if interpolate_column() produces the wrong answer +subroutine test_interp(test, msg, nsrc, h_src, u_src, ndest, h_dest, u_true) + type(testing), intent(inout) :: test !< Unit testing convenience functions + character(len=*), intent(in) :: msg !< Message to label test + integer, intent(in) :: nsrc !< Number of source cells + real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] + real, dimension(nsrc+1), intent(in) :: u_src !< Values at source cell interfaces [A] + integer, intent(in) :: ndest !< Number of destination cells + real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] + real, dimension(ndest+1), intent(in) :: u_true !< Correct value at destination cell interfaces [A] + ! Local variables + real, dimension(ndest+1) :: u_dest ! Interpolated value at destination cell interfaces [A] + + ! Interpolate from src to dest + call interpolate_column(nsrc, h_src, u_src, ndest, h_dest, u_dest, .true.) + call test%real_arr(ndest, u_dest, u_true, msg) +end subroutine test_interp + +!> Test if reintegrate_column() produces the wrong answer +subroutine test_reintegrate(test, msg, nsrc, h_src, uh_src, ndest, h_dest, uh_true) + type(testing), intent(inout) :: test !< Unit testing convenience functions + character(len=*), intent(in) :: msg !< Message to label test + integer, intent(in) :: nsrc !< Number of source cells + real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] + real, dimension(nsrc), intent(in) :: uh_src !< Values of source cell stuff [A H] + integer, intent(in) :: ndest !< Number of destination cells + real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] + real, dimension(ndest), intent(in) :: uh_true !< Correct value of destination cell stuff [A H] ! Local variables - integer, parameter :: n0 = 4, n1 = 3, n2 = 6 - real :: h0(n0), x0(n0+1), u0(n0) - real :: h1(n1), x1(n1+1), u1(n1), hn1(n1), dx1(n1+1) - real :: h2(n2), x2(n2+1), u2(n2), hn2(n2), dx2(n2+1) - data u0 /9., 3., -3., -9./ ! Linear profile, 4 at surface to -4 at bottom - data h0 /4*0.75/ ! 4 uniform layers with total depth of 3 - data h1 /3*1./ ! 3 uniform layers with total depth of 3 - data h2 /6*0.5/ ! 6 uniform layers with total depth of 3 - type(remapping_CS) :: CS !< Remapping control structure - real, allocatable, dimension(:,:) :: ppoly0_E, ppoly0_S, ppoly0_coefs - logical :: answers_2018 ! If true use older, less acccurate expressions. - integer :: i - real :: err, h_neglect, h_neglect_edge - logical :: thisTest, v - - v = verbose - answers_2018 = .false. ! .true. - h_neglect = hNeglect_dflt - h_neglect_edge = hNeglect_dflt ; if (answers_2018) h_neglect_edge = 1.0e-10 - - write(stdout,*) '==== MOM_remapping: remapping_unit_tests =================' - remapping_unit_tests = .false. ! Normally return false - - thisTest = .false. - call buildGridFromH(n0, h0, x0) - do i=1,n0+1 - err=x0(i)-0.75*real(i-1) - if (abs(err)>real(i-1)*epsilon(err)) thisTest = .true. + real, dimension(ndest) :: uh_dest ! Reintegrated value on destination cells [A H] + + ! Interpolate from src to dest + call reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, uh_dest) + call test%real_arr(ndest, uh_dest, uh_true, msg) + +end subroutine test_reintegrate + +!> Test class-based remapping for internal consistency on random data +subroutine test_recon_consistency(test, scheme, n0, niter, h_neglect) + type(testing), intent(inout) :: test !< Unit testing convenience functions + character(len=*), intent(in) :: scheme !< Name of scheme to use + integer, intent(in) :: n0 !< Number of source cells + integer, intent(in) :: niter !< Number of randomized columns to try + real, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H] + ! Local + type(remapping_CS) :: remapCS !< Remapping control structure + real :: h0(n0) ! Source grid [H but really nondim] + real :: u0(n0) ! Source values [A] + logical :: error ! Indicates a divergence + integer :: iter ! Loop counter + integer :: seed_size ! Number of integers used by seed + integer, allocatable :: seed(:) ! Random number seed + character(len=16) :: label ! Generated label + + call initialize_remapping(remapCS, scheme, nk=n0, h_neglect=h_neglect, & + force_bounds_in_subcell=.false. ) + + call random_seed(size=seed_size) + allocate( seed(seed_Size) ) + seed(:) = 102030405 ! Repeatable sequences + call random_seed(put=seed) + + error = .false. + do iter = 1, niter + call random_number( h0 ) ! In range 0-1 + h0(:) = max(0., h0(:) - 0.05) ! Make 5% of values equal to zero + call random_number( u0 ) ! In range 0-1 + + call remapCS%reconstruction%reconstruct(h0, u0) + if ( remapCS%reconstruction%check_reconstruction(h0, u0) ) then + if ( .not. error ) then ! Only dump first error + print *,'iter=',iter + print *,'h0',h0 + print *,'u0',u0 + endif + error = .true. + endif + enddo - if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed buildGridFromH() 1' - remapping_unit_tests = remapping_unit_tests .or. thisTest - call buildGridFromH(n1, h1, x1) - do i=1,n1+1 - err=x1(i)-real(i-1) - if (abs(err)>real(i-1)*epsilon(err)) thisTest = .true. + + write(label,'(I0)') niter + call test%test( error, trim(label)//' consistency tests of '//scheme ) + + call remapCS%reconstruction%destroy() + +end subroutine test_recon_consistency + +!> Test that remapping a uniform field remains uniform +subroutine test_preserve_uniform(test, scheme, n0, niter, h_neglect) + type(testing), intent(inout) :: test !< Unit testing convenience functions + character(len=*), intent(in) :: scheme !< Name of scheme to use + integer, intent(in) :: n0 !< Number of source cells + integer, intent(in) :: niter !< Number of randomized columns to try + real, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H] + ! Local + type(remapping_CS) :: remapCS !< Remapping control structure + real :: h0(n0), h1(n0) ! Source and target grids [H but really nondim] + real :: u0(n0), u1(n0) ! Source and target values [A] + logical :: error ! Indicates a divergence + integer :: iter ! Loop counter + integer :: seed_size ! Number of integers used by seed + integer, allocatable :: seed(:) ! Random number seed + character(len=16) :: label ! Generated label + + call initialize_remapping(remapCS, scheme, nk=n0, h_neglect=h_neglect, & + force_bounds_in_subcell=.true., & + force_bounds_in_target=.true., & + better_force_bounds_in_target=.true., & + offset_tgt_summation=.false., & + om4_remap_via_sub_cells=.false.) + + call random_seed(size=seed_size) + allocate( seed(seed_Size) ) + seed(:) = 102030405 ! Repeatable sequences + call random_seed(put=seed) + + error = .false. + do iter = 1, niter + call random_number( h0 ) ! In range 0-1 + h0(:) = max(0., h0(:) - 0.05) ! Make 5% of values equal to zero + call random_number( h1 ) ! In range 0-1 + h1(:) = max(0., h1(:) - 0.05) ! Make 5% of values equal to zero + call random_number( u0(1) ) ! In range 0-1 + u0(:) = u0(1) ! Make u0 uniform + + call remapping_core_h( remapCS, n0, h0, u0, n0, h1, u1 ) + if ( maxval( abs( u1(:) - u0(1) ) ) > 0. ) then + if ( .not. error ) then ! Only dump first error + print *,'iter=',iter + print *,'u0(1)',u0(1) + print *,'u1',u1 + print *,'u1-u0(1)',u1 - u0(1) + endif + error = .true. + endif + enddo - if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed buildGridFromH() 2' - remapping_unit_tests = remapping_unit_tests .or. thisTest - thisTest = .false. - call initialize_remapping(CS, 'PPM_H4', answers_2018=answers_2018) - if (verbose) write(stdout,*) 'h0 (test data)' - if (verbose) call dumpGrid(n0,h0,x0,u0) + write(label,'(I0)') niter + call test%test( error, trim(label)//' uniformity tests of '//scheme ) + +end subroutine test_preserve_uniform + +!> Test that remapping to the same grid preserves answers +!! +!! Notes: +!! 1) this test is currently imperfect since occasionally we see round-off +!! implying that ( A * B ) / A != B +!! 2) this test does not work for vanished layers +subroutine test_unchanged_grid(test, scheme, n0, niter, h_neglect) + type(testing), intent(inout) :: test !< Unit testing convenience functions + character(len=*), intent(in) :: scheme !< Name of scheme to use + integer, intent(in) :: n0 !< Number of source cells + integer, intent(in) :: niter !< Number of randomized columns to try + real, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H] + ! Local + type(remapping_CS) :: remapCS !< Remapping control structure + real :: h0(n0), h1(n0) ! Source and target grids [H but really nondim] + real :: u0(n0), u1(n0) ! Source and target values [A] + logical :: error ! Indicates a divergence + integer :: iter ! Loop counter + character(len=16) :: label ! Generated label + + call initialize_remapping(remapCS, scheme, nk=n0, h_neglect=h_neglect, & + force_bounds_in_subcell=.true., & + force_bounds_in_target=.false., & + better_force_bounds_in_target=.true., & + offset_tgt_summation=.true., & + om4_remap_via_sub_cells=.false.) + + error = .false. + do iter = 1, niter + call random_number( h0 ) ! In range 0-1 + h0(:) = max(0., h0(:) - 0.00) ! Note we do NOT test with vanished layers + h1(:) = h0(:) ! Exact copy + call random_number( u0 ) ! In range 0-1 + + call remapping_core_h( remapCS, n0, h0, u0, n0, h1, u1 ) + if ( maxval( abs( u1(:) - u0(:) ) ) > epsilon(h0(1)) * maxval( abs( u0 ) ) ) then + if ( .not. error ) then ! Only dump first error + print *,'iter=',iter + print *,'h0',h0 + print *,'u0',u0 + print *,'u1',u1 + print *,'u1-u0',u1 - u0 + endif + error = .true. + endif - call dzFromH1H2( n0, h0, n1, h1, dx1 ) - call remapping_core_w( CS, n0, h0, u0, n1, dx1, u1, h_neglect, h_neglect_edge) - do i=1,n1 - err=u1(i)-8.*(0.5*real(1+n1)-real(i)) - if (abs(err)>real(n1-1)*epsilon(err)) thisTest = .true. enddo - if (verbose) write(stdout,*) 'h1 (by projection)' - if (verbose) call dumpGrid(n1,h1,x1,u1) - if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed remapping_core_w()' - remapping_unit_tests = remapping_unit_tests .or. thisTest - thisTest = .false. - allocate(ppoly0_E(n0,2)) - allocate(ppoly0_S(n0,2)) - allocate(ppoly0_coefs(n0,CS%degree+1)) + write(label,'(I0)') niter + call test%test( error, trim(label)//' unchanged grid tests of '//scheme ) + + call remapCS%reconstruction%destroy() + +end subroutine test_unchanged_grid + +!> Test class-based remapping bitwise reproduces original implementation +subroutine compare_two_schemes(test, CS1, CS2, n0, n1, niter, msg) + type(testing), intent(inout) :: test !< Unit testing convenience functions + type(remapping_CS), intent(inout) :: CS1 !< Remapping control structure configured for + !! original implementation + type(remapping_CS), intent(inout) :: CS2 !< Remapping control structure configured for + !! class-based implementation + integer, intent(in) :: n0 !< Number of source cells + integer, intent(in) :: n1 !< Number of destination cells + integer, intent(in) :: niter !< Number of randomized columns to try + character(len=*), intent(in) :: msg !< Message to label test + ! Local + real :: h0(n0), h1(n1) ! Source and target grids [H but really nondim] + real :: u0(n0), u1(n1), u2(n1) ! Source and two target values [A] + logical :: error ! Indicates a divergence + integer :: iter ! Loop counter + integer :: seed_size ! Number of integers used by seed + integer, allocatable :: seed(:) ! Random number seed + character(len=16) :: label ! Generated label + + call random_seed(size=seed_size) + allocate( seed(seed_Size) ) + seed(:) = 102030405 ! Repeatable sequences + call random_seed(put=seed) + + error = .false. + do iter = 1, niter + call random_number( h0 ) ! In range 0-1 + h0(:) = max(0., h0(:) - 0.00) ! Make 5% of values equal to zero + h0(:) = h0(:) / sum( h0 ) ! Approximately normalize to total depth of 1 + call random_number(h1) ! In range 0-1 + h1(:) = max(0., h1(:) - 0.00) ! Make 5% of values equal to zero + h1(:) = h1(:) / sum( h1 ) ! Approximately normalize to total depth of 1 + call random_number( u0 ) ! In range 0-1 + + call remapping_core_h( CS1, n0, h0, u0, n1, h1, u1 ) + call remapping_core_h( CS2, n0, h0, u0, n1, h1, u2 ) + error = sum( abs( u2(:) - u1(:) ) ) > 0. + if (error) then + print *,'iter=',iter + print *,'h1',h1 + print *,'h0',h0 + print *,'u0',u0 + print *,'u1',u1 + print *,'u2',u2 + print *,'e',u2-u1 + ! CS1%debug = .true. + ! call remapping_core_h( CS1, n0, h0, u0, n1, h1, u1 ) + ! CS2%debug = .true. + ! call remapping_core_h( CS2, n0, h0, u0, n1, h1, u2 ) + exit + endif + enddo + + write(label,'(I0)') niter + call test%test( error, trim(label)//' comparisons of '//msg ) +end subroutine compare_two_schemes + +!> Runs unit tests on remapping functions. +!! Should only be called from a single/root thread +!! Returns True if a test fails, otherwise False +logical function remapping_unit_tests(verbose, num_comp_samp) + logical, intent(in) :: verbose !< If true, write results to stdout + integer, optional, intent(in) :: num_comp_samp !< If present, number of samples to + !! try comparing class-based cade against OM4 code + ! Local variables + integer :: n0, n1, n2 + real, allocatable :: h0(:), h1(:), h2(:) ! Thicknesses for test columns [H] + real, allocatable :: u0(:), u1(:), u2(:) ! Values for test profiles [A] + real, allocatable :: dx1(:) ! Change in interface position [H] + type(remapping_CS) :: CS, CS2 !< Remapping control structures + real, allocatable, dimension(:,:) :: ppoly0_E ! Edge values of polynomials [A] + real, allocatable, dimension(:,:) :: ppoly0_S ! Edge slopes of polynomials [A H-1] + real, allocatable, dimension(:,:) :: ppoly0_coefs ! Coefficients of polynomials [A] + real, allocatable, dimension(:) :: h_sub, h0_eff ! Subgrid and effective source thicknesses [H] + real, allocatable, dimension(:) :: u_sub, uh_sub ! Subgrid values and totals [A, A H] + real :: u02_err ! Error in remaping [A] + integer, allocatable, dimension(:) :: isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ! Indices + integer :: answer_date ! The vintage of the expressions to test + real :: err ! Errors in the remapped thicknesses [H] or values [A] + real :: h_neglect, h_neglect_edge ! Tiny thicknesses used in remapping [H] + integer :: seed_size ! Number of integers used by seed + integer, allocatable :: seed(:) ! Random number seed + type(testing) :: test ! Unit testing convenience functions + integer :: om4 ! Loop parameter, 0 or 1 + integer :: ntests ! Number of iterations when brute force testing + character(len=4) :: om4_tag ! Generated label + type(PCM) :: PCM_instance + type(PLM_CW) :: PLM_CW_instance + type(PLM_hybgen) :: PLM_hybgen_instance + type(MPLM_WA) :: MPLM_WA_instance + type(EMPLM_WA) :: EMPLM_WA_instance + type(MPLM_WA_poly) :: MPLM_WA_poly_instance + type(EMPLM_WA_poly) :: EMPLM_WA_poly_instance + type(PLM_CWK) :: PLM_CWK_instance + type(MPLM_CWK) :: MPLM_CWK_instance + type(EMPLM_CWK) :: EMPLM_CWK_instance + type(PPM_H4_2019) :: PPM_H4_2019_instance + type(PPM_H4_2018) :: PPM_H4_2018_instance + type(PPM_CW) :: PPM_CW_instance + type(PPM_hybgen) :: PPM_hybgen_instance + type(PPM_CWK) :: PPM_CWK_instance + type(EPPM_CWK) :: EPPM_CWK_instance + type(PLM_WLS) :: PLM_WLS_instance + + call test%set( verbose=verbose ) ! Sets the verbosity flag in test +! call test%set( stop_instantly=.true. ) ! While debugging + + answer_date = 20190101 ! 20181231 + 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 =================' + + if (verbose) write(test%stdout,*) ' - - - - - 1st generation tests - - - - -' + + 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 + allocate( h0(n0), u0(n0) ) + h0 = (/0.75, 0.75, 0.75, 0.75/) + u0 = (/9., 3., -3., -9./) + + ! Profile 1: 3 layers of thickness 1.0 and total depth 3 + n1 = 3 + allocate( h1(n1), u1(n1), dx1(n1+1) ) + h1 = (/1.0, 1.0, 1.0/) + + ! Profile 2: 6 layers of thickness 0.5 and total depth 3 + n2 = 6 + allocate( h2(n2), u2(n2) ) + h2 = (/0.5, 0.5, 0.5, 0.5, 0.5, 0.5/) + + ! Mapping u1 from h1 to h2 + call dzFromH1H2( n0, h0, n1, h1, dx1 ) + call remapping_core_w( CS, n0, h0, u0, n1, dx1, u1 ) + call test%real_arr(3, u1, (/8.,0.,-8./), 'remapping_core_w() PPM_H4') + + allocate(ppoly0_E(n0,2), ppoly0_S(n0,2), ppoly0_coefs(n0,CS%degree+1)) ppoly0_E(:,:) = 0.0 ppoly0_S(:,:) = 0.0 ppoly0_coefs(:,:) = 0.0 - call edge_values_explicit_h4( n0, h0, u0, ppoly0_E, h_neglect=1e-10, answers_2018=answers_2018 ) - call PPM_reconstruction( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect, answers_2018=answers_2018 ) - call PPM_boundary_extrapolation( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) - u1(:) = 0. - call remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefs, & - n1, h1, INTEGRATION_PPM, u1, h_neglect ) - do i=1,n1 - err=u1(i)-8.*(0.5*real(1+n1)-real(i)) - if (abs(err)>2.*epsilon(err)) thisTest = .true. - enddo - if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed remapByProjection()' - remapping_unit_tests = remapping_unit_tests .or. thisTest - - thisTest = .false. - u1(:) = 0. - call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, & - n1, x1-x0(1:n1+1), & - INTEGRATION_PPM, u1, hn1, h_neglect ) - if (verbose) write(stdout,*) 'h1 (by delta)' - if (verbose) call dumpGrid(n1,h1,x1,u1) - hn1=hn1-h1 - do i=1,n1 - err=u1(i)-8.*(0.5*real(1+n1)-real(i)) - if (abs(err)>2.*epsilon(err)) thisTest = .true. - enddo - if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed remapByDeltaZ() 1' - remapping_unit_tests = remapping_unit_tests .or. thisTest - - thisTest = .false. - call buildGridFromH(n2, h2, x2) - dx2(1:n0+1) = x2(1:n0+1) - x0 - dx2(n0+2:n2+1) = x2(n0+2:n2+1) - x0(n0+1) - call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, & - n2, dx2, & - INTEGRATION_PPM, u2, hn2, h_neglect ) - if (verbose) write(stdout,*) 'h2' - if (verbose) call dumpGrid(n2,h2,x2,u2) - if (verbose) write(stdout,*) 'hn2' - if (verbose) call dumpGrid(n2,hn2,x2,u2) - - do i=1,n2 - err=u2(i)-8./2.*(0.5*real(1+n2)-real(i)) - if (abs(err)>2.*epsilon(err)) thisTest = .true. - enddo - if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed remapByDeltaZ() 2' - remapping_unit_tests = remapping_unit_tests .or. thisTest - - if (verbose) write(stdout,*) 'Via sub-cells' - thisTest = .false. - call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & - n2, h2, INTEGRATION_PPM, .false., u2, err ) - if (verbose) call dumpGrid(n2,h2,x2,u2) - - do i=1,n2 - err=u2(i)-8./2.*(0.5*real(1+n2)-real(i)) - if (abs(err)>2.*epsilon(err)) thisTest = .true. - enddo - if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed remap_via_sub_cells() 2' - remapping_unit_tests = remapping_unit_tests .or. thisTest - - call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & - 6, (/.125,.125,.125,.125,.125,.125/), INTEGRATION_PPM, .false., u2, err ) - if (verbose) call dumpGrid(6,h2,x2,u2) - - call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & - 3, (/2.25,1.5,1./), INTEGRATION_PPM, .false., u2, err ) - if (verbose) call dumpGrid(3,h2,x2,u2) - - if (.not. remapping_unit_tests) write(stdout,*) 'Pass' - - write(stdout,*) '===== MOM_remapping: new remapping_unit_tests ==================' - - deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs) - allocate(ppoly0_coefs(5,6)) - allocate(ppoly0_E(5,2)) - allocate(ppoly0_S(5,2)) - - call PCM_reconstruction(3, (/1.,2.,4./), ppoly0_E(1:3,:), & - ppoly0_coefs(1:3,:) ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,4./), 'PCM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,2), (/1.,2.,4./), 'PCM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,1), (/1.,2.,4./), 'PCM: P0') - - call PLM_reconstruction(3, (/1.,1.,1./), (/1.,3.,5./), ppoly0_E(1:3,:), & - ppoly0_coefs(1:3,:), h_neglect ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,5./), 'Unlim PLM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,2), (/1.,4.,5./), 'Unlim PLM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,1), (/1.,2.,5./), 'Unlim PLM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Unlim PLM: P1') - - call PLM_reconstruction(3, (/1.,1.,1./), (/1.,2.,7./), ppoly0_E(1:3,:), & - ppoly0_coefs(1:3,:), h_neglect ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,1), (/1.,1.,7./), 'Left lim PLM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,2), (/1.,3.,7./), 'Left lim PLM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,1), (/1.,1.,7./), 'Left lim PLM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Left lim PLM: P1') - - call PLM_reconstruction(3, (/1.,1.,1./), (/1.,6.,7./), ppoly0_E(1:3,:), & - ppoly0_coefs(1:3,:), h_neglect ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,1), (/1.,5.,7./), 'Right lim PLM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,2), (/1.,7.,7./), 'Right lim PLM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,1), (/1.,5.,7./), 'Right lim PLM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Right lim PLM: P1') - - call PLM_reconstruction(3, (/1.,2.,3./), (/1.,4.,9./), ppoly0_E(1:3,:), & - ppoly0_coefs(1:3,:), h_neglect ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,9./), 'Non-uniform line PLM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,2), (/1.,6.,9./), 'Non-uniform line PLM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,1), (/1.,2.,9./), 'Non-uniform line PLM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,2), (/0.,4.,0./), 'Non-uniform line PLM: P1') - - call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E, & - h_neglect=1e-10, answers_2018=answers_2018 ) + call initialize_remapping(CS, 'PPM_H4', force_bounds_in_subcell=.false., answer_date=answer_date) + + call remapping_core_h( CS, n0, h0, u0, n2, h2, u2, net_err=err ) + call test%real_arr(6, u2, (/10.,6.,2.,-2.,-6.,-10./), 'remapping_core_h() 2') + + call remapping_core_h( CS, n0, h0, u0, 6, (/.125,.125,.125,.125,.125,.125/), u2, net_err=err ) + call test%real_arr(6, u2, (/11.5,10.5,9.5,8.5,7.5,6.5/), 'remapping_core_h() 3') + + call remapping_core_h( CS, n0, h0, u0, 3, (/2.25,1.5,1./), u2, net_err=err ) + call test%real_arr(3, u2, (/3.,-10.5,-12./), 'remapping_core_h() 4') + + deallocate(h0, u0, h1, u1, h2, u2, ppoly0_E, ppoly0_S, ppoly0_coefs) + call end_remapping(CS) + + ! =============================================== + ! This section tests the reconstruction functions + ! =============================================== + if (verbose) write(test%stdout,*) ' - - - - - reconstruction tests - - - - -' + + allocate( ppoly0_coefs(5,6), ppoly0_E(5,2), ppoly0_S(5,2), u2(2) ) + + call PCM_reconstruction(3, (/1.,2.,4./), & + ppoly0_E(1:3,:), ppoly0_coefs(1:3,:) ) + call test%real_arr(3, ppoly0_E(:,1), (/1.,2.,4./), 'PCM: left edges') + call test%real_arr(3, ppoly0_E(:,2), (/1.,2.,4./), 'PCM: right edges') + call test%real_arr(3, ppoly0_coefs(:,1), (/1.,2.,4./), 'PCM: P0') + + call PLM_reconstruction(3, (/1.,1.,1./), (/1.,3.,5./), & + ppoly0_E(1:3,:), ppoly0_coefs(1:3,:), h_neglect ) + call test%real_arr(3, ppoly0_E(:,1), (/1.,2.,5./), 'Unlim PLM: left edges') + call test%real_arr(3, ppoly0_E(:,2), (/1.,4.,5./), 'Unlim PLM: right edges') + call test%real_arr(3, ppoly0_coefs(:,1), (/1.,2.,5./), 'Unlim PLM: P0') + call test%real_arr(3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Unlim PLM: P1') + + call PLM_reconstruction(3, (/1.,1.,1./), (/1.,2.,7./), & + ppoly0_E(1:3,:), ppoly0_coefs(1:3,:), h_neglect ) + call test%real_arr(3, ppoly0_E(:,1), (/1.,1.,7./), 'Left lim PLM: left edges') + call test%real_arr(3, ppoly0_E(:,2), (/1.,3.,7./), 'Left lim PLM: right edges') + call test%real_arr(3, ppoly0_coefs(:,1), (/1.,1.,7./), 'Left lim PLM: P0') + call test%real_arr(3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Left lim PLM: P1') + + call PLM_reconstruction(3, (/1.,1.,1./), (/1.,6.,7./), & + ppoly0_E(1:3,:), ppoly0_coefs(1:3,:), h_neglect ) + call test%real_arr(3, ppoly0_E(:,1), (/1.,5.,7./), 'Right lim PLM: left edges') + call test%real_arr(3, ppoly0_E(:,2), (/1.,7.,7./), 'Right lim PLM: right edges') + call test%real_arr(3, ppoly0_coefs(:,1), (/1.,5.,7./), 'Right lim PLM: P0') + call test%real_arr(3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Right lim PLM: P1') + + call PLM_reconstruction(3, (/1.,2.,3./), (/1.,4.,9./), & + ppoly0_E(1:3,:), ppoly0_coefs(1:3,:), h_neglect ) + call test%real_arr(3, ppoly0_E(:,1), (/1.,2.,9./), 'Non-uniform line PLM: left edges') + call test%real_arr(3, ppoly0_E(:,2), (/1.,6.,9./), 'Non-uniform line PLM: right edges') + call test%real_arr(3, ppoly0_coefs(:,1), (/1.,2.,9./), 'Non-uniform line PLM: P0') + call test%real_arr(3, ppoly0_coefs(:,2), (/0.,4.,0./), 'Non-uniform line PLM: P1') + + call edge_values_explicit_h4(5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), & + ppoly0_E, h_neglect=1e-10, answer_date=answer_date ) ! The next two tests currently fail due to roundoff, but pass when given a reasonable tolerance. - thisTest = test_answer(v, 5, ppoly0_E(:,1), (/0.,2.,4.,6.,8./), 'Line H4: left edges', tol=8.0e-15) - remapping_unit_tests = remapping_unit_tests .or. thisTest - thisTest = test_answer(v, 5, ppoly0_E(:,2), (/2.,4.,6.,8.,10./), 'Line H4: right edges', tol=1.0e-14) - remapping_unit_tests = remapping_unit_tests .or. thisTest + call test%real_arr(5, ppoly0_E(:,1), (/0.,2.,4.,6.,8./), 'Line H4: left edges', tol=8.0e-15) + call test%real_arr(5, ppoly0_E(:,2), (/2.,4.,6.,8.,10./), 'Line H4: right edges', tol=1.0e-14) + ppoly0_E(:,1) = (/0.,2.,4.,6.,8./) ppoly0_E(:,2) = (/2.,4.,6.,8.,10./) call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E(1:5,:), & - ppoly0_coefs(1:5,:), h_neglect, answers_2018=answers_2018 ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,1), (/1.,2.,4.,6.,9./), 'Line PPM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,2), (/0.,2.,2.,2.,0./), 'Line PPM: P1') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,3), (/0.,0.,0.,0.,0./), 'Line PPM: P2') + ppoly0_coefs(1:5,:), h_neglect, answer_date=answer_date ) + call test%real_arr(5, ppoly0_coefs(:,1), (/1.,2.,4.,6.,9./), 'Line PPM: P0') + call test%real_arr(5, ppoly0_coefs(:,2), (/0.,2.,2.,2.,0./), 'Line PPM: P1') + call test%real_arr(5, ppoly0_coefs(:,3), (/0.,0.,0.,0.,0./), 'Line PPM: P2') call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,1.,7.,19.,37./), ppoly0_E, & - h_neglect=1e-10, answers_2018=answers_2018 ) - ! The next two tests are now passing when answers_2018 = .false., but otherwise only work to roundoff. - thisTest = test_answer(v, 5, ppoly0_E(:,1), (/3.,0.,3.,12.,27./), 'Parabola H4: left edges', tol=2.7e-14) - remapping_unit_tests = remapping_unit_tests .or. thisTest - thisTest = test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,48./), 'Parabola H4: right edges', tol=4.8e-14) - remapping_unit_tests = remapping_unit_tests .or. thisTest + h_neglect=1e-10, answer_date=answer_date ) + ! The next two tests are now passing when answer_date >= 20190101, but otherwise only work to roundoff. + call test%real_arr(5, ppoly0_E(:,1), (/3.,0.,3.,12.,27./), 'Parabola H4: left edges', tol=2.7e-14) + call test%real_arr(5, ppoly0_E(:,2), (/0.,3.,12.,27.,48./), 'Parabola H4: right edges', tol=4.8e-14) ppoly0_E(:,1) = (/0.,0.,3.,12.,27./) ppoly0_E(:,2) = (/0.,3.,12.,27.,48./) call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/0.,1.,7.,19.,37./), ppoly0_E(1:5,:), & - ppoly0_coefs(1:5,:), h_neglect, answers_2018=answers_2018 ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_E(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,37./), 'Parabola PPM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,2), (/0.,0.,6.,12.,0./), 'Parabola PPM: P1') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,3), (/0.,3.,3.,3.,0./), 'Parabola PPM: P2') + ppoly0_coefs(1:5,:), h_neglect, answer_date=answer_date ) + call test%real_arr(5, ppoly0_E(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: left edges') + call test%real_arr(5, ppoly0_E(:,2), (/0.,3.,12.,27.,37./), 'Parabola PPM: right edges') + call test%real_arr(5, ppoly0_coefs(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: P0') + call test%real_arr(5, ppoly0_coefs(:,2), (/0.,0.,6.,12.,0./), 'Parabola PPM: P1') + call test%real_arr(5, ppoly0_coefs(:,3), (/0.,3.,3.,3.,0./), 'Parabola PPM: P2') ppoly0_E(:,1) = (/0.,0.,6.,10.,15./) ppoly0_E(:,2) = (/0.,6.,12.,17.,15./) call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/0.,5.,7.,16.,15./), ppoly0_E(1:5,:), & - ppoly0_coefs(1:5,:), h_neglect, answers_2018=answers_2018 ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_E(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_E(:,2), (/0.,6.,9.,16.,15./), 'Limits PPM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,2), (/0.,6.,0.,0.,0./), 'Limits PPM: P1') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,3), (/0.,-3.,3.,0.,0./), 'Limits PPM: P2') - - call PLM_reconstruction(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), & - ppoly0_coefs(1:4,:), h_neglect ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 4, ppoly0_E(1:4,1), (/5.,5.,3.,1./), 'PPM: left edges h=0110') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 4, ppoly0_E(1:4,2), (/5.,3.,1.,1./), 'PPM: right edges h=0110') - call remap_via_sub_cells( 4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), & - ppoly0_coefs(1:4,:), & - 2, (/1.,1./), INTEGRATION_PLM, .false., u2, err ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 2, u2, (/4.,2./), 'PLM: remapped h=0110->h=11') - - deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs) - - if (.not. remapping_unit_tests) write(stdout,*) 'Pass' + ppoly0_coefs(1:5,:), h_neglect, answer_date=answer_date ) + call test%real_arr(5, ppoly0_E(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: left edges') + call test%real_arr(5, ppoly0_E(:,2), (/0.,6.,9.,16.,15./), 'Limits PPM: right edges') + call test%real_arr(5, ppoly0_coefs(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: P0') + call test%real_arr(5, ppoly0_coefs(:,2), (/0.,6.,0.,0.,0./), 'Limits PPM: P1') + call test%real_arr(5, ppoly0_coefs(:,3), (/0.,-3.,3.,0.,0./), 'Limits PPM: P2') + + deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs, u2) + + ! ============================================================== + ! This section tests the components of remapping_core_h() + ! ============================================================== + + if (verbose) write(test%stdout,*) ' - - - - - remapping algororithm tests - - - - -' + + ! Test 1: n0=2, n1=3 Maps uniform grids with one extra target layer and no implicitly-vanished interior sub-layers + ! h_src = | 3 | 3 | + ! h_tgt = | 2 | 2 | 2 | + ! h_sub = |0| 2 | 1 | 1 | 2 |0| + ! isrc_start |1 | 4 | + ! isrc_end | 3 | 5 | + ! isrc_max | 2 | 5 | + ! itgt_start |1 | 3 | 5 | + ! itgt_end | 2 | 4 | 6| + ! isub_src |1| 1 | 1 | 2 | 2 |2| + allocate( h_sub(6), h0_eff(2), isrc_start(2), isrc_end(2), isrc_max(2), itgt_start(3), itgt_end(3), isub_src(6) ) + call intersect_src_tgt_grids( 2, (/3., 3./), & ! n0, h0 + 3, (/2., 2., 2./), & ! n1, h1 + h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + if (verbose) write(test%stdout,*) "intersect_src_tgt_grids test 1: n0=2, n1=3" + if (verbose) write(test%stdout,*) " h_src = | 3 | 3 |" + if (verbose) write(test%stdout,*) " h_tgt = | 2 | 2 | 2 |" + call test%real_arr(6, h_sub, (/0.,2.,1.,1.,2.,0./), 'h_sub') + call test%real_arr(2, h0_eff, (/3.,3./), 'h0_eff') + call test%int_arr(2, isrc_start, (/1,4/), 'isrc_start') + call test%int_arr(2, isrc_end, (/3,5/), 'isrc_end') + call test%int_arr(2, isrc_max, (/2,5/), 'isrc_max') + call test%int_arr(3, itgt_start, (/1,3,5/), 'itgt_start') + call test%int_arr(3, itgt_end, (/2,4,6/), 'itgt_end') + call test%int_arr(6, isub_src, (/1,1,1,2,2,2/), 'isub_src') + deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + + ! Test 2: n0=3, n1=2 Reverses "test 1" with more source than target layers + ! h_src = | 2 | 2 | 2 | + ! h_tgt = | 3 | 3 | + ! h_sub = |0| 2 | 1 | 1 | 2 |0| + ! isrc_start |1 | 3 | 5 | + ! isrc_end | 2 | 4 | 5 | + ! isrc_max | 2 | 4 | 5 | + ! itgt_start |1 | 4 | + ! itgt_end | 3 | 6| + ! isub_src |1| 1 | 2 | 2 | 3 |3| + allocate( h_sub(6), h0_eff(3), isrc_start(3), isrc_end(3), isrc_max(3), itgt_start(2), itgt_end(2), isub_src(6) ) + call intersect_src_tgt_grids( 3, (/2., 2., 2./), & ! n0, h0 + 2, (/3., 3./), & ! n1, h1 + h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + if (verbose) write(test%stdout,*) "intersect_src_tgt_grids test 2: n0=3, n1=2" + if (verbose) write(test%stdout,*) " h_src = | 2 | 2 | 2 |" + if (verbose) write(test%stdout,*) " h_tgt = | 3 | 3 |" + call test%real_arr(6, h_sub, (/0.,2.,1.,1.,2.,0./), 'h_sub') + call test%real_arr(3, h0_eff, (/2.,2.,2./), 'h0_eff') + call test%int_arr(3, isrc_start, (/1,3,5/), 'isrc_start') + call test%int_arr(3, isrc_end, (/2,4,5/), 'isrc_end') + call test%int_arr(3, isrc_max, (/2,4,5/), 'isrc_max') + call test%int_arr(2, itgt_start, (/1,4/), 'itgt_start') + call test%int_arr(2, itgt_end, (/3,6/), 'itgt_end') + call test%int_arr(6, isub_src, (/1,1,2,2,3,3/), 'isub_src') + deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + + ! Test 3: n0=2, n1=3 With aligned interfaces that lead to implicitly-vanished interior sub-layers + n0 = 2 ; n1 = 3 + allocate( h0_eff(n0), isrc_start(n0), isrc_end(n0), isrc_max(n0), h0(n0), u0(n0) ) + allocate( itgt_start(n1), itgt_end(n1), h1(n1), u1(n1) ) + allocate( h_sub(n0+n1+1), isub_src(n0+n1+1) ) + u0 = (/ 2. , 5. /) + h0 = (/ 2. , 4. /) + h1 = (/ 2. , 2. , 2. /) + ! h_src = |<- 2 ->|<- 4 ->| + ! h_tgt = |<- 2 ->|<- 2 ->|<- 2 ->| + ! h_sub = |0|<- 2 ->|0|<- 2 ->|<- 2 ->|0| + ! isrc_start |1 |3 | + ! isrc_end | 2 | 5 | + ! isrc_max | 2 | 5 | + ! itgt_start |1 | 4 | 5 | + ! itgt_end | 3| 4 | 6| + ! isub_src |1| 1 |2| 2 | 2 |2| + call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + if (verbose) write(test%stdout,*) "intersect_src_tgt_grids test 3: n0=2, n1=3" + if (verbose) write(test%stdout,*) " h_src = | 2 | 4 |" + if (verbose) write(test%stdout,*) " h_tgt = | 2 | 2 | 2 |" + call test%real_arr(6, h_sub, (/0.,2.,0.,2.,2.,0./), 'h_sub') + call test%real_arr(2, h0_eff, (/2.,4./), 'h0_eff') + call test%int_arr(2, isrc_start, (/1,3/), 'isrc_start') + call test%int_arr(2, isrc_end, (/2,5/), 'isrc_end') + call test%int_arr(2, isrc_max, (/2,5/), 'isrc_max') + call test%int_arr(3, itgt_start, (/1,4,5/), 'itgt_start') + call test%int_arr(3, itgt_end, (/3,4,6/), 'itgt_end') + call test%int_arr(6, isub_src, (/1,1,2,2,2,2/), 'isub_src') + allocate(ppoly0_coefs(n0,2), ppoly0_E(n0,2), ppoly0_S(n0,2)) + ! h_src = |<- 2 ->|<- 4 ->| + ! h_sub = |0|<- 2 ->|0|<- 2 ->|<- 2 ->|0| + ! u_src = | 2 | 5 | + ! edge = |1 3|3 7| + ! u_sub = |1| 2 |3| 4 | 6 |7| + call PLM_reconstruction(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) + call PLM_boundary_extrapolation(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect) + allocate(u_sub(n0+n1+1), uh_sub(n0+n1+1)) + call remap_src_to_sub_grid_om4(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h_sub, h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(6, u_sub, (/1.,2.,3.,4.,6.,7./), 'u_sub om4') + call remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h_sub, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(6, u_sub, (/1.,2.,3.,4.,6.,7./), 'u_sub') + ! h_sub = |0|<- 2 ->|0|<- 2 ->|<- 2 ->|0| + ! u_sub = |1| 2 |3| 4 | 6 |7| + ! h_tgt = |<- 2 ->|<- 2 ->|<- 2 ->| + ! u_tgt = | 2 | 4 | 6 | + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + .false., .false., .false., u1, u02_err) + call test%real_arr(3, u1, (/2.,4.,6./), 'u1') + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + .true., .false., .false., u1, u02_err) + call test%real_arr(3, u1, (/2.,4.,6./), 'u1.b') + deallocate( ppoly0_coefs, ppoly0_E, ppoly0_S, u_sub, uh_sub, h0, u0, h1, u1) + deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + + ! Test 4: n0=2, n1=3 Incomplete target column, sum(h_tgt)|<- 4 ->| + ! h_tgt = |<- 2 ->|<- 2 ->|< 1 >| + ! h_sub = |0|<- 2 ->|0|<- 2 ->|< 1 >|< 1 >| + ! isrc_start |1 |3 | + ! isrc_end | 2 | 6 | + ! isrc_max | 2 | 4 | + ! itgt_start |1 | 4 | 5 | + ! itgt_end | 3| 4 | 5 | + ! isub_src |1| 1 |2| 2 | 2 | 2 | + call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + if (verbose) write(test%stdout,*) "intersect_src_tgt_grids test 4: n0=2, n1=3" + if (verbose) write(test%stdout,*) " h_src = | 2 | 4 |" + if (verbose) write(test%stdout,*) " h_tgt = | 2 | 2 | 1 |" + call test%real_arr(6, h_sub, (/0.,2.,0.,2.,1.,1./), 'h_sub') + call test%real_arr(2, h0_eff, (/2.,3./), 'h0_eff') + call test%int_arr(2, isrc_start, (/1,3/), 'isrc_start') + call test%int_arr(2, isrc_end, (/2,6/), 'isrc_end') + call test%int_arr(2, isrc_max, (/2,4/), 'isrc_max') + call test%int_arr(3, itgt_start, (/1,4,5/), 'itgt_start') + call test%int_arr(3, itgt_end, (/3,4,5/), 'itgt_end') + call test%int_arr(6, isub_src, (/1,1,2,2,2,2/), 'isub_src') + allocate(ppoly0_coefs(n0,2), ppoly0_E(n0,2), ppoly0_S(n0,2)) + ! h_src = |<- 2 ->|<- 4 ->| + ! h_sub = |0|<- 2 ->|0|<- 2 ->|<-1->|<-1->| + ! u_src = | 2 | 5 | + ! edge = |1 3|3 7| + ! u_sub = |1| 2 |3| 4 | 5.5 | 6.5 | + call PLM_reconstruction(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) + call PLM_boundary_extrapolation(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect) + allocate(u_sub(n0+n1+1), uh_sub(n0+n1+1)) + call remap_src_to_sub_grid(2, (/2.,4./), (/2.,5./), ppoly0_E, ppoly0_coefs, & + 3, h_sub, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(6, u_sub, (/1.,2.,3.,4.,5.5,6.5/), 'u_sub') + deallocate( ppoly0_coefs, ppoly0_E, ppoly0_S, u_sub, uh_sub, h0, u0, h1, u1) + deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + + ! Test 5: n0=3, n1=2 Target column exceeds source column, sum(h_tgt)>sum(h_src), useful for diagnostics + n0 = 3 ; n1 = 2 + allocate( h0_eff(n0), isrc_start(n0), isrc_end(n0), isrc_max(n0), h0(n0), u0(n0) ) + allocate( itgt_start(n1), itgt_end(n1), h1(n1), u1(n1) ) + allocate( h_sub(n0+n1+1), isub_src(n0+n1+1) ) + u0 = (/ 2. , 4. , 5.5 /) + h0 = (/ 2. , 2. , 1. /) + h1 = (/ 2. , 4. /) + ! h_src = |<- 2 ->|<- 2 ->|< 1 >| + ! h_tgt = |<- 2 ->|<- 4 ->| + ! h_sub = |0|<- 2 ->|0|<- 2 ->|< 1 >|< 1 >| + ! isrc_start |1 |3 | 5 | + ! isrc_end | 2 | 4 | 5 | + ! isrc_max | 2 | 4 | 5 | + ! itgt_start |1 | 4 | + ! itgt_end | 3| 6 | + ! isub_src |1| 1 |2| 2 | 3 | 3 | + call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + if (verbose) write(test%stdout,*) "intersect_src_tgt_grids test 5: n0=3, n1=2" + if (verbose) write(test%stdout,*) " h_src = | 2 | 2 | 1 |" + if (verbose) write(test%stdout,*) " h_tgt = | 2 | 4 |" + call test%real_arr(6, h_sub, (/0.,2.,0.,2.,1.,1./), 'h_sub') + call test%real_arr(3, h0_eff, (/2.,2.,1./), 'h0_eff') + call test%int_arr(3, isrc_start, (/1,3,5/), 'isrc_start') + call test%int_arr(3, isrc_end, (/2,4,5/), 'isrc_end') + call test%int_arr(3, isrc_max, (/2,4,5/), 'isrc_max') + call test%int_arr(2, itgt_start, (/1,4/), 'itgt_start') + call test%int_arr(2, itgt_end, (/3,6/), 'itgt_end') + call test%int_arr(6, isub_src, (/1,1,2,2,3,3/), 'isub_src') + allocate(ppoly0_coefs(n0,2), ppoly0_E(n0,2), ppoly0_S(n0,2)) + ! h_src = |<- 2 ->|<- 2 ->|< 1 >| + ! h_sub = |0|<- 2 ->|0|<- 2 ->|< 1 >|< 1 >| + ! u_src = | 2 | 4 | 5.5 | + ! edge = |1 3|3 5|5 6| + ! u_sub = |1| 2 |3| 4 | 5.5 | 6 | + call PLM_reconstruction(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) + call PLM_boundary_extrapolation(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect) + allocate(u_sub(n0+n1+1), uh_sub(n0+n1+1)) + call remap_src_to_sub_grid_om4(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h_sub, h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(6, u_sub, (/1.,2.,3.,4.,5.5,6./), 'u_sub om4') + call remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h_sub, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(6, u_sub, (/1.,2.,3.,4.,5.5,6./), 'u_sub') + ! h_sub = |0|<- 2 ->|0|<- 2 ->|< 1 >|< 1 >| + ! u_sub = |1| 2 |3| 4 | 5.5 | 6 | + ! h_tgt = |<- 2 ->|<- 4 ->| + ! u_tgt = | 2 | 4 7/8 | + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + .false., .false., .false., u1, u02_err) + call test%real_arr(2, u1, (/2.,4.875/), 'u1') + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + .true., .false., .false., u1, u02_err) + call test%real_arr(2, u1, (/2.,4.875/), 'u1.b') + deallocate( ppoly0_coefs, ppoly0_E, ppoly0_S, u_sub, uh_sub, h0, u0, h1, u1) + deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + + ! Test 6: n0=3, n1=5 Source and targets with vanished layers + n0 = 3 ; n1 = 5 + allocate( h0_eff(n0), isrc_start(n0), isrc_end(n0), isrc_max(n0), h0(n0), u0(n0) ) + allocate( itgt_start(n1), itgt_end(n1), h1(n1), u1(n1) ) + allocate( h_sub(n0+n1+1), isub_src(n0+n1+1) ) + u0 = (/ 2. ,3., 4. /) + h0 = (/ 2. ,0., 2. /) + h1 = (/ 1. ,0., 1. ,0., 2. /) + ! h_src = |<- 2 ->|0|<- 2 ->| + ! h_tgt = |<- 1 ->|0|<- 1 ->|0|<- 2 ->| + ! h_sub = |0|< 1 ->|0|< 1 >|0|0|0|<- 2 ->|0| + ! isrc_start |1 |5|6 | + ! isrc_end | 4 |5| 8 | + ! isrc_max | 4 |5| 8 | + ! itgt_start |1 |3| 4 |7| 8 | + ! itgt_end | 2 |3| 6|7| 9| + ! isub_src |1| 1 |1| 1 |2|3|3| 3 |3| + call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + if (verbose) write(test%stdout,*) "intersect_src_tgt_grids test 6: n0=3, n1=5" + if (verbose) write(test%stdout,*) " h_src = | 2 |0| 2 |" + if (verbose) write(test%stdout,*) " h_tgt = | 1 |0| 1 |0| 2 |" + call test%real_arr(9, h_sub, (/0.,1.,0.,1.,0.,0.,0.,2.,0./), 'h_sub') + call test%real_arr(3, h0_eff, (/2.,0.,2./), 'h0_eff') + call test%int_arr(3, isrc_start, (/1,5,6/), 'isrc_start') + call test%int_arr(3, isrc_end, (/4,5,8/), 'isrc_end') + call test%int_arr(3, isrc_max, (/4,5,8/), 'isrc_max') + call test%int_arr(5, itgt_start, (/1,3,4,7,8/), 'itgt_start') + call test%int_arr(5, itgt_end, (/2,3,6,7,9/), 'itgt_end') + call test%int_arr(9, isub_src, (/1,1,1,1,2,3,3,3,3/), 'isub_src') + allocate(ppoly0_coefs(n0,2), ppoly0_E(n0,2), ppoly0_S(n0,2)) + ! h_src = |<- 2 ->|0|<- 2 ->| + ! h_sub = |0|< 1 ->|0|< 1 >|0|0|0|<- 2 ->|0| + ! u_src = | 2 |3| 4 | + ! edge = |1 3|3|3 5| + ! u_sub = |1| 1.5 |2| 2.5 |3|3|3| 4 |5| + call PLM_reconstruction(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) + call PLM_boundary_extrapolation(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect) + allocate(u_sub(n0+n1+1), uh_sub(n0+n1+1)) + call remap_src_to_sub_grid_om4(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h_sub, h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(9, u_sub, (/1.,1.5,2.,2.5,3.,3.,3.,4.,5./), 'u_sub om4') + call remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h_sub, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(9, u_sub, (/1.,1.5,2.,2.5,3.,3.,3.,4.,5./), 'u_sub') + ! h_sub = |0|< 1 ->|0|< 1 >|0|0|0|<- 2 ->|0| + ! u_sub = |1| 1.5 |2| 2.5 |3|3|3| 4 |5| + ! h_tgt = |<- 1 ->|0|<- 1 ->|0|<- 2 ->| + ! u_tgt = | 1.5 |2| 2.5 |3| 4 | + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + .false., .false., .false., u1, u02_err) + call test%real_arr(5, u1, (/1.5,2.,2.5,3.,4./), 'u1') + call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + .true., .false., .false., u1, u02_err) + call test%real_arr(5, u1, (/1.5,2.,2.5,3.,4./), 'u1.b') + deallocate( ppoly0_coefs, ppoly0_E, ppoly0_S, u_sub, uh_sub, h0, u0, h1, u1) + deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) -end function remapping_unit_tests + ! ============================================================ + ! This section tests remapping_core_h() + ! ============================================================ + if (verbose) write(test%stdout,*) '- - - - - - - - - - remapping_core_h() tests - - - - - - - - -' + + allocate(u2(2)) + + call initialize_remapping(CS, 'PLM', force_bounds_in_subcell=.false., answer_date=answer_date) + + ! Remapping to just the two interior layers yields the same values as u_src(2:3) + call remapping_core_h(CS, 4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), 2, (/1.,1./), u2) + call test%real_arr(2, u2, (/4.,2./), 'PLM: remapped h=0110->h=11 om4') + call remapping_core_h(CS, 4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), 2, (/1.,1./), u2) + call test%real_arr(2, u2, (/4.,2./), 'PLM: remapped h=0110->h=11') + + ! Remapping to two layers that are deeper. For the bottom layer of thickness 4, + ! the first 1/4 has average 2, the remaining 3/4 has the bottom edge value or 1 + ! yield ing and average or 1.25 + call remapping_core_h(CS, 4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), 2, (/1.,4./), u2) + call test%real_arr(2, u2, (/4.,1.25/), 'PLM: remapped h=0110->h=14 om4') + call remapping_core_h(CS, 4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), 2, (/1.,4./), u2) + call test%real_arr(2, u2, (/4.,1.25/), 'PLM: remapped h=0110->h=14') + + ! Remapping to two layers with lowest layer not reach the bottom. + ! Here, the bottom layer samples top half of source yeilding 2.5. + ! Note: OM4 used the value as if the target layer was the same thickness as source. + call remapping_set_param(CS, om4_remap_via_sub_cells=.true.) + call remapping_core_h(CS, 4, (/0.,4.,4.,0./), (/5.,4.,2.,1./), 2, (/4.,2./), u2) + call test%real_arr(2, u2, (/4.,2./), 'PLM: remapped h=0440->h=42 om4 (with known bug)') + call remapping_set_param(CS, om4_remap_via_sub_cells=.false.) + call remapping_core_h(CS, 4, (/0.,4.,4.,0./), (/5.,4.,2.,1./), 2, (/4.,2./), u2) + call test%real_arr(2, u2, (/4.,2.5/), 'PLM: remapped h=0440->h=42') + + ! Remapping to two layers with no layers sampling the bottom source layer + ! The first layer samples the top half of u1, yielding 4.5 + ! The second layer samples the next quarter of u1, yielding 3.75 + call remapping_set_param(CS, om4_remap_via_sub_cells=.true.) + call remapping_core_h(CS, 4, (/0.,5.,5.,0./), (/5.,4.,2.,1./), 2, (/2.,2./), u2) + call test%real_arr(2, u2, (/4.5,3.5/), 'PLM: remapped h=0880->h=21 om4 (with known bug)') + call remapping_set_param(CS, om4_remap_via_sub_cells=.false.) + call remapping_core_h(CS, 4, (/0.,4.,4.,0./), (/5.,4.,2.,1./), 2, (/2.,1./), u2) + call test%real_arr(2, u2, (/4.5,3.75/), 'PLM: remapped h=0440->h=21') + + deallocate(u2) + + ! Profile 0: 8 layers, 1x top/2x bottom vanished, and the rest with thickness 1.0, total depth 5, u(z) = 1 + z + n0 = 8 + allocate( h0(n0), u0(n0) ) + h0 = (/0.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0.0, 0.0/) + u0 = (/1.0, 1.5, 2.5, 3.5, 4.5, 5.5, 6.0, 6.0/) + allocate( u1(8) ) + + call initialize_remapping(CS, 'PLM', answer_date=99990101, h_neglect=1.e-17, h_neglect_edge=1.e-2) + + do om4 = 0, 1 + if ( om4 == 0 ) then + CS%om4_remap_via_sub_cells = .false. + om4_tag(:) = ' ' + else + CS%om4_remap_via_sub_cells = .true. + om4_tag(:) = ' om4' + endif -!> Returns true if any cell of u and u_true are not identical. Returns false otherwise. -logical function test_answer(verbose, n, u, u_true, label, tol) - logical, intent(in) :: verbose !< If true, write results to stdout - integer, intent(in) :: n !< Number of cells in u - real, dimension(n), intent(in) :: u !< Values to test - real, dimension(n), intent(in) :: u_true !< Values to test against (correct answer) - character(len=*), intent(in) :: label !< Message - real, optional, intent(in) :: tol !< The tolerance for differences between u and u_true - ! Local variables - real :: tolerance ! The tolerance for differences between u and u_true - integer :: k + ! Unchanged grid + call remapping_core_h( CS, n0, h0, u0, 8, [0.,1.,1.,1.,1.,1.,0.,0.], u1) + call test%real_arr(8, u1, (/1.0,1.5,2.5,3.5,4.5,5.5,6.0,6.0/), 'PLM: remapped h=01111100->h=01111100'//om4_tag) - tolerance = 0.0 ; if (present(tol)) tolerance = tol - test_answer = .false. - do k = 1, n - if (abs(u(k) - u_true(k)) > tolerance) test_answer = .true. - enddo - if (test_answer .or. verbose) then - write(stdout,'(a4,2a24,x,a)') 'k','Calculated value','Correct value',label - do k = 1, n - if (abs(u(k) - u_true(k)) > tolerance) then - write(stdout,'(i4,1p2e24.16,a,1pe24.16,a)') k,u(k),u_true(k),' err=',u(k)-u_true(k),' < wrong' - write(stderr,'(i4,1p2e24.16,a,1pe24.16,a)') k,u(k),u_true(k),' err=',u(k)-u_true(k),' < wrong' - else - write(stdout,'(i4,1p2e24.16)') k,u(k),u_true(k) - endif - enddo - endif + ! Removing vanished layers (unchanged values for non-vanished layers, layer centers 0.5, 1.5, 2.5, 3.5, 4.5) + call remapping_core_h( CS, n0, h0, u0, 5, [1.,1.,1.,1.,1.], u1) + call test%real_arr(5, u1, (/1.5,2.5,3.5,4.5,5.5/), 'PLM: remapped h=01111100->h=11111'//om4_tag) + + ! Remapping to variable thickness layers (layer centers 0.25, 1.0, 2.25, 4.0) + call remapping_core_h( CS, n0, h0, u0, 4, [0.5,1.,1.5,2.], u1) + call test%real_arr(4, u1, (/1.25,2.,3.25,5./), 'PLM: remapped h=01111100->h=h1t2'//om4_tag) + + ! Remapping to variable thickness + vanished layers (layer centers 0.25, 1.0, 1.5, 2.25, 4.0) + call remapping_core_h( CS, n0, h0, u0, 6, [0.5,1.,0.,1.5,2.,0.], u1) + call test%real_arr(6, u1, (/1.25,2.,2.5,3.25,5.,6./), 'PLM: remapped h=01111100->h=h10t20'//om4_tag) + + ! Remapping to deeper water column (layer centers 0.75, 2.25, 3., 5., 8.) + call remapping_core_h( CS, n0, h0, u0, 5, [1.5,1.5,0.,4.,2.], u1) + call test%real_arr(5, u1, (/1.75,3.25,4.,5.5,6./), 'PLM: remapped h=01111100->h=tt02'//om4_tag) -end function test_answer - -!> Convenience function for printing grid to screen -subroutine dumpGrid(n,h,x,u) - integer, intent(in) :: n !< Number of cells - real, dimension(:), intent(in) :: h !< Cell thickness - real, dimension(:), intent(in) :: x !< Interface delta - real, dimension(:), intent(in) :: u !< Cell average values - integer :: i - write(stdout,'("i=",20i10)') (i,i=1,n+1) - write(stdout,'("x=",20es10.2)') (x(i),i=1,n+1) - write(stdout,'("i=",5x,20i10)') (i,i=1,n) - write(stdout,'("h=",5x,20es10.2)') (h(i),i=1,n) - write(stdout,'("u=",5x,20es10.2)') (u(i),i=1,n) -end subroutine dumpGrid + ! Remapping to slightly shorter water column (layer centers 0.5, 1.5, 2.5,, 3.5, 4.25) + call remapping_core_h( CS, n0, h0, u0, 5, [1.,1.,1.,1.,0.5], u1) + if ( om4 == 0 ) then + call test%real_arr(5, u1, (/1.5,2.5,3.5,4.5,5.25/), 'PLM: remapped h=01111100->h=1111h') + else + call test%real_arr(5, u1, (/1.5,2.5,3.5,4.5,5.5/), 'PLM: remapped h=01111100->h=1111h om4 (known bug)') + endif + + ! Remapping to much shorter water column (layer centers 0.25, 0.5, 1.) + call remapping_core_h( CS, n0, h0, u0, 3, [0.5,0.,1.], u1) + if ( om4 == 0 ) then + call test%real_arr(3, u1, (/1.25,1.5,2./), 'PLM: remapped h=01111100->h=h01') + else + call test%real_arr(3, u1, (/1.25,1.5,1.875/), 'PLM: remapped h=01111100->h=h01 om4 (known bug)') + endif + + enddo ! om4 + + call end_remapping(CS) + deallocate( h0, u0, u1 ) + + ! ============================================================ + ! This section tests interpolation and reintegration functions + ! ============================================================ + if (verbose) write(test%stdout,*) '- - - - - - - - - - interpolation tests - - - - - - - - -' + + call test_interp(test, 'Identity: 3 layer', & + 3, (/1.,2.,3./), (/1.,2.,3.,4./), & + 3, (/1.,2.,3./), (/1.,2.,3.,4./) ) + + call test_interp(test, 'A: 3 layer to 2', & + 3, (/1.,1.,1./), (/1.,2.,3.,4./), & + 2, (/1.5,1.5/), (/1.,2.5,4./) ) + + call test_interp(test, 'B: 2 layer to 3', & + 2, (/1.5,1.5/), (/1.,4.,7./), & + 3, (/1.,1.,1./), (/1.,3.,5.,7./) ) + + call test_interp(test, 'C: 3 layer (vanished middle) to 2', & + 3, (/1.,0.,2./), (/1.,2.,2.,3./), & + 2, (/1.,2./), (/1.,2.,3./) ) + + call test_interp(test, 'D: 3 layer (deep) to 3', & + 3, (/1.,2.,3./), (/1.,2.,4.,7./), & + 2, (/2.,2./), (/1.,3.,5./) ) + + call test_interp(test, 'E: 3 layer to 3 (deep)', & + 3, (/1.,2.,4./), (/1.,2.,4.,8./), & + 3, (/2.,3.,4./), (/1.,3.,6.,8./) ) + + call test_interp(test, 'F: 3 layer to 4 with vanished top/botton', & + 3, (/1.,2.,4./), (/1.,2.,4.,8./), & + 4, (/0.,2.,5.,0./), (/0.,1.,3.,8.,0./) ) + + call test_interp(test, 'Fs: 3 layer to 4 with vanished top/botton (shallow)', & + 3, (/1.,2.,4./), (/1.,2.,4.,8./), & + 4, (/0.,2.,4.,0./), (/0.,1.,3.,7.,0./) ) + + call test_interp(test, 'Fd: 3 layer to 4 with vanished top/botton (deep)', & + 3, (/1.,2.,4./), (/1.,2.,4.,8./), & + 4, (/0.,2.,6.,0./), (/0.,1.,3.,8.,0./) ) + + if (verbose) write(test%stdout,*) ' - - - - - reintegration tests - - - - -' + + call test_reintegrate(test, 'Identity: 3 layer', & + 3, (/1.,2.,3./), (/-5.,2.,1./), & + 3, (/1.,2.,3./), (/-5.,2.,1./) ) + + call test_reintegrate(test, 'A: 3 layer to 2', & + 3, (/2.,2.,2./), (/-5.,2.,1./), & + 2, (/3.,3./), (/-4.,2./) ) + + call test_reintegrate(test, 'A: 3 layer to 2 (deep)', & + 3, (/2.,2.,2./), (/-5.,2.,1./), & + 2, (/3.,4./), (/-4.,2./) ) + + call test_reintegrate(test, 'A: 3 layer to 2 (shallow)', & + 3, (/2.,2.,2./), (/-5.,2.,1./), & + 2, (/3.,2./), (/-4.,1.5/) ) + + call test_reintegrate(test, 'B: 3 layer to 4 with vanished top/bottom', & + 3, (/2.,2.,2./), (/-5.,2.,1./), & + 4, (/0.,3.,3.,0./), (/0.,-4.,2.,0./) ) + + call test_reintegrate(test, 'C: 3 layer to 4 with vanished top//middle/bottom', & + 3, (/2.,2.,2./), (/-5.,2.,1./), & + 5, (/0.,3.,0.,3.,0./), (/0.,-4.,0.,2.,0./) ) + + call test_reintegrate(test, 'D: 3 layer to 3 (vanished)', & + 3, (/2.,2.,2./), (/-5.,2.,1./), & + 3, (/0.,0.,0./), (/0.,0.,0./) ) + + call test_reintegrate(test, 'D: 3 layer (vanished) to 3', & + 3, (/0.,0.,0./), (/-5.,2.,1./), & + 3, (/2.,2.,2./), (/0., 0., 0./) ) + + call test_reintegrate(test, 'D: 3 layer (vanished) to 3 (vanished)', & + 3, (/0.,0.,0./), (/-5.,2.,1./), & + 3, (/0.,0.,0./), (/0.,0.,0./) ) + + call test_reintegrate(test, 'D: 3 layer (vanished) to 3 (vanished)', & + 3, (/0.,0.,0./), (/0.,0.,0./), & + 3, (/0.,0.,0./), (/0.,0.,0./) ) + + if (verbose) write(test%stdout,*) '- - - - - - - - - - Recon1d PCM tests - - - - - - - - -' + call test%test( PCM_instance%unit_tests(verbose, test%stdout, test%stderr), 'PCM unit test') + call test%test( MPLM_WA_instance%unit_tests(verbose, test%stdout, test%stderr), 'MPLM_WA unit test') + call test%test( EMPLM_WA_instance%unit_tests(verbose, test%stdout, test%stderr), 'EMPLM_WA unit test') + call test%test( MPLM_WA_poly_instance%unit_tests(verbose, test%stdout, test%stderr), 'MPLM_WA_poly unit test') + call test%test( EMPLM_WA_poly_instance%unit_tests(verbose, test%stdout, test%stderr), 'EMPLM_WA_poly unit test') + call test%test( PLM_hybgen_instance%unit_tests(verbose, test%stdout, test%stderr), 'PLM_hybgen unit test') + call test%test( PLM_CW_instance%unit_tests(verbose, test%stdout, test%stderr), 'PLM_CW unit test') + call test%test( PLM_CWK_instance%unit_tests(verbose, test%stdout, test%stderr), 'PLM_CWK unit test') + call test%test( MPLM_CWK_instance%unit_tests(verbose, test%stdout, test%stderr), 'MPLM_CWK unit test') + call test%test( EMPLM_CWK_instance%unit_tests(verbose, test%stdout, test%stderr), 'EMPLM_CWK unit test') + call test%test( PPM_H4_2019_instance%unit_tests(verbose, test%stdout, test%stderr), 'PPM_H4_2019 unit test') + call test%test( PPM_H4_2018_instance%unit_tests(verbose, test%stdout, test%stderr), 'PPM_H4_2018 unit test') + call test%test( PPM_hybgen_instance%unit_tests(verbose, test%stdout, test%stderr), 'PPM_hybgen unit test') + call test%test( PPM_CW_instance%unit_tests(verbose, test%stdout, test%stderr), 'PPM_CW unit test') + call test%test( PPM_CWK_instance%unit_tests(verbose, test%stdout, test%stderr), 'PPM_CWK unit test') + call test%test( EPPM_CWK_instance%unit_tests(verbose, test%stdout, test%stderr), 'EPPM_CWK unit test') + call test%test( PLM_WLS_instance%unit_tests(verbose, test%stdout, test%stderr), 'PLM_WLS unit test') + + ! Randomized, brute force tests + ntests = 3000 + if (present(num_comp_samp)) ntests = num_comp_samp + + call random_seed(size=seed_size) + allocate( seed(seed_Size) ) + seed(:) = 102030405 + call random_seed(put=seed) + + n0 = 9 + + ! Internal consistency + call test_recon_consistency(test, 'C_PCM', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_PLM_CW', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_PLM_HYBGEN', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_MPLM_WA', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_EMPLM_WA', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_MPLM_WA_poly', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_EMPLM_WA_poly', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_PLM_CWK', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_MPLM_CWK', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_EMPLM_CWK', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_PPM_H4_2018', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_PPM_H4_2019', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_PPM_HYBGEN', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_PPM_CW', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_PPM_CWK', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_EPPM_CWK', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_PLM_WLS', n0, ntests, h_neglect) + + call test_preserve_uniform(test, 'PCM', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_PCM', n0, ntests, h_neglect) +! call test_preserve_uniform(test, 'PLM', n0, ntests, h_neglect) ! Fails +! call test_preserve_uniform(test, 'PLM_HYBGEN', n0, ntests, h_neglect) ! Fails +! call test_preserve_uniform(test, 'PPM_H4', n0, ntests, h_neglect) ! Fails +! call test_preserve_uniform(test, 'PPM_IH4', n0, ntests, h_neglect) ! Fails +! call test_preserve_uniform(test, 'PPM_HYBGEN', n0, ntests, h_neglect) ! Fails +! call test_preserve_uniform(test, 'PPM_CW', n0, ntests, h_neglect) ! Fails +! call test_preserve_uniform(test, 'WENO_HYBGEN', n0, ntests, h_neglect) ! Fails +! call test_preserve_uniform(test, 'PQM_IH4IH3', n0, ntests, h_neglect) ! Fails + call test_preserve_uniform(test, 'C_PLM_CW', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_PLM_HYBGEN', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_MPLM_WA', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_EMPLM_WA', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_MPLM_WA_poly', n0, ntests, h_neglect) ! Surprised this passes -AJA +! call test_preserve_uniform(test, 'C_EMPLM_WA_poly', n0, ntests, h_neglect) ! This is known to fail + call test_preserve_uniform(test, 'C_PLM_CWK', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_MPLM_CWK', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_EMPLM_CWK', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_PPM_H4_2019', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_PPM_H4_2018', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_PPM_HYBGEN', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_PPM_CW', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_PPM_CWK', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_EPPM_CWK', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_PLM_WLS', n0, ntests, h_neglect) + + call test_unchanged_grid(test, 'C_PCM', n0, ntests, h_neglect) + call test_unchanged_grid(test, 'C_PLM_CW', n0, ntests, h_neglect) + call test_unchanged_grid(test, 'C_PLM_HYBGEN', n0, ntests, h_neglect) + call test_unchanged_grid(test, 'C_PLM_CWK', n0, ntests, h_neglect) + call test_unchanged_grid(test, 'C_MPLM_CWK', n0, ntests, h_neglect) + call test_unchanged_grid(test, 'C_EMPLM_CWK', n0, ntests, h_neglect) + call test_unchanged_grid(test, 'C_PPM_HYBGEN', n0, ntests, h_neglect) + call test_unchanged_grid(test, 'C_PPM_CW', n0, ntests, h_neglect) + call test_unchanged_grid(test, 'C_PPM_CWK', n0, ntests, h_neglect) + call test_unchanged_grid(test, 'C_EPPM_CWK', n0, ntests, h_neglect) + call test_unchanged_grid(test, 'C_PLM_WLS', n0, ntests, h_neglect) + + ! Check that remapping to the exact same grid leaves values unchanged + allocate( h0(8), u0(8) ) + h0 = (/0.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0.0, 0.0/) + u0 = (/1.0, 1.5, 2.5, 3.5, 4.5, 5.5, 6.0, 6.0/) + allocate( u1(8) ) + call initialize_remapping(CS, 'C_PLM_CW', nk=8) + call remapping_core_h( CS, 8, h0, u0, 8, [0.,1.,1.,1.,1.,1.,0.,0.], u1 ) + call test%real_arr(8, u1, u0, 'remapping_core to unchanged grid with class') + + call end_remapping(CS) + deallocate( h0, u0, u1 ) + + ! Brute force test that we have bitwise identical answers with the new classes + n0 = 7 + n1 = 4 + + ! PPM_CW and PPM_HYBGEN are identical, but are different options in build_reconstructions_1d() + call initialize_remapping(CS, 'PPM_CW', answer_date=99990101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.false., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'PPM_HYBGEN', answer_date=99990101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.false., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PPM_CW <-> PPM_HYBGEN') + + ! PPM_CW <-> PPM_HYBGEN, as above but with OM4 subcells + call initialize_remapping(CS, 'PPM_CW', answer_date=99990101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.true., force_bounds_in_subcell=.false., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'PPM_HYBGEN', answer_date=99990101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.true., force_bounds_in_subcell=.false., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PPM_CW <-> PPM_HYBGEN OM4') + + ! PPM_CW <-> PPM_HYBGEN, as above but with extrapolation + call initialize_remapping(CS, 'PPM_CW', answer_date=99990101, boundary_extrapolation=.true., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.false., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'PPM_HYBGEN', answer_date=99990101, boundary_extrapolation=.true., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.false., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PPM_CW <-> PPM_HYBGEN Extrap') + + ! PPM_CW <-> PPM_HYBGEN, as above but with OM4 subcells and subcell bounds + call initialize_remapping(CS, 'PPM_CW', answer_date=99990101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.true., force_bounds_in_subcell=.true., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'PPM_HYBGEN', answer_date=99990101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.true., force_bounds_in_subcell=.true., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PPM_CW <-> PPM_HYBGEN') + + ! PCM <-> C_PCM + call initialize_remapping(CS, 'PCM', answer_date=99990101, om4_remap_via_sub_cells=.false., & + force_bounds_in_subcell=.false.) + call initialize_remapping(CS2, 'C_PCM', nk=n0, h_neglect=h_neglect) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PCM <-> C_PCM') + + ! PLM <-> C_MPLM_WA_POLY + call initialize_remapping(CS, 'PLM', answer_date=99990101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.false., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'C_MPLM_WA_POLY', nk=n0, h_neglect=h_neglect) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PLM <-> C_MPLM_WA_poly') + + ! PLM (with subcell bounds) <-> C_MPLM_WA_POLY + call initialize_remapping(CS, 'PLM', answer_date=99990101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.true., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'C_MPLM_WA_POLY', nk=n0, h_neglect=h_neglect) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PLM bounded <-> C_MPLM_WA_poly') + + ! PLM + extrapolation <-> C_EMPLM_WA_POLY + call initialize_remapping(CS, 'PLM', answer_date=99990101, boundary_extrapolation=.true., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.false., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'C_EMPLM_WA_POLY', nk=n0, h_neglect=h_neglect) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PLM <-> C_EMPLM_WA_poly') + + ! PLM + extrapolation (with subcell bounds) <-> C_EMPLM_WA_POLY + call initialize_remapping(CS, 'PLM', answer_date=99990101, boundary_extrapolation=.true., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.true., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'C_EMPLM_WA_POLY', nk=n0, h_neglect=h_neglect) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PLM bounded <-> C_EMPLM_WA_poly') + + ! PPM_H4 (2018 answers) <-> C_PPM_H4_2018 + call initialize_remapping(CS, 'PPM_H4', answer_date=20180101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.false., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'C_PPM_H4_2018', nk=n0, h_neglect=h_neglect) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PPM_H4 2018 <-> C_PPM_H4_2018') + + ! PPM_H4 (2018 answers with subcell bounds) <-> C_PPM_H4_2018 + call initialize_remapping(CS, 'PPM_H4', answer_date=20180101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.true., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'C_PPM_H4_2018', nk=n0, h_neglect=h_neglect) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PPM_H4 2018 bounded <-> C_PPM_H4_2018') + + ! PPM_H4 (latest answers) <-> C_PPM_H4_2019 + call initialize_remapping(CS, 'PPM_H4', answer_date=99990101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.false., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'C_PPM_H4_2019', nk=n0, h_neglect=h_neglect) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PPM_H4 <-> C_PPM_H4_2019') + + ! PPM_H4 (latest answers with subcell bounds) <-> C_PPM_H4_2019 + call initialize_remapping(CS, 'PPM_H4', answer_date=99990101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.true., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'C_PPM_H4_2019', nk=n0, h_neglect=h_neglect) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PPM_H4 bounded <-> C_PPM_H4_2019') + + ! PLM_HYBGEN (latest answers with subcell bounds) <-> C_PLM_hybgen + call initialize_remapping(CS, 'PLM_HYBGEN', answer_date=99990101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.true., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'C_PLM_hybgen', nk=n0, h_neglect=h_neglect) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PLM_HYBGEN bounded <-> C_PLM_hygen') + + ! PPM_HYBGEN (latest answers with subcell bounds) <-> C_PPM_hybgen + call initialize_remapping(CS, 'PPM_HYBGEN', answer_date=99990101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.true., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'C_PPM_HYBGEN', nk=n0, h_neglect=h_neglect) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PPM_HYBGEN bounded <-> C_PPM_HYGEN') + + call end_remapping(CS) + call end_remapping(CS2) + + remapping_unit_tests = test%summarize('remapping_unit_tests') + +end function remapping_unit_tests end module MOM_remapping diff --git a/src/ALE/P1M_functions.F90 b/src/ALE/P1M_functions.F90 index d99c611229..510ebde12c 100644 --- a/src/ALE/P1M_functions.F90 +++ b/src/ALE/P1M_functions.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Linear interpolation functions module P1M_functions -! This file is part of MOM6. See LICENSE.md for the license. - use regrid_edge_values, only : bound_edge_values, average_discontinuous_edge_values implicit none ; private @@ -24,22 +26,22 @@ module P1M_functions !! !! It is assumed that the size of the array 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed here. -subroutine P1M_interpolation( N, h, u, edge_values, ppoly_coef, h_neglect, answers_2018 ) +subroutine P1M_interpolation( N, h, u, edge_values, ppoly_coef, h_neglect, answer_date ) integer, intent(in) :: N !< Number of cells 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, dimension(:,:), intent(inout) :: ppoly_coef !< Potentially modified !! piecewise polynomial coefficients, mainly [A] - real, optional, intent(in) :: h_neglect !< A negligibly small width [H] - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + 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 integer :: k ! loop index - real :: u0_l, u0_r ! edge values (left and right) + real :: u0_l, u0_r ! edge values (left and right) [A] ! Bound edge values (routine found in 'edge_values.F90') - call bound_edge_values( N, h, u, edge_values, h_neglect, answers_2018 ) + call bound_edge_values( N, h, u, edge_values, h_neglect, answer_date=answer_date ) ! Systematically average discontinuous edge values (routine found in ! 'edge_values.F90') @@ -74,10 +76,10 @@ subroutine P1M_boundary_extrapolation( N, h, u, edge_values, ppoly_coef ) real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly [A] ! Local variables - real :: u0, u1 ! cell averages - real :: h0, h1 ! corresponding cell widths - real :: slope ! retained PLM slope - real :: u0_l, u0_r ! edge values + real :: u0, u1 ! cell averages [A] + real :: h0, h1 ! corresponding cell widths [H] + real :: slope ! retained PLM slope [A] + real :: u0_l, u0_r ! edge values [A] ! ----------------------------------------- ! Left edge value in the left boundary cell @@ -153,7 +155,7 @@ end subroutine P1M_boundary_extrapolation !! linearly interpolating between them. ! !! Once the edge values are estimated, the limiting process takes care of -!! ensuring that (1) edge values are bounded by neighoring cell averages +!! ensuring that (1) edge values are bounded by neighboring cell averages !! and (2) discontinuous edge values are averaged in order to provide a !! fully continuous interpolant throughout the domain. This last step is !! essential for the regridding problem to yield a unique solution. diff --git a/src/ALE/P3M_functions.F90 b/src/ALE/P3M_functions.F90 index e3a9f75a3c..e07cd9640f 100644 --- a/src/ALE/P3M_functions.F90 +++ b/src/ALE/P3M_functions.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Cubic interpolation functions module P3M_functions -! This file is part of MOM6. See LICENSE.md for the license. - use regrid_edge_values, only : bound_edge_values, average_discontinuous_edge_values implicit none ; private @@ -10,9 +12,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 @@ -25,23 +24,24 @@ module P3M_functions !! !! It is assumed that the size of the array 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed here. -subroutine P3M_interpolation( N, h, u, edge_values, ppoly_S, ppoly_coef, h_neglect, answers_2018 ) +subroutine P3M_interpolation( N, h, u, edge_values, ppoly_S, ppoly_coef, h_neglect, answer_date ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] 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] - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Call the limiter for p3m, which takes care of everything from ! computing the coefficients of the cubic to monotonizing it. ! This routine could be called directly instead of having to call ! 'P3M_interpolation' first but we do that to provide an homogeneous ! interface. - call P3M_limiter( N, h, u, edge_values, ppoly_S, ppoly_coef, h_neglect, answers_2018 ) + call P3M_limiter( N, h, u, edge_values, ppoly_S, ppoly_coef, h_neglect, & + answer_date=answer_date ) end subroutine P3M_interpolation @@ -58,16 +58,16 @@ end subroutine P3M_interpolation !! c. If not, monotonize cubic curve and rebuild it !! !! Step 3 of the monotonization process leaves all edge values unchanged. -subroutine P3M_limiter( N, h, u, edge_values, ppoly_S, ppoly_coef, h_neglect, answers_2018 ) +subroutine P3M_limiter( N, h, u, edge_values, ppoly_S, ppoly_coef, h_neglect, answer_date ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] 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] - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Local variables integer :: k ! loop index @@ -78,15 +78,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, answers_2018 ) + 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 ) @@ -126,9 +120,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 ) @@ -196,10 +190,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 @@ -209,10 +203,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 @@ -228,7 +221,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 @@ -241,7 +234,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 @@ -285,10 +278,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 @@ -301,7 +294,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 @@ -383,7 +376,7 @@ end subroutine build_cubic_interpolant !! Hence, we check whether the roots (if any) lie inside this interval. If there !! is no root or if both roots lie outside this interval, the cubic is monotonic. logical function is_cubic_monotonic( ppoly_coef, k ) - real, dimension(:,:), intent(in) :: ppoly_coef !< Coefficients of cubic polynomial in arbitary units [A] + real, dimension(:,:), intent(in) :: ppoly_coef !< Coefficients of cubic polynomial in arbitrary units [A] integer, intent(in) :: k !< The index of the cell to work on ! Local variables real :: a, b, c ! Coefficients of the first derivative of the cubic [A] diff --git a/src/ALE/PCM_functions.F90 b/src/ALE/PCM_functions.F90 index 6608e85eda..dff25e5fc6 100644 --- a/src/ALE/PCM_functions.F90 +++ b/src/ALE/PCM_functions.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Piecewise constant reconstruction functions module PCM_functions -! This file is part of MOM6. See LICENSE.md for the license. - implicit none ; private public PCM_reconstruction @@ -17,11 +19,11 @@ module PCM_functions !! defining 'grid' and 'ppoly'. No consistency check is performed. subroutine PCM_reconstruction( N, u, edge_values, ppoly_coef ) integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: u !< cell averages + real, dimension(:), intent(in) :: u !< cell averages in arbitrary units [A] real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial, - !! with the same units as u. + !! with the same units as u [A]. real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, - !! with the same units as u. + !! with the same units as u [A]. ! Local variables integer :: k @@ -42,7 +44,7 @@ end subroutine PCM_reconstruction !! Date of creation: 2008.06.06 !! L. White !! -!! This module contains routines that handle one-dimensionnal finite volume +!! This module contains routines that handle one-dimensional finite volume !! reconstruction using the piecewise constant method (PCM). end module PCM_functions diff --git a/src/ALE/PLM_functions.F90 b/src/ALE/PLM_functions.F90 index d0f620e4a8..ab70541747 100644 --- a/src/ALE/PLM_functions.F90 +++ b/src/ALE/PLM_functions.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Piecewise linear reconstruction functions module PLM_functions -! This file is part of MOM6. See LICENSE.md for the license. - implicit none ; private public PLM_boundary_extrapolation @@ -12,24 +14,23 @@ 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. [units of u] +!> Returns a limited PLM slope following White and Adcroft, 2008, in the same arbitrary +!! units [A] as the input values. !! Note that this is not the same as the Colella and Woodward method. real elemental pure function PLM_slope_wa(h_l, h_c, h_r, h_neglect, u_l, u_c, u_r) - real, intent(in) :: h_l !< Thickness of left cell [units of grid thickness] - real, intent(in) :: h_c !< Thickness of center cell [units of grid thickness] - real, intent(in) :: h_r !< Thickness of right cell [units of grid thickness] - real, intent(in) :: h_neglect !< A negligible thickness [units of grid thickness] - real, intent(in) :: u_l !< Value of left cell [units of u] - real, intent(in) :: u_c !< Value of center cell [units of u] - real, intent(in) :: u_r !< Value of right cell [units of u] + real, intent(in) :: h_l !< Thickness of left cell in arbitrary grid thickness units [H] + real, intent(in) :: h_c !< Thickness of center cell in arbitrary grid thickness units [H] + real, intent(in) :: h_r !< Thickness of right cell in arbitrary grid thickness units [H] + real, intent(in) :: h_neglect !< A negligible thickness [H] + real, intent(in) :: u_l !< Value of left cell in arbitrary units [A] + real, intent(in) :: u_c !< Value of center cell in arbitrary units [A] + real, intent(in) :: u_r !< Value of right cell in arbitrary units [A] ! Local variables real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as - ! differences across the cell [units of u] - real :: u_min, u_max ! Minimum and maximum value across cell [units of u] + ! differences across the cell [A] + real :: u_min, u_max ! Minimum and maximum value across cell [A] ! Side differences sigma_r = u_r - u_c @@ -63,20 +64,21 @@ real elemental pure function PLM_slope_wa(h_l, h_c, h_r, h_neglect, u_l, u_c, u_ end function PLM_slope_wa -!> Returns a limited PLM slope following Colella and Woodward 1984. +!> Returns a limited PLM slope following Colella and Woodward 1984, in the same +!! arbitrary units as the input values [A]. real elemental pure function PLM_slope_cw(h_l, h_c, h_r, h_neglect, u_l, u_c, u_r) - real, intent(in) :: h_l !< Thickness of left cell [units of grid thickness] - real, intent(in) :: h_c !< Thickness of center cell [units of grid thickness] - real, intent(in) :: h_r !< Thickness of right cell [units of grid thickness] - real, intent(in) :: h_neglect !< A negligible thickness [units of grid thickness] - real, intent(in) :: u_l !< Value of left cell [units of u] - real, intent(in) :: u_c !< Value of center cell [units of u] - real, intent(in) :: u_r !< Value of right cell [units of u] + real, intent(in) :: h_l !< Thickness of left cell in arbitrary grid thickness units [H] + real, intent(in) :: h_c !< Thickness of center cell in arbitrary grid thickness units [H] + real, intent(in) :: h_r !< Thickness of right cell in arbitrary grid thickness units [H] + real, intent(in) :: h_neglect !< A negligible thickness [H] + real, intent(in) :: u_l !< Value of left cell in arbitrary units [A] + real, intent(in) :: u_c !< Value of center cell in arbitrary units [A] + real, intent(in) :: u_r !< Value of right cell in arbitrary units [A] ! Local variables real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as - ! differences across the cell [units of u] - real :: u_min, u_max ! Minimum and maximum value across cell [units of u] - real :: h_cn ! Thickness of center cell [units of grid thickness] + ! differences across the cell [A] + real :: u_min, u_max ! Minimum and maximum value across cell [A] + real :: h_cn ! Thickness of center cell [H] h_cn = h_c + h_neglect @@ -117,18 +119,19 @@ real elemental pure function PLM_slope_cw(h_l, h_c, h_r, h_neglect, u_l, u_c, u_ end function PLM_slope_cw -!> Returns a limited PLM slope following Colella and Woodward 1984. +!> Returns a limited PLM slope following Colella and Woodward 1984, in the same +!! arbitrary units as the input values [A]. real elemental pure function PLM_monotonized_slope(u_l, u_c, u_r, s_l, s_c, s_r) - real, intent(in) :: u_l !< Value of left cell [units of u] - real, intent(in) :: u_c !< Value of center cell [units of u] - real, intent(in) :: u_r !< Value of right cell [units of u] - real, intent(in) :: s_l !< PLM slope of left cell [units of u] - real, intent(in) :: s_c !< PLM slope of center cell [units of u] - real, intent(in) :: s_r !< PLM slope of right cell [units of u] + real, intent(in) :: u_l !< Value of left cell in arbitrary units [A] + real, intent(in) :: u_c !< Value of center cell in arbitrary units [A] + real, intent(in) :: u_r !< Value of right cell in arbitrary units [A] + real, intent(in) :: s_l !< PLM slope of left cell [A] + real, intent(in) :: s_c !< PLM slope of center cell [A] + real, intent(in) :: s_r !< PLM slope of right cell [A] ! Local variables - real :: e_r, e_l, edge ! Right, left and temporary edge values [units of u] - real :: almost_two ! The number 2, almost. - real :: slp ! Magnitude of PLM central slope [units of u] + real :: e_r, e_l, edge ! Right, left and temporary edge values [A] + real :: almost_two ! The number 2, almost [nondim] + real :: slp ! Magnitude of PLM central slope [A] almost_two = 2. * ( 1. - epsilon(s_c) ) @@ -155,17 +158,18 @@ real elemental pure function PLM_monotonized_slope(u_l, u_c, u_r, s_l, s_c, s_r) end function PLM_monotonized_slope -!> Returns a PLM slope using h2 extrapolation from a cell to the left. -!! Use the negative to extrapolate from the a cell to the right. +!> Returns a PLM slope using h2 extrapolation from a cell to the left, in the same +!! arbitrary units as the input values [A]. +!! Use the negative to extrapolate from the cell to the right. real elemental pure function PLM_extrapolate_slope(h_l, h_c, h_neglect, u_l, u_c) - real, intent(in) :: h_l !< Thickness of left cell [units of grid thickness] - real, intent(in) :: h_c !< Thickness of center cell [units of grid thickness] - real, intent(in) :: h_neglect !< A negligible thickness [units of grid thickness] - real, intent(in) :: u_l !< Value of left cell [units of u] - real, intent(in) :: u_c !< Value of center cell [units of u] + real, intent(in) :: h_l !< Thickness of left cell in arbitrary grid thickness units [H] + real, intent(in) :: h_c !< Thickness of center cell in arbitrary grid thickness units [H] + real, intent(in) :: h_neglect !< A negligible thickness [H] + real, intent(in) :: u_l !< Value of left cell in arbitrary units [A] + real, intent(in) :: u_c !< Value of center cell in arbitrary units [A] ! Local variables - real :: left_edge ! Left edge value [units of u] - real :: hl, hc ! Left and central cell thicknesses [units of grid thickness] + real :: left_edge ! Left edge value [A] + real :: hl, hc ! Left and central cell thicknesses [H] ! Avoid division by zero for vanished cells hl = h_l + h_neglect @@ -185,34 +189,31 @@ end function PLM_extrapolate_slope !! defining 'grid' and 'ppoly'. No consistency check is performed here. subroutine PLM_reconstruction( N, h, u, edge_values, ppoly_coef, h_neglect ) integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] real, dimension(:,:), intent(inout) :: edge_values !< edge values of piecewise polynomials, - !! with the same units as u. + !! with the same units as u [A]. real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly - !! with the same units as u. - real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! with the same units as u [A]. + real, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions - !! in the same units as h + !! in the same units as h [H] ! Local variables - integer :: k ! loop index - real :: u_l, u_c, u_r ! left, center and right cell averages - real :: h_l, h_c, h_r, h_cn ! left, center and right cell widths - real :: slope ! retained PLM slope - real :: a, b ! auxiliary variables - real :: u_min, u_max, e_l, e_r, edge - real :: almost_one - real, dimension(N) :: slp, mslp - real :: hNeglect - - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + integer :: k ! loop index + real :: u_l, u_r ! left and right cell averages [A] + real :: slope ! retained PLM slope for a normalized cell width [A] + real :: e_r ! The edge value in the neighboring cell [A] + real :: edge ! The projected edge value in the cell [A] + 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] 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. @@ -267,23 +268,20 @@ end subroutine PLM_reconstruction !! defining 'grid' and 'ppoly'. No consistency check is performed here. subroutine PLM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_neglect ) integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] real, dimension(:,:), intent(inout) :: edge_values !< edge values of piecewise polynomials, - !! with the same units as u. + !! with the same units as u [A]. real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly - !! with the same units as u. - real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! with the same units as u [A]. + real, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions - !! in the same units as h + !! in the same units as h [H] ! Local variables - real :: slope ! retained PLM slope - real :: hNeglect - - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + real :: slope ! retained PLM slope for a normalized cell width [A] ! 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 @@ -292,7 +290,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 @@ -307,7 +305,7 @@ end subroutine PLM_boundary_extrapolation !! Date of creation: 2008.06.06 !! L. White !! -!! This module contains routines that handle one-dimensionnal finite volume +!! This module contains routines that handle one-dimensional finite volume !! reconstruction using the piecewise linear method (PLM). end module PLM_functions diff --git a/src/ALE/PPM_functions.F90 b/src/ALE/PPM_functions.F90 index bbf93b4a81..ad8fe2adb6 100644 --- a/src/ALE/PPM_functions.F90 +++ b/src/ALE/PPM_functions.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Provides functions used with the Piecewise-Parabolic-Method in the vertical ALE algorithm. module PPM_functions -! This file is part of MOM6. See LICENSE.md for the license. - ! First version was created by Laurent White, June 2008. ! Substantially re-factored January 2016. @@ -13,33 +15,26 @@ module PPM_functions implicit none ; private -public PPM_reconstruction, PPM_boundary_extrapolation - -!> 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 +public PPM_reconstruction, PPM_boundary_extrapolation, PPM_monotonicity contains !> Builds quadratic polynomials coefficients from cell mean and edge values. -subroutine PPM_reconstruction( N, h, u, edge_values, ppoly_coef, h_neglect, answers_2018) +subroutine PPM_reconstruction( N, h, u, edge_values, ppoly_coef, h_neglect, answer_date) integer, intent(in) :: N !< Number of cells real, dimension(N), intent(in) :: h !< Cell widths [H] - real, dimension(N), intent(in) :: u !< Cell averages [A] + 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] - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + 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 integer :: k ! Loop index - real :: edge_l, edge_r ! Edge values (left and right) + real :: edge_l, edge_r ! Edge values (left and right) [A] ! PPM limiter - call PPM_limiter_standard( N, h, u, edge_values, h_neglect, answers_2018 ) + call PPM_limiter_standard( N, h, u, edge_values, h_neglect, answer_date=answer_date ) ! Loop over all cells do k = 1,N @@ -59,22 +54,22 @@ end subroutine PPM_reconstruction !> Adjusts edge values using the standard PPM limiter (Colella & Woodward, JCP 1984) !! after first checking that the edge values are bounded by neighbors cell averages !! and that the edge values are monotonic between cell averages. -subroutine PPM_limiter_standard( N, h, u, edge_values, h_neglect, answers_2018 ) +subroutine PPM_limiter_standard( N, h, u, edge_values, h_neglect, answer_date ) integer, intent(in) :: N !< Number of cells 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] - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + 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 integer :: k ! Loop index - real :: u_l, u_c, u_r ! Cell averages (left, center and right) - real :: edge_l, edge_r ! Edge values (left and right) - real :: expr1, expr2 + real :: u_l, u_c, u_r ! Cell averages (left, center and right) [A] + real :: edge_l, edge_r ! Edge values (left and right) [A] + real :: expr1, expr2 ! Temporary expressions [A2] ! Bound edge values - call bound_edge_values( N, h, u, edge_values, h_neglect, answers_2018 ) + call bound_edge_values( N, h, u, edge_values, h_neglect, answer_date=answer_date ) ! Make discontinuous edge values monotonic call check_discontinuous_edge_values( N, u, edge_values ) @@ -110,7 +105,7 @@ subroutine PPM_limiter_standard( N, h, u, edge_values, h_neglect, answers_2018 ) endif ! This checks that the difference in edge values is representable ! and avoids overshoot problems due to round off. - !### The 1.e-60 needs to have units of [A], so this dimensionally inconsisent. + !### The 1.e-60 needs to have units of [A], so this dimensionally inconsistent. if ( abs( edge_r - edge_l ) Adjusts edge values using the original monotonicity constraint (Colella & Woodward, JCP 1984) +!! Based on hybgen_ppm_coefs +subroutine PPM_monotonicity( N, u, edge_values ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: u !< cell average properties (size N) [A] + real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values [A] + + ! Local variables + integer :: k ! Loop index + real :: a6, da ! Normalized scalar curvature and slope [A] + + ! Loop on interior cells to impose monotonicity + ! Eq. 1.10 of (Colella & Woodward, JCP 84) + do k = 2,N-1 + if (((u(k+1)-u(k))*(u(k)-u(k-1)) <= 0.)) then !local extremum + edge_values(k,1) = u(k) + edge_values(k,2) = u(k) + else + da = edge_values(k,2)-edge_values(k,1) + a6 = 6.0*u(k) - 3.0*(edge_values(k,1)+edge_values(k,2)) + if (da*a6 > da*da) then !peak in right half of zone + edge_values(k,1) = 3.0*u(k) - 2.0*edge_values(k,2) + elseif (da*a6 < -da*da) then !peak in left half of zone + edge_values(k,2) = 3.0*u(k) - 2.0*edge_values(k,1) + endif + endif + enddo ! end loop on interior cells + +end subroutine PPM_monotonicity !------------------------------------------------------------------------------ !> Reconstruction by parabolas within boundary cells @@ -161,21 +185,20 @@ 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 integer :: i0, i1 - real :: u0, u1 - real :: h0, h1 - real :: a, b, c - real :: u0_l, u0_r - real :: u1_l, u1_r - real :: slope - real :: exp1, exp2 - real :: hNeglect - - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + real :: u0, u1 ! Average concentrations in the two neighboring cells [A] + real :: h0, h1 ! Thicknesses of the two neighboring cells [H] + real :: a, b, c ! An edge value, normalized slope and normalized curvature + ! of a reconstructed distribution [A] + real :: u0_l, u0_r ! Edge values of a neighboring cell [A] + real :: u1_l, u1_r ! Neighboring cell slopes renormalized by the thickness of + ! the cell being worked on [A] + real :: slope ! The normalized slope [A] + real :: exp1, exp2 ! Temporary expressions [A2] ! ----- Left boundary ----- i0 = 1 @@ -188,7 +211,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 @@ -242,7 +265,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 630ecb34fc..d0bd58a9fe 100644 --- a/src/ALE/PQM_functions.F90 +++ b/src/ALE/PQM_functions.F90 @@ -1,42 +1,42 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Piecewise quartic reconstruction functions module PQM_functions -! This file is part of MOM6. See LICENSE.md for the license. - use regrid_edge_values, only : bound_edge_values, check_discontinuous_edge_values implicit none ; private 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. !! !! It is assumed that the dimension of 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed. -subroutine PQM_reconstruction( N, h, u, edge_values, edge_slopes, ppoly_coef, h_neglect, answers_2018 ) +subroutine PQM_reconstruction( N, h, u, edge_values, edge_slopes, ppoly_coef, h_neglect, answer_date ) integer, intent(in) :: N !< Number of cells real, dimension(:), intent(in) :: h !< cell widths (size N) [H] real, dimension(:), intent(in) :: u !< cell averages (size N) [A] 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] - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Local variables integer :: k ! loop index - real :: h_c ! cell width + real :: h_c ! cell width [H] real :: u0_l, u0_r ! edge values (left and right) [A] real :: u1_l, u1_r ! edge slopes (left and right) [A H-1] - real :: a, b, c, d, e ! parabola coefficients + real :: a, b, c, d, e ! quartic fit coefficients [A] ! PQM limiter - call PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answers_2018 ) + call PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answer_date=answer_date ) ! Loop on cells to construct the cubic within each cell do k = 1,N @@ -72,15 +72,15 @@ end subroutine PQM_reconstruction !! !! It is assumed that the dimension of 'u' is equal to the number of cells !! defining 'grid' and 'ppoly'. No consistency check is performed. -subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answers_2018 ) +subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answer_date ) integer, intent(in) :: N !< Number of cells 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, 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] - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Local variables integer :: k ! loop index @@ -90,19 +90,17 @@ subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answers_20 real :: u1_l, u1_r ! edge slopes [A H-1] real :: u_l, u_c, u_r ! left, center and right cell averages [A] 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 - real :: slope ! retained PLM slope - real :: a, b, c, d, e - real :: alpha1, alpha2, alpha3 - real :: rho, sqrt_rho - real :: gradient1, gradient2 - real :: x1, x2 - real :: hNeglect - - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + 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 :: a, b, c, d, e ! quartic fit coefficients [A] + real :: alpha1, alpha2, alpha3 ! Normalized second derivative coefficients [A] + real :: rho ! A temporary expression [A2] + 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] ! Bound edge values - call bound_edge_values( N, h, u, edge_values, hNeglect, answers_2018 ) + 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 ) @@ -131,9 +129,9 @@ subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answers_20 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 ) @@ -158,7 +156,7 @@ subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answers_20 ! Edge values are bounded and averaged when discontinuous and not ! monotonic, edge slopes are consistent and the cell is not an extremum. - ! We now need to check and encorce the monotonicity of the quartic within + ! We now need to check and enforce the monotonicity of the quartic within ! the cell if ( (inflexion_l == 0) .AND. (inflexion_r == 0) ) then @@ -271,8 +269,8 @@ subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answers_20 ! 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 @@ -282,13 +280,13 @@ subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answers_20 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 @@ -296,8 +294,8 @@ subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answers_20 ! 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 @@ -307,13 +305,13 @@ subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answers_20 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 @@ -359,13 +357,13 @@ subroutine PQM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef ) real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly [A] ! Local variables integer :: i0, i1 - real :: u0, u1 - real :: h0, h1 - real :: a, b, c, d, e - real :: u0_l, u0_r - real :: u1_l, u1_r - real :: slope - real :: exp1, exp2 + real :: u0, u1 ! Successive cell averages [A] + real :: h0, h1 ! Successive cell thicknesses [H] + real :: a, b, c, d, e ! quartic fit coefficients [A] + real :: u0_l, u0_r ! Edge values [A] + real :: u1_l, u1_r ! Edge slopes [A H-1] + real :: slope ! The integrated slope across the cell [A] + real :: exp1, exp2 ! Two temporary expressions [A2] ! ----- Left boundary ----- i0 = 1 @@ -505,27 +503,26 @@ 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 integer :: inflexion_l integer :: inflexion_r - real :: u0, u1, um - real :: h0, h1 - real :: a, b, c, d, e - real :: ar, br, beta - real :: u0_l, u0_r - real :: u1_l, u1_r - real :: u_plm - real :: slope - real :: alpha1, alpha2, alpha3 - real :: rho, sqrt_rho - real :: gradient1, gradient2 - real :: x1, x2 - real :: hNeglect - - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + real :: u0, u1, um ! Successive cell averages [A] + real :: h0, h1 ! Successive cell thicknesses [H] + real :: a, b, c, d, e ! quartic fit coefficients [A] + real :: ar, br ! Temporary variables in [A] + real :: beta ! A rational function coefficient [nondim] + real :: u0_l, u0_r ! Edge values [A] + real :: u1_l, u1_r ! Edge slopes [A H-1] + real :: u_plm ! The integrated piecewise linear method slope [A] + real :: slope ! The integrated slope across the cell [A] + real :: alpha1, alpha2, alpha3 ! Normalized second derivative coefficients [A] + real :: rho ! A temporary expression [A2] + 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] ! ----- Left boundary (TOP) ----- i0 = 1 @@ -538,7 +535,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 @@ -547,12 +544,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 @@ -571,10 +568,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 @@ -632,8 +629,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 @@ -643,13 +640,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 @@ -833,7 +830,7 @@ end subroutine PQM_boundary_extrapolation_v1 !! Date of creation: 2008.06.06 !! L. White !! -!! This module contains routines that handle one-dimensionnal finite volume +!! This module contains routines that handle one-dimensional finite volume !! reconstruction using the piecewise quartic method (PQM). end module PQM_functions diff --git a/src/ALE/Recon1d_EMPLM_CWK.F90 b/src/ALE/Recon1d_EMPLM_CWK.F90 new file mode 100644 index 0000000000..bcd06c3f6f --- /dev/null +++ b/src/ALE/Recon1d_EMPLM_CWK.F90 @@ -0,0 +1,150 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Piecewise Linear Method 1D reconstruction in index space and boundary extrapolation +!! +!! This implementation of PLM follows Colella and Woodward, 1984 \cite colella1984, except for assuming +!! uniform resolution so that the method is independent of grid spacing. The cell-wise reconstructions +!! are limited so that the edge values (which are also the extrema in a cell) are bounded by the neighbors. +!! The slope of the first and last cells are set so that the first interior edge values match the interior +!! cell (i.e. extrapolates from the interior). +module Recon1d_EMPLM_CWK + +use Recon1d_type, only : testing +use Recon1d_MPLM_CWK, only : MPLM_CWK + +implicit none ; private + +public EMPLM_CWK, testing + +!> PLM reconstruction following Colella and Woodward, 1984 +!! +!! Implemented by extending recon1d_mplm_cwk. +!! +!! The source for the methods ultimately used by this class are: +!! - init() -> recon1d_mplm_cwk -> recon1d_plm_cw.init() +!! - reconstruct() *locally defined +!! - average() -> recon1d_mplm_cwk -> recon1d_plm_cw.average() +!! - f() -> recon1d_mplm_cwk -> recon1d_plm_cw.f() +!! - dfdx() -> recon1d_mplm_cwk -> recon1d_plm_cw.dfdx() +!! - check_reconstruction() -> recon1d_mplm_cwk.check_reconstruction() +!! - unit_tests() *locally defined +!! - destroy() -> recon1d_mplm_cwk -> recon1d_plm_cw.destroy() +!! - remap_to_sub_grid() -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> init() +!! - reconstruct_parent() -> recon1d_mplm_cwk.reconstruct() +type, extends (MPLM_CWK) :: EMPLM_CWK + +contains + !> Implementation of the EMPLM_CWK reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of unit tests for the EMPLM_CWK reconstruction + procedure :: unit_tests => unit_tests + +end type EMPLM_CWK + +contains + +!> Calculate a 1D PLM reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(EMPLM_CWK), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: slp ! The PLM slopes (difference across cell) [A] + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [A] + real :: u_min, u_max ! Minimum and maximum value across cell [A] + real :: u_l, u_r, u_c ! Left, right, and center values [A] + real :: u_e(this%n+1) ! Average of edge values [A] + integer :: k, n + + n = this%n + + call this%reconstruct_parent(h, u) + + this%ur(1) = this%ul(2) + this%ul(1) = u(1) + ( u(1) - this%ur(1) ) + + this%ul(n) = this%ur(n-1) + this%ur(n) = u(n) + ( u(n) - this%ul(n) ) + +end subroutine reconstruct + +!> Runs PLM reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(EMPLM_CWK), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + call this%init(3) + call test%test( this%n /= 3, 'Setting number of levels') + allocate( um(3), ul(3), ur(3), ull(3), urr(3) ) + + call this%reconstruct( (/2.,2.,2./), (/1.,3.,5./) ) + call test%real_arr(3, this%u_mean, (/1.,3.,5./), 'Setting cell values') + + do k = 1, 3 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(3, ul, (/0.,2.,4./), 'Evaluation on left edge') + call test%real_arr(3, um, (/1.,3.,5./), 'Evaluation in center') + call test%real_arr(3, ur, (/2.,4.,6./), 'Evaluation on right edge') + + do k = 1, 3 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + call test%real_arr(3, ul, (/2.,2.,2./), 'dfdx on left edge') + call test%real_arr(3, um, (/2.,2.,2./), 'dfdx in center') + call test%real_arr(3, ur, (/2.,2.,2./), 'dfdx on right edge') + + do k = 1, 3 + um(k) = this%average(k, 0.25, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + call test%real_arr(3, um, (/1.,3.,5./), 'Return interval average') + + call this%destroy() + deallocate( um, ul, ur, ull, urr ) + + allocate( um(4), ul(4), ur(4) ) + call this%init(4) + + ! These values lead to non-monotonic reconstuctions which are + ! valid for transport problems but not always appropriate for + ! remapping to arbitrary resolution grids. + ! The O(h^2) slopes are -, 2, 2, - and the limited + ! slopes are 0, 1, 1, 0 so the everywhere the reconstructions + ! are bounded by neighbors but ur(2) and ul(3) are out-of-order. + call this%reconstruct( (/1.,1.,1.,1./), (/0.,3.,4.,7./) ) + do k = 1, 4 + ul(k) = this%f(k, 0.) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(4, ul, (/-2.5,2.5,3.5,4.5/), 'Evaluation on left edge') + call test%real_arr(4, ur, (/2.5,3.5,4.5,9.5/), 'Evaluation on right edge') + + deallocate( um, ul, ur ) + + unit_tests = test%summarize('EMPLM_CWK:unit_tests') + +end function unit_tests + +!> \namespace recon1d_emplm_cwk +!! + +end module Recon1d_EMPLM_CWK diff --git a/src/ALE/Recon1d_EMPLM_WA.F90 b/src/ALE/Recon1d_EMPLM_WA.F90 new file mode 100644 index 0000000000..b72203e0f0 --- /dev/null +++ b/src/ALE/Recon1d_EMPLM_WA.F90 @@ -0,0 +1,174 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Extrapolated-Monotonized Piecewise Linear Method 1D reconstruction +!! +!! This extends MPLM_WA, following White and Adcroft, 2008 \cite white2008, by extrapolating for the slopes of the +!! first and last cells. This extrapolation is used by White et al., 2009, during grid-generation. +module Recon1d_EMPLM_WA + +use Recon1d_MPLM_WA, only : MPLM_WA, testing + +implicit none ; private + +public EMPLM_WA + +!> Extraplated Monotonic PLM reconstruction of White and Adcroft, 2008 +!! +!! The source for the methods ultimately used by this class are: +!! - init() -> recon1d_mplm_wa -> recon1d_plm_cw.init() +!! - reconstruct() *locally defined +!! - average() -> recon1d_mplm_wa -> recon1d_plm_cw.average() +!! - f() -> recon1d_mplm_wa -> recon1d_plm_cw.f() +!! - dfdx() -> recon1d_mplm_wa -> recon1d_plm_cw.dfdx() +!! - check_reconstruction() -> recon1d_mplm_wa.check_reconstruction() +!! - unit_tests() *locally defined +!! - destroy() -> recon1d_mplm_wa -> recon1d_plm_cw.destroy() +!! - remap_to_sub_grid() -> recon1d_mplm_wa -> recon1d_plm_cw -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> recon1d_mplm_wa -> recon1d_plm_cw.init() +!! - reconstruct_parent() -> recon1d_mplm_wa.reconstruct() +type, extends (MPLM_WA) :: EMPLM_WA + +contains + !> Implementation of the EMPLM_WA reconstruction with boundary extrapolation + procedure :: reconstruct => reconstruct + !> Implementation of unit tests for the EMPLM_WA reconstruction + procedure :: unit_tests => unit_tests + +end type EMPLM_WA + +contains + +!> Calculate a 1D PLM reconstruction based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(EMPLM_WA), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: n + real :: slope ! Difference of u across cell [A] + real :: edge_h2 ! Edge value found by linear interpolation [A] + real :: slope_h2 ! Twice the difference between cell center and 2nd order edge value [A] + real :: slope_e ! Twice the difference between cell center and neighbor edge value [A] + real :: hn, hc ! Neighbor and central cell thicknesses adjusted by h_neglect [H] + real :: u_min, u_max ! Working values for bounding edge values [A] + + ! Use parent (MPLM_WA) reconstruction + call this%reconstruct_parent(h, u) + + ! Fix reconstruction for first cell + ! Avoid division by zero for vanished cells + hn = h(2) + this%h_neglect + hc = h(1) + this%h_neglect + edge_h2 = ( u(2) * hc + u(1) * hn ) / ( hn + hc ) + slope_h2 = 2.0 * ( edge_h2 - u(1) ) + slope_e = 2.0 * ( this%ul(2) - u(1) ) + slope = sign( min( abs(slope_h2), abs(slope_e) ), u(2) - u(1) ) + edge_h2 = u(1) + 0.5 * slope + u_min = min( this%ul(2), u(1) ) + u_max = max( this%ul(2), u(1) ) + this%ur(1) = max( u_min, min( u_max, edge_h2 ) ) + this%ul(1) = u(1) - 0.5 * slope +! slope = - PLM_extrapolate_slope( h(2), h(1), this%h_neglect, this%ul(2), u(1) ) +! this%ul(1) = u(1) - 0.5 * slope +! this%ur(1) = u(1) + 0.5 * slope + + ! Fix reconstruction for last cell + n = this%n + ! Avoid division by zero for vanished cells + hn = h(n-1) + this%h_neglect + hc = h(n) + this%h_neglect + edge_h2 = ( u(n-1) * hc + u(n) * hn ) / ( hn + hc ) + slope_h2 = 2.0 * ( u(n) - edge_h2 ) + slope_e = 2.0 * ( u(n) - this%ur(n-1) ) + slope = sign( min( abs(slope_h2), abs(slope_e) ), u(n) - u(n-1) ) + edge_h2 = u(n) - 0.5 * slope + u_min = min( this%ur(n-1), u(n) ) + u_max = max( this%ur(n-1), u(n) ) + this%ul(n) = max( u_min, min( u_max, edge_h2 ) ) + this%ur(n) = u(n) + 0.5 * slope +! slope = PLM_extrapolate_slope( h(n-1), h(n), this%h_neglect, this%ur(n-1), u(n) ) +! this%ul(n) = u(n) - 0.5 * slope +! this%ur(n) = u(n) + 0.5 * slope + +end subroutine reconstruct + +!> Returns a PLM slope using h2 extrapolation from a cell to the left, in the same +!! arbitrary units as the input values [A]. +!! Use the negative to extrapolate from the cell to the right. +real elemental pure function PLM_extrapolate_slope(h_l, h_c, h_neglect, u_l, u_c) + real, intent(in) :: h_l !< Thickness of left cell in arbitrary grid thickness units [H] + real, intent(in) :: h_c !< Thickness of center cell in arbitrary grid thickness units [H] + real, intent(in) :: h_neglect !< A negligible thickness [H] + real, intent(in) :: u_l !< Value of left cell in arbitrary units [A] + real, intent(in) :: u_c !< Value of center cell in arbitrary units [A] + ! Local variables + real :: left_edge ! Left edge value [A] + real :: hl, hc ! Left and central cell thicknesses [H] + + ! Avoid division by zero for vanished cells + hl = h_l + h_neglect + hc = h_c + h_neglect + + ! The h2 scheme is used to compute the left edge value + left_edge = (u_l*hc + u_c*hl) / (hl + hc) + + PLM_extrapolate_slope = 2.0 * ( u_c - left_edge ) + +end function PLM_extrapolate_slope + +!> Runs PLM reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(EMPLM_WA), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + call this%init(3) + call test%test( this%n /= 3, 'Setting number of levels') + allocate( um(3), ul(3), ur(3), ull(3), urr(3) ) + + call this%reconstruct( (/2.,2.,2./), (/1.,3.,5./) ) + call test%real_arr(3, this%u_mean, (/1.,3.,5./), 'Setting cell values') + + do k = 1, 3 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(3, ul, (/0.,2.,4./), 'Evaluation on left edge') + call test%real_arr(3, um, (/1.,3.,5./), 'Evaluation in center') + call test%real_arr(3, ur, (/2.,4.,6./), 'Evaluation on right edge') + + do k = 1, 3 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + call test%real_arr(3, ul, (/2.,2.,2./), 'dfdx on left edge') + call test%real_arr(3, um, (/2.,2.,2./), 'dfdx in center') + call test%real_arr(3, ur, (/2.,2.,2./), 'dfdx on right edge') + + do k = 1, 3 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + call test%real_arr(3, um, (/1.25,3.25,5.25/), 'Return interval average') + + unit_tests = test%summarize('EMPLM_WA:unit_tests') + +end function unit_tests + +!> \namespace recon1d_emplm_wa +!! + +end module Recon1d_EMPLM_WA diff --git a/src/ALE/Recon1d_EMPLM_WA_poly.F90 b/src/ALE/Recon1d_EMPLM_WA_poly.F90 new file mode 100644 index 0000000000..8aa06a883a --- /dev/null +++ b/src/ALE/Recon1d_EMPLM_WA_poly.F90 @@ -0,0 +1,202 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Extrapolated-Monotonized Piecewise Linear Method 1D reconstruction +!! +!! This extends MPLM_poly, following White and Adcroft, 2008 \cite white2008, by extraplating for the slopes of the +!! first and last cells. This extrapolation is used by White et al., 2009, during grid-generation. +!! +!! This stores and evaluates the reconstruction using a polynomial representation which is not preferred +!! but was the form used in OM4. +module Recon1d_EMPLM_WA_poly + +use Recon1d_MPLM_WA_poly, only : MPLM_WA_poly, testing + +implicit none ; private + +public EMPLM_WA_poly + +!> Extrapolation Limited Monotonic PLM reconstruction following White and Adcroft, 2008 +!! +!! The source for the methods ultimately used by this class are: +!! - init() -> recon1d_mplm_wa_poly.init() +!! - reconstruct() -> recon1d_mplm_wa_poly.reconstruct() +!! - average() -> recon1d_mplm_wa_poly.average() +!! - f() -> recon1d_mplm_wa_poly -> recon1d_mplm_wa -> recon1d_plm_cw.f() +!! - dfdx() -> recon1d_mplm_wa_poly -> recon1d_mplm_wa -> recon1d_plm_cw.dfdx() +!! - check_reconstruction() *locally defined +!! - unit_tests() *locally defined +!! - destroy() -> recon1d_mplm_wa_poly -> recon1d_mplm_wa -> recon1d_plm_cw.destroy() +!! - remap_to_sub_grid() *locally defined +!! - init_parent() -> recon1d_mplm_wa_poly -> recon1d_mplm_wa.init() +!! - reconstruct_parent() -> recon1d_mplm_wa_poly -> recon1d_mplm_wa.reconstruct() +type, extends (MPLM_WA_poly) :: EMPLM_WA_poly + +contains + !> Implementation of the EMPLM_WA_poly reconstruction with boundary extrapolation + procedure :: reconstruct => reconstruct + !> Implementation of check reconstruction for the EMPLM_WA_poly reconstruction + procedure :: check_reconstruction => check_reconstruction + !> Implementation of unit tests for the EMPLM_WA_poly reconstruction + procedure :: unit_tests => unit_tests + +end type EMPLM_WA_poly + +contains + +!> Calculate a 1D PLM reconstruction based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(EMPLM_WA_poly), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: n + real :: slope ! Difference of u across cell [A] + + ! Use parent (MPLM_WA) reconstruction + call this%reconstruct_parent(h, u) + + n = this%n + + ! Fix reconstruction for first cell + slope = - PLM_extrapolate_slope( h(2), h(1), this%h_neglect, u(2), u(1) ) + this%ul(1) = u(1) - 0.5 * slope + this%ur(1) = u(1) + 0.5 * slope + this%poly_coef(1,1) = this%ul(1) + this%poly_coef(1,2) = this%ur(1) - this%ul(1) + + ! Fix reconstruction for last cell + slope = PLM_extrapolate_slope( h(n-1), h(n), this%h_neglect, u(n-1), u(n) ) + this%ul(n) = u(n) - 0.5 * slope + this%ur(n) = u(n) + 0.5 * slope + this%poly_coef(n,1) = this%ul(n) + this%poly_coef(n,2) = this%ur(n) - this%ul(n) + +end subroutine reconstruct + +!> Returns a PLM slope using h2 extrapolation from a cell to the left, in the same +!! arbitrary units as the input values [A]. +!! Use the negative to extrapolate from the cell to the right. +real elemental pure function PLM_extrapolate_slope(h_l, h_c, h_neglect, u_l, u_c) + real, intent(in) :: h_l !< Thickness of left cell in arbitrary grid thickness units [H] + real, intent(in) :: h_c !< Thickness of center cell in arbitrary grid thickness units [H] + real, intent(in) :: h_neglect !< A negligible thickness [H] + real, intent(in) :: u_l !< Value of left cell in arbitrary units [A] + real, intent(in) :: u_c !< Value of center cell in arbitrary units [A] + ! Local variables + real :: left_edge ! Left edge value [A] + real :: hl, hc ! Left and central cell thicknesses [H] + + ! Avoid division by zero for vanished cells + hl = h_l + h_neglect + hc = h_c + h_neglect + + ! The h2 scheme is used to compute the left edge value + left_edge = (u_l*hc + u_c*hl) / (hl + hc) + + PLM_extrapolate_slope = 2.0 * ( u_c - left_edge ) + +end function PLM_extrapolate_slope + +!> Checks the EMPLM_WA_poly reconstruction for consistency +logical function check_reconstruction(this, h, u) + class(EMPLM_WA_poly), intent(in) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k + + check_reconstruction = .false. + + do k = 1, this%n + if ( abs( this%u_mean(k) - u(k) ) > 0. ) check_reconstruction = .true. + enddo + + ! Check implied curvature + do k = 1, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ur(k) - this%u_mean(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! These two checks fail MOM_remapping:test_recon_consistency in the presence of vanished layers + ! e.g. intel/2023.2.0 on gaea at iter=26 + +! ! Check bounding of right edges, w.r.t. the cell means +! do K = 1, this%n-1 +! if ( ( this%ur(k) - this%u_mean(k) ) * ( this%u_mean(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. +! enddo + +! ! Check bounding of left edges, w.r.t. the cell means +! do K = 2, this%n +! if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%u_mean(k-1) ) < 0. ) check_reconstruction = .true. +! enddo + + ! Check order of u, ur, ul + ! Note that in the OM4-era implementation, we were not consistent for top and bottom layers due + ! extrapolation using cell means rather than edge values, hence reduced range for K + do K = 2, this%n-2 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%ul(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. this cell mean and the previous cell right edge + do K = 3, this%n-1 + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%ur(k-1) ) < 0. ) check_reconstruction = .true. + enddo + +end function check_reconstruction + + +!> Runs PLM reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(EMPLM_WA_poly), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + call this%init(3) + call test%test( this%n /= 3, 'Setting number of levels') + allocate( um(3), ul(3), ur(3), ull(3), urr(3) ) + + call this%reconstruct( (/2.,2.,2./), (/1.,3.,5./) ) + call test%real_arr(3, this%u_mean, (/1.,3.,5./), 'Setting cell values') + + do k = 1, 3 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(3, ul, (/0.,2.,4./), 'Evaluation on left edge') + call test%real_arr(3, um, (/1.,3.,5./), 'Evaluation in center') + call test%real_arr(3, ur, (/2.,4.,6./), 'Evaluation on right edge') + + do k = 1, 3 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + call test%real_arr(3, ul, (/2.,2.,2./), 'dfdx on left edge') + call test%real_arr(3, um, (/2.,2.,2./), 'dfdx in center') + call test%real_arr(3, ur, (/2.,2.,2./), 'dfdx on right edge') + + do k = 1, 3 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + call test%real_arr(3, um, (/1.25,3.25,5.25/), 'Return interval average') + + unit_tests = test%summarize('EMPLM_WA_poly:unit_tests') + +end function unit_tests + +!> \namespace recon1d_emplm_wa_poly +!! + +end module Recon1d_EMPLM_WA_poly diff --git a/src/ALE/Recon1d_EPPM_CWK.F90 b/src/ALE/Recon1d_EPPM_CWK.F90 new file mode 100644 index 0000000000..e39bf557e0 --- /dev/null +++ b/src/ALE/Recon1d_EPPM_CWK.F90 @@ -0,0 +1,177 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Piecewise Parabolic Method 1D reconstruction in model index space with linear +!! extrapolation for first and last cells +!! +!! This implementation of PPM follows Colella and Woodward, 1984, using uniform thickness +!! and with cells resorting to PCM for local extrema. First and last cells use a PLM +!! representation with slope set by matching the edge of the first interior cell. +module Recon1d_EPPM_CWK + +use Recon1d_type, only : Recon1d, testing +use Recon1d_PPM_CWK, only : PPM_CWK + +implicit none ; private + +public EPPM_CWK, testing + +!> PPM reconstruction in index space (no grid dependence) with linear extrapolation +!! for first and last cells. +!! +!! Implemented by extending recon1d_ppm_cwk. +!! +!! The source for the methods ultimately used by this class are: +!! - init() -> recon1d_ppm_cwk.init() +!! - reconstruct() *locally defined +!! - average() -> recon1d_ppm_cwk.average() +!! - f() -> recon1d_ppm_cwk.f() +!! - dfdx() -> recon1d_ppm_cwk.dfdx() +!! - check_reconstruction() -> recon1d_ppm_cwk.check_reconstruction() +!! - unit_tests() *locally defined +!! - destroy() -> recon1d_ppm_cwk.destroy() +!! - remap_to_sub_grid() -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> recon1d_ppm_cwk.init() +!! - reconstruct_parent() -> recon1d_ppm_cwk.reconstruct() +type, extends (PPM_CWK) :: EPPM_CWK + +contains + !> Implementation of the EPPM_CWK reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of unit tests for the EPPM_CWK reconstruction + procedure :: unit_tests => unit_tests + +end type EPPM_CWK + +contains + +!> Calculate a 1D EPPM_CWK reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(EPPM_CWK), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: dul, dur ! Left and right cell PLM slopes [A] + real :: u0, u1, u2 ! Far left, left, and right cell values [A] + real :: edge ! Edge value between cell k-1 and k [A] + real :: u_min, u_max ! Minimum and maximum value across edge [A] + real :: a6 ! Colella and Woodward curvature [A] + real :: du ! Difference between edges across cell [A] + real :: slp(this%n) ! PLM slope [A] + real, parameter :: one_sixth = 1. / 6. ! 1/6 [nondim] + integer :: k, n + + n = this%n + + call this%reconstruct_parent( h, u ) + + ! Extrapolate in first cell + this%ur(1) = this%ul(2) ! Assume ur=ul on right edge + this%ul(1) = u(1) + ( u(1) - this%ur(1) ) ! Linearly extrapolat across cell + + ! Extrapolate in last cell + this%ul(n) = this%ur(n-1) ! Assume ul=ur on left edge + this%ur(n) = u(n) + ( u(n) - this%ul(n) ) ! Linearly extrapolat across cell + +end subroutine reconstruct + +!> Runs EPPM_CWK reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(EPPM_CWK), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + if (verbose) write(stdout,'(a)') 'EPPM_CWK:unit_tests testing with linear fn' + + call this%init(5) + call test%test( this%n /= 5, 'Setting number of levels') + allocate( um(5), ul(5), ur(5), ull(5), urr(5) ) + + ! Straight line, f(x) = x , or f(K) = 2*K + call this%reconstruct( (/2.,2.,2.,2.,2./), (/1.,4.,7.,10.,13./) ) + call test%real_arr(5, this%u_mean, (/1.,4.,7.,10.,13./), 'Setting cell values') + call test%real_arr(5, this%ul, (/-0.5,2.5,5.5,8.5,11.5/), 'Left edge values') + call test%real_arr(5, this%ur, (/2.5,5.5,8.5,11.5,14.5/), 'Right edge values') + + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, this%ul, 'Evaluation on left edge') + call test%real_arr(5, um, (/1.,4.,7.,10.,13./), 'Evaluation in center') + call test%real_arr(5, ur, this%ur, 'Evaluation on right edge') + + do k = 1, 5 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + ! Most of these values are affected by the PLM boundary cells + call test%real_arr(5, ul, (/3.,3.,3.,3.,3./), 'dfdx on left edge') + call test%real_arr(5, um, (/3.,3.,3.,3.,3./), 'dfdx in center') + call test%real_arr(5, ur, (/3.,3.,3.,3.,3./), 'dfdx on right edge') + + do k = 1, 5 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + ! Most of these values are affected by the PLM boundary cells + call test%real_arr(5, um, (/1.375,4.375,7.375,10.375,13.375/), 'Return interval average') + + if (verbose) write(stdout,'(a)') 'EPPM_CWK:unit_tests testing with parabola' + + ! x = 2 i i=0 at origin + ! f(x) = 3/4 x^2 = (2 i)^2 + ! f[i] = 3/4 ( 2 i - 1 )^2 on centers + ! f[I] = 3/4 ( 2 I )^2 on edges + ! f[i] = 1/8 [ x^3 ] for means + ! edges: 0, 1, 12, 27, 48, 75 + ! means: 1, 7, 19, 37, 61 + ! centers: 0.75, 6.75, 18.75, 36.75, 60.75 + call this%reconstruct( (/2.,2.,2.,2.,2./), (/1.,7.,19.,37.,61./) ) + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, (/-1.,3.,12.,27.,48./), 'Return left edge') + call test%real_arr(5, um, (/1.,6.75,18.75,36.75,61./), 'Return center') + call test%real_arr(5, ur, (/3.,12.,27.,48.,74./), 'Return right edge') + + ! x = 3 i i=0 at origin + ! f(x) = x^2 / 3 = 3 i^2 + ! f[i] = [ ( 3 i )^3 - ( 3 i - 3 )^3 ] i=1,2,3,4,5 + ! means: 1, 7, 19, 37, 61 + ! edges: 0, 3, 12, 27, 48, 75 + call this%reconstruct( (/3.,3.,3.,3.,3./), (/1.,7.,19.,37.,61./) ) + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, (/-1.,3.,12.,27.,48./), 'Return left edge') + call test%real_arr(5, um, (/1.,6.75,18.75,36.75,61./), 'Return center') + call test%real_arr(5, ur, (/3.,12.,27.,48.,74./), 'Return right edge') + + call this%destroy() + deallocate( um, ul, ur, ull, urr ) + + unit_tests = test%summarize('EPPM_CWK:unit_tests') + +end function unit_tests + +!> \namespace recon1d_eppm_cwk +!! + +end module Recon1d_EPPM_CWK diff --git a/src/ALE/Recon1d_MPLM_CWK.F90 b/src/ALE/Recon1d_MPLM_CWK.F90 new file mode 100644 index 0000000000..87d623cf53 --- /dev/null +++ b/src/ALE/Recon1d_MPLM_CWK.F90 @@ -0,0 +1,294 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Piecewise Linear Method 1D reconstruction in index space +!! +!! This implementation of PLM follows Colella and Woodward, 1984 \cite colella1984, except for assuming +!! uniform resolution so that the method is independent of grid spacing. The cell-wise reconstructions +!! are limited so that the edge values (which are also the extrema in a cell) are bounded by the neighbors. +!! The first and last cells are always limited to PCM. +module Recon1d_MPLM_CWK + +use Recon1d_type, only : testing +use Recon1d_PLM_CWK, only : PLM_CWK + +implicit none ; private + +public MPLM_CWK, testing + +!> PLM reconstruction following Colella and Woodward, 1984 +!! +!! Implemented by extending recon1d_plm_cwk. +!! +!! The source for the methods ultimately used by this class are: +!! - init() -> recon1d_plm_cwk -> recon1d_plm_cw.init() +!! - reconstruct() *locally defined +!! - average() -> recon1d_plm_cwk -> recon1d_plm_cw.average() +!! - f() -> recon1d_plm_cwk -> recon1d_plm_cw.f() +!! - dfdx() -> recon1d_plm_cwk -> recon1d_plm_cw.dfdx() +!! - check_reconstruction() *locally defined +!! - unit_tests() *locally defined +!! - destroy() -> recon1d_plm_cwk -> recon1d_plm_cw.destroy() +!! - remap_to_sub_grid() -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> init() +!! - reconstruct_parent() -> reconstruct() +type, extends (PLM_CWK) :: MPLM_CWK + +contains + !> Implementation of the MPLM_CWK reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of check reconstruction for the MPLM_CWK reconstruction + procedure :: check_reconstruction => check_reconstruction + !> Implementation of unit tests for the MPLM_CWK reconstruction + procedure :: unit_tests => unit_tests + + !> Duplicate interface to reconstruct() + procedure :: reconstruct_parent => reconstruct +end type MPLM_CWK + +contains + +!> Calculate a 1D PLM reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(MPLM_CWK), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: slp ! The PLM slopes (difference across cell) [A] + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [A] + real :: u_min, u_max ! Minimum and maximum value across cell [A] + real :: u_l, u_r, u_c ! Left, right, and center values [A] + real :: u_e(this%n+1) ! Average of edge values [A] + integer :: k, n + + n = this%n + + ! Loop over all cells + do k = 1, n + this%u_mean(k) = u(k) + enddo + + ! Boundary cells use PCM + this%ul(1) = u(1) + this%ur(1) = u(1) + + ! Loop over interior cells + do k = 2, n-1 + u_l = u(k-1) + u_c = u(k) + u_r = u(k+1) + + ! Side differences + sigma_r = u_r - u_c + sigma_l = u_c - u_l + + ! This is the second order slope given by equation 1.7 of + ! Piecewise Parabolic Method, Colella and Woodward (1984), + ! http://dx.doi.org/10.1016/0021-991(84)90143-8. + ! For uniform resolution it simplifies to ( u_r - u_l )/2 . + sigma_c = 0.5 * ( u_r - u_l ) + + ! Limit slope so that reconstructions are bounded by neighbors + u_min = min( u_l, u_c, u_r ) + u_max = max( u_l, u_c, u_r ) + + if ( (sigma_l * sigma_r) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the two cell averages spanning the edge + slp = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) + else + ! Extrema in the mean values require a PCM reconstruction + slp = 0.0 + endif + + ! Left edge + u_min = min( u_c, u_l ) + u_max = max( u_c, u_l ) + u_l = u_c - 0.5 * slp + this%ul(k) = max( min( u_l, u_max), u_min ) + + ! Right edge + u_min = min( u_c, u_r ) + u_max = max( u_c, u_r ) + u_r = u_c + 0.5 * slp + this%ur(k) = max( min( u_r, u_max), u_min ) + enddo + + ! Boundary cells use PCM + this%ul(n) = u(n) + this%ur(n) = u(n) + + ! Average edge values + u_e(1) = this%ul(1) + do K = 2, n + u_e(K) = 0.5 * ( this%ur(k-1) + this%ul(k) ) + enddo + u_e(n+1) = this%ur(n) + + ! Loop over interior cells, redo PLM slope limiting using average edge as neighbor cell values + do k = 2, n-1 + u_l = u_e(k) + u_c = u(k) + u_r = u_e(k+1) + + ! Side differences + sigma_r = u_r - u_c + sigma_l = u_c - u_l + + ! This is the second order slope given by equation 1.7 of + ! Piecewise Parabolic Method, Colella and Woodward (1984), + ! http://dx.doi.org/10.1016/0021-991(84)90143-8. + ! For uniform resolution it simplifies to ( u_r - u_l )/2 . + sigma_c = this%ur(k) - this%ul(k) + + ! Limit slope so that reconstructions are bounded by neighbors + u_min = min( u_l, u_c, u_r ) + u_max = max( u_l, u_c, u_r ) + + if ( (sigma_l * sigma_r) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the two cell averages spanning the edge + slp = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) + else + ! Extrema in the mean values require a PCM reconstruction + slp = 0.0 + endif + + ! Left edge + u_min = min( u_c, u_l ) + u_max = max( u_c, u_l ) + u_l = u_c - 0.5 * slp + this%ul(k) = max( min( u_l, u_max), u_min ) + + ! Right edge + u_min = min( u_c, u_r ) + u_max = max( u_c, u_r ) + u_r = u_c + 0.5 * slp + this%ur(k) = max( min( u_r, u_max), u_min ) + enddo + +end subroutine reconstruct + +!> Checks the MPLM_CWK reconstruction for consistency +logical function check_reconstruction(this, h, u) + class(MPLM_CWK), intent(in) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k + + check_reconstruction = .false. + + do k = 1, this%n + if ( abs( this%u_mean(k) - u(k) ) > 0. ) check_reconstruction = .true. + enddo + + ! Check the cell reconstruction is monotonic within each cell (it should be as a straight line) + do k = 1, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ur(k) - this%u_mean(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check the cell is a straight line (to within machine precision) + do k = 1, this%n + if ( abs(2. * this%u_mean(k) - ( this%ul(k) + this%ur(k) )) > epsilon(this%u_mean(1)) * & + max(abs(2. * this%u_mean(k)), abs(this%ul(k)), abs(this%ur(k))) ) check_reconstruction = .true. + enddo + + ! Check bounding of right edges, w.r.t. the cell means + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%u_mean(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. the cell means + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%u_mean(k-1) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of right edges, w.r.t. this cell mean and the next cell left edge + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%ul(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. this cell mean and the previous cell right edge + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%ur(k-1) ) < 0. ) check_reconstruction = .true. + enddo + +end function check_reconstruction + +!> Runs PLM reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(MPLM_CWK), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + call this%init(3) + call test%test( this%n /= 3, 'Setting number of levels') + allocate( um(3), ul(3), ur(3), ull(3), urr(3) ) + + call this%reconstruct( (/2.,2.,2./), (/1.,3.,5./) ) + call test%real_arr(3, this%u_mean, (/1.,3.,5./), 'Setting cell values') + + do k = 1, 3 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(3, ul, (/1.,2.,5./), 'Evaluation on left edge') + call test%real_arr(3, um, (/1.,3.,5./), 'Evaluation in center') + call test%real_arr(3, ur, (/1.,4.,5./), 'Evaluation on right edge') + + do k = 1, 3 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + call test%real_arr(3, ul, (/0.,2.,0./), 'dfdx on left edge') + call test%real_arr(3, um, (/0.,2.,0./), 'dfdx in center') + call test%real_arr(3, ur, (/0.,2.,0./), 'dfdx on right edge') + + do k = 1, 3 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + call test%real_arr(3, um, (/1.,3.25,5./), 'Return interval average') + + call this%destroy() + deallocate( um, ul, ur, ull, urr ) + + allocate( um(4), ul(4), ur(4) ) + call this%init(4) + + ! These values lead to non-monotonic reconstuctions which are + ! valid for transport problems but not always appropriate for + ! remapping to arbitrary resolution grids. + ! The O(h^2) slopes are -, 2, 2, - and the limited + ! slopes are 0, 1, 1, 0 so the everywhere the reconstructions + ! are bounded by neighbors but ur(2) and ul(3) are out-of-order. + call this%reconstruct( (/1.,1.,1.,1./), (/0.,3.,4.,7./) ) + do k = 1, 4 + ul(k) = this%f(k, 0.) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(4, ul, (/0.,2.5,3.5,7./), 'Evaluation on left edge') + call test%real_arr(4, ur, (/0.,3.5,4.5,7./), 'Evaluation on right edge') + + deallocate( um, ul, ur ) + + unit_tests = test%summarize('MPLM_CWK:unit_tests') + +end function unit_tests + +!> \namespace recon1d_mplm_cwk +!! + +end module Recon1d_MPLM_CWK diff --git a/src/ALE/Recon1d_MPLM_WA.F90 b/src/ALE/Recon1d_MPLM_WA.F90 new file mode 100644 index 0000000000..29b54ccdeb --- /dev/null +++ b/src/ALE/Recon1d_MPLM_WA.F90 @@ -0,0 +1,287 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Monotonized Piecewise Linear Method 1D reconstruction +!! +!! This implementation of PLM follows White and Adcroft, 2008 \cite white2008. +!! The PLM slopes are first limited following Colella and Woodward, 1984, but are then +!! further limited to ensure the edge values moving across cell boundaries are monotone. +!! The first and last cells are always limited to PCM. +!! +!! This differs from recon1d_mplm_wa_poly in the internally not polynomial representations +!! are referred to. +module Recon1d_MPLM_WA + +use Recon1d_PLM_CW, only : PLM_CW, testing + +implicit none ; private + +public MPLM_WA, testing + +!> Limited Monotonic PLM reconstruction following White and Adcroft, 2008 +!! +!! The source for the methods ultimately used by this class are: +!! - init() -> recon1d_plm_cw.init() +!! - reconstruct() *locally defined +!! - average() -> recon1d_plm_cw.average() +!! - f() -> recon1d_plm_cw.f() +!! - dfdx() -> recon1d_plm_cw.dfdx() +!! - check_reconstruction() *locally defined +!! - unit_tests() *locally defined +!! - destroy() -> recon1d_plm_cw.destroy() +!! - remap_to_sub_grid() -> recon1d_plm_cw -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> recon1d_plm_cw.init() +!! - reconstruct_parent() -> reconstruct() +type, extends (PLM_CW) :: MPLM_WA + +contains + !> Implementation of the MPLM_WA reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of check reconstruction for the MPLM_WA reconstruction + procedure :: check_reconstruction => check_reconstruction + !> Implementation of unit tests for the MPLM_WA reconstruction + procedure :: unit_tests => unit_tests + + !> Duplicate interface to reconstruct() + procedure :: reconstruct_parent => reconstruct + +end type MPLM_WA + +contains + +!> Calculate a 1D PLM reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(MPLM_WA), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: slp(this%n) ! The PLM slopes (difference across cell) [A] + real :: mslp(this%n) ! The monotonized PLM slopes [A] + integer :: k, n + real :: u_tmp, u_min, u_max ! Working values of cells [A] + + n = this%n + + ! Loop over all cells + do k = 1, n + this%u_mean(k) = u(k) + enddo + + ! Loop on interior cells + do k = 2, n-1 + slp(k) = PLM_slope_wa(h(k-1), h(k), h(k+1), this%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. + slp(1) = 0. + slp(n) = 0. + + ! This loop adjusts the slope so that edge values are monotonic. + do k = 2, n-1 + mslp(k) = PLM_monotonized_slope( u(k-1), u(k), u(k+1), slp(k-1), slp(k), slp(k+1) ) + enddo ! end loop on interior cells + mslp(1) = 0. + mslp(n) = 0. + + ! Store edge values + this%ul(1) = u(1) + this%ur(1) = u(1) + do k = 2, n-1 + u_tmp = u(k-1) + 0.5 * mslp(k-1) ! Right edge value of cell k-1 + u_min = min( u(k), u_tmp ) + u_max = max( u(k), u_tmp ) + u_tmp = u(k) - 0.5 * mslp(k) ! Left edge value of cell k + this%ul(k) = max( min( u_tmp, u_max), u_min ) ! Bounded to handle roundoff + u_tmp = u(k+1) - 0.5 * mslp(k-1) ! Left edge value of cell k+1 + u_min = min( u(k), u_tmp ) + u_max = max( u(k), u_tmp ) + u_tmp = u(k) + 0.5 * mslp(k) ! Right edge value of cell k + this%ur(k) = max( min( u_tmp, u_max), u_min ) ! Bounded to handle roundoff + enddo + this%ul(n) = u(n) + this%ur(n) = u(n) + +end subroutine reconstruct + +!> Returns a limited PLM slope following White and Adcroft, 2008, in the same arbitrary +!! units [A] as the input values. +!! Note that this is not the same as the Colella and Woodward method. +real elemental pure function PLM_slope_wa(h_l, h_c, h_r, h_neglect, u_l, u_c, u_r) + real, intent(in) :: h_l !< Thickness of left cell in arbitrary grid thickness units [H] + real, intent(in) :: h_c !< Thickness of center cell in arbitrary grid thickness units [H] + real, intent(in) :: h_r !< Thickness of right cell in arbitrary grid thickness units [H] + real, intent(in) :: h_neglect !< A negligible thickness [H] + real, intent(in) :: u_l !< Value of left cell in arbitrary units [A] + real, intent(in) :: u_c !< Value of center cell in arbitrary units [A] + real, intent(in) :: u_r !< Value of right cell in arbitrary units [A] + ! Local variables + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [A] + real :: u_min, u_max ! Minimum and maximum value across cell [A] + + ! Side differences + sigma_r = u_r - u_c + sigma_l = u_c - u_l + + ! Quasi-second order difference + sigma_c = 2.0 * ( u_r - u_l ) * ( h_c / ( h_l + 2.0*h_c + h_r + h_neglect) ) + + ! Limit slope so that reconstructions are bounded by neighbors + u_min = min( u_l, u_c, u_r ) + u_max = max( u_l, u_c, u_r ) + if ( (sigma_l * sigma_r) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the + ! two cell averages spanning the edge. + PLM_slope_wa = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) + else + ! Extrema in the mean values require a PCM reconstruction avoid generating + ! larger extreme values. + PLM_slope_wa = 0.0 + endif + +end function PLM_slope_wa + +!> Returns a limited PLM slope following Colella and Woodward 1984, in the same +!! arbitrary units as the input values [A]. +real elemental pure function PLM_monotonized_slope(u_l, u_c, u_r, s_l, s_c, s_r) + real, intent(in) :: u_l !< Value of left cell in arbitrary units [A] + real, intent(in) :: u_c !< Value of center cell in arbitrary units [A] + real, intent(in) :: u_r !< Value of right cell in arbitrary units [A] + real, intent(in) :: s_l !< PLM slope of left cell [A] + real, intent(in) :: s_c !< PLM slope of center cell [A] + real, intent(in) :: s_r !< PLM slope of right cell [A] + ! Local variables + real :: neighbor_edge ! Edge value of nieghbor cell [A] + real :: this_edge ! Edge value of this cell [A] + real :: slp ! Magnitude of PLM central slope [A] + + ! Comparison are made assuming +ve slopes + slp = abs(s_c) + + ! Check that left edge is between right edge of cell to the left and this cell mean + neighbor_edge = u_l + 0.5 * s_l + this_edge = u_c - 0.5 * s_c + if ( ( this_edge - neighbor_edge ) * ( u_c - this_edge ) < 0. ) then + ! Using the midpoint works because the neighbor is similarly adjusted + this_edge = 0.5 * ( this_edge + neighbor_edge ) + slp = min( slp, abs( this_edge - u_c ) * 2. ) + endif + + ! Check that right edge is between left edge of cell to the right and this cell mean + neighbor_edge = u_r - 0.5 * s_r + this_edge = u_c + 0.5 * s_c + if ( ( this_edge - u_c ) * ( neighbor_edge - this_edge ) < 0. ) then + ! Using the midpoint works because the neighbor is similarly adjusted + this_edge = 0.5 * ( this_edge + neighbor_edge ) + slp = min( slp, abs( this_edge - u_c ) * 2. ) + endif + + PLM_monotonized_slope = sign( slp, s_c ) + +end function PLM_monotonized_slope + +!> Checks the MPLM_WA reconstruction for consistency +logical function check_reconstruction(this, h, u) + class(MPLM_WA), intent(in) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k + + check_reconstruction = .false. + + do k = 1, this%n + if ( abs( this%u_mean(k) - u(k) ) > 0. ) check_reconstruction = .true. + enddo + + ! Check the cell reconstruction is monotonic within each cell (it should be as a straight line) + do k = 1, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ur(k) - this%u_mean(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! This next test fails abysmally! + ! Using intel/2023.2.0 on gaea, MOM_remapping:test_recon_consistency iter=6 + ! um~0.581492556923472 ul~0.402083491713151 ur~0.749082615698503 + ! Check the cell is a straight line (to within machine precision) +! do k = 1, this%n +! if ( abs(2. * this%u_mean(k) - ( this%ul(k) + this%ur(k) )) > epsilon(this%u_mean(1)) * & +! max(abs(2. * this%u_mean(k)), abs(this%ul(k)), abs(this%ur(k))) ) check_reconstruction = .true. +! enddo + + ! Check bounding of right edges, w.r.t. the cell means + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%u_mean(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. the cell means + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%u_mean(k-1) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check order of u, ur, ul + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%ul(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. this cell mean and the previous cell right edge + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%ur(k-1) ) < 0. ) check_reconstruction = .true. + enddo + +end function check_reconstruction + +!> Runs PLM reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(MPLM_WA), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + call this%init(3) + call test%test( this%n /= 3, 'Setting number of levels') + allocate( um(3), ul(3), ur(3), ull(3), urr(3) ) + + call this%reconstruct( (/2.,2.,2./), (/1.,3.,5./) ) + call test%real_arr(3, this%u_mean, (/1.,3.,5./), 'Setting cell values') + + do k = 1, 3 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(3, ul, (/1.,2.,5./), 'Evaluation on left edge') + call test%real_arr(3, um, (/1.,3.,5./), 'Evaluation in center') + call test%real_arr(3, ur, (/1.,4.,5./), 'Evaluation on right edge') + + do k = 1, 3 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + call test%real_arr(3, ul, (/0.,2.,0./), 'dfdx on left edge') + call test%real_arr(3, um, (/0.,2.,0./), 'dfdx in center') + call test%real_arr(3, ur, (/0.,2.,0./), 'dfdx on right edge') + + do k = 1, 3 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + call test%real_arr(3, um, (/1.,3.25,5./), 'Return interval average') + + unit_tests = test%summarize('MPLM_WA:unit_tests') + +end function unit_tests + +!> \namespace recon1d_mplm_wa +!! + +end module Recon1d_MPLM_WA diff --git a/src/ALE/Recon1d_MPLM_WA_poly.F90 b/src/ALE/Recon1d_MPLM_WA_poly.F90 new file mode 100644 index 0000000000..333377f726 --- /dev/null +++ b/src/ALE/Recon1d_MPLM_WA_poly.F90 @@ -0,0 +1,492 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Monotonized Piecewise Linear Method 1D reconstruction using polynomial representation +!! +!! This implementation of PLM follows White and Adcroft, 2008 \cite white2008. +!! The PLM slopes are first limited following Colella and Woodward, 1984, but are then +!! further limited to ensure the edge values moving across cell boundaries are monotone. +!! The first and last cells are always limited to PCM. +!! +!! This stores and evaluates the reconstruction using a polynomial representation which is +!! not preferred but was the form used in OM4. +module Recon1d_MPLM_WA_poly + +use Recon1d_MPLM_WA, only : MPLM_WA, testing + +implicit none ; private + +public MPLM_WA_poly, testing + +!> Limited Monotonic PLM reconstruction following White and Adcroft, 2008 +!! +!! The source for the methods ultimately used by this class are: +!! - init() *locally defined +!! - reconstruct() *locally defined +!! - average() *locally defined +!! - f() -> recon1d_mplm_wa -> recon1d_plm_cw.f() +!! - dfdx() -> recon1d_mplm_wa -> recon1d_plm_cw.dfdx() +!! - check_reconstruction() *locally defined +!! - unit_tests() *locally defined +!! - destroy() -> recon1d_mplm_wa -> recon1d_plm_cw.destroy() +!! - remap_to_sub_grid() *locally defined +!! - init_parent() -> init() +!! - reconstruct_parent() -> reconstruct() +type, extends (MPLM_WA) :: MPLM_WA_poly + + ! Legacy representation + integer :: degree !< Degree of polynomial used in legacy representation + real, allocatable, dimension(:,:) :: poly_coef !< Polynomial coefficients in legacy representation + +contains + !> Implementation of the MPLM_WA_poly initialization + procedure :: init => init + !> Implementation of the MPLM_WA_poly reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of the MPLM_WA_poly average over an interval [A] + procedure :: average => average + !> Implementation of check reconstruction for the MPLM_WA_poly reconstruction + procedure :: check_reconstruction => check_reconstruction + !> Implementation of unit tests for the MPLM_WA_poly reconstruction + procedure :: unit_tests => unit_tests + + !> Duplicate interface to init() + procedure :: init_parent => init + !> Duplicate interface to reconstruct() + procedure :: reconstruct_parent => reconstruct + +#undef USE_BASE_CLASS_REMAP +#ifndef USE_BASE_CLASS_REMAP +! This block is here to test whether the compiler can do better if we have local copies of +! the remapping functions. + !> Remaps the column to subgrid h_sub + procedure :: remap_to_sub_grid => remap_to_sub_grid +#endif + +end type MPLM_WA_poly + +contains + +!> Initialize a 1D PLM reconstruction for n cells +subroutine init(this, n, h_neglect, check) + class(MPLM_WA_poly), intent(out) :: this !< This reconstruction + integer, intent(in) :: n !< Number of cells in this column + real, optional, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H] + logical, optional, intent(in) :: check !< If true, enable some consistency checking + + this%n = n + + allocate( this%u_mean(n) ) + allocate( this%ul(n) ) + allocate( this%ur(n) ) + + this%h_neglect = tiny( this%u_mean(1) ) + if (present(h_neglect)) this%h_neglect = h_neglect + this%check = .false. + if (present(check)) this%check = check + + this%degree = 2 + allocate( this%poly_coef(n,2) ) + +end subroutine init + +!> Calculate a 1D MPLM_WA_poly reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(MPLM_WA_poly), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: slp(this%n) ! The PLM slopes (difference across cell) [A] + real :: mslp(this%n) ! The monotonized PLM slopes [A] + real :: e_r, edge ! Edge values [A] + real :: almost_one ! A value that is slightly smaller than 1 [nondim] + integer :: k, n + + n = this%n + + ! Loop over all cells + do k = 1, n + this%u_mean(k) = u(k) + enddo + + ! Loop on interior cells + do k = 2, n-1 + slp(k) = PLM_slope_wa(h(k-1), h(k), h(k+1), this%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. + slp(1) = 0. + slp(n) = 0. + + ! This loop adjusts the slope so that edge values are monotonic. + do k = 2, n-1 + mslp(k) = PLM_monotonized_slope( u(k-1), u(k), u(k+1), slp(k-1), slp(k), slp(k+1) ) + enddo ! end loop on interior cells + mslp(1) = 0. + mslp(n) = 0. + + ! Store and return edge values and polynomial coefficients. + almost_one = 1. - epsilon(e_r) + this%ul(1) = u(1) + this%ur(1) = u(1) + this%poly_coef(1,1) = u(1) + this%poly_coef(1,2) = 0. + do k = 2, n-1 + this%ul(k) = u(k) - 0.5 * mslp(k) ! Left edge value of cell k + this%ur(k) = u(k) + 0.5 * mslp(k) ! Right edge value of cell k + + this%poly_coef(k,1) = this%ul(k) + this%poly_coef(k,2) = this%ur(k) - this%ul(k) + ! Check to see if this evaluation of the polynomial at x=1 would be + ! monotonic w.r.t. the next cell's edge value. If not, scale back! + edge = this%poly_coef(k,2) + this%poly_coef(k,1) + e_r = u(k+1) - 0.5 * sign( mslp(k+1), slp(k+1) ) + if ( (edge-u(k))*(e_r-edge)<0.) then + this%poly_coef(k,2) = this%poly_coef(k,2) * almost_one + endif + enddo + this%ul(n) = u(n) + this%ur(n) = u(n) + this%poly_coef(n,1) = u(n) + this%poly_coef(n,2) = 0. + +end subroutine reconstruct + +!> Returns a limited PLM slope following White and Adcroft, 2008, in the same arbitrary +!! units [A] as the input values. +!! Note that this is not the same as the Colella and Woodward method. +real elemental pure function PLM_slope_wa(h_l, h_c, h_r, h_neglect, u_l, u_c, u_r) + real, intent(in) :: h_l !< Thickness of left cell in arbitrary grid thickness units [H] + real, intent(in) :: h_c !< Thickness of center cell in arbitrary grid thickness units [H] + real, intent(in) :: h_r !< Thickness of right cell in arbitrary grid thickness units [H] + real, intent(in) :: h_neglect !< A negligible thickness [H] + real, intent(in) :: u_l !< Value of left cell in arbitrary units [A] + real, intent(in) :: u_c !< Value of center cell in arbitrary units [A] + real, intent(in) :: u_r !< Value of right cell in arbitrary units [A] + ! Local variables + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [A] + real :: u_min, u_max ! Minimum and maximum value across cell [A] + + ! Side differences + sigma_r = u_r - u_c + sigma_l = u_c - u_l + + ! Quasi-second order difference + sigma_c = 2.0 * ( u_r - u_l ) * ( h_c / ( h_l + 2.0*h_c + h_r + h_neglect) ) + + ! Limit slope so that reconstructions are bounded by neighbors + u_min = min( u_l, u_c, u_r ) + u_max = max( u_l, u_c, u_r ) + if ( (sigma_l * sigma_r) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the + ! two cell averages spanning the edge. + PLM_slope_wa = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) + else + ! Extrema in the mean values require a PCM reconstruction avoid generating + ! larger extreme values. + PLM_slope_wa = 0.0 + endif + + ! This block tests to see if roundoff causes edge values to be out of bounds + if (u_c - 0.5*abs(PLM_slope_wa) < u_min .or. u_c + 0.5*abs(PLM_slope_wa) > u_max) then + PLM_slope_wa = PLM_slope_wa * ( 1. - epsilon(PLM_slope_wa) ) + endif + + ! An attempt to avoid inconsistency when the values become unrepresentable. + ! ### The following 1.E-140 is dimensionally inconsistent. A newer version of + ! PLM is progress that will avoid the need for such rounding. + if (abs(PLM_slope_wa) < 1.E-140) PLM_slope_wa = 0. + +end function PLM_slope_wa + +!> Returns a limited PLM slope following Colella and Woodward 1984, in the same +!! arbitrary units as the input values [A]. +real elemental pure function PLM_monotonized_slope(u_l, u_c, u_r, s_l, s_c, s_r) + real, intent(in) :: u_l !< Value of left cell in arbitrary units [A] + real, intent(in) :: u_c !< Value of center cell in arbitrary units [A] + real, intent(in) :: u_r !< Value of right cell in arbitrary units [A] + real, intent(in) :: s_l !< PLM slope of left cell [A] + real, intent(in) :: s_c !< PLM slope of center cell [A] + real, intent(in) :: s_r !< PLM slope of right cell [A] + ! Local variables + real :: e_r, e_l, edge ! Right, left and temporary edge values [A] + real :: almost_two ! The number 2, almost [nondim] + real :: slp ! Magnitude of PLM central slope [A] + + almost_two = 2. * ( 1. - epsilon(s_c) ) + + ! Edge values of neighbors abutting this cell + e_r = u_l + 0.5*s_l + e_l = u_r - 0.5*s_r + slp = abs(s_c) + + ! Check that left edge is between right edge of cell to the left and this cell mean + edge = u_c - 0.5 * s_c + if ( ( edge - e_r ) * ( u_c - edge ) < 0. ) then + edge = 0.5 * ( edge + e_r ) + slp = min( slp, abs( edge - u_c ) * almost_two ) + endif + + ! Check that right edge is between left edge of cell to the right and this cell mean + edge = u_c + 0.5 * s_c + if ( ( edge - u_c ) * ( e_l - edge ) < 0. ) then + edge = 0.5 * ( edge + e_l ) + slp = min( slp, abs( edge - u_c ) * almost_two ) + endif + + PLM_monotonized_slope = sign( slp, s_c ) + +end function PLM_monotonized_slope + +!> Average between xa and xb for cell k of a 1D PLM reconstruction [A] +!! Note: this uses the simple polynomial form a + b * x on x E (0,1) +!! which can overshoot at x=1 +real function average(this, k, xa, xb) + class(MPLM_WA_poly), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: xa !< Start of averaging interval on element (0 to 1) + real, intent(in) :: xb !< End of averaging interval on element (0 to 1) + + average = this%poly_coef(k,1) & + + this%poly_coef(k,2) * 0.5 * ( xb + xa ) + +end function average + +#ifndef USE_BASE_CLASS_REMAP +! This block is needed to enable the "bounded" to test whether the compiler can do better if we have local copies of +! the remapping functions. + +!> Remaps the column to subgrid h_sub +!! +!! It is assumed that h_sub is a perfect sub-grid of h0, meaning each h0 cell +!! can be constructed by joining a contiguous set of h_sub cells. The integer +!! indices isrc_start, isrc_end, isub_src provide this mapping, and are +!! calculated in MOM_remapping +subroutine remap_to_sub_grid(this, h0, u0, n1, h_sub, & + isrc_start, isrc_end, isrc_max, isub_src, & + u_sub, uh_sub, u02_err) + class(MPLM_WA_poly), intent(in) :: this !< 1-D reconstruction type + real, intent(in) :: h0(*) !< Source grid widths (size n0) [H] + real, intent(in) :: u0(*) !< Source grid widths (size n0) [H] + integer, intent(in) :: n1 !< Number of cells in target grid + real, intent(in) :: h_sub(*) !< Overlapping sub-cell thicknesses, h_sub [H] + integer, intent(in) :: isrc_start(*) !< Index of first sub-cell within each source cell + integer, intent(in) :: isrc_end(*) !< Index of last sub-cell within each source cell + integer, intent(in) :: isrc_max(*) !< Index of thickest sub-cell within each source cell + integer, intent(in) :: isub_src(*) !< Index of source cell for each sub-cell + real, intent(out) :: u_sub(*) !< Sub-cell cell averages (size n1) [A] + real, intent(out) :: uh_sub(*) !< Sub-cell cell integrals (size n1) [A H] + real, intent(out) :: u02_err !< Integrated reconstruction error estimates [A H] + ! Local variables + integer :: i_sub ! Index of sub-cell + integer :: i0 ! Index into h0(1:n0), source column + integer :: i_max ! Used to record which sub-cell is the largest contribution of a source cell + real :: dh_max ! Used to record which sub-cell is the largest contribution of a source cell [H] + real :: xa, xb ! Non-dimensional position within a source cell (0..1) [nondim] + real :: dh ! The width of the sub-cell [H] + real :: duh ! The total amount of accumulated stuff (u*h) [A H] + real :: dh0_eff ! Running sum of source cell thickness [H] + integer :: i0_last_thick_cell, n0 + real :: u0_min(this%n), u0_max(this%n) ! Min/max of u0 for each source cell [A] + real :: ul, ur ! left/right edge values of cell i0 + + n0 = this%n + + i0_last_thick_cell = 0 + do i0 = 1, n0 + ul = this%ul(i0) + ur = this%ur(i0) + u0_min(i0) = min(ul, ur) + u0_max(i0) = max(ul, ur) + if (h0(i0)>0.) i0_last_thick_cell = i0 + enddo + + ! Loop over each sub-cell to calculate average/integral values within each sub-cell. + ! Uses: h_sub, isub_src, h0_eff + ! Sets: u_sub, uh_sub + xa = 0. + dh0_eff = 0. + u02_err = 0. + do i_sub = 1, n0+n1 + + ! Sub-cell thickness from loop above + dh = h_sub(i_sub) + + ! Source cell + i0 = isub_src(i_sub) + + ! Evaluate average and integral for sub-cell i_sub. + ! Integral is over distance dh but expressed in terms of non-dimensional + ! positions with source cell from xa to xb (0 <= xa <= xb <= 1). + dh0_eff = dh0_eff + dh ! Cumulative thickness within the source cell + if (h0(i0)>0.) then + xb = dh0_eff / h0(i0) ! This expression yields xa <= xb <= 1.0 + xb = min(1., xb) ! This is only needed when the total target column is wider than the source column + u_sub(i_sub) = this%average( i0, xa, xb ) + else ! Vanished cell + xb = 1. + u_sub(i_sub) = u0(i0) + endif + uh_sub(i_sub) = dh * u_sub(i_sub) + u_sub(i_sub) = max( u_sub(i_sub), u0_min(i0) ) + u_sub(i_sub) = min( u_sub(i_sub), u0_max(i0) ) + + if (isub_src(i_sub+1) /= i0) then + ! If the next sub-cell is in a different source cell, reset the position counters + dh0_eff = 0. + xa = 0. + else + xa = xb ! Next integral will start at end of last + endif + + enddo + i_sub = n0+n1+1 + ! Sub-cell thickness from loop above + dh = h_sub(i_sub) + ! Source cell + i0 = isub_src(i_sub) + + ! Evaluate average and integral for sub-cell i_sub. + ! Integral is over distance dh but expressed in terms of non-dimensional + ! positions with source cell from xa to xb (0 <= xa <= xb <= 1). + dh0_eff = dh0_eff + dh ! Cumulative thickness within the source cell + if (h0(i0)>0.) then + xb = dh0_eff / h0(i0) ! This expression yields xa <= xb <= 1.0 + xb = min(1., xb) ! This is only needed when the total target column is wider than the source column + u_sub(i_sub) = this%average( i0, xa, xb ) + else ! Vanished cell + xb = 1. + u_sub(i_sub) = u0(i0) + endif + u_sub(i_sub) = max( u_sub(i_sub), u0_min(i0) ) + u_sub(i_sub) = min( u_sub(i_sub), u0_max(i0) ) + uh_sub(i_sub) = dh * u_sub(i_sub) + + ! Loop over each source cell substituting the integral/average for the thickest sub-cell (within + ! the source cell) with the residual of the source cell integral minus the other sub-cell integrals + ! aka a genius algorithm for accurate conservation when remapping from Robert Hallberg (\@Hallberg-NOAA). + ! Uses: i0_last_thick_cell, isrc_max, h_sub, isrc_start, isrc_end, uh_sub, u0, h0 + ! Updates: uh_sub + do i0 = 1, i0_last_thick_cell + i_max = isrc_max(i0) + dh_max = h_sub(i_max) + if (dh_max > 0.) then + ! duh will be the sum of sub-cell integrals within the source cell except for the thickest sub-cell. + duh = 0. + do i_sub = isrc_start(i0), isrc_end(i0) + if (i_sub /= i_max) duh = duh + uh_sub(i_sub) + enddo + uh_sub(i_max) = u0(i0)*h0(i0) - duh + u02_err = u02_err + max( abs(uh_sub(i_max)), abs(u0(i0)*h0(i0)), abs(duh) ) + endif + enddo + + ! This should not generally be used + if (this%check) then + if ( this%check_reconstruction(h0, u0) ) stop 912 ! A debugger is required to understand why this failed + endif + +end subroutine remap_to_sub_grid +#endif + +!> Checks the MPLM_WA_poly reconstruction for consistency +logical function check_reconstruction(this, h, u) + class(MPLM_WA_poly), intent(in) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k + + check_reconstruction = .false. + + do k = 1, this%n + if ( abs( this%u_mean(k) - u(k) ) > 0. ) check_reconstruction = .true. + enddo + + ! Check the cell reconstruction is monotonic within each cell (it should be as a straight line) + do k = 1, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ur(k) - this%u_mean(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check the cell is a straight line (to within machine precision) + do k = 1, this%n + if ( abs(2. * this%u_mean(k) - ( this%ul(k) + this%ur(k) )) > epsilon(this%u_mean(1)) * & + max(abs(2. * this%u_mean(k)), abs(this%ul(k)), abs(this%ur(k))) ) check_reconstruction = .true. + enddo + + ! Check bounding of right edges, w.r.t. the cell means + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%u_mean(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. the cell means + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%u_mean(k-1) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. this cell mean and the previous cell right edge + ! Check order of u, ur, ul + ! Note that in OM4 implementation, we were not consistent for top and bottom layers due + ! extrapolation using cell means rather than edge values + do K = 2, this%n-2 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%ul(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + +end function check_reconstruction + +!> Runs PLM reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(MPLM_WA_poly), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + call this%init(3) + call test%test( this%n /= 3, 'Setting number of levels') + allocate( um(3), ul(3), ur(3), ull(3), urr(3) ) + + call this%reconstruct( (/2.,2.,2./), (/1.,3.,5./) ) + call test%real_arr(3, this%u_mean, (/1.,3.,5./), 'Setting cell values') + + do k = 1, 3 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(3, ul, (/1.,2.,5./), 'Evaluation on left edge') + call test%real_arr(3, um, (/1.,3.,5./), 'Evaluation in center') + call test%real_arr(3, ur, (/1.,4.,5./), 'Evaluation on right edge') + + do k = 1, 3 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + call test%real_arr(3, ul, (/0.,2.,0./), 'dfdx on left edge') + call test%real_arr(3, um, (/0.,2.,0./), 'dfdx in center') + call test%real_arr(3, ur, (/0.,2.,0./), 'dfdx on right edge') + + do k = 1, 3 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + call test%real_arr(3, um, (/1.,3.25,5./), 'Return interval average') + + unit_tests = test%summarize('MPLM_WA_poly:unit_tests') + +end function unit_tests + +!> \namespace recon1d_mplm_wa_poly +!! + +end module Recon1d_MPLM_WA_poly diff --git a/src/ALE/Recon1d_PCM.F90 b/src/ALE/Recon1d_PCM.F90 new file mode 100644 index 0000000000..efb943c354 --- /dev/null +++ b/src/ALE/Recon1d_PCM.F90 @@ -0,0 +1,229 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> 1D reconstructions using the Piecewise Constant Method (PCM) +module Recon1d_PCM + +use Recon1d_type, only : Recon1d, testing + +implicit none ; private + +public PCM + +!> PCM (piecewise constant) reconstruction +!! +!! The source for the methods ultimately used by this class are: +!! init() *locally defined +!! reconstruct() *locally defined +!! average() *locally defined +!! f() *locally defined +!! dfdx() *locally defined +!! - x() *locally defined +!! check_reconstruction() *locally defined +!! unit_tests() *locally defined +!! destroy() *locally defined +!! remap_to_sub_grid() -> Recon1d%remap_to_sub_grid() +!! init_parent() -> init() +!! reconstruct_parent() -> parent() +type, extends (Recon1d) :: PCM + +contains + !> Implementation of the PCM initialization + procedure :: init => init + !> Implementation of the PCM reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of the PCM average over an interval [A] + procedure :: average => average + !> Implementation of evaluating the PCM reconstruction at a point [A] + procedure :: f => f + !> Implementation of the derivative of the PCM reconstruction at a point [A] + procedure :: dfdx => dfdx + !> Implementation of solver for x: f(x)=t + procedure :: x => x + !> Implementation of deallocation for PCM + procedure :: destroy => destroy + !> Implementation of check reconstruction for the PCM reconstruction + procedure :: check_reconstruction => check_reconstruction + !> Implementation of unit tests for the PCM reconstruction + procedure :: unit_tests => unit_tests + + !> Duplicate interface to init() + procedure :: init_parent => init + !> Duplicate interface to reconstruct() + procedure :: reconstruct_parent => reconstruct + +end type PCM + +contains + +!> Initialize a 1D PCM reconstruction for n cells +subroutine init(this, n, h_neglect, check) + class(PCM), intent(out) :: this !< This reconstruction + integer, intent(in) :: n !< Number of cells in this column + real, optional, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H]. + !! Not used by PCM. + logical, optional, intent(in) :: check !< If true, enable some consistency checking + + if (present(h_neglect)) this%n = n ! no-op to avoid compiler warning about unused dummy argument + if (present(check)) this%check = check + + this%n = n + + allocate( this%u_mean(n) ) + +end subroutine init + +!> Calculate a 1D PCM reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(PCM), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k + + this%u_mean(1) = h(1) ! no-op to avoid compiler warning about unused dummy argument + + do k = 1, this%n + this%u_mean(k) = u(k) + enddo + +end subroutine reconstruct + +!> Value of PCM reconstruction at a point in cell k [A] +real function f(this, k, x) + class(PCM), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + + f = this%u_mean(k) + +end function f + +!> Derivative of PCM reconstruction at a point in cell k [A] +real function dfdx(this, k, x) + class(PCM), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + + dfdx = 0. + +end function dfdx + +!> Solver for x: f(x)=t +real function x(this, k, t) + class(PCM), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: t !< Value to solve for [A] + real :: slp ! Difference across cell [A] + + slp = this%u_mean(min(k+1,this%n)) - this%u_mean(max(k-1,1)) + if ( abs(slp) > 0. ) slp = sign(1., slp) + x = 0.5 ! Fall back if t==u_mean + ! if t>u_mean & slp=1 then x=1 + ! if tu_mean & slp=-1 then x=0 + ! if t 0. ) x = 0.5 + slp * sign(0.5, t - this%u_mean(k)) +end function x + +!> Average between xa and xb for cell k of a 1D PCM reconstruction [A] +real function average(this, k, xa, xb) + class(PCM), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: xa !< Start of averaging interval on element (0 to 1) + real, intent(in) :: xb !< End of averaging interval on element (0 to 1) + + average = xb + xa ! no-op to avoid compiler warnings about unused dummy argument + average = this%u_mean(k) + +end function average + +!> Deallocate the PCM reconstruction +subroutine destroy(this) + class(PCM), intent(inout) :: this !< This reconstruction + + deallocate( this%u_mean ) + +end subroutine destroy + +!> Checks the PCM reconstruction for consistency +logical function check_reconstruction(this, h, u) + class(PCM), intent(in) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k + + check_reconstruction = .false. + + do k = 1, this%n + if ( abs( this%u_mean(k) - u(k) ) > 0. ) check_reconstruction = .true. + enddo + +end function check_reconstruction + +!> Runs PCM reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(PCM), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + call this%init(3) + call test%test( this%n /= 3, 'Setting number of levels') + allocate( um(3), ul(3), ur(3) ) + + call this%reconstruct( (/2.,2.,2./), (/1.,3.,5./) ) + call test%real_arr(3, this%u_mean, (/1.,3.,5./), 'Setting cell values') + + do k = 1, 3 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(3, ul, (/1.,3.,5./), 'Evaluation on left edge') + call test%real_arr(3, um, (/1.,3.,5./), 'Evaluation in center') + call test%real_arr(3, ur, (/1.,3.,5./), 'Evaluation on right edge') + + do k = 1, 3 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + call test%real_arr(3, ul, (/0.,0.,0./), 'dfdx on left edge') + call test%real_arr(3, um, (/0.,0.,0./), 'dfdx in center') + call test%real_arr(3, ur, (/0.,0.,0./), 'dfdx on right edge') + + call test%real_scalar( this%x(1,0.), 0., 'f-1(1,0)=0') + call test%real_scalar( this%x(1,1.), 0.5, 'f-1(1,1)=0.5') + call test%real_scalar( this%x(1,3.), 1., 'f-1(1,3)=1') + call test%real_scalar( this%x(2,1.), 0., 'f-1(2,1)=0') + call test%real_scalar( this%x(2,3.), 0.5, 'f-1(2,3)=0.5') + call test%real_scalar( this%x(2,5.), 1., 'f-1(2,5)=1') + call test%real_scalar( this%x(3,3.), 0., 'f-1(3,3)=0') + call test%real_scalar( this%x(3,5.), 0.5, 'f-1(3,5)=0.5') + call test%real_scalar( this%x(3,7.), 1., 'f-1(3,7)=1') + + do k = 1, 3 + um(k) = this%average(k, 0.5, 0.75) + enddo + call test%real_arr(3, um, (/1.,3.,5./), 'Return interval average') + + unit_tests = test%summarize('PCM:unit_tests') + +end function unit_tests + +!> \namespace recon1d_pcm +!! + +end module Recon1d_PCM diff --git a/src/ALE/Recon1d_PLM_CW.F90 b/src/ALE/Recon1d_PLM_CW.F90 new file mode 100644 index 0000000000..be42a399f0 --- /dev/null +++ b/src/ALE/Recon1d_PLM_CW.F90 @@ -0,0 +1,411 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Piecewise Linear Method 1D reconstruction +!! +!! This implementation of PLM follows Colella and Woodward, 1984 \cite colella1984, with cells +!! resorting to PCM for extrema including the first and last cells in column. +!! The cell-wise reconstructions are limited so that the edge values (which are also the extrema +!! in a cell) are bounded by the neighboring cell means. +!! This does not yield monotonic profiles for the general remapping problem. +module Recon1d_PLM_CW + +use Recon1d_type, only : Recon1d, testing + +implicit none ; private + +public PLM_CW, testing + +!> PLM reconstruction following Colella and Woodward, 1984 +!! +!! The source for the methods ultimately used by this class are: +!! - init() *locally defined +!! - reconstruct() *locally defined +!! - average() *locally defined +!! - f() *locally defined +!! - dfdx() *locally defined +!! - x() *locally defined +!! - check_reconstruction() *locally defined +!! - unit_tests() *locally defined +!! - destroy() *locally defined +!! - remap_to_sub_grid() -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> init() +!! - reconstruct_parent() -> reconstruct() +type, extends (Recon1d) :: PLM_CW + + real, allocatable :: ul(:) !< Left edge value [A] + real, allocatable :: ur(:) !< Right edge value [A] + +contains + !> Implementation of the PLM_CW initialization + procedure :: init => init + !> Implementation of the PLM_CW reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of the PLM_CW average over an interval [A] + procedure :: average => average + !> Implementation of evaluating the PLM_CW reconstruction at a point [A] + procedure :: f => f + !> Implementation of the derivative of the PLM_CW reconstruction at a point [A] + procedure :: dfdx => dfdx + !> Implementation of solver for x: f(x)=t + procedure :: x => x + !> Implementation of deallocation for PLM_CW + procedure :: destroy => destroy + !> Implementation of check reconstruction for the PLM_CW reconstruction + procedure :: check_reconstruction => check_reconstruction + !> Implementation of unit tests for the PLM_CW reconstruction + procedure :: unit_tests => unit_tests + + !> Duplicate interface to init() + procedure :: init_parent => init + !> Duplicate interface to reconstruct() + procedure :: reconstruct_parent => reconstruct + +end type PLM_CW + +contains + +!> Initialize a 1D PLM reconstruction for n cells +subroutine init(this, n, h_neglect, check) + class(PLM_CW), intent(out) :: this !< This reconstruction + integer, intent(in) :: n !< Number of cells in this column + real, optional, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H] + logical, optional, intent(in) :: check !< If true, enable some consistency checking + + this%n = n + + allocate( this%u_mean(n) ) + allocate( this%ul(n) ) + allocate( this%ur(n) ) + + this%h_neglect = tiny( this%u_mean(1) ) + if (present(h_neglect)) this%h_neglect = h_neglect + this%check = .false. + if (present(check)) this%check = check + +end subroutine init + +!> Calculate a 1D PLM reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(PLM_CW), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: slp ! The PLM slopes (difference across cell) [A] + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [A] + real :: u_min, u_max ! Minimum and maximum value across cell [A] + real :: u_l, u_r, u_c ! Left, right, and center values [A] + real :: h_l, h_c, h_r ! Thickness of left, center and right cells [H] + real :: h_c0 ! Thickness of center with h_neglect added [H] + integer :: k, n + + n = this%n + + ! Loop over all cells + do k = 1, n + this%u_mean(k) = u(k) + enddo + + ! Boundary cells use PCM + this%ul(1) = u(1) + this%ur(1) = u(1) + + ! Loop over interior cells + do k = 2, n-1 + u_l = u(k-1) + u_c = u(k) + u_r = u(k+1) + + ! Side differences + sigma_r = u_r - u_c + sigma_l = u_c - u_l + + h_l = h(k-1) + h_c = h(k) + h_r = h(k+1) + ! Avoids division by zero + h_c0 = h_c + this%h_neglect + + ! This is the second order slope given by equation 1.7 of + ! Piecewise Parabolic Method, Colella and Woodward (1984), + ! http://dx.doi.org/10.1016/0021-991(84)90143-8. + ! For uniform resolution it simplifies to ( u_r - u_l )/2 . + sigma_c = ( h_c / ( h_c0 + ( h_l + h_r ) ) ) * ( & + ( 2.*h_l + h_c ) / ( h_r + h_c0 ) * sigma_r & + + ( 2.*h_r + h_c ) / ( h_l + h_c0 ) * sigma_l ) + + ! Limit slope so that reconstructions are bounded by neighbors + u_min = min( u_l, u_c, u_r ) + u_max = max( u_l, u_c, u_r ) + + if ( (sigma_l * sigma_r) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the two cell averages spanning the edge + slp = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) + else + ! Extrema in the mean values require a PCM reconstruction + slp = 0.0 + endif + + ! Left edge + u_min = min( u_c, u_l ) + u_max = max( u_c, u_l ) + u_l = u_c - 0.5 * slp + this%ul(k) = max( min( u_l, u_max), u_min ) + + ! Right edge + u_min = min( u_c, u_r ) + u_max = max( u_c, u_r ) + u_r = u_c + 0.5 * slp + this%ur(k) = max( min( u_r, u_max), u_min ) + enddo + + ! Boundary cells use PCM + this%ul(n) = u(n) + this%ur(n) = u(n) + +end subroutine reconstruct + +!> Value of PLM_CW reconstruction at a point in cell k [A] +real function f(this, k, x) + class(PLM_CW), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + real :: xc ! Bounded version of x [nondim] + real :: du ! Difference across cell [A] + real :: u_a, u_b ! Two estimate of f [A] + + du = this%ur(k) - this%ul(k) + xc = max( 0., min( 1., x ) ) + + ! This expression for u_a can overshoot u_r but is good for x<<1 + u_a = this%ul(k) + du * xc + ! This expression for u_b can overshoot u_l but is good for 1-x<<1 + u_b = this%ur(k) + du * ( xc - 1. ) + + ! Since u_a and u_b are both bounded, this will perserve uniformity + f = 0.5 * ( u_a + u_b ) + +end function f + +!> Derivative of PLM_CW reconstruction at a point in cell k [A] +real function dfdx(this, k, x) + class(PLM_CW), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + + dfdx = this%ur(k) - this%ul(k) + +end function dfdx + +!> Solver for x such that f(x)=t +real function x(this, k, t) + class(PLM_CW), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: t !< Value to solve for [A] + real :: slp ! Difference across cell [A] + + slp = this%ur(k) - this%ul(k) + if ( abs(slp) > 0. ) then + x = ( t - this%ul(k) ) / slp + x = max( 0., min( x, 1. ) ) + else + slp = this%ul(min(k+1,this%n)) - this%ur(max(k-1,1)) + if ( abs(slp) > 0. ) slp = sign(1., slp) + x = 0.5 ! Fall back if t==u_mean + ! if t>u_mean & slp=1 then x=1 + ! if tu_mean & slp=-1 then x=0 + ! if t 0. ) x = 0.5 + slp * sign(0.5, t - this%u_mean(k)) + endif +end function x + +!> Average between xa and xb for cell k of a 1D PLM reconstruction [A] +real function average(this, k, xa, xb) + class(PLM_CW), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: xa !< Start of averaging interval on element (0 to 1) + real, intent(in) :: xb !< End of averaging interval on element (0 to 1) + real :: xmab ! Mid-point between xa and xb (0 to 1) + real :: u_a, u_b ! Values at xa and xb [A] + + ! This form is not guaranteed to be bounded by {ul,ur} +! u_a = this%ul(k) * ( 1. - xa ) + this%ur(k) * xa +! u_b = this%ul(k) * ( 1. - xb ) + this%ur(k) * xb +! average = 0.5 * ( u_a + u_b ) + + ! Mid-point between xa and xb + xmab = 0.5 * ( xa + xb ) + + ! The following expression is exact at xmab=0 and xmab=1, + ! i.e. gives the numerically correct values. + ! It is not obvious that the expression is monotonic but according to + ! https://math.stackexchange.com/questions/907329/accurate-floating-point-linear-interpolation + ! it will be for the default rounding behavior. Otherwise is it + ! then possible this expression can be outside the range of ul and ur? +! average = this%ul(k) * ( 1. - xmab ) + this%ur(k) * xmab + ! Emperically it fails the uniform value test + + ! The following is more complicated but seems to ensure being within bounds. + ! This expression for u_a can overshoot u_r but is good for xmab<<1 + u_a = this%ul(k) + ( this%ur(k) - this%ul(k) ) * xmab + ! This expression for u_b can overshoot u_l but is good for 1-xmab<<1 + u_b = this%ur(k) + ( this%ul(k) - this%ur(k) ) * ( 1. - xmab ) + ! Replace xmab with -1 for xmab<0.5, 1 for xmab>=0.5 +! xmab = sign(1., xmab-0.5) + ! Select either u_a or u_b, depending whether mid-point of xa, xb is smaller/larger than 0.5 +! average = xmab * u_b + ( 1. - xmab ) * u_a + + ! Since u_a and u_b are both bounded, this will perserve uniformity but will the + ! sum be bounded? Emperically it seems to work... + average = 0.5 * ( u_a + u_b ) + +end function average + +!> Deallocate the PLM reconstruction +subroutine destroy(this) + class(PLM_CW), intent(inout) :: this !< This reconstruction + + deallocate( this%u_mean, this%ul, this%ur ) + +end subroutine destroy + +!> Checks the PLM_CW reconstruction for consistency +logical function check_reconstruction(this, h, u) + class(PLM_CW), intent(in) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k + + check_reconstruction = .false. + + do k = 1, this%n + if ( abs( this%u_mean(k) - u(k) ) > 0. ) check_reconstruction = .true. + enddo + + ! Check the cell reconstruction is monotonic within each cell (it should be as a straight line) + do k = 1, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ur(k) - this%u_mean(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check the cell is a straight line (to within machine precision) + do k = 1, this%n + if ( abs(2. * this%u_mean(k) - ( this%ul(k) + this%ur(k) )) > epsilon(this%u_mean(1)) * & + max(abs(2. * this%u_mean(k)), abs(this%ul(k)), abs(this%ur(k))) ) check_reconstruction = .true. + enddo + + ! Check bounding of right edges, w.r.t. the cell means + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%u_mean(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. the cell means + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%u_mean(k-1) ) < 0. ) check_reconstruction = .true. + enddo + + ! PLM is not globally monotonic (expected) + +! ! Check bounding of right edges, w.r.t. this cell mean and the next cell left edge +! do K = 1, this%n-1 +! if ( ( this%ur(k) - this%u_mean(k) ) * ( this%ul(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. +! enddo + +! ! Check bounding of left edges, w.r.t. this cell mean and the previous cell right edge +! do K = 2, this%n +! if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%ur(k-1) ) < 0. ) check_reconstruction = .true. +! enddo + +end function check_reconstruction + +!> Runs PLM reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(PLM_CW), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + call this%init(3) + call test%test( this%n /= 3, 'Setting number of levels') + allocate( um(3), ul(3), ur(3), ull(3), urr(3) ) + + call this%reconstruct( (/2.,2.,2./), (/1.,3.,5./) ) + call test%real_arr(3, this%u_mean, (/1.,3.,5./), 'Setting cell values') + + do k = 1, 3 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(3, ul, (/1.,2.,5./), 'Evaluation on left edge') + call test%real_arr(3, um, (/1.,3.,5./), 'Evaluation in center') + call test%real_arr(3, ur, (/1.,4.,5./), 'Evaluation on right edge') + + do k = 1, 3 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + call test%real_arr(3, ul, (/0.,2.,0./), 'dfdx on left edge') + call test%real_arr(3, um, (/0.,2.,0./), 'dfdx in center') + call test%real_arr(3, ur, (/0.,2.,0./), 'dfdx on right edge') + + call test%real_scalar( this%x(1,0.), 0., 'f-1(1,0)=0') + call test%real_scalar( this%x(1,1.), 0.5, 'f-1(1,1)=0.5') + call test%real_scalar( this%x(1,3.), 1., 'f-1(1,3)=1') + call test%real_scalar( this%x(2,1.), 0., 'f-1(2,1)=0') + call test%real_scalar( this%x(2,3.), 0.5, 'f-1(2,3)=0.5') + call test%real_scalar( this%x(2,5.), 1., 'f-1(2,5)=1') + call test%real_scalar( this%x(3,3.), 0., 'f-1(3,3)=0') + call test%real_scalar( this%x(3,5.), 0.5, 'f-1(3,5)=0.5') + call test%real_scalar( this%x(3,7.), 1., 'f-1(3,7)=1') + + do k = 1, 3 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + call test%real_arr(3, um, (/1.,3.25,5./), 'Return interval average') + + call this%destroy() + deallocate( um, ul, ur, ull, urr ) + + allocate( um(4), ul(4), ur(4) ) + call this%init(4) + + ! These values lead to non-monotonic reconstuctions which are + ! valid for transport problems but not always appropriate for + ! remapping to arbitrary resolution grids. + ! The O(h^2) slopes are -, 2, 2, - and the limited + ! slopes are 0, 1, 1, 0 so the everywhere the reconstructions + ! are bounded by neighbors but ur(2) and ul(3) are out-of-order. + call this%reconstruct( (/1.,1.,1.,1./), (/0.,3.,4.,7./) ) + do k = 1, 4 + ul(k) = this%f(k, 0.) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(4, ul, (/0.,2.,3.,7./), 'Evaluation on left edge') + call test%real_arr(4, ur, (/0.,4.,5.,7./), 'Evaluation on right edge') + + deallocate( um, ul, ur ) + + unit_tests = test%summarize('PLM_CW:unit_tests') + +end function unit_tests + +!> \namespace recon1d_plm_cw +!! + +end module Recon1d_PLM_CW diff --git a/src/ALE/Recon1d_PLM_CWK.F90 b/src/ALE/Recon1d_PLM_CWK.F90 new file mode 100644 index 0000000000..1e20f87318 --- /dev/null +++ b/src/ALE/Recon1d_PLM_CWK.F90 @@ -0,0 +1,124 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Piecewise Linear Method 1D reconstruction +!! +!! This implementation of PLM follows Colella and Woodward, 1984, except for assuming +!! uniform cell thicknesses. Cells resort to PCM for extrema including first and last cells in column. +!! The cell-wise reconstructions are limited so that the edge values (which are also the +!! extrema in a cell) are bounded by the neighbor cell means. However, this does not yield +!! monotonic profiles for the whole column. +!! +!! Note that internally the edge values, rather than the PLM slope, are stored to ensure +!! resulting calculations are properly bounded. +module Recon1d_PLM_CWK + +use Recon1d_type, only : testing +use Recon1d_PLM_CW, only : PLM_CW + +implicit none ; private + +public PLM_CWK, testing + +!> PLM reconstruction following Colella and Woodward, 1984 +!! +!! Implemented by extending recon1d_plm_cw. +!! +!! The source for the methods ultimately used by this class are: +!! - init() -> recon1d_plm_cw.init() +!! - reconstruct() *locally defined +!! - average() -> recon1d_plm_cw.average() +!! - f() -> recon1d_plm_cw.f() +!! - dfdx() -> recon1d_plm_cw.dfdx() +!! - x() -> recon1d_plm_cw.x() +!! - check_reconstruction() -> recon1d_plm_cw.check_reconstruction() +!! - unit_tests() -> recon1d_plm_cw.unit_tests() +!! - destroy() -> recon1d_plm_cw.destroy() +!! - remap_to_sub_grid() -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> init() +!! - reconstruct_parent() -> reconstruct() +type, extends (PLM_CW) :: PLM_CWK + +contains + !> Implementation of the PLM_CWK reconstruction + procedure :: reconstruct => reconstruct + +end type PLM_CWK + +contains + +!> Calculate a 1D PLM reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(PLM_CWK), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: slp ! The PLM slopes (difference across cell) [A] + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [A] + real :: u_min, u_max ! Minimum and maximum value across cell [A] + real :: u_l, u_r, u_c ! Left, right, and center values [A] + integer :: k, n + + n = this%n + + ! Loop over all cells + do k = 1, n + this%u_mean(k) = u(k) + enddo + + ! Boundary cells use PCM + this%ul(1) = u(1) + this%ur(1) = u(1) + + ! Loop over interior cells + do k = 2, n-1 + u_l = u(k-1) + u_c = u(k) + u_r = u(k+1) + + ! Side differences + sigma_r = u_r - u_c + sigma_l = u_c - u_l + + ! This is the second order slope given by equation 1.7 of + ! Piecewise Parabolic Method, Colella and Woodward (1984), + ! but for uniform resolution. + sigma_c = 0.5 * ( u_r - u_l ) + + ! Limit slope so that reconstructions are bounded by neighbors + u_min = min( u_l, u_c, u_r ) + u_max = max( u_l, u_c, u_r ) + + if ( (sigma_l * sigma_r) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the two cell averages spanning the edge + slp = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) + else + ! Extrema in the mean values require a PCM reconstruction + slp = 0.0 + endif + + ! Left edge + u_min = min( u_c, u_l ) + u_max = max( u_c, u_l ) + u_l = u_c - 0.5 * slp + this%ul(k) = max( min( u_l, u_max), u_min ) + + ! Right edge + u_min = min( u_c, u_r ) + u_max = max( u_c, u_r ) + u_r = u_c + 0.5 * slp + this%ur(k) = max( min( u_r, u_max), u_min ) + enddo + + ! Boundary cells use PCM + this%ul(n) = u(n) + this%ur(n) = u(n) + +end subroutine reconstruct + +!> \namespace recon1d_plm_cwk +!! + +end module Recon1d_PLM_CWK diff --git a/src/ALE/Recon1d_PLM_WLS.F90 b/src/ALE/Recon1d_PLM_WLS.F90 new file mode 100644 index 0000000000..f32ff59b73 --- /dev/null +++ b/src/ALE/Recon1d_PLM_WLS.F90 @@ -0,0 +1,473 @@ +!> Piecewise Linear Method using Weighted Conservative Least Squares 1D reconstruction +module Recon1d_PLM_WLS + +! This file is part of MOM6. See LICENSE.md for the license. + +use Recon1d_type, only : Recon1d, testing + +implicit none ; private + +public PLM_WLS, testing + +!> PLM reconstruction using Weighted Least Squares constrained to conserve for central cell +!! +!! The source for the methods ultimately used by this class are: +!! - init() *locally defined +!! - reconstruct() *locally defined +!! - average() *locally defined +!! - f() *locally defined +!! - dfdx() *locally defined +!! - x() -> recon1d_type.x() +!! - check_reconstruction() *locally defined +!! - unit_tests() *locally defined +!! - destroy() *locally defined +!! - remap_to_sub_grid() -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> init() +!! - reconstruct_parent() -> reconstruct() +type, extends (Recon1d) :: PLM_WLS + + real, allocatable :: ul(:) !< Left edge value [A] + real, allocatable :: ur(:) !< Right edge value [A] + real, allocatable, private :: slp(:) !< Difference across cell, ur - ul [A]. + !! This is redundant with ul and ur and not used + !! in any evaluations, but is needed for testing. + +contains + !> Implementation of the PLM_WLS initialization + procedure :: init => init + !> Implementation of the PLM_WLS reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of the PLM_WLS average over an interval [A] + procedure :: average => average + !> Implementation of evaluating the PLM_WLS reconstruction at a point [A] + procedure :: f => f + !> Implementation of the derivative of the PLM_WLS reconstruction at a point [A] + procedure :: dfdx => dfdx + !> Implementation of deallocation for PLM_WLS + procedure :: destroy => destroy + !> Implementation of check reconstruction for the PLM_WLS reconstruction + procedure :: check_reconstruction => check_reconstruction + !> Implementation of unit tests for the PLM_WLS reconstruction + procedure :: unit_tests => unit_tests + + !> Duplicate interface to init() + procedure :: init_parent => init + !> Duplicate interface to reconstruct() + procedure :: reconstruct_parent => reconstruct + +end type PLM_WLS + +contains + +!> Initialize a 1D PLM reconstruction for n cells +subroutine init(this, n, h_neglect, check) + class(PLM_WLS), intent(out) :: this !< This reconstruction + integer, intent(in) :: n !< Number of cells in this column + real, optional, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H] + logical, optional, intent(in) :: check !< If true, enable some consistency checking + + this%n = n + + allocate( this%u_mean(n) ) + allocate( this%ul(n) ) + allocate( this%ur(n) ) + allocate( this%slp(n) ) + + this%h_neglect = tiny( this%u_mean(1) ) + if (present(h_neglect)) this%h_neglect = h_neglect + this%check = .false. + if (present(check)) this%check = check + +end subroutine init + +!> Calculate a 1D PLM_WLS reconstruction based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(PLM_WLS), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: slp ! The PLM slopes (difference across cell) [A] + real :: u_l, u_r, u_c ! Left, right, and center values [A] + real :: h_l, h_c, h_r ! Thickness of left, center and right cells [H] + real :: h_l0, h_r0 ! Thickness of left and right cells with h_neglect added [H] + real :: hx2l, hx2r ! Contributions to denominator, [H3] + real :: hxyl, hxyr ! Contributions to numerator, [H2 A] + integer :: n, km1, k, kp1 + + n = this%n + + ! Loop over all cells + do k = 1, n + km1 = max(1, k-1) + kp1 = min(n, k+1) + u_l = u(km1) + u_c = u(k) + u_r = u(kp1) + + h_l = h(km1) * real( k - km1 ) ! This zeroes h_l at k==1 + h_c = h(k) + h_r = h(kp1) * real( kp1 - k ) ! This zeroes h_r at k==n + + ! This is the slope that minimizes the error + ! sum_l={-1,1} h(k+l) * [ u(k+l) - u(k) + slp * ( z(k+l) - z(k) ) ] + ! i.e. volume weighted least squares + h_l0 = h_l + this%h_neglect + h_r0 = h_r + this%h_neglect + hxyl = ( h_l * ( h_c + h_l ) ) * ( u_c - u_l ) + hxyr = ( h_r * ( h_c + h_r ) ) * ( u_r - u_c ) + hx2l = h_l0 * ( h_c + h_l0 )**2 + hx2r = h_r0 * ( h_c + h_r0 )**2 + slp = 2. * h_c * ( hxyr + hxyl ) / ( hx2l + hx2r ) + + ! Mean value + this%u_mean(k) = u_c + + ! Left edge + this%ul(k) = u_c - 0.5 * slp + + ! Right edge + this%ur(k) = u_c + 0.5 * slp + + ! Store slope + this%slp(k) = slp + enddo + +end subroutine reconstruct + +!> Value of PLM_WLS reconstruction at a point in cell k [A] +real function f(this, k, x) + class(PLM_WLS), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + real :: du ! Difference across cell [A] + + du = this%ur(k) - this%ul(k) + + ! This expression might be used beyond the element to evaluate + ! LS errors. In other PLM implementations x is bounded to the + ! element and the expressions are constructed to not exceed + ! bounds. There are no such constraints for PLM_WLS. + f = this%u_mean(k) + du * ( x - 0.5) + !f = this%u_mean(k) + this%slp(k) * ( x - 0.5) + +end function f + +!> Derivative of PLM_WLS reconstruction at a point in cell k [A] +real function dfdx(this, k, x) + class(PLM_WLS), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + + dfdx = this%ur(k) - this%ul(k) + +end function dfdx + +!> Average between xa and xb for cell k of a 1D PLM reconstruction [A] +real function average(this, k, xa, xb) + class(PLM_WLS), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: xa !< Start of averaging interval on element (0 to 1) + real, intent(in) :: xb !< End of averaging interval on element (0 to 1) + real :: xmab ! Mid-point between xa and xb (0 to 1) + real :: u_a, u_b ! Values at xa and xb [A] + + ! Mid-point between xa and xb + xmab = 0.5 * ( xa + xb ) + + ! This expression for u_a can overshoot u_r but is good for xmab<<1 + u_a = this%ul(k) + ( this%ur(k) - this%ul(k) ) * xmab + ! This expression for u_b can overshoot u_l but is good for 1-xmab<<1 + u_b = this%ur(k) + ( this%ul(k) - this%ur(k) ) * ( 1. - xmab ) + + ! Since u_a and u_b are both bounded, this will perserve uniformity but will the + ! sum be bounded? Emperically it seems to work... + average = 0.5 * ( u_a + u_b ) + +end function average + +!> Deallocate the PLM reconstruction +subroutine destroy(this) + class(PLM_WLS), intent(inout) :: this !< This reconstruction + + deallocate( this%u_mean, this%ul, this%ur ) + +end subroutine destroy + +!> Checks the PLM_WLS reconstruction for consistency +logical function check_reconstruction(this, h, u) + class(PLM_WLS), intent(in) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k + real :: slp ! Cell slope [A] + type(PLM_WLS) :: perturbed !< A perturbed reconstruction + real :: u_l, u_r, u_c ! Left, right, and center values [A] + real :: h_l, h_c, h_r ! Thickness of left, center and right cells [H] + real :: h_l0, h_r0, h_c0 ! Thickness of left, right, center cells with h_neglect added [H] + real :: x_l, x_r ! Positions of left and right cells [H] + real :: hx2l, hx2r ! Contributions to denominator, [H3] + real :: hxyl, hxyr ! Contributions to numerator, [H2 A] + real :: hy2l, hy2r ! Contributions to error, [H3] + real :: y_l, y_r ! Left, right, value differencess [A] + real :: b_h, bp_h ! slp / h_c [A H-1] + integer :: km1, kp1 + + check_reconstruction = .false. + + do k = 1, this%n + if ( abs( this%u_mean(k) - u(k) ) > 0. ) check_reconstruction = .true. + enddo + + ! Check the cell reconstruction is monotonic within each cell (it should be as a straight line) + do k = 1, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ur(k) - this%u_mean(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check the cell is a straight line (to within machine precision) + do k = 1, this%n + if ( abs(2. * this%u_mean(k) - ( this%ul(k) + this%ur(k) )) > epsilon(this%u_mean(1)) * & + max(abs(2. * this%u_mean(k)), abs(this%ul(k)), abs(this%ur(k))) ) check_reconstruction = .true. + enddo + + ! Create a perturbable reconstruction + perturbed = this ! Complete copy of this + ! Check the copy is identical + do k = 1, this%n + if ( abs( perturbed%u_mean(k) - this%u_mean(k) ) > 0. ) check_reconstruction = .true. + if ( abs( perturbed%ul(k) - this%ul(k) ) > 0. ) check_reconstruction = .true. + if ( abs( perturbed%ur(k) - this%ur(k) ) > 0. ) check_reconstruction = .true. + if ( abs( perturbed%slp(k) - this%slp(k) ) > 0. ) check_reconstruction = .true. + enddo + ! The !DIR$ NOINLINE directive would be needed here to avoid ifort -O2 changing answers + ! Now perturb the slope. The local error should not decrease. + do k = 1, this%n + slp = this%slp(k) * ( 1.0 + 1. * epsilon(slp) ) + perturbed%slp(k) = slp + perturbed%ul(k) = u(k) - 0.5 * slp + perturbed%ur(k) = u(k) + 0.5 * slp + if ( LS_error(perturbed, k, h, u) < LS_error(this, k, h, u) ) check_reconstruction = .true. + + slp = this%slp(k) * ( 1.0 - 1. * epsilon(slp) ) + perturbed%slp(k) = slp + perturbed%ul(k) = u(k) - 0.5 * slp + perturbed%ur(k) = u(k) + 0.5 * slp + if ( LS_error(perturbed, k, h, u) < LS_error(this, k, h, u) ) check_reconstruction = .true. + enddo + +end function check_reconstruction + +!> Returns local least squares error for a particular cell +!! +!! Note that this is the error relative to the minimum of the loss function so that at the +!! true solution this function returns zero. See module documentation. +real function LS_error(this, k, h, u) + type(PLM_WLS), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: u_l, u_r, u_c ! Left, right, and center values [A] + real :: h_l, h_c, h_r ! Thickness of left, center and right cells [H] + real :: h_l0, h_r0, hc0 ! Thickness of left, right, center cells with h_neglect added [H] + real :: hx2l, hx2r ! Contributions to denominator, [H3] + real :: hxyl, hxyr ! Contributions to numerator, [H2 A] + real :: slp ! The PLM slopes (difference across cell) [A] + integer :: km1, kp1 + + km1 = max(1, k-1) + kp1 = min(this%n, k+1) + u_l = u(km1) + u_c = u(k) + u_r = u(kp1) + + h_l = h(km1) * real( k - km1 ) ! This zeroes h_l at k==1 + h_r = h(kp1) * real( kp1 - k ) ! This zeroes h_r at k==n + h_c = h(k) + hc0 = h_c + this%h_neglect + + h_l0 = h_l + this%h_neglect + h_r0 = h_r + this%h_neglect + hxyl = ( h_l * ( h_c + h_l ) ) * ( u_c - u_l ) + hxyr = ( h_r * ( h_c + h_r ) ) * ( u_r - u_c ) + hx2l = h_l0 * ( h_c + h_l0 )**2 + hx2r = h_r0 * ( h_c + h_r0 )**2 + slp = 2. * h_c * ( hxyr + hxyl ) / ( hx2l + hx2r ) + LS_error = h_c * ( ( hx2l + hx2r ) * ( this%slp(k) - slp ) )**2 + LS_error = LS_error / ( hc0 * ( hx2l + hx2r ) ) +end function LS_error + +!> Runs PLM_WLS reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(PLM_WLS), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + call this%init(3, h_neglect=1.e-20) + call test%test( this%n /= 3, "Setting number of levels") + allocate( um(3), ul(3), ur(3), ull(3), urr(3) ) + + call this%reconstruct( (/1.,1.,1./), (/-1.,0.,2./) ) + call test%real_arr(3, this%slp, (/1.,1.5,2./), "(1,1,1)(-1,0,2) slope") + + do k = 1, 3 + um(k) = LS_error(this, k, (/1.,1.,1./), (/-1.,0.,2./) ) + enddo + call test%real_arr(3, um, (/0.,0.,0./), "(1,1,1)(-1,0,2) LS' rel error") + + call this%reconstruct( (/0.,1.,1./), (/-1.,0.,2./) ) + call test%real_arr(3, this%slp, (/0.,2.,2./), "(0,1,1)(-1,0,2) slope") + + do k = 1, 3 + um(k) = LS_error(this, k, (/0.,1.,1./), (/-1.,0.,2./) ) + enddo + call test%real_arr(3, um, (/0.,0.,0./), "(0,1,1)(-1,0,2) LS' rel error") + + call this%reconstruct( (/1.,1.,1./), (/-2.,0.,1./) ) + call test%real_arr(3, this%slp, (/2.,1.5,1./), "(1,1,1)(-2,0,1) slope") + + call this%reconstruct( (/1.,1.,0./), (/-2.,0.,1./) ) + call test%real_arr(3, this%slp, (/2.,2.,0./), "(1,1,0)(-2,0,1) slope") + + call this%destroy() + call this%init(3) ! Reset to defaults + + ! Straight line data on uniform grid + call this%reconstruct( (/2.,2.,2./), (/1.,3.,5./) ) + call test%real_arr(3, this%u_mean, (/1.,3.,5./), "Straight line data") + + do k = 1, 3 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(3, ul, (/0.,2.,4./), "Evaluation on left edge") + call test%real_arr(3, um, (/1.,3.,5./), "Evaluation in center") + call test%real_arr(3, ur, (/2.,4.,6./), "Evaluation on right edge") + + do k = 1, 3 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + call test%real_arr(3, ul, (/2.,2.,2./), "dfdx on left edge") + call test%real_arr(3, um, (/2.,2.,2./), "dfdx in center") + call test%real_arr(3, ur, (/2.,2.,2./), "dfdx on right edge") + + do k = 1, 3 + um(k) = LS_error(this, k, (/2.,2.,2./), (/1.,3.,5./) ) + enddo + call test%real_arr(3, um, (/0.,0.,0./), "Rel error is 0") + + do k = 1, 3 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.5 to 0.75 in each cell + enddo + call test%real_arr(3, um, (/1.25,3.25,5.25/), "Return interval average") + + call test%real_scalar( this%x(1,0.), 0., 'f-1(1,0)=0') + call test%real_scalar( this%x(1,1.), 0.5, 'f-1(1,1)=0.5') + call test%real_scalar( this%x(1,3.), 1., 'f-1(1,3)=1') + call test%real_scalar( this%x(2,1.), 0., 'f-1(2,1)=0') + call test%real_scalar( this%x(2,3.), 0.5, 'f-1(2,3)=0.5') + call test%real_scalar( this%x(2,5.), 1., 'f-1(2,5)=1') + call test%real_scalar( this%x(3,3.), 0., 'f-1(3,3)=0') + call test%real_scalar( this%x(3,5.), 0.5, 'f-1(3,5)=0.5') + call test%real_scalar( this%x(3,7.), 1., 'f-1(3,7)=1') + + call this%destroy() + deallocate( um, ul, ur, ull, urr ) + + allocate( um(4), ul(4), ur(4) ) + call this%init(4) + + deallocate( um, ul, ur ) + + unit_tests = test%summarize("PLM_WLS:unit_tests") + +end function unit_tests + +!> \namespace recon1d_plm_wls +!! +!! This implementation of PLM fits the slope using least squares, but retains conservation +!! for the central cell by passing through the central value. +!! Cell-wise reconstructions are NOT limited by neighbours. +!! Thus, this reconstruction does not yield monotonic profiles needed for the general remapping problem. +!! +!! The algorithm solves the least squares problem of fitting a straight line through +!! the neighboring data. The line is constained to pass through the center cell, +!! \f$ (x_{k}, y_{k}) \f$, so that the construction is conservative. The more general +!! function \f$ f(x) = a_{k} + b_{k} x \f$ would not conserve for arbitrary data. +!! +!! The unknown parameter \f$ b_{k} \f$ in the line +!! \f[ +!! f(x) = y_{k} + b_{k} ( x - x_{k} ) / h_{k} +!! \f] +!! is fit to neighbors \f$ x_{k-1}, y_{k-1} \f$ and \f$ x_{k+1}, y_{k+1} \f$. +!! +!! Denoting \f$ y'_{k+j} = y_{k+j} - y_{k} \f$ and \f$ x'_{k+j} = x_{k+j} - x_{k} \f$ +!! the local error is +!! \f{align}{ +!! e_{k+j} &= b_k \frac{ x_{k+j} - x_{k} }{ h_{k} } + y_{k} - y_{k+j} \\\\ +!! &= b_k \frac{ x'_{k+j} }{ h_{k} } - y'_{k+j} +!! \;\; . \f} +!! +!! We use volume weighting in the loss +!! \f[ +!! G(b) = h_{k-1} e_{k-1}^2 + h_{k+1} e_{k+1}^2 +!! \;\; . \f] +!! +!! When solving for \f$ b_k \f$, we solve \f$ dG/db = 0 \f$ where +!! \f{align}{ +!! dG/db &= 2 h_{k-1} e_{k-1} \frac{ de_{k-1} }{db} + 2 h_{k+1} e_{k+1} \frac{ de_{k+1} }{db} \\\\ +!! &= 2 h_{k-1} ( b_k \frac{ x'_{k-1} }{ h_{k} } - \frac{ y'_{k-1} ) x'_{k-1} }{ h_{k} } + +!! 2 h_{k+1} ( b_k \frac{ x'_{k+1} }{ h_{k} } - \frac{ y'_{k+1} ) x'_{k+1} }{ h_{k} } \\\\ +!! &= 4 b_k \frac{ < h x'^2 > }{ h_{k}^2 } - 4 \frac{ < h x' y' > }{ h_{k} } +!! \f} +!! and where \f$ < a > = \frac{1}{2} ( a_{k-1} + a_{k+1} ) \f$. +!! Thus +!! \f[ +!! b_k = \frac{ h_{k} < h x' y' > }{ < h x'^2 > } \;\; . +!! \f] +!! +!! When evaluating the loss, \f$ G \f$, some rearrangement is necessary to reduce truncation +!! errors. Since +!! \f{align}{ +!! e_{k+j}^2 &= \left( b \frac{ x'_{k+j} }{ h_{k} } - y'_{k+j} \right)^2 \\\\ +!! &= b^2 \frac{ {x'}_{k+j}^2 }{ h_{k}^2 } - 2 b \frac{ x'_{k+j} y'_{k+j} }{ h_{k} } + {y'}_{k+j}^2 +!! \f} +!! then +!! \f{align}{ +!! G(b) &= 2 < h e^2 > \\\\ +!! &= 2 b^2 \frac{ < h {x'}^2 > }{ h_{k}^2 } - 4 b \frac{ < h x' y' > }{ h_{k} } + 2 < h {y'}^2 > +!! \;\; . +!! \f} +!! +!! If we denote the value of b that yields the minimum value as \f$ b^* \f$ then +!! \f[ +!! G(b^*) = 2 < h {y'}^2 > - \frac{ 2 < h x' y' >^2 }{ < h {x'}^2 > } +!! \;\; . +!! \f] +!! +!! Let +!! \f{align}{ +!! G''(b) &= G(b) - G(b^*) \\\\ +!! &= 2 b^2 \frac{ < h {x'}^2 > }{ h_{k}^2 } - 4 b \frac{ < h x' y' > }{ h_{k} } +!! + 2 \frac{ < h x' y' >^2 }{ < h {x'}^2 > } \\\\ +!! &= 2 \frac{ \left( b < h {x'}^2 > - h_{k} < h x' y' > \right)^2 }{ h_{k} < h {x'}^2 > } +!! \;\; . +!! \f} +!! Minimizing \f$ G''(b) \f$ is equivalent to minimizing \f$ G(b) \f$ for the same data. +!! \f$ G''(b^*)=0 \f$ so evaluation with the last form, in the vicinity of \f$ b^* \f$, avoids +!! large cancelling terms. + +end module Recon1d_PLM_WLS diff --git a/src/ALE/Recon1d_PLM_hybgen.F90 b/src/ALE/Recon1d_PLM_hybgen.F90 new file mode 100644 index 0000000000..0d5fa26e26 --- /dev/null +++ b/src/ALE/Recon1d_PLM_hybgen.F90 @@ -0,0 +1,408 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Piecewise Linear Method 1D reconstruction ported from "hybgen" module in Hycom. +!! +!! This implementation of PLM follows Colella and Woodward, 1984, with cells resorting to PCM for +!! extrema including first and last cells in column. The cell-wise reconstructions are limited so +!! that the edge values (which are also the extrema in a cell) are bounded by the neighbors. The +!! limiter yields monotonicity for the CFL<1 transport problem where parts of a cell can only move +!! to a neighboring cell, but does not yield monotonic profiles for the general remapping problem. +!! The first and last cells are always limited to PCM. +!! +!! The mom_hybgen_remap.hybgen_plm_coefs() function calculates PLM coefficients numerically +!! equiavalent to the recon1d_plm_hybgen module (this implementation). +module Recon1d_PLM_hybgen + +use Recon1d_type, only : Recon1d, testing + +implicit none ; private + +public PLM_hybgen, testing + +!> PLM reconstruction following "hybgen". +!! +!! This implementation is a refactor of hybgen_plm_coefs() from mom_hybgen_remap. +!! +!! The source for the methods ultimately used by this class are: +!! - init() *locally defined +!! - reconstruct() *locally defined +!! - average() *locally defined +!! - f() *locally defined +!! - dfdx() *locally defined +!! - x() -> recon1d_plm_cw.x() +!! - check_reconstruction() *locally defined +!! - unit_tests() *locally defined +!! - destroy() *locally defined +!! - remap_to_sub_grid() -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> init() +!! - reconstruct_parent() -> reconstruct() +type, extends (Recon1d) :: PLM_hybgen + + real, allocatable :: ul(:) !< Left edge value [A] + real, allocatable :: ur(:) !< Right edge value [A] + real, allocatable :: slp(:) !< Right minus left edge values [A] + +contains + !> Implementation of the PLM_hybgen initialization + procedure :: init => init + !> Implementation of the PLM_hybgen reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of the PLM_hybgen average over an interval [A] + procedure :: average => average + !> Implementation of evaluating the PLM_hybgen reconstruction at a point [A] + procedure :: f => f + !> Implementation of the derivative of the PLM_hybgen reconstruction at a point [A] + procedure :: dfdx => dfdx + !> Implementation of deallocation for PLM_hybgen + procedure :: destroy => destroy + !> Implementation of check reconstruction for the PLM_hybgen reconstruction + procedure :: check_reconstruction => check_reconstruction + !> Implementation of unit tests for the PLM_hybgen reconstruction + procedure :: unit_tests => unit_tests + + !> Duplicate interface to init() + procedure :: init_parent => init + !> Duplicate interface to reconstruct() + procedure :: reconstruct_parent => reconstruct + +end type PLM_hybgen + +contains + +!> Initialize a 1D PLM reconstruction for n cells +subroutine init(this, n, h_neglect, check) + class(PLM_hybgen), intent(out) :: this !< This reconstruction + integer, intent(in) :: n !< Number of cells in this column + real, optional, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H] + logical, optional, intent(in) :: check !< If true, enable some consistency checking + + this%n = n + + allocate( this%u_mean(n) ) + allocate( this%ul(n) ) + allocate( this%ur(n) ) + allocate( this%slp(n) ) + + this%h_neglect = tiny( this%u_mean(1) ) + if (present(h_neglect)) this%h_neglect = h_neglect + this%check = .false. + if (present(check)) this%check = check + +end subroutine init + +!> Calculate a 1D PLM reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(PLM_hybgen), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: slp ! The PLM slopes (difference across cell) [A] + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [A] + real :: u_min, u_max ! Minimum and maximum value across cell [A] + real :: u_l, u_r, u_c ! Left, right, and center values [A] + real :: h_l, h_c, h_r ! Thickness of left, center and right cells [H] + real :: h_c0 ! Thickness of center with h_neglect added [H] + integer :: k, n + + n = this%n + + ! Loop over all cells + do k = 1, n + this%u_mean(k) = u(k) + enddo + + ! Boundary cells use PCM + this%ul(1) = u(1) + this%ur(1) = u(1) + this%slp(1) = 0. + + ! Loop over interior cells + do k = 2, n-1 + u_l = u(k-1) + u_c = u(k) + u_r = u(k+1) + + ! Side differences + sigma_r = u_r - u_c + sigma_l = u_c - u_l + + h_l = h(k-1) + h_c = h(k) + h_r = h(k+1) + ! Avoids division by zero + h_c0 = h_c + this%h_neglect + + ! This is the second order slope given by equation 1.7 of + ! Piecewise Parabolic Method, Colella and Woodward (1984), + ! http://dx.doi.org/10.1016/0021-991(84)90143-8. + ! For uniform resolution it simplifies to ( u_r - u_l )/2 . + sigma_c = ( h_c / ( h_c0 + ( h_l + h_r ) ) ) * ( & + ( 2.*h_l + h_c ) / ( h_r + h_c0 ) * sigma_r & + + ( 2.*h_r + h_c ) / ( h_l + h_c0 ) * sigma_l ) + if (h_c <= this%h_neglect) then + sigma_c = 0. + else + sigma_c = ( h_c / ( h_c + 0.5 * ( h_l + h_r ) ) ) * ( u_r - u_l ) + endif + + ! Limit slope so that reconstructions are bounded by neighbors + u_min = min( u_l, u_c, u_r ) + u_max = max( u_l, u_c, u_r ) + + if ( (sigma_l * sigma_r) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the two cell averages spanning the edge + slp = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) +! slp = sign( min( abs(sigma_c), 2. * abs(u_c - u_l), 2. * abs(u_r - u_c) ), sigma_c ) + else + ! Extrema in the mean values require a PCM reconstruction + slp = 0.0 + endif + this%slp(k) = slp + + ! Left edge + u_min = min( u_c, u_l ) + u_max = max( u_c, u_l ) + u_l = u_c - 0.5 * slp + this%ul(k) = max( min( u_l, u_max), u_min ) + this%ul(k) = u_l + + ! Right edge + u_min = min( u_c, u_r ) + u_max = max( u_c, u_r ) + u_r = u_c + 0.5 * slp + this%ur(k) = max( min( u_r, u_max), u_min ) + this%ur(k) = u_r + enddo + + ! Boundary cells use PCM + this%ul(n) = u(n) + this%ur(n) = u(n) + this%slp(n) = 0. + +end subroutine reconstruct + +!> Value of PLM_hybgen reconstruction at a point in cell k [A] +real function f(this, k, x) + class(PLM_hybgen), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + real :: xc ! Bounded version of x [nondim] + real :: du ! Difference across cell [A] + real :: u_a, u_b ! Two estimate of f [A] + + du = this%ur(k) - this%ul(k) + xc = max( 0., min( 1., x ) ) + + ! This expression for u_a can overshoot u_r but is good for x<<1 + u_a = this%ul(k) + du * xc + ! This expression for u_b can overshoot u_l but is good for 1-x<<1 + u_b = this%ur(k) + du * ( xc - 1. ) + + ! Since u_a and u_b are both bounded, this will perserve uniformity + f = 0.5 * ( u_a + u_b ) + +end function f + +!> Derivative of PLM_hybgen reconstruction at a point in cell k [A] +real function dfdx(this, k, x) + class(PLM_hybgen), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + + dfdx = this%ur(k) - this%ul(k) + +end function dfdx + +!> Average between xa and xb for cell k of a 1D PLM reconstruction [A] +real function average(this, k, xa, xb) + class(PLM_hybgen), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: xa !< Start of averaging interval on element (0 to 1) + real, intent(in) :: xb !< End of averaging interval on element (0 to 1) + real :: xmab ! Mid-point between xa and xb (0 to 1) +! real :: u_a, u_b ! Values at xa and xb [A] + + ! This form is not guaranteed to be bounded by {ul,ur} +! u_a = this%ul(k) * ( 1. - xa ) + this%ur(k) * xa +! u_b = this%ul(k) * ( 1. - xb ) + this%ur(k) * xb +! average = 0.5 * ( u_a + u_b ) + + ! Mid-point between xa and xb + xmab = 0.5 * ( xa + xb ) + + ! The following expression is exact at xmab=0 and xmab=1, + ! i.e. gives the numerically correct values. + ! It is not obvious that the expression is monotonic but according to + ! https://math.stackexchange.com/questions/907329/accurate-floating-point-linear-interpolation + ! it will be for the default rounding behavior. Otherwise is it + ! then possible this expression can be outside the range of ul and ur? +! average = this%ul(k) * ( 1. - xmab ) + this%ur(k) * xmab + ! Emperically it fails the uniform value test + + ! The following is more complicated but seems to ensure being within bounds. + ! This expression for u_a can overshoot u_r but is good for xmab<<1 +! u_a = this%ul(k) + ( this%ur(k) - this%ul(k) ) * xmab + ! This expression for u_b can overshoot u_l but is good for 1-xmab<<1 +! u_b = this%ur(k) + ( this%ul(k) - this%ur(k) ) * ( 1. - xmab ) + ! Replace xmab with -1 for xmab<0.5, 1 for xmab>=0.5 +! xmab = sign(1., xmab-0.5) + ! Select either u_a or u_b, depending whether mid-point of xa, xb is smaller/larger than 0.5 +! average = xmab * u_b + ( 1. - xmab ) * u_a + + ! Since u_a and u_b are both bounded, this will perserve uniformity but will the + ! sum be bounded? Emperically it seems to work... +! average = 0.5 * ( u_a + u_b ) + + ! This expression is equivalent to integrating the polynomial form of the PLM reconstruction + average = this%ul(k) + xmab * this%slp(k) + +end function average + +!> Deallocate the PLM reconstruction +subroutine destroy(this) + class(PLM_hybgen), intent(inout) :: this !< This reconstruction + + deallocate( this%u_mean, this%ul, this%ur ) + +end subroutine destroy + +!> Checks the PLM_hybgen reconstruction for consistency +logical function check_reconstruction(this, h, u) + class(PLM_hybgen), intent(in) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k + + check_reconstruction = .false. + + do k = 1, this%n + if ( abs( this%u_mean(k) - u(k) ) > 0. ) check_reconstruction = .true. + enddo + + ! Check the cell reconstruction is monotonic within each cell (it should be as a straight line) + do k = 1, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ur(k) - this%u_mean(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check the cell is a straight line (to within machine precision) + do k = 1, this%n + if ( abs(2. * this%u_mean(k) - ( this%ul(k) + this%ur(k) )) > epsilon(this%u_mean(1)) * & + max(abs(2. * this%u_mean(k)), abs(this%ul(k)), abs(this%ur(k))) ) check_reconstruction = .true. + enddo + +! The following test fails MOM_remapping:test_recon_consistency with Intel/2023.2.0 on gaea at iter=84 +! ! Check bounding of right edges, w.r.t. the cell means +! do K = 1, this%n-1 +! if ( ( this%ur(k) - this%u_mean(k) ) * ( this%u_mean(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. +! enddo + +! The following test fails MOM_remapping:test_recon_consistency with Intel/2023.2.0 on gaea at iter=161 +! ! Check bounding of left edges, w.r.t. the cell means +! do K = 2, this%n +! if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%u_mean(k-1) ) < 0. ) check_reconstruction = .true. +! enddo + + ! PLM is not globally monotonic so the following are expected to fail + +! ! Check bounding of right edges, w.r.t. this cell mean and the next cell left edge +! do K = 1, this%n-1 +! if ( ( this%ur(k) - this%u_mean(k) ) * ( this%ul(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. +! enddo + +! ! Check bounding of left edges, w.r.t. this cell mean and the previous cell right edge +! do K = 2, this%n +! if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%ur(k-1) ) < 0. ) check_reconstruction = .true. +! enddo + +end function check_reconstruction + +!> Runs PLM reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(PLM_hybgen), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + call this%init(3) + call test%test( this%n /= 3, 'Setting number of levels') + allocate( um(3), ul(3), ur(3), ull(3), urr(3) ) + + call this%reconstruct( (/2.,2.,2./), (/1.,3.,5./) ) + call test%real_arr(3, this%u_mean, (/1.,3.,5./), 'Setting cell values') + + do k = 1, 3 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(3, ul, (/1.,2.,5./), 'Evaluation on left edge') + call test%real_arr(3, um, (/1.,3.,5./), 'Evaluation in center') + call test%real_arr(3, ur, (/1.,4.,5./), 'Evaluation on right edge') + + do k = 1, 3 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + call test%real_arr(3, ul, (/0.,2.,0./), 'dfdx on left edge') + call test%real_arr(3, um, (/0.,2.,0./), 'dfdx in center') + call test%real_arr(3, ur, (/0.,2.,0./), 'dfdx on right edge') + + call test%real_scalar( this%x(1,0.), 0., 'f-1(1,0)=0') + call test%real_scalar( this%x(1,1.), 0.5, 'f-1(1,1)=0.5') + call test%real_scalar( this%x(1,3.), 1., 'f-1(1,3)=1') + call test%real_scalar( this%x(2,1.), 0., 'f-1(2,1)=0') + call test%real_scalar( this%x(2,3.), 0.5, 'f-1(2,3)=0.5') + call test%real_scalar( this%x(2,5.), 1., 'f-1(2,5)=1') + call test%real_scalar( this%x(3,3.), 0., 'f-1(3,3)=0') + call test%real_scalar( this%x(3,5.), 0.5, 'f-1(3,5)=0.5') + call test%real_scalar( this%x(3,7.), 1., 'f-1(3,7)=1') + + do k = 1, 3 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + call test%real_arr(3, um, (/1.,3.25,5./), 'Return interval average') + + call this%destroy() + deallocate( um, ul, ur, ull, urr ) + + allocate( um(4), ul(4), ur(4) ) + call this%init(4) + + ! These values lead to non-monotonic reconstuctions which are + ! valid for transport problems but not always appropriate for + ! remapping to arbitrary resolution grids. + ! The O(h^2) slopes are -, 2, 2, - and the limited + ! slopes are 0, 1, 1, 0 so the everywhere the reconstructions + ! are bounded by neighbors but ur(2) and ul(3) are out-of-order. + call this%reconstruct( (/1.,1.,1.,1./), (/0.,3.,4.,7./) ) + do k = 1, 4 + ul(k) = this%f(k, 0.) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(4, ul, (/0.,2.,3.,7./), 'Evaluation on left edge') + call test%real_arr(4, ur, (/0.,4.,5.,7./), 'Evaluation on right edge') + + deallocate( um, ul, ur ) + + unit_tests = test%summarize('PLM_hybgen:unit_tests') + +end function unit_tests + +!> \namespace recon1d_plm_hybgen +!! + +end module Recon1d_PLM_hybgen diff --git a/src/ALE/Recon1d_PPM_CW.F90 b/src/ALE/Recon1d_PPM_CW.F90 new file mode 100644 index 0000000000..7a0734ec88 --- /dev/null +++ b/src/ALE/Recon1d_PPM_CW.F90 @@ -0,0 +1,434 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Piecewise Parabolic Method 1D reconstruction following Colella and Woodward, 1984 +!! +!! This is a near faithful implementation of PPM following Colella and Woodward, 1984, with +!! cells resorting to PCM for extrema including first and last cells in column. The +!! only exception is that the PLM slopes used for edge interpolation are not set to zero +!! for the first and last cells, but are side-differenced. This improves accuracy of edge +!! values near boundaries and reduces the adverse influence of the boundaries on the +!! interior reconstructions. The final PPM reconstruction in the first and last cells are +!! set to PCM. The reconstructions are grid-spacing dependent, and so quasi-forth order in h. +module Recon1d_PPM_CW + +use Recon1d_type, only : Recon1d, testing +use Recon1d_PLM_CW, only : PLM_CW + +implicit none ; private + +public PPM_CW, testing + +!> PPM reconstruction following Colella and Woordward, 1984. +!! +!! The source for the methods ultimately used by this class are: +!! - init() *locally defined +!! - reconstruct() *locally defined +!! - average() *locally defined +!! - f() *locally defined +!! - dfdx() *locally defined +!! - x() *locally defined +!! - check_reconstruction() *locally defined +!! - unit_tests() *locally defined +!! - destroy() *locally defined +!! - remap_to_sub_grid() -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> init() +!! - reconstruct_parent() -> reconstruct() +type, extends (Recon1d) :: PPM_CW + + real, allocatable :: ul(:) !< Left edge value [A] + real, allocatable :: ur(:) !< Right edge value [A] + type(PLM_CW) :: PLM !< The PLM reconstruction used to estimate edge values + +contains + !> Implementation of the PPM_CW initialization + procedure :: init => init + !> Implementation of the PPM_CW reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of the PPM_CW average over an interval [A] + procedure :: average => average + !> Implementation of evaluating the PPM_CW reconstruction at a point [A] + procedure :: f => f + !> Implementation of the derivative of the PPM_CW reconstruction at a point [A] + procedure :: dfdx => dfdx + !> Implementation of solver for x: f(x)=t +! procedure :: x => x + !> Implementation of deallocation for PPM_CW + procedure :: destroy => destroy + !> Implementation of check reconstruction for the PPM_CW reconstruction + procedure :: check_reconstruction => check_reconstruction + !> Implementation of unit tests for the PPM_CW reconstruction + procedure :: unit_tests => unit_tests + + !> Duplicate interface to init() + procedure :: init_parent => init + !> Duplicate interface to reconstruct() + procedure :: reconstruct_parent => reconstruct + +end type PPM_CW + +contains + +!> Initialize a 1D PPM_CW reconstruction for n cells +subroutine init(this, n, h_neglect, check) + class(PPM_CW), intent(out) :: this !< This reconstruction + integer, intent(in) :: n !< Number of cells in this column + real, optional, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H] + logical, optional, intent(in) :: check !< If true, enable some consistency checking + + this%n = n + + allocate( this%u_mean(n) ) + allocate( this%ul(n) ) + allocate( this%ur(n) ) + + ! This incurs an extra store of u_mean but by using PCM_CW + ! we avoid duplicating and testing more code + call this%PLM%init( n, h_neglect=h_neglect, check=check ) + + this%h_neglect = tiny( this%u_mean(1) ) + if (present(h_neglect)) this%h_neglect = h_neglect + this%check = .false. + if (present(check)) this%check = check + +end subroutine init + +!> Calculate a 1D PPM_CW reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(PPM_CW), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: h0, h1, h2, h3 ! Cell thickness h(k-2), h(k-1), h(k), h(k+1) in K loop [H] + real :: d12 ! h1 + h2 but used in the denominator so include h_neglect [H] + real :: h01_h112, h23_h122 ! Approximately 2/3 [nondim] + real :: ddh ! Approximately 0 [nondim] + real :: I_h12, I_h0123 ! Reciprocals of d12 and sum(h) [H-1] + real :: dul, dur ! Left and right cell PLM slopes [A] + real :: u0, u1, u2 ! Far left, left, and right cell values [A] + real :: edge ! Edge value between cell k-1 and k [A] + real :: u_min, u_max ! Minimum and maximum value across edge [A] + real :: a6 ! Colella and Woodward curvature [A] + real :: du ! Difference between edges across cell [A] + real :: slp(this%n) ! PLM slope [A] + integer :: k, n + + n = this%n + + ! First populate the PLM reconstructions + call this%PLM%reconstruct( h, u ) + do k = 1, n + slp(k) = this%PLM%ur(k) - this%PLM%ul(k) + enddo + ! Extrapolate from interior for boundary PLM slopes + ! Note: this is not conventional but helps retain accuracy near top/bottom + ! boundaries and reduces the adverse influence of the boundaries in the interior + ! reconstructions. The final PPM reconstruction is still bounded to PCM. + slp(1) = 2.0 * ( this%PLM%ul(2) - u(1) ) + slp(n) = 2.0 * ( u(n) - this%PLM%ur(n-1) ) + + do K = 2, n ! K=2 is interface between cells 1 and 2 + h0 = h( max( 1, k-2 ) ) ! This treatment implies a virtual mirror cell at k=0 + h1 = h(k-1) + h2 = h(k) + h3 = h( min( n, k+1 ) ) ! This treatment implies a virtual mirror cell at k=n+1 + d12 = ( h1 + h2 ) + this%h_neglect ! d12 is only ever used in the denominator + h01_h112 = ( h0 + h1 ) / ( h1 + d12 ) ! When uniform -> 2/3 + h23_h122 = ( h2 + h3 ) / ( d12 + h2 ) ! When uniform -> 2/3 + ddh = h01_h112 - h23_h122 ! When uniform -> 0 + I_h12 = 1.0 / d12 ! When uniform -> 1/(2h) + I_h0123 = 1.0 / ( d12 + ( h0 + h3 ) ) ! When uniform -> 1/(4h) + dul = slp(k-1) + dur = slp(k) + u2 = u(k) + u1 = u(k-1) + edge = I_h12 * ( h2 * u1 + h1 * u2 ) & ! 1/2 u1 + 1/2 u2 + + I_h0123 * ( 2.0 * h1 * h2 * I_h12 * ddh * ( u2 - u1 ) & ! 0 + + ( h2 * h23_h122 * dul - h1 * h01_h112 * dur ) ) ! 1/6 dul - 1/6 dur + u_min = min( u1, u2 ) + u_max = max( u1, u2 ) + edge = max( min( edge, u_max), u_min ) ! Unclear if we need this bounding in the interior + this%ur(k-1) = edge + this%ul(k) = edge + enddo + this%ul(1) = u(1) ! PCM + this%ur(1) = u(1) ! PCM + this%ur(n) = u(n) ! PCM + this%ul(n) = u(n) ! PCM + + do K = 2, n-1 ! K=2 is interface between cells 1 and 2 + u0 = u(k-1) + u1 = u(k) + u2 = u(k+1) + a6 = 3.0 * ( ( u1 - this%ul(k) ) + ( u1 - this%ur(k) ) ) + du = this%ur(k) - this%ul(k) + if ( ( u2 - u1 ) * ( u1 - u0 ) <= 0.0 ) then ! Large scale extrema + this%ul(k) = u1 + this%ur(k) = u1 + elseif ( du * a6 > du * du ) then ! Extrema on right + ! edge = 3.0 * u1 - 2.0 * this%ur(k) ! OM4 era expressions is subject to round off + edge = u1 + 2.0 * ( u1 - this%ur(k) ) ! Passes consistency tests - AJA + ! The following bounds were applied in OM4 era schemes but are not needed now + ! u_min = min( u0, u1 ) + ! u_max = max( u0, u1 ) + ! edge = max( min( edge, u_max), u_min ) + this%ul(k) = edge + elseif ( du * a6 < - du * du ) then ! Extrema on left + ! edge = 3.0 * u1 - 2.0 * this%ul(k) ! OM4 era expressions is subject to round off + edge = u1 + 2.0 * ( u1 - this%ul(k) ) ! Passes consistency tests - AJA + ! The following bounds were applied in OM4 era schemes but are not needed now + ! u_min = min( u1, u2 ) + ! u_max = max( u1, u2 ) + ! edge = max( min( edge, u_max), u_min ) + this%ur(k) = edge + endif + enddo + + ! After the limiter, are ur and ul bounded???? -AJA + + ! Store mean + do k = 1, n + this%u_mean(k) = u(k) + enddo + +end subroutine reconstruct + +!> Value of PPM_CW reconstruction at a point in cell k [A] +real function f(this, k, x) + class(PPM_CW), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + real :: xc ! Bounded version of x [nondim] + real :: du ! Difference across cell [A] + real :: a6 ! Collela and Woordward curvature parameter [A] + real :: u_a, u_b ! Two estimate of f [A] + real :: lmx ! 1 - x [nondim] + real :: wb ! Weight based on x [nondim] + + du = this%ur(k) - this%ul(k) + a6 = 3.0 * ( ( this%u_mean(k) - this%ul(k) ) + ( this%u_mean(k) - this%ur(k) ) ) + xc = max( 0., min( 1., x ) ) + lmx = 1.0 - xc + + ! This expression for u_a can overshoot u_r but is good for x<<1 + u_a = this%ul(k) + xc * ( du + a6 * lmx ) + ! This expression for u_b can overshoot u_l but is good for 1-x<<1 + u_b = this%ur(k) + lmx * ( - du + a6 * xc ) + + ! Since u_a and u_b are both side-bounded, using weights=0 or 1 will preserve uniformity + wb = 0.5 + sign(0.5, xc - 0.5 ) ! = 1 @ x=0, = 0 @ x=1 + f = ( ( 1. - wb ) * u_a ) + ( wb * u_b ) + +end function f + +!> Derivative of PPM_CW reconstruction at a point in cell k [A] +real function dfdx(this, k, x) + class(PPM_CW), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + real :: xc ! Bounded version of x [nondim] + real :: du ! Difference across cell [A] + real :: a6 ! Collela and Woordward curvature parameter [A] + + du = this%ur(k) - this%ul(k) + a6 = 3.0 * ( ( this%u_mean(k) - this%ul(k) ) + ( this%u_mean(k) - this%ur(k) ) ) + xc = max( 0., min( 1., x ) ) + + dfdx = du + a6 * ( 2.0 * xc - 1.0 ) + +end function dfdx + +!> Average between xa and xb for cell k of a 1D PPM reconstruction [A] +real function average(this, k, xa, xb) + class(PPM_CW), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: xa !< Start of averaging interval on element (0 to 1) + real, intent(in) :: xb !< End of averaging interval on element (0 to 1) + real :: xapxb ! A sum of fracional positions [nondim] + real :: mx, Ya, Yb, my ! Various fractional positions [nondim] + real :: u_a, u_b ! Values at xa and xb [A] + real :: xa2pxb2, xa2b2ab, Ya2b2ab ! Sums of squared fractional positions [nondim] + real :: a_L, a_R, u_c, a_c ! Values of the polynomial at various locations [A] + + mx = 0.5 * ( xa + xb ) + a_L = this%ul(k) + a_R = this%ur(k) + u_c = this%u_mean(k) + a_c = 0.5 * ( ( u_c - a_L ) + ( u_c - a_R ) ) ! a_6 / 6 + if (mx<0.5) then + ! This integration of the PPM reconstruction is expressed in distances from the left edge + xa2b2ab = (xa * xa + xb * xb) + xa * xb + average = a_L + ( ( a_R - a_L ) * mx & + + a_c * ( 3. * ( xb + xa ) - 2. * xa2b2ab ) ) + else + ! This integration of the PPM reconstruction is expressed in distances from the right edge + Ya = 1. - xa + Yb = 1. - xb + my = 0.5 * ( Ya + Yb ) + Ya2b2ab = (Ya * Ya + Yb * Yb) + Ya * Yb + average = a_R + ( ( a_L - a_R ) * my & + + a_c * ( 3. * ( Yb + Ya ) - 2. * Ya2b2ab ) ) + endif + +end function average + +!> Deallocate the PPM_CW reconstruction +subroutine destroy(this) + class(PPM_CW), intent(inout) :: this !< This reconstruction + + deallocate( this%u_mean, this%ul, this%ur ) + +end subroutine destroy + +!> Checks the PPM_CW reconstruction for consistency +logical function check_reconstruction(this, h, u) + class(PPM_CW), intent(in) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k + + check_reconstruction = .false. + + ! Simply checks the internal copy of "u" is exactly equal to "u" + do k = 1, this%n + if ( abs( this%u_mean(k) - u(k) ) > 0. ) check_reconstruction = .true. + enddo + + ! If (u - ul) has the opposite sign from (ur - u), then this cell has an interior extremum + do k = 1, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ur(k) - this%u_mean(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of right edges, w.r.t. the cell means + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%u_mean(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. the cell means + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%u_mean(k-1) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of right edges, w.r.t. this cell mean and the next cell left edge + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%ul(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. this cell mean and the previous cell right edge + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%ur(k-1) ) < 0. ) check_reconstruction = .true. + enddo + +end function check_reconstruction + +!> Runs PPM_CW reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(PPM_CW), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test +call test%set( stop_instantly=.true. ) + + if (verbose) write(stdout,'(a)') 'PPM_CW:unit_tests testing with linear fn' + + call this%init(5) + call test%test( this%n /= 5, 'Setting number of levels') + allocate( um(5), ul(5), ur(5), ull(5), urr(5) ) + + ! Straight line, f(x) = x , or f(K) = 2*K + call this%reconstruct( (/2.,2.,2.,2.,2./), (/1.,4.,7.,10.,13./) ) + call test%real_arr(5, this%u_mean, (/1.,4.,7.,10.,13./), 'Setting cell values') + ! Without PLM extrapolation we get l(2)=2 and r(4)=12 due to PLM=0 in boundary cells. -AJA + call test%real_arr(5, this%ul, (/1.,2.5,5.5,8.5,13./), 'Left edge values') + call test%real_arr(5, this%ur, (/1.,5.5,8.5,11.5,13./), 'Right edge values') + + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, this%ul, 'Evaluation on left edge') + call test%real_arr(5, um, (/1.,4.,7.,10.,13./), 'Evaluation in center') + call test%real_arr(5, ur, this%ur, 'Evaluation on right edge') + + do k = 1, 5 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + ! Most of these values are affected by the PLM boundary cells + call test%real_arr(5, ul, (/0.,3.,3.,3.,0./), 'dfdx on left edge') + call test%real_arr(5, um, (/0.,3.,3.,3.,0./), 'dfdx in center') + call test%real_arr(5, ur, (/0.,3.,3.,3.,0./), 'dfdx on right edge') + + call test%real_scalar( this%x(2,1.), 0., 'f-1(2,1)=0') + call test%real_scalar( this%x(2,4.), 0.5, 'f-1(2,4)=0.5') + call test%real_scalar( this%x(2,5.5), 1., 'f-1(2,5.5)=1') + + do k = 1, 5 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + ! Most of these values are affected by the PLM boundary cells + call test%real_arr(5, um, (/1.,4.375,7.375,10.375,13./), 'Return interval average') + + if (verbose) write(stdout,'(a)') 'PPM_CW:unit_tests testing with parabola' + + ! x = 2 i i=0 at origin + ! f(x) = 3/4 x^2 = (2 i)^2 + ! f[i] = 3/4 ( 2 i - 1 )^2 on centers + ! f[I] = 3/4 ( 2 I )^2 on edges + ! f[i] = 1/8 [ x^3 ] for means + ! edges: 0, 1, 12, 27, 48, 75 + ! means: 1, 7, 19, 37, 61 + ! centers: 0.75, 6.75, 18.75, 36.75, 60.75 + call this%reconstruct( (/2.,2.,2.,2.,2./), (/1.,7.,19.,37.,61./) ) + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, (/1.,3.,12.,27.,61./), 'Return left edge') + call test%real_arr(5, um, (/1.,6.75,18.75,36.75,61./), 'Return center') + call test%real_arr(5, ur, (/1.,12.,27.,48.,61./), 'Return right edge') + + call test%real_scalar( this%x(3,12.), 0., 'f-1(3,12)=0') + call test%real_scalar( this%x(3,18.75), 0.5, 'f-1(3,18.75)=0.5', robits=1) + call test%real_scalar( this%x(3,27.), 1., 'f-1(3,27)=1') + + ! x = 3 i i=0 at origin + ! f(x) = x^2 / 3 = 3 i^2 + ! f[i] = [ ( 3 i )^3 - ( 3 i - 3 )^3 ] i=1,2,3,4,5 + ! means: 1, 7, 19, 37, 61 + ! edges: 0, 3, 12, 27, 48, 75 + call this%reconstruct( (/3.,3.,3.,3.,3./), (/1.,7.,19.,37.,61./) ) + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, (/1.,3.,12.,27.,61./), 'Return left edge') + call test%real_arr(5, um, (/1.,0.25*(6*7-15),0.25*(6*19-39),0.25*(6*37-75),61./), 'Return center') + call test%real_arr(5, ur, (/1.,12.,27.,48.,61./), 'Return right edge') + + call this%destroy() + deallocate( um, ul, ur, ull, urr ) + + unit_tests = test%summarize('PPM_CW:unit_tests') + +end function unit_tests + +!> \namespace recon1d_ppm_cw +!! + +end module Recon1d_PPM_CW diff --git a/src/ALE/Recon1d_PPM_CWK.F90 b/src/ALE/Recon1d_PPM_CWK.F90 new file mode 100644 index 0000000000..42d6cd04f7 --- /dev/null +++ b/src/ALE/Recon1d_PPM_CWK.F90 @@ -0,0 +1,473 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Piecewise Parabolic Method 1D reconstruction in model index space +!! +!! This implementation of PPM follows Colella and Woodward, 1984, using uniform thickness +!! and with cells resorting to PCM for local extrema including the first and last cells. +!! +!! "Fourth order" estimates of edge values use PLM also calculated in index space +!! (i.e. with no grid dependence). First and last PLM slopes are extrapolated. +!! Limiting follows Colella and Woodward thereafter. The high accuracy of this scheme is +!! realized only when the grid-spacing is exactly uniform. This scheme deviates from CW84 +!! when the grid spacing is variable. +module Recon1d_PPM_CWK + +use Recon1d_type, only : Recon1d, testing +use Recon1d_PLM_CWK, only : PLM_CWK + +implicit none ; private + +public PPM_CWK, testing + +!> PPM reconstruction in index space (no grid dependence). +!! +!! The source for the methods ultimately used by this class are: +!! - init() *locally defined +!! - reconstruct() *locally defined +!! - average() *locally defined +!! - f() *locally defined +!! - dfdx() *locally defined +!! - x() *locally defined +!! - check_reconstruction() *locally defined +!! - unit_tests() *locally defined +!! - destroy() *locally defined +!! - remap_to_sub_grid() -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> init() +!! - reconstruct_parent() -> reconstruct() +type, extends (Recon1d) :: PPM_CWK + + real, allocatable :: ul(:) !< Left edge value [A] + real, allocatable :: ur(:) !< Right edge value [A] + type(PLM_CWK) :: PLM !< The PLM reconstruction used to estimate edge values + +contains + !> Implementation of the PPM_CWK initialization + procedure :: init => init + !> Implementation of the PPM_CWK reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of the PPM_CWK average over an interval [A] + procedure :: average => average + !> Implementation of evaluating the PPM_CWK reconstruction at a point [A] + procedure :: f => f + !> Implementation of the derivative of the PPM_CWK reconstruction at a point [A] + procedure :: dfdx => dfdx + !> Implementation of solver for x: f(x)=t + procedure :: x => x + !> Implementation of deallocation for PPM_CWK + procedure :: destroy => destroy + !> Implementation of check reconstruction for the PPM_CWK reconstruction + procedure :: check_reconstruction => check_reconstruction + !> Implementation of unit tests for the PPM_CWK reconstruction + procedure :: unit_tests => unit_tests + + !> Duplicate interface to init() + procedure :: init_parent => init + !> Duplicate interface to reconstruct() + procedure :: reconstruct_parent => reconstruct + +end type PPM_CWK + +contains + +!> Initialize a 1D PPM_CWK reconstruction for n cells +subroutine init(this, n, h_neglect, check) + class(PPM_CWK), intent(out) :: this !< This reconstruction + integer, intent(in) :: n !< Number of cells in this column + real, optional, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H] + logical, optional, intent(in) :: check !< If true, enable some consistency checking + + this%n = n + + allocate( this%u_mean(n) ) + allocate( this%ul(n) ) + allocate( this%ur(n) ) + + ! This incurs an extra store of u_mean but by using PCM_CW + ! we avoid duplicating and testing more code + call this%PLM%init( n, h_neglect=h_neglect, check=check ) + + this%h_neglect = tiny( this%u_mean(1) ) + if (present(h_neglect)) this%h_neglect = h_neglect + this%check = .false. + if (present(check)) this%check = check + +end subroutine init + +!> Calculate a 1D PPM_CWK reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(PPM_CWK), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: dul, dur ! Left and right cell PLM slopes [A] + real :: u0, u1, u2 ! Far left, left, and right cell values [A] + real :: edge ! Edge value between cell k-1 and k [A] + real :: u_min, u_max ! Minimum and maximum value across edge [A] + real :: a6 ! Colella and Woodward curvature [A] + real :: du ! Difference between edges across cell [A] + real :: slp(this%n) ! PLM slope [A] + real, parameter :: one_sixth = 1. / 6. ! 1/6 [nondim] + integer :: k, n + + n = this%n + + ! First populate the PLM (k-space) reconstructions + call this%PLM%reconstruct( h, u ) + do k = 1, n + slp(k) = this%PLM%ur(k) - this%PLM%ul(k) + enddo + ! Extrapolate from interior for boundary PLM slopes + ! Note: this is not conventional but helps retain accuracy near top/bottom + ! boudaries and reduces the adverse influence of the boudnaries int he interior + ! reconstructions. The final PPM reconstruction is still bounded to PCM. + slp(1) = 2.0 * ( this%PLM%ul(2) - u(1) ) + slp(n) = 2.0 * ( u(n) - this%PLM%ur(n-1) ) + + do K = 2, n ! K=2 is interface between cells 1 and 2 + dul = slp(k-1) + dur = slp(k) + u2 = u(k) + u1 = u(k-1) + edge = 0.5 * ( u1 + u2 ) + one_sixth * ( dul - dur ) ! Eq. 1.6 with uniform h + u_min = min( u1, u2 ) + u_max = max( u1, u2 ) + edge = max( min( edge, u_max), u_min ) ! Unclear if we need this bounding in the interior + this%ur(k-1) = edge + this%ul(k) = edge + enddo + this%ul(1) = u(1) ! PCM + this%ur(1) = u(1) ! PCM + this%ur(n) = u(n) ! PCM + this%ul(n) = u(n) ! PCM + + do K = 2, n-1 ! K=2 is interface between cells 1 and 2 + u0 = u(k-1) + u1 = u(k) + u2 = u(k+1) + a6 = 3.0 * ( ( u1 - this%ul(k) ) + ( u1 - this%ur(k) ) ) + du = this%ur(k) - this%ul(k) + if ( ( u2 - u1 ) * ( u1 - u0 ) <= 0.0 ) then ! Large scale extrema + this%ul(k) = u1 + this%ur(k) = u1 + elseif ( du * a6 > du * du ) then ! Extrema on right + edge = u1 + 2.0 * ( u1 - this%ur(k) ) + ! u_min = min( u0, u1 ) + ! u_max = max( u0, u1 ) + ! edge = max( min( edge, u_max), u_min ) + this%ul(k) = edge + elseif ( du * a6 < - du * du ) then ! Extrema on left + edge = u1 + 2.0 * ( u1 - this%ul(k) ) + ! u_min = min( u1, u2 ) + ! u_max = max( u1, u2 ) + ! edge = max( min( edge, u_max), u_min ) + this%ur(k) = edge + endif + enddo + + ! After the limiter, are ur and ul bounded???? -AJA + + ! Store mean + do k = 1, n + this%u_mean(k) = u(k) + enddo + +end subroutine reconstruct + +!> Value of PPM_CWK reconstruction at a point in cell k [A] +real function f(this, k, x) + class(PPM_CWK), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + real :: xc ! Bounded version of x [nondim] + real :: du ! Difference across cell [A] + real :: a6 ! Collela and Woordward curvature parameter [A] + real :: u_a, u_b ! Two estimate of f [A] + real :: lmx ! 1 - x [nondim] + real :: wb ! Weight based on x [nondim] + + du = this%ur(k) - this%ul(k) + a6 = 3.0 * ( ( this%u_mean(k) - this%ul(k) ) + ( this%u_mean(k) - this%ur(k) ) ) + xc = max( 0., min( 1., x ) ) + lmx = 1.0 - xc + + ! This expression for u_a can overshoot u_r but is good for x<<1 + u_a = this%ul(k) + xc * ( du + a6 * lmx ) + ! This expression for u_b can overshoot u_l but is good for 1-x<<1 + u_b = this%ur(k) + lmx * ( - du + a6 * xc ) + + ! Since u_a and u_b are both side-bounded, using weights=0 or 1 will preserve uniformity + wb = 0.5 + sign(0.5, xc - 0.5 ) ! = 1 @ x=0, = 0 @ x=1 + f = ( ( 1. - wb ) * u_a ) + ( wb * u_b ) + +end function f + +!> Derivative of PPM_CWK reconstruction at a point in cell k [A] +real function dfdx(this, k, x) + class(PPM_CWK), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + real :: xc ! Bounded version of x [nondim] + real :: du ! Difference across cell [A] + real :: a6 ! Collela and Woordward curvature parameter [A] + + du = this%ur(k) - this%ul(k) + a6 = 3.0 * ( ( this%u_mean(k) - this%ul(k) ) + ( this%u_mean(k) - this%ur(k) ) ) + xc = max( 0., min( 1., x ) ) + + dfdx = du + a6 * ( 2.0 * xc - 1.0 ) + +end function dfdx + +!> Solver for x: f(x)=t +real function x(this, k, t) + class(PPM_CWK), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: t !< Value to solve for [A] + real :: slp ! Difference in edge values, ur-ul [A] + real :: a6 ! Colella and Woodward curvature parameter [A] + real :: sD ! Square root of the quadratic discriminant [A] + real :: b ! The b in f(x) = a x^2 + b x + c [A] + real :: c ! The c in f(x) = a x^2 + b x + c [A] + + ! The PPM profile is the quadratic profile: f(x) = ul + (slp+a6)*x - a6*x^2. + ! Setting f(x)=t gives: -a6*x^2 + (slp+a6)*x + (ul-t) = 0. + ! In the common parlance of solving a*x^2 + b*x + c = 0, this means + ! a = -a6; b = slp+a6; c = ul-t + ! The quadratic formula x = ( -b +/- sD ) / ( 2a ) with sD = sqrt(b^2-4*a*c) + ! can suffer from catastrophic cancellation in some scenarios. + ! A mathematically equivalent form of x = 2c / ( -b -/+ sD ) also can fail. + ! Usually, to avoid catastrophic cancellation, we use the rule + ! If b>0 then the two roots are + ! ra = -(b+sD)/(2a) + ! rc = -2c/(b+sD) + ! otherwise if b<0 then the two roots are + ! ra = (-b+sD)/(2a) + ! rc = 2c/(-b+sD) + ! In all expressions, sD and b do not have cancelling contributions due to the signs. + ! Note that here, if b>0 then c<0, and vice versa, because we are looking + ! for f(x)=t which shifts "c" by t so that the root we are interested in + ! falls in the range 0 <= x <= 1 (assuming t falls in ul...ur). + ! When b>0 and a>0 then -b/(2a)<0 and ra<00 and a<0 then -b/(2a)>0 and ra>rc, so we need rc + ! When b<0 and a>0 then -b/(2a)>0 and ra>rc, so we need rc + ! When b<0 and a<0 then -b/(2a)<0 and ra<0 0.) then + ! The max(0,..a.) here is out of an abundance of caution, but if the PPM parameters + ! have been made monotonic then the max is not necessary. + sD = sqrt( max( 0., b**2 + 4. * a6 * c ) ) + ! Calculate the reciprocal of the denominator. Note: even if b=0, sign(sD,b)=sD>0. + x = 1. / ( b + sign( sD, b ) ) + ! The actual root is + x = -2. * c * x + x = max( 0., min( 1., x ) ) + else + ! Constant (or inconsistent) profile (ul=ur, a6=?): infer position from adjacent cell slopes. + x = 0.5 ! fallback + slp = this%ul(min(k+1,this%n)) - this%ur(max(k-1,1)) + if (abs(slp) > 0.) x = 0.5 + sign( 0.5, slp ) ! either 0 or 1 + endif +end function x + +!> Average between xa and xb for cell k of a 1D PPM reconstruction [A] +real function average(this, k, xa, xb) + class(PPM_CWK), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: xa !< Start of averaging interval on element (0 to 1) + real, intent(in) :: xb !< End of averaging interval on element (0 to 1) + real :: xapxb ! A sum of fracional positions [nondim] + real :: mx, Ya, Yb, my ! Various fractional positions [nondim] + real :: u_a, u_b ! Values at xa and xb [A] + real :: xa2pxb2, xa2b2ab, Ya2b2ab ! Sums of squared fractional positions [nondim] + real :: a_L, a_R, u_c, a_c ! Values of the polynomial at various locations [A] + + mx = 0.5 * ( xa + xb ) + a_L = this%ul(k) + a_R = this%ur(k) + u_c = this%u_mean(k) + a_c = 0.5 * ( ( u_c - a_L ) + ( u_c - a_R ) ) ! a_6 / 6 + if (mx<0.5) then + ! This integration of the PPM reconstruction is expressed in distances from the left edge + xa2b2ab = (xa * xa + xb * xb) + xa * xb + average = a_L + ( ( a_R - a_L ) * mx & + + a_c * ( 3. * ( xb + xa ) - 2. * xa2b2ab ) ) + else + ! This integration of the PPM reconstruction is expressed in distances from the right edge + Ya = 1. - xa + Yb = 1. - xb + my = 0.5 * ( Ya + Yb ) + Ya2b2ab = (Ya * Ya + Yb * Yb) + Ya * Yb + average = a_R + ( ( a_L - a_R ) * my & + + a_c * ( 3. * ( Yb + Ya ) - 2. * Ya2b2ab ) ) + endif + +end function average + +!> Deallocate the PPM_CWK reconstruction +subroutine destroy(this) + class(PPM_CWK), intent(inout) :: this !< This reconstruction + + deallocate( this%u_mean, this%ul, this%ur ) + +end subroutine destroy + +!> Checks the PPM_CWK reconstruction for consistency +logical function check_reconstruction(this, h, u) + class(PPM_CWK), intent(in) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k + + check_reconstruction = .false. + + ! Simply checks the internal copy of "u" is exactly equal to "u" + do k = 1, this%n + if ( abs( this%u_mean(k) - u(k) ) > 0. ) check_reconstruction = .true. + enddo + + ! If (u - ul) has the opposite sign from (ur - u), then this cell has an interior extremum + do k = 1, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ur(k) - this%u_mean(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of right edges, w.r.t. the cell means + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%u_mean(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. the cell means + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%u_mean(k-1) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of right edges, w.r.t. this cell mean and the next cell left edge + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%ul(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. this cell mean and the previous cell right edge + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%ur(k-1) ) < 0. ) check_reconstruction = .true. + enddo + +end function check_reconstruction + +!> Runs PPM_CWK reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(PPM_CWK), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + if (verbose) write(stdout,'(a)') 'PPM_CWK:unit_tests testing with linear fn' + + call this%init(5) + call test%test( this%n /= 5, 'Setting number of levels') + allocate( um(5), ul(5), ur(5), ull(5), urr(5) ) + + ! Straight line, f(x) = x , or f(K) = 2*K + call this%reconstruct( (/2.,2.,2.,2.,2./), (/1.,4.,7.,10.,13./) ) + call test%real_arr(5, this%u_mean, (/1.,4.,7.,10.,13./), 'Setting cell values') + ! Without PLM extrapolation we get l(2)=2 and r(4)=12 due to PLM=0 in boundary cells. -AJA + call test%real_arr(5, this%ul, (/1.,2.5,5.5,8.5,13./), 'Left edge values') + call test%real_arr(5, this%ur, (/1.,5.5,8.5,11.5,13./), 'Right edge values') + + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, this%ul, 'Evaluation on left edge') + call test%real_arr(5, um, (/1.,4.,7.,10.,13./), 'Evaluation in center') + call test%real_arr(5, ur, this%ur, 'Evaluation on right edge') + + do k = 1, 5 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + ! Most of these values are affected by the PLM boundary cells + call test%real_arr(5, ul, (/0.,3.,3.,3.,0./), 'dfdx on left edge') + call test%real_arr(5, um, (/0.,3.,3.,3.,0./), 'dfdx in center') + call test%real_arr(5, ur, (/0.,3.,3.,3.,0./), 'dfdx on right edge') + + do k = 1, 5 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + ! Most of these values are affected by the PLM boundary cells + call test%real_arr(5, um, (/1.,4.375,7.375,10.375,13./), 'Return interval average') + + if (verbose) write(stdout,'(a)') 'PPM_CWK:unit_tests testing with parabola' + + ! x = 2 i i=0 at origin + ! f(x) = 3/4 x^2 = (2 i)^2 + ! f[i] = 3/4 ( 2 i - 1 )^2 on centers + ! f[I] = 3/4 ( 2 I )^2 on edges + ! f[i] = 1/8 [ x^3 ] for means + ! edges: 0, 1, 12, 27, 48, 75 + ! means: 1, 7, 19, 37, 61 + ! centers: 0.75, 6.75, 18.75, 36.75, 60.75 + call this%reconstruct( (/2.,2.,2.,2.,2./), (/1.,7.,19.,37.,61./) ) + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, (/1.,3.,12.,27.,61./), 'Return left edge') + call test%real_arr(5, um, (/1.,6.75,18.75,36.75,61./), 'Return center') + call test%real_arr(5, ur, (/1.,12.,27.,48.,61./), 'Return right edge') + + call test%real_scalar( this%x(3,12.), 0., 'f-1(3,12)=0') + call test%real_scalar( this%x(3,15.1875), 0.25, 'f-1(3,15.1875)=0.25') + call test%real_scalar( this%x(3,18.75), 0.5, 'f-1(3,18.75)=0.5') + call test%real_scalar( this%x(3,27.), 1., 'f-1(3,27)=1') + + call this%reconstruct( (/2.,2.,2.,2.,2./), (/-1.,-7.,-19.,-37.,-61./) ) + call test%real_scalar( this%x(3,-12.), 0., 'f-1(3,-12)=0') + call test%real_scalar( this%x(3,-15.1875), 0.25, 'f-1(3,-15.1875)=0.25') + call test%real_scalar( this%x(3,-18.75), 0.5, 'f-1(3,-18.75)=0.5') + call test%real_scalar( this%x(3,-27.), 1., 'f-1(3,-27)=1') + + ! x = 3 i i=0 at origin + ! f(x) = x^2 / 3 = 3 i^2 + ! f[i] = [ ( 3 i )^3 - ( 3 i - 3 )^3 ] i=1,2,3,4,5 + ! means: 1, 7, 19, 37, 61 + ! edges: 0, 3, 12, 27, 48, 75 + call this%reconstruct( (/3.,3.,3.,3.,3./), (/1.,7.,19.,37.,61./) ) + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, (/1.,3.,12.,27.,61./), 'Return left edge') + call test%real_arr(5, um, (/1.,6.75,18.75,36.75,61./), 'Return center') + call test%real_arr(5, ur, (/1.,12.,27.,48.,61./), 'Return right edge') + + call this%destroy() + deallocate( um, ul, ur, ull, urr ) + + unit_tests = test%summarize('PPM_CWK:unit_tests') + +end function unit_tests + +!> \namespace recon1d_ppm_cwk +!! + +end module Recon1d_PPM_CWK diff --git a/src/ALE/Recon1d_PPM_H4_2018.F90 b/src/ALE/Recon1d_PPM_H4_2018.F90 new file mode 100644 index 0000000000..401c95e504 --- /dev/null +++ b/src/ALE/Recon1d_PPM_H4_2018.F90 @@ -0,0 +1,305 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Piecewise Parabolic Method 1D reconstruction with h4 interpolation for edges (2018 version) +!! +!! This implementation of PPM follows White and Adcroft 2008 \cite white2008, with cells +!! resorting to PCM for extrema including first and last cells in column. +!! This scheme differs from Colella and Woodward, 1984 \cite colella1984, in the method +!! of first estimating the fourth-order accurate edge values. +!! This uses numerical expressions that predate a 2019 refactoring. +!! The first and last cells are always limited to PCM. +module Recon1d_PPM_H4_2018 + +use Recon1d_PPM_H4_2019, only : PPM_H4_2019, testing +use regrid_edge_values, only : bound_edge_values, check_discontinuous_edge_values +use regrid_solvers, only : solve_linear_system + +implicit none ; private + +public PPM_H4_2018, testing + +!> PPM reconstruction following White and Adcroft, 2008 +!! +!! Implemented by extending recon1d_ppm_h4_2019. +!! +!! The source for the methods ultimately used by this class are: +!! - init() -> recon1d_ppm_h4_2019.init() +!! - reconstruct() *locally defined +!! - average() -> recon1d_ppm_h4_2019.average() +!! - f() -> recon1d_ppm_h4_2019.f() +!! - dfdx() -> recon1d_ppm_h4_2019.dfdx() +!! - check_reconstruction() -> recon1d_ppm_h4_2019.check_reconstruction() +!! - unit_tests() *locally defined +!! - destroy() -> recon1d_ppm_h4_2019.destroy() +!! - remap_to_sub_grid() -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> recon1d_ppm_h4_2019.init() +!! - reconstruct_parent() -> recon1d_ppm_h4_2019.reconstruct() +type, extends (PPM_H4_2019) :: PPM_H4_2018 + +contains + !> Implementation of the PPM_H4_2018 reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of unit tests for the PPM_H4_2018 reconstruction + procedure :: unit_tests => unit_tests + +end type PPM_H4_2018 + +contains + +!> Calculate a 1D PPM_H4_2018 reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(PPM_H4_2018), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: slp ! The PLM slopes (difference across cell) [A] + real :: u_l, u_r, u_c ! Left, right, and center values [A] + real :: h_l, h_c, h_r ! Thickness of left, center and right cells [H] + real :: h0, h1, h2, h3 ! temporary thicknesses [H] + real :: h_min ! A minimal cell width [H] + real :: f1 ! An auxiliary variable [H] + real :: f2 ! An auxiliary variable [A H] + real :: f3 ! An auxiliary variable [H-1] + real :: et1, et2, et3 ! terms the expression for edge values [A H] + real :: dx ! Difference of successive values of x [H] + real :: f ! value of polynomial at x in arbitrary units [A] + real :: edge_l, edge_r ! Edge values (left and right) [A] + real :: expr1, expr2 ! Temporary expressions [A2] + real, parameter :: hMinFrac = 1.e-5 !< A minimum fraction for min(h)/sum(h) [nondim] + real, dimension(5) :: x ! Coordinate system with 0 at edges [H] + real :: edge_values(this%n,2) ! Edge values [A] + real :: ppoly_coef(this%n,3) ! Polynomial coefficients [A] + real, dimension(4,4) :: A ! Differences in successive positions raised to various powers, + ! in units that vary with the second (j) index as [H^j] + 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)] + integer :: k, n, j + + n = this%n + + ! Loop on interior cells + do K = 3, n-1 + + h0 = h(k-2) + h1 = h(k-1) + h2 = h(k) + h3 = h(k+1) + + ! Avoid singularities when consecutive pairs of h vanish + if (h0+h1==0.0 .or. h1+h2==0.0 .or. h2+h3==0.0) then + h_min = hMinFrac*max( this%h_neglect, h0+h1+h2+h3 ) + h0 = max( h_min, h(k-2) ) + h1 = max( h_min, h(k-1) ) + h2 = max( h_min, h(k) ) + h3 = max( h_min, h(k+1) ) + endif + + f1 = (h0+h1) * (h2+h3) / (h1+h2) + f2 = h2 * u(k-1) + h1 * u(k) + f3 = 1.0 / (h0+h1+h2) + 1.0 / (h1+h2+h3) + et1 = f1 * f2 * f3 + et2 = ( h2 * (h2+h3) / ( (h0+h1+h2)*(h0+h1) ) ) * & + ((h0+2.0*h1) * u(k-1) - h1 * u(k-2)) + et3 = ( h1 * (h0+h1) / ( (h1+h2+h3)*(h2+h3) ) ) * & + ((2.0*h2+h3) * u(k) - h2 * u(k+1)) + edge_values(k,1) = (et1 + et2 + et3) / ( h0 + h1 + h2 + h3) + edge_values(k-1,2) = edge_values(k,1) + + enddo ! end loop on interior cells + + ! Determine first two edge values + h_min = max( this%h_neglect, hMinFrac*sum(h(1:4)) ) + x(1) = 0.0 + do k = 1,4 + dx = max(h_min, h(k) ) + x(k+1) = x(k) + dx + do j = 1,4 ; A(k,j) = ( (x(k+1)**j) - (x(k)**j) ) / real(j) ; enddo + B(k) = u(k) * dx + enddo + + call solve_linear_system( A, B, C, 4 ) + + ! Set the edge values of the first cell + f = 0.0 + do k = 1, 4 + f = f + C(k) * ( x(1)**(k-1) ) + enddo + edge_values(1,1) = f + f = 0.0 + do k = 1, 4 + f = f + C(k) * ( x(2)**(k-1) ) + enddo + edge_values(1,2) = f + edge_values(2,1) = edge_values(1,2) + + ! Determine two edge values of the last cell + h_min = max( this%h_neglect, hMinFrac*sum(h(n-3:n)) ) + x(1) = 0.0 + do k = 1,4 + dx = max(h_min, h(n-4+k) ) + x(k+1) = x(k) + dx + do j = 1,4 ; A(k,j) = ( (x(k+1)**j) - (x(k)**j) ) / real(j) ; enddo + B(k) = u(n-4+k) * dx + enddo + + call solve_linear_system( A, B, C, 4 ) + + ! Set the last and second to last edge values + f = 0.0 + do k = 1, 4 + f = f + C(k) * ( x(5)**(k-1) ) + enddo + edge_values(n,2) = f + f = 0.0 + do k = 1, 4 + f = f + C(k) * ( x(4)**(k-1) ) + enddo + edge_values(n,1) = f + edge_values(n-1,2) = edge_values(n,1) + + ! Bound edge values + call bound_edge_values( n, h, u, edge_values, this%h_neglect, answer_date=20180101 ) + + ! Make discontinuous edge values monotonic + call check_discontinuous_edge_values( n, u, edge_values ) + + ! Loop on interior cells to apply the standard + ! PPM limiter (Colella & Woodward, JCP 84) + do k = 2,n-1 + + ! Get cell averages + u_l = u(k-1) + u_c = u(k) + u_r = u(k+1) + + edge_l = edge_values(k,1) + edge_r = edge_values(k,2) + + if ( (u_r - u_c)*(u_c - u_l) <= 0.0) then + ! Flatten extremum + edge_l = u_c + edge_r = u_c + else + expr1 = 3.0 * (edge_r - edge_l) * ( (u_c - edge_l) + (u_c - edge_r)) + expr2 = (edge_r - edge_l) * (edge_r - edge_l) + if ( expr1 > expr2 ) then + ! Place extremum at right edge of cell by adjusting left edge value + edge_l = u_c + 2.0 * ( u_c - edge_r ) + edge_l = max( min( edge_l, max(u_l, u_c) ), min(u_l, u_c) ) ! In case of round off + elseif ( expr1 < -expr2 ) then + ! Place extremum at left edge of cell by adjusting right edge value + edge_r = u_c + 2.0 * ( u_c - edge_l ) + edge_r = max( min( edge_r, max(u_r, u_c) ), min(u_r, u_c) ) ! In case of round off + endif + endif + ! This checks that the difference in edge values is representable + ! and avoids overshoot problems due to round off. + !### The 1.e-60 needs to have units of [A], so this dimensionally inconsistent. + if ( abs( edge_r - edge_l ) Runs PPM_H4_2018 reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(PPM_H4_2018), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + if (verbose) write(stdout,'(a)') 'PPM_H4_2018:unit_tests testing with linear fn' + + call this%init(5) + call test%test( this%n /= 5, 'Setting number of levels') + allocate( um(5), ul(5), ur(5), ull(5), urr(5) ) + + ! Straight line, f(x) = x , or f(K) = 2*K + call this%reconstruct( (/2.,2.,2.,2.,2./), (/1.,3.,5.,7.,9./) ) + call test%real_arr(5, this%u_mean, (/1.,3.,5.,7.,9./), 'Setting cell values') + call test%real_arr(5, this%ul, (/1.,2.,4.,6.,9./), 'Left edge values', robits=2) + call test%real_arr(5, this%ur, (/1.,4.,6.,8.,9./), 'Right edge values', robits=1) + do k = 1, 5 + um(k) = this%u_mean(k) + enddo + call test%real_arr(5, um, (/1.,3.,5.,7.,9./), 'Return cell mean') + + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, this%ul, 'Evaluation on left edge') + call test%real_arr(5, um, (/1.,3.,5.,7.,9./), 'Evaluation in center') + call test%real_arr(5, ur, this%ur, 'Evaluation on right edge') + + do k = 1, 5 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + call test%real_arr(5, ul, (/0.,2.,2.,2.,0./), 'dfdx on left edge', robits=4) + call test%real_arr(5, um, (/0.,2.,2.,2.,0./), 'dfdx in center', robits=2) + call test%real_arr(5, ur, (/0.,2.,2.,2.,0./), 'dfdx on right edge', robits=6) + + do k = 1, 5 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + call test%real_arr(5, um, (/1.,3.25,5.25,7.25,9./), 'Return interval average') + + if (verbose) write(stdout,'(a)') 'PPM_H4_2018:unit_tests testing with parabola' + + ! x = 3 i i=0 at origin + ! f(x) = x^2 / 3 = 3 i^2 + ! f[i] = [ ( 3 i )^3 - ( 3 i - 3 )^3 ] i=1,2,3,4,5 + ! means: 1, 7, 19, 37, 61 + ! edges: 0, 3, 12, 27, 48, 75 + call this%reconstruct( (/3.,3.,3.,3.,3./), (/1.,7.,19.,37.,61./) ) + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, (/1.,3.,12.,27.,61./), 'Return left edge', robits=2) + call test%real_arr(5, ur, (/1.,12.,27.,48.,61./), 'Return right edge', robits=1) + + call this%destroy() + deallocate( um, ul, ur, ull, urr ) + + unit_tests = test%summarize('PPM_H4_2018:unit_tests') + +end function unit_tests + +!> \namespace recon1d_ppm_h4_2018 +!! + +end module Recon1d_PPM_H4_2018 diff --git a/src/ALE/Recon1d_PPM_H4_2019.F90 b/src/ALE/Recon1d_PPM_H4_2019.F90 new file mode 100644 index 0000000000..2dc3315eaf --- /dev/null +++ b/src/ALE/Recon1d_PPM_H4_2019.F90 @@ -0,0 +1,587 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Piecewise Parabolic Method 1D reconstruction with h4 interpolation for edges +!! +!! This implementation of PPM follows White and Adcroft 2008 \cite white2008, with cells +!! resorting to PCM for extrema including first and last cells in column. +!! This scheme differs from Colella and Woodward, 1984 \cite colella1984, in the method +!! of first estimating the fourth-order accurate edge values. +!! This uses numerical expressions refactored at the beginning of 2019. +!! The first and last cells are always limited to PCM. +module Recon1d_PPM_H4_2019 + +use Recon1d_type, only : Recon1d, testing + +implicit none ; private + +public PPM_H4_2019, testing + +!> PPM reconstruction following White and Adcroft, 2008 +!! +!! The source for the methods ultimately used by this class are: +!! - init() *locally defined +!! - reconstruct() *locally defined +!! - average() *locally defined +!! - f() *locally defined +!! - dfdx() *locally defined +!! - check_reconstruction() *locally defined +!! - unit_tests() *locally defined +!! - destroy() *locally defined +!! - remap_to_sub_grid() -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> init() +!! - reconstruct_parent() -> reconstruct() +type, extends (Recon1d) :: PPM_H4_2019 + + real, allocatable :: ul(:) !< Left edge value [A] + real, allocatable :: ur(:) !< Right edge value [A] + +contains + !> Implementation of the PPM_H4_2019 initialization + procedure :: init => init + !> Implementation of the PPM_H4_2019 reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of the PPM_H4_2019 average over an interval [A] + procedure :: average => average + !> Implementation of evaluating the PPM_H4_2019 reconstruction at a point [A] + procedure :: f => f + !> Implementation of the derivative of the PPM_H4_2019 reconstruction at a point [A] + procedure :: dfdx => dfdx + !> Implementation of deallocation for PPM_H4_2019 + procedure :: destroy => destroy + !> Implementation of check reconstruction for the PPM_H4_2019 reconstruction + procedure :: check_reconstruction => check_reconstruction + !> Implementation of unit tests for the PPM_H4_2019 reconstruction + procedure :: unit_tests => unit_tests + + !> Duplicate interface to init() + procedure :: init_parent => init + !> Duplicate interface to reconstruct() + procedure :: reconstruct_parent => reconstruct + +end type PPM_H4_2019 + +contains + +!> Initialize a 1D PPM_H4_2019 reconstruction for n cells +subroutine init(this, n, h_neglect, check) + class(PPM_H4_2019), intent(out) :: this !< This reconstruction + integer, intent(in) :: n !< Number of cells in this column + real, optional, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H] + logical, optional, intent(in) :: check !< If true, enable some consistency checking + + this%n = n + + allocate( this%u_mean(n) ) + allocate( this%ul(n) ) + allocate( this%ur(n) ) + + this%h_neglect = tiny( this%u_mean(1) ) + if (present(h_neglect)) this%h_neglect = h_neglect + this%check = .false. + if (present(check)) this%check = check + +end subroutine init + +!> Calculate a 1D PPM_H4_2019 reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(PPM_H4_2019), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: slp ! The PLM slopes (difference across cell) [A] + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [A] + real :: u_min, u_max ! Minimum and maximum value across cell [A] + real :: u_l, u_r, u_c ! Left, right, and center values [A] + real :: h_l, h_c, h_r ! Thickness of left, center and right cells [H] + real :: h_c0 ! Thickness of center with h_neglect added [H] + real :: h0, h1, h2, h3 ! temporary thicknesses [H] + real :: h_min ! A minimal cell width [H] + real :: f1 ! An auxiliary variable [H] + real :: f2 ! An auxiliary variable [A H] + real :: f3 ! An auxiliary variable [H-1] + real :: et1, et2, et3 ! terms the expression for edge values [A H] + real :: I_h12 ! The inverse of the sum of the two central thicknesses [H-1] + real :: I_h012, I_h123 ! Inverses of sums of three successive thicknesses [H-1] + real :: I_den_et2, I_den_et3 ! Inverses of denominators in edge value terms [H-2] + real :: dx ! Difference of successive values of x [H] + real :: f ! value of polynomial at x in arbitrary units [A] + real :: edge_l, edge_r ! Edge values (left and right) [A] + real :: expr1, expr2 ! Temporary expressions [A2] + real :: slope_x_h ! retained PLM slope times half grid step [A] + real :: u0_avg ! avg value at given edge [A] + real, parameter :: hMinFrac = 1.e-5 !< A minimum fraction for min(h)/sum(h) [nondim] + real :: edge_values(this%n,2) ! Edge values [A] + real :: ppoly_coef(this%n,3) ! Polynomial coefficients [A] + real :: dz(4) ! A temporary array of limited layer thicknesses [H] + real :: u_tmp(4) ! A temporary array of cell average properties [A] + real :: A(4,4) ! Differences in successive positions raised to various powers, + ! in units that vary with the second (j) index as [H^j] + real :: B(4) ! The right hand side of the system to solve for C [A H] + real :: C(4) ! The coefficients of a fit polynomial in units that vary + ! with the index (j) as [A H^(j-1)] + integer :: k, n, km1, kp1 + + n = this%n + + ! Loop on interior cells + do K = 3, n-1 + + h0 = h(k-2) + h1 = h(k-1) + h2 = h(k) + h3 = h(k+1) + + ! Avoid singularities when consecutive pairs of h vanish + if (h0+h1==0.0 .or. h1+h2==0.0 .or. h2+h3==0.0) then + h_min = hMinFrac*max( this%h_neglect, (h0+h1)+(h2+h3) ) + h0 = max( h_min, h0 ) + h1 = max( h_min, h1 ) + h2 = max( h_min, h2 ) + h3 = max( h_min, h3 ) + endif + + I_h12 = 1.0 / (h1+h2) + I_den_et2 = 1.0 / ( ((h0+h1)+h2)*(h0+h1) ) ; I_h012 = (h0+h1) * I_den_et2 + I_den_et3 = 1.0 / ( (h1+(h2+h3))*(h2+h3) ) ; I_h123 = (h2+h3) * I_den_et3 + + et1 = ( 1.0 + (h1 * I_h012 + (h0+h1) * I_h123) ) * I_h12 * (h2*(h2+h3)) * u(k-1) + & + ( 1.0 + (h2 * I_h123 + (h2+h3) * I_h012) ) * I_h12 * (h1*(h0+h1)) * u(k) + et2 = ( h1 * (h2*(h2+h3)) * I_den_et2 ) * (u(k-1)-u(k-2)) + et3 = ( h2 * (h1*(h0+h1)) * I_den_et3 ) * (u(k) - u(k+1)) + edge_values(k,1) = (et1 + (et2 + et3)) / ((h0 + h1) + (h2 + h3)) + edge_values(k-1,2) = edge_values(k,1) + + enddo ! end loop on interior cells + + ! Determine first two edge values + do k=1,4 ; dz(k) = max(this%h_neglect, h(k) ) ; u_tmp(k) = u(k) ; enddo + call end_value_h4(dz, u_tmp, C) + + ! Set the edge values of the first cell + edge_values(1,1) = C(1) + edge_values(1,2) = C(1) + dz(1) * ( C(2) + dz(1) * ( C(3) + dz(1) * C(4) ) ) + edge_values(2,1) = edge_values(1,2) + + ! Determine two edge values of the last cell + do k=1,4 ; dz(k) = max(this%h_neglect, h(n+1-k) ) ; u_tmp(k) = u(n+1-k) ; enddo + call end_value_h4(dz, u_tmp, C) + + ! Set the last and second to last edge values + edge_values(n,2) = C(1) + edge_values(n,1) = C(1) + dz(1) * ( C(2) + dz(1) * ( C(3) + dz(1) * C(4) ) ) + edge_values(n-1,2) = edge_values(n,1) + + ! Loop on cells to bound edge value + do k = 1, n + + ! For the sake of bounding boundary edge values, the left neighbor of the left boundary cell + ! is assumed to be the same as the left boundary cell and the right neighbor of the right + ! boundary cell is assumed to be the same as the right boundary cell. This effectively makes + ! boundary cells look like extrema. + km1 = max(1,k-1) ; kp1 = min(k+1,N) + + slope_x_h = 0.0 + sigma_l = ( u(k) - u(km1) ) + if ( (h(km1) + h(kp1)) + 2.0*h(k) > 0. ) then + sigma_c = ( u(kp1) - u(km1) ) * ( h(k) / ((h(km1) + h(kp1)) + 2.0*h(k)) ) + else + sigma_c = 0. + endif + sigma_r = ( u(kp1) - u(k) ) + + ! 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) + if ( (sigma_l * sigma_r) > 0.0 ) & + slope_x_h = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) + + ! Limit the edge values + if ( (u(km1)-edge_values(k,1)) * (edge_values(k,1)-u(k)) < 0.0 ) then + edge_values(k,1) = u(k) - sign( min( abs(slope_x_h), abs(edge_values(k,1)-u(k)) ), slope_x_h ) + endif + + if ( (u(kp1)-edge_values(k,2)) * (edge_values(k,2)-u(k)) < 0.0 ) then + edge_values(k,2) = u(k) + sign( min( abs(slope_x_h), abs(edge_values(k,2)-u(k)) ), slope_x_h ) + endif + + ! Finally bound by neighboring cell means in case of roundoff + edge_values(k,1) = max( min( edge_values(k,1), max(u(km1), u(k)) ), min(u(km1), u(k)) ) + edge_values(k,2) = max( min( edge_values(k,2), max(u(kp1), u(k)) ), min(u(kp1), u(k)) ) + + enddo ! loop on interior edges + + do k = 1, n-1 + if ( (edge_values(k+1,1) - edge_values(k,2)) * (u(k+1) - u(k)) < 0.0 ) then + u0_avg = 0.5 * ( edge_values(k,2) + edge_values(k+1,1) ) + u0_avg = max( min( u0_avg, max(u(k), u(k+1)) ), min(u(k), u(k+1)) ) + edge_values(k,2) = u0_avg + edge_values(k+1,1) = u0_avg + endif + enddo ! end loop on interior edges + + ! Loop on interior cells to apply the standard + ! PPM limiter (Colella & Woodward, JCP 84) + do k = 2,N-1 + + ! Get cell averages + u_l = u(k-1) + u_c = u(k) + u_r = u(k+1) + + edge_l = edge_values(k,1) + edge_r = edge_values(k,2) + + if ( (u_r - u_c)*(u_c - u_l) <= 0.0) then + ! Flatten extremum + edge_l = u_c + edge_r = u_c + else + expr1 = 3.0 * (edge_r - edge_l) * ( (u_c - edge_l) + (u_c - edge_r)) + expr2 = (edge_r - edge_l) * (edge_r - edge_l) + if ( expr1 > expr2 ) then + ! Place extremum at right edge of cell by adjusting left edge value + edge_l = u_c + 2.0 * ( u_c - edge_r ) + edge_l = max( min( edge_l, max(u_l, u_c) ), min(u_l, u_c) ) ! In case of round off + elseif ( expr1 < -expr2 ) then + ! Place extremum at left edge of cell by adjusting right edge value + edge_r = u_c + 2.0 * ( u_c - edge_l ) + edge_r = max( min( edge_r, max(u_r, u_c) ), min(u_r, u_c) ) ! In case of round off + endif + endif + ! This checks that the difference in edge values is representable + ! and avoids overshoot problems due to round off. + !### The 1.e-60 needs to have units of [A], so this dimensionally inconsistent. + if ( abs( edge_r - edge_l ) Determine a one-sided 4th order polynomial fit of u to the data points for the purposes of specifying +!! edge values, as described in the appendix of White and Adcroft JCP 2008. +subroutine end_value_h4(dz, u, Csys) + real, intent(in) :: dz(4) !< The thicknesses of 4 layers, starting at the edge [H]. + !! The values of dz must be positive. + real, intent(in) :: u(4) !< The average properties of 4 layers, starting at the edge [A] + real, intent(out) :: Csys(4) !< The four coefficients of a 4th order polynomial fit + !! of u as a function of z [A H-(n-1)] + + ! Local variables + real :: Wt(3,4) ! The weights of successive u differences in the 4 closed form expressions. + ! The units of Wt vary with the second index as [H-(n-1)]. + real :: h1, h2, h3, h4 ! Copies of the layer thicknesses [H] + real :: h12, h23, h34 ! Sums of two successive thicknesses [H] + real :: h123, h234 ! Sums of three successive thicknesses [H] + real :: h1234 ! Sums of all four thicknesses [H] + ! real :: I_h1 ! The inverse of the a thickness [H-1] + real :: I_h12, I_h23, I_h34 ! The inverses of sums of two thicknesses [H-1] + real :: I_h123, I_h234 ! The inverse of the sum of three thicknesses [H-1] + real :: I_h1234 ! The inverse of the sum of all four thicknesses [H-1] + real :: I_denom ! The inverse of the denominator some expressions [H-3] + real :: I_denB3 ! The inverse of the product of three sums of thicknesses [H-3] + real :: min_frac = 1.0e-6 ! The square of min_frac should be much larger than roundoff [nondim] + real, parameter :: C1_3 = 1.0 / 3.0 ! A rational parameter [nondim] + + ! if ((dz(1) == dz(2)) .and. (dz(1) == dz(3)) .and. (dz(1) == dz(4))) then + ! ! There are simple closed-form expressions in this case + ! I_h1 = 0.0 ; if (dz(1) > 0.0) I_h1 = 1.0 / dz(1) + ! Csys(1) = u(1) + (-13.0 * (u(2)-u(1)) + 10.0 * (u(3)-u(2)) - 3.0 * (u(4)-u(3))) * (0.25*C1_3) + ! Csys(2) = (35.0 * (u(2)-u(1)) - 34.0 * (u(3)-u(2)) + 11.0 * (u(4)-u(3))) * (0.25*C1_3 * I_h1) + ! Csys(3) = (-5.0 * (u(2)-u(1)) + 8.0 * (u(3)-u(2)) - 3.0 * (u(4)-u(3))) * (0.25 * I_h1**2) + ! Csys(4) = ((u(2)-u(1)) - 2.0 * (u(3)-u(2)) + (u(4)-u(3))) * (0.5*C1_3) + ! else + + ! Express the coefficients as sums of the differences between properties of successive layers. + + h1 = dz(1) ; h2 = dz(2) ; h3 = dz(3) ; h4 = dz(4) + ! Some of the weights used below are proportional to (h1/(h2+h3))**2 or (h1/(h2+h3))*(h2/(h3+h4)) + ! so h2 and h3 should be adjusted to ensure that these ratios are not so large that property + ! differences at the level of roundoff are amplified to be of order 1. + if ((h2+h3) < min_frac*h1) h3 = min_frac*h1 - h2 + if ((h3+h4) < min_frac*h1) h4 = min_frac*h1 - h3 + + h12 = h1+h2 ; h23 = h2+h3 ; h34 = h3+h4 + h123 = h12 + h3 ; h234 = h2 + h34 ; h1234 = h12 + h34 + ! Find 3 reciprocals with a single division for efficiency. + I_denB3 = 1.0 / (h123 * h12 * h23) + I_h12 = (h123 * h23) * I_denB3 + I_h23 = (h12 * h123) * I_denB3 + I_h123 = (h12 * h23) * I_denB3 + I_denom = 1.0 / ( h1234 * (h234 * h34) ) + I_h34 = (h1234 * h234) * I_denom + I_h234 = (h1234 * h34) * I_denom + I_h1234 = (h234 * h34) * I_denom + + ! Calculation coefficients in the four equations + + ! The expressions for Csys(3) and Csys(4) come from reducing the 4x4 matrix problem into the following 2x2 + ! matrix problem, then manipulating the analytic solution to avoid any subtraction and simplifying. + ! (C1_3 * h123 * h23) * Csys(3) + (0.25 * h123 * h23 * (h3 + 2.0*h2 + 3.0*h1)) * Csys(4) = + ! (u(3)-u(1)) - (u(2)-u(1)) * (h12 + h23) * I_h12 + ! (C1_3 * ((h23 + h34) * h1234 + h23 * h3)) * Csys(3) + + ! (0.25 * ((h1234 + h123 + h12 + h1) * h23 * h3 + (h1234 + h12 + h1) * (h23 + h34) * h1234)) * Csys(4) = + ! (u(4)-u(1)) - (u(2)-u(1)) * (h123 + h234) * I_h12 + ! The final expressions for Csys(1) and Csys(2) were derived by algebraically manipulating the following expressions: + ! Csys(1) = (C1_3 * h1 * h12 * Csys(3) + 0.25 * h1 * h12 * (2.0*h1+h2) * Csys(4)) - & + ! (h1*I_h12)*(u(2)-u(1)) + u(1) + ! Csys(2) = (-2.0*C1_3 * (2.0*h1+h2) * Csys(3) - 0.5 * (h1**2 + h12 * (2.0*h1+h2)) * Csys(4)) + & + ! 2.0*I_h12 * (u(2)-u(1)) + ! These expressions are typically evaluated at x=0 and x=h1, so it is important that these are well behaved + ! for these values, suggesting that h1/h23 and h1/h34 should not be allowed to be too large. + + Wt(1,1) = -h1 * (I_h1234 + I_h123 + I_h12) ! > -3 + Wt(2,1) = h1 * h12 * ( I_h234 * I_h1234 + I_h23 * (I_h234 + I_h123) ) ! < (h1/h234) + (h1/h23)*(2+(h1/h234)) + Wt(3,1) = -h1 * h12 * h123 * I_denom ! > -(h1/h34)*(1+(h1/h234)) + + Wt(1,2) = 2.0 * (I_h12*(1.0 + (h1+h12) * (I_h1234 + I_h123)) + h1 * I_h1234*I_h123) ! < 10/h12 + Wt(2,2) = -2.0 * ((h1 * h12 * I_h1234) * (I_h23 * (I_h234 + I_h123)) + & ! > -(10+6*(h1/h234))/h23 + (h1+h12) * ( I_h1234*I_h234 + I_h23 * (I_h234 + I_h123) ) ) + Wt(3,2) = 2.0 * ((h1+h12) * h123 + h1*h12 ) * I_denom ! < (2+(6*h1/h234)) / h34 + + Wt(1,3) = -3.0 * I_h12 * I_h123* ( 1.0 + I_h1234 * ((h1+h12)+h123) ) ! > -12 / (h12*h123) + Wt(2,3) = 3.0 * I_h23 * ( I_h123 + I_h1234 * ((h1+h12)+h123) * (I_h123 + I_h234) ) ! < 12 / (h23^2) + Wt(3,3) = -3.0 * ((h1+h12)+h123) * I_denom ! > -9 / (h234*h23) + + Wt(1,4) = 4.0 * I_h1234 * I_h123 * I_h12 ! Wt*h1^3 < 4 + Wt(2,4) = -4.0 * I_h1234 * (I_h23 * (I_h123 + I_h234)) ! Wt*h1^3 > -4* (h1/h23)*(1+h1/h234) + Wt(3,4) = 4.0 * I_denom ! = 4.0*I_h1234 * I_h234 * I_h34 ! Wt*h1^3 < 4 * (h1/h234)*(h1/h34) + + Csys(1) = ((u(1) + (Wt(1,1) * (u(2)-u(1)))) + (Wt(2,1) * (u(3)-u(2)))) + (Wt(3,1) * (u(4)-u(3))) + Csys(2) = ((Wt(1,2) * (u(2)-u(1))) + (Wt(2,2) * (u(3)-u(2)))) + (Wt(3,2) * (u(4)-u(3))) + Csys(3) = ((Wt(1,3) * (u(2)-u(1))) + (Wt(2,3) * (u(3)-u(2)))) + (Wt(3,3) * (u(4)-u(3))) + Csys(4) = ((Wt(1,4) * (u(2)-u(1))) + (Wt(2,4) * (u(3)-u(2)))) + (Wt(3,4) * (u(4)-u(3))) + + ! endif ! End of non-uniform layer thickness branch. + +end subroutine end_value_h4 + +!> Value of PPM_H4_2019 reconstruction at a point in cell k [A] +real function f(this, k, x) + class(PPM_H4_2019), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + real :: xc ! Bounded version of x [nondim] + real :: du ! Difference across cell [A] + real :: a6 ! Collela and Woordward curvature parameter [A] + real :: u_a, u_b ! Two estimate of f [A] + real :: lmx ! 1 - x [nondim] + real :: wb ! Weight based on x [nondim] + + du = this%ur(k) - this%ul(k) + a6 = 3.0 * ( ( this%u_mean(k) - this%ul(k) ) + ( this%u_mean(k) - this%ur(k) ) ) + xc = max( 0., min( 1., x ) ) + lmx = 1.0 - xc + + ! This expression for u_a can overshoot u_r but is good for x<<1 + u_a = this%ul(k) + xc * ( du + a6 * lmx ) + ! This expression for u_b can overshoot u_l but is good for 1-x<<1 + u_b = this%ur(k) + lmx * ( - du + a6 * xc ) + + ! Since u_a and u_b are both side-bounded, using weights=0 or 1 will preserve uniformity + wb = 0.5 + sign(0.5, xc - 0.5 ) ! = 1 @ x=0, = 0 @ x=1 + f = ( ( 1. - wb ) * u_a ) + ( wb * u_b ) + +end function f + +!> Derivative of PPM_H4_2019 reconstruction at a point in cell k [A] +real function dfdx(this, k, x) + class(PPM_H4_2019), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + real :: xc ! Bounded version of x [nondim] + real :: du ! Difference across cell [A] + real :: a6 ! Collela and Woordward curvature parameter [A] + + du = this%ur(k) - this%ul(k) + a6 = 3.0 * ( ( this%u_mean(k) - this%ul(k) ) + ( this%u_mean(k) - this%ur(k) ) ) + xc = max( 0., min( 1., x ) ) + + dfdx = du + a6 * ( 2.0 * xc - 1.0 ) + +end function dfdx + +!> Average between xa and xb for cell k of a 1D PPM reconstruction [A] +real function average(this, k, xa, xb) + class(PPM_H4_2019), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: xa !< Start of averaging interval on element (0 to 1) + real, intent(in) :: xb !< End of averaging interval on element (0 to 1) + real :: xapxb ! A sum of fracional positions [nondim] + real :: mx, Ya, Yb, my ! Various fractional positions [nondim] + real :: u_a, u_b ! Values at xa and xb [A] + real :: xa2pxb2, xa2b2ab, Ya2b2ab ! Sums of squared fractional positions [nondim] + real :: a_L, a_R, u_c, a_c ! Values of the polynomial at various locations [A] + + mx = 0.5 * ( xa + xb ) + a_L = this%ul(k) + a_R = this%ur(k) + u_c = this%u_mean(k) + a_c = 0.5 * ( ( u_c - a_L ) + ( u_c - a_R ) ) ! a_6 / 6 + if (mx<0.5) then + ! This integration of the PPM reconstruction is expressed in distances from the left edge + xa2b2ab = (xa*xa+xb*xb)+xa*xb + average = a_L + ( ( a_R - a_L ) * mx & + + a_c * ( 3. * ( xb + xa ) - 2.*xa2b2ab ) ) + else + ! This integration of the PPM reconstruction is expressed in distances from the right edge + Ya = 1. - xa + Yb = 1. - xb + my = 0.5 * ( Ya + Yb ) + Ya2b2ab = (Ya*Ya+Yb*Yb)+Ya*Yb + average = a_R + ( ( a_L - a_R ) * my & + + a_c * ( 3. * ( Yb + Ya ) - 2.*Ya2b2ab ) ) + endif + +end function average + +!> Deallocate the PPM_H4_2019 reconstruction +subroutine destroy(this) + class(PPM_H4_2019), intent(inout) :: this !< This reconstruction + + deallocate( this%u_mean, this%ul, this%ur ) + +end subroutine destroy + +!> Checks the PPM_H4_2019 reconstruction for consistency +logical function check_reconstruction(this, h, u) + class(PPM_H4_2019), intent(in) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k + + check_reconstruction = .false. + + ! Simply checks the internal copy of "u" is exactly equal to "u" + do k = 1, this%n + if ( abs( this%u_mean(k) - u(k) ) > 0. ) check_reconstruction = .true. + enddo + + ! If (u - ul) has the opposite sign from (ur - u), then this cell has an interior extremum + do k = 1, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ur(k) - this%u_mean(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of right edges, w.r.t. the cell means + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%u_mean(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. the cell means + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%u_mean(k-1) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of right edges, w.r.t. this cell mean and the next cell left edge + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%ul(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. this cell mean and the previous cell right edge + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%ur(k-1) ) < 0. ) check_reconstruction = .true. + enddo + +end function check_reconstruction + +!> Runs PPM_H4_2019 reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(PPM_H4_2019), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + if (verbose) write(stdout,'(a)') 'PPM_H4_2019:unit_tests testing with linear fn' + + call this%init(5) + call test%test( this%n /= 5, 'Setting number of levels') + allocate( um(5), ul(5), ur(5), ull(5), urr(5) ) + + ! Straight line, f(x) = x , or f(K) = 2*K + call this%reconstruct( (/2.,2.,2.,2.,2./), (/1.,3.,5.,7.,9./) ) + call test%real_arr(5, this%u_mean, (/1.,3.,5.,7.,9./), 'Setting cell values') + call test%real_arr(5, this%ul, (/1.,2.,4.,6.,9./), 'Left edge values', robits=2) + call test%real_arr(5, this%ur, (/1.,4.,6.,8.,9./), 'Right edge values') + do k = 1, 5 + um(k) = this%u_mean(k) + enddo + call test%real_arr(5, um, (/1.,3.,5.,7.,9./), 'Return cell mean') + + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, this%ul, 'Evaluation on left edge') + call test%real_arr(5, um, (/1.,3.,5.,7.,9./), 'Evaluation in center') + call test%real_arr(5, ur, this%ur, 'Evaluation on right edge') + + do k = 1, 5 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + call test%real_arr(5, ul, (/0.,2.,2.,2.,0./), 'dfdx on left edge', robits=3) + call test%real_arr(5, um, (/0.,2.,2.,2.,0./), 'dfdx in center', robits=2) + call test%real_arr(5, ur, (/0.,2.,2.,2.,0./), 'dfdx on right edge', robits=6) + + do k = 1, 5 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + call test%real_arr(5, um, (/1.,3.25,5.25,7.25,9./), 'Return interval average') + + if (verbose) write(stdout,'(a)') 'PPM_H4_2019:unit_tests testing with parabola' + + ! x = 3 i i=0 at origin + ! f(x) = x^2 / 3 = 3 i^2 + ! f[i] = [ ( 3 i )^3 - ( 3 i - 3 )^3 ] i=1,2,3,4,5 + ! means: 1, 7, 19, 37, 61 + ! edges: 0, 3, 12, 27, 48, 75 + call this%reconstruct( (/3.,3.,3.,3.,3./), (/1.,7.,19.,37.,61./) ) + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, (/1.,3.,12.,27.,61./), 'Return left edge', robits=2) + call test%real_arr(5, ur, (/1.,12.,27.,48.,61./), 'Return right edge', robits=1) + + call this%destroy() + deallocate( um, ul, ur, ull, urr ) + + unit_tests = test%summarize('PPM_H4_2019:unit_tests') + +end function unit_tests + +!> \namespace recon1d_ppm_c4_2019 +!! + +end module Recon1d_PPM_H4_2019 diff --git a/src/ALE/Recon1d_PPM_hybgen.F90 b/src/ALE/Recon1d_PPM_hybgen.F90 new file mode 100644 index 0000000000..343da5d8e8 --- /dev/null +++ b/src/ALE/Recon1d_PPM_hybgen.F90 @@ -0,0 +1,453 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Piecewise Parabolic Method 1D reconstruction following Colella and Woodward, 1984 +!! +!! This implementation of PPM follows Colella and Woodward, 1984 \cite colella1984, with +!! cells resorting to PCM for extrema including first and last cells in column. The algorithm was +!! first ported from Hycom as hybgen_ppm_coefs() in the mom_hybgen_remap module. This module is +!! a refactor to facilitate more complete testing and evaluation. +!! +!! The mom_hybgen_remap.hybgen_ppm_coefs() function (reached with "PPM_HYGEN"), +!! regrid_edge_values.edge_values_explicit_h4cw() function followed by ppm_functions.ppm_reconstruction() +!! (reached with "PPM_CW"), are equivalent. Similarly recon1d_ppm_hybgen (this implementation) is equivalent also. +module Recon1d_PPM_hybgen + +use Recon1d_type, only : testing +use Recon1d_PPM_CW, only : PPM_CW + +implicit none ; private + +public PPM_hybgen, testing + +!> PPM reconstruction following White and Adcroft, 2008 +!! +!! Implemented by extending recon1d_ppm_cwk. +!! +!! The source for the methods ultimately used by this class are: +!! - init() -> recon1d_ppm_cw.init() +!! - reconstruct() *locally defined +!! - average() *locally defined but calls recon1d_ppm_cw.average() +!! - f() -> recon1d_ppm_cw.f() +!! - dfdx() -> recon1d_ppm_cw.dfdx() +!! - check_reconstruction() *locally defined +!! - unit_tests() -> recon1d_ppm_cw.unit_tests() +!! - destroy() -> recon1d_ppm_cw.destroy() +!! - remap_to_sub_grid() -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> init() +!! - reconstruct_parent() -> reconstruct() +type, extends (PPM_CW) :: PPM_hybgen + +contains + !> Implementation of the PPM_hybgen reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of the PPM_hybgen average over an interval [A] + procedure :: average => average + !> Implementation of check reconstruction for the PPM_hybgen reconstruction + procedure :: check_reconstruction => check_reconstruction + !> Implementation of unit tests for the PPM_hybgen reconstruction + procedure :: unit_tests => unit_tests + +end type PPM_hybgen + +contains + +!> Calculate a 1D PPM_hybgen reconstruction based on h(:) and u(:) +!! +!! First pass: hybgen_ppm_coefs() computes initial edge estimates with CW monotonicity. +!! Second pass: applies OM4-era bound_edge_values() and check_discontinuous_edge_values(), +!! then the standard CW PPM limiter (post-2018 expressions, answer_date=99991231). +!! This reproduces bit-for-bit the behavior of the old-style PPM_HYBGEN scheme. +subroutine reconstruct(this, h, u) + class(PPM_hybgen), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k, n + real :: ppoly_e(this%n, 2) ! PPM edge values [A] + real :: u_l, u_c, u_r ! Left, center, right cell averages [A] + real :: edge_l, edge_r ! Left and right edge values [A] + real :: expr1, expr2 ! Temporary expressions [A2] + + n = this%n + + ! First pass: compute initial edge estimates using the hybgen algorithm with CW monotonicity + call hybgen_ppm_coefs(u, h, ppoly_e, n, this%h_neglect) + + ! Second pass: apply OM4-era PPM limiters (post-2018 answers via answer_date=99991231) + call bound_edge_values(n, h, u, ppoly_e, this%h_neglect, answer_date=99991231) + call check_discontinuous_edge_values(n, u, ppoly_e) + + ! Apply the standard CW PPM limiter (Colella & Woodward, JCP 84) on interior cells + do k = 2, n-1 + u_l = u(k-1) ; u_c = u(k) ; u_r = u(k+1) + edge_l = ppoly_e(k,1) ; edge_r = ppoly_e(k,2) + if ( (u_r - u_c)*(u_c - u_l) <= 0.0 ) then + edge_l = u_c ; edge_r = u_c + else + expr1 = 3.0 * (edge_r - edge_l) * ( (u_c - edge_l) + (u_c - edge_r) ) + expr2 = (edge_r - edge_l) * (edge_r - edge_l) + if ( expr1 > expr2 ) then + edge_l = u_c + 2.0 * ( u_c - edge_r ) + edge_l = max( min( edge_l, max(u_l, u_c) ), min(u_l, u_c) ) + elseif ( expr1 < -expr2 ) then + edge_r = u_c + 2.0 * ( u_c - edge_l ) + edge_r = max( min( edge_r, max(u_r, u_c) ), min(u_r, u_c) ) + endif + endif + !### The 1.e-60 needs to have units of [A], so this is dimensionally inconsistent. + if ( abs( edge_r - edge_l ) < max(1.e-60, epsilon(u_c)*abs(u_c)) ) then + edge_l = u_c ; edge_r = u_c + endif + ppoly_e(k,1) = edge_l ; ppoly_e(k,2) = edge_r + enddo + ! Boundary cells are PCM + ppoly_e(1,:) = u(1) ; ppoly_e(n,:) = u(n) + + do k = 1, n + this%ul(k) = ppoly_e(k, 1) + this%ur(k) = ppoly_e(k, 2) + this%u_mean(k) = u(k) + enddo + +end subroutine reconstruct + +!> Average between xa and xb for cell k of a PPM_hybgen reconstruction [A] +!! +!! Calls the parent PPM_CW average and then clamps the result to [min(ul,ur), max(ul,ur)]. +!! This replicates the force_bounds_in_subcell behavior of the equivalent old-style PPM_HYBGEN +!! scheme. +real function average(this, k, xa, xb) + class(PPM_hybgen), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: xa !< Start of averaging interval on element (0 to 1) + real, intent(in) :: xb !< End of averaging interval on element (0 to 1) + real :: u_lo, u_hi ! Bounds on the sub-cell average given by the edge values [A] + + average = this%PPM_CW%average(k, xa, xb) + u_lo = min(this%ul(k), this%ur(k)) + u_hi = max(this%ul(k), this%ur(k)) + average = max(u_lo, min(u_hi, average)) + +end function average + +!> Checks the PPM_hybgen reconstruction for consistency +logical function check_reconstruction(this, h, u) + class(PPM_hybgen), intent(in) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k + + check_reconstruction = .false. + + ! Simply checks the internal copy of "u" is exactly equal to "u" + do k = 1, this%n + if ( abs( this%u_mean(k) - u(k) ) > 0. ) check_reconstruction = .true. + enddo + + ! If (u - ul) has the opposite sign from (ur - u), then this cell has an interior extremum + do k = 1, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ur(k) - this%u_mean(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! The following consistency checks would fail for this implementation of PPM CW, + ! due to round off in the final limiter violating the monotonicity of edge values, + ! but actually passes due to the second pass of the limiters with explicit bounding. + ! i.e. This implementation cheats! + + ! Check bounding of right edges, w.r.t. the cell means + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%u_mean(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. the cell means + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%u_mean(k-1) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of right edges, w.r.t. this cell mean and the next cell left edge + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%ul(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. this cell mean and the previous cell right edge + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%ur(k-1) ) < 0. ) check_reconstruction = .true. + enddo + +end function check_reconstruction + +!> Runs PPM_hybgen reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(PPM_hybgen), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + if (verbose) write(stdout,'(a)') 'PPM_hybgen:unit_tests testing with linear fn' + + call this%init(5) + call test%test( this%n /= 5, 'Setting number of levels') + allocate( um(5), ul(5), ur(5), ull(5), urr(5) ) + + ! Straight line, f(x) = x , or f(K) = 2*K + call this%reconstruct( (/2.,2.,2.,2.,2./), (/1.,4.,7.,10.,13./) ) + call test%real_arr(5, this%u_mean, (/1.,4.,7.,10.,13./), 'Setting cell values') + ! Without PLM extrapolation we get l(2)=2 and r(4)=12 due to PLM=0 in boundary cells. -AJA + call test%real_arr(5, this%ul, (/1.,1.,5.5,8.5,13./), 'Left edge values') + call test%real_arr(5, this%ur, (/1.,5.5,8.5,13.,13./), 'Right edge values') + + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, this%ul, 'Evaluation on left edge') + call test%real_arr(5, um, (/1.,4.375,7.,9.625,13./), 'Evaluation in center') + call test%real_arr(5, ur, this%ur, 'Evaluation on right edge') + + do k = 1, 5 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + ! Most of these values are affected by the PLM boundary cells + call test%real_arr(5, ul, (/0.,0.,3.,9.,0./), 'dfdx on left edge') + call test%real_arr(5, um, (/0.,4.5,3.,4.5,0./), 'dfdx in center') + call test%real_arr(5, ur, (/0.,9.,3.,0.,0./), 'dfdx on right edge') + + do k = 1, 5 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + ! Most of these values are affected by the PLM boundary cells + call test%real_arr(5, um, (/1.,4.84375,7.375,10.28125,13./), 'Return interval average') + + if (verbose) write(stdout,'(a)') 'PPM_hybgen:unit_tests testing with parabola' + + ! x = 2 i i=0 at origin + ! f(x) = 3/4 x^2 = (2 i)^2 + ! f[i] = 3/4 ( 2 i - 1 )^2 on centers + ! f[I] = 3/4 ( 2 I )^2 on edges + ! f[i] = 1/8 [ x^3 ] for means + ! edges: 0, 1, 12, 27, 48, 75 + ! means: 1, 7, 19, 37, 61 + ! cengters: 0.75, 6.75, 18.75, 36.75, 60.75 + call this%reconstruct( (/2.,2.,2.,2.,2./), (/1.,7.,19.,37.,61./) ) + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, (/1.,1.,12.,27.,61./), 'Return left edge') + call test%real_arr(5, um, (/1.,7.25,18.75,34.5,61./), 'Return center') + call test%real_arr(5, ur, (/1.,12.,27.,57.,61./), 'Return right edge') + + ! x = 3 i i=0 at origin + ! f(x) = x^2 / 3 = 3 i^2 + ! f[i] = [ ( 3 i )^3 - ( 3 i - 3 )^3 ] i=1,2,3,4,5 + ! means: 1, 7, 19, 37, 61 + ! edges: 0, 3, 12, 27, 48, 75 + call this%reconstruct( (/3.,3.,3.,3.,3./), (/1.,7.,19.,37.,61./) ) + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, (/1.,1.,12.,27.,61./), 'Return left edge') + call test%real_arr(5, ur, (/1.,12.,27.,57.,61./), 'Return right edge') + + call this%destroy() + deallocate( um, ul, ur, ull, urr ) + + unit_tests = test%summarize('PPM_hybgen:unit_tests') + +end function unit_tests + +!> \namespace recon1d_ppm_hybgen +!! + +! ============================================================================ +! Private subroutines copied from phased-out modules to avoid dependencies. +! These reproduce bit-for-bit the results of the original functions they replace. +! ============================================================================ + +!> Set up edge values for PPM reconstruction using the hybgen (HYCOM) algorithm. +!! +!! Copied from MOM_hybgen_remap.hybgen_ppm_coefs(). +!! Original code by Tim Campbell (MSU, 2002) and Alan Wallcraft (NRL, 2007). +subroutine hybgen_ppm_coefs(s, h_src, edges, nk, thin, PCM_lay) + integer, intent(in) :: nk !< The number of input layers + real, intent(in) :: s(nk) !< The input scalar fields [A] + real, intent(in) :: h_src(nk) !< The input grid layer thicknesses [H ~> m or kg m-2] + real, intent(out) :: edges(nk,2) !< The PPM interpolation edge values [A] + real, intent(in) :: thin !< A negligible layer thickness [H ~> m or kg m-2] + logical, optional, intent(in) :: PCM_lay(nk) !< If true for a layer, use PCM remapping + + real :: dp(nk) ! Input grid layer thicknesses, but with a minimum thickness given by thin [H ~> m or kg m-2] + logical :: PCM_layer(nk) ! True for layers that should use PCM remapping + 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] + real :: sck ! Scalar differences across a cell [A] + real :: as(nk) ! Scalar field difference across each cell [A] + real :: al(nk), ar(nk) ! Scalar field at the left and right edges of a cell [A] + real :: h112(nk+1), h122(nk+1) ! Combinations of thicknesses [H ~> m or kg m-2] + real :: I_h12(nk+1) ! Inverses of combinations of thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: h2_h123(nk) ! A ratio of a layer thickness to the sum of 3 adjacent thicknesses [nondim] + real :: I_h0123(nk) ! Inverse of the sum of 4 adjacent thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: h01_h112(nk+1) ! A ratio of sums of adjacent thicknesses [nondim] + real :: h23_h122(nk+1) ! A ratio of sums of adjacent thicknesses [nondim] + integer :: k + + do k=1,nk ; dp(k) = max(h_src(k), thin) ; enddo + + if (present(PCM_lay)) then + do k=1,nk ; PCM_layer(k) = (PCM_lay(k) .or. dp(k) <= thin) ; enddo + else + do k=1,nk ; PCM_layer(k) = (dp(k) <= thin) ; enddo + endif + + do k=2,nk + h112(K) = 2.*dp(k-1) + dp(k) + h122(K) = dp(k-1) + 2.*dp(k) + I_h12(K) = 1.0 / (dp(k-1) + dp(k)) + enddo + do k=2,nk-1 + h2_h123(k) = dp(k) / (dp(k) + (dp(k-1)+dp(k+1))) + enddo + do K=3,nk-1 + I_h0123(K) = 1.0 / ((dp(k-2) + dp(k-1)) + (dp(k) + dp(k+1))) + h01_h112(K) = (dp(k-2) + dp(k-1)) / (2.0*dp(k-1) + dp(k)) + h23_h122(K) = (dp(k) + dp(k+1)) / (dp(k-1) + 2.0*dp(k)) + enddo + + as(1) = 0. + do k=2,nk-1 + if (PCM_layer(k)) then + as(k) = 0.0 + else + slk = s(k)-s(k-1) + srk = s(k+1)-s(k) + if (slk*srk > 0.) then + sck = h2_h123(k)*( h112(K)*srk*I_h12(K+1) + h122(K+1)*slk*I_h12(K) ) + as(k) = sign(min(abs(2.0*slk), abs(sck), abs(2.0*srk)), sck) + else + as(k) = 0. + endif + endif + enddo + as(nk) = 0. + al(1) = s(1) + ar(1) = s(1) + al(2) = s(1) + do K=3,nk-1 + al(k) = (dp(k)*s(k-1) + dp(k-1)*s(k)) * I_h12(K) & + + I_h0123(K)*( 2.*dp(k)*dp(k-1)*I_h12(K)*(s(k)-s(k-1)) * & + ( h01_h112(K) - h23_h122(K) ) & + + (dp(k)*as(k-1)*h23_h122(K) - dp(k-1)*as(k)*h01_h112(K)) ) + ar(k-1) = al(k) + enddo + ar(nk-1) = s(nk) + al(nk) = s(nk) + ar(nk) = s(nk) + do k=2,nk-1 + if ((PCM_layer(k)) .or. ((s(k+1)-s(k))*(s(k)-s(k-1)) <= 0.)) then + al(k) = s(k) + ar(k) = s(k) + else + da = ar(k)-al(k) + a6 = 6.0*s(k) - 3.0*(al(k)+ar(k)) + if (da*a6 > da*da) then + al(k) = 3.0*s(k) - 2.0*ar(k) + elseif (da*a6 < -da*da) then + ar(k) = 3.0*s(k) - 2.0*al(k) + endif + endif + enddo + do k=1,nk + edges(k,1) = al(k) + edges(k,2) = ar(k) + enddo + +end subroutine hybgen_ppm_coefs + +!> Bound edge values by the averages of the neighboring cells. +!! +!! Copied from regrid_edge_values.bound_edge_values(). +subroutine bound_edge_values(N, h, u, edge_val, h_neglect, answer_date) + integer, intent(in) :: N !< Number of cells + real, dimension(N), intent(in) :: h !< Cell widths [H] + real, dimension(N), intent(in) :: u !< Cell averages [A] + real, dimension(N,2), intent(inout) :: edge_val !< Edge values [A] + real, intent(in) :: h_neglect !< A negligibly small width [H] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use + + real :: sigma_l, sigma_c, sigma_r + real :: slope_x_h + logical :: use_2018_answers + integer :: k, km1, kp1 + + use_2018_answers = .true. ; if (present(answer_date)) use_2018_answers = (answer_date < 20190101) + + do k = 1,N + km1 = max(1,k-1) ; kp1 = min(k+1,N) + slope_x_h = 0.0 + if (use_2018_answers) then + 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 ) + if ( (sigma_l * sigma_r) > 0.0 ) & + slope_x_h = 0.5 * h(k) * sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) + elseif ( ((h(km1) + h(kp1)) + 2.0*h(k)) > 0.0 ) then + sigma_l = ( u(k) - u(km1) ) + sigma_c = ( u(kp1) - u(km1) ) * ( h(k) / ((h(km1) + h(kp1)) + 2.0*h(k)) ) + sigma_r = ( u(kp1) - u(k) ) + if ( (sigma_l * sigma_r) > 0.0 ) & + slope_x_h = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) + endif + if ( (u(km1)-edge_val(k,1)) * (edge_val(k,1)-u(k)) < 0.0 ) then + edge_val(k,1) = u(k) - sign( min( abs(slope_x_h), abs(edge_val(k,1)-u(k)) ), slope_x_h ) + endif + if ( (u(kp1)-edge_val(k,2)) * (edge_val(k,2)-u(k)) < 0.0 ) then + edge_val(k,2) = u(k) + sign( min( abs(slope_x_h), abs(edge_val(k,2)-u(k)) ), slope_x_h ) + endif + edge_val(k,1) = max( min( edge_val(k,1), max(u(km1), u(k)) ), min(u(km1), u(k)) ) + edge_val(k,2) = max( min( edge_val(k,2), max(u(kp1), u(k)) ), min(u(kp1), u(k)) ) + enddo + +end subroutine bound_edge_values + +!> Replace discontinuous edge values with their average when not monotonic. +!! +!! Copied from regrid_edge_values.check_discontinuous_edge_values(). +subroutine check_discontinuous_edge_values(N, u, edge_val) + integer, intent(in) :: N !< Number of cells + real, dimension(N), intent(in) :: u !< Cell averages [A] + real, dimension(N,2), intent(inout) :: edge_val !< Edge values [A] + + integer :: k + real :: u0_avg + + do k = 1,N-1 + if ( (edge_val(k+1,1) - edge_val(k,2)) * (u(k+1) - u(k)) < 0.0 ) then + u0_avg = 0.5 * ( edge_val(k,2) + edge_val(k+1,1) ) + u0_avg = max( min( u0_avg, max(u(k), u(k+1)) ), min(u(k), u(k+1)) ) + edge_val(k,2) = u0_avg + edge_val(k+1,1) = u0_avg + endif + enddo + +end subroutine check_discontinuous_edge_values + +end module Recon1d_PPM_hybgen diff --git a/src/ALE/Recon1d_type.F90 b/src/ALE/Recon1d_type.F90 new file mode 100644 index 0000000000..505adc6c2e --- /dev/null +++ b/src/ALE/Recon1d_type.F90 @@ -0,0 +1,397 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> A generic type for vertical 1D reconstructions +module Recon1d_type + +use numerical_testing_type, only : testing + +implicit none ; private + +public Recon1d +public testing + +!> The base class for implementations of 1D reconstructions +type, abstract :: Recon1d + + integer :: n = 0 !< Number of cells in column + real, allocatable, dimension(:) :: u_mean !< Cell mean [A] + real :: h_neglect = 0. !< A negligibly small width used in cell reconstructions in the same units as h [H] + real :: x_tolerance = 1. * epsilon(1.) !< Solver tolerance for x in element (0,1) [nondim] + logical :: check = .false. !< If true, enable some consistency checking + + logical :: debug = .false. !< If true, dump info as calculations are made (do not enable) +contains + + ! The following functions/subroutines are deferred and must be provided specifically by each scheme + + !> Deferred implementation of initialization + procedure(i_init), deferred :: init + !> Deferred implementation of reconstruction function + procedure(i_reconstruct), deferred :: reconstruct + !> Deferred implementation of the average over an interval + procedure(i_average), deferred :: average + !> Deferred implementation of evaluating the reconstruction at a point + procedure(i_f), deferred :: f + !> Deferred implementation of the derivative of the reconstruction at a point + procedure(i_dfdx), deferred :: dfdx + !> Deferred implementation of check_reconstruction + !! + !! Returns True if a check fails. Returns False if all checks pass. + !! Checks are about internal, or inferred, state for arbitrary inputs. + !! Checks should cover all the expected properties of a reconstruction. + procedure(i_check_reconstruction), deferred :: check_reconstruction + !> Deferred implementation of unit tests for the reconstruction + !! + !! Returns True if a test fails. Returns False if all tests pass. + !! Tests in unit_tests() are usually checks against known (e.g. analytic) solutions. + procedure(i_unit_tests), deferred :: unit_tests + !> Deferred implementation of deallocation + procedure(i_destroy), deferred :: destroy + + ! The following functions/subroutines are shared across all reconstructions and provided by this module + ! unless replaced for the purpose of optimization + + !> Solves for x such that f(x)=t + procedure :: x => x + !> Remaps the column to subgrid h_sub + procedure :: remap_to_sub_grid => remap_to_sub_grid + !> Set debugging + procedure :: set_debug => a_set_debug + + ! The following functions usually point to the same implementation as above but + ! for derived secondary children these allow invocation of the parent class function. + + !> Second interface to init(), used to reach the primary class if derived from a primary implementation + procedure(i_init_parent), deferred :: init_parent + !> Second interface to reconstruct(), used to reach the primary class if derived from a primary implementation + procedure(i_reconstruct_parent), deferred :: reconstruct_parent + +end type Recon1d + +interface + + !> Initialize a 1D reconstruction for n cells + subroutine i_init(this, n, h_neglect, check) + import :: Recon1d + class(Recon1d), intent(out) :: this !< This reconstruction + integer, intent(in) :: n !< Number of cells in this column + real, optional, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H] + logical, optional, intent(in) :: check !< If true, enable some consistency checking + end subroutine i_init + + !> Calculate a 1D reconstructions based on h(:) and u(:) + subroutine i_reconstruct(this, h, u) + import :: Recon1d + class(Recon1d), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness), typically in [H] + real, intent(in) :: u(*) !< Cell mean values [A] + end subroutine i_reconstruct + + !> Average between xa and xb for cell k of a 1D reconstruction [A] + !! + !! It is assumed that 0<=xa<=1, 0<=xb<=1, and xa<=xb + real function i_average(this, k, xa, xb) + import :: Recon1d + class(Recon1d), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: xa !< Start of averaging interval on element (0 to 1) + real, intent(in) :: xb !< End of averaging interval on element (0 to 1) + end function i_average + + !> Point-wise value of reconstruction [A] + !! + !! The function is only valid for 0 <= x <= 1. x is effectively clipped to this range. + real function i_f(this, k, x) + import :: Recon1d + class(Recon1d), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + end function i_f + + !> Point-wise value of derivative reconstruction [A] + !! + !! The function is only valid for 0 <= x <= 1. x is effectively clipped to this range. + real function i_dfdx(this, k, x) + import :: Recon1d + class(Recon1d), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + end function i_dfdx + + !> Point-wise solver for x: f(x)=t [nondim] + !! + !! The function solves for the non-dimensional position x within the cell where + !! the reconstruction f(x)=t. The solver returns x=0 or x=1 if the target, t, + !! is outside of the cell. + real function i_x(this, k, t) + import :: Recon1d + class(Recon1d), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: t !< Value to solve for [A] + end function i_x + + !> Returns true if some inconsistency is detected, false otherwise + !! + !! The nature of "consistency" is defined by the implementations + !! and might be no-ops. + logical function i_check_reconstruction(this, h, u) + import :: Recon1d + class(Recon1d), intent(in) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness), typically in [H] + real, intent(in) :: u(*) !< Cell mean values [A] + end function i_check_reconstruction + + !> Deallocate a 1D reconstruction + subroutine i_destroy(this) + import :: Recon1d + class(Recon1d), intent(inout) :: this !< This reconstruction + end subroutine i_destroy + + !> Second interface to init(), or to parent init() + subroutine i_init_parent(this, n, h_neglect, check) + import :: Recon1d + class(Recon1d), intent(out) :: this !< This reconstruction + integer, intent(in) :: n !< Number of cells in this column + real, optional, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H] + logical, optional, intent(in) :: check !< If true, enable some consistency checking + end subroutine i_init_parent + + !> Second interface to reconstruct(), or to parent reconstruct() + subroutine i_reconstruct_parent(this, h, u) + import :: Recon1d + class(Recon1d), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness), typically in [H] + real, intent(in) :: u(*) !< Cell mean values [A] + end subroutine i_reconstruct_parent + + !> Runs reconstruction unit tests and returns True for any fails, False otherwise + !! + !! Assumes single process/thread context + logical function i_unit_tests(this, verbose, stdout, stderr) + import :: Recon1d + class(Recon1d), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + end function i_unit_tests + +end interface + +contains + +!> Solve for x such that f(x)=t +!! +!! This solver uses bounded Newton-Raphson method with a fixed +!! number of iterations +real function x(this, k, t) + class(Recon1d), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: t !< Value to solve for [A] + real :: xl, xr, xo ! Left/right bounds and guess [nondim] + real :: fl, fr ! Left right values [A] + real :: slp ! Difference across cell or derivative wrt nondim x [A] + real :: f_at_x ! Value at current x [A] + integer :: iter + + x = 0.5 ! Fall back for special conditions + fl = this%f(k, 0.) + fr = this%f(k, 1.) + slp = fr - fl + if ( ( fl - t ) * ( t - fr ) > 0. ) then + ! t is inside the range fl..fr + xl = 0. + xr = 1. + xo = ( t - this%f(k, 0.) ) / slp ! First guess by regula falsi + f_at_x = this%f(k, xo) + do iter = 1,10 + slp = this%dfdx(k, xo) + x = xo - ( f_at_x - t ) / slp ! Newton-Raphson step + if ( x < xl ) x = 0.5 * ( xl + xo ) ! Replace with bi-section + if ( x > xr ) x = 0.5 * ( xr + xo ) ! Replace with bi-section + f_at_x = this%f(k, x) + if ( abs(f_at_x - t) <= 0. .or. abs(x - xo) < this%x_tolerance ) return + if ( f_at_x < t ) xl = x ! Replace left bound + if ( f_at_x > t ) xr = x ! Replace right bound + xo = x + enddo + elseif ( abs(slp) > 0. ) then + slp = sign(1., slp) + ! if t>u_mean & slp=1 then x=1 + ! if tu_mean & slp=-1 then x=0 + ! if t 0. ) slp = sign(1., slp) + ! if t>u_mean & slp=1 then x=1 + ! if tu_mean & slp=-1 then x=0 + ! if t 0. ) x = 0.5 + slp * sign(0.5, t - this%u_mean(k)) + endif +end function x + +!> Remaps the column to subgrid h_sub +!! +!! It is assumed that h_sub is a perfect sub-grid of h0, meaning each h0 cell +!! can be constructed by joining a contiguous set of h_sub cells. The integer +!! indices isrc_start, isrc_end, isub_src provide this mapping, and are +!! calculated in MOM_remapping +subroutine remap_to_sub_grid(this, h0, u0, n1, h_sub, & + isrc_start, isrc_end, isrc_max, isub_src, & + u_sub, uh_sub, u02_err) + class(Recon1d), intent(in) :: this !< 1-D reconstruction type + real, intent(in) :: h0(*) !< Source grid widths (size n0) [H] + real, intent(in) :: u0(*) !< Source grid widths (size n0) [H] + integer, intent(in) :: n1 !< Number of cells in target grid + real, intent(in) :: h_sub(*) !< Overlapping sub-cell thicknesses, h_sub [H] + integer, intent(in) :: isrc_start(*) !< Index of first sub-cell within each source cell + integer, intent(in) :: isrc_end(*) !< Index of last sub-cell within each source cell + integer, intent(in) :: isrc_max(*) !< Index of thickest sub-cell within each source cell + integer, intent(in) :: isub_src(*) !< Index of source cell for each sub-cell + real, intent(out) :: u_sub(*) !< Sub-cell cell averages (size n1) [A] + real, intent(out) :: uh_sub(*) !< Sub-cell cell integrals (size n1) [A H] + real, intent(out) :: u02_err !< Integrated reconstruction error estimates [A H] + ! Local variables + integer :: i_sub ! Index of sub-cell + integer :: i0 ! Index into h0(1:n0), source column + integer :: i_max ! Used to record which sub-cell is the largest contribution of a source cell + real :: dh_max ! Used to record which sub-cell is the largest contribution of a source cell [H] + real :: xa, xb ! Non-dimensional position within a source cell (0..1) [nondim] + real :: dh ! The width of the sub-cell [H] + real :: duh ! The total amount of accumulated stuff (u*h) [A H] + real :: dh0_eff ! Running sum of source cell thickness [H] + integer :: i0_last_thick_cell, n0 +! real :: u0_min(this%n), u0_max(this%n) ! Min/max of u0 for each source cell [A] +! real :: ul,ur ! Left/right edge values [A] + + n0 = this%n + + i0_last_thick_cell = 0 + do i0 = 1, n0 +! ul = this%f(i0, 0.) +! ur = this%f(i0, 1.) +! u0_min(i0) = min(ul, ur) +! u0_max(i0) = max(ul, ur) + if (h0(i0)>0.) i0_last_thick_cell = i0 + enddo + + ! Loop over each sub-cell to calculate average/integral values within each sub-cell. + ! Uses: h_sub, isub_src, h0_eff + ! Sets: u_sub, uh_sub + xa = 0. + dh0_eff = 0. + u02_err = 0. + do i_sub = 1, n0+n1 + + ! Sub-cell thickness from loop above + dh = h_sub(i_sub) + + ! Source cell + i0 = isub_src(i_sub) + + ! Evaluate average and integral for sub-cell i_sub. + ! Integral is over distance dh but expressed in terms of non-dimensional + ! positions with source cell from xa to xb (0 <= xa <= xb <= 1). + dh0_eff = dh0_eff + dh ! Cumulative thickness within the source cell + if (h0(i0)>0.) then + xb = dh0_eff / h0(i0) ! This expression yields xa <= xb <= 1.0 + xb = min(1., xb) ! This is only needed when the total target column is wider than the source column + u_sub(i_sub) = this%average( i0, xa, xb ) + else ! Vanished cell + xb = 1. + u_sub(i_sub) = u0(i0) + endif +! u_sub(i_sub) = max( u_sub(i_sub), u0_min(i0) ) +! u_sub(i_sub) = min( u_sub(i_sub), u0_max(i0) ) + uh_sub(i_sub) = dh * u_sub(i_sub) + + if (isub_src(i_sub+1) /= i0) then + ! If the next sub-cell is in a different source cell, reset the position counters + dh0_eff = 0. + xa = 0. + else + xa = xb ! Next integral will start at end of last + endif + + enddo + i_sub = n0+n1+1 + ! Sub-cell thickness from loop above + dh = h_sub(i_sub) + ! Source cell + i0 = isub_src(i_sub) + + ! Evaluate average and integral for sub-cell i_sub. + ! Integral is over distance dh but expressed in terms of non-dimensional + ! positions with source cell from xa to xb (0 <= xa <= xb <= 1). + dh0_eff = dh0_eff + dh ! Cumulative thickness within the source cell + if (h0(i0)>0.) then + xb = dh0_eff / h0(i0) ! This expression yields xa <= xb <= 1.0 + xb = min(1., xb) ! This is only needed when the total target column is wider than the source column + u_sub(i_sub) = this%average( i0, xa, xb ) + else ! Vanished cell + xb = 1. + u_sub(i_sub) = u0(i0) + endif +! u_sub(i_sub) = max( u_sub(i_sub), u0_min(i0) ) +! u_sub(i_sub) = min( u_sub(i_sub), u0_max(i0) ) + uh_sub(i_sub) = dh * u_sub(i_sub) + + ! Loop over each source cell substituting the integral/average for the thickest sub-cell (within + ! the source cell) with the residual of the source cell integral minus the other sub-cell integrals + ! aka a genius algorithm for accurate conservation when remapping from Robert Hallberg (\@Hallberg-NOAA). + ! Uses: i0_last_thick_cell, isrc_max, h_sub, isrc_start, isrc_end, uh_sub, u0, h0 + ! Updates: uh_sub + do i0 = 1, i0_last_thick_cell + i_max = isrc_max(i0) + dh_max = h_sub(i_max) + if (dh_max > 0.) then + ! duh will be the sum of sub-cell integrals within the source cell except for the thickest sub-cell. + duh = 0. + do i_sub = isrc_start(i0), isrc_end(i0) + if (i_sub /= i_max) duh = duh + uh_sub(i_sub) + enddo + uh_sub(i_max) = u0(i0)*h0(i0) - duh + u02_err = u02_err + max( abs(uh_sub(i_max)), abs(u0(i0)*h0(i0)), abs(duh) ) + endif + enddo + + ! This should not generally be used + if (this%check) then + if ( this%check_reconstruction(h0, u0) ) stop 910 ! A debugger is required to understand why this failed + endif + +end subroutine remap_to_sub_grid + +!> Turns on debugging +subroutine a_set_debug(this) + class(Recon1d), intent(inout) :: this !< 1-D reconstruction type + + this%debug = .true. + +end subroutine a_set_debug + +!> \namespace recon1d_type +!! +!! \section section_recon1d_type Generic vertical reconstruction type +!! +!! A class to describe generic reconstruction in 1-D. This module has no implementations +!! but defines the interfaces for members that implement a reconstruction. +!! +!! e.g. a chain of derived reconstructions might look like +!! Recon1d_type <- Recond1d_XYZ <- Recon1d_XYZ_v2 +!! where +!! Recon1d_type - defines the interfaces (this module) +!! Recon1d_XYZ - extends Recon1d_type, implements the XYZ reconstruction in reconstruct(), +!! and reconstruc_parent() -> reconstruct() of the same Recon1d_XYZ module +!! Recon1d_XYZ_v2 - implements a slight variant of Recon1d_XYZ via reconstruct() +!! but reconstruc_parent() is not redefined so that it still is defined by Recon1d_XYZ +!! +!! The schemes that use this structure are described in \ref Vertical_Reconstruction +end module Recon1d_type diff --git a/src/ALE/_ALE.dox b/src/ALE/_ALE.dox index 9313ed2aa1..b3b4f54213 100644 --- a/src/ALE/_ALE.dox +++ b/src/ALE/_ALE.dox @@ -1,90 +1,184 @@ -/*! \page ALE ALE +/*! \page ALE Vertical Lagrangian method: conceptual -\section section_ALE Basics of the Vertical Lagrangian-Remap Method in MOM6 +\section section_ALE Lagrangian and ALE -As discussed by \cite adcroft2006, there are two general classes +As discussed by Adcroft and Hallberg (2008) \cite adcroft2006 and +Griffies, Adcroft and Hallberg (2020) \cite Griffies_Adcroft_Hallberg2020, +we can conceive of two general classes of algorithms that frame how hydrostatic ocean models are formulated. The two classes differ in how they treat the vertical direction. Quasi-Eulerian methods follow the approach traditionally -used in geopotential coordinate models, whereby vertical motion -is diagnosed via the continuity equation. Quasi-Lagrangian -methods are traditionally used by layered isopycnal models, with -the Lagrangian approach specifying motion that crosses coordinate +used in geopotential coordinate models, whereby vertical motion is +diagnosed via the continuity equation. Quasi-Lagrangian methods are +traditionally used by layered isopycnal models, with the vertical +Lagrangian approach specifying motion that crosses coordinate surfaces. Indeed, such dia-surface flow can be set to zero using -Lagrangian methods for studies of adiabatic dynamics. MOM6 makes -use of the vertical Lagrangian remap method, as pioneered for -ocean modeling by \cite bleck2002, which is a limit case of the -Arbitrary-Lagrangian-Eulerian method (\cite hirt1997). Dia-surface +Lagrangian methods for studies of adiabatic dynamics. MOM6 makes use +of the vertical Lagrangian remap method, as pioneered for ocean +modeling by Bleck (2002) \cite bleck2002 and further documented by +\cite Griffies_Adcroft_Hallberg2020, with this method a limit case of +the Arbitrary-Lagrangian-Eulerian method (\cite hirt1997). Dia-surface transport is implemented via a remapping so that the method can be -summarized as the Lagrangian plus remap approach and is essentially -a one-dimensional version of the incremental remapping of +summarized as the Lagrangian plus remap approach and so it is a +one-dimensional version of the incremental remapping of Dukowicz (2000) \cite dukowicz2000. -The MOM6 implementation of the vertical Lagrangian-remap method makes use -of two general steps. The first evolves the ocean state forward in -time according to a vertical Lagrangian limit with \f$\dot{r}=0\f$. Hence, -the horizontal momentum, thickness, and tracers are time stepped -with the red terms removed in equations \eqref{eq:h-horz-momentum,h-equations,momentum}, -\eqref{eq:h-thickness-equation,h-equations,thickness}, \eqref{eq:h-temperature-equation,h-equations,potential temperature}, -and \eqref{eq:h-salinity-equation,h-equations,salinity}. All advective transport thus -occurs within a layer as defined by constant \f$r\f$-surfaces so that -the volume within each layer is fixed. All other terms are retained in -their full form, including subgrid scale terms that contribute to -the transfer of tracer and momentum into distinct \f$r\f$ layers (e.g., -dia-surface diffusion of tracer and velocity). Maintaining constant -volume within a layer yet allowing for tracers to move between layers -engenders no inconsistency between tracer and thickness evolution. The -reason is that tracer diffusion, even dia-surface diffusion, does -not transfer volume. +\image html ALE_general_schematic.png "Schematic of the 3d Lagrangian regrid/remap method" width=70% +\image latex ALE_general_schematic.png "Schematic of the 3d Lagrangian regrid/remap method" width=0.7\textwidth -The second step in the algorithm comprises the generation of a new +Refer to the above figure taken from Griffies, Adcroft, and Hallberg +(2020) \cite Griffies_Adcroft_Hallberg2020. It shows a schematic of +the Lagrangian-remap method as well as the Arbitrary +Lagrangian-Eulerian (ALE) method. The first panel shows a square fluid +region and square grid used to represent the fluid, along with +rectangular subregions partitioned by grid lines. The second panel +shows the result of evolving the fluid region and evolving the +grid. The grid can evolve according to the fluid flow, as per a +Lagrangian method, or it can evolve according to some specified grid +evolution, as per an ALE method. The right panel depicts the grid +reinitialization onto a target grid (the regrid step). A regrid step +necessitates a corresponding remap step to estimate the ocean state on +the target grid, with conservative remapping required to preserve +integrated scalar contents (e.g., potential enthalpy, salt mass, and +seawater mass). The regrid/remap steps are needed for Lagrangian +methods in order for the grid to retain an accurate representation of +the ocean state. Ideally, the remap step does not affect any changes +to the fluid state; rather, it only modifies where in space the fluid +state is represented. However, any numerical realization incurs +interpolation inaccuracies that lead to unphysical (spurious) state +changes. + +\section section_ALE_MOM Vertical Lagrangian regrid/remap method + +We now get a bit more specific to the vertical Lagrangian method. +For this purpose, recall recall the basic dynamical equations (those +equations with a time derivative) of MOM6 discussed in +\ref General_Coordinate +\f{align} +\rho_0 +\left[ \frac{\partial \mathbf{u}}{\partial t} + \frac{( f + \zeta )}{h} \, +\hat{\mathbf{z}} \times h \, \mathbf{u} + \underbrace{ \dot{r} \, +\frac{\partial \mathbf{u}}{\partial r} } +\right] +&= -\nabla_r \, (p + \rho_{0} \, K) - +\rho \nabla_r \, \Phi + \mathbf{\mathcal{F}} +&\mbox{horizontal momentum} +\label{eq:h-horz-momentum-vlm} +\\ +\frac{\partial h}{\partial t} + \nabla_r \cdot \left( h \, \mathbf{u} \right) + +\underbrace{ \delta_r ( z_r \dot{r} ) } + &= 0 +&\mbox{thickness} +\label{eq:h-thickness-equation-vlm} +\\ +\frac{\partial ( \theta \, h )}{\partial t} + \nabla_r \cdot \left( \theta h \, +\mathbf{u} \right) + \underbrace{ \delta_r ( \theta \, z_r \dot{r} ) } +&= +h \mathbf{\mathcal{N}}_\theta^\gamma - \delta_r J_\theta^{(z)} +&\mbox{potential/Conservative temp} +\label{eq:h-temperature-equation-vlm} + \\ +\frac{\partial ( S \, h )}{\partial t} + \nabla_r \cdot \left( S \, h \, +\mathbf{u} \right) + \underbrace{ \delta_r ( S \, z_r \dot{r} ) } + &= +h \mathbf{\mathcal{N}}_S^\gamma - \delta_r J_S^{(z)} +&\mbox{salinity} +\label{eq:h-salinity-equation-vlm} +\f} +The MOM6 implementation of the vertical Lagrangian method makes +use of two general steps. The first evolves the ocean state forward in +time according to a vertical Lagrangian approach with with +\f$\dot{r}=0\f$. Hence, the horizontal momentum, thickness, and +tracers are time stepped with the underbraced terms removed in the +above equations. All advective transport occurs within a layer as +defined by constant \f$r\f$-surfaces so that the volume within each +layer is fixed. All other terms are retained in their full form, +including subgrid scale terms that contribute to the transfer of +tracer and momentum into distinct \f$r\f$ layers (e.g., dia-surface +diffusion of tracer and velocity). Maintaining constant volume within +a layer yet allowing for tracers to move between layers engenders no +inconsistency between tracer and thickness evolution. The reason is +that tracer diffusion, even dia-surface diffusion, does not transfer +volume. + +The second step in the method comprises the generation of a new vertical grid following a prescription, such as whether the grid -should align with isopcynals or constant \f$z^{*}\f$ or a combination. The -ocean state is then vertically remapped to the newly generated vertical -grid. The remapping step incorporates dia-surface transfer of properties, -with such transfer depending on the prescription given for the vertical +should align with isopcynals or constant \f$z^{*}\f$ or a combination. +This second step is known as the regrid step. The ocean state is then +vertically remapped to the newly generated vertical grid. This +remapping step incorporates dia-surface transfer of properties, with +such transfer depending on the prescription given for the vertical grid generation. To minimize discretization errors and the associated -spurious mixing, the remapping step makes use of the high order accurate -methods developed by \cite white2008 and \cite white2009. +spurious mixing, the remapping step makes use of the high order +accurate methods developed by \cite white2008 and \cite white2009. -The underlying algorithm for treatment of the vertical can -be related to operator-splitting of the red terms in equations -\eqref{eq:h-thickness-equation,h-equations,thickness}--\eqref{eq:h-temperature-equation,h-equations,potential temperature}. If we -consider, for simplicity, an Euler-forward update for a time-step \f$\Delta -t\f$, the time-stepping for the continuity and temperature equation can -be summarized as -\f{eqnarray} -\label{html:ale-equations}\notag \\ -h^\dagger &= h^{(n)} - \Delta t \left[ \nabla_r \cdot \left( h \, \mathbf{u} \right) \right] -&\mbox{thickness} \label{eq:ale-thickness-equation} \\ -\theta^\dagger \, h^\dagger &= \theta^{(n)} \, h^{(n)} - \Delta t \left[ \nabla_r \cdot \left( \theta h \, \mathbf{u} \right) - h \boldsymbol{\mathcal{N}}_\theta^\gamma + \delta_r J_\theta^{(z)} \right] -&\;\;\;\;\mbox{potential temp} \label{eq:ale-temperature-equation} \\ -h^{(n+1)} &= h^\dagger - \Delta t \, \delta_r \left( z_r \dot{r} \right) -&\mbox{move grid} \label{eq:ale-new-grid} \\ -\theta^{(n+1)} h^{(n+1)} &= \theta^\dagger h^\dagger - \Delta t \, \delta_r \left( z_r \dot{r} \, \theta^\dagger \right) -&\mbox{remap temperature.} \label{eq:ale-remap-temperature} -\f} +\section section_ALE_MOM_numerics Outlining the numerical algorithm -Substituting \eqref{eq:ale-thickness-equation,ale-equations,thickness} into \eqref{eq:ale-new-grid,ale-equations,move grid} -recovers a time-discrete form of \eqref{eq:h-thickness-equation,h-equations,thickness}. The -intermediate quantities indicated by \f$^\dagger\f$-symbols are the result of -the vertical Lagrangian step of the algorithm. What were the red terms in -the continuous-in-time equations are used to evolve the the intermediate -quantities to the final updated quantities each step. In MOM6, equation -\eqref{eq:ale-new-grid,ale-equations,move grid} is essentially used to define the dia-surface -transport \f$z_r \dot{r}\f$ by prescribing \f$h^{(n+1)}\f$. For example, to -recover a z-coordinate model, \f$h^{(n+1)}=\Delta z\f$, and \f$z_r \dot{r}\f$ -becomes the Eulerian vertical velocity, \f$w\f$. +The underlying algorithm for treatment of the vertical can be related +to operator-splitting of the underbraced terms in the above equations. +If we consider, for simplicity, an Euler-forward update for a +time-step \f$\Delta t\f$, the time-stepping for the thickness and +tracer equation (\f$C\f$ is an arbitrary tracer) can be summarized as +(from Table 1 in Griffies, Adcroft and Hallberg (2020) +\cite Griffies_Adcroft_Hallberg2020) +\f{align} +\label{html:ale-equations}\notag +\\ + \delta_{r} w^{\scriptstyle{\mathrm{grid}}} + &= -\nabla_{r} \cdot [h \, \mathbf{u}]^{(n)} + &\mbox{layer motion via horz conv} +\\ + h^{\dagger} &= h^{(n)} + \Delta t \, \delta_{r} w^{\scriptstyle{\mathrm{grid}}} += h^{(n)} - \Delta t \, \nabla_{r} \cdot [h \, \mathbf{u}]^{(n)} + &\mbox{update thickness via horz advect} +\\ + [h \, C]^{\dagger} &= [h \, C]^{(n)} -\Delta t \, \nabla_{r} \cdot [ h \, C \, \mathbf{u} ]^{(n)} + &\mbox{update tracer via horz advect} +\\ + h^{(n+1)} &= h^{\scriptstyle{\mathrm{target}}} + &\mbox{regrid to the target grid} +\\ + \delta_{r} w^{(\dot{r})} &= -(h^{\scriptstyle{\mathrm{target}}} - h^{\dagger})/\Delta t + &\mbox{diagnose dia-surface transport} +\\ + [h \, C]^{(n+1)} &= [h \, C]^{\dagger} - \Delta t \, \delta_{r} ( w^{(\dot{r})} \, C^{\dagger}) + &\mbox{remap tracer via dia-surface transport} +\f} +The first three equations constitute the Lagrangian portion of the +algorithm. In particular, the second equation provides an +intermediate or predictor value for the updated thickness, +\f$h^{\dagger}\f$, resulting from the vertical Lagrangian update. +Similarly, the third equation performs a Lagrangian update of the +thickness-weighted tracer to intermediate values, again operationally +realized by dropping the \f$w^{(\dot{r})}\f$ contribution. +The fourth equation is the regrid step, which is the key step in the +algorithm with the new grid defined by the new thickness +\f$h^{(n+1)}\f$. The new thickness is prescribed by the target values +for the vertical grid, +\f{align} + h^{(n+1)} = h^{\scriptstyle{\mathrm{target}}}. +\f} +The prescribed target grid thicknesses are then used to diagnose the +dia-surface velocity according to +\f{align} + \delta_{r} w^{(\dot{r})} = -(h^{\scriptstyle{\mathrm{target}}} - h^{\dagger})/\Delta t. +\f} +This step, and the remaining step for tracers, constitute the +remapping portion of the algorithm. For example, if the prescribed +coordinate surfaces are geopotentials, then \f$w^{(\dot{r})}\f$ and +\f$h^{\scriptstyle{\mathrm{target}}} = h^{(n)}\f$, in which case the +remap step reduces to Cartesian vertical advection. Within the above framework for evolving the ocean state, we make use of a standard split-explicit time stepping method by decomposing the horizontal momentum equation into its fast (depth integrated) and slow -(deviation from depth integrated) components. Furthermore, we follow the -methods of \cite hallberg2009 to ensure that the free surface resulting -from time stepping the depth integrated thickness equation (i.e., the -free surface equation) is consistent with the sum of the thicknesses -that result from time stepping the layer thickness equations for each -of the discretized layers; i.e., \f$\sum_{k} h = H + \eta\f$. +(deviation from depth integrated) components. Furthermore, we follow +the methods of Hallberg and Adcroft (2009) \cite hallberg2009 to +ensure that the free surface resulting from time stepping the depth +integrated thickness equation (i.e., the free surface equation) is +consistent with the sum of the thicknesses that result from time +stepping the layer thickness equations for each of the discretized +layers; i.e., \f$\sum_{k} h = H + \eta\f$. */ diff --git a/src/ALE/_ALE_timestep.dox b/src/ALE/_ALE_timestep.dox index e6da55fda9..04ed495e77 100644 --- a/src/ALE/_ALE_timestep.dox +++ b/src/ALE/_ALE_timestep.dox @@ -1,50 +1,62 @@ -/*! \page ALE_Timestep ALE Timestep - -\section section_ALE_remap Explanation of ALE remapping - -The Arbitrary Lagrangian-Eulerian (ALE) remapping is not a timestep in the traditional -sense, but rather an operation performed to bring the vertical coordinate back to the target -specification. This remapping can be less frequent than the momentum or -thermodynamic timesteps, but must be done before the layer interfaces become entangled -with each other. - -Assuming the target vertical grid is level \f$z\f$-surfaces, the initial state is -shown on the left in the following figure: - -\image html remapping1.png "The initial state with level surface (left) and the perturbed state after a wave has come through (right)." -\image latex remapping1.png "The initial state with level surface (left) and the perturbed state after a wave has come through (right)." - -Some time later, a wave has perturbed the surfaces which move with the -fluid and it has been determined that a remapping operation is needed. The -target vertical grid is still level \f$z\f$-surfaces, so this new target -grid is shown overlaid on the left as regrid: - -\image html remapping2.png "The regrid operation (left) and the remap operation (right)." -\image latex remapping2.png "The regrid operation (left) and the remap operation (right)." - -The complex part of the operation is remapping the wavy field onto the new grid as -shown on the right and again in the final frame after the old deformed coordinate -system has been deleted: - -\image html remapping3.png "The final state after remapping." -\image latex remapping3.png "The final state after remapping." - -Mathematically, the new layer thicknesses, \f$h_k\f$, are computed and then populated -with the new velocities and tracers: - -\f[ - h_k^{\mbox{new}} = \nabla_k z_{\mbox{coord}} -\f] -\f[ - \sum h_k^{\mbox{new}} = \sum h_k^{\mbox{old}} -\f] -\f[ - \vec{u}_k^{\mbox{new}} = \frac{1}{h_k} \int_{z_{k + \frac{1}{2}}}^{z_{k + - \frac{1}{2}} + h_k} \vec{u}^{\mbox{old}}(z')dz' -\f] -\f[ - \theta^{\mbox{new}} = \frac{1}{h_k} \int_{z_{k + \frac{1}{2}}}^{z_{k + - \frac{1}{2}} + h_k} \theta^{\mbox{old}}(z')dz' -\f] +/*! \page ALE_Timestep Vertical Lagrangian method in pictures + +\section section_ALE_remap Graphical explanation of vertical Lagrangian method + +Vertical Lagrangian regridding/remapping is not a timestep method in +the traditional sense. Rather, it is a sequence of operations +performed to bring the vertical grid back to a target specification +(the regrid step), and then to remap the ocean state onto this new +grid (the remap step). This regrid/remap process can be chosen to be +less frequent than the momentum or thermodynamic timesteps. We are +motivated to choose less frequent regrid/remap steps to save +computational time and to reduce spurious mixing that occurs due to +truncation errors in the remap step. However, there is a downside to +delaying the regrid/remap. Namely, if delayed too long then the layer +interfaces can become entangled (i.e., no longer monotonic in the +vertical), which is a common problem with purely Lagrangian methods. +On this page we illustrate the regrid/remap steps by making use of +Figure 3 from Griffies, Adcroft, and Hallberg (2020) +\cite Griffies_Adcroft_Hallberg2020. + +For purposes of this example, assume that the target vertical grid is +comprised of geopotential \f$z\f$-surfaces, with the initial ocean +state (e.g., the temperature field) shown on the left in the following +figure. + +\image html remapping1.png "Initial state with level surface (left) and perturbed state after a wave has come through (right)" width=60% +\image latex remapping1.png "Initial state with level surface (left) and perturbed state after a wave has come through (right)" width=0.6\textwidth + +Some time later, assume a wave has perturbed the ocean state. During +the Lagrangian portion of the algorithm, the coordinate surfaces move +vertically with the ocean fluid according to \f$\dot{r}=0\f$. Assume +now that the algorithm has determined that a regrid step is needed, +with the target vertical grid still geopotential \f$z\f$-surfaces, so +this new target grid is shown overlaid on the left as a regrid. + +\image html remapping2.png "The regrid operation (left) and the remap operation (right)" width=60% +\image latex remapping2.png "The regrid operation (left) and the remap operation (right)" width=0.6\textwidth + +The most complex part of the method involves remapping the wavy ocean +field onto the new grid. This step also incurs truncation errors that +are a function of the vertical grid spacing and the numerical method +used to perform the remapping. We illustrate this remap step in the +figure above, as well as in the frame below shown after the old +deformed coordinate grid has been deleted: + +\image html remapping3.png "The final state after regriddinig and remapping" width=30% +\image latex remapping3.png "The final state after regridding and remapping" width=0.3\textwidth + +The new layer thicknesses, \f$h_k\f$, are computed and then the layers +are populated with the new velocities and tracers +\f{align} + \sum h_k^{\scriptstyle{\mathrm{new}}} &= \sum h_k^{\scriptstyle{\mathrm{old}}} +\\ + \mathbf{u}_k^{\scriptstyle{\mathrm{new}}} + &= \frac{1}{h_k} + \int_{z_{k + 1/2}}^{z_{k + 1/2} + h_k} \mathbf{u}^{\scriptstyle{\mathrm{old}}}(z') \, \mathrm{d}z' +\\ + \theta_k^{\scriptstyle{\mathrm{new}}} &= \frac{1}{h_k} + \int_{z_{k + 1/2}}^{z_{k + 1/2} + h_k} \theta^{\scriptstyle{\mathrm{old}}}(z') \, \mathrm{d}z' +\f} */ diff --git a/src/ALE/_Vertical_Reconstruction.dox b/src/ALE/_Vertical_Reconstruction.dox new file mode 100644 index 0000000000..4db5261b16 --- /dev/null +++ b/src/ALE/_Vertical_Reconstruction.dox @@ -0,0 +1,92 @@ +/*! \page Vertical_Reconstruction Vertical Reconstruction + +\section section_vertical_reconstruction Vertical Reconstruction Methods + +Within the ALE or Lagrangian Remap Method (LRM), the structure of fields within cells (or layers in the case of MOM6) are reconstructed from the resolved cell means (i.e. the model variables). +The most widely used reconstructions use a piecewise polynomial representation for the reconstruction within each cell. +The simplest of these is the Piecewise Constant Method (PCM) which simply uses the cell mean value as a constant value throughout the cell. +The reconstructed fields may be discontinuous across cell boundaries, which is inherently the case for PCM. +PCM is a first order method and considered too diffusive for ALE, although it is the implicit representation in the traditional "layered" mode. +A second order reconstruction if the Piecewise Linear Method (PLM) of Van Leer, 1977 \cite van_leer_1977. +Higher order reconstructions are the Piecwise Parabloic Method (PPM) of Colella and Woodward, 1984 \cite colella1984, and the Piecwise Quartic Method (PQM) of White and Adcroft, 2008 \cite white2008. + +\section section_vertical_reconstruction_implementation Implementation + +The original implementations of vertical reconstructions are available in the `src/ALE` directory via modules such as plm_functions, ppm_functions, regrid_edge_values, etc. +These versions were used in OM4 \cite Adcroft2019 but later found to have inaccuracies with regard to round-off errors that could lead to non-monotonic behaviors. +A revision of the schemes was made available after comparing and porting from Hycom and are available via modules such as mom_hybgen_remap. +A recent refactoring of reconstructions for remapping was implemented via classes derived from the recon1d_type (also in `src/ALE` directory). + +The following table summarizes the OM4-era and Hycom-ported methods and routines, all selected by the runtime parameter `REMAPPING_SCHEME`. +The branch points (`select case`) in the code are in mom_remapping::build_reconstructions_1d(). + +REMAPPING_SCHEME | Description | Functions invoked (from MOM_remapping::build_reconstructions_1d()) +:--------------: | :---------- | :----------------------------------------------------------------- +PCM | Piecewise Constant Method | pcm_functions::pcm_reconstruction() +PLM | Monotonized Piecewise Linear Method \cite white2008 | plm_functions::plm_reconstruction() (calls plm_functions::plm_slope_wa() and plm_functions::plm_monotonized_slope()) (opt. plm_functions::plm_boundary_extrapolation()) +PLM_HYBGEN | Piecewise Linear Method, ported from Hycom \cite colella1984 | mom_hybgen_remap::hybgen_plm_coefs() (opt. plm_functions::plm_boundary_extrapolation()) +PPM_H4 | Piecewise Parabolic Method with explicit 4th order edge values \cite white2008 | regrid_edge_values::edge_values_explicit_h4() ppm_functions::ppm_reconstruction() (opt. ppm_functions::ppm_boundary_extrapolation()) +PPM_IH4 | Piecewise Parabolic Method with implicit 4th order edge values \cite white2008 | regrid_edge_values::edge_values_implicit_h4() ppm_functions::ppm_reconstruction() (opt. ppm_functions::ppm_boundary_extrapolation()) +PPM_HYBGEN | Piecewise Parabolic Method with quasi-4th order edge values using PLM \cite colella1984 | mom_hybgen_remap::hybgen_ppm_coefs() (opt. ppm_functions::ppm_boundary_extrapolation()) +PPM_CW | (should be equivalent to PPM_HYBGEN) | regrid_edge_values::edge_values_explicit_h4cw() ppm_functions::ppm_monotonicity() ppm_functions::ppm_reconstruction() (calls ppm_functions::ppm_limiter_standard()) (opt. ppm_functions::ppm_boundary_extrapolation()) +WENO_HYBGEN | Piecewise Parabolic Method with WENO edge values, ported from Hycom | mom_hybgen_remap::hybgen_weno_coefs() ppm_functions::ppm_reconstruction() (calls ppm_functions::ppm_limiter_standard()) (opt. ppm_functions::ppm_boundary_extrapolation()) +PQM_IH4IH3 | Piecewise Quartic Method with implicit quasi-4th order edge values and 3rd order edge slopes \cite white2008 | regrid_edge_values::edge_values_implicit_h4() regrid_edge_values::edge_slopes_implicit_h3() pqm_functions::pqm_reconstruction() (calls pqm_functions::pqm_limiter()) (opt. pqm_functions::pqm_boundary_extrapolation_v1()) +PQM_IH6IH5 | Piecewise Quartic Method with implicit quasi-6th order edge values and 5rd order edge slopes \cite white2008 | regrid_edge_values::edge_values_implicit_h6() regrid_edge_values::edge_slopes_implicit_h5() pqm_functions::pqm_reconstruction() (calls pqm_functions::pqm_limiter()) (opt. pqm_functions::pqm_boundary_extrapolation_v1()) + +The following table summarizes the newly refactored methods based on the class recon1d_type::recon1d. +These are also controlled by the runtime parameter `REMAPPING_SCHEME` but the branch point is in the form of a type allocation during initialization in mom_remapping::setreconstructiontype(). + +REMAPPING_SCHEME | Description | Module +:--------------: | :---------- | :----- +C_PCM | Piecewise Constant Method (equivalent to PCM) | recon1d_pcm +C_PLM_CW | Piecewise Linear Method (faithful to Colella and Woodward \cite colella1984) | recon1d_plm_cw +C_PLM_HYBGEN | PLM (equivalent to PLM_HYBGEN) | recon1d_plm_hybgen +C_MPLM_WA | Monotonized Piecewise Linear Method (faithful to White and Adcroft \cite white2008) | recon1d_mplm_wa +C_MPLM_WA_POLY | MPLM using polynomial representation (euivalent to PLM) | recon1d_mplm_wa_poly +C_EMPLM_WA | Boundary extrapolation of MPLM_WA (faithful to White and Adcroft \cite white2008) | recon1d_emplm_wa +C_EMPLM_WA_POLY | Boundary extrapolation of MPLM using polynomial repesentation (equivalent to PLM) | recon1d_emplm_wa_poly +C_PLM_CWK | Piecewise Linear Method in index space (grid independent) | recon1d_plm_cwk +C_MPLM_CWK | Monotonized Piecewise Linear Method in index space (grid independent) | recon1d_mplm_cwk +C_EMPLM_CWK | Boundary extrapolatino of Monotonized Piecewise Linear Method in index space (grid independent) | recon1d_emplm_cwk +C_PPM_CW | Piecewise Linear Method (faithful to Colella and Woodward \cite colella1984) | recon1d_ppm_cw +C_PPM_HYBGEN | PPM (equivalent to PPM_HYBGEN) | recon1d_ppm_hybgen +C_PPM_H4_2018 | (equivalent to PPM_H4 with answers circa 2018) | recon1d_ppm_h4_2018 +C_PPM_H4_2019 | (equivalent to PPM_H4 with answers post 2019) | recon1d_ppm_h4_2019 +C_PPM_CWK | Piecewise Parabolic Method in index space (grid independent) | recon1d_ppm_cwk +C_EPPM_CWK | Piecewise Parabolic Method in index space (grid independent) | recon1d_eppm_cwk (extends recon1d_ppm_cwk) + +The motivation for some of the schemes in the last table was to recover certain numerical of computationsl properties, summarized in the next table. + +REMAPPING_SCHEME | Representation | Globally monotonic | Consistent | Grid dependent | Uniform test +:--------------: | :------------- | :----------------- | :--------- | :------------- | :----------- +PCM | Single scalar | Yes | Yes | No | Pass +PLM | Polynomial | Forced | | Yes | Fail +PLM_HYBGEN | Polynomial | No | | Yes | Fail +PPM_H4 | Edge values | | | Yes | Fail +PPM_IH4 | Edge values | | | Yes | Fail +PPM_HYBGEN | Edge values | | | Yes | Fail +PPM_CW | Edge values | | | Yes | Fail +WENO_HYBGEN | Edge values | | | Yes | Fail +PQM_IH4IH3 | Polynomial | | | Yes | Fail +PQM_IH6IH5 | Polynomial | | | Yes | Fail +C_PCM | Single scalar | Yes | Yes | No | Pass +C_PLM_CW | Edge values | No | Yes | Yes | Pass +C_PLM_HYBGEN | Edge values | No | Yes | Yes | Pass +C_MPLM_WA | Edge values | Yes | No | Yes | Pass +C_MPLM_WA_POLY | Polynomial | Yes | * | Yes | Pass +C_EMPLM_WA | Edge values | Yes | No | Yes | Pass +C_EMPLM_WA_POLY | Polynomial | No | | Yes | Pass +C_PLM_CWK | Edge values | Yes | Yes | No | Pass +C_MPLM_CWK | Edge values | Yes | Yes | No | Pass +C_EMPLM_CWK | Edge values | Yes | Yes | No | Pass +C_PPM_CW | Edge values | Yes | Yes | Yes | Pass +C_PPM_HYBGEN | Edge values | * forced | Yes | Yes | Pass +C_PPM_H4_2018 | Edge values | * forced | | Yes | Pass +C_PPM_H4_2019 | Edge values | * forced | Yes | Yes | Pass +C_PPM_CWK | Edge values | Yes | Yes | No | Pass +C_EPPM_CWK | Edge values | Yes | Yes | No | Pass + +The OM4-era schemes calculate values via the function mom_remapping::average_value_ppoly() which uses reconstructions stored as the corresponding polynomial coefficients for PLM and PQM, but uses edge values for PPM. +The newer class-based schemes use edge values to store the reconstructions for all schemes (except where replicating the OM4-era schemes). + +*/ diff --git a/src/ALE/coord_adapt.F90 b/src/ALE/coord_adapt.F90 index fe3864fc7a..3b6a068f66 100644 --- a/src/ALE/coord_adapt.F90 +++ b/src/ALE/coord_adapt.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Regrid columns for the adaptive coordinate module coord_adapt -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_EOS, only : calculate_density_derivs use MOM_error_handler, only : MOM_error, FATAL use MOM_unit_scaling, only : unit_scale_type @@ -22,19 +24,19 @@ module coord_adapt !> Nominal near-surface resolution [H ~> m or kg m-2] real, allocatable, dimension(:) :: coordinateResolution - !> Ratio of optimisation and diffusion timescales + !> Ratio of optimisation and diffusion timescales [nondim] real :: adaptTimeRatio - !> Nondimensional coefficient determining how much optimisation to apply + !> Nondimensional coefficient determining how much optimisation to apply [nondim] real :: adaptAlpha !> Near-surface zooming depth [H ~> m or kg m-2] real :: adaptZoom - !> Near-surface zooming coefficient + !> Near-surface zooming coefficient [nondim] real :: adaptZoomCoeff - !> Stratification-dependent diffusion coefficient + !> Stratification-dependent diffusion coefficient [nondim] real :: adaptBuoyCoeff !> Reference density difference for stratification-dependent diffusion [R ~> kg m-3] @@ -55,8 +57,10 @@ subroutine init_coord_adapt(CS, nk, coordinateResolution, m_to_H, kg_m3_to_R) integer, intent(in) :: nk !< Number of layers in the grid real, dimension(:), intent(in) :: coordinateResolution !< Nominal near-surface resolution [m] or !! other units specified with m_to_H - real, intent(in) :: m_to_H !< A conversion factor from m to the units of thicknesses - real, intent(in) :: kg_m3_to_R !< A conversion factor from kg m-3 to the units of density + real, intent(in) :: m_to_H !< A conversion factor from m to the units of thicknesses, + !! perhaps in units of [H m-1 ~> 1 or kg m-3] + real, intent(in) :: kg_m3_to_R !< A conversion factor from kg m-3 to the units of density, + !! perhaps in units of [R m3 kg-1 ~> 1] if (associated(CS)) call MOM_error(FATAL, "init_coord_adapt: CS already associated") allocate(CS) @@ -89,12 +93,12 @@ end subroutine end_coord_adapt subroutine set_adapt_params(CS, adaptTimeRatio, adaptAlpha, adaptZoom, adaptZoomCoeff, & adaptBuoyCoeff, adaptDrho0, adaptDoMin) type(adapt_CS), pointer :: CS !< The control structure for this module - real, optional, intent(in) :: adaptTimeRatio !< Ratio of optimisation and diffusion timescales + real, optional, intent(in) :: adaptTimeRatio !< Ratio of optimisation and diffusion timescales [nondim] real, optional, intent(in) :: adaptAlpha !< Nondimensional coefficient determining - !! how much optimisation to apply + !! how much optimisation to apply [nondim] real, optional, intent(in) :: adaptZoom !< Near-surface zooming depth [H ~> m or kg m-2] - real, optional, intent(in) :: adaptZoomCoeff !< Near-surface zooming coefficient - real, optional, intent(in) :: adaptBuoyCoeff !< Stratification-dependent diffusion coefficient + real, optional, intent(in) :: adaptZoomCoeff !< Near-surface zooming coefficient [nondim] + real, optional, intent(in) :: adaptBuoyCoeff !< Stratification-dependent diffusion coefficient [nondim] real, optional, intent(in) :: adaptDrho0 !< Reference density difference for !! stratification-dependent diffusion [R ~> kg m-3] logical, optional, intent(in) :: adaptDoMin !< If true, form a HYCOM1-like mixed layer by @@ -112,7 +116,7 @@ subroutine set_adapt_params(CS, adaptTimeRatio, adaptAlpha, adaptZoom, adaptZoom if (present(adaptDoMin)) CS%adaptDoMin = adaptDoMin end subroutine set_adapt_params -subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNext) +subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, nom_depth_H, zNext) type(adapt_CS), intent(in) :: CS !< The control structure for this module type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -122,20 +126,32 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex integer, intent(in) :: i !< The i-index of the column to work on integer, intent(in) :: j !< The j-index of the column to work on real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: zInt !< Interface heights [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: tInt !< Interface temperatures [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: sInt !< Interface salinities [ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: tInt !< Interface temperatures [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: sInt !< Interface salinities [S ~> ppt] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(SZK_(GV)+1), intent(inout) :: zNext !< updated interface positions + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] + real, dimension(SZK_(GV)+1), intent(inout) :: zNext !< updated interface positions [H ~> m or kg m-2] ! Local variables integer :: k, nz - real :: h_up, b1, b_denom_1, d1, depth, nominal_z, stretching + real :: h_up ! The upwind source grid thickness based on the direction of the + ! adjustive fluxes [H ~> m or kg m-2] + real :: b1 ! The inverse of the tridiagonal denominator [nondim] + real :: b_denom_1 ! The leading term in the tridiagonal denominator [nondim] + real :: d1 ! A term in the tridiagonal expressions [nondim] + real :: depth ! Depth in thickness units [H ~> m or kg m-2] + real :: nominal_z ! A nominal interface position in thickness units [H ~> m or kg m-2] + real :: stretching ! A stretching factor for the water column [nondim] real :: drdz ! The vertical density gradient [R H-1 ~> kg m-4 or m-1] - real, dimension(SZK_(GV)+1) :: alpha ! drho/dT [R degC-1 ~> kg m-3 degC-1] - real, dimension(SZK_(GV)+1) :: beta ! drho/dS [R ppt-1 ~> kg m-3 ppt-1] + real, dimension(SZK_(GV)+1) :: alpha ! drho/dT [R C-1 ~> kg m-3 degC-1] + real, dimension(SZK_(GV)+1) :: beta ! drho/dS [R S-1 ~> kg m-3 ppt-1] real, dimension(SZK_(GV)+1) :: del2sigma ! Laplacian of in situ density times grid spacing [R ~> kg m-3] real, dimension(SZK_(GV)+1) :: dh_d2s ! Thickness change in response to del2sigma [H ~> m or kg m-2] - real, dimension(SZK_(GV)) :: kGrid, c1 ! grid diffusivity on layers, and tridiagonal work array + real, dimension(SZK_(GV)) :: kGrid ! grid diffusivity on layers [nondim] + real, dimension(SZK_(GV)) :: c1 ! A tridiagonal work array [nondim] nz = CS%nk @@ -144,7 +160,7 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex zNext(nz+1) = zInt(i,j,nz+1) ! local depth for scaling diffusivity - depth = (G%bathyT(i,j) + G%Z_ref) * GV%Z_to_H + depth = nom_depth_H(i,j) ! initialize del2sigma and the thickness change response to it zero del2sigma(:) = 0.0 ; dh_d2s(:) = 0.0 @@ -154,7 +170,7 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex ! TODO: this needs to be adjusted to account for vanished layers near topography ! up (j-1) - if (G%mask2dT(i,j-1) > 0.) then + if (G%mask2dT(i,j-1) > 0.0) then call calculate_density_derivs( & 0.5 * (tInt(i,j,2:nz) + tInt(i,j-1,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i,j-1,2:nz)), & @@ -166,7 +182,7 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex beta(2:nz) * (sInt(i,j-1,2:nz) - sInt(i,j,2:nz))) endif ! down (j+1) - if (G%mask2dT(i,j+1) > 0.) then + if (G%mask2dT(i,j+1) > 0.0) then call calculate_density_derivs( & 0.5 * (tInt(i,j,2:nz) + tInt(i,j+1,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i,j+1,2:nz)), & @@ -178,7 +194,7 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex beta(2:nz) * (sInt(i,j+1,2:nz) - sInt(i,j,2:nz))) endif ! left (i-1) - if (G%mask2dT(i-1,j) > 0.) then + if (G%mask2dT(i-1,j) > 0.0) then call calculate_density_derivs( & 0.5 * (tInt(i,j,2:nz) + tInt(i-1,j,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i-1,j,2:nz)), & @@ -190,7 +206,7 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex beta(2:nz) * (sInt(i-1,j,2:nz) - sInt(i,j,2:nz))) endif ! right (i+1) - if (G%mask2dT(i+1,j) > 0.) then + if (G%mask2dT(i+1,j) > 0.0) then call calculate_density_derivs( & 0.5 * (tInt(i,j,2:nz) + tInt(i+1,j,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i+1,j,2:nz)), & @@ -244,9 +260,9 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex ! set vertical grid diffusivity kGrid(k) = (CS%adaptTimeRatio * nz**2 * depth) * & - (CS%adaptZoomCoeff / (CS%adaptZoom + 0.5*(zNext(K) + zNext(K+1))) + & - (CS%adaptBuoyCoeff * drdz / CS%adaptDrho0) + & - max(1.0 - CS%adaptZoomCoeff - CS%adaptBuoyCoeff, 0.0) / depth) + ( CS%adaptZoomCoeff / (CS%adaptZoom + 0.5*(zNext(K) + zNext(K+1))) + & + (CS%adaptBuoyCoeff * drdz / CS%adaptDrho0) + & + max(1.0 - CS%adaptZoomCoeff - CS%adaptBuoyCoeff, 0.0) / depth) enddo ! initial denominator (first diagonal element) diff --git a/src/ALE/coord_hycom.F90 b/src/ALE/coord_hycom.F90 index 4d70f925aa..d383351517 100644 --- a/src/ALE/coord_hycom.F90 +++ b/src/ALE/coord_hycom.F90 @@ -1,14 +1,21 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Regrid columns for the HyCOM coordinate module coord_hycom -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_error_handler, only : MOM_error, FATAL +use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, NOTE +use MOM_variables, only : ocean_grid_type, thermo_var_ptrs use MOM_EOS, only : EOS_type, calculate_density -use regrid_interp, only : interp_CS_type, build_and_interpolate_grid +use MOM_remapping, only : remapping_CS, remapping_core_h +use regrid_interp, only : interp_CS_type, build_and_interpolate_grid, regridding_set_ppolys +use regrid_interp, only : DEGREE_MAX implicit none ; private +#include + !> Control structure containing required parameters for the HyCOM coordinate type, public :: hycom_CS ; private @@ -27,11 +34,23 @@ module coord_hycom !> Maximum thicknesses of layers [H ~> m or kg m-2] real, allocatable, dimension(:) :: max_layer_thickness + !> If true, an interface only moves if it improves the density fit + logical :: only_improves = .false. + + !> If true, use 3-D control fields + logical :: use_3d = .false. + + !> Nominal density of interfaces [R ~> kg m-3] + real, allocatable, dimension(:,:,:) :: target_density_3d + + !> Nominal near-surface resolution [Z ~> m] + real, allocatable, dimension(:,:,:) :: coordinateResolution_3d + !> Interpolation control structure type(interp_CS_type) :: interp_CS end type hycom_CS -public init_coord_hycom, set_hycom_params, build_hycom1_column, end_coord_hycom +public init_coord_hycom, init_3d_coord_hycom, set_hycom_params, build_hycom1_column, end_coord_hycom contains @@ -51,73 +70,130 @@ subroutine init_coord_hycom(CS, nk, coordinateResolution, target_density, interp CS%nk = nk CS%coordinateResolution(:) = coordinateResolution(:) CS%target_density(:) = target_density(:) + CS%use_3d = .false. CS%interp_CS = interp_CS + if (is_root_pe()) call MOM_error(NOTE, "init_coord_hycom: use_3d = .false.") + end subroutine init_coord_hycom +!> Initialise a hycom_CS with pointers to parameters +subroutine init_3d_coord_hycom(CS, G, nk, coordinateResolution, target_density, interp_CS) + type(hycom_CS), pointer :: CS !< Unassociated pointer to hold the control structure + type(ocean_grid_type),intent(in) :: G !< Ocean grid structure + integer, intent(in) :: nk !< Number of layers in generated grid + real, dimension(SZI_(G),SZJ_(G),nk), intent(in) :: coordinateResolution !< Nominal near-surface resolution [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),nk+1), intent(in) :: target_density !< Interface target densities [R ~> kg m-3] + type(interp_CS_type), intent(in) :: interp_CS !< Controls for interpolation + ! Local variables + integer :: i,j,k + + if (associated(CS)) call MOM_error(FATAL, "init_3d_coord_hycom: CS already associated!") + + allocate(CS) + allocate(CS%coordinateResolution_3d(nk,SZI_(G),SZJ_(G)), source=0.0) + allocate(CS%target_density_3d(nk+1,SZI_(G),SZJ_(G)), source=0.0) + + CS%nk = nk + CS%use_3d = .true. + CS%interp_CS = interp_CS + + do i=G%isc-1,G%iec+1 ; do j=G%jsc-1,G%jec+1 + if (G%mask2dT(i,j)>0.) then + do k= 1,nk + CS%coordinateResolution_3d(k,i,j) = coordinateResolution(i,j,k) + CS%target_density_3d(k,i,j) = target_density(i,j,k) + enddo + CS%target_density_3d(nk+1,i,j) = target_density(i,j,nk+1) + endif !mask2dT + enddo ; enddo + + if (is_root_pe()) call MOM_error(NOTE, "init_3d_coord_hycom: use_3d = .true.") + +end subroutine init_3d_coord_hycom + !> This subroutine deallocates memory in the control structure for the coord_hycom module subroutine end_coord_hycom(CS) type(hycom_CS), pointer :: CS !< Coordinate control structure ! nothing to do if (.not. associated(CS)) return - deallocate(CS%coordinateResolution) - deallocate(CS%target_density) + + if (allocated(CS%coordinateResolution)) deallocate(CS%coordinateResolution) + if (allocated(CS%target_density)) deallocate(CS%target_density) + if (allocated(CS%coordinateResolution_3d)) deallocate(CS%coordinateResolution_3d) + if (allocated(CS%target_density_3d)) deallocate(CS%target_density_3d) if (allocated(CS%max_interface_depths)) deallocate(CS%max_interface_depths) if (allocated(CS%max_layer_thickness)) deallocate(CS%max_layer_thickness) deallocate(CS) end subroutine end_coord_hycom !> This subroutine can be used to set the parameters for the coord_hycom module -subroutine set_hycom_params(CS, max_interface_depths, max_layer_thickness, interp_CS) +subroutine set_hycom_params(CS, max_interface_depths, max_layer_thickness, only_improves, interp_CS) type(hycom_CS), pointer :: CS !< Coordinate control structure real, dimension(:), optional, intent(in) :: max_interface_depths !< Maximum depths of interfaces [H ~> m or kg m-2] real, dimension(:), optional, intent(in) :: max_layer_thickness !< Maximum thicknesses of layers [H ~> m or kg m-2] + logical, optional, intent(in) :: only_improves !< If true, an interface only moves if it improves the density fit type(interp_CS_type), optional, intent(in) :: interp_CS !< Controls for interpolation if (.not. associated(CS)) call MOM_error(FATAL, "set_hycom_params: CS not associated") if (present(max_interface_depths)) then if (size(max_interface_depths) /= CS%nk+1) & - call MOM_error(FATAL, "set_hycom_params: max_interface_depths inconsistent size") + call MOM_error(FATAL, "set_hycom_params: max_interface_depths inconsistent size") allocate(CS%max_interface_depths(CS%nk+1)) CS%max_interface_depths(:) = max_interface_depths(:) endif if (present(max_layer_thickness)) then if (size(max_layer_thickness) /= CS%nk) & - call MOM_error(FATAL, "set_hycom_params: max_layer_thickness inconsistent size") + call MOM_error(FATAL, "set_hycom_params: max_layer_thickness inconsistent size") allocate(CS%max_layer_thickness(CS%nk)) CS%max_layer_thickness(:) = max_layer_thickness(:) endif + if (present(only_improves)) CS%only_improves = only_improves + if (present(interp_CS)) CS%interp_CS = interp_CS end subroutine set_hycom_params !> Build a HyCOM coordinate column -subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, & +subroutine build_hycom1_column(CS, remapCS, eqn_of_state, nz, ix, jy, depth, h, T, S, p_col, & z_col, z_col_new, zScale, h_neglect, h_neglect_edge) type(hycom_CS), intent(in) :: CS !< Coordinate control structure + type(remapping_CS), intent(in) :: remapCS !< Remapping parameters and options type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure integer, intent(in) :: nz !< Number of levels + integer, intent(in) :: ix !< x direction array index + integer, intent(in) :: jy !< y direction array index real, intent(in) :: depth !< Depth of ocean bottom (positive [H ~> m or kg m-2]) - real, dimension(nz), intent(in) :: T !< Temperature of column [degC] - real, dimension(nz), intent(in) :: S !< Salinity of column [ppt] + real, dimension(nz), intent(in) :: T !< Temperature of column [C ~> degC] + real, dimension(nz), intent(in) :: S !< Salinity of column [S ~> ppt] real, dimension(nz), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(nz), intent(in) :: p_col !< Layer pressure [R L2 T-2 ~> Pa] real, dimension(nz+1), intent(in) :: z_col !< Interface positions relative to the surface [H ~> m or kg m-2] real, dimension(CS%nk+1), intent(inout) :: z_col_new !< Absolute positions of interfaces [H ~> m or kg m-2] 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. - real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose of + !! 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, 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] ! Local variables integer :: k - real, dimension(nz) :: rho_col ! Layer densities in a column [R ~> kg m-3] - real, dimension(CS%nk) :: h_col_new ! New layer thicknesses + real, dimension(nz) :: rho_col ! Layer densities in a column [R ~> kg m-3] + real, dimension(CS%nk) :: h_col_new ! New layer thicknesses [H ~> m or kg m-2] + real, dimension(CS%nk) :: r_col_new ! New layer densities [R ~> kg m-3] + real, dimension(CS%nk) :: T_col_new ! New layer temperatures [C ~> degC] + real, dimension(CS%nk) :: S_col_new ! New layer salinities [S ~> ppt] + real, dimension(CS%nk) :: p_col_new ! New layer pressure [R L2 T-2 ~> Pa] + real, dimension(CS%nk+1) :: RiA_ini ! Initial nk+1 interface density anomaly w.r.t. the + ! interface target densities [R ~> kg m-3] + real, dimension(CS%nk+1) :: RiA_new ! New interface density anomaly w.r.t. the + ! interface target densities [R ~> kg m-3] + real :: z_1, z_nz ! mid point of 1st and last layers [H ~> m or kg m-2] real :: z_scale ! A scaling factor from the input thicknesses to the target thicknesses, ! perhaps 1 or a factor in [H Z-1 ~> 1 or kg m-3] real :: stretching ! z* stretching, converts z* to z [nondim]. @@ -130,28 +206,66 @@ subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, & z_scale = 1.0 ; if (present(zScale)) z_scale = zScale - ! Work bottom recording potential density - call calculate_density(T, S, p_col, rho_col, eqn_of_state) - ! This ensures the potential density profile is monotonic - ! although not necessarily single valued. - do k = nz-1, 1, -1 - rho_col(k) = min( rho_col(k), rho_col(k+1) ) - enddo + if (CS%only_improves .and. nz == CS%nk) then + call build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, CS%nk, ix, jy, depth, & + h, T, S, p_col, rho_col, RiA_ini, h_neglect, h_neglect_edge) + else + ! Work bottom recording potential density + call calculate_density(T, S, p_col, rho_col, eqn_of_state) + ! This ensures the potential density profile is monotonic + ! although not necessarily single valued. + do k = nz-1, 1, -1 + rho_col(k) = min( rho_col(k), rho_col(k+1) ) + enddo + endif ! Interpolates for the target interface position with the rho_col profile ! Based on global density profile, interpolate to generate a new grid - call build_and_interpolate_grid(CS%interp_CS, rho_col, nz, h(:), z_col, & - CS%target_density, CS%nk, h_col_new, z_col_new, h_neglect, h_neglect_edge) + if (CS%use_3d) then + call build_and_interpolate_grid(CS%interp_CS, rho_col, nz, h(:), z_col, & + CS%target_density_3d(:,ix,jy), CS%nk, h_col_new, z_col_new, h_neglect, h_neglect_edge) + else + call build_and_interpolate_grid(CS%interp_CS, rho_col, nz, h(:), z_col, & + CS%target_density, CS%nk, h_col_new, z_col_new, h_neglect, h_neglect_edge) + endif + if (CS%only_improves .and. nz == CS%nk) then + ! Only move an interface if it improves the density fit + z_1 = 0.5 * ( z_col(1) + z_col(2) ) + z_nz = 0.5 * ( z_col(nz) + z_col(nz+1) ) + do k = 1,CS%nk + p_col_new(k) = p_col(1) + ( 0.5 * ( z_col_new(K) + z_col_new(K+1) ) - z_1 ) & + / ( z_nz - z_1 ) * ( 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) + 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, ix, jy, 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 + if ( abs(RiA_ini(K)) <= abs(RiA_new(K)) .and. z_col(K) > z_col_new(K-1) .and. & + z_col(K) < z_col_new(K+1)) then + z_col_new(K) = z_col(K) + endif + enddo + endif !only_improves ! Sweep down the interfaces and make sure that the interface is at least ! as deep as a nominal target z* grid nominal_z = 0. stretching = z_col(nz+1) / depth ! Stretches z* to z - do k = 2, CS%nk+1 - nominal_z = nominal_z + (z_scale * CS%coordinateResolution(k-1)) * stretching - z_col_new(k) = max( z_col_new(k), nominal_z ) - z_col_new(k) = min( z_col_new(k), z_col(nz+1) ) - enddo + if (CS%use_3d) then + do k = 2, CS%nk+1 + nominal_z = nominal_z + (z_scale * CS%coordinateResolution_3d(k-1,ix,jy)) * stretching + z_col_new(k) = max( z_col_new(k), nominal_z ) + z_col_new(k) = min( z_col_new(k), z_col(nz+1) ) + enddo + else + do k = 2, CS%nk+1 + nominal_z = nominal_z + (z_scale * CS%coordinateResolution(k-1)) * stretching + z_col_new(k) = max( z_col_new(k), nominal_z ) + z_col_new(k) = min( z_col_new(k), z_col(nz+1) ) + enddo + endif if (maximum_depths_set .and. maximum_h_set) then ; do k=2,CS%nk ! The loop bounds are 2 & nz so the top and bottom interfaces do not move. @@ -165,4 +279,76 @@ subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, & enddo ; endif end subroutine build_hycom1_column +!> Calculate interface density anomaly w.r.t. the target. +subroutine build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, nz, ix, jy, depth, h, T, S, & + p_col, R, RiAnom, h_neglect, h_neglect_edge) + type(hycom_CS), intent(in) :: CS !< Coordinate control structure + type(remapping_CS), intent(in) :: remapCS !< Remapping parameters and options + type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure + integer, intent(in) :: nz !< Number of levels + integer, intent(in) :: ix !< x direction array index + integer, intent(in) :: jy !< y direction array index + real, intent(in) :: depth !< Depth of ocean bottom (positive [H ~> m or kg m-2]) + real, dimension(nz), intent(in) :: T !< Temperature of column [C ~> degC] + real, dimension(nz), intent(in) :: S !< Salinity of column [S ~> ppt] + real, dimension(nz), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(nz), intent(in) :: p_col !< Layer pressure [R L2 T-2 ~> Pa] + real, dimension(nz), intent(out) :: R !< Layer density [R ~> kg m-3] + real, dimension(nz+1), intent(out) :: RiAnom !< The interface density anomaly + !! w.r.t. the interface target + !! densities [R ~> kg m-3] + 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] + ! Local variables + integer :: degree,k + real, dimension(nz) :: rho_col ! Layer densities in a column [R ~> kg m-3] + real, dimension(nz,2) :: ppoly_E ! Polynomial edge values [R ~> kg m-3] + real, dimension(nz,2) :: ppoly_S ! Polynomial edge slopes [R H-1] + real, dimension(nz,DEGREE_MAX+1) :: ppoly_C ! Polynomial interpolant coeficients on the local 0-1 grid [R ~> kg m-3] + + ! Work bottom recording potential density + call calculate_density(T, S, p_col, rho_col, eqn_of_state) + ! This ensures the potential density profile is monotonic + ! although not necessarily single valued. + do k = nz-1, 1, -1 + rho_col(k) = min( rho_col(k), rho_col(k+1) ) + enddo + + call regridding_set_ppolys(CS%interp_CS, rho_col, nz, h, ppoly_E, ppoly_S, ppoly_C, & + degree, h_neglect, h_neglect_edge) + + if (CS%use_3d) then + R(1) = rho_col(1) + RiAnom(1) = ppoly_E(1,1) - CS%target_density_3d(1,ix,jy) + do k= 2,nz + R(k) = rho_col(k) + if (ppoly_E(k-1,2) > CS%target_density_3d(k,ix,jy)) then + RiAnom(k) = ppoly_E(k-1,2) - CS%target_density_3d(k,ix,jy) !interface is heavier than target + elseif (ppoly_E(k,1) < CS%target_density_3d(k,ix,jy)) then + RiAnom(k) = ppoly_E(k,1) - CS%target_density_3d(k,ix,jy) !interface is lighter than target + else + RiAnom(k) = 0.0 !interface spans the target + endif + enddo + RiAnom(nz+1) = ppoly_E(nz,2) - CS%target_density_3d(nz+1,ix,jy) + else + R(1) = rho_col(1) + RiAnom(1) = ppoly_E(1,1) - CS%target_density(1) + do k= 2,nz + R(k) = rho_col(k) + if (ppoly_E(k-1,2) > CS%target_density(k)) then + RiAnom(k) = ppoly_E(k-1,2) - CS%target_density(k) !interface is heavier than target + elseif (ppoly_E(k,1) < CS%target_density(k)) then + RiAnom(k) = ppoly_E(k,1) - CS%target_density(k) !interface is lighter than target + else + RiAnom(k) = 0.0 !interface spans the target + endif + enddo + RiAnom(nz+1) = ppoly_E(nz,2) - CS%target_density(nz+1) + endif !use_3d:else + +end subroutine build_hycom1_target_anomaly + end module coord_hycom diff --git a/src/ALE/coord_rho.F90 b/src/ALE/coord_rho.F90 index 4a9872d429..904517ef15 100644 --- a/src/ALE/coord_rho.F90 +++ b/src/ALE/coord_rho.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Regrid columns for the continuous isopycnal (rho) coordinate module coord_rho -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_error_handler, only : MOM_error, FATAL use MOM_remapping, only : remapping_CS, remapping_core_h use MOM_EOS, only : EOS_type, calculate_density @@ -67,12 +69,14 @@ subroutine end_coord_rho(CS) end subroutine end_coord_rho !> This subroutine can be used to set the parameters for the coord_rho module -subroutine set_rho_params(CS, min_thickness, integrate_downward_for_e, interp_CS) +subroutine set_rho_params(CS, min_thickness, integrate_downward_for_e, interp_CS, ref_pressure) type(rho_CS), pointer :: CS !< Coordinate control structure real, optional, intent(in) :: min_thickness !< Minimum allowed thickness [H ~> m or kg m-2] logical, optional, intent(in) :: integrate_downward_for_e !< If true, integrate for interface !! positions from the top downward. If false, integrate !! from the bottom upward, as does the rest of the model. + real, optional, intent(in) :: ref_pressure !< The reference pressure for density-dependent + !! coordinates [R L2 T-2 ~> Pa] type(interp_CS_type), optional, intent(in) :: interp_CS !< Controls for interpolation @@ -81,6 +85,7 @@ subroutine set_rho_params(CS, min_thickness, integrate_downward_for_e, interp_CS if (present(min_thickness)) CS%min_thickness = min_thickness if (present(integrate_downward_for_e)) CS%integrate_downward_for_e = integrate_downward_for_e if (present(interp_CS)) CS%interp_CS = interp_CS + if (present(ref_pressure)) CS%ref_pressure = ref_pressure end subroutine set_rho_params !> Build a rho coordinate column @@ -93,16 +98,16 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & integer, intent(in) :: nz !< Number of levels on source grid (i.e. length of h, T, S) real, intent(in) :: depth !< Depth of ocean bottom (positive downward) [H ~> m or kg m-2] real, dimension(nz), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(nz), intent(in) :: T !< Temperature for source column [degC] - real, dimension(nz), intent(in) :: S !< Salinity for source column [ppt] + real, dimension(nz), intent(in) :: T !< Temperature for source column [C ~> degC] + real, dimension(nz), intent(in) :: S !< Salinity for source column [S ~> ppt] type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure real, dimension(CS%nk+1), & - intent(inout) :: z_interface !< Absolute positions of interfaces + intent(inout) :: z_interface !< Absolute positions of interfaces [H ~> m or kg m-2] real, optional, intent(in) :: z_rigid_top !< The height of a rigid top (positive upward in the same - !! units as depth) [Z ~> m] or [H ~> m or kg m-2] + !! 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) [Z ~> m] or [H ~> m or kg m-2] - real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose + !! units as depth) [H ~> m or kg m-2] + 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] @@ -116,22 +121,10 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & real, dimension(nz+1) :: xTmp ! Temporary positions [H ~> m or kg m-2] real, dimension(CS%nk) :: h_new ! New thicknesses [H ~> m or kg m-2] real, dimension(CS%nk+1) :: x1 ! Interface heights [H ~> m or kg m-2] - real :: z0_top, eta ! Thicknesses or heights [Z ~> m] or [H ~> m or kg m-2] ! Construct source column with vanished layers removed (stored in h_nv) call copy_finite_thicknesses(nz, h, CS%min_thickness, count_nonzero_layers, h_nv, mapping) - z0_top = 0. - eta=0.0 - if (present(z_rigid_top)) then - z0_top = z_rigid_top - eta=z0_top - if (present(eta_orig)) then - eta=eta_orig - endif - endif - - if (count_nonzero_layers > 1) then xTmp(1) = 0.0 do k = 1,count_nonzero_layers @@ -206,11 +199,11 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ integer, intent(in) :: nz !< Number of levels real, intent(in) :: depth !< Depth of ocean bottom [Z ~> m] real, dimension(nz), intent(in) :: h !< Layer thicknesses in Z coordinates [Z ~> m] - real, dimension(nz), intent(in) :: T !< T for column [degC] - real, dimension(nz), intent(in) :: S !< S for column [ppt] + real, dimension(nz), intent(in) :: T !< T for column [C ~> degC] + 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 - real, optional, intent(in) :: h_neglect !< A negligibly small width for the + real, dimension(nz+1), intent(inout) :: zInterface !< Absolute positions of interfaces [Z ~> m] + 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 @@ -224,8 +217,7 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ real, dimension(nz+1) :: x0, x1, xTmp ! Temporary interface heights [Z ~> m] real, dimension(nz) :: pres ! The pressure used in the equation of state [R L2 T-2 ~> Pa]. real, dimension(nz) :: densities ! Layer densities [R ~> kg m-3] - real, dimension(nz) :: T_tmp, S_tmp ! A temporary profile of temperature [degC] and salinity [ppt]. - real, dimension(nz) :: Tmp ! A temporary variable holding a remapped variable. + real, dimension(nz) :: T_tmp, S_tmp ! A temporary profile of temperature [C ~> degC] and salinity [S ~> ppt]. real, dimension(nz) :: h0, h1, hTmp ! Temporary thicknesses [Z ~> m] real :: deviation ! When iterating to determine the final grid, this is the ! deviation between two successive grids [Z ~> m]. @@ -263,7 +255,7 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ enddo ! Compute densities within current water column - call calculate_density( T_tmp, S_tmp, pres, densities, eqn_of_state) + call calculate_density(T_tmp, S_tmp, pres, densities, eqn_of_state) do k = 1,count_nonzero_layers densities(k) = densities(mapping(k)) @@ -282,11 +274,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, Tmp, h_neglect, h_neglect_edge) - S_tmp(:) = Tmp(:) + call remapping_core_h(remapCS, nz, h0, S, nz, h1, S_tmp) - call remapping_core_h(remapCS, nz, h0, T, nz, h1, Tmp, h_neglect, h_neglect_edge) - T_tmp(:) = Tmp(:) + call remapping_core_h(remapCS, nz, h0, T, nz, h1, T_tmp) ! Compute the deviation between two successive grids deviation = 0.0 @@ -374,17 +364,19 @@ end subroutine copy_finite_thicknesses subroutine old_inflate_layers_1d( min_thickness, nk, h ) ! Argument - real, intent(in) :: min_thickness !< Minimum allowed thickness [H ~> m or kg m-2] + real, intent(in) :: min_thickness !< Minimum allowed thickness [H ~> m or kg m-2] or other units integer, intent(in) :: nk !< Number of layers in the grid - real, dimension(:), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(:), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] or other units ! Local variable integer :: k integer :: k_found integer :: count_nonzero_layers - real :: delta - real :: correction - real :: maxThickness + real :: delta ! An increase to a layer to increase it to the minimum thickness in the + ! same units as h, often [H ~> m or kg m-2] + real :: correction ! The accumulated correction that will be applied to the thickest layer + ! to give mass conservation in the same units as h, often [H ~> m or kg m-2] + real :: maxThickness ! The thickness of the thickest layer in the same units as h, often [H ~> m or kg m-2] ! Count number of nonzero layers count_nonzero_layers = 0 diff --git a/src/ALE/coord_sigma.F90 b/src/ALE/coord_sigma.F90 index 19c3213996..60e05654d9 100644 --- a/src/ALE/coord_sigma.F90 +++ b/src/ALE/coord_sigma.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Regrid columns for the sigma coordinate module coord_sigma -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_error_handler, only : MOM_error, FATAL implicit none ; private @@ -13,10 +15,10 @@ module coord_sigma !> Number of levels integer :: nk - !> Minimum thickness allowed for layers + !> Minimum thickness allowed for layers [H ~> m or kg m-2] real :: min_thickness - !> Target coordinate resolution, nondimensional + !> Target coordinate resolution [nondim] real, allocatable, dimension(:) :: coordinateResolution end type sigma_CS diff --git a/src/ALE/coord_slight.F90 b/src/ALE/coord_slight.F90 deleted file mode 100644 index 23a390456e..0000000000 --- a/src/ALE/coord_slight.F90 +++ /dev/null @@ -1,735 +0,0 @@ -!> Regrid columns for the SLight coordinate -module coord_slight - -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_error_handler, only : MOM_error, FATAL -use MOM_EOS, only : EOS_type, calculate_compress -use MOM_EOS, only : calculate_density, calculate_density_derivs -use regrid_interp, only : interp_CS_type, regridding_set_ppolys -use regrid_interp, only : NR_ITERATIONS, NR_TOLERANCE, DEGREE_MAX - -implicit none ; private - -!> Control structure containing required parameters for the SLight coordinate -type, public :: slight_CS ; private - - !> Number of layers/levels - integer :: nk - - !> Minimum thickness allowed when building the new grid through regridding [H ~> m or kg m-2] - real :: min_thickness - - !> Reference pressure for potential density calculations [R L2 T-2 ~> Pa] - real :: ref_pressure - - !> Fraction (between 0 and 1) of compressibility to add to potential density - !! profiles when interpolating for target grid positions. [nondim] - real :: compressibility_fraction - - ! The following 4 parameters were introduced for use with the SLight coordinate: - !> Depth over which to average to determine the mixed layer potential density [H ~> m or kg m-2] - real :: Rho_ML_avg_depth - - !> Number of layers to offset the mixed layer density to find resolved stratification [nondim] - real :: nlay_ml_offset - - !> The number of fixed-thickness layers at the top of the model - integer :: nz_fixed_surface = 2 - - !> The fixed resolution in the topmost SLight_nkml_min layers [H ~> m or kg m-2] - real :: dz_ml_min - - !> If true, detect regions with much weaker stratification in the coordinate - !! than based on in-situ density, and use a stretched coordinate there. - logical :: fix_haloclines = .false. - - !> A length scale over which to filter T & S when looking for spuriously - !! unstable water mass profiles [H ~> m or kg m-2]. - real :: halocline_filter_length - - !> A value of the stratification ratio that defines a problematic halocline region [nondim]. - real :: halocline_strat_tol - - !> Nominal density of interfaces [R ~> kg m-3]. - real, allocatable, dimension(:) :: target_density - - !> Maximum depths of interfaces [H ~> m or kg m-2]. - real, allocatable, dimension(:) :: max_interface_depths - - !> Maximum thicknesses of layers [H ~> m or kg m-2]. - real, allocatable, dimension(:) :: max_layer_thickness - - !> Interpolation control structure - type(interp_CS_type) :: interp_CS -end type slight_CS - -public init_coord_slight, set_slight_params, build_slight_column, end_coord_slight - -contains - -!> Initialise a slight_CS with pointers to parameters -subroutine init_coord_slight(CS, nk, ref_pressure, target_density, interp_CS, m_to_H) - type(slight_CS), pointer :: CS !< Unassociated pointer to hold the control structure - integer, intent(in) :: nk !< Number of layers in the grid - real, intent(in) :: ref_pressure !< Coordinate reference pressure [R L2 T-2 ~> Pa] - real, dimension(:), intent(in) :: target_density !< Nominal density of interfaces [R ~> kg m-3] - type(interp_CS_type), intent(in) :: interp_CS !< Controls for interpolation - real, optional, intent(in) :: m_to_H !< A conversion factor from m to the units of thicknesses - - real :: m_to_H_rescale ! A unit conversion factor. - - if (associated(CS)) call MOM_error(FATAL, "init_coord_slight: CS already associated!") - allocate(CS) - allocate(CS%target_density(nk+1)) - - m_to_H_rescale = 1.0 ; if (present(m_to_H)) m_to_H_rescale = m_to_H - - CS%nk = nk - CS%ref_pressure = ref_pressure - CS%target_density(:) = target_density(:) - CS%interp_CS = interp_CS - - ! Set real parameter default values - CS%compressibility_fraction = 0. ! Nondim. - CS%Rho_ML_avg_depth = 1.0 * m_to_H_rescale - CS%nlay_ml_offset = 2.0 ! Nondim. - CS%dz_ml_min = 1.0 * m_to_H_rescale - CS%halocline_filter_length = 2.0 * m_to_H_rescale - CS%halocline_strat_tol = 0.25 ! Nondim. - -end subroutine init_coord_slight - -!> This subroutine deallocates memory in the control structure for the coord_slight module -subroutine end_coord_slight(CS) - type(slight_CS), pointer :: CS !< Coordinate control structure - - ! nothing to do - if (.not. associated(CS)) return - deallocate(CS%target_density) - deallocate(CS) -end subroutine end_coord_slight - -!> This subroutine can be used to set the parameters for the coord_slight module -subroutine set_slight_params(CS, max_interface_depths, max_layer_thickness, & - min_thickness, compressibility_fraction, dz_ml_min, & - nz_fixed_surface, Rho_ML_avg_depth, nlay_ML_offset, fix_haloclines, & - halocline_filter_length, halocline_strat_tol, interp_CS) - type(slight_CS), pointer :: CS !< Coordinate control structure - real, dimension(:), & - optional, intent(in) :: max_interface_depths !< Maximum depths of interfaces [H ~> m or kg m-2] - real, dimension(:), & - optional, intent(in) :: max_layer_thickness !< Maximum thicknesses of layers [H ~> m or kg m-2] - real, optional, intent(in) :: min_thickness !< Minimum thickness allowed when building the - !! new grid through regridding [H ~> m or kg m-2] - real, optional, intent(in) :: compressibility_fraction !< Fraction (between 0 and 1) of - !! compressibility to add to potential density profiles when - !! interpolating for target grid positions. [nondim] - real, optional, intent(in) :: dz_ml_min !< The fixed resolution in the topmost - !! SLight_nkml_min layers [H ~> m or kg m-2] - integer, optional, intent(in) :: nz_fixed_surface !< The number of fixed-thickness layers at the - !! top of the model - real, optional, intent(in) :: Rho_ML_avg_depth !< Depth over which to average to determine - !! the mixed layer potential density [H ~> m or kg m-2] - real, optional, intent(in) :: nlay_ML_offset !< Number of layers to offset the mixed layer - !! density to find resolved stratification [nondim] - logical, optional, intent(in) :: fix_haloclines !< If true, detect regions with much weaker than - !! based on in-situ density, and use a stretched coordinate there. - real, optional, intent(in) :: halocline_filter_length !< A length scale over which to filter T & S - !! when looking for spuriously unstable water mass profiles [H ~> m or kg m-2]. - real, optional, intent(in) :: halocline_strat_tol !< A value of the stratification ratio that - !! defines a problematic halocline region [nondim]. - type(interp_CS_type), & - optional, intent(in) :: interp_CS !< Controls for interpolation - - if (.not. associated(CS)) call MOM_error(FATAL, "set_slight_params: CS not associated") - - if (present(max_interface_depths)) then - if (size(max_interface_depths) /= CS%nk+1) & - call MOM_error(FATAL, "set_slight_params: max_interface_depths inconsistent size") - allocate(CS%max_interface_depths(CS%nk+1)) - CS%max_interface_depths(:) = max_interface_depths(:) - endif - - if (present(max_layer_thickness)) then - if (size(max_layer_thickness) /= CS%nk) & - call MOM_error(FATAL, "set_slight_params: max_layer_thickness inconsistent size") - allocate(CS%max_layer_thickness(CS%nk)) - CS%max_layer_thickness(:) = max_layer_thickness(:) - endif - - if (present(min_thickness)) CS%min_thickness = min_thickness - if (present(compressibility_fraction)) CS%compressibility_fraction = compressibility_fraction - - if (present(dz_ml_min)) CS%dz_ml_min = dz_ml_min - if (present(nz_fixed_surface)) CS%nz_fixed_surface = nz_fixed_surface - if (present(Rho_ML_avg_depth)) CS%Rho_ML_avg_depth = Rho_ML_avg_depth - if (present(nlay_ML_offset)) CS%nlay_ML_offset = nlay_ML_offset - if (present(fix_haloclines)) CS%fix_haloclines = fix_haloclines - if (present(halocline_filter_length)) CS%halocline_filter_length = halocline_filter_length - if (present(halocline_strat_tol)) then - if (halocline_strat_tol > 1.0) call MOM_error(FATAL, "set_slight_params: "//& - "HALOCLINE_STRAT_TOL must not exceed 1.0.") - CS%halocline_strat_tol = halocline_strat_tol - endif - - if (present(interp_CS)) CS%interp_CS = interp_CS -end subroutine set_slight_params - -!> Build a SLight coordinate column -subroutine build_slight_column(CS, eqn_of_state, H_to_pres, H_subroundoff, & - nz, depth, h_col, T_col, S_col, p_col, z_col, z_col_new, & - h_neglect, h_neglect_edge) - type(slight_CS), intent(in) :: CS !< Coordinate control structure - type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure - real, intent(in) :: H_to_pres !< A conversion factor from thicknesses to - !! scaled pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] - real, intent(in) :: H_subroundoff !< GV%H_subroundoff - integer, intent(in) :: nz !< Number of levels - real, intent(in) :: depth !< Depth of ocean bottom (positive [H ~> m or kg m-2]) - real, dimension(nz), intent(in) :: T_col !< T for column - real, dimension(nz), intent(in) :: S_col !< S for column - real, dimension(nz), intent(in) :: h_col !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(nz), intent(in) :: p_col !< Layer center pressure [R L2 T-2 ~> Pa] - real, dimension(nz+1), intent(in) :: z_col !< Interface positions relative to the surface [H ~> m or kg m-2] - real, dimension(nz+1), intent(inout) :: z_col_new !< Absolute positions of interfaces [H ~> m or kg m-2] - real, optional, 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]. - ! Local variables - real, dimension(nz) :: rho_col ! Layer densities [R ~> kg m-3] - real, dimension(nz) :: T_f, S_f ! Filtered layer temperature [degC] and salinity [ppt] - logical, dimension(nz+1) :: reliable ! If true, this interface is in a reliable position. - real, dimension(nz+1) :: T_int, S_int ! Temperature [degC] and salinity [ppt] interpolated to interfaces. - real, dimension(nz+1) :: rho_tmp ! A temporary density [R ~> kg m-3] - real, dimension(nz+1) :: drho_dp ! The partial derivative of density with pressure [T2 L-2 ~> kg m-3 Pa-1] - real, dimension(nz+1) :: p_IS, p_R ! Pressures [R L2 T-2 ~> Pa] - real, dimension(nz+1) :: drhoIS_dT ! The partial derivative of in situ density with temperature - ! in [R degC-1 ~> kg m-3 degC-1] - real, dimension(nz+1) :: drhoIS_dS ! The partial derivative of in situ density with salinity - ! in [R ppt-1 ~> kg m-3 ppt-1] - real, dimension(nz+1) :: drhoR_dT ! The partial derivative of reference density with temperature - ! in [R degC-1 ~> kg m-3 degC-1] - real, dimension(nz+1) :: drhoR_dS ! The partial derivative of reference density with salinity - ! in [R ppt-1 ~> kg m-3 ppt-1] - real, dimension(nz+1) :: strat_rat - real :: H_to_cPa ! A conversion factor from thicknesses to the compressibility fraction times - ! the units of pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] - real :: drIS, drR ! In situ and reference density differences [R ~> kg m-3] - real :: Fn_now, I_HStol, Fn_zero_val ! Nondimensional variables [nondim] - real :: z_int_unst ! The depth where the stratification allows the interior grid to start [H ~> m or kg m-2] - real :: dz ! A uniform layer thickness in very shallow water [H ~> m or kg m-2]. - real :: dz_ur ! The total thickness of an unstable region [H ~> m or kg m-2]. - real :: wgt, cowgt ! A weight and its complement [nondim]. - real :: rho_ml_av ! The average potential density in a near-surface region [R ~> kg m-3]. - real :: H_ml_av ! A thickness to try to use in taking the near-surface average [H ~> m or kg m-2]. - real :: rho_x_z ! A cumulative integral of a density [R H ~> kg m-2 or kg2 m-5]. - real :: z_wt ! The thickness actually used in taking the near-surface average [H ~> m or kg m-2]. - real :: k_interior ! The (real) value of k where the interior grid starts [nondim]. - real :: k_int2 ! The (real) value of k where the interior grid starts [nondim]. - real :: z_interior ! The depth where the interior grid starts [H ~> m or kg m-2]. - real :: z_ml_fix ! The depth at which the fixed-thickness near-surface layers end [H ~> m or kg m-2]. - real :: dz_dk ! The thickness of layers between the fixed-thickness - ! near-surface layars and the interior [H ~> m or kg m-2]. - real :: Lfilt ! A filtering lengthscale [H ~> m or kg m-2]. - logical :: maximum_depths_set ! If true, the maximum depths of interface have been set. - logical :: maximum_h_set ! If true, the maximum layer thicknesses have been set. - real :: k2_used, k2here, dz_sum, z_max - integer :: k2 - real :: h_tr, b_denom_1, b1, d1 ! Temporary variables used by the tridiagonal solver. - real, dimension(nz) :: c1 ! Temporary variables used by the tridiagonal solver. - integer :: kur1, kur2 ! The indicies at the top and bottom of an unreliable region. - integer :: kur_ss ! The index to start with in the search for the next unstable region. - integer :: i, j, k, nkml - - maximum_depths_set = allocated(CS%max_interface_depths) - maximum_h_set = allocated(CS%max_layer_thickness) - - if (z_col(nz+1) - z_col(1) < nz*CS%min_thickness) then - ! This is a nearly massless total depth, so distribute the water evenly. - dz = (z_col(nz+1) - z_col(1)) / real(nz) - do K=2,nz ; z_col_new(K) = z_col(1) + dz*real(K-1) ; enddo - else - call calculate_density(T_col, S_col, p_col, rho_col, eqn_of_state) - - ! Find the locations of the target potential densities, flagging - ! locations in apparently unstable regions as not reliable. - call rho_interfaces_col(rho_col, h_col, z_col, CS%target_density, nz, & - z_col_new, CS, reliable, debug=.true., & - h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) - - ! Ensure that the interfaces are at least CS%min_thickness apart. - if (CS%min_thickness > 0.0) then - ! Move down interfaces below overly thin layers. - do K=2,nz ; if (z_col_new(K) < z_col_new(K-1) + CS%min_thickness) then - z_col_new(K) = z_col_new(K-1) + CS%min_thickness - endif ; enddo - ! Now move up any interfaces that are too close to the bottom. - do K=nz,2,-1 ; if (z_col_new(K) > z_col_new(K+1) - CS%min_thickness) then - z_col_new(K) = z_col_new(K+1) - CS%min_thickness - else - exit ! No more interfaces can be too close to the bottom. - endif ; enddo - endif - - ! Fix up the unreliable regions. - kur_ss = 2 ! reliable(1) and reliable(nz+1) must always be true. - do - ! Search for the uppermost unreliable interface postion. - kur1 = nz+2 - do K=kur_ss,nz ; if (.not.reliable(K)) then - kur1 = K ; exit - endif ; enddo - if (kur1 > nz) exit ! Everything is now reliable. - - kur2 = kur1-1 ! For error checking. - do K=kur1+1,nz+1 ; if (reliable(K)) then - kur2 = K-1 ; kur_ss = K ; exit - endif ; enddo - if (kur2 < kur1) call MOM_error(FATAL, "Bad unreliable range.") - - dz_ur = z_col_new(kur2+1) - z_col_new(kur1-1) - ! drho = CS%target_density(kur2+1) - CS%target_density(kur1-1) - ! Perhaps reset the wgt and cowgt depending on how bad the old interface - ! locations were. - wgt = 1.0 ; cowgt = 0.0 ! = 1.0-wgt - do K=kur1,kur2 - z_col_new(K) = cowgt*z_col_new(K) + & - wgt * (z_col_new(kur1-1) + dz_ur*(K - (kur1-1)) / ((kur2 - kur1) + 2)) - enddo - enddo - - ! Determine which interfaces are in the s-space region and the depth extent - ! of this region. - z_wt = 0.0 ; rho_x_z = 0.0 - H_ml_av = CS%Rho_ml_avg_depth - do k=1,nz - if (z_wt + h_col(k) >= H_ml_av) then - rho_x_z = rho_x_z + rho_col(k) * (H_ml_av - z_wt) - z_wt = H_ml_av - exit - else - rho_x_z = rho_x_z + rho_col(k) * h_col(k) - z_wt = z_wt + h_col(k) - endif - enddo - if (z_wt > 0.0) rho_ml_av = rho_x_z / z_wt - - nkml = CS%nz_fixed_surface - ! Find the interface that matches rho_ml_av. - if (rho_ml_av <= CS%target_density(nkml)) then - k_interior = CS%nlay_ml_offset + real(nkml) - elseif (rho_ml_av > CS%target_density(nz+1)) then - k_interior = real(nz+1) - else ; do K=nkml,nz - if ((rho_ml_av >= CS%target_density(K)) .and. & - (rho_ml_av < CS%target_density(K+1))) then - k_interior = (CS%nlay_ml_offset + K) + & - (rho_ml_av - CS%target_density(K)) / & - (CS%target_density(K+1) - CS%target_density(K)) - exit - endif - enddo ; endif - if (k_interior > real(nz+1)) k_interior = real(nz+1) - - ! Linearly interpolate to find z_interior. This could be made more sophisticated. - K = int(ceiling(k_interior)) - z_interior = (K-k_interior)*z_col_new(K-1) + (1.0+(k_interior-K))*z_col_new(K) - - if (CS%fix_haloclines) then - ! ! Identify regions above the reference pressure where the chosen - ! ! potential density significantly underestimates the actual - ! ! stratification, and use these to find a second estimate of - ! ! z_int_unst and k_interior. - - if (CS%halocline_filter_length > 0.0) then - Lfilt = CS%halocline_filter_length - - ! Filter the temperature and salnity with a fixed lengthscale. - h_tr = h_col(1) + H_subroundoff - b1 = 1.0 / (h_tr + Lfilt) ; d1 = h_tr * b1 - T_f(1) = (b1*h_tr)*T_col(1) ; S_f(1) = (b1*h_tr)*S_col(1) - do k=2,nz - c1(k) = Lfilt * b1 - h_tr = h_col(k) + H_subroundoff ; b_denom_1 = h_tr + d1*Lfilt - b1 = 1.0 / (b_denom_1 + Lfilt) ; d1 = b_denom_1 * b1 - T_f(k) = b1 * (h_tr*T_col(k) + Lfilt*T_f(k-1)) - S_f(k) = b1 * (h_tr*S_col(k) + Lfilt*S_f(k-1)) - enddo - do k=nz-1,1,-1 - T_f(k) = T_f(k) + c1(k+1)*T_f(k+1) ; S_f(k) = S_f(k) + c1(k+1)*S_f(k+1) - enddo - else - do k=1,nz ; T_f(k) = T_col(k) ; S_f(k) = S_col(k) ; enddo - endif - - T_int(1) = T_f(1) ; S_int(1) = S_f(1) - do K=2,nz - T_int(K) = 0.5*(T_f(k-1) + T_f(k)) ; S_int(K) = 0.5*(S_f(k-1) + S_f(k)) - p_IS(K) = z_col(K) * H_to_pres - p_R(K) = CS%ref_pressure + CS%compressibility_fraction * ( p_IS(K) - CS%ref_pressure ) - enddo - T_int(nz+1) = T_f(nz) ; S_int(nz+1) = S_f(nz) - p_IS(nz+1) = z_col(nz+1) * H_to_pres - call calculate_density_derivs(T_int, S_int, p_IS, drhoIS_dT, drhoIS_dS, & - eqn_of_state, (/2,nz/) ) - call calculate_density_derivs(T_int, S_int, p_R, drhoR_dT, drhoR_dS, & - eqn_of_state, (/2,nz/) ) - if (CS%compressibility_fraction > 0.0) then - call calculate_compress(T_int, S_int, p_R(:), rho_tmp, drho_dp, 2, nz-1, eqn_of_state) - else - do K=2,nz ; drho_dp(K) = 0.0 ; enddo - endif - - H_to_cPa = CS%compressibility_fraction * H_to_pres - strat_rat(1) = 1.0 - do K=2,nz - drIS = drhoIS_dT(K) * (T_f(k) - T_f(k-1)) + & - drhoIS_dS(K) * (S_f(k) - S_f(k-1)) - drR = (drhoR_dT(K) * (T_f(k) - T_f(k-1)) + & - drhoR_dS(K) * (S_f(k) - S_f(k-1))) + & - drho_dp(K) * (H_to_cPa*0.5*(h_col(k) + h_col(k-1))) - - if (drIS <= 0.0) then - strat_rat(K) = 2.0 ! Maybe do this? => ; if (drR < 0.0) strat_rat(K) = -2.0 - else - strat_rat(K) = 2.0*max(drR,0.0) / (drIS + abs(drR)) - endif - enddo - strat_rat(nz+1) = 1.0 - - z_int_unst = 0.0 ; Fn_now = 0.0 - Fn_zero_val = min(2.0*CS%halocline_strat_tol, & - 0.5*(1.0 + CS%halocline_strat_tol)) - if (CS%halocline_strat_tol > 0.0) then - ! Use Adcroft's reciprocal rule. - I_HStol = 0.0 ; if (Fn_zero_val - CS%halocline_strat_tol > 0.0) & - I_HStol = 1.0 / (Fn_zero_val - CS%halocline_strat_tol) - do k=nz,1,-1 ; if (CS%ref_pressure > p_IS(k+1)) then - z_int_unst = z_int_unst + Fn_now * h_col(k) - if (strat_rat(K) <= Fn_zero_val) then - if (strat_rat(K) <= CS%halocline_strat_tol) then ; Fn_now = 1.0 - else - Fn_now = max(Fn_now, (Fn_zero_val - strat_rat(K)) * I_HStol) - endif - endif - endif ; enddo - else - do k=nz,1,-1 ; if (CS%ref_pressure > p_IS(k+1)) then - z_int_unst = z_int_unst + Fn_now * h_col(k) - if (strat_rat(K) <= CS%halocline_strat_tol) Fn_now = 1.0 - endif ; enddo - endif - - if (z_interior < z_int_unst) then - ! Find a second estimate of the extent of the s-coordinate region. - kur1 = max(int(ceiling(k_interior)),2) - if (z_col_new(kur1-1) < z_interior) then - k_int2 = kur1 - do K = kur1,nz+1 ; if (z_col_new(K) >= z_int_unst) then - ! This is linear interpolation again. - if (z_col_new(K-1) >= z_int_unst) & - call MOM_error(FATAL,"build_grid_SLight, bad halocline structure.") - k_int2 = real(K-1) + (z_int_unst - z_col_new(K-1)) / & - (z_col_new(K) - z_col_new(K-1)) - exit - endif ; enddo - if (z_col_new(nz+1) < z_int_unst) then - ! This should be unnecessary. - z_int_unst = z_col_new(nz+1) ; k_int2 = real(nz+1) - endif - - ! Now take the larger values. - if (k_int2 > k_interior) then - k_interior = k_int2 ; z_interior = z_int_unst - endif - endif - endif - endif ! fix_haloclines - - z_col_new(1) = 0.0 - do K=2,nkml+1 - z_col_new(K) = min((K-1)*CS%dz_ml_min, & - z_col_new(nz+1) - CS%min_thickness*(nz+1-K)) - enddo - z_ml_fix = z_col_new(nkml+1) - if (z_interior > z_ml_fix) then - dz_dk = (z_interior - z_ml_fix) / (k_interior - (nkml+1)) - do K=nkml+2,int(floor(k_interior)) - z_col_new(K) = z_ml_fix + dz_dk * (K - (nkml+1)) - enddo - else ! The fixed-thickness z-region penetrates into the interior. - do K=nkml+2,nz - if (z_col_new(K) <= z_col_new(CS%nz_fixed_surface+1)) then - z_col_new(K) = z_col_new(CS%nz_fixed_surface+1) - else ; exit ; endif - enddo - endif - - if (maximum_depths_set .and. maximum_h_set) then ; do k=2,nz - ! The loop bounds are 2 & nz so the top and bottom interfaces do not move. - ! Recall that z_col_new is positive downward. - z_col_new(K) = min(z_col_new(K), CS%max_interface_depths(K), & - z_col_new(K-1) + CS%max_layer_thickness(k-1)) - enddo ; elseif (maximum_depths_set) then ; do K=2,nz - z_col_new(K) = min(z_col_new(K), CS%max_interface_depths(K)) - enddo ; elseif (maximum_h_set) then ; do k=2,nz - z_col_new(K) = min(z_col_new(K), z_col_new(K-1) + CS%max_layer_thickness(k-1)) - enddo ; endif - - endif ! Total thickness exceeds nz*CS%min_thickness. - -end subroutine build_slight_column - -!> Finds the new interface locations in a column of water that match the -!! prescribed target densities. -subroutine rho_interfaces_col(rho_col, h_col, z_col, rho_tgt, nz, z_col_new, & - CS, reliable, debug, h_neglect, h_neglect_edge) - integer, intent(in) :: nz !< Number of layers - real, dimension(nz), intent(in) :: rho_col !< Initial layer reference densities [R ~> kg m-3]. - real, dimension(nz), intent(in) :: h_col !< Initial layer thicknesses [H ~> m or kg m-2]. - real, dimension(nz+1), intent(in) :: z_col !< Initial interface heights [H ~> m or kg m-2]. - real, dimension(nz+1), intent(in) :: rho_tgt !< Interface target densities. - real, dimension(nz+1), intent(inout) :: z_col_new !< New interface heights [H ~> m or kg m-2]. - type(slight_CS), intent(in) :: CS !< Coordinate control structure - logical, dimension(nz+1), intent(inout) :: reliable !< If true, the interface positions - !! are well defined from a stable region. - logical, optional, intent(in) :: debug !< If present and true, do debugging checks. - real, optional, 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] - - real, dimension(nz+1) :: ru_max_int ! The maximum and minimum densities in - real, dimension(nz+1) :: ru_min_int ! an unstable region around an interface [R ~> kg m-3]. - real, dimension(nz) :: ru_max_lay ! The maximum and minimum densities in - real, dimension(nz) :: ru_min_lay ! an unstable region containing a layer [R ~> kg m-3]. - real, dimension(nz,2) :: ppoly_i_E ! Edge value of polynomial [R ~> kg m-3] - real, dimension(nz,2) :: ppoly_i_S ! Edge slope of polynomial [R H-1 ~> kg m-4 or m-1] - real, dimension(nz,DEGREE_MAX+1) :: ppoly_i_coefficients ! Coefficients of polynomial [R ~> kg m-3] - logical, dimension(nz) :: unstable_lay ! If true, this layer is in an unstable region. - logical, dimension(nz+1) :: unstable_int ! If true, this interface is in an unstable region. - real :: rt ! The current target density [R ~> kg m-3]. - real :: zf ! The fractional z-position within a layer of the target density [nondim]. - real :: rfn ! The target density relative to the interpolated density [R ~> kg m-3] - real :: a(5) ! Coefficients of a local polynomial minus the target density [R ~> kg m-3]. - real :: zf1, zf2 ! Two previous estimates of zf [nondim] - real :: rfn1, rfn2 ! Values of rfn at zf1 and zf2 [R ~> kg m-3] - real :: drfn_dzf ! The partial derivative of rfn with zf [R ~> kg m-3] - real :: sgn, delta_zf, zf_prev ! [nondim] - real :: tol ! The tolerance for convergence of zf [nondim] - logical :: k_found ! If true, the position has been found. - integer :: k_layer ! The index of the stable layer containing an interface. - integer :: ppoly_degree - integer :: k, k1, k1_min, itt, max_itt, m - - real :: z_sgn ! 1 or -1, depending on whether z increases with increasing K. - logical :: debugging - - debugging = .false. ; if (present(debug)) debugging = debug - max_itt = NR_ITERATIONS - tol = NR_TOLERANCE - - z_sgn = 1.0 ; if ( z_col(1) > z_col(nz+1) ) z_sgn = -1.0 - if (debugging) then - do K=1,nz - if (abs((z_col(K+1) - z_col(K)) - z_sgn*h_col(k)) > & - 1.0e-14*(abs(z_col(K+1)) + abs(z_col(K)) + abs(h_col(k))) ) & - call MOM_error(FATAL, "rho_interfaces_col: Inconsistent z_col and h_col") - enddo - endif - - if ( z_col(1) == z_col(nz+1) ) then - ! This is a massless column! - do K=1,nz+1 ; z_col_new(K) = z_col(1) ; reliable(K) = .true. ; enddo - return - endif - - ! This sets up the piecewise polynomials based on the rho_col profile. - call regridding_set_ppolys(CS%interp_CS, rho_col, nz, h_col, ppoly_i_E, ppoly_i_S, & - ppoly_i_coefficients, ppoly_degree, h_neglect, h_neglect_edge) - - ! Determine the density ranges of unstably stratified segments. - ! Interfaces that start out in an unstably stratified segment can - ! only escape if they are outside of the bounds of that segment, and no - ! interfaces are ever mapped into an unstable segment. - unstable_int(1) = .false. - ru_max_int(1) = ppoly_i_E(1,1) - - unstable_lay(1) = (ppoly_i_E(1,1) > ppoly_i_E(1,2)) - ru_max_lay(1) = max(ppoly_i_E(1,1), ppoly_i_E(1,2)) - - do K=2,nz - unstable_int(K) = (ppoly_i_E(k-1,2) > ppoly_i_E(k,1)) - ru_max_int(K) = max(ppoly_i_E(k-1,2), ppoly_i_E(k,1)) - ru_min_int(K) = min(ppoly_i_E(k-1,2), ppoly_i_E(k,1)) - if (unstable_int(K) .and. unstable_lay(k-1)) & - ru_max_int(K) = max(ru_max_lay(k-1), ru_max_int(K)) - - unstable_lay(k) = (ppoly_i_E(k,1) > ppoly_i_E(k,2)) - ru_max_lay(k) = max(ppoly_i_E(k,1), ppoly_i_E(k,2)) - ru_min_lay(k) = min(ppoly_i_E(k,1), ppoly_i_E(k,2)) - if (unstable_lay(k) .and. unstable_int(K)) & - ru_max_lay(k) = max(ru_max_int(K), ru_max_lay(k)) - enddo - unstable_int(nz+1) = .false. - ru_min_int(nz+1) = ppoly_i_E(nz,2) - - do K=nz,1,-1 - if (unstable_lay(k) .and. unstable_int(K+1)) & - ru_min_lay(k) = min(ru_min_int(K+1), ru_min_lay(k)) - - if (unstable_int(K) .and. unstable_lay(k)) & - ru_min_int(K) = min(ru_min_lay(k), ru_min_int(K)) - enddo - - z_col_new(1) = z_col(1) ; reliable(1) = .true. - k1_min = 1 - do K=2,nz ! Find the locations of the various target densities for the interfaces. - rt = rho_tgt(K) - k_layer = -1 - k_found = .false. - - ! Many light layers are found at the top, so start there. - if (rt <= ppoly_i_E(k1_min,1)) then - z_col_new(K) = z_col(k1_min) - k_found = .true. - ! Do not change k1_min for the next layer. - elseif (k1_min == nz+1) then - z_col_new(K) = z_col(nz+1) - else - ! Start with the previous location and search outward. - if (unstable_int(K) .and. (rt >= ru_min_int(K)) .and. (rt <= ru_max_int(K))) then - ! This interface started in an unstable region and should not move due to remapping. - z_col_new(K) = z_col(K) ; reliable(K) = .false. - k1_min = K ; k_found = .true. - elseif ((rt >= ppoly_i_E(k-1,2)) .and. (rt <= ppoly_i_E(k,1))) then - ! This interface is already in the right place and does not move. - z_col_new(K) = z_col(K) ; reliable(K) = .true. - k1_min = K ; k_found = .true. - elseif (rt < ppoly_i_E(k-1,2)) then ! Search upward - do k1=K-1,k1_min,-1 - ! Check whether rt is in layer k. - if ((rt < ppoly_i_E(k1,2)) .and. (rt > ppoly_i_E(k1,1))) then - ! rt is in layer k. - k_layer = k1 - k1_min = k1 ; k_found = .true. ; exit - elseif (unstable_lay(k1) .and. (rt >= ru_min_lay(k1)) .and. (rt <= ru_max_lay(K1))) then - ! rt would be found at unstable layer that it can not penetrate. - ! It is possible that this can never happen? - z_col_new(K) = z_col(K1+1) ; reliable(K) = .false. - k1_min = k1 ; k_found = .true. ; exit - endif - ! Check whether rt is at interface K. - if (k1 > 1) then ; if ((rt <= ppoly_i_E(k1,1)) .and. (rt >= ppoly_i_E(k1-1,2))) then - ! rt is at interface K1 - z_col_new(K) = z_col(K1) ; reliable(K) = .true. - k1_min = k1 ; k_found = .true. ; exit - elseif (unstable_int(K1) .and. (rt >= ru_min_int(k1)) .and. (rt <= ru_max_int(K1))) then - ! rt would be found at an unstable interface that it can not pass. - ! It is possible that this can never happen? - z_col_new(K) = z_col(K1) ; reliable(K) = .false. - k1_min = k1 ; k_found = .true. ; exit - endif ; endif - enddo - - if (.not.k_found) then - ! This should not happen unless k1_min = 1. - if (k1_min < 2) then - z_col_new(K) = z_col(k1_min) - else - z_col_new(K) = z_col(k1_min) - endif - endif - - else ! Search downward - do k1=K,nz - if ((rt < ppoly_i_E(k1,2)) .and. (rt > ppoly_i_E(k1,1))) then - ! rt is in layer k. - k_layer = k1 - k1_min = k1 ; k_found = .true. ; exit - elseif (unstable_lay(k1) .and. (rt >= ru_min_lay(k1)) .and. (rt <= ru_max_lay(K1))) then - ! rt would be found at unstable layer that it can not penetrate. - ! It is possible that this can never happen? - z_col_new(K) = z_col(K1) - reliable(K) = .false. - k1_min = k1 ; k_found = .true. ; exit - endif - if (k1 < nz) then ; if ((rt <= ppoly_i_E(k1+1,1)) .and. (rt >= ppoly_i_E(k1,2))) then - ! rt is at interface K1+1 - - z_col_new(K) = z_col(K1+1) ; reliable(K) = .true. - k1_min = k1+1 ; k_found = .true. ; exit - elseif (unstable_int(K1+1) .and. (rt >= ru_min_int(k1+1)) .and. (rt <= ru_max_int(K1+1))) then - ! rt would be found at an unstable interface that it can not pass. - ! It is possible that this can never happen? - z_col_new(K) = z_col(K1+1) - reliable(K) = .false. - k1_min = k1+1 ; k_found = .true. ; exit - endif ; endif - enddo - if (.not.k_found) then - z_col_new(K) = z_col(nz+1) - if (rt >= ppoly_i_E(nz,2)) then - reliable(K) = .true. - else - reliable(K) = .false. - endif - endif - endif - - if (k_layer > 0) then ! The new location is inside of layer k_layer. - ! Note that this is coded assuming that this layer is stably stratified. - if (.not.(ppoly_i_E(k1,2) > ppoly_i_E(k1,1))) call MOM_error(FATAL, & - "build_grid_SLight: Erroneously searching for an interface in an unstratified layer.") - - ! Use the false position method to find the location (degree <= 1) or the first guess. - zf = (rt - ppoly_i_E(k1,1)) / (ppoly_i_E(k1,2) - ppoly_i_E(k1,1)) - - if (ppoly_degree > 1) then ! Iterate to find the solution. - a(:) = 0.0 ; a(1) = ppoly_i_coefficients(k_layer,1) - rt - do m=2,ppoly_degree+1 ; a(m) = ppoly_i_coefficients(k_layer,m) ; enddo - ! Bracket the root. - zf1 = 0.0 ; rfn1 = a(1) - zf2 = 1.0 ; rfn2 = a(1) + (a(2) + (a(3) + (a(4) + a(5)))) - if (rfn1 * rfn2 > 0.0) call MOM_error(FATAL, "build_grid_SLight: Bad bracketing.") - - do itt=1,max_itt - rfn = a(1) + zf*(a(2) + zf*(a(3) + zf*(a(4) + zf*a(5)))) - ! Reset one of the ends of the bracket. - if (rfn * rfn1 > 0.0) then - zf1 = zf ; rfn1 = rfn - else - zf2 = zf ; rfn2 = rfn - endif - if (rfn1 == rfn2) exit - - drfn_dzf = (a(2) + zf*(2.0*a(3) + zf*(3.0*a(4) + zf*4.0*a(5)))) - sgn = 1.0 ; if (drfn_dzf < 0.0) sgn = -1.0 - - if ((sgn*(zf - rfn) >= zf1 * abs(drfn_dzf)) .and. & - (sgn*(zf - rfn) <= zf2 * abs(drfn_dzf))) then - delta_zf = -rfn / drfn_dzf - zf = zf + delta_zf - else ! Newton's method goes out of bounds, so use a false position method estimate - zf_prev = zf - zf = ( rfn2 * zf1 - rfn1 * zf2 ) / (rfn2 - rfn1) - delta_zf = zf - zf_prev - endif - - if (abs(delta_zf) < tol) exit - enddo - endif - z_col_new(K) = z_col(k_layer) + zf * z_sgn * h_col(k_layer) - reliable(K) = .true. - endif - - endif - - enddo - z_col_new(nz+1) = z_col(nz+1) ; reliable(nz+1) = .true. - -end subroutine rho_interfaces_col - -end module coord_slight diff --git a/src/ALE/coord_zlike.F90 b/src/ALE/coord_zlike.F90 index f2ed7f0035..ad7772d7ae 100644 --- a/src/ALE/coord_zlike.F90 +++ b/src/ALE/coord_zlike.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Regrid columns for a z-like coordinate (z-star, z-level) module coord_zlike -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_error_handler, only : MOM_error, FATAL implicit none ; private @@ -67,13 +69,15 @@ subroutine build_zstar_column(CS, depth, total_thickness, zInterface, & !! output units), units may be [Z ~> m] or [H ~> m or kg m-2] real, intent(in) :: total_thickness !< Column thickness (positive definite in the same !! units as depth) [Z ~> m] or [H ~> m or kg m-2] - real, dimension(CS%nk+1), intent(inout) :: zInterface !< Absolute positions of interfaces + real, dimension(CS%nk+1), intent(inout) :: zInterface !< Absolute positions of interfaces (in the same + !! units as depth) [Z ~> m] or [H ~> m or kg m-2] real, optional, intent(in) :: z_rigid_top !< The height of a rigid top (positive upward in the same !! units as depth) [Z ~> m] or [H ~> m or kg m-2] - real, optional, intent(in) :: eta_orig !< The actual original height of the top in the same + real, optional, intent(in) :: eta_orig !< The actual original height of the top (in the same !! units as depth) [Z ~> m] or [H ~> m or kg m-2] real, optional, intent(in) :: zScale !< Scaling factor from the target coordinate resolution - !! in Z to desired units for zInterface, perhaps Z_to_H + !! in Z to desired units for zInterface, perhaps Z_to_H, + !! often [nondim] or [H Z-1 ~> 1 or kg m-3] ! Local variables real :: eta ! Free surface height [Z ~> m] or [H ~> m or kg m-2] real :: stretching ! A stretching factor for the coordinate [nondim] diff --git a/src/ALE/polynomial_functions.F90 b/src/ALE/polynomial_functions.F90 index e5c90fe31d..0b232dc359 100644 --- a/src/ALE/polynomial_functions.F90 +++ b/src/ALE/polynomial_functions.F90 @@ -1,15 +1,17 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Polynomial functions module polynomial_functions -! This file is part of MOM6. See LICENSE.md for the license. - implicit none ; private public :: evaluation_polynomial, integration_polynomial, first_derivative_polynomial contains -!> Pointwise evaluation of a polynomial at x +!> Pointwise evaluation of a polynomial in arbitrary units [A] at x !! !! The polynomial is defined by the coefficients contained in the !! array of the same name, as follows: C(1) + C(2)x + C(3)x^2 + C(4)x^3 + ... @@ -17,12 +19,14 @@ module polynomial_functions !! The number of coefficients is given by ncoef and x !! is the coordinate where the polynomial is to be evaluated. real function evaluation_polynomial( coeff, ncoef, x ) - real, dimension(:), intent(in) :: coeff !< The coefficients of the polynomial + real, dimension(:), intent(in) :: coeff !< The coefficients of the polynomial, in units that + !! vary with the index k as [A H^(k-1)] integer, intent(in) :: ncoef !< The number of polynomial coefficients real, intent(in) :: x !< The position at which to evaluate the polynomial + !! in arbitrary thickness units [H] ! Local variables integer :: k - real :: f ! value of polynomial at x + real :: f ! value of polynomial at x in arbitrary units [A] f = 0.0 do k = 1,ncoef @@ -33,7 +37,8 @@ real function evaluation_polynomial( coeff, ncoef, x ) end function evaluation_polynomial -!> Calculates the first derivative of a polynomial evaluated at a point x +!> Calculates the first derivative of a polynomial evaluated in arbitrary units of [A H-1] +!! at a point x !! !! The polynomial is defined by the coefficients contained in the !! array of the same name, as follows: C(1) + C(2)x + C(3)x^2 + C(4)x^3 + ... @@ -41,12 +46,14 @@ end function evaluation_polynomial !! The number of coefficients is given by ncoef and x !! is the coordinate where the polynomial's derivative is to be evaluated. real function first_derivative_polynomial( coeff, ncoef, x ) - real, dimension(:), intent(in) :: coeff !< The coefficients of the polynomial + real, dimension(:), intent(in) :: coeff !< The coefficients of the polynomial, in units that + !! vary with the index k as [A H^(k-1)] integer, intent(in) :: ncoef !< The number of polynomial coefficients real, intent(in) :: x !< The position at which to evaluate the derivative + !! in arbitrary thickness units [H] ! Local variables integer :: k - real :: f ! value of polynomial at x + real :: f ! value of the derivative at x in [A H-1] f = 0.0 do k = 2,ncoef @@ -57,17 +64,20 @@ real function first_derivative_polynomial( coeff, ncoef, x ) end function first_derivative_polynomial -!> Exact integration of polynomial of degree npoly +!> Exact integration of polynomial of degree npoly in arbitrary units of [A H] !! !! The array of coefficients (Coeff) must be of size npoly+1. real function integration_polynomial( xi0, xi1, Coeff, npoly ) - real, intent(in) :: xi0 !< The lower bound of the integral - real, intent(in) :: xi1 !< The lower bound of the integral - real, dimension(:), intent(in) :: Coeff !< The coefficients of the polynomial + real, intent(in) :: xi0 !< The lower bound of the integral in arbitrary + !! thickness units [H] + real, intent(in) :: xi1 !< The upper bound of the integral in arbitrary + !! thickness units [H] + real, dimension(:), intent(in) :: Coeff !< The coefficients of the polynomial, in units that + !! vary with the index k as [A H^(k-1)] integer, intent(in) :: npoly !< The degree of the polynomial ! Local variables - integer :: k - real :: integral + integer :: k + real :: integral ! The integral of the polynomial over the specified range in [A H] integral = 0.0 diff --git a/src/ALE/regrid_consts.F90 b/src/ALE/regrid_consts.F90 index 7e8edea344..b3ca485f0a 100644 --- a/src/ALE/regrid_consts.F90 +++ b/src/ALE/regrid_consts.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Contains constants for interpreting input parameters that control regridding. module regrid_consts -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_error_handler, only : MOM_error, FATAL use MOM_string_functions, only : uppercase @@ -16,11 +18,10 @@ module regrid_consts integer, parameter :: REGRIDDING_SIGMA = 4 !< Sigma coordinates identifier integer, parameter :: REGRIDDING_ARBITRARY = 5 !< Arbitrary coordinates identifier integer, parameter :: REGRIDDING_HYCOM1 = 6 !< Simple HyCOM coordinates without BBL -integer, parameter :: REGRIDDING_SLIGHT = 7 !< Identifier for stretched coordinates in the - !! lightest water, isopycnal below integer, parameter :: REGRIDDING_SIGMA_SHELF_ZSTAR = 8 !< Identifiered for z* coordinates at the bottom, !! sigma-near the top integer, parameter :: REGRIDDING_ADAPTIVE = 9 !< Adaptive coordinate mode identifier +integer, parameter :: REGRIDDING_HYBGEN = 10 !< Hybgen coordinates identifier character(len=*), parameter :: REGRIDDING_LAYER_STRING = "LAYER" !< Layer string character(len=*), parameter :: REGRIDDING_ZSTAR_STRING_OLD = "Z*" !< z* string (legacy name) @@ -29,7 +30,7 @@ module regrid_consts character(len=*), parameter :: REGRIDDING_SIGMA_STRING = "SIGMA" !< Sigma string character(len=*), parameter :: REGRIDDING_ARBITRARY_STRING = "ARB" !< Arbitrary coordinates character(len=*), parameter :: REGRIDDING_HYCOM1_STRING = "HYCOM1" !< Hycom string -character(len=*), parameter :: REGRIDDING_SLIGHT_STRING = "SLIGHT" !< Hybrid S-rho string +character(len=*), parameter :: REGRIDDING_HYBGEN_STRING = "HYBGEN" !< Hybgen string character(len=*), parameter :: REGRIDDING_SIGMA_SHELF_ZSTAR_STRING = "SIGMA_SHELF_ZSTAR" !< Hybrid z*/sigma character(len=*), parameter :: REGRIDDING_ADAPTIVE_STRING = "ADAPTIVE" !< Adaptive coordinate string character(len=*), parameter :: DEFAULT_COORDINATE_MODE = REGRIDDING_LAYER_STRING !< Default coordinate mode @@ -60,7 +61,7 @@ function coordinateMode(string) case (trim(REGRIDDING_RHO_STRING)); coordinateMode = REGRIDDING_RHO case (trim(REGRIDDING_SIGMA_STRING)); coordinateMode = REGRIDDING_SIGMA case (trim(REGRIDDING_HYCOM1_STRING)); coordinateMode = REGRIDDING_HYCOM1 - case (trim(REGRIDDING_SLIGHT_STRING)); coordinateMode = REGRIDDING_SLIGHT + case (trim(REGRIDDING_HYBGEN_STRING)); coordinateMode = REGRIDDING_HYBGEN case (trim(REGRIDDING_ARBITRARY_STRING)); coordinateMode = REGRIDDING_ARBITRARY case (trim(REGRIDDING_SIGMA_SHELF_ZSTAR_STRING)); coordinateMode = REGRIDDING_SIGMA_SHELF_ZSTAR case (trim(REGRIDDING_ADAPTIVE_STRING)); coordinateMode = REGRIDDING_ADAPTIVE @@ -81,7 +82,7 @@ function coordinateUnitsI(coordMode) case (REGRIDDING_RHO); coordinateUnitsI = "kg m^-3" case (REGRIDDING_SIGMA); coordinateUnitsI = "Non-dimensional" case (REGRIDDING_HYCOM1); coordinateUnitsI = "m" - case (REGRIDDING_SLIGHT); coordinateUnitsI = "m" + case (REGRIDDING_HYBGEN); coordinateUnitsI = "m" case (REGRIDDING_ADAPTIVE); coordinateUnitsI = "m" case default ; call MOM_error(FATAL, "coordinateUnts: "//& "Unrecognized coordinate mode.") @@ -116,7 +117,7 @@ logical function state_dependent_int(mode) case (REGRIDDING_RHO); state_dependent_int = .true. case (REGRIDDING_SIGMA); state_dependent_int = .false. case (REGRIDDING_HYCOM1); state_dependent_int = .true. - case (REGRIDDING_SLIGHT); state_dependent_int = .true. + case (REGRIDDING_HYBGEN); state_dependent_int = .true. case (REGRIDDING_ADAPTIVE); state_dependent_int = .true. case default ; call MOM_error(FATAL, "state_dependent: "//& "Unrecognized choice of coordinate.") diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index 2baac56599..15dc4a2005 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -1,7 +1,9 @@ -!> Edge value estimation for high-order resconstruction -module regrid_edge_values +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 -! This file is part of MOM6. See LICENSE.md for the license. +!> Edge value estimation for high-order reconstruction +module regrid_edge_values use MOM_error_handler, only : MOM_error, FATAL use regrid_solvers, only : solve_linear_system, linear_solver @@ -14,20 +16,15 @@ module regrid_edge_values ! The following routines are visible to the outside world ! ----------------------------------------------------------------------------- public bound_edge_values, average_discontinuous_edge_values, check_discontinuous_edge_values -public edge_values_explicit_h2, edge_values_explicit_h4 +public edge_values_explicit_h2, edge_values_explicit_h4, edge_values_explicit_h4cw 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) +real, parameter :: hMinFrac = 1.e-5 !< A minimum fraction for min(h)/sum(h) [nondim] contains @@ -40,26 +37,23 @@ module regrid_edge_values !! !! Both boundary edge values are set equal to the boundary cell averages. !! Any extrapolation scheme is applied after this routine has been called. -!! Therefore, boundary cells are treated as if they were local extrama. -subroutine bound_edge_values( N, h, u, edge_val, h_neglect, answers_2018 ) +!! Therefore, boundary cells are treated as if they were local extrema. +subroutine bound_edge_values( N, h, u, edge_val, h_neglect, answer_date ) integer, intent(in) :: N !< Number of cells real, dimension(N), intent(in) :: h !< cell widths [H] 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] - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + 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 acccurate expressions. + 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(answers_2018)) use_2018_answers = answers_2018 - if (use_2018_answers) then - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - endif + use_2018_answers = .true. ; if (present(answer_date)) use_2018_answers = (answer_date < 20190101) ! Loop on cells to bound edge value do k = 1,N @@ -72,9 +66,9 @@ subroutine bound_edge_values( N, h, u, edge_val, h_neglect, answers_2018 ) 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) @@ -118,7 +112,7 @@ subroutine average_discontinuous_edge_values( N, edge_val ) !! second index is for the two edges of each cell. ! Local variables integer :: k ! loop index - real :: u0_avg ! avg value at given edge + real :: u0_avg ! avg value at given edge [A] ! Loop on interior edges do k = 1,N-1 @@ -218,41 +212,39 @@ end subroutine edge_values_explicit_h2 !! available interpolant. !! !! For this fourth-order scheme, at least four cells must exist. -subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) +subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answer_date ) integer, intent(in) :: N !< Number of cells real, dimension(N), intent(in) :: h !< cell widths [H] 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] - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + 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 :: h0, h1, h2, h3 ! temporary thicknesses [H] - real :: h_sum ! A sum of adjacent thicknesses [H] real :: h_min ! A minimal cell width [H] - real :: f1, f2, f3 ! auxiliary variables with various units - real :: et1, et2, et3 ! terms the expresson for edge values [A H] + real :: f1 ! An auxiliary variable [H] + real :: f2 ! An auxiliary variable [A H] + real :: f3 ! An auxiliary variable [H-1] + real :: et1, et2, et3 ! terms the expression for edge values [A H] real :: I_h12 ! The inverse of the sum of the two central thicknesses [H-1] - real :: I_h012, I_h123 ! Inverses of sums of three succesive thicknesses [H-1] + real :: I_h012, I_h123 ! Inverses of sums of three successive thicknesses [H-1] real :: I_den_et2, I_den_et3 ! Inverses of denominators in edge value terms [H-2] - real, dimension(5) :: x ! Coordinate system with 0 at edges [H] - real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] - real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] - real, parameter :: C1_12 = 1.0 / 12.0 - real :: dx, xavg ! Differences and averages of successive values of x [H] - real, dimension(4,4) :: A ! values near the boundaries - real, dimension(4) :: B, C - real :: hNeglect ! A negligible thickness in the same units as h. + real, dimension(5) :: x ! Coordinate system with 0 at edges [H] + real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] + real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] + real, parameter :: C1_12 = 1.0 / 12.0 ! A rational constant [nondim] + real :: dx ! Difference of successive values of x [H] + real, dimension(4,4) :: A ! Differences in successive positions raised to various powers, + ! in units that vary with the second (j) index as [H^j] + 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)] integer :: i, j - logical :: use_2018_answers ! If true use older, less acccurate expressions. + logical :: use_2018_answers ! If true use older, less accurate expressions. - use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 - 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 + use_2018_answers = .true. ; if (present(answer_date)) use_2018_answers = (answer_date < 20190101) ! Loop on interior cells do i = 3,N-1 @@ -265,9 +257,9 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) ! 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) ) @@ -302,7 +294,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) ! 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) ) @@ -317,7 +309,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) 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 @@ -328,7 +320,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) ! 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 @@ -346,7 +338,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) 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 @@ -357,6 +349,103 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) end subroutine edge_values_explicit_h4 +!> Compute h4 edge values (explicit fourth order accurate) +!! in the same units as u. +!! +!! From (Colella & Woodward, JCP, 1984) and based on hybgen_ppm_coefs. +!! +!! Compute edge values based on fourth-order explicit estimates. +!! These estimates are based on a cubic interpolant spanning four cells +!! and evaluated at the location of the middle edge. An interpolant spanning +!! cells i-2, i-1, i and i+1 is evaluated at edge i-1/2. The estimate for +!! each edge is unique. +!! +!! i-2 i-1 i i+1 +!! ..--o------o------o------o------o--.. +!! i-1/2 +!! +!! For this fourth-order scheme, at least four cells must exist. +subroutine edge_values_explicit_h4cw( N, h, u, edge_val, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(N), intent(in) :: h !< cell widths [H] + 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, 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 :: 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] + real :: sck ! Scalar differences across a cell [A] + real :: au(N) ! Scalar field difference across each cell [A] + real :: al(N), ar(N) ! Scalar field at the left and right edges of a cell [A] + real :: h112(N+1), h122(N+1) ! Combinations of thicknesses [H ~> m or kg m-2] + real :: I_h12(N+1) ! Inverses of combinations of thickesses [H-1 ~> m-1 or m2 kg-1] + real :: h2_h123(N) ! A ratio of a layer thickness of the sum of 3 adjacent thicknesses [nondim] + real :: I_h0123(N) ! Inverse of the sum of 4 adjacent thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: h01_h112(N+1) ! A ratio of sums of adjacent thicknesses [nondim], 2/3 in the limit of uniform thicknesses. + real :: h23_h122(N+1) ! A ratio of sums of adjacent thicknesses [nondim], 2/3 in the limit of uniform thicknesses. + integer :: k + + ! Set the thicknesses for very thin layers to some minimum value. + do k=1,N ; dp(k) = max(h(k), h_neglect) ; enddo + + !compute grid metrics + do k=2,N + h112(K) = 2.*dp(k-1) + dp(k) + h122(K) = dp(k-1) + 2.*dp(k) + I_h12(K) = 1.0 / (dp(k-1) + dp(k)) + enddo !k + do k=2,N-1 + h2_h123(k) = dp(k) / (dp(k) + (dp(k-1)+dp(k+1))) + enddo + do K=3,N-1 + I_h0123(K) = 1.0 / ((dp(k-2) + dp(k-1)) + (dp(k) + dp(k+1))) + + h01_h112(K) = (dp(k-2) + dp(k-1)) / (2.0*dp(k-1) + dp(k)) + h23_h122(K) = (dp(k) + dp(k+1)) / (dp(k-1) + 2.0*dp(k)) + enddo + + !Compute average slopes: Colella, Eq. (1.8) + au(1) = 0. + do k=2,N-1 + slk = u(k )-u(k-1) + srk = u(k+1)-u(k) + if (slk*srk > 0.) then + sck = h2_h123(k)*( h112(K)*srk*I_h12(K+1) + h122(K+1)*slk*I_h12(K) ) + au(k) = sign(min(abs(2.0*slk), abs(sck), abs(2.0*srk)), sck) + else + au(k) = 0. + endif + enddo !k + au(N) = 0. + + !Compute "first guess" edge values: Colella, Eq. (1.6) + al(1) = u(1) ! 1st layer PCM + ar(1) = u(1) ! 1st layer PCM + al(2) = u(1) ! 1st layer PCM + do K=3,N-1 + ! This is a 4th order explicit edge value estimate. + al(k) = (dp(k)*u(k-1) + dp(k-1)*u(k)) * I_h12(K) & + + I_h0123(K)*( 2.*dp(k)*dp(k-1)*I_h12(K)*(u(k)-u(k-1)) * & + ( h01_h112(K) - h23_h122(K) ) & + + (dp(k)*au(k-1)*h23_h122(K) - dp(k-1)*au(k)*h01_h112(K)) ) + ar(k-1) = al(k) + enddo !k + ar(N-1) = u(N) ! last layer PCM + al(N) = u(N) ! last layer PCM + ar(N) = u(N) ! last layer PCM + + !Set coefficients + do k=1,N + edge_val(k,1) = al(k) + edge_val(k,2) = ar(k) + enddo !k + +end subroutine edge_values_explicit_h4cw + !> Compute ih4 edge values (implicit fourth order accurate) !! in the same units as u. !! @@ -383,48 +472,45 @@ end subroutine edge_values_explicit_h4 !! !! There are N+1 unknowns and we are able to write N-1 equations. The !! boundary conditions close the system. -subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) +subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answer_date ) integer, intent(in) :: N !< Number of cells real, dimension(N), intent(in) :: h !< cell widths [H] 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] - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + 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 integer :: i, j ! loop indexes - real :: h0, h1, h2 ! cell widths [H] + real :: h0, h1 ! cell widths [H] real :: h_min ! A minimal cell width [H] - real :: h_sum ! A sum of adjacent thicknesses [H] - real :: h0_2, h1_2, h0h1 - real :: h0ph1_2, h0ph1_4 + real :: h0_2, h1_2, h0h1 ! Squares or products of thicknesses [H2] + real :: h0ph1_2 ! The square of a sum of thicknesses [H2] + real :: h0ph1_4 ! The fourth power of a sum of thicknesses [H4] real :: alpha, beta ! stencil coefficients [nondim] real :: I_h2, abmix ! stencil coefficients [nondim] - real :: a, b + real :: a, b ! Combinations of stencil coefficients [nondim] real, dimension(5) :: x ! Coordinate system with 0 at edges [H] - real, parameter :: C1_12 = 1.0 / 12.0 - real, parameter :: C1_3 = 1.0 / 3.0 + real, parameter :: C1_12 = 1.0 / 12.0 ! A rational constant [nondim] + real, parameter :: C1_3 = 1.0 / 3.0 ! A rational constant [nondim] real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] - real :: dx, xavg ! Differences and averages of successive values of x [H] - real, dimension(4,4) :: Asys ! boundary conditions - real, dimension(4) :: Bsys, Csys + real :: dx ! Differences and averages of successive values of x [H] + real, dimension(4,4) :: Asys ! Differences in successive positions raised to various powers, + ! in units that vary with the second (j) index as [H^j] + real, dimension(4) :: Bsys ! The right hand side of the system to solve for C [A H] + real, dimension(4) :: Csys ! The coefficients of a fit polynomial in units that vary + ! with the index (j) as [A H^(j-1)] real, dimension(N+1) :: tri_l, & ! tridiagonal system (lower diagonal) [nondim] tri_d, & ! tridiagonal system (middle diagonal) [nondim] - tri_c, & ! tridiagonal system central value, with tri_d = tri_c+tri_l+tri_u + tri_c, & ! tridiagonal system central value [nondim], with tri_d = tri_c+tri_l+tri_u 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 acccurate expressions. + logical :: use_2018_answers ! If true use older, less accurate expressions. - use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 - 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 + use_2018_answers = .true. ; if (present(answer_date)) use_2018_answers = (answer_date < 20190101) ! Loop on cells (except last one) do i = 1,N-1 @@ -434,8 +520,8 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) 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 @@ -454,8 +540,8 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) 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 @@ -479,7 +565,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) ! 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) ) @@ -493,7 +579,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) 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. @@ -503,7 +589,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) ! 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) ) @@ -521,7 +607,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) 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 @@ -568,8 +654,7 @@ subroutine end_value_h4(dz, u, Csys) real :: I_denom ! The inverse of the denominator some expressions [H-3] real :: I_denB3 ! The inverse of the product of three sums of thicknesses [H-3] real :: min_frac = 1.0e-6 ! The square of min_frac should be much larger than roundoff [nondim] - real, parameter :: C1_3 = 1.0 / 3.0 - integer :: i, j, k + real, parameter :: C1_3 = 1.0 / 3.0 ! A rational parameter [nondim] ! These are only used for code verification ! real, dimension(4) :: Atest ! The coefficients of an expression that is being tested. @@ -586,7 +671,7 @@ subroutine end_value_h4(dz, u, Csys) ! Csys(4) = ((u(2)-u(1)) - 2.0 * (u(3)-u(2)) + (u(4)-u(3))) * (0.5*C1_3) ! else - ! Express the coefficients as sums of the differences between properties of succesive layers. + ! Express the coefficients as sums of the differences between properties of successive layers. h1 = dz(1) ; h2 = dz(2) ; h3 = dz(3) ; h4 = dz(4) ! Some of the weights used below are proportional to (h1/(h2+h3))**2 or (h1/(h2+h3))*(h2/(h3+h4)) @@ -641,10 +726,10 @@ subroutine end_value_h4(dz, u, Csys) Wt(2,4) = -4.0 * I_h1234 * (I_h23 * (I_h123 + I_h234)) ! Wt*h1^3 > -4* (h1/h23)*(1+h1/h234) Wt(3,4) = 4.0 * I_denom ! = 4.0*I_h1234 * I_h234 * I_h34 ! Wt*h1^3 < 4 * (h1/h234)*(h1/h34) - Csys(1) = ((u(1) + Wt(1,1) * (u(2)-u(1))) + Wt(2,1) * (u(3)-u(2))) + Wt(3,1) * (u(4)-u(3)) - Csys(2) = (Wt(1,2) * (u(2)-u(1)) + Wt(2,2) * (u(3)-u(2))) + Wt(3,2) * (u(4)-u(3)) - Csys(3) = (Wt(1,3) * (u(2)-u(1)) + Wt(2,3) * (u(3)-u(2))) + Wt(3,3) * (u(4)-u(3)) - Csys(4) = (Wt(1,4) * (u(2)-u(1)) + Wt(2,4) * (u(3)-u(2))) + Wt(3,4) * (u(4)-u(3)) + Csys(1) = ((u(1) + (Wt(1,1) * (u(2)-u(1)))) + (Wt(2,1) * (u(3)-u(2)))) + (Wt(3,1) * (u(4)-u(3))) + Csys(2) = ((Wt(1,2) * (u(2)-u(1))) + (Wt(2,2) * (u(3)-u(2)))) + (Wt(3,2) * (u(4)-u(3))) + Csys(3) = ((Wt(1,3) * (u(2)-u(1))) + (Wt(2,3) * (u(3)-u(2)))) + (Wt(3,3) * (u(4)-u(3))) + Csys(4) = ((Wt(1,4) * (u(2)-u(1))) + (Wt(2,4) * (u(3)-u(2)))) + (Wt(3,4) * (u(4)-u(3))) ! endif ! End of non-uniform layer thickness branch. @@ -693,46 +778,48 @@ end subroutine end_value_h4 !! !! There are N+1 unknowns and we are able to write N-1 equations. The !! boundary conditions close the system. -subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_2018 ) +subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answer_date ) integer, intent(in) :: N !< Number of cells real, dimension(N), intent(in) :: h !< cell widths [H] 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] - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + 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 integer :: i, j ! loop indexes real :: h0, h1 ! cell widths [H or nondim] real :: h0_2, h1_2, h0h1 ! products of cell widths [H2 or nondim] real :: h0_3, h1_3 ! products of three cell widths [H3 or nondim] - real :: h_min ! A minimal cell width [H] real :: d ! A temporary variable [H3] real :: I_d ! A temporary variable [nondim] real :: I_h ! Inverses of thicknesses [H-1] real :: alpha, beta ! stencil coefficients [nondim] real :: a, b ! weights of cells [H-1] - real, parameter :: C1_12 = 1.0 / 12.0 + real, parameter :: C1_12 = 1.0 / 12.0 ! A rational parameter [nondim] real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] - real, dimension(5) :: x ! Coordinate system with 0 at edges [H] - real :: dx, xavg ! Differences and averages of successive values of x [H] - real, dimension(4,4) :: Asys ! matrix used to find boundary conditions - real, dimension(4) :: Bsys, Csys - real, dimension(3) :: Dsys + real, dimension(5) :: x ! Coordinate system with 0 at edges [H] + real :: dx ! Differences and averages of successive values of x [H] + real, dimension(4,4) :: Asys ! Differences in successive positions raised to various powers, + ! in units that vary with the second (j) index as [H^j] + real, dimension(4) :: Bsys ! The right hand side of the system to solve for C [A H] + real, dimension(4) :: Csys ! The coefficients of a fit polynomial in units that vary with the + ! index (j) as [A H^(j-1)] + real, dimension(3) :: Dsys ! The coefficients of the first derivative of the fit polynomial + ! in units that vary with the index (j) as [A H^(j-2)] real, dimension(N+1) :: tri_l, & ! tridiagonal system (lower diagonal) [nondim] tri_d, & ! tridiagonal system (middle diagonal) [nondim] - tri_c, & ! tridiagonal system central value, with tri_d = tri_c+tri_l+tri_u + tri_c, & ! tridiagonal system central value [nondim], with tri_d = tri_c+tri_l+tri_u 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 acccurate expressions. + logical :: use_2018_answers ! If true use older, less accurate expressions. - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - hNeglect3 = hNeglect**3 - use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 + hNeglect3 = h_neglect**3 + use_2018_answers = .true. ; if (present(answer_date)) use_2018_answers = (answer_date < 20190101) ! Loop on cells (except last one) do i = 1,N-1 @@ -764,8 +851,8 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 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 @@ -806,7 +893,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 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 @@ -834,7 +921,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 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) @@ -863,14 +950,15 @@ end subroutine edge_slopes_implicit_h3 !------------------------------------------------------------------------------ !> Compute ih5 edge slopes (implicit fifth order accurate) -subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_2018 ) +subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answer_date ) integer, intent(in) :: N !< Number of cells real, dimension(N), intent(in) :: h !< cell widths [H] 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] - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + real, intent(in) :: h_neglect !< A negligibly small width [H] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use + ! ----------------------------------------------------------------------------- ! Fifth-order implicit estimates of edge slopes are based on a four-cell, ! three-edge stencil. A tridiagonal system is set up and is based on @@ -909,32 +997,34 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 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 ! the coefficients of the - real :: h1_3, h2_3 ! tridiagonal system - real :: h1_4, h2_4 ! ... - real :: h1_5, h2_5 ! ... - real :: alpha, beta ! stencil coefficients - real, dimension(7) :: x ! Coordinate system with 0 at edges [same units as h] - real, parameter :: C1_12 = 1.0 / 12.0 - real, parameter :: C5_6 = 5.0 / 6.0 - real :: dx, xavg ! Differences and averages of successive values of x [same units as h] - real, dimension(6,6) :: Asys ! matrix used to find boundary conditions - real, dimension(6) :: Bsys, Csys ! ... - real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) - tri_d, & ! trid. system (middle diagonal) - tri_u, & ! trid. system (upper diagonal) - tri_b, & ! trid. system (unknowns vector) - tri_x ! trid. system (rhs) - real :: h_Min_Frac = 1.0e-4 - integer :: i, j, k ! loop indexes - - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + 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] + real :: h1_5, h2_5 ! Fifth powers of thicknesses [H5] + real :: alpha, beta ! stencil coefficients [nondim] + real, dimension(7) :: x ! Coordinate system with 0 at edges in the same units as h [H] + real, parameter :: C1_12 = 1.0 / 12.0 ! A rational parameter [nondim] + real, parameter :: C5_6 = 5.0 / 6.0 ! A rational parameter [nondim] + real :: dx ! Differences between successive values of x in the same units as h [H] + real :: xavg ! Average of successive values of x in the same units as h [H] + real, dimension(6,6) :: Asys ! The matrix that is being inverted for a solution, + ! in units that might vary with the second (j) index as [H^j] + real, dimension(6) :: Bsys ! The right hand side of the system to solve for C in various + ! units that sometimes vary with the intex (j) as [H^(j-1)] or [H^j] + ! or might be [A] + real, dimension(6) :: Csys ! The solution to a matrix equation usually [nondim] in this routine. + real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) [nondim] + tri_d, & ! trid. system (middle diagonal) [nondim] + tri_u, & ! trid. system (upper diagonal) [nondim] + tri_b, & ! trid. system (rhs) [A H-1] + tri_x ! trid. system (unknowns vector) [A H-1] + real :: h_Min_Frac = 1.0e-4 ! A minimum fractional thickness [nondim] + integer :: i, k ! loop indexes ! 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) @@ -975,7 +1065,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 ! 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) @@ -1031,7 +1121,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 ! 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) @@ -1133,43 +1223,46 @@ end subroutine edge_slopes_implicit_h5 !! become computationally expensive if regridding is carried out !! often. Figuring out closed-form expressions for these coefficients !! on nonuniform meshes turned out to be intractable. -subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) +subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answer_date ) integer, intent(in) :: N !< Number of cells real, dimension(N), intent(in) :: h !< cell widths [H] 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] - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + 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 :: h0, h1, h2, h3 ! cell widths [H] 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 - real, dimension(7) :: x ! Coordinate system with 0 at edges [same units as h] - real, parameter :: C1_12 = 1.0 / 12.0 - real, parameter :: C5_6 = 5.0 / 6.0 - real :: dx, xavg ! Differences and averages of successive values of x [same units as h] - real, dimension(6,6) :: Asys ! boundary conditions - real, dimension(6) :: Bsys, Csys ! ... - real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) - tri_d, & ! trid. system (middle diagonal) - tri_u, & ! trid. system (upper diagonal) - tri_b, & ! trid. system (unknowns vector) - tri_x ! trid. system (rhs) - integer :: i, j, k ! loop indexes - - hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect + real :: alpha, beta ! stencil coefficients [nondim] + real, dimension(7) :: x ! Coordinate system with 0 at edges in the same units as h [H] + real, parameter :: C1_12 = 1.0 / 12.0 ! A rational parameter [nondim] + real, parameter :: C5_6 = 5.0 / 6.0 ! A rational parameter [nondim] + real :: dx, xavg ! Differences and averages of successive values of x [H] + real, dimension(6,6) :: Asys ! The matrix that is being inverted for a solution, + ! in units that might vary with the second (j) index as [H^j] + real, dimension(6) :: Bsys ! The right hand side of the system to solve for C in various + ! units that sometimes vary with the intex (j) as [H^(j-1)] or [H^j] + ! or might be [A] + real, dimension(6) :: Csys ! The solution to a matrix equation, which might be [nondim] or the + ! coefficients of a fit polynomial in units that vary with the + ! index (j) as [A H^(j-1)] + real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) [nondim] + tri_d, & ! trid. system (middle diagonal) [nondim] + tri_u, & ! trid. system (upper diagonal) [nondim] + tri_b, & ! trid. system (rhs) [A] + tri_x ! trid. system (unknowns vector) [A] + integer :: i, k ! loop indexes ! 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) @@ -1207,7 +1300,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) ! 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) @@ -1242,7 +1335,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) 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) ) @@ -1264,7 +1357,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) ! 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) @@ -1299,7 +1392,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) 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) ) @@ -1333,16 +1426,16 @@ end subroutine edge_values_implicit_h6 !> Test that A*C = R to within a tolerance, issuing a fatal error with an explanatory message if they do not. subroutine test_line(msg, N, A, C, R, mag, tol) - real, intent(in) :: mag !< The magnitude of leading order terms in this line - integer, intent(in) :: N !< The number of points in the system - real, dimension(4), intent(in) :: A !< One of the two vectors being multiplied - real, dimension(4), intent(in) :: C !< One of the two vectors being multiplied - real, intent(in) :: R !< The expected solution of the equation character(len=*), intent(in) :: msg !< An identifying message for this test - real, optional, intent(in) :: tol !< The fractional tolerance for the two solutions - - real :: sum, sum_mag - real :: tolerance + integer, intent(in) :: N !< The number of points in the system + real, dimension(4), intent(in) :: A !< One of the two vectors being multiplied in arbitrary units [A] + real, dimension(4), intent(in) :: C !< One of the two vectors being multiplied in arbitrary units [B] + real, intent(in) :: R !< The expected solution of the equation [A B] + real, intent(in) :: mag !< The magnitude of leading order terms in this line [A B] + real, optional, intent(in) :: tol !< The fractional tolerance for the sums [nondim] + + real :: sum, sum_mag ! The sum of the products and their magnitude in arbitrary units [A B] + real :: tolerance ! The fractional tolerance for the sums [nondim] character(len=128) :: mesg2 integer :: i diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index 87019d46cf..e2b756c334 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -1,17 +1,21 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Vertical interpolation for regridding module regrid_interp -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_error_handler, only : MOM_error, FATAL use MOM_string_functions, only : uppercase use regrid_edge_values, only : edge_values_explicit_h2, edge_values_explicit_h4 +use regrid_edge_values, only : edge_values_explicit_h4cw use regrid_edge_values, only : edge_values_implicit_h4, edge_values_implicit_h6 use regrid_edge_values, only : edge_slopes_implicit_h3, edge_slopes_implicit_h5 use PLM_functions, only : PLM_reconstruction, PLM_boundary_extrapolation use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation +use PPM_functions, only : PPM_monotonicity use PQM_functions, only : PQM_reconstruction, PQM_boundary_extrapolation_v1 use P1M_functions, only : P1M_interpolation, P1M_boundary_extrapolation @@ -31,19 +35,19 @@ module regrid_interp !! boundary cells logical :: boundary_extrapolation - !> If true use older, less acccurate expressions. - logical :: answers_2018 = .true. + !> The vintage of the expressions to use for regridding + integer :: answer_date = 99991231 end type interp_CS_type -public regridding_set_ppolys, interpolate_grid -public build_and_interpolate_grid -public set_interp_scheme, set_interp_extrap +public regridding_set_ppolys, build_and_interpolate_grid +public set_interp_scheme, set_interp_extrap, set_interp_answer_date ! List of interpolation schemes integer, parameter :: INTERPOLATION_P1M_H2 = 0 !< O(h^2) integer, parameter :: INTERPOLATION_P1M_H4 = 1 !< O(h^2) integer, parameter :: INTERPOLATION_P1M_IH4 = 2 !< O(h^2) integer, parameter :: INTERPOLATION_PLM = 3 !< O(h^2) +integer, parameter :: INTERPOLATION_PPM_CW =10 !< O(h^3) integer, parameter :: INTERPOLATION_PPM_H4 = 4 !< O(h^3) integer, parameter :: INTERPOLATION_PPM_IH4 = 5 !< O(h^3) integer, parameter :: INTERPOLATION_P3M_IH4IH3 = 6 !< O(h^4) @@ -85,15 +89,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 @@ -107,7 +115,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & case ( INTERPOLATION_P1M_H2 ) degree = DEGREE_1 call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answers_2018=CS%answers_2018 ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) endif @@ -115,11 +123,11 @@ 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, answers_2018=CS%answers_2018 ) + 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 - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answers_2018=CS%answers_2018 ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) endif @@ -127,11 +135,11 @@ 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, answers_2018=CS%answers_2018 ) + 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 - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answers_2018=CS%answers_2018 ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) endif @@ -143,11 +151,30 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & call PLM_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) endif + case ( INTERPOLATION_PPM_CW ) + if ( n0 >= 4 ) then + degree = DEGREE_2 + 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 + call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, & + ppoly0_coefs, h_neglect ) + endif + else + degree = DEGREE_1 + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) + if (extrapolate) then + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) + endif + endif + case ( INTERPOLATION_PPM_H4 ) if ( n0 >= 4 ) then degree = DEGREE_2 - call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge, answers_2018=CS%answers_2018 ) - call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answers_2018=CS%answers_2018 ) + 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, & ppoly0_coefs, h_neglect ) @@ -155,7 +182,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & else degree = DEGREE_1 call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answers_2018=CS%answers_2018 ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) endif @@ -164,8 +191,8 @@ 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, answers_2018=CS%answers_2018 ) - call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answers_2018=CS%answers_2018 ) + 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, & ppoly0_coefs, h_neglect ) @@ -173,7 +200,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & else degree = DEGREE_1 call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answers_2018=CS%answers_2018 ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) endif @@ -182,18 +209,18 @@ 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, answers_2018=CS%answers_2018 ) - call edge_slopes_implicit_h3( n0, h0, densities, ppoly0_S, h_neglect, answers_2018=CS%answers_2018 ) + 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, answers_2018=CS%answers_2018 ) + 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 call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answers_2018=CS%answers_2018 ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) endif @@ -202,10 +229,10 @@ 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, answers_2018=CS%answers_2018 ) - call edge_slopes_implicit_h5( n0, h0, densities, ppoly0_S, h_neglect, answers_2018=CS%answers_2018 ) + 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, answers_2018=CS%answers_2018 ) + 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 ) @@ -213,7 +240,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & else degree = DEGREE_1 call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answers_2018=CS%answers_2018 ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) endif @@ -222,10 +249,10 @@ 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, answers_2018=CS%answers_2018 ) - call edge_slopes_implicit_h3( n0, h0, densities, ppoly0_S, h_neglect, answers_2018=CS%answers_2018 ) + 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, answers_2018=CS%answers_2018 ) + ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) if (extrapolate) then call PQM_boundary_extrapolation_v1( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect ) @@ -233,7 +260,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & else degree = DEGREE_1 call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answers_2018=CS%answers_2018 ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) endif @@ -242,10 +269,10 @@ 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, answers_2018=CS%answers_2018 ) - call edge_slopes_implicit_h5( n0, h0, densities, ppoly0_S, h_neglect, answers_2018=CS%answers_2018 ) + 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, answers_2018=CS%answers_2018 ) + ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) if (extrapolate) then call PQM_boundary_extrapolation_v1( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect ) @@ -253,7 +280,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & else degree = DEGREE_1 call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) - call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answers_2018=CS%answers_2018 ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) endif @@ -268,7 +295,7 @@ end subroutine regridding_set_ppolys !! 'ppoly0' (possibly discontinuous), the coordinates of the new grid 'grid1' !! are determined by finding the corresponding target interface densities. subroutine interpolate_grid( n0, h0, x0, ppoly0_E, ppoly0_coefs, & - target_values, degree, n1, h1, x1, answers_2018 ) + target_values, degree, n1, h1, x1, answer_date ) integer, intent(in) :: n0 !< Number of points on source grid integer, intent(in) :: n1 !< Number of points on target grid real, dimension(n0), intent(in) :: h0 !< Thicknesses of source grid cells [H] @@ -280,12 +307,11 @@ subroutine interpolate_grid( n0, h0, x0, ppoly0_E, ppoly0_coefs, & integer, intent(in) :: degree !< Degree of interpolating polynomials real, dimension(n1), intent(inout) :: h1 !< Thicknesses of target grid cells [H] real, dimension(n1+1), intent(inout) :: x1 !< Target interface positions [H] - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Local variables - logical :: use_2018_answers ! If true use older, less acccurate expressions. integer :: k ! loop index - real :: t ! current interface target density + real :: t ! current interface target density [A] ! Make sure boundary coordinates of new grid coincide with boundary ! coordinates of previous grid @@ -296,7 +322,7 @@ subroutine interpolate_grid( n0, h0, x0, ppoly0_E, ppoly0_coefs, & do k = 2,n1 t = target_values(k) x1(k) = get_polynomial_coordinate ( n0, h0, x0, ppoly0_E, ppoly0_coefs, t, degree, & - answers_2018=answers_2018 ) + answer_date=answer_date ) h1(k-1) = x1(k) - x1(k-1) enddo h1(n1) = x1(n1+1) - x1(n1) @@ -311,26 +337,26 @@ subroutine build_and_interpolate_grid(CS, densities, n0, h0, x0, target_values, integer, intent(in) :: n1 !< The number of points on the output grid real, dimension(n0), intent(in) :: densities !< Input cell densities [R ~> kg m-3] real, dimension(n1+1), intent(in) :: target_values !< Target values of interfaces [R ~> kg m-3] - real, dimension(n0), intent(in) :: h0 !< Initial cell widths [H] - 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 - !! 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. + real, dimension(n0), intent(in) :: h0 !< Initial cell widths usually in [H ~> m or kg m-2] or [Z ~> m] + real, dimension(n0+1), intent(in) :: x0 !< Source interface positions [H ~> m or kg m-2] or [Z ~> m] + real, dimension(n1), intent(inout) :: h1 !< Output cell widths [H ~> m or kg m-2] or [Z ~> m] + real, dimension(n1+1), intent(inout) :: x1 !< Target interface positions [H ~> m or kg m-2] or [Z ~> m] + real, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions in the same + !! units as h0 [H ~> m or kg m-2] or [Z ~> m]. + 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 ~> m or kg m-2] or [Z ~> m] real, dimension(n0,2) :: ppoly0_E ! Polynomial edge values [R ~> kg m-3] - real, dimension(n0,2) :: ppoly0_S ! Polynomial edge slopes [R H-1] + real, dimension(n0,2) :: ppoly0_S ! Polynomial edge slopes [R H-1 ~> kg m-4 or m-1] or [R Z-1 ~> kg m-4] real, dimension(n0,DEGREE_MAX+1) :: ppoly0_C ! Polynomial interpolant coeficients on the local 0-1 grid [R ~> kg m-3] integer :: degree call regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, ppoly0_C, & degree, h_neglect, h_neglect_edge) call interpolate_grid(n0, h0, x0, ppoly0_E, ppoly0_C, target_values, degree, & - n1, h1, x1, answers_2018=CS%answers_2018) + n1, h1, x1, answer_date=CS%answer_date) end subroutine build_and_interpolate_grid !> Given a target value, find corresponding coordinate for given polynomial @@ -350,7 +376,7 @@ end subroutine build_and_interpolate_grid !! It is assumed that the number of cells defining 'grid' and 'ppoly' are the !! same. function get_polynomial_coordinate( N, h, x_g, edge_values, ppoly_coefs, & - target_value, degree, answers_2018 ) result ( x_tgt ) + target_value, degree, answer_date ) result ( x_tgt ) ! Arguments integer, intent(in) :: N !< Number of grid cells real, dimension(N), intent(in) :: h !< Grid cell thicknesses [H] @@ -359,26 +385,26 @@ function get_polynomial_coordinate( N, h, x_g, edge_values, ppoly_coefs, & real, dimension(N,DEGREE_MAX+1), intent(in) :: ppoly_coefs !< Coefficients of interpolating polynomials [A] real, intent(in) :: target_value !< Target value to find position for [A] integer, intent(in) :: degree !< Degree of the interpolating polynomials - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + integer, intent(in) :: answer_date !< The vintage of the expressions to use real :: x_tgt !< The position of x_g at which target_value is found [H] ! Local variables real :: xi0 ! normalized target coordinate [nondim] real, dimension(DEGREE_MAX) :: a ! polynomial coefficients [A] - real :: numerator - real :: denominator + real :: numerator ! The numerator of an expression [A] + real :: denominator ! The denominator of an expression [A] real :: delta ! Newton-Raphson increment [nondim] -! real :: x ! global target coordinate +! real :: x ! global target coordinate [nondim] real :: eps ! offset used to get away from boundaries [nondim] real :: grad ! gradient during N-R iterations [A] integer :: i, k, iter ! loop indices integer :: k_found ! index of target cell character(len=320) :: mesg - logical :: use_2018_answers ! If true use older, less acccurate expressions. + logical :: use_2018_answers ! If true use older, less accurate expressions. eps = NR_OFFSET k_found = -1 - use_2018_answers = .true. ; if (present(answers_2018)) use_2018_answers = answers_2018 + use_2018_answers = (answer_date < 20190101) ! If the target value is outside the range of all values, we ! force the target coordinate to be equal to the lowest or @@ -486,7 +512,7 @@ end function get_polynomial_coordinate !> Numeric value of interpolation_scheme corresponding to scheme name integer function interpolation_scheme(interp_scheme) character(len=*), intent(in) :: interp_scheme !< Name of the interpolation scheme - !! Valid values include "P1M_H2", "P1M_H4", "P1M_IH2", "PLM", "PPM_H4", + !! Valid values include "P1M_H2", "P1M_H4", "P1M_IH2", "PLM", "PPM_CW", "PPM_H4", !! "PPM_IH4", "P3M_IH4IH3", "P3M_IH6IH5", "PQM_IH4IH3", and "PQM_IH6IH5" select case ( uppercase(trim(interp_scheme)) ) @@ -494,6 +520,7 @@ integer function interpolation_scheme(interp_scheme) case ("P1M_H4"); interpolation_scheme = INTERPOLATION_P1M_H4 case ("P1M_IH2"); interpolation_scheme = INTERPOLATION_P1M_IH4 case ("PLM"); interpolation_scheme = INTERPOLATION_PLM + case ("PPM_CW"); interpolation_scheme = INTERPOLATION_PPM_CW case ("PPM_H4"); interpolation_scheme = INTERPOLATION_PPM_H4 case ("PPM_IH4"); interpolation_scheme = INTERPOLATION_PPM_IH4 case ("P3M_IH4IH3"); interpolation_scheme = INTERPOLATION_P3M_IH4IH3 @@ -509,7 +536,7 @@ end function interpolation_scheme subroutine set_interp_scheme(CS, interp_scheme) type(interp_CS_type), intent(inout) :: CS !< A control structure for regrid_interp character(len=*), intent(in) :: interp_scheme !< Name of the interpolation scheme - !! Valid values include "P1M_H2", "P1M_H4", "P1M_IH2", "PLM", "PPM_H4", + !! Valid values include "P1M_H2", "P1M_H4", "P1M_IH2", "PLM", "PPM_CW", "PPM_H4", !! "PPM_IH4", "P3M_IH4IH3", "P3M_IH6IH5", "PQM_IH4IH3", and "PQM_IH6IH5" CS%interpolation_scheme = interpolation_scheme(interp_scheme) @@ -524,4 +551,13 @@ subroutine set_interp_extrap(CS, extrap) CS%boundary_extrapolation = extrap end subroutine set_interp_extrap +!> Store the value of the answer_date in the interp_CS +subroutine set_interp_answer_date(CS, answer_date) + type(interp_CS_type), intent(inout) :: CS !< A control structure for regrid_interp + integer, intent(in) :: answer_date !< An integer encoding the vintage of + !! the expressions to use for regridding + + CS%answer_date = answer_date +end subroutine set_interp_answer_date + end module regrid_interp diff --git a/src/ALE/regrid_solvers.F90 b/src/ALE/regrid_solvers.F90 index 50bd7f984d..328a06204a 100644 --- a/src/ALE/regrid_solvers.F90 +++ b/src/ALE/regrid_solvers.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Solvers of linear systems. module regrid_solvers -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_error_handler, only : MOM_error, FATAL implicit none ; private @@ -16,22 +18,26 @@ module regrid_solvers !! This routine uses Gauss's algorithm to transform the system's original !! matrix into an upper triangular matrix. Back substitution yields the answer. !! The matrix A must be square, with the first index varing down the column. -subroutine solve_linear_system( A, R, X, N, answers_2018 ) +subroutine solve_linear_system( A, R, X, N, answer_date ) integer, intent(in) :: N !< The size of the system - real, dimension(N,N), intent(inout) :: A !< The matrix being inverted [nondim] - real, dimension(N), intent(inout) :: R !< system right-hand side [A] - real, dimension(N), intent(inout) :: X !< solution vector [A] - logical, optional, intent(in) :: answers_2018 !< If true or absent use older, less efficient expressions. + real, dimension(N,N), intent(inout) :: A !< The matrix being inverted in arbitrary units [A] on + !! input, but internally modified to become nondimensional + !! during the solver. + real, dimension(N), intent(inout) :: R !< system right-hand side in arbitrary units [A B] on + !! input, but internally modified to have units of [B] + !! during the solver + real, dimension(N), intent(inout) :: X !< solution vector in arbitrary units [B] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Local variables - real, parameter :: eps = 0.0 ! Minimum pivot magnitude allowed - real :: factor ! The factor that eliminates the leading nonzero element in a row. - real :: pivot, I_pivot ! The pivot value and its reciprocal [nondim] - real :: swap_a, swap_b + real, parameter :: eps = 0.0 ! Minimum pivot magnitude allowed [A] + real :: factor ! The factor that eliminates the leading nonzero element in a row [A-1] + real :: pivot, I_pivot ! The pivot value and its reciprocal, in [A] and [A-1] + real :: swap_a, swap_b ! Swap space in various units [various] logical :: found_pivot ! If true, a pivot has been found logical :: old_answers ! If true, use expressions that give the original (2008 through 2018) MOM6 answers integer :: i, j, k - old_answers = .true. ; if (present(answers_2018)) old_answers = answers_2018 + old_answers = .true. ; if (present(answer_date)) old_answers = (answer_date < 20190101) ! Loop on rows to transform the problem into multiplication by an upper-right matrix. do i = 1,N-1 @@ -110,16 +116,18 @@ end subroutine solve_linear_system !! The matrix A must be square, with the first index varing along the row. subroutine linear_solver( N, A, R, X ) integer, intent(in) :: N !< The size of the system - real, dimension(N,N), intent(inout) :: A !< The matrix being inverted [nondim] - real, dimension(N), intent(inout) :: R !< system right-hand side [A] - real, dimension(N), intent(inout) :: X !< solution vector [A] + real, dimension(N,N), intent(inout) :: A !< The matrix being inverted in arbitrary units [A] on + !! input, but internally modified to become nondimensional + !! during the solver. + real, dimension(N), intent(inout) :: R !< system right-hand side in [A B] on input, but internally + !! modified to have units of [B] during the solver + real, dimension(N), intent(inout) :: X !< solution vector [B] ! Local variables - real, parameter :: eps = 0.0 ! Minimum pivot magnitude allowed - real :: factor ! The factor that eliminates the leading nonzero element in a row. - real :: I_pivot ! The reciprocal of the pivot value [inverse of the input units of a row of A] - real :: swap - logical :: found_pivot ! If true, a pivot has been found + real, parameter :: eps = 0.0 ! Minimum pivot magnitude allowed [A] + real :: factor ! The factor that eliminates the leading nonzero element in a row [A-1]. + real :: I_pivot ! The reciprocal of the pivot value [A-1] + real :: swap ! Swap space used in various units [various] integer :: i, j, k ! Loop on rows to transform the problem into multiplication by an upper-right matrix. @@ -158,7 +166,7 @@ subroutine linear_solver( N, A, R, X ) if (A(N,N) == 0.0) then ! no pivot could be found, and the sytem is singular call MOM_error(FATAL, 'The final pivot in linear_solver is zero.') - end if + endif ! Solve the system by back substituting into what is now an upper-right matrix. X(N) = R(N) / A(N,N) ! The last row is now trivially solved. @@ -174,22 +182,23 @@ end subroutine linear_solver !! !! This routine uses Thomas's algorithm to solve the tridiagonal system AX = R. !! (A is made up of lower, middle and upper diagonals) -subroutine solve_tridiagonal_system( Al, Ad, Au, R, X, N, answers_2018 ) +subroutine solve_tridiagonal_system( Al, Ad, Au, R, X, N, answer_date ) integer, intent(in) :: N !< The size of the system - real, dimension(N), intent(in) :: Ad !< Matrix center diagonal - real, dimension(N), intent(in) :: Al !< Matrix lower diagonal - real, dimension(N), intent(in) :: Au !< Matrix upper diagonal - real, dimension(N), intent(in) :: R !< system right-hand side - real, dimension(N), intent(out) :: X !< solution vector - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + real, dimension(N), intent(in) :: Ad !< Matrix center diagonal in arbitrary units [A] + real, dimension(N), intent(in) :: Al !< Matrix lower diagonal [A] + real, dimension(N), intent(in) :: Au !< Matrix upper diagonal [A] + real, dimension(N), intent(in) :: R !< system right-hand side in arbitrary units [A B] + real, dimension(N), intent(out) :: X !< solution vector in arbitrary units [B] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Local variables - real, dimension(N) :: pivot, Al_piv - real, dimension(N) :: c1 ! Au / pivot for the backward sweep - real :: I_pivot ! The inverse of the most recent pivot + real, dimension(N) :: pivot ! The pivot value [A] + real, dimension(N) :: Al_piv ! The lower diagonal divided by the pivot value [nondim] + real, dimension(N) :: c1 ! Au / pivot for the backward sweep [nondim] + real :: I_pivot ! The inverse of the most recent pivot [A-1] integer :: k ! Loop index logical :: old_answers ! If true, use expressions that give the original (2008 through 2018) MOM6 answers - old_answers = .true. ; if (present(answers_2018)) old_answers = answers_2018 + old_answers = .true. ; if (present(answer_date)) old_answers = (answer_date < 20190101) if (old_answers) then ! This version gives the same answers as the original (2008 through 2018) MOM6 code @@ -238,16 +247,16 @@ end subroutine solve_tridiagonal_system !! roundoff compared with (Al+Au), the answers are prone to inaccuracy. subroutine solve_diag_dominant_tridiag( Al, Ac, Au, R, X, N ) integer, intent(in) :: N !< The size of the system - real, dimension(N), intent(in) :: Ac !< Matrix center diagonal offset from Al + Au - real, dimension(N), intent(in) :: Al !< Matrix lower diagonal - real, dimension(N), intent(in) :: Au !< Matrix upper diagonal - real, dimension(N), intent(in) :: R !< system right-hand side - real, dimension(N), intent(out) :: X !< solution vector + real, dimension(N), intent(in) :: Ac !< Matrix center diagonal offset from Al + Au in arbitrary units [A] + real, dimension(N), intent(in) :: Al !< Matrix lower diagonal [A] + real, dimension(N), intent(in) :: Au !< Matrix upper diagonal [A] + real, dimension(N), intent(in) :: R !< system right-hand side in arbitrary units [A B] + real, dimension(N), intent(out) :: X !< solution vector in arbitrary units [B] ! Local variables - real, dimension(N) :: c1 ! Au / pivot for the backward sweep - real :: d1 ! The next value of 1.0 - c1 - real :: I_pivot ! The inverse of the most recent pivot - real :: denom_t1 ! The first term in the denominator of the inverse of the pivot. + real, dimension(N) :: c1 ! Au / pivot for the backward sweep [nondim] + real :: d1 ! The next value of 1.0 - c1 [nondim] + real :: I_pivot ! The inverse of the most recent pivot [A-1] + real :: denom_t1 ! The first term in the denominator of the inverse of the pivot [A] integer :: k ! Loop index ! Factorization and forward sweep, in a form that will never give a division by a diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index ba784f4a40..f26013c1a5 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1,12 +1,14 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> The central module of the MOM6 ocean model module MOM -! This file is part of MOM6. See LICENSE.md for the license. - ! Infrastructure modules use MOM_array_transform, only : rotate_array, rotate_vector -use MOM_debugging, only : MOM_debugging_init, hchksum, uvchksum -use MOM_debugging, only : check_redundant +use MOM_debugging, only : MOM_debugging_init, hchksum, uvchksum, totalTandS +use MOM_debugging, only : check_redundant, query_debugging_checks use MOM_checksum_packages, only : MOM_thermo_chksum, MOM_state_chksum use MOM_checksum_packages, only : MOM_accel_chksum, MOM_surface_chksum use MOM_coms, only : num_PEs @@ -23,7 +25,7 @@ module MOM use MOM_diag_mediator, only : diag_grid_storage, diag_grid_storage_init use MOM_diag_mediator, only : diag_save_grids, diag_restore_grids use MOM_diag_mediator, only : diag_copy_storage_to_diag, diag_copy_diag_to_storage -use MOM_domains, only : MOM_domains_init +use MOM_domains, only : MOM_domains_init, MOM_domain_type use MOM_domains, only : sum_across_PEs, pass_var, pass_vector use MOM_domains, only : clone_MOM_domain, deallocate_MOM_domain use MOM_domains, only : To_North, To_East, To_South, To_West @@ -34,32 +36,38 @@ module MOM use MOM_error_handler, only : MOM_set_verbosity, callTree_showQuery use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : read_param, get_param, log_version, param_file_type -use MOM_forcing_type, only : forcing, mech_forcing +use MOM_forcing_type, only : forcing, mech_forcing, find_ustar use MOM_forcing_type, only : MOM_forcing_chksum, MOM_mech_forcing_chksum use MOM_get_input, only : Get_MOM_Input, directories use MOM_io, only : MOM_io_init, vardesc, var_desc use MOM_io, only : slasher, file_exists, MOM_read_data use MOM_obsolete_params, only : find_obsolete_params -use MOM_restart, only : register_restart_field, register_restart_pair -use MOM_restart, only : query_initialized, save_restart, restart_registry_lock +use MOM_restart, only : register_restart_field, register_restart_pair, save_restart +use MOM_restart, only : query_initialized, set_initialized, restart_registry_lock use MOM_restart, only : restart_init, is_new_run, determine_is_new_run, MOM_restart_CS use MOM_spatial_means, only : global_mass_integral -use MOM_time_manager, only : time_type, real_to_time, time_type_to_real, operator(+) +use MOM_time_manager, only : time_type, real_to_time, operator(+) use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) use MOM_time_manager, only : operator(>=), operator(==), increment_date use MOM_unit_tests, only : unit_tests ! MOM core modules -use MOM_ALE, only : ALE_init, ALE_end, ALE_main, ALE_CS, adjustGridForIntegrity +use MOM_ALE, only : ALE_init, ALE_end, ALE_regrid, ALE_CS, adjustGridForIntegrity use MOM_ALE, only : ALE_getCoordinate, ALE_getCoordinateUnits, ALE_writeCoordinateFile -use MOM_ALE, only : ALE_updateVerticalGridType, ALE_remap_init_conds, ALE_register_diags +use MOM_ALE, only : ALE_updateVerticalGridType, ALE_remap_init_conds, pre_ALE_adjustments +use MOM_ALE, only : ALE_remap_tracers, ALE_remap_velocities +use MOM_ALE, only : ALE_remap_set_h_vel, ALE_remap_set_h_vel_via_dz +use MOM_ALE, only : ALE_update_regrid_weights, pre_ALE_diagnostics, ALE_register_diags +use MOM_ALE, only : ALE_set_extrap_boundaries use MOM_ALE_sponge, only : rotate_ALE_sponge, update_ALE_sponge_field use MOM_barotropic, only : Barotropic_CS use MOM_boundary_update, only : call_OBC_register, OBC_register_end, update_OBC_CS -use MOM_coord_initialization, only : MOM_initialize_coord +use MOM_check_scaling, only : check_MOM6_scaling_factors +use MOM_coord_initialization, only : MOM_initialize_coord, write_vertgrid_file use MOM_diabatic_driver, only : diabatic, diabatic_driver_init, diabatic_CS, extract_diabatic_member use MOM_diabatic_driver, only : adiabatic, adiabatic_driver_init, diabatic_driver_end -use MOM_stochastics, only : stochastics_init, update_stochastics, stochastic_CS +use MOM_diabatic_driver, only : register_diabatic_restarts +use MOM_stochastics, only : stochastics_init, update_stochastics, stochastic_CS, apply_skeb use MOM_diagnostics, only : calculate_diagnostic_fields, MOM_diagnostics_init use MOM_diagnostics, only : register_transport_diags, post_transport_diagnostics use MOM_diagnostics, only : register_surface_diags, write_static_fields @@ -71,7 +79,11 @@ module MOM use MOM_dynamics_unsplit, only : MOM_dyn_unsplit_CS use MOM_dynamics_split_RK2, only : step_MOM_dyn_split_RK2, register_restarts_dyn_split_RK2 use MOM_dynamics_split_RK2, only : initialize_dyn_split_RK2, end_dyn_split_RK2 -use MOM_dynamics_split_RK2, only : MOM_dyn_split_RK2_CS +use MOM_dynamics_split_RK2, only : MOM_dyn_split_RK2_CS, remap_dyn_split_rk2_aux_vars +use MOM_dynamics_split_RK2, only : init_dyn_split_RK2_diabatic +use MOM_dynamics_split_RK2b, only : step_MOM_dyn_split_RK2b, register_restarts_dyn_split_RK2b +use MOM_dynamics_split_RK2b, only : initialize_dyn_split_RK2b, end_dyn_split_RK2b +use MOM_dynamics_split_RK2b, only : MOM_dyn_split_RK2b_CS, remap_dyn_split_RK2b_aux_vars use MOM_dynamics_unsplit_RK2, only : step_MOM_dyn_unsplit_RK2, register_restarts_dyn_unsplit_RK2 use MOM_dynamics_unsplit_RK2, only : initialize_dyn_unsplit_RK2, end_dyn_unsplit_RK2 use MOM_dynamics_unsplit_RK2, only : MOM_dyn_unsplit_RK2_CS @@ -82,11 +94,18 @@ module MOM use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing use MOM_forcing_type, only : deallocate_mech_forcing, deallocate_forcing_type use MOM_forcing_type, only : rotate_forcing, rotate_mech_forcing +use MOM_forcing_type, only : copy_common_forcing_fields, set_derived_forcing_fields +use MOM_forcing_type, only : homogenize_forcing, homogenize_mech_forcing use MOM_grid, only : ocean_grid_type, MOM_grid_init, MOM_grid_end -use MOM_grid, only : set_first_direction, rescale_grid_bathymetry +use MOM_grid, only : set_first_direction +use MOM_harmonic_analysis, only : HA_accum, harmonic_analysis_CS use MOM_hor_index, only : hor_index_type, hor_index_init use MOM_hor_index, only : rotate_hor_index -use MOM_interface_heights, only : find_eta +use MOM_interface_heights, only : find_eta, calc_derived_thermo, thickness_to_dz +use MOM_interface_filter, only : interface_filter, interface_filter_init, interface_filter_end +use MOM_interface_filter, only : interface_filter_CS +use MOM_internal_tides, only : int_tide_CS +use MOM_kappa_shear, only : kappa_shear_at_vertex use MOM_lateral_mixing_coeffs, only : calc_slope_functions, VarMix_init, VarMix_end use MOM_lateral_mixing_coeffs, only : calc_resoln_function, calc_depth_function, VarMix_CS use MOM_MEKE, only : MEKE_alloc_register_restart, step_forward_MEKE @@ -95,17 +114,26 @@ module MOM use MOM_mixed_layer_restrat, only : mixedlayer_restrat, mixedlayer_restrat_init, mixedlayer_restrat_CS use MOM_mixed_layer_restrat, only : mixedlayer_restrat_register_restarts use MOM_obsolete_diagnostics, only : register_obsolete_diagnostics -use MOM_open_boundary, only : ocean_OBC_type, OBC_registry_type -use MOM_open_boundary, only : register_temp_salt_segments -use MOM_open_boundary, only : open_boundary_register_restarts -use MOM_open_boundary, only : update_segment_tracer_reservoirs -use MOM_open_boundary, only : rotate_OBC_config, rotate_OBC_init -use MOM_set_visc, only : set_viscous_BBL, set_viscous_ML -use MOM_set_visc, only : set_visc_register_restarts, set_visc_CS +use MOM_open_boundary, only : ocean_OBC_type, open_boundary_end +use MOM_open_boundary, only : register_temp_salt_segments, update_segment_tracer_reservoirs +use MOM_open_boundary, only : read_OBC_segment_data, initialize_OBC_segment_reservoirs +use MOM_open_boundary, only : setup_OBC_tracer_reservoirs +use MOM_open_boundary, only : setup_OBC_thickness_reservoirs +use MOM_open_boundary, only : open_boundary_register_restarts, remap_OBC_fields +use MOM_open_boundary, only : open_boundary_setup_vert, initialize_segment_data +use MOM_open_boundary, only : update_OBC_segment_data, rotate_OBC_config +use MOM_open_boundary, only : open_boundary_halo_update, write_OBC_info, chksum_OBC_segments +use MOM_open_boundary, only : segment_thickness_reservoir_init +use MOM_porous_barriers, only : porous_widths_layer, porous_widths_interface, porous_barriers_init +use MOM_porous_barriers, only : porous_barrier_CS +use MOM_set_visc, only : set_viscous_BBL, set_viscous_ML, set_visc_CS +use MOM_set_visc, only : set_visc_register_restarts, remap_vertvisc_aux_vars use MOM_set_visc, only : set_visc_init, set_visc_end use MOM_shared_initialization, only : write_ocean_geometry_file use MOM_sponge, only : init_sponge_diags, sponge_CS -use MOM_state_initialization, only : MOM_initialize_state +use MOM_state_initialization, only : MOM_initialize_state, MOM_initialize_OBCs +use MOM_stoch_eos, only : MOM_stoch_eos_init, MOM_stoch_eos_run, MOM_stoch_eos_CS +use MOM_stoch_eos, only : stoch_EOS_register_restarts, post_stoch_EOS_diags, mom_calc_varT use MOM_sum_output, only : write_energy, accumulate_net_input use MOM_sum_output, only : MOM_sum_output_init, MOM_sum_output_end use MOM_sum_output, only : sum_output_CS @@ -118,26 +146,25 @@ module MOM use MOM_tracer_hor_diff, only : tracer_hor_diff_end, tracer_hor_diff_CS use MOM_tracer_registry, only : tracer_registry_type, register_tracer, tracer_registry_init use MOM_tracer_registry, only : register_tracer_diagnostics, post_tracer_diagnostics_at_sync -use MOM_tracer_registry, only : post_tracer_transport_diagnostics +use MOM_tracer_registry, only : post_tracer_transport_diagnostics, MOM_tracer_chksum use MOM_tracer_registry, only : preALE_tracer_diagnostics, postALE_tracer_diagnostics use MOM_tracer_registry, only : lock_tracer_registry, tracer_registry_end use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_CS use MOM_tracer_flow_control, only : tracer_flow_control_init, call_tracer_surface_state -use MOM_tracer_flow_control, only : tracer_flow_control_end +use MOM_tracer_flow_control, only : tracer_flow_control_end, call_tracer_register_obc_segments use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid -use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init -use MOM_unit_scaling, only : unit_scaling_end, fix_restart_unit_scaling +use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init, unit_scaling_end use MOM_variables, only : surface, allocate_surface_state, deallocate_surface_state -use MOM_variables, only : thermo_var_ptrs, vertvisc_type, porous_barrier_ptrs +use MOM_variables, only : thermo_var_ptrs, vertvisc_type, porous_barrier_type use MOM_variables, only : accel_diag_ptrs, cont_diag_ptrs, ocean_internal_state use MOM_variables, only : rotate_surface_state use MOM_verticalGrid, only : verticalGrid_type, verticalGridInit, verticalGridEnd -use MOM_verticalGrid, only : fix_restart_scaling use MOM_verticalGrid, only : get_thickness_units, get_flux_units, get_tr_flux_units -use MOM_wave_interface, only : wave_parameters_CS, waves_end +use MOM_wave_interface, only : wave_parameters_CS, waves_end, waves_register_restarts use MOM_wave_interface, only : Update_Stokes_Drift -use MOM_porous_barriers, only : porous_widths +! Database client used for machine-learning interface +use MOM_database_comms, only : dbcomms_CS_type, database_comms_init, dbclient_type ! ODA modules use MOM_oda_driver_mod, only : ODA_CS, oda, init_oda, oda_end @@ -151,10 +178,9 @@ module MOM use MOM_offline_main, only : offline_redistribute_residual, offline_diabatic_ale use MOM_offline_main, only : offline_fw_fluxes_into_ocean, offline_fw_fluxes_out_ocean use MOM_offline_main, only : offline_advection_layer, offline_transport_end -use MOM_ALE, only : ale_offline_tracer_final, ALE_main_offline use MOM_ice_shelf, only : ice_shelf_CS, ice_shelf_query, initialize_ice_shelf use MOM_particles_mod, only : particles, particles_init, particles_run, particles_save_restart, particles_end - +use MOM_particles_mod, only : particles_to_k_space, particles_to_z_space implicit none ; private #include @@ -178,8 +204,8 @@ module MOM type, public :: MOM_control_struct ; private real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: & h, & !< layer thickness [H ~> m or kg m-2] - T, & !< potential temperature [degC] - S !< salinity [ppt] + T, & !< potential temperature [C ~> degC] + S !< salinity [S ~> ppt] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: & u, & !< zonal velocity component [L T-1 ~> m s-1] uh, & !< uh = u * h * dy at u grid points [H L2 T-1 ~> m3 s-1 or kg s-1] @@ -196,8 +222,8 @@ module MOM real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: eta_av_bc !< free surface height or column mass time averaged over the last !! baroclinic dynamics time step [H ~> m or kg m-2] - real, dimension(:,:), pointer :: & - Hml => NULL() !< active mixed layer depth [Z ~> m] + real, dimension(:,:), pointer :: Hml => NULL() + !< active mixed layer depth, or 0 if there is no boundary layer scheme [Z ~> m] real :: time_in_cycle !< The running time of the current time-stepping cycle !! in calls that step the dynamics, and also the length of !! the time integral of ssh_rint [T ~> s]. @@ -207,6 +233,9 @@ module MOM type(ocean_grid_type) :: G_in !< Input grid metric type(ocean_grid_type), pointer :: G => NULL() !< Model grid metric logical :: rotate_index = .false. !< True if index map is rotated + logical :: homogenize_forcings = .false. !< True if all inputs are homogenized + logical :: update_ustar = .false. !< True to update ustar from homogenized tau + logical :: vertex_shear = .false. !< True if vertex shear is on type(verticalGrid_type), pointer :: & GV => NULL() !< structure containing vertical grid info @@ -238,52 +267,75 @@ module MOM logical :: use_ALE_algorithm !< If true, use the ALE algorithm rather than layered !! isopycnal/stacked shallow water mode. This logical is set by calling the !! function useRegridding() from the MOM_regridding module. + logical :: remap_aux_vars !< If true, apply ALE remapping to all of the auxiliary 3-D + !! variables that are needed to reproduce across restarts, + !! similarly to what is done with the primary state variables. + logical :: remap_uv_using_old_alg !< If true, use the old "remapping via a delta z" method for + !! velocities. If false, remap between two grids described by thicknesses. + + type(MOM_stoch_eos_CS) :: stoch_eos_CS !< structure containing random pattern for stoch EOS logical :: alternate_first_direction !< If true, alternate whether the x- or y-direction !! updates occur first in directionally split parts of the calculation. - real :: first_dir_restart = -1.0 !< A real copy of G%first_direction for use in restart files + real :: first_dir_restart = -1.0 !< A real copy of G%first_direction for use in restart files [nondim] logical :: offline_tracer_mode = .false. !< If true, step_offline() is called instead of step_MOM(). !! This is intended for running MOM6 in offline tracer mode + logical :: MEKE_in_dynamics !< If .true. (default), MEKE is called in the dynamics routine otherwise + !! it is called during the tracer dynamics type(time_type), pointer :: Time !< pointer to the ocean clock real :: dt !< (baroclinic) dynamics time step [T ~> s] - real :: dt_therm !< thermodynamics time step [T ~> s] + real :: dt_therm !< diabatic time step [T ~> s] + real :: dt_tr_adv !< tracer advection time step [T ~> s] logical :: thermo_spans_coupling !< If true, thermodynamic and tracer time !! steps can span multiple coupled time steps. + logical :: tradv_spans_coupling !< If true, thermodynamic and tracer time integer :: nstep_tot = 0 !< The total number of dynamic timesteps taken !! so far in this run segment logical :: count_calls = .false. !< If true, count the calls to step_MOM, rather than the !! number of dynamics steps in nstep_tot logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: debug_OBCs !< If true, write verbose OBC values for debugging purposes. integer :: ntrunc !< number u,v truncations since last call to write_energy integer :: cont_stencil !< The stencil for thickness from the continuity solver. + integer :: dyn_h_stencil !< The stencil for thickness for the dynamics based on + !! the continuity solver and Coriolis schemes. ! These elements are used to control the dynamics updates. logical :: do_dynamics !< If false, does not call step_MOM_dyn_*. This is an !! undocumented run-time flag that is fragile. logical :: split !< If true, use the split time stepping scheme. + logical :: use_alt_split !< If true, use a version of the split explicit time stepping + !! scheme that exchanges velocities with step_MOM that have the + !! average barotropic phase over a baroclinic timestep rather + !! than the instantaneous barotropic phase. logical :: use_RK2 !< If true, use RK2 instead of RK3 in unsplit mode !! (i.e., no split between barotropic and baroclinic). + logical :: interface_filter !< If true, apply an interface height filter immediately + !! after any calls to thickness_diffuse. logical :: thickness_diffuse !< If true, diffuse interface height w/ a diffusivity KHTH. logical :: thickness_diffuse_first !< If true, diffuse thickness before dynamics. + logical :: interface_filter_dt_bug !< If true, uses the wrong time interval in + !! calls to interface_filter and thickness_diffuse. logical :: mixedlayer_restrat !< If true, use submesoscale mixed layer restratifying scheme. logical :: useMEKE !< If true, call the MEKE parameterization. + logical :: use_stochastic_EOS !< If true, use the stochastic EOS parameterizations. logical :: useWaves !< If true, update Stokes drift - logical :: use_p_surf_in_EOS !< If true, always include the surface pressure contributions - !! in equation of state calculations. - logical :: use_diabatic_time_bug !< If true, uses the wrong calendar time for diabatic processes, - !! as was done in MOM6 versions prior to February 2018. real :: dtbt_reset_period !< The time interval between dynamic recalculation of the - !! barotropic time step [s]. If this is negative dtbt is never + !! barotropic time step [T ~> s]. If this is negative dtbt is never !! calculated, and if it is 0, dtbt is calculated every step. type(time_type) :: dtbt_reset_interval !< A time_time representation of dtbt_reset_period. - type(time_type) :: dtbt_reset_time !< The next time DTBT should be calculated. + type(time_type) :: dtbt_reset_time !< The next time DTBT should be calculated. + real :: dt_obc_seg_period !< The time interval between OBC segment updates for OBGC + !! tracers [T ~> s], or a negative value if the segment + !! data are time-invarant, or zero to update the OBGC + !! segment data with every call to update_OBC_segment_data. + type(time_type) :: dt_obc_seg_interval !< A time_time representation of dt_obc_seg_period. + type(time_type) :: dt_obc_seg_time !< The next time OBC segment update is applied to OBGC tracers. + real, dimension(:,:), pointer :: frac_shelf_h => NULL() !< fraction of total area occupied - !! by ice shelf [nondim] - real, dimension(:,:,:), pointer :: & - h_pre_dyn => NULL(), & !< The thickness before the transports [H ~> m or kg m-2]. - T_pre_dyn => NULL(), & !< Temperature before the transports [degC]. - S_pre_dyn => NULL() !< Salinity before the transports [ppt]. + !! by ice shelf [nondim] + real, dimension(:,:), pointer :: mass_shelf => NULL() !< Mass of ice shelf [R Z ~> kg m-2] type(accel_diag_ptrs) :: ADp !< structure containing pointers to accelerations, !! for derived diagnostics (e.g., energy budgets) type(cont_diag_ptrs) :: CDp !< structure containing pointers to continuity equation @@ -313,26 +365,30 @@ module MOM ! These elements are used to control the calculation and error checking of the surface state real :: Hmix !< Diagnostic mixed layer thickness over which to !! average surface tracer properties when a bulk - !! mixed layer is not used [Z ~> m], or a negative value + !! mixed layer is not used [H ~> m or kg m-2], or a negative value !! if a bulk mixed layer is being used. - real :: HFrz !< If HFrz > 0, the nominal depth over which melt potential is - !! computed [Z ~> m]. The actual depth over which melt potential is + real :: HFrz !< If HFrz > 0, the nominal depth over which melt potential is computed + !! [H ~> m or kg m-2]. The actual depth over which melt potential is !! computed is min(HFrz, OBLD), where OBLD is the boundary layer depth. !! If HFrz <= 0 (default), melt potential will not be computed. real :: Hmix_UV !< Depth scale over which to average surface flow to - !! feedback to the coupler/driver [Z ~> m] when + !! feedback to the coupler/driver [H ~> m or kg m-2] when !! bulk mixed layer is not used, or a negative value !! if a bulk mixed layer is being used. logical :: check_bad_sfc_vals !< If true, scan surface state for ridiculous values. real :: bad_val_ssh_max !< Maximum SSH before triggering bad value message [Z ~> m] - real :: bad_val_sst_max !< Maximum SST before triggering bad value message [degC] - real :: bad_val_sst_min !< Minimum SST before triggering bad value message [degC] - real :: bad_val_sss_max !< Maximum SSS before triggering bad value message [ppt] + real :: bad_val_sst_max !< Maximum SST before triggering bad value message [C ~> degC] + real :: bad_val_sst_min !< Minimum SST before triggering bad value message [C ~> degC] + real :: bad_val_sss_max !< Maximum SSS before triggering bad value message [S ~> ppt] real :: bad_val_col_thick !< Minimum column thickness before triggering bad value message [Z ~> m] - logical :: answers_2018 !< If true, use expressions for the surface properties that recover - !! the answers from the end of 2018. Otherwise, use more appropriate - !! expressions that differ at roundoff for non-Boussinesq cases. + integer :: answer_date !< The vintage of the expressions for the surface properties. Values + !! below 20190101 recover the answers from the end of 2018, while + !! higher values use more appropriate expressions that differ at + !! roundoff for non-Boussinesq cases. logical :: use_particles !< Turns on the particles package + logical :: use_uh_particles !< particles are advected by uh/h + logical :: uh_particles_bug !< If true, uses an inconsistent timestep for particle advection + logical :: use_dbclient !< Turns on the database client used for ML inference/analysis character(len=10) :: particle_type !< Particle types include: surface(default), profiling and sail drone. type(MOM_diag_IDs) :: IDs !< Handles used for diagnostics. @@ -349,9 +405,15 @@ module MOM !< Pointer to the control structure used for the unsplit RK2 dynamics type(MOM_dyn_split_RK2_CS), pointer :: dyn_split_RK2_CSp => NULL() !< Pointer to the control structure used for the mode-split RK2 dynamics + type(MOM_dyn_split_RK2b_CS), pointer :: dyn_split_RK2b_CSp => NULL() + !< Pointer to the control structure used for an alternate version of the mode-split RK2 dynamics + type(harmonic_analysis_CS), pointer :: HA_CSp => NULL() + !< Pointer to the control structure for harmonic analysis type(thickness_diffuse_CS) :: thickness_diffuse_CSp !< Pointer to the control structure used for the isopycnal height diffusive transport. !! This is also common referred to as Gent-McWilliams diffusion + type(interface_filter_CS) :: interface_filter_CSp + !< Control structure used for the interface height smoothing operator. type(mixedlayer_restrat_CS) :: mixedlayer_restrat_CSp !< Pointer to the control structure used for the mixed layer restratification type(set_visc_CS) :: set_visc_CSp @@ -379,9 +441,11 @@ module MOM type(sponge_CS), pointer :: sponge_CSp => NULL() !< Pointer to the layered-mode sponge control structure type(ALE_sponge_CS), pointer :: ALE_sponge_CSp => NULL() - !< Pointer to the oda incremental update control structure - type(oda_incupd_CS), pointer :: oda_incupd_CSp => NULL() !< Pointer to the ALE-mode sponge control structure + type(oda_incupd_CS), pointer :: oda_incupd_CSp => NULL() + !< Pointer to the oda incremental update control structure + type(int_tide_CS), pointer :: int_tide_CSp => NULL() + !< Pointer to the internal tides control structure type(ALE_CS), pointer :: ALE_CSp => NULL() !< Pointer to the Arbitrary Lagrangian Eulerian (ALE) vertical coordinate control structure @@ -392,6 +456,8 @@ module MOM !< Pointer to the MOM diagnostics control structure type(offline_transport_CS), pointer :: offline_CSp => NULL() !< Pointer to the offline tracer transport control structure + type(porous_barrier_CS) :: por_bar_CS + !< Control structure for porous barrier logical :: ensemble_ocean !< if true, this run is part of a !! larger ensemble for the purpose of data assimilation @@ -399,17 +465,14 @@ module MOM type(ODA_CS), pointer :: odaCS => NULL() !< a pointer to the control structure for handling !! ensemble model state vectors and data assimilation !! increments and priors - type(porous_barrier_ptrs) :: pbv !< porous barrier fractional cell metrics - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) & - :: por_face_areaU !< fractional open area of U-faces [nondim] - real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) & - :: por_face_areaV !< fractional open area of V-faces [nondim] - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NK_INTERFACE_) & - :: por_layer_widthU !< fractional open width of U-faces [nondim] - real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NK_INTERFACE_) & - :: por_layer_widthV !< fractional open width of V-faces [nondim] + type(dbcomms_CS_type) :: dbcomms_CS !< Control structure for database client used for online ML/AI + logical :: use_porbar !< If true, use porous barrier to constrain the widths and face areas + !! at the edges of the grid cells. + type(porous_barrier_type) :: pbv !< porous barrier fractional cell metrics type(particles), pointer :: particles => NULL() ! NULL() !< a pointer to the stochastics control structure + type(MOM_restart_CS), pointer :: restart_CS => NULL() + !< Pointer to MOM's restart control structure end type MOM_control_struct public initialize_MOM, finish_MOM_initialization, MOM_end @@ -417,16 +480,20 @@ module MOM public extract_surface_state, get_ocean_stocks public get_MOM_state_elements, MOM_state_is_synchronized public allocate_surface_state, deallocate_surface_state +public save_MOM_restart !>@{ CPU time clock IDs integer :: id_clock_ocean integer :: id_clock_dynamics integer :: id_clock_thermo +integer :: id_clock_MOM_end +integer :: id_clock_remap integer :: id_clock_tracer integer :: id_clock_diabatic integer :: id_clock_adiabatic integer :: id_clock_continuity ! also in dynamics s/r integer :: id_clock_thick_diff +integer :: id_clock_int_filter integer :: id_clock_BBL_visc integer :: id_clock_ml_restrat integer :: id_clock_diagnostics @@ -438,7 +505,10 @@ module MOM integer :: id_clock_ALE integer :: id_clock_other integer :: id_clock_offline_tracer +integer :: id_clock_save_restart integer :: id_clock_unit_tests +integer :: id_clock_stoch +integer :: id_clock_varT !>@} contains @@ -456,7 +526,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS !! tracer and mass exchange forcing fields type(surface), target, intent(inout) :: sfc_state !< surface ocean state type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type - real, intent(in) :: time_int_in !< time interval covered by this run segment [s]. + real, intent(in) :: time_int_in !< time interval covered by this run segment [T ~> s]. type(MOM_control_struct), intent(inout), target :: CS !< control structure from initialize_MOM type(Wave_parameters_CS), & optional, pointer :: Waves !< An optional pointer to a wave property CS @@ -471,7 +541,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS !! treated as the last call to step_MOM in a !! time-stepping cycle; missing is like true. real, optional, intent(in) :: cycle_length !< The amount of time in a coupled time - !! stepping cycle [s]. + !! stepping cycle [T ~> s]. logical, optional, intent(in) :: reset_therm !< This indicates whether the running sums of !! thermodynamic quantities should be reset. !! If missing, this is like start_cycle. @@ -483,8 +553,10 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS type(verticalGrid_type), pointer :: GV => NULL() ! Pointer to the vertical grid structure type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing ! various unit conversion factors - integer :: ntstep ! time steps between tracer updates or diabatic forcing + integer :: ntstep ! number of time steps between diabatic forcing updates + integer :: ntastep ! number of time steps between tracer advection updates integer :: n_max ! number of steps to take in this call + integer :: halo_sz, dynamics_stencil integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, n integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -492,8 +564,9 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS real :: time_interval ! time interval covered by this run segment [T ~> s]. real :: dt ! baroclinic time step [T ~> s] real :: dtdia ! time step for diabatic processes [T ~> s] + real :: dt_tr_adv ! time step for tracer advection [T ~> s] real :: dt_therm ! a limited and quantized version of CS%dt_therm [T ~> s] - real :: dt_therm_here ! a further limited value of dt_therm [T ~> s] + real :: dt_tradv_here ! a further limited value of dt_tr_adv [T ~> s] real :: wt_end, wt_beg ! Fractional weights of the future pressure at the end ! and beginning of the current time step [nondim] @@ -502,22 +575,30 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ! if it is not to be calculated anew [T ~> s]. real :: rel_time = 0.0 ! relative time since start of this call [T ~> s]. - logical :: calc_dtbt ! Indicates whether the dynamically adjusted - ! barotropic time step needs to be updated. - logical :: do_advection ! If true, it is time to advect tracers. - logical :: do_calc_bbl ! If true, calculate the boundary layer properties. - logical :: thermo_does_span_coupling ! If true, thermodynamic forcing spans - ! multiple dynamic timesteps. + logical :: do_advection ! If true, do tracer advection. + logical :: do_diabatic ! If true, do diabatic update. + logical :: thermo_does_span_coupling ! If true,thermodynamic (diabatic) forcing spans + ! multiple coupling timesteps. + logical :: tradv_does_span_coupling ! If true, tracer advection spans + ! multiple coupling timesteps. logical :: do_dyn ! If true, dynamics are updated with this call. logical :: do_thermo ! If true, thermodynamics and remapping may be applied with this call. + logical :: debug_redundant ! If true, check redundant values on PE boundaries when debugging. + logical :: nonblocking_p_surf_update ! A flag to indicate whether surface properties + ! can use nonblocking halo updates logical :: cycle_start ! If true, do calculations that are only done at the start of ! a stepping cycle (whatever that may mean). logical :: cycle_end ! If true, do calculations and diagnostics that are only done at ! the end of a stepping cycle (whatever that may mean). logical :: therm_reset ! If true, reset running sums of thermodynamic quantities. real :: cycle_time ! The length of the coupled time-stepping cycle [T ~> s]. + real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: & + U_star ! The wind friction velocity, calculated using the Boussinesq reference density or + ! the time-evolving surface density in non-Boussinesq mode [Z T-1 ~> m s-1] real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: & ssh ! sea surface height, which may be based on eta_av [Z ~> m] + real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)) :: & + dz ! Vertical distance across layers [Z ~> m] real, dimension(:,:,:), pointer :: & u => NULL(), & ! u : zonal velocity component [L T-1 ~> m s-1] @@ -527,7 +608,9 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS p_surf => NULL() ! A pointer to the ocean surface pressure [R L2 T-2 ~> Pa]. real :: I_wt_ssh ! The inverse of the time weights [T-1 ~> s-1] - type(time_type) :: Time_local, end_time_thermo, Time_temp + type(time_type) :: Time_local, end_time_thermo + type(time_type) :: Time_end_diag ! End time of a diagnostic segment, as a time type + type(group_pass_type) :: pass_tau_ustar_psurf logical :: showCallTree @@ -544,20 +627,21 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB u => CS%u ; v => CS%v ; h => CS%h - time_interval = US%s_to_T*time_int_in + time_interval = time_int_in do_dyn = .true. ; if (present(do_dynamics)) do_dyn = do_dynamics do_thermo = .true. ; if (present(do_thermodynamics)) do_thermo = do_thermodynamics if (.not.(do_dyn .or. do_thermo)) call MOM_error(FATAL,"Step_MOM: "//& "Both do_dynamics and do_thermodynamics are false, which makes no sense.") cycle_start = .true. ; if (present(start_cycle)) cycle_start = start_cycle cycle_end = .true. ; if (present(end_cycle)) cycle_end = end_cycle - cycle_time = time_interval ; if (present(cycle_length)) cycle_time = US%s_to_T*cycle_length + cycle_time = time_interval ; if (present(cycle_length)) cycle_time = cycle_length therm_reset = cycle_start ; if (present(reset_therm)) therm_reset = reset_therm call cpu_clock_begin(id_clock_ocean) call cpu_clock_begin(id_clock_other) if (CS%debug) then + call query_debugging_checks(do_redundant=debug_redundant) call MOM_state_chksum("Beginning of step_MOM ", u, v, h, CS%uh, CS%vh, G, GV, US) endif @@ -572,54 +656,102 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS call rotate_mech_forcing(forces_in, turns, forces) allocate(fluxes) - call allocate_forcing_type(fluxes_in, G, fluxes) + call allocate_forcing_type(fluxes_in, G, fluxes, turns=turns) call rotate_forcing(fluxes_in, fluxes, turns) else forces => forces_in fluxes => fluxes_in endif + ! Homogenize the forces + if (CS%homogenize_forcings) then + ! Homogenize all forcing and fluxes fields. + call homogenize_mech_forcing(forces, G, US, GV%Rho0, CS%update_ustar) + ! Note the following computes the mean ustar as the mean of ustar rather than + ! ustar of the mean of tau. + call homogenize_forcing(fluxes, G, GV, US) + if (CS%update_ustar) then + ! These calls corrects the ustar values + call copy_common_forcing_fields(forces, fluxes, G) + call set_derived_forcing_fields(forces, fluxes, G, US, GV%Rho0) + endif + endif + + ! This will be replaced later with the pressures from forces or fluxes if they are available. + if (associated(CS%tv%p_surf)) CS%tv%p_surf(:,:) = 0.0 + ! First determine the time step that is consistent with this call and an ! integer fraction of time_interval. if (do_dyn) then n_max = 1 if (time_interval > CS%dt) n_max = ceiling(time_interval/CS%dt - 0.001) + dt = time_interval / real(n_max) thermo_does_span_coupling = (CS%thermo_spans_coupling .and. & (CS%dt_therm > 1.5*cycle_time)) + tradv_does_span_coupling = (CS%tradv_spans_coupling .and. & + (CS%dt_tr_adv > 1.5*cycle_time)) if (thermo_does_span_coupling) then ! Set dt_therm to be an integer multiple of the coupling time step. dt_therm = cycle_time * floor(CS%dt_therm / cycle_time + 0.001) ntstep = floor(dt_therm/dt + 0.001) elseif (.not.do_thermo) then dt_therm = CS%dt_therm - if (present(cycle_length)) dt_therm = min(CS%dt_therm, US%s_to_T*cycle_length) - ! ntstep is not used. + if (present(cycle_length)) dt_therm = min(CS%dt_therm, cycle_length) + ntstep = 1 ! ntstep is initialized to avoid an error in a secondary logical test, + ! but the nonzero value of ntstep does not matter when do_thermo is false. else ntstep = MAX(1, MIN(n_max, floor(CS%dt_therm/dt + 0.001))) dt_therm = dt*ntstep endif - - if (associated(forces%p_surf)) p_surf => forces%p_surf - if (.not.associated(forces%p_surf)) CS%interp_p_surf = .false. - CS%tv%p_surf => NULL() - if (CS%use_p_surf_in_EOS .and. associated(forces%p_surf)) CS%tv%p_surf => forces%p_surf + if (tradv_does_span_coupling) then + ! Set dt_tr_adv to be an integer multiple of the coupling time step. + dt_tr_adv = cycle_time * floor(CS%dt_tr_adv / cycle_time + 0.001) + ntastep = floor(dt_tr_adv/dt + 0.001) + elseif (.not.do_thermo) then + dt_tr_adv = CS%dt_tr_adv + if (present(cycle_length)) dt_tr_adv = min(CS%dt_tr_adv, cycle_length) + ! ntastep is not used. + else + ntastep = MAX(1, MIN(n_max, floor(CS%dt_tr_adv/dt + 0.001))) + dt_tr_adv = dt*ntastep + endif !---------- Initiate group halo pass of the forcing fields call cpu_clock_begin(id_clock_pass) + ! Halo updates for surface pressure need to be completed before calling calc_resoln_function + ! among other routines if the surface pressure is used in the equation of state. + nonblocking_p_surf_update = G%nonblocking_updates .and. & + .not.(associated(CS%tv%p_surf) .and. associated(forces%p_surf) .and. & + allocated(CS%tv%SpV_avg) .and. associated(CS%tv%T)) if (.not.associated(forces%taux) .or. .not.associated(forces%tauy)) & call MOM_error(FATAL,'step_MOM:forces%taux,tauy not associated') call create_group_pass(pass_tau_ustar_psurf, forces%taux, forces%tauy, G%Domain) if (associated(forces%ustar)) & call create_group_pass(pass_tau_ustar_psurf, forces%ustar, G%Domain) + if (associated(forces%tau_mag)) & + call create_group_pass(pass_tau_ustar_psurf, forces%tau_mag, G%Domain) if (associated(forces%p_surf)) & call create_group_pass(pass_tau_ustar_psurf, forces%p_surf, G%Domain) - if (G%nonblocking_updates) then + if (nonblocking_p_surf_update) then call start_group_pass(pass_tau_ustar_psurf, G%Domain) else call do_group_pass(pass_tau_ustar_psurf, G%Domain) endif call cpu_clock_end(id_clock_pass) + + if (associated(forces%p_surf)) p_surf => forces%p_surf + if (.not.associated(forces%p_surf)) CS%interp_p_surf = .false. + if (associated(CS%tv%p_surf) .and. associated(forces%p_surf)) then + do j=jsd,jed ; do i=isd,ied ; CS%tv%p_surf(i,j) = forces%p_surf(i,j) ; enddo ; enddo + + if (allocated(CS%tv%SpV_avg) .and. associated(CS%tv%T)) then + ! The internal ocean state depends on the surface pressues, so update SpV_avg. + dynamics_stencil = min(3, G%Domain%nihalo, G%Domain%njhalo) + call calc_derived_thermo(CS%tv, h, G, GV, US, halo=dynamics_stencil, debug=CS%debug) + endif + endif + else ! This step only updates the thermodynamics so setting timesteps is simpler. n_max = 1 @@ -628,17 +760,31 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS dt = time_interval / real(n_max) dt_therm = dt ; ntstep = 1 + + if (CS%UseWaves .and. associated(fluxes%ustar)) & + call pass_var(fluxes%ustar, G%Domain, clock=id_clock_pass, halo=1) + if (CS%UseWaves .and. associated(fluxes%tau_mag)) & + call pass_var(fluxes%tau_mag, G%Domain, clock=id_clock_pass, halo=1) + if (associated(fluxes%p_surf)) p_surf => fluxes%p_surf - CS%tv%p_surf => NULL() - if (associated(fluxes%p_surf)) then - if (CS%use_p_surf_in_EOS) CS%tv%p_surf => fluxes%p_surf + if (associated(CS%tv%p_surf) .and. associated(fluxes%p_surf)) then + do j=js,je ; do i=is,ie ; CS%tv%p_surf(i,j) = fluxes%p_surf(i,j) ; enddo ; enddo + if (allocated(CS%tv%SpV_avg)) then + call pass_var(CS%tv%p_surf, G%Domain, clock=id_clock_pass) + ! The internal ocean state depends on the surface pressues, so update SpV_avg. + call extract_diabatic_member(CS%diabatic_CSp, diabatic_halo=halo_sz) + halo_sz = max(halo_sz, 1) + call calc_derived_thermo(CS%tv, h, G, GV, US, halo=halo_sz, debug=CS%debug) + endif endif - if (CS%UseWaves) call pass_var(fluxes%ustar, G%Domain, clock=id_clock_pass) endif if (therm_reset) then CS%time_in_thermo_cycle = 0.0 - if (associated(CS%tv%frazil)) CS%tv%frazil(:,:) = 0.0 + if (associated(CS%tv%frazil)) then + CS%tv%frazil(:,:) = 0.0 + CS%tv%frazil_was_reset = .true. + endif if (associated(CS%tv%salt_deficit)) CS%tv%salt_deficit(:,:) = 0.0 if (associated(CS%tv%TempxPmE)) CS%tv%TempxPmE(:,:) = 0.0 if (associated(CS%tv%internal_heat)) CS%tv%internal_heat(:,:) = 0.0 @@ -649,17 +795,19 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS do j=js,je ; do i=is,ie ; CS%ssh_rint(i,j) = 0.0 ; enddo ; enddo 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) + Time_end_diag = Time_start + real_to_time(cycle_time, unscale=US%T_to_s) + call enable_averages(cycle_time, Time_end_diag, CS%diag) + call calc_resoln_function(h, CS%tv, G, GV, US, CS%VarMix, CS%MEKE, CS%OBC, dt) call calc_depth_function(G, CS%VarMix) call disable_averaging(CS%diag) endif endif ! advance the random pattern if stochastic physics is active - if (CS%stoch_CS%do_sppt .OR. CS%stoch_CS%pert_epbl) call update_stochastics(CS%stoch_CS) + if (CS%stoch_CS%do_sppt .OR. CS%stoch_CS%pert_epbl .OR. CS%stoch_CS%do_skeb) & + call update_stochastics(CS%stoch_CS) if (do_dyn) then - if (G%nonblocking_updates) & + if (nonblocking_p_surf_update) & call complete_group_pass(pass_tau_ustar_psurf, G%Domain, clock=id_clock_pass) if (CS%interp_p_surf) then @@ -674,40 +822,42 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS else CS%p_surf_end => forces%p_surf endif - if (CS%UseWaves) then ! Update wave information, which is presently kept static over each call to step_mom - call enable_averages(time_interval, Time_start + real_to_time(US%T_to_s*time_interval), CS%diag) - call Update_Stokes_Drift(G, GV, US, Waves, h, forces%ustar) + Time_end_diag = Time_start + real_to_time(time_interval, unscale=US%T_to_s) + call enable_averages(time_interval, Time_end_diag, CS%diag) + call find_ustar(forces, CS%tv, U_star, G, GV, US, halo=1) + call thickness_to_dz(h, CS%tv, dz, G, GV, US, halo_size=1) + call Update_Stokes_Drift(G, GV, US, Waves, dz, U_star, time_interval, do_dyn) call disable_averaging(CS%diag) endif else ! not do_dyn. - if (CS%UseWaves) & ! Diagnostics are not enabled in this call. - call Update_Stokes_Drift(G, GV, US, Waves, h, fluxes%ustar) + if (CS%UseWaves) then ! Diagnostics are not enabled in this call. + call find_ustar(fluxes, CS%tv, U_star, G, GV, US, halo=1) + call thickness_to_dz(h, CS%tv, dz, G, GV, US, halo_size=1) + call Update_Stokes_Drift(G, GV, US, Waves, dz, U_star, time_interval, do_dyn) + endif endif if (CS%debug) then if (cycle_start) & call MOM_state_chksum("Before steps ", u, v, h, CS%uh, CS%vh, G, GV, US) - if (cycle_start) call check_redundant("Before steps ", u, v, G) + if (cycle_start .and. debug_redundant) & + call check_redundant("Before steps ", u, v, G, unscale=US%L_T_to_m_s) if (do_dyn) call MOM_mech_forcing_chksum("Before steps", forces, G, US, haloshift=0) - if (do_dyn) call check_redundant("Before steps ", forces%taux, forces%tauy, G) + if (do_dyn .and. debug_redundant) & + call check_redundant("Before steps ", forces%taux, forces%tauy, G, & + unscale=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) endif call cpu_clock_end(id_clock_other) rel_time = 0.0 do n=1,n_max - if (CS%use_diabatic_time_bug) then - ! This wrong form of update was used until Feb 2018, recovered with CS%use_diabatic_time_bug=T. - CS%Time = Time_start + real_to_time(US%T_to_s*int(floor(rel_time+0.5*dt+0.5))) - rel_time = rel_time + dt - else - rel_time = rel_time + dt ! The relative time at the end of the step. - ! Set the universally visible time to the middle of the time step. - CS%Time = Time_start + real_to_time(US%T_to_s*(rel_time - 0.5*dt)) - endif + rel_time = rel_time + dt ! The relative time at the end of the step. + ! Set the universally visible time to the middle of the time step. + CS%Time = Time_start + real_to_time(rel_time - 0.5*dt, unscale=US%T_to_s) ! Set the local time to the end of the time step. - Time_local = Time_start + real_to_time(US%T_to_s*rel_time) + Time_local = Time_start + real_to_time(rel_time, unscale=US%T_to_s) if (showCallTree) call callTree_enter("DT cycles (step_MOM) n=",n) @@ -735,31 +885,29 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS endif end_time_thermo = Time_local - if (dtdia > dt .and. .not. CS%use_diabatic_time_bug) then + if (dtdia > dt) then ! If necessary, temporarily reset CS%Time to the center of the period covered ! by the call to step_MOM_thermo, noting that they begin at the same time. - ! This step was missing prior to Feb 2018, and is skipped with CS%use_diabatic_time_bug=T. - CS%Time = CS%Time + real_to_time(0.5*US%T_to_s*(dtdia-dt)) - endif - if (dtdia > dt .or. CS%use_diabatic_time_bug) then + CS%Time = CS%Time + real_to_time(0.5*(dtdia-dt), unscale=US%T_to_s) ! The end-time of the diagnostic interval needs to be set ahead if there ! are multiple dynamic time steps worth of thermodynamics applied here. - ! This line was not conditional prior to Feb 2018, recovered with CS%use_diabatic_time_bug=T. - end_time_thermo = Time_local + real_to_time(US%T_to_s*(dtdia-dt)) + end_time_thermo = Time_local + real_to_time(dtdia-dt, unscale=US%T_to_s) endif ! Apply diabatic forcing, do mixing, and regrid. call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, dtdia, & end_time_thermo, .true., Waves=Waves) + if ( CS%use_ALE_algorithm ) & + call ALE_regridding_and_remapping(CS, G, GV, US, u, v, h, CS%tv, dtdia, Time_local) + call post_diabatic_halo_updates(CS, G, GV, US, u, v, h, CS%tv) CS%time_in_thermo_cycle = CS%time_in_thermo_cycle + dtdia ! The diabatic processes are now ahead of the dynamics by dtdia. CS%t_dyn_rel_thermo = -dtdia if (showCallTree) call callTree_waypoint("finished diabatic_first (step_MOM)") - if (dtdia > dt .and. .not. CS%use_diabatic_time_bug) & ! Reset CS%Time to its previous value. - ! This step was missing prior to Feb 2018, recovered with CS%use_diabatic_time_bug=T. - CS%Time = Time_start + real_to_time(US%T_to_s*(rel_time - 0.5*dt)) + if (dtdia > dt) & ! Reset CS%Time to its previous value. + CS%Time = Time_start + real_to_time(rel_time - 0.5*dt, unscale=US%T_to_s) endif ! end of block "(CS%diabatic_first .and. (CS%t_dyn_rel_adv==0.0))" if (do_dyn) then @@ -781,9 +929,15 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS enddo ; enddo ; enddo endif - dt_therm_here = dt_therm - if (do_thermo .and. do_dyn .and. .not.thermo_does_span_coupling) & - dt_therm_here = dt*min(ntstep, n_max-n+1) + if (CS%interface_filter_dt_bug) then + dt_tradv_here = dt_therm + if (do_thermo .and. do_dyn .and. .not.thermo_does_span_coupling) & + dt_tradv_here = dt*min(ntstep, n_max-n+1) + else + dt_tradv_here = dt_tr_adv + if (do_thermo .and. do_dyn .and. .not.tradv_does_span_coupling) & + dt_tradv_here = dt*min(ntstep, n_max-n+1) + endif ! Indicate whether the bottom boundary layer properties need to be ! recalculated, and if so for how long an interval they are valid. @@ -807,18 +961,17 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS enddo ; enddo endif - call step_MOM_dynamics(forces, CS%p_surf_begin, CS%p_surf_end, dt, & - dt_therm_here, bbl_time_int, CS, & + dt_tradv_here, bbl_time_int, CS, & Time_local, Waves=Waves) !=========================================================================== ! This is the start of the tracer advection part of the algorithm. - - if (thermo_does_span_coupling .or. .not.do_thermo) then - do_advection = (CS%t_dyn_rel_adv + 0.5*dt > dt_therm) + if (tradv_does_span_coupling .or. .not.do_thermo) then + do_advection = ((CS%t_dyn_rel_adv + 0.5*dt > dt_tr_adv) .or. & + (CS%t_dyn_rel_thermo + 0.5*dt > dt_therm)) else - do_advection = ((MOD(n,ntstep) == 0) .or. (n==n_max)) + do_advection = ((MOD(n,ntastep) == 0) .or. (n==n_max)) endif if (do_advection) then ! Do advective transport and lateral tracer mixing. @@ -831,7 +984,12 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS !=========================================================================== ! This is the second place where the diabatic processes and remapping could occur. - if ((CS%t_dyn_rel_adv==0.0) .and. do_thermo .and. (.not.CS%diabatic_first)) then + if (thermo_does_span_coupling .or. .not.do_dyn) then + do_diabatic = (do_thermo .and. (CS%t_dyn_rel_thermo + 0.5*dt > dt_therm)) + else + do_diabatic = (do_thermo .and. ((MOD(n,ntstep) == 0) .or. (n==n_max))) + endif + if ((CS%t_dyn_rel_adv==0.0) .and. (.not.CS%diabatic_first) .and. do_diabatic) then dtdia = CS%t_dyn_rel_thermo ! If the MOM6 dynamic and thermodynamic time stepping is being orchestrated @@ -846,13 +1004,15 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ! If necessary, temporarily reset CS%Time to the center of the period covered ! by the call to step_MOM_thermo, noting that they end at the same time. - ! This step was missing prior to Feb 2018, and is skipped with CS%use_diabatic_time_bug=T. - if (dtdia > dt .and. .not. CS%use_diabatic_time_bug) & - CS%Time = CS%Time - real_to_time(0.5*US%T_to_s*(dtdia-dt)) + if (dtdia > dt) & + CS%Time = CS%Time - real_to_time(0.5*(dtdia-dt), unscale=US%T_to_s) ! Apply diabatic forcing, do mixing, and regrid. call step_MOM_thermo(CS, G, GV, US, u, v, h, CS%tv, fluxes, dtdia, & Time_local, .false., Waves=Waves) + if ( CS%use_ALE_algorithm ) & + call ALE_regridding_and_remapping(CS, G, GV, US, u, v, h, CS%tv, dtdia, Time_local) + call post_diabatic_halo_updates(CS, G, GV, US, u, v, h, CS%tv) CS%time_in_thermo_cycle = CS%time_in_thermo_cycle + dtdia if ((CS%t_dyn_rel_thermo==0.0) .and. .not.do_dyn) then @@ -863,9 +1023,8 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS endif ! Reset CS%Time to its previous value. - ! This step was missing prior to Feb 2018, and is skipped with CS%use_diabatic_time_bug=T. - if (dtdia > dt .and. .not. CS%use_diabatic_time_bug) & - CS%Time = Time_start + real_to_time(US%T_to_s*(rel_time - 0.5*dt)) + if (dtdia > dt) & + CS%Time = Time_start + real_to_time(rel_time - 0.5*dt, unscale=US%T_to_s) endif if (do_dyn) then @@ -877,7 +1036,11 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS do j=js,je ; do i=is,ie CS%ssh_rint(i,j) = CS%ssh_rint(i,j) + dt*ssh(i,j) enddo ; enddo - if (CS%IDs%id_ssh_inst > 0) call post_data(CS%IDs%id_ssh_inst, ssh, CS%diag) + if (CS%IDs%id_ssh_inst > 0) then + call enable_averages(dt, Time_local, CS%diag) + call post_data(CS%IDs%id_ssh_inst, ssh, CS%diag) + call disable_averaging(CS%diag) + endif call cpu_clock_end(id_clock_dynamics) endif @@ -916,6 +1079,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ssh(i,j) = CS%ssh_rint(i,j)*I_wt_ssh CS%ave_ssh_ibc(i,j) = ssh(i,j) enddo ; enddo + if (associated(CS%HA_CSp)) call HA_accum('ssh', ssh, Time_local, G, CS%HA_CSp) if (do_dyn) then call adjust_ssh_for_p_atm(CS%tv, G, GV, US, CS%ave_ssh_ibc, forces%p_surf_SSH, & CS%calc_rho_for_sea_lev) @@ -944,9 +1108,10 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ! Do diagnostics that only occur at the end of a complete forcing step. if (cycle_end) then + if (showCallTree) call callTree_waypoint("Do cycle end diagnostics (step_MOM)") if (CS%rotate_index) then allocate(sfc_state_diag) - call rotate_surface_state(sfc_state, G_in, sfc_state_diag, G, turns) + call rotate_surface_state(sfc_state, sfc_state_diag, G, turns) else sfc_state_diag => sfc_state endif @@ -963,6 +1128,10 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS endif call disable_averaging(CS%diag) call cpu_clock_end(id_clock_diagnostics) + if (CS%rotate_index) then + call deallocate_surface_state(sfc_state_diag) + endif + if (showCallTree) call callTree_waypoint("Done with end cycle diagnostics (step_MOM)") endif ! Accumulate the surface fluxes for assessing conservation @@ -973,7 +1142,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS if (MOM_state_is_synchronized(CS)) & call write_energy(CS%u, CS%v, CS%h, CS%tv, Time_local, CS%nstep_tot, & G, GV, US, CS%sum_output_CSp, CS%tracer_flow_CSp, & - dt_forcing=real_to_time(US%T_to_s*time_interval) ) + dt_forcing=real_to_time(time_interval, unscale=US%T_to_s) ) call cpu_clock_end(id_clock_other) @@ -993,7 +1162,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS end subroutine step_MOM !> Time step the ocean dynamics, including the momentum and continuity equations -subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & +subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_tr_adv, & bbl_time_int, CS, Time_local, Waves) type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces real, dimension(:,:), pointer :: p_surf_begin !< A pointer (perhaps NULL) to the surface @@ -1003,7 +1172,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & !! pressure at the end of this dynamic step, !! intent in [R L2 T-2 ~> Pa]. real, intent(in) :: dt !< time interval covered by this call [T ~> s]. - real, intent(in) :: dt_thermo !< time interval covered by any updates that may + real, intent(in) :: dt_tr_adv !< time interval covered by any updates that may !! span multiple dynamics steps [T ~> s]. real, intent(in) :: bbl_time_int !< time interval over which updates to the !! bottom boundary layer properties will apply [T ~> s], @@ -1026,6 +1195,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & v => NULL(), & ! v : meridional velocity component [L T-1 ~> m s-1] h => NULL() ! h : layer thickness [H ~> m or kg m-2] + type(time_type) :: Time_end_diag ! End time of a diagnostic segment, as a time type logical :: calc_dtbt ! Indicates whether the dynamically adjusted ! barotropic time step needs to be updated. logical :: showCallTree @@ -1033,8 +1203,6 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)+1) :: eta_por ! layer interface heights - !! for porous topo. [Z ~> m or 1/eta_to_m] G => CS%G ; GV => CS%GV ; US => CS%US ; IDs => CS%IDs is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -1044,32 +1212,63 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & showCallTree = callTree_showQuery() call cpu_clock_begin(id_clock_dynamics) + call cpu_clock_begin(id_clock_stoch) + if (CS%use_stochastic_EOS) call MOM_stoch_eos_run(G, u, v, dt, Time_local, CS%stoch_eos_CS) + call cpu_clock_end(id_clock_stoch) + call cpu_clock_begin(id_clock_varT) + if (CS%use_stochastic_EOS) then + call MOM_calc_varT(G, GV, US, h, CS%tv, CS%stoch_eos_CS, dt) + if (associated(CS%tv%varT)) call pass_var(CS%tv%varT, G%Domain, clock=id_clock_pass, halo=1) + endif + call cpu_clock_end(id_clock_varT) + + if ((CS%t_dyn_rel_adv == 0.0) .and. CS%thickness_diffuse_first .and. & + (CS%thickness_diffuse .or. CS%interface_filter)) then + + Time_end_diag = Time_local + real_to_time(dt_tr_adv - dt, unscale=US%T_to_s) + call enable_averages(dt_tr_adv, Time_end_diag, CS%diag) + if (CS%thickness_diffuse) then + call cpu_clock_begin(id_clock_thick_diff) + if (CS%VarMix%use_variable_mixing) & + call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix, OBC=CS%OBC) + call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt_tr_adv, G, GV, US, & + CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp, & + CS%stoch_CS) + call cpu_clock_end(id_clock_thick_diff) + call pass_var(h, G%Domain, clock=id_clock_pass, halo=CS%dyn_h_stencil) + if (showCallTree) call callTree_waypoint("finished thickness_diffuse_first (step_MOM)") + endif - if ((CS%t_dyn_rel_adv == 0.0) .and. CS%thickness_diffuse .and. CS%thickness_diffuse_first) then + if (CS%interface_filter) then + if (allocated(CS%tv%SpV_avg)) call pass_var(CS%tv%SpV_avg, G%Domain, clock=id_clock_pass) + CS%tv%valid_SpV_halo = min(G%Domain%nihalo, G%Domain%njhalo) + call cpu_clock_begin(id_clock_int_filter) + call interface_filter(h, CS%uhtr, CS%vhtr, CS%tv, dt_tr_adv, G, GV, US, & + CS%CDp, CS%interface_filter_CSp) + call cpu_clock_end(id_clock_int_filter) + call pass_var(h, G%Domain, clock=id_clock_pass, halo=CS%dyn_h_stencil) + if (showCallTree) call callTree_waypoint("finished interface_filter_first (step_MOM)") + endif - call enable_averages(dt_thermo, Time_local+real_to_time(US%T_to_s*(dt_thermo-dt)), CS%diag) - call cpu_clock_begin(id_clock_thick_diff) - if (CS%VarMix%use_variable_mixing) & - call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix, OBC=CS%OBC) - call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt_thermo, G, GV, US, & - CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp) - call cpu_clock_end(id_clock_thick_diff) - call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil)) call disable_averaging(CS%diag) - if (showCallTree) call callTree_waypoint("finished thickness_diffuse_first (step_MOM)") - ! Whenever thickness changes let the diag manager know, target grids ! for vertical remapping may need to be regenerated. call diag_update_remap_grids(CS%diag) endif - !update porous barrier fractional cell metrics - call porous_widths(h, CS%tv, G, GV, US, eta_por, CS%pbv) + ! Update porous barrier fractional cell metrics + if (CS%use_porbar) then + call enable_averages(dt, Time_local, CS%diag) + call porous_widths_layer(h, CS%tv, G, GV, US, CS%pbv, CS%por_bar_CS) + call disable_averaging(CS%diag) + call pass_vector(CS%pbv%por_face_areaU, CS%pbv%por_face_areaV, & + G%Domain, direction=To_All+SCALAR_PAIR, clock=id_clock_pass, halo=CS%cont_stencil) + endif ! The bottom boundary layer properties need to be recalculated. if (bbl_time_int > 0.0) then - call enable_averages(bbl_time_int, & - Time_local + real_to_time(US%T_to_s*(bbl_time_int-dt)), CS%diag) + Time_end_diag = Time_local + real_to_time(bbl_time_int - dt, unscale=US%T_to_s) + call enable_averages(bbl_time_int, Time_end_diag, CS%diag) ! Calculate the BBL properties and store them inside visc (u,h). call cpu_clock_begin(id_clock_BBL_visc) call set_viscous_BBL(CS%u, CS%v, CS%h, CS%tv, CS%visc, G, GV, US, CS%set_visc_CSp, CS%pbv) @@ -1078,6 +1277,18 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & call disable_averaging(CS%diag) endif + !OBC segment data update for some fields can be less frequent than others + if (associated(CS%OBC)) then + CS%OBC%update_OBC_seg_data = .false. + if (CS%dt_obc_seg_period == 0.0) CS%OBC%update_OBC_seg_data = .true. + if (CS%dt_obc_seg_period > 0.0) then + if (Time_local >= CS%dt_obc_seg_time) then + CS%OBC%update_OBC_seg_data = .true. + CS%dt_obc_seg_time = CS%dt_obc_seg_time + CS%dt_obc_seg_interval + endif + endif + endif + ! if (CS%debug_OBCs .and. associated(CS%OBC)) call chksum_OBC_segments(CS%OBC, G, GV, US, 3) if (CS%do_dynamics .and. CS%split) then !--------------------------- start SPLIT ! This section uses a split time stepping scheme for the dynamic equations, @@ -1092,10 +1303,17 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & endif endif - call step_MOM_dyn_split_RK2(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & - p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & - CS%eta_av_bc, G, GV, US, CS%dyn_split_RK2_CSp, calc_dtbt, CS%VarMix, & - CS%MEKE, CS%thickness_diffuse_CSp, CS%pbv, waves=waves) + if (CS%use_alt_split) then + call step_MOM_dyn_split_RK2b(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & + p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & + CS%eta_av_bc, G, GV, US, CS%dyn_split_RK2b_CSp, calc_dtbt, CS%VarMix, & + CS%MEKE, CS%thickness_diffuse_CSp, CS%pbv, waves=waves) + else + call step_MOM_dyn_split_RK2(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & + p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & + CS%eta_av_bc, G, GV, US, CS%dyn_split_RK2_CSp, calc_dtbt, CS%VarMix, & + CS%MEKE, CS%thickness_diffuse_CSp, CS%pbv, CS%stoch_CS, waves=waves) + endif if (showCallTree) call callTree_waypoint("finished step_MOM_dyn_split (step_MOM)") elseif (CS%do_dynamics) then ! ------------------------------------ not SPLIT @@ -1109,55 +1327,104 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & if (CS%use_RK2) then call step_MOM_dyn_unsplit_RK2(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & - CS%eta_av_bc, G, GV, US, CS%dyn_unsplit_RK2_CSp, CS%VarMix, CS%MEKE, CS%pbv) + CS%eta_av_bc, G, GV, US, CS%dyn_unsplit_RK2_CSp, CS%VarMix, CS%MEKE, CS%pbv, & + CS%stoch_CS) else call step_MOM_dyn_unsplit(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & - CS%eta_av_bc, G, GV, US, CS%dyn_unsplit_CSp, CS%VarMix, CS%MEKE, CS%pbv, Waves=Waves) + CS%eta_av_bc, G, GV, US, CS%dyn_unsplit_CSp, CS%VarMix, CS%MEKE, CS%pbv, & + CS%stoch_CS, Waves=Waves) endif if (showCallTree) call callTree_waypoint("finished step_MOM_dyn_unsplit (step_MOM)") endif ! -------------------------------------------------- end SPLIT - if (CS%do_dynamics) then!run particles whether or not stepping is split - if (CS%use_particles) then - call particles_run(CS%particles, Time_local, CS%u, CS%v, CS%h, CS%tv) ! Run the particles model - endif - endif + if (CS%use_particles .and. CS%do_dynamics .and. (.not. CS%use_uh_particles)) then + if (CS%thickness_diffuse_first) call MOM_error(WARNING,"particles_run: "//& + "Thickness_diffuse_first is true and use_uh_particles is false. "//& + "This is usually a bad combination.") + !Run particles using unweighted velocity + call particles_run(CS%particles, Time_local, CS%u, CS%v, CS%h, & + CS%tv, dt, CS%use_uh_particles) + call particles_to_z_space(CS%particles, h) + endif + + ! Update the model's current to reflect wind-wave growth + if (Waves%Stokes_DDT .and. (.not.Waves%Passive_Stokes_DDT)) then + do J=jsq,jeq ; do i=is,ie + v(i,J,:) = v(i,J,:) + Waves%ddt_us_y(i,J,:)*dt + enddo ; enddo + do j=js,je ; do I=isq,ieq + u(I,j,:) = u(I,j,:) + Waves%ddt_us_x(I,j,:)*dt + enddo ; enddo + call pass_vector(u, v, G%Domain) + endif + ! Added an additional output to track Stokes drift time tendency. + ! It is mostly for debugging, and perhaps doesn't need to hang + ! around permanently. + if (Waves%Stokes_DDT .and. (Waves%id_3dstokes_y_from_ddt>0)) then + do J=jsq,jeq ; do i=is,ie + Waves%us_y_from_ddt(i,J,:) = Waves%us_y_from_ddt(i,J,:) + Waves%ddt_us_y(i,J,:)*dt + enddo ; enddo + endif + if (Waves%Stokes_DDT .and. (Waves%id_3dstokes_x_from_ddt>0)) then + do j=js,je ; do I=isq,ieq + Waves%us_x_from_ddt(I,j,:) = Waves%us_x_from_ddt(I,j,:) + Waves%ddt_us_x(I,j,:)*dt + enddo ; enddo + endif - if (CS%thickness_diffuse .and. .not.CS%thickness_diffuse_first) then - call cpu_clock_begin(id_clock_thick_diff) + if ((CS%thickness_diffuse .or. CS%interface_filter) .and. & + .not.CS%thickness_diffuse_first) then - if (CS%debug) call hchksum(h,"Pre-thickness_diffuse h", G%HI, haloshift=0, scale=GV%H_to_m) + if (CS%debug) call hchksum(h,"Pre-thickness_diffuse h", G%HI, haloshift=0, unscale=GV%H_to_MKS) - if (CS%VarMix%use_variable_mixing) & - call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix, OBC=CS%OBC) - call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt, G, GV, US, & - CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp) + if (CS%thickness_diffuse) then + call cpu_clock_begin(id_clock_thick_diff) + if (CS%VarMix%use_variable_mixing) & + call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix, OBC=CS%OBC) + call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt, G, GV, US, & + CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp, CS%stoch_CS) - if (CS%debug) call hchksum(h,"Post-thickness_diffuse h", G%HI, haloshift=1, scale=GV%H_to_m) - call cpu_clock_end(id_clock_thick_diff) - call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil)) - if (showCallTree) call callTree_waypoint("finished thickness_diffuse (step_MOM)") + call cpu_clock_end(id_clock_thick_diff) + call pass_var(h, G%Domain, clock=id_clock_pass, halo=CS%dyn_h_stencil) + if (CS%debug) call hchksum(h,"Post-thickness_diffuse h", G%HI, haloshift=1, unscale=GV%H_to_MKS) + if (showCallTree) call callTree_waypoint("finished thickness_diffuse (step_MOM)") + endif + + if (CS%interface_filter) then + if (allocated(CS%tv%SpV_avg)) call pass_var(CS%tv%SpV_avg, G%Domain, clock=id_clock_pass) + CS%tv%valid_SpV_halo = min(G%Domain%nihalo, G%Domain%njhalo) + call cpu_clock_begin(id_clock_int_filter) + if (CS%interface_filter_dt_bug) then + call interface_filter(h, CS%uhtr, CS%vhtr, CS%tv, dt_tr_adv, G, GV, US, & + CS%CDp, CS%interface_filter_CSp) + else + call interface_filter(h, CS%uhtr, CS%vhtr, CS%tv, dt, G, GV, US, & + CS%CDp, CS%interface_filter_CSp) + endif + call cpu_clock_end(id_clock_int_filter) + call pass_var(h, G%Domain, clock=id_clock_pass, halo=CS%dyn_h_stencil) + if (showCallTree) call callTree_waypoint("finished interface_filter (step_MOM)") + endif endif ! apply the submesoscale mixed layer restratification parameterization if (CS%mixedlayer_restrat) then if (CS%debug) then - call hchksum(h,"Pre-mixedlayer_restrat h", G%HI, haloshift=1, scale=GV%H_to_m) + call hchksum(h,"Pre-mixedlayer_restrat h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call uvchksum("Pre-mixedlayer_restrat uhtr", & - CS%uhtr, CS%vhtr, G%HI, haloshift=0, scale=GV%H_to_m*US%L_to_m**2) + CS%uhtr, CS%vhtr, G%HI, haloshift=0, unscale=GV%H_to_MKS*US%L_to_m**2) endif call cpu_clock_begin(id_clock_ml_restrat) - call mixedlayer_restrat(h, CS%uhtr, CS%vhtr, CS%tv, forces, dt, CS%visc%MLD, & - CS%VarMix, G, GV, US, CS%mixedlayer_restrat_CSp) + call mixedlayer_restrat(h, CS%uhtr, CS%vhtr, CS%tv, forces, dt, CS%visc%MLD, CS%visc%h_ML, & + CS%visc%sfc_buoy_flx, CS%VarMix, G, GV, US, CS%mixedlayer_restrat_CSp) call cpu_clock_end(id_clock_ml_restrat) - call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil)) + call pass_var(h, G%Domain, clock=id_clock_pass, halo=CS%dyn_h_stencil) if (CS%debug) then - call hchksum(h,"Post-mixedlayer_restrat h", G%HI, haloshift=1, scale=GV%H_to_m) + call hchksum(h,"Post-mixedlayer_restrat h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call uvchksum("Post-mixedlayer_restrat [uv]htr", & - CS%uhtr, CS%vhtr, G%HI, haloshift=0, scale=GV%H_to_m*US%L_to_m**2) + CS%uhtr, CS%vhtr, G%HI, haloshift=0, unscale=GV%H_to_MKS*US%L_to_m**2) endif endif @@ -1165,16 +1432,29 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & ! for vertical remapping may need to be regenerated. call diag_update_remap_grids(CS%diag) - if (CS%useMEKE) call step_forward_MEKE(CS%MEKE, h, CS%VarMix%SN_u, CS%VarMix%SN_v, & - CS%visc, dt, G, GV, US, CS%MEKE_CSp, CS%uhtr, CS%vhtr) + if (CS%useMEKE .and. CS%MEKE_in_dynamics) then + call step_forward_MEKE(CS%MEKE, h, CS%VarMix%SN_u, CS%VarMix%SN_v, & + CS%visc, dt, G, GV, US, CS%MEKE_CSp, CS%uhtr, CS%vhtr, & + CS%u, CS%v, CS%tv, Time_local) + endif call disable_averaging(CS%diag) ! Advance the dynamics time by dt. CS%t_dyn_rel_adv = CS%t_dyn_rel_adv + dt + + if (CS%use_particles .and. CS%do_dynamics .and. CS%use_uh_particles .and. & + CS%uh_particles_bug) then + ! Run particles using thickness-weighted velocity + call particles_run(CS%particles, Time_local, CS%uhtr, CS%vhtr, CS%h, & + CS%tv, CS%t_dyn_rel_adv, CS%use_uh_particles) + endif + CS%n_dyn_steps_in_adv = CS%n_dyn_steps_in_adv + 1 if (CS%alternate_first_direction) then call set_first_direction(G, MODULO(G%first_direction+1,2)) CS%first_dir_restart = real(G%first_direction) + elseif (CS%use_particles .and. CS%do_dynamics .and. (.not.CS%use_uh_particles)) then + call particles_to_k_space(CS%particles, h) endif CS%t_dyn_rel_thermo = CS%t_dyn_rel_thermo + dt if (abs(CS%t_dyn_rel_thermo) < 1e-6*dt) CS%t_dyn_rel_thermo = 0.0 @@ -1188,6 +1468,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & if (IDs%id_u > 0) call post_data(IDs%id_u, u, CS%diag) if (IDs%id_v > 0) call post_data(IDs%id_v, v, CS%diag) if (IDs%id_h > 0) call post_data(IDs%id_h, h, CS%diag) + if (CS%use_stochastic_EOS) call post_stoch_EOS_diags(CS%stoch_eos_CS, CS%tv, CS%diag) call disable_averaging(CS%diag) call cpu_clock_end(id_clock_diagnostics) ; call cpu_clock_end(id_clock_other) @@ -1213,15 +1494,15 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) if (CS%debug) then call cpu_clock_begin(id_clock_other) - call hchksum(h,"Pre-advection h", G%HI, haloshift=1, scale=GV%H_to_m) + call hchksum(h,"Pre-advection h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call uvchksum("Pre-advection uhtr", CS%uhtr, CS%vhtr, G%HI, & - haloshift=0, scale=GV%H_to_m*US%L_to_m**2) - if (associated(CS%tv%T)) call hchksum(CS%tv%T, "Pre-advection T", G%HI, haloshift=1) - if (associated(CS%tv%S)) call hchksum(CS%tv%S, "Pre-advection S", G%HI, haloshift=1) + haloshift=0, unscale=GV%H_to_MKS*US%L_to_m**2) + if (associated(CS%tv%T)) call hchksum(CS%tv%T, "Pre-advection T", G%HI, haloshift=1, unscale=US%C_to_degC) + if (associated(CS%tv%S)) call hchksum(CS%tv%S, "Pre-advection S", G%HI, haloshift=1, unscale=US%S_to_ppt) if (associated(CS%tv%frazil)) call hchksum(CS%tv%frazil, "Pre-advection frazil", G%HI, haloshift=0, & - scale=US%Q_to_J_kg*US%RZ_to_kg_m2) + unscale=US%Q_to_J_kg*US%RZ_to_kg_m2) if (associated(CS%tv%salt_deficit)) call hchksum(CS%tv%salt_deficit, & - "Pre-advection salt deficit", G%HI, haloshift=0, scale=US%RZ_to_kg_m2) + "Pre-advection salt deficit", G%HI, haloshift=0, unscale=US%S_to_ppt*US%RZ_to_kg_m2) ! call MOM_thermo_chksum("Pre-advection ", CS%tv, G, US) call cpu_clock_end(id_clock_other) endif @@ -1229,6 +1510,13 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) call cpu_clock_begin(id_clock_thermo) ; call cpu_clock_begin(id_clock_tracer) call enable_averages(CS%t_dyn_rel_adv, Time_local, CS%diag) + if (CS%use_particles .and. CS%use_uh_particles .and. (.not. CS%uh_particles_bug)) then + ! Run particles using thickness-weighted velocity + call particles_run(CS%particles, Time_local, CS%uhtr, CS%vhtr, CS%h, & + CS%tv, CS%t_dyn_rel_adv, CS%use_uh_particles) + endif + + if (CS%alternate_first_direction) then ! This calculation of the value of G%first_direction from the start of the accumulation of ! mass transports for use by the tracers is the equivalent to adding 2*n_dyn_steps before @@ -1237,13 +1525,19 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) else x_first = (MODULO(G%first_direction,2) == 0) endif + if (CS%debug) call MOM_tracer_chksum("Pre-advect ", CS%tracer_Reg, G) call advect_tracer(h, CS%uhtr, CS%vhtr, CS%OBC, CS%t_dyn_rel_adv, G, GV, US, & CS%tracer_adv_CSp, CS%tracer_Reg, x_first_in=x_first) - call tracer_hordiff(h, CS%t_dyn_rel_adv, CS%MEKE, CS%VarMix, G, GV, US, & + if (CS%debug) call MOM_tracer_chksum("Post-advect ", CS%tracer_Reg, G) + call tracer_hordiff(h, CS%t_dyn_rel_adv, CS%MEKE, CS%VarMix, CS%visc, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) + if (CS%debug) call MOM_tracer_chksum("Post-diffuse ", CS%tracer_Reg, G) if (showCallTree) call callTree_waypoint("finished tracer advection/diffusion (step_MOM)") - call update_segment_tracer_reservoirs(G, GV, CS%uhtr, CS%vhtr, h, CS%OBC, & - CS%t_dyn_rel_adv, CS%tracer_Reg) + if (associated(CS%OBC)) then + call pass_vector(CS%uhtr, CS%vhtr, G%Domain) + call update_segment_tracer_reservoirs(G, GV, CS%uhtr, CS%vhtr, h, CS%OBC, & + CS%tracer_Reg) + endif call cpu_clock_end(id_clock_tracer) ; call cpu_clock_end(id_clock_thermo) call cpu_clock_begin(id_clock_other) ; call cpu_clock_begin(id_clock_diagnostics) @@ -1265,8 +1559,16 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) CS%t_dyn_rel_adv = 0.0 call cpu_clock_end(id_clock_tracer) ; call cpu_clock_end(id_clock_thermo) + if (CS%useMEKE .and. (.not. CS%MEKE_in_dynamics)) then + call step_forward_MEKE(CS%MEKE, h, CS%VarMix%SN_u, CS%VarMix%SN_v, & + CS%visc, CS%t_dyn_rel_adv, G, GV, US, CS%MEKE_CSp, CS%uhtr, CS%vhtr, & + CS%u, CS%v, CS%tv, Time_local) + endif + if (associated(CS%tv%T)) then call extract_diabatic_member(CS%diabatic_CSp, diabatic_halo=halo_sz) + ! The bottom boundary layer calculation may need halo values of SpV_avg, including the corners. + if (allocated(CS%tv%SpV_avg)) halo_sz = max(halo_sz, 1) if (halo_sz > 0) then call create_group_pass(pass_T_S, CS%tv%T, G%Domain, To_All, halo=halo_sz) call create_group_pass(pass_T_S, CS%tv%S, G%Domain, To_All, halo=halo_sz) @@ -1277,6 +1579,12 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) call create_group_pass(pass_T_S, CS%tv%T, G%Domain, To_All+Omit_Corners, halo=1) call create_group_pass(pass_T_S, CS%tv%S, G%Domain, To_All+Omit_Corners, halo=1) call do_group_pass(pass_T_S, G%Domain, clock=id_clock_pass) + halo_sz = 1 + endif + + ! Update derived thermodynamic quantities. + if (allocated(CS%tv%SpV_avg)) then + call calc_derived_thermo(CS%tv, h, G, GV, US, halo=halo_sz, debug=CS%debug) endif endif @@ -1285,7 +1593,7 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) end subroutine step_MOM_tracer_dyn !> MOM_step_thermo orchestrates the thermodynamic time stepping and vertical -!! remapping, via calls to diabatic (or adiabatic) and ALE_main. +!! remapping, via calls to diabatic (or adiabatic). subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & Time_end_thermo, update_BBL, Waves) type(MOM_control_struct), intent(inout) :: CS !< Master MOM control structure @@ -1307,23 +1615,16 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & optional, pointer :: Waves !< Container for wave related parameters !! the fields in Waves are intent in here. - logical :: use_ice_shelf ! Needed for selecting the right ALE interface. + logical :: debug_redundant ! If true, check redundant values on PE boundaries when debugging. logical :: showCallTree - type(group_pass_type) :: pass_T_S, pass_T_S_h, pass_uv_T_S_h + type(group_pass_type) :: pass_T_S integer :: dynamics_stencil ! The computational stencil for the calculations ! in the dynamic core. integer :: halo_sz ! The size of a halo where data must be valid. - integer :: i, j, k, is, ie, js, je, nz - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)+1) :: eta_por ! layer interface heights - !! for porous topo. [Z ~> m or 1/eta_to_m] - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke showCallTree = callTree_showQuery() if (showCallTree) call callTree_enter("step_MOM_thermo(), MOM.F90") - - use_ice_shelf = .false. - if (associated(CS%frac_shelf_h)) use_ice_shelf = .true. + if (CS%debug) call query_debugging_checks(do_redundant=debug_redundant) call enable_averages(dtdia, Time_end_thermo, CS%diag) @@ -1331,7 +1632,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & if (CS%debug) then call MOM_thermo_chksum("Pre-oda ", tv, G, US, haloshift=0) endif - call apply_oda_tracer_increments(US%T_to_s*dtdia, Time_end_thermo, G, GV, tv, h, CS%odaCS) + call apply_oda_tracer_increments(dtdia, Time_end_thermo, G, GV, tv, h, CS%odaCS) if (CS%debug) then call MOM_thermo_chksum("Post-oda ", tv, G, US, haloshift=0) endif @@ -1354,7 +1655,11 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & ! and set_viscous_BBL is called as a part of the dynamic stepping. call cpu_clock_begin(id_clock_BBL_visc) !update porous barrier fractional cell metrics - call porous_widths(h, CS%tv, G, GV, US, eta_por, CS%pbv) + if (CS%use_porbar) then + call porous_widths_interface(h, CS%tv, G, GV, US, CS%pbv, CS%por_bar_CS) + call pass_vector(CS%pbv%por_layer_widthU, CS%pbv%por_layer_widthV, & + G%Domain, direction=To_ALL+SCALAR_PAIR, clock=id_clock_pass, halo=CS%cont_stencil) + endif call set_viscous_BBL(u, v, h, tv, CS%visc, G, GV, US, CS%set_visc_CSp, CS%pbv) call cpu_clock_end(id_clock_BBL_visc) if (showCallTree) call callTree_wayPoint("done with set_viscous_BBL (step_MOM_thermo)") @@ -1363,13 +1668,14 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call cpu_clock_begin(id_clock_thermo) if (.not.CS%adiabatic) then if (CS%debug) then - call uvchksum("Pre-diabatic [uv]", u, v, G%HI, haloshift=2, scale=US%L_T_to_m_s) - call hchksum(h,"Pre-diabatic h", G%HI, haloshift=1, scale=GV%H_to_m) + call uvchksum("Pre-diabatic [uv]", u, v, G%HI, haloshift=2, unscale=US%L_T_to_m_s) + call hchksum(h,"Pre-diabatic h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call uvchksum("Pre-diabatic [uv]h", CS%uhtr, CS%vhtr, G%HI, & - haloshift=0, scale=GV%H_to_m*US%L_to_m**2) + haloshift=0, unscale=GV%H_to_MKS*US%L_to_m**2) ! call MOM_state_chksum("Pre-diabatic ", u, v, h, CS%uhtr, CS%vhtr, G, GV, vel_scale=1.0) call MOM_thermo_chksum("Pre-diabatic ", tv, G, US, haloshift=0) - call check_redundant("Pre-diabatic ", u, v, G) + if (debug_redundant) & + call check_redundant("Pre-diabatic ", u, v, G, unscale=US%L_T_to_m_s) call MOM_forcing_chksum("Pre-diabatic", fluxes, G, US, haloshift=0) endif @@ -1379,82 +1685,28 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & Time_end_thermo, G, GV, US, CS%diabatic_CSp, CS%stoch_CS, CS%OBC, Waves) fluxes%fluxes_used = .true. - if (showCallTree) call callTree_waypoint("finished diabatic (step_MOM_thermo)") - - ! Regridding/remapping is done here, at end of thermodynamics time step - ! (that may comprise several dynamical time steps) - ! The routine 'ALE_main' can be found in 'MOM_ALE.F90'. - if ( CS%use_ALE_algorithm ) then - call enable_averages(dtdia, Time_end_thermo, CS%diag) -! call pass_vector(u, v, G%Domain) - call cpu_clock_begin(id_clock_pass) - if (associated(tv%T)) & - call create_group_pass(pass_T_S_h, tv%T, G%Domain, To_All+Omit_Corners, halo=1) - if (associated(tv%S)) & - call create_group_pass(pass_T_S_h, tv%S, G%Domain, To_All+Omit_Corners, halo=1) - call create_group_pass(pass_T_S_h, h, G%Domain, To_All+Omit_Corners, halo=1) - call do_group_pass(pass_T_S_h, G%Domain) - call cpu_clock_end(id_clock_pass) - - call preAle_tracer_diagnostics(CS%tracer_Reg, G, GV) - - if (CS%debug) then - call MOM_state_chksum("Pre-ALE ", u, v, h, CS%uh, CS%vh, G, GV, US) - call hchksum(tv%T,"Pre-ALE T", G%HI, haloshift=1) - call hchksum(tv%S,"Pre-ALE S", G%HI, haloshift=1) - call check_redundant("Pre-ALE ", u, v, G) - endif - call cpu_clock_begin(id_clock_ALE) - if (use_ice_shelf) then - call ALE_main(G, GV, US, h, u, v, tv, CS%tracer_Reg, CS%ALE_CSp, CS%OBC, & - dtdia, CS%frac_shelf_h) - else - call ALE_main(G, GV, US, h, u, v, tv, CS%tracer_Reg, CS%ALE_CSp, CS%OBC, dtdia) - endif - - if (showCallTree) call callTree_waypoint("finished ALE_main (step_MOM_thermo)") - call cpu_clock_end(id_clock_ALE) - endif ! endif for the block "if ( CS%use_ALE_algorithm )" - - dynamics_stencil = min(3, G%Domain%nihalo, G%Domain%njhalo) - call create_group_pass(pass_uv_T_S_h, u, v, G%Domain, halo=dynamics_stencil) - if (associated(tv%T)) & - call create_group_pass(pass_uv_T_S_h, tv%T, G%Domain, halo=dynamics_stencil) - if (associated(tv%S)) & - call create_group_pass(pass_uv_T_S_h, tv%S, G%Domain, halo=dynamics_stencil) - call create_group_pass(pass_uv_T_S_h, h, G%Domain, halo=dynamics_stencil) - call do_group_pass(pass_uv_T_S_h, G%Domain, clock=id_clock_pass) - - if (CS%debug .and. CS%use_ALE_algorithm) then - call MOM_state_chksum("Post-ALE ", u, v, h, CS%uh, CS%vh, G, GV, US) - call hchksum(tv%T, "Post-ALE T", G%HI, haloshift=1) - call hchksum(tv%S, "Post-ALE S", G%HI, haloshift=1) - call check_redundant("Post-ALE ", u, v, G) + if (CS%stoch_CS%do_skeb) then + call apply_skeb(CS%G,CS%GV,CS%stoch_CS,CS%u,CS%v,CS%h,CS%tv,dtdia,Time_end_thermo) endif - ! Whenever thickness changes let the diag manager know, target grids - ! for vertical remapping may need to be regenerated. This needs to - ! happen after the H update and before the next post_data. - call diag_update_remap_grids(CS%diag) - - !### Consider moving this up into the if ALE block. - call postALE_tracer_diagnostics(CS%tracer_Reg, G, GV, CS%diag, dtdia) + if (showCallTree) call callTree_waypoint("finished diabatic (step_MOM_thermo)") if (CS%debug) then - call uvchksum("Post-diabatic u", u, v, G%HI, haloshift=2, scale=US%L_T_to_m_s) - call hchksum(h, "Post-diabatic h", G%HI, haloshift=1, scale=GV%H_to_m) + call uvchksum("Post-diabatic u", u, v, G%HI, haloshift=2, unscale=US%L_T_to_m_s) + call hchksum(h, "Post-diabatic h", G%HI, haloshift=1, unscale=GV%H_to_MKS) call uvchksum("Post-diabatic [uv]h", CS%uhtr, CS%vhtr, G%HI, & - haloshift=0, scale=GV%H_to_m*US%L_to_m**2) + haloshift=0, unscale=GV%H_to_MKS*US%L_to_m**2) ! call MOM_state_chksum("Post-diabatic ", u, v, & ! h, CS%uhtr, CS%vhtr, G, GV, haloshift=1) - if (associated(tv%T)) call hchksum(tv%T, "Post-diabatic T", G%HI, haloshift=1) - if (associated(tv%S)) call hchksum(tv%S, "Post-diabatic S", G%HI, haloshift=1) + if (associated(tv%T)) call hchksum(tv%T, "Post-diabatic T", G%HI, haloshift=1, unscale=US%C_to_degC) + if (associated(tv%S)) call hchksum(tv%S, "Post-diabatic S", G%HI, haloshift=1, unscale=US%S_to_ppt) if (associated(tv%frazil)) call hchksum(tv%frazil, "Post-diabatic frazil", G%HI, haloshift=0, & - scale=US%Q_to_J_kg*US%RZ_to_kg_m2) + unscale=US%Q_to_J_kg*US%RZ_to_kg_m2) if (associated(tv%salt_deficit)) call hchksum(tv%salt_deficit, & - "Post-diabatic salt deficit", G%HI, haloshift=0, scale=US%RZ_to_kg_m2) + "Post-diabatic salt deficit", G%HI, haloshift=0, unscale=US%RZ_to_kg_m2) ! call MOM_thermo_chksum("Post-diabatic ", tv, G, US) - call check_redundant("Post-diabatic ", u, v, G) + if (debug_redundant) & + call check_redundant("Post-diabatic ", u, v, G, unscale=US%L_T_to_m_s) endif call disable_averaging(CS%diag) @@ -1467,12 +1719,18 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call cpu_clock_end(id_clock_adiabatic) if (associated(tv%T)) then - call create_group_pass(pass_T_S, tv%T, G%Domain, To_All+Omit_Corners, halo=1) - call create_group_pass(pass_T_S, tv%S, G%Domain, To_All+Omit_Corners, halo=1) + dynamics_stencil = min(3, G%Domain%nihalo, G%Domain%njhalo) + call create_group_pass(pass_T_S, tv%T, G%Domain, To_All+Omit_Corners, halo=dynamics_stencil) + call create_group_pass(pass_T_S, tv%S, G%Domain, To_All+Omit_Corners, halo=dynamics_stencil) call do_group_pass(pass_T_S, G%Domain, clock=id_clock_pass) if (CS%debug) then - if (associated(tv%T)) call hchksum(tv%T, "Post-diabatic T", G%HI, haloshift=1) - if (associated(tv%S)) call hchksum(tv%S, "Post-diabatic S", G%HI, haloshift=1) + if (associated(tv%T)) call hchksum(tv%T, "Post-diabatic T", G%HI, haloshift=1, unscale=US%C_to_degC) + if (associated(tv%S)) call hchksum(tv%S, "Post-diabatic S", G%HI, haloshift=1, unscale=US%S_to_ppt) + endif + + ! Update derived thermodynamic quantities. + if (allocated(tv%SpV_avg)) then + call calc_derived_thermo(tv, h, G, GV, US, halo=dynamics_stencil, debug=CS%debug) endif endif @@ -1481,10 +1739,244 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call disable_averaging(CS%diag) +! This works in general: +! if (associated(tv%T)) & +! call totalTandS(G%HI, h, G%areaT, tv%T, tv%S, "End of step_MOM", US, GV%H_to_mks) +! This works only if there is no rescaling being used: +! if (associated(tv%T)) & +! call totalTandS(G%HI, h, G%areaT, tv%T, tv%S, "End of step_MOM") + if (showCallTree) call callTree_leave("step_MOM_thermo(), MOM.F90") end subroutine step_MOM_thermo +!> ALE_regridding_and_remapping does regridding (the generation of a new grid) and remapping +!! (from the old grid to the new grid). This is done after the themrodynamic step. +subroutine ALE_regridding_and_remapping(CS, G, GV, US, u, v, h, tv, dtdia, Time_end_thermo) + type(MOM_control_struct), intent(inout) :: CS !< Master MOM control structure + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(inout) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: v !< meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic variables + real, intent(in) :: dtdia !< The time interval over which to advance [T ~> s] + type(time_type), intent(in) :: Time_end_thermo !< End of averaging interval for thermo diags + + real :: h_new(SZI_(G),SZJ_(G),SZK_(GV)) ! Layer thicknesses after regridding [H ~> m or kg m-2] + real :: dzRegrid(SZI_(G),SZJ_(G),SZK_(GV)+1) ! The change in grid interface positions due to regridding, + ! in the same units as thicknesses [H ~> m or kg m-2] + real :: h_old_u(SZIB_(G),SZJ_(G),SZK_(GV)) ! Source grid thickness at zonal + ! velocity points [H ~> m or kg m-2] + real :: h_old_v(SZI_(G),SZJB_(G),SZK_(GV)) ! Source grid thickness at meridional + ! velocity points [H ~> m or kg m-2] + real :: h_new_u(SZIB_(G),SZJ_(G),SZK_(GV)) ! Destination grid thickness at zonal + ! velocity points [H ~> m or kg m-2] + real :: h_new_v(SZI_(G),SZJB_(G),SZK_(GV)) ! Destination grid thickness at meridional + ! velocity points [H ~> m or kg m-2] + logical :: PCM_cell(SZI_(G),SZJ_(G),SZK_(GV)) ! If true, PCM remapping should be used in a cell. + logical :: use_ice_shelf ! Needed for selecting the right ALE interface. + logical :: debug_redundant ! If true, check redundant values on PE boundaries when debugging. + logical :: showCallTree + type(group_pass_type) :: pass_T_S_h + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + use_ice_shelf = .false. + if (associated(CS%frac_shelf_h)) use_ice_shelf = .true. + showCallTree = callTree_showQuery() + if (showCallTree) call callTree_enter("ALE_regridding_and_remapping(), MOM.F90") + if (CS%debug) call query_debugging_checks(do_redundant=debug_redundant) + + call cpu_clock_begin(id_clock_remap) + + ! Regridding/remapping is done here, at end of thermodynamics time step + ! (that may comprise several dynamical time steps) + ! The routine 'ALE_regrid' can be found in 'MOM_ALE.F90'. + call enable_averages(dtdia, Time_end_thermo, CS%diag) + + call cpu_clock_begin(id_clock_pass) + if (associated(tv%T)) & + call create_group_pass(pass_T_S_h, tv%T, G%Domain, To_All+Omit_Corners, halo=1) + if (associated(tv%S)) & + call create_group_pass(pass_T_S_h, tv%S, G%Domain, To_All+Omit_Corners, halo=1) + call create_group_pass(pass_T_S_h, h, G%Domain, To_All+Omit_Corners, halo=1) + call do_group_pass(pass_T_S_h, G%Domain) + call cpu_clock_end(id_clock_pass) + + call preAle_tracer_diagnostics(CS%tracer_Reg, G, GV) + + if (CS%use_particles) then + call particles_to_z_space(CS%particles, h) + endif + + if (CS%debug) then + call MOM_state_chksum("Pre-ALE ", u, v, h, CS%uh, CS%vh, G, GV, US, omit_corners=.true.) + call hchksum(tv%T,"Pre-ALE T", G%HI, haloshift=1, omit_corners=.true., unscale=US%C_to_degC) + call hchksum(tv%S,"Pre-ALE S", G%HI, haloshift=1, omit_corners=.true., unscale=US%S_to_ppt) + if (debug_redundant) & + call check_redundant("Pre-ALE ", u, v, G, unscale=US%L_T_to_m_s) + endif + call cpu_clock_begin(id_clock_ALE) + + call pre_ALE_diagnostics(G, GV, US, h, u, v, tv, CS%ALE_CSp) + call ALE_update_regrid_weights(dtdia, CS%ALE_CSp) + ! Do any necessary adjustments ot the state prior to remapping. + call pre_ALE_adjustments(G, GV, US, h, tv, CS%tracer_Reg, CS%ALE_CSp, u, v) + ! Adjust the target grids for diagnostics, in case there have been thickness adjustments. + call diag_update_remap_grids(CS%diag) + + if (use_ice_shelf) then + call ALE_regrid(G, GV, US, h, h_new, dzRegrid, tv, CS%ALE_CSp, CS%frac_shelf_h, PCM_cell) + else + call ALE_regrid(G, GV, US, h, h_new, dzRegrid, tv, CS%ALE_CSp, PCM_cell=PCM_cell) + endif + + if (showCallTree) call callTree_waypoint("new grid generated") + ! Remap all variables from the old grid h onto the new grid h_new + call ALE_remap_tracers(CS%ALE_CSp, G, GV, h, h_new, CS%tracer_Reg, showCallTree, dtdia, PCM_cell) + + ! Determine the old and new grid thicknesses at velocity points. + call ALE_remap_set_h_vel(CS%ALE_CSp, G, GV, h, h_old_u, h_old_v, CS%OBC, debug=showCallTree) + if (CS%remap_uv_using_old_alg) then + call ALE_remap_set_h_vel_via_dz(CS%ALE_CSp, G, GV, h_new, h_new_u, h_new_v, CS%OBC, h, dzRegrid, showCallTree) + else + call ALE_remap_set_h_vel(CS%ALE_CSp, G, GV, h_new, h_new_u, h_new_v, CS%OBC, debug=showCallTree) + endif + + ! Remap the velocity components. + call ALE_remap_velocities(CS%ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u, v, showCallTree, & + dtdia, allow_preserve_variance=.true.) + + if (allocated(tv%SpV_avg)) tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. + + if (CS%remap_aux_vars) then + if (CS%split .and. CS%use_alt_split) then + call remap_dyn_split_RK2b_aux_vars(G, GV, CS%dyn_split_RK2b_CSp, h_old_u, h_old_v, & + h_new_u, h_new_v, CS%ALE_CSp) + elseif (CS%split) then + call remap_dyn_split_RK2_aux_vars(G, GV, CS%dyn_split_RK2_CSp, h_old_u, h_old_v, h_new_u, h_new_v, CS%ALE_CSp) + endif + + if (associated(CS%OBC) .or. associated(CS%visc%Kv_shear_Bu)) then + call pass_var(h, G%Domain, complete=.false.) + call pass_var(h_new, G%Domain, complete=.true.) + endif + + if (associated(CS%OBC)) & + call remap_OBC_fields(G, GV, h, h_new, CS%OBC, PCM_cell=PCM_cell) + + call remap_vertvisc_aux_vars(G, GV, CS%visc, h, h_new, CS%ALE_CSp, CS%OBC) + if (associated(CS%visc%Kv_shear)) & + call pass_var(CS%visc%Kv_shear, G%Domain, To_All+Omit_Corners, clock=id_clock_pass, halo=1) + endif + + ! Replace the old grid with new one. All remapping must be done by this point in the code. + !$OMP parallel do default(shared) + do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + h(i,j,k) = h_new(i,j,k) + enddo ; enddo ; enddo + + if (showCallTree) call callTree_waypoint("finished ALE_regrid (ALE_regridding_and_remapping)") + call cpu_clock_end(id_clock_ALE) + + ! Update derived thermodynamic quantities. + if (allocated(CS%tv%SpV_avg)) then + call calc_derived_thermo(CS%tv, CS%h, G, GV, US, halo=1, debug=CS%debug) + endif + + ! Whenever thickness changes let the diag manager know, target grids + ! for vertical remapping may need to be regenerated. In non-Boussinesq mode, + ! calc_derived_thermo needs to be called before diag_update_remap_grids. + ! This needs to happen after the H update and before the next post_data. + call diag_update_remap_grids(CS%diag) + + call postALE_tracer_diagnostics(CS%tracer_Reg, G, GV, CS%diag, dtdia) + + if (CS%debug .and. CS%use_ALE_algorithm) then + call MOM_state_chksum("Post-ALE ", u, v, h, CS%uh, CS%vh, G, GV, US) + call hchksum(tv%T, "Post-ALE T", G%HI, haloshift=1, unscale=US%C_to_degC) + call hchksum(tv%S, "Post-ALE S", G%HI, haloshift=1, unscale=US%S_to_ppt) + if (debug_redundant) & + call check_redundant("Post-ALE ", u, v, G, unscale=US%L_T_to_m_s) + endif + if (CS%debug) then + call uvchksum("Post-ALE, Post-diabatic u", u, v, G%HI, haloshift=2, unscale=US%L_T_to_m_s) + call hchksum(h, "Post-ALE, Post-diabatic h", G%HI, haloshift=1, unscale=GV%H_to_MKS) + call uvchksum("Post-ALE, Post-diabatic [uv]h", CS%uhtr, CS%vhtr, G%HI, & + haloshift=0, unscale=GV%H_to_MKS*US%L_to_m**2) + ! call MOM_state_chksum("Post-diabatic ", u, v, & + ! h, CS%uhtr, CS%vhtr, G, GV, haloshift=1) + if (associated(tv%T)) call hchksum(tv%T, "Post-ALE, Post-diabatic T", G%HI, haloshift=1, unscale=US%C_to_degC) + if (associated(tv%S)) call hchksum(tv%S, "Post-ALE, Post-diabatic S", G%HI, haloshift=1, unscale=US%S_to_ppt) + if (associated(tv%frazil)) call hchksum(tv%frazil, "Post-ALE, Post-diabatic frazil", G%HI, haloshift=0, & + unscale=US%Q_to_J_kg*US%RZ_to_kg_m2) + if (associated(tv%salt_deficit)) call hchksum(tv%salt_deficit, & + "Post-ALE, Post-diabatic salt deficit", G%HI, haloshift=0, unscale=US%RZ_to_kg_m2) + ! call MOM_thermo_chksum("Post-diabatic ", tv, G, US) + if (debug_redundant) & + call check_redundant("Post-ALE, Post-diabatic ", u, v, G, unscale=US%L_T_to_m_s) + endif + call disable_averaging(CS%diag) + + call cpu_clock_end(id_clock_remap) + + if (showCallTree) call callTree_leave("ALE_regridding_and_remapping(), MOM.F90") + +end subroutine ALE_regridding_and_remapping + +!> post_diabatic_halo_updates does halo updates and calculates derived thermodynamic quantities +!! (e.g. specific volume). This must be done after the diabatic step regardless of is ALE +!! cooridinates are used or not. +subroutine post_diabatic_halo_updates(CS, G, GV, US, u, v, h, tv) + type(MOM_control_struct), intent(inout) :: CS !< Master MOM control structure + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(inout) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: v !< meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic variables + + logical :: debug_redundant ! If true, check redundant values on PE boundaries when debugging. + logical :: showCallTree + type(group_pass_type) :: pass_uv_T_S_h + integer :: dynamics_stencil ! The computational stencil for the calculations + ! in the dynamic core. + + showCallTree = callTree_showQuery() + if (showCallTree) call callTree_enter("post_diabatic_halo_updates, MOM.F90") + if (CS%debug) call query_debugging_checks(do_redundant=debug_redundant) + + if (CS%use_particles) then + call particles_to_k_space(CS%particles, h) + endif + + dynamics_stencil = min(3, G%Domain%nihalo, G%Domain%njhalo) + call create_group_pass(pass_uv_T_S_h, u, v, G%Domain, halo=dynamics_stencil) + if (associated(tv%T)) & + call create_group_pass(pass_uv_T_S_h, tv%T, G%Domain, halo=dynamics_stencil) + if (associated(tv%S)) & + call create_group_pass(pass_uv_T_S_h, tv%S, G%Domain, halo=dynamics_stencil) + call create_group_pass(pass_uv_T_S_h, h, G%Domain, halo=dynamics_stencil) + call do_group_pass(pass_uv_T_S_h, G%Domain, clock=id_clock_pass) + + if (associated(tv%frazil) .and. (.not.tv%frazil_was_reset) .and. CS%vertex_shear) & + call pass_var(tv%frazil, G%Domain, halo=1) + + ! Update derived thermodynamic quantities. + if (allocated(tv%SpV_avg)) then + call calc_derived_thermo(tv, h, G, GV, US, halo=dynamics_stencil, debug=CS%debug) + endif + if (showCallTree) call callTree_leave("post_diabatic_halo_updates, MOM.F90") +end subroutine post_diabatic_halo_updates !> step_offline is the main driver for running tracers offline in MOM6. This has been primarily !! developed with ALE configurations in mind. Some work has been done in isopycnal configuration, but @@ -1495,7 +1987,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS type(forcing), intent(inout) :: fluxes !< pointers to forcing fields type(surface), intent(inout) :: sfc_state !< surface ocean state type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type - real, intent(in) :: time_interval !< time interval + real, intent(in) :: time_interval !< time interval [T ~> s] type(MOM_control_struct), intent(inout) :: CS !< control structure from initialize_MOM ! Local pointers @@ -1511,15 +2003,18 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS logical :: do_vertical !< If enough time has elapsed, do the diabatic tracer sources/sinks logical :: adv_converged !< True if all the horizontal fluxes have been used + real, allocatable, dimension(:,:,:) :: h_new ! Layer thicknesses after regridding [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: dzRegrid ! The change in grid interface positions due to regridding, + ! in the same units as thicknesses [H ~> m or kg m-2] real :: dt_offline ! The offline timestep for advection [T ~> s] real :: dt_offline_vertical ! The offline timestep for vertical fluxes and remapping [T ~> s] logical :: skip_diffusion - integer :: id_eta_diff_end type(time_type), pointer :: accumulated_time => NULL() type(time_type), pointer :: vertical_time => NULL() - integer :: i,j,k - integer :: is, ie, js, je, isd, ied, jsd, jed + integer :: dynamics_stencil ! The computational stencil for the calculations + ! in the dynamic core. + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz ! 3D pointers real, dimension(:,:,:), pointer :: & @@ -1534,35 +2029,27 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS ! Grid-related pointer assignments G => CS%G ; GV => CS%GV ; US => CS%US - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + 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 cpu_clock_begin(id_clock_offline_tracer) call extract_offline_main(CS%offline_CSp, uhtr, vhtr, eatr, ebtr, h_end, accumulated_time, & vertical_time, dt_offline, dt_offline_vertical, skip_diffusion) - Time_end = increment_date(Time_start, seconds=floor(time_interval+0.001)) + Time_end = increment_date(Time_start, seconds=floor(US%T_to_s*time_interval+0.001)) - call enable_averaging(time_interval, Time_end, CS%diag) + call enable_averages(time_interval, Time_end, CS%diag) ! Check to see if this is the first iteration of the offline interval - if (accumulated_time == real_to_time(0.0)) then - first_iter = .true. - else ! This is probably unnecessary but is used to guard against unwanted behavior - first_iter = .false. - endif + first_iter = (accumulated_time == real_to_time(0.0)) ! Check to see if vertical tracer functions should be done - if (first_iter .or. (accumulated_time >= vertical_time)) then - do_vertical = .true. - vertical_time = accumulated_time + real_to_time(US%T_to_s*dt_offline_vertical) - else - do_vertical = .false. - endif + do_vertical = (first_iter .or. (accumulated_time >= vertical_time)) + if (do_vertical) vertical_time = accumulated_time + real_to_time(dt_offline_vertical, unscale=US%T_to_s) ! Increment the amount of time elapsed since last read and check if it's time to roll around - accumulated_time = accumulated_time + real_to_time(time_interval) + accumulated_time = accumulated_time + real_to_time(time_interval, unscale=US%T_to_s) - last_iter = (accumulated_time >= real_to_time(US%T_to_s*dt_offline)) + last_iter = (accumulated_time >= real_to_time(dt_offline, unscale=US%T_to_s)) if (CS%use_ALE_algorithm) then ! If this is the first iteration in the offline timestep, then we need to read in fields and @@ -1573,53 +2060,54 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS ! call update_transport_from_files(G, GV, CS%offline_CSp, h_end, eatr, ebtr, uhtr, vhtr, & ! CS%tv%T, CS%tv%S, fluxes, CS%use_ALE_algorithm) ! call update_transport_from_arrays(CS%offline_CSp) - call update_offline_fields(CS%offline_CSp, CS%h, fluxes, CS%use_ALE_algorithm) + call update_offline_fields(CS%offline_CSp, G, GV, US, CS%h, fluxes, CS%use_ALE_algorithm) ! Apply any fluxes into the ocean call offline_fw_fluxes_into_ocean(G, GV, CS%offline_CSp, fluxes, CS%h) if (.not.CS%diabatic_first) then - call offline_advection_ale(fluxes, Time_start, time_interval, CS%offline_CSp, id_clock_ALE, & - CS%h, uhtr, vhtr, converged=adv_converged) + call offline_advection_ale(fluxes, Time_start, time_interval, G, GV, US, CS%offline_CSp, & + id_clock_ALE, CS%h, uhtr, vhtr, converged=adv_converged) ! Redistribute any remaining transport - call offline_redistribute_residual(CS%offline_CSp, CS%h, uhtr, vhtr, adv_converged) + call offline_redistribute_residual(CS%offline_CSp, G, GV, US, CS%h, uhtr, vhtr, adv_converged) ! Perform offline diffusion if requested 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, CS%OBC, 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 - call tracer_hordiff(CS%h, dt_offline, CS%MEKE, CS%VarMix, G, GV, US, & - CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) + call tracer_hordiff(CS%h, dt_offline, CS%MEKE, CS%VarMix, CS%visc, G, GV, US, & + CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) endif endif endif ! The functions related to column physics of tracers is performed separately in ALE mode if (do_vertical) then - call offline_diabatic_ale(fluxes, Time_start, Time_end, CS%offline_CSp, CS%h, eatr, ebtr) + call offline_diabatic_ale(fluxes, Time_start, Time_end, G, GV, US, CS%offline_CSp, & + CS%h, CS%tv, eatr, ebtr) endif ! Last thing that needs to be done is the final ALE remapping if (last_iter) then if (CS%diabatic_first) then - call offline_advection_ale(fluxes, Time_start, time_interval, CS%offline_CSp, id_clock_ALE, & - CS%h, uhtr, vhtr, converged=adv_converged) + call offline_advection_ale(fluxes, Time_start, time_interval, G, GV, US, CS%offline_CSp, & + id_clock_ALE, CS%h, uhtr, vhtr, converged=adv_converged) ! Redistribute any remaining transport and perform the remaining advection - call offline_redistribute_residual(CS%offline_CSp, CS%h, uhtr, vhtr, adv_converged) + call offline_redistribute_residual(CS%offline_CSp, G, GV, US, CS%h, uhtr, vhtr, adv_converged) ! Perform offline diffusion if requested 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, CS%OBC, 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 - call tracer_hordiff(CS%h, dt_offline, CS%MEKE, CS%VarMix, G, GV, US, & + call tracer_hordiff(CS%h, dt_offline, CS%MEKE, CS%VarMix, CS%visc, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) endif endif @@ -1630,12 +2118,34 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call offline_fw_fluxes_out_ocean(G, GV, CS%offline_CSp, fluxes, CS%h) ! These diagnostic can be used to identify which grid points did not converge within ! the specified number of advection sub iterations - call post_offline_convergence_diags(CS%offline_CSp, CS%h, h_end, uhtr, vhtr) + call post_offline_convergence_diags(G, GV, CS%offline_CSp, CS%h, h_end, uhtr, vhtr) ! Call ALE one last time to make sure that tracers are remapped onto the layer thicknesses ! stored from the forward run call cpu_clock_begin(id_clock_ALE) - call ALE_offline_tracer_final( G, GV, CS%h, CS%tv, h_end, CS%tracer_Reg, CS%ALE_CSp, CS%OBC) + + ! Do any necessary adjustments ot the state prior to remapping. + call pre_ALE_adjustments(G, GV, US, h_end, CS%tv, CS%tracer_Reg, CS%ALE_CSp) + + allocate(h_new(isd:ied, jsd:jed, nz), source=0.0) + allocate(dzRegrid(isd:ied, jsd:jed, nz+1), source=0.0) + + ! Generate the new grid based on the tracer grid at the end of the interval. + call ALE_regrid(G, GV, US, h_end, h_new, dzRegrid, CS%tv, CS%ALE_CSp) + + ! Remap the tracers from the previous tracer grid onto the new grid. The thicknesses that + ! are used are intended to ensure that in the case where transports don't quite conserve, + ! the offline layer thicknesses do not drift too far away from the online model. + call ALE_remap_tracers(CS%ALE_CSp, G, GV, CS%h, h_new, CS%tracer_Reg, debug=CS%debug) + if (allocated(CS%tv%SpV_avg)) CS%tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. + + ! Update the tracer grid. + do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + CS%h(i,j,k) = h_new(i,j,k) + enddo ; enddo ; enddo + + deallocate(h_new, dzRegrid) + call cpu_clock_end(id_clock_ALE) call pass_var(CS%h, G%Domain) endif @@ -1645,16 +2155,16 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS ! Note that for the layer mode case, the calls to tracer sources and sinks is embedded in ! main_offline_advection_layer. Warning: this may not be appropriate for tracers that ! exchange with the atmosphere - if (abs(time_interval - US%T_to_s*dt_offline) > 1.0e-6) then + if (abs(time_interval - dt_offline) > 1.0e-6*US%s_to_T) then call MOM_error(FATAL, & "For offline tracer mode in a non-ALE configuration, dt_offline must equal time_interval") endif - call update_offline_fields(CS%offline_CSp, CS%h, fluxes, CS%use_ALE_algorithm) - call offline_advection_layer(fluxes, Time_start, time_interval, CS%offline_CSp, & - CS%h, eatr, ebtr, uhtr, vhtr) + call update_offline_fields(CS%offline_CSp, G, GV, US, CS%h, fluxes, CS%use_ALE_algorithm) + call offline_advection_layer(fluxes, Time_start, time_interval, G, GV, US, CS%offline_CSp, & + CS%h, eatr, ebtr, uhtr, vhtr) ! Perform offline diffusion if requested if (.not. skip_diffusion) then - call tracer_hordiff(h_end, dt_offline, CS%MEKE, CS%VarMix, G, GV, US, & + call tracer_hordiff(h_end, dt_offline, CS%MEKE, CS%VarMix, CS%visc, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) endif @@ -1677,6 +2187,12 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS fluxes%fluxes_used = .true. + ! Update derived thermodynamic quantities. + if (allocated(CS%tv%SpV_avg)) then + dynamics_stencil = min(3, G%Domain%nihalo, G%Domain%njhalo) + call calc_derived_thermo(CS%tv, CS%h, G, GV, US, halo=dynamics_stencil) + endif + if (last_iter) then accumulated_time = real_to_time(0.0) endif @@ -1687,17 +2203,15 @@ end subroutine step_offline !> Initialize MOM, including memory allocation, setting up parameters and diagnostics, !! initializing the ocean state variables, and initializing subsidiary modules -subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & +subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & Time_in, offline_tracer_mode, input_restart_file, diag_ptr, & - count_calls, tracer_flow_CSp, ice_shelf_CSp) + count_calls, tracer_flow_CSp, ice_shelf_CSp, waves_CSp, ensemble_num, & + calve_ice_shelf_bergs) type(time_type), target, intent(inout) :: Time !< model time, set in this routine type(time_type), intent(in) :: Time_init !< The start time for the coupled model's calendar type(param_file_type), intent(out) :: param_file !< structure indicating parameter file to parse type(directories), intent(out) :: dirs !< structure with directory paths type(MOM_control_struct), intent(inout), target :: CS !< pointer set in this routine to MOM control structure - type(MOM_restart_CS), pointer :: restart_CSp !< pointer set in this routine to the - !! restart control structure that will - !! be used for MOM. type(time_type), optional, intent(in) :: Time_in !< time passed to MOM_initialize_state when !! model is not being started from a restart file logical, optional, intent(out) :: offline_tracer_mode !< True is returned if tracers are being run offline @@ -1711,32 +2225,44 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & !! calls to step_MOM instead of the number of !! dynamics timesteps. type(ice_shelf_CS), optional, pointer :: ice_shelf_CSp !< A pointer to an ice shelf control structure + type(Wave_parameters_CS), & + optional, pointer :: Waves_CSp !< An optional pointer to a wave property CS + integer, optional :: ensemble_num !< Ensemble index provided by the cap (instead of FMS + !! ensemble manager) + logical, optional :: calve_ice_shelf_bergs !< If true, will add point iceberg calving variables to the ice + !! shelf restart ! local variables type(ocean_grid_type), pointer :: G => NULL() ! A pointer to the metric grid use for the run type(ocean_grid_type), pointer :: G_in => NULL() ! Pointer to the input grid type(hor_index_type), pointer :: HI => NULL() ! A hor_index_type for array extents type(hor_index_type), target :: HI_in ! HI on the input grid + type(hor_index_type) :: HI_in_unmasked ! HI on the unmasked input grid type(verticalGrid_type), pointer :: GV => NULL() type(dyn_horgrid_type), pointer :: dG => NULL(), test_dG => NULL() type(dyn_horgrid_type), pointer :: dG_in => NULL() + type(dyn_horgrid_type), pointer :: dG_unmasked_in => NULL() type(diag_ctrl), pointer :: diag => NULL() type(unit_scale_type), pointer :: US => NULL() + type(MOM_restart_CS), pointer :: restart_CSp => NULL() character(len=4), parameter :: vers_num = 'v2.0' integer :: turns ! Number of grid quarter-turns + logical :: point_calving ! Initial state on the input index map real, allocatable :: u_in(:,:,:) ! Initial zonal velocities [L T-1 ~> m s-1] real, allocatable :: v_in(:,:,:) ! Initial meridional velocities [L T-1 ~> m s-1] real, allocatable :: h_in(:,:,:) ! Initial layer thicknesses [H ~> m or kg m-2] real, allocatable, target :: frac_shelf_in(:,:) ! Initial fraction of the total cell area occupied - ! by an ice shelf [nondim] - real, allocatable, target :: T_in(:,:,:) ! Initial temperatures [degC] - real, allocatable, target :: S_in(:,:,:) ! Initial salinities [ppt] + ! by an ice shelf [nondim] + real, allocatable, target :: mass_shelf_in(:,:) ! Initial mass of ice shelf contained within a grid cell + ! [R Z ~> kg m-2] + real, allocatable, target :: T_in(:,:,:) ! Initial temperatures [C ~> degC] + real, allocatable, target :: S_in(:,:,:) ! Initial salinities [S ~> ppt] + type(ocean_OBC_type), pointer :: OBC_in => NULL() type(sponge_CS), pointer :: sponge_in_CSp => NULL() type(ALE_sponge_CS), pointer :: ALE_sponge_in_CSp => NULL() type(oda_incupd_CS),pointer :: oda_incupd_in_CSp => NULL() - ! This include declares and sets the variable "version". # include "version_variable.h" @@ -1746,30 +2272,42 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! of the maximum stable value [nondim]. real, allocatable, dimension(:,:) :: eta ! free surface height or column mass [H ~> m or kg m-2] - real, allocatable, dimension(:,:) :: area_shelf_in ! area occupied by ice shelf [L2 ~> m2] -! real, dimension(:,:), pointer :: shelf_area => NULL() - type(MOM_restart_CS), pointer :: restart_CSp_tmp => NULL() + real, allocatable, dimension(:,:,:) :: h_new ! Layer thicknesses after regridding [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: dzRegrid ! The change in grid interface positions due to regridding, + ! in the same units as thicknesses [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: h_old_u ! Source grid thickness at zonal velocity points [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: h_old_v ! Source grid thickness at meridional velocity + ! points [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: h_new_u ! Destination grid thickness at zonal + ! velocity points [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: h_new_v ! Destination grid thickness at meridional + ! velocity points [H ~> m or kg m-2] + logical, allocatable, dimension(:,:,:) :: PCM_cell ! If true, PCM remapping should be used in a cell. type(group_pass_type) :: tmp_pass_uv_T_S_h, pass_uv_T_S_h - real :: default_val ! default value for a parameter + real :: Hmix_z, Hmix_UV_z ! Temporary variables with averaging depths [Z ~> m] + real :: HFrz_z ! Temporary variable with the melt potential depth [Z ~> m] + real :: default_val ! The default value for DTBT_RESET_PERIOD [s] logical :: write_geom_files ! If true, write out the grid geometry files. - logical :: ensemble_ocean ! If true, perform an ensemble gather at the end of step_MOM logical :: new_sim ! If true, this has been determined to be a new simulation logical :: use_geothermal ! If true, apply geothermal heating. logical :: use_EOS ! If true, density calculated from T & S using an equation of state. logical :: symmetric ! If true, use symmetric memory allocation. logical :: save_IC ! If true, save the initial conditions. logical :: do_unit_tests ! If true, call unit tests. + logical :: fpmix ! Needed to decide if BLD should be passed to RK2. logical :: test_grid_copy = .false. logical :: bulkmixedlayer ! If true, a refined bulk mixed layer scheme is used ! with nkml sublayers and nkbl buffer layer. logical :: use_temperature ! If true, temperature and salinity used as state variables. + logical :: use_p_surf_in_EOS ! If true, always include the surface pressure contributions + ! in equation of state calculations. logical :: use_frazil ! If true, liquid seawater freezes if temp below freezing, ! with accumulated heat deficit returned to surface ocean. logical :: bound_salinity ! If true, salt is added to keep salinity above ! a minimum value, and the deficit is reported. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. logical :: use_conT_absS ! If true, the prognostics T & S are conservative temperature ! and absolute salinity. Care should be taken to convert them ! to potential temperature and practical salinity before @@ -1787,30 +2325,44 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & integer :: first_direction ! An integer that indicates which direction is to be ! updated first in directionally split parts of the ! calculation. - integer :: nkml, nkbl, verbosity, write_geom + logical :: enable_bugs ! If true, the defaults for certain recently added bug-fix flags are + ! set to recreate the bugs so that the code can be moved forward + ! without changing answers for existing configurations. When this is + ! false, bugs are only used if they are actively selected. + logical :: non_Bous ! If true, this run is fully non-Boussinesq + logical :: Boussinesq ! If true, this run is fully Boussinesq + logical :: semi_Boussinesq ! If true, this run is partially non-Boussinesq + logical :: use_KPP ! If true, diabatic is using KPP vertical mixing + logical :: MLE_use_PBL_MLD ! If true, use stored boundary layer depths for submesoscale restratification. + logical :: OBC_reservoir_init_bug + integer :: nkml, nkbl, verbosity, write_geom, number_of_OBC_segments integer :: dynamics_stencil ! The computational stencil for the calculations ! in the dynamic core. + real :: salin_underflow ! A tiny value of salinity below which the it is set to 0 [S ~> ppt] + real :: temp_underflow ! A tiny magnitude of temperatures below which they are set to 0 [C ~> degC] real :: conv2watt ! A conversion factor from temperature fluxes to heat - ! fluxes [J m-2 H-1 degC-1 ~> J m-3 degC-1 or J kg-1 degC-1] + ! fluxes [J m-2 H-1 C-1 ~> J m-3 degC-1 or J kg-1 degC-1] real :: conv2salt ! A conversion factor for salt fluxes [m H-1 ~> 1] or [kg m-2 H-1 ~> 1] - real :: RL2_T2_rescale, Z_rescale, QRZ_rescale ! Unit conversion factors - character(len=48) :: flux_units, S_flux_units + character(len=48) :: S_flux_units type(vardesc) :: vd_T, vd_S ! Structures describing temperature and salinity variables. type(time_type) :: Start_time type(ocean_internal_state) :: MOM_internal_state - character(len=200) :: area_varname, ice_shelf_file, inputdir, filename + type(MOM_domain_type), pointer :: MOM_dom_unmasked => null() ! Unmasked MOM domain instance + ! (To be used for writing out ocean geometry) + character(len=240) :: geom_file ! Name of the ocean geometry file CS%Time => Time + id_clock_ocean = cpu_clock_id('Ocean', grain=CLOCK_COMPONENT) id_clock_init = cpu_clock_id('Ocean Initialization', grain=CLOCK_SUBCOMPONENT) - call cpu_clock_begin(id_clock_init) + call cpu_clock_begin(id_clock_ocean) ; call cpu_clock_begin(id_clock_init) Start_time = Time ; if (present(Time_in)) Start_time = Time_in ! Read paths and filenames from namelist and store in "dirs". ! Also open the parsed input parameter file(s) and setup param_file. - call get_MOM_input(param_file, dirs, default_input_filename=input_restart_file) + call get_MOM_input(param_file, dirs, default_input_filename=input_restart_file, ensemble_num=ensemble_num) verbosity = 2 ; call read_param(param_file, "VERBOSITY", verbosity) call MOM_set_verbosity(verbosity) @@ -1841,6 +2393,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call get_param(param_file, "MOM", "SPLIT", CS%split, & "Use the split time stepping if true.", default=.true.) + call get_param(param_file, "MOM", "SPLIT_RK2B", CS%use_alt_split, & + "If true, use a version of the split explicit time stepping scheme that "//& + "exchanges velocities with step_MOM that have the average barotropic phase over "//& + "a baroclinic timestep rather than the instantaneous barotropic phase.", & + default=.false., do_not_log=.not.CS%split) if (CS%split) then CS%use_RK2 = .false. else @@ -1849,10 +2406,28 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & default=.false.) endif + ! FPMIX is needed to decide if boundary layer depth should be passed to RK2 + call get_param(param_file, '', "FPMIX", fpmix, & + "If true, add non-local momentum flux increments and diffuse down the Eulerian gradient.", & + default=.false., do_not_log=.true.) + + if (fpmix .and. .not. CS%split) then + call MOM_error(FATAL, "initialize_MOM: "//& + "FPMIX=True only works when SPLIT=True.") + endif + + call get_param(param_file, "MOM", "BOUSSINESQ", Boussinesq, & + "If true, make the Boussinesq approximation.", default=.true., do_not_log=.true.) + call get_param(param_file, "MOM", "SEMI_BOUSSINESQ", semi_Boussinesq, & + "If true, do non-Boussinesq pressure force calculations and use mass-based "//& + "thicknesses, but use RHO_0 to convert layer thicknesses into certain "//& + "height changes. This only applies if BOUSSINESQ is false.", & + default=.true., do_not_log=.true.) + non_Bous = .not.(Boussinesq .or. semi_Boussinesq) call get_param(param_file, "MOM", "CALC_RHO_FOR_SEA_LEVEL", CS%calc_rho_for_sea_lev, & "If true, the in-situ density is used to calculate the "//& "effective sea level that is returned to the coupler. If false, "//& - "the Boussinesq parameter RHO_0 is used.", default=.false.) + "the Boussinesq parameter RHO_0 is used.", default=non_Bous) call get_param(param_file, "MOM", "ENABLE_THERMODYNAMICS", use_temperature, & "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) @@ -1873,10 +2448,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & default=.false.) CS%tv%T_is_conT = use_conT_absS ; CS%tv%S_is_absS = use_conT_absS call get_param(param_file, "MOM", "ADIABATIC", CS%adiabatic, & - "There are no diapycnal mass fluxes if ADIABATIC is "//& - "true. This assumes that KD = KDML = 0.0 and that "//& - "there is no buoyancy forcing, but makes the model "//& - "faster by eliminating subroutine calls.", default=.false.) + "There are no diapycnal mass fluxes if ADIABATIC is true. "//& + "This assumes that KD = 0.0 and that there is no buoyancy forcing, "//& + "but makes the model faster by eliminating subroutine calls.", default=.false.) call get_param(param_file, "MOM", "DO_DYNAMICS", CS%do_dynamics, & "If False, skips the dynamics calls that update u & v, as well as "//& "the gravity wave adjustment to h. This may be a fragile feature, "//& @@ -1886,7 +2460,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "If False, T/S are registered for advection. "//& "This is intended only to be used in offline tracer mode "//& "and is by default false in that case.", & - do_not_log = .true., default=.true. ) + do_not_log=.true., default=.true.) if (present(offline_tracer_mode)) then ! Only read this parameter in enabled modes call get_param(param_file, "MOM", "OFFLINE_TRACER_MODE", CS%offline_tracer_mode, & "If true, barotropic and baroclinic dynamics, thermodynamics "//& @@ -1898,7 +2472,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call get_param(param_file, "MOM", "ADVECT_TS", advect_TS, & "If True, advect temperature and salinity horizontally "//& "If False, T/S are registered for advection. "//& - "This is intended only to be used in offline tracer mode."//& + "This is intended only to be used in offline tracer mode, "//& "and is by default false in that case", & default=.false. ) endif @@ -1906,6 +2480,17 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call get_param(param_file, "MOM", "USE_REGRIDDING", CS%use_ALE_algorithm, & "If True, use the ALE algorithm (regridding/remapping). "//& "If False, use the layered isopycnal algorithm.", default=.false. ) + call get_param(param_file, "MOM", "REMAP_UV_USING_OLD_ALG", CS%remap_uv_using_old_alg, & + "If true, uses the old remapping-via-a-delta-z method for "//& + "remapping u and v. If false, uses the new method that remaps "//& + "between grids described by an old and new thickness.", & + default=.false., do_not_log=.not.CS%use_ALE_algorithm) + call get_param(param_file, "MOM", "REMAP_AUXILIARY_VARS", CS%remap_aux_vars, & + "If true, apply ALE remapping to all of the auxiliary 3-dimensional "//& + "variables that are needed to reproduce across restarts, similarly to "//& + "what is already being done with the primary state variables. "//& + "The default should be changed to true.", default=.false., & + do_not_log=.not.CS%use_ALE_algorithm) call get_param(param_file, "MOM", "BULKMIXEDLAYER", bulkmixedlayer, & "If true, use a Kraus-Turner-like bulk mixed layer "//& "with transitional buffer layers. Layers 1 through "//& @@ -1914,15 +2499,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "BULKMIXEDLAYER can not be used with USE_REGRIDDING. "//& "The default is influenced by ENABLE_THERMODYNAMICS.", & default=use_temperature .and. .not.CS%use_ALE_algorithm) - call get_param(param_file, "MOM", "THICKNESSDIFFUSE", CS%thickness_diffuse, & - "If true, interface heights are diffused with a "//& - "coefficient of KHTH.", default=.false.) - call get_param(param_file, "MOM", "THICKNESSDIFFUSE_FIRST", & - CS%thickness_diffuse_first, & - "If true, do thickness diffusion before dynamics. "//& - "This is only used if THICKNESSDIFFUSE is true.", & + 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=.false.) - if (.not.CS%thickness_diffuse) CS%thickness_diffuse_first = .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 "//& @@ -1937,6 +2517,20 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call get_param(param_file, "MOM", "DEBUG_TRUNCATIONS", debug_truncations, & "If true, calculate all diagnostics that are useful for "//& "debugging truncations.", default=.false., debuggingParam=.true.) + call get_param(param_file, "MOM", "OBC_NUMBER_OF_SEGMENTS", number_of_OBC_segments, & + default=0, do_not_log=.true.) + call get_param(param_file, "MOM", "DEBUG_OBCS", CS%debug_OBCs, & + "If true, write out verbose debugging data about OBCs.", & + default=.false., debuggingParam=.true., do_not_log=(number_of_OBC_segments<=0)) + call get_param(param_file, "MOM", "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + "If true, the defaults for certain recently added bug-fix flags are set to "//& + "recreate the bugs so that the code can be moved forward without changing "//& + "answers for existing configurations. The defaults for groups of bug-fix "//& + "flags are periodically changed to correct the bugs, at which point this "//& + "parameter will no longer be used to set their default. Setting this to false "//& + "means that bugs are only used if they are actively selected, but it also "//& + "means that answers may change when code is updated due to newly found bugs.", & + default=.true.) call get_param(param_file, "MOM", "DT", CS%dt, & "The (baroclinic) dynamics time step. The time-step that "//& @@ -1945,46 +2539,83 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "coupling timestep in coupled mode.)", units="s", scale=US%s_to_T, & fail_if_missing=.true.) call get_param(param_file, "MOM", "DT_THERM", CS%dt_therm, & - "The thermodynamic and tracer advection time step. "//& - "Ideally DT_THERM should be an integer multiple of DT "//& - "and less than the forcing or coupling time-step, unless "//& - "THERMO_SPANS_COUPLING is true, in which case DT_THERM "//& - "can be an integer multiple of the coupling timestep. By "//& - "default DT_THERM is set to DT.", & + "The thermodynamic time step. Ideally DT_THERM should be an "//& + "integer multiple of DT and of DT_TRACER_ADVECT "//& + "and less than the forcing or coupling time-step. However, if "//& + "THERMO_SPANS_COUPLING is true, DT_THERM can be an integer multiple "//& + "of the coupling timestep. By default DT_THERM is set to DT.", & units="s", scale=US%s_to_T, default=US%T_to_s*CS%dt) call get_param(param_file, "MOM", "THERMO_SPANS_COUPLING", CS%thermo_spans_coupling, & - "If true, the MOM will take thermodynamic and tracer "//& + "If true, the MOM will take thermodynamic "//& "timesteps that can be longer than the coupling timestep. "//& "The actual thermodynamic timestep that is used in this "//& "case is the largest integer multiple of the coupling "//& "timestep that is less than or equal to DT_THERM.", default=.false.) + call get_param(param_file, "MOM", "DT_TRACER_ADVECT", CS%dt_tr_adv, & + "The tracer advection time step. Ideally DT_TRACER_ADVECT should be an "//& + "integer multiple of DT, less than DT_THERM, and less than the forcing "//& + "or coupling time-step. However, if TRADV_SPANS_COUPLING is true, "//& + "DT_TRACER_ADVECT can be longer than the coupling timestep. By "//& + "default DT_TRACER_ADVECT is set to DT_THERM.", & + units="s", scale=US%s_to_T, default=US%T_to_s*CS%dt_therm) + call get_param(param_file, "MOM", "TRADV_SPANS_COUPLING", CS%tradv_spans_coupling, & + "If true, the MOM will take tracer advection "//& + "timesteps that can be longer than the coupling timestep. "//& + "The actual tracer advection timestep that is used in this "//& + "case is the largest integer multiple of the coupling "//& + "timestep that is less than or equal to DT_TRACER_ADVECT.", & + default=CS%thermo_spans_coupling) + if ( CS%diabatic_first .and. (CS%dt_tr_adv /= CS%dt_therm) ) then + call MOM_error(FATAL,"MOM: If using DIABATIC_FIRST, DT_TRACER_ADVECT must equal DT_THERM.") + endif + call get_param(param_file, "MOM", "THICKNESSDIFFUSE", CS%thickness_diffuse, & + "If true, isopycnal surfaces are diffused with a Laplacian "//& + "coefficient of KHTH.", default=.false.) + call get_param(param_file, "MOM", "APPLY_INTERFACE_FILTER", CS%interface_filter, & + "If true, model interface heights are subjected to a grid-scale "//& + "dependent spatial smoothing, often with biharmonic filter.", default=.false.) + call get_param(param_file, "MOM", "THICKNESSDIFFUSE_FIRST", CS%thickness_diffuse_first, & + "If true, do thickness diffusion or interface height smoothing before dynamics. "//& + "This is only used if THICKNESSDIFFUSE or APPLY_INTERFACE_FILTER is true.", & + default=.false., do_not_log=.not.(CS%thickness_diffuse.or.CS%interface_filter)) + CS%interface_filter_dt_bug = .false. + if ((.not.CS%thickness_diffuse_first .and. CS%interface_filter) .or. & + (CS%thickness_diffuse_first .and. (CS%thickness_diffuse .or. CS%interface_filter) & + .and. (CS%dt_tr_adv /= CS%dt_therm))) then + call get_param(param_file, "MOM", "INTERFACE_FILTER_DT_BUG", CS%interface_filter_dt_bug, & + "If true, uses the wrong time interval in calls to interface_filter "//& + "and thickness_diffuse. Has no effect when THICKNESSDIFFUSE_FIRST is "//& + "true and DT_TRACER_ADVECT = DT_THERMO or when THICKNESSDIFFUSE_FIRST "//& + "is false and APPLY_INTERFACE_FILTER is false. ", default=.false.) + endif if (bulkmixedlayer) then CS%Hmix = -1.0 ; CS%Hmix_UV = -1.0 else - call get_param(param_file, "MOM", "HMIX_SFC_PROP", CS%Hmix, & + call get_param(param_file, "MOM", "HMIX_SFC_PROP", Hmix_z, & "If BULKMIXEDLAYER is false, HMIX_SFC_PROP is the depth "//& "over which to average to find surface properties like "//& "SST and SSS or density (but not surface velocities).", & units="m", default=1.0, scale=US%m_to_Z) - call get_param(param_file, "MOM", "HMIX_UV_SFC_PROP", CS%Hmix_UV, & + call get_param(param_file, "MOM", "HMIX_UV_SFC_PROP", Hmix_UV_z, & "If BULKMIXEDLAYER is false, HMIX_UV_SFC_PROP is the depth "//& "over which to average to find surface flow properties, "//& "SSU, SSV. A non-positive value indicates no averaging.", & units="m", default=0.0, scale=US%m_to_Z) endif - call get_param(param_file, "MOM", "HFREEZE", CS%HFrz, & + call get_param(param_file, "MOM", "HFREEZE", HFrz_z, & "If HFREEZE > 0, melt potential will be computed. The actual depth "//& "over which melt potential is computed will be min(HFREEZE, OBLD), "//& "where OBLD is the boundary layer depth. If HFREEZE <= 0 (default), "//& - "melt potential will not be computed.", units="m", default=-1.0, scale=US%m_to_Z) + "melt potential will not be computed.", & + units="m", default=-1.0, scale=US%m_to_Z) call get_param(param_file, "MOM", "INTERPOLATE_P_SURF", CS%interp_p_surf, & "If true, linearly interpolate the surface pressure "//& "over the coupling time step, using the specified value "//& "at the end of the step.", default=.false.) if (CS%split) then - call get_param(param_file, "MOM", "DTBT", dtbt, default=-0.98) + call get_param(param_file, "MOM", "DTBT", dtbt, units="s or nondim", default=-0.98) default_val = US%T_to_s*CS%dt_therm ; if (dtbt > 0.0) default_val = -1.0 CS%dtbt_reset_period = -1.0 call get_param(param_file, "MOM", "DTBT_RESET_PERIOD", CS%dtbt_reset_period, & @@ -1993,12 +2624,18 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "only on information available at initialization. If 0, "//& "DTBT will be set every dynamics time step. The default "//& "is set by DT_THERM. This is only used if SPLIT is true.", & - units="s", default=default_val, do_not_read=(dtbt > 0.0)) + units="s", default=default_val, scale=US%s_to_T, do_not_read=(dtbt > 0.0)) endif + call get_param(param_file, "MOM", "DT_OBC_SEG_UPDATE_OBGC", CS%dt_obc_seg_period, & + "The time between OBC segment data updates for OBGC tracers. "//& + "This must be an integer multiple of DT and DT_THERM. "//& + "The default is set to DT.", & + units="s", default=US%T_to_s*CS%dt, scale=US%s_to_T, do_not_log=.not.associated(OBC_in)) + ! This is here in case these values are used inappropriately. - use_frazil = .false. ; bound_salinity = .false. - CS%tv%P_Ref = 2.0e7*US%kg_m3_to_R*US%m_s_to_L_T**2 + use_frazil = .false. ; bound_salinity = .false. ; use_p_surf_in_EOS = .false. + CS%tv%P_Ref = 2.0e7*US%Pa_to_RL2_T2 if (use_temperature) then call get_param(param_file, "MOM", "FRAZIL", use_frazil, & "If true, water freezes if it gets too cold, and the "//& @@ -2013,14 +2650,20 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "drive the salinity negative otherwise.)", default=.false.) call get_param(param_file, "MOM", "MIN_SALINITY", CS%tv%min_salinity, & "The minimum value of salinity when BOUND_SALINITY=True.", & - units="PPT", default=0.0, do_not_log=.not.bound_salinity) + units="PPT", default=0.0, scale=US%ppt_to_S, do_not_log=.not.bound_salinity) + call get_param(param_file, "MOM", "SALINITY_UNDERFLOW", salin_underflow, & + "A tiny value of salinity below which the it is set to 0. For reference, "//& + "one molecule of salt per square meter of ocean is of order 1e-29 ppt.", & + units="PPT", default=0.0, scale=US%ppt_to_S) + call get_param(param_file, "MOM", "TEMPERATURE_UNDERFLOW", temp_underflow, & + "A tiny magnitude of temperatures below which they are set to 0.", & + units="degC", default=0.0, scale=US%degC_to_C) call get_param(param_file, "MOM", "C_P", CS%tv%C_p, & - "The heat capacity of sea water, approximated as a "//& - "constant. This is only used if ENABLE_THERMODYNAMICS is "//& - "true. The default value is from the TEOS-10 definition "//& - "of conservative temperature.", units="J kg-1 K-1", & - default=3991.86795711963, scale=US%J_kg_to_Q) - call get_param(param_file, "MOM", "USE_PSURF_IN_EOS", CS%use_p_surf_in_EOS, & + "The heat capacity of sea water, approximated as a constant. "//& + "This is only used if ENABLE_THERMODYNAMICS is true. The default "//& + "value is from the TEOS-10 definition of conservative temperature.", & + units="J kg-1 K-1", default=3991.86795711963, scale=US%J_kg_to_Q*US%C_to_degC) + call get_param(param_file, "MOM", "USE_PSURF_IN_EOS", use_p_surf_in_EOS, & "If true, always include the surface pressure contributions "//& "in equation of state calculations.", default=.true.) endif @@ -2028,16 +2671,15 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "The pressure that is used for calculating the coordinate "//& "density. (1 Pa = 1e4 dbar, so 2e7 is commonly used.) "//& "This is only used if USE_EOS and ENABLE_THERMODYNAMICS are true.", & - units="Pa", default=2.0e7, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) + units="Pa", default=2.0e7, scale=US%Pa_to_RL2_T2) if (bulkmixedlayer) then call get_param(param_file, "MOM", "NKML", nkml, & "The number of sublayers within the mixed layer if "//& "BULKMIXEDLAYER is true.", units="nondim", default=2) call get_param(param_file, "MOM", "NKBL", nkbl, & - "The number of layers that are used as variable density "//& - "buffer layers if BULKMIXEDLAYER is true.", units="nondim", & - default=2) + "The number of layers that are used as variable density buffer "//& + "layers if BULKMIXEDLAYER is true.", units="nondim", default=2) endif call get_param(param_file, "MOM", "GLOBAL_INDEXING", global_indexing, & @@ -2069,32 +2711,30 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & units="m", default=20.0, scale=US%m_to_Z) call get_param(param_file, "MOM", "BAD_VAL_SSS_MAX", CS%bad_val_sss_max, & "The value of SSS above which a bad value message is "//& - "triggered, if CHECK_BAD_SURFACE_VALS is true.", units="PPT", & - default=45.0) + "triggered, if CHECK_BAD_SURFACE_VALS is true.", & + units="PPT", default=45.0, scale=US%ppt_to_S) call get_param(param_file, "MOM", "BAD_VAL_SST_MAX", CS%bad_val_sst_max, & "The value of SST above which a bad value message is "//& "triggered, if CHECK_BAD_SURFACE_VALS is true.", & - units="deg C", default=45.0) + units="deg C", default=45.0, scale=US%degC_to_C) call get_param(param_file, "MOM", "BAD_VAL_SST_MIN", CS%bad_val_sst_min, & "The value of SST below which a bad value message is "//& "triggered, if CHECK_BAD_SURFACE_VALS is true.", & - units="deg C", default=-2.1) + units="deg C", default=-2.1, scale=US%degC_to_C) call get_param(param_file, "MOM", "BAD_VAL_COLUMN_THICKNESS", CS%bad_val_col_thick, & "The value of column thickness below which a bad value message is "//& "triggered, if CHECK_BAD_SURFACE_VALS is true.", & units="m", default=0.0, scale=US%m_to_Z) endif - call get_param(param_file, "MOM", "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) - call get_param(param_file, "MOM", "SURFACE_2018_ANSWERS", CS%answers_2018, & - "If true, use expressions for the surface properties that recover the answers "//& - "from the end of 2018. Otherwise, use more appropriate expressions that differ "//& - "at roundoff for non-Boussinesq cases.", default=default_2018_answers) - call get_param(param_file, "MOM", "USE_DIABATIC_TIME_BUG", CS%use_diabatic_time_bug, & - "If true, uses the wrong calendar time for diabatic processes, as was "//& - "done in MOM6 versions prior to February 2018. This is not recommended.", & - default=.false.) + call get_param(param_file, "MOM", "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, "MOM", "SURFACE_ANSWER_DATE", CS%answer_date, & + "The vintage of the expressions for the surface properties. 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=non_Bous) + if (non_Bous) CS%answer_date = 99991231 call get_param(param_file, "MOM", "SAVE_INITIAL_CONDS", save_IC, & "If true, write the initial conditions to a file given "//& @@ -2109,6 +2749,13 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "vertical grid files. Other values are invalid.", default=1) if (write_geom<0 .or. write_geom>2) call MOM_error(FATAL,"MOM: "//& "WRITE_GEOM must be equal to 0, 1 or 2.") + call get_param(param_file, "MOM", "GEOM_FILE", geom_file, & + "The file into which to write the ocean geometry.", & + default="ocean_geometry") + call get_param(param_file, "MOM", "USE_DBCLIENT", CS%use_dbclient, & + "If true, initialize a client to a remote database that can "//& + "be used for online analysis and machine-learning inference.",& + default=.false.) ! Check for inconsistent parameter settings. if (CS%use_ALE_algorithm .and. bulkmixedlayer) call MOM_error(FATAL, & @@ -2133,7 +2780,13 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call get_param(param_file, "MOM", "USE_PARTICLES", CS%use_particles, & "If true, use the particles package.", default=.false.) - + call get_param(param_file, "MOM", "USE_UH_PARTICLES", CS%use_uh_particles, & + "If true, use the uh velocity in the particles package.", & + default=.false., do_not_log=.not.CS%use_particles) + call get_param(param_file, "MOM", "UH_PARTICLES_BUG", CS%uh_particles_bug, & + "If true, use a bug in which the particles are advected inconsistently"//& + "with the dynamics timestep instead of the tracer timestep.", & + default=enable_bugs, do_not_log=.not.CS%use_uh_particles) CS%ensemble_ocean=.false. call get_param(param_file, "MOM", "ENSEMBLE_OCEAN", CS%ensemble_ocean, & "If False, The model is being run in serial mode as a single realization. "//& @@ -2143,6 +2796,14 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call callTree_waypoint("MOM parameters read (initialize_MOM)") + call get_param(param_file, "MOM", "HOMOGENIZE_FORCINGS", CS%homogenize_forcings, & + "If True, homogenize the forces and fluxes.", default=.false.) + call get_param(param_file, "MOM", "UPDATE_USTAR",CS%update_ustar, & + "If True, update ustar from homogenized tau when using the "//& + "HOMOGENIZE_FORCINGS option. Note that this will not work "//& + "with a non-zero gustiness factor.", default=.false., & + do_not_log=.not.CS%homogenize_forcings) + ! Grid rotation test call get_param(param_file, "MOM", "ROTATE_INDEX", CS%rotate_index, & "Enable rotation of the horizontal indices.", default=.false., & @@ -2164,6 +2825,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call get_param(param_file, "MOM", "INDEX_TURNS", turns, & "Number of counterclockwise quarter-turn index rotations.", & default=1, debuggingParam=.true.) + else + turns = 0 endif ! Set up the model domain and grids. @@ -2175,12 +2838,12 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & G_in => CS%G_in #ifdef STATIC_MEMORY_ call MOM_domains_init(G_in%domain, param_file, symmetric=symmetric, & - static_memory=.true., NIHALO=NIHALO_, NJHALO=NJHALO_, & - NIGLOBAL=NIGLOBAL_, NJGLOBAL=NJGLOBAL_, NIPROC=NIPROC_, & - NJPROC=NJPROC_) + static_memory=.true., NIHALO=NIHALO_, NJHALO=NJHALO_, & + NIGLOBAL=NIGLOBAL_, NJGLOBAL=NJGLOBAL_, NIPROC=NIPROC_, & + NJPROC=NJPROC_, US=US, MOM_dom_unmasked=MOM_dom_unmasked) #else call MOM_domains_init(G_in%domain, param_file, symmetric=symmetric, & - domain_name="MOM_in") + domain_name="MOM_in", US=US, MOM_dom_unmasked=MOM_dom_unmasked) #endif ! Copy input grid (G_in) domain to active grid G @@ -2215,7 +2878,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call MOM_grid_init(G_in, param_file, US, HI_in, bathymetry_at_vel=bathy_at_vel) ! Allocate initialize time-invariant MOM variables. - call MOM_initialize_fixed(dG_in, US, OBC_in, param_file, .false., dirs%output_directory) + call MOM_initialize_fixed(dG_in, US, OBC_in, param_file) ! Copy the grid metrics and bathymetry to the ocean_grid_type call copy_dyngrid_to_MOM_grid(dG_in, G_in, US) @@ -2225,6 +2888,15 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call verticalGridInit( param_file, CS%GV, US ) GV => CS%GV + ! Now that the vertical grid has been initialized, rescale parameters that depend on factors + ! that are set with the vertical grid to their desired units. This added rescaling step would + ! be unnecessary if the vertical grid were initialized earlier in this routine. + if (.not.bulkmixedlayer) then + CS%Hmix = (US%Z_to_m * GV%m_to_H) * Hmix_z + CS%Hmix_UV = (US%Z_to_m * GV%m_to_H) * Hmix_UV_z + endif + CS%HFrz = (US%Z_to_m * GV%m_to_H) * HFrz_z + ! 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 @@ -2240,9 +2912,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call copy_dyngrid_to_MOM_grid(dG, G, US) if (associated(OBC_in)) then - ! TODO: General OBC index rotations is not yet supported. - if (modulo(turns, 4) /= 1) & - call MOM_error(FATAL, "OBC index rotation of 180 and 270 degrees is not yet supported.") allocate(CS%OBC) call rotate_OBC_config(OBC_in, dG_in, CS%OBC, dG, turns) endif @@ -2256,6 +2925,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif ! dG_in is retained for now so that it can be used with write_ocean_geometry_file() below. + if (is_root_PE()) call check_MOM6_scaling_factors(CS%GV, US) + call callTree_waypoint("grids initialized (initialize_MOM)") call MOM_timing_init(CS) @@ -2277,48 +2948,57 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & CS%tv%T => CS%T ; CS%tv%S => CS%S if (CS%tv%T_is_conT) then vd_T = var_desc(name="contemp", units="Celsius", longname="Conservative Temperature", & - cmor_field_name="thetao", cmor_longname="Sea Water Potential Temperature", & - conversion=US%Q_to_J_kg*CS%tv%C_p) + cmor_field_name="bigthetao", cmor_longname="Sea Water Conservative Temperature", & + conversion=US%C_to_degC) else vd_T = var_desc(name="temp", units="degC", longname="Potential Temperature", & cmor_field_name="thetao", cmor_longname="Sea Water Potential Temperature", & - conversion=US%Q_to_J_kg*CS%tv%C_p) + conversion=US%C_to_degC) endif if (CS%tv%S_is_absS) then vd_S = var_desc(name="abssalt", units="g kg-1", longname="Absolute Salinity", & - cmor_field_name="so", cmor_longname="Sea Water Salinity", & - conversion=0.001) + cmor_field_name="absso", cmor_longname="Sea Water Absolute Salinity", & + conversion=US%S_to_ppt) else vd_S = var_desc(name="salt", units="psu", longname="Salinity", & cmor_field_name="so", cmor_longname="Sea Water Salinity", & - conversion=0.001) + conversion=US%S_to_ppt) endif if (advect_TS) then S_flux_units = get_tr_flux_units(GV, "psu") ! Could change to "kg m-2 s-1"? conv2watt = GV%H_to_kg_m2 * US%Q_to_J_kg*CS%tv%C_p if (GV%Boussinesq) then - conv2salt = GV%H_to_m ! Could change to GV%H_to_kg_m2 * 0.001? + conv2salt = US%S_to_ppt*GV%H_to_m ! Could change to US%S_to_ppt*GV%H_to_kg_m2 * 0.001? else - conv2salt = GV%H_to_kg_m2 + conv2salt = US%S_to_ppt*GV%H_to_kg_m2 endif call register_tracer(CS%tv%T, CS%tracer_Reg, param_file, HI, GV, & - tr_desc=vd_T, registry_diags=.true., flux_nameroot='T', & - flux_units='W', flux_longname='Heat', & + tr_desc=vd_T, registry_diags=.true., conc_scale=US%C_to_degC, & + flux_nameroot='T', flux_units='W', flux_longname='Heat', & + net_surfflux_name='KPP_QminusSW', NLT_budget_name='KPP_NLT_temp_budget', & + net_surfflux_longname='Net temperature flux ignoring short-wave, as used by [CVMix] KPP', & flux_scale=conv2watt, convergence_units='W m-2', & - convergence_scale=conv2watt, CMOR_tendprefix="opottemp", diag_form=2) + convergence_scale=conv2watt, CMOR_tendprefix="opottemp", & + diag_form=2, underflow_conc=temp_underflow, Tr_out=CS%tv%tr_T) call register_tracer(CS%tv%S, CS%tracer_Reg, param_file, HI, GV, & - tr_desc=vd_S, registry_diags=.true., flux_nameroot='S', & - flux_units=S_flux_units, flux_longname='Salt', & + tr_desc=vd_S, registry_diags=.true., conc_scale=US%S_to_ppt, & + flux_nameroot='S', flux_units=S_flux_units, flux_longname='Salt', & + net_surfflux_name='KPP_netSalt', NLT_budget_name='KPP_NLT_saln_budget', & flux_scale=conv2salt, convergence_units='kg m-2 s-1', & - convergence_scale=0.001*GV%H_to_kg_m2, CMOR_tendprefix="osalt", diag_form=2) + convergence_scale=0.001*US%S_to_ppt*GV%H_to_kg_m2, CMOR_tendprefix="osalt", & + diag_form=2, underflow_conc=salin_underflow, Tr_out=CS%tv%tr_S) endif endif - if (use_frazil) allocate(CS%tv%frazil(isd:ied,jsd:jed), source=0.0) + if (use_p_surf_in_EOS) allocate(CS%tv%p_surf(isd:ied,jsd:jed), source=0.0) + if (use_frazil) then + allocate(CS%tv%frazil(isd:ied,jsd:jed), source=0.0) + CS%tv%frazil_was_reset = .true. + endif if (bound_salinity) allocate(CS%tv%salt_deficit(isd:ied,jsd:jed), source=0.0) - if (bulkmixedlayer .or. use_temperature) allocate(CS%Hml(isd:ied,jsd:jed), source=0.0) + allocate(CS%Hml(isd:ied,jsd:jed), source=0.0) if (bulkmixedlayer) then GV%nkml = nkml ; GV%nk_rho_varies = nkml + nkbl @@ -2364,18 +3044,17 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & CS%time_in_cycle = 0.0 ; CS%time_in_thermo_cycle = 0.0 !allocate porous topography variables - ALLOC_(CS%por_face_areaU(IsdB:IedB,jsd:jed,nz)) ; CS%por_face_areaU(:,:,:) = 1.0 - ALLOC_(CS%por_face_areaV(isd:ied,JsdB:JedB,nz)) ; CS%por_face_areaV(:,:,:) = 1.0 - ALLOC_(CS%por_layer_widthU(IsdB:IedB,jsd:jed,nz+1)) ; CS%por_layer_widthU(:,:,:) = 1.0 - ALLOC_(CS%por_layer_widthV(isd:ied,JsdB:JedB,nz+1)) ; CS%por_layer_widthV(:,:,:) = 1.0 - CS%pbv%por_face_areaU => CS%por_face_areaU; CS%pbv%por_face_areaV=> CS%por_face_areaV - CS%pbv%por_layer_widthU => CS%por_layer_widthU; CS%pbv%por_layer_widthV => CS%por_layer_widthV + allocate(CS%pbv%por_face_areaU(IsdB:IedB,jsd:jed,nz), source=1.0) + allocate(CS%pbv%por_face_areaV(isd:ied,JsdB:JedB,nz), source=1.0) + allocate(CS%pbv%por_layer_widthU(IsdB:IedB,jsd:jed,nz+1), source=1.0) + allocate(CS%pbv%por_layer_widthV(isd:ied,JsdB:JedB,nz+1), source=1.0) + ! Use the Wright equation of state by default, unless otherwise specified ! Note: this line and the following block ought to be in a separate ! initialization routine for tv. if (use_EOS) then allocate(CS%tv%eqn_of_state) - call EOS_init(param_file, CS%tv%eqn_of_state, US) + call EOS_init(param_file, CS%tv%eqn_of_state, US, use_conT_absS) endif if (use_temperature) then allocate(CS%tv%TempxPmE(isd:ied,jsd:jed), source=0.0) @@ -2387,10 +3066,15 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! Set the fields that are needed for bitwise identical restarting ! the time stepping scheme. - call restart_init(param_file, restart_CSp) + call restart_init(param_file, CS%restart_CS) + restart_CSp => CS%restart_CS + call set_restart_fields(GV, US, param_file, CS, restart_CSp) - if (CS%split) then - call register_restarts_dyn_split_RK2(HI, GV, param_file, & + if (CS%split .and. CS%use_alt_split) then + call register_restarts_dyn_split_RK2b(HI, GV, US, param_file, & + CS%dyn_split_RK2b_CSp, restart_CSp, CS%uh, CS%vh) + elseif (CS%split) then + call register_restarts_dyn_split_RK2(HI, GV, US, param_file, & CS%dyn_split_RK2_CSp, restart_CSp, CS%uh, CS%vh) elseif (CS%use_RK2) then call register_restarts_dyn_unsplit_RK2(HI, GV, param_file, & @@ -2402,42 +3086,55 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! This subroutine calls user-specified tracer registration routines. ! Additional calls can be added to MOM_tracer_flow_control.F90. - call call_tracer_register(HI, GV, US, param_file, CS%tracer_flow_CSp, & + call call_tracer_register(G, GV, US, param_file, CS%tracer_flow_CSp, & CS%tracer_Reg, restart_CSp) - call MEKE_alloc_register_restart(HI, param_file, CS%MEKE, restart_CSp) - call set_visc_register_restarts(HI, GV, param_file, CS%visc, restart_CSp) - call mixedlayer_restrat_register_restarts(HI, param_file, & + call MEKE_alloc_register_restart(HI, US, param_file, CS%MEKE, restart_CSp) + call set_visc_register_restarts(HI, G, GV, US, param_file, CS%visc, restart_CSp, use_ice_shelf) + call mixedlayer_restrat_register_restarts(HI, GV, US, param_file, & CS%mixedlayer_restrat_CSp, restart_CSp) - if (CS%rotate_index .and. associated(OBC_in) .and. use_temperature) then - ! NOTE: register_temp_salt_segments includes allocation of tracer fields - ! along segments. Bit reproducibility requires that MOM_initialize_state - ! be called on the input index map, so we must setup both OBC and OBC_in. - ! - ! XXX: This call on OBC_in allocates the tracer fields on the unrotated - ! grid, but also incorrectly stores a pointer to a tracer_type for the - ! rotated registry (e.g. segment%tr_reg%Tr(n)%Tr) from CS%tracer_reg. - ! - ! While incorrect and potentially dangerous, it does not seem that this - ! pointer is used during initialization, so we leave it for now. - call register_temp_salt_segments(GV, OBC_in, CS%tracer_Reg, param_file) - endif - if (associated(CS%OBC)) then + ! This call initializes the relevant vertical remapping structures. + call open_boundary_setup_vert(GV, US, CS%OBC) + ! Set up remaining information about open boundary conditions that is needed for OBCs. - call call_OBC_register(param_file, CS%update_OBC_CSp, US, CS%OBC, CS%tracer_Reg) - !### Package specific changes to OBCs need to go here? + ! Package specific changes to OBCs occur here. + call call_OBC_register(G, GV, US, param_file, CS%update_OBC_CSp, CS%OBC, CS%tracer_Reg) ! This is the equivalent to 2 calls to register_segment_tracer (per segment), which ! could occur with the call to update_OBC_data or after the main initialization. if (use_temperature) & - call register_temp_salt_segments(GV, CS%OBC, CS%tracer_Reg, param_file) + call register_temp_salt_segments(GV, US, CS%OBC, CS%tracer_Reg, param_file) + ! This is the equivalent call to register_temp_salt_segments for external tracers with OBC + call call_tracer_register_obc_segments(GV, param_file, CS%tracer_flow_CSp, CS%tracer_Reg, CS%OBC) + + ! Set up the thickness reservoirs if using them. + if (CS%OBC%use_h_res) & + call segment_thickness_reservoir_init(GV, US, CS%OBC, param_file) ! This needs the number of tracers and to have called any code that sets whether ! reservoirs are used. - call open_boundary_register_restarts(HI, GV, CS%OBC, CS%tracer_Reg, & + call open_boundary_register_restarts(HI, GV, US, CS%OBC, CS%tracer_Reg, & param_file, restart_CSp, use_temperature) + + ! This call allocates the arrays on the segments for open boundary data, but it must occur + ! after any calls to call_tracer_register_obc_segments. + call initialize_segment_data(GV, US, CS%OBC, param_file, turns, use_temperature) + + if (CS%debug_OBCs) call write_OBC_info(CS%OBC, G, GV, US) + endif + + if (present(waves_CSp)) then + call waves_register_restarts(waves_CSp, HI, GV, US, param_file, restart_CSp) + endif + + if (use_temperature) then + call stoch_EOS_register_restarts(HI, param_file, CS%stoch_eos_CS, restart_CSp) + endif + + if (.not. CS%adiabatic) then + call register_diabatic_restarts(G, GV, US, param_file, CS%int_tide_CSp, restart_CSp, CS%diabatic_CSp) endif call callTree_waypoint("restart registration complete (initialize_MOM)") @@ -2446,18 +3143,29 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! Write out all of the grid data used by this run. new_sim = determine_is_new_run(dirs%input_filename, dirs%restart_input_dir, G_in, restart_CSp) write_geom_files = ((write_geom==2) .or. ((write_geom==1) .and. new_sim)) - if (write_geom_files) call write_ocean_geometry_file(dG_in, param_file, dirs%output_directory, US=US) - + if (write_geom_files) then + if (associated(MOM_dom_unmasked)) then + call hor_index_init(MOM_dom_unmasked, HI_in_unmasked, param_file, & + local_indexing=.not.global_indexing) + call create_dyn_horgrid(dG_unmasked_in, HI_in_unmasked, bathymetry_at_vel=bathy_at_vel) + call clone_MOM_domain(MOM_dom_unmasked, dG_unmasked_in%Domain) + call MOM_initialize_fixed(dG_unmasked_in, US, OBC_in, param_file) + call write_ocean_geometry_file(dG_unmasked_in, param_file, dirs%output_directory, US=US, geom_file=geom_file) + call deallocate_MOM_domain(MOM_dom_unmasked) + call destroy_dyn_horgrid(dG_unmasked_in) + else + call write_ocean_geometry_file(dG_in, param_file, dirs%output_directory, US=US, geom_file=geom_file) + endif + endif call destroy_dyn_horgrid(dG_in) ! Initialize dynamically evolving fields, perhaps from restart files. call cpu_clock_begin(id_clock_MOM_init) - call MOM_initialize_coord(GV, US, param_file, write_geom_files, & - dirs%output_directory, CS%tv, G%max_depth) + call MOM_initialize_coord(GV, US, param_file, CS%tv, G%max_depth) call callTree_waypoint("returned from MOM_initialize_coord() (initialize_MOM)") if (CS%use_ALE_algorithm) then - call ALE_init(param_file, GV, US, G%max_depth, CS%ALE_CSp) + call ALE_init(param_file, G, GV, US, G%max_depth, CS%ALE_CSp) call callTree_waypoint("returned from ALE_init() (initialize_MOM)") endif @@ -2475,9 +3183,18 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! Consider removing this later? G%ke = GV%ke + if (use_ice_shelf) then + point_calving = .false. ; if (present(calve_ice_shelf_bergs)) point_calving = calve_ice_shelf_bergs + endif + if (CS%rotate_index) then G_in%ke = GV%ke + ! Allocate the auxiliary non-symmetric domain for debugging or I/O purposes. + if (CS%debug .or. G_in%symmetric) then + call clone_MOM_domain(G_in%Domain, G_in%Domain_aux, symmetric=.false.) + else ; G_in%Domain_aux => G_in%Domain ; endif + allocate(u_in(G_in%IsdB:G_in%IedB, G_in%jsd:G_in%jed, nz), source=0.0) allocate(v_in(G_in%isd:G_in%ied, G_in%JsdB:G_in%JedB, nz), source=0.0) allocate(h_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed, nz), source=GV%Angstrom_H) @@ -2488,22 +3205,36 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & CS%tv%T => T_in CS%tv%S => S_in + + if (associated(CS%OBC)) then + ! Log this parameter in MOM_initialize_state + call get_param(param_file, "MOM", "OBC_RESERVOIR_INIT_BUG", OBC_reservoir_init_bug, & + "If true, set the OBC tracer reservoirs at the startup of a new run from the "//& + "interior tracer concentrations regardless of properties that may be explicitly "//& + "specified for the reservoir concentrations.", default=enable_bugs, do_not_log=.true.) + if (OBC_reservoir_init_bug .and. (allocated(CS%OBC%tres_x) .or. allocated(CS%OBC%tres_y))) & + call MOM_error(FATAL, "OBC_RESERVOIR_INIT_BUG can not be set to true with grid rotation.") + endif endif if (use_ice_shelf) then ! These arrays are not initialized in most solo cases, but are needed ! when using an ice shelf. Passing the ice shelf diagnostics CS from MOM ! for legacy reasons. The actual ice shelf diag CS is internal to the ice shelf - call initialize_ice_shelf(param_file, G_in, Time, ice_shelf_CSp, diag_ptr) + call initialize_ice_shelf(param_file, G, Time, ice_shelf_CSp, diag_ptr, & + Time_init, dirs%output_directory, calve_ice_shelf_bergs=point_calving) allocate(frac_shelf_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed), source=0.0) + allocate(mass_shelf_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed), source=0.0) allocate(CS%frac_shelf_h(isd:ied, jsd:jed), source=0.0) - call ice_shelf_query(ice_shelf_CSp,G,CS%frac_shelf_h) + allocate(CS%mass_shelf(isd:ied, jsd:jed), source=0.0) + call ice_shelf_query(ice_shelf_CSp, G, CS%frac_shelf_h, CS%mass_shelf) ! MOM_initialize_state is using the unrotated metric call rotate_array(CS%frac_shelf_h, -turns, frac_shelf_in) + call rotate_array(CS%mass_shelf, -turns, mass_shelf_in) call MOM_initialize_state(u_in, v_in, h_in, CS%tv, Time, G_in, GV, US, & param_file, dirs, restart_CSp, CS%ALE_CSp, CS%tracer_Reg, & sponge_in_CSp, ALE_sponge_in_CSp, oda_incupd_in_CSp, OBC_in, Time_in, & - frac_shelf_h=frac_shelf_in) + frac_shelf_h=frac_shelf_in, mass_shelf=mass_shelf_in) else call MOM_initialize_state(u_in, v_in, h_in, CS%tv, Time, G_in, GV, US, & param_file, dirs, restart_CSp, CS%ALE_CSp, CS%tracer_Reg, & @@ -2531,14 +3262,12 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif if (associated(ALE_sponge_in_CSp)) then - call rotate_ALE_sponge(ALE_sponge_in_CSp, G_in, CS%ALE_sponge_CSp, G, GV, turns, param_file) + call rotate_ALE_sponge(ALE_sponge_in_CSp, G_in, CS%ALE_sponge_CSp, G, GV, US, turns, param_file) call update_ALE_sponge_field(CS%ALE_sponge_CSp, T_in, G, GV, CS%T) call update_ALE_sponge_field(CS%ALE_sponge_CSp, S_in, G, GV, CS%S) endif - if (associated(OBC_in)) & - call rotate_OBC_init(OBC_in, G, GV, US, param_file, CS%tv, restart_CSp, CS%OBC) - + ! Deallocate the unrotated arrays and types that are no longer needed. deallocate(u_in) deallocate(v_in) deallocate(h_in) @@ -2546,21 +3275,24 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & deallocate(T_in) deallocate(S_in) endif - if (use_ice_shelf) & - deallocate(frac_shelf_in) - else + if (use_ice_shelf) deallocate(frac_shelf_in, mass_shelf_in) + if (associated(OBC_in)) call open_boundary_end(OBC_in) + + else ! The model is being run without grid rotation. This is true of all production runs. if (use_ice_shelf) then - call initialize_ice_shelf(param_file, G, Time, ice_shelf_CSp, diag_ptr) + call initialize_ice_shelf(param_file, G, Time, ice_shelf_CSp, diag_ptr, Time_init, & + dirs%output_directory, calve_ice_shelf_bergs=point_calving) allocate(CS%frac_shelf_h(isd:ied, jsd:jed), source=0.0) - call ice_shelf_query(ice_shelf_CSp,G,CS%frac_shelf_h) + allocate(CS%mass_shelf(isd:ied, jsd:jed), source=0.0) + call ice_shelf_query(ice_shelf_CSp,G,CS%frac_shelf_h, CS%mass_shelf) call MOM_initialize_state(CS%u, CS%v, CS%h, CS%tv, Time, G, GV, US, & param_file, dirs, restart_CSp, CS%ALE_CSp, CS%tracer_Reg, & - CS%sponge_CSp, CS%ALE_sponge_CSp,CS%oda_incupd_CSp, CS%OBC, Time_in, & - frac_shelf_h=CS%frac_shelf_h) + CS%sponge_CSp, CS%ALE_sponge_CSp, CS%oda_incupd_CSp, CS%OBC, Time_in, & + frac_shelf_h=CS%frac_shelf_h, mass_shelf=CS%mass_shelf, OBC_for_bug=CS%OBC) else call MOM_initialize_state(CS%u, CS%v, CS%h, CS%tv, Time, G, GV, US, & param_file, dirs, restart_CSp, CS%ALE_CSp, CS%tracer_Reg, & - CS%sponge_CSp, CS%ALE_sponge_CSp, CS%oda_incupd_CSp, CS%OBC, Time_in) + CS%sponge_CSp, CS%ALE_sponge_CSp, CS%oda_incupd_CSp, CS%OBC, Time_in, OBC_for_bug=CS%OBC) endif ! Reset the first direction if it was found in a restart file. @@ -2571,8 +3303,31 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif endif - if (use_ice_shelf .and. CS%debug) & + ! Allocate any derived densities or other equation of state derived fields. + if (.not.(GV%Boussinesq .or. GV%semi_Boussinesq)) then + allocate(CS%tv%SpV_avg(isd:ied,jsd:jed,nz), source=0.0) + CS%tv%valid_SpV_halo = -1 ! This array does not yet have any valid data. + endif + + if (associated(CS%OBC)) then + call MOM_initialize_OBCs(CS%h, CS%tv, CS%OBC, Time, G, GV, US, param_file, restart_CSp, CS%tracer_Reg) + + if (use_temperature) then + call pass_var(CS%tv%T, G%Domain, complete=.false.) + call pass_var(CS%tv%S, G%Domain, complete=.true.) + endif + call calc_derived_thermo(CS%tv, CS%h, G, GV, US) + + ! Call this during initialization to fill boundary arrays from fixed values + call read_OBC_segment_data(G, GV, US, CS%OBC, CS%tv, CS%h, Time) + call update_OBC_segment_data(G, GV, US, CS%OBC, CS%h, Time) + call initialize_OBC_segment_reservoirs(GV, CS%OBC) + endif + + if (use_ice_shelf .and. CS%debug) then call hchksum(CS%frac_shelf_h, "MOM:frac_shelf_h", G%HI, haloshift=0) + call hchksum(CS%mass_shelf, "MOM:mass_shelf", G%HI, haloshift=0, unscale=US%RZ_to_kg_m2) + endif call cpu_clock_end(id_clock_MOM_init) call callTree_waypoint("returned from MOM_initialize_state() (initialize_MOM)") @@ -2607,39 +3362,101 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (ALE_remap_init_conds(CS%ALE_CSp) .and. .not. query_initialized(CS%h,"h",restart_CSp)) then ! This block is controlled by the ALE parameter REMAP_AFTER_INITIALIZATION. - ! \todo This block exists for legacy reasons and we should phase it out of - ! all examples. !### + ! \todo This block exists for legacy reasons and we should phase it out of all examples. !### if (CS%debug) then - call uvchksum("Pre ALE adjust init cond [uv]", & - CS%u, CS%v, G%HI, haloshift=1) - call hchksum(CS%h,"Pre ALE adjust init cond h", G%HI, haloshift=1, scale=GV%H_to_m) + call uvchksum("Pre ALE adjust init cond [uv]", CS%u, CS%v, G%HI, haloshift=1, unscale=US%L_T_to_m_s) + call hchksum(CS%h,"Pre ALE adjust init cond h", G%HI, haloshift=1, unscale=GV%H_to_MKS) endif call callTree_waypoint("Calling adjustGridForIntegrity() to remap initial conditions (initialize_MOM)") call adjustGridForIntegrity(CS%ALE_CSp, G, GV, CS%h ) - call callTree_waypoint("Calling ALE_main() to remap initial conditions (initialize_MOM)") + if (allocated(CS%tv%SpV_avg)) call calc_derived_thermo(CS%tv, CS%h, G, GV, US, halo=1) + call pre_ALE_adjustments(G, GV, US, CS%h, CS%tv, CS%tracer_Reg, CS%ALE_CSp, CS%u, CS%v) + + call callTree_waypoint("Calling ALE_regrid() to remap initial conditions (initialize_MOM)") + allocate(h_new(isd:ied, jsd:jed, nz), source=0.0) + allocate(dzRegrid(isd:ied, jsd:jed, nz+1), source=0.0) + allocate(PCM_cell(isd:ied, jsd:jed, nz), source=.false.) + allocate(h_old_u(IsdB:IedB, jsd:jed, nz), source=0.0) + allocate(h_new_u(IsdB:IedB, jsd:jed, nz), source=0.0) + allocate(h_old_v(isd:ied, JsdB:JedB, nz), source=0.0) + allocate(h_new_v(isd:ied, JsdB:JedB, nz), source=0.0) if (use_ice_shelf) then - call ALE_main(G, GV, US, CS%h, CS%u, CS%v, CS%tv, CS%tracer_Reg, CS%ALE_CSp, & - CS%OBC, frac_shelf_h=CS%frac_shelf_h) + call ALE_regrid(G, GV, US, CS%h, h_new, dzRegrid, CS%tv, CS%ALE_CSp, CS%frac_shelf_h, PCM_cell) + else + call ALE_regrid(G, GV, US, CS%h, h_new, dzRegrid, CS%tv, CS%ALE_CSp, PCM_cell=PCM_cell) + endif + + if (callTree_showQuery()) call callTree_waypoint("new grid generated") + ! Remap all variables from the old grid h onto the new grid h_new + call ALE_remap_tracers(CS%ALE_CSp, G, GV, CS%h, h_new, CS%tracer_Reg, CS%debug, PCM_cell=PCM_cell) + + ! Determine the old and new grid thicknesses at velocity points. + call ALE_remap_set_h_vel(CS%ALE_CSp, G, GV, CS%h, h_old_u, h_old_v, CS%OBC, debug=CS%debug) + if (CS%remap_uv_using_old_alg) then + call ALE_remap_set_h_vel_via_dz(CS%ALE_CSp, G, GV, h_new, h_new_u, h_new_v, CS%OBC, CS%h, dzRegrid, CS%debug) else - call ALE_main( G, GV, US, CS%h, CS%u, CS%v, CS%tv, CS%tracer_Reg, CS%ALE_CSp, CS%OBC) + call ALE_remap_set_h_vel(CS%ALE_CSp, G, GV, h_new, h_new_u, h_new_v, CS%OBC, debug=CS%debug) endif + ! Remap the velocity components. + call ALE_remap_velocities(CS%ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, CS%u, CS%v, CS%debug) + + if (allocated(CS%tv%SpV_avg)) CS%tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. + + ! Replace the old grid with new one. All remapping must be done at this point. + !$OMP parallel do default(shared) + do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + CS%h(i,j,k) = h_new(i,j,k) + enddo ; enddo ; enddo + + deallocate(h_new, dzRegrid, PCM_cell, h_old_u, h_new_u, h_old_v, h_new_v) + call cpu_clock_begin(id_clock_pass_init) call create_group_pass(tmp_pass_uv_T_S_h, CS%u, CS%v, G%Domain) if (use_temperature) then - call create_group_pass(tmp_pass_uv_T_S_h, CS%tv%T, G%Domain, halo=1) - call create_group_pass(tmp_pass_uv_T_S_h, CS%tv%S, G%Domain, halo=1) + call create_group_pass(tmp_pass_uv_T_S_h, CS%tv%T, G%Domain) + call create_group_pass(tmp_pass_uv_T_S_h, CS%tv%S, G%Domain) endif - call create_group_pass(tmp_pass_uv_T_S_h, CS%h, G%Domain, halo=1) + call create_group_pass(tmp_pass_uv_T_S_h, CS%h, G%Domain) call do_group_pass(tmp_pass_uv_T_S_h, G%Domain) call cpu_clock_end(id_clock_pass_init) if (CS%debug) then - call uvchksum("Post ALE adjust init cond [uv]", CS%u, CS%v, G%HI, haloshift=1) - call hchksum(CS%h, "Post ALE adjust init cond h", G%HI, haloshift=1, scale=GV%H_to_m) + call uvchksum("Post ALE adjust init cond [uv]", CS%u, CS%v, G%HI, haloshift=1, unscale=US%L_T_to_m_s) + call hchksum(CS%h, "Post ALE adjust init cond h", G%HI, haloshift=2, unscale=GV%H_to_MKS) + if (use_temperature) then + call hchksum(CS%tv%T, "Post ALE adjust init cond T", G%HI, haloshift=2, unscale=US%C_to_degC) + call hchksum(CS%tv%S, "Post ALE adjust init cond S", G%HI, haloshift=2, unscale=US%S_to_ppt) + endif endif endif - if ( CS%use_ALE_algorithm ) call ALE_updateVerticalGridType( CS%ALE_CSp, GV ) + if ( CS%use_ALE_algorithm ) then + call ALE_set_extrap_boundaries (param_file, CS%ALE_CSp) + call callTree_waypoint("returned from ALE_init() (initialize_MOM)") + call ALE_updateVerticalGridType( CS%ALE_CSp, GV ) + endif + ! The basic state variables have now been fully initialized, so update their halos and + ! calculate any derived thermodynmics quantities. + + !--- set up group pass for u,v,T,S and h. pass_uv_T_S_h also is used in step_MOM + call cpu_clock_begin(id_clock_pass_init) + dynamics_stencil = min(3, G%Domain%nihalo, G%Domain%njhalo) + call create_group_pass(pass_uv_T_S_h, CS%u, CS%v, G%Domain, halo=dynamics_stencil) + if (use_temperature) then + call create_group_pass(pass_uv_T_S_h, CS%tv%T, G%Domain, halo=dynamics_stencil) + call create_group_pass(pass_uv_T_S_h, CS%tv%S, G%Domain, halo=dynamics_stencil) + endif + call create_group_pass(pass_uv_T_S_h, CS%h, G%Domain, halo=dynamics_stencil) + + call do_group_pass(pass_uv_T_S_h, G%Domain) + if (associated(CS%tv%p_surf)) call pass_var(CS%tv%p_surf, G%Domain, halo=dynamics_stencil) + call cpu_clock_end(id_clock_pass_init) + + ! Update derived thermodynamic quantities. + if (allocated(CS%tv%SpV_avg)) then + call calc_derived_thermo(CS%tv, CS%h, G, GV, US, halo=dynamics_stencil, debug=CS%debug) + endif + diag => CS%diag ! Initialize the diag mediator. @@ -2653,15 +3470,15 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! Set up pointers within diag mediator control structure, ! this needs to occur _after_ CS%h etc. have been allocated. - call diag_set_state_ptrs(CS%h, CS%T, CS%S, CS%tv%eqn_of_state, diag) + call diag_set_state_ptrs(CS%h, CS%tv, diag) ! This call sets up the diagnostic axes. These are needed, ! e.g. to generate the target grids below. call set_axes_info(G, GV, US, param_file, diag) ! Whenever thickness/T/S changes let the diag manager know, target grids - ! for vertical remapping may need to be regenerated. - ! FIXME: are h, T, S updated at the same time? Review these for T, S updates. + ! for vertical remapping may need to be regenerated. In non-Boussinesq mode, + ! calc_derived_thermo needs to be called before diag_update_remap_grids. call diag_update_remap_grids(diag) ! Setup the diagnostic grid storage types @@ -2674,36 +3491,61 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! must be defined. call set_masks_for_axes(G, diag) - ! Diagnose static fields AND associate areas/volumes with axes - call write_static_fields(G, GV, US, CS%tv, CS%diag) - call callTree_waypoint("static fields written (initialize_MOM)") - ! Register the volume cell measure (must be one of first diagnostics) call register_cell_measure(G, CS%diag, Time) call cpu_clock_begin(id_clock_MOM_init) + ! Diagnose static fields AND associate areas/volumes with axes + call write_static_fields(G, GV, US, CS%tv, CS%diag) + call callTree_waypoint("static fields written (initialize_MOM)") + if (CS%use_ALE_algorithm) then call ALE_writeCoordinateFile( CS%ALE_CSp, GV, dirs%output_directory ) + call callTree_waypoint("ALE initialized (initialize_MOM)") + elseif (write_geom_files) then + call write_vertgrid_file(GV, US, param_file, dirs%output_directory) endif call cpu_clock_end(id_clock_MOM_init) - call callTree_waypoint("ALE initialized (initialize_MOM)") - CS%useMEKE = MEKE_init(Time, G, US, param_file, diag, CS%MEKE_CSp, CS%MEKE, restart_CSp) + if (CS%use_dbclient) call database_comms_init(param_file, CS%dbcomms_CS) + CS%useMEKE = MEKE_init(Time, G, GV, US, param_file, diag, CS%dbcomms_CS, CS%MEKE_CSp, CS%MEKE, & + restart_CSp, CS%MEKE_in_dynamics) call VarMix_init(Time, G, GV, US, param_file, diag, CS%VarMix) call set_visc_init(Time, G, GV, US, param_file, diag, CS%visc, CS%set_visc_CSp, restart_CSp, CS%OBC) call thickness_diffuse_init(Time, G, GV, US, param_file, diag, CS%CDp, CS%thickness_diffuse_CSp) + if (CS%interface_filter) & + call interface_filter_init(Time, G, GV, US, param_file, diag, CS%CDp, CS%interface_filter_CSp) + + new_sim = is_new_run(restart_CSp) + if (use_temperature) then + CS%use_stochastic_EOS = MOM_stoch_eos_init(Time, G, GV, US, param_file, diag, CS%stoch_eos_CS, restart_CSp) + else + CS%use_stochastic_EOS = .false. + endif + + if (CS%use_porbar) & + call porous_barriers_init(Time, GV, US, param_file, diag, CS%por_bar_CS) if (CS%split) then allocate(eta(SZI_(G),SZJ_(G)), source=0.0) - call initialize_dyn_split_RK2(CS%u, CS%v, CS%h, CS%uh, CS%vh, eta, Time, & - G, GV, US, param_file, diag, CS%dyn_split_RK2_CSp, restart_CSp, & + if (CS%use_alt_split) then + call initialize_dyn_split_RK2b(CS%u, CS%v, CS%h, CS%tv, CS%uh, CS%vh, eta, Time, & + G, GV, US, param_file, diag, CS%dyn_split_RK2b_CSp, CS%HA_CSp, restart_CSp, & CS%dt, CS%ADp, CS%CDp, MOM_internal_state, CS%VarMix, CS%MEKE, & - CS%thickness_diffuse_CSp, & - CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, & - CS%visc, dirs, CS%ntrunc, CS%pbv, calc_dtbt=calc_dtbt, cont_stencil=CS%cont_stencil) + CS%thickness_diffuse_CSp, CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, & + CS%visc, dirs, CS%ntrunc, CS%pbv, calc_dtbt=calc_dtbt, & + cont_stencil=CS%cont_stencil, dyn_h_stencil=CS%dyn_h_stencil) + else + call initialize_dyn_split_RK2(CS%u, CS%v, CS%h, CS%tv, CS%uh, CS%vh, eta, Time, & + G, GV, US, param_file, diag, CS%dyn_split_RK2_CSp, CS%HA_CSp, restart_CSp, & + CS%dt, CS%ADp, CS%CDp, MOM_internal_state, CS%VarMix, CS%MEKE, & + CS%thickness_diffuse_CSp, CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, & + CS%visc, dirs, CS%ntrunc, CS%pbv, calc_dtbt=calc_dtbt, & + cont_stencil=CS%cont_stencil, dyn_h_stencil=CS%dyn_h_stencil) + endif if (CS%dtbt_reset_period > 0.0) then - CS%dtbt_reset_interval = real_to_time(CS%dtbt_reset_period) + CS%dtbt_reset_interval = real_to_time(CS%dtbt_reset_period, unscale=US%T_to_s) ! Set dtbt_reset_time to be the next even multiple of dtbt_reset_interval. CS%dtbt_reset_time = Time_init + CS%dtbt_reset_interval * & ((Time - Time_init) / CS%dtbt_reset_interval) @@ -2715,29 +3557,49 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif endif elseif (CS%use_RK2) then - call initialize_dyn_unsplit_RK2(CS%u, CS%v, CS%h, Time, G, GV, US, & - param_file, diag, CS%dyn_unsplit_RK2_CSp, & + call initialize_dyn_unsplit_RK2(CS%u, CS%v, CS%h, CS%tv, Time, G, GV, & + US, param_file, diag, CS%dyn_unsplit_RK2_CSp, & CS%ADp, CS%CDp, MOM_internal_state, CS%OBC, & CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, CS%visc, dirs, & - CS%ntrunc, cont_stencil=CS%cont_stencil) + CS%ntrunc, cont_stencil=CS%cont_stencil, dyn_h_stencil=CS%dyn_h_stencil) else - call initialize_dyn_unsplit(CS%u, CS%v, CS%h, Time, G, GV, US, & - param_file, diag, CS%dyn_unsplit_CSp, & + call initialize_dyn_unsplit(CS%u, CS%v, CS%h, CS%tv, Time, G, GV, & + US, param_file, diag, CS%dyn_unsplit_CSp, & CS%ADp, CS%CDp, MOM_internal_state, CS%OBC, & CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, CS%visc, dirs, & - CS%ntrunc, cont_stencil=CS%cont_stencil) + CS%ntrunc, cont_stencil=CS%cont_stencil, dyn_h_stencil=CS%dyn_h_stencil) + endif + CS%dyn_h_stencil = max(2, CS%dyn_h_stencil) + + !Set OBC segment data update period + if (associated(CS%OBC) .and. CS%dt_obc_seg_period > 0.0) then + CS%dt_obc_seg_interval = real_to_time(CS%dt_obc_seg_period, unscale=US%T_to_s) + CS%dt_obc_seg_time = Time + CS%dt_obc_seg_interval endif call callTree_waypoint("dynamics initialized (initialize_MOM)") CS%mixedlayer_restrat = mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, & CS%mixedlayer_restrat_CSp, restart_CSp) + + if (GV%Boussinesq .and. associated(CS%visc%h_ML)) then + ! This is here to allow for a transition of restart files between model versions. + call get_param(param_file, "MOM", "MLE_USE_PBL_MLD", MLE_use_PBL_MLD, & + default=.false., do_not_log=.true.) + if (MLE_use_PBL_MLD .and. .not.query_initialized(CS%visc%h_ML, "h_ML", restart_CSp) .and. & + associated(CS%visc%MLD)) then + do j=js,je ; do i=is,ie ; CS%visc%h_ML(i,j) = GV%Z_to_H * CS%visc%MLD(i,j) ; enddo ; enddo + endif + endif + if (CS%mixedlayer_restrat) then if (.not.(bulkmixedlayer .or. CS%use_ALE_algorithm)) & call MOM_error(FATAL, "MOM: MIXEDLAYER_RESTRAT true requires a boundary layer scheme.") ! When DIABATIC_FIRST=False and using CS%visc%ML in mixedlayer_restrat we need to update after a restart if (.not. CS%diabatic_first .and. associated(CS%visc%MLD)) & call pass_var(CS%visc%MLD, G%domain, halo=1) + if (.not. CS%diabatic_first .and. associated(CS%visc%h_ML)) & + call pass_var(CS%visc%h_ML, G%domain, halo=1) endif call MOM_diagnostics_init(MOM_internal_state, CS%ADp, CS%CDp, Time, G, GV, US, & @@ -2751,19 +3613,22 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & else call diabatic_driver_init(Time, G, GV, US, param_file, CS%use_ALE_algorithm, diag, & CS%ADp, CS%CDp, CS%diabatic_CSp, CS%tracer_flow_CSp, & - CS%sponge_CSp, CS%ALE_sponge_CSp, CS%oda_incupd_CSp) + CS%sponge_CSp, CS%ALE_sponge_CSp, CS%oda_incupd_CSp, CS%int_tide_CSp) + endif + + CS%vertex_shear = kappa_shear_at_vertex(param_file) + + ! GMM, the following is needed to get BLDs into the dynamics module + if (CS%split .and. fpmix) then + call init_dyn_split_RK2_diabatic(CS%diabatic_CSp, CS%dyn_split_RK2_CSp) endif if (associated(CS%sponge_CSp)) & call init_sponge_diags(Time, G, GV, US, diag, CS%sponge_CSp) - if (associated(CS%ALE_sponge_CSp)) & - call init_ALE_sponge_diags(Time, G, diag, CS%ALE_sponge_CSp, US) - if (associated(CS%oda_incupd_CSp)) & call init_oda_incupd_diags(Time, G, GV, diag, CS%oda_incupd_CSp, US) - call tracer_advect_init(Time, G, US, param_file, diag, CS%tracer_adv_CSp) call tracer_hor_diff_init(Time, G, GV, US, param_file, diag, CS%tv%eqn_of_state, CS%diabatic_CSp, & CS%tracer_diff_CSp) @@ -2775,19 +3640,31 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call register_surface_diags(Time, G, US, CS%sfc_IDs, CS%diag, CS%tv) call register_diags(Time, G, GV, US, CS%IDs, CS%diag) call register_transport_diags(Time, G, GV, US, CS%transport_IDs, CS%diag) + call extract_diabatic_member(CS%diabatic_CSp, use_KPP=use_KPP) call register_tracer_diagnostics(CS%tracer_Reg, CS%h, Time, diag, G, GV, US, & - CS%use_ALE_algorithm) + CS%use_ALE_algorithm, use_KPP) if (CS%use_ALE_algorithm) then call ALE_register_diags(Time, G, GV, US, diag, CS%ALE_CSp) endif + ! Do any necessary halo updates on any auxiliary variables that have been initialized. + call cpu_clock_begin(id_clock_pass_init) + if (associated(CS%visc%Kv_shear)) & + call pass_var(CS%visc%Kv_shear, G%Domain, To_All+Omit_Corners, halo=1) + + if (associated(CS%visc%Kv_slow)) & + call pass_var(CS%visc%Kv_slow, G%Domain, To_All+Omit_Corners, halo=1) + call cpu_clock_end(id_clock_pass_init) + ! This subroutine initializes any tracer packages. - new_sim = is_new_run(restart_CSp) call tracer_flow_control_init(.not.new_sim, Time, G, GV, US, CS%h, param_file, & CS%diag, CS%OBC, CS%tracer_flow_CSp, CS%sponge_CSp, & CS%ALE_sponge_CSp, CS%tv) if (present(tracer_flow_CSp)) tracer_flow_CSp => CS%tracer_flow_CSp + if (associated(CS%ALE_sponge_CSp)) & + call init_ALE_sponge_diags(Time, G, diag, CS%ALE_sponge_CSp, US) + ! If running in offline tracer mode, initialize the necessary control structure and ! parameters if (present(offline_tracer_mode)) offline_tracer_mode=CS%offline_tracer_mode @@ -2796,95 +3673,45 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! Setup some initial parameterizations and also assign some of the subtypes call offline_transport_init(param_file, CS%offline_CSp, CS%diabatic_CSp, G, GV, US) call insert_offline_main( CS=CS%offline_CSp, ALE_CSp=CS%ALE_CSp, diabatic_CSp=CS%diabatic_CSp, & - diag=CS%diag, OBC=CS%OBC, tracer_adv_CSp=CS%tracer_adv_CSp, & - tracer_flow_CSp=CS%tracer_flow_CSp, tracer_Reg=CS%tracer_Reg, & + diag=CS%diag, OBC=CS%OBC, tracer_adv_CSp=CS%tracer_adv_CSp, & + tracer_flow_CSp=CS%tracer_flow_CSp, tracer_Reg=CS%tracer_Reg, & tv=CS%tv, x_before_y=(MODULO(first_direction,2)==0), debug=CS%debug ) - call register_diags_offline_transport(Time, CS%diag, CS%offline_CSp) + call register_diags_offline_transport(Time, CS%diag, CS%offline_CSp, GV, US) endif - !--- set up group pass for u,v,T,S and h. pass_uv_T_S_h also is used in step_MOM - call cpu_clock_begin(id_clock_pass_init) - dynamics_stencil = min(3, G%Domain%nihalo, G%Domain%njhalo) - call create_group_pass(pass_uv_T_S_h, CS%u, CS%v, G%Domain, halo=dynamics_stencil) - if (use_temperature) then - call create_group_pass(pass_uv_T_S_h, CS%tv%T, G%Domain, halo=dynamics_stencil) - call create_group_pass(pass_uv_T_S_h, CS%tv%S, G%Domain, halo=dynamics_stencil) + if (associated(CS%OBC)) then + ! At this point any information related to the tracer reservoirs has either been read from + ! the restart file or has been specified in the segments. Initialize the tracer reservoir + ! values from the segments if they have not been set via the restart file. + call setup_OBC_tracer_reservoirs(G, GV, CS%OBC, restart_CSp) + call setup_OBC_thickness_reservoirs(G, GV, CS%OBC, restart_CSp) + call open_boundary_halo_update(G, CS%OBC) endif - call create_group_pass(pass_uv_T_S_h, CS%h, G%Domain, halo=dynamics_stencil) - - call do_group_pass(pass_uv_T_S_h, G%Domain) - - if (associated(CS%visc%Kv_shear)) & - call pass_var(CS%visc%Kv_shear, G%Domain, To_All+Omit_Corners, halo=1) - - if (associated(CS%visc%Kv_slow)) & - call pass_var(CS%visc%Kv_slow, G%Domain, To_All+Omit_Corners, halo=1) - - call cpu_clock_end(id_clock_pass_init) call register_obsolete_diagnostics(param_file, CS%diag) if (use_frazil) then - if (query_initialized(CS%tv%frazil, "frazil", restart_CSp)) then - ! Test whether the dimensional rescaling has changed for heat content. - if ((US%kg_m3_to_R_restart*US%m_to_Z_restart*US%J_kg_to_Q_restart /= 0.0) .and. & - ((US%J_kg_to_Q*US%kg_m3_to_R*US%m_to_Z) /= & - (US%J_kg_to_Q_restart*US%kg_m3_to_R_restart*US%m_to_Z_restart)) ) then - QRZ_rescale = (US%J_kg_to_Q*US%kg_m3_to_R*US%m_to_Z) / & - (US%J_kg_to_Q_restart*US%kg_m3_to_R_restart*US%m_to_Z_restart) - do j=js,je ; do i=is,ie - CS%tv%frazil(i,j) = QRZ_rescale * CS%tv%frazil(i,j) - enddo ; enddo - endif - else + if (.not.query_initialized(CS%tv%frazil, "frazil", restart_CSp)) then CS%tv%frazil(:,:) = 0.0 + call set_initialized(CS%tv%frazil, "frazil", restart_CSp) endif endif if (CS%interp_p_surf) then - CS%p_surf_prev_set = query_initialized(CS%p_surf_prev,"p_surf_prev",restart_CSp) + CS%p_surf_prev_set = query_initialized(CS%p_surf_prev, "p_surf_prev", restart_CSp) if (CS%p_surf_prev_set) then - ! Test whether the dimensional rescaling has changed for pressure. - if ((US%kg_m3_to_R_restart*US%s_to_T_restart*US%m_to_L_restart /= 0.0) .and. & - ((US%kg_m3_to_R*(US%m_to_L*US%s_to_T_restart)**2) /= & - (US%kg_m3_to_R_restart*(US%m_to_L_restart*US%s_to_T)**2)) ) then - RL2_T2_rescale = (US%kg_m3_to_R*(US%m_to_L*US%s_to_T_restart)**2) / & - (US%kg_m3_to_R_restart*(US%m_to_L_restart*US%s_to_T)**2) - do j=js,je ; do i=is,ie - CS%p_surf_prev(i,j) = RL2_T2_rescale * CS%p_surf_prev(i,j) - enddo ; enddo - endif - call pass_var(CS%p_surf_prev, G%domain) endif endif - if (use_ice_shelf .and. associated(CS%Hml)) then - if (query_initialized(CS%Hml, "hML", restart_CSp)) then - ! Test whether the dimensional rescaling has changed for depths. - if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z /= US%m_to_Z_restart) ) then - Z_rescale = US%m_to_Z / US%m_to_Z_restart - do j=js,je ; do i=is,ie - CS%Hml(i,j) = Z_rescale * CS%Hml(i,j) - enddo ; enddo - endif - endif - endif - - if (query_initialized(CS%ave_ssh_ibc,"ave_ssh",restart_CSp)) then - if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z /= US%m_to_Z_restart) ) then - Z_rescale = US%m_to_Z / US%m_to_Z_restart - do j=js,je ; do i=is,ie - CS%ave_ssh_ibc(i,j) = Z_rescale * CS%ave_ssh_ibc(i,j) - enddo ; enddo - endif - else + if (.not.query_initialized(CS%ave_ssh_ibc, "ave_ssh", restart_CSp)) then if (CS%split) then call find_eta(CS%h, CS%tv, G, GV, US, CS%ave_ssh_ibc, eta, dZref=G%Z_ref) else call find_eta(CS%h, CS%tv, G, GV, US, CS%ave_ssh_ibc, dZref=G%Z_ref) endif + call set_initialized(CS%ave_ssh_ibc, "ave_ssh", restart_CSp) endif if (CS%split) deallocate(eta) @@ -2899,37 +3726,30 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & (LEN_TRIM(dirs%input_filename) == 1)) if (CS%ensemble_ocean) then - call init_oda(Time, G, GV, CS%diag, CS%odaCS) + call init_oda(Time, G, GV, US, CS%diag, CS%odaCS) endif ! initialize stochastic physics call stochastics_init(CS%dt_therm, CS%G, CS%GV, CS%stoch_CS, param_file, diag, Time) - !### This could perhaps go here instead of in finish_MOM_initialization? - ! call fix_restart_scaling(GV) - ! call fix_restart_unit_scaling(US) - call callTree_leave("initialize_MOM()") - call cpu_clock_end(id_clock_init) + call cpu_clock_end(id_clock_init) ; call cpu_clock_end(id_clock_ocean) end subroutine initialize_MOM !> Finishes initializing MOM and writes out the initial conditions. -subroutine finish_MOM_initialization(Time, dirs, CS, restart_CSp) +subroutine finish_MOM_initialization(Time, dirs, CS) type(time_type), intent(in) :: Time !< model time, used in this routine type(directories), intent(in) :: dirs !< structure with directory paths type(MOM_control_struct), intent(inout) :: CS !< MOM control structure - type(MOM_restart_CS), pointer :: restart_CSp !< pointer to the restart control - !! structure that will be used for MOM. - ! Local variables + type(ocean_grid_type), pointer :: G => NULL() ! pointer to a structure containing ! metrics and related information type(verticalGrid_type), pointer :: GV => NULL() ! Pointer to the vertical grid structure type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing ! various unit conversion factors type(MOM_restart_CS), pointer :: restart_CSp_tmp => NULL() - real, allocatable :: z_interface(:,:,:) ! Interface heights [m] - type(vardesc) :: vd + real, allocatable :: z_interface(:,:,:) ! Interface heights [Z ~> m] call cpu_clock_begin(id_clock_init) call callTree_enter("finish_MOM_initialization()") @@ -2937,24 +3757,19 @@ subroutine finish_MOM_initialization(Time, dirs, CS, restart_CSp) ! Pointers for convenience G => CS%G ; GV => CS%GV ; US => CS%US - !### Move to initialize_MOM? - call fix_restart_scaling(GV) - call fix_restart_unit_scaling(US) - - if (CS%use_particles) then - call particles_init(CS%particles, G, CS%Time, CS%dt_therm, CS%u, CS%v) + call particles_init(CS%particles, G, CS%Time, CS%dt_therm, CS%u, CS%v, CS%h) endif ! Write initial conditions if (CS%write_IC) then allocate(restart_CSp_tmp) - restart_CSp_tmp = restart_CSp + restart_CSp_tmp = CS%restart_CS call restart_registry_lock(restart_CSp_tmp, unlocked=.true.) allocate(z_interface(SZI_(G),SZJ_(G),SZK_(GV)+1)) - call find_eta(CS%h, CS%tv, G, GV, US, z_interface, eta_to_m=1.0, dZref=G%Z_ref) + call find_eta(CS%h, CS%tv, G, GV, US, z_interface, dZref=G%Z_ref) call register_restart_field(z_interface, "eta", .true., restart_CSp_tmp, & - "Interface heights", "meter", z_grid='i') + "Interface heights", "meter", z_grid='i', conversion=US%Z_to_m) ! NOTE: write_ic=.true. routes routine to fms2 IO write_initial_conditions interface call save_restart(dirs%output_directory, Time, CS%G_in, & restart_CSp_tmp, filename=CS%IC_file, GV=GV, write_ic=.true.) @@ -2993,16 +3808,18 @@ subroutine register_diags(Time, G, GV, US, IDs, diag) v_extensive=.true.) IDs%id_ssh_inst = register_diag_field('ocean_model', 'SSH_inst', diag%axesT1, & Time, 'Instantaneous Sea Surface Height', 'm', conversion=US%Z_to_m) + end subroutine register_diags !> Set up CPU clock IDs for timing various subroutines. subroutine MOM_timing_init(CS) type(MOM_control_struct), intent(in) :: CS !< control structure set up by initialize_MOM. - id_clock_ocean = cpu_clock_id('Ocean', grain=CLOCK_COMPONENT) id_clock_dynamics = cpu_clock_id('Ocean dynamics', grain=CLOCK_SUBCOMPONENT) id_clock_thermo = cpu_clock_id('Ocean thermodynamics and tracers', grain=CLOCK_SUBCOMPONENT) + id_clock_remap = cpu_clock_id('Ocean grid generation and remapping', grain=CLOCK_SUBCOMPONENT) id_clock_other = cpu_clock_id('Ocean Other', grain=CLOCK_SUBCOMPONENT) + id_clock_MOM_end = cpu_clock_id('Ocean MOM_end', grain=CLOCK_SUBCOMPONENT) id_clock_tracer = cpu_clock_id('(Ocean tracer advection)', grain=CLOCK_MODULE_DRIVER) if (.not.CS%adiabatic) then id_clock_diabatic = cpu_clock_id('(Ocean diabatic driver)', grain=CLOCK_MODULE_DRIVER) @@ -3017,6 +3834,8 @@ subroutine MOM_timing_init(CS) id_clock_pass_init = cpu_clock_id('(Ocean init message passing *)', grain=CLOCK_ROUTINE) if (CS%thickness_diffuse) & id_clock_thick_diff = cpu_clock_id('(Ocean thickness diffusion *)', grain=CLOCK_MODULE) + if (CS%interface_filter) & + id_clock_int_filter = cpu_clock_id('(Ocean interface height filter *)', grain=CLOCK_MODULE) !if (CS%mixedlayer_restrat) & id_clock_ml_restrat = cpu_clock_id('(Ocean mixed layer restrat)', grain=CLOCK_MODULE) id_clock_diagnostics = cpu_clock_id('(Ocean collective diagnostics)', grain=CLOCK_MODULE) @@ -3025,6 +3844,10 @@ subroutine MOM_timing_init(CS) if (CS%offline_tracer_mode) then id_clock_offline_tracer = cpu_clock_id('Ocean offline tracers', grain=CLOCK_SUBCOMPONENT) endif + id_clock_stoch = cpu_clock_id('(Stochastic EOS)', grain=CLOCK_MODULE) + id_clock_varT = cpu_clock_id('(SGS Temperature Variance)', grain=CLOCK_MODULE) + + id_clock_save_restart = cpu_clock_id('(Ocean MOM save_restart)', grain=CLOCK_MODULE) end subroutine MOM_timing_init @@ -3052,54 +3875,46 @@ subroutine set_restart_fields(GV, US, param_file, CS, restart_CSp) thickness_units = get_thickness_units(GV) flux_units = get_flux_units(GV) - u_desc = var_desc("u", "m s-1", "Zonal velocity", hor_grid='Cu') - v_desc = var_desc("v", "m s-1", "Meridional velocity", hor_grid='Cv') - if (associated(CS%tv%T)) & call register_restart_field(CS%tv%T, "Temp", .true., restart_CSp, & - "Potential Temperature", "degC") + "Potential Temperature", "degC", conversion=US%C_to_degC) if (associated(CS%tv%S)) & call register_restart_field(CS%tv%S, "Salt", .true., restart_CSp, & - "Salinity", "PPT") + "Salinity", "PPT", conversion=US%S_to_ppt) call register_restart_field(CS%h, "h", .true., restart_CSp, & - "Layer Thickness", thickness_units) + "Layer Thickness", thickness_units, conversion=GV%H_to_MKS) - call register_restart_pair(CS%u, CS%v, u_desc, v_desc, .true., restart_CSp) + u_desc = var_desc("u", "m s-1", "Zonal velocity", hor_grid='Cu') + v_desc = var_desc("v", "m s-1", "Meridional velocity", hor_grid='Cv') + call register_restart_pair(CS%u, CS%v, u_desc, v_desc, .true., restart_CSp, conversion=US%L_T_to_m_s) if (associated(CS%tv%frazil)) & call register_restart_field(CS%tv%frazil, "frazil", .false., restart_CSp, & - "Frazil heat flux into ocean", "J m-2") + "Frazil heat flux into ocean", & + "J m-2", conversion=US%Q_to_J_kg*US%RZ_to_kg_m2) if (CS%interp_p_surf) then call register_restart_field(CS%p_surf_prev, "p_surf_prev", .false., restart_CSp, & - "Previous ocean surface pressure", "Pa") + "Previous ocean surface pressure", "Pa", conversion=US%RL2_T2_to_Pa) endif + if (associated(CS%tv%p_surf)) & + call register_restart_field(CS%tv%p_surf, "p_surf_EOS", .false., restart_CSp, & + "Ocean surface pressure used in EoS", "Pa", conversion=US%RL2_T2_to_Pa) + call register_restart_field(CS%ave_ssh_ibc, "ave_ssh", .false., restart_CSp, & - "Time average sea surface height", "meter") + "Time average sea surface height", "meter", conversion=US%Z_to_m) ! hML is needed when using the ice shelf module call get_param(param_file, '', "ICE_SHELF", use_ice_shelf, default=.false., & do_not_log=.true.) if (use_ice_shelf .and. associated(CS%Hml)) then call register_restart_field(CS%Hml, "hML", .false., restart_CSp, & - "Mixed layer thickness", "meter") + "Mixed layer thickness", "m", conversion=US%Z_to_m) endif ! Register scalar unit conversion factors. - call register_restart_field(US%m_to_Z_restart, "m_to_Z", .false., restart_CSp, & - "Height unit conversion factor", "Z meter-1") - call register_restart_field(GV%m_to_H_restart, "m_to_H", .false., restart_CSp, & - "Thickness unit conversion factor", "H meter-1") - call register_restart_field(US%m_to_L_restart, "m_to_L", .false., restart_CSp, & - "Length unit conversion factor", "L meter-1") - call register_restart_field(US%s_to_T_restart, "s_to_T", .false., restart_CSp, & - "Time unit conversion factor", "T second-1") - call register_restart_field(US%kg_m3_to_R_restart, "kg_m3_to_R", .false., restart_CSp, & - "Density unit conversion factor", "R m3 kg-1") - call register_restart_field(US%J_kg_to_Q_restart, "J_kg_to_Q", .false., restart_CSp, & - "Heat content unit conversion factor.", units="Q kg J-1") call register_restart_field(CS%first_dir_restart, "First_direction", .false., restart_CSp, & "Indicator of the first direction in split calculations.", "nondim") @@ -3171,13 +3986,14 @@ subroutine extract_surface_state(CS, sfc_state_in) !! layer properties [Z ~> m] or [H ~> m or kg m-2] real :: dh !< Thickness of a layer within the mixed layer [Z ~> m] or [H ~> m or kg m-2] real :: mass !< Mass per unit area of a layer [R Z ~> kg m-2] - real :: T_freeze !< freezing temperature [degC] real :: I_depth !< The inverse of depth [Z-1 ~> m-1] or [H-1 ~> m-1 or m2 kg-1] real :: missing_depth !< The portion of depth_ml that can not be found in a column [H ~> m or kg m-2] real :: H_rescale !< A conversion factor from thickness units to the units used in the !! calculation of properties of the uppermost ocean [nondim] or [Z H-1 ~> 1 or m3 kg-1] ! After the ANSWERS_2018 flag has been obsoleted, H_rescale will be 1. - real :: delT(SZI_(CS%G)) !< Depth integral of T-T_freeze [Z degC ~> m degC] + real :: T_freeze(SZI_(CS%G)) !< freezing temperature [C ~> degC] + real :: pres(SZI_(CS%G)) !< Pressure to use for the freezing temperature calculation [R L2 T-2 ~> Pa] + real :: delT(SZI_(CS%G)) !< Depth integral of T-T_freeze [H C ~> m degC or degC kg m-2] logical :: use_temperature !< If true, temperature and salinity are used as state variables. integer :: i, j, k, is, ie, js, je, nz, numberOfErrors, ig, jg integer :: isd, ied, jsd, jed @@ -3191,8 +4007,8 @@ subroutine extract_surface_state(CS, sfc_state_in) G => CS%G ; G_in => CS%G_in ; GV => CS%GV ; US => CS%US 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 - iscB = G%iscB ; iecB = G%iecB; jscB = G%jscB ; jecB = G%jecB - isdB = G%isdB ; iedB = G%iedB; jsdB = G%jsdB ; jedB = G%jedB + iscB = G%iscB ; iecB = G%iecB ; jscB = G%jscB ; jecB = G%jecB + isdB = G%isdB ; iedB = G%iedB ; jsdB = G%jsdB ; jedB = G%jedB h => CS%h use_temperature = associated(CS%tv%T) @@ -3215,8 +4031,8 @@ subroutine extract_surface_state(CS, sfc_state_in) if (CS%rotate_index) then allocate(sfc_state) call allocate_surface_state(sfc_state, G, use_temperature, & - do_integrals=.true., omit_frazil=.not.associated(CS%tv%frazil),& - use_iceshelves=use_iceshelves) + do_integrals=.true., omit_frazil=.not.associated(CS%tv%frazil),& + use_iceshelves=use_iceshelves, sfc_state_in=sfc_state_in, turns=turns) else sfc_state => sfc_state_in endif @@ -3233,11 +4049,9 @@ subroutine extract_surface_state(CS, sfc_state_in) enddo ; enddo ; endif ! copy Hml into sfc_state, so that caps can access it - if (associated(CS%Hml)) then - do j=js,je ; do i=is,ie - sfc_state%Hml(i,j) = CS%Hml(i,j) - enddo ; enddo - endif + do j=js,je ; do i=is,ie + sfc_state%Hml(i,j) = CS%Hml(i,j) + enddo ; enddo if (CS%Hmix < 0.0) then ! A bulk mixed layer is in use, so layer 1 has the properties if (use_temperature) then ; do j=js,je ; do i=is,ie @@ -3252,9 +4066,12 @@ subroutine extract_surface_state(CS, sfc_state_in) enddo ; enddo else ! (CS%Hmix >= 0.0) - H_rescale = 1.0 ; if (CS%answers_2018) H_rescale = GV%H_to_Z + H_rescale = 1.0 depth_ml = CS%Hmix - if (.not.CS%answers_2018) depth_ml = CS%Hmix*GV%Z_to_H + if (CS%answer_date < 20190101) then + H_rescale = GV%H_to_Z + depth_ml = GV%H_to_Z*CS%Hmix + endif ! Determine the mean tracer properties of the uppermost depth_ml fluid. !$OMP parallel do default(shared) private(depth,dh) @@ -3286,7 +4103,7 @@ subroutine extract_surface_state(CS, sfc_state_in) enddo ; enddo ! Calculate the average properties of the mixed layer depth. do i=is,ie - if (CS%answers_2018) then + if (CS%answer_date < 20190101) then if (depth(i) < GV%H_subroundoff*H_rescale) & depth(i) = GV%H_subroundoff*H_rescale if (use_temperature) then @@ -3325,9 +4142,9 @@ subroutine extract_surface_state(CS, sfc_state_in) ! This assumes that u and v halos have already been updated. if (CS%Hmix_UV>0.) then depth_ml = CS%Hmix_UV - if (.not.CS%answers_2018) depth_ml = CS%Hmix_UV*GV%Z_to_H + if (CS%answer_date < 20190101) depth_ml = GV%H_to_Z*CS%Hmix_UV !$OMP parallel do default(shared) private(depth,dh,hv) - do J=js-1,ie + do J=js-1,je do i=is,ie depth(i) = 0.0 sfc_state%v(i,J) = 0.0 @@ -3385,28 +4202,37 @@ subroutine extract_surface_state(CS, sfc_state_in) if (allocated(sfc_state%melt_potential)) then - !$OMP parallel do default(shared) private(depth_ml, dh, T_freeze, depth, delT) + !$OMP parallel do default(shared) private(depth_ml, dh, T_freeze, depth, pres, delT) do j=js,je do i=is,ie depth(i) = 0.0 delT(i) = 0.0 + pres(i) = 0.0 + ! Here it is assumed that p=0 is OK, since HFrz ~ 10 to 20m, but under ice-shelves this + ! can be a very bad assumption. ###To fix this, uncomment the following... + ! pres(i) = p_surface(i) + 0.5*(GV%g_Earth*GV%H_to_RZ)*h(i,j,1) enddo - do k=1,nz ; do i=is,ie - depth_ml = min(CS%HFrz, CS%visc%MLD(i,j)) - if (depth(i) + h(i,j,k)*GV%H_to_Z < depth_ml) then - dh = h(i,j,k)*GV%H_to_Z - elseif (depth(i) < depth_ml) then - dh = depth_ml - depth(i) - else - dh = 0.0 - endif + do k=1,nz + call calculate_TFreeze(CS%tv%S(is:ie,j,k), pres(is:ie), T_freeze(is:ie), CS%tv%eqn_of_state) + do i=is,ie + depth_ml = min(CS%HFrz, CS%visc%h_ML(i,j)) + if (depth(i) + h(i,j,k) < depth_ml) then + dh = h(i,j,k) + elseif (depth(i) < depth_ml) then + dh = depth_ml - depth(i) + else + dh = 0.0 + endif - ! p=0 OK, HFrz ~ 10 to 20m - call calculate_TFreeze(CS%tv%S(i,j,k), 0.0, T_freeze, CS%tv%eqn_of_state) - depth(i) = depth(i) + dh - delT(i) = delT(i) + dh * (CS%tv%T(i,j,k) - T_freeze) - enddo ; enddo + depth(i) = depth(i) + dh + delT(i) = delT(i) + dh * (CS%tv%T(i,j,k) - T_freeze(i)) + enddo + ! If there is a pressure-dependent freezing point calculation uncomment the following. + ! if (k0.) then ! instantaneous melt_potential [Q R Z ~> J m-2] - sfc_state%melt_potential(i,j) = CS%tv%C_p * GV%Rho0 * delT(i) + sfc_state%melt_potential(i,j) = CS%tv%C_p * GV%H_to_RZ * delT(i) endif enddo enddo ! end of j loop endif ! melt_potential - if (allocated(sfc_state%salt_deficit) .and. associated(CS%tv%salt_deficit)) then - !$OMP parallel do default(shared) - do j=js,je ; do i=is,ie - ! Convert from gSalt to kgSalt - sfc_state%salt_deficit(i,j) = 0.001 * CS%tv%salt_deficit(i,j) - enddo ; enddo - endif - if (allocated(sfc_state%TempxPmE) .and. associated(CS%tv%TempxPmE)) then - !$OMP parallel do default(shared) - do j=js,je ; do i=is,ie - sfc_state%TempxPmE(i,j) = CS%tv%TempxPmE(i,j) - enddo ; enddo - endif - if (allocated(sfc_state%internal_heat) .and. associated(CS%tv%internal_heat)) then - !$OMP parallel do default(shared) - do j=js,je ; do i=is,ie - sfc_state%internal_heat(i,j) = CS%tv%internal_heat(i,j) - enddo ; enddo - endif - if (allocated(sfc_state%taux_shelf) .and. associated(CS%visc%taux_shelf)) then + if (allocated(sfc_state%taux_shelf) .and. allocated(CS%visc%taux_shelf)) then !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie sfc_state%taux_shelf(I,j) = CS%visc%taux_shelf(I,j) enddo ; enddo endif - if (allocated(sfc_state%tauy_shelf) .and. associated(CS%visc%tauy_shelf)) then + if (allocated(sfc_state%tauy_shelf) .and. allocated(CS%visc%tauy_shelf)) then !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie sfc_state%tauy_shelf(i,J) = CS%visc%tauy_shelf(i,J) @@ -3481,7 +4288,7 @@ subroutine extract_surface_state(CS, sfc_state_in) !$OMP parallel do default(shared) private(mass) do j=js,je ; do k=1,nz ; do i=is,ie mass = GV%H_to_RZ*h(i,j,k) - sfc_state%ocean_heat(i,j) = sfc_state%ocean_heat(i,j) + mass*CS%tv%T(i,j,k) + sfc_state%ocean_heat(i,j) = sfc_state%ocean_heat(i,j) + mass * CS%tv%T(i,j,k) enddo ; enddo ; enddo endif if (allocated(sfc_state%ocean_salt)) then @@ -3496,16 +4303,16 @@ subroutine extract_surface_state(CS, sfc_state_in) endif if (associated(CS%tracer_flow_CSp)) then - call call_tracer_surface_state(sfc_state, h, G, GV, CS%tracer_flow_CSp) + call call_tracer_surface_state(sfc_state, h, G, GV, US, CS%tracer_flow_CSp) endif if (CS%check_bad_sfc_vals) then numberOfErrors=0 ! count number of errors do j=js,je ; do i=is,ie if (G%mask2dT(i,j)>0.) then - localError = sfc_state%sea_lev(i,j) <= -G%bathyT(i,j) - G%Z_ref & - .or. sfc_state%sea_lev(i,j) >= CS%bad_val_ssh_max & - .or. sfc_state%sea_lev(i,j) <= -CS%bad_val_ssh_max & + localError = sfc_state%sea_lev(i,j) < -G%bathyT(i,j) - G%Z_ref & + .or. sfc_state%sea_lev(i,j) >= CS%bad_val_ssh_max + (G%meanSL(i,j) - G%Z_ref) & + .or. sfc_state%sea_lev(i,j) <= -CS%bad_val_ssh_max + (G%meanSL(i,j) - G%Z_ref) & .or. sfc_state%sea_lev(i,j) + G%bathyT(i,j) + G%Z_ref < CS%bad_val_col_thick if (use_temperature) localError = localError & .or. sfc_state%SSS(i,j)<0. & @@ -3518,20 +4325,20 @@ subroutine extract_surface_state(CS, sfc_state_in) ig = i + G%HI%idg_offset ! Global i-index jg = j + G%HI%jdg_offset ! Global j-index if (use_temperature) then - write(msg(1:240),'(2(a,i4,x),4(a,f8.3,x),8(a,es11.4,x))') & + write(msg(1:240),'(2(a,I0,1x),4(a,f8.3,1x),8(a,es11.4,1x))') & 'Extreme surface sfc_state detected: i=',ig,'j=',jg, & 'lon=',G%geoLonT(i,j), 'lat=',G%geoLatT(i,j), & 'x=',G%gridLonT(ig), 'y=',G%gridLatT(jg), & - 'D=',US%Z_to_m*(G%bathyT(i,j)+G%Z_ref), 'SSH=',US%Z_to_m*sfc_state%sea_lev(i,j), & - 'SST=',sfc_state%SST(i,j), 'SSS=',sfc_state%SSS(i,j), & + 'D=',US%Z_to_m*(G%bathyT(i,j)+G%Z_ref), 'SSH=',US%Z_to_m*sfc_state%sea_lev(i,j), & + 'SST=',US%C_to_degC*sfc_state%SST(i,j), 'SSS=',US%S_to_ppt*sfc_state%SSS(i,j), & 'U-=',US%L_T_to_m_s*sfc_state%u(I-1,j), 'U+=',US%L_T_to_m_s*sfc_state%u(I,j), & 'V-=',US%L_T_to_m_s*sfc_state%v(i,J-1), 'V+=',US%L_T_to_m_s*sfc_state%v(i,J) else - write(msg(1:240),'(2(a,i4,x),4(a,f8.3,x),6(a,es11.4))') & + write(msg(1:240),'(2(a,I0,1x),4(a,f8.3,1x),6(a,es11.4))') & 'Extreme surface sfc_state detected: i=',ig,'j=',jg, & 'lon=',G%geoLonT(i,j), 'lat=',G%geoLatT(i,j), & - 'x=',G%gridLonT(i), 'y=',G%gridLatT(j), & - 'D=',US%Z_to_m*(G%bathyT(i,j)+G%Z_ref), 'SSH=',US%Z_to_m*sfc_state%sea_lev(i,j), & + 'x=',G%gridLonT(ig), 'y=',G%gridLatT(jg), & + 'D=',US%Z_to_m*(G%bathyT(i,j)+G%Z_ref), 'SSH=',US%Z_to_m*sfc_state%sea_lev(i,j), & 'U-=',US%L_T_to_m_s*sfc_state%u(I-1,j), 'U+=',US%L_T_to_m_s*sfc_state%u(I,j), & 'V-=',US%L_T_to_m_s*sfc_state%v(i,J-1), 'V+=',US%L_T_to_m_s*sfc_state%v(i,J) endif @@ -3544,17 +4351,17 @@ subroutine extract_surface_state(CS, sfc_state_in) enddo ; enddo call sum_across_PEs(numberOfErrors) if (numberOfErrors>0) then - write(msg(1:240),'(3(a,i9,x))') 'There were a total of ',numberOfErrors, & - 'locations detected with extreme surface values!' + write(msg(1:240),'(a,i0,a)') 'There were a total of ',numberOfErrors, & + ' locations detected with extreme surface values!' call MOM_error(FATAL, trim(msg)) endif endif - if (CS%debug) call MOM_surface_chksum("Post extract_sfc", sfc_state, G, US, haloshift=0) + if (CS%debug) call MOM_surface_chksum("Post extract_sfc", sfc_state, G, US, haloshift=0, symmetric=.true.) ! Rotate sfc_state back onto the input grid, sfc_state_in if (CS%rotate_index) then - call rotate_surface_state(sfc_state, G, sfc_state_in, G_in, -turns) + call rotate_surface_state(sfc_state, sfc_state_in, G_in, -turns) call deallocate_surface_state(sfc_state) endif @@ -3567,15 +4374,15 @@ subroutine rotate_initial_state(u_in, v_in, h_in, T_in, S_in, & real, dimension(:,:,:), intent(in) :: u_in !< Zonal velocity on the initial grid [L T-1 ~> m s-1] real, dimension(:,:,:), intent(in) :: v_in !< Meridional velocity on the initial grid [L T-1 ~> m s-1] real, dimension(:,:,:), intent(in) :: h_in !< Layer thickness on the initial grid [H ~> m or kg m-2] - real, dimension(:,:,:), intent(in) :: T_in !< Temperature on the initial grid [degC] - real, dimension(:,:,:), intent(in) :: S_in !< Salinity on the initial grid [ppt] + real, dimension(:,:,:), intent(in) :: T_in !< Temperature on the initial grid [C ~> degC] + real, dimension(:,:,:), intent(in) :: S_in !< Salinity on the initial grid [S ~> ppt] logical, intent(in) :: use_temperature !< If true, temperature and salinity are active integer, intent(in) :: turns !< The number quarter-turns to apply real, dimension(:,:,:), intent(out) :: u !< Zonal velocity on the rotated grid [L T-1 ~> m s-1] real, dimension(:,:,:), intent(out) :: v !< Meridional velocity on the rotated grid [L T-1 ~> m s-1] real, dimension(:,:,:), intent(out) :: h !< Layer thickness on the rotated grid [H ~> m or kg m-2] - real, dimension(:,:,:), intent(out) :: T !< Temperature on the rotated grid [degC] - real, dimension(:,:,:), intent(out) :: S !< Salinity on the rotated grid [ppt] + real, dimension(:,:,:), intent(out) :: T !< Temperature on the rotated grid [C ~> degC] + real, dimension(:,:,:), intent(out) :: S !< Salinity on the rotated grid [S ~> ppt] call rotate_vector(u_in, v_in, turns, u, v) call rotate_array(h_in, turns, h) @@ -3614,13 +4421,13 @@ subroutine get_MOM_state_elements(CS, G, GV, US, C_p, C_p_scaled, use_temp) type(unit_scale_type), optional, pointer :: US !< A dimensional unit scaling type real, optional, intent(out) :: C_p !< The heat capacity [J kg degC-1] real, optional, intent(out) :: C_p_scaled !< The heat capacity in scaled - !! units [Q degC-1 ~> J kg-1 degC-1] + !! units [Q C-1 ~> J kg-1 degC-1] logical, optional, intent(out) :: use_temp !< True if temperature is a state variable if (present(G)) G => CS%G_in if (present(GV)) GV => CS%GV if (present(US)) US => CS%US - if (present(C_p)) C_p = CS%US%Q_to_J_kg * CS%tv%C_p + if (present(C_p)) C_p = CS%US%Q_to_J_kg*US%degC_to_C * CS%tv%C_p if (present(C_p_scaled)) C_p_scaled = CS%tv%C_p if (present(use_temp)) use_temp = associated(CS%tv%T) end subroutine get_MOM_state_elements @@ -3636,27 +4443,64 @@ subroutine get_ocean_stocks(CS, mass, heat, salt, on_PE_only) if (present(mass)) & mass = global_mass_integral(CS%h, CS%G, CS%GV, on_PE_only=on_PE_only) if (present(heat)) & - heat = CS%US%Q_to_J_kg*CS%tv%C_p * global_mass_integral(CS%h, CS%G, CS%GV, CS%tv%T, on_PE_only=on_PE_only) + heat = CS%US%Q_to_J_kg*CS%US%RZL2_to_kg * CS%tv%C_p * & + global_mass_integral(CS%h, CS%G, CS%GV, CS%tv%T, on_PE_only=on_PE_only, tmp_scale=CS%US%C_to_degC) if (present(salt)) & - salt = 1.0e-3 * global_mass_integral(CS%h, CS%G, CS%GV, CS%tv%S, on_PE_only=on_PE_only) + salt = 1.0e-3 * global_mass_integral(CS%h, CS%G, CS%GV, CS%tv%S, on_PE_only=on_PE_only, unscale=CS%US%S_to_ppt) end subroutine get_ocean_stocks + +!> Save restart/pickup files required to initialize the MOM6 internal state. +subroutine save_MOM_restart(CS, directory, time, G, time_stamped, filename, & + GV, num_rest_files, write_IC) + type(MOM_control_struct), intent(inout) :: CS + !< MOM control structure + character(len=*), intent(in) :: directory + !< The directory where the restart files are to be written + type(time_type), intent(in) :: time + !< The current model time + type(ocean_grid_type), intent(inout) :: G + !< The ocean's grid structure + logical, optional, intent(in) :: time_stamped + !< If present and true, add time-stamp to the restart file names + character(len=*), optional, intent(in) :: filename + !< A filename that overrides the name in CS%restartfile + type(verticalGrid_type), optional, intent(in) :: GV + !< The ocean's vertical grid structure + integer, optional, intent(out) :: num_rest_files + !< number of restart files written + logical, optional, intent(in) :: write_IC + !< If present and true, initial conditions are being written + + logical :: showCallTree + showCallTree = callTree_showQuery() + + call cpu_clock_begin(id_clock_ocean) ; call cpu_clock_begin(id_clock_save_restart) + if (showCallTree) call callTree_waypoint("About to call save_restart (step_MOM)") + call save_restart(directory, time, G, CS%restart_CS, & + time_stamped=time_stamped, filename=filename, GV=GV, & + num_rest_files=num_rest_files, write_IC=write_IC) + if (showCallTree) call callTree_waypoint("Done with call to save_restart (step_MOM)") + + if (CS%use_particles) call particles_save_restart(CS%particles, CS%h, directory, time, time_stamped) + call cpu_clock_end(id_clock_save_restart) ; call cpu_clock_end(id_clock_ocean) +end subroutine save_MOM_restart + + !> End of ocean model, including memory deallocation subroutine MOM_end(CS) type(MOM_control_struct), intent(inout) :: CS !< MOM control structure - if (CS%use_particles) then - call particles_save_restart(CS%particles) - endif + call cpu_clock_begin(id_clock_ocean) ; call cpu_clock_begin(id_clock_MOM_end) call MOM_sum_output_end(CS%sum_output_CSp) if (CS%use_ALE_algorithm) call ALE_end(CS%ALE_CSp) !deallocate porous topography variables - DEALLOC_(CS%por_face_areaU) ; DEALLOC_(CS%por_face_areaV) - DEALLOC_(CS%por_layer_widthU) ; DEALLOC_(CS%por_layer_widthV) + deallocate(CS%pbv%por_face_areaU) ; deallocate(CS%pbv%por_face_areaV) + deallocate(CS%pbv%por_layer_widthU) ; deallocate(CS%pbv%por_layer_widthV) ! NOTE: Allocated in PressureForce_FV_Bouss if (associated(CS%tv%varT)) deallocate(CS%tv%varT) @@ -3675,7 +4519,9 @@ subroutine MOM_end(CS) if (CS%offline_tracer_mode) call offline_transport_end(CS%offline_CSp) - if (CS%split) then + if (CS%split .and. CS%use_alt_split) then + call end_dyn_split_RK2b(CS%dyn_split_RK2b_CSp) + elseif (CS%split) then call end_dyn_split_RK2(CS%dyn_split_RK2_CSp) elseif (CS%use_RK2) then call end_dyn_unsplit_RK2(CS%dyn_unsplit_RK2_CSp) @@ -3684,11 +4530,12 @@ subroutine MOM_end(CS) endif if (CS%use_particles) then - call particles_end(CS%particles) - deallocate(CS%particles) + call particles_end(CS%particles, CS%h) + deallocate(CS%particles) endif call thickness_diffuse_end(CS%thickness_diffuse_CSp, CS%CDp) + if (CS%interface_filter) call interface_filter_end(CS%interface_filter_CSp, CS%CDp) call VarMix_end(CS%VarMix) call set_visc_end(CS%visc, CS%set_visc_CSp) call MEKE_end(CS%MEKE) @@ -3696,7 +4543,7 @@ subroutine MOM_end(CS) if (associated(CS%tv%internal_heat)) deallocate(CS%tv%internal_heat) if (associated(CS%tv%TempxPmE)) deallocate(CS%tv%TempxPmE) - DEALLOC_(CS%ave_ssh_ibc) ; DEALLOC_(CS%ssh_rint) + DEALLOC_(CS%ave_ssh_ibc) ; DEALLOC_(CS%ssh_rint) ; DEALLOC_(CS%eta_av_bc) ! TODO: debug_truncations deallocation @@ -3705,6 +4552,7 @@ subroutine MOM_end(CS) if (associated(CS%Hml)) deallocate(CS%Hml) if (associated(CS%tv%salt_deficit)) deallocate(CS%tv%salt_deficit) if (associated(CS%tv%frazil)) deallocate(CS%tv%frazil) + if (allocated(CS%tv%SpV_avg)) deallocate(CS%tv%SpV_avg) if (associated(CS%tv%T)) then DEALLOC_(CS%T) ; CS%tv%T => NULL() ; DEALLOC_(CS%S) ; CS%tv%S => NULL() @@ -3714,6 +4562,7 @@ subroutine MOM_end(CS) DEALLOC_(CS%uh) ; DEALLOC_(CS%vh) if (associated(CS%update_OBC_CSp)) call OBC_register_end(CS%update_OBC_CSp) + if (associated(CS%OBC)) call open_boundary_end(CS%OBC) call verticalGridEnd(CS%GV) call MOM_grid_end(CS%G) @@ -3729,6 +4578,9 @@ subroutine MOM_end(CS) call deallocate_MOM_domain(CS%G_in%domain, cursory=.true.) call unit_scaling_end(CS%US) + + call cpu_clock_end(id_clock_MOM_end) ; call cpu_clock_end(id_clock_ocean) + end subroutine MOM_end !> \namespace mom diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index 953d64c1f0..5004108a83 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -1,25 +1,32 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Accelerations due to the Coriolis force and momentum advection module MOM_CoriolisAdv -! This file is part of MOM6. See LICENSE.md for the license. - !> \author Robert Hallberg, April 1994 - June 2002 use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl +use MOM_diag_mediator, only : post_product_u, post_product_sum_u +use MOM_diag_mediator, only : post_product_v, post_product_sum_v use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, time_type use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_open_boundary, only : ocean_OBC_type, OBC_DIRECTION_E, OBC_DIRECTION_W use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S +use MOM_open_boundary, only : OBC_VORTICITY_ZERO, OBC_VORTICITY_FREESLIP +use MOM_open_boundary, only : OBC_VORTICITY_COMPUTED, OBC_VORTICITY_SPECIFIED use MOM_string_functions, only : uppercase use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : accel_diag_ptrs, porous_barrier_ptrs +use MOM_variables, only : accel_diag_ptrs, porous_barrier_type use MOM_verticalGrid, only : verticalGrid_type +use MOM_wave_interface, only : wave_parameters_CS implicit none ; private -public CorAdCalc, CoriolisAdv_init, CoriolisAdv_end +public CorAdCalc, CoriolisAdv_init, CoriolisAdv_end, CoriolisAdv_stencil #include @@ -34,11 +41,15 @@ module MOM_CoriolisAdv !! - SADOURNY75_ENSTRO - Sadourny, JAS 1975, Enstrophy !! - ARAKAWA_LAMB81 - Arakawa & Lamb, MWR 1981, Energy & Enstrophy !! - ARAKAWA_LAMB_BLEND - A blend of Arakawa & Lamb with Arakawa & Hsu and Sadourny energy. + !! - WENOVI3RD_PV_ENSTRO - 3rd-order WENO scheme for PV reconstruction + !! - WENOVI5TH_PV_ENSTRO - 5th-order WENO scheme for PV reconstruction + !! - WENOVI7TH_PV_ENSTRO - 7th-order WENO scheme for PV reconstruction !! The default, SADOURNY75_ENERGY, is the safest choice then the !! deformation radius is poorly resolved. integer :: KE_Scheme !< KE_SCHEME selects the discretization for !! the kinetic energy. Valid values are: !! KE_ARAKAWA, KE_SIMPLE_GUDONOV, KE_GUDONOV + logical :: KE_use_limiter !< If true, use the Koren limiter for KE_UP3 scheme integer :: PV_Adv_Scheme !< PV_ADV_SCHEME selects the discretization for PV advection !! Valid values are: !! - PV_ADV_CENTERED - centered (aka Sadourny, 75) @@ -46,10 +57,10 @@ module MOM_CoriolisAdv real :: F_eff_max_blend !< The factor by which the maximum effective Coriolis !! acceleration from any point can be increased when !! blending different discretizations with the - !! ARAKAWA_LAMB_BLEND Coriolis scheme. This must be - !! greater than 2.0, and is 4.0 by default. + !! ARAKAWA_LAMB_BLEND Coriolis scheme [nondim]. + !! This must be greater than 2.0, and is 4.0 by default. real :: wt_lin_blend !< A weighting value beyond which the blending between - !! Sadourny and Arakawa & Hsu goes linearly to 0. + !! Sadourny and Arakawa & Hsu goes linearly to 0 [nondim]. !! This must be between 1 and 1e-15, often 1/8. logical :: no_slip !< If true, no slip boundary conditions are used. !! Otherwise free slip boundary conditions are assumed. @@ -70,6 +81,7 @@ module MOM_CoriolisAdv !! relative to the other one is used. This is only !! available at present if Coriolis scheme is !! SADOURNY75_ENERGY. + logical :: weno_velocity_smooth !< If true, use velocity to compute the smoothness indicator for WENO type(time_type), pointer :: Time !< A pointer to the ocean model's clock. type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the timing of diagnostic output. !>@{ Diagnostic IDs @@ -83,6 +95,7 @@ module MOM_CoriolisAdv integer :: id_h_gKEu = -1, id_h_gKEv = -1 integer :: id_h_rvxu = -1, id_h_rvxv = -1 integer :: id_intz_rvxu_2d = -1, id_intz_rvxv_2d = -1 + integer :: id_CAuS = -1, id_CAvS = -1 !>@} end type CoriolisAdv_CS @@ -93,20 +106,28 @@ module MOM_CoriolisAdv integer, parameter :: SADOURNY75_ENSTRO = 4 integer, parameter :: ARAKAWA_LAMB81 = 5 integer, parameter :: AL_BLEND = 6 +integer, parameter :: wenovi7th_PV_ENSTRO = 7 +integer, parameter :: wenovi5th_PV_ENSTRO = 8 +integer, parameter :: wenovi3rd_PV_ENSTRO = 9 character*(20), parameter :: SADOURNY75_ENERGY_STRING = "SADOURNY75_ENERGY" character*(20), parameter :: ARAKAWA_HSU_STRING = "ARAKAWA_HSU90" character*(20), parameter :: ROBUST_ENSTRO_STRING = "ROBUST_ENSTRO" character*(20), parameter :: SADOURNY75_ENSTRO_STRING = "SADOURNY75_ENSTRO" character*(20), parameter :: ARAKAWA_LAMB_STRING = "ARAKAWA_LAMB81" character*(20), parameter :: AL_BLEND_STRING = "ARAKAWA_LAMB_BLEND" +character*(20), parameter :: WENOVI7TH_PV_ENSTRO_STRING = "WENOVI7TH_PV_ENSTRO" +character*(20), parameter :: WENOVI5TH_PV_ENSTRO_STRING = "WENOVI5TH_PV_ENSTRO" +character*(20), parameter :: WENOVI3RD_PV_ENSTRO_STRING = "WENOVI3RD_PV_ENSTRO" !>@} !>@{ Enumeration values for KE_Scheme integer, parameter :: KE_ARAKAWA = 10 integer, parameter :: KE_SIMPLE_GUDONOV = 11 integer, parameter :: KE_GUDONOV = 12 +integer, parameter :: KE_UP3 = 13 character*(20), parameter :: KE_ARAKAWA_STRING = "KE_ARAKAWA" character*(20), parameter :: KE_SIMPLE_GUDONOV_STRING = "KE_SIMPLE_GUDONOV" character*(20), parameter :: KE_GUDONOV_STRING = "KE_GUDONOV" +character*(20), parameter :: KE_UP3_STRING = "KE_UP3" !>@} !>@{ Enumeration values for PV_Adv_Scheme integer, parameter :: PV_ADV_CENTERED = 21 @@ -118,8 +139,8 @@ module MOM_CoriolisAdv contains !> Calculates the Coriolis and momentum advection contributions to the acceleration. -subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) - type(ocean_grid_type), intent(in) :: G !< Ocen grid structure +subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Waves) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] @@ -136,12 +157,15 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) type(accel_diag_ptrs), intent(inout) :: AD !< Storage for acceleration diagnostics type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(CoriolisAdv_CS), intent(in) :: CS !< Control structure for MOM_CoriolisAdv - type(porous_barrier_ptrs), intent(in) :: pbv !< porous barrier fractional cell metrics + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + type(Wave_parameters_CS), optional, pointer :: Waves !< An optional pointer to Stokes drift CS ! Local variables real, dimension(SZIB_(G),SZJB_(G)) :: & q, & ! Layer potential vorticity [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]. + qS, & ! Layer Stokes vorticity [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]. Ih_q, & ! The inverse of thickness interpolated to q points [H-1 ~> m-1 or m2 kg-1]. + h_q, & ! The thickness interpolated to q points [H-1 ~> m-1 or m2 kg-1]. Area_q ! The sum of the ocean areas at the 4 adjacent thickness points [L2 ~> m2]. real, dimension(SZIB_(G),SZJ_(G)) :: & @@ -167,38 +191,38 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) ! KEy = d/dy KE. vh_center ! Transport based on arithmetic mean h at v-points [H L2 T-1 ~> m3 s-1 or kg s-1] real, dimension(SZI_(G),SZJ_(G)) :: & - uh_min, uh_max, & ! The smallest and largest estimates of the volume - vh_min, vh_max, & ! fluxes through the faces (i.e. u*h*dy & v*h*dx) - ! [H L2 T-1 ~> m3 s-1 or kg s-1]. + uh_min, uh_max, & ! The smallest and largest estimates of the zonal volume fluxes through + ! the faces (i.e. u*h*dy) [H L2 T-1 ~> m3 s-1 or kg s-1] + vh_min, vh_max, & ! The smallest and largest estimates of the meridional volume fluxes through + ! the faces (i.e. v*h*dx) [H L2 T-1 ~> m3 s-1 or kg s-1] ep_u, ep_v ! Additional pseudo-Coriolis terms in the Arakawa and Lamb ! discretization [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]. real, dimension(SZIB_(G),SZJB_(G)) :: & dvdx, dudy, & ! Contributions to the circulation around q-points [L2 T-1 ~> m2 s-1] + dvSdx, duSdy, & ! idem. for Stokes drift [L2 T-1 ~> m2 s-1] rel_vort, & ! Relative vorticity at q-points [T-1 ~> s-1]. abs_vort, & ! Absolute vorticity at q-points [T-1 ~> s-1]. - q2, & ! Relative vorticity over thickness [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]. - max_fvq, & ! The maximum of the adjacent values of (-u) times absolute vorticity [L T-2 ~> m s-2]. - min_fvq, & ! The minimum of the adjacent values of (-u) times absolute vorticity [L T-2 ~> m s-2]. - max_fuq, & ! The maximum of the adjacent values of u times absolute vorticity [L T-2 ~> m s-2]. - min_fuq ! The minimum of the adjacent values of u times absolute vorticity [L T-2 ~> m s-2]. + stk_vort, & ! Stokes vorticity at q-points [T-1 ~> s-1]. + q2 ! Relative vorticity over thickness [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]. real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)) :: & PV, & ! A diagnostic array of the potential vorticities [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]. RV ! A diagnostic array of the relative vorticities [T-1 ~> s-1]. - real :: fv1, fv2, fv3, fv4 ! (f+rv)*v [L T-2 ~> m s-2]. - real :: fu1, fu2, fu3, fu4 ! -(f+rv)*u [L T-2 ~> m s-2]. - real :: max_fv, max_fu ! The maximum or minimum of the neighboring Coriolis - real :: min_fv, min_fu ! accelerations [L T-2 ~> m s-2], i.e. max(min)_fu(v)q. - - real, parameter :: C1_12=1.0/12.0 ! C1_12 = 1/12 - real, parameter :: C1_24=1.0/24.0 ! C1_24 = 1/24 - real :: absolute_vorticity ! Absolute vorticity [T-1 ~> s-1]. - real :: relative_vorticity ! Relative vorticity [T-1 ~> s-1]. - real :: Ih ! Inverse of thickness [H-1 ~> m-1 or m2 kg-1]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: CAuS ! Stokes contribution to CAu [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: CAvS ! Stokes contribution to CAv [L T-2 ~> m s-2] + real :: fv1, fv2, fv3, fv4 ! (f+rv)*v at the 4 points surrounding a u points[L T-2 ~> m s-2] + real :: fu1, fu2, fu3, fu4 ! -(f+rv)*u at the 4 points surrounding a v point [L T-2 ~> m s-2] + real :: max_fv, max_fu ! The maximum of the neighboring Coriolis accelerations [L T-2 ~> m s-2] + real :: min_fv, min_fu ! The minimum of the neighboring Coriolis accelerations [L T-2 ~> m s-2] + + real, parameter :: C1_12 = 1.0 / 12.0 ! C1_12 = 1/12 [nondim] + real, parameter :: C1_24 = 1.0 / 24.0 ! C1_24 = 1/24 [nondim] real :: max_Ihq, min_Ihq ! The maximum and minimum of the nearby Ihq [H-1 ~> m-1 or m2 kg-1]. real :: hArea_q ! The sum of area times thickness of the cells ! surrounding a q point [H L2 ~> m3 or kg]. real :: vol_neglect ! A volume so small that is expected to be ! lost in roundoff [H L2 ~> m3 or kg]. + real :: area_neglect ! An area so small that is expected to be + ! lost in roundoff [L2 ~> m2]. real :: temp1, temp2 ! Temporary variables [L2 T-2 ~> m2 s-2]. real :: eps_vel ! A tiny, positive velocity [L T-1 ~> m s-1]. @@ -222,25 +246,18 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) real :: UHeff, VHeff ! More temporary variables [H L2 T-1 ~> m3 s-1 or kg s-1]. real :: QUHeff,QVHeff ! More temporary variables [H L2 T-2 ~> m3 s-2 or kg s-2]. integer :: i, j, k, n, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - -! Diagnostics for fractional thickness-weighted terms - real, allocatable, dimension(:,:) :: & - hf_gKEu_2d, hf_gKEv_2d, & ! Depth sum of hf_gKEu, hf_gKEv [L T-2 ~> m s-2]. - hf_rvxu_2d, hf_rvxv_2d ! Depth sum of hf_rvxu, hf_rvxv [L T-2 ~> m s-2]. - - !real, allocatable, dimension(:,:,:) :: & - ! hf_gKEu, hf_gKEv, & ! accel. due to KE gradient x fract. thickness [L T-2 ~> m s-2]. - ! hf_rvxu, hf_rvxv ! accel. due to RV x fract. thickness [L T-2 ~> m s-2]. - ! 3D diagnostics hf_gKEu etc. are commented because there is no clarity on proper remapping grid option. - ! The code is retained for debugging purposes in the future. - -! Diagnostics for thickness multiplied momentum budget terms - real, allocatable, dimension(:,:,:) :: h_gKEu, h_gKEv ! h x gKEu, h x gKEv [H L T-2 ~> m2 s-2]. - real, allocatable, dimension(:,:,:) :: h_rvxv, h_rvxu ! h x rvxv, h x rvxu [H L T-2 ~> m2 s-2]. - -! Diagnostics for depth-integrated momentum budget terms - real, dimension(SZIB_(G),SZJ_(G)) :: intz_gKEu_2d, intz_rvxv_2d ! [H L T-2 ~> m2 s-2]. - real, dimension(SZI_(G),SZJB_(G)) :: intz_gKEv_2d, intz_rvxu_2d ! [H L T-2 ~> m2 s-2]. + integer :: Is_q, Ie_q, Js_q, Je_q ! The scheme-dependent range of values at which vorticity is set. + logical :: Stokes_VF + real :: u_v, v_u ! u_v is the u velocity at v point, v_u is the v velocity at u point [L T-1 ~> m s-1] + real :: q_v, q_u ! PV at the u and v points [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1] + integer :: seventh_order, fifth_order, third_order ! Order of accuracy for the WENO calculations + real :: u_q8(8) ! Eight-point zonal velocity at WENO stencils [L T-1 ~> m s-1] + real :: u_q6(6) ! Six-point zonal velocity at WENO stencils [L T-1 ~> m s-1] + real :: u_q4(4) ! Four-point zonal velocity at WENO stencils [L T-1 ~> m s-1] + real :: v_q8(8) ! Eight-point meridional velocity at WENO stencils [L T-1 ~> m s-1] + real :: v_q6(6) ! Six-point meridional velocity at WENO stencils [L T-1 ~> m s-1] + real :: v_q4(4) ! Four-point meridional velocity at WENO stencils [L T-1 ~> m s-1] + integer :: stencil ! Stencil size of WENO scheme ! To work, the following fields must be set outside of the usual ! is to ie range before this subroutine is called: @@ -253,26 +270,36 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke vol_neglect = GV%H_subroundoff * (1e-4 * US%m_to_L)**2 + area_neglect = (1e-4 * US%m_to_L)**2 eps_vel = 1.0e-10*US%m_s_to_L_T h_tiny = GV%Angstrom_H ! Perhaps this should be set to h_neglect instead. - !$OMP parallel do default(private) shared(Isq,Ieq,Jsq,Jeq,G,Area_h) - do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+2 + stencil = CoriolisAdv_stencil(CS) + + if ((CS%Coriolis_Scheme == wenovi7th_PV_ENSTRO) .or. (CS%Coriolis_Scheme == wenovi5th_PV_ENSTRO) .or. & + (CS%Coriolis_Scheme == wenovi3rd_PV_ENSTRO)) then + Is_q = is - stencil ; Ie_q = ie + stencil - 1 ; Js_q = js - stencil ; Je_q = je + stencil - 1 + else + Is_q = G%IscB - 1 ; Ie_q = G%IecB + 1 ; Js_q = G%JscB - 1 ; Je_q = G%JecB + 1 + endif + + !$OMP parallel do default(private) shared(Is_q,Ie_q,Js_q,Je_q,G,Area_h) + do j=Js_q,Je_q+1 ; do I=Is_q,Ie_q+1 Area_h(i,j) = G%mask2dT(i,j) * G%areaT(i,j) enddo ; enddo if (associated(OBC)) then ; do n=1,OBC%number_of_segments if (.not. OBC%segment(n)%on_pe) cycle I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB - if (OBC%segment(n)%is_N_or_S .and. (J >= Jsq-1) .and. (J <= Jeq+1)) then - do i = max(Isq-1,OBC%segment(n)%HI%isd), min(Ieq+2,OBC%segment(n)%HI%ied) + if (OBC%segment(n)%is_N_or_S .and. (J >= Js_q) .and. (J <= Je_q)) then + do i = max(Is_q,OBC%segment(n)%HI%isd), min(Ie_q+1,OBC%segment(n)%HI%ied) if (OBC%segment(n)%direction == OBC_DIRECTION_N) then Area_h(i,j+1) = Area_h(i,j) else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) Area_h(i,j) = Area_h(i,j+1) endif enddo - elseif (OBC%segment(n)%is_E_or_W .and. (I >= Isq-1) .and. (I <= Ieq+1)) then - do j = max(Jsq-1,OBC%segment(n)%HI%jsd), min(Jeq+2,OBC%segment(n)%HI%jed) + elseif (OBC%segment(n)%is_E_or_W .and. (I >= Is_q) .and. (I <= Ie_q)) then + do j = max(Js_q,OBC%segment(n)%HI%jsd), min(Je_q+1,OBC%segment(n)%HI%jed) if (OBC%segment(n)%direction == OBC_DIRECTION_E) then Area_h(i+1,j) = Area_h(i,j) else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) @@ -281,15 +308,20 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) enddo endif enddo ; endif - !$OMP parallel do default(private) shared(Isq,Ieq,Jsq,Jeq,G,Area_h,Area_q) - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + !$OMP parallel do default(private) shared(Is_q,Ie_q,Js_q,Je_q,G,Area_h,Area_q) + do J=Js_q,Je_q ; do I=Is_q,Ie_q Area_q(i,j) = (Area_h(i,j) + Area_h(i+1,j+1)) + & (Area_h(i+1,j) + Area_h(i,j+1)) enddo ; enddo + Stokes_VF = .false. + if (present(Waves)) then ; if (associated(Waves)) then + Stokes_VF = Waves%Stokes_VF + endif ; endif + !$OMP parallel do default(private) shared(u,v,h,uh,vh,CAu,CAv,G,GV,CS,AD,Area_h,Area_q,& - !$OMP RV,PV,is,ie,js,je,Isq,Ieq,Jsq,Jeq,nz,vol_neglect,h_tiny,OBC,eps_vel, & - !$OMP pbv) + !$OMP RV,PV,is,ie,js,je,Isq,Ieq,Jsq,Jeq,Is_q,Ie_q,Js_q,Je_q,nz,vol_neglect,& + !$OMP h_tiny,OBC,eps_vel,area_neglect,pbv,Stokes_VF,stencil) do k=1,nz ! Here the second order accurate layer potential vorticities, q, @@ -297,15 +329,39 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) ! vorticity is second order accurate everywhere with free slip b.c.s, ! but only first order accurate at boundaries with no slip b.c.s. ! First calculate the contributions to the circulation around the q-point. - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 - dvdx(I,J) = (v(i+1,J,k)*G%dyCv(i+1,J) - v(i,J,k)*G%dyCv(i,J)) - dudy(I,J) = (u(I,j+1,k)*G%dxCu(I,j+1) - u(I,j,k)*G%dxCu(I,j)) - enddo ; enddo - do J=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+2 - hArea_v(i,J) = 0.5*(Area_h(i,j) * h(i,j,k) + Area_h(i,j+1) * h(i,j+1,k)) + if (Stokes_VF) then + if (CS%id_CAuS>0 .or. CS%id_CAvS>0) then + do J=Js_q,Je_q ; do I=Is_q,Ie_q + dvSdx(I,J) = (-Waves%us_y(i+1,J,k)*G%dyCv(i+1,J)) - & + (-Waves%us_y(i,J,k)*G%dyCv(i,J)) + duSdy(I,J) = (-Waves%us_x(I,j+1,k)*G%dxCu(I,j+1)) - & + (-Waves%us_x(I,j,k)*G%dxCu(I,j)) + enddo ; enddo + endif + if (.not. Waves%Passive_Stokes_VF) then + do J=Js_q,Je_q ; do I=Is_q,Ie_q + dvdx(I,J) = ((v(i+1,J,k)-Waves%us_y(i+1,J,k))*G%dyCv(i+1,J)) - & + ((v(i,J,k)-Waves%us_y(i,J,k))*G%dyCv(i,J)) + dudy(I,J) = ((u(I,j+1,k)-Waves%us_x(I,j+1,k))*G%dxCu(I,j+1)) - & + ((u(I,j,k)-Waves%us_x(I,j,k))*G%dxCu(I,j)) + enddo ; enddo + else + do J=Js_q,Je_q ; do I=Is_q,Ie_q + dvdx(I,J) = (v(i+1,J,k)*G%dyCv(i+1,J)) - (v(i,J,k)*G%dyCv(i,J)) + dudy(I,J) = (u(I,j+1,k)*G%dxCu(I,j+1)) - (u(I,j,k)*G%dxCu(I,j)) + enddo ; enddo + endif + else + do J=Js_q,Je_q ; do I=Is_q,Ie_q + dvdx(I,J) = (v(i+1,J,k)*G%dyCv(i+1,J)) - (v(i,J,k)*G%dyCv(i,J)) + dudy(I,J) = (u(I,j+1,k)*G%dxCu(I,j+1)) - (u(I,j,k)*G%dxCu(I,j)) + enddo ; enddo + endif + do J=Js_q,Je_q ; do i=Is_q,Ie_q+1 + hArea_v(i,J) = 0.5*((Area_h(i,j) * h(i,j,k)) + (Area_h(i,j+1) * h(i,j+1,k))) enddo ; enddo - do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+1 - hArea_u(I,j) = 0.5*(Area_h(i,j) * h(i,j,k) + Area_h(i+1,j) * h(i+1,j,k)) + do j=Js_q,Je_q+1 ; do I=Is_q,Ie_q + hArea_u(I,j) = 0.5*((Area_h(i,j) * h(i,j,k)) + (Area_h(i+1,j) * h(i+1,j,k))) enddo ; enddo if (CS%Coriolis_En_Dis) then @@ -322,30 +378,36 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) if (associated(OBC)) then ; do n=1,OBC%number_of_segments if (.not. OBC%segment(n)%on_pe) cycle I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB - if (OBC%segment(n)%is_N_or_S .and. (J >= Jsq-1) .and. (J <= Jeq+1)) then - if (OBC%zero_vorticity) then ; do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB - dvdx(I,J) = 0. ; dudy(I,J) = 0. - enddo ; endif - if (OBC%freeslip_vorticity) then ; do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB - dudy(I,J) = 0. - enddo ; endif - if (OBC%computed_vorticity) then ; do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB - if (OBC%segment(n)%direction == OBC_DIRECTION_N) then - dudy(I,J) = 2.0*(OBC%segment(n)%tangential_vel(I,J,k) - u(I,j,k))*G%dxCu(I,j) - else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) - dudy(I,J) = 2.0*(u(I,j+1,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%dxCu(I,j+1) - endif - enddo ; endif - if (OBC%specified_vorticity) then ; do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB - if (OBC%segment(n)%direction == OBC_DIRECTION_N) then - dudy(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dxCu(I,j)*G%dyBu(I,J) - else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) - dudy(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dxCu(I,j+1)*G%dyBu(I,J) - endif - enddo ; endif + if (OBC%segment(n)%is_N_or_S .and. (J >= Js_q) .and. (J <= Je_q)) then + select case (OBC%vorticity_config) + case (OBC_VORTICITY_ZERO) + do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB + dvdx(I,J) = 0. ; dudy(I,J) = 0. + enddo + case (OBC_VORTICITY_FREESLIP) + do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB + dudy(I,J) = 0. + enddo + case (OBC_VORTICITY_COMPUTED) + do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + dudy(I,J) = 2.0*(OBC%segment(n)%tangential_vel(I,J,k) - u(I,j,k))*G%dxCu(I,j) + else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) + dudy(I,J) = 2.0*(u(I,j+1,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%dxCu(I,j+1) + endif + enddo + case (OBC_VORTICITY_SPECIFIED) + do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + dudy(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dxCu(I,j)*G%dyBu(I,J) + else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) + dudy(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dxCu(I,j+1)*G%dyBu(I,J) + endif + enddo + end select ! Project thicknesses across OBC points with a no-gradient condition. - do i = max(Isq-1,OBC%segment(n)%HI%isd), min(Ieq+2,OBC%segment(n)%HI%ied) + do i = max(Is_q,OBC%segment(n)%HI%isd), min(Ie_q+1,OBC%segment(n)%HI%ied) if (OBC%segment(n)%direction == OBC_DIRECTION_N) then hArea_v(i,J) = 0.5 * (Area_h(i,j) + Area_h(i,j+1)) * h(i,j,k) else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) @@ -354,7 +416,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) enddo if (CS%Coriolis_En_Dis) then - do i = max(Isq-1,OBC%segment(n)%HI%isd), min(Ieq+2,OBC%segment(n)%HI%ied) + do i = max(Isq,OBC%segment(n)%HI%isd), min(Ieq+1,OBC%segment(n)%HI%ied) if (OBC%segment(n)%direction == OBC_DIRECTION_N) then vh_center(i,J) = (G%dx_Cv(i,J)*pbv%por_face_areaV(i,J,k)) * v(i,J,k) * h(i,j,k) else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) @@ -362,30 +424,36 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) endif enddo endif - elseif (OBC%segment(n)%is_E_or_W .and. (I >= Isq-1) .and. (I <= Ieq+1)) then - if (OBC%zero_vorticity) then ; do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB - dvdx(I,J) = 0. ; dudy(I,J) = 0. - enddo ; endif - if (OBC%freeslip_vorticity) then ; do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB - dvdx(I,J) = 0. - enddo ; endif - if (OBC%computed_vorticity) then ; do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB - if (OBC%segment(n)%direction == OBC_DIRECTION_E) then - dvdx(I,J) = 2.0*(OBC%segment(n)%tangential_vel(I,J,k) - v(i,J,k))*G%dyCv(i,J) - else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) - dvdx(I,J) = 2.0*(v(i+1,J,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%dyCv(i+1,J) - endif - enddo ; endif - if (OBC%specified_vorticity) then ; do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB - if (OBC%segment(n)%direction == OBC_DIRECTION_E) then - dvdx(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dyCv(i,J)*G%dxBu(I,J) - else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) - dvdx(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dyCv(i+1,J)*G%dxBu(I,J) - endif - enddo ; endif + elseif (OBC%segment(n)%is_E_or_W .and. (I >= Is_q) .and. (I <= Ie_q)) then + select case (OBC%vorticity_config) + case (OBC_VORTICITY_ZERO) + do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB + dvdx(I,J) = 0. ; dudy(I,J) = 0. + enddo + case (OBC_VORTICITY_FREESLIP) + do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB + dvdx(I,J) = 0. + enddo + case (OBC_VORTICITY_COMPUTED) + do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB + if (OBC%segment(n)%direction == OBC_DIRECTION_E) then + dvdx(I,J) = 2.0*(OBC%segment(n)%tangential_vel(I,J,k) - v(i,J,k))*G%dyCv(i,J) + else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) + dvdx(I,J) = 2.0*(v(i+1,J,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%dyCv(i+1,J) + endif + enddo + case (OBC_VORTICITY_SPECIFIED) + do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB + if (OBC%segment(n)%direction == OBC_DIRECTION_E) then + dvdx(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dyCv(i,J)*G%dxBu(I,J) + else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) + dvdx(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dyCv(i+1,J)*G%dxBu(I,J) + endif + enddo + end select ! Project thicknesses across OBC points with a no-gradient condition. - do j = max(Jsq-1,OBC%segment(n)%HI%jsd), min(Jeq+2,OBC%segment(n)%HI%jed) + do j = max(Js_q,OBC%segment(n)%HI%jsd), min(Je_q+1,OBC%segment(n)%HI%jed) if (OBC%segment(n)%direction == OBC_DIRECTION_E) then hArea_u(I,j) = 0.5*(Area_h(i,j) + Area_h(i+1,j)) * h(i,j,k) else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) @@ -393,7 +461,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) endif enddo if (CS%Coriolis_En_Dis) then - do j = max(Jsq-1,OBC%segment(n)%HI%jsd), min(Jeq+2,OBC%segment(n)%HI%jed) + do j = max(Jsq,OBC%segment(n)%HI%jsd), min(Jeq+1,OBC%segment(n)%HI%jed) if (OBC%segment(n)%direction == OBC_DIRECTION_E) then uh_center(I,j) = (G%dy_Cu(I,j)*pbv%por_face_areaU(I,j,k)) * u(I,j,k) * h(i,j,k) else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) @@ -409,8 +477,8 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) ! Now project thicknesses across cell-corner points in the OBCs. The two ! projections have to occur in sequence and can not be combined easily. I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB - if (OBC%segment(n)%is_N_or_S .and. (J >= Jsq-1) .and. (J <= Jeq+1)) then - do I = max(Isq-1,OBC%segment(n)%HI%IsdB), min(Ieq+1,OBC%segment(n)%HI%IedB) + if (OBC%segment(n)%is_N_or_S .and. (J >= Js_q) .and. (J <= Je_q)) then + do I = max(Is_q,OBC%segment(n)%HI%IsdB), min(Ie_q,OBC%segment(n)%HI%IedB) if (OBC%segment(n)%direction == OBC_DIRECTION_N) then if (Area_h(i,j) + Area_h(i+1,j) > 0.0) then hArea_u(I,j+1) = hArea_u(I,j) * ((Area_h(i,j+1) + Area_h(i+1,j+1)) / & @@ -423,8 +491,8 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) else ; hArea_u(I,j) = 0.0 ; endif endif enddo - elseif (OBC%segment(n)%is_E_or_W .and. (I >= Isq-1) .and. (I <= Ieq+1)) then - do J = max(Jsq-1,OBC%segment(n)%HI%JsdB), min(Jeq+1,OBC%segment(n)%HI%JedB) + elseif (OBC%segment(n)%is_E_or_W .and. (I >= Is_q) .and. (I <= Ie_q)) then + do J = max(Js_q,OBC%segment(n)%HI%JsdB), min(Je_q,OBC%segment(n)%HI%JedB) if (OBC%segment(n)%direction == OBC_DIRECTION_E) then if (Area_h(i,j) + Area_h(i,j+1) > 0.0) then hArea_v(i+1,J) = hArea_v(i,J) * ((Area_h(i+1,j) + Area_h(i+1,j+1)) / & @@ -442,25 +510,48 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) enddo ; endif if (CS%no_slip) then - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + do J=Js_q,Je_q ; do I=Is_q,Ie_q rel_vort(I,J) = (2.0 - G%mask2dBu(I,J)) * (dvdx(I,J) - dudy(I,J)) * G%IareaBu(I,J) enddo ; enddo + if (Stokes_VF) then + if (CS%id_CAuS>0 .or. CS%id_CAvS>0) then + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + stk_vort(I,J) = (2.0 - G%mask2dBu(I,J)) * (dvSdx(I,J) - duSdy(I,J)) * G%IareaBu(I,J) + enddo ; enddo + endif + endif else - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + do J=Js_q,Je_q ; do I=Is_q,Ie_q rel_vort(I,J) = G%mask2dBu(I,J) * (dvdx(I,J) - dudy(I,J)) * G%IareaBu(I,J) enddo ; enddo + if (Stokes_VF) then + if (CS%id_CAuS>0 .or. CS%id_CAvS>0) then + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + stk_vort(I,J) = (2.0 - G%mask2dBu(I,J)) * (dvSdx(I,J) - duSdy(I,J)) * G%IareaBu(I,J) + enddo ; enddo + endif + endif endif - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + do J=Js_q,Je_q ; do I=Is_q,Ie_q abs_vort(I,J) = G%CoriolisBu(I,J) + rel_vort(I,J) enddo ; enddo - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + do J=Js_q,Je_q ; do I=Is_q,Ie_q hArea_q = (hArea_u(I,j) + hArea_u(I,j+1)) + (hArea_v(i,J) + hArea_v(i+1,J)) Ih_q(I,J) = Area_q(I,J) / (hArea_q + vol_neglect) + h_q(I,J) = hArea_q / max(Area_q(I,J), area_neglect) q(I,J) = abs_vort(I,J) * Ih_q(I,J) enddo ; enddo + if (Stokes_VF) then + if (CS%id_CAuS>0 .or. CS%id_CAvS>0) then + do J=js-1,Jeq ; do I=is-1,Ieq + qS(I,J) = stk_vort(I,J) * Ih_q(I,J) + enddo ; enddo + endif + endif + if (CS%id_rv > 0) then do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 RV(I,J,k) = rel_vort(I,J) @@ -599,7 +690,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) endif ! Calculate KE and the gradient of KE - call gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, GV, US, CS) + call gradKE(u(:,:,k), v(:,:,k), h(:,:,k), KE, KEx, KEy, G, GV, US, CS) ! Calculate the tendencies of zonal velocity due to the Coriolis ! force and momentum advection. On a Cartesian grid, this is @@ -630,8 +721,8 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) ! Energy conserving scheme, Sadourny 1975 do j=js,je ; do I=Isq,Ieq CAu(I,j,k) = 0.25 * & - (q(I,J) * (vh(i+1,J,k) + vh(i,J,k)) + & - q(I,J-1) * (vh(i,J-1,k) + vh(i+1,J-1,k))) * G%IdxCu(I,j) + ((q(I,J) * (vh(i+1,J,k) + vh(i,J,k))) + & + (q(I,J-1) * (vh(i,J-1,k) + vh(i+1,J-1,k)))) * G%IdxCu(I,j) enddo ; enddo endif elseif (CS%Coriolis_Scheme == SADOURNY75_ENSTRO) then @@ -644,8 +735,8 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) (CS%Coriolis_Scheme == AL_BLEND)) then ! (Global) Energy and (Local) Enstrophy conserving, Arakawa & Hsu 1990 do j=js,je ; do I=Isq,Ieq - CAu(I,j,k) = ((a(I,j) * vh(i+1,J,k) + c(I,j) * vh(i,J-1,k)) + & - (b(I,j) * vh(i,J,k) + d(I,j) * vh(i+1,J-1,k))) * G%IdxCu(I,j) + CAu(I,j,k) = (((a(I,j) * vh(i+1,J,k)) + (c(I,j) * vh(i,J-1,k))) + & + ((b(I,j) * vh(i,J,k)) + (d(I,j) * vh(i+1,J-1,k)))) * G%IdxCu(I,j) enddo ; enddo elseif (CS%Coriolis_Scheme == ROBUST_ENSTRO) then ! An enstrophy conserving scheme robust to vanishing layers @@ -670,19 +761,138 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) (h_tiny + ((Heff1+Heff4) + (Heff2+Heff3)) ) * G%IdxCu(I,j) elseif (CS%PV_Adv_Scheme == PV_ADV_UPWIND1) then VHeff = ((vh(i,J,k) + vh(i+1,J-1,k)) + (vh(i,J-1,k) + vh(i+1,J,k)) ) - QVHeff = 0.5*( (abs_vort(I,J)+abs_vort(I,J-1))*VHeff & - -(abs_vort(I,J)-abs_vort(I,J-1))*abs(VHeff) ) + QVHeff = 0.5*( ((abs_vort(I,J)+abs_vort(I,J-1))*VHeff) & + - ((abs_vort(I,J)-abs_vort(I,J-1))*abs(VHeff)) ) CAu(I,j,k) = (QVHeff / ( h_tiny + ((Heff1+Heff4) + (Heff2+Heff3)) ) ) * G%IdxCu(I,j) endif enddo ; enddo + elseif (CS%Coriolis_Scheme == wenovi7th_PV_ENSTRO) then + do j=js,je ; do I=Isq,Ieq + v_u = 0.25*G%IdxCu(I,j)*((vh(i+1,J,k) + vh(i,J,k)) + (vh(i,J-1,k) + vh(i+1,J-1,k))) + ! check whether there is masked land points in the stencil + third_order = (G%mask2dCu(I,j-2) * G%mask2dCu(I,j-1) * G%mask2dCu(I,j) * & + G%mask2dCu(I,j+1) * G%mask2dCu(I,j+2)) + + fifth_order = third_order * G%mask2dCu(I,j-3) * G%mask2dCu(I,j+3) + seventh_order = fifth_order * G%mask2dCu(I,j-4) * G%mask2dCu(I,j+4) + + + ! compute the masking to make sure that inland values are not used + if (seventh_order == 1) then + ! all values are valid, we use seventh order reconstruction + u_q8(:) = (u(I,j-4:j+3,k) + u(I,j-3:j+4,k)) * 0.5 + call weno_seven_h_weight_reconstruction(abs_vort(I,J-4:J+3), & + h_q(I,J-4:J+3), & + u_q8, & + GV%H_subroundoff, v_u, q_u, cs%weno_velocity_smooth) + CAu(I,j,k) = (q_u * v_u) + + elseif (fifth_order == 1) then + ! all values are valid, we use fifth order reconstruction + u_q6(:) = (u(I,j-3:j+2,k) + u(I,j-2:j+3,k)) * 0.5 + call weno_five_h_weight_reconstruction(abs_vort(I,J-3:J+2), & + h_q(I,J-3:J+2), & + u_q6, & + GV%H_subroundoff, v_u, q_u, CS%weno_velocity_smooth) + CAu(I,j,k) = (q_u * v_u) + + elseif (third_order == 1) then + ! only the middle values are valid, we use third order reconstruction + u_q4(:) = (u(I,j-2:j+1,k) + u(I,j-1:j+2,k)) * 0.5 + call weno_three_h_weight_reconstruction(abs_vort(I,J-2:J+1), & + h_q(I,J-2:J+1), & + u_q4, & + GV%H_subroundoff, v_u, q_u, CS%weno_velocity_smooth) + CAu(I,j,k) = (q_u * v_u) + else ! Upwind first order + if (v_u>0.) then + q_u = q(I,J-1) + else + q_u = q(I,J) + endif + CAu(I,j,k) = (q_u * v_u) + + endif + enddo ; enddo + elseif (CS%Coriolis_Scheme == wenovi5th_PV_ENSTRO) then + do j=js,je ; do I=Isq,Ieq + v_u = 0.25*G%IdxCu(I,j)*((vh(i+1,J,k) + vh(i,J,k)) + (vh(i,J-1,k) + vh(i+1,J-1,k))) + third_order = (G%mask2dCu(I,j-2) * G%mask2dCu(I,j-1) * G%mask2dCu(I,j) * & + G%mask2dCu(I,j+1) * G%mask2dCu(I,j+2)) + + fifth_order = third_order * G%mask2dCu(I,j-3) * G%mask2dCu(I,j+3) + + if (fifth_order == 1) then + ! all values are valid, we use fifth order reconstruction + u_q6(:) = (u(I,j-3:j+2,k) + u(I,j-2:j+3,k)) * 0.5 + call weno_five_h_weight_reconstruction(abs_vort(I,J-3:J+2), & + h_q(I,J-3:J+2), & + u_q6, & + GV%H_subroundoff, v_u, q_u, CS%weno_velocity_smooth) + CAu(I,j,k) = (q_u * v_u) + + elseif (third_order == 1) then + ! only the middle values are valid, we use third order reconstruction + u_q4(:) = (u(I,j-2:j+1,k) + u(I,j-1:j+2,k)) * 0.5 + call weno_three_h_weight_reconstruction(abs_vort(I,J-2:J+1), & + h_q(I,J-2:J+1), & + u_q4, & + GV%H_subroundoff, v_u, q_u, CS%weno_velocity_smooth) + CAu(I,j,k) = (q_u * v_u) + + else ! Upwind first order + if (v_u>0.) then + q_u = q(I,J-1) + else + q_u = q(I,J) + endif + CAu(I,j,k) = (q_u * v_u) + endif + enddo ; enddo + elseif (CS%Coriolis_Scheme == wenovi3rd_PV_ENSTRO) then + do j=js,je ; do I=Isq,Ieq + v_u = 0.25*G%IdxCu(I,j)*((vh(i+1,J,k) + vh(i,J,k)) + (vh(i,J-1,k) + vh(i+1,J-1,k))) + third_order = (G%mask2dCu(I,j-2) * G%mask2dCu(I,j-1) * G%mask2dCu(I,j) * & + G%mask2dCu(I,j+1) * G%mask2dCu(I,j+2)) + + + if (third_order == 1) then + ! only the middle values are valid, we use third order reconstruction + u_q4(:) = (u(I,j-2:j+1,k) + u(I,j-1:j+2,k)) * 0.5 + call weno_three_h_weight_reconstruction(abs_vort(I,J-2:J+1), & + h_q(I,J-2:J+1), & + u_q4, & + GV%H_subroundoff, v_u, q_u, CS%weno_velocity_smooth) + CAu(I,j,k) = (q_u * v_u) + + else ! Upwind first order + if (v_u>0.) then + q_u = q(I,J-1) + else + q_u = q(I,J) + endif + CAu(I,j,k) = (q_u * v_u) + endif + enddo ; enddo endif ! Add in the additional terms with Arakawa & Lamb. if ((CS%Coriolis_Scheme == ARAKAWA_LAMB81) .or. & (CS%Coriolis_Scheme == AL_BLEND)) then ; do j=js,je ; do I=Isq,Ieq CAu(I,j,k) = CAu(I,j,k) + & - (ep_u(i,j)*uh(I-1,j,k) - ep_u(i+1,j)*uh(I+1,j,k)) * G%IdxCu(I,j) + ((ep_u(i,j)*uh(I-1,j,k)) - (ep_u(i+1,j)*uh(I+1,j,k))) * G%IdxCu(I,j) enddo ; enddo ; endif + if (Stokes_VF) then + if (CS%id_CAuS>0 .or. CS%id_CAvS>0) then + ! Computing the diagnostic Stokes contribution to CAu + do j=js,je ; do I=Isq,Ieq + CAuS(I,j,k) = 0.25 * & + ((qS(I,J) * (vh(i+1,J,k) + vh(i,J,k))) + & + (qS(I,J-1) * (vh(i,J-1,k) + vh(i+1,J-1,k)))) * G%IdxCu(I,j) + enddo ; enddo + endif + endif + if (CS%bound_Coriolis) then do j=js,je ; do I=Isq,Ieq fv1 = abs_vort(I,J) * v(i+1,J,k) @@ -738,8 +948,8 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) ! Energy conserving scheme, Sadourny 1975 do J=Jsq,Jeq ; do i=is,ie CAv(i,J,k) = - 0.25* & - (q(I-1,J)*(uh(I-1,j,k) + uh(I-1,j+1,k)) + & - q(I,J)*(uh(I,j,k) + uh(I,j+1,k))) * G%IdyCv(i,J) + ((q(I-1,J)*(uh(I-1,j,k) + uh(I-1,j+1,k))) + & + (q(I,J)*(uh(I,j,k) + uh(I,j+1,k)))) * G%IdyCv(i,J) enddo ; enddo endif elseif (CS%Coriolis_Scheme == SADOURNY75_ENSTRO) then @@ -752,10 +962,10 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) (CS%Coriolis_Scheme == AL_BLEND)) then ! (Global) Energy and (Local) Enstrophy conserving, Arakawa & Hsu 1990 do J=Jsq,Jeq ; do i=is,ie - CAv(i,J,k) = - ((a(I-1,j) * uh(I-1,j,k) + & - c(I,j+1) * uh(I,j+1,k)) & - + (b(I,j) * uh(I,j,k) + & - d(I-1,j+1) * uh(I-1,j+1,k))) * G%IdyCv(i,J) + CAv(i,J,k) = - (((a(I-1,j) * uh(I-1,j,k)) + & + (c(I,j+1) * uh(I,j+1,k))) & + + ((b(I,j) * uh(I,j,k)) + & + (d(I-1,j+1) * uh(I-1,j+1,k)))) * G%IdyCv(i,J) enddo ; enddo elseif (CS%Coriolis_Scheme == ROBUST_ENSTRO) then ! An enstrophy conserving scheme robust to vanishing layers @@ -782,20 +992,149 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) elseif (CS%PV_Adv_Scheme == PV_ADV_UPWIND1) then UHeff = ((uh(I ,j ,k)+uh(I-1,j+1,k)) + & (uh(I-1,j ,k)+uh(I ,j+1,k)) ) - QUHeff = 0.5*( (abs_vort(I,J)+abs_vort(I-1,J))*UHeff & - -(abs_vort(I,J)-abs_vort(I-1,J))*abs(UHeff) ) + QUHeff = 0.5*( ((abs_vort(I,J)+abs_vort(I-1,J))*UHeff) & + - ((abs_vort(I,J)-abs_vort(I-1,J))*abs(UHeff)) ) CAv(i,J,k) = - QUHeff / & (h_tiny + ((Heff1+Heff4) +(Heff2+Heff3)) ) * G%IdyCv(i,J) endif enddo ; enddo + ! Calculate the tendencies of meridional velocity due to the Coriolis + ! force and momentum advection. On a Cartesian grid, this is + ! CAv = - q * uh - d(KE)/dy. + elseif (CS%Coriolis_Scheme == wenovi7th_PV_ENSTRO) then + do J=Jsq,Jeq ; do i=is,ie + u_v = 0.25*G%IdyCv(i,J)*((uh(I-1,j,k) + uh(I-1,j+1,k)) + (uh(I,j,k) + uh(I,j+1,k))) + + ! check whether there is any masked land values within the stencils + third_order = (G%mask2dCv(i-2,J) * G%mask2dCv(i-1,J) * G%mask2dCv(i,J) * G%mask2dCv(i+1,J) * & + G%mask2dCv(i+2,J)) + fifth_order = third_order * G%mask2dCv(i-3,J) * G%mask2dCv(i+3,J) + seventh_order = fifth_order * G%mask2dCv(i-4,J) * G%mask2dCv(i+4,J) + + + + ! compute the masking to make sure that inland values are not used + if (seventh_order == 1) then + v_q8(:) = (v(i-4:i+3,J,k) + v(i-3:i+4,J,k)) * 0.5 + ! all values are valid, we use seventh order reconstruction + call weno_seven_h_weight_reconstruction(abs_vort(I-4:I+3,J), & + h_q(I-4:I+3,J), & + v_q8, & + GV%H_subroundoff, u_v, q_v, CS%weno_velocity_smooth) + CAv(i,J,k) = - (q_v * u_v) + + elseif (fifth_order == 1) then + v_q6(:) = (v(i-3:i+2,J,k) + v(i-2:i+3,J,k)) * 0.5 + ! all values are valid, we use fifth order reconstruction + call weno_five_h_weight_reconstruction(abs_vort(I-3:I+2,J), & + h_q(I-3:I+2,J), & + v_q6, & + GV%H_subroundoff, u_v, q_v, CS%weno_velocity_smooth) + CAv(i,J,k) = - (q_v * u_v) + + elseif (third_order == 1) then + v_q4(:) = (v(i-2:i+1,J,k) + v(i-1:i+2,J,k)) * 0.5 +! ! only the middle values are valid, we use third order reconstruction + call weno_three_h_weight_reconstruction(abs_vort(I-2:I+1,J), & + h_q(I-2:I+1,J), & + v_q4, & + GV%H_subroundoff, u_v, q_v, CS%weno_velocity_smooth) + CAv(i,J,k) = - (q_v * u_v) + else ! Upwind first order! + if (u_v>0.) then + q_v = q(I-1,J) + else + q_v = q(I,J) + endif + CAv(i,J,k) = - (q_v * u_v) + endif + + enddo ; enddo + elseif (CS%Coriolis_Scheme == wenovi5th_PV_ENSTRO) then + do J=Jsq,Jeq ; do i=is,ie + u_v = 0.25*G%IdyCv(i,J)*((uh(I-1,j,k) + uh(I-1,j+1,k)) + (uh(I,j,k) + uh(I,j+1,k))) + + third_order = (G%mask2dCv(i-2,J) * G%mask2dCv(i-1,J) * G%mask2dCv(i,J) * G%mask2dCv(i+1,J) * & + G%mask2dCv(i+2,J)) + fifth_order = third_order * G%mask2dCv(i-3,J) * G%mask2dCv(i+3,J) + + + ! compute the masking to make sure that inland values are not used + if (fifth_order == 1) then + v_q6(:) = (v(i-3:i+2,J,k) + v(i-2:i+3,J,k)) * 0.5 + ! all values are valid, we use fifth order reconstruction + call weno_five_h_weight_reconstruction(abs_vort(I-3:I+2,J), & + h_q(I-3:I+2,J), & + v_q6, & + GV%H_subroundoff, u_v, q_v, CS%weno_velocity_smooth) + CAv(i,J,k) = - (q_v * u_v) + + elseif (third_order == 1) then + v_q4(:) = (v(i-2:i+1,J,k) + v(i-1:i+2,J,k)) * 0.5 +! ! only the middle values are valid, we use third order reconstruction + call weno_three_h_weight_reconstruction(abs_vort(I-2:I+1,J), & + h_q(I-2:I+1,J), & + v_q4, & + GV%H_subroundoff, u_v, q_v, CS%weno_velocity_smooth) + CAv(i,J,k) = - (q_v * u_v) + + else + if (u_v>0.) then + q_v = q(I-1,J) + else + q_v = q(I,J) + endif + CAv(i,J,k) = - (q_v * u_v) + endif + + enddo ; enddo + elseif (CS%Coriolis_Scheme == wenovi3rd_PV_ENSTRO) then + do J=Jsq,Jeq ; do i=is,ie + u_v = 0.25*G%IdyCv(i,J)*((uh(I-1,j,k) + uh(I-1,j+1,k)) + (uh(I,j,k) + uh(I,j+1,k))) + + third_order = (G%mask2dCv(i-2,J) * G%mask2dCv(i-1,J) * G%mask2dCv(i,J) * G%mask2dCv(i+1,J) * & + G%mask2dCv(i+2,J)) + + + ! compute the masking to make sure that inland values are not used + if (third_order == 1) then + v_q4(:) = (v(i-2:i+1,J,k) + v(i-1:i+2,J,k)) * 0.5 +! ! only the middle values are valid, we use third order reconstruction + call weno_three_h_weight_reconstruction(abs_vort(I-2:I+1,J), & + h_q(I-2:I+1,J), & + v_q4, & + GV%H_subroundoff, u_v, q_v, CS%weno_velocity_smooth) + CAv(i,J,k) = - (q_v * u_v) + + else + if (u_v>0.) then + q_v = q(I-1,J) + else + q_v = q(I,J) + endif + CAv(i,J,k) = - (q_v * u_v) + endif + + enddo ; enddo endif ! Add in the additonal terms with Arakawa & Lamb. if ((CS%Coriolis_Scheme == ARAKAWA_LAMB81) .or. & (CS%Coriolis_Scheme == AL_BLEND)) then ; do J=Jsq,Jeq ; do i=is,ie CAv(i,J,k) = CAv(i,J,k) + & - (ep_v(i,j)*vh(i,J-1,k) - ep_v(i,j+1)*vh(i,J+1,k)) * G%IdyCv(i,J) + ((ep_v(i,j)*vh(i,J-1,k)) - (ep_v(i,j+1)*vh(i,J+1,k))) * G%IdyCv(i,J) enddo ; enddo ; endif + if (Stokes_VF) then + if (CS%id_CAuS>0 .or. CS%id_CAvS>0) then + ! Computing the diagnostic Stokes contribution to CAv + do J=Jsq,Jeq ; do i=is,ie + CAvS(i,J,k) = 0.25 * & + ((qS(I,J) * (uh(I,j+1,k) + uh(I,j,k))) + & + (qS(I-1,J) * (uh(I-1,j,k) + uh(I-1,j+1,k)))) * G%IdyCv(i,J) + enddo ; enddo + endif + endif + if (CS%bound_Coriolis) then do J=Jsq,Jeq ; do i=is,ie fu1 = -abs_vort(I,J) * u(I,j+1,k) @@ -827,36 +1166,36 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) if (associated(AD%rv_x_u)) then do J=Jsq,Jeq ; do i=is,ie AD%rv_x_u(i,J,k) = - 0.25* & - (q2(I-1,j)*(uh(I-1,j,k) + uh(I-1,j+1,k)) + & - q2(I,j)*(uh(I,j,k) + uh(I,j+1,k))) * G%IdyCv(i,J) + ((q2(I-1,j)*(uh(I-1,j,k) + uh(I-1,j+1,k))) + & + (q2(I,j)*(uh(I,j,k) + uh(I,j+1,k)))) * G%IdyCv(i,J) enddo ; enddo endif if (associated(AD%rv_x_v)) then do j=js,je ; do I=Isq,Ieq AD%rv_x_v(I,j,k) = 0.25 * & - (q2(I,j) * (vh(i+1,J,k) + vh(i,J,k)) + & - q2(I,j-1) * (vh(i,J-1,k) + vh(i+1,J-1,k))) * G%IdxCu(I,j) + ((q2(I,j) * (vh(i+1,J,k) + vh(i,J,k))) + & + (q2(I,j-1) * (vh(i,J-1,k) + vh(i+1,J-1,k)))) * G%IdxCu(I,j) enddo ; enddo endif else if (associated(AD%rv_x_u)) then do J=Jsq,Jeq ; do i=is,ie AD%rv_x_u(i,J,k) = -G%IdyCv(i,J) * C1_12 * & - ((q2(I,J) + q2(I-1,J) + q2(I-1,J-1)) * uh(I-1,j,k) + & - (q2(I-1,J) + q2(I,J) + q2(I,J-1)) * uh(I,j,k) + & - (q2(I-1,J) + q2(I,J+1) + q2(I,J)) * uh(I,j+1,k) + & - (q2(I,J) + q2(I-1,J+1) + q2(I-1,J)) * uh(I-1,j+1,k)) + (((((q2(I,J) + q2(I-1,J-1)) + q2(I-1,J)) * uh(I-1,j,k)) + & + (((q2(I-1,J) + q2(I,J+1)) + q2(I,J)) * uh(I,j+1,k))) + & + ((((q2(I-1,J) + q2(I,J-1)) + q2(I,J)) * uh(I,j,k))+ & + (((q2(I,J) + q2(I-1,J+1)) + q2(I-1,J)) * uh(I-1,j+1,k)))) enddo ; enddo endif if (associated(AD%rv_x_v)) then do j=js,je ; do I=Isq,Ieq AD%rv_x_v(I,j,k) = G%IdxCu(I,j) * C1_12 * & - ((q2(I+1,J) + q2(I,J) + q2(I,J-1)) * vh(i+1,J,k) + & - (q2(I-1,J) + q2(I,J) + q2(I,J-1)) * vh(i,J,k) + & - (q2(I-1,J-1) + q2(I,J) + q2(I,J-1)) * vh(i,J-1,k) + & - (q2(I+1,J-1) + q2(I,J) + q2(I,J-1)) * vh(i+1,J-1,k)) + (((((q2(I+1,J) + q2(I,J-1)) + q2(I,J)) * vh(i+1,J,k)) + & + (((q2(I-1,J-1) + q2(I,J)) + q2(I,J-1)) * vh(i,J-1,k))) + & + ((((q2(I-1,J) + q2(I,J-1)) + q2(I,J)) * vh(i,J,k)) + & + (((q2(I+1,J-1) + q2(I,J)) + q2(I,J-1)) * vh(i+1,J-1,k)))) enddo ; enddo endif endif @@ -872,178 +1211,61 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) if (CS%id_gKEv>0) call post_data(CS%id_gKEv, AD%gradKEv, CS%diag) if (CS%id_rvxu > 0) call post_data(CS%id_rvxu, AD%rv_x_u, CS%diag) if (CS%id_rvxv > 0) call post_data(CS%id_rvxv, AD%rv_x_v, CS%diag) + if (Stokes_VF) then + if (CS%id_CAuS > 0) call post_data(CS%id_CAuS, CAuS, CS%diag) + if (CS%id_CAvS > 0) call post_data(CS%id_CAvS, CAvS, CS%diag) + endif ! Diagnostics for terms multiplied by fractional thicknesses ! 3D diagnostics hf_gKEu etc. are commented because there is no clarity on proper remapping grid option. ! The code is retained for debugging purposes in the future. - !if (CS%id_hf_gKEu > 0) then - ! allocate(hf_gKEu(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) - ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq - ! hf_gKEu(I,j,k) = AD%gradKEu(I,j,k) * AD%diag_hfrac_u(I,j,k) - ! enddo ; enddo ; enddo - ! call post_data(CS%id_hf_gKEu, hf_gKEu, CS%diag) - !endif - - !if (CS%id_hf_gKEv > 0) then - ! allocate(hf_gKEv(G%isd:G%ied,G%JsdB:G%JedB,GV%ke)) - ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - ! hf_gKEv(i,J,k) = AD%gradKEv(i,J,k) * AD%diag_hfrac_v(i,J,k) - ! enddo ; enddo ; enddo - ! call post_data(CS%id_hf_gKEv, hf_gKEv, CS%diag) - !endif - - if (CS%id_hf_gKEu_2d > 0) then - allocate(hf_gKEu_2d(G%IsdB:G%IedB,G%jsd:G%jed)) - hf_gKEu_2d(:,:) = 0.0 - do k=1,nz ; do j=js,je ; do I=Isq,Ieq - hf_gKEu_2d(I,j) = hf_gKEu_2d(I,j) + AD%gradKEu(I,j,k) * AD%diag_hfrac_u(I,j,k) - enddo ; enddo ; enddo - call post_data(CS%id_hf_gKEu_2d, hf_gKEu_2d, CS%diag) - deallocate(hf_gKEu_2d) - endif - - if (CS%id_hf_gKEv_2d > 0) then - allocate(hf_gKEv_2d(G%isd:G%ied,G%JsdB:G%JedB)) - hf_gKEv_2d(:,:) = 0.0 - do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - hf_gKEv_2d(i,J) = hf_gKEv_2d(i,J) + AD%gradKEv(i,J,k) * AD%diag_hfrac_v(i,J,k) - enddo ; enddo ; enddo - call post_data(CS%id_hf_gKEv_2d, hf_gKEv_2d, CS%diag) - deallocate(hf_gKEv_2d) - endif - - if (CS%id_intz_gKEu_2d > 0) then - intz_gKEu_2d(:,:) = 0.0 - do k=1,nz ; do j=js,je ; do I=Isq,Ieq - intz_gKEu_2d(I,j) = intz_gKEu_2d(I,j) + AD%gradKEu(I,j,k) * AD%diag_hu(I,j,k) - enddo ; enddo ; enddo - call post_data(CS%id_intz_gKEu_2d, intz_gKEu_2d, CS%diag) - endif - - if (CS%id_intz_gKEv_2d > 0) then - intz_gKEv_2d(:,:) = 0.0 - do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - intz_gKEv_2d(i,J) = intz_gKEv_2d(i,J) + AD%gradKEv(i,J,k) * AD%diag_hv(i,J,k) - enddo ; enddo ; enddo - call post_data(CS%id_intz_gKEv_2d, intz_gKEv_2d, CS%diag) - endif - - !if (CS%id_hf_rvxv > 0) then - ! allocate(hf_rvxv(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) - ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq - ! hf_rvxv(I,j,k) = AD%rv_x_v(I,j,k) * AD%diag_hfrac_u(I,j,k) - ! enddo ; enddo ; enddo - ! call post_data(CS%id_hf_rvxv, hf_rvxv, CS%diag) - !endif - - !if (CS%id_hf_rvxu > 0) then - ! allocate(hf_rvxu(G%isd:G%ied,G%JsdB:G%JedB,GV%ke)) - ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - ! hf_rvxu(i,J,k) = AD%rv_x_u(i,J,k) * AD%diag_hfrac_v(i,J,k) - ! enddo ; enddo ; enddo - ! call post_data(CS%id_hf_rvxu, hf_rvxu, CS%diag) - !endif - - if (CS%id_hf_rvxv_2d > 0) then - allocate(hf_rvxv_2d(G%IsdB:G%IedB,G%jsd:G%jed)) - hf_rvxv_2d(:,:) = 0.0 - do k=1,nz ; do j=js,je ; do I=Isq,Ieq - hf_rvxv_2d(I,j) = hf_rvxv_2d(I,j) + AD%rv_x_v(I,j,k) * AD%diag_hfrac_u(I,j,k) - enddo ; enddo ; enddo - call post_data(CS%id_hf_rvxv_2d, hf_rvxv_2d, CS%diag) - deallocate(hf_rvxv_2d) - endif - - if (CS%id_hf_rvxu_2d > 0) then - allocate(hf_rvxu_2d(G%isd:G%ied,G%JsdB:G%JedB)) - hf_rvxu_2d(:,:) = 0.0 - do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - hf_rvxu_2d(i,J) = hf_rvxu_2d(i,J) + AD%rv_x_u(i,J,k) * AD%diag_hfrac_v(i,J,k) - enddo ; enddo ; enddo - call post_data(CS%id_hf_rvxu_2d, hf_rvxu_2d, CS%diag) - deallocate(hf_rvxu_2d) - endif - - if (CS%id_h_gKEu > 0) then - allocate(h_gKEu(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) - h_gKEu(:,:,:) = 0.0 - do k=1,nz ; do j=js,je ; do I=Isq,Ieq - h_gKEu(I,j,k) = AD%gradKEu(I,j,k) * AD%diag_hu(I,j,k) - enddo ; enddo ; enddo - call post_data(CS%id_h_gKEu, h_gKEu, CS%diag) - deallocate(h_gKEu) - endif - if (CS%id_h_gKEv > 0) then - allocate(h_gKEv(G%isd:G%ied,G%JsdB:G%JedB,GV%ke)) - h_gKEv(:,:,:) = 0.0 - do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - h_gKEv(i,J,k) = AD%gradKEv(i,J,k) * AD%diag_hv(i,J,k) - enddo ; enddo ; enddo - call post_data(CS%id_h_gKEv, h_gKEv, CS%diag) - deallocate(h_gKEv) - endif - - if (CS%id_h_rvxv > 0) then - allocate(h_rvxv(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke)) - h_rvxv(:,:,:) = 0.0 - do k=1,nz ; do j=js,je ; do I=Isq,Ieq - h_rvxv(I,j,k) = AD%rv_x_v(I,j,k) * AD%diag_hu(I,j,k) - enddo ; enddo ; enddo - call post_data(CS%id_h_rvxv, h_rvxv, CS%diag) - deallocate(h_rvxv) - endif - if (CS%id_h_rvxu > 0) then - allocate(h_rvxu(G%isd:G%ied,G%JsdB:G%JedB,GV%ke)) - h_rvxu(:,:,:) = 0.0 - do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - h_rvxu(i,J,k) = AD%rv_x_u(i,J,k) * AD%diag_hv(i,J,k) - enddo ; enddo ; enddo - call post_data(CS%id_h_rvxu, h_rvxu, CS%diag) - deallocate(h_rvxu) - endif - - if (CS%id_intz_rvxv_2d > 0) then - intz_rvxv_2d(:,:) = 0.0 - do k=1,nz ; do j=js,je ; do I=Isq,Ieq - intz_rvxv_2d(I,j) = intz_rvxv_2d(I,j) + AD%rv_x_v(I,j,k) * AD%diag_hu(I,j,k) - enddo ; enddo ; enddo - call post_data(CS%id_intz_rvxv_2d, intz_rvxv_2d, CS%diag) - endif - - if (CS%id_intz_rvxu_2d > 0) then - intz_rvxu_2d(:,:) = 0.0 - do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - intz_rvxu_2d(i,J) = intz_rvxu_2d(i,J) + AD%rv_x_u(i,J,k) * AD%diag_hv(i,J,k) - enddo ; enddo ; enddo - call post_data(CS%id_intz_rvxu_2d, intz_rvxu_2d, CS%diag) - endif + ! if (CS%id_hf_gKEu > 0) call post_product_u(CS%id_hf_gKEu, AD%gradKEu, AD%diag_hfrac_u, G, nz, CS%diag) + ! if (CS%id_hf_gKEv > 0) call post_product_v(CS%id_hf_gKEv, AD%gradKEv, AD%diag_hfrac_v, G, nz, CS%diag) + ! if (CS%id_hf_rvxv > 0) call post_product_u(CS%id_hf_rvxv, AD%rv_x_v, AD%diag_hfrac_u, G, nz, CS%diag) + ! if (CS%id_hf_rvxu > 0) call post_product_v(CS%id_hf_rvxu, AD%rv_x_u, AD%diag_hfrac_v, G, nz, CS%diag) + + if (CS%id_hf_gKEu_2d > 0) call post_product_sum_u(CS%id_hf_gKEu_2d, AD%gradKEu, AD%diag_hfrac_u, G, nz, CS%diag) + if (CS%id_hf_gKEv_2d > 0) call post_product_sum_v(CS%id_hf_gKEv_2d, AD%gradKEv, AD%diag_hfrac_v, G, nz, CS%diag) + if (CS%id_intz_gKEu_2d > 0) call post_product_sum_u(CS%id_intz_gKEu_2d, AD%gradKEu, AD%diag_hu, G, nz, CS%diag) + if (CS%id_intz_gKEv_2d > 0) call post_product_sum_v(CS%id_intz_gKEv_2d, AD%gradKEv, AD%diag_hv, G, nz, CS%diag) + + if (CS%id_hf_rvxv_2d > 0) call post_product_sum_u(CS%id_hf_rvxv_2d, AD%rv_x_v, AD%diag_hfrac_u, G, nz, CS%diag) + if (CS%id_hf_rvxu_2d > 0) call post_product_sum_v(CS%id_hf_rvxu_2d, AD%rv_x_u, AD%diag_hfrac_v, G, nz, CS%diag) + + if (CS%id_h_gKEu > 0) call post_product_u(CS%id_h_gKEu, AD%gradKEu, AD%diag_hu, G, nz, CS%diag) + if (CS%id_h_gKEv > 0) call post_product_v(CS%id_h_gKEv, AD%gradKEv, AD%diag_hv, G, nz, CS%diag) + if (CS%id_h_rvxv > 0) call post_product_u(CS%id_h_rvxv, AD%rv_x_v, AD%diag_hu, G, nz, CS%diag) + if (CS%id_h_rvxu > 0) call post_product_v(CS%id_h_rvxu, AD%rv_x_u, AD%diag_hv, G, nz, CS%diag) + + if (CS%id_intz_rvxv_2d > 0) call post_product_sum_u(CS%id_intz_rvxv_2d, AD%rv_x_v, AD%diag_hu, G, nz, CS%diag) + if (CS%id_intz_rvxu_2d > 0) call post_product_sum_v(CS%id_intz_rvxu_2d, AD%rv_x_u, AD%diag_hv, G, nz, CS%diag) endif end subroutine CorAdCalc -!> Calculates the acceleration due to the gradient of kinetic energy. -subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, GV, US, CS) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - real, dimension(SZI_(G) ,SZJ_(G) ), intent(out) :: KE !< Kinetic energy per unit mass [L2 T-2 ~> m2 s-2] - real, dimension(SZIB_(G),SZJ_(G) ), intent(out) :: KEx !< Zonal acceleration due to kinetic - !! energy gradient [L T-2 ~> m s-2] - real, dimension(SZI_(G) ,SZJB_(G)), intent(out) :: KEy !< Meridional acceleration due to kinetic - !! energy gradient [L T-2 ~> m s-2] - integer, intent(in) :: k !< Layer number to calculate for - type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(CoriolisAdv_CS), intent(in) :: CS !< Control structure for MOM_CoriolisAdv +!> Calculates the acceleration due to the gradient of kinetic energy in one layer. +subroutine gradKE(u, v, h, KE, KEx, KEy, G, GV, US, CS) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: KE !< Kinetic energy per unit mass [L2 T-2 ~> m2 s-2] + real, dimension(SZIB_(G),SZJ_(G)), intent(out) :: KEx !< Zonal acceleration due to kinetic + !! energy gradient [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G)), intent(out) :: KEy !< Meridional acceleration due to kinetic + !! energy gradient [L T-2 ~> m s-2] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(CoriolisAdv_CS), intent(in) :: CS !< Control structure for MOM_CoriolisAdv ! Local variables real :: um, up, vm, vp ! Temporary variables [L T-1 ~> m s-1]. real :: um2, up2, vm2, vp2 ! Temporary variables [L2 T-2 ~> m2 s-2]. real :: um2a, up2a, vm2a, vp2a ! Temporary variables [L4 T-2 ~> m4 s-2]. + real :: third_order_u, third_order_v ! Product of mask values to determine the boundary integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, n + real, parameter :: C1_12 = 1.0/12.0 ! The ratio of 1/12 [nondim] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -1055,58 +1277,616 @@ subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, GV, US, CS) ! identified in Arakawa & Lamb 1982 as important for KE conservation. It ! also includes the possibility of partially-blocked tracer cell faces. do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - KE(i,j) = ( ( G%areaCu( I ,j)*(u( I ,j,k)*u( I ,j,k)) + & - G%areaCu(I-1,j)*(u(I-1,j,k)*u(I-1,j,k)) ) + & - ( G%areaCv(i, J )*(v(i, J ,k)*v(i, J ,k)) + & - G%areaCv(i,J-1)*(v(i,J-1,k)*v(i,J-1,k)) ) )*0.25*G%IareaT(i,j) + KE(i,j) = ( ( (G%areaCu( I ,j)*(u( I ,j)*u( I ,j))) + & + (G%areaCu(I-1,j)*(u(I-1,j)*u(I-1,j))) ) + & + ( (G%areaCv(i, J )*(v(i, J )*v(i, J ))) + & + (G%areaCv(i,J-1)*(v(i,J-1)*v(i,J-1))) ) )*0.25*G%IareaT(i,j) enddo ; enddo elseif (CS%KE_Scheme == KE_SIMPLE_GUDONOV) then ! The following discretization of KE is based on the one-dimensional Gudonov ! scheme which does not take into account any geometric factors do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - up = 0.5*( u(I-1,j,k) + ABS( u(I-1,j,k) ) ) ; up2 = up*up - um = 0.5*( u( I ,j,k) - ABS( u( I ,j,k) ) ) ; um2 = um*um - vp = 0.5*( v(i,J-1,k) + ABS( v(i,J-1,k) ) ) ; vp2 = vp*vp - vm = 0.5*( v(i, J ,k) - ABS( v(i, J ,k) ) ) ; vm2 = vm*vm + up = 0.5*( u(I-1,j) + ABS( u(I-1,j) ) ) ; up2 = up*up + um = 0.5*( u( I ,j) - ABS( u( I ,j) ) ) ; um2 = um*um + vp = 0.5*( v(i,J-1) + ABS( v(i,J-1) ) ) ; vp2 = vp*vp + vm = 0.5*( v(i, J ) - ABS( v(i, J ) ) ) ; vm2 = vm*vm KE(i,j) = ( max(up2,um2) + max(vp2,vm2) ) *0.5 enddo ; enddo elseif (CS%KE_Scheme == KE_GUDONOV) then ! The following discretization of KE is based on the one-dimensional Gudonov ! scheme but has been adapted to take horizontal grid factors into account do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - up = 0.5*( u(I-1,j,k) + ABS( u(I-1,j,k) ) ) ; up2a = up*up*G%areaCu(I-1,j) - um = 0.5*( u( I ,j,k) - ABS( u( I ,j,k) ) ) ; um2a = um*um*G%areaCu( I ,j) - vp = 0.5*( v(i,J-1,k) + ABS( v(i,J-1,k) ) ) ; vp2a = vp*vp*G%areaCv(i,J-1) - vm = 0.5*( v(i, J ,k) - ABS( v(i, J ,k) ) ) ; vm2a = vm*vm*G%areaCv(i, J ) + up = 0.5*( u(I-1,j) + ABS( u(I-1,j) ) ) ; up2a = up*up*G%areaCu(I-1,j) + um = 0.5*( u( I ,j) - ABS( u( I ,j) ) ) ; um2a = um*um*G%areaCu( I ,j) + vp = 0.5*( v(i,J-1) + ABS( v(i,J-1) ) ) ; vp2a = vp*vp*G%areaCv(i,J-1) + vm = 0.5*( v(i, J ) - ABS( v(i, J ) ) ) ; vm2a = vm*vm*G%areaCv(i, J ) KE(i,j) = ( max(um2a,up2a) + max(vm2a,vp2a) )*0.5*G%IareaT(i,j) enddo ; enddo + elseif (CS%KE_Scheme == KE_UP3) then + ! The following discretization of KE is based on the one-dimensional third-order + ! upwind scheme which does not take horizontal grid factors into account + if (CS%KE_use_limiter) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + ! compute the masking to make sure that inland values are not used + third_order_u = (G%mask2dCu(I-2,j) * G%mask2dCu(I-1,j)* & + G%mask2dCu(I,j) * G%mask2dCu(I+1,j)) + + if (third_order_u == 1) then + up = (7.0 * (u(I-1,j) + u(I,j)) - (u(I-2,j) + u(I+1,j))) * C1_12 + call UP3_Koren_limiter_reconstruction(u(I-2:I+1,j), up, um) + else + up = (u(I-1,j) + u(I,j))*0.5 + if (up>0.) then + um = u(I-1,j) + elseif (up<0.) then + um = u(I,j) + else + um = up + endif + endif + + third_order_v = (G%mask2dCv(i,J-2) * G%mask2dCv(i,J-1)* & + G%mask2dCv(i,J) * G%mask2dCv(i,J+1)) + if (third_order_v ==1) then + vp = (7.0 * (v(i,J-1) + v(i,J)) - (v(i,J-2) + v(i,J+1))) * C1_12 + call UP3_Koren_limiter_reconstruction(v(i,J-2:J+1), vp, vm) + else + vp = (v(i,J-1) + v(i,J))*0.5 + if (vp>0.) then + vm = v(i,J-1) + elseif (vp<0.) then + vm = v(i,J) + else + vm = vp + endif + endif + + KE(i,j) = ( (um*um) + (vm*vm) )*0.5 + enddo ; enddo + else + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + ! compute the masking to make sure that inland values are not used + third_order_u = (G%mask2dCu(I-2,j) * G%mask2dCu(I-1,j)* & + G%mask2dCu(I,j) * G%mask2dCu(I+1,j)) + + if (third_order_u == 1) then + up = (7.0 * (u(I-1,j) + u(I,j)) - (u(I-2,j) + u(I+1,j))) * C1_12 + call UP3_reconstruction(u(I-2:I+1,j), up, um) + else + up = (u(I-1,j) + u(I,j))*0.5 + if (up>0.) then + um = u(I-1,j) + elseif (up<0.) then + um = u(I,j) + else + um = up + endif + endif + + third_order_v = (G%mask2dCv(i,J-2) * G%mask2dCv(i,J-1)* & + G%mask2dCv(i,J) * G%mask2dCv(i,J+1)) + if (third_order_v ==1) then + vp = (7.0 * (v(i,J-1) + v(i,J)) - (v(i,J-2) + v(i,J+1))) * C1_12 + call UP3_reconstruction(v(i,J-2:J+1), vp, vm) + else + vp = (v(i,J-1) + v(i,J))*0.5 + if (vp>0.) then + vm = v(i,J-1) + elseif (vp<0.) then + vm = v(i,J) + else + vm = vp + endif + endif + + KE(i,j) = ( (um*um) + (vm*vm) )*0.5 + enddo ; enddo + endif endif ! Term - d(KE)/dx. do j=js,je ; do I=Isq,Ieq - KEx(I,j) = (KE(i+1,j) - KE(i,j)) * G%IdxCu(I,j) + KEx(I,j) = (KE(i+1,j) - KE(i,j)) * G%IdxCu_OBCmask(I,j) enddo ; enddo ! Term - d(KE)/dy. do J=Jsq,Jeq ; do i=is,ie - KEy(i,J) = (KE(i,j+1) - KE(i,j)) * G%IdyCv(i,J) + KEy(i,J) = (KE(i,j+1) - KE(i,j)) * G%IdyCv_OBCmask(i,J) enddo ; enddo - if (associated(OBC)) then - do n=1,OBC%number_of_segments - if (OBC%segment(n)%is_N_or_S) then - do i=OBC%segment(n)%HI%isd,OBC%segment(n)%HI%ied - KEy(i,OBC%segment(n)%HI%JsdB) = 0. - enddo - elseif (OBC%segment(n)%is_E_or_W) then - do j=OBC%segment(n)%HI%jsd,OBC%segment(n)%HI%jed - KEx(OBC%segment(n)%HI%IsdB,j) = 0. - enddo +end subroutine gradKE + +!> Reconstruct the scalar (e.g., pv, vorticity) onto point i-1/2 using a third-order upwind scheme +subroutine UP3_reconstruction(q4,u,qr) + real, intent(in) :: q4(4) !< Tracer values on points i-2, i-1, i, i+1 [A ~> a] + real, intent(in) :: u !< Velocity or thickness flux on point i-1/2 + !! [l t-1 ~> m s-1] or [l2 t-1 ~> m2 s-1] + real, intent(inout) :: qr !< Reconstruction of tracer q at point i-1/2 [A ~> a] + real, parameter :: C1_6 = 1.0/6.0 ! The ratio of 1/6 [nondim] + + if (u>0.) then + qr = ((2.*q4(3) + 5.*q4(2)) - q4(1)) * C1_6 + else + qr = ((2.*q4(2) + 5.*q4(3)) - q4(4)) * C1_6 + endif + +end subroutine UP3_reconstruction + + +!> Reconstruct the scalar (e.g., PV, vorticity) onto point i-1/2 +!! using a third-order upwind scheme with the Koren flux limiter +subroutine UP3_Koren_limiter_reconstruction(q4,u,qr) + real, intent(in) :: q4(4) !< Tracer values on points i-2, i-1, i, i+1 [A ~> a] + real, intent(in) :: u !< Velocity or thickness flux on point i-1/2 + !! [L T-1 ~> m s-1] or [L2 T-1 ~> m2 s-1] + real, intent(inout) :: qr !< Reconstruction of tracer q on point i-1/2 [A ~> a] + real :: theta ! Ratio of gradient [nondim] + real :: psi ! Limiter function [nondim] + real, parameter :: C1_3 = 1.0/3.0 ! The ratio of 1/3 [nondim] + real, parameter :: C1_6 = 1.0/6.0 ! The ratio of 1/6 [nondim] + + if (u>0.) then + if (q4(3) == q4(2)) then + qr = q4(2) + else + theta = (q4(2) - q4(1))/(q4(3) - q4(2)) + psi = max(0., min(1., C1_3 + C1_6*theta, theta)) ! limiter introduced by Koren (1993) + qr = q4(2) + psi*(q4(3) - q4(2)) + endif + else + if (q4(3) == q4(2)) then + qr = q4(3) + else + theta = (q4(4) - q4(3))/(q4(3) - q4(2)) + psi = max(0., min(1., C1_3 + C1_6*theta, theta)) + qr = q4(3) + psi*(q4(2) - q4(3)) + endif + endif + +end subroutine UP3_Koren_limiter_reconstruction + +!> Compute the factor for the WENO weights +function fac_fn(tau, b) result(fac) + real, intent(in) :: tau !< Difference of the smoothness indicator [A ~> a] + real, intent(in) :: b !< The smoothness indicator [A ~> a] + real :: fac !< The factor for the weight [nondim] + + fac = 1.0e40 ; if (abs(b) > 1.0e-20*tau) fac = (1 + tau / b)**2 + +end function fac_fn + + +!> Reconstruct the tracer (e.g., PV, vorticity) onto the point i-1/2 using a third-order WENO scheme +!! This reconstruction is thickness-weighted +subroutine weno_three_h_weight_reconstruction(q4, h4, u4, & + h_tiny, u, qr, velocity_smoothing) + real, intent(in) :: q4(4) !< Tracer value times thickness on points i-2, i-1, i, i+1 [A ~> a] + real, intent(in) :: h4(4) !< Thickness values on points i-2, i-1, i, i+1 [L ~> m] + real, optional, intent(in) :: u4(4) !< Velocity values on points i-2, i-1, i, i+1 + !![L T-1 ~> m s-1] + real, intent(in) :: h_tiny !< A tiny thickness to prevent division by zero [L ~> m] + real, intent(in) :: u !< Velocity or thickness flux on point i-1/2 + !! [L T-1 ~> m s-1] or [L2 T-1 ~> m2 s-1] + real, intent(inout) :: qr !< Reconstruction of tracer q on point i-1/2 [A ~> a] + logical, intent(in) :: velocity_smoothing !< If true, use velocity to compute smoothness indicator + real :: vr ! Reconstruction of hq [A ~> a] + real :: hr ! Reconstruction of h [L ~> m] + real :: c0, c1 ! Intermediate reconstruction of q [A ~> a] + real :: d0, d1 ! Intermediate reconstruction of h [L ~> m] + real :: b0, b1 ! Smoothness indicator [A ~> a] + real :: tau ! Difference of smoothness indicator [A ~> a] + real :: w0, w1 ! Weights [nondim] + real :: s ! Temporary variables [nondim] + real, parameter :: C2_3 = 2.0/3.0 ! The ratio of 2/3 [nondim] + real, parameter :: C1_3 = 1.0/3.0 ! The ratio of 1/3 [nondim] + + if (u>0.) then + call weno_three_reconstruction_0(q4(2:3), c0) ! Reconstruction in the second upwind stencil + call weno_three_reconstruction_1(q4(1:2), c1) ! Reconstruction in the first upwind stencil + + call weno_three_reconstruction_0(h4(2:3), d0) + call weno_three_reconstruction_1(h4(1:2), d1) + if (velocity_smoothing) then + call weno_three_weight(u4(2:3), b0) ! Smoothness indicator the second upwind stencil + call weno_three_weight(u4(1:2), b1) ! Smoothness indicator the first upwind stencil + else + call weno_three_weight(q4(2:3), b0) ! Smoothness indicator the second upwind stencil + call weno_three_weight(q4(1:2), b1) ! Smoothness indicator the first upwind stencil endif - enddo + else + call weno_three_reconstruction_0(q4(3:2:-1), c0) ! Reconstruction in the second upwind stencil + call weno_three_reconstruction_1(q4(4:3:-1), c1) ! Reconstruction in the first upwind stencil + + call weno_three_reconstruction_0(h4(3:2:-1), d0) + call weno_three_reconstruction_1(h4(4:3:-1), d1) + if (velocity_smoothing) then + call weno_three_weight(u4(3:2:-1), b0) ! Smoothness indicator the second upwind stencil + call weno_three_weight(u4(4:3:-1), b1) ! Smoothness indicator the first upwind stencil + else + call weno_three_weight(q4(3:2:-1), b0) ! Smoothness indicator the second upwind stencil + call weno_three_weight(q4(4:3:-1), b1) ! Smoothness indicator the first upwind stencil + endif + endif + + tau = abs(b0-b1) + w0 = C2_3 * fac_fn(tau, b0) + w1 = C1_3 * fac_fn(tau, b1) + + s = 1. / (w0 + w1) + w0 = w0 * s ! Weights of stencils + w1 = w1 * s + + vr = (w0 * c0) + (w1 * c1) + hr = (w0 * d0) + (w1 * d1) +! vr = min(max(q4(3), q4(2)), vr) ; vr = max(min(q4(3), q4(2)), vr) !Impose a monotonicity limiter + hr = min(max(h4(3), h4(2)), hr) ; hr = max(min(h4(3), h4(2)), hr) ! A monotonicity limiter + + qr = vr / max(hr, h_tiny) + +end subroutine weno_three_h_weight_reconstruction + +!> Compute the smoothness indicator for the two-point stencil of the third-order WENO scheme +subroutine weno_three_weight(q2, w0) + real, intent(in) :: q2(2) !< Tracer values on the two-point stencil [A ~> a] + real, intent(inout) :: w0 !< Smoothness indicator for this stencil [A2 ~> a2] + + w0 = (q2(1) - q2(2))**2 + +end subroutine weno_three_weight + +!> Reconstruction in the second upwind stencil of the third-order WENO scheme +subroutine weno_three_reconstruction_0(q2, w0) + real, intent(in) :: q2(2) !< Tracer values on the two-point stencil [A ~> a] + real, intent(inout) :: w0 !< Reconstruction of the quantity [A2 ~> a2] + + w0 = (q2(1) + q2(2)) * 0.5 + +end subroutine weno_three_reconstruction_0 + +!> Reconstruction in the first upwind stencil for third-order WENO scheme +subroutine weno_three_reconstruction_1(q2, w0) + real, intent(in) :: q2(2) !< Tracer values on the two-point stencil [A ~> a] + real, intent(inout) :: w0 !< Reconstruction of the quantity [A ~> a] + + w0 = (- q2(1) + 3 * q2(2)) * 0.5 + +end subroutine weno_three_reconstruction_1 + + +!> Reconstruct the tracer (e.g., PV, vorticity) onto point i-1/2 using a fifth-order WENO scheme +!! The reconstruction is weighted by the thickness +subroutine weno_five_h_weight_reconstruction(q6, h6, u6, & + h_tiny, u, qr, velocity_smoothing) + real, intent(in) :: q6(6) + !< Tracer values on points i-3, i-2, i-1, i, i+1, i+2 [A ~> a] + real, intent(in) :: h6(6) + !< Thickness values on points i-3, i-2, i-1, i, i+1, i+2 [L ~> m] + real, optional, intent(in) :: u6(6) + !< Velocity values on points i-3, i-2, i-1, i, i+1, i+2 [L T-1 ~> m s-1] + real, intent(in) :: h_tiny !< A tiny thickness to prevent division by zero [L ~> m] + real, intent(in) :: u !< Velocity or thickness flux on point i-1/2 + !! [L T-1 ~> m s-1] or [L2 T-1 ~> m2 s-1] + logical, intent(in) :: velocity_smoothing !< If ture, use velocity to compute the smoothness indicator + real, intent(inout) :: qr !< Reconstruction of tracer q on point i-1/2 [A ~> a] + real :: vr ! Reconstruction of hq [A ~> a] + real :: hr ! Reconstruction of h [L ~> m] + real :: c0, c1, c2 ! Intermediate reconstruction of hq[A ~> a] + real :: d0, d1, d2 ! Intermediate reconstruction of h [L ~> m] + real :: b0, b1, b2 ! Smoothness indicator [A ~> a] + real :: tau ! Difference of smoothness indicators [A ~> a] + real :: w0, w1, w2 ! Weights [nondim] + real :: s ! Temporary variables [nondim] + real, parameter :: C3_10 = 3.0/10.0 ! The ratio of 3/10 [nondim] + real, parameter :: C3_5 = 3.0/5.0 ! The ratio of 3/5 [nondim] + real, parameter :: C1_10 = 1.0/10.0 ! The ratio of 1/10 [nondim] + + if (u>0.) then + call weno_five_reconstruction_0(q6(3:5), c0) ! Reconstruction in the third upwind stencil + call weno_five_reconstruction_1(q6(2:4), c1) ! Reconstruction in the second upwind stencil + call weno_five_reconstruction_2(q6(1:3), c2) ! Reconstruction in the first upwind stencil + + call weno_five_reconstruction_0(h6(3:5), d0) + call weno_five_reconstruction_1(h6(2:4), d1) + call weno_five_reconstruction_2(h6(1:3), d2) + if (velocity_smoothing) then + call weno_five_weight_0(u6(3:5), b0) ! Smoothness indicator of the third upwind stencil + call weno_five_weight_1(u6(2:4), b1) ! Smoothness indicator of the second upwind stencil + call weno_five_weight_2(u6(1:3), b2) ! Smoothness indicator of the first upwind stencil + else + call weno_five_weight_0(q6(3:5), b0) + call weno_five_weight_1(q6(2:4), b1) + call weno_five_weight_2(q6(1:3), b2) + endif + else + call weno_five_reconstruction_0(q6(4:2:-1), c0) ! Reconstruction in the third upwind stencil + call weno_five_reconstruction_1(q6(5:3:-1), c1) ! Reconstruction in the second upwind stencil + call weno_five_reconstruction_2(q6(6:4:-1), c2) ! Reconstruction in the first upwind stencil + + call weno_five_reconstruction_0(h6(4:2:-1), d0) + call weno_five_reconstruction_1(h6(5:3:-1), d1) + call weno_five_reconstruction_2(h6(6:4:-1), d2) + if (velocity_smoothing) then + call weno_five_weight_0(u6(4:2:-1), b0) ! Smoothness indicator of the third upwind stencil + call weno_five_weight_1(u6(5:3:-1), b1) ! Smoothness indicator of the second upwind stencil + call weno_five_weight_2(u6(6:4:-1), b2) ! Smoothness indicator of the first upwind stencil + else + call weno_five_weight_0(q6(4:2:-1), b0) + call weno_five_weight_1(q6(5:3:-1), b1) + call weno_five_weight_2(q6(6:4:-1), b2) + endif + endif + + tau = abs(b0 - b2) + w0 = C3_10 * fac_fn(tau, b0) + w1 = C3_5 * fac_fn(tau, b1) + w2 = C1_10 * fac_fn(tau, b2) + + s = 1. / ((w0 + w1) + w2) + w0 = w0 * s ! Weights of stencils + w1 = w1 * s + w2 = w2 * s + + vr = ((w0 * c0) + (w1 * c1)) + (w2 * c2) + hr = ((w0 * d0) + (w1 * d1)) + (w2 * d2) +! vr = min(max(q6(3), q6(4)), vr) ; vr = max(min(q6(3), q6(4)), vr) !Impose a monotonicity limiter + hr = min(max(h6(3), h6(4)), hr) ; hr = max(min(h6(3), h6(4)), hr) !Impose a monotonicity limiter + + qr = vr / max(hr, h_tiny) + +end subroutine weno_five_h_weight_reconstruction + +!> Compute the smoothness indicator for the third upwind stencil of the fifth-order WENO scheme +subroutine weno_five_weight_0(q3, w0) + real, intent(in) :: q3(3) !< Tracer values on the three-point stencil [A ~> a] + real, intent(inout) :: w0 !< Smoothness indicator for this stencil [A2 ~> a2] + + w0 = (q3(1) * ((10 * q3(1) - 31 * q3(2)) + 11 * q3(3))) + & + ((q3(2) * (25 * q3(2) - 19 * q3(3))) + 4 * (q3(3) * q3(3))) + +end subroutine weno_five_weight_0 + +!> Compute the smoothness indicator for the second upwind stencil of the fifth-order WENO scheme +subroutine weno_five_weight_1(q3, w1) + real, intent(in) :: q3(3) !< Tracer values on the three-point stencil [A ~> a] + real, intent(inout) :: w1 !< Smoothness indicator for this stencil [A2 ~> a2] + + w1 = (q3(1) * ((4 * q3(1) - 13 * q3(2)) + 5 * q3(3))) + & + ((q3(2) * (13 * q3(2) - 13 * q3(3))) + 4 * (q3(3) * q3(3))) + +end subroutine weno_five_weight_1 + +!> Compute the smoothness indicator for the first upwind stencil of the fifth-order WENO scheme +subroutine weno_five_weight_2(q3, w2) + real, intent(in) :: q3(3) !< Tracer values on the three-point stencil [A ~> a] + real, intent(inout) :: w2 !< Smoothness indicator for this stencil [A2 ~> a2] + + w2 = (q3(1) * ((4 * q3(1) - 19 * q3(2)) + 11 * q3(3))) + & + ((q3(2) * (25 * q3(2) - 31 * q3(3))) + 10 * (q3(3) * q3(3))) + +end subroutine weno_five_weight_2 + +!> Reconstruction in the third upwind stencil of the fifth-order WENO scheme +subroutine weno_five_reconstruction_0(q3, p0) + real, intent(in) :: q3(3) !< Tracer values on three points [A ~> a] + real, intent(inout) :: p0 !< Reconstruction of the quantity [A ~> a] + real, parameter :: C1_6 = 1.0/6.0 ! One sixth [nondim] + + p0 = ((2*q3(1) + 5*q3(2)) - q3(3)) * C1_6 + +end subroutine weno_five_reconstruction_0 + +!> Reconstruction in the second upwind stencil of the fifth-order WENO scheme +subroutine weno_five_reconstruction_1(q3, p1) + real, intent(in) :: q3(3) !< Tracer values on the three-point stencil [A ~> a] + real, intent(inout) :: p1 !< Reconstruction of the quantity [A ~> a] + real, parameter :: C1_6 = 1.0/6.0 ! One sixth [nondim] + + p1 = ((-q3(1) + 5*q3(2)) + 2*q3(3)) * C1_6 + +end subroutine weno_five_reconstruction_1 + +!> Reconstruction in the first upwind stencil of the fifth-order WENO scheme +subroutine weno_five_reconstruction_2(q3, p2) + real, intent(in) :: q3(3) !< Tracer values on the three-point stencil [A ~> a] + real, intent(inout) :: p2 !< Reconstruction of the quantity [A ~> a] + real, parameter :: C1_6 = 1.0/6.0 ! One sixth [nondim] + + p2 = ((2*q3(1) - 7*q3(2)) + 11*q3(3)) * C1_6 + +end subroutine weno_five_reconstruction_2 + + +!> Reconstruct the tracer (e.g., PV, vorticity) onto point i-1/2 using a seventh-order WENO scheme +!! This reconstruction computes a thickness weighted average of PV +subroutine weno_seven_h_weight_reconstruction(q8, h8, u8, & + h_tiny, u, qr, velocity_smoothing) + real, intent(in) :: q8(8) + !< Tracer values on points i-4, i-3, i-2, i-1, i, i+1, i+2, i+3 + real, intent(in) :: h8(8) + !< Thickness on the same tracer points i-4, i-3, i-2, i-1, i, i+1, i+2, i+3 [L ~> m] + real, optional, intent(in) :: u8(8) + !< Velocity values on points i-4, i-3, i-2, i-1, i, i+1, i+2, i+3 [L T-1 ~> m s-1] + real, intent(in) :: h_tiny !< A tiny thickness to prevent division by zero [L ~> m] + real, intent(in) :: u !< Velocity or thickness flux on point i-1/2 + !! [L T-1 ~> m s-1] or [L2 T-1 ~> m2 s-1] + logical, intent(in) :: velocity_smoothing !< If true, use velocity to compute the smoothness indicator + real, intent(inout) :: qr !< Reconstruction of tracer q on point i-1/2 [A ~> a] + real :: vr ! Reconstruction of hq [A ~> a] + real :: hr ! Reconstruction of h [L ~> m] + real :: c0, c1, c2, c3 ! Intermediate reconstruction of hq [A ~> a] + real :: d0, d1, d2, d3 ! Intermediate reconstruction of h [L ~> m] + real :: b0, b1, b2, b3 ! Smoothness indicator [A ~> a] + real :: tau ! Difference of smoothness indicators [A ~> a] + real :: w0, w1, w2, w3 ! Weights [nondim] + real :: s ! Temporary variables [nondim] + real, parameter :: C4_35 = 4.0/35.0 ! The ratio of 4/35 [nondim] + real, parameter :: C18_35 = 18.0/35.0 ! The ratio of 18/35 [nondim] + real, parameter :: C12_35 = 12.0/35.0 ! The ratio of 12/35 [nondim] + real, parameter :: C1_35 = 1.0/35.0 ! The ratio of 1/35 [nondim] + + if (u>0.) then + call weno_seven_reconstruction_0(q8(4:7), c0) ! Reconstruction in the fourth upwind stencil + call weno_seven_reconstruction_1(q8(3:6), c1) ! Reconstruction in the third upwind stencil + call weno_seven_reconstruction_2(q8(2:5), c2) ! Reconstruction in the second upwind stencil + call weno_seven_reconstruction_3(q8(1:4), c3) ! Reconstruction in the first upwind stencil + + call weno_seven_reconstruction_0(h8(4:7), d0) ! Reconstruction in the fourth upwind stencil + call weno_seven_reconstruction_1(h8(3:6), d1) ! Reconstruction in the third upwind stencil + call weno_seven_reconstruction_2(h8(2:5), d2) ! Reconstruction in the second upwind stencil + call weno_seven_reconstruction_3(h8(1:4), d3) ! Reconstruction in the first upwind stencil + if (velocity_smoothing) then + call weno_seven_weight_0(u8(4:7), b0) ! Smoothness indicator of the fourth upwind stencil + call weno_seven_weight_1(u8(3:6), b1) ! Smoothness indicator of the third upwind stencil + call weno_seven_weight_2(u8(2:5), b2) ! Smoothness indicator of the second upwind stencil + call weno_seven_weight_3(u8(1:4), b3) ! Smoothness indicator of the first upwind stencil + else + call weno_seven_weight_0(q8(4:7), b0) + call weno_seven_weight_1(q8(3:6), b1) + call weno_seven_weight_2(q8(2:5), b2) + call weno_seven_weight_3(q8(1:4), b3) + endif + else + call weno_seven_reconstruction_0(q8(5:2:-1), c0) ! Reconstruction in the fourth upwind stencil + call weno_seven_reconstruction_1(q8(6:3:-1), c1) ! Reconstruction in the third upwind stencil + call weno_seven_reconstruction_2(q8(7:4:-1), c2) ! Reconstruction in the second upwind stencil + call weno_seven_reconstruction_3(q8(8:5:-1), c3) ! Reconstruction in the first upwind stencil + + call weno_seven_reconstruction_0(h8(5:2:-1), d0) + call weno_seven_reconstruction_1(h8(6:3:-1), d1) + call weno_seven_reconstruction_2(h8(7:4:-1), d2) + call weno_seven_reconstruction_3(h8(8:5:-1), d3) + if (velocity_smoothing) then + call weno_seven_weight_0(u8(5:2:-1), b0) ! Smoothness indicator of the fourth upwind stencil + call weno_seven_weight_1(u8(6:3:-1), b1) ! Smoothness indicator of the third upwind stencil + call weno_seven_weight_2(u8(7:4:-1), b2) ! Smoothness indicator of the second upwind stencil + call weno_seven_weight_3(u8(8:5:-1), b3) ! Smoothness indicator of the first upwind stencil + else + call weno_seven_weight_0(q8(5:2:-1), b0) + call weno_seven_weight_1(q8(6:3:-1), b1) + call weno_seven_weight_2(q8(7:4:-1), b2) + call weno_seven_weight_3(q8(8:5:-1), b3) + endif endif -end subroutine gradKE + tau = abs((b0 - b3) + 3 * (b1 - b2)) + w0 = C4_35 * fac_fn(tau, b0) + w1 = C18_35 * fac_fn(tau, b1) + w2 = C12_35 * fac_fn(tau, b2) + w3 = C1_35 * fac_fn(tau, b3) + + s = 1. / ((w0 + w1) + (w2 + w3)) + w0 = w0 * s ! Weights of the stencils + w1 = w1 * s + w2 = w2 * s + w3 = w3 * s + + vr = ((w0 * c0) + (w1 * c1)) + ((w2 * c2) + (w3 * c3)) + hr = ((w0 * d0) + (w1 * d1)) + ((w2 * d2) + (w3 * d3)) + +! vr = min(max(q4, q5), vr) ; vr = max(min(q4, q5), vr) + hr = min(max(h8(4), h8(5)), hr) ; hr = max(min(h8(4), h8(5)), hr) ! Impose a monotonicity limiter + + qr = vr / max(hr, h_tiny) + +end subroutine weno_seven_h_weight_reconstruction + +!> Compute the smoothness indicator for the fourth upwind stencil of the seventh-order WENO scheme +subroutine weno_seven_weight_0(q4, w0) + real, intent(in) :: q4(4) !< Tracer values on the four-point stencil [A ~> a] + real, intent(inout) :: w0 !< Smoothness indicator for this stencil [A2 ~> a2] + + ! Coefficients from Balsara and Shu (2000). The division by 1000 will be normalized out by fac_fn + w0 = ((q4(1) * ((2.107 * q4(1) - 9.402 * q4(2)) + (7.042 * q4(3) - 1.854 * q4(4)))) + & + (q4(2) * ((11.003 * q4(2) - 17.246 * q4(3)) + 4.642 * q4(4)))) + & + ((q4(3) * (7.043 * q4(3) - 3.882 * q4(4))) + 0.547 * (q4(4) * q4(4))) + +end subroutine weno_seven_weight_0 + +!> Compute the smoothness indicator for the third upwind stencil of the seventh-order WENO scheme +subroutine weno_seven_weight_1(q4, w1) + real, intent(in) :: q4(4) !< Tracer values on the four-point stencil [A ~> a] + real, intent(inout) :: w1 !< Smoothness indicator for this stencil [A2 ~> a2] + + ! Coefficients from Balsara and Shu (2000). The division by 1000 will be normalized out by fac_fn + w1 = ((q4(1) * ((0.547 * q4(1) - 2.522 * q4(2)) + (1.922 * q4(3) - 0.494 * q4(4)))) + & + (q4(2) * ((3.443 * q4(2) - 5.966 * q4(3)) + 1.602 * q4(4)))) + & + ((q4(3) * (2.843 * q4(3) - 1.642 * q4(4))) + 0.267 * (q4(4) * q4(4))) + +end subroutine weno_seven_weight_1 + +!> Compute the smoothness indicator for the second upwind stencil of the seventh-order WENO scheme +subroutine weno_seven_weight_2(q4, w2) + real, intent(in) :: q4(4) !< Tracer values on the four-point stencil [A ~> a] + real, intent(inout) :: w2 !< Smoothness indicator for this stencil [A2 ~> a2] + + ! Coefficients from Balsara and Shu (2000). The division by 1000 will be normalized out by fac_fn + w2 = ((q4(1) * ((0.267 * q4(1) - 1.642 * q4(2)) + (1.602 * q4(3) - 0.494 * q4(4)))) + & + (q4(2) * ((2.843 * q4(2) - 5.966 * q4(3)) + 1.922 * q4(4)))) + & + ((q4(3) * (3.443 * q4(3) - 2.522 * q4(4))) + 0.547 * (q4(4) * q4(4))) + +end subroutine weno_seven_weight_2 + +!> Compute smoothness indicator for the first upwind stencil of the seventh-order WENO scheme +subroutine weno_seven_weight_3(q4, w3) + real, intent(in) :: q4(4) !< Tracer values on the four-point stencil [A ~> a] + real, intent(inout) :: w3 !< Smoothness indicator for this stencil [A2 ~> a2] + + ! Coefficients from Balsara and Shu (2000). The division by 1000 will be normalized out by fac_fn + w3 = ((q4(1) * ((0.547 * q4(1) - 3.882 * q4(2)) + (4.642 * q4(3) - 1.854 * q4(4)))) + & + (q4(2) * ((7.043 * q4(2) - 17.246 * q4(3)) + 7.042 * q4(4)))) + & + ((q4(3) * (11.003 * q4(3) - 9.402 * q4(4))) + 2.107 * (q4(4) * q4(4))) + +end subroutine weno_seven_weight_3 + +!> Reconstruction in the fourth upwind stencil for seventh-order WENO scheme +subroutine weno_seven_reconstruction_0(q4, p0) + real, intent(in) :: q4(4) !< Tracer values on the four-point stencil [A ~> a] + real, intent(inout) :: p0 !< Reconstruction of the quantity [A ~> a] + real, parameter :: C1_24 = 1.0/24.0 ! One twenty fourth [nondim] + + p0 = (((6 * q4(1) + 26 * q4(2)) - 10 * q4(3)) + 2 * q4(4)) * C1_24 + +end subroutine weno_seven_reconstruction_0 + +!> Reconstruction in the third upwind stencil for seventh-order WENO scheme +subroutine weno_seven_reconstruction_1(q4, p1) + real, intent(in) :: q4(4) !< Tracer values on the four-point stencil [A ~> a] + real, intent(inout) :: p1 !< Reconstruction of the quantity [A ~> a] + real, parameter :: C1_24 = 1.0/24.0 ! One twenty fourth [nondim] + + p1 = (14 * (q4(2) + q4(3)) - 2 * (q4(1) + q4(4))) * C1_24 + +end subroutine weno_seven_reconstruction_1 + +!> Reconstruction in the second upwind stencil for seventh-order WENO scheme +subroutine weno_seven_reconstruction_2(q4, p2) + real, intent(in) :: q4(4) !< Tracer values on the four-point stencil [A ~> a] + real, intent(inout) :: p2 !< Reconstruction of the quantity [A ~> a] + real, parameter :: C1_24 = 1.0/24.0 ! One twenty fourth [nondim] + + p2 = (((2 * q4(1) - 10 * q4(2)) + 26 * q4(3)) + 6 * q4(4)) * C1_24 + +end subroutine weno_seven_reconstruction_2 + +!> Reconstruction in the first upwind stencil for seventh-order WENO scheme +subroutine weno_seven_reconstruction_3(q4, p3) + real, intent(in) :: q4(4) !< Tracer values on the four-point stencil [A ~> a] + real, intent(inout) :: p3 !< Reconstruction of the quantity [A ~> a] + real, parameter :: C1_24 = 1.0/24.0 ! One twenty fourth [nondim] + + p3 = (((-6 * q4(1) + 26 * q4(2)) - 46 * q4(3)) + 50 * q4(4)) * C1_24 + +end subroutine weno_seven_reconstruction_3 + +function CoriolisAdv_stencil(CS) result(stencil) + type(CoriolisAdv_CS), intent(in) :: CS !< Control structure for MOM_CoriolisAdv + integer :: stencil !< The halo stencil size for the Coriolis advection scheme + + stencil = 2 + if (CS%Coriolis_Scheme == wenovi7th_PV_ENSTRO) stencil = 4 + if (CS%Coriolis_Scheme == wenovi5th_PV_ENSTRO) stencil = 3 + +end function CoriolisAdv_stencil !> Initializes the control structure for MOM_CoriolisAdv subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) @@ -1158,7 +1938,10 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) "\t SADOURNY75_ENSTRO - Sadourny, 1975; enstrophy cons. \n"//& "\t ARAKAWA_LAMB81 - Arakawa & Lamb, 1981; En. + Enst.\n"//& "\t ARAKAWA_LAMB_BLEND - A blend of Arakawa & Lamb with \n"//& - "\t Arakawa & Hsu and Sadourny energy", & + "\t Arakawa & Hsu and Sadourny energy \n"//& + "\t WENOVI5TH_PV_ENSTRO - 5th-order WENO PV enstrophy \n"//& + "\t WENOVI3RD_PV_ENSTRO - 3rd-order WENO PV enstrophy \n"//& + "\t WENOVI7TH_PV_ENSTRO - 7th-order WENO PV enstrophy \n", & default=SADOURNY75_ENERGY_STRING) tmpstr = uppercase(tmpstr) select case (tmpstr) @@ -1175,11 +1958,25 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) case (ROBUST_ENSTRO_STRING) CS%Coriolis_Scheme = ROBUST_ENSTRO CS%Coriolis_En_Dis = .false. + case (WENOVI7TH_PV_ENSTRO_STRING) + CS%Coriolis_Scheme = wenovi7th_PV_ENSTRO + case (WENOVI5TH_PV_ENSTRO_STRING) + CS%Coriolis_Scheme = wenovi5th_PV_ENSTRO + case (WENOVI3RD_PV_ENSTRO_STRING) + CS%Coriolis_Scheme = wenovi3rd_PV_ENSTRO case default call MOM_mesg('CoriolisAdv_init: Coriolis_Scheme ="'//trim(tmpstr)//'"', 0) call MOM_error(FATAL, "CoriolisAdv_init: Unrecognized setting "// & "#define CORIOLIS_SCHEME "//trim(tmpstr)//" found in input file.") end select + + if (CS%Coriolis_Scheme == wenovi7th_PV_ENSTRO .or. & + CS%Coriolis_Scheme == wenovi5th_PV_ENSTRO .or. CS%Coriolis_Scheme == wenovi3rd_PV_ENSTRO) then + call get_param(param_file, mdl, "WENO_VELOCITY_SMOOTH", CS%weno_velocity_smooth, & + "If true, use velocity to compute weighting for WENO. ", & + default=.false.) + endif + if (CS%Coriolis_Scheme == AL_BLEND) then call get_param(param_file, mdl, "CORIOLIS_BLEND_WT_LIN", CS%wt_lin_blend, & "A weighting value for the ratio of inverse thicknesses, "//& @@ -1220,19 +2017,26 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) call get_param(param_file, mdl, "KE_SCHEME", tmpstr, & "KE_SCHEME selects the discretization for acceleration "//& "due to the kinetic energy gradient. Valid values are: \n"//& - "\t KE_ARAKAWA, KE_SIMPLE_GUDONOV, KE_GUDONOV", & + "\t KE_ARAKAWA, KE_SIMPLE_GUDONOV, KE_GUDONOV, KE_UP3", & default=KE_ARAKAWA_STRING) tmpstr = uppercase(tmpstr) select case (tmpstr) case (KE_ARAKAWA_STRING); CS%KE_Scheme = KE_ARAKAWA case (KE_SIMPLE_GUDONOV_STRING); CS%KE_Scheme = KE_SIMPLE_GUDONOV case (KE_GUDONOV_STRING); CS%KE_Scheme = KE_GUDONOV + case (KE_UP3_STRING); CS%KE_Scheme = KE_UP3 case default call MOM_mesg('CoriolisAdv_init: KE_Scheme ="'//trim(tmpstr)//'"', 0) call MOM_error(FATAL, "CoriolisAdv_init: "// & "#define KE_SCHEME "//trim(tmpstr)//" in input file is invalid.") end select + if (CS%KE_Scheme == KE_UP3) then + call get_param(param_file, mdl, "KE_USE_LIMITER", CS%KE_use_limiter, & + "If true, use Koren limiter for KE_UP3 scheme", & + default=.True.) + endif + ! Set PV_Adv_Scheme (selects discretization of PV advection) call get_param(param_file, mdl, "PV_ADV_SCHEME", tmpstr, & "PV_ADV_SCHEME selects the discretization for PV "//& @@ -1259,146 +2063,119 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) CS%id_gKEu = register_diag_field('ocean_model', 'gKEu', diag%axesCuL, Time, & 'Zonal Acceleration from Grad. Kinetic Energy', 'm s-2', conversion=US%L_T2_to_m_s2) - if (CS%id_gKEu > 0) call safe_alloc_ptr(AD%gradKEu,IsdB,IedB,jsd,jed,nz) CS%id_gKEv = register_diag_field('ocean_model', 'gKEv', diag%axesCvL, Time, & 'Meridional Acceleration from Grad. Kinetic Energy', 'm s-2', conversion=US%L_T2_to_m_s2) - if (CS%id_gKEv > 0) call safe_alloc_ptr(AD%gradKEv,isd,ied,JsdB,JedB,nz) CS%id_rvxu = register_diag_field('ocean_model', 'rvxu', diag%axesCvL, Time, & 'Meridional Acceleration from Relative Vorticity', 'm s-2', conversion=US%L_T2_to_m_s2) - if (CS%id_rvxu > 0) call safe_alloc_ptr(AD%rv_x_u,isd,ied,JsdB,JedB,nz) CS%id_rvxv = register_diag_field('ocean_model', 'rvxv', diag%axesCuL, Time, & 'Zonal Acceleration from Relative Vorticity', 'm s-2', conversion=US%L_T2_to_m_s2) - if (CS%id_rvxv > 0) call safe_alloc_ptr(AD%rv_x_v,IsdB,IedB,jsd,jed,nz) + + CS%id_CAuS = register_diag_field('ocean_model', 'CAu_Stokes', diag%axesCuL, Time, & + 'Zonal Acceleration from Stokes Vorticity', 'm s-2', conversion=US%L_T2_to_m_s2) + ! add to AD + + CS%id_CAvS = register_diag_field('ocean_model', 'CAv_Stokes', diag%axesCvL, Time, & + 'Meridional Acceleration from Stokes Vorticity', 'm s-2', conversion=US%L_T2_to_m_s2) + ! add to AD !CS%id_hf_gKEu = register_diag_field('ocean_model', 'hf_gKEu', diag%axesCuL, Time, & ! 'Fractional Thickness-weighted Zonal Acceleration from Grad. Kinetic Energy', & ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) - !if (CS%id_hf_gKEu > 0) then - ! call safe_alloc_ptr(AD%gradKEu,IsdB,IedB,jsd,jed,nz) - ! call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) - !endif - - !CS%id_hf_gKEv = register_diag_field('ocean_model', 'hf_gKEv', diag%axesCvL, Time, & - ! 'Fractional Thickness-weighted Meridional Acceleration from Grad. Kinetic Energy', & - ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) - !if (CS%id_hf_gKEv > 0) then - ! call safe_alloc_ptr(AD%gradKEv,isd,ied,JsdB,JedB,nz) - ! call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,JsdB,JedB,nz) - !endif - CS%id_hf_gKEu_2d = register_diag_field('ocean_model', 'hf_gKEu_2d', diag%axesCu1, Time, & 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Grad. Kinetic Energy', & 'm s-2', conversion=US%L_T2_to_m_s2) - if (CS%id_hf_gKEu_2d > 0) then - call safe_alloc_ptr(AD%gradKEu,IsdB,IedB,jsd,jed,nz) - call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) - endif + !CS%id_hf_gKEv = register_diag_field('ocean_model', 'hf_gKEv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Acceleration from Grad. Kinetic Energy', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) CS%id_hf_gKEv_2d = register_diag_field('ocean_model', 'hf_gKEv_2d', diag%axesCv1, Time, & 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Grad. Kinetic Energy', & 'm s-2', conversion=US%L_T2_to_m_s2) - if (CS%id_hf_gKEv_2d > 0) then - call safe_alloc_ptr(AD%gradKEv,isd,ied,JsdB,JedB,nz) - call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,JsdB,JedB,nz) - endif CS%id_h_gKEu = register_diag_field('ocean_model', 'h_gKEu', diag%axesCuL, Time, & 'Thickness Multiplied Zonal Acceleration from Grad. Kinetic Energy', & 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) - if (CS%id_h_gKEu > 0) then - call safe_alloc_ptr(AD%gradKEu,IsdB,IedB,jsd,jed,nz) - call safe_alloc_ptr(AD%diag_hu,IsdB,IedB,jsd,jed,nz) - endif - CS%id_intz_gKEu_2d = register_diag_field('ocean_model', 'intz_gKEu_2d', diag%axesCu1, Time, & 'Depth-integral of Zonal Acceleration from Grad. Kinetic Energy', & 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) - if (CS%id_intz_gKEu_2d > 0) then - call safe_alloc_ptr(AD%gradKEu,IsdB,IedB,jsd,jed,nz) - call safe_alloc_ptr(AD%diag_hu,IsdB,IedB,jsd,jed,nz) - endif CS%id_h_gKEv = register_diag_field('ocean_model', 'h_gKEv', diag%axesCvL, Time, & 'Thickness Multiplied Meridional Acceleration from Grad. Kinetic Energy', & 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) - if (CS%id_h_gKEv > 0) then - call safe_alloc_ptr(AD%gradKEv,isd,ied,JsdB,JedB,nz) - call safe_alloc_ptr(AD%diag_hv,isd,ied,JsdB,JedB,nz) - endif - CS%id_intz_gKEv_2d = register_diag_field('ocean_model', 'intz_gKEv_2d', diag%axesCv1, Time, & 'Depth-integral of Meridional Acceleration from Grad. Kinetic Energy', & 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) - if (CS%id_intz_gKEv_2d > 0) then - call safe_alloc_ptr(AD%gradKEv,isd,ied,JsdB,JedB,nz) - call safe_alloc_ptr(AD%diag_hv,isd,ied,JsdB,JedB,nz) - endif !CS%id_hf_rvxu = register_diag_field('ocean_model', 'hf_rvxu', diag%axesCvL, Time, & ! 'Fractional Thickness-weighted Meridional Acceleration from Relative Vorticity', & - ! 'm-1 s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) - !if (CS%id_hf_rvxu > 0) then - ! call safe_alloc_ptr(AD%rv_x_u,isd,ied,JsdB,JedB,nz) - ! call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,JsdB,JedB,nz) - !endif - - !CS%id_hf_rvxv = register_diag_field('ocean_model', 'hf_rvxv', diag%axesCuL, Time, & - ! 'Fractional Thickness-weighted Zonal Acceleration from Relative Vorticity', & - ! 'm-1 s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) - !if (CS%id_hf_rvxv > 0) then - ! call safe_alloc_ptr(AD%rv_x_v,IsdB,IedB,jsd,jed,nz) - ! call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) - !endif - + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) CS%id_hf_rvxu_2d = register_diag_field('ocean_model', 'hf_rvxu_2d', diag%axesCv1, Time, & 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Relative Vorticity', & 'm s-2', conversion=US%L_T2_to_m_s2) - if (CS%id_hf_rvxu_2d > 0) then - call safe_alloc_ptr(AD%rv_x_u,isd,ied,JsdB,JedB,nz) - call safe_alloc_ptr(AD%diag_hfrac_v,isd,ied,JsdB,JedB,nz) - endif + !CS%id_hf_rvxv = register_diag_field('ocean_model', 'hf_rvxv', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Acceleration from Relative Vorticity', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) CS%id_hf_rvxv_2d = register_diag_field('ocean_model', 'hf_rvxv_2d', diag%axesCu1, Time, & 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Relative Vorticity', & 'm s-2', conversion=US%L_T2_to_m_s2) - if (CS%id_hf_rvxv_2d > 0) then - call safe_alloc_ptr(AD%rv_x_v,IsdB,IedB,jsd,jed,nz) - call safe_alloc_ptr(AD%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) - endif CS%id_h_rvxu = register_diag_field('ocean_model', 'h_rvxu', diag%axesCvL, Time, & 'Thickness Multiplied Meridional Acceleration from Relative Vorticity', & 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) - if (CS%id_h_rvxu > 0) then - call safe_alloc_ptr(AD%rv_x_u,isd,ied,JsdB,JedB,nz) - call safe_alloc_ptr(AD%diag_hv,isd,ied,JsdB,JedB,nz) - endif - CS%id_intz_rvxu_2d = register_diag_field('ocean_model', 'intz_rvxu_2d', diag%axesCv1, Time, & 'Depth-integral of Meridional Acceleration from Relative Vorticity', & 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) - if (CS%id_intz_rvxu_2d > 0) then - call safe_alloc_ptr(AD%rv_x_u,isd,ied,JsdB,JedB,nz) - call safe_alloc_ptr(AD%diag_hv,isd,ied,JsdB,JedB,nz) - endif CS%id_h_rvxv = register_diag_field('ocean_model', 'h_rvxv', diag%axesCuL, Time, & 'Thickness Multiplied Zonal Acceleration from Relative Vorticity', & 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) - if (CS%id_h_rvxv > 0) then - call safe_alloc_ptr(AD%rv_x_v,IsdB,IedB,jsd,jed,nz) - call safe_alloc_ptr(AD%diag_hu,IsdB,IedB,jsd,jed,nz) - endif - CS%id_intz_rvxv_2d = register_diag_field('ocean_model', 'intz_rvxv_2d', diag%axesCu1, Time, & 'Depth-integral of Fractional Thickness-weighted Zonal Acceleration from Relative Vorticity', & 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) - if (CS%id_intz_rvxv_2d > 0) then - call safe_alloc_ptr(AD%rv_x_v,IsdB,IedB,jsd,jed,nz) - call safe_alloc_ptr(AD%diag_hu,IsdB,IedB,jsd,jed,nz) + + ! Allocate memory needed for the diagnostics that have been enabled. + if ((CS%id_gKEu > 0) .or. (CS%id_hf_gKEu_2d > 0) .or. & + ! (CS%id_hf_gKEu > 0) .or. & + (CS%id_h_gKEu > 0) .or. (CS%id_intz_gKEu_2d > 0)) then + call safe_alloc_ptr(AD%gradKEu, IsdB, IedB, jsd, jed, nz) + endif + if ((CS%id_gKEv > 0) .or. (CS%id_hf_gKEv_2d > 0) .or. & + ! (CS%id_hf_gKEv > 0) .or. & + (CS%id_h_gKEv > 0) .or. (CS%id_intz_gKEv_2d > 0)) then + call safe_alloc_ptr(AD%gradKEv, isd, ied, JsdB, JedB, nz) + endif + if ((CS%id_rvxu > 0) .or. (CS%id_hf_rvxu_2d > 0) .or. & + ! (CS%id_hf_rvxu > 0) .or. & + (CS%id_h_rvxu > 0) .or. (CS%id_intz_rvxu_2d > 0)) then + call safe_alloc_ptr(AD%rv_x_u, isd, ied, JsdB, JedB, nz) + endif + if ((CS%id_rvxv > 0) .or. (CS%id_hf_rvxv_2d > 0) .or. & + ! (CS%id_hf_rvxv > 0) .or. & + (CS%id_h_rvxv > 0) .or. (CS%id_intz_rvxv_2d > 0)) then + call safe_alloc_ptr(AD%rv_x_v, IsdB, IedB, jsd, jed, nz) + endif + + if ((CS%id_hf_gKEv_2d > 0) .or. & + ! (CS%id_hf_gKEv > 0) .or. (CS%id_hf_rvxu > 0) .or. & + (CS%id_hf_rvxu_2d > 0)) then + call safe_alloc_ptr(AD%diag_hfrac_v, isd, ied, JsdB, JedB, nz) + endif + if ((CS%id_hf_gKEu_2d > 0) .or. & + ! (CS%id_hf_gKEu > 0) .or. (CS%id_hf_rvxv > 0) .or. & + (CS%id_hf_rvxv_2d > 0)) then + call safe_alloc_ptr(AD%diag_hfrac_u, IsdB, IedB, jsd, jed, nz) + endif + if ((CS%id_h_gKEu > 0) .or. (CS%id_intz_gKEu_2d > 0) .or. & + (CS%id_h_rvxv > 0) .or. (CS%id_intz_rvxv_2d > 0)) then + call safe_alloc_ptr(AD%diag_hu, IsdB, IedB, jsd, jed, nz) + endif + if ((CS%id_h_gKEv > 0) .or. (CS%id_intz_gKEv_2d > 0) .or. & + (CS%id_h_rvxu > 0) .or. (CS%id_intz_rvxu_2d > 0)) then + call safe_alloc_ptr(AD%diag_hv, isd, ied, JsdB, JedB, nz) endif end subroutine CoriolisAdv_init diff --git a/src/core/MOM_PressureForce.F90 b/src/core/MOM_PressureForce.F90 index 844d9db4bc..133de90434 100644 --- a/src/core/MOM_PressureForce.F90 +++ b/src/core/MOM_PressureForce.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> A thin wrapper for Boussinesq/non-Boussinesq forms of the pressure force calculation. module MOM_PressureForce -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type @@ -13,9 +15,10 @@ module MOM_PressureForce use MOM_PressureForce_Mont, only : PressureForce_Mont_Bouss, PressureForce_Mont_nonBouss use MOM_PressureForce_Mont, only : PressureForce_Mont_init use MOM_PressureForce_Mont, only : PressureForce_Mont_CS +use MOM_self_attr_load, only : SAL_CS use MOM_tidal_forcing, only : tidal_forcing_CS use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs +use MOM_variables, only : thermo_var_ptrs, accel_diag_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_ALE, only: ALE_CS implicit none ; private @@ -37,7 +40,7 @@ module MOM_PressureForce contains !> A thin layer between the model and the Boussinesq and non-Boussinesq pressure force routines. -subroutine PressureForce(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) +subroutine PressureForce(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, ADp, p_atm, pbce, eta) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -50,6 +53,7 @@ subroutine PressureForce(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, e intent(out) :: PFv !< Meridional pressure force acceleration [L T-2 ~> m s-2] type(PressureForce_CS), intent(inout) :: CS !< Pressure force control structure type(ALE_CS), pointer :: ALE_CSp !< ALE control structure + type(accel_diag_ptrs), pointer :: ADp !< Acceleration diagnostic pointers real, dimension(:,:), pointer :: p_atm !< The pressure at the ice-ocean or !! atmosphere-ocean interface [R L2 T-2 ~> Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & @@ -62,10 +66,10 @@ subroutine PressureForce(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, e if (CS%Analytic_FV_PGF) then if (GV%Boussinesq) then call PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS%PressureForce_FV, & - ALE_CSp, p_atm, pbce, eta) + ALE_CSp, ADp, p_atm, pbce, eta) else call PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS%PressureForce_FV, & - ALE_CSp, p_atm, pbce, eta) + ALE_CSp, ADp, p_atm, pbce, eta) endif else if (GV%Boussinesq) then @@ -80,7 +84,7 @@ subroutine PressureForce(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, e end subroutine Pressureforce !> Initialize the pressure force control structure -subroutine PressureForce_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) +subroutine PressureForce_init(Time, G, GV, US, param_file, diag, CS, ADp, SAL_CSp, tides_CSp) type(time_type), target, intent(in) :: Time !< Current model time type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure @@ -88,7 +92,9 @@ subroutine PressureForce_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) type(param_file_type), intent(in) :: param_file !< Parameter file handles type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(PressureForce_CS), intent(inout) :: CS !< Pressure force control structure - type(tidal_forcing_CS), intent(inout), optional :: tides_CSp !< Tide control structure + type(accel_diag_ptrs), pointer :: ADp !< Acceleration diagnostic pointers + type(SAL_CS), intent(in), optional :: SAL_CSp !< SAL control structure + type(tidal_forcing_CS), intent(in), optional :: tides_CSp !< Tide control structure #include "version_variable.h" character(len=40) :: mdl = "MOM_PressureForce" ! This module's name. @@ -103,10 +109,10 @@ subroutine PressureForce_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) if (CS%Analytic_FV_PGF) then call PressureForce_FV_init(Time, G, GV, US, param_file, diag, & - CS%PressureForce_FV, tides_CSp) + CS%PressureForce_FV, ADp, SAL_CSp, tides_CSp) else call PressureForce_Mont_init(Time, G, GV, US, param_file, diag, & - CS%PressureForce_Mont, tides_CSp) + CS%PressureForce_Mont, SAL_CSp, tides_CSp) endif end subroutine PressureForce_init diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 2a79486a5f..3509ac7d60 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -1,24 +1,30 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Finite volume pressure gradient (integrated by quadrature or analytically) module MOM_PressureForce_FV -! This file is part of MOM6. See LICENSE.md for the license. - +use MOM_debugging, only : hchksum, uvchksum use MOM_diag_mediator, only : post_data, register_diag_field use MOM_diag_mediator, only : safe_alloc_ptr, diag_ctrl, time_type use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_PressureForce_Mont, only : set_pbce_Bouss, set_pbce_nonBouss +use MOM_self_attr_load, only : calc_SAL, SAL_CS use MOM_tidal_forcing, only : calc_tidal_forcing, tidal_forcing_CS +use MOM_tidal_forcing, only : calc_tidal_forcing_legacy use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs +use MOM_variables, only : thermo_var_ptrs, accel_diag_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs +use MOM_EOS, only : calculate_density, calculate_spec_vol, EOS_domain use MOM_density_integrals, only : int_density_dz, int_specific_vol_dp use MOM_density_integrals, only : int_density_dz_generic_plm, int_density_dz_generic_ppm use MOM_density_integrals, only : int_spec_vol_dp_generic_plm use MOM_density_integrals, only : int_density_dz_generic_pcm, int_spec_vol_dp_generic_pcm -use MOM_ALE, only : TS_PLM_edge_values, TS_PPM_edge_values, ALE_CS +use MOM_density_integrals, only : diagnose_mass_weight_Z, diagnose_mass_weight_p +use MOM_ALE, only : TS_PLM_edge_values, TS_PPM_edge_values, TS_PLM_WLS_edge_values, ALE_CS implicit none ; private @@ -35,15 +41,33 @@ module MOM_PressureForce_FV !> Finite volume pressure gradient control structure type, public :: PressureForce_FV_CS ; private logical :: initialized = .false. !< True if this control structure has been initialized. - logical :: tides !< If true, apply tidal momentum forcing. - real :: Rho0 !< The density used in the Boussinesq - !! approximation [R ~> kg m-3]. + logical :: calculate_SAL = .false. !< If true, calculate self-attraction and loading. + logical :: sal_use_bpa = .false. !< If true, use bottom pressure anomaly instead of SSH + !! to calculate SAL. + logical :: tides = .false. !< If true, apply tidal momentum forcing. + real :: rho_ref !< The reference density that is subtracted off when calculating pressure + !! gradient forces [R ~> kg m-3]. + logical :: rho_ref_bug !< If true, recover a bug that mixes GV%Rho0 and CS%rho_ref in Boussinesq mode. real :: GFS_scale !< A scaling of the surface pressure gradients to !! allow the use of a reduced gravity model [nondim]. type(time_type), pointer :: Time !< A pointer to the ocean model's clock. type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. - logical :: useMassWghtInterp !< Use mass weighting in T/S interpolation + integer :: MassWghtInterp !< A flag indicating whether and how to use mass weighting in T/S interpolation + logical :: correction_intxpa !< If true, apply a correction to the value of intxpa at a selected + !! interface under ice, using matching at the end values along with a + !! 5-point quadrature integral of the hydrostatic pressure or height + !! changes along that interface. The selected interface is either at the + !! ocean's surface or in the interior, depending on reset_intxpa_integral. + logical :: reset_intxpa_integral !< If true and the surface displacement between adjacent cells + !! exceeds the vertical grid spacing, reset intxpa at the interface below + !! a trusted interior cell. (This often applies in ice shelf cavities.) + logical :: MassWghtInterpVanOnly !< If true, don't do mass weighting of T/S interpolation unless vanished + logical :: reset_intxpa_flattest !< If true, use flattest interface rather than top for reset integral + !! in cases where no best nonvanished interface + real :: h_nonvanished !< A minimal layer thickness that indicates that a layer is thick enough + !! to usefully reestimate the pressure integral across the interface + !! below it [H ~> m or kg m-2] logical :: use_inaccurate_pgf_rho_anom !< If true, uses the older and less accurate !! method to calculate density anomalies, as used prior to !! March 2018. @@ -58,11 +82,29 @@ module MOM_PressureForce_FV integer :: Recon_Scheme !< Order of the polynomial of the reconstruction of T & S !! for the finite volume pressure gradient calculation. !! By the default (1) is for a piecewise linear method - real :: Stanley_T2_det_coeff !< The coefficient correlating SGS temperature variance with - !! the mean temperature gradient in the deterministic part of - !! the Stanley form of the Brankart correction. - integer :: id_e_tidal = -1 !< Diagnostic identifier - integer :: id_tvar_sgs = -1 !< Diagnostic identifier + + logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: use_SSH_in_Z0p !< If true, adjust the height at which the pressure used in the + !! equation of state is 0 to account for the displacement of the sea + !! surface including adjustments for atmospheric or sea-ice pressure. + logical :: use_stanley_pgf !< If true, turn on Stanley parameterization in the PGF + logical :: bq_sal_tides = .false. !< If true, use an alternative method for SAL and tides + !! in Boussinesq mode + integer :: tides_answer_date = 99991231 !< Recover old answers with tides + integer :: id_e_tide = -1 !< Diagnostic identifier + integer :: id_e_tidal_eq = -1 !< Diagnostic identifier + integer :: id_e_tidal_sal = -1 !< Diagnostic identifier + integer :: id_e_sal = -1 !< Diagnostic identifier + integer :: id_rho_pgf = -1 !< Diagnostic identifier + integer :: id_rho_stanley_pgf = -1 !< Diagnostic identifier + integer :: id_p_stanley = -1 !< Diagnostic identifier + integer :: id_MassWt_u = -1 !< Diagnostic identifier + integer :: id_MassWt_v = -1 !< Diagnostic identifier + integer :: id_sal_u = -1 !< Diagnostic identifier + integer :: id_sal_v = -1 !< Diagnostic identifier + integer :: id_tides_u = -1 !< Diagnostic identifier + integer :: id_tides_v = -1 !< Diagnostic identifier + type(SAL_CS), pointer :: SAL_CSp => NULL() !< SAL control structure type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< Tides control structure end type PressureForce_FV_CS @@ -77,7 +119,7 @@ module MOM_PressureForce_FV !! To work, the following fields must be set outside of the usual (is:ie,js:je) !! range before this subroutine is called: !! h(isB:ie+1,jsB:je+1), T(isB:ie+1,jsB:je+1), and S(isB:ie+1,jsB:je+1). -subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) +subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, ADp, p_atm, pbce, eta) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -87,6 +129,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: PFv !< Meridional acceleration [L T-2 ~> m s-2] type(PressureForce_FV_CS), intent(in) :: CS !< Finite volume PGF control structure type(ALE_CS), pointer :: ALE_CSp !< ALE control structure + type(accel_diag_ptrs), pointer :: ADp !< Acceleration diagnostic pointers real, dimension(:,:), pointer :: p_atm !< The pressure at the ice-ocean !! or atmosphere-ocean interface [R L2 T-2 ~> Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(out) :: pbce !< The baroclinic pressure @@ -98,14 +141,14 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: p ! Interface pressure [R L2 T-2 ~> Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: & T_tmp, & ! Temporary array of temperatures where layers that are lighter - ! than the mixed layer have the mixed layer's properties [degC]. + ! than the mixed layer have the mixed layer's properties [C ~> degC]. S_tmp ! Temporary array of salinities where layers that are lighter - ! than the mixed layer have the mixed layer's properties [ppt]. + ! than the mixed layer have the mixed layer's properties [S ~> ppt]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & - S_t, & ! Top and bottom edge values for linear reconstructions - S_b, & ! of salinity within each layer [ppt]. - T_t, & ! Top and bottom edge values for linear reconstructions - T_b ! of temperature within each layer [degC]. + S_t, S_b, & ! Top and bottom edge values for linear reconstructions + ! of salinity within each layer [S ~> ppt]. + T_t, T_b ! Top and bottom edge values for linear reconstructions + ! of temperature within each layer [C ~> degC]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & dza, & ! The change in geopotential anomaly between the top and bottom ! of a layer [L2 T-2 ~> m2 s-2]. @@ -113,37 +156,92 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ ! the pressure anomaly at the top of the layer [R L4 T-4 ~> Pa m2 s-2]. real, dimension(SZI_(G),SZJ_(G)) :: & dp, & ! The (positive) change in pressure across a layer [R L2 T-2 ~> Pa]. - SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. - e_tidal, & ! The bottom geopotential anomaly due to tidal forces from - ! astronomical sources and self-attraction and loading [Z ~> m]. - dM, & ! The barotropic adjustment to the Montgomery potential to + SSH, & ! Sea surfae height anomaly for self-attraction and loading. Used if + ! CALCULATE_SAL is True and SAL_USE_BPA is False [Z ~> m]. + pbot, & ! Total bottom pressure for self-attraction and loading. Used if + ! CALCULATE_SAL is True and SAL_USE_BPA is True [R L2 T-2 ~> Pa]. + e_sal, & ! The bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. + e_tidal_eq, & ! The bottom geopotential anomaly due to tidal forces from astronomical sources [Z ~> m]. + e_tidal_sal, & ! The bottom geopotential anomaly due to harmonic self-attraction and loading + ! specific to tides [Z ~> m]. + e_sal_and_tide, & ! The summation of self-attraction and loading and tidal forcing, used for recovering + ! old answers only [Z ~> m]. + dM ! The barotropic adjustment to the Montgomery potential to ! account for a reduced gravity model [L2 T-2 ~> m2 s-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & za ! The geopotential anomaly (i.e. g*e + alpha_0*pressure) at the - ! interface atop a layer [L2 T-2 ~> m2 s-2]. + ! interfaces [L2 T-2 ~> m2 s-2]. real, dimension(SZI_(G)) :: Rho_cv_BL ! The coordinate potential density in the deepest variable ! density near-surface layer [R ~> kg m-3]. - real, dimension(SZIB_(G),SZJ_(G)) :: & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & intx_za ! The zonal integral of the geopotential anomaly along the - ! interface below a layer, divided by the grid spacing [L2 T-2 ~> m2 s-2]. + ! interfaces, divided by the grid spacing [L2 T-2 ~> m2 s-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & intx_dza ! The change in intx_za through a layer [L2 T-2 ~> m2 s-2]. - real, dimension(SZI_(G),SZJB_(G)) :: & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & inty_za ! The meridional integral of the geopotential anomaly along the - ! interface below a layer, divided by the grid spacing [L2 T-2 ~> m2 s-2]. + ! interfaces, divided by the grid spacing [L2 T-2 ~> m2 s-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & inty_dza ! The change in inty_za through a layer [L2 T-2 ~> m2 s-2]. + real, dimension(SZI_(G),SZJ_(G)) :: & + T_top, & ! Temperature of top layer used with correction_intxpa [C ~> degC] + S_top ! Salinity of top layer used with correction_intxpa [S ~> ppt] + real, dimension(SZIB_(G),SZJ_(G)) :: & + intx_za_cor ! Correction for curvature in intx_za [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJB_(G)) :: & + inty_za_cor ! Correction for curvature in inty_za [L2 T-2 ~> m2 s-2] + + ! These variables are used with reset_intxpa_integral. The values are taken from different + ! interfaces as a function of position. + real, dimension(SZIB_(G),SZJ_(G)) :: & + T_int_W, T_int_E, & ! Temperatures on the reference interface to the east and west of a u-point [C ~> degC] + S_int_W, S_int_E, & ! Salinities on the reference interface to the east and west of a u-point [S ~> ppt] + p_int_W, p_int_E, & ! Pressures on the reference interface to the east and west of a u-point [R L2 T-2 ~> Pa] + intx_za_nonlin, & ! Deviations in the previous version of intx_pa for the reference interface + ! from the value that would be obtained from assuming that pressure varies + ! linearly with depth along that interface [R L2 T-2 ~> Pa]. + dp_int_x, & ! The change in x in pressure along the reference interface [R L2 T-2 ~> Pa] + intx_za_cor_ri ! The correction to intx_za based on the reference interface calculations [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJB_(G)) :: & + T_int_S, T_int_N, & ! Temperatures on the reference interface to the north and south of a v-point [C ~> degC] + S_int_S, S_int_N, & ! Salinities on the reference interface to the north and south of a v-point [S ~> ppt] + p_int_S, p_int_N, & ! Pressures on the reference interface to the north and south of a v-point [R L2 T-2 ~> Pa] + inty_za_nonlin, & ! Deviations in the previous version of intx_pa for the reference interface + ! from the value that would be obtained from assuming that pressure varies + ! linearly with depth along that interface [L2 T-2 ~> m2 s-2]. + dp_int_y, & ! The change in y in geopotenial height along the reference interface [R L2 T-2 ~> Pa] + inty_za_cor_ri ! The correction to inty_za based on the reference interface calculations [L2 T-2 ~> m2 s-2] + logical, dimension(SZIB_(G),SZJ_(G)) :: & + seek_x_cor ! If true, try to find a u-point interface that would provide a better estimate + ! of the curvature terms in the intx_pa. + logical, dimension(SZI_(G),SZJB_(G)) :: & + seek_y_cor ! If true, try to find a v-point interface that would provide a better estimate + ! of the curvature terms in the inty_pa. + real, dimension(SZIB_(G),SZJ_(G)) :: & + delta_p_x ! If using flattest interface for reset integral, store x interface + ! differences [R L2 T-2 ~> Pa] + real, dimension(SZI_(G),SZJB_(G)) :: & + delta_p_y ! If using flattest interface for reset integral, store y interface + ! differences [R L2 T-2 ~> Pa] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & + MassWt_u ! The fractional mass weighting at a u-point [nondim]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & + MassWt_v ! The fractional mass weighting at a v-point [nondim]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density, [R L2 T-2 ~> Pa] (usually 2e7 Pa = 2000 dbar). + real :: dp_sfc ! The change in surface pressure between adjacent cells [R L2 T-2 ~> Pa] real :: dp_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [R L2 T-2 ~> Pa]. + real :: p_nonvanished ! nonvanshed pressure [R L2 T-2 ~> Pa] real :: I_gEarth ! The inverse of GV%g_Earth [T2 Z L-2 ~> s2 m-1] real :: alpha_anom ! The in-situ specific volume, averaged over a ! layer, less alpha_ref [R-1 ~> m3 kg-1]. logical :: use_p_atm ! If true, use the atmospheric pressure. logical :: use_ALE ! If true, use an ALE pressure reconstruction. logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. + logical :: do_more_k ! If true, there are still points where a flatter interface remains to be found. type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. real :: alpha_ref ! A reference specific volume [R-1 ~> m3 kg-1] that is used @@ -153,22 +251,33 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ ! [H T2 R-1 L-2 ~> m Pa-1 or kg m-2 Pa-1]. real :: H_to_RL2_T2 ! A factor to convert from thickness units (H) to pressure ! units [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1]. -! real :: oneatm ! 1 standard atmosphere of pressure in [R L2 T-2 ~> Pa] - real, parameter :: C1_6 = 1.0/6.0 + real :: T5(5) ! Temperatures and salinities at five quadrature points [C ~> degC] + real :: S5(5) ! Salinities at five quadrature points [S ~> ppt] + real :: p5(5) ! Pressures at five quadrature points for use with the equation of state [R L2 T-2 ~> Pa] + real :: SpV5(5) ! Specific volume anomalies at five quadrature points [R-1 ~> m3 kg-1] + real :: wt_R ! A weighting factor [nondim] + + ! real :: oneatm ! 1 standard atmosphere of pressure in [R L2 T-2 ~> Pa] + real, parameter :: C1_6 = 1.0/6.0 ! [nondim] + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state - integer :: i, j, k + integer, dimension(2) :: EOSdom_u ! The i-computational domain for the equation of state at u-velocity points + integer, dimension(2) :: EOSdom_v ! The i-computational domain for the equation of state at v-velocity points + integer :: i, j, k, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke nkmb=GV%nk_rho_varies Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) + EOSdom_u(1) = Isq - (G%IsdB-1) ; EOSdom_u(2) = Ieq - (G%IsdB-1) + EOSdom_v(1) = is - (G%isd-1) ; EOSdom_v(2) = ie - (G%isd-1) if (.not.CS%initialized) call MOM_error(FATAL, & "MOM_PressureForce_FV_nonBouss: Module must be initialized before it is used.") - if (CS%Stanley_T2_det_coeff>=0.) call MOM_error(FATAL, & - "MOM_PressureForce_FV_nonBouss: The Stanley parameterization is not yet"//& + if (CS%use_stanley_pgf) call MOM_error(FATAL, & + "MOM_PressureForce_FV_nonBouss: The Stanley parameterization is not yet "//& "implemented in non-Boussinesq mode.") use_p_atm = associated(p_atm) @@ -178,8 +287,13 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ H_to_RL2_T2 = GV%g_Earth*GV%H_to_RZ dp_neglect = GV%g_Earth*GV%H_to_RZ * GV%H_subroundoff - alpha_ref = 1.0 / CS%Rho0 + alpha_ref = 1.0 / CS%rho_ref I_gEarth = 1.0 / GV%g_Earth + p_nonvanished = GV%g_Earth*GV%H_to_RZ*CS%h_nonvanished + + if ((CS%id_MassWt_u > 0) .or. (CS%id_MassWt_v > 0)) then + MassWt_u(:,:,:) = 0.0 ; MassWt_v(:,:,:) = 0.0 + endif if (use_p_atm) then !$OMP parallel do default(shared) @@ -187,7 +301,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ p(i,j,1) = p_atm(i,j) enddo ; enddo else - ! oneatm = 101325.0 * US%kg_m3_to_R * US%m_s_to_L_T**2 ! 1 atm scaled to [R L2 T-2 ~> Pa] + ! oneatm = 101325.0 * US%Pa_to_RL2_T2 ! 1 atm scaled to [R L2 T-2 ~> Pa] !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 p(i,j,1) = 0.0 ! or oneatm @@ -232,12 +346,16 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ ! and temperature across each layer. The subscripts 't' and 'b' refer ! to top and bottom values within each layer (these are the only degrees ! of freedom needed to know the linear profile). - if ( use_ALE ) then - if ( CS%Recon_Scheme == 1 ) then + if ( use_ALE .and. (CS%Recon_Scheme == 1) ) then call TS_PLM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) - elseif ( CS%Recon_Scheme == 2) then + elseif ( use_ALE .and. (CS%Recon_Scheme == 2) ) then call TS_PPM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) - endif + elseif ( use_ALE .and. (CS%Recon_Scheme == 3) ) then + call TS_PLM_WLS_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h) + elseif (CS%reset_intxpa_integral) then + do k=1,nz ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + T_b(i,j,k) = tv%T(i,j,k) ; S_b(i,j,k) = tv%S(i,j,k) + enddo ; enddo ; enddo endif !$OMP parallel do default(shared) private(alpha_anom,dp) @@ -246,26 +364,32 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ ! subsequent calculation. if (use_EOS) then if ( use_ALE .and. CS%Recon_Scheme > 0 ) then - if ( CS%Recon_Scheme == 1 ) then + if ( CS%Recon_Scheme == 1 .or. CS%Recon_Scheme == 3 ) then call int_spec_vol_dp_generic_plm( T_t(:,:,k), T_b(:,:,k), S_t(:,:,k), S_b(:,:,k), & p(:,:,K), p(:,:,K+1), alpha_ref, dp_neglect, p(:,:,nz+1), G%HI, & tv%eqn_of_state, US, dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), inty_dza(:,:,k), & - useMassWghtInterp=CS%useMassWghtInterp) + P_surf=p(:,:,1), MassWghtInterp=CS%MassWghtInterp, & + MassWghtInterpVanOnly=CS%MassWghtInterpVanOnly, p_nv=p_nonvanished) elseif ( CS%Recon_Scheme == 2 ) then call MOM_error(FATAL, "PressureForce_FV_nonBouss: "//& "int_spec_vol_dp_generic_ppm does not exist yet.") ! call int_spec_vol_dp_generic_ppm ( tv%T(:,:,k), T_t(:,:,k), T_b(:,:,k), & ! tv%S(:,:,k), S_t(:,:,k), S_b(:,:,k), p(:,:,K), p(:,:,K+1), & ! alpha_ref, G%HI, tv%eqn_of_state, dza(:,:,k), intp_dza(:,:,k), & - ! intx_dza(:,:,k), inty_dza(:,:,k)) + ! intx_dza(:,:,k), inty_dza(:,:,k), P_surf=p(:,:,1), MassWghtInterp=CS%MassWghtInterp) endif else call int_specific_vol_dp(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), p(:,:,K), & p(:,:,K+1), alpha_ref, G%HI, tv%eqn_of_state, & US, dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), & - inty_dza(:,:,k), bathyP=p(:,:,nz+1), dP_tiny=dp_neglect, & - useMassWghtInterp=CS%useMassWghtInterp) + inty_dza(:,:,k), bathyP=p(:,:,nz+1), P_surf=p(:,:,1), dP_tiny=dp_neglect, & + MassWghtInterp=CS%MassWghtInterp, & + MassWghtInterpVanOnly=CS%MassWghtInterpVanOnly, p_nv=p_nonvanished) endif + if ((CS%id_MassWt_u > 0) .or. (CS%id_MassWt_v > 0)) & + call diagnose_mass_weight_p(p(:,:,K), p(:,:,K+1), p(:,:,nz+1), p(:,:,1), dp_neglect, CS%MassWghtInterp, & + G%HI, MassWt_u(:,:,k), MassWt_v(:,:,k), & + MassWghtInterpVanOnly=CS%MassWghtInterpVanOnly, p_nv=p_nonvanished) else alpha_anom = 1.0 / GV%Rlay(k) - alpha_ref do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -293,100 +417,462 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ !$OMP parallel do default(shared) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - za(i,j) = alpha_ref*p(i,j,nz+1) - GV%g_Earth*G%bathyT(i,j) + za(i,j,nz+1) = alpha_ref*p(i,j,nz+1) - GV%g_Earth*G%bathyT(i,j) enddo do k=nz,1,-1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) + dza(i,j,k) + za(i,j,K) = za(i,j,K+1) + dza(i,j,k) enddo ; enddo enddo + ! Calculate and add self-attraction and loading (SAL) geopotential height anomaly to interface height. + if (CS%calculate_SAL) then + if (CS%sal_use_bpa) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + pbot(i,j) = p(i,j,nz+1) + enddo ; enddo + call calc_SAL(pbot, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + SSH(i,j) = (za(i,j,1) - alpha_ref*p(i,j,1)) * I_gEarth - G%Z_ref + ! Remove above sea level topography at floodable cells + SSH(i,j) = SSH(i,j) - max(-G%bathyT(i,j)-G%meanSL(i,j), 0.0) + enddo ; enddo + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) + endif + + ! This gives new answers after the change of separating SAL from tidal forcing module. + if ((CS%tides_answer_date>20230630) .or. (.not.GV%semi_Boussinesq) .or. (.not.CS%tides)) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + za(i,j,1) = za(i,j,1) - GV%g_Earth * e_sal(i,j) + enddo ; enddo + endif + endif + + ! Calculate and add tidal geopotential height anomaly to interface height. if (CS%tides) then - ! Find and add the tidal geopotential anomaly. - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - SSH(i,j) = (za(i,j) - alpha_ref*p(i,j,1)) * I_gEarth - G%Z_ref - enddo ; enddo - call calc_tidal_forcing(CS%Time, SSH, e_tidal, G, US, CS%tides_CSp) + if ((CS%tides_answer_date>20230630) .or. (.not.GV%semi_Boussinesq)) then + call calc_tidal_forcing(CS%Time, e_tidal_eq, e_tidal_sal, G, US, CS%tides_CSp) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + za(i,j,1) = za(i,j,1) - GV%g_Earth * (e_tidal_eq(i,j) + e_tidal_sal(i,j)) + enddo ; enddo + else ! This block recreates older answers with tides. + if (.not.CS%calculate_SAL) e_sal(:,:) = 0.0 + call calc_tidal_forcing_legacy(CS%Time, e_sal, e_sal_and_tide, e_tidal_eq, e_tidal_sal, & + G, US, CS%tides_CSp) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + za(i,j,1) = za(i,j,1) - GV%g_Earth * e_sal_and_tide(i,j) + enddo ; enddo + endif + endif + + ! Find the height anomalies at the interfaces. If there are no tides and no SAL, + ! there is no need to correct za, but omitting this changes answers at roundoff. + do k=1,nz !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - GV%g_Earth * e_tidal(i,j) + za(i,j,K+1) = za(i,j,K) - dza(i,j,k) enddo ; enddo - endif + enddo - if (CS%GFS_scale < 1.0) then - ! Adjust the Montgomery potential to make this a reduced gravity model. - if (use_EOS) then - !$OMP parallel do default(shared) private(rho_in_situ) - do j=Jsq,Jeq+1 - call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p(:,j,1), rho_in_situ, & - tv%eqn_of_state, EOSdom) + if (CS%debug) then + call hchksum(za, "Pre-correction za", G%HI, haloshift=1, unscale=US%L_T_to_m_s**2) + call hchksum(p, "Pre-correction p", G%HI, haloshift=1, unscale=US%RL2_T2_to_Pa) + endif - do i=Isq,Ieq+1 - dM(i,j) = (CS%GFS_scale - 1.0) * (p(i,j,1)*(1.0/rho_in_situ(i) - alpha_ref) + za(i,j)) - enddo - enddo + ! With an ice-shelf or icebergs, this linearity condition might need to be applied + ! to a sub-surface interface. + if (CS%correction_intxpa .or. CS%reset_intxpa_integral) then + ! Determine surface temperature and salinity for use in the pressure gradient corrections + if (use_ALE .and. (CS%Recon_Scheme > 0)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + T_top(i,j) = T_t(i,j,1) ; S_top(i,j) = S_t(i,j,1) + enddo ; enddo else - !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dM(i,j) = (CS%GFS_scale - 1.0) * (p(i,j,1)*(1.0/GV%Rlay(1) - alpha_ref) + za(i,j)) + T_top(i,j) = tv%T(i,j,1) ; S_top(i,j) = tv%S(i,j,1) enddo ; enddo endif -! else -! do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 ; dM(i,j) = 0.0 ; enddo ; enddo endif - ! This order of integrating upward and then downward again is necessary with - ! a nonlinear equation of state, so that the surface geopotentials will go - ! linearly between the values at thickness points, but the bottom - ! geopotentials will not now be linear at the sub-grid-scale. Doing this - ! ensures no motion with flat isopycnals, even with a nonlinear equation of state. - !$OMP parallel do default(shared) - do j=js,je ; do I=Isq,Ieq - intx_za(I,j) = 0.5*(za(i,j) + za(i+1,j)) - enddo ; enddo - !$OMP parallel do default(shared) - do J=Jsq,Jeq ; do i=is,ie - inty_za(i,J) = 0.5*(za(i,j) + za(i,j+1)) - enddo ; enddo + if (CS%correction_intxpa) then + ! This version makes a 5 point quadrature correction for hydrostatic variations in surface + ! pressure under ice. + !$OMP parallel do default(shared) private(dp_sfc,T5,S5,p5,wt_R,SpV5) + do j=js,je ; do I=Isq,Ieq + intx_za_cor(I,j) = 0.0 + dp_sfc = (p(i+1,j,1) - p(i,j,1)) + ! If the changes in pressure and height anomaly were explicable by just a hydrostatic balance, + ! the implied specific volume would be SpV_implied = alpha_ref - (dza_x / dp_x) + if (dp_sfc * (alpha_ref*dp_sfc - (za(i+1,j,1)-za(i,j,1))) > 0.0) then + T5(1) = T_top(i,j) ; T5(5) = T_top(i+1,j) + S5(1) = S_top(i,j) ; S5(5) = S_top(i+1,j) + p5(1) = p(i,j,1) ; p5(5) = p(i+1,j,1) + do m=2,4 + wt_R = 0.25*real(m-1) + T5(m) = T5(1) + (T5(5)-T5(1))*wt_R + S5(m) = S5(1) + (S5(5)-S5(1))*wt_R + p5(m) = p5(1) + (p5(5)-p5(1))*wt_R + enddo !m + call calculate_spec_vol(T5, S5, p5, SpV5, tv%eqn_of_state, spv_ref=alpha_ref) + ! See the Boussinesq calculation of inty_pa_cor for the derivation of the following expression. + intx_za_cor(I,j) = C1_90 * (4.75*(SpV5(5)-SpV5(1)) + 5.5*(SpV5(4)-SpV5(2))) * dp_sfc + ! Note the consistency with the linear form below because (4.75 + 5.5/2) / 90 = 1/12 + endif + intx_za(I,j,1) = 0.5*(za(i,j,1) + za(i+1,j,1)) + intx_za_cor(I,j) + enddo ; enddo + !$OMP parallel do default(shared) private(dp_sfc,T5,S5,p5,wt_R,SpV5) + do J=Jsq,Jeq ; do i=is,ie + inty_za_cor(i,J) = 0.0 + dp_sfc = (p(i,j+1,1) - p(i,j,1)) + if (dp_sfc * (alpha_ref*dp_sfc - (za(i,j+1,1)-za(i,j,1))) > 0.0) then + ! The pressure/depth relationship has a positive implied specific volume. + T5(1) = T_top(i,j) ; T5(5) = T_top(i,j+1) + S5(1) = S_top(i,j) ; S5(5) = S_top(i,j+1) + p5(1) = p(i,j,1) ; p5(5) = p(i,j+1,1) + do m=2,4 + wt_R = 0.25*real(m-1) + T5(m) = T5(1) + (T5(5)-T5(1))*wt_R + S5(m) = S5(1) + (S5(5)-S5(1))*wt_R + p5(m) = p5(1) + (p5(5)-p5(1))*wt_R + enddo !m + call calculate_spec_vol(T5, S5, p5, SpV5, tv%eqn_of_state, spv_ref=alpha_ref) + ! See the Boussinesq calculation of inty_pa_cor for the derivation of the following expression. + inty_za_cor(i,J) = C1_90 * (4.75*(SpV5(5)-SpV5(1)) + 5.5*(SpV5(4)-SpV5(2))) * dp_sfc + endif + inty_za(i,J,1) = 0.5*(za(i,j,1) + za(i,j+1,1)) + inty_za_cor(i,J) + enddo ; enddo + else + ! This order of integrating upward and then downward again is necessary with + ! a nonlinear equation of state, so that the surface geopotentials will go + ! linearly between the values at thickness points, but the bottom geopotentials + ! will not now be linear at the sub-grid-scale. Doing this ensures no motion + ! with flat isopycnals, even with a nonlinear equation of state. + !$OMP parallel do default(shared) + do j=js,je ; do I=Isq,Ieq + intx_za(I,j,1) = 0.5*(za(i,j,1) + za(i+1,j,1)) + enddo ; enddo + !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie + inty_za(i,J,1) = 0.5*(za(i,j,1) + za(i,j+1,1)) + enddo ; enddo + endif + + do k=1,nz + !$OMP parallel do default(shared) + do j=js,je ; do I=Isq,Ieq + intx_za(I,j,K+1) = intx_za(I,j,K) - intx_dza(I,j,k) + enddo ; enddo + enddo do k=1,nz - ! These expressions for the acceleration have been carefully checked in - ! a set of idealized cases, and should be bug-free. !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie + inty_za(i,J,K+1) = inty_za(i,J,K) - inty_dza(i,J,k) + enddo ; enddo + enddo + + if (CS%debug) then + call uvchksum("Prelim int[xy]_za", intx_za, inty_za, G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, scalar_pair=.true., unscale=US%L_T_to_m_s**2) + call uvchksum("Prelim int[xy]_dza", intx_dza, inty_dza, G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, scalar_pair=.true., unscale=US%L_T_to_m_s**2) + endif + + if (CS%reset_intxpa_integral) then + ! Having stored the pressure gradient info, we can work out where the first nonvanished layers is + ! reset intx_za there, then adjust intx_za throughout the water column. + + ! Zero out the 2-d arrays that will be set from various reference interfaces. + T_int_W(:,:) = 0.0 ; S_int_W(:,:) = 0.0 ; p_int_W(:,:) = 0.0 + T_int_E(:,:) = 0.0 ; S_int_E(:,:) = 0.0 ; p_int_E(:,:) = 0.0 + intx_za_nonlin(:,:) = 0.0 ; intx_za_cor_ri(:,:) = 0.0 ; dp_int_x(:,:) = 0.0 + do j=js,je ; do I=Isq,Ieq + seek_x_cor(I,j) = (G%mask2dCu(I,j) > 0.) + delta_p_x(I,j) = 0.0 + enddo ; enddo + + do j=js,je ; do I=Isq,Ieq ; if (seek_x_cor(I,j)) then + if ((p(i+1,j,2) >= p(i,j,1)) .and. (p(i,j,2) >= p(i+1,j,1))) then + ! This is the typical case in the open ocean, so use the topmost interface. + T_int_W(I,j) = T_top(i,j) ; T_int_E(I,j) = T_top(i+1,j) + S_int_W(I,j) = S_top(i,j) ; S_int_E(I,j) = S_top(i+1,j) + p_int_W(I,j) = p(i,j,1) ; p_int_E(I,j) = p(i+1,j,1) + intx_za_nonlin(I,j) = intx_za(I,j,1) - 0.5*(za(i,j,1) + za(i+1,j,1)) + dp_int_x(I,j) = p(i+1,j,1)-p(i,j,1) + seek_x_cor(I,j) = .false. + endif + endif ; enddo ; enddo + + do k=1,nz + do_more_k = .false. + do j=js,je ; do I=Isq,Ieq ; if (seek_x_cor(I,j)) then + ! Find the topmost layer for which both sides are nonvanished and mass-weighting is not + ! activated in the subgrid interpolation. + if (((h(i,j,k) > CS%h_nonvanished) .and. (h(i+1,j,k) > CS%h_nonvanished)) .and. & + (max(0., p(i,j,1)-p(i+1,j,K+1), p(i+1,j,1)-p(i,j,K+1)) <= 0.0)) then + ! Store properties at the bottom of this cell to get a "good estimate" for intxpa at + ! the interface below this cell (it might have quadratic pressure dependence if sloped) + T_int_W(I,j) = T_b(i,j,k) ; T_int_E(I,j) = T_b(i+1,j,k) + S_int_W(I,j) = S_b(i,j,k) ; S_int_E(I,j) = S_b(i+1,j,k) + p_int_W(I,j) = p(i,j,K+1) ; p_int_E(I,j) = p(i+1,j,K+1) + + intx_za_nonlin(I,j) = intx_za(I,j,K+1) - 0.5*(za(i,j,K+1) + za(i+1,j,K+1)) + dp_int_x(I,j) = p(i+1,j,K+1)-p(i,j,K+1) + seek_x_cor(I,j) = .false. + else + do_more_k = .true. + endif + endif ; enddo ; enddo + if (.not.do_more_k) exit ! All reference interfaces have been found, so stop working downward. + enddo + + if (do_more_k) then + if (CS%reset_intxpa_flattest) then + ! There are still points where a correction is needed, so use flattest interface + do j=js,je ; do I=Isq,Ieq ; if (seek_x_cor(I,j)) then + ! choose top layer first + T_int_W(I,j) = T_top(i,j) ; T_int_E(I,j) = T_top(i+1,j) + S_int_W(I,j) = S_top(i,j) ; S_int_E(I,j) = S_top(i+1,j) + p_int_W(I,j) = p(i,j,1) ; p_int_E(I,j) = p(i+1,j,1) + intx_za_nonlin(I,j) = intx_za(I,j,1) - 0.5*(za(i,j,1) + za(i+1,j,1)) + dp_int_x(I,j) = p(i+1,j,1)-p(i,j,1) + delta_p_x(I,j) = abs(p(i+1,j,1)-p(i,j,1)) + do k=1,nz + if (abs(p(i+1,j,k+1)-p(i,j,k+1)) < delta_p_x(I,j)) then + ! bottom of layer is less sloped than top. Use this layer + delta_p_x(I,j) = abs(p(i+1,j,k+1)-p(i,j,k+1)) + T_int_W(I,j) = T_b(i,j,k) ; T_int_E(I,j) = T_b(i+1,j,k) + S_int_W(I,j) = S_b(i,j,k) ; S_int_E(I,j) = S_b(i+1,j,k) + p_int_W(I,j) = p(i,j,K+1) ; p_int_E(I,j) = p(i+1,j,K+1) + intx_za_nonlin(I,j) = intx_za(I,j,K+1) - 0.5*(za(i,j,K+1) + za(i+1,j,K+1)) + dp_int_x(I,j) = p(i+1,j,K+1)-p(i,j,K+1) + endif + enddo + seek_x_cor(I,j) = .false. + endif ; enddo ; enddo + else + ! There are still points where a correction is needed, so use the top interface. + do j=js,je ; do I=Isq,Ieq ; if (seek_x_cor(I,j)) then + T_int_W(I,j) = T_top(i,j) ; T_int_E(I,j) = T_top(i+1,j) + S_int_W(I,j) = S_top(i,j) ; S_int_E(I,j) = S_top(i+1,j) + p_int_W(I,j) = p(i,j,1) ; p_int_E(I,j) = p(i+1,j,1) + intx_za_nonlin(I,j) = intx_za(I,j,1) - 0.5*(za(i,j,1) + za(i+1,j,1)) + dp_int_x(I,j) = p(i+1,j,1)-p(i,j,1) + seek_x_cor(I,j) = .false. + endif ; enddo ; enddo + endif + endif + + do j=js,je + do I=Isq,Ieq + ! This expression assumes that temperature and salinity vary linearly with pressure + ! between the corners of the reference interfaces found above to get a correction to + ! intx_pa that takes nonlinearities in the equation of state into account. + ! It is derived from a 5 point quadrature estimate of the integral with a large-scale + ! linear correction so that the pressures and heights match at the end-points. It turns + ! out that this linear correction cancels out the mid-point specific volume. + ! This can be used without masking because dp_int_x and intx_za_nonlin are 0 over land. + T5(1) = T_Int_W(I,j) ; S5(1) = S_Int_W(I,j) ; p5(1) = p_Int_W(I,j) + T5(5) = T_Int_E(I,j) ; S5(5) = S_Int_E(I,j) ; p5(5) = p_Int_E(I,j) + T5(2) = 0.25*(3.0*T5(1) + T5(5)) ; T5(4) = 0.25*(3.0*T5(5) + T5(1)) ; T5(3) = 0.5*(T5(5) + T5(1)) + S5(2) = 0.25*(3.0*S5(1) + S5(5)) ; S5(4) = 0.25*(3.0*S5(5) + S5(1)) ; S5(3) = 0.5*(S5(5) + S5(1)) + p5(2) = 0.25*(3.0*p5(1) + p5(5)) ; p5(4) = 0.25*(3.0*p5(5) + p5(1)) ; p5(3) = 0.5*(p5(5) + p5(1)) + call calculate_spec_vol(T5, S5, p5, SpV5, tv%eqn_of_state, spv_ref=alpha_ref) + + ! Note the consistency with the linear form below because (4.75 + 5.5/2) / 90 = 1/12 + intx_za_cor_ri(I,j) = C1_90 * (4.75*(SpV5(5)-SpV5(1)) + 5.5*(SpV5(4)-SpV5(2))) * & + dp_int_x(I,j) - intx_za_nonlin(I,j) + enddo + enddo + + ! Repeat the calculations above for v-velocity points. + T_int_S(:,:) = 0.0 ; S_int_S(:,:) = 0.0 ; p_int_S(:,:) = 0.0 + T_int_N(:,:) = 0.0 ; S_int_N(:,:) = 0.0 ; p_int_N(:,:) = 0.0 + inty_za_nonlin(:,:) = 0.0 ; inty_za_cor_ri(:,:) = 0.0 ; dp_int_y(:,:) = 0.0 + do J=Jsq,Jeq ; do i=is,ie + seek_y_cor(i,J) = (G%mask2dCv(i,J) > 0.) + delta_p_y(i,J) = 0.0 + enddo ; enddo + + do J=Jsq,Jeq ; do i=is,ie ; if (seek_y_cor(i,J)) then + if ((p(i,j+1,2) >= p(i,j,1)) .and. (p(i,j,2) >= p(i,j+1,1))) then + ! This is the typical case in the open ocean, so use the topmost interface. + T_int_S(i,J) = T_top(i,j) ; T_int_N(i,J) = T_top(i,j+1) + S_int_S(i,J) = S_top(i,j) ; S_int_N(i,J) = S_top(i,j+1) + p_int_S(i,J) = p(i,j,1) ; p_int_N(i,J) = p(i,j+1,1) + inty_za_nonlin(i,J) = inty_za(i,J,1) - 0.5*(za(i,j,1) + za(i,j+1,1)) + dp_int_y(i,J) = p(i,j+1,1) - p(i,j,1) + seek_y_cor(i,J) = .false. + endif + endif ; enddo ; enddo + + do k=1,nz + do_more_k = .false. + do J=Jsq,Jeq ; do i=is,ie ; if (seek_y_cor(i,J)) then + ! Find the topmost layer for which both sides are nonvanished and mass-weighting is not + ! activated in the subgrid interpolation. + if (((h(i,j,k) > CS%h_nonvanished) .and. (h(i,j+1,k) > CS%h_nonvanished)) .and. & + (max(0., p(i,j,1)-p(i,j+1,K+1), p(i,j+1,1)-p(i,j,K+1)) <= 0.0)) then + ! Store properties at the bottom of this cell to get a "good estimate" for intypa at + ! the interface below this cell (it might have quadratic pressure dependence if sloped) + T_int_S(i,J) = T_b(i,j,k) ; T_int_N(i,J) = T_b(i,j+1,k) + S_int_S(i,J) = S_b(i,j,k) ; S_int_N(i,J) = S_b(i,j+1,k) + p_int_S(i,J) = p(i,j,K+1) ; p_int_N(i,J) = p(i,j+1,K+1) + inty_za_nonlin(i,J) = inty_za(i,J,K+1) - 0.5*(za(i,j,K+1) + za(i,j+1,K+1)) + dp_int_y(i,J) = p(i,j+1,K+1) - p(i,j,K+1) + seek_y_cor(i,J) = .false. + else + do_more_k = .true. + endif + endif ; enddo ; enddo + if (.not.do_more_k) exit ! All reference interfaces have been found, so stop working downward. + enddo + + if (do_more_k) then + if (CS%reset_intxpa_flattest) then + ! There are still points where a correction is needed, so use flattest interface. + do J=Jsq,Jeq ; do i=is,ie ; if (seek_y_cor(i,J)) then + ! choose top interface first + T_int_S(i,J) = T_top(i,j) ; T_int_N(i,J) = T_top(i,j+1) + S_int_S(i,J) = S_top(i,j) ; S_int_N(i,J) = S_top(i,j+1) + p_int_S(i,J) = p(i,j,1) ; p_int_N(i,J) = p(i,j+1,1) + inty_za_nonlin(i,J) = inty_za(i,J,1) - 0.5*(za(i,j,1) + za(i,j+1,1)) + dp_int_y(i,J) = p(i,j+1,1) - p(i,j,1) + delta_p_y(i,J) = abs(p(i,j+1,1)-p(i,j,1)) + do k=1,nz + if (abs(p(i,j+1,k+1)-p(i,j,k+1)) < delta_p_y(i,J)) then + ! bottom of layer is less sloped than top. Use this layer + delta_p_y(i,J) = abs(p(i,j+1,k+1)-p(i,j,k+1)) + T_int_S(i,J) = T_b(i,j,k) ; T_int_N(i,J) = T_b(i,j+1,k) + S_int_S(i,J) = S_b(i,j,k) ; S_int_N(i,J) = S_b(i,j+1,k) + p_int_S(i,J) = p(i,j,K+1) ; p_int_N(i,J) = p(i,j+1,K+1) + inty_za_nonlin(i,J) = inty_za(i,J,K+1) - 0.5*(za(i,j,K+1) + za(i,j+1,K+1)) + dp_int_y(i,J) = p(i,j+1,K+1) - p(i,j,K+1) + endif + enddo + seek_y_cor(i,J) = .false. + endif ; enddo ; enddo + else + ! There are still points where a correction is needed, so use the top interface. + do J=Jsq,Jeq ; do i=is,ie ; if (seek_y_cor(i,J)) then + T_int_S(i,J) = T_top(i,j) ; T_int_N(i,J) = T_top(i,j+1) + S_int_S(i,J) = S_top(i,j) ; S_int_N(i,J) = S_top(i,j+1) + p_int_S(i,J) = p(i,j,1) ; p_int_N(i,J) = p(i,j+1,1) + inty_za_nonlin(i,J) = inty_za(i,J,1) - 0.5*(za(i,j,1) + za(i,j+1,1)) + dp_int_y(i,J) = p(i,j+1,1) - p(i,j,1) + seek_y_cor(i,J) = .false. + endif ; enddo ; enddo + endif + endif + + do J=Jsq,Jeq + do i=is,ie + ! This expression assumes that temperature and salinity vary linearly with pressure + ! between the corners of the reference interfaces found above to get a correction to + ! intx_pa that takes nonlinearities in the equation of state into account. + ! It is derived from a 5 point quadrature estimate of the integral with a large-scale + ! linear correction so that the pressures and heights match at the end-points. It turns + ! out that this linear correction cancels out the mid-point specific volume. + ! This can be used without masking because dp_int_x and intx_za_nonlin are 0 over land. + T5(1) = T_Int_S(i,J) ; S5(1) = S_Int_S(i,J) ; p5(1) = p_Int_S(i,J) + T5(5) = T_Int_N(i,J) ; S5(5) = S_Int_N(i,J) ; p5(5) = p_Int_N(i,J) + T5(2) = 0.25*(3.0*T5(1) + T5(5)) ; T5(4) = 0.25*(3.0*T5(5) + T5(1)) ; T5(3) = 0.5*(T5(5) + T5(1)) + S5(2) = 0.25*(3.0*S5(1) + S5(5)) ; S5(4) = 0.25*(3.0*S5(5) + S5(1)) ; S5(3) = 0.5*(S5(5) + S5(1)) + p5(2) = 0.25*(3.0*p5(1) + p5(5)) ; p5(4) = 0.25*(3.0*p5(5) + p5(1)) ; p5(3) = 0.5*(p5(5) + p5(1)) + call calculate_spec_vol(T5, S5, p5, SpV5, tv%eqn_of_state, spv_ref=alpha_ref) + + ! Note the consistency with the linear form below because (4.75 + 5.5/2) / 90 = 1/12 + inty_za_cor_ri(i,J) = C1_90 * (4.75*(SpV5(5)-SpV5(1)) + 5.5*(SpV5(4)-SpV5(2))) * & + dp_int_y(i,J) - inty_za_nonlin(i,J) + enddo + enddo + + if (CS%debug) then + call uvchksum("Pre-reset int[xy]_za", intx_za, inty_za, G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, scalar_pair=.true., unscale=US%L_T_to_m_s**2) + call uvchksum("int[xy]_za_cor", intx_za_cor_ri, inty_za_cor_ri, G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, scalar_pair=.true., unscale=US%L_T_to_m_s**2) + call uvchksum("int[xy]_za_nonlin", intx_za_nonlin, inty_za_nonlin, G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, scalar_pair=.true., unscale=US%L_T_to_m_s**2) + call uvchksum("dp_int_[xy]", dp_int_x, dp_int_y, G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, unscale=US%RL2_T2_to_Pa) + endif + + ! Correct intx_pa and inty_pa at each interface using vertically constant corrections. + do K=1,nz+1 ; do j=js,je ; do I=Isq,Ieq + intx_za(I,j,K) = intx_za(I,j,K) + intx_za_cor_ri(I,j) + enddo ; enddo ; enddo + + do K=1,nz+1 ; do J=Jsq,Jeq ; do i=is,ie + inty_za(i,J,K) = inty_za(i,J,K) + inty_za_cor_ri(i,J) + enddo ; enddo ; enddo + + if (CS%debug) then + call uvchksum("Post-reset int[xy]_za", intx_za, inty_za, G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, scalar_pair=.true., unscale=US%L_T_to_m_s**2) + endif + + endif ! intx_za and inty_za have now been reset to reflect the properties of an unimpeded interface. + + !$OMP parallel do default(shared) private(dp) + do k=1,nz do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 dp(i,j) = H_to_RL2_T2 * h(i,j,k) - za(i,j) = za(i,j) - dza(i,j,k) enddo ; enddo - !$OMP parallel do default(shared) + + ! Find the horizontal pressure gradient accelerations. + ! These expressions for the accelerations have been carefully checked in + ! a set of idealized cases, and should be bug-free. do j=js,je ; do I=Isq,Ieq - intx_za(I,j) = intx_za(I,j) - intx_dza(I,j,k) - PFu(I,j,k) = ( ((za(i,j)*dp(i,j) + intp_dza(i,j,k)) - & - (za(i+1,j)*dp(i+1,j) + intp_dza(i+1,j,k))) + & - ((dp(i+1,j) - dp(i,j)) * intx_za(I,j) - & + PFu(I,j,k) = ( ((za(i,j,K+1)*dp(i,j) + intp_dza(i,j,k)) - & + (za(i+1,j,K+1)*dp(i+1,j) + intp_dza(i+1,j,k))) + & + ((dp(i+1,j) - dp(i,j)) * intx_za(I,j,K+1) - & (p(i+1,j,K) - p(i,j,K)) * intx_dza(I,j,k)) ) * & (2.0*G%IdxCu(I,j) / ((dp(i,j) + dp(i+1,j)) + dp_neglect)) enddo ; enddo - !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie - inty_za(i,J) = inty_za(i,J) - inty_dza(i,J,k) - PFv(i,J,k) = (((za(i,j)*dp(i,j) + intp_dza(i,j,k)) - & - (za(i,j+1)*dp(i,j+1) + intp_dza(i,j+1,k))) + & - ((dp(i,j+1) - dp(i,j)) * inty_za(i,J) - & + PFv(i,J,k) = (((za(i,j,K+1)*dp(i,j) + intp_dza(i,j,k)) - & + (za(i,j+1,K+1)*dp(i,j+1) + intp_dza(i,j+1,k))) + & + ((dp(i,j+1) - dp(i,j)) * inty_za(i,J,K+1) - & (p(i,j+1,K) - p(i,j,K)) * inty_dza(i,J,k))) * & (2.0*G%IdyCv(i,J) / ((dp(i,j) + dp(i,j+1)) + dp_neglect)) enddo ; enddo + enddo + + if (CS%GFS_scale < 1.0) then + ! Adjust the Montgomery potential to make this a reduced gravity model. + if (use_EOS) then + !$OMP parallel do default(shared) private(rho_in_situ) + do j=Jsq,Jeq+1 + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p(:,j,1), rho_in_situ, & + tv%eqn_of_state, EOSdom) - if (CS%GFS_scale < 1.0) then - ! Adjust the Montgomery potential to make this a reduced gravity model. + do i=Isq,Ieq+1 + dM(i,j) = (CS%GFS_scale - 1.0) * (p(i,j,1)*(1.0/rho_in_situ(i) - alpha_ref) + za(i,j,1)) + enddo + enddo + else !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dM(i,j) = (CS%GFS_scale - 1.0) * (p(i,j,1)*(1.0/GV%Rlay(1) - alpha_ref) + za(i,j,1)) + enddo ; enddo + endif + + !$OMP parallel do default(shared) + do k=1,nz do j=js,je ; do I=Isq,Ieq PFu(I,j,k) = PFu(I,j,k) - (dM(i+1,j) - dM(i,j)) * G%IdxCu(I,j) enddo ; enddo - !$OMP parallel do default(shared) do J=Jsq,Jeq ; do i=is,ie PFv(i,J,k) = PFv(i,J,k) - (dM(i,j+1) - dM(i,j)) * G%IdyCv(i,J) enddo ; enddo - endif - enddo + enddo + endif if (present(pbce)) then call set_pbce_nonBouss(p, tv_tmp, G, GV, US, CS%GFS_scale, pbce) @@ -407,8 +893,47 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ endif endif - if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_tidal, CS%diag) + if (CS%id_MassWt_u>0) call post_data(CS%id_MassWt_u, MassWt_u, CS%diag) + if (CS%id_MassWt_v>0) call post_data(CS%id_MassWt_v, MassWt_v, CS%diag) + + ! Diagnostics for tidal forcing and SAL height anomaly + if (CS%id_e_tide>0) then + ! To be consistent with old runs, tidal forcing diagnostic also includes total SAL. + ! New diagnostics are given for each individual field. + if (CS%tides_answer_date>20230630) then ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_sal_and_tide(i,j) = e_sal(i,j) + e_tidal_eq(i,j) + e_tidal_sal(i,j) + enddo ; enddo ; endif + call post_data(CS%id_e_tide, e_sal_and_tide, CS%diag) + endif + if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) + if (CS%id_e_tidal_eq>0) call post_data(CS%id_e_tidal_eq, e_tidal_eq, CS%diag) + if (CS%id_e_tidal_sal>0) call post_data(CS%id_e_tidal_sal, e_tidal_sal, CS%diag) + + ! Diagnostics for tidal forcing and SAL horizontal gradients + if (CS%calculate_SAL .and. (associated(ADp%sal_u) .or. associated(ADp%sal_v))) then + if (CS%tides) then ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_sal(i,j) = e_sal(i,j) + e_tidal_sal(i,j) + enddo ; enddo ; endif + if (associated(ADp%sal_u)) then ; do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ADp%sal_u(I,j,k) = (e_sal(i+1,j) - e_sal(i,j)) * GV%g_Earth * G%IdxCu(I,j) + enddo ; enddo ; enddo ; endif + if (associated(ADp%sal_v)) then ; do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ADp%sal_v(i,J,k) = (e_sal(i,j+1) - e_sal(i,j)) * GV%g_Earth * G%IdyCv(i,J) + enddo ; enddo ; enddo ; endif + if (CS%id_sal_u>0) call post_data(CS%id_sal_u, ADp%sal_u, CS%diag) + if (CS%id_sal_v>0) call post_data(CS%id_sal_v, ADp%sal_v, CS%diag) + endif + if (CS%tides .and. (associated(ADp%tides_u) .or. associated(ADp%tides_v))) then + if (associated(ADp%tides_u)) then ; do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ADp%tides_u(I,j,k) = (e_tidal_eq(i+1,j) - e_tidal_eq(i,j)) * GV%g_Earth * G%IdxCu(I,j) + enddo ; enddo ; enddo ; endif + if (associated(ADp%tides_v)) then ; do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ADp%tides_v(i,J,k) = (e_tidal_eq(i,j+1) - e_tidal_eq(i,j)) * GV%g_Earth * G%IdyCv(i,J) + enddo ; enddo ; enddo ; endif + if (CS%id_tides_u>0) call post_data(CS%id_tides_u, ADp%tides_u, CS%diag) + if (CS%id_tides_v>0) call post_data(CS%id_tides_v, ADp%tides_v, CS%diag) + endif end subroutine PressureForce_FV_nonBouss !> \brief Boussinesq analytically-integrated finite volume form of pressure gradient @@ -419,7 +944,7 @@ end subroutine PressureForce_FV_nonBouss !! To work, the following fields must be set outside of the usual (is:ie,js:je) !! range before this subroutine is called: !! h(isB:ie+1,jsB:je+1), T(isB:ie+1,jsB:je+1), and S(isB:ie+1,jsB:je+1). -subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, eta) +subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, ADp, p_atm, pbce, eta) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -429,6 +954,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: PFv !< Meridional acceleration [L T-2 ~> m s-2] type(PressureForce_FV_CS), intent(in) :: CS !< Finite volume PGF control structure type(ALE_CS), pointer :: ALE_CSp !< ALE control structure + type(accel_diag_ptrs), pointer :: ADp !< Acceleration diagnostic pointers real, dimension(:,:), pointer :: p_atm !< The pressure at the ice-ocean !! or atmosphere-ocean interface [R L2 T-2 ~> Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(out) :: pbce !< The baroclinic pressure @@ -440,67 +966,149 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: e ! Interface height in depth units [Z ~> m]. real, dimension(SZI_(G),SZJ_(G)) :: & - e_tidal, & ! The bottom geopotential anomaly due to tidal forces from - ! astronomical sources and self-attraction and loading [Z ~> m]. - SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. + e_sal_and_tide, & ! The summation of self-attraction and loading and tidal forcing [Z ~> m]. + e_sal, & ! The bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. + e_tidal_eq, & ! The bottom geopotential anomaly due to tidal forces from astronomical sources + ! [Z ~> m]. + e_tidal_sal, & ! The bottom geopotential anomaly due to harmonic self-attraction and loading + ! specific to tides [Z ~> m]. + Z_0p, & ! The height at which the pressure used in the equation of state is 0 [Z ~> m] + SSH, & ! Sea surfae height anomaly for self-attraction and loading. Used if + ! CALCULATE_SAL is True and SAL_USE_BPA is False [Z ~> m]. + pbot, & ! Total bottom pressure for self-attraction and loading. Used if + ! CALCULATE_SAL is True and SAL_USE_BPA is True [R L2 T-2 ~> Pa]. dM ! The barotropic adjustment to the Montgomery potential to ! account for a reduced gravity model [L2 T-2 ~> m2 s-2]. real, dimension(SZI_(G)) :: & - Rho_cv_BL ! The coordinate potential density in the deepest variable + Rho_cv_BL ! The coordinate potential density in the deepest variable ! density near-surface layer [R ~> kg m-3]. real, dimension(SZI_(G),SZJ_(G)) :: & - dz_geo, & ! The change in geopotential thickness through a layer [L2 T-2 ~> m2 s-2]. - pa, & ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at the + dz_geo ! The change in geopotential thickness through a layer [L2 T-2 ~> m2 s-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & + pa ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at the ! the interface atop a layer [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & dpa, & ! The change in pressure anomaly between the top and bottom ! of a layer [R L2 T-2 ~> Pa]. intz_dpa ! The vertical integral in depth of the pressure anomaly less the ! pressure anomaly at the top of the layer [H R L2 T-2 ~> m Pa]. - real, dimension(SZIB_(G),SZJ_(G)) :: & - intx_pa, & ! The zonal integral of the pressure anomaly along the interface + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & + intx_pa ! The zonal integral of the pressure anomaly along the interface ! atop a layer, divided by the grid spacing [R L2 T-2 ~> Pa]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & intx_dpa ! The change in intx_pa through a layer [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G),SZJB_(G)) :: & - inty_pa, & ! The meridional integral of the pressure anomaly along the + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & + inty_pa ! The meridional integral of the pressure anomaly along the ! interface atop a layer, divided by the grid spacing [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & inty_dpa ! The change in inty_pa through a layer [R L2 T-2 ~> Pa]. + real, dimension(SZIB_(G),SZJ_(G)) :: & + intx_pa_cor ! Correction for curvature in intx_pa [R L2 T-2 ~> Pa] + real, dimension(SZI_(G),SZJB_(G)) :: & + inty_pa_cor ! Correction for curvature in inty_pa [R L2 T-2 ~> Pa] + + ! These variables are used with reset_intxpa_integral. The values are taken from different + ! interfaces as a function of position. + real, dimension(SZIB_(G),SZJ_(G)) :: & + T_int_W, T_int_E, & ! Temperatures on the reference interface to the east and west of a u-point [C ~> degC] + S_int_W, S_int_E, & ! Salinities on the reference interface to the east and west of a u-point [S ~> ppt] + p_int_W, p_int_E, & ! Pressures on the reference interface to the east and west of a u-point [R L2 T-2 ~> Pa] + intx_pa_nonlin, & ! Deviations in the previous version of intx_pa for the reference interface + ! from the value that would be obtained from assuming that pressure varies + ! linearly with depth along that interface [R L2 T-2 ~> Pa]. + dgeo_x, & ! The change in x in geopotenial height along the reference interface [L2 T-2 ~> m2 s-2] + intx_pa_cor_ri ! The correction to intx_pa based on the reference interface calculations [R L2 T-2 ~> Pa] + real, dimension(SZI_(G),SZJB_(G)) :: & + T_int_S, T_int_N, & ! Temperatures on the reference interface to the north and south of a v-point [C ~> degC] + S_int_S, S_int_N, & ! Salinities on the reference interface to the north and south of a v-point [S ~> ppt] + p_int_S, p_int_N, & ! Pressures on the reference interface to the north and south of a v-point [R L2 T-2 ~> Pa] + inty_pa_nonlin, & ! Deviations in the previous version of intx_pa for the reference interface + ! from the value that would be obtained from assuming that pressure varies + ! linearly with depth along that interface [R L2 T-2 ~> Pa]. + dgeo_y, & ! The change in y in geopotenial height along the reference interface [L2 T-2 ~> m2 s-2] + inty_pa_cor_ri ! The correction to inty_pa based on the reference interface calculations [R L2 T-2 ~> Pa] + logical, dimension(SZIB_(G),SZJ_(G)) :: & + seek_x_cor ! If true, try to find a u-point interface that would provide a better estimate + ! of the curvature terms in the intx_pa. + logical, dimension(SZI_(G),SZJB_(G)) :: & + seek_y_cor ! If true, try to find a v-point interface that would provide a better estimate + ! of the curvature terms in the inty_pa. + real, dimension(SZIB_(G),SZJ_(G)) :: & + delta_z_x ! If using flattest interface for reset integral, store x interface differences [Z ~> m] + real, dimension(SZI_(G),SZJB_(G)) :: & + delta_z_y ! If using flattest interface for reset integral, store y interface differences [Z ~> m] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: & T_tmp, & ! Temporary array of temperatures where layers that are lighter - ! than the mixed layer have the mixed layer's properties [degC]. + ! than the mixed layer have the mixed layer's properties [C ~> degC]. S_tmp ! Temporary array of salinities where layers that are lighter - ! than the mixed layer have the mixed layer's properties [ppt]. + ! than the mixed layer have the mixed layer's properties [S ~> ppt]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & - S_t, S_b, T_t, T_b ! Top and bottom edge values for linear reconstructions - ! of salinity and temperature within each layer. + S_t, S_b, & ! Top and bottom edge values for linear reconstructions + ! of salinity within each layer [S ~> ppt]. + T_t, T_b ! Top and bottom edge values for linear reconstructions + ! of temperature within each layer [C ~> degC]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & + MassWt_u ! The fractional mass weighting at a u-point [nondim]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & + MassWt_v ! The fractional mass weighting at a v-point [nondim]. + real, dimension(SZI_(G),SZJ_(G)) :: & + T_top, & ! Temperature of top layer used with correction_intxpa [C ~> degC] + S_top, & ! Salinity of top layer used with correction_intxpa [S ~> ppt] + rho_top ! Density anomaly of top layer used in calculating intx_pa_cor and inty_pa_cor + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + rho_pgf, rho_stanley_pgf ! Density [R ~> kg m-3] from EOS with and without SGS T variance + ! in Stanley parameterization. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + p_stanley ! Pressure [R L2 T-2 ~> Pa] estimated with Rho_0 + real :: zeros(SZI_(G)) ! An array of zero values that can be used as an argument [various] real :: rho_in_situ(SZI_(G)) ! The in situ density [R ~> kg m-3]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density, [R L2 T-2 ~> Pa] (usually 2e7 Pa = 2000 dbar). + real :: p_surf_EOS(SZI_(G)) ! The pressure at the ocean surface determined from the surface height, + ! consistent with what is used in the density integral routines [R L2 T-2 ~> Pa] real :: p0(SZI_(G)) ! An array of zeros to use for pressure [R L2 T-2 ~> Pa]. + real :: dz_geo_sfc ! The change in surface geopotential height between adjacent cells [L2 T-2 ~> m2 s-2] + real :: GxRho0 ! The gravitational acceleration times mean ocean density [R L2 Z-1 T-2 ~> Pa m-1] + real :: GxRho_ref ! The gravitational acceleration times reference density [R L2 Z-1 T-2 ~> Pa m-1] + real :: rho0_int_density ! Rho0 used in int_density_dz_* subroutines [R ~> kg m-3] + real :: rho0_set_pbce ! Rho0 used in set_pbce_Bouss subroutine [R ~> kg m-3] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m]. real :: I_Rho0 ! The inverse of the Boussinesq reference density [R-1 ~> m3 kg-1]. - real :: G_Rho0 ! G_Earth / Rho0 in [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]. + real :: G_Rho0 ! G_Earth / Rho_0 in [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]. + real :: I_g_rho ! The inverse of the density times the gravitational acceleration [Z T2 L-2 R-1 ~> m Pa-1] real :: rho_ref ! The reference density [R ~> kg m-3]. real :: dz_neglect ! A minimal thickness [Z ~> m], like e. + real :: dz_nonvanished ! A small thickness considered to be vanished for mass weighting [Z ~> m] + real :: H_to_RL2_T2 ! A factor to convert from thickness units (H) to pressure + ! units [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1]. + real :: T5(5) ! Temperatures and salinities at five quadrature points [C ~> degC] + real :: S5(5) ! Salinities at five quadrature points [S ~> ppt] + real :: p5(5) ! Full pressures at five quadrature points for use with the equation of state [R L2 T-2 ~> Pa] + real :: pa5(5) ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at five quadrature points [R L2 T-2 ~> Pa]. + real :: r5(5) ! Densities at five quadrature points [R ~> kg m-3] + real :: wt_R ! A weighting factor [nondim] + real, parameter :: C1_6 = 1.0/6.0 ! A rational constant [nondim] + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] logical :: use_p_atm ! If true, use the atmospheric pressure. logical :: use_ALE ! If true, use an ALE pressure reconstruction. logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. + logical :: do_more_k ! If true, there are still points where a flatter interface remains to be found. type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. - real :: Tl(5) ! copy and T in local stencil [degC] - real :: mn_T ! mean of T in local stencil [degC] - real :: mn_T2 ! mean of T**2 in local stencil [degC2] - real :: hl(5) ! Copy of local stencil of H [H ~> m] - real :: r_sm_H ! Reciprocal of sum of H in local stencil [H-1 ~> m-1] - real, parameter :: C1_6 = 1.0/6.0 integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer, dimension(2) :: EOSdom_h ! The i-computational domain for the equation of state at tracer points + integer, dimension(2) :: EOSdom_u ! The i-computational domain for the equation of state at u-velocity points + integer, dimension(2) :: EOSdom_v ! The i-computational domain for the equation of state at v-velocity points integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb - integer :: i, j, k + integer :: i, j, k, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke nkmb=GV%nk_rho_varies Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) + EOSdom_u(1) = Isq - (G%IsdB-1) ; EOSdom_u(2) = Ieq - (G%IsdB-1) + EOSdom_v(1) = is - (G%isd-1) ; EOSdom_v(2) = ie - (G%isd-1) if (.not.CS%initialized) call MOM_error(FATAL, & "MOM_PressureForce_FV_Bouss: Module must be initialized before it is used.") @@ -511,101 +1119,94 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm use_ALE = .false. if (associated(ALE_CSp)) use_ALE = CS%reconstruct .and. use_EOS - if (CS%Stanley_T2_det_coeff>=0.) then - if (.not. associated(tv%varT)) call safe_alloc_ptr(tv%varT, G%isd, G%ied, G%jsd, G%jed, GV%ke) - do k=1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 - ! Strictly speaking we should estimate the *horizontal* grid-scale variance - ! but neither of the following blocks make a rotation to the horizontal - ! and instead work along coordinate. - - ! This block calculates a simple |delta T| along coordinates and does - ! not allow vanishing layer thicknesses or layers tracking topography - !! SGS variance in i-direction [degC2] - !dTdi2 = ( ( G%mask2dCu(I ,j) * G%IdxCu(I ,j) * ( tv%T(i+1,j,k) - tv%T(i,j,k) ) & - ! + G%mask2dCu(I-1,j) * G%IdxCu(I-1,j) * ( tv%T(i,j,k) - tv%T(i-1,j,k) ) & - ! ) * G%dxT(i,j) * 0.5 )**2 - !! SGS variance in j-direction [degC2] - !dTdj2 = ( ( G%mask2dCv(i,J ) * G%IdyCv(i,J ) * ( tv%T(i,j+1,k) - tv%T(i,j,k) ) & - ! + G%mask2dCv(i,J-1) * G%IdyCv(i,J-1) * ( tv%T(i,j,k) - tv%T(i,j-1,k) ) & - ! ) * G%dyT(i,j) * 0.5 )**2 - !tv%varT(i,j,k) = CS%Stanley_T2_det_coeff * 0.5 * ( dTdi2 + dTdj2 ) - - ! This block does a thickness weighted variance calculation and helps control for - ! extreme gradients along layers which are vanished against topography. It is - ! still a poor approximation in the interior when coordinates are strongly tilted. - hl(1) = h(i,j,k) * G%mask2dT(i,j) - hl(2) = h(i-1,j,k) * G%mask2dCu(I-1,j) - hl(3) = h(i+1,j,k) * G%mask2dCu(I,j) - hl(4) = h(i,j-1,k) * G%mask2dCv(i,J-1) - hl(5) = h(i,j+1,k) * G%mask2dCv(i,J) - r_sm_H = 1. / ( ( hl(1) + ( ( hl(2) + hl(3) ) + ( hl(4) + hl(5) ) ) ) + GV%H_subroundoff ) - ! Mean of T - Tl(1) = tv%T(i,j,k) ; Tl(2) = tv%T(i-1,j,k) ; Tl(3) = tv%T(i+1,j,k) - Tl(4) = tv%T(i,j-1,k) ; Tl(5) = tv%T(i,j+1,k) - mn_T = ( hl(1)*Tl(1) + ( ( hl(2)*Tl(2) + hl(3)*Tl(3) ) + ( hl(4)*Tl(4) + hl(5)*Tl(5) ) ) ) * r_sm_H - ! Adjust T vectors to have zero mean - Tl(:) = Tl(:) - mn_T ; mn_T = 0. - ! Variance of T - mn_T2 = ( hl(1)*Tl(1)*Tl(1) + ( ( hl(2)*Tl(2)*Tl(2) + hl(3)*Tl(3)*Tl(3) ) & - + ( hl(4)*Tl(4)*Tl(4) + hl(5)*Tl(5)*Tl(5) ) ) ) * r_sm_H - ! Variance should be positive but round-off can violate this. Calculating - ! variance directly would fix this but requires more operations. - tv%varT(i,j,k) = CS%Stanley_T2_det_coeff * max(0., mn_T2) - enddo ; enddo ; enddo - endif - h_neglect = GV%H_subroundoff - dz_neglect = GV%H_subroundoff * GV%H_to_Z + dz_neglect = GV%dZ_subroundoff + dz_nonvanished = GV%H_to_Z*CS%h_nonvanished I_Rho0 = 1.0 / GV%Rho0 G_Rho0 = GV%g_Earth / GV%Rho0 - rho_ref = CS%Rho0 + GxRho0 = GV%g_Earth * GV%Rho0 + rho_ref = CS%rho_ref + + if (CS%rho_ref_bug) then + rho0_int_density = rho_ref + rho0_set_pbce = rho_ref + GxRho_ref = GxRho0 + I_g_rho = 1.0 / (rho_ref * GV%g_Earth) + else + rho0_int_density = GV%Rho0 + rho0_set_pbce = GV%Rho0 + GxRho_ref = GV%g_Earth * rho_ref + I_g_rho = 1.0 / (GV%rho0 * GV%g_Earth) + endif - if (CS%tides) then - ! Determine the surface height anomaly for calculating self attraction - ! and loading. This should really be based on bottom pressure anomalies, - ! but that is not yet implemented, and the current form is correct for - ! barotropic tides. + if ((CS%id_MassWt_u > 0) .or. (CS%id_MassWt_v > 0)) then + MassWt_u(:,:,:) = 0.0 ; MassWt_v(:,:,:) = 0.0 + endif + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,nz+1) = -G%bathyT(i,j) + enddo ; enddo + + ! The following two if-blocks are used to recover old answers for self-attraction and loading + ! (SAL) and tides only. The old algorithm moves interface heights before density calculations, + ! and therefore is incorrect without SSH_IN_EOS_PRESSURE_FOR_PGF=True (added in August 2024). + ! See the code right after Pa calculation loop for the new algorithm. + + ! Calculate and add SAL geopotential anomaly to interface height (old answers) + if (CS%calculate_SAL .and. CS%tides_answer_date<=20250131) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - SSH(i,j) = -G%bathyT(i,j) - G%Z_ref + SSH(i,j) = min(-G%bathyT(i,j) - G%meanSL(i,j), 0.0) enddo do k=1,nz ; do i=Isq,Ieq+1 SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z enddo ; enddo enddo - call calc_tidal_forcing(CS%Time, SSH, e_tidal, G, US, CS%tides_CSp) + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) + + if (CS%tides_answer_date>20230630) then ! answers_date between [20230701, 20250131] + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,nz+1) = e(i,j,nz+1) - e_sal(i,j) + enddo ; enddo + endif endif -! Here layer interface heights, e, are calculated. - if (CS%tides) then - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -(G%bathyT(i,j) + e_tidal(i,j)) - enddo ; enddo - else - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -G%bathyT(i,j) - enddo ; enddo + ! Calculate and add tidal geopotential anomaly to interface height (old answers) + if (CS%tides .and. CS%tides_answer_date<=20250131) then + if (CS%tides_answer_date>20230630) then ! answers_date between [20230701, 20250131] + call calc_tidal_forcing(CS%Time, e_tidal_eq, e_tidal_sal, G, US, CS%tides_CSp) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,nz+1) = e(i,j,nz+1) - (e_tidal_eq(i,j) + e_tidal_sal(i,j)) + enddo ; enddo + else ! answers_date before 20230701 + if (.not.CS%calculate_SAL) e_sal(:,:) = 0.0 + call calc_tidal_forcing_legacy(CS%Time, e_sal, e_sal_and_tide, e_tidal_eq, e_tidal_sal, & + G, US, CS%tides_CSp) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,nz+1) = e(i,j,nz+1) - e_sal_and_tide(i,j) + enddo ; enddo + endif endif + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do k=nz,1,-1 ; do i=Isq,Ieq+1 e(i,j,K) = e(i,j,K+1) + h(i,j,k)*GV%H_to_Z enddo ; enddo ; enddo if (use_EOS) then -! With a bulk mixed layer, replace the T & S of any layers that are -! lighter than the buffer layer with the properties of the buffer -! layer. These layers will be massless anyway, and it avoids any -! formal calculations with hydrostatically unstable profiles. - if (nkmb>0) then + ! With a bulk mixed layer, replace the T & S of any layers that are lighter than the buffer + ! layer with the properties of the buffer layer. These layers will be massless anyway, and + ! it avoids any formal calculations with hydrostatically unstable profiles. tv_tmp%T => T_tmp ; tv_tmp%S => S_tmp tv_tmp%eqn_of_state => tv%eqn_of_state do i=Isq,Ieq+1 ; p_ref(i) = tv%P_Ref ; enddo - !$OMP parallel do default(shared) private(Rho_cv_BL) + !$OMP parallel do default(shared) private(Rho_cv_BL) do j=Jsq,Jeq+1 do k=1,nkmb ; do i=Isq,Ieq+1 tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) @@ -627,41 +1228,20 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm endif endif - if (CS%GFS_scale < 1.0) then - ! Adjust the Montgomery potential to make this a reduced gravity model. - if (use_EOS) then - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 - if (use_p_atm) then - call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p_atm(:,j), rho_in_situ, & - tv%eqn_of_state, EOSdom) - else - call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, & - tv%eqn_of_state, EOSdom) - endif - do i=Isq,Ieq+1 - dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * rho_in_situ(i)) * (e(i,j,1) - G%Z_ref) - enddo - enddo - else - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * GV%Rlay(1)) * (e(i,j,1) - G%Z_ref) - enddo ; enddo - endif - endif - ! I have checked that rho_0 drops out and that the 1-layer case is right. RWH. - ! If regridding is activated, do a linear reconstruction of salinity ! and temperature across each layer. The subscripts 't' and 'b' refer ! to top and bottom values within each layer (these are the only degrees ! of freedom needed to know the linear profile). - if ( use_ALE ) then - if ( CS%Recon_Scheme == 1 ) then - call TS_PLM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) - elseif ( CS%Recon_Scheme == 2 ) then - call TS_PPM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) - endif + if ( use_ALE .and. (CS%Recon_Scheme == 1) ) then + call TS_PLM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + elseif ( use_ALE .and. (CS%Recon_Scheme == 2) ) then + call TS_PPM_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + elseif ( use_ALE .and. (CS%Recon_Scheme == 3) ) then + call TS_PLM_WLS_edge_values(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h) + elseif (CS%reset_intxpa_integral) then + do k=1,nz ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + T_b(i,j,k) = tv%T(i,j,k) ; S_b(i,j,k) = tv%S(i,j,k) + enddo ; enddo ; enddo endif ! Set the surface boundary conditions on pressure anomaly and its horizontal @@ -670,27 +1250,32 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm if (use_p_atm) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - pa(i,j) = (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) + p_atm(i,j) + pa(i,j,1) = GxRho_ref * (e(i,j,1) - G%Z_ref) + p_atm(i,j) enddo ; enddo else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - pa(i,j) = (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) + pa(i,j,1) = GxRho_ref * (e(i,j,1) - G%Z_ref) + enddo ; enddo + endif + + if (CS%use_SSH_in_Z0p .and. use_p_atm) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Z_0p(i,j) = e(i,j,1) + p_atm(i,j) * I_g_rho + enddo ; enddo + elseif (CS%use_SSH_in_Z0p) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Z_0p(i,j) = e(i,j,1) + enddo ; enddo + else + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Z_0p(i,j) = G%meanSL(i,j) enddo ; enddo endif - !$OMP parallel do default(shared) - do j=js,je ; do I=Isq,Ieq - intx_pa(I,j) = 0.5*(pa(i,j) + pa(i+1,j)) - enddo ; enddo - !$OMP parallel do default(shared) - do J=Jsq,Jeq ; do i=is,ie - inty_pa(i,J) = 0.5*(pa(i,j) + pa(i,j+1)) - enddo ; enddo do k=1,nz ! Calculate 4 integrals through the layer that are required in the ! subsequent calculation. - if (use_EOS) then ! The following routine computes the integrals that are needed to ! calculate the pressure gradient force. Linear profiles for T and S are @@ -698,79 +1283,591 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! is used, whereby densities within each layer are constant no matter ! where the layers are located. if ( use_ALE .and. CS%Recon_Scheme > 0 ) then - if ( CS%Recon_Scheme == 1 ) then - call int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, & - rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & - G%HI, GV, tv%eqn_of_state, US, dpa, intz_dpa, intx_dpa, inty_dpa, & - useMassWghtInterp=CS%useMassWghtInterp, & - use_inaccurate_form=CS%use_inaccurate_pgf_rho_anom, Z_0p=G%Z_ref) + if ( CS%Recon_Scheme == 1 .or. CS%Recon_Scheme == 3 ) then + call int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, & + rho_ref, rho0_int_density, GV%g_Earth, dz_neglect, G%bathyT, & + G%HI, GV, tv%eqn_of_state, US, CS%use_stanley_pgf, dpa(:,:,k), intz_dpa(:,:,k), & + intx_dpa(:,:,k), inty_dpa(:,:,k), & + MassWghtInterp=CS%MassWghtInterp, & + use_inaccurate_form=CS%use_inaccurate_pgf_rho_anom, Z_0p=Z_0p, & + MassWghtInterpVanOnly=CS%MassWghtInterpVanOnly, h_nv=dz_nonvanished) elseif ( CS%Recon_Scheme == 2 ) then call int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & - rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & - G%HI, GV, tv%eqn_of_state, US, dpa, intz_dpa, intx_dpa, inty_dpa, & - useMassWghtInterp=CS%useMassWghtInterp, Z_0p=G%Z_ref) + rho_ref, rho0_int_density, GV%g_Earth, dz_neglect, G%bathyT, & + G%HI, GV, tv%eqn_of_state, US, CS%use_stanley_pgf, dpa(:,:,k), intz_dpa(:,:,k), & + intx_dpa(:,:,k), inty_dpa(:,:,k), & + MassWghtInterp=CS%MassWghtInterp, Z_0p=Z_0p, & + MassWghtInterpVanOnly=CS%MassWghtInterpVanOnly, h_nv=dz_nonvanished) endif else call int_density_dz(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), e(:,:,K), e(:,:,K+1), & - rho_ref, CS%Rho0, GV%g_Earth, G%HI, tv%eqn_of_state, US, dpa, & - intz_dpa, intx_dpa, inty_dpa, G%bathyT, dz_neglect, CS%useMassWghtInterp, Z_0p=G%Z_ref) + rho_ref, rho0_int_density, GV%g_Earth, G%HI, tv%eqn_of_state, US, dpa(:,:,k), & + intz_dpa(:,:,k), intx_dpa(:,:,k), inty_dpa(:,:,k), G%bathyT, e(:,:,1), dz_neglect, & + CS%MassWghtInterp, Z_0p=Z_0p, & + MassWghtInterpVanOnly=CS%MassWghtInterpVanOnly, h_nv=dz_nonvanished) endif - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - intz_dpa(i,j) = intz_dpa(i,j)*GV%Z_to_H - enddo ; enddo + if (GV%Z_to_H /= 1.0) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + intz_dpa(i,j,k) = intz_dpa(i,j,k)*GV%Z_to_H + enddo ; enddo + endif + if ((CS%id_MassWt_u > 0) .or. (CS%id_MassWt_v > 0)) & + call diagnose_mass_weight_Z(e(:,:,K), e(:,:,K+1), G%bathyT, e(:,:,1), dz_neglect, CS%MassWghtInterp, & + G%HI, MassWt_u(:,:,k), MassWt_v(:,:,k), & + MassWghtInterpVanOnly=CS%MassWghtInterpVanOnly, h_nv=CS%h_nonvanished) else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 dz_geo(i,j) = GV%g_Earth * GV%H_to_Z*h(i,j,k) - dpa(i,j) = (GV%Rlay(k) - rho_ref) * dz_geo(i,j) - intz_dpa(i,j) = 0.5*(GV%Rlay(k) - rho_ref) * dz_geo(i,j)*h(i,j,k) + dpa(i,j,k) = (GV%Rlay(k) - rho_ref) * dz_geo(i,j) + intz_dpa(i,j,k) = 0.5*(GV%Rlay(k) - rho_ref) * dz_geo(i,j)*h(i,j,k) enddo ; enddo !$OMP parallel do default(shared) do j=js,je ; do I=Isq,Ieq - intx_dpa(I,j) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_geo(i,j) + dz_geo(i+1,j)) + intx_dpa(I,j,k) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_geo(i,j) + dz_geo(i+1,j)) enddo ; enddo !$OMP parallel do default(shared) do J=Jsq,Jeq ; do i=is,ie - inty_dpa(i,J) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_geo(i,j) + dz_geo(i,j+1)) + inty_dpa(i,J,k) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_geo(i,j) + dz_geo(i,j+1)) enddo ; enddo endif + enddo - ! Compute pressure gradient in x direction + ! Set the pressure anomalies at the interfaces. + do k=1,nz + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + pa(i,j,K+1) = pa(i,j,K) + dpa(i,j,k) + enddo ; enddo + enddo + + ! Calculate and add SAL geopotential anomaly to interface height (new answers) + if (CS%calculate_SAL .and. CS%tides_answer_date>20250131) then + if (CS%sal_use_bpa) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + pbot(i,j) = pa(i,j,nz+1) - GxRho_ref * (e(i,j,nz+1) - G%Z_ref) + enddo ; enddo + call calc_SAL(pbot, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + SSH(i,j) = e(i,j,1) - G%Z_ref + ! Remove above sea level topography at floodable cells + SSH(i,j) = SSH(i,j) - max(-G%bathyT(i,j)-G%meanSL(i,j), 0.0) + enddo ; enddo + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) + endif + if (.not.CS%bq_sal_tides) then ; do K=1,nz+1 + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,K) = e(i,j,K) - e_sal(i,j) + pa(i,j,K) = pa(i,j,K) - GxRho_ref * e_sal(i,j) + enddo ; enddo + enddo ; endif + endif + + ! Calculate and add tidal geopotential anomaly to interface height (new answers) + if (CS%tides .and. CS%tides_answer_date>20250131) then + call calc_tidal_forcing(CS%Time, e_tidal_eq, e_tidal_sal, G, US, CS%tides_CSp) + if (.not.CS%bq_sal_tides) then ; do K=1,nz+1 + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,K) = e(i,j,K) - (e_tidal_eq(i,j) + e_tidal_sal(i,j)) + pa(i,j,K) = pa(i,j,K) - GxRho_ref * (e_tidal_eq(i,j) + e_tidal_sal(i,j)) + enddo ; enddo + enddo ; endif + endif + + if (CS%correction_intxpa .or. CS%reset_intxpa_integral) then + ! Determine surface temperature and salinity for use in the pressure gradient corrections + if (use_ALE .and. (CS%Recon_Scheme > 0)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + T_top(i,j) = T_t(i,j,1) ; S_top(i,j) = S_t(i,j,1) + enddo ; enddo + else + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + T_top(i,j) = tv%T(i,j,1) ; S_top(i,j) = tv%S(i,j,1) + enddo ; enddo + endif + endif + + if (CS%correction_intxpa) then + ! Determine surface density for use in the pressure gradient corrections + !$OMP parallel do default(shared) private(p_surf_EOS) + do j=Jsq,Jeq+1 + ! P_surf_EOS here is consistent with the pressure that is used in the int_density_dz routines. + do i=Isq,Ieq+1 ; p_surf_EOS(i) = -GxRho0*(e(i,j,1) - Z_0p(i,j)) ; enddo + call calculate_density(T_top(:,j), S_top(:,j), p_surf_EOS, rho_top(:,j), & + tv%eqn_of_state, EOSdom, rho_ref=rho_ref) + enddo + + if (CS%debug) then + call hchksum(rho_top, "intx_pa rho_top", G%HI, haloshift=1, unscale=US%R_to_kg_m3) + call hchksum(e(:,:,1), "intx_pa e(1)", G%HI, haloshift=1, unscale=US%Z_to_m) + call hchksum(pa(:,:,1), "intx_pa pa(1)", G%HI, haloshift=1, unscale=US%RL2_T2_to_Pa) + endif + + ! This version attempts to correct for hydrostatic variations in surface pressure under ice. + !$OMP parallel do default(shared) private(dz_geo_sfc) + do j=js,je ; do I=Isq,Ieq + intx_pa_cor(I,j) = 0.0 + dz_geo_sfc = GV%g_Earth * (e(i+1,j,1)-e(i,j,1)) + if ((dz_geo_sfc * rho_ref - (pa(i+1,j,1)-pa(i,j,1)))*dz_geo_sfc > 0.0) then + ! The pressure/depth relationship has a positive implied density given by + ! rho_implied = rho_ref - (pa(i+1,j,1)-pa(i,j,1)) / dz_geo_sfc + if (-dz_geo_sfc * (pa(i+1,j,1)-pa(i,j,1)) > & + 0.25*((rho_top(i+1,j)+rho_top(i,j))-2.0*rho_ref) * dz_geo_sfc**2) then + ! The pressure difference is at least half the size of the difference expected by hydrostatic + ! balance. This test gets rid of pressure differences that are small, e.g. open ocean. + ! Use 5 point quadrature to calculate intxpa + T5(1) = T_top(i,j) ; T5(5) = T_top(i+1,j) + S5(1) = S_top(i,j) ; S5(5) = S_top(i+1,j) + pa5(1) = pa(i,j,1) ; pa5(5) = pa(i+1,j,1) + ! Pressure input to density EOS is consistent with the pressure used in the int_density_dz routines. + p5(1) = -GxRho0*(e(i,j,1) - Z_0p(i,j)) + p5(5) = -GxRho0*(e(i+1,j,1) - Z_0p(i,j)) + do m=2,4 + wt_R = 0.25*real(m-1) + T5(m) = T5(1) + (T5(5)-T5(1))*wt_R + S5(m) = S5(1) + (S5(5)-S5(1))*wt_R + p5(m) = p5(1) + (p5(5)-p5(1))*wt_R + enddo !m + call calculate_density(T5, S5, p5, r5, tv%eqn_of_state, rho_ref=rho_ref) + + ! Use a trapezoidal rule integral of the hydrostatic equation to determine the pressure + ! anomalies at 5 equally spaced points along the interface, and then use Boole's rule + ! quadrature to find the integrated correction to the integral of pressure along the interface. + ! The derivation for this expression is shown below in the y-direction version. + intx_pa_cor(I,j) = C1_90 * (4.75*(r5(5)-r5(1)) + 5.5*(r5(4)-r5(2))) * dz_geo_sfc + ! Note that (4.75 + 5.5/2) / 90 = 1/12, so this is consistent with the linear result below. + endif + endif + intx_pa(I,j,1) = 0.5*(pa(i,j,1) + pa(i+1,j,1)) + intx_pa_cor(I,j) + enddo ; enddo + !$OMP parallel do default(shared) private(dz_geo_sfc) + do J=Jsq,Jeq ; do i=is,ie + inty_pa_cor(i,J) = 0.0 + dz_geo_sfc = GV%g_Earth * (e(i,j+1,1)-e(i,j,1)) + if ((dz_geo_sfc * rho_ref - (pa(i,j+1,1)-pa(i,j,1)))*dz_geo_sfc > 0.0) then + ! The pressure/depth relationship has a positive implied density + if (-dz_geo_sfc * (pa(i,j+1,1)-pa(i,j,1)) > & + 0.25*((rho_top(i,j+1)+rho_top(i,j))-2.0*rho_ref) * dz_geo_sfc**2) then + ! The pressure difference is at least half the size of the difference expected by hydrostatic + ! balance. This test gets rid of pressure differences that are small, e.g. open ocean. + ! Use 5 point quadrature to calculate intypa + T5(1) = T_top(i,j) ; T5(5) = T_top(i,j+1) + S5(1) = S_top(i,j) ; S5(5) = S_top(i,j+1) + pa5(1) = pa(i,j,1) ; pa5(5) = pa(i,j+1,1) + ! Pressure input to density EOS is consistent with the pressure used in the int_density_dz routines. + p5(1) = -GxRho0*(e(i,j,1) - Z_0p(i,j)) + p5(5) = -GxRho0*(e(i,j+1,1) - Z_0p(i,j)) + + do m=2,4 + wt_R = 0.25*real(m-1) + T5(m) = T5(1) + (T5(5)-T5(1))*wt_R + S5(m) = S5(1) + (S5(5)-S5(1))*wt_R + p5(m) = p5(1) + (p5(5)-p5(1))*wt_R + enddo !m + call calculate_density(T5, S5, p5, r5, tv%eqn_of_state, rho_ref=rho_ref) + + ! Use a trapezoidal rule integral of the hydrostatic equation to determine the pressure + ! anomalies at 5 equally spaced points along the interface, and then use Boole's rule + ! quadrature to find the integrated correction to the integral of pressure along the interface. + inty_pa_cor(i,J) = C1_90 * (4.75*(r5(5)-r5(1)) + 5.5*(r5(4)-r5(2))) * dz_geo_sfc + + ! The derivation of this correction follows: + + ! Make pressure curvature a difference from the linear fit of pressure between the two points + ! (which is equivalent to taking 4 trapezoidal rule integrals of the hydrostatic equation on + ! sub-segments), with a constant slope that is chosen so that the pressure anomalies at the + ! two ends of the segment agree with their known values. + ! d_geo_8 = 0.125*dz_geo_sfc + ! dpa_subseg = 0.25*(pa5(5)-pa5(1)) + & + ! 0.25*d_geo_8 * ((r5(5)+r5(1)) + 2.0*((r5(4)+r5(2)) + r5(3))) + ! do m=2,4 + ! pa5(m) = pa5(m-1) + dpa_subseg - d_geo_8*(r5(m)+r5(m-1))) + ! enddo + + ! Explicitly finding expressions for the incremental pressures from the recursion relation above: + ! pa5(2) = 0.25*(3.*pa5(1) + pa5(5)) + 0.25*d_geo_8 * ( (r5(5)-3.*r5(1)) + 2.0*((r5(4)-r5(2)) + r5(3)) ) + ! ! pa5(3) = 0.5*(pa5(1) + pa5(5)) + 0.25*d_geo_8 * & + ! ! ( (r5(5)+r5(1)) + 2.0*((r5(4)+r5(2)) + r5(3)) + & + ! ! (r5(5)-3.*r5(1)) + 2.0*((r5(4)-r5(2)) + r5(3)) - 4.*(r5(3)+r5(2)) ) + ! pa5(3) = 0.5*(pa5(1) + pa5(5)) + d_geo_8 * (0.5*(r5(5)-r5(1)) + (r5(4)-r5(2)) ) + ! ! pa5(4) = 0.25*(pa5(1) + 3.0*pa5(5)) + 0.25*d_geo_8 * & + ! ! (2.0*(r5(5)-r5(1)) + 4.0*(r5(4)-r5(2)) + (r5(5)+r5(1)) + & + ! ! 2.0*(r5(4)+r5(2)) + 2.0*r5(3) - 4.*(r5(4)+r5(3))) + ! pa5(4) = 0.25*(pa5(1) + 3.0*pa5(5)) + 0.25*d_geo_8 * ( (3.*r5(5)-r5(1)) + 2.0*((r5(4)-r5(2)) - r5(3)) ) + ! ! pa5(5) = pa5(5) + 0.25*d_geo_8 * & + ! ! ( (3.*r5(5)-r5(1)) + 2.0*((r5(4)-r5(2)) - r5(3)) + & + ! ! ((r5(5)+r5(1)) + 2.0*((r5(4)+r5(2)) + r5(3))) - 4.*(r5(5)+r5(4)) ) + ! pa5(5) = pa5(5) ! As it should. + + ! From these: + ! pa5(2) + pa5(4) = (pa5(1) + pa5(5)) + 0.25*d_geo_8 * & + ! ( (r5(5)-3.*r5(1)) + 2.0*((r5(4)-r5(2)) + r5(3)) + (3.*r5(5)-r5(1)) + 2.0*((r5(4)-r5(2)) - r5(3)) + ! pa5(2) + pa5(4) = (pa5(1) + pa5(5)) + d_geo_8 * ( (r5(5)-r5(1)) + (r5(4)-r5(2)) ) + + ! Get the correction from the difference between the 5-point quadrature integral of pa5 and + ! its trapezoidal rule integral as: + ! inty_pa_cor(i,J) = C1_90*(7.0*(pa5(1)+pa5(5)) + 32.0*(pa5(2)+pa5(4)) + 12.0*pa5(3)) - 0.5*(pa5(1)+pa5(5))) + ! inty_pa_cor(i,J) = C1_90*((32.0*(pa5(2)+pa5(4)) + 12.0*pa5(3)) - 38.0*(pa5(1)+pa5(5))) + ! inty_pa_cor(i,J) = C1_90*d_geo_8 * ((32.0*( (r5(5)-r5(1)) + (r5(4)-r5(2)) ) + & + ! (6.*(r5(5)-r5(1)) + 12.0*(r5(4)-r5(2)) )) + ! inty_pa_cor(i,J) = C1_90*d_geo_8 * ( 38.0*(r5(5)-r5(1)) + 44.0*(r5(4)-r5(2)) ) + endif + endif + inty_pa(i,J,1) = 0.5*(pa(i,j,1) + pa(i,j+1,1)) + inty_pa_cor(i,J) + enddo ; enddo + + if (CS%debug) then + call uvchksum("int[xy]_pa_cor", intx_pa_cor, inty_pa_cor, G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, scalar_pair=.true., unscale=US%RL2_T2_to_Pa) + call uvchksum("int[xy]_pa(1)", intx_pa(:,:,1), inty_pa(:,:,1), G%HI, haloshift=0, & + symmetric=G%Domain%symmetric, scalar_pair=.true., unscale=US%RL2_T2_to_Pa) + endif + + else + ! Set the surface boundary conditions on the horizontally integrated pressure anomaly, + ! assuming that the surface pressure anomaly varies linearly in x and y. + ! If there is an ice-shelf or icebergs, this linear variation would need to be applied + ! to an interior interface. !$OMP parallel do default(shared) do j=js,je ; do I=Isq,Ieq - PFu(I,j,k) = (((pa(i,j)*h(i,j,k) + intz_dpa(i,j)) - & - (pa(i+1,j)*h(i+1,j,k) + intz_dpa(i+1,j))) + & - ((h(i+1,j,k) - h(i,j,k)) * intx_pa(I,j) - & - (e(i+1,j,K+1) - e(i,j,K+1)) * intx_dpa(I,j) * GV%Z_to_H)) * & - ((2.0*I_Rho0*G%IdxCu(I,j)) / & - ((h(i,j,k) + h(i+1,j,k)) + h_neglect)) - intx_pa(I,j) = intx_pa(I,j) + intx_dpa(I,j) + intx_pa(I,j,1) = 0.5*(pa(i,j,1) + pa(i+1,j,1)) enddo ; enddo - ! Compute pressure gradient in y direction !$OMP parallel do default(shared) do J=Jsq,Jeq ; do i=is,ie - PFv(i,J,k) = (((pa(i,j)*h(i,j,k) + intz_dpa(i,j)) - & - (pa(i,j+1)*h(i,j+1,k) + intz_dpa(i,j+1))) + & - ((h(i,j+1,k) - h(i,j,k)) * inty_pa(i,J) - & - (e(i,j+1,K+1) - e(i,j,K+1)) * inty_dpa(i,J) * GV%Z_to_H)) * & - ((2.0*I_Rho0*G%IdyCv(i,J)) / & - ((h(i,j,k) + h(i,j+1,k)) + h_neglect)) - inty_pa(i,J) = inty_pa(i,J) + inty_dpa(i,J) + inty_pa(i,J,1) = 0.5*(pa(i,j,1) + pa(i,j+1,1)) enddo ; enddo + endif + + do k=1,nz !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - pa(i,j) = pa(i,j) + dpa(i,j) + do j=js,je ; do I=Isq,Ieq + intx_pa(I,j,K+1) = intx_pa(I,j,K) + intx_dpa(I,j,k) + enddo ; enddo + enddo + do k=1,nz + !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie + inty_pa(i,J,K+1) = inty_pa(i,J,K) + inty_dpa(i,J,k) enddo ; enddo enddo - if (CS%GFS_scale < 1.0) then + if (CS%reset_intxpa_integral) then + ! Having stored the pressure gradient info, we can work out where the first nonvanished layers is + ! reset intxpa there, then adjust intxpa throughout the water column. + + ! Zero out the 2-d arrays that will be set from various reference interfaces. + T_int_W(:,:) = 0.0 ; S_int_W(:,:) = 0.0 ; p_int_W(:,:) = 0.0 + T_int_E(:,:) = 0.0 ; S_int_E(:,:) = 0.0 ; p_int_E(:,:) = 0.0 + intx_pa_nonlin(:,:) = 0.0 ; dgeo_x(:,:) = 0.0 ; intx_pa_cor_ri(:,:) = 0.0 + do j=js,je ; do I=Isq,Ieq + seek_x_cor(I,j) = (G%mask2dCu(I,j) > 0.) + delta_z_x(I,j) = 0.0 + enddo ; enddo + + do j=js,je ; do I=Isq,Ieq ; if (seek_x_cor(I,j)) then + if ((e(i+1,j,2) <= e(i,j,1)) .and. (e(i,j,2) <= e(i+1,j,1))) then + ! This is a typical case in the open ocean, so use the topmost interface. + T_int_W(I,j) = T_top(i,j) ; T_int_E(I,j) = T_top(i+1,j) + S_int_W(I,j) = S_top(i,j) ; S_int_E(I,j) = S_top(i+1,j) + p_int_W(I,j) = -GxRho0*(e(i,j,1) - Z_0p(i,j)) + p_int_E(I,j) = -GxRho0*(e(i+1,j,1) - Z_0p(i,j)) + intx_pa_nonlin(I,j) = intx_pa(I,j,1) - 0.5*(pa(i,j,1) + pa(i+1,j,1)) + dgeo_x(I,j) = GV%g_Earth * (e(i+1,j,1)-e(i,j,1)) + seek_x_cor(I,j) = .false. + endif + endif ; enddo ; enddo + + do k=1,nz + do_more_k = .false. + do j=js,je ; do I=Isq,Ieq ; if (seek_x_cor(I,j)) then + ! Find the topmost layer for which both sides are nonvanished and mass-weighting is not + ! activated in the subgrid interpolation. + if (((h(i,j,k) > CS%h_nonvanished) .and. (h(i+1,j,k) > CS%h_nonvanished)) .and. & + (max(0., e(i+1,j,K+1)-e(i,j,1), e(i,j,K+1)-e(i+1,j,1)) <= 0.0)) then + ! Store properties at the bottom of this cell to get a "good estimate" for intxpa at + ! the interface below this cell (it might have quadratic pressure dependence if sloped) + T_int_W(I,j) = T_b(i,j,k) ; T_int_E(I,j) = T_b(i+1,j,k) + S_int_W(I,j) = S_b(i,j,k) ; S_int_E(I,j) = S_b(i+1,j,k) + ! These pressures are only used for the equation of state, and are only a function of + ! height, consistent with the expressions in the int_density_dz routines. + p_int_W(I,j) = -GxRho0*(e(i,j,K+1) - Z_0p(i,j)) + p_int_E(I,j) = -GxRho0*(e(i+1,j,K+1) - Z_0p(i,j)) + + intx_pa_nonlin(I,j) = intx_pa(I,j,K+1) - 0.5*(pa(i,j,K+1) + pa(i+1,j,K+1)) + dgeo_x(I,j) = GV%g_Earth * (e(i+1,j,K+1)-e(i,j,K+1)) + seek_x_cor(I,j) = .false. + else + do_more_k = .true. + endif + endif ; enddo ; enddo + if (.not.do_more_k) exit ! All reference interfaces have been found, so stop working downward. + enddo + + if (do_more_k) then + if (CS%reset_intxpa_flattest) then + ! There are still points where a correction is needed, so use flattest interface + do j=js,je ; do I=Isq,Ieq ; if (seek_x_cor(I,j)) then + ! choose top layer first + T_int_W(I,j) = T_top(i,j) ; T_int_E(I,j) = T_top(i+1,j) + S_int_W(I,j) = S_top(i,j) ; S_int_E(I,j) = S_top(i+1,j) + p_int_W(I,j) = -GxRho0*(e(i,j,1) - Z_0p(i,j)) + p_int_E(I,j) = -GxRho0*(e(i+1,j,1) - Z_0p(i,j)) + intx_pa_nonlin(I,j) = intx_pa(I,j,1) - 0.5*(pa(i,j,1) + pa(i+1,j,1)) + dgeo_x(I,j) = GV%g_Earth * (e(i+1,j,1)-e(i,j,1)) + delta_z_x(I,j) = abs(e(i+1,j,1)-e(i,j,1)) + do k=1,nz + if (abs(e(i+1,j,k+1)-e(i,j,k+1)) < delta_z_x(I,j)) then + ! bottom of layer is less sloped than top. Use this layer + delta_z_x(I,j) = abs(e(i+1,j,k+1)-e(i,j,k+1)) + T_int_W(I,j) = T_b(i,j,k) ; T_int_E(I,j) = T_b(i+1,j,k) + S_int_W(I,j) = S_b(i,j,k) ; S_int_E(I,j) = S_b(i+1,j,k) + p_int_W(I,j) = -GxRho0*(e(i,j,K+1) - Z_0p(i,j)) + p_int_E(I,j) = -GxRho0*(e(i+1,j,K+1) - Z_0p(i,j)) + intx_pa_nonlin(I,j) = intx_pa(I,j,K+1) - 0.5*(pa(i,j,K+1) + pa(i+1,j,K+1)) + dgeo_x(I,j) = GV%g_Earth * (e(i+1,j,K+1)-e(i,j,K+1)) + endif + enddo + seek_x_cor(I,j) = .false. + endif ; enddo ; enddo + else + ! There are still points where a correction is needed, so use the top interface for lack of a better idea? + do j=js,je ; do I=Isq,Ieq ; if (seek_x_cor(I,j)) then + T_int_W(I,j) = T_top(i,j) ; T_int_E(I,j) = T_top(i+1,j) + S_int_W(I,j) = S_top(i,j) ; S_int_E(I,j) = S_top(i+1,j) + p_int_W(I,j) = -GxRho0*(e(i,j,1) - Z_0p(i,j)) + p_int_E(I,j) = -GxRho0*(e(i+1,j,1) - Z_0p(i,j)) + intx_pa_nonlin(I,j) = intx_pa(I,j,1) - 0.5*(pa(i,j,1) + pa(i+1,j,1)) + dgeo_x(I,j) = GV%g_Earth * (e(i+1,j,1)-e(i,j,1)) + seek_x_cor(I,j) = .false. + endif ; enddo ; enddo + endif + endif + + do j=js,je + do I=Isq,Ieq + ! This expression assumes that temperature and salinity vary linearly with hieght + ! between the corners of the reference interfaces found above to get a correction to + ! intx_pa that takes nonlinearities in the equation of state into account. + ! It is derived from a 5 point quadrature estimate of the integral with a large-scale + ! linear correction so that the pressures and heights match at the end-points. It turns + ! out that this linear correction cancels out the mid-point density anomaly. + ! This can be used without masking because dgeo_x and intx_pa_nonlin are 0 over land. + T5(1) = T_Int_W(I,j) ; S5(1) = S_Int_W(I,j) ; p5(1) = p_Int_W(I,j) + T5(5) = T_Int_E(I,j) ; S5(5) = S_Int_E(I,j) ; p5(5) = p_Int_E(I,j) + T5(2) = 0.25*(3.0*T5(1) + T5(5)) ; T5(4) = 0.25*(3.0*T5(5) + T5(1)) ; T5(3) = 0.5*(T5(5) + T5(1)) + S5(2) = 0.25*(3.0*S5(1) + S5(5)) ; S5(4) = 0.25*(3.0*S5(5) + S5(1)) ; S5(3) = 0.5*(S5(5) + S5(1)) + p5(2) = 0.25*(3.0*p5(1) + p5(5)) ; p5(4) = 0.25*(3.0*p5(5) + p5(1)) ; p5(3) = 0.5*(p5(5) + p5(1)) + call calculate_density(T5, S5, p5, r5, tv%eqn_of_state, rho_ref=rho_ref) + + ! Note the consistency with the linear form below because (4.75 + 5.5/2) / 90 = 1/12 + intx_pa_cor_ri(I,j) = C1_90 * (4.75*(r5(5)-r5(1)) + 5.5*(r5(4)-r5(2))) * dgeo_x(I,j) - & + intx_pa_nonlin(I,j) + enddo + enddo + + ! Repeat the calculations above for v-velocity points. + T_int_S(:,:) = 0.0 ; S_int_S(:,:) = 0.0 ; p_int_S(:,:) = 0.0 + T_int_N(:,:) = 0.0 ; S_int_N(:,:) = 0.0 ; p_int_N(:,:) = 0.0 + inty_pa_nonlin(:,:) = 0.0 ; dgeo_y(:,:) = 0.0 ; inty_pa_cor_ri(:,:) = 0.0 + do J=Jsq,Jeq ; do i=is,ie + seek_y_cor(i,J) = (G%mask2dCv(i,J) > 0.) + delta_z_y(i,J) = 0.0 + enddo ; enddo + + do J=Jsq,Jeq ; do i=is,ie ; if (seek_y_cor(i,J)) then + if ((e(i,j+1,2) <= e(i,j,1)) .and. (e(i,j,2) <= e(i,j+1,1))) then + ! This is a typical case in the open ocean, so use the topmost interface. + T_int_S(i,J) = T_top(i,j) ; T_int_N(i,J) = T_top(i,j+1) + S_int_S(i,J) = S_top(i,j) ; S_int_N(i,J) = S_top(i,j+1) + p_int_S(i,J) = -GxRho0*(e(i,j,1) - Z_0p(i,j)) + p_int_N(i,J) = -GxRho0*(e(i,j+1,1) - Z_0p(i,j)) + inty_pa_nonlin(i,J) = inty_pa(i,J,1) - 0.5*(pa(i,j,1) + pa(i,j+1,1)) + dgeo_y(i,J) = GV%g_Earth * (e(i,j+1,1)-e(i,j,1)) + seek_y_cor(i,J) = .false. + endif + endif ; enddo ; enddo + do k=1,nz + do_more_k = .false. + do J=Jsq,Jeq ; do i=is,ie ; if (seek_y_cor(i,J)) then + ! Find the topmost layer for which both sides are nonvanished and mass-weighting is not + ! activated in the subgrid interpolation. + if (((h(i,j,k) > CS%h_nonvanished) .and. (h(i,j+1,k) > CS%h_nonvanished)) .and. & + (max(0., e(i,j+1,K+1)-e(i,j,1), e(i,j,K+1)-e(i,j+1,1)) <= 0.0)) then + ! Store properties at the bottom of this cell to get a "good estimate" for intypa at + ! the interface below this cell (it might have quadratic pressure dependence if sloped) + T_int_S(i,J) = T_b(i,j,k) ; T_int_N(i,J) = T_b(i,j+1,k) + S_int_S(i,J) = S_b(i,j,k) ; S_int_N(i,J) = S_b(i,j+1,k) + ! These pressures are only used for the equation of state, and are only a function of + ! height, consistent with the expressions in the int_density_dz routines. + p_int_S(i,J) = -GxRho0*(e(i,j,K+1) - Z_0p(i,j)) + p_int_N(i,J) = -GxRho0*(e(i,j+1,K+1) - Z_0p(i,j)) + inty_pa_nonlin(i,J) = inty_pa(i,J,K+1) - 0.5*(pa(i,j,K+1) + pa(i,j+1,K+1)) + dgeo_y(i,J) = GV%g_Earth * (e(i,j+1,K+1)-e(i,j,K+1)) + seek_y_cor(i,J) = .false. + else + do_more_k = .true. + endif + endif ; enddo ; enddo + if (.not.do_more_k) exit ! All reference interfaces have been found, so stop working downward. + enddo + + if (do_more_k) then + if (CS%reset_intxpa_flattest) then + ! There are still points where a correction is needed, so use flattest interface. + do J=Jsq,Jeq ; do i=is,ie ; if (seek_y_cor(i,J)) then + ! choose top interface first + T_int_S(i,J) = T_top(i,j) ; T_int_N(i,J) = T_top(i,j+1) + S_int_S(i,J) = S_top(i,j) ; S_int_N(i,J) = S_top(i,j+1) + p_int_S(i,J) = -GxRho0*(e(i,j,1) - Z_0p(i,j)) + p_int_N(i,J) = -GxRho0*(e(i,j+1,1) - Z_0p(i,j)) + inty_pa_nonlin(i,J) = inty_pa(i,J,1) - 0.5*(pa(i,j,1) + pa(i,j+1,1)) + dgeo_y(i,J) = GV%g_Earth * (e(i,j+1,1)-e(i,j,1)) + delta_z_y(i,J) = abs(e(i,j+1,1)-e(i,j,1)) + do k=1,nz + if (abs(e(i,j+1,k+1)-e(i,j,k+1)) < delta_z_y(i,J)) then + ! bottom of layer is less sloped than top. Use this layer + delta_z_y(i,J) = abs(e(i,j+1,k+1)-e(i,j,k+1)) + T_int_S(i,J) = T_b(i,j,k) ; T_int_N(i,J) = T_b(i,j+1,k) + S_int_S(i,J) = S_b(i,j,k) ; S_int_N(i,J) = S_b(i,j+1,k) + p_int_S(i,J) = -GxRho0*(e(i,j,k+1) - Z_0p(i,j)) + p_int_N(i,J) = -GxRho0*(e(i,j+1,k+1) - Z_0p(i,j)) + inty_pa_nonlin(i,J) = inty_pa(i,J,k+1) - 0.5*(pa(i,j,k+1) + pa(i,j+1,k+1)) + dgeo_y(i,J) = GV%g_Earth * (e(i,j+1,k+1)-e(i,j,k+1)) + endif + enddo + seek_y_cor(i,J) = .false. + endif ; enddo ; enddo + else + ! There are still points where a correction is needed, so use the top interface for lack of a better idea? + do J=Jsq,Jeq ; do i=is,ie ; if (seek_y_cor(i,J)) then + T_int_S(i,J) = T_top(i,j) ; T_int_N(i,J) = T_top(i,j+1) + S_int_S(i,J) = S_top(i,j) ; S_int_N(i,J) = S_top(i,j+1) + p_int_S(i,J) = -GxRho0*(e(i,j,1) - Z_0p(i,j)) + p_int_N(i,J) = -GxRho0*(e(i,j+1,1) - Z_0p(i,j)) + inty_pa_nonlin(i,J) = inty_pa(i,J,1) - 0.5*(pa(i,j,1) + pa(i,j+1,1)) + dgeo_y(i,J) = GV%g_Earth * (e(i,j+1,1)-e(i,j,1)) + seek_y_cor(i,J) = .false. + endif ; enddo ; enddo + endif + endif + + do J=Jsq,Jeq + do i=is,ie + ! This expression assumes that temperature and salinity vary linearly with hieght + ! between the corners of the reference interfaces found above to get a correction to + ! intx_pa that takes nonlinearities in the equation of state into account. + ! It is derived from a 5 point quadrature estimate of the integral with a large-scale + ! linear correction so that the pressures and heights match at the end-points. It turns + ! out that this linear correction cancels out the mid-point density anomaly. + ! This can be used without masking because dgeo_y and inty_pa_nonlin are 0 over land. + T5(1) = T_Int_S(i,J) ; S5(1) = S_Int_S(i,J) ; p5(1) = p_Int_S(i,J) + T5(5) = T_Int_N(i,J) ; S5(5) = S_Int_N(i,J) ; p5(5) = p_Int_N(i,J) + T5(2) = 0.25*(3.0*T5(1) + T5(5)) ; T5(4) = 0.25*(3.0*T5(5) + T5(1)) ; T5(3) = 0.5*(T5(5) + T5(1)) + S5(2) = 0.25*(3.0*S5(1) + S5(5)) ; S5(4) = 0.25*(3.0*S5(5) + S5(1)) ; S5(3) = 0.5*(S5(5) + S5(1)) + p5(2) = 0.25*(3.0*p5(1) + p5(5)) ; p5(4) = 0.25*(3.0*p5(5) + p5(1)) ; p5(3) = 0.5*(p5(5) + p5(1)) + call calculate_density(T5, S5, p5, r5, tv%eqn_of_state, rho_ref=rho_ref) + + ! Note the consistency with the linear form below because (4.75 + 5.5/2) / 90 = 1/12 + inty_pa_cor_ri(i,J) = C1_90 * (4.75*(r5(5)-r5(1)) + 5.5*(r5(4)-r5(2))) * dgeo_y(i,J) - & + inty_pa_nonlin(i,J) + enddo + enddo + + ! Correct intx_pa and inty_pa at each interface using vertically constant corrections. + do K=1,nz+1 ; do j=js,je ; do I=Isq,Ieq + intx_pa(I,j,K) = intx_pa(I,j,K) + intx_pa_cor_ri(I,j) + enddo ; enddo ; enddo + + do K=1,nz+1 ; do J=Jsq,Jeq ; do i=is,ie + inty_pa(i,J,K) = inty_pa(i,J,K) + inty_pa_cor_ri(i,J) + enddo ; enddo ; enddo + endif ! intx_pa and inty_pa have now been reset to reflect the properties of an unimpeded interface. + + ! Compute pressure gradient in x direction + !$OMP parallel do default(shared) + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + PFu(I,j,k) = (((pa(i,j,K)*h(i,j,k) + intz_dpa(i,j,k)) - & + (pa(i+1,j,K)*h(i+1,j,k) + intz_dpa(i+1,j,k))) + & + ((h(i+1,j,k) - h(i,j,k)) * intx_pa(I,j,K) - & + (e(i+1,j,K+1) - e(i,j,K+1)) * intx_dpa(I,j,k) * GV%Z_to_H)) * & + ((2.0*I_Rho0*G%IdxCu(I,j)) / & + ((h(i,j,k) + h(i+1,j,k)) + h_neglect)) + enddo ; enddo ; enddo + + ! Compute pressure gradient in y direction + !$OMP parallel do default(shared) + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + PFv(i,J,k) = (((pa(i,j,K)*h(i,j,k) + intz_dpa(i,j,k)) - & + (pa(i,j+1,K)*h(i,j+1,k) + intz_dpa(i,j+1,k))) + & + ((h(i,j+1,k) - h(i,j,k)) * inty_pa(i,J,K) - & + (e(i,j+1,K+1) - e(i,j,K+1)) * inty_dpa(i,J,k) * GV%Z_to_H)) * & + ((2.0*I_Rho0*G%IdyCv(i,J)) / & + ((h(i,j,k) + h(i,j+1,k)) + h_neglect)) + enddo ; enddo ; enddo + + ! Calculate SAL geopotential anomaly and add its gradient to pressure gradient force + if (CS%calculate_SAL .and. CS%tides_answer_date>20230630 .and. CS%bq_sal_tides) then + !$OMP parallel do default(shared) + do k=1,nz + do j=js,je ; do I=Isq,Ieq + PFu(I,j,k) = PFu(I,j,k) + (e_sal(i+1,j) - e_sal(i,j)) * GV%g_Earth * G%IdxCu(I,j) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + PFv(i,J,k) = PFv(i,J,k) + (e_sal(i,j+1) - e_sal(i,j)) * GV%g_Earth * G%IdyCv(i,J) + enddo ; enddo + enddo + endif + + ! Calculate tidal geopotential anomaly and add its gradient to pressure gradient force + if (CS%tides .and. CS%tides_answer_date>20230630 .and. CS%bq_sal_tides) then + !$OMP parallel do default(shared) + do k=1,nz + do j=js,je ; do I=Isq,Ieq + PFu(I,j,k) = PFu(I,j,k) + ((e_tidal_eq(i+1,j) + e_tidal_sal(i+1,j)) & + - (e_tidal_eq(i,j) + e_tidal_sal(i,j))) * GV%g_Earth * G%IdxCu(I,j) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + PFv(i,J,k) = PFv(i,J,k) + ((e_tidal_eq(i,j+1) + e_tidal_sal(i,j+1)) & + - (e_tidal_eq(i,j) + e_tidal_sal(i,j))) * GV%g_Earth * G%IdyCv(i,J) + enddo ; enddo + enddo + endif + + if (CS%GFS_scale < 1.0) then + ! Adjust the Montgomery potential to make this a reduced gravity model. + if (use_EOS) then !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 + if (use_p_atm) then + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p_atm(:,j), rho_in_situ, & + tv%eqn_of_state, EOSdom) + else + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, & + tv%eqn_of_state, EOSdom) + endif + do i=Isq,Ieq+1 + dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * rho_in_situ(i)) * (e(i,j,1) - G%Z_ref) + enddo + enddo + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * GV%Rlay(1)) * (e(i,j,1) - G%Z_ref) + enddo ; enddo + endif + + !$OMP parallel do default(shared) + do k=1,nz do j=js,je ; do I=Isq,Ieq PFu(I,j,k) = PFu(I,j,k) - (dM(i+1,j) - dM(i,j)) * G%IdxCu(I,j) enddo ; enddo - !$OMP parallel do default(shared) do J=Jsq,Jeq ; do i=is,ie PFv(i,J,k) = PFv(i,J,k) - (dM(i,j+1) - dM(i,j)) * G%IdyCv(i,J) enddo ; enddo @@ -778,32 +1875,149 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm endif if (present(pbce)) then - call set_pbce_Bouss(e, tv_tmp, G, GV, US, CS%Rho0, CS%GFS_scale, pbce) + call set_pbce_Bouss(e, tv_tmp, G, GV, US, rho0_set_pbce, CS%GFS_scale, pbce) endif if (present(eta)) then - if (CS%tides) then ! eta is the sea surface height relative to a time-invariant geoid, for comparison with ! what is used for eta in btstep. See how e was calculated about 200 lines above. + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = e(i,j,1)*GV%Z_to_H + enddo ; enddo + if (CS%tides .and. (.not.CS%bq_sal_tides)) then + if (CS%tides_answer_date>20230630) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = eta(i,j) + (e_tidal_eq(i,j)+e_tidal_sal(i,j))*GV%Z_to_H + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = eta(i,j) + e_sal_and_tide(i,j)*GV%Z_to_H + enddo ; enddo + endif + endif + if (CS%calculate_SAL .and. (CS%tides_answer_date>20230630) .and. (.not.CS%bq_sal_tides)) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%Z_to_H + e_tidal(i,j)*GV%Z_to_H + eta(i,j) = eta(i,j) + e_sal(i,j)*GV%Z_to_H enddo ; enddo - else - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%Z_to_H + endif + endif + + if (CS%use_stanley_pgf) then + ! Calculated diagnostics related to the Stanley parameterization + zeros(:) = 0.0 + EOSdom_h(:) = EOS_domain(G%HI) + if ((CS%id_p_stanley>0) .or. (CS%id_rho_pgf>0) .or. (CS%id_rho_stanley_pgf>0)) then + ! Find the pressure at the mid-point of each layer. + H_to_RL2_T2 = GV%g_Earth*GV%H_to_RZ + if (use_p_atm) then + do j=js,je ; do i=is,ie + p_stanley(i,j,1) = 0.5*h(i,j,1) * H_to_RL2_T2 + p_atm(i,j) + enddo ; enddo + else + do j=js,je ; do i=is,ie + p_stanley(i,j,1) = 0.5*h(i,j,1) * H_to_RL2_T2 + enddo ; enddo + endif + do k=2,nz ; do j=js,je ; do i=is,ie + p_stanley(i,j,k) = p_stanley(i,j,k-1) + 0.5*(h(i,j,k-1) + h(i,j,k)) * H_to_RL2_T2 + enddo ; enddo ; enddo + endif + if (CS%id_p_stanley>0) call post_data(CS%id_p_stanley, p_stanley, CS%diag) + if (CS%id_rho_pgf>0) then + do k=1,nz ; do j=js,je + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_stanley(:,j,k), zeros, & + zeros, zeros, rho_pgf(:,j,k), tv%eqn_of_state, EOSdom_h) enddo ; enddo + call post_data(CS%id_rho_pgf, rho_pgf, CS%diag) + endif + if (CS%id_rho_stanley_pgf>0) then + do k=1,nz ; do j=js,je + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_stanley(:,j,k), tv%varT(:,j,k), & + zeros, zeros, rho_stanley_pgf(:,j,k), tv%eqn_of_state, EOSdom_h) + enddo ; enddo + call post_data(CS%id_rho_stanley_pgf, rho_stanley_pgf, CS%diag) endif endif - if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_tidal, CS%diag) - if (CS%id_tvar_sgs>0) call post_data(CS%id_tvar_sgs, tv%varT, CS%diag) + if (CS%id_MassWt_u>0) call post_data(CS%id_MassWt_u, MassWt_u, CS%diag) + if (CS%id_MassWt_v>0) call post_data(CS%id_MassWt_v, MassWt_v, CS%diag) + + if (CS%id_rho_pgf>0) call post_data(CS%id_rho_pgf, rho_pgf, CS%diag) + if (CS%id_rho_stanley_pgf>0) call post_data(CS%id_rho_stanley_pgf, rho_stanley_pgf, CS%diag) + if (CS%id_p_stanley>0) call post_data(CS%id_p_stanley, p_stanley, CS%diag) + + ! Diagnostics for tidal forcing and SAL height anomaly + if (CS%id_e_tide>0) then + ! To be consistent with old runs, tidal forcing diagnostic also includes total SAL. + ! New diagnostics are given for each individual field. + if (CS%tides_answer_date>20230630) then ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_sal_and_tide(i,j) = e_sal(i,j) + e_tidal_eq(i,j) + e_tidal_sal(i,j) + enddo ; enddo ; endif + call post_data(CS%id_e_tide, e_sal_and_tide, CS%diag) + endif + if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) + if (CS%id_e_tidal_eq>0) call post_data(CS%id_e_tidal_eq, e_tidal_eq, CS%diag) + if (CS%id_e_tidal_sal>0) call post_data(CS%id_e_tidal_sal, e_tidal_sal, CS%diag) + + ! Diagnostics for tidal forcing and SAL horizontal gradients + if (CS%calculate_SAL .and. ((associated(ADp%sal_u) .or. associated(ADp%sal_v)))) then + if (CS%tides) then ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_sal(i,j) = e_sal(i,j) + e_tidal_sal(i,j) + enddo ; enddo ; endif + if (CS%bq_sal_tides) then + ! sal_u = ( e(i+1) - e(i) ) * g / dx + if (associated(ADp%sal_u)) then ; do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ADp%sal_u(I,j,k) = (e_sal(i+1,j) - e_sal(i,j)) * GV%g_Earth * G%IdxCu(I,j) + enddo ; enddo ; enddo ; endif + if (associated(ADp%sal_v)) then ; do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ADp%sal_v(i,J,k) = (e_sal(i,j+1) - e_sal(i,j)) * GV%g_Earth * G%IdyCv(i,J) + enddo ; enddo ; enddo ; endif + else + ! sal_u = ( e(i+1) - e(i) ) * g / dx * (rho(k) / rho0) + if (associated(ADp%sal_u)) then ; do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ADp%sal_u(I,j,k) = (e_sal(i+1,j) - e_sal(i,j)) * G%IdxCu(I,j) * I_Rho0 * & + (2.0 * intx_dpa(I,j,k) * GV%Z_to_H / ((h(i,j,k) + h(i+1,j,k)) + h_neglect) + GxRho_ref) + enddo ; enddo ; enddo ; endif + if (associated(ADp%sal_v)) then ; do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ADp%sal_v(i,J,k) = (e_sal(i,j+1) - e_sal(i,j)) * G%IdyCv(i,J) * I_Rho0 * & + (2.0 * inty_dpa(i,J,k) * GV%Z_to_H / ((h(i,j,k) + h(i,j+1,k)) + h_neglect) + GxRho_ref) + enddo ; enddo ; enddo ; endif + endif + if (CS%id_sal_u>0) call post_data(CS%id_sal_u, ADp%sal_u, CS%diag) + if (CS%id_sal_v>0) call post_data(CS%id_sal_v, ADp%sal_v, CS%diag) + endif + if (CS%tides .and. ((associated(ADp%tides_u) .or. associated(ADp%tides_v)))) then + if (CS%bq_sal_tides) then + ! tides_u = ( e(i+1) - e(i) ) * g / dx + if (associated(ADp%tides_u)) then ; do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ADp%tides_u(I,j,k) = (e_tidal_eq(i+1,j) - e_tidal_eq(i,j)) * GV%g_Earth * G%IdxCu(I,j) + enddo ; enddo ; enddo ; endif + if (associated(ADp%tides_v)) then ; do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ADp%tides_v(i,J,k) = (e_tidal_eq(i,j+1) - e_tidal_eq(i,j)) * GV%g_Earth * G%IdyCv(i,J) + enddo ; enddo ; enddo ; endif + else + ! tides_u = ( e(i+1) - e(i) ) * g / dx * (rho(k) / rho0) + if (associated(ADp%tides_u)) then ; do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ADp%tides_u(I,j,k) = (e_tidal_eq(i+1,j) - e_tidal_eq(i,j)) * G%IdxCu(I,j) * I_Rho0 * & + (2.0 * intx_dpa(I,j,k) * GV%Z_to_H / ((h(i,j,k) + h(i+1,j,k)) + h_neglect) + GxRho_ref) + enddo ; enddo ; enddo ; endif + if (associated(ADp%tides_v)) then ; do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ADp%tides_v(i,J,k) = (e_tidal_eq(i,j+1) - e_tidal_eq(i,j)) * G%IdyCv(i,J) * I_Rho0 * & + (2.0 * inty_dpa(i,J,k) * GV%Z_to_H / ((h(i,j,k) + h(i,j+1,k)) + h_neglect) + GxRho_ref) + enddo ; enddo ; enddo ; endif + endif + if (CS%id_tides_u>0) call post_data(CS%id_tides_u, ADp%tides_u, CS%diag) + if (CS%id_tides_v>0) call post_data(CS%id_tides_v, ADp%tides_v, CS%diag) + endif end subroutine PressureForce_FV_Bouss !> Initializes the finite volume pressure gradient control structure -subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) +subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, ADp, SAL_CSp, tides_CSp) type(time_type), target, intent(in) :: Time !< Current model time type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure @@ -811,34 +2025,149 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, tides_CS type(param_file_type), intent(in) :: param_file !< Parameter file handles type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(PressureForce_FV_CS), intent(inout) :: CS !< Finite volume PGF control structure + type(accel_diag_ptrs), pointer :: ADp !< Acceleration diagnostic pointers + type(SAL_CS), intent(in), target, optional :: SAL_CSp !< SAL control structure type(tidal_forcing_CS), intent(in), target, optional :: tides_CSp !< Tides control structure + + ! Local variables + real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale + ! temperature variance [nondim] + integer :: default_answer_date ! Global answer date + logical :: use_temperature ! If true, temperature and salinity are used as state variables. + logical :: use_EOS ! If true, density calculated from T & S using an equation of state. + logical :: useMassWghtInterp ! If true, use near-bottom mass weighting for T and S + logical :: MassWghtInterpTop ! If true, use near-surface mass weighting for T and S under ice shelves + logical :: MassWghtInterp_NonBous_bug ! If true, use a buggy mass weighting when non-Boussinesq + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl ! This module's name. - logical :: use_ALE + logical :: use_ALE ! If true, use the Vertical Lagrangian Remap algorithm + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB CS%initialized = .true. CS%diag => diag ; CS%Time => Time if (present(tides_CSp)) & CS%tides_CSp => tides_CSp + if (present(SAL_CSp)) & + CS%SAL_CSp => SAL_CSp mdl = "MOM_PressureForce_FV" call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to "//& - "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& - "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true., do_not_log=.true.) + call get_param(param_file, mdl, "RHO_PGF_REF", CS%rho_ref, & + "The reference density that is subtracted off when calculating pressure "//& + "gradient forces. Its inverse is subtracted off of specific volumes when "//& + "in non-Boussinesq mode. The default is RHO_0.", & + units="kg m-3", default=GV%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. + call get_param(param_file, mdl, "RHO_PGF_REF_BUG", CS%rho_ref_bug, & + "If true, recover a bug that RHO_0 (the mean seawater density in Boussinesq mode) "//& + "and RHO_PGF_REF (the subtracted reference density in finite volume pressure "//& + "gradient forces) are incorrectly interchanged in several instances in Boussinesq mode.", & + default=enable_bugs) call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) + if (CS%tides) then + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "TIDES_ANSWER_DATE", CS%tides_answer_date, "The vintage of "//& + "self-attraction and loading (SAL) and tidal forcing calculations. Setting "//& + "dates before 20230701 recovers old answers (Boussinesq and non-Boussinesq "//& + "modes) when SAL is part of the tidal forcing calculation. The answer "//& + "difference is only at bit level and due to a reordered summation. Setting "//& + "dates before 20250201 recovers answers (Boussinesq mode) that interface "//& + "heights are modified before pressure force integrals are calculated.", & + default=default_answer_date, do_not_log=(.not.CS%tides)) + endif + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=CS%tides) + if (CS%calculate_SAL) & + call get_param(param_file, '', "SAL_USE_BPA", CS%sal_use_bpa, default=.false., & + do_not_log=.true.) + if ((CS%tides .or. CS%calculate_SAL) .and. GV%Boussinesq) & + call get_param(param_file, mdl, "BOUSSINESQ_SAL_TIDES", CS%bq_sal_tides, "If true, "//& + "in Boussinesq mode, use an alternative method to include self-attraction "//& + "and loading (SAL) and tidal forcings in pressure gradient, in which their "//& + "gradients are calculated separately, instead of adding geopotential "//& + "anomalies as corrections to the interface height. This alternative method "//& + "elimates a baroclinic component of the SAL and tidal forcings.", & + default=.false.) + call get_param(param_file, "MOM", "ENABLE_THERMODYNAMICS", use_temperature, & + "If true, Temperature and salinity are used as state variables.", & + default=.true., do_not_log=.true.) + call get_param(param_file, "MOM", "USE_EOS", use_EOS, & + "If true, density is calculated from temperature and "//& + "salinity with an equation of state. If USE_EOS is "//& + "true, ENABLE_THERMODYNAMICS must be true as well.", & + default=use_temperature, do_not_log=.true.) + + call get_param(param_file, mdl, "SSH_IN_EOS_PRESSURE_FOR_PGF", CS%use_SSH_in_Z0p, & + "If true, include contributions from the sea surface height in the height-based "//& + "pressure used in the equation of state calculations for the Boussinesq pressure "//& + "gradient forces, including adjustments for atmospheric or sea-ice pressure.", & + default=.false., do_not_log=.not.GV%Boussinesq) + if (CS%tides .and. CS%tides_answer_date<=20250131 .and. CS%use_SSH_in_Z0p) & + call MOM_error(FATAL, trim(mdl) // ", PressureForce_FV_init: SSH_IN_EOS_PRESSURE_FOR_PGF "//& + "needs to be FALSE to recover tide answers before 20250131.") + call get_param(param_file, "MOM", "USE_REGRIDDING", use_ALE, & "If True, use the ALE algorithm (regridding/remapping). "//& "If False, use the layered isopycnal algorithm.", default=.false. ) - call get_param(param_file, mdl, "MASS_WEIGHT_IN_PRESSURE_GRADIENT", CS%useMassWghtInterp, & - "If true, use mass weighting when interpolating T/S for "//& - "integrals near the bathymetry in FV pressure gradient "//& - "calculations.", default=.false.) + call get_param(param_file, mdl, "MASS_WEIGHT_IN_PRESSURE_GRADIENT", useMassWghtInterp, & + "If true, use mass weighting when interpolating T/S for integrals "//& + "near the bathymetry in FV pressure gradient calculations.", & + default=.false.) + call get_param(param_file, mdl, "MASS_WEIGHT_IN_PRESSURE_GRADIENT_TOP", MassWghtInterpTop, & + "If true and MASS_WEIGHT_IN_PRESSURE_GRADIENT is true, use mass weighting when "//& + "interpolating T/S for integrals near the top of the water column in FV "//& + "pressure gradient calculations. ", & + default=useMassWghtInterp) + call get_param(param_file, mdl, "MASS_WEIGHT_IN_PGF_NONBOUS_BUG", MassWghtInterp_NonBous_bug, & + "If true, use a masking bug in non-Boussinesq calculations with mass weighting "//& + "when interpolating T/S for integrals near the bathymetry in FV pressure "//& + "gradient calculations.", & + default=.false., do_not_log=(GV%Boussinesq .or. (.not.useMassWghtInterp))) + call get_param(param_file, mdl, "MASS_WEIGHT_IN_PGF_VANISHED_ONLY", CS%MassWghtInterpVanOnly, & + "If true, use mass weighting when interpolating T/S for integrals "//& + "only if one side is vanished according to RESET_INTXPA_H_NONVANISHED. ", & + default=.false.) + + CS%MassWghtInterp = 0 + if (useMassWghtInterp) & + CS%MassWghtInterp = ibset(CS%MassWghtInterp, 0) ! Same as CS%MassWghtInterp + 1 + if (MassWghtInterpTop) & + CS%MassWghtInterp = ibset(CS%MassWghtInterp, 1) ! Same as CS%MassWghtInterp + 2 + if ((.not.GV%Boussinesq) .and. MassWghtInterp_NonBous_bug) & + CS%MassWghtInterp = ibset(CS%MassWghtInterp, 3) ! Same as CS%MassWghtInterp + 8 + + call get_param(param_file, mdl, "CORRECTION_INTXPA", CS%correction_intxpa, & + "If true, use a correction for surface pressure curvature in intx_pa.", & + default=.false., do_not_log=.not.use_EOS) + call get_param(param_file, mdl, "RESET_INTXPA_INTEGRAL", CS%reset_intxpa_integral, & + "If true, reset INTXPA to match pressures at first nonvanished cell. "//& + "Includes pressure correction.", default=.false., do_not_log=.not.use_EOS) + call get_param(param_file, mdl, "RESET_INTXPA_INTEGRAL_FLATTEST", CS%reset_intxpa_flattest, & + "If true, use flattest interface as reference interface where there is no "//& + "better choice for RESET_INTXPA_INTEGRAL. Otherwise, use surface interface.", & + default=.false., do_not_log=.not.use_EOS) + if (.not.use_EOS) then ! These options do nothing without an equation of state. + CS%correction_intxpa = .false. + CS%reset_intxpa_integral = .false. + CS%reset_intxpa_flattest = .false. + endif + call get_param(param_file, mdl, "RESET_INTXPA_H_NONVANISHED", CS%h_nonvanished, & + "A minimal layer thickness that indicates that a layer is thick enough to usefully "//& + "reestimate the pressure integral across the interface below.", & + default=1.0e-6, units="m", scale=GV%m_to_H, do_not_log=.not.CS%reset_intxpa_integral) call get_param(param_file, mdl, "USE_INACCURATE_PGF_RHO_ANOM", CS%use_inaccurate_pgf_rho_anom, & "If true, use a form of the PGF that uses the reference density "//& "in an inaccurate way. This is not recommended.", default=.false.) @@ -853,30 +2182,68 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, tides_CS "integrals within the FV pressure gradient calculation.\n"//& " 0: PCM or no reconstruction.\n"//& " 1: PLM reconstruction.\n"//& - " 2: PPM reconstruction.", default=1) + " 2: PPM reconstruction.\n"//& + " 3: PLM with least squares slope.", default=1) call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION_PRESSURE", CS%boundary_extrap, & "If true, the reconstruction of T & S for pressure in "//& "boundary cells is extrapolated, rather than using PCM "//& "in these cells. If true, the same order polynomial is "//& "used as is used for the interior cells.", default=.true.) - call get_param(param_file, mdl, "PGF_STANLEY_T2_DET_COEFF", CS%Stanley_T2_det_coeff, & - "The coefficient correlating SGS temperature variance with "// & - "the mean temperature gradient in the deterministic part of "// & - "the Stanley form of the Brankart correction. "// & - "Negative values disable the scheme.", units="nondim", default=-1.0) - if (CS%Stanley_T2_det_coeff>=0.) then - CS%id_tvar_sgs = register_diag_field('ocean_model', 'tvar_sgs_pgf', diag%axesTL, & - Time, 'SGS temperature variance used in PGF', 'degC2') + call get_param(param_file, mdl, "USE_STANLEY_PGF", CS%use_stanley_pgf, & + "If true, turn on Stanley SGS T variance parameterization "// & + "in PGF code.", default=.false.) + if (CS%use_stanley_pgf) then + call get_param(param_file, mdl, "STANLEY_COEFF", Stanley_coeff, & + "Coefficient correlating the temperature gradient and SGS T variance.", & + units="nondim", default=-1.0, do_not_log=.true.) + if (Stanley_coeff < 0.0) call MOM_error(FATAL, & + "STANLEY_COEFF must be set >= 0 if USE_STANLEY_PGF is true.") + + CS%id_rho_pgf = register_diag_field('ocean_model', 'rho_pgf', diag%axesTL, & + Time, 'rho in PGF', 'kg m-3', conversion=US%R_to_kg_m3) + CS%id_rho_stanley_pgf = register_diag_field('ocean_model', 'rho_stanley_pgf', diag%axesTL, & + Time, 'rho in PGF with Stanley correction', 'kg m-3', conversion=US%R_to_kg_m3) + CS%id_p_stanley = register_diag_field('ocean_model', 'p_stanley', diag%axesTL, & + Time, 'p in PGF with Stanley correction', 'Pa', conversion=US%RL2_T2_to_Pa) + endif + if (CS%calculate_SAL) then + CS%id_e_sal = register_diag_field('ocean_model', 'e_sal', diag%axesT1, Time, & + 'Self-attraction and loading height anomaly', 'meter', conversion=US%Z_to_m) + CS%id_sal_u = register_diag_field('ocean_model', 'SAL_u', diag%axesCuL, Time, & + 'Zonal Acceleration due to self-attraction and loading', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_sal_v = register_diag_field('ocean_model', 'SAL_v', diag%axesCvL, Time, & + 'Meridional Acceleration due to self-attraction and loading', 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_sal_u > 0) & + call safe_alloc_ptr(ADp%sal_u, IsdB, IedB, jsd, jed, nz) + if (CS%id_sal_v > 0) & + call safe_alloc_ptr(ADp%sal_v, isd, ied, JsdB, JedB, nz) endif if (CS%tides) then - CS%id_e_tidal = register_diag_field('ocean_model', 'e_tidal', diag%axesT1, & - Time, 'Tidal Forcing Astronomical and SAL Height Anomaly', 'meter', conversion=US%Z_to_m) + CS%id_e_tide = register_diag_field('ocean_model', 'e_tidal', diag%axesT1, Time, & + 'Tidal Forcing Astronomical and SAL Height Anomaly', 'meter', conversion=US%Z_to_m) + CS%id_e_tidal_eq = register_diag_field('ocean_model', 'e_tide_eq', diag%axesT1, Time, & + 'Equilibrium tides height anomaly', 'meter', conversion=US%Z_to_m) + CS%id_e_tidal_sal = register_diag_field('ocean_model', 'e_tide_sal', diag%axesT1, Time, & + 'Read-in tidal self-attraction and loading height anomaly', 'meter', conversion=US%Z_to_m) + CS%id_tides_u = register_diag_field('ocean_model', 'tides_u', diag%axesCuL, Time, & + 'Zonal Acceleration due to tidal forcing', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_tides_v = register_diag_field('ocean_model', 'tides_v', diag%axesCvL, Time, & + 'Meridional Acceleration due to tidal forcing', 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_tides_u > 0) & + call safe_alloc_ptr(ADp%tides_u, IsdB, IedB, jsd, jed, nz) + if (CS%id_tides_v > 0) & + call safe_alloc_ptr(ADp%tides_v, isd, ied, JsdB, JedB, nz) endif + CS%id_MassWt_u = register_diag_field('ocean_model', 'MassWt_u', diag%axesCuL, Time, & + 'The fractional mass weighting at u-point PGF calculations', 'nondim') + CS%id_MassWt_v = register_diag_field('ocean_model', 'MassWt_v', diag%axesCvL, Time, & + 'The fractional mass weighting at v-point PGF calculations', 'nondim') + CS%GFS_scale = 1.0 if (GV%g_prime(1) /= GV%g_Earth) CS%GFS_scale = GV%g_prime(1) / GV%g_Earth - call log_param(param_file, mdl, "GFS / G_EARTH", CS%GFS_scale) + call log_param(param_file, mdl, "GFS / G_EARTH", CS%GFS_scale, units="nondim") end subroutine PressureForce_FV_init diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 18ea07b313..e79f540546 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -1,14 +1,17 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Provides the Montgomery potential form of pressure gradient module MOM_PressureForce_Mont -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_density_integrals, only : int_specific_vol_dp use MOM_diag_mediator, only : post_data, register_diag_field use MOM_diag_mediator, only : safe_alloc_ptr, diag_ctrl, time_type use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_self_attr_load, only : calc_SAL, SAL_CS use MOM_tidal_forcing, only : calc_tidal_forcing, tidal_forcing_CS use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs @@ -31,6 +34,7 @@ module MOM_PressureForce_Mont !> Control structure for the Montgomery potential form of pressure gradient type, public :: PressureForce_Mont_CS ; private logical :: initialized = .false. !< True if this control structure has been initialized. + logical :: calculate_SAL !< If true, calculate self-attraction and loading. logical :: tides !< If true, apply tidal momentum forcing. real :: Rho0 !< The density used in the Boussinesq !! approximation [R ~> kg m-3]. @@ -45,8 +49,10 @@ module MOM_PressureForce_Mont real, allocatable :: PFv_bc(:,:,:) !< Meridional accelerations due to pressure gradients !! deriving from density gradients within layers [L T-2 ~> m s-2]. !>@{ Diagnostic IDs - integer :: id_PFu_bc = -1, id_PFv_bc = -1, id_e_tidal = -1 + integer :: id_PFu_bc = -1, id_PFv_bc = -1, id_e_sal = -1 + integer :: id_e_tide = -1, id_e_tide_eq = -1, id_e_tide_sal = -1 !>@} + type(SAL_CS), pointer :: SAL_CSp => NULL() !< SAL control structure type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< The tidal forcing control structure end type PressureForce_Mont_CS @@ -91,9 +97,9 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb ! in seawater, but p will still be close to the pressure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: & T_tmp, & ! Temporary array of temperatures where layers that are lighter - ! than the mixed layer have the mixed layer's properties [degC]. + ! than the mixed layer have the mixed layer's properties [C ~> degC]. S_tmp ! Temporary array of salinities where layers that are lighter - ! than the mixed layer have the mixed layer's properties [ppt]. + ! than the mixed layer have the mixed layer's properties [S ~> ppt]. real, dimension(SZI_(G)) :: Rho_cv_BL ! The coordinate potential density in the ! deepest variable density near-surface layer [R ~> kg m-3]. @@ -103,8 +109,10 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb ! of a reduced gravity form of the equations [L2 T-2 ~> m2 s-2]. dp_star, & ! Layer thickness after compensation for compressibility [R L2 T-2 ~> Pa]. SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. - e_tidal, & ! Bottom geopotential anomaly due to tidal forces from - ! astronomical sources and self-attraction and loading [Z ~> m]. + e_sal, & ! Bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. + e_tide_eq, & ! Bottom geopotential anomaly due to tidal forces from astronomical sources [Z ~> m]. + e_tide_sal, & ! Bottom geopotential anomaly due to harmonic self-attraction and loading + ! specific to tides [Z ~> m]. geopot_bot ! Bottom geopotential relative to a temporally fixed reference value, ! including any tidal contributions [L2 T-2 ~> m2 s-2]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate @@ -122,7 +130,8 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb real :: I_gEarth ! The inverse of g_Earth [T2 Z L-2 ~> s2 m-1] ! real :: dalpha - real :: Pa_to_H ! A factor to convert from R L2 T-2 to the thickness units (H). + real :: Pa_to_H ! A factor to convert from R L2 T-2 to the thickness units (H) + ! [H T2 R-1 L-2 ~> m2 s2 kg-1 or s2 m-1]. real :: alpha_Lay(SZK_(GV)) ! The specific volume of each layer [R-1 ~> m3 kg-1]. real :: dalpha_int(SZK_(GV)+1) ! The change in specific volume across each ! interface [R-1 ~> m3 kg-1]. @@ -179,12 +188,18 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb endif endif - if (CS%tides) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + geopot_bot(i,j) = -GV%g_Earth * G%bathyT(i,j) + enddo ; enddo + + ! Calculate and add the self-attraction and loading geopotential anomaly. + if (CS%calculate_SAL) then ! Determine the sea surface height anomalies, to enable the calculation ! of self-attraction and loading. !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - SSH(i,j) = -G%bathyT(i,j) - G%Z_ref + SSH(i,j) = min(-G%bathyT(i,j) - G%meanSL(i,j), 0.0) enddo ; enddo if (use_EOS) then !$OMP parallel do default(shared) @@ -203,15 +218,19 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb enddo ; enddo ; enddo endif - call calc_tidal_forcing(CS%Time, SSH, e_tidal, G, US, CS%tides_CSp) + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - geopot_bot(i,j) = -GV%g_Earth*(e_tidal(i,j) + G%bathyT(i,j)) + geopot_bot(i,j) = geopot_bot(i,j) - GV%g_Earth*e_sal(i,j) enddo ; enddo - else + endif + + ! Calculate and add the tidal geopotential anomaly. + if (CS%tides) then + call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - geopot_bot(i,j) = -GV%g_Earth*G%bathyT(i,j) + geopot_bot(i,j) = geopot_bot(i,j) - GV%g_Earth*(e_tide_eq(i,j) + e_tide_sal(i,j)) enddo ; enddo endif @@ -320,14 +339,14 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb do j=js,je ; do I=Isq,Ieq ! PFu_bc = p* grad alpha* PFu_bc = (alpha_star(i+1,j,k) - alpha_star(i,j,k)) * (G%IdxCu(I,j) * & - ((dp_star(i,j)*dp_star(i+1,j) + (p(i,j,K)*dp_star(i+1,j) + p(i+1,j,K)*dp_star(i,j))) / & + ((dp_star(i,j)*dp_star(i+1,j) + ((p(i,j,K)*dp_star(i+1,j)) + (p(i+1,j,K)*dp_star(i,j)))) / & (dp_star(i,j) + dp_star(i+1,j)))) PFu(I,j,k) = -(M(i+1,j,k) - M(i,j,k)) * G%IdxCu(I,j) + PFu_bc if (allocated(CS%PFu_bc)) CS%PFu_bc(i,j,k) = PFu_bc enddo ; enddo do J=Jsq,Jeq ; do i=is,ie PFv_bc = (alpha_star(i,j+1,k) - alpha_star(i,j,k)) * (G%IdyCv(i,J) * & - ((dp_star(i,j)*dp_star(i,j+1) + (p(i,j,K)*dp_star(i,j+1) + p(i,j+1,K)*dp_star(i,j))) / & + ((dp_star(i,j)*dp_star(i,j+1) + ((p(i,j,K)*dp_star(i,j+1)) + (p(i,j+1,K)*dp_star(i,j)))) / & (dp_star(i,j) + dp_star(i,j+1)))) PFv(i,J,k) = -(M(i,j+1,k) - M(i,j,k)) * G%IdyCv(i,J) + PFv_bc if (allocated(CS%PFv_bc)) CS%PFv_bc(i,j,k) = PFv_bc @@ -347,7 +366,12 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb if (CS%id_PFu_bc>0) call post_data(CS%id_PFu_bc, CS%PFu_bc, CS%diag) if (CS%id_PFv_bc>0) call post_data(CS%id_PFv_bc, CS%PFv_bc, CS%diag) - if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_tidal, CS%diag) + ! To be consistent with old runs, tidal forcing diagnostic also includes total SAL. + ! New diagnostics are given for each individual field. + if (CS%id_e_tide>0) call post_data(CS%id_e_tide, e_sal+e_tide_eq+e_tide_sal, CS%diag) + if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) + if (CS%id_e_tide_eq>0) call post_data(CS%id_e_tide_eq, e_tide_eq, CS%diag) + if (CS%id_e_tide_sal>0) call post_data(CS%id_e_tide_sal, e_tide_sal, CS%diag) end subroutine PressureForce_Mont_nonBouss @@ -380,31 +404,33 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, M, & ! The Montgomery potential, M = (p/rho + gz) [L2 T-2 ~> m2 s-2]. rho_star ! In-situ density divided by the derivative with depth of the ! corrected e times (G_Earth/Rho0) [L2 Z-1 T-2 ~> m s-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: e ! Interface height in m. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: e ! Interface height [Z ~> m]. ! e may be adjusted (with a nonlinear equation of state) so that ! its derivative compensates for the adiabatic compressibility ! in seawater, but e will still be close to the interface depth. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: & T_tmp, & ! Temporary array of temperatures where layers that are lighter - ! than the mixed layer have the mixed layer's properties [degC]. + ! than the mixed layer have the mixed layer's properties [C ~> degC]. S_tmp ! Temporary array of salinities where layers that are lighter - ! than the mixed layer have the mixed layer's properties [ppt]. + ! than the mixed layer have the mixed layer's properties [S ~> ppt]. real :: Rho_cv_BL(SZI_(G)) ! The coordinate potential density in ! the deepest variable density near-surface layer [R ~> kg m-3]. real :: h_star(SZI_(G),SZJ_(G)) ! Layer thickness after compensation ! for compressibility [Z ~> m]. real :: SSH(SZI_(G),SZJ_(G)) ! The sea surface height anomaly, in depth units [Z ~> m]. - real :: e_tidal(SZI_(G),SZJ_(G)) ! Bottom geopotential anomaly due to tidal - ! forces from astronomical sources and self- - ! attraction and loading, in depth units [Z ~> m]. + real :: e_sal(SZI_(G),SZJ_(G)) ! The bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. + real :: e_tide_eq(SZI_(G),SZJ_(G)) ! Bottom geopotential anomaly due to tidal forces from astronomical sources + ! [Z ~> m]. + real :: e_tide_sal(SZI_(G),SZJ_(G)) ! Bottom geopotential anomaly due to harmonic self-attraction and loading + ! specific to tides, in depth units [Z ~> m]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density [R L2 T-2 ~> Pa] (usually 2e7 Pa = 2000 dbar). real :: I_Rho0 ! 1/Rho0 [R-1 ~> m3 kg-1]. real :: G_Rho0 ! G_Earth / Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]. real :: PFu_bc, PFv_bc ! The pressure gradient force due to along-layer ! compensated density gradients [L T-2 ~> m s-2] - real :: h_neglect ! A thickness that is so small it is usually lost + real :: dz_neglect ! A vertical distance that is so small it is usually lost ! in roundoff and can be neglected [Z ~> m]. logical :: use_p_atm ! If true, use the atmospheric pressure. logical :: use_EOS ! If true, density is calculated from T & S using @@ -435,37 +461,44 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, "can no longer be used with a compressible EOS. Use #define ANALYTIC_FV_PGF.") endif - h_neglect = GV%H_subroundoff * GV%H_to_Z + dz_neglect = GV%dZ_subroundoff I_Rho0 = 1.0/CS%Rho0 G_Rho0 = GV%g_Earth / GV%Rho0 - if (CS%tides) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,nz+1) = -G%bathyT(i,j) + enddo ; enddo + + ! Calculate and add the self-attraction and loading geopotential anomaly. + if (CS%calculate_SAL) then ! Determine the surface height anomaly for calculating self attraction ! and loading. This should really be based on bottom pressure anomalies, ! but that is not yet implemented, and the current form is correct for ! barotropic tides. !$OMP parallel do default(shared) do j=Jsq,Jeq+1 - do i=Isq,Ieq+1 ; SSH(i,j) = -G%bathyT(i,j) - G%Z_ref ; enddo + do i=Isq,Ieq+1 ; SSH(i,j) = min(-G%bathyT(i,j) - G%meanSL(i,j), 0.0) ; enddo do k=1,nz ; do i=Isq,Ieq+1 SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z enddo ; enddo enddo - call calc_tidal_forcing(CS%Time, SSH, e_tidal, G, US, CS%tides_CSp) - endif - -! Here layer interface heights, e, are calculated. - if (CS%tides) then + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -(G%bathyT(i,j) + e_tidal(i,j)) + e(i,j,nz+1) = e(i,j,nz+1) - e_sal(i,j) enddo ; enddo - else + endif + + ! Calculate and add the tidal geopotential anomaly. + if (CS%tides) then + call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -G%bathyT(i,j) + e(i,j,nz+1) = e(i,j,nz+1) - (e_tide_eq(i,j) + e_tide_sal(i,j)) enddo ; enddo endif + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do k=nz,1,-1 ; do i=Isq,Ieq+1 e(i,j,K) = e(i,j,K+1) + h(i,j,k)*GV%H_to_Z @@ -551,19 +584,19 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, !$OMP parallel do default(shared) private(h_star,PFu_bc,PFv_bc) do k=1,nz do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - h_star(i,j) = (e(i,j,K) - e(i,j,K+1)) + h_neglect + h_star(i,j) = (e(i,j,K) - e(i,j,K+1)) + dz_neglect enddo ; enddo do j=js,je ; do I=Isq,Ieq PFu_bc = -1.0*(rho_star(i+1,j,k) - rho_star(i,j,k)) * (G%IdxCu(I,j) * & - ((h_star(i,j) * h_star(i+1,j) - (e(i,j,K) * h_star(i+1,j) + & - e(i+1,j,K) * h_star(i,j))) / (h_star(i,j) + h_star(i+1,j)))) + ((h_star(i,j) * h_star(i+1,j) - ((e(i,j,K) * h_star(i+1,j)) + & + (e(i+1,j,K) * h_star(i,j)))) / (h_star(i,j) + h_star(i+1,j)))) PFu(I,j,k) = -(M(i+1,j,k) - M(i,j,k)) * G%IdxCu(I,j) + PFu_bc if (allocated(CS%PFu_bc)) CS%PFu_bc(i,j,k) = PFu_bc enddo ; enddo do J=Jsq,Jeq ; do i=is,ie PFv_bc = -1.0*(rho_star(i,j+1,k) - rho_star(i,j,k)) * (G%IdyCv(i,J) * & - ((h_star(i,j) * h_star(i,j+1) - (e(i,j,K) * h_star(i,j+1) + & - e(i,j+1,K) * h_star(i,j))) / (h_star(i,j) + h_star(i,j+1)))) + ((h_star(i,j) * h_star(i,j+1) - ((e(i,j,K) * h_star(i,j+1)) + & + (e(i,j+1,K) * h_star(i,j)))) / (h_star(i,j) + h_star(i,j+1)))) PFv(i,J,k) = -(M(i,j+1,k) - M(i,j,k)) * G%IdyCv(i,J) + PFv_bc if (allocated(CS%PFv_bc)) CS%PFv_bc(i,j,k) = PFv_bc enddo ; enddo @@ -581,25 +614,35 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, endif ! use_EOS if (present(eta)) then - if (CS%tides) then ! eta is the sea surface height relative to a time-invariant geoid, for ! comparison with what is used for eta in btstep. See how e was calculated ! about 200 lines above. + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = e(i,j,1)*GV%Z_to_H + enddo ; enddo + if (CS%tides) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%Z_to_H + e_tidal(i,j)*GV%Z_to_H + eta(i,j) = eta(i,j) + (e_tide_eq(i,j)+e_tide_sal(i,j))*GV%Z_to_H enddo ; enddo - else + endif + if (CS%calculate_SAL) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%Z_to_H + eta(i,j) = eta(i,j) + e_sal(i,j)*GV%Z_to_H enddo ; enddo endif endif if (CS%id_PFu_bc>0) call post_data(CS%id_PFu_bc, CS%PFu_bc, CS%diag) if (CS%id_PFv_bc>0) call post_data(CS%id_PFv_bc, CS%PFv_bc, CS%diag) - if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_tidal, CS%diag) + ! To be consistent with old runs, tidal forcing diagnostic also includes total SAL. + ! New diagnostics are given for each individual field. + if (CS%id_e_tide>0) call post_data(CS%id_e_tide, e_sal+e_tide_eq+e_tide_sal, CS%diag) + if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) + if (CS%id_e_tide_eq>0) call post_data(CS%id_e_tide_eq, e_tide_eq, CS%diag) + if (CS%id_e_tide_sal>0) call post_data(CS%id_e_tide_sal, e_tide_sal, CS%diag) end subroutine PressureForce_Mont_Bouss @@ -626,16 +669,16 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) ! Local variables real :: Ihtot(SZI_(G)) ! The inverse of the sum of the layer thicknesses [H-1 ~> m-1 or m2 kg-1]. real :: press(SZI_(G)) ! Interface pressure [R L2 T-2 ~> Pa]. - real :: T_int(SZI_(G)) ! Interface temperature [degC]. - real :: S_int(SZI_(G)) ! Interface salinity [ppt]. - real :: dR_dT(SZI_(G)) ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. - real :: dR_dS(SZI_(G)) ! Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. + real :: T_int(SZI_(G)) ! Interface temperature [C ~> degC] + real :: S_int(SZI_(G)) ! Interface salinity [S ~> ppt] + real :: dR_dT(SZI_(G)) ! Partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: dR_dS(SZI_(G)) ! Partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. real :: rho_in_situ(SZI_(G)) ! In-situ density at the top of a layer [R ~> kg m-3]. real :: G_Rho0 ! A scaled version of g_Earth / Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] real :: Rho0xG ! g_Earth * Rho0 [R L2 Z-1 T-2 ~> kg s-2 m-2] logical :: use_EOS ! If true, density is calculated from T & S using ! an equation of state. - real :: z_neglect ! A thickness that is so small it is usually lost + real :: dz_neglect ! A vertical distance that is so small it is usually lost ! in roundoff and can be neglected [Z ~> m]. integer, dimension(2) :: EOSdom ! The computational domain for the equation of state integer :: Isq, Ieq, Jsq, Jeq, nz, i, j, k @@ -646,14 +689,14 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) Rho0xG = Rho0 * GV%g_Earth G_Rho0 = GV%g_Earth / GV%Rho0 use_EOS = associated(tv%eqn_of_state) - z_neglect = GV%H_subroundoff*GV%H_to_Z + dz_neglect = GV%dZ_subroundoff if (use_EOS) then if (present(rho_star)) then !$OMP parallel do default(shared) private(Ihtot) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - Ihtot(i) = GV%H_to_Z / ((e(i,j,1)-e(i,j,nz+1)) + z_neglect) + Ihtot(i) = GV%H_to_Z / ((e(i,j,1)-e(i,j,nz+1)) + dz_neglect) pbce(i,j,1) = GFS_scale * rho_star(i,j,1) * GV%H_to_Z enddo do k=2,nz ; do i=Isq,Ieq+1 @@ -665,8 +708,8 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) !$OMP parallel do default(shared) private(Ihtot,press,rho_in_situ,T_int,S_int,dR_dT,dR_dS) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - Ihtot(i) = GV%H_to_Z / ((e(i,j,1)-e(i,j,nz+1)) + z_neglect) - press(i) = -Rho0xG*(e(i,j,1) - G%Z_ref) + Ihtot(i) = GV%H_to_Z / ((e(i,j,1)-e(i,j,nz+1)) + dz_neglect) + press(i) = -Rho0xG*(e(i,j,1) - G%meanSL(i,j)) enddo call calculate_density(tv%T(:,j,1), tv%S(:,j,1), press, rho_in_situ, & tv%eqn_of_state, EOSdom) @@ -675,7 +718,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) enddo do k=2,nz do i=Isq,Ieq+1 - press(i) = -Rho0xG*(e(i,j,K) - G%Z_ref) + press(i) = -Rho0xG*(e(i,j,K) - G%meanSL(i,j)) T_int(i) = 0.5*(tv%T(i,j,k-1)+tv%T(i,j,k)) S_int(i) = 0.5*(tv%S(i,j,k-1)+tv%S(i,j,k)) enddo @@ -694,7 +737,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) !$OMP parallel do default(shared) private(Ihtot) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - Ihtot(i) = 1.0 / ((e(i,j,1)-e(i,j,nz+1)) + z_neglect) + Ihtot(i) = 1.0 / ((e(i,j,1)-e(i,j,nz+1)) + dz_neglect) pbce(i,j,1) = GV%g_prime(1) * GV%H_to_Z enddo do k=2,nz ; do i=Isq,Ieq+1 @@ -727,10 +770,10 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) dpbce, & ! A barotropic correction to the pbce to enable the use of ! a reduced gravity form of the equations [L2 H-1 T-2 ~> m4 kg-1 s-2]. C_htot ! dP_dH divided by the total ocean pressure [H-1 ~> m2 kg-1]. - real :: T_int(SZI_(G)) ! Interface temperature [degC]. - real :: S_int(SZI_(G)) ! Interface salinity [ppt]. - real :: dR_dT(SZI_(G)) ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. - real :: dR_dS(SZI_(G)) ! Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. + real :: T_int(SZI_(G)) ! Interface temperature [C ~> degC] + real :: S_int(SZI_(G)) ! Interface salinity [S ~> ppt] + real :: dR_dT(SZI_(G)) ! Partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: dR_dS(SZI_(G)) ! Partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. real :: rho_in_situ(SZI_(G)) ! In-situ density at an interface [R ~> kg m-3]. real :: alpha_Lay(SZK_(GV)) ! The specific volume of each layer [R-1 ~> m3 kg-1]. real :: dalpha_int(SZK_(GV)+1) ! The change in specific volume across each interface [R-1 ~> m3 kg-1]. @@ -820,7 +863,7 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) end subroutine Set_pbce_nonBouss !> Initialize the Montgomery-potential form of PGF control structure -subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) +subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, tides_CSp) type(time_type), target, intent(in) :: Time !< Current model time type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure @@ -828,10 +871,11 @@ subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, tides_ type(param_file_type), intent(in) :: param_file !< Parameter file handles type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(PressureForce_Mont_CS), intent(inout) :: CS !< Montgomery PGF control structure + type(SAL_CS), intent(in), target, optional :: SAL_CSp !< SAL control structure type(tidal_forcing_CS), intent(in), target, optional :: tides_CSp !< Tides control structure ! Local variables - logical :: use_temperature, use_EOS + logical :: use_EOS ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl ! This module's name. @@ -840,17 +884,21 @@ subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, tides_ CS%diag => diag ; CS%Time => Time if (present(tides_CSp)) & CS%tides_CSp => tides_CSp + if (present(SAL_CSp)) & + CS%SAL_CSp => SAL_CSp mdl = "MOM_PressureForce_Mont" call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "RHO_0", CS%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& + "properties, or with BOUSSINESQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0, scale=US%R_to_kg_m3) call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=CS%tides) call get_param(param_file, mdl, "USE_EOS", use_EOS, default=.true., & do_not_log=.true.) ! Input for diagnostic use only. @@ -865,15 +913,23 @@ subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, tides_ allocate(CS%PFv_bc(G%isd:G%ied,G%JsdB:G%JedB,GV%ke), source=0.) endif + if (CS%calculate_SAL) then + CS%id_e_sal = register_diag_field('ocean_model', 'e_sal', diag%axesT1, Time, & + 'Self-attraction and loading height anomaly', 'meter', conversion=US%Z_to_m) + endif if (CS%tides) then - CS%id_e_tidal = register_diag_field('ocean_model', 'e_tidal', diag%axesT1, & - Time, 'Tidal Forcing Astronomical and SAL Height Anomaly', 'meter', conversion=US%Z_to_m) + CS%id_e_tide = register_diag_field('ocean_model', 'e_tidal', diag%axesT1, Time, & + 'Tidal Forcing Astronomical and SAL Height Anomaly', 'meter', conversion=US%Z_to_m) + CS%id_e_tide_eq = register_diag_field('ocean_model', 'e_tide_eq', diag%axesT1, Time, & + 'Equilibrium tides height anomaly', 'meter', conversion=US%Z_to_m) + CS%id_e_tide_sal = register_diag_field('ocean_model', 'e_tide_sal', diag%axesT1, Time, & + 'Read-in tidal self-attraction and loading height anomaly', 'meter', conversion=US%Z_to_m) endif CS%GFS_scale = 1.0 if (GV%g_prime(1) /= GV%g_Earth) CS%GFS_scale = GV%g_prime(1) / GV%g_Earth - call log_param(param_file, mdl, "GFS / G_EARTH", CS%GFS_scale) + call log_param(param_file, mdl, "GFS / G_EARTH", CS%GFS_scale, units="nondim") end subroutine PressureForce_Mont_init diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index a7e8194a84..3a1fa10a7e 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -1,12 +1,16 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Barotropic solver module MOM_barotropic -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_debugging, only : hchksum, uvchksum +use MOM_checksums, only : chksum0 +use MOM_coms, only : any_across_PEs use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_debugging, only : hchksum, uvchksum, Bchksum use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field -use MOM_diag_mediator, only : diag_ctrl, enable_averaging +use MOM_diag_mediator, only : diag_ctrl, enable_averaging, enable_averages use MOM_domains, only : min_across_PEs, clone_MOM_domain, deallocate_MOM_domain use MOM_domains, only : To_All, Scalar_Pair, AGRID, CORNER, MOM_domain_type use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type @@ -15,19 +19,23 @@ module MOM_barotropic use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : mech_forcing use MOM_grid, only : ocean_grid_type +use MOM_harmonic_analysis, only : HA_accum, harmonic_analysis_CS use MOM_hor_index, only : hor_index_type -use MOM_io, only : vardesc, var_desc, MOM_read_data, slasher -use MOM_open_boundary, only : ocean_OBC_type, OBC_SIMPLE, OBC_NONE, open_boundary_query +use MOM_io, only : vardesc, var_desc, MOM_read_data, slasher, NORTH_FACE, EAST_FACE +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, open_boundary_query use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S, OBC_segment_type use MOM_restart, only : register_restart_field, register_restart_pair use MOM_restart, only : query_initialized, MOM_restart_CS -use MOM_tidal_forcing, only : tidal_forcing_sensitivity, tidal_forcing_CS +use MOM_self_attr_load, only : scalar_SAL_sensitivity +use MOM_self_attr_load, only : SAL_CS +use MOM_streaming_filter, only : Filt_register, Filt_init, Filt_accum, Filter_CS use MOM_time_manager, only : time_type, real_to_time, operator(+), operator(-) use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : BT_cont_type, alloc_bt_cont_type use MOM_verticalGrid, only : verticalGrid_type use MOM_variables, only : accel_diag_ptrs +use MOM_wave_drag, only : wave_drag_init, wave_drag_calc, wave_drag_CS implicit none ; private @@ -69,8 +77,8 @@ module MOM_barotropic type, private :: BT_OBC_type real, allocatable :: Cg_u(:,:) !< The external wave speed at u-points [L T-1 ~> m s-1]. real, allocatable :: Cg_v(:,:) !< The external wave speed at u-points [L T-1 ~> m s-1]. - real, allocatable :: H_u(:,:) !< The total thickness at the u-points [H ~> m or kg m-2]. - real, allocatable :: H_v(:,:) !< The total thickness at the v-points [H ~> m or kg m-2]. + real, allocatable :: dZ_u(:,:) !< The total vertical column extent at the u-points [Z ~> m]. + real, allocatable :: dZ_v(:,:) !< The total vertical column extent at the v-points [Z ~> m]. real, allocatable :: uhbt(:,:) !< The zonal barotropic thickness fluxes specified !! for open boundary conditions (if any) [H L2 T-1 ~> m3 s-1 or kg s-1]. real, allocatable :: vhbt(:,:) !< The meridional barotropic thickness fluxes specified @@ -79,25 +87,29 @@ module MOM_barotropic !! as set by the open boundary conditions [L T-1 ~> m s-1]. real, allocatable :: vbt_outer(:,:) !< The meridional velocities just outside the domain, !! as set by the open boundary conditions [L T-1 ~> m s-1]. - real, allocatable :: eta_outer_u(:,:) !< The surface height outside of the domain - !! at a u-point with an open boundary condition [H ~> m or kg m-2]. - real, allocatable :: eta_outer_v(:,:) !< The surface height outside of the domain - !! at a v-point with an open boundary condition [H ~> m or kg m-2]. - logical :: apply_u_OBCs !< True if this PE has an open boundary at a u-point. - logical :: apply_v_OBCs !< True if this PE has an open boundary at a v-point. - !>@{ Index ranges for the open boundary conditions - integer :: is_u_obc, ie_u_obc, js_u_obc, je_u_obc - integer :: is_v_obc, ie_v_obc, js_v_obc, je_v_obc + real, allocatable :: SSH_outer_u(:,:) !< The surface height outside of the domain + !! at a u-point with an open boundary condition [Z ~> m]. + real, allocatable :: SSH_outer_v(:,:) !< The surface height outside of the domain + !! at a v-point with an open boundary condition [Z ~> m]. + integer, allocatable :: u_OBC_type(:,:) !< An integer encoding the type and direction of u-point OBCs + integer, allocatable :: v_OBC_type(:,:) !< An integer encoding the type and direction of v-point OBCs + logical :: u_OBCs_on_PE !< True if this PE has an open boundary at any u-points. + logical :: v_OBCs_on_PE !< True if this PE has an open boundary at any v-points. + !>@{ Index ranges on the local PE for the open boundary conditions in various directions + integer :: Is_u_W_obc, Ie_u_W_obc, js_u_W_obc, je_u_W_obc + integer :: Is_u_E_obc, Ie_u_E_obc, js_u_E_obc, je_u_E_obc + integer :: is_v_S_obc, ie_v_S_obc, Js_v_S_obc, Je_v_S_obc + integer :: is_v_N_obc, ie_v_N_obc, Js_v_N_obc, Je_v_N_obc !>@} - logical :: is_alloced = .false. !< True if BT_OBC is in use and has been allocated - type(group_pass_type) :: pass_uv !< Structure for group halo pass - type(group_pass_type) :: pass_uhvh !< Structure for group halo pass - type(group_pass_type) :: pass_h !< Structure for group halo pass - type(group_pass_type) :: pass_cg !< Structure for group halo pass - type(group_pass_type) :: pass_eta_outer !< Structure for group halo pass + type(group_pass_type) :: pass_uv !< Structure for group halo pass of vectors + type(group_pass_type) :: scalar_pass !< Structure for group halo pass of scalars end type BT_OBC_type +integer, parameter :: SPECIFIED_OBC = 1 !< An integer used to encode a specified OBC point +integer, parameter :: FLATHER_OBC = 2 !< An integer used to encode a Flather OBC point +integer, parameter :: GRADIENT_OBC = 4 !< An integer used to encode a gradient OBC point + !> The barotropic stepping control structure type, public :: barotropic_CS ; private real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: frhatu @@ -105,21 +117,21 @@ module MOM_barotropic real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: frhatv !< The fraction of the total column thickness interpolated to v grid points in each layer [nondim]. real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: IDatu - !< Inverse of the basin depth at u grid points [Z-1 ~> m-1]. - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: lin_drag_u + !< Inverse of the total thickness at u grid points [H-1 ~> m-1 or m2 kg-1]. + real, allocatable, dimension(:,:) :: lin_drag_u !< A spatially varying linear drag coefficient acting on the zonal barotropic flow !! [H T-1 ~> m s-1 or kg m-2 s-1]. - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: ubt_IC + real, allocatable, dimension(:,:) :: ubt_IC !< The barotropic solvers estimate of the zonal velocity that will be the initial !! condition for the next call to btstep [L T-1 ~> m s-1]. real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: ubtav !< The barotropic zonal velocity averaged over the baroclinic time step [L T-1 ~> m s-1]. real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: IDatv !< Inverse of the basin depth at v grid points [Z-1 ~> m-1]. - real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: lin_drag_v + real, allocatable, dimension(:,:) :: lin_drag_v !< A spatially varying linear drag coefficient acting on the zonal barotropic flow !! [H T-1 ~> m s-1 or kg m-2 s-1]. - real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: vbt_IC + real, allocatable, dimension(:,:) :: vbt_IC !< The barotropic solvers estimate of the zonal velocity that will be the initial !! condition for the next call to btstep [L T-1 ~> m s-1]. real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: vbtav @@ -128,7 +140,7 @@ module MOM_barotropic !< The difference between the free surface height from the barotropic calculation and the sum !! of the layer thicknesses. This difference is imposed as a forcing term in the barotropic !! calculation over a baroclinic timestep [H ~> m or kg m-2]. - real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: eta_cor_bound + real, allocatable, dimension(:,:) :: eta_cor_bound !< A limit on the rate at which eta_cor can be applied while avoiding instability !! [H T-1 ~> m s-1 or kg m-2 s-1]. This is only used if CS%bound_BT_corr is true. real ALLOCABLE_, dimension(NIMEMW_,NJMEMW_) :: & @@ -139,18 +151,25 @@ module MOM_barotropic !< This is a copy of G%IareaT with wide halos, but will !! still utilize the macro IareaT when referenced, [L-2 ~> m-2]. real ALLOCABLE_, dimension(NIMEMBW_,NJMEMW_) :: & - D_u_Cor, & !< A simply averaged depth at u points [Z ~> m]. dy_Cu, & !< A copy of G%dy_Cu with wide halos [L ~> m]. - IdxCu !< A copy of G%IdxCu with wide halos [L-1 ~> m-1]. + IdxCu, & !< A copy of G%IdxCu with wide halos [L-1 ~> m-1]. + OBCmask_u !< An array to multiplicatively mask out changes at OBC points, 0 or 1 [nondim] real ALLOCABLE_, dimension(NIMEMW_,NJMEMBW_) :: & - D_v_Cor, & !< A simply averaged depth at v points [Z ~> m]. dx_Cv, & !< A copy of G%dx_Cv with wide halos [L ~> m]. - IdyCv !< A copy of G%IdyCv with wide halos [L-1 ~> m-1]. - real ALLOCABLE_, dimension(NIMEMBW_,NJMEMBW_) :: & - q_D !< f / D at PV points [Z-1 T-1 ~> m-1 s-1]. - + IdyCv, & !< A copy of G%IdyCv with wide halos [L-1 ~> m-1]. + OBCmask_v !< An array to multiplicatively mask out changes at OBC points, 0 or 1 [nondim] + real, allocatable, dimension(:,:) :: & + D_u_Cor, & !< A simply averaged depth at u points recast as a thickness [H ~> m or kg m-2] + D_v_Cor, & !< A simply averaged depth at v points recast as a thickness [H ~> m or kg m-2] + q_D !< f / D at PV points [T-1 H-1 ~> s-1 m-1 or m2 s-1 kg-1] + real, allocatable, dimension(:,:,:) :: & + q_wt !< The area weights for the thicknesses around a corner point to be used when + !! calculating PV for use in the Coriolis term, taking OBCs into account [L2 ~> m2]. + !! The order of the 4 values at a point is the order in which the neighboring + !! tracer points occur in memory, i.e. SW, SE, NW then NE. real, allocatable :: frhatu1(:,:,:) !< Predictor step values of frhatu stored for diagnostics [nondim] real, allocatable :: frhatv1(:,:,:) !< Predictor step values of frhatv stored for diagnostics [nondim] + real, allocatable :: IareaT_OBCmask(:,:) !< If non-zero, work on given points [L-2 ~> m-2]. type(BT_OBC_type) :: BT_OBC !< A structure with all of this modules fields !! for applying open boundary conditions. @@ -170,6 +189,10 @@ module MOM_barotropic !! 0.0 gives a forward-backward scheme, while 1.0 !! give backward Euler. In practice, bebt should be !! of order 0.2 or greater. + real :: Rho_BT_lin !< A density that is used to convert total water column thicknesses + !! into mass in non-Boussinesq mode with linearized options in the + !! barotropic solver or when estimating the stable barotropic timestep + !! without access to the full baroclinic model state [R ~> kg m-3] logical :: split !< If true, use the split time stepping scheme. logical :: bound_BT_corr !< If true, the magnitude of the fake mass source !! in the barotropic equation that drives the two @@ -192,6 +215,14 @@ module MOM_barotropic !! equation. Otherwise the transports are the sum of the transports !! based on a series of instantaneous velocities and the BT_CONT_TYPE !! for transports. This is only valid if a BT_CONT_TYPE is used. + logical :: bt_adjust_src_for_filter !< If true, increases the rate at which BT mass sources are + !! applied so that they are all used up before the steps within the + !! filtering period start. This avoids the mass sink driving the SSH + !! below the bottom during the period of filtering. + logical :: bt_limit_integral_transport !< If true, limit the time-integrated transports by the + !! initial volume accounting for sinks of mass. + logical :: integral_OBCs !< This is true if integral_bt_cont is true and there are open boundary + !! conditions being applied somewhere in the global domain. logical :: Nonlinear_continuity !< If true, the barotropic continuity equation !! uses the full ocean thickness for transport. integer :: Nonlin_cont_update_period !< The number of barotropic time steps @@ -207,24 +238,24 @@ module MOM_barotropic !! old and new velocities, with weights of (1-BEBT) and BEBT. logical :: nonlin_stress !< If true, use the full depth of the ocean at the start of the !! barotropic step when calculating the surface stress contribution to - !! the barotropic acclerations. Otherwise use the depth based on bathyT. + !! the barotropic accelerations. Otherwise use the depth based on bathyT. real :: BT_Coriolis_scale !< A factor by which the barotropic Coriolis acceleration anomaly !! terms are scaled [nondim]. - logical :: answers_2018 !< If true, use expressions for the barotropic solver that recover - !! the answers from the end of 2018. Otherwise, use more efficient - !! or general expressions. + integer :: answer_date !< The vintage of the expressions in the barotropic solver. + !! Values below 20190101 recover the answers from the end of 2018, + !! while higher values use more efficient or general expressions. logical :: dynamic_psurf !< If true, add a dynamic pressure due to a viscous !! ice shelf, for instance. - real :: Dmin_dyn_psurf !< The minimum depth to use in limiting the size - !! of the dynamic surface pressure for stability [Z ~> m]. + real :: Dmin_dyn_psurf !< The minimum total thickness to use in limiting the size + !! of the dynamic surface pressure for stability [H ~> m or kg m-2]. real :: ice_strength_length !< The length scale at which the damping rate !! due to the ice strength should be the same as if !! a Laplacian were applied [L ~> m]. real :: const_dyn_psurf !< The constant that scales the dynamic surface !! pressure [nondim]. Stable values are < ~1.0. !! The default is 0.9. - logical :: tides !< If true, apply tidal momentum forcing. + logical :: calculate_SAL !< If true, calculate self-attraction and loading. logical :: tidal_sal_bug !< If true, the tidal self-attraction and loading anomaly in the !! barotropic solver has the wrong sign, replicating a long-standing !! bug. @@ -235,20 +266,34 @@ module MOM_barotropic !! HARMONIC, ARITHMETIC, HYBRID, and FROM_BT_CONT logical :: strong_drag !< If true, use a stronger estimate of the retarding !! effects of strong bottom drag. + logical :: rescale_strong_drag !< If true, reduce the barotropic contribution to the layer + !! accelerations to account for the difference between the forces that + !! can be counteracted by the stronger drag with BT_STRONG_DRAG and the + !! average of the layer viscous remnants after a baroclinic timestep. logical :: linear_wave_drag !< If true, apply a linear drag to the barotropic !! velocities, using rates set by lin_drag_u & _v !! divided by the depth of the ocean. logical :: linearized_BT_PV !< If true, the PV and interface thicknesses used !! in the barotropic Coriolis calculation is time !! invariant and linearized. + logical :: use_filter !< If true, use streaming band-pass filter to detect the + !! instantaneous tidal signals in the simulation. + logical :: linear_freq_drag !< If true, apply a linear frequency-dependent drag to the tidal + !! velocities. The streaming band-pass filter must be turned on. logical :: use_wide_halos !< If true, use wide halos and march in during the !! barotropic time stepping for efficiency. + integer :: min_stencil !< The minimum stencil width to use with the wide halo iterations. + !! A nonzero value may reflect the distribution of OBC faces or it + !! may be useful for debugging purposes. logical :: clip_velocity !< If true, limit any velocity components that are !! are large enough for a CFL number to exceed !! CFL_trunc. This should only be used as a !! desperate debugging measure. logical :: debug !< If true, write verbose checksums for debugging purposes. - logical :: debug_bt !< If true, write verbose checksums for debugging purposes. + logical :: debug_bt !< If true, write verbose checksums from within the barotropic + !! time-stepping loop for debugging purposes. + logical :: debug_wide_halos !< If true, write the checksums on the full wide halos. Otherwise + !! only the output for the final computational domain is written. real :: vel_underflow !< Velocity components smaller than vel_underflow !! are set to 0 [L T-1 ~> m s-1]. real :: maxvel !< Velocity components greater than maxvel are @@ -273,12 +318,27 @@ module MOM_barotropic logical :: use_old_coriolis_bracket_bug !< If True, use an order of operations !! that is not bitwise rotationally symmetric in the !! meridional Coriolis term of the barotropic solver. + logical :: tidal_sal_flather !< Apply adjustment to external gravity wave speed + !! consistent with tidal self-attraction and loading + !! used within the barotropic solver + logical :: wt_uv_bug = .true. !< If true, recover a bug that wt_[uv] that is not normalized. + logical :: exterior_OBC_bug = .true. !< If true, recover a bug with boundary conditions + !! inside the domain. + logical :: interior_OBC_PV !< If true, use only interior ocean points at OBCs to specify the PV + !! used in the barotropic Coriolis anomalies. Otherwise the + !! calculation relies on bathymetry and eta being projected outward + !! across OBCs. Unfortunately, this option does change answers near + !! convex (peninsula-type) pairs of OBC segments. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean models clock. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate !! the timing of diagnostic output. type(MOM_domain_type), pointer :: BT_Domain => NULL() !< Barotropic MOM domain type(hor_index_type), pointer :: debug_BT_HI => NULL() !< debugging copy of horizontal index_type - type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< Control structure for tides + type(SAL_CS), pointer :: SAL_CSp => NULL() !< Control structure for SAL + type(harmonic_analysis_CS), pointer :: HA_CSp => NULL() !< Control structure for harmonic analysis + type(Filter_CS) :: Filt_CS_u, & !< Control structures for the streaming band-pass filter of ubt + Filt_CS_v !< Control structures for the streaming band-pass filter of vbt + type(wave_drag_CS) :: Drag_CS !< Control structures for the frequency-dependent drag logical :: module_is_initialized = .false. !< If true, module has been initialized integer :: isdw !< The lower i-memory limit for the wide halo arrays. @@ -297,16 +357,19 @@ module MOM_barotropic type(group_pass_type) :: pass_ubt_Cor !< Handle for a group halo pass type(group_pass_type) :: pass_ubta_uhbta !< Handle for a group halo pass type(group_pass_type) :: pass_e_anom !< Handle for a group halo pass + type(group_pass_type) :: pass_SpV_avg !< Handle for a group halo pass !>@{ Diagnostic IDs integer :: id_PFu_bt = -1, id_PFv_bt = -1, id_Coru_bt = -1, id_Corv_bt = -1 + integer :: id_LDu_bt = -1, id_LDv_bt = -1, id_eta_cor = -1 integer :: id_ubtforce = -1, id_vbtforce = -1, id_uaccel = -1, id_vaccel = -1 - integer :: id_visc_rem_u = -1, id_visc_rem_v = -1, id_eta_cor = -1 + integer :: id_visc_rem_u = -1, id_visc_rem_v = -1, id_bt_rem_u = -1, id_bt_rem_v = -1 integer :: id_ubt = -1, id_vbt = -1, id_eta_bt = -1, id_ubtav = -1, id_vbtav = -1 integer :: id_ubt_st = -1, id_vbt_st = -1, id_eta_st = -1 integer :: id_ubtdt = -1, id_vbtdt = -1 integer :: id_ubt_hifreq = -1, id_vbt_hifreq = -1, id_eta_hifreq = -1 integer :: id_uhbt_hifreq = -1, id_vhbt_hifreq = -1, id_eta_pred_hifreq = -1 + integer :: id_etaPF_hifreq = -1, id_etaPF_anom = -1 integer :: id_gtotn = -1, id_gtots = -1, id_gtote = -1, id_gtotw = -1 integer :: id_uhbt = -1, id_frhatu = -1, id_vhbt = -1, id_frhatv = -1 integer :: id_frhatu1 = -1, id_frhatv1 = -1 @@ -317,6 +380,7 @@ module MOM_barotropic integer :: id_BTC_vbt_NN = -1, id_BTC_vbt_SS = -1 integer :: id_BTC_FA_u_rat0 = -1, id_BTC_FA_v_rat0 = -1, id_BTC_FA_h_rat0 = -1 integer :: id_uhbt0 = -1, id_vhbt0 = -1 + integer :: id_SSH_u_OBC = -1, id_SSH_v_OBC = -1, id_ubt_OBC = -1, id_vbt_OBC = -1 !>@} end type barotropic_CS @@ -398,6 +462,10 @@ module MOM_barotropic character*(20), parameter :: BT_CONT_STRING = "FROM_BT_CONT" !>@} +!> A negligible parameter which avoids division by zero, but is too small to +!! modify physical values [nondim]. +real, parameter :: subroundoff = 1e-30 + contains !> This subroutine time steps the barotropic equations explicitly. @@ -409,7 +477,7 @@ module MOM_barotropic subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, & eta_PF_in, U_Cor, V_Cor, accel_layer_u, accel_layer_v, & eta_out, uhbtav, vhbtav, G, GV, US, CS, & - visc_rem_u, visc_rem_v, ADp, OBC, BT_cont, eta_PF_start, & + visc_rem_u, visc_rem_v, SpV_avg, ADp, OBC, BT_cont, eta_PF_start, & taux_bot, tauy_bot, uh0, vh0, u_uh0, v_vh0, etaav) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -459,6 +527,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !! viscosity is applied, in the zonal direction [nondim]. !! Visc_rem_u is between 0 (at the bottom) and 1 (far above). real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: visc_rem_v !< Ditto for meridional direction [nondim]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: SpV_avg !< The column average specific volume, used + !! in non-Boussinesq OBC calculations [R-1 ~> m3 kg-1] type(accel_diag_ptrs), pointer :: ADp !< Acceleration diagnostic pointers type(ocean_OBC_type), pointer :: OBC !< The open boundary condition structure. type(BT_cont_type), pointer :: BT_cont !< A structure with elements that describe @@ -490,15 +560,26 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real :: wt_v(SZI_(G),SZJB_(G),SZK_(GV)) ! normalized weights to ! be used in calculating barotropic velocities, possibly with ! sums less than one due to viscous losses [nondim] + real :: Iwt_u_tot(SZIB_(G),SZJ_(G)) ! Iwt_u_tot and Iwt_v_tot are the + real :: Iwt_v_tot(SZI_(G),SZJB_(G)) ! inverses of wt_u and wt_v vertical integrals, + ! used to normalize wt_u and wt_v [nondim] real, dimension(SZIB_(G),SZJ_(G)) :: & av_rem_u, & ! The weighted average of visc_rem_u [nondim] tmp_u, & ! A temporary array at u points [L T-2 ~> m s-2] or [nondim] ubt_st, & ! The zonal barotropic velocity at the start of timestep [L T-1 ~> m s-1]. + ubt_wtd, & ! A weighted sum used to find the filtered final ubt [L T-1 ~> m s-1]. + PFu_avg, & ! The average zonal barotropic pressure gradient force [L T-2 ~> m s-2]. + Coru_avg, & ! The average zonal barotropic Coriolis acceleration [L T-2 ~> m s-2]. + LDu_avg, & ! The average zonal barotropic linear wave drag acceleration [L T-2 ~> m s-2]. ubt_dt ! The zonal barotropic velocity tendency [L T-2 ~> m s-2]. real, dimension(SZI_(G),SZJB_(G)) :: & av_rem_v, & ! The weighted average of visc_rem_v [nondim] tmp_v, & ! A temporary array at v points [L T-2 ~> m s-2] or [nondim] vbt_st, & ! The meridional barotropic velocity at the start of timestep [L T-1 ~> m s-1]. + vbt_wtd, & ! A weighted sum used to find the filtered final vbt [L T-1 ~> m s-1]. + PFv_avg, & ! The average meridional barotropic pressure gradient force [L T-2 ~> m s-2]. + Corv_avg, & ! The average meridional barotropic Coriolis acceleration [L T-2 ~> m s-2]. + LDv_avg, & ! The average meridional barotropic linear wave drag acceleration [L T-2 ~> m s-2]. vbt_dt ! The meridional barotropic velocity tendency [L T-2 ~> m s-2]. real, dimension(SZI_(G),SZJ_(G)) :: & tmp_h, & ! A temporary array at h points [nondim] @@ -507,8 +588,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! relative to eta_PF, with SAL effects included [H ~> m or kg m-2]. ! These are always allocated with symmetric memory and wide halos. - real :: q(SZIBW_(CS),SZJBW_(CS)) ! A pseudo potential vorticity [T-1 Z-1 ~> s-1 m-1] - ! or [T-1 H-1 ~> s-1 m-1 or m2 s-1 kg-1] + real :: q(SZIBW_(CS),SZJBW_(CS)) ! A pseudo potential vorticity [T-1 H-1 ~> s-1 m-1 or m2 s-1 kg-1] real, dimension(SZIBW_(CS),SZJW_(CS)) :: & ubt, & ! The zonal barotropic velocity [L T-1 ~> m s-1]. bt_rem_u, & ! The fraction of the barotropic zonal velocity that remains @@ -522,26 +602,13 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, uhbt0, & ! The difference between the sum of the layer zonal thickness ! fluxes and the barotropic thickness flux using the same ! velocity [H L2 T-1 ~> m3 s-1 or kg s-1]. - ubt_old, & ! The starting value of ubt in a barotropic step [L T-1 ~> m s-1]. - ubt_first, & ! The starting value of ubt in a series of barotropic steps [L T-1 ~> m s-1]. - ubt_sum, & ! The sum of ubt over the time steps [L T-1 ~> m s-1]. - ubt_int, & ! The running time integral of ubt over the time steps [L ~> m]. - uhbt_sum, & ! The sum of uhbt over the time steps [H L2 T-1 ~> m3 s-1 or kg s-1]. - uhbt_int, & ! The running time integral of uhbt over the time steps [H L2 ~> m3]. - ubt_wtd, & ! A weighted sum used to find the filtered final ubt [L T-1 ~> m s-1]. - ubt_trans, & ! The latest value of ubt used for a transport [L T-1 ~> m s-1]. - azon, bzon, & ! _zon and _mer are the values of the Coriolis force which - czon, dzon, & ! are applied to the neighboring values of vbtav and ubtav, - amer, bmer, & ! respectively to get the barotropic inertial rotation - cmer, dmer, & ! [T-1 ~> s-1]. - Cor_u, & ! The zonal Coriolis acceleration [L T-2 ~> m s-2]. Cor_ref_u, & ! The zonal barotropic Coriolis acceleration due ! to the reference velocities [L T-2 ~> m s-2]. - PFu, & ! The zonal pressure force acceleration [L T-2 ~> m s-2]. - Rayleigh_u, & ! A Rayleigh drag timescale operating at u-points [T-1 ~> s-1]. - PFu_bt_sum, & ! The summed zonal barotropic pressure gradient force [L T-2 ~> m s-2]. - Coru_bt_sum, & ! The summed zonal barotropic Coriolis acceleration [L T-2 ~> m s-2]. - DCor_u, & ! An averaged depth or total thickness at u points [Z ~> m] or [H ~> m or kg m-2]. + Rayleigh_u, & ! A Rayleigh drag timescale operating at u-points for drag parameterizations + ! that introduced directly into the barotropic solver rather than coming in via + ! the visc_rem_u arrays from the layered equations [T-1 ~> s-1]. + ! This is nonzero mostly for a barotropic tidal body drag. + DCor_u, & ! An averaged total thickness at u points [H ~> m or kg m-2]. Datu ! Basin depth at u-velocity grid points times the y-grid ! spacing [H L ~> m2 or kg m-1]. real, dimension(SZIW_(CS),SZJBW_(CS)) :: & @@ -557,33 +624,38 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, vhbt0, & ! The difference between the sum of the layer meridional ! thickness fluxes and the barotropic thickness flux using ! the same velocities [H L2 T-1 ~> m3 s-1 or kg s-1]. - vbt_old, & ! The starting value of vbt in a barotropic step [L T-1 ~> m s-1]. - vbt_first, & ! The starting value of ubt in a series of barotropic steps [L T-1 ~> m s-1]. - vbt_sum, & ! The sum of vbt over the time steps [L T-1 ~> m s-1]. - vbt_int, & ! The running time integral of vbt over the time steps [L ~> m]. - vhbt_sum, & ! The sum of vhbt over the time steps [H L2 T-1 ~> m3 s-1 or kg s-1]. - vhbt_int, & ! The running time integral of vhbt over the time steps [H L2 ~> m3]. - vbt_wtd, & ! A weighted sum used to find the filtered final vbt [L T-1 ~> m s-1]. - vbt_trans, & ! The latest value of vbt used for a transport [L T-1 ~> m s-1]. - Cor_v, & ! The meridional Coriolis acceleration [L T-2 ~> m s-2]. Cor_ref_v, & ! The meridional barotropic Coriolis acceleration due ! to the reference velocities [L T-2 ~> m s-2]. - PFv, & ! The meridional pressure force acceleration [L T-2 ~> m s-2]. - Rayleigh_v, & ! A Rayleigh drag timescale operating at v-points [T-1 ~> s-1]. - PFv_bt_sum, & ! The summed meridional barotropic pressure gradient force, - ! [L T-2 ~> m s-2]. - Corv_bt_sum, & ! The summed meridional barotropic Coriolis acceleration, - ! [L T-2 ~> m s-2]. - DCor_v, & ! An averaged depth or total thickness at v points [Z ~> m] or [H ~> m or kg m-2]. + Rayleigh_v, & ! A Rayleigh drag timescale operating at v-points for drag parameterizations + ! that introduced directly into the barotropic solver rather than coming + ! in via the visc_rem_v arrays from the layered equations [T-1 ~> s-1]. + ! This is nonzero mostly for a barotropic tidal body drag. + DCor_v, & ! An averaged total thickness at v points [H ~> m or kg m-2]. Datv ! Basin depth at v-velocity grid points times the x-grid ! spacing [H L ~> m2 or kg m-1]. + real, dimension(4,SZIBW_(CS),SZJW_(CS)) :: & + f_4_u !< The terms giving the contribution to the Coriolis acceleration at a zonal + !! velocity point from the neighboring meridional velocity anomalies [T-1 ~> s-1]. + !! These are the products of thicknesses at v points and appropriately staggered + !! averaged pseudo potential vorticities, but with sufficiently smooth topography + !! they are approximately f / 4. The 4 values on the innermost loop are for + !! v-velocities to the southwest, southeast, northwest and northeast. + real, dimension(4,SZIW_(CS),SZJBW_(CS)) :: & + f_4_v !< The terms giving the contribution to the Coriolis acceleration at a meridional + !! velocity point from the neighboring meridional velocity anomalies [T-1 ~> s-1]. + !! These are the products of thicknesses at u points and appropriately staggered + !! averaged pseudo potential vorticities, but with sufficiently smooth topography + !! they are approximately f / 4. The 4 values on the innermost loop are for + !! u-velocities to the southwest, southeast, northwest and northeast. + real, dimension(:,:,:), pointer :: ufilt, vfilt + ! Filtered velocities from the output of streaming filters [L T-1 ~> m s-1] + real, dimension(SZIB_(G),SZJ_(G)) :: Drag_u + ! The zonal acceleration due to frequency-dependent drag [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G)) :: Drag_v + ! The meridional acceleration due to frequency-dependent drag [L T-2 ~> m s-2] real, target, dimension(SZIW_(CS),SZJW_(CS)) :: & - eta, & ! The barotropic free surface height anomaly or column mass + eta ! The barotropic free surface height anomaly or column mass ! anomaly [H ~> m or kg m-2] - eta_pred ! A predictor value of eta [H ~> m or kg m-2] like eta. - real, dimension(:,:), pointer :: & - eta_PF_BT ! A pointer to the eta array (either eta or eta_pred) that - ! determines the barotropic pressure force [H ~> m or kg m-2] real, dimension(SZIW_(CS),SZJW_(CS)) :: & eta_sum, & ! eta summed across the timesteps [H ~> m or kg m-2]. eta_wtd, & ! A weighted estimate used to calculate eta_out [H ~> m or kg m-2]. @@ -602,62 +674,40 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! from the thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. ! (See Hallberg, J Comp Phys 1997 for a discussion.) eta_src, & ! The source of eta per barotropic timestep [H ~> m or kg m-2]. - dyn_coef_eta, & ! The coefficient relating the changes in eta to the + SpV_col_avg, & ! The column average specific volume [R-1 ~> m3 kg-1] + dyn_coef_eta ! The coefficient relating the changes in eta to the ! dynamic surface pressure under rigid ice ! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. - p_surf_dyn ! A dynamic surface pressure under rigid ice [L2 T-2 ~> m2 s-2]. type(local_BT_cont_u_type), dimension(SZIBW_(CS),SZJW_(CS)) :: & BTCL_u ! A repackaged version of the u-point information in BT_cont. type(local_BT_cont_v_type), dimension(SZIW_(CS),SZJBW_(CS)) :: & BTCL_v ! A repackaged version of the v-point information in BT_cont. ! End of wide-sized variables. - real, dimension(SZIBW_(CS),SZJW_(CS)) :: & - ubt_prev, ubt_sum_prev, ubt_wtd_prev, & ! Previous velocities stored for OBCs [L T-1 ~> m s-1] - uhbt_prev, uhbt_sum_prev, & ! Previous transports stored for OBCs [L2 H T-1 ~> m3 s-1] - ubt_int_prev, & ! Previous value of time-integrated velocity stored for OBCs [L ~> m] - uhbt_int_prev ! Previous value of time-integrated transport stored for OBCs [L2 H ~> m3] - real, dimension(SZIW_(CS),SZJBW_(CS)) :: & - vbt_prev, vbt_sum_prev, vbt_wtd_prev, & ! Previous velocities stored for OBCs [L T-1 ~> m s-1] - vhbt_prev, vhbt_sum_prev, & ! Previous transports stored for OBCs [L2 H T-1 ~> m3 s-1] - vbt_int_prev, & ! Previous value of time-integrated velocity stored for OBCs [L ~> m] - vhbt_int_prev ! Previous value of time-integrated transport stored for OBCs [L2 H ~> m3] - real :: mass_to_Z ! The inverse of the the mean density (Rho0) [R-1 ~> m3 kg-1] real :: visc_rem ! A work variable that may equal visc_rem_[uv] [nondim] - real :: vel_prev ! The previous velocity [L T-1 ~> m s-1]. real :: dtbt ! The barotropic time step [T ~> s]. - real :: bebt ! A copy of CS%bebt [nondim]. - real :: be_proj ! The fractional amount by which velocities are projected - ! when project_velocity is true [nondim]. For now be_proj is set - ! to equal bebt, as they have similar roles and meanings. real :: Idt ! The inverse of dt [T-1 ~> s-1]. real :: det_de ! The partial derivative due to self-attraction and loading ! of the reference geopotential with the sea surface height [nondim]. ! This is typically ~0.09 or less. - real :: dgeo_de ! The constant of proportionality between geopotential and - ! sea surface height [nondim]. It is of order 1, but for - ! stability this may be made larger than the physical - ! problem would suggest. + real :: dgeo_de ! The constant of proportionality between geopotential and sea surface height + ! [nondim]. It is of order 1, but for stability this may be made larger than + ! the physical problem would suggest. + real :: dgeo_de_OBC ! The value of dgeo_de to be used with Flather open boundary conditions [nondim]. real :: Instep ! The inverse of the number of barotropic time steps to take [nondim]. - real :: wt_end ! The weighting of the final value of eta_PF [nondim] integer :: nstep ! The number of barotropic time steps to take. - type(time_type) :: & - time_bt_start, & ! The starting time of the barotropic steps. - time_step_end, & ! The end time of a barotropic step. - time_end_in ! The end time for diagnostics when this routine started. - real :: time_int_in ! The diagnostics' time interval when this routine started. real :: Htot_avg ! The average total thickness of the tracer columns adjacent to a ! velocity point [H ~> m or kg m-2] - logical :: do_hifreq_output ! If true, output occurs every barotropic step. - logical :: use_BT_cont, do_ave, find_etaav, find_PF, find_Cor + logical :: use_BT_cont, find_etaav logical :: integral_BT_cont ! If true, update the barotropic continuity equation directly ! from the initial condition using the time-integrated barotropic velocity. logical :: ice_is_rigid, nonblock_setup, interp_eta_PF - logical :: project_velocity, add_uh0 + logical :: add_uh0 real :: dyn_coef_max ! The maximum stable value of dyn_coef_eta ! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. real :: ice_strength = 0.0 ! The effective strength of the ice [L2 Z-1 T-2 ~> m s-2]. + real :: H_to_Z ! A local unit conversion factor used with rigid ice [Z H-1 ~> nondim or m3 kg-1] real :: Idt_max2 ! The squared inverse of the local maximum stable ! barotropic time step [T-2 ~> s-2]. real :: H_min_dyn ! The minimum depth to use in limiting the size of the @@ -669,43 +719,37 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real :: Htot ! The total thickness [H ~> m or kg m-2]. real :: eta_cor_max ! The maximum fluid that can be added as a correction to eta [H ~> m or kg m-2]. real :: accel_underflow ! An acceleration that is so small it should be zeroed out [L T-2 ~> m s-2]. - real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected [H ~> m or kg m-2]. - real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1] + real :: h_a_neglect ! A cell volume or mass that is so small it is usually lost + ! in roundoff and can be neglected [H L2 ~> m3 or kg]. real, allocatable :: wt_vel(:) ! The raw or relative weights of each of the barotropic timesteps ! in determining the average velocities [nondim] real, allocatable :: wt_eta(:) ! The raw or relative weights of each of the barotropic timesteps - ! in determining the average the average of eta [nondim] + ! in determining the average eta [nondim] real, allocatable :: wt_accel(:) ! The raw or relative weights of each of the barotropic timesteps ! in determining the average accelerations [nondim] real, allocatable :: wt_trans(:) ! The raw or relative weights of each of the barotropic timesteps ! in determining the average transports [nondim] real, allocatable :: wt_accel2(:) ! A potentially un-normalized copy of wt_accel [nondim] real :: sum_wt_vel ! The sum of the raw weights used to find average velocities [nondim] - real :: sum_wt_eta ! The sum of the raw weights used to find average the average of eta [nondim] + real :: sum_wt_eta ! The sum of the raw weights used to find average eta [nondim] real :: sum_wt_accel ! The sum of the raw weights used to find average accelerations [nondim] real :: sum_wt_trans ! The sum of the raw weights used to find average transports [nondim] real :: I_sum_wt_vel ! The inverse of the sum of the raw weights used to find average velocities [nondim] - real :: I_sum_wt_eta ! The inverse of the sum of the raw weights used to find the average of eta [nondim] + real :: I_sum_wt_eta ! The inverse of the sum of the raw weights used to find eta [nondim] real :: I_sum_wt_accel ! The inverse of the sum of the raw weights used to find average accelerations [nondim] real :: I_sum_wt_trans ! The inverse of the sum of the raw weights used to find average transports [nondim] real :: dt_filt ! The half-width of the barotropic filter [T ~> s]. - real :: trans_wt1, trans_wt2 ! The weights used to compute ubt_trans and vbt_trans integer :: nfilter - logical :: apply_OBCs, apply_OBC_flather, apply_OBC_open + logical :: apply_OBCs, apply_OBC_flather type(memory_size_type) :: MS character(len=200) :: mesg - integer :: isv, iev, jsv, jev ! The valid array size at the end of a step. integer :: stencil ! The stencil size of the algorithm, often 1 or 2. integer :: isvf, ievf, jsvf, jevf, num_cycles - integer :: err_count ! A counter to limit the volume of error messages written to stdout. integer :: i, j, k, n integer :: is, ie, js, je, nz, Isq, Ieq, Jsq, Jeq integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - integer :: ioff, joff - integer :: l_seg if (.not.CS%module_is_initialized) call MOM_error(FATAL, & "btstep: Module MOM_barotropic must be initialized before it is used.") @@ -716,8 +760,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB MS%isdw = CS%isdw ; MS%iedw = CS%iedw ; MS%jsdw = CS%jsdw ; MS%jedw = CS%jedw - h_neglect = GV%H_subroundoff - err_count = 0 + h_a_neglect = GV%H_subroundoff * (1.0 * US%m_to_L**2) Idt = 1.0 / dt accel_underflow = CS%vel_underflow * Idt @@ -727,17 +770,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, interp_eta_PF = associated(eta_PF_start) - project_velocity = CS%BT_project_velocity - ! Figure out the fullest arrays that could be updated. - stencil = 1 + stencil = max(1, CS%min_stencil) if ((.not.use_BT_cont) .and. CS%Nonlinear_continuity .and. & - (CS%Nonlin_cont_update_period > 0)) stencil = 2 + (CS%Nonlin_cont_update_period > 0)) stencil = max(2, CS%min_stencil) - do_ave = query_averaging_enabled(CS%diag) find_etaav = present(etaav) - find_PF = (do_ave .and. ((CS%id_PFu_bt > 0) .or. (CS%id_PFv_bt > 0))) - find_Cor = (do_ave .and. ((CS%id_Coru_bt > 0) .or. (CS%id_Corv_bt > 0))) add_uh0 = associated(uh0) if (add_uh0 .and. .not.(associated(vh0) .and. associated(u_uh0) .and. & @@ -749,20 +787,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (id_clock_calc_pre > 0) call cpu_clock_begin(id_clock_calc_pre) - apply_OBCs = .false. ; CS%BT_OBC%apply_u_OBCs = .false. ; CS%BT_OBC%apply_v_OBCs = .false. - apply_OBC_open = .false. apply_OBC_flather = .false. + apply_OBCs = .false. if (associated(OBC)) then - CS%BT_OBC%apply_u_OBCs = OBC%open_u_BCs_exist_globally .or. OBC%specified_u_BCs_exist_globally - CS%BT_OBC%apply_v_OBCs = OBC%open_v_BCs_exist_globally .or. OBC%specified_v_BCs_exist_globally apply_OBC_flather = open_boundary_query(OBC, apply_Flather_OBC=.true.) - apply_OBC_open = open_boundary_query(OBC, apply_open_OBC=.true.) apply_OBCs = open_boundary_query(OBC, apply_specified_OBC=.true.) .or. & - apply_OBC_flather .or. apply_OBC_open - - if (apply_OBC_flather .and. .not.GV%Boussinesq) call MOM_error(FATAL, & - "btstep: Flather open boundary conditions have not yet been "// & - "implemented for a non-Boussinesq model.") + apply_OBC_flather .or. open_boundary_query(OBC, apply_open_OBC=.true.) endif num_cycles = 1 @@ -772,7 +802,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, jsvf = js - (num_cycles-1)*stencil ; jevf = je + (num_cycles-1)*stencil nstep = CEILING(dt/CS%dtbt - 0.0001) - if (is_root_PE() .and. (nstep /= CS%nstep_last)) then + if (is_root_PE() .and. ((nstep /= CS%nstep_last) .or. CS%debug)) then write(mesg,'("btstep is using a dynamic barotropic timestep of ", ES12.6, & & " seconds, max ", ES12.6, ".")') (US%T_to_s*dt/nstep), US%T_to_s*CS%dtbt_max call MOM_mesg(mesg, 3) @@ -782,28 +812,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Set the actual barotropic time step. Instep = 1.0 / real(nstep) dtbt = dt * Instep - Idtbt = 1.0 / dtbt - bebt = CS%bebt - be_proj = CS%bebt - mass_to_Z = 1.0 / GV%Rho0 - - !--- setup the weight when computing vbt_trans and ubt_trans - if (project_velocity) then - trans_wt1 = (1.0 + be_proj); trans_wt2 = -be_proj - else - trans_wt1 = bebt ; trans_wt2 = (1.0-bebt) - endif - - do_hifreq_output = .false. - if ((CS%id_ubt_hifreq > 0) .or. (CS%id_vbt_hifreq > 0) .or. & - (CS%id_eta_hifreq > 0) .or. (CS%id_eta_pred_hifreq > 0) .or. & - (CS%id_uhbt_hifreq > 0) .or. (CS%id_vhbt_hifreq > 0)) then - do_hifreq_output = query_averaging_enabled(CS%diag, time_int_in, time_end_in) - if (do_hifreq_output) & - time_bt_start = time_end_in - real_to_time(US%T_to_s*dt) - endif -!--- begin setup for group halo update + !--- begin setup for group halo update if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre) if (.not. CS%linearized_BT_PV) then call create_group_pass(CS%pass_q_DCor, q, CS%BT_Domain, To_All, position=CORNER) @@ -828,15 +838,13 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (integral_BT_cont) & call create_group_pass(CS%pass_eta_bt_rem, eta_IC, CS%BT_Domain) call create_group_pass(CS%pass_eta_bt_rem, eta_src, CS%BT_Domain) - ! The following halo updates are not needed without wide halos. RWH - ! We do need them after all. -! if (ievf > ie) then - call create_group_pass(CS%pass_eta_bt_rem, bt_rem_u, bt_rem_v, & - CS%BT_Domain, To_All+Scalar_Pair) - if (CS%linear_wave_drag) & - call create_group_pass(CS%pass_eta_bt_rem, Rayleigh_u, Rayleigh_v, & - CS%BT_Domain, To_All+Scalar_Pair) -! endif + + call create_group_pass(CS%pass_eta_bt_rem, bt_rem_u, bt_rem_v, & + CS%BT_Domain, To_All+Scalar_Pair) + if (CS%linear_wave_drag) & + call create_group_pass(CS%pass_eta_bt_rem, Rayleigh_u, Rayleigh_v, & + CS%BT_Domain, To_All+Scalar_Pair) + ! The following halo update is not needed without wide halos. RWH if (((G%isd > CS%isdw) .or. (G%jsd > CS%jsdw)) .or. (Isq <= is-1) .or. (Jsq <= js-1)) & call create_group_pass(CS%pass_force_hbt0_Cor_ref, BT_force_u, BT_force_v, CS%BT_Domain) @@ -845,14 +853,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (.not. use_BT_cont) then call create_group_pass(CS%pass_Dat_uv, Datu, Datv, CS%BT_Domain, To_All+Scalar_Pair) endif - call create_group_pass(CS%pass_eta_ubt, eta, CS%BT_Domain) - call create_group_pass(CS%pass_eta_ubt, ubt, vbt, CS%BT_Domain) - if (integral_BT_cont) then - call create_group_pass(CS%pass_eta_ubt, ubt_int, vbt_int, CS%BT_Domain) - ! This is only needed with integral_BT_cont, OBCs and multiple barotropic steps between halo updates. - if (apply_OBC_open) & - call create_group_pass(CS%pass_eta_ubt, uhbt_int, vhbt_int, CS%BT_Domain) - endif + if (apply_OBC_flather .and. .not.GV%Boussinesq) & + call create_group_pass(CS%pass_SpV_avg, SpV_col_avg, CS%BT_domain) call create_group_pass(CS%pass_ubt_Cor, ubt_Cor, vbt_Cor, G%Domain) ! These passes occur at the end of the routine, as data is being readied to @@ -891,35 +893,98 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, DCor_u(I,j) = 0.5 * (max(GV%Z_to_H*G%bathyT(i+1,j) + eta_in(i+1,j), 0.0) + & max(GV%Z_to_H*G%bathyT(i,j) + eta_in(i,j), 0.0) ) enddo ; enddo + if (CS%interior_OBC_PV .and. CS%BT_OBC%u_OBCs_on_PE) then + !$OMP parallel do default(shared) + do j = max(js,CS%BT_OBC%js_u_W_obc), min(je,CS%BT_OBC%je_u_W_obc) + do I = max(is-1,CS%BT_OBC%Is_u_W_obc), min(ie,CS%BT_OBC%Ie_u_W_obc) + if (CS%BT_OBC%u_OBC_type(I,j) < 0) & ! Western boundary condition + DCor_u(I,j) = max(GV%Z_to_H*G%bathyT(i+1,j) + eta_in(i+1,j), 0.0) + enddo + enddo + !$OMP parallel do default(shared) + do j = max(js,CS%BT_OBC%js_u_E_obc), min(je,CS%BT_OBC%je_u_E_obc) + do I = max(is-1,CS%BT_OBC%Is_u_E_obc), min(ie,CS%BT_OBC%Ie_u_E_obc) + if (CS%BT_OBC%u_OBC_type(I,j) > 0) & ! Eastern boundary condition + DCor_u(I,j) = max(GV%Z_to_H*G%bathyT(i,j) + eta_in(i,j), 0.0) + enddo + enddo + endif + !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie DCor_v(i,J) = 0.5 * (max(GV%Z_to_H*G%bathyT(i,j+1) + eta_in(i+1,j), 0.0) + & max(GV%Z_to_H*G%bathyT(i,j) + eta_in(i,j), 0.0) ) enddo ; enddo + if (CS%interior_OBC_PV .and. CS%BT_OBC%v_OBCs_on_PE) then + !$OMP parallel do default(shared) + do j = max(js,CS%BT_OBC%js_v_S_obc), min(je,CS%BT_OBC%je_v_S_obc) + do I = max(is-1,CS%BT_OBC%Is_v_S_obc), min(ie,CS%BT_OBC%Ie_v_S_obc) + if (CS%BT_OBC%v_OBC_type(i,J) < 0) & ! Southern boundary condition + DCor_v(i,J) = max(GV%Z_to_H*G%bathyT(i,j+1) + eta_in(i,j+1), 0.0) + enddo + enddo + !$OMP parallel do default(shared) + do j = max(js,CS%BT_OBC%js_v_N_obc), min(je,CS%BT_OBC%je_v_N_obc) + do I = max(is-1,CS%BT_OBC%Is_v_N_obc), min(ie,CS%BT_OBC%Ie_v_N_obc) + if (CS%BT_OBC%v_OBC_type(i,J) > 0) & ! Northern boundary condition + DCor_v(i,J) = max(GV%Z_to_H*G%bathyT(i,j) + eta_in(i,j), 0.0) + enddo + enddo + endif !$OMP parallel do default(shared) do J=js-1,je ; do I=is-1,ie q(I,J) = 0.25 * (CS%BT_Coriolis_scale * G%CoriolisBu(I,J)) * & - ((G%areaT(i,j) + G%areaT(i+1,j+1)) + (G%areaT(i+1,j) + G%areaT(i,j+1))) / & - (max((G%areaT(i,j) * max(GV%Z_to_H*G%bathyT(i,j) + eta_in(i,j), 0.0) + & - G%areaT(i+1,j+1) * max(GV%Z_to_H*G%bathyT(i+1,j+1) + eta_in(i+1,j+1), 0.0)) + & - (G%areaT(i+1,j) * max(GV%Z_to_H*G%bathyT(i+1,j) + eta_in(i+1,j), 0.0) + & - G%areaT(i,j+1) * max(GV%Z_to_H*G%bathyT(i,j+1) + eta_in(i,j+1), 0.0)), h_neglect) ) + ((CS%q_wt(1,I,J) + CS%q_wt(4,I,J)) + (CS%q_wt(2,I,J) + CS%q_wt(3,I,J))) / & + (max(((CS%q_wt(1,I,J) * max(GV%Z_to_H*G%bathyT(i,j) + eta_in(i,j), 0.0)) + & + (CS%q_wt(4,I,J) * max(GV%Z_to_H*G%bathyT(i+1,j+1) + eta_in(i+1,j+1), 0.0))) + & + ((CS%q_wt(2,I,J) * max(GV%Z_to_H*G%bathyT(i+1,j) + eta_in(i+1,j), 0.0)) + & + (CS%q_wt(3,I,J) * max(GV%Z_to_H*G%bathyT(i,j+1) + eta_in(i,j+1), 0.0))), h_a_neglect) ) enddo ; enddo - else + else ! Non-Boussinesq !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie DCor_u(I,j) = 0.5 * (eta_in(i+1,j) + eta_in(i,j)) enddo ; enddo + if (CS%interior_OBC_PV .and. CS%BT_OBC%u_OBCs_on_PE) then + !$OMP parallel do default(shared) + do j = max(js,CS%BT_OBC%js_u_W_obc), min(je,CS%BT_OBC%je_u_W_obc) + do I = max(is-1,CS%BT_OBC%Is_u_W_obc), min(ie,CS%BT_OBC%Ie_u_W_obc) + if (CS%BT_OBC%u_OBC_type(I,j) < 0) DCor_u(I,j) = eta_in(i+1,j) ! Western boundary condition + enddo + enddo + !$OMP parallel do default(shared) + do j = max(js,CS%BT_OBC%js_u_E_obc), min(je,CS%BT_OBC%je_u_E_obc) + do I = max(is-1,CS%BT_OBC%Is_u_E_obc), min(ie,CS%BT_OBC%Ie_u_E_obc) + if (CS%BT_OBC%u_OBC_type(I,j) > 0) DCor_u(I,j) = eta_in(i,j) ! Eastern boundary condition + enddo + enddo + endif + !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie DCor_v(i,J) = 0.5 * (eta_in(i,j+1) + eta_in(i,j)) enddo ; enddo + if (CS%interior_OBC_PV .and. CS%BT_OBC%v_OBCs_on_PE) then + !$OMP parallel do default(shared) + do j = max(js,CS%BT_OBC%js_v_S_obc), min(je,CS%BT_OBC%je_v_S_obc) + do I = max(is-1,CS%BT_OBC%Is_v_S_obc), min(ie,CS%BT_OBC%Ie_v_S_obc) + if (CS%BT_OBC%v_OBC_type(i,J) < 0) DCor_v(i,J) = eta_in(i,j+1) ! Southern boundary condition + enddo + enddo + !$OMP parallel do default(shared) + do j = max(js,CS%BT_OBC%js_v_N_obc), min(je,CS%BT_OBC%je_v_N_obc) + do I = max(is-1,CS%BT_OBC%Is_v_N_obc), min(ie,CS%BT_OBC%Ie_v_N_obc) + if (CS%BT_OBC%v_OBC_type(i,J) > 0) DCor_v(i,J) = eta_in(i,j) ! Northern boundary condition + enddo + enddo + endif + !$OMP parallel do default(shared) do J=js-1,je ; do I=is-1,ie q(I,J) = 0.25 * (CS%BT_Coriolis_scale * G%CoriolisBu(I,J)) * & - ((G%areaT(i,j) + G%areaT(i+1,j+1)) + (G%areaT(i+1,j) + G%areaT(i,j+1))) / & - (max((G%areaT(i,j) * eta_in(i,j) + G%areaT(i+1,j+1) * eta_in(i+1,j+1)) + & - (G%areaT(i+1,j) * eta_in(i+1,j) + G%areaT(i,j+1) * eta_in(i,j+1)), h_neglect) ) + ((CS%q_wt(1,I,J) + CS%q_wt(4,I,J)) + (CS%q_wt(2,I,J) + CS%q_wt(3,I,J))) / & + (max(((CS%q_wt(1,I,J) * eta_in(i,j)) + (CS%q_wt(4,I,J) * eta_in(i+1,j+1))) + & + ((CS%q_wt(2,I,J) * eta_in(i+1,j)) + (CS%q_wt(3,I,J) * eta_in(i,j+1))), h_a_neglect) ) enddo ; enddo endif @@ -949,7 +1014,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (integral_BT_cont) then eta_IC(i,j) = 0.0 endif - p_surf_dyn(i,j) = 0.0 if (CS%dynamic_psurf) dyn_coef_eta(i,j) = 0.0 enddo ; enddo ! The halo regions of various arrays need to be initialized to @@ -966,6 +1030,22 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, Datv(i,J) = 0.0 ; bt_rem_v(i,J) = 0.0 ; vhbt0(i,J) = 0.0 enddo ; enddo + if (apply_OBCs) then + SpV_col_avg(:,:) = 0.0 + if (apply_OBC_flather .and. .not.GV%Boussinesq) then + ! Copy the column average specific volumes into a wide halo array + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + SpV_col_avg(i,j) = Spv_avg(i,j) + enddo ; enddo + if (nonblock_setup) then + call start_group_pass(CS%pass_SpV_avg, CS%BT_domain) + else + call do_group_pass(CS%pass_SpV_avg, CS%BT_domain) + endif + endif + endif + if (CS%linear_wave_drag) then !$OMP parallel do default(shared) do j=CS%jsdw,CS%jedw ; do I=CS%isdw-1,CS%iedw @@ -1001,26 +1081,50 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !$OMP parallel do default(shared) private(visc_rem) do k=1,nz ; do j=js,je ; do I=is-1,ie - ! rem needs greater than visc_rem_u and 1-Instep/visc_rem_u. + ! rem needs to be greater than visc_rem_u and 1-Instep/visc_rem_u. ! The 0.5 below is just for safety. - if (visc_rem_u(I,j,k) <= 0.0) then ; visc_rem = 0.0 - elseif (visc_rem_u(I,j,k) >= 1.0) then ; visc_rem = 1.0 - elseif (visc_rem_u(I,j,k)**2 > visc_rem_u(I,j,k) - 0.5*Instep) then - visc_rem = visc_rem_u(I,j,k) - else ; visc_rem = 1.0 - 0.5*Instep/visc_rem_u(I,j,k) ; endif + ! NOTE: subroundoff is a negligible value used to prevent division by zero. + ! When 1-0.5*Instep/visc_rem exceeds visc_rem, the subroundoff is too small + ! to modify the significand. When visc_rem is small, the max() operators + ! select visc_rem or 0. So subroundoff cannot impact the final value. + visc_rem = min(visc_rem_u(I,j,k), 1.) + visc_rem = max(visc_rem, 1. - 0.5 * Instep / (visc_rem + subroundoff)) + visc_rem = max(visc_rem, 0.) wt_u(I,j,k) = CS%frhatu(I,j,k) * visc_rem enddo ; enddo ; enddo !$OMP parallel do default(shared) private(visc_rem) do k=1,nz ; do J=js-1,je ; do i=is,ie - ! rem needs greater than visc_rem_v and 1-Instep/visc_rem_v. - if (visc_rem_v(i,J,k) <= 0.0) then ; visc_rem = 0.0 - elseif (visc_rem_v(i,J,k) >= 1.0) then ; visc_rem = 1.0 - elseif (visc_rem_v(i,J,k)**2 > visc_rem_v(i,J,k) - 0.5*Instep) then - visc_rem = visc_rem_v(i,J,k) - else ; visc_rem = 1.0 - 0.5*Instep/visc_rem_v(i,J,k) ; endif + ! As above, rem must be greater than visc_rem_v and 1-Instep/visc_rem_v. + visc_rem = min(visc_rem_v(I,j,k), 1.) + visc_rem = max(visc_rem, 1. - 0.5 * Instep / (visc_rem + subroundoff)) + visc_rem = max(visc_rem, 0.) wt_v(i,J,k) = CS%frhatv(i,J,k) * visc_rem enddo ; enddo ; enddo + if (.not. CS%wt_uv_bug) then + do j=js,je ; do I=is-1,ie ; Iwt_u_tot(I,j) = wt_u(I,j,1) ; enddo ; enddo + do k=2,nz ; do j=js,je ; do I=is-1,ie + Iwt_u_tot(I,j) = Iwt_u_tot(I,j) + wt_u(I,j,k) + enddo ; enddo ; enddo + do j=js,je ; do I=is-1,ie + if (abs(Iwt_u_tot(I,j)) > 0.0 ) Iwt_u_tot(I,j) = G%mask2dCu(I,j) / Iwt_u_tot(I,j) + enddo ; enddo + do k=1,nz ; do j=js,je ; do I=is-1,ie + wt_u(I,j,k) = wt_u(I,j,k) * Iwt_u_tot(I,j) + enddo ; enddo ; enddo + + do J=js-1,je ; do i=is,ie ; Iwt_v_tot(i,J) = wt_v(i,J,1) ; enddo ; enddo + do k=2,nz ; do J=js-1,je ; do i=is,ie + Iwt_v_tot(i,J) = Iwt_v_tot(i,J) + wt_v(i,J,k) + enddo ; enddo ; enddo + do J=js-1,je ; do i=is,ie + if (abs(Iwt_v_tot(i,J)) > 0.0 ) Iwt_v_tot(i,J) = G%mask2dCv(i,J) / Iwt_v_tot(i,J) + enddo ; enddo + do k=1,nz ; do J=js-1,je ; do i=is,ie + wt_v(i,J,k) = wt_v(i,J,k) * Iwt_v_tot(i,J) + enddo ; enddo ; enddo + endif + ! Use u_Cor and v_Cor as the reference values for the Coriolis terms, ! including the viscous remnant. !$OMP parallel do default(shared) @@ -1055,8 +1159,25 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, enddo ; enddo enddo - if (CS%tides) then - call tidal_forcing_sensitivity(G, CS%tides_CSp, det_de) + if (CS%BT_OBC%u_OBCs_on_PE) then + do j=js,je ; do I=is-1,ie + if (CS%BT_OBC%u_OBC_type(I,j) > 0) & ! Eastern boundary condition + gtot_W(i+1,j) = gtot_W(i,j) ! Perhaps this should be gtot_E(i,j)? + if (CS%BT_OBC%u_OBC_type(I,j) < 0) & ! Western boundary condition + gtot_E(i,j) = gtot_E(i+1,j) ! Perhaps this should be gtot_W(i+1,j)? + enddo ; enddo + endif + if (CS%BT_OBC%v_OBCs_on_PE) then + do J=js-1,je ; do i=is,ie + if (CS%BT_OBC%v_OBC_type(i,J) > 0) & ! Northern boundary condition + gtot_S(i,j+1) = gtot_S(i,j) !### Should this be gtot_N(i,j) to use wt_v at the same point? + if (CS%BT_OBC%v_OBC_type(i,J) < 0) & ! Southern boundary condition + gtot_N(i,j) = gtot_N(i,j+1) ! Perhaps this should be gtot_S(i,j+1)? + enddo ; enddo + endif + + if (CS%calculate_SAL) then + call scalar_SAL_sensitivity(CS%SAL_CSp, det_de) if (CS%tidal_sal_bug) then dgeo_de = 1.0 + det_de + CS%G_extra else @@ -1086,10 +1207,15 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif endif - ! Set up fields related to the open boundary conditions. + ! Set up fields related to the open boundary conditions. These calls include halo updates that + ! must occur on all PEs when there are open boundary conditions anywhere. if (apply_OBCs) then - call set_up_BT_OBC(OBC, eta, CS%BT_OBC, CS%BT_Domain, G, GV, US, MS, ievf-ie, use_BT_cont, & - integral_BT_cont, dt, Datu, Datv, BTCL_u, BTCL_v) + if (nonblock_setup .and. apply_OBC_flather .and. .not.GV%Boussinesq) & + call complete_group_pass(CS%pass_SpV_avg, CS%BT_domain) + + dgeo_de_OBC = 1.0 ; if (CS%tidal_SAL_Flather) dgeo_de_OBC = dgeo_de + call set_up_BT_OBC(OBC, eta, SpV_col_avg, CS%BT_OBC, CS%BT_Domain, G, GV, US, CS, MS, ievf-ie, & + use_BT_cont, integral_BT_cont, dt, Datu, Datv, BTCL_u, BTCL_v, dgeo_de_OBC) endif ! Determine the difference between the sum of the layer fluxes and the @@ -1170,61 +1296,31 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, vhbt0(i,J) = vhbt(i,J) - Datv(i,J)*vbt(i,J) enddo ; enddo endif - if (CS%BT_OBC%apply_u_OBCs) then ! zero out pressure force across boundary + if (CS%BT_OBC%u_OBCs_on_PE) then ! Zero out the reference transport at OBC points !$OMP parallel do default(shared) - do j=js,je ; do I=is-1,ie ; if (OBC%segnum_u(I,j) /= OBC_NONE) then + do j=js,je ; do I=is-1,ie ; if (CS%BT_OBC%u_OBC_type(I,j) /= 0) then uhbt0(I,j) = 0.0 endif ; enddo ; enddo endif - if (CS%BT_OBC%apply_v_OBCs) then ! zero out PF across boundary + if (CS%BT_OBC%v_OBCs_on_PE) then !Zero out the reference transport at OBC points !$OMP parallel do default(shared) - do J=js-1,je ; do i=is,ie ; if (OBC%segnum_v(i,J) /= OBC_NONE) then + do J=js-1,je ; do i=is,ie ; if (CS%BT_OBC%v_OBC_type(i,J) /= 0) then vhbt0(i,J) = 0.0 endif ; enddo ; enddo endif endif ! Calculate the initial barotropic velocities from the layer's velocities. - if (integral_BT_cont) then - !$OMP parallel do default(shared) - do j=jsvf-1,jevf+1 ; do I=isvf-2,ievf+1 - ubt(I,j) = 0.0 ; uhbt(I,j) = 0.0 ; u_accel_bt(I,j) = 0.0 - ubt_int(I,j) = 0.0 ; uhbt_int(I,j) = 0.0 - enddo ; enddo - !$OMP parallel do default(shared) - do J=jsvf-2,jevf+1 ; do i=isvf-1,ievf+1 - vbt(i,J) = 0.0 ; vhbt(i,J) = 0.0 ; v_accel_bt(i,J) = 0.0 - vbt_int(i,J) = 0.0 ; vhbt_int(i,J) = 0.0 - enddo ; enddo - else - !$OMP parallel do default(shared) - do j=jsvf-1,jevf+1 ; do I=isvf-2,ievf+1 - ubt(I,j) = 0.0 ; uhbt(I,j) = 0.0 ; u_accel_bt(I,j) = 0.0 - enddo ; enddo - !$OMP parallel do default(shared) - do J=jsvf-2,jevf+1 ; do i=isvf-1,ievf+1 - vbt(i,J) = 0.0 ; vhbt(i,J) = 0.0 ; v_accel_bt(i,J) = 0.0 - enddo ; enddo - endif - !$OMP parallel do default(shared) - do j=js,je ; do k=1,nz ; do I=is-1,ie - ubt(I,j) = ubt(I,j) + wt_u(I,j,k) * U_in(I,j,k) - enddo ; enddo ; enddo - !$OMP parallel do default(shared) - do J=js-1,je ; do k=1,nz ; do i=is,ie - vbt(i,J) = vbt(i,J) + wt_v(i,J,k) * V_in(i,J,k) - enddo ; enddo ; enddo - !$OMP parallel do default(shared) - do j=js,je ; do I=is-1,ie - if (abs(ubt(I,j)) < CS%vel_underflow) ubt(I,j) = 0.0 - enddo ; enddo - !$OMP parallel do default(shared) - do J=js-1,je ; do i=is,ie - if (abs(vbt(i,J)) < CS%vel_underflow) vbt(i,J) = 0.0 - enddo ; enddo + call btstep_ubt_from_layer(U_in, V_in, wt_u, wt_v, ubt, vbt, G, GV, CS) - if (apply_OBCs) then - ubt_first(:,:) = ubt(:,:) ; vbt_first(:,:) = vbt(:,:) + uhbt(:,:) = 0.0 ; vhbt(:,:) = 0.0 + u_accel_bt(:,:) = 0.0 ; v_accel_bt(:,:) = 0.0 + + if (apply_OBCs .or. (CS%id_ubtdt > 0)) then + do j=js,je ; do I=is-1,ie ; ubt_st(I,j) = ubt(I,j) ; enddo ; enddo + endif + if (apply_OBCs .or. (CS%id_vbtdt > 0)) then + do J=js-1,je ; do i=is,ie ; vbt_st(i,J) = vbt(i,J) ; enddo ; enddo endif ! Here the vertical average accelerations due to the Coriolis, advective, @@ -1234,7 +1330,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! barotropic calculation. !$OMP parallel do default(shared) - do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.0) then + do j=js,je ; do I=is-1,ie ; if (G%OBCmaskCu(I,j) > 0.0) then if (CS%nonlin_stress) then if (GV%Boussinesq) then Htot_avg = 0.5*(max(CS%bathyT(i,j)*GV%Z_to_H + eta(i,j), 0.0) + & @@ -1255,12 +1351,12 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif endif - BT_force_u(I,j) = forces%taux(I,j) * mass_to_Z * CS%IDatu(I,j)*visc_rem_u(I,j,1) + BT_force_u(I,j) = forces%taux(I,j) * GV%RZ_to_H * CS%IDatu(I,j)*visc_rem_u(I,j,1) else BT_force_u(I,j) = 0.0 endif ; enddo ; enddo !$OMP parallel do default(shared) - do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then + do J=js-1,je ; do i=is,ie ; if (G%OBCmaskCv(i,J) > 0.0) then if (CS%nonlin_stress) then if (GV%Boussinesq) then Htot_avg = 0.5*(max(CS%bathyT(i,j)*GV%Z_to_H + eta(i,j), 0.0) + & @@ -1281,18 +1377,18 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif endif - BT_force_v(i,J) = forces%tauy(i,J) * mass_to_Z * CS%IDatv(i,J)*visc_rem_v(i,J,1) + BT_force_v(i,J) = forces%tauy(i,J) * GV%RZ_to_H * CS%IDatv(i,J)*visc_rem_v(i,J,1) else BT_force_v(i,J) = 0.0 endif ; enddo ; enddo if (associated(taux_bot) .and. associated(tauy_bot)) then !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.0) then - BT_force_u(I,j) = BT_force_u(I,j) - taux_bot(I,j) * mass_to_Z * CS%IDatu(I,j) + BT_force_u(I,j) = BT_force_u(I,j) - taux_bot(I,j) * GV%RZ_to_H * CS%IDatu(I,j) endif ; enddo ; enddo !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then - BT_force_v(i,J) = BT_force_v(i,J) - tauy_bot(i,J) * mass_to_Z * CS%IDatv(i,J) + BT_force_v(i,J) = BT_force_v(i,J) - tauy_bot(i,J) * GV%RZ_to_H * CS%IDatv(i,J) endif ; enddo ; enddo endif @@ -1322,6 +1418,56 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, enddo ; enddo endif + ! Compute instantaneous tidal velocities and apply frequency-dependent drag. + ! Note that the filtered velocities are only updated during the current predictor step, + ! and are calculated using the barotropic velocity from the previous correction step. + if (CS%use_filter) then + call Filt_accum(ubt(G%IsdB:G%IedB,G%jsd:G%jed), ufilt, CS%Time, US, CS%Filt_CS_u) + call Filt_accum(vbt(G%isd:G%ied,G%JsdB:G%JedB), vfilt, CS%Time, US, CS%Filt_CS_v) + endif + + if (CS%use_filter .and. CS%linear_freq_drag) then + call wave_drag_calc(ufilt, vfilt, Drag_u, Drag_v, G, CS%Drag_CS) + !$OMP do + do j=js,je ; do I=is-1,ie + Htot = 0.5 * (eta(i,j) + eta(i+1,j)) + if (GV%Boussinesq) & + Htot = Htot + 0.5*GV%Z_to_H * (CS%bathyT(i,j) + CS%bathyT(i+1,j)) + if (Htot > 0.0) then + Drag_u(I,j) = Drag_u(I,j) / Htot + BT_force_u(I,j) = BT_force_u(I,j) - Drag_u(I,j) + else + Drag_u(I,j) = 0.0 + endif + enddo ; enddo + !$OMP do + do J=js-1,je ; do i=is,ie + Htot = 0.5 * (eta(i,j) + eta(i,j+1)) + if (GV%Boussinesq) & + Htot = Htot + 0.5*GV%Z_to_H * (CS%bathyT(i,j) + CS%bathyT(i,j+1)) + if (Htot > 0.0) then + Drag_v(i,J) = Drag_v(i,J) / Htot + BT_force_v(i,J) = BT_force_v(i,J) - Drag_v(i,J) + else + Drag_v(i,J) = 0.0 + endif + enddo ; enddo + endif + + ! Mask out the forcing at OBC points + if (CS%BT_OBC%u_OBCs_on_PE) then + !$OMP do + do j=js,je ; do I=is-1,ie + BT_force_u(I,j) = CS%OBCmask_u(I,j) * BT_force_u(I,j) + enddo ; enddo + endif + if (CS%BT_OBC%v_OBCs_on_PE) then + !$OMP do + do J=js-1,je ; do i=is,ie + BT_force_v(i,J) = CS%OBCmask_v(i,J) * BT_force_v(i,J) + enddo ; enddo + endif + if ((Isq > is-1) .or. (Jsq > js-1)) then ! Non-symmetric memory is being used, so the edge values need to be ! filled in with a halo update of a non-symmetric array. @@ -1351,43 +1497,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif ! Determine the weighted Coriolis parameters for the neighboring velocities. - !$OMP parallel do default(shared) - do J=jsvf-1,jevf ; do i=isvf-1,ievf+1 - if (CS%Sadourny) then - amer(I-1,j) = DCor_u(I-1,j) * q(I-1,J) - bmer(I,j) = DCor_u(I,j) * q(I,J) - cmer(I,j+1) = DCor_u(I,j+1) * q(I,J) - dmer(I-1,j+1) = DCor_u(I-1,j+1) * q(I-1,J) - else - amer(I-1,j) = DCor_u(I-1,j) * & - ((q(I,J) + q(I-1,J-1)) + q(I-1,J)) / 3.0 - bmer(I,j) = DCor_u(I,j) * & - (q(I,J) + (q(I-1,J) + q(I,J-1))) / 3.0 - cmer(I,j+1) = DCor_u(I,j+1) * & - (q(I,J) + (q(I-1,J) + q(I,J+1))) / 3.0 - dmer(I-1,j+1) = DCor_u(I-1,j+1) * & - ((q(I,J) + q(I-1,J+1)) + q(I-1,J)) / 3.0 - endif - enddo ; enddo - - !$OMP parallel do default(shared) - do j=jsvf-1,jevf+1 ; do I=isvf-1,ievf - if (CS%Sadourny) then - azon(I,j) = DCor_v(i+1,J) * q(I,J) - bzon(I,j) = DCor_v(i,J) * q(I,J) - czon(I,j) = DCor_v(i,J-1) * q(I,J-1) - dzon(I,j) = DCor_v(i+1,J-1) * q(I,J-1) - else - azon(I,j) = DCor_v(i+1,J) * & - (q(I,J) + (q(I+1,J) + q(I,J-1))) / 3.0 - bzon(I,j) = DCor_v(i,J) * & - (q(I,J) + (q(I-1,J) + q(I,J-1))) / 3.0 - czon(I,j) = DCor_v(i,J-1) * & - ((q(I,J) + q(I-1,J-1)) + q(I,J-1)) / 3.0 - dzon(I,j) = DCor_v(i+1,J-1) * & - ((q(I,J) + q(I+1,J-1)) + q(I,J-1)) / 3.0 - endif - enddo ; enddo + call btstep_find_Cor(q, DCor_u, DCor_v, f_4_u, f_4_v, isvf, ievf, jsvf, jevf, CS) ! Complete the previously initiated message passing. if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre) @@ -1414,14 +1524,14 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie Cor_ref_u(I,j) = & - ((azon(I,j) * vbt_Cor(i+1,j) + czon(I,j) * vbt_Cor(i ,j-1)) + & - (bzon(I,j) * vbt_Cor(i ,j) + dzon(I,j) * vbt_Cor(i+1,j-1))) + (((f_4_u(4,I,j) * vbt_Cor(i+1,j)) + (f_4_u(1,I,j) * vbt_Cor(i ,j-1))) + & + ((f_4_u(3,I,j) * vbt_Cor(i ,j)) + (f_4_u(2,I,j) * vbt_Cor(i+1,j-1)))) enddo ; enddo !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie Cor_ref_v(i,J) = -1.0 * & - ((amer(I-1,j) * ubt_Cor(I-1,j) + cmer(I ,j+1) * ubt_Cor(I ,j+1)) + & - (bmer(I ,j) * ubt_Cor(I ,j) + dmer(I-1,j+1) * ubt_Cor(I-1,j+1))) + (((f_4_v(1,i,J) * ubt_Cor(I-1,j)) + (f_4_v(4,i,J) * ubt_Cor(I ,j+1))) + & + ((f_4_v(2,i,J) * ubt_Cor(I ,j)) + (f_4_v(3,i,J) * ubt_Cor(I-1,j+1)))) enddo ; enddo ! Now start new halo updates. @@ -1474,49 +1584,44 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif if (CS%linear_wave_drag) then !$OMP do - do j=js,je ; do I=is-1,ie ; if (CS%lin_drag_u(I,j) > 0.0) then + do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) * CS%lin_drag_u(I,j) > 0.0) then Htot = 0.5 * (eta(i,j) + eta(i+1,j)) if (GV%Boussinesq) & Htot = Htot + 0.5*GV%Z_to_H * (CS%bathyT(i,j) + CS%bathyT(i+1,j)) - bt_rem_u(I,j) = bt_rem_u(I,j) * (Htot / (Htot + CS%lin_drag_u(I,j) * dtbt)) - - Rayleigh_u(I,j) = CS%lin_drag_u(I,j) / Htot + ! If Htot==0., linear wave drag is not used and Rayleigh_u = 0.0 (from initialization) + ! and bt_rem_u is unmodified. + if (Htot > 0.0) then + bt_rem_u(I,j) = bt_rem_u(I,j) * (Htot / (Htot + CS%lin_drag_u(I,j) * dtbt)) + Rayleigh_u(I,j) = CS%lin_drag_u(I,j) / Htot + endif endif ; enddo ; enddo !$OMP do - do J=js-1,je ; do i=is,ie ; if (CS%lin_drag_v(i,J) > 0.0) then + do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) * CS%lin_drag_v(i,J) > 0.0) then Htot = 0.5 * (eta(i,j) + eta(i,j+1)) if (GV%Boussinesq) & Htot = Htot + 0.5*GV%Z_to_H * (CS%bathyT(i,j) + CS%bathyT(i,j+1)) - bt_rem_v(i,J) = bt_rem_v(i,J) * (Htot / (Htot + CS%lin_drag_v(i,J) * dtbt)) - - Rayleigh_v(i,J) = CS%lin_drag_v(i,J) / Htot + ! If Htot==0., linear wave drag is not used and Rayleigh_v = 0.0 (from initialization) + ! and bt_rem_v is unmodified. + if (Htot > 0.0) then + bt_rem_v(i,J) = bt_rem_v(i,J) * (Htot / (Htot + CS%lin_drag_v(i,J) * dtbt)) + Rayleigh_v(i,J) = CS%lin_drag_v(i,J) / Htot + endif endif ; enddo ; enddo endif - ! Zero out the arrays for various time-averaged quantities. - if (find_etaav) then + ! Avoid changing the velocities at OBC points due to non-OBC calculations. + if (CS%BT_OBC%u_OBCs_on_PE) then !$OMP do - do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1 - eta_sum(i,j) = 0.0 ; eta_wtd(i,j) = 0.0 - enddo ; enddo - else + do j=js,je ; do I=is-1,ie ; if (CS%BT_OBC%u_OBC_type(I,j) /= 0) then + bt_rem_u(I,j) = 1.0 + endif ; enddo ; enddo + endif + if (CS%BT_OBC%v_OBCs_on_PE) then !$OMP do - do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1 - eta_wtd(i,j) = 0.0 - enddo ; enddo + do J=js-1,je ; do i=is,ie ; if (CS%BT_OBC%v_OBC_type(i,J) /= 0) then + bt_rem_v(i,J) = 1.0 + endif ; enddo ; enddo endif - !$OMP do - do j=jsvf-1,jevf+1 ; do I=isvf-1,ievf - ubt_sum(I,j) = 0.0 ; uhbt_sum(I,j) = 0.0 - PFu_bt_sum(I,j) = 0.0 ; Coru_bt_sum(I,j) = 0.0 - ubt_wtd(I,j) = 0.0 ; ubt_trans(I,j) = 0.0 - enddo ; enddo - !$OMP do - do J=jsvf-1,jevf ; do i=isvf-1,ievf+1 - vbt_sum(i,J) = 0.0 ; vhbt_sum(i,J) = 0.0 - PFv_bt_sum(i,J) = 0.0 ; Corv_bt_sum(i,J) = 0.0 - vbt_wtd(i,J) = 0.0 ; vbt_trans(i,J) = 0.0 - enddo ; enddo ! Set the mass source, after first initializing the halos to 0. !$OMP do @@ -1560,15 +1665,20 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, do j=js,je ; do i=is,ie eta_src(i,j) = G%mask2dT(i,j) * (Instep * CS%eta_cor(i,j)) enddo ; enddo -!$OMP end parallel + !$OMP end parallel if (CS%dynamic_psurf) then ice_is_rigid = (associated(forces%rigidity_ice_u) .and. & associated(forces%rigidity_ice_v)) - H_min_dyn = GV%Z_to_H * CS%Dmin_dyn_psurf + H_min_dyn = CS%Dmin_dyn_psurf if (ice_is_rigid .and. use_BT_cont) & call BT_cont_to_face_areas(BT_cont, Datu, Datv, G, US, MS, halo=0) if (ice_is_rigid) then + if (GV%Boussinesq) then + H_to_Z = GV%H_to_Z + else + H_to_Z = GV%H_to_RZ / CS%Rho_BT_lin + endif !$OMP parallel do default(shared) private(Idt_max2,H_eff_dx2,dyn_coef_max,ice_strength) do j=js,je ; do i=is,ie ! First determine the maximum stable value for dyn_coef_eta. @@ -1576,17 +1686,17 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! This estimate of the maximum stable time step is pretty accurate for ! gravity waves, but it is a conservative estimate since it ignores the ! stabilizing effect of the bottom drag. - Idt_max2 = 0.5 * (dgeo_de * (1.0 + 2.0*bebt)) * (G%IareaT(i,j) * & - ((gtot_E(i,j) * (Datu(I,j)*G%IdxCu(I,j)) + & - gtot_W(i,j) * (Datu(I-1,j)*G%IdxCu(I-1,j))) + & - (gtot_N(i,j) * (Datv(i,J)*G%IdyCv(i,J)) + & - gtot_S(i,j) * (Datv(i,J-1)*G%IdyCv(i,J-1)))) + & - ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & - (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) * CS%BT_Coriolis_scale**2 ) - H_eff_dx2 = max(H_min_dyn * ((G%IdxT(i,j))**2 + (G%IdyT(i,j))**2), & + Idt_max2 = 0.5 * (dgeo_de * (1.0 + 2.0*CS%bebt)) * (G%IareaT(i,j) * & + (((gtot_E(i,j) * (Datu(I,j)*G%IdxCu(I,j))) + & + (gtot_W(i,j) * (Datu(I-1,j)*G%IdxCu(I-1,j)))) + & + ((gtot_N(i,j) * (Datv(i,J)*G%IdyCv(i,J))) + & + (gtot_S(i,j) * (Datv(i,J-1)*G%IdyCv(i,J-1))))) + & + ((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + & + (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) * CS%BT_Coriolis_scale**2 ) + H_eff_dx2 = max(H_min_dyn * ((G%IdxT(i,j)**2) + (G%IdyT(i,j)**2)), & G%IareaT(i,j) * & - ((Datu(I,j)*G%IdxCu(I,j) + Datu(I-1,j)*G%IdxCu(I-1,j)) + & - (Datv(i,J)*G%IdyCv(i,J) + Datv(i,J-1)*G%IdyCv(i,J-1)) ) ) + (((Datu(I,j)*G%IdxCu(I,j)) + (Datu(I-1,j)*G%IdxCu(I-1,j))) + & + ((Datv(i,J)*G%IdyCv(i,J)) + (Datv(i,J-1)*G%IdyCv(i,J-1))) ) ) dyn_coef_max = CS%const_dyn_psurf * max(0.0, 1.0 - dtbt**2 * Idt_max2) / & (dtbt**2 * H_eff_dx2) @@ -1596,7 +1706,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, (CS%ice_strength_length**2 * dtbt) ! Units of dyn_coef: [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1] - dyn_coef_eta(i,j) = min(dyn_coef_max, ice_strength * GV%H_to_Z) + dyn_coef_eta(i,j) = min(dyn_coef_max, ice_strength * H_to_Z) enddo ; enddo ; endif endif @@ -1629,44 +1739,56 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%debug) then call uvchksum("BT [uv]hbt", uhbt, vhbt, CS%debug_BT_HI, haloshift=0, & - scale=US%s_to_T*US%L_to_m**2*GV%H_to_m) - call uvchksum("BT Initial [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=0, scale=US%L_T_to_m_s) - call hchksum(eta, "BT Initial eta", CS%debug_BT_HI, haloshift=0, scale=GV%H_to_m) + unscale=US%s_to_T*US%L_to_m**2*GV%H_to_m) + call uvchksum("BT Initial [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=0, unscale=US%L_T_to_m_s) + call hchksum(eta, "BT Initial eta", CS%debug_BT_HI, haloshift=0, unscale=GV%H_to_MKS) call uvchksum("BT BT_force_[uv]", BT_force_u, BT_force_v, & - CS%debug_BT_HI, haloshift=0, scale=US%L_T2_to_m_s2) + CS%debug_BT_HI, haloshift=0, unscale=US%L_T2_to_m_s2) if (interp_eta_PF) then - call hchksum(eta_PF_1, "BT eta_PF_1",CS%debug_BT_HI,haloshift=0, scale=GV%H_to_m) - call hchksum(d_eta_PF, "BT d_eta_PF",CS%debug_BT_HI,haloshift=0, scale=GV%H_to_m) + call hchksum(eta_PF_1, "BT eta_PF_1", CS%debug_BT_HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(d_eta_PF, "BT d_eta_PF", CS%debug_BT_HI, haloshift=0, unscale=GV%H_to_MKS) + else + call hchksum(eta_PF, "BT eta_PF", CS%debug_BT_HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(eta_PF_in, "BT eta_PF_in", G%HI,haloshift=0, unscale=GV%H_to_MKS) + endif + if (CS%linearized_BT_PV) then + call Bchksum(CS%q_D, "BT PV (q_D)", CS%debug_BT_HI, haloshift=0, symmetric=.true., unscale=US%s_to_T/GV%H_to_MKS) else - call hchksum(eta_PF, "BT eta_PF",CS%debug_BT_HI,haloshift=0, scale=GV%H_to_m) - call hchksum(eta_PF_in, "BT eta_PF_in",G%HI,haloshift=0, scale=GV%H_to_m) + call Bchksum(q, "BT PV (q)", CS%debug_BT_HI, haloshift=0, symmetric=.true., unscale=US%s_to_T/GV%H_to_MKS) endif - call uvchksum("BT Cor_ref_[uv]", Cor_ref_u, Cor_ref_v, CS%debug_BT_HI, haloshift=0, scale=US%L_T2_to_m_s2) + call uvchksum("BT DCor_[uv]", DCor_u, DCor_v, G%HI, haloshift=0, & + symmetric=.true., omit_corners=.true., scalar_pair=.true., unscale=GV%H_to_MKS) + call uvchksum("BT Cor_ref_[uv]", Cor_ref_u, Cor_ref_v, CS%debug_BT_HI, haloshift=0, unscale=US%L_T2_to_m_s2) call uvchksum("BT [uv]hbt0", uhbt0, vhbt0, CS%debug_BT_HI, haloshift=0, & - scale=US%L_to_m**2*US%s_to_T*GV%H_to_m) + unscale=US%L_to_m**2*US%s_to_T*GV%H_to_m) if (.not. use_BT_cont) then - call uvchksum("BT Dat[uv]", Datu, Datv, CS%debug_BT_HI, haloshift=1, scale=US%L_to_m*GV%H_to_m) + call uvchksum("BT Dat[uv]", Datu, Datv, CS%debug_BT_HI, haloshift=1, unscale=US%L_to_m*GV%H_to_m) endif call uvchksum("BT wt_[uv]", wt_u, wt_v, G%HI, haloshift=0, & symmetric=.true., omit_corners=.true., scalar_pair=.true.) call uvchksum("BT frhat[uv]", CS%frhatu, CS%frhatv, G%HI, haloshift=0, & symmetric=.true., omit_corners=.true., scalar_pair=.true.) - call uvchksum("BT bc_accel_[uv]", bc_accel_u, bc_accel_v, G%HI, haloshift=0, scale=US%L_T2_to_m_s2) + call uvchksum("BT visc_rem_[uv]", visc_rem_u, visc_rem_v, G%HI, haloshift=0, & + symmetric=.true., omit_corners=.true., scalar_pair=.true.) + call uvchksum("BT bc_accel_[uv]", bc_accel_u, bc_accel_v, G%HI, haloshift=0, unscale=US%L_T2_to_m_s2) call uvchksum("BT IDat[uv]", CS%IDatu, CS%IDatv, G%HI, haloshift=0, & - scale=US%m_to_Z, scalar_pair=.true.) + unscale=GV%m_to_H, scalar_pair=.true.) call uvchksum("BT visc_rem_[uv]", visc_rem_u, visc_rem_v, G%HI, & haloshift=1, scalar_pair=.true.) - endif - if (CS%id_ubtdt > 0) then - do j=js-1,je+1 ; do I=is-1,ie - ubt_st(I,j) = ubt(I,j) - enddo ; enddo - endif - if (CS%id_vbtdt > 0) then - do J=js-1,je ; do i=is-1,ie+1 - vbt_st(i,J) = vbt(i,J) - enddo ; enddo + if (apply_OBCs) then + call uvchksum("BT_OBC%[uv]bt_outer", CS%BT_OBC%ubt_outer, CS%BT_OBC%vbt_outer, CS%debug_BT_HI, & + symmetric=.true., omit_corners=.true., unscale=US%L_T_to_m_s) + if (allocated(CS%BT_OBC%SSH_outer_u) .and. allocated(CS%BT_OBC%SSH_outer_v)) & + call uvchksum("BT_OBC%SSH_outer[uv]", CS%BT_OBC%SSH_outer_u, CS%BT_OBC%SSH_outer_v, CS%debug_BT_HI, & + symmetric=.true., omit_corners=.true., unscale=US%Z_to_m, scalar_pair=.true.) + if (allocated(CS%BT_OBC%Cg_u) .and. allocated(CS%BT_OBC%Cg_v)) & + call uvchksum("BT_OBC%Cg_[uv]", CS%BT_OBC%Cg_u, CS%BT_OBC%Cg_v, CS%debug_BT_HI, & + symmetric=.true., omit_corners=.true., unscale=US%L_T_to_m_s, scalar_pair=.true.) + if (allocated(CS%BT_OBC%dZ_u) .and. allocated(CS%BT_OBC%dZ_v)) & + call uvchksum("BT_OBC%dZ_[uv]", CS%BT_OBC%dZ_u, CS%BT_OBC%dZ_v, CS%debug_BT_HI, & + symmetric=.true., omit_corners=.true., unscale=US%Z_to_m, scalar_pair=.true.) + endif endif if (query_averaging_enabled(CS%diag)) then @@ -1678,8 +1800,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre) if (id_clock_calc > 0) call cpu_clock_begin(id_clock_calc) - if (project_velocity) then ; eta_PF_BT => eta ; else ; eta_PF_BT => eta_pred ; endif - if (CS%dt_bt_filter >= 0.0) then dt_filt = 0.5 * max(0.0, min(CS%dt_bt_filter, 2.0*dt)) else @@ -1687,8 +1807,10 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, endif nfilter = ceiling(dt_filt / dtbt) - if (nstep+nfilter==0 ) call MOM_error(FATAL, & + if ( nstep+nfilter<=0 ) call MOM_error(FATAL, & "btstep: number of barotropic step (nstep+nfilter) is 0") + if ( CS%bt_limit_integral_transport .and. nstep-nfilter<=0 ) call MOM_error(FATAL, & + "btstep: barotropic filter steps too large (nstep-nfilter) is 0") ! Set up the normalized weights for the filtered velocity. sum_wt_vel = 0.0 ; sum_wt_eta = 0.0 ; sum_wt_accel = 0.0 ; sum_wt_trans = 0.0 @@ -1724,7 +1846,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, I_sum_wt_eta = 1.0 / sum_wt_eta ; I_sum_wt_trans = 1.0 / sum_wt_trans do n=1,nstep+nfilter wt_vel(n) = wt_vel(n) * I_sum_wt_vel - if (CS%answers_2018) then + if (CS%answer_date < 20190101) then wt_accel2(n) = wt_accel(n) ! wt_trans(n) = wt_trans(n) * I_sum_wt_trans else @@ -1734,1016 +1856,1849 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, wt_accel(n) = wt_accel(n) * I_sum_wt_accel wt_eta(n) = wt_eta(n) * I_sum_wt_eta enddo + if (CS%answer_date < 20190101) then + ! Recalculate the sum of the weights even that they may have been renormalized already. + sum_wt_vel = 0.0 ; sum_wt_eta = 0.0 ; sum_wt_trans = 0.0 ; sum_wt_accel = 0.0 + do n=1,nstep+nfilter + sum_wt_vel = sum_wt_vel + wt_vel(n) + sum_wt_eta = sum_wt_eta + wt_eta(n) + sum_wt_accel = sum_wt_accel + wt_accel2(n) + sum_wt_trans = sum_wt_trans + wt_trans(n) + enddo + I_sum_wt_vel = 1.0 / sum_wt_vel ; I_sum_wt_eta = 1.0 / sum_wt_eta + I_sum_wt_accel = 1.0 / sum_wt_accel ; I_sum_wt_trans = 1.0 / sum_wt_trans + else + I_sum_wt_vel = 1.0 ; I_sum_wt_eta = 1.0 ; I_sum_wt_accel = 1.0 ; I_sum_wt_trans = 1.0 + endif - sum_wt_vel = 0.0 ; sum_wt_eta = 0.0 ; sum_wt_accel = 0.0 ; sum_wt_trans = 0.0 - - ! The following loop contains all of the time steps. - isv=is ; iev=ie ; jsv=js ; jev=je - do n=1,nstep+nfilter + ! March the barotropic solver through all of its time steps. + call btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL_v, eta_IC, & + eta_PF_1, d_eta_PF, eta_src, dyn_coef_eta, uhbtav, vhbtav, u_accel_bt, v_accel_bt, & + f_4_u, f_4_v, bt_rem_u, bt_rem_v, & + BT_force_u, BT_force_v, Cor_ref_u, Cor_ref_v, Rayleigh_u, Rayleigh_v, & + eta_PF, gtot_E, gtot_W, gtot_N, gtot_S, SpV_col_avg, dgeo_de, & + eta_sum, eta_wtd, ubt_wtd, vbt_wtd, Coru_avg, PFu_avg, LDu_avg, Corv_avg, PFv_avg, & + LDv_avg, use_BT_cont, interp_eta_PF, find_etaav, dt, dtbt, nstep, nfilter, & + wt_vel, wt_eta, wt_accel, wt_trans, wt_accel2, ADp, CS%BT_OBC, CS, G, MS, GV, US) - sum_wt_vel = sum_wt_vel + wt_vel(n) - sum_wt_eta = sum_wt_eta + wt_eta(n) - sum_wt_accel = sum_wt_accel + wt_accel2(n) - sum_wt_trans = sum_wt_trans + wt_trans(n) + if (id_clock_calc > 0) call cpu_clock_end(id_clock_calc) + if (id_clock_calc_post > 0) call cpu_clock_begin(id_clock_calc_post) - if (CS%clip_velocity) then - do j=jsv,jev ; do I=isv-1,iev - if ((ubt(I,j) * (dt * G%dy_Cu(I,j))) * G%IareaT(i+1,j) < -CS%CFL_trunc) then - ! Add some error reporting later. - ubt(I,j) = (-0.95*CS%CFL_trunc) * (G%areaT(i+1,j) / (dt * G%dy_Cu(I,j))) - elseif ((ubt(I,j) * (dt * G%dy_Cu(I,j))) * G%IareaT(i,j) > CS%CFL_trunc) then - ! Add some error reporting later. - ubt(I,j) = (0.95*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dy_Cu(I,j))) - endif - enddo ; enddo - do J=jsv-1,jev ; do i=isv,iev - if ((vbt(i,J) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j+1) < -CS%CFL_trunc) then - ! Add some error reporting later. - vbt(i,J) = (-0.9*CS%CFL_trunc) * (G%areaT(i,j+1) / (dt * G%dx_Cv(i,J))) - elseif ((vbt(i,J) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j) > CS%CFL_trunc) then - ! Add some error reporting later. - vbt(i,J) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dx_Cv(i,J))) - endif + if (find_etaav) then ; do j=js,je ; do i=is,ie + etaav(i,j) = eta_sum(i,j) * I_sum_wt_accel + enddo ; enddo ; endif + do j=js-1,je+1 ; do i=is-1,ie+1 ; e_anom(i,j) = 0.0 ; enddo ; enddo + if (interp_eta_PF) then + do j=js,je ; do i=is,ie + e_anom(i,j) = dgeo_de * (0.5 * (eta(i,j) + eta_in(i,j)) - & + (eta_PF_1(i,j) + 0.5*d_eta_PF(i,j))) + enddo ; enddo + else + do j=js,je ; do i=is,ie + e_anom(i,j) = dgeo_de * (0.5 * (eta(i,j) + eta_in(i,j)) - eta_PF(i,j)) + enddo ; enddo + endif + if (apply_OBCs) then + ! This block of code may be unnecessary because e_anom is only used for accelerations that + ! are then recalculated at OBC points. + if (CS%BT_OBC%u_OBCs_on_PE) then ! copy back the value for u-points on the boundary. + !GOMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + if (CS%BT_OBC%u_OBC_type(I,j) > 0) e_anom(i+1,j) = e_anom(i,j) ! OBC_DIRECTION_E + if (CS%BT_OBC%u_OBC_type(I,j) < 0) e_anom(i,j) = e_anom(i+1,j) ! OBC_DIRECTION_W enddo ; enddo endif - if ((iev - stencil < ie) .or. (jev - stencil < je)) then - if (id_clock_calc > 0) call cpu_clock_end(id_clock_calc) - call do_group_pass(CS%pass_eta_ubt, CS%BT_Domain, clock=id_clock_pass_step) - isv = isvf ; iev = ievf ; jsv = jsvf ; jev = jevf - if (id_clock_calc > 0) call cpu_clock_begin(id_clock_calc) - else - isv = isv+stencil ; iev = iev-stencil - jsv = jsv+stencil ; jev = jev-stencil + if (CS%BT_OBC%v_OBCs_on_PE) then ! copy back the value for v-points on the boundary. + !GOMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + if (CS%BT_OBC%v_OBC_type(i,J) > 0) e_anom(i,j+1) = e_anom(i,j) ! OBC_DIRECTION_N + if (CS%BT_OBC%v_OBC_type(i,J) < 0) e_anom(i,j) = e_anom(i,j+1) ! OBC_DIRECTION_S + enddo ; enddo endif + endif - if ((.not.use_BT_cont) .and. CS%Nonlinear_continuity .and. & - (CS%Nonlin_cont_update_period > 0)) then - if ((n>1) .and. (mod(n-1,CS%Nonlin_cont_update_period) == 0)) & - call find_face_areas(Datu, Datv, G, GV, US, CS, MS, 1+iev-ie, eta) - endif + ! Note that it is possible that eta_out and eta_in are the same array. + do j=js,je ; do i=is,ie + eta_out(i,j) = eta_wtd(i,j) * I_sum_wt_eta + enddo ; enddo - if (integral_BT_cont) then - !$OMP parallel do default(shared) - do j=jsv-1,jev+1 ; do I=isv-2,iev+1 - ubt_int_prev(I,j) = ubt_int(I,j) ; uhbt_int_prev(I,j) = uhbt_int(I,j) - enddo ; enddo - !$OMP parallel do default(shared) - do J=jsv-2,jev+1 ; do i=isv-1,iev+1 - vbt_int_prev(i,J) = vbt_int(i,J) ; vhbt_int_prev(i,J) = vhbt_int(i,J) - enddo ; enddo - endif + ! Accumulator is updated at the end of every baroclinic time step. + ! Harmonic analysis will not be performed of a field that is not registered. + if (associated(CS%HA_CSp) .and. find_etaav) then + call HA_accum('ubt', ubt, CS%Time, G, CS%HA_CSp) + call HA_accum('vbt', vbt, CS%Time, G, CS%HA_CSp) + endif - !$OMP parallel default(shared) private(vel_prev, ioff, joff) - if (CS%dynamic_psurf .or. .not.project_velocity) then - if (integral_BT_cont) then - !$OMP do - do j=jsv-1,jev+1 ; do I=isv-2,iev+1 - uhbt_int(I,j) = find_uhbt(ubt_int(I,j) + dtbt*ubt(I,j), BTCL_u(I,j)) + n*dtbt*uhbt0(I,j) - enddo ; enddo - !$OMP end do nowait - !$OMP do - do J=jsv-2,jev+1 ; do i=isv-1,iev+1 - vhbt_int(i,J) = find_vhbt(vbt_int(i,J) + dtbt*vbt(i,J), BTCL_v(i,J)) + n*dtbt*vhbt0(i,J) - enddo ; enddo - !$OMP do - do j=jsv-1,jev+1 ; do i=isv-1,iev+1 - eta_pred(i,j) = (eta_IC(i,j) + n*eta_src(i,j)) + CS%IareaT(i,j) * & - ((uhbt_int(I-1,j) - uhbt_int(I,j)) + (vhbt_int(i,J-1) - vhbt_int(i,J))) - enddo ; enddo - elseif (use_BT_cont) then - !$OMP do - do j=jsv-1,jev+1 ; do I=isv-2,iev+1 - uhbt(I,j) = find_uhbt(ubt(I,j), BTCL_u(I,j)) + uhbt0(I,j) - enddo ; enddo - !$OMP do - do J=jsv-2,jev+1 ; do i=isv-1,iev+1 - vhbt(i,J) = find_vhbt(vbt(i,J), BTCL_v(i,J)) + vhbt0(i,J) - enddo ; enddo - !$OMP do - do j=jsv-1,jev+1 ; do i=isv-1,iev+1 - eta_pred(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * CS%IareaT(i,j)) * & - ((uhbt(I-1,j) - uhbt(I,j)) + (vhbt(i,J-1) - vhbt(i,J))) - enddo ; enddo - else - !$OMP do - do j=jsv-1,jev+1 ; do i=isv-1,iev+1 - eta_pred(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * CS%IareaT(i,j)) * & - (((Datu(I-1,j)*ubt(I-1,j) + uhbt0(I-1,j)) - & - (Datu(I,j)*ubt(I,j) + uhbt0(I,j))) + & - ((Datv(i,J-1)*vbt(i,J-1) + vhbt0(i,J-1)) - & - (Datv(i,J)*vbt(i,J) + vhbt0(i,J)))) - enddo ; enddo - endif + if (id_clock_calc_post > 0) call cpu_clock_end(id_clock_calc_post) + if (id_clock_pass_post > 0) call cpu_clock_begin(id_clock_pass_post) + if (G%nonblocking_updates) then + call start_group_pass(CS%pass_e_anom, G%Domain) + else + if (find_etaav) call do_group_pass(CS%pass_etaav, G%Domain) + call do_group_pass(CS%pass_e_anom, G%Domain) + endif + if (id_clock_pass_post > 0) call cpu_clock_end(id_clock_pass_post) + if (id_clock_calc_post > 0) call cpu_clock_begin(id_clock_calc_post) - if (CS%dynamic_psurf) then - !$OMP do - do j=jsv-1,jev+1 ; do i=isv-1,iev+1 - p_surf_dyn(i,j) = dyn_coef_eta(i,j) * (eta_pred(i,j) - eta(i,j)) - enddo ; enddo - endif - endif + ! Find or store the weighted time-mean velocities and transports. + if (CS%answer_date < 20190101) then + do j=js,je ; do I=is-1,ie + CS%ubtav(I,j) = CS%ubtav(I,j) * I_sum_wt_trans + uhbtav(I,j) = uhbtav(I,j) * I_sum_wt_trans + ubt_wtd(I,j) = ubt_wtd(I,j) * I_sum_wt_vel + enddo ; enddo - ! Recall that just outside the do n loop, there is code like... - ! eta_PF_BT => eta_pred ; if (project_velocity) eta_PF_BT => eta + do J=js-1,je ; do i=is,ie + CS%vbtav(i,J) = CS%vbtav(i,J) * I_sum_wt_trans + vhbtav(i,J) = vhbtav(i,J) * I_sum_wt_trans + vbt_wtd(i,J) = vbt_wtd(i,J) * I_sum_wt_vel + enddo ; enddo + endif - if (find_etaav) then - !$OMP do - do j=js,je ; do i=is,ie - eta_sum(i,j) = eta_sum(i,j) + wt_accel2(n) * eta_PF_BT(i,j) - enddo ; enddo - !$OMP end do nowait - endif + if (CS%use_filter .and. CS%linear_freq_drag) then ! Apply frequency-dependent drag + !$OMP do + do j=js,je ; do I=is-1,ie + u_accel_bt(I,j) = u_accel_bt(I,j) - Drag_u(I,j) + enddo ; enddo + !$OMP do + do J=js-1,je ; do i=is,ie + v_accel_bt(i,J) = v_accel_bt(i,J) - Drag_v(i,J) + enddo ; enddo - if (interp_eta_PF) then - wt_end = n*Instep ! This could be (n-0.5)*Instep. - !$OMP do - do j=jsv-1,jev+1 ; do i=isv-1,iev+1 - eta_PF(i,j) = eta_PF_1(i,j) + wt_end*d_eta_PF(i,j) - enddo ; enddo - endif + if ((CS%id_LDu_bt > 0) .or. (associated(ADp%bt_lwd_u))) then ; do j=js,je ; do I=is-1,ie + LDu_avg(I,j) = LDu_avg(I,j) - Drag_u(I,j) + enddo ; enddo ; endif + if ((CS%id_LDv_bt > 0) .or. (associated(ADp%bt_lwd_v))) then ; do J=js-1,je ; do i=is,ie + LDv_avg(i,J) = LDv_avg(i,J) - Drag_v(i,J) + enddo ; enddo ; endif + endif - if (apply_OBC_flather .or. apply_OBC_open) then - !$OMP do - do j=jsv,jev ; do I=isv-2,iev+1 - ubt_old(I,j) = ubt(I,j) - enddo ; enddo - !$OMP do - do J=jsv-2,jev+1 ; do i=isv,iev - vbt_old(i,J) = vbt(i,J) - enddo ; enddo - endif + if (id_clock_calc_post > 0) call cpu_clock_end(id_clock_calc_post) + if (id_clock_pass_post > 0) call cpu_clock_begin(id_clock_pass_post) + if (G%nonblocking_updates) then + call complete_group_pass(CS%pass_e_anom, G%Domain) + if (find_etaav) call start_group_pass(CS%pass_etaav, G%Domain) + call start_group_pass(CS%pass_ubta_uhbta, G%DoMain) + else + call do_group_pass(CS%pass_ubta_uhbta, G%Domain) + endif + if (id_clock_pass_post > 0) call cpu_clock_end(id_clock_pass_post) + if (id_clock_calc_post > 0) call cpu_clock_begin(id_clock_calc_post) - if (apply_OBCs) then - if (MOD(n+G%first_direction,2)==1) then - ioff = 1; joff = 0 - else - ioff = 0; joff = 1 - endif + if (CS%strong_drag .and. CS%rescale_strong_drag) then + do j=js,je ; do I=is-1,ie + if (G%mask2dCu(I,j) * av_rem_u(I,j) > 0.0) & + u_accel_bt(I,j) = u_accel_bt(I,j) * min(bt_rem_u(I,j)**nstep / av_rem_u(I,j), 1.0) + enddo ; enddo + do J=js-1,je ; do i=is,ie + if (G%mask2dCv(i,J) * av_rem_v(i,J) > 0.0) & + v_accel_bt(i,J) = v_accel_bt(i,J) * min(bt_rem_v(i,J)**nstep / av_rem_v(i,J), 1.0) + enddo ; enddo + endif - if (CS%BT_OBC%apply_u_OBCs) then ! save the old value of ubt and uhbt - !$OMP do - do j=jsv-joff,jev+joff ; do I=isv-1,iev - ubt_prev(I,j) = ubt(I,j) ; uhbt_prev(I,j) = uhbt(I,j) - ubt_sum_prev(I,j) = ubt_sum(I,j) ; uhbt_sum_prev(I,j) = uhbt_sum(I,j) ; ubt_wtd_prev(I,j) = ubt_wtd(I,j) - enddo ; enddo - endif + ! Now calculate each layer's accelerations. + call btstep_layer_accel(dt, u_accel_bt, v_accel_bt, pbce, gtot_E, gtot_W, gtot_N, gtot_S, & + e_anom, G, GV, CS, accel_layer_u, accel_layer_v) - if (CS%BT_OBC%apply_v_OBCs) then ! save the old value of vbt and vhbt - !$OMP do - do J=jsv-1,jev ; do i=isv-ioff,iev+ioff - vbt_prev(i,J) = vbt(i,J) ; vhbt_prev(i,J) = vhbt(i,J) - vbt_sum_prev(i,J) = vbt_sum(i,J) ; vhbt_sum_prev(i,J) = vhbt_sum(i,J) ; vbt_wtd_prev(i,J) = vbt_wtd(i,J) - enddo ; enddo + if (apply_OBCs) then + ! Correct the accelerations at OBC velocity points, but only in the + ! symmetric-memory computational domain, not in the wide halo regions. + if (CS%BT_OBC%u_OBCs_on_PE) then ; do j=js,je ; do I=is-1,ie + if (CS%BT_OBC%u_OBC_type(I,j) /= 0) then + u_accel_bt(I,j) = (ubt_wtd(I,j) - ubt_st(I,j)) / dt + do k=1,nz ; accel_layer_u(I,j,k) = u_accel_bt(I,j) ; enddo endif - endif - - if (MOD(n+G%first_direction,2)==1) then - ! On odd-steps, update v first. - !$OMP do schedule(static) - do J=jsv-1,jev ; do i=isv-1,iev+1 - Cor_v(i,J) = -1.0*((amer(I-1,j) * ubt(I-1,j) + cmer(I,j+1) * ubt(I,j+1)) + & - (bmer(I,j) * ubt(I,j) + dmer(I-1,j+1) * ubt(I-1,j+1))) - Cor_ref_v(i,J) - PFv(i,J) = ((eta_PF_BT(i,j)-eta_PF(i,j))*gtot_N(i,j) - & - (eta_PF_BT(i,j+1)-eta_PF(i,j+1))*gtot_S(i,j+1)) * & - dgeo_de * CS%IdyCv(i,J) - enddo ; enddo - !$OMP end do nowait - if (CS%dynamic_psurf) then - !$OMP do schedule(static) - do J=jsv-1,jev ; do i=isv-1,iev+1 - PFv(i,J) = PFv(i,J) + (p_surf_dyn(i,j) - p_surf_dyn(i,j+1)) * CS%IdyCv(i,J) - enddo ; enddo - !$OMP end do nowait + enddo ; enddo ; endif + if (CS%BT_OBC%v_OBCs_on_PE) then ; do J=js-1,je ; do i=is,ie + if (CS%BT_OBC%v_OBC_type(i,J) /= 0) then + v_accel_bt(i,J) = (vbt_wtd(i,J) - vbt_st(i,J)) / dt + do k=1,nz ; accel_layer_v(i,J,k) = v_accel_bt(i,J) ; enddo endif + enddo ; enddo ; endif + endif - if (CS%BT_OBC%apply_v_OBCs) then ! zero out PF across boundary - !$OMP do schedule(static) - do J=jsv-1,jev ; do i=isv-1,iev+1 ; if (OBC%segnum_v(i,J) /= OBC_NONE) then - PFv(i,J) = 0.0 - endif ; enddo ; enddo - !$OMP end do nowait - endif + if (id_clock_calc_post > 0) call cpu_clock_end(id_clock_calc_post) - !$OMP do schedule(static) - do J=jsv-1,jev ; do i=isv-1,iev+1 - vel_prev = vbt(i,J) - vbt(i,J) = bt_rem_v(i,J) * (vbt(i,J) + & - dtbt * ((BT_force_v(i,J) + Cor_v(i,J)) + PFv(i,J))) - if (abs(vbt(i,J)) < CS%vel_underflow) vbt(i,J) = 0.0 - vbt_trans(i,J) = trans_wt1*vbt(i,J) + trans_wt2*vel_prev - enddo ; enddo + ! Calculate diagnostic quantities. + if (query_averaging_enabled(CS%diag)) then - if (CS%linear_wave_drag) then - !$OMP do schedule(static) - do J=jsv-1,jev ; do i=isv-1,iev+1 - v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * & - ((Cor_v(i,J) + PFv(i,J)) - vbt(i,J)*Rayleigh_v(i,J)) - enddo ; enddo - else - !$OMP do schedule(static) - do J=jsv-1,jev ; do i=isv-1,iev+1 - v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * (Cor_v(i,J) + PFv(i,J)) - enddo ; enddo - endif + if (CS%gradual_BT_ICs) then + do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = ubt_wtd(I,j) ; enddo ; enddo + do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = vbt_wtd(i,J) ; enddo ; enddo + endif - if (integral_BT_cont) then - !$OMP do schedule(static) - do J=jsv-1,jev ; do i=isv-1,iev+1 - vbt_int(i,J) = vbt_int(i,J) + dtbt * vbt_trans(i,J) - vhbt_int(i,J) = find_vhbt(vbt_int(i,J), BTCL_v(i,J)) + n*dtbt*vhbt0(i,J) - ! Estimate the mass flux within a single timestep to take the filtered average. - vhbt(i,J) = (vhbt_int(i,J) - vhbt_int_prev(i,J)) * Idtbt - enddo ; enddo - elseif (use_BT_cont) then - !$OMP do schedule(static) - do J=jsv-1,jev ; do i=isv-1,iev+1 - vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J)) + vhbt0(i,J) - enddo ; enddo - !$OMP end do nowait - else - !$OMP do schedule(static) - do J=jsv-1,jev ; do i=isv-1,iev+1 - vhbt(i,J) = Datv(i,J)*vbt_trans(i,J) + vhbt0(i,J) + ! Calculate various time-averaged barotropic diagnostics. + if (CS%answer_date >= 20190101) then + if (CS%id_PFu_bt > 0) call post_data(CS%id_PFu_bt, PFu_avg, CS%diag) + if (CS%id_PFv_bt > 0) call post_data(CS%id_PFv_bt, PFv_avg, CS%diag) + if (CS%id_Coru_bt > 0) call post_data(CS%id_Coru_bt, Coru_avg, CS%diag) + if (CS%id_Corv_bt > 0) call post_data(CS%id_Corv_bt, Corv_avg, CS%diag) + if (CS%id_LDu_bt > 0) call post_data(CS%id_LDu_bt, LDu_avg, CS%diag) + if (CS%id_LDv_bt > 0) call post_data(CS%id_LDv_bt, LDv_avg, CS%diag) + else ! if (CS%answer_date < 20190101) then + if (CS%id_PFu_bt > 0) then + do j=js,je ; do I=is-1,ie + PFu_avg(I,j) = PFu_avg(I,j) * I_sum_wt_accel enddo ; enddo - !$OMP end do nowait + call post_data(CS%id_PFu_bt, PFu_avg, CS%diag) endif - if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. - !$OMP do schedule(static) - do J=jsv-1,jev ; do i=isv-1,iev+1 ; if (OBC%segnum_v(i,J) /= OBC_NONE) then - vbt(i,J) = vbt_prev(i,J) ; vhbt(i,J) = vhbt_prev(i,J) - endif ; enddo ; enddo + if (CS%id_PFv_bt > 0) then + do J=js-1,je ; do i=is,ie + PFv_avg(i,J) = PFv_avg(i,J) * I_sum_wt_accel + enddo ; enddo + call post_data(CS%id_PFv_bt, PFv_avg, CS%diag) endif - ! Now update the zonal velocity. - !$OMP do schedule(static) - do j=jsv,jev ; do I=isv-1,iev - Cor_u(I,j) = ((azon(I,j) * vbt(i+1,J) + czon(I,j) * vbt(i,J-1)) + & - (bzon(I,j) * vbt(i,J) + dzon(I,j) * vbt(i+1,J-1))) - & - Cor_ref_u(I,j) - PFu(I,j) = ((eta_PF_BT(i,j)-eta_PF(i,j))*gtot_E(i,j) - & - (eta_PF_BT(i+1,j)-eta_PF(i+1,j))*gtot_W(i+1,j)) * & - dgeo_de * CS%IdxCu(I,j) - enddo ; enddo - !$OMP end do nowait - - if (CS%dynamic_psurf) then - !$OMP do schedule(static) - do j=jsv,jev ; do I=isv-1,iev - PFu(I,j) = PFu(I,j) + (p_surf_dyn(i,j) - p_surf_dyn(i+1,j)) * CS%IdxCu(I,j) + if (CS%id_Coru_bt > 0) then + do j=js,je ; do I=is-1,ie + Coru_avg(I,j) = Coru_avg(I,j) * I_sum_wt_accel enddo ; enddo - !$OMP end do nowait + call post_data(CS%id_Coru_bt, Coru_avg, CS%diag) endif - - if (CS%BT_OBC%apply_u_OBCs) then ! zero out pressure force across boundary - !$OMP do schedule(static) - do j=jsv,jev ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then - PFu(I,j) = 0.0 - endif ; enddo ; enddo - !$OMP end do nowait + if (CS%id_Corv_bt > 0) then + do J=js-1,je ; do i=is,ie + Corv_avg(i,J) = Corv_avg(i,J) * I_sum_wt_accel + enddo ; enddo + call post_data(CS%id_Corv_bt, Corv_avg, CS%diag) endif + endif - !$OMP do schedule(static) - do j=jsv,jev ; do I=isv-1,iev - vel_prev = ubt(I,j) - ubt(I,j) = bt_rem_u(I,j) * (ubt(I,j) + & - dtbt * ((BT_force_u(I,j) + Cor_u(I,j)) + PFu(I,j))) - if (abs(ubt(I,j)) < CS%vel_underflow) ubt(I,j) = 0.0 - ubt_trans(I,j) = trans_wt1*ubt(I,j) + trans_wt2*vel_prev + ! Diagnostics for time tendency + if (CS%id_ubtdt > 0) then + do j=js,je ; do I=is-1,ie + ubt_dt(I,j) = (ubt_wtd(I,j) - ubt_st(I,j))*Idt enddo ; enddo - !$OMP end do nowait + call post_data(CS%id_ubtdt, ubt_dt(IsdB:IedB,jsd:jed), CS%diag) + endif + if (CS%id_vbtdt > 0) then + do J=js-1,je ; do i=is,ie + vbt_dt(i,J) = (vbt_wtd(i,J) - vbt_st(i,J))*Idt + enddo ; enddo + call post_data(CS%id_vbtdt, vbt_dt(isd:ied,JsdB:JedB), CS%diag) + endif - if (CS%linear_wave_drag) then - !$OMP do schedule(static) - do j=jsv,jev ; do I=isv-1,iev - u_accel_bt(I,j) = u_accel_bt(I,j) + wt_accel(n) * & - ((Cor_u(I,j) + PFu(I,j)) - ubt(I,j)*Rayleigh_u(I,j)) - enddo ; enddo - !$OMP end do nowait - else - !$OMP do schedule(static) - do j=jsv,jev ; do I=isv-1,iev - u_accel_bt(I,j) = u_accel_bt(I,j) + wt_accel(n) * (Cor_u(I,j) + PFu(I,j)) - enddo ; enddo - !$OMP end do nowait - endif + ! Copy decomposed barotropic accelerations to ADp + if (associated(ADp%bt_pgf_u)) then + ! Note that CS%IdxCu is 0 at OBC points, so ADp%bt_pgf_u is zeroed out there. + do k=1,nz ; do j=js,je ; do I=is-1,ie + ADp%bt_pgf_u(I,j,k) = PFu_avg(I,j) - & + (((pbce(i+1,j,k) - gtot_W(i+1,j)) * e_anom(i+1,j)) - & + ((pbce(i,j,k) - gtot_E(i,j)) * e_anom(i,j))) * CS%IdxCu(I,j) + enddo ; enddo ; enddo + endif + if (associated(ADp%bt_pgf_v)) then + ! Note that CS%IdyCv is 0 at OBC points, so ADp%bt_pgf_v is zeroed out there. + do k=1,nz ; do J=js-1,je ; do i=is,ie + ADp%bt_pgf_v(i,J,k) = PFv_avg(i,J) - & + (((pbce(i,j+1,k) - gtot_S(i,j+1)) * e_anom(i,j+1)) - & + ((pbce(i,j,k) - gtot_N(i,j)) * e_anom(i,j))) * CS%IdyCv(i,J) + enddo ; enddo ; enddo + endif - if (integral_BT_cont) then - !$OMP do schedule(static) - do j=jsv,jev ; do I=isv-1,iev - ubt_int(I,j) = ubt_int(I,j) + dtbt * ubt_trans(I,j) - uhbt_int(I,j) = find_uhbt(ubt_int(I,j), BTCL_u(I,j)) + n*dtbt*uhbt0(I,j) - ! Estimate the mass flux within a single timestep to take the filtered average. - uhbt(I,j) = (uhbt_int(I,j) - uhbt_int_prev(I,j)) * Idtbt - enddo ; enddo - elseif (use_BT_cont) then - !$OMP do schedule(static) - do j=jsv,jev ; do I=isv-1,iev - uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j)) + uhbt0(I,j) - enddo ; enddo - else - !$OMP do schedule(static) - do j=jsv,jev ; do I=isv-1,iev - uhbt(I,j) = Datu(I,j)*ubt_trans(I,j) + uhbt0(I,j) - enddo ; enddo - endif - if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. - !$OMP do schedule(static) - do j=jsv,jev ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then - ubt(I,j) = ubt_prev(I,j) ; uhbt(I,j) = uhbt_prev(I,j) - endif ; enddo ; enddo - endif - else - ! On even steps, update u first. - !$OMP do schedule(static) - do j=jsv-1,jev+1 ; do I=isv-1,iev - Cor_u(I,j) = ((azon(I,j) * vbt(i+1,J) + czon(I,j) * vbt(i,J-1)) + & - (bzon(I,j) * vbt(i,J) + dzon(I,j) * vbt(i+1,J-1))) - & - Cor_ref_u(I,j) - PFu(I,j) = ((eta_PF_BT(i,j)-eta_PF(i,j))*gtot_E(i,j) - & - (eta_PF_BT(i+1,j)-eta_PF(i+1,j))*gtot_W(i+1,j)) * & - dgeo_de * CS%IdxCu(I,j) - enddo ; enddo - !$OMP end do nowait + if (associated(ADp%bt_cor_u)) then ; do j=js,je ; do I=is-1,ie + ADp%bt_cor_u(I,j) = Coru_avg(I,j) + enddo ; enddo ; endif + if (associated(ADp%bt_cor_v)) then ; do J=js-1,je ; do i=is,ie + ADp%bt_cor_v(i,J) = Corv_avg(i,J) + enddo ; enddo ; endif - if (CS%dynamic_psurf) then - !$OMP do schedule(static) - do j=jsv-1,jev+1 ; do I=isv-1,iev - PFu(I,j) = PFu(I,j) + (p_surf_dyn(i,j) - p_surf_dyn(i+1,j)) * CS%IdxCu(I,j) - enddo ; enddo - !$OMP end do nowait - endif + if (associated(ADp%bt_lwd_u)) then ; do j=js,je ; do I=is-1,ie + ADp%bt_lwd_u(I,j) = LDu_avg(I,j) + enddo ; enddo ; endif + if (associated(ADp%bt_lwd_v)) then ; do J=js-1,je ; do i=is,ie + ADp%bt_lwd_v(i,J) = LDv_avg(i,J) + enddo ; enddo ; endif - if (CS%BT_OBC%apply_u_OBCs) then ! zero out pressure force across boundary - !$OMP do schedule(static) - do j=jsv,jev ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then - PFu(I,j) = 0.0 - endif ; enddo ; enddo - endif + if (CS%id_ubtforce > 0) call post_data(CS%id_ubtforce, BT_force_u(IsdB:IedB,jsd:jed), CS%diag) + if (CS%id_vbtforce > 0) call post_data(CS%id_vbtforce, BT_force_v(isd:ied,JsdB:JedB), CS%diag) + if (CS%id_uaccel > 0) call post_data(CS%id_uaccel, u_accel_bt(IsdB:IedB,jsd:jed), CS%diag) + if (CS%id_vaccel > 0) call post_data(CS%id_vaccel, v_accel_bt(isd:ied,JsdB:JedB), CS%diag) - !$OMP do schedule(static) - do j=jsv-1,jev+1 ; do I=isv-1,iev - vel_prev = ubt(I,j) - ubt(I,j) = bt_rem_u(I,j) * (ubt(I,j) + & - dtbt * ((BT_force_u(I,j) + Cor_u(I,j)) + PFu(I,j))) - if (abs(ubt(I,j)) < CS%vel_underflow) ubt(I,j) = 0.0 - ubt_trans(I,j) = trans_wt1*ubt(I,j) + trans_wt2*vel_prev - enddo ; enddo + if (CS%id_eta_cor > 0) call post_data(CS%id_eta_cor, CS%eta_cor, CS%diag) + if (CS%id_eta_bt > 0) call post_data(CS%id_eta_bt, eta_out, CS%diag) ! - G%Z_ref? + if (CS%id_gtotn > 0) call post_data(CS%id_gtotn, gtot_N(isd:ied,jsd:jed), CS%diag) + if (CS%id_gtots > 0) call post_data(CS%id_gtots, gtot_S(isd:ied,jsd:jed), CS%diag) + if (CS%id_gtote > 0) call post_data(CS%id_gtote, gtot_E(isd:ied,jsd:jed), CS%diag) + if (CS%id_gtotw > 0) call post_data(CS%id_gtotw, gtot_W(isd:ied,jsd:jed), CS%diag) + if (CS%id_ubt > 0) call post_data(CS%id_ubt, ubt_wtd(IsdB:IedB,jsd:jed), CS%diag) + if (CS%id_vbt > 0) call post_data(CS%id_vbt, vbt_wtd(isd:ied,JsdB:JedB), CS%diag) + if (CS%id_ubtav > 0) call post_data(CS%id_ubtav, CS%ubtav, CS%diag) + if (CS%id_vbtav > 0) call post_data(CS%id_vbtav, CS%vbtav, CS%diag) + if (CS%id_visc_rem_u > 0) call post_data(CS%id_visc_rem_u, visc_rem_u, CS%diag) + if (CS%id_visc_rem_v > 0) call post_data(CS%id_visc_rem_v, visc_rem_v, CS%diag) - if (CS%linear_wave_drag) then - !$OMP do schedule(static) - do j=jsv-1,jev+1 ; do I=isv-1,iev - u_accel_bt(I,j) = u_accel_bt(I,j) + wt_accel(n) * & - ((Cor_u(I,j) + PFu(I,j)) - ubt(I,j)*Rayleigh_u(I,j)) - enddo ; enddo - else - !$OMP do schedule(static) - do j=jsv-1,jev+1 ; do I=isv-1,iev - u_accel_bt(I,j) = u_accel_bt(I,j) + wt_accel(n) * (Cor_u(I,j) + PFu(I,j)) - enddo ; enddo - endif + if (CS%id_frhatu > 0) call post_data(CS%id_frhatu, CS%frhatu, CS%diag) + if (CS%id_uhbt > 0) call post_data(CS%id_uhbt, uhbtav, CS%diag) + if (CS%id_frhatv > 0) call post_data(CS%id_frhatv, CS%frhatv, CS%diag) + if (CS%id_vhbt > 0) call post_data(CS%id_vhbt, vhbtav, CS%diag) + if (CS%id_uhbt0 > 0) call post_data(CS%id_uhbt0, uhbt0(IsdB:IedB,jsd:jed), CS%diag) + if (CS%id_vhbt0 > 0) call post_data(CS%id_vhbt0, vhbt0(isd:ied,JsdB:JedB), CS%diag) - if (integral_BT_cont) then - !$OMP do schedule(static) - do j=jsv-1,jev+1 ; do I=isv-1,iev - ubt_int(I,j) = ubt_int(I,j) + dtbt * ubt_trans(I,j) - uhbt_int(I,j) = find_uhbt(ubt_int(I,j), BTCL_u(I,j)) + n*dtbt*uhbt0(I,j) - ! Estimate the mass flux within a single timestep to take the filtered average. - uhbt(I,j) = (uhbt_int(I,j) - uhbt_int_prev(I,j)) * Idtbt - enddo ; enddo - elseif (use_BT_cont) then - !$OMP do schedule(static) - do j=jsv-1,jev+1 ; do I=isv-1,iev - uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j)) + uhbt0(I,j) - enddo ; enddo - !$OMP end do nowait - else - !$OMP do schedule(static) - do j=jsv-1,jev+1 ; do I=isv-1,iev - uhbt(I,j) = Datu(I,j)*ubt_trans(I,j) + uhbt0(I,j) - enddo ; enddo - !$OMP end do nowait - endif - if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. - !$OMP do schedule(static) - do j=jsv-1,jev+1 ; do I=isv-1,iev ; if (OBC%segnum_u(I,j) /= OBC_NONE) then - ubt(I,j) = ubt_prev(I,j) ; uhbt(I,j) = uhbt_prev(I,j) - endif ; enddo ; enddo - endif + if (CS%id_frhatu1 > 0) call post_data(CS%id_frhatu1, CS%frhatu1, CS%diag) + if (CS%id_frhatv1 > 0) call post_data(CS%id_frhatv1, CS%frhatv1, CS%diag) - ! Now update the meridional velocity. - if (CS%use_old_coriolis_bracket_bug) then - !$OMP do schedule(static) - do J=jsv-1,jev ; do i=isv,iev - Cor_v(i,J) = -1.0*((amer(I-1,j) * ubt(I-1,j) + bmer(I,j) * ubt(I,j)) + & - (cmer(I,j+1) * ubt(I,j+1) + dmer(I-1,j+1) * ubt(I-1,j+1))) - Cor_ref_v(i,J) - PFv(i,J) = ((eta_PF_BT(i,j)-eta_PF(i,j))*gtot_N(i,j) - & - (eta_PF_BT(i,j+1)-eta_PF(i,j+1))*gtot_S(i,j+1)) * & - dgeo_de * CS%IdyCv(i,J) - enddo ; enddo - !$OMP end do nowait - else - !$OMP do schedule(static) - do J=jsv-1,jev ; do i=isv,iev - Cor_v(i,J) = -1.0*((amer(I-1,j) * ubt(I-1,j) + cmer(I,j+1) * ubt(I,j+1)) + & - (bmer(I,j) * ubt(I,j) + dmer(I-1,j+1) * ubt(I-1,j+1))) - Cor_ref_v(i,J) - PFv(i,J) = ((eta_PF_BT(i,j)-eta_PF(i,j))*gtot_N(i,j) - & - (eta_PF_BT(i,j+1)-eta_PF(i,j+1))*gtot_S(i,j+1)) * & - dgeo_de * CS%IdyCv(i,J) - enddo ; enddo - !$OMP end do nowait - endif + if (CS%id_bt_rem_u > 0) call post_data(CS%id_bt_rem_u, bt_rem_u(IsdB:IedB,jsd:jed), CS%diag) + if (CS%id_bt_rem_v > 0) call post_data(CS%id_bt_rem_v, bt_rem_v(isd:ied,JsdB:JedB), CS%diag) + if (CS%id_etaPF_anom > 0) call post_data(CS%id_etaPF_anom, e_anom(isd:ied,jsd:jed), CS%diag) - if (CS%dynamic_psurf) then - !$OMP do schedule(static) - do J=jsv-1,jev ; do i=isv,iev - PFv(i,J) = PFv(i,J) + (p_surf_dyn(i,j) - p_surf_dyn(i,j+1)) * CS%IdyCv(i,J) + if (use_BT_cont) then + if (CS%id_BTC_FA_u_EE > 0) call post_data(CS%id_BTC_FA_u_EE, BT_cont%FA_u_EE, CS%diag) + if (CS%id_BTC_FA_u_E0 > 0) call post_data(CS%id_BTC_FA_u_E0, BT_cont%FA_u_E0, CS%diag) + if (CS%id_BTC_FA_u_W0 > 0) call post_data(CS%id_BTC_FA_u_W0, BT_cont%FA_u_W0, CS%diag) + if (CS%id_BTC_FA_u_WW > 0) call post_data(CS%id_BTC_FA_u_WW, BT_cont%FA_u_WW, CS%diag) + if (CS%id_BTC_uBT_EE > 0) call post_data(CS%id_BTC_uBT_EE, BT_cont%uBT_EE, CS%diag) + if (CS%id_BTC_uBT_WW > 0) call post_data(CS%id_BTC_uBT_WW, BT_cont%uBT_WW, CS%diag) + if (CS%id_BTC_FA_u_rat0 > 0) then + tmp_u(:,:) = 0.0 + do j=js,je ; do I=is-1,ie + if ((G%mask2dCu(I,j) > 0.0) .and. (BT_cont%FA_u_W0(I,j) > 0.0)) then + tmp_u(I,j) = (BT_cont%FA_u_E0(I,j)/ BT_cont%FA_u_W0(I,j)) + else + tmp_u(I,j) = 1.0 + endif enddo ; enddo - !$OMP end do nowait - endif - - if (CS%BT_OBC%apply_v_OBCs) then ! zero out PF across boundary - !$OMP do schedule(static) - do J=jsv-1,jev ; do i=isv-1,iev+1 ; if (OBC%segnum_v(i,J) /= OBC_NONE) then - PFv(i,J) = 0.0 - endif ; enddo ; enddo + call post_data(CS%id_BTC_FA_u_rat0, tmp_u, CS%diag) endif - - !$OMP do schedule(static) - do J=jsv-1,jev ; do i=isv,iev - vel_prev = vbt(i,J) - vbt(i,J) = bt_rem_v(i,J) * (vbt(i,J) + & - dtbt * ((BT_force_v(i,J) + Cor_v(i,J)) + PFv(i,J))) - if (abs(vbt(i,J)) < CS%vel_underflow) vbt(i,J) = 0.0 - vbt_trans(i,J) = trans_wt1*vbt(i,J) + trans_wt2*vel_prev - enddo ; enddo - !$OMP end do nowait - - if (CS%linear_wave_drag) then - !$OMP do schedule(static) - do J=jsv-1,jev ; do i=isv,iev - v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * & - ((Cor_v(i,J) + PFv(i,J)) - vbt(i,J)*Rayleigh_v(i,J)) - enddo ; enddo - !$OMP end do nowait - else - !$OMP do schedule(static) - do J=jsv-1,jev ; do i=isv,iev - v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel(n) * (Cor_v(i,J) + PFv(i,J)) + if (CS%id_BTC_FA_v_NN > 0) call post_data(CS%id_BTC_FA_v_NN, BT_cont%FA_v_NN, CS%diag) + if (CS%id_BTC_FA_v_N0 > 0) call post_data(CS%id_BTC_FA_v_N0, BT_cont%FA_v_N0, CS%diag) + if (CS%id_BTC_FA_v_S0 > 0) call post_data(CS%id_BTC_FA_v_S0, BT_cont%FA_v_S0, CS%diag) + if (CS%id_BTC_FA_v_SS > 0) call post_data(CS%id_BTC_FA_v_SS, BT_cont%FA_v_SS, CS%diag) + if (CS%id_BTC_vBT_NN > 0) call post_data(CS%id_BTC_vBT_NN, BT_cont%vBT_NN, CS%diag) + if (CS%id_BTC_vBT_SS > 0) call post_data(CS%id_BTC_vBT_SS, BT_cont%vBT_SS, CS%diag) + if (CS%id_BTC_FA_v_rat0 > 0) then + tmp_v(:,:) = 0.0 + do J=js-1,je ; do i=is,ie + if ((G%mask2dCv(i,J) > 0.0) .and. (BT_cont%FA_v_S0(i,J) > 0.0)) then + tmp_v(i,J) = (BT_cont%FA_v_N0(i,J)/ BT_cont%FA_v_S0(i,J)) + else + tmp_v(i,J) = 1.0 + endif enddo ; enddo - !$OMP end do nowait + call post_data(CS%id_BTC_FA_v_rat0, tmp_v, CS%diag) endif - - if (integral_BT_cont) then - !$OMP do schedule(static) - do J=jsv-1,jev ; do i=isv,iev - vbt_int(i,J) = vbt_int(i,J) + dtbt * vbt_trans(i,J) - vhbt_int(i,J) = find_vhbt(vbt_int(i,J), BTCL_v(i,J)) + n*dtbt*vhbt0(i,J) - ! Estimate the mass flux within a single timestep to take the filtered average. - vhbt(i,J) = (vhbt_int(i,J) - vhbt_int_prev(i,J)) * Idtbt - enddo ; enddo - elseif (use_BT_cont) then - !$OMP do schedule(static) - do J=jsv-1,jev ; do i=isv,iev - vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J)) + vhbt0(i,J) - enddo ; enddo - else - !$OMP do schedule(static) - do J=jsv-1,jev ; do i=isv,iev - vhbt(i,J) = Datv(i,J)*vbt_trans(i,J) + vhbt0(i,J) + if (CS%id_BTC_FA_h_rat0 > 0) then + tmp_h(:,:) = 0.0 + do j=js,je ; do i=is,ie + tmp_h(i,j) = 1.0 + if ((G%mask2dCu(I,j) > 0.0) .and. (BT_cont%FA_u_W0(I,j) > 0.0) .and. (BT_cont%FA_u_E0(I,j) > 0.0)) then + if (BT_cont%FA_u_W0(I,j) > BT_cont%FA_u_E0(I,j)) then + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_W0(I,j)/ BT_cont%FA_u_E0(I,j))) + else + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_E0(I,j)/ BT_cont%FA_u_W0(I,j))) + endif + endif + if ((G%mask2dCu(I-1,j) > 0.0) .and. (BT_cont%FA_u_W0(I-1,j) > 0.0) .and. (BT_cont%FA_u_E0(I-1,j) > 0.0)) then + if (BT_cont%FA_u_W0(I-1,j) > BT_cont%FA_u_E0(I-1,j)) then + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_W0(I-1,j)/ BT_cont%FA_u_E0(I-1,j))) + else + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_E0(I-1,j)/ BT_cont%FA_u_W0(I-1,j))) + endif + endif + if ((G%mask2dCv(i,J) > 0.0) .and. (BT_cont%FA_v_S0(i,J) > 0.0) .and. (BT_cont%FA_v_N0(i,J) > 0.0)) then + if (BT_cont%FA_v_S0(i,J) > BT_cont%FA_v_N0(i,J)) then + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_S0(i,J)/ BT_cont%FA_v_N0(i,J))) + else + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_N0(i,J)/ BT_cont%FA_v_S0(i,J))) + endif + endif + if ((G%mask2dCv(i,J-1) > 0.0) .and. (BT_cont%FA_v_S0(i,J-1) > 0.0) .and. (BT_cont%FA_v_N0(i,J-1) > 0.0)) then + if (BT_cont%FA_v_S0(i,J-1) > BT_cont%FA_v_N0(i,J-1)) then + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_S0(i,J-1)/ BT_cont%FA_v_N0(i,J-1))) + else + tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_N0(i,J-1)/ BT_cont%FA_v_S0(i,J-1))) + endif + endif enddo ; enddo - endif - if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. - !$OMP do schedule(static) - do J=jsv-1,jev ; do i=isv,iev ; if (OBC%segnum_v(i,J) /= OBC_NONE) then - vbt(i,J) = vbt_prev(i,J); vhbt(i,J) = vhbt_prev(i,J) - endif ; enddo ; enddo + call post_data(CS%id_BTC_FA_h_rat0, tmp_h, CS%diag) endif endif - ! This might need to be moved outside of the OMP do loop directives. - if (CS%debug_bt) then - write(mesg,'("BT vel update ",I4)') n - call uvchksum(trim(mesg)//" PF[uv]", PFu, PFv, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%L_T_to_m_s*US%s_to_T) - call uvchksum(trim(mesg)//" Cor_[uv]", Cor_u, Cor_v, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%L_T_to_m_s*US%s_to_T) - call uvchksum(trim(mesg)//" BT_force_[uv]", BT_force_u, BT_force_v, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%L_T_to_m_s*US%s_to_T) - call uvchksum(trim(mesg)//" BT_rem_[uv]", BT_rem_u, BT_rem_v, CS%debug_BT_HI, & - haloshift=iev-ie, scalar_pair=.true.) - call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%L_T_to_m_s) - call uvchksum(trim(mesg)//" [uv]bt_trans", ubt_trans, vbt_trans, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%L_T_to_m_s) - call uvchksum(trim(mesg)//" [uv]hbt", uhbt, vhbt, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%s_to_T*US%L_to_m**2*GV%H_to_m) - if (integral_BT_cont) & - call uvchksum(trim(mesg)//" [uv]hbt_int", uhbt_int, vhbt_int, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%L_to_m**2*GV%H_to_m) - endif + if (CS%id_SSH_u_OBC > 0) call post_data(CS%id_SSH_u_OBC, CS%BT_OBC%SSH_outer_u(IsdB:IedB,jsd:jed), CS%diag) + if (CS%id_SSH_v_OBC > 0) call post_data(CS%id_SSH_v_OBC, CS%BT_OBC%SSH_outer_v(isd:ied,JsdB:JedB), CS%diag) + if (CS%id_ubt_OBC > 0) call post_data(CS%id_ubt_OBC, CS%BT_OBC%ubt_outer(IsdB:IedB,jsd:jed), CS%diag) + if (CS%id_vbt_OBC > 0) call post_data(CS%id_vbt_OBC, CS%BT_OBC%vbt_outer(isd:ied,JsdB:JedB), CS%diag) + else + if (CS%id_frhatu1 > 0) CS%frhatu1(:,:,:) = CS%frhatu(:,:,:) + if (CS%id_frhatv1 > 0) CS%frhatv1(:,:,:) = CS%frhatv(:,:,:) + endif - if (find_PF) then - !$OMP do - do j=js,je ; do I=is-1,ie - PFu_bt_sum(I,j) = PFu_bt_sum(I,j) + wt_accel2(n) * PFu(I,j) - enddo ; enddo - !$OMP end do nowait - !$OMP do - do J=js-1,je ; do i=is,ie - PFv_bt_sum(i,J) = PFv_bt_sum(i,J) + wt_accel2(n) * PFv(i,J) - enddo ; enddo - !$OMP end do nowait - endif - if (find_Cor) then - !$OMP do - do j=js,je ; do I=is-1,ie - Coru_bt_sum(I,j) = Coru_bt_sum(I,j) + wt_accel2(n) * Cor_u(I,j) - enddo ; enddo - !$OMP end do nowait - !$OMP do - do J=js-1,je ; do i=is,ie - Corv_bt_sum(i,J) = Corv_bt_sum(i,J) + wt_accel2(n) * Cor_v(i,J) - enddo ; enddo - !$OMP end do nowait - endif + if (associated(ADp%diag_hfrac_u)) then + do k=1,nz ; do j=js,je ; do I=is-1,ie + ADp%diag_hfrac_u(I,j,k) = CS%frhatu(I,j,k) + enddo ; enddo ; enddo + endif + if (associated(ADp%diag_hfrac_v)) then + do k=1,nz ; do J=js-1,je ; do i=is,ie + ADp%diag_hfrac_v(i,J,k) = CS%frhatv(i,J,k) + enddo ; enddo ; enddo + endif - !$OMP do - do j=js,je ; do I=is-1,ie - ubt_sum(I,j) = ubt_sum(I,j) + wt_trans(n) * ubt_trans(I,j) - uhbt_sum(I,j) = uhbt_sum(I,j) + wt_trans(n) * uhbt(I,j) - ubt_wtd(I,j) = ubt_wtd(I,j) + wt_vel(n) * ubt(I,j) - enddo ; enddo - !$OMP end do nowait - !$OMP do - do J=js-1,je ; do i=is,ie - vbt_sum(i,J) = vbt_sum(i,J) + wt_trans(n) * vbt_trans(i,J) - vhbt_sum(i,J) = vhbt_sum(i,J) + wt_trans(n) * vhbt(i,J) - vbt_wtd(i,J) = vbt_wtd(i,J) + wt_vel(n) * vbt(i,J) - enddo ; enddo - !$OMP end do nowait + if (use_BT_cont .and. associated(ADp%diag_hu)) then + do k=1,nz ; do j=js,je ; do I=is-1,ie + ADp%diag_hu(I,j,k) = BT_cont%h_u(I,j,k) + enddo ; enddo ; enddo + endif + if (use_BT_cont .and. associated(ADp%diag_hv)) then + do k=1,nz ; do J=js-1,je ; do i=is,ie + ADp%diag_hv(i,J,k) = BT_cont%h_v(i,J,k) + enddo ; enddo ; enddo + endif + if (associated(ADp%visc_rem_u)) then + do k=1,nz ; do j=js,je ; do I=is-1,ie + ADp%visc_rem_u(I,j,k) = visc_rem_u(I,j,k) + enddo ; enddo ; enddo + endif + if (associated(ADp%visc_rem_v)) then + do k=1,nz ; do J=js-1,je ; do i=is,ie + ADp%visc_rem_v(i,J,k) = visc_rem_v(i,J,k) + enddo ; enddo ; enddo + endif - if (apply_OBCs) then + if (G%nonblocking_updates) then + if (find_etaav) call complete_group_pass(CS%pass_etaav, G%Domain) + call complete_group_pass(CS%pass_ubta_uhbta, G%Domain) + endif - !$OMP single - call apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, & - ubt_trans, vbt_trans, eta, ubt_old, vbt_old, CS%BT_OBC, & - G, MS, US, iev-ie, dtbt, bebt, use_BT_cont, integral_BT_cont, & - n*dtbt, Datu, Datv, BTCL_u, BTCL_v, uhbt0, vhbt0, & - ubt_int_prev, vbt_int_prev, uhbt_int_prev, vhbt_int_prev) - !$OMP end single + deallocate(wt_vel, wt_eta, wt_trans, wt_accel, wt_accel2) - if (CS%BT_OBC%apply_u_OBCs) then - !$OMP do - do j=js,je ; do I=is-1,ie - if (OBC%segnum_u(I,j) /= OBC_NONE) then - ! Update the summed and integrated quantities from the saved previous values. - ubt_sum(I,j) = ubt_sum_prev(I,j) + wt_trans(n) * ubt_trans(I,j) - uhbt_sum(I,j) = uhbt_sum_prev(I,j) + wt_trans(n) * uhbt(I,j) - ubt_wtd(I,j) = ubt_wtd_prev(I,j) + wt_vel(n) * ubt(I,j) - if (integral_BT_cont) then - uhbt_int(I,j) = uhbt_int_prev(I,j) + dtbt * uhbt(I,j) - ubt_int(I,j) = ubt_int_prev(I,j) + dtbt * ubt_trans(I,j) - endif - endif - enddo ; enddo - endif - if (CS%BT_OBC%apply_v_OBCs) then - !$OMP do - do J=js-1,je ; do i=is,ie - if (OBC%segnum_v(i,J) /= OBC_NONE) then - ! Update the summed and integrated quantities from the saved previous values. - vbt_sum(i,J) = vbt_sum_prev(i,J) + wt_trans(n) * vbt_trans(i,J) - vhbt_sum(i,J) = vhbt_sum_prev(i,J) + wt_trans(n) * vhbt(i,J) - vbt_wtd(i,J) = vbt_wtd_prev(i,J) + wt_vel(n) * vbt(i,J) - if (integral_BT_cont) then - vbt_int(i,J) = vbt_int_prev(i,J) + dtbt * vbt_trans(i,J) - vhbt_int(i,J) = vhbt_int_prev(i,J) + dtbt * vhbt(i,J) - endif - endif - enddo ; enddo - endif - endif +end subroutine btstep - if (CS%debug_bt) then - call uvchksum("BT [uv]hbt just after OBC", uhbt, vhbt, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%s_to_T*US%L_to_m**2*GV%H_to_m) - if (integral_BT_cont) & - call uvchksum("BT [uv]hbt_int just after OBC", uhbt_int, vhbt_int, CS%debug_BT_HI, & - haloshift=iev-ie, scale=US%L_to_m**2*GV%H_to_m) - endif +!> Update the barotropic solver through multiple time steps. +subroutine btstep_timeloop(eta, ubt, vbt, uhbt0, Datu, BTCL_u, vhbt0, Datv, BTCL_v, eta_IC, & + eta_PF_1, d_eta_PF, eta_src, dyn_coef_eta, uhbtav, vhbtav, u_accel_bt, v_accel_bt, & + f_4_u, f_4_v, bt_rem_u, bt_rem_v, & + BT_force_u, BT_force_v, Cor_ref_u, Cor_ref_v, Rayleigh_u, Rayleigh_v, & + eta_PF, gtot_E, gtot_W, gtot_N, gtot_S, SpV_col_avg, dgeo_de, & + eta_sum, eta_wtd, ubt_wtd, vbt_wtd, Coru_avg, PFu_avg, LDu_avg, Corv_avg, PFv_avg, & + LDv_avg, use_BT_cont, interp_eta_PF, find_etaav, dt, dtbt, nstep, nfilter, & + wt_vel, wt_eta, wt_accel, wt_trans, wt_accel2, ADp, BT_OBC, CS, G, MS, GV, US) + + type(barotropic_CS), intent(inout) :: CS !< Barotropic control structure + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure (inout to allow for halo updates) + type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of + !! the argument arrays. + real, dimension(SZIW_(CS),SZJW_(CS)), target, intent(inout) :: & + eta !< The barotropic free surface height anomaly or column mass anomaly [H ~> m or kg m-2] + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(inout) :: & + ubt !< The zonal barotropic velocity [L T-1 ~> m s-1] + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(inout) :: & + vbt !< The meridional barotropic velocity [L T-1 ~> m s-1] + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: & + uhbt0 !< The difference between the sum of the layer zonal thickness flux and the + !! barotropic thickness flux using the same velocity [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(inout) :: & + Datu !< Basin depth at u-velocity grid points times the y-grid spacing [H L ~> m2 or kg m-1] + type(local_BT_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: & + BTCL_u !< Structure of information used for a dynamic estimate of the face areas at u-points. + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: & + vhbt0 !< The difference between the sum of the layer meridional thickness flux and the + !! barotropic thickness flux using the same velocity [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(inout) :: & + Datv !< Basin depth at v-velocity grid points times the x-grid spacing [H L ~> m2 or kg m-1] + type(local_BT_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: & + BTCL_v !< Structure of information used for a dynamic estimate of the face areas at v-points + real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: & + eta_IC !< A local copy of the initial 2-D eta field (eta_in) [H ~> m or kg m-2] + real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: & + eta_PF_1 !< The initial value of eta_PF, when interp_eta_PF is true [H ~> m or kg m-2] + real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: & + d_eta_PF !< The change in eta_PF over the barotropic time stepping when + !! interp_eta_PF is true [H ~> m or kg m-2] + real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: & + eta_src !< The source of eta per barotropic timestep [H ~> m or kg m-2] + real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: & + dyn_coef_eta !< The coefficient relating the changes in eta to the dynamic surface pressure + !! under rigid ice [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. + real, dimension(SZIB_(G),SZJ_(G)), intent(out) :: & + uhbtav !< the barotropic zonal volume or mass fluxes averaged through the barotropic + !! steps [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G)), intent(out) :: & + vhbtav !< the barotropic meridional volume or mass fluxes averaged through the barotropic + !! steps [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(inout) :: & + u_accel_bt !! The difference between the zonal acceleration from the + !< barotropic calculation and BT_force_v [L T-2 ~> m s-2]. + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(inout) :: & + v_accel_bt !< The difference between the meridional acceleration from the + !! barotropic calculation and BT_force_v [L T-2 ~> m s-2]. + real, dimension(4,SZIBW_(CS),SZJW_(CS)), intent(inout) :: & + f_4_u !< The terms giving the contribution to the Coriolis acceleration at a zonal + !! velocity point from the neighboring meridional velocity anomalies [T-1 ~> s-1]. + !! These are the products of thicknesses at v points and appropriately staggered + !! averaged pseudo potential vorticities, but with sufficiently smooth topography + !! they are approximately f / 4. The 4 values on the innermost loop are for + !! v-velocities to the southwest, southeast, northwest and northeast. + real, dimension(4,SZIW_(CS),SZJBW_(CS)), intent(in) :: & + f_4_v !< The terms giving the contribution to the Coriolis acceleration at a meridional + !! velocity point from the neighboring meridional velocity anomalies [T-1 ~> s-1]. + !! These are the products of thicknesses at u points and appropriately staggered + !! averaged pseudo potential vorticities, but with sufficiently smooth topography + !! they are approximately f / 4. The 4 values on the innermost loop are for + !! u-velocities to the southwest, southeast, northwest and northeast. + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: & + bt_rem_u !< The fraction of the barotropic zonal velocity that remains after a time step, + !! the rest being lost to bottom drag [nondim]. bt_rem_v is between 0 and 1. + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: & + bt_rem_v !< The fraction of the barotropic meridional velocity that remains after a time step, + !! the rest being lost to bottom drag [nondim]. bt_rem_v is between 0 and 1. + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: & + BT_force_u !< The vertical average of all of the v-accelerations that are + !! not explicitly included in the barotropic equation [L T-2 ~> m s-2] + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: & + BT_force_v !< The vertical average of all of the v-accelerations that are + !! not explicitly included in the barotropic equation [L T-2 ~> m s-2] + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: & + Cor_ref_u !< The meridional barotropic Coriolis acceleration due + !! to the reference velocities [L T-2 ~> m s-2]. + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: & + Cor_ref_v !< The meridional barotropic Coriolis acceleration due + !! to the reference velocities [L T-2 ~> m s-2]. + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: & + Rayleigh_u !< A Rayleigh drag timescale operating at u-points for drag parameterizations + !! that introduced directly into the barotropic solver rather than coming + !! in via the visc_rem_u arrays from the layered equations [T-1 ~> s-1] + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: & + Rayleigh_v !< A Rayleigh drag timescale operating at v-points for drag parameterizations + !! that introduced directly into the barotropic solver rather than coming + !! in via the visc_rem_v arrays from the layered equations [T-1 ~> s-1] + real, dimension(SZIW_(CS),SZJW_(CS)), intent(inout) :: & + eta_PF !< The 2-D eta field (either SSH anomaly or column mass anomaly) that was used to + !! calculate the input pressure gradient accelerations [H ~> m or kg m-2] + real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: & + gtot_E !< The effective total reduced gravity used to relate free surface height + !! deviations to pressure forces (including GFS and baroclinic contributions) + !! in the barotropic momentum equations half a grid-point to the east of a + !! thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: & + gtot_W !< The effective total reduced gravity used to relate free surface height + !! deviations to pressure forces (including GFS and baroclinic contributions) + !! in the barotropic momentum equations half a grid-point to the west of a + !! thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2] + !! (See Hallberg, J Comp Phys 1997 for a discussion of gtot_E and gtot_W.) + real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: & + gtot_N !< The effective total reduced gravity used to relate free surface height + !! deviations to pressure forces (including GFS and baroclinic contributions) + !! in the barotropic momentum equations half a grid-point to the north of a + !! thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2] + real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: & + gtot_S !< The effective total reduced gravity used to relate free surface height + !! deviations to pressure forces (including GFS and baroclinic contributions) + !! in the barotropic momentum equations half a grid-point to the south of a + !! thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2] + !! (See Hallberg, J Comp Phys 1997 for a discussion of gtot_E and gtot_W.) + real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: & + SpV_col_avg !< The column average specific volume [R-1 ~> m3 kg-1] + real, intent(in) :: dgeo_de !< The constant of proportionality between geopotential and + !! sea surface height [nondim]. It is of order 1, but for stability this + !! may be made larger than the physical problem would suggest. + real, dimension(SZIW_(CS),SZJW_(CS)), intent(out) :: & + eta_sum !< eta summed across the timesteps [H ~> m or kg m-2] + real, dimension(SZIW_(CS),SZJW_(CS)), intent(out) :: & + eta_wtd !< A weighted estimate used to calculate eta_out [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G)), intent(out) :: & + ubt_wtd !< A weighted sum used to find the filtered final ubt [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G)), intent(out) :: & + vbt_wtd !< A weighted sum used to find the filtered final vbt [L T-1 ~> m s-1] + real, dimension(SZIB_(G),SZJ_(G)), intent(out) :: & + Coru_avg !< The average zonal barotropic Coriolis acceleration [L T-2 ~> m s-2] + real, dimension(SZIB_(G),SZJ_(G)), intent(out) :: & + PFu_avg !< The average zonal barotropic pressure gradient force [L T-2 ~> m s-2] + real, dimension(SZIB_(G),SZJ_(G)), intent(out) :: & + LDu_avg !< The average zonal barotropic linear wave drag acceleration [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G)), intent(out) :: & + Corv_avg !< The average meridional barotropic Coriolis acceleration [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G)), intent(out) :: & + PFv_avg !< The average meridional barotropic pressure gradient force [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G)), intent(out) :: & + LDv_avg !< The average meridional barotropic linear wave drag acceleration [L T-2 ~> m s-2] + logical, intent(in) :: use_BT_cont !< If true, use the information in the bt_cont_types to + !! calculate the mass transports + logical, intent(in) :: interp_eta_PF !< If true, interpolate the reference value of eta used + !! to calculate the pressure force with time. + logical, intent(in) :: find_etaav !< If true, diagnose the time mean value of eta + real, intent(in) :: dt !< The time increment to integrate over [T ~> s] + real, intent(in) :: dtbt !< The barotropic time step [T ~> s] + integer, intent(in) :: nstep !< The number of barotropic time steps to take to cover the specified time interval + integer, intent(in) :: nfilter !< The number of extra barotropic steps to take to allow for time filtering + real, dimension(nstep+nfilter), intent(in) :: & + wt_vel !< The raw or relative weights of each of the barotropic timesteps + !! in determining the average velocities [nondim] + real, dimension(nstep+nfilter), intent(in) :: & + wt_eta !< The raw or relative weights of each of the barotropic timesteps + !! in determining the average eta [nondim] + real, dimension(nstep+nfilter+1), intent(in) :: & + wt_accel !< The raw or relative weights of each of the barotropic timesteps + !! in determining the average accelerations [nondim] + real, dimension(nstep+nfilter+1), intent(in) :: & + wt_trans !< The raw or relative weights of each of the barotropic timesteps + !! in determining the average transports [nondim] + real, dimension(nstep+nfilter+1), intent(in) :: & + wt_accel2 !< Potentially un-normalized relative weights of each of the + !! barotropic timesteps in determining the average accelerations [nondim] + type(accel_diag_ptrs), pointer :: ADp !< Acceleration diagnostic pointers + type(BT_OBC_type), intent(in) :: BT_OBC !< A structure with the private barotropic arrays + !! related to the open boundary conditions, + !! with time evolving data stored via set_up_BT_OBC + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - if (integral_BT_cont) then - !$OMP do - do j=jsv,jev ; do i=isv,iev - eta(i,j) = (eta_IC(i,j) + n*eta_src(i,j)) + CS%IareaT(i,j) * & - ((uhbt_int(I-1,j) - uhbt_int(I,j)) + (vhbt_int(i,J-1) - vhbt_int(i,J))) - eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n) - enddo ; enddo - else - !$OMP do - do j=jsv,jev ; do i=isv,iev - eta(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * CS%IareaT(i,j)) * & - ((uhbt(I-1,j) - uhbt(I,j)) + (vhbt(i,J-1) - vhbt(i,J))) - eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n) - enddo ; enddo - endif - !$OMP end parallel + ! Local variables + real, dimension(SZIBW_(CS),SZJW_(CS)) :: & + uhbt, & ! The zonal barotropic thickness fluxes [H L2 T-1 ~> m3 s-1 or kg s-1] + ubt_prev, & ! The starting value of ubt in a barotropic step [L T-1 ~> m s-1] + ubt_trans, & ! The latest value of ubt used for a transport [L T-1 ~> m s-1] + PFu, & ! The zonal pressure force acceleration [L T-2 ~> m s-2] + Cor_u, & ! The zonal Coriolis acceleration [L T-2 ~> m s-2] + ubt_int, & ! The running time integral of ubt over the time steps [L ~> m] + uhbt_int, & ! The running time integral of uhbt over the time steps [H L2 ~> m3 or kg] + ubt_int_prev, & ! Previous value of time-integrated velocity stored for OBCs [L ~> m] + uhbt_int_prev ! Previous value of time-integrated transport stored for integral_BT_cont [H L2 ~> m3 or kg] + real, dimension(SZIW_(CS),SZJBW_(CS)) :: & + vhbt, & ! The meridional barotropic thickness fluxes [H L2 T-1 ~> m3 s-1 or kg s-1] + vbt_prev, & ! The starting value of vbt in a barotropic step [L T-1 ~> m s-1] + vbt_trans, & ! The latest value of vbt used for a transport [L T-1 ~> m s-1] + PFv, & ! The meridional pressure force acceleration [L T-2 ~> m s-2] + Cor_v, & ! The meridional Coriolis acceleration [L T-2 ~> m s-2] + vbt_int, & ! The running time integral of vbt over the time steps [L ~> m] + vhbt_int, & ! The running time integral of vhbt over the time steps [H L2 ~> m3 or kg] + vbt_int_prev, & ! Previous value of time-integrated velocity stored for OBCs [L ~> m] + vhbt_int_prev ! Previous value of time-integrated transport stored for integral_BT_cont [H L2 ~> m3 or kg] + real, target, dimension(SZIW_(CS),SZJW_(CS)) :: & + eta_pred ! A predictor value of eta [H ~> m or kg m-2] like eta + real, dimension(SZIW_(CS),SZJW_(CS)) :: & + p_surf_dyn, & !< A dynamic surface pressure under rigid ice [L2 T-2 ~> m2 s-2] + cfl_ltd_vol !< The volume available after removing sinks used to limit uhbt_int and vhbt_int [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJ_(G)) :: & + eta_anom_PF ! The eta anomalies used to find the pressure force anomalies [H ~> m or kg m-2] + real :: wt_end ! The weighting of the final value of eta_PF [nondim] + real :: Instep ! The inverse of the number of barotropic time steps to take [nondim] + real :: trans_wt1, trans_wt2 ! The weights used to compute ubt_trans and vbt_trans [nondim] + real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1] + type(time_type) :: & + time_bt_start, & ! The starting time of the barotropic steps. + time_step_end, & ! The end time of a barotropic step. + time_end_in ! The end time for diagnostics when this routine started. + real :: dtbt_diag ! The nominal barotropic time step used in hifreq diagnostics [T ~> s] + ! dtbt_diag = dt/(nstep+nfilter) + real :: time_int_in ! The diagnostics' time interval when this routine started [s] + real :: be_proj ! The fractional amount by which velocities are projected + ! when project_velocity is true [nondim]. For now be_proj is set + ! to equal bebt, as they have similar roles and meanings. + real :: eta_cor_multiplier ! Increases the rate of applying CS%eta_cor so that the mass + ! source is all used up by the beginning of the filtering [nondim] + real :: eta_acc ! Change due to divergence of mass transport [H ~> m or kg m-2] + logical :: do_hifreq_output ! If true, output occurs every barotropic step. + logical :: do_ave ! If true, diagnostics are enabled on this step. + logical :: evolving_face_areas + logical :: v_first ! If true, update the v-velocity first with the present loop iteration + logical :: integral_BT_cont ! If true, update the barotropic continuity equation directly + ! from the initial condition using the time-integrated barotropic velocity. + character(len=200) :: mesg + integer :: isv, iev, jsv, jev ! The valid array size at the end of a step. + integer :: isvf, ievf, jsvf, jevf ! The fullest range of array indices that could be used. + integer :: num_cycles ! The number of timesteps before a halo update is needed. + integer :: stencil ! The stencil size of the algorithm, often 1 or 2. + integer :: err_count ! A counter to limit the volume of error messages written to stdout. + integer :: i, j, n, is, ie, js, je + integer :: debug_halo ! The halo size to use for debugging checksums + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - if (do_hifreq_output) then - time_step_end = time_bt_start + real_to_time(n*US%T_to_s*dtbt) - call enable_averaging(US%T_to_s*dtbt, time_step_end, CS%diag) - if (CS%id_ubt_hifreq > 0) call post_data(CS%id_ubt_hifreq, ubt(IsdB:IedB,jsd:jed), CS%diag) - if (CS%id_vbt_hifreq > 0) call post_data(CS%id_vbt_hifreq, vbt(isd:ied,JsdB:JedB), CS%diag) - if (CS%id_eta_hifreq > 0) call post_data(CS%id_eta_hifreq, eta(isd:ied,jsd:jed), CS%diag) - if (CS%id_uhbt_hifreq > 0) call post_data(CS%id_uhbt_hifreq, uhbt(IsdB:IedB,jsd:jed), CS%diag) - if (CS%id_vhbt_hifreq > 0) call post_data(CS%id_vhbt_hifreq, vhbt(isd:ied,JsdB:JedB), CS%diag) - if (CS%id_eta_pred_hifreq > 0) call post_data(CS%id_eta_pred_hifreq, eta_PF_BT(isd:ied,jsd:jed), CS%diag) - endif + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + err_count = 0 - if (CS%debug_bt) then - write(mesg,'("BT step ",I4)') n - call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=iev-ie, & - scale=US%L_T_to_m_s) - call hchksum(eta, trim(mesg)//" eta", CS%debug_BT_HI, haloshift=iev-ie, scale=GV%H_to_m) - endif + ! Figure out the fullest arrays that could be updated. + stencil = max(1, CS%min_stencil) + if ((.not.use_BT_cont) .and. CS%Nonlinear_continuity .and. (CS%Nonlin_cont_update_period > 0)) & + stencil = max(2, CS%min_stencil) + num_cycles = 1 + if (CS%use_wide_halos) & + num_cycles = min((is-CS%isdw) / stencil, (js-CS%jsdw) / stencil) + isvf = is - (num_cycles-1)*stencil ; ievf = ie + (num_cycles-1)*stencil + jsvf = js - (num_cycles-1)*stencil ; jevf = je + (num_cycles-1)*stencil + + integral_BT_cont = use_BT_cont .and. CS%integral_BT_cont + evolving_face_areas = (.not.use_BT_cont) .and. CS%Nonlinear_continuity .and. & + (CS%Nonlin_cont_update_period > 0) + Instep = 1.0 / real(nstep) + Idtbt = 1.0 / dtbt + + !--- setup the weight when computing vbt_trans and ubt_trans + if (CS%BT_project_velocity) then + be_proj = CS%bebt + trans_wt1 = (1.0 + be_proj) ; trans_wt2 = -be_proj + else + trans_wt1 = CS%bebt ; trans_wt2 = (1.0-CS%bebt) + endif + + ! Manage diagnostics + do_ave = query_averaging_enabled(CS%diag) .and. & + ((CS%id_PFu_bt > 0) .or. (CS%id_Coru_bt > 0) .or. (CS%id_LDu_bt > 0) .or. & + (CS%id_PFv_bt > 0) .or. (CS%id_Corv_bt > 0) .or. (CS%id_LDv_bt > 0) .or. & + associated(ADp%bt_pgf_u) .or. associated(ADp%bt_cor_u) .or. associated(ADp%bt_lwd_u) .or. & + associated(ADp%bt_pgf_v) .or. associated(ADp%bt_cor_v) .or. associated(ADp%bt_lwd_v)) + + do_hifreq_output = .false. + if ((CS%id_ubt_hifreq > 0) .or. (CS%id_vbt_hifreq > 0) .or. & + (CS%id_eta_hifreq > 0) .or. (CS%id_eta_pred_hifreq > 0) .or. (CS%id_etaPF_hifreq > 0) .or. & + (CS%id_uhbt_hifreq > 0) .or. (CS%id_vhbt_hifreq > 0)) & + do_hifreq_output = query_averaging_enabled(CS%diag, time_int_in, time_end_in) + if (do_hifreq_output) then + time_bt_start = time_end_in - real_to_time(dt, unscale=US%T_to_s) + dtbt_diag = dt/(nstep+nfilter) ! Note that this is not dtbt. + endif + + ! Zero out the arrays for various time-averaged quantities. + if (find_etaav) then + !$OMP do + do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1 + eta_sum(i,j) = 0.0 ; eta_wtd(i,j) = 0.0 + enddo ; enddo + else + !$OMP do + do j=jsvf-1,jevf+1 ; do i=isvf-1,ievf+1 + eta_wtd(i,j) = 0.0 + enddo ; enddo + endif + !$OMP do + do j=js,je ; do I=is-1,ie + CS%ubtav(I,j) = 0.0 ; uhbtav(I,j) = 0.0 + PFu_avg(I,j) = 0.0 ; Coru_avg(I,j) = 0.0 + LDu_avg(I,j) = 0.0 ; ubt_wtd(I,j) = 0.0 + enddo ; enddo + !$OMP do + do j=jsvf-1,jevf+1 ; do I=isvf-1,ievf + ubt_trans(I,j) = 0.0 + enddo ; enddo + !$OMP do + do J=js-1,je ; do i=is,ie + CS%vbtav(i,J) = 0.0 ; vhbtav(i,J) = 0.0 + PFv_avg(i,J) = 0.0 ; Corv_avg(i,J) = 0.0 + LDv_avg(i,J) = 0.0 ; vbt_wtd(i,J) = 0.0 + enddo ; enddo + !$OMP do + do J=jsvf-1,jevf ; do i=isvf-1,ievf+1 + vbt_trans(i,J) = 0.0 + enddo ; enddo + if (integral_BT_cont) then + ubt_int(:,:) = 0.0 ; uhbt_int(:,:) = 0.0 + vbt_int(:,:) = 0.0 ; vhbt_int(:,:) = 0.0 + endif + + p_surf_dyn(:,:) = 0.0 + cfl_ltd_vol(:,:) = huge( GV%Z_to_H ) + if (CS%bt_limit_integral_transport) then + ! Issue warnings if there are unphysical values of the initial sea surface height or total water column mass. if (GV%Boussinesq) then do j=js,je ; do i=is,ie - if ((eta(i,j) < -GV%Z_to_H*G%bathyT(i,j)) .and. (G%mask2dT(i,j) > 0.0)) then + if ((eta_IC(i,j) < -GV%Z_to_H*G%bathyT(i,j)) .and. (G%mask2dT(i,j) > 0.0)) then write(mesg,'(ES24.16," vs. ",ES24.16, " at ", ES12.4, ES12.4, i7, i7)') GV%H_to_m*eta(i,j), & - -US%Z_to_m*G%bathyT(i,j), G%geoLonT(i,j), G%geoLatT(i,j), i + G%isd_global, j + G%jsd_global - if (err_count < 2) & - call MOM_error(WARNING, "btstep: eta has dropped below bathyT: "//trim(mesg), all_print=.true.) - err_count = err_count + 1 + -US%Z_to_m*G%bathyT(i,j), G%geoLonT(i,j), G%geoLatT(i,j), i + G%HI%idg_offset, j + G%HI%jdg_offset + call MOM_error(FATAL, "btstep: eta_IC starts below bathyT: "//trim(mesg), all_print=.true.) endif enddo ; enddo else do j=js,je ; do i=is,ie - if (eta(i,j) < 0.0) then - if (err_count < 2) & - call MOM_error(WARNING, "btstep: negative eta in a non-Boussinesq barotropic solver.", all_print=.true.) - err_count = err_count + 1 + if ((eta_IC(i,j) < 0.0) .and. (G%mask2dT(i,j) > 0.0)) then + write(mesg,'(" at ", ES12.4, ES12.4, i7, i7)') & + G%geoLonT(i,j), G%geoLatT(i,j), i + G%HI%idg_offset, j + G%HI%jdg_offset + call MOM_error(FATAL, "btstep: negative eta_IC at start of a non-Boussinesq barotropic solver "//& + trim(mesg), all_print=.true.) endif enddo ; enddo endif + endif - enddo ! end of do n=1,ntimestep - if (id_clock_calc > 0) call cpu_clock_end(id_clock_calc) - if (id_clock_calc_post > 0) call cpu_clock_begin(id_clock_calc_post) + ! Set up the group pass used for halo updates within the barotropic time stepping loops. + call create_group_pass(CS%pass_eta_ubt, eta, CS%BT_Domain) + call create_group_pass(CS%pass_eta_ubt, ubt, vbt, CS%BT_Domain) + if (integral_BT_cont) then + call create_group_pass(CS%pass_eta_ubt, ubt_int, vbt_int, CS%BT_Domain) + ! This is only needed with integral_BT_cont, OBCs and multiple barotropic steps between halo updates. + if (CS%integral_OBCs) & + call create_group_pass(CS%pass_eta_ubt, uhbt_int, vhbt_int, CS%BT_Domain) + endif - ! Reset the time information in the diag type. - if (do_hifreq_output) call enable_averaging(time_int_in, time_end_in, CS%diag) + ! The following loop contains all of the time steps. + isv = is ; iev = ie ; jsv = js ; jev = je + do n=1,nstep+nfilter + if (CS%clip_velocity) call truncate_velocities(ubt, vbt, dt, G, CS, isv, iev, jsv, jev) - if (CS%answers_2018) then - I_sum_wt_vel = 1.0 / sum_wt_vel ; I_sum_wt_eta = 1.0 / sum_wt_eta - I_sum_wt_accel = 1.0 / sum_wt_accel ; I_sum_wt_trans = 1.0 / sum_wt_trans - else - I_sum_wt_vel = 1.0 ; I_sum_wt_eta = 1.0 ; I_sum_wt_accel = 1.0 ; I_sum_wt_trans = 1.0 - endif + ! Update the range of valid points, either by doing a halo update or by marching inward. + if ((iev - stencil < ie) .or. (jev - stencil < je)) then + if (id_clock_calc > 0) call cpu_clock_end(id_clock_calc) + call do_group_pass(CS%pass_eta_ubt, CS%BT_Domain, clock=id_clock_pass_step) + isv = isvf ; iev = ievf ; jsv = jsvf ; jev = jevf + if (id_clock_calc > 0) call cpu_clock_begin(id_clock_calc) + else + isv = isv+stencil ; iev = iev-stencil + jsv = jsv+stencil ; jev = jev-stencil + endif - if (find_etaav) then ; do j=js,je ; do i=is,ie - etaav(i,j) = eta_sum(i,j) * I_sum_wt_accel - enddo ; enddo ; endif - do j=js-1,je+1 ; do i=is-1,ie+1 ; e_anom(i,j) = 0.0 ; enddo ; enddo - if (interp_eta_PF) then - do j=js,je ; do i=is,ie - e_anom(i,j) = dgeo_de * (0.5 * (eta(i,j) + eta_in(i,j)) - & - (eta_PF_1(i,j) + 0.5*d_eta_PF(i,j))) + ! Store the previous velocities for time-filtered transports and OBCs. + do j=jsv,jev ; do I=isv-2,iev+1 + ubt_prev(I,j) = ubt(I,j) enddo ; enddo - else - do j=js,je ; do i=is,ie - e_anom(i,j) = dgeo_de * (0.5 * (eta(i,j) + eta_in(i,j)) - eta_PF(i,j)) + do J=jsv-2,jev+1 ; do i=isv,iev + vbt_prev(i,J) = vbt(i,J) enddo ; enddo - endif - if (apply_OBCs) then - !!! Not safe for wide halos... - if (CS%BT_OBC%apply_u_OBCs) then ! copy back the value for u-points on the boundary. - !GOMP parallel do default(shared) - do j=js,je ; do I=is-1,ie - l_seg = OBC%segnum_u(I,j) - if (l_seg == OBC_NONE) cycle - if (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then - e_anom(i+1,j) = e_anom(i,j) - elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_W) then - e_anom(i,j) = e_anom(i+1,j) - endif + if (integral_BT_cont) then + !$OMP parallel do default(shared) + do j=jsv-1,jev+1 ; do I=isv-2,iev+1 + uhbt_int_prev(I,j) = uhbt_int(I,j) + enddo ; enddo + !$OMP parallel do default(shared) + do J=jsv-2,jev+1 ; do i=isv-1,iev+1 + vhbt_int_prev(i,J) = vhbt_int(i,J) enddo ; enddo endif - if (CS%BT_OBC%apply_v_OBCs) then ! copy back the value for v-points on the boundary. - !GOMP parallel do default(shared) - do J=js-1,je ; do I=is,ie - l_seg = OBC%segnum_v(i,J) - if (l_seg == OBC_NONE) cycle - - if (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then - e_anom(i,j+1) = e_anom(i,j) - elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_S) then - e_anom(i,j) = e_anom(i,j+1) - endif - enddo ; enddo + ! Do a predictor step update of eta + if (evolving_face_areas) then + if ((n>1) .and. (mod(n-1,CS%Nonlin_cont_update_period) == 0)) & + call find_face_areas(Datu, Datv, G, GV, US, CS, MS, 1+iev-ie, eta) endif - endif - ! It is possible that eta_out and eta_in are the same. - do j=js,je ; do i=is,ie - eta_out(i,j) = eta_wtd(i,j) * I_sum_wt_eta - enddo ; enddo + if (CS%dynamic_psurf .or. (.not.CS%BT_project_velocity)) then + ! Estimate the change in the free surface height. + call btloop_eta_predictor(n, dtbt, ubt, vbt, eta, ubt_int, vbt_int, uhbt, vhbt, uhbt0, vhbt0, & + uhbt_int, vhbt_int, BTCL_u, BTCL_v, Datu, Datv, eta_IC, eta_src, eta_pred, & + isv, iev, jsv, jev, integral_BT_cont, use_BT_cont, G, US, CS) + endif - if (id_clock_calc_post > 0) call cpu_clock_end(id_clock_calc_post) - if (id_clock_pass_post > 0) call cpu_clock_begin(id_clock_pass_post) - if (G%nonblocking_updates) then - call start_group_pass(CS%pass_e_anom, G%Domain) - else - if (find_etaav) call do_group_pass(CS%pass_etaav, G%Domain) - call do_group_pass(CS%pass_e_anom, G%Domain) - endif - if (id_clock_pass_post > 0) call cpu_clock_end(id_clock_pass_post) - if (id_clock_calc_post > 0) call cpu_clock_begin(id_clock_calc_post) + if (interp_eta_PF) then + ! Interpolate the effective surface pressure in time + wt_end = n*Instep ! This could be (n-0.5)*Instep. + !$OMP parallel do default(shared) + do j=jsv-1,jev+1 ; do i=isv-1,iev+1 + eta_PF(i,j) = eta_PF_1(i,j) + wt_end*d_eta_PF(i,j) + enddo ; enddo + endif - if (CS%answers_2018) then - do j=js,je ; do I=is-1,ie - CS%ubtav(I,j) = ubt_sum(I,j) * I_sum_wt_trans - uhbtav(I,j) = uhbt_sum(I,j) * I_sum_wt_trans - ubt_wtd(I,j) = ubt_wtd(I,j) * I_sum_wt_vel - enddo ; enddo + v_first = (MOD(n+G%first_direction,2)==1) - do J=js-1,je ; do i=is,ie - CS%vbtav(i,J) = vbt_sum(i,J) * I_sum_wt_trans - vhbtav(i,J) = vhbt_sum(i,J) * I_sum_wt_trans - vbt_wtd(i,J) = vbt_wtd(i,J) * I_sum_wt_vel - enddo ; enddo - else - do j=js,je ; do I=is-1,ie - CS%ubtav(I,j) = ubt_sum(I,j) - uhbtav(I,j) = uhbt_sum(I,j) - enddo ; enddo + ! Determine the pressure force accelerations due to the updated eta anomalies. + if (CS%BT_project_velocity) then + call btloop_find_PF(PFu, PFv, isv, iev, jsv, jev, eta, eta_PF, & + gtot_N, gtot_S, gtot_E, gtot_W, dgeo_de, find_etaav, & + wt_accel2(n), eta_sum, v_first, G, US, CS) + else + call btloop_find_PF(PFu, PFv, isv, iev, jsv, jev, eta_pred, eta_PF, & + gtot_N, gtot_S, gtot_E, gtot_W, dgeo_de, find_etaav, & + wt_accel2(n), eta_sum, v_first, G, US, CS) + endif - do J=js-1,je ; do i=is,ie - CS%vbtav(i,J) = vbt_sum(i,J) - vhbtav(i,J) = vhbt_sum(i,J) - enddo ; enddo - endif + ! Use the change in eta to determine an additional divergence damping due to the ice strength. + if (CS%dynamic_psurf) then + call btloop_add_dyn_PF(PFu, PFv, eta_pred, eta, dyn_coef_eta, p_surf_dyn, & + isv, iev, jsv, jev, v_first, G, US, CS) + endif + if (v_first) then + ! On odd-steps, update v first. + call btloop_update_v(dtbt, ubt, vbt, v_accel_bt, Cor_v, PFv, isv-1, iev+1, jsv-1, jev, & + f_4_v, bt_rem_v, BT_force_v, Cor_ref_v, Rayleigh_v, & + wt_accel(n), G, US, CS) - if (id_clock_calc_post > 0) call cpu_clock_end(id_clock_calc_post) - if (id_clock_pass_post > 0) call cpu_clock_begin(id_clock_pass_post) - if (G%nonblocking_updates) then - call complete_group_pass(CS%pass_e_anom, G%Domain) - if (find_etaav) call start_group_pass(CS%pass_etaav, G%Domain) - call start_group_pass(CS%pass_ubta_uhbta, G%DoMain) - else - call do_group_pass(CS%pass_ubta_uhbta, G%Domain) - endif - if (id_clock_pass_post > 0) call cpu_clock_end(id_clock_pass_post) - if (id_clock_calc_post > 0) call cpu_clock_begin(id_clock_calc_post) + ! Now update the zonal velocity. + call btloop_update_u(dtbt, ubt, vbt, u_accel_bt, Cor_u, PFu, isv-1, iev, jsv, jev, & + f_4_u, bt_rem_u, BT_force_u, Cor_ref_u, Rayleigh_u, & + wt_accel(n), G, US, CS) - ! Now calculate each layer's accelerations. - !$OMP parallel do default(shared) - do k=1,nz - do j=js,je ; do I=is-1,ie - accel_layer_u(I,j,k) = (u_accel_bt(I,j) - & - ((pbce(i+1,j,k) - gtot_W(i+1,j)) * e_anom(i+1,j) - & - (pbce(i,j,k) - gtot_E(i,j)) * e_anom(i,j)) * CS%IdxCu(I,j) ) - if (abs(accel_layer_u(I,j,k)) < accel_underflow) accel_layer_u(I,j,k) = 0.0 - enddo ; enddo - do J=js-1,je ; do i=is,ie - accel_layer_v(i,J,k) = (v_accel_bt(i,J) - & - ((pbce(i,j+1,k) - gtot_S(i,j+1)) * e_anom(i,j+1) - & - (pbce(i,j,k) - gtot_N(i,j)) * e_anom(i,j)) * CS%IdyCv(i,J) ) - if (abs(accel_layer_v(i,J,k)) < accel_underflow) accel_layer_v(i,J,k) = 0.0 - enddo ; enddo - enddo + else + ! On even steps, update u first. + call btloop_update_u(dtbt, ubt, vbt, u_accel_bt, Cor_u, PFu, isv-1, iev, jsv-1, jev+1, & + f_4_u, bt_rem_u, BT_force_u, Cor_ref_u, Rayleigh_u, & + wt_accel(n), G, US, CS) + ! Now update the meridional velocity. + call btloop_update_v(dtbt, ubt, vbt, v_accel_bt, Cor_v, PFv, isv, iev, jsv-1, jev, & + f_4_v, bt_rem_v, BT_force_v, Cor_ref_v, Rayleigh_v, & + wt_accel(n), G, US, CS, Cor_bracket_bug=CS%use_old_coriolis_bracket_bug) + endif - if (apply_OBCs) then - ! Correct the accelerations at OBC velocity points, but only in the - ! symmetric-memory computational domain, not in the wide halo regions. - if (CS%BT_OBC%apply_u_OBCs) then ; do j=js,je ; do I=is-1,ie - if (OBC%segnum_u(I,j) /= OBC_NONE) then - u_accel_bt(I,j) = (ubt_wtd(I,j) - ubt_first(I,j)) / dt - do k=1,nz ; accel_layer_u(I,j,k) = u_accel_bt(I,j) ; enddo - endif - enddo ; enddo ; endif - if (CS%BT_OBC%apply_v_OBCs) then ; do J=js-1,je ; do i=is,ie - if (OBC%segnum_v(i,J) /= OBC_NONE) then - v_accel_bt(i,J) = (vbt_wtd(i,J) - vbt_first(i,J)) / dt - do k=1,nz ; accel_layer_v(i,J,k) = v_accel_bt(i,J) ; enddo + ! Determine the transports based on the updated velocities when no OBCs are applied + if (integral_BT_cont) then + if (CS%bt_limit_integral_transport) then + ! Calculate the volume that could be used for divergent transport to use for a limter. This applies to + ! uhbt_int and vhbt_int at each BT step. It does not allow for temporary flooding during the BT cycling. + ! Only the sink is accounted for: if diverent motion occurs at the beginning of the BT cycling but the volume + ! was due only to a +ve source being applied gradually, then the instantaneous eta could drop below the bottom. + if (GV%Boussinesq) then + do j=jsv,jev ; do i=isv,iev + cfl_ltd_vol(i,j) = ( CS%maxCFL_BT_cont * G%areaT(i,j) ) * & + max( 0., ( GV%Z_to_H*G%bathyT(i,j) + eta_IC(i,j) ) + nstep * min( 0., eta_src(i,j) ) ) + enddo ; enddo + else + do j=jsv,jev ; do i=isv,iev + cfl_ltd_vol(i,j) = ( CS%maxCFL_BT_cont * G%areaT(i,j) ) * & + max( 0., eta_IC(i,j) + nstep * min( 0., eta_src(i,j) ) ) + enddo ; enddo + endif endif - enddo ; enddo ; endif - endif + !$OMP do schedule(static) + do j=jsv,jev ; do I=isv-1,iev + ubt_trans(I,j) = trans_wt1*ubt(I,j) + trans_wt2*ubt_prev(I,j) + ubt_int_prev(I,j) = ubt_int(I,j) ! Store the previous integrated velocity so it can be reset by at OBC points + ubt_int(I,j) = ubt_int(I,j) + dtbt * ubt_trans(I,j) + uhbt_int(I,j) = find_uhbt(ubt_int(I,j), BTCL_u(I,j)) + n*dtbt*uhbt0(I,j) + uhbt_int(I,j) = max( -cfl_ltd_vol(i+1,j), min( uhbt_int(I,j), cfl_ltd_vol(i,j) ) ) + ! Estimate the mass flux within a single timestep to take the filtered average. + uhbt(I,j) = (uhbt_int(I,j) - uhbt_int_prev(I,j)) * Idtbt + enddo ; enddo + !$OMP end do nowait + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv,iev + vbt_trans(i,J) = trans_wt1*vbt(i,J) + trans_wt2*vbt_prev(i,J) + vbt_int_prev(i,J) = vbt_int(i,J) ! Store the previous integrated velocity so it can be reset by at OBC points + vbt_int(i,J) = vbt_int(i,J) + dtbt * vbt_trans(i,J) + vhbt_int(i,J) = find_vhbt(vbt_int(i,J), BTCL_v(i,J)) + n*dtbt*vhbt0(i,J) + vhbt_int(i,J) = max( -cfl_ltd_vol(i,j+1), min( vhbt_int(i,J), cfl_ltd_vol(i,j) ) ) + ! Estimate the mass flux within a single timestep to take the filtered average. + vhbt(i,J) = (vhbt_int(i,J) - vhbt_int_prev(i,J)) * Idtbt + enddo ; enddo + elseif (use_BT_cont) then + !$OMP do schedule(static) + do j=jsv,jev ; do I=isv-1,iev + ubt_trans(I,j) = trans_wt1*ubt(I,j) + trans_wt2*ubt_prev(I,j) + uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j)) + uhbt0(I,j) + enddo ; enddo + !$OMP end do nowait + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv,iev + vbt_trans(i,J) = trans_wt1*vbt(i,J) + trans_wt2*vbt_prev(i,J) + vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J)) + vhbt0(i,J) + enddo ; enddo + else + !$OMP do schedule(static) + do j=jsv,jev ; do I=isv-1,iev + ubt_trans(I,j) = trans_wt1*ubt(I,j) + trans_wt2*ubt_prev(I,j) + uhbt(I,j) = Datu(I,j)*ubt_trans(I,j) + uhbt0(I,j) + enddo ; enddo + !$OMP end do nowait + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=isv,iev + vbt_trans(i,J) = trans_wt1*vbt(i,J) + trans_wt2*vbt_prev(i,J) + vhbt(i,J) = Datv(i,J)*vbt_trans(i,J) + vhbt0(i,J) + enddo ; enddo + endif - if (id_clock_calc_post > 0) call cpu_clock_end(id_clock_calc_post) + ! This might need to be moved outside of the OMP do loop directives. + if (CS%debug_bt) then + write(mesg,'("BT vel update ",I0)') n + debug_halo = 0 ; if (CS%debug_wide_halos) debug_halo = iev - ie + call uvchksum(trim(mesg)//" PF[uv]", PFu, PFv, CS%debug_BT_HI, haloshift=debug_halo, & + symmetric=.true., unscale=US%L_T_to_m_s*US%s_to_T) + call uvchksum(trim(mesg)//" Cor_[uv]", Cor_u, Cor_v, CS%debug_BT_HI, haloshift=debug_halo, & + symmetric=.true., unscale=US%L_T_to_m_s*US%s_to_T) + call uvchksum(trim(mesg)//" BT_force_[uv]", BT_force_u, BT_force_v, CS%debug_BT_HI, haloshift=debug_halo, & + symmetric=.true., unscale=US%L_T_to_m_s*US%s_to_T) + call uvchksum(trim(mesg)//" BT_rem_[uv]", BT_rem_u, BT_rem_v, CS%debug_BT_HI, haloshift=debug_halo, & + symmetric=.true., scalar_pair=.true.) + call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=debug_halo, & + symmetric=.true., unscale=US%L_T_to_m_s) + call uvchksum(trim(mesg)//" [uv]bt_trans", ubt_trans, vbt_trans, CS%debug_BT_HI, haloshift=debug_halo, & + symmetric=.true., unscale=US%L_T_to_m_s) + call uvchksum(trim(mesg)//" [uv]hbt", uhbt, vhbt, CS%debug_BT_HI, haloshift=debug_halo, & + symmetric=.true., unscale=US%s_to_T*US%L_to_m**2*GV%H_to_m) + if (integral_BT_cont) & + call uvchksum(trim(mesg)//" [uv]hbt_int", uhbt_int, vhbt_int, CS%debug_BT_HI, haloshift=debug_halo, & + symmetric=.true., unscale=US%L_to_m**2*GV%H_to_m) + endif - ! Calculate diagnostic quantities. - if (query_averaging_enabled(CS%diag)) then + ! Apply open boundary condition considerations to revise the updated velocities and transports. + if (CS%BT_OBC%u_OBCs_on_PE) then + !$OMP single + call apply_u_velocity_OBCs(ubt, uhbt, ubt_trans, eta, SpV_col_avg, ubt_prev, BT_OBC, & + G, MS, GV, US, CS, iev-ie, dtbt, CS%bebt, use_BT_cont, integral_BT_cont, n*dtbt, & + Datu, BTCL_u, uhbt0, ubt_int, ubt_int_prev, uhbt_int, uhbt_int_prev) + !$OMP end single + endif - if (CS%gradual_BT_ICs) then - do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = ubt_wtd(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = vbt_wtd(i,J) ; enddo ; enddo + if (CS%BT_OBC%v_OBCs_on_PE) then + !$OMP single + call apply_v_velocity_OBCs(vbt, vhbt, vbt_trans, eta, SpV_col_avg, vbt_prev, BT_OBC, & + G, MS, GV, US, CS, iev-ie, dtbt, CS%bebt, use_BT_cont, integral_BT_cont, n*dtbt, & + Datv, BTCL_v, vhbt0, vbt_int, vbt_int_prev, vhbt_int, vhbt_int_prev) + !$OMP end single endif -! Offer various barotropic terms for averaging. - if (CS%id_PFu_bt > 0) then - do j=js,je ; do I=is-1,ie - PFu_bt_sum(I,j) = PFu_bt_sum(I,j) * I_sum_wt_accel - enddo ; enddo - call post_data(CS%id_PFu_bt, PFu_bt_sum(IsdB:IedB,jsd:jed), CS%diag) + ! Contribute to the running sums of the transports and velocities. + !$OMP do + do j=js,je ; do I=is-1,ie + CS%ubtav(I,j) = CS%ubtav(I,j) + wt_trans(n) * ubt_trans(I,j) + uhbtav(I,j) = uhbtav(I,j) + wt_trans(n) * uhbt(I,j) + ubt_wtd(I,j) = ubt_wtd(I,j) + wt_vel(n) * ubt(I,j) + enddo ; enddo + !$OMP end do nowait + !$OMP do + do J=js-1,je ; do i=is,ie + CS%vbtav(i,J) = CS%vbtav(i,J) + wt_trans(n) * vbt_trans(i,J) + vhbtav(i,J) = vhbtav(i,J) + wt_trans(n) * vhbt(i,J) + vbt_wtd(i,J) = vbt_wtd(i,J) + wt_vel(n) * vbt(i,J) + enddo ; enddo + !$OMP end do nowait + + if (CS%debug_bt) then + call uvchksum("BT [uv]hbt just after OBC", uhbt, vhbt, CS%debug_BT_HI, haloshift=debug_halo, & + symmetric=.true., unscale=US%s_to_T*US%L_to_m**2*GV%H_to_m) + if (integral_BT_cont) & + call uvchksum("BT [uv]hbt_int just after OBC", uhbt_int, vhbt_int, CS%debug_BT_HI, & + haloshift=debug_halo, symmetric=.true., unscale=US%L_to_m**2*GV%H_to_m) endif - if (CS%id_PFv_bt > 0) then - do J=js-1,je ; do i=is,ie - PFv_bt_sum(i,J) = PFv_bt_sum(i,J) * I_sum_wt_accel + + ! Update eta in a corrector step using the barotropic continuity equation. + if (integral_BT_cont) then + eta_cor_multiplier = n + if ( CS%bt_adjust_src_for_filter ) then + if ( nstep > nfilter ) then + eta_cor_multiplier = min(nstep - nfilter, n) * nstep / real(nstep - nfilter) + else + eta_cor_multiplier = nstep + endif + endif + !$OMP do + do j=jsv,jev ; do i=isv,iev + eta(i,j) = (eta_IC(i,j) + eta_cor_multiplier*eta_src(i,j)) + CS%IareaT_OBCmask(i,j) * & + ((uhbt_int(I-1,j) - uhbt_int(I,j)) + (vhbt_int(i,J-1) - vhbt_int(i,J))) + ! eta_acc contains the magnitude of the largest term in the above expression which + ! will be used to estimate a bound for round off when comparing to the bottom depth + eta_acc = abs( CS%IareaT_OBCmask(i,j) * & + ((uhbt_int(I-1,j) - uhbt_int(I,j)) + (vhbt_int(i,J-1) - vhbt_int(i,J))) ) + eta_acc = max( eta_acc, abs( eta_cor_multiplier*eta_src(i,j) ), abs( eta_IC(i,j) ) ) + if ( G%mask2dT(i,j) * ( eta(i,j) + GV%Z_to_H*G%bathyT(i,j) ) > & + -G%mask2dT(i,j) * eta_acc * epsilon(eta_acc) * 2. ) & + eta(i,j) = max( eta(i,j), -GV%Z_to_H*G%bathyT(i,j) ) + eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n) + if ((eta(i,j) < -GV%Z_to_H*G%bathyT(i,j)) .and. (G%mask2dT(i,j) > 0.0)) then + write(mesg,'(ES24.16," vs. ",ES24.16, " at ", ES12.4, ES12.4, i7, i7)') GV%H_to_m*eta(i,j), & + -US%Z_to_m*G%bathyT(i,j), G%geoLonT(i,j), G%geoLatT(i,j), i + G%HI%idg_offset, j + G%HI%jdg_offset + if (CS%bt_limit_integral_transport) & + call MOM_error(FATAL, "btstep: eta has dropped below bathyT: "//trim(mesg)) + endif enddo ; enddo - call post_data(CS%id_PFv_bt, PFv_bt_sum(isd:ied,JsdB:JedB), CS%diag) - endif - if (CS%id_Coru_bt > 0) then - do j=js,je ; do I=is-1,ie - Coru_bt_sum(I,j) = Coru_bt_sum(I,j) * I_sum_wt_accel + else + !$OMP do + do j=jsv,jev ; do i=isv,iev + eta(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * CS%IareaT_OBCmask(i,j)) * & + ((uhbt(I-1,j) - uhbt(I,j)) + (vhbt(i,J-1) - vhbt(i,J))) + eta_wtd(i,j) = eta_wtd(i,j) + eta(i,j) * wt_eta(n) enddo ; enddo - call post_data(CS%id_Coru_bt, Coru_bt_sum(IsdB:IedB,jsd:jed), CS%diag) endif - if (CS%id_Corv_bt > 0) then - do J=js-1,je ; do i=is,ie - Corv_bt_sum(i,J) = Corv_bt_sum(i,J) * I_sum_wt_accel - enddo ; enddo - call post_data(CS%id_Corv_bt, Corv_bt_sum(isd:ied,JsdB:JedB), CS%diag) + + if (CS%debug_bt) then + write(mesg,'("BT step ",I0)') n + call uvchksum(trim(mesg)//" [uv]bt", ubt, vbt, CS%debug_BT_HI, haloshift=debug_halo, & + symmetric=.true., unscale=US%L_T_to_m_s) + call hchksum(eta, trim(mesg)//" eta", CS%debug_BT_HI, haloshift=debug_halo, unscale=GV%H_to_MKS) endif - if (CS%id_ubtdt > 0) then - do j=js,je ; do I=is-1,ie - ubt_dt(I,j) = (ubt_wtd(I,j) - ubt_st(I,j))*Idt + + ! Issue warnings if there are unphysical values of the sea surface height or total water column mass. + if (GV%Boussinesq) then + do j=js,je ; do i=is,ie + if ((eta(i,j) < -GV%Z_to_H*G%bathyT(i,j)) .and. (G%mask2dT(i,j) > 0.0)) then + write(mesg,'(ES24.16," vs. ",ES24.16, " at ", ES12.4, ES12.4, i7, i7)') GV%H_to_m*eta(i,j), & + -US%Z_to_m*G%bathyT(i,j), G%geoLonT(i,j), G%geoLatT(i,j), i + G%HI%idg_offset, j + G%HI%jdg_offset + if (CS%bt_limit_integral_transport) & + call MOM_error(FATAL, "btstep: eta has dropped below bathyT: "//trim(mesg)) + if (err_count < 2) & + call MOM_error(WARNING, "btstep: eta has dropped below bathyT: "//trim(mesg), all_print=.true.) + err_count = err_count + 1 + endif enddo ; enddo - call post_data(CS%id_ubtdt, ubt_dt(IsdB:IedB,jsd:jed), CS%diag) - endif - if (CS%id_vbtdt > 0) then - do J=js-1,je ; do i=is,ie - vbt_dt(i,J) = (vbt_wtd(i,J) - vbt_st(i,J))*Idt + else + do j=js,je ; do i=is,ie + if ((eta(i,j) < 0.0) .and. (G%mask2dT(i,j) > 0.0)) then + write(mesg,'(" at ", ES12.4, ES12.4, i7, i7)') & + G%geoLonT(i,j), G%geoLatT(i,j), i + G%HI%idg_offset, j + G%HI%jdg_offset + if (CS%bt_limit_integral_transport) & + call MOM_error(FATAL, "btstep: negative eta in a non-Boussinesq barotropic solver "//trim(mesg)) + if (err_count < 2) & + call MOM_error(WARNING, "btstep: negative eta in a non-Boussinesq barotropic solver "//& + trim(mesg), all_print=.true.) + err_count = err_count + 1 + endif enddo ; enddo - call post_data(CS%id_vbtdt, vbt_dt(isd:ied,JsdB:JedB), CS%diag) endif - if (CS%id_ubtforce > 0) call post_data(CS%id_ubtforce, BT_force_u(IsdB:IedB,jsd:jed), CS%diag) - if (CS%id_vbtforce > 0) call post_data(CS%id_vbtforce, BT_force_v(isd:ied,JsdB:JedB), CS%diag) - if (CS%id_uaccel > 0) call post_data(CS%id_uaccel, u_accel_bt(IsdB:IedB,jsd:jed), CS%diag) - if (CS%id_vaccel > 0) call post_data(CS%id_vaccel, v_accel_bt(isd:ied,JsdB:JedB), CS%diag) - - if (CS%id_eta_cor > 0) call post_data(CS%id_eta_cor, CS%eta_cor, CS%diag) - if (CS%id_eta_bt > 0) call post_data(CS%id_eta_bt, eta_out, CS%diag) ! - G%Z_ref? - if (CS%id_gtotn > 0) call post_data(CS%id_gtotn, gtot_N(isd:ied,jsd:jed), CS%diag) - if (CS%id_gtots > 0) call post_data(CS%id_gtots, gtot_S(isd:ied,jsd:jed), CS%diag) - if (CS%id_gtote > 0) call post_data(CS%id_gtote, gtot_E(isd:ied,jsd:jed), CS%diag) - if (CS%id_gtotw > 0) call post_data(CS%id_gtotw, gtot_W(isd:ied,jsd:jed), CS%diag) - if (CS%id_ubt > 0) call post_data(CS%id_ubt, ubt_wtd(IsdB:IedB,jsd:jed), CS%diag) - if (CS%id_vbt > 0) call post_data(CS%id_vbt, vbt_wtd(isd:ied,JsdB:JedB), CS%diag) - if (CS%id_ubtav > 0) call post_data(CS%id_ubtav, CS%ubtav, CS%diag) - if (CS%id_vbtav > 0) call post_data(CS%id_vbtav, CS%vbtav, CS%diag) - if (CS%id_visc_rem_u > 0) call post_data(CS%id_visc_rem_u, visc_rem_u, CS%diag) - if (CS%id_visc_rem_v > 0) call post_data(CS%id_visc_rem_v, visc_rem_v, CS%diag) - - if (CS%id_frhatu > 0) call post_data(CS%id_frhatu, CS%frhatu, CS%diag) - if (CS%id_uhbt > 0) call post_data(CS%id_uhbt, uhbtav, CS%diag) - if (CS%id_frhatv > 0) call post_data(CS%id_frhatv, CS%frhatv, CS%diag) - if (CS%id_vhbt > 0) call post_data(CS%id_vhbt, vhbtav, CS%diag) - if (CS%id_uhbt0 > 0) call post_data(CS%id_uhbt0, uhbt0(IsdB:IedB,jsd:jed), CS%diag) - if (CS%id_vhbt0 > 0) call post_data(CS%id_vhbt0, vhbt0(isd:ied,JsdB:JedB), CS%diag) - - if (CS%id_frhatu1 > 0) call post_data(CS%id_frhatu1, CS%frhatu1, CS%diag) - if (CS%id_frhatv1 > 0) call post_data(CS%id_frhatv1, CS%frhatv1, CS%diag) - - if (use_BT_cont) then - if (CS%id_BTC_FA_u_EE > 0) call post_data(CS%id_BTC_FA_u_EE, BT_cont%FA_u_EE, CS%diag) - if (CS%id_BTC_FA_u_E0 > 0) call post_data(CS%id_BTC_FA_u_E0, BT_cont%FA_u_E0, CS%diag) - if (CS%id_BTC_FA_u_W0 > 0) call post_data(CS%id_BTC_FA_u_W0, BT_cont%FA_u_W0, CS%diag) - if (CS%id_BTC_FA_u_WW > 0) call post_data(CS%id_BTC_FA_u_WW, BT_cont%FA_u_WW, CS%diag) - if (CS%id_BTC_uBT_EE > 0) call post_data(CS%id_BTC_uBT_EE, BT_cont%uBT_EE, CS%diag) - if (CS%id_BTC_uBT_WW > 0) call post_data(CS%id_BTC_uBT_WW, BT_cont%uBT_WW, CS%diag) - if (CS%id_BTC_FA_u_rat0 > 0) then - tmp_u(:,:) = 0.0 + ! Accumulate some diagnostics of time-averaged barotropic accelerations. + if (do_ave) then + if ((CS%id_PFu_bt > 0) .or. associated(ADp%bt_pgf_u)) then + !$OMP do do j=js,je ; do I=is-1,ie - if ((G%mask2dCu(I,j) > 0.0) .and. (BT_cont%FA_u_W0(I,j) > 0.0)) then - tmp_u(I,j) = (BT_cont%FA_u_E0(I,j)/ BT_cont%FA_u_W0(I,j)) - else - tmp_u(I,j) = 1.0 - endif + PFu_avg(I,j) = PFu_avg(I,j) + wt_accel2(n) * PFu(I,j) enddo ; enddo - call post_data(CS%id_BTC_FA_u_rat0, tmp_u, CS%diag) + !$OMP end do nowait endif - if (CS%id_BTC_FA_v_NN > 0) call post_data(CS%id_BTC_FA_v_NN, BT_cont%FA_v_NN, CS%diag) - if (CS%id_BTC_FA_v_N0 > 0) call post_data(CS%id_BTC_FA_v_N0, BT_cont%FA_v_N0, CS%diag) - if (CS%id_BTC_FA_v_S0 > 0) call post_data(CS%id_BTC_FA_v_S0, BT_cont%FA_v_S0, CS%diag) - if (CS%id_BTC_FA_v_SS > 0) call post_data(CS%id_BTC_FA_v_SS, BT_cont%FA_v_SS, CS%diag) - if (CS%id_BTC_vBT_NN > 0) call post_data(CS%id_BTC_vBT_NN, BT_cont%vBT_NN, CS%diag) - if (CS%id_BTC_vBT_SS > 0) call post_data(CS%id_BTC_vBT_SS, BT_cont%vBT_SS, CS%diag) - if (CS%id_BTC_FA_v_rat0 > 0) then - tmp_v(:,:) = 0.0 + if ((CS%id_PFv_bt > 0) .or. associated(ADp%bt_pgf_v)) then + !$OMP do do J=js-1,je ; do i=is,ie - if ((G%mask2dCv(i,J) > 0.0) .and. (BT_cont%FA_v_S0(i,J) > 0.0)) then - tmp_v(i,J) = (BT_cont%FA_v_N0(i,J)/ BT_cont%FA_v_S0(i,J)) - else - tmp_v(i,J) = 1.0 - endif + PFv_avg(i,J) = PFv_avg(i,J) + wt_accel2(n) * PFv(i,J) enddo ; enddo - call post_data(CS%id_BTC_FA_v_rat0, tmp_v, CS%diag) + !$OMP end do nowait endif - if (CS%id_BTC_FA_h_rat0 > 0) then - tmp_h(:,:) = 0.0 - do j=js,je ; do i=is,ie - tmp_h(i,j) = 1.0 - if ((G%mask2dCu(I,j) > 0.0) .and. (BT_cont%FA_u_W0(I,j) > 0.0) .and. (BT_cont%FA_u_E0(I,j) > 0.0)) then - if (BT_cont%FA_u_W0(I,j) > BT_cont%FA_u_E0(I,j)) then - tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_W0(I,j)/ BT_cont%FA_u_E0(I,j))) - else - tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_E0(I,j)/ BT_cont%FA_u_W0(I,j))) - endif - endif - if ((G%mask2dCu(I-1,j) > 0.0) .and. (BT_cont%FA_u_W0(I-1,j) > 0.0) .and. (BT_cont%FA_u_E0(I-1,j) > 0.0)) then - if (BT_cont%FA_u_W0(I-1,j) > BT_cont%FA_u_E0(I-1,j)) then - tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_W0(I-1,j)/ BT_cont%FA_u_E0(I-1,j))) - else - tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_u_E0(I-1,j)/ BT_cont%FA_u_W0(I-1,j))) - endif - endif - if ((G%mask2dCv(i,J) > 0.0) .and. (BT_cont%FA_v_S0(i,J) > 0.0) .and. (BT_cont%FA_v_N0(i,J) > 0.0)) then - if (BT_cont%FA_v_S0(i,J) > BT_cont%FA_v_N0(i,J)) then - tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_S0(i,J)/ BT_cont%FA_v_N0(i,J))) - else - tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_N0(i,J)/ BT_cont%FA_v_S0(i,J))) - endif - endif - if ((G%mask2dCv(i,J-1) > 0.0) .and. (BT_cont%FA_v_S0(i,J-1) > 0.0) .and. (BT_cont%FA_v_N0(i,J-1) > 0.0)) then - if (BT_cont%FA_v_S0(i,J-1) > BT_cont%FA_v_N0(i,J-1)) then - tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_S0(i,J-1)/ BT_cont%FA_v_N0(i,J-1))) - else - tmp_h(i,j) = max(tmp_h(i,j), (BT_cont%FA_v_N0(i,J-1)/ BT_cont%FA_v_S0(i,J-1))) - endif - endif + if ((CS%id_Coru_bt > 0) .or. associated(ADp%bt_cor_u)) then + !$OMP do + do j=js,je ; do I=is-1,ie + Coru_avg(I,j) = Coru_avg(I,j) + wt_accel2(n) * Cor_u(I,j) enddo ; enddo - call post_data(CS%id_BTC_FA_h_rat0, tmp_h, CS%diag) + !$OMP end do nowait + endif + if ((CS%id_Corv_bt > 0) .or. associated(ADp%bt_cor_v)) then + !$OMP do + do J=js-1,je ; do i=is,ie + Corv_avg(i,J) = Corv_avg(i,J) + wt_accel2(n) * Cor_v(i,J) + enddo ; enddo + !$OMP end do nowait + endif + + if (CS%linear_wave_drag) then + if ((CS%id_LDu_bt > 0) .or. (associated(ADp%bt_lwd_u))) then + !$OMP do + do j=js,je ; do I=is-1,ie + LDu_avg(I,j) = LDu_avg(I,j) - wt_accel2(n) * (ubt(I,j) * Rayleigh_u(I,j)) + enddo ; enddo + !$OMP end do nowait + endif + if ((CS%id_LDv_bt > 0) .or. (associated(ADp%bt_lwd_v))) then + !$OMP do + do J=js-1,je ; do i=is,ie + LDv_avg(i,J) = LDv_avg(i,J) - wt_accel2(n) * (vbt(i,J) * Rayleigh_v(i,J)) + enddo ; enddo + !$OMP end do nowait + endif endif endif - else - if (CS%id_frhatu1 > 0) CS%frhatu1(:,:,:) = CS%frhatu(:,:,:) - if (CS%id_frhatv1 > 0) CS%frhatv1(:,:,:) = CS%frhatv(:,:,:) + + if (do_hifreq_output) then + ! Note that this compresses the time so that all of the timesteps, including those in the + ! extra timesteps for filtering, fit within dt. + time_step_end = time_bt_start + real_to_time(n*dtbt_diag, unscale=US%T_to_s) + call enable_averages(dtbt, time_step_end, CS%diag) + if (CS%id_ubt_hifreq > 0) call post_data(CS%id_ubt_hifreq, ubt(IsdB:IedB,jsd:jed), CS%diag) + if (CS%id_vbt_hifreq > 0) call post_data(CS%id_vbt_hifreq, vbt(isd:ied,JsdB:JedB), CS%diag) + if (CS%id_eta_hifreq > 0) call post_data(CS%id_eta_hifreq, eta(isd:ied,jsd:jed), CS%diag) + if (CS%id_etaPF_hifreq > 0) then + if (CS%BT_project_velocity) then + do j=js,je ; do i=is,ie + eta_anom_PF(i,j) = eta(i,j) - eta_PF(i,j) + enddo ; enddo + else + do j=js,je ; do i=is,ie + eta_anom_PF(i,j) = eta_pred(i,j) - eta_PF(i,j) + enddo ; enddo + endif + call post_data(CS%id_etaPF_hifreq, eta_anom_PF(isd:ied,jsd:jed), CS%diag) + endif + if (CS%id_uhbt_hifreq > 0) call post_data(CS%id_uhbt_hifreq, uhbt(IsdB:IedB,jsd:jed), CS%diag) + if (CS%id_vhbt_hifreq > 0) call post_data(CS%id_vhbt_hifreq, vhbt(isd:ied,JsdB:JedB), CS%diag) + if (CS%BT_project_velocity) then + ! This diagnostic is redundant in this case and should probably be omitted. + if (CS%id_eta_pred_hifreq > 0) call post_data(CS%id_eta_pred_hifreq, eta(isd:ied,jsd:jed), CS%diag) + else + if (CS%id_eta_pred_hifreq > 0) call post_data(CS%id_eta_pred_hifreq, eta_pred(isd:ied,jsd:jed), CS%diag) + endif + endif + enddo ! end of do n=1,ntimestep + + ! Reset the time information in the diag type. + if (do_hifreq_output) call enable_averaging(time_int_in, time_end_in, CS%diag) + +end subroutine btstep_timeloop + + +!> Find the Coriolis force terms _zon and _mer. +subroutine btstep_find_Cor(q, DCor_u, DCor_v, f_4_u, f_4_v, isvf, ievf, jsvf, jevf, CS) + type(barotropic_CS), intent(inout) :: CS !< Barotropic control structure + real, intent(in) :: q(SZIBW_(CS),SZJBW_(CS)) !< A pseudo potential vorticity [T-1 Z-1 ~> s-1 m-1] + !! or [T-1 H-1 ~> s-1 m-1 or m2 s-1 kg-1] + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: & + DCor_u !< An averaged depth or total thickness at u points [Z ~> m] or [H ~> m or kg m-2]. + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: & + DCor_v !< An averaged depth or total thickness at v points [Z ~> m] or [H ~> m or kg m-2]. + real, dimension(4,SZIBW_(CS),SZJW_(CS)), intent(inout) :: & + f_4_u !< The terms giving the contribution to the Coriolis acceleration at a zonal + !! velocity point from the neighboring meridional velocity anomalies [T-1 ~> s-1]. + !! These are the products of thicknesses at v points and appropriately staggered + !! averaged pseudo potential vorticities, but with sufficiently smooth topography + !! they are approximately f / 4. The 4 values on the innermost loop are for + !! v-velocities to the southwest, southeast, northwest and northeast. + real, dimension(4,SZIW_(CS),SZJBW_(CS)), intent(inout) :: & + f_4_v !< The terms giving the contribution to the Coriolis acceleration at a meridional + !! velocity point from the neighboring meridional velocity anomalies [T-1 ~> s-1]. + !! These are the products of thicknesses at u points and appropriately staggered + !! averaged pseudo potential vorticities, but with sufficiently smooth topography + !! they are approximately f / 4. The 4 values on the innermost loop are for + !! u-velocities to the southwest, southeast, northwest and northeast. + integer, intent(in) :: isvf !< The starting i-index of the largest valid range for tracer points + integer, intent(in) :: ievf !< The ending i-index of the largest valid range for tracer points + integer, intent(in) :: jsvf !< The starting j-index of the largest valid range for tracer points + integer, intent(in) :: jevf !< The ending j-index of the largest valid range for tracer points + + ! real :: C1_3 ! One third [nondim] + integer :: i, j + + if (CS%Sadourny) then + !$OMP parallel do default(shared) + do J=jsvf-1,jevf ; do i=isvf-1,ievf+1 + f_4_v(1,i,J) = CS%OBCmask_v(i,J) * DCor_u(I-1,j) * q(I-1,J) + f_4_v(2,i,J) = CS%OBCmask_v(i,J) * DCor_u(I,j) * q(I,J) + f_4_v(4,i,J) = CS%OBCmask_v(i,J) * DCor_u(I,j+1) * q(I,J) + f_4_v(3,i,J) = CS%OBCmask_v(i,J) * DCor_u(I-1,j+1) * q(I-1,J) + enddo ; enddo + !$OMP parallel do default(shared) + do j=jsvf-1,jevf+1 ; do I=isvf-1,ievf + f_4_u(4,I,j) = CS%OBCmask_u(I,j) * DCor_v(i+1,J) * q(I,J) + f_4_u(3,I,j) = CS%OBCmask_u(I,j) * DCor_v(i,J) * q(I,J) + f_4_u(1,I,j) = CS%OBCmask_u(I,j) * DCor_v(i,J-1) * q(I,J-1) + f_4_u(2,I,j) = CS%OBCmask_u(I,j) * DCor_v(i+1,J-1) * q(I,J-1) + enddo ; enddo + else !### if (CS%answer_date < 20250601) then ! Uncomment this later. + !$OMP parallel do default(shared) + do J=jsvf-1,jevf ; do i=isvf-1,ievf+1 + f_4_v(1,i,J) = CS%OBCmask_v(i,J) * DCor_u(I-1,j) * ((q(I,J) + q(I-1,J-1)) + q(I-1,J)) / 3.0 + f_4_v(2,i,J) = CS%OBCmask_v(i,J) * DCor_u(I,j) * (q(I,J) + (q(I-1,J) + q(I,J-1))) / 3.0 + f_4_v(4,i,J) = CS%OBCmask_v(i,J) * DCor_u(I,j+1) * (q(I,J) + (q(I-1,J) + q(I,J+1))) / 3.0 + f_4_v(3,i,J) = CS%OBCmask_v(i,J) * DCor_u(I-1,j+1) * ((q(I,J) + q(I-1,J+1)) + q(I-1,J)) / 3.0 + enddo ; enddo + !$OMP parallel do default(shared) + do j=jsvf-1,jevf+1 ; do I=isvf-1,ievf + f_4_u(4,I,j) = CS%OBCmask_u(I,j) * DCor_v(i+1,J) * (q(I,J) + (q(I+1,J) + q(I,J-1))) / 3.0 + f_4_u(3,I,j) = CS%OBCmask_u(I,j) * DCor_v(i,J) * (q(I,J) + (q(I-1,J) + q(I,J-1))) / 3.0 + f_4_u(1,I,j) = CS%OBCmask_u(I,j) * DCor_v(i,J-1) * ((q(I,J) + q(I-1,J-1)) + q(I,J-1)) / 3.0 + f_4_u(2,I,j) = CS%OBCmask_u(I,j) * DCor_v(i+1,J-1) * ((q(I,J) + q(I+1,J-1)) + q(I,J-1)) / 3.0 + enddo ; enddo + ! else + ! C1_3 = 1.0 / 3.0 + ! !$OMP parallel do default(shared) + ! do J=jsvf-1,jevf ; do i=isvf-1,ievf+1 + ! f_4_v(1,i,J) = CS%OBCmask_v(i,J) * DCor_u(I-1,j) * ((q(I,J) + q(I-1,J-1)) + q(I-1,J)) * C1_3 + ! f_4_v(2,i,J) = CS%OBCmask_v(i,J) * DCor_u(I,j) * (q(I,J) + (q(I-1,J) + q(I,J-1))) * C1_3 + ! f_4_v(4,i,J) = CS%OBCmask_v(i,J) * DCor_u(I,j+1) * (q(I,J) + (q(I-1,J) + q(I,J+1))) * C1_3 + ! f_4_v(3,i,J) = CS%OBCmask_v(i,J) * DCor_u(I-1,j+1) * ((q(I,J) + q(I-1,J+1)) + q(I-1,J)) * C1_3 + ! enddo ; enddo + ! !$OMP parallel do default(shared) + ! do j=jsvf-1,jevf+1 ; do I=isvf-1,ievf + ! f_4_u(4,I,j) = CS%OBCmask_u(I,j) * DCor_v(i+1,J) * (q(I,J) + (q(I+1,J) + q(I,J-1))) * C1_3 + ! f_4_u(3,I,j) = CS%OBCmask_u(I,j) * DCor_v(i,J) * (q(I,J) + (q(I-1,J) + q(I,J-1))) * C1_3 + ! f_4_u(1,I,j) = CS%OBCmask_u(I,j) * DCor_v(i,J-1) * ((q(I,J) + q(I-1,J-1)) + q(I,J-1)) * C1_3 + ! f_4_u(2,I,j) = CS%OBCmask_u(I,j) * DCor_v(i+1,J-1) * ((q(I,J) + q(I+1,J-1)) + q(I,J-1)) * C1_3 + ! enddo ; enddo endif - if (associated(ADp%diag_hfrac_u)) then - do k=1,nz ; do j=js,je ; do I=is-1,ie - ADp%diag_hfrac_u(I,j,k) = CS%frhatu(I,j,k) - enddo ; enddo ; enddo +end subroutine btstep_find_Cor + +!> Do a CFL-based truncation of any excessively large batotropic velocities. +!! This should only be used as desperate debugging measure. +subroutine truncate_velocities(ubt, vbt, dt, G, CS, isv, iev, jsv, jev) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(barotropic_CS), intent(inout) :: CS !< Barotropic control structure + real, intent(inout) :: ubt(SZIBW_(CS),SZJW_(CS)) !< The zonal barotropic velocity [L T-1 ~> m s-1] + real, intent(inout) :: vbt(SZIW_(CS),SZJBW_(CS)) !< The meridional barotropic velocity [L T-1 ~> m s-1] + real, intent(in) :: dt !< The time increment to integrate over [T ~> s]. + integer, intent(in) :: isv !< The starting valid tracer array i-index that is being worked on + integer, intent(in) :: iev !< The ending valid tracer array i-index that is being worked on + integer, intent(in) :: jsv !< The starting valid tracer array j-index that is being worked on + integer, intent(in) :: jev !< The ending valid tracer array j-index being that is worked on + + integer :: i, j + + if (CS%clip_velocity) then + do j=jsv,jev ; do I=isv-1,iev + if ((ubt(I,j) * (dt * G%dy_Cu(I,j))) * G%IareaT(i+1,j) < -CS%CFL_trunc) then + ! Add some error reporting later. + ubt(I,j) = (-0.95*CS%CFL_trunc) * (G%areaT(i+1,j) / (dt * G%dy_Cu(I,j))) + elseif ((ubt(I,j) * (dt * G%dy_Cu(I,j))) * G%IareaT(i,j) > CS%CFL_trunc) then + ! Add some error reporting later. + ubt(I,j) = (0.95*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dy_Cu(I,j))) + endif + enddo ; enddo + do J=jsv-1,jev ; do i=isv,iev + if ((vbt(i,J) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j+1) < -CS%CFL_trunc) then + ! Add some error reporting later. + vbt(i,J) = (-0.9*CS%CFL_trunc) * (G%areaT(i,j+1) / (dt * G%dx_Cv(i,J))) + elseif ((vbt(i,J) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j) > CS%CFL_trunc) then + ! Add some error reporting later. + vbt(i,J) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dx_Cv(i,J))) + endif + enddo ; enddo endif - if (associated(ADp%diag_hfrac_v)) then - do k=1,nz ; do J=js-1,je ; do i=is,ie - ADp%diag_hfrac_v(i,J,k) = CS%frhatv(i,J,k) - enddo ; enddo ; enddo + +end subroutine truncate_velocities + + +!> A routine to set eta_pred and the running time integral of uhbt and vhbt. +subroutine btloop_eta_predictor(n, dtbt, ubt, vbt, eta, ubt_int, vbt_int, uhbt, vhbt, uhbt0, vhbt0, & + uhbt_int, vhbt_int, BTCL_u, BTCL_v, Datu, Datv, & + eta_IC, eta_src, eta_pred, isv, iev, jsv, jev, & + integral_BT_cont, use_BT_cont, G, US, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(barotropic_CS), intent(in) :: CS !< Barotropic control structure + integer, intent(in) :: n !< The current step in loop of timesteps + real, intent(in) :: dtbt !< The barotropic time step [T ~> s] + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: & + ubt !< The zonal barotropic velocity [L T-1 ~> m s-1]. + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: & + vbt !< The zonal barotropic velocity [L T-1 ~> m s-1]. + real, target, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: & + eta !< The barotropic free surface height anomaly or column mass + !! anomaly [H ~> m or kg m-2] + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: & + ubt_int !< The running time integral of ubt over the time steps [L ~> m]. + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: & + vbt_int !< The running time integral of vbt over the time steps [L ~> m]. + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: & + uhbt0 !< The difference between the sum of the layer zonal thickness + !! fluxes and the barotropic thickness flux using the same + !! velocity [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: & + vhbt0 !< The difference between the sum of the layer meridional + !! thickness fluxes and the barotropic thickness flux using + !! the same velocities [H L2 T-1 ~> m3 s-1 or kg s-1]. + type(local_BT_cont_u_type), dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: & + BTCL_u !< A repackaged version of the u-point information in BT_cont. + type(local_BT_cont_v_type), dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: & + BTCL_v !< A repackaged version of the v-point information in BT_cont. + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: & + Datu !< Basin depth at u-velocity grid points times the y-grid + !! spacing [H L ~> m2 or kg m-1]. + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: & + Datv !< Basin depth at v-velocity grid points times the x-grid + !! spacing [H L ~> m2 or kg m-1]. + real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: & + eta_IC !< A local copy of the initial 2-D eta field (eta_in) [H ~> m or kg m-2] + real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: & + eta_src !< The source of eta per barotropic timestep [H ~> m or kg m-2]. + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(inout) :: & + uhbt !< The zonal barotropic thickness fluxes [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(inout) :: & + vhbt !< The meridional barotropic thickness fluxes [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(inout) :: & + uhbt_int !< The running time integral of uhbt over the time steps [H L2 ~> m3 or kg]. + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(inout) :: & + vhbt_int !< The running time integral of vhbt over the time steps [H L2 ~> m3 or kg]. + real, target, dimension(SZIW_(CS),SZJW_(CS)), intent(inout) :: & + eta_pred !< A predictor value of eta [H ~> m or kg m-2] like eta. + integer, intent(in) :: isv !< The starting i-index of eta_pred to calculate + integer, intent(in) :: iev !< The ending i-index of eta_pred to calculate + integer, intent(in) :: jsv !< The starting j-index of eta_pred to calculate + integer, intent(in) :: jev !< The ending j-index of eta_pred to calculate + logical, intent(in) :: integral_BT_cont !< If true, update the barotropic continuity equation directly + !! from the initial condition using the time-integrated barotropic velocity. + logical, intent(in) :: use_BT_cont !< If true, use the information in the BT_cont_type to determine + !! barotropic transports as a function of the barotropic velocities. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + integer :: i, j + + !$OMP parallel default(shared) + if (integral_BT_cont) then + !$OMP do + do j=jsv-1,jev+1 ; do I=isv-2,iev+1 + uhbt_int(I,j) = find_uhbt(ubt_int(I,j) + dtbt*ubt(I,j), BTCL_u(I,j)) + n*dtbt*uhbt0(I,j) + enddo ; enddo + !$OMP end do nowait + !$OMP do + do J=jsv-2,jev+1 ; do i=isv-1,iev+1 + vhbt_int(i,J) = find_vhbt(vbt_int(i,J) + dtbt*vbt(i,J), BTCL_v(i,J)) + n*dtbt*vhbt0(i,J) + enddo ; enddo + !$OMP do + do j=jsv-1,jev+1 ; do i=isv-1,iev+1 + eta_pred(i,j) = (eta_IC(i,j) + n*eta_src(i,j)) + CS%IareaT_OBCmask(i,j) * & + ((uhbt_int(I-1,j) - uhbt_int(I,j)) + (vhbt_int(i,J-1) - vhbt_int(i,J))) + enddo ; enddo + elseif (use_BT_cont) then + !$OMP do + do j=jsv-1,jev+1 ; do I=isv-2,iev+1 + uhbt(I,j) = find_uhbt(ubt(I,j), BTCL_u(I,j)) + uhbt0(I,j) + enddo ; enddo + !$OMP do + do J=jsv-2,jev+1 ; do i=isv-1,iev+1 + vhbt(i,J) = find_vhbt(vbt(i,J), BTCL_v(i,J)) + vhbt0(i,J) + enddo ; enddo + !$OMP do + do j=jsv-1,jev+1 ; do i=isv-1,iev+1 + eta_pred(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * CS%IareaT_OBCmask(i,j)) * & + ((uhbt(I-1,j) - uhbt(I,j)) + (vhbt(i,J-1) - vhbt(i,J))) + enddo ; enddo + else + !$OMP do + do j=jsv-1,jev+1 ; do i=isv-1,iev+1 + eta_pred(i,j) = (eta(i,j) + eta_src(i,j)) + (dtbt * CS%IareaT_OBCmask(i,j)) * & + (((Datu(I-1,j)*ubt(I-1,j) + uhbt0(I-1,j)) - & + (Datu(I,j)*ubt(I,j) + uhbt0(I,j))) + & + ((Datv(i,J-1)*vbt(i,J-1) + vhbt0(i,J-1)) - & + (Datv(i,J)*vbt(i,J) + vhbt0(i,J)))) + enddo ; enddo + endif + !$OMP end parallel + +end subroutine btloop_eta_predictor + +subroutine btloop_find_PF(PFu, PFv, isv, iev, jsv, jev, eta_PF_BT, eta_PF, & + gtot_N, gtot_S, gtot_E, gtot_W, dgeo_de, find_etaav, & + wt_accel2_n, eta_sum, v_first, G, US, CS) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(barotropic_CS), intent(inout) :: CS !< Barotropic control structure + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(inout) :: & + PFu !< The anomalous zonal pressure force acceleration [L T-2 ~> m s-2]. + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(inout) :: & + PFv !< The meridional pressure force acceleration [L T-2 ~> m s-2]. + integer, intent(in) :: isv !< The starting i-index of eta being set in ths loop + integer, intent(in) :: iev !< The ending i-index of eta_pred being set in ths loop + integer, intent(in) :: jsv !< The starting j-index of eta_pred being set in ths loop + integer, intent(in) :: jev !< The ending j-index of eta_pred being set in ths loop + real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: & + eta_PF_BT !< The eta array (either the SSH anomaly or column mass anomaly) that + !! determines the barotropic pressure force [H ~> m or kg m-2] + real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: & + eta_PF !< The input 2-D eta field (either SSH anomaly or column mass anomaly) + !! that was used to calculate the input pressure gradient + !! accelerations [H ~> m or kg m-2]. + real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: & + gtot_N !< The effective total reduced gravity used to relate free surface height + !! deviations to pressure forces (including GFS and baroclinic contributions) + !! in the barotropic momentum equations half a grid-point to the north of a + !! thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: & + gtot_S !< The effective total reduced gravity used to relate free surface height + !! deviations to pressure forces (including GFS and baroclinic contributions) + !! in the barotropic momentum equations half a grid-point to the south of a + !! thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + !! (See Hallberg, J Comp Phys 1997 for a discussion of gtot_E and gtot_W.) + real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: & + gtot_E !< The effective total reduced gravity used to relate free surface height + !! deviations to pressure forces (including GFS and baroclinic contributions) + !! in the barotropic momentum equations half a grid-point to the east of a + !! thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: & + gtot_W !< The effective total reduced gravity used to relate free surface height + !! deviations to pressure forces (including GFS and baroclinic contributions) + !! in the barotropic momentum equations half a grid-point to the west of a + !! thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + !! (See Hallberg, J Comp Phys 1997 for a discussion of gtot_E and gtot_W.) + real, intent(in) :: dgeo_de !< The constant of proportionality between geopotential and + !! sea surface height [nondim]. It is of order 1, but for stability this + !! may be made larger than the physical problem would suggest. + logical, intent(in) :: find_etaav !< If true, diagnose the time mean value of eta + real, intent(in) :: wt_accel2_n !< The weighting value of wt_accel2 at step n. + real, dimension(SZIW_(CS),SZJW_(CS)), intent(inout) :: & + eta_sum !< A weighted running sum of eta summed across the timesteps [H ~> m or kg m-2] + logical, intent(in) :: v_first !< If true, update the v-velocity first with the present loop iteration + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + integer :: i, j, js_u, je_u, is_v, ie_v + + ! Ensure that the extra points used for the temporally staggered Coriolis terms are updated. + if (v_first) then + is_v = isv-1 ; ie_v = iev+1 ; js_u = jsv ; je_u = jev + else + is_v = isv ; ie_v = iev ; js_u = jsv-1 ; je_u = jev+1 endif - if (use_BT_cont .and. associated(ADp%diag_hu)) then - do k=1,nz ; do j=js,je ; do I=is-1,ie - ADp%diag_hu(I,j,k) = BT_cont%h_u(I,j,k) - enddo ; enddo ; enddo + !$OMP do schedule(static) + do j=js_u,je_u ; do I=isv-1,iev + PFu(I,j) = (((eta_PF_BT(i,j)-eta_PF(i,j))*gtot_E(i,j)) - & + ((eta_PF_BT(i+1,j)-eta_PF(i+1,j))*gtot_W(i+1,j))) * & + dgeo_de * CS%IdxCu(I,j) + enddo ; enddo + !$OMP end do nowait + + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=is_v,ie_v + PFv(i,J) = (((eta_PF_BT(i,j)-eta_PF(i,j))*gtot_N(i,j)) - & + ((eta_PF_BT(i,j+1)-eta_PF(i,j+1))*gtot_S(i,j+1))) * & + dgeo_de * CS%IdyCv(i,J) + enddo ; enddo + !$OMP end do nowait + + if (find_etaav .and. (abs(wt_accel2_n) > 0.0)) then + !$OMP do + do j=G%jsc,G%jec ; do i=G%isc,G%iec + eta_sum(i,j) = eta_sum(i,j) + wt_accel2_n * eta_PF_BT(i,j) + enddo ; enddo + !$OMP end do nowait endif - if (use_BT_cont .and. associated(ADp%diag_hv)) then - do k=1,nz ; do J=js-1,je ; do i=is,ie - ADp%diag_hv(i,J,k) = BT_cont%h_v(i,J,k) - enddo ; enddo ; enddo + +end subroutine btloop_find_PF + +!> This routine adds a dynamic pressure force based on the temporal changes in the predicted value +!! of eta, perhaps as an effective divergence damping to emulate the rigidity of an ice-sheet. +subroutine btloop_add_dyn_PF(PFu, PFv, eta_pred, eta, dyn_coef_eta, p_surf_dyn, & + isv, iev, jsv, jev, v_first, G, US, CS) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(barotropic_CS), intent(inout) :: CS !< Barotropic control structure + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(inout) :: & + PFu !< The anomalous zonal pressure force acceleration [L T-2 ~> m s-2]. + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(inout) :: & + PFv !< The meridional pressure force acceleration [L T-2 ~> m s-2]. + real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: & + eta_pred !< The updated eta field (either SSH anomaly or column mass anomaly) that is + !! used to estimate the divergence that is to be damped [H ~> m or kg m-2]. + real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: & + eta !< The previous eta field (either SSH anomaly or column mass anomaly) that is + !! used to estimate the divergence that is to be damped [H ~> m or kg m-2]. + real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: & + dyn_coef_eta !< The coefficient relating the changes in eta to the dynamic surface pressure + !! under rigid ice [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. + real, dimension(SZIW_(CS),SZJW_(CS)), intent(inout) :: & + p_surf_dyn !< A dynamic surface pressure under rigid ice [L2 T-2 ~> m2 s-2]. + integer, intent(in) :: isv !< The starting i-index of eta being set in ths loop + integer, intent(in) :: iev !< The ending i-index of eta_pred being set in ths loop + integer, intent(in) :: jsv !< The starting j-index of eta_pred being set in ths loop + integer, intent(in) :: jev !< The ending j-index of eta_pred being set in ths loop + logical, intent(in) :: v_first !< If true, update the v-velocity first with the present loop iteration + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + integer :: i, j, js_u, je_u, is_v, ie_v + + ! Ensure that the extra points used for the temporally staggered Coriolis terms are updated. + if (v_first) then + is_v = isv-1 ; ie_v = iev+1 ; js_u = jsv ; je_u = jev + else + is_v = isv ; ie_v = iev ; js_u = jsv-1 ; je_u = jev+1 endif - if (associated(ADp%visc_rem_u)) then - do k=1,nz ; do j=js,je ; do I=is-1,ie - ADp%visc_rem_u(I,j,k) = visc_rem_u(I,j,k) - enddo ; enddo ; enddo + + ! Use the change in eta to estimate the flow divergence and dynamic pressure. + !$OMP do + do j=jsv-1,jev+1 ; do i=isv-1,iev+1 + p_surf_dyn(i,j) = dyn_coef_eta(i,j) * (eta_pred(i,j) - eta(i,j)) + enddo ; enddo + + !$OMP do schedule(static) + do j=js_u,je_u ; do I=isv-1,iev + PFu(I,j) = PFu(I,j) + (p_surf_dyn(i,j) - p_surf_dyn(i+1,j)) * CS%IdxCu(I,j) + enddo ; enddo + !$OMP end do nowait + !$OMP do schedule(static) + do J=jsv-1,jev ; do i=is_v,ie_v + PFv(i,J) = PFv(i,J) + (p_surf_dyn(i,j) - p_surf_dyn(i,j+1)) * CS%IdyCv(i,J) + enddo ; enddo + !$OMP end do nowait + +end subroutine btloop_add_dyn_PF + +!> Update meridional velocity. +subroutine btloop_update_v(dtbt, ubt, vbt, v_accel_bt, & + Cor_v, PFv, is_v, ie_v, Js_v, Je_v, f_4_v, & + bt_rem_v, BT_force_v, Cor_ref_v, Rayleigh_v, & + wt_accel_n, G, US, CS, Cor_bracket_bug) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(barotropic_CS), intent(inout) :: CS !< Barotropic control structure + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: & + ubt !< The zonal barotropic velocity [L T-1 ~> m s-1]. + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(inout) :: & + vbt !< The meridional barotropic velocity [L T-1 ~> m s-1]. + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(inout) :: & + v_accel_bt !< The difference between the meridional acceleration from the + !! barotropic calculation and BT_force_v [L T-2 ~> m s-2]. + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(inout) :: & + Cor_v !< The meridional Coriolis acceleration [L T-2 ~> m s-2] + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: & + PFv !< The meridional pressure force acceleration [L T-2 ~> m s-2]. + real, dimension(4,SZIW_(CS),SZJBW_(CS)), intent(in) :: & + f_4_v !< The terms giving the contribution to the Coriolis acceleration at a meridional + !! velocity point from the neighboring meridional velocity anomalies [T-1 ~> s-1]. + !! These are the products of thicknesses at u points and appropriately staggered + !! averaged pseudo potential vorticities, but with sufficiently smooth topography + !! they are approximately f / 4. The 4 values on the innermost loop are for + !! u-velocities to the southwest, southeast, northwest and northeast. + integer, intent(in) :: is_v !< The starting i-index of the range of v-point values to calculate + integer, intent(in) :: ie_v !< The ending i-index of the range of v-point values to calculate + integer, intent(in) :: Js_v !< The starting j-index of the range of v-point values to calculate + integer, intent(in) :: Je_v !< The ending j-index of the range of v-point values to calculate + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: & + bt_rem_v !< The fraction of the barotropic meridional velocity that + !! remains after a time step, the rest being lost to bottom + !! drag [nondim]. bt_rem_v is between 0 and 1. + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: & + BT_force_v !< The vertical average of all of the v-accelerations that are + !! not explicitly included in the barotropic equation [L T-2 ~> m s-2]. + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: & + Cor_ref_v !< The meridional barotropic Coriolis acceleration due + !! to the reference velocities [L T-2 ~> m s-2]. + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: & + Rayleigh_v !< A Rayleigh drag timescale operating at v-points for drag parameterizations + !! that introduced directly into the barotropic solver rather than coming + !! in via the visc_rem_v arrays from the layered equations [T-1 ~> s-1] + real, intent(in) :: wt_accel_n !< The raw or relative weights of each of the barotropic timesteps + !! in determining the average accelerations [nondim] + real, intent(in) :: dtbt !< The barotropic time step [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + logical, optional, intent(in) :: Cor_bracket_bug !< If present and true, use an order of operations that is + !! not bitwise rotationally symmetric in the meridional Coriolis term + + ! Local variables + logical :: use_bracket_bug + integer :: i, j + + use_bracket_bug = .false. ; if (present(Cor_bracket_bug)) use_bracket_bug = Cor_bracket_bug + + ! The bracket bug only applies if v is second, use ioff to check. + if (use_bracket_bug) then + !$OMP do schedule(static) + do J=Js_v,Je_v ; do i=is_v,ie_v + Cor_v(i,J) = -1.0*(((f_4_v(1,i,J) * ubt(I-1,j)) + (f_4_v(2,i,J) * ubt(I,j))) + & + ((f_4_v(4,i,J) * ubt(I,j+1)) + (f_4_v(3,i,J) * ubt(I-1,j+1)))) - Cor_ref_v(i,J) + enddo ; enddo + !$OMP end do nowait + else + !$OMP do schedule(static) + do J=Js_v,Je_v ; do i=is_v,ie_v + Cor_v(i,J) = -1.0*(((f_4_v(1,i,J) * ubt(I-1,j)) + (f_4_v(4,i,J) * ubt(I,j+1))) + & + ((f_4_v(2,i,J) * ubt(I,j)) + (f_4_v(3,i,J) * ubt(I-1,j+1)))) - Cor_ref_v(i,J) + enddo ; enddo + !$OMP end do nowait endif - if (associated(ADp%visc_rem_u)) then - do k=1,nz ; do J=js-1,je ; do i=is,ie - ADp%visc_rem_v(i,J,k) = visc_rem_v(i,J,k) - enddo ; enddo ; enddo + + !$OMP do schedule(static) + ! This updates the v-velocity, except at OBC points. + do J=Js_v,Je_v ; do i=is_v,ie_v + vbt(i,J) = bt_rem_v(i,J) * (vbt(i,J) + & + dtbt * ((BT_force_v(i,J) + Cor_v(i,J)) + PFv(i,J))) + if (abs(vbt(i,J)) < CS%vel_underflow) vbt(i,J) = 0.0 + enddo ; enddo + !$OMP end do nowait + + if (CS%linear_wave_drag) then + !$OMP do schedule(static) + do J=Js_v,Je_v ; do i=is_v,ie_v + v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel_n * & + ((Cor_v(i,J) + PFv(i,J)) - vbt(i,J)*Rayleigh_v(i,J)) + enddo ; enddo + else + !$OMP do schedule(static) + do J=Js_v,Je_v ; do i=is_v,ie_v + v_accel_bt(i,J) = v_accel_bt(i,J) + wt_accel_n * (Cor_v(i,J) + PFv(i,J)) + enddo ; enddo endif - if (G%nonblocking_updates) then - if (find_etaav) call complete_group_pass(CS%pass_etaav, G%Domain) - call complete_group_pass(CS%pass_ubta_uhbta, G%Domain) +end subroutine btloop_update_v + +!> Update zonal velocity. +subroutine btloop_update_u(dtbt, ubt, vbt, u_accel_bt, & + Cor_u, PFu, Is_u, Ie_u, js_u, je_u, f_4_u, & + bt_rem_u, BT_force_u, Cor_ref_u, Rayleigh_u, & + wt_accel_n, G, US, CS) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(barotropic_CS), intent(inout) :: CS !< Barotropic control structure + real, intent(in) :: dtbt !< The barotropic time step [T ~> s]. + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(inout) :: & + ubt !< The zonal barotropic velocity [L T-1 ~> m s-1]. + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: & + vbt !< The meridional barotropic velocity [L T-1 ~> m s-1]. + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(inout) :: & + u_accel_bt !! The difference between the zonal acceleration from the + !< barotropic calculation and BT_force_v [L T-2 ~> m s-2]. + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(inout) :: & + Cor_u !< The anomalous zonal Coriolis acceleration [L T-2 ~> m s-2] + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: & + PFu !< The anomalous zonal pressure force acceleration [L T-2 ~> m s-2]. + integer, intent(in) :: Is_u !< The starting i-index of the range of u-point values to calculate + integer, intent(in) :: Ie_u !< The ending i-index of the range of u-point values to calculate + integer, intent(in) :: js_u !< The starting j-index of the range of u-point values to calculate + integer, intent(in) :: je_u !< The ending j-index of the range of u-point values to calculate + real, dimension(4,SZIBW_(CS),SZJW_(CS)), intent(in) :: & + f_4_u !< The terms giving the contribution to the Coriolis acceleration at a zonal + !! velocity point from the neighboring meridional velocity anomalies [T-1 ~> s-1]. + !! These are the products of thicknesses at v points and appropriately staggered + !! averaged pseudo potential vorticities, but with sufficiently smooth topography + !! they are approximately f / 4. The 4 values on the innermost loop are for + !! v-velocities to the southwest, southeast, northwest and northeast. + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: & + bt_rem_u !< The fraction of the barotropic meridional velocity that + !! remains after a time step, the rest being lost to bottom + !! drag [nondim]. bt_rem_v is between 0 and 1. + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: & + BT_force_u !< The vertical average of all of the v-accelerations that are + !! not explicitly included in the barotropic equation [L T-2 ~> m s-2]. + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: & + Cor_ref_u !< The meridional barotropic Coriolis acceleration due + !! to the reference velocities [L T-2 ~> m s-2]. + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: & + Rayleigh_u !< A Rayleigh drag timescale operating at u-points for drag parameterizations + !! that introduced directly into the barotropic solver rather than coming + !! in via the visc_rem_u arrays from the layered equations [T-1 ~> s-1]. + real, intent(in) :: wt_accel_n !< The raw or relative weights of each of the barotropic timesteps + !! in determining the average accelerations [nondim] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + integer :: i, j + + !$OMP do schedule(static) + do j=js_u,je_u ; do I=Is_u,Ie_u + Cor_u(I,j) = (((f_4_u(4,I,j) * vbt(i+1,J)) + (f_4_u(1,I,j) * vbt(i,J-1))) + & + ((f_4_u(3,I,j) * vbt(i,J)) + (f_4_u(2,I,j) * vbt(i+1,J-1)))) - & + Cor_ref_u(I,j) + + ubt(I,j) = bt_rem_u(I,j) * (ubt(I,j) + & + dtbt * ((BT_force_u(I,j) + Cor_u(I,j)) + PFu(I,j))) + if (abs(ubt(I,j)) < CS%vel_underflow) ubt(I,j) = 0.0 + enddo ; enddo + !$OMP end do nowait + + if (CS%linear_wave_drag) then + !$OMP do schedule(static) + do j=js_u,je_u ; do I=Is_u,Ie_u + u_accel_bt(I,j) = u_accel_bt(I,j) + wt_accel_n * & + ((Cor_u(I,j) + PFu(I,j)) - ubt(I,j)*Rayleigh_u(I,j)) + enddo ; enddo + !$OMP end do nowait + else + !$OMP do schedule(static) + do j=js_u,je_u ; do I=Is_u,Ie_u + u_accel_bt(I,j) = u_accel_bt(I,j) + wt_accel_n * (Cor_u(I,j) + PFu(I,j)) + enddo ; enddo + !$OMP end do nowait endif -end subroutine btstep +end subroutine btloop_update_u + + +!> Calculate the zonal and meridional velocity from the 3-D velocity. +subroutine btstep_ubt_from_layer(U_in, V_in, wt_u, wt_v, ubt, vbt, G, GV, CS) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(barotropic_CS), intent(inout) :: CS !< Barotropic control structure + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + real, intent(in) :: U_in(SZIB_(G),SZJ_(G),SZK_(GV)) !< The initial (3-D) zonal velocity [L T-1 ~> m s-1] + real, intent(in) :: V_in(SZI_(G),SZJB_(G),SZK_(GV)) !< The initial (3-D) meridional velocity [L T-1 ~> m s-1] + real, intent(in) :: wt_u(SZIB_(G),SZJ_(G),SZK_(GV)) !< The normalized weights to be used in calculating + !! zonal barotropic velocities, possibly with sums + !! less than one due to viscous losses [nondim] + real, intent(in) :: wt_v(SZI_(G),SZJB_(G),SZK_(GV)) !< The normalized weights to be used in calculating + !! meridional barotropic velocities, possibly with + !! sums less than one due to viscous losses [nondim] + real, intent(out) :: ubt(SZIBW_(CS),SZJW_(CS)) !< The zonal barotropic velocity [L T-1 ~> m s-1] + real, intent(out) :: vbt(SZIW_(CS),SZJBW_(CS)) !< The meridional barotropic velocity [L T-1 ~> m s-1] + + ! Local variables + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke -!> This subroutine automatically determines an optimal value for dtbt based -!! on some state of the ocean. -subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) + ubt(:,:) = 0.0 ; vbt(:,:) = 0.0 + + !$OMP parallel do default(shared) + do j=js,je ; do k=1,nz ; do I=is-1,ie + ubt(I,j) = ubt(I,j) + wt_u(I,j,k) * U_in(I,j,k) + enddo ; enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do k=1,nz ; do i=is,ie + vbt(i,J) = vbt(i,J) + wt_v(i,J,k) * V_in(i,J,k) + enddo ; enddo ; enddo + + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + if (abs(ubt(I,j)) < CS%vel_underflow) ubt(I,j) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + if (abs(vbt(i,J)) < CS%vel_underflow) vbt(i,J) = 0.0 + enddo ; enddo + +end subroutine btstep_ubt_from_layer + + +!> Calculate the zonal and meridional acceleration of each layer due to the barotropic calculation. +subroutine btstep_layer_accel(dt, u_accel_bt, v_accel_bt, pbce, gtot_E, gtot_W, gtot_N, gtot_S, & + e_anom, G, GV, CS, accel_layer_u, accel_layer_v) + type(barotropic_CS), intent(inout) :: CS !< Barotropic control structure + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, intent(in) :: dt !< The time increment to integrate over [T ~> s]. + real, dimension(SZIBW_(CS),SZJW_(CS)), intent(in) :: & + u_accel_bt !< The difference between the zonal acceleration from the + !! barotropic calculation and BT_force_u [L T-2 ~> m s-2]. + real, dimension(SZIW_(CS),SZJBW_(CS)), intent(in) :: & + v_accel_bt !< The difference between the meridional acceleration from the + !! barotropic calculation and BT_force_v [L T-2 ~> m s-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: pbce !< The baroclinic pressure anomaly in each layer + !! due to free surface height anomalies + !! [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: & + gtot_E !< The effective total reduced gravity used to relate free surface height + !! deviations to pressure forces (including GFS and baroclinic contributions) + !! in the barotropic momentum equations half a grid-point to the east of a + !! thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: & + gtot_W !< The effective total reduced gravity used to relate free surface height + !! deviations to pressure forces (including GFS and baroclinic contributions) + !! in the barotropic momentum equations half a grid-point to the west of a + !! thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: & + gtot_N !< The effective total reduced gravity used to relate free surface height + !! deviations to pressure forces (including GFS and baroclinic contributions) + !! in the barotropic momentum equations half a grid-point to the north of a + !! thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + real, dimension(SZIW_(CS),SZJW_(CS)), intent(in) :: & + gtot_S !< The effective total reduced gravity used to relate free surface height + !! deviations to pressure forces (including GFS and baroclinic contributions) + !! in the barotropic momentum equations half a grid-point to the south of a + !! thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + !! (See Hallberg, J Comp Phys 1997 for a discussion of gtot_E, etc.) + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: & + e_anom !< The anomaly in the sea surface height or column mass + !! averaged between the beginning and end of the time step, + !! relative to eta_PF, with SAL effects included [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(out) :: accel_layer_u !< The zonal acceleration of each layer due + !! to the barotropic calculation [L T-2 ~> m s-2]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: accel_layer_v !< The meridional acceleration of each layer + !! due to the barotropic calculation [L T-2 ~> m s-2]. + + ! Local variables + real :: accel_underflow ! An acceleration that is so small it should be zeroed out [L T-2 ~> m s-2]. + real :: Idt ! The inverse of dt [T-1 ~> s-1]. + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + Idt = 1.0 / dt + accel_underflow = CS%vel_underflow * Idt + + ! Now calculate each layer's accelerations. + !$OMP parallel do default(shared) + do k=1,nz + do j=js,je ; do I=is-1,ie + accel_layer_u(I,j,k) = (u_accel_bt(I,j) - & + (((pbce(i+1,j,k) - gtot_W(i+1,j)) * e_anom(i+1,j)) - & + ((pbce(i,j,k) - gtot_E(i,j)) * e_anom(i,j))) * CS%IdxCu(I,j) ) + if (abs(accel_layer_u(I,j,k)) < accel_underflow) accel_layer_u(I,j,k) = 0.0 + enddo ; enddo + do J=js-1,je ; do i=is,ie + accel_layer_v(i,J,k) = (v_accel_bt(i,J) - & + (((pbce(i,j+1,k) - gtot_S(i,j+1)) * e_anom(i,j+1)) - & + ((pbce(i,j,k) - gtot_N(i,j)) * e_anom(i,j))) * CS%IdyCv(i,J) ) + if (abs(accel_layer_v(i,J,k)) < accel_underflow) accel_layer_v(i,J,k) = 0.0 + enddo ; enddo + enddo + +end subroutine btstep_layer_accel + +!> This subroutine automatically determines an optimal value for dtbt based on some state of the ocean. Either pbce or +!! gtot_est is required to calculate gravitational acceleration. Column thickness can be estimated using BT_cont, eta, +!! and SSH_add (default=0), with priority given in that order. The subroutine sets CS%dtbt_max and CS%dtbt. +subroutine set_dtbt(G, GV, US, CS, pbce, gtot_est, BT_cont, eta, SSH_add) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(barotropic_CS), intent(inout) :: CS !< Barotropic control structure - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: eta !< The barotropic free surface - !! height anomaly or column mass anomaly [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(in) :: pbce !< The baroclinic pressure - !! anomaly in each layer due to free surface - !! height anomalies [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. - type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe - !! the effective open face areas as a - !! function of barotropic flow. - real, optional, intent(in) :: gtot_est !< An estimate of the total gravitational - !! acceleration [L2 Z-1 T-2 ~> m s-2]. - real, optional, intent(in) :: SSH_add !< An additional contribution to SSH to - !! provide a margin of error when - !! calculating the external wave speed [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: pbce !< The baroclinic pressure anomaly in each layer due to free + !! surface height anomalies [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + real, optional, intent(in) :: gtot_est !< An estimate of the total gravitational acceleration + !! [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe the effective open + !! face areas as a function of barotropic flow. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: eta !< The barotropic free surface height anomaly or column mass + !! anomaly [H ~> m or kg m-2]. + real, optional, intent(in) :: SSH_add !< An additional contribution to SSH to provide a margin of + !! error when calculating the external wave speed [Z ~> m]. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & @@ -2776,7 +3731,6 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) logical :: use_BT_cont type(memory_size_type) :: MS - character(len=200) :: mesg integer :: i, j, k, is, ie, js, je, nz if (.not.CS%module_is_initialized) call MOM_error(FATAL, & @@ -2786,6 +3740,7 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke MS%isdw = G%isd ; MS%iedw = G%ied ; MS%jsdw = G%jsd ; MS%jedw = G%jed + if (.not.(present(pbce) .or. present(gtot_est))) call MOM_error(FATAL, & "set_dtbt: Either pbce or gtot_est must be present.") @@ -2803,7 +3758,7 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) endif det_de = 0.0 - if (CS%tides) call tidal_forcing_sensitivity(G, CS%tides_CSp, det_de) + if (CS%calculate_SAL) call scalar_SAL_sensitivity(CS%SAL_CSp, det_de) if (CS%tidal_sal_bug) then dgeo_de = 1.0 + max(0.0, det_de + CS%G_extra) else @@ -2822,8 +3777,8 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) enddo ; enddo ; enddo else do j=js,je ; do i=is,ie - gtot_E(i,j) = gtot_est * GV%H_to_Z ; gtot_W(i,j) = gtot_est * GV%H_to_Z - gtot_N(i,j) = gtot_est * GV%H_to_Z ; gtot_S(i,j) = gtot_est * GV%H_to_Z + gtot_E(i,j) = gtot_est ; gtot_W(i,j) = gtot_est + gtot_N(i,j) = gtot_est ; gtot_S(i,j) = gtot_est enddo ; enddo endif @@ -2832,10 +3787,10 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) ! This is pretty accurate for gravity waves, but it is a conservative ! estimate since it ignores the stabilizing effect of the bottom drag. Idt_max2 = 0.5 * (1.0 + 2.0*CS%bebt) * (G%IareaT(i,j) * & - ((gtot_E(i,j)*Datu(I,j)*G%IdxCu(I,j) + gtot_W(i,j)*Datu(I-1,j)*G%IdxCu(I-1,j)) + & - (gtot_N(i,j)*Datv(i,J)*G%IdyCv(i,J) + gtot_S(i,j)*Datv(i,J-1)*G%IdyCv(i,J-1))) + & - ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & - (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) * CS%BT_Coriolis_scale**2 ) + (((gtot_E(i,j)*Datu(I,j)*G%IdxCu(I,j)) + (gtot_W(i,j)*Datu(I-1,j)*G%IdxCu(I-1,j))) + & + ((gtot_N(i,j)*Datv(i,J)*G%IdyCv(i,J)) + (gtot_S(i,j)*Datv(i,J-1)*G%IdyCv(i,J-1)))) + & + ((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + & + (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) * CS%BT_Coriolis_scale**2 ) if (Idt_max2 * min_max_dt2 > 1.0) min_max_dt2 = 1.0 / Idt_max2 enddo ; enddo dtbt_max = sqrt(min_max_dt2 / dgeo_de) @@ -2845,17 +3800,22 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) CS%dtbt = CS%dtbt_fraction * dtbt_max CS%dtbt_max = dtbt_max + + if (CS%debug) then + call chksum0(CS%dtbt, "End set_dtbt dtbt", unscale=US%T_to_s) + call chksum0(CS%dtbt_max, "End set_dtbt dtbt_max", unscale=US%T_to_s) + endif + end subroutine set_dtbt -!> The following 4 subroutines apply the open boundary conditions. -!! This subroutine applies the open boundary conditions on barotropic +! The following 5 subroutines apply the open boundary conditions. + +!> This subroutine applies the open boundary conditions on barotropic zonal !! velocities and mass transports, as developed by Mehmet Ilicak. -subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, eta, & - ubt_old, vbt_old, BT_OBC, G, MS, US, halo, dtbt, bebt, & - use_BT_cont, integral_BT_cont, dt_elapsed, Datu, Datv, & - BTCL_u, BTCL_v, uhbt0, vhbt0, ubt_int, vbt_int, uhbt_int, vhbt_int) - type(ocean_OBC_type), pointer :: OBC !< An associated pointer to an OBC type. - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. +subroutine apply_u_velocity_OBCs(ubt, uhbt, ubt_trans, eta, SpV_avg, ubt_old, BT_OBC, G, MS, & + GV, US, CS, halo, dtbt, bebt, use_BT_cont, integral_BT_cont, dt_elapsed, & + Datu, BTCL_u, uhbt0, ubt_int, ubt_int_prev, uhbt_int, uhbt_int_prev) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of !! the argument arrays. real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: ubt !< the zonal barotropic velocity [L T-1 ~> m s-1]. @@ -2863,6 +3823,187 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, !! [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: ubt_trans !< The zonal barotropic velocity used in !! transport [L T-1 ~> m s-1]. + real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: eta !< The barotropic free surface height anomaly or + !! column mass anomaly [H ~> m or kg m-2]. + real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: SpV_avg !< The column average specific volume [R-1 ~> m3 kg-1] + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: ubt_old !< The starting value of ubt in a barotropic + !! step [L T-1 ~> m s-1]. + type(BT_OBC_type), intent(in) :: BT_OBC !< A structure with the private barotropic arrays + !! related to the open boundary conditions, + !! set by set_up_BT_OBC. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(barotropic_CS), intent(in) :: CS !< Barotropic control structure + integer, intent(in) :: halo !< The extra halo size to use here. + real, intent(in) :: dtbt !< The time step [T ~> s]. + real, intent(in) :: bebt !< The fractional weighting of the future velocity + !! in determining the transport [nondim] + logical, intent(in) :: use_BT_cont !< If true, use the BT_cont_types to calculate + !! transports. + logical, intent(in) :: integral_BT_cont !< If true, update the barotropic continuity + !! equation directly from the initial condition + !! using the time-integrated barotropic velocity. + real, intent(in) :: dt_elapsed !< The amount of time in the barotropic stepping + !! that will have elapsed [T ~> s]. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: Datu !< A fixed estimate of the face areas at u points + !! [H L ~> m2 or kg m-1]. + type(local_BT_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: BTCL_u !< Structure of information used + !! for a dynamic estimate of the face areas at + !! u-points. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: uhbt0 !< A correction to the zonal transport so that + !! the barotropic functions agree with the sum + !! of the layer transports + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: ubt_int !< The time-integrated zonal barotropic + !! velocity after this update [L T-1 ~> m s-1] + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: ubt_int_prev !< The time-integrated zonal barotropic + !! velocity before this update [L T-1 ~> m s-1] + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: uhbt_int !< The time-integrated zonal barotropic transport + !! after this update [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: uhbt_int_prev !< The time-integrated zonal barotropic + !! transport before this update + !! [H L2 T-1 ~> m3 s-1 or kg s-1] + + ! Local variables + real :: vel_prev ! The previous velocity [L T-1 ~> m s-1]. + real :: cfl ! The CFL number at the point in question [nondim] + real :: u_inlet ! The zonal inflow velocity [L T-1 ~> m s-1] + real :: uhbt_int_new ! The updated time-integrated zonal transport [H L2 ~> m3] + real :: ssh_in ! The inflow sea surface height [Z ~> m] + real :: ssh_1 ! The sea surface height in the interior cell adjacent to the an OBC face [Z ~> m] + real :: ssh_2 ! The sea surface height in the next cell inward from the OBC face [Z ~> m] + real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1] + integer :: i, j, Is_u, Ie_u, js, je + + if (.not.BT_OBC%u_OBCs_on_PE) return + + Idtbt = 1.0 / dtbt + + ! Work on Eastern OBC points + Is_u = max((G%isc-1)-halo, BT_OBC%Is_u_E_obc) ; Ie_u = min(G%iec+halo, BT_OBC%Ie_u_E_obc) + js = max(G%jsc-halo, BT_OBC%js_u_E_obc) ; je = min(G%jec+halo, BT_OBC%je_u_E_obc) + do j=js,je ; do I=Is_u,Ie_u ; if (BT_OBC%u_OBC_type(I,j) > 0) then + if (BT_OBC%u_OBC_type(I,j) == SPECIFIED_OBC) then ! Eastern specified OBC + uhbt(I,j) = BT_OBC%uhbt(I,j) + ubt(I,j) = BT_OBC%ubt_outer(I,j) + ubt_trans(I,j) = ubt(I,j) + if (integral_BT_cont) then + uhbt_int(I,j) = uhbt_int_prev(I,j) + dtbt * uhbt(I,j) + ubt_int(I,j) = ubt_int_prev(I,j) + dtbt * ubt_trans(I,j) + endif + elseif (BT_OBC%u_OBC_type(I,j) == FLATHER_OBC) then ! Eastern Flather OBC + cfl = dtbt * BT_OBC%Cg_u(I,j) * G%IdxCu(I,j) ! CFL + u_inlet = cfl*ubt_old(I-1,j) + (1.0-cfl)*ubt_old(I,j) ! Valid for cfl<1 + if (I <= MS%isdw) then + ! Do not apply an Eastern Flather OBC at the western halo points on a PE, as doing so would + ! create a segmentation fault and this velocity will not propagate through to the next iteration. + ssh_in = BT_OBC%SSH_outer_u(I,j) + elseif (GV%Boussinesq) then + ssh_in = GV%H_to_Z*(eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i-1,j))) ! internal + else + ssh_1 = GV%H_to_RZ * eta(i,j) * SpV_avg(i,j) - (CS%bathyT(i,j) + G%Z_ref) + ssh_2 = GV%H_to_RZ * eta(i-1,j) * SpV_avg(i-1,j) - (CS%bathyT(i-1,j) + G%Z_ref) + ssh_in = ssh_1 + (0.5-cfl)*(ssh_1-ssh_2) ! internal + endif + if (BT_OBC%dZ_u(I,j) > 0.0) then + vel_prev = ubt(I,j) + ubt(I,j) = 0.5*((u_inlet + BT_OBC%ubt_outer(I,j)) + & + (BT_OBC%Cg_u(I,j)/BT_OBC%dZ_u(I,j)) * (ssh_in-BT_OBC%SSH_outer_u(I,j))) + ubt_trans(I,j) = (1.0-bebt)*vel_prev + bebt*ubt(I,j) + else ! This point is now dry. + ubt(I,j) = 0.0 + ubt_trans(I,j) = 0.0 + endif + elseif (BT_OBC%u_OBC_type(I,j) == GRADIENT_OBC) then ! Eastern gradient OBC + ubt(I,j) = ubt(I-1,j) + ubt_trans(I,j) = ubt(I,j) + endif + + ! Reset transports and related time-inetegrated velocities with non-specified OBCs + if (BT_OBC%u_OBC_type(I,j) > SPECIFIED_OBC) then ! Eastern Flather or gradient OBC + if (integral_BT_cont) then + ubt_int(I,j) = ubt_int_prev(I,j) + dtbt * ubt_trans(I,j) + uhbt_int_new = find_uhbt(ubt_int(I,j), BTCL_u(I,j)) + dt_elapsed*uhbt0(I,j) + uhbt(I,j) = (uhbt_int_new - uhbt_int_prev(I,j)) * Idtbt + uhbt_int(I,j) = uhbt_int_prev(I,j) + dtbt * uhbt(I,j) + ! The line above is equivalent to: uhbt_int(I,j) = uhbt_int_new + elseif (use_BT_cont) then + uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j)) + uhbt0(I,j) + else + uhbt(I,j) = Datu(I,j)*ubt_trans(I,j) + uhbt0(I,j) + endif + endif + + endif ; enddo ; enddo + + ! Work on Western OBC points + Is_u = max((G%isc-1)-halo, BT_OBC%Is_u_W_obc) ; Ie_u = min(G%iec+halo, BT_OBC%Ie_u_W_obc) + js = max(G%jsc-halo, BT_OBC%js_u_W_obc) ; je = min(G%jec+halo, BT_OBC%je_u_W_obc) + do j=js,je ; do I=Is_u,Ie_u ; if (BT_OBC%u_OBC_type(I,j) < 0) then + if (BT_OBC%u_OBC_type(I,j) == -SPECIFIED_OBC) then ! Western specified OBC + uhbt(I,j) = BT_OBC%uhbt(I,j) + ubt(I,j) = BT_OBC%ubt_outer(I,j) + ubt_trans(I,j) = ubt(I,j) + if (integral_BT_cont) then + uhbt_int(I,j) = uhbt_int_prev(I,j) + dtbt * uhbt(I,j) + ubt_int(I,j) = ubt_int_prev(I,j) + dtbt * ubt_trans(I,j) + endif + elseif (BT_OBC%u_OBC_type(I,j) == -FLATHER_OBC) then ! Western Flather OBC + cfl = dtbt * BT_OBC%Cg_u(I,j) * G%IdxCu(I,j) ! CFL + u_inlet = cfl*ubt_old(I+1,j) + (1.0-cfl)*ubt_old(I,j) ! Valid for cfl<1 + if (I >= MS%iedw-1) then + ! Do not apply a Western Flather OBC at the eastern halo points on a PE, as doing so would + ! create a segmentation fault and this velocity will not propagate through to the next iteration. + ssh_in = BT_OBC%SSH_outer_u(I,j) + elseif (GV%Boussinesq) then + ssh_in = GV%H_to_Z*(eta(i+1,j) + (0.5-cfl)*(eta(i+1,j)-eta(i+2,j))) ! internal + else + ssh_1 = GV%H_to_RZ * eta(i+1,j) * SpV_avg(i+1,j) - (CS%bathyT(i+1,j) + G%Z_ref) + ssh_2 = GV%H_to_RZ * eta(i+2,j) * SpV_avg(i+2,j) - (CS%bathyT(i+2,j) + G%Z_ref) + ssh_in = ssh_1 + (0.5-cfl)*(ssh_1-ssh_2) ! internal + endif + + if (BT_OBC%dZ_u(I,j) > 0.0) then + vel_prev = ubt(I,j) + ubt(I,j) = 0.5*((u_inlet + BT_OBC%ubt_outer(I,j)) + & + (BT_OBC%Cg_u(I,j)/BT_OBC%dZ_u(I,j)) * (BT_OBC%SSH_outer_u(I,j)-ssh_in)) + ubt_trans(I,j) = (1.0-bebt)*vel_prev + bebt*ubt(I,j) + else ! This point is now dry. + ubt(I,j) = 0.0 + ubt_trans(I,j) = 0.0 + endif + elseif (BT_OBC%u_OBC_type(I,j) == -GRADIENT_OBC) then ! Western gradient OBC + ubt(I,j) = ubt(I+1,j) + ubt_trans(I,j) = ubt(I,j) + endif + + ! Reset transports and related time-inetegrated velocities with non-specified OBCs + if (BT_OBC%u_OBC_type(I,j) < -SPECIFIED_OBC) then ! Western Flather or gradient OBC + if (integral_BT_cont) then + ubt_int(I,j) = ubt_int_prev(I,j) + dtbt * ubt_trans(I,j) + uhbt_int_new = find_uhbt(ubt_int(I,j), BTCL_u(I,j)) + dt_elapsed*uhbt0(I,j) + uhbt(I,j) = (uhbt_int_new - uhbt_int_prev(I,j)) * Idtbt + uhbt_int(I,j) = uhbt_int_prev(I,j) + dtbt * uhbt(I,j) + ! The line above is equivalent to: uhbt_int(I,j) = uhbt_int_new + elseif (use_BT_cont) then + uhbt(I,j) = find_uhbt(ubt_trans(I,j), BTCL_u(I,j)) + uhbt0(I,j) + else + uhbt(I,j) = Datu(I,j)*ubt_trans(I,j) + uhbt0(I,j) + endif + endif + + endif ; enddo ; enddo + +end subroutine apply_u_velocity_OBCs + +!> This subroutine applies the open boundary conditions on barotropic meridional +!! velocities and mass transports, as developed by Mehmet Ilicak. +subroutine apply_v_velocity_OBCs(vbt, vhbt, vbt_trans, eta, SpV_avg, vbt_old, BT_OBC, & + G, MS, GV, US, CS, halo, dtbt, bebt, use_BT_cont, integral_BT_cont, dt_elapsed, & + Datv, BTCL_v, vhbt0, vbt_int, vbt_int_prev, vhbt_int, vhbt_int_prev) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of + !! the argument arrays. real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vbt !< The meridional barotropic velocity !! [L T-1 ~> m s-1]. real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vhbt !< the meridional barotropic transport @@ -2871,18 +4012,19 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, !! transports [L T-1 ~> m s-1]. real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: eta !< The barotropic free surface height anomaly or !! column mass anomaly [H ~> m or kg m-2]. - real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: ubt_old !< The starting value of ubt in a barotropic - !! step [L T-1 ~> m s-1]. + real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: SpV_avg !< The column average specific volume [R-1 ~> m3 kg-1] real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vbt_old !< The starting value of vbt in a barotropic !! step [L T-1 ~> m s-1]. type(BT_OBC_type), intent(in) :: BT_OBC !< A structure with the private barotropic arrays !! related to the open boundary conditions, !! set by set_up_BT_OBC. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(barotropic_CS), intent(in) :: CS !< Barotropic control structure integer, intent(in) :: halo !< The extra halo size to use here. real, intent(in) :: dtbt !< The time step [T ~> s]. real, intent(in) :: bebt !< The fractional weighting of the future velocity - !! in determining the transport. + !! in determining the transport [nondim] logical, intent(in) :: use_BT_cont !< If true, use the BT_cont_types to calculate !! transports. logical, intent(in) :: integral_BT_cont !< If true, update the barotropic continuity @@ -2890,174 +4032,329 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, !! using the time-integrated barotropic velocity. real, intent(in) :: dt_elapsed !< The amount of time in the barotropic stepping !! that will have elapsed [T ~> s]. - real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: Datu !< A fixed estimate of the face areas at u points - !! [H L ~> m2 or kg m-1]. real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: Datv !< A fixed estimate of the face areas at v points !! [H L ~> m2 or kg m-1]. - type(local_BT_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: BTCL_u !< Structure of information used - !! for a dynamic estimate of the face areas at - !! u-points. type(local_BT_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: BTCL_v !< Structure of information used !! for a dynamic estimate of the face areas at !! v-points. - real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: uhbt0 !< A correction to the zonal transport so that - !! the barotropic functions agree with the sum - !! of the layer transports - !! [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vhbt0 !< A correction to the meridional transport so that !! the barotropic functions agree with the sum !! of the layer transports !! [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: ubt_int !< The time-integrated zonal barotropic - !! velocity before this update [L T-1 ~> m s-1]. - real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: uhbt_int !< The time-integrated zonal barotropic - !! transport [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vbt_int !< The time-integrated meridional barotropic + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vbt_int !< The time-integrated meridional barotropic + !! velocity after this update [L T-1 ~> m s-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vbt_int_prev !< The time-integrated meridional barotropic !! velocity before this update [L T-1 ~> m s-1]. - real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vhbt_int !< The time-integrated meridional barotropic - !! transport [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(inout) :: vhbt_int !< The time-integrated meridional barotropic + !! transport after this update + !! [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vhbt_int_prev !< The time-integrated meridional barotropic + !! transport before this update + !! [H L2 T-1 ~> m3 s-1 or kg s-1] + + ! Local variables + real :: vel_prev ! The previous velocity [L T-1 ~> m s-1]. + real :: cfl ! The CFL number at the point in question [nondim] + real :: v_inlet ! The meridional inflow velocity [L T-1 ~> m s-1] + real :: vhbt_int_new ! The updated time-integrated meridional transport [H L2 ~> m3] + real :: ssh_in ! The inflow sea surface height [Z ~> m] + real :: ssh_1 ! The sea surface height in the interior cell adjacent to the an OBC face [Z ~> m] + real :: ssh_2 ! The sea surface height in the next cell inward from the OBC face [Z ~> m] + real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1] + integer :: i, j, is, ie, Js_v, Je_v + + if (.not.BT_OBC%v_OBCs_on_PE) return + + Idtbt = 1.0 / dtbt + + ! This routine uses separate blocks of code and loops for Northern and southern open boundary + ! condition points, despite this leading to some code duplication, because the OBCs almost always + ! occur at the edge of the domain, and in parallel appliations, most PEs will only have one or + ! the other. + + + ! Work on Northern OBC points + is = max(G%isc-halo, BT_OBC%is_v_N_obc) ; ie = min(G%iec+halo, BT_OBC%ie_v_N_obc) + Js_v = max((G%jsc-1)-halo, BT_OBC%Js_v_N_obc) ; Je_v = min(G%jec+halo, BT_OBC%Je_v_N_obc) + do J=Js_v,Je_v ; do i=is,ie ; if (BT_OBC%v_OBC_type(i,J) > 0) then + if (BT_OBC%v_OBC_type(i,J) == SPECIFIED_OBC) then ! Northern specified OBC + vhbt(i,J) = BT_OBC%vhbt(i,J) + vbt(i,J) = BT_OBC%vbt_outer(i,J) + vbt_trans(i,J) = vbt(i,J) + if (integral_BT_cont) then + vbt_int(i,J) = vbt_int_prev(i,J) + dtbt * vbt(i,J) + vhbt_int(i,J) = vhbt_int_prev(i,J) + dtbt * vhbt(i,J) + endif + elseif (BT_OBC%v_OBC_type(i,J) == FLATHER_OBC) then ! Northern Flather OBC + cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(i,J) ! CFL + v_inlet = cfl*vbt_old(i,J-1) + (1.0-cfl)*vbt_old(i,J) ! Valid for cfl<1 + if (J <= MS%jsdw) then + ! Do not apply a Northern Flather OBC at the southern halo points on a PE, as doing so would + ! create a segmentation fault and this velocity will not propagate through to the next iteration. + ssh_in = BT_OBC%SSH_outer_v(i,J) + elseif (GV%Boussinesq) then + ssh_in = GV%H_to_Z*(eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i,j-1))) ! internal + else + ssh_1 = GV%H_to_RZ * eta(i,j) * SpV_avg(i,j) - (CS%bathyT(i,j) + G%Z_ref) + ssh_2 = GV%H_to_RZ * eta(i,j-1) * SpV_avg(i,j-1) - (CS%bathyT(i,j-1) + G%Z_ref) + ssh_in = ssh_1 + (0.5-cfl)*(ssh_1-ssh_2) ! internal + endif + + if (BT_OBC%dZ_v(i,J) > 0.0) then + vel_prev = vbt(i,J) + vbt(i,J) = 0.5*((v_inlet + BT_OBC%vbt_outer(i,J)) + & + (BT_OBC%Cg_v(i,J)/BT_OBC%dZ_v(i,J)) * (ssh_in-BT_OBC%SSH_outer_v(i,J))) + vbt_trans(i,J) = (1.0-bebt)*vel_prev + bebt*vbt(i,J) + else ! This point is now dry + vbt(i,J) = 0.0 + vbt_trans(i,J) = 0.0 + endif + elseif (BT_OBC%v_OBC_type(i,J) == GRADIENT_OBC) then ! Northern gradient OBC + vbt(i,J) = vbt(i,J-1) + vbt_trans(i,J) = vbt(i,J) + endif + + ! Reset transports and related time-inetegrated velocities with non-specified OBCs + if (BT_OBC%v_OBC_type(i,J) > SPECIFIED_OBC) then ! Northern Flather or gradient OBC + if (integral_BT_cont) then + vbt_int(i,J) = vbt_int_prev(i,J) + dtbt * vbt_trans(i,J) + vhbt_int_new = find_vhbt(vbt_int(i,J), BTCL_v(i,J)) + dt_elapsed*vhbt0(i,J) + vhbt(i,J) = (vhbt_int_new - vhbt_int_prev(i,J)) * Idtbt + vhbt_int(i,J) = vhbt_int_prev(i,J) + dtbt * vhbt(i,J) + ! The line above is equivalent to: vhbt_int(i,J) = vhbt_int_new + elseif (use_BT_cont) then + vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J)) + vhbt0(i,J) + else + vhbt(i,J) = vbt_trans(i,J)*Datv(i,J) + vhbt0(i,J) + endif + endif + + endif ; enddo ; enddo + + ! Work on Southern OBC points + is = max(G%isc-halo, BT_OBC%is_v_S_obc) ; ie = min(G%iec+halo, BT_OBC%ie_v_S_obc) + Js_v = max((G%jsc-1)-halo, BT_OBC%Js_v_S_obc) ; Je_v = min(G%jec+halo, BT_OBC%Je_v_S_obc) + do J=Js_v,Je_v ; do i=is,ie ; if (BT_OBC%v_OBC_type(i,J) < 0) then + if (BT_OBC%v_OBC_type(i,J) == -SPECIFIED_OBC) then ! Southern specified OBC + vhbt(i,J) = BT_OBC%vhbt(i,J) + vbt(i,J) = BT_OBC%vbt_outer(i,J) + vbt_trans(i,J) = vbt(i,J) + if (integral_BT_cont) then + vbt_int(i,J) = vbt_int_prev(i,J) + dtbt * vbt(i,J) + vhbt_int(i,J) = vhbt_int_prev(i,J) + dtbt * vhbt(i,J) + endif + elseif (BT_OBC%v_OBC_type(i,J) == -FLATHER_OBC) then ! Southern Flather OBC + cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(i,J) ! CFL + v_inlet = cfl*vbt_old(i,J+1) + (1.0-cfl)*vbt_old(i,J) ! Valid for cfl <1 + if (J >= MS%jedw-1) then + ! Do not apply a Southern Flather OBC at the northern halo points on a PE, as doing so would + ! create a segmentation fault and this velocity will not propagate through to the next iteration. + ssh_in = BT_OBC%SSH_outer_v(i,J) + elseif (GV%Boussinesq) then + ssh_in = GV%H_to_Z*(eta(i,j+1) + (0.5-cfl)*(eta(i,j+1)-eta(i,j+2))) ! internal + else + ssh_1 = GV%H_to_RZ * eta(i,j+1) * SpV_avg(i,j+1) - (CS%bathyT(i,j+1) + G%Z_ref) + ssh_2 = GV%H_to_RZ * eta(i,j+2) * SpV_avg(i,j+2) - (CS%bathyT(i,j+2) + G%Z_ref) + ssh_in = ssh_1 + (0.5-cfl)*(ssh_1-ssh_2) ! internal + endif + + if (BT_OBC%dZ_v(i,J) > 0.0) then + vel_prev = vbt(i,J) + vbt(i,J) = 0.5*((v_inlet + BT_OBC%vbt_outer(i,J)) + & + (BT_OBC%Cg_v(i,J)/BT_OBC%dZ_v(i,J)) * (BT_OBC%SSH_outer_v(i,J)-ssh_in)) + vbt_trans(i,J) = (1.0-bebt)*vel_prev + bebt*vbt(i,J) + else ! This point is now dry + vbt(i,J) = 0.0 + vbt_trans(i,J) = 0.0 + endif + elseif (BT_OBC%v_OBC_type(i,J) == -GRADIENT_OBC) then ! Southern gradient OBC + vbt(i,J) = vbt(i,J+1) + vbt_trans(i,J) = vbt(i,J) + endif + + ! Reset transports and related time-inetegrated velocities with non-specified OBCs + if (BT_OBC%v_OBC_type(i,J) < -SPECIFIED_OBC) then ! Southern Flather or gradient OBC + if (integral_BT_cont) then + vbt_int(i,J) = vbt_int_prev(i,J) + dtbt * vbt_trans(i,J) + vhbt_int_new = find_vhbt(vbt_int(i,J), BTCL_v(i,J)) + dt_elapsed*vhbt0(i,J) + vhbt(i,J) = (vhbt_int_new - vhbt_int_prev(i,J)) * Idtbt + vhbt_int(i,J) = vhbt_int_prev(i,J) + dtbt * vhbt(i,J) + ! The line above is equivalent to: vhbt_int(i,J) = vhbt_int_new + elseif (use_BT_cont) then + vhbt(i,J) = find_vhbt(vbt_trans(i,J), BTCL_v(i,J)) + vhbt0(i,J) + else + vhbt(i,J) = vbt_trans(i,J)*Datv(i,J) + vhbt0(i,J) + endif + endif + + endif ; enddo ; enddo + +end subroutine apply_v_velocity_OBCs + +!> This subroutine sets up the time-invariant control information about the open boundary +!! conditions on the full wide halo domain used by the barotropic solver. +subroutine initialize_BT_OBC(OBC, BT_OBC, G, CS) + type(ocean_OBC_type), target, intent(inout) :: OBC !< An associated pointer to an OBC type. + type(BT_OBC_type), intent(inout) :: BT_OBC !< A structure with the private barotropic arrays + !! related to the open boundary conditions, + !! set by set_up_BT_OBC. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(barotropic_CS), intent(inout) :: CS !< Barotropic control structure ! Local variables - real :: vel_prev ! The previous velocity [L T-1 ~> m s-1]. - real :: vel_trans ! The combination of the previous and current velocity - ! that does the mass transport [L T-1 ~> m s-1]. - real :: H_u ! The total thickness at the u-point [H ~> m or kg m-2]. - real :: H_v ! The total thickness at the v-point [H ~> m or kg m-2]. - real :: cfl ! The CFL number at the point in question [nondim] - real :: u_inlet ! The zonal inflow velocity [L T-1 ~> m s-1] - real :: v_inlet ! The meridional inflow velocity [L T-1 ~> m s-1] - real :: uhbt_int_new ! The updated time-integrated zonal transport [H L2 ~> m3] - real :: vhbt_int_new ! The updated time-integrated meridional transport [H L2 ~> m3] - real :: h_in ! The inflow thickness [H ~> m or kg m-2]. - real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1] - integer :: i, j, is, ie, js, je - is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo + real, dimension(SZIBW_(CS),SZJW_(CS)) :: & + u_OBC ! A set of integers encoding the nature of the u-point open boundary conditions, + ! converted to real numbers to work with the MOM6 halo update code [nondim] + real, dimension(SZIW_(CS),SZJBW_(CS)) :: & + v_OBC ! A set of integers encoding the nature of the v-point open boundary conditions, + ! converted to real numbers to work with the MOM6 halo update code [nondim] + integer :: OBC_type ! The integer encoding the type of OBC being used at a point [nondim] + logical :: reversed_OBCs ! True of there any OBCs in the opposite halo on this PE, e.g. points + ! with a southern OBC in a northern halo. + logical :: any_reversed_OBCs + integer :: i, j, isdw, iedw, jsdw, jedw + integer :: l_seg, Flather_OBC_in_halo - if (.not.(BT_OBC%apply_u_OBCs .or. BT_OBC%apply_v_OBCs)) return + isdw = CS%isdw ; iedw = CS%iedw ; jsdw = CS%jsdw ; jedw = CS%jedw - Idtbt = 1.0 / dtbt + u_OBC(:,:) = 0.0 + v_OBC(:,:) = 0.0 - if (BT_OBC%apply_u_OBCs) then - do j=js,je ; do I=is-1,ie ; if (OBC%segnum_u(I,j) /= OBC_NONE) then - if (OBC%segment(OBC%segnum_u(I,j))%specified) then - uhbt(I,j) = BT_OBC%uhbt(I,j) - ubt(I,j) = BT_OBC%ubt_outer(I,j) - vel_trans = ubt(I,j) - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - if (OBC%segment(OBC%segnum_u(I,j))%Flather) then - cfl = dtbt * BT_OBC%Cg_u(I,j) * G%IdxCu(I,j) ! CFL - u_inlet = cfl*ubt_old(I-1,j) + (1.0-cfl)*ubt_old(I,j) ! Valid for cfl<1 - h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i-1,j)) ! internal - H_u = BT_OBC%H_u(I,j) - vel_prev = ubt(I,j) - ubt(I,j) = 0.5*((u_inlet + BT_OBC%ubt_outer(I,j)) + & - (BT_OBC%Cg_u(I,j)/H_u) * (h_in-BT_OBC%eta_outer_u(I,j))) - vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) - elseif (OBC%segment(OBC%segnum_u(I,j))%gradient) then - ubt(I,j) = ubt(I-1,j) - vel_trans = ubt(I,j) - endif - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - if (OBC%segment(OBC%segnum_u(I,j))%Flather) then - cfl = dtbt * BT_OBC%Cg_u(I,j) * G%IdxCu(I,j) ! CFL - u_inlet = cfl*ubt_old(I+1,j) + (1.0-cfl)*ubt_old(I,j) ! Valid for cfl<1 - h_in = eta(i+1,j) + (0.5-cfl)*(eta(i+1,j)-eta(i+2,j)) ! external - - H_u = BT_OBC%H_u(I,j) - vel_prev = ubt(I,j) - ubt(I,j) = 0.5*((u_inlet + BT_OBC%ubt_outer(I,j)) + & - (BT_OBC%Cg_u(I,j)/H_u) * (BT_OBC%eta_outer_u(I,j)-h_in)) - - vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) - elseif (OBC%segment(OBC%segnum_u(I,j))%gradient) then - ubt(I,j) = ubt(I+1,j) - vel_trans = ubt(I,j) - endif - endif + do j=G%jsc,G%jec ; do I=G%isc-1,G%iec - if (.not. OBC%segment(OBC%segnum_u(I,j))%specified) then - if (integral_BT_cont) then - uhbt_int_new = find_uhbt(ubt_int(I,j) + dtbt*vel_trans, BTCL_u(I,j)) + & - dt_elapsed*uhbt0(I,j) - uhbt(I,j) = (uhbt_int_new - uhbt_int(I,j)) * Idtbt - elseif (use_BT_cont) then - uhbt(I,j) = find_uhbt(vel_trans, BTCL_u(I,j)) + uhbt0(I,j) - else - uhbt(I,j) = Datu(I,j)*vel_trans + uhbt0(I,j) - endif - endif + OBC_type = 0 + if (OBC%segnum_u(I,j) /= 0) then + l_seg = abs(OBC%segnum_u(I,j)) + if (OBC%segment(l_seg)%gradient) OBC_type = GRADIENT_OBC + if (OBC%segment(l_seg)%Flather) OBC_type = FLATHER_OBC + if (OBC%segment(l_seg)%specified) OBC_type = SPECIFIED_OBC + u_OBC(I,j) = sign(OBC_type, OBC%segnum_u(I,j)) + endif + enddo ; enddo - ubt_trans(I,j) = vel_trans - endif ; enddo ; enddo - endif + do J=G%jsc-1,G%jec ; do i=G%isc,G%iec + OBC_type = 0 + if (OBC%segnum_v(i,J) /= 0) then + l_seg = abs(OBC%segnum_v(i,J)) + if (OBC%segment(l_seg)%gradient) OBC_type = GRADIENT_OBC + if (OBC%segment(l_seg)%Flather) OBC_type = FLATHER_OBC + if (OBC%segment(l_seg)%specified) OBC_type = SPECIFIED_OBC + v_OBC(i,J) = sign(OBC_type, OBC%segnum_v(i,J)) + endif + enddo ; enddo - if (BT_OBC%apply_v_OBCs) then - do J=js-1,je ; do i=is,ie ; if (OBC%segnum_v(i,J) /= OBC_NONE) then - if (OBC%segment(OBC%segnum_v(i,J))%specified) then - vhbt(i,J) = BT_OBC%vhbt(i,J) - vbt(i,J) = BT_OBC%vbt_outer(i,J) - vel_trans = vbt(i,J) - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - if (OBC%segment(OBC%segnum_v(i,J))%Flather) then - cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(i,J) ! CFL - v_inlet = cfl*vbt_old(i,J-1) + (1.0-cfl)*vbt_old(i,J) ! Valid for cfl<1 - h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i,j-1)) ! internal - - H_v = BT_OBC%H_v(i,J) - vel_prev = vbt(i,J) - vbt(i,J) = 0.5*((v_inlet + BT_OBC%vbt_outer(i,J)) + & - (BT_OBC%Cg_v(i,J)/H_v) * (h_in-BT_OBC%eta_outer_v(i,J))) - - vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) - elseif (OBC%segment(OBC%segnum_v(i,J))%gradient) then - vbt(i,J) = vbt(i,J-1) - vel_trans = vbt(i,J) - endif - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - if (OBC%segment(OBC%segnum_v(i,J))%Flather) then - cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(i,J) ! CFL - v_inlet = cfl*vbt_old(i,J+1) + (1.0-cfl)*vbt_old(i,J) ! Valid for cfl <1 - h_in = eta(i,j+1) + (0.5-cfl)*(eta(i,j+1)-eta(i,j+2)) ! internal - - H_v = BT_OBC%H_v(i,J) - vel_prev = vbt(i,J) - vbt(i,J) = 0.5*((v_inlet + BT_OBC%vbt_outer(i,J)) + & - (BT_OBC%Cg_v(i,J)/H_v) * (BT_OBC%eta_outer_v(i,J)-h_in)) - - vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) - elseif (OBC%segment(OBC%segnum_v(i,J))%gradient) then - vbt(i,J) = vbt(i,J+1) - vel_trans = vbt(i,J) - endif + call pass_vector(u_OBC, v_OBC, CS%BT_Domain) + + allocate(BT_OBC%u_OBC_type(isdw-1:iedw,jsdw:jedw), source=0) + allocate(BT_OBC%v_OBC_type(isdw:iedw,jsdw-1:jedw), source=0) + + ! Determine the maximum and minimum index range for various directions of OBC points on this PE + ! by first setting these one point outside of the wrong side of the domain. + BT_OBC%Is_u_W_obc = iedw + 1 ; BT_OBC%Ie_u_W_obc = isdw - 2 + BT_OBC%js_u_W_obc = jedw + 1 ; BT_OBC%je_u_W_obc = jsdw - 1 + BT_OBC%Is_u_E_obc = iedw + 1 ; BT_OBC%Ie_u_E_obc = isdw - 2 + BT_OBC%js_u_E_obc = jedw + 1 ; BT_OBC%je_u_E_obc = jsdw - 1 + BT_OBC%is_v_S_obc = iedw + 1 ; BT_OBC%ie_v_S_obc = isdw - 1 + BT_OBC%Js_v_S_obc = jedw + 1 ; BT_OBC%Je_v_S_obc = jsdw - 2 + BT_OBC%is_v_N_obc = iedw + 1 ; BT_OBC%ie_v_N_obc = isdw - 1 + BT_OBC%Js_v_N_obc = jedw + 1 ; BT_OBC%Je_v_N_obc = jsdw - 2 + + Flather_OBC_in_halo = 0 + do j=jsdw,jedw ; do I=isdw-1,iedw + BT_OBC%u_OBC_type(I,j) = nint(u_OBC(I,j)) + if (BT_OBC%u_OBC_type(I,j) < 0) then ! This point has OBC_DIRECTION_W. + if ((BT_OBC%u_OBC_type(I,j) == -FLATHER_OBC) .and. (I >= iedw-1)) then + ! There is no need to specify the OBC at this point, but the stencil might need to be increased. + Flather_OBC_in_halo = 1 + else + BT_OBC%Is_u_W_obc = min(I, BT_OBC%Is_u_W_obc) ; BT_OBC%Ie_u_W_obc = max(I, BT_OBC%Ie_u_W_obc) + BT_OBC%js_u_W_obc = min(j, BT_OBC%js_u_W_obc) ; BT_OBC%je_u_W_obc = max(j, BT_OBC%je_u_W_obc) + endif + endif + if (BT_OBC%u_OBC_type(I,j) > 0) then ! This point has OBC_DIRECTION_E. + if ((BT_OBC%u_OBC_type(I,j) == FLATHER_OBC) .and. (I <= isdw)) then + ! There is no need to specify the OBC at this point, but the stencil might need to be increased. + Flather_OBC_in_halo = 1 + else + BT_OBC%Is_u_E_obc = min(I, BT_OBC%Is_u_E_obc) ; BT_OBC%Ie_u_E_obc = max(I, BT_OBC%Ie_u_E_obc) + BT_OBC%js_u_E_obc = min(j, BT_OBC%js_u_E_obc) ; BT_OBC%je_u_E_obc = max(j, BT_OBC%je_u_E_obc) endif + endif + enddo ; enddo - if (.not. OBC%segment(OBC%segnum_v(i,J))%specified) then - if (integral_BT_cont) then - vhbt_int_new = find_vhbt(vbt_int(i,J) + dtbt*vel_trans, BTCL_v(i,J)) + & - dt_elapsed*vhbt0(i,J) - vhbt(i,J) = (vhbt_int_new - vhbt_int(i,J)) * Idtbt - elseif (use_BT_cont) then - vhbt(i,J) = find_vhbt(vel_trans, BTCL_v(i,J)) + vhbt0(i,J) - else - vhbt(i,J) = vel_trans*Datv(i,J) + vhbt0(i,J) - endif + do J=jsdw-1,jedw ; do i=isdw,iedw + BT_OBC%v_OBC_type(i,J) = nint(v_OBC(i,J)) + if (BT_OBC%v_OBC_type(i,J) < 0) then ! This point has OBC_DIRECTION_S. + if ((BT_OBC%v_OBC_type(i,J) == -FLATHER_OBC) .and. (J >= jedw-1)) then + ! There is no need to specify the OBC at this point, but the stencil might need to be increased. + Flather_OBC_in_halo = 1 + else + BT_OBC%is_v_S_obc = min(i, BT_OBC%is_v_S_obc) ; BT_OBC%ie_v_S_obc = max(i, BT_OBC%ie_v_S_obc) + BT_OBC%Js_v_S_obc = min(J, BT_OBC%Js_v_S_obc) ; BT_OBC%Je_v_S_obc = max(J, BT_OBC%Je_v_S_obc) + endif + endif + if (BT_OBC%v_OBC_type(i,J) > 0) then ! This point has OBC_DIRECTION_N. + if ((BT_OBC%v_OBC_type(i,J) == FLATHER_OBC) .and. (J <= jsdw)) then + ! There is no need to specify the OBC at this point, but the stencil might need to be increased. + Flather_OBC_in_halo = 1 + else + BT_OBC%is_v_N_obc = min(i, BT_OBC%is_v_N_obc) ; BT_OBC%ie_v_N_obc = max(i, BT_OBC%ie_v_N_obc) + BT_OBC%Js_v_N_obc = min(J, BT_OBC%Js_v_N_obc) ; BT_OBC%Je_v_N_obc = max(J, BT_OBC%Je_v_N_obc) endif + endif + enddo ; enddo - vbt_trans(i,J) = vel_trans - endif ; enddo ; enddo + BT_OBC%u_OBCs_on_PE = ((BT_OBC%Is_u_E_obc <= iedw) .or. (BT_OBC%Is_u_W_obc <= iedw)) + BT_OBC%v_OBCs_on_PE = ((BT_OBC%is_v_N_obc <= iedw) .or. (BT_OBC%is_v_S_obc <= iedw)) + + + ! Determine whether there are any OBCs in the opposite halo on any processors in the domain, e.g., + ! points with OBC_DIRECTION_S in a northern halo. + reversed_OBCs = (BT_OBC%u_OBCs_on_PE .and. ((BT_OBC%Is_u_E_obc <= G%isc-1) .or. (BT_OBC%Ie_u_W_obc >= G%iec))) .or. & + (BT_OBC%v_OBCs_on_PE .and. ((BT_OBC%Js_v_N_obc <= G%jsc-1) .or. (BT_OBC%Je_v_S_obc >= G%jec))) + any_reversed_OBCs = any_across_PEs(reversed_OBCs) + if (any_reversed_OBCs) call MOM_mesg("OBCs in an opposite halo require the use of a wider stencil.", 5) + if (any_reversed_OBCs) CS%min_stencil = max(CS%min_stencil, 2) + + ! Allocate time-varying arrays that will be used for open boundary conditions. + + ! This pair is used with either Flather or specified OBCs. + allocate(BT_OBC%ubt_outer(isdw-1:iedw,jsdw:jedw), source=0.0) + allocate(BT_OBC%vbt_outer(isdw:iedw,jsdw-1:jedw), source=0.0) + call create_group_pass(BT_OBC%pass_uv, BT_OBC%ubt_outer, BT_OBC%vbt_outer, CS%BT_Domain) + + ! This pair is only used with specified OBCs. + allocate(BT_OBC%uhbt(isdw-1:iedw,jsdw:jedw), source=0.0) + allocate(BT_OBC%vhbt(isdw:iedw,jsdw-1:jedw), source=0.0) + call create_group_pass(BT_OBC%pass_uv, BT_OBC%uhbt, BT_OBC%vhbt, CS%BT_Domain) + + if (OBC%Flather_u_BCs_exist_globally .or. OBC%Flather_v_BCs_exist_globally) then + ! These 3 pairs are only used with Flather OBCs. + allocate(BT_OBC%Cg_u(isdw-1:iedw,jsdw:jedw), source=0.0) + allocate(BT_OBC%dZ_u(isdw-1:iedw,jsdw:jedw), source=0.0) + allocate(BT_OBC%SSH_outer_u(isdw-1:iedw,jsdw:jedw), source=0.0) + + allocate(BT_OBC%Cg_v(isdw:iedw,jsdw-1:jedw), source=0.0) + allocate(BT_OBC%dZ_v(isdw:iedw,jsdw-1:jedw), source=0.0) + allocate(BT_OBC%SSH_outer_v(isdw:iedw,jsdw-1:jedw), source=0.0) + + call create_group_pass(BT_OBC%scalar_pass, BT_OBC%SSH_outer_u, BT_OBC%SSH_outer_v, CS%BT_Domain, To_All+Scalar_Pair) + call create_group_pass(BT_OBC%scalar_pass, BT_OBC%dZ_u, BT_OBC%dZ_v, CS%BT_Domain, To_All+Scalar_Pair) + call create_group_pass(BT_OBC%scalar_pass, BT_OBC%Cg_u, BT_OBC%Cg_v, CS%BT_Domain, To_All+Scalar_Pair) endif -end subroutine apply_velocity_OBCs +end subroutine initialize_BT_OBC -!> This subroutine sets up the private structure used to apply the open +!> This subroutine sets up the time-varying fields in the private structure used to apply the open !! boundary conditions, as developed by Mehmet Ilicak. -subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_BT_cont, & - integral_BT_cont, dt_baroclinic, Datu, Datv, BTCL_u, BTCL_v) - type(ocean_OBC_type), target, intent(inout) :: OBC !< An associated pointer to an OBC type. +subroutine set_up_BT_OBC(OBC, eta, SpV_avg, BT_OBC, BT_Domain, G, GV, US, CS, MS, halo, use_BT_cont, & + integral_BT_cont, dt_baroclinic, Datu, Datv, BTCL_u, BTCL_v, dgeo_de) + type(ocean_OBC_type), target, intent(inout) :: OBC !< An associated pointer to an OBC type. type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the !! argument arrays. real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: eta !< The barotropic free surface height anomaly or !! column mass anomaly [H ~> m or kg m-2]. + real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: SpV_avg !< The column average specific volume [R-1 ~> m3 kg-1] type(BT_OBC_type), intent(inout) :: BT_OBC !< A structure with the private barotropic arrays !! related to the open boundary conditions, !! set by set_up_BT_OBC. @@ -3065,6 +4362,7 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(barotropic_CS), intent(inout) :: CS !< Barotropic control structure integer, intent(in) :: halo !< The extra halo size to use here. logical, intent(in) :: use_BT_cont !< If true, use the BT_cont_types to calculate !! transports. @@ -3083,13 +4381,13 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B type(local_BT_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: BTCL_v !< Structure of information used !! for a dynamic estimate of the face areas at !! v-points. - + real, intent(in) :: dgeo_de !< The constant of proportionality between + !! geopotential and sea surface height [nondim]. ! Local variables real :: I_dt ! The inverse of the time interval of this call [T-1 ~> s-1]. - integer :: i, j, k, is, ie, js, je, n, nz, Isq, Ieq, Jsq, Jeq + integer :: i, j, k, is, ie, js, je, n, nz integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB integer :: isdw, iedw, jsdw, jedw - logical :: OBC_used type(OBC_segment_type), pointer :: segment !< Open boundary segment is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo @@ -3099,32 +4397,7 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B I_dt = 1.0 / dt_baroclinic - if ((isdw < isd) .or. (jsdw < jsd)) then - call MOM_error(FATAL, "set_up_BT_OBC: Open boundary conditions are not "//& - "yet fully implemented with wide barotropic halos.") - endif - - if (.not. BT_OBC%is_alloced) then - allocate(BT_OBC%Cg_u(isdw-1:iedw,jsdw:jedw), source=0.0) - allocate(BT_OBC%H_u(isdw-1:iedw,jsdw:jedw), source=0.0) - allocate(BT_OBC%uhbt(isdw-1:iedw,jsdw:jedw), source=0.0) - allocate(BT_OBC%ubt_outer(isdw-1:iedw,jsdw:jedw), source=0.0) - allocate(BT_OBC%eta_outer_u(isdw-1:iedw,jsdw:jedw), source=0.0) - - allocate(BT_OBC%Cg_v(isdw:iedw,jsdw-1:jedw), source=0.0) - allocate(BT_OBC%H_v(isdw:iedw,jsdw-1:jedw), source=0.0) - allocate(BT_OBC%vhbt(isdw:iedw,jsdw-1:jedw), source=0.0) - allocate(BT_OBC%vbt_outer(isdw:iedw,jsdw-1:jedw), source=0.0) - allocate(BT_OBC%eta_outer_v(isdw:iedw,jsdw-1:jedw), source=0.0) - BT_OBC%is_alloced = .true. - call create_group_pass(BT_OBC%pass_uv, BT_OBC%ubt_outer, BT_OBC%vbt_outer, BT_Domain) - call create_group_pass(BT_OBC%pass_uhvh, BT_OBC%uhbt, BT_OBC%vhbt, BT_Domain) - call create_group_pass(BT_OBC%pass_eta_outer, BT_OBC%eta_outer_u, BT_OBC%eta_outer_v, BT_Domain,To_All+Scalar_Pair) - call create_group_pass(BT_OBC%pass_h, BT_OBC%H_u, BT_OBC%H_v, BT_Domain,To_All+Scalar_Pair) - call create_group_pass(BT_OBC%pass_cg, BT_OBC%Cg_u, BT_OBC%Cg_v, BT_Domain,To_All+Scalar_Pair) - endif - - if (BT_OBC%apply_u_OBCs) then + if (BT_OBC%u_OBCs_on_PE) then if (OBC%specified_u_BCs_exist_globally) then do n = 1, OBC%number_of_segments segment => OBC%segment(n) @@ -3138,9 +4411,8 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B endif enddo endif - do j=js,je ; do I=is-1,ie ; if (OBC%segnum_u(I,j) /= OBC_NONE) then - ! Can this go in segment loop above? Is loop above wrong for wide halos?? - if (OBC%segment(OBC%segnum_u(I,j))%specified) then + do j=js,je ; do I=is-1,ie ; if (BT_OBC%u_OBC_type(I,j) /= 0) then + if (abs(BT_OBC%u_OBC_type(I,j)) == SPECIFIED_OBC) then ! Eastern or western specified OBC if (integral_BT_cont) then BT_OBC%ubt_outer(I,j) = uhbt_to_ubt(BT_OBC%uhbt(I,j)*dt_baroclinic, BTCL_u(I,j)) * I_dt elseif (use_BT_cont) then @@ -3148,37 +4420,37 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B else if (Datu(I,j) > 0.0) BT_OBC%ubt_outer(I,j) = BT_OBC%uhbt(I,j) / Datu(I,j) endif - else ! This is assuming Flather as only other option + elseif (BT_OBC%u_OBC_type(I,j) == FLATHER_OBC) then ! Eastern Flather OBC if (GV%Boussinesq) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - BT_OBC%H_u(I,j) = G%bathyT(i,j)*GV%Z_to_H + eta(i,j) - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - BT_OBC%H_u(I,j) = G%bathyT(i+1,j)*GV%Z_to_H + eta(i+1,j) - endif + BT_OBC%dZ_u(I,j) = CS%bathyT(i,j) + GV%H_to_Z*eta(i,j) else - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - BT_OBC%H_u(I,j) = eta(i,j) - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - BT_OBC%H_u(I,j) = eta(i+1,j) - endif + BT_OBC%dZ_u(I,j) = GV%H_to_RZ * eta(i,j) * SpV_avg(i,j) + endif + BT_OBC%Cg_u(I,j) = SQRT(dgeo_de * GV%g_prime(1) * BT_OBC%dZ_u(I,j)) + elseif (BT_OBC%u_OBC_type(I,j) == -FLATHER_OBC) then ! Western Flather OBC + if (GV%Boussinesq) then + BT_OBC%dZ_u(I,j) = CS%bathyT(i+1,j) + GV%H_to_Z*eta(i+1,j) + else + BT_OBC%dZ_u(I,j) = GV%H_to_RZ * eta(i+1,j) * SpV_avg(i+1,j) endif - BT_OBC%Cg_u(I,j) = SQRT(GV%g_prime(1) * GV%H_to_Z*BT_OBC%H_u(i,j)) + BT_OBC%Cg_u(I,j) = SQRT(dgeo_de * GV%g_prime(1) * BT_OBC%dZ_u(I,j)) endif endif ; enddo ; enddo + if (OBC%Flather_u_BCs_exist_globally) then do n = 1, OBC%number_of_segments segment => OBC%segment(n) if (segment%is_E_or_W .and. segment%Flather) then do j=segment%HI%jsd,segment%HI%jed ; do I=segment%HI%IsdB,segment%HI%IedB BT_OBC%ubt_outer(I,j) = segment%normal_vel_bt(I,j) - BT_OBC%eta_outer_u(I,j) = segment%eta(I,j) + G%Z_ref*GV%Z_to_H + BT_OBC%SSH_outer_u(I,j) = segment%SSH(I,j) + G%Z_ref enddo ; enddo endif enddo endif endif - if (BT_OBC%apply_v_OBCs) then + if (BT_OBC%v_OBCs_on_PE) then if (OBC%specified_v_BCs_exist_globally) then do n = 1, OBC%number_of_segments segment => OBC%segment(n) @@ -3192,9 +4464,8 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B endif enddo endif - do J=js-1,je ; do i=is,ie ; if (OBC%segnum_v(i,J) /= OBC_NONE) then - ! Can this go in segment loop above? Is loop above wrong for wide halos?? - if (OBC%segment(OBC%segnum_v(i,J))%specified) then + do J=js-1,je ; do i=is,ie ; if (BT_OBC%v_OBC_type(i,J) /= 0) then + if (abs(BT_OBC%v_OBC_type(i,J)) == SPECIFIED_OBC) then ! Northern or southern specified OBC if (integral_BT_cont) then BT_OBC%vbt_outer(i,J) = vhbt_to_vbt(BT_OBC%vhbt(i,J)*dt_baroclinic, BTCL_v(i,J)) * I_dt elseif (use_BT_cont) then @@ -3202,21 +4473,20 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B else if (Datv(i,J) > 0.0) BT_OBC%vbt_outer(i,J) = BT_OBC%vhbt(i,J) / Datv(i,J) endif - else ! This is assuming Flather as only other option + elseif (BT_OBC%v_OBC_type(i,J) == FLATHER_OBC) then ! Northern Flather OBC if (GV%Boussinesq) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - BT_OBC%H_v(i,J) = G%bathyT(i,j)*GV%Z_to_H + eta(i,j) - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - BT_OBC%H_v(i,J) = G%bathyT(i,j+1)*GV%Z_to_H + eta(i,j+1) - endif + BT_OBC%dZ_v(i,J) = CS%bathyT(i,j) + GV%H_to_Z*eta(i,j) else - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - BT_OBC%H_v(i,J) = eta(i,j) - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - BT_OBC%H_v(i,J) = eta(i,j+1) - endif + BT_OBC%dZ_v(i,J) = GV%H_to_RZ * eta(i,j) * SpV_avg(i,j) + endif + BT_OBC%Cg_v(i,J) = SQRT(dgeo_de * GV%g_prime(1) * BT_OBC%dZ_v(i,J)) + elseif (BT_OBC%v_OBC_type(i,J) == -FLATHER_OBC) then ! Southern Flather OBC + if (GV%Boussinesq) then + BT_OBC%dZ_v(i,J) = CS%bathyT(i,j+1) + GV%H_to_Z*eta(i,j+1) + else + BT_OBC%dZ_v(i,J) = GV%H_to_RZ * eta(i,j+1) * SpV_avg(i,j+1) endif - BT_OBC%Cg_v(i,J) = SQRT(GV%g_prime(1) * GV%H_to_Z*BT_OBC%H_v(i,J)) + BT_OBC%Cg_v(i,J) = SQRT(dgeo_de * GV%g_prime(1) * BT_OBC%dZ_v(i,J)) endif endif ; enddo ; enddo if (OBC%Flather_v_BCs_exist_globally) then @@ -3225,7 +4495,7 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B if (segment%is_N_or_S .and. segment%Flather) then do J=segment%HI%JsdB,segment%HI%JedB ; do i=segment%HI%isd,segment%HI%ied BT_OBC%vbt_outer(i,J) = segment%normal_vel_bt(i,J) - BT_OBC%eta_outer_v(i,J) = segment%eta(i,J) + G%Z_ref*GV%Z_to_H + BT_OBC%SSH_outer_v(i,J) = segment%SSH(i,J) + G%Z_ref enddo ; enddo endif enddo @@ -3233,10 +4503,8 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B endif call do_group_pass(BT_OBC%pass_uv, BT_Domain) - call do_group_pass(BT_OBC%pass_uhvh, BT_Domain) - call do_group_pass(BT_OBC%pass_eta_outer, BT_Domain) - call do_group_pass(BT_OBC%pass_h, BT_Domain) - call do_group_pass(BT_OBC%pass_cg, BT_Domain) + if (OBC%Flather_u_BCs_exist_globally .or. OBC%Flather_v_BCs_exist_globally) & + call do_group_pass(BT_OBC%scalar_pass, BT_Domain) end subroutine set_up_BT_OBC @@ -3246,27 +4514,25 @@ subroutine destroy_BT_OBC(BT_OBC) !! related to the open boundary conditions, !! set by set_up_BT_OBC. - if (BT_OBC%is_alloced) then - deallocate(BT_OBC%Cg_u) - deallocate(BT_OBC%H_u) - deallocate(BT_OBC%uhbt) - deallocate(BT_OBC%ubt_outer) - deallocate(BT_OBC%eta_outer_u) - - deallocate(BT_OBC%Cg_v) - deallocate(BT_OBC%H_v) - deallocate(BT_OBC%vhbt) - deallocate(BT_OBC%vbt_outer) - deallocate(BT_OBC%eta_outer_v) - BT_OBC%is_alloced = .false. - endif + if (allocated(BT_OBC%u_OBC_type)) deallocate(BT_OBC%u_OBC_type) + if (allocated(BT_OBC%v_OBC_type)) deallocate(BT_OBC%v_OBC_type) + + if (allocated(BT_OBC%Cg_u)) deallocate(BT_OBC%Cg_u) + if (allocated(BT_OBC%dZ_u)) deallocate(BT_OBC%dZ_u) + if (allocated(BT_OBC%uhbt)) deallocate(BT_OBC%uhbt) + if (allocated(BT_OBC%ubt_outer)) deallocate(BT_OBC%ubt_outer) + if (allocated(BT_OBC%SSH_outer_u)) deallocate(BT_OBC%SSH_outer_u) + + if (allocated(BT_OBC%Cg_v)) deallocate(BT_OBC%Cg_v) + if (allocated(BT_OBC%dZ_v)) deallocate(BT_OBC%dZ_v) + if (allocated(BT_OBC%vhbt)) deallocate(BT_OBC%vhbt) + if (allocated(BT_OBC%vbt_outer)) deallocate(BT_OBC%vbt_outer) + if (allocated(BT_OBC%SSH_outer_v)) deallocate(BT_OBC%SSH_outer_v) + end subroutine destroy_BT_OBC -!> btcalc calculates the barotropic velocities from the full velocity and -!! thickness fields, determines the fraction of the total water column in each -!! layer at velocity points, and determines a corrective fictitious mass source -!! that will drive the barotropic estimate of the free surface height toward the -!! baroclinic estimate. +!> btcalc determines the fraction of the total water column in each +!! layer at velocity points. subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -3274,9 +4540,19 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. type(barotropic_CS), intent(inout) :: CS !< Barotropic control structure real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - optional, intent(in) :: h_u !< The specified thicknesses at u-points [H ~> m or kg m-2]. + optional, intent(in) :: h_u !< The specified effective thicknesses at u-points, + !! perhaps scaled down to account for viscosity and + !! fractional open areas [H ~> m or kg m-2]. These + !! are used here as non-normalized weights for each + !! layer that are converted the normalized weights + !! for determining the barotropic accelerations. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - optional, intent(in) :: h_v !< The specified thicknesses at v-points [H ~> m or kg m-2]. + optional, intent(in) :: h_v !< The specified effective thicknesses at v-points, + !! perhaps scaled down to account for viscosity and + !! fractional open areas [H ~> m or kg m-2]. These + !! are used here as non-normalized weights for each + !! layer that are converted the normalized weights + !! for determining the barotropic accelerations. logical, optional, intent(in) :: may_use_default !< An optional logical argument !! to indicate that the default velocity point !! thicknesses may be used for this particular @@ -3286,6 +4562,8 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) type(ocean_OBC_type), optional, pointer :: OBC !< Open boundary control structure. ! Local variables + real :: hatu(SZIB_(G),SZK_(GV)) ! The layer thicknesses interpolated to u points [H ~> m or kg m-2] + real :: hatv(SZI_(G),SZK_(GV)) ! The layer thicknesses interpolated to v points [H ~> m or kg m-2] real :: hatutot(SZIB_(G)) ! The sum of the layer thicknesses interpolated to u points [H ~> m or kg m-2]. real :: hatvtot(SZI_(G)) ! The sum of the layer thicknesses interpolated to v points [H ~> m or kg m-2]. real :: Ihatutot(SZIB_(G)) ! Ihatutot is the inverse of hatutot [H-1 ~> m-1 or m2 kg-1]. @@ -3296,22 +4574,17 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: wt_arith ! The weight for the arithmetic mean thickness [nondim]. ! The harmonic mean uses a weight of (1 - wt_arith). - real :: Rh ! A ratio of summed thicknesses, nondim. - real :: e_u(SZIB_(G),SZK_(GV)+1) ! The interface heights at u-velocity and - real :: e_v(SZI_(G),SZK_(GV)+1) ! v-velocity points [H ~> m or kg m-2]. + real :: e_u(SZIB_(G),SZK_(GV)+1) ! The interface heights at u-velocity points [H ~> m or kg m-2] + real :: e_v(SZI_(G),SZK_(GV)+1) ! The interface heights at v-velocity points [H ~> m or kg m-2] real :: D_shallow_u(SZI_(G)) ! The height of the shallower of the adjacent bathymetric depths ! around a u-point (positive upward) [H ~> m or kg m-2] real :: D_shallow_v(SZIB_(G))! The height of the shallower of the adjacent bathymetric depths ! around a v-point (positive upward) [H ~> m or kg m-2] - real :: htot ! The sum of the layer thicknesses [H ~> m or kg m-2]. - real :: Ihtot ! The inverse of htot [H-1 ~> m-1 or m2 kg-1]. + real :: Z_to_H ! A local conversion factor [H Z-1 ~> nondim or kg m-3] - logical :: use_default, test_dflt, apply_OBCs + logical :: use_default, test_dflt integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, i, j, k - integer :: iss, ies, n -! This section interpolates thicknesses onto u & v grid points with the -! second order accurate estimate h = 2*(h+ * h-)/(h+ + h-). if (.not.CS%module_is_initialized) call MOM_error(FATAL, & "btcalc: Module MOM_barotropic must be initialized before it is used.") @@ -3331,202 +4604,167 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) "btcalc: Inconsistent settings of optional arguments and hvel_scheme.") endif - apply_OBCs = .false. - if (present(OBC)) then ; if (associated(OBC)) then ; if (OBC%OBC_pe) then - ! Some open boundary condition points might be in this processor's symmetric - ! computational domain. - apply_OBCs = (OBC%number_of_segments > 0) - endif ; endif ; endif - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB h_neglect = GV%H_subroundoff - ! This estimates the fractional thickness of each layer at the velocity - ! points, using a harmonic mean estimate. -!$OMP parallel do default(none) shared(is,ie,js,je,nz,h_u,CS,h_neglect,h,use_default,G,GV) & -!$OMP private(hatutot,Ihatutot,e_u,D_shallow_u,h_arith,h_harm,wt_arith) + !$OMP parallel do default(none) shared(is,ie,js,je,nz,h_u,CS,h_neglect,h,use_default,G,GV) & + !$OMP private(hatu,hatutot,Ihatutot,e_u,D_shallow_u,h_arith,h_harm,wt_arith,Z_to_H) do j=js,je + do I=is-1,ie ; hatutot(I) = 0.0 ; enddo + if (present(h_u)) then - do I=is-1,ie ; hatutot(I) = h_u(I,j,1) ; enddo - do k=2,nz ; do I=is-1,ie - hatutot(I) = hatutot(I) + h_u(I,j,k) + do k=1,nz ; do I=is-1,ie + hatu(I,k) = h_u(I,j,k) + hatutot(I) = hatutot(I) + hatu(I,k) enddo ; enddo - do I=is-1,ie ; Ihatutot(I) = G%mask2dCu(I,j) / (hatutot(I) + h_neglect) ; enddo + elseif (CS%hvel_scheme == ARITHMETIC) then do k=1,nz ; do I=is-1,ie - CS%frhatu(I,j,k) = h_u(I,j,k) * Ihatutot(I) + hatu(I,k) = 0.5 * (h(i+1,j,k) + h(i,j,k)) + hatutot(I) = hatutot(I) + hatu(I,k) enddo ; enddo - else - if (CS%hvel_scheme == ARITHMETIC) then - do I=is-1,ie - CS%frhatu(I,j,1) = 0.5 * (h(i+1,j,1) + h(i,j,1)) - hatutot(I) = CS%frhatu(I,j,1) - enddo - do k=2,nz ; do I=is-1,ie - CS%frhatu(I,j,k) = 0.5 * (h(i+1,j,k) + h(i,j,k)) - hatutot(I) = hatutot(I) + CS%frhatu(I,j,k) - enddo ; enddo - elseif (CS%hvel_scheme == HYBRID .or. use_default) then - do I=is-1,ie - e_u(I,nz+1) = -0.5 * GV%Z_to_H * (G%bathyT(i+1,j) + G%bathyT(i,j)) - D_shallow_u(I) = -GV%Z_to_H * min(G%bathyT(i+1,j), G%bathyT(i,j)) - hatutot(I) = 0.0 - enddo - do k=nz,1,-1 ; do I=is-1,ie - e_u(I,K) = e_u(I,K+1) + 0.5 * (h(i+1,j,k) + h(i,j,k)) - h_arith = 0.5 * (h(i+1,j,k) + h(i,j,k)) - if (e_u(I,K+1) >= D_shallow_u(I)) then - CS%frhatu(I,j,k) = h_arith + elseif (CS%hvel_scheme == HYBRID .or. use_default) then + Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin + do I=is-1,ie + e_u(I,nz+1) = -0.5 * Z_to_H * (G%bathyT(i+1,j) + G%bathyT(i,j)) + D_shallow_u(I) = -Z_to_H * min(G%bathyT(i+1,j), G%bathyT(i,j)) + enddo + do k=nz,1,-1 ; do I=is-1,ie + e_u(I,K) = e_u(I,K+1) + 0.5 * (h(i+1,j,k) + h(i,j,k)) + h_arith = 0.5 * (h(i+1,j,k) + h(i,j,k)) + if (e_u(I,K+1) >= D_shallow_u(I)) then + hatu(I,k) = h_arith + else + h_harm = (h(i+1,j,k) * h(i,j,k)) / (h_arith + h_neglect) + if (e_u(I,K) <= D_shallow_u(I)) then + hatu(I,k) = h_harm else - h_harm = (h(i+1,j,k) * h(i,j,k)) / (h_arith + h_neglect) - if (e_u(I,K) <= D_shallow_u(I)) then - CS%frhatu(I,j,k) = h_harm - else - wt_arith = (e_u(I,K) - D_shallow_u(I)) / (h_arith + h_neglect) - CS%frhatu(I,j,k) = wt_arith*h_arith + (1.0-wt_arith)*h_harm - endif + wt_arith = (e_u(I,K) - D_shallow_u(I)) / (h_arith + h_neglect) + hatu(I,k) = wt_arith*h_arith + (1.0-wt_arith)*h_harm endif - hatutot(I) = hatutot(I) + CS%frhatu(I,j,k) - enddo ; enddo - elseif (CS%hvel_scheme == HARMONIC) then - do I=is-1,ie - CS%frhatu(I,j,1) = 2.0*(h(i+1,j,1) * h(i,j,1)) / & - ((h(i+1,j,1) + h(i,j,1)) + h_neglect) - hatutot(I) = CS%frhatu(I,j,1) - enddo - do k=2,nz ; do I=is-1,ie - CS%frhatu(I,j,k) = 2.0*(h(i+1,j,k) * h(i,j,k)) / & - ((h(i+1,j,k) + h(i,j,k)) + h_neglect) - hatutot(I) = hatutot(I) + CS%frhatu(I,j,k) - enddo ; enddo - endif - do I=is-1,ie ; Ihatutot(I) = G%mask2dCu(I,j) / (hatutot(I) + h_neglect) ; enddo + endif + hatutot(I) = hatutot(I) + hatu(I,k) + enddo ; enddo + elseif (CS%hvel_scheme == HARMONIC) then + ! Interpolates thicknesses onto u grid points with the + ! second order accurate estimate h = 2*(h+ * h-)/(h+ + h-). do k=1,nz ; do I=is-1,ie - CS%frhatu(I,j,k) = CS%frhatu(I,j,k) * Ihatutot(I) + hatu(I,k) = 2.0*(h(i+1,j,k) * h(i,j,k)) / & + ((h(i+1,j,k) + h(i,j,k)) + h_neglect) + hatutot(I) = hatutot(I) + hatu(I,k) enddo ; enddo endif + + if (CS%BT_OBC%u_OBCs_on_PE) then + ! Reset velocity point thicknesses and their sums at OBC points + if ((j >= CS%BT_OBC%js_u_E_obc) .and. (j <= CS%BT_OBC%je_u_E_obc)) then + do I = max(is-1,CS%BT_OBC%Is_u_E_obc), min(ie,CS%BT_OBC%Ie_u_E_obc) + if (CS%BT_OBC%u_OBC_type(I,j) > 0) then ! Eastern boundary condition + hatutot(I) = 0.0 + do k=1,nz + hatu(I,k) = h(i,j,k) + hatutot(I) = hatutot(I) + hatu(I,k) + enddo + endif + enddo + endif + if ((j >= CS%BT_OBC%js_u_W_obc) .and. (j <= CS%BT_OBC%je_u_W_obc)) then + do I = max(is-1,CS%BT_OBC%Is_u_W_obc), min(ie,CS%BT_OBC%Ie_u_W_obc) + if (CS%BT_OBC%u_OBC_type(I,j) < 0) then ! Western boundary condition + hatutot(I) = 0.0 + do k=1,nz + hatu(I,k) = h(i+1,j,k) + hatutot(I) = hatutot(I) + hatu(I,k) + enddo + endif + enddo + endif + endif + + ! Determine the fractional thickness of each layer at the velocity points. + do I=is-1,ie ; Ihatutot(I) = G%mask2dCu(I,j) / (hatutot(I) + h_neglect) ; enddo + do k=1,nz ; do I=is-1,ie + CS%frhatu(I,j,k) = hatu(I,k) * Ihatutot(I) + enddo ; enddo enddo -!$OMP parallel do default(none) shared(is,ie,js,je,nz,CS,G,GV,h_v,h_neglect,h,use_default) & -!$OMP private(hatvtot,Ihatvtot,e_v,D_shallow_v,h_arith,h_harm,wt_arith) + !$OMP parallel do default(none) shared(is,ie,js,je,nz,CS,G,GV,h_v,h_neglect,h,use_default) & + !$OMP private(hatv,hatvtot,Ihatvtot,e_v,D_shallow_v,h_arith,h_harm,wt_arith,Z_to_H) do J=js-1,je + do i=is,ie ; hatvtot(i) = 0.0 ; enddo if (present(h_v)) then - do i=is,ie ; hatvtot(i) = h_v(i,J,1) ; enddo - do k=2,nz ; do i=is,ie - hatvtot(i) = hatvtot(i) + h_v(i,J,k) + do k=1,nz ; do i=is,ie + hatv(i,k) = h_v(i,J,k) + hatvtot(i) = hatvtot(i) + hatv(i,k) enddo ; enddo - do i=is,ie ; Ihatvtot(i) = G%mask2dCv(i,J) / (hatvtot(i) + h_neglect) ; enddo + elseif (CS%hvel_scheme == ARITHMETIC) then do k=1,nz ; do i=is,ie - CS%frhatv(i,J,k) = h_v(i,J,k) * Ihatvtot(i) + hatv(i,k) = 0.5 * (h(i,j+1,k) + h(i,j,k)) + hatvtot(i) = hatvtot(i) + hatv(i,k) enddo ; enddo - else - if (CS%hvel_scheme == ARITHMETIC) then - do i=is,ie - CS%frhatv(i,J,1) = 0.5 * (h(i,j+1,1) + h(i,j,1)) - hatvtot(i) = CS%frhatv(i,J,1) - enddo - do k=2,nz ; do i=is,ie - CS%frhatv(i,J,k) = 0.5 * (h(i,j+1,k) + h(i,j,k)) - hatvtot(i) = hatvtot(i) + CS%frhatv(i,J,k) - enddo ; enddo - elseif (CS%hvel_scheme == HYBRID .or. use_default) then - do i=is,ie - e_v(i,nz+1) = -0.5 * GV%Z_to_H * (G%bathyT(i,j+1) + G%bathyT(i,j)) - D_shallow_v(I) = -GV%Z_to_H * min(G%bathyT(i,j+1), G%bathyT(i,j)) - hatvtot(I) = 0.0 - enddo - do k=nz,1,-1 ; do i=is,ie - e_v(i,K) = e_v(i,K+1) + 0.5 * (h(i,j+1,k) + h(i,j,k)) - h_arith = 0.5 * (h(i,j+1,k) + h(i,j,k)) - if (e_v(i,K+1) >= D_shallow_v(i)) then - CS%frhatv(i,J,k) = h_arith + elseif (CS%hvel_scheme == HYBRID .or. use_default) then + Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin + do i=is,ie + e_v(i,nz+1) = -0.5 * Z_to_H * (G%bathyT(i,j+1) + G%bathyT(i,j)) + D_shallow_v(I) = -Z_to_H * min(G%bathyT(i,j+1), G%bathyT(i,j)) + enddo + do k=nz,1,-1 ; do i=is,ie + e_v(i,K) = e_v(i,K+1) + 0.5 * (h(i,j+1,k) + h(i,j,k)) + h_arith = 0.5 * (h(i,j+1,k) + h(i,j,k)) + if (e_v(i,K+1) >= D_shallow_v(i)) then + hatv(i,k) = h_arith + else + h_harm = (h(i,j+1,k) * h(i,j,k)) / (h_arith + h_neglect) + if (e_v(i,K) <= D_shallow_v(i)) then + hatv(i,k) = h_harm else - h_harm = (h(i,j+1,k) * h(i,j,k)) / (h_arith + h_neglect) - if (e_v(i,K) <= D_shallow_v(i)) then - CS%frhatv(i,J,k) = h_harm - else - wt_arith = (e_v(i,K) - D_shallow_v(i)) / (h_arith + h_neglect) - CS%frhatv(i,J,k) = wt_arith*h_arith + (1.0-wt_arith)*h_harm - endif + wt_arith = (e_v(i,K) - D_shallow_v(i)) / (h_arith + h_neglect) + hatv(i,k) = wt_arith*h_arith + (1.0-wt_arith)*h_harm endif - hatvtot(i) = hatvtot(i) + CS%frhatv(i,J,k) - enddo ; enddo - elseif (CS%hvel_scheme == HARMONIC) then - do i=is,ie - CS%frhatv(i,J,1) = 2.0*(h(i,j+1,1) * h(i,j,1)) / & - ((h(i,j+1,1) + h(i,j,1)) + h_neglect) - hatvtot(i) = CS%frhatv(i,J,1) - enddo - do k=2,nz ; do i=is,ie - CS%frhatv(i,J,k) = 2.0*(h(i,j+1,k) * h(i,j,k)) / & - ((h(i,j+1,k) + h(i,j,k)) + h_neglect) - hatvtot(i) = hatvtot(i) + CS%frhatv(i,J,k) - enddo ; enddo - endif - do i=is,ie ; Ihatvtot(i) = G%mask2dCv(i,J) / (hatvtot(i) + h_neglect) ; enddo + endif + hatvtot(i) = hatvtot(i) + hatv(i,k) + enddo ; enddo + elseif (CS%hvel_scheme == HARMONIC) then do k=1,nz ; do i=is,ie - CS%frhatv(i,J,k) = CS%frhatv(i,J,k) * Ihatvtot(i) + hatv(i,k) = 2.0*(h(i,j+1,k) * h(i,j,k)) / & + ((h(i,j+1,k) + h(i,j,k)) + h_neglect) + hatvtot(i) = hatvtot(i) + hatv(i,k) enddo ; enddo endif - enddo - if (apply_OBCs) then ; do n=1,OBC%number_of_segments ! Test for segment type? - if (.not. OBC%segment(n)%on_pe) cycle - if (OBC%segment(n)%direction == OBC_DIRECTION_N) then - J = OBC%segment(n)%HI%JsdB - if ((J >= js-1) .and. (J <= je)) then - iss = max(is,OBC%segment(n)%HI%isd) ; ies = min(ie,OBC%segment(n)%HI%ied) - do i=iss,ies ; hatvtot(i) = h(i,j,1) ; enddo - do k=2,nz ; do i=iss,ies - hatvtot(i) = hatvtot(i) + h(i,j,k) - enddo ; enddo - do i=iss,ies - Ihatvtot(i) = G%mask2dCv(i,J) / (hatvtot(i) + h_neglect) - enddo - do k=1,nz ; do i=iss,ies - CS%frhatv(i,J,k) = h(i,j,k) * Ihatvtot(i) - enddo ; enddo - endif - elseif (OBC%segment(n)%direction == OBC_DIRECTION_S) then - J = OBC%segment(n)%HI%JsdB - if ((J >= js-1) .and. (J <= je)) then - iss = max(is,OBC%segment(n)%HI%isd) ; ies = min(ie,OBC%segment(n)%HI%ied) - do i=iss,ies ; hatvtot(i) = h(i,j+1,1) ; enddo - do k=2,nz ; do i=iss,ies - hatvtot(i) = hatvtot(i) + h(i,j+1,k) - enddo ; enddo - do i=iss,ies - Ihatvtot(i) = G%mask2dCv(i,J) / (hatvtot(i) + h_neglect) - enddo - do k=1,nz ; do i=iss,ies - CS%frhatv(i,J,k) = h(i,j+1,k) * Ihatvtot(i) - enddo ; enddo - endif - elseif (OBC%segment(n)%direction == OBC_DIRECTION_E) then - I = OBC%segment(n)%HI%IsdB - if ((I >= is-1) .and. (I <= ie)) then - do j = max(js,OBC%segment(n)%HI%jsd), min(je,OBC%segment(n)%HI%jed) - htot = h(i,j,1) - do k=2,nz ; htot = htot + h(i,j,k) ; enddo - Ihtot = G%mask2dCu(I,j) / (htot + h_neglect) - do k=1,nz ; CS%frhatu(I,j,k) = h(i,j,k) * Ihtot ; enddo + if (CS%BT_OBC%v_OBCs_on_PE) then + ! Reset v-velocity point thicknesses and their sums at OBC points + if ((J >= CS%BT_OBC%Js_v_N_obc) .and. (J <= CS%BT_OBC%Je_v_N_obc)) then + do i = max(is,CS%BT_OBC%is_v_N_obc), min(ie,CS%BT_OBC%ie_v_N_obc) + if (CS%BT_OBC%v_OBC_type(i,J) > 0) then ! Northern boundary condition + hatvtot(i) = 0.0 + do k=1,nz + hatv(i,k) = h(i,j,k) + hatvtot(i) = hatvtot(i) + hatv(i,k) + enddo + endif enddo endif - elseif (OBC%segment(n)%direction == OBC_DIRECTION_W) then - I = OBC%segment(n)%HI%IsdB - if ((I >= is-1) .and. (I <= ie)) then - do j = max(js,OBC%segment(n)%HI%jsd), min(je,OBC%segment(n)%HI%jed) - htot = h(i+1,j,1) - do k=2,nz ; htot = htot + h(i+1,j,k) ; enddo - Ihtot = G%mask2dCu(I,j) / (htot + h_neglect) - do k=1,nz ; CS%frhatu(I,j,k) = h(i+1,j,k) * Ihtot ; enddo + if ((J >= CS%BT_OBC%Js_v_S_obc) .and. (J <= CS%BT_OBC%Je_v_S_obc)) then + do i = max(is,CS%BT_OBC%is_v_S_obc), min(ie,CS%BT_OBC%ie_v_S_obc) + if (CS%BT_OBC%v_OBC_type(i,J) < 0) then ! Southern boundary condition + hatvtot(i) = 0.0 + do k=1,nz + hatv(i,k) = h(i,j+1,k) + hatvtot(i) = hatvtot(i) + hatv(i,k) + enddo + endif enddo endif - else - call MOM_error(fatal, "btcalc encountered and OBC segment of indeterminate direction.") endif - enddo ; endif + + ! Determine the fractional thickness of each layer at the velocity points. + do i=is,ie ; Ihatvtot(i) = G%mask2dCv(i,J) / (hatvtot(i) + h_neglect) ; enddo + do k=1,nz ; do i=is,ie + CS%frhatv(i,J,k) = hatv(i,k) * Ihatvtot(i) + enddo ; enddo + enddo if (CS%debug) then call uvchksum("btcalc frhat[uv]", CS%frhatu, CS%frhatv, G%HI, & @@ -3534,9 +4772,9 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) scalar_pair=.true.) if (present(h_u) .and. present(h_v)) & call uvchksum("btcalc h_[uv]", h_u, h_v, G%HI, haloshift=0, & - symmetric=.true., omit_corners=.true., scale=GV%H_to_m, & + symmetric=.true., omit_corners=.true., unscale=GV%H_to_MKS, & scalar_pair=.true.) - call hchksum(h, "btcalc h",G%HI, haloshift=1, scale=GV%H_to_m) + call hchksum(h, "btcalc h", G%HI, haloshift=1, unscale=GV%H_to_MKS) endif end subroutine btcalc @@ -3612,8 +4850,6 @@ function uhbt_to_ubt(uhbt, BTC) result(ubt) real :: uherr_min, uherr_max ! The bounding values of the transport error [H L2 T-1 ~> m3 s-1 or kg s-1] ! or [H L2 ~> m3 or kg]. real, parameter :: tol = 1.0e-10 ! A fractional match tolerance [nondim] - real :: dvel ! Temporary variable used in the limiting the velocity [L T-1 ~> m s-1] or [L ~> m]. - real :: vsr ! Temporary variable used in the limiting the velocity [nondim]. real, parameter :: vs1 = 1.25 ! Nondimensional parameters used in limiting real, parameter :: vs2 = 2.0 ! the velocity, starting at vs1, with the ! maximum increase of vs2, both [nondim]. @@ -3747,8 +4983,6 @@ function vhbt_to_vbt(vhbt, BTC) result(vbt) real :: vherr_min, vherr_max ! The bounding values of the transport error [H L2 T-1 ~> m3 s-1 or kg s-1] ! or [H L2 ~> m3 or kg]. real, parameter :: tol = 1.0e-10 ! A fractional match tolerance [nondim] - real :: dvel ! Temporary variable used in the limiting the velocity [L T-1 ~> m s-1] or [L ~> m]. - real :: vsr ! Temporary variable used in the limiting the velocity [nondim]. real, parameter :: vs1 = 1.25 ! Nondimensional parameters used in limiting real, parameter :: vs2 = 2.0 ! the velocity, starting at vs1, with the ! maximum increase of vs2, both [nondim]. @@ -3840,7 +5074,7 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain vBT_NN, vBT_SS, & ! Meridional velocities at which the form of the fit changes [L T-1 ~> m s-1] FA_v_NN, FA_v_N0, FA_v_S0, FA_v_SS ! Meridional face areas [H L ~> m2 or kg m-1] real :: dt ! The baroclinic timestep [T ~> s] or 1.0 [nondim] - real, parameter :: C1_3 = 1.0/3.0 + real, parameter :: C1_3 = 1.0/3.0 ! [nondim] integer :: i, j, is, ie, js, je, hs is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -3848,34 +5082,32 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain dt = 1.0 ; if (present(dt_baroclinic)) dt = dt_baroclinic ! Copy the BT_cont arrays into symmetric, potentially wide haloed arrays. -!$OMP parallel default(none) shared(is,ie,js,je,hs,u_polarity,uBT_EE,uBT_WW,FA_u_EE, & -!$OMP FA_u_E0,FA_u_W0,FA_u_WW,v_polarity,vBT_NN,vBT_SS,& -!$OMP FA_v_NN,FA_v_N0,FA_v_S0,FA_v_SS,BT_cont ) -!$OMP do + !$OMP parallel default(shared) + !$OMP do do j=js-hs,je+hs ; do i=is-hs-1,ie+hs u_polarity(i,j) = 1.0 uBT_EE(i,j) = 0.0 ; uBT_WW(i,j) = 0.0 FA_u_EE(i,j) = 0.0 ; FA_u_E0(i,j) = 0.0 ; FA_u_W0(i,j) = 0.0 ; FA_u_WW(i,j) = 0.0 enddo ; enddo -!$OMP do + !$OMP do do j=js-hs-1,je+hs ; do i=is-hs,ie+hs v_polarity(i,j) = 1.0 vBT_NN(i,j) = 0.0 ; vBT_SS(i,j) = 0.0 FA_v_NN(i,j) = 0.0 ; FA_v_N0(i,j) = 0.0 ; FA_v_S0(i,j) = 0.0 ; FA_v_SS(i,j) = 0.0 enddo ; enddo -!$OMP do + !$OMP do do j=js,je ; do I=is-1,ie uBT_EE(I,j) = BT_cont%uBT_EE(I,j) ; uBT_WW(I,j) = BT_cont%uBT_WW(I,j) FA_u_EE(I,j) = BT_cont%FA_u_EE(I,j) ; FA_u_E0(I,j) = BT_cont%FA_u_E0(I,j) FA_u_W0(I,j) = BT_cont%FA_u_W0(I,j) ; FA_u_WW(I,j) = BT_cont%FA_u_WW(I,j) enddo ; enddo -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie vBT_NN(i,J) = BT_cont%vBT_NN(i,J) ; vBT_SS(i,J) = BT_cont%vBT_SS(i,J) FA_v_NN(i,J) = BT_cont%FA_v_NN(i,J) ; FA_v_N0(i,J) = BT_cont%FA_v_N0(i,J) FA_v_S0(i,J) = BT_cont%FA_v_S0(i,J) ; FA_v_SS(i,J) = BT_cont%FA_v_SS(i,J) enddo ; enddo -!$OMP end parallel + !$OMP end parallel if (id_clock_calc_pre > 0) call cpu_clock_end(id_clock_calc_pre) if (id_clock_pass_pre > 0) call cpu_clock_begin(id_clock_pass_pre) @@ -3975,7 +5207,7 @@ subroutine adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & ! Local variables real :: dt ! The baroclinic timestep [T ~> s] or 1.0 [nondim] - real, parameter :: C1_3 = 1.0/3.0 + real, parameter :: C1_3 = 1.0/3.0 ! [nondim] integer :: i, j, is, ie, js, je, hs is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -4105,38 +5337,38 @@ subroutine find_face_areas(Datu, Datv, G, GV, US, CS, MS, halo, eta, add_max) ! Local variables real :: H1, H2 ! Temporary total thicknesses [H ~> m or kg m-2]. + real :: Z_to_H ! A local conversion factor [H Z-1 ~> nondim or kg m-3] integer :: i, j, is, ie, js, je, hs is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec hs = max(halo,0) -!$OMP parallel default(none) shared(is,ie,js,je,hs,eta,GV,G,CS,Datu,Datv,add_max) & -!$OMP private(H1,H2) + !$OMP parallel default(shared) private(H1,H2,Z_to_H) if (present(eta)) then ! The use of harmonic mean thicknesses ensure positive definiteness. if (GV%Boussinesq) then -!$OMP do + !$OMP do do j=js-hs,je+hs ; do I=is-1-hs,ie+hs H1 = CS%bathyT(i,j)*GV%Z_to_H + eta(i,j) ; H2 = CS%bathyT(i+1,j)*GV%Z_to_H + eta(i+1,j) Datu(I,j) = 0.0 ; if ((H1 > 0.0) .and. (H2 > 0.0)) & Datu(I,j) = CS%dy_Cu(I,j) * (2.0 * H1 * H2) / (H1 + H2) -! Datu(I,j) = CS%dy_Cu(I,j) * 0.5 * (H1 + H2) + ! Datu(I,j) = CS%dy_Cu(I,j) * 0.5 * (H1 + H2) enddo ; enddo -!$OMP do + !$OMP do do J=js-1-hs,je+hs ; do i=is-hs,ie+hs H1 = CS%bathyT(i,j)*GV%Z_to_H + eta(i,j) ; H2 = CS%bathyT(i,j+1)*GV%Z_to_H + eta(i,j+1) Datv(i,J) = 0.0 ; if ((H1 > 0.0) .and. (H2 > 0.0)) & Datv(i,J) = CS%dx_Cv(i,J) * (2.0 * H1 * H2) / (H1 + H2) -! Datv(i,J) = CS%dy_v(i,J) * 0.5 * (H1 + H2) + ! Datv(i,J) = CS%dy_v(i,J) * 0.5 * (H1 + H2) enddo ; enddo else -!$OMP do + !$OMP do do j=js-hs,je+hs ; do I=is-1-hs,ie+hs Datu(I,j) = 0.0 ; if ((eta(i,j) > 0.0) .and. (eta(i+1,j) > 0.0)) & Datu(I,j) = CS%dy_Cu(I,j) * (2.0 * eta(i,j) * eta(i+1,j)) / & (eta(i,j) + eta(i+1,j)) ! Datu(I,j) = CS%dy_Cu(I,j) * 0.5 * (eta(i,j) + eta(i+1,j)) enddo ; enddo -!$OMP do + !$OMP do do J=js-1-hs,je+hs ; do i=is-hs,ie+hs Datv(i,J) = 0.0 ; if ((eta(i,j) > 0.0) .and. (eta(i,j+1) > 0.0)) & Datv(i,J) = CS%dx_Cv(i,J) * (2.0 * eta(i,j) * eta(i,j+1)) / & @@ -4145,33 +5377,41 @@ subroutine find_face_areas(Datu, Datv, G, GV, US, CS, MS, halo, eta, add_max) enddo ; enddo endif elseif (present(add_max)) then -!$OMP do + Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin + + !$OMP do do j=js-hs,je+hs ; do I=is-1-hs,ie+hs - Datu(I,j) = CS%dy_Cu(I,j) * GV%Z_to_H * & - max(max(CS%bathyT(i+1,j), CS%bathyT(i,j)) + (G%Z_ref + add_max), 0.0) + H1 = max((G%meanSL(i+1,j) + add_max) + G%bathyT(i+1,j), 0.0) + H2 = max((G%meanSL(i,j) + add_max) + G%bathyT(i,j), 0.0) + Datu(I,j) = CS%dy_Cu(I,j) * Z_to_H * max(H1, H2) enddo ; enddo -!$OMP do + !$OMP do do J=js-1-hs,je+hs ; do i=is-hs,ie+hs - Datv(i,J) = CS%dx_Cv(i,J) * GV%Z_to_H * & - max(max(CS%bathyT(i,j+1), CS%bathyT(i,j)) + (G%Z_ref + add_max), 0.0) + H1 = max((G%meanSL(i,j+1) + add_max) + G%bathyT(i,j+1), 0.0) + H2 = max((G%meanSL(i,j) + add_max) + G%bathyT(i,j), 0.0) + Datv(i,J) = CS%dx_Cv(i,J) * Z_to_H * max(H1, H2) enddo ; enddo else -!$OMP do + Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin + + !$OMP do do j=js-hs,je+hs ; do I=is-1-hs,ie+hs - H1 = (CS%bathyT(i,j) + G%Z_ref) * GV%Z_to_H ; H2 = (CS%bathyT(i+1,j) + G%Z_ref) * GV%Z_to_H + H1 = max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) * Z_to_H + H2 = max(G%meanSL(i+1,j) + G%bathyT(i+1,j), 0.0) * Z_to_H Datu(I,j) = 0.0 if ((H1 > 0.0) .and. (H2 > 0.0)) & Datu(I,j) = CS%dy_Cu(I,j) * (2.0 * H1 * H2) / (H1 + H2) enddo ; enddo -!$OMP do + !$OMP do do J=js-1-hs,je+hs ; do i=is-hs,ie+hs - H1 = (CS%bathyT(i,j) + G%Z_ref) * GV%Z_to_H ; H2 = (CS%bathyT(i,j+1) + G%Z_ref) * GV%Z_to_H + H1 = max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) * Z_to_H + H2 = max(G%meanSL(i,j+1) + G%bathyT(i,j+1), 0.0) * Z_to_H Datv(i,J) = 0.0 if ((H1 > 0.0) .and. (H2 > 0.0)) & Datv(i,J) = CS%dx_Cv(i,J) * (2.0 * H1 * H2) / (H1 + H2) enddo ; enddo endif -!$OMP end parallel + !$OMP end parallel end subroutine find_face_areas @@ -4237,8 +5477,8 @@ end subroutine bt_mass_source !> barotropic_init initializes a number of time-invariant fields used in the !! barotropic calculation and initializes any barotropic fields that have not !! already been initialized. -subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, & - restart_CS, calc_dtbt, BT_cont, tides_CSp) +subroutine barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, CS, & + restart_CS, calc_dtbt, BT_cont, OBC, SAL_CSp, HA_CSp) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -4248,9 +5488,6 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G)), & - intent(in) :: eta !< Free surface height or column mass anomaly - !! [Z ~> m] or [H ~> kg m-2]. type(time_type), target, intent(in) :: Time !< The current model time. type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic @@ -4262,8 +5499,11 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, type(BT_cont_type), pointer :: BT_cont !< A structure with elements that describe the !! effective open face areas as a function of !! barotropic flow. - type(tidal_forcing_CS), target, optional :: tides_CSp !< A pointer to the control structure of the - !! tide module. + type(ocean_OBC_type), pointer :: OBC !< The open boundary condition structure. + type(SAL_CS), target, optional :: SAL_CSp !< A pointer to the control structure of the + !! SAL module. + type(harmonic_analysis_CS), target, optional :: HA_CSp !< A pointer to the control structure of the + !! harmonic analysis module ! This include declares and sets the variable "version". # include "version_variable.h" @@ -4271,35 +5511,47 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, character(len=40) :: mdl = "MOM_barotropic" ! This module's name. real :: Datu(SZIBS_(G),SZJ_(G)) ! Zonal open face area [H L ~> m2 or kg m-1]. real :: Datv(SZI_(G),SZJBS_(G)) ! Meridional open face area [H L ~> m2 or kg m-1]. - real :: gtot_estimate ! Summed GV%g_prime [L2 Z-1 T-2 ~> m s-2], to give an upper-bound estimate for pbce. + real :: gtot_estimate ! Summed GV%g_prime [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2], to give an + ! upper-bound estimate for pbce. real :: SSH_extra ! An estimate of how much higher SSH might get, for use ! in calculating the safe external wave speed [Z ~> m]. real :: dtbt_input ! The input value of DTBT, [nondim] if negative or [s] if positive. - real :: dtbt_tmp ! A temporary copy of CS%dtbt read from a restart file [T ~> s] + real :: dtbt_restart ! A temporary copy of CS%dtbt read from a restart file [T ~> s] real :: wave_drag_scale ! A scaling factor for the barotropic linear wave drag - ! piston velocities. + ! piston velocities [nondim]. character(len=200) :: inputdir ! The directory in which to find input files. character(len=200) :: wave_drag_file ! The file from which to read the wave ! drag piston velocity. character(len=80) :: wave_drag_var ! The wave drag piston velocity variable ! name in wave_drag_file. - real :: vel_rescale ! A rescaling factor for horizontal velocity from the representation in - ! a restart file to the internal representation in this run. - real :: uH_rescale ! A rescaling factor for thickness transports from the representation in - ! a restart file to the internal representation in this run. - real :: mean_SL ! The mean sea level that is used along with the bathymetry to estimate the - ! geometry when LINEARIZED_BT_CORIOLIS is true or BT_NONLIN_STRESS is false [Z ~> m]. + character(len=80) :: wave_drag_u ! The wave drag piston velocity variable + ! name in wave_drag_file. + character(len=80) :: wave_drag_v ! The wave drag piston velocity variable + ! name in wave_drag_file. + real :: htot ! Total column thickness used when BT_NONLIN_STRESS is false [Z ~> m]. + real :: Z_to_H ! A local unit conversion factor [H Z-1 ~> nondim or kg m-3] + real :: H_to_Z ! A local unit conversion factor [Z H-1 ~> nondim or m3 kg-1] real :: det_de ! The partial derivative due to self-attraction and loading of the reference - ! geopotential with the sea surface height when tides are enabled. + ! geopotential with the sea surface height when scalar SAL are enabled [nondim]. ! This is typically ~0.09 or less. + real :: h_a_neglect ! A cell volume or mass that is so small it is usually lost + ! in roundoff and can be neglected [H L2 ~> m3 or kg] real, allocatable :: lin_drag_h(:,:) ! A spatially varying linear drag coefficient at tracer points - ! that acts on the barotropic flow [Z T-1 ~> m s-1]. + ! that acts on the barotropic flow [H T-1 ~> m s-1 or kg m-2 s-1]. type(memory_size_type) :: MS type(group_pass_type) :: pass_static_data, pass_q_D_Cor type(group_pass_type) :: pass_bt_hbt_btav, pass_a_polarity - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: apply_bt_drag, use_BT_cont_type + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: use_BT_cont_type + logical :: mask_coastal_pressure_force ! If true, apply masks to some stored inverse grid spacings + ! so that diagnosed barotropic pressure gradient forces are zero at + ! land, coastal or OBC points. + logical :: use_tides + logical :: OBC_projection_bug + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. + logical :: visc_rem_bug ! Stores the value of runtime paramter VISC_REM_BUG. character(len=48) :: thickness_units, flux_units character*(40) :: hvel_str integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz @@ -4321,8 +5573,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, CS%module_is_initialized = .true. CS%diag => diag ; CS%Time => Time - if (present(tides_CSp)) then - CS%tides_CSp => tides_CSp + if (present(SAL_CSp)) then + CS%SAL_CSp => SAL_CSp endif ! Read all relevant parameters and write them to the model log. @@ -4368,6 +5620,16 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "This is a decent approximation to the inclusion of "//& "sum(u dh_dt) while also correcting for truncation errors.", & default=.false.) + call get_param(param_file, mdl, "BT_ADJUST_SRC_FOR_FILTER", CS%bt_adjust_src_for_filter, & + "If true, increases the rate at which BT mass sources are applied so "//& + "that they are all used up before the filtering period starts. "//& + "This option is only valid if INTEGRAL_BT_CONTINUITY = True.", & + default=.false., do_not_log=.not.CS%integral_bt_cont) + call get_param(param_file, mdl, "BT_LIMIT_INTEGRAL_TRANSPORT", CS%bt_limit_integral_transport, & + "If true, limit the time-integrated transports by the initial volume "//& + "accounting for sinks of mass. The limiter uses MAXCFL_BT_CONT. "//& + "This option is only valid if INTEGRAL_BT_CONTINUITY = True.", & + default=.false., do_not_log=.not.CS%integral_bt_cont) call get_param(param_file, mdl, "BT_USE_VISC_REM_U_UH0", CS%visc_rem_u_uh0, & "If true, use the viscous remnants when estimating the "//& "barotropic velocities that were used to calculate uh0 "//& @@ -4379,21 +5641,19 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, call get_param(param_file, mdl, "BTHALO", bt_halo_sz, & "The minimum halo size for the barotropic solver.", default=0, & layoutParam=.true.) + call get_param(param_file, mdl, "BT_WIDE_HALO_MIN_STENCIL", CS%min_stencil, & + "The minimum stencil width to use with the wide halo iterations. "//& + "A nonzero value may be useful for debugging purposes, but at the "//& + "cost of reducing the efficiency gain from BT_USE_WIDE_HALOS.", & + default=0, layoutParam=.true., do_not_log=.not.CS%use_wide_halos) #ifdef STATIC_MEMORY_ if ((bt_halo_sz > 0) .and. (bt_halo_sz /= BTHALO_)) call MOM_error(FATAL, & "barotropic_init: Run-time values of BTHALO must agree with the "//& "macro BTHALO_ with STATIC_MEMORY_.") wd_halos(1) = WHALOI_+NIHALO_ ; wd_halos(2) = WHALOJ_+NJHALO_ #else - wd_halos(1) = bt_halo_sz; wd_halos(2) = bt_halo_sz + wd_halos(1) = bt_halo_sz ; wd_halos(2) = bt_halo_sz #endif - call log_param(param_file, mdl, "!BT x-halo", wd_halos(1), & - "The barotropic x-halo size that is actually used.", & - layoutParam=.true.) - call log_param(param_file, mdl, "!BT y-halo", wd_halos(2), & - "The barotropic y-halo size that is actually used.", & - layoutParam=.true.) - call get_param(param_file, mdl, "NONLINEAR_BT_CONTINUITY", CS%Nonlinear_continuity, & "If true, use nonlinear transports in the barotropic "//& "continuity equation. This does not apply if "//& @@ -4402,7 +5662,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "If NONLINEAR_BT_CONTINUITY is true, this is the number "//& "of barotropic time steps between updates to the face "//& "areas, or 0 to update only before the barotropic stepping.", & - units="nondim", default=1, do_not_log=.not.CS%Nonlinear_continuity) + default=1, do_not_log=.not.CS%Nonlinear_continuity) call get_param(param_file, mdl, "BT_PROJECT_VELOCITY", CS%BT_project_velocity,& "If true, step the barotropic velocity first and project "//& @@ -4416,6 +5676,13 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "If true, use the full depth of the ocean at the start of the barotropic "//& "step when calculating the surface stress contribution to the barotropic "//& "acclerations. Otherwise use the depth based on bathyT.", default=.false.) + call get_param(param_file, mdl, "BT_RHO_LINEARIZED", CS%Rho_BT_lin, & + "A density that is used to convert total water column thicknesses into mass "//& + "in non-Boussinesq mode with linearized options in the barotropic solver or "//& + "when estimating the stable barotropic timestep without access to the full "//& + "baroclinic model state.", & + units="kg m-3", default=GV%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=GV%Boussinesq) call get_param(param_file, mdl, "DYNAMIC_SURFACE_PRESSURE", CS%dynamic_psurf, & "If true, add a dynamic pressure due to a viscous ice "//& @@ -4429,7 +5696,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "The minimum depth to use in limiting the size of the "//& "dynamic surface pressure for stability, if "//& "DYNAMIC_SURFACE_PRESSURE is true..", & - units="m", default=1.0e-6, scale=US%m_to_Z, do_not_log=.not.CS%dynamic_psurf) + units="m", default=1.0e-6, scale=GV%m_to_H, do_not_log=.not.CS%dynamic_psurf) call get_param(param_file, mdl, "CONST_DYN_PSURF", CS%const_dyn_psurf, & "The constant that scales the dynamic surface pressure, "//& "if DYNAMIC_SURFACE_PRESSURE is true. Stable values "//& @@ -4438,24 +5705,58 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, call get_param(param_file, mdl, "BT_CORIOLIS_SCALE", CS%BT_Coriolis_scale, & "A factor by which the barotropic Coriolis anomaly terms are scaled.", & units="nondim", default=1.0) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) - call get_param(param_file, mdl, "BAROTROPIC_2018_ANSWERS", CS%answers_2018, & - "If true, use expressions for the barotropic solver that recover the answers "//& - "from the end of 2018. Otherwise, use more efficient or general expressions.", & - default=default_2018_answers) - - call get_param(param_file, mdl, "TIDES", CS%tides, & + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "BAROTROPIC_ANSWER_DATE", CS%answer_date, & + "The vintage of the expressions in the barotropic solver. "//& + "Values below 20190101 recover the answers from the end of 2018, "//& + "while higher values use more efficient or general expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) + + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. + call get_param(param_file, mdl, "VISC_REM_BUG", visc_rem_bug, default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "VISC_REM_BT_WEIGHT_BUG", CS%wt_uv_bug, & + "If true, recover a bug in barotropic solver that uses an unnormalized weight "//& + "function for vertical averages of baroclinic velocity and forcing. Default "//& + "of this flag is set by VISC_REM_BUG.", default=visc_rem_bug) + call get_param(param_file, mdl, "EXTERIOR_OBC_BUG", CS%exterior_OBC_bug, & + "If true, recover a bug in barotropic solver and other routines when "//& + "boundary contitions interior to the domain are used.", & + default=enable_bugs, do_not_log=.true.) + call get_param(param_file, mdl, "OBC_PROJECTION_BUG", OBC_projection_bug, & + "If false, use only interior ocean points at OBCs to specify several "//& + "calculations at OBC points, and it avoids applying a land mask at the bay-like "//& + "intersection of orthogonal OBC segments. Otherwise the calculation of terms "//& + "like the potential vorticity used in the barotropic solver relies on bathymetry "//& + "or other fields being projected outward across OBCs. This option changes "//& + "answers for some configurations that use OBCs.", & + default=enable_bugs, do_not_log=.true.) + CS%interior_OBC_PV = .not.OBC_projection_bug + + call get_param(param_file, mdl, "TIDES", use_tides, & "If true, apply tidal momentum forcing.", default=.false.) + if (use_tides .and. present(HA_CSp)) CS%HA_CSp => HA_CSp + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=use_tides) det_de = 0.0 - if (CS%tides .and. associated(CS%tides_CSp)) & - call tidal_forcing_sensitivity(G, CS%tides_CSp, det_de) + if (CS%calculate_SAL .and. associated(CS%SAL_CSp)) & + call scalar_SAL_sensitivity(CS%SAL_CSp, det_de) call get_param(param_file, mdl, "BAROTROPIC_TIDAL_SAL_BUG", CS%tidal_sal_bug, & "If true, the tidal self-attraction and loading anomaly in the barotropic "//& "solver has the wrong sign, replicating a long-standing bug with a scalar "//& "self-attraction and loading term or the SAL term from a previous simulation.", & - default=.true., do_not_log=(det_de==0.0)) + default=.false., do_not_log=(det_de==0.0)) + call get_param(param_file, mdl, "TIDAL_SAL_FLATHER", CS%tidal_sal_flather, & + "If true, then apply adjustments to the external gravity "//& + "wave speed used with the Flather OBC routine consistent "//& + "with the barotropic solver. This applies to cases with "//& + "tidal forcing using the scalar self-attraction approximation. "//& + "The default is currently False in order to retain previous answers "//& + "but should be set to True for new experiments", default=.false.) + call get_param(param_file, mdl, "SADOURNY", CS%Sadourny, & "If true, the Coriolis terms are discretized with the "//& "Sadourny (1975) energy conserving scheme, otherwise "//& @@ -4496,18 +5797,37 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "with the barotropic time-step instead of implicit with "//& "the baroclinic time-step and dividing by the number of "//& "barotropic steps.", default=.false.) + call get_param(param_file, mdl, "RESCALE_STRONG_DRAG", CS%rescale_strong_drag, & + "If true, reduce the barotropic contribution to the layer accelerations "//& + "to account for the difference between the forces that can be counteracted "//& + "by the stronger drag with BT_STRONG_DRAG and the average of the layer "//& + "viscous remnants after a baroclinic timestep.", & + default=.false., do_not_log=.not.CS%strong_drag) call get_param(param_file, mdl, "BT_LINEAR_WAVE_DRAG", CS%linear_wave_drag, & "If true, apply a linear drag to the barotropic velocities, "//& "using rates set by lin_drag_u & _v divided by the depth of "//& "the ocean. This was introduced to facilitate tide modeling.", & default=.false.) + call get_param(param_file, mdl, "BT_LINEAR_FREQ_DRAG", CS%linear_freq_drag, & + "If true, apply frequency-dependent drag to the tidal velocities. "//& + "The streaming band-pass filter must be turned on.", default=.false.) call get_param(param_file, mdl, "BT_WAVE_DRAG_FILE", wave_drag_file, & "The name of the file with the barotropic linear wave drag "//& - "piston velocities.", default="", do_not_log=.not.CS%linear_wave_drag) + "piston velocities.", default="", & + do_not_log=(.not.CS%linear_wave_drag) .and. (.not.CS%linear_freq_drag)) call get_param(param_file, mdl, "BT_WAVE_DRAG_VAR", wave_drag_var, & "The name of the variable in BT_WAVE_DRAG_FILE with the "//& - "barotropic linear wave drag piston velocities at h points.", & + "barotropic linear wave drag piston velocities at h points. "//& + "It will not be used if both BT_WAVE_DRAG_U and BT_WAVE_DRAG_V are defined.", & default="rH", do_not_log=.not.CS%linear_wave_drag) + call get_param(param_file, mdl, "BT_WAVE_DRAG_U", wave_drag_u, & + "The name of the variable in BT_WAVE_DRAG_FILE with the "//& + "barotropic linear wave drag piston velocities at u points.", & + default="", do_not_log=.not.CS%linear_wave_drag) + call get_param(param_file, mdl, "BT_WAVE_DRAG_V", wave_drag_v, & + "The name of the variable in BT_WAVE_DRAG_FILE with the "//& + "barotropic linear wave drag piston velocities at v points.", & + default="", do_not_log=.not.CS%linear_wave_drag) call get_param(param_file, mdl, "BT_WAVE_DRAG_SCALE", wave_drag_scale, & "A scaling factor for the barotropic linear wave drag "//& "piston velocities.", default=1.0, units="nondim", & @@ -4560,6 +5880,12 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "barotropic time-stepping loop. The data volume can be "//& "quite large if this is true.", default=CS%debug, & debuggingParam=.true.) + call get_param(param_file, mdl, "DEBUG_BT_WIDE_HALOS", CS%debug_wide_halos, & + "If true, write the checksums on the full wide halos. Otherwise only the "//& + "output for the final computational domain is written. This can be valuable "//& + "for debugging certain cases where the stencil used in the wide halo "//& + "iterations depends on which opoen boundary conditions are in the halos.", & + default=.true., do_not_log=.not.(CS%debug_bt.and.CS%use_wide_halos), debuggingParam=.true.) call get_param(param_file, mdl, "LINEARIZED_BT_CORIOLIS", CS%linearized_BT_PV, & "If true use the bottom depth instead of the total water column thickness "//& @@ -4572,6 +5898,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "gravity waves) to 1 (for a backward Euler treatment). "//& "In practice, BEBT must be greater than about 0.05.", & units="nondim", default=0.1) + ! Note that dtbt_input is not rescaled because it has different units for + ! positive [s] and negative [nondim] values. call get_param(param_file, mdl, "DTBT", dtbt_input, & "The barotropic time step, in s. DTBT is only used with "//& "the split explicit time stepping. To set the time step "//& @@ -4579,13 +5907,18 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "a negative value gives the fraction of the stable value. "//& "Setting DTBT to 0 is the same as setting it to -0.98. "//& "The value of DTBT that will actually be used is an "//& - "integer fraction of DT, rounding down.", units="s or nondim",& - default = -0.98) - call get_param(param_file, mdl, "BT_USE_OLD_CORIOLIS_BRACKET_BUG", & - CS%use_old_coriolis_bracket_bug , & + "integer fraction of DT, rounding down.", & + units="s or nondim", default=-0.98) + call get_param(param_file, mdl, "BT_USE_OLD_CORIOLIS_BRACKET_BUG", CS%use_old_coriolis_bracket_bug, & "If True, use an order of operations that is not bitwise "//& "rotationally symmetric in the meridional Coriolis term of "//& "the barotropic solver.", default=.false.) + call get_param(param_file, mdl, "MASK_COASTAL_PRESSURE_FORCE", mask_coastal_pressure_force, & + "If true, use the land masks to zero out the diagnosed barotropic pressure "//& + "gradient accelerations at coastal or land points. This changes diagnostics "//& + "and improves the reproducibility of certain debugging checksums, but it "//& + "does not alter the solutions themselves.", default=.false.) + !### Change the default for MASK_COASTAL_PRESSURE_FORCE to true? ! Initialize a version of the MOM domain that is specific to the barotropic solver. call clone_MOM_domain(G%Domain, CS%BT_Domain, min_halo=wd_halos, symmetric=.true.) @@ -4602,6 +5935,12 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, call MOM_mesg("barotropic_init: barotropic y-halo size increased.", 3) endif #endif + call log_param(param_file, mdl, "!BT x-halo", wd_halos(1), & + "The barotropic x-halo size that is actually used.", & + layoutParam=.true.) + call log_param(param_file, mdl, "!BT y-halo", wd_halos(2), & + "The barotropic y-halo size that is actually used.", & + layoutParam=.true.) CS%isdw = G%isc-wd_halos(1) ; CS%iedw = G%iec+wd_halos(1) CS%jsdw = G%jsc-wd_halos(2) ; CS%jedw = G%jec+wd_halos(2) @@ -4609,9 +5948,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, ALLOC_(CS%frhatu(IsdB:IedB,jsd:jed,nz)) ; ALLOC_(CS%frhatv(isd:ied,JsdB:JedB,nz)) ALLOC_(CS%eta_cor(isd:ied,jsd:jed)) - if (CS%bound_BT_corr) then - ALLOC_(CS%eta_cor_bound(isd:ied,jsd:jed)) ; CS%eta_cor_bound(:,:) = 0.0 - endif + if (CS%bound_BT_corr) & + allocate(CS%eta_cor_bound(isd:ied,jsd:jed), source=0.0) ALLOC_(CS%IDatu(IsdB:IedB,jsd:jed)) ; ALLOC_(CS%IDatv(isd:ied,JsdB:JedB)) ALLOC_(CS%ua_polarity(isdw:iedw,jsdw:jedw)) @@ -4630,22 +5968,22 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, if (CS%debug) then ! Make a local copy of loop ranges for chksum calls allocate(CS%debug_BT_HI) - CS%debug_BT_HI%isc=G%isc - CS%debug_BT_HI%iec=G%iec - CS%debug_BT_HI%jsc=G%jsc - CS%debug_BT_HI%jec=G%jec - CS%debug_BT_HI%IscB=G%isc-1 - CS%debug_BT_HI%IecB=G%iec - CS%debug_BT_HI%JscB=G%jsc-1 - CS%debug_BT_HI%JecB=G%jec - CS%debug_BT_HI%isd=CS%isdw - CS%debug_BT_HI%ied=CS%iedw - CS%debug_BT_HI%jsd=CS%jsdw - CS%debug_BT_HI%jed=CS%jedw - CS%debug_BT_HI%IsdB=CS%isdw-1 - CS%debug_BT_HI%IedB=CS%iedw - CS%debug_BT_HI%JsdB=CS%jsdw-1 - CS%debug_BT_HI%JedB=CS%jedw + CS%debug_BT_HI%isc = G%isc + CS%debug_BT_HI%iec = G%iec + CS%debug_BT_HI%jsc = G%jsc + CS%debug_BT_HI%jec = G%jec + CS%debug_BT_HI%IscB = G%isc-1 + CS%debug_BT_HI%IecB = G%iec + CS%debug_BT_HI%JscB = G%jsc-1 + CS%debug_BT_HI%JecB = G%jec + CS%debug_BT_HI%isd = CS%isdw + CS%debug_BT_HI%ied = CS%iedw + CS%debug_BT_HI%jsd = CS%jsdw + CS%debug_BT_HI%jed = CS%jedw + CS%debug_BT_HI%IsdB = CS%isdw-1 + CS%debug_BT_HI%IedB = CS%iedw + CS%debug_BT_HI%JsdB = CS%jsdw-1 + CS%debug_BT_HI%JedB = CS%jedw CS%debug_BT_HI%turns = G%HI%turns endif @@ -4656,50 +5994,179 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, ALLOC_(CS%IdyCv(CS%isdw:CS%iedw,CS%jsdw-1:CS%jedw)) ; CS%IdyCv(:,:) = 0.0 ALLOC_(CS%dy_Cu(CS%isdw-1:CS%iedw,CS%jsdw:CS%jedw)) ; CS%dy_Cu(:,:) = 0.0 ALLOC_(CS%dx_Cv(CS%isdw:CS%iedw,CS%jsdw-1:CS%jedw)) ; CS%dx_Cv(:,:) = 0.0 + allocate(CS%IareaT_OBCmask(isdw:iedw,jsdw:jedw), source=0.0) + ALLOC_(CS%OBCmask_u(CS%isdw-1:CS%iedw,CS%jsdw:CS%jedw)) ; CS%OBCmask_u(:,:) = 0.0 + ALLOC_(CS%OBCmask_v(CS%isdw:CS%iedw,CS%jsdw-1:CS%jedw)) ; CS%OBCmask_v(:,:) = 0.0 do j=G%jsd,G%jed ; do i=G%isd,G%ied CS%IareaT(i,j) = G%IareaT(i,j) CS%bathyT(i,j) = G%bathyT(i,j) + CS%IareaT_OBCmask(i,j) = CS%IareaT(i,j) enddo ; enddo ! Note: G%IdxCu & G%IdyCv may be valid for a smaller extent than CS%IdxCu & CS%IdyCv, even without ! wide halos. do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB CS%IdxCu(I,j) = G%IdxCu(I,j) ; CS%dy_Cu(I,j) = G%dy_Cu(I,j) + CS%OBCmask_u(I,j) = G%OBCmaskCu(I,j) enddo ; enddo do J=G%JsdB,G%JedB ; do i=G%isd,G%ied CS%IdyCv(i,J) = G%IdyCv(i,J) ; CS%dx_Cv(i,J) = G%dx_Cv(i,J) + CS%OBCmask_v(i,J) = G%OBCmaskCv(i,J) enddo ; enddo + + ! This sets pressure force diagnostics on land, at coastlines and at OBC points to zero. + if (mask_coastal_pressure_force) then + do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB + CS%IdxCu(I,j) = G%IdxCu_OBCmask(I,j) + enddo ; enddo + do J=G%JsdB,G%JedB ; do i=G%isd,G%ied + CS%IdyCv(i,J) = G%IdyCv_OBCmask(i,J) + enddo ; enddo + endif + + if (associated(OBC)) then + ! Set up information about the location and nature of the open boundary condition points. + call initialize_BT_OBC(OBC, CS%BT_OBC, G, CS) + + ! Update IareaT_OBCmask so that nothing changes outside of the OBC (problem for interior OBCs only) + if (.not.CS%exterior_OBC_bug) then + if (CS%BT_OBC%u_OBCs_on_PE) then + do j=jsd,jed ; do i=isd,ied + if (CS%BT_OBC%u_OBC_type(I-1,j) > 0) CS%IareaT_OBCmask(i,j) = 0.0 ! OBC_DIRECTION_E + if (CS%BT_OBC%u_OBC_type(I,j) < 0) CS%IareaT_OBCmask(i,j) = 0.0 ! OBC_DIRECTION_W + enddo ; enddo + endif + if (CS%BT_OBC%v_OBCs_on_PE) then + do j=jsd,jed ; do i=isd,ied + if (CS%BT_OBC%v_OBC_type(i,J-1) > 0) CS%IareaT_OBCmask(i,j) = 0.0 ! OBC_DIRECTION_N + if (CS%BT_OBC%v_OBC_type(i,J) < 0) CS%IareaT_OBCmask(i,j) = 0.0 ! OBC_DIRECTION_S + enddo ; enddo + endif + endif + + ! Set masks to avoid changing velocities at OBC points. + if (CS%BT_OBC%u_OBCs_on_PE) then + do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB ; if (CS%BT_OBC%u_OBC_type(I,j) /= 0) then + CS%OBCmask_u(I,j) = 0.0 ; CS%IdxCu(I,j) = 0.0 + endif ; enddo ; enddo + endif + if (CS%BT_OBC%v_OBCs_on_PE) then + do J=G%JsdB,G%JedB ; do i=G%isd,G%ied ; if (CS%BT_OBC%v_OBC_type(i,J) /= 0) then + CS%OBCmask_v(i,J) = 0.0 ; CS%IdyCv(i,J) = 0.0 + endif ; enddo ; enddo + endif + + CS%integral_OBCs = CS%integral_BT_cont .and. open_boundary_query(OBC, apply_open_OBC=.true.) + else ! There are no OBC points anywhere. + CS%BT_OBC%u_OBCs_on_PE = .false. + CS%BT_OBC%v_OBCs_on_PE = .false. + CS%integral_OBCs = .false. + endif + call create_group_pass(pass_static_data, CS%IareaT, CS%BT_domain, To_All) call create_group_pass(pass_static_data, CS%bathyT, CS%BT_domain, To_All) + call create_group_pass(pass_static_data, CS%IareaT_OBCmask, CS%BT_domain, To_All) call create_group_pass(pass_static_data, CS%IdxCu, CS%IdyCv, CS%BT_domain, To_All+Scalar_Pair) call create_group_pass(pass_static_data, CS%dy_Cu, CS%dx_Cv, CS%BT_domain, To_All+Scalar_Pair) + call create_group_pass(pass_static_data, CS%OBCmask_u, CS%OBCmask_v, CS%BT_domain, To_All+Scalar_Pair) call do_group_pass(pass_static_data, CS%BT_domain) + ! Determine the weights to use for the thicknesses when calculating PV for use in the Coriolis terms + allocate(CS%q_wt(4,CS%isdw-1:CS%iedw,CS%jsdw-1:CS%jedw), source=0.0) + do J=js-1,je ; do I=is-1,ie + if (G%mask2dT(i,j) + G%mask2dT(i,j+1) + G%mask2dT(i+1,j) + G%mask2dT(i+1,j+1) > 0.) then + CS%q_wt(1,I,J) = G%areaT(i,j) ; CS%q_wt(2,I,J) = G%areaT(i+1,j) + CS%q_wt(3,I,J) = G%areaT(i,j+1) ; CS%q_wt(4,I,J) = G%areaT(i+1,j+1) + else + CS%q_wt(1:4,I,J) = 0.0 + endif + enddo ; enddo + + if (CS%interior_OBC_PV .and. (CS%BT_OBC%u_OBCs_on_PE .or. CS%BT_OBC%v_OBCs_on_PE)) then + ! Reset the potential vorticity at OBC vertices as a masked weighted average. + do J=js-1,je ; do I=is-1,ie + if ((G%mask2dT(i,j) + G%mask2dT(i,j+1) + G%mask2dT(i+1,j) + G%mask2dT(i+1,j+1) > 0.) .and. & + ((abs(CS%BT_OBC%u_OBC_type(I,j)) > 0) .or. (abs(CS%BT_OBC%u_OBC_type(I,j+1)) > 0) .or. & + (abs(CS%BT_OBC%v_OBC_type(i,J)) > 0) .or. (abs(CS%BT_OBC%v_OBC_type(i+1,J)) > 0)) ) then + ! This is an OBC vertex, so use an area weighted masked average and avoid external values. + CS%q_wt(1,I,J) = G%mask2dT(i,j) * G%areaT(i,j) + CS%q_wt(2,I,J) = G%mask2dT(i+1,j) * G%areaT(i+1,j) + CS%q_wt(3,I,J) = G%mask2dT(i,j+1) * G%areaT(i,j+1) + CS%q_wt(4,I,J) = G%mask2dT(i+1,j+1) * G%areaT(i+1,j+1) + + ! The following block is the equivalent of shifting weights inward across OBC points. With + ! two OBCs in a line, it gives weights of about 1/2 and 1/2 to the interior points. At a + ! peninsula-like corner between two OBCs it gives weights of about 3/8, 1/4 and 3/8 for the + ! 3 interior points. At a bay-liek corner there is only one interior point with a weight of 1. + ! The masking above zeros out the weights for exterior points. + if (CS%BT_OBC%u_OBC_type(I,j) > 0) then ! Eastern OBC in the u-point to the south + CS%q_wt(1,I,J) = CS%q_wt(1,I,J) + 0.5*G%mask2dT(i,j)*G%areaT(i,j) ! already CS%q_wt(2,I,J) = 0.0 + elseif (CS%BT_OBC%u_OBC_type(I,j) < 0) then ! Western OBC in the u-point to the south + CS%q_wt(2,I,J) = CS%q_wt(2,I,J) + 0.5*G%mask2dT(i+1,j)*G%areaT(i+1,j) ! already CS%q_wt(1,I,J) = 0.0 + endif + if (CS%BT_OBC%u_OBC_type(I,j+1) > 0) then ! Eastern OBC in the u-point to the north + CS%q_wt(3,I,J) = CS%q_wt(3,I,J) + 0.5*G%mask2dT(i,j+1)*G%areaT(i,j+1) ! already CS%q_wt(4,I,J) = 0.0 + elseif (CS%BT_OBC%u_OBC_type(I,j+1) < 0) then ! Western OBC in the u-point to the north + CS%q_wt(4,I,J) = CS%q_wt(4,I,J) + 0.5*G%mask2dT(i+1,j+1)*G%areaT(i+1,j+1) ! already CS%q_wt(3,I,J) = 0.0 + endif + if (CS%BT_OBC%v_OBC_type(i,J) > 0) then ! Northern OBC in the v-point to the west + CS%q_wt(1,I,J) = CS%q_wt(1,I,J) + 0.5*G%mask2dT(i,j)*G%areaT(i,j) ! already CS%q_wt(3,I,J) = 0.0 + elseif (CS%BT_OBC%v_OBC_type(i,J) < 0) then ! Southern OBC in the v-point to the west + CS%q_wt(3,I,J) = CS%q_wt(3,I,J) + 0.5*G%mask2dT(i,j+1)*G%areaT(i,j+1) ! already CS%q_wt(1,I,J) = 0.0 + endif + if (CS%BT_OBC%v_OBC_type(i+1,J) > 0) then ! Northern OBC in the v-point to the west + CS%q_wt(2,I,J) = CS%q_wt(2,I,J) + 0.5*G%mask2dT(i+1,j)*G%areaT(i+1,j) ! already CS%q_wt(4,I,J) = 0.0 + elseif (CS%BT_OBC%v_OBC_type(i+1,J) < 0) then ! Southern OBC in the v-point to the west + CS%q_wt(4,I,J) = CS%q_wt(4,I,J) + 0.5*G%mask2dT(i+1,j+1)*G%areaT(i+1,j+1) ! already CS%q_wt(2,I,J) = 0.0 + endif + endif + enddo ; enddo + endif + if (CS%linearized_BT_PV) then - ALLOC_(CS%q_D(CS%isdw-1:CS%iedw,CS%jsdw-1:CS%jedw)) - ALLOC_(CS%D_u_Cor(CS%isdw-1:CS%iedw,CS%jsdw:CS%jedw)) - ALLOC_(CS%D_v_Cor(CS%isdw:CS%iedw,CS%jsdw-1:CS%jedw)) - CS%q_D(:,:) = 0.0 ; CS%D_u_Cor(:,:) = 0.0 ; CS%D_v_Cor(:,:) = 0.0 + allocate(CS%q_D(CS%isdw-1:CS%iedw,CS%jsdw-1:CS%jedw), source=0.0) + allocate(CS%D_u_Cor(CS%isdw-1:CS%iedw,CS%jsdw:CS%jedw), source=0.0) + allocate(CS%D_v_Cor(CS%isdw:CS%iedw,CS%jsdw-1:CS%jedw), source=0.0) + + Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin - Mean_SL = G%Z_ref do j=js,je ; do I=is-1,ie - CS%D_u_Cor(I,j) = 0.5 * (max(Mean_SL+G%bathyT(i+1,j),0.0) + max(Mean_SL+G%bathyT(i,j),0.0)) + CS%D_u_Cor(I,j) = 0.5 * ( max(G%meanSL(i+1,j) + G%bathyT(i+1,j), 0.0) & + + max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) ) * Z_to_H enddo ; enddo + if (CS%interior_OBC_PV .and. CS%BT_OBC%u_OBCs_on_PE) then ; do j=js,je ; do I=is-1,ie + if (CS%BT_OBC%u_OBC_type(I,j) < 0) & ! Western boundary condition + CS%D_u_Cor(I,j) = max(G%meanSL(i+1,j) + G%bathyT(i+1,j), 0.0) * Z_to_H + if (CS%BT_OBC%u_OBC_type(I,j) > 0) & ! Eastern boundary condition + CS%D_u_Cor(I,j) = max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) * Z_to_H + enddo ; enddo ; endif + do J=js-1,je ; do i=is,ie - CS%D_v_Cor(i,J) = 0.5 * (max(Mean_SL+G%bathyT(i,j+1),0.0) + max(Mean_SL+G%bathyT(i,j),0.0)) + CS%D_v_Cor(i,J) = 0.5 * ( max(G%meanSL(i,j+1) + G%bathyT(i,j+1), 0.0) & + + max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) ) * Z_to_H enddo ; enddo + if (CS%interior_OBC_PV .and. CS%BT_OBC%v_OBCs_on_PE) then ; do J=js-1,je ; do i=is,ie + if (CS%BT_OBC%v_OBC_type(i,J) < 0) & ! Southern boundary condition + CS%D_v_Cor(i,J) = max(G%meanSL(i,j+1) + G%bathyT(i,j+1), 0.0) * Z_to_H + if (CS%BT_OBC%v_OBC_type(i,J) > 0) & ! Northern boundary condition + CS%D_v_Cor(i,J) = max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) * Z_to_H + enddo ; enddo ; endif + + h_a_neglect = GV%H_subroundoff * 1.0 * US%m_to_L**2 do J=js-1,je ; do I=is-1,ie - if (G%mask2dT(i,j)+G%mask2dT(i,j+1)+G%mask2dT(i+1,j)+G%mask2dT(i+1,j+1)>0.) then + if ((CS%q_wt(1,I,J) + CS%q_wt(4,I,J)) + (CS%q_wt(2,I,J) + CS%q_wt(3,I,J)) > 0.) then CS%q_D(I,J) = 0.25 * (CS%BT_Coriolis_scale * G%CoriolisBu(I,J)) * & - ((G%areaT(i,j) + G%areaT(i+1,j+1)) + (G%areaT(i+1,j) + G%areaT(i,j+1))) / & - (max(((G%areaT(i,j) * max(Mean_SL+G%bathyT(i,j),0.0) + & - G%areaT(i+1,j+1) * max(Mean_SL+G%bathyT(i+1,j+1),0.0)) + & - (G%areaT(i+1,j) * max(Mean_SL+G%bathyT(i+1,j),0.0) + & - G%areaT(i,j+1) * max(Mean_SL+G%bathyT(i,j+1),0.0))), GV%H_to_Z*GV%H_subroundoff) ) - else ! All four h points are masked out so q_D(I,J) will is meaningless + ((CS%q_wt(1,I,J) + CS%q_wt(4,I,J)) + (CS%q_wt(2,I,J) + CS%q_wt(3,I,J))) / & + max(Z_to_H * (((CS%q_wt(1,I,J) * max(G%meanSL(i,j) + G%bathyT(i,j), 0.0)) + & + (CS%q_wt(4,I,J) * max(G%meanSL(i+1,j+1) + G%bathyT(i+1,j+1), 0.0))) + & + ((CS%q_wt(2,I,J) * max(G%meanSL(i+1,j) + G%bathyT(i+1,j), 0.0)) + & + (CS%q_wt(3,I,J) * max(G%meanSL(i,j+1) + G%bathyT(i,j+1), 0.0)))), & + h_a_neglect) + else ! All four h points are masked out so q_D(I,J) is meaningless CS%q_D(I,J) = 0. endif enddo ; enddo + ! With very wide halos, q and D need to be calculated on the available data ! domain and then updated onto the full computational domain. call create_group_pass(pass_q_D_Cor, CS%q_D, CS%BT_Domain, To_All, position=CORNER) @@ -4709,53 +6176,80 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, endif if (CS%linear_wave_drag) then - ALLOC_(CS%lin_drag_u(IsdB:IedB,jsd:jed)) ; CS%lin_drag_u(:,:) = 0.0 - ALLOC_(CS%lin_drag_v(isd:ied,JsdB:JedB)) ; CS%lin_drag_v(:,:) = 0.0 + allocate(CS%lin_drag_u(IsdB:IedB,jsd:jed), source=0.0) + allocate(CS%lin_drag_v(isd:ied,JsdB:JedB), source=0.0) if (len_trim(wave_drag_file) > 0) then inputdir = "." ; call get_param(param_file, mdl, "INPUTDIR", inputdir) wave_drag_file = trim(slasher(inputdir))//trim(wave_drag_file) call log_param(param_file, mdl, "INPUTDIR/BT_WAVE_DRAG_FILE", wave_drag_file) - allocate(lin_drag_h(isd:ied,jsd:jed), source=0.0) + if (len_trim(wave_drag_u) > 0 .and. len_trim(wave_drag_v) > 0) then + call MOM_read_data(wave_drag_file, wave_drag_u, CS%lin_drag_u, G%Domain, & + position=EAST_FACE, scale=wave_drag_scale*GV%m_to_H*US%T_to_s) + call MOM_read_data(wave_drag_file, wave_drag_v, CS%lin_drag_v, G%Domain, & + position=NORTH_FACE, scale=wave_drag_scale*GV%m_to_H*US%T_to_s) + call pass_vector(CS%lin_drag_u, CS%lin_drag_v, G%domain, direction=To_All+SCALAR_PAIR) + else + allocate(lin_drag_h(isd:ied,jsd:jed), source=0.0) - call MOM_read_data(wave_drag_file, wave_drag_var, lin_drag_h, G%Domain, scale=US%m_to_Z*US%T_to_s) - call pass_var(lin_drag_h, G%Domain) - do j=js,je ; do I=is-1,ie - CS%lin_drag_u(I,j) = (GV%Z_to_H * wave_drag_scale) * & - 0.5 * (lin_drag_h(i,j) + lin_drag_h(i+1,j)) - enddo ; enddo - do J=js-1,je ; do i=is,ie - CS%lin_drag_v(i,J) = (GV%Z_to_H * wave_drag_scale) * & - 0.5 * (lin_drag_h(i,j) + lin_drag_h(i,j+1)) - enddo ; enddo - deallocate(lin_drag_h) + call MOM_read_data(wave_drag_file, wave_drag_var, lin_drag_h, G%Domain, scale=GV%m_to_H*US%T_to_s) + call pass_var(lin_drag_h, G%Domain) + do j=js,je ; do I=is-1,ie + CS%lin_drag_u(I,j) = wave_drag_scale * 0.5 * (lin_drag_h(i,j) + lin_drag_h(i+1,j)) + enddo ; enddo + do J=js-1,je ; do i=is,ie + CS%lin_drag_v(i,J) = wave_drag_scale * 0.5 * (lin_drag_h(i,j) + lin_drag_h(i,j+1)) + enddo ; enddo + deallocate(lin_drag_h) + endif ! len_trim(wave_drag_u) > 0 .and. len_trim(wave_drag_v) > 0 + endif ! len_trim(wave_drag_file) > 0 + endif ! CS%linear_wave_drag + + ! Initialize streaming band-pass filters and frequency-dependent drag + if (CS%use_filter) then + call Filt_init(param_file, US, CS%Filt_CS_u, restart_CS) + call Filt_init(param_file, US, CS%Filt_CS_v, restart_CS) + endif + + if (CS%use_filter .and. CS%linear_freq_drag) then + if (.not.CS%linear_wave_drag .and. len_trim(wave_drag_file) > 0) then + inputdir = "." ; call get_param(param_file, mdl, "INPUTDIR", inputdir) + wave_drag_file = trim(slasher(inputdir))//trim(wave_drag_file) + call log_param(param_file, mdl, "INPUTDIR/BT_WAVE_DRAG_FILE", wave_drag_file) endif + call wave_drag_init(param_file, wave_drag_file, G, GV, US, CS%Drag_CS) endif CS%dtbt_fraction = 0.98 ; if (dtbt_input < 0.0) CS%dtbt_fraction = -dtbt_input - dtbt_tmp = -1.0 + dtbt_restart = -1.0 if (query_initialized(CS%dtbt, "DTBT", restart_CS)) then - dtbt_tmp = CS%dtbt - if ((US%s_to_T_restart /= 0.0) .and. (US%s_to_T_restart /= US%s_to_T)) & - dtbt_tmp = (US%s_to_T / US%s_to_T_restart) * CS%dtbt + dtbt_restart = CS%dtbt endif ! Estimate the maximum stable barotropic time step. gtot_estimate = 0.0 - do k=1,GV%ke ; gtot_estimate = gtot_estimate + GV%g_prime(K) ; enddo + if (GV%Boussinesq) then + do k=1,GV%ke ; gtot_estimate = gtot_estimate + GV%H_to_Z*GV%g_prime(K) ; enddo + else + H_to_Z = GV%H_to_RZ / CS%Rho_BT_lin + do k=1,GV%ke ; gtot_estimate = gtot_estimate + H_to_Z*GV%g_prime(K) ; enddo + endif + + ! CS%dtbt calculated here by set_dtbt is only used when dtbt is not reset during the run, i.e. DTBT_RESET_PERIOD<0. call set_dtbt(G, GV, US, CS, gtot_est=gtot_estimate, SSH_add=SSH_extra) if (dtbt_input > 0.0) then CS%dtbt = US%s_to_T * dtbt_input - elseif (dtbt_tmp > 0.0) then - CS%dtbt = dtbt_tmp + elseif (dtbt_restart > 0.0) then + CS%dtbt = dtbt_restart endif - if ((dtbt_tmp > 0.0) .and. (dtbt_input > 0.0)) calc_dtbt = .false. - call log_param(param_file, mdl, "DTBT as used", CS%dtbt*US%T_to_s) - call log_param(param_file, mdl, "estimated maximum DTBT", CS%dtbt_max*US%T_to_s) + calc_dtbt = .true. ; if ((dtbt_restart > 0.0) .and. (dtbt_input > 0.0)) calc_dtbt = .false. + + call log_param(param_file, mdl, "DTBT as used", CS%dtbt, units="s", unscale=US%T_to_s) + call log_param(param_file, mdl, "estimated maximum DTBT", CS%dtbt_max, units="s", unscale=US%T_to_s) ! ubtav and vbtav, and perhaps ubt_IC and vbt_IC, are allocated and ! initialized in register_barotropic_restarts. @@ -4767,9 +6261,18 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, endif CS%id_PFu_bt = register_diag_field('ocean_model', 'PFuBT', diag%axesCu1, Time, & - 'Zonal Anomalous Barotropic Pressure Force Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + 'Zonal Anomalous Barotropic Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_PFv_bt = register_diag_field('ocean_model', 'PFvBT', diag%axesCv1, Time, & 'Meridional Anomalous Barotropic Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_etaPF_anom = register_diag_field('ocean_model', 'etaPF_anom', diag%axesT1, Time, & + 'Eta anomalies used for pressure forces averaged over a baroclinic timestep', & + thickness_units, conversion=GV%H_to_MKS) + if (CS%linear_wave_drag .or. (CS%use_filter .and. CS%linear_freq_drag)) then + CS%id_LDu_bt = register_diag_field('ocean_model', 'WaveDraguBT', diag%axesCu1, Time, & + 'Zonal Barotropic Linear Wave Drag Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_LDv_bt = register_diag_field('ocean_model', 'WaveDragvBT', diag%axesCv1, Time, & + 'Meridional Barotropic Linear Wave Drag Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + endif CS%id_Coru_bt = register_diag_field('ocean_model', 'CoruBT', diag%axesCu1, Time, & 'Zonal Barotropic Coriolis Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_Corv_bt = register_diag_field('ocean_model', 'CorvBT', diag%axesCv1, Time, & @@ -4804,11 +6307,15 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, CS%id_vbtav = register_diag_field('ocean_model', 'vbtav', diag%axesCv1, Time, & 'Barotropic time-average meridional velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_eta_cor = register_diag_field('ocean_model', 'eta_cor', diag%axesT1, Time, & - 'Corrective mass flux within a timestep', 'm', conversion=GV%H_to_m) + 'Corrective mass or volume flux within a timestep', thickness_units, conversion=GV%H_to_MKS) CS%id_visc_rem_u = register_diag_field('ocean_model', 'visc_rem_u', diag%axesCuL, Time, & 'Viscous remnant at u', 'nondim') CS%id_visc_rem_v = register_diag_field('ocean_model', 'visc_rem_v', diag%axesCvL, Time, & 'Viscous remnant at v', 'nondim') + CS%id_bt_rem_u = register_diag_field('ocean_model', 'bt_rem_u', diag%axesCu1, Time, & + 'Barotropic viscous remnant per barotropic step at u', 'nondim') + CS%id_bt_rem_v = register_diag_field('ocean_model', 'bt_rem_v', diag%axesCv1, Time, & + 'Barotropic viscous remnant per barotropic step at v', 'nondim') CS%id_gtotn = register_diag_field('ocean_model', 'gtot_n', diag%axesT1, Time, & 'gtot to North', 'm s-2', conversion=GV%m_to_H*(US%L_T_to_m_s**2)) CS%id_gtots = register_diag_field('ocean_model', 'gtot_s', diag%axesT1, Time, & @@ -4823,8 +6330,11 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, 'High Frequency Barotropic zonal velocity', 'm s-1', conversion=US%L_T_to_m_s) CS%id_vbt_hifreq = register_diag_field('ocean_model', 'vbt_hifreq', diag%axesCv1, Time, & 'High Frequency Barotropic meridional velocity', 'm s-1', conversion=US%L_T_to_m_s) + ! if (.not.CS%BT_project_velocity) & ! The following diagnostic is redundant with BT_project_velocity. CS%id_eta_pred_hifreq = register_diag_field('ocean_model', 'eta_pred_hifreq', diag%axesT1, Time, & 'High Frequency Predictor Barotropic SSH', thickness_units, conversion=GV%H_to_MKS) + CS%id_etaPF_hifreq = register_diag_field('ocean_model', 'etaPF_hifreq', diag%axesT1, Time, & + 'High Frequency Barotropic SSH anomalies used for pressure forces', thickness_units, conversion=GV%H_to_MKS) CS%id_uhbt_hifreq = register_diag_field('ocean_model', 'uhbt_hifreq', diag%axesCu1, Time, & 'High Frequency Barotropic zonal transport', & 'm3 s-1', conversion=GV%H_to_m*US%L_to_m*US%L_T_to_m_s) @@ -4884,6 +6394,18 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, 'Barotropic zonal transport difference', 'm3 s-1', conversion=GV%H_to_m*US%L_to_m**2*US%s_to_T) CS%id_vhbt0 = register_diag_field('ocean_model', 'vhbt0', diag%axesCv1, Time, & 'Barotropic meridional transport difference', 'm3 s-1', conversion=GV%H_to_m*US%L_to_m**2*US%s_to_T) + if (associated(OBC)) then + if (OBC%Flather_u_BCs_exist_globally .or. OBC%Flather_v_BCs_exist_globally) then + CS%id_SSH_u_OBC = register_diag_field('ocean_model', 'SSH_u_OBC', diag%axesCu1, Time, & + 'Outer sea surface height at u OBC points', 'm', conversion=US%Z_to_m) + CS%id_SSH_v_OBC = register_diag_field('ocean_model', 'SSH_v_OBC', diag%axesCv1, Time, & + 'Outer sea surface height at v OBC points', 'm', conversion=US%Z_to_m) + CS%id_ubt_OBC = register_diag_field('ocean_model', 'ubt_OBC', diag%axesCu1, Time, & + 'Outer u velocity at OBC points', 'm', conversion=US%L_T_to_m_s) + CS%id_vbt_OBC = register_diag_field('ocean_model', 'vbt_OBC', diag%axesCv1, Time, & + 'Outer v velocity at OBC points', 'm', conversion=US%L_T_to_m_s) + endif + endif if (CS%id_frhatu1 > 0) allocate(CS%frhatu1(IsdB:IedB,jsd:jed,nz), source=0.) if (CS%id_frhatv1 > 0) allocate(CS%frhatv1(isd:ied,JsdB:JedB,nz), source=0.) @@ -4898,11 +6420,6 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, do k=1,nz ; do J=js-1,je ; do i=is,ie CS%vbtav(i,J) = CS%vbtav(i,J) + CS%frhatv(i,J,k) * v(i,J,k) enddo ; enddo ; enddo - elseif ((US%s_to_T_restart*US%m_to_L_restart /= 0.0) .and. & - (US%m_to_L*US%s_to_T_restart) /= (US%m_to_L_restart*US%s_to_T)) then - vel_rescale = (US%m_to_L*US%s_to_T_restart) / (US%m_to_L_restart*US%s_to_T) - do j=js,je ; do I=is-1,ie ; CS%ubtav(I,j) = vel_rescale * CS%ubtav(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vbtav(i,J) = vel_rescale * CS%vbtav(i,J) ; enddo ; enddo endif if (CS%gradual_BT_ICs) then @@ -4910,28 +6427,25 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, .NOT.query_initialized(CS%vbt_IC,"vbt_IC",restart_CS)) then do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = CS%ubtav(I,j) ; enddo ; enddo do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = CS%vbtav(i,J) ; enddo ; enddo - elseif ((US%s_to_T_restart*US%m_to_L_restart /= 0.0) .and. & - (US%m_to_L*US%s_to_T_restart) /= (US%m_to_L_restart*US%s_to_T)) then - vel_rescale = (US%m_to_L*US%s_to_T_restart) / (US%m_to_L_restart*US%s_to_T) - do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = vel_rescale * CS%ubt_IC(I,j) ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = vel_rescale * CS%vbt_IC(i,J) ; enddo ; enddo endif endif -! Calculate other constants which are used for btstep. + ! Calculate other constants which are used for btstep. if (.not.CS%nonlin_stress) then - Mean_SL = G%Z_ref + Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin do j=js,je ; do I=is-1,ie - if (G%mask2dCu(I,j)>0.) then - CS%IDatu(I,j) = G%mask2dCu(I,j) * 2.0 / ((G%bathyT(i+1,j) + G%bathyT(i,j)) + 2.0*Mean_SL) - else ! Both neighboring H points are masked out so IDatu(I,j) is meaningless + htot = max(G%meanSL(i+1,j) + G%bathyT(i+1,j), 0.0) + max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) + if (G%OBCmaskCu(I,j) * htot > 0.) then + CS%IDatu(I,j) = G%OBCmaskCu(I,j) * 2.0 / (Z_to_H * htot) + else ! Both neighboring H points are masked out or this is an OBC face so IDatu(I,j) is unused CS%IDatu(I,j) = 0. endif enddo ; enddo do J=js-1,je ; do i=is,ie - if (G%mask2dCv(i,J)>0.) then - CS%IDatv(i,J) = G%mask2dCv(i,J) * 2.0 / ((G%bathyT(i,j+1) + G%bathyT(i,j)) + 2.0*Mean_SL) - else ! Both neighboring H points are masked out so IDatv(i,J) is meaningless + htot = max(G%meanSL(i,j+1) + G%bathyT(i,j+1), 0.0) + max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) + if (G%OBCmaskCv(i,J) * htot > 0.) then + CS%IDatv(i,J) = G%OBCmaskCv(i,J) * 2.0 / (Z_to_H * htot) + else ! Both neighboring H points are masked out or this is an OBC face so IDatv(i,J) is unused CS%IDatv(i,J) = 0. endif enddo ; enddo @@ -4952,7 +6466,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, call create_group_pass(pass_bt_hbt_btav, CS%ubtav, CS%vbtav, G%Domain) call do_group_pass(pass_bt_hbt_btav, G%Domain) -! id_clock_pass = cpu_clock_id('(Ocean BT halo updates)', grain=CLOCK_ROUTINE) + ! id_clock_pass = cpu_clock_id('(Ocean BT halo updates)', grain=CLOCK_ROUTINE) id_clock_calc_pre = cpu_clock_id('(Ocean BT pre-calcs only)', grain=CLOCK_ROUTINE) id_clock_pass_pre = cpu_clock_id('(Ocean BT pre-step halo updates)', grain=CLOCK_ROUTINE) id_clock_calc = cpu_clock_id('(Ocean BT stepping calcs only)', grain=CLOCK_ROUTINE) @@ -4996,14 +6510,27 @@ subroutine barotropic_end(CS) ! Allocated in barotropic_init, called in timestep initialization DEALLOC_(CS%ua_polarity) ; DEALLOC_(CS%va_polarity) DEALLOC_(CS%IDatu) ; DEALLOC_(CS%IDatv) - if (CS%bound_BT_corr) then - DEALLOC_(CS%eta_cor_bound) - endif + if (allocated(CS%eta_cor_bound)) deallocate(CS%eta_cor_bound) DEALLOC_(CS%eta_cor) - DEALLOC_(CS%frhatu) ; DEALLOC_(CS%frhatv) + DEALLOC_(CS%bathyT) ; DEALLOC_(CS%IareaT) + DEALLOC_(CS%frhatu) ; DEALLOC_(CS%frhatv) + DEALLOC_(CS%OBCmask_u) ; DEALLOC_(CS%OBCmask_v) + DEALLOC_(CS%IdxCu) ; DEALLOC_(CS%IdyCv) + DEALLOC_(CS%dy_Cu) ; DEALLOC_(CS%dx_Cv) if (allocated(CS%frhatu1)) deallocate(CS%frhatu1) if (allocated(CS%frhatv1)) deallocate(CS%frhatv1) + if (allocated(CS%IareaT_OBCmask)) deallocate(CS%IareaT_OBCmask) + + if (allocated(CS%q_D)) deallocate(CS%q_D) + if (allocated(CS%D_u_Cor)) deallocate(CS%D_u_Cor) + if (allocated(CS%D_v_Cor)) deallocate(CS%D_v_Cor) + if (allocated(CS%ubt_IC)) deallocate(CS%ubt_IC) + if (allocated(CS%vbt_IC)) deallocate(CS%vbt_IC) + if (allocated(CS%lin_drag_u)) deallocate(CS%lin_drag_u) + if (allocated(CS%lin_drag_v)) deallocate(CS%lin_drag_v) + + if (associated(CS%debug_BT_HI)) deallocate(CS%debug_BT_HI) call deallocate_MOM_domain(CS%BT_domain) ! Allocated in restart registration, prior to timestep initialization @@ -5012,16 +6539,18 @@ end subroutine barotropic_end !> This subroutine is used to register any fields from MOM_barotropic.F90 !! that should be written to or read from the restart file. -subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) +subroutine register_barotropic_restarts(HI, GV, US, param_file, CS, restart_CS) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. type(barotropic_CS), intent(inout) :: CS !< Barotropic control structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure ! Local variables type(vardesc) :: vd(3) character(len=40) :: mdl = "MOM_barotropic" ! This module's name. + integer :: n_filters !< Number of streaming band-pass filters to be used in the simulation. integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed @@ -5038,15 +6567,16 @@ subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) ALLOC_(CS%ubtav(IsdB:IedB,jsd:jed)) ; CS%ubtav(:,:) = 0.0 ALLOC_(CS%vbtav(isd:ied,JsdB:JedB)) ; CS%vbtav(:,:) = 0.0 if (CS%gradual_BT_ICs) then - ALLOC_(CS%ubt_IC(IsdB:IedB,jsd:jed)) ; CS%ubt_IC(:,:) = 0.0 - ALLOC_(CS%vbt_IC(isd:ied,JsdB:JedB)) ; CS%vbt_IC(:,:) = 0.0 + allocate(CS%ubt_IC(IsdB:IedB,jsd:jed), source=0.0) + allocate(CS%vbt_IC(isd:ied,JsdB:JedB), source=0.0) endif vd(2) = var_desc("ubtav","m s-1","Time mean barotropic zonal velocity", & hor_grid='u', z_grid='1') vd(3) = var_desc("vbtav","m s-1","Time mean barotropic meridional velocity",& hor_grid='v', z_grid='1') - call register_restart_pair(CS%ubtav, CS%vbtav, vd(2), vd(3), .false., restart_CS) + call register_restart_pair(CS%ubtav, CS%vbtav, vd(2), vd(3), .false., restart_CS, & + conversion=US%L_T_to_m_s) if (CS%gradual_BT_ICs) then vd(2) = var_desc("ubt_IC", "m s-1", & @@ -5055,15 +6585,29 @@ subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) vd(3) = var_desc("vbt_IC", "m s-1", & longname="Next initial condition for the barotropic meridional velocity",& hor_grid='v', z_grid='1') - call register_restart_pair(CS%ubt_IC, CS%vbt_IC, vd(2), vd(3), .false., restart_CS) + call register_restart_pair(CS%ubt_IC, CS%vbt_IC, vd(2), vd(3), .false., restart_CS, & + conversion=US%L_T_to_m_s) endif - call register_restart_field(CS%dtbt, "DTBT", .false., restart_CS, & - longname="Barotropic timestep", units="seconds") + longname="Barotropic timestep", units="seconds", conversion=US%T_to_s) + + ! Register streaming band-pass filters + call get_param(param_file, mdl, "USE_FILTER", CS%use_filter, & + "If true, use streaming band-pass filters to detect the "//& + "instantaneous tidal signals in the simulation.", default=.false.) + call get_param(param_file, mdl, "N_FILTERS", n_filters, & + "Number of streaming band-pass filters to be used in the simulation.", & + default=0, do_not_log=.not.CS%use_filter) + if (n_filters<=0) CS%use_filter = .false. + if (CS%use_filter) then + call Filt_register(n_filters, 'ubt', 'u', HI, CS%Filt_CS_u, restart_CS) + call Filt_register(n_filters, 'vbt', 'v', HI, CS%Filt_CS_v, restart_CS) + endif end subroutine register_barotropic_restarts + !> \namespace mom_barotropic !! !! By Robert Hallberg, April 1994 - January 2007 @@ -5079,7 +6623,7 @@ end subroutine register_barotropic_restarts !! surface height (or column mass), and the volume (or mass) fluxes !! summed through the layers and averaged over the baroclinic time !! step. As input, btstep takes the initial 3-D velocities, the -!! inital free surface height, the 3-D accelerations of the layers, +!! initial free surface height, the 3-D accelerations of the layers, !! and the external forcing. Everything in btstep is cast in terms !! of anomalies, so if everything is in balance, there is explicitly !! no acceleration due to btstep. diff --git a/src/core/MOM_boundary_update.F90 b/src/core/MOM_boundary_update.F90 index 11973f8c02..70e35f7274 100644 --- a/src/core/MOM_boundary_update.F90 +++ b/src/core/MOM_boundary_update.F90 @@ -1,16 +1,18 @@ -! This file is part of MOM6. See LICENSE.md for the license. +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Controls where open boundary conditions are applied module MOM_boundary_update -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_diag_mediator, only : time_type use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_version, param_file_type, log_param use MOM_grid, only : ocean_grid_type use MOM_dyn_horgrid, only : dyn_horgrid_type -use MOM_open_boundary, only : ocean_obc_type, update_OBC_segment_data +use MOM_open_boundary, only : ocean_obc_type, update_OBC_segment_data, chksum_OBC_segments +use MOM_open_boundary, only : read_OBC_segment_data use MOM_open_boundary, only : OBC_registry_type, file_OBC_CS use MOM_open_boundary, only : register_file_OBC, file_OBC_end use MOM_unit_scaling, only : unit_scale_type @@ -41,6 +43,11 @@ module MOM_boundary_update logical :: use_tidal_bay = .false. !< If true, use the tidal_bay open boundary. logical :: use_shelfwave = .false. !< If true, use the shelfwave open boundary. logical :: use_dyed_channel = .false. !< If true, use the dyed channel open boundary. + logical :: debug_OBCs = .false. !< If true, write verbose OBC values for debugging purposes. + logical :: value_update_bug = .true. !< If true, recover a bug that OBC segment data does not + !! update if all segments use 'value' and none uses 'file'. + integer :: nk_OBC_debug = 0 !< The number of layers of OBC segment data to write out + !! in full when DEBUG_OBCS is true. !>@{ Pointers to the control structures for named OBC specifications type(file_OBC_CS), pointer :: file_OBC_CSp => NULL() type(Kelvin_OBC_CS), pointer :: Kelvin_OBC_CSp => NULL() @@ -59,14 +66,17 @@ module MOM_boundary_update !> The following subroutines and associated definitions provide the !! machinery to register and call the subroutines that initialize !! open boundary conditions. -subroutine call_OBC_register(param_file, CS, US, OBC, tr_Reg) - type(param_file_type), intent(in) :: param_file !< Parameter file to parse - type(update_OBC_CS), pointer :: CS !< Control structure for OBCs - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry. +subroutine call_OBC_register(G, GV, US, param_file, CS, OBC, tr_Reg) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file to parse + type(update_OBC_CS), pointer :: CS !< Control structure for OBCs + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry. ! Local variables + logical :: debug character(len=200) :: config character(len=40) :: mdl = "MOM_boundary_update" ! This module's name. ! This include declares and sets the variable "version". @@ -79,6 +89,9 @@ subroutine call_OBC_register(param_file, CS, US, OBC, tr_Reg) call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "OBC_VALUE_UPDATE_BUG", CS%value_update_bug, & + "If true, recover a bug that OBC segment data does not update if all segments "//& + "use 'value' and none uses 'file'.", default=.true.) call get_param(param_file, mdl, "USE_FILE_OBC", CS%use_files, & "If true, use external files for the open boundary.", & default=.false.) @@ -104,6 +117,16 @@ subroutine call_OBC_register(param_file, CS, US, OBC, tr_Reg) " supercritical - now only needed here for the allocations\n"//& " tidal_bay - Flather with tidal forcing on eastern boundary\n"//& " USER - user specified", default="none", do_not_log=.true.) + call get_param(param_file, mdl, "DEBUG", debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + call get_param(param_file, mdl, "DEBUG_OBCS", CS%debug_OBCs, & + "If true, write out verbose debugging data about OBCs.", & + default=.false., debuggingParam=.true.) + call get_param(param_file, mdl, "NK_OBC_DEBUG", CS%nk_OBC_debug, & + "The number of layers of OBC segment data to write out in full "//& + "when DEBUG_OBCS is true.", & + default=0, debuggingParam=.true., do_not_log=.not.CS%debug_OBCs) if (CS%use_files) CS%use_files = & register_file_OBC(param_file, CS%file_OBC_CSp, US, & @@ -124,7 +147,7 @@ subroutine call_OBC_register(param_file, CS, US, OBC, tr_Reg) register_Kelvin_OBC(param_file, CS%Kelvin_OBC_CSp, US, & OBC%OBC_Reg) if (CS%use_shelfwave) CS%use_shelfwave = & - register_shelfwave_OBC(param_file, CS%shelfwave_OBC_CSp, US, & + register_shelfwave_OBC(param_file, CS%shelfwave_OBC_CSp, G, US, & OBC%OBC_Reg) if (CS%use_dyed_channel) CS%use_dyed_channel = & register_dyed_channel_OBC(param_file, CS%dyed_channel_OBC_CSp, US, & @@ -143,9 +166,6 @@ subroutine update_OBC_data(OBC, G, GV, US, tv, h, CS, Time) type(update_OBC_CS), pointer :: CS !< Control structure for OBCs type(time_type), intent(in) :: Time !< Model time -! Something here... with CS%file_OBC_CSp? -! if (CS%use_files) & -! call update_OBC_segment_data(G, GV, OBC, tv, h, Time) if (CS%use_tidal_bay) & call tidal_bay_set_OBC_data(OBC, CS%tidal_bay_OBC, G, GV, US, h, Time) if (CS%use_Kelvin) & @@ -153,9 +173,15 @@ subroutine update_OBC_data(OBC, G, GV, US, tv, h, CS, Time) if (CS%use_shelfwave) & call shelfwave_set_OBC_data(OBC, CS%shelfwave_OBC_CSp, G, GV, US, h, Time) if (CS%use_dyed_channel) & - call dyed_channel_update_flow(OBC, CS%dyed_channel_OBC_CSp, G, GV, US, Time) - if (OBC%needs_IO_for_data .or. OBC%add_tide_constituents) & - call update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) + call dyed_channel_update_flow(OBC, CS%dyed_channel_OBC_CSp, G, GV, US, h, Time) + + if (.not. OBC%user_BCs_set_globally) then + if (OBC%any_needs_IO_for_data) call read_OBC_segment_data(G, GV, US, OBC, tv, h, Time) + if ((.not.CS%value_update_bug) .or. (OBC%any_needs_IO_for_data .or. OBC%add_tide_constituents)) & + call update_OBC_segment_data(G, GV, US, OBC, h, Time) + endif + + if (CS%debug_OBCs) call chksum_OBC_segments(OBC, G, GV, US, CS%nk_OBC_debug) end subroutine update_OBC_data diff --git a/src/core/MOM_check_scaling.F90 b/src/core/MOM_check_scaling.F90 new file mode 100644 index 0000000000..b52b577293 --- /dev/null +++ b/src/core/MOM_check_scaling.F90 @@ -0,0 +1,237 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> This module is used to check the dimensional scaling factors used by the MOM6 ocean model +module MOM_check_scaling + +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, assert, MOM_get_verbosity +use MOM_unique_scales, only : check_scaling_uniqueness, scales_to_powers +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +public check_MOM6_scaling_factors + +contains + +!> Evaluate whether the dimensional scaling factors provide unique tests for all of the combinations +!! of dimensions that are used in MOM6 (or perhaps widely used), and if they are not unique, explore +!! whether another combination of scaling factors can be found that is unique or has less common +!! cases with coinciding scaling. +subroutine check_MOM6_scaling_factors(GV, US) + type(verticalGrid_type), pointer :: GV !< The container for vertical grid data + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + integer, parameter :: ndims = 8 ! The number of rescalable dimensional factors. + real, dimension(ndims) :: scales ! An array of scaling factors for each of the basic units [various]. + integer, dimension(ndims) :: scale_pow2 ! The powers of 2 that give each element of scales. + character(len=2), dimension(ndims) :: key + integer, allocatable :: weights(:) + character(len=80), allocatable :: descriptions(:) + integer :: n, ns, max_pow + + ! If no scaling is being done, simply return. + if ((US%Z_to_m == 1.) .and. (GV%H_to_MKS == 1.) .and. (US%L_to_m == 1.) .and. & + (US%T_to_s == 1.) .and. (US%R_to_kg_m3 == 1.) .and. (US%Q_to_J_kg == 1.) .and. & + (US%C_to_degC == 1.) .and. (US%S_to_ppt == 1.)) return + + ! Set the names and scaling factors of the dimensions being rescaled. + key(:) = ["Z", "H", "L", "T", "R", "Q", "C", "S"] + scales(:) = (/ US%Z_to_m, GV%H_to_MKS, US%L_to_m, US%T_to_s, US%R_to_kg_m3, US%Q_to_J_kg, & + US%C_to_degC, US%S_to_ppt/) + call scales_to_powers(scales, scale_pow2) + max_pow = 40 ! 60 + + ! The first call is just to find out how many elements are in the list of scaling combinations. + call compose_dimension_list(ns, descriptions, weights) + + allocate(descriptions(ns)) + do n=1,ns ; descriptions(n) = "" ; enddo + allocate(weights(ns), source=0) + ! This call records all the list of powers, the descriptions, and their weights. + call compose_dimension_list(ns, descriptions, weights) + + call check_scaling_uniqueness("MOM6", descriptions, weights, key, scale_pow2, max_pow) + + deallocate(weights) + deallocate(descriptions) + +end subroutine check_MOM6_scaling_factors + + +!> This routine composes a list of the commonly used dimensional scaling factors in the MOM6 +!! code, along with weights reflecting the frequency of their occurrence in the MOM6 code or +!! other considerations of how likely the variables are be used. +subroutine compose_dimension_list(ns, des, wts) + integer, intent(out) :: ns !< The running sum of valid descriptions + character(len=*), allocatable, intent(inout) :: des(:) !< The unit descriptions that have been converted + integer, allocatable, intent(inout) :: wts(:) !< A list of the integer weights for each scaling factor, + !! perhaps the number of times it occurs in the MOM6 code. + + ns = 0 + ! Accumulate a list of units used in MOM6, in approximate descending order of frequency of occurrence in + ! doxygen comments (i.e., arguments and elements in types), excluding the code in the user, ice_shelf and + ! framework directories and the passive tracer packages. + call add_scaling(ns, des, wts, "[H ~> m or kg m-2]", 716) ! Layer thicknesses + call add_scaling(ns, des, wts, "[L T-1 ~> m s-1]", 264) ! Horizontal velocities + call add_scaling(ns, des, wts, "[Z ~> m]", 244) ! Depths and vertical distance + call add_scaling(ns, des, wts, "[T ~> s]", 154) ! Time intervals + call add_scaling(ns, des, wts, "[S ~> ppt]", 135) ! Salinities + call add_scaling(ns, des, wts, "[C ~> degC]", 135) ! Temperatures + call add_scaling(ns, des, wts, "[R L2 T-2 ~> Pa]", 133) ! Dynamic pressure + ! call add_scaling(ns, des, wts, "[R L2 T-2 ~> J m-3]") ! Energy density + call add_scaling(ns, des, wts, "[Z2 T-1 ~> m2 s-1]", 132) ! Vertical viscosities and diffusivities + call add_scaling(ns, des, wts, "[R ~> kg m-3]", 122) ! Densities + + call add_scaling(ns, des, wts, "[H L2 T-1 ~> m3 s-1 or kg s-1]", 97) ! Volume or mass transports + call add_scaling(ns, des, wts, "[H L2 ~> m3 or kg]", 91) ! Cell volumes or masses + call add_scaling(ns, des, wts, "[L T-2 ~> m s-2]", 82) ! Horizontal accelerations + call add_scaling(ns, des, wts, "[T-1 ~> s-1]", 67) ! Rates + call add_scaling(ns, des, wts, "[Z T-1 ~> m s-1]", 56) ! Friction velocities and viscous coupling + call add_scaling(ns, des, wts, "[Q R Z T-1 ~> W m-2]", 42) ! Vertical heat fluxes + call add_scaling(ns, des, wts, "[L2 T-1 ~> m2 s-1]", 45) ! Horizontal viscosity or diffusivity + call add_scaling(ns, des, wts, "[L2 T-2 ~> m2 s-2]", 37) ! Resolved kinetic energy per unit mass + call add_scaling(ns, des, wts, "[L ~> m]", 35) ! Horizontal distances + call add_scaling(ns, des, wts, "[T-2 ~> s-2]", 33) ! Squared shears and buoyancy frequency + + call add_scaling(ns, des, wts, "[R Z L T-2 ~> Pa]", 33) ! Wind stresses + call add_scaling(ns, des, wts, "[H L ~> m2 or kg m-1]", 32) ! Lateral cell face areas + call add_scaling(ns, des, wts, "[L2 ~> m2]", 31) ! Horizontal areas + call add_scaling(ns, des, wts, "[R C-1 ~> kg m-3 degC-1]", 26) ! Thermal expansion coefficients + call add_scaling(ns, des, wts, "[L2 Z-1 T-2 ~> m s-2]", 26) ! Gravitational acceleration + call add_scaling(ns, des, wts, "[R S-1 ~> kg m-3 ppt-1]", 23) ! Haline contraction coefficients + call add_scaling(ns, des, wts, "[R Z3 T-3 ~> W m-2]", 23) ! Integrated turbulent kinetic energy sources + call add_scaling(ns, des, wts, "[R Z T-1 ~> kg m-2 s-1]", 19) ! Vertical mass fluxes + call add_scaling(ns, des, wts, "[C H ~> degC m or degC kg m-2]", 17) ! Heat content + call add_scaling(ns, des, wts, "[H-1 ~> m-1 or m2 kg-1]", 17) ! Inverse cell thicknesses + + call add_scaling(ns, des, wts, "[Z-1 ~> m-1]", 14) ! Inverse vertical distances + call add_scaling(ns, des, wts, "[R-1 ~> m3 kg-1]", 14) ! Specific volumes + call add_scaling(ns, des, wts, "[Z L-1 ~> nondim]", 12) ! Slopes + call add_scaling(ns, des, wts, "[L-1 ~> m-1]", 12) ! Inverse horizontal distances + call add_scaling(ns, des, wts, "[L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]", 12) ! pbce or gtot + call add_scaling(ns, des, wts, "[R Z ~> kg m-2]", 11) ! Layer or column mass loads + call add_scaling(ns, des, wts, "[Z L2 T-2 ~> m3 s-2]", 11) ! Integrated energy per unit mass + call add_scaling(ns, des, wts, "[R Z3 T-2 ~> J m-2]", 11) ! Integrated turbulent kinetic energy density + call add_scaling(ns, des, wts, "[H T-1 ~> m s-1 or kg m-2 s-1]", 9) ! Vertical thickness fluxes + call add_scaling(ns, des, wts, "[L-1 T-1 ~> m-1 s-1]", 9) ! Laplacian of velocity + + call add_scaling(ns, des, wts, "[Z3 T-3 ~> m3 s-3]", 9) ! Integrated turbulent kinetic energy sources + call add_scaling(ns, des, wts, "[S H ~> ppt m or ppt kg m-2]", 8) ! Depth integrated salinity + call add_scaling(ns, des, wts, "[Z2 T-2 ~> m2 s-2]", 8) ! Turbulent kinetic energy + call add_scaling(ns, des, wts, "[R L2 Z T-2 ~> Pa m]", 7) ! Vertically integrated pressure anomalies + call add_scaling(ns, des, wts, "[T2 Z-1 ~> s2 m-1]", 7) ! (TKE_to_Kd) + call add_scaling(ns, des, wts, "[L4 T-1 ~> m4 s-1]", 7) ! Biharmonic viscosity + call add_scaling(ns, des, wts, "[L3 ~> m3]", 7) ! Metric dependent constants for viscosity + call add_scaling(ns, des, wts, "[L2 T-3 ~> m2 s-3]", 7) ! Buoyancy flux or MEKE sources [L2 T-3 ~> W kg-1] + call add_scaling(ns, des, wts, "[H2 ~> m2 or kg2 m-4]", 7) ! Squared layer thicknesses + call add_scaling(ns, des, wts, "[C H T-1 ~> degC m s-1 or degC kg m-2 s-1]", 7) ! vertical heat fluxes + + call add_scaling(ns, des, wts, "[L-2 ~> m-2]", 6) ! Inverse areas + call add_scaling(ns, des, wts, "[R Z L2 T-3 ~> W m-2]", 6) ! Energy sources, including for MEKE + call add_scaling(ns, des, wts, "[Z2 T-3 ~> m2 s-3]", 5) ! Certain buoyancy fluxes + call add_scaling(ns, des, wts, "[Z2 ~> m2]", 5) ! Squared vertical distances + call add_scaling(ns, des, wts, "[S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1]", 5) ! vertical salinity fluxes + call add_scaling(ns, des, wts, "[R-1 C-1 ~> m3 kg-1 degC-1]", 5) ! Specific volume temperature gradient + call add_scaling(ns, des, wts, "[R-1 S-1 ~> m3 kg-1 ppt-1]", 4) ! Specific volume salnity gradient + call add_scaling(ns, des, wts, "[Q R Z ~> J m-2]", 4) ! time-integrated frazil heat flux + call add_scaling(ns, des, wts, "[Z C-1 ~> m degC-1]", 4) ! Inverse temperature gradients + call add_scaling(ns, des, wts, "[Z S-1 ~> m ppt-1]", 4) ! Inverse salinity gradients + + call add_scaling(ns, des, wts, "[R Z3 T-2 H-1 ~> J m-3 or J kg-1]", 4) ! Partial derivatives of energy + call add_scaling(ns, des, wts, "[R Z3 T-2 S-1 ~> J m-2 ppt-1]", 4) ! Sensitity of energy change to salinity + call add_scaling(ns, des, wts, "[R Z3 T-2 C-1 ~> J m-2 degC-1]", 4) ! Sensitity of energy change to temperature + call add_scaling(ns, des, wts, "[R L4 T-4 ~> Pa m2 s-2]", 4) ! Integral in geopotential of pressure + call add_scaling(ns, des, wts, "[Q ~> J kg-1]", 4) ! Latent heats + call add_scaling(ns, des, wts, "[Q C-1 ~> J kg-1 degC-1]", 4) ! Heat capacity + call add_scaling(ns, des, wts, "[L-3 ~> m-3]", 4) ! Metric dependent constants for viscosity + call add_scaling(ns, des, wts, "[L2 Z-2 T-2 ~> s-2]", 4) ! Buoyancy frequency in some params. + call add_scaling(ns, des, wts, "[H R ~> kg m-2 or kg2 m-5]", 4) ! Layer-integrated density + call add_scaling(ns, des, wts, "[H L T-1 ~> m2 s-1 or kg m-1 s-1]", 4) ! Layer integrated velocities + + call add_scaling(ns, des, wts, "[H T2 L-1 ~> s2 or kg s2 m-3]", 4) ! BT_cont_type face curvature fit + call add_scaling(ns, des, wts, "[H L-1 ~> nondim or kg m-3]", 4) ! BT_cont_type face curvature fit + call add_scaling(ns, des, wts, "[C2 ~> degC2]", 4) ! Squared temperature anomalies + call add_scaling(ns, des, wts, "[S2 ~> ppt2]", 3) ! Squared salinity anomalies + call add_scaling(ns, des, wts, "[C S ~> degC ppt]", 3) ! Covariance of temperature and salinity anomalies + call add_scaling(ns, des, wts, "[S R Z ~> gSalt m-2]", 3) ! Total ocean column salt + call add_scaling(ns, des, wts, "[C R Z ~> degC kg m-2]", 3) ! Total ocean column temperature + call add_scaling(ns, des, wts, "[Pa T2 R-1 L-2 ~> 1]", 3) ! Pressure conversions + call add_scaling(ns, des, wts, "[Z H-1 ~> nondim or m3 kg-1]", 3) ! Thickness to height conversion + call add_scaling(ns, des, wts, "[R Z2 T-2 ~> J m-3]", 3) ! Potential energy height derivatives + + call add_scaling(ns, des, wts, "[H-2 ~> m-2 or m4 kg-2]", 3) ! Mixed layer local work variables + call add_scaling(ns, des, wts, "[C S-1 ~> degC ppt-1]", 2) ! T / S gauge transformation + call add_scaling(ns, des, wts, "[R S-2 ~> kg m-3 ppt-2]", 2) ! Second derivative of density + call add_scaling(ns, des, wts, "[R C-2 ~> kg m-3 degC-2]", 2) ! Second derivative of density + call add_scaling(ns, des, wts, "[R S-1 C-1 ~> kg m-3 ppt-1 degC-1]", 2) ! Second derivative of density + call add_scaling(ns, des, wts, "[T2 S-1 L-2 ~> kg m-3 ppt-1 Pa-1]", 2) ! Second derivative of density + call add_scaling(ns, des, wts, "[T2 C-1 L-2 ~> kg m-3 degC-1 Pa-1]", 2) ! Second derivative of density + call add_scaling(ns, des, wts, "[T2 L-2 ~> s2 m-2]", 2) ! Inverse velocities squared + call add_scaling(ns, des, wts, "[R Z2 T-3 ~> W m-3]", 2) ! Kinetic energy dissipation rates + call add_scaling(ns, des, wts, "[R H-1 ~> kg m-4 or m-1]", 2) ! Vertical density gradients + + call add_scaling(ns, des, wts, "[L4 ~> m4]", 2) ! Metric dependent constants for viscosity + call add_scaling(ns, des, wts, "[Z L T-1 ~> m2 s-1]", 2) ! Layer integrated velocities + call add_scaling(ns, des, wts, "[C Z ~> degC m]", 2) ! Depth integrated temperature + call add_scaling(ns, des, wts, "[S Z ~> ppt m]", 1) ! Layer integrated salinity + call add_scaling(ns, des, wts, "[T L4 ~> s m4]", 2) ! Biharmonic metric dependent constant + call add_scaling(ns, des, wts, "[L6 ~> m6]", 2) ! Biharmonic Leith metric dependent constant + call add_scaling(ns, des, wts, "[L4 Z-1 T-1 ~> m3 s-1]", 2) ! Rigidity of ice + call add_scaling(ns, des, wts, "[L4 Z-2 T-1 ~> m2 s-1]", 1) ! Ice rigidity term + call add_scaling(ns, des, wts, "[R-1 Z-1 ~> m2 kg-1]", 1) ! Inverse of column mass + call add_scaling(ns, des, wts, "[Z-2 ~> m-2]", 1) ! Inverse of denominator in some weighted averages + + call add_scaling(ns, des, wts, "[R Z2 T-1 ~> J s m-3]", 1) ! River mixing term + call add_scaling(ns, des, wts, "[R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1]", 1) ! Thickness to pressure conversion + call add_scaling(ns, des, wts, "[Z T2 R-1 L-2 ~> m Pa-1]", 1) ! Atmospheric pressure SSH correction + call add_scaling(ns, des, wts, "[T Z ~> s m] ", 1) ! Time integrated SSH + call add_scaling(ns, des, wts, "[Z-1 T-1 ~> m-1 s-1]", 1) ! barotropic PV + call add_scaling(ns, des, wts, "[L2 T ~> m2 s]", 1) ! Greatbatch & Lamb 90 coefficient + call add_scaling(ns, des, wts, "[Z L2 T-1 ~> m3 s-1]", 1) ! Overturning (GM) streamfunction + call add_scaling(ns, des, wts, "[kg H-1 L-2 ~> kg m-3 or 1]", 1) ! Diagnostic conversions to mass + call add_scaling(ns, des, wts, "[S-1 ~> ppt-1]", 1) ! Unscaling salinity + call add_scaling(ns, des, wts, "[C-1 ~> degC-1]", 1) ! Unscaling temperature + + call add_scaling(ns, des, wts, "[R Z H-1 ~> kg m-3 or 1] ", 1) ! A unit conversion factor + call add_scaling(ns, des, wts, "[H R-1 Z-1 ~> m3 kg-2 or 1]", 1) ! A unit conversion factor + call add_scaling(ns, des, wts, "[H Z-1 ~> 1 or kg m-3]", 1) ! A unit conversion factor + call add_scaling(ns, des, wts, "[m T s-1 L-1 ~> 1]", 1) ! A unit conversion factor + +end subroutine compose_dimension_list + +!> Augment the count the valid unit descriptions, and add the provided description and its weight +!! to the end of the list if that list is allocated. +subroutine add_scaling(ns, descs, wts, scaling, weight) + integer, intent(inout) :: ns !< The running sum of valid descriptions. + character(len=*), allocatable, intent(inout) :: descs(:) !< The unit descriptions that have been converted + integer, allocatable, intent(inout) :: wts(:) !< A list of the integers for each scaling + character(len=*), intent(in) :: scaling !< The unit description that will be converted + integer, optional, intent(in) :: weight !< An optional weight or occurrence count + !! for this unit description, 1 by default. + + integer :: iend + + iend = index(scaling, "~>") + if (iend <= 1) then + call MOM_mesg("No scaling indicator ~> found for "//trim(scaling)) + else + ! Count and perhaps store this description and its weight. + ns = ns + 1 + if (allocated(descs)) descs(ns) = scaling + if (allocated(wts)) then + wts(ns) = 1 ; if (present(weight)) wts(ns) = weight + endif + endif + +end subroutine add_scaling + +end module MOM_check_scaling diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index 917a4afdc3..bfe1366bf6 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Provides routines that do checksums of groups of MOM variables module MOM_checksum_packages -! This file is part of MOM6. See LICENSE.md for the license. - ! This module provides several routines that do check-sums of groups ! of variables in the various dynamic solver routines. @@ -29,9 +31,9 @@ module MOM_checksum_packages !> A type for storing statistica about a variable type :: stats ; private - real :: minimum = 1.E34 !< The minimum value - real :: maximum = -1.E34 !< The maximum value - real :: average = 0. !< The average value + real :: minimum = 1.E34 !< The minimum value [degC] or [ppt] or other units + real :: maximum = -1.E34 !< The maximum value [degC] or [ppt] or other units + real :: average = 0. !< The average value [degC] or [ppt] or other units end type stats contains @@ -39,7 +41,7 @@ module MOM_checksum_packages ! ============================================================================= !> Write out chksums for the model's basic state variables, including transports. -subroutine MOM_state_chksum_5arg(mesg, u, v, h, uh, vh, G, GV, US, haloshift, symmetric, vel_scale) +subroutine MOM_state_chksum_5arg(mesg, u, v, h, uh, vh, G, GV, US, haloshift, symmetric, omit_corners, vel_scale) character(len=*), & intent(in) :: mesg !< A message that appears on the chksum lines. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. @@ -60,9 +62,10 @@ subroutine MOM_state_chksum_5arg(mesg, u, v, h, uh, vh, G, GV, US, haloshift, sy integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0). logical, optional, intent(in) :: symmetric !< If true, do checksums on the fully symmetric !! computational domain. - real, optional, intent(in) :: vel_scale !< The scaling factor to convert velocities to [m s-1] + logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts + real, optional, intent(in) :: vel_scale !< The scaling factor to convert velocities to [T m L-1 s-1 ~> 1] - real :: scale_vel ! The scaling factor to convert velocities to [m s-1] + real :: scale_vel ! The scaling factor to convert velocities to mks units [T m L-1 s-1 ~> 1] logical :: sym integer :: hs @@ -73,16 +76,17 @@ subroutine MOM_state_chksum_5arg(mesg, u, v, h, uh, vh, G, GV, US, haloshift, sy sym = .false. ; if (present(symmetric)) sym=symmetric scale_vel = US%L_T_to_m_s ; if (present(vel_scale)) scale_vel = vel_scale - call uvchksum(mesg//" [uv]", u, v, G%HI, haloshift=hs, symmetric=sym, scale=scale_vel) - call hchksum(h, mesg//" h", G%HI, haloshift=hs, scale=GV%H_to_m) - call uvchksum(mesg//" [uv]h", uh, vh, G%HI, haloshift=hs, & - symmetric=sym, scale=GV%H_to_m*US%L_to_m**2*US%s_to_T) + call uvchksum(mesg//" [uv]", u, v, G%HI, haloshift=hs, symmetric=sym, & + omit_corners=omit_corners, unscale=scale_vel) + call hchksum(h, mesg//" h", G%HI, haloshift=hs, omit_corners=omit_corners, unscale=GV%H_to_MKS) + call uvchksum(mesg//" [uv]h", uh, vh, G%HI, haloshift=hs, symmetric=sym, & + omit_corners=omit_corners, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) end subroutine MOM_state_chksum_5arg ! ============================================================================= !> Write out chksums for the model's basic state variables. -subroutine MOM_state_chksum_3arg(mesg, u, v, h, G, GV, US, haloshift, symmetric) +subroutine MOM_state_chksum_3arg(mesg, u, v, h, G, GV, US, haloshift, symmetric, omit_corners) character(len=*), intent(in) :: mesg !< A message that appears on the chksum lines. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -92,11 +96,12 @@ subroutine MOM_state_chksum_3arg(mesg, u, v, h, G, GV, US, haloshift, symmetric) intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] or [m s-1].. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type, which is + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type, which is !! used to rescale u and v if present. integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0). logical, optional, intent(in) :: symmetric !< If true, do checksums on the fully !! symmetric computational domain. + logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts integer :: hs logical :: sym @@ -106,30 +111,43 @@ subroutine MOM_state_chksum_3arg(mesg, u, v, h, G, GV, US, haloshift, symmetric) ! and js...je as their extent. hs = 1 ; if (present(haloshift)) hs = haloshift sym = .false. ; if (present(symmetric)) sym = symmetric - call uvchksum(mesg//" u", u, v, G%HI, haloshift=hs, symmetric=sym, scale=US%L_T_to_m_s) - call hchksum(h, mesg//" h",G%HI, haloshift=hs, scale=GV%H_to_m) + call uvchksum(mesg//" u", u, v, G%HI, haloshift=hs, symmetric=sym, & + omit_corners=omit_corners, unscale=US%L_T_to_m_s) + call hchksum(h, mesg//" h",G%HI, haloshift=hs, omit_corners=omit_corners, unscale=GV%H_to_MKS) end subroutine MOM_state_chksum_3arg ! ============================================================================= !> Write out chksums for the model's thermodynamic state variables. -subroutine MOM_thermo_chksum(mesg, tv, G, US, haloshift) +subroutine MOM_thermo_chksum(mesg, tv, G, US, haloshift, omit_corners) character(len=*), intent(in) :: mesg !< A message that appears on the chksum lines. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0). + logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts integer :: hs hs=1 ; if (present(haloshift)) hs=haloshift - if (associated(tv%T)) call hchksum(tv%T, mesg//" T", G%HI, haloshift=hs) - if (associated(tv%S)) call hchksum(tv%S, mesg//" S", G%HI, haloshift=hs) - if (associated(tv%frazil)) call hchksum(tv%frazil, mesg//" frazil", G%HI, haloshift=hs, & - scale=US%Q_to_J_kg*US%R_to_kg_m3*US%Z_to_m) + if (associated(tv%T)) & + call hchksum(tv%T, mesg//" T", G%HI, haloshift=hs, omit_corners=omit_corners, unscale=US%C_to_degC) + if (associated(tv%S)) & + call hchksum(tv%S, mesg//" S", G%HI, haloshift=hs, omit_corners=omit_corners, unscale=US%S_to_ppt) + if (associated(tv%frazil)) & + call hchksum(tv%frazil, mesg//" frazil", G%HI, haloshift=hs, omit_corners=omit_corners, & + unscale=US%Q_to_J_kg*US%R_to_kg_m3*US%Z_to_m) if (associated(tv%salt_deficit)) & - call hchksum(tv%salt_deficit, mesg//" salt deficit", G%HI, haloshift=hs, scale=US%RZ_to_kg_m2) + call hchksum(tv%salt_deficit, mesg//" salt deficit", G%HI, haloshift=hs, omit_corners=omit_corners, & + unscale=US%S_to_ppt*US%RZ_to_kg_m2) + if (associated(tv%varT)) & + call hchksum(tv%varT, mesg//" varT", G%HI, haloshift=hs, omit_corners=omit_corners, unscale=US%C_to_degC**2) + if (associated(tv%varS)) & + call hchksum(tv%varS, mesg//" varS", G%HI, haloshift=hs, omit_corners=omit_corners, unscale=US%S_to_ppt**2) + if (associated(tv%covarTS)) & + call hchksum(tv%covarTS, mesg//" covarTS", G%HI, haloshift=hs, omit_corners=omit_corners, & + unscale=US%S_to_ppt*US%C_to_degC) end subroutine MOM_thermo_chksum @@ -151,21 +169,29 @@ subroutine MOM_surface_chksum(mesg, sfc_state, G, US, haloshift, symmetric) logical :: sym sym = .false. ; if (present(symmetric)) sym = symmetric - hs = 1 ; if (present(haloshift)) hs = haloshift + hs = 0 ; if (present(haloshift)) hs = haloshift - if (allocated(sfc_state%SST)) call hchksum(sfc_state%SST, mesg//" SST", G%HI, haloshift=hs) - if (allocated(sfc_state%SSS)) call hchksum(sfc_state%SSS, mesg//" SSS", G%HI, haloshift=hs) + if (allocated(sfc_state%SST)) call hchksum(sfc_state%SST, mesg//" SST", G%HI, haloshift=hs, & + unscale=US%C_to_degC) + if (allocated(sfc_state%SSS)) call hchksum(sfc_state%SSS, mesg//" SSS", G%HI, haloshift=hs, & + unscale=US%S_to_ppt) if (allocated(sfc_state%sea_lev)) call hchksum(sfc_state%sea_lev, mesg//" sea_lev", G%HI, & - haloshift=hs, scale=US%Z_to_m) + haloshift=hs, unscale=US%Z_to_m) if (allocated(sfc_state%Hml)) call hchksum(sfc_state%Hml, mesg//" Hml", G%HI, haloshift=hs, & - scale=US%Z_to_m) + unscale=US%Z_to_m) if (allocated(sfc_state%u) .and. allocated(sfc_state%v)) & call uvchksum(mesg//" SSU", sfc_state%u, sfc_state%v, G%HI, haloshift=hs, symmetric=sym, & - scale=US%L_T_to_m_s) -! if (allocated(sfc_state%salt_deficit)) & -! call hchksum(sfc_state%salt_deficit, mesg//" salt deficit", G%HI, haloshift=hs, scale=US%RZ_to_kg_m2) + unscale=US%L_T_to_m_s) if (allocated(sfc_state%frazil)) call hchksum(sfc_state%frazil, mesg//" frazil", G%HI, & - haloshift=hs, scale=US%Q_to_J_kg*US%RZ_to_kg_m2) + haloshift=hs, unscale=US%Q_to_J_kg*US%RZ_to_kg_m2) + if (allocated(sfc_state%melt_potential)) call hchksum(sfc_state%melt_potential, mesg//" melt_potential", & + G%HI, haloshift=hs, unscale=US%Q_to_J_kg*US%RZ_to_kg_m2) + if (allocated(sfc_state%ocean_mass)) call hchksum(sfc_state%ocean_mass, mesg//" ocean_mass", & + G%HI, haloshift=hs, unscale=US%RZ_to_kg_m2) + if (allocated(sfc_state%ocean_heat)) call hchksum(sfc_state%ocean_heat, mesg//" ocean_heat", & + G%HI, haloshift=hs, unscale=US%C_to_degC*US%RZ_to_kg_m2) + if (allocated(sfc_state%ocean_salt)) call hchksum(sfc_state%ocean_salt, mesg//" ocean_salt", & + G%HI, haloshift=hs, unscale=US%S_to_ppt*US%RZ_to_kg_m2) end subroutine MOM_surface_chksum @@ -211,19 +237,19 @@ subroutine MOM_accel_chksum(mesg, CAu, CAv, PFu, PFv, diffu, diffv, G, GV, US, p logical :: sym - sym=.false.; if (present(symmetric)) sym=symmetric + sym = .false. ; if (present(symmetric)) sym = symmetric ! Note that for the chksum calls to be useful for reproducing across PE ! counts, there must be no redundant points, so all variables use is..ie ! and js...je as their extent. - call uvchksum(mesg//" CA[uv]", CAu, CAv, G%HI, haloshift=0, symmetric=sym, scale=US%L_T2_to_m_s2) - call uvchksum(mesg//" PF[uv]", PFu, PFv, G%HI, haloshift=0, symmetric=sym, scale=US%L_T2_to_m_s2) - call uvchksum(mesg//" diffu", diffu, diffv, G%HI,haloshift=0, symmetric=sym, scale=US%L_T2_to_m_s2) + call uvchksum(mesg//" CA[uv]", CAu, CAv, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T2_to_m_s2) + call uvchksum(mesg//" PF[uv]", PFu, PFv, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T2_to_m_s2) + call uvchksum(mesg//" diffu", diffu, diffv, G%HI,haloshift=0, symmetric=sym, unscale=US%L_T2_to_m_s2) if (present(pbce)) & - call hchksum(pbce, mesg//" pbce",G%HI,haloshift=0, scale=GV%m_to_H*US%L_T_to_m_s**2) + call hchksum(pbce, mesg//" pbce",G%HI,haloshift=0, unscale=GV%m_to_H*US%L_T_to_m_s**2) if (present(u_accel_bt) .and. present(v_accel_bt)) & call uvchksum(mesg//" [uv]_accel_bt", u_accel_bt, v_accel_bt, G%HI,haloshift=0, symmetric=sym, & - scale=US%L_T2_to_m_s2) + unscale=US%L_T2_to_m_s2) end subroutine MOM_accel_chksum ! ============================================================================= @@ -240,9 +266,9 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. real, pointer, dimension(:,:,:), & - intent(in) :: Temp !< Temperature [degC]. + intent(in) :: Temp !< Temperature [C ~> degC]. real, pointer, dimension(:,:,:), & - intent(in) :: Salt !< Salinity [ppt]. + intent(in) :: Salt !< Salinity [S ~> ppt]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type logical, optional, intent(in) :: allowChange !< do not flag an error !! if the statistics change. @@ -251,21 +277,25 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe ! Local variables real, dimension(G%isc:G%iec, G%jsc:G%jec) :: & - tmp_A, & ! The area per cell [m2] (unscaled to permit reproducing sum). - tmp_V, & ! The column-integrated volume [m3] (unscaled to permit reproducing sum) - tmp_T, & ! The column-integrated temperature [degC m3] - tmp_S ! The column-integrated salinity [ppt m3] - real :: Vol, dV ! The total ocean volume and its change [m3] (unscaled to permit reproducing sum). - real :: Area ! The total ocean surface area [m2] (unscaled to permit reproducing sum). + tmp_A, & ! The area per cell [L2 ~> m2] + tmp_V, & ! The column-integrated volume or mass [H L2 ~> m3 or kg], + ! depending on whether the Boussinesq approximation is used + tmp_T, & ! The column-integrated temperature [C H L2 ~> degC m3 or degC kg] + tmp_S ! The column-integrated salinity [S H L2 ~> ppt m3 or ppt kg] + real :: Vol, dV ! The total ocean volume or mass and its change [H L2 ~> m3 or kg] + real :: Area ! The total ocean surface area [L2 ~> m2]. real :: h_minimum ! The minimum layer thicknesses [H ~> m or kg m-2] + real :: T_scale ! The scaling conversion factor for temperatures [degC C-1 ~> 1] + real :: S_scale ! The scaling conversion factor for salinities [ppt S-1 ~> 1] logical :: do_TS ! If true, evaluate statistics for temperature and salinity - type(stats) :: T, S, delT, delS + type(stats) :: T, delT ! Temperature statistics in unscaled units [degC] + type(stats) :: S, delS ! Salinity statistics in unscaled units [ppt] ! NOTE: save data is not normally allowed but we use it for debugging purposes here on the ! assumption we will not turn this on with threads type(stats), save :: oldT, oldS logical, save :: firstCall = .true. - real, save :: oldVol ! The previous total ocean volume [m3] + real, save :: oldVol ! The previous total ocean volume or mass [H L2 ~> m3 or kg] character(len=80) :: lMsg integer :: is, ie, js, je, nz, i, j, k @@ -278,32 +308,35 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe tmp_T(:,:) = 0.0 tmp_S(:,:) = 0.0 + T_scale = US%C_to_degC ; S_scale = US%S_to_ppt + ! First collect local stats do j=js,je ; do i=is,ie - tmp_A(i,j) = tmp_A(i,j) + US%L_to_m**2*G%areaT(i,j) + tmp_A(i,j) = tmp_A(i,j) + G%areaT(i,j) enddo ; enddo T%minimum = 1.E34 ; T%maximum = -1.E34 ; T%average = 0. S%minimum = 1.E34 ; S%maximum = -1.E34 ; S%average = 0. h_minimum = 1.E34*GV%m_to_H do k=1,nz ; do j=js,je ; do i=is,ie if (G%mask2dT(i,j)>0.) then - dV = US%L_to_m**2*G%areaT(i,j)*GV%H_to_m*h(i,j,k) + dV = G%areaT(i,j)*h(i,j,k) tmp_V(i,j) = tmp_V(i,j) + dV if (do_TS .and. h(i,j,k)>0.) then - T%minimum = min( T%minimum, Temp(i,j,k) ) ; T%maximum = max( T%maximum, Temp(i,j,k) ) - T%average = T%average + dV*Temp(i,j,k) - S%minimum = min( S%minimum, Salt(i,j,k) ) ; S%maximum = max( S%maximum, Salt(i,j,k) ) - S%average = S%average + dV*Salt(i,j,k) + T%minimum = min( T%minimum, T_scale*Temp(i,j,k) ) ; T%maximum = max( T%maximum, T_scale*Temp(i,j,k) ) + S%minimum = min( S%minimum, S_scale*Salt(i,j,k) ) ; S%maximum = max( S%maximum, S_scale*Salt(i,j,k) ) + tmp_T(i,j) = tmp_T(i,j) + dV*Temp(i,j,k) + tmp_S(i,j) = tmp_S(i,j) + dV*Salt(i,j,k) endif if (h_minimum > h(i,j,k)) h_minimum = h(i,j,k) endif enddo ; enddo ; enddo - Area = reproducing_sum( tmp_A ) ; Vol = reproducing_sum( tmp_V ) + Area = reproducing_sum( tmp_A, unscale=US%L_to_m**2 ) + Vol = reproducing_sum( tmp_V, unscale=US%L_to_m**2*GV%H_to_mks ) if (do_TS) then call min_across_PEs( T%minimum ) ; call max_across_PEs( T%maximum ) call min_across_PEs( S%minimum ) ; call max_across_PEs( S%maximum ) - T%average = reproducing_sum( tmp_T ) ; S%average = reproducing_sum( tmp_S ) - T%average = T%average / Vol ; S%average = S%average / Vol + T%average = T_scale*reproducing_sum( tmp_T, unscale=US%C_to_degC*US%L_to_m**2*GV%H_to_mks) / Vol + S%average = S_scale*reproducing_sum( tmp_S, unscale=US%S_to_ppt*US%L_to_m**2*GV%H_to_mks) / Vol endif if (is_root_pe()) then if (.not.firstCall) then @@ -312,7 +345,7 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe delT%average = T%average - oldT%average delS%minimum = S%minimum - oldS%minimum ; delS%maximum = S%maximum - oldS%maximum delS%average = S%average - oldS%average - write(lMsg(1:80),'(2(a,es12.4))') 'Mean thickness =', Vol/Area,' frac. delta=',dV/Vol + write(lMsg(1:80),'(2(a,es12.4))') 'Mean thickness =', GV%H_to_mks*Vol/Area,' frac. delta=',dV/Vol call MOM_mesg(lMsg//trim(mesg)) if (do_TS) then write(lMsg(1:80),'(a,3es12.4)') 'Temp min/mean/max =',T%minimum,T%average,T%maximum @@ -325,7 +358,7 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe call MOM_mesg(lMsg//trim(mesg)) endif else - write(lMsg(1:80),'(a,es12.4)') 'Mean thickness =', Vol/Area + write(lMsg(1:80),'(a,es12.4)') 'Mean thickness =', GV%H_to_mks*Vol/Area call MOM_mesg(lMsg//trim(mesg)) if (do_TS) then write(lMsg(1:80),'(a,3es12.4)') 'Temp min/mean/max =', T%minimum, T%average, T%maximum @@ -341,11 +374,11 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe if (do_TS .and. T%minimum<-5.0) then do j=js,je ; do i=is,ie - if (minval(Temp(i,j,:)) == T%minimum) then + if (minval(T_scale*Temp(i,j,:)) == T%minimum) then write(0,'(a,2f12.5)') 'x,y=', G%geoLonT(i,j), G%geoLatT(i,j) write(0,'(a3,3a12)') 'k','h','Temp','Salt' do k = 1, nz - write(0,'(i3,3es12.4)') k, h(i,j,k), Temp(i,j,k), Salt(i,j,k) + write(0,'(I0," ",3es12.4)') k, h(i,j,k), T_scale*Temp(i,j,k), S_scale*Salt(i,j,k) enddo stop 'Extremum detected' endif @@ -358,7 +391,7 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe write(0,'(a,2f12.5)') 'x,y=',G%geoLonT(i,j),G%geoLatT(i,j) write(0,'(a3,3a12)') 'k','h','Temp','Salt' do k = 1, nz - write(0,'(i3,3es12.4)') k, h(i,j,k), Temp(i,j,k), Salt(i,j,k) + write(0,'(I0," ",3es12.4)') k, h(i,j,k), T_scale*Temp(i,j,k), S_scale*Salt(i,j,k) enddo stop 'Negative thickness detected' endif diff --git a/src/core/MOM_continuity.F90 b/src/core/MOM_continuity.F90 index 0852d10cd2..27d69fc3d8 100644 --- a/src/core/MOM_continuity.F90 +++ b/src/core/MOM_continuity.F90 @@ -1,161 +1,32 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Solve the layer continuity equation. module MOM_continuity -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_continuity_PPM, only : continuity_PPM, continuity_PPM_init -use MOM_continuity_PPM, only : continuity_PPM_stencil -use MOM_continuity_PPM, only : continuity_PPM_CS -use MOM_diag_mediator, only : time_type, diag_ctrl -use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_string_functions, only : uppercase -use MOM_grid, only : ocean_grid_type -use MOM_open_boundary, only : ocean_OBC_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : BT_cont_type, porous_barrier_ptrs -use MOM_verticalGrid, only : verticalGrid_type +use MOM_continuity_PPM, only : continuity=>continuity_PPM +use MOM_continuity_PPM, only : continuity_stencil=>continuity_PPM_stencil +use MOM_continuity_PPM, only : continuity_init=>continuity_PPM_init +use MOM_continuity_PPM, only : continuity_CS=>continuity_PPM_CS +use MOM_continuity_PPM, only : continuity_fluxes, continuity_adjust_vel +use MOM_continuity_PPM, only : zonal_mass_flux, meridional_mass_flux +use MOM_continuity_PPM, only : zonal_edge_thickness, meridional_edge_thickness +use MOM_continuity_PPM, only : continuity_zonal_convergence, continuity_merdional_convergence +use MOM_continuity_PPM, only : zonal_flux_thickness, meridional_flux_thickness +use MOM_continuity_PPM, only : zonal_BT_mass_flux, meridional_BT_mass_flux +use MOM_continuity_PPM, only : set_continuity_loop_bounds, cont_loop_bounds_type implicit none ; private -#include - -public continuity, continuity_init, continuity_stencil - -!> Control structure for mom_continuity -type, public :: continuity_CS ; private - integer :: continuity_scheme !< Selects the discretization for the continuity solver. - !! Valid values are: - !! - PPM - A directionally split piecewise parabolic reconstruction solver. - !! The default, PPM, seems most appropriate for use with our current - !! time-splitting strategies. - type(continuity_PPM_CS) :: PPM !< Control structure for mom_continuity_ppm -end type continuity_CS - -integer, parameter :: PPM_SCHEME = 1 !< Enumerated constant to select PPM -character(len=20), parameter :: PPM_STRING = "PPM" !< String to select PPM - -contains - -!> Time steps the layer thicknesses, using a monotonically limited, directionally split PPM scheme, -!! based on Lin (1994). -subroutine continuity(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhbt, vhbt, & - visc_rem_u, visc_rem_v, u_cor, v_cor, BT_cont) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: hin !< Initial layer thickness [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: h !< Final layer thickness [H ~> m or kg m-2]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: uh !< Volume flux through zonal faces = - !! u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(out) :: vh !< Volume flux through meridional faces = - !! v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, intent(in) :: dt !< Time increment [T ~> s]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(continuity_CS), intent(in) :: CS !< Control structure for mom_continuity. - type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. - type(porous_barrier_ptrs), intent(in) :: pbv !< porous barrier fractional cell metrics - real, dimension(SZIB_(G),SZJ_(G)), & - optional, intent(in) :: uhbt !< The vertically summed volume - !! flux through zonal faces [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, dimension(SZI_(G),SZJB_(G)), & - optional, intent(in) :: vhbt !< The vertically summed volume - !! flux through meridional faces [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - optional, intent(in) :: visc_rem_u !< Both the fraction of - !! zonal momentum that remains after a time-step of viscosity, and the fraction of a time-step's - !! worth of a barotropic acceleration that a layer experiences after viscosity is applied. - !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - optional, intent(in) :: visc_rem_v !< Both the fraction of - !! meridional momentum that remains after a time-step of viscosity, and the fraction of a time-step's - !! worth of a barotropic acceleration that a layer experiences after viscosity is applied. - !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - optional, intent(out) :: u_cor !< The zonal velocities that - !! give uhbt as the depth-integrated transport [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - optional, intent(out) :: v_cor !< The meridional velocities that - !! give vhbt as the depth-integrated transport [L T-1 ~> m s-1]. - type(BT_cont_type), & - optional, pointer :: BT_cont !< A structure with elements - !! that describe the effective open face areas as a function of barotropic flow. - - if (present(visc_rem_u) .neqv. present(visc_rem_v)) call MOM_error(FATAL, & - "MOM_continuity: Either both visc_rem_u and visc_rem_v or neither"// & - " one must be present in call to continuity.") - if (present(u_cor) .neqv. present(v_cor)) call MOM_error(FATAL, & - "MOM_continuity: Either both u_cor and v_cor or neither"// & - " one must be present in call to continuity.") - - if (CS%continuity_scheme == PPM_SCHEME) then - call continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS%PPM, OBC, pbv, uhbt, vhbt, & - visc_rem_u, visc_rem_v, u_cor, v_cor, BT_cont=BT_cont) - else - call MOM_error(FATAL, "continuity: Unrecognized value of continuity_scheme") - endif - -end subroutine continuity - -!> Initializes continuity_cs -subroutine continuity_init(Time, G, GV, US, param_file, diag, CS) - type(time_type), target, intent(in) :: Time !< Current model time. - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure. - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< Parameter file handles. - type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure. - type(continuity_CS), intent(inout) :: CS !< Control structure for mom_continuity. - - ! This include declares and sets the variable "version". -# include "version_variable.h" - character(len=40) :: mdl = "MOM_continuity" ! This module's name. - character(len=20) :: tmpstr - - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "CONTINUITY_SCHEME", tmpstr, & - "CONTINUITY_SCHEME selects the discretization for the "//& - "continuity solver. The only valid value currently is: \n"//& - "\t PPM - use a positive-definite (or monotonic) \n"//& - "\t piecewise parabolic reconstruction solver.", & - default=PPM_STRING) - - tmpstr = uppercase(tmpstr) ; CS%continuity_scheme = 0 - select case (trim(tmpstr)) - case (PPM_STRING) ; CS%continuity_scheme = PPM_SCHEME - case default - call MOM_mesg('continuity_init: CONTINUITY_SCHEME ="'//trim(tmpstr)//'"', 0) - call MOM_mesg("continuity_init: The only valid value is currently "// & - trim(PPM_STRING), 0) - call MOM_error(FATAL, "continuity_init: Unrecognized setting "// & - "#define CONTINUITY_SCHEME "//trim(tmpstr)//" found in input file.") - end select - - if (CS%continuity_scheme == PPM_SCHEME) then - call continuity_PPM_init(Time, G, GV, US, param_file, diag, CS%PPM) - endif - -end subroutine continuity_init - - -!> continuity_stencil returns the continuity solver stencil size -function continuity_stencil(CS) result(stencil) - type(continuity_CS), intent(in) :: CS !< Module's control structure. - integer :: stencil !< The continuity solver stencil size with the current settings. - - stencil = 1 - - if (CS%continuity_scheme == PPM_SCHEME) then - stencil = continuity_PPM_stencil(CS%PPM) - endif -end function continuity_stencil +! These are direct pass-throughs of routines in continuity_PPM +public continuity, continuity_init, continuity_stencil, continuity_CS +public continuity_fluxes, continuity_adjust_vel +public zonal_mass_flux, meridional_mass_flux +public zonal_edge_thickness, meridional_edge_thickness +public continuity_zonal_convergence, continuity_merdional_convergence +public zonal_flux_thickness, meridional_flux_thickness +public zonal_BT_mass_flux, meridional_BT_mass_flux +public set_continuity_loop_bounds, cont_loop_bounds_type end module MOM_continuity diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 7bc67e2fdf..3375291ba1 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Solve the layer continuity equation using the PPM method for layer fluxes. module MOM_continuity_PPM -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_diag_mediator, only : time_type, diag_ctrl use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe @@ -11,7 +13,7 @@ module MOM_continuity_PPM use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_type, OBC_NONE use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : BT_cont_type, porous_barrier_ptrs +use MOM_variables, only : BT_cont_type, porous_barrier_type use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -19,9 +21,16 @@ module MOM_continuity_PPM #include public continuity_PPM, continuity_PPM_init, continuity_PPM_stencil +public continuity_fluxes, continuity_adjust_vel +public zonal_mass_flux, meridional_mass_flux +public zonal_edge_thickness, meridional_edge_thickness +public continuity_zonal_convergence, continuity_merdional_convergence +public zonal_flux_thickness, meridional_flux_thickness +public zonal_BT_mass_flux, meridional_BT_mass_flux +public set_continuity_loop_bounds !>@{ CPU time clock IDs -integer :: id_clock_update, id_clock_correct +integer :: id_clock_reconstruct, id_clock_update, id_clock_correct !>@} !> Control structure for mom_continuity_ppm @@ -42,6 +51,9 @@ module MOM_continuity_PPM !! discrepancies between the barotropic solution and !! the sum of the layer thicknesses [L T-1 ~> m s-1]. real :: CFL_limit_adjust !< The maximum CFL of the adjusted velocities [nondim] + real :: h_marg_min !< Negligible floor on h_marg, the marginal thickness + !! used to calculate the partial derivative of transports + !! with velocities [H ~> m or kg m-2] logical :: aggress_adjust !< If true, allow the adjusted velocities to have a !! relative CFL change up to 0.5. False by default. logical :: vol_CFL !< If true, use the ratio of the open face lengths @@ -60,19 +72,25 @@ module MOM_continuity_PPM end type continuity_PPM_CS !> A container for loop bounds -type :: loop_bounds_type ; private +type, public :: cont_loop_bounds_type ; private !>@{ Loop bounds integer :: ish, ieh, jsh, jeh !>@} -end type loop_bounds_type +end type cont_loop_bounds_type + +!> Finds the thickness fluxes from the continuity solver or their vertical sum without +!! actually updating the layer thicknesses. +interface continuity_fluxes + module procedure continuity_3d_fluxes, continuity_2d_fluxes +end interface continuity_fluxes contains !> Time steps the layer thicknesses, using a monotonically limit, directionally split PPM scheme, !! based on Lin (1994). subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhbt, vhbt, & - visc_rem_u, visc_rem_v, u_cor, v_cor, BT_cont) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + visc_rem_u, visc_rem_v, u_cor, v_cor, BT_cont, du_cor, dv_cor) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. @@ -90,7 +108,7 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhb type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(continuity_PPM_CS), intent(in) :: CS !< Module's control structure. type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. - type(porous_barrier_ptrs), intent(in) :: pbv !< pointers to porous barrier fractional cell metrics + type(porous_barrier_type), intent(in) :: pbv !< pointers to porous barrier fractional cell metrics real, dimension(SZIB_(G),SZJ_(G)), & optional, intent(in) :: uhbt !< The summed volume flux through zonal faces !! [H L2 T-1 ~> m3 s-1 or kg s-1]. @@ -120,15 +138,21 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhb !! transport [L T-1 ~> m s-1]. type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe !! the effective open face areas as a function of barotropic flow. + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(out) :: du_cor !< The zonal velocity increments from u that give uhbt + !! as the depth-integrated transports [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G)), & + optional, intent(out) :: dv_cor !< The meridional velocity increments from v that give vhbt + !! as the depth-integrated transports [L T-1 ~> m s-1]. ! Local variables + real :: h_W(SZI_(G),SZJ_(G),SZK_(GV)) ! West edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_E(SZI_(G),SZJ_(G),SZK_(GV)) ! East edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_S(SZI_(G),SZJ_(G),SZK_(GV)) ! South edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + real :: h_N(SZI_(G),SZJ_(G),SZK_(GV)) ! North edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. - type(loop_bounds_type) :: LB - integer :: is, ie, js, je, nz, stencil - integer :: i, j, k - + type(cont_loop_bounds_type) :: LB ! A type indicating the loop range for a phase of the updates logical :: x_first - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke h_min = GV%Angstrom_H @@ -138,96 +162,388 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhb x_first = (MOD(G%first_direction,2) == 0) if (present(visc_rem_u) .neqv. present(visc_rem_v)) call MOM_error(FATAL, & - "MOM_continuity_PPM: Either both visc_rem_u and visc_rem_v or neither"// & - " one must be present in call to continuity_PPM.") - - stencil = 3 ; if (CS%simple_2nd) stencil = 2 ; if (CS%upwind_1st) stencil = 1 + "MOM_continuity_PPM: Either both visc_rem_u and visc_rem_v or neither "// & + "one must be present in call to continuity_PPM.") if (x_first) then - ! First, advect zonally. - LB%ish = G%isc ; LB%ieh = G%iec - LB%jsh = G%jsc-stencil ; LB%jeh = G%jec+stencil - call zonal_mass_flux(u, hin, uh, dt, G, GV, US, CS, LB, OBC, & - pbv%por_face_areaU, uhbt, visc_rem_u, u_cor, BT_cont) + ! First advect zonally, with loop bounds that accomodate the subsequent meridional advection. + LB = set_continuity_loop_bounds(G, CS, i_stencil=.false., j_stencil=.true.) + call zonal_edge_thickness(hin, h_W, h_E, G, GV, US, CS, OBC, LB) + call zonal_mass_flux(u, hin, h_W, h_E, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU, & + LB, uhbt, visc_rem_u, u_cor, BT_cont, du_cor) + call continuity_zonal_convergence(h, uh, dt, G, GV, LB, hin) + + ! Now advect meridionally, using the updated thicknesses to determine the fluxes. + LB = set_continuity_loop_bounds(G, CS, i_stencil=.false., j_stencil=.false.) + call meridional_edge_thickness(h, h_S, h_N, G, GV, US, CS, OBC, LB) + call meridional_mass_flux(v, h, h_S, h_N, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV, & + LB, vhbt, visc_rem_v, v_cor, BT_cont, dv_cor) + call continuity_merdional_convergence(h, vh, dt, G, GV, LB, hmin=h_min) + + else ! .not. x_first + ! First advect meridionally, with loop bounds that accomodate the subsequent zonal advection. + LB = set_continuity_loop_bounds(G, CS, i_stencil=.true., j_stencil=.false.) + call meridional_edge_thickness(hin, h_S, h_N, G, GV, US, CS, OBC, LB) + call meridional_mass_flux(v, hin, h_S, h_N, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV, & + LB, vhbt, visc_rem_v, v_cor, BT_cont, dv_cor) + call continuity_merdional_convergence(h, vh, dt, G, GV, LB, hin) + + ! Now advect zonally, using the updated thicknesses to determine the fluxes. + LB = set_continuity_loop_bounds(G, CS, i_stencil=.false., j_stencil=.false.) + call zonal_edge_thickness(h, h_W, h_E, G, GV, US, CS, OBC, LB) + call zonal_mass_flux(u, h, h_W, h_E, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU, & + LB, uhbt, visc_rem_u, u_cor, BT_cont, du_cor) + call continuity_zonal_convergence(h, uh, dt, G, GV, LB, hmin=h_min) + endif + +end subroutine continuity_PPM + +!> Finds the thickness fluxes from the continuity solver without actually updating the +!! layer thicknesses. Because the fluxes in the two directions are calculated based on the +!! input thicknesses, which are not updated between the direcitons, the fluxes returned here +!! are not the same as those that would be returned by a call to continuity. +subroutine continuity_3d_fluxes(u, v, h, uh, vh, dt, G, GV, US, CS, OBC, pbv) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: uh !< Thickness fluxes through zonal faces, + !! u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(out) :: vh !< Thickness fluxes through meridional faces, + !! v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< Control structure for mom_continuity. + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + + ! Local variables + real :: h_W(SZI_(G),SZJ_(G),SZK_(GV)) ! West edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_E(SZI_(G),SZJ_(G),SZK_(GV)) ! East edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_S(SZI_(G),SZJ_(G),SZK_(GV)) ! South edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + real :: h_N(SZI_(G),SZJ_(G),SZK_(GV)) ! North edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + + call zonal_edge_thickness(h, h_W, h_E, G, GV, US, CS, OBC) + call zonal_mass_flux(u, h, h_W, h_E, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU) + + call meridional_edge_thickness(h, h_S, h_N, G, GV, US, CS, OBC) + call meridional_mass_flux(v, h, h_S, h_N, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV) + +end subroutine continuity_3d_fluxes + +!> Find the vertical sum of the thickness fluxes from the continuity solver without actually +!! updating the layer thicknesses. Because the fluxes in the two directions are calculated +!! based on the input thicknesses, which are not updated between the directions, the fluxes +!! returned here are not the same as those that would be returned by a call to continuity. +subroutine continuity_2d_fluxes(u, v, h, uhbt, vhbt, dt, G, GV, US, CS, OBC, pbv) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G)), & + intent(out) :: uhbt !< Vertically summed thickness flux through + !! zonal faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G)), & + intent(out) :: vhbt !< Vertically summed thickness flux through + !! meridional faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< Control structure for mom_continuity. + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + + ! Local variables + real :: h_W(SZI_(G),SZJ_(G),SZK_(GV)) ! West edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_E(SZI_(G),SZJ_(G),SZK_(GV)) ! East edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_S(SZI_(G),SZJ_(G),SZK_(GV)) ! South edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + real :: h_N(SZI_(G),SZJ_(G),SZK_(GV)) ! North edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + + call zonal_edge_thickness(h, h_W, h_E, G, GV, US, CS, OBC) + call zonal_BT_mass_flux(u, h, h_W, h_E, uhbt, dt, G, GV, US, CS, OBC, pbv%por_face_areaU) + + call meridional_edge_thickness(h, h_S, h_N, G, GV, US, CS, OBC) + call meridional_BT_mass_flux(v, h, h_S, h_N, vhbt, dt, G, GV, US, CS, OBC, pbv%por_face_areaV) + +end subroutine continuity_2d_fluxes + +!> Correct the velocities to give the specified depth-integrated transports by applying a +!! barotropic acceleration (subject to viscous drag) to the velocities. +subroutine continuity_adjust_vel(u, v, h, dt, G, GV, US, CS, OBC, pbv, uhbt, vhbt, visc_rem_u, visc_rem_v) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: u !< Zonal velocity, which will be adjusted to + !! give uhbt as the depth-integrated + !! transport [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: v !< Meridional velocity, which will be adjusted + !! to give vhbt as the depth-integrated + !! transport [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< Control structure for mom_continuity. + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + real, dimension(SZIB_(G),SZJ_(G)), & + intent(in) :: uhbt !< The vertically summed thickness flux through + !! zonal faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G)), & + intent(in) :: vhbt !< The vertically summed thickness flux through + !! meridional faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: visc_rem_u !< Both the fraction of the zonal momentum + !! that remains after a time-step of viscosity, and + !! the fraction of a time-step's worth of a barotropic + !! acceleration that a layer experiences after viscosity + !! is applied [nondim]. This goes between 0 (at the + !! bottom) and 1 (far above the bottom). When this + !! column is under an ice shelf, this also goes to 0 + !! at the top due to the no-slip boundary condition there. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + optional, intent(in) :: visc_rem_v !< Both the fraction of the meridional momentum + !! that remains after a time-step of viscosity, and + !! the fraction of a time-step's worth of a barotropic + !! acceleration that a layer experiences after viscosity + !! is applied [nondim]. This goes between 0 (at the + !! bottom) and 1 (far above the bottom). When this + !! column is under an ice shelf, this also goes to 0 + !! at the top due to the no-slip boundary condition there. + + ! Local variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: u_in !< Input zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: v_in !< Input meridional velocity [L T-1 ~> m s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uh !< Volume flux through zonal faces = + !! u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vh !< Volume flux through meridional faces = + !! v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: h_W(SZI_(G),SZJ_(G),SZK_(GV)) ! West edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_E(SZI_(G),SZJ_(G),SZK_(GV)) ! East edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_S(SZI_(G),SZJ_(G),SZK_(GV)) ! South edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + real :: h_N(SZI_(G),SZJ_(G),SZK_(GV)) ! North edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + + ! It might not be necessary to separate the input velocity array from the adjusted velocities, + ! but it seems safer to do so, even if it might be less efficient. + u_in(:,:,:) = u(:,:,:) + v_in(:,:,:) = v(:,:,:) + + call zonal_edge_thickness(h, h_W, h_E, G, GV, US, CS, OBC) + call zonal_mass_flux(u_in, h, h_W, h_E, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU, & + uhbt=uhbt, visc_rem_u=visc_rem_u, u_cor=u) + + call meridional_edge_thickness(h, h_S, h_N, G, GV, US, CS, OBC) + call meridional_mass_flux(v_in, h, h_S, h_N, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV, & + vhbt=vhbt, visc_rem_v=visc_rem_v, v_cor=v) + +end subroutine continuity_adjust_vel + + +!> Updates the thicknesses due to zonal thickness fluxes. +subroutine continuity_zonal_convergence(h, uh, dt, G, GV, LB, hin, hmin) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Final layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: uh !< Zonal thickness flux, u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1] + real, intent(in) :: dt !< Time increment [T ~> s] + type(cont_loop_bounds_type), intent(in) :: LB !< Loop bounds structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: hin !< Initial layer thickness [H ~> m or kg m-2]. + !! If hin is absent, h is also the initial thickness. + real, optional, intent(in) :: hmin !< The minimum layer thickness [H ~> m or kg m-2] + + real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. + integer :: i, j, k + + call cpu_clock_begin(id_clock_update) - call cpu_clock_begin(id_clock_update) + h_min = 0.0 ; if (present(hmin)) h_min = hmin + + if (present(hin)) then !$OMP parallel do default(shared) - do k=1,nz ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh - h(i,j,k) = hin(i,j,k) - dt * G%IareaT(i,j) * (uh(I,j,k) - uh(I-1,j,k)) - ! Uncomment this line to prevent underflow. - ! if (h(i,j,k) < h_min) h(i,j,k) = h_min + do k=1,GV%ke ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh + h(i,j,k) = max( hin(i,j,k) - dt * G%IareaT(i,j) * (uh(I,j,k) - uh(I-1,j,k)), h_min ) enddo ; enddo ; enddo - call cpu_clock_end(id_clock_update) + else + !$OMP parallel do default(shared) + do k=1,GV%ke ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh + h(i,j,k) = max( h(i,j,k) - dt * G%IareaT(i,j) * (uh(I,j,k) - uh(I-1,j,k)), h_min ) + enddo ; enddo ; enddo + endif - LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec + call cpu_clock_end(id_clock_update) + +end subroutine continuity_zonal_convergence - ! Now advect meridionally, using the updated thicknesses to determine - ! the fluxes. - call meridional_mass_flux(v, h, vh, dt, G, GV, US, CS, LB, OBC, & - pbv%por_face_areaV, vhbt, visc_rem_v, v_cor, BT_cont) +!> Updates the thicknesses due to meridional thickness fluxes. +subroutine continuity_merdional_convergence(h, vh, dt, G, GV, LB, hin, hmin) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Final layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: vh !< Meridional thickness flux, v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1] + real, intent(in) :: dt !< Time increment [T ~> s] + type(cont_loop_bounds_type), intent(in) :: LB !< Loop bounds structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: hin !< Initial layer thickness [H ~> m or kg m-2]. + !! If hin is absent, h is also the initial thickness. + real, optional, intent(in) :: hmin !< The minimum layer thickness [H ~> m or kg m-2] + + real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. + integer :: i, j, k - call cpu_clock_begin(id_clock_update) + call cpu_clock_begin(id_clock_update) + + h_min = 0.0 ; if (present(hmin)) h_min = hmin + + if (present(hin)) then + !$OMP parallel do default(shared) + do k=1,GV%ke ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh + h(i,j,k) = max( hin(i,j,k) - dt * G%IareaT(i,j) * (vh(i,J,k) - vh(i,J-1,k)), h_min ) + enddo ; enddo ; enddo + else !$OMP parallel do default(shared) - do k=1,nz ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh - h(i,j,k) = h(i,j,k) - dt * G%IareaT(i,j) * (vh(i,J,k) - vh(i,J-1,k)) - ! This line prevents underflow. - if (h(i,j,k) < h_min) h(i,j,k) = h_min + do k=1,GV%ke ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh + h(i,j,k) = max( h(i,j,k) - dt * G%IareaT(i,j) * (vh(i,J,k) - vh(i,J-1,k)), h_min ) enddo ; enddo ; enddo - call cpu_clock_end(id_clock_update) + endif - else ! .not. x_first - ! First, advect meridionally, so set the loop bounds accordingly. - LB%ish = G%isc-stencil ; LB%ieh = G%iec+stencil - LB%jsh = G%jsc ; LB%jeh = G%jec + call cpu_clock_end(id_clock_update) + +end subroutine continuity_merdional_convergence + + +!> Set the reconstructed thicknesses at the eastern and western edges of tracer cells. +subroutine zonal_edge_thickness(h_in, h_W, h_E, G, GV, US, CS, OBC, LB_in) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_in !< Tracer cell layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h_W !< Western edge layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h_E !< Eastern edge layer thickness [H ~> m or kg m-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure. + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + type(cont_loop_bounds_type), & + optional, intent(in) :: LB_in !< Loop bounds structure. - call meridional_mass_flux(v, hin, vh, dt, G, GV, US, CS, LB, OBC, & - pbv%por_face_areaV, vhbt, visc_rem_v, v_cor, BT_cont) + ! Local variables + type(cont_loop_bounds_type) :: LB + integer :: i, j, k, ish, ieh, jsh, jeh, nz + + call cpu_clock_begin(id_clock_reconstruct) + + if (present(LB_in)) then + LB = LB_in + else + LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec + endif + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke - call cpu_clock_begin(id_clock_update) + if (CS%upwind_1st) then !$OMP parallel do default(shared) - do k=1,nz ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh - h(i,j,k) = hin(i,j,k) - dt * G%IareaT(i,j) * (vh(i,J,k) - vh(i,J-1,k)) + do k=1,nz ; do j=jsh,jeh ; do i=ish-1,ieh+1 + h_W(i,j,k) = h_in(i,j,k) ; h_E(i,j,k) = h_in(i,j,k) enddo ; enddo ; enddo - call cpu_clock_end(id_clock_update) + else + !$OMP parallel do default(shared) + do k=1,nz + call PPM_reconstruction_x(h_in(:,:,k), h_W(:,:,k), h_E(:,:,k), G, LB, & + 2.0*GV%Angstrom_H, CS%monotonic, CS%simple_2nd, OBC, k) + enddo + endif + + call cpu_clock_end(id_clock_reconstruct) + +end subroutine zonal_edge_thickness + + +!> Set the reconstructed thicknesses at the eastern and western edges of tracer cells. +subroutine meridional_edge_thickness(h_in, h_S, h_N, G, GV, US, CS, OBC, LB_in) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_in !< Tracer cell layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h_S !< Southern edge layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h_N !< Northern edge layer thickness [H ~> m or kg m-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure. + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + type(cont_loop_bounds_type), & + optional, intent(in) :: LB_in !< Loop bounds structure. - ! Now advect zonally, using the updated thicknesses to determine - ! the fluxes. + ! Local variables + type(cont_loop_bounds_type) :: LB + integer :: i, j, k, ish, ieh, jsh, jeh, nz + + call cpu_clock_begin(id_clock_reconstruct) + + if (present(LB_in)) then + LB = LB_in + else LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec - call zonal_mass_flux(u, h, uh, dt, G, GV, US, CS, LB, OBC, & - pbv%por_face_areaU, uhbt, visc_rem_u, u_cor, BT_cont) + endif + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke - call cpu_clock_begin(id_clock_update) + if (CS%upwind_1st) then !$OMP parallel do default(shared) - do k=1,nz ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh - h(i,j,k) = h(i,j,k) - dt * G%IareaT(i,j) * (uh(I,j,k) - uh(I-1,j,k)) - ! This line prevents underflow. - if (h(i,j,k) < h_min) h(i,j,k) = h_min + do k=1,nz ; do j=jsh-1,jeh+1 ; do i=ish,ieh + h_S(i,j,k) = h_in(i,j,k) ; h_N(i,j,k) = h_in(i,j,k) enddo ; enddo ; enddo - call cpu_clock_end(id_clock_update) - + else + !$OMP parallel do default(shared) + do k=1,nz + call PPM_reconstruction_y(h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), G, LB, & + 2.0*GV%Angstrom_H, CS%monotonic, CS%simple_2nd, OBC, k) + enddo endif -end subroutine continuity_PPM + call cpu_clock_end(id_clock_reconstruct) + +end subroutine meridional_edge_thickness + !> Calculates the mass or volume fluxes through the zonal faces, and other related quantities. -subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, OBC, por_face_areaU, uhbt, & - visc_rem_u, u_cor, BT_cont) - type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. +subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_face_areaU, & + LB_in, uhbt, visc_rem_u, u_cor, BT_cont, du_cor) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h_in !< Layer thickness used to calculate fluxes [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_W !< Western edge thicknesses [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_E !< Eastern edge thicknesses [H ~> m or kg m-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(out) :: uh !< Volume flux through zonal faces = u*h*dy !! [H L2 T-1 ~> m3 s-1 or kg s-1]. real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure. - type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. real, dimension(SZIB_(G), SZJ_(G), SZK_(G)), & intent(in) :: por_face_areaU !< fractional open area of U-faces [nondim] + type(cont_loop_bounds_type), & + optional, intent(in) :: LB_in !< Loop bounds structure. real, dimension(SZIB_(G),SZJ_(G)), & optional, intent(in) :: uhbt !< The summed volume flux through zonal faces !! [H L2 T-1 ~> m3 s-1 or kg s-1]. @@ -240,105 +556,99 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, OBC, por_face_are real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & optional, intent(out) :: u_cor !< The zonal velocities (u with a barotropic correction) - !! that give uhbt as the depth-integrated transport, m s-1. + !! that give uhbt as the depth-integrated transport [L T-1 ~> m s-1] type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe the !! effective open face areas as a function of barotropic flow. + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(out) :: du_cor !< The zonal velocity increments from u that give uhbt + !! as the depth-integrated transports [L T-1 ~> m s-1]. ! Local variables real, dimension(SZIB_(G),SZK_(GV)) :: duhdu ! Partial derivative of uh with u [H L ~> m2 or kg m-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_L, h_R ! Left and right face thicknesses [H ~> m or kg m-2]. real, dimension(SZIB_(G)) :: & - du, & ! Corrective barotropic change in the velocity [L T-1 ~> m s-1]. - du_min_CFL, & ! Min/max limits on du correction - du_max_CFL, & ! to avoid CFL violations [L T-1 ~> m s-1] + du, & ! Corrective barotropic change in the velocity to give uhbt [L T-1 ~> m s-1]. + du_min_CFL, & ! Lower limit on du correction to avoid CFL violations [L T-1 ~> m s-1] + du_max_CFL, & ! Upper limit on du correction to avoid CFL violations [L T-1 ~> m s-1] duhdu_tot_0, & ! Summed partial derivative of uh with u [H L ~> m2 or kg m-1]. - uh_tot_0, & ! Summed transport with no barotropic correction [H L2 T-1 ~> m3 s-1 or kg s-1]. + uh_tot_0, & ! Summed transport with no barotropic correction [H L2 T-1 ~> m3 s-1 or kg s-1]. visc_rem_max ! The column maximum of visc_rem [nondim]. logical, dimension(SZIB_(G)) :: do_I real, dimension(SZIB_(G),SZK_(GV)) :: & visc_rem ! A 2-D copy of visc_rem_u or an array of 1's [nondim]. real, dimension(SZIB_(G)) :: FAuI ! A list of sums of zonal face areas [H L ~> m2 or kg m-1]. real :: FA_u ! A sum of zonal face areas [H L ~> m2 or kg m-1]. - real :: I_vrm ! 1.0 / visc_rem_max, nondim. + real :: I_vrm ! 1.0 / visc_rem_max [nondim] real :: CFL_dt ! The maximum CFL ratio of the adjusted velocities divided by ! the time step [T-1 ~> s-1]. real :: I_dt ! 1.0 / dt [T-1 ~> s-1]. real :: du_lim ! The velocity change that give a relative CFL of 1 [L T-1 ~> m s-1]. real :: dx_E, dx_W ! Effective x-grid spacings to the east and west [L ~> m]. + type(cont_loop_bounds_type) :: LB integer :: i, j, k, ish, ieh, jsh, jeh, n, nz - integer :: l_seg - logical :: local_specified_BC, use_visc_rem, set_BT_cont, any_simple_OBC - logical :: local_Flather_OBC, local_open_BC, is_simple - type(OBC_segment_type), pointer :: segment => NULL() + integer :: l_seg ! The OBC segment number + logical :: use_visc_rem, set_BT_cont + logical :: local_specified_BC, local_Flather_OBC, local_open_BC, any_simple_OBC ! OBC-related logicals + logical :: simple_OBC_pt(SZIB_(G)) ! Indicates points in a row with specified transport OBCs + + call cpu_clock_begin(id_clock_correct) use_visc_rem = present(visc_rem_u) - local_specified_BC = .false. ; set_BT_cont = .false. ; local_Flather_OBC = .false. - local_open_BC = .false. - if (present(BT_cont)) set_BT_cont = (associated(BT_cont)) + + set_BT_cont = .false. ; if (present(BT_cont)) set_BT_cont = (associated(BT_cont)) + + local_specified_BC = .false. ; local_Flather_OBC = .false. ; local_open_BC = .false. if (associated(OBC)) then ; if (OBC%OBC_pe) then local_specified_BC = OBC%specified_u_BCs_exist_globally local_Flather_OBC = OBC%Flather_u_BCs_exist_globally local_open_BC = OBC%open_u_BCs_exist_globally endif ; endif + + if (present(du_cor)) du_cor(:,:) = 0.0 + + if (present(LB_in)) then + LB = LB_in + else + LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec + endif ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke CFL_dt = CS%CFL_limit_adjust / dt I_dt = 1.0 / dt if (CS%aggress_adjust) CFL_dt = I_dt - call cpu_clock_begin(id_clock_update) -!$OMP parallel do default(none) shared(ish,ieh,jsh,jeh,nz,CS,h_L,h_in,h_R,G,GV,LB,visc_rem,OBC) - do k=1,nz - ! This sets h_L and h_R. - if (CS%upwind_1st) then - do j=jsh,jeh ; do i=ish-1,ieh+1 - h_L(i,j,k) = h_in(i,j,k) ; h_R(i,j,k) = h_in(i,j,k) - enddo ; enddo - else - call PPM_reconstruction_x(h_in(:,:,k), h_L(:,:,k), h_R(:,:,k), G, LB, & - 2.0*GV%Angstrom_H, CS%monotonic, CS%simple_2nd, OBC) - endif - do I=ish-1,ieh ; visc_rem(I,k) = 1.0 ; enddo - enddo - call cpu_clock_end(id_clock_update) - - call cpu_clock_begin(id_clock_correct) -!$OMP parallel do default(none) shared(ish,ieh,jsh,jeh,nz,u,h_in,h_L,h_R,use_visc_rem,visc_rem_u, & -!$OMP uh,dt,US,G,GV,CS,local_specified_BC,OBC,uhbt,set_BT_cont, & -!$OMP CFL_dt,I_dt,u_cor,BT_cont, local_Flather_OBC, & -!$OMP por_face_areaU) & -!$OMP private(do_I,duhdu,du,du_max_CFL,du_min_CFL,uh_tot_0,duhdu_tot_0, & -!$OMP is_simple,FAuI,visc_rem_max,I_vrm,du_lim,dx_E,dx_W, & -!$OMP any_simple_OBC,l_seg) & -!$OMP firstprivate(visc_rem) + if (.not.use_visc_rem) visc_rem(:,:) = 1.0 + !$OMP parallel do default(shared) private(do_I,duhdu,du,du_max_CFL,du_min_CFL,uh_tot_0, & + !$OMP duhdu_tot_0,FAuI,visc_rem_max,I_vrm,du_lim,dx_E,dx_W, & + !$OMP simple_OBC_pt,any_simple_OBC,l_seg) & + !$OMP firstprivate(visc_rem) do j=jsh,jeh - do I=ish-1,ieh ; do_I(I) = .true. ; visc_rem_max(I) = 0.0 ; enddo + do I=ish-1,ieh ; do_I(I) = .true. ; enddo ! Set uh and duhdu. do k=1,nz if (use_visc_rem) then ; do I=ish-1,ieh visc_rem(I,k) = visc_rem_u(I,j,k) - visc_rem_max(I) = max(visc_rem_max(I), visc_rem(I,k)) enddo ; endif - call zonal_flux_layer(u(:,j,k), h_in(:,j,k), h_L(:,j,k), h_R(:,j,k), & + call zonal_flux_layer(u(:,j,k), h_in(:,j,k), h_W(:,j,k), h_E(:,j,k), & uh(:,j,k), duhdu(:,k), visc_rem(:,k), & - dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k), OBC) + dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k), & + CS%h_marg_min, OBC) if (local_specified_BC) then - do I=ish-1,ieh - l_seg = OBC%segnum_u(I,j) - - if (l_seg /= OBC_NONE) then - if (OBC%segment(l_seg)%specified) & - uh(I,j,k) = OBC%segment(l_seg)%normal_trans(I,j,k) - endif - enddo + do I=ish-1,ieh ; if (OBC%segnum_u(I,j) /= 0) then + l_seg = abs(OBC%segnum_u(I,j)) + if (OBC%segment(l_seg)%specified) uh(I,j,k) = OBC%segment(l_seg)%normal_trans(I,j,k) + endif ; enddo endif enddo - if ((.not.use_visc_rem).or.(.not.CS%use_visc_rem_max)) then ; do I=ish-1,ieh - visc_rem_max(I) = 1.0 - enddo ; endif - if (present(uhbt) .or. set_BT_cont) then + if (use_visc_rem .and. CS%use_visc_rem_max) then + visc_rem_max(:) = 0.0 + do k=1,nz ; do I=ish-1,ieh + visc_rem_max(I) = max(visc_rem_max(I), visc_rem(I,k)) + enddo ; enddo + else + visc_rem_max(:) = 1.0 + endif ! Set limits on du that will keep the CFL number between -1 and 1. ! This should be adequate to keep the root bracketed in all cases. do I=ish-1,ieh @@ -379,9 +689,9 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, OBC, por_face_are dx_E = ratio_max(G%areaT(i+1,j), G%dy_Cu(I,j), 1000.0*G%dxT(i+1,j)) else ; dx_W = G%dxT(i,j) ; dx_E = G%dxT(i+1,j) ; endif - if (du_max_CFL(I) * visc_rem(I,k) > dx_W*CFL_dt - u(I,j,k)) & + if (du_max_CFL(I) * visc_rem(I,k) > dx_W*CFL_dt - u(I,j,k)*G%mask2dCu(I,j)) & du_max_CFL(I) = (dx_W*CFL_dt - u(I,j,k)) / visc_rem(I,k) - if (du_min_CFL(I) * visc_rem(I,k) < -dx_E*CFL_dt - u(I,j,k)) & + if (du_min_CFL(I) * visc_rem(I,k) < -dx_E*CFL_dt - u(I,j,k)*G%mask2dCu(I,j)) & du_min_CFL(I) = -(dx_E*CFL_dt + u(I,j,k)) / visc_rem(I,k) enddo ; enddo endif @@ -418,60 +728,52 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, OBC, por_face_are any_simple_OBC = .false. if (present(uhbt) .or. set_BT_cont) then if (local_specified_BC .or. local_Flather_OBC) then ; do I=ish-1,ieh - l_seg = OBC%segnum_u(I,j) + l_seg = abs(OBC%segnum_u(I,j)) ! Avoid reconciling barotropic/baroclinic transports if transport is specified - is_simple = .false. - if (l_seg /= OBC_NONE) & - is_simple = OBC%segment(l_seg)%specified - do_I(I) = .not. (l_seg /= OBC_NONE .and. is_simple) - any_simple_OBC = any_simple_OBC .or. is_simple + simple_OBC_pt(I) = .false. + if (l_seg /= OBC_NONE) simple_OBC_pt(I) = OBC%segment(l_seg)%specified + do_I(I) = .not.simple_OBC_pt(I) + any_simple_OBC = any_simple_OBC .or. simple_OBC_pt(I) enddo ; else ; do I=ish-1,ieh do_I(I) = .true. enddo ; endif endif if (present(uhbt)) then - call zonal_flux_adjust(u, h_in, h_L, h_R, uhbt(:,j), uh_tot_0, duhdu_tot_0, du, & + ! Find du and uh. + call zonal_flux_adjust(u, h_in, h_W, h_E, uhbt(:,j), uh_tot_0, duhdu_tot_0, du, & du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & j, ish, ieh, do_I, por_face_areaU, uh, OBC=OBC) if (present(u_cor)) then ; do k=1,nz do I=ish-1,ieh ; u_cor(I,j,k) = u(I,j,k) + du(I) * visc_rem(I,k) ; enddo - if (local_specified_BC) then ; do I=ish-1,ieh - l_seg = OBC%segnum_u(I,j) - - if (l_seg /= OBC_NONE) then - if (OBC%segment(l_seg)%specified) & - u_cor(I,j,k) = OBC%segment(l_seg)%normal_vel(I,j,k) - endif - enddo ; endif + if (any_simple_OBC) then ; do I=ish-1,ieh ; if (simple_OBC_pt(I)) then + u_cor(I,j,k) = OBC%segment(abs(OBC%segnum_u(I,j)))%normal_vel(I,j,k) + endif ; enddo ; endif enddo ; endif ! u-corrected + if (present(du_cor)) then + do I=ish-1,ieh ; du_cor(I,j) = du(I) ; enddo + endif + endif if (set_BT_cont) then - call set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0,& + call set_zonal_BT_cont(u, h_in, h_W, h_E, BT_cont, uh_tot_0, duhdu_tot_0,& du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & visc_rem_max, j, ish, ieh, do_I, por_face_areaU) if (any_simple_OBC) then do I=ish-1,ieh - l_seg = OBC%segnum_u(I,j) - - do_I(I) = .false. - if (l_seg /= OBC_NONE) & - do_I(I) = OBC%segment(l_seg)%specified - - if (do_I(I)) FAuI(I) = GV%H_subroundoff*G%dy_Cu(I,j) + if (simple_OBC_pt(I)) FAuI(I) = GV%H_subroundoff*G%dy_Cu(I,j) enddo - ! NOTE: do_I(I) should prevent access to segment OBC_NONE - do k=1,nz ; do I=ish-1,ieh ; if (do_I(I)) then - if ((abs(OBC%segment(OBC%segnum_u(I,j))%normal_vel(I,j,k)) > 0.0) .and. & - (OBC%segment(OBC%segnum_u(I,j))%specified)) & - FAuI(I) = FAuI(I) + OBC%segment(OBC%segnum_u(I,j))%normal_trans(I,j,k) / & - OBC%segment(OBC%segnum_u(I,j))%normal_vel(I,j,k) + ! NOTE: simple_OBC_pt(I) should prevent access to segment OBC_NONE + do k=1,nz ; do I=ish-1,ieh ; if (simple_OBC_pt(I)) then + l_seg = abs(OBC%segnum_u(I,j)) + if ((abs(OBC%segment(l_seg)%normal_vel(I,j,k)) > 0.0) .and. (OBC%segment(l_seg)%specified)) & + FAuI(I) = FAuI(I) + OBC%segment(l_seg)%normal_trans(I,j,k) / OBC%segment(l_seg)%normal_vel(I,j,k) endif ; enddo ; enddo - do I=ish-1,ieh ; if (do_I(I)) then + do I=ish-1,ieh ; if (simple_OBC_pt(I)) then BT_cont%FA_u_W0(I,j) = FAuI(I) ; BT_cont%FA_u_E0(I,j) = FAuI(I) BT_cont%FA_u_WW(I,j) = FAuI(I) ; BT_cont%FA_u_EE(I,j) = FAuI(I) BT_cont%uBT_WW(I,j) = 0.0 ; BT_cont%uBT_EE(I,j) = 0.0 @@ -507,24 +809,100 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, OBC, por_face_are endif enddo endif - call cpu_clock_end(id_clock_correct) if (set_BT_cont) then ; if (allocated(BT_cont%h_u)) then if (present(u_cor)) then - call zonal_face_thickness(u_cor, h_in, h_L, h_R, BT_cont%h_u, dt, G, GV, US, LB, & + 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_face_thickness(u, h_in, h_L, h_R, BT_cont%h_u, dt, G, GV, US, LB, & + 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 + call cpu_clock_end(id_clock_correct) + end subroutine zonal_mass_flux + +!> Calculates the vertically integrated mass or volume fluxes through the zonal faces. +subroutine zonal_BT_mass_flux(u, h_in, h_W, h_E, uhbt, dt, G, GV, US, CS, OBC, por_face_areaU, LB_in) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to + !! calculate fluxes [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_W !< Western edge thickness in the PPM + !! reconstruction [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_E !< Eastern edge thickness in the PPM + !! reconstruction [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G)), intent(out) :: uhbt !< The summed volume flux through zonal + !! faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure.G + type(ocean_OBC_type), pointer :: OBC !< Open boundary condition type + !! specifies whether, where, and what + !! open boundary conditions are used. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: por_face_areaU !< fractional open area of U-faces [nondim] + type(cont_loop_bounds_type), optional, intent(in) :: LB_in !< Loop bounds structure. + + ! Local variables + real :: uh(SZIB_(G)) ! Volume flux through zonal faces = u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: duhdu(SZIB_(G)) ! Partial derivative of uh with u [H L ~> m2 or kg m-1]. + logical, dimension(SZIB_(G)) :: do_I + real :: ones(SZIB_(G)) ! An array of 1's [nondim] + integer :: i, j, k, ish, ieh, jsh, jeh, nz, l_seg + logical :: local_specified_BC, OBC_in_row + + call cpu_clock_begin(id_clock_correct) + + local_specified_BC = .false. + if (associated(OBC)) then ; if (OBC%OBC_pe) then + local_specified_BC = OBC%specified_v_BCs_exist_globally + endif ; endif + + if (present(LB_in)) then + ish = LB_in%ish ; ieh = LB_in%ieh ; jsh = LB_in%jsh ; jeh = LB_in%jeh ; nz = GV%ke + else + ish = G%isc ; ieh = G%iec ; jsh = G%jsc ; jeh = G%jec ; nz = GV%ke + endif + + ones(:) = 1.0 ; do_I(:) = .true. + + uhbt(:,:) = 0.0 + !$OMP parallel do default(shared) private(uh,duhdu,OBC_in_row) + do j=jsh,jeh + ! Determining whether there are any OBC points outside of the k-loop should be more efficient. + OBC_in_row = .false. + if (local_specified_BC) then ; do I=ish-1,ieh ; if (OBC%segnum_u(I,j) /= 0) then + if (OBC%segment(abs(OBC%segnum_u(I,j)))%specified) OBC_in_row = .true. + endif ; enddo ; endif + do k=1,nz + ! This sets uh and duhdu. + call zonal_flux_layer(u(:,j,k), h_in(:,j,k), h_W(:,j,k), h_E(:,j,k), uh, duhdu, ones, & + dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k), & + CS%h_marg_min, OBC) + if (OBC_in_row) then ; do I=ish-1,ieh ; if (OBC%segnum_u(I,j) /= 0) then + l_seg = abs(OBC%segnum_u(I,j)) + if (OBC%segment(l_seg)%specified) uh(I) = OBC%segment(l_seg)%normal_trans(I,j,k) + endif ; enddo ; endif + + ! Accumulate the barotropic transport. + do I=ish-1,ieh + uhbt(I,j) = uhbt(I,j) + uh(I) + enddo + enddo ! k-loop + enddo ! j-loop + call cpu_clock_end(id_clock_correct) + +end subroutine zonal_BT_mass_flux + + !> Evaluates the zonal mass or volume fluxes in a layer. -subroutine zonal_flux_layer(u, h, h_L, h_R, uh, duhdu, visc_rem, dt, G, US, j, & - ish, ieh, do_I, vol_CFL, por_face_areaU, OBC) - type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. +subroutine zonal_flux_layer(u, h, h_W, h_E, uh, duhdu, visc_rem, dt, G, US, j, & + ish, ieh, do_I, vol_CFL, por_face_areaU, h_marg_min, OBC) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. real, dimension(SZIB_(G)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. real, dimension(SZIB_(G)), intent(in) :: visc_rem !< Both the fraction of the !! momentum originally in a layer that remains after a time-step @@ -532,13 +910,13 @@ subroutine zonal_flux_layer(u, h, h_L, h_R, uh, duhdu, visc_rem, dt, G, US, j, & !! acceleration that a layer experiences after viscosity is applied [nondim]. !! Visc_rem is between 0 (at the bottom) and 1 (far above the bottom). real, dimension(SZI_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. - real, dimension(SZI_(G)), intent(in) :: h_L !< Left thickness [H ~> m or kg m-2]. - real, dimension(SZI_(G)), intent(in) :: h_R !< Right thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(in) :: h_W !< West edge thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(in) :: h_E !< East edge thickness [H ~> m or kg m-2]. real, dimension(SZIB_(G)), intent(inout) :: uh !< Zonal mass or volume !! transport [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIB_(G)), intent(inout) :: duhdu !< Partial derivative of uh !! with u [H L ~> m2 or kg m-1]. - real, intent(in) :: dt !< Time increment [T ~> s]. + real, intent(in) :: dt !< Time increment [T ~> s] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: j !< Spatial index. integer, intent(in) :: ish !< Start of index range. @@ -547,14 +925,13 @@ subroutine zonal_flux_layer(u, h, h_L, h_R, uh, duhdu, visc_rem, dt, G, US, j, & logical, intent(in) :: vol_CFL !< If true, rescale the real, dimension(SZIB_(G)), intent(in) :: por_face_areaU !< fractional open area of U-faces [nondim] !! ratio of face areas to the cell areas when estimating the CFL number. + real, intent(in) :: h_marg_min !< Negligible floor on h_marg [H ~> m or kg m-2] type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim] - real :: curv_3 ! A measure of the thickness curvature over a grid length, - ! with the same units as h_in. + real :: curv_3 ! A measure of the thickness curvature over a grid length [H ~> m or kg m-2] real :: h_marg ! The marginal thickness of a flux [H ~> m or kg m-2]. integer :: i - integer :: l_seg logical :: local_open_BC local_open_BC = .false. @@ -567,59 +944,60 @@ subroutine zonal_flux_layer(u, h, h_L, h_R, uh, duhdu, visc_rem, dt, G, US, j, & if (u(I) > 0.0) then if (vol_CFL) then ; CFL = (u(I) * dt) * (G%dy_Cu(I,j) * G%IareaT(i,j)) else ; CFL = u(I) * dt * G%IdxT(i,j) ; endif - curv_3 = h_L(i) + h_R(i) - 2.0*h(i) + curv_3 = (h_W(i) + h_E(i)) - 2.0*h(i) uh(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * u(I) * & - (h_R(i) + CFL * (0.5*(h_L(i) - h_R(i)) + curv_3*(CFL - 1.5))) - h_marg = h_R(i) + CFL * ((h_L(i) - h_R(i)) + 3.0*curv_3*(CFL - 1.0)) + (h_E(i) + CFL * (0.5*(h_W(i) - h_E(i)) + curv_3*(CFL - 1.5))) + h_marg = h_E(i) + CFL * ((h_W(i) - h_E(i)) + 3.0*curv_3*(CFL - 1.0)) elseif (u(I) < 0.0) then if (vol_CFL) then ; CFL = (-u(I) * dt) * (G%dy_Cu(I,j) * G%IareaT(i+1,j)) else ; CFL = -u(I) * dt * G%IdxT(i+1,j) ; endif - curv_3 = h_L(i+1) + h_R(i+1) - 2.0*h(i+1) + curv_3 = (h_W(i+1) + h_E(i+1)) - 2.0*h(i+1) uh(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * u(I) * & - (h_L(i+1) + CFL * (0.5*(h_R(i+1)-h_L(i+1)) + curv_3*(CFL - 1.5))) - h_marg = h_L(i+1) + CFL * ((h_R(i+1)-h_L(i+1)) + 3.0*curv_3*(CFL - 1.0)) + (h_W(i+1) + CFL * (0.5*(h_E(i+1)-h_W(i+1)) + curv_3*(CFL - 1.5))) + h_marg = h_W(i+1) + CFL * ((h_E(i+1)-h_W(i+1)) + 3.0*curv_3*(CFL - 1.0)) else uh(I) = 0.0 - h_marg = 0.5 * (h_L(i+1) + h_R(i)) + h_marg = 0.5 * (h_W(i+1) + h_E(i)) endif + h_marg = max(h_marg, h_marg_min) duhdu(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * h_marg * visc_rem(I) endif ; enddo if (local_open_BC) then - do I=ish-1,ieh ; if (do_I(I)) then - l_seg = OBC%segnum_u(I,j) - - if (l_seg /= OBC_NONE) then - if (OBC%segment(l_seg)%open) then - if (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then - uh(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * u(I) * h(i) - duhdu(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * h(i) * visc_rem(I) - else - uh(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * u(I) * h(i+1) - duhdu(I) = (G%dy_Cu(I,j)* por_face_areaU(I)) * h(i+1) * visc_rem(I) - endif + do I=ish-1,ieh ; if (do_I(I)) then ; if (OBC%segnum_u(I,j) /= 0) then + if (OBC%segment(abs(OBC%segnum_u(I,j)))%open) then + if (OBC%segnum_u(I,j) > 0) then ! OBC_DIRECTION_E + uh(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * u(I) * h(i) + duhdu(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * max(h(i), h_marg_min) * visc_rem(I) + else ! OBC_DIRECTION_W + uh(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * u(I) * h(i+1) + duhdu(I) = (G%dy_Cu(I,j)* por_face_areaU(I)) * max(h(i+1), h_marg_min) * visc_rem(I) endif endif - endif ; enddo + endif ; endif ; enddo endif end subroutine zonal_flux_layer -!> Sets the effective interface thickness at each zonal velocity point. -subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt, G, GV, US, LB, vol_CFL, & +!> Sets the effective interface thickness associated with the fluxes at each zonal velocity point, +!! optionally scaling back these thicknesses to account for viscosity and fractional open areas. +subroutine zonal_flux_thickness(u, h, h_W, h_E, h_u, dt, G, GV, US, LB, vol_CFL, & marginal, OBC, por_face_areaU, visc_rem_u) - type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness used to !! calculate fluxes [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_L !< Left thickness in the + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_W !< West edge thickness in the !! reconstruction [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_R !< Right thickness in the + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_E !< East edge thickness in the !! reconstruction [H ~> m or kg m-2]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h_u !< Thickness at zonal faces [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h_u !< Effective thickness at zonal faces, + !! scaled down to account for the effects of + !! viscosity and the fractional open area + !! [H ~> m or kg m-2]. real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. + type(cont_loop_bounds_type), intent(in) :: LB !< Loop bounds structure. logical, intent(in) :: vol_CFL !< If true, rescale the ratio !! of face areas to the cell areas when estimating the CFL number. logical, intent(in) :: marginal !< If true, report the @@ -636,8 +1014,7 @@ subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt, G, GV, US, LB, vol_CFL, ! Local variables real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim] - real :: curv_3 ! A measure of the thickness curvature over a grid length, - ! with the same units as h_in. + real :: curv_3 ! A measure of the thickness curvature over a grid length [H ~> m or kg m-2] real :: h_avg ! The average thickness of a flux [H ~> m or kg m-2]. real :: h_marg ! The marginal thickness of a flux [H ~> m or kg m-2]. logical :: local_open_BC @@ -649,34 +1026,40 @@ subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt, G, GV, US, LB, vol_CFL, if (u(I,j,k) > 0.0) then if (vol_CFL) then ; CFL = (u(I,j,k) * dt) * (G%dy_Cu(I,j) * G%IareaT(i,j)) else ; CFL = u(I,j,k) * dt * G%IdxT(i,j) ; endif - curv_3 = h_L(i,j,k) + h_R(i,j,k) - 2.0*h(i,j,k) - h_avg = h_R(i,j,k) + CFL * (0.5*(h_L(i,j,k) - h_R(i,j,k)) + curv_3*(CFL - 1.5)) - h_marg = h_R(i,j,k) + CFL * ((h_L(i,j,k) - h_R(i,j,k)) + 3.0*curv_3*(CFL - 1.0)) + curv_3 = (h_W(i,j,k) + h_E(i,j,k)) - 2.0*h(i,j,k) + h_avg = h_E(i,j,k) + CFL * (0.5*(h_W(i,j,k) - h_E(i,j,k)) + curv_3*(CFL - 1.5)) + h_marg = h_E(i,j,k) + CFL * ((h_W(i,j,k) - h_E(i,j,k)) + 3.0*curv_3*(CFL - 1.0)) elseif (u(I,j,k) < 0.0) then if (vol_CFL) then ; CFL = (-u(I,j,k)*dt) * (G%dy_Cu(I,j) * G%IareaT(i+1,j)) else ; CFL = -u(I,j,k) * dt * G%IdxT(i+1,j) ; endif - curv_3 = h_L(i+1,j,k) + h_R(i+1,j,k) - 2.0*h(i+1,j,k) - h_avg = h_L(i+1,j,k) + CFL * (0.5*(h_R(i+1,j,k)-h_L(i+1,j,k)) + curv_3*(CFL - 1.5)) - h_marg = h_L(i+1,j,k) + CFL * ((h_R(i+1,j,k)-h_L(i+1,j,k)) + & + curv_3 = (h_W(i+1,j,k) + h_E(i+1,j,k)) - 2.0*h(i+1,j,k) + h_avg = h_W(i+1,j,k) + CFL * (0.5*(h_E(i+1,j,k)-h_W(i+1,j,k)) + curv_3*(CFL - 1.5)) + h_marg = h_W(i+1,j,k) + CFL * ((h_E(i+1,j,k)-h_W(i+1,j,k)) + & 3.0*curv_3*(CFL - 1.0)) else - h_avg = 0.5 * (h_L(i+1,j,k) + h_R(i,j,k)) + h_avg = 0.5 * (h_W(i+1,j,k) + h_E(i,j,k)) ! The choice to use the arithmetic mean here is somewhat arbitrarily, but - ! it should be noted that h_L(i+1,j,k) and h_R(i,j,k) are usually the same. - h_marg = 0.5 * (h_L(i+1,j,k) + h_R(i,j,k)) - ! h_marg = (2.0 * h_L(i+1,j,k) * h_R(i,j,k)) / & - ! (h_L(i+1,j,k) + h_R(i,j,k) + GV%H_subroundoff) + ! it should be noted that h_W(i+1,j,k) and h_E(i,j,k) are usually the same. + h_marg = 0.5 * (h_W(i+1,j,k) + h_E(i,j,k)) + ! h_marg = (2.0 * h_W(i+1,j,k) * h_E(i,j,k)) / & + ! (h_W(i+1,j,k) + h_E(i,j,k) + GV%H_subroundoff) endif if (marginal) then ; h_u(I,j,k) = h_marg else ; h_u(I,j,k) = h_avg ; endif enddo ; enddo ; enddo if (present(visc_rem_u)) then - !### The expression setting h_u should also be multiplied by por_face_areaU in this case, - ! and in the two OBC cases below with visc_rem_u. + ! Scale back the thickness to account for the effects of viscosity and the fractional open + ! thickness to give an appropriate non-normalized weight for each layer in determining the + ! barotropic acceleration. !$OMP parallel do default(shared) do k=1,nz ; do j=jsh,jeh ; do I=ish-1,ieh - h_u(I,j,k) = h_u(I,j,k) * visc_rem_u(I,j,k) !### * por_face_areaU(I,j,k) + h_u(I,j,k) = h_u(I,j,k) * (visc_rem_u(I,j,k) * por_face_areaU(I,j,k)) + enddo ; enddo ; enddo + else + !$OMP parallel do default(shared) + do k=1,nz ; do j=jsh,jeh ; do I=ish-1,ieh + h_u(I,j,k) = h_u(I,j,k) * por_face_areaU(I,j,k) enddo ; enddo ; enddo endif @@ -689,21 +1072,21 @@ subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt, G, GV, US, LB, vol_CFL, if (OBC%segment(n)%direction == OBC_DIRECTION_E) then if (present(visc_rem_u)) then ; do k=1,nz do j = OBC%segment(n)%HI%jsd, OBC%segment(n)%HI%jed - h_u(I,j,k) = h(i,j,k) * visc_rem_u(I,j,k) !### * por_face_areaU(I,j,k) + h_u(I,j,k) = h(i,j,k) * (visc_rem_u(I,j,k) * por_face_areaU(I,j,k)) enddo enddo ; else ; do k=1,nz do j = OBC%segment(n)%HI%jsd, OBC%segment(n)%HI%jed - h_u(I,j,k) = h(i,j,k) + h_u(I,j,k) = h(i,j,k) * por_face_areaU(I,j,k) enddo enddo ; endif else if (present(visc_rem_u)) then ; do k=1,nz do j = OBC%segment(n)%HI%jsd, OBC%segment(n)%HI%jed - h_u(I,j,k) = h(i+1,j,k) * visc_rem_u(I,j,k) !### * por_face_areaU(I,j,k) + h_u(I,j,k) = h(i+1,j,k) * (visc_rem_u(I,j,k) * por_face_areaU(I,j,k)) enddo enddo ; else ; do k=1,nz do j = OBC%segment(n)%HI%jsd, OBC%segment(n)%HI%jed - h_u(I,j,k) = h(i+1,j,k) + h_u(I,j,k) = h(i+1,j,k) * por_face_areaU(I,j,k) enddo enddo ; endif endif @@ -711,29 +1094,29 @@ subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt, G, GV, US, LB, vol_CFL, enddo endif -end subroutine zonal_face_thickness +end subroutine zonal_flux_thickness !> Returns the barotropic velocity adjustment that gives the !! desired barotropic (layer-summed) transport. -subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & +subroutine zonal_flux_adjust(u, h_in, h_W, h_E, uhbt, uh_tot_0, duhdu_tot_0, & du, du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & j, ish, ieh, do_I_in, por_face_areaU, uh_3d, OBC) - type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to !! calculate fluxes [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_L !< Left thickness in the + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_W !< West edge thickness in the !! reconstruction [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_R !< Right thickness in the + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_E !< East edge thickness in the !! reconstruction [H ~> m or kg m-2]. real, dimension(SZIB_(G),SZK_(GV)), intent(in) :: visc_rem !< Both the fraction of the !! momentum originally in a layer that remains after a time-step of viscosity, and !! the fraction of a time-step's worth of a barotropic acceleration that a layer !! experiences after viscosity is applied [nondim]. !! Visc_rem is between 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZIB_(G)), optional, intent(in) :: uhbt !< The summed volume flux + real, dimension(SZIB_(G)), intent(in) :: uhbt !< The summed volume flux !! through zonal faces [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIB_(G)), intent(in) :: du_max_CFL !< Maximum acceptable @@ -768,10 +1151,10 @@ subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & uh_err_best, & ! The smallest value of uh_err found so far [H L2 T-1 ~> m3 s-1 or kg s-1]. u_new, & ! The velocity with the correction added [L T-1 ~> m s-1]. duhdu_tot,&! Summed partial derivative of uh with u [H L ~> m2 or kg m-1]. - du_min, & ! Min/max limits on du correction based on CFL limits - du_max ! and previous iterations [L T-1 ~> m s-1]. + du_min, & ! Lower limit on du correction based on CFL limits and previous iterations [L T-1 ~> m s-1] + du_max ! Upper limit on du correction based on CFL limits and previous iterations [L T-1 ~> m s-1] real :: du_prev ! The previous value of du [L T-1 ~> m s-1]. - real :: ddu ! The change in du from the previous iteration [L T-1 ~> m s-1]. + real :: ddu ! The change in du from the previous iteration [L T-1 ~> m s-1]. real :: tol_eta ! The tolerance for the current iteration [H ~> m or kg m-2]. real :: tol_vel ! The tolerance for velocity in the current iteration [L T-1 ~> m s-1]. integer :: i, k, nz, itt, max_itts = 20 @@ -838,9 +1221,10 @@ subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & if ((itt < max_itts) .or. present(uh_3d)) then ; do k=1,nz do I=ish-1,ieh ; u_new(I) = u(I,j,k) + du(I) * visc_rem(I,k) ; enddo - call zonal_flux_layer(u_new, h_in(:,j,k), h_L(:,j,k), h_R(:,j,k), & + call zonal_flux_layer(u_new, h_in(:,j,k), h_W(:,j,k), h_E(:,j,k), & uh_aux(:,k), duhdu(:,k), visc_rem(:,k), & - dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k), OBC) + dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k), & + CS%h_marg_min, OBC) enddo ; endif if (itt < max_itts) then @@ -868,17 +1252,17 @@ end subroutine zonal_flux_adjust !> Sets a structure that describes the zonal barotropic volume or mass fluxes as a !! function of barotropic flow to agree closely with the sum of the layer's transports. -subroutine set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0, & +subroutine set_zonal_BT_cont(u, h_in, h_W, h_E, BT_cont, uh_tot_0, duhdu_tot_0, & du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & visc_rem_max, j, ish, ieh, do_I, por_face_areaU) - type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to !! calculate fluxes [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_L !< Left thickness in the + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_W !< West edge thickness in the !! reconstruction [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_R !< Right thickness in the + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_E !< East edge thickness in the !! reconstruction [H ~> m or kg m-2]. type(BT_cont_type), intent(inout) :: BT_cont !< A structure with elements !! that describe the effective open face areas as a function of barotropic flow. @@ -911,7 +1295,7 @@ subroutine set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0, du0, & ! The barotropic velocity increment that gives 0 transport [L T-1 ~> m s-1]. duL, duR, & ! The barotropic velocity increments that give the westerly ! (duL) and easterly (duR) test velocities [L T-1 ~> m s-1]. - zeros, & ! An array of full of 0's. + zeros, & ! An array of full of 0 transports [H L2 T-1 ~> m3 s-1 or kg s-1] du_CFL, & ! The velocity increment that corresponds to CFL_min [L T-1 ~> m s-1]. u_L, u_R, & ! The westerly (u_L), easterly (u_R), and zero-barotropic u_0, & ! transport (u_0) layer test velocities [L T-1 ~> m s-1]. @@ -932,7 +1316,7 @@ subroutine set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0, ! from leading to large CFL numbers. real :: min_visc_rem ! The smallest permitted value for visc_rem that is used ! in finding the barotropic velocity that changes the - ! flow direction. This is necessary to keep the inverse + ! flow direction [nondim]. This is necessary to keep the inverse ! of visc_rem from leading to large CFL numbers. real :: CFL_min ! A minimal increment in the CFL to try to ensure that the ! flow is truly upwind [nondim] @@ -945,7 +1329,7 @@ subroutine set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0, ! Diagnose the zero-transport correction, du0. do I=ish-1,ieh ; zeros(I) = 0.0 ; enddo - call zonal_flux_adjust(u, h_in, h_L, h_R, zeros, uh_tot_0, duhdu_tot_0, du0, & + call zonal_flux_adjust(u, h_in, h_W, h_E, zeros, uh_tot_0, duhdu_tot_0, du0, & du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & j, ish, ieh, do_I, por_face_areaU) @@ -987,12 +1371,15 @@ subroutine set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0, u_R(I) = u(I,j,k) + duR(I) * visc_rem(I,k) u_0(I) = u(I,j,k) + du0(I) * visc_rem(I,k) endif ; enddo - call zonal_flux_layer(u_0, h_in(:,j,k), h_L(:,j,k), h_R(:,j,k), uh_0, duhdu_0, & - visc_rem(:,k), dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k)) - call zonal_flux_layer(u_L, h_in(:,j,k), h_L(:,j,k), h_R(:,j,k), uh_L, duhdu_L, & - visc_rem(:,k), dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k)) - call zonal_flux_layer(u_R, h_in(:,j,k), h_L(:,j,k), h_R(:,j,k), uh_R, duhdu_R, & - visc_rem(:,k), dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k)) + call zonal_flux_layer(u_0, h_in(:,j,k), h_W(:,j,k), h_E(:,j,k), uh_0, duhdu_0, & + visc_rem(:,k), dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, & + por_face_areaU(:,j,k), CS%h_marg_min) + call zonal_flux_layer(u_L, h_in(:,j,k), h_W(:,j,k), h_E(:,j,k), uh_L, duhdu_L, & + visc_rem(:,k), dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, & + por_face_areaU(:,j,k), CS%h_marg_min) + call zonal_flux_layer(u_R, h_in(:,j,k), h_W(:,j,k), h_E(:,j,k), uh_R, duhdu_R, & + visc_rem(:,k), dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, & + por_face_areaU(:,j,k), CS%h_marg_min) do I=ish-1,ieh ; if (do_I(I)) then FAmt_0(I) = FAmt_0(I) + duhdu_0(I) FAmt_L(I) = FAmt_L(I) + duhdu_L(I) @@ -1034,133 +1421,134 @@ subroutine set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0, end subroutine set_zonal_BT_cont !> Calculates the mass or volume fluxes through the meridional faces, and other related quantities. -subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, OBC, por_face_areaV, vhbt, & - visc_rem_v, v_cor, BT_cont) - type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to - !! calculate fluxes [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: vh !< Volume flux through meridional - !! faces = v*h*dx [H L2 s-1 ~> m3 s-1 or kg s-1] - real, intent(in) :: dt !< Time increment [T ~> s]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure.G - type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. - type(ocean_OBC_type), pointer :: OBC !< Open boundary condition type - !! specifies whether, where, and what open boundary conditions are used. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(in) :: por_face_areaV !< fractional open area of V-faces [nondim] - real, dimension(SZI_(G),SZJB_(G)), optional, intent(in) :: vhbt !< The summed volume flux through - !< meridional faces [H L2 T-1 ~> m3 s-1 or kg s-1]. +subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, por_face_areaV, & + LB_in, vhbt, visc_rem_v, v_cor, BT_cont, dv_cor) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to + !! calculate fluxes [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_S !< South edge thickness in the + !! reconstruction [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_N !< North edge thickness in the + !! reconstruction [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: vh !< Volume flux through meridional + !! faces = v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1] + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure.G + type(ocean_OBC_type), pointer :: OBC !< Open boundary condition type + !! specifies whether, where, and what + !! open boundary conditions are used. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: por_face_areaV !< fractional open area of V-faces [nondim] + type(cont_loop_bounds_type), optional, intent(in) :: LB_in !< Loop bounds structure. + real, dimension(SZI_(G),SZJB_(G)), optional, intent(in) :: vhbt !< The summed volume flux through meridional + !! faces [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - optional, intent(in) :: visc_rem_v !< Both the fraction of the momentum + optional, intent(in) :: visc_rem_v !< Both the fraction of the momentum !! originally in a layer that remains after a time-step of viscosity, !! and the fraction of a time-step's worth of a barotropic acceleration !! that a layer experiences after viscosity is applied [nondim]. !! Visc_rem_v is between 0 (at the bottom) and 1 (far above the bottom). real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - optional, intent(out) :: v_cor + optional, intent(out) :: v_cor !< The meridional velocities (v with a barotropic correction) !! that give vhbt as the depth-integrated transport [L T-1 ~> m s-1]. - type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe + type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe !! the effective open face areas as a function of barotropic flow. + real, dimension(SZI_(G),SZJB_(G)), & + optional, intent(out) :: dv_cor !< The meridional velocity increments from v + !! that give vhbt as the depth-integrated + !! transports [L T-1 ~> m s-1]. + ! Local variables real, dimension(SZI_(G),SZK_(GV)) :: & - dvhdv ! Partial derivative of vh with v [H L ~> m2 or kg m-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & - h_L, h_R ! Left and right face thicknesses [H ~> m or kg m-2]. + dvhdv ! Partial derivative of vh with v [H L ~> m2 or kg m-1]. real, dimension(SZI_(G)) :: & - dv, & ! Corrective barotropic change in the velocity [L T-1 ~> m s-1]. - dv_min_CFL, & ! Min/max limits on dv correction - dv_max_CFL, & ! to avoid CFL violations + dv, & ! Corrective barotropic change in the velocity to give vhbt [L T-1 ~> m s-1]. + dv_min_CFL, & ! Lower limit on dv correction to avoid CFL violations [L T-1 ~> m s-1] + dv_max_CFL, & ! Upper limit on dv correction to avoid CFL violations [L T-1 ~> m s-1] dvhdv_tot_0, & ! Summed partial derivative of vh with v [H L ~> m2 or kg m-1]. vh_tot_0, & ! Summed transport with no barotropic correction [H L2 T-1 ~> m3 s-1 or kg s-1]. - visc_rem_max ! The column maximum of visc_rem. + visc_rem_max ! The column maximum of visc_rem [nondim] logical, dimension(SZI_(G)) :: do_I real, dimension(SZI_(G)) :: FAvi ! A list of sums of meridional face areas [H L ~> m2 or kg m-1]. real :: FA_v ! A sum of meridional face areas [H L ~> m2 or kg m-1]. real, dimension(SZI_(G),SZK_(GV)) :: & - visc_rem ! A 2-D copy of visc_rem_v or an array of 1's. - real :: I_vrm ! 1.0 / visc_rem_max, nondim. + visc_rem ! A 2-D copy of visc_rem_v or an array of 1's [nondim] + real :: I_vrm ! 1.0 / visc_rem_max [nondim] real :: CFL_dt ! The maximum CFL ratio of the adjusted velocities divided by ! the time step [T-1 ~> s-1]. real :: I_dt ! 1.0 / dt [T-1 ~> s-1]. real :: dv_lim ! The velocity change that give a relative CFL of 1 [L T-1 ~> m s-1]. real :: dy_N, dy_S ! Effective y-grid spacings to the north and south [L ~> m]. + type(cont_loop_bounds_type) :: LB integer :: i, j, k, ish, ieh, jsh, jeh, n, nz - integer :: l_seg - logical :: local_specified_BC, use_visc_rem, set_BT_cont, any_simple_OBC - logical :: local_Flather_OBC, is_simple, local_open_BC + integer :: l_seg ! The OBC segment number + logical :: use_visc_rem, set_BT_cont + logical :: local_specified_BC, local_Flather_OBC, local_open_BC, any_simple_OBC ! OBC-related logicals + logical :: simple_OBC_pt(SZI_(G)) ! Indicates points in a row with specified transport OBCs type(OBC_segment_type), pointer :: segment => NULL() + call cpu_clock_begin(id_clock_correct) + use_visc_rem = present(visc_rem_v) - local_specified_BC = .false. ; set_BT_cont = .false. ; local_Flather_OBC = .false. - local_open_BC = .false. - if (present(BT_cont)) set_BT_cont = (associated(BT_cont)) + + set_BT_cont = .false. ; if (present(BT_cont)) set_BT_cont = (associated(BT_cont)) + + local_specified_BC = .false. ; local_Flather_OBC = .false. ; local_open_BC = .false. if (associated(OBC)) then ; if (OBC%OBC_pe) then local_specified_BC = OBC%specified_v_BCs_exist_globally local_Flather_OBC = OBC%Flather_v_BCs_exist_globally local_open_BC = OBC%open_v_BCs_exist_globally endif ; endif + + if (present(dv_cor)) dv_cor(:,:) = 0.0 + + if (present(LB_in)) then + LB = LB_in + else + LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec + endif ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke CFL_dt = CS%CFL_limit_adjust / dt I_dt = 1.0 / dt if (CS%aggress_adjust) CFL_dt = I_dt - call cpu_clock_begin(id_clock_update) -!$OMP parallel do default(none) shared(nz,ish,ieh,jsh,jeh,h_in,h_L,h_R,G,GV,LB,CS,visc_rem,OBC) - do k=1,nz - ! This sets h_L and h_R. - if (CS%upwind_1st) then - do j=jsh-1,jeh+1 ; do i=ish,ieh - h_L(i,j,k) = h_in(i,j,k) ; h_R(i,j,k) = h_in(i,j,k) - enddo ; enddo - else - call PPM_reconstruction_y(h_in(:,:,k), h_L(:,:,k), h_R(:,:,k), G, LB, & - 2.0*GV%Angstrom_H, CS%monotonic, CS%simple_2nd, OBC) - endif - do i=ish,ieh ; visc_rem(i,k) = 1.0 ; enddo - enddo - call cpu_clock_end(id_clock_update) - - call cpu_clock_begin(id_clock_correct) -!$OMP parallel do default(none) shared(ish,ieh,jsh,jeh,nz,v,h_in,h_L,h_R,vh,use_visc_rem, & -!$OMP visc_rem_v,dt,US,G,GV,CS,local_specified_BC,OBC,vhbt, & -!$OMP set_BT_cont,CFL_dt,I_dt,v_cor,BT_cont, local_Flather_OBC, & -!$OMP por_face_areaV) & -!$OMP private(do_I,dvhdv,dv,dv_max_CFL,dv_min_CFL,vh_tot_0, & -!$OMP dvhdv_tot_0,visc_rem_max,I_vrm,dv_lim,dy_N, & -!$OMP is_simple,FAvi,dy_S,any_simple_OBC,l_seg) & -!$OMP firstprivate(visc_rem) + if (.not.use_visc_rem) visc_rem(:,:) = 1.0 + !$OMP parallel do default(shared) private(do_I,dvhdv,dv,dv_max_CFL,dv_min_CFL,vh_tot_0, & + !$OMP dvhdv_tot_0,FAvi,visc_rem_max,I_vrm,dv_lim,dy_N,dy_S, & + !$OMP simple_OBC_pt,any_simple_OBC,l_seg) & + !$OMP firstprivate(visc_rem) do J=jsh-1,jeh - do i=ish,ieh ; do_I(i) = .true. ; visc_rem_max(I) = 0.0 ; enddo + do i=ish,ieh ; do_I(i) = .true. ; enddo ! This sets vh and dvhdv. do k=1,nz if (use_visc_rem) then ; do i=ish,ieh visc_rem(i,k) = visc_rem_v(i,J,k) - visc_rem_max(i) = max(visc_rem_max(i), visc_rem(i,k)) enddo ; endif - call merid_flux_layer(v(:,J,k), h_in(:,:,k), h_L(:,:,k), h_R(:,:,k), & + call merid_flux_layer(v(:,J,k), h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), & vh(:,J,k), dvhdv(:,k), visc_rem(:,k), & - dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k), OBC) + dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k), & + CS%h_marg_min, OBC) if (local_specified_BC) then - do i=ish,ieh - l_seg = OBC%segnum_v(i,J) - - if (l_seg /= OBC_NONE) then - if (OBC%segment(l_seg)%specified) & - vh(i,J,k) = OBC%segment(l_seg)%normal_trans(i,J,k) - endif - enddo + do i=ish,ieh ; if (OBC%segnum_v(i,J) /= 0) then + l_seg = abs(OBC%segnum_v(i,J)) + if (OBC%segment(l_seg)%specified) vh(i,J,k) = OBC%segment(l_seg)%normal_trans(i,J,k) + endif ; enddo endif enddo ! k-loop - if ((.not.use_visc_rem) .or. (.not.CS%use_visc_rem_max)) then ; do i=ish,ieh - visc_rem_max(i) = 1.0 - enddo ; endif if (present(vhbt) .or. set_BT_cont) then + if (use_visc_rem .and. CS%use_visc_rem_max) then + visc_rem_max(:) = 0.0 + do k=1,nz ; do i=ish,ieh + visc_rem_max(i) = max(visc_rem_max(i), visc_rem(i,k)) + enddo ; enddo + else + visc_rem_max(:) = 1.0 + endif ! Set limits on dv that will keep the CFL number between -1 and 1. ! This should be adequate to keep the root bracketed in all cases. do i=ish,ieh @@ -1200,9 +1588,9 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, OBC, por_fac dy_S = ratio_max(G%areaT(i,j), G%dx_Cv(I,j), 1000.0*G%dyT(i,j)) dy_N = ratio_max(G%areaT(i,j+1), G%dx_Cv(I,j), 1000.0*G%dyT(i,j+1)) else ; dy_S = G%dyT(i,j) ; dy_N = G%dyT(i,j+1) ; endif - if (dv_max_CFL(i) * visc_rem(i,k) > dy_S*CFL_dt - v(i,J,k)) & + if (dv_max_CFL(i) * visc_rem(i,k) > dy_S*CFL_dt - v(i,J,k)*G%mask2dCv(i,J)) & dv_max_CFL(i) = (dy_S*CFL_dt - v(i,J,k)) / visc_rem(i,k) - if (dv_min_CFL(i) * visc_rem(i,k) < -dy_N*CFL_dt - v(i,J,k)) & + if (dv_min_CFL(i) * visc_rem(i,k) < -dy_N*CFL_dt - v(i,J,k)*G%mask2dCv(i,J)) & dv_min_CFL(i) = -(dy_N*CFL_dt + v(i,J,k)) / visc_rem(i,k) enddo ; enddo endif @@ -1237,59 +1625,52 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, OBC, por_fac any_simple_OBC = .false. if (present(vhbt) .or. set_BT_cont) then if (local_specified_BC .or. local_Flather_OBC) then ; do i=ish,ieh - l_seg = OBC%segnum_v(i,J) + l_seg = abs(OBC%segnum_v(i,J)) ! Avoid reconciling barotropic/baroclinic transports if transport is specified - is_simple = .false. - if (l_seg /= OBC_NONE) & - is_simple = OBC%segment(l_seg)%specified - do_I(i) = .not.(l_seg /= OBC_NONE .and. is_simple) - any_simple_OBC = any_simple_OBC .or. is_simple + simple_OBC_pt(i) = .false. + if (l_seg /= 0) simple_OBC_pt(i) = OBC%segment(l_seg)%specified + do_I(i) = .not.simple_OBC_pt(i) + any_simple_OBC = any_simple_OBC .or. simple_OBC_pt(i) enddo ; else ; do i=ish,ieh do_I(i) = .true. enddo ; endif endif if (present(vhbt)) then - call meridional_flux_adjust(v, h_in, h_L, h_R, vhbt(:,J), vh_tot_0, dvhdv_tot_0, dv, & + ! Find dv and vh. + call meridional_flux_adjust(v, h_in, h_S, h_N, vhbt(:,J), vh_tot_0, dvhdv_tot_0, dv, & dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & j, ish, ieh, do_I, por_face_areaV, vh, OBC=OBC) if (present(v_cor)) then ; do k=1,nz do i=ish,ieh ; v_cor(i,J,k) = v(i,J,k) + dv(i) * visc_rem(i,k) ; enddo - if (local_specified_BC) then ; do i=ish,ieh - l_seg = OBC%segnum_v(i,J) - - if (l_seg /= OBC_NONE) then - if (OBC%segment(OBC%segnum_v(i,J))%specified) & - v_cor(i,J,k) = OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k) - endif - enddo ; endif + if (any_simple_OBC) then ; do i=ish,ieh ; if (simple_OBC_pt(i)) then + v_cor(i,J,k) = OBC%segment(abs(OBC%segnum_v(i,J)))%normal_vel(i,J,k) + endif ; enddo ; endif enddo ; endif ! v-corrected + + if (present(dv_cor)) then + do i=ish,ieh ; dv_cor(i,J) = dv(i) ; enddo + endif + endif if (set_BT_cont) then - call set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0,& + call set_merid_BT_cont(v, h_in, h_S, h_N, BT_cont, vh_tot_0, dvhdv_tot_0,& dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & visc_rem_max, J, ish, ieh, do_I, por_face_areaV) if (any_simple_OBC) then do i=ish,ieh - l_seg = OBC%segnum_v(i,J) - - do_I(I) = .false. - if(l_seg /= OBC_NONE) & - do_I(i) = (OBC%segment(l_seg)%specified) - - if (do_I(i)) FAvi(i) = GV%H_subroundoff*G%dx_Cv(i,J) + if (simple_OBC_pt(i)) FAvi(i) = GV%H_subroundoff*G%dx_Cv(i,J) enddo - ! NOTE: do_I(I) should prevent access to segment OBC_NONE - do k=1,nz ; do i=ish,ieh ; if (do_I(i)) then - if ((abs(OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k)) > 0.0) .and. & - (OBC%segment(OBC%segnum_v(i,J))%specified)) & - FAvi(i) = FAvi(i) + OBC%segment(OBC%segnum_v(i,J))%normal_trans(i,J,k) / & - OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k) + ! NOTE: simple_OBC_pt(i) should prevent access to segment OBC_NONE + do k=1,nz ; do i=ish,ieh ; if (simple_OBC_pt(i)) then + segment => OBC%segment(abs(OBC%segnum_v(i,J))) + if ((abs(segment%normal_vel(i,J,k)) > 0.0) .and. (segment%specified)) & + FAvi(i) = FAvi(i) + segment%normal_trans(i,J,k) / segment%normal_vel(i,J,k) endif ; enddo ; enddo - do i=ish,ieh ; if (do_I(i)) then + do i=ish,ieh ; if (simple_OBC_pt(i)) then BT_cont%FA_v_S0(i,J) = FAvi(i) ; BT_cont%FA_v_N0(i,J) = FAvi(i) BT_cont%FA_v_SS(i,J) = FAvi(i) ; BT_cont%FA_v_NN(i,J) = FAvi(i) BT_cont%vBT_SS(i,J) = 0.0 ; BT_cont%vBT_NN(i,J) = 0.0 @@ -1325,24 +1706,101 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, OBC, por_fac endif enddo endif - call cpu_clock_end(id_clock_correct) if (set_BT_cont) then ; if (allocated(BT_cont%h_v)) then if (present(v_cor)) then - call merid_face_thickness(v_cor, h_in, h_L, h_R, BT_cont%h_v, dt, G, GV, US, LB, & - CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV, visc_rem_v) + 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 merid_face_thickness(v, h_in, h_L, h_R, BT_cont%h_v, dt, G, GV, US, LB, & - CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV, visc_rem_v) + 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 + call cpu_clock_end(id_clock_correct) + end subroutine meridional_mass_flux + +!> Calculates the vertically integrated mass or volume fluxes through the meridional faces. +subroutine meridional_BT_mass_flux(v, h_in, h_S, h_N, vhbt, dt, G, GV, US, CS, OBC, por_face_areaV, LB_in) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to + !! calculate fluxes [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_S !< Southern edge thickness in the PPM + !! reconstruction [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_N !< Northern edge thickness in the PPM + !! reconstruction [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJB_(G)), intent(out) :: vhbt !< The summed volume flux through meridional + !! faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure.G + type(ocean_OBC_type), pointer :: OBC !< Open boundary condition type + !! specifies whether, where, and what + !! open boundary conditions are used. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: por_face_areaV !< fractional open area of V-faces [nondim] + type(cont_loop_bounds_type), optional, intent(in) :: LB_in !< Loop bounds structure. + + ! Local variables + real :: vh(SZI_(G)) ! Volume flux through meridional faces = v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: dvhdv(SZI_(G)) ! Partial derivative of vh with v [H L ~> m2 or kg m-1]. + logical, dimension(SZI_(G)) :: do_I + real :: ones(SZI_(G)) ! An array of 1's [nondim] + integer :: i, j, k, ish, ieh, jsh, jeh, nz, l_seg + logical :: local_specified_BC, OBC_in_row + + call cpu_clock_begin(id_clock_correct) + + local_specified_BC = .false. + if (associated(OBC)) then ; if (OBC%OBC_pe) then + local_specified_BC = OBC%specified_v_BCs_exist_globally + endif ; endif + + if (present(LB_in)) then + ish = LB_in%ish ; ieh = LB_in%ieh ; jsh = LB_in%jsh ; jeh = LB_in%jeh ; nz = GV%ke + else + ish = G%isc ; ieh = G%iec ; jsh = G%jsc ; jeh = G%jec ; nz = GV%ke + endif + + ones(:) = 1.0 ; do_I(:) = .true. + + vhbt(:,:) = 0.0 + !$OMP parallel do default(shared) private(vh,dvhdv,OBC_in_row) + do J=jsh-1,jeh + ! Determining whether there are any OBC points outside of the k-loop should be more efficient. + OBC_in_row = .false. + if (local_specified_BC) then ; do i=ish,ieh ; if (OBC%segnum_v(i,J) /= 0) then + if (OBC%segment(abs(OBC%segnum_v(i,J)))%specified) OBC_in_row = .true. + endif ; enddo ; endif + do k=1,nz + ! This sets vh and dvhdv. + call merid_flux_layer(v(:,J,k), h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), vh, dvhdv, ones, & + dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k), & + CS%h_marg_min, OBC) + if (OBC_in_row) then ; do i=ish,ieh ; if (OBC%segnum_v(i,J) /= 0) then + l_seg = abs(OBC%segnum_v(i,J)) + if (OBC%segment(l_seg)%specified) vh(i) = OBC%segment(l_seg)%normal_trans(i,J,k) + endif ; enddo ; endif + + ! Accumulate the barotropic transport. + do i=ish,ieh + vhbt(i,J) = vhbt(i,J) + vh(i) + enddo + enddo ! k-loop + enddo ! j-loop + + call cpu_clock_end(id_clock_correct) + +end subroutine meridional_BT_mass_flux + + !> Evaluates the meridional mass or volume fluxes in a layer. -subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt, G, US, J, & - ish, ieh, do_I, vol_CFL, por_face_areaV, OBC) - type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. +subroutine merid_flux_layer(v, h, h_S, h_N, vh, dvhdv, visc_rem, dt, G, US, J, & + ish, ieh, do_I, vol_CFL, por_face_areaV, h_marg_min, OBC) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. real, dimension(SZI_(G)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G)), intent(in) :: visc_rem !< Both the fraction of the !! momentum originally in a layer that remains after a time-step @@ -1351,9 +1809,9 @@ subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt, G, US, J, & !! Visc_rem is between 0 (at the bottom) and 1 (far above the bottom). real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h !< Layer thickness used to calculate fluxes, !! [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_L !< Left thickness in the reconstruction + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_S !< South edge thickness in the reconstruction !! [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_R !< Right thickness in the reconstruction + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_N !< North edge thickness in the reconstruction !! [H ~> m or kg m-2]. real, dimension(SZI_(G)), intent(inout) :: vh !< Meridional mass or volume transport !! [H L2 T-1 ~> m3 s-1 or kg s-1]. @@ -1367,8 +1825,9 @@ subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt, G, US, J, & logical, dimension(SZI_(G)), intent(in) :: do_I !< Which i values to work on. logical, intent(in) :: vol_CFL !< If true, rescale the !! ratio of face areas to the cell areas when estimating the CFL number. - real, dimension(SZI_(G), SZJB_(G)), & + real, dimension(SZI_(G),SZJB_(G)), & intent(in) :: por_face_areaV !< fractional open area of V-faces [nondim] + real, intent(in) :: h_marg_min !< Negligible floor on h_marg [H ~> m or kg m-2] type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim] @@ -1376,7 +1835,6 @@ subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt, G, US, J, & ! with the same units as h, i.e. [H ~> m or kg m-2]. real :: h_marg ! The marginal thickness of a flux [H ~> m or kg m-2]. integer :: i - integer :: l_seg logical :: local_open_BC local_open_BC = .false. @@ -1388,38 +1846,37 @@ subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt, G, US, J, & if (v(i) > 0.0) then if (vol_CFL) then ; CFL = (v(i) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j)) else ; CFL = v(i) * dt * G%IdyT(i,j) ; endif - curv_3 = h_L(i,j) + h_R(i,j) - 2.0*h(i,j) - vh(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * v(i) * ( h_R(i,j) + CFL * & - (0.5*(h_L(i,j) - h_R(i,j)) + curv_3*(CFL - 1.5)) ) - h_marg = h_R(i,j) + CFL * ((h_L(i,j) - h_R(i,j)) + & + curv_3 = (h_S(i,j) + h_N(i,j)) - 2.0*h(i,j) + vh(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * v(i) * ( h_N(i,j) + CFL * & + (0.5*(h_S(i,j) - h_N(i,j)) + curv_3*(CFL - 1.5)) ) + h_marg = h_N(i,j) + CFL * ((h_S(i,j) - h_N(i,j)) + & 3.0*curv_3*(CFL - 1.0)) elseif (v(i) < 0.0) then if (vol_CFL) then ; CFL = (-v(i) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j+1)) else ; CFL = -v(i) * dt * G%IdyT(i,j+1) ; endif - curv_3 = h_L(i,j+1) + h_R(i,j+1) - 2.0*h(i,j+1) - vh(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * v(i) * ( h_L(i,j+1) + CFL * & - (0.5*(h_R(i,j+1)-h_L(i,j+1)) + curv_3*(CFL - 1.5)) ) - h_marg = h_L(i,j+1) + CFL * ((h_R(i,j+1)-h_L(i,j+1)) + & + curv_3 = (h_S(i,j+1) + h_N(i,j+1)) - 2.0*h(i,j+1) + vh(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * v(i) * ( h_S(i,j+1) + CFL * & + (0.5*(h_N(i,j+1)-h_S(i,j+1)) + curv_3*(CFL - 1.5)) ) + h_marg = h_S(i,j+1) + CFL * ((h_N(i,j+1)-h_S(i,j+1)) + & 3.0*curv_3*(CFL - 1.0)) else vh(i) = 0.0 - h_marg = 0.5 * (h_L(i,j+1) + h_R(i,j)) + h_marg = 0.5 * (h_S(i,j+1) + h_N(i,j)) endif + h_marg = max(h_marg, h_marg_min) dvhdv(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * h_marg * visc_rem(i) endif ; enddo if (local_open_BC) then do i=ish,ieh ; if (do_I(i)) then - l_seg = OBC%segnum_v(i,J) - - if (l_seg /= OBC_NONE) then - if (OBC%segment(l_seg)%open) then - if (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then + if (OBC%segnum_v(i,J) /= 0) then + if (OBC%segment(abs(OBC%segnum_v(i,J)))%open) then + if (OBC%segnum_v(i,J) > 0) then ! OBC_DIRECTION_N vh(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * v(i) * h(i,j) - dvhdv(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * h(i,j) * visc_rem(i) + dvhdv(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * max(h(i,j), h_marg_min) * visc_rem(i) else vh(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * v(i) * h(i,j+1) - dvhdv(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * h(i,j+1) * visc_rem(i) + dvhdv(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * max(h(i,j+1), h_marg_min) * visc_rem(i) endif endif endif @@ -1427,22 +1884,25 @@ subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt, G, US, J, & endif end subroutine merid_flux_layer -!> Sets the effective interface thickness at each meridional velocity point. -subroutine merid_face_thickness(v, h, h_L, h_R, h_v, dt, G, GV, US, LB, vol_CFL, & - marginal, OBC, por_face_areaV, visc_rem_v) - type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. +!> Sets the effective interface thickness associated with the fluxes at each meridional velocity point, +!! optionally scaling back these thicknesses to account for viscosity and fractional open areas. +subroutine meridional_flux_thickness(v, h, h_S, h_N, h_v, dt, G, GV, US, LB, vol_CFL, & + marginal, OBC, por_face_areaV, visc_rem_v) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness used to calculate fluxes, !! [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_L !< Left thickness in the reconstruction, + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_S !< South edge thickness in the reconstruction, !! [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_R !< Right thickness in the reconstruction, + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_N !< North edge thickness in the reconstruction, !! [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: h_v !< Thickness at meridional faces, + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: h_v !< Effective thickness at meridional faces, + !! scaled down to account for the effects of + !! viscosity and the fractional open area !! [H ~> m or kg m-2]. real, intent(in) :: dt !< Time increment [T ~> s]. - type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. + type(cont_loop_bounds_type), intent(in) :: LB !< Loop bounds structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type logical, intent(in) :: vol_CFL !< If true, rescale the ratio !! of face areas to the cell areas when estimating the CFL number. @@ -1472,24 +1932,24 @@ subroutine merid_face_thickness(v, h, h_L, h_R, h_v, dt, G, GV, US, LB, vol_CFL, if (v(i,J,k) > 0.0) then if (vol_CFL) then ; CFL = (v(i,J,k) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j)) else ; CFL = v(i,J,k) * dt * G%IdyT(i,j) ; endif - curv_3 = h_L(i,j,k) + h_R(i,j,k) - 2.0*h(i,j,k) - h_avg = h_R(i,j,k) + CFL * (0.5*(h_L(i,j,k) - h_R(i,j,k)) + curv_3*(CFL - 1.5)) - h_marg = h_R(i,j,k) + CFL * ((h_L(i,j,k) - h_R(i,j,k)) + & + curv_3 = (h_S(i,j,k) + h_N(i,j,k)) - 2.0*h(i,j,k) + h_avg = h_N(i,j,k) + CFL * (0.5*(h_S(i,j,k) - h_N(i,j,k)) + curv_3*(CFL - 1.5)) + h_marg = h_N(i,j,k) + CFL * ((h_S(i,j,k) - h_N(i,j,k)) + & 3.0*curv_3*(CFL - 1.0)) elseif (v(i,J,k) < 0.0) then if (vol_CFL) then ; CFL = (-v(i,J,k)*dt) * (G%dx_Cv(i,J) * G%IareaT(i,j+1)) else ; CFL = -v(i,J,k) * dt * G%IdyT(i,j+1) ; endif - curv_3 = h_L(i,j+1,k) + h_R(i,j+1,k) - 2.0*h(i,j+1,k) - h_avg = h_L(i,j+1,k) + CFL * (0.5*(h_R(i,j+1,k)-h_L(i,j+1,k)) + curv_3*(CFL - 1.5)) - h_marg = h_L(i,j+1,k) + CFL * ((h_R(i,j+1,k)-h_L(i,j+1,k)) + & + curv_3 = (h_S(i,j+1,k) + h_N(i,j+1,k)) - 2.0*h(i,j+1,k) + h_avg = h_S(i,j+1,k) + CFL * (0.5*(h_N(i,j+1,k)-h_S(i,j+1,k)) + curv_3*(CFL - 1.5)) + h_marg = h_S(i,j+1,k) + CFL * ((h_N(i,j+1,k)-h_S(i,j+1,k)) + & 3.0*curv_3*(CFL - 1.0)) else - h_avg = 0.5 * (h_L(i,j+1,k) + h_R(i,j,k)) + h_avg = 0.5 * (h_S(i,j+1,k) + h_N(i,j,k)) ! The choice to use the arithmetic mean here is somewhat arbitrarily, but - ! it should be noted that h_L(i+1,j,k) and h_R(i,j,k) are usually the same. - h_marg = 0.5 * (h_L(i,j+1,k) + h_R(i,j,k)) - ! h_marg = (2.0 * h_L(i,j+1,k) * h_R(i,j,k)) / & - ! (h_L(i,j+1,k) + h_R(i,j,k) + GV%H_subroundoff) + ! it should be noted that h_S(i+1,j,k) and h_N(i,j,k) are usually the same. + h_marg = 0.5 * (h_S(i,j+1,k) + h_N(i,j,k)) + ! h_marg = (2.0 * h_S(i,j+1,k) * h_N(i,j,k)) / & + ! (h_S(i,j+1,k) + h_N(i,j,k) + GV%H_subroundoff) endif if (marginal) then ; h_v(i,J,k) = h_marg @@ -1497,11 +1957,17 @@ subroutine merid_face_thickness(v, h, h_L, h_R, h_v, dt, G, GV, US, LB, vol_CFL, enddo ; enddo ; enddo if (present(visc_rem_v)) then - !### This expression setting h_v should also be multiplied by por_face_areaU in this case, - ! and in the two OBC cases below with visc_rem_u. + ! Scale back the thickness to account for the effects of viscosity and the fractional open + ! thickness to give an appropriate non-normalized weight for each layer in determining the + ! barotropic acceleration. + !$OMP parallel do default(shared) + do k=1,nz ; do J=jsh-1,jeh ; do i=ish,ieh + h_v(i,J,k) = h_v(i,J,k) * (visc_rem_v(i,J,k) * por_face_areaV(i,J,k)) + enddo ; enddo ; enddo + else !$OMP parallel do default(shared) do k=1,nz ; do J=jsh-1,jeh ; do i=ish,ieh - h_v(i,J,k) = h_v(i,J,k) * visc_rem_v(i,J,k) !### * por_face_areaV(i,J,k) + h_v(i,J,k) = h_v(i,J,k) * por_face_areaV(i,J,k) enddo ; enddo ; enddo endif @@ -1514,21 +1980,21 @@ subroutine merid_face_thickness(v, h, h_L, h_R, h_v, dt, G, GV, US, LB, vol_CFL, if (OBC%segment(n)%direction == OBC_DIRECTION_N) then if (present(visc_rem_v)) then ; do k=1,nz do i = OBC%segment(n)%HI%isd, OBC%segment(n)%HI%ied - h_v(i,J,k) = h(i,j,k) * visc_rem_v(i,J,k) !### * por_face_areaV(i,J,k) + h_v(i,J,k) = h(i,j,k) * (visc_rem_v(i,J,k) * por_face_areaV(i,J,k)) enddo enddo ; else ; do k=1,nz do i = OBC%segment(n)%HI%isd, OBC%segment(n)%HI%ied - h_v(i,J,k) = h(i,j,k) + h_v(i,J,k) = h(i,j,k) * por_face_areaV(i,J,k) enddo enddo ; endif else if (present(visc_rem_v)) then ; do k=1,nz do i = OBC%segment(n)%HI%isd, OBC%segment(n)%HI%ied - h_v(i,J,k) = h(i,j+1,k) * visc_rem_v(i,J,k) !### * por_face_areaV(i,J,k) + h_v(i,J,k) = h(i,j+1,k) * (visc_rem_v(i,J,k) * por_face_areaV(i,J,k)) enddo enddo ; else ; do k=1,nz do i = OBC%segment(n)%HI%isd, OBC%segment(n)%HI%ied - h_v(i,J,k) = h(i,j+1,k) + h_v(i,J,k) = h(i,j+1,k) * por_face_areaV(i,J,k) enddo enddo ; endif endif @@ -1536,37 +2002,36 @@ subroutine merid_face_thickness(v, h, h_L, h_R, h_v, dt, G, GV, US, LB, vol_CFL, enddo endif -end subroutine merid_face_thickness +end subroutine meridional_flux_thickness !> Returns the barotropic velocity adjustment that gives the desired barotropic (layer-summed) transport. -subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0, & +subroutine meridional_flux_adjust(v, h_in, h_S, h_N, vhbt, vh_tot_0, dvhdv_tot_0, & dv, dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & j, ish, ieh, do_I_in, por_face_areaV, vh_3d, OBC) - type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h_in !< Layer thickness used to calculate fluxes [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)),& - intent(in) :: h_L !< Left thickness in the reconstruction [H ~> m or kg m-2]. + intent(in) :: h_S !< South edge thickness in the reconstruction [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h_R !< Right thickness in the reconstruction [H ~> m or kg m-2]. + intent(in) :: h_N !< North edge thickness in the reconstruction [H ~> m or kg m-2]. real, dimension(SZI_(G),SZK_(GV)), intent(in) :: visc_rem !< Both the fraction of the momentum originally !! in a layer that remains after a time-step of viscosity, and the !! fraction of a time-step's worth of a barotropic acceleration that !! a layer experiences after viscosity is applied [nondim]. !! Visc_rem is between 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZI_(G)), & - optional, intent(in) :: vhbt !< The summed volume flux through meridional faces + real, dimension(SZI_(G)), intent(in) :: vhbt !< The summed volume flux through meridional faces !! [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G)), intent(in) :: dv_max_CFL !< Maximum acceptable value of dv [L T-1 ~> m s-1]. real, dimension(SZI_(G)), intent(in) :: dv_min_CFL !< Minimum acceptable value of dv [L T-1 ~> m s-1]. real, dimension(SZI_(G)), intent(in) :: vh_tot_0 !< The summed transport with 0 adjustment - !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G)), intent(in) :: dvhdv_tot_0 !< The partial derivative of dv_err with - !! dv at 0 adjustment [H L ~> m2 or kg m-1]. + !! dv at 0 adjustment [H L ~> m2 or kg m-1]. real, dimension(SZI_(G)), intent(out) :: dv !< The barotropic velocity adjustment [L T-1 ~> m s-1]. real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -1591,10 +2056,10 @@ subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0 vh_err_best, & ! The smallest value of vh_err found so far [H L2 T-1 ~> m3 s-1 or kg s-1]. v_new, & ! The velocity with the correction added [L T-1 ~> m s-1]. dvhdv_tot,&! Summed partial derivative of vh with u [H L ~> m2 or kg m-1]. - dv_min, & ! Min/max limits on dv correction based on CFL limits - dv_max ! and previous iterations [L T-1 ~> m s-1]. + dv_min, & ! Lower limit on dv correction based on CFL limits and previous iterations [L T-1 ~> m s-1] + dv_max ! Upper limit on dv correction based on CFL limits and previous iterations [L T-1 ~> m s-1] real :: dv_prev ! The previous value of dv [L T-1 ~> m s-1]. - real :: ddv ! The change in dv from the previous iteration [L T-1 ~> m s-1]. + real :: ddv ! The change in dv from the previous iteration [L T-1 ~> m s-1]. real :: tol_eta ! The tolerance for the current iteration [H ~> m or kg m-2]. real :: tol_vel ! The tolerance for velocity in the current iteration [L T-1 ~> m s-1]. integer :: i, k, nz, itt, max_itts = 20 @@ -1661,9 +2126,10 @@ subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0 if ((itt < max_itts) .or. present(vh_3d)) then ; do k=1,nz do i=ish,ieh ; v_new(i) = v(i,J,k) + dv(i) * visc_rem(i,k) ; enddo - call merid_flux_layer(v_new, h_in(:,:,k), h_L(:,:,k), h_R(:,:,k), & + call merid_flux_layer(v_new, h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), & vh_aux(:,k), dvhdv(:,k), visc_rem(:,k), & - dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k), OBC) + dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k), & + CS%h_marg_min, OBC) enddo ; endif if (itt < max_itts) then @@ -1691,17 +2157,17 @@ end subroutine meridional_flux_adjust !> Sets of a structure that describes the meridional barotropic volume or mass fluxes as a !! function of barotropic flow to agree closely with the sum of the layer's transports. -subroutine set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0, & +subroutine set_merid_BT_cont(v, h_in, h_S, h_N, BT_cont, vh_tot_0, dvhdv_tot_0, & dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & visc_rem_max, j, ish, ieh, do_I, por_face_areaV) - type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to calculate fluxes, !! [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_L !< Left thickness in the reconstruction, + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_S !< South edge thickness in the reconstruction, !! [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_R !< Right thickness in the reconstruction, + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_N !< North edge thickness in the reconstruction, !! [H ~> m or kg m-2]. type(BT_cont_type), intent(inout) :: BT_cont !< A structure with elements !! that describe the effective open face areas as a function of barotropic flow. @@ -1734,7 +2200,7 @@ subroutine set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0, dv0, & ! The barotropic velocity increment that gives 0 transport [L T-1 ~> m s-1]. dvL, dvR, & ! The barotropic velocity increments that give the southerly ! (dvL) and northerly (dvR) test velocities [L T-1 ~> m s-1]. - zeros, & ! An array of full of 0's. + zeros, & ! An array of full of 0 transports [H L2 T-1 ~> m3 s-1 or kg s-1] dv_CFL, & ! The velocity increment that corresponds to CFL_min [L T-1 ~> m s-1]. v_L, v_R, & ! The southerly (v_L), northerly (v_R), and zero-barotropic v_0, & ! transport (v_0) layer test velocities [L T-1 ~> m s-1]. @@ -1768,7 +2234,7 @@ subroutine set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0, ! Diagnose the zero-transport correction, dv0. do i=ish,ieh ; zeros(i) = 0.0 ; enddo - call meridional_flux_adjust(v, h_in, h_L, h_R, zeros, vh_tot_0, dvhdv_tot_0, dv0, & + call meridional_flux_adjust(v, h_in, h_S, h_N, zeros, vh_tot_0, dvhdv_tot_0, dv0, & dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & j, ish, ieh, do_I, por_face_areaV) @@ -1810,12 +2276,15 @@ subroutine set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0, v_R(i) = v(I,j,k) + dvR(i) * visc_rem(i,k) v_0(i) = v(I,j,k) + dv0(i) * visc_rem(i,k) endif ; enddo - call merid_flux_layer(v_0, h_in(:,:,k), h_L(:,:,k), h_R(:,:,k), vh_0, dvhdv_0, & - visc_rem(:,k), dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k)) - call merid_flux_layer(v_L, h_in(:,:,k), h_L(:,:,k), h_R(:,:,k), vh_L, dvhdv_L, & - visc_rem(:,k), dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k)) - call merid_flux_layer(v_R, h_in(:,:,k), h_L(:,:,k), h_R(:,:,k), vh_R, dvhdv_R, & - visc_rem(:,k), dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k)) + call merid_flux_layer(v_0, h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), vh_0, dvhdv_0, & + visc_rem(:,k), dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, & + por_face_areaV(:,:,k), CS%h_marg_min) + call merid_flux_layer(v_L, h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), vh_L, dvhdv_L, & + visc_rem(:,k), dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, & + por_face_areaV(:,:,k), CS%h_marg_min) + call merid_flux_layer(v_R, h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), vh_R, dvhdv_R, & + visc_rem(:,k), dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, & + por_face_areaV(:,:,k), CS%h_marg_min) do i=ish,ieh ; if (do_I(i)) then FAmt_0(i) = FAmt_0(i) + dvhdv_0(i) FAmt_L(i) = FAmt_L(i) + dvhdv_L(i) @@ -1855,16 +2324,16 @@ subroutine set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0, end subroutine set_merid_BT_cont !> Calculates left/right edge values for PPM reconstruction. -subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_2nd, OBC) +subroutine PPM_reconstruction_x(h_in, h_W, h_E, G, LB, h_min, monotonic, simple_2nd, OBC, k) type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Layer thickness [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_L !< Left thickness in the reconstruction, + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_W !< West edge thickness in the reconstruction, !! [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_R !< Right thickness in the reconstruction, + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_E !< East edge thickness in the reconstruction, !! [H ~> m or kg m-2]. - type(loop_bounds_type), intent(in) :: LB !< Active loop bounds structure. + type(cont_loop_bounds_type), intent(in) :: LB !< Active loop bounds structure. real, intent(in) :: h_min !< The minimum thickness - !! that can be obtained by a concave parabolic fit. + !! that can be obtained by a concave parabolic fit [H ~> m or kg m-2] logical, intent(in) :: monotonic !< If true, use the !! Colella & Woodward monotonic limiter. !! Otherwise use a simple positive-definite limiter. @@ -1872,10 +2341,11 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ !! arithmetic mean thicknesses as the default edge values !! for a simple 2nd order scheme. type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + integer :: k !< vertical grid index ! Local variables with useful mnemonic names. - real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slopes. - real, parameter :: oneSixth = 1./6. + real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slopes per grid point [H ~> m or kg m-2] + real, parameter :: oneSixth = 1./6. ! [nondim] real :: h_ip1, h_im1 ! Neighboring thicknesses or sensibly extrapolated values [H ~> m or kg m-2] real :: dMx, dMn ! The difference between the local thickness and the maximum (dMx) or ! minimum (dMn) of the surrounding values [H ~> m or kg m-2] @@ -1896,13 +2366,13 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ if ((isl-stencil < G%isd) .or. (iel+stencil > G%ied)) then write(mesg,'("In MOM_continuity_PPM, PPM_reconstruction_x called with a ", & - & "x-halo that needs to be increased by ",i2,".")') & + & "x-halo that needs to be increased by ",I0,".")') & stencil + max(G%isd-isl,iel-G%ied) call MOM_error(FATAL,mesg) endif if ((jsl < G%jsd) .or. (jel > G%jed)) then write(mesg,'("In MOM_continuity_PPM, PPM_reconstruction_x called with a ", & - & "y-halo that needs to be increased by ",i2,".")') & + & "y-halo that needs to be increased by ",I0,".")') & max(G%jsd-jsl,jel-G%jed) call MOM_error(FATAL,mesg) endif @@ -1911,8 +2381,8 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ do j=jsl,jel ; do i=isl,iel h_im1 = G%mask2dT(i-1,j) * h_in(i-1,j) + (1.0-G%mask2dT(i-1,j)) * h_in(i,j) h_ip1 = G%mask2dT(i+1,j) * h_in(i+1,j) + (1.0-G%mask2dT(i+1,j)) * h_in(i,j) - h_L(i,j) = 0.5*( h_im1 + h_in(i,j) ) - h_R(i,j) = 0.5*( h_ip1 + h_in(i,j) ) + h_W(i,j) = 0.5*( h_im1 + h_in(i,j) ) + h_E(i,j) = 0.5*( h_ip1 + h_in(i,j) ) enddo ; enddo else do j=jsl,jel ; do i=isl-1,iel+1 @@ -1933,8 +2403,7 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ do n=1, OBC%number_of_segments segment => OBC%segment(n) if (.not. segment%on_pe) cycle - if (segment%direction == OBC_DIRECTION_E .or. & - segment%direction == OBC_DIRECTION_W) then + if (segment%is_E_or_W) then I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed slp(i+1,j) = 0.0 @@ -1952,8 +2421,8 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ h_im1 = G%mask2dT(i-1,j) * h_in(i-1,j) + (1.0-G%mask2dT(i-1,j)) * h_in(i,j) h_ip1 = G%mask2dT(i+1,j) * h_in(i+1,j) + (1.0-G%mask2dT(i+1,j)) * h_in(i,j) ! Left/right values following Eq. B2 in Lin 1994, MWR (132) - h_L(i,j) = 0.5*( h_im1 + h_in(i,j) ) + oneSixth*( slp(i-1,j) - slp(i,j) ) - h_R(i,j) = 0.5*( h_ip1 + h_in(i,j) ) + oneSixth*( slp(i,j) - slp(i+1,j) ) + h_W(i,j) = 0.5*( h_im1 + h_in(i,j) ) + oneSixth*( slp(i-1,j) - slp(i,j) ) + h_E(i,j) = 0.5*( h_ip1 + h_in(i,j) ) + oneSixth*( slp(i,j) - slp(i+1,j) ) enddo ; enddo endif @@ -1963,44 +2432,62 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ if (.not. segment%on_pe) cycle if (segment%direction == OBC_DIRECTION_E) then I=segment%HI%IsdB - do j=segment%HI%jsd,segment%HI%jed - h_L(i+1,j) = h_in(i,j) - h_R(i+1,j) = h_in(i,j) - h_L(i,j) = h_in(i,j) - h_R(i,j) = h_in(i,j) - enddo + if (associated(segment%h_Reg)) then + do j=segment%HI%jsd,segment%HI%jed + h_W(i+1,j) = segment%h_Reg%h_res(i,j,k) + h_E(i+1,j) = segment%h_Reg%h_res(i,j,k) + h_W(i,j) = segment%h_Reg%h_res(i,j,k) + h_E(i,j) = segment%h_Reg%h_res(i,j,k) + enddo + else + do j=segment%HI%jsd,segment%HI%jed + h_W(i+1,j) = h_in(i,j) + h_E(i+1,j) = h_in(i,j) + h_W(i,j) = h_in(i,j) + h_E(i,j) = h_in(i,j) + enddo + endif elseif (segment%direction == OBC_DIRECTION_W) then I=segment%HI%IsdB - do j=segment%HI%jsd,segment%HI%jed - h_L(i,j) = h_in(i+1,j) - h_R(i,j) = h_in(i+1,j) - h_L(i+1,j) = h_in(i+1,j) - h_R(i+1,j) = h_in(i+1,j) - enddo + if (associated(segment%h_Reg)) then + do j=segment%HI%jsd,segment%HI%jed + h_W(i,j) = segment%h_Reg%h_res(i,j,k) + h_E(i,j) = segment%h_Reg%h_res(i,j,k) + h_W(i+1,j) = segment%h_Reg%h_res(i,j,k) + h_E(i+1,j) = segment%h_Reg%h_res(i,j,k) + enddo + else + do j=segment%HI%jsd,segment%HI%jed + h_W(i,j) = h_in(i+1,j) + h_E(i,j) = h_in(i+1,j) + h_W(i+1,j) = h_in(i+1,j) + h_E(i+1,j) = h_in(i+1,j) + enddo + endif endif enddo endif if (monotonic) then - call PPM_limit_CW84(h_in, h_L, h_R, G, isl, iel, jsl, jel) + call PPM_limit_CW84(h_in, h_W, h_E, G, isl, iel, jsl, jel) else - call PPM_limit_pos(h_in, h_L, h_R, h_min, G, isl, iel, jsl, jel) + call PPM_limit_pos(h_in, h_W, h_E, h_min, G, isl, iel, jsl, jel) endif return end subroutine PPM_reconstruction_x !> Calculates left/right edge values for PPM reconstruction. -subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_2nd, OBC) +subroutine PPM_reconstruction_y(h_in, h_S, h_N, G, LB, h_min, monotonic, simple_2nd, OBC, k) type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Layer thickness [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_L !< Left thickness in the reconstruction, + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_S !< South edge thickness in the reconstruction, !! [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_R !< Right thickness in the reconstruction, + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_N !< North edge thickness in the reconstruction, !! [H ~> m or kg m-2]. - type(loop_bounds_type), intent(in) :: LB !< Active loop bounds structure. + type(cont_loop_bounds_type), intent(in) :: LB !< Active loop bounds structure. real, intent(in) :: h_min !< The minimum thickness - !! that can be obtained by a concave parabolic fit. + !! that can be obtained by a concave parabolic fit [H ~> m or kg m-2] logical, intent(in) :: monotonic !< If true, use the !! Colella & Woodward monotonic limiter. !! Otherwise use a simple positive-definite limiter. @@ -2008,10 +2495,11 @@ subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ !! arithmetic mean thicknesses as the default edge values !! for a simple 2nd order scheme. type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + integer :: k !< vertical grid index ! Local variables with useful mnemonic names. - real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slopes. - real, parameter :: oneSixth = 1./6. + real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slopes per grid point [H ~> m or kg m-2] + real, parameter :: oneSixth = 1./6. ! [nondim] real :: h_jp1, h_jm1 ! Neighboring thicknesses or sensibly extrapolated values [H ~> m or kg m-2] real :: dMx, dMn ! The difference between the local thickness and the maximum (dMx) or ! minimum (dMn) of the surrounding values [H ~> m or kg m-2] @@ -2032,13 +2520,13 @@ subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ if ((isl < G%isd) .or. (iel > G%ied)) then write(mesg,'("In MOM_continuity_PPM, PPM_reconstruction_y called with a ", & - & "x-halo that needs to be increased by ",i2,".")') & + & "x-halo that needs to be increased by ",I0,".")') & max(G%isd-isl,iel-G%ied) call MOM_error(FATAL,mesg) endif if ((jsl-stencil < G%jsd) .or. (jel+stencil > G%jed)) then write(mesg,'("In MOM_continuity_PPM, PPM_reconstruction_y called with a ", & - & "y-halo that needs to be increased by ",i2,".")') & + & "y-halo that needs to be increased by ",I0,".")') & stencil + max(G%jsd-jsl,jel-G%jed) call MOM_error(FATAL,mesg) endif @@ -2047,8 +2535,8 @@ subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ do j=jsl,jel ; do i=isl,iel h_jm1 = G%mask2dT(i,j-1) * h_in(i,j-1) + (1.0-G%mask2dT(i,j-1)) * h_in(i,j) h_jp1 = G%mask2dT(i,j+1) * h_in(i,j+1) + (1.0-G%mask2dT(i,j+1)) * h_in(i,j) - h_L(i,j) = 0.5*( h_jm1 + h_in(i,j) ) - h_R(i,j) = 0.5*( h_jp1 + h_in(i,j) ) + h_S(i,j) = 0.5*( h_jm1 + h_in(i,j) ) + h_N(i,j) = 0.5*( h_jp1 + h_in(i,j) ) enddo ; enddo else do j=jsl-1,jel+1 ; do i=isl,iel @@ -2069,8 +2557,7 @@ subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ do n=1, OBC%number_of_segments segment => OBC%segment(n) if (.not. segment%on_pe) cycle - if (segment%direction == OBC_DIRECTION_S .or. & - segment%direction == OBC_DIRECTION_N) then + if (segment%is_N_or_S) then J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied slp(i,j+1) = 0.0 @@ -2086,8 +2573,8 @@ subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ h_jm1 = G%mask2dT(i,j-1) * h_in(i,j-1) + (1.0-G%mask2dT(i,j-1)) * h_in(i,j) h_jp1 = G%mask2dT(i,j+1) * h_in(i,j+1) + (1.0-G%mask2dT(i,j+1)) * h_in(i,j) ! Left/right values following Eq. B2 in Lin 1994, MWR (132) - h_L(i,j) = 0.5*( h_jm1 + h_in(i,j) ) + oneSixth*( slp(i,j-1) - slp(i,j) ) - h_R(i,j) = 0.5*( h_jp1 + h_in(i,j) ) + oneSixth*( slp(i,j) - slp(i,j+1) ) + h_S(i,j) = 0.5*( h_jm1 + h_in(i,j) ) + oneSixth*( slp(i,j-1) - slp(i,j) ) + h_N(i,j) = 0.5*( h_jp1 + h_in(i,j) ) + oneSixth*( slp(i,j) - slp(i,j+1) ) enddo ; enddo endif @@ -2097,28 +2584,46 @@ subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ if (.not. segment%on_pe) cycle if (segment%direction == OBC_DIRECTION_N) then J=segment%HI%JsdB - do i=segment%HI%isd,segment%HI%ied - h_L(i,j+1) = h_in(i,j) - h_R(i,j+1) = h_in(i,j) - h_L(i,j) = h_in(i,j) - h_R(i,j) = h_in(i,j) - enddo + if (associated(segment%h_Reg)) then + do i=segment%HI%isd,segment%HI%ied + h_S(i,j+1) = segment%h_Reg%h_res(i,j,k) + h_N(i,j+1) = segment%h_Reg%h_res(i,j,k) + h_S(i,j) = segment%h_Reg%h_res(i,j,k) + h_N(i,j) = segment%h_Reg%h_res(i,j,k) + enddo + else + do i=segment%HI%isd,segment%HI%ied + h_S(i,j+1) = h_in(i,j) + h_N(i,j+1) = h_in(i,j) + h_S(i,j) = h_in(i,j) + h_N(i,j) = h_in(i,j) + enddo + endif elseif (segment%direction == OBC_DIRECTION_S) then J=segment%HI%JsdB - do i=segment%HI%isd,segment%HI%ied - h_L(i,j) = h_in(i,j+1) - h_R(i,j) = h_in(i,j+1) - h_L(i,j+1) = h_in(i,j+1) - h_R(i,j+1) = h_in(i,j+1) - enddo + if (associated(segment%h_Reg)) then + do i=segment%HI%isd,segment%HI%ied + h_S(i,j) = segment%h_Reg%h_res(i,j,k) + h_N(i,j) = segment%h_Reg%h_res(i,j,k) + h_S(i,j+1) = segment%h_Reg%h_res(i,j,k) + h_N(i,j+1) = segment%h_Reg%h_res(i,j,k) + enddo + else + do i=segment%HI%isd,segment%HI%ied + h_S(i,j) = h_in(i,j+1) + h_N(i,j) = h_in(i,j+1) + h_S(i,j+1) = h_in(i,j+1) + h_N(i,j+1) = h_in(i,j+1) + enddo + endif endif enddo endif if (monotonic) then - call PPM_limit_CW84(h_in, h_L, h_R, G, isl, iel, jsl, jel) + call PPM_limit_CW84(h_in, h_S, h_N, G, isl, iel, jsl, jel) else - call PPM_limit_pos(h_in, h_L, h_R, h_min, G, isl, iel, jsl, jel) + call PPM_limit_pos(h_in, h_S, h_N, h_min, G, isl, iel, jsl, jel) endif return @@ -2134,7 +2639,7 @@ subroutine PPM_limit_pos(h_in, h_L, h_R, h_min, G, iis, iie, jis, jie) real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_L !< Left thickness in the reconstruction [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_R !< Right thickness in the reconstruction [H ~> m or kg m-2]. real, intent(in) :: h_min !< The minimum thickness - !! that can be obtained by a concave parabolic fit. + !! that can be obtained by a concave parabolic fit [H ~> m or kg m-2] integer, intent(in) :: iis !< Start of i index range. integer, intent(in) :: iie !< End of i index range. integer, intent(in) :: jis !< Start of j index range. @@ -2149,7 +2654,7 @@ subroutine PPM_limit_pos(h_in, h_L, h_R, h_min, G, iis, iie, jis, jie) do j=jis,jie ; do i=iis,iie ! This limiter prevents undershooting minima within the domain with ! values less than h_min. - curv = 3.0*(h_L(i,j) + h_R(i,j) - 2.0*h_in(i,j)) + curv = 3.0*((h_L(i,j) + h_R(i,j)) - 2.0*h_in(i,j)) if (curv > 0.0) then ! Only minima are limited. dh = h_R(i,j) - h_L(i,j) if (abs(dh) < curv) then ! The parabola's minimum is within the cell. @@ -2211,10 +2716,10 @@ end subroutine PPM_limit_CW84 !> Return the maximum ratio of a/b or maxrat. function ratio_max(a, b, maxrat) result(ratio) - real, intent(in) :: a !< Numerator - real, intent(in) :: b !< Denominator - real, intent(in) :: maxrat !< Maximum value of ratio. - real :: ratio !< Return value. + real, intent(in) :: a !< Numerator, in arbitrary units [A] + real, intent(in) :: b !< Denominator, in arbitrary units [B] + real, intent(in) :: maxrat !< Maximum value of ratio [A B-1] + real :: ratio !< Return value [A B-1] if (abs(a) > abs(maxrat*b)) then ratio = maxrat @@ -2224,23 +2729,33 @@ function ratio_max(a, b, maxrat) result(ratio) end function ratio_max !> Initializes continuity_ppm_cs -subroutine continuity_PPM_init(Time, G, GV, US, param_file, diag, CS) +subroutine continuity_PPM_init(Time, G, GV, US, param_file, diag, CS, OBC) type(time_type), target, intent(in) :: Time !< The current model time. 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 + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure indicating !! the open file to parse for model parameter values. type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to !! regulate diagnostic output. type(continuity_PPM_CS), intent(inout) :: CS !< Module's control structure. + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + logical :: local_open_BC, use_h_marg_min + type(OBC_segment_type), pointer :: segment => NULL() + integer :: n !> This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_continuity_PPM" ! This module's name. + character(len=256) :: mesg CS%initialized = .true. + local_open_BC = .false. + if (associated(OBC)) then + local_open_BC = OBC%open_u_BCs_exist_globally + endif + ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "MONOTONIC_CONTINUITY", CS%monotonic, & @@ -2291,20 +2806,42 @@ subroutine continuity_PPM_init(Time, G, GV, US, param_file, diag, CS) "If true, stop corrective iterations using a velocity "//& "based criterion and only stop if the iteration is "//& "better than all predecessors.", default=.true.) - call get_param(param_file, mdl, "CONT_PPM_USE_VISC_REM_MAX", & - CS%use_visc_rem_max, & + call get_param(param_file, mdl, "CONT_PPM_USE_VISC_REM_MAX", CS%use_visc_rem_max, & "If true, use more appropriate limiting bounds for "//& "corrections in strongly viscous columns.", default=.true.) call get_param(param_file, mdl, "CONT_PPM_MARGINAL_FACE_AREAS", CS%marginal_faces, & "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, "CONT_USE_H_MARG_MIN", use_h_marg_min, & + "If true, the marginal thickness used and returned from continuity "//& + "is bounded from below by a sub-roundoff value. Otherwise the "//& + "minimum is 0.", default=.false.) CS%diag => diag + id_clock_reconstruct = cpu_clock_id('(Ocean continuity reconstruction)', grain=CLOCK_ROUTINE) id_clock_update = cpu_clock_id('(Ocean continuity update)', grain=CLOCK_ROUTINE) id_clock_correct = cpu_clock_id('(Ocean continuity correction)', grain=CLOCK_ROUTINE) + if (use_h_marg_min) then + CS%h_marg_min = GV%H_subroundoff + else + CS%h_marg_min = 0. + endif + + if (local_open_BC) then + do n=1, OBC%number_of_segments + segment => OBC%segment(n) + if (associated(segment%h_Reg)) then + if (.not. allocated(segment%h_Reg%h_res)) then + write(mesg,'("In MOM_continuity_PPM, continuity_PPM_init called with ", & + & "badly configured h_res.")') + call MOM_error(FATAL, mesg) + endif + endif + enddo + endif + end subroutine continuity_PPM_init !> continuity_PPM_stencil returns the continuity solver stencil size @@ -2316,6 +2853,39 @@ function continuity_PPM_stencil(CS) result(stencil) end function continuity_PPM_stencil +!> Set up a structure that stores the sizes of the i- and j-loops to to work on in the continuity solver. +function set_continuity_loop_bounds(G, CS, i_stencil, j_stencil) result(LB) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(continuity_PPM_CS), intent(in) :: CS !< Module's control structure. + logical, optional, intent(in) :: i_stencil !< If present and true, extend the i-loop bounds + !! by the stencil width of the continuity scheme. + logical, optional, intent(in) :: j_stencil !< If present and true, extend the j-loop bounds + !! by the stencil width of the continuity scheme. + type(cont_loop_bounds_type) :: LB !< A type storing the array sizes to work on in the continuity routines. + + ! Local variables + logical :: add_i_stencil, add_j_stencil ! Local variables set based on i_stencil and j_stensil + integer :: stencil ! The continuity solver stencil size with the current continuity scheme. + + add_i_stencil = .false. ; if (present(i_stencil)) add_i_stencil = i_stencil + add_j_stencil = .false. ; if (present(j_stencil)) add_j_stencil = j_stencil + + stencil = continuity_PPM_stencil(CS) + + if (add_i_stencil) then + LB%ish = G%isc-stencil ; LB%ieh = G%iec+stencil + else + LB%ish = G%isc ; LB%ieh = G%iec + endif + + if (add_j_stencil) then + LB%jsh = G%jsc-stencil ; LB%jeh = G%jec+stencil + else + LB%jsh = G%jsc ; LB%jeh = G%jec + endif + +end function set_continuity_loop_bounds + !> \namespace mom_continuity_ppm !! !! This module contains the subroutines that advect layer diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 8f26918253..bb398d9f00 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -1,15 +1,18 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Provides integrals of density module MOM_density_integrals -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_EOS, only : EOS_type -use MOM_EOS, only : EOS_quadrature +use MOM_EOS, only : EOS_quadrature, EOS_domain use MOM_EOS, only : analytic_int_density_dz use MOM_EOS, only : analytic_int_specific_vol_dp use MOM_EOS, only : calculate_density use MOM_EOS, only : calculate_spec_vol use MOM_EOS, only : calculate_specific_vol_derivs +use MOM_EOS, only : average_specific_vol use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg use MOM_hor_index, only : hor_index_type use MOM_string_functions, only : uppercase @@ -28,7 +31,9 @@ module MOM_density_integrals public int_specific_vol_dp public int_spec_vol_dp_generic_pcm public int_spec_vol_dp_generic_plm +public avg_specific_vol public find_depth_of_pressure_in_cell +public diagnose_mass_weight_Z, diagnose_mass_weight_p contains @@ -37,29 +42,30 @@ module MOM_density_integrals !! required for calculating the finite-volume form pressure accelerations in a !! Boussinesq model. subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, & - intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp, Z_0p) + intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, MassWghtInterp, Z_0p, & + MassWghtInterpVanOnly, h_nv) type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the arrays real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: T !< Potential temperature referenced to the surface [degC] + intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: S !< Salinity [ppt] + intent(in) :: S !< Salinity [S ~> ppt] real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m] real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] - real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that is !! subtracted out to reduce the magnitude of each of the !! integrals. - real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [kg m-3], that is used + real, intent(in) :: rho_0 !< A density [R ~> kg m-3], that is used !! to calculate the pressure (as p~=-z*rho_0*G_e) !! used in the equation of state. real, intent(in) :: G_e !< The Earth's gravitational acceleration - !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2] + !! [L2 Z-1 T-2 ~> m s-2] type(EOS_type), intent(in) :: EOS !< Equation of state structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(HI),SZJ_(HI)), & intent(inout) :: dpa !< The change in the pressure anomaly - !! across the layer [R L2 T-2 ~> Pa] or [Pa] + !! across the layer [R L2 T-2 ~> Pa] real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(inout) :: intz_dpa !< The integral through the thickness of the !! layer of the pressure anomaly relative to the @@ -74,17 +80,26 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: SSH !< The sea surface height [Z ~> m] real, optional, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals + logical, optional, intent(in) :: MassWghtInterpVanOnly !< If true, does not do mass weighting + !! of T/S unless one side smaller than h_nv (i.e. vanished) + real, optional, intent(in) :: h_nv !< Nonvanished height [Z ~> m] + + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] if (EOS_quadrature(EOS)) then call int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, US, dpa, & - intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp, Z_0p=Z_0p) + intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, & + MassWghtInterp, Z_0p=Z_0p, MassWghtInterpVanOnly=MassWghtInterpVanOnly, & + h_nv=h_nv) else call analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & - intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp, Z_0p=Z_0p) + intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, MassWghtInterp, Z_0p=Z_0p) endif end subroutine int_density_dz @@ -93,30 +108,31 @@ end subroutine int_density_dz !> Calculates (by numerical quadrature) integrals of pressure anomalies across layers, which !! are required for calculating the finite-volume form pressure accelerations in a Boussinesq model. subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - EOS, US, dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & - dz_neglect, useMassWghtInterp, use_inaccurate_form, Z_0p) + EOS, US, dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, & + dz_neglect, MassWghtInterp, use_inaccurate_form, Z_0p, & + MassWghtInterpVanOnly, h_nv) type(hor_index_type), intent(in) :: HI !< Horizontal index type for input variables. real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: T !< Potential temperature of the layer [degC] + intent(in) :: T !< Potential temperature of the layer [C ~> degC] real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: S !< Salinity of the layer [ppt] + intent(in) :: S !< Salinity of the layer [S ~> ppt] real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m] real, dimension(SZI_(HI),SZJ_(HI)), & intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] - real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that is !! subtracted out to reduce the magnitude !! of each of the integrals. - real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [kg m-3], that is used + real, intent(in) :: rho_0 !< A density [R ~> kg m-3], that is used !! to calculate the pressure (as p~=-z*rho_0*G_e) !! used in the equation of state. real, intent(in) :: G_e !< The Earth's gravitational acceleration - !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2] + !! [L2 Z-1 T-2 ~> m s-2] type(EOS_type), intent(in) :: EOS !< Equation of state structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(HI),SZJ_(HI)), & intent(inout) :: dpa !< The change in the pressure anomaly - !! across the layer [R L2 T-2 ~> Pa] or [Pa] + !! across the layer [R L2 T-2 ~> Pa] real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(inout) :: intz_dpa !< The integral through the thickness of the !! layer of the pressure anomaly relative to the @@ -131,26 +147,35 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: SSH !< The sea surface height [Z ~> m] real, optional, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals + logical, optional, intent(in) :: MassWghtInterpVanOnly !< If true, does not do mass weighting + !! of T/S unless one side smaller than h_nv (i.e. vanished) + real, optional, intent(in) :: h_nv !< Nonvanished height [Z ~> m] logical, optional, intent(in) :: use_inaccurate_form !< If true, uses an inaccurate form of !! density anomalies, as was used prior to March 2018. - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! Local variables - real :: T5(5), S5(5) ! Temperatures and salinities at five quadrature points [degC] and [ppt] - real :: p5(5) ! Pressures at five quadrature points, never rescaled from Pa [Pa] - real :: r5(5) ! Densities at five quadrature points [R ~> kg m-3] or [kg m-3] - real :: rho_anom ! The depth averaged density anomaly [R ~> kg m-3] or [kg m-3] - real :: w_left, w_right ! Left and right weights [nondim] - real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. - real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] - real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] - real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] - real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] + real :: T5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Temperatures along a line of subgrid locations [C ~> degC] + real :: S5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Salinities along a line of subgrid locations [S ~> ppt] + real :: p5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Pressures along a line of subgrid locations [R L2 T-2 ~> Pa] + real :: r5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Densities anomalies along a line of subgrid locations [R ~> kg m-3] + real :: T15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Temperatures at an array of subgrid locations [C ~> degC] + real :: S15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Salinities at an array of subgrid locations [S ~> ppt] + real :: p15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Pressures at an array of subgrid locations [R L2 T-2 ~> Pa] + real :: r15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Densities at an array of subgrid locations [R ~> kg m-3] + real :: rho_anom ! The depth averaged density anomaly [R ~> kg m-3] + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] + real :: GxRho ! The product of the gravitational acceleration and reference density [R L2 Z-1 T-2 ~> Pa m-1] real :: dz ! The layer thickness [Z ~> m] - real :: z0pres ! The height at which the pressure is zero [Z ~> m] + real :: dz_x(5,HI%iscB:HI%iecB) ! Layer thicknesses along an x-line of subgrid locations [Z ~> m] + real :: dz_y(5,HI%isc:HI%iec) ! Layer thicknesses along a y-line of subgrid locations [Z ~> m] + real :: z0pres(HI%isd:HI%ied,HI%jsd:HI%jed) ! The height at which the pressure is zero [Z ~> m] real :: hWght ! A pressure-thickness below topography [Z ~> m] real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m] real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> m-2] @@ -159,11 +184,18 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim] real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim] real :: intz(5) ! The gravitational acceleration times the integrals of density - ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa] - logical :: do_massWeight ! Indicates whether to do mass weighting. + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] + logical :: do_massWeight ! Indicates whether to do mass weighting near bathymetry + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface + real :: massWeightNVonlyToggle ! A non-dimensional toggle factor for only using mass weighting + ! if at least one side vanished (0 or 1) [nondim] + real :: h_nonvanished ! nonvanished height [Z ~> m] logical :: use_rho_ref ! Pass rho_ref to the equation of state for more accurate calculation ! of density anomalies. - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m, n + integer, dimension(2) :: EOSdom_h5 ! The 5-point h-point i-computational domain for the equation of state + integer, dimension(2) :: EOSdom_q15 ! The 3x5-point q-point i-computational domain for the equation of state + integer, dimension(2) :: EOSdom_h15 ! The 3x5-point h-point i-computational domain for the equation of state + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m, n, pos ! These array bounds work for the indexing convention of the input arrays, but ! on the computational domain defined for the output arrays. @@ -172,192 +204,240 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & is = HI%isc ; ie = HI%iec js = HI%jsc ; je = HI%jec - rho_scale = US%kg_m3_to_R - GxRho = US%RL2_T2_to_Pa * G_e * rho_0 - rho_ref_mks = rho_ref * US%R_to_kg_m3 - I_Rho = 1.0 / rho_0 - z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p + GxRho = G_e * rho_0 + if (present(Z_0p)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + z0pres(i,j) = Z_0p(i,j) + enddo ; enddo + else + z0pres(:,:) = 0.0 + endif use_rho_ref = .true. if (present(use_inaccurate_form)) then if (use_inaccurate_form) use_rho_ref = .not. use_inaccurate_form endif - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. - if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& - "bathyT must be present if useMassWghtInterp is present and true.") - if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& - "dz_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif - - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dz = z_t(i,j) - z_b(i,j) - do n=1,5 - T5(n) = T(i,j) ; S5(n) = S(i,j) - p5(n) = -GxRho*((z_t(i,j) - z0pres) - 0.25*real(n-1)*dz) + do_massWeight = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + if (do_massWeight .and. .not.present(bathyT)) call MOM_error(FATAL, & + "int_density_dz_generic: bathyT must be present if near-bottom mass weighting is in use.") + if (top_massWeight .and. .not.present(SSH)) call MOM_error(FATAL, & + "int_density_dz_generic: SSH must be present if near-surface mass weighting is in use.") + if ((do_massWeight .or. top_massWeight) .and. .not.present(dz_neglect)) call MOM_error(FATAL, & + "int_density_dz_generic: dz_neglect must be present if mass weighting is in use.") + endif + massWeightNVonlyToggle = 1. + if (present(MassWghtInterpVanOnly)) then + if (MassWghtInterpVanOnly) massWeightNVonlyToggle = 0. + endif + h_nonvanished = 0. + if (present(h_nv)) then + h_nonvanished = h_nv + endif + + ! Set the loop ranges for equation of state calculations at various points. + EOSdom_h5(1) = 1 ; EOSdom_h5(2) = 5*(Ieq-Isq+2) + EOSdom_q15(1) = 1 ; EOSdom_q15(2) = 15*(Ieq-Isq+1) + EOSdom_h15(1) = 1 ; EOSdom_h15(2) = 15*(HI%iec-HI%isc+1) + + do j=Jsq,Jeq+1 + do i=Isq,Ieq+1 + dz = z_t(i,j) - z_b(i,j) + do n=1,5 + T5(i*5+n) = T(i,j) ; S5(i*5+n) = S(i,j) + p5(i*5+n) = -GxRho*((z_t(i,j) - z0pres(i,j)) - 0.25*real(n-1)*dz) + enddo enddo + if (use_rho_ref) then - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) - endif - ! Use Boole's rule to estimate the pressure anomaly change. - rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) + call calculate_density(T5, S5, p5, r5, EOS, EOSdom_h5, rho_ref=rho_ref) else - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, scale=rho_scale) + call calculate_density(T5, S5, p5, r5, EOS, EOSdom_h5) + endif + + do i=Isq,Ieq+1 + ! Use Boole's rule to estimate the pressure anomaly change. + rho_anom = C1_90*(7.0*(r5(i*5+1)+r5(i*5+5)) + 32.0*(r5(i*5+2)+r5(i*5+4)) + 12.0*r5(i*5+3)) + if (.not.use_rho_ref) rho_anom = rho_anom - rho_ref + dz = z_t(i,j) - z_b(i,j) + dpa(i,j) = G_e*dz*rho_anom + ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of + ! the pressure anomaly. + if (present(intz_dpa)) intz_dpa(i,j) = 0.5*G_e*dz**2 * & + (rho_anom - C1_90*(16.0*(r5(i*5+4)-r5(i*5+2)) + 7.0*(r5(i*5+5)-r5(i*5+1))) ) + enddo + enddo + + if (present(intx_dpa)) then ; do j=js,je + do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i+1,j)-SSH(i,j), z_b(i,j)-SSH(i+1,j)) + ! If both sides are nonvanished, then set it back to zero. + if (((z_t(i,j) - z_b(i,j)) > h_nonvanished) .and. ((z_t(i+1,j) - z_b(i+1,j)) > h_nonvanished)) then + hWght = massWeightNVonlyToggle * hWght + endif + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS) + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 endif - ! Use Boole's rule to estimate the pressure anomaly change. - rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) - rho_ref - endif - dpa(i,j) = G_e*dz*rho_anom - ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of - ! the pressure anomaly. - if (present(intz_dpa)) intz_dpa(i,j) = 0.5*G_e*dz**2 * & - (rho_anom - C1_90*(16.0*(r5(4)-r5(2)) + 7.0*(r5(5)-r5(1))) ) - enddo ; enddo + do m=2,4 + ! T, S, and z are interpolated in the horizontal. The z interpolation + ! is linear, but for T and S it may be thickness weighted. + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR) + dz_x(m,i) = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j))) + pos = i*15+(m-2)*5 + T15(pos+1) = (wtT_L*T(i,j)) + (wtT_R*T(i+1,j)) + S15(pos+1) = (wtT_L*S(i,j)) + (wtT_R*S(i+1,j)) + p15(pos+1) = -GxRho * ((wt_L*(z_t(i,j)-z0pres(i,j))) + (wt_R*(z_t(i+1,j)-z0pres(i+1,j)))) + do n=2,5 + T15(pos+n) = T15(pos+1) ; S15(pos+n) = S15(pos+1) + p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i) + enddo + enddo + enddo - if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation of - ! T & S along the top and bottom integrals, akin to thickness weighting. - hWght = 0.0 - if (do_massWeight) & - hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) - if (hWght > 0.) then - hL = (z_t(i,j) - z_b(i,j)) + dz_neglect - hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + if (use_rho_ref) then + call calculate_density(T15, S15, p15, r15, EOS, EOSdom_q15, rho_ref=rho_ref) else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + call calculate_density(T15, S15, p15, r15, EOS, EOSdom_q15) endif - intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) - do m=2,4 - ! T, S, and z are interpolated in the horizontal. The z interpolation - ! is linear, but for T and S it may be thickness weighted. - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j)) - T5(1) = wtT_L*T(i,j) + wtT_R*T(i+1,j) - S5(1) = wtT_L*S(i,j) + wtT_R*S(i+1,j) - p5(1) = -GxRho*((wt_L*z_t(i,j) + wt_R*z_t(i+1,j)) - z0pres) - do n=2,5 - T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) + GxRho*0.25*dz - enddo + do I=Isq,Ieq + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + ! Use Boole's rule to estimate the pressure anomaly change. if (use_rho_ref) then - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) - endif - ! Use Boole's rule to estimate the pressure anomaly change. - intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3))) + do m=2,4 + pos = i*15+(m-2)*5 + intz(m) = (G_e*dz_x(m,i)*(C1_90*( 7.0*(r15(pos+1)+r15(pos+5)) + & + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3)) )) + enddo else - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, scale=rho_scale) - else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS) - endif - ! Use Boole's rule to estimate the pressure anomaly change. - intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) - rho_ref ) + do m=2,4 + pos = i*15+(m-2)*5 + intz(m) = (G_e*dz_x(m,i)*(C1_90*( 7.0*(r15(pos+1)+r15(pos+5)) + & + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3)) - rho_ref )) + enddo + endif + ! Use Boole's rule to integrate the bottom pressure anomaly values in x. + intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) + enddo + enddo ; endif + + if (present(inty_dpa)) then ; do J=Jsq,Jeq + do i=is,ie + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i,j+1)-SSH(i,j), z_b(i,j)-SSH(i,j+1)) + ! If both sides are nonvanished, then set it back to zero. + if (((z_t(i,j) - z_b(i,j)) > h_nonvanished) .and. ((z_t(i,j+1) - z_b(i,j+1)) > h_nonvanished)) then + hWght = massWeightNVonlyToggle * hWght + endif + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 endif + do m=2,4 + ! T, S, and z are interpolated in the horizontal. The z interpolation + ! is linear, but for T and S it may be thickness weighted. + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR) + dz_y(m,i) = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1))) + pos = i*15+(m-2)*5 + T15(pos+1) = (wtT_L*T(i,j)) + (wtT_R*T(i,j+1)) + S15(pos+1) = (wtT_L*S(i,j)) + (wtT_R*S(i,j+1)) + p15(pos+1) = -GxRho * ((wt_L*(z_t(i,j)-z0pres(i,j))) + (wt_R*(z_t(i,j+1)-z0pres(i,j+1)))) + do n=2,5 + T15(pos+n) = T15(pos+1) ; S15(pos+n) = S15(pos+1) + p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) + enddo + enddo enddo - ! Use Boole's rule to integrate the bottom pressure anomaly values in x. - intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & - 12.0*intz(3)) - enddo ; enddo ; endif - if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=is,ie - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation of - ! T & S along the top and bottom integrals, akin to thickness weighting. - hWght = 0.0 - if (do_massWeight) & - hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) - if (hWght > 0.) then - hL = (z_t(i,j) - z_b(i,j)) + dz_neglect - hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + if (use_rho_ref) then + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + r15(15*HI%isc+1:), EOS, EOSdom_h15, rho_ref=rho_ref) else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + r15(15*HI%isc+1:), EOS, EOSdom_h15) endif - intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) - do m=2,4 - ! T, S, and z are interpolated in the horizontal. The z interpolation - ! is linear, but for T and S it may be thickness weighted. - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1)) - T5(1) = wtT_L*T(i,j) + wtT_R*T(i,j+1) - S5(1) = wtT_L*S(i,j) + wtT_R*S(i,j+1) - p5(1) = -GxRho*((wt_L*z_t(i,j) + wt_R*z_t(i,j+1)) - z0pres) - do n=2,5 - T5(n) = T5(1) ; S5(n) = S5(1) - p5(n) = p5(n-1) + GxRho*0.25*dz - enddo - if (use_rho_ref) then - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks) - endif - ! Use Boole's rule to estimate the pressure anomaly change. - intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3))) - else - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, scale=rho_scale) + do i=is,ie + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + ! Use Boole's rule to estimate the pressure anomaly change. + do m=2,4 + pos = i*15+(m-2)*5 + if (use_rho_ref) then + intz(m) = (G_e*dz_y(m,i)*(C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + & + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3)) )) else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS) + intz(m) = (G_e*dz_y(m,i)*(C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + & + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3)) - rho_ref )) endif - ! Use Boole's rule to estimate the pressure anomaly change. - intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) - rho_ref ) - endif - + enddo + ! Use Boole's rule to integrate the values. + inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) enddo - ! Use Boole's rule to integrate the values. - inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & - 12.0*intz(3)) - enddo ; enddo ; endif + enddo ; endif end subroutine int_density_dz_generic_pcm !> Compute pressure gradient force integrals by quadrature for the case where !! T and S are linear profiles. subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & - rho_0, G_e, dz_subroundoff, bathyT, HI, GV, EOS, US, dpa, & - intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp, & - use_inaccurate_form, Z_0p) + rho_0, G_e, dz_subroundoff, bathyT, HI, GV, EOS, US, use_stanley_eos, dpa, & + intz_dpa, intx_dpa, inty_dpa, MassWghtInterp, & + use_inaccurate_form, Z_0p, MassWghtInterpVanOnly, h_nv) integer, intent(in) :: k !< Layer index to calculate integrals for type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & - intent(in) :: T_t !< Potential temperature at the cell top [degC] + intent(in) :: T_t !< Potential temperature at the cell top [C ~> degC] real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & - intent(in) :: T_b !< Potential temperature at the cell bottom [degC] + intent(in) :: T_b !< Potential temperature at the cell bottom [C ~> degC] real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & - intent(in) :: S_t !< Salinity at the cell top [ppt] + intent(in) :: S_t !< Salinity at the cell top [S ~> ppt] real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & - intent(in) :: S_b !< Salinity at the cell bottom [ppt] + intent(in) :: S_b !< Salinity at the cell bottom [S ~> ppt] real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)+1), & intent(in) :: e !< Height of interfaces [Z ~> m] - real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is subtracted + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that is subtracted !! out to reduce the magnitude of each of the integrals. - real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [kg m-3], that is used to calculate + real, intent(in) :: rho_0 !< A density [R ~> kg m-3], that is used to calculate !! the pressure (as p~=-z*rho_0*G_e) used in the equation of state. real, intent(in) :: G_e !< The Earth's gravitational acceleration [L2 Z-1 T-2 ~> m s-2] real, intent(in) :: dz_subroundoff !< A minuscule thickness change [Z ~> m] @@ -365,6 +445,7 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] type(EOS_type), intent(in) :: EOS !< Equation of state structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + logical, intent(in) :: use_stanley_eos !< If true, turn on Stanley SGS T variance parameterization real, dimension(SZI_(HI),SZJ_(HI)), & intent(inout) :: dpa !< The change in the pressure anomaly across the layer [R L2 T-2 ~> Pa] real, dimension(SZI_(HI),SZJ_(HI)), & @@ -379,11 +460,15 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & optional, intent(inout) :: inty_dpa !< The integral in y of the difference between the !! pressure anomaly at the top and bottom of the layer !! divided by the y grid spacing [R L2 T-2 ~> Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals logical, optional, intent(in) :: use_inaccurate_form !< If true, uses an inaccurate form of !! density anomalies, as was used prior to March 2018. - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + logical, optional, intent(in) :: MassWghtInterpVanOnly !< If true, does not do mass weighting + !! of T/S unless one side smaller than h_nv (i.e. vanished) + real, optional, intent(in) :: h_nv !< Nonvanished height [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! This subroutine calculates (by numerical quadrature) integrals of ! pressure anomalies across layers, which are required for calculating the @@ -397,72 +482,93 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & ! a linear interpolation is used to compute intermediate values. ! Local variables - real :: T5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Temperatures along a line of subgrid locations [degC] - real :: S5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Salinities along a line of subgrid locations [ppt] - real :: T25((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS temperature variance along a line of subgrid locations [degC2] - real :: TS5((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS temp-salt covariance along a line of subgrid locations [degC ppt] - real :: S25((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS salinity variance along a line of subgrid locations [ppt2] - real :: p5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Pressures along a line of subgrid locations, never - ! rescaled from Pa [Pa] + real :: T5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Temperatures along a line of subgrid locations [C ~> degC] + real :: S5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Salinities along a line of subgrid locations [S ~> ppt] + real :: T25((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS temperature variance along a line of subgrid + ! locations [C2 ~> degC2] + real :: TS5((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS temp-salt covariance along a line of subgrid + ! locations [C S ~> degC ppt] + real :: S25((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS salinity variance along a line of subgrid locations [S2 ~> ppt2] + real :: p5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Pressures along a line of subgrid locations [R L2 T-2 ~> Pa] real :: r5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Densities anomalies along a line of subgrid - ! locations [R ~> kg m-3] or [kg m-3] + ! locations [R ~> kg m-3] real :: u5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Densities anomalies along a line of subgrid locations - ! (used for inaccurate form) [R ~> kg m-3] or [kg m-3] - real :: T15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Temperatures at an array of subgrid locations [degC] - real :: S15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Salinities at an array of subgrid locations [ppt] - real :: T215((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS temperature variance along a line of subgrid locations [degC2] - real :: TS15((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS temp-salt covariance along a line of subgrid locations [degC ppt] - real :: S215((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS salinity variance along a line of subgrid locations [ppt2] - real :: p15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Pressures at an array of subgrid locations [Pa] - real :: r15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Densities at an array of subgrid locations - ! [R ~> kg m-3] or [kg m-3] + ! (used for inaccurate form) [R ~> kg m-3] + real :: T15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Temperatures at an array of subgrid locations [C ~> degC] + real :: S15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Salinities at an array of subgrid locations [S ~> ppt] + real :: T215((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS temperature variance along a line of subgrid + ! locations [C2 ~> degC2] + real :: TS15((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS temp-salt covariance along a line of subgrid + ! locations [C S ~> degC ppt] + real :: S215((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS salinity variance along a line of subgrid + ! locations [S2 ~> ppt2] + real :: p15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Pressures at an array of subgrid locations [R L2 T-2 ~> Pa] + real :: r15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Densities at an array of subgrid locations [R ~> kg m-3] real :: wt_t(5), wt_b(5) ! Top and bottom weights [nondim] - real :: rho_anom ! A density anomaly [R ~> kg m-3] or [kg m-3] + real :: rho_anom ! A density anomaly [R ~> kg m-3] real :: w_left, w_right ! Left and right weights [nondim] real :: intz(5) ! The gravitational acceleration times the integrals of density - ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa] + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] - real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] - real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] - real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] - real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] + real :: GxRho ! The product of the gravitational acceleration and reference density [R L2 Z-1 T-2 ~> Pa m-1] real :: dz(HI%iscB:HI%iecB+1) ! Layer thicknesses at tracer points [Z ~> m] real :: dz_x(5,HI%iscB:HI%iecB) ! Layer thicknesses along an x-line of subgrid locations [Z ~> m] real :: dz_y(5,HI%isc:HI%iec) ! Layer thicknesses along a y-line of subgrid locations [Z ~> m] - real :: massWeightToggle ! A non-dimensional toggle factor (0 or 1) [nondim] - real :: Ttl, Tbl, Ttr, Tbr ! Temperatures at the velocity cell corners [degC] - real :: Stl, Sbl, Str, Sbr ! Salinities at the velocity cell corners [ppt] - real :: z0pres ! The height at which the pressure is zero [Z ~> m] + real :: massWeightToggle ! A non-dimensional toggle factor for near-bottom mass weighting (0 or 1) [nondim] + real :: TopWeightToggle ! A non-dimensional toggle factor for near-surface mass weighting (0 or 1) [nondim] + real :: massWeightNVonlyToggle ! A non-dimensional toggle factor for only using mass weighting + ! if at least one side vanished (0 or 1) [nondim] + real :: Ttl, Tbl, Ttr, Tbr ! Temperatures at the velocity cell corners [C ~> degC] + real :: Stl, Sbl, Str, Sbr ! Salinities at the velocity cell corners [S ~> ppt] + real :: z0pres(HI%isd:HI%ied,HI%jsd:HI%jed) ! The height at which the pressure is zero [Z ~> m] real :: hWght ! A topographically limited thickness weight [Z ~> m] + real :: hWghtTop ! An ice draft limited thickness weight [Z ~> m] real :: hL, hR ! Thicknesses to the left and right [Z ~> m] real :: iDenom ! The denominator of the thickness weight expressions [Z-2 ~> m-2] - logical :: use_stanley_eos ! True is SGS variance fields exist in tv. + real :: h_nonvanished ! nonvanished height [Z ~> m] logical :: use_rho_ref ! Pass rho_ref to the equation of state for more accurate calculation ! of density anomalies. logical :: use_varT, use_varS, use_covarTS ! Logicals for SGS variances fields - integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n - integer :: pos + integer, dimension(2) :: EOSdom_h5 ! The 5-point h-point i-computational domain for the equation of state + integer, dimension(2) :: EOSdom_q15 ! The 3x5-point q-point i-computational domain for the equation of state + integer, dimension(2) :: EOSdom_h15 ! The 3x5-point h-point i-computational domain for the equation of state + integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n, pos Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB - rho_scale = US%kg_m3_to_R - GxRho = US%RL2_T2_to_Pa * G_e * rho_0 - rho_ref_mks = rho_ref * US%R_to_kg_m3 - I_Rho = 1.0 / rho_0 - z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p - massWeightToggle = 0. - if (present(useMassWghtInterp)) then - if (useMassWghtInterp) massWeightToggle = 1. + GxRho = G_e * rho_0 + if (present(Z_0p)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + z0pres(i,j) = Z_0p(i,j) + enddo ; enddo + else + z0pres(:,:) = 0.0 + endif + massWeightToggle = 0. ; TopWeightToggle = 0. + if (present(MassWghtInterp)) then + if (BTEST(MassWghtInterp, 0)) massWeightToggle = 1. + if (BTEST(MassWghtInterp, 1)) TopWeightToggle = 1. + endif + massWeightNVonlyToggle = 1. + if (present(MassWghtInterpVanOnly)) then + if (MassWghtInterpVanOnly) massWeightNVonlyToggle = 0. + endif + h_nonvanished = 0. + if (present(h_nv)) then + h_nonvanished = h_nv endif use_rho_ref = .true. - if (present(use_inaccurate_form)) then - if (use_inaccurate_form) use_rho_ref = .not. use_inaccurate_form + if (present(use_inaccurate_form)) use_rho_ref = .not. use_inaccurate_form + + use_varT = .false. !ensure initialized + use_covarTS = .false. + use_varS = .false. + if (use_stanley_eos) then + use_varT = associated(tv%varT) + use_covarTS = associated(tv%covarTS) + use_varS = associated(tv%varS) endif - use_varT = associated(tv%varT) - use_covarTS = associated(tv%covarTS) - use_varS = associated(tv%varS) - use_stanley_eos = use_varT .or. use_covarTS .or. use_varS T25(:) = 0. TS5(:) = 0. S25(:) = 0. @@ -475,12 +581,17 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & wt_b(n) = 1.0 - wt_t(n) enddo + ! Set the loop ranges for equation of state calculations at various points. + EOSdom_h5(1) = 1 ; EOSdom_h5(2) = 5*(Ieq-Isq+2) + EOSdom_q15(1) = 1 ; EOSdom_q15(2) = 15*(Ieq-Isq+1) + EOSdom_h15(1) = 1 ; EOSdom_h15(2) = 15*(HI%iec-HI%isc+1) + ! 1. Compute vertical integrals do j=Jsq,Jeq+1 do i = Isq,Ieq+1 dz(i) = e(i,j,K) - e(i,j,K+1) do n=1,5 - p5(i*5+n) = -GxRho*((e(i,j,K) - z0pres) - 0.25*real(n-1)*dz(i)) + p5(i*5+n) = -GxRho*((e(i,j,K) - z0pres(i,j)) - 0.25*real(n-1)*dz(i)) ! Salinity and temperature points are linearly interpolated S5(i*5+n) = wt_t(n) * S_t(i,j,k) + wt_b(n) * S_b(i,j,k) T5(i*5+n) = wt_t(n) * T_t(i,j,k) + wt_b(n) * T_b(i,j,k) @@ -490,27 +601,12 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & if (use_varS) S25(i*5+1:i*5+5) = tv%varS(i,j,k) enddo if (use_Stanley_eos) then - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, T25, TS5, S25, r5, 1, (ieq-isq+2)*5, EOS, & - rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density(T5, S5, p5, T25, TS5, S25, r5, 1, (ieq-isq+2)*5, EOS, & - rho_ref=rho_ref_mks) - endif + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, EOS, EOSdom_h5, rho_ref=rho_ref) else if (use_rho_ref) then - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks, & - scale=rho_scale) - else - call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref=rho_ref_mks) - endif + call calculate_density(T5, S5, p5, r5, EOS, EOSdom_h5, rho_ref=rho_ref) else - if (rho_scale /= 1.0) then - call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, scale=rho_scale) - else - call calculate_density(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS) - endif + call calculate_density(T5, S5, p5, r5, EOS, EOSdom_h5) u5(:) = r5(:) - rho_ref endif endif @@ -521,8 +617,8 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & rho_anom = C1_90*(7.0*(r5(i*5+1)+r5(i*5+5)) + 32.0*(r5(i*5+2)+r5(i*5+4)) + 12.0*r5(i*5+3)) dpa(i,j) = G_e*dz(i)*rho_anom if (present(intz_dpa)) then - ! Use a Boole's-rule-like fifth-order accurate estimate of - ! the double integral of the pressure anomaly. + ! Use a Boole's-rule-like fifth-order accurate estimate of + ! the double integral of the pressure anomaly. intz_dpa(i,j) = 0.5*G_e*dz(i)**2 * & (rho_anom - C1_90*(16.0*(r5(i*5+4)-r5(i*5+2)) + 7.0*(r5(i*5+5)-r5(i*5+1))) ) endif @@ -534,8 +630,8 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & - rho_ref dpa(i,j) = G_e*dz(i)*rho_anom if (present(intz_dpa)) then - ! Use a Boole's-rule-like fifth-order accurate estimate of - ! the double integral of the pressure anomaly. + ! Use a Boole's-rule-like fifth-order accurate estimate of + ! the double integral of the pressure anomaly. intz_dpa(i,j) = 0.5*G_e*dz(i)**2 * & (rho_anom - C1_90*(16.0*(u5(i*5+4)-u5(i*5+2)) + 7.0*(u5(i*5+5)-u5(i*5+1))) ) endif @@ -555,6 +651,21 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & ! this distance by the layer thickness to replicate other models. hWght = massWeightToggle * & max(0., -bathyT(i,j)-e(i+1,j,K), -bathyT(i+1,j)-e(i,j,K)) + ! CY: The below code just uses top interface, which may be bad in high res open ocean + ! We want something like if (pa(i+1,k+1) h_nonvanished) .and. ((e(i+1,j,K) - e(i+1,j,K+1)) > h_nonvanished)) then + hWght = massWeightNVonlyToggle * hWght + endif if (hWght > 0.) then hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff hR = (e(i+1,j,K) - e(i+1,j,K+1)) + dz_subroundoff @@ -569,26 +680,26 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & Sbl = ( (hWght*hR)*S_b(i+1,j,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i+1,j,k) ) * iDenom else - Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i+1,j,k); Tbr = T_b(i+1,j,k) - Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i+1,j,k); Sbr = S_b(i+1,j,k) + Ttl = T_t(i,j,k) ; Tbl = T_b(i,j,k) ; Ttr = T_t(i+1,j,k) ; Tbr = T_b(i+1,j,k) + Stl = S_t(i,j,k) ; Sbl = S_b(i,j,k) ; Str = S_t(i+1,j,k) ; Sbr = S_b(i+1,j,k) endif do m=2,4 w_left = wt_t(m) ; w_right = wt_b(m) - dz_x(m,i) = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i+1,j,K) - e(i+1,j,K+1)) + dz_x(m,i) = (w_left*(e(i,j,K) - e(i,j,K+1))) + (w_right*(e(i+1,j,K) - e(i+1,j,K+1))) ! Salinity and temperature points are linearly interpolated in ! the horizontal. The subscript (1) refers to the top value in ! the vertical profile while subscript (5) refers to the bottom ! value in the vertical profile. pos = i*15+(m-2)*5 - T15(pos+1) = w_left*Ttl + w_right*Ttr - T15(pos+5) = w_left*Tbl + w_right*Tbr + T15(pos+1) = (w_left*Ttl) + (w_right*Ttr) + T15(pos+5) = (w_left*Tbl) + (w_right*Tbr) - S15(pos+1) = w_left*Stl + w_right*Str - S15(pos+5) = w_left*Sbl + w_right*Sbr + S15(pos+1) = (w_left*Stl) + (w_right*Str) + S15(pos+5) = (w_left*Sbl) + (w_right*Sbr) - p15(pos+1) = -GxRho*((w_left*e(i,j,K) + w_right*e(i+1,j,K)) - z0pres) + p15(pos+1) = -GxRho * ((w_left*(e(i,j,K)-z0pres(i,j))) + (w_right*(e(i+1,j,K)-z0pres(i+1,j)))) ! Pressure do n=2,5 @@ -600,34 +711,19 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & S15(pos+n) = wt_t(n) * S15(pos+1) + wt_b(n) * S15(pos+5) T15(pos+n) = wt_t(n) * T15(pos+1) + wt_b(n) * T15(pos+5) enddo - if (use_varT) T215(pos+1:pos+5) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i+1,j,k) - if (use_covarTS) TS15(pos+1:pos+5) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i+1,j,k) - if (use_varS) S215(pos+1:pos+5) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i+1,j,k) + if (use_varT) T215(pos+1:pos+5) = (w_left*tv%varT(i,j,k)) + (w_right*tv%varT(i+1,j,k)) + if (use_covarTS) TS15(pos+1:pos+5) = (w_left*tv%covarTS(i,j,k)) + (w_right*tv%covarTS(i+1,j,k)) + if (use_varS) S215(pos+1:pos+5) = (w_left*tv%varS(i,j,k)) + (w_right*tv%varS(i+1,j,k)) enddo enddo if (use_stanley_eos) then - if (rho_scale /= 1.0) then - call calculate_density(T15, S15, p15, T215, TS15, S215, r15, 1, 15*(ieq-isq+1), EOS, & - rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density(T15, S15, p15, T215, TS15, S215, r15, 1, 15*(ieq-isq+1), EOS, & - rho_ref=rho_ref_mks) - endif + call calculate_density(T15, S15, p15, T215, TS15, S215, r15, EOS, EOSdom_q15, rho_ref=rho_ref) else if (use_rho_ref) then - if (rho_scale /= 1.0) then - call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks, & - scale=rho_scale) - else - call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref=rho_ref_mks) - endif + call calculate_density(T15, S15, p15, r15, EOS, EOSdom_q15, rho_ref=rho_ref) else - if (rho_scale /= 1.0) then - call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, scale=rho_scale) - else - call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS) - endif + call calculate_density(T15, S15, p15, r15, EOS, EOSdom_q15) endif endif @@ -638,14 +734,14 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & if (use_rho_ref) then do m = 2,4 pos = i*15+(m-2)*5 - intz(m) = G_e*dz_x(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + 32.0*(r15(pos+2)+r15(pos+4)) + & - 12.0*r15(pos+3)) ) + intz(m) = (G_e*dz_x(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3)) )) enddo else do m = 2,4 pos = i*15+(m-2)*5 - intz(m) = G_e*dz_x(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + 32.0*(r15(pos+2)+r15(pos+4)) + & - 12.0*r15(pos+3)) - rho_ref ) + intz(m) = (G_e*dz_x(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3)) - rho_ref )) enddo endif ! Use Boole's rule to integrate the bottom pressure anomaly values in x. @@ -666,6 +762,22 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & ! this distance by the layer thickness to replicate other models. hWght = massWeightToggle * & max(0., -bathyT(i,j)-e(i,j+1,K), -bathyT(i,j+1)-e(i,j,K)) + ! CY: The below code just uses top interface, which may be bad in high res open ocean + ! We want something like if (pa(j+1,k+1) h_nonvanished) .and. ((e(i,j+1,K) - e(i,j+1,K+1)) > h_nonvanished)) then + hWght = massWeightNVonlyToggle * hWght + endif + if (hWght > 0.) then hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff hR = (e(i,j+1,K) - e(i,j+1,K+1)) + dz_subroundoff @@ -680,26 +792,26 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & Sbl = ( (hWght*hR)*S_b(i,j+1,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i,j+1,k) ) * iDenom else - Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i,j+1,k); Tbr = T_b(i,j+1,k) - Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i,j+1,k); Sbr = S_b(i,j+1,k) + Ttl = T_t(i,j,k) ; Tbl = T_b(i,j,k) ; Ttr = T_t(i,j+1,k) ; Tbr = T_b(i,j+1,k) + Stl = S_t(i,j,k) ; Sbl = S_b(i,j,k) ; Str = S_t(i,j+1,k) ; Sbr = S_b(i,j+1,k) endif do m=2,4 w_left = wt_t(m) ; w_right = wt_b(m) - dz_y(m,i) = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i,j+1,K) - e(i,j+1,K+1)) + dz_y(m,i) = (w_left*(e(i,j,K) - e(i,j,K+1))) + (w_right*(e(i,j+1,K) - e(i,j+1,K+1))) ! Salinity and temperature points are linearly interpolated in ! the horizontal. The subscript (1) refers to the top value in ! the vertical profile while subscript (5) refers to the bottom ! value in the vertical profile. pos = i*15+(m-2)*5 - T15(pos+1) = w_left*Ttl + w_right*Ttr - T15(pos+5) = w_left*Tbl + w_right*Tbr + T15(pos+1) = (w_left*Ttl) + (w_right*Ttr) + T15(pos+5) = (w_left*Tbl) + (w_right*Tbr) - S15(pos+1) = w_left*Stl + w_right*Str - S15(pos+5) = w_left*Sbl + w_right*Sbr + S15(pos+1) = (w_left*Stl) + (w_right*Str) + S15(pos+5) = (w_left*Sbl) + (w_right*Sbr) - p15(pos+1) = -GxRho*((w_left*e(i,j,K) + w_right*e(i,j+1,K)) - z0pres) + p15(pos+1) = -GxRho * ((w_left*(e(i,j,K)-z0pres(i,j))) + (w_right*(e(i,j+1,K)-z0pres(i,j+1)))) ! Pressure do n=2,5 @@ -711,42 +823,23 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & S15(pos+n) = wt_t(n) * S15(pos+1) + wt_b(n) * S15(pos+5) T15(pos+n) = wt_t(n) * T15(pos+1) + wt_b(n) * T15(pos+5) enddo - if (use_varT) T215(pos+1:pos+5) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i,j+1,k) - if (use_covarTS) TS15(pos+1:pos+5) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i,j+1,k) - if (use_varS) S215(pos+1:pos+5) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i,j+1,k) + if (use_varT) T215(pos+1:pos+5) = (w_left*tv%varT(i,j,k)) + (w_right*tv%varT(i,j+1,k)) + if (use_covarTS) TS15(pos+1:pos+5) = (w_left*tv%covarTS(i,j,k)) + (w_right*tv%covarTS(i,j+1,k)) + if (use_varS) S215(pos+1:pos+5) = (w_left*tv%varS(i,j,k)) + (w_right*tv%varS(i,j+1,k)) enddo enddo if (use_stanley_eos) then - if (rho_scale /= 1.0) then - call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & - T215(15*HI%isc+1:), TS15(15*HI%isc+1:), S215(15*HI%isc+1:), & - r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, & - rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & - T215(15*HI%isc+1:), TS15(15*HI%isc+1:), S215(15*HI%isc+1:), & - r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, rho_ref=rho_ref_mks) - endif + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + T215(15*HI%isc+1:), TS15(15*HI%isc+1:), S215(15*HI%isc+1:), & + r15(15*HI%isc+1:), EOS, EOSdom_h15, rho_ref=rho_ref) else if (use_rho_ref) then - if (rho_scale /= 1.0) then - call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & - r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, & - rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & - r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, rho_ref=rho_ref_mks) - endif + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + r15(15*HI%isc+1:), EOS, EOSdom_h15, rho_ref=rho_ref) else - if (rho_scale /= 1.0) then - call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & - r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS, & - scale=rho_scale) - else - call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & - r15(15*HI%isc+1:), 1, 15*(HI%iec-HI%isc+1), EOS) - endif + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + r15(15*HI%isc+1:), EOS, EOSdom_h15) endif endif @@ -757,16 +850,16 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & if (use_rho_ref) then do m = 2,4 pos = i*15+(m-2)*5 - intz(m) = G_e*dz_y(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + & + intz(m) = (G_e*dz_y(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + & 32.0*(r15(pos+2)+r15(pos+4)) + & - 12.0*r15(pos+3)) ) + 12.0*r15(pos+3)) )) enddo else do m = 2,4 pos = i*15+(m-2)*5 - intz(m) = G_e*dz_y(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + & + intz(m) = (G_e*dz_y(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + & 32.0*(r15(pos+2)+r15(pos+4)) + & - 12.0*r15(pos+3)) - rho_ref ) + 12.0*r15(pos+3)) - rho_ref )) enddo endif ! Use Boole's rule to integrate the values. @@ -781,25 +874,26 @@ end subroutine int_density_dz_generic_plm !> Compute pressure gradient force integrals for layer "k" and the case where T and S !! are parabolic profiles subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & - rho_ref, rho_0, G_e, dz_subroundoff, bathyT, HI, GV, EOS, US, & - dpa, intz_dpa, intx_dpa, inty_dpa, useMassWghtInterp, Z_0p) + rho_ref, rho_0, G_e, dz_subroundoff, bathyT, HI, GV, EOS, US, use_stanley_eos, & + dpa, intz_dpa, intx_dpa, inty_dpa, MassWghtInterp, Z_0p, & + MassWghtInterpVanOnly, h_nv) integer, intent(in) :: k !< Layer index to calculate integrals for type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structures for the input arrays type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & - intent(in) :: T_t !< Potential temperature at the cell top [degC] + intent(in) :: T_t !< Potential temperature at the cell top [C ~> degC] real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & - intent(in) :: T_b !< Potential temperature at the cell bottom [degC] + intent(in) :: T_b !< Potential temperature at the cell bottom [C ~> degC] real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & - intent(in) :: S_t !< Salinity at the cell top [ppt] + intent(in) :: S_t !< Salinity at the cell top [S ~> ppt] real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & - intent(in) :: S_b !< Salinity at the cell bottom [ppt] + intent(in) :: S_b !< Salinity at the cell bottom [S ~> ppt] real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)+1), & intent(in) :: e !< Height of interfaces [Z ~> m] - real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that is !! subtracted out to reduce the magnitude of each of the integrals. - real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [kg m-3], that is used to calculate + real, intent(in) :: rho_0 !< A density [R ~> kg m-3], that is used to calculate !! the pressure (as p~=-z*rho_0*G_e) used in the equation of state. real, intent(in) :: G_e !< The Earth's gravitational acceleration [L2 Z-1 T-2 ~> m s-2] real, intent(in) :: dz_subroundoff !< A minuscule thickness change [Z ~> m] @@ -807,6 +901,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] type(EOS_type), intent(in) :: EOS !< Equation of state structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + logical, intent(in) :: use_stanley_eos !< If true, turn on Stanley SGS T variance parameterization real, dimension(SZI_(HI),SZJ_(HI)), & intent(inout) :: dpa !< The change in the pressure anomaly across the layer [R L2 T-2 ~> Pa] real, dimension(SZI_(HI),SZJ_(HI)), & @@ -821,9 +916,14 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & optional, intent(inout) :: inty_dpa !< The integral in y of the difference between the !! pressure anomaly at the top and bottom of the layer !! divided by the y grid spacing [R L2 T-2 ~> Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals + logical, optional, intent(in) :: MassWghtInterpVanOnly !< If true, does not do mass weighting + !! of T/S unless one side smaller than h_nv (i.e. vanished) + real, optional, intent(in) :: h_nv !< Nonvanished height [Z ~> m] + + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! This subroutine calculates (by numerical quadrature) integrals of ! pressure anomalies across layers, which are required for calculating the @@ -837,50 +937,81 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & ! a parabolic interpolation is used to compute intermediate values. ! Local variables - real :: T5(5) ! Temperatures along a line of subgrid locations [degC] - real :: S5(5) ! Salinities along a line of subgrid locations [ppt] - real :: T25(5) ! SGS temperature variance along a line of subgrid locations [degC2] - real :: TS5(5) ! SGS temperature-salinity covariance along a line of subgrid locations [degC ppt] - real :: S25(5) ! SGS salinity variance along a line of subgrid locations [ppt2] - real :: p5(5) ! Pressures at five quadrature points, never rescaled from Pa [Pa] - real :: r5(5) ! Density anomalies from rho_ref at quadrature points [R ~> kg m-3] or [kg m-3] + real :: T5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Temperatures along a line of subgrid locations [C ~> degC] + real :: S5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Salinities along a line of subgrid locations [S ~> ppt] + real :: T25((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS temperature variance along a line of subgrid + ! locations [C2 ~> degC2] + real :: TS5((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS temp-salt covariance along a line of subgrid + ! locations [C S ~> degC ppt] + real :: S25((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS salinity variance along a line of subgrid locations [S2 ~> ppt2] + real :: p5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Pressures along a line of subgrid locations [R L2 T-2 ~> Pa] + real :: r5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Densities anomalies along a line of subgrid + ! locations [R ~> kg m-3] + real :: T15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Temperatures at an array of subgrid locations [C ~> degC] + real :: S15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Salinities at an array of subgrid locations [S ~> ppt] + real :: T215((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS temperature variance along a line of subgrid + ! locations [C2 ~> degC2] + real :: TS15((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS temp-salt covariance along a line of subgrid + ! locations [C S ~> degC ppt] + real :: S215((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS salinity variance along a line of subgrid + ! locations [S2 ~> ppt2] + real :: p15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Pressures at an array of subgrid locations [R L2 T-2 ~> Pa] + real :: r15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Densities at an array of subgrid locations [R ~> kg m-3] real :: wt_t(5), wt_b(5) ! Top and bottom weights [nondim] - real :: rho_anom ! The integrated density anomaly [R ~> kg m-3] or [kg m-3] + real :: rho_anom ! The integrated density anomaly [R ~> kg m-3] real :: w_left, w_right ! Left and right weights [nondim] real :: intz(5) ! The gravitational acceleration times the integrals of density - ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa] - real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. - real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] - real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] - real :: rho_scale ! A scaling factor for densities from kg m-3 to R [R m3 kg-1 ~> 1] - real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] + real :: GxRho ! The gravitational acceleration times density [R L2 Z-1 T-2 ~> kg m-2 s-2] real :: dz ! Layer thicknesses at tracer points [Z ~> m] - real :: massWeightToggle ! A non-dimensional toggle factor (0 or 1) [nondim] - real :: Ttl, Tbl, Tml, Ttr, Tbr, Tmr ! Temperatures at the velocity cell corners [degC] - real :: Stl, Sbl, Sml, Str, Sbr, Smr ! Salinities at the velocity cell corners [ppt] - real :: s6 ! PPM curvature coefficient for S [ppt] - real :: t6 ! PPM curvature coefficient for T [degC] - real :: T_top, T_mn, T_bot ! Left edge, cell mean and right edge values used in PPM reconstructions of T - real :: S_top, S_mn, S_bot ! Left edge, cell mean and right edge values used in PPM reconstructions of S - real :: z0pres ! The height at which the pressure is zero [Z ~> m] + real :: dz_x(5,HI%iscB:HI%iecB) ! Layer thicknesses along an x-line of subgrid locations [Z ~> m] + real :: dz_y(5,HI%isc:HI%iec) ! Layer thicknesses along a y-line of subgrid locations [Z ~> m] + real :: massWeightToggle ! A non-dimensional toggle factor for near-bottom mass weighting (0 or 1) [nondim] + real :: TopWeightToggle ! A non-dimensional toggle factor for near-surface mass weighting (0 or 1) [nondim] + real :: massWeightNVonlyToggle ! A non-dimensional toggle factor for only using mass weighting + ! if at least one side vanished (0 or 1) [nondim] + real :: Ttl, Tbl, Tml, Ttr, Tbr, Tmr ! Temperatures at the velocity cell corners [C ~> degC] + real :: Stl, Sbl, Sml, Str, Sbr, Smr ! Salinities at the velocity cell corners [S ~> ppt] + real :: s6 ! PPM curvature coefficient for S [S ~> ppt] + real :: t6 ! PPM curvature coefficient for T [C ~> degC] + real :: T_top, T_mn, T_bot ! Left edge, cell mean and right edge values used in PPM reconstructions of T [C ~> degC] + real :: S_top, S_mn, S_bot ! Left edge, cell mean and right edge values used in PPM reconstructions of S [S ~> ppt] + real :: z0pres(HI%isd:HI%ied,HI%jsd:HI%jed) ! The height at which the pressure is zero [Z ~> m] real :: hWght ! A topographically limited thickness weight [Z ~> m] + real :: hWghtTop ! A surface displacement limited thickness weight [Z ~> m] real :: hL, hR ! Thicknesses to the left and right [Z ~> m] real :: iDenom ! The denominator of the thickness weight expressions [Z-2 ~> m-2] - integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n + real :: h_nonvanished ! nonvanished height [Z ~> m] + integer, dimension(2) :: EOSdom_h5 ! The 5-point h-point i-computational domain for the equation of state + integer, dimension(2) :: EOSdom_q15 ! The 3x5-point q-point i-computational domain for the equation of state + integer, dimension(2) :: EOSdom_h15 ! The 3x5-point h-point i-computational domain for the equation of state + integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n, pos logical :: use_PPM ! If false, assume zero curvature in reconstruction, i.e. PLM - logical :: use_stanley_eos ! True is SGS variance fields exist in tv. - logical :: use_varT, use_varS, use_covarTS + logical :: use_varT, use_varS, use_covarTS ! Logicals for SGS variances fields Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB - rho_scale = US%kg_m3_to_R - GxRho = US%RL2_T2_to_Pa * G_e * rho_0 - rho_ref_mks = rho_ref * US%R_to_kg_m3 - I_Rho = 1.0 / rho_0 - z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p - massWeightToggle = 0. - if (present(useMassWghtInterp)) then - if (useMassWghtInterp) massWeightToggle = 1. + GxRho = G_e * rho_0 + if (present(Z_0p)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + z0pres(i,j) = Z_0p(i,j) + enddo ; enddo + else + z0pres(:,:) = 0.0 + endif + massWeightToggle = 0. ; TopWeightToggle = 0. + if (present(MassWghtInterp)) then + if (BTEST(MassWghtInterp, 0)) massWeightToggle = 1. + if (BTEST(MassWghtInterp, 1)) TopWeightToggle = 1. + endif + massWeightNVonlyToggle = 1. + if (present(MassWghtInterpVanOnly)) then + if (MassWghtInterpVanOnly) massWeightNVonlyToggle = 0. + endif + h_nonvanished = 0. + if (present(h_nv)) then + h_nonvanished = h_nv endif ! In event PPM calculation is bypassed with use_PPM=False @@ -888,250 +1019,317 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & t6 = 0. use_PPM = .true. ! This is a place-holder to allow later re-use of this function - use_varT = associated(tv%varT) - use_covarTS = associated(tv%covarTS) - use_varS = associated(tv%varS) - use_stanley_eos = use_varT .or. use_covarTS .or. use_varS + use_varT = .false. !ensure initialized + use_covarTS = .false. + use_varS = .false. + if (use_stanley_eos) then + use_varT = associated(tv%varT) + use_covarTS = associated(tv%covarTS) + use_varS = associated(tv%varS) + endif + T25(:) = 0. TS5(:) = 0. S25(:) = 0. + T215(:) = 0. + TS15(:) = 0. + S215(:) = 0. do n = 1, 5 wt_t(n) = 0.25 * real(5-n) wt_b(n) = 1.0 - wt_t(n) enddo - ! 1. Compute vertical integrals - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - if (use_PPM) then - ! Curvature coefficient of the parabolas - s6 = 3.0 * ( 2.0*tv%S(i,j,k) - ( S_t(i,j,k) + S_b(i,j,k) ) ) - t6 = 3.0 * ( 2.0*tv%T(i,j,k) - ( T_t(i,j,k) + T_b(i,j,k) ) ) - endif - dz = e(i,j,K) - e(i,j,K+1) - do n=1,5 - p5(n) = -GxRho*((e(i,j,K) - z0pres) - 0.25*real(n-1)*dz) - ! Salinity and temperature points are reconstructed with PPM - S5(n) = wt_t(n) * S_t(i,j,k) + wt_b(n) * ( S_b(i,j,k) + s6 * wt_t(n) ) - T5(n) = wt_t(n) * T_t(i,j,k) + wt_b(n) * ( T_b(i,j,k) + t6 * wt_t(n) ) - enddo - if (use_stanley_eos) then - if (use_varT) T25(:) = tv%varT(i,j,k) - if (use_covarTS) TS5(:) = tv%covarTS(i,j,k) - if (use_varS) S25(:) = tv%varS(i,j,k) - call calculate_density(T5, S5, p5, T25, TS5, S25, r5, & - 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) - endif - - ! Use Boole's rule to estimate the pressure anomaly change. - rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) - dpa(i,j) = G_e*dz*rho_anom - if (present(intz_dpa)) then - ! Use a Boole's-rule-like fifth-order accurate estimate of - ! the double integral of the pressure anomaly. - intz_dpa(i,j) = 0.5*G_e*dz**2 * & - (rho_anom - C1_90*(16.0*(r5(4)-r5(2)) + 7.0*(r5(5)-r5(1))) ) - endif - enddo ; enddo ! end loops on j and i - - ! 2. Compute horizontal integrals in the x direction - if (present(intx_dpa)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq - ! Corner values of T and S - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation - ! of T,S along the top and bottom integrals, almost like thickness - ! weighting. - ! Note: To work in terrain following coordinates we could offset - ! this distance by the layer thickness to replicate other models. - hWght = massWeightToggle * & - max(0., -bathyT(i,j)-e(i+1,j,K), -bathyT(i+1,j)-e(i,j,K)) - if (hWght > 0.) then - hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff - hR = (e(i+1,j,K) - e(i+1,j,K+1)) + dz_subroundoff - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1./( hWght*(hR + hL) + hL*hR ) - Ttl = ( (hWght*hR)*T_t(i+1,j,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom - Tbl = ( (hWght*hR)*T_b(i+1,j,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom - Tml = ( (hWght*hR)*tv%T(i+1,j,k)+ (hWght*hL + hR*hL)*tv%T(i,j,k) ) * iDenom - Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i+1,j,k) ) * iDenom - Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i+1,j,k) ) * iDenom - Tmr = ( (hWght*hL)*tv%T(i,j,k) + (hWght*hR + hR*hL)*tv%T(i+1,j,k) ) * iDenom - Stl = ( (hWght*hR)*S_t(i+1,j,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom - Sbl = ( (hWght*hR)*S_b(i+1,j,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom - Sml = ( (hWght*hR)*tv%S(i+1,j,k) + (hWght*hL + hR*hL)*tv%S(i,j,k) ) * iDenom - Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i+1,j,k) ) * iDenom - Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i+1,j,k) ) * iDenom - Smr = ( (hWght*hL)*tv%S(i,j,k) + (hWght*hR + hR*hL)*tv%S(i+1,j,k) ) * iDenom - else - Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i+1,j,k); Tbr = T_b(i+1,j,k) - Tml = tv%T(i,j,k); Tmr = tv%T(i+1,j,k) - Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i+1,j,k); Sbr = S_b(i+1,j,k) - Sml = tv%S(i,j,k); Smr = tv%S(i+1,j,k) - endif + ! Set the loop ranges for equation of state calculations at various points. + EOSdom_h5(1) = 1 ; EOSdom_h5(2) = 5*(Ieq-Isq+2) + EOSdom_q15(1) = 1 ; EOSdom_q15(2) = 15*(Ieq-Isq+1) + EOSdom_h15(1) = 1 ; EOSdom_h15(2) = 15*(HI%iec-HI%isc+1) - do m=2,4 - w_left = wt_t(m) ; w_right = wt_b(m) - - ! Salinity and temperature points are linearly interpolated in - ! the horizontal. The subscript (1) refers to the top value in - ! the vertical profile while subscript (5) refers to the bottom - ! value in the vertical profile. - T_top = w_left*Ttl + w_right*Ttr - T_mn = w_left*Tml + w_right*Tmr - T_bot = w_left*Tbl + w_right*Tbr - - S_top = w_left*Stl + w_right*Str - S_mn = w_left*Sml + w_right*Smr - S_bot = w_left*Sbl + w_right*Sbr - - ! Pressure - dz = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i+1,j,K) - e(i+1,j,K+1)) - p5(1) = -GxRho*((w_left*e(i,j,K) + w_right*e(i+1,j,K)) - z0pres) - do n=2,5 - p5(n) = p5(n-1) + GxRho*0.25*dz - enddo - - ! Parabolic reconstructions in the vertical for T and S + ! 1. Compute vertical integrals + do j=Jsq,Jeq+1 + do i=Isq,Ieq+1 if (use_PPM) then - ! Coefficients of the parabolas - s6 = 3.0 * ( 2.0*S_mn - ( S_top + S_bot ) ) - t6 = 3.0 * ( 2.0*T_mn - ( T_top + T_bot ) ) + ! Curvature coefficient of the parabolas + s6 = 3.0 * ( 2.0*tv%S(i,j,k) - ( S_t(i,j,k) + S_b(i,j,k) ) ) + t6 = 3.0 * ( 2.0*tv%T(i,j,k) - ( T_t(i,j,k) + T_b(i,j,k) ) ) endif + dz = e(i,j,K) - e(i,j,K+1) do n=1,5 - S5(n) = wt_t(n) * S_top + wt_b(n) * ( S_bot + s6 * wt_t(n) ) - T5(n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) + p5(I*5+n) = -GxRho*((e(i,j,K) - z0pres(i,j)) - 0.25*real(n-1)*dz) + ! Salinity and temperature points are reconstructed with PPM + S5(I*5+n) = wt_t(n) * S_t(i,j,k) + wt_b(n) * ( S_b(i,j,k) + s6 * wt_t(n) ) + T5(I*5+n) = wt_t(n) * T_t(i,j,k) + wt_b(n) * ( T_b(i,j,k) + t6 * wt_t(n) ) enddo - if (use_stanley_eos) then - if (use_varT) T25(:) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i+1,j,k) - if (use_covarTS) TS5(:) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i+1,j,k) - if (use_varS) S25(:) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i+1,j,k) - call calculate_density(T5, S5, p5, T25, TS5, S25, r5, & - 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) - else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + if (use_varT) T25(I*5+1:I*5+5) = tv%varT(i,j,k) + if (use_covarTS) TS5(I*5+1:I*5+5) = tv%covarTS(i,j,k) + if (use_varS) S25(I*5+1:I*5+5) = tv%varS(i,j,k) endif + enddo - ! Use Boole's rule to estimate the pressure anomaly change. - intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) ) - enddo ! m - intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) - - ! Use Boole's rule to integrate the bottom pressure anomaly values in x. - intx_dpa(I,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) - - enddo ; enddo ; endif - - ! 3. Compute horizontal integrals in the y direction - if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec - ! Corner values of T and S - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation - ! of T,S along the top and bottom integrals, almost like thickness - ! weighting. - ! Note: To work in terrain following coordinates we could offset - ! this distance by the layer thickness to replicate other models. - hWght = massWeightToggle * & - max(0., -bathyT(i,j)-e(i,j+1,K), -bathyT(i,j+1)-e(i,j,K)) - if (hWght > 0.) then - hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff - hR = (e(i,j+1,K) - e(i,j+1,K+1)) + dz_subroundoff - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1./( hWght*(hR + hL) + hL*hR ) - Ttl = ( (hWght*hR)*T_t(i,j+1,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom - Tbl = ( (hWght*hR)*T_b(i,j+1,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom - Tml = ( (hWght*hR)*tv%T(i,j+1,k)+ (hWght*hL + hR*hL)*tv%T(i,j,k) ) * iDenom - Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i,j+1,k) ) * iDenom - Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i,j+1,k) ) * iDenom - Tmr = ( (hWght*hL)*tv%T(i,j,k) + (hWght*hR + hR*hL)*tv%T(i,j+1,k) ) * iDenom - Stl = ( (hWght*hR)*S_t(i,j+1,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom - Sbl = ( (hWght*hR)*S_b(i,j+1,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom - Sml = ( (hWght*hR)*tv%S(i,j+1,k)+ (hWght*hL + hR*hL)*tv%S(i,j,k) ) * iDenom - Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i,j+1,k) ) * iDenom - Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i,j+1,k) ) * iDenom - Smr = ( (hWght*hL)*tv%S(i,j,k) + (hWght*hR + hR*hL)*tv%S(i,j+1,k) ) * iDenom + if (use_stanley_eos) then + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, EOS, EOSdom_h5, rho_ref=rho_ref) else - Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i,j+1,k); Tbr = T_b(i,j+1,k) - Tml = tv%T(i,j,k); Tmr = tv%T(i,j+1,k) - Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i,j+1,k); Sbr = S_b(i,j+1,k) - Sml = tv%S(i,j,k); Smr = tv%S(i,j+1,k) + call calculate_density(T5, S5, p5, r5, EOS, EOSdom_h5, rho_ref=rho_ref) endif - do m=2,4 - w_left = wt_t(m) ; w_right = wt_b(m) - - ! Salinity and temperature points are linearly interpolated in - ! the horizontal. The subscript (1) refers to the top value in - ! the vertical profile while subscript (5) refers to the bottom - ! value in the vertical profile. - T_top = w_left*Ttl + w_right*Ttr - T_mn = w_left*Tml + w_right*Tmr - T_bot = w_left*Tbl + w_right*Tbr - - S_top = w_left*Stl + w_right*Str - S_mn = w_left*Sml + w_right*Smr - S_bot = w_left*Sbl + w_right*Sbr - - ! Pressure - dz = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i,j+1,K) - e(i,j+1,K+1)) - p5(1) = -GxRho*((w_left*e(i,j,K) + w_right*e(i,j+1,K)) - z0pres) - do n=2,5 - p5(n) = p5(n-1) + GxRho*0.25*dz - enddo - - ! Parabolic reconstructions in the vertical for T and S - if (use_PPM) then - ! Coefficients of the parabolas - s6 = 3.0 * ( 2.0*S_mn - ( S_top + S_bot ) ) - t6 = 3.0 * ( 2.0*T_mn - ( T_top + T_bot ) ) + do i=Isq,Ieq+1 + dz = e(i,j,K) - e(i,j,K+1) + ! Use Boole's rule to estimate the pressure anomaly change. + rho_anom = C1_90*(7.0*(r5(i*5+1)+r5(i*5+5)) + 32.0*(r5(i*5+2)+r5(i*5+4)) + 12.0*r5(i*5+3)) + dpa(i,j) = G_e*dz*rho_anom + if (present(intz_dpa)) then + ! Use a Boole's-rule-like fifth-order accurate estimate of + ! the double integral of the pressure anomaly. + intz_dpa(i,j) = 0.5*G_e*dz**2 * & + (rho_anom - C1_90*(16.0*(r5(i*5+4)-r5(i*5+2)) + 7.0*(r5(i*5+5)-r5(i*5+1))) ) endif - do n=1,5 - S5(n) = wt_t(n) * S_top + wt_b(n) * ( S_bot + s6 * wt_t(n) ) - T5(n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) - enddo + enddo ! end loop on i + enddo ! end loop on j - if (use_stanley_eos) then - if (use_varT) T25(:) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i,j+1,k) - if (use_covarTS) TS5(:) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i,j+1,k) - if (use_varS) S25(:) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i,j+1,k) - call calculate_density(T5, S5, p5, T25, TS5, S25, r5, & - 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + ! 2. Compute horizontal integrals in the x direction + if (present(intx_dpa)) then ; do j=HI%jsc,HI%jec + do I=Isq,Ieq + ! Corner values of T and S + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. + ! Note: To work in terrain following coordinates we could offset + ! this distance by the layer thickness to replicate other models. + hWght = massWeightToggle * & + max(0., -bathyT(i,j)-e(i+1,j,K), -bathyT(i+1,j)-e(i,j,K)) + hWghtTop = TopWeightToggle * & + max(0., e(i+1,j,K+1)-e(i,j,1), e(i,j,K+1)-e(i+1,j,1)) + hWght = max(hWght, hWghtTop) + ! If both sides are nonvanished, then set it back to zero. + if (((e(i,j,K) - e(i,j,K+1)) > h_nonvanished) .and. ((e(i+1,j,K) - e(i+1,j,K+1)) > h_nonvanished)) then + hWght = massWeightNVonlyToggle * hWght + endif + if (hWght > 0.) then + hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff + hR = (e(i+1,j,K) - e(i+1,j,K+1)) + dz_subroundoff + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1./( hWght*(hR + hL) + hL*hR ) + Ttl = ( (hWght*hR)*T_t(i+1,j,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i+1,j,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom + Tml = ( (hWght*hR)*tv%T(i+1,j,k)+ (hWght*hL + hR*hL)*tv%T(i,j,k) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i+1,j,k) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i+1,j,k) ) * iDenom + Tmr = ( (hWght*hL)*tv%T(i,j,k) + (hWght*hR + hR*hL)*tv%T(i+1,j,k) ) * iDenom + Stl = ( (hWght*hR)*S_t(i+1,j,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i+1,j,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom + Sml = ( (hWght*hR)*tv%S(i+1,j,k) + (hWght*hL + hR*hL)*tv%S(i,j,k) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i+1,j,k) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i+1,j,k) ) * iDenom + Smr = ( (hWght*hL)*tv%S(i,j,k) + (hWght*hR + hR*hL)*tv%S(i+1,j,k) ) * iDenom else - call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref=rho_ref_mks, scale=rho_scale) + Ttl = T_t(i,j,k) ; Tbl = T_b(i,j,k) ; Ttr = T_t(i+1,j,k) ; Tbr = T_b(i+1,j,k) + Tml = tv%T(i,j,k) ; Tmr = tv%T(i+1,j,k) + Stl = S_t(i,j,k) ; Sbl = S_b(i,j,k) ; Str = S_t(i+1,j,k) ; Sbr = S_b(i+1,j,k) + Sml = tv%S(i,j,k) ; Smr = tv%S(i+1,j,k) endif - ! Use Boole's rule to estimate the pressure anomaly change. - intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) ) - enddo ! m - intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + do m=2,4 + w_left = wt_t(m) ; w_right = wt_b(m) - ! Use Boole's rule to integrate the bottom pressure anomaly values in y. - inty_dpa(i,J) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) + ! Salinity and temperature points are linearly interpolated in + ! the horizontal. The subscript (1) refers to the top value in + ! the vertical profile while subscript (5) refers to the bottom + ! value in the vertical profile. + T_top = (w_left*Ttl) + (w_right*Ttr) + T_mn = (w_left*Tml) + (w_right*Tmr) + T_bot = (w_left*Tbl) + (w_right*Tbr) - enddo ; enddo ; endif + S_top = (w_left*Stl) + (w_right*Str) + S_mn = (w_left*Sml) + (w_right*Smr) + S_bot = (w_left*Sbl) + (w_right*Sbr) -end subroutine int_density_dz_generic_ppm + ! Pressure + dz_x(m,i) = (w_left*(e(i,j,K) - e(i,j,K+1))) + (w_right*(e(i+1,j,K) - e(i+1,j,K+1))) -!> Calls the appropriate subroutine to calculate analytical and nearly-analytical -!! integrals in pressure across layers of geopotential anomalies, which are + pos = i*15+(m-2)*5 + p15(pos+1) = -GxRho * ((w_left*(e(i,j,K)-z0pres(i,j))) + (w_right*(e(i+1,j,K)-z0pres(i+1,j)))) + do n=2,5 + p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i) + enddo + + ! Parabolic reconstructions in the vertical for T and S + if (use_PPM) then + ! Coefficients of the parabolas + s6 = 3.0 * ( 2.0*S_mn - ( S_top + S_bot ) ) + t6 = 3.0 * ( 2.0*T_mn - ( T_top + T_bot ) ) + endif + do n=1,5 + S15(pos+n) = wt_t(n) * S_top + wt_b(n) * ( S_bot + s6 * wt_t(n) ) + T15(pos+n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) + enddo + if (use_stanley_eos) then + if (use_varT) T215(pos+1:pos+5) = (w_left*tv%varT(i,j,k)) + (w_right*tv%varT(i+1,j,k)) + if (use_covarTS) TS15(pos+1:pos+5) = (w_left*tv%covarTS(i,j,k)) + (w_right*tv%covarTS(i+1,j,k)) + if (use_varS) S215(pos+1:pos+5) = (w_left*tv%varS(i,j,k)) + (w_right*tv%varS(i+1,j,k)) + endif + if (use_stanley_eos) then + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, EOS, rho_ref=rho_ref) + else + call calculate_density(T5, S5, p5, r5, EOS, rho_ref=rho_ref) + endif + enddo + enddo + + if (use_stanley_eos) then + call calculate_density(T15, S15, p15, T215, TS15, S215, r15, EOS, EOSdom_q15, rho_ref=rho_ref) + else + call calculate_density(T15, S15, p15, r15, EOS, EOSdom_q15, rho_ref=rho_ref) + endif + + do I=Isq,Ieq + do m=2,4 + pos = i*15+(m-2)*5 + ! Use Boole's rule to estimate the pressure anomaly change. + intz(m) = (G_e*dz_x(m,i)*(C1_90*( 7.0*(r15(pos+1)+r15(pos+5)) + & + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3)) )) + enddo ! m + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + + ! Use Boole's rule to integrate the bottom pressure anomaly values in x. + intx_dpa(I,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) + + enddo + enddo ; endif + + ! 3. Compute horizontal integrals in the y direction + if (present(inty_dpa)) then ; do J=Jsq,Jeq + do i=HI%isc,HI%iec + ! Corner values of T and S + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. + ! Note: To work in terrain following coordinates we could offset + ! this distance by the layer thickness to replicate other models. + hWght = massWeightToggle * & + max(0., -bathyT(i,j)-e(i,j+1,K), -bathyT(i,j+1)-e(i,j,K)) + hWghtTop = TopWeightToggle * & + max(0., e(i,j+1,K+1)-e(i,j,1), e(i,j,K+1)-e(i,j+1,1)) + hWght = max(hWght, hWghtTop) + ! If both sides are nonvanished, then set it back to zero. + if (((e(i,j,K) - e(i,j,K+1)) > h_nonvanished) .and. ((e(i,j+1,K) - e(i,j+1,K+1)) > h_nonvanished)) then + hWght = massWeightNVonlyToggle * hWght + endif + if (hWght > 0.) then + hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff + hR = (e(i,j+1,K) - e(i,j+1,K+1)) + dz_subroundoff + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1./( hWght*(hR + hL) + hL*hR ) + Ttl = ( (hWght*hR)*T_t(i,j+1,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i,j+1,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom + Tml = ( (hWght*hR)*tv%T(i,j+1,k)+ (hWght*hL + hR*hL)*tv%T(i,j,k) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i,j+1,k) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i,j+1,k) ) * iDenom + Tmr = ( (hWght*hL)*tv%T(i,j,k) + (hWght*hR + hR*hL)*tv%T(i,j+1,k) ) * iDenom + Stl = ( (hWght*hR)*S_t(i,j+1,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i,j+1,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom + Sml = ( (hWght*hR)*tv%S(i,j+1,k)+ (hWght*hL + hR*hL)*tv%S(i,j,k) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i,j+1,k) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i,j+1,k) ) * iDenom + Smr = ( (hWght*hL)*tv%S(i,j,k) + (hWght*hR + hR*hL)*tv%S(i,j+1,k) ) * iDenom + else + Ttl = T_t(i,j,k) ; Tbl = T_b(i,j,k) ; Ttr = T_t(i,j+1,k) ; Tbr = T_b(i,j+1,k) + Tml = tv%T(i,j,k) ; Tmr = tv%T(i,j+1,k) + Stl = S_t(i,j,k) ; Sbl = S_b(i,j,k) ; Str = S_t(i,j+1,k) ; Sbr = S_b(i,j+1,k) + Sml = tv%S(i,j,k) ; Smr = tv%S(i,j+1,k) + endif + + do m=2,4 + w_left = wt_t(m) ; w_right = wt_b(m) + + ! Salinity and temperature points are linearly interpolated in + ! the horizontal. The subscript (1) refers to the top value in + ! the vertical profile while subscript (5) refers to the bottom + ! value in the vertical profile. + T_top = (w_left*Ttl) + (w_right*Ttr) + T_mn = (w_left*Tml) + (w_right*Tmr) + T_bot = (w_left*Tbl) + (w_right*Tbr) + + S_top = (w_left*Stl) + (w_right*Str) + S_mn = (w_left*Sml) + (w_right*Smr) + S_bot = (w_left*Sbl) + (w_right*Sbr) + + ! Pressure + dz_y(m,i) = (w_left*(e(i,j,K) - e(i,j,K+1))) + (w_right*(e(i,j+1,K) - e(i,j+1,K+1))) + + pos = i*15+(m-2)*5 + p15(pos+1) = -GxRho * ((w_left*(e(i,j,K)-z0pres(i,j))) + (w_right*(e(i,j+1,K)-z0pres(i,j+1)))) + do n=2,5 + p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) + enddo + + ! Parabolic reconstructions in the vertical for T and S + if (use_PPM) then + ! Coefficients of the parabolas + s6 = 3.0 * ( 2.0*S_mn - ( S_top + S_bot ) ) + t6 = 3.0 * ( 2.0*T_mn - ( T_top + T_bot ) ) + endif + do n=1,5 + S15(pos+n) = wt_t(n) * S_top + wt_b(n) * ( S_bot + s6 * wt_t(n) ) + T15(pos+n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) + enddo + + if (use_stanley_eos) then + if (use_varT) T215(pos+1:pos+5) = (w_left*tv%varT(i,j,k)) + (w_right*tv%varT(i,j+1,k)) + if (use_covarTS) TS15(pos+1:pos+5) = (w_left*tv%covarTS(i,j,k)) + (w_right*tv%covarTS(i,j+1,k)) + if (use_varS) S215(pos+1:pos+5) = (w_left*tv%varS(i,j,k)) + (w_right*tv%varS(i,j+1,k)) + endif + enddo + enddo + + if (use_stanley_eos) then + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + T215(15*HI%isc+1:), TS15(15*HI%isc+1:), S215(15*HI%isc+1:), & + r15(15*HI%isc+1:), EOS, EOSdom_h15, rho_ref=rho_ref) + else + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + r15(15*HI%isc+1:), EOS, EOSdom_h15, rho_ref=rho_ref) + endif + + do i=HI%isc,HI%iec + do m=2,4 + ! Use Boole's rule to estimate the pressure anomaly change. + pos = i*15+(m-2)*5 + intz(m) = (G_e*dz_y(m,i)*(C1_90*( 7.0*(r15(pos+1)+r15(pos+5)) + & + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3)) )) + enddo ! m + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + + ! Use Boole's rule to integrate the bottom pressure anomaly values in y. + inty_dpa(i,J) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) + enddo + enddo ; endif + +end subroutine int_density_dz_generic_ppm + +!> Calls the appropriate subroutine to calculate analytical and nearly-analytical +!! integrals in pressure across layers of geopotential anomalies, which are !! required for calculating the finite-volume form pressure accelerations in a !! non-Boussinesq model. There are essentially no free assumptions, apart from the !! use of Boole's rule to do the horizontal integrals, and from a truncation in the !! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) + bathyP, P_surf, dP_tiny, MassWghtInterp, & + MassWghtInterpVanOnly, p_nv) type(hor_index_type), intent(in) :: HI !< The horizontal index structure real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: T !< Potential temperature referenced to the surface [degC] + intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: S !< Salinity [ppt] + intent(in) :: S !< Salinity [S ~> ppt] real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] or [Pa] + intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: p_b !< Pressure at the bottom of the layer [R L2 T-2 ~> Pa] or [Pa] + intent(in) :: p_b !< Pressure at the bottom of the layer [R L2 T-2 ~> Pa] real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1] !! The calculation is mathematically identical with different values of @@ -1140,35 +1338,42 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(HI),SZJ_(HI)), & intent(inout) :: dza !< The change in the geopotential anomaly across - !! the layer [L2 T-2 ~> m2 s-2] or [m2 s-2] + !! the layer [L2 T-2 ~> m2 s-2] real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of the !! geopotential anomaly relative to the anomaly at the bottom of the - !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2] + !! layer [R L4 T-4 ~> Pa m2 s-2] real, dimension(SZIB_(HI),SZJ_(HI)), & optional, intent(inout) :: intx_dza !< The integral in x of the difference between the !! geopotential anomaly at the top and bottom of the layer divided by - !! the x grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] + !! the x grid spacing [L2 T-2 ~> m2 s-2] real, dimension(SZI_(HI),SZJB_(HI)), & optional, intent(inout) :: inty_dza !< The integral in y of the difference between the !! geopotential anomaly at the top and bottom of the layer divided by - !! the y grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] + !! the y grid spacing [L2 T-2 ~> m2 s-2] integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. real, dimension(SZI_(HI),SZJ_(HI)), & - optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] real, optional, intent(in) :: dP_tiny !< A minuscule pressure change with - !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. + !! the same units as p_t [R L2 T-2 ~> Pa] + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals + logical, optional, intent(in) :: MassWghtInterpVanOnly !< If true, does not do mass weighting + !! of T/S unless one side smaller than h_nv (i.e. vanished) + real, optional, intent(in) :: p_nv !< Nonvanished pressure [R L2 T-2 ~> Pa] + if (EOS_quadrature(EOS)) then call int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, & dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) + bathyP, P_surf, dP_tiny, MassWghtInterp, & + MassWghtInterpVanOnly, p_nv) else call analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) + bathyP, P_surf, dP_tiny, MassWghtInterp) endif end subroutine int_specific_vol_dp @@ -1180,16 +1385,17 @@ end subroutine int_specific_vol_dp !! no free assumptions, apart from the use of Boole's rule quadrature to do the integrals. subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, dza, & intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_neglect, useMassWghtInterp) + bathyP, P_surf, dP_neglect, MassWghtInterp, & + MassWghtInterpVanOnly, p_nv) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: T !< Potential temperature of the layer [degC] + intent(in) :: T !< Potential temperature of the layer [C ~> degC] real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: S !< Salinity of the layer [ppt] + intent(in) :: S !< Salinity of the layer [S ~> ppt] real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: p_t !< Pressure atop the layer [R L2 T-2 ~> Pa] or [Pa] + intent(in) :: p_t !< Pressure atop the layer [R L2 T-2 ~> Pa] real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] or [Pa] + intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1] !! The calculation is mathematically identical with different values of @@ -1199,26 +1405,31 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(HI),SZJ_(HI)), & intent(inout) :: dza !< The change in the geopotential anomaly - !! across the layer [L2 T-2 ~> m2 s-2] or [m2 s-2] + !! across the layer [L2 T-2 ~> m2 s-2] real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of !! the geopotential anomaly relative to the anomaly at the bottom of the - !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2] + !! layer [R L4 T-4 ~> Pa m2 s-2] real, dimension(SZIB_(HI),SZJ_(HI)), & optional, intent(inout) :: intx_dza !< The integral in x of the difference between !! the geopotential anomaly at the top and bottom of the layer divided - !! by the x grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] + !! by the x grid spacing [L2 T-2 ~> m2 s-2] real, dimension(SZI_(HI),SZJB_(HI)), & optional, intent(inout) :: inty_dza !< The integral in y of the difference between !! the geopotential anomaly at the top and bottom of the layer divided - !! by the y grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] + !! by the y grid spacing [L2 T-2 ~> m2 s-2] integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. real, dimension(SZI_(HI),SZJ_(HI)), & - optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] real, optional, intent(in) :: dP_neglect !< A minuscule pressure change with - !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. + !! the same units as p_t [R L2 T-2 ~> Pa] + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals + logical, optional, intent(in) :: MassWghtInterpVanOnly !< If true, does not do mass weighting + !! of T/S unless one side smaller than h_nv (i.e. vanished) + real, optional, intent(in) :: p_nv !< Nonvanished pressure [R L2 T-2 ~> Pa] ! This subroutine calculates analytical and nearly-analytical integrals in ! pressure across layers of geopotential anomalies, which are required for @@ -1228,15 +1439,21 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d ! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. ! Local variables - real :: T5(5) ! Temperatures at five quadrature points [degC] - real :: S5(5) ! Salinities at five quadrature points [ppt] - real :: p5(5) ! Pressures at five quadrature points, scaled back to Pa if necessary [Pa] - real :: a5(5) ! Specific volumes at five quadrature points [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: T5((5*HI%isd+1):(5*(HI%ied+2))) ! Temperatures along a line of subgrid locations [C ~> degC] + real :: S5((5*HI%isd+1):(5*(HI%ied+2))) ! Salinities along a line of subgrid locations [S ~> ppt] + real :: p5((5*HI%isd+1):(5*(HI%ied+2))) ! Pressures along a line of subgrid locations [R L2 T-2 ~> Pa] + real :: a5((5*HI%isd+1):(5*(HI%ied+2))) ! Specific volumes anomalies along a line of subgrid + ! locations [R-1 ~> m3 kg-1] + real :: T15((15*HI%isd+1):(15*(HI%ied+1))) ! Temperatures at an array of subgrid locations [C ~> degC] + real :: S15((15*HI%isd+1):(15*(HI%ied+1))) ! Salinities at an array of subgrid locations [S ~> ppt] + real :: p15((15*HI%isd+1):(15*(HI%ied+1))) ! Pressures at an array of subgrid locations [R L2 T-2 ~> Pa] + real :: a15((15*HI%isd+1):(15*(HI%ied+1))) ! Specific volumes at an array of subgrid locations [R ~> kg m-3] real :: alpha_anom ! The depth averaged specific density anomaly [R-1 ~> m3 kg-1] real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa] + real :: dp_x(5,SZIB_(HI)) ! The pressure change through a layer along an x-line of subgrid locations [Z ~> m] + real :: dp_y(5,SZI_(HI)) ! The pressure change through a layer along a y-line of subgrid locations [Z ~> m] real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa] real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa] - real :: alpha_ref_mks ! The reference specific volume in MKS units, never rescaled from m3 kg-1 [m3 kg-1] real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> Pa-2] real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim] real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim] @@ -1244,148 +1461,205 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim] real :: intp(5) ! The integrals of specific volume with pressure at the ! 5 sub-column locations [L2 T-2 ~> m2 s-2] - real :: RL2_T2_to_Pa ! A unit conversion factor from the rescaled units of pressure to Pa [Pa T2 R-1 L-2 ~> 1] - real :: SV_scale ! A multiplicative factor by which to scale specific - ! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] logical :: do_massWeight ! Indicates whether to do mass weighting. - real, parameter :: C1_90 = 1.0/90.0 ! A rational constant. - integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, n, halo + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface + logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting + real :: massWeightNVonlyToggle ! A non-dimensional toggle factor for only using mass weighting + ! if at least one side vanished (0 or 1) [nondim] + real :: p_nonvanished ! nonvanished pressure [R L2 T-2 ~> Pa] + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] + integer, dimension(2) :: EOSdom_h5 ! The 5-point h-point i-computational domain for the equation of state + integer, dimension(2) :: EOSdom_q15 ! The 3x5-point q-point i-computational domain for the equation of state + integer, dimension(2) :: EOSdom_h15 ! The 3x5-point h-point i-computational domain for the equation of state + integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, n, pos, halo Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB halo = 0 ; if (present(halo_size)) halo = MAX(halo_size,0) ish = HI%isc-halo ; ieh = HI%iec+halo ; jsh = HI%jsc-halo ; jeh = HI%jec+halo - if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh); endif - if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh); endif - - SV_scale = US%R_to_kg_m3 - RL2_T2_to_Pa = US%RL2_T2_to_Pa - alpha_ref_mks = alpha_ref * US%kg_m3_to_R - - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. - if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& - "bathyP must be present if useMassWghtInterp is present and true.") - if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& - "dP_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif - - do j=jsh,jeh ; do i=ish,ieh - dp = p_b(i,j) - p_t(i,j) - do n=1,5 - T5(n) = T(i,j) ; S5(n) = S(i,j) - p5(n) = RL2_T2_to_Pa * (p_b(i,j) - 0.25*real(n-1)*dp) - enddo + if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh) ; endif + if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh) ; endif + + do_massWeight = .false. ; massWeight_bug = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set + if (do_massWeight .and. .not.present(bathyP)) call MOM_error(FATAL, & + "int_spec_vol_dp_generic_pcm: bathyP must be present if near-bottom mass weighting is in use.") + if (top_massWeight .and. .not.present(P_surf)) call MOM_error(FATAL, & + "int_spec_vol_dp_generic_pcm: P_surf must be present if near-surface mass weighting is in use.") + if ((do_massWeight .or. top_massWeight) .and. .not.present(dP_neglect)) call MOM_error(FATAL, & + "int_spec_vol_dp_generic_pcm: dP_neglect must be present if mass weighting is in use.") + endif + massWeightNVonlyToggle = 1. + if (present(MassWghtInterpVanOnly)) then + if (MassWghtInterpVanOnly) massWeightNVonlyToggle = 0. + endif + p_nonvanished = 0. + if (present(p_nv)) then + p_nonvanished = p_nv + endif - if (SV_scale /= 1.0) then - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) - else - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) - endif - ! Use Boole's rule to estimate the interface height anomaly change. - alpha_anom = C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + 12.0*a5(3)) - dza(i,j) = dp*alpha_anom - ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of - ! the interface height anomaly. - if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & - (alpha_anom - C1_90*(16.0*(a5(4)-a5(2)) + 7.0*(a5(5)-a5(1))) ) - enddo ; enddo + ! Set the loop ranges for equation of state calculations at various points. + EOSdom_h5(1) = 1 ; EOSdom_h5(2) = 5*(ieh-ish+1) + EOSdom_q15(1) = 1 ; EOSdom_q15(2) = 15*(Ieq-Isq+1) + EOSdom_h15(1) = 1 ; EOSdom_h15(2) = 15*(HI%iec-HI%isc+1) - if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation of - ! T & S along the top and bottom integrals, akin to thickness weighting. - hWght = 0.0 - if (do_massWeight) & - hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) - if (hWght > 0.) then - hL = (p_b(i,j) - p_t(i,j)) + dP_neglect - hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 - endif + do j=jsh,jeh + do i=ish,ieh + dp = p_b(i,j) - p_t(i,j) + pos = 5*i + do n=1,5 + T5(pos+n) = T(i,j) ; S5(pos+n) = S(i,j) + p5(pos+n) = p_b(i,j) - 0.25*real(n-1)*dp + enddo + enddo - intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) - do m=2,4 - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + call calculate_spec_vol(T5(5*ish+1:), S5(5*ish+1:), p5(5*ish+1:), a5(5*ish+1:), EOS, & + EOSdom_h5, spv_ref=alpha_ref) - ! T, S, and p are interpolated in the horizontal. The p interpolation - ! is linear, but for T and S it may be thickness weighted. - p5(1) = RL2_T2_to_Pa * (wt_L*p_b(i,j) + wt_R*p_b(i+1,j)) - dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(i+1,j)) - T5(1) = wtT_L*T(i,j) + wtT_R*T(i+1,j) - S5(1) = wtT_L*S(i,j) + wtT_R*S(i+1,j) + do i=ish,ieh + dp = p_b(i,j) - p_t(i,j) + ! Use Boole's rule to estimate the interface height anomaly change. + pos = 5*i + alpha_anom = C1_90*(7.0*(a5(pos+1)+a5(pos+5)) + 32.0*(a5(pos+2)+a5(pos+4)) + 12.0*a5(pos+3)) + dza(i,j) = dp*alpha_anom + ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of + ! the interface height anomaly. + if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & + (alpha_anom - C1_90*(16.0*(a5(pos+4)-a5(pos+2)) + 7.0*(a5(pos+5)-a5(pos+1))) ) + enddo + enddo - do n=2,5 - T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) - RL2_T2_to_Pa * 0.25*dp - enddo - if (SV_scale /= 1.0) then - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) + if (present(intx_dza)) then ; do j=HI%jsc,HI%jec + do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight .and. massWeight_bug) then + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i+1,j), P_surf(i+1,j)-p_b(i,j)) + ! If both sides are nonvanished, then set it back to zero. + if (((p_b(i,j) - p_t(i,j)) > p_nonvanished) .and. ((p_b(i+1,j) - p_t(i+1,j)) > p_nonvanished)) then + hWght = massWeightNVonlyToggle * hWght + endif + + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom else - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 endif - ! Use Boole's rule to estimate the interface height anomaly change. - intp(m) = dp*( C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + & - 12.0*a5(3))) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR) + pos = i*15+(m-2)*5 + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + p15(pos+1) = (wt_L*p_b(i,j)) + (wt_R*p_b(i+1,j)) + dp_x(m,I) = (wt_L*(p_b(i,j) - p_t(i,j))) + (wt_R*(p_b(i+1,j) - p_t(i+1,j))) + T15(pos+1) = (wtT_L*T(i,j)) + (wtT_R*T(i+1,j)) + S15(pos+1) = (wtT_L*S(i,j)) + (wtT_R*S(i+1,j)) + + do n=2,5 + T15(pos+n) = T15(pos+1) ; S15(pos+n) = S15(pos+1) + p15(pos+n) = p15(pos+n-1) - 0.25*dp_x(m,I) + enddo + enddo enddo - ! Use Boole's rule to integrate the interface height anomaly values in x. - intx_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & - 12.0*intp(3)) - enddo ; enddo ; endif - if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation of - ! T & S along the top and bottom integrals, akin to thickness weighting. - hWght = 0.0 - if (do_massWeight) & - hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) - if (hWght > 0.) then - hL = (p_b(i,j) - p_t(i,j)) + dP_neglect - hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom - else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 - endif + call calculate_spec_vol(T15(15*Isq+1:), S15(15*Isq+1:), p15(15*Isq+1:), & + a15(15*Isq+1:), EOS, EOSdom_q15, spv_ref=alpha_ref) - intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) - do m=2,4 - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - - ! T, S, and p are interpolated in the horizontal. The p interpolation - ! is linear, but for T and S it may be thickness weighted. - p5(1) = RL2_T2_to_Pa * (wt_L*p_b(i,j) + wt_R*p_b(i,j+1)) - dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(i,j+1)) - T5(1) = wtT_L*T(i,j) + wtT_R*T(i,j+1) - S5(1) = wtT_L*S(i,j) + wtT_R*S(i,j+1) - do n=2,5 - T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = RL2_T2_to_Pa * (p5(n-1) - 0.25*dp) + do I=Isq,Ieq + intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) + ! Use Boole's rule to estimate the interface height anomaly change. + do m=2,4 + pos = i*15+(m-2)*5 + intp(m) = (dp_x(m,I)*( C1_90*(7.0*(a15(pos+1)+a15(pos+5)) + 32.0*(a15(pos+2)+a15(pos+4)) + & + 12.0*a15(pos+3)) )) enddo - if (SV_scale /= 1.0) then - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) + ! Use Boole's rule to integrate the interface height anomaly values in x. + intx_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + enddo + enddo ; endif + + if (present(inty_dza)) then ; do J=Jsq,Jeq + do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight .and. massWeight_bug) then + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i,j+1), P_surf(i,j+1)-p_b(i,j)) + ! If both sides are nonvanished, then set it back to zero. + if (((p_b(i,j) - p_t(i,j)) > p_nonvanished) .and. ((p_b(i,j+1) - p_t(i,j+1)) > p_nonvanished)) then + hWght = massWeightNVonlyToggle * hWght + endif + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom else - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 endif - ! Use Boole's rule to estimate the interface height anomaly change. - intp(m) = dp*( C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + & - 12.0*a5(3))) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR) + pos = i*15+(m-2)*5 + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + p15(pos+1) = (wt_L*p_b(i,j)) + (wt_R*p_b(i,j+1)) + dp_y(m,i) = (wt_L*(p_b(i,j) - p_t(i,j))) + (wt_R*(p_b(i,j+1) - p_t(i,j+1))) + T15(pos+1) = (wtT_L*T(i,j)) + (wtT_R*T(i,j+1)) + S15(pos+1) = (wtT_L*S(i,j)) + (wtT_R*S(i,j+1)) + do n=2,5 + T15(pos+n) = T15(pos+1) ; S15(pos+n) = S15(pos+1) + p15(pos+n) = p15(pos+n-1) - 0.25*dp_y(m,i) + enddo + enddo enddo - ! Use Boole's rule to integrate the interface height anomaly values in y. - inty_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & - 12.0*intp(3)) - enddo ; enddo ; endif + + call calculate_spec_vol(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + a15(15*HI%isc+1:), EOS, EOSdom_h15, spv_ref=alpha_ref) + + do i=HI%isc,HI%iec + + intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) + ! Use Boole's rule to estimate the interface height anomaly change. + do m=2,4 + pos = i*15+(m-2)*5 + intp(m) = (dp_y(m,i)*( C1_90*(7.0*(a15(pos+1)+a15(pos+5)) + 32.0*(a15(pos+2)+a15(pos+4)) + & + 12.0*a15(pos+3)) )) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in y. + inty_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + enddo + enddo ; endif end subroutine int_spec_vol_dp_generic_pcm @@ -1395,29 +1669,30 @@ end subroutine int_spec_vol_dp_generic_pcm !! no free assumptions, apart from the use of Boole's rule quadrature to do the integrals. subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, & dP_neglect, bathyP, HI, EOS, US, dza, & - intp_dza, intx_dza, inty_dza, useMassWghtInterp) + intp_dza, intx_dza, inty_dza, P_surf, MassWghtInterp, & + MassWghtInterpVanOnly, p_nv) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: T_t !< Potential temperature at the top of the layer [degC] + intent(in) :: T_t !< Potential temperature at the top of the layer [C ~> degC] real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: T_b !< Potential temperature at the bottom of the layer [degC] + intent(in) :: T_b !< Potential temperature at the bottom of the layer [C ~> degC] real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: S_t !< Salinity at the top the layer [ppt] + intent(in) :: S_t !< Salinity at the top the layer [S ~> ppt] real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: S_b !< Salinity at the bottom the layer [ppt] + intent(in) :: S_b !< Salinity at the bottom the layer [S ~> ppt] real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: p_t !< Pressure atop the layer [R L2 T-2 ~> Pa] or [Pa] + intent(in) :: p_t !< Pressure atop the layer [R L2 T-2 ~> Pa] real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] or [Pa] + intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1] !! The calculation is mathematically identical with different values of !! alpha_ref, but alpha_ref alters the effects of roundoff, and !! answers do change. real, intent(in) :: dP_neglect ! Pa] or [Pa] + !! the same units as p_t [R L2 T-2 ~> Pa] real, dimension(SZI_(HI),SZJ_(HI)), & - intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] + intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] type(EOS_type), intent(in) :: EOS !< Equation of state structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(HI),SZJ_(HI)), & @@ -1426,17 +1701,22 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, real, dimension(SZI_(HI),SZJ_(HI)), & optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of !! the geopotential anomaly relative to the anomaly at the bottom of the - !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2] + !! layer [R L4 T-4 ~> Pa m2 s-2] real, dimension(SZIB_(HI),SZJ_(HI)), & optional, intent(inout) :: intx_dza !< The integral in x of the difference between !! the geopotential anomaly at the top and bottom of the layer divided - !! by the x grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] + !! by the x grid spacing [L2 T-2 ~> m2 s-2] real, dimension(SZI_(HI),SZJB_(HI)), & optional, intent(inout) :: inty_dza !< The integral in y of the difference between !! the geopotential anomaly at the top and bottom of the layer divided - !! by the y grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. + !! by the y grid spacing [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(HI),SZJ_(HI)), & + optional, intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals + logical, optional, intent(in) :: MassWghtInterpVanOnly !< If true, does not do mass weighting + !! of T/S unless one side smaller than h_nv (i.e. vanished) + real, optional, intent(in) :: p_nv !< Nonvanished pressure [R L2 T-2 ~> Pa] ! This subroutine calculates analytical and nearly-analytical integrals in ! pressure across layers of geopotential anomalies, which are required for @@ -1445,26 +1725,25 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, ! Boole's rule to do the horizontal integrals, and from a truncation in the ! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. - real :: T5(5) ! Temperatures at five quadrature points [degC] - real :: S5(5) ! Salinities at five quadrature points [ppt] - real :: p5(5) ! Pressures at five quadrature points, scaled back to Pa as necessary [Pa] - real :: a5(5) ! Specific volumes at five quadrature points [R-1 ~> m3 kg-1] or [m3 kg-1] - real :: T15(15) ! Temperatures at fifteen interior quadrature points [degC] - real :: S15(15) ! Salinities at fifteen interior quadrature points [ppt] - real :: p15(15) ! Pressures at fifteen quadrature points, scaled back to Pa as necessary [Pa] - real :: a15(15) ! Specific volumes at fifteen quadrature points [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: T5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Temperatures along a line of subgrid locations [C ~> degC] + real :: S5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Salinities along a line of subgrid locations [S ~> ppt] + real :: p5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Pressures along a line of subgrid locations [R L2 T-2 ~> Pa] + real :: a5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Specific volumes anomalies along a line of subgrid + ! locations [R-1 ~> m3 kg-1] + real :: T15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Temperatures at an array of subgrid locations [C ~> degC] + real :: S15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Salinities at an array of subgrid locations [S ~> ppt] + real :: p15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Pressures at an array of subgrid locations [R L2 T-2 ~> Pa] + real :: a15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Specific volumes at an array of subgrid locations [R ~> kg m-3] real :: wt_t(5), wt_b(5) ! Weights of top and bottom values at quadrature points [nondim] - real :: T_top, T_bot ! Horizontally interpolated temperature at the cell top and bottom [degC] - real :: S_top, S_bot ! Horizontally interpolated salinity at the cell top and bottom [ppt] - real :: P_top, P_bot ! Horizontally interpolated pressure at the cell top and bottom, - ! scaled back to Pa as necessary [Pa] + real :: T_top, T_bot ! Horizontally interpolated temperature at the cell top and bottom [C ~> degC] + real :: S_top, S_bot ! Horizontally interpolated salinity at the cell top and bottom [S ~> ppt] + real :: P_top, P_bot ! Horizontally interpolated pressure at the cell top and bottom [R L2 T-2 ~> Pa] - real :: alpha_anom ! The depth averaged specific density anomaly [R-1 ~> m3 kg-1] or [m3 kg-1] + real :: alpha_anom ! The depth averaged specific density anomaly [R-1 ~> m3 kg-1] real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa] - real :: dp_90(2:4) ! The pressure change through a layer divided by 90 [R L2 T-2 ~> Pa] + real :: dp_90(2:4,SZIB_(HI)) ! The pressure change through a layer divided by 90 [R L2 T-2 ~> Pa] real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa] real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa] - real :: alpha_ref_mks ! The reference specific volume in MKS units, never rescaled from m3 kg-1 [m3 kg-1] real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> Pa-2] real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim] real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim] @@ -1472,184 +1751,432 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim] real :: intp(5) ! The integrals of specific volume with pressure at the ! 5 sub-column locations [L2 T-2 ~> m2 s-2] - real :: RL2_T2_to_Pa ! A unit conversion factor from the rescaled units of pressure to Pa [Pa T2 R-1 L-2 ~> 1] - real :: SV_scale ! A multiplicative factor by which to scale specific - ! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] - real, parameter :: C1_90 = 1.0/90.0 ! A rational constant. + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface + logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting + real :: massWeightNVonlyToggle ! A non-dimensional toggle factor for only using mass weighting + ! if at least one side vanished (0 or 1) [nondim] + real :: p_nonvanished ! nonvanished pressure [R L2 T-2 ~> Pa] + integer, dimension(2) :: EOSdom_h5 ! The 5-point h-point i-computational domain for the equation of state + integer, dimension(2) :: EOSdom_q15 ! The 3x5-point q-point i-computational domain for the equation of state + integer, dimension(2) :: EOSdom_h15 ! The 3x5-point h-point i-computational domain for the equation of state integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n, pos Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB - do_massWeight = .false. - if (present(useMassWghtInterp)) do_massWeight = useMassWghtInterp - - SV_scale = US%R_to_kg_m3 - RL2_T2_to_Pa = US%RL2_T2_to_Pa - alpha_ref_mks = alpha_ref * US%kg_m3_to_R + do_massWeight = .false. ; massWeight_bug = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set + if (top_massWeight .and. .not.present(P_surf)) call MOM_error(FATAL, & + "int_spec_vol_dp_generic_plm: P_surf must be present if near-surface mass weighting is in use.") + endif + massWeightNVonlyToggle = 1. + if (present(MassWghtInterpVanOnly)) then + if (MassWghtInterpVanOnly) massWeightNVonlyToggle = 0. + endif + p_nonvanished = 0. + if (present(p_nv)) then + p_nonvanished = p_nv + endif do n = 1, 5 ! Note that these are reversed from int_density_dz. wt_t(n) = 0.25 * real(n-1) wt_b(n) = 1.0 - wt_t(n) enddo + ! Set the loop ranges for equation of state calculations at various points. + EOSdom_h5(1) = 1 ; EOSdom_h5(2) = 5*(Ieq-Isq+2) + EOSdom_q15(1) = 1 ; EOSdom_q15(2) = 15*(Ieq-Isq+1) + EOSdom_h15(1) = 1 ; EOSdom_h15(2) = 15*(HI%iec-HI%isc+1) + ! 1. Compute vertical integrals - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dp = p_b(i,j) - p_t(i,j) - do n=1,5 ! T, S and p are linearly interpolated in the vertical. - p5(n) = RL2_T2_to_Pa * (wt_t(n) * p_t(i,j) + wt_b(n) * p_b(i,j)) - S5(n) = wt_t(n) * S_t(i,j) + wt_b(n) * S_b(i,j) - T5(n) = wt_t(n) * T_t(i,j) + wt_b(n) * T_b(i,j) + do j=Jsq,Jeq+1 + do i=Isq,Ieq+1 + do n=1,5 ! T, S and p are linearly interpolated in the vertical. + p5(i*5+n) = wt_t(n) * p_t(i,j) + wt_b(n) * p_b(i,j) + S5(i*5+n) = wt_t(n) * S_t(i,j) + wt_b(n) * S_b(i,j) + T5(i*5+n) = wt_t(n) * T_t(i,j) + wt_b(n) * T_b(i,j) + enddo + enddo + call calculate_spec_vol(T5, S5, p5, a5, EOS, EOSdom_h5, spv_ref=alpha_ref) + do i=Isq,Ieq+1 + ! Use Boole's rule to estimate the interface height anomaly change. + dp = p_b(i,j) - p_t(i,j) + alpha_anom = C1_90*((7.0*(a5(i*5+1)+a5(i*5+5)) + 32.0*(a5(i*5+2)+a5(i*5+4))) + 12.0*a5(i*5+3)) + dza(i,j) = dp*alpha_anom + ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of + ! the interface height anomaly. + if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & + (alpha_anom - C1_90*(16.0*(a5(i*5+4)-a5(i*5+2)) + 7.0*(a5(i*5+5)-a5(i*5+1))) ) + enddo + enddo + + ! 2. Compute horizontal integrals in the x direction + if (present(intx_dza)) then ; do j=HI%jsc,HI%jec + do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. Note: To work in terrain following coordinates we could + ! offset this distance by the layer thickness to replicate other models. + hWght = 0.0 + if (do_massWeight .and. massWeight_bug) then + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i+1,j), P_surf(i+1,j)-p_b(i,j)) + ! If both sides are nonvanished, then set it back to zero. + if (((p_b(i,j) - p_t(i,j)) > p_nonvanished) .and. ((p_b(i+1,j) - p_t(i+1,j)) > p_nonvanished)) then + hWght = massWeightNVonlyToggle * hWght + endif + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR) + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + P_top = (wt_L*p_t(i,j)) + (wt_R*p_t(i+1,j)) + P_bot = (wt_L*p_b(i,j)) + (wt_R*p_b(i+1,j)) + T_top = (wtT_L*T_t(i,j)) + (wtT_R*T_t(i+1,j)) + T_bot = (wtT_L*T_b(i,j)) + (wtT_R*T_b(i+1,j)) + S_top = (wtT_L*S_t(i,j)) + (wtT_R*S_t(i+1,j)) + S_bot = (wtT_L*S_b(i,j)) + (wtT_R*S_b(i+1,j)) + dp_90(m,I) = C1_90*(P_bot - P_top) + + ! Salinity, temperature and pressure with linear interpolation in the vertical. + pos = i*15+(m-2)*5 + do n=1,5 + p15(pos+n) = wt_t(n) * P_top + wt_b(n) * P_bot + S15(pos+n) = wt_t(n) * S_top + wt_b(n) * S_bot + T15(pos+n) = wt_t(n) * T_top + wt_b(n) * T_bot + enddo + enddo + enddo + + call calculate_spec_vol(T15, S15, p15, a15, EOS, EOSdom_q15, spv_ref=alpha_ref) + + do I=Isq,Ieq + intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) + do m=2,4 + ! Use Boole's rule to estimate the interface height anomaly change. + ! The integrals at the ends of the segment are already known. + pos = I*15+(m-2)*5 + intp(m) = (dp_90(m,I)*((7.0*(a15(pos+1)+a15(pos+5)) + & + 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3) )) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in x. + intx_dza(I,j) = C1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + & + 12.0*intp(3)) + enddo + enddo ; endif + + ! 3. Compute horizontal integrals in the y direction + if (present(inty_dza)) then ; do J=Jsq,Jeq + do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, like thickness weighting. + hWght = 0.0 + if (do_massWeight .and. massWeight_bug) then + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i,j+1), P_surf(i,j+1)-p_b(i,j)) + ! If both sides are nonvanished, then set it back to zero. + if (((p_b(i,j) - p_t(i,j)) > p_nonvanished) .and. ((p_b(i,j+1) - p_t(i,j+1)) > p_nonvanished)) then + hWght = massWeightNVonlyToggle * hWght + endif + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR) + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + P_top = (wt_L*p_t(i,j)) + (wt_R*p_t(i,j+1)) + P_bot = (wt_L*p_b(i,j)) + (wt_R*p_b(i,j+1)) + T_top = (wtT_L*T_t(i,j)) + (wtT_R*T_t(i,j+1)) + T_bot = (wtT_L*T_b(i,j)) + (wtT_R*T_b(i,j+1)) + S_top = (wtT_L*S_t(i,j)) + (wtT_R*S_t(i,j+1)) + S_bot = (wtT_L*S_b(i,j)) + (wtT_R*S_b(i,j+1)) + dp_90(m,i) = C1_90*(P_bot - P_top) + + ! Salinity, temperature and pressure with linear interpolation in the vertical. + pos = i*15+(m-2)*5 + do n=1,5 + p15(pos+n) = wt_t(n) * P_top + wt_b(n) * P_bot + S15(pos+n) = wt_t(n) * S_top + wt_b(n) * S_bot + T15(pos+n) = wt_t(n) * T_top + wt_b(n) * T_bot + enddo + enddo + enddo + + call calculate_spec_vol(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + a15(15*HI%isc+1:), EOS, EOSdom_h15, spv_ref=alpha_ref) + + do i=HI%isc,HI%iec + intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) + do m=2,4 + ! Use Boole's rule to estimate the interface height anomaly change. + ! The integrals at the ends of the segment are already known. + pos = i*15+(m-2)*5 + intp(m) = (dp_90(m,i) * ((7.0*(a15(pos+1)+a15(pos+5)) + & + 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3))) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in x. + inty_dza(i,J) = C1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + & + 12.0*intp(3)) enddo - if (SV_scale /= 1.0) then - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks, scale=SV_scale) + enddo ; endif + +end subroutine int_spec_vol_dp_generic_plm + + +!> Diagnose the fractional mass weighting in a layer that might be used with a Boussinesq calculation. +subroutine diagnose_mass_weight_Z(z_t, z_b, bathyT, SSH, dz_neglect, MassWghtInterp, HI, & + MassWt_u, MassWt_v, MassWghtInterpVanOnly, h_nv) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: SSH !< The sea surface height [Z ~> m] + real, intent(in) :: dz_neglect !< A minuscule thickness change [Z ~> m] + integer, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals + real, dimension(SZIB_(HI),SZJ_(HI)), & + intent(inout) :: MassWt_u !< The fractional mass weighting at u-points [nondim] + real, dimension(SZI_(HI),SZJB_(HI)), & + intent(inout) :: MassWt_v !< The fractional mass weighting at v-points [nondim] + logical, optional, intent(in) :: MassWghtInterpVanOnly !< If true, does not do mass weighting + !! of T/S unless one side smaller than h_nv (i.e. vanished) + real, optional, intent(in) :: h_nv !< Nonvanished height [Z ~> m] + + ! Local variables + real :: hWght ! A pressure-thickness below topography [Z ~> m] + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m] + real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> m-2] + logical :: do_massWeight ! Indicates whether to do mass weighting near bathymetry + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface + real :: massWeightNVonlyToggle ! A non-dimensional toggle factor for only using mass weighting + real :: h_nonvanished ! nonvanished height [Z ~> m] + integer :: Isq, Ieq, Jsq, Jeq, i, j + + Isq = HI%IscB ; Ieq = HI%IecB + Jsq = HI%JscB ; Jeq = HI%JecB + + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + massWeightNVonlyToggle = 1. + if (present(MassWghtInterpVanOnly)) then + if (MassWghtInterpVanOnly) massWeightNVonlyToggle = 0. + endif + h_nonvanished = 0. + if (present(h_nv)) then + h_nonvanished = h_nv + endif + + ! Calculate MassWt_u + do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, like thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i+1,j)-SSH(i,j), z_b(i,j)-SSH(i+1,j)) + ! If both sides are nonvanished, then set it back to zero. + if (((z_t(i,j) - z_b(i,j)) > h_nonvanished) .and. ((z_t(i+1,j) - z_b(i+1,j)) > h_nonvanished)) then + hWght = massWeightNVonlyToggle * hWght + endif + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + MassWt_u(I,j) = (hWght*hR + hWght*hL) * iDenom else - call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref_mks) + MassWt_u(I,j) = 0.0 endif - - ! Use Boole's rule to estimate the interface height anomaly change. - alpha_anom = C1_90*((7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4))) + 12.0*a5(3)) - dza(i,j) = dp*alpha_anom - ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of - ! the interface height anomaly. - if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & - (alpha_anom - C1_90*(16.0*(a5(4)-a5(2)) + 7.0*(a5(5)-a5(1))) ) enddo ; enddo - ! 2. Compute horizontal integrals in the x direction - if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! Calculate MassWt_v + do J=Jsq,Jeq ; do i=HI%isc,HI%iec ! hWght is the distance measure by which the cell is violation of ! hydrostatic consistency. For large hWght we bias the interpolation - ! of T,S along the top and bottom integrals, almost like thickness - ! weighting. Note: To work in terrain following coordinates we could - ! offset this distance by the layer thickness to replicate other models. + ! of T,S along the top and bottom integrals, like thickness weighting. hWght = 0.0 if (do_massWeight) & - hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i,j+1)-SSH(i,j), z_b(i,j)-SSH(i,j+1)) + ! If both sides are nonvanished, then set it back to zero. + if (((z_t(i,j) - z_b(i,j)) > h_nonvanished) .and. ((z_t(i,j+1) - z_b(i,j+1)) > h_nonvanished)) then + hWght = massWeightNVonlyToggle * hWght + endif if (hWght > 0.) then - hL = (p_b(i,j) - p_t(i,j)) + dP_neglect - hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect hWght = hWght * ( (hL-hR)/(hL+hR) )**2 iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + MassWt_v(i,J) = (hWght*hR + hWght*hL) * iDenom else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + MassWt_v(i,J) = 0.0 endif + enddo ; enddo - do m=2,4 - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - - ! T, S, and p are interpolated in the horizontal. The p interpolation - ! is linear, but for T and S it may be thickness weighted. - P_top = wt_L*p_t(i,j) + wt_R*p_t(i+1,j) - P_bot = wt_L*p_b(i,j) + wt_R*p_b(i+1,j) - T_top = wtT_L*T_t(i,j) + wtT_R*T_t(i+1,j) - T_bot = wtT_L*T_b(i,j) + wtT_R*T_b(i+1,j) - S_top = wtT_L*S_t(i,j) + wtT_R*S_t(i+1,j) - S_bot = wtT_L*S_b(i,j) + wtT_R*S_b(i+1,j) - dp_90(m) = C1_90*(P_bot - P_top) - - ! Salinity, temperature and pressure with linear interpolation in the vertical. - pos = (m-2)*5 - do n=1,5 - p15(pos+n) = RL2_T2_to_Pa * (wt_t(n) * P_top + wt_b(n) * P_bot) - S15(pos+n) = wt_t(n) * S_top + wt_b(n) * S_bot - T15(pos+n) = wt_t(n) * T_top + wt_b(n) * T_bot - enddo - enddo +end subroutine diagnose_mass_weight_Z - if (SV_scale /= 1.0) then - call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks, scale=SV_scale) - else - call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks) - endif - intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) - do m=2,4 - ! Use Boole's rule to estimate the interface height anomaly change. - ! The integrals at the ends of the segment are already known. - pos = (m-2)*5 - intp(m) = dp_90(m)*((7.0*(a15(pos+1)+a15(pos+5)) + & - 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3)) - enddo - ! Use Boole's rule to integrate the interface height anomaly values in x. - intx_dza(I,j) = C1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + & - 12.0*intp(3)) - enddo ; enddo ; endif +!> Diagnose the fractional mass weighting in a layer that might be used with a non-Boussinesq calculation. +subroutine diagnose_mass_weight_p(p_t, p_b, bathyP, P_surf, dP_neglect, MassWghtInterp, HI, & + MassWt_u, MassWt_v, MassWghtInterpVanOnly, p_nv) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_t !< Pressure atop the layer [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_b !< Pressure below the layer [R L2 T-2 ~> Pa] + real, intent(in) :: dP_neglect ! Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] + integer, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals + real, dimension(SZIB_(HI),SZJ_(HI)), & + intent(inout) :: MassWt_u !< The fractional mass weighting at u-points [nondim] + real, dimension(SZI_(HI),SZJB_(HI)), & + intent(inout) :: MassWt_v !< The fractional mass weighting at v-points [nondim] + logical, optional, intent(in) :: MassWghtInterpVanOnly !< If true, does not do mass weighting + !! of T/S unless one side smaller than h_nv (i.e. vanished) + real, optional, intent(in) :: p_nv !< Nonvanished pressure [R L2 T-2 ~> Pa] - ! 3. Compute horizontal integrals in the y direction - if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! Local variables + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa] + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa] + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> Pa-2] + logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface + logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting + real :: massWeightNVonlyToggle ! A non-dimensional toggle factor for only using mass weighting + ! if at least one side vanished (0 or 1) [nondim] + real :: p_nonvanished ! nonvanished pressure [R L2 T-2 ~> Pa] + + integer :: Isq, Ieq, Jsq, Jeq, i, j + + Isq = HI%IscB ; Ieq = HI%IecB + Jsq = HI%JscB ; Jeq = HI%JecB + + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set + massWeightNVonlyToggle = 1. + if (present(MassWghtInterpVanOnly)) then + if (MassWghtInterpVanOnly) massWeightNVonlyToggle = 0. + endif + p_nonvanished = 0. + if (present(p_nv)) then + p_nonvanished = p_nv + endif + + ! Calculate MassWt_u + do j=HI%jsc,HI%jec ; do I=Isq,Ieq ! hWght is the distance measure by which the cell is violation of ! hydrostatic consistency. For large hWght we bias the interpolation ! of T,S along the top and bottom integrals, like thickness weighting. hWght = 0.0 - if (do_massWeight) & - hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + if (do_massWeight .and. massWeight_bug) then + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i+1,j), P_surf(i+1,j)-p_b(i,j)) + ! If both sides are nonvanished, then set it back to zero. + if (((p_b(i,j) - p_t(i,j)) > p_nonvanished) .and. ((p_b(i+1,j) - p_t(i+1,j)) > p_nonvanished)) then + hWght = massWeightNVonlyToggle * hWght + endif if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect - hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect hWght = hWght * ( (hL-hR)/(hL+hR) )**2 iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) - hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom - hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + MassWt_u(I,j) = (hWght*hR + hWght*hL) * iDenom else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + MassWt_u(I,j) = 0.0 endif + enddo ; enddo - do m=2,4 - wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - - ! T, S, and p are interpolated in the horizontal. The p interpolation - ! is linear, but for T and S it may be thickness weighted. - P_top = wt_L*p_t(i,j) + wt_R*p_t(i,j+1) - P_bot = wt_L*p_b(i,j) + wt_R*p_b(i,j+1) - T_top = wtT_L*T_t(i,j) + wtT_R*T_t(i,j+1) - T_bot = wtT_L*T_b(i,j) + wtT_R*T_b(i,j+1) - S_top = wtT_L*S_t(i,j) + wtT_R*S_t(i,j+1) - S_bot = wtT_L*S_b(i,j) + wtT_R*S_b(i,j+1) - dp_90(m) = C1_90*(P_bot - P_top) - - ! Salinity, temperature and pressure with linear interpolation in the vertical. - pos = (m-2)*5 - do n=1,5 - p15(pos+n) = RL2_T2_to_Pa * (wt_t(n) * P_top + wt_b(n) * P_bot) - S15(pos+n) = wt_t(n) * S_top + wt_b(n) * S_bot - T15(pos+n) = wt_t(n) * T_top + wt_b(n) * T_bot - enddo - enddo - - if (SV_scale /= 1.0) then - call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks, scale=SV_scale) + ! Calculate MassWt_v + do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, like thickness weighting. + hWght = 0.0 + if (do_massWeight .and. massWeight_bug) then + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i,j+1), P_surf(i,j+1)-p_b(i,j)) + ! If both sides are nonvanished, then set it back to zero. + if (((p_b(i,j) - p_t(i,j)) > p_nonvanished) .and. ((p_b(i,j+1) - p_t(i,j+1)) > p_nonvanished)) then + hWght = massWeightNVonlyToggle * hWght + endif + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + MassWt_v(i,J) = (hWght*hR + hWght*hL) * iDenom else - call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref_mks) + MassWt_v(i,J) = 0.0 endif + enddo ; enddo - intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) - do m=2,4 - ! Use Boole's rule to estimate the interface height anomaly change. - ! The integrals at the ends of the segment are already known. - pos = (m-2)*5 - intp(m) = dp_90(m) * ((7.0*(a15(pos+1)+a15(pos+5)) + & - 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3)) - enddo - ! Use Boole's rule to integrate the interface height anomaly values in x. - inty_dza(i,J) = C1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + & - 12.0*intp(3)) - enddo ; enddo ; endif - -end subroutine int_spec_vol_dp_generic_plm - +end subroutine diagnose_mass_weight_p !> Find the depth at which the reconstructed pressure matches P_tgt subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_tgt, & - rho_ref, G_e, EOS, US, P_b, z_out, z_tol) - real, intent(in) :: T_t !< Potential temperature at the cell top [degC] - real, intent(in) :: T_b !< Potential temperature at the cell bottom [degC] - real, intent(in) :: S_t !< Salinity at the cell top [ppt] - real, intent(in) :: S_b !< Salinity at the cell bottom [ppt] + rho_ref, G_e, EOS, US, P_b, z_out, z_tol, frac_dp_bugfix) + real, intent(in) :: T_t !< Potential temperature at the cell top [C ~> degC] + real, intent(in) :: T_b !< Potential temperature at the cell bottom [C ~> degC] + real, intent(in) :: S_t !< Salinity at the cell top [S ~> ppt] + real, intent(in) :: S_b !< Salinity at the cell bottom [S ~> ppt] real, intent(in) :: z_t !< Absolute height of top of cell [Z ~> m] (Boussinesq ????) real, intent(in) :: z_b !< Absolute height of bottom of cell [Z ~> m] real, intent(in) :: P_t !< Anomalous pressure of top of cell, relative @@ -1660,22 +2187,24 @@ subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_t !! are anomalous to [R ~> kg m-3] real, intent(in) :: G_e !< Gravitational acceleration [L2 Z-1 T-2 ~> m s-2] type(EOS_type), intent(in) :: EOS !< Equation of state structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(out) :: P_b !< Pressure at the bottom of the cell [R L2 T-2 ~> Pa] real, intent(out) :: z_out !< Absolute depth at which anomalous pressure = p_tgt [Z ~> m] - real, optional, intent(in) :: z_tol !< The tolerance in finding z_out [Z ~> m] + real, intent(in) :: z_tol !< The tolerance in finding z_out [Z ~> m] + logical, intent(in) :: frac_dp_bugfix !< If true, use bugfix in frac_dp_at_pos ! Local variables real :: dp ! Pressure thickness of the layer [R L2 T-2 ~> Pa] real :: F_guess, F_l, F_r ! Fractional positions [nondim] real :: GxRho ! The product of the gravitational acceleration and reference density [R L2 Z-1 T-2 ~> Pa m-1] real :: Pa, Pa_left, Pa_right, Pa_tol ! Pressure anomalies, P = integral of g*(rho-rho_ref) dz [R L2 T-2 ~> Pa] + integer :: m ! A counter for how many iterations have been done in the while loop character(len=240) :: msg GxRho = G_e * rho_ref ! Anomalous pressure difference across whole cell - dp = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, 1.0, EOS) + dp = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, 1.0, EOS, frac_dp_bugfix) P_b = P_t + dp ! Anomalous pressure at bottom of cell @@ -1693,15 +2222,20 @@ subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_t Pa_left = P_t - P_tgt ! Pa_left < 0 F_r = 1. Pa_right = P_b - P_tgt ! Pa_right > 0 - Pa_tol = GxRho * 1.0e-5*US%m_to_Z - if (present(z_tol)) Pa_tol = GxRho * z_tol + Pa_tol = GxRho * z_tol F_guess = F_l - Pa_left / (Pa_right - Pa_left) * (F_r - F_l) Pa = Pa_right - Pa_left ! To get into iterative loop + m = 0 ! Reset the counter for the loop to be zero do while ( abs(Pa) > Pa_tol ) + m = m + 1 + if (m > 30) then ! Call an error, because convergence to the tolerance has not been achieved + write(msg,*) Pa_left,Pa,Pa_right,P_t-P_tgt,P_b-P_tgt + call MOM_error(FATAL, 'find_depth_of_pressure_in_cell completes too many iterations: '//msg) + endif z_out = z_t + ( z_b - z_t ) * F_guess - Pa = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, F_guess, EOS) - ( P_tgt - P_t ) + Pa = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, F_guess, EOS, frac_dp_bugfix) - ( P_tgt - P_t ) if (Pa Calculate the average in situ specific volume across layers +subroutine avg_specific_vol(T, S, p_t, dp, HI, EOS, SpV_avg, halo_size) + type(hor_index_type), intent(in) :: HI !< The horizontal index structure + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: T !< Potential temperature of the layer [C ~> degC] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: S !< Salinity of the layer [S ~> ppt] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(in) :: dp !< Pressure change in the layer [R L2 T-2 ~> Pa] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + real, dimension(SZI_(HI),SZJ_(HI)), & + intent(inout) :: SpV_avg !< The vertical average specific volume + !! in the layer [R-1 ~> m3 kg-1] + integer, optional, intent(in) :: halo_size !< The number of halo points in which to work. + + ! Local variables + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: jsh, jeh, j, halo + + halo = 0 ; if (present(halo_size)) halo = MAX(halo_size,0) + jsh = HI%jsc-halo ; jeh = HI%jec+halo + + EOSdom(:) = EOS_domain(HI, halo_size) + do j=jsh,jeh + call average_specific_vol(T(:,j), S(:,j), p_t(:,j), dp(:,j), SpV_avg(:,j), EOS, EOSdom) + enddo + +end subroutine avg_specific_vol !> Returns change in anomalous pressure change from top to non-dimensional -!! position pos between z_t and z_b -real function frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, pos, EOS) - real, intent(in) :: T_t !< Potential temperature at the cell top [degC] - real, intent(in) :: T_b !< Potential temperature at the cell bottom [degC] - real, intent(in) :: S_t !< Salinity at the cell top [ppt] - real, intent(in) :: S_b !< Salinity at the cell bottom [ppt] +!! position pos between z_t and z_b [R L2 T-2 ~> Pa] +real function frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, pos, EOS, frac_dp_bugfix) + real, intent(in) :: T_t !< Potential temperature at the cell top [C ~> degC] + real, intent(in) :: T_b !< Potential temperature at the cell bottom [C ~> degC] + real, intent(in) :: S_t !< Salinity at the cell top [S ~> ppt] + real, intent(in) :: S_b !< Salinity at the cell bottom [S ~> ppt] real, intent(in) :: z_t !< The geometric height at the top of the layer [Z ~> m] real, intent(in) :: z_b !< The geometric height at the bottom of the layer [Z ~> m] real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that is subtracted out to @@ -1739,15 +2303,15 @@ real function frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, pos, EO real, intent(in) :: G_e !< The Earth's gravitational acceleration [L2 Z-1 T-2 ~> m s-2] real, intent(in) :: pos !< The fractional vertical position, 0 to 1 [nondim] type(EOS_type), intent(in) :: EOS !< Equation of state structure - real :: fract_dp_at_pos !< The change in pressure from the layer top to - !! fractional position pos [R L2 T-2 ~> Pa] + logical, intent(in) :: frac_dp_bugfix !< If true, use bugfix in frac_dp_at_pos + ! Local variables real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] real :: dz ! Distance from the layer top [Z ~> m] real :: top_weight, bottom_weight ! Fractional weights at quadrature points [nondim] real :: rho_ave ! Average density [R ~> kg m-3] - real, dimension(5) :: T5 ! Temperatures at quadrature points [degC] - real, dimension(5) :: S5 ! Salinities at quadrature points [ppt] + real, dimension(5) :: T5 ! Temperatures at quadrature points [C ~> degC] + real, dimension(5) :: S5 ! Salinities at quadrature points [S ~> ppt] real, dimension(5) :: p5 ! Pressures at quadrature points [R L2 T-2 ~> Pa] real, dimension(5) :: rho5 ! Densities at quadrature points [R ~> kg m-3] integer :: n @@ -1759,7 +2323,11 @@ real function frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, pos, EO ! Salinity and temperature points are linearly interpolated S5(n) = top_weight * S_t + bottom_weight * S_b T5(n) = top_weight * T_t + bottom_weight * T_b - p5(n) = ( top_weight * z_t + bottom_weight * z_b ) * ( G_e * rho_ref ) + if (frac_dp_bugfix) then + p5(n) = (-1) * ( top_weight * z_t + bottom_weight * z_b ) * ( G_e * rho_ref ) + else + p5(n) = ( top_weight * z_t + bottom_weight * z_b ) * ( G_e * rho_ref ) + endif !bugfix enddo call calculate_density(T5, S5, p5, rho5, EOS) rho5(:) = rho5(:) !- rho_ref ! Work with anomalies relative to rho_ref diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 68b844562f..ee58249dd1 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -1,9 +1,11 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Time step the adiabatic dynamic core of MOM using RK2 method. module MOM_dynamics_split_RK2 -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_variables, only : vertvisc_type, thermo_var_ptrs, porous_barrier_ptrs +use MOM_variables, only : vertvisc_type, thermo_var_ptrs, porous_barrier_type use MOM_variables, only : BT_cont_type, alloc_bt_cont_type, dealloc_bt_cont_type use MOM_variables, only : accel_diag_ptrs, ocean_internal_state, cont_diag_ptrs use MOM_forcing_type, only : mech_forcing @@ -12,6 +14,7 @@ module MOM_dynamics_split_RK2 use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_SUBCOMPONENT use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member use MOM_diag_mediator, only : diag_mediator_init, enable_averages use MOM_diag_mediator, only : disable_averaging, post_data, safe_alloc_ptr use MOM_diag_mediator, only : post_product_u, post_product_sum_u @@ -21,21 +24,22 @@ module MOM_dynamics_split_RK2 use MOM_domains, only : To_South, To_West, To_All, CGRID_NE, SCALAR_PAIR use MOM_domains, only : To_North, To_East, Omit_Corners use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type -use MOM_domains, only : start_group_pass, complete_group_pass, pass_var -use MOM_debugging, only : hchksum, uvchksum +use MOM_domains, only : start_group_pass, complete_group_pass, pass_var, pass_vector +use MOM_debugging, only : hchksum, uvchksum, query_debugging_checks use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_error_handler, only : MOM_set_verbosity, callTree_showQuery use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories -use MOM_io, only : vardesc, var_desc +use MOM_io, only : vardesc, var_desc, EAST_FACE, NORTH_FACE use MOM_restart, only : register_restart_field, register_restart_pair -use MOM_restart, only : query_initialized, save_restart +use MOM_restart, only : query_initialized, set_initialized, save_restart +use MOM_restart, only : only_read_from_restarts use MOM_restart, only : restart_init, is_new_run, MOM_restart_CS -use MOM_time_manager, only : time_type, time_type_to_real, operator(+) +use MOM_time_manager, only : time_type, operator(+) use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) -use MOM_ALE, only : ALE_CS +use MOM_ALE, only : ALE_CS, ALE_remap_velocities use MOM_barotropic, only : barotropic_init, btstep, btcalc, bt_mass_source use MOM_barotropic, only : register_barotropic_restarts, set_dtbt, barotropic_CS use MOM_barotropic, only : barotropic_end @@ -43,31 +47,39 @@ module MOM_dynamics_split_RK2 use MOM_continuity, only : continuity, continuity_CS use MOM_continuity, only : continuity_init, continuity_stencil use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_CS -use MOM_CoriolisAdv, only : CoriolisAdv_init, CoriolisAdv_end +use MOM_CoriolisAdv, only : CoriolisAdv_init, CoriolisAdv_end, CoriolisAdv_stencil +use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS use MOM_debugging, only : check_redundant +use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS use MOM_grid, only : ocean_grid_type +use MOM_harmonic_analysis, only : HA_init, harmonic_analysis_CS use MOM_hor_index, only : hor_index_type -use MOM_hor_visc, only : horizontal_viscosity, hor_visc_CS +use MOM_hor_visc, only : horizontal_viscosity, hor_visc_CS, hor_visc_vel_stencil use MOM_hor_visc, only : hor_visc_init, hor_visc_end -use MOM_interface_heights, only : find_eta +use MOM_interface_heights, only : thickness_to_dz, find_col_avg_SpV use MOM_lateral_mixing_coeffs, only : VarMix_CS use MOM_MEKE_types, only : MEKE_type use MOM_open_boundary, only : ocean_OBC_type, radiation_open_bdry_conds -use MOM_open_boundary, only : open_boundary_zero_normal_flow +use MOM_open_boundary, only : open_boundary_zero_normal_flow, open_boundary_query use MOM_open_boundary, only : open_boundary_test_extern_h, update_OBC_ramp +use MOM_open_boundary, only : copy_thickness_reservoirs +use MOM_open_boundary, only : update_segment_thickness_reservoirs use MOM_PressureForce, only : PressureForce, PressureForce_CS use MOM_PressureForce, only : PressureForce_init use MOM_set_visc, only : set_viscous_ML, set_visc_CS +use MOM_stochastics, only : stochastic_CS use MOM_thickness_diffuse, only : thickness_diffuse_CS +use MOM_self_attr_load, only : SAL_CS +use MOM_self_attr_load, only : SAL_init, SAL_end use MOM_tidal_forcing, only : tidal_forcing_CS use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_end use MOM_unit_scaling, only : unit_scale_type use MOM_vert_friction, only : vertvisc, vertvisc_coef, vertvisc_remnant use MOM_vert_friction, only : vertvisc_init, vertvisc_end, vertvisc_CS -use MOM_vert_friction, only : updateCFLtruncationValue +use MOM_vert_friction, only : updateCFLtruncationValue, vertFPmix use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_verticalGrid, only : get_flux_units, get_tr_flux_units -use MOM_wave_interface, only: wave_parameters_CS +use MOM_wave_interface, only : wave_parameters_CS, Stokes_PGF implicit none ; private @@ -77,19 +89,23 @@ module MOM_dynamics_split_RK2 type, public :: MOM_dyn_split_RK2_CS ; private real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: & CAu, & !< CAu = f*v - u.grad(u) [L T-2 ~> m s-2] + CAu_pred, & !< The predictor step value of CAu = f*v - u.grad(u) [L T-2 ~> m s-2] PFu, & !< PFu = -dM/dx [L T-2 ~> m s-2] + PFu_Stokes, & !< PFu_Stokes = -d/dx int_r (u_L*duS/dr) [L T-2 ~> m s-2] diffu !< Zonal acceleration due to convergence of the along-isopycnal stress tensor [L T-2 ~> m s-2] real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: & CAv, & !< CAv = -f*u - u.grad(v) [L T-2 ~> m s-2] + CAv_pred, & !< The predictor step value of CAv = -f*u - u.grad(v) [L T-2 ~> m s-2] PFv, & !< PFv = -dM/dy [L T-2 ~> m s-2] + PFv_Stokes, & !< PFv_Stokes = -d/dy int_r (v_L*dvS/dr) [L T-2 ~> m s-2] diffv !< Meridional acceleration due to convergence of the along-isopycnal stress tensor [L T-2 ~> m s-2] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: visc_rem_u !< Both the fraction of the zonal momentum originally in a !! layer that remains after a time-step of viscosity, and the !! fraction of a time-step worth of a barotropic acceleration - !! that a layer experiences after viscosity is applied. + !! that a layer experiences after viscosity is applied [nondim]. !! Nondimensional between 0 (at the bottom) and 1 (far above). real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: u_accel_bt !< The zonal layer accelerations due to the difference between @@ -99,7 +115,7 @@ module MOM_dynamics_split_RK2 !< Both the fraction of the meridional momentum originally in !! a layer that remains after a time-step of viscosity, and the !! fraction of a time-step worth of a barotropic acceleration - !! that a layer experiences after viscosity is applied. + !! that a layer experiences after viscosity is applied [nondim]. !! Nondimensional between 0 (at the bottom) and 1 (far above). real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: v_accel_bt !< The meridional layer accelerations due to the difference between @@ -129,25 +145,41 @@ module MOM_dynamics_split_RK2 real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: pbce !< pbce times eta gives the baroclinic pressure !! anomaly in each layer due to free surface height !! anomalies [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + type(KPP_CS), pointer :: KPP_CSp => NULL() !< KPP control structure needed to ge + type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL() !< ePBL control structure - real, pointer, dimension(:,:) :: taux_bot => NULL() !< frictional x-bottom stress from the ocean - !! to the seafloor [R L Z T-2 ~> Pa] - real, pointer, dimension(:,:) :: tauy_bot => NULL() !< frictional y-bottom stress from the ocean - !! to the seafloor [R L Z T-2 ~> Pa] - type(BT_cont_type), pointer :: BT_cont => NULL() !< A structure with elements that describe the - !! effective summed open face areas as a function - !! of barotropic flow. + real, pointer, dimension(:,:) :: taux_bot => NULL() !< frictional x-bottom stress from the ocean + !! to the seafloor [R L Z T-2 ~> Pa] + real, pointer, dimension(:,:) :: tauy_bot => NULL() !< frictional y-bottom stress from the ocean + !! to the seafloor [R L Z T-2 ~> Pa] + type(BT_cont_type), pointer :: BT_cont => NULL() !< A structure with elements that describe the + !! effective summed open face areas as a function + !! of barotropic flow. ! This is to allow the previous, velocity-based coupling with between the ! baroclinic and barotropic modes. logical :: BT_use_layer_fluxes !< If true, use the summed layered fluxes plus !! an adjustment due to a changed barotropic !! velocity in the barotropic continuity equation. + logical :: BT_adj_corr_mass_src !< If true, recalculates the barotropic mass source after + !! predictor step. This should make little difference in the + !! deep ocean but appears to help for vanished layers. logical :: split_bottom_stress !< If true, provide the bottom stress !! calculated by the vertical viscosity to the !! barotropic solver. - logical :: calc_dtbt !< If true, calculate the barotropic time-step - !! dynamically. + logical :: dtbt_use_bt_cont !< If true, use BT_cont to calculate DTBT. + logical :: store_CAu !< If true, store the Coriolis and advective accelerations at the + !! end of the timestep for use in the next predictor step. + logical :: CAu_pred_stored !< If true, the Coriolis and advective accelerations at the + !! end of the timestep have been stored for use in the next + !! predictor step. This is used to accomodate various generations + !! of restart files. + logical :: calculate_SAL !< If true, calculate self-attraction and loading. + logical :: use_tides !< If true, tidal forcing is enabled. + logical :: use_HA !< If true, perform inline harmonic analysis. + logical :: remap_aux !< If true, apply ALE remapping to all of the auxiliary 3-D + !! variables that are needed to reproduce across restarts, + !! similarly to what is done with the primary state variables. real :: be !< A nondimensional number from 0.5 to 1 that controls !! the backward weighting of the time stepping scheme [nondim] @@ -155,10 +187,14 @@ module MOM_dynamics_split_RK2 !! the extent to which the treatment of gravity waves !! is forward-backward (0) or simulated backward !! Euler (1) [nondim]. 0 is often used. - logical :: debug !< If true, write verbose checksums for debugging purposes. - logical :: debug_OBC !< If true, do debugging calls for open boundary conditions. - + real :: Cemp_NL !< Empirical coefficient of non-local momentum mixing [nondim] + logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: debug_OBC !< If true, do additional calls resetting values to help debug the correctness + !! of the open boundary condition code. + logical :: fpmix !< If true, add non-local momentum flux increments and diffuse down the Eulerian gradient. logical :: module_is_initialized = .false. !< Record whether this module has been initialized. + logical :: visc_rem_dt_bug = .true. !< If true, recover a bug that uses dt_pred rather than dt for vertvisc_rem + !! at the end of predictor. !>@{ Diagnostic IDs integer :: id_uh = -1, id_vh = -1 @@ -177,6 +213,7 @@ module MOM_dynamics_split_RK2 integer :: id_hf_CAu_2d = -1, id_hf_CAv_2d = -1 integer :: id_intz_CAu_2d = -1, id_intz_CAv_2d = -1 integer :: id_CAu_visc_rem = -1, id_CAv_visc_rem = -1 + integer :: id_deta_dt = -1 ! Split scheme only. integer :: id_uav = -1, id_vav = -1 @@ -188,13 +225,16 @@ module MOM_dynamics_split_RK2 integer :: id_u_BT_accel_visc_rem = -1, id_v_BT_accel_visc_rem = -1 !>@} - type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the !! timing of diagnostic output. - type(accel_diag_ptrs), pointer :: ADp !< A structure pointing to the various + type(accel_diag_ptrs), pointer :: ADp => NULL() !< A structure pointing to the various !! accelerations in the momentum equations, !! which can later be used to calculate !! derived diagnostics like energy budgets. - type(cont_diag_ptrs), pointer :: CDp !< A structure with pointers to various + type(accel_diag_ptrs), pointer :: AD_pred => NULL() !< A structure pointing to the various + !! predictor step accelerations in the momentum equations, + !! which can be used to debug truncations. + type(cont_diag_ptrs), pointer :: CDp => NULL() !< A structure with pointers to various !! terms in the continuity equations, !! which can later be used to calculate !! derived diagnostics like energy budgets. @@ -214,8 +254,12 @@ module MOM_dynamics_split_RK2 type(set_visc_CS), pointer :: set_visc_CSp => NULL() !> A pointer to the barotropic stepping control structure type(barotropic_CS) :: barotropic_CSp + !> A pointer to the SAL control structure + type(SAL_CS) :: SAL_CSp !> A pointer to the tidal forcing control structure type(tidal_forcing_CS) :: tides_CSp + !> A pointer to the harmonic analysis control structure + type(harmonic_analysis_CS) :: HA_CSp !> A pointer to the ALE control structure. type(ALE_CS), pointer :: ALE_CSp => NULL() @@ -240,6 +284,8 @@ module MOM_dynamics_split_RK2 public step_MOM_dyn_split_RK2 public register_restarts_dyn_split_RK2 public initialize_dyn_split_RK2 +public remap_dyn_split_RK2_aux_vars +public init_dyn_split_RK2_diabatic public end_dyn_split_RK2 !>@{ CPU time clock IDs @@ -253,16 +299,16 @@ module MOM_dynamics_split_RK2 contains !> RK2 splitting for time stepping MOM adiabatic dynamics -subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_surf_begin, p_surf_end, & - uh, vh, uhtr, vhtr, eta_av, G, GV, US, CS, calc_dtbt, VarMix, & - MEKE, thickness_diffuse_CSp, pbv, Waves) +subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, forces, & + p_surf_begin, p_surf_end, uh, vh, uhtr, vhtr, eta_av, G, GV, US, CS, & + calc_dtbt, VarMix, MEKE, thickness_diffuse_CSp, pbv, STOCH, Waves) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - target, intent(inout) :: u !< Zonal velocity [L T-1 ~> m s-1] + target, intent(inout) :: u_inst !< Instantaneous zonal velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - target, intent(inout) :: v !< Meridional velocity [L T-1 ~> m s-1] + target, intent(inout) :: v_inst !< Instantaneous meridional velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic type @@ -294,35 +340,46 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s type(MEKE_type), intent(inout) :: MEKE !< MEKE fields type(thickness_diffuse_CS), intent(inout) :: thickness_diffuse_CSp !< Pointer to a structure containing !! interface height diffusivities - type(porous_barrier_ptrs), intent(in) :: pbv !< porous barrier fractional cell metrics + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + type(stochastic_CS), optional, intent(inout) :: STOCH !< Stochastic control structure type(wave_parameters_CS), optional, pointer :: Waves !< A pointer to a structure containing !! fields related to the surface wave conditions ! local variables real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: up ! Predicted zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vp ! Predicted meridional velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: hp ! Predicted thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: hp ! Predicted thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Distance between the interfaces around a layer [Z ~> m] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: ueffA ! Effective Area of U-Faces [H L ~> m2] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: veffA ! Effective Area of V-Faces [H L ~> m2] - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: u_bc_accel - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: v_bc_accel - ! u_bc_accel and v_bc_accel are the summed baroclinic accelerations of each - ! layer calculated by the non-barotropic part of the model [L T-2 ~> m s-2]. - - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), target :: uh_in - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), target :: vh_in - ! uh_in and vh_in are the zonal or meridional mass transports that would be - ! obtained using the initial velocities [H L2 T-1 ~> m3 s-1 or kg s-1]. - - real, dimension(SZI_(G),SZJ_(G)) :: eta_pred - ! eta_pred is the predictor value of the free surface height or column mass, - ! [H ~> m or kg m-2]. - - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: u_old_rad_OBC - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: v_old_rad_OBC - ! u_old_rad_OBC and v_old_rad_OBC are the starting velocities, which are - ! saved for use in the Flather open boundary condition code [L T-1 ~> m s-1]. - + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: u_bc_accel ! The summed zonal baroclinic accelerations + ! of each layer calculated by the non-barotropic + ! part of the model [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: v_bc_accel ! The summed meridional baroclinic accelerations + ! of each layer calculated by the non-barotropic + ! part of the model [L T-2 ~> m s-2] + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), target :: uh_in ! The zonal mass transports that would be + ! obtained using the initial velocities [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), target :: vh_in ! The meridional mass transports that would be + ! obtained using the initial velocities [H L2 T-1 ~> m3 s-1 or kg s-1] + + real, dimension(SZI_(G),SZJ_(G)) :: eta_pred ! The predictor value of the free surface height + ! or column mass [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)) :: SpV_avg ! The column averaged specific volume [R-1 ~> m3 kg-1] + real, dimension(SZI_(G),SZJ_(G)) :: deta_dt ! A diagnostic of the time derivative of the free surface + ! height or column mass [H T-1 ~> m s-1 or kg m-2 s-1] + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: u_old_rad_OBC ! The starting zonal velocities, which are + ! saved for use in the radiation open boundary condition code [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: v_old_rad_OBC ! The starting meridional velocities, which are + ! saved for use in the radiation open boundary condition code [L T-1 ~> m s-1] + + ! GMM, TODO: make these allocatable? + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uold ! u-velocity before vert_visc is applied, for fpmix + ! [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vold ! v-velocity before vert_visc is applied, for fpmix + ! [L T-1 ~> m s-1] real :: pres_to_eta ! A factor that converts pressures to the units of eta ! [H T2 R-1 L-2 ~> m Pa-1 or kg m-2 Pa-1] real, pointer, dimension(:,:) :: & @@ -346,22 +403,30 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s v_av, & ! The meridional velocity time-averaged over a time step [L T-1 ~> m s-1]. h_av ! The layer thickness time-averaged over a time step [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth from Cvmix [H ~> m or kg m-2] real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. - + real :: Idt_bc ! Inverse of the baroclinic timestep [T-1 ~> s-1] logical :: dyn_p_surf + logical :: debug_redundant ! If true, check redundant values on PE boundaries when debugging logical :: BT_cont_BT_thick ! If true, use the BT_cont_type to estimate the ! relative weightings of the layers in calculating ! the barotropic accelerations. + logical :: Use_Stokes_PGF ! If true, add Stokes PGF to hydrostatic PGF !---For group halo pass logical :: showCallTree, sym - + logical :: lFPpost ! Used to only post diagnostics in vertFPmix when fpmix=true and + ! in the corrector step (not the predict) integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - integer :: cont_stencil + integer :: cont_stencil, obc_stencil, vel_stencil + integer :: cor_stencil + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB u_av => CS%u_av ; v_av => CS%v_av ; h_av => CS%h_av ; eta => CS%eta - sym=.false.;if (G%Domain%symmetric) sym=.true. ! switch to include symmetric domain in checksums + Idt_bc = 1.0 / dt + + sym = G%Domain%symmetric ! switch to include symmetric domain in checksums showCallTree = callTree_showQuery() if (showCallTree) call callTree_enter("step_MOM_dyn_split_RK2(), MOM_dynamics_split_RK2.F90") @@ -377,9 +442,12 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s call updateCFLtruncationValue(Time_local, CS%vertvisc_CSp, US) if (CS%debug) then - call MOM_state_chksum("Start predictor ", u, v, h, uh, vh, G, GV, US, symmetric=sym) - call check_redundant("Start predictor u ", u, v, G) - call check_redundant("Start predictor uh ", uh, vh, G) + call query_debugging_checks(do_redundant=debug_redundant) + call MOM_state_chksum("Start predictor ", u_inst, v_inst, h, uh, vh, G, GV, US, symmetric=sym) + if (debug_redundant) then + call check_redundant("Start predictor u ", u_inst, v_inst, G, unscale=US%L_T_to_m_s) + call check_redundant("Start predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif endif dyn_p_surf = associated(p_surf_begin) .and. associated(p_surf_end) @@ -416,29 +484,35 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s !--- begin set up for group halo pass cont_stencil = continuity_stencil(CS%continuity_CSp) + obc_stencil = 2 + cor_stencil = CoriolisAdv_stencil(CS%CoriolisAdv) + if (associated(CS%OBC)) then + if (CS%OBC%oblique_BCs_exist_globally) obc_stencil = 3 + endif + vel_stencil = max(2, obc_stencil, hor_visc_vel_stencil(CS%hor_visc)) call cpu_clock_begin(id_clock_pass) call create_group_pass(CS%pass_eta, eta, G%Domain, halo=1) call create_group_pass(CS%pass_visc_rem, CS%visc_rem_u, CS%visc_rem_v, G%Domain, & To_All+SCALAR_PAIR, CGRID_NE, halo=max(1,cont_stencil)) call create_group_pass(CS%pass_uvp, up, vp, G%Domain, halo=max(1,cont_stencil)) - call create_group_pass(CS%pass_hp_uv, hp, G%Domain, halo=2) - call create_group_pass(CS%pass_hp_uv, u_av, v_av, G%Domain, halo=2) - call create_group_pass(CS%pass_hp_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=2) - - call create_group_pass(CS%pass_uv, u, v, G%Domain, halo=max(2,cont_stencil)) - call create_group_pass(CS%pass_h, h, G%Domain, halo=max(2,cont_stencil)) - call create_group_pass(CS%pass_av_uvh, u_av, v_av, G%Domain, halo=2) - call create_group_pass(CS%pass_av_uvh, uh(:,:,:), vh(:,:,:), G%Domain, halo=2) + call create_group_pass(CS%pass_uv, u_inst, v_inst, G%Domain, halo=max(2,cont_stencil)) + + call create_group_pass(CS%pass_hp_uv, hp, G%Domain, halo=cor_stencil) + call create_group_pass(CS%pass_hp_uv, u_av, v_av, G%Domain, halo=max(cor_stencil,vel_stencil)) + call create_group_pass(CS%pass_hp_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(cor_stencil,vel_stencil)) + call create_group_pass(CS%pass_h, h, g%domain, halo=max(cor_stencil,cont_stencil)) + call create_group_pass(CS%pass_av_uvh, u_av, v_av, g%domain, halo=max(cor_stencil,vel_stencil)) + call create_group_pass(CS%pass_av_uvh, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(cor_stencil,vel_stencil)) + call cpu_clock_end(id_clock_pass) !--- end set up for group halo pass - ! PFu = d/dx M(h,T,S) ! pbce = dM/deta if (CS%begw == 0.0) call enable_averages(dt, Time_local, CS%diag) call cpu_clock_begin(id_clock_pres) call PressureForce(h, tv, CS%PFu, CS%PFv, G, GV, US, CS%PressureForce_CSp, & - CS%ALE_CSp, p_surf, CS%pbce, CS%eta_PF) + CS%ALE_CSp, CS%ADp, p_surf, CS%pbce, CS%eta_PF) if (dyn_p_surf) then pres_to_eta = 1.0 / (GV%g_Earth * GV%H_to_RZ) !$OMP parallel do default(shared) @@ -446,6 +520,32 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s eta_PF_start(i,j) = CS%eta_PF(i,j) - pres_to_eta * (p_surf_begin(i,j) - p_surf_end(i,j)) enddo ; enddo endif + ! Stokes shear force contribution to pressure gradient + Use_Stokes_PGF = present(Waves) + if (Use_Stokes_PGF) then + Use_Stokes_PGF = associated(Waves) + if (Use_Stokes_PGF) Use_Stokes_PGF = Waves%Stokes_PGF + if (Use_Stokes_PGF) then + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call Stokes_PGF(G, GV, US, dz, u_inst, v_inst, CS%PFu_Stokes, CS%PFv_Stokes, Waves) + + ! We are adding Stokes_PGF to hydrostatic PGF here. The diag PFu/PFv + ! will therefore report the sum total PGF and we avoid other + ! modifications in the code. The PFu_Stokes is output within the waves routines. + if (.not.Waves%Passive_Stokes_PGF) then + do k=1,nz + do j=js,je ; do I=Isq,Ieq + CS%PFu(I,j,k) = CS%PFu(I,j,k) + CS%PFu_Stokes(I,j,k) + enddo ; enddo + enddo + do k=1,nz + do J=Jsq,Jeq ; do i=is,ie + CS%PFv(i,J,k) = CS%PFv(i,J,k) + CS%PFv_Stokes(i,J,k) + enddo ; enddo + enddo + endif + endif + endif call cpu_clock_end(id_clock_pres) call disable_averaging(CS%diag) if (showCallTree) call callTree_wayPoint("done with PressureForce (step_MOM_dyn_split_RK2)") @@ -460,21 +560,25 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s call start_group_pass(CS%pass_eta, G%Domain, clock=id_clock_pass) ! CAu = -(f+zeta_av)/h_av vh + d/dx KE_av - call cpu_clock_begin(id_clock_Cor) - call CorAdCalc(u_av, v_av, h_av, uh, vh, CS%CAu, CS%CAv, CS%OBC, CS%ADp, & - G, Gv, US, CS%CoriolisAdv, pbv) - call cpu_clock_end(id_clock_Cor) - if (showCallTree) call callTree_wayPoint("done with CorAdCalc (step_MOM_dyn_split_RK2)") + if (.not.CS%CAu_pred_stored) then + ! Calculate a predictor-step estimate of the Coriolis and momentum advection terms, + ! if it was not already stored from the end of the previous time step. + call cpu_clock_begin(id_clock_Cor) + call CorAdCalc(u_av, v_av, h_av, uh, vh, CS%CAu_pred, CS%CAv_pred, CS%OBC, CS%AD_pred, & + G, GV, US, CS%CoriolisAdv, pbv, Waves=Waves) + call cpu_clock_end(id_clock_Cor) + if (showCallTree) call callTree_wayPoint("done with CorAdCalc (step_MOM_dyn_split_RK2)") + endif ! u_bc_accel = CAu + PFu + diffu(u[n-1]) call cpu_clock_begin(id_clock_btforce) !$OMP parallel do default(shared) do k=1,nz do j=js,je ; do I=Isq,Ieq - u_bc_accel(I,j,k) = (CS%CAu(I,j,k) + CS%PFu(I,j,k)) + CS%diffu(I,j,k) + u_bc_accel(I,j,k) = (CS%CAu_pred(I,j,k) + CS%PFu(I,j,k)) + CS%diffu(I,j,k) enddo ; enddo do J=Jsq,Jeq ; do i=is,ie - v_bc_accel(i,J,k) = (CS%CAv(i,J,k) + CS%PFv(i,J,k)) + CS%diffv(i,J,k) + v_bc_accel(i,J,k) = (CS%CAv_pred(i,J,k) + CS%PFv(i,J,k)) + CS%diffv(i,J,k) enddo ; enddo enddo if (associated(CS%OBC)) then @@ -483,34 +587,37 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s call cpu_clock_end(id_clock_btforce) if (CS%debug) then - call MOM_accel_chksum("pre-btstep accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & + call MOM_accel_chksum("pre-btstep accel", CS%CAu_pred, CS%CAv_pred, CS%PFu, CS%PFv, & CS%diffu, CS%diffv, G, GV, US, CS%pbce, u_bc_accel, v_bc_accel, & symmetric=sym) - call check_redundant("pre-btstep CS%Ca ", CS%Cau, CS%Cav, G) - call check_redundant("pre-btstep CS%PF ", CS%PFu, CS%PFv, G) - call check_redundant("pre-btstep CS%diff ", CS%diffu, CS%diffv, G) - call check_redundant("pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G) + if (debug_redundant) then + call check_redundant("pre-btstep CS%CA ", CS%CAu_pred, CS%CAv_pred, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) + endif endif call cpu_clock_begin(id_clock_vertvisc) !$OMP parallel do default(shared) do k=1,nz do j=js,je ; do I=Isq,Ieq - up(I,j,k) = G%mask2dCu(I,j) * (u(I,j,k) + dt * u_bc_accel(I,j,k)) + up(I,j,k) = G%mask2dCu(I,j) * (u_inst(I,j,k) + dt * u_bc_accel(I,j,k)) enddo ; enddo do J=Jsq,Jeq ; do i=is,ie - vp(i,J,k) = G%mask2dCv(i,J) * (v(i,J,k) + dt * v_bc_accel(i,J,k)) + vp(i,J,k) = G%mask2dCv(i,J) * (v_inst(i,J,k) + dt * v_bc_accel(i,J,k)) enddo ; enddo enddo call enable_averages(dt, Time_local, CS%diag) - call set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS%set_visc_CSp) + call set_viscous_ML(u_inst, v_inst, h, tv, forces, visc, dt, G, GV, US, CS%set_visc_CSp) call disable_averaging(CS%diag) if (CS%debug) then - call uvchksum("before vertvisc: up", up, vp, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) + call uvchksum("before vertvisc: up", up, vp, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s) endif - call vertvisc_coef(up, vp, h, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC) + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(up, vp, h, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) call cpu_clock_end(id_clock_vertvisc) if (showCallTree) call callTree_wayPoint("done with vertvisc_coef (step_MOM_dyn_split_RK2)") @@ -531,15 +638,26 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (.not.BT_cont_BT_thick) & call btcalc(h, G, GV, CS%barotropic_CSp, OBC=CS%OBC) call bt_mass_source(h, eta, .true., G, GV, CS%barotropic_CSp) + + SpV_avg(:,:) = 0.0 + if ((.not.GV%Boussinesq) .and. associated(CS%OBC)) then + ! Determine the column average specific volume if it is needed due to the + ! use of Flather open boundary conditions in non-Boussinesq mode. + if (open_boundary_query(CS%OBC, apply_Flather_OBC=.true.)) & + call find_col_avg_SpV(h, SpV_avg, tv, G, GV, US) + endif call cpu_clock_end(id_clock_btcalc) if (G%nonblocking_updates) & call complete_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass) + if (associated(CS%OBC)) & + call copy_thickness_reservoirs(CS%OBC, G, GV) + ! u_accel_bt = layer accelerations due to barotropic solver if (associated(CS%BT_cont) .or. CS%BT_use_layer_fluxes) then call cpu_clock_begin(id_clock_continuity) - call continuity(u, v, h, hp, uh_in, vh_in, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & + call continuity(u_inst, v_inst, h, hp, uh_in, vh_in, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & visc_rem_u=CS%visc_rem_u, visc_rem_v=CS%visc_rem_v, BT_cont=CS%BT_cont) call cpu_clock_end(id_clock_continuity) if (BT_cont_BT_thick) then @@ -550,16 +668,25 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s endif if (CS%BT_use_layer_fluxes) then - uh_ptr => uh_in ; vh_ptr => vh_in; u_ptr => u ; v_ptr => v + uh_ptr => uh_in ; vh_ptr => vh_in ; u_ptr => u_inst ; v_ptr => v_inst endif call cpu_clock_begin(id_clock_btstep) - if (calc_dtbt) call set_dtbt(G, GV, US, CS%barotropic_CSp, eta, CS%pbce) + if (calc_dtbt) then + if (CS%dtbt_use_bt_cont .and. associated(CS%BT_cont)) then + call set_dtbt(G, GV, US, CS%barotropic_CSp, CS%pbce, BT_cont=CS%BT_cont) + else + ! In the following call, eta is only used when NONLINEAR_BT_CONTINUITY is True. Otherwise, dtbt is effectively + ! calculated with eta=0. Note that NONLINEAR_BT_CONTINUITY is False if BT_CONT is used, which is the default. + call set_dtbt(G, GV, US, CS%barotropic_CSp, CS%pbce, eta=eta) + endif + endif if (showCallTree) call callTree_enter("btstep(), MOM_barotropic.F90") ! This is the predictor step call to btstep. - call btstep(u, v, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, CS%eta_PF, u_av, v_av, & + ! The CS%ADp argument here stores the weights for certain integrated diagnostics. + call btstep(u_inst, v_inst, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, CS%eta_PF, u_av, v_av, & CS%u_accel_bt, CS%v_accel_bt, eta_pred, CS%uhbt, CS%vhbt, G, GV, US, & - CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, CS%ADp, CS%OBC, CS%BT_cont, & + CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, SpV_avg, CS%ADp, CS%OBC, CS%BT_cont, & eta_PF_start, taux_bot, tauy_bot, uh_ptr, vh_ptr, u_ptr, v_ptr) if (showCallTree) call callTree_leave("btstep()") call cpu_clock_end(id_clock_btstep) @@ -571,47 +698,88 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s !$OMP parallel do default(shared) do k=1,nz do J=Jsq,Jeq ; do i=is,ie - vp(i,J,k) = G%mask2dCv(i,J) * (v(i,J,k) + dt_pred * & + vp(i,J,k) = G%mask2dCv(i,J) * (v_inst(i,J,k) + dt_pred * & (v_bc_accel(i,J,k) + CS%v_accel_bt(i,J,k))) enddo ; enddo do j=js,je ; do I=Isq,Ieq - up(I,j,k) = G%mask2dCu(I,j) * (u(I,j,k) + dt_pred * & + up(I,j,k) = G%mask2dCu(I,j) * (u_inst(I,j,k) + dt_pred * & (u_bc_accel(I,j,k) + CS%u_accel_bt(I,j,k))) enddo ; enddo enddo call cpu_clock_end(id_clock_mom_update) if (CS%debug) then - call uvchksum("Predictor 1 [uv]", up, vp, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) - call hchksum(h, "Predictor 1 h", G%HI, haloshift=1, scale=GV%H_to_m) - call uvchksum("Predictor 1 [uv]h", uh, vh, G%HI,haloshift=2, & - symmetric=sym, scale=GV%H_to_m*US%L_to_m**2*US%s_to_T) -! call MOM_state_chksum("Predictor 1", up, vp, h, uh, vh, G, GV, US, haloshift=1) - call MOM_accel_chksum("Predictor accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & + call MOM_accel_chksum("Predictor accel", CS%CAu_pred, CS%CAv_pred, CS%PFu, CS%PFv, & CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, symmetric=sym) - call MOM_state_chksum("Predictor 1 init", u, v, h, uh, vh, G, GV, US, haloshift=2, & + call uvchksum("Predictor 1 [uv]", up, vp, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s) + call hchksum(h, "Predictor 1 h", G%HI, haloshift=1, unscale=GV%H_to_MKS) + call uvchksum("Predictor 1 [uv]h", uh, vh, G%HI,haloshift=2, & + symmetric=sym, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + ! call MOM_state_chksum("Predictor 1", up, vp, h, uh, vh, G, GV, US, haloshift=1) + call MOM_state_chksum("Predictor 1 init", u_inst, v_inst, h, uh, vh, G, GV, US, haloshift=1, & symmetric=sym) - call check_redundant("Predictor 1 up", up, vp, G) - call check_redundant("Predictor 1 uh", uh, vh, G) + if (debug_redundant) then + call check_redundant("Predictor 1 up", up, vp, G, unscale=US%L_T_to_m_s) + call check_redundant("Predictor 1 uh", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif endif ! up <- up + dt_pred d/dz visc d/dz up ! u_av <- u_av + dt_pred d/dz visc d/dz u_av call cpu_clock_begin(id_clock_vertvisc) if (CS%debug) then - call uvchksum("0 before vertvisc: [uv]p", up, vp, G%HI,haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) + call uvchksum("0 before vertvisc: [uv]p", up, vp, G%HI,haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s) + endif + + if (CS%fpmix) then + uold(:,:,:) = 0.0 + vold(:,:,:) = 0.0 + do k = 1, nz + do j = js , je + do I = Isq, Ieq + uold(I,j,k) = up(I,j,k) + enddo + enddo + do J = Jsq, Jeq + do i = is, ie + vold(i,J,k) = vp(i,J,k) + enddo + enddo + enddo endif - call vertvisc_coef(up, vp, h, forces, visc, dt_pred, G, GV, US, CS%vertvisc_CSp, & - CS%OBC) - call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%ADp, CS%CDp, G, & - GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) + + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(up, vp, h, dz, forces, visc, tv, dt_pred, G, GV, US, CS%vertvisc_CSp, & + CS%OBC, VarMix) + + if (CS%fpmix) then + hbl(:,:) = 0.0 + if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G, US, m_to_BLD_units=GV%m_to_H) + if (ASSOCIATED(CS%energetic_PBL_CSp)) & + call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US, m_to_MLD_units=GV%m_to_H) + + ! lFPpost must be false in the predictor step to avoid averaging into the diagnostics + lFPpost = .false. + call vertFPmix(up, vp, uold, vold, hbl, h, forces, dt_pred, lFPpost, CS%Cemp_NL, & + G, GV, US, CS%vertvisc_CSp, CS%OBC, waves=waves) + call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%AD_pred, CS%CDp, G, & + GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, fpmix=CS%fpmix, waves=waves) + else + call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%AD_pred, CS%CDp, G, & + GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) + endif + if (showCallTree) call callTree_wayPoint("done with vertvisc (step_MOM_dyn_split_RK2)") if (G%nonblocking_updates) then call cpu_clock_end(id_clock_vertvisc) call start_group_pass(CS%pass_uvp, G%Domain, clock=id_clock_pass) call cpu_clock_begin(id_clock_vertvisc) endif - call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt_pred, G, GV, US, CS%vertvisc_CSp) + if (CS%visc_rem_dt_bug) then + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt_pred, G, GV, US, CS%vertvisc_CSp) + else + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) + endif call cpu_clock_end(id_clock_vertvisc) call do_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass) @@ -625,8 +793,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! hp = h + dt * div . uh call cpu_clock_begin(id_clock_continuity) call continuity(up, vp, h, hp, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & - CS%uhbt, CS%vhbt, CS%visc_rem_u, CS%visc_rem_v, & - u_av, v_av, BT_cont=CS%BT_cont) + uhbt=CS%uhbt, vhbt=CS%vhbt, visc_rem_u=CS%visc_rem_u, visc_rem_v=CS%visc_rem_v, & + u_cor=u_av, v_cor=v_av, BT_cont=CS%BT_cont) call cpu_clock_end(id_clock_continuity) if (showCallTree) call callTree_wayPoint("done with continuity (step_MOM_dyn_split_RK2)") @@ -635,24 +803,21 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (associated(CS%OBC)) then if (CS%debug) & - call uvchksum("Pre OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) + call uvchksum("Pre OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s) call radiation_open_bdry_conds(CS%OBC, u_av, u_old_rad_OBC, v_av, v_old_rad_OBC, G, GV, US, dt_pred) if (CS%debug) & - call uvchksum("Post OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) + call uvchksum("Post OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s) ! These should be done with a pass that excludes uh & vh. ! call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass) - endif - - if (G%nonblocking_updates) then - call start_group_pass(CS%pass_av_uvh, G%Domain, clock=id_clock_pass) + call pass_vector(u_av, v_av, G%Domain, halo=max(cor_stencil,vel_stencil), clock=id_clock_pass) endif ! h_av = (h + hp)/2 !$OMP parallel do default(shared) - do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + do k=1,nz ; do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil h_av(i,j,k) = 0.5*(h(i,j,k) + hp(i,j,k)) enddo ; enddo ; enddo @@ -663,9 +828,11 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! used in the next call to btstep. This call is at this point so that ! hp can be changed if CS%begw /= 0. ! eta_cor = ... (hidden inside CS%barotropic_CSp) - call cpu_clock_begin(id_clock_btcalc) - call bt_mass_source(hp, eta_pred, .false., G, GV, CS%barotropic_CSp) - call cpu_clock_end(id_clock_btcalc) + if (CS%BT_adj_corr_mass_src) then + call cpu_clock_begin(id_clock_btcalc) + call bt_mass_source(hp, eta_pred, .false., G, GV, CS%barotropic_CSp) + call cpu_clock_end(id_clock_btcalc) + endif if (CS%begw /= 0.0) then ! hp <- (1-begw)*h_in + begw*hp @@ -680,14 +847,33 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! pbce = dM/deta call cpu_clock_begin(id_clock_pres) call PressureForce(hp, tv, CS%PFu, CS%PFv, G, GV, US, CS%PressureForce_CSp, & - CS%ALE_CSp, p_surf, CS%pbce, CS%eta_PF) + CS%ALE_CSp, CS%ADp, p_surf, CS%pbce, CS%eta_PF) + ! Stokes shear force contribution to pressure gradient + Use_Stokes_PGF = present(Waves) + if (Use_Stokes_PGF) then + Use_Stokes_PGF = associated(Waves) + if (Use_Stokes_PGF) Use_Stokes_PGF = Waves%Stokes_PGF + if (Use_Stokes_PGF) then + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call Stokes_PGF(G, GV, US, dz, u_inst, v_inst, CS%PFu_Stokes, CS%PFv_Stokes, Waves) + if (.not.Waves%Passive_Stokes_PGF) then + do k=1,nz + do j=js,je ; do I=Isq,Ieq + CS%PFu(I,j,k) = CS%PFu(I,j,k) + CS%PFu_Stokes(I,j,k) + enddo ; enddo + enddo + do k=1,nz + do J=Jsq,Jeq ; do i=is,ie + CS%PFv(i,J,k) = CS%PFv(i,J,k) + CS%PFv_Stokes(i,J,k) + enddo ; enddo + enddo + endif + endif + endif call cpu_clock_end(id_clock_pres) if (showCallTree) call callTree_wayPoint("done with PressureForce[hp=(1-b).h+b.h] (step_MOM_dyn_split_RK2)") endif - if (G%nonblocking_updates) & - call complete_group_pass(CS%pass_av_uvh, G%Domain, clock=id_clock_pass) - if (BT_cont_BT_thick) then call btcalc(h, G, GV, CS%barotropic_CSp, CS%BT_cont%h_u, CS%BT_cont%h_v, & OBC=CS%OBC) @@ -696,26 +882,28 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%debug) then call MOM_state_chksum("Predictor ", up, vp, hp, uh, vh, G, GV, US, symmetric=sym) - call uvchksum("Predictor avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) - call hchksum(h_av, "Predictor avg h", G%HI, haloshift=0, scale=GV%H_to_m) + call uvchksum("Predictor avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s) + call hchksum(h_av, "Predictor avg h", G%HI, haloshift=2, unscale=GV%H_to_MKS) ! call MOM_state_chksum("Predictor avg ", u_av, v_av, h_av, uh, vh, G, GV, US) - call check_redundant("Predictor up ", up, vp, G) - call check_redundant("Predictor uh ", uh, vh, G) + if (debug_redundant) then + call check_redundant("Predictor up ", up, vp, G, unscale=US%L_T_to_m_s) + call check_redundant("Predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif endif ! diffu = horizontal viscosity terms (u_av) call cpu_clock_begin(id_clock_horvisc) - call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, & - MEKE, Varmix, G, GV, US, CS%hor_visc, & + call horizontal_viscosity(u_av, v_av, h_av, uh, vh, CS%diffu, CS%diffv, & + MEKE, Varmix, G, GV, US, CS%hor_visc, tv, dt, & OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, & - ADp=CS%ADp) + ADp=CS%ADp, hu_cont=CS%BT_cont%h_u, hv_cont=CS%BT_cont%h_v, STOCH=STOCH) call cpu_clock_end(id_clock_horvisc) if (showCallTree) call callTree_wayPoint("done with horizontal_viscosity (step_MOM_dyn_split_RK2)") ! CAu = -(f+zeta_av)/h_av vh + d/dx KE_av call cpu_clock_begin(id_clock_Cor) call CorAdCalc(u_av, v_av, h_av, uh, vh, CS%CAu, CS%CAv, CS%OBC, CS%ADp, & - G, GV, US, CS%CoriolisAdv, pbv) + G, GV, US, CS%CoriolisAdv, pbv, Waves=Waves) call cpu_clock_end(id_clock_Cor) if (showCallTree) call callTree_wayPoint("done with CorAdCalc (step_MOM_dyn_split_RK2)") @@ -741,10 +929,12 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s call MOM_accel_chksum("corr pre-btstep accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & CS%diffu, CS%diffv, G, GV, US, CS%pbce, u_bc_accel, v_bc_accel, & symmetric=sym) - call check_redundant("corr pre-btstep CS%Ca ", CS%Cau, CS%Cav, G) - call check_redundant("corr pre-btstep CS%PF ", CS%PFu, CS%PFv, G) - call check_redundant("corr pre-btstep CS%diff ", CS%diffu, CS%diffv, G) - call check_redundant("corr pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G) + if (debug_redundant) then + call check_redundant("corr pre-btstep CS%CA ", CS%CAu, CS%CAv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) + endif endif ! u_accel_bt = layer accelerations due to barotropic solver @@ -756,17 +946,20 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (showCallTree) call callTree_enter("btstep(), MOM_barotropic.F90") ! This is the corrector step call to btstep. - call btstep(u, v, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, CS%eta_PF, u_av, v_av, & + call btstep(u_inst, v_inst, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, CS%eta_PF, u_av, v_av, & CS%u_accel_bt, CS%v_accel_bt, eta_pred, CS%uhbt, CS%vhbt, G, GV, US, & - CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, CS%ADp, CS%OBC, CS%BT_cont, & + CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, SpV_avg, CS%ADp, CS%OBC, CS%BT_cont, & eta_PF_start, taux_bot, tauy_bot, uh_ptr, vh_ptr, u_ptr, v_ptr, etaav=eta_av) + if (CS%id_deta_dt>0) then + do j=js,je ; do i=is,ie ; deta_dt(i,j) = (eta_pred(i,j) - eta(i,j))*Idt_bc ; enddo ; enddo + endif do j=js,je ; do i=is,ie ; eta(i,j) = eta_pred(i,j) ; enddo ; enddo call cpu_clock_end(id_clock_btstep) if (showCallTree) call callTree_leave("btstep()") - if (CS%debug) then - call check_redundant("u_accel_bt ", CS%u_accel_bt, CS%v_accel_bt, G) + if (CS%debug .and. debug_redundant) then + call check_redundant("u_accel_bt ", CS%u_accel_bt, CS%v_accel_bt, G, unscale=US%L_T2_to_m_s2) endif ! u = u + dt*( u_bc_accel + u_accel_bt ) @@ -774,33 +967,64 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s !$OMP parallel do default(shared) do k=1,nz do j=js,je ; do I=Isq,Ieq - u(I,j,k) = G%mask2dCu(I,j) * (u(I,j,k) + dt * & + u_inst(I,j,k) = G%mask2dCu(I,j) * (u_inst(I,j,k) + dt * & (u_bc_accel(I,j,k) + CS%u_accel_bt(I,j,k))) enddo ; enddo do J=Jsq,Jeq ; do i=is,ie - v(i,J,k) = G%mask2dCv(i,J) * (v(i,J,k) + dt * & + v_inst(i,J,k) = G%mask2dCv(i,J) * (v_inst(i,J,k) + dt * & (v_bc_accel(i,J,k) + CS%v_accel_bt(i,J,k))) enddo ; enddo enddo call cpu_clock_end(id_clock_mom_update) if (CS%debug) then - call uvchksum("Corrector 1 [uv]", u, v, G%HI,haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) - call hchksum(h, "Corrector 1 h", G%HI, haloshift=2, scale=GV%H_to_m) - call uvchksum("Corrector 1 [uv]h", uh, vh, G%HI, haloshift=2, & - symmetric=sym, scale=GV%H_to_m*US%L_to_m**2*US%s_to_T) - ! call MOM_state_chksum("Corrector 1", u, v, h, uh, vh, G, GV, US, haloshift=1) call MOM_accel_chksum("Corrector accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, & symmetric=sym) + call uvchksum("Corrector 1 [uv]", u_inst, v_inst, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s) + call hchksum(h, "Corrector 1 h", G%HI, haloshift=1, unscale=GV%H_to_MKS) + call uvchksum("Corrector 1 [uv]h", uh, vh, G%HI, haloshift=2, & + symmetric=sym, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + ! call MOM_state_chksum("Corrector 1", u_inst, v_inst, h, uh, vh, G, GV, US, haloshift=1) + endif ! u <- u + dt d/dz visc d/dz u ! u_av <- u_av + dt d/dz visc d/dz u_av call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC) - call vertvisc(u, v, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & - CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot,waves=waves) + + if (CS%fpmix) then + uold(:,:,:) = 0.0 + vold(:,:,:) = 0.0 + do k = 1, nz + do j = js , je + do I = Isq, Ieq + uold(I,j,k) = u_inst(I,j,k) + enddo + enddo + do J = Jsq, Jeq + do i = is, ie + vold(i,J,k) = v_inst(i,J,k) + enddo + enddo + enddo + endif + + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(u_inst, v_inst, h, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + + if (CS%fpmix) then + lFPpost = .true. + call vertFPmix(u_inst, v_inst, uold, vold, hbl, h, forces, dt, lFPpost, CS%Cemp_NL, & + G, GV, US, CS%vertvisc_CSp, CS%OBC, Waves=Waves) + call vertvisc(u_inst, v_inst, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & + CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, fpmix=CS%fpmix, waves=waves) + + else + call vertvisc(u_inst, v_inst, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & + CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) + endif + if (G%nonblocking_updates) then call cpu_clock_end(id_clock_vertvisc) call start_group_pass(CS%pass_uv, G%Domain, clock=id_clock_pass) @@ -812,7 +1036,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! Later, h_av = (h_in + h_out)/2, but for now use h_av to store h_in. !$OMP parallel do default(shared) - do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + do k=1,nz ; do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil h_av(i,j,k) = h(i,j,k) enddo ; enddo ; enddo @@ -827,8 +1051,9 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! h = h + dt * div . uh ! u_av and v_av adjusted so their mass transports match uhbt and vhbt. call cpu_clock_begin(id_clock_continuity) - call continuity(u, v, h, h, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & - CS%uhbt, CS%vhbt, CS%visc_rem_u, CS%visc_rem_v, u_av, v_av) + call continuity(u_inst, v_inst, h, h, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & + uhbt=CS%uhbt, vhbt=CS%vhbt, visc_rem_u=CS%visc_rem_u, visc_rem_v=CS%visc_rem_v, & + u_cor=u_av, v_cor=v_av) call cpu_clock_end(id_clock_continuity) call do_group_pass(CS%pass_h, G%Domain, clock=id_clock_pass) ! Whenever thickness changes let the diag manager know, target grids @@ -843,12 +1068,14 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s endif if (associated(CS%OBC)) then - call radiation_open_bdry_conds(CS%OBC, u, u_old_rad_OBC, v, v_old_rad_OBC, G, GV, US, dt) + !### I suspect that there is a bug here when u_inst is compared with a previous value of u_av + ! to estimate the dominant outward group velocity, but a fix is not available yet. + call radiation_open_bdry_conds(CS%OBC, u_inst, u_old_rad_OBC, v_inst, v_old_rad_OBC, G, GV, US, dt) endif ! h_av = (h_in + h_out)/2 . Going in to this line, h_av = h_in. !$OMP parallel do default(shared) - do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + do k=1,nz ; do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil h_av(i,j,k) = 0.5*(h_av(i,j,k) + h(i,j,k)) enddo ; enddo ; enddo @@ -865,6 +1092,26 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s enddo ; enddo enddo + if (associated(CS%OBC)) then + call update_segment_thickness_reservoirs(G, GV, uhtr, vhtr, h, CS%OBC) + endif + + if (CS%store_CAu) then + ! Calculate a predictor-step estimate of the Coriolis and momentum advection terms + ! for use in the next time step, possibly after it has been vertically remapped. + call cpu_clock_begin(id_clock_Cor) + call disable_averaging(CS%diag) ! These calculations should not be used for diagnostics. + ! CAu = -(f+zeta_av)/h_av vh + d/dx KE_av + call CorAdCalc(u_av, v_av, h_av, uh, vh, CS%CAu_pred, CS%CAv_pred, CS%OBC, CS%AD_pred, & + G, GV, US, CS%CoriolisAdv, pbv, Waves=Waves) + CS%CAu_pred_stored = .true. + call enable_averages(dt, Time_local, CS%diag) ! Reenable the averaging + call cpu_clock_end(id_clock_Cor) + if (showCallTree) call callTree_wayPoint("done with CorAdCalc (step_MOM_dyn_split_RK2)") + else + CS%CAu_pred_stored = .false. + endif + ! The time-averaged free surface height has already been set by the last call to btstep. ! Deallocate this memory to avoid a memory leak. ### We should revisit how this array is declared. -RWH @@ -878,8 +1125,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%id_CAv > 0) call post_data(CS%id_CAv, CS%CAv, CS%diag) ! Here the thickness fluxes are offered for time averaging. - if (CS%id_uh > 0) call post_data(CS%id_uh , uh, CS%diag) - if (CS%id_vh > 0) call post_data(CS%id_vh , vh, CS%diag) + if (CS%id_uh > 0) call post_data(CS%id_uh, uh, CS%diag) + if (CS%id_vh > 0) call post_data(CS%id_vh, vh, CS%diag) if (CS%id_uav > 0) call post_data(CS%id_uav, u_av, CS%diag) if (CS%id_vav > 0) call post_data(CS%id_vav, v_av, CS%diag) if (CS%id_u_BT_accel > 0) call post_data(CS%id_u_BT_accel, CS%u_accel_bt, CS%diag) @@ -958,10 +1205,13 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%id_v_BT_accel_visc_rem > 0) & call post_product_v(CS%id_v_BT_accel_visc_rem, CS%v_accel_bt, CS%ADp%visc_rem_v, G, nz, CS%diag) + ! Diagnostics related to changes in eta + if (CS%id_deta_dt > 0) call post_data(CS%id_deta_dt, deta_dt, CS%diag) + if (CS%debug) then - call MOM_state_chksum("Corrector ", u, v, h, uh, vh, G, GV, US, symmetric=sym) - call uvchksum("Corrector avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) - call hchksum(h_av, "Corrector avg h", G%HI, haloshift=1, scale=GV%H_to_m) + call MOM_state_chksum("Corrector ", u_inst, v_inst, h, uh, vh, G, GV, US, symmetric=sym) + call uvchksum("Corrector avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s) + call hchksum(h_av, "Corrector avg h", G%HI, haloshift=1, unscale=GV%H_to_MKS) ! call MOM_state_chksum("Corrector avg ", u_av, v_av, h_av, uh, vh, G, GV, US) endif @@ -972,9 +1222,10 @@ end subroutine step_MOM_dyn_split_RK2 !> This subroutine sets up any auxiliary restart variables that are specific !! to the split-explicit time stepping scheme. All variables registered here should !! have the ability to be recreated if they are not present in a restart file. -subroutine register_restarts_dyn_split_RK2(HI, GV, param_file, CS, restart_CS, uh, vh) +subroutine register_restarts_dyn_split_RK2(HI, GV, US, param_file, CS, restart_CS, uh, vh) type(hor_index_type), intent(in) :: HI !< Horizontal index structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< parameter file type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure @@ -983,9 +1234,9 @@ subroutine register_restarts_dyn_split_RK2(HI, GV, param_file, CS, restart_CS, u real, dimension(SZI_(HI),SZJB_(HI),SZK_(GV)), & target, intent(inout) :: vh !< merid volume or mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] - type(vardesc) :: vd(2) - character(len=40) :: mdl = "MOM_dynamics_split_RK2" ! This module's name. - character(len=48) :: thickness_units, flux_units + character(len=40) :: mdl = "MOM_dynamics_split_RK2" ! This module's name. + type(vardesc) :: vd(2) + character(len=48) :: thickness_units, flux_units integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB @@ -1004,6 +1255,8 @@ subroutine register_restarts_dyn_split_RK2(HI, GV, param_file, CS, restart_CS, u ALLOC_(CS%diffv(isd:ied,JsdB:JedB,nz)) ; CS%diffv(:,:,:) = 0.0 ALLOC_(CS%CAu(IsdB:IedB,jsd:jed,nz)) ; CS%CAu(:,:,:) = 0.0 ALLOC_(CS%CAv(isd:ied,JsdB:JedB,nz)) ; CS%CAv(:,:,:) = 0.0 + ALLOC_(CS%CAu_pred(IsdB:IedB,jsd:jed,nz)) ; CS%CAu_pred(:,:,:) = 0.0 + ALLOC_(CS%CAv_pred(isd:ied,JsdB:JedB,nz)) ; CS%CAv_pred(:,:,:) = 0.0 ALLOC_(CS%PFu(IsdB:IedB,jsd:jed,nz)) ; CS%PFu(:,:,:) = 0.0 ALLOC_(CS%PFv(isd:ied,JsdB:JedB,nz)) ; CS%PFv(:,:,:) = 0.0 @@ -1015,40 +1268,102 @@ subroutine register_restarts_dyn_split_RK2(HI, GV, param_file, CS, restart_CS, u thickness_units = get_thickness_units(GV) flux_units = get_flux_units(GV) + call get_param(param_file, mdl, "STORE_CORIOLIS_ACCEL", CS%store_CAu, & + "If true, calculate the Coriolis accelerations at the end of each "//& + "timestep for use in the predictor step of the next split RK2 timestep.", & + default=.true., do_not_log=.true.) + if (GV%Boussinesq) then - vd(1) = var_desc("sfc",thickness_units,"Free surface Height",'h','1') + call register_restart_field(CS%eta, "sfc", .false., restart_CS, & + longname="Free surface Height", units=thickness_units, conversion=GV%H_to_mks) else - vd(1) = var_desc("p_bot",thickness_units,"Bottom Pressure",'h','1') + call register_restart_field(CS%eta, "p_bot", .false., restart_CS, & + longname="Bottom Pressure", units=thickness_units, conversion=GV%H_to_mks) endif - call register_restart_field(CS%eta, vd(1), .false., restart_CS) - - vd(1) = var_desc("u2","m s-1","Auxiliary Zonal velocity",'u','L') - vd(2) = var_desc("v2","m s-1","Auxiliary Meridional velocity",'v','L') - call register_restart_pair(CS%u_av, CS%v_av, vd(1), vd(2), .false., restart_CS) - vd(1) = var_desc("h2",thickness_units,"Auxiliary Layer Thickness",'h','L') - call register_restart_field(CS%h_av, vd(1), .false., restart_CS) + ! These are needed, either to calculate CAu and CAv or to calculate the velocity anomalies in + ! the barotropic solver's Coriolis terms. + vd(1) = var_desc("u2", "m s-1", "Auxiliary Zonal velocity", 'u', 'L') + vd(2) = var_desc("v2", "m s-1", "Auxiliary Meridional velocity", 'v', 'L') + call register_restart_pair(CS%u_av, CS%v_av, vd(1), vd(2), .false., restart_CS, & + conversion=US%L_T_to_m_s) + + if (CS%store_CAu) then + vd(1) = var_desc("CAu", "m s-2", "Zonal Coriolis and advactive acceleration", 'u', 'L') + vd(2) = var_desc("CAv", "m s-2", "Meridional Coriolis and advactive acceleration", 'v', 'L') + call register_restart_pair(CS%CAu_pred, CS%CAv_pred, vd(1), vd(2), .false., restart_CS, & + conversion=US%L_T2_to_m_s2) + else + call register_restart_field(CS%h_av, "h2", .false., restart_CS, & + longname="Auxiliary Layer Thickness", units=thickness_units, conversion=GV%H_to_mks) - vd(1) = var_desc("uh",flux_units,"Zonal thickness flux",'u','L') - vd(2) = var_desc("vh",flux_units,"Meridional thickness flux",'v','L') - call register_restart_pair(uh, vh, vd(1), vd(2), .false., restart_CS) + vd(1) = var_desc("uh", flux_units, "Zonal thickness flux", 'u', 'L') + vd(2) = var_desc("vh", flux_units, "Meridional thickness flux", 'v', 'L') + call register_restart_pair(uh, vh, vd(1), vd(2), .false., restart_CS, & + conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif - vd(1) = var_desc("diffu","m s-2","Zonal horizontal viscous acceleration",'u','L') - vd(2) = var_desc("diffv","m s-2","Meridional horizontal viscous acceleration",'v','L') - call register_restart_pair(CS%diffu, CS%diffv, vd(1), vd(2), .false., restart_CS) + vd(1) = var_desc("diffu", "m s-2", "Zonal horizontal viscous acceleration", 'u', 'L') + vd(2) = var_desc("diffv", "m s-2", "Meridional horizontal viscous acceleration", 'v', 'L') + call register_restart_pair(CS%diffu, CS%diffv, vd(1), vd(2), .false., restart_CS, & + conversion=US%L_T2_to_m_s2) - call register_barotropic_restarts(HI, GV, param_file, CS%barotropic_CSp, & - restart_CS) + call register_barotropic_restarts(HI, GV, US, param_file, CS%barotropic_CSp, restart_CS) end subroutine register_restarts_dyn_split_RK2 +!> This subroutine does remapping for the auxiliary restart variables that are used +!! with the split RK2 time stepping scheme. +subroutine remap_dyn_split_RK2_aux_vars(G, GV, CS, h_old_u, h_old_v, h_new_u, h_new_v, ALE_CSp) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old_u !< Source grid thickness at zonal + !! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: h_old_v !< Source grid thickness at meridional + !! velocity points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new_u !< Destination grid thickness at zonal + !! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: h_new_v !< Destination grid thickness at meridional + !! velocity points [H ~> m or kg m-2] + type(ALE_CS), pointer :: ALE_CSp !< ALE control structure to use when remapping + + if (.not.CS%remap_aux) return + + if (CS%store_CAu) then + call ALE_remap_velocities(ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, CS%u_av, CS%v_av) + call pass_vector(CS%u_av, CS%v_av, G%Domain, complete=.false.) + call ALE_remap_velocities(ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, CS%CAu_pred, CS%CAv_pred) + call pass_vector(CS%CAu_pred, CS%CAv_pred, G%Domain, complete=.false.) + endif + + call ALE_remap_velocities(ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, CS%diffu, CS%diffv) + call pass_vector(CS%diffu, CS%diffv, G%Domain, complete=.true.) + +end subroutine remap_dyn_split_RK2_aux_vars + +!> Initializes aspects of the dyn_split_RK2 that depend on diabatic processes. +!! Needed when BLDs are used in the dynamics. +subroutine init_dyn_split_RK2_diabatic(diabatic_CSp, CS) + type(diabatic_CS), intent(in) :: diabatic_CSp !< diabatic structure + type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure + + call extract_diabatic_member(diabatic_CSp, KPP_CSp=CS%KPP_CSp) + call extract_diabatic_member(diabatic_CSp, energetic_PBL_CSp=CS%energetic_PBL_CSp) + +end subroutine init_dyn_split_RK2_diabatic + !> This subroutine initializes all of the variables that are used by this !! dynamic core, including diagnostics and the cpu clocks. -subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param_file, & - diag, CS, restart_CS, dt, Accel_diag, Cont_diag, MIS, & +subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, param_file, & + diag, CS, HA_CSp, restart_CS, dt, Accel_diag, Cont_diag, MIS, & VarMix, MEKE, thickness_diffuse_CSp, & OBC, update_OBC_CSp, ALE_CSp, set_visc, & - visc, dirs, ntrunc, pbv, calc_dtbt, cont_stencil) + visc, dirs, ntrunc, pbv, calc_dtbt, cont_stencil, dyn_h_stencil) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -1056,8 +1371,9 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(inout) :: v !< merid velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) , & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic type real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & target, intent(inout) :: uh !< zonal volume/mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & @@ -1067,7 +1383,9 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param type(param_file_type), intent(in) :: param_file !< parameter file for parsing type(diag_ctrl), target, intent(inout) :: diag !< to control diagnostics type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure - type(MOM_restart_CS), intent(in) :: restart_CS !< MOM restart control structure + type(harmonic_analysis_CS), pointer :: HA_CSp !< A pointer to the control structure of the + !! harmonic analysis module + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure real, intent(in) :: dt !< time step [T ~> s] type(accel_diag_ptrs), target, intent(inout) :: Accel_diag !< points to momentum equation terms for !! budget analysis @@ -1088,9 +1406,12 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param !! the number of times the velocity is !! truncated (this should be 0). logical, intent(out) :: calc_dtbt !< If true, recalculate the barotropic time step - type(porous_barrier_ptrs), intent(in) :: pbv !< porous barrier fractional cell metrics + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics integer, intent(out) :: cont_stencil !< The stencil for thickness !! from the continuity solver. + integer, intent(out) :: dyn_h_stencil !< The stencil for thickness for the + !! the dynamics based on the continuity + !! solver and Coriolis scheme. ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_tmp ! A temporary copy of the layer thicknesses [H ~> m or kg m-2] @@ -1098,19 +1419,17 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param ! This include declares and sets the variable "version". # include "version_variable.h" character(len=48) :: thickness_units, flux_units, eta_rest_name - real :: H_rescale ! A rescaling factor for thicknesses from the representation in a - ! restart file to the internal representation in this run [various units ~> 1] - real :: vel_rescale ! A rescaling factor for velocities from the representation in a - ! restart file to the internal representation in this run [various units ~> 1] - real :: uH_rescale ! A rescaling factor for thickness transports from the representation in a - ! restart file to the internal representation in this run [various units ~> 1] - real :: accel_rescale ! A rescaling factor for accelerations from the representation in a - ! restart file to the internal representation in this run [various units ~> 1] type(group_pass_type) :: pass_av_h_uvh - logical :: use_tides, debug_truncations + logical :: debug_truncations + logical :: read_uv, read_h2 + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. + logical :: visc_rem_bug ! Stores the value of runtime paramter VISC_REM_BUG. + integer :: cor_stencil integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB + integer :: nc ! Number of tidal constituents to be harmonically analyzed 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 IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -1127,11 +1446,19 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param CS%diag => diag call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "TIDES", use_tides, & + call get_param(param_file, mdl, "TIDES", CS%use_tides, & "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=CS%use_tides) + call get_param(param_file, mdl, "USE_HA", CS%use_HA, & + "If true, perform inline harmonic analysis.", default=.false.) + call get_param(param_file, mdl, "HA_N_CONST", nc, & + "Number of tidal constituents to be harmonically analyzed.", & + default=0, do_not_log=.not.CS%use_HA) + if (nc<=0) CS%use_HA = .false. call get_param(param_file, mdl, "BE", CS%be, & "If SPLIT is true, BE determines the relative weighting "//& - "of a 2nd-order Runga-Kutta baroclinic time stepping "//& + "of a 2nd-order Runga-Kutta baroclinic time stepping "//& "scheme (0.5) and a backward Euler scheme (1) that is "//& "used for the Coriolis and inertial terms. BE may be "//& "from 0.5 to 1, but instability may occur near 0.5. "//& @@ -1145,7 +1472,8 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param "If SPLIT is false and USE_RK2 is true, BEGW can be "//& "between 0 and 0.5 to damp gravity waves.", & units="nondim", default=0.0) - + call get_param(param_file, mdl, "SET_DTBT_USE_BT_CONT", CS%dtbt_use_bt_cont, & + "If true, use BT_CONT to calculate DTBT if possible.", default=.false.) call get_param(param_file, mdl, "SPLIT_BOTTOM_STRESS", CS%split_bottom_stress, & "If true, provide the bottom stress calculated by the "//& "vertical viscosity to the barotropic solver.", default=.false.) @@ -1153,12 +1481,51 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param "If true, use the summed layered fluxes plus an "//& "adjustment due to the change in the barotropic velocity "//& "in the barotropic continuity equation.", default=.true.) + call get_param(param_file, mdl, "BT_ADJ_CORR_MASS_SRC", CS%BT_adj_corr_mass_src, & + "If true, recalculates the barotropic mass source after "//& + "predictor step. This should make little difference in the "//& + "deep ocean but appears to help for vanished layers. If false, "//& + "uses the same mass source as from the predictor step.", default=.true.) + call get_param(param_file, mdl, "STORE_CORIOLIS_ACCEL", CS%store_CAu, & + "If true, calculate the Coriolis accelerations at the end of each "//& + "timestep for use in the predictor step of the next split RK2 timestep.", & + default=.true.) + call get_param(param_file, mdl, "FPMIX", CS%fpmix, & + "If true, add non-local momentum flux increments and diffuse down the Eulerian gradient.", & + default=.false.) + if (CS%fpmix) then + call get_param(param_file, "MOM", "CEMP_NL", CS%Cemp_NL, & + "Empirical coefficient of non-local momentum mixing.", & + units="nondim", default=3.6) + endif + call get_param(param_file, mdl, "REMAP_AUXILIARY_VARS", CS%remap_aux, & + "If true, apply ALE remapping to all of the auxiliary 3-dimensional "//& + "variables that are needed to reproduce across restarts, similarly to "//& + "what is already being done with the primary state variables. "//& + "The default should be changed to true.", default=.false., do_not_log=.true.) + if (CS%remap_aux .and. .not.CS%store_CAu) call MOM_error(FATAL, & + "REMAP_AUXILIARY_VARS requires that STORE_CORIOLIS_ACCEL = True.") call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) - call get_param(param_file, mdl, "DEBUG_OBC", CS%debug_OBC, default=.false.) + call get_param(param_file, mdl, "OBC_DEBUGGING_TESTS", CS%debug_OBC, & + "If true, do additional calls resetting certain values to help verify the "//& + "correctness of the open boundary condition code.", & + default=.false., old_name="DEBUG_OBC", debuggingParam=.true., do_not_log=.true.) call get_param(param_file, mdl, "DEBUG_TRUNCATIONS", debug_truncations, & default=.false.) + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. + call get_param(param_file, mdl, "VISC_REM_BUG", visc_rem_bug, & + "If true, visc_rem_[uv] in split mode is incorrectly calculated or accounted "//& + "for in two places. This parameter controls the defaults of two individual "//& + "flags, VISC_REM_TIMESTEP_BUG in MOM_dynamics_split_RK2(b) and "//& + "VISC_REM_BT_WEIGHT_BUG in MOM_barotropic.", default=.false.) + 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) @@ -1172,6 +1539,8 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param ALLOC_(CS%u_accel_bt(IsdB:IedB,jsd:jed,nz)) ; CS%u_accel_bt(:,:,:) = 0.0 ALLOC_(CS%v_accel_bt(isd:ied,JsdB:JedB,nz)) ; CS%v_accel_bt(:,:,:) = 0.0 + ALLOC_(CS%PFu_Stokes(IsdB:IedB,jsd:jed,nz)) ; CS%PFu_Stokes(:,:,:) = 0.0 + ALLOC_(CS%PFv_Stokes(isd:ied,JsdB:JedB,nz)) ; CS%PFv_Stokes(:,:,:) = 0.0 MIS%diffu => CS%diffu MIS%diffv => CS%diffv @@ -1196,32 +1565,47 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param Accel_diag%u_accel_bt => CS%u_accel_bt Accel_diag%v_accel_bt => CS%v_accel_bt + allocate(CS%AD_pred) + CS%AD_pred%diffu => CS%diffu + CS%AD_pred%diffv => CS%diffv + CS%AD_pred%PFu => CS%PFu + CS%AD_pred%PFv => CS%PFv + CS%AD_pred%CAu => CS%CAu_pred + CS%AD_pred%CAv => CS%CAv_pred + CS%AD_pred%u_accel_bt => CS%u_accel_bt + CS%AD_pred%v_accel_bt => CS%v_accel_bt ! Accel_diag%pbce => CS%pbce ! Accel_diag%u_accel_bt => CS%u_accel_bt ; Accel_diag%v_accel_bt => CS%v_accel_bt ! Accel_diag%u_av => CS%u_av ; Accel_diag%v_av => CS%v_av - id_clock_pass_init = cpu_clock_id('(Ocean init message passing)', & - grain=CLOCK_ROUTINE) + id_clock_pass_init = cpu_clock_id('(Ocean init message passing)', grain=CLOCK_ROUTINE) - call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) + call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp, CS%OBC) cont_stencil = continuity_stencil(CS%continuity_CSp) call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) - if (use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) - call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & - CS%tides_CSp) + cor_stencil = CoriolisAdv_stencil(CS%CoriolisAdv) + dyn_h_stencil = max(cont_stencil, CoriolisAdv_stencil(CS%CoriolisAdv)) + if (CS%calculate_SAL) call SAL_init(h, tv, G, GV, US, param_file, CS%SAL_CSp, restart_CS) + if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) + if (CS%use_HA) then + call HA_init(Time, US, param_file, nc, CS%HA_CSp) + HA_CSp => CS%HA_CSp + else + HA_CSp => NULL() + endif + call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, CS%ADp, & + CS%SAL_CSp, CS%tides_CSp) call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc, ADp=CS%ADp) call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, & - ntrunc, CS%vertvisc_CSp) + ntrunc, CS%vertvisc_CSp, CS%fpmix) CS%set_visc_CSp => set_visc - call updateCFLtruncationValue(Time, CS%vertvisc_CSp, US, & - activate=is_new_run(restart_CS) ) + call updateCFLtruncationValue(Time, CS%vertvisc_CSp, US, activate=is_new_run(restart_CS) ) if (associated(ALE_CSp)) CS%ALE_CSp => ALE_CSp if (associated(OBC)) then CS%OBC => OBC - if (OBC%ramp) call update_OBC_ramp(Time, CS%OBC, US, & - activate=is_new_run(restart_CS) ) + if (OBC%ramp) call update_OBC_ramp(Time, CS%OBC, US, activate=is_new_run(restart_CS) ) endif if (associated(update_OBC_CSp)) CS%update_OBC_CSp => update_OBC_CSp @@ -1238,81 +1622,99 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param do k=1,nz ; do j=js,je ; do i=is,ie CS%eta(i,j) = CS%eta(i,j) + h(i,j,k) enddo ; enddo ; enddo - elseif ((GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= GV%m_to_H)) then - H_rescale = GV%m_to_H / GV%m_to_H_restart - do j=js,je ; do i=is,ie ; CS%eta(i,j) = H_rescale * CS%eta(i,j) ; enddo ; enddo + call set_initialized(CS%eta, trim(eta_rest_name), restart_CS) endif ! Copy eta into an output array. do j=js,je ; do i=is,ie ; eta(i,j) = CS%eta(i,j) ; enddo ; enddo - call barotropic_init(u, v, h, CS%eta, Time, G, GV, US, param_file, diag, & + call barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, & CS%barotropic_CSp, restart_CS, calc_dtbt, CS%BT_cont, & - CS%tides_CSp) - - if (.not. query_initialized(CS%diffu,"diffu",restart_CS) .or. & - .not. query_initialized(CS%diffv,"diffv",restart_CS)) then - call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, VarMix, & - G, GV, US, CS%hor_visc, & - OBC=CS%OBC, BT=CS%barotropic_CSp, & - TD=thickness_diffuse_CSp) - else - if ( (US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & - (US%m_to_L * US%s_to_T_restart**2 /= US%m_to_L_restart * US%s_to_T**2) ) then - accel_rescale = (US%m_to_L * US%s_to_T_restart**2) / (US%m_to_L_restart * US%s_to_T**2) - do k=1,nz ; do j=js,je ; do I=G%IscB,G%IecB - CS%diffu(I,j,k) = accel_rescale * CS%diffu(I,j,k) - enddo ; enddo ; enddo - do k=1,nz ; do J=G%JscB,G%JecB ; do i=is,ie - CS%diffv(i,J,k) = accel_rescale * CS%diffv(i,J,k) - enddo ; enddo ; enddo - endif + CS%OBC, CS%SAL_CSp, HA_CSp) + + if (.not. query_initialized(CS%diffu, "diffu", restart_CS) .or. & + .not. query_initialized(CS%diffv, "diffv", restart_CS)) then + call horizontal_viscosity(u, v, h, uh, vh, CS%diffu, CS%diffv, MEKE, VarMix, G, GV, US, CS%hor_visc, & + tv, dt, OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, & + hu_cont=CS%BT_cont%h_u, hv_cont=CS%BT_cont%h_v) + call set_initialized(CS%diffu, "diffu", restart_CS) + call set_initialized(CS%diffv, "diffv", restart_CS) endif - if (.not. query_initialized(CS%u_av,"u2", restart_CS) .or. & - .not. query_initialized(CS%u_av,"v2", restart_CS)) then + if (.not. query_initialized(CS%u_av, "u2", restart_CS) .or. & + .not. query_initialized(CS%v_av, "v2", restart_CS)) then do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB ; CS%u_av(I,j,k) = u(I,j,k) ; enddo ; enddo ; enddo do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied ; CS%v_av(i,J,k) = v(i,J,k) ; enddo ; enddo ; enddo - elseif ( (US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & - ((US%m_to_L * US%s_to_T_restart) /= (US%m_to_L_restart * US%s_to_T)) ) then - vel_rescale = (US%m_to_L * US%s_to_T_restart) / (US%m_to_L_restart * US%s_to_T) - do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB ; CS%u_av(I,j,k) = vel_rescale * CS%u_av(I,j,k) ; enddo ; enddo ; enddo - do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied ; CS%v_av(i,J,k) = vel_rescale * CS%v_av(i,J,k) ; enddo ; enddo ; enddo + call set_initialized(CS%u_av, "u2", restart_CS) + call set_initialized(CS%v_av, "v2", restart_CS) endif - ! This call is just here to initialize uh and vh. - if (.not. query_initialized(uh,"uh",restart_CS) .or. & - .not. query_initialized(vh,"vh",restart_CS)) then - do k=1,nz ; do j=jsd,jed ; do i=isd,ied ; h_tmp(i,j,k) = h(i,j,k) ; enddo ; enddo ; enddo - call continuity(u, v, h, h_tmp, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv) - call pass_var(h_tmp, G%Domain, clock=id_clock_pass_init) - do k=1,nz ; do j=jsd,jed ; do i=isd,ied - CS%h_av(i,j,k) = 0.5*(h(i,j,k) + h_tmp(i,j,k)) - enddo ; enddo ; enddo - else - if (.not. query_initialized(CS%h_av,"h2",restart_CS)) then - CS%h_av(:,:,:) = h(:,:,:) - elseif ((GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= GV%m_to_H)) then - H_rescale = GV%m_to_H / GV%m_to_H_restart - do k=1,nz ; do j=js,je ; do i=is,ie ; CS%h_av(i,j,k) = H_rescale * CS%h_av(i,j,k) ; enddo ; enddo ; enddo + if (CS%store_CAu) then + if (query_initialized(CS%CAu_pred, "CAu", restart_CS) .and. & + query_initialized(CS%CAv_pred, "CAv", restart_CS)) then + CS%CAu_pred_stored = .true. + else + call only_read_from_restarts(uh, vh, 'uh', 'vh', G, restart_CS, stagger=CGRID_NE, & + filename=dirs%input_filename, directory=dirs%restart_input_dir, & + success=read_uv, scale=US%m_to_L**2*US%T_to_s/GV%H_to_mks) + call only_read_from_restarts('h2', CS%h_av, G, restart_CS, & + filename=dirs%input_filename, directory=dirs%restart_input_dir, & + success=read_h2, scale=1.0/GV%H_to_mks) + if (read_uv .and. read_h2) then + call pass_var(CS%h_av, G%Domain, clock=id_clock_pass_init) + else + do k=1,nz ; do j=jsd,jed ; do i=isd,ied ; h_tmp(i,j,k) = h(i,j,k) ; enddo ; enddo ; enddo + call continuity(CS%u_av, CS%v_av, h, h_tmp, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv) + call pass_var(h_tmp, G%Domain, clock=id_clock_pass_init) + do k=1,nz ; do j=jsd,jed ; do i=isd,ied + CS%h_av(i,j,k) = 0.5*(h(i,j,k) + h_tmp(i,j,k)) + enddo ; enddo ; enddo + endif + call pass_vector(CS%u_av, CS%v_av, G%Domain, halo=cor_stencil, clock=id_clock_pass_init, complete=.false.) + call pass_vector(uh, vh, G%Domain, halo=cor_stencil, clock=id_clock_pass_init, complete=.true.) + call CorAdCalc(CS%u_av, CS%v_av, CS%h_av, uh, vh, CS%CAu_pred, CS%CAv_pred, CS%OBC, CS%ADp, & + G, GV, US, CS%CoriolisAdv, pbv) !, Waves=Waves) + CS%CAu_pred_stored = .true. endif - if ( (GV%m_to_H_restart * US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & - ((GV%m_to_H * US%m_to_L**2 * US%s_to_T_restart) /= & - (GV%m_to_H_restart * US%m_to_L_restart**2 * US%s_to_T)) ) then - uH_rescale = (GV%m_to_H * US%m_to_L**2 * US%s_to_T_restart) / & - (GV%m_to_H_restart * US%m_to_L_restart**2 * US%s_to_T) - do k=1,nz ; do j=js,je ; do I=G%IscB,G%IecB ; uh(I,j,k) = uH_rescale * uh(I,j,k) ; enddo ; enddo ; enddo - do k=1,nz ; do J=G%JscB,G%JecB ; do i=is,ie ; vh(i,J,k) = uH_rescale * vh(i,J,k) ; enddo ; enddo ; enddo + else + CS%CAu_pred_stored = .false. + ! This call is just here to initialize uh and vh. + if (.not. query_initialized(uh, "uh", restart_CS) .or. & + .not. query_initialized(vh, "vh", restart_CS)) then + do k=1,nz ; do j=jsd,jed ; do i=isd,ied ; h_tmp(i,j,k) = h(i,j,k) ; enddo ; enddo ; enddo + call continuity(u, v, h, h_tmp, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv) + call pass_var(h_tmp, G%Domain, clock=id_clock_pass_init) + do k=1,nz ; do j=jsd,jed ; do i=isd,ied + CS%h_av(i,j,k) = 0.5*(h(i,j,k) + h_tmp(i,j,k)) + enddo ; enddo ; enddo + call set_initialized(uh, "uh", restart_CS) + call set_initialized(vh, "vh", restart_CS) + call set_initialized(CS%h_av, "h2", restart_CS) + ! Try reading the CAu and CAv fields from the restart file, in case this restart file is + ! using a newer format. + call only_read_from_restarts(CS%CAu_pred, CS%CAv_pred, "CAu", "CAv", G, restart_CS, & + stagger=CGRID_NE, filename=dirs%input_filename, directory=dirs%restart_input_dir, & + success=read_uv, scale=US%m_s_to_L_T*US%T_to_s) + CS%CAu_pred_stored = read_uv + else + if (.not. query_initialized(CS%h_av, "h2", restart_CS)) then + CS%h_av(:,:,:) = h(:,:,:) + call set_initialized(CS%h_av, "h2", restart_CS) + endif endif endif - call cpu_clock_begin(id_clock_pass_init) call create_group_pass(pass_av_h_uvh, CS%u_av, CS%v_av, G%Domain, halo=2) - call create_group_pass(pass_av_h_uvh, CS%h_av, G%Domain, halo=2) - call create_group_pass(pass_av_h_uvh, uh, vh, G%Domain, halo=2) + if (CS%CAu_pred_stored) then + call create_group_pass(pass_av_h_uvh, CS%CAu_pred, CS%CAv_pred, G%Domain, halo=2) + else + call create_group_pass(pass_av_h_uvh, CS%h_av, G%Domain, halo=2) + call create_group_pass(pass_av_h_uvh, uh, vh, G%Domain, halo=2) + endif call do_group_pass(pass_av_h_uvh, G%Domain) call cpu_clock_end(id_clock_pass_init) flux_units = get_flux_units(GV) + thickness_units = get_thickness_units(GV) CS%id_uh = register_diag_field('ocean_model', 'uh', diag%axesCuL, Time, & 'Zonal Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & y_cell_method='sum', v_extensive=.true.) @@ -1329,11 +1731,19 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param CS%id_PFv = register_diag_field('ocean_model', 'PFv', diag%axesCvL, Time, & 'Meridional Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_ueffA = register_diag_field('ocean_model', 'ueffA', diag%axesCuL, Time, & - 'Effective U-Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & - y_cell_method='sum', v_extensive = .true.) + 'Effective U-Face Area', 'm^2', conversion=GV%H_to_m*US%L_to_m, & + y_cell_method='sum', v_extensive=.true.) CS%id_veffA = register_diag_field('ocean_model', 'veffA', diag%axesCvL, Time, & - 'Effective V-Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & - x_cell_method='sum', v_extensive = .true.) + 'Effective V-Face Area', 'm^2', conversion=GV%H_to_m*US%L_to_m, & + x_cell_method='sum', v_extensive=.true.) + if (GV%Boussinesq) then + CS%id_deta_dt = register_diag_field('ocean_model', 'deta_dt', diag%axesT1, Time, & + 'Barotropic SSH tendency due to dynamics', trim(thickness_units)//' s-1', conversion=GV%H_to_MKS*US%s_to_T) + else + CS%id_deta_dt = register_diag_field('ocean_model', 'deta_dt', diag%axesT1, Time, & + 'Barotropic column-mass tendency due to dynamics', trim(thickness_units)//' s-1', & + conversion=GV%H_to_mks*US%s_to_T) + endif !CS%id_hf_PFu = register_diag_field('ocean_model', 'hf_PFu', diag%axesCuL, Time, & ! 'Fractional Thickness-weighted Zonal Pressure Force Acceleration', & @@ -1368,12 +1778,12 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param CS%id_h_PFu = register_diag_field('ocean_model', 'h_PFu', diag%axesCuL, Time, & 'Thickness Multiplied Zonal Pressure Force Acceleration', & 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) - if(CS%id_h_PFu > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + if (CS%id_h_PFu > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) CS%id_h_PFv = register_diag_field('ocean_model', 'h_PFv', diag%axesCvL, Time, & 'Thickness Multiplied Meridional Pressure Force Acceleration', & 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) - if(CS%id_h_PFv > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + if (CS%id_h_PFv > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) CS%id_intz_PFu_2d = register_diag_field('ocean_model', 'intz_PFu_2d', diag%axesCu1, Time, & 'Depth-integral of Zonal Pressure Force Acceleration', & @@ -1398,12 +1808,12 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param CS%id_h_CAu = register_diag_field('ocean_model', 'h_CAu', diag%axesCuL, Time, & 'Thickness Multiplied Zonal Coriolis and Advective Acceleration', & 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) - if(CS%id_h_CAu > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + if (CS%id_h_CAu > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) CS%id_h_CAv = register_diag_field('ocean_model', 'h_CAv', diag%axesCvL, Time, & 'Thickness Multiplied Meridional Coriolis and Advective Acceleration', & 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) - if(CS%id_h_CAv > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + if (CS%id_h_CAv > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) CS%id_intz_CAu_2d = register_diag_field('ocean_model', 'intz_CAu_2d', diag%axesCu1, Time, & 'Depth-integral of Zonal Coriolis and Advective Acceleration', & @@ -1448,12 +1858,12 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param CS%id_h_u_BT_accel = register_diag_field('ocean_model', 'h_u_BT_accel', diag%axesCuL, Time, & 'Thickness Multiplied Barotropic Anomaly Zonal Acceleration', & 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) - if(CS%id_h_u_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + if (CS%id_h_u_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) CS%id_h_v_BT_accel = register_diag_field('ocean_model', 'h_v_BT_accel', diag%axesCvL, Time, & 'Thickness Multiplied Barotropic Anomaly Meridional Acceleration', & 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) - if(CS%id_h_v_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + if (CS%id_h_v_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) CS%id_intz_u_BT_accel_2d = register_diag_field('ocean_model', 'intz_u_BT_accel_2d', diag%axesCu1, Time, & 'Depth-integral of Barotropic Anomaly Zonal Acceleration', & @@ -1472,7 +1882,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param CS%id_PFv_visc_rem = register_diag_field('ocean_model', 'PFv_visc_rem', diag%axesCvL, Time, & 'Meridional Pressure Force Acceleration multiplied by the viscous remnant', & 'm s-2', conversion=US%L_T2_to_m_s2) - if(CS%id_PFv_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_v,isd,ied,JsdB,JedB,nz) + if (CS%id_PFv_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_v,isd,ied,JsdB,JedB,nz) CS%id_CAu_visc_rem = register_diag_field('ocean_model', 'CAu_visc_rem', diag%axesCuL, Time, & 'Zonal Coriolis and Advective Acceleration multiplied by the viscous remnant', & @@ -1481,7 +1891,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param CS%id_CAv_visc_rem = register_diag_field('ocean_model', 'CAv_visc_rem', diag%axesCvL, Time, & 'Meridional Coriolis and Advective Acceleration multiplied by the viscous remnant', & 'm s-2', conversion=US%L_T2_to_m_s2) - if(CS%id_CAv_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_v,isd,ied,JsdB,JedB,nz) + if (CS%id_CAv_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_v,isd,ied,JsdB,JedB,nz) CS%id_u_BT_accel_visc_rem = register_diag_field('ocean_model', 'u_BT_accel_visc_rem', diag%axesCuL, Time, & 'Barotropic Anomaly Zonal Acceleration multiplied by the viscous remnant', & @@ -1490,7 +1900,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param CS%id_v_BT_accel_visc_rem = register_diag_field('ocean_model', 'v_BT_accel_visc_rem', diag%axesCvL, Time, & 'Barotropic Anomaly Meridional Acceleration multiplied by the viscous remnant', & 'm s-2', conversion=US%L_T2_to_m_s2) - if(CS%id_v_BT_accel_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_v,isd,ied,JsdB,JedB,nz) + if (CS%id_v_BT_accel_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_v,isd,ied,JsdB,JedB,nz) id_clock_Cor = cpu_clock_id('(Ocean Coriolis & mom advection)', grain=CLOCK_MODULE) id_clock_continuity = cpu_clock_id('(Ocean continuity equation)', grain=CLOCK_MODULE) @@ -1516,11 +1926,13 @@ subroutine end_dyn_split_RK2(CS) deallocate(CS%vertvisc_CSp) call hor_visc_end(CS%hor_visc) - call tidal_forcing_end(CS%tides_CSp) + if (CS%calculate_SAL) call SAL_end(CS%SAL_CSp) + if (CS%use_tides) call tidal_forcing_end(CS%tides_CSp) call CoriolisAdv_end(CS%CoriolisAdv) DEALLOC_(CS%diffu) ; DEALLOC_(CS%diffv) DEALLOC_(CS%CAu) ; DEALLOC_(CS%CAv) + DEALLOC_(CS%CAu_pred) ; DEALLOC_(CS%CAv_pred) DEALLOC_(CS%PFu) ; DEALLOC_(CS%PFv) if (associated(CS%taux_bot)) deallocate(CS%taux_bot) @@ -1533,6 +1945,7 @@ subroutine end_dyn_split_RK2(CS) DEALLOC_(CS%h_av) ; DEALLOC_(CS%u_av) ; DEALLOC_(CS%v_av) call dealloc_BT_cont_type(CS%BT_cont) + deallocate(CS%AD_pred) deallocate(CS) end subroutine end_dyn_split_RK2 diff --git a/src/core/MOM_dynamics_split_RK2b.F90 b/src/core/MOM_dynamics_split_RK2b.F90 new file mode 100644 index 0000000000..377016d43e --- /dev/null +++ b/src/core/MOM_dynamics_split_RK2b.F90 @@ -0,0 +1,1785 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Time step the adiabatic dynamic core of MOM using RK2 method with greater use of the +!! time-filtered velocities and less inheritance of tedencies from the previous step in the +!! predictor step than in the original MOM_dyanmics_split_RK2. +module MOM_dynamics_split_RK2b + +use MOM_variables, only : vertvisc_type, thermo_var_ptrs, porous_barrier_type +use MOM_variables, only : BT_cont_type, alloc_bt_cont_type, dealloc_bt_cont_type +use MOM_variables, only : accel_diag_ptrs, ocean_internal_state, cont_diag_ptrs +use MOM_forcing_type, only : mech_forcing + +use MOM_checksum_packages, only : MOM_thermo_chksum, MOM_state_chksum, MOM_accel_chksum +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_SUBCOMPONENT +use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diag_mediator, only : diag_mediator_init, enable_averages +use MOM_diag_mediator, only : disable_averaging, post_data, safe_alloc_ptr +use MOM_diag_mediator, only : post_product_u, post_product_sum_u +use MOM_diag_mediator, only : post_product_v, post_product_sum_v +use MOM_diag_mediator, only : register_diag_field, register_static_field +use MOM_diag_mediator, only : set_diag_mediator_grid, diag_ctrl, diag_update_remap_grids +use MOM_domains, only : To_South, To_West, To_All, CGRID_NE, SCALAR_PAIR +use MOM_domains, only : To_North, To_East, Omit_Corners +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_domains, only : start_group_pass, complete_group_pass, pass_var, pass_vector +use MOM_debugging, only : hchksum, uvchksum, query_debugging_checks +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : MOM_set_verbosity, callTree_showQuery +use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_io, only : vardesc, var_desc, EAST_FACE, NORTH_FACE +use MOM_restart, only : register_restart_field, register_restart_pair +use MOM_restart, only : query_initialized, set_initialized, save_restart +use MOM_restart, only : only_read_from_restarts +use MOM_restart, only : restart_init, is_new_run, MOM_restart_CS +use MOM_time_manager, only : time_type, operator(+) +use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) + +use MOM_ALE, only : ALE_CS, ALE_remap_velocities +use MOM_barotropic, only : barotropic_init, btstep, btcalc, bt_mass_source +use MOM_barotropic, only : register_barotropic_restarts, set_dtbt, barotropic_CS +use MOM_barotropic, only : barotropic_end +use MOM_boundary_update, only : update_OBC_data, update_OBC_CS +use MOM_continuity, only : continuity, continuity_CS +use MOM_continuity, only : continuity_init, continuity_stencil +use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_CS +use MOM_CoriolisAdv, only : CoriolisAdv_init, CoriolisAdv_end, CoriolisAdv_stencil +use MOM_debugging, only : check_redundant +use MOM_grid, only : ocean_grid_type +use MOM_harmonic_analysis, only : HA_init, harmonic_analysis_CS +use MOM_hor_index, only : hor_index_type +use MOM_hor_visc, only : horizontal_viscosity, hor_visc_CS +use MOM_hor_visc, only : hor_visc_init, hor_visc_end +use MOM_interface_heights, only : thickness_to_dz, find_col_avg_SpV +use MOM_lateral_mixing_coeffs, only : VarMix_CS +use MOM_MEKE_types, only : MEKE_type +use MOM_open_boundary, only : ocean_OBC_type, radiation_open_bdry_conds +use MOM_open_boundary, only : open_boundary_zero_normal_flow, open_boundary_query +use MOM_open_boundary, only : open_boundary_test_extern_h, update_OBC_ramp +use MOM_open_boundary, only : copy_thickness_reservoirs +use MOM_open_boundary, only : update_segment_thickness_reservoirs +use MOM_PressureForce, only : PressureForce, PressureForce_CS +use MOM_PressureForce, only : PressureForce_init +use MOM_set_visc, only : set_viscous_ML, set_visc_CS +use MOM_thickness_diffuse, only : thickness_diffuse_CS +use MOM_self_attr_load, only : SAL_CS +use MOM_self_attr_load, only : SAL_init, SAL_end +use MOM_tidal_forcing, only : tidal_forcing_CS +use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_end +use MOM_unit_scaling, only : unit_scale_type +use MOM_vert_friction, only : vertvisc, vertvisc_coef, vertvisc_remnant +use MOM_vert_friction, only : vertvisc_init, vertvisc_end, vertvisc_CS +use MOM_vert_friction, only : updateCFLtruncationValue, vertFPmix +use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units +use MOM_verticalGrid, only : get_flux_units, get_tr_flux_units +use MOM_wave_interface, only : wave_parameters_CS, Stokes_PGF + +implicit none ; private + +#include + +!> MOM_dynamics_split_RK2b module control structure +type, public :: MOM_dyn_split_RK2b_CS ; private + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: & + CAu, & !< CAu = f*v - u.grad(u) [L T-2 ~> m s-2] + CAu_pred, & !< The predictor step value of CAu = f*v - u.grad(u) [L T-2 ~> m s-2] + PFu, & !< PFu = -dM/dx [L T-2 ~> m s-2] + PFu_Stokes, & !< PFu_Stokes = -d/dx int_r (u_L*duS/dr) [L T-2 ~> m s-2] + diffu !< Zonal acceleration due to convergence of the along-isopycnal stress tensor [L T-2 ~> m s-2] + + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: & + CAv, & !< CAv = -f*u - u.grad(v) [L T-2 ~> m s-2] + CAv_pred, & !< The predictor step value of CAv = -f*u - u.grad(v) [L T-2 ~> m s-2] + PFv, & !< PFv = -dM/dy [L T-2 ~> m s-2] + PFv_Stokes, & !< PFv_Stokes = -d/dy int_r (v_L*dvS/dr) [L T-2 ~> m s-2] + diffv !< Meridional acceleration due to convergence of the along-isopycnal stress tensor [L T-2 ~> m s-2] + + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: visc_rem_u + !< Both the fraction of the zonal momentum originally in a + !! layer that remains after a time-step of viscosity, and the + !! fraction of a time-step worth of a barotropic acceleration + !! that a layer experiences after viscosity is applied [nondim]. + !! Nondimensional between 0 (at the bottom) and 1 (far above). + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: u_accel_bt + !< The zonal layer accelerations due to the difference between + !! the barotropic accelerations and the baroclinic accelerations + !! that were fed into the barotopic calculation [L T-2 ~> m s-2] + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: visc_rem_v + !< Both the fraction of the meridional momentum originally in + !! a layer that remains after a time-step of viscosity, and the + !! fraction of a time-step worth of a barotropic acceleration + !! that a layer experiences after viscosity is applied [nondim]. + !! Nondimensional between 0 (at the bottom) and 1 (far above). + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: v_accel_bt + !< The meridional layer accelerations due to the difference between + !! the barotropic accelerations and the baroclinic accelerations + !! that were fed into the barotopic calculation [L T-2 ~> m s-2] + + ! The following variables are only used with the split time stepping scheme. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: eta !< Instantaneous free surface height (in Boussinesq + !! mode) or column mass anomaly (in non-Boussinesq + !! mode) [H ~> m or kg m-2] + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: u_av !< layer x-velocity with vertical mean replaced by + !! time-mean barotropic velocity over a baroclinic + !! timestep [L T-1 ~> m s-1] + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: v_av !< layer y-velocity with vertical mean replaced by + !! time-mean barotropic velocity over a baroclinic + !! timestep [L T-1 ~> m s-1] + real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: h_av !< arithmetic mean of two successive layer + !! thicknesses [H ~> m or kg m-2] + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: eta_PF !< instantaneous SSH used in calculating PFu and + !! PFv [H ~> m or kg m-2] + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: uhbt !< average x-volume or mass flux determined by the + !! barotropic solver [H L2 T-1 ~> m3 s-1 or kg s-1]. + !! uhbt is roughly equal to the vertical sum of uh. + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: vhbt !< average y-volume or mass flux determined by the + !! barotropic solver [H L2 T-1 ~> m3 s-1 or kg s-1]. + !! vhbt is roughly equal to vertical sum of vh. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: pbce !< pbce times eta gives the baroclinic pressure + !! anomaly in each layer due to free surface height + !! anomalies [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: du_av_inst !< The barotropic zonal velocity increment + !! between filtered and instantaneous velocities + !! [L T-1 ~> m s-1] + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: dv_av_inst !< The barotropic meridional velocity increment + !! between filtered and instantaneous velocities + !! [L T-1 ~> m s-1] + + real, pointer, dimension(:,:) :: taux_bot => NULL() !< frictional x-bottom stress from the ocean + !! to the seafloor [R L Z T-2 ~> Pa] + real, pointer, dimension(:,:) :: tauy_bot => NULL() !< frictional y-bottom stress from the ocean + !! to the seafloor [R L Z T-2 ~> Pa] + type(BT_cont_type), pointer :: BT_cont => NULL() !< A structure with elements that describe the + !! effective summed open face areas as a function + !! of barotropic flow. + + logical :: BT_adj_corr_mass_src !< If true, recalculates the barotropic mass source after + !! predictor step. This should make little difference in the + !! deep ocean but appears to help for vanished layers. + logical :: split_bottom_stress !< If true, provide the bottom stress + !! calculated by the vertical viscosity to the + !! barotropic solver. + logical :: dtbt_use_bt_cont !< If true, use BT_cont to calculate DTBT. + logical :: calculate_SAL !< If true, calculate self-attraction and loading. + logical :: use_tides !< If true, tidal forcing is enabled. + logical :: use_HA !< If true, perform inline harmonic analysis. + logical :: remap_aux !< If true, apply ALE remapping to all of the auxiliary 3-D + !! variables that are needed to reproduce across restarts, + !! similarly to what is done with the primary state variables. + + real :: be !< A nondimensional number from 0.5 to 1 that controls + !! the backward weighting of the time stepping scheme [nondim] + real :: begw !< A nondimensional number from 0 to 1 that controls + !! the extent to which the treatment of gravity waves + !! is forward-backward (0) or simulated backward + !! Euler (1) [nondim]. 0 is often used. + logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: debug_OBC !< If true, do additional calls resetting values to help verify the correctness + !! of the open boundary condition code. + logical :: fpmix = .false. !< If true, applies profiles of momentum flux magnitude and direction. + logical :: module_is_initialized = .false. !< Record whether this module has been initialized. + logical :: visc_rem_dt_bug = .true. !< If true, recover a bug that uses dt_pred rather than dt for vertvisc_rem + !! at the end of predictor. + + !>@{ Diagnostic IDs + ! integer :: id_uold = -1, id_vold = -1 + integer :: id_uh = -1, id_vh = -1 + integer :: id_umo = -1, id_vmo = -1 + integer :: id_umo_2d = -1, id_vmo_2d = -1 + integer :: id_PFu = -1, id_PFv = -1 + integer :: id_CAu = -1, id_CAv = -1 + integer :: id_ueffA = -1, id_veffA = -1 + ! integer :: id_hf_PFu = -1, id_hf_PFv = -1 + integer :: id_h_PFu = -1, id_h_PFv = -1 + integer :: id_hf_PFu_2d = -1, id_hf_PFv_2d = -1 + integer :: id_intz_PFu_2d = -1, id_intz_PFv_2d = -1 + integer :: id_PFu_visc_rem = -1, id_PFv_visc_rem = -1 + ! integer :: id_hf_CAu = -1, id_hf_CAv = -1 + integer :: id_h_CAu = -1, id_h_CAv = -1 + integer :: id_hf_CAu_2d = -1, id_hf_CAv_2d = -1 + integer :: id_intz_CAu_2d = -1, id_intz_CAv_2d = -1 + integer :: id_CAu_visc_rem = -1, id_CAv_visc_rem = -1 + integer :: id_deta_dt = -1 + + ! Split scheme only. + integer :: id_uav = -1, id_vav = -1 + integer :: id_u_BT_accel = -1, id_v_BT_accel = -1 + ! integer :: id_hf_u_BT_accel = -1, id_hf_v_BT_accel = -1 + integer :: id_h_u_BT_accel = -1, id_h_v_BT_accel = -1 + integer :: id_hf_u_BT_accel_2d = -1, id_hf_v_BT_accel_2d = -1 + integer :: id_intz_u_BT_accel_2d = -1, id_intz_v_BT_accel_2d = -1 + integer :: id_u_BT_accel_visc_rem = -1, id_v_BT_accel_visc_rem = -1 + !>@} + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the + !! timing of diagnostic output. + type(accel_diag_ptrs), pointer :: ADp => NULL() !< A structure pointing to the various + !! accelerations in the momentum equations, + !! which can later be used to calculate + !! derived diagnostics like energy budgets. + type(accel_diag_ptrs), pointer :: AD_pred => NULL() !< A structure pointing to the various + !! predictor step accelerations in the momentum equations, + !! which can be used to debug truncations. + type(cont_diag_ptrs), pointer :: CDp => NULL() !< A structure with pointers to various + !! terms in the continuity equations, + !! which can later be used to calculate + !! derived diagnostics like energy budgets. + + ! The remainder of the structure points to child subroutines' control structures. + !> A pointer to the horizontal viscosity control structure + type(hor_visc_CS) :: hor_visc + !> A pointer to the continuity control structure + type(continuity_CS) :: continuity_CSp + !> The CoriolisAdv control structure + type(CoriolisAdv_CS) :: CoriolisAdv + !> A pointer to the PressureForce control structure + type(PressureForce_CS) :: PressureForce_CSp + !> A pointer to a structure containing interface height diffusivities + type(vertvisc_CS), pointer :: vertvisc_CSp => NULL() + !> A pointer to the set_visc control structure + type(set_visc_CS), pointer :: set_visc_CSp => NULL() + !> A pointer to the barotropic stepping control structure + type(barotropic_CS) :: barotropic_CSp + !> A pointer to the SAL control structure + type(SAL_CS) :: SAL_CSp + !> A pointer to the tidal forcing control structure + type(tidal_forcing_CS) :: tides_CSp + !> A pointer to the harmonic analysis control structure + type(harmonic_analysis_CS) :: HA_CSp + !> A pointer to the ALE control structure. + type(ALE_CS), pointer :: ALE_CSp => NULL() + + type(ocean_OBC_type), pointer :: OBC => NULL() !< A pointer to an open boundary + !! condition type that specifies whether, where, and what open boundary + !! conditions are used. If no open BCs are used, this pointer stays + !! nullified. Flather OBCs use open boundary_CS as well. + !> A pointer to the update_OBC control structure + type(update_OBC_CS), pointer :: update_OBC_CSp => NULL() + + type(group_pass_type) :: pass_eta !< Structure for group halo pass + type(group_pass_type) :: pass_visc_rem !< Structure for group halo pass + type(group_pass_type) :: pass_uvp !< Structure for group halo pass + type(group_pass_type) :: pass_uv_inst !< Structure for group halo pass + type(group_pass_type) :: pass_hp_uv !< Structure for group halo pass + type(group_pass_type) :: pass_hp_uhvh !< Structure for group halo pass + type(group_pass_type) :: pass_h_uv !< Structure for group halo pass + +end type MOM_dyn_split_RK2b_CS + + +public step_MOM_dyn_split_RK2b +public register_restarts_dyn_split_RK2b +public initialize_dyn_split_RK2b +public remap_dyn_split_RK2b_aux_vars +public end_dyn_split_RK2b + +!>@{ CPU time clock IDs +integer :: id_clock_Cor, id_clock_pres, id_clock_vertvisc +integer :: id_clock_horvisc, id_clock_mom_update +integer :: id_clock_continuity, id_clock_thick_diff +integer :: id_clock_btstep, id_clock_btcalc, id_clock_btforce +integer :: id_clock_pass +!>@} + +contains + +!> RK2 splitting for time stepping MOM adiabatic dynamics +subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forces, & + p_surf_begin, p_surf_end, uh, vh, uhtr, vhtr, eta_av, & + G, GV, US, CS, calc_dtbt, VarMix, MEKE, thickness_diffuse_CSp, pbv, Waves) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + target, intent(inout) :: u_av !< Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + target, intent(inout) :: v_av !< Meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic type + type(vertvisc_type), intent(inout) :: visc !< Vertical visc, bottom drag, and related + type(time_type), intent(in) :: Time_local !< Model time at end of time step + real, intent(in) :: dt !< Baroclinic dynamics time step [T ~> s] + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, dimension(:,:), pointer :: p_surf_begin !< Surface pressure at the start of this dynamic + !! time step [R L2 T-2 ~> Pa] + real, dimension(:,:), pointer :: p_surf_end !< Surface pressure at the end of this dynamic + !! time step [R L2 T-2 ~> Pa] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + target, intent(inout) :: uh !< Zonal volume or mass transport + !! [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + target, intent(inout) :: vh !< Meridional volume or mass transport + !! [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: uhtr !< Accumulated zonal volume or mass transport + !! since last tracer advection [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: vhtr !< Accumulated meridional volume or mass transport + !! since last tracer advection [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_av !< Free surface height or column mass + !! averaged over time step [H ~> m or kg m-2] + type(MOM_dyn_split_RK2b_CS), pointer :: CS !< Module control structure + logical, intent(in) :: calc_dtbt !< If true, recalculate the barotropic time step + type(VarMix_CS), intent(inout) :: VarMix !< Variable mixing control structure + type(MEKE_type), intent(inout) :: MEKE !< MEKE fields + type(thickness_diffuse_CS), intent(inout) :: thickness_diffuse_CSp !< Pointer to a structure containing + !! interface height diffusivities + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + type(wave_parameters_CS), optional, pointer :: Waves !< A pointer to a structure containing + !! fields related to the surface wave conditions + + ! local variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: up ! Predicted zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vp ! Predicted meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: hp ! Predicted thickness [H ~> m or kg m-2]. + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Distance between the interfaces around a layer [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: ueffA ! Effective Area of U-Faces [H L ~> m2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: veffA ! Effective Area of V-Faces [H L ~> m2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: u_bc_accel ! The summed zonal baroclinic accelerations + ! of each layer calculated by the non-barotropic + ! part of the model [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: v_bc_accel ! The summed meridional baroclinic accelerations + ! of each layer calculated by the non-barotropic + ! part of the model [L T-2 ~> m s-2] + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), target :: u_inst ! Instantaneous zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), target :: v_inst ! Instantaneous meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_av ! The average of the layer thicknesses at the beginning + ! and end of a time step [H ~> m or kg m-2] + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), target :: uh_in ! The zonal mass transports that would be + ! obtained using the initial velocities [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), target :: vh_in ! The meridional mass transports that would be + ! obtained using the initial velocities [H L2 T-1 ~> m3 s-1 or kg s-1] + + real, dimension(SZI_(G),SZJ_(G)) :: eta_pred ! The predictor value of the free surface height + ! or column mass [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)) :: SpV_avg ! The column averaged specific volume [R-1 ~> m3 kg-1] + real, dimension(SZI_(G),SZJ_(G)) :: deta_dt ! A diagnostic of the time derivative of the free surface + ! height or column mass [H T-1 ~> m s-1 or kg m-2 s-1] + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: u_old_rad_OBC ! The starting zonal velocities, which are + ! saved for use in the Flather open boundary condition code [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: v_old_rad_OBC ! The starting meridional velocities, which are + ! saved for use in the Flather open boundary condition code [L T-1 ~> m s-1] + + ! GMM, TODO: make these allocatable? + ! real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uold ! u-velocity before vert_visc is applied, for fpmix + ! ! [L T-1 ~> m s-1] + ! real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vold ! v-velocity before vert_visc is applied, for fpmix + ! ! [L T-1 ~> m s-1] + real :: pres_to_eta ! A factor that converts pressures to the units of eta + ! [H T2 R-1 L-2 ~> m Pa-1 or kg m-2 Pa-1] + real, pointer, dimension(:,:) :: & + p_surf => NULL(), & ! A pointer to the surface pressure [R L2 T-2 ~> Pa] + eta_PF_start => NULL(), & ! The value of eta that corresponds to the starting pressure + ! for the barotropic solver [H ~> m or kg m-2] + taux_bot => NULL(), & ! A pointer to the zonal bottom stress in some cases [R L Z T-2 ~> Pa] + tauy_bot => NULL(), & ! A pointer to the meridional bottom stress in some cases [R L Z T-2 ~> Pa] + ! This pointer is just used as shorthand for CS%eta. + eta => NULL() ! A pointer to the instantaneous free surface height (in Boussinesq + ! mode) or column mass anomaly (in non-Boussinesq mode) [H ~> m or kg m-2] + + real, pointer, dimension(:,:,:) :: & + ! These pointers are used to alter which fields are passed to btstep with various options: + u_ptr => NULL(), & ! A pointer to a zonal velocity [L T-1 ~> m s-1] + v_ptr => NULL(), & ! A pointer to a meridional velocity [L T-1 ~> m s-1] + uh_ptr => NULL(), & ! A pointer to a zonal volume or mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] + vh_ptr => NULL() ! A pointer to a meridional volume or mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] + + ! real, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth from Cvmix [H ~> m or kg m-2] + real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. + real :: Idt_bc ! Inverse of the baroclinic timestep [T-1 ~> s-1] + logical :: dyn_p_surf + logical :: debug_redundant ! If true, check redundant values on PE boundaries when debugging + logical :: BT_cont_BT_thick ! If true, use the BT_cont_type to estimate the + ! relative weightings of the layers in calculating + ! the barotropic accelerations. + !---For group halo pass + logical :: showCallTree, sym + + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: cont_stencil, obc_stencil + integer :: cor_stencil + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + eta => CS%eta + + Idt_bc = 1.0 / dt + + sym = G%Domain%symmetric ! switch to include symmetric domain in checksums + + showCallTree = callTree_showQuery() + if (showCallTree) call callTree_enter("step_MOM_dyn_split_RK2b(), MOM_dynamics_split_RK2b.F90") + + ! Fill in some halo points for arrays that will have halo updates. + hp(:,:,:) = h(:,:,:) + up(:,:,:) = 0.0 ; vp(:,:,:) = 0.0 ; u_inst(:,:,:) = 0.0 ; v_inst(:,:,:) = 0.0 + + ! Update CFL truncation value as function of time + call updateCFLtruncationValue(Time_local, CS%vertvisc_CSp, US) + + if (CS%debug) then + call query_debugging_checks(do_redundant=debug_redundant) + call MOM_state_chksum("Start predictor ", u_av, v_av, h, uh, vh, G, GV, US, symmetric=sym) + if (debug_redundant) then + call check_redundant("Start predictor u ", u_av, v_av, G, unscale=US%L_T_to_m_s) + call check_redundant("Start predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif + endif + + dyn_p_surf = associated(p_surf_begin) .and. associated(p_surf_end) + if (dyn_p_surf) then + p_surf => p_surf_end + call safe_alloc_ptr(eta_PF_start,G%isd,G%ied,G%jsd,G%jed) + eta_PF_start(:,:) = 0.0 + else + p_surf => forces%p_surf + endif + + if (associated(CS%OBC)) then + if (CS%debug_OBC) call open_boundary_test_extern_h(G, GV, CS%OBC, h) + + ! Update OBC ramp value as function of time + call update_OBC_ramp(Time_local, CS%OBC, US) + + do k=1,nz ; do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB + u_old_rad_OBC(I,j,k) = u_av(I,j,k) + enddo ; enddo ; enddo + do k=1,nz ; do J=G%JsdB,G%JedB ; do i=G%isd,G%ied + v_old_rad_OBC(i,J,k) = v_av(i,J,k) + enddo ; enddo ; enddo + endif + + BT_cont_BT_thick = .false. + if (associated(CS%BT_cont)) BT_cont_BT_thick = & + (allocated(CS%BT_cont%h_u) .and. allocated(CS%BT_cont%h_v)) + + if (CS%split_bottom_stress) then + taux_bot => CS%taux_bot ; tauy_bot => CS%tauy_bot + endif + + !--- begin set up for group halo pass + + cont_stencil = continuity_stencil(CS%continuity_CSp) + obc_stencil = 2 + cor_stencil = CoriolisAdv_stencil(CS%CoriolisAdv) + if (associated(CS%OBC)) then + if (CS%OBC%oblique_BCs_exist_globally) obc_stencil = 3 + endif + call cpu_clock_begin(id_clock_pass) + call create_group_pass(CS%pass_eta, eta, G%Domain, halo=1) + call create_group_pass(CS%pass_visc_rem, CS%visc_rem_u, CS%visc_rem_v, G%Domain, & + To_All+SCALAR_PAIR, CGRID_NE, halo=max(1,cont_stencil)) + call create_group_pass(CS%pass_uvp, up, vp, G%Domain, halo=max(1,cont_stencil)) + call create_group_pass(CS%pass_uv_inst, u_inst, v_inst, G%Domain, halo=max(2,cont_stencil)) + + call create_group_pass(CS%pass_hp_uv, hp, G%Domain, halo=cor_stencil) + call create_group_pass(CS%pass_hp_uv, u_av, v_av, G%Domain, halo=max(cor_stencil,obc_stencil)) + call create_group_pass(CS%pass_hp_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(cor_stencil,obc_stencil)) + + call create_group_pass(CS%pass_hp_uhvh, hp, G%Domain, halo=cor_stencil) + call create_group_pass(CS%pass_hp_uhvh, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(cor_stencil,obc_stencil)) + if (cor_stencil > 2) then + call create_group_pass(CS%pass_hp_uhvh, u_av, v_av, G%Domain, halo=max(cor_stencil,obc_stencil)) + call create_group_pass(CS%pass_hp_uhvh, h, G%Domain, halo=cor_stencil) + endif + + call create_group_pass(CS%pass_h_uv, h, G%Domain, halo=max(cor_stencil,cont_stencil)) + call create_group_pass(CS%pass_h_uv, u_av, v_av, G%Domain, halo=max(cor_stencil,obc_stencil)) + call create_group_pass(CS%pass_h_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(cor_stencil,obc_stencil)) + + call cpu_clock_end(id_clock_pass) + !--- end set up for group halo pass + + ! This calculates the transports and averaged thicknesses that will be used for the + ! predictor version of the Coriolis scheme. + call cpu_clock_begin(id_clock_continuity) + call continuity(u_av, v_av, h, hp, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv) + call cpu_clock_end(id_clock_continuity) + + if (G%nonblocking_updates) & + call start_group_pass(CS%pass_hp_uhvh, G%Domain, clock=id_clock_pass) + +! PFu = d/dx M(h,T,S) +! pbce = dM/deta + if (CS%begw == 0.0) call enable_averages(dt, Time_local, CS%diag) + call cpu_clock_begin(id_clock_pres) + call PressureForce(h, tv, CS%PFu, CS%PFv, G, GV, US, CS%PressureForce_CSp, & + CS%ALE_CSp, CS%ADp, p_surf, CS%pbce, CS%eta_PF) + if (dyn_p_surf) then + pres_to_eta = 1.0 / (GV%g_Earth * GV%H_to_RZ) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta_PF_start(i,j) = CS%eta_PF(i,j) - pres_to_eta * (p_surf_begin(i,j) - p_surf_end(i,j)) + enddo ; enddo + endif + ! Stokes shear force contribution to pressure gradient + if (present(Waves)) then ; if (associated(Waves)) then ; if (Waves%Stokes_PGF) then + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call Stokes_PGF(G, GV, US, dz, u_av, v_av, CS%PFu_Stokes, CS%PFv_Stokes, Waves) + + ! We are adding Stokes_PGF to hydrostatic PGF here. The diag PFu/PFv + ! will therefore report the sum total PGF and we avoid other + ! modifications in the code. The PFu_Stokes is output within the waves routines. + if (.not.Waves%Passive_Stokes_PGF) then + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + CS%PFu(I,j,k) = CS%PFu(I,j,k) + CS%PFu_Stokes(I,j,k) + enddo ; enddo ; enddo + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + CS%PFv(i,J,k) = CS%PFv(i,J,k) + CS%PFv_Stokes(i,J,k) + enddo ; enddo ; enddo + endif + endif ; endif ; endif + call cpu_clock_end(id_clock_pres) + call disable_averaging(CS%diag) + if (showCallTree) call callTree_wayPoint("done with PressureForce (step_MOM_dyn_split_RK2b)") + + if (associated(CS%OBC)) then ; if (CS%OBC%update_OBC) then + call update_OBC_data(CS%OBC, G, GV, US, tv, h, CS%update_OBC_CSp, Time_local) + endif ; endif + if (associated(CS%OBC) .and. CS%debug_OBC) & + call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%PFu, CS%PFv) + + if (G%nonblocking_updates) then + call complete_group_pass(CS%pass_hp_uhvh, G%Domain, clock=id_clock_pass) + call start_group_pass(CS%pass_eta, G%Domain, clock=id_clock_pass) + else + call do_group_pass(CS%pass_hp_uhvh, G%Domain, clock=id_clock_pass) + endif + + !$OMP parallel do default(shared) + do k=1,nz ; do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil + h_av(i,j,k) = 0.5*(h(i,j,k) + hp(i,j,k)) + enddo ; enddo ; enddo + + ! Calculate a predictor-step estimate of the Coriolis and momentum advection terms + ! and horizontal viscous accelerations. + +! CAu = -(f+zeta_av)/h_av vh + d/dx KE_av + call cpu_clock_begin(id_clock_Cor) + call CorAdCalc(u_av, v_av, h_av, uh, vh, CS%CAu_pred, CS%CAv_pred, CS%OBC, CS%AD_pred, & + G, GV, US, CS%CoriolisAdv, pbv, Waves=Waves) + call cpu_clock_end(id_clock_Cor) + if (showCallTree) call callTree_wayPoint("done with predictor CorAdCalc (step_MOM_dyn_split_RK2b)") + +! diffu = horizontal viscosity terms (u_av) + call cpu_clock_begin(id_clock_horvisc) + call horizontal_viscosity(u_av, v_av, h_av, uh, vh, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, & + tv, dt, OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, ADp=CS%AD_pred) + call cpu_clock_end(id_clock_horvisc) + if (showCallTree) call callTree_wayPoint("done with predictor horizontal_viscosity (step_MOM_dyn_split_RK2b)") + +! u_bc_accel = CAu + PFu + diffu(u[n-1]) + call cpu_clock_begin(id_clock_btforce) + !$OMP parallel do default(shared) + do k=1,nz + do j=js,je ; do I=Isq,Ieq + u_bc_accel(I,j,k) = (CS%CAu_pred(I,j,k) + CS%PFu(I,j,k)) + CS%diffu(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + v_bc_accel(i,J,k) = (CS%CAv_pred(i,J,k) + CS%PFv(i,J,k)) + CS%diffv(i,J,k) + enddo ; enddo + enddo + if (associated(CS%OBC)) then + call open_boundary_zero_normal_flow(CS%OBC, G, GV, u_bc_accel, v_bc_accel) + endif + call cpu_clock_end(id_clock_btforce) + + if (CS%debug) then + call MOM_accel_chksum("pre-btstep accel", CS%CAu_pred, CS%CAv_pred, CS%PFu, CS%PFv, & + CS%diffu, CS%diffv, G, GV, US, CS%pbce, u_bc_accel, v_bc_accel, & + symmetric=sym) + if (debug_redundant) then + call check_redundant("pre-btstep CS%CA ", CS%CAu_pred, CS%CAv_pred, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) + endif + endif + + call cpu_clock_begin(id_clock_vertvisc) + !$OMP parallel do default(shared) + do k=1,nz + do j=js,je ; do I=Isq,Ieq + up(I,j,k) = G%mask2dCu(I,j) * (u_av(I,j,k) + dt * u_bc_accel(I,j,k)) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + vp(i,J,k) = G%mask2dCv(i,J) * (v_av(i,J,k) + dt * v_bc_accel(i,J,k)) + enddo ; enddo + enddo + + call enable_averages(dt, Time_local, CS%diag) + call set_viscous_ML(u_av, v_av, h, tv, forces, visc, dt, G, GV, US, CS%set_visc_CSp) + call disable_averaging(CS%diag) + + if (CS%debug) then + call uvchksum("before vertvisc: up", up, vp, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s) + endif + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(up, vp, h, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) + call cpu_clock_end(id_clock_vertvisc) + if (showCallTree) call callTree_wayPoint("done with vertvisc_coef (step_MOM_dyn_split_RK2b)") + + + call cpu_clock_begin(id_clock_pass) + if (G%nonblocking_updates) then + call complete_group_pass(CS%pass_eta, G%Domain) + call start_group_pass(CS%pass_visc_rem, G%Domain) + else + call do_group_pass(CS%pass_eta, G%Domain) + call do_group_pass(CS%pass_visc_rem, G%Domain) + endif + call cpu_clock_end(id_clock_pass) + + call cpu_clock_begin(id_clock_btcalc) + ! Calculate the relative layer weights for determining barotropic quantities. + if (.not.BT_cont_BT_thick) & + call btcalc(h, G, GV, CS%barotropic_CSp, OBC=CS%OBC) + call bt_mass_source(h, eta, .true., G, GV, CS%barotropic_CSp) + + SpV_avg(:,:) = 0.0 + if ((.not.GV%Boussinesq) .and. associated(CS%OBC)) then + ! Determine the column average specific volume if it is needed due to the + ! use of Flather open boundary conditions in non-Boussinesq mode. + if (open_boundary_query(CS%OBC, apply_Flather_OBC=.true.)) & + call find_col_avg_SpV(h, SpV_avg, tv, G, GV, US) + endif + call cpu_clock_end(id_clock_btcalc) + + if (G%nonblocking_updates) & + call complete_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass) + + ! Reconstruct u_inst and v_inst from u_av and v_av. + call cpu_clock_begin(id_clock_mom_update) + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + u_inst(I,j,k) = u_av(I,j,k) - CS%du_av_inst(I,j) * CS%visc_rem_u(I,j,k) + enddo ; enddo ; enddo + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + v_inst(i,J,k) = v_av(i,J,k) - CS%dv_av_inst(i,j) * CS%visc_rem_v(i,J,k) + enddo ; enddo ; enddo + call cpu_clock_end(id_clock_mom_update) + call do_group_pass(CS%pass_uv_inst, G%Domain, clock=id_clock_pass) + + if (associated(CS%OBC)) & + call copy_thickness_reservoirs(CS%OBC, G, GV) + +! u_accel_bt = layer accelerations due to barotropic solver + call cpu_clock_begin(id_clock_continuity) + call continuity(u_inst, v_inst, h, hp, uh_in, vh_in, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & + visc_rem_u=CS%visc_rem_u, visc_rem_v=CS%visc_rem_v, BT_cont=CS%BT_cont) + call cpu_clock_end(id_clock_continuity) + if (BT_cont_BT_thick) then + call btcalc(h, G, GV, CS%barotropic_CSp, CS%BT_cont%h_u, CS%BT_cont%h_v, & + OBC=CS%OBC) + endif + if (showCallTree) call callTree_wayPoint("done with continuity[BT_cont] (step_MOM_dyn_split_RK2b)") + + uh_ptr => uh_in ; vh_ptr => vh_in ; u_ptr => u_inst ; v_ptr => v_inst + + call cpu_clock_begin(id_clock_btstep) + if (calc_dtbt) then + if (CS%dtbt_use_bt_cont .and. associated(CS%BT_cont)) then + call set_dtbt(G, GV, US, CS%barotropic_CSp, CS%pbce, BT_cont=CS%BT_cont) + else + ! In the following call, eta is only used when NONLINEAR_BT_CONTINUITY is True. Otherwise, dtbt is effectively + ! calculated with eta=0. Note that NONLINEAR_BT_CONTINUITY is False if BT_CONT is used, which is the default. + call set_dtbt(G, GV, US, CS%barotropic_CSp, CS%pbce, eta=eta) + endif + endif + if (showCallTree) call callTree_enter("btstep(), MOM_barotropic.F90") + ! This is the predictor step call to btstep. + ! The CS%ADp argument here stores the weights for certain integrated diagnostics. + call btstep(u_inst, v_inst, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, CS%eta_PF, u_av, v_av, & + CS%u_accel_bt, CS%v_accel_bt, eta_pred, CS%uhbt, CS%vhbt, G, GV, US, & + CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, SpV_avg, CS%ADp, CS%OBC, CS%BT_cont, & + eta_PF_start, taux_bot, tauy_bot, uh_ptr, vh_ptr, u_ptr, v_ptr) + if (showCallTree) call callTree_leave("btstep()") + call cpu_clock_end(id_clock_btstep) + + dt_pred = dt * CS%be + call cpu_clock_begin(id_clock_mom_update) + +! up = u + dt_pred*( u_bc_accel + u_accel_bt ) + !$OMP parallel do default(shared) + do k=1,nz + do J=Jsq,Jeq ; do i=is,ie + vp(i,J,k) = G%mask2dCv(i,J) * (v_inst(i,J,k) + dt_pred * & + (v_bc_accel(i,J,k) + CS%v_accel_bt(i,J,k))) + enddo ; enddo + do j=js,je ; do I=Isq,Ieq + up(I,j,k) = G%mask2dCu(I,j) * (u_inst(I,j,k) + dt_pred * & + (u_bc_accel(I,j,k) + CS%u_accel_bt(I,j,k))) + enddo ; enddo + enddo + call cpu_clock_end(id_clock_mom_update) + + if (CS%debug) then + call uvchksum("Predictor 1 [uv]", up, vp, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s) + call hchksum(h, "Predictor 1 h", G%HI, haloshift=1, unscale=GV%H_to_MKS) + call uvchksum("Predictor 1 [uv]h", uh, vh, G%HI,haloshift=2, & + symmetric=sym, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) +! call MOM_state_chksum("Predictor 1", up, vp, h, uh, vh, G, GV, US, haloshift=1) + call MOM_accel_chksum("Predictor accel", CS%CAu_pred, CS%CAv_pred, CS%PFu, CS%PFv, & + CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, symmetric=sym) + call MOM_state_chksum("Predictor 1 init", u_inst, v_inst, h, uh, vh, G, GV, US, haloshift=1, & + symmetric=sym) + if (debug_redundant) then + call check_redundant("Predictor 1 up", up, vp, G, unscale=US%L_T_to_m_s) + call check_redundant("Predictor 1 uh", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif + endif + +! up <- up + dt_pred d/dz visc d/dz up +! u_av <- u_av + dt_pred d/dz visc d/dz u_av + call cpu_clock_begin(id_clock_vertvisc) + if (CS%debug) then + call uvchksum("0 before vertvisc: [uv]p", up, vp, G%HI,haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s) + endif + + ! if (CS%fpmix) then + ! uold(:,:,:) = 0.0 + ! vold(:,:,:) = 0.0 + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! uold(I,j,k) = up(I,j,k) + ! enddo ; enddo ; enddo + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! vold(i,J,k) = vp(i,J,k) + ! enddo ; enddo ; enddo + ! endif + + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(up, vp, h, dz, forces, visc, tv, dt_pred, G, GV, US, CS%vertvisc_CSp, & + CS%OBC, VarMix) + call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%AD_pred, CS%CDp, G, & + GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) + + ! if (CS%fpmix) then + ! hbl(:,:) = 0.0 + ! if (associated(visc%h_ML)) hbl(:,:) = visc%h_ML(:,:) + ! call vertFPmix(up, vp, uold, vold, hbl, h, forces, & + ! dt_pred, G, GV, US, CS%vertvisc_CSp, CS%OBC) + ! call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%ADp, CS%CDp, G, & + ! GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) + ! endif + + if (showCallTree) call callTree_wayPoint("done with vertvisc (step_MOM_dyn_split_RK2b)") + if (G%nonblocking_updates) then + call cpu_clock_end(id_clock_vertvisc) + 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_bug) then + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt_pred, G, GV, US, CS%vertvisc_CSp) + else + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) + endif + call cpu_clock_end(id_clock_vertvisc) + + call do_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass) + if (G%nonblocking_updates) then + call complete_group_pass(CS%pass_uvp, G%Domain, clock=id_clock_pass) + else + call do_group_pass(CS%pass_uvp, G%Domain, clock=id_clock_pass) + endif + + ! uh = u_av * h + ! hp = h + dt * div . uh + call cpu_clock_begin(id_clock_continuity) + call continuity(up, vp, h, hp, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & + CS%uhbt, CS%vhbt, CS%visc_rem_u, CS%visc_rem_v, & + u_av, v_av, BT_cont=CS%BT_cont) + call cpu_clock_end(id_clock_continuity) + if (showCallTree) call callTree_wayPoint("done with continuity (step_MOM_dyn_split_RK2b)") + + call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass) + + if (associated(CS%OBC)) then + + if (CS%debug) & + call uvchksum("Pre OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s) + + call radiation_open_bdry_conds(CS%OBC, u_av, u_old_rad_OBC, v_av, v_old_rad_OBC, G, GV, US, dt_pred) + + if (CS%debug) & + call uvchksum("Post OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s) + endif + + ! h_av = (h + hp)/2 + !$OMP parallel do default(shared) + do k=1,nz ; do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil + h_av(i,j,k) = 0.5*(h(i,j,k) + hp(i,j,k)) + enddo ; enddo ; enddo + + ! The correction phase of the time step starts here. + call enable_averages(dt, Time_local, CS%diag) + + ! Calculate a revised estimate of the free-surface height correction to be + ! used in the next call to btstep. This call is at this point so that + ! hp can be changed if CS%begw /= 0. + ! eta_cor = ... (hidden inside CS%barotropic_CSp) + if (CS%BT_adj_corr_mass_src) then + call cpu_clock_begin(id_clock_btcalc) + call bt_mass_source(hp, eta_pred, .false., G, GV, CS%barotropic_CSp) + call cpu_clock_end(id_clock_btcalc) + endif + + if (CS%begw /= 0.0) then + ! hp <- (1-begw)*h_in + begw*hp + ! Back up hp to the value it would have had after a time-step of + ! begw*dt. hp is not used again until recalculated by continuity. + !$OMP parallel do default(shared) + do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + hp(i,j,k) = (1.0-CS%begw)*h(i,j,k) + CS%begw*hp(i,j,k) + enddo ; enddo ; enddo + + ! PFu = d/dx M(hp,T,S) + ! pbce = dM/deta + call cpu_clock_begin(id_clock_pres) + call PressureForce(hp, tv, CS%PFu, CS%PFv, G, GV, US, CS%PressureForce_CSp, & + CS%ALE_CSp, CS%ADp, p_surf, CS%pbce, CS%eta_PF) + ! Stokes shear force contribution to pressure gradient + if (present(Waves)) then ; if (associated(Waves)) then ; if (Waves%Stokes_PGF) then + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call Stokes_PGF(G, GV, US, dz, u_av, v_av, CS%PFu_Stokes, CS%PFv_Stokes, Waves) + if (.not.Waves%Passive_Stokes_PGF) then + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + CS%PFu(I,j,k) = CS%PFu(I,j,k) + CS%PFu_Stokes(I,j,k) + enddo ; enddo ; enddo + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + CS%PFv(i,J,k) = CS%PFv(i,J,k) + CS%PFv_Stokes(i,J,k) + enddo ; enddo ; enddo + endif + endif ; endif ; endif + call cpu_clock_end(id_clock_pres) + if (showCallTree) call callTree_wayPoint("done with PressureForce[hp=(1-b).h+b.h] (step_MOM_dyn_split_RK2b)") + endif + + if (BT_cont_BT_thick) then + call btcalc(h, G, GV, CS%barotropic_CSp, CS%BT_cont%h_u, CS%BT_cont%h_v, & + OBC=CS%OBC) + if (showCallTree) call callTree_wayPoint("done with btcalc[BT_cont_BT_thick] (step_MOM_dyn_split_RK2b)") + endif + + if (CS%debug) then + call MOM_state_chksum("Predictor ", up, vp, hp, uh, vh, G, GV, US, symmetric=sym) + call uvchksum("Predictor avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, unscale=US%L_T_to_m_s) + call hchksum(h_av, "Predictor avg h", G%HI, haloshift=2, unscale=GV%H_to_MKS) + ! call MOM_state_chksum("Predictor avg ", u_av, v_av, h_av, uh, vh, G, GV, US) + if (debug_redundant) then + call check_redundant("Predictor up ", up, vp, G, unscale=US%L_T_to_m_s) + call check_redundant("Predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif + endif + +! diffu = horizontal viscosity terms (u_av) + call cpu_clock_begin(id_clock_horvisc) + call horizontal_viscosity(u_av, v_av, h_av, uh, vh, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, & + tv, dt, OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, ADp=CS%ADp) + call cpu_clock_end(id_clock_horvisc) + if (showCallTree) call callTree_wayPoint("done with horizontal_viscosity (step_MOM_dyn_split_RK2b)") + +! CAu = -(f+zeta_av)/h_av vh + d/dx KE_av + call cpu_clock_begin(id_clock_Cor) + call CorAdCalc(u_av, v_av, h_av, uh, vh, CS%CAu, CS%CAv, CS%OBC, CS%ADp, & + G, GV, US, CS%CoriolisAdv, pbv, Waves=Waves) + call cpu_clock_end(id_clock_Cor) + if (showCallTree) call callTree_wayPoint("done with CorAdCalc (step_MOM_dyn_split_RK2b)") + +! Calculate the momentum forcing terms for the barotropic equations. + +! u_bc_accel = CAu + PFu + diffu(u[n-1]) + call cpu_clock_begin(id_clock_btforce) + !$OMP parallel do default(shared) + do k=1,nz + do j=js,je ; do I=Isq,Ieq + u_bc_accel(I,j,k) = (CS%Cau(I,j,k) + CS%PFu(I,j,k)) + CS%diffu(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + v_bc_accel(i,J,k) = (CS%Cav(i,J,k) + CS%PFv(i,J,k)) + CS%diffv(i,J,k) + enddo ; enddo + enddo + if (associated(CS%OBC)) then + call open_boundary_zero_normal_flow(CS%OBC, G, GV, u_bc_accel, v_bc_accel) + endif + call cpu_clock_end(id_clock_btforce) + + if (CS%debug) then + call MOM_accel_chksum("corr pre-btstep accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & + CS%diffu, CS%diffv, G, GV, US, CS%pbce, u_bc_accel, v_bc_accel, & + symmetric=sym) + if (debug_redundant) then + call check_redundant("corr pre-btstep CS%CA ", CS%CAu, CS%CAv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) + endif + endif + + ! u_accel_bt = layer accelerations due to barotropic solver + ! pbce = dM/deta + call cpu_clock_begin(id_clock_btstep) + + uh_ptr => uh ; vh_ptr => vh ; u_ptr => u_av ; v_ptr => v_av + + if (showCallTree) call callTree_enter("btstep(), MOM_barotropic.F90") + ! This is the corrector step call to btstep. + call btstep(u_inst, v_inst, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, CS%eta_PF, u_av, v_av, & + CS%u_accel_bt, CS%v_accel_bt, eta_pred, CS%uhbt, CS%vhbt, G, GV, US, & + CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, SpV_avg, CS%ADp, CS%OBC, CS%BT_cont, & + eta_PF_start, taux_bot, tauy_bot, uh_ptr, vh_ptr, u_ptr, v_ptr, etaav=eta_av) + if (CS%id_deta_dt>0) then + do j=js,je ; do i=is,ie ; deta_dt(i,j) = (eta_pred(i,j) - eta(i,j))*Idt_bc ; enddo ; enddo + endif + do j=js,je ; do i=is,ie ; eta(i,j) = eta_pred(i,j) ; enddo ; enddo + + call cpu_clock_end(id_clock_btstep) + if (showCallTree) call callTree_leave("btstep()") + + if (CS%debug .and. debug_redundant) then + call check_redundant("u_accel_bt ", CS%u_accel_bt, CS%v_accel_bt, G, unscale=US%L_T2_to_m_s2) + endif + + ! u = u + dt*( u_bc_accel + u_accel_bt ) + call cpu_clock_begin(id_clock_mom_update) + !$OMP parallel do default(shared) + do k=1,nz + do j=js,je ; do I=Isq,Ieq + u_inst(I,j,k) = G%mask2dCu(I,j) * (u_inst(I,j,k) + dt * & + (u_bc_accel(I,j,k) + CS%u_accel_bt(I,j,k))) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + v_inst(i,J,k) = G%mask2dCv(i,J) * (v_inst(i,J,k) + dt * & + (v_bc_accel(i,J,k) + CS%v_accel_bt(i,J,k))) + enddo ; enddo + enddo + call cpu_clock_end(id_clock_mom_update) + + if (CS%debug) then + call uvchksum("Corrector 1 [uv]", u_inst, v_inst, G%HI, haloshift=0, symmetric=sym, unscale=US%L_T_to_m_s) + call hchksum(h, "Corrector 1 h", G%HI, haloshift=1, unscale=GV%H_to_MKS) + call uvchksum("Corrector 1 [uv]h", uh, vh, G%HI, haloshift=2, & + symmetric=sym, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + ! call MOM_state_chksum("Corrector 1", u_inst, v_inst, h, uh, vh, G, GV, US, haloshift=1) + call MOM_accel_chksum("Corrector accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & + CS%diffu, CS%diffv, G, GV, US, CS%pbce, CS%u_accel_bt, CS%v_accel_bt, & + symmetric=sym) + endif + + ! u <- u + dt d/dz visc d/dz u + ! u_av <- u_av + dt d/dz visc d/dz u_av + call cpu_clock_begin(id_clock_vertvisc) + + ! if (CS%fpmix) then + ! uold(:,:,:) = 0.0 + ! vold(:,:,:) = 0.0 + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! uold(I,j,k) = u_inst(I,j,k) + ! enddo ; enddo ; enddo + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! vold(i,J,k) = v_inst(i,J,k) + ! enddo ; enddo ; enddo + ! endif + + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(u_inst, v_inst, h, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call vertvisc(u_inst, v_inst, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & + CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) + + ! if (CS%fpmix) then + ! call vertFPmix(u_inst, v_inst, uold, vold, hbl, h, forces, dt, & + ! G, GV, US, CS%vertvisc_CSp, CS%OBC) + ! call vertvisc(u_inst, v_inst, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & + ! CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) + ! endif + + if (G%nonblocking_updates) then + call cpu_clock_end(id_clock_vertvisc) + call start_group_pass(CS%pass_uv_inst, G%Domain, clock=id_clock_pass) + call cpu_clock_begin(id_clock_vertvisc) + endif + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) + call cpu_clock_end(id_clock_vertvisc) + if (showCallTree) call callTree_wayPoint("done with vertvisc (step_MOM_dyn_split_RK2b)") + + call do_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass) + if (G%nonblocking_updates) then + call complete_group_pass(CS%pass_uv_inst, G%Domain, clock=id_clock_pass) + else + call do_group_pass(CS%pass_uv_inst, G%Domain, clock=id_clock_pass) + endif + + ! uh = u_av * h + ! h = h + dt * div . uh + ! u_av and v_av adjusted so their mass transports match uhbt and vhbt. + call cpu_clock_begin(id_clock_continuity) + + call continuity(u_inst, v_inst, h, h, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & + CS%uhbt, CS%vhbt, CS%visc_rem_u, CS%visc_rem_v, u_av, v_av, & + du_cor=CS%du_av_inst, dv_cor=CS%dv_av_inst) + + ! This tests the ability to readjust the instantaneous velocity, and here it changes answers only at roundoff. + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! u_inst(I,j,k) = u_av(I,j,k) - CS%du_av_inst(I,j) * CS%visc_rem_u(I,j,k) + ! enddo ; enddo ; enddo + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! v_inst(i,J,k) = v_av(i,J,k) - CS%dv_av_inst(i,J) * CS%visc_rem_v(i,J,k) + ! enddo ; enddo ; enddo + + call cpu_clock_end(id_clock_continuity) + + call do_group_pass(CS%pass_h_uv, G%Domain, clock=id_clock_pass) + + ! Whenever thickness changes let the diag manager know, target grids + ! for vertical remapping may need to be regenerated. + call diag_update_remap_grids(CS%diag) + if (showCallTree) call callTree_wayPoint("done with continuity (step_MOM_dyn_split_RK2b)") + + if (associated(CS%OBC)) then + call radiation_open_bdry_conds(CS%OBC, u_av, u_old_rad_OBC, v_av, v_old_rad_OBC, G, GV, US, dt) + endif + + !$OMP parallel do default(shared) + do k=1,nz + do j=js-2,je+2 ; do I=Isq-2,Ieq+2 + uhtr(I,j,k) = uhtr(I,j,k) + uh(I,j,k)*dt + enddo ; enddo + do J=Jsq-2,Jeq+2 ; do i=is-2,ie+2 + vhtr(i,J,k) = vhtr(i,J,k) + vh(i,J,k)*dt + enddo ; enddo + enddo + + if (associated(CS%OBC)) then + call update_segment_thickness_reservoirs(G, GV, uhtr, vhtr, h, CS%OBC) + endif + + ! if (CS%fpmix) then + ! if (CS%id_uold > 0) call post_data(CS%id_uold, uold, CS%diag) + ! if (CS%id_vold > 0) call post_data(CS%id_vold, vold, CS%diag) + ! endif + + ! The time-averaged free surface height has already been set by the last call to btstep. + + ! Deallocate this memory to avoid a memory leak. ### We should revisit how this array is declared. -RWH + if (dyn_p_surf .and. associated(eta_PF_start)) deallocate(eta_PF_start) + + ! Here various terms used in to update the momentum equations are + ! offered for time averaging. + if (CS%id_PFu > 0) call post_data(CS%id_PFu, CS%PFu, CS%diag) + if (CS%id_PFv > 0) call post_data(CS%id_PFv, CS%PFv, CS%diag) + if (CS%id_CAu > 0) call post_data(CS%id_CAu, CS%CAu, CS%diag) + if (CS%id_CAv > 0) call post_data(CS%id_CAv, CS%CAv, CS%diag) + + ! Here the thickness fluxes are offered for time averaging. + if (CS%id_uh > 0) call post_data(CS%id_uh, uh, CS%diag) + if (CS%id_vh > 0) call post_data(CS%id_vh, vh, CS%diag) + if (CS%id_uav > 0) call post_data(CS%id_uav, u_av, CS%diag) + if (CS%id_vav > 0) call post_data(CS%id_vav, v_av, CS%diag) + if (CS%id_u_BT_accel > 0) call post_data(CS%id_u_BT_accel, CS%u_accel_bt, CS%diag) + if (CS%id_v_BT_accel > 0) call post_data(CS%id_v_BT_accel, CS%v_accel_bt, CS%diag) + + ! Calculate effective areas and post data + if (CS%id_ueffA > 0) then + ueffA(:,:,:) = 0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + if (abs(u_av(I,j,k)) > 0.) ueffA(I,j,k) = uh(I,j,k) / u_av(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_ueffA, ueffA, CS%diag) + endif + + if (CS%id_veffA > 0) then + veffA(:,:,:) = 0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + if (abs(v_av(i,J,k)) > 0.) veffA(i,J,k) = vh(i,J,k) / v_av(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_veffA, veffA, CS%diag) + endif + + ! Diagnostics of the fractional thicknesses times momentum budget terms + ! 3D diagnostics hf_PFu etc. are commented because there is no clarity on proper remapping grid option. + ! The code is retained for debugging purposes in the future. + !if (CS%id_hf_PFu > 0) call post_product_u(CS%id_hf_PFu, CS%PFu, CS%ADp%diag_hfrac_u, G, nz, CS%diag) + !if (CS%id_hf_PFv > 0) call post_product_v(CS%id_hf_PFv, CS%PFv, CS%ADp%diag_hfrac_v, G, nz, CS%diag) + !if (CS%id_hf_CAu > 0) call post_product_u(CS%id_hf_CAu, CS%CAu, CS%ADp%diag_hfrac_u, G, nz, CS%diag) + !if (CS%id_hf_CAv > 0) call post_product_v(CS%id_hf_CAv, CS%CAv, CS%ADp%diag_hfrac_v, G, nz, CS%diag) + !if (CS%id_hf_u_BT_accel > 0) & + ! call post_product_u(CS%id_hf_u_BT_accel, CS%u_accel_bt, CS%ADp%diag_hfrac_u, G, nz, CS%diag) + !if (CS%id_hf_v_BT_accel > 0) & + ! call post_product_v(CS%id_hf_v_BT_accel, CS%v_accel_bt, CS%ADp%diag_hfrac_v, G, nz, CS%diag) + + ! Diagnostics for the vertical sum of layer thickness x prssure force accelerations + if (CS%id_intz_PFu_2d > 0) call post_product_sum_u(CS%id_intz_PFu_2d, CS%PFu, CS%ADp%diag_hu, G, nz, CS%diag) + if (CS%id_intz_PFv_2d > 0) call post_product_sum_v(CS%id_intz_PFv_2d, CS%PFv, CS%ADp%diag_hv, G, nz, CS%diag) + + ! Diagnostics for thickness-weighted vertically averaged prssure force accelerations + if (CS%id_hf_PFu_2d > 0) call post_product_sum_u(CS%id_hf_PFu_2d, CS%PFu, CS%ADp%diag_hfrac_u, G, nz, CS%diag) + if (CS%id_hf_PFv_2d > 0) call post_product_sum_v(CS%id_hf_PFv_2d, CS%PFv, CS%ADp%diag_hfrac_v, G, nz, CS%diag) + + ! Diagnostics for thickness x prssure force accelerations + if (CS%id_h_PFu > 0) call post_product_u(CS%id_h_PFu, CS%PFu, CS%ADp%diag_hu, G, nz, CS%diag) + if (CS%id_h_PFv > 0) call post_product_v(CS%id_h_PFv, CS%PFv, CS%ADp%diag_hv, G, nz, CS%diag) + + ! Diagnostics of Coriolis acceleratations + if (CS%id_intz_CAu_2d > 0) call post_product_sum_u(CS%id_intz_CAu_2d, CS%CAu, CS%ADp%diag_hu, G, nz, CS%diag) + if (CS%id_intz_CAv_2d > 0) call post_product_sum_v(CS%id_intz_CAv_2d, CS%CAv, CS%ADp%diag_hv, G, nz, CS%diag) + if (CS%id_hf_CAu_2d > 0) call post_product_sum_u(CS%id_hf_CAu_2d, CS%CAu, CS%ADp%diag_hfrac_u, G, nz, CS%diag) + if (CS%id_hf_CAv_2d > 0) call post_product_sum_v(CS%id_hf_CAv_2d, CS%CAv, CS%ADp%diag_hfrac_v, G, nz, CS%diag) + if (CS%id_h_CAu > 0) call post_product_u(CS%id_h_CAu, CS%CAu, CS%ADp%diag_hu, G, nz, CS%diag) + if (CS%id_h_CAv > 0) call post_product_v(CS%id_h_CAv, CS%CAv, CS%ADp%diag_hv, G, nz, CS%diag) + + ! Diagnostics of barotropic solver acceleratations + if (CS%id_intz_u_BT_accel_2d > 0) & + call post_product_sum_u(CS%id_intz_u_BT_accel_2d, CS%u_accel_bt, CS%ADp%diag_hu, G, nz, CS%diag) + if (CS%id_intz_v_BT_accel_2d > 0) & + call post_product_sum_v(CS%id_intz_v_BT_accel_2d, CS%v_accel_bt, CS%ADp%diag_hv, G, nz, CS%diag) + if (CS%id_hf_u_BT_accel_2d > 0) & + call post_product_sum_u(CS%id_hf_u_BT_accel_2d, CS%u_accel_bt, CS%ADp%diag_hfrac_u, G, nz, CS%diag) + if (CS%id_hf_v_BT_accel_2d > 0) & + call post_product_sum_v(CS%id_hf_v_BT_accel_2d, CS%v_accel_bt, CS%ADp%diag_hfrac_v, G, nz, CS%diag) + if (CS%id_h_u_BT_accel > 0) & + call post_product_u(CS%id_h_u_BT_accel, CS%u_accel_bt, CS%ADp%diag_hu, G, nz, CS%diag) + if (CS%id_h_v_BT_accel > 0) & + call post_product_v(CS%id_h_v_BT_accel, CS%v_accel_bt, CS%ADp%diag_hv, G, nz, CS%diag) + + ! Diagnostics for momentum budget terms multiplied by visc_rem_[uv], + if (CS%id_PFu_visc_rem > 0) call post_product_u(CS%id_PFu_visc_rem, CS%PFu, CS%ADp%visc_rem_u, G, nz, CS%diag) + if (CS%id_PFv_visc_rem > 0) call post_product_v(CS%id_PFv_visc_rem, CS%PFv, CS%ADp%visc_rem_v, G, nz, CS%diag) + if (CS%id_CAu_visc_rem > 0) call post_product_u(CS%id_CAu_visc_rem, CS%CAu, CS%ADp%visc_rem_u, G, nz, CS%diag) + if (CS%id_CAv_visc_rem > 0) call post_product_v(CS%id_CAv_visc_rem, CS%CAv, CS%ADp%visc_rem_v, G, nz, CS%diag) + if (CS%id_u_BT_accel_visc_rem > 0) & + call post_product_u(CS%id_u_BT_accel_visc_rem, CS%u_accel_bt, CS%ADp%visc_rem_u, G, nz, CS%diag) + if (CS%id_v_BT_accel_visc_rem > 0) & + call post_product_v(CS%id_v_BT_accel_visc_rem, CS%v_accel_bt, CS%ADp%visc_rem_v, G, nz, CS%diag) + + ! Diagnostics related to changes in eta + if (CS%id_deta_dt > 0) call post_data(CS%id_deta_dt, deta_dt, CS%diag) + + if (CS%debug) then + call MOM_state_chksum("Corrector ", u_av, v_av, h, uh, vh, G, GV, US, symmetric=sym) + ! call uvchksum("Corrector inst [uv]", u_inst, v_inst, G%HI, symmetric=sym, unscale=US%L_T_to_m_s) + endif + + if (showCallTree) call callTree_leave("step_MOM_dyn_split_RK2b()") + +end subroutine step_MOM_dyn_split_RK2b + +!> This subroutine sets up any auxiliary restart variables that are specific +!! to the split-explicit time stepping scheme. All variables registered here should +!! have the ability to be recreated if they are not present in a restart file. +subroutine register_restarts_dyn_split_RK2b(HI, GV, US, param_file, CS, restart_CS, uh, vh) + type(hor_index_type), intent(in) :: HI !< Horizontal index structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< parameter file + type(MOM_dyn_split_RK2b_CS), pointer :: CS !< module control structure + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure + real, dimension(SZIB_(HI),SZJ_(HI),SZK_(GV)), & + target, intent(inout) :: uh !< zonal volume or mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(HI),SZJB_(HI),SZK_(GV)), & + target, intent(inout) :: vh !< merid volume or mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] + + type(vardesc) :: vd(2) + character(len=48) :: thickness_units, flux_units + + integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB + + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + IsdB = HI%IsdB ; IedB = HI%IedB ; JsdB = HI%JsdB ; JedB = HI%JedB + + ! This is where a control structure specific to this module would be allocated. + if (associated(CS)) then + call MOM_error(WARNING, "register_restarts_dyn_split_RK2b called with an associated "// & + "control structure.") + return + endif + allocate(CS) + + ALLOC_(CS%diffu(IsdB:IedB,jsd:jed,nz)) ; CS%diffu(:,:,:) = 0.0 + ALLOC_(CS%diffv(isd:ied,JsdB:JedB,nz)) ; CS%diffv(:,:,:) = 0.0 + ALLOC_(CS%CAu(IsdB:IedB,jsd:jed,nz)) ; CS%CAu(:,:,:) = 0.0 + ALLOC_(CS%CAv(isd:ied,JsdB:JedB,nz)) ; CS%CAv(:,:,:) = 0.0 + ALLOC_(CS%CAu_pred(IsdB:IedB,jsd:jed,nz)) ; CS%CAu_pred(:,:,:) = 0.0 + ALLOC_(CS%CAv_pred(isd:ied,JsdB:JedB,nz)) ; CS%CAv_pred(:,:,:) = 0.0 + ALLOC_(CS%PFu(IsdB:IedB,jsd:jed,nz)) ; CS%PFu(:,:,:) = 0.0 + ALLOC_(CS%PFv(isd:ied,JsdB:JedB,nz)) ; CS%PFv(:,:,:) = 0.0 + ALLOC_(CS%du_av_inst(IsdB:IedB,jsd:jed)) ; CS%du_av_inst(:,:) = 0.0 + ALLOC_(CS%dv_av_inst(isd:ied,JsdB:JedB)) ; CS%dv_av_inst(:,:) = 0.0 + + ALLOC_(CS%eta(isd:ied,jsd:jed)) ; CS%eta(:,:) = 0.0 + + thickness_units = get_thickness_units(GV) + flux_units = get_flux_units(GV) + + if (GV%Boussinesq) then + call register_restart_field(CS%eta, "sfc", .false., restart_CS, & + longname="Free surface Height", units=thickness_units, conversion=GV%H_to_mks) + else + call register_restart_field(CS%eta, "p_bot", .false., restart_CS, & + longname="Bottom Pressure", units=thickness_units, conversion=GV%H_to_mks) + endif + + ! These are needed to reconstruct the phase in the barotorpic solution. + vd(1) = var_desc("du_avg_inst", "m s-1", & + "Barotropic velocity increment between instantaneous and filtered zonal velocities", 'u', '1') + vd(2) = var_desc("dv_avg_inst", "m s-1", & + "Barotropic velocity increment between instantaneous and filtered meridional velocities", 'v', '1') + call register_restart_pair(CS%du_av_inst, CS%dv_av_inst, vd(1), vd(2), .false., restart_CS, & + conversion=US%L_T_to_m_s) + + call register_barotropic_restarts(HI, GV, US, param_file, CS%barotropic_CSp, restart_CS) + +end subroutine register_restarts_dyn_split_RK2b + +!> This subroutine does remapping for the auxiliary restart variables that are used +!! with the split RK2 time stepping scheme. +subroutine remap_dyn_split_RK2b_aux_vars(G, GV, CS, h_old_u, h_old_v, h_new_u, h_new_v, ALE_CSp) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(MOM_dyn_split_RK2b_CS), pointer :: CS !< module control structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old_u !< Source grid thickness at zonal + !! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: h_old_v !< Source grid thickness at meridional + !! velocity points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new_u !< Destination grid thickness at zonal + !! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: h_new_v !< Destination grid thickness at meridional + !! velocity points [H ~> m or kg m-2] + type(ALE_CS), pointer :: ALE_CSp !< ALE control structure to use when remapping + + return + +end subroutine remap_dyn_split_RK2b_aux_vars + +!> This subroutine initializes all of the variables that are used by this +!! dynamic core, including diagnostics and the cpu clocks. +subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, param_file, & + diag, CS, HA_CSp, restart_CS, dt, Accel_diag, Cont_diag, MIS, & + VarMix, MEKE, thickness_diffuse_CSp, & + OBC, update_OBC_CSp, ALE_CSp, set_visc, & + visc, dirs, ntrunc, pbv, calc_dtbt, cont_stencil, dyn_h_stencil) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: v !< merid velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + target, intent(inout) :: uh !< zonal volume/mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + target, intent(inout) :: vh !< merid volume/mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: eta !< free surface height or column mass [H ~> m or kg m-2] + type(time_type), target, intent(in) :: Time !< current model time + type(param_file_type), intent(in) :: param_file !< parameter file for parsing + type(diag_ctrl), target, intent(inout) :: diag !< to control diagnostics + type(MOM_dyn_split_RK2b_CS), pointer :: CS !< module control structure + type(harmonic_analysis_CS), pointer :: HA_CSp !< A pointer to the control structure of the + !! harmonic analysis module + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure + real, intent(in) :: dt !< time step [T ~> s] + type(accel_diag_ptrs), target, intent(inout) :: Accel_diag !< points to momentum equation terms for + !! budget analysis + type(cont_diag_ptrs), target, intent(inout) :: Cont_diag !< points to terms in continuity equation + type(ocean_internal_state), intent(inout) :: MIS !< "MOM6 internal state" used to pass + !! diagnostic pointers + type(VarMix_CS), intent(inout) :: VarMix !< points to spatially variable viscosities + type(MEKE_type), intent(inout) :: MEKE !< MEKE fields + type(thickness_diffuse_CS), intent(inout) :: thickness_diffuse_CSp !< Pointer to the control structure + !! used for the isopycnal height diffusive transport. + type(ocean_OBC_type), pointer :: OBC !< points to OBC related fields + type(update_OBC_CS), pointer :: update_OBC_CSp !< points to OBC update related fields + type(ALE_CS), pointer :: ALE_CSp !< points to ALE control structure + type(set_visc_CS), target, intent(in) :: set_visc !< set_visc control structure + type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, bottom drag, and related + type(directories), intent(in) :: dirs !< contains directory paths + integer, target, intent(inout) :: ntrunc !< A target for the variable that records + !! the number of times the velocity is + !! truncated (this should be 0). + logical, intent(out) :: calc_dtbt !< If true, recalculate the barotropic time step + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + integer, intent(out) :: cont_stencil !< The stencil for thickness + !! from the continuity solver. + integer, intent(out) :: dyn_h_stencil !< The stencil for thickness for the + !! dynamics based on the continuity + !! solver and Coriolis scheme. + + ! local variables + character(len=40) :: mdl = "MOM_dynamics_split_RK2b" ! This module's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=48) :: thickness_units, flux_units, eta_rest_name + logical :: debug_truncations + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. + logical :: visc_rem_bug ! Stores the value of runtime paramter VISC_REM_BUG. + + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz + integer :: IsdB, IedB, JsdB, JedB + integer :: nc ! Number of tidal constituents to be harmonically analyzed + 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 + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (.not.associated(CS)) call MOM_error(FATAL, & + "initialize_dyn_split_RK2b called with an unassociated control structure.") + if (CS%module_is_initialized) then + call MOM_error(WARNING, "initialize_dyn_split_RK2b called with a control "// & + "structure that has already been initialized.") + return + endif + CS%module_is_initialized = .true. + + CS%diag => diag + + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "TIDES", CS%use_tides, & + "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=CS%use_tides) + call get_param(param_file, mdl, "USE_HA", CS%use_HA, & + "If true, perform inline harmonic analysis.", default=.false.) + call get_param(param_file, mdl, "HA_N_CONST", nc, & + "Number of tidal constituents to be harmonically analyzed.", & + default=0, do_not_log=.not.CS%use_HA) + if (nc<=0) CS%use_HA = .false. + call get_param(param_file, mdl, "BE", CS%be, & + "If SPLIT is true, BE determines the relative weighting "//& + "of a 2nd-order Runga-Kutta baroclinic time stepping "//& + "scheme (0.5) and a backward Euler scheme (1) that is "//& + "used for the Coriolis and inertial terms. BE may be "//& + "from 0.5 to 1, but instability may occur near 0.5. "//& + "BE is also applicable if SPLIT is false and USE_RK2 "//& + "is true.", units="nondim", default=0.6) + call get_param(param_file, mdl, "BEGW", CS%begw, & + "If SPLIT is true, BEGW is a number from 0 to 1 that "//& + "controls the extent to which the treatment of gravity "//& + "waves is forward-backward (0) or simulated backward "//& + "Euler (1). 0 is almost always used. "//& + "If SPLIT is false and USE_RK2 is true, BEGW can be "//& + "between 0 and 0.5 to damp gravity waves.", & + units="nondim", default=0.0) + call get_param(param_file, mdl, "SET_DTBT_USE_BT_CONT", CS%dtbt_use_bt_cont, & + "If true, use BT_CONT to calculate DTBT if possible.", default=.false.) + call get_param(param_file, mdl, "SPLIT_BOTTOM_STRESS", CS%split_bottom_stress, & + "If true, provide the bottom stress calculated by the "//& + "vertical viscosity to the barotropic solver.", default=.false.) + call get_param(param_file, mdl, "BT_ADJ_CORR_MASS_SRC", CS%BT_adj_corr_mass_src, & + "If true, recalculates the barotropic mass source after "//& + "predictor step. This should make little difference in the "//& + "deep ocean but appears to help for vanished layers. If false, "//& + "uses the same mass source as from the predictor step.", default=.true.) + ! call get_param(param_file, mdl, "FPMIX", CS%fpmix, & + ! "If true, apply profiles of momentum flux magnitude and direction.", & + ! default=.false.) + CS%fpmix = .false. + call get_param(param_file, mdl, "REMAP_AUXILIARY_VARS", CS%remap_aux, & + "If true, apply ALE remapping to all of the auxiliary 3-dimensional "//& + "variables that are needed to reproduce across restarts, similarly to "//& + "what is already being done with the primary state variables. "//& + "The default should be changed to true.", default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + call get_param(param_file, mdl, "OBC_DEBUGGING_TESTS", CS%debug_OBC, & + "If true, do additional calls resetting certain values to help verify the "//& + "correctness of the open boundary condition code.", & + default=.false., old_name="DEBUG_OBC", debuggingParam=.true., do_not_log=.true.) + call get_param(param_file, mdl, "DEBUG_TRUNCATIONS", debug_truncations, & + default=.false.) + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. + call get_param(param_file, mdl, "VISC_REM_BUG", visc_rem_bug, & + "If true, visc_rem_[uv] in split mode is incorrectly calculated or accounted "//& + "for in two places. This parameter controls the defaults of two individual "//& + "flags, VISC_REM_TIMESTEP_BUG in MOM_dynamics_split_RK2(b) and "//& + "VISC_REM_BT_WEIGHT_BUG in MOM_barotropic.", default=.false.) + 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) + + ALLOC_(CS%uhbt(IsdB:IedB,jsd:jed)) ; CS%uhbt(:,:) = 0.0 + ALLOC_(CS%vhbt(isd:ied,JsdB:JedB)) ; CS%vhbt(:,:) = 0.0 + ALLOC_(CS%visc_rem_u(IsdB:IedB,jsd:jed,nz)) ; CS%visc_rem_u(:,:,:) = 0.0 + ALLOC_(CS%visc_rem_v(isd:ied,JsdB:JedB,nz)) ; CS%visc_rem_v(:,:,:) = 0.0 + ALLOC_(CS%eta_PF(isd:ied,jsd:jed)) ; CS%eta_PF(:,:) = 0.0 + ALLOC_(CS%pbce(isd:ied,jsd:jed,nz)) ; CS%pbce(:,:,:) = 0.0 + + ALLOC_(CS%u_accel_bt(IsdB:IedB,jsd:jed,nz)) ; CS%u_accel_bt(:,:,:) = 0.0 + ALLOC_(CS%v_accel_bt(isd:ied,JsdB:JedB,nz)) ; CS%v_accel_bt(:,:,:) = 0.0 + ALLOC_(CS%PFu_Stokes(IsdB:IedB,jsd:jed,nz)) ; CS%PFu_Stokes(:,:,:) = 0.0 + ALLOC_(CS%PFv_Stokes(isd:ied,JsdB:JedB,nz)) ; CS%PFv_Stokes(:,:,:) = 0.0 + + MIS%diffu => CS%diffu + MIS%diffv => CS%diffv + MIS%PFu => CS%PFu + MIS%PFv => CS%PFv + MIS%CAu => CS%CAu + MIS%CAv => CS%CAv + MIS%pbce => CS%pbce + MIS%u_accel_bt => CS%u_accel_bt + MIS%v_accel_bt => CS%v_accel_bt + + CS%ADp => Accel_diag + CS%CDp => Cont_diag + Accel_diag%diffu => CS%diffu + Accel_diag%diffv => CS%diffv + Accel_diag%PFu => CS%PFu + Accel_diag%PFv => CS%PFv + Accel_diag%CAu => CS%CAu + Accel_diag%CAv => CS%CAv + Accel_diag%u_accel_bt => CS%u_accel_bt + Accel_diag%v_accel_bt => CS%v_accel_bt + + allocate(CS%AD_pred) + CS%AD_pred%diffu => CS%diffu + CS%AD_pred%diffv => CS%diffv + CS%AD_pred%PFu => CS%PFu + CS%AD_pred%PFv => CS%PFv + CS%AD_pred%CAu => CS%CAu_pred + CS%AD_pred%CAv => CS%CAv_pred + CS%AD_pred%u_accel_bt => CS%u_accel_bt + CS%AD_pred%v_accel_bt => CS%v_accel_bt + +! Accel_diag%pbce => CS%pbce +! Accel_diag%u_accel_bt => CS%u_accel_bt ; Accel_diag%v_accel_bt => CS%v_accel_bt +! Accel_diag%u_av => CS%u_av ; Accel_diag%v_av => CS%v_av + + call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp, CS%OBC) + cont_stencil = continuity_stencil(CS%continuity_CSp) + call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) + dyn_h_stencil = max(cont_stencil, CoriolisAdv_stencil(CS%CoriolisAdv)) + if (CS%calculate_SAL) call SAL_init(h, tv, G, GV, US, param_file, CS%SAL_CSp, restart_CS) + if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) + if (CS%use_HA) then + call HA_init(Time, US, param_file, nc, CS%HA_CSp) + HA_CSp => CS%HA_CSp + else + HA_CSp => NULL() + endif + call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, CS%ADp, & + CS%SAL_CSp, CS%tides_CSp) + call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc, ADp=CS%ADp) + call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, & + ntrunc, CS%vertvisc_CSp) + CS%set_visc_CSp => set_visc + call updateCFLtruncationValue(Time, CS%vertvisc_CSp, US, & + activate=is_new_run(restart_CS) ) + + if (associated(ALE_CSp)) CS%ALE_CSp => ALE_CSp + if (associated(OBC)) then + CS%OBC => OBC + if (OBC%ramp) call update_OBC_ramp(Time, CS%OBC, US, & + activate=is_new_run(restart_CS) ) + endif + if (associated(update_OBC_CSp)) CS%update_OBC_CSp => update_OBC_CSp + + eta_rest_name = "sfc" ; if (.not.GV%Boussinesq) eta_rest_name = "p_bot" + if (.not. query_initialized(CS%eta, trim(eta_rest_name), restart_CS)) then + ! Estimate eta based on the layer thicknesses - h. With the Boussinesq + ! approximation, eta is the free surface height anomaly, while without it + ! eta is the mass of ocean per unit area. eta always has the same + ! dimensions as h, either m or kg m-3. + ! CS%eta(:,:) = 0.0 already from initialization. + if (GV%Boussinesq) then + do j=js,je ; do i=is,ie ; CS%eta(i,j) = -GV%Z_to_H * G%bathyT(i,j) ; enddo ; enddo + endif + do k=1,nz ; do j=js,je ; do i=is,ie + CS%eta(i,j) = CS%eta(i,j) + h(i,j,k) + enddo ; enddo ; enddo + call set_initialized(CS%eta, trim(eta_rest_name), restart_CS) + endif + ! Copy eta into an output array. + do j=js,je ; do i=is,ie ; eta(i,j) = CS%eta(i,j) ; enddo ; enddo + + call barotropic_init(u, v, h, Time, G, GV, US, param_file, diag, & + CS%barotropic_CSp, restart_CS, calc_dtbt, CS%BT_cont, & + CS%OBC, CS%SAL_CSp, HA_CSp) + + flux_units = get_flux_units(GV) + thickness_units = get_thickness_units(GV) + CS%id_uh = register_diag_field('ocean_model', 'uh', diag%axesCuL, Time, & + 'Zonal Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & + y_cell_method='sum', v_extensive=.true.) + CS%id_vh = register_diag_field('ocean_model', 'vh', diag%axesCvL, Time, & + 'Meridional Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & + x_cell_method='sum', v_extensive=.true.) + + CS%id_CAu = register_diag_field('ocean_model', 'CAu', diag%axesCuL, Time, & + 'Zonal Coriolis and Advective Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_CAv = register_diag_field('ocean_model', 'CAv', diag%axesCvL, Time, & + 'Meridional Coriolis and Advective Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_PFu = register_diag_field('ocean_model', 'PFu', diag%axesCuL, Time, & + 'Zonal Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_PFv = register_diag_field('ocean_model', 'PFv', diag%axesCvL, Time, & + 'Meridional Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_ueffA = register_diag_field('ocean_model', 'ueffA', diag%axesCuL, Time, & + 'Effective U-Face Area', 'm^2', conversion=GV%H_to_m*US%L_to_m, & + y_cell_method='sum', v_extensive=.true.) + CS%id_veffA = register_diag_field('ocean_model', 'veffA', diag%axesCvL, Time, & + 'Effective V-Face Area', 'm^2', conversion=GV%H_to_m*US%L_to_m, & + x_cell_method='sum', v_extensive=.true.) + if (GV%Boussinesq) then + CS%id_deta_dt = register_diag_field('ocean_model', 'deta_dt', diag%axesT1, Time, & + 'Barotropic SSH tendency due to dynamics', trim(thickness_units)//' s-1', conversion=GV%H_to_MKS*US%s_to_T) + else + CS%id_deta_dt = register_diag_field('ocean_model', 'deta_dt', diag%axesT1, Time, & + 'Barotropic column-mass tendency due to dynamics', trim(thickness_units)//' s-1', & + conversion=GV%H_to_mks*US%s_to_T) + endif + + !CS%id_hf_PFu = register_diag_field('ocean_model', 'hf_PFu', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Pressure Force Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_PFu > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + !CS%id_hf_PFv = register_diag_field('ocean_model', 'hf_PFv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Pressure Force Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_PFv > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + !CS%id_hf_CAu = register_diag_field('ocean_model', 'hf_CAu', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Coriolis and Advective Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_CAu > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + !CS%id_hf_CAv = register_diag_field('ocean_model', 'hf_CAv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Coriolis and Advective Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_CAv > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + CS%id_hf_PFu_2d = register_diag_field('ocean_model', 'hf_PFu_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Pressure Force Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_PFu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + CS%id_hf_PFv_2d = register_diag_field('ocean_model', 'hf_PFv_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Pressure Force Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_PFv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + CS%id_h_PFu = register_diag_field('ocean_model', 'h_PFu', diag%axesCuL, Time, & + 'Thickness Multiplied Zonal Pressure Force Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_PFu > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_h_PFv = register_diag_field('ocean_model', 'h_PFv', diag%axesCvL, Time, & + 'Thickness Multiplied Meridional Pressure Force Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_PFv > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + + CS%id_intz_PFu_2d = register_diag_field('ocean_model', 'intz_PFu_2d', diag%axesCu1, Time, & + 'Depth-integral of Zonal Pressure Force Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_PFu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_intz_PFv_2d = register_diag_field('ocean_model', 'intz_PFv_2d', diag%axesCv1, Time, & + 'Depth-integral of Meridional Pressure Force Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_PFv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + + CS%id_hf_CAu_2d = register_diag_field('ocean_model', 'hf_CAu_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Coriolis and Advective Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_CAu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + CS%id_hf_CAv_2d = register_diag_field('ocean_model', 'hf_CAv_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Coriolis and Advective Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_CAv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + CS%id_h_CAu = register_diag_field('ocean_model', 'h_CAu', diag%axesCuL, Time, & + 'Thickness Multiplied Zonal Coriolis and Advective Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_CAu > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_h_CAv = register_diag_field('ocean_model', 'h_CAv', diag%axesCvL, Time, & + 'Thickness Multiplied Meridional Coriolis and Advective Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_CAv > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + + CS%id_intz_CAu_2d = register_diag_field('ocean_model', 'intz_CAu_2d', diag%axesCu1, Time, & + 'Depth-integral of Zonal Coriolis and Advective Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_CAu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_intz_CAv_2d = register_diag_field('ocean_model', 'intz_CAv_2d', diag%axesCv1, Time, & + 'Depth-integral of Meridional Coriolis and Advective Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_CAv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + + CS%id_uav = register_diag_field('ocean_model', 'uav', diag%axesCuL, Time, & + 'Barotropic-step Averaged Zonal Velocity', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_vav = register_diag_field('ocean_model', 'vav', diag%axesCvL, Time, & + 'Barotropic-step Averaged Meridional Velocity', 'm s-1', conversion=US%L_T_to_m_s) + + CS%id_u_BT_accel = register_diag_field('ocean_model', 'u_BT_accel', diag%axesCuL, Time, & + 'Barotropic Anomaly Zonal Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_v_BT_accel = register_diag_field('ocean_model', 'v_BT_accel', diag%axesCvL, Time, & + 'Barotropic Anomaly Meridional Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + + !CS%id_hf_u_BT_accel = register_diag_field('ocean_model', 'hf_u_BT_accel', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Barotropic Anomaly Zonal Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_u_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + !CS%id_hf_v_BT_accel = register_diag_field('ocean_model', 'hf_v_BT_accel', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Barotropic Anomaly Meridional Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_v_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + CS%id_hf_u_BT_accel_2d = register_diag_field('ocean_model', 'hf_u_BT_accel_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Barotropic Anomaly Zonal Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_u_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + CS%id_hf_v_BT_accel_2d = register_diag_field('ocean_model', 'hf_v_BT_accel_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Barotropic Anomaly Meridional Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_v_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + CS%id_h_u_BT_accel = register_diag_field('ocean_model', 'h_u_BT_accel', diag%axesCuL, Time, & + 'Thickness Multiplied Barotropic Anomaly Zonal Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_u_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_h_v_BT_accel = register_diag_field('ocean_model', 'h_v_BT_accel', diag%axesCvL, Time, & + 'Thickness Multiplied Barotropic Anomaly Meridional Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_v_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + + CS%id_intz_u_BT_accel_2d = register_diag_field('ocean_model', 'intz_u_BT_accel_2d', diag%axesCu1, Time, & + 'Depth-integral of Barotropic Anomaly Zonal Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_u_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_intz_v_BT_accel_2d = register_diag_field('ocean_model', 'intz_v_BT_accel_2d', diag%axesCv1, Time, & + 'Depth-integral of Barotropic Anomaly Meridional Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_v_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + + CS%id_PFu_visc_rem = register_diag_field('ocean_model', 'PFu_visc_rem', diag%axesCuL, Time, & + 'Zonal Pressure Force Acceleration multiplied by the viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_PFu_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_u,IsdB,IedB,jsd,jed,nz) + CS%id_PFv_visc_rem = register_diag_field('ocean_model', 'PFv_visc_rem', diag%axesCvL, Time, & + 'Meridional Pressure Force Acceleration multiplied by the viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_PFv_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_v,isd,ied,JsdB,JedB,nz) + + CS%id_CAu_visc_rem = register_diag_field('ocean_model', 'CAu_visc_rem', diag%axesCuL, Time, & + 'Zonal Coriolis and Advective Acceleration multiplied by the viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_CAu_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_u,IsdB,IedB,jsd,jed,nz) + CS%id_CAv_visc_rem = register_diag_field('ocean_model', 'CAv_visc_rem', diag%axesCvL, Time, & + 'Meridional Coriolis and Advective Acceleration multiplied by the viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_CAv_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_v,isd,ied,JsdB,JedB,nz) + + CS%id_u_BT_accel_visc_rem = register_diag_field('ocean_model', 'u_BT_accel_visc_rem', diag%axesCuL, Time, & + 'Barotropic Anomaly Zonal Acceleration multiplied by the viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_u_BT_accel_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_u,IsdB,IedB,jsd,jed,nz) + CS%id_v_BT_accel_visc_rem = register_diag_field('ocean_model', 'v_BT_accel_visc_rem', diag%axesCvL, Time, & + 'Barotropic Anomaly Meridional Acceleration multiplied by the viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_v_BT_accel_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_v,isd,ied,JsdB,JedB,nz) + + id_clock_Cor = cpu_clock_id('(Ocean Coriolis & mom advection)', grain=CLOCK_MODULE) + id_clock_continuity = cpu_clock_id('(Ocean continuity equation)', grain=CLOCK_MODULE) + id_clock_pres = cpu_clock_id('(Ocean pressure force)', grain=CLOCK_MODULE) + id_clock_vertvisc = cpu_clock_id('(Ocean vertical viscosity)', grain=CLOCK_MODULE) + id_clock_horvisc = cpu_clock_id('(Ocean horizontal viscosity)', grain=CLOCK_MODULE) + id_clock_mom_update = cpu_clock_id('(Ocean momentum increments)', grain=CLOCK_MODULE) + id_clock_pass = cpu_clock_id('(Ocean message passing)', grain=CLOCK_MODULE) + id_clock_btcalc = cpu_clock_id('(Ocean barotropic mode calc)', grain=CLOCK_MODULE) + id_clock_btstep = cpu_clock_id('(Ocean barotropic mode stepping)', grain=CLOCK_MODULE) + id_clock_btforce = cpu_clock_id('(Ocean barotropic forcing calc)', grain=CLOCK_MODULE) + +end subroutine initialize_dyn_split_RK2b + + +!> Close the dyn_split_RK2b module +subroutine end_dyn_split_RK2b(CS) + type(MOM_dyn_split_RK2b_CS), pointer :: CS !< module control structure + + call barotropic_end(CS%barotropic_CSp) + + call vertvisc_end(CS%vertvisc_CSp) + deallocate(CS%vertvisc_CSp) + + call hor_visc_end(CS%hor_visc) + if (CS%calculate_SAL) call SAL_end(CS%SAL_CSp) + if (CS%use_tides) call tidal_forcing_end(CS%tides_CSp) + call CoriolisAdv_end(CS%CoriolisAdv) + + DEALLOC_(CS%diffu) ; DEALLOC_(CS%diffv) + DEALLOC_(CS%CAu) ; DEALLOC_(CS%CAv) + DEALLOC_(CS%CAu_pred) ; DEALLOC_(CS%CAv_pred) + DEALLOC_(CS%PFu) ; DEALLOC_(CS%PFv) + + if (associated(CS%taux_bot)) deallocate(CS%taux_bot) + if (associated(CS%tauy_bot)) deallocate(CS%tauy_bot) + DEALLOC_(CS%uhbt) ; DEALLOC_(CS%vhbt) + DEALLOC_(CS%du_av_inst) ; DEALLOC_(CS%dv_av_inst) + DEALLOC_(CS%u_accel_bt) ; DEALLOC_(CS%v_accel_bt) + DEALLOC_(CS%visc_rem_u) ; DEALLOC_(CS%visc_rem_v) + + DEALLOC_(CS%eta) ; DEALLOC_(CS%eta_PF) ; DEALLOC_(CS%pbce) + + call dealloc_BT_cont_type(CS%BT_cont) + deallocate(CS%AD_pred) + + deallocate(CS) +end subroutine end_dyn_split_RK2b + + +!> \namespace mom_dynamics_split_rk2b +!! +!! This file time steps the adiabatic dynamic core by splitting +!! between baroclinic and barotropic modes. It uses a pseudo-second order +!! Runge-Kutta time stepping scheme for the baroclinic momentum +!! equation and a forward-backward coupling between the baroclinic +!! momentum and continuity equations. This split time-stepping +!! scheme is described in detail in Hallberg (JCP, 1997). Additional +!! issues related to exact tracer conservation and how to +!! ensure consistency between the barotropic and layered estimates +!! of the free surface height are described in Hallberg and +!! Adcroft (Ocean Modelling, 2009). This was the time stepping code +!! that is used for most GOLD applications, including GFDL's ESM2G +!! Earth system model, and all of the examples provided with the +!! MOM code (although several of these solutions are routinely +!! verified by comparison with the slower unsplit schemes). +!! +!! The subroutine step_MOM_dyn_split_RK2b actually does the time +!! stepping, while register_restarts_dyn_split_RK2b sets the fields +!! that are found in a full restart file with this scheme, and +!! initialize_dyn_split_RK2b initializes the cpu clocks that are +!! used in this module. For largely historical reasons, this module +!! does not have its own control structure, but shares the same +!! control structure with MOM.F90 and the other MOM_dynamics_... +!! modules. + +end module MOM_dynamics_split_RK2b diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index fcc4c3d49b..34897d0894 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Time steps the ocean dynamics with an unsplit quasi 3rd order scheme module MOM_dynamics_unsplit -! This file is part of MOM6. See LICENSE.md for the license. - !********+*********+*********+*********+*********+*********+*********+** !* * !* By Robert Hallberg, 1993-2012 * @@ -50,7 +52,7 @@ module MOM_dynamics_unsplit !* * !********+*********+*********+*********+*********+*********+*********+** -use MOM_variables, only : vertvisc_type, thermo_var_ptrs, porous_barrier_ptrs +use MOM_variables, only : vertvisc_type, thermo_var_ptrs, porous_barrier_type use MOM_variables, only : accel_diag_ptrs, ocean_internal_state, cont_diag_ptrs use MOM_forcing_type, only : mech_forcing use MOM_checksum_packages, only : MOM_thermo_chksum, MOM_state_chksum, MOM_accel_chksum @@ -65,7 +67,7 @@ module MOM_dynamics_unsplit use MOM_domains, only : pass_vector, pass_vector_start, pass_vector_complete use MOM_domains, only : To_South, To_West, To_All, CGRID_NE, SCALAR_PAIR use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe -use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_get_input, only : directories use MOM_time_manager, only : time_type, real_to_time, operator(+) use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) @@ -74,12 +76,12 @@ module MOM_dynamics_unsplit use MOM_barotropic, only : barotropic_CS use MOM_boundary_update, only : update_OBC_data, update_OBC_CS use MOM_continuity, only : continuity, continuity_init, continuity_CS, continuity_stencil -use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_init, CoriolisAdv_CS +use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_init, CoriolisAdv_CS, CoriolisAdv_stencil use MOM_debugging, only : check_redundant use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_hor_visc, only : horizontal_viscosity, hor_visc_init, hor_visc_CS -use MOM_interface_heights, only : find_eta +use MOM_interface_heights, only : find_eta, thickness_to_dz use MOM_lateral_mixing_coeffs, only : VarMix_CS use MOM_MEKE_types, only : MEKE_type use MOM_open_boundary, only : ocean_OBC_type @@ -87,7 +89,9 @@ module MOM_dynamics_unsplit use MOM_open_boundary, only : open_boundary_zero_normal_flow use MOM_PressureForce, only : PressureForce, PressureForce_init, PressureForce_CS use MOM_set_visc, only : set_viscous_ML, set_visc_CS -use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_CS +use MOM_stochastics, only : stochastic_CS +use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_end, tidal_forcing_CS +use MOM_self_attr_load, only : SAL_init, SAL_end, SAL_CS use MOM_unit_scaling, only : unit_scale_type use MOM_vert_friction, only : vertvisc, vertvisc_coef, vertvisc_init, vertvisc_CS use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units @@ -115,11 +119,13 @@ module MOM_dynamics_unsplit real, pointer, dimension(:,:) :: tauy_bot => NULL() !< frictional y-bottom stress from the ocean !! to the seafloor [R L Z T-2 ~> Pa] - logical :: use_correct_dt_visc !< If true, use the correct timestep in the viscous terms applied - !! in the first predictor step with the unsplit time stepping scheme, - !! and in the calculation of the turbulent mixed layer properties - !! for viscosity. The default should be true, but it is false. - logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: dt_visc_bug !< If false, use the correct timestep in viscous terms applied in the + !! first predictor step and in the calculation of the turbulent mixed + !! layer properties for viscosity. If this is true, an older incorrect + !! setting is used. + logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: calculate_SAL !< If true, calculate self-attraction and loading. + logical :: use_tides !< If true, tidal forcing is enabled. logical :: module_is_initialized = .false. !< Record whether this module has been initialized. @@ -153,8 +159,10 @@ module MOM_dynamics_unsplit type(vertvisc_CS), pointer :: vertvisc_CSp => NULL() !> A pointer to the set_visc control structure type(set_visc_CS), pointer :: set_visc_CSp => NULL() + !> A pointer to the SAL control structure + type(SAL_CS) :: SAL_CSp !> A pointer to the tidal forcing control structure - type(tidal_forcing_CS), pointer :: tides_CSp => NULL() + type(tidal_forcing_CS) :: tides_CSp !> A pointer to the ALE control structure. type(ALE_CS), pointer :: ALE_CSp => NULL() @@ -184,7 +192,7 @@ module MOM_dynamics_unsplit !! 3rd order (for the inviscid momentum equations) order scheme subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & p_surf_begin, p_surf_end, uh, vh, uhtr, vhtr, eta_av, G, GV, US, CS, & - VarMix, MEKE, pbv, Waves) + VarMix, MEKE, pbv, STOCH, Waves) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -217,12 +225,14 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & !! initialize_dyn_unsplit. type(VarMix_CS), intent(inout) :: VarMix !< Variable mixing control structure type(MEKE_type), intent(inout) :: MEKE !< MEKE fields - type(porous_barrier_ptrs), intent(in) :: pbv !< porous barrier fractional cell metrics + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + type(stochastic_CS), intent(inout) :: STOCH !< Stochastic control structure type(wave_parameters_CS), optional, pointer :: Waves !< A pointer to a structure containing !! fields related to the surface wave conditions ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_av, hp ! Predicted or averaged layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Distance between the interfaces around a layer [Z ~> m] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: up, upp ! Predicted zonal velocities [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vp, vpp ! Predicted meridional velocities [L T-1 ~> m s-1] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: ueffA ! Effective Area of U-Faces [H L ~> m2] @@ -232,15 +242,15 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & real :: dt_visc ! The time step for a part of the update due to viscosity [T ~> s]. logical :: dyn_p_surf integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: cor_stencil ! Stencil size for Coriolis schemes [nondim] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB dt_pred = dt / 3.0 + cor_stencil = CoriolisAdv_stencil(CS%CoriolisAdv) - h_av(:,:,:) = 0; hp(:,:,:) = 0 - up(:,:,:) = 0; upp(:,:,:) = 0 - vp(:,:,:) = 0; vpp(:,:,:) = 0 - if (CS%id_ueffA > 0) ueffA(:,:,:) = 0 - if (CS%id_veffA > 0) veffA(:,:,:) = 0 + h_av(:,:,:) = 0 ; hp(:,:,:) = 0 + up(:,:,:) = 0 ; upp(:,:,:) = 0 + vp(:,:,:) = 0 ; vpp(:,:,:) = 0 dyn_p_surf = associated(p_surf_begin) .and. associated(p_surf_end) if (dyn_p_surf) then @@ -259,7 +269,8 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! diffu = horizontal viscosity terms (u,h) call enable_averages(dt, Time_local, CS%diag) call cpu_clock_begin(id_clock_horvisc) - call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc) + call horizontal_viscosity(u, v, h, uh, vh, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, tv, dt, & + STOCH=STOCH) call cpu_clock_end(id_clock_horvisc) call disable_averaging(CS%diag) @@ -271,7 +282,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & call pass_var(hp, G%Domain, clock=id_clock_pass) call pass_vector(uh, vh, G%Domain, clock=id_clock_pass) - call enable_averages(0.5*dt, Time_local-real_to_time(0.5*US%T_to_s*dt), CS%diag) + call enable_averages(0.5*dt, Time_local-real_to_time(0.5*dt, unscale=US%T_to_s), CS%diag) ! Here the first half of the thickness fluxes are offered for averaging. if (CS%id_uh > 0) call post_data(CS%id_uh, uh, CS%diag) if (CS%id_vh > 0) call post_data(CS%id_vh, vh, CS%diag) @@ -281,7 +292,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! u = u + dt diffu call cpu_clock_begin(id_clock_mom_update) do k=1,nz - do j=js-2,je+2 ; do i=is-2,ie+2 + do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil h_av(i,j,k) = (h(i,j,k) + hp(i,j,k)) * 0.5 enddo ; enddo do j=js,je ; do I=Isq,Ieq @@ -312,7 +323,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & p_surf(i,j) = 0.75*p_surf_begin(i,j) + 0.25*p_surf_end(i,j) enddo ; enddo ; endif call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, US, & - CS%PressureForce_CSp, CS%ALE_CSp, p_surf) + CS%PressureForce_CSp, CS%ALE_CSp, CS%ADp, p_surf) call cpu_clock_end(id_clock_pres) if (associated(CS%OBC)) then ; if (CS%OBC%update_OBC) then @@ -342,12 +353,13 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! up <- up + dt/2 d/dz visc d/dz up call cpu_clock_begin(id_clock_vertvisc) call enable_averages(dt, Time_local, CS%diag) - dt_visc = 0.5*dt ; if (CS%use_correct_dt_visc) dt_visc = dt + dt_visc = dt ; if (CS%dt_visc_bug) dt_visc = 0.5*dt call set_viscous_ML(u, v, h_av, tv, forces, visc, dt_visc, G, GV, US, CS%set_visc_CSp) call disable_averaging(CS%diag) - dt_visc = 0.5*dt ; if (CS%use_correct_dt_visc) dt_visc = dt_pred - call vertvisc_coef(up, vp, h_av, forces, visc, dt_visc, G, GV, US, CS%vertvisc_CSp, CS%OBC) + dt_visc = dt_pred ; if (CS%dt_visc_bug) dt_visc = 0.5*dt + call thickness_to_dz(h_av, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(up, vp, h_av, dz, forces, visc, tv, dt_visc, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(up, vp, h_av, forces, visc, dt_visc, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, Waves=Waves) call cpu_clock_end(id_clock_vertvisc) @@ -362,7 +374,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & call pass_vector(uh, vh, G%Domain, clock=id_clock_pass) ! h_av <- (hp + h_av)/2 - do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + do k=1,nz ; do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil h_av(i,j,k) = (hp(i,j,k) + h_av(i,j,k)) * 0.5 enddo ; enddo ; enddo @@ -378,7 +390,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & p_surf(i,j) = 0.25*p_surf_begin(i,j) + 0.75*p_surf_end(i,j) enddo ; enddo ; endif call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, US, & - CS%PressureForce_CSp, CS%ALE_CSp, p_surf) + CS%PressureForce_CSp, CS%ALE_CSp, CS%ADp, p_surf) call cpu_clock_end(id_clock_pres) if (associated(CS%OBC)) then ; if (CS%OBC%update_OBC) then @@ -407,7 +419,8 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! upp <- upp + dt/2 d/dz visc d/dz upp call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(upp, vpp, hp, forces, visc, dt*0.5, G, GV, US, CS%vertvisc_CSp, CS%OBC) + call thickness_to_dz(hp, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(upp, vpp, hp, dz, forces, visc, tv, dt*0.5, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(upp, vpp, hp, forces, visc, dt*0.5, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, Waves=Waves) call cpu_clock_end(id_clock_vertvisc) @@ -431,25 +444,26 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & call disable_averaging(CS%diag) call enable_averages(dt, Time_local, CS%diag) -! Calculate effective areas and post data + ! Calculate effective areas and post data if (CS%id_ueffA > 0) then - do k=1,nz ; do j=js,je ; do I=Isq,Ieq - if (abs(up(I,j,k)) > 0.) ueffA(I,j,k) = uh(I,j,k)/up(I,j,k) - enddo ; enddo ; enddo - call post_data(CS%id_ueffA, ueffA, CS%diag) + ueffA(:,:,:) = 0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + if (abs(up(I,j,k)) > 0.) ueffA(I,j,k) = uh(I,j,k)/up(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_ueffA, ueffA, CS%diag) endif if (CS%id_veffA > 0) then - do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - if (abs(vp(i,J,k)) > 0.) veffA(i,J,k) = vh(i,J,k)/vp(i,J,k) - enddo ; enddo ; enddo - call post_data(CS%id_veffA, veffA, CS%diag) + veffA(:,:,:) = 0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + if (abs(vp(i,J,k)) > 0.) veffA(i,J,k) = vh(i,J,k)/vp(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_veffA, veffA, CS%diag) endif - ! h_av = (h + hp)/2 do k=1,nz - do j=js-2,je+2 ; do i=is-2,ie+2 + do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil h_av(i,j,k) = 0.5*(h(i,j,k) + hp(i,j,k)) enddo ; enddo do j=js-2,je+2 ; do I=Isq-2,Ieq+2 @@ -469,7 +483,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! PFu = d/dx M(h_av,T,S) call cpu_clock_begin(id_clock_pres) call PressureForce(h_av, tv, CS%PFu, CS%PFv, G, GV, US, & - CS%PressureForce_CSp, CS%ALE_CSp, p_surf) + CS%PressureForce_CSp, CS%ALE_CSp, CS%ADp, p_surf) call cpu_clock_end(id_clock_pres) if (associated(CS%OBC)) then ; if (CS%OBC%update_OBC) then @@ -490,7 +504,8 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! u <- u + dt d/dz visc d/dz u call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(u, v, h_av, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC) + call thickness_to_dz(h_av, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(u, v, h_av, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(u, v, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, Waves=Waves) call cpu_clock_end(id_clock_vertvisc) @@ -537,7 +552,6 @@ subroutine register_restarts_dyn_unsplit(HI, GV, param_file, CS) type(MOM_dyn_unsplit_CS), pointer :: CS !< The control structure set up by !! initialize_dyn_unsplit. - character(len=40) :: mdl = "MOM_dynamics_unsplit" ! This module's name. character(len=48) :: thickness_units, flux_units integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke @@ -566,10 +580,10 @@ subroutine register_restarts_dyn_unsplit(HI, GV, param_file, CS) end subroutine register_restarts_dyn_unsplit !> Initialize parameters and allocate memory associated with the unsplit dynamics module. -subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS, & +subroutine initialize_dyn_unsplit(u, v, h, tv, Time, G, GV, US, param_file, diag, CS, & Accel_diag, Cont_diag, MIS, & OBC, update_OBC_CSp, ALE_CSp, set_visc, & - visc, dirs, ntrunc, cont_stencil) + visc, dirs, ntrunc, cont_stencil, dyn_h_stencil) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -579,6 +593,7 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS intent(inout) :: v !< The meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic type type(time_type), target, intent(in) :: Time !< The current model time. type(param_file_type), intent(in) :: param_file !< A structure to parse !! for run-time parameters. @@ -613,17 +628,19 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS !! records the number of times the velocity !! is truncated (this should be 0). integer, intent(out) :: cont_stencil !< The stencil for thickness - !! from the continuity solver. + !! from the continuity solver. + integer, intent(out) :: dyn_h_stencil !< The stencil for thickness + !! for the dynamics based on the + !! continuity solver and Coriolis scheme. ! This subroutine initializes all of the variables that are used by this ! dynamic core, including diagnostics and the cpu clocks. ! Local variables character(len=40) :: mdl = "MOM_dynamics_unsplit" ! This module's name. - character(len=48) :: thickness_units, flux_units + character(len=48) :: flux_units ! This include declares and sets the variable "version". # include "version_variable.h" - logical :: use_tides integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -640,16 +657,21 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS CS%diag => diag call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "FIX_UNSPLIT_DT_VISC_BUG", CS%use_correct_dt_visc, & - "If true, use the correct timestep in the viscous terms applied in the first "//& + + call get_param(param_file, mdl, "UNSPLIT_DT_VISC_BUG", CS%dt_visc_bug, & + "If false, use the correct timestep in the viscous terms applied in the first "//& "predictor step with the unsplit time stepping scheme, and in the calculation "//& "of the turbulent mixed layer properties for viscosity with unsplit or "//& - "unsplit_RK2.", default=.true.) + "unsplit_RK2. If true, an older incorrect value is used.", & + default=.false.) + call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) - call get_param(param_file, mdl, "TIDES", use_tides, & + call get_param(param_file, mdl, "TIDES", CS%use_tides, & "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=CS%use_tides) allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source=0.0) allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source=0.0) @@ -663,12 +685,14 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS Accel_diag%PFu => CS%PFu ; Accel_diag%PFv => CS%PFv Accel_diag%CAu => CS%CAu ; Accel_diag%CAv => CS%CAv - call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) + call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp, CS%OBC) cont_stencil = continuity_stencil(CS%continuity_CSp) call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) - if (use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) - call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & - CS%tides_CSp) + dyn_h_stencil = max(cont_stencil, CoriolisAdv_stencil(CS%CoriolisAdv)) + if (CS%calculate_SAL) call SAL_init(h, tv, G, GV, US, param_file, CS%SAL_CSp) + if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) + call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, CS%ADp, & + CS%SAL_CSp, CS%tides_CSp) call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc) call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, & ntrunc, CS%vertvisc_CSp) @@ -694,11 +718,11 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS CS%id_PFv = register_diag_field('ocean_model', 'PFv', diag%axesCvL, Time, & 'Meridional Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_ueffA = register_diag_field('ocean_model', 'ueffA', diag%axesCuL, Time, & - 'Effective U Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & - y_cell_method='sum', v_extensive = .true.) + 'Effective U Face Area', 'm^2', conversion=GV%H_to_m*US%L_to_m, & + y_cell_method='sum', v_extensive=.true.) CS%id_veffA = register_diag_field('ocean_model', 'veffA', diag%axesCvL, Time, & - 'Effective V Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & - x_cell_method='sum', v_extensive = .true.) + 'Effective V Face Area', 'm^2', conversion=GV%H_to_m*US%L_to_m, & + x_cell_method='sum', v_extensive=.true.) id_clock_Cor = cpu_clock_id('(Ocean Coriolis & mom advection)', grain=CLOCK_MODULE) id_clock_continuity = cpu_clock_id('(Ocean continuity equation)', grain=CLOCK_MODULE) @@ -720,6 +744,9 @@ subroutine end_dyn_unsplit(CS) DEALLOC_(CS%CAu) ; DEALLOC_(CS%CAv) DEALLOC_(CS%PFu) ; DEALLOC_(CS%PFv) + if (CS%calculate_SAL) call SAL_end(CS%SAL_CSp) + if (CS%use_tides) call tidal_forcing_end(CS%tides_CSp) + deallocate(CS) end subroutine end_dyn_unsplit diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 694d88f2ea..005a2a77e1 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Time steps the ocean dynamics with an unsplit quasi 2nd order Runge-Kutta scheme module MOM_dynamics_unsplit_RK2 -! This file is part of MOM6. See LICENSE.md for the license. - !********+*********+*********+*********+*********+*********+*********+** !* * !* By Alistair Adcroft and Robert Hallberg, 2010-2012 * @@ -48,7 +50,7 @@ module MOM_dynamics_unsplit_RK2 !* * !********+*********+*********+*********+*********+*********+*********+** -use MOM_variables, only : vertvisc_type, thermo_var_ptrs, porous_barrier_ptrs +use MOM_variables, only : vertvisc_type, thermo_var_ptrs, porous_barrier_type use MOM_variables, only : ocean_internal_state, accel_diag_ptrs, cont_diag_ptrs use MOM_forcing_type, only : mech_forcing use MOM_checksum_packages, only : MOM_thermo_chksum, MOM_state_chksum, MOM_accel_chksum @@ -64,20 +66,21 @@ module MOM_dynamics_unsplit_RK2 use MOM_domains, only : To_South, To_West, To_All, CGRID_NE, SCALAR_PAIR use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_error_handler, only : MOM_set_verbosity -use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_get_input, only : directories -use MOM_time_manager, only : time_type, time_type_to_real, operator(+) +use MOM_time_manager, only : time_type, operator(+) use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) use MOM_ALE, only : ALE_CS use MOM_boundary_update, only : update_OBC_data, update_OBC_CS use MOM_barotropic, only : barotropic_CS use MOM_continuity, only : continuity, continuity_init, continuity_CS, continuity_stencil -use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_init, CoriolisAdv_CS +use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_init, CoriolisAdv_CS, CoriolisAdv_stencil use MOM_debugging, only : check_redundant use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_hor_visc, only : horizontal_viscosity, hor_visc_init, hor_visc_CS +use MOM_interface_heights, only : thickness_to_dz use MOM_lateral_mixing_coeffs, only : VarMix_CS use MOM_MEKE_types, only : MEKE_type use MOM_open_boundary, only : ocean_OBC_type @@ -85,7 +88,9 @@ module MOM_dynamics_unsplit_RK2 use MOM_open_boundary, only : open_boundary_zero_normal_flow use MOM_PressureForce, only : PressureForce, PressureForce_init, PressureForce_CS use MOM_set_visc, only : set_viscous_ML, set_visc_CS -use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_CS +use MOM_self_attr_load, only : SAL_init, SAL_end, SAL_CS +use MOM_stochastics, only : stochastic_CS +use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_end, tidal_forcing_CS use MOM_unit_scaling, only : unit_scale_type use MOM_vert_friction, only : vertvisc, vertvisc_coef, vertvisc_init, vertvisc_CS use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units @@ -112,16 +117,18 @@ module MOM_dynamics_unsplit_RK2 real, pointer, dimension(:,:) :: tauy_bot => NULL() !< frictional y-bottom stress from the ocean !! to the seafloor [R L Z T-2 ~> Pa] - real :: be !< A nondimensional number from 0.5 to 1 that controls - !! the backward weighting of the time stepping scheme [nondim]. - real :: begw !< A nondimensional number from 0 to 1 that controls - !! the extent to which the treatment of gravity waves - !! is forward-backward (0) or simulated backward - !! Euler (1) [nondim]. 0 is often used. - logical :: use_correct_dt_visc !< If true, use the correct timestep in the calculation of the - !! turbulent mixed layer properties for viscosity. - !! The default should be true, but it is false. - logical :: debug !< If true, write verbose checksums for debugging purposes. + real :: be !< A nondimensional number from 0.5 to 1 that controls + !! the backward weighting of the time stepping scheme [nondim]. + real :: begw !< A nondimensional number from 0 to 1 that controls + !! the extent to which the treatment of gravity waves + !! is forward-backward (0) or simulated backward + !! Euler (1) [nondim]. 0 is often used. + logical :: dt_visc_bug !< If false, use the correct timestep in the calculation of the + !! turbulent mixed layer properties for viscosity. Otherwise if + !! this is true, an older incorrect setting is used. + logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: calculate_SAL !< If true, calculate self-attraction and loading. + logical :: use_tides !< If true, tidal forcing is enabled. logical :: module_is_initialized = .false. !< Record whether this module has been initialized. @@ -155,8 +162,10 @@ module MOM_dynamics_unsplit_RK2 type(vertvisc_CS), pointer :: vertvisc_CSp => NULL() !> A pointer to the set_visc control structure type(set_visc_CS), pointer :: set_visc_CSp => NULL() + !> A pointer to the SAL control structure + type(SAL_CS) :: SAL_CSp !> A pointer to the tidal forcing control structure - type(tidal_forcing_CS), pointer :: tides_CSp => NULL() + type(tidal_forcing_CS) :: tides_CSp !> A pointer to the ALE control structure. type(ALE_CS), pointer :: ALE_CSp => NULL() @@ -186,7 +195,7 @@ module MOM_dynamics_unsplit_RK2 !> Step the MOM6 dynamics using an unsplit quasi-2nd order Runge-Kutta scheme subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, forces, & p_surf_begin, p_surf_end, uh, vh, uhtr, vhtr, eta_av, G, GV, US, CS, & - VarMix, MEKE, pbv) + VarMix, MEKE, pbv, STOCH) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -230,10 +239,12 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, type(MEKE_type), intent(inout) :: MEKE !< MEKE fields !! fields related to the Mesoscale !! Eddy Kinetic Energy. - type(porous_barrier_ptrs), intent(in) :: pbv !< porous barrier fractional cell metrics + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + type(stochastic_CS), intent(inout) :: STOCH !< Stochastic control structure ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_av ! Averaged layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: hp ! Predicted layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Distance between the interfaces around a layer [Z ~> m] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: up ! Predicted zonal velocities [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vp ! Predicted meridional velocities [L T-1 ~> m s-1] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: ueffA ! Effective Area of U-Faces [H L ~> m2] @@ -243,15 +254,15 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, real :: dt_visc ! The time step for a part of the update due to viscosity [T ~> s] logical :: dyn_p_surf integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: cor_stencil ! Stencil size for Coriolis schemes [nondim] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB dt_pred = dt * CS%BE + cor_stencil = CoriolisAdv_stencil(CS%CoriolisAdv) - h_av(:,:,:) = 0; hp(:,:,:) = 0 + h_av(:,:,:) = 0 ; hp(:,:,:) = 0 up(:,:,:) = 0 vp(:,:,:) = 0 - if (CS%id_ueffA > 0) ueffA(:,:,:) = 0 - if (CS%id_veffA > 0) veffA(:,:,:) = 0 dyn_p_surf = associated(p_surf_begin) .and. associated(p_surf_end) if (dyn_p_surf) then @@ -270,8 +281,8 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! diffu = horizontal viscosity terms (u,h) call enable_averages(dt,Time_local, CS%diag) call cpu_clock_begin(id_clock_horvisc) - call horizontal_viscosity(u_in, v_in, h_in, CS%diffu, CS%diffv, MEKE, VarMix, & - G, GV, US, CS%hor_visc) + call horizontal_viscosity(u_in, v_in, h_in, uh, vh, CS%diffu, CS%diffv, MEKE, VarMix, & + G, GV, US, CS%hor_visc, tv, dt, STOCH=STOCH) call cpu_clock_end(id_clock_horvisc) call disable_averaging(CS%diag) call pass_vector(CS%diffu, CS%diffv, G%Domain, clock=id_clock_pass) @@ -285,12 +296,15 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! and could/should be optimized out. -AJA call continuity(u_in, v_in, h_in, hp, uh, vh, dt_pred, G, GV, US, CS%continuity_CSp, CS%OBC, pbv) call cpu_clock_end(id_clock_continuity) - call pass_var(hp, G%Domain, clock=id_clock_pass) - call pass_vector(uh, vh, G%Domain, clock=id_clock_pass) + call pass_var(hp, G%Domain, halo=cor_stencil, clock=id_clock_pass) + call pass_vector(uh, vh, G%Domain, halo=cor_stencil, clock=id_clock_pass) + if (cor_stencil > 2) then + call pass_vector(u_in, v_in, G%Domain, halo=cor_stencil, clock=id_clock_pass) + endif ! h_av = (h + hp)/2 (used in PV denominator) call cpu_clock_begin(id_clock_mom_update) - do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + do k=1,nz ; do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil h_av(i,j,k) = (h_in(i,j,k) + hp(i,j,k)) * 0.5 enddo ; enddo ; enddo call cpu_clock_end(id_clock_mom_update) @@ -306,7 +320,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, if (dyn_p_surf) then ; do j=js-2,je+2 ; do i=is-2,ie+2 p_surf(i,j) = 0.5*p_surf_begin(i,j) + 0.5*p_surf_end(i,j) enddo ; enddo ; endif - call PressureForce(h_in, tv, CS%PFu, CS%PFv, G, GV, US, CS%PressureForce_CSp, CS%ALE_CSp, p_surf) + call PressureForce(h_in, tv, CS%PFu, CS%PFv, G, GV, US, CS%PressureForce_CSp, CS%ALE_CSp, CS%ADp, p_surf) call cpu_clock_end(id_clock_pres) call pass_vector(CS%PFu, CS%PFv, G%Domain, clock=id_clock_pass) call pass_vector(CS%CAu, CS%CAv, G%Domain, clock=id_clock_pass) @@ -339,11 +353,12 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! up[n-1/2] <- up*[n-1/2] + dt/2 d/dz visc d/dz up[n-1/2] call cpu_clock_begin(id_clock_vertvisc) call enable_averages(dt, Time_local, CS%diag) - dt_visc = dt_pred ; if (CS%use_correct_dt_visc) dt_visc = dt + dt_visc = dt ; if (CS%dt_visc_bug) dt_visc = dt_pred call set_viscous_ML(u_in, v_in, h_av, tv, forces, visc, dt_visc, G, GV, US, CS%set_visc_CSp) call disable_averaging(CS%diag) - call vertvisc_coef(up, vp, h_av, forces, visc, dt_pred, G, GV, US, CS%vertvisc_CSp, CS%OBC) + call thickness_to_dz(h_av, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(up, vp, h_av, dz, forces, visc, tv, dt_pred, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(up, vp, h_av, forces, visc, dt_pred, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp) call cpu_clock_end(id_clock_vertvisc) @@ -358,7 +373,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, call pass_vector(uh, vh, G%Domain, clock=id_clock_pass) ! h_av <- (h + hp)/2 (centered at n-1/2) - do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + do k=1,nz ; do j=js-cor_stencil,je+cor_stencil ; do i=is-cor_stencil,ie+cor_stencil h_av(i,j,k) = (h_in(i,j,k) + hp(i,j,k)) * 0.5 enddo ; enddo ; enddo @@ -394,10 +409,11 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! up[n] <- up* + dt d/dz visc d/dz up ! u[n] <- u*[n] + dt d/dz visc d/dz u[n] call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(up, vp, h_av, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC) + call thickness_to_dz(h_av, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(up, vp, h_av, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(up, vp, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot) - call vertvisc_coef(u_in, v_in, h_av, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC) + call vertvisc_coef(u_in, v_in, h_av, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(u_in, v_in, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp,& G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot) call cpu_clock_end(id_clock_vertvisc) @@ -452,17 +468,19 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! Calculate effective areas and post data if (CS%id_ueffA > 0) then - do k=1,nz ; do j=js,je ; do I=Isq,Ieq - if (abs(up(I,j,k)) > 0.) ueffA(I,j,k) = uh(I,j,k)/up(I,j,k) - enddo ; enddo ; enddo - call post_data(CS%id_ueffA, ueffA, CS%diag) + ueffA(:,:,:) = 0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + if (abs(up(I,j,k)) > 0.) ueffA(I,j,k) = uh(I,j,k)/up(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_ueffA, ueffA, CS%diag) endif if (CS%id_veffA > 0) then - do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - if (abs(vp(i,J,k)) > 0.) veffA(i,J,k) = vh(i,J,k)/vp(i,J,k) - enddo ; enddo ; enddo - call post_data(CS%id_veffA, veffA, CS%diag) + veffA(:,:,:) = 0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + if (abs(vp(i,J,k)) > 0.) veffA(i,J,k) = vh(i,J,k)/vp(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_veffA, veffA, CS%diag) endif @@ -515,16 +533,17 @@ subroutine register_restarts_dyn_unsplit_RK2(HI, GV, param_file, CS) end subroutine register_restarts_dyn_unsplit_RK2 !> Initialize parameters and allocate memory associated with the unsplit RK2 dynamics module. -subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag, CS, & +subroutine initialize_dyn_unsplit_RK2(u, v, h, tv, Time, G, GV, US, param_file, diag, CS, & Accel_diag, Cont_diag, MIS, & OBC, update_OBC_CSp, ALE_CSp, set_visc, & - visc, dirs, ntrunc, cont_stencil) + visc, dirs, ntrunc, cont_stencil, dyn_h_stencil) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< The zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< The meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic type type(time_type), target, intent(in) :: Time !< The current model time. type(param_file_type), intent(in) :: param_file !< A structure to parse !! for run-time parameters. @@ -560,16 +579,18 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag !! velocity is truncated (this should be 0). integer, intent(out) :: cont_stencil !< The stencil for !! thickness from the continuity solver. + integer, intent(out) :: dyn_h_stencil !< The stencil for + !! thickness for the dynamics based on the + !! continuity solver and Coriolis scheme. ! This subroutine initializes all of the variables that are used by this ! dynamic core, including diagnostics and the cpu clocks. ! Local variables character(len=40) :: mdl = "MOM_dynamics_unsplit_RK2" ! This module's name. - character(len=48) :: thickness_units, flux_units + character(len=48) :: flux_units ! This include declares and sets the variable "version". # include "version_variable.h" - logical :: use_tides integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -588,7 +609,7 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "BE", CS%be, & "If SPLIT is true, BE determines the relative weighting "//& - "of a 2nd-order Runga-Kutta baroclinic time stepping "//& + "of a 2nd-order Runga-Kutta baroclinic time stepping "//& "scheme (0.5) and a backward Euler scheme (1) that is "//& "used for the Coriolis and inertial terms. BE may be "//& "from 0.5 to 1, but instability may occur near 0.5. "//& @@ -602,16 +623,21 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag "If SPLIT is false and USE_RK2 is true, BEGW can be "//& "between 0 and 0.5 to damp gravity waves.", & units="nondim", default=0.0) - call get_param(param_file, mdl, "FIX_UNSPLIT_DT_VISC_BUG", CS%use_correct_dt_visc, & - "If true, use the correct timestep in the viscous terms applied in the first "//& + + call get_param(param_file, mdl, "UNSPLIT_DT_VISC_BUG", CS%dt_visc_bug, & + "If false, use the correct timestep in the viscous terms applied in the first "//& "predictor step with the unsplit time stepping scheme, and in the calculation "//& "of the turbulent mixed layer properties for viscosity with unsplit or "//& - "unsplit_RK2.", default=.true.) + "unsplit_RK2. If true, an older incorrect value is used.", & + default=.false.) + call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) - call get_param(param_file, mdl, "TIDES", use_tides, & + call get_param(param_file, mdl, "TIDES", CS%use_tides, & "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=CS%use_tides) allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source=0.0) allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source=0.0) @@ -625,12 +651,14 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag Accel_diag%PFu => CS%PFu ; Accel_diag%PFv => CS%PFv Accel_diag%CAu => CS%CAu ; Accel_diag%CAv => CS%CAv - call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) + call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp, CS%OBC) cont_stencil = continuity_stencil(CS%continuity_CSp) call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) - if (use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) - call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & - CS%tides_CSp) + dyn_h_stencil = max(cont_stencil, CoriolisAdv_stencil(CS%CoriolisAdv)) + if (CS%calculate_SAL) call SAL_init(h, tv, G, GV, US, param_file, CS%SAL_CSp) + if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) + call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, CS%ADp, & + CS%SAL_CSp, CS%tides_CSp) call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc) call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, & ntrunc, CS%vertvisc_CSp) @@ -655,11 +683,11 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag CS%id_PFv = register_diag_field('ocean_model', 'PFv', diag%axesCvL, Time, & 'Meridional Pressure Force Acceleration', 'meter second-2', conversion=US%L_T2_to_m_s2) CS%id_ueffA = register_diag_field('ocean_model', 'ueffA', diag%axesCuL, Time, & - 'Effective U-Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & - y_cell_method='sum', v_extensive = .true.) + 'Effective U-Face Area', 'm^2', conversion=GV%H_to_m*US%L_to_m, & + y_cell_method='sum', v_extensive=.true.) CS%id_veffA = register_diag_field('ocean_model', 'veffA', diag%axesCvL, Time, & - 'Effective V-Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & - x_cell_method='sum', v_extensive = .true.) + 'Effective V-Face Area', 'm^2', conversion=GV%H_to_m*US%L_to_m, & + x_cell_method='sum', v_extensive=.true.) id_clock_Cor = cpu_clock_id('(Ocean Coriolis & mom advection)', grain=CLOCK_MODULE) id_clock_continuity = cpu_clock_id('(Ocean continuity equation)', grain=CLOCK_MODULE) @@ -681,6 +709,9 @@ subroutine end_dyn_unsplit_RK2(CS) DEALLOC_(CS%CAu) ; DEALLOC_(CS%CAv) DEALLOC_(CS%PFu) ; DEALLOC_(CS%PFv) + if (CS%calculate_SAL) call SAL_end(CS%SAL_CSp) + if (CS%use_tides) call tidal_forcing_end(CS%tides_CSp) + deallocate(CS) end subroutine end_dyn_unsplit_RK2 diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index c58340c498..646e46f5f0 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -1,22 +1,27 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> This module implements boundary forcing for MOM6. module MOM_forcing_type -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_array_transform, only : rotate_array, rotate_vector, rotate_array_pair use MOM_coupler_types, only : coupler_2d_bc_type, coupler_type_destructor use MOM_coupler_types, only : coupler_type_increment_data, coupler_type_initialized +use MOM_coupler_types, only : coupler_type_copy_data, coupler_type_spawn use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_debugging, only : hchksum, uvchksum use MOM_diag_mediator, only : post_data, register_diag_field, register_scalar_field use MOM_diag_mediator, only : time_type, diag_ctrl, safe_alloc_alloc, query_averaging_enabled -use MOM_diag_mediator, only : enable_averages, enable_averaging, disable_averaging -use MOM_EOS, only : calculate_density_derivs, EOS_domain +use MOM_diag_mediator, only : enable_averages, disable_averaging +use MOM_EOS, only : calculate_density_derivs, calculate_specific_vol_derivs, EOS_domain use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz use MOM_opacity, only : sumSWoverBands, optics_type, extract_optics_slice, optics_nbands use MOM_spatial_means, only : global_area_integral, global_area_mean +use MOM_spatial_means, only : global_area_mean_u, global_area_mean_v use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -27,7 +32,7 @@ module MOM_forcing_type public extractFluxes1d, extractFluxes2d, optics_type public MOM_forcing_chksum, MOM_mech_forcing_chksum -public calculateBuoyancyFlux1d, calculateBuoyancyFlux2d +public calculateBuoyancyFlux1d, calculateBuoyancyFlux2d, find_ustar public forcing_accumulate, fluxes_accumulate public forcing_SinglePointPrint, mech_forcing_diags, forcing_diagnostics public register_forcing_type_diags, allocate_forcing_type, deallocate_forcing_type @@ -35,6 +40,7 @@ module MOM_forcing_type public set_derived_forcing_fields, copy_back_forcing_fields public set_net_mass_forcing, get_net_mass_forcing public rotate_forcing, rotate_mech_forcing +public homogenize_forcing, homogenize_mech_forcing !> Allocate the fields of a (flux) forcing type, based on either a set of input !! flags for each group of fields, or a pre-allocated reference forcing. @@ -50,6 +56,18 @@ module MOM_forcing_type module procedure allocate_mech_forcing_from_ref end interface allocate_mech_forcing +!> Allocate arrays if optional flag is present and true (works for 2D and 3D) +interface myAlloc + module procedure myAlloc_2d + module procedure myAlloc_3d +end interface myAlloc + +!> Determine the friction velocity from a forcing type or a mechanical forcing type. +interface find_ustar + module procedure find_ustar_fluxes + module procedure find_ustar_mech_forcing +end interface find_ustar + ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with ! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units @@ -65,9 +83,18 @@ module MOM_forcing_type ! surface stress components and turbulent velocity scale real, pointer, dimension(:,:) :: & + omega_w2x => NULL(), & !< the counter-clockwise angle of the wind stress with respect ustar => NULL(), & !< surface friction velocity scale [Z T-1 ~> m s-1]. - ustar_gustless => NULL() !< surface friction velocity scale without any + tau_mag => NULL(), & !< Magnitude of the wind stress averaged over tracer cells, + !! including any contributions from sub-gridscale variability + !! or gustiness, rescaled to units that are more convenient for + !! calculating turbulent fluxes and friction velocities [R Z2 T-2 ~> Pa] + ustar_gustless => NULL(), & !< surface friction velocity scale without any !! any augmentation for gustiness [Z T-1 ~> m s-1]. + tau_mag_gustless => NULL() !< Magnitude of the wind stress averaged over tracer cells, + !! without any augmentation for sub-gridscale variability + !! or gustiness, rescaled to units that are more convenient for + !! calculating turbulent fluxes and friction velocities [R Z2 T-2 ~> Pa] ! surface buoyancy force, used when temperature is not a state variable real, pointer, dimension(:,:) :: & @@ -91,46 +118,56 @@ module MOM_forcing_type ! components of latent heat fluxes used for diagnostic purposes real, pointer, dimension(:,:) :: & - latent_evap_diag => NULL(), & !< latent [Q R Z T-1 ~> W m-2] from evaporating liquid water (typically < 0) - latent_fprec_diag => NULL(), & !< latent [Q R Z T-1 ~> W m-2] from melting fprec (typically < 0) - latent_frunoff_diag => NULL() !< latent [Q R Z T-1 ~> W m-2] from melting frunoff (calving) (typically < 0) + latent_evap_diag => NULL(), & !< latent [Q R Z T-1 ~> W m-2] from evaporating liquid water (typically < 0) + latent_fprec_diag => NULL(), & !< latent [Q R Z T-1 ~> W m-2] from melting fprec (typically < 0) + latent_frunoff_diag => NULL(), & !< latent [Q R Z T-1 ~> W m-2] from melting frunoff (calving) (typically < 0) + latent_frunoff_glc_diag => NULL() !< latent [Q R Z T-1 ~> W m-2] from melting glacier frunoff (typically < 0) ! water mass fluxes into the ocean [R Z T-1 ~> kg m-2 s-1]; these fluxes impact the ocean mass real, pointer, dimension(:,:) :: & - evap => NULL(), & !< (-1)*fresh water flux evaporated out of the ocean [R Z T-1 ~> kg m-2 s-1] - lprec => NULL(), & !< precipitating liquid water into the ocean [R Z T-1 ~> kg m-2 s-1] - fprec => NULL(), & !< precipitating frozen water into the ocean [R Z T-1 ~> kg m-2 s-1] - vprec => NULL(), & !< virtual liquid precip associated w/ SSS restoring [R Z T-1 ~> kg m-2 s-1] - lrunoff => NULL(), & !< liquid river runoff entering ocean [R Z T-1 ~> kg m-2 s-1] - frunoff => NULL(), & !< frozen river runoff (calving) entering ocean [R Z T-1 ~> kg m-2 s-1] - seaice_melt => NULL() !< snow/seaice melt (positive) or formation (negative) [R Z T-1 ~> kg m-2 s-1] + evap => NULL(), & !< (-1)*fresh water flux evaporated out of the ocean [R Z T-1 ~> kg m-2 s-1] + lprec => NULL(), & !< precipitating liquid water into the ocean [R Z T-1 ~> kg m-2 s-1] + fprec => NULL(), & !< precipitating frozen water into the ocean [R Z T-1 ~> kg m-2 s-1] + vprec => NULL(), & !< virtual liquid precip associated w/ SSS restoring [R Z T-1 ~> kg m-2 s-1] + lrunoff => NULL(), & !< liquid river runoff entering ocean [R Z T-1 ~> kg m-2 s-1] + frunoff => NULL(), & !< frozen river runoff (calving) entering ocean [R Z T-1 ~> kg m-2 s-1] + lrunoff_glc => NULL(), & !< liquid river glacier runoff entering ocean [R Z T-1 ~> kg m-2 s-1] + frunoff_glc => NULL(), & !< frozen river glacier runoff entering ocean [R Z T-1 ~> kg m-2 s-1] + seaice_melt => NULL() !< snow/seaice melt (positive) or formation (negative) [R Z T-1 ~> kg m-2 s-1] + + ! carbon content associated with water crossing ocean surface + real, pointer, dimension(:,:) :: & + carbon_content_lrunoff => NULL() !< carbon content associated with liquid runoff [R Z T-1 ~> kg m-2 s-1] ! Integrated water mass fluxes into the ocean, used for passive tracer sources [H ~> m or kg m-2] real, pointer, dimension(:,:) :: & - netMassIn => NULL(), & !< Sum of water mass fluxes into the ocean integrated over a - !! forcing timestep [H ~> m or kg m-2] - netMassOut => NULL() !< Net water mass flux out of the ocean integrated over a forcing timestep, - !! with negative values for water leaving the ocean [H ~> m or kg m-2] + netMassIn => NULL(), & !< Sum of water mass fluxes into the ocean integrated over a + !! forcing timestep [H ~> m or kg m-2] + netMassOut => NULL() !< Net water mass flux out of the ocean integrated over a forcing timestep, + !! with negative values for water leaving the ocean [H ~> m or kg m-2] ! heat associated with water crossing ocean surface real, pointer, dimension(:,:) :: & - heat_content_cond => NULL(), & !< heat content associated with condensating water [Q R Z T-1 ~> W m-2] - heat_content_lprec => NULL(), & !< heat content associated with liquid >0 precip [Q R Z T-1 ~> W m-2] - heat_content_icemelt => NULL(), & !< heat content associated with snow and seaice - !! melt and formation [Q R Z T-1 ~> W m-2] - heat_content_fprec => NULL(), & !< heat content associated with frozen precip [Q R Z T-1 ~> W m-2] - heat_content_vprec => NULL(), & !< heat content associated with virtual >0 precip [Q R Z T-1 ~> W m-2] - heat_content_lrunoff => NULL(), & !< heat content associated with liquid runoff [Q R Z T-1 ~> W m-2] - heat_content_frunoff => NULL(), & !< heat content associated with frozen runoff [Q R Z T-1 ~> W m-2] - heat_content_massout => NULL(), & !< heat content associated with mass leaving ocean [Q R Z T-1 ~> W m-2] - heat_content_massin => NULL() !< heat content associated with mass entering ocean [Q R Z T-1 ~> W m-2] + heat_content_cond => NULL(), & !< heat content associated with condensating water [Q R Z T-1 ~> W m-2] + heat_content_evap => NULL(), & !< heat content associated with evaporating water [Q R Z T-1 ~> W m-2] + heat_content_lprec => NULL(), & !< heat content associated with liquid >0 precip [Q R Z T-1 ~> W m-2] + heat_content_fprec => NULL(), & !< heat content associated with frozen precip [Q R Z T-1 ~> W m-2] + heat_content_vprec => NULL(), & !< heat content associated with virtual >0 precip [Q R Z T-1 ~> W m-2] + heat_content_lrunoff => NULL(), & !< heat content associated with liquid runoff [Q R Z T-1 ~> W m-2] + heat_content_frunoff => NULL(), & !< heat content associated with frozen runoff [Q R Z T-1 ~> W m-2] + heat_content_lrunoff_glc => NULL(), & !< heat content associated with liquid runoff [Q R Z T-1 ~> W m-2] + heat_content_frunoff_glc => NULL(), & !< heat content associated with frozen runoff [Q R Z T-1 ~> W m-2] + heat_content_massout => NULL(), & !< heat content associated with mass leaving ocean [Q R Z T-1 ~> W m-2] + heat_content_massin => NULL() !< heat content associated with mass entering ocean [Q R Z T-1 ~> W m-2] ! salt mass flux (contributes to ocean mass only if non-Bouss ) real, pointer, dimension(:,:) :: & salt_flux => NULL(), & !< net salt flux into the ocean [R Z T-1 ~> kgSalt m-2 s-1] salt_flux_in => NULL(), & !< salt flux provided to the ocean from coupler [R Z T-1 ~> kgSalt m-2 s-1] - salt_flux_added => NULL() !< additional salt flux from restoring or flux adjustment before adjustment + salt_flux_added => NULL(), & !< additional salt flux from restoring or flux adjustment before adjustment !! to net zero [R Z T-1 ~> kgSalt m-2 s-1] + salt_left_behind => NULL() !< salt left in ocean at the surface from brine rejection + !! [R Z T-1 ~> kgSalt m-2 s-1] ! applied surface pressure from other component models (e.g., atmos, sea ice, land ice) real, pointer, dimension(:,:) :: p_surf_full => NULL() @@ -150,7 +187,8 @@ module MOM_forcing_type ! tide related inputs real, pointer, dimension(:,:) :: & - TKE_tidal => NULL(), & !< tidal energy source driving mixing in bottom boundary layer [R Z3 T-3 ~> W m-2] + BBL_tidal_dis => NULL(), & !< Tidal energy dissipation in the bottom boundary layer that can act + !! as a source of energy for bottom boundary layer mixing [R Z L2 T-3 ~> W m-2] ustar_tidal => NULL() !< tidal contribution to bottom ustar [Z T-1 ~> m s-1] ! iceberg related inputs @@ -168,11 +206,14 @@ module MOM_forcing_type !! exactly 0 away from shelves or on land. real, pointer, dimension(:,:) :: iceshelf_melt => NULL() !< Ice shelf melt rate (positive) !! or freezing (negative) [R Z T-1 ~> kg m-2 s-1] + real, pointer, dimension(:,:) :: shelf_sfc_mass_flux => NULL() !< Ice shelf surface mass flux + !! deposition from the atmosphere. [R Z T-1 ~> kg m-2 s-1] ! Scalars set by surface forcing modules - real :: vPrecGlobalAdj = 0. !< adjustment to restoring vprec to zero out global net [kg m-2 s-1] - real :: saltFluxGlobalAdj = 0. !< adjustment to restoring salt flux to zero out global net [kgSalt m-2 s-1] - real :: netFWGlobalAdj = 0. !< adjustment to net fresh water to zero out global net [kg m-2 s-1] + real :: vPrecGlobalAdj = 0. !< adjustment to restoring vprec to zero out global net [R Z T-1 ~> kg m-2 s-1] + real :: saltFluxGlobalAdj = 0. !< adjustment to restoring salt flux to zero out global + !! net [R Z T-1 ~> kgSalt m-2 s-1] + real :: netFWGlobalAdj = 0. !< adjustment to net fresh water to zero out global net [R Z T-1 ~> kg m-2 s-1] real :: vPrecGlobalScl = 0. !< scaling of restoring vprec to zero out global net ( -1..1 ) [nondim] real :: saltFluxGlobalScl = 0. !< scaling of restoring salt flux to zero out global net ( -1..1 ) [nondim] real :: netFWGlobalScl = 0. !< scaling of net fresh water to zero out global net ( -1..1 ) [nondim] @@ -184,16 +225,27 @@ module MOM_forcing_type !! type variable has not yet been initialized. logical :: gustless_accum_bug = .true. !< If true, use an incorrect expression in the time !! average of the gustless wind stress. - real :: C_p !< heat capacity of seawater [Q degC-1 ~> J kg-1 degC-1]. - !! C_p is is the same value as in thermovar_ptrs_type. + real :: C_p !< heat capacity of seawater [Q C-1 ~> J kg-1 degC-1]. + !! C_p is is the same value as in thermovar_ptrs_type. - ! CFC-related arrays needed in the MOM_CFC_cap module + ! arrays needed in the some tracer modules, e.g., MOM_CFC_cap real, pointer, dimension(:,:) :: & - cfc11_flux => NULL(), & !< flux of cfc_11 into the ocean [CU R Z T-1 kg m-3 ~> mol m-2 s-1] - cfc12_flux => NULL(), & !< flux of cfc_12 into the ocean [CU R Z T-1 kg m-3 ~> mol m-2 s-1] ice_fraction => NULL(), & !< fraction of sea ice coverage at h-cells, from 0 to 1 [nondim]. u10_sqr => NULL() !< wind magnitude at 10 m squared [L2 T-2 ~> m2 s-2] + ! Forcing fields required for MARBL + real, pointer, dimension(:,:) :: & + noy_dep => NULL(), & !< NOy Deposition [conc Z T-1 ~> conc m s-1] + nhx_dep => NULL(), & !< NHx Deposition [conc Z T-1 ~> conc m s-1] + atm_co2 => NULL(), & !< Atmospheric CO2 Concentration [ppm] + atm_alt_co2 => NULL(), & !< Alternate atmospheric CO2 Concentration [ppm] + dust_flux => NULL(), & !< Flux of dust into the ocean [R Z T-1 ~> kgN m-2 s-1] + iron_flux => NULL() !< Flux of dust into the ocean [conc Z T-1 ~> conc m s-1] + + real, pointer, dimension(:,:,:) :: & + fracr_cat => NULL(), & !< per-category ice fraction [nondim] + qsw_cat => NULL() !< per-category shortwave [Q R Z T-1 ~> W m-2] + real, pointer, dimension(:,:) :: & lamult => NULL() !< Langmuir enhancement factor [nondim] @@ -218,8 +270,12 @@ module MOM_forcing_type real, pointer, dimension(:,:) :: & taux => NULL(), & !< zonal wind stress [R L Z T-2 ~> Pa] tauy => NULL(), & !< meridional wind stress [R L Z T-2 ~> Pa] + tau_mag => NULL(), & !< Magnitude of the wind stress averaged over tracer cells, including any + !! contributions from sub-gridscale variability or gustiness [R L Z T-2 ~> Pa] ustar => NULL(), & !< surface friction velocity scale [Z T-1 ~> m s-1]. - net_mass_src => NULL() !< The net mass source to the ocean [R Z T-1 ~> kg m-2 s-1] + net_mass_src => NULL(), & !< The net mass source to the ocean [R Z T-1 ~> kg m-2 s-1] + omega_w2x => NULL() !< the counter-clockwise angle of the wind stress with respect + !! to the horizontal abscissa (x-coordinate) at tracer points [rad]. ! applied surface pressure from other component models (e.g., atmos, sea ice, land ice) real, pointer, dimension(:,:) :: p_surf_full => NULL() @@ -251,7 +307,7 @@ module MOM_forcing_type rigidity_ice_v => NULL() !< Depth-integrated lateral viscosity of ice shelves or sea ice at !! v-points [L4 Z-1 T-1 ~> m3 s-1] real :: dt_force_accum = -1.0 !< The amount of time over which the mechanical forcing fluxes - !! have been averaged [s]. + !! have been averaged [T ~> s]. logical :: net_mass_src_set = .false. !< If true, an estimate of net_mass_src has been provided. logical :: accumulate_p_surf = .false. !< If true, the surface pressure due to the atmosphere !! and various types of ice needs to be accumulated, and the @@ -260,16 +316,13 @@ module MOM_forcing_type logical :: accumulate_rigidity = .false. !< If true, the rigidity due to various types of !! ice needs to be accumulated, and the rigidity explicitly !! reset to zero at the driver level when appropriate. - real, pointer, dimension(:,:) :: & - ustk0 => NULL(), & !< Surface Stokes drift, zonal [m s-1] - vstk0 => NULL() !< Surface Stokes drift, meridional [m s-1] real, pointer, dimension(:) :: & - stk_wavenumbers => NULL() !< The central wave number of Stokes bands [rad m-1] + stk_wavenumbers => NULL() !< The central wave number of Stokes bands [rad Z-1 ~> rad m-1] real, pointer, dimension(:,:,:) :: & - ustkb => NULL(), & !< Stokes Drift spectrum, zonal [m s-1] + ustkb => NULL(), & !< Stokes Drift spectrum, zonal [L T-1 ~> m s-1] !! Horizontal - u points !! 3rd dimension - wavenumber - vstkb => NULL() !< Stokes Drift spectrum, meridional [m s-1] + vstkb => NULL() !< Stokes Drift spectrum, meridional [L T-1 ~> m s-1] !! Horizontal - v points !! 3rd dimension - wavenumber @@ -277,7 +330,7 @@ module MOM_forcing_type end type mech_forcing !> Structure that defines the id handles for the forcing type -type, public :: forcing_diags +type, public :: forcing_diags ; private !>@{ Forcing diagnostic handles ! mass flux diagnostic handles @@ -285,6 +338,7 @@ module MOM_forcing_type integer :: id_precip = -1, id_vprec = -1 integer :: id_lprec = -1, id_fprec = -1 integer :: id_lrunoff = -1, id_frunoff = -1 + integer :: id_lrunoff_glc = -1, id_frunoff_glc = -1 integer :: id_net_massout = -1, id_net_massin = -1 integer :: id_massout_flux = -1, id_massin_flux = -1 integer :: id_seaice_melt = -1 @@ -294,6 +348,7 @@ module MOM_forcing_type integer :: id_total_precip = -1, id_total_vprec = -1 integer :: id_total_lprec = -1, id_total_fprec = -1 integer :: id_total_lrunoff = -1, id_total_frunoff = -1 + integer :: id_total_lrunoff_glc = -1, id_total_frunoff_glc = -1 integer :: id_total_net_massout = -1, id_total_net_massin = -1 integer :: id_total_seaice_melt = -1 @@ -303,32 +358,39 @@ module MOM_forcing_type integer :: id_precip_ga = -1, id_vprec_ga= -1 ! heat flux diagnostic handles - integer :: id_net_heat_coupler = -1, id_net_heat_surface = -1 - integer :: id_sens = -1, id_LwLatSens = -1 - integer :: id_sw = -1, id_lw = -1 - integer :: id_sw_vis = -1, id_sw_nir = -1 - integer :: id_lat_evap = -1, id_lat_frunoff = -1 - integer :: id_lat = -1, id_lat_fprec = -1 - integer :: id_heat_content_lrunoff= -1, id_heat_content_frunoff = -1 - integer :: id_heat_content_lprec = -1, id_heat_content_fprec = -1 - integer :: id_heat_content_cond = -1, id_heat_content_surfwater= -1 - integer :: id_heat_content_vprec = -1, id_heat_content_massout = -1 - integer :: id_heat_added = -1, id_heat_content_massin = -1 - integer :: id_hfrainds = -1, id_hfrunoffds = -1 - integer :: id_seaice_melt_heat = -1, id_heat_content_icemelt = -1 + integer :: id_net_heat_coupler = -1, id_net_heat_surface = -1 + integer :: id_sens = -1, id_LwLatSens = -1 + integer :: id_sw = -1, id_lw = -1 + integer :: id_sw_vis = -1, id_sw_nir = -1 + integer :: id_lat_evap = -1, id_lat_frunoff = -1 + integer :: id_lat_frunoff_glc = -1 + integer :: id_lat = -1, id_lat_fprec = -1 + integer :: id_heat_content_lrunoff = -1, id_heat_content_frunoff = -1 + integer :: id_heat_content_lrunoff_glc= -1, id_heat_content_frunoff_glc= -1 + integer :: id_heat_content_lprec = -1, id_heat_content_fprec = -1 + integer :: id_heat_content_cond = -1, id_heat_content_surfwater = -1 + integer :: id_heat_content_evap = -1 + integer :: id_heat_content_vprec = -1, id_heat_content_massout = -1 + integer :: id_heat_added = -1, id_heat_content_massin = -1 + integer :: id_hfrainds = -1, id_hfrunoffds = -1 + integer :: id_seaice_melt_heat = -1 + integer :: id_carbon_content_lrunoff = -1 ! global area integrated heat flux diagnostic handles - integer :: id_total_net_heat_coupler = -1, id_total_net_heat_surface = -1 - integer :: id_total_sens = -1, id_total_LwLatSens = -1 - integer :: id_total_sw = -1, id_total_lw = -1 - integer :: id_total_lat_evap = -1, id_total_lat_frunoff = -1 - integer :: id_total_lat = -1, id_total_lat_fprec = -1 - integer :: id_total_heat_content_lrunoff= -1, id_total_heat_content_frunoff = -1 - integer :: id_total_heat_content_lprec = -1, id_total_heat_content_fprec = -1 - integer :: id_total_heat_content_cond = -1, id_total_heat_content_surfwater= -1 - integer :: id_total_heat_content_vprec = -1, id_total_heat_content_massout = -1 - integer :: id_total_heat_added = -1, id_total_heat_content_massin = -1 - integer :: id_total_seaice_melt_heat = -1, id_total_heat_content_icemelt = -1 + integer :: id_total_net_heat_coupler = -1, id_total_net_heat_surface = -1 + integer :: id_total_sens = -1, id_total_LwLatSens = -1 + integer :: id_total_sw = -1, id_total_lw = -1 + integer :: id_total_lat_evap = -1, id_total_lat_frunoff = -1 + integer :: id_total_lat_frunoff_glc = -1 + integer :: id_total_lat = -1, id_total_lat_fprec = -1 + integer :: id_total_heat_content_lrunoff = -1, id_total_heat_content_frunoff = -1 + integer :: id_total_heat_content_lrunoff_glc= -1, id_total_heat_content_frunoff_glc=-1 + integer :: id_total_heat_content_lprec = -1, id_total_heat_content_fprec = -1 + integer :: id_total_heat_content_cond = -1, id_total_heat_content_surfwater = -1 + integer :: id_total_heat_content_evap = -1 + integer :: id_total_heat_content_vprec = -1, id_total_heat_content_massout = -1 + integer :: id_total_heat_added = -1, id_total_heat_content_massin = -1 + integer :: id_total_seaice_melt_heat = -1 ! global area averaged heat flux diagnostic handles integer :: id_net_heat_coupler_ga = -1, id_net_heat_surface_ga = -1 @@ -340,6 +402,7 @@ module MOM_forcing_type integer :: id_saltflux = -1 integer :: id_saltFluxIn = -1 integer :: id_saltFluxAdded = -1 + integer :: id_saltFluxBehind = -1 integer :: id_total_saltflux = -1 integer :: id_total_saltFluxIn = -1 @@ -356,14 +419,13 @@ module MOM_forcing_type integer :: id_taux = -1 integer :: id_tauy = -1 integer :: id_ustar = -1 - + integer :: id_omega_w2x = -1 + integer :: id_tau_mag = -1 integer :: id_psurf = -1 integer :: id_TKE_tidal = -1 integer :: id_buoy = -1 - ! cfc-related diagnostics handles - integer :: id_cfc11 = -1 - integer :: id_cfc12 = -1 + ! tracer surface flux related diagnostics handles integer :: id_ice_fraction = -1 integer :: id_u10_sqr = -1 @@ -375,7 +437,6 @@ module MOM_forcing_type ! Iceberg + Ice shelf diagnostic handles integer :: id_ustar_ice_cover = -1 integer :: id_frac_ice_cover = -1 - ! wave forcing diagnostics handles. integer :: id_lamult = -1 !>@} @@ -412,7 +473,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: h !< layer thickness [H ~> m or kg m-2] real, dimension(SZI_(G),SZK_(GV)), & - intent(in) :: T !< layer temperatures [degC] + intent(in) :: T !< layer temperatures [C ~> degC] real, dimension(SZI_(G)), intent(out) :: netMassInOut !< net mass flux (non-Bouss) or volume flux !! (if Bouss) of water in/out of ocean over !! a time step [H ~> m or kg m-2] @@ -426,12 +487,12 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & !! (1) downwelling (penetrative) SW, !! (2) evaporation heat content, !! (since do not yet know evap temperature). - !! [degC H ~> degC m or degC kg m-2]. + !! [C H ~> degC m or degC kg m-2]. real, dimension(SZI_(G)), intent(out) :: net_salt !< surface salt flux into the ocean !! accumulated over a time step - !! [ppt H ~> ppt m or ppt kg m-2]. + !! [S H ~> ppt m or ppt kg m-2]. real, dimension(max(1,nsw),G%isd:G%ied), intent(out) :: pen_SW_bnd !< penetrating SW flux, split into bands. - !! [degC H ~> degC m or degC kg m-2] + !! [C H ~> degC m or degC kg m-2] !! and array size nsw x SZI_(G), where !! nsw=number of SW bands in pen_SW_bnd. !! This heat flux is not part of net_heat. @@ -442,33 +503,34 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & logical, intent(in) :: aggregate_FW !< For determining how to aggregate forcing. real, dimension(SZI_(G)), & optional, intent(out) :: nonpenSW !< Non-penetrating SW used in net_heat - !! [degC H ~> degC m or degC kg m-2]. + !! [C H ~> degC m or degC kg m-2]. !! Summed over SW bands when diagnosing nonpenSW. real, dimension(SZI_(G)), & optional, intent(out) :: net_Heat_rate !< Rate of net surface heating - !! [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1]. + !! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1]. real, dimension(SZI_(G)), & optional, intent(out) :: net_salt_rate !< Surface salt flux into the ocean - !! [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1]. + !! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1]. real, dimension(SZI_(G)), & optional, intent(out) :: netmassInOut_rate !< Rate of net mass flux into the ocean !! [H T-1 ~> m s-1 or kg m-2 s-1]. real, dimension(max(1,nsw),G%isd:G%ied), & optional, intent(out) :: pen_sw_bnd_rate !< Rate of penetrative shortwave heating - !! [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1]. + !! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1]. ! local real :: htot(SZI_(G)) ! total ocean depth [H ~> m or kg m-2] - real :: Pen_sw_tot(SZI_(G)) ! sum across all bands of Pen_SW [degC H ~> degC m or degC kg m-2]. + real :: Pen_sw_tot(SZI_(G)) ! sum across all bands of Pen_SW [C H ~> degC m or degC kg m-2]. real :: pen_sw_tot_rate(SZI_(G)) ! Summed rate of shortwave heating across bands - ! [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] + ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] real :: Ih_limit ! inverse depth at which surface fluxes start to be limited ! or 0 for no limiting [H-1 ~> m-1 or m2 kg-1] real :: scale ! scale scales away fluxes if depth < FluxRescaleDepth [nondim] - real :: I_Cp ! 1.0 / C_p [degC Q-1 ~> kg degC J-1] + real :: I_Cp ! 1.0 / C_p [C Q-1 ~> kg degC J-1] real :: I_Cp_Hconvert ! Unit conversion factors divided by the heat capacity - ! [degC H R-1 Z-1 Q-1 ~> degC m3 J-1 or kg degC J-1] + ! [C H R-1 Z-1 Q-1 ~> degC m3 J-1 or kg degC J-1] logical :: calculate_diags ! Indicate to calculate/update diagnostic arrays + logical :: do_enthalpy ! If true (default) enthalpy terms are computed in MOM6 character(len=200) :: mesg integer :: is, ie, nz, i, k, n @@ -488,9 +550,16 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & if (present(pen_sw_bnd_rate)) do_PSWBR = .true. !}BGR + ! GMM: by default heat content from mass entering and leaving the ocean (enthalpy) + ! is diagnosed in this subroutine. When heat_content_evap is associated, + ! the enthalpy terms are provided via coupler and, therefore, they do not need + ! to be computed again. + do_enthalpy = .true. + if (associated(fluxes%heat_content_evap)) do_enthalpy = .false. + Ih_limit = 0.0 ; if (FluxRescaleDepth > 0.0) Ih_limit = 1.0 / FluxRescaleDepth - I_Cp = 1.0 / fluxes%C_p - I_Cp_Hconvert = 1.0 / (GV%H_to_RZ * fluxes%C_p) + I_Cp = 1.0 / tv%C_p + I_Cp_Hconvert = 1.0 / (GV%H_to_RZ * tv%C_p) is = G%isc ; ie = G%iec ; nz = GV%ke @@ -536,7 +605,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & scale = 1.0 ; if ((Ih_limit > 0.0) .and. (htot(i)*Ih_limit < 1.0)) scale = htot(i)*Ih_limit - ! Convert the penetrating shortwave forcing to (K * H) and reduce fluxes for shallow depths. + ! Convert the penetrating shortwave forcing to (C * H) and reduce fluxes for shallow depths. ! (H=m for Bouss, H=kg/m2 for non-Bouss) Pen_sw_tot(i) = 0.0 if (nsw >= 1) then @@ -562,23 +631,27 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & ! net volume/mass of liquid and solid passing through surface boundary fluxes netMassInOut(i) = dt * (scale * & - (((((( fluxes%lprec(i,j) & + (((((((( fluxes%lprec(i,j) & + fluxes%fprec(i,j) ) & + fluxes%evap(i,j) ) & + fluxes%lrunoff(i,j) ) & + + fluxes%lrunoff_glc(i,j)) & + fluxes%vprec(i,j) ) & + fluxes%seaice_melt(i,j)) & - + fluxes%frunoff(i,j) )) + + fluxes%frunoff(i,j) ) & + + fluxes%frunoff_glc(i,j))) if (do_NMIOr) then ! Repeat the above code without multiplying by a timestep for legacy reasons netMassInOut_rate(i) = (scale * & - (((((( fluxes%lprec(i,j) & + (((((((( fluxes%lprec(i,j) & + fluxes%fprec(i,j) ) & + fluxes%evap(i,j) ) & + fluxes%lrunoff(i,j) ) & + + fluxes%lrunoff_glc(i,j)) & + fluxes%vprec(i,j) ) & + fluxes%seaice_melt(i,j)) & - + fluxes%frunoff(i,j) )) + + fluxes%frunoff(i,j) ) & + + fluxes%frunoff_glc(i,j))) endif ! smg: @@ -598,7 +671,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & ! evap > 0 means condensating water is added into ocean. ! evap < 0 means evaporation of water from the ocean, in - ! which case heat_content_evap is computed in MOM_diabatic_driver.F90 + ! which case heat_content_massout is computed in MOM_diabatic_driver.F90 if (fluxes%evap(i,j) < 0.0) netMassOut(i) = netMassOut(i) + fluxes%evap(i,j) ! if (associated(fluxes%heat_content_cond)) fluxes%heat_content_cond(i,j) = 0.0 !??? --AJA @@ -624,6 +697,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & ! (H=m for Bouss, H=kg/m2 for non-Bouss) ! CIME provides heat flux from snow&ice melt (seaice_melt_heat), so this is added below + ! Note: this term accounts for the enthalpy associated with water flux due to sea ice melting/freezing if (associated(fluxes%seaice_melt_heat)) then net_heat(i) = scale * dt * I_Cp_Hconvert * & ( fluxes%sw(i,j) + (((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) + & @@ -652,6 +726,8 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & ! remove lrunoff*SST here, to counteract its addition elsewhere net_heat(i) = (net_heat(i) + (scale*(dt * I_Cp_Hconvert)) * fluxes%heat_content_lrunoff(i,j)) - & (GV%RZ_to_H * (scale * dt)) * fluxes%lrunoff(i,j) * T(i,1) + net_heat(i) = (net_heat(i) + (scale*(dt * I_Cp_Hconvert)) * fluxes%heat_content_lrunoff_glc(i,j)) - & + (GV%RZ_to_H * (scale * dt)) * fluxes%lrunoff_glc(i,j) * T(i,1) !BGR-Jul 5, 2017{ !Intentionally neglect the following contribution to rate for legacy reasons. !if (do_NHR) net_heat_rate(i) = (net_heat_rate(i) + (scale*I_Cp_Hconvert) * fluxes%heat_content_lrunoff(i,j)) - & @@ -660,6 +736,8 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & if (calculate_diags .and. associated(tv%TempxPmE)) then tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + (scale * dt) * & (I_Cp*fluxes%heat_content_lrunoff(i,j) - fluxes%lrunoff(i,j)*T(i,1)) + tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + (scale * dt) * & + (I_Cp*fluxes%heat_content_lrunoff_glc(i,j) - fluxes%lrunoff_glc(i,j)*T(i,1)) endif endif @@ -669,6 +747,8 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & ! remove frunoff*SST here, to counteract its addition elsewhere net_heat(i) = net_heat(i) + (scale*(dt * I_Cp_Hconvert)) * fluxes%heat_content_frunoff(i,j) - & (GV%RZ_to_H * (scale * dt)) * fluxes%frunoff(i,j) * T(i,1) + net_heat(i) = net_heat(i) + (scale*(dt * I_Cp_Hconvert)) * fluxes%heat_content_frunoff_glc(i,j) - & + (GV%RZ_to_H * (scale * dt)) * fluxes%frunoff_glc(i,j) * T(i,1) !BGR-Jul 5, 2017{ !Intentionally neglect the following contribution to rate for legacy reasons. ! if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale*I_Cp_Hconvert) * fluxes%heat_content_frunoff(i,j) - & @@ -677,6 +757,8 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & if (calculate_diags .and. associated(tv%TempxPmE)) then tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + (scale * dt) * & (I_Cp*fluxes%heat_content_frunoff(i,j) - fluxes%frunoff(i,j)*T(i,1)) + tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + (scale * dt) * & + (I_Cp*fluxes%heat_content_frunoff_glc(i,j) - fluxes%frunoff_glc(i,j)*T(i,1)) endif endif @@ -696,13 +778,22 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & ! (fluxes%heat_content_cond(i,j) + fluxes%heat_content_vprec(i,j)))))) ! endif + ! When enthalpy terms are provided via coupler, they must be included in net_heat + if (.not. do_enthalpy) then + net_heat(i) = net_heat(i) + (scale * dt * I_Cp_Hconvert * & + ((((fluxes%heat_content_lrunoff(i,j) + fluxes%heat_content_frunoff(i,j)) + & + (fluxes%heat_content_lrunoff_glc(i,j) + fluxes%heat_content_frunoff_glc(i,j))) + & + (fluxes%heat_content_lprec(i,j) + fluxes%heat_content_fprec(i,j))) + & + (fluxes%heat_content_evap(i,j) + fluxes%heat_content_cond(i,j)))) + endif + if (fluxes%num_msg < fluxes%max_msg) then if (Pen_SW_tot(i) > 1.000001 * I_Cp_Hconvert*scale*dt*fluxes%sw(i,j)) then fluxes%num_msg = fluxes%num_msg + 1 write(mesg,'("Penetrating shortwave of ",1pe17.10, & &" exceeds total shortwave of ",1pe17.10,& - &" at ",1pg11.4,"E, "1pg11.4,"N.")') & - Pen_SW_tot(i), I_Cp_Hconvert*scale*dt * fluxes%sw(i,j), & + &" at ",1pg11.4,",E,",1pg11.4,"N.")') & + US%C_to_degC*Pen_SW_tot(i), US%C_to_degC*I_Cp_Hconvert*scale*dt * fluxes%sw(i,j), & G%geoLonT(i,j), G%geoLatT(i,j) call MOM_error(WARNING,mesg) endif @@ -720,28 +811,28 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & endif ! Salt fluxes - Net_salt(i) = 0.0 - if (do_NSR) Net_salt_rate(i) = 0.0 + net_salt(i) = 0.0 + if (do_NSR) net_salt_rate(i) = 0.0 ! Convert salt_flux from kg (salt)/(m^2 * s) to ! Boussinesq: (ppt * m) ! non-Bouss: (g/m^2) if (associated(fluxes%salt_flux)) then - Net_salt(i) = (scale * dt * (1000.0 * fluxes%salt_flux(i,j))) * GV%RZ_to_H + net_salt(i) = (scale * dt * (1000.0*US%ppt_to_S * fluxes%salt_flux(i,j))) * GV%RZ_to_H !Repeat above code for 'rate' term - if (do_NSR) Net_salt_rate(i) = (scale * 1. * (1000.0 * fluxes%salt_flux(i,j))) * GV%RZ_to_H + if (do_NSR) net_salt_rate(i) = (scale * 1. * (1000.0*US%ppt_to_S * fluxes%salt_flux(i,j))) * GV%RZ_to_H endif ! Diagnostics follow... - if (calculate_diags) then + if (calculate_diags .and. do_enthalpy) then ! Initialize heat_content_massin that is diagnosed in mixedlayer_convection or ! applyBoundaryFluxes such that the meaning is as the sum of all incoming components. if (associated(fluxes%heat_content_massin)) then if (aggregate_FW) then if (netMassInOut(i) > 0.0) then ! net is "in" - fluxes%heat_content_massin(i,j) = -fluxes%C_p * netMassOut(i) * T(i,1) * GV%H_to_RZ / dt + fluxes%heat_content_massin(i,j) = -tv%C_p * netMassOut(i) * T(i,1) * GV%H_to_RZ / dt else ! net is "out" - fluxes%heat_content_massin(i,j) = fluxes%C_p * ( netMassInout(i) - netMassOut(i) ) * & + fluxes%heat_content_massin(i,j) = tv%C_p * ( netMassInout(i) - netMassOut(i) ) * & T(i,1) * GV%H_to_RZ / dt endif else @@ -754,9 +845,9 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & if (associated(fluxes%heat_content_massout)) then if (aggregate_FW) then if (netMassInOut(i) > 0.0) then ! net is "in" - fluxes%heat_content_massout(i,j) = fluxes%C_p * netMassOut(i) * T(i,1) * GV%H_to_RZ / dt + fluxes%heat_content_massout(i,j) = tv%C_p * netMassOut(i) * T(i,1) * GV%H_to_RZ / dt else ! net is "out" - fluxes%heat_content_massout(i,j) = -fluxes%C_p * ( netMassInout(i) - netMassOut(i) ) * & + fluxes%heat_content_massout(i,j) = -tv%C_p * ( netMassInout(i) - netMassOut(i) ) * & T(i,1) * GV%H_to_RZ / dt endif else @@ -773,7 +864,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & ! wait until MOM_diabatic_driver.F90. if (associated(fluxes%heat_content_lprec)) then if (fluxes%lprec(i,j) > 0.0) then - fluxes%heat_content_lprec(i,j) = fluxes%C_p*fluxes%lprec(i,j)*T(i,1) + fluxes%heat_content_lprec(i,j) = tv%C_p*fluxes%lprec(i,j)*T(i,1) else fluxes%heat_content_lprec(i,j) = 0.0 endif @@ -784,27 +875,18 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & ! and until we do so fprec is treated like lprec and enters at SST. -AJA if (associated(fluxes%heat_content_fprec)) then if (fluxes%fprec(i,j) > 0.0) then - fluxes%heat_content_fprec(i,j) = fluxes%C_p*fluxes%fprec(i,j)*T(i,1) + fluxes%heat_content_fprec(i,j) = tv%C_p*fluxes%fprec(i,j)*T(i,1) else fluxes%heat_content_fprec(i,j) = 0.0 endif endif - ! Following lprec and fprec, water flux due to sea ice melt (seaice_melt) enters at SST - GMM - if (associated(fluxes%heat_content_icemelt)) then - if (fluxes%seaice_melt(i,j) > 0.0) then - fluxes%heat_content_icemelt(i,j) = fluxes%C_p*fluxes%seaice_melt(i,j)*T(i,1) - else - fluxes%heat_content_icemelt(i,j) = 0.0 - endif - endif - ! virtual precip associated with salinity restoring ! vprec > 0 means add water to ocean, assumed to be at SST ! vprec < 0 means remove water from ocean; set heat_content_vprec in MOM_diabatic_driver.F90 if (associated(fluxes%heat_content_vprec)) then if (fluxes%vprec(i,j) > 0.0) then - fluxes%heat_content_vprec(i,j) = fluxes%C_p*fluxes%vprec(i,j)*T(i,1) + fluxes%heat_content_vprec(i,j) = tv%C_p*fluxes%vprec(i,j)*T(i,1) else fluxes%heat_content_vprec(i,j) = 0.0 endif @@ -818,7 +900,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & ! Condensation is assumed to drop into the ocean at the SST, just like lprec. if (associated(fluxes%heat_content_cond)) then if (fluxes%evap(i,j) > 0.0) then - fluxes%heat_content_cond(i,j) = fluxes%C_p*fluxes%evap(i,j)*T(i,1) + fluxes%heat_content_cond(i,j) = tv%C_p*fluxes%evap(i,j)*T(i,1) else fluxes%heat_content_cond(i,j) = 0.0 endif @@ -827,18 +909,46 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & ! Liquid runoff enters ocean at SST if land model does not provide runoff heat content. if (.not. useRiverHeatContent) then if (associated(fluxes%lrunoff) .and. associated(fluxes%heat_content_lrunoff)) then - fluxes%heat_content_lrunoff(i,j) = fluxes%C_p*fluxes%lrunoff(i,j)*T(i,1) + fluxes%heat_content_lrunoff(i,j) = tv%C_p*fluxes%lrunoff(i,j)*T(i,1) + endif + if (associated(fluxes%lrunoff_glc) .and. associated(fluxes%heat_content_lrunoff_glc)) then + fluxes%heat_content_lrunoff_glc(i,j) = tv%C_p*fluxes%lrunoff_glc(i,j)*T(i,1) endif endif ! Icebergs enter ocean at SST if land model does not provide calving heat content. if (.not. useCalvingHeatContent) then if (associated(fluxes%frunoff) .and. associated(fluxes%heat_content_frunoff)) then - fluxes%heat_content_frunoff(i,j) = fluxes%C_p*fluxes%frunoff(i,j)*T(i,1) + fluxes%heat_content_frunoff(i,j) = tv%C_p*fluxes%frunoff(i,j)*T(i,1) + endif + if (associated(fluxes%frunoff_glc) .and. associated(fluxes%heat_content_frunoff_glc)) then + fluxes%heat_content_frunoff_glc(i,j) = tv%C_p*fluxes%frunoff_glc(i,j)*T(i,1) endif endif - endif ! calculate_diags + elseif (.not. do_enthalpy) then + + ! virtual precip associated with salinity restoring. Heat content associated with + ! that is *not* provided by the coupler and must be calculated by MOM6. + ! vprec > 0 means add water to ocean, assumed to be at SST + ! vprec < 0 means remove water from ocean; set heat_content_vprec in MOM_diabatic_driver.F90 + if (associated(fluxes%heat_content_vprec)) then + if (fluxes%vprec(i,j) > 0.0) then + fluxes%heat_content_vprec(i,j) = fluxes%C_p*fluxes%vprec(i,j)*T(i,1) + else + fluxes%heat_content_vprec(i,j) = 0.0 + endif + endif + + if (associated(tv%TempxPmE)) then + tv%TempxPmE(i,j) = (I_Cp*dt*scale) * & + ((((fluxes%heat_content_lprec(i,j) + fluxes%heat_content_fprec(i,j)) + & + (fluxes%heat_content_lrunoff(i,j) + fluxes%heat_content_frunoff(i,j))) + & + (fluxes%heat_content_lrunoff_glc(i,j) + fluxes%heat_content_frunoff_glc(i,j))) + & + (fluxes%heat_content_evap(i,j) + fluxes%heat_content_cond(i,j))) + endif + + endif ! calculate_diags and do_enthalpy enddo ! i-loop @@ -867,7 +977,7 @@ subroutine extractFluxes2d(G, GV, US, fluxes, optics, nsw, dt, FluxRescaleDepth, real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< layer thickness [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: T !< layer temperatures [degC] + intent(in) :: T !< layer temperatures [C ~> degC] real, dimension(SZI_(G),SZJ_(G)), intent(out) :: netMassInOut !< net mass flux (non-Bouss) or volume flux !! (if Bouss) of water in/out of ocean over !! a time step [H ~> m or kg m-2] @@ -880,11 +990,11 @@ subroutine extractFluxes2d(G, GV, US, fluxes, optics, nsw, dt, FluxRescaleDepth, !! (1) downwelling (penetrative) SW, !! (2) evaporation heat content, !! (since do not yet know temperature of evap). - !! [degC H ~> degC m or degC kg m-2] + !! [C H ~> degC m or degC kg m-2] real, dimension(SZI_(G),SZJ_(G)), intent(out) :: net_salt !< surface salt flux into the ocean accumulated - !! over a time step [ppt H ~> ppt m or ppt kg m-2] + !! over a time step [S H ~> ppt m or ppt kg m-2] real, dimension(max(1,nsw),G%isd:G%ied,G%jsd:G%jed), intent(out) :: pen_SW_bnd !< penetrating SW flux, by frequency - !! band [degC H ~> degC m or degC kg m-2] with array + !! band [C H ~> degC m or degC kg m-2] with array !! size nsw x SZI_(G), where nsw=number of SW bands !! in pen_SW_bnd. This heat flux is not in net_heat. type(thermo_var_ptrs), intent(inout) :: tv !< structure containing pointers to available @@ -918,34 +1028,41 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt type(optics_type), pointer :: optics !< penetrating SW optics integer, intent(in) :: nsw !< The number of frequency bands of !! penetrating shortwave radiation - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: Temp !< prognostic temp [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: Salt !< salinity [ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: Temp !< prognostic temp [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: Salt !< salinity [S ~> ppt] type(thermo_var_ptrs), intent(inout) :: tv !< thermodynamics type integer, intent(in) :: j !< j-row to work on real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: buoyancyFlux !< buoyancy fluxes [L2 T-3 ~> m2 s-3] real, dimension(SZI_(G)), intent(out) :: netHeatMinusSW !< Surface heat flux excluding shortwave - !! [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] + !! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] real, dimension(SZI_(G)), intent(out) :: netSalt !< surface salt flux - !! [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + !! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] ! local variables real, dimension(SZI_(G)) :: netH ! net FW flux [H T-1 ~> m s-1 or kg m-2 s-1] real, dimension(SZI_(G)) :: netEvap ! net FW flux leaving ocean via evaporation ! [H T-1 ~> m s-1 or kg m-2 s-1] - real, dimension(SZI_(G)) :: netHeat ! net temp flux [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] + real, dimension(SZI_(G)) :: netHeat ! net temp flux [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + real, dimension(SZI_(G), SZK_(GV)) :: dz ! Layer thicknesses in depth units [Z ~> m] real, dimension(max(nsw,1), SZI_(G)) :: penSWbnd ! penetrating SW radiation by band - ! [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] + ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] real, dimension(SZI_(G)) :: pressure ! pressure at the surface [R L2 T-2 ~> Pa] - real, dimension(SZI_(G)) :: dRhodT ! density partial derivative wrt temp [R degC-1 ~> kg m-3 degC-1] - real, dimension(SZI_(G)) :: dRhodS ! density partial derivative wrt saln [R ppt-1 ~> kg m-3 ppt-1] + real, dimension(SZI_(G)) :: dRhodT ! density partial derivative wrt temp [R C-1 ~> kg m-3 degC-1] + real, dimension(SZI_(G)) :: dRhodS ! density partial derivative wrt saln [R S-1 ~> kg m-3 ppt-1] + real, dimension(SZI_(G)) :: dSpV_dT ! Partial derivative of specific volume with respect + ! to temperature [R-1 C-1 ~> m3 kg-1 degC-1] + real, dimension(SZI_(G)) :: dSpV_dS ! Partial derivative of specific volume with respect + ! to salinity [R-1 S-1 ~> m3 kg-1 ppt-1] real, dimension(SZI_(G),SZK_(GV)+1) :: netPen ! The net penetrating shortwave radiation at each level - ! [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] + ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] logical :: useRiverHeatContent logical :: useCalvingHeatContent - real :: GoRho ! The gravitational acceleration divided by mean density times a - ! unit conversion factor [L2 H-1 R-1 T-2 ~> m4 kg-1 s-2 or m7 kg-2 s-2] + real :: GoRho ! The gravitational acceleration divided by mean density times a + ! unit conversion factor [L2 H-1 R-1 T-2 ~> m4 kg-1 s-2 or m7 kg-2 s-2] + real :: g_conv ! The gravitational acceleration times the conversion factors from non-Boussinesq + ! thickness units to mass per units area [R L2 H-1 T-2 ~> kg m-2 s-2 or m s-2] real :: H_limit_fluxes ! A depth scale that specifies when the ocean is shallow that ! it is necessary to eliminate fluxes [H ~> m or kg m-2] integer :: i, k @@ -955,15 +1072,12 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt useCalvingHeatContent = .False. H_limit_fluxes = max( GV%Angstrom_H, 1.e-30*GV%m_to_H ) - pressure(:) = 0. - if (associated(tv%p_surf)) then ; do i=G%isc,G%iec ; pressure(i) = tv%p_surf(i,j) ; enddo ; endif - GoRho = (GV%g_Earth * GV%H_to_Z) / GV%Rho0 ! The surface forcing is contained in the fluxes type. ! We aggregate the thermodynamic forcing for a time step into the following: ! netH = water added/removed via surface fluxes [H T-1 ~> m s-1 or kg m-2 s-1] - ! netHeat = heat via surface fluxes [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] - ! netSalt = salt via surface fluxes [ppt H T-1 ~> ppt m s-1 or gSalt m-2 s-1] + ! netHeat = heat via surface fluxes [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + ! netSalt = salt via surface fluxes [S H T-1 ~> ppt m s-1 or gSalt m-2 s-1] ! Note that unlike other calls to extractFLuxes1d() that return the time-integrated flux ! this call returns the rate because dt=1 (in arbitrary time units) call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, 1.0, & @@ -973,30 +1087,55 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt ! Sum over bands and attenuate as a function of depth ! netPen is the netSW as a function of depth - call sumSWoverBands(G, GV, US, h(:,j,:), optics_nbands(optics), optics, j, 1.0, & + call thickness_to_dz(h, tv, dz, j, G, GV) + call sumSWoverBands(G, GV, US, h(:,j,:), dz, optics_nbands(optics), optics, j, 1.0, & H_limit_fluxes, .true., penSWbnd, netPen) - ! Density derivatives - call calculate_density_derivs(Temp(:,j,1), Salt(:,j,1), pressure, dRhodT, dRhodS, & - tv%eqn_of_state, EOS_domain(G%HI)) - ! Adjust netSalt to reflect dilution effect of FW flux - ! [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + ! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] netSalt(G%isc:G%iec) = netSalt(G%isc:G%iec) - Salt(G%isc:G%iec,j,1) * netH(G%isc:G%iec) ! Add in the SW heating for purposes of calculating the net ! surface buoyancy flux affecting the top layer. - ! [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] + ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] !netHeat(:) = netHeatMinusSW(:) + sum( penSWbnd, dim=1 ) netHeat(G%isc:G%iec) = netHeatMinusSW(G%isc:G%iec) + netPen(G%isc:G%iec,1) - ! Convert to a buoyancy flux, excluding penetrating SW heating - buoyancyFlux(G%isc:G%iec,1) = - GoRho * ( dRhodS(G%isc:G%iec) * netSalt(G%isc:G%iec) + & - dRhodT(G%isc:G%iec) * netHeat(G%isc:G%iec) ) ! [L2 T-3 ~> m2 s-3] - ! We also have a penetrative buoyancy flux associated with penetrative SW - do k=2, GV%ke+1 - buoyancyFlux(G%isc:G%iec,k) = - GoRho * ( dRhodT(G%isc:G%iec) * netPen(G%isc:G%iec,k) ) ! [L2 T-3 ~> m2 s-3] - enddo + ! Determine the buoyancy flux + pressure(:) = 0. + if (associated(tv%p_surf)) then ; do i=G%isc,G%iec ; pressure(i) = tv%p_surf(i,j) ; enddo ; endif + + if ((.not.GV%Boussinesq) .and. (.not.GV%semi_Boussinesq)) then + g_conv = GV%g_Earth * GV%H_to_RZ + + ! Specific volume derivatives + call calculate_specific_vol_derivs(Temp(:,j,1), Salt(:,j,1), pressure, dSpV_dT, dSpV_dS, & + tv%eqn_of_state, EOS_domain(G%HI)) + + ! Convert to a buoyancy flux [L2 T-3 ~> m2 s-3], first excluding penetrating SW heating + do i=G%isc,G%iec + buoyancyFlux(i,1) = g_conv * (dSpV_dS(i) * netSalt(i) + dSpV_dT(i) * netHeat(i)) + enddo + ! We also have a penetrative buoyancy flux associated with penetrative SW + do k=2,GV%ke+1 ; do i=G%isc,G%iec + buoyancyFlux(i,k) = g_conv * ( dSpV_dT(i) * netPen(i,k) ) ! [L2 T-3 ~> m2 s-3] + enddo ; enddo + else + GoRho = (GV%g_Earth * GV%H_to_Z) / GV%Rho0 + + ! Density derivatives + call calculate_density_derivs(Temp(:,j,1), Salt(:,j,1), pressure, dRhodT, dRhodS, & + tv%eqn_of_state, EOS_domain(G%HI)) + + ! Convert to a buoyancy flux [L2 T-3 ~> m2 s-3], excluding penetrating SW heating + do i=G%isc,G%iec + buoyancyFlux(i,1) = - GoRho * ( dRhodS(i) * netSalt(i) + dRhodT(i) * netHeat(i) ) + enddo + ! We also have a penetrative buoyancy flux associated with penetrative SW + do k=2,GV%ke+1 ; do i=G%isc,G%iec + buoyancyFlux(i,k) = - GoRho * ( dRhodT(i) * netPen(i,k) ) ! [L2 T-3 ~> m2 s-3] + enddo ; enddo + endif end subroutine calculateBuoyancyFlux1d @@ -1011,14 +1150,15 @@ subroutine calculateBuoyancyFlux2d(G, GV, US, fluxes, optics, h, Temp, Salt, tv, type(forcing), intent(inout) :: fluxes !< surface fluxes type(optics_type), pointer :: optics !< SW ocean optics real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: Temp !< temperature [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: Salt !< salinity [ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: Temp !< temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: Salt !< salinity [S ~> ppt] type(thermo_var_ptrs), intent(inout) :: tv !< thermodynamics type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: buoyancyFlux !< buoyancy fluxes [L2 T-3 ~> m2 s-3] real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: netHeatMinusSW !< surface heat flux excluding shortwave - !! [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] + !! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: netSalt !< Net surface salt flux - !! [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + !! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + ! local variables integer :: j @@ -1031,6 +1171,138 @@ subroutine calculateBuoyancyFlux2d(G, GV, US, fluxes, optics, h, Temp, Salt, tv, end subroutine calculateBuoyancyFlux2d +!> Determine the friction velocity from the contenxts of a forcing type, perhaps +!! using the evolving surface density. +subroutine find_ustar_fluxes(fluxes, tv, U_star, G, GV, US, halo, H_T_units) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(forcing), intent(in) :: fluxes !< Surface fluxes container + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any + !! available thermodynamic fields. + real, dimension(SZI_(G),SZJ_(G)), & + intent(out) :: U_star !< The surface friction velocity [Z T-1 ~> m s-1] or + !! [H T-1 ~> m s-1 or kg m-2 s-1], depending on H_T_units. + integer, optional, intent(in) :: halo !< The extra halo size to fill in, 0 by default + logical, optional, intent(in) :: H_T_units !< If present and true, return U_star in units + !! of [H T-1 ~> m s-1 or kg m-2 s-1] + + ! Local variables + real :: I_rho ! The inverse of the reference density [R-1 ~> m3 kg-1] + ! or in some semi-Boussinesq cases the reference + ! density [H2 Z-2 R-1 ~> m3 kg-1 or kg m-3] + logical :: Z_T_units ! If true, U_star is returned in units of [Z T-1 ~> m s-1], otherwise it is + ! returned in [H T-1 ~> m s-1 or kg m-2 s-1] + integer :: i, j, is, ie, js, je, hs + + hs = 0 ; if (present(halo)) hs = max(halo, 0) + is = G%isc - hs ; ie = G%iec + hs ; js = G%jsc - hs ; je = G%jec + hs + + Z_T_units = .true. ; if (present(H_T_units)) Z_T_units = .not.H_T_units + + if (.not.(associated(fluxes%ustar) .or. associated(fluxes%tau_mag))) & + call MOM_error(FATAL, "find_ustar_fluxes requires that either ustar or tau_mag be associated.") + + if (associated(fluxes%ustar) .and. (GV%Boussinesq .or. .not.associated(fluxes%tau_mag))) then + if (Z_T_units) then + do j=js,je ; do i=is,ie + U_star(i,j) = fluxes%ustar(i,j) + enddo ; enddo + else + do j=js,je ; do i=is,ie + U_star(i,j) = GV%Z_to_H * fluxes%ustar(i,j) + enddo ; enddo + endif + elseif (allocated(tv%SpV_avg)) then + if (tv%valid_SpV_halo < 0) call MOM_error(FATAL, & + "find_ustar_fluxes called in non-Boussinesq mode with invalid values of SpV_avg.") + if (tv%valid_SpV_halo < hs) call MOM_error(FATAL, & + "find_ustar_fluxes called in non-Boussinesq mode with insufficient valid values of SpV_avg.") + if (Z_T_units) then + do j=js,je ; do i=is,ie + U_star(i,j) = sqrt(fluxes%tau_mag(i,j) * tv%SpV_avg(i,j,1)) + enddo ; enddo + else + do j=js,je ; do i=is,ie + U_star(i,j) = GV%RZ_to_H * sqrt(fluxes%tau_mag(i,j) / tv%SpV_avg(i,j,1)) + enddo ; enddo + endif + else + I_rho = GV%Z_to_H * GV%RZ_to_H + if (Z_T_units) I_rho = GV%H_to_Z * GV%RZ_to_H ! == 1.0 / GV%Rho0 + do j=js,je ; do i=is,ie + U_star(i,j) = sqrt(fluxes%tau_mag(i,j) * I_rho) + enddo ; enddo + endif + +end subroutine find_ustar_fluxes + + +!> Determine the friction velocity from the contenxts of a forcing type, perhaps +!! using the evolving surface density. +subroutine find_ustar_mech_forcing(forces, tv, U_star, G, GV, US, halo, H_T_units) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(mech_forcing), intent(in) :: forces !< Surface forces container + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any + !! available thermodynamic fields. + real, dimension(SZI_(G),SZJ_(G)), & + intent(out) :: U_star !< The surface friction velocity [Z T-1 ~> m s-1] + integer, optional, intent(in) :: halo !< The extra halo size to fill in, 0 by default + logical, optional, intent(in) :: H_T_units !< If present and true, return U_star in units + !! of [H T-1 ~> m s-1 or kg m-2 s-1] + + ! Local variables + real :: I_rho ! The inverse of the reference density [R-1 ~> m3 kg-1] or in some semi-Boussinesq cases + ! the rescaled reference density [H2 Z-2 R-1 ~> m3 kg-1 or kg m-3] + logical :: Z_T_units ! If true, U_star is returned in units of [Z T-1 ~> m s-1], otherwise it is + ! returned in [H T-1 ~> m s-1 or kg m-2 s-1] + integer :: i, j, is, ie, js, je, hs + + hs = 0 ; if (present(halo)) hs = max(halo, 0) + is = G%isc - hs ; ie = G%iec + hs ; js = G%jsc - hs ; je = G%jec + hs + + Z_T_units = .true. ; if (present(H_T_units)) Z_T_units = .not.H_T_units + + if (.not.(associated(forces%ustar) .or. associated(forces%tau_mag))) & + call MOM_error(FATAL, "find_ustar_mech requires that either ustar or tau_mag be associated.") + + if (associated(forces%ustar) .and. (GV%Boussinesq .or. .not.associated(forces%tau_mag))) then + if (Z_T_units) then + do j=js,je ; do i=is,ie + U_star(i,j) = forces%ustar(i,j) + enddo ; enddo + else + do j=js,je ; do i=is,ie + U_star(i,j) = GV%Z_to_H * forces%ustar(i,j) + enddo ; enddo + endif + elseif (allocated(tv%SpV_avg)) then + if (tv%valid_SpV_halo < 0) call MOM_error(FATAL, & + "find_ustar_mech called in non-Boussinesq mode with invalid values of SpV_avg.") + if (tv%valid_SpV_halo < hs) call MOM_error(FATAL, & + "find_ustar_mech called in non-Boussinesq mode with insufficient valid values of SpV_avg.") + if (Z_T_units) then + do j=js,je ; do i=is,ie + U_star(i,j) = sqrt(forces%tau_mag(i,j) * tv%SpV_avg(i,j,1)) + enddo ; enddo + else + do j=js,je ; do i=is,ie + U_star(i,j) = GV%RZ_to_H * sqrt(forces%tau_mag(i,j) / tv%SpV_avg(i,j,1)) + enddo ; enddo + endif + else + I_rho = GV%Z_to_H * GV%RZ_to_H + if (Z_T_units) I_rho = GV%H_to_Z * GV%RZ_to_H ! == 1.0 / GV%Rho0 + do j=js,je ; do i=is,ie + U_star(i,j) = sqrt(forces%tau_mag(i,j) * I_rho) + enddo ; enddo + endif + +end subroutine find_ustar_mech_forcing + + !> Write out chksums for thermodynamic fluxes. subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) character(len=*), intent(in) :: mesg !< message @@ -1047,88 +1319,103 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) ! counts, there must be no redundant points, so all variables use is..ie ! and js...je as their extent. if (associated(fluxes%ustar)) & - call hchksum(fluxes%ustar, mesg//" fluxes%ustar", G%HI, haloshift=hshift, scale=US%Z_to_m*US%s_to_T) + call hchksum(fluxes%ustar, mesg//" fluxes%ustar", G%HI, haloshift=hshift, unscale=US%Z_to_m*US%s_to_T) + if (associated(fluxes%tau_mag)) & + call hchksum(fluxes%tau_mag, mesg//" fluxes%tau_mag", G%HI, haloshift=hshift, unscale=US%RLZ_T2_to_Pa*US%Z_to_L) if (associated(fluxes%buoy)) & - call hchksum(fluxes%buoy, mesg//" fluxes%buoy ", G%HI, haloshift=hshift, scale=US%L_to_m**2*US%s_to_T**3) + call hchksum(fluxes%buoy, mesg//" fluxes%buoy ", G%HI, haloshift=hshift, unscale=US%L_to_m**2*US%s_to_T**3) if (associated(fluxes%sw)) & - call hchksum(fluxes%sw, mesg//" fluxes%sw", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%sw, mesg//" fluxes%sw", G%HI, haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%sw_vis_dir)) & - call hchksum(fluxes%sw_vis_dir, mesg//" fluxes%sw_vis_dir", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%sw_vis_dir, mesg//" fluxes%sw_vis_dir", G%HI, haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%sw_vis_dif)) & - call hchksum(fluxes%sw_vis_dif, mesg//" fluxes%sw_vis_dif", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%sw_vis_dif, mesg//" fluxes%sw_vis_dif", G%HI, haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%sw_nir_dir)) & - call hchksum(fluxes%sw_nir_dir, mesg//" fluxes%sw_nir_dir", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%sw_nir_dir, mesg//" fluxes%sw_nir_dir", G%HI, haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%sw_nir_dif)) & - call hchksum(fluxes%sw_nir_dif, mesg//" fluxes%sw_nir_dif", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%sw_nir_dif, mesg//" fluxes%sw_nir_dif", G%HI, haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%lw)) & - call hchksum(fluxes%lw, mesg//" fluxes%lw", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%lw, mesg//" fluxes%lw", G%HI, haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%latent)) & - call hchksum(fluxes%latent, mesg//" fluxes%latent", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%latent, mesg//" fluxes%latent", G%HI, haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%latent_evap_diag)) & call hchksum(fluxes%latent_evap_diag, mesg//" fluxes%latent_evap_diag", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%latent_fprec_diag)) & call hchksum(fluxes%latent_fprec_diag, mesg//" fluxes%latent_fprec_diag", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%latent_frunoff_diag)) & call hchksum(fluxes%latent_frunoff_diag, mesg//" fluxes%latent_frunoff_diag", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) + if (associated(fluxes%latent_frunoff_glc_diag)) & + call hchksum(fluxes%latent_frunoff_glc_diag, mesg//" fluxes%latent_frunoff_glc_diag", G%HI, & + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%sens)) & - call hchksum(fluxes%sens, mesg//" fluxes%sens", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%sens, mesg//" fluxes%sens", G%HI, haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%evap)) & - call hchksum(fluxes%evap, mesg//" fluxes%evap", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + call hchksum(fluxes%evap, mesg//" fluxes%evap", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) if (associated(fluxes%lprec)) & - call hchksum(fluxes%lprec, mesg//" fluxes%lprec", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + call hchksum(fluxes%lprec, mesg//" fluxes%lprec", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) if (associated(fluxes%fprec)) & - call hchksum(fluxes%fprec, mesg//" fluxes%fprec", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + call hchksum(fluxes%fprec, mesg//" fluxes%fprec", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) if (associated(fluxes%vprec)) & - call hchksum(fluxes%vprec, mesg//" fluxes%vprec", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + call hchksum(fluxes%vprec, mesg//" fluxes%vprec", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) if (associated(fluxes%seaice_melt)) & - call hchksum(fluxes%seaice_melt, mesg//" fluxes%seaice_melt", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + call hchksum(fluxes%seaice_melt, mesg//" fluxes%seaice_melt", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) if (associated(fluxes%seaice_melt_heat)) & call hchksum(fluxes%seaice_melt_heat, mesg//" fluxes%seaice_melt_heat", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%p_surf)) & - call hchksum(fluxes%p_surf, mesg//" fluxes%p_surf", G%HI, haloshift=hshift, scale=US%RL2_T2_to_Pa) + call hchksum(fluxes%p_surf, mesg//" fluxes%p_surf", G%HI, haloshift=hshift, unscale=US%RL2_T2_to_Pa) if (associated(fluxes%u10_sqr)) & - call hchksum(fluxes%u10_sqr, mesg//" fluxes%u10_sqr", G%HI, haloshift=hshift, scale=US%L_to_m**2*US%s_to_T**2) + call hchksum(fluxes%u10_sqr, mesg//" fluxes%u10_sqr", G%HI, haloshift=hshift, unscale=US%L_to_m**2*US%s_to_T**2) if (associated(fluxes%ice_fraction)) & call hchksum(fluxes%ice_fraction, mesg//" fluxes%ice_fraction", G%HI, haloshift=hshift) - if (associated(fluxes%cfc11_flux)) & - call hchksum(fluxes%cfc11_flux, mesg//" fluxes%cfc11_flux", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) - if (associated(fluxes%cfc12_flux)) & - call hchksum(fluxes%cfc12_flux, mesg//" fluxes%cfc12_flux", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) if (associated(fluxes%salt_flux)) & - call hchksum(fluxes%salt_flux, mesg//" fluxes%salt_flux", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) - if (associated(fluxes%TKE_tidal)) & - call hchksum(fluxes%TKE_tidal, mesg//" fluxes%TKE_tidal", G%HI, haloshift=hshift, scale=US%RZ3_T3_to_W_m2) + call hchksum(fluxes%salt_flux, mesg//" fluxes%salt_flux", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) + if (associated(fluxes%BBL_tidal_dis)) & + call hchksum(fluxes%BBL_tidal_dis, mesg//" fluxes%BBL_tidal_dis", G%HI, haloshift=hshift, & + unscale=US%L_to_Z**2*US%RZ3_T3_to_W_m2) if (associated(fluxes%ustar_tidal)) & - call hchksum(fluxes%ustar_tidal, mesg//" fluxes%ustar_tidal", G%HI, haloshift=hshift, scale=US%Z_to_m*US%s_to_T) + call hchksum(fluxes%ustar_tidal, mesg//" fluxes%ustar_tidal", G%HI, haloshift=hshift, unscale=US%Z_to_m*US%s_to_T) if (associated(fluxes%lrunoff)) & - call hchksum(fluxes%lrunoff, mesg//" fluxes%lrunoff", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + call hchksum(fluxes%lrunoff, mesg//" fluxes%lrunoff", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) + if (associated(fluxes%lrunoff_glc)) & + call hchksum(fluxes%lrunoff_glc, mesg//" fluxes%lrunoff_glc", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) if (associated(fluxes%frunoff)) & - call hchksum(fluxes%frunoff, mesg//" fluxes%frunoff", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + call hchksum(fluxes%frunoff, mesg//" fluxes%frunoff", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) + if (associated(fluxes%frunoff_glc)) & + call hchksum(fluxes%frunoff_glc, mesg//" fluxes%frunoff_glc", G%HI, haloshift=hshift, unscale=US%RZ_T_to_kg_m2s) if (associated(fluxes%heat_content_lrunoff)) & call hchksum(fluxes%heat_content_lrunoff, mesg//" fluxes%heat_content_lrunoff", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) + if (associated(fluxes%heat_content_lrunoff_glc)) & + call hchksum(fluxes%heat_content_lrunoff_glc, mesg//" fluxes%heat_content_lrunoff_glc", G%HI, & + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%heat_content_frunoff)) & call hchksum(fluxes%heat_content_frunoff, mesg//" fluxes%heat_content_frunoff", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) + if (associated(fluxes%heat_content_frunoff_glc)) & + call hchksum(fluxes%heat_content_frunoff_glc, mesg//" fluxes%heat_content_frunoff_glc", G%HI, & + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%heat_content_lprec)) & - call hchksum(fluxes%heat_content_lprec, mesg//" fluxes%heat_content_lprec", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + call hchksum(fluxes%heat_content_lprec, mesg//" fluxes%heat_content_lprec", G%HI, & + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%heat_content_fprec)) & call hchksum(fluxes%heat_content_fprec, mesg//" fluxes%heat_content_fprec", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) - if (associated(fluxes%heat_content_icemelt)) & - call hchksum(fluxes%heat_content_icemelt, mesg//" fluxes%heat_content_icemelt", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%heat_content_cond)) & call hchksum(fluxes%heat_content_cond, mesg//" fluxes%heat_content_cond", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) + if (associated(fluxes%heat_content_evap)) & + call hchksum(fluxes%heat_content_evap, mesg//" fluxes%heat_content_evap", G%HI, & + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) if (associated(fluxes%heat_content_massout)) & call hchksum(fluxes%heat_content_massout, mesg//" fluxes%heat_content_massout", G%HI, & - haloshift=hshift, scale=US%QRZ_T_to_W_m2) + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) + if (associated(fluxes%heat_content_massin)) & + call hchksum(fluxes%heat_content_massin, mesg//" fluxes%heat_content_massin", G%HI, & + haloshift=hshift, unscale=US%QRZ_T_to_W_m2) end subroutine MOM_forcing_chksum !> Write out chksums for the driving mechanical forces. @@ -1148,15 +1435,17 @@ subroutine MOM_mech_forcing_chksum(mesg, forces, G, US, haloshift) ! and js...je as their extent. if (associated(forces%taux) .and. associated(forces%tauy)) & call uvchksum(mesg//" forces%tau[xy]", forces%taux, forces%tauy, G%HI, & - haloshift=hshift, symmetric=.true., scale=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) + haloshift=hshift, symmetric=.true., unscale=US%RLZ_T2_to_Pa) if (associated(forces%p_surf)) & - call hchksum(forces%p_surf, mesg//" forces%p_surf", G%HI, haloshift=hshift, scale=US%RL2_T2_to_Pa) + call hchksum(forces%p_surf, mesg//" forces%p_surf", G%HI, haloshift=hshift, unscale=US%RL2_T2_to_Pa) if (associated(forces%ustar)) & - call hchksum(forces%ustar, mesg//" forces%ustar", G%HI, haloshift=hshift, scale=US%Z_to_m*US%s_to_T) + call hchksum(forces%ustar, mesg//" forces%ustar", G%HI, haloshift=hshift, unscale=US%Z_to_m*US%s_to_T) + if (associated(forces%tau_mag)) & + call hchksum(forces%tau_mag, mesg//" forces%tau_mag", G%HI, haloshift=hshift, unscale=US%RLZ_T2_to_Pa*US%Z_to_L) if (associated(forces%rigidity_ice_u) .and. associated(forces%rigidity_ice_v)) & call uvchksum(mesg//" forces%rigidity_ice_[uv]", forces%rigidity_ice_u, & forces%rigidity_ice_v, G%HI, haloshift=hshift, symmetric=.true., & - scale=US%L_to_m**3*US%L_to_Z*US%s_to_T, scalar_pair=.true.) + unscale=US%L_to_m**3*US%L_to_Z*US%s_to_T, scalar_pair=.true.) end subroutine MOM_mech_forcing_chksum @@ -1199,6 +1488,7 @@ subroutine forcing_SinglePointPrint(fluxes, G, i, j, mesg) write(0,'(2a)') 'MOM_forcing_type, forcing_SinglePointPrint: Called from ',mesg write(0,'(a,2es15.3)') 'MOM_forcing_type, forcing_SinglePointPrint: lon,lat = ',G%geoLonT(i,j),G%geoLatT(i,j) call locMsg(fluxes%ustar,'ustar') + call locMsg(fluxes%tau_mag,'tau_mag') call locMsg(fluxes%buoy,'buoy') call locMsg(fluxes%sw,'sw') call locMsg(fluxes%sw_vis_dir,'sw_vis_dir') @@ -1210,6 +1500,7 @@ subroutine forcing_SinglePointPrint(fluxes, G, i, j, mesg) call locMsg(fluxes%latent_evap_diag,'latent_evap_diag') call locMsg(fluxes%latent_fprec_diag,'latent_fprec_diag') call locMsg(fluxes%latent_frunoff_diag,'latent_frunoff_diag') + call locMsg(fluxes%latent_frunoff_glc_diag,'latent_frunoff_glc_diag') call locMsg(fluxes%sens,'sens') call locMsg(fluxes%evap,'evap') call locMsg(fluxes%lprec,'lprec') @@ -1219,18 +1510,24 @@ subroutine forcing_SinglePointPrint(fluxes, G, i, j, mesg) call locMsg(fluxes%seaice_melt_heat,'seaice_melt_heat') call locMsg(fluxes%p_surf,'p_surf') call locMsg(fluxes%salt_flux,'salt_flux') - call locMsg(fluxes%TKE_tidal,'TKE_tidal') + call locMsg(fluxes%BBL_tidal_dis,'BBL_tidal_dis') call locMsg(fluxes%ustar_tidal,'ustar_tidal') call locMsg(fluxes%lrunoff,'lrunoff') + call locMsg(fluxes%lrunoff_glc,'lrunoff_glc') call locMsg(fluxes%frunoff,'frunoff') + call locMsg(fluxes%frunoff_glc,'frunoff_glc') call locMsg(fluxes%heat_content_lrunoff,'heat_content_lrunoff') + call locMsg(fluxes%heat_content_lrunoff_glc,'heat_content_lrunoff_glc') call locMsg(fluxes%heat_content_frunoff,'heat_content_frunoff') + call locMsg(fluxes%heat_content_frunoff_glc,'heat_content_frunoff_glc') call locMsg(fluxes%heat_content_lprec,'heat_content_lprec') call locMsg(fluxes%heat_content_fprec,'heat_content_fprec') - call locMsg(fluxes%heat_content_icemelt,'heat_content_icemelt') call locMsg(fluxes%heat_content_vprec,'heat_content_vprec') call locMsg(fluxes%heat_content_cond,'heat_content_cond') call locMsg(fluxes%heat_content_cond,'heat_content_massout') + call locMsg(fluxes%heat_content_evap,'heat_content_evap') + call locMsg(fluxes%heat_content_massout,'heat_content_massout') + call locMsg(fluxes%heat_content_massin,'heat_content_massin') contains !> Format and write a message depending on associated state of array @@ -1249,7 +1546,8 @@ end subroutine forcing_SinglePointPrint !> Register members of the forcing type for diagnostics -subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, use_berg_fluxes, use_waves, use_cfcs) +subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, use_berg_fluxes, use_waves, & + use_cfcs, use_glc_runoff, use_carbon_runoff) type(time_type), intent(in) :: Time !< time type type(diag_ctrl), intent(inout) :: diag !< diagnostic control type type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -1258,36 +1556,45 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, logical, optional, intent(in) :: use_berg_fluxes !< If true, allow iceberg flux diagnostics logical, optional, intent(in) :: use_waves !< If true, allow wave forcing diagnostics logical, optional, intent(in) :: use_cfcs !< If true, allow cfc related diagnostics + logical, optional, intent(in) :: use_glc_runoff !< If true, allow separate glacial runoff diagnostics + logical, optional, intent(in) :: use_carbon_runoff !< If true, allow separate carbon runoff diagnostics ! Clock for forcing diagnostics handles%id_clock_forcing=cpu_clock_id('(Ocean forcing diagnostics)', grain=CLOCK_ROUTINE) handles%id_taux = register_diag_field('ocean_model', 'taux', diag%axesCu1, Time, & - 'Zonal surface stress from ocean interactions with atmos and ice', & - 'Pa', conversion=US%RZ_T_to_kg_m2s*US%L_T_to_m_s, & + 'Zonal surface stress from ocean interactions with atmos and ice', & + 'Pa', conversion=US%RLZ_T2_to_Pa, & standard_name='surface_downward_x_stress', cmor_field_name='tauuo', & cmor_units='N m-2', cmor_long_name='Surface Downward X Stress', & cmor_standard_name='surface_downward_x_stress') handles%id_tauy = register_diag_field('ocean_model', 'tauy', diag%axesCv1, Time, & - 'Meridional surface stress ocean interactions with atmos and ice', & - 'Pa', conversion=US%RZ_T_to_kg_m2s*US%L_T_to_m_s, & + 'Meridional surface stress ocean interactions with atmos and ice', & + 'Pa', conversion=US%RLZ_T2_to_Pa, & standard_name='surface_downward_y_stress', cmor_field_name='tauvo', & cmor_units='N m-2', cmor_long_name='Surface Downward Y Stress', & cmor_standard_name='surface_downward_y_stress') + handles%id_tau_mag = register_diag_field('ocean_model', 'tau_mag', diag%axesT1, Time, & + 'Average magnitude of the wind stress including contributions from gustiness', & + 'Pa', conversion=US%RLZ_T2_to_Pa*US%Z_to_L) + handles%id_ustar = register_diag_field('ocean_model', 'ustar', diag%axesT1, Time, & 'Surface friction velocity = [(gustiness + tau_magnitude)/rho0]^(1/2)', & 'm s-1', conversion=US%Z_to_m*US%s_to_T) + handles%id_omega_w2x = register_diag_field('ocean_model', 'omega_w2x', diag%axesT1, Time, & + 'Counter-clockwise angle of the wind stress from the horizontal axis.', 'rad', conversion=1.0) + if (present(use_berg_fluxes)) then if (use_berg_fluxes) then handles%id_ustar_berg = register_diag_field('ocean_model', 'ustar_berg', diag%axesT1, Time, & 'Friction velocity below iceberg ', 'm s-1', conversion=US%Z_to_m*US%s_to_T) handles%id_area_berg = register_diag_field('ocean_model', 'area_berg', diag%axesT1, Time, & - 'Area of grid cell covered by iceberg ', 'm2 m-2') + 'Area of grid cell covered by iceberg ', 'm2 m-2', conversion=1.0) handles%id_mass_berg = register_diag_field('ocean_model', 'mass_berg', diag%axesT1, Time, & 'Mass of icebergs ', 'kg m-2', conversion=US%RZ_to_kg_m2) @@ -1296,35 +1603,18 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 'Friction velocity below iceberg and ice shelf together', 'm s-1', conversion=US%Z_to_m*US%s_to_T) handles%id_frac_ice_cover = register_diag_field('ocean_model', 'frac_ice_cover', diag%axesT1, Time, & - 'Area of grid cell below iceberg and ice shelf together ', 'm2 m-2') + 'Area of grid cell below iceberg and ice shelf together ', 'm2 m-2', conversion=1.0) endif endif - ! units for cfc11_flux and cfc12_flux are [Conc R Z T-1 ~> mol m-2 s-1] ! See: - ! http://clipc-services.ceda.ac.uk/dreq/u/0940cbee6105037e4b7aa5579004f124.html - ! http://clipc-services.ceda.ac.uk/dreq/u/e9e21426e4810d0bb2d3dddb24dbf4dc.html if (present(use_cfcs)) then if (use_cfcs) then - handles%id_cfc11 = register_diag_field('ocean_model', 'cfc11_flux', diag%axesT1, Time, & - 'Gas exchange flux of CFC11 into the ocean ', & - 'mol m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & - cmor_field_name='fgcfc11', & - cmor_long_name='Surface Downward CFC11 Flux', & - cmor_standard_name='surface_downward_cfc11_flux') - - handles%id_cfc12 = register_diag_field('ocean_model', 'cfc12_flux', diag%axesT1, Time, & - 'Gas exchange flux of CFC12 into the ocean ', & - 'mol m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & - cmor_field_name='fgcfc12', & - cmor_long_name='Surface Downward CFC12 Flux', & - cmor_standard_name='surface_downward_cfc12_flux') - handles%id_ice_fraction = register_diag_field('ocean_model', 'ice_fraction', diag%axesT1, Time, & - 'Fraction of cell area covered by sea ice', 'm2 m-2') + 'Fraction of cell area covered by sea ice', 'm2 m-2', conversion=1.0) handles%id_u10_sqr = register_diag_field('ocean_model', 'u10_sqr', diag%axesT1, Time, & - 'Wind magnitude at 10m, squared', 'm2 s-2', conversion=US%Z_to_m**2*US%s_to_T**2) + 'Wind magnitude at 10m, squared', 'm2 s-2', conversion=US%L_to_m**2*US%s_to_T**2) endif endif @@ -1335,7 +1625,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, cmor_standard_name='sea_water_pressure_at_sea_water_surface') handles%id_TKE_tidal = register_diag_field('ocean_model', 'TKE_tidal', diag%axesT1, Time, & - 'Tidal source of BBL mixing', 'W m-2', conversion=US%RZ3_T3_to_W_m2) + 'Tidal source of BBL mixing', 'W m-2', conversion=US%L_to_Z**2*US%RZ3_T3_to_W_m2) if (.not. use_temperature) then handles%id_buoy = register_diag_field('ocean_model', 'buoy', diag%axesT1, Time, & @@ -1348,8 +1638,8 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, ! surface mass flux maps handles%id_prcme = register_diag_field('ocean_model', 'PRCmE', diag%axesT1, Time, & - 'Net surface water flux (precip+melt+lrunoff+ice calving-evap)', & - 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + 'Net surface water flux (precip+melt+lrunoff+ice calving-evap)', & + 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & standard_name='water_flux_into_sea_water', cmor_field_name='wfo', & cmor_standard_name='water_flux_into_sea_water',cmor_long_name='Water Flux Into Sea Water') @@ -1363,7 +1653,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, ! smg: seaice_melt field requires updates to the sea ice model handles%id_seaice_melt = register_diag_field('ocean_model', 'seaice_melt', & diag%axesT1, Time, 'water flux to ocean from snow/sea ice melting(> 0) or formation(< 0)', & - 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & standard_name='water_flux_into_sea_water_due_to_sea_ice_thermodynamics', & cmor_field_name='fsitherm', & cmor_standard_name='water_flux_into_sea_water_due_to_sea_ice_thermodynamics',& @@ -1373,37 +1663,49 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 'Liquid + frozen precipitation into ocean', 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) handles%id_fprec = register_diag_field('ocean_model', 'fprec', diag%axesT1, Time, & - 'Frozen precipitation into ocean', & - units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + 'Frozen precipitation into ocean', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & standard_name='snowfall_flux', cmor_field_name='prsn', & cmor_standard_name='snowfall_flux', cmor_long_name='Snowfall Flux where Ice Free Ocean over Sea') handles%id_lprec = register_diag_field('ocean_model', 'lprec', diag%axesT1, Time, & - 'Liquid precipitation into ocean', & - units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + 'Liquid precipitation into ocean', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & standard_name='rainfall_flux', & cmor_field_name='prlq', cmor_standard_name='rainfall_flux', & cmor_long_name='Rainfall Flux where Ice Free Ocean over Sea') handles%id_vprec = register_diag_field('ocean_model', 'vprec', diag%axesT1, Time, & - 'Virtual liquid precip into ocean due to SSS restoring', & + 'Virtual liquid precip into ocean due to SSS restoring', & units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) handles%id_frunoff = register_diag_field('ocean_model', 'frunoff', diag%axesT1, Time, & - 'Frozen runoff (calving) and iceberg melt into ocean', & - units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + 'Frozen runoff (calving) and iceberg melt into ocean', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & standard_name='water_flux_into_sea_water_from_icebergs', & cmor_field_name='ficeberg', & cmor_standard_name='water_flux_into_sea_water_from_icebergs', & cmor_long_name='Water Flux into Seawater from Icebergs') handles%id_lrunoff = register_diag_field('ocean_model', 'lrunoff', diag%axesT1, Time, & - 'Liquid runoff (rivers) into ocean', & - units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + 'Liquid runoff (rivers) into ocean', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & standard_name='water_flux_into_sea_water_from_rivers', cmor_field_name='friver', & cmor_standard_name='water_flux_into_sea_water_from_rivers', & cmor_long_name='Water Flux into Sea Water From Rivers') + if (present(use_glc_runoff)) then + handles%id_frunoff_glc = register_diag_field('ocean_model', 'frunoff_glc', diag%axesT1, Time, & + 'Frozen glacier runoff (calving) and iceberg melt into ocean', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + standard_name='glc_water_flux_into_sea_water_from_icebergs') ! todo: update cmor names + + handles%id_lrunoff_glc = register_diag_field('ocean_model', 'lrunoff_glc', diag%axesT1, Time, & + 'Liquid runoff (glaciers) into ocean', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + standard_name='water_flux_into_sea_water_from_glaciers') ! todo: update cmor names + endif + handles%id_net_massout = register_diag_field('ocean_model', 'net_massout', diag%axesT1, Time, & 'Net mass leaving the ocean due to evaporation, seaice formation', & 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) @@ -1424,101 +1726,124 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, ! area integrated surface mass transport, all are rescaled to MKS units before area integration. handles%id_total_prcme = register_scalar_field('ocean_model', 'total_PRCmE', Time, diag, & - long_name='Area integrated net surface water flux (precip+melt+liq runoff+ice calving-evap)',& - units='kg s-1', standard_name='water_flux_into_sea_water_area_integrated', & + long_name='Area integrated net surface water flux (precip+melt+liq runoff+ice calving-evap)', & + units='kg s-1', conversion=US%RZL2_to_kg*US%s_to_T, & + standard_name='water_flux_into_sea_water_area_integrated', & cmor_field_name='total_wfo', & cmor_standard_name='water_flux_into_sea_water_area_integrated', & cmor_long_name='Water Transport Into Sea Water Area Integrated') handles%id_total_evap = register_scalar_field('ocean_model', 'total_evap', Time, diag,& long_name='Area integrated evap/condense at ocean surface', & - units='kg s-1', standard_name='water_evaporation_flux_area_integrated', & + units='kg s-1', conversion=US%RZL2_to_kg*US%s_to_T, & + standard_name='water_evaporation_flux_area_integrated', & cmor_field_name='total_evs', & cmor_standard_name='water_evaporation_flux_area_integrated', & cmor_long_name='Evaporation Where Ice Free Ocean over Sea Area Integrated') ! seaice_melt field requires updates to the sea ice model handles%id_total_seaice_melt = register_scalar_field('ocean_model', 'total_icemelt', Time, diag, & - long_name='Area integrated sea ice melt (>0) or form (<0)', units='kg s-1', & + long_name='Area integrated sea ice melt (>0) or form (<0)', & + units='kg s-1', conversion=US%RZL2_to_kg*US%s_to_T, & standard_name='water_flux_into_sea_water_due_to_sea_ice_thermodynamics_area_integrated', & cmor_field_name='total_fsitherm', & cmor_standard_name='water_flux_into_sea_water_due_to_sea_ice_thermodynamics_area_integrated', & cmor_long_name='Water Melt/Form from Sea Ice Area Integrated') handles%id_total_precip = register_scalar_field('ocean_model', 'total_precip', Time, diag, & - long_name='Area integrated liquid+frozen precip into ocean', units='kg s-1') + long_name='Area integrated liquid+frozen precip into ocean', & + units='kg s-1', conversion=US%RZL2_to_kg*US%s_to_T) handles%id_total_fprec = register_scalar_field('ocean_model', 'total_fprec', Time, diag,& - long_name='Area integrated frozen precip into ocean', units='kg s-1', & + long_name='Area integrated frozen precip into ocean', & + units='kg s-1', conversion=US%RZL2_to_kg*US%s_to_T, & standard_name='snowfall_flux_area_integrated', & cmor_field_name='total_prsn', & cmor_standard_name='snowfall_flux_area_integrated', & cmor_long_name='Snowfall Flux where Ice Free Ocean over Sea Area Integrated') handles%id_total_lprec = register_scalar_field('ocean_model', 'total_lprec', Time, diag,& - long_name='Area integrated liquid precip into ocean', units='kg s-1', & + long_name='Area integrated liquid precip into ocean', & + units='kg s-1', conversion=US%RZL2_to_kg*US%s_to_T, & standard_name='rainfall_flux_area_integrated', & cmor_field_name='total_pr', & cmor_standard_name='rainfall_flux_area_integrated', & cmor_long_name='Rainfall Flux where Ice Free Ocean over Sea Area Integrated') handles%id_total_vprec = register_scalar_field('ocean_model', 'total_vprec', Time, diag, & - long_name='Area integrated virtual liquid precip due to SSS restoring', units='kg s-1') + long_name='Area integrated virtual liquid precip due to SSS restoring', & + units='kg s-1', conversion=US%RZL2_to_kg*US%s_to_T) handles%id_total_frunoff = register_scalar_field('ocean_model', 'total_frunoff', Time, diag, & - long_name='Area integrated frozen runoff (calving) & iceberg melt into ocean', units='kg s-1',& + long_name='Area integrated frozen runoff (calving) & iceberg melt into ocean', & + units='kg s-1', conversion=US%RZL2_to_kg*US%s_to_T, & cmor_field_name='total_ficeberg', & cmor_standard_name='water_flux_into_sea_water_from_icebergs_area_integrated', & cmor_long_name='Water Flux into Seawater from Icebergs Area Integrated') handles%id_total_lrunoff = register_scalar_field('ocean_model', 'total_lrunoff', Time, diag,& - long_name='Area integrated liquid runoff into ocean', units='kg s-1', & + long_name='Area integrated liquid runoff into ocean', & + units='kg s-1', conversion=US%RZL2_to_kg*US%s_to_T, & cmor_field_name='total_friver', & cmor_standard_name='water_flux_into_sea_water_from_rivers_area_integrated', & cmor_long_name='Water Flux into Sea Water From Rivers Area Integrated') + if (present(use_glc_runoff)) then + handles%id_total_frunoff_glc = register_scalar_field('ocean_model', 'total_frunoff_glc', Time, diag, & + long_name='Area integrated frozen glacier runoff (calving) & iceberg melt into ocean', & + units='kg s-1', conversion=US%RZL2_to_kg*US%s_to_T) + + handles%id_total_lrunoff_glc = register_scalar_field('ocean_model', 'total_lrunoff_glc', Time, diag, & + long_name='Area integrated liquid glacier runoff into ocean', & + units='kg s-1', conversion=US%RZL2_to_kg*US%s_to_T) + endif + handles%id_total_net_massout = register_scalar_field('ocean_model', 'total_net_massout', Time, diag, & - long_name='Area integrated mass leaving ocean due to evap and seaice form', units='kg s-1') + long_name='Area integrated mass leaving ocean due to evap and seaice form', & + units='kg s-1', conversion=US%RZL2_to_kg*US%s_to_T) handles%id_total_net_massin = register_scalar_field('ocean_model', 'total_net_massin', Time, diag, & - long_name='Area integrated mass entering ocean due to predip, runoff, ice melt', units='kg s-1') + long_name='Area integrated mass entering ocean due to predip, runoff, ice melt', & + units='kg s-1', conversion=US%RZL2_to_kg*US%s_to_T) !========================================================================= ! area averaged surface mass transport - handles%id_prcme_ga = register_scalar_field('ocean_model', 'PRCmE_ga', Time, diag, & - long_name='Area averaged net surface water flux (precip+melt+liq runoff+ice calving-evap)',& - units='kg m-2 s-1', standard_name='water_flux_into_sea_water_area_averaged', & - cmor_field_name='ave_wfo', & - cmor_standard_name='rainfall_flux_area_averaged', & + handles%id_prcme_ga = register_scalar_field('ocean_model', 'PRCmE_ga', Time, diag, & + long_name='Area averaged net surface water flux (precip+melt+liq runoff+ice calving-evap)', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + standard_name='water_flux_into_sea_water_area_averaged', & + cmor_field_name='ave_wfo', cmor_standard_name='rainfall_flux_area_averaged', & cmor_long_name='Water Transport Into Sea Water Area Averaged') - handles%id_evap_ga = register_scalar_field('ocean_model', 'evap_ga', Time, diag,& - long_name='Area averaged evap/condense at ocean surface', & - units='kg m-2 s-1', standard_name='water_evaporation_flux_area_averaged', & - cmor_field_name='ave_evs', & - cmor_standard_name='water_evaporation_flux_area_averaged', & + handles%id_evap_ga = register_scalar_field('ocean_model', 'evap_ga', Time, diag, & + long_name='Area averaged evap/condense at ocean surface', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + standard_name='water_evaporation_flux_area_averaged', & + cmor_field_name='ave_evs', cmor_standard_name='water_evaporation_flux_area_averaged', & cmor_long_name='Evaporation Where Ice Free Ocean over Sea Area Averaged') - handles%id_lprec_ga = register_scalar_field('ocean_model', 'lprec_ga', Time, diag,& - long_name='Area integrated liquid precip into ocean', units='kg m-2 s-1', & - standard_name='rainfall_flux_area_averaged', & - cmor_field_name='ave_pr', & - cmor_standard_name='rainfall_flux_area_averaged', & + handles%id_lprec_ga = register_scalar_field('ocean_model', 'lprec_ga', Time, diag,& + long_name='Area integrated liquid precip into ocean', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + standard_name='rainfall_flux_area_averaged', & + cmor_field_name='ave_pr', cmor_standard_name='rainfall_flux_area_averaged', & cmor_long_name='Rainfall Flux where Ice Free Ocean over Sea Area Averaged') - handles%id_fprec_ga = register_scalar_field('ocean_model', 'fprec_ga', Time, diag,& - long_name='Area integrated frozen precip into ocean', units='kg m-2 s-1', & + handles%id_fprec_ga = register_scalar_field('ocean_model', 'fprec_ga', Time, diag, & + long_name='Area integrated frozen precip into ocean', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & standard_name='snowfall_flux_area_averaged', & - cmor_field_name='ave_prsn', & - cmor_standard_name='snowfall_flux_area_averaged', & + cmor_field_name='ave_prsn',cmor_standard_name='snowfall_flux_area_averaged', & cmor_long_name='Snowfall Flux where Ice Free Ocean over Sea Area Averaged') handles%id_precip_ga = register_scalar_field('ocean_model', 'precip_ga', Time, diag, & - long_name='Area averaged liquid+frozen precip into ocean', units='kg m-2 s-1') + long_name='Area averaged liquid+frozen precip into ocean', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) handles%id_vprec_ga = register_scalar_field('ocean_model', 'vrec_ga', Time, diag, & - long_name='Area averaged virtual liquid precip due to SSS restoring', units='kg m-2 s-1') + long_name='Area averaged virtual liquid precip due to SSS restoring', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) !=============================================================== ! surface heat flux maps @@ -1533,9 +1858,27 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 'W m-2', conversion=US%QRZ_T_to_W_m2, & standard_name='temperature_flux_due_to_runoff_expressed_as_heat_flux_into_sea_water') + if (present(use_carbon_runoff)) then + if (use_carbon_runoff) then + handles%id_carbon_content_lrunoff = register_diag_field('ocean_model', 'carbon_content_lrunoff', & + diag%axesT1, Time, 'Carbon content of liquid runoff into ocean', & + 'kg m-2 s-1', standard_name='carbon_flux_due_to_runoff') + endif + endif + + if (present(use_glc_runoff)) then + handles%id_heat_content_frunoff_glc = register_diag_field('ocean_model', 'heat_content_frunoff_glc', & + diag%axesT1, Time, 'Heat content (relative to 0C) of solid glacier runoff into ocean', & + 'W m-2', conversion=US%QRZ_T_to_W_m2) + + handles%id_heat_content_lrunoff_glc = register_diag_field('ocean_model', 'heat_content_lrunoff_glc', & + diag%axesT1, Time, 'Heat content (relative to 0C) of liquid glacier runoff into ocean', & + 'W m-2', conversion=US%QRZ_T_to_W_m2) + endif + handles%id_hfrunoffds = register_diag_field('ocean_model', 'hfrunoffds', & diag%axesT1, Time, 'Heat content (relative to 0C) of liquid+solid runoff into ocean', & - 'W m-2', conversion=US%QRZ_T_to_W_m2, & + 'W m-2', conversion=US%QRZ_T_to_W_m2, & standard_name='temperature_flux_due_to_runoff_expressed_as_heat_flux_into_sea_water') handles%id_heat_content_lprec = register_diag_field('ocean_model', 'heat_content_lprec', & @@ -1546,10 +1889,6 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, diag%axesT1,Time,'Heat content (relative to 0degC) of frozen prec entering ocean',& 'W m-2', conversion=US%QRZ_T_to_W_m2) - handles%id_heat_content_icemelt = register_diag_field('ocean_model', 'heat_content_icemelt',& - diag%axesT1,Time,'Heat content (relative to 0degC) of water flux due to sea ice melting/freezing',& - 'W m-2', conversion=US%QRZ_T_to_W_m2) - handles%id_heat_content_vprec = register_diag_field('ocean_model', 'heat_content_vprec', & diag%axesT1,Time,'Heat content (relative to 0degC) of virtual precip entering ocean',& 'W m-2', conversion=US%QRZ_T_to_W_m2) @@ -1558,6 +1897,10 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, diag%axesT1,Time,'Heat content (relative to 0degC) of water condensing into ocean',& 'W m-2', conversion=US%QRZ_T_to_W_m2) + handles%id_heat_content_evap = register_diag_field('ocean_model', 'heat_content_evap', & + diag%axesT1,Time,'Heat content (relative to 0degC) of water evaporating from ocean',& + 'W m-2', conversion=US%QRZ_T_to_W_m2) + handles%id_hfrainds = register_diag_field('ocean_model', 'hfrainds', & diag%axesT1,Time,'Heat content (relative to 0degC) of liquid+frozen precip entering ocean', & 'W m-2', conversion=US%QRZ_T_to_W_m2, & @@ -1593,7 +1936,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, cmor_long_name='Surface ocean heat flux from SW+LW+latent+sensible+masstransfer+frazil+seaice_melt_heat') handles%id_sw = register_diag_field('ocean_model', 'SW', diag%axesT1, Time, & - 'Shortwave radiation flux into ocean', 'W m-2', conversion=US%QRZ_T_to_W_m2, & + 'Shortwave radiation flux into ocean', 'W m-2', conversion=US%QRZ_T_to_W_m2, & standard_name='net_downward_shortwave_flux_at_sea_water_surface', & cmor_field_name='rsntds', & cmor_standard_name='net_downward_shortwave_flux_at_sea_water_surface', & @@ -1606,7 +1949,8 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 'W m-2', conversion=US%QRZ_T_to_W_m2) handles%id_LwLatSens = register_diag_field('ocean_model', 'LwLatSens', diag%axesT1, Time, & - 'Combined longwave, latent, and sensible heating at ocean surface', 'W m-2', conversion=US%QRZ_T_to_W_m2) + 'Combined longwave, latent, and sensible heating at ocean surface', & + 'W m-2', conversion=US%QRZ_T_to_W_m2) handles%id_lw = register_diag_field('ocean_model', 'LW', diag%axesT1, Time, & 'Longwave radiation flux into ocean', 'W m-2', conversion=US%QRZ_T_to_W_m2, & @@ -1625,8 +1969,8 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 'Latent heat flux into ocean due to evaporation/condensation', 'W m-2', conversion=US%QRZ_T_to_W_m2) handles%id_lat_fprec = register_diag_field('ocean_model', 'latent_fprec_diag', diag%axesT1, Time,& - 'Latent heat flux into ocean due to melting of frozen precipitation', 'W m-2', conversion=US%QRZ_T_to_W_m2, & - cmor_field_name='hfsnthermds', & + 'Latent heat flux into ocean due to melting of frozen precipitation', & + 'W m-2', conversion=US%QRZ_T_to_W_m2, cmor_field_name='hfsnthermds', & cmor_standard_name='heat_flux_into_sea_water_due_to_snow_thermodynamics', & cmor_long_name='Latent Heat to Melt Frozen Precipitation') @@ -1636,6 +1980,11 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, cmor_standard_name='heat_flux_into_sea_water_due_to_iceberg_thermodynamics', & cmor_long_name='Latent Heat to Melt Frozen Runoff/Iceberg') + if (present(use_glc_runoff)) then + handles%id_lat_frunoff_glc = register_diag_field('ocean_model', 'latent_frunoff_glc', diag%axesT1, Time, & + 'Latent heat flux into ocean due to melting of frozen glacier runoff', 'W m-2', conversion=US%QRZ_T_to_W_m2) + endif + handles%id_sens = register_diag_field('ocean_model', 'sensible', diag%axesT1, Time, & 'Sensible heat flux into ocean', 'W m-2', conversion=US%QRZ_T_to_W_m2, & standard_name='surface_downward_sensible_heat_flux', & @@ -1660,7 +2009,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_total_heat_content_frunoff = register_scalar_field('ocean_model', & 'total_heat_content_frunoff', Time, diag, & long_name='Area integrated heat content (relative to 0C) of solid runoff', & - units='W', cmor_field_name='total_hfsolidrunoffds', & + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2, cmor_field_name='total_hfsolidrunoffds', & cmor_standard_name= & 'temperature_flux_due_to_solid_runoff_expressed_as_heat_flux_into_sea_water_area_integrated',& cmor_long_name= & @@ -1669,16 +2018,28 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_total_heat_content_lrunoff = register_scalar_field('ocean_model', & 'total_heat_content_lrunoff', Time, diag, & long_name='Area integrated heat content (relative to 0C) of liquid runoff', & - units='W', cmor_field_name='total_hfrunoffds', & + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2, cmor_field_name='total_hfrunoffds', & cmor_standard_name= & 'temperature_flux_due_to_runoff_expressed_as_heat_flux_into_sea_water_area_integrated',& cmor_long_name= & 'Temperature Flux due to Runoff Expressed as Heat Flux into Sea Water Area Integrated') + if (present(use_glc_runoff)) then + handles%id_total_heat_content_frunoff_glc = register_scalar_field('ocean_model', & + 'total_heat_content_frunoff_glc', Time, diag, & + long_name='Area integrated heat content (relative to 0C) of solid glacier runoff', & + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2) ! todo: update cmor names + + handles%id_total_heat_content_lrunoff_glc = register_scalar_field('ocean_model', & + 'total_heat_content_lrunoff_glc', Time, diag, & + long_name='Area integrated heat content (relative to 0C) of liquid glacier runoff', & + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2) ! todo: update cmor names + endif + handles%id_total_heat_content_lprec = register_scalar_field('ocean_model', & 'total_heat_content_lprec', Time, diag, & long_name='Area integrated heat content (relative to 0C) of liquid precip', & - units='W', cmor_field_name='total_hfrainds', & + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2, cmor_field_name='total_hfrainds', & cmor_standard_name= & 'temperature_flux_due_to_rainfall_expressed_as_heat_flux_into_sea_water_area_integrated',& cmor_long_name= & @@ -1687,32 +2048,32 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_total_heat_content_fprec = register_scalar_field('ocean_model', & 'total_heat_content_fprec', Time, diag, & long_name='Area integrated heat content (relative to 0C) of frozen precip',& - units='W') - - handles%id_total_heat_content_icemelt = register_scalar_field('ocean_model', & - 'total_heat_content_icemelt', Time, diag,long_name= & - 'Area integrated heat content (relative to 0C) of water flux due sea ice melting/freezing', & - units='W') + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2) handles%id_total_heat_content_vprec = register_scalar_field('ocean_model', & 'total_heat_content_vprec', Time, diag, & long_name='Area integrated heat content (relative to 0C) of virtual precip',& - units='W') + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2) handles%id_total_heat_content_cond = register_scalar_field('ocean_model', & 'total_heat_content_cond', Time, diag, & long_name='Area integrated heat content (relative to 0C) of condensate',& - units='W') + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2) + + handles%id_total_heat_content_evap = register_scalar_field('ocean_model', & + 'total_heat_content_evap', Time, diag, & + long_name='Area integrated heat content (relative to 0C) of evaporation',& + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2) handles%id_total_heat_content_surfwater = register_scalar_field('ocean_model', & 'total_heat_content_surfwater', Time, diag, & long_name='Area integrated heat content (relative to 0C) of water crossing surface',& - units='W') + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2) handles%id_total_heat_content_massout = register_scalar_field('ocean_model', & 'total_heat_content_massout', Time, diag, & long_name='Area integrated heat content (relative to 0C) of water leaving ocean', & - units='W', & + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2, & cmor_field_name='total_hfevapds', & cmor_standard_name= & 'temperature_flux_due_to_evaporation_expressed_as_heat_flux_out_of_sea_water_area_integrated',& @@ -1721,17 +2082,17 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_total_heat_content_massin = register_scalar_field('ocean_model', & 'total_heat_content_massin', Time, diag, & long_name='Area integrated heat content (relative to 0C) of water entering ocean',& - units='W') + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2) handles%id_total_net_heat_coupler = register_scalar_field('ocean_model', & 'total_net_heat_coupler', Time, diag, & long_name='Area integrated surface heat flux from SW+LW+latent+sensible+seaice_melt_heat (via the coupler)',& - units='W') + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2) handles%id_total_net_heat_surface = register_scalar_field('ocean_model', & 'total_net_heat_surface', Time, diag, & long_name='Area integrated surface heat flux from SW+LW+lat+sens+mass+frazil+restore or flux adjustments', & - units='W', & + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2, & cmor_field_name='total_hfds', & cmor_standard_name='surface_downward_heat_flux_in_sea_water_area_integrated', & cmor_long_name= & @@ -1740,7 +2101,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_total_sw = register_scalar_field('ocean_model', & 'total_sw', Time, diag, & long_name='Area integrated net downward shortwave at sea water surface', & - units='W', & + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2, & cmor_field_name='total_rsntds', & cmor_standard_name='net_downward_shortwave_flux_at_sea_water_surface_area_integrated',& cmor_long_name= & @@ -1749,12 +2110,12 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_total_LwLatSens = register_scalar_field('ocean_model',& 'total_LwLatSens', Time, diag, & long_name='Area integrated longwave+latent+sensible heating',& - units='W') + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2) handles%id_total_lw = register_scalar_field('ocean_model', & 'total_lw', Time, diag, & long_name='Area integrated net downward longwave at sea water surface', & - units='W', & + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2, & cmor_field_name='total_rlntds', & cmor_standard_name='surface_net_downward_longwave_flux_area_integrated',& cmor_long_name= & @@ -1763,7 +2124,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_total_lat = register_scalar_field('ocean_model', & 'total_lat', Time, diag, & long_name='Area integrated surface downward latent heat flux', & - units='W', & + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2, & cmor_field_name='total_hflso', & cmor_standard_name='surface_downward_latent_heat_flux_area_integrated',& cmor_long_name= & @@ -1772,12 +2133,12 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_total_lat_evap = register_scalar_field('ocean_model', & 'total_lat_evap', Time, diag, & long_name='Area integrated latent heat flux due to evap/condense',& - units='W') + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2) handles%id_total_lat_fprec = register_scalar_field('ocean_model', & 'total_lat_fprec', Time, diag, & long_name='Area integrated latent heat flux due to melting frozen precip', & - units='W', & + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2, & cmor_field_name='total_hfsnthermds', & cmor_standard_name='heat_flux_into_sea_water_due_to_snow_thermodynamics_area_integrated',& cmor_long_name= & @@ -1786,16 +2147,23 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_total_lat_frunoff = register_scalar_field('ocean_model', & 'total_lat_frunoff', Time, diag, & long_name='Area integrated latent heat flux due to melting icebergs', & - units='W', & + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2, & cmor_field_name='total_hfibthermds', & cmor_standard_name='heat_flux_into_sea_water_due_to_iceberg_thermodynamics_area_integrated',& cmor_long_name= & 'Heat Flux into Sea Water due to Iceberg Thermodynamics Area Integrated') + if (present(use_glc_runoff)) then + handles%id_total_lat_frunoff_glc = register_scalar_field('ocean_model', & + 'total_lat_frunoff_glc', Time, diag, & + long_name='Area integrated latent heat flux due to melting frozen glacier runoff', & + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2) ! todo: update cmor names + endif + handles%id_total_sens = register_scalar_field('ocean_model', & 'total_sens', Time, diag, & long_name='Area integrated downward sensible heat flux', & - units='W', & + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2, & cmor_field_name='total_hfsso', & cmor_standard_name='surface_downward_sensible_heat_flux_area_integrated',& cmor_long_name= & @@ -1804,12 +2172,12 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_total_heat_added = register_scalar_field('ocean_model',& 'total_heat_adjustment', Time, diag, & long_name='Area integrated surface heat flux from restoring and/or flux adjustment', & - units='W') + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2) handles%id_total_seaice_melt_heat = register_scalar_field('ocean_model',& 'total_seaice_melt_heat', Time, diag, & long_name='Area integrated surface heat flux from snow and sea ice melt', & - units='W') + units='W', conversion=US%QRZ_T_to_W_m2*US%L_to_m**2) !=============================================================== ! area averaged surface heat fluxes @@ -1817,12 +2185,12 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_net_heat_coupler_ga = register_scalar_field('ocean_model', & 'net_heat_coupler_ga', Time, diag, & long_name='Area averaged surface heat flux from SW+LW+latent+sensible+seaice_melt_heat (via the coupler)',& - units='W m-2') + units='W m-2', conversion=US%QRZ_T_to_W_m2) handles%id_net_heat_surface_ga = register_scalar_field('ocean_model', & - 'net_heat_surface_ga', Time, diag, long_name= & + 'net_heat_surface_ga', Time, diag, long_name= & 'Area averaged surface heat flux from SW+LW+lat+sens+mass+frazil+restore+seaice_melt_heat or flux adjustments', & - units='W m-2', & + units='W m-2', conversion=US%QRZ_T_to_W_m2, & cmor_field_name='ave_hfds', & cmor_standard_name='surface_downward_heat_flux_in_sea_water_area_averaged', & cmor_long_name= & @@ -1831,7 +2199,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_sw_ga = register_scalar_field('ocean_model', & 'sw_ga', Time, diag, & long_name='Area averaged net downward shortwave at sea water surface', & - units='W m-2', & + units='W m-2', conversion=US%QRZ_T_to_W_m2, & cmor_field_name='ave_rsntds', & cmor_standard_name='net_downward_shortwave_flux_at_sea_water_surface_area_averaged',& cmor_long_name= & @@ -1840,12 +2208,12 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_LwLatSens_ga = register_scalar_field('ocean_model',& 'LwLatSens_ga', Time, diag, & long_name='Area averaged longwave+latent+sensible heating',& - units='W m-2') + units='W m-2', conversion=US%QRZ_T_to_W_m2) handles%id_lw_ga = register_scalar_field('ocean_model', & 'lw_ga', Time, diag, & long_name='Area averaged net downward longwave at sea water surface', & - units='W m-2', & + units='W m-2', conversion=US%QRZ_T_to_W_m2, & cmor_field_name='ave_rlntds', & cmor_standard_name='surface_net_downward_longwave_flux_area_averaged',& cmor_long_name= & @@ -1854,7 +2222,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_lat_ga = register_scalar_field('ocean_model', & 'lat_ga', Time, diag, & long_name='Area averaged surface downward latent heat flux', & - units='W m-2', & + units='W m-2', conversion=US%QRZ_T_to_W_m2, & cmor_field_name='ave_hflso', & cmor_standard_name='surface_downward_latent_heat_flux_area_averaged',& cmor_long_name= & @@ -1863,7 +2231,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_sens_ga = register_scalar_field('ocean_model', & 'sens_ga', Time, diag, & long_name='Area averaged downward sensible heat flux', & - units='W m-2', & + units='W m-2', conversion=US%QRZ_T_to_W_m2, & cmor_field_name='ave_hfsso', & cmor_standard_name='surface_downward_sensible_heat_flux_area_averaged',& cmor_long_name= & @@ -1875,7 +2243,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_saltflux = register_diag_field('ocean_model', 'salt_flux', diag%axesT1, Time,& 'Net salt flux into ocean at surface (restoring + sea-ice)', & - units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & cmor_field_name='sfdsi', cmor_standard_name='downward_sea_ice_basal_salt_flux', & cmor_long_name='Downward Sea Ice Basal Salt Flux') @@ -1887,58 +2255,64 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, diag%axesT1,Time,'Salt flux into ocean at surface due to restoring or flux adjustment', & units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) + handles%id_saltFluxBehind = register_diag_field('ocean_model', 'salt_left_behind', & + diag%axesT1,Time,'Salt left in ocean at surface due to ice formation', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) + handles%id_saltFluxGlobalAdj = register_scalar_field('ocean_model', & 'salt_flux_global_restoring_adjustment', Time, diag, & 'Adjustment needed to balance net global salt flux into ocean at surface', & - units='kg m-2 s-1') !, conversion=US%RZ_T_to_kg_m2s) + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) handles%id_vPrecGlobalAdj = register_scalar_field('ocean_model', & 'vprec_global_adjustment', Time, diag, & 'Adjustment needed to adjust net vprec into ocean to zero', & - 'kg m-2 s-1') + 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) handles%id_netFWGlobalAdj = register_scalar_field('ocean_model', & 'net_fresh_water_global_adjustment', Time, diag, & 'Adjustment needed to adjust net fresh water into ocean to zero',& - 'kg m-2 s-1') + 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) handles%id_saltFluxGlobalScl = register_scalar_field('ocean_model', & 'salt_flux_global_restoring_scaling', Time, diag, & 'Scaling applied to balance net global salt flux into ocean at surface', & - 'nondim') + 'nondim', conversion=1.0) handles%id_vPrecGlobalScl = register_scalar_field('ocean_model',& 'vprec_global_scaling', Time, diag, & 'Scaling applied to adjust net vprec into ocean to zero', & - 'nondim') + 'nondim', conversion=1.0) handles%id_netFWGlobalScl = register_scalar_field('ocean_model', & 'net_fresh_water_global_scaling', Time, diag, & 'Scaling applied to adjust net fresh water into ocean to zero', & - 'nondim') + 'nondim', conversion=1.0) !=============================================================== ! area integrals of surface salt fluxes - handles%id_total_saltflux = register_scalar_field('ocean_model', & - 'total_salt_flux', Time, diag, & - long_name='Area integrated surface salt flux', units='kg s-1', & + handles%id_total_saltflux = register_scalar_field('ocean_model', 'total_salt_flux', & + Time, diag, long_name='Area integrated surface salt flux', & + units='kg s-1', conversion=1e-3*US%RZL2_to_kg*US%s_to_T, & cmor_field_name='total_sfdsi', & cmor_standard_name='downward_sea_ice_basal_salt_flux_area_integrated',& cmor_long_name='Downward Sea Ice Basal Salt Flux Area Integrated') handles%id_total_saltFluxIn = register_scalar_field('ocean_model', 'total_salt_Flux_In', & - Time, diag, long_name='Area integrated surface salt flux at surface from coupler', units='kg s-1') + Time, diag, long_name='Area integrated surface salt flux at surface from coupler', & + units='kg s-1', conversion=1e-3*US%RZL2_to_kg*US%s_to_T) handles%id_total_saltFluxAdded = register_scalar_field('ocean_model', 'total_salt_Flux_Added', & - Time, diag, long_name='Area integrated surface salt flux due to restoring or flux adjustment', units='kg s-1') + Time, diag, long_name='Area integrated surface salt flux due to restoring or flux adjustment', & + units='kg s-1', conversion=1e-3*US%RZL2_to_kg*US%s_to_T) !=============================================================== ! wave forcing diagnostics if (present(use_waves)) then if (use_waves) then handles%id_lamult = register_diag_field('ocean_model', 'lamult', & - diag%axesT1, Time, long_name='Langmuir enhancement factor received from WW3', units="nondim") + diag%axesT1, Time, long_name='Langmuir enhancement factor received from WW3', units="nondim", conversion=1.0) endif endif @@ -1953,7 +2327,7 @@ subroutine forcing_accumulate(flux_tmp, forces, fluxes, G, wt2) type(forcing), intent(inout) :: fluxes !< A structure containing time-averaged !! thermodynamic forcing fields type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, intent(out) :: wt2 !< The relative weight of the new fluxes + real, intent(out) :: wt2 !< The relative weight of the new fluxes [nondim] ! This subroutine copies mechancal forcing from flux_tmp to fluxes and ! stores the time-weighted averages of the various buoyancy fluxes in fluxes, @@ -1971,7 +2345,7 @@ subroutine fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces) type(forcing), intent(inout) :: fluxes !< A structure containing time-averaged !! thermodynamic forcing fields type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, intent(out) :: wt2 !< The relative weight of the new fluxes + real, intent(out) :: wt2 !< The relative weight of the new fluxes [nondim] type(mech_forcing), optional, intent(in) :: forces !< A structure with the driving mechanical forces ! This subroutine copies mechanical forcing from flux_tmp to fluxes and @@ -1980,8 +2354,8 @@ subroutine fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces) ! applied based on the time interval stored in flux_tmp. real :: wt1 ! The relative weight of the previous fluxes [nondim] - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isr, ier, jsr, jer + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -1996,38 +2370,63 @@ subroutine fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces) wt2 = 1.0 - wt1 ! = flux_tmp%dt_buoy_accum / (fluxes%dt_buoy_accum + flux_tmp%dt_buoy_accum) fluxes%dt_buoy_accum = fluxes%dt_buoy_accum + flux_tmp%dt_buoy_accum - ! Copy over the pressure fields and accumulate averages of ustar, either from the forcing + ! Copy over the pressure fields and accumulate averages of ustar or tau_mag, either from the forcing ! type or from the temporary fluxes type. if (present(forces)) then do j=js,je ; do i=is,ie fluxes%p_surf(i,j) = forces%p_surf(i,j) fluxes%p_surf_full(i,j) = forces%p_surf_full(i,j) + enddo ; enddo + if (associated(fluxes%ustar)) then ; do j=js,je ; do i=is,ie fluxes%ustar(i,j) = wt1*fluxes%ustar(i,j) + wt2*forces%ustar(i,j) - enddo ; enddo + enddo ; enddo ; endif + if (associated(fluxes%tau_mag)) then ; do j=js,je ; do i=is,ie + fluxes%tau_mag(i,j) = wt1*fluxes%tau_mag(i,j) + wt2*forces%tau_mag(i,j) + enddo ; enddo ; endif else do j=js,je ; do i=is,ie fluxes%p_surf(i,j) = flux_tmp%p_surf(i,j) fluxes%p_surf_full(i,j) = flux_tmp%p_surf_full(i,j) + enddo ; enddo + if (associated(fluxes%ustar)) then ; do j=js,je ; do i=is,ie fluxes%ustar(i,j) = wt1*fluxes%ustar(i,j) + wt2*flux_tmp%ustar(i,j) - enddo ; enddo + enddo ; enddo ; endif + if (associated(fluxes%tau_mag)) then ; do j=js,je ; do i=is,ie + fluxes%tau_mag(i,j) = wt1*fluxes%tau_mag(i,j) + wt2*flux_tmp%tau_mag(i,j) + enddo ; enddo ; endif endif - ! Average the water, heat, and salt fluxes, and ustar. - do j=js,je ; do i=is,ie + ! Average ustar_gustless. + if (associated(fluxes%ustar_gustless)) then if (fluxes%gustless_accum_bug) then - fluxes%ustar_gustless(i,j) = flux_tmp%ustar_gustless(i,j) + do j=js,je ; do i=is,ie + fluxes%ustar_gustless(i,j) = flux_tmp%ustar_gustless(i,j) + enddo ; enddo else - fluxes%ustar_gustless(i,j) = wt1*fluxes%ustar_gustless(i,j) + wt2*flux_tmp%ustar_gustless(i,j) + do j=js,je ; do i=is,ie + fluxes%ustar_gustless(i,j) = wt1*fluxes%ustar_gustless(i,j) + wt2*flux_tmp%ustar_gustless(i,j) + enddo ; enddo endif + endif + + if (associated(fluxes%tau_mag_gustless)) then + do j=js,je ; do i=is,ie + fluxes%tau_mag_gustless(i,j) = wt1*fluxes%tau_mag_gustless(i,j) + wt2*flux_tmp%tau_mag_gustless(i,j) + enddo ; enddo + endif + ! Average the water, heat, and salt fluxes. + do j=js,je ; do i=is,ie fluxes%evap(i,j) = wt1*fluxes%evap(i,j) + wt2*flux_tmp%evap(i,j) fluxes%lprec(i,j) = wt1*fluxes%lprec(i,j) + wt2*flux_tmp%lprec(i,j) fluxes%fprec(i,j) = wt1*fluxes%fprec(i,j) + wt2*flux_tmp%fprec(i,j) fluxes%vprec(i,j) = wt1*fluxes%vprec(i,j) + wt2*flux_tmp%vprec(i,j) fluxes%lrunoff(i,j) = wt1*fluxes%lrunoff(i,j) + wt2*flux_tmp%lrunoff(i,j) fluxes%frunoff(i,j) = wt1*fluxes%frunoff(i,j) + wt2*flux_tmp%frunoff(i,j) + fluxes%lrunoff_glc(i,j) = wt1*fluxes%lrunoff_glc(i,j) + wt2*flux_tmp%lrunoff_glc(i,j) + fluxes%frunoff_glc(i,j) = wt1*fluxes%frunoff_glc(i,j) + wt2*flux_tmp%frunoff_glc(i,j) fluxes%seaice_melt(i,j) = wt1*fluxes%seaice_melt(i,j) + wt2*flux_tmp%seaice_melt(i,j) fluxes%sw(i,j) = wt1*fluxes%sw(i,j) + wt2*flux_tmp%sw(i,j) fluxes%sw_vis_dir(i,j) = wt1*fluxes%sw_vis_dir(i,j) + wt2*flux_tmp%sw_vis_dir(i,j) @@ -2051,6 +2450,11 @@ subroutine fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces) fluxes%heat_content_cond(i,j) = wt1*fluxes%heat_content_cond(i,j) + wt2*flux_tmp%heat_content_cond(i,j) enddo ; enddo endif + if (associated(fluxes%heat_content_evap) .and. associated(flux_tmp%heat_content_evap)) then + do j=js,je ; do i=is,ie + fluxes%heat_content_evap(i,j) = wt1*fluxes%heat_content_evap(i,j) + wt2*flux_tmp%heat_content_evap(i,j) + enddo ; enddo + endif if (associated(fluxes%heat_content_lprec) .and. associated(flux_tmp%heat_content_lprec)) then do j=js,je ; do i=is,ie fluxes%heat_content_lprec(i,j) = wt1*fluxes%heat_content_lprec(i,j) + wt2*flux_tmp%heat_content_lprec(i,j) @@ -2061,11 +2465,6 @@ subroutine fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces) fluxes%heat_content_fprec(i,j) = wt1*fluxes%heat_content_fprec(i,j) + wt2*flux_tmp%heat_content_fprec(i,j) enddo ; enddo endif - if (associated(fluxes%heat_content_icemelt) .and. associated(flux_tmp%heat_content_icemelt)) then - do j=js,je ; do i=is,ie - fluxes%heat_content_icemelt(i,j) = wt1*fluxes%heat_content_icemelt(i,j) + wt2*flux_tmp%heat_content_icemelt(i,j) - enddo ; enddo - endif if (associated(fluxes%heat_content_vprec) .and. associated(flux_tmp%heat_content_vprec)) then do j=js,je ; do i=is,ie fluxes%heat_content_vprec(i,j) = wt1*fluxes%heat_content_vprec(i,j) + wt2*flux_tmp%heat_content_vprec(i,j) @@ -2081,9 +2480,22 @@ subroutine fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces) fluxes%heat_content_frunoff(i,j) = wt1*fluxes%heat_content_frunoff(i,j) + wt2*flux_tmp%heat_content_frunoff(i,j) enddo ; enddo endif - if (associated(fluxes%heat_content_icemelt) .and. associated(flux_tmp%heat_content_icemelt)) then + if (associated(fluxes%heat_content_lrunoff_glc) .and. associated(flux_tmp%heat_content_lrunoff_glc)) then + do j=js,je ; do i=is,ie + fluxes%heat_content_lrunoff_glc(i,j) = wt1*fluxes%heat_content_lrunoff_glc(i,j) + & + wt2*flux_tmp%heat_content_lrunoff_glc(i,j) + enddo ; enddo + endif + if (associated(fluxes%heat_content_frunoff_glc) .and. associated(flux_tmp%heat_content_frunoff_glc)) then + do j=js,je ; do i=is,ie + fluxes%heat_content_frunoff_glc(i,j) = wt1*fluxes%heat_content_frunoff_glc(i,j) + & + wt2*flux_tmp%heat_content_frunoff_glc(i,j) + enddo ; enddo + endif + if (associated(fluxes%carbon_content_lrunoff) .and. associated(flux_tmp%carbon_content_lrunoff)) then do j=js,je ; do i=is,ie - fluxes%heat_content_icemelt(i,j) = wt1*fluxes%heat_content_icemelt(i,j) + wt2*flux_tmp%heat_content_icemelt(i,j) + fluxes%carbon_content_lrunoff(i,j) = wt1*fluxes%carbon_content_lrunoff(i,j) + & + wt2*flux_tmp%carbon_content_lrunoff(i,j) enddo ; enddo endif @@ -2097,6 +2509,12 @@ subroutine fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces) fluxes%iceshelf_melt(i,j) = flux_tmp%iceshelf_melt(i,j) enddo ; enddo endif + if (associated(fluxes%shelf_sfc_mass_flux) & + .and. associated(flux_tmp%shelf_sfc_mass_flux)) then + do i=isd,ied ; do j=jsd,jed + fluxes%shelf_sfc_mass_flux(i,j) = flux_tmp%shelf_sfc_mass_flux(i,j) + enddo ; enddo + endif if (associated(fluxes%frac_shelf_h) .and. associated(flux_tmp%frac_shelf_h)) then do i=isd,ied ; do j=jsd,jed fluxes%frac_shelf_h(i,j) = flux_tmp%frac_shelf_h(i,j) @@ -2129,6 +2547,16 @@ subroutine copy_common_forcing_fields(forces, fluxes, G, skip_pres) fluxes%ustar(i,j) = forces%ustar(i,j) enddo ; enddo endif + if (associated(forces%omega_w2x) .and. associated(fluxes%omega_w2x)) then + do j=js,je ; do i=is,ie + fluxes%omega_w2x(i,j) = forces%omega_w2x(i,j) + enddo ; enddo + endif + if (associated(forces%tau_mag) .and. associated(fluxes%tau_mag)) then + do j=js,je ; do i=is,ie + fluxes%tau_mag(i,j) = forces%tau_mag(i,j) + enddo ; enddo + endif if (do_pres) then if (associated(forces%p_surf) .and. associated(fluxes%p_surf)) then @@ -2169,25 +2597,30 @@ subroutine set_derived_forcing_fields(forces, fluxes, G, US, Rho0) Irho0 = US%L_to_Z / Rho0 - if (associated(forces%taux) .and. associated(forces%tauy) .and. & - associated(fluxes%ustar_gustless)) then + if ( associated(forces%taux) .and. associated(forces%tauy) .and. & + (associated(fluxes%ustar_gustless) .or. associated(fluxes%tau_mag_gustless)) ) then do j=js,je ; do i=is,ie taux2 = 0.0 - if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0) & - taux2 = (G%mask2dCu(I-1,j) * forces%taux(I-1,j)**2 + & - G%mask2dCu(I,j) * forces%taux(I,j)**2) / & + if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0.0) & + taux2 = (G%mask2dCu(I-1,j) * (forces%taux(I-1,j)**2) + & + G%mask2dCu(I,j) * (forces%taux(I,j)**2)) / & (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) tauy2 = 0.0 - if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & - tauy2 = (G%mask2dCv(i,J-1) * forces%tauy(i,J-1)**2 + & - G%mask2dCv(i,J) * forces%tauy(i,J)**2) / & + if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0.0) & + tauy2 = (G%mask2dCv(i,J-1) * (forces%tauy(i,J-1)**2) + & + G%mask2dCv(i,J) * (forces%tauy(i,J)**2)) / & (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) - if (fluxes%gustless_accum_bug) then - ! This change is just for computational efficiency, but it is wrapped with another change. - fluxes%ustar_gustless(i,j) = sqrt(US%L_to_Z * sqrt(taux2 + tauy2) / Rho0) - else - fluxes%ustar_gustless(i,j) = sqrt(sqrt(taux2 + tauy2) * Irho0) + if (associated(fluxes%ustar_gustless)) then + if (fluxes%gustless_accum_bug) then + ! This change is just for computational efficiency, but it is wrapped with another change. + fluxes%ustar_gustless(i,j) = sqrt(US%L_to_Z * sqrt(taux2 + tauy2) / Rho0) + else + fluxes%ustar_gustless(i,j) = sqrt(sqrt(taux2 + tauy2) * Irho0) + endif + endif + if (associated(fluxes%tau_mag_gustless)) then + fluxes%tau_mag_gustless(i,j) = US%L_to_Z*sqrt(taux2 + tauy2) endif enddo ; enddo endif @@ -2236,6 +2669,12 @@ subroutine get_net_mass_forcing(fluxes, G, US, net_mass_src) if (associated(fluxes%frunoff)) then ; do j=js,je ; do i=is,ie net_mass_src(i,j) = net_mass_src(i,j) + fluxes%frunoff(i,j) enddo ; enddo ; endif + if (associated(fluxes%lrunoff_glc)) then ; do j=js,je ; do i=is,ie + net_mass_src(i,j) = net_mass_src(i,j) + fluxes%lrunoff_glc(i,j) + enddo ; enddo ; endif + if (associated(fluxes%frunoff_glc)) then ; do j=js,je ; do i=is,ie + net_mass_src(i,j) = net_mass_src(i,j) + fluxes%frunoff_glc(i,j) + enddo ; enddo ; endif if (associated(fluxes%evap)) then ; do j=js,je ; do i=is,ie net_mass_src(i,j) = net_mass_src(i,j) + fluxes%evap(i,j) enddo ; enddo ; endif @@ -2260,6 +2699,16 @@ subroutine copy_back_forcing_fields(fluxes, forces, G) forces%ustar(i,j) = fluxes%ustar(i,j) enddo ; enddo endif + if (associated(forces%omega_w2x) .and. associated(fluxes%omega_w2x)) then + do j=js,je ; do i=is,ie + forces%omega_w2x(i,j) = fluxes%omega_w2x(i,j) + enddo ; enddo + endif + if (associated(forces%tau_mag) .and. associated(fluxes%tau_mag)) then + do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = fluxes%tau_mag(i,j) + enddo ; enddo + endif end subroutine copy_back_forcing_fields @@ -2267,13 +2716,13 @@ end subroutine copy_back_forcing_fields !! fields registered as part of register_forcing_type_diags. subroutine mech_forcing_diags(forces_in, dt, G, time_end, diag, handles) type(mech_forcing), target, intent(in) :: forces_in !< mechanical forcing input fields - real, intent(in) :: dt !< time step for the forcing [s] + real, intent(in) :: dt !< time step for the forcing [T ~> s] type(ocean_grid_type), intent(in) :: G !< grid type type(time_type), intent(in) :: time_end !< The end time of the diagnostic interval. type(diag_ctrl), intent(inout) :: diag !< diagnostic type type(forcing_diags), intent(inout) :: handles !< diagnostic id for diag_manager - integer :: i,j,is,ie,js,je + integer :: is, ie, js, je type(mech_forcing), pointer :: forces integer :: turns @@ -2292,7 +2741,7 @@ subroutine mech_forcing_diags(forces_in, dt, G, time_end, diag, handles) endif is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - call enable_averaging(dt, time_end, diag) + call enable_averages(dt, time_end, diag) ! if (query_averaging_enabled(diag)) then if ((handles%id_taux > 0) .and. associated(forces%taux)) & @@ -2322,7 +2771,7 @@ end subroutine mech_forcing_diags !> Offer buoyancy forcing fields for diagnostics for those !! fields registered as part of register_forcing_type_diags. -subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, handles) +subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, handles, enthalpy) type(forcing), target, intent(in) :: fluxes_in !< A structure containing thermodynamic forcing fields type(surface), intent(in) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. @@ -2331,28 +2780,39 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h type(time_type), intent(in) :: time_end !< The end time of the diagnostic interval. type(diag_ctrl), intent(inout) :: diag !< diagnostic regulator type(forcing_diags), intent(inout) :: handles !< diagnostic ids + logical, optional, intent(in ) :: enthalpy !< If present and true, the heat content associated + !! with mass entering/leaving the ocean is provided + !! by the coupler. Diagnostics net_heat_surface and + !! heat_content_surfwater are computed using + !! heat_content_evap instead of heat_content_massout. ! local variables type(ocean_grid_type), pointer :: G ! Grid metric on model index map type(forcing), pointer :: fluxes ! Fluxes on the model index map real, dimension(SZI_(diag%G),SZJ_(diag%G)) :: res ! A temporary array for combinations - ! of fluxes [R Z T-1 ~> kg m-2 s-1] or [Q R Z T-1 ~> W m-2] - real :: total_transport ! for diagnosing integrated boundary transport, in MKS units of [kg s-1] or [W] - real :: ave_flux ! for diagnosing averaged boundary flux, in MKS units of [kg m-2 s-1] or [W m-2] + ! of mass fluxes [R Z T-1 ~> kg m-2 s-1] or heat fluxes [Q R Z T-1 ~> W m-2] + real :: total_mass_flux ! Diagnostic of an integrated boundary mass flux in [R Z L2 T-1 ~> kg s-1] + real :: total_heat_flux ! Diagnostic of an integrated boundary heat flux in [Q R Z L2 T-1 ~> W] + real :: total_salt_flux ! Diagnostic of an integrated boundary salt flux in [R Z L2 T-1 ~> kg s-1] + real :: ave_mass_flux ! Diagnostic of the average of a surface mass flux in [R Z T-1 ~> kg m-2 s-1] + real :: ave_heat_flux ! Diagnostic of the average of a surface heat flux in [Q R Z T-1 ~> W m-2] real :: I_dt ! inverse time step [T-1 ~> s-1] - real :: ppt2mks ! conversion between ppt and mks units [nondim] integer :: turns ! Number of index quarter turns + logical :: mom_enthalpy ! If true (default) enthalpy terms are computed in MOM6 integer :: i, j, is, ie, js, je call cpu_clock_begin(handles%id_clock_forcing) + mom_enthalpy = .true. + if (present(enthalpy)) mom_enthalpy = .not. enthalpy + ! NOTE: post_data expects data to be on the rotated index map, so any ! rotations must be applied before saving the output. turns = diag%G%HI%turns if (turns /= 0) then G => diag%G allocate(fluxes) - call allocate_forcing_type(fluxes_in, G, fluxes) + call allocate_forcing_type(fluxes_in, G, fluxes, turns=turns) call rotate_forcing(fluxes_in, fluxes, turns) else G => G_in @@ -2360,7 +2820,6 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h endif I_dt = 1.0 / fluxes%dt_buoy_accum - ppt2mks = 1e-3 is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec call enable_averages(fluxes%dt_buoy_accum, time_end, diag) @@ -2377,17 +2836,19 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (associated(fluxes%evap)) res(i,j) = res(i,j) + fluxes%evap(i,j) if (associated(fluxes%lrunoff)) res(i,j) = res(i,j) + fluxes%lrunoff(i,j) if (associated(fluxes%frunoff)) res(i,j) = res(i,j) + fluxes%frunoff(i,j) + if (associated(fluxes%lrunoff_glc)) res(i,j) = res(i,j) + fluxes%lrunoff_glc(i,j) + if (associated(fluxes%frunoff_glc)) res(i,j) = res(i,j) + fluxes%frunoff_glc(i,j) if (associated(fluxes%vprec)) res(i,j) = res(i,j) + fluxes%vprec(i,j) if (associated(fluxes%seaice_melt)) res(i,j) = res(i,j) + fluxes%seaice_melt(i,j) enddo ; enddo if (handles%id_prcme > 0) call post_data(handles%id_prcme, res, diag) if (handles%id_total_prcme > 0) then - total_transport = global_area_integral(res, G, scale=US%RZ_T_to_kg_m2s) - call post_data(handles%id_total_prcme, total_transport, diag) + total_mass_flux = global_area_integral(res, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_prcme, total_mass_flux, diag) endif if (handles%id_prcme_ga > 0) then - ave_flux = global_area_mean(res, G, scale=US%RZ_T_to_kg_m2s) - call post_data(handles%id_prcme_ga, ave_flux, diag) + ave_mass_flux = global_area_mean(res, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_prcme_ga, ave_mass_flux, diag) endif endif @@ -2409,8 +2870,8 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h enddo ; enddo if (handles%id_net_massout > 0) call post_data(handles%id_net_massout, res, diag) if (handles%id_total_net_massout > 0) then - total_transport = global_area_integral(res, G, scale=US%RZ_T_to_kg_m2s) - call post_data(handles%id_total_net_massout, total_transport, diag) + total_mass_flux = global_area_integral(res, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_net_massout, total_mass_flux, diag) endif endif @@ -2420,10 +2881,11 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (handles%id_net_massin > 0 .or. handles%id_total_net_massin > 0) then do j=js,je ; do i=is,ie res(i,j) = 0.0 - if (associated(fluxes%fprec)) res(i,j) = res(i,j) + fluxes%fprec(i,j) if (associated(fluxes%lrunoff)) res(i,j) = res(i,j) + fluxes%lrunoff(i,j) if (associated(fluxes%frunoff)) res(i,j) = res(i,j) + fluxes%frunoff(i,j) + if (associated(fluxes%lrunoff_glc)) res(i,j) = res(i,j) + fluxes%lrunoff_glc(i,j) + if (associated(fluxes%frunoff_glc)) res(i,j) = res(i,j) + fluxes%frunoff_glc(i,j) if (associated(fluxes%lprec)) then if (fluxes%lprec(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%lprec(i,j) @@ -2441,8 +2903,8 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h enddo ; enddo if (handles%id_net_massin > 0) call post_data(handles%id_net_massin, res, diag) if (handles%id_total_net_massin > 0) then - total_transport = global_area_integral(res, G, scale=US%RZ_T_to_kg_m2s) - call post_data(handles%id_total_net_massin, total_transport, diag) + total_mass_flux = global_area_integral(res, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_net_massin, total_mass_flux, diag) endif endif @@ -2452,12 +2914,12 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if ((handles%id_evap > 0) .and. associated(fluxes%evap)) & call post_data(handles%id_evap, fluxes%evap, diag) if ((handles%id_total_evap > 0) .and. associated(fluxes%evap)) then - total_transport = global_area_integral(fluxes%evap, G, scale=US%RZ_T_to_kg_m2s) - call post_data(handles%id_total_evap, total_transport, diag) + total_mass_flux = global_area_integral(fluxes%evap, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_evap, total_mass_flux, diag) endif if ((handles%id_evap_ga > 0) .and. associated(fluxes%evap)) then - ave_flux = global_area_mean(fluxes%evap, G, scale=US%RZ_T_to_kg_m2s) - call post_data(handles%id_evap_ga, ave_flux, diag) + ave_mass_flux = global_area_mean(fluxes%evap, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_evap_ga, ave_mass_flux, diag) endif if (associated(fluxes%lprec) .and. associated(fluxes%fprec)) then @@ -2466,138 +2928,171 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h enddo ; enddo if (handles%id_precip > 0) call post_data(handles%id_precip, res, diag) if (handles%id_total_precip > 0) then - total_transport = global_area_integral(res, G, scale=US%RZ_T_to_kg_m2s) - call post_data(handles%id_total_precip, total_transport, diag) + total_mass_flux = global_area_integral(res, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_precip, total_mass_flux, diag) endif if (handles%id_precip_ga > 0) then - ave_flux = global_area_mean(res, G, scale=US%RZ_T_to_kg_m2s) - call post_data(handles%id_precip_ga, ave_flux, diag) + ave_mass_flux = global_area_mean(res, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_precip_ga, ave_mass_flux, diag) endif endif if (associated(fluxes%lprec)) then if (handles%id_lprec > 0) call post_data(handles%id_lprec, fluxes%lprec, diag) if (handles%id_total_lprec > 0) then - total_transport = global_area_integral(fluxes%lprec, G, scale=US%RZ_T_to_kg_m2s) - call post_data(handles%id_total_lprec, total_transport, diag) + total_mass_flux = global_area_integral(fluxes%lprec, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_lprec, total_mass_flux, diag) endif if (handles%id_lprec_ga > 0) then - ave_flux = global_area_mean(fluxes%lprec, G, scale=US%RZ_T_to_kg_m2s) - call post_data(handles%id_lprec_ga, ave_flux, diag) + ave_mass_flux = global_area_mean(fluxes%lprec, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_lprec_ga, ave_mass_flux, diag) endif endif if (associated(fluxes%fprec)) then if (handles%id_fprec > 0) call post_data(handles%id_fprec, fluxes%fprec, diag) if (handles%id_total_fprec > 0) then - total_transport = global_area_integral(fluxes%fprec, G, scale=US%RZ_T_to_kg_m2s) - call post_data(handles%id_total_fprec, total_transport, diag) + total_mass_flux = global_area_integral(fluxes%fprec, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_fprec, total_mass_flux, diag) endif if (handles%id_fprec_ga > 0) then - ave_flux = global_area_mean(fluxes%fprec, G, scale=US%RZ_T_to_kg_m2s) - call post_data(handles%id_fprec_ga, ave_flux, diag) + ave_mass_flux = global_area_mean(fluxes%fprec, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_fprec_ga, ave_mass_flux, diag) endif endif if (associated(fluxes%vprec)) then if (handles%id_vprec > 0) call post_data(handles%id_vprec, fluxes%vprec, diag) if (handles%id_total_vprec > 0) then - total_transport = global_area_integral(fluxes%vprec, G, scale=US%RZ_T_to_kg_m2s) - call post_data(handles%id_total_vprec, total_transport, diag) + total_mass_flux = global_area_integral(fluxes%vprec, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_vprec, total_mass_flux, diag) endif if (handles%id_vprec_ga > 0) then - ave_flux = global_area_mean(fluxes%vprec, G, scale=US%RZ_T_to_kg_m2s) - call post_data(handles%id_vprec_ga, ave_flux, diag) + ave_mass_flux = global_area_mean(fluxes%vprec, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_vprec_ga, ave_mass_flux, diag) endif endif if (associated(fluxes%lrunoff)) then if (handles%id_lrunoff > 0) call post_data(handles%id_lrunoff, fluxes%lrunoff, diag) if (handles%id_total_lrunoff > 0) then - total_transport = global_area_integral(fluxes%lrunoff, G, scale=US%RZ_T_to_kg_m2s) - call post_data(handles%id_total_lrunoff, total_transport, diag) + total_mass_flux = global_area_integral(fluxes%lrunoff, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_lrunoff, total_mass_flux, diag) + endif + endif + + if (associated(fluxes%lrunoff_glc)) then + if (handles%id_lrunoff_glc > 0) call post_data(handles%id_lrunoff_glc, fluxes%lrunoff_glc, diag) + if (handles%id_total_lrunoff_glc > 0) then + total_mass_flux = global_area_integral(fluxes%lrunoff_glc, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_lrunoff_glc, total_mass_flux, diag) endif endif if (associated(fluxes%frunoff)) then if (handles%id_frunoff > 0) call post_data(handles%id_frunoff, fluxes%frunoff, diag) if (handles%id_total_frunoff > 0) then - total_transport = global_area_integral(fluxes%frunoff, G, scale=US%RZ_T_to_kg_m2s) - call post_data(handles%id_total_frunoff, total_transport, diag) + total_mass_flux = global_area_integral(fluxes%frunoff, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_frunoff, total_mass_flux, diag) + endif + endif + + if (associated(fluxes%frunoff_glc)) then + if (handles%id_frunoff_glc > 0) call post_data(handles%id_frunoff_glc, fluxes%frunoff_glc, diag) + if (handles%id_total_frunoff_glc > 0) then + total_mass_flux = global_area_integral(fluxes%frunoff_glc, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_frunoff_glc, total_mass_flux, diag) endif endif if (associated(fluxes%seaice_melt)) then if (handles%id_seaice_melt > 0) call post_data(handles%id_seaice_melt, fluxes%seaice_melt, diag) if (handles%id_total_seaice_melt > 0) then - total_transport = global_area_integral(fluxes%seaice_melt, G, scale=US%RZ_T_to_kg_m2s) - call post_data(handles%id_total_seaice_melt, total_transport, diag) + total_mass_flux = global_area_integral(fluxes%seaice_melt, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_seaice_melt, total_mass_flux, diag) endif endif + if ((handles%id_carbon_content_lrunoff > 0) .and. associated(fluxes%carbon_content_lrunoff)) & + call post_data(handles%id_carbon_content_lrunoff, fluxes%carbon_content_lrunoff, diag) + ! post diagnostics for boundary heat fluxes ==================================== if ((handles%id_heat_content_lrunoff > 0) .and. associated(fluxes%heat_content_lrunoff)) & call post_data(handles%id_heat_content_lrunoff, fluxes%heat_content_lrunoff, diag) if ((handles%id_total_heat_content_lrunoff > 0) .and. associated(fluxes%heat_content_lrunoff)) then - total_transport = global_area_integral(fluxes%heat_content_lrunoff, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_heat_content_lrunoff, total_transport, diag) + total_heat_flux = global_area_integral(fluxes%heat_content_lrunoff, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_lrunoff, total_heat_flux, diag) + endif + + + if ((handles%id_heat_content_lrunoff_glc > 0) .and. associated(fluxes%heat_content_lrunoff_glc)) & + call post_data(handles%id_heat_content_lrunoff_glc, fluxes%heat_content_lrunoff_glc, diag) + if ((handles%id_total_heat_content_lrunoff_glc > 0) .and. associated(fluxes%heat_content_lrunoff_glc)) then + total_heat_flux = global_area_integral(fluxes%heat_content_lrunoff_glc, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_lrunoff_glc, total_heat_flux, diag) endif if ((handles%id_heat_content_frunoff > 0) .and. associated(fluxes%heat_content_frunoff)) & call post_data(handles%id_heat_content_frunoff, fluxes%heat_content_frunoff, diag) if ((handles%id_total_heat_content_frunoff > 0) .and. associated(fluxes%heat_content_frunoff)) then - total_transport = global_area_integral(fluxes%heat_content_frunoff, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_heat_content_frunoff, total_transport, diag) + total_heat_flux = global_area_integral(fluxes%heat_content_frunoff, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_frunoff, total_heat_flux, diag) + endif + if ((handles%id_heat_content_frunoff_glc > 0) .and. associated(fluxes%heat_content_frunoff_glc)) & + call post_data(handles%id_heat_content_frunoff_glc, fluxes%heat_content_frunoff_glc, diag) + if ((handles%id_total_heat_content_frunoff_glc > 0) .and. associated(fluxes%heat_content_frunoff_glc)) then + total_heat_flux = global_area_integral(fluxes%heat_content_frunoff_glc, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_frunoff_glc, total_heat_flux, diag) endif if ((handles%id_heat_content_lprec > 0) .and. associated(fluxes%heat_content_lprec)) & call post_data(handles%id_heat_content_lprec, fluxes%heat_content_lprec, diag) if ((handles%id_total_heat_content_lprec > 0) .and. associated(fluxes%heat_content_lprec)) then - total_transport = global_area_integral(fluxes%heat_content_lprec, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_heat_content_lprec, total_transport, diag) + total_heat_flux = global_area_integral(fluxes%heat_content_lprec, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_lprec, total_heat_flux, diag) endif if ((handles%id_heat_content_fprec > 0) .and. associated(fluxes%heat_content_fprec)) & call post_data(handles%id_heat_content_fprec, fluxes%heat_content_fprec, diag) if ((handles%id_total_heat_content_fprec > 0) .and. associated(fluxes%heat_content_fprec)) then - total_transport = global_area_integral(fluxes%heat_content_fprec, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_heat_content_fprec, total_transport, diag) - endif - - if ((handles%id_heat_content_icemelt > 0) .and. associated(fluxes%heat_content_icemelt)) & - call post_data(handles%id_heat_content_icemelt, fluxes%heat_content_icemelt, diag) - if ((handles%id_total_heat_content_icemelt > 0) .and. associated(fluxes%heat_content_icemelt)) then - total_transport = global_area_integral(fluxes%heat_content_icemelt, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_heat_content_icemelt, total_transport, diag) + total_heat_flux = global_area_integral(fluxes%heat_content_fprec, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_fprec, total_heat_flux, diag) endif if ((handles%id_heat_content_vprec > 0) .and. associated(fluxes%heat_content_vprec)) & call post_data(handles%id_heat_content_vprec, fluxes%heat_content_vprec, diag) if ((handles%id_total_heat_content_vprec > 0) .and. associated(fluxes%heat_content_vprec)) then - total_transport = global_area_integral(fluxes%heat_content_vprec, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_heat_content_vprec, total_transport, diag) + total_heat_flux = global_area_integral(fluxes%heat_content_vprec, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_vprec, total_heat_flux, diag) endif if ((handles%id_heat_content_cond > 0) .and. associated(fluxes%heat_content_cond)) & call post_data(handles%id_heat_content_cond, fluxes%heat_content_cond, diag) if ((handles%id_total_heat_content_cond > 0) .and. associated(fluxes%heat_content_cond)) then - total_transport = global_area_integral(fluxes%heat_content_cond, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_heat_content_cond, total_transport, diag) + total_heat_flux = global_area_integral(fluxes%heat_content_cond, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_cond, total_heat_flux, diag) + endif + + if ((handles%id_heat_content_evap > 0) .and. associated(fluxes%heat_content_evap)) & + call post_data(handles%id_heat_content_evap, fluxes%heat_content_evap, diag) + if ((handles%id_total_heat_content_evap > 0) .and. associated(fluxes%heat_content_evap)) then + total_heat_flux = global_area_integral(fluxes%heat_content_evap, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_evap, total_heat_flux, diag) endif if ((handles%id_heat_content_massout > 0) .and. associated(fluxes%heat_content_massout)) & call post_data(handles%id_heat_content_massout, fluxes%heat_content_massout, diag) if ((handles%id_total_heat_content_massout > 0) .and. associated(fluxes%heat_content_massout)) then - total_transport = global_area_integral(fluxes%heat_content_massout, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_heat_content_massout, total_transport, diag) + total_heat_flux = global_area_integral(fluxes%heat_content_massout, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_massout, total_heat_flux, diag) endif if ((handles%id_heat_content_massin > 0) .and. associated(fluxes%heat_content_massin)) & call post_data(handles%id_heat_content_massin, fluxes%heat_content_massin, diag) if ((handles%id_total_heat_content_massin > 0) .and. associated(fluxes%heat_content_massin)) then - total_transport = global_area_integral(fluxes%heat_content_massin, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_heat_content_massin, total_transport, diag) + total_heat_flux = global_area_integral(fluxes%heat_content_massin, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_massin, total_heat_flux, diag) endif if (handles%id_net_heat_coupler > 0 .or. handles%id_total_net_heat_coupler > 0 .or. & @@ -2612,12 +3107,12 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h enddo ; enddo if (handles%id_net_heat_coupler > 0) call post_data(handles%id_net_heat_coupler, res, diag) if (handles%id_total_net_heat_coupler > 0) then - total_transport = global_area_integral(res, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_net_heat_coupler, total_transport, diag) + total_heat_flux = global_area_integral(res, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_net_heat_coupler, total_heat_flux, diag) endif if (handles%id_net_heat_coupler_ga > 0) then - ave_flux = global_area_mean(res, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_net_heat_coupler_ga, ave_flux, diag) + ave_heat_flux = global_area_mean(res, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_net_heat_coupler_ga, ave_heat_flux, diag) endif endif @@ -2631,60 +3126,64 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (associated(fluxes%SW)) res(i,j) = res(i,j) + fluxes%sw(i,j) if (associated(fluxes%seaice_melt_heat)) res(i,j) = res(i,j) + fluxes%seaice_melt_heat(i,j) if (allocated(sfc_state%frazil)) res(i,j) = res(i,j) + sfc_state%frazil(i,j) * I_dt - !if (associated(sfc_state%TempXpme)) then - ! res(i,j) = res(i,j) + sfc_state%TempXpme(i,j) * fluxes%C_p * I_dt - !else - if (associated(fluxes%heat_content_lrunoff)) & - res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) - if (associated(fluxes%heat_content_frunoff)) & - res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) - if (associated(fluxes%heat_content_lprec)) & - res(i,j) = res(i,j) + fluxes%heat_content_lprec(i,j) - if (associated(fluxes%heat_content_fprec)) & - res(i,j) = res(i,j) + fluxes%heat_content_fprec(i,j) - if (associated(fluxes%heat_content_icemelt)) & - res(i,j) = res(i,j) + fluxes%heat_content_icemelt(i,j) - if (associated(fluxes%heat_content_vprec)) & - res(i,j) = res(i,j) + fluxes%heat_content_vprec(i,j) - if (associated(fluxes%heat_content_cond)) & - res(i,j) = res(i,j) + fluxes%heat_content_cond(i,j) + if (associated(fluxes%heat_content_lrunoff)) & + res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) + if (associated(fluxes%heat_content_frunoff)) & + res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) + if (associated(fluxes%heat_content_lrunoff_glc)) & + res(i,j) = res(i,j) + fluxes%heat_content_lrunoff_glc(i,j) + if (associated(fluxes%heat_content_frunoff_glc)) & + res(i,j) = res(i,j) + fluxes%heat_content_frunoff_glc(i,j) + if (associated(fluxes%heat_content_lprec)) & + res(i,j) = res(i,j) + fluxes%heat_content_lprec(i,j) + if (associated(fluxes%heat_content_fprec)) & + res(i,j) = res(i,j) + fluxes%heat_content_fprec(i,j) + if (associated(fluxes%heat_content_vprec)) & + res(i,j) = res(i,j) + fluxes%heat_content_vprec(i,j) + if (associated(fluxes%heat_content_cond)) & + res(i,j) = res(i,j) + fluxes%heat_content_cond(i,j) + if (mom_enthalpy) then if (associated(fluxes%heat_content_massout)) & res(i,j) = res(i,j) + fluxes%heat_content_massout(i,j) - !endif + else + if (associated(fluxes%heat_content_evap)) & + res(i,j) = res(i,j) + fluxes%heat_content_evap(i,j) + endif if (associated(fluxes%heat_added)) res(i,j) = res(i,j) + fluxes%heat_added(i,j) enddo ; enddo if (handles%id_net_heat_surface > 0) call post_data(handles%id_net_heat_surface, res, diag) if (handles%id_total_net_heat_surface > 0) then - total_transport = global_area_integral(res, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_net_heat_surface, total_transport, diag) + total_heat_flux = global_area_integral(res, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_net_heat_surface, total_heat_flux, diag) endif if (handles%id_net_heat_surface_ga > 0) then - ave_flux = global_area_mean(res, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_net_heat_surface_ga, ave_flux, diag) + ave_heat_flux = global_area_mean(res, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_net_heat_surface_ga, ave_heat_flux, diag) endif endif if (handles%id_heat_content_surfwater > 0 .or. handles%id_total_heat_content_surfwater > 0) then do j=js,je ; do i=is,ie res(i,j) = 0.0 - ! if (associated(sfc_state%TempXpme)) then - ! res(i,j) = res(i,j) + sfc_state%TempXpme(i,j) * fluxes%C_p * I_dt - ! else - if (associated(fluxes%heat_content_lrunoff)) res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) - if (associated(fluxes%heat_content_frunoff)) res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) - if (associated(fluxes%heat_content_lprec)) res(i,j) = res(i,j) + fluxes%heat_content_lprec(i,j) - if (associated(fluxes%heat_content_icemelt)) res(i,j) = res(i,j) + fluxes%heat_content_icemelt(i,j) - if (associated(fluxes%heat_content_fprec)) res(i,j) = res(i,j) + fluxes%heat_content_fprec(i,j) - if (associated(fluxes%heat_content_vprec)) res(i,j) = res(i,j) + fluxes%heat_content_vprec(i,j) - if (associated(fluxes%heat_content_cond)) res(i,j) = res(i,j) + fluxes%heat_content_cond(i,j) + if (associated(fluxes%heat_content_lrunoff)) res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) + if (associated(fluxes%heat_content_frunoff)) res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) + if (associated(fluxes%heat_content_lrunoff_glc)) res(i,j) = res(i,j) + fluxes%heat_content_lrunoff_glc(i,j) + if (associated(fluxes%heat_content_frunoff_glc)) res(i,j) = res(i,j) + fluxes%heat_content_frunoff_glc(i,j) + if (associated(fluxes%heat_content_lprec)) res(i,j) = res(i,j) + fluxes%heat_content_lprec(i,j) + if (associated(fluxes%heat_content_fprec)) res(i,j) = res(i,j) + fluxes%heat_content_fprec(i,j) + if (associated(fluxes%heat_content_vprec)) res(i,j) = res(i,j) + fluxes%heat_content_vprec(i,j) + if (associated(fluxes%heat_content_cond)) res(i,j) = res(i,j) + fluxes%heat_content_cond(i,j) + if (mom_enthalpy) then if (associated(fluxes%heat_content_massout)) res(i,j) = res(i,j) + fluxes%heat_content_massout(i,j) - ! endif + else + if (associated(fluxes%heat_content_evap)) res(i,j) = res(i,j) + fluxes%heat_content_evap(i,j) + endif enddo ; enddo if (handles%id_heat_content_surfwater > 0) call post_data(handles%id_heat_content_surfwater, res, diag) if (handles%id_total_heat_content_surfwater > 0) then - total_transport = global_area_integral(res, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_heat_content_surfwater, total_transport, diag) + total_heat_flux = global_area_integral(res, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_surfwater, total_heat_flux, diag) endif endif @@ -2694,6 +3193,8 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h res(i,j) = 0.0 if (associated(fluxes%heat_content_lrunoff)) res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) if (associated(fluxes%heat_content_frunoff)) res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) + if (associated(fluxes%heat_content_lrunoff_glc)) res(i,j) = res(i,j) + fluxes%heat_content_lrunoff_glc(i,j) + if (associated(fluxes%heat_content_frunoff_glc)) res(i,j) = res(i,j) + fluxes%heat_content_frunoff_glc(i,j) enddo ; enddo call post_data(handles%id_hfrunoffds, res, diag) endif @@ -2722,8 +3223,8 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h do j=js,je ; do i=is,ie res(i,j) = (fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j) enddo ; enddo - total_transport = global_area_integral(res, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_LwLatSens, total_transport, diag) + total_heat_flux = global_area_integral(res, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_LwLatSens, total_heat_flux, diag) endif if ((handles%id_LwLatSens_ga > 0) .and. associated(fluxes%lw) .and. & @@ -2731,8 +3232,8 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h do j=js,je ; do i=is,ie res(i,j) = ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) enddo ; enddo - ave_flux = global_area_mean(res, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_LwLatSens_ga, ave_flux, diag) + ave_heat_flux = global_area_mean(res, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_LwLatSens_ga, ave_heat_flux, diag) endif if ((handles%id_sw > 0) .and. associated(fluxes%sw)) then @@ -2747,60 +3248,68 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_sw_nir, fluxes%sw_nir_dir+fluxes%sw_nir_dif, diag) endif if ((handles%id_total_sw > 0) .and. associated(fluxes%sw)) then - total_transport = global_area_integral(fluxes%sw, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_sw, total_transport, diag) + total_heat_flux = global_area_integral(fluxes%sw, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_sw, total_heat_flux, diag) endif if ((handles%id_sw_ga > 0) .and. associated(fluxes%sw)) then - ave_flux = global_area_mean(fluxes%sw, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_sw_ga, ave_flux, diag) + ave_heat_flux = global_area_mean(fluxes%sw, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_sw_ga, ave_heat_flux, diag) endif if ((handles%id_lw > 0) .and. associated(fluxes%lw)) then call post_data(handles%id_lw, fluxes%lw, diag) endif if ((handles%id_total_lw > 0) .and. associated(fluxes%lw)) then - total_transport = global_area_integral(fluxes%lw, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_lw, total_transport, diag) + total_heat_flux = global_area_integral(fluxes%lw, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_lw, total_heat_flux, diag) endif if ((handles%id_lw_ga > 0) .and. associated(fluxes%lw)) then - ave_flux = global_area_mean(fluxes%lw, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_lw_ga, ave_flux, diag) + ave_heat_flux = global_area_mean(fluxes%lw, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_lw_ga, ave_heat_flux, diag) endif if ((handles%id_lat > 0) .and. associated(fluxes%latent)) then call post_data(handles%id_lat, fluxes%latent, diag) endif if ((handles%id_total_lat > 0) .and. associated(fluxes%latent)) then - total_transport = global_area_integral(fluxes%latent, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_lat, total_transport, diag) + total_heat_flux = global_area_integral(fluxes%latent, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_lat, total_heat_flux, diag) endif if ((handles%id_lat_ga > 0) .and. associated(fluxes%latent)) then - ave_flux = global_area_mean(fluxes%latent, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_lat_ga, ave_flux, diag) + ave_heat_flux = global_area_mean(fluxes%latent, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_lat_ga, ave_heat_flux, diag) endif if ((handles%id_lat_evap > 0) .and. associated(fluxes%latent_evap_diag)) then call post_data(handles%id_lat_evap, fluxes%latent_evap_diag, diag) endif if ((handles%id_total_lat_evap > 0) .and. associated(fluxes%latent_evap_diag)) then - total_transport = global_area_integral(fluxes%latent_evap_diag, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_lat_evap, total_transport, diag) + total_heat_flux = global_area_integral(fluxes%latent_evap_diag, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_lat_evap, total_heat_flux, diag) endif if ((handles%id_lat_fprec > 0) .and. associated(fluxes%latent_fprec_diag)) then call post_data(handles%id_lat_fprec, fluxes%latent_fprec_diag, diag) endif if ((handles%id_total_lat_fprec > 0) .and. associated(fluxes%latent_fprec_diag)) then - total_transport = global_area_integral(fluxes%latent_fprec_diag, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_lat_fprec, total_transport, diag) + total_heat_flux = global_area_integral(fluxes%latent_fprec_diag, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_lat_fprec, total_heat_flux, diag) endif if ((handles%id_lat_frunoff > 0) .and. associated(fluxes%latent_frunoff_diag)) then call post_data(handles%id_lat_frunoff, fluxes%latent_frunoff_diag, diag) endif if (handles%id_total_lat_frunoff > 0 .and. associated(fluxes%latent_frunoff_diag)) then - total_transport = global_area_integral(fluxes%latent_frunoff_diag, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_lat_frunoff, total_transport, diag) + total_heat_flux = global_area_integral(fluxes%latent_frunoff_diag, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_lat_frunoff, total_heat_flux, diag) + endif + + if ((handles%id_lat_frunoff_glc > 0) .and. associated(fluxes%latent_frunoff_glc_diag)) then + call post_data(handles%id_lat_frunoff_glc, fluxes%latent_frunoff_glc_diag, diag) + endif + if (handles%id_total_lat_frunoff_glc > 0 .and. associated(fluxes%latent_frunoff_glc_diag)) then + total_heat_flux = global_area_integral(fluxes%latent_frunoff_glc_diag, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_lat_frunoff_glc, total_heat_flux, diag) endif if ((handles%id_sens > 0) .and. associated(fluxes%sens)) then @@ -2812,17 +3321,17 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h endif if ((handles%id_total_seaice_melt_heat > 0) .and. associated(fluxes%seaice_melt_heat)) then - total_transport = global_area_integral(fluxes%seaice_melt_heat, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_seaice_melt_heat, total_transport, diag) + total_heat_flux = global_area_integral(fluxes%seaice_melt_heat, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_seaice_melt_heat, total_heat_flux, diag) endif if ((handles%id_total_sens > 0) .and. associated(fluxes%sens)) then - total_transport = global_area_integral(fluxes%sens, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_sens, total_transport, diag) + total_heat_flux = global_area_integral(fluxes%sens, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_sens, total_heat_flux, diag) endif if ((handles%id_sens_ga > 0) .and. associated(fluxes%sens)) then - ave_flux = global_area_mean(fluxes%sens, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_sens_ga, ave_flux, diag) + ave_heat_flux = global_area_mean(fluxes%sens, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_sens_ga, ave_heat_flux, diag) endif if ((handles%id_heat_added > 0) .and. associated(fluxes%heat_added)) then @@ -2830,8 +3339,8 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h endif if ((handles%id_total_heat_added > 0) .and. associated(fluxes%heat_added)) then - total_transport = global_area_integral(fluxes%heat_added, G, scale=US%QRZ_T_to_W_m2) - call post_data(handles%id_total_heat_added, total_transport, diag) + total_heat_flux = global_area_integral(fluxes%heat_added, G, tmp_scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_added, total_heat_flux, diag) endif @@ -2840,24 +3349,27 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if ((handles%id_saltflux > 0) .and. associated(fluxes%salt_flux)) & call post_data(handles%id_saltflux, fluxes%salt_flux, diag) if ((handles%id_total_saltflux > 0) .and. associated(fluxes%salt_flux)) then - total_transport = ppt2mks*global_area_integral(fluxes%salt_flux, G, scale=US%RZ_T_to_kg_m2s) - call post_data(handles%id_total_saltflux, total_transport, diag) + total_salt_flux = global_area_integral(fluxes%salt_flux, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_saltflux, total_salt_flux, diag) endif if ((handles%id_saltFluxAdded > 0) .and. associated(fluxes%salt_flux_added)) & call post_data(handles%id_saltFluxAdded, fluxes%salt_flux_added, diag) if ((handles%id_total_saltFluxAdded > 0) .and. associated(fluxes%salt_flux_added)) then - total_transport = ppt2mks*global_area_integral(fluxes%salt_flux_added, G, scale=US%RZ_T_to_kg_m2s) - call post_data(handles%id_total_saltFluxAdded, total_transport, diag) + total_salt_flux = global_area_integral(fluxes%salt_flux_added, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_saltFluxAdded, total_salt_flux, diag) endif if (handles%id_saltFluxIn > 0 .and. associated(fluxes%salt_flux_in)) & call post_data(handles%id_saltFluxIn, fluxes%salt_flux_in, diag) if ((handles%id_total_saltFluxIn > 0) .and. associated(fluxes%salt_flux_in)) then - total_transport = ppt2mks*global_area_integral(fluxes%salt_flux_in, G, scale=US%RZ_T_to_kg_m2s) - call post_data(handles%id_total_saltFluxIn, total_transport, diag) + total_salt_flux = global_area_integral(fluxes%salt_flux_in, G, tmp_scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_saltFluxIn, total_salt_flux, diag) endif + if (handles%id_saltFluxBehind > 0 .and. associated(fluxes%salt_left_behind)) & + call post_data(handles%id_saltFluxBehind, fluxes%salt_left_behind, diag) + if (handles%id_saltFluxGlobalAdj > 0) & call post_data(handles%id_saltFluxGlobalAdj, fluxes%saltFluxGlobalAdj, diag) if (handles%id_vPrecGlobalAdj > 0) & @@ -2871,13 +3383,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (handles%id_netFWGlobalScl > 0) & call post_data(handles%id_netFWGlobalScl, fluxes%netFWGlobalScl, diag) - ! post diagnostics related to cfcs ==================================== - - if ((handles%id_cfc11 > 0) .and. associated(fluxes%cfc11_flux)) & - call post_data(handles%id_cfc11, fluxes%cfc11_flux, diag) - - if ((handles%id_cfc11 > 0) .and. associated(fluxes%cfc12_flux)) & - call post_data(handles%id_cfc12, fluxes%cfc12_flux, diag) + ! post diagnostics related to tracer surface fluxes ======================== if ((handles%id_ice_fraction > 0) .and. associated(fluxes%ice_fraction)) & call post_data(handles%id_ice_fraction, fluxes%ice_fraction, diag) @@ -2890,15 +3396,21 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if ((handles%id_psurf > 0) .and. associated(fluxes%p_surf)) & call post_data(handles%id_psurf, fluxes%p_surf, diag) - if ((handles%id_TKE_tidal > 0) .and. associated(fluxes%TKE_tidal)) & - call post_data(handles%id_TKE_tidal, fluxes%TKE_tidal, diag) + if ((handles%id_TKE_tidal > 0) .and. associated(fluxes%BBL_tidal_dis)) & + call post_data(handles%id_TKE_tidal, fluxes%BBL_tidal_dis, diag) if ((handles%id_buoy > 0) .and. associated(fluxes%buoy)) & call post_data(handles%id_buoy, fluxes%buoy, diag) + if ((handles%id_tau_mag > 0) .and. associated(fluxes%tau_mag)) & + call post_data(handles%id_tau_mag, fluxes%tau_mag, diag) + if ((handles%id_ustar > 0) .and. associated(fluxes%ustar)) & call post_data(handles%id_ustar, fluxes%ustar, diag) + if ((handles%id_omega_w2x > 0) .and. associated(fluxes%omega_w2x)) & + call post_data(handles%id_omega_w2x, fluxes%omega_w2x, diag) + if ((handles%id_ustar_berg > 0) .and. associated(fluxes%ustar_berg)) & call post_data(handles%id_ustar_berg, fluxes%ustar_berg, diag) @@ -2926,7 +3438,9 @@ end subroutine forcing_diagnostics !> Conditionally allocate fields within the forcing type subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & - shelf, iceberg, salt, fix_accum_bug, cfc, waves) + shelf, iceberg, salt, fix_accum_bug, cfc, marbl, & + waves, shelf_sfc_accumulation, lamult, hevap, & + ice_ncat, tau_mag, carbon) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields logical, optional, intent(in) :: water !< If present and true, allocate water fluxes @@ -2938,18 +3452,43 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & logical, optional, intent(in) :: salt !< If present and true, allocate salt fluxes logical, optional, intent(in) :: fix_accum_bug !< If present and true, avoid using a bug in !! accumulation of ustar_gustless - logical, optional, intent(in) :: cfc !< If present and true, allocate cfc fluxes + logical, optional, intent(in) :: cfc !< If present and true, allocate fields needed + !! for cfc surface fluxes + logical, optional, intent(in) :: marbl !< If present and true, allocate fields needed + !! for MARBL surface fluxes logical, optional, intent(in) :: waves !< If present and true, allocate wave fields + logical, optional, intent(in) :: shelf_sfc_accumulation !< If present and true, and shelf is true, + !! then allocate surface flux deposition from the atmosphere + !! over ice shelves and ice sheets. + logical, optional, intent(in) :: lamult !< If present and true, allocate langmuir enhancement factor + logical, optional, intent(in) :: hevap !< If present and true, allocate heat content evap. + !! This field must be allocated when enthalpy is provided + !! via coupler. + integer, optional, intent(in) :: ice_ncat !< number of ice categories + logical, optional, intent(in) :: tau_mag !< If present and true, allocate tau_mag and related fields + logical, optional, intent(in) :: carbon !< If present and true, allocate carbon fluxes ! Local variables integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - logical :: heat_water + logical :: shelf_sfc_acc, enthalpy_mom + + ! if true, allocate fluxes needed to calculate enthalpy terms in MOM6 + enthalpy_mom = .true. + if (present (hevap)) enthalpy_mom = .not. hevap isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + shelf_sfc_acc = .false. + if (present(shelf_sfc_accumulation)) shelf_sfc_acc = shelf_sfc_accumulation + call myAlloc(fluxes%ustar,isd,ied,jsd,jed, ustar) call myAlloc(fluxes%ustar_gustless,isd,ied,jsd,jed, ustar) + call myAlloc(fluxes%tau_mag,isd,ied,jsd,jed, ustar) + + ! Note that myAlloc can be called safely multiple times for the same pointer. + call myAlloc(fluxes%tau_mag,isd,ied,jsd,jed, tau_mag) + call myAlloc(fluxes%tau_mag_gustless,isd,ied,jsd,jed, tau_mag) call myAlloc(fluxes%evap,isd,ied,jsd,jed, water) call myAlloc(fluxes%lprec,isd,ied,jsd,jed, water) @@ -2957,6 +3496,8 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & call myAlloc(fluxes%vprec,isd,ied,jsd,jed, water) call myAlloc(fluxes%lrunoff,isd,ied,jsd,jed, water) call myAlloc(fluxes%frunoff,isd,ied,jsd,jed, water) + call myAlloc(fluxes%lrunoff_glc,isd,ied,jsd,jed, water) + call myAlloc(fluxes%frunoff_glc,isd,ied,jsd,jed, water) call myAlloc(fluxes%seaice_melt,isd,ied,jsd,jed, water) call myAlloc(fluxes%netMassOut,isd,ied,jsd,jed, water) call myAlloc(fluxes%netMassIn,isd,ied,jsd,jed, water) @@ -2968,59 +3509,85 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & call myAlloc(fluxes%latent_evap_diag,isd,ied,jsd,jed, heat) call myAlloc(fluxes%latent_fprec_diag,isd,ied,jsd,jed, heat) call myAlloc(fluxes%latent_frunoff_diag,isd,ied,jsd,jed, heat) + call myAlloc(fluxes%latent_frunoff_glc_diag,isd,ied,jsd,jed, heat) call myAlloc(fluxes%salt_flux,isd,ied,jsd,jed, salt) + call myAlloc(fluxes%carbon_content_lrunoff,isd,ied,jsd,jed, carbon) if (present(heat) .and. present(water)) then ; if (heat .and. water) then call myAlloc(fluxes%heat_content_cond,isd,ied,jsd,jed, .true.) - call myAlloc(fluxes%heat_content_icemelt,isd,ied,jsd,jed, .true.) + call myAlloc(fluxes%heat_content_evap,isd,ied,jsd,jed, .not. enthalpy_mom) call myAlloc(fluxes%heat_content_lprec,isd,ied,jsd,jed, .true.) call myAlloc(fluxes%heat_content_fprec,isd,ied,jsd,jed, .true.) call myAlloc(fluxes%heat_content_vprec,isd,ied,jsd,jed, .true.) call myAlloc(fluxes%heat_content_lrunoff,isd,ied,jsd,jed, .true.) call myAlloc(fluxes%heat_content_frunoff,isd,ied,jsd,jed, .true.) - call myAlloc(fluxes%heat_content_massout,isd,ied,jsd,jed, .true.) - call myAlloc(fluxes%heat_content_massin,isd,ied,jsd,jed, .true.) + call myAlloc(fluxes%heat_content_lrunoff_glc,isd,ied,jsd,jed, .true.) + call myAlloc(fluxes%heat_content_frunoff_glc,isd,ied,jsd,jed, .true.) + call myAlloc(fluxes%heat_content_massout,isd,ied,jsd,jed, enthalpy_mom) + call myAlloc(fluxes%heat_content_massin,isd,ied,jsd,jed, enthalpy_mom) endif ; endif call myAlloc(fluxes%p_surf,isd,ied,jsd,jed, press) - call myAlloc(fluxes%frac_shelf_h,isd,ied,jsd,jed, shelf) - call myAlloc(fluxes%ustar_shelf,isd,ied,jsd,jed, shelf) - call myAlloc(fluxes%iceshelf_melt,isd,ied,jsd,jed, shelf) + ! These fields should only be allocated if ice shelf is enabled. + if (present(shelf)) then ; if (shelf) then + call myAlloc(fluxes%frac_shelf_h,isd,ied,jsd,jed, shelf) + call myAlloc(fluxes%ustar_shelf,isd,ied,jsd,jed, shelf) + call myAlloc(fluxes%iceshelf_melt,isd,ied,jsd,jed, shelf) + if (shelf_sfc_acc) call myAlloc(fluxes%shelf_sfc_mass_flux,isd,ied,jsd,jed, shelf_sfc_acc) + endif ; endif - !These fields should only on allocated when iceberg area is being passed through the coupler. + !These fields should only be allocated when iceberg area is being passed through the coupler. call myAlloc(fluxes%ustar_berg,isd,ied,jsd,jed, iceberg) call myAlloc(fluxes%area_berg,isd,ied,jsd,jed, iceberg) call myAlloc(fluxes%mass_berg,isd,ied,jsd,jed, iceberg) - !These fields should only on allocated when USE_CFC_CAP is activated. - call myAlloc(fluxes%cfc11_flux,isd,ied,jsd,jed, cfc) - call myAlloc(fluxes%cfc12_flux,isd,ied,jsd,jed, cfc) + !These fields should only be allocated when USE_CFC_CAP is activated. call myAlloc(fluxes%ice_fraction,isd,ied,jsd,jed, cfc) call myAlloc(fluxes%u10_sqr,isd,ied,jsd,jed, cfc) - !These fields should only on allocated when wave coupling is activated. + !These fields should only be allocated when wave coupling is activated. call myAlloc(fluxes%ice_fraction,isd,ied,jsd,jed, waves) - call myAlloc(fluxes%lamult,isd,ied,jsd,jed, waves) + call myAlloc(fluxes%lamult,isd,ied,jsd,jed, lamult) if (present(fix_accum_bug)) fluxes%gustless_accum_bug = .not.fix_accum_bug -end subroutine allocate_forcing_by_group + !These fields should only be allocated when USE_MARBL is activated. + call myAlloc(fluxes%ice_fraction,isd,ied,jsd,jed, marbl) + call myAlloc(fluxes%u10_sqr,isd,ied,jsd,jed, marbl) + call myAlloc(fluxes%noy_dep,isd,ied,jsd,jed, marbl) + call myAlloc(fluxes%nhx_dep,isd,ied,jsd,jed, marbl) + call myAlloc(fluxes%atm_co2,isd,ied,jsd,jed, marbl) + call myAlloc(fluxes%atm_alt_co2,isd,ied,jsd,jed, marbl) + call myAlloc(fluxes%dust_flux,isd,ied,jsd,jed, marbl) + call myAlloc(fluxes%iron_flux,isd,ied,jsd,jed, marbl) + + ! These fields should only be allocated when receiving multiple ice categories + if (present(ice_ncat)) then + call myAlloc(fluxes%fracr_cat,isd,ied,jsd,jed,1,ice_ncat+1, ice_ncat > 0) + call myAlloc(fluxes%qsw_cat,isd,ied,jsd,jed,1,ice_ncat+1, ice_ncat > 0) + endif -subroutine allocate_forcing_by_ref(fluxes_ref, G, fluxes) - type(forcing), intent(in) :: fluxes_ref !< Reference fluxes - type(ocean_grid_type), intent(in) :: G !< Grid metric of target fluxes - type(forcing), intent(out) :: fluxes !< Target fluxes +end subroutine allocate_forcing_by_group - logical :: do_ustar, do_water, do_heat, do_salt, do_press, do_shelf, & - do_iceberg, do_heat_added, do_buoy +!> Allocate elements of a new forcing type based on their status in an existing type. +subroutine allocate_forcing_by_ref(fluxes_ref, G, fluxes, turns) + type(forcing), intent(in) :: fluxes_ref !< Reference fluxes + type(ocean_grid_type), intent(in) :: G !< Grid metric of target fluxes + type(forcing), intent(out) :: fluxes !< Target fluxes + integer, optional, intent(in) :: turns !< If present, the number of counterclockwise + !! quarter turns to use on the new grid. - call get_forcing_groups(fluxes_ref, do_water, do_heat, do_ustar, do_press, & - do_shelf, do_iceberg, do_salt, do_heat_added, do_buoy) + logical :: do_ustar, do_taumag, do_water, do_heat, do_salt, do_press, do_shelf + logical :: do_iceberg, do_heat_added, do_buoy, do_carbon + logical :: even_turns ! True if turns is absent or even + + call get_forcing_groups(fluxes_ref, do_water, do_heat, do_ustar, do_taumag, do_press, & + do_shelf, do_iceberg, do_salt, do_heat_added, do_buoy, do_carbon) call allocate_forcing_type(G, fluxes, do_water, do_heat, do_ustar, & - do_press, do_shelf, do_iceberg, do_salt) + do_press, do_shelf, do_iceberg, do_salt, tau_mag=do_taumag, carbon=do_carbon) ! The following fluxes would typically be allocated by the driver call myAlloc(fluxes%sw_vis_dir, G%isd, G%ied, G%jsd, G%jed, & @@ -3045,21 +3612,34 @@ subroutine allocate_forcing_by_ref(fluxes_ref, G, fluxes) call myAlloc(fluxes%buoy, G%isd, G%ied, G%jsd, G%jed, & associated(fluxes_ref%buoy)) - call myAlloc(fluxes%TKE_tidal, G%isd, G%ied, G%jsd, G%jed, & - associated(fluxes_ref%TKE_tidal)) + call myAlloc(fluxes%BBL_tidal_dis, G%isd, G%ied, G%jsd, G%jed, & + associated(fluxes_ref%BBL_tidal_dis)) call myAlloc(fluxes%ustar_tidal, G%isd, G%ied, G%jsd, G%jed, & associated(fluxes_ref%ustar_tidal)) ! This flag would normally be set by a control flag in allocate_forcing_type. ! Here we copy the flag from the reference forcing. fluxes%gustless_accum_bug = fluxes_ref%gustless_accum_bug + + if (coupler_type_initialized(fluxes_ref%tr_fluxes)) then + ! The data fields in the coupler_2d_bc_type are never rotated. + even_turns = .true. ; if (present(turns)) even_turns = (modulo(turns, 2) == 0) + if (even_turns) then + call coupler_type_spawn(fluxes_ref%tr_fluxes, fluxes%tr_fluxes, & + (/G%isc,G%isc,G%iec,G%iec/), (/G%jsc,G%jsc,G%jec,G%jec/)) + else + call coupler_type_spawn(fluxes_ref%tr_fluxes, fluxes%tr_fluxes, & + (/G%jsc,G%jsc,G%jec,G%jec/), (/G%isc,G%isc,G%iec,G%iec/)) + endif + endif + end subroutine allocate_forcing_by_ref !> Conditionally allocate fields within the mechanical forcing type using !! control flags. subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & - press, iceberg, waves, num_stk_bands) + press, iceberg, waves, num_stk_bands, tau_mag) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(mech_forcing), intent(inout) :: forces !< Forcing fields structure @@ -3070,10 +3650,10 @@ subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & logical, optional, intent(in) :: iceberg !< If present and true, allocate forces for icebergs logical, optional, intent(in) :: waves !< If present and true, allocate wave fields integer, optional, intent(in) :: num_stk_bands !< Number of Stokes bands to allocate + logical, optional, intent(in) :: tau_mag !< If present and true, allocate tau_mag ! Local variables integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - logical :: heat_water isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -3082,6 +3662,9 @@ subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & call myAlloc(forces%tauy,isd,ied,JsdB,JedB, stress) call myAlloc(forces%ustar,isd,ied,jsd,jed, ustar) + call myAlloc(forces%tau_mag,isd,ied,jsd,jed, ustar) + ! Note that myAlloc can be called safely multiple times for the same pointer. + call myAlloc(forces%tau_mag,isd,ied,jsd,jed, tau_mag) call myAlloc(forces%p_surf,isd,ied,jsd,jed, press) call myAlloc(forces%p_surf_full,isd,ied,jsd,jed, press) @@ -3097,29 +3680,20 @@ subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & call myAlloc(forces%mass_berg,isd,ied,jsd,jed, iceberg) !These fields should only be allocated when waves - call myAlloc(forces%ustk0,isd,ied,jsd,jed, waves) - call myAlloc(forces%vstk0,isd,ied,jsd,jed, waves) - if (present(waves)) then; if (waves) then; + if (present(waves)) then ; if (waves) then if (.not. present(num_stk_bands)) then call MOM_error(FATAL,"Requested to & - initialize with waves, but no waves are present.") + &initialize with waves, but no waves are present.") endif if (num_stk_bands > 0) then if (.not.associated(forces%ustkb)) then - allocate(forces%stk_wavenumbers(num_stk_bands)) - forces%stk_wavenumbers(:) = 0.0 - allocate(forces%ustkb(isd:ied,jsd:jed,num_stk_bands)) - forces%ustkb(isd:ied,jsd:jed,:) = 0.0 + allocate(forces%stk_wavenumbers(num_stk_bands), source=0.0) + allocate(forces%ustkb(isd:ied,jsd:jed,num_stk_bands), source=0.0) + allocate(forces%vstkb(isd:ied,jsd:jed,num_stk_bands), source=0.0) endif endif endif ; endif - - if (present(waves)) then; if (waves) then; if (.not.associated(forces%vstkb)) then - allocate(forces%vstkb(isd:ied,jsd:jed,num_stk_bands)) - forces%vstkb(isd:ied,jsd:jed,:) = 0.0 - endif ; endif ; endif - end subroutine allocate_mech_forcing_by_group @@ -3130,37 +3704,39 @@ subroutine allocate_mech_forcing_from_ref(forces_ref, G, forces) type(ocean_grid_type), intent(in) :: G !< Grid metric of target forcing type(mech_forcing), intent(out) :: forces !< Mechanical forcing fields - logical :: do_stress, do_ustar, do_shelf, do_press, do_iceberg + logical :: do_stress, do_ustar, do_tau_mag, do_shelf, do_press, do_iceberg ! Identify the active fields in the reference forcing - call get_mech_forcing_groups(forces_ref, do_stress, do_ustar, do_shelf, & - do_press, do_iceberg) + call get_mech_forcing_groups(forces_ref, do_stress, do_ustar, do_tau_mag, do_shelf, & + do_press, do_iceberg) call allocate_mech_forcing(G, forces, do_stress, do_ustar, do_shelf, & - do_press, do_iceberg) + do_press, do_iceberg, tau_mag=do_tau_mag) end subroutine allocate_mech_forcing_from_ref !> Return flags indicating which groups of forcings are allocated -subroutine get_forcing_groups(fluxes, water, heat, ustar, press, shelf, & - iceberg, salt, heat_added, buoy) +subroutine get_forcing_groups(fluxes, water, heat, ustar, tau_mag, press, shelf, & + iceberg, salt, heat_added, buoy, carbon) type(forcing), intent(in) :: fluxes !< Reference flux fields logical, intent(out) :: water !< True if fluxes contains water-based fluxes logical, intent(out) :: heat !< True if fluxes contains heat-based fluxes - logical, intent(out) :: ustar !< True if fluxes contains ustar fluxes + logical, intent(out) :: ustar !< True if fluxes contains ustar + logical, intent(out) :: tau_mag !< True if fluxes contains tau_mag logical, intent(out) :: press !< True if fluxes contains surface pressure logical, intent(out) :: shelf !< True if fluxes contains ice shelf fields logical, intent(out) :: iceberg !< True if fluxes contains iceberg fluxes logical, intent(out) :: salt !< True if fluxes contains salt flux logical, intent(out) :: heat_added !< True if fluxes contains explicit heat logical, intent(out) :: buoy !< True if fluxes contains buoyancy fluxes + logical, optional, intent(out) :: carbon !< True if fluxes contains carbon fluxes ! NOTE: heat, salt, heat_added, and buoy would typically depend on each other ! to some degree. But since this would be enforced at the driver level, ! we handle them here as independent flags. - ustar = associated(fluxes%ustar) & - .and. associated(fluxes%ustar_gustless) + ustar = associated(fluxes%ustar) .and. associated(fluxes%ustar_gustless) + tau_mag = associated(fluxes%tau_mag) .and. associated(fluxes%tau_mag_gustless) ! TODO: Check for all associated fields, but for now just check one as a marker water = associated(fluxes%evap) heat = associated(fluxes%seaice_melt_heat) @@ -3170,14 +3746,16 @@ subroutine get_forcing_groups(fluxes, water, heat, ustar, press, shelf, & iceberg = associated(fluxes%ustar_berg) heat_added = associated(fluxes%heat_added) buoy = associated(fluxes%buoy) + if (present(carbon)) carbon = associated(fluxes%carbon_content_lrunoff) end subroutine get_forcing_groups !> Return flags indicating which groups of mechanical forcings are allocated -subroutine get_mech_forcing_groups(forces, stress, ustar, shelf, press, iceberg) +subroutine get_mech_forcing_groups(forces, stress, ustar, tau_mag, shelf, press, iceberg) type(mech_forcing), intent(in) :: forces !< Reference forcing fields logical, intent(out) :: stress !< True if forces contains wind stress fields logical, intent(out) :: ustar !< True if forces contains ustar field + logical, intent(out) :: tau_mag !< True if forces contains tau_mag field logical, intent(out) :: shelf !< True if forces contains ice shelf fields logical, intent(out) :: press !< True if forces contains pressure fields logical, intent(out) :: iceberg !< True if forces contains iceberg fields @@ -3185,6 +3763,7 @@ subroutine get_mech_forcing_groups(forces, stress, ustar, shelf, press, iceberg) stress = associated(forces%taux) & .and. associated(forces%tauy) ustar = associated(forces%ustar) + tau_mag = associated(forces%tau_mag) shelf = associated(forces%rigidity_ice_u) & .and. associated(forces%rigidity_ice_v) & .and. associated(forces%frac_shelf_u) & @@ -3198,7 +3777,7 @@ end subroutine get_mech_forcing_groups !> Allocates and zeroes-out array. -subroutine myAlloc(array, is, ie, js, je, flag) +subroutine myAlloc_2d(array, is, ie, js, je, flag) real, dimension(:,:), pointer :: array !< Array to be allocated integer, intent(in) :: is !< Start i-index integer, intent(in) :: ie !< End i-index @@ -3207,16 +3786,33 @@ subroutine myAlloc(array, is, ie, js, je, flag) logical, optional, intent(in) :: flag !< Flag to indicate to allocate if (present(flag)) then ; if (flag) then ; if (.not.associated(array)) then - allocate(array(is:ie,js:je)) ; array(is:ie,js:je) = 0.0 + allocate(array(is:ie,js:je), source=0.0) endif ; endif ; endif -end subroutine myAlloc +end subroutine myAlloc_2d + +subroutine myAlloc_3d(array, is, ie, js, je, ks, ke, flag) + real, dimension(:,:,:), pointer :: array !< Array to be allocated + integer, intent(in) :: is !< Start i-index + integer, intent(in) :: ie !< End i-index + integer, intent(in) :: js !< Start j-index + integer, intent(in) :: je !< End j-index + integer, intent(in) :: ks !< Start k-index + integer, intent(in) :: ke !< End k-index + logical, optional, intent(in) :: flag !< Flag to indicate to allocate + + if (present(flag)) then ; if (flag) then ; if (.not.associated(array)) then + allocate(array(is:ie,js:je,ks:ke), source=0.0) + endif ; endif ; endif +end subroutine myAlloc_3d !> Deallocate the forcing type subroutine deallocate_forcing_type(fluxes) type(forcing), intent(inout) :: fluxes !< Forcing fields structure + if (associated(fluxes%omega_w2x)) deallocate(fluxes%omega_w2x) if (associated(fluxes%ustar)) deallocate(fluxes%ustar) if (associated(fluxes%ustar_gustless)) deallocate(fluxes%ustar_gustless) + if (associated(fluxes%tau_mag)) deallocate(fluxes%tau_mag) if (associated(fluxes%buoy)) deallocate(fluxes%buoy) if (associated(fluxes%sw)) deallocate(fluxes%sw) if (associated(fluxes%seaice_melt_heat)) deallocate(fluxes%seaice_melt_heat) @@ -3229,14 +3825,18 @@ subroutine deallocate_forcing_type(fluxes) if (associated(fluxes%latent_evap_diag)) deallocate(fluxes%latent_evap_diag) if (associated(fluxes%latent_fprec_diag)) deallocate(fluxes%latent_fprec_diag) if (associated(fluxes%latent_frunoff_diag)) deallocate(fluxes%latent_frunoff_diag) + if (associated(fluxes%latent_frunoff_glc_diag)) deallocate(fluxes%latent_frunoff_glc_diag) if (associated(fluxes%sens)) deallocate(fluxes%sens) + if (associated(fluxes%carbon_content_lrunoff)) deallocate(fluxes%carbon_content_lrunoff) if (associated(fluxes%heat_added)) deallocate(fluxes%heat_added) if (associated(fluxes%heat_content_lrunoff)) deallocate(fluxes%heat_content_lrunoff) if (associated(fluxes%heat_content_frunoff)) deallocate(fluxes%heat_content_frunoff) - if (associated(fluxes%heat_content_icemelt)) deallocate(fluxes%heat_content_icemelt) + if (associated(fluxes%heat_content_lrunoff_glc)) deallocate(fluxes%heat_content_lrunoff_glc) + if (associated(fluxes%heat_content_frunoff_glc)) deallocate(fluxes%heat_content_frunoff_glc) if (associated(fluxes%heat_content_lprec)) deallocate(fluxes%heat_content_lprec) if (associated(fluxes%heat_content_fprec)) deallocate(fluxes%heat_content_fprec) if (associated(fluxes%heat_content_cond)) deallocate(fluxes%heat_content_cond) + if (associated(fluxes%heat_content_evap)) deallocate(fluxes%heat_content_evap) if (associated(fluxes%heat_content_massout)) deallocate(fluxes%heat_content_massout) if (associated(fluxes%heat_content_massin)) deallocate(fluxes%heat_content_massin) if (associated(fluxes%evap)) deallocate(fluxes%evap) @@ -3245,24 +3845,34 @@ subroutine deallocate_forcing_type(fluxes) if (associated(fluxes%vprec)) deallocate(fluxes%vprec) if (associated(fluxes%lrunoff)) deallocate(fluxes%lrunoff) if (associated(fluxes%frunoff)) deallocate(fluxes%frunoff) + if (associated(fluxes%lrunoff_glc)) deallocate(fluxes%lrunoff_glc) + if (associated(fluxes%frunoff_glc)) deallocate(fluxes%frunoff_glc) if (associated(fluxes%seaice_melt)) deallocate(fluxes%seaice_melt) if (associated(fluxes%netMassOut)) deallocate(fluxes%netMassOut) if (associated(fluxes%netMassIn)) deallocate(fluxes%netMassIn) if (associated(fluxes%salt_flux)) deallocate(fluxes%salt_flux) if (associated(fluxes%p_surf_full)) deallocate(fluxes%p_surf_full) if (associated(fluxes%p_surf)) deallocate(fluxes%p_surf) - if (associated(fluxes%TKE_tidal)) deallocate(fluxes%TKE_tidal) + if (associated(fluxes%BBL_tidal_dis)) deallocate(fluxes%BBL_tidal_dis) if (associated(fluxes%ustar_tidal)) deallocate(fluxes%ustar_tidal) if (associated(fluxes%ustar_shelf)) deallocate(fluxes%ustar_shelf) if (associated(fluxes%iceshelf_melt)) deallocate(fluxes%iceshelf_melt) + if (associated(fluxes%shelf_sfc_mass_flux)) & + deallocate(fluxes%shelf_sfc_mass_flux) if (associated(fluxes%frac_shelf_h)) deallocate(fluxes%frac_shelf_h) if (associated(fluxes%ustar_berg)) deallocate(fluxes%ustar_berg) if (associated(fluxes%area_berg)) deallocate(fluxes%area_berg) if (associated(fluxes%mass_berg)) deallocate(fluxes%mass_berg) if (associated(fluxes%ice_fraction)) deallocate(fluxes%ice_fraction) if (associated(fluxes%u10_sqr)) deallocate(fluxes%u10_sqr) - if (associated(fluxes%cfc11_flux)) deallocate(fluxes%cfc11_flux) - if (associated(fluxes%cfc12_flux)) deallocate(fluxes%cfc12_flux) + if (associated(fluxes%noy_dep)) deallocate(fluxes%noy_dep) + if (associated(fluxes%nhx_dep)) deallocate(fluxes%nhx_dep) + if (associated(fluxes%atm_co2)) deallocate(fluxes%atm_co2) + if (associated(fluxes%atm_alt_co2)) deallocate(fluxes%atm_alt_co2) + if (associated(fluxes%dust_flux)) deallocate(fluxes%dust_flux) + if (associated(fluxes%iron_flux)) deallocate(fluxes%iron_flux) + if (associated(fluxes%fracr_cat)) deallocate(fluxes%fracr_cat) + if (associated(fluxes%qsw_cat)) deallocate(fluxes%qsw_cat) call coupler_type_destructor(fluxes%tr_fluxes) @@ -3273,9 +3883,11 @@ end subroutine deallocate_forcing_type subroutine deallocate_mech_forcing(forces) type(mech_forcing), intent(inout) :: forces !< Forcing fields structure - if (associated(forces%taux)) deallocate(forces%taux) - if (associated(forces%tauy)) deallocate(forces%tauy) - if (associated(forces%ustar)) deallocate(forces%ustar) + if (associated(forces%omega_w2x)) deallocate(forces%omega_w2x) + if (associated(forces%taux)) deallocate(forces%taux) + if (associated(forces%tauy)) deallocate(forces%tauy) + if (associated(forces%ustar)) deallocate(forces%ustar) + if (associated(forces%tau_mag)) deallocate(forces%tau_mag) if (associated(forces%p_surf)) deallocate(forces%p_surf) if (associated(forces%p_surf_full)) deallocate(forces%p_surf_full) if (associated(forces%net_mass_src)) deallocate(forces%net_mass_src) @@ -3295,16 +3907,21 @@ subroutine rotate_forcing(fluxes_in, fluxes, turns) type(forcing), intent(inout) :: fluxes !< Rotated forcing structure integer, intent(in) :: turns !< Number of quarter turns - logical :: do_ustar, do_water, do_heat, do_salt, do_press, do_shelf, & + logical :: do_ustar, do_taumag, do_water, do_heat, do_salt, do_press, do_shelf, & do_iceberg, do_heat_added, do_buoy - call get_forcing_groups(fluxes_in, do_water, do_heat, do_ustar, do_press, & + call get_forcing_groups(fluxes_in, do_water, do_heat, do_ustar, do_taumag, do_press, & do_shelf, do_iceberg, do_salt, do_heat_added, do_buoy) - if (do_ustar) then + if (associated(fluxes_in%ustar)) & call rotate_array(fluxes_in%ustar, turns, fluxes%ustar) + if (associated(fluxes_in%ustar_gustless)) & call rotate_array(fluxes_in%ustar_gustless, turns, fluxes%ustar_gustless) - endif + + if (associated(fluxes_in%tau_mag)) & + call rotate_array(fluxes_in%tau_mag, turns, fluxes%tau_mag) + if (associated(fluxes_in%tau_mag_gustless)) & + call rotate_array(fluxes_in%tau_mag_gustless, turns, fluxes%tau_mag_gustless) if (do_water) then call rotate_array(fluxes_in%evap, turns, fluxes%evap) @@ -3313,6 +3930,8 @@ subroutine rotate_forcing(fluxes_in, fluxes, turns) call rotate_array(fluxes_in%vprec, turns, fluxes%vprec) call rotate_array(fluxes_in%lrunoff, turns, fluxes%lrunoff) call rotate_array(fluxes_in%frunoff, turns, fluxes%frunoff) + call rotate_array(fluxes_in%lrunoff_glc, turns, fluxes%lrunoff_glc) + call rotate_array(fluxes_in%frunoff_glc, turns, fluxes%frunoff_glc) call rotate_array(fluxes_in%seaice_melt, turns, fluxes%seaice_melt) call rotate_array(fluxes_in%netMassOut, turns, fluxes%netMassOut) call rotate_array(fluxes_in%netMassIn, turns, fluxes%netMassIn) @@ -3327,6 +3946,7 @@ subroutine rotate_forcing(fluxes_in, fluxes, turns) call rotate_array(fluxes_in%latent_evap_diag, turns, fluxes%latent_evap_diag) call rotate_array(fluxes_in%latent_fprec_diag, turns, fluxes%latent_fprec_diag) call rotate_array(fluxes_in%latent_frunoff_diag, turns, fluxes%latent_frunoff_diag) + call rotate_array(fluxes_in%latent_frunoff_glc_diag, turns, fluxes%latent_frunoff_glc_diag) endif if (do_salt) then @@ -3335,14 +3955,19 @@ subroutine rotate_forcing(fluxes_in, fluxes, turns) if (do_heat .and. do_water) then call rotate_array(fluxes_in%heat_content_cond, turns, fluxes%heat_content_cond) - call rotate_array(fluxes_in%heat_content_icemelt, turns, fluxes%heat_content_icemelt) call rotate_array(fluxes_in%heat_content_lprec, turns, fluxes%heat_content_lprec) call rotate_array(fluxes_in%heat_content_fprec, turns, fluxes%heat_content_fprec) call rotate_array(fluxes_in%heat_content_vprec, turns, fluxes%heat_content_vprec) call rotate_array(fluxes_in%heat_content_lrunoff, turns, fluxes%heat_content_lrunoff) + call rotate_array(fluxes_in%heat_content_lrunoff_glc, turns, fluxes%heat_content_lrunoff_glc) call rotate_array(fluxes_in%heat_content_frunoff, turns, fluxes%heat_content_frunoff) - call rotate_array(fluxes_in%heat_content_massout, turns, fluxes%heat_content_massout) - call rotate_array(fluxes_in%heat_content_massin, turns, fluxes%heat_content_massin) + call rotate_array(fluxes_in%heat_content_frunoff_glc, turns, fluxes%heat_content_frunoff_glc) + if (associated (fluxes_in%heat_content_evap)) then + call rotate_array(fluxes_in%heat_content_evap, turns, fluxes%heat_content_evap) + else + call rotate_array(fluxes_in%heat_content_massout, turns, fluxes%heat_content_massout) + call rotate_array(fluxes_in%heat_content_massin, turns, fluxes%heat_content_massin) + endif endif if (do_press) then @@ -3353,11 +3978,13 @@ subroutine rotate_forcing(fluxes_in, fluxes, turns) call rotate_array(fluxes_in%frac_shelf_h, turns, fluxes%frac_shelf_h) call rotate_array(fluxes_in%ustar_shelf, turns, fluxes%ustar_shelf) call rotate_array(fluxes_in%iceshelf_melt, turns, fluxes%iceshelf_melt) + call rotate_array(fluxes_in%shelf_sfc_mass_flux, turns, fluxes%shelf_sfc_mass_flux) endif if (do_iceberg) then call rotate_array(fluxes_in%ustar_berg, turns, fluxes%ustar_berg) call rotate_array(fluxes_in%area_berg, turns, fluxes%area_berg) + !BGR: pretty sure the following line isn't supposed to be here. call rotate_array(fluxes_in%iceshelf_melt, turns, fluxes%iceshelf_melt) endif @@ -3386,14 +4013,16 @@ subroutine rotate_forcing(fluxes_in, fluxes, turns) if (associated(fluxes_in%buoy)) & call rotate_array(fluxes_in%buoy, turns, fluxes%buoy) - if (associated(fluxes_in%TKE_tidal)) & - call rotate_array(fluxes_in%TKE_tidal, turns, fluxes%TKE_tidal) + if (associated(fluxes_in%BBL_tidal_dis)) & + call rotate_array(fluxes_in%BBL_tidal_dis, turns, fluxes%BBL_tidal_dis) if (associated(fluxes_in%ustar_tidal)) & call rotate_array(fluxes_in%ustar_tidal, turns, fluxes%ustar_tidal) - ! TODO: tracer flux rotation - if (coupler_type_initialized(fluxes%tr_fluxes)) & - call MOM_error(FATAL, "Rotation of tracer BC fluxes not yet implemented.") + ! NOTE: Tracer fields are handled by FMS, so are left unrotated. Any + ! reads/writes to tr_fields must be appropriately rotated. + if (coupler_type_initialized(fluxes%tr_fluxes)) then + call coupler_type_copy_data(fluxes_in%tr_fluxes, fluxes%tr_fluxes) + endif ! Scalars and flags fluxes%accumulate_p_surf = fluxes_in%accumulate_p_surf @@ -3420,17 +4049,19 @@ subroutine rotate_mech_forcing(forces_in, turns, forces) integer, intent(in) :: turns !< Number of quarter-turns type(mech_forcing), intent(inout) :: forces !< Forcing on the rotated domain - logical :: do_stress, do_ustar, do_shelf, do_press, do_iceberg + logical :: do_stress, do_ustar, do_tau_mag, do_shelf, do_press, do_iceberg - call get_mech_forcing_groups(forces_in, do_stress, do_ustar, do_shelf, & + call get_mech_forcing_groups(forces_in, do_stress, do_ustar, do_tau_mag, do_shelf, & do_press, do_iceberg) if (do_stress) & call rotate_vector(forces_in%taux, forces_in%tauy, turns, & forces%taux, forces%tauy) - if (do_ustar) & + if (associated(forces_in%ustar)) & call rotate_array(forces_in%ustar, turns, forces%ustar) + if (associated(forces_in%tau_mag)) & + call rotate_array(forces_in%tau_mag, turns, forces%tau_mag) if (do_shelf) then call rotate_array_pair( & @@ -3444,10 +4075,18 @@ subroutine rotate_mech_forcing(forces_in, turns, forces) endif if (do_press) then - ! NOTE: p_surf_SSH either points to p_surf or p_surf_full call rotate_array(forces_in%p_surf, turns, forces%p_surf) call rotate_array(forces_in%p_surf_full, turns, forces%p_surf_full) call rotate_array(forces_in%net_mass_src, turns, forces%net_mass_src) + + ! p_surf_SSH points to either p_surf or p_surf_full + if (associated(forces_in%p_surf_SSH, forces_in%p_surf)) then + forces%p_surf_SSH => forces%p_surf + else if (associated(forces_in%p_surf_SSH, forces_in%p_surf_full)) then + forces%p_surf_SSH => forces%p_surf_full + else + forces%p_surf_SSH => null() + endif endif if (do_iceberg) then @@ -3463,6 +4102,261 @@ subroutine rotate_mech_forcing(forces_in, turns, forces) forces%initialized = forces_in%initialized end subroutine rotate_mech_forcing +!< Homogenize the forcing fields from the input domain +subroutine homogenize_mech_forcing(forces, G, US, Rho0, UpdateUstar) + type(mech_forcing), intent(inout) :: forces !< Forcing on the input domain + type(ocean_grid_type), intent(in) :: G !< Grid metric of target forcing + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: Rho0 !< A reference density of seawater [R ~> kg m-3], + !! as used to calculate ustar. + logical, optional, intent(in) :: UpdateUstar !< A logical to determine if Ustar should be directly averaged + !! or updated from mean tau. + + real :: tx_mean, ty_mean ! Mean wind stresses [R L Z T-2 ~> Pa] + real :: tau_mag ! The magnitude of the wind stresses [R Z2 T-2 ~> Pa] + real :: Irho0 ! Inverse of the mean density [R-1 ~> m3 kg-1] + logical :: do_stress, do_ustar, do_taumag, do_shelf, do_press, do_iceberg, tau2ustar + integer :: i, j, is, ie, js, je, isB, ieB, jsB, jeB + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isB = G%iscB ; ieB = G%iecB ; jsB = G%jscB ; jeB = G%jecB + + Irho0 = 1.0 / Rho0 + + tau2ustar = .false. + if (present(UpdateUstar)) tau2ustar = UpdateUstar + + call get_mech_forcing_groups(forces, do_stress, do_ustar, do_taumag, do_shelf, & + do_press, do_iceberg) + + if (do_stress) then + tx_mean = global_area_mean_u(forces%taux, G, tmp_scale=US%RLZ_T2_to_Pa) + do j=js,je ; do i=isB,ieB + if (G%mask2dCu(I,j) > 0.0) forces%taux(I,j) = tx_mean + enddo ; enddo + ty_mean = global_area_mean_v(forces%tauy, G, tmp_scale=US%RLZ_T2_to_Pa) + do j=jsB,jeB ; do i=is,ie + if (G%mask2dCv(i,J) > 0.0) forces%tauy(i,J) = ty_mean + enddo ; enddo + if (tau2ustar) then + tau_mag = US%L_to_Z*sqrt((tx_mean**2) + (ty_mean**2)) + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + forces%tau_mag(i,j) = tau_mag + endif ; enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + forces%ustar(i,j) = sqrt(tau_mag * Irho0) + endif ; enddo ; enddo ; endif + else + if (associated(forces%ustar)) & + call homogenize_field_t(forces%ustar, G, tmp_scale=US%Z_to_m*US%s_to_T) + if (associated(forces%tau_mag)) & + call homogenize_field_t(forces%tau_mag, G, tmp_scale=US%RLZ_T2_to_Pa*US%Z_to_L) + endif + else + if (associated(forces%ustar)) & + call homogenize_field_t(forces%ustar, G, tmp_scale=US%Z_to_m*US%s_to_T) + if (associated(forces%tau_mag)) & + call homogenize_field_t(forces%tau_mag, G, tmp_scale=US%RLZ_T2_to_Pa*US%Z_to_L) + endif + + if (do_shelf) then + call homogenize_field_u(forces%rigidity_ice_u, G, tmp_scale=US%L_T_to_m_s*US%L_to_m**2*US%L_to_Z) + call homogenize_field_v(forces%rigidity_ice_v, G, tmp_scale=US%L_T_to_m_s*US%L_to_m**2*US%L_to_Z) + call homogenize_field_u(forces%frac_shelf_u, G) + call homogenize_field_v(forces%frac_shelf_v, G) + endif + + if (do_press) then + ! NOTE: p_surf_SSH either points to p_surf or p_surf_full + call homogenize_field_t(forces%p_surf, G, tmp_scale=US%RL2_T2_to_Pa) + call homogenize_field_t(forces%p_surf_full, G, tmp_scale=US%RL2_T2_to_Pa) + call homogenize_field_t(forces%net_mass_src, G, tmp_scale=US%RZ_T_to_kg_m2s) + endif + + if (do_iceberg) then + call homogenize_field_t(forces%area_berg, G) + call homogenize_field_t(forces%mass_berg, G, tmp_scale=US%RZ_to_kg_m2) + endif + +end subroutine homogenize_mech_forcing + +!< Homogenize the fluxes +subroutine homogenize_forcing(fluxes, G, GV, US) + type(forcing), intent(inout) :: fluxes !< Input forcing struct + type(ocean_grid_type), intent(in) :: G !< Grid metric of target forcing + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + logical :: do_ustar, do_taumag, do_water, do_heat, do_salt, do_press, do_shelf + logical :: do_iceberg, do_heat_added, do_buoy + + call get_forcing_groups(fluxes, do_water, do_heat, do_ustar, do_taumag, do_press, & + do_shelf, do_iceberg, do_salt, do_heat_added, do_buoy) + + if (associated(fluxes%ustar)) & + call homogenize_field_t(fluxes%ustar, G, tmp_scale=US%Z_to_m*US%s_to_T) + if (associated(fluxes%ustar_gustless)) & + call homogenize_field_t(fluxes%ustar_gustless, G, tmp_scale=US%Z_to_m*US%s_to_T) + + if (associated(fluxes%tau_mag)) & + call homogenize_field_t(fluxes%tau_mag, G, tmp_scale=US%RLZ_T2_to_Pa*US%Z_to_L) + if (associated(fluxes%tau_mag_gustless)) & + call homogenize_field_t(fluxes%tau_mag_gustless, G, tmp_scale=US%RLZ_T2_to_Pa*US%Z_to_L) + + if (do_water) then + call homogenize_field_t(fluxes%evap, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%lprec, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%fprec, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%vprec, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%lrunoff, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%frunoff, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%lrunoff_glc, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%frunoff_glc, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%seaice_melt, G, tmp_scale=US%RZ_T_to_kg_m2s) + ! These two calls might not be needed. + call homogenize_field_t(fluxes%netMassOut, G, tmp_scale=GV%H_to_mks) + call homogenize_field_t(fluxes%netMassIn, G, tmp_scale=GV%H_to_mks) + !This was removed and I don't think replaced. Not needed? + !call homogenize_field_t(fluxes%netSalt, G) + endif + + if (do_heat) then + call homogenize_field_t(fluxes%seaice_melt_heat, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%sw, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%lw, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%latent, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%sens, G, tmp_scale=US%QRZ_T_to_W_m2) + !### These are for diagnostics only and may not be needed. + call homogenize_field_t(fluxes%latent_evap_diag, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%latent_fprec_diag, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%latent_frunoff_diag, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%latent_frunoff_glc_diag, G, tmp_scale=US%QRZ_T_to_W_m2) + endif + + if (do_salt) call homogenize_field_t(fluxes%salt_flux, G, tmp_scale=US%RZ_T_to_kg_m2s) + + if (do_heat .and. do_water) then + call homogenize_field_t(fluxes%heat_content_cond, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_lprec, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_fprec, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_vprec, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_lrunoff, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_frunoff, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_lrunoff_glc, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_frunoff_glc, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_massout, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_massin, G, tmp_scale=US%QRZ_T_to_W_m2) + endif + + if (do_press) call homogenize_field_t(fluxes%p_surf, G, tmp_scale=US%RL2_T2_to_Pa) + + if (do_shelf) then + call homogenize_field_t(fluxes%frac_shelf_h, G) + call homogenize_field_t(fluxes%ustar_shelf, G, tmp_scale=US%Z_to_m*US%s_to_T) + call homogenize_field_t(fluxes%iceshelf_melt, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%shelf_sfc_mass_flux, G, tmp_scale=US%RZ_T_to_kg_m2s) + endif + + if (do_iceberg) then + call homogenize_field_t(fluxes%ustar_berg, G, tmp_scale=US%Z_to_m*US%s_to_T) + call homogenize_field_t(fluxes%area_berg, G) + endif + + if (do_heat_added) then + call homogenize_field_t(fluxes%heat_added, G, tmp_scale=US%QRZ_T_to_W_m2) + endif + + ! The following fields are handled by drivers rather than control flags. + if (associated(fluxes%sw_vis_dir)) & + call homogenize_field_t(fluxes%sw_vis_dir, G, tmp_scale=US%QRZ_T_to_W_m2) + + if (associated(fluxes%sw_vis_dif)) & + call homogenize_field_t(fluxes%sw_vis_dif, G, tmp_scale=US%QRZ_T_to_W_m2) + + if (associated(fluxes%sw_nir_dir)) & + call homogenize_field_t(fluxes%sw_nir_dir, G, tmp_scale=US%QRZ_T_to_W_m2) + + if (associated(fluxes%sw_nir_dif)) & + call homogenize_field_t(fluxes%sw_nir_dif, G, tmp_scale=US%QRZ_T_to_W_m2) + + if (associated(fluxes%salt_flux_in)) & + call homogenize_field_t(fluxes%salt_flux_in, G, tmp_scale=US%RZ_T_to_kg_m2s) + + if (associated(fluxes%salt_flux_added)) & + call homogenize_field_t(fluxes%salt_flux_added, G, tmp_scale=US%RZ_T_to_kg_m2s) + + if (associated(fluxes%p_surf_full)) & + call homogenize_field_t(fluxes%p_surf_full, G, tmp_scale=US%RL2_T2_to_Pa) + + if (associated(fluxes%buoy)) & + call homogenize_field_t(fluxes%buoy, G, tmp_scale=US%L_to_m**2*US%s_to_T**3) + + if (associated(fluxes%BBL_tidal_dis)) & + call homogenize_field_t(fluxes%BBL_tidal_dis, G, tmp_scale=US%L_to_Z**2*US%RZ3_T3_to_W_m2) + + if (associated(fluxes%ustar_tidal)) & + call homogenize_field_t(fluxes%ustar_tidal, G, tmp_scale=US%Z_to_m*US%s_to_T) + + ! TODO: tracer flux homogenization + ! Having a warning causes a lot of errors (each time step). + !if (coupler_type_initialized(fluxes%tr_fluxes)) & + ! call MOM_error(WARNING, "Homogenization of tracer BC fluxes not yet implemented.") + +end subroutine homogenize_forcing + +subroutine homogenize_field_t(var, G, tmp_scale) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: var !< The variable to homogenize [A ~> a] + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the + !! return value [a A-1 ~> 1] + + real :: avg ! Global average of var, in the same units as var [A ~> a] + integer :: i, j, is, ie, js, je + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + avg = global_area_mean(var, G, tmp_scale=tmp_scale) + do j=js,je ; do i=is,ie + if (G%mask2dT(i,j) > 0.0) var(i,j) = avg + enddo ; enddo + +end subroutine homogenize_field_t + +subroutine homogenize_field_v(var, G, tmp_scale) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: var !< The variable to homogenize [A ~> a] + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the + !! return value [a A-1 ~> 1] + + real :: avg ! Global average of var, in the same units as var [A ~> a] + integer :: i, j, is, ie, jsB, jeB + is = G%isc ; ie = G%iec ; jsB = G%jscB ; jeB = G%jecB + + avg = global_area_mean_v(var, G, tmp_scale=tmp_scale) + do J=jsB,jeB ; do i=is,ie + if (G%mask2dCv(i,J) > 0.0) var(i,J) = avg + enddo ; enddo + +end subroutine homogenize_field_v + +subroutine homogenize_field_u(var, G, tmp_scale) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: var !< The variable to homogenize [A ~> a] + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the + !! return value [a A-1 ~> 1] + + real :: avg ! Global average of var, in the same units as var [A ~> a] + integer :: i, j, isB, ieB, js, je + isB = G%iscB ; ieB = G%iecB ; js = G%jsc ; je = G%jec + + avg = global_area_mean_u(var, G, tmp_scale=tmp_scale) + do j=js,je ; do I=isB,ieB + if (G%mask2dCu(I,j) > 0.0) var(I,j) = avg + enddo ; enddo + +end subroutine homogenize_field_u + !> \namespace mom_forcing_type !! !! \section section_fluxes Boundary fluxes diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index d9ed8ffee4..9df574f6be 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Provides the ocean grid type module MOM_grid -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_hor_index, only : hor_index_type, hor_index_init use MOM_domains, only : MOM_domain_type, get_domain_extent, compute_block_extent use MOM_domains, only : get_global_shape, deallocate_MOM_domain @@ -15,7 +17,7 @@ module MOM_grid #include public MOM_grid_init, MOM_grid_end, set_derived_metrics, set_first_direction -public isPointInCell, hor_index_type, get_global_grid_size, rescale_grid_bathymetry +public isPointInCell, hor_index_type, get_global_grid_size ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -75,8 +77,8 @@ module MOM_grid real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & mask2dT, & !< 0 for land points and 1 for ocean points on the h-grid [nondim]. - geoLatT, & !< The geographic latitude at q points in degrees of latitude or m. - geoLonT, & !< The geographic longitude at q points in degrees of longitude or m. + geoLatT, & !< The geographic latitude at tracer (h) points [degrees_N] or [km] or [m] + geoLonT, & !< The geographic longitude at tracer (h) points [degrees_E] or [km] or [m] dxT, & !< dxT is delta x at h points [L ~> m]. IdxT, & !< 1/dxT [L-1 ~> m-1]. dyT, & !< dyT is delta y at h points [L ~> m]. @@ -84,16 +86,18 @@ module MOM_grid areaT, & !< The area of an h-cell [L2 ~> m2]. IareaT, & !< 1/areaT [L-2 ~> m-2]. sin_rot, & !< The sine of the angular rotation between the local model grid's northward - !! and the true northward directions. + !! and the true northward directions [nondim]. cos_rot !< The cosine of the angular rotation between the local model grid's northward - !! and the true northward directions. + !! and the true northward directions [nondim]. real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: & mask2dCu, & !< 0 for boundary points and 1 for ocean points on the u grid [nondim]. - geoLatCu, & !< The geographic latitude at u points in degrees of latitude or m. - geoLonCu, & !< The geographic longitude at u points in degrees of longitude or m. + OBCmaskCu, & !< 0 for boundary or OBC points and 1 for ocean points on the u grid [nondim]. + geoLatCu, & !< The geographic latitude at u points [degrees_N] or [km] or [m] + geoLonCu, & !< The geographic longitude at u points [degrees_E] or [km] or [m]. dxCu, & !< dxCu is delta x at u points [L ~> m]. IdxCu, & !< 1/dxCu [L-1 ~> m-1]. + IdxCu_OBCmask, & !< 1/dxCu or 0 at boundary or OBC points [L-1 ~> m-1]. dyCu, & !< dyCu is delta y at u points [L ~> m]. IdyCu, & !< 1/dyCu [L-1 ~> m-1]. dy_Cu, & !< The unblocked lengths of the u-faces of the h-cell [L ~> m]. @@ -102,30 +106,32 @@ module MOM_grid real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: & mask2dCv, & !< 0 for boundary points and 1 for ocean points on the v grid [nondim]. - geoLatCv, & !< The geographic latitude at v points in degrees of latitude or m. - geoLonCv, & !< The geographic longitude at v points in degrees of longitude or m. + OBCmaskCv, & !< 0 for boundary or OBC points and 1 for ocean points on the v grid [nondim]. + geoLatCv, & !< The geographic latitude at v points [degrees_N] or [km] or [m] + geoLonCv, & !< The geographic longitude at v points [degrees_E] or [km] or [m]. dxCv, & !< dxCv is delta x at v points [L ~> m]. IdxCv, & !< 1/dxCv [L-1 ~> m-1]. dyCv, & !< dyCv is delta y at v points [L ~> m]. IdyCv, & !< 1/dyCv [L-1 ~> m-1]. + IdyCv_OBCmask, & !< 1/dxCv or 0 at boundary or OBC points [L-1 ~> m-1]. dx_Cv, & !< The unblocked lengths of the v-faces of the h-cell [L ~> m]. IareaCv, & !< The masked inverse areas of v-grid cells [L-2 ~> m-2]. areaCv !< The areas of the v-grid cells [L2 ~> m2]. real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: & - porous_DminU, & !< minimum topographic height of U-face [Z ~> m] - porous_DmaxU, & !< maximum topographic height of U-face [Z ~> m] + porous_DminU, & !< minimum topographic height (deepest) of U-face [Z ~> m] + porous_DmaxU, & !< maximum topographic height (shallowest) of U-face [Z ~> m] porous_DavgU !< average topographic height of U-face [Z ~> m] real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: & - porous_DminV, & !< minimum topographic height of V-face [Z ~> m] - porous_DmaxV, & !< maximum topographic height of V-face [Z ~> m] + porous_DminV, & !< minimum topographic height (deepest) of V-face [Z ~> m] + porous_DmaxV, & !< maximum topographic height (shallowest) of V-face [Z ~> m] porous_DavgV !< average topographic height of V-face [Z ~> m] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & mask2dBu, & !< 0 for boundary points and 1 for ocean points on the q grid [nondim]. - geoLatBu, & !< The geographic latitude at q points in degrees of latitude or m. - geoLonBu, & !< The geographic longitude at q points in degrees of longitude or m. + geoLatBu, & !< The geographic latitude at q points [degrees_N] or [km] or [m] + geoLonBu, & !< The geographic longitude at q points [degrees_E] or [km] or [m]. dxBu, & !< dxBu is delta x at q points [L ~> m]. IdxBu, & !< 1/dxBu [L-1 ~> m-1]. dyBu, & !< dyBu is delta y at q points [L ~> m]. @@ -134,21 +140,38 @@ module MOM_grid IareaBu !< IareaBu = 1/areaBu [L-2 ~> m-2]. real, pointer, dimension(:) :: & - gridLatT => NULL(), & !< The latitude of T points for the purpose of labeling the output axes. + gridLatT => NULL(), & !< The latitude of T points for the purpose of labeling the output axes, + !! often in units of [degrees_N] or [km] or [m] or [gridpoints]. !! On many grids this is the same as geoLatT. - gridLatB => NULL() !< The latitude of B points for the purpose of labeling the output axes. + gridLatB => NULL() !< The latitude of B points for the purpose of labeling the output axes, + !! often in units of [degrees_N] or [km] or [m] or [gridpoints]. !! On many grids this is the same as geoLatBu. real, pointer, dimension(:) :: & - gridLonT => NULL(), & !< The longitude of T points for the purpose of labeling the output axes. + gridLonT => NULL(), & !< The longitude of T points for the purpose of labeling the output axes, + !! often in units of [degrees_E] or [km] or [m] or [gridpoints]. !! On many grids this is the same as geoLonT. - gridLonB => NULL() !< The longitude of B points for the purpose of labeling the output axes. + gridLonB => NULL() !< The longitude of B points for the purpose of labeling the output axes, + !! often in units of [degrees_E] or [km] or [m] or [gridpoints]. !! On many grids this is the same as geoLonBu. character(len=40) :: & + ! Except on a Cartesian grid, these are usually some variant of "degrees". x_axis_units, & !< The units that are used in labeling the x coordinate axes. - y_axis_units !< The units that are used in labeling the y coordinate axes. + y_axis_units, & !< The units that are used in labeling the y coordinate axes. + ! These are internally generated names, including "m", "km", "deg_E" and "deg_N". + x_ax_unit_short, & !< A short description of the x-axis units for documenting parameter units + y_ax_unit_short !< A short description of the y-axis units for documenting parameter units real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & - bathyT !< Ocean bottom depth at tracer points, in depth units [Z ~> m]. + bathyT !< Ocean bottom depth, referenced to Z_ref at tracer points. bathyT is in + !! depth units and positive *below* Z_ref [Z ~> m]. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & + meanSL !< Spatially varying time mean sea level, referenced to Z_ref at tracer points. + !! meanSL is in height units and positive *above* Z_ref. It is used + !! a) as the height where p = p_atm or zero; + !! b) to calculate time mean thickness of the water column, where + !! mean thickness = max(meanSL + bathyT, 0.0). + !! meanSL is 2D for the consideration of a domain with spatically varying mean + !! height, e.g. the Great Lakes system [Z ~> m]. real :: Z_ref !< A reference value for all geometric height fields, such as bathyT [Z ~> m]. logical :: bathymetry_at_vel !< If true, there are separate values for the @@ -161,14 +184,15 @@ module MOM_grid Dblock_v, & !< Topographic depths at v-points at which the flow is blocked [Z ~> m]. Dopen_v !< Topographic depths at v-points at which the flow is open at width dx_Cv [Z ~> m]. real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & - CoriolisBu !< The Coriolis parameter at corner points [T-1 ~> s-1]. + CoriolisBu, & !< The Coriolis parameter at corner points [T-1 ~> s-1]. + Coriolis2Bu !< The square of the Coriolis parameter at corner points [T-2 ~> s-2]. real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & df_dx, & !< Derivative d/dx f (Coriolis parameter) at h-points [T-1 L-1 ~> s-1 m-1]. df_dy !< Derivative d/dy f (Coriolis parameter) at h-points [T-1 L-1 ~> s-1 m-1]. - ! These variables are global sums that are useful for 1-d diagnostics and should not be rescaled. - real :: areaT_global !< Global sum of h-cell area [m2] - real :: IareaT_global !< Global sum of inverse h-cell area (1/areaT_global) [m-2]. + ! These variables are global sums that are useful for 1-d diagnostics. + real :: areaT_global !< Global sum of h-cell area [L2 ~> m2] + real :: IareaT_global !< Global sum of inverse h-cell area (1/areaT_global) [L-2 ~> m-2]. type(unit_scale_type), pointer :: US => NULL() !< A dimensional unit scaling type @@ -179,11 +203,14 @@ module MOM_grid ! These parameters are run-time parameters that are used during some ! initialization routines (but not all) - real :: south_lat !< The latitude (or y-coordinate) of the first v-line - real :: west_lon !< The longitude (or x-coordinate) of the first u-line - real :: len_lat !< The latitudinal (or y-coord) extent of physical domain - real :: len_lon !< The longitudinal (or x-coord) extent of physical domain - real :: Rad_Earth !< The radius of the planet [m] + real :: grid_unit_to_L !< A factor that converts a the geoLat and geoLon variables and related + !! variables like len_lat and len_lon into rescaled horizontal distance + !! units on a Cartesian grid, in [L km ~> 1000] or [L m-1 ~> 1] or + !! is 0 for a non-Cartesian grid. + real :: south_lat !< The latitude (or y-coordinate) of the first v-line [degrees_N] or [km] or [m] + real :: west_lon !< The longitude (or x-coordinate) of the first u-line [degrees_E] or [km] or [m] + real :: len_lat !< The latitudinal (or y-coord) extent of physical domain [degrees_N] or [km] or [m] + real :: len_lon !< The longitudinal (or x-coord) extent of physical domain [degrees_E] or [km] or [m] real :: Rad_Earth_L !< The radius of the planet in rescaled units [L ~> m] real :: max_depth !< The maximum depth of the ocean in depth units [Z ~> m] end type ocean_grid_type @@ -207,7 +234,7 @@ subroutine MOM_grid_init(G, param_file, US, HI, global_indexing, bathymetry_at_v ! Local variables real :: mean_SeaLev_scale ! A scaling factor for the reference height variable [1] or [Z m-1 ~> 1] - integer :: isd, ied, jsd, jed, nk + integer :: isd, ied, jsd, jed integer :: IsdB, IedB, JsdB, JedB integer :: ied_max, jed_max integer :: niblock, njblock, nihalo, njhalo, nblocks, n, i, j @@ -219,9 +246,11 @@ subroutine MOM_grid_init(G, param_file, US, HI, global_indexing, bathymetry_at_v integer, allocatable, dimension(:) :: ibegin, iend, jbegin, jend character(len=40) :: mod_nm = "MOM_grid" ! This module's name. + mean_SeaLev_scale = 1.0 ; if (associated(G%US)) mean_SeaLev_scale = G%US%m_to_Z ! Read all relevant parameters and write them to the model log. - call get_param(param_file, mod_nm, "REFERENCE_HEIGHT", G%Z_ref, default=0.0, do_not_log=.true.) + call get_param(param_file, mod_nm, "REFERENCE_HEIGHT", G%Z_ref, & + units="m", default=0.0, scale=mean_SeaLev_scale, do_not_log=.true.) call log_version(param_file, mod_nm, version, & "Parameters providing information about the lateral grid.", & log_to_all=.true., layout=.true., all_default=(G%Z_ref==0.0)) @@ -234,7 +263,6 @@ subroutine MOM_grid_init(G, param_file, US, HI, global_indexing, bathymetry_at_v layoutParam=.true.) if (present(US)) then ; if (associated(US)) G%US => US ; endif - mean_SeaLev_scale = 1.0 ; if (associated(G%US)) mean_SeaLev_scale = G%US%m_to_Z call get_param(param_file, mod_nm, "REFERENCE_HEIGHT", G%Z_ref, & "A reference value for geometric height fields, such as bathyT.", & units="m", default=0.0, scale=mean_SeaLev_scale) @@ -337,16 +365,16 @@ subroutine MOM_grid_init(G, param_file, US, HI, global_indexing, bathymetry_at_v G%Block(n)%jec = G%Block(n)%jsc + jend(j) - jbegin(j) G%Block(n)%ied = G%Block(n)%iec + nihalo G%Block(n)%jed = G%Block(n)%jec + njhalo - G%Block(n)%IscB = G%Block(n)%isc; G%Block(n)%IecB = G%Block(n)%iec - G%Block(n)%JscB = G%Block(n)%jsc; G%Block(n)%JecB = G%Block(n)%jec + G%Block(n)%IscB = G%Block(n)%isc ; G%Block(n)%IecB = G%Block(n)%iec + G%Block(n)%JscB = G%Block(n)%jsc ; G%Block(n)%JecB = G%Block(n)%jec ! For symmetric memory domains, the first block will have the extra point ! at the lower boundary of its computational domain. if (G%symmetric) then if (i==1) G%Block(n)%IscB = G%Block(n)%IscB-1 if (j==1) G%Block(n)%JscB = G%Block(n)%JscB-1 endif - G%Block(n)%IsdB = G%Block(n)%isd; G%Block(n)%IedB = G%Block(n)%ied - G%Block(n)%JsdB = G%Block(n)%jsd; G%Block(n)%JedB = G%Block(n)%jed + G%Block(n)%IsdB = G%Block(n)%isd ; G%Block(n)%IedB = G%Block(n)%ied + G%Block(n)%JsdB = G%Block(n)%jsd ; G%Block(n)%JedB = G%Block(n)%jed !--- For symmetric memory domain, every block will have an extra point !--- at the lower boundary of its data domain. if (G%symmetric) then @@ -393,40 +421,6 @@ subroutine MOM_grid_init(G, param_file, US, HI, global_indexing, bathymetry_at_v end subroutine MOM_grid_init -!> rescale_grid_bathymetry permits a change in the internal units for the bathymetry on the grid, -!! both rescaling the depths and recording the new internal units. -subroutine rescale_grid_bathymetry(G, m_in_new_units) - type(ocean_grid_type), intent(inout) :: G !< The horizontal grid structure - real, intent(in) :: m_in_new_units !< The new internal representation of 1 m depth. - !### It appears that this routine is never called. - - ! Local variables - real :: rescale ! A unit rescaling factor [various combinations of units ~> 1] - integer :: i, j, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - if (m_in_new_units == 1.0) return - if (m_in_new_units < 0.0) & - call MOM_error(FATAL, "rescale_grid_bathymetry: Negative depth units are not permitted.") - if (m_in_new_units == 0.0) & - call MOM_error(FATAL, "rescale_grid_bathymetry: Zero depth units are not permitted.") - - rescale = 1.0 / m_in_new_units - do j=jsd,jed ; do i=isd,ied - G%bathyT(i,j) = rescale*G%bathyT(i,j) - enddo ; enddo - if (G%bathymetry_at_vel) then ; do j=jsd,jed ; do I=IsdB,IedB - G%Dblock_u(I,j) = rescale*G%Dblock_u(I,j) ; G%Dopen_u(I,j) = rescale*G%Dopen_u(I,j) - enddo ; enddo ; endif - if (G%bathymetry_at_vel) then ; do J=JsdB,JedB ; do i=isd,ied - G%Dblock_v(i,J) = rescale*G%Dblock_v(i,J) ; G%Dopen_v(i,J) = rescale*G%Dopen_v(i,J) - enddo ; enddo ; endif - G%max_depth = rescale*G%max_depth - -end subroutine rescale_grid_bathymetry - !> set_derived_metrics calculates metric terms that are derived from other metrics. subroutine set_derived_metrics(G, US) type(ocean_grid_type), intent(inout) :: G !< The horizontal grid structure @@ -452,6 +446,7 @@ subroutine set_derived_metrics(G, US) if (G%dyCu(I,j) < 0.0) G%dyCu(I,j) = 0.0 G%IdxCu(I,j) = Adcroft_reciprocal(G%dxCu(I,j)) G%IdyCu(I,j) = Adcroft_reciprocal(G%dyCu(I,j)) + G%IdxCu_OBCmask(I,j) = G%OBCmaskCu(I,j) * G%IdxCu(I,j) ! This may be reset if masks are reset. enddo ; enddo do J=JsdB,JedB ; do i=isd,ied @@ -459,6 +454,7 @@ subroutine set_derived_metrics(G, US) if (G%dyCv(i,J) < 0.0) G%dyCv(i,J) = 0.0 G%IdxCv(i,J) = Adcroft_reciprocal(G%dxCv(i,J)) G%IdyCv(i,J) = Adcroft_reciprocal(G%dyCv(i,J)) + G%IdyCv_OBCmask(i,J) = G%OBCmaskCv(i,J) * G%IdyCv(i,J) ! This may be reset if masks are reset. enddo ; enddo do J=JsdB,JedB ; do I=IsdB,IedB @@ -475,8 +471,8 @@ end subroutine set_derived_metrics !> Adcroft_reciprocal(x) = 1/x for |x|>0 or 0 for x=0. function Adcroft_reciprocal(val) result(I_val) - real, intent(in) :: val !< The value being inverted. - real :: I_val !< The Adcroft reciprocal of val. + real, intent(in) :: val !< The value being inverted [A]. + real :: I_val !< The Adcroft reciprocal of val [A-1]. I_val = 0.0 ; if (val /= 0.0) I_val = 1.0/val end function Adcroft_reciprocal @@ -486,12 +482,12 @@ logical function isPointInCell(G, i, j, x, y) type(ocean_grid_type), intent(in) :: G !< Grid type integer, intent(in) :: i !< i index of cell to test integer, intent(in) :: j !< j index of cell to test - real, intent(in) :: x !< x coordinate of point - real, intent(in) :: y !< y coordinate of point + real, intent(in) :: x !< x coordinate of point [degrees_E] + real, intent(in) :: y !< y coordinate of point [degrees_N] ! Local variables - real :: xNE, xNW, xSE, xSW ! Longitudes of cell corners [degLon] - real :: yNE, yNW, ySE, ySW ! Latitudes of cell corners [degLat] - real :: l0, l1, l2, l3 ! Crossed products of differences in position [degLon degLat] + real :: xNE, xNW, xSE, xSW ! Longitudes of cell corners [degrees_E] + real :: yNE, yNW, ySE, ySW ! Latitudes of cell corners [degrees_N] + real :: l0, l1, l2, l3 ! Crossed products of differences in position [degrees_E degrees_N] real :: p0, p1, p2, p3 ! Trinary unitary values reflecting the signs of the crossed products [nondim] isPointInCell = .false. xNE = G%geoLonBu(i ,j ) ; yNE = G%geoLatBu(i ,j ) @@ -554,6 +550,7 @@ subroutine allocate_metrics(G) ALLOC_(G%dxBu(IsdB:IedB,JsdB:JedB)) ; G%dxBu(:,:) = 0.0 ALLOC_(G%IdxT(isd:ied,jsd:jed)) ; G%IdxT(:,:) = 0.0 ALLOC_(G%IdxCu(IsdB:IedB,jsd:jed)) ; G%IdxCu(:,:) = 0.0 + ALLOC_(G%IdxCu_OBCmask(IsdB:IedB,jsd:jed)) ; G%IdxCu_OBCmask(:,:) = 0.0 ALLOC_(G%IdxCv(isd:ied,JsdB:JedB)) ; G%IdxCv(:,:) = 0.0 ALLOC_(G%IdxBu(IsdB:IedB,JsdB:JedB)) ; G%IdxBu(:,:) = 0.0 @@ -564,6 +561,7 @@ subroutine allocate_metrics(G) ALLOC_(G%IdyT(isd:ied,jsd:jed)) ; G%IdyT(:,:) = 0.0 ALLOC_(G%IdyCu(IsdB:IedB,jsd:jed)) ; G%IdyCu(:,:) = 0.0 ALLOC_(G%IdyCv(isd:ied,JsdB:JedB)) ; G%IdyCv(:,:) = 0.0 + ALLOC_(G%IdyCv_OBCmask(isd:ied,JsdB:JedB)) ; G%IdyCv_OBCmask(:,:) = 0.0 ALLOC_(G%IdyBu(IsdB:IedB,JsdB:JedB)) ; G%IdyBu(:,:) = 0.0 ALLOC_(G%areaT(isd:ied,jsd:jed)) ; G%areaT(:,:) = 0.0 @@ -573,7 +571,9 @@ subroutine allocate_metrics(G) ALLOC_(G%mask2dT(isd:ied,jsd:jed)) ; G%mask2dT(:,:) = 0.0 ALLOC_(G%mask2dCu(IsdB:IedB,jsd:jed)) ; G%mask2dCu(:,:) = 0.0 + ALLOC_(G%OBCmaskCu(IsdB:IedB,jsd:jed)) ; G%OBCmaskCu(:,:) = 0.0 ALLOC_(G%mask2dCv(isd:ied,JsdB:JedB)) ; G%mask2dCv(:,:) = 0.0 + ALLOC_(G%OBCmaskCv(isd:ied,JsdB:JedB)) ; G%OBCmaskCv(:,:) = 0.0 ALLOC_(G%mask2dBu(IsdB:IedB,JsdB:JedB)) ; G%mask2dBu(:,:) = 0.0 ALLOC_(G%geoLatT(isd:ied,jsd:jed)) ; G%geoLatT(:,:) = 0.0 ALLOC_(G%geoLatCu(IsdB:IedB,jsd:jed)) ; G%geoLatCu(:,:) = 0.0 @@ -587,13 +587,13 @@ subroutine allocate_metrics(G) ALLOC_(G%dx_Cv(isd:ied,JsdB:JedB)) ; G%dx_Cv(:,:) = 0.0 ALLOC_(G%dy_Cu(IsdB:IedB,jsd:jed)) ; G%dy_Cu(:,:) = 0.0 - ALLOC_(G%porous_DminU(IsdB:IedB,jsd:jed)); G%porous_DminU(:,:) = 0.0 - ALLOC_(G%porous_DmaxU(IsdB:IedB,jsd:jed)); G%porous_DmaxU(:,:) = 0.0 - ALLOC_(G%porous_DavgU(IsdB:IedB,jsd:jed)); G%porous_DavgU(:,:) = 0.0 + ALLOC_(G%porous_DminU(IsdB:IedB,jsd:jed)) ; G%porous_DminU(:,:) = 0.0 + ALLOC_(G%porous_DmaxU(IsdB:IedB,jsd:jed)) ; G%porous_DmaxU(:,:) = 0.0 + ALLOC_(G%porous_DavgU(IsdB:IedB,jsd:jed)) ; G%porous_DavgU(:,:) = 0.0 - ALLOC_(G%porous_DminV(isd:ied,JsdB:JedB)); G%porous_DminV(:,:) = 0.0 - ALLOC_(G%porous_DmaxV(isd:ied,JsdB:JedB)); G%porous_DmaxV(:,:) = 0.0 - ALLOC_(G%porous_DavgV(isd:ied,JsdB:JedB)); G%porous_DavgV(:,:) = 0.0 + ALLOC_(G%porous_DminV(isd:ied,JsdB:JedB)) ; G%porous_DminV(:,:) = 0.0 + ALLOC_(G%porous_DmaxV(isd:ied,JsdB:JedB)) ; G%porous_DmaxV(:,:) = 0.0 + ALLOC_(G%porous_DavgV(isd:ied,JsdB:JedB)) ; G%porous_DavgV(:,:) = 0.0 ALLOC_(G%areaCu(IsdB:IedB,jsd:jed)) ; G%areaCu(:,:) = 0.0 ALLOC_(G%areaCv(isd:ied,JsdB:JedB)) ; G%areaCv(:,:) = 0.0 @@ -601,7 +601,9 @@ subroutine allocate_metrics(G) ALLOC_(G%IareaCv(isd:ied,JsdB:JedB)) ; G%IareaCv(:,:) = 0.0 ALLOC_(G%bathyT(isd:ied, jsd:jed)) ; G%bathyT(:,:) = -G%Z_ref + ALLOC_(G%meanSL(isd:ied, jsd:jed)) ; G%meanSL(:,:) = G%Z_ref ALLOC_(G%CoriolisBu(IsdB:IedB, JsdB:JedB)) ; G%CoriolisBu(:,:) = 0.0 + ALLOC_(G%Coriolis2Bu(IsdB:IedB, JsdB:JedB)) ; G%Coriolis2Bu(:,:) = 0.0 ALLOC_(G%dF_dx(isd:ied, jsd:jed)) ; G%dF_dx(:,:) = 0.0 ALLOC_(G%dF_dy(isd:ied, jsd:jed)) ; G%dF_dy(:,:) = 0.0 @@ -632,13 +634,15 @@ subroutine MOM_grid_end(G) DEALLOC_(G%dyT) ; DEALLOC_(G%dyCu) ; DEALLOC_(G%dyCv) ; DEALLOC_(G%dyBu) DEALLOC_(G%IdyT) ; DEALLOC_(G%IdyCu) ; DEALLOC_(G%IdyCv) ; DEALLOC_(G%IdyBu) + DEALLOC_(G%IdxCu_OBCmask) ; DEALLOC_(G%IdyCv_OBCmask) + DEALLOC_(G%areaT) ; DEALLOC_(G%IareaT) DEALLOC_(G%areaBu) ; DEALLOC_(G%IareaBu) DEALLOC_(G%areaCu) ; DEALLOC_(G%IareaCu) DEALLOC_(G%areaCv) ; DEALLOC_(G%IareaCv) - DEALLOC_(G%mask2dT) ; DEALLOC_(G%mask2dCu) - DEALLOC_(G%mask2dCv) ; DEALLOC_(G%mask2dBu) + DEALLOC_(G%mask2dT) ; DEALLOC_(G%mask2dCu) ; DEALLOC_(G%OBCmaskCu) + DEALLOC_(G%mask2dCv) ; DEALLOC_(G%OBCmaskCv) ; DEALLOC_(G%mask2dBu) DEALLOC_(G%geoLatT) ; DEALLOC_(G%geoLatCu) DEALLOC_(G%geoLatCv) ; DEALLOC_(G%geoLatBu) @@ -647,9 +651,10 @@ subroutine MOM_grid_end(G) DEALLOC_(G%dx_Cv) ; DEALLOC_(G%dy_Cu) - DEALLOC_(G%bathyT) ; DEALLOC_(G%CoriolisBu) - DEALLOC_(G%dF_dx) ; DEALLOC_(G%dF_dy) - DEALLOC_(G%sin_rot) ; DEALLOC_(G%cos_rot) + DEALLOC_(G%bathyT) ; DEALLOC_(G%meanSL) + DEALLOC_(G%CoriolisBu) ; DEALLOC_(G%Coriolis2Bu) + DEALLOC_(G%dF_dx) ; DEALLOC_(G%dF_dy) + DEALLOC_(G%sin_rot) ; DEALLOC_(G%cos_rot) DEALLOC_(G%porous_DminU) ; DEALLOC_(G%porous_DmaxU) ; DEALLOC_(G%porous_DavgU) DEALLOC_(G%porous_DminV) ; DEALLOC_(G%porous_DmaxV) ; DEALLOC_(G%porous_DavgV) @@ -686,6 +691,7 @@ end subroutine MOM_grid_end !! !! Each location also has a 2D mask indicating whether the entire column is land or ocean. !! `mask2dT` is 1 if the column is wet or 0 if the T-cell is land. -!! `mask2dCu` is 1 if both neighboring column are ocean, and 0 if either is land. +!! `mask2dCu` is 1 if both neighboring columns are ocean, and 0 if either is land. +!! `OBCmasku` is 1 if both neighboring columns are ocean, and 0 if either is land of if this is OBC point. end module MOM_grid diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index 7047dd6421..8821c0cb16 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -1,42 +1,134 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Functions for calculating interface heights, including free surface height. module MOM_interface_heights -! This file is part of MOM6. See LICENSE.md for the license. - +use MOM_density_integrals, only : int_specific_vol_dp, avg_specific_vol, int_density_dz +use MOM_debugging, only : hchksum use MOM_error_handler, only : MOM_error, FATAL -use MOM_file_parser, only : log_version -use MOM_grid, only : ocean_grid_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type -use MOM_density_integrals, only : int_specific_vol_dp +use MOM_EOS, only : calculate_density, average_specific_vol, EOS_type, EOS_domain +use MOM_file_parser, only : log_version +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private #include -public find_eta +public find_eta, find_dz_for_eta, dz_to_thickness, thickness_to_dz, dz_to_thickness_simple +public calc_derived_thermo +public convert_MLD_to_ML_thickness +public find_rho_bottom, find_col_avg_SpV, find_col_mass !> Calculates the heights of the free surface or all interfaces from layer thicknesses. interface find_eta module procedure find_eta_2d, find_eta_3d end interface find_eta +!> Calculates layer thickness in thickness units from geometric distance between the +!! interfaces around that layer in height units. +interface dz_to_thickness + module procedure dz_to_thickness_tv, dz_to_thickness_EoS +end interface dz_to_thickness + +!> Converts layer thickness in thickness units into the vertical distance between the +!! interfaces around a layer in height units. +interface thickness_to_dz + module procedure thickness_to_dz_3d, thickness_to_dz_jslice +end interface thickness_to_dz + contains +!> Calculates the change in height across layers, using the appropriate form for +!! consistency with the calculation of the pressure gradient forces. +subroutine find_dz_for_eta(h, tv, G, GV, US, dz_lay, halo_size) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: dz_lay !< Height change across layers [Z ~> m] + integer, optional, intent(in) :: halo_size !< width of halo points on + !! which to calculate eta. + + ! Local variables + real :: p(SZI_(G),SZJ_(G),SZK_(GV)+1) ! Hydrostatic pressure at each interface [R L2 T-2 ~> Pa] + real :: dz_geo(SZI_(G),SZJ_(G)) ! The change in geopotential height across a layer [L2 T-2 ~> m2 s-2] + real :: SpV_lay_conv(SZK_(GV)) ! The prescribed layer specific volume times a conversion factor from + ! the units of thickness to layer mass [Z H-1 ~> nondim or m3 kg-1] + real :: I_gEarth ! The inverse of the gravitational acceleration times the + ! rescaling factor derived from eta_to_m [T2 Z L-2 ~> s2 m-1] + integer :: i, j, k, isv, iev, jsv, jev, nz, halo + + halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) + + isv = G%isc-halo ; iev = G%iec+halo ; jsv = G%jsc-halo ; jev = G%jec+halo + nz = GV%ke + + if ((isvG%ied) .or. (jsvG%jed)) & + call MOM_error(FATAL,"find_dz_for_eta called with an overly large halo_size.") + + if (GV%Boussinesq) then + do k=1,nz ; do j=jsv,jev ; do i=isv,iev + dz_lay(i,j,K) = h(i,j,k)*GV%H_to_Z + enddo ; enddo ; enddo + elseif (associated(tv%eqn_of_state)) then + I_gEarth = 1.0 / GV%g_Earth + !$OMP parallel do default(shared) + do j=jsv,jev + if (associated(tv%p_surf)) then + do i=isv,iev ; p(i,j,1) = tv%p_surf(i,j) ; enddo + else + do i=isv,iev ; p(i,j,1) = 0.0 ; enddo + endif + do k=1,nz ; do i=isv,iev + p(i,j,K+1) = p(i,j,K) + GV%g_Earth*GV%H_to_RZ*h(i,j,k) + enddo ; enddo + enddo + !$OMP parallel do default(shared) private(dz_geo) + do k=1,nz + call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,K), p(:,:,K+1), & + 0.0, G%HI, tv%eqn_of_state, US, dz_geo, halo_size=halo) + do j=jsv,jev ; do i=isv,iev + dz_lay(i,j,K) = I_gEarth * dz_geo(i,j) + enddo ; enddo + enddo + else ! non-Boussinesq but with no equation of state + do k=1,nz ; do j=jsv,jev ; do i=isv,iev + dz_lay(i,j,K) = GV%H_to_RZ*h(i,j,k) / GV%Rlay(k) + enddo ; enddo ; enddo + ! This would be faster but could change answers. + ! do k=1,nz ; SpV_lay_conv(k) = GV%H_to_RZ / GV%Rlay(k) ; enddo + ! do k=1,nz ; do j=jsv,jev ; do i=isv,iev + ! dz_lay(i,j,K) = h(i,j,k) * SpV_lay_conv(k) + ! enddo ; enddo ; enddo + endif + + ! To find eta, do the following: + ! do j=jsv,jev ; do i=isv,iev ; eta(i,j,nz+1) = -(G%bathyT(i,j) + dZ_ref) ; enddo ; enddo + ! do k=nz,1,-1 ; do j=jsv,jev ; do i=isv,iev + ! eta(i,j,K) = eta(i,j,K+1) + dz_lay(i,j,K) + ! enddo ; enddo ; enddo + +end subroutine find_dz_for_eta + !> Calculates the heights of all interfaces between layers, using the appropriate !! form for consistency with the calculation of the pressure gradient forces. !! Additionally, these height may be dilated for consistency with the !! corresponding time-average quantity from the barotropic calculation. -subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m, dZref) +subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, dZref) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(out) :: eta !< layer interface heights - !! [Z ~> m] or [1/eta_to_m m]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(out) :: eta !< layer interface heights [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: eta_bt !< optional barotropic variable !! that gives the "correct" free surface height (Boussinesq) or total water !! column mass per unit area (non-Boussinesq). This is used to dilate the layer @@ -44,23 +136,16 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m, dZref !! In Boussinesq mode, eta_bt and G%bathyT use the same reference height. integer, optional, intent(in) :: halo_size !< width of halo points on !! which to calculate eta. - real, optional, intent(in) :: eta_to_m !< The conversion factor from - !! the units of eta to m; by default this is US%Z_to_m. real, optional, intent(in) :: dZref !< The difference in the !! reference height between G%bathyT and eta [Z ~> m]. The default is 0. ! Local variables - real :: p(SZI_(G),SZJ_(G),SZK_(GV)+1) ! Hydrostatic pressure at each interface [R L2 T-2 ~> Pa] - real :: dz_geo(SZI_(G),SZJ_(G),SZK_(GV)) ! The change in geopotential height - ! across a layer [L2 T-2 ~> m2 s-2]. - real :: dilate(SZI_(G)) ! non-dimensional dilation factor + real :: dz_lay(SZI_(G),SZJ_(G),SZK_(GV)) ! The change in height across a layer [Z ~> m] + real :: dilate(SZI_(G)) ! A non-dimensional dilation factor [nondim] real :: htot(SZI_(G)) ! total thickness [H ~> m or kg m-2] - real :: I_gEarth ! The inverse of the gravitational acceleration times the - ! rescaling factor derived from eta_to_m [T2 Z L-2 ~> s2 m-1] - real :: Z_to_eta, H_to_eta, H_to_rho_eta ! Unit conversion factors with obvious names. real :: dZ_ref ! The difference in the reference height between G%bathyT and eta [Z ~> m]. ! dZ_ref is 0 unless the optional argument dZref is present. - integer i, j, k, isv, iev, jsv, jev, nz, halo + integer :: i, j, k, isv, iev, jsv, jev, nz, halo halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) @@ -70,66 +155,44 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m, dZref if ((isvG%ied) .or. (jsvG%jed)) & call MOM_error(FATAL,"find_eta called with an overly large halo_size.") - Z_to_eta = 1.0 ; if (present(eta_to_m)) Z_to_eta = US%Z_to_m / eta_to_m - H_to_eta = GV%H_to_Z * Z_to_eta - H_to_rho_eta = GV%H_to_RZ * Z_to_eta - I_gEarth = Z_to_eta / GV%g_Earth dZ_ref = 0.0 ; if (present(dZref)) dZ_ref = dZref - !$OMP parallel default(shared) private(dilate,htot) - !$OMP do - do j=jsv,jev ; do i=isv,iev ; eta(i,j,nz+1) = -Z_to_eta*(G%bathyT(i,j) + dZ_ref) ; enddo ; enddo - if (GV%Boussinesq) then + !$OMP parallel default(shared) private(dilate,htot) + !$OMP do + do j=jsv,jev ; do i=isv,iev ; eta(i,j,nz+1) = -(G%bathyT(i,j) + dZ_ref) ; enddo ; enddo !$OMP do do j=jsv,jev ; do k=nz,1,-1 ; do i=isv,iev - eta(i,j,K) = eta(i,j,K+1) + h(i,j,k)*H_to_eta + eta(i,j,K) = eta(i,j,K+1) + h(i,j,k)*GV%H_to_Z enddo ; enddo ; enddo if (present(eta_bt)) then ! Dilate the water column to agree with the free surface height ! that is used for the dynamics. !$OMP do - do j=jsv,jev + do j=jsv,jev !$OMP parallel do default(shared) + do i=isv,iev - dilate(i) = (eta_bt(i,j)*H_to_eta + Z_to_eta*G%bathyT(i,j)) / & - (eta(i,j,1) + Z_to_eta*(G%bathyT(i,j) + dZ_ref)) + dilate(i) = (eta_bt(i,j)*GV%H_to_Z + G%bathyT(i,j)) / & + (eta(i,j,1) + (G%bathyT(i,j) + dZ_ref)) enddo do k=1,nz ; do i=isv,iev - eta(i,j,K) = dilate(i) * (eta(i,j,K) + Z_to_eta*(G%bathyT(i,j) + dZ_ref)) - & - Z_to_eta*(G%bathyT(i,j) + dZ_ref) + eta(i,j,K) = dilate(i) * (eta(i,j,K) + (G%bathyT(i,j) + dZ_ref)) - & + (G%bathyT(i,j) + dZ_ref) enddo ; enddo enddo endif + !$OMP end parallel else - if (associated(tv%eqn_of_state)) then - !$OMP do - do j=jsv,jev - if (associated(tv%p_surf)) then - do i=isv,iev ; p(i,j,1) = tv%p_surf(i,j) ; enddo - else - do i=isv,iev ; p(i,j,1) = 0.0 ; enddo - endif - do k=1,nz ; do i=isv,iev - p(i,j,K+1) = p(i,j,K) + GV%g_Earth*GV%H_to_RZ*h(i,j,k) - enddo ; enddo - enddo - !$OMP do - do k=1,nz - call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,K), p(:,:,K+1), & - 0.0, G%HI, tv%eqn_of_state, US, dz_geo(:,:,k), halo_size=halo) - enddo - !$OMP do - do j=jsv,jev - do k=nz,1,-1 ; do i=isv,iev - eta(i,j,K) = eta(i,j,K+1) + I_gEarth * dz_geo(i,j,k) - enddo ; enddo - enddo - else - !$OMP do - do j=jsv,jev ; do k=nz,1,-1 ; do i=isv,iev - eta(i,j,K) = eta(i,j,K+1) + H_to_rho_eta*h(i,j,k) / GV%Rlay(k) - enddo ; enddo ; enddo - endif + call find_dz_for_eta(h, tv, G, GV, US, dz_lay, halo_size) + !$OMP parallel default(shared) private(dilate,htot) + !$OMP do + do j=jsv,jev + do i=isv,iev ; eta(i,j,nz+1) = -(G%bathyT(i,j) + dZ_ref) ; enddo + do k=nz,1,-1 ; do i=isv,iev + eta(i,j,K) = eta(i,j,K+1) + dz_lay(i,j,k) + enddo ; enddo + enddo + if (present(eta_bt)) then ! Dilate the water column to agree with the free surface height ! from the time-averaged barotropic solution. @@ -139,13 +202,13 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m, dZref do k=1,nz ; do i=isv,iev ; htot(i) = htot(i) + h(i,j,k) ; enddo ; enddo do i=isv,iev ; dilate(i) = eta_bt(i,j) / htot(i) ; enddo do k=1,nz ; do i=isv,iev - eta(i,j,K) = dilate(i) * (eta(i,j,K) + Z_to_eta*(G%bathyT(i,j) + dZ_ref)) - & - Z_to_eta*(G%bathyT(i,j) + dZ_ref) + eta(i,j,K) = dilate(i) * (eta(i,j,K) + (G%bathyT(i,j) + dZ_ref)) - & + (G%bathyT(i,j) + dZ_ref) enddo ; enddo enddo endif + !$OMP end parallel endif - !$OMP end parallel end subroutine find_eta_3d @@ -153,7 +216,7 @@ end subroutine find_eta_3d !! with the calculation of the pressure gradient forces. Additionally, the sea !! surface height may be adjusted for consistency with the corresponding !! time-average quantity from the barotropic calculation. -subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m, dZref) +subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, dZref) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -168,79 +231,47 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m, dZref !! In Boussinesq mode, eta_bt and G%bathyT use the same reference height. integer, optional, intent(in) :: halo_size !< width of halo points on !! which to calculate eta. - real, optional, intent(in) :: eta_to_m !< The conversion factor from - !! the units of eta to m; by default this is US%Z_to_m. real, optional, intent(in) :: dZref !< The difference in the !! reference height between G%bathyT and eta [Z ~> m]. The default is 0. ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & - p ! Hydrostatic pressure at each interface [R L2 T-2 ~> Pa] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & - dz_geo ! The change in geopotential height across a layer [L2 T-2 ~> m2 s-2]. + real :: dz_lay(SZI_(G),SZJ_(G),SZK_(GV)) ! The change in height across a layer [Z ~> m] real :: htot(SZI_(G)) ! The sum of all layers' thicknesses [H ~> m or kg m-2]. - real :: I_gEarth ! The inverse of the gravitational acceleration times the - ! rescaling factor derived from eta_to_m [T2 Z L-2 ~> s2 m-1] - real :: Z_to_eta, H_to_eta, H_to_rho_eta ! Unit conversion factors with obvious names. real :: dZ_ref ! The difference in the reference height between G%bathyT and eta [Z ~> m]. ! dZ_ref is 0 unless the optional argument dZref is present. - integer i, j, k, is, ie, js, je, nz, halo + integer :: i, j, k, is, ie, js, je, nz, halo halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo nz = GV%ke - Z_to_eta = 1.0 ; if (present(eta_to_m)) Z_to_eta = US%Z_to_m / eta_to_m - H_to_eta = GV%H_to_Z * Z_to_eta - H_to_rho_eta = GV%H_to_RZ * Z_to_eta - I_gEarth = Z_to_eta / GV%g_Earth dZ_ref = 0.0 ; if (present(dZref)) dZ_ref = dZref - !$OMP parallel default(shared) private(htot) - !$OMP do - do j=js,je ; do i=is,ie ; eta(i,j) = -Z_to_eta*(G%bathyT(i,j) + dZ_ref) ; enddo ; enddo - if (GV%Boussinesq) then if (present(eta_bt)) then - !$OMP do + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - eta(i,j) = H_to_eta*eta_bt(i,j) - Z_to_eta*dZ_ref + eta(i,j) = GV%H_to_Z*eta_bt(i,j) - dZ_ref enddo ; enddo else - !$OMP do - do j=js,je ; do k=1,nz ; do i=is,ie - eta(i,j) = eta(i,j) + h(i,j,k)*H_to_eta - enddo ; enddo ; enddo - endif - else - if (associated(tv%eqn_of_state)) then - !$OMP do + !$OMP parallel do default(shared) do j=js,je - if (associated(tv%p_surf)) then - do i=is,ie ; p(i,j,1) = tv%p_surf(i,j) ; enddo - else - do i=is,ie ; p(i,j,1) = 0.0 ; enddo - endif - + do i=is,ie ; eta(i,j) = -(G%bathyT(i,j) + dZ_ref) ; enddo do k=1,nz ; do i=is,ie - p(i,j,k+1) = p(i,j,k) + GV%g_Earth*GV%H_to_RZ*h(i,j,k) + eta(i,j) = eta(i,j) + h(i,j,k)*GV%H_to_Z enddo ; enddo enddo - !$OMP do - do k = 1, nz - call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p(:,:,k), p(:,:,k+1), 0.0, & - G%HI, tv%eqn_of_state, US, dz_geo(:,:,k), halo_size=halo) - enddo - !$OMP do - do j=js,je ; do k=1,nz ; do i=is,ie - eta(i,j) = eta(i,j) + I_gEarth * dz_geo(i,j,k) - enddo ; enddo ; enddo - else - !$OMP do - do j=js,je ; do k=1,nz ; do i=is,ie - eta(i,j) = eta(i,j) + H_to_rho_eta*h(i,j,k) / GV%Rlay(k) - enddo ; enddo ; enddo endif + else + call find_dz_for_eta(h, tv, G, GV, US, dz_lay, halo_size) + !$OMP parallel default(shared) private(htot) + !$OMP do + do j=js,je + do i=is,ie ; eta(i,j) = -(G%bathyT(i,j) + dZ_ref) ; enddo + do k=1,nz ; do i=is,ie + eta(i,j) = eta(i,j) + dz_lay(i,j,k) + enddo ; enddo + enddo if (present(eta_bt)) then ! Dilate the water column to agree with the time-averaged column ! mass from the barotropic solution. @@ -249,14 +280,758 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m, dZref do i=is,ie ; htot(i) = GV%H_subroundoff ; enddo do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k) ; enddo ; enddo do i=is,ie - eta(i,j) = (eta_bt(i,j) / htot(i)) * (eta(i,j) + Z_to_eta*(G%bathyT(i,j) + dZ_ref)) - & - Z_to_eta*(G%bathyT(i,j) + dZ_ref) + eta(i,j) = (eta_bt(i,j) / htot(i)) * (eta(i,j) + (G%bathyT(i,j) + dZ_ref)) - & + (G%bathyT(i,j) + dZ_ref) enddo enddo endif + !$OMP end parallel endif - !$OMP end parallel end subroutine find_eta_2d + +!> Calculate derived thermodynamic quantities for re-use later. +subroutine calc_derived_thermo(tv, h, G, GV, US, halo, debug) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various + !! thermodynamic variables, some of + !! which will be set here. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + integer, optional, intent(in) :: halo !< Width of halo within which to + !! calculate thicknesses + logical, optional, intent(in) :: debug !< If present and true, write debugging checksums + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: p_t ! Hydrostatic pressure atop a layer [R L2 T-2 ~> Pa] + real, dimension(SZI_(G),SZJ_(G)) :: dp ! Pressure change across a layer [R L2 T-2 ~> Pa] + real, dimension(SZK_(GV)) :: SpV_lay ! The specific volume of each layer when no equation of + ! state is used [R-1 ~> m3 kg-1] + logical :: do_debug ! If true, write checksums for debugging. + integer :: i, j, k, is, ie, js, je, halos, nz + + do_debug = .false. ; if (present(debug)) do_debug = debug + halos = 0 ; if (present(halo)) halos = max(0,halo) + is = G%isc-halos ; ie = G%iec+halos ; js = G%jsc-halos ; je = G%jec+halos ; nz = GV%ke + + if (allocated(tv%Spv_avg) .and. associated(tv%eqn_of_state)) then + if (associated(tv%p_surf)) then + do j=js,je ; do i=is,ie ; p_t(i,j) = tv%p_surf(i,j) ; enddo ; enddo + else + do j=js,je ; do i=is,ie ; p_t(i,j) = 0.0 ; enddo ; enddo + endif + do k=1,nz + do j=js,je ; do i=is,ie + dp(i,j) = GV%g_Earth*GV%H_to_RZ*h(i,j,k) + enddo ; enddo + call avg_specific_vol(tv%T(:,:,k), tv%S(:,:,k), p_t, dp, G%HI, tv%eqn_of_state, tv%SpV_avg(:,:,k), halo) + if (k Determine the column average specific volumes. +subroutine find_col_avg_SpV(h, SpV_avg, tv, G, GV, US, halo_size) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), & + intent(inout) :: SpV_avg !< Column average specific volume [R-1 ~> m3 kg-1] + ! SpV_avg is intent inout to retain excess halo values. + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + !! thermodynamic fields. + integer, optional, intent(in) :: halo_size !< width of halo points on which to work + + ! Local variables + real :: h_tot(SZI_(G)) ! Sum of the layer thicknesses [H ~> m or kg m-2] + real :: SpV_x_h_tot(SZI_(G)) ! Vertical sum of the layer average specific volume times + ! the layer thicknesses [H R-1 ~> m4 kg-1 or m] + real :: I_rho ! The inverse of the Boussiensq reference density [R-1 ~> m3 kg-1] + real :: SpV_lay(SZK_(GV)) ! The inverse of the layer target potential densities [R-1 ~> m3 kg-1] + character(len=128) :: mesg ! A string for error messages + integer :: i, j, k, is, ie, js, je, nz, halo + + halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) + + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo + nz = GV%ke + + if (GV%Boussinesq) then + I_rho = 1.0 / GV%Rho0 + do j=js,je ; do i=is,ie + SpV_avg(i,j) = I_rho + enddo ; enddo + elseif (.not.allocated(tv%SpV_avg)) then + do k=1,nz ; Spv_lay(k) = 1.0 / GV%Rlay(k) ; enddo + do j=js,je + do i=is,ie ; SpV_x_h_tot(i) = 0.0 ; h_tot(i) = 0.0 ; enddo + do k=1,nz ; do i=is,ie + h_tot(i) = h_tot(i) + max(h(i,j,k), GV%H_subroundoff) + SpV_x_h_tot(i) = SpV_x_h_tot(i) + Spv_lay(k)*max(h(i,j,k), GV%H_subroundoff) + enddo ; enddo + do i=is,ie ; SpV_avg(i,j) = SpV_x_h_tot(i) / h_tot(i) ; enddo + enddo + else + ! Check that SpV_avg has been set. + if ((allocated(tv%SpV_avg)) .and. (tv%valid_SpV_halo < halo)) then + if (tv%valid_SpV_halo < 0) then + mesg = "invalid values of SpV_avg." + else + write(mesg, '("insufficiently large SpV_avg halos of width ", i2, " but ", i2," is needed.")') & + tv%valid_SpV_halo, halo + endif + call MOM_error(FATAL, "find_col_avg_SpV called in fully non-Boussinesq mode with "//trim(mesg)) + endif + + do j=js,je + do i=is,ie ; SpV_x_h_tot(i) = 0.0 ; h_tot(i) = 0.0 ; enddo + do k=1,nz ; do i=is,ie + h_tot(i) = h_tot(i) + max(h(i,j,k), GV%H_subroundoff) + SpV_x_h_tot(i) = SpV_x_h_tot(i) + tv%SpV_avg(i,j,k)*max(h(i,j,k), GV%H_subroundoff) + enddo ; enddo + do i=is,ie ; SpV_avg(i,j) = SpV_x_h_tot(i) / h_tot(i) ; enddo + enddo + endif + +end subroutine find_col_avg_SpV + +!> Calculate the integrated mass of the water column. +subroutine find_col_mass(h, tv, G, GV, US, mass, p_bot, p_surf) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: mass !< Integrated mass of the water column + !! [R Z ~> kg m-2] + real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: p_bot !< Bottom pressure = g * mass + psurf + !! [R L2 T-2 ~> Pa] + real, dimension(:,:), optional, pointer :: p_surf !< A pointer to surface pressure + !! [R L2 T-2 ~> Pa] + + ! Local variables + real :: I_gEarth ! The inverse of GV%g_Earth [T2 Z L-2 ~> s2 m-1] + real, dimension(SZI_(G),SZJ_(G)) :: & + z_top, & ! Height of the top of a layer [Z ~> m]. + z_bot, & ! Height of the bottom of a layer [Z ~> m]. + dp ! Change in hydrostatic pressure across a layer [R L2 T-2 ~> Pa]. + integer :: i, j, k, is, ie, js, je, isq, ieq, jsq, jeq, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isq = G%iscB ; ieq = G%iecB ; jsq = G%jscB ; jeq = G%jecB + nz = GV%ke + + do j=js,je ; do i=is,ie ; mass(i,j) = 0.0 ; enddo ; enddo + if (GV%Boussinesq) then + if (associated(tv%eqn_of_state)) then + I_gEarth = 1.0 / GV%g_Earth + do j=jsq,jeq+1 ; do i=isq,ieq+1 ; z_bot(i,j) = 0.0 ; enddo ; enddo + do k=1,nz + ! NOTE: int_density_z expects z_top and z_bot values from [ij]sq to [ij]eq+1 + do j=jsq,jeq+1 ; do i=isq,ieq+1 + z_top(i,j) = z_bot(i,j) + z_bot(i,j) = z_top(i,j) - GV%H_to_Z * h(i,j,k) + enddo ; enddo + call int_density_dz(tv%T(:,:,k), tv%S(:,:,k), z_top, z_bot, 0.0, GV%Rho0, GV%g_Earth, & + G%HI, tv%eqn_of_state, US, dp) + do j=js,je ; do i=is,ie + mass(i,j) = mass(i,j) + dp(i,j) * I_gEarth + enddo ; enddo + enddo + else + do k=1,nz ; do j=js,je ; do i=is,ie + mass(i,j) = mass(i,j) + (GV%H_to_Z * GV%Rlay(k)) * h(i,j,k) + enddo ; enddo ; enddo + endif + else + do k=1,nz ; do j=js,je ; do i=is,ie + mass(i,j) = mass(i,j) + GV%H_to_RZ * h(i,j,k) + enddo ; enddo ; enddo + endif + + if (present(p_bot)) then + do j=js,je ; do i=is,ie + p_bot(i,j) = GV%g_Earth * mass(i,j) + enddo ; enddo + if (present(p_surf) .and. associated(p_surf)) then ; do j=js,je ; do i=is,ie + p_bot(i,j) = p_bot(i,j) + p_surf(i,j) + enddo ; enddo ; endif + endif + +end subroutine find_col_mass + +!> Determine the in situ density averaged over a specified distance from the bottom, +!! calculating it as the inverse of the mass-weighted average specific volume. +subroutine find_rho_bottom(G, GV, US, tv, h, dz, pres_int, dz_avg, j, Rho_bot, h_bot, k_bot) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + !! thermodynamic fields. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: dz !< Height change across layers [Z ~> m] + real, dimension(SZI_(G),SZK_(GV)+1), & + intent(in) :: pres_int !< Pressure at each interface [R L2 T-2 ~> Pa] + real, dimension(SZI_(G)), intent(in) :: dz_avg !< The vertical distance over which to average [Z ~> m] + integer, intent(in) :: j !< j-index of row to work on + real, dimension(SZI_(G)), intent(out) :: Rho_bot !< Near-bottom density [R ~> kg m-3]. + real, dimension(SZI_(G)), intent(out) :: h_bot !< Bottom boundary layer thickness [H ~> m or kg m-2] + integer, dimension(SZI_(G)), intent(out) :: k_bot !< Bottom boundary layer top layer index + + ! Local variables + real :: hb(SZI_(G)) ! Running sum of the thickness in the bottom boundary layer [H ~> m or kg m-2] + real :: SpV_h_bot(SZI_(G)) ! Running sum of the specific volume times thickness in the bottom + ! boundary layer [H R-1 ~> m4 kg-1 or m] + real :: dz_bbl_rem(SZI_(G)) ! Vertical extent of the boundary layer that has yet to be accounted + ! for [Z ~> m] + real :: h_bbl_frac(SZI_(G)) ! Thickness of the fractional layer that makes up the top of the + ! boundary layer [H ~> m or kg m-2] + real :: T_bbl(SZI_(G)) ! Temperature of the fractional layer that makes up the top of the + ! boundary layer [C ~> degC] + real :: S_bbl(SZI_(G)) ! Salinity of the fractional layer that makes up the top of the + ! boundary layer [S ~> ppt] + real :: P_bbl(SZI_(G)) ! Pressure the top of the boundary layer [R L2 T-2 ~> Pa] + real :: dp(SZI_(G)) ! Pressure change across the fractional layer that makes up the top + ! of the boundary layer [R L2 T-2 ~> Pa] + real :: SpV_bbl(SZI_(G)) ! In situ specific volume of the fractional layer that makes up the + ! top of the boundary layer [R-1 ~> m3 kg-1] + real :: frac_in ! The fraction of a layer that is within the bottom boundary layer [nondim] + logical :: do_i(SZI_(G)), do_any + logical :: use_EOS + 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 + + use_EOS = associated(tv%T) .and. associated(tv%S) .and. associated(tv%eqn_of_state) + + if (GV%Boussinesq .or. GV%semi_Boussinesq .or. .not.allocated(tv%SpV_avg)) then + do i=is,ie + rho_bot(i) = GV%Rho0 + enddo + + ! Obtain bottom boundary layer thickness and index of top layer + do i=is,ie + hb(i) = 0.0 ; h_bot(i) = 0.0 ; k_bot(i) = nz + dz_bbl_rem(i) = G%mask2dT(i,j) * max(0.0, dz_avg(i)) + do_i(i) = .true. + if (G%mask2dT(i,j) <= 0.0) then + h_bbl_frac(i) = 0.0 + do_i(i) = .false. + endif + enddo + + do k=nz,1,-1 + do_any = .false. + do i=is,ie ; if (do_i(i)) then + if (dz(i,k) < dz_bbl_rem(i)) then + ! This layer is fully within the averaging depth. + dz_bbl_rem(i) = dz_bbl_rem(i) - dz(i,k) + hb(i) = hb(i) + h(i,j,k) + k_bot(i) = k + do_any = .true. + else + if (dz(i,k) > 0.0) then + frac_in = dz_bbl_rem(i) / dz(i,k) + if (frac_in >= 0.5) k_bot(i) = k ! update bbl top index if >= 50% of layer + else + frac_in = 0.0 + endif + h_bbl_frac(i) = frac_in * h(i,j,k) + dz_bbl_rem(i) = 0.0 + do_i(i) = .false. + endif + endif ; enddo + if (.not.do_any) exit + enddo + do i=is,ie ; if (do_i(i)) then + ! The nominal bottom boundary layer is thicker than the water column, but layer 1 is + ! already included in the averages. These values are set so that the call to find + ! the layer-average specific volume will behave sensibly. + h_bbl_frac(i) = 0.0 + endif ; enddo + + do i=is,ie + if (hb(i) + h_bbl_frac(i) < GV%H_subroundoff) h_bbl_frac(i) = GV%H_subroundoff + h_bot(i) = hb(i) + h_bbl_frac(i) + enddo + + else + ! Check that SpV_avg has been set. + if (tv%valid_SpV_halo < 0) call MOM_error(FATAL, & + "find_rho_bottom called in fully non-Boussinesq mode with invalid values of SpV_avg.") + + ! Set the bottom density to the inverse of the in situ specific volume averaged over the + ! specified distance, with care taken to avoid having compressibility lead to an imprint + ! of the layer thicknesses on this density. + do i=is,ie + hb(i) = 0.0 ; SpV_h_bot(i) = 0.0 ; h_bot(i) = 0.0 ; k_bot(i) = nz + dz_bbl_rem(i) = G%mask2dT(i,j) * max(0.0, dz_avg(i)) + do_i(i) = .true. + if (G%mask2dT(i,j) <= 0.0) then + ! Set acceptable values for calling the equation of state over land. + T_bbl(i) = 0.0 ; S_bbl(i) = 0.0 ; dp(i) = 0.0 ; P_bbl(i) = 0.0 + SpV_bbl(i) = 1.0 ! This value is arbitrary, provided it is non-zero. + h_bbl_frac(i) = 0.0 + do_i(i) = .false. + endif + enddo + + do k=nz,1,-1 + do_any = .false. + do i=is,ie ; if (do_i(i)) then + if (dz(i,k) < dz_bbl_rem(i)) then + ! This layer is fully within the averaging depth. + SpV_h_bot(i) = SpV_h_bot(i) + h(i,j,k) * tv%SpV_avg(i,j,k) + dz_bbl_rem(i) = dz_bbl_rem(i) - dz(i,k) + hb(i) = hb(i) + h(i,j,k) + k_bot(i) = k + do_any = .true. + else + if (dz(i,k) > 0.0) then + frac_in = dz_bbl_rem(i) / dz(i,k) + if (frac_in >= 0.5) k_bot(i) = k ! update bbl top index if >= 50% of layer + else + frac_in = 0.0 + endif + if (use_EOS) then + ! Store the properties of this layer to determine the average + ! specific volume of the portion that is within the BBL. + T_bbl(i) = tv%T(i,j,k) ; S_bbl(i) = tv%S(i,j,k) + dp(i) = frac_in * (GV%g_Earth*GV%H_to_RZ * h(i,j,k)) + P_bbl(i) = pres_int(i,K) + (1.0-frac_in) * (GV%g_Earth*GV%H_to_RZ * h(i,j,k)) + else + SpV_bbl(i) = tv%SpV_avg(i,j,k) + endif + h_bbl_frac(i) = frac_in * h(i,j,k) + dz_bbl_rem(i) = 0.0 + do_i(i) = .false. + endif + endif ; enddo + if (.not.do_any) exit + enddo + do i=is,ie ; if (do_i(i)) then + ! The nominal bottom boundary layer is thicker than the water column, but layer 1 is + ! already included in the averages. These values are set so that the call to find + ! the layer-average specific volume will behave sensibly. + if (use_EOS) then + T_bbl(i) = tv%T(i,j,1) ; S_bbl(i) = tv%S(i,j,1) + dp(i) = 0.0 + P_bbl(i) = pres_int(i,1) + else + SpV_bbl(i) = tv%SpV_avg(i,j,1) + endif + h_bbl_frac(i) = 0.0 + endif ; enddo + + if (use_EOS) then + ! Find the average specific volume of the fractional layer atop the BBL. + EOSdom(:) = EOS_domain(G%HI) + call average_specific_vol(T_bbl, S_bbl, P_bbl, dp, SpV_bbl, tv%eqn_of_state, EOSdom) + endif + + do i=is,ie + if (hb(i) + h_bbl_frac(i) < GV%H_subroundoff) h_bbl_frac(i) = GV%H_subroundoff + rho_bot(i) = G%mask2dT(i,j) * (hb(i) + h_bbl_frac(i)) / (SpV_h_bot(i) + h_bbl_frac(i)*SpV_bbl(i)) + h_bot(i) = hb(i) + h_bbl_frac(i) + enddo + endif + +end subroutine find_rho_bottom + + +!> Converts thickness from geometric height units to thickness units, perhaps via an +!! inversion of the integral of the density in pressure using variables stored in +!! the thermo_var_ptrs type when in non-Boussinesq mode. +subroutine dz_to_thickness_tv(dz, tv, h, G, GV, US, halo_size) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: dz !< Geometric layer thicknesses in height units [Z ~> m] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Output thicknesses in thickness units [H ~> m or kg m-2]. + !! This is essentially intent out, but declared as intent + !! inout to preserve any initialized values in halo points. + integer, optional, intent(in) :: halo_size !< Width of halo within which to + !! calculate thicknesses + ! Local variables + integer :: i, j, k, is, ie, js, je, halo, nz + + halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo ; nz = GV%ke + + if (GV%Boussinesq) then + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = GV%Z_to_H * dz(i,j,k) + enddo ; enddo ; enddo + else + if (associated(tv%eqn_of_state)) then + if (associated(tv%p_surf)) then + call dz_to_thickness_EOS(dz, tv%T, tv%S, tv%eqn_of_state, h, G, GV, US, halo, tv%p_surf) + else + call dz_to_thickness_EOS(dz, tv%T, tv%S, tv%eqn_of_state, h, G, GV, US, halo) + endif + else + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = (GV%RZ_to_H * GV%Rlay(k)) * dz(i,j,k) + enddo ; enddo ; enddo + endif + endif + +end subroutine dz_to_thickness_tv + +!> Converts thickness from geometric height units to thickness units, working via an +!! inversion of the integral of the density in pressure when in non-Boussinesq mode. +subroutine dz_to_thickness_EOS(dz, Temp, Saln, EoS, h, G, GV, US, halo_size, p_surf) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: dz !< Geometric layer thicknesses in height units [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: Temp !< Input layer temperatures [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: Saln !< Input layer salinities [S ~> ppt] + type(EOS_type), intent(in) :: EoS !< Equation of state structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Output thicknesses in thickness units [H ~> m or kg m-2]. + !! This is essentially intent out, but declared as intent + !! inout to preserve any initialized values in halo points. + integer, optional, intent(in) :: halo_size !< Width of halo within which to + !! calculate thicknesses + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: p_surf !< Surface pressures [R L2 T-2 ~> Pa] + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: & + p_top, p_bot ! Pressure at the interfaces above and below a layer [R L2 T-2 ~> Pa] + real :: dp(SZI_(G),SZJ_(G)) ! Pressure change across a layer [R L2 T-2 ~> Pa] + real :: dz_geo(SZI_(G),SZJ_(G)) ! The change in geopotential height across a layer [L2 T-2 ~> m2 s-2] + real :: rho(SZI_(G)) ! The in situ density [R ~> kg m-3] + real :: dp_adj ! The amount by which to change the bottom pressure in an + ! iteration [R L2 T-2 ~> Pa] + real :: I_gEarth ! Unit conversion factors divided by the gravitational + ! acceleration [H T2 R-1 L-2 ~> s2 m2 kg-1 or s2 m-1] + logical :: do_more(SZI_(G),SZJ_(G)) ! If true, additional iterations would be beneficial. + logical :: do_any ! True if there are points in this layer that need more itertions. + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, k, is, ie, js, je, halo, nz + integer :: itt, max_itt + + halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo ; nz = GV%ke + max_itt = 10 + + if (GV%Boussinesq) then + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = GV%Z_to_H * dz(i,j,k) + enddo ; enddo ; enddo + else + I_gEarth = GV%RZ_to_H / GV%g_Earth + + if (present(p_surf)) then + do j=js,je ; do i=is,ie + p_bot(i,j) = 0.0 ; p_top(i,j) = p_surf(i,j) + enddo ; enddo + else + do j=js,je ; do i=is,ie + p_bot(i,j) = 0.0 ; p_top(i,j) = 0.0 + enddo ; enddo + endif + EOSdom(:) = EOS_domain(G%HI) + + ! The iterative approach here is inherited from very old code that was in the + ! MOM_state_initialization module. It does converge, but it is very inefficient and + ! should be revised, although doing so would change answers in non-Boussinesq mode. + do k=1,nz + do j=js,je + do i=is,ie ; p_top(i,j) = p_bot(i,j) ; enddo + call calculate_density(Temp(:,j,k), Saln(:,j,k), p_top(:,j), rho, & + EoS, EOSdom) + ! The following two expressions are mathematically equivalent. + if (GV%semi_Boussinesq) then + do i=is,ie + p_bot(i,j) = p_top(i,j) + (GV%g_Earth*GV%H_to_Z) * ((GV%Z_to_H*dz(i,j,k)) * rho(i)) + dp(i,j) = (GV%g_Earth*GV%H_to_Z) * ((GV%Z_to_H*dz(i,j,k)) * rho(i)) + enddo + else + do i=is,ie + p_bot(i,j) = p_top(i,j) + rho(i) * (GV%g_Earth * dz(i,j,k)) + dp(i,j) = rho(i) * (GV%g_Earth * dz(i,j,k)) + enddo + endif + enddo + + do_more(:,:) = .true. + do itt=1,max_itt + do_any = .false. + call int_specific_vol_dp(Temp(:,:,k), Saln(:,:,k), p_top, p_bot, 0.0, G%HI, EoS, US, dz_geo) + if (itt < max_itt) then ; do j=js,je + call calculate_density(Temp(:,j,k), Saln(:,j,k), p_bot(:,j), rho, EoS, EOSdom) + ! Use Newton's method to correct the bottom value. + ! The hydrostatic equation is sufficiently linear that no bounds-checking is needed. + if (GV%semi_Boussinesq) then + do i=is,ie + dp_adj = rho(i) * ((GV%g_Earth*GV%H_to_Z)*(GV%Z_to_H*dz(i,j,k)) - dz_geo(i,j)) + p_bot(i,j) = p_bot(i,j) + dp_adj + dp(i,j) = dp(i,j) + dp_adj + enddo + do_any = .true. ! To avoid changing answers, always use the maximum number of itertions. + else + do i=is,ie ; if (do_more(i,j)) then + dp_adj = rho(i) * (GV%g_Earth*dz(i,j,k) - dz_geo(i,j)) + p_bot(i,j) = p_bot(i,j) + dp_adj + dp(i,j) = dp(i,j) + dp_adj + ! Check for convergence to roundoff. + do_more(i,j) = (abs(dp_adj) > 1.0e-15*dp(i,j)) + if (do_more(i,j)) do_any = .true. + endif ; enddo + endif + enddo ; endif + if (.not.do_any) exit + enddo + + if (GV%semi_Boussinesq) then + do j=js,je ; do i=is,ie + h(i,j,k) = (p_bot(i,j) - p_top(i,j)) * I_gEarth + enddo ; enddo + else + do j=js,je ; do i=is,ie + h(i,j,k) = dp(i,j) * I_gEarth + enddo ; enddo + endif + enddo + endif + +end subroutine dz_to_thickness_EOS + +!> Converts thickness from geometric height units to thickness units, perhaps using +!! a simple conversion factor that may be problematic in non-Boussinesq mode. +subroutine dz_to_thickness_simple(dz, h, G, GV, US, halo_size, layer_mode) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: dz !< Geometric layer thicknesses in height units [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Output thicknesses in thickness units [H ~> m or kg m-2]. + !! This is essentially intent out, but declared as intent + !! inout to preserve any initialized values in halo points. + integer, optional, intent(in) :: halo_size !< Width of halo within which to + !! calculate thicknesses + logical, optional, intent(in) :: layer_mode !< If present and true, do the conversion that + !! is appropriate in pure isopycnal layer mode with + !! no state variables or equation of state. Otherwise + !! use a simple constant rescaling factor and avoid the + !! use of GV%Rlay. + ! Local variables + logical :: layered ! If true and the model is non-Boussinesq, do calculations appropriate for use + ! in pure isopycnal layered mode with no state variables or equation of state. + integer :: i, j, k, is, ie, js, je, halo, nz + + halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) + layered = .false. ; if (present(layer_mode)) layered = layer_mode + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo ; nz = GV%ke + + if (GV%Boussinesq) then + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = GV%Z_to_H * dz(i,j,k) + enddo ; enddo ; enddo + elseif (layered) then + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = (GV%RZ_to_H * GV%Rlay(k)) * dz(i,j,k) + enddo ; enddo ; enddo + else + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = (US%Z_to_m * GV%m_to_H) * dz(i,j,k) + enddo ; enddo ; enddo + endif + +end subroutine dz_to_thickness_simple + +!> Converts layer thicknesses in thickness units to the vertical distance between edges in height +!! units, perhaps by multiplication by the precomputed layer-mean specific volume stored in an +!! array in the thermo_var_ptrs type when in non-Boussinesq mode. +subroutine thickness_to_dz_3d(h, tv, dz, G, GV, US, halo_size) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Input thicknesses in thickness units [H ~> m or kg m-2]. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: dz !< Geometric layer thicknesses in height units [Z ~> m] + !! This is essentially intent out, but declared as intent + !! inout to preserve any initialized values in halo points. + integer, optional, intent(in) :: halo_size !< Width of halo within which to + !! calculate thicknesses + ! Local variables + character(len=128) :: mesg ! A string for error messages + integer :: i, j, k, is, ie, js, je, halo, nz + + halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo ; nz = GV%ke + + if ((.not.GV%Boussinesq) .and. allocated(tv%SpV_avg)) then + if ((allocated(tv%SpV_avg)) .and. (tv%valid_SpV_halo < halo)) then + if (tv%valid_SpV_halo < 0) then + mesg = "invalid values of SpV_avg." + else + write(mesg, '("insufficiently large SpV_avg halos of width ", i2, " but ", i2," is needed.")') & + tv%valid_SpV_halo, halo + endif + call MOM_error(FATAL, "thickness_to_dz called in fully non-Boussinesq mode with "//trim(mesg)) + endif + + do k=1,nz ; do j=js,je ; do i=is,ie + dz(i,j,k) = GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + enddo ; enddo ; enddo + else + do k=1,nz ; do j=js,je ; do i=is,ie + dz(i,j,k) = GV%H_to_Z * h(i,j,k) + enddo ; enddo ; enddo + endif + +end subroutine thickness_to_dz_3d + + +!> Converts a vertical i- / k- slice of layer thicknesses in thickness units to the vertical +!! distance between edges in height units, perhaps by multiplication by the precomputed layer-mean +!! specific volume stored in an array in the thermo_var_ptrs type when in non-Boussinesq mode. +subroutine thickness_to_dz_jslice(h, tv, dz, j, G, GV, halo_size) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Input thicknesses in thickness units [H ~> m or kg m-2]. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + real, dimension(SZI_(G),SZK_(GV)), & + intent(inout) :: dz !< Geometric layer thicknesses in height units [Z ~> m] + !! This is essentially intent out, but declared as intent + !! inout to preserve any initialized values in halo points. + integer, intent(in) :: j !< The second (j-) index of the input thicknesses to work with + integer, optional, intent(in) :: halo_size !< Width of halo within which to + !! calculate thicknesses + ! Local variables + character(len=128) :: mesg ! A string for error messages + integer :: i, k, is, ie, halo, nz + + halo = 0 ; if (present(halo_size)) halo = max(0,halo_size) + is = G%isc-halo ; ie = G%iec+halo ; nz = GV%ke + + if ((.not.GV%Boussinesq) .and. allocated(tv%SpV_avg)) then + if ((allocated(tv%SpV_avg)) .and. (tv%valid_SpV_halo < halo)) then + if (tv%valid_SpV_halo < 0) then + mesg = "invalid values of SpV_avg." + else + write(mesg, '("insufficiently large SpV_avg halos of width ", i2, " but ", i2," is needed.")') & + tv%valid_SpV_halo, halo + endif + call MOM_error(FATAL, "thickness_to_dz called in fully non-Boussinesq mode with "//trim(mesg)) + endif + + do k=1,nz ; do i=is,ie + dz(i,k) = GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + enddo ; enddo + else + do k=1,nz ; do i=is,ie + dz(i,k) = GV%H_to_Z * h(i,j,k) + enddo ; enddo + endif + +end subroutine thickness_to_dz_jslice + + +!> Convert mixed layer depths in height units into the thickness of water in the mixed +!! in thickness units. +subroutine convert_MLD_to_ML_thickness(MLD_in, h, h_MLD, tv, G, GV, halo) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: MLD_in !< Input mixed layer depth [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), & + intent(out) :: h_MLD !< Thickness of water in the mixed layer [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + !! thermodynamic fields. + integer, optional, intent(in) :: halo !< Halo width over which to calculate frazil + + ! Local variables + real :: MLD_rem(SZI_(G)) ! The vertical extent of the MLD_in that has not yet been accounted for [Z ~> m] + character(len=128) :: mesg ! A string for error messages + logical :: keep_going + integer :: i, j, k, is, ie, js, je, nz, halos + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + halos = 0 ; if (present(halo)) halos = halo + if (present(halo)) then + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo + endif + + if (GV%Boussinesq .or. (.not.allocated(tv%SpV_avg))) then + do j=js,je ; do i=is,ie + h_MLD(i,j) = GV%Z_to_H * MLD_in(i,j) + enddo ; enddo + else ! The fully non-Boussinesq conversion between height in MLD_in and thickness. + if ((allocated(tv%SpV_avg)) .and. (tv%valid_SpV_halo < halos)) then + if (tv%valid_SpV_halo < 0) then + mesg = "invalid values of SpV_avg." + else + write(mesg, '("insufficiently large SpV_avg halos of width ", i2, " but ", i2," is needed.")') & + tv%valid_SpV_halo, halos + endif + call MOM_error(FATAL, "convert_MLD_to_ML_thickness called in fully non-Boussinesq mode with "//trim(mesg)) + endif + + do j=js,je + do i=is,ie ; MLD_rem(i) = MLD_in(i,j) ; h_MLD(i,j) = 0.0 ; enddo + do k=1,nz + keep_going = .false. + do i=is,ie ; if (MLD_rem(i) > 0.0) then + if (MLD_rem(i) > GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k)) then + h_MLD(i,j) = h_MLD(i,j) + h(i,j,k) + MLD_rem(i) = MLD_rem(i) - GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + keep_going = .true. + else + h_MLD(i,j) = h_MLD(i,j) + GV%RZ_to_H * MLD_rem(i) / tv%SpV_avg(i,j,k) + MLD_rem(i) = 0.0 + endif + endif ; enddo + if (.not.keep_going) exit + enddo + enddo + endif + +end subroutine convert_MLD_to_ML_thickness + end module MOM_interface_heights diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 80d94ec7fe..1dd1d92bf2 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -1,13 +1,17 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Calculations of isoneutral slopes and stratification. module MOM_isopycnal_slopes -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_grid, only : ocean_grid_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density_derivs +use MOM_debugging, only : hchksum, uvchksum +use MOM_error_handler, only : MOM_error, FATAL +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density_derivs, calculate_density_second_derivs, EOS_domain use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S @@ -26,18 +30,19 @@ module MOM_isopycnal_slopes !> Calculate isopycnal slopes, and optionally return other stratification dependent functions such as N^2 !! and dz*S^2*g-prime used, or calculable from factors used, during the calculation. -subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & - slope_x, slope_y, N2_u, N2_v, dzu, dzv, dzSxN, dzSyN, halo, OBC) !, eta_to_m) +subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stanley, slope_x, slope_y, & + N2_u, N2_v, dzu, dzv, dzSxN, dzSyN, halo, OBC, OBC_N2) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface heights [Z ~> m] or units - !! given by 1/eta_to_m) + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface heights [Z ~> m] type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables - real, intent(in) :: dt_kappa_smooth !< A smoothing vertical diffusivity - !! times a smoothing timescale [Z2 ~> m2]. + real, intent(in) :: dt_kappa_smooth !< A smoothing vertical + !! diffusivity times a smoothing + !! timescale [H Z ~> m2 or kg m-1] + logical, intent(in) :: use_stanley !< turn on stanley param in slope real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: slope_x !< Isopycnal slope in i-dir [Z L-1 ~> nondim] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: slope_y !< Isopycnal slope in j-dir [Z L-1 ~> nondim] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), & @@ -58,47 +63,65 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !! Eady growth rate at v-points. [Z T-1 ~> m s-1] integer, optional, intent(in) :: halo !< Halo width over which to compute type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. + logical, optional, intent(in) :: OBC_N2 !< If present and true, use interior data + !! to calculate stratification at open boundary + !! condition faces. - ! real, optional, intent(in) :: eta_to_m !< The conversion factor from the units - ! (This argument has been tested but for now serves no purpose.) !! of eta to m; US%Z_to_m by default. ! Local variables real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: & - T, & ! The temperature [degC], with the values in + T, & ! The temperature [C ~> degC], with the values in ! in massless layers filled vertically by diffusion. - S !, & ! The filled salinity [ppt], with the values in + S ! The filled salinity [S ~> ppt], with the values in ! in massless layers filled vertically by diffusion. -! Rho ! Density itself, when a nonlinear equation of state is not in use [R ~> kg m-3]. real, dimension(SZI_(G), SZJ_(G),SZK_(GV)+1) :: & pres ! The pressure at an interface [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G)) :: scrap ! An array to pass to calculate_density_second_derivs() that is + ! set there but will be ignored, it is used simultaneously with four different + ! inconsistent units of [R S-1 C-1 ~> kg m-3 degC-1 ppt-1], [R S-2 ~> kg m-3 ppt-2], + ! [T2 S-1 L-2 ~> kg m-3 ppt-1 Pa-1] and [T2 C-1 L-2 ~> kg m-3 degC-1 Pa-1]. real, dimension(SZIB_(G)) :: & - drho_dT_u, & ! The derivative of density with temperature at u points [R degC-1 ~> kg m-3 degC-1]. - drho_dS_u ! The derivative of density with salinity at u points [R ppt-1 ~> kg m-3 ppt-1]. + drho_dT_u, & ! The derivative of density with temperature at u points [R C-1 ~> kg m-3 degC-1]. + drho_dS_u ! The derivative of density with salinity at u points [R S-1 ~> kg m-3 ppt-1]. real, dimension(SZI_(G)) :: & - drho_dT_v, & ! The derivative of density with temperature at v points [R degC-1 ~> kg m-3 degC-1]. - drho_dS_v ! The derivative of density with salinity at v points [R ppt-1 ~> kg m-3 ppt-1]. + drho_dT_v, & ! The derivative of density with temperature at v points [R C-1 ~> kg m-3 degC-1]. + drho_dS_v, & ! The derivative of density with salinity at v points [R S-1 ~> kg m-3 ppt-1]. + drho_dT_dT_h, & ! The second derivative of density with temperature at h points [R C-2 ~> kg m-3 degC-2] + drho_dT_dT_hr ! The second derivative of density with temperature at h (+1) points [R C-2 ~> kg m-3 degC-2] real, dimension(SZIB_(G)) :: & - T_u, & ! Temperature on the interface at the u-point [degC]. - S_u, & ! Salinity on the interface at the u-point [ppt]. + T_u, & ! Temperature on the interface at the u-point [C ~> degC]. + S_u, & ! Salinity on the interface at the u-point [S ~> ppt]. + GxSpV_u, & ! Gravitiational acceleration times the specific volume at an interface + ! at the u-points [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] pres_u ! Pressure on the interface at the u-point [R L2 T-2 ~> Pa]. real, dimension(SZI_(G)) :: & - T_v, & ! Temperature on the interface at the v-point [degC]. - S_v, & ! Salinity on the interface at the v-point [ppt]. + T_v, & ! Temperature on the interface at the v-point [C ~> degC]. + S_v, & ! Salinity on the interface at the v-point [S ~> ppt]. + GxSpV_v, & ! Gravitiational acceleration times the specific volume at an interface + ! at the v-points [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] pres_v ! Pressure on the interface at the v-point [R L2 T-2 ~> Pa]. - real :: drdiA, drdiB ! Along layer zonal- and meridional- potential density - real :: drdjA, drdjB ! gradients in the layers above (A) and below (B) the - ! interface times the grid spacing [R ~> kg m-3]. + real, dimension(SZI_(G)) :: & + T_h, & ! Temperature on the interface at the h-point [C ~> degC]. + S_h, & ! Salinity on the interface at the h-point [S ~> ppt] + pres_h, & ! Pressure on the interface at the h-point [R L2 T-2 ~> Pa]. + T_hr, & ! Temperature on the interface at the h (+1) point [C ~> degC]. + S_hr, & ! Salinity on the interface at the h (+1) point [S ~> ppt] + pres_hr ! Pressure on the interface at the h (+1) point [R L2 T-2 ~> Pa]. + real :: drdiA, drdiB ! Along layer zonal potential density gradients in the layers above (A) + ! and below (B) the interface times the grid spacing [R ~> kg m-3]. + real :: drdjA, drdjB ! Along layer meridional potential density gradients in the layers above (A) + ! and below (B) the interface times the grid spacing [R ~> kg m-3]. real :: drdkL, drdkR ! Vertical density differences across an interface [R ~> kg m-3]. real :: hg2A, hg2B ! Squares of geometric mean thicknesses [H2 ~> m2 or kg2 m-4]. real :: hg2L, hg2R ! Squares of geometric mean thicknesses [H2 ~> m2 or kg2 m-4]. real :: haA, haB, haL, haR ! Arithmetic mean thicknesses [H ~> m or kg m-2]. real :: dzaL, dzaR ! Temporary thicknesses in eta units [Z ~> m]. - real :: wtA, wtB, wtL, wtR ! Unscaled weights, with various units. + real :: wtA, wtB ! Unnormalized weights of the slopes above and below [H3 ~> m3 or kg3 m-6] + real :: wtL, wtR ! Unnormalized weights of the slopes to the left and right [H3 Z ~> m4 or kg3 m-5] real :: drdx, drdy ! Zonal and meridional density gradients [R L-1 ~> kg m-4]. real :: drdz ! Vertical density gradient [R Z-1 ~> kg m-4]. real :: slope ! The slope of density surfaces, calculated in a way ! that is always between -1 and 1. [Z L-1 ~> nondim] real :: mag_grad2 ! The squared magnitude of the 3-d density gradient [R2 Z-2 ~> kg2 m-8]. - real :: slope2_Ratio ! The ratio of the slope squared to slope_max squared. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4]. @@ -106,39 +129,43 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & ! in roundoff and can be neglected [Z ~> m]. logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. real :: G_Rho0 ! The gravitational acceleration divided by density [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] - real :: Z_to_L ! A conversion factor between from units for e to the - ! units for lateral distances [L Z-1 ~> 1] - real :: L_to_Z ! A conversion factor between from units for lateral distances - ! to the units for e [Z L-1 ~> 1] - real :: H_to_Z ! A conversion factor from thickness units to the units of e [Z H-1 ~> 1 or m3 kg-1] logical :: present_N2_u, present_N2_v - integer, dimension(2) :: EOSdom_u, EOSdom_v ! Domains for the equation of state calculations at u and v points + logical :: local_open_u_BC, local_open_v_BC ! True if u- or v-face OBCs exist anywhere in the global domain. + logical :: OBC_friendly ! If true, open boundary conditions are in use and only interior data should + ! be used to calculate N2 at OBC faces. + integer, dimension(2) :: EOSdom_u ! The shifted I-computational domain to use for equation of + ! state calculations at u-points. + integer, dimension(2) :: EOSdom_v ! The shifted i-computational domain to use for equation of + ! state calculations at v-points. + integer, dimension(2) :: EOSdom_h1 ! The shifted i-computational domain to use for equation of + ! state calculations at h points with 1 extra halo point integer :: is, ie, js, je, nz, IsdB integer :: i, j, k - integer :: l_seg - logical :: local_open_u_BC, local_open_v_BC if (present(halo)) then is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo + EOSdom_h1(:) = EOS_domain(G%HI, halo=halo+1) else is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + EOSdom_h1(:) = EOS_domain(G%HI, halo=1) endif + EOSdom_u(1) = is-1 - (G%IsdB-1) ; EOSdom_u(2) = ie - (G%IsdB-1) + EOSdom_v(:) = EOS_domain(G%HI, halo=halo) + nz = GV%ke ; IsdB = G%IsdB + h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect**2 - Z_to_L = US%Z_to_L ; H_to_Z = GV%H_to_Z - ! if (present(eta_to_m)) then - ! Z_to_L = eta_to_m*US%m_to_L ; H_to_Z = GV%H_to_m / eta_to_m - ! endif - L_to_Z = 1.0 / Z_to_L - dz_neglect = GV%H_subroundoff * H_to_Z + dz_neglect = GV%dZ_subroundoff local_open_u_BC = .false. local_open_v_BC = .false. + OBC_friendly = .false. if (present(OBC)) then ; if (associated(OBC)) then local_open_u_BC = OBC%open_u_BCs_exist_globally local_open_v_BC = OBC%open_v_BCs_exist_globally + if (present(OBC_N2)) OBC_friendly = OBC_N2 endif ; endif use_EOS = associated(tv%eqn_of_state) @@ -185,9 +212,20 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & if (use_EOS) then if (present(halo)) then - call vert_fill_TS(h, tv%T, tv%S, dt_kappa_smooth, T, S, G, GV, halo+1) + call vert_fill_TS(h, tv%T, tv%S, dt_kappa_smooth, T, S, G, GV, US, halo+1) else - call vert_fill_TS(h, tv%T, tv%S, dt_kappa_smooth, T, S, G, GV, 1) + call vert_fill_TS(h, tv%T, tv%S, dt_kappa_smooth, T, S, G, GV, US, 1) + endif + endif + + if ((use_EOS .and. allocated(tv%SpV_avg) .and. (tv%valid_SpV_halo < 1)) .and. & + (present_N2_u .or. present(dzSxN) .or. present_N2_v .or. present(dzSyN))) then + if (tv%valid_SpV_halo < 0) then + call MOM_error(FATAL, "calc_isoneutral_slopes called in fully non-Boussinesq mode "//& + "with invalid values of SpV_avg.") + else + call MOM_error(FATAL, "calc_isoneutral_slopes called in fully non-Boussinesq mode "//& + "with insufficiently large SpV_avg halos of width 0 but 1 is needed.") endif endif @@ -210,16 +248,19 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & enddo ; enddo enddo - EOSdom_u(1) = is-1 - (G%IsdB-1) ; EOSdom_u(2) = ie - (G%IsdB-1) - + do I=is-1,ie + GxSpV_u(I) = G_Rho0 ! This will be changed if both use_EOS and allocated(tv%SpV_avg) are true + enddo !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv,h,e, & - !$OMP h_neglect,dz_neglect,Z_to_L,L_to_Z,H_to_Z,h_neglect2, & - !$OMP present_N2_u,G_Rho0,N2_u,slope_x,dzSxN,EOSdom_u,local_open_u_BC, & - !$OMP dzu,OBC) & + !$OMP h_neglect,dz_neglect,h_neglect2, & + !$OMP present_N2_u,G_Rho0,N2_u,slope_x,dzSxN,EOSdom_u,EOSdom_h1, & + !$OMP local_open_u_BC,dzu,OBC,use_stanley,OBC_friendly) & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & + !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & - !$OMP drdx,mag_grad2,slope,slope2_Ratio,l_seg) + !$OMP drdx,mag_grad2,slope) & + !$OMP firstprivate(GxSpV_u) do j=js,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdiA = 0.0 ; drdiB = 0.0 @@ -233,8 +274,49 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & T_u(I) = 0.25*((T(i,j,k) + T(i+1,j,k)) + (T(i,j,k-1) + T(i+1,j,k-1))) S_u(I) = 0.25*((S(i,j,k) + S(i+1,j,k)) + (S(i,j,k-1) + S(i+1,j,k-1))) enddo + if (OBC_friendly) then + if (OBC%u_E_OBCs_on_PE .and. (j>=OBC%js_u_E_obc) .and. (j<=OBC%je_u_E_obc)) then + do I = max(is-1, OBC%Is_u_E_obc), min(ie, OBC%Ie_u_E_obc) + if (OBC%segnum_u(I,j) > 0) then ! OBC_DIRECTION_E + pres_u(I) = pres(i,j,K) + T_u(I) = 0.5*(T(i,j,k) + T(i,j,k-1)) + S_u(I) = 0.5*(S(i,j,k) + S(i,j,k-1)) + endif + enddo + endif + if (OBC%u_W_OBCs_on_PE .and. (j>=OBC%js_u_W_obc) .and. (j<=OBC%je_u_W_obc)) then + do I = max(is-1, OBC%Is_u_W_obc), min(ie, OBC%Ie_u_W_obc) + if (OBC%segnum_u(I,j) < 0) then ! OBC_DIRECTION_W + pres_u(I) = pres(i+1,j,K) + T_u(I) = 0.5*(T(i+1,j,k) + T(i+1,j,k-1)) + S_u(I) = 0.5*(S(i+1,j,k) + S(i+1,j,k-1)) + endif + enddo + endif + endif call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, drho_dS_u, & tv%eqn_of_state, EOSdom_u) + if (present_N2_u .or. (present(dzSxN))) then + if (allocated(tv%SpV_avg)) then + do I=is-1,ie + GxSpV_u(I) = GV%g_Earth * 0.25* ((tv%SpV_avg(i,j,k) + tv%SpV_avg(i+1,j,k)) + & + (tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i+1,j,k-1))) + enddo + endif + endif + endif + + if (use_stanley) then + do i=is-1,ie+1 + pres_h(i) = pres(i,j,K) + T_h(i) = 0.5*(T(i,j,k) + T(i,j,k-1)) + S_h(i) = 0.5*(S(i,j,k) + S(i,j,k-1)) + enddo + ! The second line below would correspond to arguments + ! drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & + call calculate_density_second_derivs(T_h, S_h, pres_h, & + scrap, scrap, drho_dT_dT_h, scrap, scrap, & + tv%eqn_of_state, dom=EOSdom_h1) endif do I=is-1,ie @@ -251,18 +333,25 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & drdkR = (drho_dT_u(I) * (T(i+1,j,k)-T(i+1,j,k-1)) + & drho_dS_u(I) * (S(i+1,j,k)-S(i+1,j,k-1))) endif - + if (use_stanley) then + ! Correction to the horizontal density gradient due to nonlinearity in + ! the EOS rectifying SGS temperature anomalies + drdiA = drdiA + 0.5 * ((drho_dT_dT_h(i+1) * tv%varT(i+1,j,k-1)) - & + (drho_dT_dT_h(i) * tv%varT(i,j,k-1)) ) + drdiB = drdiB + 0.5 * ((drho_dT_dT_h(i+1) * tv%varT(i+1,j,k)) - & + (drho_dT_dT_h(i) * tv%varT(i,j,k)) ) + endif hg2A = h(i,j,k-1)*h(i+1,j,k-1) + h_neglect2 hg2B = h(i,j,k)*h(i+1,j,k) + h_neglect2 hg2L = h(i,j,k-1)*h(i,j,k) + h_neglect2 hg2R = h(i+1,j,k-1)*h(i+1,j,k) + h_neglect2 - haA = 0.5*(h(i,j,k-1) + h(i+1,j,k-1)) + haA = 0.5*(h(i,j,k-1) + h(i+1,j,k-1)) + h_neglect haB = 0.5*(h(i,j,k) + h(i+1,j,k)) + h_neglect haL = 0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect haR = 0.5*(h(i+1,j,k-1) + h(i+1,j,k)) + h_neglect if (GV%Boussinesq) then - dzaL = haL * H_to_Z ; dzaR = haR * H_to_Z + dzaL = haL * GV%H_to_Z ; dzaR = haR * GV%H_to_Z else dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect dzaR = 0.5*(e(i+1,j,K-1) - e(i+1,j,K+1)) + dz_neglect @@ -273,12 +362,26 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & wtA = hg2A*haB ; wtB = hg2B*haA wtL = hg2L*(haR*dzaR) ; wtR = hg2R*(haL*dzaL) - drdz = (wtL * drdkL + wtR * drdkR) / (dzaL*wtL + dzaR*wtR) + drdz = ((wtL * drdkL) + (wtR * drdkR)) / ((dzaL*wtL) + (dzaR*wtR)) ! The expression for drdz above is mathematically equivalent to: ! drdz = ((hg2L/haL) * drdkL/dzaL + (hg2R/haR) * drdkR/dzaR) / & ! ((hg2L/haL) + (hg2R/haR)) - ! This is the gradient of density along geopotentials. - if (present_N2_u) N2_u(I,j,K) = G_Rho0 * drdz * G%mask2dCu(I,j) ! Square of buoyancy freq. [L2 Z-2 T-2 ~> s-2] + ! which is an estimate of the gradient of density across geopotentials. + if (present_N2_u) then + if (OBC_friendly) then ; if (OBC%segnum_u(I,j) /= 0) then + if (OBC%segnum_u(I,j) > 0) then ! OBC_DIRECTION_E + drdz = drdkL / dzaL ! Note that drdz is not used for slopes at OBC faces. + if (use_EOS .and. allocated(tv%SpV_avg)) & + GxSpV_u(I) = GV%g_Earth * 0.5 * (tv%SpV_avg(i,j,k) + tv%SpV_avg(i,j,k-1)) + elseif (OBC%segnum_u(I,j) < 0) then ! OBC_DIRECTION_W + drdz = drdkR / dzaR + if (use_EOS .and. allocated(tv%SpV_avg)) & + GxSpV_u(I) = GV%g_Earth * 0.5 * (tv%SpV_avg(i+1,j,k) + tv%SpV_avg(i+1,j,k-1)) + endif + endif ; endif + + N2_u(I,j,K) = GxSpV_u(I) * drdz * G%mask2dCu(I,j) ! Square of buoyancy freq. [L2 Z-2 T-2 ~> s-2] + endif if (use_EOS) then drdx = ((wtA * drdiA + wtB * drdiB) / (wtA + wtB) - & @@ -286,51 +389,57 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & ! This estimate of slope is accurate for small slopes, but bounded ! to be between -1 and 1. - mag_grad2 = (Z_to_L*drdx)**2 + drdz**2 + mag_grad2 = (US%Z_to_L*drdx)**2 + drdz**2 if (mag_grad2 > 0.0) then slope = drdx / sqrt(mag_grad2) else ! Just in case mag_grad2 = 0 ever. slope = 0.0 endif else ! With .not.use_EOS, the layers are constant density. - slope = (e(i,j,K)-e(i+1,j,K)) * G%IdxCu(I,j) + slope = (e(i+1,j,K)-e(i,j,K)) * G%IdxCu(I,j) endif + if (local_open_u_BC) then - l_seg = OBC%segnum_u(I,j) - if (l_seg /= OBC_NONE) then - if (OBC%segment(l_seg)%open) then + if (OBC%segnum_u(I,j) /= 0) then + if (OBC%segment(abs(OBC%segnum_u(I,j)))%open) then slope = 0. ! This and/or the masking code below is to make slopes match inside ! land mask. Might not be necessary except for DEBUG output. -! if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then +! if (OBC%segnum_u(I,j) > 0) then ! OBC_DIRECTION_E ! slope_x(I+1,j,K) = 0. ! else ! slope_x(I-1,j,K) = 0. ! endif endif endif - slope = slope * max(g%mask2dT(i,j),g%mask2dT(i+1,j)) + slope = slope * max(G%mask2dT(i,j), G%mask2dT(i+1,j)) endif + slope_x(I,j,K) = slope - if (present(dzSxN)) dzSxN(I,j,K) = sqrt( G_Rho0 * max(0., wtL * ( dzaL * drdkL ) & - + wtR * ( dzaR * drdkR )) / (wtL + wtR) ) & ! dz * N - * abs(slope) * G%mask2dCu(I,j) ! x-direction contribution to S^2 + if (present(dzSxN)) & + dzSxN(I,j,K) = sqrt( GxSpV_u(I) * max(0., (wtL * ( dzaL * drdkL )) & + + (wtR * ( dzaR * drdkR ))) / (wtL + wtR) ) & ! dz * N + * abs(slope) * G%mask2dCu(I,j) ! x-direction contribution to S^2 enddo ! I enddo ; enddo ! end of j-loop - EOSdom_v(1) = is - (G%isd-1) ; EOSdom_v(2) = ie - (G%isd-1) - + do i=is,ie + GxSpV_v(i) = G_Rho0 !This will be changed if both use_EOS and allocated(tv%SpV_avg) are true + enddo ! Calculate the meridional isopycnal slope. !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv, & - !$OMP h,h_neglect,e,dz_neglect,Z_to_L,L_to_Z,H_to_Z, & + !$OMP h,h_neglect,e,dz_neglect, & !$OMP h_neglect2,present_N2_v,G_Rho0,N2_v,slope_y,dzSyN,EOSdom_v, & - !$OMP dzv,local_open_v_BC,OBC) & + !$OMP dzv,local_open_v_BC,OBC,use_stanley,OBC_friendly) & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & + !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h, & + !$OMP drho_dT_dT_hr,pres_hr,T_hr,S_hr, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & - !$OMP drdy,mag_grad2,slope,slope2_Ratio,l_seg) - do j=js-1,je ; do K=nz,2,-1 + !$OMP drdy,mag_grad2,slope) & + !$OMP firstprivate(GxSpV_v) + do J=js-1,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdjA = 0.0 ; drdjB = 0.0 drdkL = GV%Rlay(k)-GV%Rlay(k-1) ; drdkR = GV%Rlay(k)-GV%Rlay(k-1) @@ -342,8 +451,57 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & T_v(i) = 0.25*((T(i,j,k) + T(i,j+1,k)) + (T(i,j,k-1) + T(i,j+1,k-1))) S_v(i) = 0.25*((S(i,j,k) + S(i,j+1,k)) + (S(i,j,k-1) + S(i,j+1,k-1))) enddo - call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, tv%eqn_of_state, & - EOSdom_v) + if (OBC_friendly) then + if (OBC%v_N_OBCs_on_PE .and. (J>=OBC%Js_v_N_obc) .and. (J<=OBC%Je_v_N_obc)) then + do i = max(is, OBC%is_v_N_obc), min(ie, OBC%ie_v_N_obc) + if (OBC%segnum_v(i,J) > 0) then ! OBC_DIRECTION_N + pres_v(i) = pres(i,j,K) + T_v(i) = 0.5*(T(i,j,k) + T(i,j,k-1)) + S_v(i) = 0.5*(S(i,j,k) + S(i,j,k-1)) + endif + enddo + endif + if (OBC%v_S_OBCs_on_PE .and. (J>=OBC%Js_v_S_obc) .and. (J<=OBC%Je_v_S_obc)) then + do i = max(is, OBC%is_v_S_obc), min(ie, OBC%ie_v_S_obc) + if (OBC%segnum_v(i,J) < 0) then ! OBC_DIRECTION_S + pres_v(i) = pres(i,j+1,K) + T_v(i) = 0.5*(T(i,j+1,k) + T(i,j+1,k-1)) + S_v(i) = 0.5*(S(i,j+1,k) + S(i,j+1,k-1)) + endif + enddo + endif + endif + call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, & + tv%eqn_of_state, EOSdom_v) + + if ((present_N2_v) .or. (present(dzSyN))) then + if (allocated(tv%SpV_avg)) then + do i=is,ie + GxSpV_v(i) = GV%g_Earth * 0.25* ((tv%SpV_avg(i,j,k) + tv%SpV_avg(i,j+1,k)) + & + (tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i,j+1,k-1))) + enddo + endif + endif + endif + + if (use_stanley) then + do i=is,ie + pres_h(i) = pres(i,j,K) + T_h(i) = 0.5*(T(i,j,k) + T(i,j,k-1)) + S_h(i) = 0.5*(S(i,j,k) + S(i,j,k-1)) + + pres_hr(i) = pres(i,j+1,K) + T_hr(i) = 0.5*(T(i,j+1,k) + T(i,j+1,k-1)) + S_hr(i) = 0.5*(S(i,j+1,k) + S(i,j+1,k-1)) + enddo + ! The second line below would correspond to arguments + ! drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & + call calculate_density_second_derivs(T_h, S_h, pres_h, & + scrap, scrap, drho_dT_dT_h, scrap, scrap, & + tv%eqn_of_state, dom=EOSdom_v) + call calculate_density_second_derivs(T_hr, S_hr, pres_hr, & + scrap, scrap, drho_dT_dT_hr, scrap, scrap, & + tv%eqn_of_state, dom=EOSdom_v) endif do i=is,ie if (use_EOS) then @@ -359,6 +517,14 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & drdkR = (drho_dT_v(i) * (T(i,j+1,k)-T(i,j+1,k-1)) + & drho_dS_v(i) * (S(i,j+1,k)-S(i,j+1,k-1))) endif + if (use_stanley) then + ! Correction to the horizontal density gradient due to nonlinearity in + ! the EOS rectifying SGS temperature anomalies + drdjA = drdjA + 0.5 * ((drho_dT_dT_hr(i) * tv%varT(i,j+1,k-1)) - & + (drho_dT_dT_h(i) * tv%varT(i,j,k-1)) ) + drdjB = drdjB + 0.5 * ((drho_dT_dT_hr(i) * tv%varT(i,j+1,k)) - & + (drho_dT_dT_h(i) * tv%varT(i,j,k)) ) + endif hg2A = h(i,j,k-1)*h(i,j+1,k-1) + h_neglect2 hg2B = h(i,j,k)*h(i,j+1,k) + h_neglect2 @@ -369,7 +535,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & haL = 0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect haR = 0.5*(h(i,j+1,k-1) + h(i,j+1,k)) + h_neglect if (GV%Boussinesq) then - dzaL = haL * H_to_Z ; dzaR = haR * H_to_Z + dzaL = haL * GV%H_to_Z ; dzaR = haR * GV%H_to_Z else dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect dzaR = 0.5*(e(i,j+1,K-1) - e(i,j+1,K+1)) + dz_neglect @@ -380,12 +546,26 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & wtA = hg2A*haB ; wtB = hg2B*haA wtL = hg2L*(haR*dzaR) ; wtR = hg2R*(haL*dzaL) - drdz = (wtL * drdkL + wtR * drdkR) / (dzaL*wtL + dzaR*wtR) + drdz = ((wtL * drdkL) + (wtR * drdkR)) / ((dzaL*wtL) + (dzaR*wtR)) ! The expression for drdz above is mathematically equivalent to: ! drdz = ((hg2L/haL) * drdkL/dzaL + (hg2R/haR) * drdkR/dzaR) / & ! ((hg2L/haL) + (hg2R/haR)) - ! This is the gradient of density along geopotentials. - if (present_N2_v) N2_v(i,J,K) = G_Rho0 * drdz * G%mask2dCv(i,J) ! Square of buoyancy freq. [L2 Z-2 T-2 ~> s-2] + ! which is an estimate of the gradient of density across geopotentials. + if (present_N2_v) then + if (OBC_friendly) then ; if (OBC%segnum_v(i,J) /= 0) then + if (OBC%segnum_v(i,J) > 0) then ! OBC_DIRECTION_N + drdz = drdkL / dzaL ! Note that drdz is not used for slopes at OBC faces. + if (use_EOS .and. allocated(tv%SpV_avg)) & + GxSpV_v(i) = GV%g_Earth * 0.5 * (tv%SpV_avg(i,j,k) + tv%SpV_avg(i,j,k-1)) + elseif (OBC%segnum_v(i,J) < 0) then ! OBC_DIRECTION_S + drdz = drdkL / dzaL + if (use_EOS .and. allocated(tv%SpV_avg)) & + GxSpV_v(i) = GV%g_Earth * 0.5 * (tv%SpV_avg(i,j+1,k) + tv%SpV_avg(i,j+1,k-1)) + endif + endif ; endif + + N2_v(i,J,K) = GxSpV_v(i) * drdz * G%mask2dCv(i,J) ! Square of buoyancy freq. [L2 Z-2 T-2 ~> s-2] + endif if (use_EOS) then drdy = ((wtA * drdjA + wtB * drdjB) / (wtA + wtB) - & @@ -393,37 +573,36 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & ! This estimate of slope is accurate for small slopes, but bounded ! to be between -1 and 1. - mag_grad2 = (Z_to_L*drdy)**2 + drdz**2 + mag_grad2 = (US%Z_to_L*drdy)**2 + drdz**2 if (mag_grad2 > 0.0) then slope = drdy / sqrt(mag_grad2) else ! Just in case mag_grad2 = 0 ever. slope = 0.0 endif - - else ! With .not.use_EOS, the layers are constant density. - slope = (e(i,j,K)-e(i,j+1,K)) * G%IdyCv(i,J) + slope = (e(i,j+1,K)-e(i,j,K)) * G%IdyCv(i,J) endif + if (local_open_v_BC) then - l_seg = OBC%segnum_v(i,J) - if (l_seg /= OBC_NONE) then - if (OBC%segment(l_seg)%open) then + if (OBC%segnum_v(i,J) /= 0) then + if (OBC%segment(abs(OBC%segnum_v(i,J)))%open) then slope = 0. ! This and/or the masking code below is to make slopes match inside ! land mask. Might not be necessary except for DEBUG output. -! if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then +! if (OBC%segnum_v(i,J)) > 0) then ! OBC_DIRECTION_N ! slope_y(i,J+1,K) = 0. ! else ! slope_y(i,J-1,K) = 0. ! endif endif endif - slope = slope * max(g%mask2dT(i,j),g%mask2dT(i,j+1)) + slope = slope * max(G%mask2dT(i,j), G%mask2dT(i,j+1)) endif slope_y(i,J,K) = slope - if (present(dzSyN)) dzSyN(i,J,K) = sqrt( G_Rho0 * max(0., wtL * ( dzaL * drdkL ) & - + wtR * ( dzaR * drdkR )) / (wtL + wtR) ) & ! dz * N - * abs(slope) * G%mask2dCv(i,J) ! x-direction contribution to S^2 + if (present(dzSyN)) & + dzSyN(i,J,K) = sqrt( GxSpV_v(i) * max(0., (wtL * ( dzaL * drdkL )) & + + (wtR * ( dzaR * drdkR ))) / (wtL + wtR) ) & ! dz * N + * abs(slope) * G%mask2dCv(i,J) ! x-direction contribution to S^2 enddo ! i enddo ; enddo ! end of j-loop @@ -432,16 +611,17 @@ end subroutine calc_isoneutral_slopes !> Returns tracer arrays (nominally T and S) with massless layers filled with !! sensible values, by diffusing vertically with a small but constant diffusivity. -subroutine vert_fill_TS(h, T_in, S_in, kappa_dt, T_f, S_f, G, GV, halo_here, larger_h_denom) +subroutine vert_fill_TS(h, T_in, S_in, kappa_dt, T_f, S_f, G, GV, US, halo_here, larger_h_denom) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: T_in !< Input temperature [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: S_in !< Input salinity [ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: T_in !< Input temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: S_in !< Input salinity [S ~> ppt] real, intent(in) :: kappa_dt !< A vertical diffusivity to use for smoothing - !! times a smoothing timescale [Z2 ~> m2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T_f !< Filled temperature [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S_f !< Filled salinity [ppt] + !! times a smoothing timescale [H Z ~> m2 or kg m-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T_f !< Filled temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S_f !< Filled salinity [S ~> ppt] integer, optional, intent(in) :: halo_here !< Number of halo points to work on, !! 0 by default logical, optional, intent(in) :: larger_h_denom !< Present and true, add a large @@ -452,8 +632,9 @@ subroutine vert_fill_TS(h, T_in, S_in, kappa_dt, T_f, S_f, G, GV, halo_here, lar ! Local variables real :: ent(SZI_(G),SZK_(GV)+1) ! The diffusive entrainment (kappa*dt)/dz ! between layers in a timestep [H ~> m or kg m-2]. - real :: b1(SZI_(G)), d1(SZI_(G)) ! b1, c1, and d1 are variables used by the - real :: c1(SZI_(G),SZK_(GV)) ! tridiagonal solver. + real :: b1(SZI_(G)) ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1] + real :: d1(SZI_(G)) ! A variable used by the tridiagonal solver [nondim], d1 = 1 - c1. + real :: c1(SZI_(G),SZK_(GV)) ! A variable used by the tridiagonal solver [nondim]. real :: kap_dt_x2 ! The 2*kappa_dt converted to H units [H2 ~> m2 or kg2 m-4]. real :: h_neglect ! A negligible thickness [H ~> m or kg m-2], to allow for zero thicknesses. real :: h0 ! A negligible thickness to allow for zero thickness layers without @@ -468,10 +649,15 @@ subroutine vert_fill_TS(h, T_in, S_in, kappa_dt, T_f, S_f, G, GV, halo_here, lar is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo ; nz = GV%ke h_neglect = GV%H_subroundoff - kap_dt_x2 = (2.0*kappa_dt)*GV%Z_to_H**2 + ! The use of the fixed rescaling factor in the next line avoids an extra call to thickness_to_dz() + ! and the use of an extra 3-d array of vertical distnaces across layers (dz). This would be more + ! physically consistent, but it would also be more expensive, and given that this routine applies + ! a small (but arbitrary) amount of mixing to clean up the properties of nearly massless layers, + ! the added expense is hard to justify. + kap_dt_x2 = (2.0*kappa_dt) * (US%Z_to_m*GV%m_to_H) ! Usually the latter term is GV%Z_to_H. h0 = h_neglect if (present(larger_h_denom)) then - if (larger_h_denom) h0 = 1.0e-16*sqrt(kappa_dt)*GV%Z_to_H + if (larger_h_denom) h0 = 1.0e-16*sqrt(0.5*kap_dt_x2) endif if (kap_dt_x2 <= 0.0) then @@ -480,7 +666,7 @@ subroutine vert_fill_TS(h, T_in, S_in, kappa_dt, T_f, S_f, G, GV, halo_here, lar T_f(i,j,k) = T_in(i,j,k) ; S_f(i,j,k) = S_in(i,j,k) enddo ; enddo ; enddo else - !$OMP parallel do default(shared) private(ent,b1,d1,c1,h_tr) + !$OMP parallel do default(shared) private(ent,b1,d1,c1,h_tr) do j=js,je do i=is,ie ent(i,2) = kap_dt_x2 / ((h(i,j,1)+h(i,j,2)) + h0) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 2c3f016005..ee8d59cef3 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -1,32 +1,37 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Controls where open boundary conditions are applied module MOM_open_boundary -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_array_transform, only : rotate_array, rotate_array_pair -use MOM_array_transform, only : allocate_rotated_array -use MOM_coms, only : sum_across_PEs, Set_PElist, Get_PElist, PE_here, num_PEs +use MOM_coms, only : sum_across_PEs, any_across_PEs +use MOM_coms, only : Set_PElist, Get_PElist, PE_here, num_PEs use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_debugging, only : hchksum, uvchksum, chksum use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_domains, only : pass_var, pass_vector +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type use MOM_domains, only : To_All, EAST_FACE, NORTH_FACE, SCALAR_PAIR, CGRID_NE, CORNER +use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, NOTE, is_root_pe -use MOM_file_parser, only : get_param, log_version, param_file_type, log_param +use MOM_file_parser, only : get_param, log_version, param_file_type, read_param use MOM_grid, only : ocean_grid_type, hor_index_type -use MOM_dyn_horgrid, only : dyn_horgrid_type -use MOM_io, only : slasher, field_size, SINGLE_FILE +use MOM_interface_heights, only : thickness_to_dz +use MOM_interpolate, only : init_external_field, time_interp_external, time_interp_external_init +use MOM_interpolate, only : external_field +use MOM_io, only : slasher, field_size, file_exists, stderr, SINGLE_FILE use MOM_io, only : vardesc, query_vardesc, var_desc +use MOM_regridding, only : regridding_CS +use MOM_remapping, only : remappingSchemesDoc, remappingDefaultScheme, remapping_CS +use MOM_remapping, only : initialize_remapping, remapping_core_h, end_remapping use MOM_restart, only : register_restart_field, register_restart_pair -use MOM_restart, only : query_initialized, MOM_restart_CS -use MOM_obsolete_params, only : obsolete_logical, obsolete_int, obsolete_real, obsolete_char -use MOM_string_functions, only : extract_word, remove_spaces +use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS +use MOM_string_functions, only : extract_word, remove_spaces, uppercase, lowercase use MOM_tidal_forcing, only : astro_longitudes, astro_longitudes_init, eq_phase, nodal_fu, tidal_frequency -use MOM_time_manager, only : set_date, time_type, time_type_to_real, operator(-) +use MOM_time_manager, only : set_date, time_type, time_minus_signed use MOM_tracer_registry, only : tracer_type, tracer_registry_type, tracer_name_lookup -use MOM_interpolate, only : init_external_field, time_interp_external, time_interp_external_init -use MOM_remapping, only : remappingSchemesDoc, remappingDefaultScheme, remapping_CS -use MOM_remapping, only : initialize_remapping, remapping_core_h, end_remapping -use MOM_regridding, only : regridding_CS use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -37,66 +42,146 @@ module MOM_open_boundary public open_boundary_apply_normal_flow public open_boundary_config -public open_boundary_init +public open_boundary_setup_vert +public open_boundary_halo_update public open_boundary_query public open_boundary_end public open_boundary_impose_normal_slope public open_boundary_impose_land_mask public radiation_open_bdry_conds -public set_tracer_data +public read_OBC_segment_data public update_OBC_segment_data +public initialize_OBC_segment_reservoirs public open_boundary_test_extern_uv public open_boundary_test_extern_h public open_boundary_zero_normal_flow +public parse_segment_str public register_OBC, OBC_registry_init public register_file_OBC, file_OBC_end public segment_tracer_registry_init public segment_tracer_registry_end +public segment_thickness_reservoir_init public register_segment_tracer public register_temp_salt_segments +public register_obgc_segments public fill_temp_salt_segments +public fill_obgc_segments +public fill_thickness_segments +public set_obgc_segments_props +public setup_OBC_tracer_reservoirs +public setup_OBC_thickness_reservoirs public open_boundary_register_restarts +public copy_thickness_reservoirs public update_segment_tracer_reservoirs +public update_segment_thickness_reservoirs +public set_initialized_OBC_tracer_reservoirs public update_OBC_ramp +public remap_OBC_fields public rotate_OBC_config -public rotate_OBC_init +public rotate_OBC_segment_direction +public write_OBC_info, chksum_OBC_segments public initialize_segment_data +public flood_fill +public flood_fill2 integer, parameter, public :: OBC_NONE = 0 !< Indicates the use of no open boundary -integer, parameter, public :: OBC_SIMPLE = 1 !< Indicates the use of a simple inflow open boundary -integer, parameter, public :: OBC_WALL = 2 !< Indicates the use of a closed wall -integer, parameter, public :: OBC_FLATHER = 3 !< Indicates the use of a Flather open boundary -integer, parameter, public :: OBC_RADIATION = 4 !< Indicates the use of a radiation open boundary integer, parameter, public :: OBC_DIRECTION_N = 100 !< Indicates the boundary is an effective northern boundary integer, parameter, public :: OBC_DIRECTION_S = 200 !< Indicates the boundary is an effective southern boundary integer, parameter, public :: OBC_DIRECTION_E = 300 !< Indicates the boundary is an effective eastern boundary integer, parameter, public :: OBC_DIRECTION_W = 400 !< Indicates the boundary is an effective western boundary -integer, parameter :: MAX_OBC_FIELDS = 100 !< Maximum number of data fields needed for OBC segments +!>@{ Enumeration values for OBC relative vorticity configurations +integer, parameter, public :: OBC_VORTICITY_NONE = 0 +integer, parameter, public :: OBC_VORTICITY_ZERO = 1 +integer, parameter, public :: OBC_VORTICITY_FREESLIP = 2 +integer, parameter, public :: OBC_VORTICITY_COMPUTED = 3 +integer, parameter, public :: OBC_VORTICITY_SPECIFIED = 4 +!>@} +!>@{ Enumeration values for OBC strain configurations +integer, parameter, public :: OBC_STRAIN_NONE = 0 +integer, parameter, public :: OBC_STRAIN_ZERO = 1 +integer, parameter, public :: OBC_STRAIN_FREESLIP = 2 +integer, parameter, public :: OBC_STRAIN_COMPUTED = 3 +integer, parameter, public :: OBC_STRAIN_SPECIFIED = 4 +!>@} +integer, parameter :: NUM_PHYS_FIELDS = 13 !< Number of physical fields +!>@{ Indices of physical field positions in segment%field array +integer, parameter :: & + F_U = 1, F_V = 2, F_VX = 3, F_UY = 4, F_Z = 5, F_UAMP = 6, F_UPHASE = 7, & + F_VAMP = 8, F_VPHASE = 9, F_ZAMP = 10, F_ZPHASE = 11, F_T = 12, F_S = 13 +!>@} +character(len=8), parameter :: PHYS_FIELD_NAMES(NUM_PHYS_FIELDS) = & + [character(len=8) :: 'U', 'V', 'DVDX', 'DUDY', 'SSH', 'Uamp', & + 'Uphase', 'Vamp', 'Vphase', 'SSHamp', 'SSHphase', 'TEMP', 'SALT'] !< Physical field name + !! strings used by input parameter !> Open boundary segment data from files (mostly). type, public :: OBC_segment_data_type - integer :: fid !< handle from FMS associated with segment data on disk - integer :: fid_dz !< handle from FMS associated with segment thicknesses on disk - character(len=8) :: name !< a name identifier for the segment data - real, allocatable :: buffer_src(:,:,:) !< buffer for segment data located at cell faces - !! and on the original vertical grid - integer :: nk_src !< Number of vertical levels in the source data + type(external_field) :: handle !< handle from FMS associated with segment data on disk + type(external_field) :: dz_handle !< handle from FMS associated with segment thicknesses on disk + logical :: required = .false. !< True if this field is required + logical :: use_IO = .false. !< True if segment data is based on file input + character(len=32) :: name !< A name identifier for the segment data. When there is grid + !! rotation, this is the name on the rotated internal grid. + integer :: tr_index = -1 !< If this field is a tracer, its index in registry is stored here. + logical :: bgc_tracer !< True if this field is a BGC tracer + logical :: on_face !< If true, this field is discretized on the OBC segment + !! (velocity-point) faces, or if false it as the vorticiy points + real :: scale !< A scaling factor for converting input data to + !! the internal units of this field. For salinity this would + !! be in units of [S ppt-1 ~> 1] + real, allocatable :: buffer_src(:,:,:) !< buffer for segment data located at cell faces and on + !! the original vertical grid in the internally scaled + !! units for the field in question, such as [L T-1 ~> m s-1] + !! for a velocity or [S ~> ppt] for salinity. + integer :: nk_src !< Number of vertical levels in the source data real, allocatable :: dz_src(:,:,:) !< vertical grid cell spacing of the incoming segment - !! data, set in [Z ~> m] then scaled to [H ~> m or kg m-2] + !! data in [Z ~> m]. real, allocatable :: buffer_dst(:,:,:) !< buffer src data remapped to the target vertical grid - real :: value !< constant value if fid is equal to -1 + !! in the internally scaled units for the field in + !! question, such as [L T-1 ~> m s-1] for a velocity or + !! [S ~> ppt] for salinity. + real :: value !< A constant value for the inflow concentration if not read + !! from file, in the internal units of a field, such as [S ~> ppt] + !! for salinity. + real :: resrv_lfac_in = 1. !< The reservoir inverse length scale factor for the inward + !! direction per field [nondim]. The general 1/Lscale_in is + !! multiplied by this factor for a specific tracer or thickness. + real :: resrv_lfac_out= 1. !< The reservoir inverse length scale factor for the outward + !! direction per field [nondim]. The general 1/Lscale_out is + !! multiplied by this factor for a specific tracer or thickness. end type OBC_segment_data_type !> Tracer on OBC segment data structure, for putting into a segment tracer registry. type, public :: OBC_segment_tracer_type - real, allocatable :: t(:,:,:) !< tracer concentration array - real :: OBC_inflow_conc = 0.0 !< tracer concentration for generic inflows + real, allocatable :: t(:,:,:) !< tracer concentration array in rescaled units, + !! like [S ~> ppt] for salinity. + real :: OBC_inflow_conc = 0.0 !< tracer concentration for generic inflows in rescaled units, + !! like [S ~> ppt] for salinity. character(len=32) :: name !< tracer name used for error messages type(tracer_type), pointer :: Tr => NULL() !< metadata describing the tracer - real, allocatable :: tres(:,:,:) !< tracer reservoir array + real, allocatable :: tres(:,:,:) !< tracer reservoir array in rescaled units, + !! like [S ~> ppt] for salinity. + real :: scale !< A scaling factor for converting the units of input + !! data, like [S ppt-1 ~> 1] for salinity. logical :: is_initialized !< reservoir values have been set when True + integer :: ntr_index = -1 !< index of segment tracer in the global tracer registry + integer :: fd_index = -1 !< index of segment tracer in the input fields end type OBC_segment_tracer_type +!> Thickness on OBC segment data structure, with a reservoir +type, public :: OBC_segment_thickness_type + real, allocatable :: h(:,:,:) !< layer thickness array in rescaled units, [Z ~> m]. + real :: OBC_inflow_conc = 0.0 !< layer thickness for generic inflows in rescaled units, + !! [Z ~> m]. + character(len=32) :: name !< thickness name used for error messages + real, allocatable :: h_res(:,:,:) !< thickness reservoir array in rescaled units, + !! [Z ~> m]. + real :: scale !< A scaling factor for converting the units of input + !! data, [Z m-1 ~> 1]. + logical :: is_initialized !< reservoir values have been set when True + integer :: fd_index = -1 !< index of segment thickness in the input fields +end type OBC_segment_thickness_type + !> Registry type for tracers on segments type, public :: segment_tracer_registry_type integer :: ntseg = 0 !< number of registered tracer segments @@ -106,7 +191,8 @@ module MOM_open_boundary !! Not sure who should lock it or when... end type segment_tracer_registry_type -!> Open boundary segment data structure. +!> Open boundary segment data structure. Unless otherwise noted, 2-d and 3-d arrays are discretized +!! at the same position as normal velocity points in the middle of the OBC segments. type, public :: OBC_segment_type logical :: Flather !< If true, applies Flather + Chapman radiation of barotropic gravity waves. logical :: radiation !< If true, 1D Orlanksi radiation boundary conditions are applied. @@ -126,80 +212,81 @@ module MOM_open_boundary logical :: specified !< Boundary normal velocity fixed to external value. logical :: specified_tan !< Boundary tangential velocity fixed to external value. logical :: specified_grad !< Boundary gradient of tangential velocity fixed to external value. - logical :: open !< Boundary is open for continuity solver. + logical :: open !< Boundary is open for continuity solver, and there are no other + !! parameterized mass fluxes at the open boundary. logical :: gradient !< Zero gradient at boundary. - logical :: values_needed !< Whether or not any external OBC fields are needed. - logical :: u_values_needed !< Whether or not external u OBC fields are needed. - logical :: uamp_values_needed !< Whether or not external u amplitude OBC fields are needed. - logical :: uphase_values_needed !< Whether or not external u phase OBC fields are needed. - logical :: v_values_needed !< Whether or not external v OBC fields are needed. - logical :: vamp_values_needed !< Whether or not external v amplitude OBC fields are needed. - logical :: vphase_values_needed !< Whether or not external v phase OBC fields are needed. - logical :: t_values_needed!< Whether or not external T OBC fields are needed. - logical :: s_values_needed!< Whether or not external S OBC fields are needed. - logical :: z_values_needed!< Whether or not external zeta OBC fields are needed. - logical :: zamp_values_needed !< Whether or not external zeta amplitude OBC fields are needed. - logical :: zphase_values_needed !< Whether or not external zeta phase OBC fields are needed. - logical :: g_values_needed!< Whether or not external gradient OBC fields are needed. integer :: direction !< Boundary faces one of the four directions. logical :: is_N_or_S !< True if the OB is facing North or South and exists on this PE. logical :: is_E_or_W !< True if the OB is facing East or West and exists on this PE. logical :: is_E_or_W_2 !< True if the OB is facing East or West anywhere. type(OBC_segment_data_type), pointer :: field(:) => NULL() !< OBC data integer :: num_fields !< number of OBC data fields (e.g. u_normal,u_parallel and eta for Flather) - integer :: Is_obc !< i-indices of boundary segment. - integer :: Ie_obc !< i-indices of boundary segment. - integer :: Js_obc !< j-indices of boundary segment. - integer :: Je_obc !< j-indices of boundary segment. - integer :: uamp_index !< Save where uamp is in segment%field. - integer :: uphase_index !< Save where uphase is in segment%field. - integer :: vamp_index !< Save where vamp is in segment%field. - integer :: vphase_index !< Save where vphase is in segment%field. - integer :: zamp_index !< Save where zamp is in segment%field. - integer :: zphase_index !< Save where zphase is in segment%field. + integer :: Is_obc !< Starting local i-index of boundary segment, this may be outside of the local PE. + integer :: Ie_obc !< Ending local i-index of boundary segment, this may be outside of the local PE. + integer :: Js_obc !< Starting local j-index of boundary segment, this may be outside of the local PE. + integer :: Je_obc !< Ending local j-index of boundary segment, this may be outside of the local PE. real :: Velocity_nudging_timescale_in !< Nudging timescale on inflow [T ~> s]. real :: Velocity_nudging_timescale_out !< Nudging timescale on outflow [T ~> s]. logical :: on_pe !< true if any portion of the segment is located in this PE's data domain logical :: temp_segment_data_exists !< true if temperature data arrays are present logical :: salt_segment_data_exists !< true if salinity data arrays are present - real, allocatable :: Cg(:,:) !< The external gravity wave speed [L T-1 ~> m s-1] - !! at OBC-points. real, allocatable :: Htot(:,:) !< The total column thickness [H ~> m or kg m-2] at OBC-points. - real, allocatable :: h(:,:,:) !< The cell thickness [H ~> m or kg m-2] at OBC-points. + real, allocatable :: dZtot(:,:) !< The total column vertical extent [Z ~> m] at OBC segment faces. real, allocatable :: normal_vel(:,:,:) !< The layer velocity normal to the OB !! segment [L T-1 ~> m s-1]. - real, allocatable :: tangential_vel(:,:,:) !< The layer velocity tangential to the - !! OB segment [L T-1 ~> m s-1]. - real, allocatable :: tangential_grad(:,:,:) !< The gradient of the velocity tangential - !! to the OB segment [T-1 ~> s-1]. + real, allocatable :: tangential_vel(:,:,:) !< The layer velocity tangential to the OB segment + !! [L T-1 ~> m s-1], discretized at the corner points. + real, allocatable :: tangential_grad(:,:,:) !< The gradient of the velocity tangential to the OB + !! segment [T-1 ~> s-1], discretized at the corner points. real, allocatable :: normal_trans(:,:,:) !< The layer transport normal to the OB !! segment [H L2 T-1 ~> m3 s-1]. real, allocatable :: normal_vel_bt(:,:) !< The barotropic velocity normal to !! the OB segment [L T-1 ~> m s-1]. - real, allocatable :: eta(:,:) !< The sea-surface elevation along the - !! segment [H ~> m or kg m-2]. + real, allocatable :: normal_trans_bt(:,:) !< The barotropic transport normal + !! the OB segment [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, allocatable :: tidal_vn(:,:) !< The barotropic tidal velocity normal to + !! the OB segment [L T-1 ~> m s-1]. + real, allocatable :: tidal_vt(:,:) !< The barotropic tidal velocity tangential to + !! the OB segment [L T-1 ~> m s-1]. + real, allocatable :: SSH(:,:) !< The sea-surface elevation along the + !! segment [Z ~> m]. + real, allocatable :: tidal_elev(:,:) !< Tidal elevation at the OBC points [Z ~> m] real, allocatable :: grad_normal(:,:,:) !< The gradient of the normal flow along the - !! segment times the grid spacing [L T-1 ~> m s-1] + !! segment times the grid spacing [L T-1 ~> m s-1], + !! with the first index being the corner-point index + !! along the segment, and the second index being 1 (for + !! values one point into the domain) or 2 (for values + !! along the OBC itself) real, allocatable :: grad_tan(:,:,:) !< The gradient of the tangential flow along the - !! segment times the grid spacing [L T-1 ~> m s-1] - real, allocatable :: grad_gradient(:,:,:) !< The gradient of the gradient of tangential flow along - !! the segment times the grid spacing [T-1 ~> s-1] + !! segment times the grid spacing [L T-1 ~> m s-1], with the + !! first index being the velocity/tracer point index along the + !! segment, and the second being 1 for the value 1.5 points + !! inside the domain and 2 for the value half a point + !! inside the domain. + real, allocatable :: grad_gradient(:,:,:) !< The gradient normal to the segment of the gradient + !! tangetial to the segment of tangential flow along the segment + !! times the grid spacing [T-1 ~> s-1], with the first + !! index being the velocity/tracer point index along the segment, + !! and the second being 1 for the value 2 points into the domain + !! and 2 for the value 1 point into the domain. real, allocatable :: rx_norm_rad(:,:,:) !< The previous normal phase speed use for EW radiation !! OBC, in grid points per timestep [nondim] real, allocatable :: ry_norm_rad(:,:,:) !< The previous normal phase speed use for NS radiation !! OBC, in grid points per timestep [nondim] - real, allocatable :: rx_norm_obl(:,:,:) !< The previous normal radiation coefficient for EW - !! oblique OBCs [L2 T-2 ~> m2 s-2] - real, allocatable :: ry_norm_obl(:,:,:) !< The previous normal radiation coefficient for NS - !! oblique OBCs [L2 T-2 ~> m2 s-2] - real, allocatable :: cff_normal(:,:,:) !< The denominator for oblique radiation - !! for normal velocity [L2 T-2 ~> m2 s-2] + real, allocatable :: rx_norm_obl(:,:,:) !< The previous x-direction normalized radiation coefficient + !! for either EW or NS oblique OBCs [L2 T-2 ~> m2 s-2] + real, allocatable :: ry_norm_obl(:,:,:) !< The previous y-direction normalized radiation coefficient + !! for either EW or NS oblique OBCs [L2 T-2 ~> m2 s-2] + real, allocatable :: cff_normal(:,:,:) !< The denominator for oblique radiation of the normal + !! velocity [L2 T-2 ~> m2 s-2] real, allocatable :: nudged_normal_vel(:,:,:) !< The layer velocity normal to the OB segment !! that values should be nudged towards [L T-1 ~> m s-1]. real, allocatable :: nudged_tangential_vel(:,:,:) !< The layer velocity tangential to the OB segment - !! that values should be nudged towards [L T-1 ~> m s-1]. + !! that values should be nudged towards [L T-1 ~> m s-1], + !! discretized at the corner (PV) points. real, allocatable :: nudged_tangential_grad(:,:,:) !< The layer dvdx or dudy towards which nudging !! can occur [T-1 ~> s-1]. + type(OBC_segment_thickness_type), pointer :: h_Reg=> NULL()!< A pointer to the thickness for the segment. type(segment_tracer_registry_type), pointer :: tr_Reg=> NULL()!< A pointer to the tracer registry for the segment. type(hor_index_type) :: HI !< Horizontal index ranges real :: Tr_InvLscale_out !< An effective inverse length scale for restoring @@ -209,11 +296,19 @@ module MOM_open_boundary real :: Tr_InvLscale_in !< An effective inverse length scale for restoring !! the tracer concentration towards an externally !! imposed value when flow is entering [L-1 ~> m-1] + real :: Th_InvLscale_out !< An effective inverse length scale for restoring + !! the layer thickness in a fictitious + !! reservoir towards interior values when flow + !! is exiting the domain [L-1 ~> m-1] + real :: Th_InvLscale_in !< An effective inverse length scale for restoring + !! the layer thickness towards an externally + !! imposed value when flow is entering [L-1 ~> m-1] end type OBC_segment_type !> Open-boundary data type, public :: ocean_OBC_type integer :: number_of_segments = 0 !< The number of open-boundary segments. + logical :: reverse_segment_order = .false. !< If true, store the segments internally in the reversed order. integer :: ke = 0 !< The number of model layers logical :: open_u_BCs_exist_globally = .false. !< True if any zonal velocity points !! in the global domain use open BCs. @@ -237,21 +332,11 @@ module MOM_open_boundary logical :: user_BCs_set_globally = .false. !< True if any OBC_USER_CONFIG is set !! for input from user directory. logical :: update_OBC = .false. !< Is OBC data time-dependent - logical :: needs_IO_for_data = .false. !< Is any i/o needed for OBCs - logical :: zero_vorticity = .false. !< If True, sets relative vorticity to zero on open boundaries. - logical :: freeslip_vorticity = .false. !< If True, sets normal gradient of tangential velocity to zero - !! in the relative vorticity on open boundaries. - logical :: computed_vorticity = .false. !< If True, uses external data for tangential velocity - !! in the relative vorticity on open boundaries. - logical :: specified_vorticity = .false. !< If True, uses external data for tangential velocity - !! gradients in the relative vorticity on open boundaries. - logical :: zero_strain = .false. !< If True, sets strain to zero on open boundaries. - logical :: freeslip_strain = .false. !< If True, sets normal gradient of tangential velocity to zero - !! in the strain on open boundaries. - logical :: computed_strain = .false. !< If True, uses external data for tangential velocity to compute - !! normal gradient in the strain on open boundaries. - logical :: specified_strain = .false. !< If True, uses external data for tangential velocity gradients - !! to compute strain on open boundaries. + logical :: update_OBC_seg_data = .false. !< Is it the time for OBC segment data update for fields that + !! require less frequent update + logical :: any_needs_IO_for_data = .false. !< Is any i/o needed for OBCs globally + integer :: vorticity_config !< An integer indicating OBC relative vorticity configuration + integer :: strain_config !< An integer indicating OBC strain configuration logical :: zero_biharmonic = .false. !< If True, zeros the Laplacian of flow on open boundaries for !! use in the biharmonic viscosity term. logical :: brushcutter_mode = .false. !< If True, read data on supergrid. @@ -259,12 +344,15 @@ module MOM_open_boundary !! true for those with x reservoirs (needed for restarts). logical, allocatable :: tracer_y_reservoirs_used(:) !< Dimensioned by the number of tracers, set globally, !! true for those with y reservoirs (needed for restarts). + logical :: thickness_x_reservoirs_used = .false. !< True for thichness reservoirs in x (needed for restarts). + logical :: thickness_y_reservoirs_used = .false. !< True for thichness reservoirs in y (needed for restarts). integer :: ntr = 0 !< number of tracers integer :: n_tide_constituents = 0 !< Number of tidal constituents to add to the boundary. logical :: add_tide_constituents = .false. !< If true, add tidal constituents to the boundary elevation !! and velocity. Will be set to true if n_tide_constituents > 0. character(len=2), allocatable, dimension(:) :: tide_names !< Names of tidal constituents to add to the boundary data. - real, allocatable, dimension(:) :: tide_frequencies !< Angular frequencies of chosen tidal constituents [T-1 ~> s-1]. + real, allocatable, dimension(:) :: tide_frequencies !< Angular frequencies of chosen tidal + !! constituents [rad T-1 ~> rad s-1]. real, allocatable, dimension(:) :: tide_eq_phases !< Equilibrium phases of chosen tidal constituents [rad]. real, allocatable, dimension(:) :: tide_fn !< Amplitude modulation of boundary tides by nodal cycle [nondim]. real, allocatable, dimension(:) :: tide_un !< Phase modulation of boundary tides by nodal cycle [rad]. @@ -277,8 +365,15 @@ module MOM_open_boundary ! Properties of the segments used. type(OBC_segment_type), allocatable :: segment(:) !< List of segment objects. ! Which segment object describes the current point. - integer, allocatable :: segnum_u(:,:) !< Segment number of u-points. - integer, allocatable :: segnum_v(:,:) !< Segment number of v-points. + integer, allocatable :: segnum_u(:,:) !< The absolute value gives the segment number of any OBCs at u-points, + !! while the sign indicates whether they are Eastern (> 0) or Western (< 0) + !! OBCs, with 0 for velocities that are not on an OBC. + integer, allocatable :: segnum_v(:,:) !< The absolute value gives the segment number of any OBCs at v-points, + !! while the sign indicates whether they are Northern (> 0) or Southern (< 0) + !! OBCs, with 0 for velocities that are not on an OBC. + ! Keep the OBC segment properties for external BGC tracers + type(external_tracers_segments_props), pointer :: obgc_segments_props => NULL() !< obgc segment properties + integer :: num_obgc_tracers = 0 !< The total number of obgc tracers ! The following parameters are used in the baroclinic radiation code: real :: gamma_uv !< The relative weighting for the baroclinic radiation @@ -288,19 +383,53 @@ 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 + logical :: u_OBCs_on_PE !< True if there are any u-point OBCs on this PE, including in its halos. + logical :: v_OBCs_on_PE !< True if there are any v-point OBCs on this PE, including in its halos. + logical :: v_N_OBCs_on_PE !< True if there are any northern v-point OBCs on this PE, including in its halos. + logical :: v_S_OBCs_on_PE !< True if there are any southern v-point OBCs on this PE, including in its halos. + logical :: u_E_OBCs_on_PE !< True if there are any eastern u-point OBCs on this PE, including in its halos. + logical :: u_W_OBCs_on_PE !< True if there are any western u-point OBCs on this PE, including in its halos. + !>@{ Index ranges on the local PE for the open boundary conditions in various directions + integer :: Is_u_W_obc, Ie_u_W_obc, js_u_W_obc, je_u_W_obc + integer :: Is_u_E_obc, Ie_u_E_obc, js_u_E_obc, je_u_E_obc + integer :: is_v_S_obc, ie_v_S_obc, Js_v_S_obc, Je_v_S_obc + integer :: is_v_N_obc, ie_v_N_obc, Js_v_N_obc, Je_v_N_obc + !>@} + 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] - real, allocatable :: ry_normal(:,:,:) !< Array storage for normal phase speed for NS radiation OBCs in units of - !! grid points per timestep [nondim] - real, allocatable :: rx_oblique(:,:,:) !< Array storage for oblique boundary condition restarts [L2 T-2 ~> m2 s-2] - real, allocatable :: ry_oblique(:,:,:) !< Array storage for oblique boundary condition restarts [L2 T-2 ~> m2 s-2] - real, allocatable :: cff_normal(:,:,:) !< Array storage for oblique boundary condition restarts [L2 T-2 ~> m2 s-2] - real, allocatable :: tres_x(:,:,:,:) !< Array storage of tracer reservoirs for restarts [conc L ~> conc m] - real, allocatable :: tres_y(:,:,:,:) !< Array storage of tracer reservoirs for restarts [conc L ~> conc m] + real, allocatable :: rx_normal(:,:,:) !< Array storage for normal phase speed for EW radiation OBCs + !! in units of grid points per timestep [nondim] + real, allocatable :: ry_normal(:,:,:) !< Array storage for normal phase speed for NS radiation OBCs + !! in units of grid points per timestep [nondim] + real, allocatable :: rx_oblique_u(:,:,:) !< X-direction oblique boundary condition radiation speeds + !! squared at u points for restarts [L2 T-2 ~> m2 s-2] + real, allocatable :: ry_oblique_u(:,:,:) !< Y-direction oblique boundary condition radiation speeds + !! squared at u points for restarts [L2 T-2 ~> m2 s-2] + real, allocatable :: rx_oblique_v(:,:,:) !< X-direction oblique boundary condition radiation speeds + !! squared at v points for restarts [L2 T-2 ~> m2 s-2] + real, allocatable :: ry_oblique_v(:,:,:) !< Y-direction oblique boundary condition radiation speeds + !! squared at v points for restarts [L2 T-2 ~> m2 s-2] + real, allocatable :: cff_normal_u(:,:,:) !< Denominator for normalizing EW oblique boundary condition + !! radiation rates at u points for restarts [L2 T-2 ~> m2 s-2] + real, allocatable :: cff_normal_v(:,:,:) !< Denominator for normalizing NS oblique boundary condition + !! radiation rates at v points for restarts [L2 T-2 ~> m2 s-2] + real, allocatable :: tres_x(:,:,:,:) !< Array storage of tracer reservoirs for restarts, + !! in unscaled units [conc] + real, allocatable :: tres_y(:,:,:,:) !< Array storage of tracer reservoirs for restarts, + !! in unscaled units [conc] + real, allocatable :: h_res_x(:,:,:) !< Array storage of thickness reservoirs for restarts, + !! [Z ~> m] + real, allocatable :: h_res_y(:,:,:) !< Array storage of thickness reservoirs for restarts, + !! [Z ~> m] + logical :: use_h_res = .false. !< If true, use thickness reservoirs + logical :: debug !< If true, write verbose checksums for debugging purposes. + integer :: nk_OBC_debug = 0 !< The number of layers of OBC segment data to write out + !! in full when DEBUG_OBCS is true. real :: silly_h !< A silly value of thickness outside of the domain that can be used to test - !! the independence of the OBCs to this external data [H ~> m or kg m-2]. + !! the independence of the OBCs to this external data [Z ~> m]. real :: silly_u !< A silly value of velocity outside of the domain that can be used to test !! the independence of the OBCs to this external data [L T-1 ~> m s-1]. logical :: ramp = .false. !< If True, ramp from zero to the external values for SSH. @@ -310,12 +439,30 @@ module MOM_open_boundary real :: ramp_value !< If ramp is True, where we are on the ramp from !! zero to one [nondim]. type(time_type) :: ramp_start_time !< Time when model was started. + integer :: 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. + 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 + logical :: exterior_OBC_bug !< If true, use incorrect form of tracers exterior to OBCs. + logical :: hor_index_bug !< If true, recover set of a horizontal indexing bugs in the OBC code. + logical :: reservoir_init_bug !< If true, set the OBC tracer reservoirs at the startup of a new + !! run from the interior tracer concentrations regardless of + !! properties that may be explicitly specified for the reservoir + !! concentrations. + logical :: ts_needed_bug !< If true, recover a bug that temperature and salinity can be ignored + !! even if they are registered tracers in the rest of the model. end type ocean_OBC_type !> Control structure for open boundaries that read from files. !! Probably lots to update here. type, public :: file_OBC_CS ; private - real :: tide_flow = 3.0e6 !< Placeholder for now... + logical :: OBC_file_used = .false. !< Placeholder for now to avoid an empty type. end type file_OBC_CS !> Type to carry something (what??) for the OBC registry. @@ -331,6 +478,15 @@ module MOM_open_boundary !! When locked=.true.,no more boundaries can be registered. end type OBC_registry_type +!> Type to carry OBC information needed for setting segments for OBGC tracers +type, private :: external_tracers_segments_props + type(external_tracers_segments_props), pointer :: next => NULL() !< pointer to the next node + character(len=128) :: tracer_name !< tracer name + character(len=128) :: tracer_src_file !< tracer source file for BC + character(len=128) :: tracer_src_field !< name of the field in source file to extract BC + real :: lfac_in !< multiplicative factor for inbound tracer reservoir length scale [nondim] + real :: lfac_out !< multiplicative factor for outbound tracer reservoir length scale [nondim] +end type external_tracers_segments_props integer :: id_clock_pass !< A CPU time clock character(len=40) :: mdl = "MOM_open_boundary" !< This module's name. @@ -338,12 +494,11 @@ module MOM_open_boundary contains !> Enables OBC module and reads configuration parameters -!> This routine is called from MOM_initialize_fixed which -!> occurs before the initialization of the vertical coordinate -!> 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 - +!! This routine is called from MOM_initialize_fixed which +!! occurs before the initialization of the vertical coordinate +!! 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 @@ -351,276 +506,409 @@ subroutine open_boundary_config(G, US, param_file, OBC) type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure ! Local variables - integer :: l ! For looping over segments - logical :: debug_OBC, debug, mask_outside, reentrant_x, reentrant_y + integer :: num_of_segs ! Number of open boundary segments + integer :: n, n_seg ! For looping over segments + logical :: debug, mask_outside, reentrant_x, reentrant_y character(len=15) :: segment_param_str ! The run-time parameter name for each segment character(len=1024) :: segment_str ! The contents (rhs) for parameter "segment_param_str" - character(len=200) :: config1 ! String for OBC_USER_CONFIG + character(len=200) :: config ! A string to temporarily store a few runtime parameters real :: Lscale_in, Lscale_out ! parameters controlling tracer values at the boundaries [L ~> m] - character(len=128) :: inputdir - logical :: answers_2018, default_2018_answers - logical :: check_reconstruction, check_remapping, force_bounds_in_subcell - character(len=32) :: remappingScheme -! This include declares and sets the variable "version". + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. + logical :: debugging_tests ! If true, do additional calls resetting values to help debug the performance + ! of the open boundary condition code. + logical :: obsolete_param_set, param_set + logical :: zero_vorticity, freeslip_vorticity, computed_vorticity, specified_vorticity + logical :: zero_strain, freeslip_strain, computed_strain, specified_strain + ! This include declares and sets the variable "version". # include "version_variable.h" - allocate(OBC) + call log_version(param_file, mdl, version, "Controls where open boundaries are located, "//& + "what kind of boundary condition to impose, and what data to apply, if any.", & + all_default=.false.) + ! Parameter OBC_NUMBER_OF_SEGMENTS is always logged. + call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", num_of_segs, & + "The number of open boundary segments.", default=0) + if (num_of_segs <= 0) & ! Do nothing if there is no OBC segments + return - call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", OBC%number_of_segments, & - default=0, do_not_log=.true.) - call log_version(param_file, mdl, version, & - "Controls where open boundaries are located, what kind of boundary condition "//& - "to impose, and what data to apply, if any.", & - all_default=(OBC%number_of_segments<=0)) - call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", OBC%number_of_segments, & - "The number of open boundary segments.", & - default=0) - call get_param(param_file, mdl, "OBC_USER_CONFIG", config1, & + allocate(OBC) + OBC%number_of_segments = num_of_segs + call get_param(param_file, mdl, "OBC_USER_CONFIG", config, & "A string that sets how the open boundary conditions are "//& " configured: \n", default="none", do_not_log=.true.) call get_param(param_file, mdl, "NK", OBC%ke, & "The number of model layers", default=0, do_not_log=.true.) - if (config1 /= "none" .and. config1 /= "dyed_obcs") OBC%user_BCs_set_globally = .true. - - if (OBC%number_of_segments > 0) then - call get_param(param_file, mdl, "OBC_ZERO_VORTICITY", OBC%zero_vorticity, & - "If true, sets relative vorticity to zero on open boundaries.", & - default=.false.) - call get_param(param_file, mdl, "OBC_FREESLIP_VORTICITY", OBC%freeslip_vorticity, & - "If true, sets the normal gradient of tangential velocity to "//& - "zero in the relative vorticity on open boundaries. This cannot "//& - "be true if another OBC_XXX_VORTICITY option is True.", default=.true.) - call get_param(param_file, mdl, "OBC_COMPUTED_VORTICITY", OBC%computed_vorticity, & - "If true, uses the external values of tangential velocity "//& - "in the relative vorticity on open boundaries. This cannot "//& - "be true if another OBC_XXX_VORTICITY option is True.", default=.false.) - call get_param(param_file, mdl, "OBC_SPECIFIED_VORTICITY", OBC%specified_vorticity, & - "If true, uses the external values of tangential velocity "//& - "in the relative vorticity on open boundaries. This cannot "//& - "be true if another OBC_XXX_VORTICITY option is True.", default=.false.) - if ((OBC%zero_vorticity .and. OBC%freeslip_vorticity) .or. & - (OBC%zero_vorticity .and. OBC%computed_vorticity) .or. & - (OBC%zero_vorticity .and. OBC%specified_vorticity) .or. & - (OBC%freeslip_vorticity .and. OBC%computed_vorticity) .or. & - (OBC%freeslip_vorticity .and. OBC%specified_vorticity) .or. & - (OBC%computed_vorticity .and. OBC%specified_vorticity)) & - call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config:\n"//& - "Only one of OBC_ZERO_VORTICITY, OBC_FREESLIP_VORTICITY, OBC_COMPUTED_VORTICITY\n"//& - "and OBC_IMPORTED_VORTICITY can be True at once.") - call get_param(param_file, mdl, "OBC_ZERO_STRAIN", OBC%zero_strain, & - "If true, sets the strain used in the stress tensor to zero on open boundaries.", & - default=.false.) - call get_param(param_file, mdl, "OBC_FREESLIP_STRAIN", OBC%freeslip_strain, & - "If true, sets the normal gradient of tangential velocity to "//& - "zero in the strain use in the stress tensor on open boundaries. This cannot "//& - "be true if another OBC_XXX_STRAIN option is True.", default=.true.) - call get_param(param_file, mdl, "OBC_COMPUTED_STRAIN", OBC%computed_strain, & - "If true, sets the normal gradient of tangential velocity to "//& - "zero in the strain use in the stress tensor on open boundaries. This cannot "//& - "be true if another OBC_XXX_STRAIN option is True.", default=.false.) - call get_param(param_file, mdl, "OBC_SPECIFIED_STRAIN", OBC%specified_strain, & - "If true, sets the normal gradient of tangential velocity to "//& - "zero in the strain use in the stress tensor on open boundaries. This cannot "//& - "be true if another OBC_XXX_STRAIN option is True.", default=.false.) - if ((OBC%zero_strain .and. OBC%freeslip_strain) .or. & - (OBC%zero_strain .and. OBC%computed_strain) .or. & - (OBC%zero_strain .and. OBC%specified_strain) .or. & - (OBC%freeslip_strain .and. OBC%computed_strain) .or. & - (OBC%freeslip_strain .and. OBC%specified_strain) .or. & - (OBC%computed_strain .and. OBC%specified_strain)) & - call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config: \n"//& - "Only one of OBC_ZERO_STRAIN, OBC_FREESLIP_STRAIN, OBC_COMPUTED_STRAIN \n"//& - "and OBC_IMPORTED_STRAIN can be True at once.") - call get_param(param_file, mdl, "OBC_ZERO_BIHARMONIC", OBC%zero_biharmonic, & - "If true, zeros the Laplacian of flow on open boundaries in the biharmonic "//& - "viscosity term.", default=.false.) - call get_param(param_file, mdl, "MASK_OUTSIDE_OBCS", mask_outside, & - "If true, set the areas outside open boundaries to be land.", & - default=.false.) - call get_param(param_file, mdl, "RAMP_OBCS", OBC%ramp, & - "If true, ramps from zero to the external values over time, with"//& - "a ramping timescale given by RAMP_TIMESCALE. Ramping SSH only so far", & - default=.false.) - call get_param(param_file, mdl, "OBC_RAMP_TIMESCALE", OBC%ramp_timescale, & - "If RAMP_OBCS is true, this sets the ramping timescale.", & - units="days", default=1.0, scale=86400.0*US%s_to_T) - call get_param(param_file, mdl, "OBC_TIDE_N_CONSTITUENTS", OBC%n_tide_constituents, & - "Number of tidal constituents being added to the open boundary.", & - default=0) - - if (OBC%n_tide_constituents > 0) then - OBC%add_tide_constituents = .true. + if (config /= "none" .and. config /= "dyed_obcs") OBC%user_BCs_set_globally = .true. + + ! Configuration for OBC relative vorticity. + ! Old setup method + obsolete_param_set = .false. + zero_vorticity = .false. + call read_param(param_file, "OBC_ZERO_VORTICITY", zero_vorticity, set=param_set) + obsolete_param_set = obsolete_param_set .or. param_set + freeslip_vorticity = .true. + call read_param(param_file, "OBC_FREESLIP_VORTICITY", freeslip_vorticity, set=param_set) + obsolete_param_set = obsolete_param_set .or. param_set + computed_vorticity = .false. + call read_param(param_file, "OBC_COMPUTED_VORTICITY", computed_vorticity, set=param_set) + obsolete_param_set = obsolete_param_set .or. param_set + specified_vorticity = .false. + call read_param(param_file, "OBC_SPECIFIED_VORTICITY", specified_vorticity, set=param_set) + obsolete_param_set = obsolete_param_set .or. param_set + if (obsolete_param_set) then + call MOM_error(WARNING, 'OBC_ZERO_VORTICITY, OBC_FREESLIP_VORTICITY, OBC_COMPUTED_VORTICITY'//& + ' and OBC_SPECIFIED_VORTICITY are obsolete, use OBC_VORTICITY_CONFIG instead.') + if ((zero_vorticity .and. freeslip_vorticity) .or. & + (zero_vorticity .and. computed_vorticity) .or. & + (zero_vorticity .and. specified_vorticity) .or. & + (freeslip_vorticity .and. computed_vorticity) .or. & + (freeslip_vorticity .and. specified_vorticity) .or. & + (computed_vorticity .and. specified_vorticity)) & + call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config:\n"//& + "Only one of OBC_ZERO_VORTICITY, OBC_FREESLIP_VORTICITY, OBC_COMPUTED_VORTICITY\n"//& + "and OBC_IMPORTED_VORTICITY can be True at once.") + ! "config" is set from OBC_XXX_VORTICITY if they are used. + if (zero_vorticity) then + config = 'zero' + elseif (freeslip_vorticity) then + config = 'freeslip' + elseif (computed_vorticity) then + config = 'computed' + elseif (specified_vorticity) then + config = 'specified' else - OBC%add_tide_constituents = .false. + config = 'none' endif + else + config = 'freeslip' ! Default + endif + ! New setup method (overrides old method if specified) + call read_param(param_file, "OBC_VORTICITY_CONFIG", config) + call get_param(param_file, mdl, "OBC_VORTICITY_CONFIG", config, & + "Configuration for relative vorticity in momentum advection at open "//& + "boundaries. Options are: \n"// & + " \t none - No adjustment.\n"//& + " \t zero - Sets relative vorticity to zero.\n"//& + " \t freeslip - Sets the normal gradient of tangential velocity to zero.\n"//& + " \t computed - Computes the normal gradient of tangential velocity using\n"//& + " \t external values of tangential velocity.\n"//& + " \t specified - Uses the external values of the normal gradient of\n"//& + " \t tangential velocity.", default="freeslip", do_not_read=.true.) + select case (trim(config)) + case ("none") ; OBC%vorticity_config = OBC_VORTICITY_NONE + case ("zero") ; OBC%vorticity_config = OBC_VORTICITY_ZERO + case ("freeslip") ; OBC%vorticity_config = OBC_VORTICITY_FREESLIP + case ("computed") ; OBC%vorticity_config = OBC_VORTICITY_COMPUTED + case ("specified") ; OBC%vorticity_config = OBC_VORTICITY_SPECIFIED + case default + call MOM_error(FATAL, "MOM_open_boundary: Unrecognized OBC_VORTICITY_CONFIG: "//trim(config)) + end select - call get_param(param_file, mdl, "DEBUG", debug, default=.false.) - call get_param(param_file, mdl, "DEBUG_OBC", debug_OBC, default=.false.) - if (debug_OBC .or. debug) & - call log_param(param_file, mdl, "DEBUG_OBC", debug_OBC, & - "If true, do additional calls to help debug the performance "//& - "of the open boundary condition code.", default=.false., & - debuggingParam=.true.) + ! Configuration for OBC strain. + ! Old setup method + obsolete_param_set = .false. + zero_strain = .false. + call read_param(param_file, "OBC_ZERO_STRAIN", zero_strain, set=param_set) + obsolete_param_set = obsolete_param_set .or. param_set + freeslip_strain = .true. + call read_param(param_file, "OBC_FREESLIP_STRAIN", freeslip_strain, set=param_set) + obsolete_param_set = obsolete_param_set .or. param_set + computed_strain = .false. + call read_param(param_file, "OBC_COMPUTED_STRAIN", computed_strain, set=param_set) + obsolete_param_set = obsolete_param_set .or. param_set + specified_strain = .false. + call read_param(param_file, "OBC_SPECIFIED_STRAIN", specified_strain, set=param_set) + obsolete_param_set = obsolete_param_set .or. param_set + if (obsolete_param_set) then + call MOM_error(WARNING, 'OBC_ZERO_STRAIN, OBC_FREESLIP_STRAIN, OBC_COMPUTED_STRAIN'//& + ' and OBC_SPECIFIED_STRAIN are obsolete, use OBC_STRAIN_CONFIG instead.') + if ((zero_strain .and. freeslip_strain) .or. & + (zero_strain .and. computed_strain) .or. & + (zero_strain .and. specified_strain) .or. & + (freeslip_strain .and. computed_strain) .or. & + (freeslip_strain .and. specified_strain) .or. & + (computed_strain .and. specified_strain)) & + call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config: \n"//& + "Only one of OBC_ZERO_STRAIN, OBC_FREESLIP_STRAIN, OBC_COMPUTED_STRAIN \n"//& + "and OBC_IMPORTED_STRAIN can be True at once.") + ! "config" is set from OBC_XXX_STRAIN if they are used. + if (zero_strain) then + config = 'zero' + elseif (freeslip_strain) then + config = 'freeslip' + elseif (computed_strain) then + config = 'computed' + elseif (specified_strain) then + config = 'specified' + else + config = 'none' + endif + else + config = 'freeslip' ! Default + endif + ! New setup method (overrides old method if specified) + call read_param(param_file, "OBC_STRAIN_CONFIG", config) + call get_param(param_file, mdl, "OBC_STRAIN_CONFIG", config, & + "Configuration for strain in horizontal viscosity at open boundaries. "//& + "Options are: \n"// & + " \t none - No adjustment.\n"//& + " \t zero - Sets strain to zero.\n"//& + " \t freeslip - Sets the normal gradient of tangential velocity to zero.\n"//& + " \t computed - Computes the normal gradient of tangential velocity using\n"//& + " \t external values of tangential velocity.\n"//& + " \t specified - Uses the external values of the normal gradient of\n"//& + " \t tangential velocity.", default="freeslip", do_not_read=.true.) + select case (trim(config)) + case ("none") ; OBC%strain_config = OBC_STRAIN_NONE + case ("zero") ; OBC%strain_config = OBC_STRAIN_ZERO + case ("freeslip") ; OBC%strain_config = OBC_STRAIN_FREESLIP + case ("computed") ; OBC%strain_config = OBC_STRAIN_COMPUTED + case ("specified") ; OBC%strain_config = OBC_STRAIN_SPECIFIED + case default + call MOM_error(FATAL, "MOM_open_boundary: Unrecognized OBC_STRAIN_CONFIG: "//trim(config)) + end select - call get_param(param_file, mdl, "OBC_SILLY_THICK", OBC%silly_h, & + call get_param(param_file, mdl, "OBC_ZERO_BIHARMONIC", OBC%zero_biharmonic, & + "If true, zeros the Laplacian of flow on open boundaries in the biharmonic "//& + "viscosity term.", default=.false.) + call get_param(param_file, mdl, "MASK_OUTSIDE_OBCS", mask_outside, & + "If true, set the areas outside open boundaries to be land.", & + default=.false.) + call get_param(param_file, mdl, "RAMP_OBCS", OBC%ramp, & + "If true, ramps from zero to the external values over time, with "//& + "a ramping timescale given by RAMP_TIMESCALE. Ramping SSH only so far.", & + default=.false.) + call get_param(param_file, mdl, "OBC_RAMP_TIMESCALE", OBC%ramp_timescale, & + "If RAMP_OBCS is true, this sets the ramping timescale.", & + units="days", default=1.0, scale=86400.0*US%s_to_T) + call get_param(param_file, mdl, "OBC_TIDE_N_CONSTITUENTS", OBC%n_tide_constituents, & + "Number of tidal constituents being added to the open boundary.", & + default=0) + OBC%add_tide_constituents = (OBC%n_tide_constituents > 0) + + call get_param(param_file, mdl, "DEBUG", debug, default=.false.) + call get_param(param_file, mdl, "DEBUG_OBCS", OBC%debug, & + "If true, do additional calls to help debug the performance "//& + "of the open boundary condition code.", & + default=.false., debuggingParam=.true.) + if (OBC%debug .and. (num_PEs() > 1)) & + call MOM_error(FATAL, "DEBUG_OBCS = True is currently only supported for single PE runs.") + call get_param(param_file, mdl, "OBC_DEBUGGING_TESTS", debugging_tests, & + "If true, do additional calls resetting certain values to help verify the correctness "//& + "of the open boundary condition code.", & + default=.false., old_name="DEBUG_OBC", debuggingParam=.true.) + call get_param(param_file, mdl, "NK_OBC_DEBUG", OBC%nk_OBC_debug, & + "The number of layers of OBC segment data to write out in full "//& + "when DEBUG_OBCS is true.", & + default=0, debuggingParam=.true., do_not_log=.not.OBC%debug) + call get_param(param_file, mdl, "OBC_REVERSE_SEGMENT_ORDER", OBC%reverse_segment_order, & + "If true, store the OBC segments internally and handle them in the reverse "//& + "order from that with which they are specified via external parameters to test "//& + "for dependencies on the order with which the OBC segments are applied.", & + default=.false., debuggingParam=.true., do_not_log=(OBC%number_of_segments<2)) + + call get_param(param_file, mdl, "OBC_SILLY_THICK", OBC%silly_h, & "A silly value of thicknesses used outside of open boundary "//& "conditions for debugging.", units="m", default=0.0, scale=US%m_to_Z, & - do_not_log=.not.debug_OBC, debuggingParam=.true.) - call get_param(param_file, mdl, "OBC_SILLY_VEL", OBC%silly_u, & + do_not_log=.not.debugging_tests, debuggingParam=.true.) + call get_param(param_file, mdl, "OBC_SILLY_VEL", OBC%silly_u, & "A silly value of velocities used outside of open boundary "//& "conditions for debugging.", units="m/s", default=0.0, scale=US%m_s_to_L_T, & - do_not_log=.not.debug_OBC, debuggingParam=.true.) - reentrant_x = .false. - call get_param(param_file, mdl, "REENTRANT_X", reentrant_x, default=.true.) - reentrant_y = .false. - call get_param(param_file, mdl, "REENTRANT_Y", reentrant_y, default=.false.) - - ! Allocate everything - allocate(OBC%segment(1:OBC%number_of_segments)) - do l=1,OBC%number_of_segments - OBC%segment(l)%Flather = .false. - OBC%segment(l)%radiation = .false. - OBC%segment(l)%radiation_tan = .false. - OBC%segment(l)%radiation_grad = .false. - OBC%segment(l)%oblique = .false. - OBC%segment(l)%oblique_tan = .false. - OBC%segment(l)%oblique_grad = .false. - OBC%segment(l)%nudged = .false. - OBC%segment(l)%nudged_tan = .false. - OBC%segment(l)%nudged_grad = .false. - OBC%segment(l)%specified = .false. - OBC%segment(l)%specified_tan = .false. - OBC%segment(l)%specified_grad = .false. - OBC%segment(l)%open = .false. - OBC%segment(l)%gradient = .false. - OBC%segment(l)%values_needed = .false. - OBC%segment(l)%u_values_needed = .false. - OBC%segment(l)%uamp_values_needed = OBC%add_tide_constituents - OBC%segment(l)%uphase_values_needed = OBC%add_tide_constituents - OBC%segment(l)%v_values_needed = .false. - OBC%segment(l)%vamp_values_needed = OBC%add_tide_constituents - OBC%segment(l)%vphase_values_needed = OBC%add_tide_constituents - OBC%segment(l)%t_values_needed = .false. - OBC%segment(l)%s_values_needed = .false. - OBC%segment(l)%z_values_needed = .false. - OBC%segment(l)%zamp_values_needed = OBC%add_tide_constituents - OBC%segment(l)%zphase_values_needed = OBC%add_tide_constituents - OBC%segment(l)%g_values_needed = .false. - OBC%segment(l)%direction = OBC_NONE - OBC%segment(l)%is_N_or_S = .false. - OBC%segment(l)%is_E_or_W = .false. - OBC%segment(l)%is_E_or_W_2 = .false. - OBC%segment(l)%Velocity_nudging_timescale_in = 0.0 - OBC%segment(l)%Velocity_nudging_timescale_out = 0.0 - OBC%segment(l)%num_fields = 0 - enddo - allocate(OBC%segnum_u(G%IsdB:G%IedB,G%jsd:G%jed), source=OBC_NONE) - allocate(OBC%segnum_v(G%isd:G%ied,G%JsdB:G%JedB), source=OBC_NONE) - - do l = 1, OBC%number_of_segments - write(segment_param_str(1:15),"('OBC_SEGMENT_',i3.3)") l - call get_param(param_file, mdl, segment_param_str, segment_str, & - "Documentation needs to be dynamic?????", & - fail_if_missing=.true.) - segment_str = remove_spaces(segment_str) - if (segment_str(1:2) == 'I=') then - call setup_u_point_obc(OBC, G, US, segment_str, l, param_file, reentrant_y) - elseif (segment_str(1:2) == 'J=') then - call setup_v_point_obc(OBC, G, US, segment_str, l, param_file, reentrant_x) - else - call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config: "//& - "Unable to interpret "//segment_param_str//" = "//trim(segment_str)) - endif - enddo + do_not_log=.not.debugging_tests, debuggingParam=.true.) + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. + call get_param(param_file, mdl, "EXTERIOR_OBC_BUG", OBC%exterior_OBC_bug, & + "If true, recover a bug in barotropic solver and other routines when "//& + "boundary contitions interior to the domain are used.", & + default=enable_bugs) + call get_param(param_file, mdl, "OBC_HOR_INDEXING_BUG", OBC%hor_index_bug, & + "If true, recover set of a horizontal indexing bugs in the OBC code.", & + default=enable_bugs) + call get_param(param_file, mdl, "OBC_RESERVOIR_INIT_BUG", OBC%reservoir_init_bug, & + "If true, set the OBC tracer reservoirs at the startup of a new run from the "//& + "interior tracer concentrations regardless of properties that may be explicitly "//& + "specified for the reservoir concentrations.", default=enable_bugs, do_not_log=.true.) + call get_param(param_file, mdl, "OBC_TEMP_SALT_NEEDED_BUG", OBC%ts_needed_bug, & + "If true, recover a bug that OBC temperature and salinity can be ignored "//& + "even if they are registered tracers in the rest of the model.", default=.true.) + call get_param(param_file, mdl, "REENTRANT_X", reentrant_x, default=.true.) + call get_param(param_file, mdl, "REENTRANT_Y", reentrant_y, default=.false.) + + ! Allocate everything + allocate(OBC%segment(1:OBC%number_of_segments)) + do n=1,OBC%number_of_segments + OBC%segment(n)%Flather = .false. + OBC%segment(n)%radiation = .false. + OBC%segment(n)%radiation_tan = .false. + OBC%segment(n)%radiation_grad = .false. + OBC%segment(n)%oblique = .false. + OBC%segment(n)%oblique_tan = .false. + OBC%segment(n)%oblique_grad = .false. + OBC%segment(n)%nudged = .false. + OBC%segment(n)%nudged_tan = .false. + OBC%segment(n)%nudged_grad = .false. + OBC%segment(n)%specified = .false. + OBC%segment(n)%specified_tan = .false. + OBC%segment(n)%specified_grad = .false. + OBC%segment(n)%open = .false. + OBC%segment(n)%gradient = .false. + OBC%segment(n)%direction = OBC_NONE + OBC%segment(n)%is_N_or_S = .false. + OBC%segment(n)%is_E_or_W = .false. + OBC%segment(n)%is_E_or_W_2 = .false. + OBC%segment(n)%Velocity_nudging_timescale_in = 0.0 + OBC%segment(n)%Velocity_nudging_timescale_out = 0.0 + OBC%segment(n)%num_fields = 0 + enddo + allocate(OBC%segnum_u(G%IsdB:G%IedB,G%jsd:G%jed), source=0) + allocate(OBC%segnum_v(G%isd:G%ied,G%JsdB:G%JedB), source=0) + OBC%u_OBCs_on_PE = .false. + OBC%v_OBCs_on_PE = .false. - ! Moved this earlier because time_interp_external_init needs to be called - ! before anything that uses time_interp_external (such as initialize_segment_data) - if (OBC%specified_u_BCs_exist_globally .or. OBC%specified_v_BCs_exist_globally .or. & - OBC%open_u_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally) then - ! Need this for ocean_only mode boundary interpolation. - call time_interp_external_init() + do n=1,OBC%number_of_segments + n_seg = n ; if (OBC%reverse_segment_order) n_seg = OBC%number_of_segments + 1 - n + write(segment_param_str(1:15),"('OBC_SEGMENT_',i3.3)") n + call get_param(param_file, mdl, segment_param_str, segment_str, & + "Documentation needs to be dynamic?????", & + fail_if_missing=.true.) + segment_str = remove_spaces(segment_str) + if (segment_str(1:2) == 'I=') then + call setup_u_point_obc(OBC, G, US, segment_str, n_seg, n, param_file, reentrant_y) + elseif (segment_str(1:2) == 'J=') then + call setup_v_point_obc(OBC, G, US, segment_str, n_seg, n, param_file, reentrant_x) + else + call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config: "//& + "Unable to interpret "//segment_param_str//" = "//trim(segment_str)) endif - ! if (open_boundary_query(OBC, needs_ext_seg_data=.true.)) & - ! call initialize_segment_data(G, OBC, param_file) + enddo + ! Set arrays indicating the segment number and segment direction, and also store the + ! range of indices within which various orientations of OBCs can be found on this PE. + call set_segnum_signs(OBC, G) + + ! Moved this earlier because time_interp_external_init needs to be called + ! before anything that uses time_interp_external (such as initialize_segment_data) + if (OBC%specified_u_BCs_exist_globally .or. OBC%specified_v_BCs_exist_globally .or. & + OBC%open_u_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally) then + ! Need this for ocean_only mode boundary interpolation. + call time_interp_external_init() + endif + ! if (open_boundary_query(OBC, needs_ext_seg_data=.true.)) & + ! call initialize_segment_data(G, OBC, param_file) - if (open_boundary_query(OBC, apply_open_OBC=.true.)) then - call get_param(param_file, mdl, "OBC_RADIATION_MAX", OBC%rx_max, & + if (open_boundary_query(OBC, apply_open_OBC=.true.)) then + call get_param(param_file, mdl, "OBC_RADIATION_MAX", OBC%rx_max, & "The maximum magnitude of the baroclinic radiation velocity (or speed of "//& "characteristics), in gridpoints per timestep. This is only "//& "used if one of the open boundary segments is using Orlanski.", & units="nondim", default=1.0) - call get_param(param_file, mdl, "OBC_RAD_VEL_WT", OBC%gamma_uv, & + call get_param(param_file, mdl, "OBC_RAD_VEL_WT", OBC%gamma_uv, & "The relative weighting for the baroclinic radiation "//& "velocities (or speed of characteristics) at the new "//& "time level (1) or the running mean (0) for velocities. "//& "Valid values range from 0 to 1. This is only used if "//& "one of the open boundary segments is using Orlanski.", & units="nondim", default=0.3) - endif + endif - Lscale_in = 0. - Lscale_out = 0. - if (open_boundary_query(OBC, apply_open_OBC=.true.)) then - call get_param(param_file, mdl, "OBC_TRACER_RESERVOIR_LENGTH_SCALE_OUT ", Lscale_out, & - "An effective length scale for restoring the tracer concentration "//& - "at the boundaries to externally imposed values when the flow "//& - "is exiting the domain.", units="m", default=0.0, scale=US%m_to_L) - - call get_param(param_file, mdl, "OBC_TRACER_RESERVOIR_LENGTH_SCALE_IN ", Lscale_in, & - "An effective length scale for restoring the tracer concentration "//& - "at the boundaries to values from the interior when the flow "//& - "is entering the domain.", units="m", default=0.0, scale=US%m_to_L) - endif + Lscale_in = 0. + Lscale_out = 0. + if (open_boundary_query(OBC, apply_open_OBC=.true.)) then + call get_param(param_file, mdl, "OBC_TRACER_RESERVOIR_LENGTH_SCALE_OUT ", Lscale_out, & + "An effective length scale for restoring the tracer concentration "//& + "at the boundaries to externally imposed values when the flow "//& + "is exiting the domain.", units="m", default=0.0, scale=US%m_to_L) + + call get_param(param_file, mdl, "OBC_TRACER_RESERVOIR_LENGTH_SCALE_IN ", Lscale_in, & + "An effective length scale for restoring the tracer concentration "//& + "at the boundaries to values from the interior when the flow "//& + "is entering the domain.", units="m", default=0.0, scale=US%m_to_L) + endif - if (mask_outside) call mask_outside_OBCs(G, US, param_file, OBC) + if (mask_outside) call mask_outside_OBCs(G, US, param_file, OBC) - ! All tracers are using the same restoring length scale for now, but we may want to make this - ! tracer-specific in the future for example, in cases where certain tracers are poorly constrained - ! by data while others are well constrained - MJH. - do l = 1, OBC%number_of_segments - OBC%segment(l)%Tr_InvLscale_in = 0.0 - if (Lscale_in>0.) OBC%segment(l)%Tr_InvLscale_in = 1.0/Lscale_in - OBC%segment(l)%Tr_InvLscale_out = 0.0 - if (Lscale_out>0.) OBC%segment(l)%Tr_InvLscale_out = 1.0/Lscale_out - enddo + ! All tracers are using the same restoring length scale for now, but we may want to make this + ! tracer-specific in the future for example, in cases where certain tracers are poorly constrained + ! by data while others are well constrained - MJH. + do n=1,OBC%number_of_segments + OBC%segment(n)%Tr_InvLscale_in = 0.0 + if (Lscale_in>0.) OBC%segment(n)%Tr_InvLscale_in = 1.0/Lscale_in + OBC%segment(n)%Tr_InvLscale_out = 0.0 + if (Lscale_out>0.) OBC%segment(n)%Tr_InvLscale_out = 1.0/Lscale_out + enddo + + Lscale_in = 0. + Lscale_out = 0. + if (open_boundary_query(OBC, apply_open_OBC=.true.)) then + call get_param(param_file, mdl, "OBC_THICKNESS_RESERVOIR_LENGTH_SCALE_OUT ", Lscale_out, & + "An effective length scale for restoring the layer thickness "//& + "at the boundaries to externally imposed values when the flow "//& + "is exiting the domain.", units="m", default=0.0, scale=US%m_to_L) + + call get_param(param_file, mdl, "OBC_THICKNESS_RESERVOIR_LENGTH_SCALE_IN ", Lscale_in, & + "An effective length scale for restoring the layer thickness "//& + "at the boundaries to values from the interior when the flow "//& + "is entering the domain.", units="m", default=0.0, scale=US%m_to_L) + endif + + do n=1,OBC%number_of_segments + OBC%segment(n)%Th_InvLscale_in = 0.0 + if (Lscale_in>0.) OBC%segment(n)%Th_InvLscale_in = 1.0/Lscale_in + OBC%segment(n)%Th_InvLscale_out = 0.0 + if (Lscale_out>0.) OBC%segment(n)%Th_InvLscale_out = 1.0/Lscale_out + if (Lscale_in>0. .or. Lscale_out>0.) then + if (OBC%segment(n)%is_E_or_W_2) then + OBC%thickness_x_reservoirs_used = .true. + OBC%use_h_res = .true. + else + OBC%thickness_y_reservoirs_used = .true. + OBC%use_h_res = .true. + endif + endif + enddo - call get_param(param_file, mdl, "REMAPPING_SCHEME", remappingScheme, & - "This sets the reconstruction scheme used "//& - "for 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, & - "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, & - "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, & - "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.) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) - - allocate(OBC%remap_CS) - call initialize_remapping(OBC%remap_CS, remappingScheme, boundary_extrapolation = .false., & - check_reconstruction=check_reconstruction, check_remapping=check_remapping, & - force_bounds_in_subcell=force_bounds_in_subcell, answers_2018=answers_2018) - - endif ! OBC%number_of_segments > 0 - - ! Safety check + 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 OBC vertical remapping for all variables. "//& + "It can be one of the following schemes: \n"//& + 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", 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", 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.) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", OBC%remap_answer_date, & + "The vintage of the expressions and order of arithmetic to use for remapping. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "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, "REMAPPING_USE_OM4_SUBCELLS", OBC%om4_remap_via_sub_cells, & + do_not_log=.true., default=.true.) + + 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=OBC%om4_remap_via_sub_cells) + + ! Safety check if ((OBC%open_u_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally) .and. & .not.G%symmetric ) call MOM_error(FATAL, & "MOM_open_boundary, open_boundary_config: "//& @@ -640,48 +928,314 @@ subroutine open_boundary_config(G, US, param_file, OBC) end subroutine open_boundary_config -!> 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, OBC, PF) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure +!> 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 + ! Set up vertical remapping for open boundaries. Remapping happens independently on each PE, + ! so this block could be skipped for PEs without open boundary conditions that use remapping. + 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 + +!> Determine which physical fields are required for this segment based on boundary-condition type +!! and segment orientation. Also enable groups of physical fields required by tides or thermodynamics. +!! Note the tidal group could be further narrowed based on modes. +subroutine segment_determine_required_fields(segment, tides, temp_salt) + type(OBC_segment_type), intent(inout) :: segment !< OBC segment + logical, optional, intent(in) :: tides !< Switch for tidal variables + logical, optional, intent(in) :: temp_salt !< Switch for thermodynamic variables + + ! Local variables + logical :: use_tide ! Local switch for tidal variables + logical :: use_temp ! Local switch for thermodynamic variables + integer :: m + integer :: F_Vn, F_Vt, F_G + integer, parameter :: & + tide_idx(6) = (/ F_UAMP, F_UPHASE, F_VAMP, F_VPHASE, F_ZAMP, F_ZPHASE /), & ! Indices for tides + temp_idx(2) = (/ F_T, F_S /) ! Indices for thermodynamics + + if (.not. associated(segment%field)) & + call MOM_error(FATAL, 'segment_determine_required_fields: segment%field is not allocated.') + + use_tide = .false. ; if (present(tides)) use_tide = tides + use_temp = .false. ; if (present(temp_salt)) use_temp = temp_salt + + ! Normal, tangential and gradient depend on segment orientation. + if (segment%is_E_or_W_2) then + F_Vn = F_U ; F_Vt = F_V ; F_G = F_VX + else + F_Vn = F_V ; F_Vt = F_U ; F_G = F_UY + endif + if (segment%Flather) & + segment%field(F_Z)%required = .true. + + if (segment%Flather .or. segment%nudged .or. segment%specified) & + segment%field(F_Vn)%required = .true. + + if (segment%nudged_tan .or. segment%specified_tan) & + segment%field(F_Vt)%required = .true. + + if (segment%nudged_grad .or. segment%specified_grad) & + segment%field(F_G)%required = .true. + + if (use_tide) then ; do m = 1, size(tide_idx) + segment%field(tide_idx(m))%required = .true. + enddo ; endif + + if (use_temp) then ; do m = 1, size(temp_idx) + segment%field(temp_idx(m))%required = .true. + enddo ; endif + +end subroutine segment_determine_required_fields + +!> Find physical field index from name +integer function find_phys_field_index(name) + character(len=*), intent(in) :: name !< Field name + + ! Local variables + integer :: i + + find_phys_field_index = 0 + do i = 1, NUM_PHYS_FIELDS ; if (trim(name) == PHYS_FIELD_NAMES(i)) then + find_phys_field_index = i + return + endif ; enddo +end function find_phys_field_index + +!> Set global flag OBC%any_needs_IO_for_data. +subroutine OBC_any_IO(OBC) + type(ocean_OBC_type), intent(inout) :: OBC !< Open boundary control structure + + ! Local variables + integer :: m, n + logical :: use_IO + + use_IO = .false. + do n=1,OBC%number_of_segments + do m=1,OBC%segment(n)%num_fields + if (OBC%segment(n)%field(m)%use_IO) then + use_IO = .true. + exit + endif + enddo + if (use_IO) exit + enddo + + OBC%any_needs_IO_for_data = any_across_PEs(use_IO) +end subroutine OBC_any_IO + +!> Allocate data (buffer_src, buffer_dst and dz_src) for a field at an OBC segment. +subroutine allocate_segment_field_data(field, OBC, segment, US, inputdir, filename, varname, & + suffix, value, turns, nz) + type(OBC_segment_data_type), & + intent(inout) :: field !< A field of the segment + type(ocean_OBC_type), intent(in) :: OBC !< Open boundary control structure + type(OBC_segment_type), intent(inout) :: segment !< Segment to work on + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + character(len=*), intent(in) :: inputdir !< The directory of input files + character(len=*), intent(in) :: filename !< Input file name + character(len=*), intent(in) :: varname !< Variable name in the input file + character(len=*), intent(in) :: suffix !< Variable name suffix, "_segment_xxx" + real, intent(in) :: value !< Unscaled specified value of the field [a] + integer, intent(in) :: turns !< Number of quarter turns of the grid + integer, intent(in) :: nz !< Default k-axis size in buffer_dst + + ! Local variables + character(len=256) :: full_filename, full_varname ! Full filename and varname + character(len=512) :: mesg ! Error message + real :: init_value_dst ! Initial value for allocated buffer_dst array [a] + integer :: qturns ! The number of quarter turns in the range of 0 to 3 + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB ! Aliases of segment geometry indices + integer, dimension(4) :: siz, siz_check ! Four-dimensional shape of a variable in input file + integer :: dim ! Loop index for siz/siz_check + integer :: nk_dst ! k-axis size of buffer_dst + + if (.not. segment%on_pe) return + + isd = segment%HI%isd ; ied = segment%HI%ied ; IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + jsd = segment%HI%jsd ; jed = segment%HI%jed ; JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + nk_dst = nz + + qturns = modulo(turns, 4) + + field%on_face = field_is_on_face(field%name, segment%is_E_or_W) + ! The scale factor for tracers may also be set in register_segment_tracer, and a constant input + ! value is rescaled there. + field%scale = scale_factor_from_name(field%name, US, segment%tr_Reg) + field%use_IO = (trim(filename) /= 'none') + + if (field%use_IO) then + full_filename = trim(inputdir) // trim(filename) + full_varname = trim(varname) // trim(suffix) + + if (.not.file_exists(full_filename)) & + call MOM_error(FATAL," Unable to open OBC file " // trim(full_filename)) + + call field_size(full_filename, full_varname, siz, no_domain=.true.) + field%nk_src = siz(3) + + if (OBC%brushcutter_mode .and. (modulo(siz(1),2) == 0 .or. modulo(siz(2),2) == 0)) then + write(mesg, '("Brushcutter mode sizes ",I0," ",I0)') siz(1), siz(2) + call MOM_error(WARNING, mesg // " " // trim(full_filename) // " " // trim(full_varname)) + call MOM_error(FATAL,'segment data are not on the supergrid') + endif + + ! Allocate src array + if (.not.field%on_face) then + allocate(field%buffer_src(IsdB:IedB, JsdB:JedB, field%nk_src), source=0.0) + elseif (segment%is_E_or_W) then + allocate(field%buffer_src(IsdB:IedB, jsd:jed, field%nk_src), source=0.0) + else + allocate(field%buffer_src(isd:ied, JsdB:JedB, field%nk_src), source=0.0) + endif + + field%handle = init_external_field(trim(full_filename), trim(full_varname), & + ignore_axis_atts=.true., threading=SINGLE_FILE) + + if ((field%nk_src > 1) .and. (.not. field_is_tidal(field%name))) then ! nk_src is depth + full_varname = 'dz_' // trim(full_varname) + call field_size(full_filename, full_varname, siz_check, no_domain=.true.) + do dim = 1, 4 ; if (siz(dim) /= siz_check(dim)) & + call MOM_error(FATAL, "'dz' field size is inconsistent with "//& + "its corresponding variable.") + enddo + + if (.not.field%on_face) then + allocate(field%dz_src(IsdB:IedB, JsdB:JedB, field%nk_src), source=0.0) + elseif (segment%is_E_or_W) then + allocate(field%dz_src(IsdB:IedB, jsd:jed, field%nk_src), source=0.0) + else + allocate(field%dz_src(isd:ied, JsdB:JedB, field%nk_src), source=0.0) + endif + field%dz_handle = init_external_field(trim(full_filename), trim(full_varname), & + ignore_axis_atts=.true., threading=SINGLE_FILE) + + elseif (field_is_tidal(field%name)) then ! nk_src is constituent for tidal variables + ! expect third dimension to be number of constituents in MOM_input + if (OBC%add_tide_constituents .and. (field%nk_src /= OBC%n_tide_constituents)) & + call MOM_error(FATAL, 'Number of constituents in input data is not '//& + 'the same as the number specified') + nk_dst = field%nk_src + + else ! nk_src = 1 + nk_dst = 1 + + endif + + init_value_dst = 0.0 + else ! This data is not being read from a file. + field%value = field%scale * value + ! Change the sign of the specified velocities, depending on the number of quarter turns of the grid. + if ( ( ((field%name == 'U') .or. (field%name == 'Uamp')) .and. & + ((qturns == 1) .or. (qturns == 2)) ) .or. & + ( ((field%name == 'V') .or. (field%name == 'Vamp')) .and. & + ((qturns == 3) .or. (qturns == 2)) ) ) & + field%value = -field%value + + ! Check if this is a tidal field. If so, the number of expected constituents must be 1. + if (field_is_tidal(field%name)) then + if (OBC%add_tide_constituents .and. (OBC%n_tide_constituents > 1)) & + call MOM_error(FATAL, 'Only one constituent is supported when specifying '//& + 'tidal boundary conditions by value rather than file.') + nk_dst = 1 + endif + + if (field%name == 'SSH') & + nk_dst = 1 + + init_value_dst = field%value + endif + + ! Allocate buffer_dst array + if (.not.field%on_face) then + allocate(field%buffer_dst(IsdB:IedB, JsdB:JedB, nk_dst), source=init_value_dst) + elseif (segment%is_E_or_W) then + allocate(field%buffer_dst(IsdB:IedB, jsd:jed, nk_dst), source=init_value_dst) + else + allocate(field%buffer_dst(isd:ied, JsdB:JedB, nk_dst), source=init_value_dst) + endif + + ! This can be removed. + if (field%name == 'TEMP') segment%temp_segment_data_exists = .true. + if (field%name == 'SALT') segment%salt_segment_data_exists = .true. + +end subroutine allocate_segment_field_data + +!> Get and store properties about the fields on the OBC segments and allocate space for reading +!! OBC data from files. In the process, it does funky stuff with the MPI processes. +subroutine initialize_segment_data(GV, US, OBC, PF, turns, use_temperature) + 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), target, intent(inout) :: OBC !< Open boundary control structure - type(param_file_type), intent(in) :: PF !< Parameter file handle + type(param_file_type), intent(in) :: PF !< Parameter file handle + integer, intent(in) :: turns !< Number of quarter turns of the grid + logical, intent(in) :: use_temperature !< If true, temperature and + !! salinity used as state variables. - integer :: n, m, num_fields + ! Local variables + integer :: n, n_seg, m, num_manifest_fields, mm character(len=1024) :: segstr character(len=256) :: filename - character(len=20) :: segnam, suffix - character(len=32) :: varnam, fieldname + character(len=20) :: segname, suffix + character(len=32) :: varname real :: value ! A value that is parsed from the segment data string [various units] - character(len=32), dimension(MAX_OBC_FIELDS) :: fields ! segment field names + character(len=32), dimension(NUM_PHYS_FIELDS) :: phys_inputs ! input physical field names + integer, dimension(NUM_PHYS_FIELDS) :: phys_idx ! input physical field indices to PHYS_FIELD_NAMES + character(len=32) :: bgc_input ! segment field names character(len=128) :: inputdir type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list character(len=256) :: mesg ! Message for error messages. - integer, dimension(4) :: siz,siz2 - integer :: is, ie, js, je - integer :: isd, ied, jsd, jed - integer :: IsdB, IedB, JsdB, JedB integer, dimension(:), allocatable :: saved_pelist integer :: current_pe integer, dimension(1) :: single_pelist - !will be able to dynamically switch between sub-sampling refined grid data or model grid + type(external_tracers_segments_props), pointer :: obgc_segments_props_list =>NULL() + logical :: check_ts_needed ! Check if temperature and salinity are explicitly specified. + integer :: idx + character(len=256) :: routine_name ! Name of this subroutine - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + if (OBC%user_BCs_set_globally) return + + routine_name = trim(mdl) // ', initialize_segment_data' - ! There is a problem with the order of the OBC initialization - ! with respect to ALE_init. Currently handling this by copying the - ! param file so that I can use it later in step_MOM in order to finish - ! initializing segments on the first step. + OBC%update_OBC = .true. ! Data is time-dependent if not using user BC. + + check_ts_needed = use_temperature .and. (.not. OBC%ts_needed_bug) call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) - if (OBC%user_BCs_set_globally) return - ! Try this here just for the documentation. It is repeated below. - do n=1, OBC%number_of_segments - write(segnam,"('OBC_SEGMENT_',i3.3,'_DATA')") n - call get_param(PF, mdl, segnam, segstr, 'OBC segment docs') + do n=1,OBC%number_of_segments + write(segname, "('OBC_SEGMENT_',i3.3,'_DATA')") n + call get_param(PF, mdl, segname, segstr, 'OBC segment docs') enddo !< temporarily disable communication in order to read segment data independently @@ -692,262 +1246,245 @@ subroutine initialize_segment_data(G, OBC, PF) single_pelist(1) = current_pe call Set_PElist(single_pelist) - do n=1, OBC%number_of_segments - segment => OBC%segment(n) - if (.not. segment%values_needed) cycle + do n=1,OBC%number_of_segments + n_seg = n ; if (OBC%reverse_segment_order) n_seg = OBC%number_of_segments + 1 - n + segment => OBC%segment(n_seg) + + if (.not. segment%on_pe) cycle - write(segnam,"('OBC_SEGMENT_',i3.3,'_DATA')") n - write(suffix,"('_segment_',i3.3)") n + write(segname, "('OBC_SEGMENT_',i3.3,'_DATA')") n + write(suffix, "('_segment_',i3.3)") n ! needs documentation !! Yet, unsafe for now, causes grief for ! MOM_parameter_docs in circle_obcs on two processes. -! call get_param(PF, mdl, segnam, segstr, 'xyz') + ! call get_param(PF, mdl, segname, segstr, 'xyz') ! Clear out any old values segstr = '' - call get_param(PF, mdl, segnam, segstr) + call get_param(PF, mdl, segname, segstr) if (segstr == '') then - write(mesg,'("No OBC_SEGMENT_XXX_DATA string for OBC segment ",I3)') n + write(mesg,'("No OBC_SEGMENT_XXX_DATA string for OBC segment ",I0)') n call MOM_error(FATAL, mesg) endif - call parse_segment_manifest_str(trim(segstr), num_fields, fields) - if (num_fields == 0) then - call MOM_mesg('initialize_segment_data: num_fields = 0') - cycle ! cycle to next segment - endif + segment%num_fields = NUM_PHYS_FIELDS + OBC%num_obgc_tracers + allocate(segment%field(segment%num_fields)) - allocate(segment%field(num_fields)) - segment%num_fields = num_fields + ! Initialize physical fields + do m = 1, NUM_PHYS_FIELDS + segment%field(m)%name = PHYS_FIELD_NAMES(m) ! The order of physical fields is fixed. + segment%field(m)%bgc_tracer = .false. + segment%field(m)%required = .false. + segment%field(m)%use_IO = .false. + segment%field(m)%tr_index = -1 + enddo + segment%field(F_T)%tr_index = 1 ! Temperature tracer index is hard-coded. + segment%field(F_S)%tr_index = 2 ! Salinity tracer index is hard-coded. - segment%temp_segment_data_exists=.false. - segment%salt_segment_data_exists=.false. -!! -! CODE HERE FOR OTHER OPTIONS (CLAMPED, NUDGED,..) -!! + call segment_determine_required_fields(segment, tides=OBC%add_tide_constituents, & + temp_salt=check_ts_needed) - isd = segment%HI%isd ; ied = segment%HI%ied - jsd = segment%HI%jsd ; jed = segment%HI%jed - IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB - JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + ! Parse and find available physical fields + call parse_segment_manifest_str(trim(segstr), num_manifest_fields, phys_inputs) - do m=1,num_fields - call parse_segment_data_str(trim(segstr), m, trim(fields(m)), & - value, filename, fieldname) - if (trim(filename) /= 'none') then - OBC%update_OBC = .true. ! Data is assumed to be time-dependent if we are reading from file - OBC%needs_IO_for_data = .true. ! At least one segment is using I/O for OBC data -! segment%values_needed = .true. ! Indicates that i/o will be needed for this segment - segment%field(m)%name = trim(fields(m)) - if (segment%field(m)%name == 'TEMP') then - segment%temp_segment_data_exists=.true. - segment%t_values_needed = .false. - endif - if (segment%field(m)%name == 'SALT') then - segment%salt_segment_data_exists=.true. - segment%s_values_needed = .false. - endif - filename = trim(inputdir)//trim(filename) - fieldname = trim(fieldname)//trim(suffix) - call field_size(filename,fieldname,siz,no_domain=.true.) -! if (siz(4) == 1) segment%values_needed = .false. - if (segment%on_pe) then - if (OBC%brushcutter_mode .and. (modulo(siz(1),2) == 0 .or. modulo(siz(2),2) == 0)) then - call MOM_error(FATAL,'segment data are not on the supergrid') - endif - siz2(1)=1 + phys_idx(:) = -1 + do m = 1, num_manifest_fields + idx = find_phys_field_index(rotated_field_name(trim(phys_inputs(m)), turns)) + if (idx == 0) then + write(mesg,'("OBC segment ",I0," has an unknown input field: ",a)') n, trim(phys_inputs(m)) + call MOM_error(FATAL, trim(routine_name) // ", " // trim(mesg)) + endif + if ((.not. segment%field(idx)%required) .and. & + ((.not. (idx == F_T .or. idx == F_S)) .or. check_ts_needed)) then + write(mesg,'("OBC segment ",I0," has an unnecessary field: ",a)') & + n, trim(phys_inputs(m)) + call MOM_error(WARNING, trim(mesg)) + ! Unnecessary field is allowed and allocated for now. + ! Otherwise, the next line can be uncommented. + ! cycle + endif + phys_idx(idx) = m + enddo - if (siz(1)>1) then - if (OBC%brushcutter_mode) then - siz2(1)=(siz(1)-1)/2 - else - siz2(1)=siz(1) - endif - endif - siz2(2)=1 - if (siz(2)>1) then - if (OBC%brushcutter_mode) then - siz2(2)=(siz(2)-1)/2 - else - siz2(2)=siz(2) - endif - endif - siz2(3)=siz(3) + ! These can be removed. + segment%temp_segment_data_exists = .false. + segment%salt_segment_data_exists = .false. - if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V') then - allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) - segment%v_values_needed = .false. - elseif (segment%field(m)%name == 'Vamp') then - allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) - segment%vamp_values_needed = .false. - segment%vamp_index = m - elseif (segment%field(m)%name == 'Vphase') then - allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) - segment%vphase_values_needed = .false. - segment%vphase_index = m - elseif (segment%field(m)%name == 'DVDX') then - allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) - segment%g_values_needed = .false. - else - allocate(segment%field(m)%buffer_src(IsdB:IedB,jsd:jed,siz2(3))) - if (segment%field(m)%name == 'U') then - segment%u_values_needed = .false. - elseif (segment%field(m)%name == 'Uamp') then - segment%uamp_values_needed = .false. - segment%uamp_index = m - elseif (segment%field(m)%name == 'Uphase') then - segment%uphase_values_needed = .false. - segment%uphase_index = m - elseif (segment%field(m)%name == 'SSH') then - segment%z_values_needed = .false. - elseif (segment%field(m)%name == 'SSHamp') then - segment%zamp_values_needed = .false. - segment%zamp_index = m - elseif (segment%field(m)%name == 'SSHphase') then - segment%zphase_values_needed = .false. - segment%zphase_index = m - elseif (segment%field(m)%name == 'TEMP') then - segment%t_values_needed = .false. - elseif (segment%field(m)%name == 'SALT') then - segment%s_values_needed = .false. - endif - endif - else - if (segment%field(m)%name == 'U') then - allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) - segment%u_values_needed = .false. - elseif (segment%field(m)%name == 'DUDY') then - allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) - segment%g_values_needed = .false. - elseif (segment%field(m)%name == 'Uamp') then - allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) - segment%uamp_values_needed = .false. - segment%uamp_index = m - elseif (segment%field(m)%name == 'Uphase') then - allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) - segment%uphase_values_needed = .false. - segment%uphase_index = m - else - allocate(segment%field(m)%buffer_src(isd:ied,JsdB:JedB,siz2(3))) - if (segment%field(m)%name == 'V') then - segment%v_values_needed = .false. - elseif (segment%field(m)%name == 'Vamp') then - segment%vamp_values_needed = .false. - segment%vamp_index = m - elseif (segment%field(m)%name == 'Vphase') then - segment%vphase_values_needed = .false. - segment%vphase_index = m - elseif (segment%field(m)%name == 'SSH') then - segment%z_values_needed = .false. - elseif (segment%field(m)%name == 'SSHamp') then - segment%zamp_values_needed = .false. - segment%zamp_index = m - elseif (segment%field(m)%name == 'SSHphase') then - segment%zphase_values_needed = .false. - segment%zphase_index = m - elseif (segment%field(m)%name == 'TEMP') then - segment%t_values_needed = .false. - elseif (segment%field(m)%name == 'SALT') then - segment%s_values_needed = .false. - endif - endif - endif - segment%field(m)%buffer_src(:,:,:)=0.0 - segment%field(m)%fid = init_external_field(trim(filename), trim(fieldname), & - ignore_axis_atts=.true., threading=SINGLE_FILE) - if (siz(3) > 1) then - if ((index(segment%field(m)%name, 'phase') > 0) .or. (index(segment%field(m)%name, 'amp') > 0)) then - ! siz(3) is constituent for tidal variables - call field_size(filename, 'constituent', siz, no_domain=.true.) - ! expect third dimension to be number of constituents in MOM_input - if (siz(3) .ne. OBC%n_tide_constituents .and. OBC%add_tide_constituents) then - call MOM_error(FATAL, 'Number of constituents in input data is not '//& - 'the same as the number specified') - endif - segment%field(m)%nk_src=siz(3) - else - ! siz(3) is depth for everything else - fieldname = 'dz_'//trim(fieldname) - call field_size(filename,fieldname,siz,no_domain=.true.) - if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then - allocate(segment%field(m)%dz_src(IsdB:IedB,JsdB:JedB,siz(3))) - else - allocate(segment%field(m)%dz_src(IsdB:IedB,jsd:jed,siz(3))) - endif - else - if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then - allocate(segment%field(m)%dz_src(IsdB:IedB,JsdB:JedB,siz(3))) - else - allocate(segment%field(m)%dz_src(isd:ied,JsdB:JedB,siz(3))) - endif - endif - segment%field(m)%dz_src(:,:,:)=0.0 - segment%field(m)%nk_src=siz(3) - segment%field(m)%fid_dz = init_external_field(trim(filename), trim(fieldname), & - ignore_axis_atts=.true., threading=SINGLE_FILE) - endif - else - segment%field(m)%nk_src=1 - endif - endif - else - segment%field(m)%fid = -1 - segment%field(m)%value = value - segment%field(m)%name = trim(fields(m)) - ! Check if this is a tidal field. If so, the number - ! of expected constituents must be 1. - if ((index(segment%field(m)%name, 'phase') > 0) .or. (index(segment%field(m)%name, 'amp') > 0)) then - if (OBC%n_tide_constituents .gt. 1 .and. OBC%add_tide_constituents) then - call MOM_error(FATAL, 'Only one constituent is supported when specifying '//& - 'tidal boundary conditions by value rather than file.') - endif - endif - if (segment%field(m)%name == 'U') then - segment%u_values_needed = .false. - elseif (segment%field(m)%name == 'Uamp') then - segment%uamp_values_needed = .false. - segment%uamp_index = m - elseif (segment%field(m)%name == 'Uphase') then - segment%uphase_values_needed = .false. - segment%uphase_index = m - elseif (segment%field(m)%name == 'V') then - segment%v_values_needed = .false. - elseif (segment%field(m)%name == 'Vamp') then - segment%vamp_values_needed = .false. - segment%vamp_index = m - elseif (segment%field(m)%name == 'Vphase') then - segment%vphase_values_needed = .false. - segment%vphase_index = m - elseif (segment%field(m)%name == 'SSH') then - segment%z_values_needed = .false. - elseif (segment%field(m)%name == 'SSHamp') then - segment%zamp_values_needed = .false. - segment%zamp_index = m - elseif (segment%field(m)%name == 'SSHphase') then - segment%zphase_values_needed = .false. - segment%zphase_index = m - elseif (segment%field(m)%name == 'TEMP') then - segment%t_values_needed = .false. - elseif (segment%field(m)%name == 'SALT') then - segment%s_values_needed = .false. - elseif (segment%field(m)%name == 'DVDX' .or. segment%field(m)%name == 'DUDY') then - segment%g_values_needed = .false. - endif + ! Allocate physical fields + do m = 1, NUM_PHYS_FIELDS + if (segment%field(m)%required .and. (phys_idx(m) < 0)) then + write(mesg,'("OBC segment ",I0," requires field: ",a)') n, trim(segment%field(m)%name) + call MOM_error(FATAL, trim(routine_name) // ", " // trim(mesg)) + endif + if ((phys_idx(m) > 0)) then ! Field is found in input, even if not required + call parse_segment_data_str(trim(segstr), phys_idx(m), trim(phys_inputs(phys_idx(m))), & + value, filename, varname) + call allocate_segment_field_data(segment%field(m), OBC, segment, US, & + inputdir, filename, varname, suffix, value, turns, GV%ke) endif enddo - if (segment%u_values_needed .or. segment%uamp_values_needed .or. segment%uphase_values_needed .or. & - segment%v_values_needed .or. segment%vamp_values_needed .or. segment%vphase_values_needed .or. & - segment%t_values_needed .or. segment%s_values_needed .or. segment%g_values_needed .or. & - segment%z_values_needed .or. segment%zamp_values_needed .or. segment%zphase_values_needed ) then - write(mesg,'("Values needed for OBC segment ",I3)') n - call MOM_error(FATAL, mesg) - endif - enddo + + ! Allocate BGC tracer fields + obgc_segments_props_list => OBC%obgc_segments_props ! pointer to the head node + do m = NUM_PHYS_FIELDS+1, segment%num_fields + segment%field(m)%bgc_tracer = .true. + ! Query the obgc segment properties by traversing the linked list + call get_obgc_segments_props(obgc_segments_props_list, bgc_input, filename, varname, & + segment%field(m)%resrv_lfac_in, segment%field(m)%resrv_lfac_out) + ! Make sure the obgc tracer is not specified in the MOM6 param file too. + do mm=1,num_manifest_fields ; if (trim(bgc_input) == trim(phys_inputs(mm))) then + write(mesg,'("Input parameter for OBC segment ",I0," contains a BGC tracer: ", A)') & + n, trim(bgc_input) + call MOM_error(FATAL, trim(routine_name) // ", " // trim(mesg)) + endif ; enddo + segment%field(m)%name = rotated_field_name(bgc_input, turns) + segment%field(m)%tr_index = get_tracer_index(segment, trim(segment%field(m)%name)) + call allocate_segment_field_data(segment%field(m), OBC, segment, US, & + inputdir, filename, varname, suffix, 0.0, turns, GV%ke) + enddo + + ! write(stderr, '(A)') trim(suffix)//" segment checksum" + if (OBC%debug) call chksum_OBC_segment_data(OBC%segment(n_seg), GV, US, OBC%nk_OBC_debug, n) + + enddo ! n-loop for segments call Set_PElist(saved_pelist) + ! Determine global IO data requirement patterns. + call OBC_any_IO(OBC) end subroutine initialize_segment_data +!> Determine whether a particular field is descretized at the normal-velocity faces of an open +!! boundary condition segment. +logical function field_is_on_face(name, is_E_or_W) + character(len=*), intent(in) :: name !< The OBC segment data name to interpret + logical, intent(in) :: is_E_or_W !< This is true for an eastern or western open boundary condition + + field_is_on_face = .true. + if (is_E_or_W) then + if ((name == 'V') .or. (name == 'Vamp') .or. (name == 'Vphase') .or. (name == 'DVDX')) & + field_is_on_face = .false. + else + if ((name == 'U') .or. (name == 'Uamp') .or. (name == 'Uphase') .or. (name == 'DUDY')) & + field_is_on_face = .false. + endif +end function field_is_on_face + +!> Determine based on its name whether a particular field a barotropic tidal field, for which the +!! third dimension is the tidal constituent rather than a vertical axis +logical function field_is_tidal(name) + character(len=*), intent(in) :: name !< The OBC segment data name to interpret + + field_is_tidal = ((index(name, 'phase') > 0) .or. (index(name, 'amp') > 0)) +end function field_is_tidal + +!> This subroutine sets the sign of the OBC%segnum_u and OBC%segnum_v arrays to indicate the +!! direction of the faces - positive for logically eastern or northern OBCs and neagative +!! for logically western or southern OBCs, or zero on non-OBC points. Also store information +!! about which orientations of OBCs ar on this PE and the range of indices within which the +!! various orientations of OBCs can be found on this PE. +subroutine set_segnum_signs(OBC, G) + type(ocean_OBC_type), intent(inout) :: OBC !< Open boundary control structure, perhaps on a rotated grid. + type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure used by OBC + + integer :: i, j + + OBC%u_OBCs_on_PE = .false. ; OBC%v_OBCs_on_PE = .false. + do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB + OBC%segnum_u(I,j) = abs(OBC%segnum_u(I,j)) + if (abs(OBC%segnum_u(I,j)) > 0) then + OBC%u_OBCs_on_PE = .true. + if (OBC%segment(abs(OBC%segnum_u(I,j)))%direction == OBC_DIRECTION_W) & + OBC%segnum_u(I,j) = -abs(OBC%segnum_u(I,j)) + endif + enddo ; enddo + do J=G%JsdB,G%JedB ; do i=G%isd,G%ied + OBC%segnum_v(i,J) = abs(OBC%segnum_v(i,J)) + if (abs(OBC%segnum_v(i,J)) > 0) then + OBC%v_OBCs_on_PE = .true. + if (OBC%segment(abs(OBC%segnum_v(i,J)))%direction == OBC_DIRECTION_S) & + OBC%segnum_v(i,J) = -abs(OBC%segnum_v(i,J)) + endif + enddo ; enddo + + ! Determine the maximum and minimum index range for various directions of OBC points on this PE + ! by first setting these one point outside of the wrong side of the domain. + OBC%Is_u_W_obc = G%IedB + 1 ; OBC%Ie_u_W_obc = G%IsdB - 1 + OBC%js_u_W_obc = G%jed + 1 ; OBC%je_u_W_obc = G%jsd - 1 + OBC%Is_u_E_obc = G%IedB + 1 ; OBC%Ie_u_E_obc = G%IsdB - 1 + OBC%js_u_E_obc = G%jed + 1 ; OBC%je_u_E_obc = G%jsd - 1 + OBC%is_v_S_obc = G%ied + 1 ; OBC%ie_v_S_obc = G%isd - 1 + OBC%Js_v_S_obc = G%JedB + 1 ; OBC%Je_v_S_obc = G%JsdB - 1 + OBC%is_v_N_obc = G%ied + 1 ; OBC%ie_v_N_obc = G%isd - 1 + OBC%Js_v_N_obc = G%JedB + 1 ; OBC%Je_v_N_obc = G%JsdB - 1 + OBC%v_N_OBCs_on_PE = .false. ; OBC%v_S_OBCs_on_PE = .false. + OBC%u_E_OBCs_on_PE = .false. ; OBC%u_W_OBCs_on_PE = .false. + ! Note that the loop ranges are reduced because outward facing OBCs can not be applied at edge points. + do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB-1 + if (OBC%segnum_u(I,j) < 0) then ! This point has OBC_DIRECTION_W. + OBC%Is_u_W_obc = min(I, OBC%Is_u_W_obc) ; OBC%Ie_u_W_obc = max(I, OBC%Ie_u_W_obc) + OBC%js_u_W_obc = min(j, OBC%js_u_W_obc) ; OBC%je_u_W_obc = max(j, OBC%je_u_W_obc) + OBC%u_W_OBCs_on_PE = .true. + endif + enddo ; enddo + do j=G%jsd,G%jed ; do I=G%IsdB+1,G%IedB + if (OBC%segnum_u(I,j) > 0) then ! This point has OBC_DIRECTION_E. + OBC%Is_u_E_obc = min(I, OBC%Is_u_E_obc) ; OBC%Ie_u_E_obc = max(I, OBC%Ie_u_E_obc) + OBC%js_u_E_obc = min(j, OBC%js_u_E_obc) ; OBC%je_u_E_obc = max(j, OBC%je_u_E_obc) + OBC%u_E_OBCs_on_PE = .true. + endif + enddo ; enddo + do J=G%JsdB,G%JedB-1 ; do i=G%isd,G%ied + if (OBC%segnum_v(i,J) < 0) then ! This point has OBC_DIRECTION_S. + OBC%is_v_S_obc = min(i, OBC%is_v_S_obc) ; OBC%ie_v_S_obc = max(i, OBC%ie_v_S_obc) + OBC%Js_v_S_obc = min(J, OBC%Js_v_S_obc) ; OBC%Je_v_S_obc = max(J, OBC%Je_v_S_obc) + OBC%v_S_OBCs_on_PE = .true. + endif + enddo ; enddo + do J=G%JsdB+1,G%JedB ; do i=G%isd,G%ied + if (OBC%segnum_v(i,J) > 0) then ! This point has OBC_DIRECTION_N. + OBC%is_v_N_obc = min(i, OBC%is_v_N_obc) ; OBC%ie_v_N_obc = max(i, OBC%ie_v_N_obc) + OBC%Js_v_N_obc = min(J, OBC%Js_v_N_obc) ; OBC%Je_v_N_obc = max(J, OBC%Je_v_N_obc) + OBC%v_N_OBCs_on_PE = .true. + endif + enddo ; enddo + +end subroutine set_segnum_signs + +!> Return an appropriate dimensional scaling factor for input data based on an OBC segment data +!! name [various ~> 1], or 1 for tracers or other fields that do not match one of the specified names. +!! Note that calls to register_segment_tracer can come before or after calls to scale_factor_from_name. + +real function scale_factor_from_name(name, US, Tr_Reg) + character(len=*), intent(in) :: name !< The OBC segment data name to interpret + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(segment_tracer_registry_type), pointer :: Tr_Reg !< pointer to tracer registry for this segment + + integer :: m + + select case (trim(name)) + case ('U') ; scale_factor_from_name = US%m_s_to_L_T + case ('V') ; scale_factor_from_name = US%m_s_to_L_T + case ('Uamp') ; scale_factor_from_name = US%m_s_to_L_T + case ('Vamp') ; scale_factor_from_name = US%m_s_to_L_T + case ('DVDX') ; scale_factor_from_name = US%T_to_s + case ('DUDY') ; scale_factor_from_name = US%T_to_s + case ('SSH') ; scale_factor_from_name = US%m_to_Z + case ('SSHamp') ; scale_factor_from_name = US%m_to_Z + case default ; scale_factor_from_name = 1.0 + end select + + if (associated(Tr_Reg) .and. (scale_factor_from_name == 1.0)) then + ! Check for name matches with previously registered tracers. + do m=1,Tr_Reg%ntseg + if (uppercase(name) == uppercase(Tr_Reg%Tr(m)%name)) then + scale_factor_from_name = Tr_Reg%Tr(m)%scale + exit + endif + enddo + endif + +end function scale_factor_from_name + +!> Initize parameters and fields related to the specification of tides at open boundaries. subroutine initialize_obc_tides(OBC, US, param_file) type(ocean_OBC_type), intent(inout) :: OBC !< Open boundary control structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -958,38 +1495,45 @@ subroutine initialize_obc_tides(OBC, US, param_file) type(astro_longitudes) :: nodal_longitudes !< Solar and lunar longitudes for tidal forcing type(time_type) :: nodal_time !< Model time to calculate nodal modulation for. integer :: c !< Index to tidal constituent. + logical :: tides !< True if astronomical tides are also used. call get_param(param_file, mdl, "OBC_TIDE_CONSTITUENTS", tide_constituent_str, & "Names of tidal constituents being added to the open boundaries.", & fail_if_missing=.true.) - call get_param(param_file, mdl, "OBC_TIDE_ADD_EQ_PHASE", OBC%add_eq_phase, & + call get_param(param_file, mdl, "TIDES", tides, & + "If true, apply tidal momentum forcing.", default=.false., do_not_log=.true.) + + call get_param(param_file, mdl, "TIDE_USE_EQ_PHASE", OBC%add_eq_phase, & "If true, add the equilibrium phase argument to the specified tidal phases.", & - default=.false., fail_if_missing=.false.) + old_name="OBC_TIDE_ADD_EQ_PHASE", default=.false., do_not_log=tides) - call get_param(param_file, mdl, "OBC_TIDE_ADD_NODAL", OBC%add_nodal_terms, & + call get_param(param_file, mdl, "TIDE_ADD_NODAL", OBC%add_nodal_terms, & "If true, include 18.6 year nodal modulation in the boundary tidal forcing.", & - default=.false.) + old_name="OBC_TIDE_ADD_NODAL", default=.false., do_not_log=tides) - call get_param(param_file, mdl, "OBC_TIDE_REF_DATE", tide_ref_date, & + call get_param(param_file, mdl, "TIDE_REF_DATE", tide_ref_date, & "Reference date to use for tidal calculations and equilibrium phase.", & - fail_if_missing=.true.) + old_name="OBC_TIDE_REF_DATE", defaults=(/0, 0, 0/), do_not_log=tides) - call get_param(param_file, mdl, "OBC_TIDE_NODAL_REF_DATE", nodal_ref_date, & + call get_param(param_file, mdl, "TIDE_NODAL_REF_DATE", nodal_ref_date, & "Fixed reference date to use for nodal modulation of boundary tides.", & - fail_if_missing=.false., default=0) - - if (.not. OBC%add_eq_phase) then - ! If equilibrium phase argument is not added, the input phases - ! should already be relative to the reference time. - call MOM_mesg('OBC tidal phases will *not* be corrected with equilibrium arguments.') - endif + old_name="OBC_TIDE_NODAL_REF_DATE", defaults=(/0, 0, 0/), do_not_log=tides) allocate(OBC%tide_names(OBC%n_tide_constituents)) read(tide_constituent_str, *) OBC%tide_names ! Set reference time (t = 0) for boundary tidal forcing. - OBC%time_ref = set_date(tide_ref_date(1), tide_ref_date(2), tide_ref_date(3)) + if (sum(tide_ref_date) == 0) then ! tide_ref_date defaults to 0. + OBC%time_ref = set_date(1, 1, 1, 0, 0, 0) + else + if (.not. OBC%add_eq_phase) then + ! If equilibrium phase argument is not added, the input phases + ! should already be relative to the reference time. + call MOM_mesg('OBC tidal phases will *not* be corrected with equilibrium arguments.') + endif + OBC%time_ref = set_date(tide_ref_date(1), tide_ref_date(2), tide_ref_date(3), 0, 0, 0) + endif ! Find relevant lunar and solar longitudes at the reference time if (OBC%add_eq_phase) call astro_longitudes_init(OBC%time_ref, OBC%tidal_longitudes) @@ -997,9 +1541,9 @@ subroutine initialize_obc_tides(OBC, US, param_file) ! If the nodal correction is based on a different time, initialize that. ! Otherwise, it can use N from the time reference. if (OBC%add_nodal_terms) then - if (sum(nodal_ref_date) .ne. 0) then + if (sum(nodal_ref_date) /= 0) then ! A reference date was provided for the nodal correction - nodal_time = set_date(nodal_ref_date(1), nodal_ref_date(2), nodal_ref_date(3)) + nodal_time = set_date(nodal_ref_date(1), nodal_ref_date(2), nodal_ref_date(3), 0, 0, 0) call astro_longitudes_init(nodal_time, nodal_longitudes) elseif (OBC%add_eq_phase) then ! Astronomical longitudes were already calculated for use in equilibrium phases, @@ -1024,7 +1568,7 @@ subroutine initialize_obc_tides(OBC, US, param_file) "This is only used if TIDES and TIDE_"//trim(OBC%tide_names(c))// & " are true, or if OBC_TIDE_N_CONSTITUENTS > 0 and "//trim(OBC%tide_names(c))//& " is in OBC_TIDE_CONSTITUENTS.", & - units="s-1", default=tidal_frequency(trim(OBC%tide_names(c))), scale=US%T_to_s) + units="rad s-1", default=tidal_frequency(trim(OBC%tide_names(c))), scale=US%T_to_s) ! Find equilibrium phase if needed if (OBC%add_eq_phase) then @@ -1044,7 +1588,7 @@ subroutine initialize_obc_tides(OBC, US, param_file) end subroutine initialize_obc_tides !> Define indices for segment and store in hor_index_type -!> using global segment bounds corresponding to q-points +!! using global segment bounds corresponding to q-points subroutine setup_segment_indices(G, seg, Is_obc, Ie_obc, Js_obc, Je_obc) type(dyn_horgrid_type), intent(in) :: G !< grid type type(OBC_segment_type), intent(inout) :: seg !< Open boundary segment @@ -1053,7 +1597,7 @@ subroutine setup_segment_indices(G, seg, Is_obc, Ie_obc, Js_obc, Je_obc) integer, intent(in) :: Js_obc !< Q-point global j-index of start of segment integer, intent(in) :: Je_obc !< Q-point global j-index of end of segment ! Local variables - integer :: IsgB, IegB, JsgB, JegB + integer :: IsgB, IegB, JsgB, JegB ! Global corner point indices at the ends of the OBC segments integer :: isg, ieg, jsg, jeg ! Isg, Ieg will be I*_obc in global space @@ -1167,12 +1711,13 @@ subroutine setup_segment_indices(G, seg, Is_obc, Ie_obc, Js_obc, Je_obc) end subroutine setup_segment_indices !> Parse an OBC_SEGMENT_%%% string starting with "I=" and configure placement and type of OBC accordingly -subroutine setup_u_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_y) +subroutine setup_u_point_obc(OBC, G, US, segment_str, l_seg, l_seg_io, PF, reentrant_y) type(ocean_OBC_type), intent(inout) :: OBC !< Open boundary control structure type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type character(len=*), intent(in) :: segment_str !< A string in form of "I=%,J=%:%,string" - integer, intent(in) :: l_seg !< which segment is this? + integer, intent(in) :: l_seg !< The internal segment number + integer, intent(in) :: l_seg_io !< The segment number used for reading parameters type(param_file_type), intent(in) :: PF !< Parameter file handle logical, intent(in) :: reentrant_y !< is the domain reentrant in y? ! Local variables @@ -1194,7 +1739,7 @@ subroutine setup_u_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_y) OBC%segment(l_seg)%direction = OBC_DIRECTION_E elseif (Je_obcJs_obc .and. j<=Je_obc) then OBC%segnum_u(I_obc,j) = l_seg + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_W) OBC%segnum_u(I_obc,j) = -l_seg + OBC%u_OBCs_on_PE = .true. endif enddo OBC%segment(l_seg)%Is_obc = I_obc @@ -1299,20 +1838,16 @@ subroutine setup_u_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_y) if (OBC%segment(l_seg)%oblique .and. OBC%segment(l_seg)%radiation) & call MOM_error(FATAL, "MOM_open_boundary.F90, setup_u_point_obc: \n"//& "Orlanski and Oblique OBC options cannot be used together on one segment.") - - if (OBC%segment(l_seg)%u_values_needed .or. OBC%segment(l_seg)%v_values_needed .or. & - OBC%segment(l_seg)%t_values_needed .or. OBC%segment(l_seg)%s_values_needed .or. & - OBC%segment(l_seg)%z_values_needed .or. OBC%segment(l_seg)%g_values_needed) & - OBC%segment(l_seg)%values_needed = .true. end subroutine setup_u_point_obc !> Parse an OBC_SEGMENT_%%% string starting with "J=" and configure placement and type of OBC accordingly -subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_x) +subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, l_seg_io, PF, reentrant_x) type(ocean_OBC_type), intent(inout) :: OBC !< Open boundary control structure type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type character(len=*), intent(in) :: segment_str !< A string in form of "J=%,I=%:%,string" - integer, intent(in) :: l_seg !< which segment is this? + integer, intent(in) :: l_seg !< The internal segment number + integer, intent(in) :: l_seg_io !< The segment number used for reading parameters type(param_file_type), intent(in) :: PF !< Parameter file handle logical, intent(in) :: reentrant_x !< is the domain reentrant in x? ! Local variables @@ -1348,8 +1883,6 @@ subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_x) OBC%segment(l_seg)%open = .true. OBC%Flather_v_BCs_exist_globally = .true. OBC%open_v_BCs_exist_globally = .true. - OBC%segment(l_seg)%z_values_needed = .true. - OBC%segment(l_seg)%v_values_needed = .true. elseif (trim(action_str(a_loop)) == 'ORLANSKI') then OBC%segment(l_seg)%radiation = .true. OBC%segment(l_seg)%open = .true. @@ -1377,14 +1910,11 @@ subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_x) elseif (trim(action_str(a_loop)) == 'NUDGED') then OBC%segment(l_seg)%nudged = .true. OBC%nudged_v_BCs_exist_globally = .true. - OBC%segment(l_seg)%v_values_needed = .true. elseif (trim(action_str(a_loop)) == 'NUDGED_TAN') then OBC%segment(l_seg)%nudged_tan = .true. OBC%nudged_v_BCs_exist_globally = .true. - OBC%segment(l_seg)%u_values_needed = .true. elseif (trim(action_str(a_loop)) == 'NUDGED_GRAD') then OBC%segment(l_seg)%nudged_grad = .true. - OBC%segment(l_seg)%g_values_needed = .true. elseif (trim(action_str(a_loop)) == 'GRADIENT') then OBC%segment(l_seg)%gradient = .true. OBC%segment(l_seg)%open = .true. @@ -1392,25 +1922,22 @@ subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_x) elseif (trim(action_str(a_loop)) == 'SIMPLE') then OBC%segment(l_seg)%specified = .true. OBC%specified_v_BCs_exist_globally = .true. ! This avoids deallocation - OBC%segment(l_seg)%v_values_needed = .true. elseif (trim(action_str(a_loop)) == 'SIMPLE_TAN') then OBC%segment(l_seg)%specified_tan = .true. - OBC%segment(l_seg)%u_values_needed = .true. elseif (trim(action_str(a_loop)) == 'SIMPLE_GRAD') then OBC%segment(l_seg)%specified_grad = .true. - OBC%segment(l_seg)%g_values_needed = .true. else call MOM_error(FATAL, "MOM_open_boundary.F90, setup_v_point_obc: "//& "String '"//trim(action_str(a_loop))//"' not understood.") endif if (OBC%segment(l_seg)%nudged .or. OBC%segment(l_seg)%nudged_tan) then - write(segment_param_str(1:43),"('OBC_SEGMENT_',i3.3,'_VELOCITY_NUDGING_TIMESCALES')") l_seg + write(segment_param_str(1:43),"('OBC_SEGMENT_',i3.3,'_VELOCITY_NUDGING_TIMESCALES')") l_seg_io allocate(tnudge(2)) call get_param(PF, mdl, segment_param_str(1:43), tnudge, & "Timescales in days for nudging along a segment, "//& "for inflow, then outflow. Setting both to zero should "//& "behave like SIMPLE obcs for the baroclinic velocities.", & - fail_if_missing=.true., default=0., units="days", scale=86400.0*US%s_to_T) + fail_if_missing=.true., units="days", scale=86400.0*US%s_to_T) OBC%segment(l_seg)%Velocity_nudging_timescale_in = tnudge(1) OBC%segment(l_seg)%Velocity_nudging_timescale_out = tnudge(2) deallocate(tnudge) @@ -1427,6 +1954,8 @@ subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_x) do i=G%HI%isd, G%HI%ied if (i>Is_obc .and. i<=Ie_obc) then OBC%segnum_v(i,J_obc) = l_seg + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_S) OBC%segnum_v(i,J_obc) = -l_seg + OBC%v_OBCs_on_PE = .true. endif enddo OBC%segment(l_seg)%Is_obc = Is_obc @@ -1439,10 +1968,6 @@ subroutine setup_v_point_obc(OBC, G, US, segment_str, l_seg, PF, reentrant_x) call MOM_error(FATAL, "MOM_open_boundary.F90, setup_v_point_obc: \n"//& "Orlanski and Oblique OBC options cannot be used together on one segment.") - if (OBC%segment(l_seg)%u_values_needed .or. OBC%segment(l_seg)%v_values_needed .or. & - OBC%segment(l_seg)%t_values_needed .or. OBC%segment(l_seg)%s_values_needed .or. & - OBC%segment(l_seg)%z_values_needed .or. OBC%segment(l_seg)%g_values_needed) & - OBC%segment(l_seg)%values_needed = .true. end subroutine setup_v_point_obc !> Parse an OBC_SEGMENT_%%% string @@ -1458,6 +1983,7 @@ subroutine parse_segment_str(ni_global, nj_global, segment_str, l, m, n, action_ ! Local variables character(len=24) :: word1, word2, m_word, n_word !< Words delineated by commas in a string in form of !! "I=%,J=%:%,string" + character(len=3) :: max_words !< maximum number of OBC types per segment integer :: l_max !< Either ni_global or nj_global, depending on whether segment_str begins with "I=" or "J=" integer :: mn_max !< Either nj_global or ni_global, depending on whether segment_str begins with "I=" or "J=" integer :: j @@ -1477,7 +2003,7 @@ subroutine parse_segment_str(ni_global, nj_global, segment_str, l, m, n, action_ if (.not. (word2(1:2)=='I=')) call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//& "Second word of string '"//trim(segment_str)//"' must start with 'I='.") else - call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str"//& + call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//& "String '"//segment_str//"' must start with 'I=' or 'J='.") endif @@ -1523,6 +2049,14 @@ subroutine parse_segment_str(ni_global, nj_global, segment_str, l, m, n, action_ "Range in string '"//trim(segment_str)//"' must span one cell.") endif + ! checking if the number of provided OBC types is less than or equal to 8 + if (extract_word(segment_str,',',3+size(action_str))/="") then + write(max_words, '(I0)') size(action_str) + call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "// & + "Number of OBC descriptor words in '" // trim(segment_str) // "' is too large. " // & + "There can be at most " // trim(max_words) // " descriptor words.") + endif + ! Type of open boundary condition do j = 1, size(action_str) action_str(j) = extract_word(segment_str,',',2+j) @@ -1538,7 +2072,7 @@ integer function interpret_int_expr(string, imax) integer slen slen = len_trim(string) - if (slen==0) call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str"//& + if (slen==0) call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//& "Parsed string was empty!") if (len_trim(string)==1 .and. string(1:1)=='N') then interpret_int_expr = imax @@ -1554,7 +2088,7 @@ integer function interpret_int_expr(string, imax) read(string(1:slen),*,err=911) interpret_int_expr endif return - 911 call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str"//& + 911 call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_str: "//& "Problem reading value from string '"//trim(string)//"'.") end function interpret_int_expr end subroutine parse_segment_str @@ -1565,19 +2099,35 @@ subroutine parse_segment_manifest_str(segment_str, num_fields, fields) character(len=*), intent(in) :: segment_str !< A string in form of !< "VAR1=file:foo1.nc(varnam1),VAR2=file:foo2.nc(varnam2),..." integer, intent(out) :: num_fields !< The number of fields in the segment data - character(len=*), dimension(MAX_OBC_FIELDS), intent(out) :: fields + character(len=*), dimension(NUM_PHYS_FIELDS), intent(out) :: fields !< List of fieldnames for each segment ! Local variables - character(len=128) :: word1, word2 + character(len=128) :: field_spec, field + integer :: i num_fields = 0 + fields(:) = '' + do - word1 = extract_word(segment_str, ',', num_fields+1) - if (trim(word1) == '') exit + field_spec = extract_word(segment_str, ',', num_fields + 1) + if (trim(field_spec) == '') exit + + if (num_fields >= NUM_PHYS_FIELDS) & + call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_manifest_str: " // & + "too many fields in OBC segment manifest '" //trim(segment_str) // "'.") + + field = trim(extract_word(field_spec, '=', 1)) + + ! Check for duplicate fields + do i=1, num_fields + if (fields(i) == trim(field)) & + call MOM_error(FATAL, "MOM_open_boundary.F90, parse_segment_manifest_str: "//& + "duplicate field '" // trim(field) // "' in '" // trim(segment_str) // "'.") + enddo + num_fields = num_fields + 1 - word2 = extract_word(word1, '=', 1) - fields(num_fields) = trim(word2) + fields(num_fields) = trim(field) enddo end subroutine parse_segment_manifest_str @@ -1591,7 +2141,8 @@ subroutine parse_segment_data_str(segment_str, idx, var, value, filename, fieldn character(len=*), intent(out) :: filename !< The name of the input file if using "file" method character(len=*), intent(out) :: fieldname !< The name of the variable in the input file if using !! "file" method - real, optional, intent(out) :: value !< A constant value if using the "value" method + real, optional, intent(out) :: value !< A constant value if using the "value" method in various + !! units but without the internal rescaling [various units] ! Local variables character(len=128) :: word1, word2, word3, method @@ -1627,32 +2178,34 @@ subroutine parse_segment_data_str(segment_str, idx, var, value, filename, fieldn 987 call MOM_error(FATAL,'Error while parsing segment data specification! '//trim(segment_str)) end subroutine parse_segment_data_str - !> Parse all the OBC_SEGMENT_%%%_DATA strings again !! to see which need tracer reservoirs (all pes need to know). - subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) +subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) type(ocean_OBC_type), target, intent(inout) :: OBC !< Open boundary control structure type(param_file_type), intent(in) :: PF !< Parameter file handle logical, intent(in) :: use_temperature !< If true, T and S are used ! Local variables - integer :: n,m,num_fields + integer :: n ! The segment number used to read in input data + integer :: n_seg ! The internal segment number + integer :: m, num_fields ! Used to loop over the fields on a segment + integer :: na character(len=1024) :: segstr character(len=256) :: filename - character(len=20) :: segnam, suffix - character(len=32) :: varnam, fieldname + character(len=20) :: segname, suffix + character(len=32) :: fieldname real :: value ! A value that is parsed from the segment data string [various units] - character(len=32), dimension(MAX_OBC_FIELDS) :: fields ! segment field names + character(len=32), dimension(NUM_PHYS_FIELDS) :: fields ! segment field names type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list - character(len=256) :: mesg ! Message for error messages. - do n=1, OBC%number_of_segments - segment => OBC%segment(n) - write(segnam,"('OBC_SEGMENT_',i3.3,'_DATA')") n - write(suffix,"('_segment_',i3.3)") n + do n=1,OBC%number_of_segments + n_seg = n ; if (OBC%reverse_segment_order) n_seg = OBC%number_of_segments + 1 - n + segment => OBC%segment(n_seg) + write(segname, "('OBC_SEGMENT_',i3.3,'_DATA')") n + write(suffix, "('_segment_',i3.3)") n ! Clear out any old values segstr = '' - call get_param(PF, mdl, segnam, segstr) + call get_param(PF, mdl, segname, segstr) if (segstr == '') cycle call parse_segment_manifest_str(trim(segstr), num_fields, fields) @@ -1660,8 +2213,7 @@ subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) ! At this point, just search for TEMP and SALT as tracers 1 and 2. do m=1,num_fields - call parse_segment_data_str(trim(segstr), m, trim(fields(m)), & - value, filename, fieldname) + call parse_segment_data_str(trim(segstr), m, trim(fields(m)), value, filename, fieldname) if (trim(filename) /= 'none') then if (fields(m) == 'TEMP') then if (segment%is_E_or_W_2) then @@ -1689,120 +2241,51 @@ subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) OBC%tracer_y_reservoirs_used(2) = .true. endif endif - enddo - - return - -end subroutine parse_for_tracer_reservoirs - -!> Parse an OBC_SEGMENT_%%%_PARAMS string -subroutine parse_segment_param_real(segment_str, var, param_value, debug ) - character(len=*), intent(in) :: segment_str !< A string in form of - !! "VAR1=file:foo1.nc(varnam1),VAR2=file:foo2.nc(varnam2),..." - character(len=*), intent(in) :: var !< The name of the variable for which parameters are needed - real, intent(out) :: param_value !< The value of the parameter - logical, optional, intent(in) :: debug !< If present and true, write verbose debugging messages - ! Local variables - character(len=128) :: word1, word2, word3, method - integer :: lword, nfields, n, m - logical :: continue,dbg - character(len=32), dimension(MAX_OBC_FIELDS) :: flds - - nfields = 0 - continue = .true. - dbg = .false. - if (PRESENT(debug)) dbg = debug - - do while (continue) - word1 = extract_word(segment_str,',',nfields+1) - if (trim(word1) == '') exit - nfields = nfields+1 - word2 = extract_word(word1,'=',1) - flds(nfields) = trim(word2) - enddo - - ! if (PRESENT(fields)) then - ! do n=1,nfields - ! fields(n) = flds(n) - ! enddo - ! endif - - ! if (PRESENT(num_fields)) then - ! num_fields = nfields - ! return - ! endif - - m=0 -! if (PRESENT(var)) then - do n=1,nfields - if (trim(var)==trim(flds(n))) then - m = n - exit + !Add reservoirs for external/obgc tracers + !There is a diconnect in the above logic between tracer index and reservoir index. + !It arbitarily assigns reservoir indexes 1&2 to tracers T&S, + !So we need to start from reservoir index for non-native tracers from 3, hence na=2 below. + !num_fields is the number of vars in segstr (6 of them now, U,V,SSH,TEMP,SALT,dye) + !but OBC%tracer_x_reservoirs_used is allocated to size Reg%ntr, which is the total number of tracers + na = 2 ! Number of native MOM6 tracers (T&S) with reservoirs + do m=1,OBC%num_obgc_tracers + !This logic assumes all external tarcers need a reservoir + !The segments for tracers are not initialized yet (that happens later in initialize_segment_data()) + !so we cannot query to determine if this tracer needs a reservoir. + if (segment%is_E_or_W_2) then + OBC%tracer_x_reservoirs_used(m+na) = .true. + else + OBC%tracer_y_reservoirs_used(m+na) = .true. endif enddo - if (m==0) then - call abort() - endif - - ! Process first word which will start with the fieldname - word3 = extract_word(segment_str,',',m) -! word1 = extract_word(word3,':',1) -! if (trim(word1) == '') exit - word2 = extract_word(word1,'=',1) - if (trim(word2) == trim(var)) then - method=trim(extract_word(word1,'=',2)) - lword=len_trim(method) - read(method(1:lword),*,err=987) param_value - ! if (method(lword-3:lword) == 'file') then - ! ! raise an error id filename/fieldname not in argument list - ! word1 = extract_word(word3,':',2) - ! filenam = extract_word(word1,'(',1) - ! fieldnam = extract_word(word1,'(',2) - ! lword=len_trim(fieldnam) - ! fieldnam = fieldnam(1:lword-1) ! remove trailing parenth - ! value=-999. - ! elseif (method(lword-4:lword) == 'value') then - ! filenam = 'none' - ! fieldnam = 'none' - ! word1 = extract_word(word3,':',2) - ! lword=len_trim(word1) - ! read(word1(1:lword),*,end=986,err=987) value - ! endif - endif -! endif + enddo return - 986 call MOM_error(FATAL,'End of record while parsing segment data specification! '//trim(segment_str)) - 987 call MOM_error(FATAL,'Error while parsing segment parameter specification! '//trim(segment_str)) -end subroutine parse_segment_param_real +end subroutine parse_for_tracer_reservoirs -!> Initialize open boundary control structure and do any necessary rescaling of OBC -!! fields that have been read from a restart file. -subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CS) +!> Do any necessary halo updates on OBC-related fields. +subroutine open_boundary_halo_update(G, OBC) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Container for vertical grid information - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< Parameter file handle type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure - type(MOM_restart_CS), intent(in) :: restart_CS !< Restart structure, data intent(inout) ! Local variables - real :: vel2_rescale ! A rescaling factor for squared velocities from the representation in - ! a restart file to the internal representation in this run. - integer :: i, j, k, isd, ied, jsd, jed, nz, m - integer :: IsdB, IedB, JsdB, JedB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + integer :: m if (.not.associated(OBC)) return id_clock_pass = cpu_clock_id('(Ocean OBC halo updates)', grain=CLOCK_ROUTINE) if (OBC%radiation_BCs_exist_globally) call pass_vector(OBC%rx_normal, OBC%ry_normal, G%Domain, & To_All+Scalar_Pair) - if (OBC%oblique_BCs_exist_globally) call pass_vector(OBC%rx_oblique, OBC%ry_oblique, G%Domain, & - To_All+Scalar_Pair) - if (allocated(OBC%cff_normal)) call pass_var(OBC%cff_normal, G%Domain, position=CORNER) + if (OBC%oblique_BCs_exist_globally) then +! call pass_vector(OBC%rx_oblique_u, OBC%ry_oblique_v, G%Domain, To_All+Scalar_Pair) +! call pass_vector(OBC%ry_oblique_u, OBC%rx_oblique_v, G%Domain, To_All+Scalar_Pair) +! call pass_vector(OBC%cff_normal_u, OBC%cff_normal_v, G%Domain, To_All+Scalar_Pair) + call create_group_pass(OBC%pass_oblique, OBC%rx_oblique_u, OBC%ry_oblique_v, G%Domain, To_All+Scalar_Pair) + call create_group_pass(OBC%pass_oblique, OBC%ry_oblique_u, OBC%rx_oblique_v, G%Domain, To_All+Scalar_Pair) + call create_group_pass(OBC%pass_oblique, OBC%cff_normal_u, OBC%cff_normal_v, G%Domain, To_All+Scalar_Pair) + call do_group_pass(OBC%pass_oblique, G%Domain) + endif if (allocated(OBC%tres_x) .and. allocated(OBC%tres_y)) then do m=1,OBC%ntr call pass_vector(OBC%tres_x(:,:,:,m), OBC%tres_y(:,:,:,m), G%Domain, To_All+Scalar_Pair) @@ -1816,47 +2299,15 @@ subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CS) call pass_var(OBC%tres_y(:,:,:,m), G%Domain, position=NORTH_FACE) enddo endif - - ! The rx_normal and ry_normal arrays used with radiation OBCs are currently in units of grid - ! points per timestep, but if this were to be corrected to [L T-1 ~> m s-1] or [T-1 ~> s-1] to - ! permit timesteps to change between calls to the OBC code, the following would be needed: -! if ( OBC%radiation_BCs_exist_globally .and. (US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & -! ((US%m_to_L * US%s_to_T_restart) /= (US%m_to_L_restart * US%s_to_T)) ) then -! vel_rescale = (US%m_to_L * US%s_to_T_restart) / (US%m_to_L_restart * US%s_to_T) -! if (query_initialized(OBC%rx_normal, "rx_normal", restart_CS)) then -! do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB -! OBC%rx_normal(I,j,k) = vel_rescale * OBC%rx_normal(I,j,k) -! enddo ; enddo ; enddo -! endif -! if (query_initialized(OBC%ry_normal, "ry_normal", restart_CS)) then -! do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied -! OBC%ry_normal(i,J,k) = vel_rescale * OBC%ry_normal(i,J,k) -! enddo ; enddo ; enddo -! endif -! endif - - ! The oblique boundary condition terms have units of [L2 T-2 ~> m2 s-2] and may need to be rescaled. - if ( OBC%oblique_BCs_exist_globally .and. (US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & - ((US%m_to_L * US%s_to_T_restart) /= (US%m_to_L_restart * US%s_to_T)) ) then - vel2_rescale = (US%m_to_L * US%s_to_T_restart)**2 / (US%m_to_L_restart * US%s_to_T)**2 - if (query_initialized(OBC%rx_oblique, "rx_oblique", restart_CS)) then - do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB - OBC%rx_oblique(I,j,k) = vel2_rescale * OBC%rx_oblique(I,j,k) - enddo ; enddo ; enddo - endif - if (query_initialized(OBC%ry_oblique, "ry_oblique", restart_CS)) then - do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied - OBC%ry_oblique(i,J,k) = vel2_rescale * OBC%ry_oblique(i,J,k) - enddo ; enddo ; enddo - endif - if (query_initialized(OBC%cff_normal, "cff_normal", restart_CS)) then - do k=1,nz ; do J=JsdB,JedB ; do I=IsdB,IedB - OBC%cff_normal(I,J,k) = vel2_rescale * OBC%cff_normal(I,J,k) - enddo ; enddo ; enddo - endif + if (allocated(OBC%h_res_x) .and. allocated(OBC%h_res_y)) then + call pass_vector(OBC%h_res_x(:,:,:), OBC%h_res_y(:,:,:), G%Domain, To_All+Scalar_Pair) + elseif (allocated(OBC%h_res_x)) then + call pass_var(OBC%h_res_x(:,:,:), G%Domain, position=EAST_FACE) + elseif (allocated(OBC%h_res_y)) then + call pass_var(OBC%h_res_y(:,:,:), G%Domain, position=NORTH_FACE) endif -end subroutine open_boundary_init +end subroutine open_boundary_halo_update logical function open_boundary_query(OBC, apply_open_OBC, apply_specified_OBC, apply_Flather_OBC, & apply_nudged_OBC, needs_ext_seg_data) @@ -1876,7 +2327,7 @@ logical function open_boundary_query(OBC, apply_open_OBC, apply_specified_OBC, a OBC%Flather_v_BCs_exist_globally if (present(apply_nudged_OBC)) open_boundary_query = OBC%nudged_u_BCs_exist_globally .or. & OBC%nudged_v_BCs_exist_globally - if (present(needs_ext_seg_data)) open_boundary_query = OBC%needs_IO_for_data + if (present(needs_ext_seg_data)) open_boundary_query = OBC%any_needs_IO_for_data end function open_boundary_query @@ -1888,7 +2339,7 @@ subroutine open_boundary_dealloc(OBC) if (.not. associated(OBC)) return - do n=1, OBC%number_of_segments + do n=1,OBC%number_of_segments segment => OBC%segment(n) call deallocate_OBC_segment_data(segment) enddo @@ -1897,11 +2348,18 @@ subroutine open_boundary_dealloc(OBC) if (allocated(OBC%segnum_v)) deallocate(OBC%segnum_v) if (allocated(OBC%rx_normal)) deallocate(OBC%rx_normal) if (allocated(OBC%ry_normal)) deallocate(OBC%ry_normal) - if (allocated(OBC%rx_oblique)) deallocate(OBC%rx_oblique) - if (allocated(OBC%ry_oblique)) deallocate(OBC%ry_oblique) - if (allocated(OBC%cff_normal)) deallocate(OBC%cff_normal) + if (allocated(OBC%rx_oblique_u)) deallocate(OBC%rx_oblique_u) + if (allocated(OBC%ry_oblique_u)) deallocate(OBC%ry_oblique_u) + if (allocated(OBC%rx_oblique_v)) deallocate(OBC%rx_oblique_v) + if (allocated(OBC%ry_oblique_v)) deallocate(OBC%ry_oblique_v) + if (allocated(OBC%cff_normal_u)) deallocate(OBC%cff_normal_u) + 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 (allocated(OBC%h_res_x)) deallocate(OBC%h_res_x) + if (allocated(OBC%h_res_y)) deallocate(OBC%h_res_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 @@ -1913,9 +2371,9 @@ end subroutine open_boundary_end !> Sets the slope of bathymetry normal to an open boundary to zero. subroutine open_boundary_impose_normal_slope(OBC, G, depth) - type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure - type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: depth !< Bathymetry at h-points + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: depth !< Bathymetry at h-points, in [Z ~> m] or other units ! Local variables integer :: i, j, n type(OBC_segment_type), pointer :: segment => NULL() @@ -1927,7 +2385,7 @@ subroutine open_boundary_impose_normal_slope(OBC, G, depth) return do n=1,OBC%number_of_segments - segment=>OBC%segment(n) + segment => OBC%segment(n) if (.not. segment%on_pe) cycle if (segment%direction == OBC_DIRECTION_E) then I=segment%HI%IsdB @@ -1971,50 +2429,68 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv, US) if (.not.associated(OBC)) return do n=1,OBC%number_of_segments - segment=>OBC%segment(n) + segment => OBC%segment(n) if (.not. segment%on_pe) cycle if (segment%is_E_or_W) then ! Sweep along u-segments and delete the OBC for blocked points. ! Also, mask all points outside. I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed - if (G%mask2dCu(I,j) == 0) OBC%segnum_u(I,j) = OBC_NONE + if (G%mask2dCu(I,j) == 0) OBC%segnum_u(I,j) = 0 if (segment%direction == OBC_DIRECTION_W) then - G%mask2dT(i,j) = 0 + G%mask2dT(i,j) = 0.0 else - G%mask2dT(i+1,j) = 0 + G%mask2dT(i+1,j) = 0.0 endif enddo do J=segment%HI%JsdB+1,segment%HI%JedB-1 if (segment%direction == OBC_DIRECTION_W) then - G%mask2dCv(i,J) = 0 + G%mask2dCv(i,J) = 0 ; G%OBCmaskCv(i,J) = 0.0 ; G%IdyCv_OBCmask(i,J) = 0.0 else - G%mask2dCv(i+1,J) = 0 + G%mask2dCv(i+1,J) = 0.0 ; G%OBCmaskCv(i+1,J) = 0.0 ; G%IdyCv_OBCmask(i+1,J) = 0.0 endif enddo else ! Sweep along v-segments and delete the OBC for blocked points. J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied - if (G%mask2dCv(i,J) == 0) OBC%segnum_v(i,J) = OBC_NONE + if (G%mask2dCv(i,J) == 0) OBC%segnum_v(i,J) = 0 if (segment%direction == OBC_DIRECTION_S) then - G%mask2dT(i,j) = 0 + G%mask2dT(i,j) = 0.0 else - G%mask2dT(i,j+1) = 0 + G%mask2dT(i,j+1) = 0.0 endif enddo do I=segment%HI%IsdB+1,segment%HI%IedB-1 if (segment%direction == OBC_DIRECTION_S) then - G%mask2dCu(I,j) = 0 + G%mask2dCu(I,j) = 0.0 ; G%OBCmaskCu(I,j) = 0.0 ; G%IdxCu_OBCmask(I,j) = 0.0 else - G%mask2dCu(I,j+1) = 0 + G%mask2dCu(I,j+1) = 0.0 ; G%OBCmaskCu(I,j+1) = 0.0 ; G%IdxCu_OBCmask(I,j+1) = 0.0 endif enddo endif enddo do n=1,OBC%number_of_segments - segment=>OBC%segment(n) + segment => OBC%segment(n) + if (.not. (segment%on_pe .and. segment%open)) cycle + ! Set the OBCmask values to help eliminate certain terms at u- or v- OBC points. + ! Testing suggests this could be applied at all u- or v- OBC points without changing answers. + if (segment%is_E_or_W) then + I=segment%HI%IsdB + do j=segment%HI%jsd,segment%HI%jed + G%OBCmaskCu(I,j) = 0.0 ; G%IdxCu_OBCmask(I,j) = 0.0 + enddo + else + J=segment%HI%JsdB + do i=segment%HI%isd,segment%HI%ied + G%OBCmaskCv(i,J) = 0.0 ; G%IdyCv_OBCmask(i,J) = 0.0 + enddo + endif + enddo + + do n=1,OBC%number_of_segments + segment => OBC%segment(n) if (.not. segment%on_pe .or. .not. segment%specified) cycle if (segment%is_E_or_W) then ! Sweep along u-segments and for %specified BC points reset the u-point area which was masked out @@ -2033,7 +2509,7 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv, US) if (segment%direction == OBC_DIRECTION_S) then areaCv(i,J) = G%areaT(i,j+1) ! Both of these are in [L2 ~> m2] else ! North - areaCu(i,J) = G%areaT(i,j) ! Both of these are in [L2 ~> m2] + areaCv(i,J) = G%areaT(i,j) ! Both of these are in [L2 ~> m2] endif enddo endif @@ -2046,65 +2522,234 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv, US) any_U = .false. any_V = .false. do n=1,OBC%number_of_segments - segment=>OBC%segment(n) + segment => OBC%segment(n) if (.not. segment%on_pe) cycle if (segment%is_E_or_W) then I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed - if (OBC%segnum_u(I,j) /= OBC_NONE) any_U = .true. + if (OBC%segnum_u(I,j) /= 0) any_U = .true. enddo else J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied - if (OBC%segnum_v(i,J) /= OBC_NONE) any_V = .true. + if (OBC%segnum_v(i,J) /= 0) any_V = .true. enddo endif enddo - OBC%OBC_pe = .true. - if (.not.(any_U .or. any_V)) OBC%OBC_pe = .false. + OBC%u_OBCs_on_PE = any_U + OBC%v_OBCs_on_PE = any_V + OBC%OBC_pe = (any_U .or. any_V) end subroutine open_boundary_impose_land_mask -!> Make sure the OBC tracer reservoirs are initialized. -subroutine setup_OBC_tracer_reservoirs(G, GV, OBC) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(ocean_OBC_type), target, intent(inout) :: OBC !< Open boundary control structure +!> Initialize the tracer reservoirs values, perhaps only if they have not been set via a restart file. +subroutine setup_OBC_tracer_reservoirs(G, GV, OBC, restart_CS) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ocean_OBC_type), target, intent(inout) :: OBC !< Open boundary control structure + type(MOM_restart_CS), optional, intent(in) :: restart_CS !< MOM restart control structure + ! Local variables type(OBC_segment_type), pointer :: segment => NULL() + real :: I_scale ! The inverse of the scaling factor for the tracers. + ! For salinity the units would be [ppt S-1 ~> 1] + logical :: set_tres_x, set_tres_y + character(len=12) :: x_var_name, y_var_name integer :: i, j, k, m, n + do m=1,OBC%ntr + + set_tres_x = allocated(OBC%tres_x) .and. OBC%tracer_x_reservoirs_used(m) + set_tres_y = allocated(OBC%tres_y) .and. OBC%tracer_y_reservoirs_used(m) + + if (present(restart_CS)) then + ! Set the names of the reservoirs for this tracer in the restart file, and inquire whether + ! they have been initialized + if (modulo(G%HI%turns, 2) == 0) then + write(x_var_name,'("tres_x_",I3.3)') m + write(y_var_name,'("tres_y_",I3.3)') m + else + write(x_var_name,'("tres_y_",I3.3)') m + write(y_var_name,'("tres_x_",I3.3)') m + endif + if (set_tres_x) set_tres_x = .not.query_initialized(OBC%tres_x, x_var_name, restart_CS) + if (set_tres_y) set_tres_y = .not.query_initialized(OBC%tres_y, y_var_name, restart_CS) + endif + + do n=1,OBC%number_of_segments + segment => OBC%segment(n) + if (associated(segment%tr_Reg)) then ; if (allocated(segment%tr_Reg%Tr(m)%tres)) then + I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale + + if (segment%is_E_or_W .and. set_tres_x) then + I = segment%HI%IsdB + if (segment%tr_Reg%Tr(m)%is_initialized) then + do k=1,GV%ke ; do j=segment%HI%jsd,segment%HI%jed + OBC%tres_x(I,j,k,m) = I_scale * segment%tr_Reg%Tr(m)%tres(i,j,k) + enddo ; enddo + else + do k=1,GV%ke ; do j=segment%HI%jsd,segment%HI%jed + OBC%tres_x(I,j,k,m) = I_scale * segment%tr_Reg%Tr(m)%t(i,j,k) + enddo ; enddo + endif + elseif (segment%is_N_or_S .and. set_tres_y) then + J = segment%HI%JsdB + if (segment%tr_Reg%Tr(m)%is_initialized) then + do k=1,GV%ke ; do i=segment%HI%isd,segment%HI%ied + OBC%tres_y(i,J,k,m) = I_scale * segment%tr_Reg%Tr(m)%tres(i,J,k) + enddo ; enddo + else + do k=1,GV%ke ; do i=segment%HI%isd,segment%HI%ied + OBC%tres_y(i,J,k,m) = I_scale * segment%tr_Reg%Tr(m)%t(i,J,k) + enddo ; enddo + endif + endif + endif ; endif + enddo + enddo + +end subroutine setup_OBC_tracer_reservoirs + +!> Initialize the thickness reservoirs values, perhaps only if they have not been set via a restart file. +subroutine setup_OBC_thickness_reservoirs(G, GV, OBC, restart_CS) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ocean_OBC_type), target, intent(inout) :: OBC !< Open boundary control structure + type(MOM_restart_CS), optional, intent(in) :: restart_CS !< MOM restart control structure + + ! Local variables + type(OBC_segment_type), pointer :: segment => NULL() + real :: I_scale ! The inverse of the scaling factor for the thicknesses. + ! [m Z-1 ~> 1] + logical :: set_h_res_x, set_h_res_y + character(len=12) :: x_var_name, y_var_name + integer :: i, j, k, n + + set_h_res_x = allocated(OBC%h_res_x) .and. OBC%thickness_x_reservoirs_used + set_h_res_y = allocated(OBC%h_res_y) .and. OBC%thickness_y_reservoirs_used + + if (present(restart_CS)) then + ! Set the names of the reservoirs for the layer thickness in the restart file, and inquire + ! whether they have been initialized + if (modulo(G%HI%turns, 2) == 0) then + write(x_var_name,'("h_res_x")') + write(y_var_name,'("h_res_y")') + else + write(x_var_name,'("h_res_y")') + write(y_var_name,'("h_res_x")') + endif + if (set_h_res_x) set_h_res_x = .not.query_initialized(OBC%h_res_x, x_var_name, restart_CS) + if (set_h_res_y) set_h_res_y = .not.query_initialized(OBC%h_res_y, y_var_name, restart_CS) + endif + + do n=1,OBC%number_of_segments + segment => OBC%segment(n) + if (associated(segment%h_Reg)) then ; if (allocated(segment%h_Reg%h_res)) then + I_scale = 1.0 ; if (segment%h_Reg%scale /= 0.0) I_scale = 1.0 / segment%h_Reg%scale + + if (segment%is_E_or_W .and. set_h_res_x) then + I = segment%HI%IsdB + if (segment%h_Reg%is_initialized) then + do k=1,GV%ke ; do j=segment%HI%jsd,segment%HI%jed + OBC%h_res_x(I,j,k) = I_scale * segment%h_Reg%h_res(i,j,k) + enddo ; enddo + else + do k=1,GV%ke ; do j=segment%HI%jsd,segment%HI%jed + OBC%h_res_x(I,j,k) = I_scale * segment%h_Reg%h(i,j,k) + enddo ; enddo + endif + elseif (segment%is_N_or_S .and. set_h_res_y) then + J = segment%HI%JsdB + if (segment%h_Reg%is_initialized) then + do k=1,GV%ke ; do i=segment%HI%isd,segment%HI%ied + OBC%h_res_y(i,J,k) = I_scale * segment%h_Reg%h_res(i,J,k) + enddo ; enddo + else + do k=1,GV%ke ; do i=segment%HI%isd,segment%HI%ied + OBC%h_res_y(i,J,k) = I_scale * segment%h_Reg%h(i,J,k) + enddo ; enddo + endif + endif + endif ; endif + enddo + +end subroutine setup_OBC_thickness_reservoirs + +!> Record that the tracer reservoirs have been initialized so that their values are not reset later. +subroutine set_initialized_OBC_tracer_reservoirs(G, OBC, restart_CS) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(ocean_OBC_type), intent(in) :: OBC !< Open boundary control structure + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure + character(len=12) :: x_var_name, y_var_name + integer :: m + + do m=1,OBC%ntr + ! Set the names of the reservoirs for this tracer in the restart file + if (modulo(G%HI%turns, 2) == 0) then + write(x_var_name,'("tres_x_",I3.3)') m + write(y_var_name,'("tres_y_",I3.3)') m + else + write(x_var_name,'("tres_y_",I3.3)') m + write(y_var_name,'("tres_x_",I3.3)') m + endif + + if (OBC%tracer_x_reservoirs_used(m)) call set_initialized(OBC%tres_x, x_var_name, restart_CS) + if (OBC%tracer_y_reservoirs_used(m)) call set_initialized(OBC%tres_y, y_var_name, restart_CS) + enddo + +end subroutine set_initialized_OBC_tracer_reservoirs + +!> Fill segment%h_Reg from restart fields. +subroutine copy_thickness_reservoirs(OBC, G, GV) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + ! Local variables + type(OBC_segment_type), pointer :: segment => NULL() + integer :: i, j, k, n + logical :: sym + + if (.not.associated(OBC)) return + + if (.not.(OBC%thickness_x_reservoirs_used .or. OBC%thickness_y_reservoirs_used)) & + return + + ! Now thickness reservoirs do n=1,OBC%number_of_segments segment=>OBC%segment(n) - if (associated(segment%tr_Reg)) then + if (associated(segment%h_Reg)) then if (segment%is_E_or_W) then I = segment%HI%IsdB - do m=1,OBC%ntr - if (allocated(segment%tr_Reg%Tr(m)%tres)) then - do k=1,GV%ke - do j=segment%HI%jsd,segment%HI%jed - OBC%tres_x(I,j,k,m) = segment%tr_Reg%Tr(m)%t(i,j,k) - enddo + if (allocated(segment%h_Reg%h_res)) then + do k=1,GV%ke + do j=segment%HI%jsd,segment%HI%jed + segment%h_Reg%h_res(I,j,k) = segment%h_Reg%scale * OBC%h_res_x(I,j,k) enddo - endif - enddo + enddo + endif else J = segment%HI%JsdB - do m=1,OBC%ntr - if (allocated(segment%tr_Reg%Tr(m)%tres)) then - do k=1,GV%ke - do i=segment%HI%isd,segment%HI%ied - OBC%tres_y(i,J,k,m) = segment%tr_Reg%Tr(m)%t(i,J,k) - enddo + if (allocated(segment%h_Reg%h_res)) then + do k=1,GV%ke + do i=segment%HI%isd,segment%HI%ied + segment%h_Reg%h_res(i,J,k) = segment%h_Reg%scale * OBC%h_res_y(i,J,k) enddo - endif - enddo + enddo + endif endif endif enddo -end subroutine setup_OBC_tracer_reservoirs + if (OBC%debug) then + sym = G%Domain%symmetric + if (allocated(OBC%h_res_x) .and. allocated(OBC%h_res_y)) then + call uvchksum("radiation_OBCs: OBC%h_res_[xy]", OBC%h_res_x(:,:,:), OBC%h_res_y(:,:,:), G%HI, & + haloshift=0, symmetric=sym, scalar_pair=.true., unscale=1.0) + endif + endif + +end subroutine copy_thickness_reservoirs !> Apply radiation conditions to 3D u,v at open boundaries subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, dt) @@ -2112,7 +2757,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u_new !< On exit, new u values on open boundaries - !! On entry, the old time-level v but including + !! On entry, the old time-level u but including !! barotropic accelerations [L T-1 ~> m s-1]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u_old !< Original unadjusted u [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v_new !< On exit, new v values on open boundaries. @@ -2131,16 +2776,23 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, real :: cff_new, cff_avg ! denominator in oblique [L2 T-2 ~> m2 s-2] real, allocatable, dimension(:,:,:) :: & rx_tang_rad, & ! The phase speed at u-points for tangential oblique OBCs - ! in units of grid points per timestep [nondim] + ! in units of grid points per timestep [nondim], + ! discretized at the corner (PV) points. ry_tang_rad, & ! The phase speed at v-points for tangential oblique OBCs - ! in units of grid points per timestep [nondim] - rx_tang_obl, & ! The x-coefficient for tangential oblique OBCs [L2 T-2 ~> m2 s-2] - ry_tang_obl, & ! The y-coefficient for tangential oblique OBCs [L2 T-2 ~> m2 s-2] - cff_tangential ! The denominator for tangential oblique OBCs [L2 T-2 ~> m2 s-2] + ! in units of grid points per timestep [nondim], + ! discretized at the corner (PV) points. + rx_tang_obl, & ! The x-coefficient for tangential oblique OBCs [L2 T-2 ~> m2 s-2], + ! discretized at the corner (PV) points. + ry_tang_obl, & ! The y-coefficient for tangential oblique OBCs [L2 T-2 ~> m2 s-2], + ! discretized at the corner (PV) points. + cff_tangential ! The denominator for tangential oblique OBCs [L2 T-2 ~> m2 s-2], + ! discretized at the corner (PV) points. real :: eps ! A small velocity squared [L2 T-2 ~> m2 s-2] type(OBC_segment_type), pointer :: segment => NULL() integer :: i, j, k, is, ie, js, je, m, nz, n integer :: is_obc, ie_obc, js_obc, je_obc + logical :: sym + character(len=3) :: var_num is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -2149,6 +2801,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, if (.not.(OBC%open_u_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally)) & return + if (OBC%debug) call chksum_OBC_segments(OBC, G, GV, US, OBC%nk_OBC_debug) + eps = 1.0e-20*US%m_s_to_L_T**2 !! Copy previously calculated phase velocity from global arrays into segments @@ -2156,7 +2810,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, !! and needs to be revisited in the future. if (OBC%gamma_uv < 1.0) then do n=1,OBC%number_of_segments - segment=>OBC%segment(n) + segment => OBC%segment(n) if (.not. segment%on_pe) cycle if (segment%is_E_or_W .and. segment%radiation) then do k=1,GV%ke @@ -2177,18 +2831,18 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, do k=1,GV%ke I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed - segment%rx_norm_obl(I,j,k) = OBC%rx_oblique(I,j,k) - segment%ry_norm_obl(I,j,k) = OBC%ry_oblique(I,j,k) - segment%cff_normal(I,j,k) = OBC%cff_normal(I,j,k) + segment%rx_norm_obl(I,j,k) = OBC%rx_oblique_u(I,j,k) + segment%ry_norm_obl(I,j,k) = OBC%ry_oblique_u(I,j,k) + segment%cff_normal(I,j,k) = OBC%cff_normal_u(I,j,k) enddo enddo elseif (segment%is_N_or_S .and. segment%oblique) then do k=1,GV%ke J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied - segment%rx_norm_obl(i,J,k) = OBC%rx_oblique(i,J,k) - segment%ry_norm_obl(i,J,k) = OBC%ry_oblique(i,J,k) - segment%cff_normal(i,J,k) = OBC%cff_normal(i,J,k) + segment%rx_norm_obl(i,J,k) = OBC%rx_oblique_v(i,J,k) + segment%ry_norm_obl(i,J,k) = OBC%ry_oblique_v(i,J,k) + segment%cff_normal(i,J,k) = OBC%cff_normal_v(i,J,k) enddo enddo endif @@ -2197,7 +2851,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, ! Now tracers (if any) do n=1,OBC%number_of_segments - segment=>OBC%segment(n) + segment => OBC%segment(n) if (associated(segment%tr_Reg)) then if (segment%is_E_or_W) then I = segment%HI%IsdB @@ -2205,7 +2859,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, if (allocated(segment%tr_Reg%Tr(m)%tres)) then do k=1,GV%ke do j=segment%HI%jsd,segment%HI%jed - segment%tr_Reg%Tr(m)%tres(I,j,k) = OBC%tres_x(I,j,k,m) + segment%tr_Reg%Tr(m)%tres(I,j,k) = segment%tr_Reg%Tr(m)%scale * OBC%tres_x(I,j,k,m) enddo enddo endif @@ -2216,7 +2870,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, if (allocated(segment%tr_Reg%Tr(m)%tres)) then do k=1,GV%ke do i=segment%HI%isd,segment%HI%ied - segment%tr_Reg%Tr(m)%tres(i,J,k) = OBC%tres_y(i,J,k,m) + segment%tr_Reg%Tr(m)%tres(i,J,k) = segment%tr_Reg%Tr(m)%scale * OBC%tres_y(i,J,k,m) enddo enddo endif @@ -2228,7 +2882,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, gamma_u = OBC%gamma_uv rx_max = OBC%rx_max ; ry_max = OBC%rx_max do n=1,OBC%number_of_segments - segment=>OBC%segment(n) + segment => OBC%segment(n) if (.not. segment%on_pe) cycle if (segment%oblique) call gradient_at_q_points(G, GV, segment, u_new(:,:,:), v_new(:,:,:)) if (segment%direction == OBC_DIRECTION_E) then @@ -2266,21 +2920,21 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, dhdy = segment%grad_normal(J,1,k) endif if (dhdt*dhdx < 0.0) dhdt = 0.0 - cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + cff_new = max((dhdx*dhdx) + (dhdy*dhdy), eps) rx_new = min(dhdt*dhdx, cff_new*rx_max) ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) if (gamma_u < 1.0) then rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new - ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(i,J,k) + gamma_u*ry_new - cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new + ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(I,j,k) + gamma_u*ry_new + cff_avg = (1.0-gamma_u)*segment%cff_normal(I,j,k) + gamma_u*cff_new else rx_avg = rx_new ry_avg = ry_new cff_avg = cff_new endif segment%rx_norm_obl(I,j,k) = rx_avg - segment%ry_norm_obl(i,J,k) = ry_avg - segment%cff_normal(i,J,k) = cff_avg + segment%ry_norm_obl(I,j,k) = ry_avg + segment%cff_normal(I,j,k) = cff_avg segment%normal_vel(I,j,k) = ((cff_avg*u_new(I,j,k) + rx_avg*u_new(I-1,j,k)) - & (max(ry_avg,0.0)*segment%grad_normal(J-1,2,k) + & min(ry_avg,0.0)*segment%grad_normal(J,2,k))) / & @@ -2288,9 +2942,9 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, if (gamma_u < 1.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary ! implementation as a work-around to limitations in restart capability - OBC%rx_oblique(I,j,k) = segment%rx_norm_obl(I,j,k) - OBC%ry_oblique(i,J,k) = segment%ry_norm_obl(i,J,k) - OBC%cff_normal(I,j,k) = segment%cff_normal(I,j,k) + OBC%rx_oblique_u(I,j,k) = segment%rx_norm_obl(I,j,k) + OBC%ry_oblique_u(I,j,k) = segment%ry_norm_obl(I,j,k) + OBC%cff_normal_u(I,j,k) = segment%cff_normal(I,j,k) endif elseif (segment%gradient) then segment%normal_vel(I,j,k) = u_new(I-1,j,k) @@ -2408,12 +3062,12 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, dhdy = segment%grad_tan(j+1,1,k) endif if (dhdt*dhdx < 0.0) dhdt = 0.0 - cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + cff_new = max((dhdx*dhdx) + (dhdy*dhdy), eps) rx_new = min(dhdt*dhdx, cff_new*rx_max) ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) - rx_tang_obl(I,j,k) = rx_new - ry_tang_obl(i,J,k) = ry_new - cff_tangential(i,J,k) = cff_new + rx_tang_obl(I,J,k) = rx_new + ry_tang_obl(I,J,k) = ry_new + cff_tangential(I,J,k) = cff_new enddo endif enddo @@ -2511,12 +3165,12 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, endif if (dhdt*dhdx < 0.0) dhdt = 0.0 - cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + cff_new = max((dhdx*dhdx) + (dhdy*dhdy), eps) rx_new = min(dhdt*dhdx, cff_new*rx_max) ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) if (gamma_u < 1.0) then rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new - ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(i,J,k) + gamma_u*ry_new + ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(I,j,k) + gamma_u*ry_new cff_avg = (1.0-gamma_u)*segment%cff_normal(I,j,k) + gamma_u*cff_new else rx_avg = rx_new @@ -2524,8 +3178,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, cff_avg = cff_new endif segment%rx_norm_obl(I,j,k) = rx_avg - segment%ry_norm_obl(i,J,k) = ry_avg - segment%cff_normal(i,J,k) = cff_avg + segment%ry_norm_obl(I,j,k) = ry_avg + segment%cff_normal(I,j,k) = cff_avg segment%normal_vel(I,j,k) = ((cff_avg*u_new(I,j,k) + rx_avg*u_new(I+1,j,k)) - & (max(ry_avg,0.0)*segment%grad_normal(J-1,2,k) + & min(ry_avg,0.0)*segment%grad_normal(J,2,k))) / & @@ -2533,9 +3187,9 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, if (gamma_u < 1.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability - OBC%rx_oblique(I,j,k) = segment%rx_norm_obl(I,j,k) - OBC%ry_oblique(i,J,k) = segment%ry_norm_obl(i,J,k) - OBC%cff_normal(I,j,k) = segment%cff_normal(I,j,k) + OBC%rx_oblique_u(I,j,k) = segment%rx_norm_obl(I,j,k) + OBC%ry_oblique_u(I,j,k) = segment%ry_norm_obl(I,j,k) + OBC%cff_normal_u(I,j,k) = segment%cff_normal(I,j,k) endif elseif (segment%gradient) then segment%normal_vel(I,j,k) = u_new(I+1,j,k) @@ -2653,12 +3307,12 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, dhdy = segment%grad_tan(j+1,1,k) endif if (dhdt*dhdx < 0.0) dhdt = 0.0 - cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + cff_new = max((dhdx*dhdx) + (dhdy*dhdy), eps) rx_new = min(dhdt*dhdx, cff_new*rx_max) ry_new = min(cff_new,max(dhdt*dhdy,-cff_new)) - rx_tang_obl(I,j,k) = rx_new - ry_tang_obl(i,J,k) = ry_new - cff_tangential(i,J,k) = cff_new + rx_tang_obl(I,J,k) = rx_new + ry_tang_obl(I,J,k) = ry_new + cff_tangential(I,J,k) = cff_new enddo endif enddo @@ -2755,7 +3409,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, dhdx = segment%grad_normal(I,1,k) endif if (dhdt*dhdy < 0.0) dhdt = 0.0 - cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + cff_new = max((dhdx*dhdx) + (dhdy*dhdy), eps) ry_new = min(dhdt*dhdy, cff_new*ry_max) rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) if (gamma_u < 1.0) then @@ -2767,7 +3421,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, ry_avg = ry_new cff_avg = cff_new endif - segment%rx_norm_obl(I,j,k) = rx_avg + segment%rx_norm_obl(i,J,k) = rx_avg segment%ry_norm_obl(i,J,k) = ry_avg segment%cff_normal(i,J,k) = cff_avg segment%normal_vel(i,J,k) = ((cff_avg*v_new(i,J,k) + ry_avg*v_new(i,J-1,k)) - & @@ -2777,9 +3431,9 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, if (gamma_u < 1.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability - OBC%rx_oblique(I,j,k) = segment%rx_norm_obl(I,j,k) - OBC%ry_oblique(i,J,k) = segment%ry_norm_obl(i,J,k) - OBC%cff_normal(i,J,k) = segment%cff_normal(i,J,k) + OBC%rx_oblique_v(i,J,k) = segment%rx_norm_obl(i,J,k) + OBC%ry_oblique_v(i,J,k) = segment%ry_norm_obl(i,J,k) + OBC%cff_normal_v(i,J,k) = segment%cff_normal(i,J,k) endif elseif (segment%gradient) then segment%normal_vel(i,J,k) = v_new(i,J-1,k) @@ -2897,12 +3551,12 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, dhdx = segment%grad_tan(i+1,1,k) endif if (dhdt*dhdy < 0.0) dhdt = 0.0 - cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + cff_new = max((dhdx*dhdx) + (dhdy*dhdy), eps) ry_new = min(dhdt*dhdy, cff_new*ry_max) rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) - rx_tang_obl(I,j,k) = rx_new - ry_tang_obl(i,J,k) = ry_new - cff_tangential(i,J,k) = cff_new + rx_tang_obl(I,J,k) = rx_new + ry_tang_obl(I,J,k) = ry_new + cff_tangential(I,J,k) = cff_new enddo endif enddo @@ -3000,11 +3654,11 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, endif if (dhdt*dhdy < 0.0) dhdt = 0.0 - cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + cff_new = max((dhdx*dhdx) + (dhdy*dhdy), eps) ry_new = min(dhdt*dhdy, cff_new*ry_max) rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) if (gamma_u < 1.0) then - rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(I,j,k) + gamma_u*rx_new + rx_avg = (1.0-gamma_u)*segment%rx_norm_obl(i,J,k) + gamma_u*rx_new ry_avg = (1.0-gamma_u)*segment%ry_norm_obl(i,J,k) + gamma_u*ry_new cff_avg = (1.0-gamma_u)*segment%cff_normal(i,J,k) + gamma_u*cff_new else @@ -3012,7 +3666,7 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, ry_avg = ry_new cff_avg = cff_new endif - segment%rx_norm_obl(I,j,k) = rx_avg + segment%rx_norm_obl(i,J,k) = rx_avg segment%ry_norm_obl(i,J,k) = ry_avg segment%cff_normal(i,J,k) = cff_avg segment%normal_vel(i,J,k) = ((cff_avg*v_new(i,J,k) + ry_avg*v_new(i,J+1,k)) - & @@ -3022,9 +3676,9 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, if (gamma_u < 1.0) then ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability - OBC%rx_oblique(I,j,k) = segment%rx_norm_obl(I,j,k) - OBC%ry_oblique(i,J,k) = segment%ry_norm_obl(i,J,k) - OBC%cff_normal(i,J,k) = segment%cff_normal(i,J,k) + OBC%rx_oblique_v(i,J,k) = segment%rx_norm_obl(i,J,k) + OBC%ry_oblique_v(i,J,k) = segment%ry_norm_obl(i,J,k) + OBC%cff_normal_v(i,J,k) = segment%cff_normal(i,J,k) endif elseif (segment%gradient) then segment%normal_vel(i,J,k) = v_new(i,J+1,k) @@ -3142,12 +3796,12 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, dhdx = segment%grad_tan(i+1,1,k) endif if (dhdt*dhdy < 0.0) dhdt = 0.0 - cff_new = max(dhdx*dhdx + dhdy*dhdy, eps) + cff_new = max((dhdx*dhdx) + (dhdy*dhdy), eps) ry_new = min(dhdt*dhdy, cff_new*ry_max) rx_new = min(cff_new,max(dhdt*dhdx,-cff_new)) - rx_tang_obl(I,j,k) = rx_new - ry_tang_obl(i,J,k) = ry_new - cff_tangential(i,J,k) = cff_new + rx_tang_obl(I,J,k) = rx_new + ry_tang_obl(I,J,k) = ry_new + cff_tangential(I,J,k) = cff_new enddo endif enddo @@ -3215,6 +3869,29 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, call pass_vector(u_new, v_new, G%Domain, clock=id_clock_pass) + if (OBC%debug) then + sym = G%Domain%symmetric + if (OBC%radiation_BCs_exist_globally) then + call uvchksum("radiation_OBCs: OBC%r[xy]_normal", OBC%rx_normal, OBC%ry_normal, G%HI, & + haloshift=0, symmetric=sym, scalar_pair=.true., unscale=1.0) + endif + if (OBC%oblique_BCs_exist_globally) then + call uvchksum("radiation_OBCs: OBC%r[xy]_oblique_[uv]", OBC%rx_oblique_u, OBC%ry_oblique_v, G%HI, & + haloshift=0, symmetric=sym, scalar_pair=.true., unscale=1.0/US%L_T_to_m_s**2) + call uvchksum("radiation_OBCs: OBC%r[yx]_oblique_[uv]", OBC%ry_oblique_u, OBC%rx_oblique_v, G%HI, & + haloshift=0, symmetric=sym, scalar_pair=.true., unscale=1.0/US%L_T_to_m_s**2) + call uvchksum("radiation_OBCs: OBC%cff_normal_[uv]", OBC%cff_normal_u, OBC%cff_normal_v, G%HI, & + haloshift=0, symmetric=sym, scalar_pair=.true., unscale=1.0/US%L_T_to_m_s**2) + endif + if ((OBC%ntr > 0) .and. allocated(OBC%tres_x) .and. allocated(OBC%tres_y)) then + do m=1,OBC%ntr + write(var_num,'(I3.3)') m + call uvchksum("radiation_OBCs: OBC%tres_[xy]_"//var_num, OBC%tres_x(:,:,:,m), OBC%tres_y(:,:,:,m), G%HI, & + haloshift=0, symmetric=sym, scalar_pair=.true., unscale=1.0) + enddo + endif + endif + end subroutine radiation_open_bdry_conds !> Applies OBC values stored in segments to 3d u,v fields @@ -3257,11 +3934,11 @@ end subroutine open_boundary_apply_normal_flow !> Applies zero values to 3d u,v fields on OBC segments subroutine open_boundary_zero_normal_flow(OBC, G, GV, u, v) ! Arguments - type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< u field to update on open boundaries - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< v field to update on open boundaries + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< u field to update on open boundaries [arbitrary] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< v field to update on open boundaries [arbitrary] ! Local variables integer :: i, j, k, n type(OBC_segment_type), pointer :: segment => NULL() @@ -3319,9 +3996,9 @@ subroutine gradient_at_q_points(G, GV, segment, uvel, vvel) do k=1,GV%ke do J=max(segment%HI%jsd, G%HI%jsd+1),min(segment%HI%jed, G%HI%jed-1) segment%grad_gradient(j,1,k) = (((vvel(i-1,J,k) - vvel(i-2,J,k))*G%IdxBu(I-2,J)) - & - (vvel(i-1,J-1,k) - vvel(i-2,J-1,k))*G%IdxBu(I-2,J-1)) * G%mask2dCu(I-2,j) + ((vvel(i-1,J-1,k) - vvel(i-2,J-1,k))*G%IdxBu(I-2,J-1))) * G%mask2dCu(I-2,j) segment%grad_gradient(j,2,k) = (((vvel(i,J,k) - vvel(i-1,J,k))*G%IdxBu(I-1,J)) - & - (vvel(i,J-1,k) - vvel(i-1,J-1,k))*G%IdxBu(I-1,J-1)) * G%mask2dCu(I-1,j) + ((vvel(i,J-1,k) - vvel(i-1,J-1,k))*G%IdxBu(I-1,J-1))) * G%mask2dCu(I-1,j) enddo enddo endif @@ -3345,9 +4022,9 @@ subroutine gradient_at_q_points(G, GV, segment, uvel, vvel) do k=1,GV%ke do J=max(segment%HI%jsd, G%HI%jsd+1),min(segment%HI%jed, G%HI%jed-1) segment%grad_gradient(j,1,k) = (((vvel(i+3,J,k) - vvel(i+2,J,k))*G%IdxBu(I+2,J)) - & - (vvel(i+3,J-1,k) - vvel(i+2,J-1,k))*G%IdxBu(I+2,J-1)) * G%mask2dCu(I+2,j) + ((vvel(i+3,J-1,k) - vvel(i+2,J-1,k))*G%IdxBu(I+2,J-1))) * G%mask2dCu(I+2,j) segment%grad_gradient(j,2,k) = (((vvel(i+2,J,k) - vvel(i+1,J,k))*G%IdxBu(I+1,J)) - & - (vvel(i+2,J-1,k) - vvel(i+1,J-1,k))*G%IdxBu(I+1,J-1)) * G%mask2dCu(I+1,j) + ((vvel(i+2,J-1,k) - vvel(i+1,J-1,k))*G%IdxBu(I+1,J-1))) * G%mask2dCu(I+1,j) enddo enddo endif @@ -3373,9 +4050,9 @@ subroutine gradient_at_q_points(G, GV, segment, uvel, vvel) do k=1,GV%ke do I=max(segment%HI%isd, G%HI%isd+1),min(segment%HI%ied, G%HI%ied-1) segment%grad_gradient(i,1,k) = (((uvel(I,j-1,k) - uvel(I,j-2,k))*G%IdyBu(I,J-2)) - & - (uvel(I-1,j-1,k) - uvel(I-1,j-2,k))*G%IdyBu(I-1,J-2)) * G%mask2dCv(i,J-2) + ((uvel(I-1,j-1,k) - uvel(I-1,j-2,k))*G%IdyBu(I-1,J-2))) * G%mask2dCv(i,J-2) segment%grad_gradient(i,2,k) = (((uvel(I,j,k) - uvel(I,j-1,k))*G%IdyBu(I,J-1)) - & - (uvel(I-1,j,k) - uvel(I-1,j-1,k))*G%IdyBu(I-1,J-1)) * G%mask2dCv(i,J-1) + ((uvel(I-1,j,k) - uvel(I-1,j-1,k))*G%IdyBu(I-1,J-1))) * G%mask2dCv(i,J-1) enddo enddo endif @@ -3399,9 +4076,9 @@ subroutine gradient_at_q_points(G, GV, segment, uvel, vvel) do k=1,GV%ke do I=max(segment%HI%isd, G%HI%isd+1),min(segment%HI%ied, G%HI%ied-1) segment%grad_gradient(i,1,k) = (((uvel(I,j+3,k) - uvel(I,j+2,k))*G%IdyBu(I,J+2)) - & - (uvel(I-1,j+3,k) - uvel(I-1,j+2,k))*G%IdyBu(I-1,J+2)) * G%mask2dCv(i,J+2) + ((uvel(I-1,j+3,k) - uvel(I-1,j+2,k))*G%IdyBu(I-1,J+2))) * G%mask2dCv(i,J+2) segment%grad_gradient(i,2,k) = (((uvel(I,j+2,k) - uvel(I,j+1,k))*G%IdyBu(I,J+1)) - & - (uvel(I-1,j+2,k) - uvel(I-1,j+1,k))*G%IdyBu(I-1,J+1)) * G%mask2dCv(i,J+1) + ((uvel(I-1,j+2,k) - uvel(I-1,j+1,k))*G%IdyBu(I-1,J+1))) * G%mask2dCv(i,J+1) enddo enddo endif @@ -3411,60 +4088,8 @@ subroutine gradient_at_q_points(G, GV, segment, uvel, vvel) end subroutine gradient_at_q_points -!> Sets the initial values of the tracer open boundary conditions. -!! Redoing this elsewhere. -subroutine set_tracer_data(OBC, tv, h, G, GV, PF) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(ocean_OBC_type), target, intent(in) :: OBC !< Open boundary structure - type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Thickness - type(param_file_type), intent(in) :: PF !< Parameter file handle - - type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list - integer :: i, j, k, n - - ! For now, there are no radiation conditions applied to the thicknesses, since - ! the thicknesses might not be physically motivated. Instead, sponges should be - ! used to enforce the near-boundary layer structure. - - if (associated(tv%T)) then - - call pass_var(tv%T, G%Domain) - call pass_var(tv%S, G%Domain) - - do n=1,OBC%number_of_segments - segment => OBC%segment(n) - if (.not. segment%on_pe) cycle - - if (segment%direction == OBC_DIRECTION_E) then - I=segment%HI%IsdB - do k=1,GV%ke ; do j=segment%HI%jsd,segment%HI%jed - tv%T(i+1,j,k) = tv%T(i,j,k) ; tv%S(i+1,j,k) = tv%S(i,j,k) - enddo ; enddo - elseif (segment%direction == OBC_DIRECTION_W) then - I=segment%HI%IsdB - do k=1,GV%ke ; do j=segment%HI%jsd,segment%HI%jed - tv%T(i,j,k) = tv%T(i+1,j,k) ; tv%S(i,j,k) = tv%S(i+1,j,k) - enddo ; enddo - elseif (segment%direction == OBC_DIRECTION_N) then - J=segment%HI%JsdB - do k=1,GV%ke ; do i=segment%HI%isd,segment%HI%ied - tv%T(i,j+1,k) = tv%T(i,j,k) ; tv%S(i,j+1,k) = tv%S(i,j,k) - enddo ; enddo - elseif (segment%direction == OBC_DIRECTION_S) then - J=segment%HI%JsdB - do k=1,GV%ke ; do i=segment%HI%isd,segment%HI%ied - tv%T(i,j,k) = tv%T(i,j+1,k) ; tv%S(i,j,k) = tv%S(i,j+1,k) - enddo ; enddo - endif - enddo - endif - -end subroutine set_tracer_data - -!> Needs documentation -function lookup_seg_field(OBC_seg,field) +!> Return the field number on the segment for the named field, or -1 if there is no field with that name. +function lookup_seg_field(OBC_seg, field) type(OBC_segment_type), intent(in) :: OBC_seg !< OBC segment character(len=32), intent(in) :: field !< The field name integer :: lookup_seg_field @@ -3481,6 +4106,21 @@ function lookup_seg_field(OBC_seg,field) end function lookup_seg_field +!> Return the tracer index from its name +function get_tracer_index(OBC_seg,tr_name) + type(OBC_segment_type), pointer :: OBC_seg !< OBC segment + character(len=*), intent(in) :: tr_name !< The field name + integer :: get_tracer_index, it + get_tracer_index = -1 + it = 1 + do while(allocated(OBC_seg%tr_Reg%Tr(it)%t)) + if (trim(OBC_seg%tr_Reg%Tr(it)%name) == trim(tr_name)) then + get_tracer_index = it + exit + endif + it = it + 1 + enddo +end function get_tracer_index !> Allocate segment data fields subroutine allocate_OBC_segment_data(OBC, segment) @@ -3490,7 +4130,6 @@ subroutine allocate_OBC_segment_data(OBC, segment) integer :: isd, ied, jsd, jed integer :: IsdB, IedB, JsdB, JedB integer :: IscB, IecB, JscB, JecB - character(len=40) :: mdl = "allocate_OBC_segment_data" ! This subroutine's name. isd = segment%HI%isd ; ied = segment%HI%ied jsd = segment%HI%jsd ; jed = segment%HI%jed @@ -3503,26 +4142,35 @@ subroutine allocate_OBC_segment_data(OBC, segment) if (segment%is_E_or_W) then ! If these are just Flather, change update_OBC_segment_data accordingly - allocate(segment%Cg(IsdB:IedB,jsd:jed), source=0.0) allocate(segment%Htot(IsdB:IedB,jsd:jed), source=0.0) - allocate(segment%h(IsdB:IedB,jsd:jed,OBC%ke), source=0.0) - allocate(segment%eta(IsdB:IedB,jsd:jed), source=0.0) + ! Allocate dZtot with extra values at the end to avoid segmentation faults in cases where + ! it is interpolated to OBC vorticity points. + allocate(segment%dZtot(IsdB:IedB,jsd-1:jed+1), source=0.0) + allocate(segment%SSH(IsdB:IedB,jsd:jed), source=0.0) + allocate(segment%tidal_elev(IsdB:IedB,jsd:jed), source=0.0) if (segment%radiation) & allocate(segment%rx_norm_rad(IsdB:IedB,jsd:jed,OBC%ke), source=0.0) allocate(segment%normal_vel(IsdB:IedB,jsd:jed,OBC%ke), source=0.0) allocate(segment%normal_vel_bt(IsdB:IedB,jsd:jed), source=0.0) allocate(segment%normal_trans(IsdB:IedB,jsd:jed,OBC%ke), source=0.0) + allocate(segment%normal_trans_bt(IsdB:IedB,jsd:jed), source=0.0) + allocate(segment%tidal_vn(IsdB:IedB,jsd:jed), source=0.0) if (segment%nudged) & allocate(segment%nudged_normal_vel(IsdB:IedB,jsd:jed,OBC%ke), source=0.0) - if (segment%radiation_tan .or. segment%nudged_tan .or. segment%specified_tan .or. & - segment%oblique_tan .or. OBC%computed_vorticity .or. OBC%computed_strain) & + if (segment%radiation_tan .or. segment%nudged_tan .or. & + segment%specified_tan .or. segment%oblique_tan .or. & + (OBC%vorticity_config == OBC_VORTICITY_COMPUTED) .or. & + (OBC%strain_config == OBC_STRAIN_COMPUTED)) then allocate(segment%tangential_vel(IsdB:IedB,JsdB:JedB,OBC%ke), source=0.0) + allocate(segment%tidal_vt(IsdB:IedB,JsdB:JedB), source=0.0) + endif if (segment%nudged_tan) & allocate(segment%nudged_tangential_vel(IsdB:IedB,JsdB:JedB,OBC%ke), source=0.0) if (segment%nudged_grad) & allocate(segment%nudged_tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke), source=0.0) - if (OBC%specified_vorticity .or. OBC%specified_strain .or. segment%radiation_grad .or. & - segment%oblique_grad .or. segment%specified_grad) & + if (segment%radiation_grad .or. segment%oblique_grad .or. segment%specified_grad .or. & + (OBC%vorticity_config == OBC_VORTICITY_SPECIFIED) .or. & + (OBC%strain_config == OBC_STRAIN_SPECIFIED)) & allocate(segment%tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke), source=0.0) if (segment%oblique) then allocate(segment%grad_normal(JsdB:JedB,2,OBC%ke), source=0.0) @@ -3538,26 +4186,35 @@ subroutine allocate_OBC_segment_data(OBC, segment) if (segment%is_N_or_S) then ! If these are just Flather, change update_OBC_segment_data accordingly - allocate(segment%Cg(isd:ied,JsdB:JedB), source=0.0) allocate(segment%Htot(isd:ied,JsdB:JedB), source=0.0) - allocate(segment%h(isd:ied,JsdB:JedB,OBC%ke), source=0.0) - allocate(segment%eta(isd:ied,JsdB:JedB), source=0.0) + ! Allocate dZtot with extra values at the end to avoid segmentation faults in cases where + ! it is interpolated to OBC vorticity points. + allocate(segment%dZtot(isd-1:ied+1,JsdB:JedB), source=0.0) + allocate(segment%SSH(isd:ied,JsdB:JedB), source=0.0) + allocate(segment%tidal_elev(isd:ied,JsdB:JedB), source=0.0) if (segment%radiation) & allocate(segment%ry_norm_rad(isd:ied,JsdB:JedB,OBC%ke), source=0.0) allocate(segment%normal_vel(isd:ied,JsdB:JedB,OBC%ke), source=0.0) allocate(segment%normal_vel_bt(isd:ied,JsdB:JedB), source=0.0) allocate(segment%normal_trans(isd:ied,JsdB:JedB,OBC%ke), source=0.0) + allocate(segment%normal_trans_bt(isd:ied,JsdB:JedB), source=0.0) + allocate(segment%tidal_vn(isd:ied,JsdB:JedB), source=0.0) if (segment%nudged) & allocate(segment%nudged_normal_vel(isd:ied,JsdB:JedB,OBC%ke), source=0.0) - if (segment%radiation_tan .or. segment%nudged_tan .or. segment%specified_tan .or. & - segment%oblique_tan .or. OBC%computed_vorticity .or. OBC%computed_strain) & + if (segment%radiation_tan .or. segment%nudged_tan .or. & + segment%specified_tan .or. segment%oblique_tan .or. & + (OBC%vorticity_config == OBC_VORTICITY_COMPUTED) .or. & + (OBC%strain_config == OBC_STRAIN_COMPUTED)) then allocate(segment%tangential_vel(IsdB:IedB,JsdB:JedB,OBC%ke), source=0.0) + allocate(segment%tidal_vt(IsdB:IedB,JsdB:JedB), source=0.0) + endif if (segment%nudged_tan) & allocate(segment%nudged_tangential_vel(IsdB:IedB,JsdB:JedB,OBC%ke), source=0.0) if (segment%nudged_grad) & allocate(segment%nudged_tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke), source=0.0) - if (OBC%specified_vorticity .or. OBC%specified_strain .or. segment%radiation_grad .or. & - segment%oblique_grad .or. segment%specified_grad) & + if (segment%radiation_grad .or. segment%oblique_grad .or. segment%specified_grad .or. & + (OBC%vorticity_config == OBC_VORTICITY_SPECIFIED) .or. & + (OBC%strain_config == OBC_STRAIN_SPECIFIED)) & allocate(segment%tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke), source=0.0) if (segment%oblique) then allocate(segment%grad_normal(IsdB:IedB,2,OBC%ke), source=0.0) @@ -3576,15 +4233,13 @@ end subroutine allocate_OBC_segment_data !> Deallocate segment data fields subroutine deallocate_OBC_segment_data(segment) type(OBC_segment_type), intent(inout) :: segment !< Open boundary segment - ! Local variables - character(len=40) :: mdl = "deallocate_OBC_segment_data" ! This subroutine's name. if (.not. segment%on_pe) return - if (allocated(segment%Cg)) deallocate(segment%Cg) if (allocated(segment%Htot)) deallocate(segment%Htot) - if (allocated(segment%h)) deallocate(segment%h) - if (allocated(segment%eta)) deallocate(segment%eta) + if (allocated(segment%dZtot)) deallocate(segment%dZtot) + if (allocated(segment%SSH)) deallocate(segment%SSH) + if (allocated(segment%tidal_elev)) deallocate(segment%tidal_elev) if (allocated(segment%rx_norm_rad)) deallocate(segment%rx_norm_rad) if (allocated(segment%ry_norm_rad)) deallocate(segment%ry_norm_rad) if (allocated(segment%rx_norm_obl)) deallocate(segment%rx_norm_obl) @@ -3596,6 +4251,9 @@ subroutine deallocate_OBC_segment_data(segment) if (allocated(segment%normal_vel)) deallocate(segment%normal_vel) if (allocated(segment%normal_vel_bt)) deallocate(segment%normal_vel_bt) if (allocated(segment%normal_trans)) deallocate(segment%normal_trans) + if (allocated(segment%normal_trans_bt)) deallocate(segment%normal_trans_Bt) + if (allocated(segment%tidal_vn)) deallocate(segment%tidal_vn) + if (allocated(segment%tidal_vt)) deallocate(segment%tidal_vt) if (allocated(segment%nudged_normal_vel)) deallocate(segment%nudged_normal_vel) if (allocated(segment%tangential_vel)) deallocate(segment%tangential_vel) if (allocated(segment%nudged_tangential_vel)) deallocate(segment%nudged_tangential_vel) @@ -3603,7 +4261,7 @@ subroutine deallocate_OBC_segment_data(segment) if (allocated(segment%tangential_grad)) deallocate(segment%tangential_grad) if (associated(segment%tr_Reg)) call segment_tracer_registry_end(segment%tr_Reg) - + if (associated(segment%h_Reg)) call segment_thickness_registry_end(segment%h_Reg) end subroutine deallocate_OBC_segment_data @@ -3621,7 +4279,7 @@ subroutine open_boundary_test_extern_uv(G, GV, OBC, u, v) if (.not. associated(OBC)) return - do n = 1, OBC%number_of_segments + do n=1,OBC%number_of_segments do k = 1, GV%ke if (OBC%segment(n)%is_N_or_S) then J = OBC%segment(n)%HI%JsdB @@ -3665,9 +4323,9 @@ subroutine open_boundary_test_extern_h(G, GV, OBC, h) if (.not. associated(OBC)) return - silly_h = GV%Z_to_H*OBC%silly_h + silly_h = GV%Z_to_H * OBC%silly_h ! This rescaling is here because GV was initialized after OBC. - do n = 1, OBC%number_of_segments + do n=1,OBC%number_of_segments do k = 1, GV%ke if (OBC%segment(n)%is_N_or_S) then J = OBC%segment(n)%HI%JsdB @@ -3697,644 +4355,575 @@ subroutine open_boundary_test_extern_h(G, GV, OBC, h) end subroutine open_boundary_test_extern_h -!> Update the OBC values on the segments. -subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Thickness [H ~> m or kg m-2] - type(time_type), intent(in) :: Time !< Model time +!> Read OBC values on the segments from files +subroutine read_OBC_segment_data(G, GV, US, OBC, tv, h, Time) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Thickness [H ~> m or kg m-2] + type(time_type), intent(in) :: Time !< Model time + ! Local variables - integer :: c, i, j, k, is, ie, js, je, isd, ied, jsd, jed - integer :: IsdB, IedB, JsdB, JedB, n, m, nz - character(len=40) :: mdl = "update_OBC_segment_data" ! This subroutine's name. - character(len=200) :: filename, OBC_file, inputdir ! Strings for file/path + integer :: i, j, k, n, m + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB type(OBC_segment_type), pointer :: segment => NULL() - integer, dimension(4) :: siz real, dimension(:,:,:), pointer :: tmp_buffer_in => NULL() ! Unrotated input [various units] integer :: ni_seg, nj_seg ! number of src gridpoints along the segments integer :: ni_buf, nj_buf ! Number of filled values in tmp_buffer - integer :: i2, j2 ! indices for referencing local domain array - integer :: is_obc, ie_obc, js_obc, je_obc ! segment indices within local domain - integer :: ishift, jshift ! offsets for staggered locations + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Distance between the interfaces around a layer [Z ~> m] real, dimension(:,:,:), allocatable, target :: tmp_buffer ! A buffer for input data [various units] - real, dimension(:), allocatable :: h_stack ! Thicknesses at corner points [H ~> m or kg m-2] - integer :: is_obc2, js_obc2 - real :: net_H_src ! Total thickness of the incoming flow in the source field [H ~> m or kg m-2] - real :: net_H_int ! Total thickness of the incoming flow in the model [H ~> m or kg m-2] + real :: dz_stack(SZK_(GV)) ! Distance between the interfaces at corner points [Z ~> m] + integer :: i_seg_offset, j_seg_offset, bug_offset + real :: net_dz_src ! Total vertical extent of the incoming flow in the source field [Z ~> m] + real :: net_dz_int ! Total vertical extent of the incoming flow in the model [Z ~> m] real :: scl_fac ! A scaling factor to compensate for differences in total thicknesses [nondim] - real :: tidal_vel ! Interpolated tidal velocity at the OBC points [m s-1] - real :: tidal_elev ! Interpolated tidal elevation at the OBC points [m] - 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] - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - nz=GV%ke - - turns = G%HI%turns + logical :: flip_buffer ! If true, the input buffer needs to be transposed if (.not. associated(OBC)) return + if (OBC%user_BCs_set_globally) return - if (OBC%add_tide_constituents) time_delta = US%s_to_T * time_type_to_real(Time - OBC%time_ref) + turns = modulo(G%HI%turns, 4) + dz(:,:,:) = 0.0 + call thickness_to_dz(h, tv, dz, G, GV, US) + call pass_var(dz, G%Domain) - do n = 1, OBC%number_of_segments + do n=1,OBC%number_of_segments segment => OBC%segment(n) - if (.not. segment%on_pe) cycle ! continue to next segment if not in computational domain - - ! NOTE: These are in segment%HI, but defined slightly differently - ni_seg = segment%ie_obc-segment%is_obc+1 - nj_seg = segment%je_obc-segment%js_obc+1 - is_obc = max(segment%is_obc,isd-1) - ie_obc = min(segment%ie_obc,ied) - js_obc = max(segment%js_obc,jsd-1) - je_obc = min(segment%je_obc,jed) - -! Calculate auxiliary fields at staggered locations. -! Segment indices are on q points: -! -! |-----------|------------|-----------|-----------| J_obc -! Is_obc Ie_obc -! -! i2 has to start at Is_obc+1 and end at Ie_obc. -! j2 is J_obc and jshift has to be +1 at both the north and south. - - ! calculate auxiliary fields at staggered locations - ishift=0;jshift=0 + if (.not. segment%on_pe) cycle ! continue to next segment if not in data domain + + isd = segment%HI%isd ; ied = segment%HI%ied ; IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + jsd = segment%HI%jsd ; jed = segment%HI%jed ; JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + + ni_seg = segment%ie_obc - segment%is_obc + 1 ! Global number of q points + nj_seg = segment%je_obc - segment%js_obc + 1 ! Global number of q points + i_seg_offset = G%idg_offset - segment%HI%IsgB + j_seg_offset = G%jdg_offset - segment%HI%JsgB + + ! Calculate auxiliary fields at staggered locations + segment%dZtot(:,:) = 0.0 if (segment%is_E_or_W) then - allocate(normal_trans_bt(segment%HI%IsdB:segment%HI%IedB,segment%HI%jsd:segment%HI%jed), source=0.0) - if (segment%direction == OBC_DIRECTION_W) ishift=1 - I=segment%HI%IsdB - do j=segment%HI%jsd,segment%HI%jed - segment%Htot(I,j) = 0.0 - do k=1,GV%ke - segment%h(I,j,k) = h(i+ishift,j,k) - segment%Htot(I,j) = segment%Htot(I,j) + segment%h(I,j,k) - enddo - segment%Cg(I,j) = sqrt(GV%g_prime(1)*segment%Htot(I,j)*GV%H_to_Z) - enddo - else! (segment%direction == OBC_DIRECTION_N .or. segment%direction == OBC_DIRECTION_S) - allocate(normal_trans_bt(segment%HI%isd:segment%HI%ied,segment%HI%JsdB:segment%HI%JedB), source=0.0) - if (segment%direction == OBC_DIRECTION_S) jshift=1 - J=segment%HI%JsdB - do i=segment%HI%isd,segment%HI%ied - segment%Htot(i,J) = 0.0 - do k=1,GV%ke - segment%h(i,J,k) = h(i,j+jshift,k) - segment%Htot(i,J) = segment%Htot(i,J) + segment%h(i,J,k) - enddo - segment%Cg(i,J) = sqrt(GV%g_prime(1)*segment%Htot(i,J)*GV%H_to_Z) - enddo + I = IsdB + ! dZtot may extend one point past the end of the segment on the current PE for use at vorticity points + do k = 1, GV%ke ; do j = max(jsd-1, G%jsd), min(jed+1, G%jed) + segment%dZtot(I,j) = segment%dZtot(I,j) + dz(isd,j,k) + enddo ; enddo + else ! (segment%direction == OBC_DIRECTION_N .or. segment%direction == OBC_DIRECTION_S) + J = JsdB + ! dZtot may extend one point past the end of the segment on the current PE for use at vorticity points + do k = 1, GV%ke ; do i = max(isd-1, G%isd), min(ied+1, G%ied) + segment%dZtot(i,J) = segment%dZtot(i,J) + dz(i,jsd,k) + enddo ; enddo endif - allocate(h_stack(GV%ke), source=0.0) - do m = 1,segment%num_fields - if (segment%field(m)%fid > 0) then - siz(1)=size(segment%field(m)%buffer_src,1) - siz(2)=size(segment%field(m)%buffer_src,2) - siz(3)=size(segment%field(m)%buffer_src,3) - if (.not.allocated(segment%field(m)%buffer_dst)) then - if (siz(3) /= segment%field(m)%nk_src) call MOM_error(FATAL,'nk_src inconsistency') - if (segment%field(m)%nk_src > 1) then - if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke)) - elseif (segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,siz(3))) ! 3rd dim is constituent - elseif (segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase' .or. & - segment%field(m)%name == 'SSHamp' .or. segment%field(m)%name == 'SSHphase') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,siz(3))) ! 3rd dim is constituent - else - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,GV%ke)) - endif - else - if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke)) - elseif (segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,siz(3))) ! 3rd dim is constituent - elseif (segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase' .or. & - segment%field(m)%name == 'SSHamp' .or. segment%field(m)%name == 'SSHphase') then - allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,siz(3))) ! 3rd dim is constituent - else - allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,GV%ke)) - endif - endif - else - if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX' .or. & - segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) - else - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,1)) - endif - else - if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY' .or. & - segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) - else - allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,1)) - endif - endif - endif - segment%field(m)%buffer_dst(:,:,:)=0.0 + ! Read data from files to buffer_src + do m=1,segment%num_fields + if (segment%field(m)%required .and. (.not. allocated(segment%field(m)%buffer_dst))) & + call MOM_error(FATAL, 'buffer_dst not allocated') + + if ( (.not. segment%field(m)%use_IO) .or. & ! .and. (.not. segment%field(m)%required) + (segment%field(m)%bgc_tracer .and. (.not. OBC%update_OBC_seg_data)) ) & + !This field may not require a high frequency OBC segment update and might be allowed + !a less frequent update as set by the parameter update_OBC_period_max in MOM.F90. + !Cycle if it is not the time to update OBC segment data for this field. + cycle + + ! read source data interpolated to the current model time + ! NOTE: buffer is sized for vertex points, but may be used for faces + if (segment%is_E_or_W) then + if (OBC%brushcutter_mode) then + allocate(tmp_buffer(1,nj_seg*2-1,segment%field(m)%nk_src)) ! segment data is currently on supergrid + else + allocate(tmp_buffer(1,nj_seg,segment%field(m)%nk_src)) ! segment data is currently on native grid endif - ! read source data interpolated to the current model time - ! NOTE: buffer is sized for vertex points, but may be used for faces - if (siz(1)==1) then - if (OBC%brushcutter_mode) then - allocate(tmp_buffer(1,nj_seg*2-1,segment%field(m)%nk_src)) ! segment data is currently on supergrid - else - allocate(tmp_buffer(1,nj_seg,segment%field(m)%nk_src)) ! segment data is currently on supergrid - endif + else + if (OBC%brushcutter_mode) then + allocate(tmp_buffer(ni_seg*2-1,1,segment%field(m)%nk_src)) ! segment data is currently on supergrid else - if (OBC%brushcutter_mode) then - allocate(tmp_buffer(ni_seg*2-1,1,segment%field(m)%nk_src)) ! segment data is currently on supergrid - else - allocate(tmp_buffer(ni_seg,1,segment%field(m)%nk_src)) ! segment data is currently on supergrid - endif + allocate(tmp_buffer(ni_seg,1,segment%field(m)%nk_src)) ! segment data is currently on native grid endif + endif - ! TODO: Since we conditionally rotate a subset of tmp_buffer_in after - ! reading the value, it is currently not possible to use the rotated - ! implementation of time_interp_extern. - ! For now, we must explicitly allocate and rotate this array. - if (turns /= 0) then - if (modulo(turns, 2) /= 0) then - allocate(tmp_buffer_in(size(tmp_buffer, 2), size(tmp_buffer, 1), size(tmp_buffer, 3))) + ! TODO: Since we conditionally rotate a subset of tmp_buffer_in after + ! reading the value, it is currently not possible to use the rotated + ! implementation of time_interp_extern. + ! For now, we must explicitly allocate and rotate this array. + if (turns /= 0) then + if (modulo(turns, 2) /= 0) then + allocate(tmp_buffer_in(size(tmp_buffer, 2), size(tmp_buffer, 1), size(tmp_buffer, 3))) + else + allocate(tmp_buffer_in(size(tmp_buffer, 1), size(tmp_buffer, 2), size(tmp_buffer, 3))) + endif + else + tmp_buffer_in => tmp_buffer + endif + + ! This is where the data values are actually read in. + call time_interp_external(segment%field(m)%handle, Time, tmp_buffer_in, scale=segment%field(m)%scale) + + ! NOTE: Rotation of face-points require that we skip the final value when not in brushcutter mode. + if (turns /= 0) then + flip_buffer = ((turns==1) .or. (turns==3)) + if (OBC%brushcutter_mode .or. (.not.flip_buffer)) then + call rotate_array(tmp_buffer_in, turns, tmp_buffer) + elseif (flip_buffer .and. segment%is_E_or_W .and. segment%field(m)%on_face) then + nj_buf = size(tmp_buffer, 2) - 1 + call rotate_array(tmp_buffer_in(:nj_buf,:,:), turns, tmp_buffer(:,:nj_buf,:)) + elseif (flip_buffer .and. segment%is_N_or_S .and. segment%field(m)%on_face) then + ni_buf = size(tmp_buffer, 1) - 1 + call rotate_array(tmp_buffer_in(:,:ni_buf,:), turns, tmp_buffer(:ni_buf,:,:)) + else + call rotate_array(tmp_buffer_in, turns, tmp_buffer) + endif + + if (((segment%field(m)%name == 'U') .and. ((turns==1).or.(turns==2))) .or. & + ((segment%field(m)%name == 'V') .and. ((turns==2).or.(turns==3))) .or. & + ((segment%field(m)%name == 'Vamp') .and. ((turns==2).or.(turns==3))) .or. & + ((segment%field(m)%name == 'Uamp') .and. ((turns==1).or.(turns==2))) .or. & + ((segment%field(m)%name == 'DVDX') .and. ((turns==1).or.(turns==3))) .or. & + ((segment%field(m)%name == 'DUDY') .and. ((turns==1).or.(turns==3))) ) then + tmp_buffer(:,:,:) = -tmp_buffer(:,:,:) + endif + endif + + if (OBC%brushcutter_mode) then + ! In brushcutter mode, the input data includes vales at both the vorticity point nodes and + ! the velocity point faces of the OBC segments. The vorticity node values are at the odd + ! positions in tmp_buffer, while the faces are at the even points. The bug that is being + ! corrected here is the use of the odd indexed points for both the corners and the faces. + bug_offset = 0 ; if (OBC%hor_index_bug) bug_offset = -1 + if (segment%is_E_or_W) then + if (.not.segment%field(m)%on_face) then + segment%field(m)%buffer_src(IsdB,:,:) = & + tmp_buffer(1, 2*(JsdB+j_seg_offset+1)-1:2*(JedB+j_seg_offset)+1:2, :) else - allocate(tmp_buffer_in(size(tmp_buffer, 1), size(tmp_buffer, 2), size(tmp_buffer, 3))) + segment%field(m)%buffer_src(IsdB,:,:) = & + tmp_buffer(1, 2*(JsdB+j_seg_offset+1)+bug_offset:2*(JedB+j_seg_offset):2, :) endif else - tmp_buffer_in => tmp_buffer + if (.not.segment%field(m)%on_face) then + segment%field(m)%buffer_src(:,JsdB,:) = & + tmp_buffer(2*(IsdB+i_seg_offset+1)-1:2*(IedB+i_seg_offset)+1:2, 1, :) + else + segment%field(m)%buffer_src(:,JsdB,:) = & + tmp_buffer(2*(IsdB+i_seg_offset+1)+bug_offset:2*(IedB+i_seg_offset):2, 1, :) + endif endif + else ! Not brushcutter_mode. + if (segment%is_E_or_W) then + if (.not.segment%field(m)%on_face) then + segment%field(m)%buffer_src(IsdB,:,:) = & + tmp_buffer(1,JsdB+j_seg_offset+1:JedB+j_seg_offset+1,:) + else + segment%field(m)%buffer_src(IsdB,:,:) = & + tmp_buffer(1,JsdB+j_seg_offset+1:JedB+j_seg_offset,:) + endif + else + if (.not.segment%field(m)%on_face) then + segment%field(m)%buffer_src(:,JsdB,:) = & + tmp_buffer(IsdB+i_seg_offset+1:IedB+i_seg_offset+1,1,:) + else + segment%field(m)%buffer_src(:,JsdB,:) = & + tmp_buffer(IsdB+i_seg_offset+1:IedB+i_seg_offset,1,:) + endif + endif + endif + + ! no dz for tidal variables + if (segment%field(m)%nk_src <= 1) then ! This is 2-d data with no remapping. + segment%field(m)%buffer_dst(:,:,1) = segment%field(m)%buffer_src(:,:,1) + elseif (field_is_tidal(segment%field(m)%name)) then + ! The 3rd axis for tidal variables is the tidal constituent, so there is no remapping. + segment%field(m)%buffer_dst(:,:,:) = segment%field(m)%buffer_src(:,:,:) + else + ! Read in 3-d data that may need to be remapped onto the new grid + ! This is also where the 2-d tidal data values (apart from phase and amp) are actually read in. + call time_interp_external(segment%field(m)%dz_handle, Time, tmp_buffer_in, scale=US%m_to_Z) - call time_interp_external(segment%field(m)%fid,Time, tmp_buffer_in) - ! NOTE: Rotation of face-points require that we skip the final value if (turns /= 0) then - ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. - if (segment%is_E_or_W & - .and. .not. (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'Vamp' & - .or. segment%field(m)%name == 'Vphase' .or. segment%field(m)%name == 'DVDX')) then + flip_buffer = ((turns==1) .or. (turns==3)) + if (flip_buffer .and. segment%is_E_or_W .and. segment%field(m)%on_face) then nj_buf = size(tmp_buffer, 2) - 1 call rotate_array(tmp_buffer_in(:nj_buf,:,:), turns, tmp_buffer(:,:nj_buf,:)) - elseif (segment%is_N_or_S & - .and. .not. (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'Uamp' & - .or. segment%field(m)%name == 'Uphase' .or. segment%field(m)%name == 'DUDY')) then + elseif (flip_buffer .and. segment%is_N_or_S .and. segment%field(m)%on_face) then ni_buf = size(tmp_buffer, 1) - 1 call rotate_array(tmp_buffer_in(:,:ni_buf,:), turns, tmp_buffer(:ni_buf,:,:)) else call rotate_array(tmp_buffer_in, turns, tmp_buffer) endif - - ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. - if (segment%field(m)%name == 'U' & - .or. segment%field(m)%name == 'DVDX' & - .or. segment%field(m)%name == 'DUDY' & - .or. segment%field(m)%name == 'Uamp') then - tmp_buffer(:,:,:) = -tmp_buffer(:,:,:) - endif - endif + endif ! End of rotation if (OBC%brushcutter_mode) then + bug_offset = 0 ; if (OBC%hor_index_bug) bug_offset = -1 if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX' .or. & - segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase') then - segment%field(m)%buffer_src(is_obc,:,:) = & - tmp_buffer(1,2*(js_obc+G%jdg_offset)+1:2*(je_obc+G%jdg_offset)+1:2,:) + if (.not.segment%field(m)%on_face) then + segment%field(m)%dz_src(IsdB,:,:) = & + tmp_buffer(1, 2*(JsdB+j_seg_offset+1)-1:2*(JedB+j_seg_offset)+1:2, :) else - segment%field(m)%buffer_src(is_obc,:,:) = & - tmp_buffer(1,2*(js_obc+G%jdg_offset)+1:2*(je_obc+G%jdg_offset):2,:) + segment%field(m)%dz_src(IsdB,:,:) = & + tmp_buffer(1, 2*(JsdB+j_seg_offset+1)+bug_offset:2*(JedB+j_seg_offset):2, :) endif else - if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY' .or. & - segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase') then - segment%field(m)%buffer_src(:,js_obc,:) = & - tmp_buffer(2*(is_obc+G%idg_offset)+1:2*(ie_obc+G%idg_offset)+1:2,1,:) + if (.not.segment%field(m)%on_face) then + segment%field(m)%dz_src(:,JsdB,:) = & + tmp_buffer(2*(IsdB+i_seg_offset+1)-1:2*(IedB+i_seg_offset)+1:2, 1, :) else - segment%field(m)%buffer_src(:,js_obc,:) = & - tmp_buffer(2*(is_obc+G%idg_offset)+1:2*(ie_obc+G%idg_offset):2,1,:) + segment%field(m)%dz_src(:,JsdB,:) = & + tmp_buffer(2*(IsdB+i_seg_offset+1)+bug_offset:2*(IedB+i_seg_offset):2, 1, :) endif endif - else + else ! Not brushcutter_mode. if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX' .or. & - segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase') then - segment%field(m)%buffer_src(is_obc,:,:)=tmp_buffer(1,js_obc+G%jdg_offset+1:je_obc+G%jdg_offset+1,:) + if (.not.segment%field(m)%on_face) then + segment%field(m)%dz_src(IsdB,:,:) = & + tmp_buffer(1,JsdB+j_seg_offset+1:JedB+j_seg_offset+1,:) else - segment%field(m)%buffer_src(is_obc,:,:)=tmp_buffer(1,js_obc+G%jdg_offset+1:je_obc+G%jdg_offset,:) + segment%field(m)%dz_src(IsdB,:,:) = & + tmp_buffer(1,JsdB+j_seg_offset+1:JedB+j_seg_offset,:) endif else - if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY' .or. & - segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase') then - segment%field(m)%buffer_src(:,js_obc,:)=tmp_buffer(is_obc+G%idg_offset+1:ie_obc+G%idg_offset+1,1,:) + if (.not.segment%field(m)%on_face) then + segment%field(m)%dz_src(:,JsdB,:) = & + tmp_buffer(IsdB+i_seg_offset+1:IedB+i_seg_offset+1,1,:) else - segment%field(m)%buffer_src(:,js_obc,:)=tmp_buffer(is_obc+G%idg_offset+1:ie_obc+G%idg_offset,1,:) + segment%field(m)%dz_src(:,JsdB,:) = & + tmp_buffer(IsdB+i_seg_offset+1:IedB+i_seg_offset,1,:) endif endif endif - ! no dz for tidal variables - if (segment%field(m)%nk_src > 1 .and.& - (index(segment%field(m)%name, 'phase') .le. 0 .and. index(segment%field(m)%name, 'amp') .le. 0)) then - call time_interp_external(segment%field(m)%fid_dz,Time, tmp_buffer_in) - if (turns /= 0) then - ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. - if (segment%is_E_or_W & - .and. .not. (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX')) then - nj_buf = size(tmp_buffer, 2) - 1 - call rotate_array(tmp_buffer_in(:nj_buf,:,:), turns, tmp_buffer(:,:nj_buf,:)) - elseif (segment%is_N_or_S & - .and. .not. (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY')) then - ni_buf = size(tmp_buffer, 1) - 1 - call rotate_array(tmp_buffer_in(:,:ni_buf,:), turns, tmp_buffer(:ni_buf,:,:)) - else - call rotate_array(tmp_buffer_in, turns, tmp_buffer) - endif - endif - if (OBC%brushcutter_mode) then - if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then - segment%field(m)%dz_src(is_obc,:,:) = & - tmp_buffer(1,2*(js_obc+G%jdg_offset)+1:2*(je_obc+G%jdg_offset)+1:2,:) - else - segment%field(m)%dz_src(is_obc,:,:) = & - tmp_buffer(1,2*(js_obc+G%jdg_offset)+1:2*(je_obc+G%jdg_offset):2,:) - endif - else - if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then - segment%field(m)%dz_src(:,js_obc,:) = & - tmp_buffer(2*(is_obc+G%idg_offset)+1:2*(ie_obc+G%idg_offset)+1:2,1,:) - else - segment%field(m)%dz_src(:,js_obc,:) = & - tmp_buffer(2*(is_obc+G%idg_offset)+1:2*(ie_obc+G%idg_offset):2,1,:) - endif - endif - else - if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then - segment%field(m)%dz_src(is_obc,:,:)=tmp_buffer(1,js_obc+G%jdg_offset+1:je_obc+G%jdg_offset+1,:) - else - segment%field(m)%dz_src(is_obc,:,:)=tmp_buffer(1,js_obc+G%jdg_offset+1:je_obc+G%jdg_offset,:) - endif - else - if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then - segment%field(m)%dz_src(:,js_obc,:)=tmp_buffer(is_obc+G%idg_offset+1:ie_obc+G%idg_offset+1,1,:) - else - segment%field(m)%dz_src(:,js_obc,:)=tmp_buffer(is_obc+G%idg_offset+1:ie_obc+G%idg_offset,1,:) - endif - endif - endif - call adjustSegmentEtaToFitBathymetry(G,GV,US,segment,m) + if ((.not.segment%field(m)%on_face) .and. (.not.OBC%hor_index_bug)) then + ! This point is at the OBC vorticity point nodes, rather than the OBC velocity point faces. + call adjustSegmentEtaToFitBathymetry(G, GV, US, segment, m, at_node=.true.) + else + call adjustSegmentEtaToFitBathymetry(G, GV, US, segment, m, at_node=.false.) + endif - if (segment%is_E_or_W) then - ishift=1 - if (segment%direction == OBC_DIRECTION_E) ishift=0 - I=is_obc - if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then - ! Do q points for the whole segment - do J=max(js_obc,jsd),min(je_obc,jed-1) - ! Using the h remapping approach - ! Pretty sure we need to check for source/target grid consistency here - 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 - h_stack(:) = 0.5*(h(i+ishift,j,:) + h(i+ishift,j+1,:)) - call remapping_core_h(OBC%remap_CS, & - segment%field(m)%nk_src,segment%field(m)%dz_src(I,J,:), & - segment%field(m)%buffer_src(I,J,:), & - GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) - elseif (G%mask2dCu(I,j)>0.) then - h_stack(:) = h(i+ishift,j,:) - call remapping_core_h(OBC%remap_CS, & - segment%field(m)%nk_src,segment%field(m)%dz_src(I,J,:), & - segment%field(m)%buffer_src(I,J,:), & - GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) - elseif (G%mask2dCu(I,j+1)>0.) then - h_stack(:) = h(i+ishift,j+1,:) - call remapping_core_h(OBC%remap_CS, & - segment%field(m)%nk_src,segment%field(m)%dz_src(I,j,:), & - segment%field(m)%buffer_src(I,J,:), & - GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) - endif - enddo - else - do j=js_obc+1,je_obc - ! Using the h remapping approach - ! Pretty sure we need to check for source/target grid consistency here - segment%field(m)%buffer_dst(I,j,:)=0.0 ! initialize remap destination buffer - if (G%mask2dCu(I,j)>0.) then - net_H_src = sum( segment%field(m)%dz_src(I,j,:) ) - net_H_int = sum( h(i+ishift,j,:) ) - scl_fac = net_H_int / net_H_src - call remapping_core_h(OBC%remap_CS, & - segment%field(m)%nk_src, scl_fac*segment%field(m)%dz_src(I,j,:), & - segment%field(m)%buffer_src(I,j,:), & - GV%ke, h(i+ishift,j,:), segment%field(m)%buffer_dst(I,j,:)) - endif - enddo - endif - else - jshift=1 - if (segment%direction == OBC_DIRECTION_N) jshift=0 - J=js_obc - if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then - ! Do q points for the whole segment - do I=max(is_obc,isd),min(ie_obc,ied-1) - segment%field(m)%buffer_dst(I,J,:)=0.0 ! initialize remap destination buffer - if (G%mask2dCv(i,J)>0. .and. G%mask2dCv(i+1,J)>0.) then + if (segment%is_E_or_W) then + I = IsdB + if (.not.segment%field(m)%on_face) then + ! Do q points for the whole segment + do J = max(JsdB, G%jsd), min(JedB, G%jed-1) ! Using the h remapping approach ! Pretty sure we need to check for source/target grid consistency here - h_stack(:) = 0.5*(h(i,j+jshift,:) + h(i+1,j+jshift,:)) - call remapping_core_h(OBC%remap_CS, & - segment%field(m)%nk_src,segment%field(m)%dz_src(I,J,:), & - segment%field(m)%buffer_src(I,J,:), & - GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) - elseif (G%mask2dCv(i,J)>0.) then - h_stack(:) = h(i,j+jshift,:) - call remapping_core_h(OBC%remap_CS, & - segment%field(m)%nk_src,segment%field(m)%dz_src(I,J,:), & - segment%field(m)%buffer_src(I,J,:), & - GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) - elseif (G%mask2dCv(i+1,J)>0.) then - h_stack(:) = h(i+1,j+jshift,:) - call remapping_core_h(OBC%remap_CS, & - segment%field(m)%nk_src,segment%field(m)%dz_src(I,J,:), & - segment%field(m)%buffer_src(I,J,:), & - GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) - endif - enddo - else - do i=is_obc+1,ie_obc + !### For a concave corner between OBC segments, there are 3 thicknesses we might + ! consider using. + segment%field(m)%buffer_dst(I,J,:) = 0.0 ! initialize remap destination buffer + if ((G%mask2dCu(I,j) > 0.0) .or. (G%mask2dCu(I,j+1) > 0.0)) then + dz_stack(:) = (1.0 / (G%mask2dCu(I,j) + G%mask2dCu(I,j+1))) * & + (G%mask2dCu(I,j) * dz(isd,j,:) + G%mask2dCu(I,j+1) * dz(isd,j+1,:)) + 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,:)) + endif + enddo + else + do j = JsdB+1, JedB ! Using the h remapping approach ! Pretty sure we need to check for source/target grid consistency here - segment%field(m)%buffer_dst(i,J,:)=0.0 ! initialize remap destination buffer - if (G%mask2dCv(i,J)>0.) then - net_H_src = sum( segment%field(m)%dz_src(i,J,:) ) - net_H_int = sum( h(i,j+jshift,:) ) - scl_fac = net_H_int / net_H_src - call remapping_core_h(OBC%remap_CS, & - segment%field(m)%nk_src, scl_fac*segment%field(m)%dz_src(i,J,:), & - segment%field(m)%buffer_src(i,J,:), & - GV%ke, h(i,j+jshift,:), segment%field(m)%buffer_dst(i,J,:)) - endif - enddo - endif - endif - elseif (segment%field(m)%nk_src > 1 .and. & - (index(segment%field(m)%name, 'phase') > 0 .or. index(segment%field(m)%name, 'amp') > 0)) then - ! no dz for tidal variables - segment%field(m)%buffer_dst(:,:,:) = segment%field(m)%buffer_src(:,:,:) - else ! 2d data - segment%field(m)%buffer_dst(:,:,1) = segment%field(m)%buffer_src(:,:,1) ! initialize remap destination buffer - endif - deallocate(tmp_buffer) - if (turns /= 0) & - deallocate(tmp_buffer_in) - else ! fid <= 0 (Uniform value) - if (.not. allocated(segment%field(m)%buffer_dst)) then - if (segment%is_E_or_W) then - if (segment%field(m)%name == 'V') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke)) - else if (segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) - elseif (segment%field(m)%name == 'U') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,GV%ke)) - elseif (segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,1)) - elseif (segment%field(m)%name == 'DVDX') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke)) - elseif (segment%field(m)%name == 'SSH' .or. segment%field(m)%name == 'SSHamp' & - .or. segment%field(m)%name == 'SSHphase') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) - else - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,GV%ke)) - endif - else - if (segment%field(m)%name == 'U') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke)) - elseif (segment%field(m)%name == 'Uamp' .or. segment%field(m)%name == 'Uphase') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) - elseif (segment%field(m)%name == 'V') then - allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,GV%ke)) - elseif (segment%field(m)%name == 'Vamp' .or. segment%field(m)%name == 'Vphase') then - allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,1)) - elseif (segment%field(m)%name == 'DUDY') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,GV%ke)) - elseif (segment%field(m)%name == 'SSH' .or. segment%field(m)%name == 'SSHamp' & - .or. segment%field(m)%name == 'SSHphase') then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) - else - allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,GV%ke)) - endif - endif - segment%field(m)%buffer_dst(:,:,:) = segment%field(m)%value - endif - endif - enddo - ! Start second loop to update all fields now that data for all fields are available. - ! (split because tides depend on multiple variables). - do m = 1,segment%num_fields - ! if (segment%field(m)%fid>0) then - ! calculate external BT velocity and transport if needed - if (trim(segment%field(m)%name) == 'U' .or. trim(segment%field(m)%name) == 'V') then - if (trim(segment%field(m)%name) == 'U' .and. segment%is_E_or_W) then - I=is_obc - do j=js_obc+1,je_obc - normal_trans_bt(I,j) = 0.0 - tidal_vel = 0.0 - if (OBC%add_tide_constituents) then - do c=1,OBC%n_tide_constituents - tidal_vel = tidal_vel + (OBC%tide_fn(c) * segment%field(segment%uamp_index)%buffer_dst(I,j,c)) * & - cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%uphase_index)%buffer_dst(I,j,c)) & - + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) - enddo - endif - do k=1,GV%ke - segment%normal_vel(I,j,k) = US%m_s_to_L_T*(segment%field(m)%buffer_dst(I,j,k) + tidal_vel) - segment%normal_trans(I,j,k) = segment%normal_vel(I,j,k)*segment%h(I,j,k) * G%dyCu(I,j) - normal_trans_bt(I,j) = normal_trans_bt(I,j) + segment%normal_trans(I,j,k) - enddo - segment%normal_vel_bt(I,j) = normal_trans_bt(I,j) & - / (max(segment%Htot(I,j), 1.e-12 * GV%m_to_H) * G%dyCu(I,j)) - if (allocated(segment%nudged_normal_vel)) segment%nudged_normal_vel(I,j,:) = segment%normal_vel(I,j,:) - enddo - elseif (trim(segment%field(m)%name) == 'V' .and. segment%is_N_or_S) then - J=js_obc - do i=is_obc+1,ie_obc - normal_trans_bt(i,J) = 0.0 - tidal_vel = 0.0 - if (OBC%add_tide_constituents) then - do c=1,OBC%n_tide_constituents - tidal_vel = tidal_vel + (OBC%tide_fn(c) * segment%field(segment%vamp_index)%buffer_dst(I,j,c)) * & - cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%vphase_index)%buffer_dst(I,j,c)) & - + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) - enddo - endif - do k=1,GV%ke - segment%normal_vel(i,J,k) = US%m_s_to_L_T*(segment%field(m)%buffer_dst(i,J,k) + tidal_vel) - segment%normal_trans(i,J,k) = segment%normal_vel(i,J,k)*segment%h(i,J,k) * & - G%dxCv(i,J) - normal_trans_bt(i,J) = normal_trans_bt(i,J) + segment%normal_trans(i,J,k) + segment%field(m)%buffer_dst(I,j,:) = 0.0 ! initialize remap destination buffer + if (G%mask2dCu(I,j)>0.) then + net_dz_src = sum( segment%field(m)%dz_src(I,j,:) ) + net_dz_int = sum( dz(isd,j,:) ) + scl_fac = net_dz_int / net_dz_src + 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(isd,j,:), segment%field(m)%buffer_dst(I,j,:)) + endif enddo - segment%normal_vel_bt(i,J) = normal_trans_bt(i,J) & - / (max(segment%Htot(i,J), 1.e-12 * GV%m_to_H) * G%dxCv(i,J)) - if (allocated(segment%nudged_normal_vel)) segment%nudged_normal_vel(i,J,:) = segment%normal_vel(i,J,:) - enddo - elseif (trim(segment%field(m)%name) == 'V' .and. segment%is_E_or_W .and. & - allocated(segment%tangential_vel)) then - I=is_obc - do J=js_obc,je_obc - tidal_vel = 0.0 - if (OBC%add_tide_constituents) then - do c=1,OBC%n_tide_constituents - tidal_vel = tidal_vel + (OBC%tide_fn(c) * segment%field(segment%vamp_index)%buffer_dst(I,j,c)) * & - cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%vphase_index)%buffer_dst(I,j,c)) & - + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) - enddo - endif - do k=1,GV%ke - segment%tangential_vel(I,J,k) = US%m_s_to_L_T*(segment%field(m)%buffer_dst(I,J,k) + tidal_vel) + endif + else + J = JsdB + if (.not.segment%field(m)%on_face) then + ! Do q points for the whole segment + do I = max(IsdB, G%isd), min(IedB, G%ied-1) + segment%field(m)%buffer_dst(I,J,:) = 0.0 ! initialize remap destination buffer + if ((G%mask2dCv(i,J) > 0.0) .or. (G%mask2dCv(i+1,J) > 0.0)) then + ! Using the h remapping approach + ! Pretty sure we need to check for source/target grid consistency here + dz_stack(:) = (1.0 / (G%mask2dCv(i,J) + G%mask2dCv(i+1,J))) * & + (G%mask2dCv(i,J) * dz(i,jsd,:) + G%mask2dCv(i+1,J) * dz(i+1,jsd,:)) + 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,:)) + endif enddo - if (allocated(segment%nudged_tangential_vel)) & - segment%nudged_tangential_vel(I,J,:) = segment%tangential_vel(I,J,:) - enddo - elseif (trim(segment%field(m)%name) == 'U' .and. segment%is_N_or_S .and. & - allocated(segment%tangential_vel)) then - J=js_obc - do I=is_obc,ie_obc - tidal_vel = 0.0 - if (OBC%add_tide_constituents) then - do c=1,OBC%n_tide_constituents - tidal_vel = tidal_vel + (OBC%tide_fn(c) * segment%field(segment%uamp_index)%buffer_dst(I,j,c)) * & - cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%uphase_index)%buffer_dst(I,j,c)) & - + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) - enddo - endif - do k=1,GV%ke - segment%tangential_vel(I,J,k) = US%m_s_to_L_T*(segment%field(m)%buffer_dst(I,J,k) + tidal_vel) + else + do i = IsdB+1, IedB + ! Using the h remapping approach + ! Pretty sure we need to check for source/target grid consistency here + segment%field(m)%buffer_dst(i,J,:) = 0.0 ! initialize remap destination buffer + if (G%mask2dCv(i,J)>0.) then + net_dz_src = sum( segment%field(m)%dz_src(i,J,:) ) + net_dz_int = sum( dz(i,jsd,:) ) + scl_fac = net_dz_int / net_dz_src + 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,jsd,:), segment%field(m)%buffer_dst(i,J,:)) + endif enddo - if (allocated(segment%nudged_tangential_vel)) & - segment%nudged_tangential_vel(I,J,:) = segment%tangential_vel(I,J,:) - enddo + endif endif - elseif (trim(segment%field(m)%name) == 'DVDX' .and. segment%is_E_or_W .and. & - allocated(segment%tangential_grad)) then - I=is_obc - do J=js_obc,je_obc - do k=1,GV%ke - segment%tangential_grad(I,J,k) = US%T_to_s*segment%field(m)%buffer_dst(I,J,k) - if (allocated(segment%nudged_tangential_grad)) & - segment%nudged_tangential_grad(I,J,:) = segment%tangential_grad(I,J,:) - enddo - enddo - elseif (trim(segment%field(m)%name) == 'DUDY' .and. segment%is_N_or_S .and. & - allocated(segment%tangential_grad)) then - J=js_obc - do I=is_obc,ie_obc - do k=1,GV%ke - segment%tangential_grad(I,J,k) = US%T_to_s*segment%field(m)%buffer_dst(I,J,k) - if (allocated(segment%nudged_tangential_grad)) & - segment%nudged_tangential_grad(I,J,:) = segment%tangential_grad(I,J,:) - enddo - enddo endif + deallocate(tmp_buffer) + if (turns /= 0) deallocate(tmp_buffer_in) + enddo ! end field loop + enddo ! endd segment loop +end subroutine read_OBC_segment_data + +!> Update OBC segment velocities, gradient, SSH and the external fields %t of thickness/tracer reservoirs. +subroutine update_OBC_segment_data(G, GV, US, OBC, h, Time) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Thickness [H ~> m or kg m-2] + type(time_type), intent(in) :: Time !< Model time - ! endif + ! Local variables + type(OBC_segment_type), pointer :: segment => NULL() + integer :: c, i, j, k, n, m, nz, nt + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + integer :: is_seg, ie_seg, js_seg, je_seg ! Orientation-agnostic loop ranges + integer :: i_offset_in, j_offset_in ! Indexing offset for interior cells + integer :: F_G, F_VN, F_VNAMP, F_VNPHASE, F_VT, F_VTAMP, F_VTPHASE ! Field indices + real :: ramp_value ! If OBC%ramp is True, where we are on the ramp from 0 to 1, or 1 otherwise [nondim]. + real :: time_delta ! Time since tidal reference date [T ~> s] + real :: tidal_amp, tidal_phase ! Tidal amplitude [Z ~> m] and phase [rad] + + if (.not. associated(OBC)) return + if (OBC%user_BCs_set_globally) return + + nz = GV%ke + + if (OBC%add_tide_constituents) & + time_delta = time_minus_signed(Time, OBC%time_ref, scale=US%s_to_T) + + do n=1,OBC%number_of_segments + segment => OBC%segment(n) + + if (.not. segment%on_pe) cycle ! continue to next segment if not in data domain + + ! Segment indices are on q points: + ! | x | x | x | x | jsd/jed (if southern boundary) + ! |-----------|-----------|-----------|-----------| JsdB/JedB + ! IsdB isd ied IedB + ! | x | x | x | x | jsd/jed (if northern boundary) - ! from this point on, data are entirely on segments - will - ! write all segment loops as 2d loops. + isd = segment%HI%isd ; ied = segment%HI%ied ; IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + jsd = segment%HI%jsd ; jed = segment%HI%jed ; JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + i_offset_in = ied - IedB ! = 0 if East, South, North; = 1 if West + j_offset_in = jed - JedB ! = 0 if North, West, East ; = 1 if South + + if (segment%is_E_or_W) then + is_seg = IsdB ; ie_seg = is_seg + js_seg = jsd ; je_seg = jed + F_VN = F_U ; F_VNAMP = F_UAMP ; F_VNPHASE = F_UPHASE + F_VT = F_V ; F_VTAMP = F_VAMP ; F_VTPHASE = F_VPHASE ; F_G = F_VX + else + is_seg = isd ; ie_seg = ied + js_seg = JsdB ; je_seg = js_seg + F_VN = F_V ; F_VNAMP = F_VAMP ; F_VNPHASE = F_VPHASE + F_VT = F_U ; F_VTAMP = F_UAMP ; F_VTPHASE = F_UPHASE ; F_G = F_UY + endif + + ! Update normal velocity, transport. Split by orientation for now because of G%dyCu and G%dxCv. + if (allocated(segment%field(F_VN)%buffer_dst)) then + ! Update tidal normal velocity + segment%tidal_vn(:,:) = 0.0 + if (OBC%add_tide_constituents) then + do c=1,OBC%n_tide_constituents ; do j=js_seg,je_seg ; do i=is_seg,ie_seg + tidal_amp = OBC%tide_fn(c) * segment%field(F_VNAMP)%buffer_dst(i,j,c) + tidal_phase = (time_delta * OBC%tide_frequencies(c) - segment%field(F_VNPHASE)%buffer_dst(i,j,c)) & + + (OBC%tide_eq_phases(c) + OBC%tide_un(c)) + segment%tidal_vn(i,j) = segment%tidal_vn(i,j) + tidal_amp * cos(tidal_phase) + enddo ; enddo ; enddo + endif + + segment%Htot(:,:) = 0.0 + segment%normal_trans_bt(:,:) = 0.0 if (segment%is_E_or_W) then - js_obc2 = js_obc+1 - is_obc2 = is_obc + do k=1,nz ; do j=js_seg,je_seg ; do i=is_seg,ie_seg + segment%Htot(i,j) = segment%Htot(i,j) + h(i+i_offset_in,j+j_offset_in,k) + segment%normal_vel(i,j,k) = segment%field(F_VN)%buffer_dst(i,j,k) + segment%tidal_vn(i,j) + segment%normal_trans(i,j,k) = & + segment%normal_vel(i,j,k) * h(i+i_offset_in,j+j_offset_in,k) * G%dyCu(i,j) + segment%normal_trans_bt(i,j) = segment%normal_trans_bt(i,j) + segment%normal_trans(i,j,k) + enddo ; enddo ; enddo + do j=js_seg,je_seg ; do i=is_seg,ie_seg + segment%normal_vel_bt(i,j) = segment%normal_trans_bt(i,j) & + / (max(segment%Htot(i,j), 1.e-12 * GV%m_to_H) * G%dyCu(i,j)) + enddo ; enddo else - js_obc2 = js_obc - is_obc2 = is_obc+1 + do k=1,nz ; do j=js_seg,je_seg ; do i=is_seg,ie_seg + segment%Htot(i,j) = segment%Htot(i,j) + h(i+i_offset_in,j+j_offset_in,k) + segment%normal_vel(i,j,k) = segment%field(F_VN)%buffer_dst(i,j,k) + segment%tidal_vn(i,j) + segment%normal_trans(i,j,k) = & + segment%normal_vel(i,j,k) * h(i+i_offset_in,j+j_offset_in,k) * G%dxCv(i,j) + segment%normal_trans_bt(i,j) = segment%normal_trans_bt(i,j) + segment%normal_trans(i,j,k) + enddo ; enddo ; enddo + do j=js_seg,je_seg ; do i=is_seg,ie_seg + segment%normal_vel_bt(i,j) = segment%normal_trans_bt(i,j) & + / (max(segment%Htot(i,j), 1.e-12 * GV%m_to_H) * G%dxCv(i,j)) + enddo ; enddo endif - if (segment%is_N_or_S) then - is_obc2 = is_obc+1 - js_obc2 = js_obc - else - is_obc2 = is_obc - js_obc2 = js_obc+1 + + if (allocated(segment%nudged_normal_vel)) then + do k=1,nz ; do j=js_seg,je_seg ; do i=is_seg,ie_seg + segment%nudged_normal_vel(i,j,k) = segment%normal_vel(i,j,k) + enddo ; enddo ; enddo endif + endif - if (trim(segment%field(m)%name) == 'SSH') then - if (OBC%ramp) then - do j=js_obc2,je_obc - do i=is_obc2,ie_obc - tidal_elev = 0.0 - if (OBC%add_tide_constituents) then - do c=1,OBC%n_tide_constituents - tidal_elev = tidal_elev + (OBC%tide_fn(c) * segment%field(segment%zamp_index)%buffer_dst(i,j,c)) * & - cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%zphase_index)%buffer_dst(i,j,c)) & - + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) - enddo - endif - segment%eta(i,j) = GV%m_to_H * OBC%ramp_value & - * (segment%field(m)%buffer_dst(i,j,1) + tidal_elev) - enddo - enddo - else - do j=js_obc2,je_obc - do i=is_obc2,ie_obc - tidal_elev = 0.0 - if (OBC%add_tide_constituents) then - do c=1,OBC%n_tide_constituents - tidal_elev = tidal_elev + (OBC%tide_fn(c) * segment%field(segment%zamp_index)%buffer_dst(i,j,c)) * & - cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%zphase_index)%buffer_dst(i,j,c)) & - + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) - enddo - endif - segment%eta(i,j) = GV%m_to_H * (segment%field(m)%buffer_dst(i,j,1) + tidal_elev) - enddo - enddo - endif + ! Update tangential velocity + if (allocated(segment%tangential_vel) .and. allocated(segment%field(F_VT)%buffer_dst)) then + ! Update tidal tangential velocity + segment%tidal_vt(:,:) = 0.0 + if (OBC%add_tide_constituents) then + do c=1,OBC%n_tide_constituents ; do J=JsdB,JedB ; do I=IsdB,IedB + tidal_amp = OBC%tide_fn(c) * segment%field(F_VTAMP)%buffer_dst(I,J,c) + tidal_phase = (time_delta * OBC%tide_frequencies(c) - segment%field(F_VTPHASE)%buffer_dst(I,J,c)) & + + (OBC%tide_eq_phases(c) + OBC%tide_un(c)) + segment%tidal_vt(I,J) = segment%tidal_vt(I,J) + tidal_amp * cos(tidal_phase) + enddo ; enddo ; enddo endif - if (trim(segment%field(m)%name) == 'TEMP') then - if (allocated(segment%field(m)%buffer_dst)) then - do k=1,nz ; do j=js_obc2,je_obc ; do i=is_obc2,ie_obc - segment%tr_Reg%Tr(1)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k) - enddo ; enddo ; enddo - if (.not. segment%tr_Reg%Tr(1)%is_initialized) then - ! if the tracer reservoir has not yet been initialized, then set to external value. - do k=1,nz ; do j=js_obc2,je_obc ; do i=is_obc2,ie_obc - segment%tr_Reg%Tr(1)%tres(i,j,k) = segment%tr_Reg%Tr(1)%t(i,j,k) - enddo ; enddo ; enddo - segment%tr_Reg%Tr(1)%is_initialized=.true. - endif - else - segment%tr_Reg%Tr(1)%OBC_inflow_conc = segment%field(m)%value - endif - elseif (trim(segment%field(m)%name) == 'SALT') then - if (allocated(segment%field(m)%buffer_dst)) then - do k=1,nz ; do j=js_obc2,je_obc ; do i=is_obc2,ie_obc - segment%tr_Reg%Tr(2)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k) - enddo ; enddo ; enddo - if (.not. segment%tr_Reg%Tr(2)%is_initialized) then - !if the tracer reservoir has not yet been initialized, then set to external value. - do k=1,nz ; do j=js_obc2,je_obc ; do i=is_obc2,ie_obc - segment%tr_Reg%Tr(2)%tres(i,j,k) = segment%tr_Reg%Tr(2)%t(i,j,k) - enddo ; enddo ; enddo - segment%tr_Reg%Tr(2)%is_initialized=.true. - endif - else - segment%tr_Reg%Tr(2)%OBC_inflow_conc = segment%field(m)%value - endif + do k=1,nz ; do J=JsdB,JedB ; do I=IsdB,IedB + segment%tangential_vel(I,J,k) = segment%field(F_VT)%buffer_dst(I,J,k) + segment%tidal_vt(I,J) + enddo ; enddo ; enddo + + if (allocated(segment%nudged_tangential_vel)) then + do k=1,nz ; do J=JsdB,JedB ; do I=IsdB,IedB + segment%nudged_tangential_vel(I,J,k) = segment%tangential_vel(I,J,k) + enddo ; enddo ; enddo endif + endif - enddo ! end field loop - deallocate(h_stack) - deallocate(normal_trans_bt) + ! Update tangential gradient dvdx and dudy + if (allocated(segment%tangential_grad) .and. allocated(segment%field(F_G)%buffer_dst)) then + do k=1,nz ; do J=JsdB,JedB ; do I=IsdB,IedB + segment%tangential_grad(I,J,k) = segment%field(F_G)%buffer_dst(I,J,k) + enddo ; enddo ; enddo - enddo ! end segment loop + if (allocated(segment%nudged_tangential_grad)) then + do k=1,nz ; do J=JsdB,JedB ; do I=IsdB,IedB + segment%nudged_tangential_grad(I,J,k) = segment%tangential_grad(I,J,k) + enddo ; enddo ; enddo + endif + endif + ! Update SSH + if (allocated(segment%field(F_Z)%buffer_dst)) then + ! Update tidal SSH + segment%tidal_elev(:,:) = 0.0 + if (OBC%add_tide_constituents) then + do c=1,OBC%n_tide_constituents ; do j=js_seg,je_seg ; do i=is_seg,ie_seg + tidal_amp = OBC%tide_fn(c) * segment%field(F_ZAMP)%buffer_dst(i,j,c) + tidal_phase = (time_delta * OBC%tide_frequencies(c) - segment%field(F_ZPHASE)%buffer_dst(i,j,c)) & + + (OBC%tide_eq_phases(c) + OBC%tide_un(c)) + segment%tidal_elev(i,j) = segment%tidal_elev(i,j) + tidal_amp * cos(tidal_phase) + enddo ; enddo ; enddo + endif + + ramp_value = 1.0 ; if (OBC%ramp) ramp_value = OBC%ramp_value + do j=js_seg,je_seg ; do i=is_seg,ie_seg + segment%SSH(i,j) = ramp_value * (segment%field(F_Z)%buffer_dst(i,j,1) + segment%tidal_elev(i,j)) + enddo ; enddo + endif + + ! Update thickness registry + if (OBC%thickness_x_reservoirs_used .or. OBC%thickness_y_reservoirs_used) then + do k=1,nz ; do j=js_seg,je_seg ; do i=is_seg,ie_seg + segment%h_Reg%h(i,j,k) = h(i+i_offset_in,j+j_offset_in,k) + enddo ; enddo ; enddo + endif + + ! Update tracer registry + do m = NUM_PHYS_FIELDS-1, segment%num_fields ! F_T = NUM_PHYS_FIELDS-1 and F_S = NUM_PHYS_FIELDS + if (.not. allocated(segment%field(m)%buffer_dst) .or. & + (segment%field(m)%bgc_tracer .and. (.not. OBC%update_OBC_seg_data))) then + cycle + endif + nt = segment%field(m)%tr_index + ! Note the following unnecessary IF-branch is kept from the old code (as recent as Jan 2026). + ! In the old code segment%field(m)%buffer_dst is always allocated at this point, and therefore + ! the "else" section is unreachable. This will be fixed when OBC_inflow_conc is reworked. + if (allocated(segment%field(m)%buffer_dst)) then + do k=1,nz ; do j=js_seg,je_seg ; do i=is_seg,ie_seg + segment%tr_Reg%Tr(nt)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k) + enddo ; enddo ; enddo + else + segment%tr_Reg%Tr(nt)%OBC_inflow_conc = segment%field(m)%value + endif + enddo ! end tracer field loop + enddo ! end segment loop end subroutine update_OBC_segment_data +!> Initialize thickness and tracer reservoirs to external value. +subroutine initialize_OBC_segment_reservoirs(GV, OBC) + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + + ! Local variables + type(OBC_segment_type), pointer :: segment => NULL() + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + integer :: is_seg, ie_seg, js_seg, je_seg, nz + integer :: n, m, nt, i, j, k + character(len=256) :: msg ! Error message + + if (.not. associated(OBC)) return + + nz = GV%ke + + do n=1,OBC%number_of_segments + segment => OBC%segment(n) + + if (.not. segment%on_pe) cycle + + isd = segment%HI%isd ; ied = segment%HI%ied ; IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + jsd = segment%HI%jsd ; jed = segment%HI%jed ; JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + + if (segment%is_E_or_W) then + is_seg = IsdB ; ie_seg = IedB ! = is_seg + js_seg = jsd ; je_seg = jed + else + is_seg = isd ; ie_seg = ied + js_seg = JsdB ; je_seg = JedB ! = js_seg + endif + + ! Thickness + ! If the thickness reservoir has not yet been initialized, then set to external value. + if (OBC%thickness_x_reservoirs_used .or. OBC%thickness_y_reservoirs_used) then + if (.not. segment%h_Reg%is_initialized) then ! h_Reg may be initialized by fill_thickness_segments + do k=1,nz ; do j=js_seg,je_seg ; do i=is_seg,ie_seg + segment%h_Reg%h_res(i,j,k) = segment%h_Reg%h(i,j,k) + enddo ; enddo ; enddo + segment%h_Reg%is_initialized = .true. + endif + endif + + ! Tracers + ! If the tracer reservoir has not yet been initialized, then set to external value. + do m=NUM_PHYS_FIELDS-1, segment%num_fields ! F_T = NUM_PHYS_FIELDS-1 and F_S = NUM_PHYS_FIELDS + if (.not. allocated(segment%field(m)%buffer_dst)) cycle + nt = segment%field(m)%tr_index + if (.not. segment%tr_Reg%Tr(nt)%is_initialized) then ! T/S may be initialized by fill_temp_salt_segments + do k=1,nz ; do j=js_seg,je_seg ; do i=is_seg,ie_seg + segment%tr_Reg%Tr(nt)%tres(i,j,k) = segment%tr_Reg%Tr(nt)%t(i,j,k) + enddo ; enddo ; enddo + segment%tr_Reg%Tr(nt)%is_initialized = .true. + endif + enddo ! end tracer field loop + enddo ! end segment loop +end subroutine initialize_OBC_segment_reservoirs + !> Update the OBC ramp value as a function of time. !! If called with the optional argument activate=.true., record the !! value of Time as the beginning of the ramp period. @@ -4362,7 +4951,7 @@ subroutine update_OBC_ramp(Time, OBC, US, activate) endif endif if (.not.OBC%ramping_is_activated) return - deltaTime = max( 0., US%s_to_T*time_type_to_real( Time - OBC%ramp_start_time ) ) + deltaTime = max(0., time_minus_signed(Time, OBC%ramp_start_time, scale=US%s_to_T)) if (deltaTime >= OBC%trunc_ramp_time) then OBC%ramp_value = 1.0 OBC%ramp = .false. ! This turns off ramping after this call @@ -4375,8 +4964,7 @@ subroutine update_OBC_ramp(Time, OBC, US, activate) OBC%ramp_value = wghtA endif write(msg(1:12),'(es12.3)') OBC%ramp_value - call MOM_error(NOTE, "MOM_open_boundary: update_OBC_ramp set OBC"// & - " ramp to "//trim(msg)) + call MOM_error(NOTE, "MOM_open_boundary: update_OBC_ramp set OBC ramp to "//trim(msg)) end subroutine update_OBC_ramp !> register open boundary objects for boundary updates. @@ -4390,9 +4978,9 @@ subroutine register_OBC(name, param_file, Reg) if (.not. associated(Reg)) call OBC_registry_init(param_file, Reg) if (Reg%nobc>=MAX_FIELDS_) then - write(mesg,'("Increase MAX_FIELDS_ in MOM_memory.h to at least ",I3," to allow for & + write(mesg, '("Increase MAX_FIELDS_ in MOM_memory.h to at least ",I0," to allow for & &all the open boundaries being registered via register_OBC.")') Reg%nobc+1 - call MOM_error(FATAL,"MOM register_tracer: "//mesg) + call MOM_error(FATAL,"MOM register_OBC: "//mesg) endif Reg%nobc = Reg%nobc + 1 nobc = Reg%nobc @@ -4413,7 +5001,6 @@ subroutine OBC_registry_init(param_file, Reg) integer, save :: init_calls = 0 # include "version_variable.h" - character(len=40) :: mdl = "MOM_open_boundary" ! This module's name. character(len=256) :: mesg ! Message for error messages. if (.not.associated(Reg)) then ; allocate(Reg) @@ -4424,9 +5011,8 @@ subroutine OBC_registry_init(param_file, Reg) init_calls = init_calls + 1 if (init_calls > 1) then - write(mesg,'("OBC_registry_init called ",I3, & - &" times with different registry pointers.")') init_calls - if (is_root_pe()) call MOM_error(WARNING,"MOM_open_boundary"//mesg) + write(mesg,'("OBC_registry_init called ",I0," times with different registry pointers.")') init_calls + if (is_root_pe()) call MOM_error(WARNING,"MOM_open_boundary: "//trim(mesg)) endif end subroutine OBC_registry_init @@ -4472,7 +5058,7 @@ subroutine segment_tracer_registry_init(param_file, segment) ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "segment_tracer_registry_init" ! This routine's name. - character(len=256) :: mesg ! Message for error messages. + !character(len=256) :: mesg ! Message for error messages. if (.not.associated(segment%tr_Reg)) then allocate(segment%tr_Reg) @@ -4485,19 +5071,84 @@ subroutine segment_tracer_registry_init(param_file, segment) ! Read all relevant parameters and write them to the model log. if (init_calls == 1) call log_version(param_file, mdl, version, "") -! Need to call once per segment with tracers... -! if (init_calls > 1) then -! write(mesg,'("segment_tracer_registry_init called ",I3, & -! &" times with different registry pointers.")') init_calls -! if (is_root_pe()) call MOM_error(WARNING,"MOM_tracer"//mesg) -! endif - end subroutine segment_tracer_registry_init +!> Initialize all the segment thickness reservoirs. +subroutine segment_thickness_reservoir_init(GV, US, OBC, param_file) + type(param_file_type), intent(in) :: param_file !< open file to parse for model parameters + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< Unit scaling type + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure +! real, optional, intent(in) :: OBC_scalar !< If present, use scalar value for segment tracer +! !! inflow concentration, including any rescaling to +! !! put the tracer concentration into its internal units, +! !! like [S ~> ppt] for salinity. +! logical, optional, intent(in) :: OBC_array !< If true, use array values for segment tracer +! !! inflow concentration. +! Local variables + real :: rescale ! A multiplicatively corrected scaling factor, in units like [S ppt-1 ~> 1] for + ! salinity, or other various units depending on what rescaling has occurred previously. + integer :: nseg, m, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + integer :: fd_id + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + integer, save :: init_calls = 0 + +! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "segment_thickness_reservoir_init" ! This routine's name. + + if (.not. associated(OBC)) return + + do nseg=1, OBC%number_of_segments + segment=>OBC%segment(nseg) + if (.not. segment%on_pe) cycle + + if (associated(segment%h_Reg)) & + call MOM_error(FATAL,"segment_thickness_reservoir_init: thickness array was previously allocated") + allocate(segment%h_Reg) + + isd = segment%HI%isd ; ied = segment%HI%ied + jsd = segment%HI%jsd ; jed = segment%HI%jed + IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + + fd_id = -1 + do m=1,segment%num_fields + if (lowercase(segment%field(m)%name) == lowercase(segment%h_Reg%name)) fd_id = m + enddo + segment%h_Reg%scale = US%Z_to_m + do m=1,segment%num_fields + if (uppercase(segment%field(m)%name) == uppercase(segment%h_Reg%name)) then + if (.not. segment%field(m)%use_IO) then + rescale = 1.0 + if ((segment%field(m)%scale /= 0.0) .and. (segment%field(m)%scale /= 1.0)) & + rescale = 1.0 / segment%field(m)%scale + segment%field(m)%value = rescale * segment%field(m)%value + endif + endif + enddo + + if (segment%is_E_or_W) then + allocate(segment%h_Reg%h(IsdB:IedB,jsd:jed,1:GV%ke), source=0.0) + allocate(segment%h_Reg%h_res(IsdB:IedB,jsd:jed,1:GV%ke), source=0.0) + elseif (segment%is_N_or_S) then + allocate(segment%h_Reg%h(isd:ied,JsdB:JedB,1:GV%ke), source=0.0) + allocate(segment%h_Reg%h_res(isd:ied,JsdB:JedB,1:GV%ke), source=0.0) + endif + segment%h_Reg%is_initialized = .false. + + init_calls = init_calls + 1 + + ! Read all relevant parameters and write them to the model log. + if (init_calls == 1) call log_version(param_file, mdl, version, "") + enddo + +end subroutine segment_thickness_reservoir_init + !> Register a tracer array that is active on an OBC segment, potentially also specifying how the !! tracer inflow values are specified. -subroutine register_segment_tracer(tr_ptr, param_file, GV, segment, & - OBC_scalar, OBC_array) +subroutine register_segment_tracer(tr_ptr, ntr_index, param_file, GV, segment, & + OBC_scalar, OBC_array, scale, fd_index) type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(tracer_type), target :: tr_ptr !< A target that can be used to set a pointer to the !! stored value of tr. This target must be @@ -4506,24 +5157,31 @@ subroutine register_segment_tracer(tr_ptr, param_file, GV, segment, & !! but it also means that any updates to this !! structure in the calling module will be !! available subsequently to the tracer registry. - type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values + integer, intent(in) :: ntr_index !< index of segment tracer in the global tracer registry + type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values type(OBC_segment_type), intent(inout) :: segment !< current segment data structure - real, optional, intent(in) :: OBC_scalar !< If present, use scalar value for segment tracer + real, optional, intent(in) :: OBC_scalar !< If present, use scalar value for segment tracer + !! inflow concentration, including any rescaling to + !! put the tracer concentration into its internal units, + !! like [S ~> ppt] for salinity. + logical, optional, intent(in) :: OBC_array !< If true, use array values for segment tracer !! inflow concentration. - logical, optional, intent(in) :: OBC_array !< If true, use array values for segment tracer - !! inflow concentration. - + real, optional, intent(in) :: scale !< A scaling factor that should be used with any + !! data that is read in to convert it to the internal + !! units of this tracer, in units like [S ppt-1 ~> 1] + !! for salinity. + integer, optional, intent(in) :: fd_index !< index of segment tracer in the input field ! Local variables - integer :: ntseg - integer :: isd, ied, jsd, jed - integer :: IsdB, IedB, JsdB, JedB + real :: rescale ! A multiplicatively corrected scaling factor, in units like [S ppt-1 ~> 1] for + ! salinity, or other various units depending on what rescaling has occurred previously. + integer :: ntseg, m, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB character(len=256) :: mesg ! Message for error messages. call segment_tracer_registry_init(param_file, segment) if (segment%tr_Reg%ntseg>=MAX_FIELDS_) then - write(mesg,'("Increase MAX_FIELDS_ in MOM_memory.h to at least ",I3," to allow for & + write(mesg,'("Increase MAX_FIELDS_ in MOM_memory.h to at least ",I0," to allow for & &all the tracers being registered via register_segment_tracer.")') segment%tr_Reg%ntseg+1 call MOM_error(FATAL,"MOM register_segment_tracer: "//mesg) endif @@ -4537,6 +5195,27 @@ subroutine register_segment_tracer(tr_ptr, param_file, GV, segment, & segment%tr_Reg%Tr(ntseg)%Tr => tr_ptr segment%tr_Reg%Tr(ntseg)%name = tr_ptr%name + segment%tr_Reg%Tr(ntseg)%ntr_index = ntr_index + if (present(fd_index)) segment%tr_Reg%Tr(ntseg)%fd_index = fd_index + + segment%tr_Reg%Tr(ntseg)%scale = 1.0 + if (present(scale)) then + segment%tr_Reg%Tr(ntseg)%scale = scale + do m=1,segment%num_fields + ! Store the scaling factor for fields with exactly matching names, and possibly + ! rescale the previously stored input values. Note that calls to register_segment_tracer + ! can come before or after calls to initialize_segment_data. + if (uppercase(segment%field(m)%name) == uppercase(segment%tr_Reg%Tr(ntseg)%name)) then + if (.not. segment%field(m)%use_IO) then + rescale = scale + if ((segment%field(m)%scale /= 0.0) .and. (segment%field(m)%scale /= 1.0)) & + rescale = scale / segment%field(m)%scale + segment%field(m)%value = rescale * segment%field(m)%value + endif + segment%field(m)%scale = scale + endif + enddo + endif if (segment%tr_Reg%locked) call MOM_error(FATAL, & "MOM register_segment_tracer was called for variable "//trim(segment%tr_Reg%Tr(ntseg)%name)//& @@ -4547,11 +5226,11 @@ subroutine register_segment_tracer(tr_ptr, param_file, GV, segment, & if (segment%is_E_or_W) then allocate(segment%tr_Reg%Tr(ntseg)%t(IsdB:IedB,jsd:jed,1:GV%ke), source=0.0) allocate(segment%tr_Reg%Tr(ntseg)%tres(IsdB:IedB,jsd:jed,1:GV%ke), source=0.0) - segment%tr_Reg%Tr(ntseg)%is_initialized=.false. + segment%tr_Reg%Tr(ntseg)%is_initialized = .false. elseif (segment%is_N_or_S) then allocate(segment%tr_Reg%Tr(ntseg)%t(isd:ied,JsdB:JedB,1:GV%ke), source=0.0) allocate(segment%tr_Reg%Tr(ntseg)%tres(isd:ied,JsdB:JedB,1:GV%ke), source=0.0) - segment%tr_Reg%Tr(ntseg)%is_initialized=.false. + segment%tr_Reg%Tr(ntseg)%is_initialized = .false. endif endif @@ -4572,45 +5251,211 @@ subroutine segment_tracer_registry_end(Reg) endif end subroutine segment_tracer_registry_end -subroutine register_temp_salt_segments(GV, OBC, tr_Reg, param_file) +!> Clean up the segment thickness object +subroutine segment_thickness_registry_end(Reg) + type(OBC_segment_thickness_type), pointer :: Reg !< pointer to thickness reservoir + +! Local variables + + if (associated(Reg)) then + if (allocated(Reg%h)) deallocate(Reg%h) + if (allocated(Reg%h_res)) deallocate(Reg%h_res) + deallocate(Reg) + endif +end subroutine segment_thickness_registry_end + +!> Registers the temperature and salinity in the segment tracer registry. +subroutine register_temp_salt_segments(GV, US, OBC, tr_Reg, param_file) type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< Unit scaling type type(ocean_OBC_type), pointer :: OBC !< Open boundary structure type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values -! Local variables - integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, nz, nf - integer :: i, j, k, n - character(len=32) :: name + ! Local variables + integer :: n, ntr_id + character(len=32) :: name type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list - type(tracer_type), pointer :: tr_ptr => NULL() + type(tracer_type), pointer :: tr_ptr => NULL() if (.not. associated(OBC)) return - do n=1, OBC%number_of_segments - segment=>OBC%segment(n) + do n=1,OBC%number_of_segments + segment => OBC%segment(n) if (.not. segment%on_pe) cycle if (associated(segment%tr_Reg)) & call MOM_error(FATAL,"register_temp_salt_segments: tracer array was previously allocated") name = 'temp' - call tracer_name_lookup(tr_Reg, tr_ptr, name) - call register_segment_tracer(tr_ptr, param_file, GV, segment, & - OBC_array=segment%temp_segment_data_exists) + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) + call register_segment_tracer(tr_ptr, ntr_id, param_file, GV, segment, & + OBC_array=segment%temp_segment_data_exists, scale=US%degC_to_C) name = 'salt' - call tracer_name_lookup(tr_Reg, tr_ptr, name) - call register_segment_tracer(tr_ptr, param_file, GV, segment, & - OBC_array=segment%salt_segment_data_exists) + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) + call register_segment_tracer(tr_ptr, ntr_id, param_file, GV, segment, & + OBC_array=segment%salt_segment_data_exists, scale=US%ppt_to_S) enddo end subroutine register_temp_salt_segments -subroutine fill_temp_salt_segments(G, GV, OBC, tv) +!> Sets the OBC properties of external obgc tracers, such as their source file and field name +subroutine set_obgc_segments_props(OBC,tr_name,obc_src_file_name,obc_src_field_name,lfac_in,lfac_out) + type(ocean_OBC_type),pointer :: OBC !< Open boundary structure + character(len=*), intent(in) :: tr_name !< Tracer name + character(len=*), intent(in) :: obc_src_file_name !< OBC source file name + character(len=*), intent(in) :: obc_src_field_name !< name of the field in the source file + real, intent(in) :: lfac_in !< factors for tracer reservoir inbound length scales [nondim] + real, intent(in) :: lfac_out !< factors for tracer reservoir outbound length scales [nondim] + + type(external_tracers_segments_props),pointer :: node_ptr => NULL() !pointer to type that keeps + ! the tracer segment properties + allocate(node_ptr) + node_ptr%tracer_name = trim(tr_name) + node_ptr%tracer_src_file = trim(obc_src_file_name) + node_ptr%tracer_src_field = trim(obc_src_field_name) + node_ptr%lfac_in = lfac_in + node_ptr%lfac_out = lfac_out + ! Reversed Linked List implementation! Make this new node to be the head of the list. + node_ptr%next => OBC%obgc_segments_props + OBC%obgc_segments_props => node_ptr + OBC%num_obgc_tracers = OBC%num_obgc_tracers+1 +end subroutine set_obgc_segments_props + +!> Get the OBC properties of external obgc tracers, such as their source file, field name, +!! reservoir length scale factors +subroutine get_obgc_segments_props(node, tr_name,obc_src_file_name,obc_src_field_name,lfac_in,lfac_out) + type(external_tracers_segments_props),pointer :: node !< pointer to tracer segment properties + character(len=*), intent(out) :: tr_name !< Tracer name + character(len=*), intent(out) :: obc_src_file_name !< OBC source file name + character(len=*), intent(out) :: obc_src_field_name !< name of the field in the source file + real, intent(out) :: lfac_in !< multiplicative factor for inbound reservoir length scale [nondim] + real, intent(out) :: lfac_out !< multiplicative factor for outbound reservoir length scale [nondim] + tr_name = trim(node%tracer_name) + obc_src_file_name = trim(node%tracer_src_file) + obc_src_field_name = trim(node%tracer_src_field) + lfac_in = node%lfac_in + lfac_out = node%lfac_out + node => node%next +end subroutine get_obgc_segments_props + +!> Registers a named tracer in the segment tracer registries for the OBC segments on which it is active. +subroutine register_obgc_segments(GV, OBC, tr_Reg, param_file, tr_name) + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry + type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values + character(len=*), intent(in) :: tr_name !< Tracer name +! Local variables + integer :: ntr_id, fd_id + integer :: n, m + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + type(tracer_type), pointer :: tr_ptr => NULL() + + if (.not. associated(OBC)) return + + do n=1,OBC%number_of_segments + segment => OBC%segment(n) + if (.not. segment%on_pe) cycle + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, tr_name) + ! get the obgc field index + fd_id = -1 + do m=1,segment%num_fields + if (lowercase(segment%field(m)%name) == lowercase(tr_name)) fd_id = m + enddo + call register_segment_tracer(tr_ptr, ntr_id, param_file, GV, segment, OBC_array=.True., fd_index=fd_id) + enddo + +end subroutine register_obgc_segments + +!> Stores the interior tracer values on the segment, and in some cases also sets the tracer reservoir values. +subroutine fill_obgc_segments(G, GV, OBC, tr_ptr, tr_name) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + real, dimension(:,:,:), pointer :: tr_ptr !< Pointer to tracer field in scaled concentration + !! units, like [S ~> ppt] for salinity. + character(len=*), intent(in) :: tr_name !< Tracer name +! Local variables + integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, n, nz, nt + integer :: i, j, k + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + real :: I_scale ! A factor that unscales the internal units of a tracer, like [ppt S-1 ~> 1] for salinity + + if (.not. associated(OBC)) return + call pass_var(tr_ptr, G%Domain) + nz = G%ke + do n=1,OBC%number_of_segments + segment => OBC%segment(n) + if (.not. segment%on_pe) cycle + nt = get_tracer_index(segment, tr_name) + if (nt < 0) then + call MOM_error(FATAL,"fill_obgc_segments: Did not find tracer "// tr_name) + endif + isd = segment%HI%isd ; ied = segment%HI%ied + jsd = segment%HI%jsd ; jed = segment%HI%jed + IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + + ! Fill segments with Tracer values + if (segment%direction == OBC_DIRECTION_W) then + I = segment%HI%IsdB + do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed + segment%tr_Reg%Tr(nt)%t(I,j,k) = tr_ptr(i+1,j,k) + enddo ; enddo + elseif (segment%direction == OBC_DIRECTION_E) then + I = segment%HI%IsdB + do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed + segment%tr_Reg%Tr(nt)%t(I,j,k) = tr_ptr(i,j,k) + enddo ; enddo + elseif (segment%direction == OBC_DIRECTION_S) then + J = segment%HI%JsdB + do k=1,nz ; do i=segment%HI%isd,segment%HI%ied + segment%tr_Reg%Tr(nt)%t(i,J,k) = tr_ptr(i,j+1,k) + enddo ; enddo + elseif (segment%direction == OBC_DIRECTION_N) then + J = segment%HI%JsdB + do k=1,nz ; do i=segment%HI%isd,segment%HI%ied + segment%tr_Reg%Tr(nt)%t(i,J,k) = tr_ptr(i,j,k) + enddo ; enddo + endif + + if (.not.segment%tr_Reg%Tr(nt)%is_initialized) & + segment%tr_Reg%Tr(nt)%tres(:,:,:) = segment%tr_Reg%Tr(nt)%t(:,:,:) + + if (OBC%reservoir_init_bug) then + ! OBC%tres_x and OBC%tres_y should not be set here, but in a subsequent call to setup_OBC_tracer_reservoirs. + ! Note that fill_obgc_segments is not called for runs that start from a restart file. + I_scale = 1.0 + if (segment%tr_Reg%Tr(nt)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(nt)%scale + if (segment%is_E_or_W) then + if (allocated(OBC%tres_x)) then + I = segment%HI%IsdB + do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed + OBC%tres_x(I,j,k,nt) = I_scale * segment%tr_Reg%Tr(nt)%tres(I,j,k) + enddo ; enddo + endif + else ! segment%is_N_or_S + if (allocated(OBC%tres_y)) then + J = segment%HI%JsdB + do k=1,nz ; do i=segment%HI%isd,segment%HI%ied + OBC%tres_y(i,J,k,nt) = I_scale * segment%tr_Reg%Tr(nt)%tres(i,J,k) + enddo ; enddo + endif + endif + endif + + enddo ! End of loop over segments. + +end subroutine fill_obgc_segments + +!> Set the value of temperatures and salinities on OBC segments +subroutine fill_temp_salt_segments(G, GV, US, OBC, tv) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< Unit scaling type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, n, nz integer :: i, j, k @@ -4620,12 +5465,9 @@ subroutine fill_temp_salt_segments(G, GV, OBC, tv) if (.not. associated(tv%T) .and. associated(tv%S)) return ! Both temperature and salinity fields - call pass_var(tv%T, G%Domain) - call pass_var(tv%S, G%Domain) - nz = GV%ke - do n=1, OBC%number_of_segments + do n=1,OBC%number_of_segments segment => OBC%segment(n) if (.not. segment%on_pe) cycle @@ -4658,13 +5500,68 @@ subroutine fill_temp_salt_segments(G, GV, OBC, tv) endif enddo ; enddo endif - segment%tr_Reg%Tr(1)%tres(:,:,:) = segment%tr_Reg%Tr(1)%t(:,:,:) - segment%tr_Reg%Tr(2)%tres(:,:,:) = segment%tr_Reg%Tr(2)%t(:,:,:) + if (.not.segment%tr_Reg%Tr(1)%is_initialized) & + segment%tr_Reg%Tr(1)%tres(:,:,:) = segment%tr_Reg%Tr(1)%t(:,:,:) + if (.not.segment%tr_Reg%Tr(2)%is_initialized) & + segment%tr_Reg%Tr(2)%tres(:,:,:) = segment%tr_Reg%Tr(2)%t(:,:,:) enddo - call setup_OBC_tracer_reservoirs(G, GV, OBC) end subroutine fill_temp_salt_segments +!> Set the value of temperatures and salinities on OBC segments +subroutine fill_thickness_segments(G, GV, US, OBC, h) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< Unit scaling + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + + integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, n, nz + integer :: i, j, k + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + + if (.not. associated(OBC)) return + ! Both temperature and salinity fields + + nz = GV%ke + + do n=1, OBC%number_of_segments + segment => OBC%segment(n) + if (.not. segment%on_pe) cycle + + isd = segment%HI%isd ; ied = segment%HI%ied + jsd = segment%HI%jsd ; jed = segment%HI%jed + IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + + ! Fill with thickness + if (segment%is_E_or_W) then + I=segment%HI%IsdB + do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed + if (segment%direction == OBC_DIRECTION_W) then + segment%h_Reg%h(I,j,k) = h(i+1,j,k) + else + segment%h_Reg%h(I,j,k) = h(i,j,k) + endif + enddo ; enddo + else + J=segment%HI%JsdB + do k=1,nz ; do i=segment%HI%isd,segment%HI%ied + if (segment%direction == OBC_DIRECTION_S) then + segment%h_Reg%h(i,J,k) = h(i,j+1,k) + else + segment%h_Reg%h(i,J,k) = h(i,j,k) + endif + enddo ; enddo + endif + if (.not.segment%h_Reg%is_initialized) then + segment%h_Reg%h_res(:,:,:) = segment%h_Reg%h(:,:,:) + segment%h_Reg%is_initialized = .true. + endif + enddo + +end subroutine fill_thickness_segments + !> Find the region outside of all open boundary segments and !! make sure it is set to land mask. Gonna need to know global land !! mask as well to get it right... @@ -4675,21 +5572,26 @@ subroutine mask_outside_OBCs(G, US, param_file, OBC) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables - integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, n integer :: i, j - integer :: l_seg logical :: fatal_error = .False. - real :: min_depth ! The minimum depth for ocean points [Z ~> m] + real :: min_depth ! The minimum depth for ocean points [Z ~> m] + real :: mask_depth ! The masking depth for ocean points [Z ~> m] + real :: Dmask ! The depth for masking in the same units as G%bathyT [Z ~> m]. integer, parameter :: cin = 3, cout = 4, cland = -1, cedge = -2 character(len=256) :: mesg ! Message for error messages. - type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list real, allocatable, dimension(:,:) :: color, color2 ! For sorting inside from outside, - ! two different ways + ! two different ways [nondim] if (.not. associated(OBC)) return call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & units="m", default=0.0, scale=US%m_to_Z, do_not_log=.true.) + call get_param(param_file, mdl, "MASKING_DEPTH", mask_depth, & + units="m", default=-9999.0, scale=US%m_to_Z, do_not_log=.true.) + + Dmask = mask_depth + if (mask_depth == -9999.0*US%m_to_Z) Dmask = min_depth + ! The reference depth on a dyn_horgrid is 0, otherwise would need: min_depth = min_depth - G%Z_ref allocate(color(G%isd:G%ied, G%jsd:G%jed), source=0.0) @@ -4719,50 +5621,38 @@ subroutine mask_outside_OBCs(G, US, param_file, OBC) enddo do j=G%jsd,G%jed ; do i=G%IsdB+1,G%IedB-1 - l_seg = OBC%segnum_u(I,j) - if (l_seg == OBC_NONE) cycle - - if (OBC%segment(l_seg)%direction == OBC_DIRECTION_W) then + if (OBC%segnum_u(I,j) < 0) then ! OBC_DIRECTION_W if (color(i,j) == 0.0) color(i,j) = cout if (color(i+1,j) == 0.0) color(i+1,j) = cin - elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then + elseif (OBC%segnum_u(I,j) > 0) then ! OBC_DIRECTION_E if (color(i,j) == 0.0) color(i,j) = cin if (color(i+1,j) == 0.0) color(i+1,j) = cout endif enddo ; enddo do J=G%JsdB+1,G%JedB-1 ; do i=G%isd,G%ied - l_seg = OBC%segnum_v(i,J) - if (l_seg == OBC_NONE) cycle - - if (OBC%segment(l_seg)%direction == OBC_DIRECTION_S) then + if (OBC%segnum_v(i,J) < 0) then ! OBC_DIRECTION_S if (color(i,j) == 0.0) color(i,j) = cout if (color(i,j+1) == 0.0) color(i,j+1) = cin - elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then + elseif (OBC%segnum_v(i,J) > 0) then ! OBC_DIRECTION_N if (color(i,j) == 0.0) color(i,j) = cin if (color(i,j+1) == 0.0) color(i,j+1) = cout endif enddo ; enddo do J=G%JsdB+1,G%JedB-1 ; do i=G%isd,G%ied - l_seg = OBC%segnum_v(i,J) - if (l_seg == OBC_NONE) cycle - - if (OBC%segment(l_seg)%direction == OBC_DIRECTION_S) then + if (OBC%segnum_v(i,J) < 0) then ! OBC_DIRECTION_S if (color2(i,j) == 0.0) color2(i,j) = cout if (color2(i,j+1) == 0.0) color2(i,j+1) = cin - elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then + elseif (OBC%segnum_v(i,J) > 0) then ! OBC_DIRECTION_N if (color2(i,j) == 0.0) color2(i,j) = cin if (color2(i,j+1) == 0.0) color2(i,j+1) = cout endif enddo ; enddo do j=G%jsd,G%jed ; do i=G%IsdB+1,G%IedB-1 - l_seg = OBC%segnum_u(I,j) - if (l_seg == OBC_NONE) cycle - - if (OBC%segment(l_seg)%direction == OBC_DIRECTION_W) then + if (OBC%segnum_u(I,j) < 0) then ! OBC_DIRECTION_W if (color2(i,j) == 0.0) color2(i,j) = cout if (color2(i+1,j) == 0.0) color2(i+1,j) = cin - elseif (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then + elseif (OBC%segnum_u(I,j) > 0) then ! OBC_DIRECTION_E if (color2(i,j) == 0.0) color2(i,j) = cin if (color2(i+1,j) == 0.0) color2(i+1,j) = cout endif @@ -4776,11 +5666,11 @@ subroutine mask_outside_OBCs(G, US, param_file, OBC) do j=G%jsd,G%jed ; do i=G%isd,G%ied if (color(i,j) /= color2(i,j)) then fatal_error = .True. - write(mesg,'("MOM_open_boundary: problem with OBC segments specification at ",I5,",",I5," during\n", & - "the masking of the outside grid points.")') i, j - call MOM_error(WARNING,"MOM register_tracer: "//mesg, all_print=.true.) + write(mesg,'("MOM_open_boundary: problem with OBC segments specification at ",I0,",",I0," during\n", & + &"the masking of the outside grid points.")') i, j + call MOM_error(WARNING,"MOM mask_outside_OBCs: "//mesg, all_print=.true.) endif - if (color(i,j) == cout) G%bathyT(i,j) = min_depth + if (color(i,j) == cout) G%bathyT(i,j) = Dmask enddo ; enddo if (fatal_error) call MOM_error(FATAL, & "MOM_open_boundary: inconsistent OBC segments.") @@ -4792,7 +5682,7 @@ end subroutine mask_outside_OBCs !> flood the cin, cout values subroutine flood_fill(G, color, cin, cout, cland) type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure - real, dimension(:,:), intent(inout) :: color !< For sorting inside from outside + real, dimension(:,:), intent(inout) :: color !< For sorting inside from outside [nondim] integer, intent(in) :: cin !< color for inside the domain integer, intent(in) :: cout !< color for outside the domain integer, intent(in) :: cland !< color for inside the land mask @@ -4852,7 +5742,7 @@ end subroutine flood_fill !> flood the cin, cout values subroutine flood_fill2(G, color, cin, cout, cland) type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure - real, dimension(:,:), intent(inout) :: color !< For sorting inside from outside + real, dimension(:,:), intent(inout) :: color !< For sorting inside from outside [nondim] integer, intent(in) :: cin !< color for inside the domain integer, intent(in) :: cout !< color for outside the domain integer, intent(in) :: cland !< color for inside the land mask @@ -4910,10 +5800,11 @@ subroutine flood_fill2(G, color, cin, cout, cland) end subroutine flood_fill2 !> Register OBC segment data for restarts -subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart_CS, & +subroutine open_boundary_register_restarts(HI, GV, US, OBC, Reg, param_file, restart_CS, & use_temperature) type(hor_index_type), intent(in) :: HI !< Horizontal indices type(verticalGrid_type), pointer :: GV !< Container for vertical grid information + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ocean_OBC_type), pointer :: OBC !< OBC data structure, data intent(inout) type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry type(param_file_type), intent(in) :: param_file !< Parameter file handle @@ -4921,40 +5812,81 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart logical, intent(in) :: use_temperature !< If true, T and S are used ! Local variables type(vardesc) :: vd(2) - integer :: m, n - character(len=100) :: mesg - type(OBC_segment_type), pointer :: segment=>NULL() + integer :: m + character(len=100) :: mesg, var_name if (.not. associated(OBC)) & call MOM_error(FATAL, "open_boundary_register_restarts: Called with "//& "uninitialized OBC control structure") - ! *** This is a temporary work around for restarts with OBC segments. + ! ### This is a temporary work around for restarts with OBC segments. ! This implementation uses 3D arrays solely for restarts. We need ! to be able to add 2D ( x,z or y,z ) data to restarts to avoid using - ! so much memory and disk space. *** + ! so much memory and disk space. if (OBC%radiation_BCs_exist_globally) then allocate(OBC%rx_normal(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke), source=0.0) allocate(OBC%ry_normal(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke), source=0.0) - vd(1) = var_desc("rx_normal", "m s-1", "Normal Phase Speed for EW radiation OBCs", 'u', 'L') - vd(2) = var_desc("ry_normal", "m s-1", "Normal Phase Speed for NS radiation OBCs", 'v', 'L') - call register_restart_pair(OBC%rx_normal, OBC%ry_normal, vd(1), vd(2), & - .false., restart_CS) + vd(1) = var_desc("rx_normal", "gridpoint timestep-1", "Normal Phase Speed for EW radiation OBCs", 'u', 'L') + vd(2) = var_desc("ry_normal", "gridpoint timestep-1", "Normal Phase Speed for NS radiation OBCs", 'v', 'L') + call register_restart_pair(OBC%rx_normal, OBC%ry_normal, vd(1), vd(2), .false., restart_CS, scalar_pair=.true.) + ! The rx_normal and ry_normal arrays used with radiation OBCs are currently in units of grid + ! points per timestep, but if this were to be corrected to [L T-1 ~> m s-1] or [T-1 ~> s-1] to + ! permit timesteps to change between calls to the OBC code, the following would be needed instead: + ! vd(1) = var_desc("rx_normal", "m s-1", "Normal Phase Speed for EW radiation OBCs", 'u', 'L') + ! vd(2) = var_desc("ry_normal", "m s-1", "Normal Phase Speed for NS radiation OBCs", 'v', 'L') + ! call register_restart_pair(OBC%rx_normal, OBC%ry_normal, vd(1), vd(2), .false., restart_CS, & + ! conversion=US%L_T_to_m_s, scalar_pair=.true.) endif if (OBC%oblique_BCs_exist_globally) then - allocate(OBC%rx_oblique(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke), source=0.0) - allocate(OBC%ry_oblique(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke), source=0.0) - - vd(1) = var_desc("rx_oblique", "m2 s-2", "Radiation Speed Squared for EW oblique OBCs", 'u', 'L') - vd(2) = var_desc("ry_oblique", "m2 s-2", "Radiation Speed Squared for NS oblique OBCs", 'v', 'L') - call register_restart_pair(OBC%rx_oblique, OBC%ry_oblique, vd(1), vd(2), & - .false., restart_CS) + allocate(OBC%rx_oblique_u(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke), source=0.0) + allocate(OBC%ry_oblique_u(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke), source=0.0) + allocate(OBC%cff_normal_u(HI%IsdB:HI%IedB,HI%jsd:HI%jed,GV%ke), source=0.0) + allocate(OBC%rx_oblique_v(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke), source=0.0) + allocate(OBC%ry_oblique_v(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke), source=0.0) + allocate(OBC%cff_normal_v(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke), source=0.0) + + vd(1) = var_desc("rx_oblique_u", "m2 s-2", "X-Direction Radiation Speed Squared for EW oblique OBCs", 'u', 'L') + vd(2) = var_desc("ry_oblique_v", "m2 s-2", "Y-Direction Radiation Speed Squared for NS oblique OBCs", 'v', 'L') + call register_restart_pair(OBC%rx_oblique_u, OBC%ry_oblique_v, vd(1), vd(2), .false., & + restart_CS, conversion=US%L_T_to_m_s**2) + vd(1) = var_desc("ry_oblique_u", "m2 s-2", "Y-Direction Radiation Speed Squared for EW oblique OBCs", 'u', 'L') + vd(2) = var_desc("rx_oblique_v", "m2 s-2", "X-Direction Radiation Speed Squared for NS oblique OBCs", 'v', 'L') + call register_restart_pair(OBC%ry_oblique_u, OBC%rx_oblique_v, vd(1), vd(2), .false., & + restart_CS, conversion=US%L_T_to_m_s**2) + + vd(1) = var_desc("norm_oblique_u", "m2 s-2", "Denominator for normalizing EW oblique OBC radiation rates", & + 'u', 'L') + vd(2) = var_desc("norm_oblique_v", "m2 s-2", "Denominator for normalizing NS oblique OBC radiation rates", & + 'v', 'L') + call register_restart_pair(OBC%cff_normal_u, OBC%cff_normal_v, vd(1), vd(2), .false., & + restart_CS, conversion=US%L_T_to_m_s**2) + endif - allocate(OBC%cff_normal(HI%IsdB:HI%IedB,HI%jsdB:HI%jedB,GV%ke), source=0.0) - vd(1) = var_desc("cff_normal", "m2 s-2", "denominator for oblique OBCs", 'q', 'L') - call register_restart_field(OBC%cff_normal, vd(1), .false., restart_CS) + if (OBC%thickness_x_reservoirs_used) then + allocate(OBC%h_res_x(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke), source=0.0) + if (modulo(HI%turns, 2) /= 0) then + write(var_name,'("h_res_y")') + call register_restart_field(OBC%h_res_x(:,:,:), var_name, .false., restart_CS, & + longname="Layer thickness for NS OBCs", units="Conc", hor_grid='v') + else + write(var_name,'("h_res_x")') + call register_restart_field(OBC%h_res_x(:,:,:), var_name, .false., restart_CS, & + longname="Layer thickness for EW OBCs", units="Conc", hor_grid='u') + endif + endif + if (OBC%thickness_y_reservoirs_used) then + allocate(OBC%h_res_y(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke), source=0.0) + if (modulo(HI%turns, 2) /= 0) then + write(var_name,'("h_res_x")') + call register_restart_field(OBC%h_res_y(:,:,:), var_name, .false., restart_CS, & + longname="Layer thickness for EW OBCs", units="Conc", hor_grid='u') + else + write(var_name,'("h_res_y")') + call register_restart_field(OBC%h_res_y(:,:,:), var_name, .false., restart_CS, & + longname="Layer thickness for NS OBCs", units="Conc", hor_grid='v') + endif endif if (Reg%ntr == 0) return @@ -4967,7 +5899,7 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart ! This would be coming from user code such as DOME. if (OBC%ntr /= Reg%ntr) then ! call MOM_error(FATAL, "open_boundary_register_restarts: Inconsistent value for ntr") - write(mesg,'("Inconsistent values for ntr ", I8," and ",I8,".")') OBC%ntr, Reg%ntr + write(mesg,'("Inconsistent values for ntr ", I0," and ",I0,".")') OBC%ntr, Reg%ntr call MOM_error(WARNING, 'open_boundary_register_restarts: '//mesg) endif endif @@ -4978,13 +5910,13 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart do m=1,OBC%ntr if (OBC%tracer_x_reservoirs_used(m)) then if (modulo(HI%turns, 2) /= 0) then - write(mesg,'("tres_y_",I3.3)') m - vd(1) = var_desc(mesg,"Conc", "Tracer concentration for NS OBCs",'v','L') - call register_restart_field(OBC%tres_x(:,:,:,m), vd(1), .false., restart_CS) + write(var_name,'("tres_y_",I3.3)') m + call register_restart_field(OBC%tres_x(:,:,:,m), var_name, .false., restart_CS, & + longname="Tracer concentration for NS OBCs", units="Conc", hor_grid='v') else - write(mesg,'("tres_x_",I3.3)') m - vd(1) = var_desc(mesg,"Conc", "Tracer concentration for EW OBCs",'u','L') - call register_restart_field(OBC%tres_x(:,:,:,m), vd(1), .false., restart_CS) + write(var_name,'("tres_x_",I3.3)') m + call register_restart_field(OBC%tres_x(:,:,:,m), var_name, .false., restart_CS, & + longname="Tracer concentration for EW OBCs", units="Conc", hor_grid='u') endif endif enddo @@ -4994,21 +5926,22 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart do m=1,OBC%ntr if (OBC%tracer_y_reservoirs_used(m)) then if (modulo(HI%turns, 2) /= 0) then - write(mesg,'("tres_x_",I3.3)') m - vd(1) = var_desc(mesg,"Conc", "Tracer concentration for EW OBCs",'u','L') - call register_restart_field(OBC%tres_y(:,:,:,m), vd(1), .false., restart_CS) + write(var_name,'("tres_x_",I3.3)') m + call register_restart_field(OBC%tres_y(:,:,:,m), var_name, .false., restart_CS, & + longname="Tracer concentration for EW OBCs", units="Conc", hor_grid='u') else - write(mesg,'("tres_y_",I3.3)') m - vd(1) = var_desc(mesg,"Conc", "Tracer concentration for NS OBCs",'v','L') - call register_restart_field(OBC%tres_y(:,:,:,m), vd(1), .false., restart_CS) + write(var_name,'("tres_y_",I3.3)') m + call register_restart_field(OBC%tres_y(:,:,:,m), var_name, .false., restart_CS, & + longname="Tracer concentration for NS OBCs", units="Conc", hor_grid='v') endif endif enddo endif + end subroutine open_boundary_register_restarts !> Update the OBC tracer reservoirs after the tracers have been updated. -subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) +subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, Reg) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: uhr !< accumulated volume/mass flux through @@ -5018,21 +5951,37 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness after advection !! [H ~> m or kg m-2] type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - real, intent(in) :: dt !< time increment [T ~> s] type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry - type(OBC_segment_type), pointer :: segment=>NULL() - real :: u_L_in, u_L_out ! The zonal distance moved in or out of a cell [L ~> m] - real :: v_L_in, v_L_out ! The meridional distance moved in or out of a cell [L ~> m] + ! Local variable + type(OBC_segment_type), pointer :: segment => NULL() + real :: u_L_in, u_L_out ! The zonal distance moved in or out of a cell, normalized by the reservoir + ! length scale [nondim] + real :: v_L_in, v_L_out ! The meridional distance moved in or out of a cell, normalized by the reservoir + ! length scale [nondim] real :: fac1 ! The denominator of the expression for tracer updates [nondim] - integer :: i, j, k, m, n, ntr, nz + real :: I_scale ! The inverse of the scaling factor for the tracers. + ! For salinity the units would be [ppt S-1 ~> 1] + integer :: i, j, k, m, n, ntr, nz, ntr_id, fd_id integer :: ishift, idir, jshift, jdir - + real :: resrv_lfac_out ! The reservoir inverse length scale scaling factor for the outward + ! direction per field [nondim] + real :: resrv_lfac_in ! The reservoir inverse length scale scaling factor for the inward + ! direction per field [nondim] + real :: b_in, b_out ! The 0 and 1 switch for tracer reservoirs + ! 1 if the length scale of reservoir is zero [nondim] + real :: a_in, a_out ! The 0 and 1(-1) switch for reservoir source weights + ! e.g. a_in is -1 only if b_in ==1 and uhr or vhr is inward + ! e.g. a_out is 1 only if b_out==1 and uhr or vhr is outward + ! It's clear that a_in and a_out cannot be both non-zero [nondim] nz = GV%ke ntr = Reg%ntr + if (associated(OBC)) then ; if (OBC%OBC_pe) then ; do n=1,OBC%number_of_segments - segment=>OBC%segment(n) + segment => OBC%segment(n) if (.not. associated(segment%tr_Reg)) cycle + b_in = 0.0 ; if (segment%Tr_InvLscale_in == 0.0) b_in = 1.0 + b_out = 0.0 ; if (segment%Tr_InvLscale_out == 0.0) b_out = 1.0 if (segment%is_E_or_W) then I = segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed @@ -5046,17 +5995,162 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) ! Can keep this or take it out, either way if (G%mask2dT(I+ishift,j) == 0.0) cycle ! Update the reservoir tracer concentration implicitly using a Backward-Euler timestep - do m=1,ntr ; if (allocated(segment%tr_Reg%Tr(m)%tres)) then ; do k=1,nz - u_L_out = max(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_out / & + do m=1,segment%tr_Reg%ntseg + ntr_id = segment%tr_Reg%Tr(m)%ntr_index + fd_id = segment%tr_Reg%Tr(m)%fd_index + if (fd_id == -1) then + resrv_lfac_out = 1.0 + resrv_lfac_in = 1.0 + else + resrv_lfac_out = segment%field(fd_id)%resrv_lfac_out + resrv_lfac_in = segment%field(fd_id)%resrv_lfac_in + endif + I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale + if (allocated(segment%tr_Reg%Tr(m)%tres)) then ; do k=1,nz + ! Calculate weights. Both a and u_L are nondim. Adding them together has no meaning. + ! However, since they cannot be both non-zero, adding them works like a switch. + ! When InvLscale_out is 0 and outflow, only interior data is applied to reservoirs + ! When InvLscale_in is 0 and inflow, only nudged data is applied to reservoirs + a_out = b_out * max(0.0, sign(1.0, idir*uhr(I,j,k))) + a_in = b_in * min(0.0, sign(1.0, idir*uhr(I,j,k))) + u_L_out = max(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_out*resrv_lfac_out / & + ((h(i+ishift,j,k) + GV%H_subroundoff)*G%dyCu(I,j))) + u_L_in = min(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_in*resrv_lfac_in / & + ((h(i+ishift,j,k) + GV%H_subroundoff)*G%dyCu(I,j))) + fac1 = (1.0 - (a_out - a_in)) + ((u_L_out + a_out) - (u_L_in + a_in)) + segment%tr_Reg%Tr(m)%tres(I,j,k) = (1.0/fac1) * & + ((1.0-a_out+a_in)*segment%tr_Reg%Tr(m)%tres(I,j,k)+ & + ((u_L_out+a_out)*Reg%Tr(ntr_id)%t(I+ishift,j,k) - & + (u_L_in+a_in)*segment%tr_Reg%Tr(m)%t(I,j,k))) + if (allocated(OBC%tres_x)) OBC%tres_x(I,j,k,m) = I_scale * segment%tr_Reg%Tr(m)%tres(I,j,k) + enddo ; endif + enddo + enddo + elseif (segment%is_N_or_S) then + J = segment%HI%JsdB + do i=segment%HI%isd,segment%HI%ied + ! jshift+J corresponds to the nearest interior tracer cell index + ! jdir switches the sign of the flow so that positive is into the reservoir + if (segment%direction == OBC_DIRECTION_S) then + jshift = 1 ; jdir = -1 + else + jshift = 0 ; jdir = 1 + endif + ! Can keep this or take it out, either way + if (G%mask2dT(i,j+jshift) == 0.0) cycle + ! Update the reservoir tracer concentration implicitly using a Backward-Euler timestep + do m=1,segment%tr_Reg%ntseg + ntr_id = segment%tr_Reg%Tr(m)%ntr_index + fd_id = segment%tr_Reg%Tr(m)%fd_index + if (fd_id == -1) then + resrv_lfac_out = 1.0 + resrv_lfac_in = 1.0 + else + resrv_lfac_out = segment%field(fd_id)%resrv_lfac_out + resrv_lfac_in = segment%field(fd_id)%resrv_lfac_in + endif + I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale + if (allocated(segment%tr_Reg%Tr(m)%tres)) then ; do k=1,nz + a_out = b_out * max(0.0, sign(1.0, jdir*vhr(i,J,k))) + a_in = b_in * min(0.0, sign(1.0, jdir*vhr(i,J,k))) + v_L_out = max(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_out*resrv_lfac_out / & + ((h(i,j+jshift,k) + GV%H_subroundoff)*G%dxCv(i,J))) + v_L_in = min(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_in*resrv_lfac_in / & + ((h(i,j+jshift,k) + GV%H_subroundoff)*G%dxCv(i,J))) + fac1 = (1.0 - (a_out - a_in)) + ((v_L_out + a_out) - (v_L_in + a_in)) + segment%tr_Reg%Tr(m)%tres(i,J,k) = (1.0/fac1) * & + ((1.0-a_out+a_in)*segment%tr_Reg%Tr(m)%tres(i,J,k) + & + ((v_L_out+a_out)*Reg%Tr(ntr_id)%t(i,J+jshift,k) - & + (v_L_in+a_in)*segment%tr_Reg%Tr(m)%t(i,J,k))) + if (allocated(OBC%tres_y)) OBC%tres_y(i,J,k,m) = I_scale * segment%tr_Reg%Tr(m)%tres(i,J,k) + enddo ; endif + enddo + enddo + endif + enddo ; endif ; endif + +end subroutine update_segment_tracer_reservoirs + +!> Update the OBC thickness reservoirs after the thicknesses have been updated. +subroutine update_segment_thickness_reservoirs(G, GV, uhr, vhr, h, OBC) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: uhr !< accumulated volume/mass flux through + !! the zonal face [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: vhr !< accumulated volume/mass flux through + !! the meridional face [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness after advection + !! [H ~> m or kg m-2] + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + + ! Local variable + type(OBC_segment_type), pointer :: segment=>NULL() + real :: u_L_in, u_L_out ! The zonal distance moved in or out of a cell, normalized by the reservoir + ! length scale [nondim] + real :: v_L_in, v_L_out ! The meridional distance moved in or out of a cell, normalized by the reservoir + ! length scale [nondim] + real :: fac1 ! The denominator of the expression for tracer updates [nondim] + real :: I_scale ! The inverse of the scaling factor for the tracers. + ! For salinity the units would be [ppt S-1 ~> 1] + integer :: i, j, k, n, nz, fd_id + integer :: ishift, idir, jshift, jdir + real :: resrv_lfac_out ! The reservoir inverse length scale scaling factor for the outward + ! direction per field [nondim] + real :: resrv_lfac_in ! The reservoir inverse length scale scaling factor for the inward + ! direction per field [nondim] + real :: b_in, b_out ! The 0 and 1 switch for tracer reservoirs + ! 1 if the length scale of reservoir is zero [nondim] + real :: a_in, a_out ! The 0 and 1(-1) switch for reservoir source weights + ! e.g. a_in is -1 only if b_in ==1 and uhr or vhr is inward + ! e.g. a_out is 1 only if b_out==1 and uhr or vhr is outward + ! It's clear that a_in and a_out cannot be both non-zero [nondim] + nz = GV%ke + + if (associated(OBC)) then ; if (OBC%OBC_pe) then ; do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + if (.not. associated(segment%h_Reg)) cycle + b_in = 0.0 ; if (segment%Tr_InvLscale_in == 0.0) b_in = 1.0 + b_out = 0.0 ; if (segment%Tr_InvLscale_out == 0.0) b_out = 1.0 + if (segment%is_E_or_W) then + I = segment%HI%IsdB + do j=segment%HI%jsd,segment%HI%jed + ! ishift+I corresponds to the nearest interior tracer cell index + ! idir switches the sign of the flow so that positive is into the reservoir + if (segment%direction == OBC_DIRECTION_W) then + ishift = 1 ; idir = -1 + else + ishift = 0 ; idir = 1 + endif + ! Can keep this or take it out, either way + if (G%mask2dT(I+ishift,j) == 0.0) cycle + ! Update the reservoir thickness concentration implicitly using a Backward-Euler timestep + fd_id = segment%h_Reg%fd_index + if (fd_id == -1) then + resrv_lfac_out = 1.0 + resrv_lfac_in = 1.0 + else + resrv_lfac_out = segment%field(fd_id)%resrv_lfac_out + resrv_lfac_in = segment%field(fd_id)%resrv_lfac_in + endif + I_scale = 1.0 ; if (segment%h_Reg%scale /= 0.0) I_scale = 1.0 / segment%h_Reg%scale + if (allocated(segment%h_Reg%h_res)) then ; do k=1,nz + ! Calculate weights. Both a and u_L are nondim. Adding them together has no meaning. + ! However, since they cannot be both non-zero, adding them works like a switch. + ! When InvLscale_out is 0 and outflow, only interior data is applied to reservoirs + ! When InvLscale_in is 0 and inflow, only nudged data is applied to reservoirs + a_out = b_out * max(0.0, sign(1.0, idir*uhr(I,j,k))) + a_in = b_in * min(0.0, sign(1.0, idir*uhr(I,j,k))) + u_L_out = max(0.0, (idir*uhr(I,j,k))*segment%Th_InvLscale_out*resrv_lfac_out / & ((h(i+ishift,j,k) + GV%H_subroundoff)*G%dyCu(I,j))) - u_L_in = min(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_in / & + u_L_in = min(0.0, (idir*uhr(I,j,k))*segment%Th_InvLscale_in*resrv_lfac_in / & ((h(i+ishift,j,k) + GV%H_subroundoff)*G%dyCu(I,j))) - fac1 = 1.0 + (u_L_out-u_L_in) - segment%tr_Reg%Tr(m)%tres(I,j,k) = (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(I,j,k) + & - (u_L_out*Reg%Tr(m)%t(I+ishift,j,k) - & - u_L_in*segment%tr_Reg%Tr(m)%t(I,j,k))) - if (allocated(OBC%tres_x)) OBC%tres_x(I,j,k,m) = segment%tr_Reg%Tr(m)%tres(I,j,k) - enddo ; endif ; enddo + fac1 = (1.0 - (a_out - a_in)) + ((u_L_out + a_out) - (u_L_in + a_in)) + segment%h_Reg%h_res(I,j,k) = (1.0/fac1) * & + ((1.0-a_out+a_in)*segment%h_Reg%h_res(I,j,k)+ & + ((u_L_out+a_out)*h(i+ishift,j,k) - & + (u_L_in+a_in)*segment%h_Reg%h(I,j,k))) + if (allocated(OBC%h_res_x)) OBC%h_res_x(I,j,k) = I_scale * segment%h_Reg%h_res(I,j,k) + enddo ; endif enddo elseif (segment%is_N_or_S) then J = segment%HI%JsdB @@ -5071,74 +6165,347 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) ! Can keep this or take it out, either way if (G%mask2dT(i,j+jshift) == 0.0) cycle ! Update the reservoir tracer concentration implicitly using a Backward-Euler timestep - do m=1,ntr ; if (allocated(segment%tr_Reg%Tr(m)%tres)) then ; do k=1,nz - v_L_out = max(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_out / & + fd_id = segment%h_Reg%fd_index + if (fd_id == -1) then + resrv_lfac_out = 1.0 + resrv_lfac_in = 1.0 + else + resrv_lfac_out = segment%field(fd_id)%resrv_lfac_out + resrv_lfac_in = segment%field(fd_id)%resrv_lfac_in + endif + I_scale = 1.0 ; if (segment%h_Reg%scale /= 0.0) I_scale = 1.0 / segment%h_Reg%scale + if (allocated(segment%h_Reg%h_res)) then ; do k=1,nz + a_out = b_out * max(0.0, sign(1.0, jdir*vhr(i,J,k))) + a_in = b_in * min(0.0, sign(1.0, jdir*vhr(i,J,k))) + v_L_out = max(0.0, (jdir*vhr(i,J,k))*segment%Th_InvLscale_out*resrv_lfac_out / & ((h(i,j+jshift,k) + GV%H_subroundoff)*G%dxCv(i,J))) - v_L_in = min(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_in / & + v_L_in = min(0.0, (jdir*vhr(i,J,k))*segment%Th_InvLscale_in*resrv_lfac_in / & ((h(i,j+jshift,k) + GV%H_subroundoff)*G%dxCv(i,J))) - fac1 = 1.0 + (v_L_out-v_L_in) - segment%tr_Reg%Tr(m)%tres(i,J,k) = (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(i,J,k) + & - (v_L_out*Reg%Tr(m)%t(i,J+jshift,k) - & - v_L_in*segment%tr_Reg%Tr(m)%t(i,J,k))) - if (allocated(OBC%tres_y)) OBC%tres_y(i,J,k,m) = segment%tr_Reg%Tr(m)%tres(i,J,k) - enddo ; endif ; enddo + fac1 = (1.0 - (a_out - a_in)) + ((v_L_out + a_out) - (v_L_in + a_in)) + segment%h_Reg%h_res(i,J,k) = (1.0/fac1) * & + ((1.0-a_out+a_in)*segment%h_Reg%h_res(i,J,k) + & + ((v_L_out+a_out)*h(i,j+jshift,k) - & + (v_L_in+a_in)*segment%h_Reg%h(i,J,k))) + if (allocated(OBC%h_res_y)) OBC%h_res_y(i,J,k) = I_scale * segment%h_Reg%h_res(i,J,k) + enddo ; endif enddo endif enddo ; endif ; endif -end subroutine update_segment_tracer_reservoirs +end subroutine update_segment_thickness_reservoirs + +!> Vertically remap the OBC tracer reservoirs and radiation rates that are filtered in time. +subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_old !< Thickness of source grid [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness of destination grid [H ~> m or kg m-2] + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + logical, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: PCM_cell !< Use PCM remapping in cells where true + + ! Local variables + type(OBC_segment_type), pointer :: segment => NULL() ! A pointer to the various segments, used just for shorthand. + + real :: tr_column(GV%ke) ! A column of updated tracer concentrations in internally scaled units. + ! For salinity the units would be [S ~> ppt]. + real :: r_norm_col(GV%ke) ! A column of updated radiation rates, in grid points per timestep [nondim] + real :: rxy_col(GV%ke) ! A column of updated radiation rates for oblique OBCs [L2 T-2 ~> m2 s-2] + 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 :: I_scale ! The inverse of the scaling factor for the tracers. + ! For salinity the units would be [ppt S-1 ~> 1]. + logical :: PCM(GV%ke) ! If true, do PCM remapping from a cell. + integer :: i, j, k, m, n, ntr, nz + + if (.not.associated(OBC)) return + + nz = GV%ke + ntr = OBC%ntr + + if (.not.present(PCM_cell)) PCM(:) = .false. + + if (associated(OBC)) then ; if (OBC%OBC_pe) then ; do n=1,OBC%number_of_segments + segment => OBC%segment(n) + if (.not.associated(segment%tr_Reg)) cycle + + if (segment%is_E_or_W) then + I = segment%HI%IsdB + do j=segment%HI%jsd,segment%HI%jed + + ! Store a column of the start and final grids + if (segment%direction == OBC_DIRECTION_W) then + if (G%mask2dT(i+1,j) == 0.0) cycle + h1(:) = h_old(i+1,j,:) + h2(:) = h_new(i+1,j,:) + if (present(PCM_cell)) then ; PCM(:) = PCM_cell(i+1,j,:) ; endif + else + if (G%mask2dT(i,j) == 0.0) cycle + h1(:) = h_old(i,j,:) + h2(:) = h_new(i,j,:) + if (present(PCM_cell)) then ; PCM(:) = PCM_cell(i,j,:) ; endif + endif + + ! Vertically remap the reservoir tracer concentrations + do m=1,ntr ; if (allocated(segment%tr_Reg%Tr(m)%tres)) then + 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_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_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? + + ! Update tracer concentrations + segment%tr_Reg%Tr(m)%tres(I,j,:) = tr_column(:) + if (allocated(OBC%tres_x)) then ; do k=1,nz + OBC%tres_x(I,j,k,m) = I_scale * segment%tr_Reg%Tr(m)%tres(I,j,k) + enddo ; endif + + endif ; enddo + + ! Vertically remap the reservoir thicknesses? + if (associated(segment%h_Reg)) then + if (allocated(segment%h_Reg%h_res)) then + I_scale = 1.0 ; if (segment%h_Reg%scale /= 0.0) I_scale = 1.0 / segment%h_Reg%scale + + if (present(PCM_cell)) then + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%h_Reg%h_res(I,j,:), nz, h2, tr_column, & + PCM_cell=PCM) + else + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%h_Reg%h_res(I,j,:), nz, h2, tr_column) + endif + + ! Possibly underflow any very tiny tracer concentrations to 0? + + ! Update tracer concentrations + segment%h_Reg%h_res(I,j,:) = tr_column(:) + if (allocated(OBC%h_res_x)) then ; do k=1,nz + OBC%h_res_x(I,j,k) = I_scale * segment%h_Reg%h_res(I,j,k) + enddo ; endif + endif + endif + + if (segment%radiation .and. (OBC%gamma_uv < 1.0)) then + 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) + OBC%rx_normal(I,j,k) = segment%rx_norm_rad(I,j,k) + enddo + endif + + if (segment%oblique .and. (OBC%gamma_uv < 1.0)) then + 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_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_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 + OBC%rx_oblique_u(I,j,k) = segment%rx_norm_obl(I,j,k) + OBC%ry_oblique_u(I,j,k) = segment%ry_norm_obl(I,j,k) + OBC%cff_normal_u(I,j,k) = segment%cff_normal(I,j,k) + enddo + endif + + enddo + elseif (segment%is_N_or_S) then + J = segment%HI%JsdB + do i=segment%HI%isd,segment%HI%ied + + ! Store a column of the start and final grids + if (segment%direction == OBC_DIRECTION_S) then + if (G%mask2dT(i,j+1) == 0.0) cycle + h1(:) = h_old(i,j+1,:) + h2(:) = h_new(i,j+1,:) + if (present(PCM_cell)) then ; PCM(:) = PCM_cell(i,j+1,:) ; endif + else + if (G%mask2dT(i,j) == 0.0) cycle + h1(:) = h_old(i,j,:) + h2(:) = h_new(i,j,:) + if (present(PCM_cell)) then ; PCM(:) = PCM_cell(i,j,:) ; endif + endif + + ! Vertically remap the reservoir tracer concentrations + do m=1,ntr ; if (allocated(segment%tr_Reg%Tr(m)%tres)) then + 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_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_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? + + ! Update tracer concentrations + segment%tr_Reg%Tr(m)%tres(i,J,:) = tr_column(:) + if (allocated(OBC%tres_y)) then ; do k=1,nz + OBC%tres_y(i,J,k,m) = I_scale * segment%tr_Reg%Tr(m)%tres(i,J,k) + enddo ; endif + + endif ; enddo + + ! Vertically remap the reservoir thicknesses? + if (associated(segment%h_Reg)) then + if (allocated(segment%h_Reg%h_res)) then + I_scale = 1.0 ; if (segment%h_Reg%scale /= 0.0) I_scale = 1.0 / segment%h_Reg%scale + + if (present(PCM_cell)) then + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%h_Reg%h_res(i,J,:), nz, h2, tr_column, & + PCM_cell=PCM) + else + call remapping_core_h(OBC%remap_h_CS, nz, h1, segment%h_Reg%h_res(i,J,:), nz, h2, tr_column) + endif + + ! Possibly underflow any very tiny tracer concentrations to 0? + + ! Update tracer concentrations + segment%h_Reg%h_res(i,J,:) = tr_column(:) + if (allocated(OBC%h_res_y)) then ; do k=1,nz + OBC%h_res_y(i,J,k) = I_scale * segment%h_Reg%h_res(i,J,k) + enddo ; endif + endif + endif + + if (segment%radiation .and. (OBC%gamma_uv < 1.0)) then + 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) + OBC%ry_normal(i,J,k) = segment%ry_norm_rad(i,J,k) + enddo + endif + + if (segment%oblique .and. (OBC%gamma_uv < 1.0)) then + 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_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_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 + OBC%rx_oblique_v(i,J,k) = segment%rx_norm_obl(i,J,k) + OBC%ry_oblique_v(i,J,k) = segment%ry_norm_obl(i,J,k) + OBC%cff_normal_v(i,J,k) = segment%cff_normal(i,J,k) + enddo + endif + + enddo + endif + enddo ; endif ; endif + if (OBC%radiation_BCs_exist_globally) call pass_vector(OBC%rx_normal, OBC%ry_normal, G%Domain, & + To_All+Scalar_Pair) + if (OBC%oblique_BCs_exist_globally) then + call do_group_pass(OBC%pass_oblique, G%Domain) + endif + +end subroutine remap_OBC_fields + !> Adjust interface heights to fit the bathymetry and diagnose layer thickness. !! !! If the bottom most interface is below the topography then the bottom-most -!! layers are contracted to GV%Angstrom_m. +!! layers are contracted to GV%Angstrom_Z. !! If the bottom most interface is above the topography then the entire column !! is dilated (expanded) to fill the void. !! @remark{There is a (hard-wired) "tolerance" parameter such that the !! criteria for adjustment must equal or exceed 10cm.} -subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) +subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment, fld, at_node) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(OBC_segment_type), intent(inout) :: segment !< OBC segment integer, intent(in) :: fld !< field index to adjust thickness + logical, intent(in) :: at_node !< True this point is at the OBC nodes rather than the faces integer :: i, j, k, is, ie, js, je, nz, contractions, dilations - integer :: n real, allocatable, dimension(:,:,:) :: eta ! Segment source data interface heights [Z ~> m] + real, allocatable, dimension(:,:) :: dz_tot ! Segment total thicknesses [Z ~> m] real :: hTolerance = 0.1 !< Tolerance to exceed adjustment criteria [Z ~> m] ! real :: dilate ! A factor by which to dilate the water column [nondim] - character(len=100) :: mesg + !character(len=100) :: mesg hTolerance = 0.1*US%m_to_Z nz = size(segment%field(fld)%dz_src,3) if (segment%is_E_or_W) then - ! segment thicknesses are defined at cell face centers. - is = segment%HI%isdB ; ie = segment%HI%iedB - js = segment%HI%jsd ; je = segment%HI%jed - else - is = segment%HI%isd ; ie = segment%HI%ied + is = segment%HI%IsdB ; ie = segment%HI%IedB + if (at_node) then ! This point is at the OBC nodes, rather than the cell face centers. + Js = max(segment%Js_obc, G%jsd) + Je = min(segment%Je_obc, G%jed-1) + else ! Segment thicknesses are defined at cell face centers. + js = segment%HI%jsd ; je = segment%HI%jed + endif + else ! segment%is_N_or_S js = segment%HI%jsdB ; je = segment%HI%jedB + if (at_node) then ! This point is at the OBC nodes, rather than the cell face centers. + is = max(segment%HI%IsdB, G%isd) + ie = min(segment%HI%IedB, G%ied-1) + else ! Segment thicknesses are defined at cell face centers. + is = segment%HI%isd ; ie = segment%HI%ied + endif endif allocate(eta(is:ie,js:je,nz+1)) - contractions=0; dilations=0 + allocate(dz_tot(is:ie,js:je), source=0.0) + + if (at_node) then + if (segment%is_E_or_W) then + I = Is + do J=Js,Je + dz_tot(I,J) = 0.5*(segment%dZtot(I,j) + segment%dZtot(I,j+1)) + enddo + ! Do not extrapolate past the end of a global segment. + ! ### For a concave corner between segments, perhaps we should do something more sophisticated. + if (Js == segment%Js_obc) dz_tot(I,Js) = segment%dZtot(I,js+1) + if (Je == segment%Js_obc) dz_tot(I,Je) = segment%dZtot(I,je) + else + J = Js + do I=Is,Ie + dz_tot(I,J) = 0.5*(segment%dZtot(i,J) + segment%dZtot(i+1,J)) + enddo + ! Do not extrapolate past the end of a global segment. + if (Is == segment%Is_obc) dz_tot(Is,J) = segment%dZtot(is+1,J) + if (Ie == segment%Is_obc) dz_tot(Ie,J) = segment%dZtot(ie,J) + endif + else + do j=js,je ; do i=is,ie + dz_tot(i,j) = segment%dZtot(i,j) + enddo ; enddo + endif + + contractions = 0 ; dilations = 0 do j=js,je ; do i=is,ie - eta(i,j,1)=0.0 ! segment data are assumed to be located on a static grid + eta(i,j,1) = 0.0 ! segment data are assumed to be located on a static grid ! For remapping calls, the entire column will be dilated ! by a factor equal to the ratio of the sum of the geopotential referenced ! source data thicknesses, and the current model thicknesses. This could be ! an issue to be addressed, for instance if we are placing open boundaries ! under ice shelf cavities. do k=2,nz+1 - eta(i,j,k)=eta(i,j,k-1)-segment%field(fld)%dz_src(i,j,k-1) + eta(i,j,k) = eta(i,j,k-1) - segment%field(fld)%dz_src(i,j,k-1) enddo ! The normal slope at the boundary is zero by a ! previous call to open_boundary_impose_normal_slope do k=nz+1,1,-1 - if (-eta(i,j,k) > segment%Htot(i,j)*GV%H_to_Z + hTolerance) then - eta(i,j,k) = -segment%Htot(i,j)*GV%H_to_Z + if (-eta(i,j,k) > dz_tot(i,j) + hTolerance) then + eta(i,j,k) = -dz_tot(i,j) contractions = contractions + 1 endif enddo @@ -5156,11 +6523,11 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) ! The whole column is dilated to accommodate deeper topography than ! the bathymetry would indicate. - if (-eta(i,j,nz+1) < (segment%Htot(i,j) * GV%H_to_Z) - hTolerance) then + if (-eta(i,j,nz+1) < dz_tot(i,j) - hTolerance) then dilations = dilations + 1 ! expand bottom-most cell only - eta(i,j,nz+1) = -(segment%Htot(i,j) * GV%H_to_Z) - segment%field(fld)%dz_src(i,j,nz)= eta(i,j,nz)-eta(i,j,nz+1) + eta(i,j,nz+1) = -dz_tot(i,j) + segment%field(fld)%dz_src(i,j,nz) = eta(i,j,nz) - eta(i,j,nz+1) ! if (eta(i,j,1) <= eta(i,j,nz+1)) then ! do k=1,nz ; segment%field(fld)%dz_src(i,j,k) = (eta(i,j,1) + G%bathyT(i,j)) / real(nz) ; enddo ! else @@ -5169,41 +6536,37 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) ! endif !do k=nz,2,-1 ; eta(i,j,K) = eta(i,j,K+1) + segment%field(fld)%dz_src(i,j,k) ; enddo endif - ! Now convert thicknesses to units of H. - do k=1,nz - segment%field(fld)%dz_src(i,j,k) = segment%field(fld)%dz_src(i,j,k)*GV%Z_to_H - enddo enddo ; enddo ! can not do communication call here since only PEs on the current segment are here - ! call sum_across_PEs(contractions) ! if ((contractions > 0) .and. (is_root_pe())) then ! write(mesg,'("Thickness OBCs were contracted ",'// & - ! '"to fit topography in ",I8," places.")') contractions + ! '"to fit topography in ",I0," places.")') contractions ! call MOM_error(WARNING, 'adjustEtaToFitBathymetry: '//mesg) ! endif ! call sum_across_PEs(dilations) ! if ((dilations > 0) .and. (is_root_pe())) then ! write(mesg,'("Thickness OBCs were dilated ",'// & - ! '"to fit topography in ",I8," places.")') dilations + ! '"to fit topography in ",I0," places.")') dilations ! call MOM_error(WARNING, 'adjustEtaToFitBathymetry: '//mesg) ! endif - deallocate(eta) + + deallocate(eta, dz_tot) end subroutine adjustSegmentEtaToFitBathymetry !> This is more of a rotate initialization than an actual rotate subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) - type(ocean_OBC_type), pointer, intent(in) :: OBC_in !< Input OBC - type(dyn_horgrid_type), intent(in) :: G_in !< Input grid metric + type(ocean_OBC_type), pointer, intent(in) :: OBC_in !< Input OBC + type(dyn_horgrid_type), intent(in) :: G_in !< Input grid type(ocean_OBC_type), pointer, intent(inout) :: OBC !< Rotated OBC - type(dyn_horgrid_type), intent(in) :: G !< Rotated grid metric - integer, intent(in) :: turns !< Number of quarter turns + type(dyn_horgrid_type), intent(in) :: G !< Rotated grid + integer, intent(in) :: turns !< Number of quarter turns - integer :: l + integer :: c, n, l_seg - if (OBC_in%number_of_segments==0) return + if (OBC_in%number_of_segments == 0) return ! Scalar and logical transfer OBC%number_of_segments = OBC_in%number_of_segments @@ -5211,65 +6574,119 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) OBC%user_BCs_set_globally = OBC_in%user_BCs_set_globally ! These are conditionally read and set if number_of_segments > 0 - OBC%zero_vorticity = OBC_in%zero_vorticity - OBC%freeslip_vorticity = OBC_in%freeslip_vorticity - OBC%computed_vorticity = OBC_in%computed_vorticity - OBC%specified_vorticity = OBC_in%specified_vorticity - OBC%zero_strain = OBC_in%zero_strain - OBC%freeslip_strain = OBC_in%freeslip_strain - OBC%computed_strain = OBC_in%computed_strain - OBC%specified_strain = OBC_in%specified_strain + OBC%vorticity_config = OBC_in%vorticity_config + OBC%strain_config = OBC_in%strain_config OBC%zero_biharmonic = OBC_in%zero_biharmonic OBC%silly_h = OBC_in%silly_h OBC%silly_u = OBC_in%silly_u + OBC%reverse_segment_order = OBC_in%reverse_segment_order ! Segment rotation allocate(OBC%segment(0:OBC%number_of_segments)) - do l = 1, OBC%number_of_segments - call rotate_OBC_segment_config(OBC_in%segment(l), G_in, OBC%segment(l), G, turns) - ! Data up to setup_[uv]_point_obc is needed for allocate_obc_segment_data! - call allocate_OBC_segment_data(OBC, OBC%segment(l)) - call rotate_OBC_segment_data(OBC_in%segment(l), OBC%segment(l), turns) + do l_seg=1,OBC%number_of_segments + call rotate_OBC_segment_config(OBC_in%segment(l_seg), G_in, OBC%segment(l_seg), G, turns) + ! Data stored in setup_[uv]_point_obc is needed for allocate_obc_segment_data + call allocate_OBC_segment_data(OBC, OBC%segment(l_seg)) enddo ! The horizontal segment map - allocate(OBC%segnum_u(G%IsdB:G%IedB,G%jsd:G%jed)) - allocate(OBC%segnum_v(G%isd:G%ied,G%JsdB:G%JedB)) - call rotate_array_pair(OBC_in%segnum_u, OBC_in%segnum_v, turns, & - OBC%segnum_u, OBC%segnum_v) + allocate(OBC%segnum_u(G%IsdB:G%IedB,G%jsd:G%jed), source=0) + allocate(OBC%segnum_v(G%isd:G%ied,G%JsdB:G%JedB), source=0) + call rotate_array_pair(OBC_in%segnum_u, OBC_in%segnum_v, turns, OBC%segnum_u, OBC%segnum_v) + call set_segnum_signs(OBC, G) ! These are conditionally enabled during segment configuration - OBC%open_u_BCs_exist_globally = OBC_in%open_v_BCs_exist_globally - OBC%open_v_BCs_exist_globally = OBC_in%open_u_BCs_exist_globally - OBC%Flather_u_BCs_exist_globally = OBC_in%Flather_v_BCs_exist_globally - OBC%Flather_v_BCs_exist_globally = OBC_in%Flather_u_BCs_exist_globally + if (modulo(turns,2) == 0) then + OBC%open_u_BCs_exist_globally = OBC_in%open_u_BCs_exist_globally + OBC%open_v_BCs_exist_globally = OBC_in%open_v_BCs_exist_globally + OBC%Flather_u_BCs_exist_globally = OBC_in%Flather_u_BCs_exist_globally + OBC%Flather_v_BCs_exist_globally = OBC_in%Flather_v_BCs_exist_globally + OBC%nudged_u_BCs_exist_globally = OBC_in%nudged_u_BCs_exist_globally + OBC%nudged_v_BCs_exist_globally = OBC_in%nudged_v_BCs_exist_globally + OBC%specified_u_BCs_exist_globally = OBC_in%specified_u_BCs_exist_globally + OBC%specified_v_BCs_exist_globally = OBC_in%specified_v_BCs_exist_globally + else ! Swap information for u- and v- OBCs + OBC%open_u_BCs_exist_globally = OBC_in%open_v_BCs_exist_globally + OBC%open_v_BCs_exist_globally = OBC_in%open_u_BCs_exist_globally + OBC%Flather_u_BCs_exist_globally = OBC_in%Flather_v_BCs_exist_globally + OBC%Flather_v_BCs_exist_globally = OBC_in%Flather_u_BCs_exist_globally + OBC%nudged_u_BCs_exist_globally = OBC_in%nudged_v_BCs_exist_globally + OBC%nudged_v_BCs_exist_globally = OBC_in%nudged_u_BCs_exist_globally + OBC%specified_u_BCs_exist_globally = OBC_in%specified_v_BCs_exist_globally + OBC%specified_v_BCs_exist_globally = OBC_in%specified_u_BCs_exist_globally + endif OBC%oblique_BCs_exist_globally = OBC_in%oblique_BCs_exist_globally - OBC%nudged_u_BCs_exist_globally = OBC_in%nudged_v_BCs_exist_globally - OBC%nudged_v_BCs_exist_globally = OBC_in%nudged_u_BCs_exist_globally - OBC%specified_u_BCs_exist_globally= OBC_in%specified_v_BCs_exist_globally - OBC%specified_v_BCs_exist_globally= OBC_in%specified_u_BCs_exist_globally OBC%radiation_BCs_exist_globally = OBC_in%radiation_BCs_exist_globally ! These are set by initialize_segment_data OBC%brushcutter_mode = OBC_in%brushcutter_mode OBC%update_OBC = OBC_in%update_OBC - OBC%needs_IO_for_data = OBC_in%needs_IO_for_data + OBC%any_needs_IO_for_data = OBC_in%any_needs_IO_for_data + OBC%update_OBC_seg_data = OBC_in%update_OBC_seg_data OBC%ntr = OBC_in%ntr + if (OBC%ntr > 0) then + allocate(OBC%tracer_x_reservoirs_used(OBC%ntr), source=.false.) + allocate(OBC%tracer_y_reservoirs_used(OBC%ntr), source=.false.) + if (modulo(turns,2) == 0) then + do n=1,OBC%ntr + OBC%tracer_x_reservoirs_used(n) = OBC_in%tracer_x_reservoirs_used(n) + OBC%tracer_y_reservoirs_used(n) = OBC_in%tracer_y_reservoirs_used(n) + enddo + else ! Swap information for u- and v- OBCs + do n=1,OBC%ntr + OBC%tracer_x_reservoirs_used(n) = OBC_in%tracer_y_reservoirs_used(n) + OBC%tracer_y_reservoirs_used(n) = OBC_in%tracer_x_reservoirs_used(n) + enddo + endif + endif OBC%gamma_uv = OBC_in%gamma_uv 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 + ! These are run-time parameters that are read in via open_boundary_config + OBC%debug = OBC_in%debug + OBC%ramp = OBC_in%ramp + OBC%ramping_is_activated = OBC_in%ramping_is_activated + OBC%ramp_timescale = OBC_in%ramp_timescale + OBC%trunc_ramp_time = OBC_in%trunc_ramp_time + OBC%ramp_value = OBC_in%ramp_value + OBC%ramp_start_time = OBC_in%ramp_start_time + OBC%remap_answer_date = OBC_in%remap_answer_date + OBC%check_reconstruction = OBC_in%check_reconstruction + OBC%check_remapping = OBC_in%check_remapping + OBC%force_bounds_in_subcell = OBC_in%force_bounds_in_subcell + OBC%om4_remap_via_sub_cells = OBC_in%om4_remap_via_sub_cells + OBC%remappingScheme = OBC_in%remappingScheme + OBC%exterior_OBC_bug = OBC_in%exterior_OBC_bug + OBC%hor_index_bug = OBC_in%hor_index_bug + OBC%n_tide_constituents = OBC_in%n_tide_constituents + OBC%add_tide_constituents = OBC_in%add_tide_constituents + + ! These are read in via initialize_obc_tides when n_tide_constituents > 0 + if (OBC%add_tide_constituents .and. (OBC%n_tide_constituents>0)) then + OBC%add_eq_phase = OBC_in%add_eq_phase + OBC%add_nodal_terms = OBC_in%add_nodal_terms + OBC%time_ref = OBC_in%time_ref + + allocate(OBC%tide_names(OBC%n_tide_constituents)) + allocate(OBC%tide_frequencies(OBC%n_tide_constituents)) + allocate(OBC%tide_eq_phases(OBC%n_tide_constituents)) + allocate(OBC%tide_fn(OBC%n_tide_constituents)) + allocate(OBC%tide_un(OBC%n_tide_constituents)) + do c=1,OBC%n_tide_constituents + OBC%tide_names(c) = OBC_in%tide_names(c) + OBC%tide_frequencies(c) = OBC_in%tide_frequencies(c) + OBC%tide_eq_phases(c) = OBC_in%tide_eq_phases(c) + OBC%tide_fn(c) = OBC_in%tide_fn(c) + OBC%tide_un(c) = OBC_in%tide_un(c) + enddo + + if (OBC%add_eq_phase .or. OBC%add_nodal_terms) & + OBC%tidal_longitudes = OBC_in%tidal_longitudes endif - ! TODO: The OBC registry seems to be a list of "registered" OBC types. - ! It does not appear to be used, so for now we skip this record. - !OBC%OBC_Reg => OBC_in%OBC_Reg end subroutine rotate_OBC_config !> Rotate the OBC segment configuration data from the input to model index map. @@ -5281,8 +6698,9 @@ subroutine rotate_OBC_segment_config(segment_in, G_in, segment, G, turns) integer, intent(in) :: turns !< Number of quarter turns ! Global segment indices - integer :: Is_obc_in, Ie_obc_in, Js_obc_in, Je_obc_in ! Input domain - integer :: Is_obc, Ie_obc, Js_obc, Je_obc ! Rotated domain + integer :: Is_obc_in, Ie_obc_in, Js_obc_in, Je_obc_in ! Input domain global indices + integer :: Is_obc, Ie_obc, Js_obc, Je_obc ! Rotated domain global indices + integer :: qturns ! The number of quarter turns in the range of 0 to 3 ! NOTE: A "rotation" of the OBC segment string would allow us to use ! setup_[uv]_point_obc to set up most of this. For now, we just copy/swap @@ -5291,6 +6709,8 @@ subroutine rotate_OBC_segment_config(segment_in, G_in, segment, G, turns) ! This is set if the segment is in the local grid segment%on_pe = segment_in%on_pe + qturns = modulo(turns, 4) + ! Transfer configuration flags segment%Flather = segment_in%Flather segment%radiation = segment_in%radiation @@ -5308,19 +6728,9 @@ subroutine rotate_OBC_segment_config(segment_in, G_in, segment, G, turns) segment%open = segment_in%open segment%gradient = segment_in%gradient - ! NOTE: [uv]_values_needed are swapped - segment%u_values_needed = segment_in%v_values_needed - segment%v_values_needed = segment_in%u_values_needed - segment%z_values_needed = segment_in%z_values_needed - segment%g_values_needed = segment_in%g_values_needed - segment%t_values_needed = segment_in%t_values_needed - segment%s_values_needed = segment_in%s_values_needed - - segment%values_needed = segment_in%values_needed - ! These are conditionally set if nudged segment%Velocity_nudging_timescale_in = segment_in%Velocity_nudging_timescale_in - segment%Velocity_nudging_timescale_out= segment_in%Velocity_nudging_timescale_out + segment%Velocity_nudging_timescale_out = segment_in%Velocity_nudging_timescale_out ! Rotate segment indices @@ -5328,7 +6738,7 @@ subroutine rotate_OBC_segment_config(segment_in, G_in, segment, G, turns) ! NOTE: The values stored in the segment are always saved in ascending order, ! e.g. (is < ie). In order to use setup_segment_indices, we reorder the ! indices here to indicate face direction. - ! Segment indices are also indexed locally, so we remove the halo offset. + ! Segment indices are also indexed locally, so here we convert to global indices if (segment_in%direction == OBC_DIRECTION_N) then Is_obc_in = segment_in%Ie_obc + G_in%idg_offset Ie_obc_in = segment_in%Is_obc + G_in%idg_offset @@ -5345,18 +6755,26 @@ subroutine rotate_OBC_segment_config(segment_in, G_in, segment, G, turns) Je_obc_in = segment_in%Je_obc + G_in%jdg_offset endif - ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. - Is_obc = G_in%jegB - Js_obc_in - Ie_obc = G_in%JegB - Je_obc_in - Js_obc = Is_obc_in - Je_obc = Ie_obc_in - - ! Orientation is based on the index ordering, [IJ][se]_obc are re-ordered - ! after the index is set. So we now need to restore the original order + ! Rotate the global indices of the segment according to the number of turns. + if (qturns == 0) then + Is_obc = Is_obc_in ; Ie_obc = Ie_obc_in + Js_obc = Js_obc_in ; Je_obc = Je_obc_in + elseif (qturns == 1) then + Is_obc = G_in%JegB - Js_obc_in ; Ie_obc = G_in%JegB - Je_obc_in + Js_obc = Is_obc_in ; Je_obc = Ie_obc_in + elseif (qturns == 2) then + Is_obc = G_in%IegB - Is_obc_in ; Ie_obc = G_in%IegB - Ie_obc_in + Js_obc = G_in%JegB - Js_obc_in ; Je_obc = G_in%JegB - Je_obc_in + elseif (qturns == 3) then + Is_obc = Js_obc_in ; Ie_obc = Je_obc_in + Js_obc = G_in%IegB - Is_obc_in ; Je_obc = G_in%IegB - Ie_obc_in + endif + ! Orientation is based on the index ordering, and setup_segment_indices + ! is based on the original order in the intput files. call setup_segment_indices(G, segment, Is_obc, Ie_obc, Js_obc, Je_obc) - ! Re-order [IJ][se]_obc back to ascending, and remove the halo offset. + ! Re-order [IJ][se]_obc back to ascending, and remove the global indexing offset. if (Is_obc > Ie_obc) then segment%Is_obc = Ie_obc - G%idg_offset segment%Ie_obc = Is_obc - G%idg_offset @@ -5374,135 +6792,474 @@ subroutine rotate_OBC_segment_config(segment_in, G_in, segment, G, turns) endif ! Reconfigure the directional flags - ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. - select case (segment_in%direction) - case (OBC_DIRECTION_N) - segment%direction = OBC_DIRECTION_W - segment%is_E_or_W_2 = segment_in%is_N_or_S - segment%is_E_or_W = segment_in%is_N_or_S .and. segment_in%on_pe - segment%is_N_or_S = .false. - case (OBC_DIRECTION_W) - segment%direction = OBC_DIRECTION_S - segment%is_N_or_S = segment_in%is_E_or_W - segment%is_E_or_W = .false. - segment%is_E_or_W_2 = .false. - case (OBC_DIRECTION_S) - segment%direction = OBC_DIRECTION_E - segment%is_E_or_W_2 = segment_in%is_N_or_S - segment%is_E_or_W = segment_in%is_N_or_S .and. segment_in%on_pe - segment%is_N_or_S = .false. - case (OBC_DIRECTION_E) - segment%direction = OBC_DIRECTION_N - segment%is_N_or_S = segment_in%is_E_or_W - segment%is_E_or_W = .false. - segment%is_E_or_W_2 = .false. - case (OBC_NONE) - segment%direction = OBC_NONE - end select + segment%direction = rotate_OBC_segment_direction(segment_in%direction, turns) + + segment%is_E_or_W_2 = ((segment%direction == OBC_DIRECTION_E) .or. & + (segment%direction == OBC_DIRECTION_W)) + segment%is_E_or_W = segment_in%on_PE .and. segment%is_E_or_W_2 + segment%is_N_or_S = segment_in%on_PE .and. & + ((segment%direction == OBC_DIRECTION_N) .or. & + (segment%direction == OBC_DIRECTION_S)) ! These are conditionally set if Lscale_{in,out} are present segment%Tr_InvLscale_in = segment_in%Tr_InvLscale_in segment%Tr_InvLscale_out = segment_in%Tr_InvLscale_out + segment%Th_InvLscale_in = segment_in%Th_InvLscale_in + segment%Th_InvLscale_out = segment_in%Th_InvLscale_out + + ! This needs to be set + segment%num_fields = segment_in%num_fields end subroutine rotate_OBC_segment_config -!> Initialize the segments and field-related data of a rotated OBC. -subroutine rotate_OBC_init(OBC_in, G, GV, US, param_file, tv, restart_CS, OBC) - type(ocean_OBC_type), intent(in) :: OBC_in !< OBC on input map - type(ocean_grid_type), intent(in) :: G !< Rotated grid metric - type(verticalGrid_type), intent(in) :: GV !< Vertical grid - type(unit_scale_type), intent(in) :: US !< Unit scaling - type(param_file_type), intent(in) :: param_file !< Input parameters - type(thermo_var_ptrs), intent(inout) :: tv !< Tracer fields - type(MOM_restart_CS), intent(in) :: restart_CS !< Restart CS - type(ocean_OBC_type), pointer, intent(inout) :: OBC !< Rotated OBC +!> Return the direction of an OBC segment on after rotation to the new grid. Note that +!! rotate_OBC_seg_direction(rotate_OBC_seg_direction(direction, turns), -turns) = direction. +function rotate_OBC_segment_direction(direction, turns) result(rotated_dir) + integer, intent(in) :: direction !< The orientation of an OBC segment on the original grid + integer, intent(in) :: turns !< Number of quarter turns + integer :: rotated_dir !< An integer encoding the new rotated segment direction + + integer :: qturns ! The number of quarter turns in the range of 0 to 3 + + qturns = modulo(turns, 4) + + if ((qturns == 0) .or. (direction == OBC_NONE)) then + rotated_dir = direction + else ! Determine the segment direction on a rotated grid + select case (direction) + case (OBC_DIRECTION_N) + if (qturns == 0) rotated_dir = OBC_DIRECTION_N + if (qturns == 1) rotated_dir = OBC_DIRECTION_W + if (qturns == 2) rotated_dir = OBC_DIRECTION_S + if (qturns == 3) rotated_dir = OBC_DIRECTION_E + case (OBC_DIRECTION_W) + if (qturns == 0) rotated_dir = OBC_DIRECTION_W + if (qturns == 1) rotated_dir = OBC_DIRECTION_S + if (qturns == 2) rotated_dir = OBC_DIRECTION_E + if (qturns == 3) rotated_dir = OBC_DIRECTION_N + case (OBC_DIRECTION_S) + if (qturns == 0) rotated_dir = OBC_DIRECTION_S + if (qturns == 1) rotated_dir = OBC_DIRECTION_E + if (qturns == 2) rotated_dir = OBC_DIRECTION_N + if (qturns == 3) rotated_dir = OBC_DIRECTION_W + case (OBC_DIRECTION_E) + if (qturns == 0) rotated_dir = OBC_DIRECTION_E + if (qturns == 1) rotated_dir = OBC_DIRECTION_N + if (qturns == 2) rotated_dir = OBC_DIRECTION_W + if (qturns == 3) rotated_dir = OBC_DIRECTION_S + case (OBC_NONE) + rotated_dir = OBC_NONE + case default ! This should never happen. + rotated_dir = direction + end select + endif - logical :: use_temperature - integer :: l +end function rotate_OBC_segment_direction + +!> Return the that the field would have after being rotated by the given number of quarter turns +function rotated_field_name(input_name, turns) + character(len=*), intent(in) :: input_name !< The unrotated field name + integer, intent(in) :: turns !< Number of quarter turns of the grid + character(len=len(input_name)) :: rotated_field_name !< The rotated field name + + if (modulo(turns, 2) /= 0) then + select case (input_name) + case ('U') ; rotated_field_name = 'V' + case ('Uamp') ; rotated_field_name = 'Vamp' + case ('Uphase') ; rotated_field_name = 'Vphase' + case ('V') ; rotated_field_name = 'U' + case ('Vamp') ; rotated_field_name = 'Uamp' + case ('Vphase') ; rotated_field_name = 'Uphase' + case ('DVDX') ; rotated_field_name = 'DUDY' + case ('DUDY') ; rotated_field_name = 'DVDX' + case default ; rotated_field_name = input_name + end select + else + rotated_field_name = input_name + endif - call get_param(param_file, "MOM", "ENABLE_THERMODYNAMICS", use_temperature, & - "If true, Temperature and salinity are used as state "//& - "variables.", default=.true., do_not_log=.true.) +end function rotated_field_name - do l = 1, OBC%number_of_segments - call rotate_OBC_segment_data(OBC_in%segment(l), OBC%segment(l), G%HI%turns) - enddo +!> Allocate an array of data for a field on a segment based on the size of a potentially rotated source array +subroutine allocate_rotated_seg_data(src_array, HI_in, tgt_array, segment) + real, dimension(:,:,:), intent(in) :: src_array !< The segment data on the unrotated source grid + type(hor_index_type), intent(in) :: HI_in !< Horizontal indices on the source grid + real, dimension(:,:,:), allocatable, intent(inout) :: tgt_array !< The segment data that is being allocated + type(OBC_segment_type), intent(inout) :: segment !< OBC segment on the target grid - if (use_temperature) & - call fill_temp_salt_segments(G, GV, OBC, tv) + ! Local variables + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nk + logical :: corner ! True if this field is discretized at the OBC segment nodes rather than the faces. - call open_boundary_init(G, GV, US, param_file, OBC, restart_CS) -end subroutine rotate_OBC_init + isd = segment%HI%isd ; ied = segment%HI%ied ; IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + jsd = segment%HI%jsd ; jed = segment%HI%jed ; JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + nk = size(src_array, 3) + ! Determine whether the source array is allocated at a segment face or at the corners. + corner = (size(src_array, 1) == abs(HI_in%IedB - HI_in%IsdB) + 1 ) .and. & + (size(src_array, 2) == abs(HI_in%JedB - HI_in%JsdB) + 1 ) -!> Rotate an OBC segment's fields from the input to the model index map. -subroutine rotate_OBC_segment_data(segment_in, segment, turns) - type(OBC_segment_type), intent(in) :: segment_in - type(OBC_segment_type), intent(inout) :: segment - integer, intent(in) :: turns + if (corner) then + allocate(tgt_array(IsdB:IedB,JsdB:JedB,nk), source=0.0) + elseif (segment%is_E_or_W) then + allocate(tgt_array(IsdB:IedB,jsd:jed,nk), source=0.0) + elseif (segment%is_N_or_S) then + allocate(tgt_array(isd:ied,JsdB:JedB,nk), source=0.0) + endif +end subroutine allocate_rotated_seg_data - integer :: n - integer :: is, ie, js, je, nk - integer :: num_fields +!> Write out information about the contents of the OBC control structure +subroutine write_OBC_info(OBC, G, GV, US) + type(ocean_OBC_type), pointer :: OBC !< An open boundary condition control structure + type(ocean_grid_type), intent(in) :: G !< Rotated grid metric + type(verticalGrid_type), intent(in) :: GV !< Vertical grid + type(unit_scale_type), intent(in) :: US !< Unit scaling - num_fields = segment_in%num_fields - allocate(segment%field(num_fields)) + ! Local variables + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + integer :: turns ! Number of index quarter turns + integer :: n ! The segment number reported in output + integer :: n_seg ! The internal segment number + integer :: dir ! This indicates the internal logical orientation of a segment + integer :: unrot_dir ! This indicates the logical orientation a segment would have had + ! without grid rotation + integer :: c ! Used to loop over tidal constituents + character(len=1024) :: mesg + + turns = modulo(G%HI%turns, 4) + + write(mesg, '("OBC has ", I0, " segments.")') OBC%number_of_segments + call MOM_mesg(mesg, verb=1) + ! call MOM_error(WARNING, mesg) + + if (modulo(turns, 2) == 0) then + if (OBC%open_u_BCs_exist_globally) call MOM_mesg("open_u_BCs_exist_globally", verb=1) + if (OBC%open_v_BCs_exist_globally) call MOM_mesg("open_v_BCs_exist_globally", verb=1) + if (OBC%Flather_u_BCs_exist_globally) call MOM_mesg("Flather_u_BCs_exist_globally", verb=1) + if (OBC%Flather_v_BCs_exist_globally) call MOM_mesg("Flather_v_BCs_exist_globally", verb=1) + if (OBC%nudged_u_BCs_exist_globally) call MOM_mesg("nudged_u_BCs_exist_globally", verb=1) + if (OBC%nudged_v_BCs_exist_globally) call MOM_mesg("nudged_v_BCs_exist_globally", verb=1) + if (OBC%specified_u_BCs_exist_globally) call MOM_mesg("specified_u_BCs_exist_globally", verb=1) + if (OBC%specified_v_BCs_exist_globally) call MOM_mesg("specified_v_BCs_exist_globally", verb=1) + else ! The u- and v-directions are swapped. + if (OBC%open_v_BCs_exist_globally) call MOM_mesg("open_u_BCs_exist_globally", verb=1) + if (OBC%open_u_BCs_exist_globally) call MOM_mesg("open_v_BCs_exist_globally", verb=1) + if (OBC%Flather_v_BCs_exist_globally) call MOM_mesg("Flather_u_BCs_exist_globally", verb=1) + if (OBC%Flather_u_BCs_exist_globally) call MOM_mesg("Flather_v_BCs_exist_globally", verb=1) + if (OBC%nudged_v_BCs_exist_globally) call MOM_mesg("nudged_u_BCs_exist_globally", verb=1) + if (OBC%nudged_u_BCs_exist_globally) call MOM_mesg("nudged_v_BCs_exist_globally", verb=1) + if (OBC%specified_v_BCs_exist_globally) call MOM_mesg("specified_u_BCs_exist_globally", verb=1) + if (OBC%specified_u_BCs_exist_globally) call MOM_mesg("specified_v_BCs_exist_globally", verb=1) + endif - segment%num_fields = segment_in%num_fields - do n = 1, num_fields - segment%field(n)%fid = segment_in%field(n)%fid - segment%field(n)%fid_dz = segment_in%field(n)%fid_dz - - if (modulo(turns, 2) /= 0) then - select case (segment_in%field(n)%name) - case ('U') - segment%field(n)%name = 'V' - case ('Uamp') - segment%field(n)%name = 'Vamp' - case ('Uphase') - segment%field(n)%name = 'Vphase' - case ('V') - segment%field(n)%name = 'U' - case ('Vamp') - segment%field(n)%name = 'Uamp' - case ('Vphase') - segment%field(n)%name = 'Uphase' - case ('DVDX') - segment%field(n)%name = 'DUDY' - case ('DUDY') - segment%field(n)%name = 'DVDX' - case default - segment%field(n)%name = segment_in%field(n)%name - end select + if (OBC%oblique_BCs_exist_globally) call MOM_mesg("oblique_BCs_exist_globally", verb=1) + if (OBC%radiation_BCs_exist_globally) call MOM_mesg("radiation_BCs_exist_globally", verb=1) + if (OBC%user_BCs_set_globally) call MOM_mesg("user_BCs_set_globally", verb=1) + if (OBC%update_OBC) call MOM_mesg("update_OBC", verb=1) + if (OBC%update_OBC_seg_data) call MOM_mesg("update_OBC_seg_data", verb=1) + if (OBC%any_needs_IO_for_data) call MOM_mesg("any_needs_IO_for_data", verb=1) + if (OBC%zero_biharmonic) call MOM_mesg("zero_biharmonic", verb=1) + if (OBC%brushcutter_mode) call MOM_mesg("brushcutter_mode", verb=1) + if (OBC%check_reconstruction) call MOM_mesg("check_reconstruction", verb=1) + if (OBC%check_remapping) call MOM_mesg("check_remapping", verb=1) + if (OBC%force_bounds_in_subcell) call MOM_mesg("force_bounds_in_subcell", verb=1) + if (OBC%om4_remap_via_sub_cells) call MOM_mesg("om4_remap_via_sub_cells", verb=1) + if (OBC%exterior_OBC_bug) call MOM_mesg("exterior_OBC_bug", verb=1) + if (OBC%hor_index_bug) call MOM_mesg("hor_index_bug", verb=1) + if (OBC%debug) call MOM_mesg("debug", verb=1) + if (OBC%ramp) call MOM_mesg("ramp", verb=1) + if (OBC%ramping_is_activated) call MOM_mesg("ramping_is_activated", verb=1) + write(mesg, '("n_tide_constituents ", I0)') OBC%n_tide_constituents + call MOM_mesg(mesg, verb=1) + if (OBC%n_tide_constituents > 0) then + do c=1,OBC%n_tide_constituents + write(mesg, '(" properties ", 4ES16.6)') & + US%s_to_T*OBC%tide_frequencies(c), OBC%tide_eq_phases(c), OBC%tide_fn(c), OBC%tide_un(c) + call MOM_mesg(trim(OBC%tide_names(c))//mesg, verb=1) + enddo + endif + if (OBC%ramp) then + write(mesg, '("ramp_values ", 3ES16.6)') OBC%ramp_timescale, OBC%trunc_ramp_time, OBC%ramp_value + call MOM_mesg(mesg, verb=1) + endif + write(mesg, '("gamma_uv ", ES16.6)') OBC%gamma_uv + call MOM_mesg(mesg, verb=1) + write(mesg, '("rx_max ", ES16.6)') OBC%rx_max + call MOM_mesg(mesg, verb=1) + + call MOM_mesg("remappingScheme = "//trim(OBC%remappingScheme), verb=1) + + do n=1,OBC%number_of_segments + n_seg = n ; if (OBC%reverse_segment_order) n_seg = OBC%number_of_segments + 1 - n + segment => OBC%segment(n_seg) + dir = segment%direction + + unrot_dir = rotate_OBC_segment_direction(dir, -turns) + write(mesg, '(" Segment ", I0, " has direction ", I0)') n, unrot_dir + if (unrot_dir == OBC_DIRECTION_N) write(mesg, '(" Segment ", I0, " is Northern")') n + if (unrot_dir == OBC_DIRECTION_S) write(mesg, '(" Segment ", I0, " is Southern")') n + if (unrot_dir == OBC_DIRECTION_E) write(mesg, '(" Segment ", I0, " is Eastern")') n + if (unrot_dir == OBC_DIRECTION_W) write(mesg, '(" Segment ", I0, " is Western")') n + call MOM_mesg(mesg, verb=1) + + ! write(mesg, '(" range:", 4(1x,I0))') segment%Is_obc, segment%Ie_obc, segment%Js_obc, segment%Je_obc + if (modulo(turns, 2) == 0) then + write(mesg, '(" size: ", I0," ",I0)') 1+abs(segment%Ie_obc-segment%Is_obc), 1+abs(segment%Je_obc-segment%Js_obc) else - segment%field(n)%name = segment_in%field(n)%name + write(mesg, '(" size: ", I0," ",I0)') 1+abs(segment%Je_obc-segment%Js_obc), 1+abs(segment%Ie_obc-segment%Is_obc) + endif + call MOM_mesg(mesg, verb=1) + + if (segment%on_pe) call MOM_mesg(" Segment is on PE.", verb=1) + + if (segment%Flather) call MOM_mesg(" Flather", verb=1) + if (segment%radiation) call MOM_mesg(" radiation", verb=1) + if (segment%radiation_tan) call MOM_mesg(" radiation_tan", verb=1) + if (segment%radiation_grad) call MOM_mesg(" radiation_grad", verb=1) + if (segment%oblique) call MOM_mesg(" oblique", verb=1) + if (segment%oblique_tan) call MOM_mesg(" oblique_tan", verb=1) + if (segment%oblique_grad) call MOM_mesg(" oblique_grad", verb=1) + if (segment%nudged) call MOM_mesg(" nudged", verb=1) + if (segment%nudged_tan) call MOM_mesg(" nudged_tan", verb=1) + if (segment%nudged_grad) call MOM_mesg(" nudged_grad", verb=1) + if (segment%specified) call MOM_mesg(" specified", verb=1) + if (segment%specified_tan) call MOM_mesg(" specified_tan", verb=1) + if (segment%specified_grad) call MOM_mesg(" specified_grad", verb=1) + if (segment%open) call MOM_mesg(" open", verb=1) + if (segment%gradient) call MOM_mesg(" gradient", verb=1) + if (modulo(turns, 2) == 0) then + if (segment%is_N_or_S) call MOM_mesg(" is_N_or_S", verb=1) + if (segment%is_E_or_W) call MOM_mesg(" is_E_or_W", verb=1) + else ! The x- and y-directions are swapped. + if (segment%is_E_or_W) call MOM_mesg(" is_N_or_S", verb=1) + if (segment%is_N_or_S) call MOM_mesg(" is_E_or_W", verb=1) + endif +! if (segment%is_E_or_W_2) call MOM_mesg(" is_E_or_W_2", verb=1) + if (segment%temp_segment_data_exists) call MOM_mesg(" temp_segment_data_exists", verb=1) + if (segment%salt_segment_data_exists) call MOM_mesg(" salt_segment_data_exists", verb=1) + + write(mesg, '(" Tr_InvLscale_out ", ES16.6)') segment%Tr_InvLscale_out*US%m_to_L + call MOM_mesg(mesg, verb=1) + write(mesg, '(" Tr_InvLscale_in ", ES16.6)') segment%Tr_InvLscale_in*US%m_to_L + call MOM_mesg(mesg, verb=1) + write(mesg, '(" Th_InvLscale_out ", ES16.6)') segment%Th_InvLscale_out*US%m_to_L + call MOM_mesg(mesg, verb=1) + write(mesg, '(" Th_InvLscale_in ", ES16.6)') segment%Th_InvLscale_in*US%m_to_L + call MOM_mesg(mesg, verb=1) + + enddo + + call chksum_OBC_segments(OBC, G, GV, US, 0) + +end subroutine write_OBC_info + +!> Write checksums and perhaps some or all of the values of all the allocated arrays on the OBC segments. +subroutine chksum_OBC_segments(OBC, G, GV, US, nk) + type(ocean_OBC_type), intent(in) :: OBC !< An open boundary condition control structure + type(ocean_grid_type), intent(in) :: G !< Rotated grid metric + type(verticalGrid_type), intent(in) :: GV !< Vertical grid + type(unit_scale_type), intent(in) :: US !< Unit scaling + integer, intent(in) :: nk !< The number of layers to print + + ! Local variables + integer :: n ! The segment number reported in output + integer :: n_seg ! The internal segment number + + do n=1,OBC%number_of_segments + n_seg = n ; if (OBC%reverse_segment_order) n_seg = OBC%number_of_segments + 1 - n + + call chksum_OBC_segment_data(OBC%segment(n_seg), GV, US, nk, n) + enddo + +end subroutine chksum_OBC_segments + + +!> Write checksums and perhaps some or all of the values of all the allocated arrays on a single OBC segment. +subroutine chksum_OBC_segment_data(segment, GV, US, nk, nseg_out) + type(OBC_segment_type), intent(in) :: segment !< Segment type to checksum + type(verticalGrid_type), intent(in) :: GV !< Vertical grid + type(unit_scale_type), intent(in) :: US !< Unit scaling + integer, intent(in) :: nk !< The number of layers to print + integer, intent(in) :: nseg_out !< The segment number reported in output + + ! Local variables + real :: norm ! A sign change used when rotating a normal component [nondim] + real :: tang ! A sign change used when rotating a tangential component [nondim] + character(len=8) :: sn, segno + integer :: dir ! This indicates the internal logical orientation of a segment + + dir = segment%direction + + write(segno, '(I0)') nseg_out + sn = '('//trim(segno)//')' + + ! Turn each segment and write it as though it is an eastern face. + norm = 0.0 ; tang = 0.0 + if (dir == OBC_DIRECTION_E) then + norm = 1.0 ; tang = 1.0 + elseif (dir == OBC_DIRECTION_N) then + norm = 1.0 ; tang = -1.0 + elseif (dir == OBC_DIRECTION_W) then + norm = -1.0 ; tang = -1.0 + elseif (dir == OBC_DIRECTION_S) then + norm = -1.0 ; tang = 1.0 + endif + + if (allocated(segment%Htot)) call write_2d_array_vals("Htot"//trim(sn), segment%Htot, dir, nk, unscale=GV%H_to_mks) + if (allocated(segment%dZtot)) call write_2d_array_vals("dZtot"//trim(sn), segment%dZtot, dir, nk, unscale=US%Z_to_m) + if (allocated(segment%SSH)) call write_2d_array_vals("SSH"//trim(sn), segment%SSH, dir, nk, unscale=US%Z_to_m) + if (allocated(segment%normal_vel)) & + call write_3d_array_vals("normal_vel"//trim(sn), segment%normal_vel, dir, nk, unscale=norm*US%L_T_to_m_s) + if (allocated(segment%normal_vel_bt)) & + call write_2d_array_vals("normal_vel_bt"//trim(sn), segment%normal_vel_bt, dir, nk, unscale=norm*US%L_T_to_m_s) + if (allocated(segment%tangential_vel)) & + call write_3d_array_vals("tangential_vel"//trim(sn), segment%tangential_vel, dir, nk, unscale=tang*US%L_T_to_m_s) + if (allocated(segment%tangential_grad)) & + call write_3d_array_vals("tangential_grad"//trim(sn), segment%tangential_grad, dir, nk, & + unscale=tang*norm*US%s_to_T) + if (allocated(segment%normal_trans)) & + call write_3d_array_vals("normal_trans"//trim(sn), segment%normal_trans, dir, nk, & + unscale=norm*GV%H_to_mks*US%L_T_to_m_s*US%L_to_m) + if (allocated(segment%grad_normal)) & + call write_3d_array_vals("grad_normal"//trim(sn), segment%grad_normal, dir, nk, unscale=norm*tang*US%L_T_to_m_s) + if (allocated(segment%grad_tan)) & + call write_3d_array_vals("grad_tan"//trim(sn), segment%grad_tan, dir, nk, unscale=1.0*US%L_T_to_m_s) + if (allocated(segment%grad_gradient)) & + call write_3d_array_vals("grad_gradient"//trim(sn), segment%grad_gradient, dir, nk, unscale=norm*US%s_to_T) + + if (allocated(segment%rx_norm_rad)) & + call write_3d_array_vals("rxy_norm_rad"//trim(sn), segment%rx_norm_rad, dir, nk, unscale=1.0) + if (allocated(segment%ry_norm_rad)) & + call write_3d_array_vals("rxy_norm_rad"//trim(sn), segment%ry_norm_rad, dir, nk, unscale=1.0) + if (segment%is_E_or_W) then + if (allocated(segment%rx_norm_obl)) & + call write_3d_array_vals("rx_norm_obl"//trim(sn), segment%rx_norm_obl, dir, nk, unscale=US%L_T_to_m_s**2) + if (allocated(segment%ry_norm_obl)) & + call write_3d_array_vals("ry_norm_obl"//trim(sn), segment%ry_norm_obl, dir, nk, unscale=US%L_T_to_m_s**2) + else ! The x- and y- directions are swapped. + if (allocated(segment%ry_norm_obl)) & + call write_3d_array_vals("rx_norm_obl"//trim(sn), segment%ry_norm_obl, dir, nk, unscale=US%L_T_to_m_s**2) + if (allocated(segment%rx_norm_obl)) & + call write_3d_array_vals("ry_norm_obl"//trim(sn), segment%rx_norm_obl, dir, nk, unscale=US%L_T_to_m_s**2) endif - if (allocated(segment_in%field(n)%buffer_src)) then - call allocate_rotated_array(segment_in%field(n)%buffer_src, & - lbound(segment_in%field(n)%buffer_src), turns, & - segment%field(n)%buffer_src) - call rotate_array(segment_in%field(n)%buffer_src, turns, & - segment%field(n)%buffer_src) + if (allocated(segment%cff_normal)) & + call write_3d_array_vals("cff_normal"//trim(sn), segment%cff_normal, dir, nk, unscale=US%L_T_to_m_s**2) + if (allocated(segment%nudged_normal_vel)) & + call write_3d_array_vals("nudged_normal_vel"//trim(sn), segment%nudged_normal_vel, dir, nk, & + unscale=norm*US%L_T_to_m_s) + if (allocated(segment%nudged_tangential_vel)) & + call write_3d_array_vals("nudged_tangential_vel"//trim(sn), segment%nudged_tangential_vel, dir, nk, & + unscale=tang*US%L_T_to_m_s) + if (allocated(segment%nudged_tangential_grad)) & + call write_3d_array_vals("nudged_tangential_grad"//trim(sn), segment%nudged_tangential_grad, dir, nk, & + unscale=tang*norm*US%s_to_T) + + contains + + !> Write out the values in a named 2-d segment data array + subroutine write_2d_array_vals(name, Array, seg_dir, nkp, unscale) + character(len=*), intent(in) :: name !< The name of the variable + real, dimension(:,:), intent(in) :: Array !< The 2-d array to write [A ~> a] + integer, intent(in) :: seg_dir !< The direction of the segment + integer, intent(in) :: nkp !< Print all the values if this is greater than 0 + real, optional, intent(in) :: unscale !< A factor that undoes the scaling of the array [a A-1 ~> 1] + ! Local variables + real :: scale ! A factor that undoes the scaling of the array [a A-1 ~> 1] + character(len=1024) :: mesg + character(len=24) :: val + integer :: i, j, n, iounit + + scale = 1.0 ; if (present(unscale)) scale = unscale + iounit = stderr + + if (nkp > 0) then + write(iounit, '(2X,A,":")') trim(name) + mesg = "" ; n = 0 + if ((seg_dir == OBC_DIRECTION_N) .or. (seg_dir == OBC_DIRECTION_W)) then + do j=size(Array,2),1,-1 ; do i=size(Array,1),1,-1 + write(val, '(ES16.6)') scale*Array(i,j) + mesg = trim(mesg)//" "//trim(val) ; n = n + 1 + if (n >= 12) then + write(iounit, '(2X,A)') trim(mesg) + mesg = "" ; n = 0 + endif + enddo ; enddo + else + do j=1,size(Array,2) ; do i=1,size(Array,1) + write(val, '(ES16.6)') scale*Array(i,j) + mesg = trim(mesg)//" "//trim(val) ; n = n + 1 + if (n >= 12) then + write(iounit, '(2X,A)') trim(mesg) + mesg = "" ; n = 0 + endif + enddo ; enddo + endif + if (n > 0) write(iounit, '(2X,A)') trim(mesg) endif - segment%field(n)%nk_src = segment_in%field(n)%nk_src + if (scale == 1.0) then + call chksum(Array, name) + else + call chksum(scale*Array(:,:), name) + endif + end subroutine write_2d_array_vals + + !> Write out the values in a 3-d segment data array + subroutine write_3d_array_vals(name, Array, seg_dir, nkp, unscale) + character(len=*), intent(in) :: name !< The name of the variable + real, dimension(:,:,:), intent(in) :: Array !< The 3-d array to write + integer, intent(in) :: seg_dir !< The direction of the segment + integer, intent(in) :: nkp !< The number of layers to print + real, optional, intent(in) :: unscale !< A factor that undoes the scaling of the array [a A-1 ~> 1] + ! Local variables + real :: scale ! A factor that undoes the scaling of the array [a A-1 ~> 1] + logical :: reverse + character(len=1024) :: mesg + character(len=24) :: val + integer :: i, j, k, n, nk, iounit + + scale = 1.0 ; if (present(unscale)) scale = unscale + iounit = stderr + + if (nkp > 0) then + nk = min(nkp, size(Array,3)) + write(iounit, '(2X,A,":")') trim(name) + do k=1,nk + mesg = "" ; n = 0 + if ((seg_dir == OBC_DIRECTION_N) .or. (seg_dir == OBC_DIRECTION_W)) then + do j=size(Array,2),1,-1 ; do i=size(Array,1),1,-1 + write(val, '(ES16.6)') scale*Array(i,j,k) + mesg = trim(mesg)//" "//trim(val) ; n = n + 1 + if (n >= 12) then + write(iounit, '(2X,A)') trim(mesg) + mesg = "" ; n = 0 + endif + enddo ; enddo + else + do j=1,size(Array,2) ; do i=1,size(Array,1) + write(val, '(ES16.6)') scale*Array(i,j,k) + mesg = trim(mesg)//" "//trim(val) ; n = n + 1 + if (n >= 12) then + write(iounit, '(2X,A)') trim(mesg) + mesg = "" ; n = 0 + endif + enddo ; enddo + endif + if (n > 0) write(iounit, '(2X,A)') trim(mesg) + enddo + endif - if (allocated(segment_in%field(n)%dz_src)) then - call allocate_rotated_array(segment_in%field(n)%dz_src, & - lbound(segment_in%field(n)%dz_src), turns, & - segment%field(n)%dz_src) - call rotate_array(segment_in%field(n)%dz_src, turns, & - segment%field(n)%dz_src) + if (scale == 1.0) then + call chksum(Array, name) + else + call chksum(scale*Array(:,:,:), name) endif - segment%field(n)%value = segment_in%field(n)%value - enddo + end subroutine write_3d_array_vals - segment%temp_segment_data_exists = segment_in%temp_segment_data_exists - segment%salt_segment_data_exists = segment_in%salt_segment_data_exists -end subroutine rotate_OBC_segment_data +end subroutine chksum_OBC_segment_data !> \namespace mom_open_boundary !! This module implements some aspects of internal open boundary diff --git a/src/core/MOM_porous_barriers.F90 b/src/core/MOM_porous_barriers.F90 index d23509d5f6..e82bfbd621 100644 --- a/src/core/MOM_porous_barriers.F90 +++ b/src/core/MOM_porous_barriers.F90 @@ -1,168 +1,505 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Module for calculating curve fit for porous topography. !written by sjd module MOM_porous_barriers -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_error_handler, only : MOM_error, FATAL -use MOM_grid, only : ocean_grid_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs, porous_barrier_ptrs -use MOM_verticalGrid, only : verticalGrid_type +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_MODULE +use MOM_error_handler, only : MOM_error, FATAL +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs, porous_barrier_type +use MOM_verticalGrid, only : verticalGrid_type use MOM_interface_heights, only : find_eta +use MOM_time_manager, only : time_type +use MOM_diag_mediator, only : register_diag_field, diag_ctrl, post_data +use MOM_file_parser, only : param_file_type, get_param, log_version +use MOM_unit_scaling, only : unit_scale_type +use MOM_debugging, only : hchksum, uvchksum implicit none ; private +public porous_widths_layer, porous_widths_interface, porous_barriers_init + #include -public porous_widths +!> The control structure for the MOM_porous_barriers module +type, public :: porous_barrier_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + type(diag_ctrl), pointer :: & + diag => Null() !< A structure to regulate diagnostic output timing + logical :: debug !< If true, write verbose checksums for debugging purposes. + real :: mask_depth !< The depth shallower than which porous barrier is not applied [Z ~> m] + integer :: eta_interp !< An integer indicating how the interface heights at the velocity + !! points are calculated. Valid values are given by the parameters + !! defined below: MAX, MIN, ARITHMETIC and HARMONIC. + integer :: answer_date !< The vintage of the porous barrier weight function calculations. + !! Values below 20220806 recover the old answers in which the layer + !! averaged weights are not strictly limited by an upper-bound of 1.0 . + !>@{ Diagnostic IDs + integer :: id_por_layer_widthU = -1, id_por_layer_widthV = -1, & + id_por_face_areaU = -1, id_por_face_areaV = -1 + !>@} +end type porous_barrier_CS -!> Calculates curve fit from D_min, D_max, D_avg -interface porous_widths - module procedure por_widths, calc_por_layer -end interface porous_widths +integer :: id_clock_porous_barrier !< CPU clock for porous barrier + +!>@{ Enumeration values for eta interpolation schemes +integer, parameter :: ETA_INTERP_MAX = 1 +integer, parameter :: ETA_INTERP_MIN = 2 +integer, parameter :: ETA_INTERP_ARITH = 3 +integer, parameter :: ETA_INTERP_HARM = 4 +character(len=20), parameter :: ETA_INTERP_MAX_STRING = "MAX" +character(len=20), parameter :: ETA_INTERP_MIN_STRING = "MIN" +character(len=20), parameter :: ETA_INTERP_ARITH_STRING = "ARITHMETIC" +character(len=20), parameter :: ETA_INTERP_HARM_STRING = "HARMONIC" +!>@} contains -!> subroutine to assign cell face areas and layer widths for porous topography -subroutine por_widths(h, tv, G, GV, US, eta, pbv, eta_bt, halo_size, eta_to_m) - !eta_bt, halo_size, eta_to_m not currently used - !variables needed to call find_eta - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various - !! thermodynamic variables. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: eta !< layer interface heights - !! [Z ~> m] or 1/eta_to_m m). - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: eta_bt !< optional barotropic - !! variable that gives the "correct" free surface height (Boussinesq) or total water - !! column mass per unit area (non-Boussinesq). This is used to dilate the layer. - !! thicknesses when calculating interfaceheights [H ~> m or kg m-2]. - integer, optional, intent(in) :: halo_size !< width of halo points on - !! which to calculate eta. - - real, optional, intent(in) :: eta_to_m !< The conversion factor from - !! the units of eta to m; by default this is US%Z_to_m. - type(porous_barrier_ptrs), intent(inout) :: pbv !< porous barrier fractional cell metrics +!> subroutine to assign porous barrier widths averaged over a layer +subroutine porous_widths_layer(h, tv, G, GV, US, pbv, CS, eta_bt) + ! Note: eta_bt is not currently used + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: eta_bt !< optional barotropic variable + !! used to dilate the layer thicknesses + !! [H ~> m or kg m-2]. + type(porous_barrier_type), intent(inout) :: pbv !< porous barrier fractional cell metrics + type(porous_barrier_CS), intent(in) :: CS !< Control structure for porous barrier !local variables - integer ii, i, j, k, nk, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - real w_layer, & ! fractional open width of layer interface [nondim] - A_layer, & ! integral of fractional open width from bottom to current layer[Z ~> m] - A_layer_prev, & ! integral of fractional open width from bottom to previous layer [Z ~> m] - eta_s, & ! layer height used for fit [Z ~> m] - eta_prev ! interface height of previous layer [Z ~> m] - isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed - IsdB = G%IsdB; IedB = G%IedB; JsdB = G%JsdB; JedB = G%JedB - - !eta is zero at surface and decreases downward - - nk = SZK_(G) - - !currently no treatment for using optional find_eta arguments if present - call find_eta(h, tv, G, GV, US, eta) - - do j=jsd,jed; do I=IsdB,IedB - if (G%porous_DavgU(I,j) < 0.) then - do K = nk+1,1,-1 - eta_s = max(eta(I,j,K), eta(I+1,j,K)) !take shallower layer height - if (eta_s <= G%porous_DminU(I,j)) then - pbv%por_layer_widthU(I,j,K) = 0.0 - A_layer_prev = 0.0 - if (K < nk+1) then - pbv%por_face_areaU(I,j,k) = 0.0; endif + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: eta_u ! Layer interface heights at u points [Z ~> m] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: eta_v ! Layer interface heights at v points [Z ~> m] + real, dimension(SZIB_(G),SZJB_(G)) :: A_layer_prev ! Integral of fractional open width from the bottom + ! to the previous layer at u or v points [Z ~> m] + logical, dimension(SZIB_(G),SZJB_(G)) :: do_I ! Booleans for calculation at u or v points + ! updated while moving up layers + real :: A_layer ! Integral of fractional open width from bottom to current layer [Z ~> m] + real :: dz_min ! The minimum layer thickness [Z ~> m] + real :: dmask ! The depth below which porous barrier is not applied [Z ~> m] + integer :: i, j, k, nk, is, ie, js, je, Isq, Ieq, Jsq, Jeq + + if (.not.CS%initialized) call MOM_error(FATAL, & + "MOM_Porous_barrier: Module must be initialized before it is used.") + + call cpu_clock_begin(id_clock_porous_barrier) + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nk = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + if (CS%answer_date < 20220806) then + dmask = 0.0 + else + dmask = CS%mask_depth + endif + + call calc_eta_at_uv(eta_u, eta_v, CS%eta_interp, dmask, h, tv, G, GV, US) + + dz_min = GV%Angstrom_Z + + ! u-points + do j=js,je ; do I=Isq,Ieq ; do_I(I,j) = .False. ; enddo ; enddo + + do j=js,je ; do I=Isq,Ieq ; if (G%porous_DavgU(I,j) < dmask) then + call calc_por_layer(G%porous_DminU(I,j), G%porous_DmaxU(I,j), G%porous_DavgU(I,j), & + eta_u(I,j,nk+1), A_layer_prev(I,j), do_I(I,j)) + endif ; enddo ; enddo + + if (CS%answer_date < 20220806) then + do k=nk,1,-1 ; do j=js,je ; do I=Isq,Ieq ; if (G%porous_DavgU(I,j) < dmask) then + call calc_por_layer(G%porous_DminU(I,j), G%porous_DmaxU(I,j), G%porous_DavgU(I,j), & + eta_u(I,j,K), A_layer, do_I(I,j)) + if (eta_u(I,j,K) - eta_u(I,j,K+1) > 0.0) then + pbv%por_face_areaU(I,j,k) = (A_layer - A_layer_prev(I,j)) / (eta_u(I,j,K) - eta_u(I,j,K+1)) + else + pbv%por_face_areaU(I,j,k) = 0.0 + endif + A_layer_prev(I,j) = A_layer + endif ; enddo ; enddo ; enddo + else + do k=nk,1,-1 ; do j=js,je ; do I=Isq,Ieq + if (do_I(I,j)) then + call calc_por_layer(G%porous_DminU(I,j), G%porous_DmaxU(I,j), G%porous_DavgU(I,j), & + eta_u(I,j,K), A_layer, do_I(I,j)) + if (eta_u(I,j,K) - (eta_u(I,j,K+1)+dz_min) > 0.0) then + pbv%por_face_areaU(I,j,k) = min(1.0, (A_layer - A_layer_prev(I,j)) / (eta_u(I,j,K) - eta_u(I,j,K+1))) else - call calc_por_layer(G%porous_DminU(I,j), G%porous_DmaxU(I,j), & - G%porous_DavgU(I,j), eta_s, w_layer, A_layer) - pbv%por_layer_widthU(I,j,K) = w_layer - if (k <= nk) then - if ((eta_s - eta_prev) > 0.0) then - pbv%por_face_areaU(I,j,k) = (A_layer - A_layer_prev)/& - (eta_s-eta_prev) - else - pbv%por_face_areaU(I,j,k) = 0.0; endif - endif - eta_prev = eta_s - A_layer_prev = A_layer + pbv%por_face_areaU(I,j,k) = 0.0 ! use calc_por_interface() might be a better choice endif - enddo - endif - enddo; enddo - - do J=JsdB,JedB; do i=isd,ied - if (G%porous_DavgV(i,J) < 0.) then - do K = nk+1,1,-1 - eta_s = max(eta(i,J,K), eta(i,J+1,K)) !take shallower layer height - if (eta_s <= G%porous_DminV(i,J)) then - pbv%por_layer_widthV(i,J,K) = 0.0 - A_layer_prev = 0.0 - if (K < nk+1) then - pbv%por_face_areaV(i,J,k) = 0.0; endif + A_layer_prev(I,j) = A_layer + else + pbv%por_face_areaU(I,j,k) = 1.0 + endif + enddo ; enddo ; enddo + endif + + ! v-points + do J=Jsq,Jeq ; do i=is,ie ; do_I(i,J) = .False. ; enddo ; enddo + + do J=Jsq,Jeq ; do i=is,ie ; if (G%porous_DavgV(i,J) < dmask) then + call calc_por_layer(G%porous_DminV(i,J), G%porous_DmaxV(i,J), G%porous_DavgV(i,J), & + eta_v(i,J,nk+1), A_layer_prev(i,J), do_I(i,J)) + endif ; enddo ; enddo + + if (CS%answer_date < 20220806) then + do k=nk,1,-1 ; do J=Jsq,Jeq ; do i=is,ie ; if (G%porous_DavgV(i,J) < dmask) then + call calc_por_layer(G%porous_DminV(i,J), G%porous_DmaxV(i,J), G%porous_DavgV(i,J), & + eta_v(i,J,K), A_layer, do_I(i,J)) + if (eta_v(i,J,K) - eta_v(i,J,K+1) > 0.0) then + pbv%por_face_areaV(i,J,k) = (A_layer - A_layer_prev(i,J)) / (eta_v(i,J,K) - eta_v(i,J,K+1)) + else + pbv%por_face_areaV(i,J,k) = 0.0 + endif + A_layer_prev(i,J) = A_layer + endif ; enddo ; enddo ; enddo + else + do k=nk,1,-1 ; do J=Jsq,Jeq ; do i=is,ie + if (do_I(i,J)) then + call calc_por_layer(G%porous_DminV(i,J), G%porous_DmaxV(i,J), G%porous_DavgV(i,J), & + eta_v(i,J,K), A_layer, do_I(i,J)) + if (eta_v(i,J,K) - (eta_v(i,J,K+1)+dz_min) > 0.0) then + pbv%por_face_areaV(i,J,k) = min(1.0, (A_layer - A_layer_prev(i,J)) / (eta_v(i,J,K) - eta_v(i,J,K+1))) else - call calc_por_layer(G%porous_DminV(i,J), G%porous_DmaxV(i,J), & - G%porous_DavgV(i,J), eta_s, w_layer, A_layer) - pbv%por_layer_widthV(i,J,K) = w_layer - if (k <= nk) then - if ((eta_s - eta_prev) > 0.0) then - pbv%por_face_areaV(i,J,k) = (A_layer - A_layer_prev)/& - (eta_s-eta_prev) - else - pbv%por_face_areaU(I,j,k) = 0.0; endif - endif - eta_prev = eta_s - A_layer_prev = A_layer + pbv%por_face_areaV(i,J,k) = 0.0 ! use calc_por_interface() might be a better choice endif - enddo - endif - enddo; enddo + A_layer_prev(i,J) = A_layer + else + pbv%por_face_areaV(i,J,k) = 1.0 + endif + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call uvchksum("Interface height used by porous barrier for layer weights", & + eta_u, eta_v, G%HI, haloshift=0, scalar_pair=.true.) + call uvchksum("Porous barrier layer-averaged weights: por_face_area[UV]", & + pbv%por_face_areaU, pbv%por_face_areaV, G%HI, haloshift=0, & + scalar_pair=.true.) + endif + + if (CS%id_por_face_areaU > 0) call post_data(CS%id_por_face_areaU, pbv%por_face_areaU, CS%diag) + if (CS%id_por_face_areaV > 0) call post_data(CS%id_por_face_areaV, pbv%por_face_areaV, CS%diag) -end subroutine por_widths + call cpu_clock_end(id_clock_porous_barrier) +end subroutine porous_widths_layer -!> subroutine to calculate the profile fit for a single layer in a column -subroutine calc_por_layer(D_min, D_max, D_avg, eta_layer, w_layer, A_layer) +!> subroutine to assign porous barrier widths at the layer interfaces +subroutine porous_widths_interface(h, tv, G, GV, US, pbv, CS, eta_bt) + ! Note: eta_bt is not currently used + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: eta_bt !< optional barotropic variable + !! used to dilate the layer thicknesses + !! [H ~> m or kg m-2]. + type(porous_barrier_type), intent(inout) :: pbv !< porous barrier fractional cell metrics + type(porous_barrier_CS), intent(in) :: CS !< Control structure for porous barrier - real, intent(in) :: D_min !< minimum topographic height [Z ~> m] - real, intent(in) :: D_max !< maximum topographic height [Z ~> m] - real, intent(in) :: D_avg !< mean topographic height [Z ~> m] - real, intent(in) :: eta_layer !< height of interface [Z ~> m] - real, intent(out) :: w_layer !< frac. open interface width of current layer [nondim] - real, intent(out) :: A_layer !< frac. open face area of current layer [Z ~> m] !local variables - real m, a, & !convenience constant for fit [nondim] - zeta, & !normalized vertical coordinate [nondim] - psi, & !fractional width of layer between D_min and D_max [nondim] - psi_int !integral of psi from 0 to zeta + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: eta_u ! Layer interface height at u points [Z ~> m] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: eta_v ! Layer interface height at v points [Z ~> m] + logical, dimension(SZIB_(G),SZJB_(G)) :: do_I ! Booleans for calculation at u or v points + ! updated while moving up layers + real :: dmask ! The depth below which porous barrier is not applied [Z ~> m] + integer :: i, j, k, nk, is, ie, js, je, Isq, Ieq, Jsq, Jeq + + if (.not.CS%initialized) call MOM_error(FATAL, & + "MOM_Porous_barrier: Module must be initialized before it is used.") + + call cpu_clock_begin(id_clock_porous_barrier) + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nk = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + if (CS%answer_date < 20220806) then + dmask = 0.0 + else + dmask = CS%mask_depth + endif + + call calc_eta_at_uv(eta_u, eta_v, CS%eta_interp, dmask, h, tv, G, GV, US) + + ! u-points + do j=js,je ; do I=Isq,Ieq + do_I(I,j) = .False. + if (G%porous_DavgU(I,j) < dmask) do_I(I,j) = .True. + enddo ; enddo + + if (CS%answer_date < 20220806) then + do K=1,nk+1 ; do j=js,je ; do I=Isq,Ieq ; if (G%porous_DavgU(I,j) < dmask) then + call calc_por_interface(G%porous_DminU(I,j), G%porous_DmaxU(I,j), G%porous_DavgU(I,j), & + eta_u(I,j,K), pbv%por_layer_widthU(I,j,K), do_I(I,j)) + endif ; enddo ; enddo ; enddo + else + do K=1,nk+1 ; do j=js,je ; do I=Isq,Ieq + if (do_I(I,j)) then + call calc_por_interface(G%porous_DminU(I,j), G%porous_DmaxU(I,j), G%porous_DavgU(I,j), & + eta_u(I,j,K), pbv%por_layer_widthU(I,j,K), do_I(I,j)) + else + pbv%por_layer_widthU(I,j,K) = 1.0 + endif + enddo ; enddo ; enddo + endif + + ! v-points + do J=Jsq,Jeq ; do i=is,ie + do_I(i,J) = .False. + if (G%porous_DavgV(i,J) < dmask) do_I(i,J) = .True. + enddo ; enddo + + if (CS%answer_date < 20220806) then + do K=1,nk+1 ; do J=Jsq,Jeq ; do i=is,ie ; if (G%porous_DavgV(i,J) < dmask) then + call calc_por_interface(G%porous_DminV(i,J), G%porous_DmaxV(i,J), G%porous_DavgV(i,J), & + eta_v(i,J,K), pbv%por_layer_widthV(i,J,K), do_I(i,J)) + endif ; enddo ; enddo ; enddo + else + do K=1,nk+1 ; do J=Jsq,Jeq ; do i=is,ie + if (do_I(i,J)) then + call calc_por_interface(G%porous_DminV(i,J), G%porous_DmaxV(i,J), G%porous_DavgV(i,J), & + eta_v(i,J,K), pbv%por_layer_widthV(i,J,K), do_I(i,J)) + else + pbv%por_layer_widthV(i,J,K) = 1.0 + endif + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call uvchksum("Interface height used by porous barrier for interface weights", & + eta_u, eta_v, G%HI, haloshift=0, scalar_pair=.true.) + call uvchksum("Porous barrier weights at the layer-interface: por_layer_width[UV]", & + pbv%por_layer_widthU, pbv%por_layer_widthV, G%HI, & + haloshift=0, scalar_pair=.true.) + endif + + if (CS%id_por_layer_widthU > 0) call post_data(CS%id_por_layer_widthU, pbv%por_layer_widthU, CS%diag) + if (CS%id_por_layer_widthV > 0) call post_data(CS%id_por_layer_widthV, pbv%por_layer_widthV, CS%diag) + + call cpu_clock_end(id_clock_porous_barrier) +end subroutine porous_widths_interface + +subroutine calc_eta_at_uv(eta_u, eta_v, interp, dmask, h, tv, G, GV, US, eta_bt) + !variables needed to call find_eta + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: eta_bt !< optional barotropic variable + !! used to dilate the layer thicknesses + !! [H ~> m or kg m-2]. + real, intent(in) :: dmask !< The depth shallower than which + !! porous barrier is not applied [Z ~> m] + integer, intent(in) :: interp !< eta interpolation method + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(out) :: eta_u !< Layer interface heights at u points [Z ~> m] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(out) :: eta_v !< Layer interface heights at v points [Z ~> m] + + ! local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: eta ! Layer interface heights [Z ~> m]. + real :: dz_neglect ! A negligible height difference [Z ~> m] + integer :: i, j, k, nk, is, ie, js, je, Isq, Ieq, Jsq, Jeq + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nk = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + ! currently no treatment for using optional find_eta arguments if present + call find_eta(h, tv, G, GV, US, eta, halo_size=1) + + dz_neglect = GV%dZ_subroundoff + + do K=1,nk+1 + do j=js,je ; do I=Isq,Ieq ; eta_u(I,j,K) = dmask ; enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie ; eta_v(i,J,K) = dmask ; enddo ; enddo + enddo + + select case (interp) + case (ETA_INTERP_MAX) ! The shallower interface height + do K=1,nk+1 + do j=js,je ; do I=Isq,Ieq ; if (G%porous_DavgU(I,j) < dmask) then + eta_u(I,j,K) = max(eta(i,j,K), eta(i+1,j,K)) + endif ; enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie ; if (G%porous_DavgV(i,J) < dmask) then + eta_v(i,J,K) = max(eta(i,j,K), eta(i,j+1,K)) + endif ; enddo ; enddo + enddo + case (ETA_INTERP_MIN) ! The deeper interface height + do K=1,nk+1 + do j=js,je ; do I=Isq,Ieq ; if (G%porous_DavgU(I,j) < dmask) then + eta_u(I,j,K) = min(eta(i,j,K), eta(i+1,j,K)) + endif ; enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie ; if (G%porous_DavgV(i,J) < dmask) then + eta_v(i,J,K) = min(eta(i,j,K), eta(i,j+1,K)) + endif ; enddo ; enddo + enddo + case (ETA_INTERP_ARITH) ! Arithmetic mean + do K=1,nk+1 + do j=js,je ; do I=Isq,Ieq ; if (G%porous_DavgU(I,j) < dmask) then + eta_u(I,j,K) = 0.5 * (eta(i,j,K) + eta(i+1,j,K)) + endif ; enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie ; if (G%porous_DavgV(i,J) < dmask) then + eta_v(i,J,K) = 0.5 * (eta(i,j,K) + eta(i,j+1,K)) + endif ; enddo ; enddo + enddo + case (ETA_INTERP_HARM) ! Harmonic mean + do K=1,nk+1 + do j=js,je ; do I=Isq,Ieq ; if (G%porous_DavgU(I,j) < dmask) then + eta_u(I,j,K) = 2.0 * (eta(i,j,K) * eta(i+1,j,K)) / (eta(i,j,K) + eta(i+1,j,K) + dz_neglect) + endif ; enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie ; if (G%porous_DavgV(i,J) < dmask) then + eta_v(i,J,K) = 2.0 * (eta(i,j,K) * eta(i,j+1,K)) / (eta(i,j,K) + eta(i,j+1,K) + dz_neglect) + endif ; enddo ; enddo + enddo + case default + call MOM_error(FATAL, "porous_widths::calc_eta_at_uv: "//& + "invalid value for eta interpolation method.") + end select +end subroutine calc_eta_at_uv - !three parameter fit from Adcroft 2013 - m = (D_avg - D_min)/(D_max - D_min) - a = (1. - m)/m +!> subroutine to calculate the profile fit (the three parameter fit from Adcroft 2013) +! of the open face area fraction below a certain depth (eta_layer) in a column +subroutine calc_por_layer(D_min, D_max, D_avg, eta_layer, A_layer, do_next) + real, intent(in) :: D_min !< minimum topographic height (deepest) [Z ~> m] + real, intent(in) :: D_max !< maximum topographic height (shallowest) [Z ~> m] + real, intent(in) :: D_avg !< mean topographic height [Z ~> m] + real, intent(in) :: eta_layer !< height of interface [Z ~> m] + real, intent(out) :: A_layer !< frac. open face area of below eta_layer [Z ~> m] + logical, intent(out) :: do_next !< False if eta_layer>D_max - zeta = (eta_layer - D_min)/(D_max - D_min) + ! local variables + real :: m ! convenience constant for fit [nondim] + real :: zeta ! normalized vertical coordinate [nondim] + do_next = .True. if (eta_layer <= D_min) then - w_layer = 0.0 A_layer = 0.0 - elseif (eta_layer >= D_max) then - w_layer = 1.0 + elseif (eta_layer > D_max) then A_layer = eta_layer - D_avg + do_next = .False. else + m = (D_avg - D_min) / (D_max - D_min) + zeta = (eta_layer - D_min) / (D_max - D_min) if (m < 0.5) then - psi = zeta**(1./a) - psi_int = (1.-m)*zeta**(1./(1.-m)) + A_layer = (D_max - D_min) * ((1.0 - m) * zeta**(1.0 / (1.0 - m))) elseif (m == 0.5) then - psi = zeta - psi_int = 0.5*zeta*zeta + A_layer = (D_max - D_min) * (0.5 * zeta * zeta) else - psi = 1. - (1. - zeta)**a - psi_int = zeta - m + m*((1-zeta)**(1/m)) + A_layer = (D_max - D_min) * (zeta - m + m * ((1.0 - zeta)**(1.0 / m))) endif - w_layer = psi - A_layer = (D_max - D_min)*psi_int endif +end subroutine calc_por_layer +!> subroutine to calculate the profile fit (the three parameter fit from Adcroft 2013) +! of the open interface fraction at a certain depth (eta_layer) in a column +subroutine calc_por_interface(D_min, D_max, D_avg, eta_layer, w_layer, do_next) + real, intent(in) :: D_min !< minimum topographic height (deepest) [Z ~> m] + real, intent(in) :: D_max !< maximum topographic height (shallowest) [Z ~> m] + real, intent(in) :: D_avg !< mean topographic height [Z ~> m] + real, intent(in) :: eta_layer !< height of interface [Z ~> m] + real, intent(out) :: w_layer !< frac. open interface width at eta_layer [nondim] + logical, intent(out) :: do_next !< False if eta_layer>D_max -end subroutine calc_por_layer + ! local variables + real :: m, a ! convenience constants for fit [nondim] + real :: zeta ! normalized vertical coordinate [nondim] + + do_next = .True. + if (eta_layer <= D_min) then + w_layer = 0.0 + elseif (eta_layer > D_max) then + w_layer = 1.0 + do_next = .False. + else ! The following option could be refactored for stability and efficiency (with fewer divisions) + m = (D_avg - D_min) / (D_max - D_min) + a = (1.0 - m) / m + zeta = (eta_layer - D_min) / (D_max - D_min) + if (m < 0.5) then + w_layer = zeta**(1.0 / a) + ! Note that this would be safer and more efficent if it were rewritten as: + ! w_layer = zeta**( (D_avg - D_min) / (D_max - D_avg) ) + elseif (m == 0.5) then + w_layer = zeta + else + w_layer = 1.0 - (1.0 - zeta)**a + endif + endif +end subroutine calc_por_interface + +subroutine porous_barriers_init(Time, GV, US, param_file, diag, CS) + type(time_type), intent(in) :: Time !< Current model time + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< structure indicating parameter file to parse + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure + type(porous_barrier_CS), intent(inout) :: CS !< Module control structure + + ! local variables + character(len=40) :: mdl = "MOM_porous_barriers" ! This module's name. + character(len=20) :: interp_method ! String storing eta interpolation method + integer :: default_answer_date ! Global answer date + !> This include declares and sets the variable "version". +# include "version_variable.h" + + CS%initialized = .true. + CS%diag => diag + + call log_version(param_file, mdl, version, "", log_to_all=.true., layout=.false., & + debugging=.false.) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "PORBAR_ANSWER_DATE", CS%answer_date, & + "The vintage of the porous barrier weight function calculations. Values below "//& + "20220806 recover the old answers in which the layer averaged weights are not "//& + "strictly limited by an upper-bound of 1.0 .", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) + call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) + call get_param(param_file, mdl, "PORBAR_MASKING_DEPTH", CS%mask_depth, & + "If the effective average depth at the velocity cell is shallower than this "//& + "number, then porous barrier is not applied at that location. "//& + "PORBAR_MASKING_DEPTH is assumed to be positive below the sea surface.", & + units="m", default=0.0, scale=US%m_to_Z) + ! The sign needs to be inverted to be consistent with the sign convention of Davg_[UV] + CS%mask_depth = -CS%mask_depth + call get_param(param_file, mdl, "PORBAR_ETA_INTERP", interp_method, & + "A string describing the method that decides how the "//& + "interface heights at the velocity points are calculated. "//& + "Valid values are:\n"//& + "\t MAX (the default) - maximum of the adjacent cells \n"//& + "\t MIN - minimum of the adjacent cells \n"//& + "\t ARITHMETIC - arithmetic mean of the adjacent cells \n"//& + "\t HARMONIC - harmonic mean of the adjacent cells \n", & + default=ETA_INTERP_MAX_STRING) + select case (interp_method) + case (ETA_INTERP_MAX_STRING) ; CS%eta_interp = ETA_INTERP_MAX + case (ETA_INTERP_MIN_STRING) ; CS%eta_interp = ETA_INTERP_MIN + case (ETA_INTERP_ARITH_STRING) ; CS%eta_interp = ETA_INTERP_ARITH + case (ETA_INTERP_HARM_STRING) ; CS%eta_interp = ETA_INTERP_HARM + case default + call MOM_error(FATAL, "porous_barriers_init: Unrecognized setting "// & + "#define PORBAR_ETA_INTERP "//trim(interp_method)//" found in input file.") + end select + + CS%id_por_layer_widthU = register_diag_field('ocean_model', 'por_layer_widthU', diag%axesCui, Time, & + 'Porous barrier open width fraction (at the layer interfaces) of the u-faces', 'nondim') + CS%id_por_layer_widthV = register_diag_field('ocean_model', 'por_layer_widthV', diag%axesCvi, Time, & + 'Porous barrier open width fraction (at the layer interfaces) of the v-faces', 'nondim') + CS%id_por_face_areaU = register_diag_field('ocean_model', 'por_face_areaU', diag%axesCuL, Time, & + 'Porous barrier open area fraction (layer averaged) of U-faces', 'nondim') + CS%id_por_face_areaV = register_diag_field('ocean_model', 'por_face_areaV', diag%axesCvL, Time, & + 'Porous barrier open area fraction (layer averaged) of V-faces', 'nondim') + + id_clock_porous_barrier = cpu_clock_id('(Ocean porous barrier)', grain=CLOCK_MODULE) +end subroutine end module MOM_porous_barriers diff --git a/src/core/MOM_stoch_eos.F90 b/src/core/MOM_stoch_eos.F90 new file mode 100644 index 0000000000..119337dd49 --- /dev/null +++ b/src/core/MOM_stoch_eos.F90 @@ -0,0 +1,264 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Provides the ocean stochastic equation of state +module MOM_stoch_eos + +use MOM_diag_mediator, only : register_diag_field, post_data, diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL +use MOM_file_parser, only : get_param, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_isopycnal_slopes, only : vert_fill_TS +use MOM_random, only : PRNG, random_2d_constructor, random_2d_norm +use MOM_restart, only : MOM_restart_CS, register_restart_field, is_new_run, query_initialized +use MOM_time_manager, only : time_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +!use random_numbers_mod, only : getRandomNumbers, initializeRandomNumberStream, randomNumberStream + +implicit none ; private +#include + +public MOM_stoch_eos_init +public MOM_stoch_eos_run +public stoch_EOS_register_restarts +public post_stoch_EOS_diags +public MOM_calc_varT + +!> Describes parameters of the stochastic component of the EOS +!! correction, described in Stanley et al. JAMES 2020. +type, public :: MOM_stoch_eos_CS ; private + real, allocatable :: l2_inv(:,:) !< One over sum of the T cell side side lengths squared [L-2 ~> m-2] + real, allocatable :: rgauss(:,:) !< nondimensional random Gaussian [nondim] + real :: tfac = 0.27 !< Nondimensional decorrelation time factor, ~1/3.7 [nondim] + real :: amplitude = 0.624499 !< Nondimensional standard deviation of Gaussian [nondim] + integer :: seed !< PRNG seed + type(PRNG) :: rn_CS !< PRNG control structure + real, allocatable :: pattern(:,:) !< Random pattern for stochastic EOS [nondim] + real, allocatable :: phi(:,:) !< temporal correlation stochastic EOS [nondim] + logical :: use_stoch_eos!< If true, use the stochastic equation of state (Stanley et al. 2020) + real :: stanley_coeff !< Coefficient correlating the temperature gradient + !! and SGS T variance [nondim]; if <0, turn off scheme in all codes + real :: stanley_a !< a in exp(aX) in stochastic coefficient [nondim] + real :: kappa_smooth !< A diffusivity for smoothing T/S in vanished layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + + !>@{ Diagnostic IDs + integer :: id_stoch_eos = -1, id_stoch_phi = -1, id_tvar_sgs = -1 + !>@} + +end type MOM_stoch_eos_CS + +contains + +!> Initializes MOM_stoch_eos module, returning a logical indicating whether this module will be used. +logical function MOM_stoch_eos_init(Time, G, GV, US, param_file, diag, CS, restart_CS) + type(time_type), intent(in) :: Time !< Time for stochastic process + 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 + type(param_file_type), intent(in) :: param_file !< structure indicating parameter file to parse + type(diag_ctrl), target, intent(inout) :: diag !< Structure used to control diagnostics + type(MOM_stoch_eos_CS), intent(inout) :: CS !< Stochastic control structure + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure. + + ! local variables + integer :: i,j + + MOM_stoch_eos_init = .false. + + CS%seed = 0 + + call get_param(param_file, "MOM_stoch_eos", "STOCH_EOS", CS%use_stoch_eos, & + "If true, stochastic perturbations are applied "//& + "to the EOS in the PGF.", default=.false.) + call get_param(param_file, "MOM_stoch_eos", "STANLEY_COEFF", CS%stanley_coeff, & + "Coefficient correlating the temperature gradient "//& + "and SGS T variance.", units="nondim", default=-1.0) + call get_param(param_file, "MOM_stoch_eos", "STANLEY_A", CS%stanley_a, & + "Coefficient a which scales chi in stochastic perturbation of the "//& + "SGS T variance.", units="nondim", default=1.0, & + do_not_log=((CS%stanley_coeff<0.0) .or. .not.CS%use_stoch_eos)) + call get_param(param_file, "MOM_stoch_eos", "KD_SMOOTH", CS%kappa_smooth, & + "A diapycnal diffusivity that is used to interpolate "//& + "more sensible values of T & S into thin layers.", & + units="m2 s-1", default=1.0e-6, scale=GV%m2_s_to_HZ_T, & + do_not_log=(CS%stanley_coeff<0.0)) + + ! Don't run anything if STANLEY_COEFF < 0 + if (CS%stanley_coeff >= 0.0) then + if (.not.allocated(CS%pattern)) call MOM_error(FATAL, & + "MOM_stoch_eos_CS%pattern is not allocated when it should be, suggesting that "//& + "stoch_EOS_register_restarts() has not been called before MOM_stoch_eos_init().") + + allocate(CS%phi(G%isd:G%ied,G%jsd:G%jed), source=0.0) + allocate(CS%l2_inv(G%isd:G%ied,G%jsd:G%jed), source=0.0) + allocate(CS%rgauss(G%isd:G%ied,G%jsd:G%jed), source=0.0) + call get_param(param_file, "MOM_stoch_eos", "SEED_STOCH_EOS", CS%seed, & + "Specfied seed for random number sequence ", default=0) + call random_2d_constructor(CS%rn_CS, G%HI, Time, CS%seed) + call random_2d_norm(CS%rn_CS, G%HI, CS%rgauss) + ! fill array with approximation of grid area needed for decorrelation time-scale calculation + do j=G%jsc,G%jec + do i=G%isc,G%iec + CS%l2_inv(i,j) = 1.0 / ( (G%dxT(i,j)**2) + (G%dyT(i,j)**2) ) + enddo + enddo + + if (.not.query_initialized(CS%pattern, "stoch_eos_pattern", restart_CS) .or. & + is_new_run(restart_CS)) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + CS%pattern(i,j) = CS%amplitude*CS%rgauss(i,j) + enddo ; enddo + endif + + !register diagnostics + CS%id_tvar_sgs = register_diag_field('ocean_model', 'tvar_sgs', diag%axesTL, Time, & + 'Parameterized SGS Temperature Variance ', 'None') + if (CS%use_stoch_eos) then + CS%id_stoch_eos = register_diag_field('ocean_model', 'stoch_eos', diag%axesT1, Time, & + 'random pattern for EOS', 'None') + CS%id_stoch_phi = register_diag_field('ocean_model', 'stoch_phi', diag%axesT1, Time, & + 'phi for EOS', 'None') + endif + endif + + ! This module is only used if explicitly enabled or a positive correlation coefficient is set. + MOM_stoch_eos_init = CS%use_stoch_eos .or. (CS%stanley_coeff >= 0.0) + +end function MOM_stoch_eos_init + +!> Register fields related to the stoch_EOS module for resarts +subroutine stoch_EOS_register_restarts(HI, param_file, CS, restart_CS) + type(hor_index_type), intent(in) :: HI !< Horizontal index structure + type(param_file_type), intent(in) :: param_file !< structure indicating parameter file to parse + type(MOM_stoch_eos_CS), intent(inout) :: CS !< Stochastic control structure + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure. + + call get_param(param_file, "MOM_stoch_eos", "STANLEY_COEFF", CS%stanley_coeff, & + "Coefficient correlating the temperature gradient "//& + "and SGS T variance.", units="nondim", default=-1.0, do_not_log=.true.) + + if (CS%stanley_coeff >= 0.0) then + allocate(CS%pattern(HI%isd:HI%ied,HI%jsd:HI%jed), source=0.0) + call register_restart_field(CS%pattern, "stoch_eos_pattern", .false., restart_CS, & + "Random pattern for stoch EOS", "nondim") + endif + +end subroutine stoch_EOS_register_restarts + +!> Generates a pattern in space and time for the ocean stochastic equation of state +subroutine MOM_stoch_eos_run(G, u, v, delt, Time, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, intent(in) :: delt !< Time step size for AR1 process [T ~> s]. + type(time_type), intent(in) :: Time !< Time for stochastic process + type(MOM_stoch_eos_CS), intent(inout) :: CS !< Stochastic control structure + + ! local variables + real :: ubar, vbar ! Averaged velocities [L T-1 ~> m s-1] + real :: phi ! A temporal correlation factor [nondim] + integer :: i, j + + ! Return without doing anything if this capability is not enabled. + if (.not.CS%use_stoch_eos) return + + call random_2d_constructor(CS%rn_CS, G%HI, Time, CS%seed) + call random_2d_norm(CS%rn_CS, G%HI, CS%rgauss) + + ! advance AR(1) + do j=G%jsc,G%jec + do i=G%isc,G%iec + ubar = 0.5*(u(I,j,1)*G%mask2dCu(I,j)+u(I-1,j,1)*G%mask2dCu(I-1,j)) + vbar = 0.5*(v(i,J,1)*G%mask2dCv(i,J)+v(i,J-1,1)*G%mask2dCv(i,J-1)) + phi = exp(-delt*CS%tfac * sqrt(((ubar**2) + (vbar**2))*CS%l2_inv(i,j))) + CS%pattern(i,j) = phi*CS%pattern(i,j) + CS%amplitude*sqrt(1-phi**2)*CS%rgauss(i,j) + CS%phi(i,j) = phi + enddo + enddo + +end subroutine MOM_stoch_eos_run + +!> Write out any diagnostics related to this module. +subroutine post_stoch_EOS_diags(CS, tv, diag) + type(MOM_stoch_eos_CS), intent(in) :: CS !< Stochastic control structure + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + type(diag_ctrl), intent(inout) :: diag !< Structure to control diagnostics + + if (CS%id_stoch_eos > 0) call post_data(CS%id_stoch_eos, CS%pattern, diag) + if (CS%id_stoch_phi > 0) call post_data(CS%id_stoch_phi, CS%phi, diag) + if (CS%id_tvar_sgs > 0) call post_data(CS%id_tvar_sgs, tv%varT, diag) + +end subroutine post_stoch_EOS_diags + +!> Computes a parameterization of the SGS temperature variance +subroutine MOM_calc_varT(G, GV, US, h, tv, CS, dt) + 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 + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thickness [H ~> m] + type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure + type(MOM_stoch_eos_CS), intent(inout) :: CS !< Stochastic control structure + real, intent(in) :: dt !< Time increment [T ~> s] + + ! local variables + real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: & + T, & !> The temperature (or density) [C ~> degC], with the values in + !! in massless layers filled vertically by diffusion. + S !> The filled salinity [S ~> ppt], with the values in + !! in massless layers filled vertically by diffusion. + real :: hl(5) !> Copy of local stencil of H [H ~> m] + real :: dTdi2, dTdj2 !> Differences in T variance [C2 ~> degC2] + integer :: i, j, k + + ! Nothing happens if a negative correlation coefficient is set. + if (CS%stanley_coeff < 0.0) return + + ! This block does a thickness weighted variance calculation and helps control for + ! extreme gradients along layers which are vanished against topography. It is + ! still a poor approximation in the interior when coordinates are strongly tilted. + if (.not. associated(tv%varT)) allocate(tv%varT(G%isd:G%ied, G%jsd:G%jed, GV%ke), source=0.0) + call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, US, halo_here=1, larger_h_denom=.true.) + + do k=1,G%ke + do j=G%jsc,G%jec + do i=G%isc,G%iec + hl(1) = h(i,j,k) * G%mask2dT(i,j) + hl(2) = h(i-1,j,k) * G%mask2dCu(I-1,j) + hl(3) = h(i+1,j,k) * G%mask2dCu(I,j) + hl(4) = h(i,j-1,k) * G%mask2dCv(i,J-1) + hl(5) = h(i,j+1,k) * G%mask2dCv(i,J) + + ! SGS variance in i-direction [C2 ~> degC2] + dTdi2 = ( ( G%mask2dCu(I ,j) * (G%IdxCu(I ,j) * ( T(i+1,j,k) - T(i,j,k) )) & + + G%mask2dCu(I-1,j) * (G%IdxCu(I-1,j) * ( T(i,j,k) - T(i-1,j,k) )) & + ) * G%dxT(i,j) * 0.5 )**2 + ! SGS variance in j-direction [C2 ~> degC2] + dTdj2 = ( ( G%mask2dCv(i,J ) * (G%IdyCv(i,J ) * ( T(i,j+1,k) - T(i,j,k) )) & + + G%mask2dCv(i,J-1) * (G%IdyCv(i,J-1) * ( T(i,j,k) - T(i,j-1,k) )) & + ) * G%dyT(i,j) * 0.5 )**2 + tv%varT(i,j,k) = CS%stanley_coeff * ( dTdi2 + dTdj2 ) + ! Turn off scheme near land + tv%varT(i,j,k) = tv%varT(i,j,k) * (minval(hl) / (maxval(hl) + GV%H_subroundoff)) + enddo + enddo + enddo + ! if stochastic, perturb + if (CS%use_stoch_eos) then + do k=1,G%ke + do j=G%jsc,G%jec + do i=G%isc,G%iec + tv%varT(i,j,k) = exp(CS%stanley_a * CS%pattern(i,j)) * tv%varT(i,j,k) + enddo + enddo + enddo + endif +end subroutine MOM_calc_varT + +end module MOM_stoch_eos diff --git a/src/core/MOM_transcribe_grid.F90 b/src/core/MOM_transcribe_grid.F90 index 7ab15d542e..78ef287dfc 100644 --- a/src/core/MOM_transcribe_grid.F90 +++ b/src/core/MOM_transcribe_grid.F90 @@ -1,9 +1,11 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Module with routines for copying information from a shared dynamic horizontal !! grid to an ocean-specific horizontal grid and the reverse. module MOM_transcribe_grid -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_array_transform, only : rotate_array, rotate_array_pair use MOM_domains, only : pass_var, pass_vector use MOM_domains, only : To_All, SCALAR_PAIR, CGRID_NE, AGRID, BGRID_NE, CORNER @@ -56,6 +58,7 @@ subroutine copy_dyngrid_to_MOM_grid(dG, oG, US) oG%dyT(i,j) = dG%dyT(i+ido,j+jdo) oG%areaT(i,j) = dG%areaT(i+ido,j+jdo) oG%bathyT(i,j) = dG%bathyT(i+ido,j+jdo) - oG%Z_ref + oG%meanSL(i,j) = dG%meanSL(i+ido,j+jdo) + oG%Z_ref oG%dF_dx(i,j) = dG%dF_dx(i+ido,j+jdo) oG%dF_dy(i,j) = dG%dF_dy(i+ido,j+jdo) @@ -76,6 +79,7 @@ subroutine copy_dyngrid_to_MOM_grid(dG, oG, US) oG%porous_DavgU(I,j) = dG%porous_DavgU(I+ido,j+jdo) - oG%Z_ref oG%mask2dCu(I,j) = dG%mask2dCu(I+ido,j+jdo) + oG%OBCmaskCu(I,j) = dG%OBCmaskCu(I+ido,j+jdo) oG%areaCu(I,j) = dG%areaCu(I+ido,j+jdo) oG%IareaCu(I,j) = dG%IareaCu(I+ido,j+jdo) enddo ; enddo @@ -92,6 +96,7 @@ subroutine copy_dyngrid_to_MOM_grid(dG, oG, US) oG%porous_DavgV(i,J) = dG%porous_DavgV(i+ido,J+jdo) - oG%Z_ref oG%mask2dCv(i,J) = dG%mask2dCv(i+ido,J+jdo) + oG%OBCmaskCv(i,J) = dG%OBCmaskCv(i+ido,J+jdo) oG%areaCv(i,J) = dG%areaCv(i+ido,J+jdo) oG%IareaCv(i,J) = dG%IareaCv(i+ido,J+jdo) enddo ; enddo @@ -103,6 +108,7 @@ subroutine copy_dyngrid_to_MOM_grid(dG, oG, US) oG%dyBu(I,J) = dG%dyBu(I+ido,J+jdo) oG%areaBu(I,J) = dG%areaBu(I+ido,J+jdo) oG%CoriolisBu(I,J) = dG%CoriolisBu(I+ido,J+jdo) + oG%Coriolis2Bu(I,J) = dG%Coriolis2Bu(I+ido,J+jdo) oG%mask2dBu(I,J) = dG%mask2dBu(I+ido,J+jdo) enddo ; enddo @@ -131,15 +137,18 @@ subroutine copy_dyngrid_to_MOM_grid(dG, oG, US) ! Copy various scalar variables and strings. oG%x_axis_units = dG%x_axis_units ; oG%y_axis_units = dG%y_axis_units + oG%x_ax_unit_short = dG%x_ax_unit_short ; oG%y_ax_unit_short = dG%y_ax_unit_short + oG%grid_unit_to_L = dG%grid_unit_to_L oG%areaT_global = dG%areaT_global ; oG%IareaT_global = dG%IareaT_global oG%south_lat = dG%south_lat ; oG%west_lon = dG%west_lon oG%len_lat = dG%len_lat ; oG%len_lon = dG%len_lon - oG%Rad_Earth = dG%Rad_Earth ; oG%Rad_Earth_L = dG%Rad_Earth_L + oG%Rad_Earth_L = dG%Rad_Earth_L oG%max_depth = dG%max_depth ! Update the halos in case the dynamic grid has smaller halos than the ocean grid. call pass_var(oG%areaT, oG%Domain) call pass_var(oG%bathyT, oG%Domain) + call pass_var(oG%meanSL, oG%Domain) call pass_var(oG%geoLonT, oG%Domain) call pass_var(oG%geoLatT, oG%Domain) call pass_vector(oG%dxT, oG%dyT, oG%Domain, To_All+Scalar_Pair, AGRID) @@ -152,6 +161,7 @@ subroutine copy_dyngrid_to_MOM_grid(dG, oG, US) call pass_vector(oG%dxCu, oG%dyCv, oG%Domain, To_All+Scalar_Pair, CGRID_NE) call pass_vector(oG%dy_Cu, oG%dx_Cv, oG%Domain, To_All+Scalar_Pair, CGRID_NE) call pass_vector(oG%mask2dCu, oG%mask2dCv, oG%Domain, To_All+Scalar_Pair, CGRID_NE) + call pass_vector(oG%OBCmaskCu, oG%OBCmaskCv, oG%Domain, To_All+Scalar_Pair, CGRID_NE) call pass_vector(oG%IareaCu, oG%IareaCv, oG%Domain, To_All+Scalar_Pair, CGRID_NE) call pass_vector(oG%IareaCu, oG%IareaCv, oG%Domain, To_All+Scalar_Pair, CGRID_NE) call pass_vector(oG%geoLatCu, oG%geoLatCv, oG%Domain, To_All+Scalar_Pair, CGRID_NE) @@ -161,6 +171,7 @@ subroutine copy_dyngrid_to_MOM_grid(dG, oG, US) call pass_var(oG%geoLatBu, oG%Domain, position=CORNER) call pass_vector(oG%dxBu, oG%dyBu, oG%Domain, To_All+Scalar_Pair, BGRID_NE) call pass_var(oG%CoriolisBu, oG%Domain, position=CORNER) + call pass_var(oG%Coriolis2Bu, oG%Domain, position=CORNER) call pass_var(oG%mask2dBu, oG%Domain, position=CORNER) if (oG%bathymetry_at_vel) then @@ -210,6 +221,7 @@ subroutine copy_MOM_grid_to_dyngrid(oG, dG, US) dG%dyT(i,j) = oG%dyT(i+ido,j+jdo) dG%areaT(i,j) = oG%areaT(i+ido,j+jdo) dG%bathyT(i,j) = oG%bathyT(i+ido,j+jdo) + oG%Z_ref + dG%meanSL(i,j) = oG%meanSL(i+ido,j+jdo) - oG%Z_ref dG%dF_dx(i,j) = oG%dF_dx(i+ido,j+jdo) dG%dF_dy(i,j) = oG%dF_dy(i+ido,j+jdo) @@ -230,6 +242,7 @@ subroutine copy_MOM_grid_to_dyngrid(oG, dG, US) dG%porous_DavgU(I,j) = oG%porous_DavgU(I+ido,j+jdo) + oG%Z_ref dG%mask2dCu(I,j) = oG%mask2dCu(I+ido,j+jdo) + dG%OBCmaskCu(I,j) = oG%OBCmaskCu(I+ido,j+jdo) dG%areaCu(I,j) = oG%areaCu(I+ido,j+jdo) dG%IareaCu(I,j) = oG%IareaCu(I+ido,j+jdo) enddo ; enddo @@ -246,6 +259,7 @@ subroutine copy_MOM_grid_to_dyngrid(oG, dG, US) dG%porous_DavgV(i,J) = oG%porous_DavgU(i+ido,J+jdo) + oG%Z_ref dG%mask2dCv(i,J) = oG%mask2dCv(i+ido,J+jdo) + dG%OBCmaskCv(i,J) = oG%OBCmaskCv(i+ido,J+jdo) dG%areaCv(i,J) = oG%areaCv(i+ido,J+jdo) dG%IareaCv(i,J) = oG%IareaCv(i+ido,J+jdo) enddo ; enddo @@ -257,6 +271,7 @@ subroutine copy_MOM_grid_to_dyngrid(oG, dG, US) dG%dyBu(I,J) = oG%dyBu(I+ido,J+jdo) dG%areaBu(I,J) = oG%areaBu(I+ido,J+jdo) dG%CoriolisBu(I,J) = oG%CoriolisBu(I+ido,J+jdo) + dG%Coriolis2Bu(I,J) = oG%Coriolis2Bu(I+ido,J+jdo) dG%mask2dBu(I,J) = oG%mask2dBu(I+ido,J+jdo) enddo ; enddo @@ -286,15 +301,18 @@ subroutine copy_MOM_grid_to_dyngrid(oG, dG, US) ! Copy various scalar variables and strings. dG%x_axis_units = oG%x_axis_units ; dG%y_axis_units = oG%y_axis_units + dG%x_ax_unit_short = oG%x_ax_unit_short ; dG%y_ax_unit_short = oG%y_ax_unit_short + dG%grid_unit_to_L = oG%grid_unit_to_L dG%areaT_global = oG%areaT_global ; dG%IareaT_global = oG%IareaT_global dG%south_lat = oG%south_lat ; dG%west_lon = oG%west_lon dG%len_lat = oG%len_lat ; dG%len_lon = oG%len_lon - dG%Rad_Earth = oG%Rad_Earth ; dG%Rad_Earth_L = oG%Rad_Earth_L + dG%Rad_Earth_L = oG%Rad_Earth_L dG%max_depth = oG%max_depth ! Update the halos in case the dynamic grid has smaller halos than the ocean grid. call pass_var(dG%areaT, dG%Domain) call pass_var(dG%bathyT, dG%Domain) + call pass_var(dG%meanSL, dG%Domain) call pass_var(dG%geoLonT, dG%Domain) call pass_var(dG%geoLatT, dG%Domain) call pass_vector(dG%dxT, dG%dyT, dG%Domain, To_All+Scalar_Pair, AGRID) @@ -307,6 +325,7 @@ subroutine copy_MOM_grid_to_dyngrid(oG, dG, US) call pass_vector(dG%dxCu, dG%dyCv, dG%Domain, To_All+Scalar_Pair, CGRID_NE) call pass_vector(dG%dy_Cu, dG%dx_Cv, dG%Domain, To_All+Scalar_Pair, CGRID_NE) call pass_vector(dG%mask2dCu, dG%mask2dCv, dG%Domain, To_All+Scalar_Pair, CGRID_NE) + call pass_vector(dG%OBCmaskCu, dG%OBCmaskCv, dG%Domain, To_All+Scalar_Pair, CGRID_NE) call pass_vector(dG%IareaCu, dG%IareaCv, dG%Domain, To_All+Scalar_Pair, CGRID_NE) call pass_vector(dG%IareaCu, dG%IareaCv, dG%Domain, To_All+Scalar_Pair, CGRID_NE) call pass_vector(dG%geoLatCu, dG%geoLatCv, dG%Domain, To_All+Scalar_Pair, CGRID_NE) @@ -316,6 +335,7 @@ subroutine copy_MOM_grid_to_dyngrid(oG, dG, US) call pass_var(dG%geoLatBu, dG%Domain, position=CORNER) call pass_vector(dG%dxBu, dG%dyBu, dG%Domain, To_All+Scalar_Pair, BGRID_NE) call pass_var(dG%CoriolisBu, dG%Domain, position=CORNER) + call pass_var(dG%Coriolis2Bu, dG%Domain, position=CORNER) call pass_var(dG%mask2dBu, dG%Domain, position=CORNER) if (dG%bathymetry_at_vel) then diff --git a/src/core/MOM_unit_tests.F90 b/src/core/MOM_unit_tests.F90 index 08f8dea634..1e197dfe2b 100644 --- a/src/core/MOM_unit_tests.F90 +++ b/src/core/MOM_unit_tests.F90 @@ -1,17 +1,25 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Invokes unit tests in all modules that have them module MOM_unit_tests ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_array_transform, only : symmetric_sum_unit_tests +use MOM_diag_buffers, only : diag_buffer_unit_tests_2d, diag_buffer_unit_tests_3d use MOM_error_handler, only : MOM_error, FATAL, is_root_pe - -use MOM_string_functions, only : string_functions_unit_tests -use MOM_remapping, only : remapping_unit_tests +use MOM_hor_bnd_diffusion, only : near_boundary_unit_tests +use MOM_intrinsic_functions, only : intrinsic_functions_unit_tests +use MOM_mixed_layer_restrat, only : mixedlayer_restrat_unit_tests use MOM_neutral_diffusion, only : neutral_diffusion_unit_tests -use MOM_diag_vkernels, only : diag_vkernels_unit_tests use MOM_random, only : random_unit_tests -use MOM_lateral_boundary_diffusion, only : near_boundary_unit_tests +use MOM_remapping, only : remapping_unit_tests +use MOM_string_functions, only : string_functions_unit_tests use MOM_CFC_cap, only : CFC_cap_unit_tests +use MOM_EOS, only : EOS_unit_tests + implicit none ; private public unit_tests @@ -31,18 +39,28 @@ subroutine unit_tests(verbosity) if (is_root_pe()) then ! The following need only be tested on 1 PE if (string_functions_unit_tests(verbose)) call MOM_error(FATAL, & "MOM_unit_tests: string_functions_unit_tests FAILED") + if (symmetric_sum_unit_tests(verbose)) call MOM_error(FATAL, & + "MOM_unit_tests: symmetric_sum_unit_tests FAILED") + if (EOS_unit_tests(verbose)) call MOM_error(FATAL, & + "MOM_unit_tests: EOS_unit_tests FAILED") if (remapping_unit_tests(verbose)) call MOM_error(FATAL, & "MOM_unit_tests: remapping_unit_tests FAILED") + if (intrinsic_functions_unit_tests(verbose)) call MOM_error(FATAL, & + "MOM_unit_tests: intrinsic_functions_unit_tests FAILED") if (neutral_diffusion_unit_tests(verbose)) call MOM_error(FATAL, & "MOM_unit_tests: neutralDiffusionUnitTests FAILED") - if (diag_vkernels_unit_tests(verbose)) call MOM_error(FATAL, & - "MOM_unit_tests: diag_vkernels_unit_tests FAILED") if (random_unit_tests(verbose)) call MOM_error(FATAL, & "MOM_unit_tests: random_unit_tests FAILED") if (near_boundary_unit_tests(verbose)) call MOM_error(FATAL, & "MOM_unit_tests: near_boundary_unit_tests FAILED") if (CFC_cap_unit_tests(verbose)) call MOM_error(FATAL, & "MOM_unit_tests: CFC_cap_unit_tests FAILED") + if (mixedlayer_restrat_unit_tests(verbose)) call MOM_error(FATAL, & + "MOM_unit_tests: mixedlayer_restrat_unit_tests FAILED") + if (diag_buffer_unit_tests_2d(verbose)) call MOM_error(FATAL, & + "MOM_unit_tests: diag_buffer_unit_tests_2d FAILED") + if (diag_buffer_unit_tests_3d(verbose)) call MOM_error(FATAL, & + "MOM_unit_tests: diag_buffer_unit_tests_3d FAILED") endif end subroutine unit_tests diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 5de7ea7319..ec0363e357 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -1,11 +1,14 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Provides transparent structures with groups of MOM6 variables and supporting routines module MOM_variables -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_array_transform, only : rotate_array, rotate_vector use MOM_coupler_types, only : coupler_1d_bc_type, coupler_2d_bc_type use MOM_coupler_types, only : coupler_type_spawn, coupler_type_destructor, coupler_type_initialized +use MOM_coupler_types, only : coupler_type_copy_data use MOM_debugging, only : hchksum use MOM_domains, only : MOM_domain_type, get_domain_extent, group_pass_type use MOM_EOS, only : EOS_type @@ -13,6 +16,7 @@ module MOM_variables use MOM_grid, only : ocean_grid_type use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type +use MOM_tracer_types, only : tracer_type implicit none ; private @@ -29,22 +33,20 @@ module MOM_variables !> A structure for creating arrays of pointers to 3D arrays type, public :: p3d - real, dimension(:,:,:), pointer :: p => NULL() !< A pointer to a 3D array + real, dimension(:,:,:), pointer :: p => NULL() !< A pointer to a 3D array [various] end type p3d !> A structure for creating arrays of pointers to 2D arrays type, public :: p2d - real, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2D array + real, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2D array [various] end type p2d !> Pointers to various fields which may be used describe the surface state of MOM, and which -!! will be returned to a the calling program +!! will be returned to the calling program type, public :: surface real, allocatable, dimension(:,:) :: & - SST, & !< The sea surface temperature [degC]. - SSS, & !< The sea surface salinity [ppt ~> psu or gSalt/kg]. + SST, & !< The sea surface temperature [C ~> degC]. + SSS, & !< The sea surface salinity [S ~> psu or gSalt/kg]. sfc_density, & !< The mixed layer density [R ~> kg m-3]. - sfc_cfc11, & !< Sea surface concentration of CFC11 [mol kg-1]. - sfc_cfc12, & !< Sea surface concentration of CFC12 [mol kg-1]. Hml, & !< The mixed layer depth [Z ~> m]. u, & !< The mixed layer zonal velocity [L T-1 ~> m s-1]. v, & !< The mixed layer meridional velocity [L T-1 ~> m s-1]. @@ -55,20 +57,15 @@ module MOM_variables melt_potential, & !< Instantaneous amount of heat that can be used to melt sea ice [Q R Z ~> J m-2]. !! This is computed w.r.t. surface freezing temperature. ocean_mass, & !< The total mass of the ocean [R Z ~> kg m-2]. - ocean_heat, & !< The total heat content of the ocean in [degC R Z ~> degC kg m-2]. - ocean_salt, & !< The total salt content of the ocean in [kgSalt kg-1 R Z ~> kgSalt m-2]. + ocean_heat, & !< The total heat content of the ocean in [C R Z ~> degC kg m-2]. + ocean_salt, & !< The total salt content of the ocean in [1e-3 S R Z ~> kgSalt m-2]. taux_shelf, & !< The zonal stresses on the ocean under shelves [R L Z T-2 ~> Pa]. tauy_shelf, & !< The meridional stresses on the ocean under shelves [R L Z T-2 ~> Pa]. - TempxPmE, & !< The net inflow of water into the ocean times the temperature at which this - !! inflow occurs during the call to step_MOM [degC R Z ~> degC kg m-2]. - salt_deficit, & !< The salt needed to maintain the ocean column above a minimum - !! salinity over the call to step_MOM [kgSalt kg-1 R Z ~> kgSalt m-2]. - internal_heat !< Any internal or geothermal heat sources that are applied to the ocean - !! integrated over the call to step_MOM [degC R Z ~> degC kg m-2]. + fco2 !< CO2 flux from the ocean to the atmosphere [R Z T-1 ~> kgCO2 m-2 s-1] logical :: T_is_conT = .false. !< If true, the temperature variable SST is actually the - !! conservative temperature in [degC]. + !! conservative temperature in [C ~> degC]. logical :: S_is_absS = .false. !< If true, the salinity variable SSS is actually the - !! absolute salinity in [gSalt kg-1]. + !! absolute salinity in [S ~> gSalt kg-1]. type(coupler_2d_bc_type) :: tr_fields !< A structure that may contain an !! array of named fields describing tracer-related quantities. !### NOTE: ALL OF THE ARRAYS IN TR_FIELDS USE THE COUPLER'S INDEXING CONVENTION AND HAVE NO @@ -81,8 +78,8 @@ module MOM_variables !! potential temperature, salinity, heat capacity, and the equation of state control structure. type, public :: thermo_var_ptrs ! If allocated, the following variables have nz layers. - real, pointer :: T(:,:,:) => NULL() !< Potential temperature [degC]. - real, pointer :: S(:,:,:) => NULL() !< Salinity [PSU] or [gSalt/kg], generically [ppt]. + real, pointer :: T(:,:,:) => NULL() !< Potential temperature [C ~> degC]. + real, pointer :: S(:,:,:) => NULL() !< Salinity [PSU] or [gSalt/kg], generically [S ~> ppt]. real, pointer :: p_surf(:,:) => NULL() !< Ocean surface pressure used in equation of state !! calculations [R L2 T-2 ~> Pa] type(EOS_type), pointer :: eqn_of_state => NULL() !< Type that indicates the @@ -90,40 +87,47 @@ module MOM_variables real :: P_Ref !< The coordinate-density reference pressure [R L2 T-2 ~> Pa]. !! This is the pressure used to calculate Rml from !! T and S when eqn_of_state is associated. - real :: C_p !< The heat capacity of seawater [Q degC-1 ~> J degC-1 kg-1]. + real :: C_p !< The heat capacity of seawater [Q C-1 ~> J degC-1 kg-1]. !! When conservative temperature is used, this is !! constant and exactly 3991.86795711963 J degC-1 kg-1. logical :: T_is_conT = .false. !< If true, the temperature variable tv%T is - !! actually the conservative temperature [degC]. + !! actually the conservative temperature [C ~> degC]. logical :: S_is_absS = .false. !< If true, the salinity variable tv%S is - !! actually the absolute salinity in units of [gSalt kg-1]. - real :: min_salinity = 0.01 !< The minimum value of salinity when BOUND_SALINITY=True [ppt]. - !! The default is 0.01 for backward compatibility but should be 0. + !! actually the absolute salinity in units of [S ~> gSalt kg-1]. + real :: min_salinity !< The minimum value of salinity when BOUND_SALINITY=True [S ~> ppt]. + real, allocatable, dimension(:,:,:) :: SpV_avg + !< The layer averaged in situ specific volume [R-1 ~> m3 kg-1]. + integer :: valid_SpV_halo = -1 !< If positive, the valid halo size for SpV_avg, or if negative + !! SpV_avg is not currently set. + ! These arrays are accumulated fluxes for communication with other components. real, dimension(:,:), pointer :: frazil => NULL() !< The energy needed to heat the ocean column to the - !! freezing point since calculate_surface_state was2 + !! freezing point since calculate_surface_state was !! last called [Q Z R ~> J m-2]. + logical :: frazil_was_reset !< If true, frazil has not accumulated since it was last reset. real, dimension(:,:), pointer :: salt_deficit => NULL() !< The salt needed to maintain the ocean column !! at a minimum salinity of MIN_SALINITY since the last time - !! that calculate_surface_state was called, [ppt R Z ~> gSalt m-2]. + !! that calculate_surface_state was called, [S R Z ~> gSalt m-2]. real, dimension(:,:), pointer :: TempxPmE => NULL() !< The net inflow of water into the ocean times the !! temperature at which this inflow occurs since the - !! last call to calculate_surface_state [degC R Z ~> degC kg m-2]. + !! last call to calculate_surface_state [C R Z ~> degC kg m-2]. !! This should be prescribed in the forcing fields, but !! as it often is not, this is a useful heat budget diagnostic. real, dimension(:,:), pointer :: internal_heat => NULL() !< Any internal or geothermal heat sources that !! have been applied to the ocean since the last call to - !! calculate_surface_state [degC R Z ~> degC kg m-2]. + !! calculate_surface_state [C R Z ~> degC kg m-2]. ! The following variables are most normally not used but when they are they ! will be either set by parameterizations or prognostic. - real, pointer :: varT(:,:,:) => NULL() !< SGS variance of potential temperature [degC2]. - real, pointer :: varS(:,:,:) => NULL() !< SGS variance of salinity [ppt2]. + real, pointer :: varT(:,:,:) => NULL() !< SGS variance of potential temperature [C2 ~> degC2]. + real, pointer :: varS(:,:,:) => NULL() !< SGS variance of salinity [S2 ~> ppt2]. real, pointer :: covarTS(:,:,:) => NULL() !< SGS covariance of salinity and potential - !! temperature [degC ppt]. + !! temperature [C S ~> degC ppt]. + type(tracer_type), pointer :: tr_T => NULL() !< pointer to temp in tracer registry + type(tracer_type), pointer :: tr_S => NULL() !< pointer to salinty in tracer registry end type thermo_var_ptrs !> Pointers to all of the prognostic variables allocated in MOM_variables.F90 and MOM.F90. @@ -133,8 +137,8 @@ module MOM_variables !! they refer to in MOM.F90. type, public :: ocean_internal_state real, pointer, dimension(:,:,:) :: & - T => NULL(), & !< Pointer to the temperature state variable [degC] - S => NULL(), & !< Pointer to the salinity state variable [ppt ~> PSU or g/kg] + T => NULL(), & !< Pointer to the temperature state variable [C ~> degC] + S => NULL(), & !< Pointer to the salinity state variable [S ~> ppt] (i.e., PSU or g/kg) u => NULL(), & !< Pointer to the zonal velocity [L T-1 ~> m s-1] v => NULL(), & !< Pointer to the meridional velocity [L T-1 ~> m s-1] h => NULL() !< Pointer to the layer thicknesses [H ~> m or kg m-2] @@ -172,14 +176,24 @@ module MOM_variables PFv => NULL(), & !< Meridional acceleration due to pressure forces [L T-2 ~> m s-2] du_dt_visc => NULL(), &!< Zonal acceleration due to vertical viscosity [L T-2 ~> m s-2] dv_dt_visc => NULL(), &!< Meridional acceleration due to vertical viscosity [L T-2 ~> m s-2] + du_dt_visc_gl90 => NULL(), &!< Zonal acceleration due to GL90 vertical viscosity + ! (is included in du_dt_visc) [L T-2 ~> m s-2] + dv_dt_visc_gl90 => NULL(), &!< Meridional acceleration due to GL90 vertical viscosity + ! (is included in dv_dt_visc) [L T-2 ~> m s-2] du_dt_str => NULL(), & !< Zonal acceleration due to the surface stress (included !! in du_dt_visc) [L T-2 ~> m s-2] dv_dt_str => NULL(), & !< Meridional acceleration due to the surface stress (included !! in dv_dt_visc) [L T-2 ~> m s-2] - du_dt_dia => NULL(), & !< Zonal acceleration due to diapycnal mixing [L T-2 ~> m s-2] - dv_dt_dia => NULL(), & !< Meridional acceleration due to diapycnal mixing [L T-2 ~> m s-2] + du_dt_dia => NULL(), & !< Zonal acceleration due to diapycnal mixing [L T-2 ~> m s-2] + dv_dt_dia => NULL(), & !< Meridional acceleration due to diapycnal mixing [L T-2 ~> m s-2] u_accel_bt => NULL(), &!< Pointer to the zonal barotropic-solver acceleration [L T-2 ~> m s-2] - v_accel_bt => NULL() !< Pointer to the meridional barotropic-solver acceleration [L T-2 ~> m s-2] + v_accel_bt => NULL(), &!< Pointer to the meridional barotropic-solver acceleration [L T-2 ~> m s-2] + + ! sal_[uv] and tide_[uv] are 3D fields because of their baroclinic component in Boussinesq mode. + sal_u => NULL(), & !< Zonal acceleration due to self-attraction and loading [L T-2 ~> m s-2] + sal_v => NULL(), & !< Meridional acceleration due to self-attraction and loading [L T-2 ~> m s-2] + tides_u => NULL(), & !< Zonal acceleration due to astronomical tidal forcing [L T-2 ~> m s-2] + tides_v => NULL() !< Meridional acceleration due to astronomical tidal forcing [L T-2 ~> m s-2] real, pointer, dimension(:,:,:) :: du_other => NULL() !< Zonal velocity changes due to any other processes that are !! not due to any explicit accelerations [L T-1 ~> m s-1]. @@ -187,19 +201,39 @@ module MOM_variables !< Meridional velocity changes due to any other processes that are !! not due to any explicit accelerations [L T-1 ~> m s-1]. + ! Sub-terms of [uv]_accel_bt + real, pointer :: bt_pgf_u(:,:,:) => NULL() !< Zonal acceleration due to anomalous pressure gradient from + !! barotropic solver, a 3D component of u_accel_bt that includes both + !! PFuBT and the offset term for central differencing timestepping + !! [L T-2 ~> m s-2] + real, pointer :: bt_pgf_v(:,:,:) => NULL() !< Meridional acceleration due to anomalous pressure gradient from + !! barotropic solver, a 3D component of v_accel_bt that includes both + !! PFvBT and the offset term for central differencing timestepping + !! [L T-2 ~> m s-2] + real, pointer :: bt_cor_u(:,:) => NULL() !< Zonal acceleration due to anomalous Coriolis force from barotropic + !! solver, a 2D component of u_accel_bt [L T-2 ~> m s-2] + real, pointer :: bt_cor_v(:,:) => NULL() !< Meridional acceleration due to anomalous Coriolis force from barotropic + !! solver, a 2D component of v_accel_bt [L T-2 ~> m s-2] + real, pointer :: bt_lwd_u(:,:) => NULL() !< Zonal acceleration due to linear wave drag from barotropic solver, + !! a 2D component of u_accel_bt [L T-2 ~> m s-2] + real, pointer :: bt_lwd_v(:,:) => NULL() !< Meridional acceleration due to linear wave drag from barotropic solver, + !! a 2D component of v_accel_bt [L T-2 ~> m s-2] + ! These accelerations are sub-terms included in the accelerations above. real, pointer :: gradKEu(:,:,:) => NULL() !< gradKEu = - d/dx(u2) [L T-2 ~> m s-2] real, pointer :: gradKEv(:,:,:) => NULL() !< gradKEv = - d/dy(u2) [L T-2 ~> m s-2] real, pointer :: rv_x_v(:,:,:) => NULL() !< rv_x_v = rv * v at u [L T-2 ~> m s-2] real, pointer :: rv_x_u(:,:,:) => NULL() !< rv_x_u = rv * u at v [L T-2 ~> m s-2] - real, pointer :: diag_hfrac_u(:,:,:) => NULL() !< Fractional layer thickness at u points - real, pointer :: diag_hfrac_v(:,:,:) => NULL() !< Fractional layer thickness at v points - real, pointer :: diag_hu(:,:,:) => NULL() !< layer thickness at u points - real, pointer :: diag_hv(:,:,:) => NULL() !< layer thickness at v points + real, pointer :: diag_hfrac_u(:,:,:) => NULL() !< Fractional layer thickness at u points [nondim] + real, pointer :: diag_hfrac_v(:,:,:) => NULL() !< Fractional layer thickness at v points [nondim] + real, pointer :: diag_hu(:,:,:) => NULL() !< layer thickness at u points, modulated by the viscous + !! remnant and fractional open areas [H ~> m or kg m-2] + real, pointer :: diag_hv(:,:,:) => NULL() !< layer thickness at v points, modulated by the viscous + !! remnant and fractional open areas [H ~> m or kg m-2] - real, pointer :: visc_rem_u(:,:,:) => NULL() !< viscous remnant at u points - real, pointer :: visc_rem_v(:,:,:) => NULL() !< viscous remnant at v points + real, pointer :: visc_rem_u(:,:,:) => NULL() !< viscous remnant at u points [nondim] + real, pointer :: visc_rem_v(:,:,:) => NULL() !< viscous remnant at v points [nondim] end type accel_diag_ptrs @@ -210,6 +244,8 @@ module MOM_variables real, pointer, dimension(:,:,:) :: & uh => NULL(), & !< Resolved zonal layer thickness fluxes, [H L2 T-1 ~> m3 s-1 or kg s-1] vh => NULL(), & !< Resolved meridional layer thickness fluxes, [H L2 T-1 ~> m3 s-1 or kg s-1] + uh_smooth => NULL(), & !< Interface height smoothing induced zonal volume fluxes [H L2 T-1 ~> m3 s-1 or kg s-1] + vh_smooth => NULL(), & !< Interface height smoothing induced meridional volume fluxes [H L2 T-1 ~> m3 s-1 or kg s-1] uhGM => NULL(), & !< Isopycnal height diffusion induced zonal volume fluxes [H L2 T-1 ~> m3 s-1 or kg s-1] vhGM => NULL() !< Isopycnal height diffusion induced meridional volume fluxes [H L2 T-1 ~> m3 s-1 or kg s-1] @@ -220,53 +256,57 @@ module MOM_variables !> Vertical viscosities, drag coefficients, and related fields. type, public :: vertvisc_type - real :: Prandtl_turb !< The Prandtl number for the turbulent diffusion - !! that is captured in Kd_shear [nondim]. - real, pointer, dimension(:,:) :: & - bbl_thick_u => NULL(), & !< The bottom boundary layer thickness at the u-points [Z ~> m]. - bbl_thick_v => NULL(), & !< The bottom boundary layer thickness at the v-points [Z ~> m]. - kv_bbl_u => NULL(), & !< The bottom boundary layer viscosity at the u-points [Z2 T-1 ~> m2 s-1]. - kv_bbl_v => NULL(), & !< The bottom boundary layer viscosity at the v-points [Z2 T-1 ~> m2 s-1]. - ustar_BBL => NULL() !< The turbulence velocity in the bottom boundary layer at h points [Z T-1 ~> m s-1]. - real, pointer, dimension(:,:) :: TKE_BBL => NULL() - !< A term related to the bottom boundary layer source of turbulent kinetic - !! energy, currently in [Z3 T-3 ~> m3 s-3], but may at some time be changed - !! to [R Z3 T-3 ~> W m-2]. - real, pointer, dimension(:,:) :: & - taux_shelf => NULL(), & !< The zonal stresses on the ocean under shelves [R Z L T-2 ~> Pa]. - tauy_shelf => NULL() !< The meridional stresses on the ocean under shelves [R Z L T-2 ~> Pa]. - real, pointer, dimension(:,:) :: tbl_thick_shelf_u => NULL() + real, allocatable, dimension(:,:) :: & + bbl_thick_u, & !< The bottom boundary layer thickness at the u-points [Z ~> m]. + bbl_thick_v, & !< The bottom boundary layer thickness at the v-points [Z ~> m]. + kv_bbl_u, & !< The bottom boundary layer viscosity at the u-points [H Z T-1 ~> m2 s-1 or Pa s] + kv_bbl_v, & !< The bottom boundary layer viscosity at the v-points [H Z T-1 ~> m2 s-1 or Pa s] + ustar_BBL, & !< The turbulence velocity in the bottom boundary layer at + !! h points [H T-1 ~> m s-1 or kg m-2 s-1]. + BBL_meanKE_loss, & !< The viscous loss of mean kinetic energy in the bottom boundary layer + !! [H L2 T-3 ~> m3 s-3 or W m-2]. + BBL_meanKE_loss_sqrtCd, & !< The viscous loss of mean kinetic energy in the bottom boundary layer + !! divided by the square root of the drag coefficient [H L2 T-3 ~> m3 s-3 or W m-2]. + !! This is being set only to retain old answers, and should be phased out. + taux_shelf, & !< The zonal stresses on the ocean under shelves [R Z L T-2 ~> Pa]. + tauy_shelf !< The meridional stresses on the ocean under shelves [R Z L T-2 ~> Pa]. + real, allocatable, dimension(:,:) :: tbl_thick_shelf_u !< Thickness of the viscous top boundary layer under ice shelves at u-points [Z ~> m]. - real, pointer, dimension(:,:) :: tbl_thick_shelf_v => NULL() + real, allocatable, dimension(:,:) :: tbl_thick_shelf_v !< Thickness of the viscous top boundary layer under ice shelves at v-points [Z ~> m]. - real, pointer, dimension(:,:) :: kv_tbl_shelf_u => NULL() - !< Viscosity in the viscous top boundary layer under ice shelves at u-points [Z2 T-1 ~> m2 s-1]. - real, pointer, dimension(:,:) :: kv_tbl_shelf_v => NULL() - !< Viscosity in the viscous top boundary layer under ice shelves at v-points [Z2 T-1 ~> m2 s-1]. - real, pointer, dimension(:,:) :: nkml_visc_u => NULL() + real, allocatable, dimension(:,:) :: kv_tbl_shelf_u + !< Viscosity in the viscous top boundary layer under ice shelves at + !! u-points [H Z T-1 ~> m2 s-1 or Pa s] + real, allocatable, dimension(:,:) :: kv_tbl_shelf_v + !< Viscosity in the viscous top boundary layer under ice shelves at + !! v-points [H Z T-1 ~> m2 s-1 or Pa s] + real, allocatable, dimension(:,:) :: nkml_visc_u !< The number of layers in the viscous surface mixed layer at u-points [nondim]. !! This is not an integer because there may be fractional layers, and it is stored in !! terms of layers, not depth, to facilitate the movement of the viscous boundary layer !! with the flow. - real, pointer, dimension(:,:) :: nkml_visc_v => NULL() + real, allocatable, dimension(:,:) :: nkml_visc_v !< The number of layers in the viscous surface mixed layer at v-points [nondim]. - real, pointer, dimension(:,:) :: & - MLD => NULL() !< Instantaneous active mixing layer depth [Z ~> m]. - real, pointer, dimension(:,:,:) :: & - Ray_u => NULL(), & !< The Rayleigh drag velocity to be applied to each layer at u-points [Z T-1 ~> m s-1]. - Ray_v => NULL() !< The Rayleigh drag velocity to be applied to each layer at v-points [Z T-1 ~> m s-1]. + real, allocatable, dimension(:,:,:) :: & + Ray_u, & !< The Rayleigh drag velocity to be applied to each layer at u-points [H T-1 ~> m s-1 or Pa s m-1]. + Ray_v !< The Rayleigh drag velocity to be applied to each layer at v-points [H T-1 ~> m s-1 or Pa s m-1]. + + ! The following elements are pointers so they can be used as targets for pointers in the restart registry. + real, pointer, dimension(:,:) :: MLD => NULL() !< Instantaneous active mixing layer depth [Z ~> m]. + real, pointer, dimension(:,:) :: h_ML => NULL() !< Instantaneous active mixing layer thickness [H ~> m or kg m-2]. + real, pointer, dimension(:,:) :: sfc_buoy_flx => NULL() !< Surface buoyancy flux (derived) [Z2 T-3 ~> m2 s-3]. real, pointer, dimension(:,:,:) :: Kd_shear => NULL() !< The shear-driven turbulent diapycnal diffusivity at the interfaces between layers - !! in tracer columns [Z2 T-1 ~> m2 s-1]. + !! in tracer columns [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, pointer, dimension(:,:,:) :: Kv_shear => NULL() !< The shear-driven turbulent vertical viscosity at the interfaces between layers - !! in tracer columns [Z2 T-1 ~> m2 s-1]. + !! in tracer columns [H Z T-1 ~> m2 s-1 or Pa s] real, pointer, dimension(:,:,:) :: Kv_shear_Bu => NULL() !< The shear-driven turbulent vertical viscosity at the interfaces between layers in - !! corner columns [Z2 T-1 ~> m2 s-1]. + !! corner columns [H Z T-1 ~> m2 s-1 or Pa s] real, pointer, dimension(:,:,:) :: Kv_slow => NULL() !< The turbulent vertical viscosity component due to "slow" processes (e.g., tidal, - !! background, convection etc) [Z2 T-1 ~> m2 s-1]. + !! background, convection etc) [H Z T-1 ~> m2 s-1 or Pa s] real, pointer, dimension(:,:,:) :: TKE_turb => NULL() !< The turbulent kinetic energy per unit mass at the interfaces [Z2 T-2 ~> m2 s-2]. !! This may be at the tracer or corner points @@ -283,10 +323,10 @@ module MOM_variables !! drawing from nearby to the west [H L ~> m2 or kg m-1]. real, allocatable :: FA_u_WW(:,:) !< The effective open face area for zonal barotropic transport !! drawing from locations far to the west [H L ~> m2 or kg m-1]. - real, allocatable :: uBT_WW(:,:) !< uBT_WW is the barotropic velocity [L T-1 ~> m s-1], beyond which the marginal - !! open face area is FA_u_WW. uBT_WW must be non-negative. - real, allocatable :: uBT_EE(:,:) !< uBT_EE is a barotropic velocity [L T-1 ~> m s-1], beyond which the marginal - !! open face area is FA_u_EE. uBT_EE must be non-positive. + real, allocatable :: uBT_WW(:,:) !< uBT_WW is the barotropic velocity [L T-1 ~> m s-1], beyond which the + !! marginal open face area is FA_u_WW. uBT_WW must be non-negative. + real, allocatable :: uBT_EE(:,:) !< uBT_EE is a barotropic velocity [L T-1 ~> m s-1], beyond which the + !! marginal open face area is FA_u_EE. uBT_EE must be non-positive. real, allocatable :: FA_v_NN(:,:) !< The effective open face area for meridional barotropic transport !! drawing from locations far to the north [H L ~> m2 or kg m-1]. real, allocatable :: FA_v_N0(:,:) !< The effective open face area for meridional barotropic transport @@ -295,25 +335,31 @@ module MOM_variables !! drawing from nearby to the south [H L ~> m2 or kg m-1]. real, allocatable :: FA_v_SS(:,:) !< The effective open face area for meridional barotropic transport !! drawing from locations far to the south [H L ~> m2 or kg m-1]. - real, allocatable :: vBT_SS(:,:) !< vBT_SS is the barotropic velocity, [L T-1 ~> m s-1], beyond which the marginal - !! open face area is FA_v_SS. vBT_SS must be non-negative. - real, allocatable :: vBT_NN(:,:) !< vBT_NN is the barotropic velocity, [L T-1 ~> m s-1], beyond which the marginal - !! open face area is FA_v_NN. vBT_NN must be non-positive. - real, allocatable :: h_u(:,:,:) !< An effective thickness at zonal faces [H ~> m or kg m-2]. - real, allocatable :: h_v(:,:,:) !< An effective thickness at meridional faces [H ~> m or kg m-2]. + real, allocatable :: vBT_SS(:,:) !< vBT_SS is the barotropic velocity, [L T-1 ~> m s-1], beyond which the + !! marginal open face area is FA_v_SS. vBT_SS must be non-negative. + real, allocatable :: vBT_NN(:,:) !< vBT_NN is the barotropic velocity, [L T-1 ~> m s-1], beyond which the + !! marginal open face area is FA_v_NN. vBT_NN must be non-positive. + real, allocatable :: h_u(:,:,:) !< An effective thickness at zonal faces, taking into account the effects + !! of vertical viscosity and fractional open areas [H ~> m or kg m-2]. + !! This is primarily used as a non-normalized weight in determining + !! the depth averaged accelerations for the barotropic solver. + real, allocatable :: h_v(:,:,:) !< An effective thickness at meridional faces, taking into account the effects + !! of vertical viscosity and fractional open areas [H ~> m or kg m-2]. + !! This is primarily used as a non-normalized weight in determining + !! the depth averaged accelerations for the barotropic solver. type(group_pass_type) :: pass_polarity_BT !< Structure for polarity group halo updates type(group_pass_type) :: pass_FA_uv !< Structure for face area group halo updates end type BT_cont_type - -!> pointers to grids modifying cell metric at porous barriers -type, public :: porous_barrier_ptrs - real, pointer, dimension(:,:,:) :: por_face_areaU => NULL() !< fractional open area of U-faces [nondim] - real, pointer, dimension(:,:,:) :: por_face_areaV => NULL() !< fractional open area of V-faces [nondim] - real, pointer, dimension(:,:,:) :: por_layer_widthU => NULL() !< fractional open width of U-faces [nondim] - real, pointer, dimension(:,:,:) :: por_layer_widthV => NULL() !< fractional open width of V-faces [nondim] -end type porous_barrier_ptrs - +!> Container for grids modifying cell metric at porous barriers +type, public :: porous_barrier_type + ! Each of the following fields has nz layers. + real, allocatable :: por_face_areaU(:,:,:) !< fractional open area of U-faces [nondim] + real, allocatable :: por_face_areaV(:,:,:) !< fractional open area of V-faces [nondim] + ! Each of the following fields is found at nz+1 interfaces. + real, allocatable :: por_layer_widthU(:,:,:) !< fractional open width of U-faces [nondim] + real, allocatable :: por_layer_widthV(:,:,:) !< fractional open width of V-faces [nondim] +end type porous_barrier_type contains @@ -321,40 +367,51 @@ module MOM_variables !! the ocean model. Unused fields are unallocated. subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & gas_fields_ocn, use_meltpot, use_iceshelves, & - omit_frazil, use_cfcs) + omit_frazil, sfc_state_in, turns, use_marbl_tracers) type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(surface), intent(inout) :: sfc_state !< ocean surface state type to be allocated. logical, optional, intent(in) :: use_temperature !< If true, allocate the space for thermodynamic variables. logical, optional, intent(in) :: do_integrals !< If true, allocate the space for vertically !! integrated fields. type(coupler_1d_bc_type), & - optional, intent(in) :: gas_fields_ocn !< If present, this type describes the ocean + optional, intent(in) :: gas_fields_ocn !< If present, this type describes the !! ocean and surface-ice fields that will participate !! in the calculation of additional gas or other !! tracer fluxes, and can be used to spawn related !! internal variables in the ice model. logical, optional, intent(in) :: use_meltpot !< If true, allocate the space for melt potential - logical, optional, intent(in) :: use_cfcs !< If true, allocate the space for cfcs logical, optional, intent(in) :: use_iceshelves !< If true, allocate the space for the stresses !! under ice shelves. logical, optional, intent(in) :: omit_frazil !< If present and false, do not allocate the space to !! pass frazil fluxes to the coupler + type(surface), & + optional, intent(in) :: sfc_state_in !< If present and its tr_fields are initialized, + !! this type describes the ocean and surface-ice fields that + !! will participate in the calculation of additional gas or + !! other tracer fluxes, and can be used to spawn related + !! internal variables in the ice model. If gas_fields_ocn + !! is present, it is used and tr_fields_in is ignored. + integer, optional, intent(in) :: turns !< If present, the number of counterclockwise quarter + !! turns to use on the new grid. + logical, optional, intent(in) :: use_marbl_tracers !< If true, allocate the space for CO2 flux from MARBL ! local variables - logical :: use_temp, alloc_integ, use_melt_potential, alloc_iceshelves, alloc_frazil, alloc_cfcs + logical :: use_temp, alloc_integ, use_melt_potential, alloc_iceshelves, alloc_frazil, alloc_fco2 + logical :: even_turns ! True if turns is absent or even + integer :: tr_field_i_mem(4), tr_field_j_mem(4) integer :: is, ie, js, je, isd, ied, jsd, jed integer :: isdB, iedB, jsdB, jedB is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - isdB = G%isdB ; iedB = G%iedB; jsdB = G%jsdB ; jedB = G%jedB + isdB = G%isdB ; iedB = G%iedB ; jsdB = G%jsdB ; jedB = G%jedB use_temp = .true. ; if (present(use_temperature)) use_temp = use_temperature alloc_integ = .true. ; if (present(do_integrals)) alloc_integ = do_integrals use_melt_potential = .false. ; if (present(use_meltpot)) use_melt_potential = use_meltpot - alloc_cfcs = .false. ; if (present(use_cfcs)) alloc_cfcs = use_cfcs alloc_iceshelves = .false. ; if (present(use_iceshelves)) alloc_iceshelves = use_iceshelves alloc_frazil = .true. ; if (present(omit_frazil)) alloc_frazil = .not.omit_frazil + alloc_fco2 = .false. ; if (present(use_marbl_tracers)) alloc_fco2 = use_marbl_tracers if (sfc_state%arrays_allocated) return @@ -376,20 +433,12 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & allocate(sfc_state%melt_potential(isd:ied,jsd:jed), source=0.0) endif - if (alloc_cfcs) then - allocate(sfc_state%sfc_cfc11(isd:ied,jsd:jed), source=0.0) - allocate(sfc_state%sfc_cfc12(isd:ied,jsd:jed), source=0.0) - endif - if (alloc_integ) then ! Allocate structures for the vertically integrated ocean_mass, ocean_heat, and ocean_salt. allocate(sfc_state%ocean_mass(isd:ied,jsd:jed), source=0.0) if (use_temp) then allocate(sfc_state%ocean_heat(isd:ied,jsd:jed), source=0.0) allocate(sfc_state%ocean_salt(isd:ied,jsd:jed), source=0.0) - allocate(sfc_state%TempxPmE(isd:ied,jsd:jed), source=0.0) - allocate(sfc_state%salt_deficit(isd:ied,jsd:jed), source=0.0) - allocate(sfc_state%internal_heat(isd:ied,jsd:jed), source=0.0) endif endif @@ -398,9 +447,26 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & allocate(sfc_state%tauy_shelf(isd:ied,JsdB:JedB), source=0.0) endif - if (present(gas_fields_ocn)) & + ! The data fields in the coupler_2d_bc_type are never rotated. + even_turns = .true. ; if (present(turns)) even_turns = (modulo(turns, 2) == 0) + if (even_turns) then + tr_field_i_mem(1:4) = (/is,is,ie,ie/) ; tr_field_j_mem(1:4) = (/js,js,je,je/) + else + tr_field_i_mem(1:4) = (/js,js,je,je/) ; tr_field_j_mem(1:4) = (/is,is,ie,ie/) + endif + if (present(gas_fields_ocn)) then call coupler_type_spawn(gas_fields_ocn, sfc_state%tr_fields, & - (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) + tr_field_i_mem, tr_field_j_mem, as_needed=.true.) + elseif (present(sfc_state_in)) then + if (coupler_type_initialized(sfc_state_in%tr_fields)) then + call coupler_type_spawn(sfc_state_in%tr_fields, sfc_state%tr_fields, & + tr_field_i_mem, tr_field_j_mem, as_needed=.true.) + endif + endif + + if (alloc_fco2) then + allocate(sfc_state%fco2(isd:ied,jsd:jed), source=0.0) + endif sfc_state%arrays_allocated = .true. @@ -423,9 +489,7 @@ subroutine deallocate_surface_state(sfc_state) if (allocated(sfc_state%ocean_mass)) deallocate(sfc_state%ocean_mass) if (allocated(sfc_state%ocean_heat)) deallocate(sfc_state%ocean_heat) if (allocated(sfc_state%ocean_salt)) deallocate(sfc_state%ocean_salt) - if (allocated(sfc_state%salt_deficit)) deallocate(sfc_state%salt_deficit) - if (allocated(sfc_state%sfc_cfc11)) deallocate(sfc_state%sfc_cfc11) - if (allocated(sfc_state%sfc_cfc12)) deallocate(sfc_state%sfc_cfc12) + if (allocated(sfc_state%fco2)) deallocate(sfc_state%fco2) call coupler_type_destructor(sfc_state%tr_fields) sfc_state%arrays_allocated = .false. @@ -433,12 +497,11 @@ subroutine deallocate_surface_state(sfc_state) end subroutine deallocate_surface_state !> Rotate the surface state fields from the input to the model indices. -subroutine rotate_surface_state(sfc_state_in, G_in, sfc_state, G, turns) - type(surface), intent(in) :: sfc_state_in - type(ocean_grid_type), intent(in) :: G_in - type(surface), intent(inout) :: sfc_state - type(ocean_grid_type), intent(in) :: G - integer, intent(in) :: turns +subroutine rotate_surface_state(sfc_state_in, sfc_state, G, turns) + type(surface), intent(in) :: sfc_state_in !< The input unrotated surface state type that is the data source. + type(surface), intent(inout) :: sfc_state !< The rotated surface state type whose arrays will be filled in + type(ocean_grid_type), intent(in) :: G !< The ocean grid structure + integer, intent(in) :: turns !< The number of counterclockwise quarter turns to use on the rotated grid. logical :: use_temperature, do_integrals, use_melt_potential, use_iceshelves @@ -451,13 +514,9 @@ subroutine rotate_surface_state(sfc_state_in, G_in, sfc_state, G, turns) .and. allocated(sfc_state_in%tauy_shelf) if (.not. sfc_state%arrays_allocated) then - call allocate_surface_state(sfc_state, G, & - use_temperature=use_temperature, & - do_integrals=do_integrals, & - use_meltpot=use_melt_potential, & - use_iceshelves=use_iceshelves & - ) - sfc_state%arrays_allocated = .true. + call allocate_surface_state(sfc_state, G, use_temperature=use_temperature, & + do_integrals=do_integrals, use_meltpot=use_melt_potential, & + use_iceshelves=use_iceshelves, sfc_state_in=sfc_state_in, turns=turns) endif if (use_temperature) then @@ -482,8 +541,6 @@ subroutine rotate_surface_state(sfc_state_in, G_in, sfc_state, G, turns) call rotate_array(sfc_state_in%ocean_heat, turns, sfc_state%ocean_heat) call rotate_array(sfc_state_in%ocean_salt, turns, sfc_state%ocean_salt) call rotate_array(sfc_state_in%SSS, turns, sfc_state%SSS) - call rotate_array(sfc_state_in%salt_deficit, turns, sfc_state%salt_deficit) - call rotate_array(sfc_state_in%internal_heat, turns, sfc_state%internal_heat) endif endif @@ -499,9 +556,11 @@ subroutine rotate_surface_state(sfc_state_in, G_in, sfc_state, G, turns) sfc_state%T_is_conT = sfc_state_in%T_is_conT sfc_state%S_is_absS = sfc_state_in%S_is_absS - ! TODO: tracer field rotation - if (coupler_type_initialized(sfc_state_in%tr_fields)) & - call MOM_error(FATAL, "Rotation of surface state tracers is not yet implemented.") + ! NOTE: Tracer fields are handled by FMS, so are left unrotated. Any + ! reads/writes to tr_fields must be appropriately rotated. + if (coupler_type_initialized(sfc_state_in%tr_fields)) then + call coupler_type_copy_data(sfc_state_in%tr_fields, sfc_state%tr_fields) + endif end subroutine rotate_surface_state !> Allocates the arrays contained within a BT_cont_type and initializes them to 0. @@ -573,15 +632,15 @@ subroutine MOM_thermovar_chksum(mesg, tv, G, US) ! counts, there must be no redundant points, so all variables use is..ie ! and js...je as their extent. if (associated(tv%T)) & - call hchksum(tv%T, mesg//" tv%T", G%HI) + call hchksum(tv%T, mesg//" tv%T", G%HI, unscale=US%C_to_degC) if (associated(tv%S)) & - call hchksum(tv%S, mesg//" tv%S", G%HI) + call hchksum(tv%S, mesg//" tv%S", G%HI, unscale=US%S_to_ppt) if (associated(tv%frazil)) & - call hchksum(tv%frazil, mesg//" tv%frazil", G%HI, scale=US%Q_to_J_kg*US%RZ_to_kg_m2) + call hchksum(tv%frazil, mesg//" tv%frazil", G%HI, unscale=US%Q_to_J_kg*US%RZ_to_kg_m2) if (associated(tv%salt_deficit)) & - call hchksum(tv%salt_deficit, mesg//" tv%salt_deficit", G%HI, scale=US%RZ_to_kg_m2) + call hchksum(tv%salt_deficit, mesg//" tv%salt_deficit", G%HI, unscale=US%RZ_to_kg_m2*US%S_to_ppt) if (associated(tv%TempxPmE)) & - call hchksum(tv%TempxPmE, mesg//" tv%TempxPmE", G%HI, scale=US%RZ_to_kg_m2) + call hchksum(tv%TempxPmE, mesg//" tv%TempxPmE", G%HI, unscale=US%RZ_to_kg_m2*US%C_to_degC) end subroutine MOM_thermovar_chksum end module MOM_variables diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index b856cff3dc..ef6d9d8eb0 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Provides a transparent vertical ocean grid type and supporting routines module MOM_verticalGrid -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_unit_scaling, only : unit_scale_type @@ -12,7 +14,7 @@ module MOM_verticalGrid #include public verticalGridInit, verticalGridEnd -public setVerticalGridAxes, fix_restart_scaling +public setVerticalGridAxes public get_flux_units, get_thickness_units, get_tr_flux_units ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional @@ -26,8 +28,9 @@ module MOM_verticalGrid ! Commonly used parameters integer :: ke !< The number of layers/levels in the vertical real :: max_depth !< The maximum depth of the ocean [Z ~> m]. - real :: mks_g_Earth !< The gravitational acceleration in unscaled MKS units [m s-2]. +! real :: mks_g_Earth !< The gravitational acceleration in unscaled MKS units [m s-2]. This might not be used. real :: g_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. + real :: g_Earth_Z_T2 !< The gravitational acceleration in alternatively rescaled units [Z T-2 ~> m s-2] real :: Rho0 !< The density used in the Boussinesq approximation or nominal !! density used to convert depths into mass units [R ~> kg m-3]. @@ -35,18 +38,28 @@ module MOM_verticalGrid character(len=40) :: zAxisUnits !< The units that vertical coordinates are written in character(len=40) :: zAxisLongName !< Coordinate name to appear in files, !! e.g. "Target Potential Density" or "Height" - real, allocatable, dimension(:) :: sLayer !< Coordinate values of layer centers - real, allocatable, dimension(:) :: sInterface !< Coordinate values on interfaces + real, allocatable, dimension(:) :: sLayer !< Coordinate values of layer centers, in unscaled + !! units that depend on the vertical coordinate, such as [kg m-3] for an + !! isopycnal or some hybrid coordinates, [m] for a Z* coordinate, + !! or [nondim] for a sigma coordinate. + real, allocatable, dimension(:) :: sInterface !< Coordinate values on interfaces, in the same + !! unscale units as sLayer [various]. integer :: direction = 1 !< Direction defaults to 1, positive up. ! The following variables give information about the vertical grid. logical :: Boussinesq !< If true, make the Boussinesq approximation. + logical :: semi_Boussinesq !< If true, do non-Boussinesq pressure force calculations and + !! use mass-based "thicknesses, but use Rho0 to convert layer thicknesses + !! into certain height changes. This only applies if BOUSSINESQ is false. real :: Angstrom_H !< A one-Angstrom thickness in the model thickness units [H ~> m or kg m-2]. real :: Angstrom_Z !< A one-Angstrom thickness in the model depth units [Z ~> m]. real :: Angstrom_m !< A one-Angstrom thickness [m]. real :: H_subroundoff !< A thickness that is so small that it can be added to a thickness of !! Angstrom or larger without changing it at the bit level [H ~> m or kg m-2]. !! If Angstrom is 0 or exceedingly small, this is negligible compared to 1e-17 m. + real :: dZ_subroundoff !< A thickness in height units that is so small that it can be added to a + !! vertical distance of Angstrom_Z or 1e-17 m without changing it at the bit + !! level [Z ~> m]. This is the height equivalent of H_subroundoff. real, allocatable, dimension(:) :: & g_prime, & !< The reduced gravity at each interface [L2 Z-1 T-2 ~> m s-2]. Rlay !< The target coordinate value (potential density) in each layer [R ~> kg m-3]. @@ -63,7 +76,7 @@ module MOM_verticalGrid real :: H_to_m !< A constant that translates distances in the units of thickness !! to m [m H-1 ~> 1 or m3 kg-1]. real :: H_to_Pa !< A constant that translates the units of thickness to pressure - !! [Pa H-1 = kg m-1 s-2 H-1 ~> kg m-2 s-2 or m s-2]. + !! [Pa H-1 ~> kg m-2 s-2 or m s-2]. real :: H_to_Z !< A constant that translates thickness units to the units of !! depth [Z H-1 ~> 1 or m3 kg-1]. real :: Z_to_H !< A constant that translates depth units to thickness units @@ -74,8 +87,17 @@ module MOM_verticalGrid !! thickness units [H R-1 Z-1 ~> m3 kg-2 or 1]. real :: H_to_MKS !< A constant that translates thickness units to its MKS unit !! (m or kg m-2) based on GV%Boussinesq [m H-1 ~> 1] or [kg m-2 H-1 ~> 1] + real :: m2_s_to_HZ_T !< The combination of conversion factors that converts kinematic viscosities + !! in m2 s-1 to the internal units of the kinematic (in Boussinesq mode) + !! or dynamic viscosity [H Z s T-1 m-2 ~> 1 or kg m-3] + real :: HZ_T_to_m2_s !< The combination of conversion factors that converts the viscosities from + !! their internal representation into a kinematic viscosity in m2 s-1 + !! [T m2 H-1 Z-1 s-1 ~> 1 or m3 kg-1] + real :: HZ_T_to_MKS !< The combination of conversion factors that converts the viscosities from + !! their internal representation into their unnscaled MKS units + !! (m2 s-1 or Pa s), depending on whether the model is Boussinesq + !! [T m2 H-1 Z-1 s-1 ~> 1] or [T Pa s H-1 Z-1 ~> 1] - real :: m_to_H_restart = 0.0 !< A copy of the m_to_H that is used in restart files. end type verticalGrid_type contains @@ -91,6 +113,8 @@ subroutine verticalGridInit( param_file, GV, US ) ! Local variables integer :: nk, H_power real :: H_rescale_factor ! The integer power of 2 by which thicknesses are rescaled [nondim] + real :: rho_Kv ! The density used convert input kinematic viscosities into dynamic viscosities + ! when in non-Boussinesq mode [R ~> kg m-3] ! This include declares and sets the variable "version". # include "version_variable.h" character(len=16) :: mdl = 'MOM_verticalGrid' @@ -105,18 +129,33 @@ subroutine verticalGridInit( param_file, GV, US ) log_to_all=.true., debugging=.true.) call get_param(param_file, mdl, "G_EARTH", GV%g_Earth, & "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80, scale=US%Z_to_m*US%m_s_to_L_T**2) + units="m s-2", default=9.80, scale=US%Z_to_m*US%m_s_to_L_T**2) call get_param(param_file, mdl, "RHO_0", GV%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& + "properties, or with BOUSSINESQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "BOUSSINESQ", GV%Boussinesq, & "If true, make the Boussinesq approximation.", default=.true.) - call get_param(param_file, mdl, "ANGSTROM", GV%Angstrom_m, & + call get_param(param_file, mdl, "SEMI_BOUSSINESQ", GV%semi_Boussinesq, & + "If true, do non-Boussinesq pressure force calculations and use mass-based "//& + "thicknesses, but use RHO_0 to convert layer thicknesses into certain "//& + "height changes. This only applies if BOUSSINESQ is false.", & + default=.true., do_not_log=GV%Boussinesq) + if (GV%Boussinesq) GV%semi_Boussinesq = .true. + call get_param(param_file, mdl, "RHO_KV_CONVERT", Rho_Kv, & + "The density used to convert input vertical distances into thickesses in "//& + "non-BOUSSINESQ mode, and to convert kinematic viscosities into dynamic "//& + "viscosities and similarly for vertical diffusivities. GV%m_to_H is set "//& + "using this value, whereas GV%Z_to_H is set using RHO_0. The default is "//& + "RHO_0, but this can be set separately to demonstrate the independence of the "//& + "non-Boussinesq solutions of the value of RHO_0.", & + units="kg m-3", default=GV%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=GV%Boussinesq) + call get_param(param_file, mdl, "ANGSTROM", GV%Angstrom_Z, & "The minimum layer thickness, usually one-Angstrom.", & - units="m", default=1.0e-10) + units="m", default=1.0e-10, scale=US%m_to_Z) call get_param(param_file, mdl, "H_RESCALE_POWER", H_power, & "An integer power of 2 that is used to rescale the model's "//& "intenal units of thickness. Valid values range from -300 to 300.", & @@ -137,12 +176,13 @@ subroutine verticalGridInit( param_file, GV, US ) "units of thickness into m.", units="m H-1", default=1.0) GV%H_to_m = GV%H_to_m * H_rescale_factor endif - GV%mks_g_Earth = US%L_T_to_m_s**2*US%m_to_Z * GV%g_Earth + ! This is not used: GV%mks_g_Earth = US%L_T_to_m_s**2*US%m_to_Z * GV%g_Earth + GV%g_Earth_Z_T2 = US%L_to_Z**2 * GV%g_Earth ! This would result from scale=US%m_to_Z*US%T_to_s**2. #ifdef STATIC_MEMORY_ ! Here NK_ is a macro, while nk is a variable. call get_param(param_file, mdl, "NK", nk, & "The number of model layers.", units="nondim", & - static_value=NK_) + default=NK_) if (nk /= NK_) call MOM_error(FATAL, "verticalGridInit: " // & "Mismatched number of layers NK_ between MOM_memory.h and param_file") @@ -156,29 +196,48 @@ subroutine verticalGridInit( param_file, GV, US ) GV%H_to_kg_m2 = US%R_to_kg_m3*GV%Rho0 * GV%H_to_m GV%kg_m2_to_H = 1.0 / GV%H_to_kg_m2 GV%m_to_H = 1.0 / GV%H_to_m - GV%Angstrom_H = GV%m_to_H * GV%Angstrom_m GV%H_to_MKS = GV%H_to_m + GV%m2_s_to_HZ_T = GV%m_to_H * US%m_to_Z * US%T_to_s + + GV%H_to_Z = GV%H_to_m * US%m_to_Z + GV%Z_to_H = US%Z_to_m * GV%m_to_H else GV%kg_m2_to_H = 1.0 / GV%H_to_kg_m2 - GV%m_to_H = US%R_to_kg_m3*GV%Rho0 * GV%kg_m2_to_H - GV%H_to_m = GV%H_to_kg_m2 / (US%R_to_kg_m3*GV%Rho0) - GV%Angstrom_H = GV%Angstrom_m*1000.0*GV%kg_m2_to_H + ! GV%m_to_H = US%R_to_kg_m3*GV%Rho0 * GV%kg_m2_to_H + GV%m_to_H = US%R_to_kg_m3*rho_Kv * GV%kg_m2_to_H GV%H_to_MKS = GV%H_to_kg_m2 + GV%m2_s_to_HZ_T = US%R_to_kg_m3*rho_Kv * GV%kg_m2_to_H * US%m_to_Z * US%T_to_s + GV%H_to_m = 1.0 / GV%m_to_H + + GV%H_to_Z = US%m_to_Z * ( GV%H_to_kg_m2 / (US%R_to_kg_m3*GV%Rho0) ) + GV%Z_to_H = US%Z_to_m * ( US%R_to_kg_m3*GV%Rho0 * GV%kg_m2_to_H ) endif - GV%H_subroundoff = 1e-20 * max(GV%Angstrom_H,GV%m_to_H*1e-17) - GV%H_to_Pa = US%L_T_to_m_s**2*US%m_to_Z * GV%g_Earth * GV%H_to_kg_m2 - GV%H_to_Z = GV%H_to_m * US%m_to_Z - GV%Z_to_H = US%Z_to_m * GV%m_to_H - GV%Angstrom_Z = US%m_to_Z * GV%Angstrom_m + GV%Angstrom_H = (US%Z_to_m * GV%m_to_H) * GV%Angstrom_Z + GV%Angstrom_m = US%Z_to_m * GV%Angstrom_Z + + GV%H_subroundoff = 1e-20 * max(GV%Angstrom_H, GV%m_to_H*1e-17) + GV%dZ_subroundoff = 1e-20 * max(GV%Angstrom_Z, US%m_to_Z*1e-17) + + GV%H_to_Pa = US%L_T_to_m_s**2*US%m_to_Z * GV%g_Earth * GV%H_to_kg_m2 GV%H_to_RZ = GV%H_to_kg_m2 * US%kg_m3_to_R * US%m_to_Z GV%RZ_to_H = GV%kg_m2_to_H * US%R_to_kg_m3 * US%Z_to_m -! Log derivative values. - call log_param(param_file, mdl, "M to THICKNESS", GV%m_to_H*H_rescale_factor) - call log_param(param_file, mdl, "M to THICKNESS rescaled by 2^-n", GV%m_to_H) - call log_param(param_file, mdl, "THICKNESS to M rescaled by 2^n", GV%H_to_m) + GV%HZ_T_to_m2_s = 1.0 / GV%m2_s_to_HZ_T + GV%HZ_T_to_MKS = GV%H_to_MKS * US%Z_to_m * US%s_to_T + + ! Note based on the above that for both Boussinsq and non-Boussinesq cases that: + ! GV%Rho0 = GV%Z_to_H * GV%H_to_RZ + ! 1.0/GV%Rho0 = GV%H_to_Z * GV%RZ_to_H + ! This is exact for power-of-2 scaling of the units, regardless of the value of Rho0, but + ! the first term on the right hand side is invertable in Boussinesq mode, but the second + ! is invertable when non-Boussinesq. + + ! Log derivative values. + call log_param(param_file, mdl, "M to THICKNESS", GV%m_to_H*H_rescale_factor, units="H m-1") + call log_param(param_file, mdl, "M to THICKNESS rescaled by 2^-n", GV%m_to_H, units="2^n H m-1") + call log_param(param_file, mdl, "THICKNESS to M rescaled by 2^n", GV%H_to_m, units="2^-n m H-1") allocate( GV%sInterface(nk+1) ) allocate( GV%sLayer(nk) ) @@ -187,13 +246,6 @@ subroutine verticalGridInit( param_file, GV, US ) end subroutine verticalGridInit -!> Set the scaling factors for restart files to the scaling factors for this run. -subroutine fix_restart_scaling(GV) - type(verticalGrid_type), intent(inout) :: GV !< The ocean's vertical grid structure - - GV%m_to_H_restart = GV%m_to_H -end subroutine fix_restart_scaling - !> Returns the model's thickness units, usually m or kg/m^2. function get_thickness_units(GV) character(len=48) :: get_thickness_units !< The vertical thickness units @@ -282,9 +334,11 @@ end function get_tr_flux_units !> This sets the coordinate data for the "layer mode" of the isopycnal model. subroutine setVerticalGridAxes( Rlay, GV, scale ) - type(verticalGrid_type), intent(inout) :: GV !< The container for vertical grid data - real, dimension(GV%ke), intent(in) :: Rlay !< The layer target density [R ~> kg m-3] - real, intent(in) :: scale !< A unit scaling factor for Rlay + type(verticalGrid_type), intent(inout) :: GV !< The container for vertical grid data + real, dimension(GV%ke), intent(in) :: Rlay !< The layer target density [R ~> kg m-3] + real, intent(in) :: scale !< A unit scaling factor for Rlay to convert + !! it into the units of sInterface, usually + !! [kg m-3 R-1 ~> 1] when used in layer mode. ! Local variables integer :: k, nk diff --git a/src/core/_General_coordinate.dox b/src/core/_General_coordinate.dox index cdaf8a34ea..6effc4717b 100644 --- a/src/core/_General_coordinate.dox +++ b/src/core/_General_coordinate.dox @@ -1,76 +1,158 @@ -/*! \page General_Coordinate General coordinate equations +/*! \page General_Coordinate Generalized vertical coordinate equations -Transforming to a vertical coordinate \f$r(z,x,y,t)\f$, with \f$\dot{r} = \frac{\partial r}{\partial t}\f$ ... +The ocean equations discretized by MOM6 are formulated using +generalized vertical coordinates. Motivation for using generalized +vertical coordinates, and a full accounting of the ocean equations +written using these coordinates, can be found in Griffies, Adcroft and +Hallberg (2020) \cite Griffies_Adcroft_Hallberg2020. Here we provide +a brief summary. -The Boussinesq hydrostatic equations of motion in general-coordinate -\f$r\f$ are: +Consider a smooth function of space and time, \f$r(x,y,z,t)\f$, that +has a single-signed and non-zero vertical derivative known as the +specific thickness +\f{align} + \partial z/\partial r = (\partial r/\partial z)^{-1} = \mbox{specific thickness.} +\f} +The specific thickness measures the inverse vertical stratification of +the vertical coordinate surfaces. As so constrained, \f$r\f$ can +uniquely prescribe a positiion in the vertical. Consequently, the +ocean equations can be mapped one-to-one from geopotential vertical +coordinates to generalized vertical coordinate. Upon transforming to +\f$r\f$-coordinates, the material time derivative of \f$r\f$ appears +throughout the equations, playing the role of a pseudo-vertical +velocity, and we make use of the following shorthand for this +derivative +\f{align} +\dot{r} = D_{t} r. +\f} -\f{eqnarray} +The Boussinesq hydrostatic ocean equations take the following form using +generalized vertical coordinates (\f$r\f$-coordinates) +\f{align} \label{html:r-equations}\notag \\ -\rho_0 \left( \frac{\partial \mathbf{u}}{\partial t} + ( f + \zeta ) \, \hat{\mathbf{z}} \times \mathbf{u} + \dot{r} \, \frac{\partial \mathbf{u}}{\partial r} + \nabla_r \, K \right) &= -\nabla_r \, p - \rho \nabla_r \, \Phi + \boldsymbol{\mathcal{F}} -&\mbox{momentum} \label{eq:r-horz-momentum} \\ -\rho \, \frac{\partial \Phi}{\partial r} + \frac{\partial p}{\partial r} &= 0 -&\mbox{hydrostatic} \label{eq:r-hydrostatic-equation} \\ -\frac{\partial z_r }{\partial t} + \nabla_r \cdot \, \left( z_r \, \mathbf{u} \right) + \frac{\partial ( z_r \, \dot{r} ) }{\partial r} &= 0 -&\mbox{thickness} \label{eq:r-non-divergence} \\ -\frac{\partial ( \theta \, z_r ) }{\partial t} + \nabla_r \cdot \left( \theta z_r \, \mathbf{u} \right) + \frac{\partial ( \theta \, z_r \, \dot{r} )}{\partial r} &= z_r \boldsymbol{\mathcal{N}}_\theta^\gamma - \frac{\partial J_\theta^{(z)}}{\partial r} -&\mbox{potential temp} \label{eq:r-temperature-equation} \\ -\frac{\partial ( S \, z_r) }{\partial t} + \nabla_r \cdot \left( S \, z_r \, \mathbf{u} \right) + \frac{\partial ( S \, z_r \, \dot{r} )}{\partial r} &= z_r \boldsymbol{\mathcal{N}}_S^\gamma - \frac{\partial J_S^{(z)}}{\partial r} -&\mbox{salinity} \label{eq:r-salinity-equation} \\ -\rho &= \rho\left( S, \theta, -g \rho_0 z(r) \right) +\rho_o \left[ + \partial_{t} \mathbf{u} + (f + \zeta) \, \hat{\mathbf{z}} \times \mathbf{u} + + \dot{r} \, \partial_{r} \mathbf{u} \right] + &= -\nabla_r \, (p + \rho_{o} \, K) -\rho \nabla_r \Phi + \rho_{o} \, \mathbf{\mathcal{F}} + &\mbox{horizontal momentum} +\label{eq:r-horz-momentum} +\\ +\rho \, \partial_{r} \Phi + \partial_{r}p + &= 0 +&\mbox{hydrostatic} +\label{eq:r-hydrostatic-equation} +\\ + \partial_{t}( z_r) ++ \nabla_r \cdot ( z_r \, \mathbf{u} ) ++ \partial_{r} ( z_r \, \dot{r} ) +&= 0 +&\mbox{specific thickness} +\label{eq:r-non-divergence} +\\ + \partial_{t} ( \theta \, z_r ) ++ \nabla_r \cdot ( \theta z_r \, \mathbf{u} ) ++ \partial_{r} ( \theta \, z_r \, \dot{r} ) +&= z_r \mathbf{\mathcal{N}}_\theta^\gamma +- \partial_{r} J_\theta^{(z)} +&\mbox{potential/Conservative temp} +\label{eq:r-temperature-equation} +\\ +\partial_{t} ( S \, z_r) ++ \nabla_r \cdot ( S \, z_r \, \mathbf{u} ) ++ \partial_{r} ( S \, z_r \, \dot{r} ) +&= z_r \mathbf{\mathcal{N}}_S^\gamma +- \partial_{r} J_S^{(z)} +&\mbox{salinity} +\label{eq:r-salinity-equation} +\\ +\rho &= \rho( S, \theta, -g \rho_0 z ) &\mbox{equation of state.} \f} +The time derivatives appearing in these equations are computed with +the generalized vertical coordinate fixed rather than the +geopotential. It is a common misconception that the horizontal +velocity, \f$\mathbf{u}\f$, is rotated to align with constant \f$r\f$ +surfaces. Such is not the case. Rather, the horizontal velocity, +\f$\mathbf{u}\f$, is precisely the same horizontal velocity used with +geopotential coordinates. However, its evolution has here been +formulated using generalized vertical coordinates. -The time derivatives are now computed with the generalized vertical -coordinate fixed rather than the geopotential. We introduced the -specific thickness, \f$z_r = \partial z/\partial r\f$, which measures the -inverse vertical stratification of the vertical coordinate surfaces. - - Similar to \cite bleck2002, MOM6 is discretized in the vertical by - integrating between surfaces of \f$r\f$ to yield layer equations where the - layer thickness is \f$h = \int z_r dr\f$ and variables are treated as finite - volume averages over each layer: - -\f{eqnarray} -\label{html:h-equations}\notag \\ -\rho_0 \left( \frac{\partial \mathbf{u}}{\partial t} + \frac{( f + \zeta )}{h} \, +As a finite volume model, MOM6 is discretized in the vertical by +integrating between surfaces of constant \f$r\f$. The layer thickness +is a basic term appearing in these equations, which results from +integrating the specific thickness over a layer +\f{align} +h = \int z_r \, \mathrm{d}r. +\f} +Correspondingly, the model variables are treated as finite volume +averages over each layer, with full accounting of this finite volume +approach presented in Griffies, Adcroft and Hallberg (2020) +\cite Griffies_Adcroft_Hallberg2020, and with the semi-discrete model +ocean model equations written as follows. +\f{align} +\rho_0 +\left[ \frac{\partial \mathbf{u}}{\partial t} + \frac{( f + \zeta )}{h} \, \hat{\mathbf{z}} \times h \, \mathbf{u} + \underbrace{ \dot{r} \, -\frac{\partial \mathbf{u}}{\partial r} } + \nabla_r K \right) &= -\nabla_r \, p - -\rho \nabla_r \, \Phi + \boldsymbol{\mathcal{F}} -&\mbox{momentum} \label{eq:h-horz-momentum} \\ -\rho \, \delta_r \Phi + \delta_r p &= 0 -&\mbox{hydrostatic} \label{eq:h-hydrostatic-equation} \\ +\frac{\partial \mathbf{u}}{\partial r} } +\right] +&= -\nabla_r \, (p + \rho_{0} \, K) - +\rho \nabla_r \, \Phi + \mathbf{\mathcal{F}} +&\mbox{horizontal momentum} +\label{eq:h-horz-momentum} +\\ +\rho \, \delta_r \Phi + \delta_r p +&= 0 +&\mbox{hydrostatic} +\label{eq:h-hydrostatic-equation} +\\ \frac{\partial h}{\partial t} + \nabla_r \cdot \left( h \, \mathbf{u} \right) + -\underbrace{ \delta_r ( z_r \dot{r} ) } &= 0 -&\mbox{thickness} \label{eq:h-thickness-equation} \\ +\underbrace{ \delta_r ( z_r \dot{r} ) } + &= 0 +&\mbox{thickness} +\label{eq:h-thickness-equation} +\\ \frac{\partial ( \theta \, h )}{\partial t} + \nabla_r \cdot \left( \theta h \, -\mathbf{u} \right) + \underbrace{ \delta_r ( \theta \, z_r \dot{r} ) } &= -h \boldsymbol{\mathcal{N}}_\theta^\gamma - \delta_r J_\theta^{(z)} -&\mbox{potential temp} \label{eq:h-temperature-equation} \\ +\mathbf{u} \right) + \underbrace{ \delta_r ( \theta \, z_r \dot{r} ) } +&= +h \mathbf{\mathcal{N}}_\theta^\gamma - \delta_r J_\theta^{(z)} +&\mbox{potential/Conservative temp} +\label{eq:h-temperature-equation} +\\ \frac{\partial ( S \, h )}{\partial t} + \nabla_r \cdot \left( S \, h \, -\mathbf{u} \right) + \underbrace{ \delta_r ( S \, z_r \dot{r} ) } &= -h \boldsymbol{\mathcal{N}}_S^\gamma - \delta_r J_S^{(z)} -&\mbox{salinity} \label{eq:h-salinity-equation} \\ +\mathbf{u} \right) + \underbrace{ \delta_r ( S \, z_r \dot{r} ) } +&= +h \mathbf{\mathcal{N}}_S^\gamma - \delta_r J_S^{(z)} +&\mbox{salinity} +\label{eq:h-salinity-equation} +\\ \rho &= \rho\left( S, \theta, -g \rho_0 z(r) \right) &\mbox{equation of state,} \label{eq:h-equation-of-state} \f} - -where \f$\delta_{r} = \mathrm{d}r \, (\partial/\partial r)\f$ is the discrete -vertical difference operator. The pressure gradient accelerations -in the momentum equation \eqref{eq:h-horz-momentum,h-equations,momentum} are written in +where +\f{align} +\delta_{r} = \mathrm{d}r \, (\partial/\partial r) +\f} +is the discrete vertical difference operator. The pressure gradient +accelerations in the momentum equation are written in continuous-in-the-vertical form for brevity; the exact discretization -is detailed in \cite adcroft2008. The MOM6 time-stepping algorithm -integrates the above layer-averaged equations forward allowing the -vertical grid to follow the motion, i.e. \f$\dot{r}=0\f$, so that the underbraced -terms are dropped. This approach is generally known as the Lagrangian -method but here the Lagrangian method is used only in the vertical -direction. After each Lagrangian step, a remap step is applied that -generates a new vertical grid of the user's choosing. The ocean state is -then mapped from the old to the new grid. The physical state is not meant -to change during the remap step, yet truncation errors make remapping -imperfect. We employ high-order accurate reconstructions to minimize -errors introduced during the remap step (\cite white2008, \cite white2009). The -connection between time-stepping and remapping is described in -section \ref ALE_Timestep. +is detailed in \cite adcroft2008 and +\cite Griffies_Adcroft_Hallberg2020. The \f$1/h\f$ and \f$h\f$ appearing in +the horizontal momentum equation are carefully handled in the code to +ensure proper cancellation even when the layer thickness goes to zero +i.e., l'Hospital's rule is respected. + +The MOM6 time-stepping algorithm integrates the above layer-averaged +equations forward in time allowing the vertical grid to follow the +motion, i.e. \f$\dot{r}=0\f$, so that the underbraced terms are +dropped. This approach is generally known as a Lagrangian method, with +the Lagrangian approach in MOM6 limited to the vertical +direction. After each Lagrangian step, a regrid step is applied that +generates a new vertical grid of the user's choosing. The ocean state +is then remapped from the old to the new grid. The physical state is +not meant to change during the remap step, yet truncation errors make +remapping imperfect. We employ high-order accurate reconstructions to +minimize errors introduced during the remap step (\cite white2008, +\cite white2009). The connection between time-stepping and remapping +is described in section \ref ALE_Timestep. */ diff --git a/src/core/_Governing.dox b/src/core/_Governing.dox index 646ba52c09..466e9d957e 100644 --- a/src/core/_Governing.dox +++ b/src/core/_Governing.dox @@ -1,71 +1,176 @@ /*! \page Governing_Equations Governing Equations -The Boussinesq hydrostatic equations of motion in height coordinates are - -\f{eqnarray} D_t \boldsymbol{u} + f \widehat{\boldsymbol{k}} \times \boldsymbol{u} + \frac{\rho}{\rho_o} \boldsymbol{\nabla}_z \Phi + \frac{1}{\rho_o} \boldsymbol{\nabla}_z p &= \boldsymbol{\mathcal{F}} &\mbox{ momentum} \\ - \rho \, \frac{\partial \Phi}{\partial z} + \frac{\partial p}{\partial z} &= 0 &\mbox{ hydrostatic} \\ - \boldsymbol{\nabla}_z \cdotp \boldsymbol{u} + \frac{\partial w}{\partial z} &= 0 &\mbox{ thickness} \\ - D_t \theta &= \boldsymbol{\mathcal{N}}_\theta^\gamma - \frac{\partial J_\theta^{(z)}}{\partial z} &\mbox{ potential temp} \\ - D_t S &= \boldsymbol{\mathcal{N}}_S^\gamma - \frac{\partial J_S^{(z)}}{\partial z} &\mbox{ salinity} \\ - \rho &= \rho(S, \theta, z) &\mbox{ equation of state.} +MOM6 is a hydrostatic ocean circulation model that time steps either +the non-Boussinesq ocean equations (where the flow velocity is +divergent: \f$\nabla \cdot \mathbf{v} \ne 0\f$), or the Boussinesq +ocean equations (where velocity is non-divergent: \f$\nabla \cdot +\mathbf{v} = 0\f$). We here display the Boussinesq version since +it is most commonly used (as of 2022). We start by casting the +equations in geopotentiial coordinates prior to transforming to the +generalized vertical coordinates used by MOM6. A more thorough +discussion of these equations, and their finite volume realization +appropriate for MOM6, can be found in Griffies, Adcroft and Hallberg (2020) +\cite Griffies_Adcroft_Hallberg2020. + +The hydrostatic Boussinesq ocean equations, written using geopotential +vertical coordinates, are given by +\f{align} + \rho_o \left[ + D_t \mathbf{u} + f \hat{\mathbf{z}} \times \mathbf{u} + \right] + &= -\rho \, \nabla_z \Phi - \nabla_z p + + \rho_o \, \mathbf{\mathcal{F}} + &\mbox{horizontal momentum} +\\ + \rho \, \partial_{z} \Phi + \partial_{z} p &= 0 &\mbox{hydrostatic} +\\ + \nabla_z \cdotp \mathbf{u} + \partial_{z} w + &= 0 + &\mbox{continuity} +\\ + D_t \theta &= \mathbf{\mathcal{N}}_\theta^\gamma + - \partial_{z} J_\theta^{(z)} + &\mbox{potential or Conservative temp} + \\ + D_t S &= \mathbf{\mathcal{N}}_S^\gamma +- \partial_{z} J_S^{(z)} + &\mbox{salinity} +\\ + \rho &= \rho(S, \theta, z) &\mbox{ equation of state} +\\ + \mathbf{v} &= \mathbf{u} + \hat{\mathbf{z}} \, w &\mbox{velocity field.} \f} -where notation is described in \ref Notation, \f$\boldsymbol{\mathcal{F}}\f$ represents the accelerations due to -the divergence of stresses including those provided through boundary interactions. - -The prognostic thermodynamic variables are potential temperature, -\f$\theta\f$, and salinity \f$S\f$, which are related to in situ density -\f$\rho\f$ through the \cite wright1997 equation of state. In the potential -temperature and salinity equations, fluxes due to diabatic, vertically -oriented processes are indicated by \f$J^{(z)}\f$. The tendency due to the -convergence of fluxes oriented along neutral directions is indicated by -\f$\boldsymbol{\mathcal{N}}^\gamma\f$. Our implementation of this neutral -diffusion parameterization is detailed in Shao et al. (personal comm.) - -The total derivative is - -\f{eqnarray} D_t & \equiv \frac{\partial}{\partial t} + \boldsymbol{v} \cdotp \boldsymbol{\nabla} \\ - &= \frac{\partial}{\partial t} + \boldsymbol{u} \cdotp \boldsymbol{\nabla}_z + w \frac{\partial}{\partial z}. +The acceleration term, \f$\mathbf{\mathcal{F}}\f$, in the +horizontal momentum equation includes the acceleration due to the +divergence of internal frictional stresses as well as from bottom and +surface boundary stresses. Other notation is described in \ref +Notation. + +The prognostic temperature, \f$\theta\f$, is either potential +temperature or Conservative Temperature, depending on the chosen +equation of state, and \f$S\f$ is the salinity. We generally follow +the discussion of \cite McDougall_etal_2021 for how to interpret the +prognostic temperature and salinity in ocean models. MOM6 has +historically used the Wright (1997) \cite wright1997 equation of state +to compute the in situ density, \f$\rho\f$. However, there +are other options as documented in \ref Equation_of_State. In the +potential temperature and salinity equations, fluxes due to diabatic +processes are indicated by \f$J^{(z)}\f$. Tendencies due to the +convergence of fluxes oriented along neutral directions are indicated +by \f$\mathbf{\mathcal{N}}^\gamma\f$, with our implementation of +neutral diffusion detailed in Shao et al (2020) +\cite Shao_etal_2020. + +The total or material time derivative operator is given by +\f{align} + D_t &\equiv \partial_{t} + \mathbf{v} \cdotp \nabla + \\ + &= \partial_{t} + \mathbf{u} \cdotp \nabla_z + w \, \partial_{z}, \f} - -The non-divergence of flow allows a total derivative to be re-written in flux form: - -\f{eqnarray} D_t \theta &= \frac{\partial}{\partial t} + \boldsymbol{\nabla} \cdotp ( \boldsymbol{v} \theta ) \\ - &= \frac{\partial}{\partial t} + \boldsymbol{\nabla}_z \cdotp ( \boldsymbol{u} \theta ) + \frac{\partial ( w \theta )}{\partial z}. +where the second equality explosed the horizontal and vertical terms. Using the non-divergence condition +on the three-dimensional velocity allows us to write the material time derivative of an arbitrary scalar field, +\f$\psi\f$, into a flux-form equation +\f{align} D_t \psi &= ( \partial_{t} + \mathbf{u} \cdotp \nabla) \, \psi + \\ + &= \partial_{t} \psi + \nabla \cdotp (\mathbf{v} \, \psi) +\\ + &= \partial_{t} \psi + \nabla_z \cdotp ( \mathbf{u} \, \psi) + \partial_{z} ( w \, \psi). \f} - -The above equations of motion can thus be written as: - -\f{eqnarray} D_t \boldsymbol{u} + f \widehat{\boldsymbol{k}} \times \boldsymbol{u} + \frac{\rho}{\rho_o}\boldsymbol{\nabla}_z \Phi + \frac{1}{\rho_o} \boldsymbol{\nabla}_z p &= \boldsymbol{\mathcal{F}} &\mbox{ momentum}\\ - \rho \, \frac{\partial \Phi}{\partial z} + \frac{\partial p}{\partial z} &= 0 &\mbox{ hydrostatic} \\ - \boldsymbol{\nabla}_z \cdotp \boldsymbol{u} + \frac{\partial w}{\partial z} &= 0 &\mbox{ thickness} \\ - \frac{\partial \theta}{\partial t} + \boldsymbol{\nabla}_z \cdotp ( \boldsymbol{u} \theta ) + \frac{\partial ( w \theta )}{\partial z} &= \boldsymbol{\mathcal{N}}_\theta^\gamma - \frac{\partial J_\theta^{(z)}}{\partial z} &\mbox{ potential temp} \\ - \frac{\partial S}{\partial t} + \boldsymbol{\nabla}_z \cdotp ( \boldsymbol{u} S ) + \frac{\partial ( w S )}{\partial z} &= \boldsymbol{\mathcal{N}}_S^\gamma - \frac{\partial J_S^{(z)}}{\partial z} &\mbox{ salinity} \\ - \rho &= \rho(S, \theta, z) &\mbox{ equation of state.} +Discretizing the flux-form scalar equations means that fluxes +transferring scalars between grid cells act in a conservative manner. +Consequently, the domain integrated scalar (e.g., total seawater volume, total +salt content, total potential enthalpy) is affected only via surface and bottom +boundary transport. Such global conservation properties are +maintained by MOM6 to within computational roundoff, with this level +of precision found to be essential for using MOM6 to study +climate. Making use of the flux-form scalar conservation equations +brings the model equations to the form +\f{align} + \rho_o \left[ + D_t \mathbf{u} + f \hat{\mathbf{z}} \times \mathbf{u} + \right] + &= -\rho \, \nabla_z \Phi - \nabla_z p + + \rho_o \, \mathbf{\mathcal{F}} + &\mbox{horizontal momentum} +\\ + \rho \, \partial_{z} \Phi + \partial_{z} p &= 0 &\mbox{hydrostatic} +\\ + \nabla_z \cdotp \mathbf{u} + \partial_{z} w + &= 0 + &\mbox{continuity} +\\ +\partial_{t} \theta + \nabla_z \cdotp (\mathbf{u} \, \theta) + \partial_{z} (w \, \theta) +&= \mathbf{\mathcal{N}}_\theta^\gamma - \partial_{z} J_\theta^{(z)} +&\mbox{potential or Conservative temp} +\\ +\partial_{t} S + \nabla_z \cdotp (\mathbf{u} \, S) + \partial_{z}(w \, S) +&= \mathbf{\mathcal{N}}_S^\gamma -\partial_{z} J_S^{(z)} + &\mbox{salinity} +\\ +\rho &= \rho(S, \theta, z) &\mbox{equation of state.} \f} -\section vector_invariant_eqns Vector Invariant Equations - -MOM6 solves the momentum equations written in vector-invariant form. - -A vector identity allows the total derivative of velocity to be written in the vector-invariant form: - -\f{eqnarray} D_t \boldsymbol{u} &= \partial_t \boldsymbol{u} + \boldsymbol{v} \cdotp \boldsymbol{\nabla} \boldsymbol{u} \\ - &= \partial_t \boldsymbol{u} + \boldsymbol{u} \cdotp \boldsymbol{\nabla}_z \boldsymbol{u} + w \partial_z \boldsymbol{u} \\ - &= \partial_t \boldsymbol{u} + \left( \boldsymbol{\nabla} - \times \boldsymbol{u} \right) \times \boldsymbol{v} + \boldsymbol{\nabla} \underbrace{\frac{1}{2} \left|\boldsymbol{u}\right|^2}_{\equiv K} . +\section vector_invariant_eqns Vector invariant velocity equation + +MOM6 time steps the horizontal velocity equation in its +vector-invariant form. To derive this equation we make use of the +following vector identity +\f{align} + D_t \mathbf{u} + &= + \partial_t \mathbf{u} + \mathbf{v} \cdotp \nabla \mathbf{u} + \\ + &= + \partial_t \mathbf{u} + \mathbf{u} \cdotp \nabla_z \mathbf{u} + w \partial_z \mathbf{u} + \\ + &= + \partial_t \mathbf{u} + \left( \nabla \times \mathbf{u} \right) \times \mathbf{v} + + \nabla \left|\mathbf{u}\right|^2/2 + \\ + &= + \partial_t \mathbf{u} + w \, \partial_{z} \mathbf{u} + + \zeta \, \hat{\mathbf{z}} \times \mathbf{u} + \nabla_{z} K, \f} - -The flux-form equations of motion in height coordinates can thus be written succinctly as: - -\f{eqnarray} \partial_t \boldsymbol{u} + \left( f \widehat{\boldsymbol{k}} + - \boldsymbol{\nabla} \times \boldsymbol{u} \right) \times \boldsymbol{v} + \boldsymbol{\nabla} K - + \frac{\rho}{\rho_o} \boldsymbol{\nabla} \Phi + \frac{1}{\rho_o} \boldsymbol{\nabla} p &= \boldsymbol{\mathcal{F}} &\mbox{ momentum} \\ - \boldsymbol{\nabla}_z \cdotp \boldsymbol{u} + \partial_z w &= 0 &\mbox{ thickness} \\ - \partial_t \theta + \boldsymbol{\nabla}_z \cdotp ( \boldsymbol{u} \theta ) + \partial_z ( w \theta ) &= \boldsymbol{\mathcal{N}}_\theta^\gamma - \frac{\partial J_\theta^{(z)}}{\partial z} &\mbox{ potential temp} \\ - \partial_t S + \boldsymbol{\nabla}_z \cdotp ( \boldsymbol{u} S ) + \partial_z ( w S ) &= \boldsymbol{\mathcal{N}}_S^\gamma - \frac{\partial J_S^{(z)}}{\partial z} &\mbox{ salinity} \\ - \rho &= \rho(S, \theta, z) &\mbox{ equation of state} +where we introduced the vertical component to the relative vorticity +\f{align} + \zeta = \hat{\mathbf{z}} \cdot (\nabla \times \mathbf{u}) + = \partial_{x}v - \partial_{y} u, +\label{eq:relative-vorticity-z} +\f} +as well as the kinetic energy per mass contained in the horizontal flow +\f{align} + K = (u^{2} + v^{2})/2. +\label{eq:kinetic-energy-per-mass} +\f} +It is just the horizontal kinetic energy per mass that appears when +making the hydrostatic approximation, whereas a non-hydrostatic fluid +(such as the MITgcm) includes the contribution from vertical motion. With +these identities we are led to the MOM6 flux-form equations of motion in +geopotential coordinates +\f{align} + \rho_{o} \left[ + \partial_t \mathbf{u} + w \, \partial_{z} \mathbf{u} + + (f + \zeta) \hat{\mathbf{z}} \times \mathbf{u} + \right] + &= -\nabla_{z} (p + K) - \rho \, \nabla_{z} \Phi + \rho_{o} \, \mathbf{\mathcal{F}} + &\mbox{vector-inv horz velocity} +\\ + \rho \, \partial_{z} \Phi + \partial_{z} p &= 0 &\mbox{hydrostatic} +\\ + \nabla_z \cdotp \mathbf{u} + \partial_{z} w + &= 0 + &\mbox{continuity} + \\ + \partial_t \theta + \nabla_z \cdotp ( \mathbf{u} \, \theta ) + \partial_z ( w \, \theta ) + &= \mathbf{\mathcal{N}}_\theta^\gamma - \partial_{z} J_\theta^{(z)} + &\mbox{potential/Cons temp} + \\ + \partial_t S + \nabla_z \cdotp ( \mathbf{u} \, S ) + \partial_z (w \, S) + &= \mathbf{\mathcal{N}}_S^\gamma - \partial_{z} J_S^{(z)} + &\mbox{salinity} + \\ + \rho &= \rho(S, \theta, z) &\mbox{equation of state.} \f} -where the horizontal momentum equations and vertical hydrostatic balance equation have been written as a single three-dimensional equation. */ diff --git a/src/core/_Notation.dox b/src/core/_Notation.dox index faecb3b258..b91baac5fe 100644 --- a/src/core/_Notation.dox +++ b/src/core/_Notation.dox @@ -2,34 +2,62 @@ \section Symbols Symbols for variables -\f$z\f$ refers to elevation (or height), increasing upward so that for much of the ocean \f$z\f$ is negative. +\f$z\f$ refers to geopotential elevation (or height), increasing +upward and with \f$z=0\f$ defining the resting ocean surface. Much of +the ocean has \f$z < 0\f$. -\f$x\f$ and \f$y\f$ are the Cartesian horizontal coordinates. +\f$x\f$ and \f$y\f$ are the Cartesian horizontal coordinates. MOM6 + uses generalized orthogonal curvilinear horizontal + coordinates. However, the equations are simpler to write using + Cartesian coordinates, and it is very straightforward to generalize + the horizontal coordinates using the methods in Chapters 20 and 21 of + \cite SMGbook. -\f$\lambda\f$ and \f$\phi\f$ are the geographic coordinates on a sphere (longitude and latitude respectively). +\f$\lambda\f$ and \f$\phi\f$ are the geographic coordinates on a +sphere (longitude and latitude, respectively). -Horizontal components of velocity are indicated by \f$u\f$ and \f$v\f$ and vertical component by \f$w\f$. +Horizontal components of velocity are indicated by \f$u\f$ and \f$v\f$ +and vertical component by \f$w\f$. -\f$p\f$ is pressure and \f$\Phi\f$ is geo-potential: +\f$p\f$ is the hydrostatic pressure. - \f[ \Phi = g z .\f] +\f$\Phi\f$ is the geopotential. In the absence of tides, the +geopotential is given by \f$\Phi = g z,\f$ whereas more general +expressions hold when including astronomical tide forcing. -The thermodynamic state variables are usually salinity, \f$S\f$, and potential temperature, \f$\theta\f$ or the absolute salinity and conservative temperature, depending on the equation of state. \f$\rho\f$ is in-situ density. +The thermodynamic state variables can be salinity, \f$S\f$, and +potential temperature, \f$\theta\f$. Alternatively, one can choose +the Conservative Temperature if using the TEOS10 equation of state +from \cite TEOS2010. -\section vector_notation Vector notation - -The three-dimensional velocity vector is denoted \f$\boldsymbol{v}\f$ +\f$\rho\f$ is the in-situ density computed as a function +\f$\rho(S,\theta,p)\f$ for non-Boussinesq ocean or +\f$\rho(S,\theta,p=-g \, \rho_o \, z)\f$ for Boussinesq ocean. See +Young (2010) \cite Young2010 or Section 2.4 of Vallis (2017) +\cite GVbook for reasoning behind the simplified pressure +used in the Boussinesq equation of state. - \f[\boldsymbol{v} = \boldsymbol{u} + \widehat{\boldsymbol{k}} w ,\f] -where \f$\widehat{\boldsymbol{k}}\f$ is the unit vector pointed in the upward vertical direction and \f$\boldsymbol{u} = (u, v, 0)\f$ is the horizontal -component of velocity normal to the vertical. -The gradient operator without a suffix is three dimensional: - - \f[\boldsymbol{\nabla} = ( \boldsymbol{\nabla}_z, \partial_z ) .\f] +\section vector_notation Vector notation -but a suffix indicates a lateral gradient along a surface of constant property indicated by the suffix: +The three-dimensional velocity vector is denoted \f$\mathbf{v}\f$ +and it is decomposed into its horizontal and vertical components according to +\f{align} +\mathbf{v} + = \mathbf{u} + \hat{\mathbf{z}} \, w + = \hat{\mathbf{x}} \, u + \hat{\mathbf{y}} \, v + \hat{\mathbf{z}} \, w, + \f} +where \f$\hat{\mathbf{z}}\f$ is the unit vector pointed in the +upward vertical direction and \f$\mathbf{u} = (u, v, 0)\f$ is the +horizontal component of velocity normal to the vertical. + +The three-dimensional gradient operator is denoted \f$\nabla\f$, and it is decomposed into +its horizontal and vertical components according to +\f{align} +\nabla + = \nabla_z + \hat{\mathbf{z}} \, \partial_z + = \hat{\mathbf{x}} \, \partial_x + \hat{\mathbf{y}} \, \partial_y + \hat{\mathbf{z}} \, \partial_z. + \f} - \f[\boldsymbol{\nabla}_z = \left( \left. \partial_x \right|_z, \left. \partial_y \right|_z, 0 \right) .\f] */ diff --git a/src/diagnostics/MOM_PointAccel.F90 b/src/diagnostics/MOM_PointAccel.F90 index a4badaf8e7..e8c116d99c 100644 --- a/src/diagnostics/MOM_PointAccel.F90 +++ b/src/diagnostics/MOM_PointAccel.F90 @@ -1,3 +1,7 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Debug accelerations at a given point !! !! The two subroutines in this file write out all of the terms @@ -7,8 +11,6 @@ !! often this is done for debugging purposes. module MOM_PointAccel -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_diag_mediator, only : diag_ctrl use MOM_domains, only : pe_here use MOM_error_handler, only : MOM_error, NOTE @@ -39,6 +41,8 @@ module MOM_PointAccel !! written by this PE during the current run. integer :: max_writes !< The maximum number of times any PE can write out !! a column's worth of accelerations during a run. + logical :: full_column !< If true, write out the accelerations in all massive layers, + !! otherwise just document the ones with large velocities. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. @@ -50,8 +54,8 @@ module MOM_PointAccel v_av => NULL(), & !< Time average velocity [L T-1 ~> m s-1] u_prev => NULL(), & !< Previous u-velocity [L T-1 ~> m s-1] v_prev => NULL(), & !< Previous v-velocity [L T-1 ~> m s-1] - T => NULL(), & !< Temperature [degC] - S => NULL(), & !< Salinity [ppt] + T => NULL(), & !< Temperature [C ~> degC] + S => NULL(), & !< Salinity [S ~> ppt] u_accel_bt => NULL(), & !< Barotropic u-accelerations [L T-2 ~> m s-2] v_accel_bt => NULL() !< Barotropic v-accelerations [L T-2 ~> m s-2] end type PointAccel_CS @@ -80,20 +84,25 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st !! call to PointAccel_init. real, intent(in) :: vel_rpt !< The velocity magnitude that triggers a report [L T-1 ~> m s-1] real, optional, intent(in) :: str !< The surface wind stress [R L Z T-2 ~> Pa] - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - optional, intent(in) :: a !< The layer coupling coefficients from vertvisc [Z T-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), & + optional, intent(in) :: a !< The layer coupling coefficients from vertvisc + !! [H T-1 ~> m s-1 or Pa s m-1] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & optional, intent(in) :: hv !< The layer thicknesses at velocity grid points, !! from vertvisc [H ~> m or kg m-2]. + ! Local variables real :: CFL ! The local velocity-based CFL number [nondim] real :: Angstrom ! A negligibly small thickness [H ~> m or kg m-2] real :: du ! A velocity change [L T-1 ~> m s-1] real :: Inorm(SZK_(GV)) ! The inverse of the normalized velocity change [L T-1 ~> m s-1] real :: e(SZK_(GV)+1) ! Simple estimates of interface heights based on the sum of thicknesses [m] - real :: h_scale ! A scaling factor for thicknesses [m H-1 ~> 1 or m3 kg-1] + real :: h_scale ! A scaling factor for thicknesses [m H-1 ~> 1] or [kg m-2 H-1 ~> 1] real :: vel_scale ! A scaling factor for velocities [m T s-1 L-1 ~> 1] - real :: uh_scale ! A scaling factor for transport per unit length [m2 T s-1 L-1 H-1 ~> 1 or m3 kg-1] + real :: uh_scale ! A scaling factor for transport per unit length [m2 T s-1 L-1 H-1 ~> 1] + ! or [kg T m-1 s-1 L-1 H-1 ~> 1] + real :: temp_scale ! A scaling factor for temperatures [degC C-1 ~> 1] + real :: saln_scale ! A scaling factor for salinities [ppt S-1 ~> 1] integer :: yr, mo, day, hr, minute, sec, yearday integer :: k, ks, ke integer :: nz @@ -102,7 +111,8 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st integer :: file Angstrom = GV%Angstrom_H + GV%H_subroundoff - h_scale = GV%H_to_m ; vel_scale = US%L_T_to_m_s ; uh_scale = GV%H_to_m*US%L_T_to_m_s + h_scale = GV%H_to_mks ; vel_scale = US%L_T_to_m_s ; uh_scale = h_scale*vel_scale + temp_scale = US%C_to_degC ; saln_scale = US%S_to_ppt ! if (.not.associated(CS)) return nz = GV%ke @@ -113,11 +123,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 @@ -140,14 +150,17 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st enddo ke = k if (ke < ks) then - ks = 1; ke = nz; write(file,'("U: Unable to set ks & ke.")') + ks = 1 ; ke = nz ; write(file,'("U: Unable to set ks & ke.")') + endif + if (CS%full_column) then + ks = 1 ; ke = nz endif call get_date(CS%Time, yr, mo, day, hr, minute, sec) call get_time((CS%Time - set_date(yr, 1, 1, 0, 0, 0)), sec, yearday) write (file,'(/,"--------------------------")') - write (file,'(/,"Time ",i5,i4,F6.2," U-velocity violation at ",I4,": ",2(I3), & - & " (",F7.2," E "F7.2," N) Layers ",I3," to ",I3,". dt = ",1PG10.4)') & + write (file,'(/,"Time ",I0," ",I0," ",F6.2," U-velocity violation at ",I0,": ",I0,", ",I0, & + & " (",F7.2," E ",F7.2," N) Layers ",I0," to ",I0,". dt = ",1PG10.4)') & yr, yearday, (REAL(sec)/3600.0), pe_here(), I, j, & G%geoLonCu(I,j), G%geoLatCu(I,j), ks, ke, US%T_to_s*dt @@ -156,174 +169,174 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st if ((hin(i,j,k) + hin(i+1,j,k)) > 3.0*Angstrom) do_k(k) = .true. enddo - write(file,'(/,"Layers:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(I10," ",$)') (k) ; enddo - write(file,'(/,"u(m): ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*um(I,j,k)) ; enddo + write(file,'(/,"Layers:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(I10," ")', advance='no') (k) ; enddo + write(file,'(/,"u(m): ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*um(I,j,k)) ; enddo if (prev_avail) then - write(file,'(/,"u(mp): ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*CS%u_prev(I,j,k)) ; enddo + write(file,'(/,"u(mp): ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%u_prev(I,j,k)) ; enddo endif - write(file,'(/,"u(3): ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*CS%u_av(I,j,k)) ; enddo + write(file,'(/,"u(3): ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%u_av(I,j,k)) ; enddo - write(file,'(/,"CFL u: ",$)') + write(file,'(/,"CFL u: ")', advance='no') do k=ks,ke ; if (do_k(k)) then CFL = abs(um(I,j,k)) * dt * G%dy_Cu(I,j) if (um(I,j,k) < 0.0) then ; CFL = CFL * G%IareaT(i+1,j) else ; CFL = CFL * G%IareaT(i,j) ; endif - write(file,'(ES10.3," ",$)') CFL + write(file,'(ES10.3," ")', advance='no') CFL endif ; enddo - write(file,'(/,"CFL0 u:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"CFL0 u:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & abs(um(I,j,k)) * dt * G%IdxCu(I,j) ; enddo if (prev_avail) then - write(file,'(/,"du: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"du: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*(um(I,j,k)-CS%u_prev(I,j,k))) ; enddo endif - write(file,'(/,"CAu: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*dt*ADp%CAu(I,j,k)) ; enddo - write(file,'(/,"PFu: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*dt*ADp%PFu(I,j,k)) ; enddo - write(file,'(/,"diffu: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*dt*ADp%diffu(I,j,k)) ; enddo + write(file,'(/,"CAu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*dt*ADp%CAu(I,j,k)) ; enddo + write(file,'(/,"PFu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*dt*ADp%PFu(I,j,k)) ; enddo + write(file,'(/,"diffu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*dt*ADp%diffu(I,j,k)) ; enddo if (associated(ADp%gradKEu)) then - write(file,'(/,"KEu: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"KEu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*dt*ADp%gradKEu(I,j,k)) ; enddo endif if (associated(ADp%rv_x_v)) then - write(file,'(/,"Coru: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"Coru: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & vel_scale*dt*(ADp%CAu(I,j,k)-ADp%rv_x_v(I,j,k)) ; enddo endif if (associated(ADp%du_dt_visc)) then - write(file,'(/,"ubv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"ubv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & vel_scale*(um(I,j,k) - dt*ADp%du_dt_visc(I,j,k)) ; enddo - write(file,'(/,"duv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"duv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*dt*ADp%du_dt_visc(I,j,k)) ; enddo endif if (associated(ADp%du_other)) then - write(file,'(/,"du_other: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"du_other: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*ADp%du_other(I,j,k)) ; enddo endif if (present(a)) then - write(file,'(/,"a: ",$)') - do k=ks,ke+1 ; if (do_k(k)) write(file,'(ES10.3," ",$)') (US%Z_to_m*a(I,j,k)*dt) ; enddo + write(file,'(/,"a: ",ES10.3," ")', advance='no') h_scale*a(I,j,ks)*dt + do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') (h_scale*a(I,j,K)*dt) ; enddo endif if (present(hv)) then - write(file,'(/,"hvel: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hv(I,j,k) ; enddo + write(file,'(/,"hvel: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hv(I,j,k) ; enddo + endif + if (present(str)) then + write(file,'(/,"Stress: ",ES10.3)', advance='no') (uh_scale*GV%RZ_to_H) * (str*dt) endif - write(file,'(/,"Stress: ",ES10.3)') vel_scale*US%Z_to_m * (str*dt / GV%Rho0) if (associated(CS%u_accel_bt)) then - write(file,'("dubt: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"dubt: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*dt*CS%u_accel_bt(I,j,k)) ; enddo - write(file,'(/)') endif + write(file,'(/)') - write(file,'(/,"h--: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (h_scale*hin(i,j-1,k)) ; enddo - write(file,'(/,"h+-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (h_scale*hin(i+1,j-1,k)) ; enddo - write(file,'(/,"h-0: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (h_scale*hin(i,j,k)) ; enddo - write(file,'(/,"h+0: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (h_scale*hin(i+1,j,k)) ; enddo - write(file,'(/,"h-+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (h_scale*hin(i,j+1,k)) ; enddo - write(file,'(/,"h++: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (h_scale*hin(i+1,j+1,k)) ; enddo + write(file,'(/,"h--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (h_scale*hin(i,j-1,k)) ; enddo + write(file,'(/,"h+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (h_scale*hin(i+1,j-1,k)) ; enddo + write(file,'(/,"h-0: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (h_scale*hin(i,j,k)) ; enddo + write(file,'(/,"h+0: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (h_scale*hin(i+1,j,k)) ; enddo + write(file,'(/,"h-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (h_scale*hin(i,j+1,k)) ; enddo + write(file,'(/,"h++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (h_scale*hin(i+1,j+1,k)) ; enddo e(nz+1) = -US%Z_to_m*(G%bathyT(i,j) + G%Z_ref) do k=nz,1,-1 ; e(K) = e(K+1) + h_scale*hin(i,j,k) ; enddo - write(file,'(/,"e-: ",$)') - write(file,'(ES10.3," ",$)') e(ks) - do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ",$)') e(K) ; enddo + write(file,'(/,"e-: ",ES10.3," ")', advance='no') e(ks) + do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') e(K) ; enddo e(nz+1) = -US%Z_to_m*(G%bathyT(i+1,j) + G%Z_ref) do k=nz,1,-1 ; e(K) = e(K+1) + h_scale*hin(i+1,j,k) ; enddo - write(file,'(/,"e+: ",$)') - write(file,'(ES10.3," ",$)') e(ks) - do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ",$)') e(K) ; enddo + write(file,'(/,"e+: ",ES10.3," ")', advance='no') e(ks) + do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') e(K) ; enddo if (associated(CS%T)) then - write(file,'(/,"T-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') CS%T(i,j,k) ; enddo - write(file,'(/,"T+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') CS%T(i+1,j,k) ; enddo + write(file,'(/,"T-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') temp_scale*CS%T(i,j,k) ; enddo + write(file,'(/,"T+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') temp_scale*CS%T(i+1,j,k) ; enddo endif if (associated(CS%S)) then - write(file,'(/,"S-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') CS%S(i,j,k) ; enddo - write(file,'(/,"S+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') CS%S(i+1,j,k) ; enddo + write(file,'(/,"S-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') saln_scale*CS%S(i,j,k) ; enddo + write(file,'(/,"S+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') saln_scale*CS%S(i+1,j,k) ; enddo endif if (prev_avail) then - write(file,'(/,"v--: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*CS%v_prev(i,J-1,k)) ; enddo - write(file,'(/,"v-+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*CS%v_prev(i,J,k)) ; enddo - write(file,'(/,"v+-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*CS%v_prev(i+1,J-1,k)) ; enddo - write(file,'(/,"v++: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*CS%v_prev(i+1,J,k)) ; enddo - endif - - write(file,'(/,"vh--: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"v--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%v_prev(i,J-1,k)) ; enddo + write(file,'(/,"v-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%v_prev(i,J,k)) ; enddo + write(file,'(/,"v+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%v_prev(i+1,J-1,k)) ; enddo + write(file,'(/,"v++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%v_prev(i+1,J,k)) ; enddo + endif + + write(file,'(/,"vh--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (uh_scale*CDp%vh(i,J-1,k)*G%IdxCv(i,J-1)) ; enddo - write(file,'(/," vhC--:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," vhC--:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (0.5*CS%v_av(i,j-1,k)*uh_scale*(hin(i,j-1,k) + hin(i,j,k))) ; enddo if (prev_avail) then - write(file,'(/," vhCp--:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," vhCp--:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (0.5*CS%v_prev(i,j-1,k)*uh_scale*(hin(i,j-1,k) + hin(i,j,k))) ; enddo endif - write(file,'(/,"vh-+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"vh-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (uh_scale*CDp%vh(i,J,k)*G%IdxCv(i,J)) ; enddo - write(file,'(/," vhC-+:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," vhC-+:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (0.5*CS%v_av(i,J,k)*uh_scale*(hin(i,j,k) + hin(i,j+1,k))) ; enddo if (prev_avail) then - write(file,'(/," vhCp-+:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," vhCp-+:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (0.5*CS%v_prev(i,J,k)*uh_scale*(hin(i,j,k) + hin(i,j+1,k))) ; enddo endif - write(file,'(/,"vh+-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"vh+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (uh_scale*CDp%vh(i+1,J-1,k)*G%IdxCv(i+1,J-1)) ; enddo - write(file,'(/," vhC+-:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," vhC+-:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (0.5*CS%v_av(i+1,J-1,k)*uh_scale*(hin(i+1,j-1,k) + hin(i+1,j,k))) ; enddo if (prev_avail) then - write(file,'(/," vhCp+-:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," vhCp+-:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (0.5*CS%v_prev(i+1,J-1,k)*uh_scale*(hin(i+1,j-1,k) + hin(i+1,j,k))) ; enddo endif - write(file,'(/,"vh++: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"vh++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (uh_scale*CDp%vh(i+1,J,k)*G%IdxCv(i+1,J)) ; enddo - write(file,'(/," vhC++:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," vhC++:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (0.5*CS%v_av(i+1,J,k)*uh_scale*(hin(i+1,j,k) + hin(i+1,j+1,k))) ; enddo if (prev_avail) then - write(file,'(/," vhCp++:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," vhCp++:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (0.5*CS%v_av(i+1,J,k)*uh_scale*(hin(i+1,j,k) + hin(i+1,j+1,k))) ; enddo endif @@ -337,48 +350,48 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st Inorm(k) = 1.0 / du enddo - write(file,'(2/,"Norm: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') (vel_scale / Inorm(k)) ; enddo + write(file,'(2/,"Norm: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') (vel_scale / Inorm(k)) ; enddo - write(file,'(/,"du: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"du: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & ((um(I,j,k)-CS%u_prev(I,j,k)) * Inorm(k)) ; enddo - write(file,'(/,"CAu: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"CAu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%CAu(I,j,k) * Inorm(k)) ; enddo - write(file,'(/,"PFu: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"PFu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%PFu(I,j,k) * Inorm(k)) ; enddo - write(file,'(/,"diffu: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"diffu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%diffu(I,j,k) * Inorm(k)) ; enddo if (associated(ADp%gradKEu)) then - write(file,'(/,"KEu: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"KEu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%gradKEu(I,j,k) * Inorm(k)) ; enddo endif if (associated(ADp%rv_x_v)) then - write(file,'(/,"Coru: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"Coru: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*(ADp%CAu(I,j,k)-ADp%rv_x_v(I,j,k)) * Inorm(k)) ; enddo endif if (associated(ADp%du_dt_visc)) then - write(file,'(/,"duv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"duv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%du_dt_visc(I,j,k) * Inorm(k)) ; enddo endif if (associated(ADp%du_other)) then - write(file,'(/,"du_other: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"du_other: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (ADp%du_other(I,j,k) * Inorm(k)) ; enddo endif if (associated(CS%u_accel_bt)) then - write(file,'(/,"dubt: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"dubt: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*CS%u_accel_bt(I,j,k) * Inorm(k)) ; enddo endif endif @@ -412,20 +425,25 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st !! call to PointAccel_init. real, intent(in) :: vel_rpt !< The velocity magnitude that triggers a report [L T-1 ~> m s-1] real, optional, intent(in) :: str !< The surface wind stress [R L Z T-2 ~> Pa] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - optional, intent(in) :: a !< The layer coupling coefficients from vertvisc [Z T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), & + optional, intent(in) :: a !< The layer coupling coefficients from vertvisc + !! [H T-1 ~> m s-1 or Pa s m-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & optional, intent(in) :: hv !< The layer thicknesses at velocity grid points, !! from vertvisc [H ~> m or kg m-2]. + ! Local variables real :: CFL ! The local velocity-based CFL number [nondim] real :: Angstrom ! A negligibly small thickness [H ~> m or kg m-2] real :: dv ! A velocity change [L T-1 ~> m s-1] real :: Inorm(SZK_(GV)) ! The inverse of the normalized velocity change [L T-1 ~> m s-1] real :: e(SZK_(GV)+1) ! Simple estimates of interface heights based on the sum of thicknesses [m] - real :: h_scale ! A scaling factor for thicknesses [m H-1 ~> 1 or m3 kg-1] + real :: h_scale ! A scaling factor for thicknesses [m H-1 ~> 1] or [kg m-2 H-1 ~> 1] real :: vel_scale ! A scaling factor for velocities [m T s-1 L-1 ~> 1] - real :: uh_scale ! A scaling factor for transport per unit length [m2 T s-1 L-1 H-1 ~> 1 or m3 kg-1] + real :: uh_scale ! A scaling factor for transport per unit length [m2 T s-1 L-1 H-1 ~> 1] + ! or [kg T m-1 s-1 L-1 H-1 ~> 1] + real :: temp_scale ! A scaling factor for temperatures [degC C-1 ~> 1] + real :: saln_scale ! A scaling factor for salinities [ppt S-1 ~> 1] integer :: yr, mo, day, hr, minute, sec, yearday integer :: k, ks, ke integer :: nz @@ -434,7 +452,8 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st integer :: file Angstrom = GV%Angstrom_H + GV%H_subroundoff - h_scale = GV%H_to_m ; vel_scale = US%L_T_to_m_s ; uh_scale = GV%H_to_m*US%L_T_to_m_s + h_scale = GV%H_to_mks ; vel_scale = US%L_T_to_m_s ; uh_scale = h_scale*vel_scale + temp_scale = US%C_to_degC ; saln_scale = US%S_to_ppt ! if (.not.associated(CS)) return nz = GV%ke @@ -445,11 +464,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 @@ -471,14 +490,17 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st enddo ke = k if (ke < ks) then - ks = 1; ke = nz; write(file,'("V: Unable to set ks & ke.")') + ks = 1 ; ke = nz ; write(file,'("V: Unable to set ks & ke.")') + endif + if (CS%full_column) then + ks = 1 ; ke = nz endif call get_date(CS%Time, yr, mo, day, hr, minute, sec) call get_time((CS%Time - set_date(yr, 1, 1, 0, 0, 0)), sec, yearday) write (file,'(/,"--------------------------")') - write (file,'(/,"Time ",i5,i4,F6.2," V-velocity violation at ",I4,": ",2(I3), & - & " (",F7.2," E ",F7.2," N) Layers ",I3," to ",I3,". dt = ",1PG10.4)') & + write (file,'(/,"Time ",I0," ",I0," ",F6.2," V-velocity violation at ",I0,": ",I0,", ",I0, & + & " (",F7.2," E ",F7.2," N) Layers ",I0," to ",I0,". dt = ",1PG10.4)') & yr, yearday, (REAL(sec)/3600.0), pe_here(), i, J, & G%geoLonCv(i,J), G%geoLatCv(i,J), ks, ke, US%T_to_s*dt @@ -487,178 +509,178 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st if ((hin(i,j,k) + hin(i,j+1,k)) > 3.0*Angstrom) do_k(k) = .true. enddo - write(file,'(/,"Layers:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(I10," ",$)') (k) ; enddo - write(file,'(/,"v(m): ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*vm(i,J,k)) ; enddo + write(file,'(/,"Layers:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(I10," ")', advance='no') (k) ; enddo + write(file,'(/,"v(m): ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*vm(i,J,k)) ; enddo if (prev_avail) then - write(file,'(/,"v(mp): ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*CS%v_prev(i,J,k)) ; enddo + write(file,'(/,"v(mp): ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%v_prev(i,J,k)) ; enddo endif - write(file,'(/,"v(3): ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*CS%v_av(i,J,k)) ; enddo - write(file,'(/,"CFL v: ",$)') + write(file,'(/,"v(3): ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%v_av(i,J,k)) ; enddo + write(file,'(/,"CFL v: ")', advance='no') do k=ks,ke ; if (do_k(k)) then CFL = abs(vm(i,J,k)) * dt * G%dx_Cv(i,J) if (vm(i,J,k) < 0.0) then ; CFL = CFL * G%IareaT(i,j+1) else ; CFL = CFL * G%IareaT(i,j) ; endif - write(file,'(ES10.3," ",$)') CFL + write(file,'(ES10.3," ")', advance='no') CFL endif ; enddo - write(file,'(/,"CFL0 v:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"CFL0 v:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & abs(vm(i,J,k)) * dt * G%IdyCv(i,J) ; enddo if (prev_avail) then - write(file,'(/,"dv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"dv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*(vm(i,J,k)-CS%v_prev(i,J,k))) ; enddo endif - write(file,'(/,"CAv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*dt*ADp%CAv(i,J,k)) ; enddo + write(file,'(/,"CAv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*dt*ADp%CAv(i,J,k)) ; enddo - write(file,'(/,"PFv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*dt*ADp%PFv(i,J,k)) ; enddo + write(file,'(/,"PFv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*dt*ADp%PFv(i,J,k)) ; enddo - write(file,'(/,"diffv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*dt*ADp%diffv(i,J,k)) ; enddo + write(file,'(/,"diffv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*dt*ADp%diffv(i,J,k)) ; enddo if (associated(ADp%gradKEv)) then - write(file,'(/,"KEv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"KEv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*dt*ADp%gradKEv(i,J,k)) ; enddo endif if (associated(ADp%rv_x_u)) then - write(file,'(/,"Corv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"Corv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & vel_scale*dt*(ADp%CAv(i,J,k)-ADp%rv_x_u(i,J,k)) ; enddo endif if (associated(ADp%dv_dt_visc)) then - write(file,'(/,"vbv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"vbv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & vel_scale*(vm(i,J,k) - dt*ADp%dv_dt_visc(i,J,k)) ; enddo - write(file,'(/,"dvv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"dvv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*dt*ADp%dv_dt_visc(i,J,k)) ; enddo endif if (associated(ADp%dv_other)) then - write(file,'(/,"dv_other: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"dv_other: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*ADp%dv_other(i,J,k)) ; enddo endif if (present(a)) then - write(file,'(/,"a: ",$)') - do k=ks,ke+1 ; if (do_k(k)) write(file,'(ES10.3," ",$)') (US%Z_to_m*a(i,j,k)*dt) ; enddo + write(file,'(/,"a: ",ES10.3," ")', advance='no') h_scale*a(i,J,ks)*dt + do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') (h_scale*a(i,J,K)*dt) ; enddo endif if (present(hv)) then - write(file,'(/,"hvel: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hv(i,J,k) ; enddo + write(file,'(/,"hvel: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hv(i,J,k) ; enddo + endif + if (present(str)) then + write(file,'(/,"Stress: ",ES10.3)', advance='no') (uh_scale*GV%RZ_to_H) * (str*dt) endif - write(file,'(/,"Stress: ",ES10.3)') vel_scale*US%Z_to_m * (str*dt / GV%Rho0) if (associated(CS%v_accel_bt)) then - write(file,'("dvbt: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'("dvbt: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*dt*CS%v_accel_bt(i,J,k)) ; enddo - write(file,'(/)') - endif - - write(file,'("h--: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hin(i-1,j,k) ; enddo - write(file,'(/,"h0-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hin(i,j,k) ; enddo - write(file,'(/,"h+-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hin(i+1,j,k) ; enddo - write(file,'(/,"h-+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hin(i-1,j+1,k) ; enddo - write(file,'(/,"h0+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hin(i,j+1,k) ; enddo - write(file,'(/,"h++: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hin(i+1,j+1,k) ; enddo + endif + write(file,'(/)') + + write(file,'("h--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hin(i-1,j,k) ; enddo + write(file,'(/,"h0-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hin(i,j,k) ; enddo + write(file,'(/,"h+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hin(i+1,j,k) ; enddo + write(file,'(/,"h-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hin(i-1,j+1,k) ; enddo + write(file,'(/,"h0+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hin(i,j+1,k) ; enddo + write(file,'(/,"h++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hin(i+1,j+1,k) ; enddo e(nz+1) = -US%Z_to_m*(G%bathyT(i,j) + G%Z_ref) do k=nz,1,-1 ; e(K) = e(K+1) + h_scale*hin(i,j,k) ; enddo - write(file,'(/,"e-: ",$)') - write(file,'(ES10.3," ",$)') e(ks) - do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ",$)') e(K) ; enddo + write(file,'(/,"e-: ",ES10.3," ")', advance='no') e(ks) + do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') e(K) ; enddo e(nz+1) = -US%Z_to_m*(G%bathyT(i,j+1) + G%Z_ref) do k=nz,1,-1 ; e(K) = e(K+1) + h_scale*hin(i,j+1,k) ; enddo - write(file,'(/,"e+: ",$)') - write(file,'(ES10.3," ",$)') e(ks) - do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ",$)') e(K) ; enddo + write(file,'(/,"e+: ",ES10.3," ")', advance='no') e(ks) + do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') e(K) ; enddo if (associated(CS%T)) then - write(file,'(/,"T-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') CS%T(i,j,k) ; enddo - write(file,'(/,"T+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') CS%T(i,j+1,k) ; enddo + write(file,'(/,"T-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') temp_scale*CS%T(i,j,k) ; enddo + write(file,'(/,"T+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') temp_scale*CS%T(i,j+1,k) ; enddo endif if (associated(CS%S)) then - write(file,'(/,"S-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') CS%S(i,j,k) ; enddo - write(file,'(/,"S+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') CS%S(i,j+1,k) ; enddo + write(file,'(/,"S-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') saln_scale*CS%S(i,j,k) ; enddo + write(file,'(/,"S+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') saln_scale*CS%S(i,j+1,k) ; enddo endif if (prev_avail) then - write(file,'(/,"u--: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') vel_scale*CS%u_prev(I-1,j,k) ; enddo - write(file,'(/,"u-+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') vel_scale*CS%u_prev(I-1,j+1,k) ; enddo - write(file,'(/,"u+-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') vel_scale*CS%u_prev(I,j,k) ; enddo - write(file,'(/,"u++: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') vel_scale*CS%u_prev(I,j+1,k) ; enddo - endif - - write(file,'(/,"uh--: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"u--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') vel_scale*CS%u_prev(I-1,j,k) ; enddo + write(file,'(/,"u-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') vel_scale*CS%u_prev(I-1,j+1,k) ; enddo + write(file,'(/,"u+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') vel_scale*CS%u_prev(I,j,k) ; enddo + write(file,'(/,"u++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') vel_scale*CS%u_prev(I,j+1,k) ; enddo + endif + + write(file,'(/,"uh--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (uh_scale*CDp%uh(I-1,j,k)*G%IdyCu(I-1,j)) ; enddo - write(file,'(/," uhC--: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," uhC--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (CS%u_av(I-1,j,k) * uh_scale*0.5*(hin(i-1,j,k) + hin(i,j,k))) ; enddo if (prev_avail) then - write(file,'(/," uhCp--:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," uhCp--:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (CS%u_prev(I-1,j,k) * uh_scale*0.5*(hin(i-1,j,k) + hin(i,j,k))) ; enddo endif - write(file,'(/,"uh-+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"uh-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (uh_scale*CDp%uh(I-1,j+1,k)*G%IdyCu(I-1,j+1)) ; enddo - write(file,'(/," uhC-+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," uhC-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (CS%u_av(I-1,j+1,k) * uh_scale*0.5*(hin(i-1,j+1,k) + hin(i,j+1,k))) ; enddo if (prev_avail) then - write(file,'(/," uhCp-+:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," uhCp-+:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (CS%u_prev(I-1,j+1,k) * uh_scale*0.5*(hin(i-1,j+1,k) + hin(i,j+1,k))) ; enddo endif - write(file,'(/,"uh+-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"uh+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (uh_scale*CDp%uh(I,j,k)*G%IdyCu(I,j)) ; enddo - write(file,'(/," uhC+-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," uhC+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (CS%u_av(I,j,k) * uh_scale*0.5*(hin(i,j,k) + hin(i+1,j,k))) ; enddo if (prev_avail) then - write(file,'(/," uhCp+-:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," uhCp+-:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (CS%u_prev(I,j,k) * uh_scale*0.5*(hin(i,j,k) + hin(i+1,j,k))) ; enddo endif - write(file,'(/,"uh++: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"uh++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (uh_scale*CDp%uh(I,j+1,k)*G%IdyCu(I,j+1)) ; enddo - write(file,'(/," uhC++: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," uhC++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (CS%u_av(I,j+1,k) * uh_scale*0.5*(hin(i,j+1,k) + hin(i+1,j+1,k))) ; enddo if (prev_avail) then - write(file,'(/," uhCp++:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," uhCp++:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (CS%u_prev(I,j+1,k) * uh_scale*0.5*(hin(i,j+1,k) + hin(i+1,j+1,k))) ; enddo endif @@ -672,44 +694,44 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st Inorm(k) = 1.0 / dv enddo - write(file,'(2/,"Norm: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') (vel_scale / Inorm(k)) ; enddo - write(file,'(/,"dv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(2/,"Norm: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') (vel_scale / Inorm(k)) ; enddo + write(file,'(/,"dv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & ((vm(i,J,k)-CS%v_prev(i,J,k)) * Inorm(k)) ; enddo - write(file,'(/,"CAv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"CAv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%CAv(i,J,k) * Inorm(k)) ; enddo - write(file,'(/,"PFv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"PFv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%PFv(i,J,k) * Inorm(k)) ; enddo - write(file,'(/,"diffv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"diffv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%diffv(i,J,k) * Inorm(k)) ; enddo if (associated(ADp%gradKEu)) then - write(file,'(/,"KEv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"KEv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%gradKEv(i,J,k) * Inorm(k)) ; enddo endif if (associated(ADp%rv_x_u)) then - write(file,'(/,"Corv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"Corv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*(ADp%CAv(i,J,k)-ADp%rv_x_u(i,J,k)) * Inorm(k)) ; enddo endif if (associated(ADp%dv_dt_visc)) then - write(file,'(/,"dvv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"dvv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%dv_dt_visc(i,J,k) * Inorm(k)) ; enddo endif if (associated(ADp%dv_other)) then - write(file,'(/,"dv_other: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"dv_other: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (ADp%dv_other(i,J,k) * Inorm(k)) ; enddo endif if (associated(CS%v_accel_bt)) then - write(file,'(/,"dvbt: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"dvbt: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*CS%v_accel_bt(i,J,k) * Inorm(k)) ; enddo endif endif @@ -749,8 +771,8 @@ subroutine PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS) CS%T => MIS%T ; CS%S => MIS%S CS%u_accel_bt => MIS%u_accel_bt ; CS%v_accel_bt => MIS%v_accel_bt CS%u_prev => MIS%u_prev ; CS%v_prev => MIS%v_prev - CS%u_av => MIS%u_av; if (.not.associated(MIS%u_av)) CS%u_av => MIS%u(:,:,:) - CS%v_av => MIS%v_av; if (.not.associated(MIS%v_av)) CS%v_av => MIS%v(:,:,:) + CS%u_av => MIS%u_av ; if (.not.associated(MIS%u_av)) CS%u_av => MIS%u(:,:,:) + CS%v_av => MIS%v_av ; if (.not.associated(MIS%v_av)) CS%v_av => MIS%v(:,:,:) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "", debugging=.true.) @@ -767,6 +789,10 @@ subroutine PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS) call get_param(param_file, mdl, "MAX_TRUNC_FILE_SIZE_PER_PE", CS%max_writes, & "The maximum number of columns of truncations that any PE "//& "will write out during a run.", default=50, debuggingParam=.true.) + call get_param(param_file, mdl, "DEBUG_FULL_COLUMN", CS%full_column, & + "If true, write out the accelerations in all massive layers; otherwise "//& + "just document the ones with large velocities.", & + default=.false., debuggingParam=.true.) if (len_trim(dirs%output_directory) > 0) then if (len_trim(CS%u_trunc_file) > 0) & diff --git a/src/diagnostics/MOM_debugging.F90 b/src/diagnostics/MOM_debugging.F90 index fda5a97d69..56efe2fd42 100644 --- a/src/diagnostics/MOM_debugging.F90 +++ b/src/diagnostics/MOM_debugging.F90 @@ -1,3 +1,7 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Provides checksumming functions for debugging !! !! This module contains subroutines that perform various error checking and @@ -6,18 +10,18 @@ !! separate we retain the ability to set up MOM6 and SIS2 debugging separately. module MOM_debugging -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_checksums, only : hchksum, Bchksum, qchksum, uvchksum, hchksum_pair -use MOM_checksums, only : is_NaN, chksum, MOM_checksums_init -use MOM_coms, only : PE_here, root_PE, num_PEs -use MOM_coms, only : min_across_PEs, max_across_PEs, reproducing_sum -use MOM_domains, only : pass_vector, pass_var, pe_here -use MOM_domains, only : BGRID_NE, AGRID, To_All, Scalar_Pair +use MOM_checksums, only : hchksum, Bchksum, qchksum, uvchksum, hchksum_pair +use MOM_checksums, only : is_NaN, chksum, MOM_checksums_init +use MOM_coms, only : PE_here, root_PE, num_PEs +use MOM_coms, only : min_across_PEs, max_across_PEs, reproducing_sum +use MOM_domains, only : pass_vector, pass_var, pe_here +use MOM_domains, only : BGRID_NE, AGRID, To_All, Scalar_Pair use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe -use MOM_file_parser, only : log_version, param_file_type, get_param -use MOM_grid, only : ocean_grid_type -use MOM_hor_index, only : hor_index_type +use MOM_file_parser, only : log_version, param_file_type, get_param +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_io, only : stdout +use MOM_unit_scaling, only : unit_scale_type implicit none ; private @@ -25,6 +29,7 @@ module MOM_debugging public :: vec_chksum, vec_chksum_C, vec_chksum_B, vec_chksum_A public :: MOM_debugging_init, totalStuff, totalTandS public :: check_column_integral, check_column_integrals +public :: query_debugging_checks ! These interfaces come from MOM_checksums. public :: hchksum, Bchksum, qchksum, is_NaN, chksum, uvchksum, hchksum_pair @@ -76,11 +81,11 @@ module MOM_debugging contains !> MOM_debugging_init initializes the MOM_debugging module, and sets -!! the parameterts that control which checks are active for MOM6. +!! the parameters that control which checks are active for MOM6. subroutine MOM_debugging_init(param_file) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_debugging" ! This module's name. call log_version(param_file, mdl, version, debugging=.true.) @@ -100,56 +105,76 @@ subroutine MOM_debugging_init(param_file) end subroutine MOM_debugging_init +!> Returns logicals indicating which debugging checks should be performed. +subroutine query_debugging_checks(do_debug, do_chksums, do_redundant) + logical, optional, intent(out) :: do_debug !< True if verbose debugging is to be output + logical, optional, intent(out) :: do_chksums !< True if checksums are to be output + logical, optional, intent(out) :: do_redundant !< True if redundant points are to be checked + + if (present(do_debug)) do_debug = debug + if (present(do_chksums)) do_chksums = debug_chksums + if (present(do_redundant)) do_redundant = debug_redundant + +end subroutine query_debugging_checks + !> Check for consistency between the duplicated points of a 3-D C-grid vector subroutine check_redundant_vC3d(mesg, u_comp, v_comp, G, is, ie, js, je, & - direction) + direction, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector - !! to be checked for consistency - real, dimension(G%isd:,G%JsdB:,:), intent(in) :: v_comp !< The u-component of the vector - !! to be checked for consistency + real, dimension(G%IsdB:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%isd:,G%JsdB:,:), intent(in) :: v_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] integer, optional, intent(in) :: is !< The starting i-index to check integer, optional, intent(in) :: ie !< The ending i-index to check integer, optional, intent(in) :: js !< The starting j-index to check integer, optional, intent(in) :: je !< The ending j-index to check integer, optional, intent(in) :: direction !< the direction flag to be !! passed to pass_vector + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] + ! Local variables character(len=24) :: mesg_k integer :: k do k=1,size(u_comp,3) - if (k < 10) then ; write(mesg_k,'(" Layer",i2," ")') k - elseif (k < 100) then ; write(mesg_k,'(" Layer",i3," ")') k - elseif (k < 1000) then ; write(mesg_k,'(" Layer",i4," ")') k - else ; write(mesg_k,'(" Layer",i9," ")') k ; endif - + write(mesg_k,'(" Layer ",i0," ")') k call check_redundant_vC2d(trim(mesg)//trim(mesg_k), u_comp(:,:,k), & - v_comp(:,:,k), G, is, ie, js, je, direction) + v_comp(:,:,k), G, is, ie, js, je, direction, unscale) enddo end subroutine check_redundant_vC3d !> Check for consistency between the duplicated points of a 2-D C-grid vector subroutine check_redundant_vC2d(mesg, u_comp, v_comp, G, is, ie, js, je, & - direction) + direction, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector - !! to be checked for consistency - real, dimension(G%isd:,G%JsdB:), intent(in) :: v_comp !< The u-component of the vector - !! to be checked for consistency + real, dimension(G%IsdB:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%isd:,G%JsdB:), intent(in) :: v_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] integer, optional, intent(in) :: is !< The starting i-index to check integer, optional, intent(in) :: ie !< The ending i-index to check integer, optional, intent(in) :: js !< The starting j-index to check integer, optional, intent(in) :: je !< The ending j-index to check integer, optional, intent(in) :: direction !< the direction flag to be !! passed to pass_vector + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables - real :: u_nonsym(G%isd:G%ied,G%jsd:G%jed) - real :: v_nonsym(G%isd:G%ied,G%jsd:G%jed) - real :: u_resym(G%IsdB:G%IedB,G%jsd:G%jed) - real :: v_resym(G%isd:G%ied,G%JsdB:G%JedB) + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input vector while [a] indicates the unscaled (e.g., mks) units to used for output. + real :: u_nonsym(G%isd:G%ied,G%jsd:G%jed) ! A nonsymmetric version of u_comp [A ~> a] + real :: v_nonsym(G%isd:G%ied,G%jsd:G%jed) ! A nonsymmetric version of v_comp [A ~> a] + real :: u_resym(G%IsdB:G%IedB,G%jsd:G%jed) ! A reconstructed symmetric version of u_comp [A ~> a] + real :: v_resym(G%isd:G%ied,G%JsdB:G%JedB) ! A reconstructed symmetric version of v_comp [A ~> a] + real :: sc ! A factor that undoes the scaling for the arrays to give consistent output [a A-1 ~> 1] character(len=128) :: mesg2 integer :: i, j, is_ch, ie_ch, js_ch, je_ch integer :: Isq, Ieq, Jsq, Jeq, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -163,12 +188,14 @@ subroutine check_redundant_vC2d(mesg, u_comp, v_comp, G, is, ie, js, je, & if ((isd == IsdB) .and. (jsd == JsdB)) return endif + sc = 1.0 ; if (present(unscale)) sc = unscale + do i=isd,ied ; do j=jsd,jed u_nonsym(i,j) = u_comp(i,j) ; v_nonsym(i,j) = v_comp(i,j) enddo ; enddo - if (.not.associated(G%Domain_aux)) call MOM_error(FATAL," check_redundant"//& - " called with a non-associated auxiliary domain the grid type.") + if (.not.associated(G%Domain_aux)) call MOM_error(FATAL, & + " check_redundant called with a non-associated auxiliary domain the grid type.") call pass_vector(u_nonsym, v_nonsym, G%Domain_aux, direction) do I=IsdB,IedB ; do j=jsd,jed ; u_resym(I,j) = u_comp(I,j) ; enddo ; enddo @@ -186,8 +213,8 @@ subroutine check_redundant_vC2d(mesg, u_comp, v_comp, G, is, ie, js, je, & if (u_resym(i,j) /= u_comp(i,j) .and. & redundant_prints(3) < max_redundant_prints) then write(mesg2,'(" redundant u-components",2(1pe12.4)," differ by ", & - & 1pe12.4," at i,j = ",2i4," on pe ",i4)') & - u_comp(i,j), u_resym(i,j),u_comp(i,j)-u_resym(i,j),i,j,pe_here() + & 1pe12.4," at i,j = ",I0,",",I0," on pe ",I0)') & + sc*u_comp(i,j), sc*u_resym(i,j), sc*(u_comp(i,j)-u_resym(i,j)), i, j, pe_here() write(0,'(A130)') trim(mesg)//trim(mesg2) redundant_prints(3) = redundant_prints(3) + 1 endif @@ -196,8 +223,8 @@ subroutine check_redundant_vC2d(mesg, u_comp, v_comp, G, is, ie, js, je, & if (v_resym(i,j) /= v_comp(i,j) .and. & redundant_prints(3) < max_redundant_prints) then write(mesg2,'(" redundant v-comps",2(1pe12.4)," differ by ", & - & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)" on pe ",i4)') & - v_comp(i,j), v_resym(i,j),v_comp(i,j)-v_resym(i,j),i,j, & + & 1pe12.4," at i,j = ",I0,",",I0," x,y = ",2(1pe12.4)," on pe ",I0)') & + sc*v_comp(i,j), sc*v_resym(i,j), sc*(v_comp(i,j)-v_resym(i,j)), i, j, & G%geoLonBu(i,j), G%geoLatBu(i,j), pe_here() write(0,'(A155)') trim(mesg)//trim(mesg2) redundant_prints(3) = redundant_prints(3) + 1 @@ -207,42 +234,47 @@ subroutine check_redundant_vC2d(mesg, u_comp, v_comp, G, is, ie, js, je, & end subroutine check_redundant_vC2d !> Check for consistency between the duplicated points of a 3-D scalar at corner points -subroutine check_redundant_sB3d(mesg, array, G, is, ie, js, je) +subroutine check_redundant_sB3d(mesg, array, G, is, ie, js, je, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: array !< The array to be checked for consistency + real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: array !< The array to be checked for consistency in + !! arbitrary, possibly rescaled units [A ~> a] integer, optional, intent(in) :: is !< The starting i-index to check integer, optional, intent(in) :: ie !< The ending i-index to check integer, optional, intent(in) :: js !< The starting j-index to check integer, optional, intent(in) :: je !< The ending j-index to check + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables character(len=24) :: mesg_k integer :: k do k=1,size(array,3) - if (k < 10) then ; write(mesg_k,'(" Layer",i2," ")') k - elseif (k < 100) then ; write(mesg_k,'(" Layer",i3," ")') k - elseif (k < 1000) then ; write(mesg_k,'(" Layer",i4," ")') k - else ; write(mesg_k,'(" Layer",i9," ")') k ; endif - + write(mesg_k,'(" Layer ",i0," ")') k call check_redundant_sB2d(trim(mesg)//trim(mesg_k), array(:,:,k), & - G, is, ie, js, je) + G, is, ie, js, je, unscale) enddo end subroutine check_redundant_sB3d !> Check for consistency between the duplicated points of a 2-D scalar at corner points -subroutine check_redundant_sB2d(mesg, array, G, is, ie, js, je) +subroutine check_redundant_sB2d(mesg, array, G, is, ie, js, je, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%JsdB:), intent(in) :: array !< The array to be checked for consistency + real, dimension(G%IsdB:,G%JsdB:), intent(in) :: array !< The array to be checked for consistency in + !! arbitrary, possibly rescaled units [A ~> a] integer, optional, intent(in) :: is !< The starting i-index to check integer, optional, intent(in) :: ie !< The ending i-index to check integer, optional, intent(in) :: js !< The starting j-index to check integer, optional, intent(in) :: je !< The ending j-index to check + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables - real :: a_nonsym(G%isd:G%ied,G%jsd:G%jed) - real :: a_resym(G%IsdB:G%IedB,G%JsdB:G%JedB) + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units to used for output. + real :: a_nonsym(G%isd:G%ied,G%jsd:G%jed) ! A nonsymmetric version of array [A ~> a] + real :: a_resym(G%IsdB:G%IedB,G%JsdB:G%JedB) ! A reconstructed symmetric version of array [A ~> a] + real :: sc ! A factor that undoes the scaling for the arrays to give consistent output [a A-1 ~> 1] character(len=128) :: mesg2 integer :: i, j, is_ch, ie_ch, js_ch, je_ch integer :: Isq, Ieq, Jsq, Jeq, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -256,12 +288,14 @@ subroutine check_redundant_sB2d(mesg, array, G, is, ie, js, je) if ((isd == IsdB) .and. (jsd == JsdB)) return endif + sc = 1.0 ; if (present(unscale)) sc = unscale + do i=isd,ied ; do j=jsd,jed a_nonsym(i,j) = array(i,j) enddo ; enddo - if (.not.associated(G%Domain_aux)) call MOM_error(FATAL," check_redundant"//& - " called with a non-associated auxiliary domain the grid type.") + if (.not.associated(G%Domain_aux)) call MOM_error(FATAL, & + " check_redundant called with a non-associated auxiliary domain the grid type.") call pass_vector(a_nonsym, a_nonsym, G%Domain_aux, & direction=To_All+Scalar_Pair, stagger=BGRID_NE) @@ -280,8 +314,8 @@ subroutine check_redundant_sB2d(mesg, array, G, is, ie, js, je) if (a_resym(i,j) /= array(i,j) .and. & redundant_prints(2) < max_redundant_prints) then write(mesg2,'(" Redundant points",2(1pe12.4)," differ by ", & - & 1pe12.4," at i,j = ",2i4," on pe ",i4)') & - array(i,j), a_resym(i,j),array(i,j)-a_resym(i,j),i,j,pe_here() + & 1pe12.4," at i,j = ",I0,",",I0," on pe ",I0)') & + sc*array(i,j), sc*a_resym(i,j), sc*(array(i,j)-a_resym(i,j)), i, j, pe_here() write(0,'(A130)') trim(mesg)//trim(mesg2) redundant_prints(2) = redundant_prints(2) + 1 endif @@ -291,54 +325,61 @@ end subroutine check_redundant_sB2d !> Check for consistency between the duplicated points of a 3-D B-grid vector subroutine check_redundant_vB3d(mesg, u_comp, v_comp, G, is, ie, js, je, & - direction) + direction, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: u_comp !< The u-component of the vector - !! to be checked for consistency - real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: v_comp !< The v-component of the vector - !! to be checked for consistency + real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] integer, optional, intent(in) :: is !< The starting i-index to check integer, optional, intent(in) :: ie !< The ending i-index to check integer, optional, intent(in) :: js !< The starting j-index to check integer, optional, intent(in) :: je !< The ending j-index to check integer, optional, intent(in) :: direction !< the direction flag to be !! passed to pass_vector + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables character(len=24) :: mesg_k integer :: k do k=1,size(u_comp,3) - if (k < 10) then ; write(mesg_k,'(" Layer",i2," ")') k - elseif (k < 100) then ; write(mesg_k,'(" Layer",i3," ")') k - elseif (k < 1000) then ; write(mesg_k,'(" Layer",i4," ")') k - else ; write(mesg_k,'(" Layer",i9," ")') k ; endif - + write(mesg_k,'(" Layer ",i0," ")') k call check_redundant_vB2d(trim(mesg)//trim(mesg_k), u_comp(:,:,k), & - v_comp(:,:,k), G, is, ie, js, je, direction) + v_comp(:,:,k), G, is, ie, js, je, direction, unscale) enddo end subroutine check_redundant_vB3d !> Check for consistency between the duplicated points of a 2-D B-grid vector subroutine check_redundant_vB2d(mesg, u_comp, v_comp, G, is, ie, js, je, & - direction) + direction, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%JsdB:), intent(in) :: u_comp !< The u-component of the vector - !! to be checked for consistency - real, dimension(G%IsdB:,G%JsdB:), intent(in) :: v_comp !< The v-component of the vector - !! to be checked for consistency + real, dimension(G%IsdB:,G%JsdB:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%IsdB:,G%JsdB:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] integer, optional, intent(in) :: is !< The starting i-index to check integer, optional, intent(in) :: ie !< The ending i-index to check integer, optional, intent(in) :: js !< The starting j-index to check integer, optional, intent(in) :: je !< The ending j-index to check integer, optional, intent(in) :: direction !< the direction flag to be !! passed to pass_vector + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables - real :: u_nonsym(G%isd:G%ied,G%jsd:G%jed) - real :: v_nonsym(G%isd:G%ied,G%jsd:G%jed) - real :: u_resym(G%IsdB:G%IedB,G%JsdB:G%JedB) - real :: v_resym(G%IsdB:G%IedB,G%JsdB:G%JedB) + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input vector while [a] indicates the unscaled (e.g., mks) units to used for output. + real :: u_nonsym(G%isd:G%ied,G%jsd:G%jed) ! A nonsymmetric version of u_comp [A ~> a] + real :: v_nonsym(G%isd:G%ied,G%jsd:G%jed) ! A nonsymmetric version of v_comp [A ~> a] + real :: u_resym(G%IsdB:G%IedB,G%JsdB:G%JedB) ! A reconstructed symmetric version of u_comp [A ~> a] + real :: v_resym(G%IsdB:G%IedB,G%JsdB:G%JedB) ! A reconstructed symmetric version of v_comp [A ~> a] + real :: sc ! A factor that undoes the scaling for the arrays to give consistent output [a A-1 ~> 1] character(len=128) :: mesg2 integer :: i, j, is_ch, ie_ch, js_ch, je_ch integer :: Isq, Ieq, Jsq, Jeq, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -352,12 +393,14 @@ subroutine check_redundant_vB2d(mesg, u_comp, v_comp, G, is, ie, js, je, & if ((isd == IsdB) .and. (jsd == JsdB)) return endif + sc = 1.0 ; if (present(unscale)) sc = unscale + do i=isd,ied ; do j=jsd,jed u_nonsym(i,j) = u_comp(i,j) ; v_nonsym(i,j) = v_comp(i,j) enddo ; enddo - if (.not.associated(G%Domain_aux)) call MOM_error(FATAL," check_redundant"//& - " called with a non-associated auxiliary domain the grid type.") + if (.not.associated(G%Domain_aux)) call MOM_error(FATAL, & + " check_redundant called with a non-associated auxiliary domain the grid type.") call pass_vector(u_nonsym, v_nonsym, G%Domain_aux, direction, stagger=BGRID_NE) do I=IsdB,IedB ; do J=JsdB,JedB @@ -376,8 +419,8 @@ subroutine check_redundant_vB2d(mesg, u_comp, v_comp, G, is, ie, js, je, & if (u_resym(i,j) /= u_comp(i,j) .and. & redundant_prints(2) < max_redundant_prints) then write(mesg2,'(" redundant u-components",2(1pe12.4)," differ by ", & - & 1pe12.4," at i,j = ",2i4," on pe ",i4)') & - u_comp(i,j), u_resym(i,j),u_comp(i,j)-u_resym(i,j),i,j,pe_here() + & 1pe12.4," at i,j = ",I0,",",I0," on pe ",I0)') & + sc*u_comp(i,j), sc*u_resym(i,j), sc*(u_comp(i,j)-u_resym(i,j)), i, j, pe_here() write(0,'(A130)') trim(mesg)//trim(mesg2) redundant_prints(2) = redundant_prints(2) + 1 endif @@ -386,8 +429,8 @@ subroutine check_redundant_vB2d(mesg, u_comp, v_comp, G, is, ie, js, je, & if (v_resym(i,j) /= v_comp(i,j) .and. & redundant_prints(2) < max_redundant_prints) then write(mesg2,'(" redundant v-comps",2(1pe12.4)," differ by ", & - & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)" on pe ",i4)') & - v_comp(i,j), v_resym(i,j),v_comp(i,j)-v_resym(i,j),i,j, & + & 1pe12.4," at i,j = ",I0,",",I0," x,y = ",2(1pe12.4)," on pe ",I0)') & + sc*v_comp(i,j), sc*v_resym(i,j), sc*(v_comp(i,j)-v_resym(i,j)), i, j, & G%geoLonBu(i,j), G%geoLatBu(i,j), pe_here() write(0,'(A155)') trim(mesg)//trim(mesg2) redundant_prints(2) = redundant_prints(2) + 1 @@ -397,51 +440,58 @@ subroutine check_redundant_vB2d(mesg, u_comp, v_comp, G, is, ie, js, je, & end subroutine check_redundant_vB2d !> Check for consistency between the duplicated points of a 3-D scalar at tracer points -subroutine check_redundant_sT3d(mesg, array, G, is, ie, js, je) +subroutine check_redundant_sT3d(mesg, array, G, is, ie, js, je, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%isd:,G%jsd:,:), intent(in) :: array !< The array to be checked for consistency + real, dimension(G%isd:,G%jsd:,:), intent(in) :: array !< The array to be checked for consistency in + !! arbitrary, possibly rescaled units [A ~> a] integer, optional, intent(in) :: is !< The starting i-index to check integer, optional, intent(in) :: ie !< The ending i-index to check integer, optional, intent(in) :: js !< The starting j-index to check integer, optional, intent(in) :: je !< The ending j-index to check + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables character(len=24) :: mesg_k integer :: k do k=1,size(array,3) - if (k < 10) then ; write(mesg_k,'(" Layer",i2," ")') k - elseif (k < 100) then ; write(mesg_k,'(" Layer",i3," ")') k - elseif (k < 1000) then ; write(mesg_k,'(" Layer",i4," ")') k - else ; write(mesg_k,'(" Layer",i9," ")') k ; endif - + write(mesg_k,'(" Layer ",i0," ")') k call check_redundant_sT2d(trim(mesg)//trim(mesg_k), array(:,:,k), & - G, is, ie, js, je) + G, is, ie, js, je, unscale) enddo end subroutine check_redundant_sT3d !> Check for consistency between the duplicated points of a 2-D scalar at tracer points -subroutine check_redundant_sT2d(mesg, array, G, is, ie, js, je) +subroutine check_redundant_sT2d(mesg, array, G, is, ie, js, je, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%isd:,G%jsd:), intent(in) :: array !< The array to be checked for consistency + real, dimension(G%isd:,G%jsd:), intent(in) :: array !< The array to be checked for consistency in + !! arbitrary, possibly rescaled units [A ~> a] integer, optional, intent(in) :: is !< The starting i-index to check integer, optional, intent(in) :: ie !< The ending i-index to check integer, optional, intent(in) :: js !< The starting j-index to check integer, optional, intent(in) :: je !< The ending j-index to check + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables - real :: a_nonsym(G%isd:G%ied,G%jsd:G%jed) + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units to used for output. + real :: a_nonsym(G%isd:G%ied,G%jsd:G%jed) ! A version of array with halo points updated by message passing [A ~> a] + real :: sc ! A factor that undoes the scaling for the arrays to give consistent output [a A-1 ~> 1] character(len=128) :: mesg2 integer :: i, j, is_ch, ie_ch, js_ch, je_ch - integer :: Isq, Ieq, Jsq, Jeq, isd, ied, jsd, jed + integer :: isd, ied, jsd, jed isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed is_ch = G%isc ; ie_ch = G%iec ; js_ch = G%jsc ; je_ch = G%jec if (present(is)) is_ch = is ; if (present(ie)) ie_ch = ie if (present(js)) js_ch = js ; if (present(js)) je_ch = je + sc = 1.0 ; if (present(unscale)) sc = unscale + ! This only works on points outside of the standard computational domain. if ((is_ch == G%isc) .and. (ie_ch == G%iec) .and. & (js_ch == G%jsc) .and. (je_ch == G%jec)) return @@ -456,8 +506,8 @@ subroutine check_redundant_sT2d(mesg, array, G, is, ie, js, je) if (a_nonsym(i,j) /= array(i,j) .and. & redundant_prints(1) < max_redundant_prints) then write(mesg2,'(" Redundant points",2(1pe12.4)," differ by ", & - & 1pe12.4," at i,j = ",2i4," on pe ",i4)') & - array(i,j), a_nonsym(i,j),array(i,j)-a_nonsym(i,j),i,j,pe_here() + & 1pe12.4," at i,j = ",I0,",",I0," on pe ",I0)') & + sc*array(i,j), sc*a_nonsym(i,j), sc*(array(i,j)-a_nonsym(i,j)), i, j, pe_here() write(0,'(A130)') trim(mesg)//trim(mesg2) redundant_prints(1) = redundant_prints(1) + 1 endif @@ -467,52 +517,59 @@ end subroutine check_redundant_sT2d !> Check for consistency between the duplicated points of a 3-D A-grid vector subroutine check_redundant_vT3d(mesg, u_comp, v_comp, G, is, ie, js, je, & - direction) + direction, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%isd:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector - !! to be checked for consistency - real, dimension(G%isd:,G%jsd:,:), intent(in) :: v_comp !< The v-component of the vector - !! to be checked for consistency + real, dimension(G%isd:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%isd:,G%jsd:,:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] integer, optional, intent(in) :: is !< The starting i-index to check integer, optional, intent(in) :: ie !< The ending i-index to check integer, optional, intent(in) :: js !< The starting j-index to check integer, optional, intent(in) :: je !< The ending j-index to check integer, optional, intent(in) :: direction !< the direction flag to be !! passed to pass_vector + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables character(len=24) :: mesg_k integer :: k do k=1,size(u_comp,3) - if (k < 10) then ; write(mesg_k,'(" Layer",i2," ")') k - elseif (k < 100) then ; write(mesg_k,'(" Layer",i3," ")') k - elseif (k < 1000) then ; write(mesg_k,'(" Layer",i4," ")') k - else ; write(mesg_k,'(" Layer",i9," ")') k ; endif - + write(mesg_k,'(" Layer ",i0," ")') k call check_redundant_vT2d(trim(mesg)//trim(mesg_k), u_comp(:,:,k), & - v_comp(:,:,k), G, is, ie, js, je, direction) + v_comp(:,:,k), G, is, ie, js, je, direction, unscale) enddo end subroutine check_redundant_vT3d !> Check for consistency between the duplicated points of a 2-D A-grid vector subroutine check_redundant_vT2d(mesg, u_comp, v_comp, G, is, ie, js, je, & - direction) + direction, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%isd:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector - !! to be checked for consistency - real, dimension(G%isd:,G%jsd:), intent(in) :: v_comp !< The v-component of the vector - !! to be checked for consistency + real, dimension(G%isd:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%isd:,G%jsd:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] integer, optional, intent(in) :: is !< The starting i-index to check integer, optional, intent(in) :: ie !< The ending i-index to check integer, optional, intent(in) :: js !< The starting j-index to check integer, optional, intent(in) :: je !< The ending j-index to check integer, optional, intent(in) :: direction !< the direction flag to be !! passed to pass_vector + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables - real :: u_nonsym(G%isd:G%ied,G%jsd:G%jed) - real :: v_nonsym(G%isd:G%ied,G%jsd:G%jed) + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input vector while [a] indicates the unscaled (e.g., mks) units to used for output. + real :: u_nonsym(G%isd:G%ied,G%jsd:G%jed) ! A version of u_comp with halo points updated by message passing [A ~> a] + real :: v_nonsym(G%isd:G%ied,G%jsd:G%jed) ! A version of v_comp with halo points updated by message passing [A ~> a] + real :: sc ! A factor that undoes the scaling for the arrays to give consistent output [a A-1 ~> 1] character(len=128) :: mesg2 integer :: i, j, is_ch, ie_ch, js_ch, je_ch @@ -525,6 +582,8 @@ subroutine check_redundant_vT2d(mesg, u_comp, v_comp, G, is, ie, js, je, & if (present(is)) is_ch = is ; if (present(ie)) ie_ch = ie if (present(js)) js_ch = js ; if (present(js)) je_ch = je + sc = 1.0 ; if (present(unscale)) sc = unscale + ! This only works on points outside of the standard computational domain. if ((is_ch == G%isc) .and. (ie_ch == G%iec) .and. & (js_ch == G%jsc) .and. (je_ch == G%jec)) return @@ -539,8 +598,8 @@ subroutine check_redundant_vT2d(mesg, u_comp, v_comp, G, is, ie, js, je, & if (u_nonsym(i,j) /= u_comp(i,j) .and. & redundant_prints(1) < max_redundant_prints) then write(mesg2,'(" redundant u-components",2(1pe12.4)," differ by ", & - & 1pe12.4," at i,j = ",2i4," on pe ",i4)') & - u_comp(i,j), u_nonsym(i,j),u_comp(i,j)-u_nonsym(i,j),i,j,pe_here() + & 1pe12.4," at i,j = ",I0,",",I0," on pe ",I0)') & + sc*u_comp(i,j), sc*u_nonsym(i,j), sc*(u_comp(i,j)-u_nonsym(i,j)), i, j, pe_here() write(0,'(A130)') trim(mesg)//trim(mesg2) redundant_prints(1) = redundant_prints(1) + 1 endif @@ -549,8 +608,8 @@ subroutine check_redundant_vT2d(mesg, u_comp, v_comp, G, is, ie, js, je, & if (v_nonsym(i,j) /= v_comp(i,j) .and. & redundant_prints(1) < max_redundant_prints) then write(mesg2,'(" redundant v-comps",2(1pe12.4)," differ by ", & - & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)" on pe ",i4)') & - v_comp(i,j), v_nonsym(i,j),v_comp(i,j)-v_nonsym(i,j),i,j, & + & 1pe12.4," at i,j = ",I0,",",I0," x,y = ",2(1pe12.4)," on pe ",I0)') & + sc*v_comp(i,j), sc*v_nonsym(i,j), sc*(v_comp(i,j)-v_nonsym(i,j)), i, j, & G%geoLonBu(i,j), G%geoLatBu(i,j), pe_here() write(0,'(A155)') trim(mesg)//trim(mesg2) redundant_prints(1) = redundant_prints(1) + 1 @@ -559,163 +618,202 @@ subroutine check_redundant_vT2d(mesg, u_comp, v_comp, G, is, ie, js, je, & end subroutine check_redundant_vT2d + +! It appears that none of the other routines in this file are ever called. + !> Do a checksum and redundant point check on a 3d C-grid vector. -subroutine chksum_vec_C3d(mesg, u_comp, v_comp, G, halos, scalars) +subroutine chksum_vec_C3d(mesg, u_comp, v_comp, G, halos, scalars, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector - real, dimension(G%isd:,G%JsdB:,:), intent(in) :: v_comp !< The v-component of the vector + real, dimension(G%IsdB:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%isd:,G%JsdB:,:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of !! scalars that are being checked. + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars if (debug_chksums) then - call uvchksum(mesg, u_comp, v_comp, G%HI, halos) + call uvchksum(mesg, u_comp, v_comp, G%HI, halos, unscale=unscale) endif if (debug_redundant) then if (are_scalars) then - call check_redundant_C(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair) + call check_redundant_C(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair, unscale=unscale) else - call check_redundant_C(mesg, u_comp, v_comp, G) + call check_redundant_C(mesg, u_comp, v_comp, G, unscale=unscale) endif endif end subroutine chksum_vec_C3d !> Do a checksum and redundant point check on a 2d C-grid vector. -subroutine chksum_vec_C2d(mesg, u_comp, v_comp, G, halos, scalars) +subroutine chksum_vec_C2d(mesg, u_comp, v_comp, G, halos, scalars, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector - real, dimension(G%isd:,G%JsdB:), intent(in) :: v_comp !< The v-component of the vector + real, dimension(G%IsdB:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%isd:,G%JsdB:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of !! scalars that are being checked. + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars if (debug_chksums) then - call uvchksum(mesg, u_comp, v_comp, G%HI, halos) + call uvchksum(mesg, u_comp, v_comp, G%HI, halos, unscale=unscale) endif if (debug_redundant) then if (are_scalars) then - call check_redundant_C(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair) + call check_redundant_C(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair, unscale=unscale) else - call check_redundant_C(mesg, u_comp, v_comp, G) + call check_redundant_C(mesg, u_comp, v_comp, G, unscale=unscale) endif endif end subroutine chksum_vec_C2d !> Do a checksum and redundant point check on a 3d B-grid vector. -subroutine chksum_vec_B3d(mesg, u_comp, v_comp, G, halos, scalars) +subroutine chksum_vec_B3d(mesg, u_comp, v_comp, G, halos, scalars, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: u_comp !< The u-component of the vector - real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: v_comp !< The v-component of the vector + real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of !! scalars that are being checked. + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars if (debug_chksums) then - call Bchksum(u_comp, mesg//"(u)", G%HI, halos) - call Bchksum(v_comp, mesg//"(v)", G%HI, halos) + call Bchksum(u_comp, mesg//"(u)", G%HI, halos, unscale=unscale) + call Bchksum(v_comp, mesg//"(v)", G%HI, halos, unscale=unscale) endif if (debug_redundant) then if (are_scalars) then - call check_redundant_B(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair) + call check_redundant_B(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair, unscale=unscale) else - call check_redundant_B(mesg, u_comp, v_comp, G) + call check_redundant_B(mesg, u_comp, v_comp, G, unscale=unscale) endif endif end subroutine chksum_vec_B3d ! Do a checksum and redundant point check on a 2d B-grid vector. -subroutine chksum_vec_B2d(mesg, u_comp, v_comp, G, halos, scalars, symmetric) +subroutine chksum_vec_B2d(mesg, u_comp, v_comp, G, halos, scalars, symmetric, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%JsdB:), intent(in) :: u_comp !< The u-component of the vector - real, dimension(G%IsdB:,G%JsdB:), intent(in) :: v_comp !< The v-component of the vector + real, dimension(G%IsdB:,G%JsdB:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%IsdB:,G%JsdB:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of !! scalars that are being checked. logical, optional, intent(in) :: symmetric !< If true, do the checksums on the !! full symmetric computational domain. + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars if (debug_chksums) then - call Bchksum(u_comp, mesg//"(u)", G%HI, halos, symmetric=symmetric) - call Bchksum(v_comp, mesg//"(v)", G%HI, halos, symmetric=symmetric) + call Bchksum(u_comp, mesg//"(u)", G%HI, halos, symmetric=symmetric, unscale=unscale) + call Bchksum(v_comp, mesg//"(v)", G%HI, halos, symmetric=symmetric, unscale=unscale) endif if (debug_redundant) then if (are_scalars) then - call check_redundant_B(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair) + call check_redundant_B(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair, unscale=unscale) else - call check_redundant_B(mesg, u_comp, v_comp, G) + call check_redundant_B(mesg, u_comp, v_comp, G, unscale=unscale) endif endif end subroutine chksum_vec_B2d !> Do a checksum and redundant point check on a 3d C-grid vector. -subroutine chksum_vec_A3d(mesg, u_comp, v_comp, G, halos, scalars) +subroutine chksum_vec_A3d(mesg, u_comp, v_comp, G, halos, scalars, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%isd:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector - real, dimension(G%isd:,G%jsd:,:), intent(in) :: v_comp !< The v-component of the vector + real, dimension(G%isd:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%isd:,G%jsd:,:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of !! scalars that are being checked. + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars if (debug_chksums) then - call hchksum(u_comp, mesg//"(u)", G%HI, halos) - call hchksum(v_comp, mesg//"(v)", G%HI, halos) + call hchksum(u_comp, mesg//"(u)", G%HI, halos, unscale=unscale) + call hchksum(v_comp, mesg//"(v)", G%HI, halos, unscale=unscale) endif if (debug_redundant) then if (are_scalars) then - call check_redundant_T(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair) + call check_redundant_T(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair, unscale=unscale) else - call check_redundant_T(mesg, u_comp, v_comp, G) + call check_redundant_T(mesg, u_comp, v_comp, G, unscale=unscale) endif endif end subroutine chksum_vec_A3d !> Do a checksum and redundant point check on a 2d C-grid vector. -subroutine chksum_vec_A2d(mesg, u_comp, v_comp, G, halos, scalars) +subroutine chksum_vec_A2d(mesg, u_comp, v_comp, G, halos, scalars, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%isd:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector - real, dimension(G%isd:,G%jsd:), intent(in) :: v_comp !< The v-component of the vector + real, dimension(G%isd:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%isd:,G%jsd:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of !! scalars that are being checked. + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars if (debug_chksums) then - call hchksum(u_comp, mesg//"(u)", G%HI, halos) - call hchksum(v_comp, mesg//"(v)", G%HI, halos) + call hchksum(u_comp, mesg//"(u)", G%HI, halos, unscale=unscale) + call hchksum(v_comp, mesg//"(v)", G%HI, halos, unscale=unscale) endif if (debug_redundant) then if (are_scalars) then - call check_redundant_T(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair) + call check_redundant_T(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair, unscale=unscale) else - call check_redundant_T(mesg, u_comp, v_comp, G) + call check_redundant_T(mesg, u_comp, v_comp, G, unscale=unscale) endif endif @@ -723,14 +821,21 @@ end subroutine chksum_vec_A2d !> This function returns the sum over computational domain of all !! processors of hThick*stuff, where stuff is a 3-d array at tracer points. -function totalStuff(HI, hThick, areaT, stuff) +function totalStuff(HI, hThick, areaT, stuff, unscale) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: hThick !< The array of thicknesses to use as weights - real, dimension(HI%isd:,HI%jsd:), intent(in) :: areaT !< The array of cell areas [m2] - real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: stuff !< The array of stuff to be summed - real :: totalStuff !< the globally integrated amoutn of stuff + !! [H ~> m or kg m-2] or [m] or [kg m-2] + real, dimension(HI%isd:,HI%jsd:), intent(in) :: areaT !< The array of cell areas [L2 ~> m2] or [m2] + real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: stuff !< The array of stuff to be summed in arbitrary + !! units [A ~> a] or [a] + real, optional, intent(in) :: unscale !< A factor that is used to undo scaling of the array + !! and the cell mass or volume before it is summed in + !! [a m3 A-1 H-1 L-2 ~> 1] or [a kg A-1 H-1 L-2 ~> 1] + real :: totalStuff !< the globally integrated amount of stuff + !! [A H L2 ~> a m3 or a kg] or [a m3] ! Local variables - real, dimension(HI%isc:HI%iec, HI%jsc:HI%jec) :: tmp_for_sum + real :: tmp_for_sum(HI%isc:HI%iec, HI%jsc:HI%jec) ! The column integrated amount of stuff in a + ! cell [A H L2 ~> a m3 or a kg] or [a m3] integer :: i, j, k, nz nz = size(hThick,3) @@ -738,48 +843,79 @@ function totalStuff(HI, hThick, areaT, stuff) do k=1,nz ; do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec tmp_for_sum(i,j) = tmp_for_sum(i,j) + hThick(i,j,k) * stuff(i,j,k) * areaT(i,j) enddo ; enddo ; enddo - totalStuff = reproducing_sum(tmp_for_sum) + totalStuff = reproducing_sum(tmp_for_sum, unscale=unscale) end function totalStuff !> This subroutine display the total thickness, temperature and salinity !! as well as the change since the last call. -subroutine totalTandS(HI, hThick, areaT, temperature, salinity, mesg) +subroutine totalTandS(HI, hThick, areaT, temperature, salinity, mesg, US, H_to_mks) type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: hThick !< The array of thicknesses to use as weights - real, dimension(HI%isd:,HI%jsd:), intent(in) :: areaT !< The array of cell areas [m2] - real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: temperature !< The temperature field to sum - real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: salinity !< The salinity field to sum + !! [H ~> m or kg m-2] or [m] or [kg m-2] + real, dimension(HI%isd:,HI%jsd:), intent(in) :: areaT !< The array of cell areas [L2 ~> m2] or [m2] + real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: temperature !< The temperature field to sum [C ~> degC] or [degC] + real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: salinity !< The salinity field to sum [S ~> ppt] or [ppt] character(len=*), intent(in) :: mesg !< An identifying message + type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type + real, optional, intent(in) :: H_to_MKS !< A constant that translates thickness units to its + !! MKS units (m or kg m-2) based on whether the model is + !! Boussinesq [m H-1 ~> 1] or not [kg m-2 H-1 ~> 1] ! NOTE: This subroutine uses "save" data which is not thread safe and is purely for ! extreme debugging without a proper debugger. - real, save :: totalH = 0., totalT = 0., totalS = 0. + real, save :: totalH = 0. ! The total ocean volume or mass, saved for the next + ! call [H L2 ~> m3 or kg] or [m3] or [kg] + real, save :: totalT = 0. ! The total volume integrated ocean temperature, saved for the next + ! call [C H L2 ~> degC m3 or degC kg] or [degC m3] or [degC kg] + real, save :: totalS = 0. ! The total volume integrated ocean salinity, saved for the next + ! call [S H L2 ~> ppt m3 or ppt kg] or [ppt m3] or [ppt kg] ! Local variables logical, save :: firstCall = .true. - real, dimension(HI%isc:HI%iec, HI%jsc:HI%jec) :: tmp_for_sum - real :: thisH, thisT, thisS, delH, delT, delS + real :: tmp_for_sum(HI%isc:HI%iec, HI%jsc:HI%jec) ! The volume of each column [H L2 ~> m3 or kg] or [m3] or [kg] + real :: thisH, delH ! The total ocean volume and the change from the last call [H L2 ~> m3 or kg] or [m3] or [kg] + real :: thisT, delT ! The current total volume integrated temperature and the change from the last + ! call [C H L2 ~> degC m3 or degC kg] or [degC m3] or [degC kg] + real :: thisS, delS ! The current total volume integrated salinity and the change from the last + ! call [S H L2 ~> ppt m3 or ppt kg] or [ppt m3] or [ppt kg] + real :: H_unscale ! A constant that translates thickness units to its MKS units (m or kg m-2) based on + ! whether the model is Boussinesq [m H-1 ~> 1] or non-Boussinesq [kg m-2 H-1 ~> 1] + real :: HL2_unscale ! An overall unscaling factor for cell mass or volume [m3 H-1 L-2 ~> 1] or [kg H-1 L-2 ~> 1] + real :: T_unscale ! An overall unscaling factor for cell-integrated temperature [degC m3 C-1 H-1 L-2 ~> 1] or + ! [degC kg C-1 H-1 L-2 ~> 1] + real :: S_unscale ! An overall unscaling factor for cell-integrated salinity [ppt m3 S-1 H-1 L-2 ~> 1] or + ! [ppt kg S-1 H-1 L-2 ~> 1] integer :: i, j, k, nz + H_unscale = 1.0 ; if (present(H_to_mks)) H_unscale = H_to_mks + if (present(US)) then + HL2_unscale = US%L_to_m**2 * H_unscale + T_unscale = US%C_to_degC * HL2_unscale ; S_unscale = US%S_to_ppt * HL2_unscale + else + HL2_unscale = H_unscale + T_unscale = HL2_unscale ; S_unscale = HL2_unscale + endif + nz = size(hThick,3) tmp_for_sum(:,:) = 0.0 do k=1,nz ; do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec tmp_for_sum(i,j) = tmp_for_sum(i,j) + hThick(i,j,k) * areaT(i,j) enddo ; enddo ; enddo - thisH = reproducing_sum(tmp_for_sum) - thisT = totalStuff(HI, hThick, areaT, temperature) - thisS = totalStuff(HI, hThick, areaT, salinity) + thisH = reproducing_sum(tmp_for_sum, unscale=HL2_unscale) + thisT = totalStuff(HI, hThick, areaT, temperature, unscale=T_unscale) + thisS = totalStuff(HI, hThick, areaT, salinity, unscale=S_unscale) if (is_root_pe()) then if (firstCall) then totalH = thisH ; totalT = thisT ; totalS = thisS - write(0,*) 'Totals H,T,S:',thisH,thisT,thisS,' ',mesg + write(stdout,*) 'Totals H,T,S:', thisH*HL2_unscale, thisT*T_unscale, thisS*S_unscale, ' ', mesg firstCall = .false. else delH = thisH - totalH delT = thisT - totalT delS = thisS - totalS totalH = thisH ; totalT = thisT ; totalS = thisS - write(0,*) 'Tot/del H,T,S:',thisH,thisT,thisS,delH,delT,delS,' ',mesg + write(0,*) 'Tot/del H,T,S:', thisH*HL2_unscale, thisT*T_unscale, thisS*S_unscale, & + delH*HL2_unscale, delT*T_unscale, delS*S_unscale, ' ', mesg endif endif @@ -788,11 +924,13 @@ end subroutine totalTandS !> Returns false if the column integral of a given quantity is within roundoff logical function check_column_integral(nk, field, known_answer) integer, intent(in) :: nk !< Number of levels in column - real, dimension(nk), intent(in) :: field !< Field to be summed - real, optional, intent(in) :: known_answer !< If present is the expected sum, + real, dimension(nk), intent(in) :: field !< Field to be summed [arbitrary] + real, optional, intent(in) :: known_answer !< If present is the expected sum [arbitrary], !! If missing, assumed zero ! Local variables - real :: u_sum, error, expected + real :: u_sum ! The vertical sum of the field [arbitrary] + real :: error ! An estimate of the roundoff error in the sum [arbitrary] + real :: expected ! The expected vertical sum [arbitrary] integer :: k u_sum = field(1) @@ -824,12 +962,15 @@ end function check_column_integral logical function check_column_integrals(nk_1, field_1, nk_2, field_2, missing_value) integer, intent(in) :: nk_1 !< Number of levels in field 1 integer, intent(in) :: nk_2 !< Number of levels in field 2 - real, dimension(nk_1), intent(in) :: field_1 !< First field to be summed - real, dimension(nk_2), intent(in) :: field_2 !< Second field to be summed + real, dimension(nk_1), intent(in) :: field_1 !< First field to be summed [arbitrary] + real, dimension(nk_2), intent(in) :: field_2 !< Second field to be summed [arbitrary] real, optional, intent(in) :: missing_value !< If column contains missing values, - !! mask them from the sum + !! mask them from the sum [arbitrary] ! Local variables - real :: u1_sum, error1, u2_sum, error2, misval + real :: u1_sum, u2_sum ! The vertical sums of the two fields [arbitrary] + real :: error1, error2 ! Estimates of the roundoff errors in the sums [arbitrary] + real :: misval ! The missing value flag, indicating elements that are to be omitted + ! from the sums [arbitrary] integer :: k ! Assign missing value @@ -844,7 +985,7 @@ logical function check_column_integrals(nk_1, field_1, nk_2, field_2, missing_va ! Reintegrate and sum roundoff errors do k=2,nk_1 - if (field_1(k)/=misval) then + if (field_1(k) /= misval) then u1_sum = u1_sum + field_1(k) error1 = error1 + EPSILON(u1_sum)*MAX(ABS(u1_sum),ABS(field_1(k))) endif @@ -855,7 +996,7 @@ logical function check_column_integrals(nk_1, field_1, nk_2, field_2, missing_va ! Reintegrate and sum roundoff errors do k=2,nk_2 - if (field_2(k)/=misval) then + if (field_2(k) /= misval) then u2_sum = u2_sum + field_2(k) error2 = error2 + EPSILON(u2_sum)*MAX(ABS(u2_sum),ABS(field_2(k))) endif diff --git a/src/diagnostics/MOM_diagnose_KdWork.F90 b/src/diagnostics/MOM_diagnose_KdWork.F90 new file mode 100644 index 0000000000..b981da9af1 --- /dev/null +++ b/src/diagnostics/MOM_diagnose_KdWork.F90 @@ -0,0 +1,1180 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Provides diagnostics of work due to a given diffusivity +module MOM_diagnose_kdwork + +use MOM_diag_mediator, only : diag_ctrl, time_type, post_data, register_diag_field +use MOM_diag_mediator, only : register_scalar_field +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_spatial_means, only : global_area_integral + +implicit none ; private + +#include + +public vbf_CS +public kdwork_diagnostics +public Allocate_VBF_CS +public Deallocate_VBF_CS +public KdWork_init +public KdWork_end + +!> This structure has memory for used in calculating diagnostics of diffusivity +!! many of the diffusivity diagnostics are copies of other 3d arrays. It could +!! be written more efficiently, but it is less intrusive to copy into this structure +!! and do all calculations in this module. These diagnostics may be expensive for +!! routine use. +type vbf_CS + ! 3d varying Kd contributions + real, pointer, dimension(:,:,:) :: & + Bflx_salt => NULL(), & !< Salinity contribution to buoyancy flux at interfaces + !! [H Z T-3 ~> m2 s-3 or W m-3] + Bflx_temp => NULL(), & !< Temperature contribution to buoyancy flux at interfaces + !! [H Z T-3 ~> m2 s-3 or W m-3] + Bflx_salt_dz => NULL(), & !< Salinity contribution to integral of buoyancy flux over layer + !! [H Z2 T-3 ~> m3 s-3 or W m-2] + Bflx_temp_dz => NULL(), & !< Temperature contribution to integral of buoyancy flux over layer + !! [H Z2 T-3 ~> m3 s-3 or W m-2] + ! The following are all allocatable arrays that store copies of process driven Kd, so that + ! the process driven buoyancy flux and work can be derived at the end of the time step. + Kd_salt => NULL(), & !< total diapycnal diffusivity of salt at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_temp => NULL(), & !< total diapycnal diffusivity of heat at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_BBL => NULL(), & !< diapycnal diffusivity due to BBL at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_ePBL => NULL(), & !< diapycnal diffusivity due to ePBL at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_KS => NULL(), & !< diapycnal diffusivity due to Kappa Shear at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_bkgnd => NULL(), & !< diapycnal diffusivity due to Kd_bkgnd at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_ddiff_S => NULL(), &!< diapycnal diffusivity due to double diffusion of salt at interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_ddiff_T => NULL(), &!< diapycnal diffusivity due to double diffusion of heat at interfaces + !![H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_leak => NULL(), & !< diapycnal diffusivity due to Kd_leak at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_quad => NULL(), & !< diapycnal diffusivity due to Kd_quad at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_itidal => NULL(), & !< diapycnal diffusivity due to Kd_itidal at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_Froude => NULL(), & !< diapycnal diffusivity due to Kd_Froude at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_slope => NULL(), & !< diapycnal diffusivity due to Kd_slope at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_lowmode => NULL(), &!< diapycnal diffusivity due to Kd_lowmode at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_Niku => NULL(), & !< diapycnal diffusivity due to Kd_Niku at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_itides => NULL() !< diapycnal diffusivity due to Kd_itides at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + + ! Constant Kd contributions + real :: Kd_add !< spatially uniform additional diapycnal diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + !! a diagnostic for this diffusivity is not yet included, but this makes it straightforward to add + + !>@{ Diagnostic IDs + integer :: id_Bdif = -1, id_Bdif_salt = -1, id_Bdif_temp = -1 + integer :: id_Bdif_dz = -1, id_Bdif_salt_dz = -1, id_Bdif_temp_dz = -1 + integer :: id_Bdif_idz = -1, id_Bdif_salt_idz = -1, id_Bdif_temp_idz = -1 + integer :: id_Bdif_idV = -1, id_Bdif_salt_idV = -1, id_Bdif_temp_idV = -1 + integer :: id_Bdif_ePBL = -1, id_Bdif_dz_ePBL = -1, id_Bdif_idz_ePBL = -1, id_Bdif_idV_ePBL = -1 + integer :: id_Bdif_BBL = -1, id_Bdif_dz_BBL = -1, id_Bdif_idz_BBL = -1, id_Bdif_idV_BBL = -1 + integer :: id_Bdif_KS = -1, id_Bdif_dz_KS = -1, id_Bdif_idz_KS = -1, id_Bdif_idV_KS = -1 + integer :: id_Bdif_bkgnd = -1, id_Bdif_dz_bkgnd = -1, id_Bdif_idz_bkgnd = -1, id_Bdif_idV_bkgnd = -1 + integer :: id_Bdif_ddiff_temp = -1, id_Bdif_ddiff_salt = -1 + integer :: id_Bdif_dz_ddiff_temp = -1, id_Bdif_dz_ddiff_salt = -1 + integer :: id_Bdif_idz_ddiff_temp = -1, id_Bdif_idz_ddiff_salt = -1 + integer :: id_Bdif_idV_ddiff_temp = -1, id_Bdif_idV_ddiff_salt = -1 + integer :: id_Bdif_leak = -1, id_Bdif_dz_leak = -1, id_Bdif_idz_leak = -1, id_Bdif_idV_leak = -1 + integer :: id_Bdif_quad = -1, id_Bdif_dz_quad = -1, id_Bdif_idz_quad = -1, id_Bdif_idV_quad = -1 + integer :: id_Bdif_itidal = -1, id_Bdif_dz_itidal = -1, id_Bdif_idz_itidal = -1, id_Bdif_idV_itidal = -1 + integer :: id_Bdif_Froude = -1, id_Bdif_dz_Froude = -1, id_Bdif_idz_Froude = -1, id_Bdif_idV_Froude = -1 + integer :: id_Bdif_slope = -1, id_Bdif_dz_slope = -1, id_Bdif_idz_slope = -1, id_Bdif_idV_slope = -1 + integer :: id_Bdif_lowmode = -1, id_Bdif_dz_lowmode = -1, id_Bdif_idz_lowmode = -1, id_Bdif_idV_lowmode = -1 + integer :: id_Bdif_Niku = -1, id_Bdif_dz_Niku = -1, id_Bdif_idz_Niku = -1, id_Bdif_idV_Niku = -1 + integer :: id_Bdif_itides = -1, id_Bdif_dz_itides = -1, id_Bdif_idz_itides = -1, id_Bdif_idV_itides = -1 + !>@} + + logical :: do_bflx_salt = .false. !< Logical flag to indicate if N2_salt should be computed + logical :: do_bflx_temp = .false. !< Logical flag to indicate if N2_temp should be computed + logical :: do_bflx_salt_dz = .false. !< Logical flag to indicate if N2_salt should be computed + logical :: do_bflx_temp_dz = .false. !< Logical flag to indicate if N2_temp should be computed + +end type vbf_CS + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +contains + +!> Loop over all implemented diffusivities to diagnose and output Kd Work/buoyancy fluxes +subroutine KdWork_Diagnostics(G,GV,US,diag,VBF,N2_Salt,N2_Temp,dz) + type(ocean_grid_type), intent(in) :: G !< Grid type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(diag_ctrl), target, intent(inout) :: diag !< regulates diagnostic output + type (vbf_CS), intent(inout) :: VBF !< Vertical buoyancy flux structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(in) :: N2_Salt !< Buoyancy frequency [T-2 ~> s-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(in) :: N2_Temp !< Buoyancy frequency [T-2 ~> s-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: dz !< Grid spacing [Z ~> m] + + ! Work arrays for computing buoyancy flux integrals + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: work3d_i + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: work3d_l + real, dimension(SZI_(G),SZJ_(G)) :: work2d, work2d_salt, work2d_temp + real :: work, work_salt, work_temp + + integer :: i, j, k, nz, isc, iec, jsc, jec + + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + + nz = GV%ke + + ! Compute total fluxes + if (VBF%id_Bdif_dz>0 .or. VBF%id_Bdif_salt_dz>0 .or. VBF%id_Bdif_temp_dz>0 .or. & + VBF%id_Bdif_idz>0 .or. VBF%id_Bdif_salt_idz>0 .or. VBF%id_Bdif_temp_idz>0 .or. & + VBF%id_Bdif_idV>0 .or. VBF%id_Bdif_salt_idV>0 .or. VBF%id_Bdif_temp_idV>0 ) then ! Doing vertical integrals + ! Do Salt + if (VBF%id_Bdif_salt_dz>0 .or. VBF%id_Bdif_dz>0 .or. VBF%id_Bdif_salt>0 .or. VBF%id_Bdif>0 .or. & + VBF%id_Bdif_idz>0 .or. VBF%id_Bdif_salt_idz>0 .or. VBF%id_Bdif_idV>0 .or. VBF%id_Bdif_salt_idV>0) & + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_salt, VBF%Bflx_salt, dz=dz, Bdif_flx_dz=VBF%Bflx_salt_dz) + ! Do Temp + if (VBF%id_Bdif_temp_dz>0 .or. VBF%id_Bdif_dz>0 .or. VBF%id_Bdif_temp>0 .or. VBF%id_Bdif>0 .or. & + VBF%id_Bdif_idz>0 .or. VBF%id_Bdif_temp_idz>0 .or. VBF%id_Bdif_idV>0 .or. VBF%id_Bdif_temp_idV>0) & + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_temp, VBF%Bflx_temp, dz=dz, Bdif_flx_dz=VBF%Bflx_temp_dz) + if (VBF%id_Bdif_temp_idz>0 .or. VBF%id_Bdif_idz>0) then + work2d_temp(:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work2d_temp(i,j) = work2d_temp(i,j) + VBF%Bflx_temp_dz(i,j,k) + enddo ; enddo ; enddo + endif + if (VBF%id_Bdif_temp_idV>0 .or. VBF%id_Bdif_idV>0) then + work_temp = 0.0 + do k = 1,nz + work_temp = work_temp + global_area_integral(VBF%Bflx_temp_dz(:,:,k), G, & + tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + enddo + endif + if (VBF%id_Bdif_salt_idz>0 .or. VBF%id_Bdif_idz>0) then + work2d_salt(:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work2d_salt(i,j) = work2d_salt(i,j) + VBF%Bflx_salt_dz(i,j,k) + enddo ; enddo ; enddo + endif + if (VBF%id_Bdif_salt_idV>0 .or. VBF%id_Bdif_idV>0) then + work_salt = 0.0 + do k = 1,nz + work_salt = work_salt + global_area_integral(VBF%Bflx_salt_dz(:,:,k), G, & + tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + enddo + endif + work = work_temp + work_salt + do j = jsc,jec ; do i = isc,iec + work2d(i,j) = work2d_temp(i,j) + work2d_salt(i,j) + enddo ; enddo + elseif (VBF%id_Bdif>0 .or. VBF%id_Bdif_salt>0 .or. VBF%id_Bdif_temp>0) then ! Not doing vertical integrals + ! Do Salt + if (VBF%id_Bdif_salt>0 .or. VBF%id_Bdif>0) & + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_salt, VBF%Bflx_salt) + if (VBF%id_Bdif_temp>0 .or. VBF%id_Bdif>0) & + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_temp, VBF%Bflx_temp) + endif + ! Post total fluxes + if (VBF%id_Bdif_salt>0) call post_data(VBF%id_Bdif_salt, VBF%Bflx_salt, diag) + if (VBF%id_Bdif_temp>0) call post_data(VBF%id_Bdif_temp, VBF%Bflx_temp, diag) + if (VBF%id_Bdif>0) then + work3d_i(:,:,:) = 0.0 + do k = 1,nz+1 ; do j = jsc,jec ; do i = isc,iec + work3d_i(i,j,k) = VBF%Bflx_temp(i,j,k) + VBF%Bflx_salt(i,j,k) + enddo ; enddo ; enddo + call post_data(VBF%id_Bdif, work3d_i, diag) + endif + if (VBF%id_Bdif_salt_dz>0) call post_data(VBF%id_Bdif_salt_dz, VBF%Bflx_salt_dz, diag) + if (VBF%id_Bdif_temp_dz>0) call post_data(VBF%id_Bdif_temp_dz, VBF%Bflx_temp_dz, diag) + if (VBF%id_Bdif_dz>0) then + work3d_l(:,:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work3d_l(i,j,k) = VBF%Bflx_temp_dz(i,j,k) + VBF%Bflx_salt_dz(i,j,k) + enddo ; enddo ; enddo + call post_data(VBF%id_Bdif_dz, work3d_l, diag) + endif + if (VBF%id_Bdif_salt_idz>0) call post_data(VBF%id_Bdif_salt_idz, work2d_salt, diag) + if (VBF%id_Bdif_temp_idz>0) call post_data(VBF%id_Bdif_temp_idz, work2d_temp, diag) + if (VBF%id_Bdif_idz>0) call post_data(VBF%id_Bdif_idz, work2d, diag) + if (VBF%id_Bdif_salt_idV>0) call post_data(VBF%id_Bdif_salt_idV, work_salt, diag) + if (VBF%id_Bdif_temp_idV>0) call post_data(VBF%id_Bdif_temp_idV, work_temp, diag) + if (VBF%id_Bdif_idV>0) call post_data(VBF%id_Bdif_idV, work, diag) + + ! Compute ePBL fluxes + if (VBF%id_Bdif_dz_ePBL>0.or.VBF%id_Bdif_idz_ePBL>0.or.VBF%id_Bdif_idV_ePBL>0) then + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_ePBL, VBF%Bflx_salt, dz=dz, Bdif_flx_dz=VBF%Bflx_salt_dz) + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_ePBL, VBF%Bflx_temp, dz=dz, Bdif_flx_dz=VBF%Bflx_temp_dz) + if (VBF%id_Bdif_idz_ePBL>0) then + work2d(:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work2d(i,j) = work2d(i,j) + (VBF%Bflx_salt_dz(i,j,k) + VBF%Bflx_temp_dz(i,j,k)) + enddo ; enddo ; enddo + endif + if (VBF%id_Bdif_idV_ePBL>0) then + work = 0.0 + do k = 1,nz + work = work + & + (global_area_integral(VBF%Bflx_temp_dz(:,:,k), G, tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + & + global_area_integral(VBF%Bflx_salt_dz(:,:,k), G, tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3)) + enddo + endif + elseif (VBF%id_Bdif_ePBL>0) then + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_ePBL, VBF%Bflx_salt) + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_ePBL, VBF%Bflx_temp) + endif + ! Post ePBL fluxes + if (VBF%id_Bdif_ePBL>0) then + work3d_i(:,:,:) = 0.0 + do k = 1,nz+1 ; do j = jsc,jec ; do i = isc,iec + work3d_i(i,j,k) = VBF%Bflx_temp(i,j,k) + VBF%Bflx_salt(i,j,k) + enddo ; enddo ; enddo + call post_data(VBF%id_Bdif_ePBL, work3d_i, diag) + endif + if (VBF%id_Bdif_dz_ePBL>0) then + work3d_l(:,:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work3d_l(i,j,k) = VBF%Bflx_temp_dz(i,j,k) + VBF%Bflx_salt_dz(i,j,k) + enddo ; enddo ; enddo + call post_data(VBF%id_Bdif_dz_ePBL, work3d_l, diag) + endif + if (VBF%id_Bdif_idz_ePBL>0) call post_data(VBF%id_Bdif_idz_ePBL, work2d, diag) + if (VBF%id_Bdif_idV_ePBL>0) call post_data(VBF%id_Bdif_idV_ePBL, work, diag) + + ! Compute BBL fluxes + if (VBF%id_Bdif_dz_BBL>0.or.VBF%id_Bdif_idz_BBL>0.or.VBF%id_Bdif_idV_BBL>0) then + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_BBL, VBF%Bflx_salt, dz=dz, Bdif_flx_dz=VBF%Bflx_salt_dz) + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_BBL, VBF%Bflx_temp, dz=dz, Bdif_flx_dz=VBF%Bflx_temp_dz) + if (VBF%id_Bdif_idz_BBL>0) then + work2d(:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work2d(i,j) = work2d(i,j) + (VBF%Bflx_salt_dz(i,j,k) + VBF%Bflx_temp_dz(i,j,k)) + enddo ; enddo ; enddo + endif + if (VBF%id_Bdif_idV_BBL>0) then + work = 0.0 + do k = 1,nz + work = work + & + (global_area_integral(VBF%Bflx_temp_dz(:,:,k), G, tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + & + global_area_integral(VBF%Bflx_salt_dz(:,:,k), G, tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3)) + enddo + endif + elseif (VBF%id_Bdif_BBL>0) then + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_BBL, VBF%Bflx_salt) + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_BBL, VBF%Bflx_temp) + endif + ! Post BBL fluxes + if (VBF%id_Bdif_BBL>0) then + work3d_i(:,:,:) = 0.0 + do k = 1,nz+1 ; do j = jsc,jec ; do i = isc,iec + work3d_i(i,j,k) = VBF%Bflx_temp(i,j,k) + VBF%Bflx_salt(i,j,k) + enddo ; enddo ; enddo + call post_data(VBF%id_Bdif_BBL, work3d_i, diag) + endif + if (VBF%id_Bdif_dz_BBL>0) then + work3d_l(:,:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work3d_l(i,j,k) = VBF%Bflx_temp_dz(i,j,k) + VBF%Bflx_salt_dz(i,j,k) + enddo ; enddo ; enddo + call post_data(VBF%id_Bdif_dz_BBL, work3d_l, diag) + endif + if (VBF%id_Bdif_idz_BBL>0) call post_data(VBF%id_Bdif_idz_BBL, work2d, diag) + if (VBF%id_Bdif_idV_BBL>0) call post_data(VBF%id_Bdif_idV_BBL, work, diag) + + ! Compute Kappa Shear fluxes + if (VBF%id_Bdif_dz_KS>0.or.VBF%id_Bdif_idz_KS>0.or.VBF%id_Bdif_idV_KS>0) then + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_KS, VBF%Bflx_salt, dz=dz, Bdif_flx_dz=VBF%Bflx_salt_dz) + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_KS, VBF%Bflx_temp, dz=dz, Bdif_flx_dz=VBF%Bflx_temp_dz) + if (VBF%id_Bdif_idz_KS>0) then + work2d(:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work2d(i,j) = work2d(i,j) + (VBF%Bflx_salt_dz(i,j,k) + VBF%Bflx_temp_dz(i,j,k)) + enddo ; enddo ; enddo + endif + if (VBF%id_Bdif_idV_KS>0) then + work = 0.0 + do k = 1,nz + work = work + & + (global_area_integral(VBF%Bflx_temp_dz(:,:,k), G, tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + & + global_area_integral(VBF%Bflx_salt_dz(:,:,k), G, tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3)) + enddo + endif + elseif (VBF%id_Bdif_KS>0) then + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_KS, VBF%Bflx_salt) + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_KS, VBF%Bflx_temp) + endif + ! Post Kappa Shear fluxes + if (VBF%id_Bdif_KS>0) then + work3d_i(:,:,:) = 0.0 + do k = 1,nz+1 ; do j = jsc,jec ; do i = isc,iec + work3d_i(i,j,k) = VBF%Bflx_temp(i,j,k) + VBF%Bflx_salt(i,j,k) + enddo ; enddo ; enddo + call post_data(VBF%id_Bdif_KS, work3d_i, diag) + endif + if (VBF%id_Bdif_dz_KS>0) then + work3d_l(:,:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work3d_l(i,j,k) = VBF%Bflx_temp_dz(i,j,k) + VBF%Bflx_salt_dz(i,j,k) + enddo ; enddo ; enddo + call post_data(VBF%id_Bdif_dz_KS, work3d_l, diag) + endif + if (VBF%id_Bdif_idz_KS>0) call post_data(VBF%id_Bdif_idz_KS, work2d, diag) + if (VBF%id_Bdif_idV_KS>0) call post_data(VBF%id_Bdif_idV_KS, work, diag) + + ! Compute bkgnd fluxes + if (VBF%id_Bdif_dz_bkgnd>0.or.VBF%id_Bdif_idz_bkgnd>0.or.VBF%id_Bdif_idV_bkgnd>0) then + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_bkgnd, VBF%Bflx_salt, dz=dz, Bdif_flx_dz=VBF%Bflx_salt_dz) + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_bkgnd, VBF%Bflx_temp, dz=dz, Bdif_flx_dz=VBF%Bflx_temp_dz) + if (VBF%id_Bdif_idz_bkgnd>0) then + work2d(:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work2d(i,j) = work2d(i,j) + (VBF%Bflx_salt_dz(i,j,k) + VBF%Bflx_temp_dz(i,j,k)) + enddo ; enddo ; enddo + endif + if (VBF%id_Bdif_idV_bkgnd>0) then + work = 0.0 + do k = 1,nz + work = work + & + (global_area_integral(VBF%Bflx_temp_dz(:,:,k), G, tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + & + global_area_integral(VBF%Bflx_salt_dz(:,:,k), G, tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3)) + enddo + endif + elseif (VBF%id_Bdif_bkgnd>0) then + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_bkgnd, VBF%Bflx_salt) + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_bkgnd, VBF%Bflx_temp) + endif + ! Post bkgnd fluxes + if (VBF%id_Bdif_bkgnd>0) then + work3d_i(:,:,:) = 0.0 + do k = 1,nz+1 ; do j = jsc,jec ; do i = isc,iec + work3d_i(i,j,k) = VBF%Bflx_temp(i,j,k) + VBF%Bflx_salt(i,j,k) + enddo ; enddo ; enddo + call post_data(VBF%id_Bdif_bkgnd, work3d_i, diag) + endif + if (VBF%id_Bdif_dz_bkgnd>0) then + work3d_l(:,:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work3d_l(i,j,k) = VBF%Bflx_temp_dz(i,j,k) + VBF%Bflx_salt_dz(i,j,k) + enddo ; enddo ; enddo + call post_data(VBF%id_Bdif_dz_bkgnd, work3d_l, diag) + endif + if (VBF%id_Bdif_idz_bkgnd>0) call post_data(VBF%id_Bdif_idz_bkgnd, work2d, diag) + if (VBF%id_Bdif_idV_bkgnd>0) call post_data(VBF%id_Bdif_idV_bkgnd, work, diag) + + ! Compute double diffusion fluxes + if (VBF%id_Bdif_dz_ddiff_temp>0.or.VBF%id_Bdif_idz_ddiff_temp>0.or.VBF%id_Bdif_idV_ddiff_temp>0) then + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_ddiff_T, VBF%Bflx_temp, dz=dz, Bdif_flx_dz=VBF%Bflx_temp_dz) + if (VBF%id_Bdif_idz_ddiff_temp>0) then + work2d_temp(:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work2d_temp(i,j) = work2d_temp(i,j) + VBF%Bflx_temp_dz(i,j,k) + enddo ; enddo ; enddo + endif + if (VBF%id_Bdif_idV_ddiff_temp>0) then + work_temp = 0.0 + do k = 1,nz + work_temp = work_temp + global_area_integral(VBF%Bflx_temp_dz(:,:,k), G, & + tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + enddo + endif + elseif (VBF%id_Bdif_ddiff_temp>0) then + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_ddiff_T, VBF%Bflx_temp) + endif + if (VBF%id_Bdif_dz_ddiff_salt>0.or.VBF%id_Bdif_idz_ddiff_salt>0.or.VBF%id_Bdif_idV_ddiff_salt>0) then + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_ddiff_S, VBF%Bflx_salt, dz=dz, Bdif_flx_dz=VBF%Bflx_salt_dz) + if (VBF%id_Bdif_idz_ddiff_salt>0) then + work2d_salt(:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work2d_salt(i,j) = work2d_salt(i,j) + VBF%Bflx_salt_dz(i,j,k) + enddo ; enddo ; enddo + endif + if (VBF%id_Bdif_idV_ddiff_salt>0) then + work_salt = 0.0 + do k = 1,nz + work_salt = work_salt + global_area_integral(VBF%Bflx_salt_dz(:,:,k), G, & + tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + enddo + endif + elseif (VBF%id_Bdif_ddiff_salt>0) then + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_ddiff_S, VBF%Bflx_salt) + endif + ! Post double diffusion fluxes + if (VBF%id_Bdif_ddiff_temp>0) call post_data(VBF%id_Bdif_ddiff_temp, VBF%Bflx_temp, diag) + if (VBF%id_Bdif_dz_ddiff_temp>0) call post_data(VBF%id_Bdif_dz_ddiff_temp, VBF%Bflx_temp_dz, diag) + if (VBF%id_Bdif_idz_ddiff_temp>0) call post_data(VBF%id_Bdif_idz_ddiff_temp, work2d_temp, diag) + if (VBF%id_Bdif_idV_ddiff_temp>0) call post_data(VBF%id_Bdif_idV_ddiff_temp, work_temp, diag) + if (VBF%id_Bdif_ddiff_salt>0) call post_data(VBF%id_Bdif_ddiff_salt, VBF%Bflx_salt, diag) + if (VBF%id_Bdif_dz_ddiff_salt>0) call post_data(VBF%id_Bdif_dz_ddiff_salt, VBF%Bflx_salt_dz, diag) + if (VBF%id_Bdif_idz_ddiff_salt>0) call post_data(VBF%id_Bdif_idz_ddiff_salt, work2d_salt, diag) + if (VBF%id_Bdif_idV_ddiff_salt>0) call post_data(VBF%id_Bdif_idV_ddiff_salt, work_salt, diag) + + ! Compute Kd_leak fluxes + if (VBF%id_Bdif_dz_leak>0.or.VBF%id_Bdif_idz_leak>0.or.VBF%id_Bdif_idV_leak>0) then + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_leak, VBF%Bflx_salt, dz=dz, Bdif_flx_dz=VBF%Bflx_salt_dz) + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_leak, VBF%Bflx_temp, dz=dz, Bdif_flx_dz=VBF%Bflx_temp_dz) + if (VBF%id_Bdif_idz_leak>0) then + work2d(:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work2d(i,j) = work2d(i,j) + (VBF%Bflx_salt_dz(i,j,k) + VBF%Bflx_temp_dz(i,j,k)) + enddo ; enddo ; enddo + endif + if (VBF%id_Bdif_idV_leak>0) then + work = 0.0 + do k = 1,nz + work = work + & + (global_area_integral(VBF%Bflx_temp_dz(:,:,k), G, tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + & + global_area_integral(VBF%Bflx_salt_dz(:,:,k), G, tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3)) + enddo + endif + elseif (VBF%id_Bdif_leak>0) then + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_leak, VBF%Bflx_salt) + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_leak, VBF%Bflx_temp) + endif + ! Post Kd_leak fluxes + if (VBF%id_Bdif_leak>0) then + work3d_i(:,:,:) = 0.0 + do k = 1,nz+1 ; do j = jsc,jec ; do i = isc,iec + work3d_i(i,j,k) = VBF%Bflx_temp(i,j,k) + VBF%Bflx_salt(i,j,k) + enddo ; enddo ; enddo + call post_data(VBF%id_Bdif_leak, work3d_i, diag) + endif + if (VBF%id_Bdif_dz_leak>0) then + work3d_l(:,:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work3d_l(i,j,k) = VBF%Bflx_temp_dz(i,j,k) + VBF%Bflx_salt_dz(i,j,k) + enddo ; enddo ; enddo + call post_data(VBF%id_Bdif_dz_leak, work3d_l, diag) + endif + if (VBF%id_Bdif_idz_leak>0) call post_data(VBF%id_Bdif_idz_leak, work2d, diag) + if (VBF%id_Bdif_idV_leak>0) call post_data(VBF%id_Bdif_idV_leak, work, diag) + + ! Compute Kd_quad fluxes + if (VBF%id_Bdif_dz_quad>0.or.VBF%id_Bdif_idz_quad>0.or.VBF%id_Bdif_idV_quad>0) then + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_quad, VBF%Bflx_salt, dz=dz, Bdif_flx_dz=VBF%Bflx_salt_dz) + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_quad, VBF%Bflx_temp, dz=dz, Bdif_flx_dz=VBF%Bflx_temp_dz) + if (VBF%id_Bdif_idz_quad>0) then + work2d(:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work2d(i,j) = work2d(i,j) + (VBF%Bflx_salt_dz(i,j,k) + VBF%Bflx_temp_dz(i,j,k)) + enddo ; enddo ; enddo + endif + if (VBF%id_Bdif_idV_quad>0) then + work = 0.0 + do k = 1,nz + work = work + & + (global_area_integral(VBF%Bflx_temp_dz(:,:,k), G, tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + & + global_area_integral(VBF%Bflx_salt_dz(:,:,k), G, tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3)) + enddo + endif + elseif (VBF%id_Bdif_quad>0) then + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_quad, VBF%Bflx_salt) + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_quad, VBF%Bflx_temp) + endif + ! Post Kd_quad fluxes + if (VBF%id_Bdif_quad>0) then + work3d_i(:,:,:) = 0.0 + do k = 1,nz+1 ; do j = jsc,jec ; do i = isc,iec + work3d_i(i,j,k) = VBF%Bflx_temp(i,j,k) + VBF%Bflx_salt(i,j,k) + enddo ; enddo ; enddo + call post_data(VBF%id_Bdif_quad, work3d_i, diag) + endif + if (VBF%id_Bdif_dz_quad>0) then + work3d_l(:,:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work3d_l(i,j,k) = VBF%Bflx_temp_dz(i,j,k) + VBF%Bflx_salt_dz(i,j,k) + enddo ; enddo ; enddo + call post_data(VBF%id_Bdif_dz_quad, work3d_l, diag) + endif + if (VBF%id_Bdif_idz_quad>0) call post_data(VBF%id_Bdif_idz_quad, work2d, diag) + if (VBF%id_Bdif_idV_quad>0) call post_data(VBF%id_Bdif_idV_quad, work, diag) + + ! Compute Kd_itidal fluxes + if (VBF%id_Bdif_dz_itidal>0.or.VBF%id_Bdif_idz_itidal>0.or.VBF%id_Bdif_idV_itidal>0) then + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_itidal, VBF%Bflx_salt, dz=dz, Bdif_flx_dz=VBF%Bflx_salt_dz) + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_itidal, VBF%Bflx_temp, dz=dz, Bdif_flx_dz=VBF%Bflx_temp_dz) + if (VBF%id_Bdif_idz_itidal>0) then + work2d(:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work2d(i,j) = work2d(i,j) + (VBF%Bflx_salt_dz(i,j,k) + VBF%Bflx_temp_dz(i,j,k)) + enddo ; enddo ; enddo + endif + if (VBF%id_Bdif_idV_itidal>0) then + work = 0.0 + do k = 1,nz + work = work + & + (global_area_integral(VBF%Bflx_temp_dz(:,:,k), G, tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + & + global_area_integral(VBF%Bflx_salt_dz(:,:,k), G, tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3)) + enddo + endif + elseif (VBF%id_Bdif_itidal>0) then + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_itidal, VBF%Bflx_salt) + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_itidal, VBF%Bflx_temp) + endif + ! Post Kd_itidal fluxes + if (VBF%id_Bdif_itidal>0) then + work3d_i(:,:,:) = 0.0 + do k = 1,nz+1 ; do j = jsc,jec ; do i = isc,iec + work3d_i(i,j,k) = VBF%Bflx_temp(i,j,k) + VBF%Bflx_salt(i,j,k) + enddo ; enddo ; enddo + call post_data(VBF%id_Bdif_itidal, work3d_i, diag) + endif + if (VBF%id_Bdif_dz_itidal>0) then + work3d_l(:,:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work3d_l(i,j,k) = VBF%Bflx_temp_dz(i,j,k)+VBF%Bflx_salt_dz(i,j,k) + enddo ; enddo ; enddo + call post_data(VBF%id_Bdif_dz_itidal, work3d_l, diag) + endif + if (VBF%id_Bdif_idz_itidal>0) call post_data(VBF%id_Bdif_idz_itidal, work2d, diag) + if (VBF%id_Bdif_idV_itidal>0) call post_data(VBF%id_Bdif_idV_itidal, work, diag) + + ! Compute Kd_Froude fluxes + if (VBF%id_Bdif_dz_Froude>0.or.VBF%id_Bdif_idz_Froude>0.or.VBF%id_Bdif_idV_Froude>0) then + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_Froude, VBF%Bflx_salt, dz=dz, Bdif_flx_dz=VBF%Bflx_salt_dz) + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_Froude, VBF%Bflx_temp, dz=dz, Bdif_flx_dz=VBF%Bflx_temp_dz) + if (VBF%id_Bdif_idz_Froude>0) then + work2d(:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work2d(i,j) = work2d(i,j) + (VBF%Bflx_salt_dz(i,j,k) + VBF%Bflx_temp_dz(i,j,k)) + enddo ; enddo ; enddo + endif + if (VBF%id_Bdif_idV_Froude>0) then + work = 0.0 + do k = 1,nz + work = work + & + (global_area_integral(VBF%Bflx_temp_dz(:,:,k), G, tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + & + global_area_integral(VBF%Bflx_salt_dz(:,:,k), G, tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3)) + enddo + endif + elseif (VBF%id_Bdif_Froude>0) then + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_Froude, VBF%Bflx_salt) + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_Froude, VBF%Bflx_temp) + endif + ! Post Kd_Froude fluxes + if (VBF%id_Bdif_Froude>0) then + work3d_i(:,:,:) = 0.0 + do k = 1,nz+1 ; do j = jsc,jec ; do i = isc,iec + work3d_i(i,j,k) = VBF%Bflx_temp(i,j,k) + VBF%Bflx_salt(i,j,k) + enddo ; enddo ; enddo + call post_data(VBF%id_Bdif_Froude, work3d_i, diag) + endif + if (VBF%id_Bdif_dz_Froude>0) then + work3d_l(:,:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work3d_l(i,j,k) = VBF%Bflx_temp_dz(i,j,k) + VBF%Bflx_salt_dz(i,j,k) + enddo ; enddo ; enddo + call post_data(VBF%id_Bdif_dz_Froude, work3d_l, diag) + endif + if (VBF%id_Bdif_idz_Froude>0) call post_data(VBF%id_Bdif_idz_Froude, work2d, diag) + if (VBF%id_Bdif_idV_Froude>0) call post_data(VBF%id_Bdif_idV_Froude, work, diag) + + ! Compute Kd_slope fluxes + if (VBF%id_Bdif_dz_slope>0.or.VBF%id_Bdif_idz_slope>0.or.VBF%id_Bdif_idV_slope>0) then + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_slope, VBF%Bflx_salt, dz=dz, Bdif_flx_dz=VBF%Bflx_salt_dz) + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_slope, VBF%Bflx_temp, dz=dz, Bdif_flx_dz=VBF%Bflx_temp_dz) + if (VBF%id_Bdif_idz_slope>0) then + work2d(:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work2d(i,j) = work2d(i,j) + (VBF%Bflx_salt_dz(i,j,k) + VBF%Bflx_temp_dz(i,j,k)) + enddo ; enddo ; enddo + endif + if (VBF%id_Bdif_idV_slope>0) then + work = 0.0 + do k = 1,nz + work = work + & + (global_area_integral(VBF%Bflx_temp_dz(:,:,k), G, tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + & + global_area_integral(VBF%Bflx_salt_dz(:,:,k), G, tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3)) + enddo + endif + elseif (VBF%id_Bdif_slope>0) then + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_slope, VBF%Bflx_salt) + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_slope, VBF%Bflx_temp) + endif + ! Post Kd_slope fluxes + if (VBF%id_Bdif_slope>0) then + work3d_i(:,:,:) = 0.0 + do k = 1,nz+1 ; do j = jsc,jec ; do i = isc,iec + work3d_i(i,j,k) = VBF%Bflx_temp(i,j,k) + VBF%Bflx_salt(i,j,k) + enddo ; enddo ; enddo + call post_data(VBF%id_Bdif_slope, work3d_i, diag) + endif + if (VBF%id_Bdif_dz_slope>0) then + work3d_l(:,:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work3d_l(i,j,k) = VBF%Bflx_temp_dz(i,j,k) + VBF%Bflx_salt_dz(i,j,k) + enddo ; enddo ; enddo + call post_data(VBF%id_Bdif_dz_slope, work3d_l, diag) + endif + if (VBF%id_Bdif_idz_slope>0) call post_data(VBF%id_Bdif_idz_slope, work2d, diag) + if (VBF%id_Bdif_idV_slope>0) call post_data(VBF%id_Bdif_idV_slope, work, diag) + + ! Compute Kd_lowmode fluxes + if (VBF%id_Bdif_dz_lowmode>0.or.VBF%id_Bdif_idz_lowmode>0.or.VBF%id_Bdif_idV_lowmode>0) then + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_lowmode, VBF%Bflx_salt, dz=dz, Bdif_flx_dz=VBF%Bflx_salt_dz) + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_lowmode, VBF%Bflx_temp, dz=dz, Bdif_flx_dz=VBF%Bflx_temp_dz) + if (VBF%id_Bdif_idz_lowmode>0) then + work2d(:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work2d(i,j) = work2d(i,j) + (VBF%Bflx_salt_dz(i,j,k) + VBF%Bflx_temp_dz(i,j,k)) + enddo ; enddo ; enddo + endif + if (VBF%id_Bdif_idV_lowmode>0) then + work = 0.0 + do k = 1,nz + work = work + & + (global_area_integral(VBF%Bflx_temp_dz(:,:,k), G, tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + & + global_area_integral(VBF%Bflx_salt_dz(:,:,k), G, tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3)) + enddo + endif + elseif (VBF%id_Bdif_lowmode>0) then + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_lowmode, VBF%Bflx_salt) + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_lowmode, VBF%Bflx_temp) + endif + ! Post Kd_lowmode fluxes + if (VBF%id_Bdif_lowmode>0) then + work3d_i(:,:,:) = 0.0 + do k = 1,nz+1 ; do j = jsc,jec ; do i = isc,iec + work3d_i(i,j,k) = VBF%Bflx_temp(i,j,k) + VBF%Bflx_salt(i,j,k) + enddo ; enddo ; enddo + call post_data(VBF%id_Bdif_lowmode, work3d_i, diag) + endif + if (VBF%id_Bdif_dz_lowmode>0) then + work3d_l(:,:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work3d_l(i,j,k) = VBF%Bflx_temp_dz(i,j,k) + VBF%Bflx_salt_dz(i,j,k) + enddo ; enddo ; enddo + call post_data(VBF%id_Bdif_dz_lowmode, work3d_l, diag) + endif + if (VBF%id_Bdif_idz_lowmode>0) call post_data(VBF%id_Bdif_idz_lowmode, work2d, diag) + if (VBF%id_Bdif_idV_lowmode>0) call post_data(VBF%id_Bdif_idV_lowmode, work, diag) + + ! Compute Kd_Niku fluxes + if (VBF%id_Bdif_dz_Niku>0 .or. VBF%id_Bdif_idz_Niku>0 .or. VBF%id_Bdif_idV_Niku>0) then + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_Niku, VBF%Bflx_salt, dz=dz, Bdif_flx_dz=VBF%Bflx_salt_dz) + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_Niku, VBF%Bflx_temp, dz=dz, Bdif_flx_dz=VBF%Bflx_temp_dz) + if (VBF%id_Bdif_idz_Niku>0) then + work2d(:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work2d(i,j) = work2d(i,j) + (VBF%Bflx_salt_dz(i,j,k) + VBF%Bflx_temp_dz(i,j,k)) + enddo ; enddo ; enddo + endif + if (VBF%id_Bdif_idV_Niku>0) then + work = 0.0 + do k = 1,nz + work = work + & + (global_area_integral(VBF%Bflx_temp_dz(:,:,k), G, tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + & + global_area_integral(VBF%Bflx_salt_dz(:,:,k), G, tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3)) + enddo + endif + elseif (VBF%id_Bdif_Niku>0) then + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_Niku, VBF%Bflx_salt) + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_Niku, VBF%Bflx_temp) + endif + ! Post Kd_Niku fluxes + if (VBF%id_Bdif_Niku>0) then + work3d_i(:,:,:) = 0.0 + do k = 1,nz+1 ; do j = jsc,jec ; do i = isc,iec + work3d_i(i,j,k) = VBF%Bflx_temp(i,j,k) + VBF%Bflx_salt(i,j,k) + enddo ; enddo ; enddo + call post_data(VBF%id_Bdif_lowmode, work3d_i, diag) + endif + if (VBF%id_Bdif_dz_Niku>0) then + work3d_l(:,:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work3d_l(i,j,k) = VBF%Bflx_temp_dz(i,j,k) + VBF%Bflx_salt_dz(i,j,k) + enddo ; enddo ; enddo + call post_data(VBF%id_Bdif_dz_Niku, work3d_l, diag) + endif + if (VBF%id_Bdif_idz_Niku>0) call post_data(VBF%id_Bdif_idz_Niku, work2d, diag) + if (VBF%id_Bdif_idV_Niku>0) call post_data(VBF%id_Bdif_idV_Niku, work, diag) + + ! Compute Kd_itides fluxes + if (VBF%id_Bdif_dz_itides>0 .or. VBF%id_Bdif_idz_itides>0 .or. VBF%id_Bdif_idV_itides>0) then + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_itides, VBF%Bflx_salt, dz=dz, Bdif_flx_dz=VBF%Bflx_salt_dz) + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_itides, VBF%Bflx_temp, dz=dz, Bdif_flx_dz=VBF%Bflx_temp_dz) + if (VBF%id_Bdif_idz_itides>0) then + work2d(:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work2d(i,j) = work2d(i,j) + (VBF%Bflx_salt_dz(i,j,k) + VBF%Bflx_temp_dz(i,j,k)) + enddo ; enddo ; enddo + endif + if (VBF%id_Bdif_idV_itides>0) then + work = 0.0 + do k = 1,nz + work = work + & + (global_area_integral(VBF%Bflx_temp_dz(:,:,k), G, tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + & + global_area_integral(VBF%Bflx_salt_dz(:,:,k), G, tmp_scale=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3)) + enddo + endif + elseif (VBF%id_Bdif_itides>0) then + call diagnoseKdWork(G, GV, N2_salt, VBF%Kd_itides, VBF%Bflx_salt) + call diagnoseKdWork(G, GV, N2_temp, VBF%Kd_itides, VBF%Bflx_temp) + endif + ! Post Kd_itides fluxes + if (VBF%id_Bdif_itides>0) then + work3d_i(:,:,:) = 0.0 + do k = 1,nz+1 ; do j = jsc,jec ; do i = isc,iec + work3d_i(i,j,k) = VBF%Bflx_temp(i,j,k) + VBF%Bflx_salt(i,j,k) + enddo ; enddo ; enddo + call post_data(VBF%id_Bdif_itides, work3d_i, diag) + endif + if (VBF%id_Bdif_dz_itides>0) then + work3d_l(:,:,:) = 0.0 + do k = 1,nz ; do j = jsc,jec ; do i = isc,iec + work3d_l(i,j,k) = VBF%Bflx_temp_dz(i,j,k) + VBF%Bflx_salt_dz(i,j,k) + enddo ; enddo ; enddo + call post_data(VBF%id_Bdif_dz_itides, work3d_l, diag) + endif + if (VBF%id_Bdif_idz_itides>0) call post_data(VBF%id_Bdif_idz_itides, work2d, diag) + if (VBF%id_Bdif_idV_itides>0) call post_data(VBF%id_Bdif_idV_itides, work, diag) + +end subroutine KdWork_Diagnostics + +!> Diagnose the implied "work", or buoyancy forcing & its integral, due to a given diffusivity and column state. +subroutine diagnoseKdWork(G, GV, N2, Kd, Bdif_flx, dz, Bdif_flx_dz) + type(ocean_grid_type), intent(in) :: G !< Grid type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(in) :: N2 !< Buoyancy frequency [T-2 ~> s-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(in) :: Kd !< Diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(out) :: Bdif_flx !< Buoyancy flux [H Z T-3 ~> m2 s-3 or W m-3] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in), optional :: dz !< Grid spacing [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out), optional :: Bdif_flx_dz !< Buoyancy flux over layer [H Z2 T-3 ~> m3 s-3 or W m-2] + + integer :: i, j, k + + Bdif_flx(:,:,1) = 0.0 + Bdif_flx(:,:,GV%ke+1) = 0.0 + !$OMP parallel do default(shared) + do K=2,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + Bdif_flx(i,j,K) = - N2(i,j,K) * Kd(i,j,K) + enddo ; enddo ; enddo + + if (present(Bdif_flx_dz) .and. present(dz)) then + !$OMP parallel do default(shared) + do K=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + Bdif_flx_dz(i,j,k) = 0.5*(Bdif_flx(i,j,K)+Bdif_flx(i,j,K+1))*dz(i,j,k) + enddo ; enddo ; enddo + endif + +end subroutine diagnoseKdWork + +!> Allocates arrays only when needed +subroutine Allocate_VBF_CS(G, GV, VBF) + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type (vbf_CS), intent(inout) :: VBF !< Vertical buoyancy flux structure + + integer :: isd, ied, jsd, jed, nz + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke + + if (VBF%do_bflx_salt) & + allocate(VBF%Bflx_salt(isd:ied,jsd:jed,nz+1), source=0.0) + if (VBF%do_bflx_salt_dz) & + allocate(VBF%Bflx_salt_dz(isd:ied,jsd:jed,nz), source=0.0) + if (VBF%do_bflx_temp) & + allocate(VBF%Bflx_temp(isd:ied,jsd:jed,nz+1), source=0.0) + if (VBF%do_bflx_temp_dz) & + allocate(VBF%Bflx_temp_dz(isd:ied,jsd:jed,nz), source=0.0) + + if (VBF%id_Bdif_salt_dz>0 .or. VBF%id_Bdif_dz>0 .or. VBF%id_Bdif_salt>0 .or. VBF%id_Bdif>0 .or. & + VBF%id_Bdif_idz>0 .or. VBF%id_Bdif_salt_idz>0 .or. VBF%id_Bdif_idV>0 .or. VBF%id_Bdif_salt_idV>0) & + allocate(VBF%Kd_salt(isd:ied,jsd:jed,nz+1), source=0.0) + if (VBF%id_Bdif_temp_dz>0 .or. VBF%id_Bdif_dz>0 .or. VBF%id_Bdif_temp>0 .or. VBF%id_Bdif>0 .or. & + VBF%id_Bdif_idz>0 .or. VBF%id_Bdif_temp_idz>0 .or. VBF%id_Bdif_idV>0 .or. VBF%id_Bdif_temp_idV>0) & + allocate(VBF%Kd_temp(isd:ied,jsd:jed,nz+1), source=0.0) + + if (VBF%id_Bdif_BBL>0 .or. VBF%id_Bdif_dz_BBL>0 .or. VBF%id_Bdif_idz_BBL>0 .or. VBF%id_Bdif_idV_BBL>0) & + allocate(VBF%Kd_BBL(isd:ied,jsd:jed,nz+1), source=0.0) + if (VBF%id_Bdif_ePBL>0 .or. VBF%id_Bdif_dz_ePBL>0 .or. VBF%id_Bdif_idz_ePBL>0 .or. VBF%id_Bdif_idV_ePBL>0) & + allocate(VBF%Kd_ePBL(isd:ied,jsd:jed,nz+1), source=0.0) + if (VBF%id_Bdif_KS>0 .or. VBF%id_Bdif_dz_KS>0 .or. VBF%id_Bdif_idz_KS>0 .or. VBF%id_Bdif_idV_KS>0) & + allocate(VBF%Kd_KS(isd:ied,jsd:jed,nz+1), source=0.0) + if (VBF%id_Bdif_bkgnd>0 .or. VBF%id_Bdif_dz_bkgnd>0 .or. VBF%id_Bdif_idz_bkgnd>0 .or. VBF%id_Bdif_idV_bkgnd>0) & + allocate(VBF%Kd_bkgnd(isd:ied,jsd:jed,nz+1), source=0.0) + if (VBF%id_Bdif_ddiff_temp>0 .or. VBF%id_Bdif_dz_ddiff_temp>0 .or. VBF%id_Bdif_idz_ddiff_temp>0 & + .or. VBF%id_Bdif_idV_ddiff_temp>0) allocate(VBF%Kd_ddiff_T(isd:ied,jsd:jed,nz+1), source=0.0) + if (VBF%id_Bdif_ddiff_salt>0 .or. VBF%id_Bdif_dz_ddiff_salt>0 .or. VBF%id_Bdif_idV_ddiff_salt>0 & + .or. VBF%id_Bdif_idV_ddiff_salt>0) allocate(VBF%Kd_ddiff_S(isd:ied,jsd:jed,nz+1), source=0.0) + if (VBF%id_Bdif_leak>0 .or. VBF%id_Bdif_dz_leak>0 .or. VBF%id_Bdif_idz_leak>0 .or. VBF%id_Bdif_idV_leak>0) & + allocate(VBF%Kd_leak(isd:ied,jsd:jed,nz+1), source=0.0) + if (VBF%id_Bdif_quad>0 .or. VBF%id_Bdif_dz_quad>0 .or. VBF%id_Bdif_idz_quad>0 .or. VBF%id_Bdif_idV_quad>0) & + allocate(VBF%Kd_quad(isd:ied,jsd:jed,nz+1), source=0.0) + if (VBF%id_Bdif_itidal>0 .or. VBF%id_Bdif_dz_itidal>0 .or. VBF%id_Bdif_idz_itidal>0 .or. VBF%id_Bdif_idV_itidal>0) & + allocate(VBF%Kd_itidal(isd:ied,jsd:jed,nz+1), source=0.0) + if (VBF%id_Bdif_Froude>0 .or. VBF%id_Bdif_dz_Froude>0 .or. VBF%id_Bdif_idz_Froude>0 .or. VBF%id_Bdif_idV_Froude>0) & + allocate(VBF%Kd_Froude(isd:ied,jsd:jed,nz+1), source=0.0) + if (VBF%id_Bdif_slope>0 .or. VBF%id_Bdif_dz_slope>0 .or. VBF%id_Bdif_idz_slope>0 .or. VBF%id_Bdif_idV_slope>0) & + allocate(VBF%Kd_slope(isd:ied,jsd:jed,nz+1), source=0.0) + if (VBF%id_Bdif_lowmode>0 .or. VBF%id_Bdif_dz_lowmode>0 .or. VBF%id_Bdif_idz_lowmode>0 .or. & + VBF%id_Bdif_idV_lowmode>0) allocate(VBF%Kd_lowmode(isd:ied,jsd:jed,nz+1), source=0.0) + if (VBF%id_Bdif_Niku>0 .or. VBF%id_Bdif_dz_Niku>0 .or. VBF%id_Bdif_idz_Niku>0 .or. VBF%id_Bdif_idV_Niku>0) & + allocate(VBF%Kd_Niku(isd:ied,jsd:jed,nz+1), source=0.0) + if (VBF%id_Bdif_itides>0 .or. VBF%id_Bdif_dz_itides>0 .or. VBF%id_Bdif_idz_itides>0 .or. VBF%id_Bdif_idV_itides>0) & + allocate(VBF%Kd_itides(isd:ied,jsd:jed,nz+1), source=0.0) + +end subroutine Allocate_VBF_CS + +!> Deallocate any arrays that were allocated +subroutine Deallocate_VBF_CS(VBF) + type (vbf_CS), intent(inout) :: VBF !< Vertical buoyancy flux structure + + if (associated(VBF%Bflx_salt)) & + deallocate(VBF%Bflx_salt) + if (associated(VBF%Bflx_temp)) & + deallocate(VBF%Bflx_temp) + if (associated(VBF%Bflx_salt_dz)) & + deallocate(VBF%Bflx_salt_dz) + if (associated(VBF%Bflx_temp_dz)) & + deallocate(VBF%Bflx_temp_dz) + if (associated(VBF%Kd_salt)) & + deallocate(VBF%Kd_salt) + if (associated(VBF%Kd_temp)) & + deallocate(VBF%Kd_temp) + if (associated(VBF%Kd_BBL)) & + deallocate(VBF%Kd_BBL) + if (associated(VBF%Kd_ePBL)) & + deallocate(VBF%Kd_ePBL) + if (associated(VBF%Kd_KS)) & + deallocate(VBF%Kd_KS) + if (associated(VBF%Kd_bkgnd)) & + deallocate(VBF%Kd_bkgnd) + if (associated(VBF%Kd_ddiff_T)) & + deallocate(VBF%Kd_ddiff_T) + if (associated(VBF%Kd_ddiff_S)) & + deallocate(VBF%Kd_ddiff_S) + if (associated(VBF%Kd_leak)) & + deallocate(VBF%Kd_leak) + if (associated(VBF%Kd_quad)) & + deallocate(VBF%Kd_quad) + if (associated(VBF%Kd_itidal)) & + deallocate(VBF%Kd_itidal) + if (associated(VBF%Kd_Froude)) & + deallocate(VBF%Kd_Froude) + if (associated(VBF%Kd_slope)) & + deallocate(VBF%Kd_slope) + if (associated(VBF%Kd_lowmode)) & + deallocate(VBF%Kd_lowmode) + if (associated(VBF%Kd_Niku)) & + deallocate(VBF%Kd_Niku) + if (associated(VBF%Kd_itides)) & + deallocate(VBF%Kd_itides) + +end subroutine Deallocate_VBF_CS + +!> Handles all KdWork diagnostics and flags which calculations should be done. +subroutine KdWork_init(Time, G,GV,US,diag,VBF,Use_KdWork_diag) + type(time_type), target :: Time !< model time + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(diag_ctrl), target, intent(inout) :: diag !< regulates diagnostic output + type (vbf_CS), pointer, intent(inout) :: VBF !< Vertical buoyancy flux structure + logical, intent(out) :: Use_KdWork_diag !< Flag if any output was turned on + + allocate(VBF) + + VBF%do_bflx_salt = .false. + VBF%do_bflx_salt_dz = .false. + VBF%do_bflx_temp = .false. + VBF%do_bflx_temp_dz = .false. + + VBF%id_Bdif = register_diag_field('ocean_model',"Bflx_dia_diff", diag%axesTi, & + Time, "Diffusive diapycnal buoyancy flux across interfaces", & + "W m-3", conversion=GV%H_to_kg_m2*US%Z_to_m*US%s_to_T**3) + VBF%id_Bdif_dz = register_diag_field('ocean_model',"Bflx_dia_diff_dz", diag%axesTl, & + Time, "Layerwise integral of diffusive diapycnal buoyancy flux.", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idz = register_diag_field('ocean_model',"Bflx_dia_diff_idz", diag%axesT1, & + Time, "Layer integrated diffusive diapycnal buoyancy flux.", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idV = register_scalar_field('ocean_model',"Bflx_dia_diff_idV", Time, diag, & + "Global integrated diffusive diapycnal buoyancy flux.", & + units="W", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3*US%L_to_m**2) + + VBF%id_Bdif_salt = register_diag_field('ocean_model',"Bflx_salt_dia_diff", diag%axesTi, & + Time, "Salinity contribution to diffusive diapycnal buoyancy flux across interfaces", & + "W m-3", conversion=GV%H_to_kg_m2*US%Z_to_m*US%s_to_T**3) + VBF%id_Bdif_salt_dz = register_diag_field('ocean_model',"Bflx_salt_dia_diff_dz", diag%axesTl, & + Time, "Salinity contribution to layer integral of diffusive diapycnal buoyancy flux.", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_salt_idz = register_diag_field('ocean_model',"Bflx_salt_dia_diff_idz", diag%axesT1, & + Time, "Salinity contribution to layer integrated diffusive diapycnal buoyancy flux.", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_salt_idV = register_scalar_field('ocean_model',"Bflx_salt_dia_diff_idV", Time, diag, & + "Salinity contribution to global integrated diffusive diapycnal buoyancy flux.", & + units="W", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3*US%L_to_m**2) + + VBF%id_Bdif_temp = register_diag_field('ocean_model',"Bflx_temp_dia_diff", diag%axesTi, & + Time, "Temperature contribution to diffusive diapycnal buoyancy flux across interfaces", & + "W m-3", conversion=GV%H_to_kg_m2*US%Z_to_m*US%s_to_T**3) + VBF%id_Bdif_temp_dz = register_diag_field('ocean_model',"Bflx_temp_dia_diff_dz", diag%axesTl, & + Time, "Temperature contribution to layer integral of diffusive diapycnal buoyancy flux.", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_temp_idz = register_diag_field('ocean_model',"Bflx_temp_dia_diff_idz", diag%axesT1, & + Time, "Temperature contribution to layer integrated diffusive diapycnal buoyancy flux.", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_temp_idV = register_scalar_field('ocean_model',"Bflx_temp_dia_diff_idV", Time, diag, & + "Temperature contribution to global integrated diffusive diapycnal buoyancy flux.", & + units="W", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3*US%L_to_m**2) + + VBF%id_Bdif_BBL = register_diag_field('ocean_model',"Bflx_dia_diff_BBL", diag%axesTi, & + Time, "Diffusive diapycnal buoyancy flux across interfaces due to the BBL parameterization.", & + "W m-3", conversion=GV%H_to_kg_m2*US%Z_to_m*US%s_to_T**3) + VBF%id_Bdif_dz_BBL = register_diag_field('ocean_model',"Bflx_dia_diff_dz_BBL", diag%axesTl, & + Time, "Layerwise integral of diffusive diapycnal buoyancy flux due to the BBL parameterization.", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idz_BBL = register_diag_field('ocean_model',"Bflx_dia_diff_idz_BBL", diag%axesT1, & + Time, "Layer integrated diffusive diapycnal buoyancy flux due to the BBL parameterization.", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idV_BBL = register_scalar_field('ocean_model',"Bflx_dia_diff_idV_BBL", Time, diag, & + "Global integrated diffusive diapycnal buoyancy flux due to BBL.", & + units="W", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3*US%L_to_m**2) + + VBF%id_Bdif_ePBL = register_diag_field('ocean_model',"Bflx_dia_diff_ePBL", diag%axesTi, & + Time, "Diffusive diapycnal buoyancy flux across interfaces due to ePBL", & + "W m-3", conversion=GV%H_to_kg_m2*US%Z_to_m*US%s_to_T**3) + VBF%id_Bdif_dz_ePBL = register_diag_field('ocean_model',"Bflx_dia_diff_dz_ePBL", diag%axesTl, & + Time, "Layerwise integral of diffusive diapycnal buoyancy flux due to ePBL.", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idz_ePBL = register_diag_field('ocean_model',"Bflx_dia_diff_idz_ePBL", diag%axesT1, & + Time, "Layer integrated diffusive diapycnal buoyancy flux due to ePBL.", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idV_ePBL = register_scalar_field('ocean_model',"Bflx_dia_diff_idV_ePBL", Time, diag, & + "Global integrated diffusive diapycnal buoyancy flux due to ePBL.", & + units="W", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3*US%L_to_m**2) + + VBF%id_Bdif_KS = register_diag_field('ocean_model',"Bflx_dia_diff_KS", diag%axesTi, & + Time, "Diffusive diapycnal buoyancy flux across interfaces due to Kappa Shear", & + "W m-3", conversion=GV%H_to_kg_m2*US%Z_to_m*US%s_to_T**3) + VBF%id_Bdif_dz_KS = register_diag_field('ocean_model',"Bflx_dia_diff_dz_KS", diag%axesTl, & + Time, "Layerwise integral of diffusive diapycnal buoyancy flux due to Kappa Shear.", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idz_KS = register_diag_field('ocean_model',"Bflx_dia_diff_idz_KS", diag%axesT1, & + Time, "Layer integrated diffusive diapycnal buoyancy flux due to Kappa Shear.", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idV_KS = register_scalar_field('ocean_model',"Bflx_dia_diff_idV_KS", Time, diag, & + "Global integrated diffusive diapycnal buoyancy flux due to Kappa Shear.", & + units="W", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3*US%L_to_m**2) + + VBF%id_Bdif_bkgnd = register_diag_field('ocean_model',"Bflx_dia_diff_bkgnd", diag%axesTi, & + Time, "Diffusive diapycnal buoyancy flux across interfaces due to bkgnd mixing", & + "W m-3", conversion=GV%H_to_kg_m2*US%Z_to_m*US%s_to_T**3) + VBF%id_Bdif_dz_bkgnd = register_diag_field('ocean_model',"Bflx_dia_diff_dz_bkgnd", diag%axesTl, & + Time, "Layerwise integral of diffusive diapycnal buoyancy flux due to bkgnd mixing", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idz_bkgnd = register_diag_field('ocean_model',"Bflx_dia_diff_idz_bkgnd", diag%axesT1, & + Time, "Layer integrated diffusive diapycnal buoyancy flux due to bkgnd mixing", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idV_bkgnd = register_scalar_field('ocean_model',"Bflx_dia_diff_idV_bkgnd", Time, diag, & + "Global integrated diffusive diapycnal buoyancy flux due to Kd_bkgnd.", & + units="W", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3*US%L_to_m**2) + + VBF%id_Bdif_ddiff_temp = register_diag_field('ocean_model',"Bflx_dia_diff_ddiff_heat", diag%axesTi, & + Time, "Diffusive diapycnal buoyancy flux across interfaces due to double diffusion of heat", & + "W m-3", conversion=GV%H_to_kg_m2*US%Z_to_m*US%s_to_T**3) + VBF%id_Bdif_dz_ddiff_temp = register_diag_field('ocean_model',"Bflx_dia_diff_dz_ddiff_heat", diag%axesTl, & + Time, "Layerwise integral of diffusive diapycnal buoyancy flux due to double diffusion of heat.", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idz_ddiff_temp = register_diag_field('ocean_model',"Bflx_dia_diff_idz_ddiff_heat", diag%axesT1, & + Time, "Layer integrated diffusive diapycnal buoyancy flux due to double diffusion of heat.", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idV_ddiff_temp = register_scalar_field('ocean_model',"Bflx_dia_diff_idV_ddiff_heat", Time, diag, & + "Global integrated diffusive diapycnal buoyancy flux due to double diffusion of heat.", & + units="W", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3*US%L_to_m**2) + + VBF%id_Bdif_ddiff_salt = register_diag_field('ocean_model',"Bflx_dia_diff_ddiff_salt", diag%axesTi, & + Time, "Diffusive diapycnal buoyancy flux across interfaces due to double diffusion of salt", & + "W m-3", conversion=GV%H_to_kg_m2*US%Z_to_m*US%s_to_T**3) + VBF%id_Bdif_dz_ddiff_salt = register_diag_field('ocean_model',"Bflx_dia_diff_dz_ddiff_salt", diag%axesTl, & + Time, "Layerwise integral of diffusive diapycnal buoyancy flux due to double diffusion of salt.", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idz_ddiff_salt = register_diag_field('ocean_model',"Bflx_dia_diff_idz_ddiff_salt", diag%axesT1, & + Time, "Layer integrated diffusive diapycnal buoyancy flux due to double diffusion of salt.", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idV_ddiff_salt = register_scalar_field('ocean_model',"Bflx_dia_diff_idV_ddiff_salt", Time, diag, & + "Global integrated diffusive diapycnal buoyancy flux due to double diffusion of salt.", & + units="W", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3*US%L_to_m**2) + + VBF%id_Bdif_leak = register_diag_field('ocean_model',"Bflx_dia_diff_leak", diag%axesTi, & + Time, "Diffusive diapycnal buoyancy flux across interfaces due to Kd_leak mixing", & + "W m-3", conversion=GV%H_to_kg_m2*US%Z_to_m*US%s_to_T**3) + VBF%id_Bdif_dz_leak = register_diag_field('ocean_model',"Bflx_dia_diff_dz_leak", diag%axesTl, & + Time, "Layerwise integral of diffusive diapycnal buoyancy flux due to bkgnd mixing", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idz_leak = register_diag_field('ocean_model',"Bflx_dia_diff_idz_leak", diag%axesT1, & + Time, "Layer integrated diffusive diapycnal buoyancy flux due to bkgnd mixing", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idV_leak = register_scalar_field('ocean_model',"Bflx_dia_diff_idV_leak", Time, diag, & + "Global integrated diffusive diapycnal buoyancy flux due to Kd_leak.", & + units="W", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3*US%L_to_m**2) + + VBF%id_Bdif_quad = register_diag_field('ocean_model',"Bflx_dia_diff_quad", diag%axesTi, & + Time, "Diffusive diapycnal buoyancy flux across interfaces due to Kd_quad mixing", & + "W m-3", conversion=GV%H_to_kg_m2*US%Z_to_m*US%s_to_T**3) + VBF%id_Bdif_dz_quad = register_diag_field('ocean_model',"Bflx_dia_diff_dz_quad", diag%axesTl, & + Time, "Layerwise integral of diffusive diapycnal buoyancy flux due to bkgnd mixing", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idz_quad = register_diag_field('ocean_model',"Bflx_dia_diff_idz_quad", diag%axesT1, & + Time, "Layer integrated diffusive diapycnal buoyancy flux due to bkgnd mixing", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idV_quad = register_scalar_field('ocean_model',"Bflx_dia_diff_idV_quad", Time, diag, & + "Global integrated diffusive diapycnal buoyancy flux due to Kd_quad.", & + units="W", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3*US%L_to_m**2) + + VBF%id_Bdif_itidal = register_diag_field('ocean_model',"Bflx_dia_diff_itidal", diag%axesTi, & + Time, "Diffusive diapycnal buoyancy flux across interfaces due to Kd_itidal mixing", & + "W m-3", conversion=GV%H_to_kg_m2*US%Z_to_m*US%s_to_T**3) + VBF%id_Bdif_dz_itidal = register_diag_field('ocean_model',"Bflx_dia_diff_dz_itidal", diag%axesTl, & + Time, "Layerwise integral of diffusive diapycnal buoyancy flux due to bkgnd mixing", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idz_itidal = register_diag_field('ocean_model',"Bflx_dia_diff_idz_itidal", diag%axesT1, & + Time, "Layer integrated diffusive diapycnal buoyancy flux due to bkgnd mixing", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idV_itidal = register_scalar_field('ocean_model',"Bflx_dia_diff_idV_itidal", Time, diag, & + "Global integrated diffusive diapycnal buoyancy flux due to Kd_itidal.", & + units="W", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3*US%L_to_m**2) + + VBF%id_Bdif_Froude = register_diag_field('ocean_model',"Bflx_dia_diff_Froude", diag%axesTi, & + Time, "Diffusive diapycnal buoyancy flux across interfaces due to Kd_Froude mixing", & + "W m-3", conversion=GV%H_to_kg_m2*US%Z_to_m*US%s_to_T**3) + VBF%id_Bdif_dz_Froude = register_diag_field('ocean_model',"Bflx_dia_diff_dz_Froude", diag%axesTl, & + Time, "Layerwise integral of diffusive diapycnal buoyancy flux due to bkgnd mixing", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idz_Froude = register_diag_field('ocean_model',"Bflx_dia_diff_idz_Froude", diag%axesT1, & + Time, "Layer integrated diffusive diapycnal buoyancy flux due to bkgnd mixing", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idV_Froude = register_scalar_field('ocean_model',"Bflx_dia_diff_idV_Froude", Time, diag, & + "Global integrated diffusive diapycnal buoyancy flux due to Kd_Froude.", & + units="W", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3*US%L_to_m**2) + + VBF%id_Bdif_slope = register_diag_field('ocean_model',"Bflx_dia_diff_slope", diag%axesTi, & + Time, "Diffusive diapycnal buoyancy flux across interfaces due to Kd_slope mixing", & + "W m-3", conversion=GV%H_to_kg_m2*US%Z_to_m*US%s_to_T**3) + VBF%id_Bdif_dz_slope = register_diag_field('ocean_model',"Bflx_dia_diff_dz_slope", diag%axesTl, & + Time, "Layerwise integral of diffusive diapycnal buoyancy flux due to bkgnd mixing", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idz_slope = register_diag_field('ocean_model',"Bflx_dia_diff_idz_slope", diag%axesT1, & + Time, "Layer integrated diffusive diapycnal buoyancy flux due to bkgnd mixing", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idV_slope = register_scalar_field('ocean_model',"Bflx_dia_diff_idV_slope", Time, diag, & + "Global integrated diffusive diapycnal buoyancy flux due to Kd_slope.", & + units="W", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3*US%L_to_m**2) + + VBF%id_Bdif_lowmode = register_diag_field('ocean_model',"Bflx_dia_diff_lowmode", diag%axesTi, & + Time, "Diffusive diapycnal buoyancy flux across interfaces due to Kd_lowmode mixing", & + "W m-3", conversion=GV%H_to_kg_m2*US%Z_to_m*US%s_to_T**3) + VBF%id_Bdif_dz_lowmode = register_diag_field('ocean_model',"Bflx_dia_diff_dz_lowmode", diag%axesTl, & + Time, "Layerwise integral of diffusive diapycnal buoyancy flux due to bkgnd mixing", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idz_lowmode = register_diag_field('ocean_model',"Bflx_dia_diff_idz_lowmode", diag%axesT1, & + Time, "Layer integrated diffusive diapycnal buoyancy flux due to bkgnd mixing", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idV_lowmode = register_scalar_field('ocean_model',"Bflx_dia_diff_idV_lowmode", Time, diag, & + "Global integrated diffusive diapycnal buoyancy flux due to Kd_lowmode.", & + units="W", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3*US%L_to_m**2) + + VBF%id_Bdif_Niku = register_diag_field('ocean_model',"Bflx_dia_diff_Niku", diag%axesTi, & + Time, "Diffusive diapycnal buoyancy flux across interfaces due to Kd_Niku mixing", & + "W m-3", conversion=GV%H_to_kg_m2*US%Z_to_m*US%s_to_T**3) + VBF%id_Bdif_dz_Niku = register_diag_field('ocean_model',"Bflx_dia_diff_dz_Niku", diag%axesTl, & + Time, "Layerwise integral of diffusive diapycnal buoyancy flux due to bkgnd mixing", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idz_Niku = register_diag_field('ocean_model',"Bflx_dia_diff_idz_Niku", diag%axesT1, & + Time, "Layer integrated diffusive diapycnal buoyancy flux due to bkgnd mixing", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idV_Niku = register_scalar_field('ocean_model',"Bflx_dia_diff_idV_Niku", Time, diag, & + "Global integrated diffusive diapycnal buoyancy flux due to Kd_Niku.", & + units="W", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3*US%L_to_m**2) + + VBF%id_Bdif_itides = register_diag_field('ocean_model',"Bflx_dia_diff_itides", diag%axesTi, & + Time, "Diffusive diapycnal buoyancy flux across interfaces due to Kd_itides mixing", & + "W m-3", conversion=GV%H_to_kg_m2*US%Z_to_m*US%s_to_T**3) + VBF%id_Bdif_dz_itides = register_diag_field('ocean_model',"Bflx_dia_diff_dz_itides", diag%axesTl, & + Time, "Layerwise integral of diffusive diapycnal buoyancy flux due to bkgnd mixing", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idz_itides = register_diag_field('ocean_model',"Bflx_dia_diff_idz_itides", diag%axesT1, & + Time, "Layer integrated diffusive diapycnal buoyancy flux due to bkgnd mixing", & + "W m-2", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3) + VBF%id_Bdif_idV_itides = register_scalar_field('ocean_model',"Bflx_dia_diff_idV_itides", Time, diag, & + "Global integrated diffusive diapycnal buoyancy flux due to Kd_itides.", & + units="W", conversion=GV%H_to_kg_m2*US%Z_to_m**2*US%s_to_T**3*US%L_to_m**2) + + if (VBF%id_Bdif_dz>0 .or. VBF%id_Bdif_salt_dz>0 .or. VBF%id_Bdif_dz_BBL>0 .or. & + VBF%id_Bdif_dz_ePBL>0 .or. VBF%id_Bdif_dz_KS>0 .or. VBF%id_Bdif_dz_bkgnd>0 .or. & + VBF%id_Bdif_dz_ddiff_salt>0 .or. VBF%id_Bdif_dz_leak>0 .or. VBF%id_Bdif_dz_quad>0 .or. & + VBF%id_Bdif_dz_itidal>0 .or. VBF%id_Bdif_dz_Froude>0 .or. VBF%id_Bdif_dz_slope>0 .or. & + VBF%id_Bdif_dz_lowmode>0 .or. VBF%id_Bdif_dz_Niku>0 .or. VBF%id_Bdif_dz_itides>0 .or. & + VBF%id_Bdif_idV>0 .or. VBF%id_Bdif_salt_idV>0 .or. VBF%id_Bdif_idV_BBL>0 .or. & + VBF%id_Bdif_idV_ePBL>0 .or. VBF%id_Bdif_idV_KS>0 .or. VBF%id_Bdif_idV_bkgnd>0 .or. & + VBF%id_Bdif_idV_ddiff_salt>0 .or. VBF%id_Bdif_idV_leak>0 .or. VBF%id_Bdif_idV_quad>0 .or. & + VBF%id_Bdif_idV_itidal>0 .or. VBF%id_Bdif_idV_Froude>0 .or. VBF%id_Bdif_idV_slope>0 .or. & + VBF%id_Bdif_idV_lowmode>0 .or. VBF%id_Bdif_idV_Niku>0 .or. VBF%id_Bdif_idV_itides>0 .or. & + VBF%id_Bdif_idz>0 .or. VBF%id_Bdif_salt_idz>0 .or. VBF%id_Bdif_idz_BBL>0 .or. & + VBF%id_Bdif_idz_ePBL>0 .or. VBF%id_Bdif_idz_KS>0 .or. VBF%id_Bdif_idz_bkgnd>0 .or. & + VBF%id_Bdif_idz_ddiff_salt>0 .or. VBF%id_Bdif_idz_leak>0 .or. VBF%id_Bdif_idz_quad>0 .or. & + VBF%id_Bdif_idz_itidal>0 .or. VBF%id_Bdif_idz_Froude>0 .or. VBF%id_Bdif_idz_slope>0 .or. & + VBF%id_Bdif_idz_lowmode>0 .or. VBF%id_Bdif_idz_Niku>0 .or. VBF%id_Bdif_idz_itides>0 ) then + VBF%do_bflx_salt_dz = .true. + endif + if (VBF%id_Bdif_dz>0 .or. VBF%id_Bdif_temp_dz>0 .or. VBF%id_Bdif_dz_BBL>0 .or. & + VBF%id_Bdif_dz_ePBL>0 .or. VBF%id_Bdif_dz_KS>0 .or. VBF%id_Bdif_dz_bkgnd>0 .or. & + VBF%id_Bdif_dz_ddiff_temp>0 .or. VBF%id_Bdif_dz_leak>0 .or. VBF%id_Bdif_dz_quad>0 .or. & + VBF%id_Bdif_dz_itidal>0 .or. VBF%id_Bdif_dz_Froude>0 .or. VBF%id_Bdif_dz_slope>0 .or. & + VBF%id_Bdif_dz_lowmode>0 .or. VBF%id_Bdif_dz_Niku>0 .or. VBF%id_Bdif_dz_itides>0 .or. & + VBF%id_Bdif_idV>0 .or. VBF%id_Bdif_temp_idV>0 .or. VBF%id_Bdif_idV_BBL>0 .or. & + VBF%id_Bdif_idV_ePBL>0 .or. VBF%id_Bdif_idV_KS>0 .or. VBF%id_Bdif_idV_bkgnd>0 .or. & + VBF%id_Bdif_idV_ddiff_temp>0 .or. VBF%id_Bdif_idV_leak>0 .or. VBF%id_Bdif_idV_quad>0 .or. & + VBF%id_Bdif_idV_itidal>0 .or. VBF%id_Bdif_idV_Froude>0 .or. VBF%id_Bdif_idV_slope>0 .or. & + VBF%id_Bdif_idV_lowmode>0 .or. VBF%id_Bdif_idV_Niku>0 .or. VBF%id_Bdif_idV_itides>0 .or. & + VBF%id_Bdif_idz>0 .or. VBF%id_Bdif_temp_idz>0 .or. VBF%id_Bdif_idz_BBL>0 .or. & + VBF%id_Bdif_idz_ePBL>0 .or. VBF%id_Bdif_idz_KS>0 .or. VBF%id_Bdif_idz_bkgnd>0 .or. & + VBF%id_Bdif_idz_ddiff_temp>0 .or. VBF%id_Bdif_idz_leak>0 .or. VBF%id_Bdif_idz_quad>0 .or. & + VBF%id_Bdif_idz_itidal>0 .or. VBF%id_Bdif_idz_Froude>0 .or. VBF%id_Bdif_idz_slope>0 .or. & + VBF%id_Bdif_idz_lowmode>0 .or. VBF%id_Bdif_idz_Niku>0 .or. VBF%id_Bdif_idz_itides>0 ) then + VBF%do_bflx_temp_dz = .true. + endif + if (VBF%id_Bdif>0 .or. VBF%id_Bdif_salt>0 .or. VBF%id_Bdif_BBL>0 .or. & + VBF%id_Bdif_ePBL>0 .or. VBF%id_Bdif_KS>0 .or. VBF%id_Bdif_bkgnd>0 .or. & + VBF%id_Bdif_ddiff_salt>0 .or. VBF%id_Bdif_leak>0 .or. VBF%id_Bdif_quad>0 .or. & + VBF%id_Bdif_itidal>0 .or. VBF%id_Bdif_Froude>0 .or. VBF%id_Bdif_slope>0 .or. & + VBF%id_Bdif_lowmode>0 .or. VBF%id_Bdif_Niku>0 .or. VBF%id_Bdif_itides>0 .or. & + VBF%do_bflx_salt_dz) then + VBF%do_bflx_salt = .true. + endif + if (VBF%id_Bdif>0 .or. VBF%id_Bdif_temp>0 .or. VBF%id_Bdif_BBL>0 .or. & + VBF%id_Bdif_ePBL>0 .or. VBF%id_Bdif_KS>0 .or. VBF%id_Bdif_bkgnd>0 .or. & + VBF%id_Bdif_ddiff_temp>0 .or. VBF%id_Bdif_leak>0 .or. VBF%id_Bdif_quad>0 .or. & + VBF%id_Bdif_itidal>0 .or. VBF%id_Bdif_Froude>0 .or. VBF%id_Bdif_slope>0 .or. & + VBF%id_Bdif_lowmode>0 .or. VBF%id_Bdif_Niku>0 .or. VBF%id_Bdif_itides>0 .or. & + VBF%do_bflx_temp_dz) then + VBF%do_bflx_temp = .true. + endif + + Use_KdWork_diag = (VBF%do_bflx_salt .or. VBF%do_bflx_temp .or. VBF%do_bflx_salt_dz .or. VBF%do_bflx_temp_dz) + +end subroutine KdWork_init + +!> Deallocates control structrue +subroutine KdWork_end(VBF) + type (vbf_CS), pointer, intent(inout) :: VBF !< Vertical buoyancy flux structure + + if (associated(VBF)) deallocate(VBF) + +end subroutine KdWork_end + +!> \namespace mom_diagnose_kdwork +!! +!! The subroutine diagnoseKdWork diagnoses the energetics associated with various vertical diffusivities +!! inside MOM6 diabatic routines. +!! + +end module MOM_diagnose_kdwork diff --git a/src/diagnostics/MOM_diagnose_MLD.F90 b/src/diagnostics/MOM_diagnose_MLD.F90 new file mode 100644 index 0000000000..b2b231cb37 --- /dev/null +++ b/src/diagnostics/MOM_diagnose_MLD.F90 @@ -0,0 +1,605 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Provides functions for some diabatic processes such as fraxil, brine rejection, +!! tendency due to surface flux divergence. +module MOM_diagnose_mld + +use MOM_diag_mediator, only : post_data +use MOM_diag_mediator, only : diag_ctrl +use MOM_EOS, only : calculate_density, calculate_TFreeze, EOS_domain +use MOM_EOS, only : calculate_specific_vol_derivs, calculate_density_derivs +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public diagnoseMLDbyEnergy, diagnoseMLDbyDensityDifference + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +contains +!> Diagnose a mixed layer depth (MLD) determined by a given density difference with the surface. +!> This routine is appropriate in MOM_diabatic_aux due to its position within the time stepping. +subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, diagPtr, & + ref_h_mld, id_ref_z, id_ref_rho, id_N2subML, id_MLDsq, & + dz_subML, MLD_out) + type(ocean_grid_type), intent(in) :: G !< Grid type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: id_MLD !< Handle (ID) of MLD diagnostic + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any + !! available thermodynamic fields. + real, intent(in) :: densityDiff !< Density difference to determine MLD [R ~> kg m-3] + type(diag_ctrl), pointer :: diagPtr !< Diagnostics structure + real, intent(in) :: ref_h_mld !< Depth of the calculated "surface" densisty [Z ~> m] + integer, intent(in) :: id_ref_z !< Handle (ID) of reference depth diagnostic + integer, intent(in) :: id_ref_rho !< Handle (ID) of reference density diagnostic + integer, optional, intent(in) :: id_N2subML !< Optional handle (ID) of subML stratification + integer, optional, intent(in) :: id_MLDsq !< Optional handle (ID) of squared MLD + real, optional, intent(in) :: dz_subML !< The distance over which to calculate N2subML + !! or 50 m if missing [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(out) :: MLD_out !< Send MLD to other routines [Z ~> m] + + ! Local variables + real, dimension(SZI_(G)) :: deltaRhoAtKm1, deltaRhoAtK ! Density differences [R ~> kg m-3]. + real, dimension(SZI_(G)) :: pRef_MLD, pRef_N2 ! Reference pressures [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G)) :: hRef_MLD ! Reference depth [Z ~> m]. + real, dimension(SZI_(G)) :: H_subML, dH_N2 ! Summed thicknesses used in N2 calculation [H ~> m or kg m-2] + real, dimension(SZI_(G)) :: dZ_N2 ! Summed vertical distance used in N2 calculation [Z ~> m] + real, dimension(SZI_(G)) :: T_subML, T_deeper ! Temperatures used in the N2 calculation [C ~> degC]. + real, dimension(SZI_(G)) :: S_subML, S_deeper ! Salinities used in the N2 calculation [S ~> ppt]. + real, dimension(SZI_(G)) :: rho_subML, rho_deeper ! Densities used in the N2 calculation [R ~> kg m-3]. + real, dimension(SZI_(G),SZK_(GV)) :: dZ_2d ! Layer thicknesses in depth units [Z ~> m] + real, dimension(SZI_(G)) :: dZ, dZm1 ! Layer thicknesses associated with interfaces [Z ~> m] + real, dimension(SZI_(G)) :: rhoSurf ! Density used in finding the mixed layer depth [R ~> kg m-3]. + real, dimension(SZI_(G), SZJ_(G)) :: z_ref_diag ! The actual depth of the reference density [Z ~> m]. + real, dimension(SZI_(G), SZJ_(G)) :: MLD ! Diagnosed mixed layer depth [Z ~> m]. + real, dimension(SZI_(G), SZJ_(G)) :: subMLN2 ! Diagnosed stratification below ML [T-2 ~> s-2]. + real, dimension(SZI_(G), SZJ_(G)) :: MLD2 ! Diagnosed MLD^2 [Z2 ~> m2]. + logical, dimension(SZI_(G)) :: N2_region_set ! If true, all necessary values for calculating N2 + ! have been stored already. + real :: gE_Rho0 ! The gravitational acceleration, sometimes divided by the Boussinesq + ! reference density [H T-2 R-1 ~> m4 s-2 kg-1 or m s-2]. + real :: dZ_sub_ML ! Depth below ML over which to diagnose stratification [Z ~> m] + real :: aFac ! A nondimensional factor [nondim] + real :: ddRho ! A density difference [R ~> kg m-3] + real :: dddpth ! A depth difference [Z ~> m] + real :: rhoSurf_k, rhoSurf_km1 ! Desisty in the layers below and above the target reference depth [R ~> kg m-3]. + real, dimension(SZI_(G), SZJ_(G)) :: rhoSurf_2d ! The density that is considered the "surface" when calculating + ! the MLD. It can be saved as a diagnostic [R ~> kg m-3]. + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, is, ie, js, je, k, nz, id_N2, id_SQ + + id_SQ = -1 ; if (PRESENT(id_MLDsq)) id_SQ = id_MLDsq + + id_N2 = -1 + if (present(id_N2subML)) then + if (present(dz_subML)) then + id_N2 = id_N2subML + dZ_sub_ML = dz_subML + else + call MOM_error(FATAL, "When the diagnostic of the subML stratification is "//& + "requested by providing id_N2_subML to diagnoseMLDbyDensityDifference, "//& + "the distance over which to calculate that distance must also be provided.") + endif + endif + + gE_rho0 = GV%g_Earth_Z_T2 / GV%H_to_RZ + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + hRef_MLD(:) = ref_h_mld + pRef_MLD(:) = GV%H_to_RZ*GV%g_Earth*ref_h_mld + z_ref_diag(:,:) = 0. + + EOSdom(:) = EOS_domain(G%HI) + do j=js,je + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dZ_2d, j, G, GV) + + if (pRef_MLD(is) /= 0.0) then + rhoSurf(:) = 0.0 + do i=is,ie + dZ(i) = 0.5 * dZ_2d(i,1) ! Depth of center of surface layer + if (dZ(i) >= hRef_MLD(i)) then + call calculate_density(tv%T(i,j,1), tv%S(i,j,1), pRef_MLD(i), rhoSurf_k, tv%eqn_of_state) + rhoSurf(i) = rhoSurf_k + endif + enddo + do k=2,nz + do i=is,ie + dZm1(i) = dZ(i) ! Depth of center of layer K-1 + dZ(i) = dZ(i) + 0.5 * ( dZ_2d(i,k) + dZ_2d(i,k-1) ) ! Depth of center of layer K + dddpth = dZ(i) - dZm1(i) + if ((rhoSurf(i) == 0.) .and. & + (dZm1(i) < hRef_MLD(i)) .and. (dZ(i) >= hRef_MLD(i))) then + aFac = ( hRef_MLD(i) - dZm1(i) ) / dddpth + z_ref_diag(i,j) = (dZ(i) * aFac + dZm1(i) * (1. - aFac)) + call calculate_density(tv%T(i,j,k) , tv%S(i,j,k) , pRef_MLD(i), rhoSurf_k, tv%eqn_of_state) + call calculate_density(tv%T(i,j,k-1), tv%S(i,j,k-1), pRef_MLD(i), rhoSurf_km1, tv%eqn_of_state) + rhoSurf(i) = (rhoSurf_k * aFac + rhoSurf_km1 * (1. - aFac)) + H_subML(i) = h(i,j,k) + elseif ((rhoSurf(i) == 0.) .and. (k >= nz)) then + call calculate_density(tv%T(i,j,1), tv%S(i,j,1), pRef_MLD(i), rhoSurf_k, tv%eqn_of_state) + rhoSurf(i) = rhoSurf_k + endif + enddo + enddo + do i=is,ie + dZ(i) = 0.5 * dZ_2d(i,1) ! reset dZ to surface depth + rhoSurf_2d(i,j) = rhoSurf(i) + deltaRhoAtK(i) = 0. + MLD(i,j) = 0. + if (id_N2>0) then + subMLN2(i,j) = 0.0 + dH_N2(i) = 0.0 ; dZ_N2(i) = 0.0 + T_subML(i) = 0.0 ; S_subML(i) = 0.0 ; T_deeper(i) = 0.0 ; S_deeper(i) = 0.0 + N2_region_set(i) = (G%mask2dT(i,j)<0.5) ! Only need to work on ocean points. + endif + enddo + elseif (pRef_MLD(is) == 0.0) then + rhoSurf(:) = 0.0 + do i=is,ie ; dZ(i) = 0.5 * dZ_2d(i,1) ; enddo ! Depth of center of surface layer + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, tv%eqn_of_state, EOSdom) + do i=is,ie + rhoSurf_2d(i,j) = rhoSurf(i) + deltaRhoAtK(i) = 0. + MLD(i,j) = 0. + if (id_N2>0) then + subMLN2(i,j) = 0.0 + H_subML(i) = h(i,j,1) ; dH_N2(i) = 0.0 ; dZ_N2(i) = 0.0 + T_subML(i) = 0.0 ; S_subML(i) = 0.0 ; T_deeper(i) = 0.0 ; S_deeper(i) = 0.0 + N2_region_set(i) = (G%mask2dT(i,j)<0.5) ! Only need to work on ocean points. + endif + enddo + endif + + do k=2,nz + do i=is,ie + dZm1(i) = dZ(i) ! Depth of center of layer K-1 + dZ(i) = dZ(i) + 0.5 * ( dZ_2d(i,k) + dZ_2d(i,k-1) ) ! Depth of center of layer K + enddo + + ! Prepare to calculate stratification, N2, immediately below the mixed layer by finding + ! the cells that extend over at least dz_subML. + if (id_N2>0) then + do i=is,ie + if (MLD(i,j) == 0.0) then ! Still in the mixed layer. + H_subML(i) = H_subML(i) + h(i,j,k) + elseif (.not.N2_region_set(i)) then ! This block is below the mixed layer, but N2 has not been found yet. + if (dZ_N2(i) == 0.0) then ! Record the temperature, salinity, pressure, immediately below the ML + T_subML(i) = tv%T(i,j,k) ; S_subML(i) = tv%S(i,j,k) + H_subML(i) = H_subML(i) + 0.5 * h(i,j,k) ! Start midway through this layer. + dH_N2(i) = 0.5 * h(i,j,k) + dZ_N2(i) = 0.5 * dz_2d(i,k) + elseif (dZ_N2(i) + dZ_2d(i,k) < dZ_sub_ML) then + dH_N2(i) = dH_N2(i) + h(i,j,k) + dZ_N2(i) = dZ_N2(i) + dz_2d(i,k) + else ! This layer includes the base of the region where N2 is calculated. + T_deeper(i) = tv%T(i,j,k) ; S_deeper(i) = tv%S(i,j,k) + dH_N2(i) = dH_N2(i) + 0.5 * h(i,j,k) + dZ_N2(i) = dZ_N2(i) + 0.5 * dz_2d(i,k) + N2_region_set(i) = .true. + endif + endif + enddo ! i-loop + endif ! id_N2>0 + + ! Mixed-layer depth, using sigma-0 (surface reference pressure) + do i=is,ie ; deltaRhoAtKm1(i) = deltaRhoAtK(i) ; enddo ! Store value from previous iteration of K + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, tv%eqn_of_state, EOSdom) + do i = is, ie + deltaRhoAtK(i) = deltaRhoAtK(i) - rhoSurf(i) ! Density difference between layer K and surface + ddRho = deltaRhoAtK(i) - deltaRhoAtKm1(i) + if ((MLD(i,j) == 0.) .and. (ddRho > 0.) .and. & + (deltaRhoAtKm1(i) < densityDiff) .and. (deltaRhoAtK(i) >= densityDiff)) then + aFac = ( densityDiff - deltaRhoAtKm1(i) ) / ddRho + MLD(i,j) = (dZ(i) * aFac + dZm1(i) * (1. - aFac)) + endif + if (id_SQ > 0) MLD2(i,j) = MLD(i,j)**2 + enddo ! i-loop + enddo ! k-loop + do i=is,ie + if ((MLD(i,j) == 0.) .and. (deltaRhoAtK(i) < densityDiff)) MLD(i,j) = dZ(i) ! Mixing goes to the bottom + enddo + + if (id_N2>0) then ! Now actually calculate stratification, N2, below the mixed layer. + do i=is,ie ; pRef_N2(i) = (GV%g_Earth * GV%H_to_RZ) * (H_subML(i) + 0.5*dH_N2(i)) ; enddo + ! if ((.not.N2_region_set(i)) .and. (dZ_N2(i) > 0.5*dZ_sub_ML)) then + ! ! Use whatever stratification we can, measured over whatever distance is available? + ! T_deeper(i) = tv%T(i,j,nz) ; S_deeper(i) = tv%S(i,j,nz) + ! N2_region_set(i) = .true. + ! endif + call calculate_density(T_subML, S_subML, pRef_N2, rho_subML, tv%eqn_of_state, EOSdom) + call calculate_density(T_deeper, S_deeper, pRef_N2, rho_deeper, tv%eqn_of_state, EOSdom) + do i=is,ie ; if ((G%mask2dT(i,j) > 0.0) .and. N2_region_set(i)) then + subMLN2(i,j) = gE_rho0 * (rho_deeper(i) - rho_subML(i)) / dH_N2(i) + endif ; enddo + endif + enddo ! j-loop + + if (id_MLD > 0) call post_data(id_MLD, MLD, diagPtr) + if (id_N2 > 0) call post_data(id_N2, subMLN2, diagPtr) + if (id_SQ > 0) call post_data(id_SQ, MLD2, diagPtr) + + if ((id_ref_z > 0) .and. (pRef_MLD(is)/=0.)) call post_data(id_ref_z, z_ref_diag , diagPtr) + if (id_ref_rho > 0) call post_data(id_ref_rho, rhoSurf_2d , diagPtr) + + if (present(MLD_out)) then + MLD_out(:,:) = 0.0 + MLD_out(is:ie,js:je) = MLD(is:ie,js:je) + endif + +end subroutine diagnoseMLDbyDensityDifference + +!> Diagnose a mixed layer depth (MLD) determined by the depth a given energy value would mix. +!> This routine is appropriate in MOM_diabatic_aux due to its position within the time stepping. +subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, k_bounds, diagPtr, OM4_iteration, MLD_out) + ! Author: Brandon Reichl + ! Date: October 2, 2020 + ! // + ! *Note that gravity is assumed constant everywhere and divided out of all calculations. + ! + ! This code has been written to step through the columns layer by layer, summing the PE + ! change inferred by mixing the layer with all layers above. When the change exceeds a + ! threshold (determined by input array Mixing_Energy), the code needs to solve for how far + ! into this layer the threshold PE change occurs (assuming constant density layers). + ! This is expressed here via solving the function F(X) = 0 where: + ! F(X) = 0.5 * ( Ca*X^3/(D1+X) + Cb*X^2/(D1+X) + Cc*X/(D1+X) + Dc/(D1+X) + ! + Ca2*X^2 + Cb2*X + Cc2) + ! where all coefficients are determined by the previous mixed layer depth, the + ! density of the previous mixed layer, the present layer thickness, and the present + ! layer density. This equation is worked out by computing the total PE assuming constant + ! density in the mixed layer as well as in the remaining part of the present layer that is + ! not mixed. + ! To solve for X in this equation a Newton's method iteration is employed, which + ! converges extremely quickly (usually 1 guess) since this equation turns out to be rather + ! linear for PE change with increasing X. + ! Input parameters: + integer, dimension(3), intent(in) :: id_MLD !< Energy output diagnostic IDs + type(ocean_grid_type), intent(in) :: G !< Grid type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(3), intent(in) :: Mixing_Energy !< Energy values for up to 3 MLDs [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any + !! available thermodynamic fields. + type(diag_ctrl), pointer :: diagPtr !< Diagnostics structure + integer, dimension(2), intent(in) :: k_bounds !< vertical interface bounds to apply calculations + logical, optional, intent(in) :: OM4_iteration !< Uses a legacy version of the MLD iteration + !! it is kept to reproduce OM4 output + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(out) :: MLD_out !< Send MLD to other routines [Z ~> m] + + ! Local variables + real, dimension(SZI_(G),SZJ_(G),3) :: MLD ! Diagnosed mixed layer depth [Z ~> m]. + real, dimension(SZK_(GV)+1) :: Z_int ! Depths of the interfaces from the surface [Z ~> m] + real, dimension(SZI_(G),SZK_(GV)) :: dZ ! Layer thicknesses in depth units [Z ~> m] + real, dimension(SZI_(G),SZK_(GV)) :: Rho_c ! Columns of layer densities [R ~> kg m-3] + real, dimension(SZI_(G)) :: pRef_MLD ! The reference pressure for the mixed layer + ! depth calculation [R L2 T-2 ~> Pa] + real, dimension(3) :: PE_threshold ! The energy threshold divided by g [R Z2 ~> kg m-1] + + real :: PE_Threshold_fraction ! The fractional tolerance of the specified energy + ! for the energy used to mix to the diagnosed depth [nondim] + real :: H_ML ! The accumulated depth of the mixed layer [Z ~> m] + real :: PE ! The cumulative potential energy of the unmixed water column to a depth + ! of H_ML, divided by the gravitational acceleration [R Z2 ~> kg m-1] + real :: PE_Mixed ! The potential energy of the completely mixed water column to a depth + ! of H_ML, divided by the gravitational acceleration [R Z2 ~> kg m-1] + real :: RhoDZ_ML ! The depth integrated density of the mixed layer [R Z ~> kg m-2] + real :: H_ML_TST ! A new test value for the depth of the mixed layer [Z ~> m] + real :: PE_Mixed_TST ! The potential energy of the completely mixed water column to a depth + ! of H_ML_TST, divided by the gravitational acceleration [R Z2 ~> kg m-1] + real :: RhoDZ_ML_TST ! A test value of the new depth integrated density of the mixed layer [R Z ~> kg m-2] + real :: Rho_ML ! The average density of the mixed layer [R ~> kg m-3] + + ! These are all temporary variables used to shorten the expressions in the iterations. + real :: R1, R2, Ca, Ca2 ! Some densities [R ~> kg m-3] + real :: D1, D2, X, X2 ! Some thicknesses [Z ~> m] + real :: Cb, Cb2 ! A depth integrated density [R Z ~> kg m-2] + real :: C, D ! A depth squared [Z2 ~> m2] + real :: Cc, Cc2 ! A density times a depth squared [R Z2 ~> kg m-1] + real :: Cd ! A density times a depth cubed [R Z3 ~> kg] + real :: Gx ! A triple integral in depth of density [R Z3 ~> kg] + real :: Gpx ! The derivative of Gx with x [R Z2 ~> kg m-1] + real :: Hx ! The vertical integral depth [Z ~> m] + real :: iHx ! The inverse of Hx [Z-1 ~> m-1] + real :: Hpx ! The derivative of Hx with x, since H(x) = constant + x, its derivative is 1. [nondim] + real :: Ix ! A double integral in depth of density [R Z2 ~> kg m-1] + real :: Ipx ! The derivative of Ix with x [R Z ~> kg m-2] + real :: Fgx ! The mixing energy difference from the target [R Z2 ~> kg m-1] + real :: Fpx ! The derivative of Fgx with x [R Z ~> kg m-2] + real :: Zr ! An upper (lower) bound for the PE integration in surface (bottom) mixed layer mode [Z ~> m] + integer :: k_Zr ! Sets the index of Zr + real :: pe_dir ! A factor that is used to generalize the iteration for upper and lower mixed layers + integer :: k_int ! Controls the direction of the loop to be forward or backward + logical :: use_OM4_iteration ! A logical to use the OM4_iteration if the optional argument is present + + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: IT, iM + integer :: i, j, is, ie, js, je, k, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (present(OM4_iteration)) then + use_OM4_iteration = OM4_iteration + endif + + pRef_MLD(:) = 0.0 + mld(:,:,:) = 0.0 + PE_Threshold_fraction = 1.e-4 !Fixed threshold of 0.01%, could be runtime. + + ! The derivative of H(x) is always 1., so it is moved outside the loops. + Hpx = 1. + + do iM=1,3 + PE_threshold(iM) = Mixing_Energy(iM) / GV%g_Earth_Z_T2 + enddo + + EOSdom(:) = EOS_domain(G%HI) + + if (k_bounds(1)0) then + ! We want to reference pressure to bottom for upward calculation + pRef_MLD(:) = 0.0 + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + do k=1,nz + pRef_MLD(i) = pRef_MLD(i) + h(i,j,k)*GV%H_to_RZ*GV%g_Earth + enddo + endif ; enddo + endif + + do k=1,nz + call calculate_density(tv%T(:,j,k), tv%S(:,j,K), pRef_MLD(:), rho_c(:,k), tv%eqn_of_state, EOSdom) + enddo + + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + + !We reference everything to the SSH, so that Z_int(1) is defined where Z=0. + ! All presently implemented calculations are not sensitive to this choice. + ! If "use_OM4_iteration = .true." setting this non-zero would break the iteration + Z_int(1) = 0.0 + do k=1,nz + Z_int(K+1) = Z_int(K) - dZ(i,k) + enddo + + ! Set the reference for the upper (lower) bound of the mixing integral as the surface + ! or the bottom depending on the direction of the calculation (as determined by + ! the interface bounds k_bounds) + Zr = Z_int(k_Zr) + + do iM=1,3 + + ! Initialize these for each column-wise calculation + PE = 0.0 + RhoDZ_ML = 0.0 + H_ML = 0.0 + RhoDZ_ML_TST = 0.0 + H_ML_TST = 0.0 + PE_Mixed = 0.0 + + do k=k_bounds(1),k_bounds(2),k_int + + ! This is the unmixed PE cumulative sum in the direction k_int + ! The first expression preserves OM4 diagnostic answers, the second is more robust + if (use_OM4_iteration) then + PE = PE + 0.5 * Rho_c(i,k) * (Z_int(K)**2 - Z_int(K+1)**2) + else + PE = PE + 0.5 * (Rho_c(i,k) * dZ(i,k)) * (Z_int(K) + Z_int(K+1)) + endif + + ! This is the depth and integral of density + H_ML_TST = H_ML + dZ(i,k) + RhoDZ_ML_TST = RhoDZ_ML + Rho_c(i,k) * dZ(i,k) + + ! The average density assuming all layers including this were mixed + Rho_ML = RhoDZ_ML_TST/H_ML_TST + + ! The PE assuming all layers including this were mixed + ! Zr is the upper (lower) bound of the integral when operating in surface (bottom) + ! mixed layer calculation mode. + !These are mathematically equivalent, the latter is numerically well-behaved, but the + ! former is kept as a comment as it may be more intuitive how it is derived. + !PE_Mixed_TST = (0.5 * (Rho_ML*pe_dir)) * ( (Zr + pe_dir*H_ML_TST)**2 - Zr**2.) + PE_Mixed_TST = (0.5 * (Rho_ML*pe_dir)) * (H_ML_TST * (H_ML_TST + 2.0*pe_dir*Zr)) + + ! Check if we supplied enough energy to mix to this layer + if (PE_Mixed_TST - PE <= PE_threshold(iM)) then + H_ML = H_ML_TST + RhoDZ_ML = RhoDZ_ML_TST + else ! If not, we need to solve where the energy ran out within the layer + ! This will be done with a Newton's method iteration: + + ! First guess for an iteration using Newton's method + X = dZ(i,k) * 0.5 + + ! We are trying to solve the function: + ! F(x) = G(x)/H(x)+I(x) + ! for where F(x) = PE+PE_threshold, or equivalently for where + ! F(x) = G(x)/H(x)+I(x) - (PE+PE_threshold) = 0 + ! We also need the derivative of this function for the Newton's method iteration + ! F'(x) = (G'(x)H(x)-G(x)H'(x))/H(x)^2 + I'(x) + ! + !For the Surface Boundary Layer: + ! The total function F(x) adds the PE of the top layer with some entrained distance X + ! to the PE of the bottom layer below the entrained distance: + ! (Rho1*D1+Rho2*x) + ! PE = ---------------- (Zr^2 - (Zr-D1-x)^2) + Rho2 * ((Zr-D1-x)^2 - (Zr-D1-D2)^2) + ! (D1 + x) + ! + ! where Rho1 is the mixed density, D1 is the mixed thickness, Rho2 is the unmixed density, + ! D2 is the unmixed thickness, Zr is the top surface height, and x is the fraction of the + ! unmixed region that becomes mixed. + ! + !// + !G(x) = (Rho1*D1+Rho2*x)*(Zr^2 - (Zr-(D1+x))^2) + ! + ! = -Rho2 * x^3 + (-Rho1*D1-2*Rho2*D1+2*Rho2*Zr)*x^2 + ! \-Ca-/ \--------Cb----------------/ + ! + ! + (-2*Rho1*D1^2+2*Rho1*D1*Zr-Rho2*D1^2+Rho2*2*D1*Zr)*X + Rho1*(-D1^3+2*D1^2*Zr) + ! \----------------------Cc----------------------/ \-------Cd----------/ + ! + !// + !H(x) = D1 + x + ! + !// + !I(x) = Rho2 * ((Zr-(D1+x))^2-(Zr-(D1+D2))^2) + ! = Rho2 * x^2 + Rho2*(2*D1-2*Zr) * X + Rho2*(D1^2-2*D1*Zr-D2^2+D1^2-2*D1*Zr-2*D2*Zr+2*D1*D2) + ! \Ca2/ \-----Cb2-----/ \-------------------Cc2----------------------------/ + ! + ! + !For the Bottom Boundary Layer: + ! The total function is relative to Zr as the bottom interface height, so slightly different: + ! (Rho1*D1+Rho2*X) + ! PE = ---------------- ((Zr+D1+X)^2 - Zr^2) + Rho2 * ((Zr+D1+D2)^2 - (Zr+D1+X)^2) + ! (D1 + X) + ! These differences propagate through and are accounted for via the factor pe_dir + ! + ! Set these coefficients before the iteration + R1 = RhoDZ_ML / H_ML ! The density of the mixed layer (not including this layer) + D1 = H_ML ! The thickness of the mixed layer (not including this layer) + R2 = Rho_c(i,k) ! The density of this layer to be mixed + D2 = dZ(i,k) ! The thickness of this layer to be mixed + + ! This sets Zr to "0", which only works for the downward surface mixed layer calculation. + ! it should give the same answer at roundoff as the more general expressions below. + if (k_int>0 .and. use_OM4_iteration) then + Ca = -(R2) + Cb = -(R1 * D1 + R2 * (2. * D1)) + D = D1**2 + Cc = -(R1 * D1 * (2. * D1) + (R2 * D)) + Cd = -R1 * (D1 * D) + Ca2 = R2 + Cb2 = R2 * (2. * D1) + C = D2**2 + D1**2 + 2. * (D1 * D2) + D = D1**2 + Cc2 = R2 * (D - C) + else + ! recall pe_dir = -1 for down, pe_dir = 1 for up. + !down Ca = -R2 + !up Ca = R2 + Ca = pe_dir * R2 ! Density of layer to be mixed + !down Cb = -(R1*D1) - 2.*R2*D1 + 2.*Zr*R2 + !up Cb = (R1*D1) + 2.*R2*D1 + 2.*Zr*R2 + Cb = pe_dir * ( (R1 * D1) + (2. * R2) * ( D1 + Zr ) ) + !down Cc = -2.*R1*D1**2 - R2*D1**2 + 2.*R2*D1*Zr + 2.*Zr*R1*D1 + !up Cc = 2.*R1*D1**2 + R2*D1**2 + 2.*R2*D1*Zr + 2.*Zr*R1*D1 + Cc = ( pe_dir * D1**2 ) * ( R2 + 2.*R1 ) + ( 2. * ( Zr * D1 ) ) * ( R2 + R1 ) + !down Cd = R1*(-D1**3+2.*D1**2*Zr) + !up Cd = R1*( D1**3+2.*D1**2*Zr) + Cd = ( R1 * D1**2 ) * ( pe_dir * D1 + 2. * Zr ) + !down Ca2 = R2 + !up Ca2 = -R2 + Ca2 = ( -1. * pe_dir ) * R2 + !down Cb2 = R2*(2*D1-2*Zr) + !up Cb2 = R2*(-2*D1-2*Zr) + Cb2 = ( 2. * R2 ) * ( (-1.*pe_dir)*D1 - Zr ) + !down Cc2 = R2*(2.*Zr*D2-2.*D1*D2-D2**2) + !up Cc2 = R2*(2.*Zr*D2+2.*D1*D2+D2**2) + Cc2 = ( R2 * D2 ) * ( 2.* Zr + pe_dir * ( 2. * D1 + D2 ) ) + endif + + IT=0 + do while(IT<10)!We can iterate up to 10 times + + ! G and its derivative + Gx = 0.5 * (Ca * (X*X*X) + Cb * X**2 + Cc * X + Cd) + Gpx = 0.5 * (3. * (Ca * X**2) + 2. * (Cb * X) + Cc) + ! H, its inverse, and its derivative + Hx = D1 + X + iHx = 1. / Hx + !Hpx = 1. ! The derivative is always 1 so it was moved outside the loop + ! I and its derivative + Ix = 0.5 * (Ca2 * X**2 + Cb2 * X + Cc2) + Ipx = 0.5 * (2. * Ca2 * X + Cb2) + + ! The Function and its derivative: + PE_Mixed = Gx * iHx + Ix + Fgx = PE_Mixed - (PE + PE_threshold(iM)) + Fpx = (Gpx * Hx - Hpx * Gx) * iHx**2 + Ipx + + ! Check if our solution is within the threshold bounds, if not update + ! using Newton's method. This appears to converge almost always in + ! one step because the function is very close to linear in most applications. + if (abs(Fgx) > PE_Threshold(iM) * PE_Threshold_fraction) then + X2 = X - Fgx / Fpx + IT = IT + 1 + if (X2 < 0. .or. X2 > dZ(i,k)) then + ! The iteration seems to be robust, but we need to do something *if* + ! things go wrong... How should we treat failed iteration? + ! Present solution: Stop trying to compute and just say we can't mix this layer. + X=0 + exit + else + X = X2 + endif + else + exit! Quit the iteration + endif + enddo + H_ML = H_ML + X + exit! Quit looping through the column + endif + enddo + MLD(i,j,iM) = H_ML + enddo + endif ; enddo + enddo + + if (id_MLD(1) > 0) call post_data(id_MLD(1), MLD(:,:,1), diagPtr) + if (id_MLD(2) > 0) call post_data(id_MLD(2), MLD(:,:,2), diagPtr) + if (id_MLD(3) > 0) call post_data(id_MLD(3), MLD(:,:,3), diagPtr) + + if (present(MLD_out)) then + MLD_out(:,:) = 0.0 + MLD_out(is:ie,js:je) = MLD(is:ie,js:je,1) + endif + +end subroutine diagnoseMLDbyEnergy + +!> \namespace mom_diagnose_mld +!! +!! This module contains subroutines that apply various diabatic processes. Usually these +!! subroutines are called from the MOM_diabatic module. All of these routines use appropriate +!! limiters or logic to work properly with arbitrary layer thicknesses (including massless layers) +!! and an arbitrarily large timestep. +!! +!! The subroutine diagnoseMLDbyDensityDifference diagnoses a mixed layer depth based on a +!! density difference criterion, and may also estimate the stratification of the water below +!! this diagnosed mixed layer. +!! +!! The subroutine diagnoseMLDbyEnergy diagnoses a mixed layer depth based on a mixing-energy +!! criterion, as described by Reichl et al., 2022, JGR: Oceans, doi:10.1029/2021JC018140. +!! + +end module MOM_diagnose_mld diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 8d667503d7..de44b07c49 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1,10 +1,12 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Calculates any requested diagnostic quantities !! that are not calculated in the various subroutines. !! Diagnostic quantities are requested by allocating them memory. module MOM_diagnostics -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_coms, only : reproducing_sum use MOM_coupler_types, only : coupler_type_send_data use MOM_density_integrals, only : int_density_dz @@ -20,26 +22,27 @@ module MOM_diagnostics use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type use MOM_domains, only : To_North, To_East use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain -use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct +use MOM_EOS, only : cons_temp_to_pot_temp, pot_temp_to_cons_temp +use MOM_EOS, only : prac_saln_to_abs_saln, abs_saln_to_prac_saln use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_interface_heights, only : find_eta +use MOM_interface_heights, only : find_eta, find_dz_for_eta, find_col_mass use MOM_spatial_means, only : global_area_mean, global_layer_mean use MOM_spatial_means, only : global_volume_mean, global_area_integral use MOM_tracer_registry, only : tracer_registry_type, post_tracer_transport_diagnostics use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, ocean_internal_state, p3d use MOM_variables, only : accel_diag_ptrs, cont_diag_ptrs, surface -use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units +use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units, get_flux_units use MOM_wave_speed, only : wave_speed, wave_speed_CS, wave_speed_init +use Recon1d_EPPM_CWK, only : EPPM_CWK implicit none ; private #include public calculate_diagnostic_fields, register_time_deriv, write_static_fields -public find_eta public register_surface_diags, post_surface_dyn_diags, post_surface_thermo_diags public register_transport_diags, post_transport_diagnostics public MOM_diagnostics_init, MOM_diagnostics_end @@ -54,9 +57,13 @@ module MOM_diagnostics logical :: initialized = .false. !< True if this control structure has been initialized. real :: mono_N2_column_fraction = 0. !< The lower fraction of water column over which N2 is limited as !! monotonic for the purposes of calculating the equivalent - !! barotropic wave speed. + !! barotropic wave speed [nondim]. real :: mono_N2_depth = -1. !< The depth below which N2 is limited as monotonic for the purposes of - !! calculating the equivalent barotropic wave speed [Z ~> m]. + !! calculating the equivalent barotropic wave speed [H ~> m or kg m-2]. + logical :: accurate_thick_cello !< If true, use the same careful integrals to find the diagnosed + !! non-Boussinesq layer thicknesses as are used to find the free + !! surface height, instead of using an approximate thickness + !! based on division by the mid-layer density. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. @@ -81,8 +88,13 @@ module MOM_diagnostics integer :: id_col_ht = -1, id_dh_dt = -1 integer :: id_KE = -1, id_dKEdt = -1 integer :: id_PE_to_KE = -1, id_KE_BT = -1 + integer :: id_KE_SAL = -1, id_KE_TIDES = -1 + integer :: id_KE_BT_PF = -1, id_KE_BT_CF = -1 + integer :: id_KE_BT_WD = -1 + integer :: id_PE_to_KE_btbc = -1, id_KE_Coradv_btbc = -1 integer :: id_KE_Coradv = -1, id_KE_adv = -1 integer :: id_KE_visc = -1, id_KE_stress = -1 + integer :: id_KE_visc_gl90 = -1 integer :: id_KE_horvisc = -1, id_KE_dia = -1 integer :: id_uh_Rlay = -1, id_vh_Rlay = -1 integer :: id_uhGM_Rlay = -1, id_vhGM_Rlay = -1 @@ -93,19 +105,28 @@ module MOM_diagnostics integer :: id_cg_ebt = -1, id_Rd_ebt = -1 integer :: id_p_ebt = -1 integer :: id_temp_int = -1, id_salt_int = -1 + integer :: id_absscint = -1, id_pfscint = -1 + integer :: id_scint = -1 + integer :: id_chcint = -1, id_phcint = -1 integer :: id_mass_wt = -1, id_col_mass = -1 integer :: id_masscello = -1, id_masso = -1 integer :: id_volcello = -1 integer :: id_Tpot = -1, id_Sprac = -1 integer :: id_tob = -1, id_sob = -1 integer :: id_thetaoga = -1, id_soga = -1 + integer :: id_bigthetaoga = -1, id_abssoga = -1 integer :: id_sosga = -1, id_tosga = -1 + integer :: id_abssosga = -1, id_bigtosga = -1 integer :: id_temp_layer_ave = -1, id_salt_layer_ave = -1 + integer :: id_bigtemp_layer_ave = -1, id_abssalt_layer_ave = -1 integer :: id_pbo = -1 integer :: id_thkcello = -1, id_rhoinsitu = -1 integer :: id_rhopot0 = -1, id_rhopot2 = -1 integer :: id_drho_dT = -1, id_drho_dS = -1 integer :: id_h_pre_sync = -1 + integer :: id_tosq = -1, id_sosq = -1 + integer :: id_t20d = -1, id_t17d = -1 + !>@} type(wave_speed_CS) :: wave_speed !< Wave speed control struct @@ -133,6 +154,7 @@ module MOM_diagnostics integer :: id_sst = -1, id_sst_sq = -1, id_sstcon = -1 integer :: id_sss = -1, id_sss_sq = -1, id_sssabs = -1 integer :: id_ssu = -1, id_ssv = -1 + integer :: id_ssu_east = -1, id_ssv_north = -1 ! Diagnostic IDs for heat and salt flux fields integer :: id_fraz = -1 @@ -198,18 +220,17 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & real :: Rcv(SZI_(G),SZJ_(G),SZK_(GV)) ! Coordinate variable potential density [R ~> kg m-3]. real :: work_3d(SZI_(G),SZJ_(G),SZK_(GV)) ! A 3-d temporary work array in various units ! including [nondim] and [H ~> m or kg m-2]. + real :: dz_lay(SZI_(G),SZJ_(G),SZK_(GV)) ! Height change across layers [Z ~> m] real :: uh_tmp(SZIB_(G),SZJ_(G),SZK_(GV)) ! A temporary zonal transport [H L2 T-1 ~> m3 s-1 or kg s-1] real :: vh_tmp(SZI_(G),SZJB_(G),SZK_(GV)) ! A temporary meridional transport [H L2 T-1 ~> m3 s-1 or kg s-1] - real :: work_2d(SZI_(G),SZJ_(G)) ! A 2-d temporary work array. + real :: mass_cell(SZI_(G),SZJ_(G)) ! The vertically integrated mass in a grid cell [R Z L2 ~> kg] real :: rho_in_situ(SZI_(G)) ! In situ density [R ~> kg m-3] real :: cg1(SZI_(G),SZJ_(G)) ! First baroclinic gravity wave speed [L T-1 ~> m s-1] real :: Rd1(SZI_(G),SZJ_(G)) ! First baroclinic deformation radius [L ~> m] real :: CFL_cg1(SZI_(G),SZJ_(G)) ! CFL for first baroclinic gravity wave speed, either based on the ! overall grid spacing or just one direction [nondim] - ! tmp array for surface properties - real :: surface_field(SZI_(G),SZJ_(G)) ! The surface temperature or salinity [degC] or [ppt] real :: pressure_1d(SZI_(G)) ! Temporary array for pressure when calling EOS [R L2 T-2 ~> Pa] real :: wt, wt_p ! The fractional weights of two successive values when interpolating from ! a list [nondim], scaled so that wt + wt_p = 1. @@ -219,13 +240,13 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & integer :: k_list - real, dimension(SZK_(GV)) :: temp_layer_ave ! The average temperature in a layer [degC] - real, dimension(SZK_(GV)) :: salt_layer_ave ! The average salinity in a layer [degC] - real :: thetaoga ! The volume mean potential temperature [degC] - real :: soga ! The volume mean ocean salinity [ppt] - real :: masso ! The total mass of the ocean [kg] - real :: tosga ! The area mean sea surface temperature [degC] - real :: sosga ! The area mean sea surface salinity [ppt] + real, dimension(SZK_(GV)) :: temp_layer_ave ! The average temperature in a layer [C ~> degC] + real, dimension(SZK_(GV)) :: salt_layer_ave ! The average salinity in a layer [S ~> ppt] + real :: thetaoga ! The volume mean potential temperature [C ~> degC] + real :: soga ! The volume mean ocean salinity [S ~> ppt] + real :: masso ! The total mass of the ocean [R Z L2 ~> kg] + real :: tosga ! The area mean sea surface temperature [C ~> degC] + real :: sosga ! The area mean sea surface salinity [S ~> ppt] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -234,9 +255,6 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & ! This value is roughly (pi / (the age of the universe) )^2. absurdly_small_freq2 = 1e-34*US%T_to_s**2 - if (loc(CS)==0) call MOM_error(FATAL, & - "calculate_diagnostic_fields: Module must be initialized before used.") - if (.not. CS%initialized) call MOM_error(FATAL, & "calculate_diagnostic_fields: Module must be initialized before used.") @@ -305,41 +323,45 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & call post_data(CS%id_uv, uv, CS%diag) endif - ! Find the interface heights, relative either to a reference height or to the bottom [Z ~> m]. - if (CS%id_e > 0) then - call find_eta(h, tv, G, GV, US, eta, dZref=G%Z_ref) + ! Find the layer thicknesses in [Z ~> m] that can be used to determine interface heights + if ((CS%id_e > 0) .or. (CS%id_e_D > 0) .or. & + ((CS%id_thkcello>0 .or. CS%id_volcello>0) .and. (CS%accurate_thick_cello))) & + call find_dz_for_eta(h, tv, G, GV, US, dz_lay) + + if ((CS%id_e > 0) .or. (CS%id_e_D > 0)) then + ! Find the interface heights, relative a reference height or to the bottom [Z ~> m] + do j=js,je ; do i=is,ie ; eta(i,j,nz+1) = -(G%bathyT(i,j) + G%Z_ref) ; enddo ; enddo + do k=nz,1,-1 ; do j=js,je ; do i=is,ie + eta(i,j,K) = eta(i,j,K+1) + dz_lay(i,j,K) + enddo ; enddo ; enddo if (CS%id_e > 0) call post_data(CS%id_e, eta, CS%diag) + if (CS%id_e_D > 0) then + ! Find the interface heights, relative to the bottom [Z ~> m] do k=1,nz+1 ; do j=js,je ; do i=is,ie eta(i,j,k) = eta(i,j,k) + (G%bathyT(i,j) + G%Z_ref) enddo ; enddo ; enddo + ! This is more accurate but changes answers in the e_D diagnostic: + ! do j=js,je ; do i=is,ie ; eta(i,j,nz+1) = 0.0 ; enddo ; enddo + ! do k=nz,1,-1 ; do j=js,je ; do i=is,ie + ! eta(i,j,K) = eta(i,j,K+1) + dz_lay(i,j,K) + ! enddo ; enddo ; enddo call post_data(CS%id_e_D, eta, CS%diag) endif - elseif (CS%id_e_D > 0) then - call find_eta(h, tv, G, GV, US, eta) - do k=1,nz+1 ; do j=js,je ; do i=is,ie - eta(i,j,k) = eta(i,j,k) + G%bathyT(i,j) - enddo ; enddo ; enddo - call post_data(CS%id_e_D, eta, CS%diag) endif ! mass per area of grid cell (for Boussinesq, use Rho0) if (CS%id_masscello > 0) then - do k=1,nz ; do j=js,je ; do i=is,ie - work_3d(i,j,k) = GV%H_to_kg_m2*h(i,j,k) - enddo ; enddo ; enddo - call post_data(CS%id_masscello, work_3d, CS%diag) - !### If the registration call has conversion=GV%H_to_kg, the mathematically equivalent form would be: - ! call post_data(CS%id_masscello, h, CS%diag) + call post_data(CS%id_masscello, h, CS%diag) endif - ! mass of liquid ocean (for Bouss, use Rho0). The reproducing sum requires the use of MKS units. + ! mass of liquid ocean (for Bouss, use Rho0) [R Z L2 ~> kg] if (CS%id_masso > 0) then - work_2d(:,:) = 0.0 + mass_cell(:,:) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - work_2d(i,j) = work_2d(i,j) + (GV%H_to_kg_m2*h(i,j,k)) * US%L_to_m**2*G%areaT(i,j) + mass_cell(i,j) = mass_cell(i,j) + (GV%H_to_RZ*h(i,j,k)) * G%areaT(i,j) enddo ; enddo ; enddo - masso = reproducing_sum(work_2d) + masso = reproducing_sum(mass_cell, unscale=US%RZL2_to_kg) call post_data(CS%id_masso, masso, CS%diag) endif @@ -350,9 +372,9 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & call post_data(CS%id_thkcello, h, CS%diag) else do k=1,nz ; do j=js,je ; do i=is,ie - work_3d(i,j,k) = GV%H_to_Z*h(i,j,k) + dz_lay(i,j,k) = GV%H_to_Z*h(i,j,k) enddo ; enddo ; enddo - call post_data(CS%id_thkcello, work_3d, CS%diag) + call post_data(CS%id_thkcello, dz_lay, CS%diag) endif ; endif if (CS%id_volcello > 0) then ! volcello = h*area for Boussinesq do k=1,nz ; do j=js,je ; do i=is,ie @@ -360,37 +382,41 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & enddo ; enddo ; enddo call post_data(CS%id_volcello, work_3d, CS%diag) endif - else ! thkcello = dp/(rho*g) for non-Boussinesq - EOSdom(:) = EOS_domain(G%HI) - do j=js,je - if (associated(p_surf)) then ! Pressure loading at top of surface layer [R L2 T-2 ~> Pa] - do i=is,ie - pressure_1d(i) = p_surf(i,j) - enddo - else - do i=is,ie - pressure_1d(i) = 0.0 - enddo - endif - do k=1,nz ! Integrate vertically downward for pressure - do i=is,ie ! Pressure for EOS at the layer center [R L2 T-2 ~> Pa] - pressure_1d(i) = pressure_1d(i) + 0.5*(GV%H_to_RZ*GV%g_Earth)*h(i,j,k) - enddo - ! Store in-situ density [R ~> kg m-3] in work_3d - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, rho_in_situ, & - tv%eqn_of_state, EOSdom) - do i=is,ie ! Cell thickness = dz = dp/(g*rho) (meter); store in work_3d - work_3d(i,j,k) = (GV%H_to_RZ*h(i,j,k)) / rho_in_situ(i) - enddo - do i=is,ie ! Pressure for EOS at the bottom interface [R L2 T-2 ~> Pa] - pressure_1d(i) = pressure_1d(i) + 0.5*(GV%H_to_RZ*GV%g_Earth)*h(i,j,k) - enddo - enddo ! k - enddo ! j - if (CS%id_thkcello > 0) call post_data(CS%id_thkcello, work_3d, CS%diag) + else ! thkcello is approximately dp/(rho*g) in non-Boussinesq mode. + if (.not.CS%accurate_thick_cello) then + ! This is only an approximate calculation of dz_lay that does not use the careful integrals + ! found in find_dz_for_eta that mirror what is done for the pressure gradient calculations. + EOSdom(:) = EOS_domain(G%HI) + do j=js,je + if (associated(p_surf)) then ! Pressure loading at top of surface layer [R L2 T-2 ~> Pa] + do i=is,ie + pressure_1d(i) = p_surf(i,j) + enddo + else + do i=is,ie + pressure_1d(i) = 0.0 + enddo + endif + do k=1,nz ! Integrate vertically downward for pressure + do i=is,ie ! Pressure for EOS at the layer center [R L2 T-2 ~> Pa] + pressure_1d(i) = pressure_1d(i) + 0.5*(GV%H_to_RZ*GV%g_Earth)*h(i,j,k) + enddo + ! Store in-situ density [R ~> kg m-3] in work_3d + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, rho_in_situ, & + tv%eqn_of_state, EOSdom) + do i=is,ie ! Cell thickness = dz = dp/(g*rho) (meter); store in work_3d + dz_lay(i,j,k) = (GV%H_to_RZ*h(i,j,k)) / rho_in_situ(i) + enddo + do i=is,ie ! Pressure for EOS at the bottom interface [R L2 T-2 ~> Pa] + pressure_1d(i) = pressure_1d(i) + 0.5*(GV%H_to_RZ*GV%g_Earth)*h(i,j,k) + enddo + enddo ! k + enddo ! j + endif ! Otherwise dz_lay is set in the call to find_dz_for_eta above. + if (CS%id_thkcello > 0) call post_data(CS%id_thkcello, dz_lay, CS%diag) if (CS%id_volcello > 0) then do k=1,nz ; do j=js,je ; do i=is,ie ! volcello = dp/(rho*g)*area for non-Boussinesq - work_3d(i,j,k) = US%Z_to_m*US%L_to_m**2*G%areaT(i,j) * work_3d(i,j,k) + work_3d(i,j,k) = US%Z_to_m*US%L_to_m**2*G%areaT(i,j) * dz_lay(i,j,k) enddo ; enddo ; enddo call post_data(CS%id_volcello, work_3d, CS%diag) endif @@ -402,75 +428,150 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & ! Internal T&S variables are conservative temperature & absolute salinity, ! so they need to converted to potential temperature and practical salinity ! for some diagnostics using TEOS-10 function calls. - if ((CS%id_Tpot > 0) .or. (CS%id_tob > 0)) then - do k=1,nz ; do j=js,je ; do i=is,ie - work_3d(i,j,k) = gsw_pt_from_ct(tv%S(i,j,k),tv%T(i,j,k)) - enddo ; enddo ; enddo + if ((CS%id_Tpot > 0) .or. (CS%id_tob > 0) .or. (CS%id_tosq > 0)) then + EOSdom(:) = EOS_domain(G%HI) + do k=1,nz ; do j=js,je + call cons_temp_to_pot_temp(tv%T(:,j,k), tv%S(:,j,k), work_3d(:,j,k), tv%eqn_of_state, EOSdom) + enddo ; enddo if (CS%id_Tpot > 0) call post_data(CS%id_Tpot, work_3d, CS%diag) - if (CS%id_tob > 0) call post_data(CS%id_tob, work_3d(:,:,nz), CS%diag, mask=G%mask2dT) + if (CS%id_tob > 0) call post_data(CS%id_tob, work_3d(:,:,nz), CS%diag) + ! volume mean potential temperature + if (CS%id_thetaoga>0) then + thetaoga = global_volume_mean(work_3d, h, G, GV, tmp_scale=US%C_to_degC) + call post_data(CS%id_thetaoga, thetaoga, CS%diag) + endif + ! volume mean conservative temperature + if (CS%id_bigthetaoga>0) then + thetaoga = global_volume_mean(tv%T, h, G, GV, tmp_scale=US%C_to_degC) + call post_data(CS%id_bigthetaoga, thetaoga, CS%diag) + endif + ! area mean potential SST + if (CS%id_tosga > 0) then + tosga = global_area_mean(work_3d(:,:,1), G, tmp_scale=US%C_to_degC) + call post_data(CS%id_tosga, tosga, CS%diag) + endif + ! area mean conservative SST + if (CS%id_bigtosga > 0) then + tosga = global_area_mean(tv%T(:,:,1), G, tmp_scale=US%C_to_degC) + call post_data(CS%id_bigtosga, tosga, CS%diag) + endif + ! layer mean potential temperature + if (CS%id_temp_layer_ave>0) then + temp_layer_ave = global_layer_mean(work_3d, h, G, GV, tmp_scale=US%C_to_degC) + call post_data(CS%id_temp_layer_ave, temp_layer_ave, CS%diag) + endif + ! layer mean conservative temperature + if (CS%id_bigtemp_layer_ave>0) then + temp_layer_ave = global_layer_mean(tv%T, h, G, GV, tmp_scale=US%C_to_degC) + call post_data(CS%id_bigtemp_layer_ave, temp_layer_ave, CS%diag) + endif + if (CS%id_tosq > 0) then + do k=1,nz ; do j=js,je ; do i=is,ie + work_3d(i,j,k) = work_3d(i,j,k)*work_3d(i,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_tosq, work_3d, CS%diag) + endif endif else ! Internal T&S variables are potential temperature & practical salinity - if (CS%id_tob > 0) call post_data(CS%id_tob, tv%T(:,:,nz), CS%diag, mask=G%mask2dT) + if (CS%id_tob > 0) call post_data(CS%id_tob, tv%T(:,:,nz), CS%diag) + if (CS%id_tosq > 0) then + do k=1,nz ; do j=js,je ; do i=is,ie + work_3d(i,j,k) = tv%T(i,j,k)*tv%T(i,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_tosq, work_3d, CS%diag) + endif + ! volume mean potential temperature + if (CS%id_thetaoga>0) then + thetaoga = global_volume_mean(tv%T, h, G, GV, tmp_scale=US%C_to_degC) + call post_data(CS%id_thetaoga, thetaoga, CS%diag) + endif + ! area mean SST + if (CS%id_tosga > 0) then + tosga = global_area_mean(tv%T(:,:,1), G, tmp_scale=US%C_to_degC) + call post_data(CS%id_tosga, tosga, CS%diag) + endif + ! layer mean potential temperature + if (CS%id_temp_layer_ave>0) then + temp_layer_ave = global_layer_mean(tv%T, h, G, GV, tmp_scale=US%C_to_degC) + call post_data(CS%id_temp_layer_ave, temp_layer_ave, CS%diag) + endif endif + ! Calculate additional, potentially derived salinity diagnostics if (tv%S_is_absS) then ! Internal T&S variables are conservative temperature & absolute salinity, ! so they need to converted to potential temperature and practical salinity ! for some diagnostics using TEOS-10 function calls. - if ((CS%id_Sprac > 0) .or. (CS%id_sob > 0)) then - do k=1,nz ; do j=js,je ; do i=is,ie - work_3d(i,j,k) = gsw_sp_from_sr(tv%S(i,j,k)) - enddo ; enddo ; enddo + if ((CS%id_Sprac > 0) .or. (CS%id_sob > 0) .or. (CS%id_sosq >0)) then + EOSdom(:) = EOS_domain(G%HI) + do k=1,nz ; do j=js,je + call abs_saln_to_prac_saln(tv%S(:,j,k), work_3d(:,j,k), tv%eqn_of_state, EOSdom) + enddo ; enddo if (CS%id_Sprac > 0) call post_data(CS%id_Sprac, work_3d, CS%diag) - if (CS%id_sob > 0) call post_data(CS%id_sob, work_3d(:,:,nz), CS%diag, mask=G%mask2dT) + if (CS%id_sob > 0) call post_data(CS%id_sob, work_3d(:,:,nz), CS%diag) + ! volume mean salinity + if (CS%id_soga>0) then + soga = global_volume_mean(work_3d, h, G, GV, tmp_scale=US%S_to_ppt) + call post_data(CS%id_soga, soga, CS%diag) + endif + ! volume mean absolute salinity + if (CS%id_abssoga>0) then + soga = global_volume_mean(tv%S, h, G, GV, tmp_scale=US%S_to_ppt) + call post_data(CS%id_abssoga, soga, CS%diag) + endif + ! area mean practical SSS + if (CS%id_sosga > 0) then + sosga = global_area_mean(work_3d(:,:,1), G, tmp_scale=US%S_to_ppt) + call post_data(CS%id_sosga, sosga, CS%diag) + endif + ! area mean absolute SSS + if (CS%id_abssosga > 0) then + sosga = global_area_mean(tv%S(:,:,1), G, tmp_scale=US%S_to_ppt) + call post_data(CS%id_abssosga, sosga, CS%diag) + endif + ! layer mean practical salinity + if (CS%id_salt_layer_ave>0) then + salt_layer_ave = global_layer_mean(work_3d, h, G, GV, tmp_scale=US%S_to_ppt) + call post_data(CS%id_salt_layer_ave, salt_layer_ave, CS%diag) + endif + ! layer mean absolute salinity + if (CS%id_abssalt_layer_ave>0) then + salt_layer_ave = global_layer_mean(tv%S, h, G, GV, tmp_scale=US%S_to_ppt) + call post_data(CS%id_abssalt_layer_ave, salt_layer_ave, CS%diag) + endif + if (CS%id_sosq > 0) then + do k=1,nz ; do j=js,je ; do i=is,ie + work_3d(i,j,k) = work_3d(i,j,k)*work_3d(i,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_sosq, work_3d, CS%diag) + endif endif else ! Internal T&S variables are potential temperature & practical salinity - if (CS%id_sob > 0) call post_data(CS%id_sob, tv%S(:,:,nz), CS%diag, mask=G%mask2dT) - endif - - ! volume mean potential temperature - if (CS%id_thetaoga>0) then - thetaoga = global_volume_mean(tv%T, h, G, GV) - call post_data(CS%id_thetaoga, thetaoga, CS%diag) - endif - - ! area mean SST - if (CS%id_tosga > 0) then - do j=js,je ; do i=is,ie - surface_field(i,j) = tv%T(i,j,1) - enddo ; enddo - tosga = global_area_mean(tv%T(:,:,1), G) - call post_data(CS%id_tosga, tosga, CS%diag) - endif - - ! volume mean salinity - if (CS%id_soga>0) then - soga = global_volume_mean(tv%S, h, G, GV) - call post_data(CS%id_soga, soga, CS%diag) - endif - - ! area mean SSS - if (CS%id_sosga > 0) then - do j=js,je ; do i=is,ie - surface_field(i,j) = tv%S(i,j,1) - enddo ; enddo - sosga = global_area_mean(surface_field, G) - call post_data(CS%id_sosga, sosga, CS%diag) - endif - - ! layer mean potential temperature - if (CS%id_temp_layer_ave>0) then - temp_layer_ave = global_layer_mean(tv%T, h, G, GV) - call post_data(CS%id_temp_layer_ave, temp_layer_ave, CS%diag) - endif - - ! layer mean salinity - if (CS%id_salt_layer_ave>0) then - salt_layer_ave = global_layer_mean(tv%S, h, G, GV) - call post_data(CS%id_salt_layer_ave, salt_layer_ave, CS%diag) + if (CS%id_sob > 0) call post_data(CS%id_sob, tv%S(:,:,nz), CS%diag) + if (CS%id_sosq > 0) then + do k=1,nz ; do j=js,je ; do i=is,ie + work_3d(i,j,k) = tv%S(i,j,k)*tv%S(i,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_sosq, work_3d, CS%diag) + endif + ! volume mean salinity + if (CS%id_soga>0) then + soga = global_volume_mean(tv%S, h, G, GV, tmp_scale=US%S_to_ppt) + call post_data(CS%id_soga, soga, CS%diag) + endif + ! area mean SSS + if (CS%id_sosga > 0) then + sosga = global_area_mean(tv%S(:,:,1), G, tmp_scale=US%S_to_ppt) + call post_data(CS%id_sosga, sosga, CS%diag) + endif + ! layer mean salinity + if (CS%id_salt_layer_ave>0) then + salt_layer_ave = global_layer_mean(tv%S, h, G, GV, tmp_scale=US%S_to_ppt) + call post_data(CS%id_salt_layer_ave, salt_layer_ave, CS%diag) + endif endif call calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) @@ -484,7 +585,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & pressure_1d(:) = tv%P_Ref !$OMP parallel do default(shared) do k=1,nz ; do j=js-1,je+1 - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), tv%eqn_of_state, & + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), tv%eqn_of_state, & EOSdom) enddo ; enddo else ! Rcv should not be used much in this case, so fill in sensible values. @@ -610,16 +711,16 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & pressure_1d(:) = 0. !$OMP parallel do default(shared) do k=1,nz ; do j=js,je - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), & + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), & tv%eqn_of_state, EOSdom) enddo ; enddo if (CS%id_rhopot0 > 0) call post_data(CS%id_rhopot0, Rcv, CS%diag) endif if (CS%id_rhopot2 > 0) then - pressure_1d(:) = 2.0e7*US%kg_m3_to_R*US%m_s_to_L_T**2 ! 2000 dbars + pressure_1d(:) = 2.0e7*US%Pa_to_RL2_T2 ! 2000 dbars !$OMP parallel do default(shared) do k=1,nz ; do j=js,je - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), & + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), & tv%eqn_of_state, EOSdom) enddo ; enddo if (CS%id_rhopot2 > 0) call post_data(CS%id_rhopot2, Rcv, CS%diag) @@ -630,8 +731,8 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & pressure_1d(:) = 0. ! Start at p=0 Pa at surface do k=1,nz pressure_1d(:) = pressure_1d(:) + 0.5 * h(:,j,k) * (GV%H_to_RZ*GV%g_Earth) ! Pressure in middle of layer k - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), & - tv%eqn_of_state, EOSdom) + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, Rcv(:,j,k), & + tv%eqn_of_state, EOSdom) pressure_1d(:) = pressure_1d(:) + 0.5 * h(:,j,k) * (GV%H_to_RZ*GV%g_Earth) ! Pressure at bottom of layer k enddo enddo @@ -643,11 +744,11 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & do j=js,je pressure_1d(:) = 0. ! Start at p=0 Pa at surface do k=1,nz - pressure_1d(:) = pressure_1d(:) + 0.5 * h(:,j,k) * GV%H_to_Pa ! Pressure in middle of layer k + pressure_1d(:) = pressure_1d(:) + 0.5 * h(:,j,k) * (GV%H_to_RZ*GV%g_Earth) ! Pressure in middle of layer k ! To avoid storing more arrays, put drho_dT into Rcv, and drho_dS into work3d - call calculate_density_derivs(tv%T(:,j,k),tv%S(:,j,k),pressure_1d, & - Rcv(:,j,k),work_3d(:,j,k),is,ie-is+1, tv%eqn_of_state) - pressure_1d(:) = pressure_1d(:) + 0.5 * h(:,j,k) * GV%H_to_Pa ! Pressure at bottom of layer k + call calculate_density_derivs(tv%T(:,j,k), tv%S(:,j,k), pressure_1d, & + Rcv(:,j,k), work_3d(:,j,k), tv%eqn_of_state, EOSdom) + pressure_1d(:) = pressure_1d(:) + 0.5 * h(:,j,k) * (GV%H_to_RZ*GV%g_Earth) ! Pressure at bottom of layer k enddo enddo if (CS%id_drho_dT > 0) call post_data(CS%id_drho_dT, Rcv, CS%diag) @@ -664,13 +765,13 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & do j=js,je ; do i=is,ie ! Blend the equatorial deformation radius with the standard one. f2_h = absurdly_small_freq2 + 0.25 * & - ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & - (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) + ((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + & + (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) mag_beta = sqrt(0.5 * ( & - (((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + & - ((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2) + & - (((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + & - ((G%CoriolisBu(I-1,J)-G%CoriolisBu(I-1,J-1)) * G%IdyCu(I-1,j))**2) )) + ((((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2) + & + (((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2)) + & + ((((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2) + & + (((G%CoriolisBu(I-1,J)-G%CoriolisBu(I-1,J-1)) * G%IdyCu(I-1,j))**2)) )) Rd1(i,j) = cg1(i,j) / sqrt(f2_h + cg1(i,j) * mag_beta) enddo ; enddo @@ -714,13 +815,13 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & do j=js,je ; do i=is,ie ! Blend the equatorial deformation radius with the standard one. f2_h = absurdly_small_freq2 + 0.25 * & - ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & - (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) + ((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + & + (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) mag_beta = sqrt(0.5 * ( & - (((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + & - ((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2) + & - (((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + & - ((G%CoriolisBu(I-1,J)-G%CoriolisBu(I-1,J-1)) * G%IdyCu(I-1,j))**2) )) + ((((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2) + & + (((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2)) + & + ((((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2) + & + (((G%CoriolisBu(I-1,J)-G%CoriolisBu(I-1,J-1)) * G%IdyCu(I-1,j))**2)) )) Rd1(i,j) = cg1(i,j) / sqrt(f2_h + cg1(i,j) * mag_beta) enddo ; enddo @@ -814,8 +915,8 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) !! as setting the surface pressure to 0. type(diagnostics_CS), intent(inout) :: CS !< Control structure returned by a !! previous call to diagnostics_init. - - real, dimension(SZI_(G), SZJ_(G)) :: & + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: & z_top, & ! Height of the top of a layer or the ocean [Z ~> m]. z_bot, & ! Height of the bottom of a layer (for id_mass) or the ! (positive) depth of the ocean (for id_col_ht) [Z ~> m]. @@ -826,12 +927,19 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) btm_pres,&! The pressure at the ocean bottom, or CMIP variable 'pbo'. ! This is the column mass multiplied by gravity plus the pressure ! at the ocean surface [R L2 T-2 ~> Pa]. - dpress, & ! Change in hydrostatic pressure across a layer [R L2 T-2 ~> Pa]. - tr_int ! vertical integral of a tracer times density, + tr_int,& ! vertical integral of a tracer times density, ! (Rho_0 in a Boussinesq model) [Conc R Z ~> Conc kg m-2]. - real :: IG_Earth ! Inverse of gravitational acceleration [T2 Z L-2 ~> s2 m-1]. + d17,& ! Depth of 17 degC isotherm [Z ~> m] + d20 ! Depth of 20 degC isotherm [Z ~> m] + real :: tmp(SZI_(G),SZJ_(G),SZK_(GV)) ! Temporary array [defined at each usage] + real :: IG_Earth ! Inverse of gravitational acceleration [T2 Z L-2 ~> s2 m-1]. + real :: Ttop, Tbot ! Temperature at top/bottom of cell [C ~> degC] + type(EPPM_CWK) :: PPM ! Class for reconstruction + real :: d_from_ssh(0:GV%ke) ! eta-z (Distance from surface) [Z ~> m] + real :: dz ! Layer thickness in Z [Z ~> m] integer :: i, j, k, is, ie, js, je, nz + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (CS%id_mass_wt > 0) then @@ -866,53 +974,139 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) call post_data(CS%id_col_ht, z_bot, CS%diag) endif - ! NOTE: int_density_z expects z_top and z_btm values from [ij]sq to [ij]eq+1 if (CS%id_col_mass > 0 .or. CS%id_pbo > 0) then - do j=js,je ; do i=is,ie ; mass(i,j) = 0.0 ; enddo ; enddo - if (GV%Boussinesq) then - if (associated(tv%eqn_of_state)) then - IG_Earth = 1.0 / GV%g_Earth -! do j=js,je ; do i=is,ie ; z_bot(i,j) = -P_SURF(i,j)/GV%H_to_Pa ; enddo ; enddo - do j=G%jscB,G%jecB+1 ; do i=G%iscB,G%iecB+1 - z_bot(i,j) = 0.0 - enddo ; enddo + if (CS%id_pbo > 0) then + call find_col_mass(h, tv, G, GV, US, mass, btm_pres, p_surf) + call post_data(CS%id_pbo, btm_pres, CS%diag) + else + call find_col_mass(h, tv, G, GV, US, mass) + endif + if (CS%id_col_mass > 0) call post_data(CS%id_col_mass, mass, CS%diag) + endif + if (CS%id_t20d > 0 .or. CS%id_t17d > 0) then + call PPM%init(GV%ke, h_neglect=0.) + do j=js,je ; do i=is,ie + ! Pre-calculate the interface depths relative to the surface + if (GV%Boussinesq) then + d_from_ssh(0) = 0. do k=1,nz - do j=G%jscB,G%jecB+1 ; do i=G%iscB,G%iecB+1 - z_top(i,j) = z_bot(i,j) - z_bot(i,j) = z_top(i,j) - GV%H_to_Z*h(i,j,k) - enddo ; enddo - call int_density_dz(tv%T(:,:,k), tv%S(:,:,k), z_top, z_bot, 0.0, GV%Rho0, GV%g_Earth, & - G%HI, tv%eqn_of_state, US, dpress) - do j=js,je ; do i=is,ie - mass(i,j) = mass(i,j) + dpress(i,j) * IG_Earth - enddo ; enddo + d_from_ssh(k) = d_from_ssh(k-1) + h(i,j,k) * GV%H_to_Z enddo else - do k=1,nz ; do j=js,je ; do i=is,ie - mass(i,j) = mass(i,j) + (GV%H_to_Z*GV%Rlay(k))*h(i,j,k) - enddo ; enddo ; enddo + ! Non-Boussinesq: use pre-computed layer-average specific volumes from tv%SpV_avg, + ! which are more accurate than cell-center specific volumes and correctly account + ! for surface pressure (including under ice-shelves). + d_from_ssh(0) = 0. + do k=1,nz + d_from_ssh(k) = d_from_ssh(k-1) + ( h(i,j,k) * GV%H_to_RZ ) * tv%SpV_avg(i,j,k) + enddo endif + call PPM%reconstruct(h(i,j,:), tv%T(i,j,:)) + d17(i,j) = d_from_ssh(nz) + d20(i,j) = d_from_ssh(nz) + do k=nz,1,-1 + Ttop = PPM%f(k, 0.) + Tbot = PPM%f(k, 1.) + if ( Tbot>Ttop ) cycle ! The cell is inverted, skip to next + if ( 20.=0 + if ( Tbot<=17. .and. 17.<=Ttop ) then + ! The 17 degC isotherm is within the cell which is non-negatively stratified + d17(i,j) = d_from_ssh(k-1) + dz * PPM%x(k, 17.) + elseif ( Ttop<17. ) then + ! The 17 degC isotherm is above the top of the cell + d17(i,j) = d_from_ssh(k-1) + endif + if ( Tbot<=20. .and. 20.<=Ttop ) then + ! The 20 degC isotherm is within the cell which is non-negatively stratified + d20(i,j) = d_from_ssh(k-1) + dz * PPM%x(k, 20.) + elseif ( Ttop<20. ) then + ! The 20 degC isotherm is above the top of the cell + d20(i,j) = d_from_ssh(k-1) + endif + enddo + enddo ; enddo + call PPM%destroy() + if (CS%id_t17d > 0) call post_data(CS%id_t17d, d17, CS%diag) + if (CS%id_t20d > 0) call post_data(CS%id_t20d, d20, CS%diag) + endif + + ! Practical salinity expressed as salt mass content + if (CS%id_scint > 0) then + EOSdom(:) = EOS_domain(G%HI) + if (tv%S_is_absS) then + do k=1,nz ; do j=js,je + call abs_saln_to_prac_saln(tv%S(:,j,k), tmp(:,j,k), tv%eqn_of_state, EOSdom) ! "tmp" [S ~> psu] + do i=is,ie + tmp(i,j,k) = ( GV%H_to_RZ * h(i,j,k) ) * tmp(i,j,k) ! "tmp" [R Z S ~> kg m-2] + enddo + enddo ; enddo else do k=1,nz ; do j=js,je ; do i=is,ie - mass(i,j) = mass(i,j) + GV%H_to_RZ*h(i,j,k) + tmp(i,j,k) = ( GV%H_to_RZ * h(i,j,k) ) * tv%S(i,j,k) ! "tmp" [R Z S ~> kg m-2] enddo ; enddo ; enddo endif - if (CS%id_col_mass > 0) then - call post_data(CS%id_col_mass, mass, CS%diag) + call post_data(CS%id_scint, tmp, CS%diag) + endif + ! Absolute salinities expressed as salt mass content + if (CS%id_absscint > 0 .or. CS%id_pfscint > 0) then + EOSdom(:) = EOS_domain(G%HI) + if (tv%S_is_absS) then + do k=1,nz ; do j=js,je ; do i=is,ie + tmp(i,j,k) = ( GV%H_to_RZ * h(i,j,k) ) * tv%S(i,j,k) ! "tmp" [R Z S ~> kg m-2] + enddo ; enddo ; enddo + else + do k=1,nz ; do j=js,je + call prac_saln_to_abs_saln(tv%S(:,j,k), tmp(:,j,k), tv%eqn_of_state, EOSdom) ! "tmp" [S ~> ppt] + do i=is,ie + tmp(i,j,k) = ( GV%H_to_RZ * h(i,j,k) ) * tmp(i,j,k) ! [R Z S ~> kg m-2] + enddo + enddo ; enddo endif - if (CS%id_pbo > 0) then - do j=js,je ; do i=is,ie ; btm_pres(i,j) = 0.0 ; enddo ; enddo - ! 'pbo' is defined as the sea water pressure at the sea floor - ! pbo = (mass * g) + p_surf - ! where p_surf is the sea water pressure at sea water surface. - do j=js,je ; do i=is,ie - btm_pres(i,j) = GV%g_Earth * mass(i,j) - if (associated(p_surf)) then - btm_pres(i,j) = btm_pres(i,j) + p_surf(i,j) - endif + if (CS%id_absscint > 0) call post_data(CS%id_absscint, tmp, CS%diag) + ! Based on the definitions in https://www.teos-10.org/pubs/gsw/pdf/TEOS-10_Manual.pdf + ! The preformed salinity, S*, is the conserved salinity used in models (page 8). + ! Although we appear to be labeling tv%S absolute salinity, we do not use the function + ! that calculates the "absolute salinity anomaly ratio" which accounts for the + ! geographic variations in the types of dissolved salts. + ! Hence, I think there is no difference between preformed and absolute salinity + ! for the current implementation of TEOS-10 and so we post the same data for + ! absscint and pfscint. -AJA + if (CS%id_pfscint > 0) call post_data(CS%id_pfscint, tmp, CS%diag) + endif + ! Potential temperature expressed as heat content + if (CS%id_phcint > 0) then + EOSdom(:) = EOS_domain(G%HI) + if (tv%T_is_conT) then + do k=1,nz ; do j=js,je + call cons_temp_to_pot_temp(tv%T(:,j,k), tv%S(:,j,k), tmp(:,j,k), tv%eqn_of_state, EOSdom) ! "tmp" [C ~> degC] + do i=is,ie + tmp(i,j,k) = ( ( tv%C_p * GV%H_to_RZ ) * h(i,j,k) ) * tmp(i,j,k) ! "tmp" [ Q R Z ~> J m-2] + enddo + enddo ; enddo + else + do k=1,nz ; do j=js,je ; do i=is,ie + tmp(i,j,k) = ( ( tv%C_p * GV%H_to_RZ ) * h(i,j,k) ) * tv%T(i,j,k) ! "tmp" [Q R Z ~> J m-2] + enddo ; enddo ; enddo + endif + call post_data(CS%id_phcint, tmp, CS%diag) + endif + ! Conservative temperature expressed as heat content + if (CS%id_chcint > 0) then + EOSdom(:) = EOS_domain(G%HI) + if (tv%T_is_conT) then + do k=1,nz ; do j=js,je ; do i=is,ie + tmp(i,j,k) = ( ( tv%C_p * GV%H_to_RZ ) * h(i,j,k) ) * tv%T(i,j,k) ! "tmp" [Q R Z ~> J m-2] + enddo ; enddo ; enddo + else + do k=1,nz ; do j=js,je + call pot_temp_to_cons_temp(tv%T(:,j,k), tv%S(:,j,k), tmp(:,j,k), tv%eqn_of_state, EOSdom) ! "tmp" [C ~> degC] + do i=is,ie + tmp(i,j,k) = ( ( tv%C_p * GV%H_to_RZ ) * h(i,j,k) ) * tmp(i,j,k) ! "tmp" [ Q R Z ~> J m-2] + enddo enddo ; enddo - call post_data(CS%id_pbo, btm_pres, CS%diag) endif + call post_data(CS%id_chcint, tmp, CS%diag) endif end subroutine calculate_vertical_integrals @@ -944,9 +1138,9 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS real :: KE_term(SZI_(G),SZJ_(G),SZK_(GV)) ! A term in the kinetic energy budget ! [H L2 T-3 ~> m3 s-3 or W m-2] real :: KE_u(SZIB_(G),SZJ_(G)) ! The area integral of a KE term in a layer at u-points - ! [H L4 T-3 ~> m5 s-3 or kg m2 s-3] + ! [H L4 T-3 ~> m5 s-3 or W] real :: KE_v(SZI_(G),SZJB_(G)) ! The area integral of a KE term in a layer at v-points - ! [H L4 T-3 ~> m5 s-3 or kg m2 s-3] + ! [H L4 T-3 ~> m5 s-3 or W] real :: KE_h(SZI_(G),SZJ_(G)) ! A KE term contribution at tracer points ! [H L2 T-3 ~> m3 s-3 or W m-2] @@ -956,13 +1150,11 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS if (.not.(CS%KE_term_on .or. (CS%id_KE > 0))) return - do j=js-1,je ; do i=is-1,ie - KE_u(I,j) = 0.0 ; KE_v(i,J) = 0.0 - enddo ; enddo + KE_u(:,:) = 0. ; KE_v(:,:) = 0. do k=1,nz ; do j=js,je ; do i=is,ie - KE(i,j,k) = ((u(I,j,k) * u(I,j,k) + u(I-1,j,k) * u(I-1,j,k)) & - + (v(i,J,k) * v(i,J,k) + v(i,J-1,k) * v(i,J-1,k))) * 0.25 + KE(i,j,k) = (((u(I,j,k) * u(I,j,k)) + (u(I-1,j,k) * u(I-1,j,k))) & + + ((v(i,J,k) * v(i,J,k)) + (v(i,J-1,k) * v(i,J-1,k)))) * 0.25 enddo ; enddo ; enddo if (CS%id_KE > 0) call post_data(CS%id_KE, KE, CS%diag) @@ -971,7 +1163,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS endif if (CS%id_dKEdt > 0) then - ! Calculate the time derivative of the layer KE [H L2 T-3 ~> m3 s-3]. + ! Calculate the time derivative of the layer KE [H L2 T-3 ~> m3 s-3 or W m-2]. do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * CS%du_dt(I,j,k) @@ -986,14 +1178,14 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie KE_term(i,j,k) = KE_h(i,j) + 0.5 * G%IareaT(i,j) & - * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) enddo ; enddo enddo call post_data(CS%id_dKEdt, KE_term, CS%diag) endif if (CS%id_PE_to_KE > 0) then - ! Calculate the potential energy to KE term [H L2 T-3 ~> m3 s-3]. + ! Calculate the potential energy to KE term [H L2 T-3 ~> m3 s-3 or W m-2]. do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%PFu(I,j,k) @@ -1005,14 +1197,52 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie KE_term(i,j,k) = 0.5 * G%IareaT(i,j) & - * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) + enddo ; enddo + enddo + call post_data(CS%id_PE_to_KE, KE_term, CS%diag) + endif + + if (CS%id_KE_SAL > 0) then + ! Calculate the KE source from self-attraction and loading [H L2 T-3 ~> m3 s-3 or W m-2]. + do k=1,nz + do j=js,je ; do I=Isq,Ieq + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%sal_u(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * ADp%sal_v(i,J,k) + enddo ; enddo + if (.not.G%symmetric) & + call do_group_pass(CS%pass_KE_uv, G%domain) + do j=js,je ; do i=is,ie + KE_term(i,j,k) = 0.5 * G%IareaT(i,j) & + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) enddo ; enddo enddo - if (CS%id_PE_to_KE > 0) call post_data(CS%id_PE_to_KE, KE_term, CS%diag) + call post_data(CS%id_KE_SAL, KE_term, CS%diag) + endif + + if (CS%id_KE_TIDES > 0) then + ! Calculate the KE source from astronomical tidal forcing [H L2 T-3 ~> m3 s-3 or W m-2]. + do k=1,nz + do j=js,je ; do I=Isq,Ieq + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%tides_u(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * ADp%tides_v(i,J,k) + enddo ; enddo + if (.not.G%symmetric) & + call do_group_pass(CS%pass_KE_uv, G%domain) + do j=js,je ; do i=is,ie + KE_term(i,j,k) = 0.5 * G%IareaT(i,j) & + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) + enddo ; enddo + enddo + call post_data(CS%id_KE_TIDES, KE_term, CS%diag) endif if (CS%id_KE_BT > 0) then - ! Calculate the barotropic contribution to KE term [H L2 T-3 ~> m3 s-3]. + ! Calculate the barotropic contribution to KE term [H L2 T-3 ~> m3 s-3 or W m-2]. do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%u_accel_bt(I,j,k) @@ -1024,14 +1254,115 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie KE_term(i,j,k) = 0.5 * G%IareaT(i,j) & - * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) enddo ; enddo enddo call post_data(CS%id_KE_BT, KE_term, CS%diag) endif + if (CS%id_PE_to_KE_btbc > 0) then + ! Calculate the potential energy to KE term including barotropic solver contribution + ! [H L2 T-3 ~> m3 s-3 or W m-2]. + do k=1,nz + do j=js,je ; do I=Isq,Ieq + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * (ADp%PFu(I,j,k) + ADp%bt_pgf_u(I,j,k)) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * (ADp%PFv(i,J,k) + ADp%bt_pgf_v(i,J,k)) + enddo ; enddo + if (.not.G%symmetric) & + call do_group_pass(CS%pass_KE_uv, G%domain) + do j=js,je ; do i=is,ie + KE_term(i,j,k) = 0.5 * G%IareaT(i,j) & + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) + enddo ; enddo + enddo + call post_data(CS%id_PE_to_KE_btbc, KE_term, CS%diag) + endif + + if (CS%id_KE_Coradv_btbc > 0) then + ! Calculate the KE source from Coriolis and advection terms including barotropic solver contribution + ! [H L2 T-3 ~> m3 s-3 or W m-2]. + do k=1,nz + do j=js,je ; do I=Isq,Ieq + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * (ADp%CAu(I,j,k) + ADp%bt_cor_u(I,j)) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * (ADp%CAv(i,J,k) + ADp%bt_cor_v(i,J)) + enddo ; enddo + do j=js,je ; do i=is,ie + KE_h(i,j) = -KE(i,j,k) * G%IareaT(i,j) & + * ((uh(I,j,k) - uh(I-1,j,k)) + (vh(i,J,k) - vh(i,J-1,k))) + enddo ; enddo + if (.not.G%symmetric) & + call do_group_pass(CS%pass_KE_uv, G%domain) + do j=js,je ; do i=is,ie + KE_term(i,j,k) = KE_h(i,j) + 0.5 * G%IareaT(i,j) & + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) + enddo ; enddo + enddo + call post_data(CS%id_KE_Coradv_btbc, KE_term, CS%diag) + endif + + if (CS%id_KE_BT_PF > 0) then + ! Calculate the anomalous pressure gradient force contribution to KE term [H L2 T-3 ~> m3 s-3 or W m-2]. + do k=1,nz + do j=js,je ; do I=Isq,Ieq + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%bt_pgf_u(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * ADp%bt_pgf_v(i,J,k) + enddo ; enddo + if (.not.G%symmetric) & + call do_group_pass(CS%pass_KE_uv, G%domain) + do j=js,je ; do i=is,ie + KE_term(i,j,k) = 0.5 * G%IareaT(i,j) & + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) + enddo ; enddo + enddo + call post_data(CS%id_KE_BT_PF, KE_term, CS%diag) + endif + + if (CS%id_KE_BT_CF > 0) then + ! Calculate the anomalous Coriolis force contribution to KE term [H L2 T-3 ~> m3 s-3 or W m-2]. + do k=1,nz + do j=js,je ; do I=Isq,Ieq + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%bt_cor_u(I,j) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * ADp%bt_cor_v(i,J) + enddo ; enddo + if (.not.G%symmetric) & + call do_group_pass(CS%pass_KE_uv, G%domain) + do j=js,je ; do i=is,ie + KE_term(i,j,k) = 0.5 * G%IareaT(i,j) & + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) + enddo ; enddo + enddo + call post_data(CS%id_KE_BT_CF, KE_term, CS%diag) + endif + + if (CS%id_KE_BT_WD > 0) then + ! Calculate the barotropic linear wave drag contribution to KE term [H L2 T-3 ~> m3 s-3 or W m-2]. + do k=1,nz + do j=js,je ; do I=Isq,Ieq + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%bt_lwd_u(I,j) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * ADp%bt_lwd_v(i,J) + enddo ; enddo + if (.not.G%symmetric) & + call do_group_pass(CS%pass_KE_uv, G%domain) + do j=js,je ; do i=is,ie + KE_term(i,j,k) = 0.5 * G%IareaT(i,j) & + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) + enddo ; enddo + enddo + call post_data(CS%id_KE_BT_WD, KE_term, CS%diag) + endif + if (CS%id_KE_Coradv > 0) then - ! Calculate the KE source from the combined Coriolis and advection terms [H L2 T-3 ~> m3 s-3]. + ! Calculate the KE source from the combined Coriolis and advection terms [H L2 T-3 ~> m3 s-3 or W m-2]. ! The Coriolis source should be zero, but is not due to truncation errors. There should be ! near-cancellation of the global integral of this spurious Coriolis source. do k=1,nz @@ -1043,20 +1374,20 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS enddo ; enddo do j=js,je ; do i=is,ie KE_h(i,j) = -KE(i,j,k) * G%IareaT(i,j) & - * (uh(I,j,k) - uh(I-1,j,k) + vh(i,J,k) - vh(i,J-1,k)) + * ((uh(I,j,k) - uh(I-1,j,k)) + (vh(i,J,k) - vh(i,J-1,k))) enddo ; enddo if (.not.G%symmetric) & call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie KE_term(i,j,k) = KE_h(i,j) + 0.5 * G%IareaT(i,j) & - * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) enddo ; enddo enddo call post_data(CS%id_KE_Coradv, KE_term, CS%diag) endif if (CS%id_KE_adv > 0) then - ! Calculate the KE source from along-layer advection [H L2 T-3 ~> m3 s-3]. + ! Calculate the KE source from along-layer advection [H L2 T-3 ~> m3 s-3 or W m-2]. ! NOTE: All terms in KE_adv are multiplied by -1, which can easily produce ! negative zeros and may signal a reproducibility issue over land. ! We resolve this by re-initializing and only evaluating over water points. @@ -1072,20 +1403,20 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS enddo ; enddo do j=js,je ; do i=is,ie KE_h(i,j) = -KE(i,j,k) * G%IareaT(i,j) & - * (uh(I,j,k) - uh(I-1,j,k) + vh(i,J,k) - vh(i,J-1,k)) + * ((uh(I,j,k) - uh(I-1,j,k)) + (vh(i,J,k) - vh(i,J-1,k))) enddo ; enddo if (.not.G%symmetric) & call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie KE_term(i,j,k) = KE_h(i,j) + 0.5 * G%IareaT(i,j) & - * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) enddo ; enddo enddo call post_data(CS%id_KE_adv, KE_term, CS%diag) endif if (CS%id_KE_visc > 0) then - ! Calculate the KE source from vertical viscosity [H L2 T-3 ~> m3 s-3]. + ! Calculate the KE source from vertical viscosity [H L2 T-3 ~> m3 s-3 or W m-2]. do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%du_dt_visc(I,j,k) @@ -1097,14 +1428,33 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie KE_term(i,j,k) = 0.5 * G%IareaT(i,j) & - * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) enddo ; enddo enddo call post_data(CS%id_KE_visc, KE_term, CS%diag) endif + if (CS%id_KE_visc_gl90 > 0) then + ! Calculate the KE source from GL90 vertical viscosity [H L2 T-3 ~> m3 s-3 or W m-2]. + do k=1,nz + do j=js,je ; do I=Isq,Ieq + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%du_dt_visc_gl90(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * ADp%dv_dt_visc_gl90(i,J,k) + enddo ; enddo + if (.not.G%symmetric) & + call do_group_pass(CS%pass_KE_uv, G%domain) + do j=js,je ; do i=is,ie + KE_term(i,j,k) = 0.5 * G%IareaT(i,j) & + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) + enddo ; enddo + enddo + call post_data(CS%id_KE_visc_gl90, KE_term, CS%diag) + endif + if (CS%id_KE_stress > 0) then - ! Calculate the KE source from surface stress (included in KE_visc) [H L2 T-3 ~> m3 s-3]. + ! Calculate the KE source from surface stress (included in KE_visc) [H L2 T-3 ~> m3 s-3 or W m-2]. do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%du_dt_str(I,j,k) @@ -1123,7 +1473,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS endif if (CS%id_KE_horvisc > 0) then - ! Calculate the KE source from horizontal viscosity [H L2 T-3 ~> m3 s-3]. + ! Calculate the KE source from horizontal viscosity [H L2 T-3 ~> m3 s-3 or W m-2]. do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%diffu(I,j,k) @@ -1135,14 +1485,14 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie KE_term(i,j,k) = 0.5 * G%IareaT(i,j) & - * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) enddo ; enddo enddo call post_data(CS%id_KE_horvisc, KE_term, CS%diag) endif if (CS%id_KE_dia > 0) then - ! Calculate the KE source from diapycnal diffusion [H L2 T-3 ~> m3 s-3]. + ! Calculate the KE source from diapycnal diffusion [H L2 T-3 ~> m3 s-3 or W m-2]. do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%du_dt_dia(I,j,k) @@ -1157,7 +1507,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie KE_term(i,j,k) = KE_h(i,j) + 0.5 * G%IareaT(i,j) & - * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) enddo ; enddo enddo call post_data(CS%id_KE_dia, KE_term, CS%diag) @@ -1169,9 +1519,10 @@ end subroutine calculate_energy_diagnostics subroutine register_time_deriv(lb, f_ptr, deriv_ptr, CS) integer, intent(in), dimension(3) :: lb !< Lower index bound of f_ptr real, dimension(lb(1):,lb(2):,:), target :: f_ptr - !< Time derivative operand + !< Time derivative operand, in arbitrary units [A ~> a] real, dimension(lb(1):,lb(2):,:), target :: deriv_ptr - !< Time derivative of f_ptr + !< Time derivative of f_ptr, in units derived from + !! the arbitrary units of f_ptr [A T-1 ~> a s-1] type(diagnostics_CS), intent(inout) :: CS !< Control structure returned by previous call to !! diagnostics_init. @@ -1250,25 +1601,38 @@ subroutine post_surface_dyn_diags(IDs, G, diag, sfc_state, ssh) ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: speed ! The surface speed [L T-1 ~> m s-1] + real :: ssu_east(SZI_(G),SZJ_(G)) ! Surface velocity due east component [L T-1 ~> m s-1] + real :: ssv_north(SZI_(G),SZJ_(G)) ! Surface velocity due north component [L T-1 ~> m s-1] integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec if (IDs%id_ssh > 0) & - call post_data(IDs%id_ssh, ssh, diag, mask=G%mask2dT) + call post_data(IDs%id_ssh, ssh, diag) if (IDs%id_ssu > 0) & - call post_data(IDs%id_ssu, sfc_state%u, diag, mask=G%mask2dCu) + call post_data(IDs%id_ssu, sfc_state%u, diag) if (IDs%id_ssv > 0) & - call post_data(IDs%id_ssv, sfc_state%v, diag, mask=G%mask2dCv) + call post_data(IDs%id_ssv, sfc_state%v, diag) if (IDs%id_speed > 0) then do j=js,je ; do i=is,ie - speed(i,j) = sqrt(0.5*(sfc_state%u(I-1,j)**2 + sfc_state%u(I,j)**2) + & - 0.5*(sfc_state%v(i,J-1)**2 + sfc_state%v(i,J)**2)) + speed(i,j) = sqrt(0.5*((sfc_state%u(I-1,j)**2) + (sfc_state%u(I,j)**2)) + & + 0.5*((sfc_state%v(i,J-1)**2) + (sfc_state%v(i,J)**2))) enddo ; enddo - call post_data(IDs%id_speed, speed, diag, mask=G%mask2dT) + call post_data(IDs%id_speed, speed, diag) + endif + + if (IDs%id_ssu_east > 0 .or. IDs%id_ssv_north > 0) then + do j=js,je ; do i=is,ie + ssu_east(i,j) = ((0.5*(sfc_state%u(I-1,j) + sfc_state%u(I,j))) * G%cos_rot(i,j)) + & + ((0.5*(sfc_state%v(i,J-1) + sfc_state%v(i,J))) * G%sin_rot(i,j)) + ssv_north(i,j) = ((0.5*(sfc_state%v(i,J-1) + sfc_state%v(i,J))) * G%cos_rot(i,j)) - & + ((0.5*(sfc_state%u(I-1,j) + sfc_state%u(I,j))) * G%sin_rot(i,j)) + enddo ; enddo + if (IDs%id_ssu_east > 0 ) call post_data(IDs%id_ssu_east, ssu_east, diag) + if (IDs%id_ssv_north > 0 ) call post_data(IDs%id_ssv_north, ssv_north, diag) endif end subroutine post_surface_dyn_diags @@ -1291,41 +1655,37 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv real, dimension(SZI_(G),SZJ_(G)), intent(in) :: ssh_ibc !< Time mean surface height with corrections !! for ice displacement and the inverse barometer [Z ~> m] - real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array + real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array [various] real, dimension(SZI_(G),SZJ_(G)) :: & - zos ! dynamic sea lev (zero area mean) from inverse-barometer adjusted ssh [m] + zos ! dynamic sea lev (zero area mean) from inverse-barometer adjusted ssh [Z ~> m] real :: I_time_int ! The inverse of the time interval [T-1 ~> s-1]. - real :: zos_area_mean ! Global area mean sea surface height [m] - real :: volo ! Total volume of the ocean [m3] - real :: ssh_ga ! Global ocean area weighted mean sea seaface height [m] + real :: zos_area_mean ! Global area mean sea surface height [Z ~> m] + real :: volo ! Total volume of the ocean [Z L2 ~> m3] + real :: ssh_ga ! Global ocean area weighted mean sea seaface height [Z ~> m] + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ! area mean SSH if (IDs%id_ssh_ga > 0) then - ssh_ga = global_area_mean(ssh, G, scale=US%Z_to_m) + ssh_ga = global_area_mean(ssh, G, tmp_scale=US%Z_to_m) call post_data(IDs%id_ssh_ga, ssh_ga, diag) endif ! post the dynamic sea level, zos, and zossq. - ! zos is ave_ssh with sea ice inverse barometer removed, - ! and with zero global area mean. + ! zos is ave_ssh with sea ice inverse barometer removed, and with zero global area mean. if (IDs%id_zos > 0 .or. IDs%id_zossq > 0) then - zos(:,:) = 0.0 - do j=js,je ; do i=is,ie - zos(i,j) = US%Z_to_m*ssh_ibc(i,j) - enddo ; enddo - zos_area_mean = global_area_mean(zos, G) + zos_area_mean = global_area_mean(ssh_ibc, G, tmp_scale=US%Z_to_m) do j=js,je ; do i=is,ie - zos(i,j) = zos(i,j) - G%mask2dT(i,j)*zos_area_mean + zos(i,j) = ssh_ibc(i,j) - G%mask2dT(i,j)*zos_area_mean enddo ; enddo - if (IDs%id_zos > 0) call post_data(IDs%id_zos, zos, diag, mask=G%mask2dT) + if (IDs%id_zos > 0) call post_data(IDs%id_zos, zos, diag) if (IDs%id_zossq > 0) then do j=js,je ; do i=is,ie work_2d(i,j) = zos(i,j)*zos(i,j) enddo ; enddo - call post_data(IDs%id_zossq, work_2d, diag, mask=G%mask2dT) + call post_data(IDs%id_zossq, work_2d, diag) endif endif @@ -1334,7 +1694,7 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv do j=js,je ; do i=is,ie work_2d(i,j) = G%mask2dT(i,j) * (ssh(i,j) + G%bathyT(i,j)) enddo ; enddo - volo = global_area_integral(work_2d, G, scale=US%Z_to_m) + volo = global_area_integral(work_2d, G, tmp_scale=US%Z_to_m) call post_data(IDs%id_volo, volo, diag) endif @@ -1346,7 +1706,7 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv do j=js,je ; do i=is,ie work_2d(i,j) = tv%frazil(i,j) * I_time_int enddo ; enddo - call post_data(IDs%id_fraz, work_2d, diag, mask=G%mask2dT) + call post_data(IDs%id_fraz, work_2d, diag) endif ! post time-averaged salt deficit @@ -1354,7 +1714,7 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv do j=js,je ; do i=is,ie work_2d(i,j) = tv%salt_deficit(i,j) * I_time_int enddo ; enddo - call post_data(IDs%id_salt_deficit, work_2d, diag, mask=G%mask2dT) + call post_data(IDs%id_salt_deficit, work_2d, diag) endif ! post temperature of P-E+R @@ -1362,7 +1722,7 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv do j=js,je ; do i=is,ie work_2d(i,j) = tv%TempxPmE(i,j) * (tv%C_p * I_time_int) enddo ; enddo - call post_data(IDs%id_Heat_PmE, work_2d, diag, mask=G%mask2dT) + call post_data(IDs%id_Heat_PmE, work_2d, diag) endif ! post geothermal heating or internal heat source/sinks @@ -1370,48 +1730,50 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv do j=js,je ; do i=is,ie work_2d(i,j) = tv%internal_heat(i,j) * (tv%C_p * I_time_int) enddo ; enddo - call post_data(IDs%id_intern_heat, work_2d, diag, mask=G%mask2dT) + call post_data(IDs%id_intern_heat, work_2d, diag) endif if (tv%T_is_conT) then ! Internal T&S variables are conservative temperature & absolute salinity - if (IDs%id_sstcon > 0) call post_data(IDs%id_sstcon, sfc_state%SST, diag, mask=G%mask2dT) + if (IDs%id_sstcon > 0) call post_data(IDs%id_sstcon, sfc_state%SST, diag) ! Use TEOS-10 function calls convert T&S diagnostics from conservative temp ! to potential temperature. - do j=js,je ; do i=is,ie - work_2d(i,j) = gsw_pt_from_ct(sfc_state%SSS(i,j), sfc_state%SST(i,j)) - enddo ; enddo - if (IDs%id_sst > 0) call post_data(IDs%id_sst, work_2d, diag, mask=G%mask2dT) + EOSdom(:) = EOS_domain(G%HI) + do j=js,je + call cons_temp_to_pot_temp(sfc_state%SST(:,j), sfc_state%SSS(:,j), work_2d(:,j), tv%eqn_of_state, EOSdom) + enddo + if (IDs%id_sst > 0) call post_data(IDs%id_sst, work_2d, diag) else ! Internal T&S variables are potential temperature & practical salinity - if (IDs%id_sst > 0) call post_data(IDs%id_sst, sfc_state%SST, diag, mask=G%mask2dT) + if (IDs%id_sst > 0) call post_data(IDs%id_sst, sfc_state%SST, diag) endif if (tv%S_is_absS) then ! Internal T&S variables are conservative temperature & absolute salinity - if (IDs%id_sssabs > 0) call post_data(IDs%id_sssabs, sfc_state%SSS, diag, mask=G%mask2dT) + if (IDs%id_sssabs > 0) call post_data(IDs%id_sssabs, sfc_state%SSS, diag) ! Use TEOS-10 function calls convert T&S diagnostics from absolute salinity ! to practical salinity. - do j=js,je ; do i=is,ie - work_2d(i,j) = gsw_sp_from_sr(sfc_state%SSS(i,j)) - enddo ; enddo - if (IDs%id_sss > 0) call post_data(IDs%id_sss, work_2d, diag, mask=G%mask2dT) + EOSdom(:) = EOS_domain(G%HI) + do j=js,je + call abs_saln_to_prac_saln(sfc_state%SSS(:,j), work_2d(:,j), tv%eqn_of_state, EOSdom) + enddo + if (IDs%id_sss > 0) call post_data(IDs%id_sss, work_2d, diag) else ! Internal T&S variables are potential temperature & practical salinity - if (IDs%id_sss > 0) call post_data(IDs%id_sss, sfc_state%SSS, diag, mask=G%mask2dT) + if (IDs%id_sss > 0) call post_data(IDs%id_sss, sfc_state%SSS, diag) endif if (IDs%id_sst_sq > 0) then do j=js,je ; do i=is,ie work_2d(i,j) = sfc_state%SST(i,j)*sfc_state%SST(i,j) enddo ; enddo - call post_data(IDs%id_sst_sq, work_2d, diag, mask=G%mask2dT) + call post_data(IDs%id_sst_sq, work_2d, diag) endif if (IDs%id_sss_sq > 0) then do j=js,je ; do i=is,ie work_2d(i,j) = sfc_state%SSS(i,j)*sfc_state%SSS(i,j) enddo ; enddo - call post_data(IDs%id_sss_sq, work_2d, diag, mask=G%mask2dT) + call post_data(IDs%id_sss_sq, work_2d, diag) endif call coupler_type_send_data(sfc_state%tr_fields, get_diag_time_end(diag)) @@ -1439,10 +1801,10 @@ subroutine post_transport_diagnostics(G, GV, US, uhtr, vhtr, h, IDs, diag_pre_dy type(tracer_registry_type), pointer :: Reg !< Pointer to the tracer registry ! Local variables - real, dimension(SZIB_(G), SZJ_(G)) :: umo2d ! Diagnostics of integrated mass transport [R Z L2 T-1 ~> kg s-1] - real, dimension(SZI_(G), SZJB_(G)) :: vmo2d ! Diagnostics of integrated mass transport [R Z L2 T-1 ~> kg s-1] - real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)) :: umo ! Diagnostics of layer mass transport [R Z L2 T-1 ~> kg s-1] - real, dimension(SZI_(G), SZJB_(G),SZK_(GV)) :: vmo ! Diagnostics of layer mass transport [R Z L2 T-1 ~> kg s-1] + real, dimension(SZIB_(G),SZJ_(G)) :: umo2d ! Diagnostics of integrated mass transport [R Z L2 T-1 ~> kg s-1] + real, dimension(SZI_(G),SZJB_(G)) :: vmo2d ! Diagnostics of integrated mass transport [R Z L2 T-1 ~> kg s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: umo ! Diagnostics of layer mass transport [R Z L2 T-1 ~> kg s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vmo ! Diagnostics of layer mass transport [R Z L2 T-1 ~> kg s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_tend ! Change in layer thickness due to dynamics ! [H T-1 ~> m s-1 or kg m-2 s-1]. real :: Idt ! The inverse of the time interval [T-1 ~> s-1] @@ -1531,16 +1893,23 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag real :: wave_speed_tol ! The fractional tolerance for finding the wave speeds [nondim] real :: convert_H ! A conversion factor from internal thickness units to the appropriate ! MKS units (m or kg m-2) for thicknesses depending on whether the - ! Boussinesq approximation is being made [m H-1 or kg m-2 H-1 ~> 1] + ! Boussinesq approximation is being made [m H-1 ~> 1] or [kg m-2 H-1 ~> 1] logical :: better_speed_est ! If true, use a more robust estimate of the first ! mode wave speed as the starting point for iterations. logical :: split ! True if using the barotropic-baroclinic split algorithm + logical :: calc_tides ! True if using tidal forcing + logical :: calc_sal ! True if using self-attraction and loading + logical :: om4_remap_via_sub_cells ! Use the OM4-era ramap_via_sub_cells for calculating the EBT structure ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_diagnostics" ! This module's name. character(len=48) :: thickness_units, flux_units logical :: use_temperature, adiabatic - logical :: default_2018_answers, remap_answers_2018 + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + integer :: 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. CS%initialized = .true. @@ -1557,7 +1926,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag call get_param(param_file, mdl, "DIAG_EBT_MONO_N2_DEPTH", CS%mono_N2_depth, & "The depth below which N2 is limited as monotonic for the "// & "purposes of calculating the equivalent barotropic wave speed.", & - units='m', scale=US%m_to_Z, default=-1.) + units='m', scale=GV%m_to_H, default=-1.) call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_TOL", wave_speed_tol, & "The fractional tolerance for finding the wave speeds.", & units="nondim", default=0.001) @@ -1568,34 +1937,52 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_BETTER_EST", better_speed_est, & "If true, use a more robust estimate of the first mode wave speed as the "//& "starting point for iterations.", default=.true.) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) + 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, "INTWAVE_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for calculating EBT structure. "//& + "See REMAPPING_USE_OM4_SUBCELLS for details. "//& + "We recommend setting this option to false.", default=om4_remap_via_sub_cells) + call get_param(param_file, mdl, "ACCURATE_NONBOUS_THICK_CELLO", CS%accurate_thick_cello, & + "If true, use the same careful integrals to find the diagnosed non-Boussinesq "//& + "layer thicknesses as are used to find the free surface height, instead of "//& + "using an approximate thickness based on division by the mid-layer density.", & + default=.false., do_not_log=GV%Boussinesq) + if (GV%Boussinesq) CS%accurate_thick_cello = .false. + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & + "The vintage of the expressions and order of arithmetic to use for remapping. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) + call get_param(param_file, mdl, "SPLIT", split, default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "TIDES", calc_tides, default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "CALCULATE_SAL", calc_sal, default=calc_tides, do_not_log=.true.) - if (GV%Boussinesq) then - thickness_units = "m" ; flux_units = "m3 s-1" ; convert_H = GV%H_to_m - else - thickness_units = "kg m-2" ; flux_units = "kg s-1" ; convert_H = GV%H_to_kg_m2 - endif + thickness_units = get_thickness_units(GV) + flux_units = get_flux_units(GV) + convert_H = GV%H_to_MKS - CS%id_masscello = register_diag_field('ocean_model', 'masscello', diag%axesTL,& - Time, 'Mass per unit area of liquid ocean grid cell', 'kg m-2', & !### , conversion=GV%H_to_kg_m2, & + CS%id_masscello = register_diag_field('ocean_model', 'masscello', diag%axesTL, & + Time, 'Mass per unit area of liquid ocean grid cell', 'kg m-2', conversion=GV%H_to_kg_m2, & standard_name='sea_water_mass_per_unit_area', v_extensive=.true.) - CS%id_masso = register_scalar_field('ocean_model', 'masso', Time, & - diag, 'Mass of liquid ocean', 'kg', standard_name='sea_water_mass') + CS%id_masso = register_scalar_field('ocean_model', 'masso', Time, diag, & + 'Mass of liquid ocean', units='kg', conversion=US%RZL2_to_kg, & + standard_name='sea_water_mass') CS%id_thkcello = register_diag_field('ocean_model', 'thkcello', diag%axesTL, Time, & - long_name = 'Cell Thickness', standard_name='cell_thickness', & + long_name='Cell Thickness', standard_name='cell_thickness', & units='m', conversion=US%Z_to_m, v_extensive=.true.) CS%id_h_pre_sync = register_diag_field('ocean_model', 'h_pre_sync', diag%axesTL, Time, & - long_name = 'Cell thickness from the previous timestep', & - units='m', conversion=GV%H_to_m, v_extensive=.true.) + long_name='Cell thickness from the previous timestep', & + units=thickness_units, conversion=GV%H_to_MKS, v_extensive=.true.) ! Note that CS%id_volcello would normally be registered here but because it is a "cell measure" and ! must be registered first. We earlier stored the handle of volcello but need it here for posting @@ -1605,53 +1992,125 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag if (use_temperature) then if (tv%T_is_conT) then CS%id_Tpot = register_diag_field('ocean_model', 'temp', diag%axesTL, & - Time, 'Potential Temperature', 'degC') + Time, 'Potential Temperature', 'degC', conversion=US%C_to_degC, cmor_field_name="thetao") endif if (tv%S_is_absS) then CS%id_Sprac = register_diag_field('ocean_model', 'salt', diag%axesTL, & - Time, 'Salinity', 'psu') + Time, 'Salinity', 'psu', conversion=US%S_to_ppt, cmor_field_name='so') endif CS%id_tob = register_diag_field('ocean_model','tob', diag%axesT1, Time, & long_name='Sea Water Potential Temperature at Sea Floor', & - standard_name='sea_water_potential_temperature_at_sea_floor', units='degC') + standard_name='sea_water_potential_temperature_at_sea_floor', & + units='degC', conversion=US%C_to_degC) CS%id_sob = register_diag_field('ocean_model','sob',diag%axesT1, Time, & long_name='Sea Water Salinity at Sea Floor', & - standard_name='sea_water_salinity_at_sea_floor', units='psu') + standard_name='sea_water_salinity_at_sea_floor', & + units='psu', conversion=US%S_to_ppt) + + CS%id_tosq = register_diag_field('ocean_model', 'tosq', diag%axesTL, & + Time, 'Square of Potential Temperature', 'degC2', conversion=US%C_to_degC**2, & + standard_name='Potential Temperature Squared') + CS%id_sosq = register_diag_field('ocean_model', 'sosq', diag%axesTL, & + Time, 'Square of Salinity', 'psu2', conversion=US%S_to_ppt**2, & + standard_name='Salinity Squared') CS%id_temp_layer_ave = register_diag_field('ocean_model', 'temp_layer_ave', & - diag%axesZL, Time, 'Layer Average Ocean Temperature', 'degC') + diag%axesZL, Time, 'Layer Average Ocean Temperature', units='degC', conversion=US%C_to_degC) + CS%id_bigtemp_layer_ave = register_diag_field('ocean_model', 'contemp_layer_ave', & + diag%axesZL, Time, 'Layer Average Ocean Conservative Temperature', units='Celsius', conversion=US%C_to_degC) CS%id_salt_layer_ave = register_diag_field('ocean_model', 'salt_layer_ave', & - diag%axesZL, Time, 'Layer Average Ocean Salinity', 'psu') + diag%axesZL, Time, 'Layer Average Ocean Salinity', units='psu', conversion=US%S_to_ppt) + CS%id_abssalt_layer_ave = register_diag_field('ocean_model', 'abssalt_layer_ave', & + diag%axesZL, Time, 'Layer Average Ocean Absolute Salinity', units='g kg-1', conversion=US%S_to_ppt) CS%id_thetaoga = register_scalar_field('ocean_model', 'thetaoga', & - Time, diag, 'Global Mean Ocean Potential Temperature', 'degC',& + Time, diag, 'Global Mean Ocean Potential Temperature', units='degC', conversion=US%C_to_degC, & standard_name='sea_water_potential_temperature') + CS%id_bigthetaoga = register_scalar_field('ocean_model', 'bigthetaoga', & + Time, diag, 'Global Mean Ocean Conservative Temperature', units='Celsius', conversion=US%C_to_degC, & + standard_name='sea_water_conservative_temperature') CS%id_soga = register_scalar_field('ocean_model', 'soga', & - Time, diag, 'Global Mean Ocean Salinity', 'psu', & + Time, diag, 'Global Mean Ocean Salinity', units='psu', conversion=US%S_to_ppt, & standard_name='sea_water_salinity') - - CS%id_tosga = register_scalar_field('ocean_model', 'sst_global', Time, diag,& - long_name='Global Area Average Sea Surface Temperature', & - units='degC', standard_name='sea_surface_temperature', & - cmor_field_name='tosga', cmor_standard_name='sea_surface_temperature', & + CS%id_abssoga = register_scalar_field('ocean_model', 'abssoga', & + Time, diag, 'Global Mean Ocean Absolute Salinity', units='g kg-1', conversion=US%S_to_ppt, & + standard_name='sea_water_absolute_salinity') + + ! The CMIP convention is potential temperature, but not indicated in the CMIP long name. + CS%id_tosga = register_scalar_field('ocean_model', 'sst_global', Time, diag, & + long_name='Global Area Average Sea Surface Temperature', & + units='degC', conversion=US%C_to_degC, standard_name='sea_surface_temperature', & + cmor_field_name='tosga', cmor_standard_name='sea_surface_temperature', & cmor_long_name='Sea Surface Temperature') - CS%id_sosga = register_scalar_field('ocean_model', 'sss_global', Time, diag,& - long_name='Global Area Average Sea Surface Salinity', & - units='psu', standard_name='sea_surface_salinity', & - cmor_field_name='sosga', cmor_standard_name='sea_surface_salinity', & + CS%id_bigtosga = register_scalar_field('ocean_model', 'sscont_global', Time, diag, & + long_name='Global Area Average Sea Surface Conservative Temperature', & + units='Celsius', conversion=US%C_to_degC, standard_name='sea_surface_temperature') + ! The CMIP convention is practical salinity, but not indicated in the CMIP long name. + CS%id_sosga = register_scalar_field('ocean_model', 'sss_global', Time, diag, & + long_name='Global Area Average Sea Surface Salinity', & + units='psu', conversion=US%S_to_ppt, standard_name='sea_surface_salinity', & + cmor_field_name='sosga', cmor_standard_name='sea_surface_salinity', & cmor_long_name='Sea Surface Salinity') - endif + CS%id_abssosga = register_scalar_field('ocean_model', 'ssabss_global', Time, diag, & + long_name='Global Area Average Sea Surface Absolute Salinity', & + units='psu', conversion=US%S_to_ppt, standard_name='sea_surface_absolute_salinity') + + ! 2d column integrated + CS%id_temp_int = register_diag_field('ocean_model', 'temp_int', diag%axesT1, Time, & + 'Density weighted column integrated potential temperature', & + 'degC kg m-2', conversion=US%C_to_degC*US%RZ_to_kg_m2, & + cmor_field_name='opottempmint', & + cmor_long_name='integral_wrt_depth_of_product_of_sea_water_density_and_potential_temperature', & + cmor_standard_name='Depth integrated density times potential temperature') + CS%id_salt_int = register_diag_field('ocean_model', 'salt_int', diag%axesT1, Time, & + 'Density weighted column integrated salinity', & + 'psu kg m-2', conversion=US%S_to_ppt*US%RZ_to_kg_m2, v_extensive=.true., & + cmor_field_name='somint', & + cmor_long_name='integral_wrt_depth_of_product_of_sea_water_density_and_salinity', & + cmor_standard_name='Depth integrated density times salinity') - CS%id_u = register_diag_field('ocean_model', 'u', diag%axesCuL, Time, & + ! 3d vertically integrated + CS%id_absscint = register_diag_field('ocean_model', 'absscint', diag%axesTL, Time, & + 'Integral wrt depth of seawater absolute salinity expressed as salt mass content', & + units='kg m-2', conversion=US%S_to_ppt*US%RZ_to_kg_m2, v_extensive=.true., & + standard_name='integral_wrt_depth_of_sea_water_absolute_salinity_expressed_as_salt_mass_content') + CS%id_pfscint = register_diag_field('ocean_model', 'pfscint', diag%axesTL, Time, & + ' Integral wrt depth of seawater preformed salinity expressed as salt mass content', & + units='kg m-2', conversion=US%S_to_ppt*US%RZ_to_kg_m2, v_extensive=.true., & + standard_name='integral_wrt_depth_of_sea_water_preformed_salinity_expressed_as_salt_mass_content') + CS%id_scint = register_diag_field('ocean_model', 'scint', diag%axesTL, Time, & + 'Integral wrt depth of seawater practical salinity expressed as salt mass content', & + units='kg m-2', conversion=US%S_to_ppt*US%RZ_to_kg_m2, v_extensive=.true., & + standard_name='integral_wrt_depth_of_sea_water_practical_salinity_expressed_as_salt_mass_content') + CS%id_chcint = register_diag_field('ocean_model', 'chcint', diag%axesTL, Time, & + 'Depth Integrated Seawater Conservative Temperature Expressed As Heat Content', & + units='J m-2', conversion=US%Q_to_J_kg*US%RZ_to_kg_m2, v_extensive=.true., & + standard_name='integral_wrt_depth_of_sea_water_conservative_temperature_expressed_as_heat_content') + CS%id_phcint = register_diag_field('ocean_model', 'phcint', diag%axesTL, Time, & + 'Integrated Ocean Heat Content from Potential Temperature', & + units='J m-2', conversion=US%Q_to_J_kg*US%RZ_to_kg_m2, v_extensive=.true., & + standard_name='integral_wrt_depth_of_sea_water_potential_temperature_expressed_as_heat_content') + + CS%id_t20d = register_diag_field('ocean_model', 't20d', diag%axesT1, Time, & + 'Depth of 20 degree Celsius Isotherm', & + units='m', conversion=US%Z_to_m, & + standard_name='depth_of_isosurface_of_sea_water_potential_temperature') + CS%id_t17d = register_diag_field('ocean_model', 't17d', diag%axesT1, Time, & + 'Depth of 17 degree Celsius Isotherm', & + units='m', conversion=US%Z_to_m, & + standard_name='depth_of_isosurface_of_sea_water_potential_temperature') + endif + + CS%id_u = register_diag_field('ocean_model', 'u', diag%axesCuL, Time, & 'Zonal velocity', 'm s-1', conversion=US%L_T_to_m_s, cmor_field_name='uo', & cmor_standard_name='sea_water_x_velocity', cmor_long_name='Sea Water X Velocity') - CS%id_v = register_diag_field('ocean_model', 'v', diag%axesCvL, Time, & + CS%id_v = register_diag_field('ocean_model', 'v', diag%axesCvL, Time, & 'Meridional velocity', 'm s-1', conversion=US%L_T_to_m_s, cmor_field_name='vo', & cmor_standard_name='sea_water_y_velocity', cmor_long_name='Sea Water Y Velocity') - CS%id_usq = register_diag_field('ocean_model', 'usq', diag%axesCuL, Time, & + CS%id_usq = register_diag_field('ocean_model', 'usq', diag%axesCuL, Time, & 'Zonal velocity squared', 'm2 s-2', conversion=US%L_T_to_m_s**2) - CS%id_vsq = register_diag_field('ocean_model', 'vsq', diag%axesCvL, Time, & + CS%id_vsq = register_diag_field('ocean_model', 'vsq', diag%axesCvL, Time, & 'Meridional velocity squared', 'm2 s-2', conversion=US%L_T_to_m_s**2) CS%id_uv = register_diag_field('ocean_model', 'uv', diag%axesTL, Time, & 'Product between zonal and meridional velocities at h-points', & @@ -1677,9 +2136,11 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag CS%id_rhoinsitu = register_diag_field('ocean_model', 'rhoinsitu', diag%axesTL, Time, & 'In situ density', 'kg m-3', conversion=US%R_to_kg_m3) CS%id_drho_dT = register_diag_field('ocean_model', 'drho_dT', diag%axesTL, Time, & - 'Partial derivative of rhoinsitu with respect to temperature (alpha)', 'kg m-3 degC-1') + 'Partial derivative of rhoinsitu with respect to temperature (alpha)', & + 'kg m-3 degC-1', conversion=US%R_to_kg_m3*US%degC_to_C) CS%id_drho_dS = register_diag_field('ocean_model', 'drho_dS', diag%axesTL, Time, & - 'Partial derivative of rhoinsitu with respect to salinity (beta)', 'kg^2 g-1 m-3') + 'Partial derivative of rhoinsitu with respect to salinity (beta)', & + 'kg^2 g-1 m-3', conversion=US%R_to_kg_m3*US%ppt_to_S) CS%id_du_dt = register_diag_field('ocean_model', 'dudt', diag%axesCuL, Time, & 'Zonal Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) @@ -1744,10 +2205,33 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag CS%id_PE_to_KE = register_diag_field('ocean_model', 'PE_to_KE', diag%axesTL, Time, & 'Potential to Kinetic Energy Conversion of Layer', & 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + if (calc_sal) & + CS%id_KE_SAL = register_diag_field('ocean_model', 'KE_SAL', diag%axesTL, Time, & + 'Kinetic Energy Source from Self-Attraction and Loading', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + if (calc_tides) & + CS%id_KE_TIDES = register_diag_field('ocean_model', 'KE_tides', diag%axesTL, Time, & + 'Kinetic Energy Source from Astronomical Tidal Forcing', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) if (split) then CS%id_KE_BT = register_diag_field('ocean_model', 'KE_BT', diag%axesTL, Time, & 'Barotropic contribution to Kinetic Energy', & 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_PE_to_KE_btbc = register_diag_field('ocean_model', 'PE_to_KE_btbc', diag%axesTL, Time, & + 'Potential to Kinetic Energy Conversion of Layer (including barotropic solver contribution)', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_KE_Coradv_btbc = register_diag_field('ocean_model', 'KE_Coradv_btbc', diag%axesTL, Time, & + 'Kinetic Energy Source from Coriolis and Advection (including barotropic solver contribution)', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_KE_BT_PF = register_diag_field('ocean_model', 'KE_BTPF', diag%axesTL, Time, & + 'Kinetic Energy Source from Barotropic Pressure Gradient Force.', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_KE_BT_CF = register_diag_field('ocean_model', 'KE_BTCF', diag%axesTL, Time, & + 'Kinetic Energy Source from Barotropic Coriolis Force.', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_KE_BT_WD = register_diag_field('ocean_model', 'KE_BTWD', diag%axesTL, Time, & + 'Kinetic Energy Source from Barotropic Linear Wave Drag.', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) endif CS%id_KE_Coradv = register_diag_field('ocean_model', 'KE_Coradv', diag%axesTL, Time, & 'Kinetic Energy Source from Coriolis and Advection', & @@ -1758,6 +2242,9 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag CS%id_KE_visc = register_diag_field('ocean_model', 'KE_visc', diag%axesTL, Time, & 'Kinetic Energy Source from Vertical Viscosity and Stresses', & 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_KE_visc_gl90 = register_diag_field('ocean_model', 'KE_visc_gl90', diag%axesTL, Time, & + 'Kinetic Energy Source from GL90 Vertical Viscosity', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) CS%id_KE_stress = register_diag_field('ocean_model', 'KE_stress', diag%axesTL, Time, & 'Kinetic Energy Source from Surface Stresses or Body Wind Stress', & 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) @@ -1791,28 +2278,14 @@ 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_answers_2018=remap_answers_2018, & + call wave_speed_init(CS%wave_speed, GV, remap_answer_date=remap_answer_date, & better_speed_est=better_speed_est, min_speed=wave_speed_min, & - wave_speed_tol=wave_speed_tol) + wave_speed_tol=wave_speed_tol, om4_remap_via_sub_cells=om4_remap_via_sub_cells) endif - CS%id_mass_wt = register_diag_field('ocean_model', 'mass_wt', diag%axesT1, Time, & + CS%id_mass_wt = register_diag_field('ocean_model', 'mass_wt', diag%axesT1, Time, & 'The column mass for calculating mass-weighted average properties', 'kg m-2', conversion=US%RZ_to_kg_m2) - if (use_temperature) then - CS%id_temp_int = register_diag_field('ocean_model', 'temp_int', diag%axesT1, Time, & - 'Density weighted column integrated potential temperature', 'degC kg m-2', conversion=US%RZ_to_kg_m2, & - cmor_field_name='opottempmint', & - cmor_long_name='integral_wrt_depth_of_product_of_sea_water_density_and_potential_temperature',& - cmor_standard_name='Depth integrated density times potential temperature') - - CS%id_salt_int = register_diag_field('ocean_model', 'salt_int', diag%axesT1, Time, & - 'Density weighted column integrated salinity', 'psu kg m-2', conversion=US%RZ_to_kg_m2, & - cmor_field_name='somint', & - cmor_long_name='integral_wrt_depth_of_product_of_sea_water_density_and_salinity',& - cmor_standard_name='Depth integrated density times salinity') - endif - CS%id_col_mass = register_diag_field('ocean_model', 'col_mass', diag%axesT1, Time, & 'The column integrated in situ density', 'kg m-2', conversion=US%RZ_to_kg_m2) @@ -1839,19 +2312,19 @@ subroutine register_surface_diags(Time, G, US, IDs, diag, tv) type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables ! Vertically integrated, budget, and surface state diagnostics - IDs%id_volo = register_scalar_field('ocean_model', 'volo', Time, diag,& - long_name='Total volume of liquid ocean', units='m3', & + IDs%id_volo = register_scalar_field('ocean_model', 'volo', Time, diag, & + long_name='Total volume of liquid ocean', units='m3', conversion=US%Z_to_m*US%L_to_m**2, & standard_name='sea_water_volume') - IDs%id_zos = register_diag_field('ocean_model', 'zos', diag%axesT1, Time,& - standard_name = 'sea_surface_height_above_geoid', & - long_name= 'Sea surface height above geoid', units='m') - IDs%id_zossq = register_diag_field('ocean_model', 'zossq', diag%axesT1, Time,& - standard_name='square_of_sea_surface_height_above_geoid', & - long_name='Square of sea surface height above geoid', units='m2') + IDs%id_zos = register_diag_field('ocean_model', 'zos', diag%axesT1, Time, & + standard_name = 'sea_surface_height_above_geoid', & + long_name= 'Sea surface height above geoid', units='m', conversion=US%Z_to_m) + IDs%id_zossq = register_diag_field('ocean_model', 'zossq', diag%axesT1, Time, & + standard_name='square_of_sea_surface_height_above_geoid', & + long_name='Square of sea surface height above geoid', units='m2', conversion=US%Z_to_m**2) IDs%id_ssh = register_diag_field('ocean_model', 'SSH', diag%axesT1, Time, & 'Sea Surface Height', 'm', conversion=US%Z_to_m) - IDs%id_ssh_ga = register_scalar_field('ocean_model', 'ssh_ga', Time, diag,& - long_name='Area averaged sea surface height', units='m', & + IDs%id_ssh_ga = register_scalar_field('ocean_model', 'ssh_ga', Time, diag, & + long_name='Area averaged sea surface height', units='m', conversion=US%Z_to_m, & standard_name='area_averaged_sea_surface_height') IDs%id_ssu = register_diag_field('ocean_model', 'SSU', diag%axesCu1, Time, & 'Sea Surface Zonal Velocity', 'm s-1', conversion=US%L_T_to_m_s) @@ -1859,31 +2332,35 @@ subroutine register_surface_diags(Time, G, US, IDs, diag, tv) 'Sea Surface Meridional Velocity', 'm s-1', conversion=US%L_T_to_m_s) IDs%id_speed = register_diag_field('ocean_model', 'speed', diag%axesT1, Time, & 'Sea Surface Speed', 'm s-1', conversion=US%L_T_to_m_s) + IDs%id_ssu_east = register_diag_field('ocean_model', 'ssu_east', diag%axesT1, Time, & + 'Eastward velocity', 'm s-1', conversion=US%L_T_to_m_s) + IDs%id_ssv_north = register_diag_field('ocean_model', 'ssv_north', diag%axesT1, Time, & + 'Northward velocity', 'm s-1', conversion=US%L_T_to_m_s) if (associated(tv%T)) then - IDs%id_sst = register_diag_field('ocean_model', 'SST', diag%axesT1, Time, & - 'Sea Surface Temperature', 'degC', cmor_field_name='tos', & - cmor_long_name='Sea Surface Temperature', & + IDs%id_sst = register_diag_field('ocean_model', 'SST', diag%axesT1, Time, & + 'Sea Surface Temperature', 'degC', conversion=US%C_to_degC, & + cmor_field_name='tos', cmor_long_name='Sea Surface Temperature', & cmor_standard_name='sea_surface_temperature') IDs%id_sst_sq = register_diag_field('ocean_model', 'SST_sq', diag%axesT1, Time, & - 'Sea Surface Temperature Squared', 'degC2', cmor_field_name='tossq', & - cmor_long_name='Square of Sea Surface Temperature ', & + 'Sea Surface Temperature Squared', 'degC2', conversion=US%C_to_degC**2, & + cmor_field_name='tossq', cmor_long_name='Square of Sea Surface Temperature ', & cmor_standard_name='square_of_sea_surface_temperature') IDs%id_sss = register_diag_field('ocean_model', 'SSS', diag%axesT1, Time, & - 'Sea Surface Salinity', 'psu', cmor_field_name='sos', & - cmor_long_name='Sea Surface Salinity', & + 'Sea Surface Salinity', 'psu', conversion=US%S_to_ppt, & + cmor_field_name='sos', cmor_long_name='Sea Surface Salinity', & cmor_standard_name='sea_surface_salinity') IDs%id_sss_sq = register_diag_field('ocean_model', 'SSS_sq', diag%axesT1, Time, & - 'Sea Surface Salinity Squared', 'psu', cmor_field_name='sossq', & - cmor_long_name='Square of Sea Surface Salinity ', & + 'Sea Surface Salinity Squared', 'psu2', conversion=US%S_to_ppt**2, & + cmor_field_name='sossq', cmor_long_name='Square of Sea Surface Salinity ', & cmor_standard_name='square_of_sea_surface_salinity') if (tv%T_is_conT) then - IDs%id_sstcon = register_diag_field('ocean_model', 'conSST', diag%axesT1, Time, & - 'Sea Surface Conservative Temperature', 'Celsius') + IDs%id_sstcon = register_diag_field('ocean_model', 'conSST', diag%axesT1, Time, & + 'Sea Surface Conservative Temperature', 'Celsius', conversion=US%C_to_degC) endif if (tv%S_is_absS) then - IDs%id_sssabs = register_diag_field('ocean_model', 'absSSS', diag%axesT1, Time, & - 'Sea Surface Absolute Salinity', 'g kg-1') + IDs%id_sssabs = register_diag_field('ocean_model', 'absSSS', diag%axesT1, Time, & + 'Sea Surface Absolute Salinity', 'g kg-1', conversion=US%S_to_ppt) endif if (associated(tv%frazil)) then IDs%id_fraz = register_diag_field('ocean_model', 'frazil', diag%axesT1, Time, & @@ -1896,11 +2373,11 @@ subroutine register_surface_diags(Time, G, US, IDs, diag, tv) IDs%id_salt_deficit = register_diag_field('ocean_model', 'salt_deficit', diag%axesT1, Time, & 'Salt source in ocean required to supply excessive ice salt fluxes', & - 'ppt kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) + 'ppt kg m-2 s-1', conversion=US%S_to_ppt*US%RZ_T_to_kg_m2s) IDs%id_Heat_PmE = register_diag_field('ocean_model', 'Heat_PmE', diag%axesT1, Time, & 'Heat flux into ocean from mass flux into ocean', & 'W m-2', conversion=US%QRZ_T_to_W_m2) - IDs%id_intern_heat = register_diag_field('ocean_model', 'internal_heat', diag%axesT1, Time,& + IDs%id_intern_heat = register_diag_field('ocean_model', 'internal_heat', diag%axesT1, Time, & 'Heat flux into ocean from geothermal or other internal sources', & 'W m-2', conversion=US%QRZ_T_to_W_m2) @@ -1911,27 +2388,26 @@ subroutine register_transport_diags(Time, G, GV, US, IDs, diag) type(time_type), intent(in) :: Time !< current model time type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(transport_diag_IDs), intent(inout) :: IDs !< A structure with the diagnostic IDs. type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output - real :: H_convert character(len=48) :: thickness_units, accum_flux_units thickness_units = get_thickness_units(GV) if (GV%Boussinesq) then - H_convert = GV%H_to_m ; accum_flux_units = "m3" + accum_flux_units = "m3" else - H_convert = GV%H_to_kg_m2 ; accum_flux_units = "kg" + accum_flux_units = "kg" endif ! Diagnostics related to tracer and mass transport IDs%id_uhtr = register_diag_field('ocean_model', 'uhtr', diag%axesCuL, Time, & 'Accumulated zonal thickness fluxes to advect tracers', & - accum_flux_units, y_cell_method='sum', v_extensive=.true., conversion=H_convert*US%L_to_m**2) + accum_flux_units, y_cell_method='sum', v_extensive=.true., conversion=GV%H_to_MKS*US%L_to_m**2) IDs%id_vhtr = register_diag_field('ocean_model', 'vhtr', diag%axesCvL, Time, & 'Accumulated meridional thickness fluxes to advect tracers', & - accum_flux_units, x_cell_method='sum', v_extensive=.true., conversion=H_convert*US%L_to_m**2) + accum_flux_units, x_cell_method='sum', v_extensive=.true., conversion=GV%H_to_MKS*US%L_to_m**2) IDs%id_umo = register_diag_field('ocean_model', 'umo', & diag%axesCuL, Time, 'Ocean Mass X Transport', & 'kg s-1', conversion=US%RZ_T_to_kg_m2s*US%L_to_m**2, & @@ -1948,12 +2424,12 @@ subroutine register_transport_diags(Time, G, GV, US, IDs, diag) diag%axesCv1, Time, 'Ocean Mass Y Transport Vertical Sum', & 'kg s-1', conversion=US%RZ_T_to_kg_m2s*US%L_to_m**2, & standard_name='ocean_mass_y_transport_vertical_sum', x_cell_method='sum') - IDs%id_dynamics_h = register_diag_field('ocean_model','dynamics_h', & + IDs%id_dynamics_h = register_diag_field('ocean_model','dynamics_h', & diag%axesTl, Time, 'Layer thicknesses prior to horizontal dynamics', & - 'm', v_extensive=.true., conversion=GV%H_to_m) - IDs%id_dynamics_h_tendency = register_diag_field('ocean_model','dynamics_h_tendency', & + thickness_units, conversion=GV%H_to_MKS, v_extensive=.true.) + IDs%id_dynamics_h_tendency = register_diag_field('ocean_model','dynamics_h_tendency', & diag%axesTl, Time, 'Change in layer thicknesses due to horizontal dynamics', & - 'm s-1', v_extensive=.true., conversion=GV%H_to_m*US%s_to_T) + trim(thickness_units)//" s-1", conversion=GV%H_to_MKS*US%s_to_T, v_extensive=.true.) end subroutine register_transport_diags @@ -1966,7 +2442,7 @@ subroutine write_static_fields(G, GV, US, tv, diag) type(diag_ctrl), target, intent(inout) :: diag !< regulates diagnostic output ! Local variables - real :: work_2d(SZI_(G),SZJ_(G)) ! A 2-d temporary work array. + real :: work_2d(SZI_(G),SZJ_(G)) ! A 2-d temporary work array [Z ~> m] integer :: id, i, j logical :: use_temperature @@ -2033,14 +2509,15 @@ subroutine write_static_fields(G, GV, US, tv, diag) x_cell_method='sum', y_cell_method='sum', area_cell_method='sum') if (id > 0) call post_data(id, G%areaBu, diag, .true.) - id = register_static_field('ocean_model', 'depth_ocean', diag%axesT1, & + id = register_static_field('ocean_model', 'depth_ocean', diag%axesT1, & 'Depth of the ocean at tracer points', 'm', conversion=US%Z_to_m, & - standard_name='sea_floor_depth_below_geoid', & - cmor_field_name='deptho', cmor_long_name='Sea Floor Depth', & + standard_name='sea_floor_depth_below_geoid', & + cmor_field_name='deptho', cmor_long_name='Sea Floor Depth', & cmor_standard_name='sea_floor_depth_below_geoid', area=diag%axesT1%id_area, & x_cell_method='mean', y_cell_method='mean', area_cell_method='mean') if (id > 0) then do j=G%jsc,G%jec ; do i=G%isc,G%iec ; work_2d(i,j) = G%bathyT(i,j)+G%Z_ref ; enddo ; enddo + ! A mask argument is required here because masks are not applied to static fields by default. call post_data(id, work_2d, diag, .true., mask=G%mask2dT) endif @@ -2125,7 +2602,7 @@ subroutine write_static_fields(G, GV, US, tv, diag) use_temperature = associated(tv%T) if (use_temperature) then id = register_static_field('ocean_model','C_p', diag%axesNull, & - 'heat capacity of sea water', 'J kg-1 K-1', conversion=US%Q_to_J_kg, & + 'heat capacity of sea water', 'J kg-1 K-1', conversion=US%Q_to_J_kg*US%degC_to_C, & cmor_field_name='cpocean', & cmor_standard_name='specific_heat_capacity_of_sea_water', & cmor_long_name='specific_heat_capacity_of_sea_water') @@ -2183,7 +2660,10 @@ subroutine set_dependent_diagnostics(MIS, ADp, CDp, G, GV, CS) call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) endif - + if (CS%id_KE_visc_gl90 > 0) then + call safe_alloc_ptr(ADp%du_dt_visc_gl90,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(ADp%dv_dt_visc_gl90,isd,ied,JsdB,JedB,nz) + endif if (CS%id_KE_stress > 0) then call safe_alloc_ptr(ADp%du_dt_str,IsdB,IedB,jsd,jed,nz) call safe_alloc_ptr(ADp%dv_dt_str,isd,ied,JsdB,JedB,nz) @@ -2195,9 +2675,37 @@ subroutine set_dependent_diagnostics(MIS, ADp, CDp, G, GV, CS) call safe_alloc_ptr(CDp%diapyc_vel,isd,ied,jsd,jed,nz+1) endif + if ((CS%id_PE_to_KE_btbc > 0) .or. (CS%id_KE_BT_PF > 0)) then + call safe_alloc_ptr(ADp%bt_pgf_u, IsdB, IedB, jsd, jed, nz) + call safe_alloc_ptr(ADp%bt_pgf_v, isd, ied, JsdB, JedB, nz) + endif + + if ((CS%id_KE_Coradv_btbc > 0) .or. (CS%id_KE_BT_CF > 0)) then + call safe_alloc_ptr(ADp%bt_cor_u, IsdB, IedB, jsd, jed) + call safe_alloc_ptr(ADp%bt_cor_v, isd, ied, JsdB, JedB) + endif + + if (CS%id_KE_BT_WD > 0) then + call safe_alloc_ptr(ADp%bt_lwd_u, IsdB, IedB, jsd, jed) + call safe_alloc_ptr(ADp%bt_lwd_v, isd, ied, JsdB, JedB) + endif + + if (CS%id_KE_SAL > 0) then + call safe_alloc_ptr(ADp%sal_u, IsdB, IedB, jsd, jed, nz) + call safe_alloc_ptr(ADp%sal_v, isd, ied, JsdB, JedB, nz) + endif + + if (CS%id_KE_TIDES > 0) then + call safe_alloc_ptr(ADp%tides_u, IsdB, IedB, jsd, jed, nz) + call safe_alloc_ptr(ADp%tides_v, isd, ied, JsdB, JedB, nz) + endif + CS%KE_term_on = ((CS%id_dKEdt > 0) .or. (CS%id_PE_to_KE > 0) .or. (CS%id_KE_BT > 0) .or. & (CS%id_KE_Coradv > 0) .or. (CS%id_KE_adv > 0) .or. (CS%id_KE_visc > 0) .or. & - (CS%id_KE_stress > 0) .or. (CS%id_KE_horvisc > 0) .or. (CS%id_KE_dia > 0)) + (CS%id_KE_visc_gl90 > 0) .or. (CS%id_KE_stress > 0) .or. (CS%id_KE_horvisc > 0) .or. & + (CS%id_KE_dia > 0) .or. (CS%id_PE_to_KE_btbc > 0) .or. (CS%id_KE_BT_PF > 0) .or. & + (CS%id_KE_Coradv_btbc > 0) .or. (CS%id_KE_BT_CF > 0) .or. (CS%id_KE_BT_WD > 0) .or. & + (CS%id_KE_SAL > 0) .or. (CS%id_KE_TIDES > 0)) if (CS%id_h_du_dt > 0) call safe_alloc_ptr(ADp%diag_hu,IsdB,IedB,jsd,jed,nz) if (CS%id_h_dv_dt > 0) call safe_alloc_ptr(ADp%diag_hv,isd,ied,JsdB,JedB,nz) @@ -2237,6 +2745,20 @@ subroutine MOM_diagnostics_end(CS, ADp, CDp) if (associated(ADp%du_other)) deallocate(ADp%du_other) if (associated(ADp%dv_other)) deallocate(ADp%dv_other) + if (associated(ADp%bt_pgf_u)) deallocate(ADp%bt_pgf_u) + if (associated(ADp%bt_pgf_v)) deallocate(ADp%bt_pgf_v) + if (associated(ADp%bt_cor_u)) deallocate(ADp%bt_cor_u) + if (associated(ADp%bt_cor_v)) deallocate(ADp%bt_cor_v) + if (associated(ADp%bt_lwd_u)) deallocate(ADp%bt_lwd_u) + if (associated(ADp%bt_lwd_v)) deallocate(ADp%bt_lwd_v) + + ! NOTE: sal_[uv] and tide_[uv] may be allocated either here (KE budget diagnostics) or + ! PressureForce module (momentum acceleration diagnostics) + if (associated(ADp%sal_u)) deallocate(ADp%sal_u) + if (associated(ADp%sal_v)) deallocate(ADp%sal_v) + if (associated(ADp%tides_u)) deallocate(ADp%tides_u) + if (associated(ADp%tides_v)) deallocate(ADp%tides_v) + if (associated(ADp%diag_hfrac_u)) deallocate(ADp%diag_hfrac_u) if (associated(ADp%diag_hfrac_v)) deallocate(ADp%diag_hfrac_v) diff --git a/src/diagnostics/MOM_harmonic_analysis.F90 b/src/diagnostics/MOM_harmonic_analysis.F90 new file mode 100644 index 0000000000..8f0eb9c87e --- /dev/null +++ b/src/diagnostics/MOM_harmonic_analysis.F90 @@ -0,0 +1,584 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Inline harmonic analysis (conventional) +module MOM_harmonic_analysis + +use MOM_time_manager, only : time_type, real_to_time, time_to_real, time_minus_signed +use MOM_time_manager, only : set_date, get_date, increment_date +use MOM_time_manager, only : operator(+), operator(-), operator(<), operator(>), operator(>=) +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_file_parser, only : param_file_type, get_param +use MOM_io, only : file_exists, open_ASCII_file, READONLY_FILE, close_file +use MOM_io, only : MOM_infra_file, vardesc, MOM_field +use MOM_io, only : var_desc, create_MOM_file, SINGLE_FILE, MOM_write_field +use MOM_error_handler, only : MOM_mesg, MOM_error, NOTE +use MOM_tidal_forcing, only : astro_longitudes, astro_longitudes_init, eq_phase, nodal_fu, tidal_frequency + +implicit none ; private + +public HA_init, HA_accum + +#include + +!> The private control structure for storing the HA info of a particular field +type, private :: HA_type + character(len=16) :: key = "none" !< Name of the field of which harmonic analysis is to be performed + character(len=1) :: grid !< The grid on which the field is defined ('h', 'q', 'u', or 'v') + real :: old_time = -1.0 !< The time of the previous accumulating step [T ~> s] + real, allocatable :: ref(:,:) !< The initial field in arbitrary units [A] + real, allocatable :: FtF(:,:) !< Accumulator of (F' * F) [nondim] + real, allocatable :: FtSSH(:,:,:) !< Accumulator of (F' * SSH_in) in arbitrary units [A] + !>@{ Lower and upper bounds of input data + integer :: is, ie, js, je + !>@} +end type HA_type + +!> A linked list of control structures that store the HA info of different fields +type, private :: HA_node + type(HA_type) :: this !< Control structure of the current field in the list + type(HA_node), pointer :: next !< The list of other fields +end type HA_node + +!> The public control structure of the MOM_harmonic_analysis module +type, public :: harmonic_analysis_CS ; private + logical :: HAready = .false. !< If true, perform harmonic analysis + type(time_type) :: & + time_start, & !< Start time of harmonic analysis + time_end, & !< End time of harmonic analysis + time_ref !< Reference time (t = 0) used to calculate tidal forcing + real, allocatable, dimension(:) :: & + freq, & !< The frequency of a tidal constituent [T-1 ~> s-1] + phase0, & !< The phase of a tidal constituent at time 0 [rad] + tide_fn, & !< Amplitude modulation of tides by nodal cycle [nondim]. + tide_un !< Phase modulation of tides by nodal cycle [rad]. + integer :: nc !< The number of tidal constituents in use + integer :: length !< Number of fields of which harmonic analysis is to be performed + character(len=4), allocatable, dimension(:) :: const_name !< The name of each constituent + character(len=255) :: path !< Path to directory where output will be written + type(unit_scale_type) :: US !< A dimensional unit scaling type + type(HA_node), pointer :: list => NULL() !< A linked list for storing the HA info of different fields +end type harmonic_analysis_CS + +contains + +!> This subroutine sets static variables used by this module and initializes CS%list. +!! THIS MUST BE CALLED AT THE END OF tidal_forcing_init. +subroutine HA_init(Time, US, param_file, nc, CS) + type(time_type), intent(in) :: Time !< The current model time + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + integer, intent(in) :: nc !< The number of tidal constituents in use + type(harmonic_analysis_CS), intent(out) :: CS !< Control structure of the MOM_harmonic_analysis module + + ! Local variables + logical :: tides !< True if tidal forcing module is enabled + logical :: use_eq_phase !< If true, tidal forcing is phase-shifted to match + !! equilibrium tide. Set to false if providing tidal phases + !! that have already been shifted by the + !! astronomical/equilibrium argument + logical :: add_nodal_terms !< If true, insert terms for the 18.6 year modulation when + !! calculating tidal forcing. + integer, dimension(3) :: tide_ref_date !< Reference date (t = 0) for tidal forcing (year, month, day) + integer, dimension(3) :: nodal_ref_date !< Date to calculate nodal modulation for (year, month, day) + type(time_type) :: nodal_time !< Model time to calculate nodal modulation for. + type(astro_longitudes) :: tidal_longitudes !< Astronomical longitudes used to calculate + !! tidal phases at t = 0. + type(astro_longitudes) :: nodal_longitudes !< Solar and lunar longitudes for tidal forcing + character(len=50) :: const_name !< Names of all tidal constituents to be harmonically analyzed + integer :: c + + type(HA_type) :: ha1 !< A temporary, null field used for initializing CS%list + real :: HA_start_time !< Start time of harmonic analysis [T ~> s] + real :: HA_end_time !< End time of harmonic analysis [T ~> s] + logical :: HA_ssh, HA_ubt, HA_vbt + character(len=40) :: mdl="MOM_harmonic_analysis" !< This module's name + character(len=255) :: mesg + integer :: year, month, day, hour, minute, second + + call get_param(param_file, mdl, "TIDES", tides, & + "If true, apply tidal momentum forcing.", default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "TIDE_USE_EQ_PHASE", use_eq_phase, & + "If true, add the equilibrium phase argument to the specified tidal phases.", & + old_name="OBC_TIDE_ADD_EQ_PHASE", default=.false., do_not_log=tides) + call get_param(param_file, mdl, "TIDE_ADD_NODAL", add_nodal_terms, & + "If true, include 18.6 year nodal modulation in the boundary tidal forcing.", & + old_name="OBC_TIDE_ADD_NODAL", default=.false., do_not_log=tides) + call get_param(param_file, mdl, "TIDE_REF_DATE", tide_ref_date, & + "Reference date to use for tidal calculations and equilibrium phase.", & + old_name="OBC_TIDE_REF_DATE", defaults=(/0, 0, 0/), do_not_log=tides) + call get_param(param_file, mdl, "TIDE_NODAL_REF_DATE", nodal_ref_date, & + "Fixed reference date to use for nodal modulation.", & + old_name="OBC_TIDE_NODAL_REF_DATE", defaults=(/0, 0, 0/), do_not_log=tides) + call get_param(param_file, mdl, "HA_CONSTITUENTS", const_name, & + "Names of tidal constituents to be harmonically analyzed. "//& + "They don't have to be the same as those used in MOM_tidal_forcing.", & + fail_if_missing=.true.) + + if (sum(tide_ref_date) == 0) then ! tide_ref_date defaults to 0. + CS%time_ref = set_date(1, 1, 1, 0, 0, 0) + else + if (.not. use_eq_phase) then + ! Using a reference date but not using phase relative to equilibrium. + ! This makes sense as long as either phases are overridden, or + ! correctly simulating tidal phases is not desired. + call MOM_mesg('Tidal phases will *not* be corrected with equilibrium arguments.') + endif + CS%time_ref = set_date(tide_ref_date(1), tide_ref_date(2), tide_ref_date(3), 0, 0, 0) + endif + + ! Initialize reference time for tides and find relevant lunar and solar + ! longitudes at the reference time. + if (use_eq_phase) call astro_longitudes_init(CS%time_ref, tidal_longitudes) + + ! If the nodal correction is based on a different time, initialize that. + ! Otherwise, it can use N from the time reference. + if (add_nodal_terms) then + if (sum(nodal_ref_date) /= 0) then + ! A reference date was provided for the nodal correction + nodal_time = set_date(nodal_ref_date(1), nodal_ref_date(2), nodal_ref_date(3)) + call astro_longitudes_init(nodal_time, nodal_longitudes) + elseif (use_eq_phase) then + ! Astronomical longitudes were already calculated for use in equilibrium phases, + ! so use nodal longitude from that. + nodal_longitudes = tidal_longitudes + else + ! Tidal reference time is a required parameter, so calculate the longitudes from that. + call astro_longitudes_init(CS%time_ref, nodal_longitudes) + endif + endif + + allocate(CS%const_name(nc)) + allocate(CS%freq(nc)) + allocate(CS%phase0(nc)) + allocate(CS%tide_fn(nc)) + allocate(CS%tide_un(nc)) + + ! Tidal constituents for harmonic analysis can be different from those defined in MOM_tidal_forcing + read(const_name, *) CS%const_name + + ! For major tidal constituents, tidal parameters defined in MOM_tidal_forcing will be used. + ! For those not available in MOM_tidal_forcing, parameters needs to be defined in MOM_input. + do c=1,nc + call get_param(param_file, mdl, "HA_"//trim(CS%const_name(c))//"_FREQ", & + CS%freq(c), "Frequency of the "//trim(CS%const_name(c))//& + " constituent. This is used if USE_HA is true and "//trim(CS%const_name(c))//& + " is in HA_CONSTITUENTS.", units="rad s-1", scale=US%T_to_s, default=0.0) + if (CS%freq(c)<=0.0) then + select case (trim(CS%const_name(c))) + case ('M4') + CS%freq(c) = tidal_frequency('M2') * 2 + case ('M6') + CS%freq(c) = tidal_frequency('M2') * 3 + case ('M8') + CS%freq(c) = tidal_frequency('M2') * 4 + case ('S4') + CS%freq(c) = tidal_frequency('S2') * 2 + case ('S6') + CS%freq(c) = tidal_frequency('S2') * 3 + case ('MK3') + CS%freq(c) = tidal_frequency('M2') + tidal_frequency('K1') + case ('MS4') + CS%freq(c) = tidal_frequency('M2') + tidal_frequency('S2') + case ('MN4') + CS%freq(c) = tidal_frequency('M2') + tidal_frequency('N2') + case default + CS%freq(c) = tidal_frequency(trim(CS%const_name(c))) + end select + endif + + call get_param(param_file, mdl, "HA_"//trim(CS%const_name(c))//"_PHASE_T0", CS%phase0(c), & + "Phase of the "//trim(CS%const_name(c))//" tidal constituent at time 0. "//& + "This is only used if USE_HA is true and "//trim(CS%const_name(c))// & + " is in HA_CONSTITUENTS.", units="radians", default=0.0) + if (use_eq_phase) CS%phase0(c) = eq_phase(trim(CS%const_name(c)), tidal_longitudes) + + ! Nodal modulation should be turned off for tidal constituents not available in MOM_tidal_forcing + if (add_nodal_terms) then + call nodal_fu(trim(trim(CS%const_name(c))), nodal_longitudes%N, CS%tide_fn(c), CS%tide_un(c)) + else + CS%tide_fn(c) = 1.0 + CS%tide_un(c) = 0.0 + endif + enddo + + ! Determine CS%time_start and CS%time_end + call get_param(param_file, mdl, "HA_START_TIME", HA_start_time, & + "Start time of harmonic analysis, in units of days after "//& + "the start of the current run segment. Must be smaller than "//& + "HA_END_TIME, otherwise harmonic analysis will not be performed. "//& + "If negative, |HA_START_TIME| determines the length of harmonic analysis, "//& + "and harmonic analysis will start |HA_START_TIME| days before HA_END_TIME, "//& + "or at the beginning of the run segment, whichever occurs later.", & + units="days", default=0.0, scale=86400.0*US%s_to_T) + call get_param(param_file, mdl, "HA_END_TIME", HA_end_time, & + "End time of harmonic analysis, in units of days after "//& + "the start of the current run segment. Must be positive "//& + "and smaller than the length of the currnet run segment, "//& + "otherwise harmonic analysis will not be performed.", & + units="days", default=0.0, scale=86400.0*US%s_to_T) + + if (HA_end_time <= 0.0) then + call MOM_mesg('MOM_harmonic_analysis: HA_END_TIME is zero or negative. '//& + 'Harmonic analysis will not be performed.') + CS%HAready = .false. ; return + endif + + if (HA_end_time <= HA_start_time) then + call MOM_mesg('MOM_harmonic_analysis: HA_END_TIME is smaller than or equal to HA_START_TIME. '//& + 'Harmonic analysis will not be performed.') + CS%HAready = .false. ; return + endif + + CS%HAready = .true. + + if (HA_start_time < 0.0) then + HA_start_time = HA_end_time + HA_start_time + if (HA_start_time <= 0.0) HA_start_time = 0.0 + endif + + CS%time_start = Time + real_to_time(HA_start_time, unscale=US%T_to_s) + CS%time_end = Time + real_to_time(HA_end_time, unscale=US%T_to_s) + + call get_date(Time, year, month, day, hour, minute, second) + write(mesg,*) "MOM_harmonic_analysis: run segment starts on ", year, month, day, hour, minute, second + call MOM_error(NOTE, trim(mesg)) + call get_date(CS%time_start, year, month, day, hour, minute, second) + write(mesg,*) "MOM_harmonic_analysis: harmonic analysis starts on ", year, month, day, hour, minute, second + call MOM_error(NOTE, trim(mesg)) + call get_date(CS%time_end, year, month, day, hour, minute, second) + write(mesg,*) "MOM_harmonic_analysis: harmonic analysis ends on ", year, month, day, hour, minute, second + call MOM_error(NOTE, trim(mesg)) + + ! Set path to directory where output will be written + call get_param(param_file, mdl, "HA_PATH", CS%path, & + "Path to output files for runtime harmonic analysis.", default="./") + + ! Populate some parameters of the control structure + CS%nc = nc + CS%length = 0 + CS%US = US + + ! Initialize CS%list + allocate(CS%list) + CS%list%this = ha1 + nullify(CS%list%next) + + ! Register variables/fields to be analyzed + call get_param(param_file, mdl, "HA_SSH", HA_ssh, & + "If true, perform harmonic analysis of sea serface height.", default=.false.) + if (HA_ssh) call HA_register('ssh', 'h', CS) + call get_param(param_file, mdl, "HA_UBT", HA_ubt, & + "If true, perform harmonic analysis of zonal barotropic velocity.", default=.false.) + if (HA_ubt) call HA_register('ubt', 'u', CS) + call get_param(param_file, mdl, "HA_VBT", HA_vbt, & + "If true, perform harmonic analysis of meridional barotropic velocity.", default=.false.) + if (HA_vbt) call HA_register('vbt', 'v', CS) + +end subroutine HA_init + +!> This subroutine registers each of the fields on which HA is to be performed. +subroutine HA_register(key, grid, CS) + character(len=*), intent(in) :: key !< Name of the current field + character(len=1), intent(in) :: grid !< The grid on which the key field is defined + type(harmonic_analysis_CS), intent(inout) :: CS !< Control structure of the MOM_harmonic_analysis module + + ! Local variables + type(HA_type) :: ha1 !< Control structure for the current field + type(HA_node), pointer :: tmp !< A temporary list to hold the current field + + if (.not. CS%HAready) return + + allocate(tmp) + ha1%key = trim(key) + ha1%grid = trim(grid) + tmp%this = ha1 + tmp%next => CS%list + CS%list => tmp + CS%length = CS%length + 1 + +end subroutine HA_register + +!> This subroutine accumulates the temporal basis functions in FtF and FtSSH and then calls HA_write to compute +!! harmonic constants and write results. The tidal constituents are those used in MOM_tidal_forcing, plus the +!! mean (of zero frequency). For FtF, only the main diagonal and entries below it are calculated, which are needed +!! for Cholesky decomposition. +subroutine HA_accum(key, data, Time, G, CS) + character(len=*), intent(in) :: key !< Name of the current field + real, dimension(:,:), intent(in) :: data !< Input data of which harmonic analysis is to be performed [A] + type(time_type), intent(in) :: Time !< The current model time + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(harmonic_analysis_CS), intent(inout) :: CS !< Control structure of the MOM_harmonic_analysis module + + ! Local variables + type(HA_type), pointer :: ha1 + type(HA_node), pointer :: tmp + real :: now !< The relative time compared with the tidal reference [T ~> s] + real :: dt !< The current time step size of the accumulator [T ~> s] + real :: cosomegat, sinomegat, ccosomegat, ssinomegat !< The components of the phase [nondim] + integer :: nc, i, j, k, c, cc, icos, isin, iccos, issin, is, ie, js, je + character(len=128) :: mesg + + ! Exit the accumulator in the following cases + if (.not. CS%HAready) return + if (CS%length == 0) return + if (Time < CS%time_start) return + if (Time > CS%time_end) return + + ! Loop through the full list to find the current field + tmp => CS%list + do k=1,CS%length + ha1 => tmp%this + if (trim(key) == trim(ha1%key)) exit + tmp => tmp%next + if (k == CS%length) return !< Do not perform harmonic analysis of a field that is not registered + enddo + + nc = CS%nc + now = time_minus_signed(Time, CS%time_ref, scale=CS%US%s_to_T) + + !!! Additional processing at the initial accumulating step !!! + if (ha1%old_time < 0.0) then + ha1%old_time = now + + write(mesg,*) "MOM_harmonic_analysis: initializing accumulator, key = ", trim(ha1%key) + call MOM_error(NOTE, trim(mesg)) + + ! Get the lower and upper bounds of input data + ha1%is = LBOUND(data,1) ; is = ha1%is + ha1%ie = UBOUND(data,1) ; ie = ha1%ie + ha1%js = LBOUND(data,2) ; js = ha1%js + ha1%je = UBOUND(data,2) ; je = ha1%je + + allocate(ha1%ref(is:ie,js:je), source=0.0) + allocate(ha1%FtF(2*nc+1,2*nc+1), source=0.0) + allocate(ha1%FtSSH(is:ie,js:je,2*nc+1), source=0.0) + ha1%ref(:,:) = data(:,:) + endif + + dt = now - ha1%old_time + ha1%old_time = now !< Keep track of time so we know when Time approaches CS%time_end + + is = ha1%is ; ie = ha1%ie ; js = ha1%js ; je = ha1%je + + !!! Accumulator of FtF !!! + !< First entry, corresponding to the zero frequency constituent (mean) + ha1%FtF(1,1) = ha1%FtF(1,1) + 1.0 + + do c=1,nc + icos = 2*c + isin = 2*c+1 + cosomegat = CS%tide_fn(c) * cos(CS%freq(c) * now + (CS%phase0(c) + CS%tide_un(c))) + sinomegat = CS%tide_fn(c) * sin(CS%freq(c) * now + (CS%phase0(c) + CS%tide_un(c))) + + ! First column, corresponding to the zero frequency constituent (mean) + ha1%FtF(icos,1) = ha1%FtF(icos,1) + cosomegat + ha1%FtF(isin,1) = ha1%FtF(isin,1) + sinomegat + + do cc=1,c + iccos = 2*cc + issin = 2*cc+1 + ccosomegat = CS%tide_fn(cc) * cos(CS%freq(cc) * now + (CS%phase0(cc) + CS%tide_un(cc))) + ssinomegat = CS%tide_fn(cc) * sin(CS%freq(cc) * now + (CS%phase0(cc) + CS%tide_un(cc))) + + ! Interior of the matrix, corresponding to the products of cosine and sine terms + ha1%FtF(icos,iccos) = ha1%FtF(icos,iccos) + cosomegat * ccosomegat + ha1%FtF(icos,issin) = ha1%FtF(icos,issin) + cosomegat * ssinomegat + ha1%FtF(isin,iccos) = ha1%FtF(isin,iccos) + sinomegat * ccosomegat + ha1%FtF(isin,issin) = ha1%FtF(isin,issin) + sinomegat * ssinomegat + enddo ! cc=1,c + enddo ! c=1,nc + + !!! Accumulator of FtSSH !!! + !< First entry, corresponding to the zero frequency constituent (mean) + do j=js,je ; do i=is,ie + ha1%FtSSH(i,j,1) = ha1%FtSSH(i,j,1) + (data(i,j) - ha1%ref(i,j)) + enddo ; enddo + + !< The remaining entries + do c=1,nc + icos = 2*c + isin = 2*c+1 + cosomegat = CS%tide_fn(c) * cos(CS%freq(c) * now + (CS%phase0(c) + CS%tide_un(c))) + sinomegat = CS%tide_fn(c) * sin(CS%freq(c) * now + (CS%phase0(c) + CS%tide_un(c))) + do j=js,je ; do i=is,ie + ha1%FtSSH(i,j,icos) = ha1%FtSSH(i,j,icos) + (data(i,j) - ha1%ref(i,j)) * cosomegat + ha1%FtSSH(i,j,isin) = ha1%FtSSH(i,j,isin) + (data(i,j) - ha1%ref(i,j)) * sinomegat + enddo ; enddo + enddo ! c=1,nc + + !!! Compute harmonic constants and write output as Time approaches CS%time_end !!! + ! This guarantees that HA_write will be called before Time becomes larger than CS%time_end. + ! Result of subtracting time types is always >= 0, which is acceptable here. + if (time_to_real(CS%time_end - Time, scale=CS%US%s_to_T) <= dt) then + call HA_write(ha1, Time, G, CS) + + write(mesg,*) "MOM_harmonic_analysis: harmonic analysis done, key = ", trim(ha1%key) + call MOM_error(NOTE, trim(mesg)) + + ! De-register the current field and deallocate memory + ha1%key = 'none' + deallocate(ha1%ref) + deallocate(ha1%FtSSH) + endif + +end subroutine HA_accum + +!> This subroutine computes the harmonic constants and write output for the current field +subroutine HA_write(ha1, Time, G, CS) + type(HA_type), pointer, intent(in) :: ha1 !< Control structure for the current field + type(time_type), intent(in) :: Time !< The current model time + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(harmonic_analysis_CS), intent(in) :: CS !< Control structure of the MOM_harmonic_analysis module + + ! Local variables + real, dimension(:,:,:), allocatable :: FtSSHw !< An array containing the harmonic constants [A] + integer :: year, month, day, hour, minute, second + integer :: nc, i, j, k, is, ie, js, je + + character(len=255) :: filename !< Output file name + type(MOM_infra_file) :: cdf !< The file handle for output harmonic constants + type(vardesc), allocatable :: cdf_vars(:) !< Output variable names + type(MOM_field), allocatable :: cdf_fields(:) !< Field type variables for the output fields + + nc = CS%nc ; is = ha1%is ; ie = ha1%ie ; js = ha1%js ; je = ha1%je + + allocate(FtSSHw(is:ie,js:je,2*nc+1), source=0.0) + + ! Compute the harmonic coefficients + call HA_solver(ha1, nc, ha1%FtF, FtSSHw) + + ! Output file name + call get_date(Time, year, month, day, hour, minute, second) + write(filename, '(a,"HA_",a,i0.4,i0.2,i0.2,".nc")') & + trim(CS%path), trim(ha1%key), year, month, day + + allocate(cdf_vars(2*nc+1)) + allocate(cdf_fields(2*nc+1)) + + ! Variable names + cdf_vars(1) = var_desc("z0", "m" ,"mean value", ha1%grid, '1', '1') + do k=1,nc + cdf_vars(2*k ) = var_desc(trim(CS%const_name(k))//"cos", "m", "cosine coefficient", ha1%grid, '1', '1') + cdf_vars(2*k+1) = var_desc(trim(CS%const_name(k))//"sin", "m", "sine coefficient", ha1%grid, '1', '1') + enddo + + ! Create output file + call create_MOM_file(cdf, trim(filename), cdf_vars, & + 2*nc+1, cdf_fields, SINGLE_FILE, 86400.0, G=G) + + ! Add the initial field back to the mean state + do j=js,je ; do i=is,ie + FtSSHw(i,j,1) = FtSSHw(i,j,1) + ha1%ref(i,j) + enddo ; enddo + + ! Write data + call MOM_write_field(cdf, cdf_fields(1), G%domain, FtSSHw(:,:,1), 0.0) + do k=1,nc + call MOM_write_field(cdf, cdf_fields(2*k ), G%domain, FtSSHw(:,:,2*k ), 0.0) + call MOM_write_field(cdf, cdf_fields(2*k+1), G%domain, FtSSHw(:,:,2*k+1), 0.0) + enddo + + call cdf%flush() + deallocate(cdf_vars) + deallocate(cdf_fields) + deallocate(FtSSHw) + +end subroutine HA_write + +!> This subroutine computes the harmonic constants (stored in x) using the dot products of the temporal +!! basis functions accumulated in FtF, and the dot products of the SSH (or other fields) with the temporal basis +!! functions accumulated in FtSSH. The system is solved by Cholesky decomposition, +!! +!! FtF * x = FtSSH, => L * (L' * x) = FtSSH, => L * y = FtSSH, +!! +!! where L is the lower triangular matrix, y = L' * x, and x is the solution vector. +!! +subroutine HA_solver(ha1, nc, FtF, x) + type(HA_type), pointer, intent(in) :: ha1 !< Control structure for the current field + integer, intent(in) :: nc !< Number of harmonic constituents + real, dimension(:,:), intent(in) :: FtF !< Accumulator of (F' * F) for all fields [nondim] + real, dimension(ha1%is:ha1%ie,ha1%js:ha1%je,2*nc+1), & + intent(out) :: x !< Solution vector of harmonic constants [A] + + ! Local variables + real :: tmp0 !< Temporary variable for Cholesky decomposition [nondim] + real, dimension(2*nc+1,2*nc+1) :: L !< Lower triangular matrix of Cholesky decomposition [nondim] + real, dimension(2*nc+1) :: tmp1 !< Inverse of the diagonal entries of L [nondim] + real, dimension(ha1%is:ha1%ie,ha1%js:ha1%je) :: tmp2 !< 2D temporary array involving FtSSH [A] + real, dimension(ha1%is:ha1%ie,ha1%js:ha1%je,2*nc+1) :: y !< 3D temporary array, i.e., L' * x [A] + integer :: k, m, n + + ! Cholesky decomposition + do m=1,2*nc+1 + + ! First, calculate the diagonal entries + tmp0 = 0.0 + do k=1,m-1 ! This loop operates along the m-th row + tmp0 = tmp0 + L(m,k) * L(m,k) + enddo + L(m,m) = sqrt(FtF(m,m) - tmp0) ! This is the m-th diagonal entry + + ! Now calculate the off-diagonal entries + tmp1(m) = 1 / L(m,m) + do k=m+1,2*nc+1 ! This loop operates along the column below the m-th diagonal entry + tmp0 = 0.0 + do n=1,m-1 + tmp0 = tmp0 + L(k,n) * L(m,n) + enddo + L(k,m) = (FtF(k,m) - tmp0) * tmp1(m) ! This is the k-th off-diagonal entry below the m-th diagonal entry + enddo + enddo + + ! Solve for y from L * y = FtSSH + do k=1,2*nc+1 + tmp2(:,:) = 0.0 + do m=1,k-1 + tmp2(:,:) = tmp2(:,:) + L(k,m) * y(:,:,m) + enddo + y(:,:,k) = (ha1%FtSSH(:,:,k) - tmp2(:,:)) * tmp1(k) + enddo + + ! Solve for x from L' * x = y + do k=2*nc+1,1,-1 + tmp2(:,:) = 0.0 + do m=k+1,2*nc+1 + tmp2(:,:) = tmp2(:,:) + L(m,k) * x(:,:,m) + enddo + x(:,:,k) = (y(:,:,k) - tmp2(:,:)) * tmp1(k) + enddo + +end subroutine HA_solver + +!> \namespace harmonic_analysis +!! +!! Major revision (August, 2025) +!! +!! This module is now independent of MOM_tidal_forcing, providing more flexibility for performing harmonic analyses +!! on tidal constituents not available in MOM_tidal_forcing (e.g., MK3, M4), with the following conditions: +!! 1) For tidal constituents not available in MOM_tidal_forcing, the frequencies and equilibrium phases (if used) +!! must be specified manually in MOM_input. +!! 2) If any tidal constituents not available in MOM_tidal_forcing are used, the nodal modulation cannot be added. +!! Or, if nodal modulation is added, then harmonic analysis can only be performed on major tidal constituents. +!! +!! Original version (April, 2024) +!! +!! This module computes the harmonic constants which can be used to reconstruct the tidal elevation (or other +!! fields) through SSH = F * x, where F is an nt-by-2*nc matrix (nt is the number of time steps and nc is the +!! number of tidal constituents) containing the cosine/sine functions for each frequency evaluated at each time +!! step, and x is a 2*nc-by-1 vector containing the constant coefficients of the sine/cosine for each constituent +!! (i.e., the harmonic constants). At each grid point, the harmonic constants are computed using least squares, +!! +!! (F' * F) * x = F' * SSH_in, => FtF * x = FtSSH, +!! +!! where the prime denotes matrix transpose, and SSH_in is the sea surface height (or other fields) determined by +!! the model. The dot products (F' * F) and (F' * SSH_in) are computed by accumulating the sums as the model is +!! running and stored in the arrays FtF and FtSSH, respectively. The FtF matrix is inverted as needed before +!! computing and writing out the harmonic constants. +!! +!! Ed Zaron and William Xu (chengzhu.xu@oregonstate.edu) + +end module MOM_harmonic_analysis + diff --git a/src/diagnostics/MOM_obsolete_diagnostics.F90 b/src/diagnostics/MOM_obsolete_diagnostics.F90 index 86034292b5..77b7b863ce 100644 --- a/src/diagnostics/MOM_obsolete_diagnostics.F90 +++ b/src/diagnostics/MOM_obsolete_diagnostics.F90 @@ -1,9 +1,11 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Provides a mechanism for recording diagnostic variables that are no longer !! valid, along with their replacement name if appropriate. module MOM_obsolete_diagnostics -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_diag_mediator, only : diag_ctrl, found_in_diagtable use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : param_file_type, log_version, get_param @@ -52,7 +54,7 @@ subroutine register_obsolete_diagnostics(param_file, diag) if (diag_found(diag, 'KPP_dTdt', 'KPP_NLT_dTdt')) foundEntry = .true. if (diag_found(diag, 'KPP_dSdt', 'KPP_NLT_dSdt')) foundEntry = .true. - if (causeFatal) then; errType = FATAL + if (causeFatal) then ; errType = FATAL else ; errType = WARNING ; endif if (foundEntry .and. is_root_pe()) & call MOM_error(errType, 'MOM_obsolete_diagnostics: Obsolete diagnostics found in diag_table.') @@ -64,8 +66,6 @@ logical function diag_found(diag, varName, newVarName) type(diag_ctrl), intent(in) :: diag !< A structure used to control diagnostics. character(len=*), intent(in) :: varName !< The obsolete diagnostic name character(len=*), optional, intent(in) :: newVarName !< The valid name of this diagnostic - ! Local - integer :: handle ! Integer handle returned from diag_manager diag_found = found_in_diagtable(diag, varName) diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index dfadaa1da5..10807a9aca 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -1,7 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Methods for testing for, and list of, obsolete run-time parameters. module MOM_obsolete_params -! This file is part of MOM6. See LICENSE.md for the license. ! This module was first conceived and written by Robert Hallberg, July 2010. use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe @@ -23,8 +26,8 @@ subroutine find_obsolete_params(param_file) character(len=40) :: mdl = "find_obsolete_params" ! This module's name. ! This include declares and sets the variable "version". #include "version_variable.h" - integer :: test_int, l_seg, nseg - logical :: test_logic, test_logic2, test_logic3, split + integer :: l_seg, nseg + logical :: test_logic, split character(len=40) :: temp_string if (.not.is_root_pe()) return @@ -56,6 +59,7 @@ subroutine find_obsolete_params(param_file) hint="Instead use OBC_SEGMENT_xxx_VELOCITY_NUDGING_TIMESCALES.") enddo + call obsolete_logical(param_file, "CONVERT_THICKNESS_UNITS", .true.) call obsolete_logical(param_file, "MASK_MASSLESS_TRACERS", .false.) call obsolete_logical(param_file, "SALT_REJECT_BELOW_ML", .false.) @@ -71,6 +75,15 @@ subroutine find_obsolete_params(param_file) call obsolete_real(param_file, "VSTAR_SCALE_COEF") call obsolete_real(param_file, "ZSTAR_RIGID_SURFACE_THRESHOLD") + call obsolete_logical(param_file, "HENYEY_IGW_BACKGROUND_NEW") + + call obsolete_real(param_file, "SLIGHT_DZ_SURFACE") + call obsolete_int(param_file, "SLIGHT_NZ_SURFACE_FIXED") + call obsolete_real(param_file, "SLIGHT_SURFACE_AVG_DEPTH") + call obsolete_real(param_file, "SLIGHT_NLAY_TO_INTERIOR") + call obsolete_logical(param_file, "SLIGHT_FIX_HALOCLINES") + call obsolete_real(param_file, "HALOCLINE_FILTER_LENGTH") + call obsolete_real(param_file, "HALOCLINE_STRAT_TOL") ! Test for inconsistent parameter settings. split = .true. ; test_logic = .false. @@ -79,20 +92,86 @@ subroutine find_obsolete_params(param_file) if (test_logic .and. .not.split) call MOM_ERROR(FATAL, & "find_obsolete_params: #define DYNAMIC_SURFACE_PRESSURE is not yet "//& "implemented without #define SPLIT.") - + call obsolete_char(param_file, "CONTINUITY_SCHEME", warning_val="PPM", & + hint="Only one continuity scheme is available so this need not be specified.") call obsolete_real(param_file, "ETA_TOLERANCE_AUX", only_warn=.true.) call obsolete_real(param_file, "BT_MASS_SOURCE_LIMIT", 0.0) - + call obsolete_real(param_file, "FIRST_GUESS_SURFACE_LAYER_DEPTH") + call obsolete_logical(param_file, "CORRECT_SURFACE_LAYER_AVERAGE") call obsolete_int(param_file, "SEAMOUNT_LENGTH_SCALE", hint="Use SEAMOUNT_X_LENGTH_SCALE instead.") + call obsolete_int(param_file, "USE_LATERAL_BOUNDARY_DIFFUSION", & + hint="Use USE_HORIZONTAL_BOUNDARY_DIFFUSION instead.") call obsolete_logical(param_file, "MSTAR_FIXED", hint="Instead use MSTAR_MODE.") call obsolete_logical(param_file, "USE_VISBECK_SLOPE_BUG", .false.) + call obsolete_logical(param_file, "Use_PP81", hint="get_param is case sensitive so use USE_PP81.") call obsolete_logical(param_file, "ALLOW_CLOCKS_IN_OMP_LOOPS", .true.) call obsolete_logical(param_file, "LARGE_FILE_SUPPORT", .true.) call obsolete_real(param_file, "MIN_Z_DIAG_INTERVAL") call obsolete_char(param_file, "Z_OUTPUT_GRID_FILE") + call obsolete_logical(param_file, "CFL_BASED_TRUNCATIONS", .true.) + call obsolete_logical(param_file, "KD_BACKGROUND_VIA_KDML_BUG", .false.) + call obsolete_logical(param_file, "USE_DIABATIC_TIME_BUG", .false.) + + call read_param(param_file, "INTERPOLATE_SPONGE_TIME_SPACE", test_logic) + call obsolete_logical(param_file, "NEW_SPONGES", warning_val=test_logic, & + hint="Use INTERPOLATE_SPONGE_TIME_SPACE instead.") + + test_logic = .true. ; call read_param(param_file, "BOUND_KH", test_logic) + call obsolete_logical(param_file, "BETTER_BOUND_KH", warning_val=test_logic, hint="Use BOUND_KH alone.") + test_logic = .true. ; call read_param(param_file, "BOUND_AH", test_logic) + call obsolete_logical(param_file, "BETTER_BOUND_AH", warning_val=test_logic, hint="Use BOUND_AH alone.") + + test_logic = .false. ; call read_param(param_file, "UNSPLIT_DT_VISC_BUG", test_logic) + call obsolete_logical(param_file, "FIX_UNSPLIT_DT_VISC_BUG", warning_val=(.not.test_logic), & + hint="Use UNSPLIT_DT_VISC_BUG instead, but with the reversed meaning.") + + call obsolete_logical(param_file, "SMOOTH_RI", hint="Instead use N_SMOOTH_RI.") + + call obsolete_logical(param_file, "INTERNAL_TIDE_CORNER_ADVECT", .false.) + call obsolete_logical(param_file, "TIDE_USE_SAL_SCALAR", hint="Use SAL_SCALAR_APPROX instead.") + call obsolete_logical(param_file, "TIDAL_SAL_SHT", hint="Use SAL_HARMONICS instead.") + call obsolete_int(param_file, "TIDAL_SAL_SHT_DEGREE", hint="Use SAL_HARMONICS_DEGREE instead.") + call obsolete_real(param_file, "RHO_E", hint="Use RHO_SOLID_EARTH instead.") + call obsolete_logical(param_file, "DEFAULT_2018_ANSWERS", hint="Instead use DEFAULT_ANSWER_DATE.") + + call obsolete_logical(param_file, "SURFACE_FORCING_2018_ANSWERS", & + hint="Instead use SURFACE_FORCING_ANSWER_DATE.") + call obsolete_logical(param_file, "WIND_GYRES_2018_ANSWERS", & + hint="Instead use WIND_GYRES_ANSWER_DATE.") + + call obsolete_logical(param_file, "BAROTROPIC_2018_ANSWERS", & + hint="Instead use BAROTROPIC_ANSWER_DATE.") + call obsolete_logical(param_file, "EPBL_2018_ANSWERS", hint="Instead use EPBL_ANSWER_DATE.") + call obsolete_logical(param_file, "HOR_REGRID_2018_ANSWERS", & + hint="Instead use HOR_REGRID_ANSWER_DATE.") + call obsolete_logical(param_file, "HOR_VISC_2018_ANSWERS", & + hint="Instead use HOR_VISC_ANSWER_DATE.") + call obsolete_logical(param_file, "IDL_HURR_2018_ANSWERS", & + hint="Instead use IDL_HURR_ANSWER_DATE.") + call obsolete_logical(param_file, "MEKE_GEOMETRIC_2018_ANSWERS", & + hint="Instead use MEKE_GEOMETRIC_ANSWER_DATE.") + call obsolete_logical(param_file, "ODA_2018_ANSWERS", hint="Instead use ODA_ANSWER_DATE.") + call obsolete_logical(param_file, "OPTICS_2018_ANSWERS", hint="Instead use OPTICS_ANSWER_DATE.") + call obsolete_logical(param_file, "REGULARIZE_LAYERS_2018_ANSWERS", & + hint="Instead use REGULARIZE_LAYERS_ANSWER_DATE.") + call obsolete_logical(param_file, "REMAPPING_2018_ANSWERS", & + hint="Instead use REMAPPING_ANSWER_DATE.") + call obsolete_logical(param_file, "SET_DIFF_2018_ANSWERS", & + hint="Instead use SET_DIFF_ANSWER_DATE.") + call obsolete_logical(param_file, "SET_VISC_2018_ANSWERS", & + hint="Instead use SET_VISC_ANSWER_DATE.") + call obsolete_logical(param_file, "SURFACE_2018_ANSWERS", hint="Instead use SURFACE_ANSWER_DATE.") + call obsolete_logical(param_file, "TIDAL_MIXING_2018_ANSWERS", & + hint="Instead use TIDAL_MIXING_ANSWER_DATE.") + call obsolete_logical(param_file, "VERT_FRICTION_2018_ANSWERS", & + hint="Instead use VERT_FRICTION_ANSWER_DATE.") + + call obsolete_logical(param_file, "USE_GRID_SPACE_DIAGNOSTIC_AXES", & + hint="Instead use USE_INDEX_DIAGNOSTIC_AXIS.") + ! Write the file version number to the model log. call log_version(param_file, mdl, version) @@ -106,29 +185,15 @@ subroutine obsolete_logical(param_file, varname, warning_val, hint) character(len=*), optional, intent(in) :: hint !< A hint to the user about what to do. ! Local variables logical :: test_logic, fatal_err + logical :: var_is_set ! True if this value was read by read_param. character(len=128) :: hint_msg - test_logic = .false. ; call read_param(param_file, varname,test_logic) + test_logic = .false. ; call read_param(param_file, varname, test_logic, set=var_is_set) fatal_err = .true. - if (present(warning_val)) fatal_err = (warning_val .neqv. .true.) + if (var_is_set .and. present(warning_val)) fatal_err = (warning_val .neqv. test_logic) hint_msg = " " ; if (present(hint)) hint_msg = hint - if (test_logic) then - if (fatal_err) then - call MOM_ERROR(FATAL, "MOM_obsolete_params: "//trim(varname)// & - " is an obsolete run-time flag, and should not be used. "// & - trim(hint_msg)) - else - call MOM_ERROR(WARNING, "MOM_obsolete_params: "//trim(varname)// & - " is an obsolete run-time flag. "//trim(hint_msg)) - endif - endif - - test_logic = .true. ; call read_param(param_file, varname, test_logic) - fatal_err = .true. - if (present(warning_val)) fatal_err = (warning_val .neqv. .false.) - - if (.not.test_logic) then + if (var_is_set) then if (fatal_err) then call MOM_ERROR(FATAL, "MOM_obsolete_params: "//trim(varname)// & " is an obsolete run-time flag, and should not be used. "// & @@ -149,12 +214,13 @@ subroutine obsolete_char(param_file, varname, warning_val, hint) character(len=*), optional, intent(in) :: hint !< A hint to the user about what to do. ! Local variables character(len=200) :: test_string, hint_msg + logical :: var_is_set ! True if this value was read by read_param. logical :: only_warn - test_string = ''; call read_param(param_file, varname, test_string) + test_string = '' ; call read_param(param_file, varname, test_string, set=var_is_set) hint_msg = " " ; if (present(hint)) hint_msg = hint - if (len_trim(test_string) > 0) then + if (var_is_set) then only_warn = .false. if (present(warning_val)) then ! Check if test_string and warning_val are the same. if (len_trim(warning_val) == len_trim(test_string)) then @@ -184,15 +250,16 @@ subroutine obsolete_real(param_file, varname, warning_val, hint, only_warn) ! Local variables real :: test_val, warn_val + logical :: var_is_set ! True if this value was read by read_param. logical :: issue_warning character(len=128) :: hint_msg - test_val = -9e35; call read_param(param_file, varname, test_val) - warn_val = -9e35; if (present(warning_val)) warn_val = warning_val + test_val = -9e35 ; call read_param(param_file, varname, test_val, set=var_is_set) + warn_val = -9e35 ; if (present(warning_val)) warn_val = warning_val hint_msg = " " ; if (present(hint)) hint_msg = hint issue_warning = .false. ; if (present(only_warn)) issue_warning = only_warn - if (test_val /= -9e35) then + if (var_is_set) then if ((test_val == warn_val) .or. issue_warning) then call MOM_ERROR(WARNING, "MOM_obsolete_params: "//trim(varname)// & " is an obsolete run-time flag. "//trim(hint_msg)) @@ -211,14 +278,15 @@ subroutine obsolete_int(param_file, varname, warning_val, hint) integer, optional, intent(in) :: warning_val !< An allowed value that causes a warning instead of an error. character(len=*), optional, intent(in) :: hint !< A hint to the user about what to do. ! Local variables + logical :: var_is_set ! True if this value was read by read_param. integer :: test_val, warn_val character(len=128) :: hint_msg - test_val = -123456788; call read_param(param_file, varname, test_val) - warn_val = -123456788; if (present(warning_val)) warn_val = warning_val + test_val = -123456788 ; call read_param(param_file, varname, test_val, set=var_is_set) + warn_val = -123456788 ; if (present(warning_val)) warn_val = warning_val hint_msg = " " ; if (present(hint)) hint_msg = hint - if (test_val /= -123456788) then + if (var_is_set) then if (test_val == warn_val) then call MOM_ERROR(WARNING, "MOM_obsolete_params: "//trim(varname)// & " is an obsolete run-time flag. "//trim(hint_msg)) diff --git a/src/diagnostics/MOM_spatial_means.F90 b/src/diagnostics/MOM_spatial_means.F90 index ffbdc5f810..1d63334a23 100644 --- a/src/diagnostics/MOM_spatial_means.F90 +++ b/src/diagnostics/MOM_spatial_means.F90 @@ -1,15 +1,19 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Functions and routines to take area, volume, mass-weighted, layerwise, zonal or meridional means module MOM_spatial_means -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=) use MOM_coms, only : EFP_to_real, real_to_EFP, EFP_sum_across_PEs use MOM_coms, only : reproducing_sum, reproducing_sum_EFP, EFP_to_real use MOM_coms, only : query_EFP_overflow_error, reset_EFP_overflow_error +use MOM_coms, only : max_across_PEs, min_across_PEs use MOM_error_handler, only : MOM_error, NOTE, WARNING, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -17,53 +21,204 @@ module MOM_spatial_means #include public :: global_i_mean, global_j_mean -public :: global_area_mean, global_layer_mean +public :: global_area_mean, global_area_mean_u, global_area_mean_v, global_layer_mean public :: global_area_integral -public :: global_volume_mean, global_mass_integral +public :: global_volume_mean, global_mass_integral, global_mass_int_EFP public :: adjust_area_mean_to_zero +public :: array_global_min_max + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. +! The functions in this module work with variables with arbitrary units, in which case the +! arbitrary rescaled units are indicated with [A ~> a], while the unscaled units are just [a]. contains -!> Return the global area mean of a variable. This uses reproducing sums. -function global_area_mean(var, G, scale) +!> Return the global area mean of a variable, perhaps with a change of units. This uses reproducing sums. +function global_area_mean(var, G, scale, tmp_scale, unscale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G), SZJ_(G)), intent(in) :: var !< The variable to average - real, optional, intent(in) :: scale !< A rescaling factor for the variable + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: var !< The variable to average in arbitrary units [a], + !! or arbitrary rescaled units [A ~> a] if unscale + !! or tmp_scale is present + !! arbitrary, possibly rescaled units [A ~> a] + real, optional, intent(in) :: scale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the variable + !! that is reversed in the return value [a A-1 ~> 1], + !! or [b B-1 ~> 1] if unscale is also present. + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums, or + !! a factor converting between rescaled units if + !! tmp_scale is also present [B A-1 ~> b a-1]. + !! Here scale and unscale are synonymous, but unscale + !! is preferred and takes precedence. + real :: global_area_mean ! The mean of the variable in arbitrary unscaled units [a] or scaled units [A ~> a] + ! or [B ~> b], depending on which optional arguments are provided - real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming - real :: global_area_mean - - real :: scalefac ! An overall scaling factor for the areas and variable. + ! Local variables + ! In the following comments, [A ~> a] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums. + ! [A ~> a] and [B ~> b] are the same units unless tmp_scale and unscale are both present. + real :: tmpForSumming(SZI_(G),SZJ_(G)) ! An unscaled cell integral in [a L2 ~> a m2] or a + ! scaled cell integral in [A L2 ~> a m2] or [B L2 ~> b m2] + real :: scalefac ! A scaling factor for the variable that is not reversed [a A-1 ~> 1] or [B A-1 ~> b a-1] or [1] + real :: temp_scale ! A temporary scaling factor [a A-1 ~> 1] or [b B-1 ~> 1] or [1] integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - scalefac = G%US%L_to_m**2 ; if (present(scale)) scalefac = G%US%L_to_m**2*scale + temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale + + scalefac = 1.0 + if (present(unscale)) then ; scalefac = unscale + elseif (present(scale)) then ; scalefac = scale ; endif tmpForSumming(:,:) = 0. do j=js,je ; do i=is,ie tmpForSumming(i,j) = var(i,j) * (scalefac * G%areaT(i,j) * G%mask2dT(i,j)) enddo ; enddo - global_area_mean = reproducing_sum(tmpForSumming) * G%IareaT_global + + global_area_mean = reproducing_sum(tmpForSumming, unscale=temp_scale*G%US%L_to_m**2) * G%IareaT_global end function global_area_mean -!> Return the global area integral of a variable, by default using the masked area from the -!! grid, but an alternate could be used instead. This uses reproducing sums. -function global_area_integral(var, G, scale, area) +!> Return the global area mean of a variable. This uses reproducing sums. +function global_area_mean_v(var, G, tmp_scale) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: var !< The variable to average in arbitrary + !! units [a], or arbitrary rescaled units + !! [A ~> a] if tmp_scale is present + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that converts it back to unscaled + !! (e.g., mks) units to enable the use of the + !! reproducing sums [a A-1 ~> 1], but is reversed + !! before output so that the return value has + !! the same units as var + + real :: global_area_mean_v ! The mean of the variable in the same arbitrary units as var [A ~> a] + + ! Local variables + ! In the following comments, [A ~> a] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + ! [A ~> a] and [B ~> b] are the same unless tmp_scale and unscale are both present. + real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming ! An unscaled cell integral [A L2 ~> a m2] + real :: temp_scale ! A temporary scaling factor [a A-1 ~> 1] or [1] + integer :: i, j, is, ie, js, je, isB, ieB, jsB, jeB + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isB = G%iscB ; ieB = G%iecB ; jsB = G%jscB ; jeB = G%jecB + + temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale + + tmpForSumming(:,:) = 0. + do j=js,je ; do i=is,ie + tmpForSumming(i,j) = G%areaT(i,j) * & + (var(i,J) * G%mask2dCv(i,J) + var(i,J-1) * G%mask2dCv(i,J-1)) / & + max(1.e-20, G%mask2dCv(i,J)+G%mask2dCv(i,J-1)) + enddo ; enddo + global_area_mean_v = reproducing_sum(tmpForSumming, unscale=G%US%L_to_m**2*temp_scale) * G%IareaT_global + +end function global_area_mean_v + +!> Return the global area mean of a variable on U grid. This uses reproducing sums. +function global_area_mean_u(var, G, tmp_scale) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: var !< The variable to average in arbitrary + !! units [a], or arbitrary rescaled units + !! [A ~> a] if tmp_scale is present + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that converts it back to unscaled + !! (e.g., mks) units to enable the use of the + !! reproducing sums [a A-1 ~> 1], but is reversed + !! before output so that the return value has + !! the same units as var + real :: global_area_mean_u ! The mean of the variable in the same arbitrary units as var [A ~> a] + + ! Local variables + ! In the following comments, [A ~> a] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming ! An unscaled cell integral [A L2 ~> a m2] + real :: temp_scale ! A temporary scaling factor [a A-1 ~> 1] or [1] + integer :: i, j, is, ie, js, je, isB, ieB, jsB, jeB + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isB = G%iscB ; ieB = G%iecB ; jsB = G%jscB ; jeB = G%jecB + + temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale + + tmpForSumming(:,:) = 0. + do j=js,je ; do i=is,ie + tmpForSumming(i,j) = G%areaT(i,j) * & + (var(I,j) * G%mask2dCu(I,j) + var(I-1,j) * G%mask2dCu(I-1,j)) / & + max(1.e-20, G%mask2dCu(I,j)+G%mask2dCu(I-1,j)) + enddo ; enddo + global_area_mean_u = reproducing_sum(tmpForSumming, unscale=G%US%L_to_m**2*temp_scale) * G%IareaT_global + +end function global_area_mean_u + +!> Return the global area integral of a variable using reproducing sums, perhaps with a change of units. +!! By default the integral uses the masked area from the grid, but an alternate could be used instead. +!! The presence of the optional tmp_scale argument determines whether the returned value is in scaled +!! (if it is present) or unscaled units for both the variable itself and for the area in the integral. +function global_area_integral(var, G, scale, area, tmp_scale, unscale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: var !< The variable to integrate - real, optional, intent(in) :: scale !< A rescaling factor for the variable + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: var !< The variable to integrate in arbitrary units [a], + !! or arbitrary rescaled units [A ~> a] if unscale + !! or tmp_scale is present + real, optional, intent(in) :: scale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: area !< The alternate area to use, including - !! any required masking [L2 ~> m2]. - real :: global_area_integral !< The returned area integral, usually in the units of var times [m2]. + !! any required masking [L2 ~> m2]. + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the variable + !! that is reversed in the return value [a A-1 ~> 1], + !! or [b B-1 ~> 1] if unscale is also present. + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums, or + !! a factor converting between rescaled units if + !! tmp_scale is also present [B A-1 ~> b a-1]. + !! Here scale and unscale are synonymous, but unscale + !! is preferred and takes precedence if both are present. + real :: global_area_integral !< The returned area integral, usually in the units of var times an area, + !! [a m2] or [A L2 ~> a m2] or [B L2 ~> b m2], depending on which optional + !! arguments are provided ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming - real :: scalefac ! An overall scaling factor for the areas and variable. + ! In the following comments, [A ~> a] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums. + ! [A ~> a] and [B ~> b] are the same units unless tmp_scale and unscale are both present. + real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming ! An unscaled cell integral in [a m2] or + ! a scaled cell integral in [B L2 ~> b m2] or other units as indicated below + real :: scalefac ! An overall scaling factor for the areas and variable, in units of [a m2 A-1 L-2 ~> 1] + ! or [1] or [B m2 A-1 L-2 ~> b a-1] or [B A-1 ~> b a-1] depending on which + ! optional arguments are present. + !_______________________________________________________________________________________________ + ! Table of units of scalefac and tmpForSumming, depending on the presence of optional arguments | + !_______________________________________________________________________________________________| + ! present(tmp_scale) | present(unscale) | scalefac units | tmpForSumming units | + !____________________|__________________|_________________________|_____________________________! + ! True | True | [B A-1 ~> b a-1] | [B L2 ~> b m2] | + ! True | False | [1] | [A L2 ~> a m2] | + ! False | True | [a m2 A-1 L-2 ~> b a-1] | [a m2] | + ! False | False | [m2 L-2 ~> 1] | [a m2] | + !____________________|__________________|_________________________|_____________________________! + real :: temp_scale ! A temporary scaling factor [a m2 L-2 A-1 ~> 1] or [b m2 L-2 B-1 ~> 1] or [1] integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - scalefac = G%US%L_to_m**2 ; if (present(scale)) scalefac = G%US%L_to_m**2*scale + if (present(tmp_scale)) then + temp_scale = G%US%L_to_m**2 * tmp_scale ! Units of [a m2 A-1 L-2 ~> 1] or [b m2 B-1 L-2 ~> 1] + scalefac = 1.0 + else + temp_scale = 1.0 + scalefac = G%US%L_to_m**2 + endif + if (present(unscale)) then ; scalefac = scalefac * unscale + elseif (present(scale)) then ; scalefac = scalefac * scale ; endif tmpForSumming(:,:) = 0. if (present(area)) then @@ -75,112 +230,246 @@ function global_area_integral(var, G, scale, area) tmpForSumming(i,j) = var(i,j) * (scalefac * G%areaT(i,j) * G%mask2dT(i,j)) enddo ; enddo endif - global_area_integral = reproducing_sum(tmpForSumming) + + global_area_integral = reproducing_sum(tmpForSumming, unscale=temp_scale) end function global_area_integral !> Return the layerwise global thickness-weighted mean of a variable. This uses reproducing sums. -function global_layer_mean(var, h, G, GV, scale) +function global_layer_mean(var, h, G, GV, scale, tmp_scale, unscale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: var !< The variable to average + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: var !< The variable to average in arbitrary units [a], + !! or arbitrary rescaled units [A ~> a] if unscale + !! or tmp_scale is present real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, optional, intent(in) :: scale !< A rescaling factor for the variable - real, dimension(SZK_(GV)) :: global_layer_mean + real, optional, intent(in) :: scale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable for use in the reproducing sums + !! that is reversed in the return value [a A-1 ~> 1], + !! or [b B-1 ~> 1] if unscale is also present. + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums, or + !! a factor converting between rescaled units if + !! tmp_scale is also present [B A-1 ~> b a-1]. + !! Here scale and unscale are synonymous, but unscale + !! is preferred and takes precedence. + real, dimension(SZK_(GV)) :: global_layer_mean !< The mean of the variable in the arbitrary scaled [A ~> a] + !! or [B ~> b] or unscaled [a] units of var, depending on which + !! optional arguments are provided - real, dimension(G%isc:G%iec, G%jsc:G%jec, SZK_(GV)) :: tmpForSumming, weight - type(EFP_type), dimension(2*SZK_(GV)) :: laysums - real, dimension(SZK_(GV)) :: global_temp_scalar, global_weight_scalar - real :: scalefac ! A scaling factor for the variable. + ! Local variables + ! In the following comments, [A ~> a] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + real :: tmpForSumming(G%isc:G%iec,G%jsc:G%jec,SZK_(GV)) ! An unscaled cell integral in [L2 a m ~> a m3] or + ! [L2 a kg m-2 ~> a kg] or a scaled cell integral in + ! [L2 B m ~> b m3] or [L2 B m ~> b m3] or other units + ! as indicated the table below. + real :: weight(G%isc:G%iec,G%jsc:G%jec,SZK_(GV)) ! The volume or mass of each cell, depending on whether + ! the model is Boussinesq, used as a weight [L2 m ~> m3] + ! or [L2 kg m-2 ~> kg] + real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] or [B A-1 ~> b a-1] or [1] + !__________________________________________________________________________________________________ + ! Units of weight, scalefac and tmpForSumming, depending on the presence of optional arguments | + !_________________________________________________________________________________________________| + ! Boussinesq | tmp_scale | unscale | weight units | scalefac units | tmpForSumming units | + ! | present | present | | | | + !____________|___________|_________|___________________|__________________|_______________________! + ! True | True | True | [L2 m ~> m3] | [B A-1 ~> b a-1] | [B L2 m ~> b m3] | + ! True | True | False | [L2 m ~> m3] | [1] | [A L2 m ~> a m3] | + ! True | False | True | [L2 m ~> m3] | [a A-1 ~> 1] | [L2 a m ~> a m3] | + ! True | False | False | [L2 m ~> m3] | [1] | [L2 a m ~> a m3] | + ! False | True | True | [L2 kg m-2 ~> kg] | [B A-1 ~> b a-1] | [B L2 kg m-2 ~> b kg] | + ! False | True | False | [L2 kg m-2 ~> kg] | [1] | [A L2 kg m-2 ~> a kg] | + ! False | False | True | [L2 kg m-2 ~> kg] | [a A-1 ~> 1] | [L2 a kg m-2 ~> a kg] | + ! False | False | False | [L2 kg m-2 ~> kg] | [1] | [L2 a kg m-2 ~> a kg] | + !____________|___________|_________|___________________|__________________|_______________________! + type(EFP_type) :: laysums(2*SZK_(GV)) ! A vector of sums with heterogeneous meanings, with the first + ! half being the tracer integrals in [b m3] or [b kg] and the + ! second half being the summed weights in [m3] or [kg] + real :: global_temp_scalar ! The global integral of the tracer over all + ! layers [L2 a m ~> a m3] or [L2 a kg m-2 ~> a kg] + real :: global_weight_scalar ! The global integral of the volume or mass over all + ! layers [L2 m ~> m3] or [L2 kg m-2 ~> kg] + real :: temp_scale ! A temporary scaling factor [a A-1 ~> 1] or [b B-1 ~> 1] or [1] integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - scalefac = 1.0 ; if (present(scale)) scalefac = scale + temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale + + scalefac = 1.0 + if (present(unscale)) then ; scalefac = unscale + elseif (present(scale)) then ; scalefac = scale ; endif tmpForSumming(:,:,:) = 0. ; weight(:,:,:) = 0. do k=1,nz ; do j=js,je ; do i=is,ie - weight(i,j,k) = (GV%H_to_m * h(i,j,k)) * (G%US%L_to_m**2*G%areaT(i,j) * G%mask2dT(i,j)) + weight(i,j,k) = (GV%H_to_MKS * h(i,j,k)) * (G%areaT(i,j) * G%mask2dT(i,j)) tmpForSumming(i,j,k) = scalefac * var(i,j,k) * weight(i,j,k) enddo ; enddo ; enddo - global_temp_scalar = reproducing_sum(tmpForSumming, EFP_lay_sums=laysums(1:nz), only_on_PE=.true.) - global_weight_scalar = reproducing_sum(weight, EFP_lay_sums=laysums(nz+1:2*nz), only_on_PE=.true.) + global_temp_scalar = reproducing_sum(tmpForSumming, EFP_lay_sums=laysums(1:nz), only_on_PE=.true., & + unscale=temp_scale*G%US%L_to_m**2) + global_weight_scalar = reproducing_sum(weight, EFP_lay_sums=laysums(nz+1:2*nz), only_on_PE=.true., & + unscale=G%US%L_to_m**2) call EFP_sum_across_PEs(laysums, 2*nz) + ! Note that temp_scale appears in the denominator here because the variables returned via the + ! EFP_lay_sums arguments to reproducing sums stay in unscaled mks units. do k=1,nz - global_layer_mean(k) = EFP_to_real(laysums(k)) / EFP_to_real(laysums(nz+k)) + global_layer_mean(k) = EFP_to_real(laysums(k)) / (temp_scale*EFP_to_real(laysums(nz+k))) enddo end function global_layer_mean !> Find the global thickness-weighted mean of a variable. This uses reproducing sums. -function global_volume_mean(var, h, G, GV, scale) +function global_volume_mean(var, h, G, GV, scale, tmp_scale, unscale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: var !< The variable being averaged + intent(in) :: var !< The variable to average in arbitrary units [a], + !! or arbitrary rescaled units [A ~> a] if unscale + !! or tmp_scale is present real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, optional, intent(in) :: scale !< A rescaling factor for the variable - real :: global_volume_mean !< The thickness-weighted average of var + real, optional, intent(in) :: scale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the return value [a A-1 ~> 1], + !! or [b B-1 ~> 1] if unscale is also present. + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums, or + !! a factor converting between rescaled units if + !! tmp_scale is also present [B A-1 ~> b a-1]. + !! Here scale and unscale are synonymous, but unscale + !! is preferred and takes precedence if both are present. + real :: global_volume_mean !< The thickness-weighted average of var in the arbitrary scaled [A ~> a] or [B ~> b] or + !! unscaled [a] units of var, depending on which optional arguments are provided - real :: scalefac ! A scaling factor for the variable. - real :: weight_here - real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming, sum_weight + ! Local variables + ! In the following comments, [A ~> a] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + ! [A ~> a] and [B ~> b] are the same units unless tmp_scale and unscale are both present. + real :: temp_scale ! A temporary scaling factor [a A-1 ~> 1] or [b B-1 ~> 1] or [1] + real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] or [B A-1 ~> b a-1] or [1] + real :: weight_here ! The volume or mass of a grid cell [L2 m ~> m3] or [L2 kg m-2 ~> kg] + real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming ! The volume or mass integral of the variable in a column + ! [B L2 m ~> b m3] or [B L2 kg m-2 ~> b kg] or + ! [L2 a m ~> a m3] or [L2 a kg m-2 ~> a kg] + real, dimension(SZI_(G),SZJ_(G)) :: sum_weight ! The volume or mass of each column of water + ! [L2 m ~> m3] or [L2 kg m-2 ~> kg] integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - scalefac = 1.0 ; if (present(scale)) scalefac = scale + temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale + + scalefac = 1.0 + if (present(unscale)) then ; scalefac = unscale + elseif (present(scale)) then ; scalefac = scale ; endif tmpForSumming(:,:) = 0. ; sum_weight(:,:) = 0. do k=1,nz ; do j=js,je ; do i=is,ie - weight_here = (GV%H_to_m * h(i,j,k)) * (G%US%L_to_m**2*G%areaT(i,j) * G%mask2dT(i,j)) + weight_here = (GV%H_to_MKS * h(i,j,k)) * (G%areaT(i,j) * G%mask2dT(i,j)) tmpForSumming(i,j) = tmpForSumming(i,j) + scalefac * var(i,j,k) * weight_here sum_weight(i,j) = sum_weight(i,j) + weight_here enddo ; enddo ; enddo - global_volume_mean = (reproducing_sum(tmpForSumming)) / & - (reproducing_sum(sum_weight)) + global_volume_mean = (reproducing_sum(tmpForSumming, unscale=temp_scale*G%US%L_to_m**2)) / & + (reproducing_sum(sum_weight, unscale=G%US%L_to_m**2)) end function global_volume_mean -!> Find the global mass-weighted integral of a variable. This uses reproducing sums. -function global_mass_integral(h, G, GV, var, on_PE_only, scale) +!> Find the global mass-weighted integral of a variable. The presence of the optional tmp_scale +!! argument determines whether the returned value is in scaled (if it is present) or unscaled units +!! for both the variable itself and for the mass in the integral. This function uses reproducing sums. +function global_mass_integral(h, G, GV, var, on_PE_only, scale, tmp_scale, unscale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - optional, intent(in) :: var !< The variable being integrated - logical, optional, intent(in) :: on_PE_only !< If present and true, the sum is only - !! done on the local PE, and it is _not_ order invariant. - real, optional, intent(in) :: scale !< A rescaling factor for the variable - real :: global_mass_integral !< The mass-weighted integral of var (or 1) in - !! kg times the units of var - - real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming - real :: scalefac ! An overall scaling factor for the areas and variable. - logical :: global_sum + optional, intent(in) :: var !< The variable to integrate in arbitrary units [a], + !! or arbitrary rescaled units [A ~> a] if unscale + !! or tmp_scale is present + logical, optional, intent(in) :: on_PE_only !< If present and true, the sum is only done + !! on the local PE, and it is _not_ order invariant. + real, optional, intent(in) :: scale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the variable + !! that is reversed in the return value [a A-1 ~> 1], + !! or [b B-1 ~> 1] if unscale is also present. + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums, or + !! a factor converting between rescaled units if + !! tmp_scale is also present [B A-1 ~> b a-1]. + !! Here scale and unscale are synonymous, but unscale + !! is preferred and takes precedence if both are present. + real :: global_mass_integral !< The mass-weighted integral of var (or 1) in kg times the arbitrary + !! units of var [kg a] or in [R Z L2 A ~> kg a] if tmp_scale is present + !! or [R Z L2 B ~> kg b] if both unscale and tmp_scale are present + + ! Local variables + ! In the following comments, [A ~> a] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + ! [A ~> a] and [B ~> b] are the same units unless tmp_scale and unscale are both present. + real :: tmpForSumming(SZI_(G),SZJ_(G)) ! The mass-weighted integral of the variable in a column in + ! [kg a] or [kg] or if tmp_scale is present in [B R Z L2 ~> kg b] or + ! [A R Z L2 !> kg m] or [R Z L2 ~> kg] + real :: scalefac ! An overall scaling factor for the cell mass and variable in [a kg A-1 R-1 Z-1 L-2 ~> 1] + ! or [kg R-1 Z-1 L-2 ~> 1] or [1] or [B A-1 ~> b a-1] if tmp_scale is present. + real :: temp_scale ! A temporary scaling factor [1] or if tmp_scale is present this could be in + ! [kg a R-1 Z-1 L-2 A-1 ~> 1] or [kg b R-1 Z-1 L-2 B-1 ~> 1] or [kg R-1 Z-1 L-2 ~> 1] + !_______________________________________________________________________________________ + ! Units of scalefac and tmpForSumming, depending on the presence of optional arguments | + !______________________________________________________________________________________| + ! var | tmp_scale | unscale | scalefac units | tmpForSumming units | + ! present | present | present | | | + !_________|___________|_________|_____________________________|________________________! + ! True | True | True | [B A-1 ~> b a-1] | [B R Z L2 ~> b kg] | + ! True | True | False | [1] | [A R Z L2 ~> a kg] | + ! True | False | True | [a kg A-1 R-1 Z-1 L-2 ~> 1] | [a kg] | + ! True | False | False | [kg R-1 Z-1 L-2 ~> 1] | [a kg] | + ! False | True | either | [1] | [R Z L2 ~> kg] | + ! False | False | either | [kg R-1 Z-1 L-2 ~> 1] | [kg] | + !_________|___________|_________|_____________________________|________________________! + logical :: global_sum ! If true do the sum globally, but if false only do the sum on the current PE. integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - scalefac = G%US%L_to_m**2 ; if (present(scale)) scalefac = G%US%L_to_m**2*scale - tmpForSumming(:,:) = 0.0 + if (present(tmp_scale)) then + temp_scale = G%US%RZL2_to_kg * tmp_scale + if (.not.present(var)) temp_scale = G%US%RZL2_to_kg + scalefac = 1.0 + else + temp_scale = 1.0 + scalefac = G%US%RZL2_to_kg + endif + if (present(var)) then + if (present(unscale)) then ; scalefac = scalefac * unscale + elseif (present(scale)) then ; scalefac = scalefac * scale ; endif + endif + tmpForSumming(:,:) = 0.0 if (present(var)) then do k=1,nz ; do j=js,je ; do i=is,ie tmpForSumming(i,j) = tmpForSumming(i,j) + var(i,j,k) * & - ((GV%H_to_kg_m2 * h(i,j,k)) * (scalefac*G%areaT(i,j) * G%mask2dT(i,j))) + ((GV%H_to_RZ * h(i,j,k)) * (scalefac*G%areaT(i,j) * G%mask2dT(i,j))) enddo ; enddo ; enddo else do k=1,nz ; do j=js,je ; do i=is,ie tmpForSumming(i,j) = tmpForSumming(i,j) + & - ((GV%H_to_kg_m2 * h(i,j,k)) * (scalefac*G%areaT(i,j) * G%mask2dT(i,j))) + ((GV%H_to_RZ * h(i,j,k)) * (scalefac*G%areaT(i,j) * G%mask2dT(i,j))) enddo ; enddo ; enddo endif global_sum = .true. ; if (present(on_PE_only)) global_sum = .not.on_PE_only if (global_sum) then - global_mass_integral = reproducing_sum(tmpForSumming) + global_mass_integral = reproducing_sum(tmpForSumming, unscale=temp_scale) else global_mass_integral = 0.0 do j=js,je ; do i=is,ie @@ -190,34 +479,104 @@ function global_mass_integral(h, G, GV, var, on_PE_only, scale) end function global_mass_integral +!> Find the global mass-weighted order invariant integral of a variable in mks units, +!! returning the value as an EFP_type. This uses reproducing sums. +function global_mass_int_EFP(h, G, GV, var, on_PE_only, scale, unscale) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: var !< The variable to integrate in arbitrary units [a], + !! or arbitrary rescaled units [A ~> a] if unscale + !! is present + logical, optional, intent(in) :: on_PE_only !< If present and true, the sum is only done + !! on the local PE, but it is still order invariant. + real, optional, intent(in) :: scale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums. + !! Here scale and unscale are synonymous, but unscale + !! is preferred and takes precedence if both are present. + type(EFP_type) :: global_mass_int_EFP !< The mass-weighted integral of var (or 1) in + !! kg times the arbitrary units of var [kg a] + + ! Local variables + ! In the following comments, [A ~> a] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + real :: tmpForSum(SZI_(G),SZJ_(G)) ! The mass-weighted integral of the variable in a column [kg a] or [kg] + real :: scalefac ! An overall scaling factor for the cell mass and variable [a kg A-1 H-1 L-2 ~> kg m-3 or 1] + integer :: i, j, k, is, ie, js, je, nz, isr, ier, jsr, jer + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isr = is - (G%isd-1) ; ier = ie - (G%isd-1) ; jsr = js - (G%jsd-1) ; jer = je - (G%jsd-1) + + scalefac = GV%H_to_kg_m2 * G%US%L_to_m**2 + if (present(unscale)) then ; scalefac = unscale * scalefac + elseif (present(scale)) then ; scalefac = scale * scalefac ; endif + + tmpForSum(:,:) = 0.0 + if (present(var)) then + do k=1,nz ; do j=js,je ; do i=is,ie + tmpForSum(i,j) = tmpForSum(i,j) + var(i,j,k) * & + ((scalefac * h(i,j,k)) * (G%areaT(i,j) * G%mask2dT(i,j))) + enddo ; enddo ; enddo + else + do k=1,nz ; do j=js,je ; do i=is,ie + tmpForSum(i,j) = tmpForSum(i,j) + & + ((scalefac * h(i,j,k)) * (G%areaT(i,j) * G%mask2dT(i,j))) + enddo ; enddo ; enddo + endif + + global_mass_int_EFP = reproducing_sum_EFP(tmpForSum, isr, ier, jsr, jer, only_on_PE=on_PE_only) + +end function global_mass_int_EFP + !> Determine the global mean of a field along rows of constant i, returning it !! in a 1-d array using the local indexing. This uses reproducing sums. -subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable being averaged - real, dimension(SZJ_(G)), intent(out) :: i_mean !< Global mean of array along its i-axis +subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale, unscale) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable to integrate in arbitrary units [a], + !! or arbitrary rescaled units [A ~> a] if unscale + !! is present + real, dimension(SZJ_(G)), intent(out) :: i_mean !< Global mean of array along its i-axis [a] or [A ~> a] real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(in) :: mask !< An array used for weighting the i-mean - real, optional, intent(in) :: scale !< A rescaling factor for the output variable + optional, intent(in) :: mask !< An array used for weighting the i-mean [nondim] + real, optional, intent(in) :: scale !< A rescaling factor for the output variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums real, optional, intent(in) :: tmp_scale !< A rescaling factor for the internal - !! calculations that is removed from the output + !! calculations that is removed from the output [a A-1 ~> 1] + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums. + !! Here scale and unscale are synonymous, but unscale + !! is preferred and takes precedence if both are present. ! Local variables - type(EFP_type), allocatable, dimension(:) :: asum, mask_sum - real :: scalefac ! A scaling factor for the variable. - real :: unscale ! A factor for undoing any internal rescaling before output. - real :: mask_sum_r + ! In the following comments, [A ~> a] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + type(EFP_type), allocatable, dimension(:) :: asum ! The masked sum of the variable in each row [a] + type(EFP_type), allocatable, dimension(:) :: mask_sum ! The sum of the mask values in each row [nondim] + real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] + real :: rescale ! A factor for redoing any internal rescaling before output [A a-1 ~> 1] + real :: mask_sum_r ! The sum of the mask values in a row [nondim] integer :: is, ie, js, je, idg_off, jdg_off integer :: i, j is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec idg_off = G%idg_offset ; jdg_off = G%jdg_offset - scalefac = 1.0 ; if (present(scale)) scalefac = scale - unscale = 1.0 + scalefac = 1.0 + if (present(unscale)) then ; scalefac = unscale + elseif (present(scale)) then ; scalefac = scale ; endif + + rescale = 1.0 if (present(tmp_scale)) then ; if (tmp_scale /= 0.0) then - scalefac = scalefac * tmp_scale ; unscale = 1.0 / tmp_scale + scalefac = scalefac * tmp_scale ; rescale = 1.0 / tmp_scale endif ; endif call reset_EFP_overflow_error() @@ -229,7 +588,7 @@ subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale) asum(j) = real_to_EFP(0.0) ; mask_sum(j) = real_to_EFP(0.0) enddo - do i=is,ie ; do j=js,je + do j=js,je ; do i=is,ie asum(j+jdg_off) = asum(j+jdg_off) + real_to_EFP(scalefac*array(i,j)*mask(i,j)) mask_sum(j+jdg_off) = mask_sum(j+jdg_off) + real_to_EFP(mask(i,j)) enddo ; enddo @@ -254,7 +613,7 @@ subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale) else do j=G%jsg,G%jeg ; asum(j) = real_to_EFP(0.0) ; enddo - do i=is,ie ; do j=js,je + do j=js,je ; do i=is,ie asum(j+jdg_off) = asum(j+jdg_off) + real_to_EFP(scalefac*array(i,j)) enddo ; enddo @@ -271,7 +630,7 @@ subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale) enddo endif - if (unscale /= 1.0) then ; do j=js,je ; i_mean(j) = unscale*i_mean(j) ; enddo ; endif + if (rescale /= 1.0) then ; do j=js,je ; i_mean(j) = rescale*i_mean(j) ; enddo ; endif deallocate(asum) @@ -279,31 +638,46 @@ end subroutine global_i_mean !> Determine the global mean of a field along rows of constant j, returning it !! in a 1-d array using the local indexing. This uses reproducing sums. -subroutine global_j_mean(array, j_mean, G, mask, scale, tmp_scale) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable being averaged - real, dimension(SZI_(G)), intent(out) :: j_mean !< Global mean of array along its j-axis +subroutine global_j_mean(array, j_mean, G, mask, scale, tmp_scale, unscale) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable to integrate in arbitrary units [a], + !! or arbitrary rescaled units [A ~> a] if unscale + !! is present + real, dimension(SZI_(G)), intent(out) :: j_mean !< Global mean of array along its j-axis [a] or [A ~> a] real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(in) :: mask !< An array used for weighting the j-mean - real, optional, intent(in) :: scale !< A rescaling factor for the output variable + optional, intent(in) :: mask !< An array used for weighting the j-mean [nondim] + real, optional, intent(in) :: scale !< A rescaling factor for the output variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums real, optional, intent(in) :: tmp_scale !< A rescaling factor for the internal - !! calculations that is removed from the output + !! calculations that is removed from the output [a A-1 ~> 1] + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums. + !! Here scale and unscale are synonymous, but unscale + !! is preferred and takes precedence if both are present. ! Local variables - type(EFP_type), allocatable, dimension(:) :: asum, mask_sum - real :: mask_sum_r - real :: scalefac ! A scaling factor for the variable. - real :: unscale ! A factor for undoing any internal rescaling before output. + ! In the following comments, [A ~> a] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + type(EFP_type), allocatable, dimension(:) :: asum ! The masked sum of the variable in each row [a] + type(EFP_type), allocatable, dimension(:) :: mask_sum ! The sum of the mask values in each row [nondim] + real :: mask_sum_r ! The sum of the mask values in a row [nondim] + real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] + real :: rescale ! A factor for redoing any internal rescaling before output [A a-1 ~> 1] integer :: is, ie, js, je, idg_off, jdg_off integer :: i, j is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec idg_off = G%idg_offset ; jdg_off = G%jdg_offset - scalefac = 1.0 ; if (present(scale)) scalefac = scale - unscale = 1.0 + scalefac = 1.0 + if (present(unscale)) then ; scalefac = unscale + elseif (present(scale)) then ; scalefac = scale ; endif + + rescale = 1.0 if (present(tmp_scale)) then ; if (tmp_scale /= 0.0) then - scalefac = scalefac * tmp_scale ; unscale = 1.0 / tmp_scale + scalefac = scalefac * tmp_scale ; rescale = 1.0 / tmp_scale endif ; endif call reset_EFP_overflow_error() @@ -357,42 +731,57 @@ subroutine global_j_mean(array, j_mean, G, mask, scale, tmp_scale) enddo endif - if (unscale /= 1.0) then ; do i=is,ie ; j_mean(i) = unscale*j_mean(i) ; enddo ; endif + if (rescale /= 1.0) then ; do i=is,ie ; j_mean(i) = rescale*j_mean(i) ; enddo ; endif deallocate(asum) end subroutine global_j_mean !> Adjust 2d array such that area mean is zero without moving the zero contour -subroutine adjust_area_mean_to_zero(array, G, scaling, unit_scale) +subroutine adjust_area_mean_to_zero(array, G, scaling, unit_scale, unscale) type(ocean_grid_type), intent(in) :: G !< Grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: array !< 2D array to be adjusted - real, optional, intent(out) :: scaling !< The scaling factor used - real, optional, intent(in) :: unit_scale !< A rescaling factor for the variable + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: array !< 2D array to be adjusted in arbitrary units [a], + !! or arbitrary rescaled units [A ~> a] if unscale + !! is present + real, optional, intent(out) :: scaling !< The scaling factor used [nondim] + real, optional, intent(in) :: unit_scale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums + real, optional, intent(in) :: unscale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums. + !! Here unit_scale and unscale are synonymous, but unscale + !! is preferred and takes precedence if both are present. ! Local variables - real, dimension(G%isc:G%iec, G%jsc:G%jec) :: posVals, negVals, areaXposVals, areaXnegVals + ! In the following comments, [A ~> a] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + real :: posVals(G%isc:G%iec, G%jsc:G%jec) ! The positive values in a cell or 0 [A ~> a] + real :: negVals(G%isc:G%iec, G%jsc:G%jec) ! The negative values in a cell or 0 [A ~> a] + real :: areaXposVals(G%isc:G%iec, G%jsc:G%jec) ! The cell area integral of the positive values [L2 A ~> m2 a] + real :: areaXnegVals(G%isc:G%iec, G%jsc:G%jec) ! The cell area integral of the negative values [L2 A ~> m2 a] + type(EFP_type), dimension(2) :: areaInt_EFP ! An EFP version integral of the values on the current PE [m2 a] + real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] + real :: areaIntPosVals, areaIntNegVals ! The global area integral of the positive and negative values [m2 a] + real :: posScale, negScale ! The scaling factor to apply to positive or negative values [nondim] integer :: i,j - type(EFP_type), dimension(2) :: areaInt_EFP - real :: scalefac ! A scaling factor for the variable. - real :: I_scalefac ! The Adcroft reciprocal of scalefac - real :: areaIntPosVals, areaIntNegVals, posScale, negScale - scalefac = 1.0 ; if (present(unit_scale)) scalefac = unit_scale - I_scalefac = 0.0 ; if (scalefac /= 0.0) I_scalefac = 1.0 / scalefac + scalefac = 1.0 + if (present(unscale)) then ; scalefac = unscale + elseif (present(unit_scale)) then ; scalefac = unit_scale ; endif ! areaXposVals(:,:) = 0. ! This zeros out halo points. ! areaXnegVals(:,:) = 0. ! This zeros out halo points. do j=G%jsc,G%jec ; do i=G%isc,G%iec - posVals(i,j) = max(0., scalefac*array(i,j)) - areaXposVals(i,j) = G%US%L_to_m**2*G%areaT(i,j) * posVals(i,j) - negVals(i,j) = min(0., scalefac*array(i,j)) - areaXnegVals(i,j) = G%US%L_to_m**2*G%areaT(i,j) * negVals(i,j) + posVals(i,j) = max(0., array(i,j)) + areaXposVals(i,j) = G%areaT(i,j) * posVals(i,j) + negVals(i,j) = min(0., array(i,j)) + areaXnegVals(i,j) = G%areaT(i,j) * negVals(i,j) enddo ; enddo ! Combining the sums like this avoids separate blocking global sums. - areaInt_EFP(1) = reproducing_sum_EFP( areaXposVals, only_on_PE=.true. ) - areaInt_EFP(2) = reproducing_sum_EFP( areaXnegVals, only_on_PE=.true. ) + areaInt_EFP(1) = reproducing_sum_EFP( areaXposVals, only_on_PE=.true., unscale=scalefac*G%US%L_to_m**2 ) + areaInt_EFP(2) = reproducing_sum_EFP( areaXnegVals, only_on_PE=.true., unscale=scalefac*G%US%L_to_m**2 ) call EFP_sum_across_PEs(areaInt_EFP, 2) areaIntPosVals = EFP_to_real( areaInt_EFP(1) ) areaIntNegVals = EFP_to_real( areaInt_EFP(2) ) @@ -402,12 +791,12 @@ subroutine adjust_area_mean_to_zero(array, G, scaling, unit_scale) if (areaIntPosVals>-areaIntNegVals) then ! Scale down positive values posScale = - areaIntNegVals / areaIntPosVals do j=G%jsc,G%jec ; do i=G%isc,G%iec - array(i,j) = ((posScale * posVals(i,j)) + negVals(i,j)) * I_scalefac + array(i,j) = (posScale * posVals(i,j)) + negVals(i,j) enddo ; enddo elseif (areaIntPosVals<-areaIntNegVals) then ! Scale down negative values negScale = - areaIntPosVals / areaIntNegVals do j=G%jsc,G%jec ; do i=G%isc,G%iec - array(i,j) = (posVals(i,j) + (negScale * negVals(i,j))) * I_scalefac + array(i,j) = posVals(i,j) + (negScale * negVals(i,j)) enddo ; enddo endif endif @@ -415,4 +804,192 @@ subroutine adjust_area_mean_to_zero(array, G, scaling, unit_scale) end subroutine adjust_area_mean_to_zero + +!> Find the global maximum and minimum of a tracer array and return the locations of the extrema. +!! When there multiple cells with the same extreme values, the reported locations are from the +!! uppermost layer where they occur, and then from the logically northernmost and then eastermost +!! such location on the unrotated version of the grid within that layer. Only ocean points (as +!! indicated by a positive value of G%mask2dT) are evaluated, and if there are no ocean points +!! anywhere in the domain, the reported extrema and their locations are all returned as 0. +subroutine array_global_min_max(tr_array, G, nk, g_min, g_max, & + xgmin, ygmin, zgmin, xgmax, ygmax, zgmax, unscale) + integer, intent(in) :: nk !< The number of vertical levels + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G),nk), intent(in) :: tr_array !< The tracer array to search for + !! extrema in arbitrary concentration units [CU ~> conc] + real, intent(out) :: g_min !< The global minimum of tr_array, either in + !! the same units as tr_array [CU ~> conc] or in + !! unscaled units if unscale is present [conc] + real, intent(out) :: g_max !< The global maximum of tr_array, either in + !! the same units as tr_array [CU ~> conc] or in + !! unscaled units if unscale is present [conc] + real, optional, intent(out) :: xgmin !< The x-position of the global minimum in the + !! units of G%geoLonT, often [degrees_E] or [km] or [m] + real, optional, intent(out) :: ygmin !< The y-position of the global minimum in the + !! units of G%geoLatT, often [degrees_N] or [km] or [m] + real, optional, intent(out) :: zgmin !< The z-position of the global minimum [layer] + real, optional, intent(out) :: xgmax !< The x-position of the global maximum in the + !! units of G%geoLonT, often [degrees_E] or [km] or [m] + real, optional, intent(out) :: ygmax !< The y-position of the global maximum in the + !! units of G%geoLatT, often [degrees_N] or [km] or [m] + real, optional, intent(out) :: zgmax !< The z-position of the global maximum [layer] + real, optional, intent(in) :: unscale !< A factor to use to undo any scaling of + !! the input tracer array [conc CU-1 ~> 1] + + ! Local variables + real :: tmax, tmin ! Maximum and minimum tracer values, in the same units as tr_array [CU ~> conc] + integer :: ijk_min_max(2) ! Integers encoding the global grid positions of the global minimum and maximum values + real :: xyz_min_max(6) ! A single array with the x-, y- and z-positions of the minimum and + ! maximum values in units that vary between the array elements [various] + logical :: valid_PE ! True if there are any valid points on the local PE. + logical :: find_location ! If true, report the locations of the extrema + integer :: ijk_loc_max ! An integer encoding the global grid position of the maximum tracer value on this PE + integer :: ijk_loc_min ! An integer encoding the global grid position of the minimum tracer value on this PE + integer :: ijk_loc_here ! An integer encoding the global grid position of the current grid point + integer :: itmax, jtmax, ktmax, itmin, jtmin, ktmin + integer :: i, j, k, isc, iec, jsc, jec + + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + + find_location = (present(xgmin) .or. present(ygmin) .or. present(zgmin) .or. & + present(xgmax) .or. present(ygmax) .or. present(zgmax)) + + ! The initial values set here are never used if there are any valid points. + tmax = -huge(tmax) ; tmin = huge(tmin) + + if (find_location) then + ! Find the maximum and minimum tracer values on this PE and their locations. + valid_PE = .false. + itmax = 0 ; jtmax = 0 ; ktmax = 0 ; ijk_loc_max = 0 + itmin = 0 ; jtmin = 0 ; ktmin = 0 ; ijk_loc_min = 0 + do k=1,nk ; do j=jsc,jec ; do i=isc,iec ; if (G%mask2dT(i,j) > 0.0) then + valid_PE = .true. + if (tr_array(i,j,k) > tmax) then + tmax = tr_array(i,j,k) + itmax = i ; jtmax = j ; ktmax = k + ijk_loc_max = ijk_loc(i, j, k, nk, G%HI) + elseif ((tr_array(i,j,k) == tmax) .and. (k <= ktmax)) then + ijk_loc_here = ijk_loc(i, j, k, nk, G%HI) + if (ijk_loc_here > ijk_loc_max) then + itmax = i ; jtmax = j ; ktmax = k + ijk_loc_max = ijk_loc_here + endif + endif + if (tr_array(i,j,k) < tmin) then + tmin = tr_array(i,j,k) + itmin = i ; jtmin = j ; ktmin = k + ijk_loc_min = ijk_loc(i, j, k, nk, G%HI) + elseif ((tr_array(i,j,k) == tmin) .and. (k <= ktmin)) then + ijk_loc_here = ijk_loc(i, j, k, nk, G%HI) + if (ijk_loc_here > ijk_loc_min) then + itmin = i ; jtmin = j ; ktmin = k + ijk_loc_min = ijk_loc_here + endif + endif + endif ; enddo ; enddo ; enddo + else + ! Only the maximum and minimum values are needed, and not their positions. + do k=1,nk ; do j=jsc,jec ; do i=isc,iec ; if (G%mask2dT(i,j) > 0.0) then + if (tr_array(i,j,k) > tmax) tmax = tr_array(i,j,k) + if (tr_array(i,j,k) < tmin) tmin = tr_array(i,j,k) + endif ; enddo ; enddo ; enddo + endif + + ! Find the global maximum and minimum tracer values. + g_max = tmax ; g_min = tmin + call max_across_PEs(g_max) + call min_across_PEs(g_min) + + if (find_location) then + if (g_max < g_min) then + ! This only occurs if there are no unmasked points anywhere in the domain. + xyz_min_max(:) = 0.0 + else + ! Find the global indices of the maximum and minimum locations. This can + ! occur on multiple PEs. + ijk_min_max(1:2) = 0 + if (valid_PE) then + if (g_min == tmin) ijk_min_max(1) = ijk_loc_min + if (g_max == tmax) ijk_min_max(2) = ijk_loc_max + endif + ! If MOM6 supported taking maxima on arrays of integers, these could be combined as: + ! call max_across_PEs(ijk_min_max, 2) + call max_across_PEs(ijk_min_max(1)) + call max_across_PEs(ijk_min_max(2)) + + ! Set the positions of the extrema if they occur on this PE. This will only + ! occur on a single PE. + xyz_min_max(1:6) = -huge(xyz_min_max) ! These huge negative values are never selected by max_across_PEs. + if (valid_PE) then + if (ijk_min_max(1) == ijk_loc_min) then + xyz_min_max(1) = G%geoLonT(itmin,jtmin) + xyz_min_max(2) = G%geoLatT(itmin,jtmin) + xyz_min_max(3) = real(ktmin) + endif + if (ijk_min_max(2) == ijk_loc_max) then + xyz_min_max(4) = G%geoLonT(itmax,jtmax) + xyz_min_max(5) = G%geoLatT(itmax,jtmax) + xyz_min_max(6) = real(ktmax) + endif + endif + + call max_across_PEs(xyz_min_max, 6) + endif + + if (present(xgmin)) xgmin = xyz_min_max(1) + if (present(ygmin)) ygmin = xyz_min_max(2) + if (present(zgmin)) zgmin = xyz_min_max(3) + if (present(xgmax)) xgmax = xyz_min_max(4) + if (present(ygmax)) ygmax = xyz_min_max(5) + if (present(zgmax)) zgmax = xyz_min_max(6) + endif + + if (g_max < g_min) then + ! There are no unmasked points anywhere in the domain. + g_max = 0.0 ; g_min = 0.0 + endif + + if (present(unscale)) then + ! Rescale g_min and g_max, perhaps changing their units from [CU ~> conc] to [conc] + g_max = unscale * g_max + g_min = unscale * g_min + endif + +end subroutine array_global_min_max + +! Return a positive integer encoding the rotationally invariant global position of a tracer cell +function ijk_loc(i, j, k, nk, HI) + integer, intent(in) :: i !< Local i-index + integer, intent(in) :: j !< Local j-index + integer, intent(in) :: k !< Local k-index + integer, intent(in) :: nk !< Range of k-index, used to pick out a low-k position. + type(hor_index_type), intent(in) :: HI !< Horizontal index ranges + integer :: ijk_loc ! An integer encoding the cell position in the global grid. + + ! Local variables + integer :: ig, jg ! Global index values with a global computational domain start value of 1. + integer :: ij_loc ! The encoding of the horizontal position + integer :: qturns ! The number of counter-clockwise quarter turns of the grid that have to be undone + + ! These global i-grid positions run from 1 to HI%niglobal, and analogously for jg. + ig = i + HI%idg_offset + (1 - HI%isg) + jg = j + HI%jdg_offset + (1 - HI%jsg) + + ! Compensate for the rotation of the model grid to give a rotationally invariant encoding. + qturns = modulo(HI%turns, 4) + if (qturns == 0) then + ij_loc = ig + HI%niglobal * jg + elseif (qturns == 1) then + ij_loc = jg + HI%njglobal * ((HI%niglobal+1)-ig) + elseif (qturns == 2) then + ij_loc = ((HI%niglobal+1)-ig) + HI%niglobal * ((HI%njglobal+1)-jg) + elseif (qturns == 3) then + ij_loc = ((HI%njglobal+1)-jg) + HI%njglobal * ig + endif + + ijk_loc = ij_loc + (HI%niglobal*HI%njglobal) * (nk-k) + +end function ijk_loc + + end module MOM_spatial_means diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 668c297658..8da4627378 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -1,26 +1,31 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Reports integrated quantities for monitoring the model state module MOM_sum_output -! This file is part of MOM6. See LICENSE.md for the license. - use iso_fortran_env, only : int64 -use MOM_coms, only : sum_across_PEs, PE_here, root_PE, num_PEs, max_across_PEs, field_chksum +use MOM_checksums, only : is_NaN, field_checksum +use MOM_coms, only : sum_across_PEs, PE_here, root_PE, num_PEs, max_across_PEs use MOM_coms, only : reproducing_sum, reproducing_sum_EFP, EFP_to_real, real_to_EFP use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=), EFP_sum_across_PEs -use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe, MOM_mesg +use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE, is_root_pe use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type use MOM_interface_heights, only : find_eta -use MOM_io, only : create_file, file_type, fieldtype, flush_file, reopen_file, close_file -use MOM_io, only : file_exists, slasher, vardesc, var_desc, write_field, MOM_write_field +use MOM_io, only : create_MOM_file, reopen_MOM_file +use MOM_io, only : MOM_infra_file, MOM_netcdf_file, MOM_field +use MOM_io, only : file_exists, slasher, vardesc, var_desc, MOM_write_field use MOM_io, only : field_size, read_variable, read_attribute, open_ASCII_file, stdout use MOM_io, only : axis_info, set_axis_info, delete_axis_info, get_filename_appendix use MOM_io, only : attribute_info, set_attribute_info, delete_attribute_info use MOM_io, only : APPEND_FILE, SINGLE_FILE, WRITEONLY_FILE -use MOM_time_manager, only : time_type, get_time, get_date, set_time, operator(>) +use MOM_spatial_means, only : array_global_min_max +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 @@ -108,23 +113,32 @@ module MOM_sum_output !! of calls to write_energy and revert to the standard !! energysavedays interval - real :: timeunit !< The length of the units for the time axis [s]. + real :: timeunit !< The length of the units for the time axis and certain input parameters + !! including ENERGYSAVEDAYS [s]. + logical :: date_stamped_output !< If true, use dates (not times) in messages to stdout. + logical :: ISO_date_stamped_output !< If true, use ISO formatted dates in messages to stdout. type(time_type) :: Start_time !< The start time of the simulation. ! Start_time is set in MOM_initialization.F90 integer, pointer :: ntrunc => NULL() !< The number of times the velocity has been !! truncated since the last call to write_energy. real :: max_Energy !< The maximum permitted energy per unit mass. If there is - !! more energy than this, the model should stop [m2 s-2]. + !! more energy than this, the model should stop [L2 T-2 ~> m2 s-2]. integer :: maxtrunc !< The number of truncations per energy save !! interval at which the run is stopped. logical :: write_stocks !< If true, write the integrated tracer amounts !! to stdout when the energy files are written. + logical :: write_min_max !< If true, write the maximum and minimum values of temperature, + !! salinity and some tracer concentrations to stdout when the energy + !! files are written. + logical :: write_min_max_loc !< If true, write the locations of the maximum and minimum values + !! of temperature, salinity and some tracer concentrations to stdout + !! when the energy files are written. integer :: previous_calls = 0 !< The number of times write_energy has been called. integer :: prev_n = 0 !< The value of n from the last call. - type(file_type) :: fileenergy_nc !< The file handle for the netCDF version of the energy file. + type(MOM_netcdf_file) :: fileenergy_nc !< The file handle for the netCDF version of the energy file. integer :: fileenergy_ascii !< The unit number of the ascii version of the energy file. - type(fieldtype), dimension(NUM_FIELDS+MAX_FIELDS_) :: & + type(MOM_field), dimension(NUM_FIELDS+MAX_FIELDS_) :: & fields !< fieldtype variables for the output fields. character(len=200) :: energyfile !< The name of the energy file with path. end type sum_output_CS @@ -147,13 +161,12 @@ subroutine MOM_sum_output_init(G, GV, US, param_file, directory, ntrnc, & type(Sum_output_CS), pointer :: CS !< A pointer that is set to point to the !! control structure for this module. ! Local variables - real :: Time_unit ! The time unit in seconds for ENERGYSAVEDAYS [s] - real :: maxvel ! The maximum permitted velocity [m s-1] + real :: maxvel ! The maximum permitted velocity [L T-1 ~> m s-1] ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_sum_output" ! This module's name. character(len=200) :: energyfile ! The name of the energy file. - character(len=32) :: filename_appendix = '' !fms appendix to filename for ensemble runs + character(len=32) :: filename_appendix = '' ! FMS appendix to filename for ensemble runs if (associated(CS)) then call MOM_error(WARNING, "MOM_sum_output_init called with associated control structure.") @@ -176,6 +189,15 @@ subroutine MOM_sum_output_init(G, GV, US, param_file, directory, ntrnc, & call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) + call get_param(param_file, mdl, "WRITE_TRACER_MIN_MAX", CS%write_min_max, & + "If true, write the maximum and minimum values of temperature, salinity and "//& + "some tracer concentrations to stdout when the energy files are written.", & + default=.false., do_not_log=.not.CS%write_stocks, debuggingParam=.true.) + call get_param(param_file, mdl, "WRITE_TRACER_MIN_MAX_LOC", CS%write_min_max_loc, & + "If true, write the locations of the maximum and minimum values of "//& + "temperature, salinity and some tracer concentrations to stdout when the "//& + "energy files are written.", & + default=.false., do_not_log=.not.CS%write_min_max, debuggingParam=.true.) call get_param(param_file, mdl, "DT", CS%dt_in_T, & "The (baroclinic) dynamics time step.", & units="s", scale=US%s_to_T, fail_if_missing=.true.) @@ -190,13 +212,14 @@ subroutine MOM_sum_output_init(G, GV, US, param_file, directory, ntrnc, & "The maximum permitted average energy per unit mass; the "//& "model will be stopped if there is more energy than "//& "this. If zero or negative, this is set to 10*MAXVEL^2.", & - units="m2 s-2", default=0.0) + units="m2 s-2", default=0.0, scale=US%m_s_to_L_T**2) if (CS%max_Energy <= 0.0) then call get_param(param_file, mdl, "MAXVEL", maxvel, & "The maximum velocity allowed before the velocity "//& - "components are truncated.", units="m s-1", default=3.0e8) + "components are truncated.", units="m s-1", default=3.0e8, scale=US%m_s_to_L_T) CS%max_Energy = 10.0 * maxvel**2 - call log_param(param_file, mdl, "MAX_ENERGY as used", CS%max_Energy) + call log_param(param_file, mdl, "MAX_ENERGY as used", CS%max_Energy, & + units="m2 s-2", unscale=US%L_T_to_m_s**2) endif call get_param(param_file, mdl, "ENERGYFILE", energyfile, & @@ -218,13 +241,15 @@ subroutine MOM_sum_output_init(G, GV, US, param_file, directory, ntrnc, & call get_param(param_file, mdl, "DATE_STAMPED_STDOUT", CS%date_stamped_output, & "If true, use dates (not times) in messages to stdout", & default=.true.) + call get_param(param_file, mdl, "ISO_DATE_STAMPED_STDOUT", CS%ISO_date_stamped_output, & + "If true, use ISO formatted dates in messages to stdout", & + default=.false.) + ! Note that the units of CS%Timeunit are the MKS units of [s]. call get_param(param_file, mdl, "TIMEUNIT", CS%Timeunit, & "The time unit in seconds a number of input fields", & units="s", default=86400.0) if (CS%Timeunit < 0.0) CS%Timeunit = 86400.0 - - if (CS%do_APE_calc) then call get_param(param_file, mdl, "READ_DEPTH_LIST", CS%read_depth_list, & "Read the depth list from a file if it exists or "//& @@ -257,18 +282,15 @@ subroutine MOM_sum_output_init(G, GV, US, param_file, directory, ntrnc, & CS%DL%listsize = 1 endif - call get_param(param_file, mdl, "TIMEUNIT", Time_unit, & - "The time unit for ENERGYSAVEDAYS.", & - units="s", default=86400.0) call get_param(param_file, mdl, "ENERGYSAVEDAYS",CS%energysavedays, & "The interval in units of TIMEUNIT between saves of the "//& "energies of the run and other globally summed diagnostics.",& - default=set_time(0,days=1), timeunit=Time_unit) + default=set_time(0,days=1), timeunit=CS%Timeunit) call get_param(param_file, mdl, "ENERGYSAVEDAYS_GEOMETRIC",CS%energysavedays_geometric, & "The starting interval in units of TIMEUNIT for the first call "//& "to save the energies of the run and other globally summed diagnostics. "//& "The interval increases by a factor of 2. after each call to write_energy.",& - default=set_time(seconds=0), timeunit=Time_unit) + default=set_time(seconds=0), timeunit=CS%Timeunit) if ((time_type_to_real(CS%energysavedays_geometric) > 0.) .and. & (CS%energysavedays_geometric < CS%energysavedays)) then @@ -322,45 +344,39 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci ! Local variables real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! The height of interfaces [Z ~> m]. real :: areaTm(SZI_(G),SZJ_(G)) ! A masked version of areaT [L2 ~> m2]. - real :: KE(SZK_(GV)) ! The total kinetic energy of a layer [J]. - real :: PE(SZK_(GV)+1)! The available potential energy of an interface [J]. - real :: KE_tot ! The total kinetic energy [J]. - real :: PE_tot ! The total available potential energy [J]. + real :: KE(SZK_(GV)) ! The total kinetic energy of a layer [R Z L4 T-2 ~> J] + real :: PE(SZK_(GV)+1)! The available potential energy of an interface [R Z L4 T-2 ~> J] + real :: KE_tot ! The total kinetic energy [R Z L4 T-2 ~> J]. + real :: PE_tot ! The total available potential energy [R Z L4 T-2 ~> J]. real :: Z_0APE(SZK_(GV)+1) ! The uniform depth which overlies the same ! volume as is below an interface [Z ~> m]. - real :: H_0APE(SZK_(GV)+1) ! A version of Z_0APE, converted to m, usually positive. - real :: toten ! The total kinetic & potential energies of - ! all layers [J] (i.e. kg m2 s-2). + real :: toten ! The total kinetic & potential energies of all layers [R Z L4 T-2 ~> J] real :: En_mass ! The total kinetic and potential energies divided by - ! the total mass of the ocean [m2 s-2]. + ! the total mass of the ocean [L2 T-2 ~> m2 s-2]. real :: vol_lay(SZK_(GV)) ! The volume of fluid in a layer [Z L2 ~> m3]. real :: volbelow ! The volume of all layers beneath an interface [Z L2 ~> m3]. - real :: mass_lay(SZK_(GV)) ! The mass of fluid in a layer [kg]. - real :: mass_tot ! The total mass of the ocean [kg]. - real :: vol_tot ! The total ocean volume [m3]. + real :: mass_lay(SZK_(GV)) ! The mass of fluid in a layer [R Z L2 ~> kg] + real :: mass_tot ! The total mass of the ocean [R Z L2 ~> kg] + real :: vol_tot ! The total ocean volume [Z L2 ~> m3] real :: mass_chg ! The change in total ocean mass of fresh water since - ! the last call to this subroutine [kg]. + ! the last call to this subroutine [R Z L2 ~> kg] real :: mass_anom ! The change in fresh water that cannot be accounted for - ! by the surface fluxes [kg]. - real :: Salt ! The total amount of salt in the ocean [ppt kg]. + ! by the surface fluxes [R Z L2 ~> kg] + real :: Salt ! The total amount of salt in the ocean [1e-3 R Z L2 ~> g Salt] real :: Salt_chg ! The change in total ocean salt since the last call - ! to this subroutine [ppt kg]. + ! to this subroutine [1e-3 R Z L2 ~> g Salt] real :: Salt_anom ! The change in salt that cannot be accounted for by - ! the surface fluxes [ppt kg]. + ! the surface fluxes [1e-3 R Z L2 ~> g Salt] real :: salin ! The mean salinity of the ocean [ppt]. - real :: salin_chg ! The change in total salt since the last call - ! to this subroutine divided by total mass [ppt]. real :: salin_anom ! The change in total salt that cannot be accounted for by ! the surface fluxes divided by total mass [ppt]. - real :: Heat ! The total amount of Heat in the ocean [J]. - real :: Heat_chg ! The change in total ocean heat since the last call to this subroutine [J]. - real :: Heat_anom ! The change in heat that cannot be accounted for by the surface fluxes [J]. - real :: temp ! The mean potential temperature of the ocean [degC]. - real :: temp_chg ! The change in total heat divided by total heat capacity - ! of the ocean since the last call to this subroutine, degC. + real :: Heat ! The total amount of Heat in the ocean [Q R Z L2 ~> J] + real :: Heat_chg ! The change in total ocean heat since the last call to this subroutine [Q R Z L2 ~> J] + real :: Heat_anom ! The change in heat that cannot be accounted for by the surface fluxes [Q R Z L2 ~> J] + real :: temp ! The mean potential temperature of the ocean [C ~> degC] real :: temp_anom ! The change in total heat that cannot be accounted for ! by the surface fluxes, divided by the total heat - ! capacity of the ocean [degC]. + ! capacity of the ocean [C ~> degC] real :: hint ! The deviation of an interface from H [Z ~> m]. real :: hbot ! 0 if the basin is deeper than H, or the ! height of the basin depth over H otherwise [Z ~> m]. @@ -385,38 +401,75 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci real :: CFL_lin ! A simpler definition of the CFL number [nondim]. real :: max_CFL(2) ! The maxima of the CFL numbers [nondim]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & - tmp1 ! A temporary array + tmp1 ! A temporary array used in reproducing sums [various] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & - PE_pt ! The potential energy at each point [J]. + PE_pt ! The potential energy at each point [R Z L4 T-2 ~> J]. real, dimension(SZI_(G),SZJ_(G)) :: & - Temp_int, Salt_int ! Layer and cell integrated heat and salt [J] and [g Salt]. - real :: HL2_to_kg ! A conversion factor from a thickness-volume to mass [kg H-1 L-2 ~> kg m-3 or 1] - real :: KE_scale_factor ! The combination of unit rescaling factors in the kinetic energy - ! calculation [kg T2 H-1 L-2 s-2 ~> kg m-3 or 1] - real :: PE_scale_factor ! The combination of unit rescaling factors in the potential energy - ! calculation [kg T2 R-1 Z-1 L-2 s-2 ~> 1] + Temp_int, Salt_int ! Layer and cell integrated heat and salt [Q R Z L2 ~> J] and [1e-3 R Z L2 ~> g Salt]. + real :: RZL4_T2_to_J ! The combination of unit rescaling factors to convert the spatially integrated + ! kinetic or potential energies into mks units [T2 kg m2 R-1 Z-1 L-4 s-2 ~> 1] + real :: QRZL2_to_J ! The combination of unit rescaling factors to convert integrated heat + ! content into mks units [J Q-1 R-1 Z-1 L-2 ~> 1] + real :: J_to_QRZL2 ! The combination of unit rescaling factors to rescale integrated heat + ! content from mks units into the internal units of MOM6 [Q R Z L2 J-1 ~> 1] + real :: kg_to_RZL2 ! The combination of unit rescaling factors to rescale masses from + ! mks units into the internal units of MOM6 [R Z L2 kg-1 ~> 1] + real :: salt_to_kg ! A factor used to rescale salt contents [kg R-1 Z-1 L-2 ~> nondim] integer :: num_nc_fields ! The number of fields that will actually go into ! the NetCDF file. - integer :: i, j, k, is, ie, js, je, ns, nz, m, Isq, Ieq, Jsq, Jeq, isr, ier, jsr, jer + integer :: i, j, k, is, ie, js, je, nz, m, Isq, Ieq, Jsq, Jeq, isr, ier, jsr, jer integer :: li, lbelow, labove ! indices of deep_area_vol, used to find Z_0APE. ! lbelow & labove are lower & upper limits for li ! in the search for the entry in lH to use. integer :: start_of_day, num_days - real :: reday, var + real :: reday ! Time in units given by CS%Timeunit, but often [days] character(len=240) :: energypath_nc character(len=200) :: mesg - character(len=32) :: mesg_intro, time_units, day_str, n_str, date_str - logical :: date_stamped + character(len=32) :: mesg_intro, time_units, day_str, n_str, date_str, ISO_date_str + logical :: date_stamped, ISO_date_stamped type(time_type) :: dt_force ! A time_type version of the forcing timestep. - real :: Tr_stocks(MAX_FIELDS_) ! The total amounts of each of the registered tracers - real :: Tr_min(MAX_FIELDS_) ! The global minimum unmasked value of the tracers - real :: Tr_max(MAX_FIELDS_) ! The global maximum unmasked value of the tracers + + real :: S_min ! The global minimum unmasked value of the salinity [ppt] + real :: S_max ! The global maximum unmasked value of the salinity [ppt] + real :: S_min_x ! The x-positions of the global salinity minima + ! in the units of G%geoLonT, often [degrees_E] or [km] + real :: S_min_y ! The y-positions of the global salinity minima + ! in the units of G%geoLatT, often [degrees_N] or [km] + real :: S_min_z ! The z-positions of the global salinity minima [layer] + real :: S_max_x ! The x-positions of the global salinity maxima + ! in the units of G%geoLonT, often [degrees_E] or [km] + real :: S_max_y ! The y-positions of the global salinity maxima + ! in the units of G%geoLatT, often [degrees_N] or [km] + real :: S_max_z ! The z-positions of the global salinity maxima [layer] + + real :: T_min ! The global minimum unmasked value of the temperature [degC] + real :: T_max ! The global maximum unmasked value of the temperature [degC] + real :: T_min_x ! The x-positions of the global temperature minima + ! in the units of G%geoLonT, often [degrees_E] or [km] + real :: T_min_y ! The y-positions of the global temperature minima + ! in the units of G%geoLatT, often [degrees_N] or [km] + real :: T_min_z ! The z-positions of the global temperature minima [layer] + real :: T_max_x ! The x-positions of the global temperature maxima + ! in the units of G%geoLonT, often [degrees_E] or [km] + real :: T_max_y ! The y-positions of the global temperature maxima + ! in the units of G%geoLatT, often [degrees_N] or [km] + real :: T_max_z ! The z-positions of the global temperature maxima [layer] + + + ! The units of the tracer stock vary between tracers, with [conc] given explicitly by Tr_units. + real :: Tr_stocks(MAX_FIELDS_) ! The total amounts of each of the registered tracers [kg conc] + real :: Tr_min(MAX_FIELDS_) ! The global minimum unmasked value of the tracers [conc] + real :: Tr_max(MAX_FIELDS_) ! The global maximum unmasked value of the tracers [conc] real :: Tr_min_x(MAX_FIELDS_) ! The x-positions of the global tracer minima + ! in the units of G%geoLonT, often [degrees_E] or [km] real :: Tr_min_y(MAX_FIELDS_) ! The y-positions of the global tracer minima - real :: Tr_min_z(MAX_FIELDS_) ! The z-positions of the global tracer minima + ! in the units of G%geoLatT, often [degrees_N] or [km] + real :: Tr_min_z(MAX_FIELDS_) ! The z-positions of the global tracer minima [layer] real :: Tr_max_x(MAX_FIELDS_) ! The x-positions of the global tracer maxima + ! in the units of G%geoLonT, often [degrees_E] or [km] real :: Tr_max_y(MAX_FIELDS_) ! The y-positions of the global tracer maxima - real :: Tr_max_z(MAX_FIELDS_) ! The z-positions of the global tracer maxima + ! in the units of G%geoLatT, often [degrees_N] or [km] + real :: Tr_max_z(MAX_FIELDS_) ! The z-positions of the global tracer maxima [layer] logical :: Tr_minmax_avail(MAX_FIELDS_) ! A flag indicating whether the global minimum and ! maximum information are available for each of the tracers character(len=40), dimension(MAX_FIELDS_) :: & @@ -444,7 +497,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 @@ -461,34 +514,38 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci endif endif + RZL4_T2_to_J = US%RZL2_to_kg*US%L_T_to_m_s**2 ! Used to unscale energies + QRZL2_to_J = US%RZL2_to_kg*US%Q_to_J_kg ! Used to unscale heat contents + salt_to_kg = 0.001*US%RZL2_to_kg ! Used to unscale salt contents + kg_to_RZL2 = US%kg_m3_to_R*US%m_to_Z*US%m_to_L**2 ! Used to scale masses + J_to_QRZL2 = US%J_kg_to_Q*kg_to_RZL2 ! Used to scale heat contents + num_nc_fields = 17 if (.not.CS%use_temperature) num_nc_fields = 11 vars(1) = var_desc("Ntrunc","Nondim","Number of Velocity Truncations",'1','1') - vars(2) = var_desc("En","Joules","Total Energy",'1','1') - vars(3) = var_desc("APE","Joules","Total Interface APE",'1','i') - vars(4) = var_desc("KE","Joules","Total Layer KE",'1','L') - vars(5) = var_desc("H0","meter","Zero APE Depth of Interface",'1','i') - vars(6) = var_desc("Mass_lay","kg","Total Layer Mass",'1','L') - vars(7) = var_desc("Mass","kg","Total Mass",'1','1') - vars(8) = var_desc("Mass_chg","kg","Total Mass Change between Entries",'1','1') - vars(9) = var_desc("Mass_anom","kg","Anomalous Total Mass Change",'1','1') + vars(2) = var_desc("En","Joules","Total Energy",'1','1', conversion=RZL4_T2_to_J) + vars(3) = var_desc("APE","Joules","Total Interface APE",'1','i', conversion=RZL4_T2_to_J) + vars(4) = var_desc("KE","Joules","Total Layer KE",'1','L', conversion=RZL4_T2_to_J) + vars(5) = var_desc("H0","meter","Zero APE Depth of Interface",'1','i', conversion=US%Z_to_m) + vars(6) = var_desc("Mass_lay","kg","Total Layer Mass",'1','L', conversion=US%RZL2_to_kg) + vars(7) = var_desc("Mass","kg","Total Mass",'1','1', conversion=US%RZL2_to_kg) + vars(8) = var_desc("Mass_chg","kg","Total Mass Change between Entries",'1','1', conversion=US%RZL2_to_kg) + vars(9) = var_desc("Mass_anom","kg","Anomalous Total Mass Change",'1','1', conversion=US%RZL2_to_kg) vars(10) = var_desc("max_CFL_trans","Nondim","Maximum finite-volume CFL",'1','1') vars(11) = var_desc("max_CFL_lin","Nondim","Maximum finite-difference CFL",'1','1') if (CS%use_temperature) then - vars(12) = var_desc("Salt","kg","Total Salt",'1','1') - vars(13) = var_desc("Salt_chg","kg","Total Salt Change between Entries",'1','1') - vars(14) = var_desc("Salt_anom","kg","Anomalous Total Salt Change",'1','1') - vars(15) = var_desc("Heat","Joules","Total Heat",'1','1') - vars(16) = var_desc("Heat_chg","Joules","Total Heat Change between Entries",'1','1') - vars(17) = var_desc("Heat_anom","Joules","Anomalous Total Heat Change",'1','1') + vars(12) = var_desc("Salt","kg","Total Salt",'1','1', conversion=salt_to_kg) + vars(13) = var_desc("Salt_chg","kg","Total Salt Change between Entries",'1','1', conversion=salt_to_kg) + vars(14) = var_desc("Salt_anom","kg","Anomalous Total Salt Change",'1','1', conversion=salt_to_kg) + vars(15) = var_desc("Heat","Joules","Total Heat",'1','1', conversion=QRZL2_to_J) + vars(16) = var_desc("Heat_chg","Joules","Total Heat Change between Entries",'1','1', conversion=QRZL2_to_J) + vars(17) = var_desc("Heat_anom","Joules","Anomalous Total Heat Change",'1','1', conversion=QRZL2_to_J) endif is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB isr = is - (G%isd-1) ; ier = ie - (G%isd-1) ; jsr = js - (G%jsd-1) ; jer = je - (G%jsd-1) - HL2_to_kg = GV%H_to_kg_m2*US%L_to_m**2 - if (.not.associated(CS)) call MOM_error(FATAL, & "write_energy: Module must be initialized before it is used.") @@ -499,44 +556,40 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci areaTm(i,j) = G%mask2dT(i,j)*G%areaT(i,j) enddo ; enddo - if (GV%Boussinesq) then - tmp1(:,:,:) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - tmp1(i,j,k) = h(i,j,k) * (HL2_to_kg*areaTm(i,j)) - enddo ; enddo ; enddo + tmp1(:,:,:) = 0.0 + do k=1,nz ; do j=js,je ; do i=is,ie + tmp1(i,j,k) = h(i,j,k) * (GV%H_to_RZ*areaTm(i,j)) + enddo ; enddo ; enddo + mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=mass_lay, EFP_sum=mass_EFP, unscale=US%RZL2_to_kg) - mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=mass_lay, EFP_sum=mass_EFP) - do k=1,nz ; vol_lay(k) = (US%m_to_L**2*GV%H_to_Z/GV%H_to_kg_m2)*mass_lay(k) ; enddo + if (GV%Boussinesq) then + do k=1,nz ; vol_lay(k) = (1.0 / GV%Rho0) * mass_lay(k) ; enddo else - tmp1(:,:,:) = 0.0 if (CS%do_APE_calc) then - do k=1,nz ; do j=js,je ; do i=is,ie - tmp1(i,j,k) = HL2_to_kg * h(i,j,k) * areaTm(i,j) - enddo ; enddo ; enddo - mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=mass_lay, EFP_sum=mass_EFP) - call find_eta(h, tv, G, GV, US, eta, dZref=G%Z_ref) do k=1,nz ; do j=js,je ; do i=is,ie - tmp1(i,j,k) = US%Z_to_m*US%L_to_m**2*(eta(i,j,K)-eta(i,j,K+1)) * areaTm(i,j) + tmp1(i,j,k) = (eta(i,j,K)-eta(i,j,K+1)) * areaTm(i,j) enddo ; enddo ; enddo - vol_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=vol_lay) - do k=1,nz ; vol_lay(k) = US%m_to_Z*US%m_to_L**2 * vol_lay(k) ; enddo - else - do k=1,nz ; do j=js,je ; do i=is,ie - tmp1(i,j,k) = HL2_to_kg * h(i,j,k) * areaTm(i,j) - enddo ; enddo ; enddo - mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=mass_lay, EFP_sum=mass_EFP) - do k=1,nz ; vol_lay(k) = US%m_to_Z*US%m_to_L**2*US%kg_m3_to_R * (mass_lay(k) / GV%Rho0) ; enddo + vol_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=vol_lay, unscale=US%Z_to_m*US%L_to_m**2) endif endif ! Boussinesq nTr_stocks = 0 Tr_minmax_avail(:) = .false. - call call_tracer_stocks(h, Tr_stocks, G, GV, US, tracer_CSp, stock_names=Tr_names, & - stock_units=Tr_units, num_stocks=nTr_stocks,& - got_min_max=Tr_minmax_avail, global_min=Tr_min, global_max=Tr_max, & - xgmin=Tr_min_x, ygmin=Tr_min_y, zgmin=Tr_min_z,& - xgmax=Tr_max_x, ygmax=Tr_max_y, zgmax=Tr_max_z) + if (CS%write_min_max .and. CS%write_min_max_loc) then + call call_tracer_stocks(h, Tr_stocks, G, GV, US, tracer_CSp, stock_names=Tr_names, & + stock_units=Tr_units, num_stocks=nTr_stocks,& + got_min_max=Tr_minmax_avail, global_min=Tr_min, global_max=Tr_max, & + xgmin=Tr_min_x, ygmin=Tr_min_y, zgmin=Tr_min_z,& + xgmax=Tr_max_x, ygmax=Tr_max_y, zgmax=Tr_max_z) + elseif (CS%write_min_max) then + call call_tracer_stocks(h, Tr_stocks, G, GV, US, tracer_CSp, stock_names=Tr_names, & + stock_units=Tr_units, num_stocks=nTr_stocks,& + got_min_max=Tr_minmax_avail, global_min=Tr_min, global_max=Tr_max) + else + call call_tracer_stocks(h, Tr_stocks, G, GV, US, tracer_CSp, stock_names=Tr_names, & + stock_units=Tr_units, num_stocks=nTr_stocks) + endif if (nTr_stocks > 0) then do m=1,nTr_stocks vars(num_nc_fields+m) = var_desc(Tr_names(m), units=Tr_units(m), & @@ -545,6 +598,13 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci num_nc_fields = num_nc_fields + nTr_stocks endif + if (CS%use_temperature .and. CS%write_stocks) then + call array_global_min_max(tv%T, G, nz, T_min, T_max, & + T_min_x, T_min_y, T_min_z, T_max_x, T_max_y, T_max_z, unscale=US%C_to_degC) + call array_global_min_max(tv%S, G, nz, S_min, S_max, & + S_min_x, S_min_y, S_min_z, S_max_x, S_max_y, S_max_z, unscale=US%S_to_ppt) + endif + if (CS%previous_calls == 0) then CS%mass_prev_EFP = mass_EFP @@ -600,17 +660,15 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci endif endif endif - endif - energypath_nc = trim(CS%energyfile) // ".nc" - if (day > CS%Start_time) then - call reopen_file(CS%fileenergy_nc, trim(energypath_nc), vars, & - num_nc_fields, CS%fields, SINGLE_FILE, CS%timeunit, & - G=G, GV=GV) - else - call create_file(CS%fileenergy_nc, trim(energypath_nc), vars, & - num_nc_fields, CS%fields, SINGLE_FILE, CS%timeunit, & - G=G, GV=GV) + energypath_nc = trim(CS%energyfile) // ".nc" + if (day > CS%Start_time) then + call reopen_MOM_file(CS%fileenergy_nc, trim(energypath_nc), vars, & + num_nc_fields, CS%fields, SINGLE_FILE, CS%timeunit, G=G, GV=GV) + else + call create_MOM_file(CS%fileenergy_nc, trim(energypath_nc), vars, & + num_nc_fields, CS%fields, SINGLE_FILE, CS%timeunit, G=G, GV=GV) + endif endif endif @@ -639,61 +697,70 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci ! Calculate the Available Potential Energy integrated over each interface. With a nonlinear ! equation of state or with a bulk mixed layer this calculation is only approximate. ! With an ALE model this does not make sense and should be revisited. - PE_scale_factor = US%RZ_to_kg_m2*US%L_to_m**2*US%L_T_to_m_s**2 PE_pt(:,:,:) = 0.0 if (GV%Boussinesq) then do j=js,je ; do i=is,ie hbelow = 0.0 - do k=nz,1,-1 + do K=nz,1,-1 hbelow = hbelow + h(i,j,k) * GV%H_to_Z hint = Z_0APE(K) + (hbelow - (G%bathyT(i,j) + G%Z_ref)) hbot = Z_0APE(K) - (G%bathyT(i,j) + G%Z_ref) hbot = (hbot + ABS(hbot)) * 0.5 - PE_pt(i,j,K) = (0.5 * PE_scale_factor * areaTm(i,j)) * (GV%Rho0*GV%g_prime(K)) * & + PE_pt(i,j,K) = (0.5 * areaTm(i,j)) * (GV%Rho0*GV%g_prime(K)) * & (hint * hint - hbot * hbot) enddo enddo ; enddo + elseif (GV%semi_Boussinesq) then + do j=js,je ; do i=is,ie + do K=nz,1,-1 + hint = Z_0APE(K) + eta(i,j,K) ! eta and H_0 have opposite signs. + hbot = max(Z_0APE(K) - (G%bathyT(i,j) + G%Z_ref), 0.0) + PE_pt(i,j,K) = (0.5 * areaTm(i,j) * (GV%Rho0*GV%g_prime(K))) * & + (hint * hint - hbot * hbot) + enddo + enddo ; enddo else do j=js,je ; do i=is,ie - do k=nz,1,-1 + do K=nz,2,-1 hint = Z_0APE(K) + eta(i,j,K) ! eta and H_0 have opposite signs. hbot = max(Z_0APE(K) - (G%bathyT(i,j) + G%Z_ref), 0.0) - PE_pt(i,j,K) = (0.5 * PE_scale_factor * areaTm(i,j) * (GV%Rho0*GV%g_prime(K))) * & - (hint * hint - hbot * hbot) + PE_pt(i,j,K) = (0.25 * areaTm(i,j) * & + ((GV%Rlay(k)+GV%Rlay(k-1))*GV%g_prime(K))) * & + (hint * hint - hbot * hbot) enddo + hint = Z_0APE(1) + eta(i,j,1) ! eta and H_0 have opposite signs. + hbot = max(Z_0APE(1) - (G%bathyT(i,j) + G%Z_ref), 0.0) + PE_pt(i,j,1) = (0.5 * areaTm(i,j) * (GV%Rlay(1)*GV%g_prime(1))) * & + (hint * hint - hbot * hbot) enddo ; enddo endif - PE_tot = reproducing_sum(PE_pt, isr, ier, jsr, jer, sums=PE) - do k=1,nz+1 ; H_0APE(K) = US%Z_to_m*Z_0APE(K) ; enddo + PE_tot = reproducing_sum(PE_pt, isr, ier, jsr, jer, sums=PE, unscale=RZL4_T2_to_J) else PE_tot = 0.0 - do k=1,nz+1 ; PE(K) = 0.0 ; H_0APE(K) = 0.0 ; enddo + do k=1,nz+1 ; PE(K) = 0.0 ; Z_0APE(K) = 0.0 ; enddo endif -! Calculate the Kinetic Energy integrated over each layer. - KE_scale_factor = HL2_to_kg*US%L_T_to_m_s**2 + ! Calculate the Kinetic Energy integrated over each layer. tmp1(:,:,:) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - tmp1(i,j,k) = (0.25 * KE_scale_factor * (areaTm(i,j) * h(i,j,k))) * & - ((u(I-1,j,k)**2 + u(I,j,k)**2) + (v(i,J-1,k)**2 + v(i,J,k)**2)) + tmp1(i,j,k) = (0.25 * GV%H_to_RZ*(areaTm(i,j) * h(i,j,k))) * & + (((u(I-1,j,k)**2) + (u(I,j,k)**2)) + ((v(i,J-1,k)**2) + (v(i,J,k)**2))) enddo ; enddo ; enddo - KE_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=KE) - - toten = KE_tot + PE_tot + KE_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=KE, unscale=RZL4_T2_to_J) - Salt = 0.0 ; Heat = 0.0 + ! Use reproducing sums to do global integrals relate to the heat, salinity and water budgets. if (CS%use_temperature) then Temp_int(:,:) = 0.0 ; Salt_int(:,:) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - Salt_int(i,j) = Salt_int(i,j) + tv%S(i,j,k) * & - (h(i,j,k)*(HL2_to_kg * areaTm(i,j))) - Temp_int(i,j) = Temp_int(i,j) + (US%Q_to_J_kg*tv%C_p * tv%T(i,j,k)) * & - (h(i,j,k)*(HL2_to_kg * areaTm(i,j))) + Salt_int(i,j) = Salt_int(i,j) + tv%S(i,j,k) * (h(i,j,k)*(GV%H_to_RZ * areaTm(i,j))) + Temp_int(i,j) = Temp_int(i,j) + (tv%C_p * tv%T(i,j,k)) * (h(i,j,k)*(GV%H_to_RZ * areaTm(i,j))) enddo ; enddo ; enddo - salt_EFP = reproducing_sum_EFP(Salt_int, isr, ier, jsr, jer, only_on_PE=.true.) - heat_EFP = reproducing_sum_EFP(Temp_int, isr, ier, jsr, jer, only_on_PE=.true.) + salt_EFP = reproducing_sum_EFP(Salt_int, isr, ier, jsr, jer, only_on_PE=.true., & + unscale=US%RZL2_to_kg*US%S_to_ppt) + heat_EFP = reproducing_sum_EFP(Temp_int, isr, ier, jsr, jer, only_on_PE=.true., & + unscale=US%RZL2_to_kg*US%Q_to_J_kg) ! Combining the sums avoids multiple blocking all-PE updates. EFP_list(1) = salt_EFP ; EFP_list(2) = heat_EFP ; EFP_list(3) = CS%fresh_water_in_EFP @@ -703,13 +770,11 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci salt_EFP = EFP_list(1) ; heat_EFP = EFP_list(2) ; CS%fresh_water_in_EFP = EFP_list(3) CS%net_salt_in_EFP = EFP_list(4) ; CS%net_heat_in_EFP = EFP_list(5) - Salt = EFP_to_real(salt_EFP) - Heat = EFP_to_real(heat_EFP) else call EFP_sum_across_PEs(CS%fresh_water_in_EFP) endif -! Calculate the maximum CFL numbers. + ! Calculate the maximum CFL numbers. max_CFL(1:2) = 0.0 do k=1,nz ; do j=js,je ; do I=Isq,Ieq CFL_Iarea = G%IareaT(i,j) @@ -733,46 +798,50 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci enddo ; enddo ; enddo call sum_across_PEs(CS%ntrunc) - ! Sum the various quantities across all the processors. This sum is NOT - ! guaranteed to be bitwise reproducible, even on the same decomposition. - ! The sum of Tr_stocks should be reimplemented using the reproducing sums. - if (nTr_stocks > 0) call sum_across_PEs(Tr_stocks,nTr_stocks) call max_across_PEs(max_CFL, 2) + Salt = 0.0 ; Heat = 0.0 if (CS%use_temperature) then + Salt = kg_to_RZL2 * EFP_to_real(salt_EFP) + Heat = J_to_QRZL2 * EFP_to_real(heat_EFP) if (CS%previous_calls == 0) then CS%salt_prev_EFP = salt_EFP ; CS%heat_prev_EFP = heat_EFP endif Salt_chg_EFP = Salt_EFP - CS%salt_prev_EFP - Salt_chg = EFP_to_real(Salt_chg_EFP) + Salt_chg = kg_to_RZL2 * EFP_to_real(Salt_chg_EFP) Salt_anom_EFP = Salt_chg_EFP - CS%net_salt_in_EFP - Salt_anom = EFP_to_real(Salt_anom_EFP) + Salt_anom = kg_to_RZL2 * EFP_to_real(Salt_anom_EFP) Heat_chg_EFP = Heat_EFP - CS%heat_prev_EFP - Heat_chg = EFP_to_real(Heat_chg_EFP) + Heat_chg = J_to_QRZL2 * EFP_to_real(Heat_chg_EFP) Heat_anom_EFP = Heat_chg_EFP - CS%net_heat_in_EFP - Heat_anom = EFP_to_real(Heat_anom_EFP) + Heat_anom = J_to_QRZL2 * EFP_to_real(Heat_anom_EFP) endif mass_chg_EFP = mass_EFP - CS%mass_prev_EFP mass_anom_EFP = mass_chg_EFP - CS%fresh_water_in_EFP - mass_anom = EFP_to_real(mass_anom_EFP) + mass_anom = kg_to_RZL2 * EFP_to_real(mass_anom_EFP) if (CS%use_temperature .and. .not.GV%Boussinesq) then - ! net_salt_input needs to be converted from ppt m s-1 to kg m-2 s-1. - mass_anom = mass_anom - 0.001*EFP_to_real(CS%net_salt_in_EFP) + ! net_salt_input needs to be converted from ppt kg to [R Z L2 ~> kg] + mass_anom = mass_anom - 0.001*kg_to_RZL2*EFP_to_real(CS%net_salt_in_EFP) endif - mass_chg = EFP_to_real(mass_chg_EFP) + mass_chg = kg_to_RZL2 * EFP_to_real(mass_chg_EFP) if (CS%use_temperature) then - salin = Salt / mass_tot ; salin_anom = Salt_anom / mass_tot + salin = Salt / mass_tot + salin_anom = Salt_anom / mass_tot ! salin_chg = Salt_chg / mass_tot - temp = heat / (mass_tot*US%Q_to_J_kg*tv%C_p) ; temp_anom = Heat_anom / (mass_tot*US%Q_to_J_kg*tv%C_p) + temp = Heat / (mass_tot*tv%C_p) + temp_anom = Heat_anom / (mass_tot*tv%C_p) endif + toten = KE_tot + PE_tot + En_mass = toten / mass_tot call get_time(day, start_of_day, num_days) date_stamped = (CS%date_stamped_output .and. (get_calendar_type() /= NO_CALENDAR)) - if (date_stamped) & + ISO_date_stamped = (CS%ISO_date_stamped_output .and. (get_calendar_type() /= NO_CALENDAR)) + if (date_stamped .or. ISO_date_stamped) & call get_date(day, iyear, imonth, iday, ihour, iminute, isecond, itick) if (abs(CS%timeunit - 86400.0) < 1.0) then reday = REAL(num_days)+ (REAL(start_of_day)/86400.0) @@ -786,124 +855,155 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci elseif (reday < 1.0e11) then ; write(day_str, '(F15.3)') reday else ; write(day_str, '(ES15.9)') reday ; endif - if (n < 1000000) then ; write(n_str, '(I6)') n - elseif (n < 10000000) then ; write(n_str, '(I7)') n - elseif (n < 100000000) then ; write(n_str, '(I8)') n - else ; write(n_str, '(I10)') n ; endif + if (n < 1000000) then ; write(n_str, '(I6)') n + else ; write(n_str, '(I0)') n ; endif - if (date_stamped) then + date_str = trim(mesg_intro)//trim(day_str) + if (date_stamped) & write(date_str,'("MOM Date",i7,2("/",i2.2)," ",i2.2,2(":",i2.2))') & - iyear, imonth, iday, ihour, iminute, isecond - else - date_str = trim(mesg_intro)//trim(day_str) - endif + iyear, imonth, iday, ihour, iminute, isecond + if (ISO_date_stamped) & + write(ISO_date_str,'(i7.4,2(i2.2),"T",i2.2,2(i2.2))') & + iyear, imonth, iday, ihour, iminute, isecond - if (is_root_pe()) then + if (is_root_pe()) then ! Only the root PE actually writes anything. if (CS%use_temperature) then write(stdout,'(A," ",A,": En ",ES12.6, ", MaxCFL ", F8.5, ", Mass ", & - & ES18.12, ", Salt ", F15.11,", Temp ", F15.11)') & - trim(date_str), trim(n_str), En_mass, max_CFL(1), mass_tot, salin, temp + & ES18.12, ", Salt ", F15.11,", Temp ", F15.11)') & + trim(date_str), trim(n_str), US%L_T_to_m_s**2*En_mass, max_CFL(1), US%RZL2_to_kg*mass_tot, & + salin, US%C_to_degC*temp else - write(stdout,'(A," ",A,": En ",ES12.6, ", MaxCFL ", F8.5, ", Mass ", & - & ES18.12)') & - trim(date_str), trim(n_str), En_mass, max_CFL(1), mass_tot + write(stdout,'(A," ",A,": En ",ES12.6, ", MaxCFL ", F8.5, ", Mass ", ES18.12)') & + trim(date_str), trim(n_str), US%L_T_to_m_s**2*En_mass, max_CFL(1), US%RZL2_to_kg*mass_tot endif if (CS%use_temperature) then - write(CS%fileenergy_ascii,'(A,",",A,",", I6,", En ",ES22.16, & - &", CFL ", F8.5, ", SL ",& - &es11.4,", M ",ES11.5,", S",f8.4,", T",f8.4,& - &", Me ",ES9.2,", Se ",ES9.2,", Te ",ES9.2)') & - trim(n_str), trim(day_str), CS%ntrunc, En_mass, max_CFL(1), & - -H_0APE(1), mass_tot, salin, temp, mass_anom/mass_tot, salin_anom, & - temp_anom + if (ISO_date_stamped) then + write(CS%fileenergy_ascii,'(A,",",A,",", I6,", En ",ES22.16, ", CFL ", F8.5, ", SL ",& + &es11.4,", M ",ES11.5,", S",f8.4,", T",f8.4,& + &", Me ",ES9.2,", Se ",ES9.2,", Te ",ES9.2)') & + trim(n_str), trim(ISO_date_str), CS%ntrunc, US%L_T_to_m_s**2*En_mass, max_CFL(1), & + -US%Z_to_m*Z_0APE(1), US%RZL2_to_kg*mass_tot, salin, US%C_to_degC*temp, mass_anom/mass_tot, & + salin_anom, US%C_to_degC*temp_anom + else + write(CS%fileenergy_ascii,'(A,",",A,",", I6,", En ",ES22.16, ", CFL ", F8.5, ", SL ",& + &es11.4,", M ",ES11.5,", S",f8.4,", T",f8.4,& + &", Me ",ES9.2,", Se ",ES9.2,", Te ",ES9.2)') & + trim(n_str), trim(day_str), CS%ntrunc, US%L_T_to_m_s**2*En_mass, max_CFL(1), & + -US%Z_to_m*Z_0APE(1), US%RZL2_to_kg*mass_tot, salin, US%C_to_degC*temp, mass_anom/mass_tot, & + salin_anom, US%C_to_degC*temp_anom + endif else - write(CS%fileenergy_ascii,'(A,",",A,",", I6,", En ",ES22.16, & - &", CFL ", F8.5, ", SL ",& - &ES11.4,", Mass ",ES11.5,", Me ",ES9.2)') & - trim(n_str), trim(day_str), CS%ntrunc, En_mass, max_CFL(1), & - -H_0APE(1), mass_tot, mass_anom/mass_tot + if (ISO_date_stamped) then + write(CS%fileenergy_ascii,'(A,",",A,",", I6,", En ",ES22.16, ", CFL ", F8.5, ", SL ",& + &ES11.4,", Mass ",ES11.5,", Me ",ES9.2)') & + trim(n_str), trim(ISO_date_str), CS%ntrunc, US%L_T_to_m_s**2*En_mass, max_CFL(1), & + -US%Z_to_m*Z_0APE(1), US%RZL2_to_kg*mass_tot, mass_anom/mass_tot + else + write(CS%fileenergy_ascii,'(A,",",A,",", I6,", En ",ES22.16, ", CFL ", F8.5, ", SL ",& + &ES11.4,", Mass ",ES11.5,", Me ",ES9.2)') & + trim(n_str), trim(day_str), CS%ntrunc, US%L_T_to_m_s**2*En_mass, max_CFL(1), & + -US%Z_to_m*Z_0APE(1), US%RZL2_to_kg*mass_tot, mass_anom/mass_tot + endif endif if (CS%ntrunc > 0) then write(stdout,'(A," Energy/Mass:",ES12.5," Truncations ",I0)') & - trim(date_str), En_mass, CS%ntrunc + trim(date_str), US%L_T_to_m_s**2*En_mass, CS%ntrunc endif if (CS%write_stocks) then - write(stdout,'(" Total Energy: ",Z16.16,ES24.16)') toten, toten + write(stdout,'(" Total Energy: ",Z16.16,ES24.16)') RZL4_T2_to_J*toten, RZL4_T2_to_J*toten write(stdout,'(" Total Mass: ",ES24.16,", Change: ",ES24.16," Error: ",ES12.5," (",ES8.1,")")') & - mass_tot, mass_chg, mass_anom, mass_anom/mass_tot + US%RZL2_to_kg*mass_tot, US%RZL2_to_kg*mass_chg, US%RZL2_to_kg*mass_anom, mass_anom/mass_tot if (CS%use_temperature) then if (Salt == 0.) then write(stdout,'(" Total Salt: ",ES24.16,", Change: ",ES24.16," Error: ",ES12.5)') & - Salt*0.001, Salt_chg*0.001, Salt_anom*0.001 + Salt*salt_to_kg, Salt_chg*salt_to_kg, Salt_anom*salt_to_kg else write(stdout,'(" Total Salt: ",ES24.16,", Change: ",ES24.16," Error: ",ES12.5," (",ES8.1,")")') & - Salt*0.001, Salt_chg*0.001, Salt_anom*0.001, Salt_anom/Salt + Salt*salt_to_kg, Salt_chg*salt_to_kg, Salt_anom*salt_to_kg, Salt_anom/Salt + endif + if (CS%write_min_max .and. CS%write_min_max_loc) then + write(stdout,'(16X,"Salinity Global Min:",ES24.16,1X,"at: (",f7.2,",",f7.2,",",f8.2,")" )') & + S_min, S_min_x, S_min_y, S_min_z + write(stdout,'(16X,"Salinity Global Max:",ES24.16,1X,"at: (",f7.2,",",f7.2,",",f8.2,")" )') & + S_max, S_max_x, S_max_y, S_max_z + elseif (CS%write_min_max) then + write(stdout,'(16X,"Salinity Global Min & Max:",ES24.16,1X,ES24.16)') S_min, S_max endif + if (Heat == 0.) then write(stdout,'(" Total Heat: ",ES24.16,", Change: ",ES24.16," Error: ",ES12.5)') & - Heat, Heat_chg, Heat_anom + QRZL2_to_J*Heat, QRZL2_to_J*Heat_chg, QRZL2_to_J*Heat_anom else write(stdout,'(" Total Heat: ",ES24.16,", Change: ",ES24.16," Error: ",ES12.5," (",ES8.1,")")') & - Heat, Heat_chg, Heat_anom, Heat_anom/Heat + QRZL2_to_J*Heat, QRZL2_to_J*Heat_chg, QRZL2_to_J*Heat_anom, Heat_anom/Heat + endif + if (CS%write_min_max .and. CS%write_min_max_loc) then + write(stdout,'(16X,"Temperature Global Min:",ES24.16,1X,"at: (",f7.2,",",f7.2,",",f8.2,")" )') & + T_min, T_min_x, T_min_y, T_min_z + write(stdout,'(16X,"Temperature Global Max:",ES24.16,1X,"at: (",f7.2,",",f7.2,",",f8.2,")" )') & + T_max, T_max_x, T_max_y, T_max_z + elseif (CS%write_min_max) then + write(stdout,'(16X,"Temperature Global Min & Max:",ES24.16,1X,ES24.16)') T_min, T_max endif endif do m=1,nTr_stocks - write(stdout,'(" Total ",a,": ",ES24.16,X,a)') & + write(stdout,'(" Total ",a,": ",ES24.16,1X,a)') & trim(Tr_names(m)), Tr_stocks(m), trim(Tr_units(m)) - if (Tr_minmax_avail(m)) then - write(stdout,'(64X,"Global Min:",ES24.16,X,"at: (", f7.2,","f7.2,","f8.2,")" )') & - Tr_min(m),Tr_min_x(m),Tr_min_y(m),Tr_min_z(m) - write(stdout,'(64X,"Global Max:",ES24.16,X,"at: (", f7.2,","f7.2,","f8.2,")" )') & - Tr_max(m),Tr_max_x(m),Tr_max_y(m),Tr_max_z(m) + if (CS%write_min_max .and. CS%write_min_max_loc .and. Tr_minmax_avail(m)) then + write(stdout,'(18X,a," Global Min:",ES24.16,1X,"at: (",f7.2,",",f7.2,",",f8.2,")" )') & + trim(Tr_names(m)), Tr_min(m), Tr_min_x(m), Tr_min_y(m), Tr_min_z(m) + write(stdout,'(18X,a," Global Max:",ES24.16,1X,"at: (",f7.2,",",f7.2,",",f8.2,")" )') & + trim(Tr_names(m)), Tr_max(m), Tr_max_x(m), Tr_max_y(m), Tr_max_z(m) + elseif (CS%write_min_max .and. Tr_minmax_avail(m)) then + write(stdout,'(18X,a," Global Min & Max:",ES24.16,1X,ES24.16)') & + trim(Tr_names(m)), Tr_min(m), Tr_max(m) endif enddo endif - endif - var = real(CS%ntrunc) - call write_field(CS%fileenergy_nc, CS%fields(1), var, reday) - call write_field(CS%fileenergy_nc, CS%fields(2), toten, reday) - call write_field(CS%fileenergy_nc, CS%fields(3), PE, reday) - call write_field(CS%fileenergy_nc, CS%fields(4), KE, reday) - call write_field(CS%fileenergy_nc, CS%fields(5), H_0APE, reday) - call write_field(CS%fileenergy_nc, CS%fields(6), mass_lay, reday) - - call write_field(CS%fileenergy_nc, CS%fields(7), mass_tot, reday) - call write_field(CS%fileenergy_nc, CS%fields(8), mass_chg, reday) - call write_field(CS%fileenergy_nc, CS%fields(9), mass_anom, reday) - call write_field(CS%fileenergy_nc, CS%fields(10), max_CFL(1), reday) - call write_field(CS%fileenergy_nc, CS%fields(11), max_CFL(2), reday) - if (CS%use_temperature) then - call write_field(CS%fileenergy_nc, CS%fields(12), 0.001*Salt, reday) - call write_field(CS%fileenergy_nc, CS%fields(13), 0.001*salt_chg, reday) - call write_field(CS%fileenergy_nc, CS%fields(14), 0.001*salt_anom, reday) - call write_field(CS%fileenergy_nc, CS%fields(15), Heat, reday) - call write_field(CS%fileenergy_nc, CS%fields(16), heat_chg, reday) - call write_field(CS%fileenergy_nc, CS%fields(17), heat_anom, reday) - do m=1,nTr_stocks - call write_field(CS%fileenergy_nc, CS%fields(17+m), Tr_stocks(m), reday) - enddo - else - do m=1,nTr_stocks - call write_field(CS%fileenergy_nc, CS%fields(11+m), Tr_stocks(m), reday) - enddo - endif + call CS%fileenergy_nc%write_field(CS%fields(1), real(CS%ntrunc), reday) + call CS%fileenergy_nc%write_field(CS%fields(2), toten, reday) + call CS%fileenergy_nc%write_field(CS%fields(3), PE, reday) + call CS%fileenergy_nc%write_field(CS%fields(4), KE, reday) + call CS%fileenergy_nc%write_field(CS%fields(5), Z_0APE, reday) + call CS%fileenergy_nc%write_field(CS%fields(6), mass_lay, reday) + + call CS%fileenergy_nc%write_field(CS%fields(7), mass_tot, reday) + call CS%fileenergy_nc%write_field(CS%fields(8), mass_chg, reday) + call CS%fileenergy_nc%write_field(CS%fields(9), mass_anom, reday) + call CS%fileenergy_nc%write_field(CS%fields(10), max_CFL(1), reday) + call CS%fileenergy_nc%write_field(CS%fields(11), max_CFL(2), reday) + if (CS%use_temperature) then + call CS%fileenergy_nc%write_field(CS%fields(12), Salt, reday) + call CS%fileenergy_nc%write_field(CS%fields(13), salt_chg, reday) + call CS%fileenergy_nc%write_field(CS%fields(14), salt_anom, reday) + call CS%fileenergy_nc%write_field(CS%fields(15), Heat, reday) + call CS%fileenergy_nc%write_field(CS%fields(16), heat_chg, reday) + call CS%fileenergy_nc%write_field(CS%fields(17), heat_anom, reday) + do m=1,nTr_stocks + call CS%fileenergy_nc%write_field(CS%fields(17+m), Tr_stocks(m), reday) + enddo + else + do m=1,nTr_stocks + call CS%fileenergy_nc%write_field(CS%fields(11+m), Tr_stocks(m), reday) + enddo + endif - call flush_file(CS%fileenergy_nc) + call CS%fileenergy_nc%flush() + endif ! Only the root PE actually writes anything. - ! The second (impossible-looking) test looks for a NaN in En_mass. - if ((En_mass>CS%max_Energy) .or. & - ((En_mass>CS%max_Energy) .and. (En_mass CS%max_Energy) then write(mesg,'("Energy per unit mass of ",ES11.4," exceeds ",ES11.4)') & - En_mass, CS%max_Energy - call MOM_error(FATAL, & - "write_energy : Excessive energy per unit mass or NaNs forced model termination.") + US%L_T_to_m_s**2*En_mass, US%L_T_to_m_s**2*CS%max_Energy + call MOM_error(FATAL, "write_energy : Excessive energy per unit mass forced model termination.") endif if (CS%ntrunc>CS%maxtrunc) then call MOM_error(FATAL, "write_energy : Ocean velocity has been truncated too many times.") @@ -919,7 +1019,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci end subroutine write_energy -!> This subroutine accumates the net input of volume, salt and heat, through +!> This subroutine accumulates the net input of volume, salt and heat, through !! the ocean surface for use in diagnosing conservation. subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) type(forcing), intent(in) :: fluxes !< A structure containing pointers to any possible @@ -935,19 +1035,11 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) !! to MOM_sum_output_init. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - FW_in, & ! The net fresh water input, integrated over a timestep [kg]. + FW_in, & ! The net fresh water input, integrated over a timestep [R Z L2 ~> kg]. salt_in, & ! The total salt added by surface fluxes, integrated - ! over a time step [ppt kg]. + ! over a time step [1e-3 R Z L2 ~> g Salt]. heat_in ! The total heat added by surface fluxes, integrated - ! over a time step [J]. - real :: FW_input ! The net fresh water input, integrated over a timestep - ! and summed over space [kg]. - real :: salt_input ! The total salt added by surface fluxes, integrated - ! over a time step and summed over space [ppt kg]. - real :: heat_input ! The total heat added by boundary fluxes, integrated - ! over a time step and summed over space [J]. - real :: RZL2_to_kg ! A combination of scaling factors for mass [kg R-1 Z-1 L-2 ~> 1] - real :: QRZL2_to_J ! A combination of scaling factors for heat [J Q-1 R-1 Z-1 L-2 ~> 1] + ! over a time step [Q R Z L2 ~> J]. type(EFP_type) :: & FW_in_EFP, & ! The net fresh water input, integrated over a timestep @@ -957,21 +1049,17 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) heat_in_EFP ! The total heat added by boundary fluxes, integrated ! over a time step and summed over space [J]. - real :: inputs(3) ! A mixed array for combining the sums integer :: i, j, is, ie, js, je, isr, ier, jsr, jer is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - RZL2_to_kg = US%L_to_m**2*US%RZ_to_kg_m2 - QRZL2_to_J = RZL2_to_kg*US%Q_to_J_kg - FW_in(:,:) = 0.0 if (associated(fluxes%evap)) then if (associated(fluxes%lprec) .and. associated(fluxes%fprec)) then do j=js,je ; do i=is,ie - FW_in(i,j) = RZL2_to_kg * dt*G%areaT(i,j)*(fluxes%evap(i,j) + & - (((fluxes%lprec(i,j) + fluxes%vprec(i,j)) + fluxes%lrunoff(i,j)) + & - (fluxes%fprec(i,j) + fluxes%frunoff(i,j)))) + FW_in(i,j) = dt*G%areaT(i,j)*(fluxes%evap(i,j) + & + (((fluxes%lprec(i,j) + fluxes%vprec(i,j)) + (fluxes%lrunoff(i,j) + fluxes%lrunoff_glc(i,j))) + & + (fluxes%fprec(i,j) + (fluxes%frunoff(i,j) + fluxes%frunoff_glc(i,j))))) enddo ; enddo else call MOM_error(WARNING, & @@ -980,27 +1068,26 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) endif if (associated(fluxes%seaice_melt)) then ; do j=js,je ; do i=is,ie - FW_in(i,j) = FW_in(i,j) + RZL2_to_kg*dt * & - G%areaT(i,j) * fluxes%seaice_melt(i,j) + FW_in(i,j) = FW_in(i,j) + dt * G%areaT(i,j) * fluxes%seaice_melt(i,j) enddo ; enddo ; endif salt_in(:,:) = 0.0 ; heat_in(:,:) = 0.0 if (CS%use_temperature) then if (associated(fluxes%sw)) then ; do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + dt * QRZL2_to_J * G%areaT(i,j) * (fluxes%sw(i,j) + & + heat_in(i,j) = heat_in(i,j) + dt * G%areaT(i,j) * (fluxes%sw(i,j) + & (fluxes%lw(i,j) + (fluxes%latent(i,j) + fluxes%sens(i,j)))) enddo ; enddo ; endif if (associated(fluxes%seaice_melt_heat)) then ; do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + dt * QRZL2_to_J * G%areaT(i,j) * & + heat_in(i,j) = heat_in(i,j) + dt * G%areaT(i,j) * & fluxes%seaice_melt_heat(i,j) enddo ; enddo ; endif ! smg: new code ! include heat content from water transport across ocean surface ! if (associated(fluxes%heat_content_lprec)) then ; do j=js,je ; do i=is,ie -! heat_in(i,j) = heat_in(i,j) + dt * QRZL2_to_J * G%areaT(i,j) * & +! heat_in(i,j) = heat_in(i,j) + dt * G%areaT(i,j) * & ! (fluxes%heat_content_lprec(i,j) + (fluxes%heat_content_fprec(i,j) & ! + (fluxes%heat_content_lrunoff(i,j) + (fluxes%heat_content_frunoff(i,j) & ! + (fluxes%heat_content_cond(i,j) + (fluxes%heat_content_vprec(i,j) & @@ -1008,36 +1095,43 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) ! enddo ; enddo ; endif ! smg: old code - if (associated(tv%TempxPmE)) then + if (associated(fluxes%heat_content_evap)) then + do j=js,je ; do i=is,ie + heat_in(i,j) = heat_in(i,j) + dt * G%areaT(i,j) * & + (fluxes%heat_content_evap(i,j) + fluxes%heat_content_lprec(i,j) + & + fluxes%heat_content_cond(i,j) + fluxes%heat_content_fprec(i,j) + & + fluxes%heat_content_lrunoff(i,j) + fluxes%heat_content_frunoff(i,j)) + enddo ; enddo + elseif (associated(tv%TempxPmE)) then do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + (fluxes%C_p * QRZL2_to_J*G%areaT(i,j)) * tv%TempxPmE(i,j) + heat_in(i,j) = heat_in(i,j) + (tv%C_p * G%areaT(i,j)) * tv%TempxPmE(i,j) enddo ; enddo elseif (associated(fluxes%evap)) then do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + (US%Q_to_J_kg*fluxes%C_p * sfc_state%SST(i,j)) * FW_in(i,j) + heat_in(i,j) = heat_in(i,j) + (tv%C_p * sfc_state%SST(i,j)) * FW_in(i,j) enddo ; enddo endif ! The following heat sources may or may not be used. if (associated(tv%internal_heat)) then do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + (fluxes%C_p * QRZL2_to_J*G%areaT(i,j)) * tv%internal_heat(i,j) + heat_in(i,j) = heat_in(i,j) + (tv%C_p * G%areaT(i,j)) * tv%internal_heat(i,j) enddo ; enddo endif if (associated(tv%frazil)) then ; do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + QRZL2_to_J * G%areaT(i,j) * tv%frazil(i,j) + heat_in(i,j) = heat_in(i,j) + G%areaT(i,j) * tv%frazil(i,j) enddo ; enddo ; endif if (associated(fluxes%heat_added)) then ; do j=js,je ; do i=is,ie - heat_in(i,j) = heat_in(i,j) + QRZL2_to_J * dt*G%areaT(i,j) * fluxes%heat_added(i,j) + heat_in(i,j) = heat_in(i,j) + dt*G%areaT(i,j) * fluxes%heat_added(i,j) enddo ; enddo ; endif ! if (associated(sfc_state%sw_lost)) then ; do j=js,je ; do i=is,ie -! heat_in(i,j) = heat_in(i,j) - US%L_to_m**2*G%areaT(i,j) * sfc_state%sw_lost(i,j) +! sfc_state%sw_lost must be in units of [Q R Z ~> J m-2] +! heat_in(i,j) = heat_in(i,j) - G%areaT(i,j) * sfc_state%sw_lost(i,j) ! enddo ; enddo ; endif if (associated(fluxes%salt_flux)) then ; do j=js,je ; do i=is,ie ! integrate salt_flux in [R Z T-1 ~> kgSalt m-2 s-1] to give [ppt kg] - salt_in(i,j) = RZL2_to_kg * dt * & - G%areaT(i,j)*(1000.0*fluxes%salt_flux(i,j)) + salt_in(i,j) = dt * G%areaT(i,j)*(1000.0*fluxes%salt_flux(i,j)) enddo ; enddo ; endif endif @@ -1046,9 +1140,12 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) ! The on-PE sums are stored here, but the sums across PEs are deferred to ! the next call to write_energy to avoid extra barriers. isr = is - (G%isd-1) ; ier = ie - (G%isd-1) ; jsr = js - (G%jsd-1) ; jer = je - (G%jsd-1) - FW_in_EFP = reproducing_sum_EFP(FW_in, isr, ier, jsr, jer, only_on_PE=.true.) - heat_in_EFP = reproducing_sum_EFP(heat_in, isr, ier, jsr, jer, only_on_PE=.true.) - salt_in_EFP = reproducing_sum_EFP(salt_in, isr, ier, jsr, jer, only_on_PE=.true.) + FW_in_EFP = reproducing_sum_EFP(FW_in, isr, ier, jsr, jer, only_on_PE=.true., & + unscale=US%RZL2_to_kg) + heat_in_EFP = reproducing_sum_EFP(heat_in, isr, ier, jsr, jer, only_on_PE=.true., & + unscale=US%RZL2_to_kg*US%Q_to_J_kg) + salt_in_EFP = reproducing_sum_EFP(salt_in, isr, ier, jsr, jer, only_on_PE=.true., & + unscale=US%RZL2_to_kg) CS%fresh_water_in_EFP = CS%fresh_water_in_EFP + FW_in_EFP CS%net_salt_in_EFP = CS%net_salt_in_EFP + salt_in_EFP @@ -1082,7 +1179,7 @@ subroutine depth_list_setup(G, GV, US, DL, CS) valid_DL_read = .true. ! Otherwise there would have been a fatal error. endif else - if (is_root_pe()) call MOM_error(WARNING, "depth_list_setup: "// & + if (is_root_pe()) call MOM_error(NOTE, "depth_list_setup: "// & trim(CS%depth_list_file)//" does not exist. Creating a new file.") valid_DL_read = .false. endif @@ -1106,7 +1203,7 @@ end subroutine depth_list_setup subroutine create_depth_list(G, DL, min_depth_inc) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(Depth_List), intent(inout) :: DL !< The list of depths, areas and volumes to create - real, intent(in) :: min_depth_inc !< The minimum increment bewteen depths in the list [Z ~> m] + real, intent(in) :: min_depth_inc !< The minimum increment between depths in the list [Z ~> m] ! Local variables real, dimension(G%Domain%niglobal*G%Domain%njglobal + 1) :: & @@ -1116,7 +1213,7 @@ subroutine create_depth_list(G, DL, min_depth_inc) indx2 !< The position of an element in the original unsorted list. real :: Dnow !< The depth now being considered for sorting [Z ~> m]. real :: Dprev !< The most recent depth that was considered [Z ~> m]. - real :: vol !< The running sum of open volume below a deptn [Z L2 ~> m3]. + real :: vol !< The running sum of open volume below a depth [Z L2 ~> m3]. real :: area !< The open area at the current depth [L2 ~> m2]. real :: D_list_prev !< The most recent depth added to the list [Z ~> m]. logical :: add_to_list !< This depth should be included as an entry on the list. @@ -1238,13 +1335,13 @@ subroutine write_depth_list(G, US, DL, filename) ! Local variables type(vardesc), dimension(:), allocatable :: & vars ! Types that described the staggering and metadata for the fields - type(fieldtype), dimension(:), allocatable :: & + type(MOM_field), dimension(:), allocatable :: & fields ! Types with metadata about the variables that will be written type(axis_info), dimension(:), allocatable :: & extra_axes ! Descriptors for extra axes that might be used type(attribute_info), dimension(:), allocatable :: & global_atts ! Global attributes and their values - type(file_type) :: IO_handle ! The I/O handle of the fileset + type(MOM_netcdf_file) :: IO_handle ! The I/O handle of the fileset character(len=16) :: depth_chksum, area_chksum ! All ranks are required to compute the global checksum @@ -1264,17 +1361,16 @@ subroutine write_depth_list(G, US, DL, filename) call set_attribute_info(global_atts(1), depth_chksum_attr, depth_chksum) call set_attribute_info(global_atts(2), area_chksum_attr, area_chksum) - call create_file(IO_handle, filename, vars, 3, fields, SINGLE_FILE, extra_axes=extra_axes, & - global_atts=global_atts) - call MOM_write_field(IO_handle, fields(1), DL%depth, scale=US%Z_to_m) - call MOM_write_field(IO_handle, fields(2), DL%area, scale=US%L_to_m**2) - call MOM_write_field(IO_handle, fields(3), DL%vol_below, scale=US%Z_to_m*US%L_to_m**2) + call create_MOM_file(IO_handle, filename, vars, 3, fields, SINGLE_FILE, & + extra_axes=extra_axes, global_atts=global_atts) + call MOM_write_field(IO_handle, fields(1), DL%depth, unscale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(2), DL%area, unscale=US%L_to_m**2) + call MOM_write_field(IO_handle, fields(3), DL%vol_below, unscale=US%Z_to_m*US%L_to_m**2) call delete_axis_info(extra_axes) call delete_attribute_info(global_atts) deallocate(vars, extra_axes, fields, global_atts) - call close_file(IO_handle) - + call IO_handle%close() end subroutine write_depth_list !> This subroutine reads in the depth list from the specified file @@ -1291,8 +1387,7 @@ subroutine read_depth_list(G, US, DL, filename, require_chksum, file_matches) ! Local variables character(len=240) :: var_msg - real, allocatable :: tmp(:) - integer :: ncid, list_size, k, ndim, sizes(4) + integer :: list_size, ndim, sizes(4) character(len=:), allocatable :: depth_file_chksum, area_file_chksum character(len=16) :: depth_grid_chksum, area_grid_chksum logical :: depth_att_found, area_att_found @@ -1366,8 +1461,9 @@ subroutine get_depth_list_checksums(G, US, depth_chksum, area_chksum) character(len=16), intent(out) :: depth_chksum !< Depth checksum hexstring character(len=16), intent(out) :: area_chksum !< Area checksum hexstring + ! Local variables + real, allocatable :: field(:,:) ! A temporary array with no halos [Z ~> m] or [L2 ~> m2] integer :: i, j - real, allocatable :: field(:,:) allocate(field(G%isc:G%iec, G%jsc:G%jec)) @@ -1375,13 +1471,13 @@ subroutine get_depth_list_checksums(G, US, depth_chksum, area_chksum) do j=G%jsc,G%jec ; do i=G%isc,G%iec field(i,j) = G%bathyT(i,j) + G%Z_ref enddo ; enddo - write(depth_chksum, '(Z16)') field_chksum(field(:,:)) + write(depth_chksum, '(Z16)') field_checksum(field(:,:), unscale=US%Z_to_m) ! Area checksum do j=G%jsc,G%jec ; do i=G%isc,G%iec - field(i,j) = G%mask2dT(i,j) * US%L_to_m**2*G%areaT(i,j) + field(i,j) = G%mask2dT(i,j) * G%areaT(i,j) enddo ; enddo - write(area_chksum, '(Z16)') field_chksum(field(:,:)) + write(area_chksum, '(Z16)') field_checksum(field(:,:), unscale=US%L_to_m**2) deallocate(field) end subroutine get_depth_list_checksums diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 6765f9aa12..9ce2af08f4 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -1,17 +1,20 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Routines for calculating baroclinic wave speeds module MOM_wave_speed -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : log_version use MOM_grid, only : ocean_grid_type -use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h +use MOM_interface_heights, only : thickness_to_dz +use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h, interpolate_column use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs +use MOM_EOS, only : calculate_density_derivs, calculate_specific_vol_derivs implicit none ; private @@ -35,27 +38,36 @@ module MOM_wave_speed !! internal wave speed. real :: mono_N2_column_fraction = 0. !< The lower fraction of water column over which N2 is limited as !! monotonic for the purposes of calculating the equivalent barotropic - !! wave speed. This parameter controls the default behavior of + !! wave speed [nondim]. This parameter controls the default behavior of !! wave_speed() which can be overridden by optional arguments. real :: mono_N2_depth = -1. !< The depth below which N2 is limited as monotonic for the purposes of - !! calculating the equivalent barotropic wave speed [Z ~> m]. + !! calculating the equivalent barotropic wave speed [H ~> m or kg m-2]. + !! If this parameter is negative, this limiting does not occur. !! This parameter controls the default behavior of wave_speed() which !! can be overridden by optional arguments. real :: min_speed2 = 0. !< The minimum mode 1 internal wave speed squared [L2 T-2 ~> m2 s-2] real :: wave_speed_tol = 0.001 !< The fractional tolerance with which to solve for the wave !! speeds [nondim] - type(remapping_CS) :: remapping_CS !< Used for vertical remapping when calculating equivalent barotropic + real :: c1_thresh = -1.0 !< A minimal value of the first mode internal wave speed + !! below which all higher mode speeds are not calculated but + !! 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) :: 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. - logical :: remap_answers_2018 = .true. !< If true, use the order of arithmetic and expressions that - !! recover the remapping answers from 2018. If false, use more - !! robust forms of the same remapping expressions. + integer :: remap_answer_date = 99991231 !< 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. type(diag_ctrl), pointer :: diag !< Diagnostics control structure end type wave_speed_CS contains !> Calculates the wave speed of the first baroclinic mode. -subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_N2_column_fraction, & +subroutine wave_speed(h, tv, G, GV, US, cg1, CS, halo_size, use_ebt_mode, mono_N2_column_fraction, & mono_N2_depth, modal_structure) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure @@ -65,96 +77,115 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables real, dimension(SZI_(G),SZJ_(G)), intent(out) :: cg1 !< First mode internal wave speed [L T-1 ~> m s-1] type(wave_speed_CS), intent(in) :: CS !< Wave speed control struct - logical, optional, intent(in) :: full_halos !< If true, do the calculation - !! over the entire computational domain. + integer, optional, intent(in) :: halo_size !< Width of halo within which to + !! calculate wave speeds 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 which N2 is limited as monotonic - !! for the purposes of calculating vertical modal structure. + !! for the purposes of calculating vertical modal structure [nondim]. real, optional, intent(in) :: mono_N2_depth !< A depth below which N2 is limited as !! monotonic for the purposes of calculating vertical - !! modal structure [Z ~> m]. + !! modal structure [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(out) :: modal_structure !< Normalized model structure [nondim] ! Local variables real, dimension(SZK_(GV)+1) :: & - dRho_dT, & ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] - dRho_dS, & ! Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1] + dRho_dT, & ! Partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + dRho_dS, & ! Partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] + dSpV_dT, & ! Partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSpV_dS, & ! Partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1] pres, & ! Interface pressure [R L2 T-2 ~> Pa] - T_int, & ! Temperature interpolated to interfaces [degC] - S_int, & ! Salinity interpolated to interfaces [ppt] - H_top, & ! The distance of each filtered interface from the ocean surface [Z ~> m] - H_bot, & ! The distance of each filtered interface from the bottom [Z ~> m] - gprime ! The reduced gravity across each interface [L2 Z-1 T-2 ~> m s-2]. + T_int, & ! Temperature interpolated to interfaces [C ~> degC] + S_int, & ! Salinity interpolated to interfaces [S ~> ppt] + H_top, & ! The distance of each filtered interface from the ocean surface [H ~> m or kg m-2] + H_bot, & ! The distance of each filtered interface from the bottom [H ~> m or kg m-2] + gprime ! The reduced gravity across each interface [L2 H-1 T-2 ~> m s-2 or m4 s-2 kg-1]. real, dimension(SZK_(GV)) :: & Igl, Igu ! The inverse of the reduced gravity across an interface times ! the thickness of the layer below (Igl) or above (Igu) it, in [T2 L-2 ~> s2 m-2]. real, dimension(SZK_(GV),SZI_(G)) :: & - Hf, & ! Layer thicknesses after very thin layers are combined [Z ~> m] - Tf, & ! Layer temperatures after very thin layers are combined [degC] - Sf, & ! Layer salinities after very thin layers are combined [ppt] + Hf, & ! Layer thicknesses after very thin layers are combined [H ~> m or kg m-2] + Tf, & ! Layer temperatures after very thin layers are combined [C ~> degC] + Sf, & ! Layer salinities after very thin layers are combined [S ~> ppt] Rf ! Layer densities after very thin layers are combined [R ~> kg m-3] real, dimension(SZK_(GV)) :: & - Hc, & ! A column of layer thicknesses after convective istabilities are removed [Z ~> m] - Tc, & ! A column of layer temperatures after convective istabilities are removed [degC] - Sc, & ! A column of layer salinites after convective istabilities are removed [ppt] - Rc, & ! A column of layer densities after convective istabilities are removed [R ~> kg m-3] - Hc_H ! Hc(:) rescaled from Z to thickness units [H ~> m or kg m-2] - real :: I_Htot ! The inverse of the total filtered thicknesses [Z ~> m] - real :: det, ddet, detKm1, detKm2, ddetKm1, ddetKm2 + Hc, & ! A column of layer thicknesses after convective instabilities are removed [H ~> m or kg m-2] + Tc, & ! A column of layer temperatures after convective instabilities are removed [C ~> degC] + Sc, & ! A column of layer salinities after convective instabilities are removed [S ~> ppt] + Rc ! A column of layer densities after convective instabilities are removed [R ~> kg m-3] + real :: I_Htot ! The inverse of the total filtered thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: det, ddet ! Determinant of the eigen system and its derivative with lam. Because the + ! units of the eigenvalue change with the number of layers and because of the + ! dynamic rescaling that is used to keep det in a numerically representable range, + ! the units of of det are hard to interpret, but det/ddet is always in units + ! of [T2 L-2 ~> s2 m-2] real :: lam ! The eigenvalue [T2 L-2 ~> s2 m-2] real :: dlam ! The change in estimates of the eigenvalue [T2 L-2 ~> s2 m-2] real :: lam0 ! The first guess of the eigenvalue [T2 L-2 ~> s2 m-2] - real :: min_h_frac ! [nondim] - real :: Z_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 Z-1 ~> Pa m-1] + real :: H_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] real, dimension(SZI_(G)) :: & - htot, hmin, & ! Thicknesses [Z ~> m] - H_here, & ! A thickness [Z ~> m] - HxT_here, & ! A layer integrated temperature [degC Z ~> degC m] - HxS_here, & ! A layer integrated salinity [ppt Z ~> ppt m] - HxR_here ! A layer integrated density [R Z ~> kg m-2] + htot, hmin, & ! Thicknesses [H ~> m or kg m-2] + H_here, & ! A thickness [H ~> m or kg m-2] + HxT_here, & ! A layer integrated temperature [C H ~> degC m or degC kg m-2] + HxS_here, & ! A layer integrated salinity [S H ~> ppt m or ppt kg m-2] + HxR_here ! A layer integrated density [R H ~> kg m-2 or kg2 m-5] real :: speed2_tot ! overestimate of the mode-1 speed squared [L2 T-2 ~> m2 s-2] real :: cg1_min2 ! A floor in the squared first mode speed below which 0 is returned [L2 T-2 ~> m2 s-2] - real :: I_Hnew ! The inverse of a new layer thickness [Z-1 ~> m-1] - real :: drxh_sum ! The sum of density differences across interfaces times thicknesses [R Z ~> kg m-2] - real :: L2_to_Z2 ! A scaling factor squared from units of lateral distances to depths [Z2 L-2 ~> 1]. - real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 Z-1 R-1 ~> m4 s-2 kg-1]. - real :: c2_scale ! A scaling factor for wave speeds to help control the growth of the determinant - ! and its derivative with lam between rows of the Thomas algorithm solver. The - ! exact value should not matter for the final result if it is an even power of 2. + real :: cg1_est ! An initial estimate of the squared first mode speed [L2 T-2 ~> m2 s-2] + real :: I_Hnew ! The inverse of a new layer thickness [H-1 ~> m-1 or m2 kg-1] + real :: drxh_sum ! The sum of density differences across interfaces times thicknesses [R H ~> kg m-2 or kg2 m-5] + real :: dSpVxh_sum ! The sum of specific volume differences across interfaces times + ! thicknesses [H R-1 ~> m4 kg-1 or m], negative for stable stratification. + real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 H-1 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]. + real :: c2_scale ! A scaling factor for wave speeds to help control the growth of the determinant and + ! its derivative with lam between rows of the Thomas algorithm solver [L2 s2 T-2 m-2 ~> nondim]. + ! The exact value should not matter for the final result if it is an even power of 2. real :: tol_Hfrac ! Layers that together are smaller than this fraction of - ! the total water column can be merged for efficiency. + ! the total water column can be merged for efficiency [nondim]. + real :: min_h_frac ! tol_Hfrac divided by the total number of layers [nondim]. real :: tol_solve ! The fractional tolerance with which to solve for the wave speeds [nondim] real :: tol_merge ! The fractional change in estimated wave speed that is allowed ! when deciding to merge layers in the calculation [nondim] - real :: rescale, I_rescale + real :: rescale ! A rescaling factor to control the magnitude of the determinant [nondim] + real :: I_rescale ! The reciprocal of the rescaling factor to control the magnitude of the determinant [nondim] integer :: kf(SZI_(G)) ! The number of active layers after filtering. integer, parameter :: max_itt = 10 - real :: lam_it(max_itt), det_it(max_itt), ddet_it(max_itt) - logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. + real :: lam_it(max_itt) ! The guess at the eignevalue with each iteration [T2 L-2 ~> s2 m-2] + real :: det_it(max_itt), ddet_it(max_itt) ! The determinant of the matrix and its derivative with lam + ! with each iteration. Because of all of the dynamic rescaling of the determinant + ! between rows, its units are not easily interpretable, but the ratio of det/ddet + ! always has units of [T2 L-2 ~> s2 m-2] + logical :: use_EOS ! If true, density or specific volume is calculated from T & S using an equation of state. + logical :: nonBous ! If true, do not make the Boussinesq approximation. logical :: better_est ! If true, use an improved estimate of the first mode internal wave speed. logical :: merge ! If true, merge the current layer with the one above. integer :: kc ! The number of layers in the column after merging - integer :: i, j, k, k2, itt, is, ie, js, je, nz - real :: hw, sum_hc - real :: gp ! A limited local copy of gprime [L2 Z-1 T-2 ~> m s-2] - real :: N2min ! A minimum buoyancy frequency [T-2 ~> s-2] + integer :: i, j, k, k2, itt, is, ie, js, je, nz, halo + real :: hw ! The mean of the adjacent layer thicknesses [H ~> m or kg m-2] + real :: sum_hc ! The sum of the layer thicknesses [H ~> m or kg m-2] + real :: gp ! A limited local copy of gprime [L2 H-1 T-2 ~> m s-2 or m4 s-2 kg-1] + real :: N2min ! A minimum buoyancy frequency, including a slope rescaling factor [L2 H-2 T-2 ~> s-2 or m6 kg-2 s-2] + logical :: below_mono_N2_frac ! True if an interface is below the fractional depth where N2 should not increase. + logical :: below_mono_N2_depth ! True if an interface is below the absolute depth where N2 should not increase. logical :: l_use_ebt_mode, calc_modal_structure - real :: l_mono_N2_column_fraction, l_mono_N2_depth - real :: mode_struct(SZK_(GV)), ms_min, ms_max, ms_sq + real :: l_mono_N2_column_fraction ! A local value of mono_N2_column_fraction [nondim] + real :: l_mono_N2_depth ! A local value of mono_N2_column_depth [H ~> m or kg m-2] + real :: mode_struct(SZK_(GV)) ! The mode structure [nondim], but it is also temporarily + ! in units of [L2 T-2 ~> m2 s-2] after it is modified inside of tdma6. + real :: ms_min, ms_max ! The minimum and maximum mode structure values returned from tdma6 [L2 T-2 ~> m2 s-2] + real :: ms_sq ! The sum of the square of the values returned from tdma6 [L4 T-4 ~> m4 s-4] - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke ; halo = 0 - if (.not. CS%initialized) call MOM_error(FATAL, "MOM_wave_speed: "// & + if (.not. CS%initialized) call MOM_error(FATAL, "MOM_wave_speed / wave_speed: "// & "Module must be initialized before it is used.") - if (present(full_halos)) then ; if (full_halos) then - is = G%isd ; ie = G%ied ; js = G%jsd ; je = G%jed - endif ; endif - - L2_to_Z2 = US%L_to_Z**2 + if (present(halo_size)) then + halo = halo_size + is = G%isc - halo ; ie = G%iec + halo ; js = G%jsc - halo ; je = G%jec + halo + endif l_use_ebt_mode = CS%use_ebt_mode if (present(use_ebt_mode)) l_use_ebt_mode = use_ebt_mode @@ -170,9 +201,10 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ enddo ; enddo ; enddo endif - g_Rho0 = GV%g_Earth / GV%Rho0 - ! Simplifying the following could change answers at roundoff. - Z_to_pres = GV%Z_to_H * (GV%H_to_RZ * GV%g_Earth) + nonBous = .not.(GV%Boussinesq .or. GV%semi_Boussinesq) + H_to_pres = GV%H_to_RZ * GV%g_Earth + ! Note that g_Rho0 = H_to_pres / GV%Rho0**2 + if (.not.nonBous) g_Rho0 = GV%g_Earth*GV%H_to_Z / GV%Rho0 use_EOS = associated(tv%eqn_of_state) better_est = CS%better_cg1_est @@ -196,24 +228,17 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ c2_scale = US%m_s_to_L_T**2 / 4096.0**2 ! Other powers of 2 give identical results. min_h_frac = tol_Hfrac / real(nz) -!$OMP parallel do default(none) shared(is,ie,js,je,nz,h,G,GV,US,min_h_frac,use_EOS,tv,& -!$OMP calc_modal_structure,l_use_ebt_mode,modal_structure, & -!$OMP l_mono_N2_column_fraction,l_mono_N2_depth,CS, & -!$OMP Z_to_pres,cg1,g_Rho0,rescale,I_rescale,L2_to_Z2, & -!$OMP better_est,cg1_min2,tol_merge,tol_solve,c2_scale) & -!$OMP private(htot,hmin,kf,H_here,HxT_here,HxS_here,HxR_here, & -!$OMP Hf,Tf,Sf,Rf,pres,T_int,S_int,drho_dT,drho_dS, & -!$OMP drxh_sum,kc,Hc,Hc_H,tC,sc,I_Hnew,gprime,& -!$OMP Rc,speed2_tot,Igl,Igu,lam0,lam,lam_it,dlam, & -!$OMP mode_struct,sum_hc,N2min,gp,hw, & -!$OMP ms_min,ms_max,ms_sq,H_top,H_bot,I_Htot,merge, & -!$OMP det,ddet,detKm1,ddetKm1,detKm2,ddetKm2,det_it,ddet_it) + !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,tv,use_EOS,nonBous, & + !$OMP CS,min_h_frac,calc_modal_structure,l_use_ebt_mode, & + !$OMP modal_structure,l_mono_N2_column_fraction,l_mono_N2_depth, & + !$OMP H_to_pres,cg1,g_Rho0,rescale,I_rescale,cg1_min2, & + !$OMP better_est,tol_solve,tol_merge,c2_scale) do j=js,je ! First merge very thin layers with the one above (or below if they are ! at the top). This also transposes the row order so that columns can ! be worked upon one at a time. do i=is,ie ; htot(i) = 0.0 ; enddo - do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k)*GV%H_to_Z ; enddo ; enddo + do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k) ; enddo ; enddo do i=is,ie hmin(i) = htot(i)*min_h_frac ; kf(i) = 1 ; H_here(i) = 0.0 @@ -221,20 +246,20 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ enddo if (use_EOS) then do k=1,nz ; do i=is,ie - if ((H_here(i) > hmin(i)) .and. (h(i,j,k)*GV%H_to_Z > hmin(i))) then + if ((H_here(i) > hmin(i)) .and. (h(i,j,k) > hmin(i))) then Hf(kf(i),i) = H_here(i) Tf(kf(i),i) = HxT_here(i) / H_here(i) Sf(kf(i),i) = HxS_here(i) / H_here(i) kf(i) = kf(i) + 1 ! Start a new layer - H_here(i) = h(i,j,k)*GV%H_to_Z - HxT_here(i) = (h(i,j,k) * GV%H_to_Z) * tv%T(i,j,k) - HxS_here(i) = (h(i,j,k) * GV%H_to_Z) * tv%S(i,j,k) + H_here(i) = h(i,j,k) + HxT_here(i) = h(i,j,k) * tv%T(i,j,k) + HxS_here(i) = h(i,j,k) * tv%S(i,j,k) else - H_here(i) = H_here(i) + h(i,j,k)*GV%H_to_Z - HxT_here(i) = HxT_here(i) + (h(i,j,k) * GV%H_to_Z) * tv%T(i,j,k) - HxS_here(i) = HxS_here(i) + (h(i,j,k) * GV%H_to_Z) * tv%S(i,j,k) + H_here(i) = H_here(i) + h(i,j,k) + HxT_here(i) = HxT_here(i) + h(i,j,k) * tv%T(i,j,k) + HxS_here(i) = HxS_here(i) + h(i,j,k) * tv%S(i,j,k) endif enddo ; enddo do i=is,ie ; if (H_here(i) > 0.0) then @@ -242,18 +267,18 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ Tf(kf(i),i) = HxT_here(i) / H_here(i) Sf(kf(i),i) = HxS_here(i) / H_here(i) endif ; enddo - else + else ! .not. (use_EOS) do k=1,nz ; do i=is,ie - if ((H_here(i) > hmin(i)) .and. (h(i,j,k)*GV%H_to_Z > hmin(i))) then + if ((H_here(i) > hmin(i)) .and. (h(i,j,k) > hmin(i))) then Hf(kf(i),i) = H_here(i) ; Rf(kf(i),i) = HxR_here(i) / H_here(i) kf(i) = kf(i) + 1 ! Start a new layer - H_here(i) = h(i,j,k)*GV%H_to_Z - HxR_here(i) = (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) + H_here(i) = h(i,j,k) + HxR_here(i) = h(i,j,k)*GV%Rlay(k) else - H_here(i) = H_here(i) + h(i,j,k)*GV%H_to_Z - HxR_here(i) = HxR_here(i) + (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) + H_here(i) = H_here(i) + h(i,j,k) + HxR_here(i) = HxR_here(i) + h(i,j,k)*GV%Rlay(k) endif enddo ; enddo do i=is,ie ; if (H_here(i) > 0.0) then @@ -262,20 +287,25 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ endif ! From this point, we can work on individual columns without causing memory to have page faults. - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then if (use_EOS) then pres(1) = 0.0 ; H_top(1) = 0.0 do K=2,kf(i) - pres(K) = pres(K-1) + Z_to_pres*Hf(k-1,i) + pres(K) = pres(K-1) + H_to_pres*Hf(k-1,i) T_int(K) = 0.5*(Tf(k,i)+Tf(k-1,i)) S_int(K) = 0.5*(Sf(k,i)+Sf(k-1,i)) H_top(K) = H_top(K-1) + Hf(k-1,i) enddo - call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & - tv%eqn_of_state, (/2,kf(i)/) ) + if (nonBous) then + call calculate_specific_vol_derivs(T_int, S_int, pres, dSpV_dT, dSpV_dS, & + tv%eqn_of_state, (/2,kf(i)/) ) + else + call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & + tv%eqn_of_state, (/2,kf(i)/) ) + endif ! Sum the reduced gravities to find out how small a density difference is negligibly small. - drxh_sum = 0.0 + drxh_sum = 0.0 ; dSpVxh_sum = 0.0 if (better_est) then ! This is an estimate that is correct for the non-EBT mode for 2 or 3 layers, or for ! clusters of massless layers at interfaces that can be grouped into 2 or 3 layers. @@ -284,44 +314,81 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ if (H_top(kf(i)) > 0.0) then I_Htot = 1.0 / (H_top(kf(i)) + Hf(kf(i),i)) ! = 1.0 / (H_top(K) + H_bot(K)) for all K. H_bot(kf(i)+1) = 0.0 - do K=kf(i),2,-1 - H_bot(K) = H_bot(K+1) + Hf(k,i) - drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & - max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) - enddo + if (nonBous) then + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + dSpVxh_sum = dSpVxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & + min(0.0, dSpV_dT(K)*(Tf(k,i)-Tf(k-1,i)) + dSpV_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + else + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & + max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + endif endif else ! This estimate is problematic in that it goes like 1/nz for a large number of layers, ! but it is an overestimate (as desired) for a small number of layers, by at a factor ! of (H1+H2)**2/(H1*H2) >= 4 for two thick layers. - do K=2,kf(i) - drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & - max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) - enddo + if (nonBous) then + do K=2,kf(i) + dSpVxh_sum = dSpVxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & + min(0.0, dSpV_dT(K)*(Tf(k,i)-Tf(k-1,i)) + dSpV_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + else + do K=2,kf(i) + drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & + max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + endif endif - else - drxh_sum = 0.0 + else ! .not. (use_EOS) + drxh_sum = 0.0 ; dSpVxh_sum = 0.0 if (better_est) then H_top(1) = 0.0 do K=2,kf(i) ; H_top(K) = H_top(K-1) + Hf(k-1,i) ; enddo if (H_top(kf(i)) > 0.0) then I_Htot = 1.0 / (H_top(kf(i)) + Hf(kf(i),i)) ! = 1.0 / (H_top(K) + H_bot(K)) for all K. H_bot(kf(i)+1) = 0.0 - do K=kf(i),2,-1 - H_bot(K) = H_bot(K+1) + Hf(k,i) - drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * max(0.0,Rf(k,i)-Rf(k-1,i)) - enddo + if (nonBous) then + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + dSpVxh_sum = dSpVxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & + min(0.0, (Rf(k-1,i)-Rf(k,i)) / (Rf(k,i)*Rf(k-1,i))) + enddo + else + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * max(0.0,Rf(k,i)-Rf(k-1,i)) + enddo + endif endif else - do K=2,kf(i) - drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * max(0.0,Rf(k,i)-Rf(k-1,i)) - enddo + if (nonBous) then + do K=2,kf(i) + dSpVxh_sum = dSpVxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & + min(0.0, (Rf(k-1,i)-Rf(k,i)) / (Rf(k,i)*Rf(k-1,i))) + enddo + else + do K=2,kf(i) + drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * max(0.0,Rf(k,i)-Rf(k-1,i)) + enddo + endif endif + endif ! use_EOS + + if (nonBous) then + ! Note that dSpVxh_sum is negative for stable stratification. + cg1_est = H_to_pres * abs(dSpVxh_sum) + else + cg1_est = g_Rho0 * drxh_sum endif ! Find gprime across each internal interface, taking care of convective instabilities by ! merging layers. If the estimated wave speed is too small, simply return zero. - if (g_Rho0 * drxh_sum <= cg1_min2) then + if (cg1_est <= cg1_min2) then cg1(i,j) = 0.0 if (present(modal_structure)) modal_structure(i,j,:) = 0. else @@ -332,9 +399,15 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ kc = 1 Hc(1) = Hf(1,i) ; Tc(1) = Tf(1,i) ; Sc(1) = Sf(1,i) do k=2,kf(i) - if (better_est) then + if (better_est .and. nonBous) then + merge = ((dSpV_dT(K)*(Tc(kc)-Tf(k,i)) + dSpV_dS(K)*(Sc(kc)-Sf(k,i))) * & + ((Hc(kc) * Hf(k,i))*I_Htot) < abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (better_est) then merge = ((drho_dT(K)*(Tf(k,i)-Tc(kc)) + drho_dS(K)*(Sf(k,i)-Sc(kc))) * & ((Hc(kc) * Hf(k,i))*I_Htot) < 2.0 * tol_merge*drxh_sum) + elseif (nonBous) then + merge = ((dSpV_dT(K)*(Tc(kc)-Tf(k,i)) + dSpV_dS(K)*(Sc(kc)-Sf(k,i))) * & + (Hc(kc) + Hf(k,i)) < abs(2.0 * tol_merge * dSpVxh_sum)) else merge = ((drho_dT(K)*(Tf(k,i)-Tc(kc)) + drho_dS(K)*(Sf(k,i)-Sc(kc))) * & (Hc(kc) + Hf(k,i)) < 2.0 * tol_merge*drxh_sum) @@ -349,9 +422,15 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ ! that the tolerance is a factor of two larger, to avoid limit how ! far back we go. do K2=kc,2,-1 - if (better_est) then + if (better_est .and. nonBous) then + merge = ( (dSpV_dT(K2)*(Tc(k2-1)-Tc(k2)) + dSpV_dS(K2)*(Sc(k2-1)-Sc(k2))) * & + ((Hc(k2) * Hc(k2-1))*I_Htot) < abs(tol_merge * dSpVxh_sum) ) + elseif (better_est) then merge = ((drho_dT(K2)*(Tc(k2)-Tc(k2-1)) + drho_dS(K2)*(Sc(k2)-Sc(k2-1))) * & ((Hc(k2) * Hc(k2-1))*I_Htot) < tol_merge*drxh_sum) + elseif (nonBous) then + merge = ( (dSpV_dT(K2)*(Tc(k2-1)-Tc(k2)) + dSpV_dS(K2)*(Sc(k2-1)-Sc(k2))) * & + (Hc(k2) + Hc(k2-1)) < abs(tol_merge * dSpVxh_sum) ) else merge = ((drho_dT(K2)*(Tc(k2)-Tc(k2-1)) + drho_dS(K2)*(Sc(k2)-Sc(k2-1))) * & (Hc(k2) + Hc(k2-1)) < tol_merge*drxh_sum) @@ -368,20 +447,36 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ else ! Add a new layer to the column. kc = kc + 1 - drho_dS(Kc) = drho_dS(K) ; drho_dT(Kc) = drho_dT(K) + if (nonBous) then + dSpV_dS(Kc) = dSpV_dS(K) ; dSpV_dT(Kc) = dSpV_dT(K) + else + drho_dS(Kc) = drho_dS(K) ; drho_dT(Kc) = drho_dT(K) + endif Tc(kc) = Tf(k,i) ; Sc(kc) = Sf(k,i) ; Hc(kc) = Hf(k,i) endif enddo ! At this point there are kc layers and the gprimes should be positive. - do K=2,kc ! Revisit this if non-Boussinesq. - gprime(K) = g_Rho0 * (drho_dT(K)*(Tc(k)-Tc(k-1)) + drho_dS(K)*(Sc(k)-Sc(k-1))) - enddo - else ! .not.use_EOS + if (nonBous) then + do K=2,kc + gprime(K) = H_to_pres * (dSpV_dT(K)*(Tc(k-1)-Tc(k)) + dSpV_dS(K)*(Sc(k-1)-Sc(k))) + enddo + else + do K=2,kc + gprime(K) = g_Rho0 * (drho_dT(K)*(Tc(k)-Tc(k-1)) + drho_dS(K)*(Sc(k)-Sc(k-1))) + enddo + endif + else ! .not. (use_EOS) ! Do the same with density directly... kc = 1 Hc(1) = Hf(1,i) ; Rc(1) = Rf(1,i) do k=2,kf(i) - if (better_est) then + if (nonBous .and. better_est) then + merge = ((Rf(k,i) - Rc(kc)) * ((Hc(kc) * Hf(k,i))*I_Htot) < & + (Rc(kc)*Rf(k,i)) * abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (nonBous) then + merge = ((Rf(k,i) - Rc(kc)) * (Hc(kc) + Hf(k,i)) < & + (Rc(kc)*Rf(k,i)) * abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (better_est) then merge = ((Rf(k,i) - Rc(kc)) * ((Hc(kc) * Hf(k,i))*I_Htot) < 2.0*tol_merge*drxh_sum) else merge = ((Rf(k,i) - Rc(kc)) * (Hc(kc) + Hf(k,i)) < 2.0*tol_merge*drxh_sum) @@ -394,7 +489,13 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ ! that the tolerance is a factor of two larger, to avoid limit how ! far back we go. do k2=kc,2,-1 - if (better_est) then + if (nonBous .and. better_est) then + merge = ((Rc(k2) - Rc(k2-1)) * ((Hc(kc) * Hf(k,i))*I_Htot) < & + (Rc(k2-1)*Rc(k2)) * abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (nonBous) then + merge = ((Rc(k2) - Rc(k2-1)) * (Hc(kc) + Hf(k,i)) < & + (Rc(k2-1)*Rc(k2)) * abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (better_est) then merge = ((Rc(k2)-Rc(k2-1)) * ((Hc(k2) * Hc(k2-1))*I_Htot) < tol_merge*drxh_sum) else merge = ((Rc(k2)-Rc(k2-1)) * (Hc(k2)+Hc(k2-1)) < tol_merge*drxh_sum) @@ -413,9 +514,15 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ endif enddo ! At this point there are kc layers and the gprimes should be positive. - do K=2,kc ! Revisit this if non-Boussinesq. - gprime(K) = g_Rho0 * (Rc(k)-Rc(k-1)) - enddo + if (nonBous) then + do K=2,kc + gprime(K) = H_to_pres * (Rc(k) - Rc(k-1)) / (Rc(k) * Rc(k-1)) + enddo + else + do K=2,kc + gprime(K) = g_Rho0 * (Rc(k)-Rc(k-1)) + enddo + endif endif ! use_EOS ! Sum the contributions from all of the interfaces to give an over-estimate @@ -433,25 +540,40 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ if (l_use_ebt_mode) then Igu(1) = 0. ! Neumann condition for pressure modes sum_hc = Hc(1) - N2min = L2_to_Z2*gprime(2)/Hc(1) + N2min = gprime(2)/Hc(1) + + below_mono_N2_frac = .false. + below_mono_N2_depth = .false. do k=2,kc hw = 0.5*(Hc(k-1)+Hc(k)) gp = gprime(K) + if (l_mono_N2_column_fraction>0. .or. l_mono_N2_depth>=0.) then - !### Change to: if ( ((htot(i) - sum_hc < l_mono_N2_column_fraction*htot(i)) .or. & ) ) - if ( (((G%bathyT(i,j)+G%Z_ref) - sum_hc < l_mono_N2_column_fraction*(G%bathyT(i,j)+G%Z_ref)) .or. & - ((l_mono_N2_depth >= 0.) .and. (sum_hc > l_mono_N2_depth))) .and. & - (L2_to_Z2*gp > N2min*hw) ) then - ! Filters out regions where N2 increases with depth but only in a lower fraction + ! Determine whether N2 estimates should not be allowed to increase with depth. + if (l_mono_N2_column_fraction>0.) then + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + below_mono_N2_frac = & + (max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) - GV%H_to_Z * sum_hc < & + l_mono_N2_column_fraction * max(G%meanSL(i,j) + G%bathyT(i,j), 0.0)) + else + below_mono_N2_frac = (htot(i) - sum_hc < l_mono_N2_column_fraction*htot(i)) + endif + endif + if (l_mono_N2_depth >= 0.) below_mono_N2_depth = (sum_hc > l_mono_N2_depth) + + if ( (gp > N2min*hw) .and. (below_mono_N2_frac .or. below_mono_N2_depth) ) then + ! Filters out regions where N2 increases with depth, but only in a lower fraction ! of the water column or below a certain depth. - gp = US%Z_to_L**2 * (N2min*hw) + gp = N2min * hw else - N2min = L2_to_Z2 * gp/hw + N2min = gp / hw endif endif + Igu(k) = 1.0/(gp*Hc(k)) Igl(k-1) = 1.0/(gp*Hc(k-1)) sum_hc = sum_hc + Hc(k) + if (better_est) then ! Estimate that the ebt_mode is sqrt(2) times the speed of the flat bottom modes. speed2_tot = speed2_tot + 2.0 * gprime(K)*((H_top(K) * H_bot(K)) * I_Htot) @@ -524,6 +646,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ if (calc_modal_structure) then call tdma6(kc, Igu, Igl, lam, mode_struct) + ! Note that tdma6 changes the units of mode_struct to [L2 T-2 ~> m2 s-2] ms_min = mode_struct(1) ms_max = mode_struct(1) ms_sq = mode_struct(1)**2 @@ -539,6 +662,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ else mode_struct(1:kc) = mode_struct(1:kc) / sqrt( ms_sq ) endif + ! After the nondimensionalization above, mode_struct is once again [nondim] endif if (abs(dlam) < tol_solve*lam) exit @@ -553,19 +677,13 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ else mode_struct(1:kc)=0. endif - ! Note that remapping_core_h requires that the same units be used - ! for both the source and target grid thicknesses, here [H ~> m or kg m-2]. - do k = 1,kc - Hc_H(k) = GV%Z_to_H * Hc(k) - enddo - if (CS%remap_answers_2018) then - call remapping_core_h(CS%remapping_CS, kc, Hc_H(:), mode_struct, & - nz, h(i,j,:), modal_structure(i,j,:), & - 1.0e-30*GV%m_to_H, 1.0e-10*GV%m_to_H) + + if (CS%remap_answer_date < 20190101) then + 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_H(:), 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 @@ -581,7 +699,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ end subroutine wave_speed -!> Solve a non-symmetric tridiagonal problem with the sum of the upper and lower diagnonals minus a +!> Solve a non-symmetric tridiagonal problem with the sum of the upper and lower diagonals minus a !! scalar contribution as the leading diagonal. !! This uses the Thomas algorithm rather than the Hallberg algorithm since the matrix is not symmetric. subroutine tdma6(n, a, c, lam, y) @@ -589,13 +707,13 @@ subroutine tdma6(n, a, c, lam, y) real, dimension(:), intent(in) :: a !< Lower diagonal [T2 L-2 ~> s2 m-2] real, dimension(:), intent(in) :: c !< Upper diagonal [T2 L-2 ~> s2 m-2] real, intent(in) :: lam !< Scalar subtracted from leading diagonal [T2 L-2 ~> s2 m-2] - real, dimension(:), intent(inout) :: y !< RHS on entry, result on exit + real, dimension(:), intent(inout) :: y !< RHS on entry [A ~> a], result on exit [A L2 T-2 ~> a m2 s-2] ! Local variables real :: lambda ! A temporary variable in [T2 L-2 ~> s2 m-2] real :: beta(n) ! A temporary variable in [T2 L-2 ~> s2 m-2] real :: I_beta(n) ! A temporary variable in [L2 T-2 ~> m2 s-2] - real :: yy(n) ! A temporary variable with the same units as y on entry. + real :: yy(n) ! A temporary variable with the same units as y on entry [A ~> a] integer :: k, m lambda = lam @@ -632,87 +750,123 @@ subroutine tdma6(n, a, c, lam, y) end subroutine tdma6 !> Calculates the wave speeds for the first few barolinic modes. -subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - 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 - integer, intent(in) :: nmodes !< Number of modes - real, dimension(G%isd:G%ied,G%jsd:G%jed,nmodes), intent(out) :: cn !< Waves speeds [L T-1 ~> m s-1] - type(wave_speed_CS), optional, intent(in) :: CS !< Wave speed control struct - logical, optional, intent(in) :: full_halos !< If true, do the calculation - !! over the entire computational domain. +subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_struct_max, u_struct_bot, Nb, int_w2, & + int_U2, int_N2w2, halo_size) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + 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 + integer, intent(in) :: nmodes !< Number of modes + type(wave_speed_CS), intent(in) :: CS !< Wave speed control struct + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1,nmodes),intent(out) :: w_struct !< Wave vertical velocity profile [nondim] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV),nmodes),intent(out) :: u_struct !< Wave horizontal velocity profile + !! [Z-1 ~> m-1] + real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: cn !< Waves speeds [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: u_struct_max !< Maximum of wave horizontal velocity + !! profile [Z-1 ~> m-1] + real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: u_struct_bot !< Bottom value of wave horizontal + !! velocity profile [Z-1 ~> m-1] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: Nb !< Bottom value of buoyancy freqency + !! [T-1 ~> s-1] + real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: int_w2 !< depth-integrated vertical velocity + !! profile squared [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: int_U2 !< depth-integrated horizontal velocity + !! profile squared [H Z-2 ~> m-1 or kg m-4] + real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: int_N2w2 !< depth-integrated buoyancy frequency + !! times vertical velocity profile + !! squared [H T-2 ~> m s-2 or kg m-2 s-2] + integer, optional, intent(in) :: halo_size !< Width of halo within which to + !! calculate wave speeds ! Local variables real, dimension(SZK_(GV)+1) :: & - dRho_dT, & ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] - dRho_dS, & ! Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1] + dRho_dT, & ! Partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + dRho_dS, & ! Partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] + dSpV_dT, & ! Partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSpV_dS, & ! Partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1] pres, & ! Interface pressure [R L2 T-2 ~> Pa] - T_int, & ! Temperature interpolated to interfaces [degC] - S_int, & ! Salinity interpolated to interfaces [ppt] - H_top, & ! The distance of each filtered interface from the ocean surface [Z ~> m] - H_bot, & ! The distance of each filtered interface from the bottom [Z ~> m] - gprime ! The reduced gravity across each interface [L2 Z-1 T-2 ~> m s-2]. + T_int, & ! Temperature interpolated to interfaces [C ~> degC] + S_int, & ! Salinity interpolated to interfaces [S ~> ppt] + H_top, & ! The distance of each filtered interface from the ocean surface [H ~> m or kg m-2] + H_bot, & ! The distance of each filtered interface from the bottom [H ~> m or kg m-2] + gprime, & ! The reduced gravity across each interface [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + N2 ! The buoyancy freqency squared [T-2 ~> s-2] real, dimension(SZK_(GV),SZI_(G)) :: & - Hf, & ! Layer thicknesses after very thin layers are combined [Z ~> m] - Tf, & ! Layer temperatures after very thin layers are combined [degC] - Sf, & ! Layer salinities after very thin layers are combined [ppt] + Hf, & ! Layer thicknesses after very thin layers are combined [H ~> m or kg m-2] + dzf, & ! Layer vertical extents after very thin layers are combined [Z ~> m] + Tf, & ! Layer temperatures after very thin layers are combined [C ~> degC] + Sf, & ! Layer salinities after very thin layers are combined [S ~> ppt] Rf ! Layer densities after very thin layers are combined [R ~> kg m-3] + real, dimension(SZI_(G),SZK_(GV)) :: & + dz_2d ! Height change across layers [Z ~> m] real, dimension(SZK_(GV)) :: & Igl, Igu, & ! The inverse of the reduced gravity across an interface times ! the thickness of the layer below (Igl) or above (Igu) it, in [T2 L-2 ~> s2 m-2]. - Hc, & ! A column of layer thicknesses after convective istabilities are removed [Z ~> m] - Tc, & ! A column of layer temperatures after convective istabilities are removed [degC] - Sc, & ! A column of layer salinites after convective istabilities are removed [ppt] - Rc ! A column of layer densities after convective istabilities are removed [R ~> kg m-3] - real :: I_Htot ! The inverse of the total filtered thicknesses [Z ~> m] - real :: c1_thresh ! if c1 is below this value, don't bother calculating - ! cn values for higher modes [L T-1 ~> m s-1] - real :: c2_scale ! A scaling factor for wave speeds to help control the growth of the determinant - ! and its derivative with lam between rows of the Thomas algorithm solver. The - ! exact value should not matter for the final result if it is an even power of 2. - real :: det, ddet ! determinant & its derivative of eigen system + Hc, & ! A column of layer thicknesses after convective instabilities are removed [H ~> m or kg m-2] + dzc, & ! A column of layer vertical extents after convective instabilities are removed [Z ~> m] + Tc, & ! A column of layer temperatures after convective instabilities are removed [C ~> degC] + Sc, & ! A column of layer salinities after convective instabilities are removed [S ~> ppt] + Rc ! A column of layer densities after convective instabilities are removed [R ~> kg m-3] + real :: I_Htot ! The inverse of the total filtered thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: c2_scale ! A scaling factor for wave speeds to help control the growth of the determinant and its + ! derivative with lam between rows of the Thomas algorithm solver [L2 s2 T-2 m-2 ~> nondim]. + ! The exact value should not matter for the final result if it is an even power of 2. + real :: det, ddet ! Determinant of the eigen system and its derivative with lam. Because the + ! units of the eigenvalue change with the number of layers and because of the + ! dynamic rescaling that is used to keep det in a numerically representable range, + ! the units of of det are hard to interpret, but det/ddet is always in units + ! of [T2 L-2 ~> s2 m-2] real :: lam_1 ! approximate mode-1 eigenvalue [T2 L-2 ~> s2 m-2] real :: lam_n ! approximate mode-n eigenvalue [T2 L-2 ~> s2 m-2] real :: dlam ! The change in estimates of the eigenvalue [T2 L-2 ~> s2 m-2] real :: lamMin ! minimum lam value for root searching range [T2 L-2 ~> s2 m-2] real :: lamMax ! maximum lam value for root searching range [T2 L-2 ~> s2 m-2] real :: lamInc ! width of moving window for root searching [T2 L-2 ~> s2 m-2] - real :: det_l,det_r ! determinant value at left and right of window - real :: ddet_l,ddet_r ! derivative of determinant at left and right of window - real :: det_sub,ddet_sub! derivative of determinant at subinterval endpoint - real :: xl,xr ! lam guesses at left and right of window [T2 L-2 ~> s2 m-2] + real :: det_l, ddet_l ! determinant of the eigensystem and its derivative with lam at the lower + ! end of the range of values bracketing a particular root, in dynamically + ! rescaled units that may differ from the other det variables, but such + ! that the units of det_l/ddet_l are [T2 L-2 ~> s2 m-2] + real :: det_r, ddet_r ! determinant and its derivative with lam at the lower end of the + ! bracket in arbitrarily rescaled units, but such that the units of + ! det_r/ddet_r are [T2 L-2 ~> s2 m-2] + real :: det_sub, ddet_sub ! determinant and its derivative with lam at a subinterval endpoint that + ! is a candidate for a new bracket endpoint in arbitrarily rescaled units, + ! but such that the units of det_sub/ddet_sub are [T2 L-2 ~> s2 m-2] + real :: xl, xr ! lam guesses at left and right of window [T2 L-2 ~> s2 m-2] real :: xl_sub ! lam guess at left of subinterval window [T2 L-2 ~> s2 m-2] - real,dimension(nmodes) :: & - xbl,xbr ! lam guesses bracketing a zero-crossing (root) [T2 L-2 ~> s2 m-2] + real, dimension(nmodes) :: & + xbl, xbr ! lam guesses bracketing a zero-crossing (root) [T2 L-2 ~> s2 m-2] integer :: numint ! number of widows (intervals) in root searching range integer :: nrootsfound ! number of extra roots found (not including 1st root) - real :: Z_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 Z-1 ~> Pa m-1] + real :: H_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] real, dimension(SZI_(G)) :: & - htot, hmin, & ! Thicknesses [Z ~> m] - H_here, & ! A thickness [Z ~> m] - HxT_here, & ! A layer integrated temperature [degC Z ~> degC m] - HxS_here, & ! A layer integrated salinity [ppt Z ~> ppt m] - HxR_here ! A layer integrated density [R Z ~> kg m-2] + htot, hmin, & ! Thicknesses [H ~> m or kg m-2] + H_here, & ! A layer thickness [H ~> m or kg m-2] + dz_here, & ! A layer vertical extent [Z ~> m] + HxT_here, & ! A layer integrated temperature [C H ~> degC m or degC kg m-2] + HxS_here, & ! A layer integrated salinity [S H ~> ppt m or ppt kg m-2] + HxR_here ! A layer integrated density [R H ~> kg m-2 or kg2 m-5] real :: speed2_tot ! overestimate of the mode-1 speed squared [L2 T-2 ~> m2 s-2] real :: speed2_min ! minimum mode speed (squared) to consider in root searching [L2 T-2 ~> m2 s-2] - real :: cg1_min2 ! A floor in the squared first mode speed below which 0 is returned [L2 T-2 ~> m2 s-2] - real, parameter :: reduct_factor = 0.5 - ! A factor used in setting speed2_min [nondim] - real :: I_Hnew ! The inverse of a new layer thickness [Z-1 ~> m-1] - real :: drxh_sum ! The sum of density differences across interfaces times thicknesses [R Z ~> kg m-2] - real, pointer, dimension(:,:,:) :: T => NULL(), S => NULL() - real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 Z-1 R-1 ~> m4 s-2 kg-1]. + real :: cg1_min2 ! A floor in the squared first mode speed below which 0 is returned [L2 T-2 ~> m2 s-2] + real :: cg1_est ! An initial estimate of the squared first mode speed [L2 T-2 ~> m2 s-2] + real, parameter :: reduct_factor = 0.5 ! A factor used in setting speed2_min [nondim] + real :: I_Hnew ! The inverse of a new layer thickness [H-1 ~> m-1 or m2 kg-1] + real :: drxh_sum ! The sum of density differences across interfaces times thicknesses [R H ~> kg m-2 or kg2 m-5] + real :: dSpVxh_sum ! The sum of specific volume differences across interfaces times + ! thicknesses [H R-1 ~> m4 kg-1 or m], negative for stable stratification. + real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 H-1 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]. real :: tol_Hfrac ! Layers that together are smaller than this fraction of - ! the total water column can be merged for efficiency. + ! the total water column can be merged for efficiency [nondim]. real :: min_h_frac ! tol_Hfrac divided by the total number of layers [nondim]. real :: tol_solve ! The fractional tolerance with which to solve for the wave speeds [nondim]. real :: tol_merge ! The fractional change in estimated wave speed that is allowed ! when deciding to merge layers in the calculation [nondim] integer :: kf(SZI_(G)) ! The number of active layers after filtering. - integer, parameter :: max_itt = 10 - logical :: use_EOS ! If true, density is calculated from T & S using the equation of state. + integer, parameter :: max_itt = 30 + logical :: use_EOS ! If true, density or specific volume is calculated from T & S using the equation of state. + logical :: nonBous ! If true, do not make the Boussinesq approximation. logical :: better_est ! If true, use an improved estimate of the first mode internal wave speed. logical :: merge ! If true, merge the current layer with the one above. integer :: nsub ! number of subintervals used for root finding @@ -722,113 +876,149 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) logical :: sub_rootfound ! if true, subdivision has located root integer :: kc ! The number of layers in the column after merging integer :: sub, sub_it - integer :: i, j, k, k2, itt, is, ie, js, je, nz, row, iint, m, ig, jg - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - - if (present(CS)) then - if (.not. CS%initialized) call MOM_error(FATAL, "MOM_wave_speed: "// & - "Module must be initialized before it is used.") + integer :: i, j, k, k2, itt, is, ie, js, je, nz, iint, m, halo + real, dimension(SZK_(GV)+1) :: modal_structure !< Normalized model structure [nondim] + real, dimension(SZK_(GV)) :: modal_structure_fder !< Normalized model structure [Z-1 ~> m-1] + real :: mode_struct(SZK_(GV)+1) ! The mode structure [nondim], but it is also temporarily + ! in units of [L2 T-2 ~> m2 s-2] after it is modified inside of tdma6. + real :: mode_struct_fder(SZK_(GV)) ! The mode structure 1st derivative [Z-1 ~> m-1], but it is also temporarily + ! in units of [L2 Z-1 T-2 ~> m s-2] after it is modified inside of tdma6. + real :: mode_struct_sq(SZK_(GV)+1) ! The square of mode structure [nondim] + real :: mode_struct_fder_sq(SZK_(GV)) ! The square of mode structure 1st derivative [Z-2 ~> m-2] + + real :: w2avg ! A total for renormalization [H L4 T-4 ~> m5 s-4 or kg m2 s-4] + real, parameter :: a_int = 0.5 ! Integral total for normalization [nondim] + real :: renorm ! Normalization factor [T2 L-2 ~> s2 m-2] + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke ; halo = 0 + + if (.not. CS%initialized) call MOM_error(FATAL, "MOM_wave_speed / wave_speeds: "// & + "Module must be initialized before it is used.") + + if (present(halo_size)) then + halo = halo_size + is = G%isc - halo ; ie = G%iec + halo ; js = G%jsc - halo ; je = G%jec + halo endif - if (present(full_halos)) then ; if (full_halos) then - is = G%isd ; ie = G%ied ; js = G%jsd ; je = G%jed - endif ; endif - - S => tv%S ; T => tv%T - g_Rho0 = GV%g_Earth / GV%Rho0 - ! Simplifying the following could change answers at roundoff. - Z_to_pres = GV%Z_to_H * (GV%H_to_RZ * GV%g_Earth) + nonBous = .not.(GV%Boussinesq .or. GV%semi_Boussinesq) + H_to_pres = GV%H_to_RZ * GV%g_Earth + if (.not.nonBous) g_Rho0 = GV%g_Earth * GV%H_to_Z / GV%Rho0 use_EOS = associated(tv%eqn_of_state) - c1_thresh = 0.01*US%m_s_to_L_T + + if (CS%c1_thresh < 0.0) & + call MOM_error(FATAL, "INTERNAL_WAVE_CG1_THRESH must be set to a non-negative "//& + "value via wave_speed_init for wave_speeds to be used.") c2_scale = US%m_s_to_L_T**2 / 4096.0**2 ! Other powers of 2 give identical results. - better_est = .false. ; if (present(CS)) better_est = CS%better_cg1_est + better_est = CS%better_cg1_est if (better_est) then - tol_solve = 0.001 ; if (present(CS)) tol_solve = CS%wave_speed_tol + tol_solve = CS%wave_speed_tol tol_Hfrac = 0.1*tol_solve ; tol_merge = tol_solve / real(nz) else tol_solve = 0.001 ; tol_Hfrac = 0.0001 ; tol_merge = 0.001 endif - cg1_min2 = 0.0 ; if (present(CS)) cg1_min2 = CS%min_speed2 + cg1_min2 = CS%min_speed2 - ! Zero out all wave speeds. Values over land or for columns that are too weakly stratified + ! Zero out all local values. Values over land or for columns that are too weakly stratified ! are not changed from this zero value. cn(:,:,:) = 0.0 + u_struct_max(:,:,:) = 0.0 + u_struct_bot(:,:,:) = 0.0 + Nb(:,:) = 0.0 + int_w2(:,:,:) = 0.0 + int_N2w2(:,:,:) = 0.0 + int_U2(:,:,:) = 0.0 + u_struct(:,:,:,:) = 0.0 + w_struct(:,:,:,:) = 0.0 min_h_frac = tol_Hfrac / real(nz) - !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,min_h_frac,use_EOS,T,S, & - !$OMP Z_to_pres,tv,cn,g_Rho0,nmodes,cg1_min2,better_est, & - !$OMP c1_thresh,tol_solve,tol_merge) + !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,CS,use_EOS,nonBous, & + !$OMP min_h_frac,H_to_pres,tv,cn,g_Rho0,nmodes,cg1_min2, & + !$OMP better_est,tol_solve,tol_merge,c2_scale) do j=js,je ! First merge very thin layers with the one above (or below if they are ! at the top). This also transposes the row order so that columns can ! be worked upon one at a time. do i=is,ie ; htot(i) = 0.0 ; enddo - do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k)*GV%H_to_Z ; enddo ; enddo + do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k) ; enddo ; enddo + + call thickness_to_dz(h, tv, dz_2d, j, G, GV, halo_size=halo) do i=is,ie - hmin(i) = htot(i)*min_h_frac ; kf(i) = 1 ; H_here(i) = 0.0 + hmin(i) = htot(i)*min_h_frac ; kf(i) = 1 ; H_here(i) = 0.0 ; dz_here(i) = 0.0 HxT_here(i) = 0.0 ; HxS_here(i) = 0.0 ; HxR_here(i) = 0.0 enddo if (use_EOS) then do k=1,nz ; do i=is,ie - if ((H_here(i) > hmin(i)) .and. (h(i,j,k)*GV%H_to_Z > hmin(i))) then + if ((H_here(i) > hmin(i)) .and. (h(i,j,k) > hmin(i))) then Hf(kf(i),i) = H_here(i) + dzf(kf(i),i) = dz_here(i) Tf(kf(i),i) = HxT_here(i) / H_here(i) Sf(kf(i),i) = HxS_here(i) / H_here(i) kf(i) = kf(i) + 1 ! Start a new layer - H_here(i) = h(i,j,k)*GV%H_to_Z - HxT_here(i) = (h(i,j,k)*GV%H_to_Z)*T(i,j,k) - HxS_here(i) = (h(i,j,k)*GV%H_to_Z)*S(i,j,k) + H_here(i) = h(i,j,k) + dz_here(i) = dz_2d(i,k) + HxT_here(i) = h(i,j,k)*tv%T(i,j,k) + HxS_here(i) = h(i,j,k)*tv%S(i,j,k) else - H_here(i) = H_here(i) + h(i,j,k)*GV%H_to_Z - HxT_here(i) = HxT_here(i) + (h(i,j,k)*GV%H_to_Z)*T(i,j,k) - HxS_here(i) = HxS_here(i) + (h(i,j,k)*GV%H_to_Z)*S(i,j,k) + H_here(i) = H_here(i) + h(i,j,k) + dz_here(i) = dz_here(i) + dz_2d(i,k) + HxT_here(i) = HxT_here(i) + h(i,j,k)*tv%T(i,j,k) + HxS_here(i) = HxS_here(i) + h(i,j,k)*tv%S(i,j,k) endif enddo ; enddo do i=is,ie ; if (H_here(i) > 0.0) then Hf(kf(i),i) = H_here(i) + dzf(kf(i),i) = dz_here(i) Tf(kf(i),i) = HxT_here(i) / H_here(i) Sf(kf(i),i) = HxS_here(i) / H_here(i) endif ; enddo - else + else ! .not. (use_EOS) do k=1,nz ; do i=is,ie - if ((H_here(i) > hmin(i)) .and. (h(i,j,k)*GV%H_to_Z > hmin(i))) then + if ((H_here(i) > hmin(i)) .and. (h(i,j,k) > hmin(i))) then Hf(kf(i),i) = H_here(i) ; Rf(kf(i),i) = HxR_here(i) / H_here(i) + dzf(kf(i),i) = dz_here(i) kf(i) = kf(i) + 1 ! Start a new layer - H_here(i) = h(i,j,k)*GV%H_to_Z - HxR_here(i) = (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) + H_here(i) = h(i,j,k) + dz_here(i) = dz_2d(i,k) + HxR_here(i) = h(i,j,k)*GV%Rlay(k) else - H_here(i) = H_here(i) + h(i,j,k)*GV%H_to_Z - HxR_here(i) = HxR_here(i) + (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) + H_here(i) = H_here(i) + h(i,j,k) + dz_here(i) = dz_here(i) + dz_2d(i,k) + HxR_here(i) = HxR_here(i) + h(i,j,k)*GV%Rlay(k) endif enddo ; enddo do i=is,ie ; if (H_here(i) > 0.0) then Hf(kf(i),i) = H_here(i) ; Rf(kf(i),i) = HxR_here(i) / H_here(i) + dzf(kf(i),i) = dz_here(i) endif ; enddo endif ! From this point, we can work on individual columns without causing memory to have page faults. do i=is,ie - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then if (use_EOS) then pres(1) = 0.0 ; H_top(1) = 0.0 do K=2,kf(i) - pres(K) = pres(K-1) + Z_to_pres*Hf(k-1,i) + pres(K) = pres(K-1) + H_to_pres*Hf(k-1,i) T_int(K) = 0.5*(Tf(k,i)+Tf(k-1,i)) S_int(K) = 0.5*(Sf(k,i)+Sf(k-1,i)) H_top(K) = H_top(K-1) + Hf(k-1,i) enddo - call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & - tv%eqn_of_state, (/2,kf(i)/) ) + if (nonBous) then + call calculate_specific_vol_derivs(T_int, S_int, pres, dSpV_dT, dSpV_dS, & + tv%eqn_of_state, (/2,kf(i)/) ) + else + call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & + tv%eqn_of_state, (/2,kf(i)/) ) + endif ! Sum the reduced gravities to find out how small a density difference is negligibly small. - drxh_sum = 0.0 + drxh_sum = 0.0 ; dSpVxh_sum = 0.0 if (better_est) then ! This is an estimate that is correct for the non-EBT mode for 2 or 3 layers, or for ! clusters of massless layers at interfaces that can be grouped into 2 or 3 layers. @@ -837,33 +1027,56 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) if (H_top(kf(i)) > 0.0) then I_Htot = 1.0 / (H_top(kf(i)) + Hf(kf(i),i)) ! = 1.0 / (H_top(K) + H_bot(K)) for all K. H_bot(kf(i)+1) = 0.0 - do K=kf(i),2,-1 - H_bot(K) = H_bot(K+1) + Hf(k,i) - drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & - max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) - enddo + if (nonBous) then + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + dSpVxh_sum = dSpVxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & + min(0.0, dSpV_dT(K)*(Tf(k,i)-Tf(k-1,i)) + dSpV_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + else + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & + max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + endif endif else ! This estimate is problematic in that it goes like 1/nz for a large number of layers, ! but it is an overestimate (as desired) for a small number of layers, by at a factor ! of (H1+H2)**2/(H1*H2) >= 4 for two thick layers. - do K=2,kf(i) - drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & - max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) - enddo + if (nonBous) then + do K=2,kf(i) + dSpVxh_sum = dSpVxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & + min(0.0, dSpV_dT(K)*(Tf(k,i)-Tf(k-1,i)) + dSpV_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + else + do K=2,kf(i) + drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & + max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + endif endif - else - drxh_sum = 0.0 + else ! Not use_EOS + drxh_sum = 0.0 ; dSpVxh_sum = 0.0 if (better_est) then H_top(1) = 0.0 do K=2,kf(i) ; H_top(K) = H_top(K-1) + Hf(k-1,i) ; enddo if (H_top(kf(i)) > 0.0) then I_Htot = 1.0 / (H_top(kf(i)) + Hf(kf(i),i)) ! = 1.0 / (H_top(K) + H_bot(K)) for all K. H_bot(kf(i)+1) = 0.0 - do K=kf(i),2,-1 - H_bot(K) = H_bot(K+1) + Hf(k,i) - drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * max(0.0,Rf(k,i)-Rf(k-1,i)) - enddo + if (nonBous) then + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + dSpVxh_sum = dSpVxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & + min(0.0, (Rf(k-1,i)-Rf(k,i)) / (Rf(k,i)*Rf(k-1,i))) + enddo + else + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * max(0.0,Rf(k,i)-Rf(k-1,i)) + enddo + endif endif else do K=2,kf(i) @@ -872,19 +1085,32 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) endif endif + if (nonBous) then + ! Note that dSpVxh_sum is negative for stable stratification. + cg1_est = H_to_pres * abs(dSpVxh_sum) + else + cg1_est = g_Rho0 * drxh_sum + endif + ! Find gprime across each internal interface, taking care of convective ! instabilities by merging layers. - if (g_Rho0 * drxh_sum > cg1_min2) then + if (cg1_est > cg1_min2) then ! Merge layers to eliminate convective instabilities or exceedingly ! small reduced gravities. Merging layers reduces the estimated wave speed by ! (rho(2)-rho(1))*h(1)*h(2) / H_tot. if (use_EOS) then kc = 1 - Hc(1) = Hf(1,i) ; Tc(1) = Tf(1,i) ; Sc(1) = Sf(1,i) + Hc(1) = Hf(1,i) ; dzc(1) = dzf(1,i) ; Tc(1) = Tf(1,i) ; Sc(1) = Sf(1,i) do k=2,kf(i) - if (better_est) then + if (better_est .and. nonBous) then + merge = ((dSpV_dT(K)*(Tc(kc)-Tf(k,i)) + dSpV_dS(K)*(Sc(kc)-Sf(k,i))) * & + ((Hc(kc) * Hf(k,i))*I_Htot) < abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (better_est) then merge = ((drho_dT(K)*(Tf(k,i)-Tc(kc)) + drho_dS(K)*(Sf(k,i)-Sc(kc))) * & ((Hc(kc) * Hf(k,i))*I_Htot) < 2.0 * tol_merge*drxh_sum) + elseif (nonBous) then + merge = ((dSpV_dT(K)*(Tc(kc)-Tf(k,i)) + dSpV_dS(K)*(Sc(kc)-Sf(k,i))) * & + (Hc(kc) + Hf(k,i)) < abs(2.0 * tol_merge * dSpVxh_sum)) else merge = ((drho_dT(K)*(Tf(k,i)-Tc(kc)) + drho_dS(K)*(Sf(k,i)-Sc(kc))) * & (Hc(kc) + Hf(k,i)) < 2.0 * tol_merge*drxh_sum) @@ -894,14 +1120,21 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) I_Hnew = 1.0 / (Hc(kc) + Hf(k,i)) Tc(kc) = (Hc(kc)*Tc(kc) + Hf(k,i)*Tf(k,i)) * I_Hnew Sc(kc) = (Hc(kc)*Sc(kc) + Hf(k,i)*Sf(k,i)) * I_Hnew - Hc(kc) = (Hc(kc) + Hf(k,i)) + Hc(kc) = Hc(kc) + Hf(k,i) + dzc(kc) = dzc(kc) + dzf(k,i) ! Backtrack to remove any convective instabilities above... Note ! that the tolerance is a factor of two larger, to avoid limit how ! far back we go. do K2=kc,2,-1 - if (better_est) then + if (better_est .and. nonBous) then + merge = ( (dSpV_dT(K2)*(Tc(k2-1)-Tc(k2)) + dSpV_dS(K2)*(Sc(k2-1)-Sc(k2))) * & + ((Hc(k2) * Hc(k2-1))*I_Htot) < abs(tol_merge * dSpVxh_sum) ) + elseif (better_est) then merge = ((drho_dT(K2)*(Tc(k2)-Tc(k2-1)) + drho_dS(K2)*(Sc(k2)-Sc(k2-1))) * & ((Hc(k2) * Hc(k2-1))*I_Htot) < tol_merge*drxh_sum) + elseif (nonBous) then + merge = ( (dSpV_dT(K2)*(Tc(k2-1)-Tc(k2)) + dSpV_dS(K2)*(Sc(k2-1)-Sc(k2))) * & + (Hc(k2) + Hc(k2-1)) < abs(tol_merge * dSpVxh_sum) ) else merge = ((drho_dT(K2)*(Tc(k2)-Tc(k2-1)) + drho_dS(K2)*(Sc(k2)-Sc(k2-1))) * & (Hc(k2) + Hc(k2-1)) < tol_merge*drxh_sum) @@ -911,35 +1144,53 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) I_Hnew = 1.0 / (Hc(kc) + Hc(kc-1)) Tc(kc-1) = (Hc(kc)*Tc(kc) + Hc(kc-1)*Tc(kc-1)) * I_Hnew Sc(kc-1) = (Hc(kc)*Sc(kc) + Hc(kc-1)*Sc(kc-1)) * I_Hnew - Hc(kc-1) = (Hc(kc) + Hc(kc-1)) + Hc(kc-1) = Hc(kc) + Hc(kc-1) + dzc(kc-1) = dzc(kc) + dzc(kc-1) kc = kc - 1 else ; exit ; endif enddo else ! Add a new layer to the column. kc = kc + 1 - drho_dS(Kc) = drho_dS(K) ; drho_dT(Kc) = drho_dT(K) - Tc(kc) = Tf(k,i) ; Sc(kc) = Sf(k,i) ; Hc(kc) = Hf(k,i) + if (nonBous) then + dSpV_dS(Kc) = dSpV_dS(K) ; dSpV_dT(Kc) = dSpV_dT(K) + else + drho_dS(Kc) = drho_dS(K) ; drho_dT(Kc) = drho_dT(K) + endif + Tc(kc) = Tf(k,i) ; Sc(kc) = Sf(k,i) ; Hc(kc) = Hf(k,i) ; dzc(kc) = dzf(k,i) endif enddo ! At this point there are kc layers and the gprimes should be positive. - do K=2,kc ! Revisit this if non-Boussinesq. - gprime(K) = g_Rho0 * (drho_dT(K)*(Tc(k)-Tc(k-1)) + drho_dS(K)*(Sc(k)-Sc(k-1))) - enddo - else ! .not.use_EOS + if (nonBous) then + do K=2,kc + gprime(K) = H_to_pres * (dSpV_dT(K)*(Tc(k-1)-Tc(k)) + dSpV_dS(K)*(Sc(k-1)-Sc(k))) + enddo + else + do K=2,kc + gprime(K) = g_Rho0 * (drho_dT(K)*(Tc(k)-Tc(k-1)) + drho_dS(K)*(Sc(k)-Sc(k-1))) + enddo + endif + else ! .not. (use_EOS) ! Do the same with density directly... kc = 1 - Hc(1) = Hf(1,i) ; Rc(1) = Rf(1,i) + Hc(1) = Hf(1,i) ; dzc(1) = dzf(1,i) ; Rc(1) = Rf(1,i) do k=2,kf(i) - if (better_est) then - merge = ((Rf(k,i) - Rc(kc)) * ((Hc(kc) * Hf(k,i))*I_Htot) < 2.0 * tol_merge*drxh_sum) + if (nonBous .and. better_est) then + merge = ((Rf(k,i) - Rc(kc)) * ((Hc(kc) * Hf(k,i))*I_Htot) < & + (Rc(kc)*Rf(k,i)) * abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (nonBous) then + merge = ((Rf(k,i) - Rc(kc)) * (Hc(kc) + Hf(k,i)) < & + (Rc(kc)*Rf(k,i)) * abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (better_est) then + merge = ((Rf(k,i) - Rc(kc)) * ((Hc(kc) * Hf(k,i))*I_Htot) < 2.0*tol_merge*drxh_sum) else merge = ((Rf(k,i) - Rc(kc)) * (Hc(kc) + Hf(k,i)) < 2.0*tol_merge*drxh_sum) endif if (merge) then ! Merge this layer with the one above and backtrack. Rc(kc) = (Hc(kc)*Rc(kc) + Hf(k,i)*Rf(k,i)) / (Hc(kc) + Hf(k,i)) - Hc(kc) = (Hc(kc) + Hf(k,i)) + Hc(kc) = Hc(kc) + Hf(k,i) + dzc(kc) = dzc(kc) + dzf(k,i) ! Backtrack to remove any convective instabilities above... Note ! that the tolerance is a factor of two larger, to avoid limit how ! far back we go. @@ -952,20 +1203,27 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) if (merge) then ! Merge the two bottommost layers. At this point kc = k2. Rc(kc-1) = (Hc(kc)*Rc(kc) + Hc(kc-1)*Rc(kc-1)) / (Hc(kc) + Hc(kc-1)) - Hc(kc-1) = (Hc(kc) + Hc(kc-1)) + Hc(kc-1) = Hc(kc) + Hc(kc-1) + dzc(kc-1) = dzc(kc) + dzc(kc-1) kc = kc - 1 else ; exit ; endif enddo else ! Add a new layer to the column. kc = kc + 1 - Rc(kc) = Rf(k,i) ; Hc(kc) = Hf(k,i) + Rc(kc) = Rf(k,i) ; Hc(kc) = Hf(k,i) ; dzc(kc) = dzf(k,i) endif enddo ! At this point there are kc layers and the gprimes should be positive. - do K=2,kc ! Revisit this if non-Boussinesq. - gprime(K) = g_Rho0 * (Rc(k)-Rc(k-1)) - enddo + if (nonBous) then + do K=2,kc + gprime(K) = H_to_pres * (Rc(k) - Rc(k-1)) / (Rc(k) * Rc(k-1)) + enddo + else + do K=2,kc + gprime(K) = g_Rho0 * (Rc(k)-Rc(k-1)) + enddo + endif endif ! use_EOS !-----------------NOW FIND WAVE SPEEDS--------------------------------------- @@ -985,8 +1243,18 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! Calculate Igu, Igl, depth, and N2 at each interior interface ! [excludes surface (K=1) and bottom (K=kc+1)] + Igl(:) = 0. + Igu(:) = 0. + N2(:) = 0. + do K=2,kc - Igl(K) = 1.0/(gprime(K)*Hc(k)) ; Igu(K) = 1.0/(gprime(K)*Hc(k-1)) + Igl(K) = 1.0 / (gprime(K)*Hc(k)) ; Igu(K) = 1.0 / (gprime(K)*Hc(k-1)) + if (nonBous) then + N2(K) = 2.0*US%L_to_Z**2*gprime(K) * (Hc(k) + Hc(k-1)) / & ! Units are [T-2 ~> s-2] + (dzc(k) + dzc(k-1))**2 + else + N2(K) = 2.0*US%L_to_Z**2*GV%Z_to_H*gprime(K) / (dzc(k) + dzc(k-1)) ! Units are [T-2 ~> s-2] + endif if (better_est) then speed2_tot = speed2_tot + gprime(K)*((H_top(K) * H_bot(K)) * I_Htot) else @@ -994,9 +1262,21 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) endif enddo + ! Set stratification for surface and bottom (setting equal to nearest interface for now) + N2(1) = N2(2) ; N2(kc+1) = N2(kc) + ! set bottom stratification + Nb(i,j) = sqrt(N2(kc+1)) + ! Under estimate the first eigenvalue (overestimate the speed) to start with. lam_1 = 1.0 / speed2_tot + ! init and first guess for mode structure + mode_struct(:) = 0. + mode_struct_fder(:) = 0. + mode_struct(2:kc) = 1. ! Uniform flow, first guess + modal_structure(:) = 0. + modal_structure_fder(:) = 0. + ! Find the first eigen value do itt=1,max_itt ! calculate the determinant of (A-lam_1*I) @@ -1014,15 +1294,85 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) lam_1 = lam_1 + dlam endif + call tdma6(kc-1, Igu(2:kc), Igl(2:kc), lam_1, mode_struct(2:kc)) + ! Note that tdma6 changes the units of mode_struct to [L2 T-2 ~> m2 s-2] + ! apply BC + mode_struct(1) = 0. + mode_struct(kc+1) = 0. + + ! renormalization of the integral of the profile + w2avg = 0.0 + do k=1,kc + w2avg = w2avg + 0.5*(mode_struct(K)**2+mode_struct(K+1)**2)*Hc(k) ! [H L4 T-4 ~> m5 s-4 or kg m2 s-4] + enddo + renorm = sqrt(htot(i)*a_int/w2avg) ! [T2 L-2 ~> s2 m-2] + do K=1,kc+1 ; mode_struct(K) = renorm * mode_struct(K) ; enddo + ! after renorm, mode_struct is again [nondim] if (abs(dlam) < tol_solve*lam_1) exit enddo if (lam_1 > 0.0) cn(i,j,1) = 1.0 / sqrt(lam_1) + ! sign of wave structure is irrelevant, flip to positive if needed + if (mode_struct(2)<0.) then + mode_struct(2:kc) = -1. * mode_struct(2:kc) + endif + + ! vertical derivative of w at interfaces lives on the layer points + do k=1,kc + mode_struct_fder(k) = (mode_struct(k) - mode_struct(k+1)) / dzc(k) + enddo + + ! boundary condition for derivative is no-gradient + do k=kc+1,nz + mode_struct_fder(k) = mode_struct_fder(kc) + enddo + + ! now save maximum value and bottom value + u_struct_bot(i,j,1) = mode_struct_fder(kc) + u_struct_max(i,j,1) = maxval(abs(mode_struct_fder(1:kc))) + + ! Calculate terms for vertically integrated energy equation + do k=1,kc + mode_struct_fder_sq(k) = mode_struct_fder(k)**2 + enddo + do K=1,kc+1 + mode_struct_sq(K) = mode_struct(K)**2 + enddo + + ! sum over layers for quantities defined on layer + do k=1,kc + int_U2(i,j,1) = int_U2(i,j,1) + mode_struct_fder_sq(k) * Hc(k) + enddo + + ! vertical integration with Trapezoidal rule for values at interfaces + do K=1,kc + int_w2(i,j,1) = int_w2(i,j,1) + 0.5*(mode_struct_sq(K)+mode_struct_sq(K+1)) * Hc(k) + int_N2w2(i,j,1) = int_N2w2(i,j,1) + 0.5*(mode_struct_sq(K)*N2(K) + & + mode_struct_sq(K+1)*N2(K+1)) * Hc(k) + enddo + + ! for w (diag) interpolate onto all interfaces + call interpolate_column(kc, Hc(1:kc), mode_struct(1:kc+1), & + nz, h(i,j,:), modal_structure(:), .false.) + + ! for u (remap) onto all layers + 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 + w_struct(i,j,k,1) = modal_structure(k) + enddo + + do k=1,nz + u_struct(i,j,k,1) = modal_structure_fder(k) + enddo + ! Find other eigen values if c1 is of significant magnitude, > cn_thresh nrootsfound = 0 ! number of extra roots found (not including 1st root) - if (nmodes>1 .and. kc>=nmodes+1 .and. cn(i,j,1)>c1_thresh) then - ! Set the the range to look for the other desired eigen values + if ((nmodes > 1) .and. (kc >= nmodes+1) .and. (cn(i,j,1) > CS%c1_thresh)) then + ! Set the range to look for the other desired eigen values ! set min value just greater than the 1st root (found above) lamMin = lam_1*(1.0 + tol_solve) ! set max value based on a low guess at wavespeed for highest mode @@ -1052,15 +1402,15 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! function changes sign but has a local max/min in interval, ! try subdividing interval as many times as necessary (or sub_it_max). ! loop that increases number of subintervals: - !call MOM_error(WARNING, "determinant changes sign"// & - ! "but has a local max/min in interval;"//& - ! " reduce increment in lam.") + !call MOM_error(WARNING, "determinant changes sign "// & + ! "but has a local max/min in interval; "//& + ! "reduce increment in lam.") ! begin subdivision loop ------------------------------------------- sub_rootfound = .false. ! initialize do sub_it=1,sub_it_max nsub = 2**sub_it ! number of subintervals; nsub=2,4,8,... ! loop over each subinterval: - do sub=1,nsub-1,2 ! only check odds; sub = 1; 1,3; 1,3,5,7;... + do sub=1,nsub-1,2 ! only check odds; sub = 1; 1,3; 1,3,5,7; ... xl_sub = xl + lamInc/(nsub)*sub call tridiag_det(Igu, Igl, 2, kc, xl_sub, det_sub, ddet_sub, & row_scale=c2_scale) @@ -1079,8 +1429,8 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! sub intervals, try subdividing again unless sub_it_max has been reached. if (sub_it == sub_it_max) then call MOM_error(WARNING, "wave_speed: root not found "// & - " after sub_it_max subdivisions of original"// & - " interval.") + "after sub_it_max subdivisions of original "// & + "interval.") endif ! sub_it == sub_it_max enddo ! sub_it-loop------------------------------------------------- endif ! det_l*ddet_l < 0.0 @@ -1103,16 +1453,98 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! Use Newton's method to find the roots within the identified windows do m=1,nrootsfound ! loop over the root-containing widows (excluding 1st mode) lam_n = xbl(m) ! first guess is left edge of window + + ! init and first guess for mode structure + mode_struct(:) = 0. + mode_struct_fder(:) = 0. + mode_struct(2:kc) = 1. ! Uniform flow, first guess + modal_structure(:) = 0. + modal_structure_fder(:) = 0. + do itt=1,max_itt ! calculate the determinant of (A-lam_n*I) call tridiag_det(Igu, Igl, 2, kc, lam_n, det, ddet, row_scale=c2_scale) ! Use Newton's method to find a new estimate of lam_n dlam = - det / ddet lam_n = lam_n + dlam + + call tdma6(kc-1, Igu(2:kc), Igl(2:kc), lam_n, mode_struct(2:kc)) + ! Note that tdma6 changes the units of mode_struct to [L2 T-2 ~> m2 s-2] + ! apply BC + mode_struct(1) = 0. + mode_struct(kc+1) = 0. + + ! renormalization of the integral of the profile + w2avg = 0.0 + do k=1,kc + w2avg = w2avg + 0.5*(mode_struct(K)**2+mode_struct(K+1)**2)*Hc(k) + enddo + renorm = sqrt(htot(i)*a_int/w2avg) + do K=1,kc+1 ; mode_struct(K) = renorm * mode_struct(K) ; enddo + if (abs(dlam) < tol_solve*lam_1) exit enddo ! itt-loop + ! calculate nth mode speed if (lam_n > 0.0) cn(i,j,m+1) = 1.0 / sqrt(lam_n) + + ! sign is irrelevant, flip to positive if needed + if (mode_struct(2)<0.) then + mode_struct(2:kc) = -1. * mode_struct(2:kc) + endif + + ! derivative of vertical profile (i.e. dw/dz) is evaluated at the layer point + do k=1,kc + mode_struct_fder(k) = (mode_struct(k) - mode_struct(k+1)) / dzc(k) + enddo + + ! boundary condition for 1st derivative is no-gradient + do k=kc+1,nz + mode_struct_fder(k) = mode_struct_fder(kc) + enddo + + ! now save maximum value and bottom value + u_struct_bot(i,j,m) = mode_struct_fder(kc) + u_struct_max(i,j,m) = maxval(abs(mode_struct_fder(1:kc))) + + ! Calculate terms for vertically integrated energy equation + do k=1,kc + mode_struct_fder_sq(k) = mode_struct_fder(k)**2 + enddo + do K=1,kc+1 + mode_struct_sq(K) = mode_struct(K)**2 + enddo + + ! sum over layers for integral of quantities defined at layer points + do k=1,kc + int_U2(i,j,m) = int_U2(i,j,m) + mode_struct_fder_sq(k) * Hc(k) + enddo + + ! vertical integration with Trapezoidal rule for quantities on interfaces + do K=1,kc + int_w2(i,j,m) = int_w2(i,j,m) + 0.5*(mode_struct_sq(K)+mode_struct_sq(K+1)) * Hc(k) + int_N2w2(i,j,m) = int_N2w2(i,j,m) + 0.5*(mode_struct_sq(K)*N2(K) + & + mode_struct_sq(K+1)*N2(K+1)) * Hc(k) + enddo + + ! for w (diag) interpolate onto all interfaces + call interpolate_column(kc, Hc(1:kc), mode_struct(1:kc+1), & + nz, h(i,j,:), modal_structure(:), .false.) + + ! for u (remap) onto all layers + 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,... + do k=1,nz+1 + w_struct(i,j,k,m+1) = modal_structure(k) + enddo + + do k=1,nz + u_struct(i,j,k,m+1) = modal_structure_fder(k) + enddo + enddo ! n-loop endif ! if nmodes>1 .and. kc>nmodes .and. c1>c1_thresh endif ! if more than 2 layers @@ -1128,20 +1560,27 @@ end subroutine wave_speeds !! signs are typically used, so internal rescaling by consistent factors are used to avoid !! over- or underflow. subroutine tridiag_det(a, c, ks, ke, lam, det, ddet, row_scale) - real, dimension(:), intent(in) :: a !< Lower diagonal of matrix (first entry unused) - real, dimension(:), intent(in) :: c !< Upper diagonal of matrix (last entry unused) + real, dimension(:), intent(in) :: a !< Lower diagonal of matrix (first entry unused) [T2 L-2 ~> s2 m-2] + real, dimension(:), intent(in) :: c !< Upper diagonal of matrix (last entry unused) [T2 L-2 ~> s2 m-2] integer, intent(in) :: ks !< Starting index to use in determinant integer, intent(in) :: ke !< Ending index to use in determinant - real, intent(in) :: lam !< Value subtracted from b - real, intent(out):: det !< Determinant - real, intent(out):: ddet !< Derivative of determinant with lam - real, intent(in) :: row_scale !< A scaling factor of the rows of the - !! matrix to limit the growth of the determinant + real, intent(in) :: lam !< Value subtracted from b [T2 L-2 ~> s2 m-2] + real, intent(out):: det !< Determinant of the matrix in dynamically rescaled units that + !! depend on the number of rows and the cumulative magnitude of + !! det and are therefore difficult to interpret, but the units + !! of det/ddet are always in [T2 L-2 ~> s2 m-2] + real, intent(out):: ddet !< Derivative of determinant with lam in units that are dynamically + !! rescaled along with those of det, such that the units of + !! det/ddet are always in [T2 L-2 ~> s2 m-2] + real, intent(in) :: row_scale !< A scaling factor of the rows of the matrix to + !! limit the growth of the determinant [L2 s2 T-2 m-2 ~> 1] ! Local variables - real :: detKm1, detKm2 ! Cumulative value of the determinant for the previous two layers. - real :: ddetKm1, ddetKm2 ! Derivative of the cumulative determinant with lam for the previous two layers. - real, parameter :: rescale = 1024.0**4 ! max value of determinant allowed before rescaling - real :: I_rescale ! inverse of rescale + real :: detKm1, detKm2 ! Cumulative value of the determinant for the previous two layers in units + ! that vary with the number of layers that have been worked on [various] + real :: ddetKm1, ddetKm2 ! Derivative of the cumulative determinant with lam for the previous two + ! layers [various], but the units of detKm1/ddetKm1 are [T2 L-2 ~> s2 m-2] + real, parameter :: rescale = 1024.0**4 ! max value of determinant allowed before rescaling [nondim] + real :: I_rescale ! inverse of rescale [nondim] integer :: k ! row (layer interface) index I_rescale = 1.0 / rescale @@ -1169,26 +1608,38 @@ 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, & - better_speed_est, min_speed, wave_speed_tol) +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 !! which N2 is limited as monotonic for the purposes of - !! calculating the vertical modal structure. + !! calculating the vertical modal structure [nondim]. real, optional, intent(in) :: mono_N2_depth !< The depth below which N2 is limited !! as monotonic for the purposes of calculating the - !! vertical modal structure [Z ~> m]. + !! vertical modal structure [H ~> m or kg m-2]. logical, optional, intent(in) :: remap_answers_2018 !< If true, use the order of arithmetic and expressions !! that recover the remapping answers from 2018. Otherwise !! use more robust but mathematically equivalent expressions. + 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. logical, optional, intent(in) :: better_speed_est !< If true, use a more robust estimate of the first !! mode speed as the starting point for iterations. + logical, optional, intent(in) :: om4_remap_via_sub_cells !< Use the OM4-era ramap_via_sub_cells + !! for calculating the EBT structure real, optional, intent(in) :: min_speed !< If present, set a floor in the first mode speed !! below which 0 is returned [L T-1 ~> m s-1]. real, optional, intent(in) :: wave_speed_tol !< The fractional tolerance for finding the !! wave speeds [nondim] + real, optional, intent(in) :: c1_thresh !< A minimal value of the first mode internal wave speed + !! below which all higher mode speeds are not calculated but are + !! simply reported as 0 [L T-1 ~> m s-1]. A non-negative value + !! must be specified for wave_speeds to be used (but not wave_speed). ! This include declares and sets the variable "version". # include "version_variable.h" @@ -1200,43 +1651,72 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de call log_version(mdl, version) call wave_speed_set_param(CS, use_ebt_mode=use_ebt_mode, mono_N2_column_fraction=mono_N2_column_fraction, & - better_speed_est=better_speed_est, min_speed=min_speed, wave_speed_tol=wave_speed_tol) - - call initialize_remapping(CS%remapping_CS, 'PLM', boundary_extrapolation=.false., & - answers_2018=CS%remap_answers_2018) + mono_N2_depth=mono_N2_depth, better_speed_est=better_speed_est, & + min_speed=min_speed, wave_speed_tol=wave_speed_tol, & + remap_answers_2018=remap_answers_2018, remap_answer_date=remap_answer_date, & + c1_thresh=c1_thresh) + + ! The following remapping is only used for wave_speed with pre-2019 answers. + if (CS%remap_answer_date < 20190101) & + call initialize_remapping(CS%remap_2018_CS, 'PLM', boundary_extrapolation=.false., & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & + answer_date=CS%remap_answer_date, & + h_neglect=1.0e-30*GV%m_to_H, h_neglect_edge=1.0e-10*GV%m_to_H) + + ! This is used in wave_speeds in all cases, and in wave_speed with newer answers. + call initialize_remapping(CS%remap_CS, 'PLM', boundary_extrapolation=.false., & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & + answer_date=CS%remap_answer_date, & + h_neglect=GV%H_subroundoff, h_neglect_edge=GV%H_subroundoff) end subroutine wave_speed_init !> Sets internal parameters for MOM_wave_speed subroutine wave_speed_set_param(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_depth, remap_answers_2018, & - better_speed_est, min_speed, wave_speed_tol) + remap_answer_date, better_speed_est, min_speed, wave_speed_tol, c1_thresh) type(wave_speed_CS), intent(inout) :: CS !< Control structure for MOM_wave_speed 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 !! which N2 is limited as monotonic for the purposes of - !! calculating the vertical modal structure. + !! calculating the vertical modal structure [nondim]. real, optional, intent(in) :: mono_N2_depth !< The depth below which N2 is limited !! as monotonic for the purposes of calculating the - !! vertical modal structure [Z ~> m]. + !! vertical modal structure [H ~> m or kg m-2]. logical, optional, intent(in) :: remap_answers_2018 !< If true, use the order of arithmetic and expressions !! that recover the remapping answers from 2018. Otherwise !! use more robust but mathematically equivalent expressions. + 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. logical, optional, intent(in) :: better_speed_est !< If true, use a more robust estimate of the first !! mode speed as the starting point for iterations. real, optional, intent(in) :: min_speed !< If present, set a floor in the first mode speed !! below which 0 is returned [L T-1 ~> m s-1]. real, optional, intent(in) :: wave_speed_tol !< The fractional tolerance for finding the !! wave speeds [nondim] + real, optional, intent(in) :: c1_thresh !< A minimal value of the first mode internal wave speed + !! below which all higher mode speeds are not calculated but are + !! simply reported as 0 [L T-1 ~> m s-1]. A non-negative value + !! must be specified for wave_speeds to be used (but not wave_speed). if (present(use_ebt_mode)) CS%use_ebt_mode = use_ebt_mode if (present(mono_N2_column_fraction)) CS%mono_N2_column_fraction = mono_N2_column_fraction if (present(mono_N2_depth)) CS%mono_N2_depth = mono_N2_depth - if (present(remap_answers_2018)) CS%remap_answers_2018 = remap_answers_2018 + if (present(remap_answers_2018)) then + if (remap_answers_2018) then + CS%remap_answer_date = 20181231 + else + CS%remap_answer_date = 20190101 + endif + endif + if (present(remap_answer_date)) CS%remap_answer_date = remap_answer_date if (present(better_speed_est)) CS%better_cg1_est = better_speed_est if (present(min_speed)) CS%min_speed2 = min_speed**2 if (present(wave_speed_tol)) CS%wave_speed_tol = wave_speed_tol + if (present(c1_thresh)) CS%c1_thresh = c1_thresh end subroutine wave_speed_set_param diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 deleted file mode 100644 index c833e973c5..0000000000 --- a/src/diagnostics/MOM_wave_structure.F90 +++ /dev/null @@ -1,761 +0,0 @@ -!> Vertical structure functions for first baroclinic mode wave speed -module MOM_wave_structure - -! This file is part of MOM6. See LICENSE.md for the license. - -! By Benjamin Mater & Robert Hallberg, 2015 - -! The subroutine in this module calculates the vertical structure -! functions of the first baroclinic mode internal wave speed. -! Calculation of interface values is the same as done in -! MOM_wave_speed by Hallberg, 2008. - -use MOM_debugging, only : isnan => is_NaN -use MOM_checksums, only : chksum0, hchksum -use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl -use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, time_type -use MOM_EOS, only : calculate_density_derivs -use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : log_version, param_file_type, get_param -use MOM_grid, only : ocean_grid_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type -use regrid_solvers, only : solve_diag_dominant_tridiag - -implicit none ; private - -#include - -public wave_structure, wave_structure_init - -! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional -! consistency testing. These are noted in comments with units like Z, H, L, and T, along with -! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units -! vary with the Boussinesq approximation, the Boussinesq variant is given first. - -!> The control structure for the MOM_wave_structure module -type, public :: wave_structure_CS ; !private - logical :: initialized = .false. !< True if this control structure has been initialized. - type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to - !! regulate the timing of diagnostic output. - real, allocatable, dimension(:,:,:) :: w_strct - !< Vertical structure of vertical velocity (normalized) [nondim]. - real, allocatable, dimension(:,:,:) :: u_strct - !< Vertical structure of horizontal velocity (normalized) [nondim]. - real, allocatable, dimension(:,:,:) :: W_profile - !< Vertical profile of w_hat(z), where - !! w(x,y,z,t) = w_hat(z)*exp(i(kx+ly-freq*t)) is the full time- - !! varying vertical velocity with w_hat(z) = W0*w_strct(z) [Z T-1 ~> m s-1]. - real, allocatable, dimension(:,:,:) :: Uavg_profile - !< Vertical profile of the magnitude of horizontal velocity, - !! (u^2+v^2)^0.5, averaged over a period [L T-1 ~> m s-1]. - real, allocatable, dimension(:,:,:) :: z_depths - !< Depths of layer interfaces [Z ~> m]. - real, allocatable, dimension(:,:,:) :: N2 - !< Squared buoyancy frequency at each interface [T-2 ~> s-2]. - integer, allocatable, dimension(:,:):: num_intfaces - !< Number of layer interfaces (including surface and bottom) [nondim]. - real :: int_tide_source_x !< X Location of generation site - !! for internal tide for testing (BDM) - real :: int_tide_source_y !< Y Location of generation site - !! for internal tide for testing (BDM) - logical :: debug !< debugging prints - -end type wave_structure_CS - -contains - -!> This subroutine determines the internal wave velocity structure for any mode. -!! -!! This subroutine solves for the eigen vector [vertical structure, e(k)] associated with -!! the first baroclinic mode speed [i.e., smallest eigen value (lam = 1/c^2)] of the -!! system d2e/dz2 = -(N2/cn2)e, or (A-lam*I)e = 0, where A = -(1/N2)(d2/dz2), lam = 1/c^2, -!! and I is the identity matrix. 2nd order discretization in the vertical lets this system -!! be represented as -!! -!! -Igu(k)*e(k-1) + (Igu(k)+Igl(k)-lam)*e(k) - Igl(k)*e(k+1) = 0.0 -!! -!! with rigid lid boundary conditions e(1) = e(nz+1) = 0.0 giving -!! -!! (Igu(2)+Igl(2)-lam)*e(2) - Igl(2)*e(3) = 0.0 -!! -Igu(nz)*e(nz-1) + (Igu(nz)+Igl(nz)-lam)*e(nz) = 0.0 -!! -!! where, upon noting N2 = reduced gravity/layer thickness, we get -!! Igl(k) = 1.0/(gprime(k)*H(k)) ; Igu(k) = 1.0/(gprime(k)*H(k-1)) -!! -!! The eigen value for this system is approximated using "wave_speed." This subroutine uses -!! these eigen values (mode speeds) to estimate the corresponding eigen vectors (velocity -!! structure) using the "inverse iteration with shift" method. The algorithm is -!! -!! Pick a starting vector reasonably close to mode structure and with unit magnitude, b_guess -!! For n=1,2,3,... -!! Solve (A-lam*I)e = e_guess for e -!! Set e_guess=e/|e| and repeat, with each iteration refining the estimate of e -subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halos) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various - !! thermodynamic variables. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: cn !< The (non-rotational) mode internal - !! gravity wave speed [L T-1 ~> m s-1]. - integer, intent(in) :: ModeNum !< Mode number - real, intent(in) :: freq !< Intrinsic wave frequency [T-1 ~> s-1]. - type(wave_structure_CS), intent(inout) :: CS !< Wave structure control struct - real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(in) :: En !< Internal wave energy density [R Z3 T-2 ~> J m-2] - logical, optional, intent(in) :: full_halos !< If true, do the calculation - !! over the entire computational domain. - ! Local variables - real, dimension(SZK_(GV)+1) :: & - dRho_dT, & !< Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] - dRho_dS, & !< Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1] - pres, & !< Interface pressure [R L2 T-2 ~> Pa] - T_int, & !< Temperature interpolated to interfaces [degC] - S_int, & !< Salinity interpolated to interfaces [ppt] - gprime !< The reduced gravity across each interface [L2 Z-1 T-2 ~> m s-2]. - real, dimension(SZK_(GV)) :: & - Igl, Igu !< The inverse of the reduced gravity across an interface times - !< the thickness of the layer below (Igl) or above (Igu) it [T2 L-2 ~> s2 m-2]. - real, dimension(SZK_(GV),SZI_(G)) :: & - Hf, & !< Layer thicknesses after very thin layers are combined [Z ~> m] - Tf, & !< Layer temperatures after very thin layers are combined [degC] - Sf, & !< Layer salinities after very thin layers are combined [ppt] - Rf !< Layer densities after very thin layers are combined [R ~> kg m-3] - real, dimension(SZK_(GV)) :: & - Hc, & !< A column of layer thicknesses after convective instabilities are removed [Z ~> m] - Tc, & !< A column of layer temperatures after convective instabilities are removed [degC] - Sc, & !< A column of layer salinites after convective instabilities are removed [ppt] - Rc, & !< A column of layer densities after convective instabilities are removed [R ~> kg m-3] - det, ddet - real, dimension(SZI_(G),SZJ_(G)) :: & - htot !< The vertical sum of the thicknesses [Z ~> m] - real :: lam !< inverse of wave speed squared [T2 L-2 ~> s2 m-2] - real :: min_h_frac !< fractional (per layer) minimum thickness [nondim] - real :: Z_to_pres !< A conversion factor from thicknesses to pressure [R L2 T-2 Z-1 ~> Pa m-1] - real, dimension(SZI_(G)) :: & - hmin, & !< Thicknesses [Z ~> m] - H_here, & !< A thickness [Z ~> m] - HxT_here, & !< A layer integrated temperature [degC Z ~> degC m] - HxS_here, & !< A layer integrated salinity [ppt Z ~> ppt m] - HxR_here !< A layer integrated density [R Z ~> kg m-2] - real :: speed2_tot - real :: I_Hnew !< The inverse of a new layer thickness [Z-1 ~> m-1] - real :: drxh_sum !< The sum of density diffrences across interfaces times thicknesses [R Z ~> kg m-2] - real, parameter :: tol1 = 0.0001, tol2 = 0.001 - real :: g_Rho0 !< G_Earth/Rho0 in [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]. - ! real :: rescale, I_rescale - integer :: kf(SZI_(G)) - integer, parameter :: max_itt = 1 !< number of times to iterate in solving for eigenvector - real :: cg_subRO !< A tiny wave speed to prevent division by zero [L T-1 ~> m s-1] - real, parameter :: a_int = 0.5 !< value of normalized integral: \int(w_strct^2)dz = a_int [nondim] - real :: I_a_int !< inverse of a_int [nondim] - real :: f2 !< squared Coriolis frequency [T-2 ~> s-2] - real :: Kmag2 !< magnitude of horizontal wave number squared [L-2 ~> m-2] - logical :: use_EOS !< If true, density is calculated from T & S using an - !! equation of state. - - ! local representations of variables in CS; note, - ! not all rows will be filled if layers get merged! - real, dimension(SZK_(GV)+1) :: w_strct !< Vertical structure of vertical velocity (normalized) [nondim]. - real, dimension(SZK_(GV)+1) :: u_strct !< Vertical structure of horizontal velocity (normalized) [nondim]. - real, dimension(SZK_(GV)+1) :: W_profile !< Vertical profile of w_hat(z) = W0*w_strct(z) [Z T-1 ~> m s-1]. - real, dimension(SZK_(GV)+1) :: Uavg_profile !< Vertical profile of the magnitude of - !! horizontal velocity [L T-1 ~> m s-1]. - real, dimension(SZK_(GV)+1) :: z_int !< Integrated depth [Z ~> m] - real, dimension(SZK_(GV)+1) :: N2 !< Squared buoyancy frequency at each interface [T-2 ~> s-2]. - real, dimension(SZK_(GV)+1) :: w_strct2 !< squared values [nondim] - real, dimension(SZK_(GV)+1) :: u_strct2 !< squared values [nondim] - real, dimension(SZK_(GV)) :: dz !< thicknesses of merged layers (same as Hc I hope) [Z ~> m] - ! real, dimension(SZK_(GV)+1) :: dWdz_profile !< profile of dW/dz - real :: w2avg !< average of squared vertical velocity structure funtion [Z ~> m] - real :: int_dwdz2 !< Vertical integral of the square of u_strct [Z ~> m] - real :: int_w2 !< Vertical integral of the square of w_strct [Z ~> m] - real :: int_N2w2 !< Vertical integral of N2 [Z T-2 ~> m s-2] - real :: KE_term !< terms in vertically averaged energy equation [R Z ~> kg m-2] - real :: PE_term !< terms in vertically averaged energy equation [R Z ~> kg m-2] - real :: W0 !< A vertical velocity magnitude [Z T-1 ~> m s-1] - real :: gp_unscaled !< A version of gprime rescaled to [L T-2 ~> m s-2]. - real, dimension(SZK_(GV)-1) :: lam_z !< product of eigen value and gprime(k); one value for each - !< interface (excluding surface and bottom) - real, dimension(SZK_(GV)-1) :: a_diag, b_diag, c_diag - !< diagonals of tridiagonal matrix; one value for each - !< interface (excluding surface and bottom) - real, dimension(SZK_(GV)-1) :: e_guess !< guess at eigen vector with unit amplitude (for TDMA) [nondim] - real, dimension(SZK_(GV)-1) :: e_itt !< improved guess at eigen vector (from TDMA) [nondim] - real :: Pi - integer :: kc - integer :: i, j, k, k2, itt, is, ie, js, je, nz, nzm, row, ig, jg, ig_stop, jg_stop - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - I_a_int = 1/a_int - - if (.not. CS%initialized) call MOM_error(FATAL, "MOM_wave_structure: "// & - "Module must be initialized before it is used.") - - if (present(full_halos)) then ; if (full_halos) then - is = G%isd ; ie = G%ied ; js = G%jsd ; je = G%jed - endif ; endif - - Pi = (4.0*atan(1.0)) - - g_Rho0 = GV%g_Earth / GV%Rho0 - - !if (CS%debug) call chksum0(g_Rho0, "g/rho0 in wave struct", & - ! scale=(US%L_to_m**2)*US%m_to_Z*(US%s_to_T**2)*US%kg_m3_to_R) - - if (CS%debug) call chksum0(freq, "freq in wave_struct", scale=US%s_to_T) - - cg_subRO = 1e-100*US%m_s_to_L_T ! The hard-coded value here might need to increase. - use_EOS = associated(tv%eqn_of_state) - - ! Simplifying the following could change answers at roundoff. - Z_to_pres = GV%Z_to_H * (GV%H_to_RZ * GV%g_Earth) - ! rescale = 1024.0**4 ; I_rescale = 1.0/rescale - - min_h_frac = tol1 / real(nz) - - do j=js,je - ! First merge very thin layers with the one above (or below if they are - ! at the top). This also transposes the row order so that columns can - ! be worked upon one at a time. - do i=is,ie ; htot(i,j) = 0.0 ; enddo - do k=1,nz ; do i=is,ie ; htot(i,j) = htot(i,j) + h(i,j,k)*GV%H_to_Z ; enddo ; enddo - - do i=is,ie - hmin(i) = htot(i,j)*min_h_frac ; kf(i) = 1 ; H_here(i) = 0.0 - HxT_here(i) = 0.0 ; HxS_here(i) = 0.0 ; HxR_here(i) = 0.0 - enddo - if (use_EOS) then - do k=1,nz ; do i=is,ie - if ((H_here(i) > hmin(i)) .and. (h(i,j,k)*GV%H_to_Z > hmin(i))) then - Hf(kf(i),i) = H_here(i) - Tf(kf(i),i) = HxT_here(i) / H_here(i) - Sf(kf(i),i) = HxS_here(i) / H_here(i) - kf(i) = kf(i) + 1 - - ! Start a new layer - H_here(i) = h(i,j,k)*GV%H_to_Z - HxT_here(i) = (h(i,j,k) * GV%H_to_Z) * tv%T(i,j,k) - HxS_here(i) = (h(i,j,k) * GV%H_to_Z) * tv%S(i,j,k) - else - H_here(i) = H_here(i) + h(i,j,k)*GV%H_to_Z - HxT_here(i) = HxT_here(i) + (h(i,j,k) * GV%H_to_Z) * tv%T(i,j,k) - HxS_here(i) = HxS_here(i) + (h(i,j,k) * GV%H_to_Z) * tv%S(i,j,k) - endif - enddo ; enddo - do i=is,ie ; if (H_here(i) > 0.0) then - Hf(kf(i),i) = H_here(i) - Tf(kf(i),i) = HxT_here(i) / H_here(i) - Sf(kf(i),i) = HxS_here(i) / H_here(i) - endif ; enddo - else - do k=1,nz ; do i=is,ie - if ((H_here(i) > hmin(i)) .and. (h(i,j,k)*GV%H_to_Z > hmin(i))) then - Hf(kf(i),i) = H_here(i) ; Rf(kf(i),i) = HxR_here(i) / H_here(i) - kf(i) = kf(i) + 1 - - ! Start a new layer - H_here(i) = h(i,j,k)*GV%H_to_Z - HxR_here(i) = (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) - else - H_here(i) = H_here(i) + h(i,j,k)*GV%H_to_Z - HxR_here(i) = HxR_here(i) + (h(i,j,k)*GV%H_to_Z)*GV%Rlay(k) - endif - enddo ; enddo - do i=is,ie ; if (H_here(i) > 0.0) then - Hf(kf(i),i) = H_here(i) ; Rf(kf(i),i) = HxR_here(i) / H_here(i) - endif ; enddo - endif ! use_EOS? - - ! From this point, we can work on individual columns without causing memory - ! to have page faults. - do i=is,ie ; if (cn(i,j)>0.0)then - !----for debugging, remove later---- - ig = i + G%idg_offset ; jg = j + G%jdg_offset - !if (ig == CS%int_tide_source_x .and. jg == CS%int_tide_source_y) then - !----------------------------------- - if (G%mask2dT(i,j) > 0.5) then - - gprime(:) = 0.0 ! init gprime - pres(:) = 0.0 ! init pres - lam = 1/(cn(i,j)**2) - - ! Calculate drxh_sum - if (use_EOS) then - pres(1) = 0.0 - do k=2,kf(i) - pres(k) = pres(k-1) + Z_to_pres*Hf(k-1,i) - T_int(k) = 0.5*(Tf(k,i)+Tf(k-1,i)) - S_int(k) = 0.5*(Sf(k,i)+Sf(k-1,i)) - enddo - call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & - tv%eqn_of_state, (/2,kf(i)/) ) - - ! Sum the reduced gravities to find out how small a density difference - ! is negligibly small. - drxh_sum = 0.0 - do k=2,kf(i) - drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & - max(0.0,dRho_dT(k)*(Tf(k,i)-Tf(k-1,i)) + & - dRho_dS(k)*(Sf(k,i)-Sf(k-1,i))) - enddo - else - drxh_sum = 0.0 - do k=2,kf(i) - drxh_sum = drxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & - max(0.0,Rf(k,i)-Rf(k-1,i)) - enddo - endif ! use_EOS? - - ! Find gprime across each internal interface, taking care of convective - ! instabilities by merging layers. - if (drxh_sum >= 0.0) then - ! Merge layers to eliminate convective instabilities or exceedingly - ! small reduced gravities. - if (use_EOS) then - kc = 1 - Hc(1) = Hf(1,i) ; Tc(1) = Tf(1,i) ; Sc(1) = Sf(1,i) - do k=2,kf(i) - if ((dRho_dT(k)*(Tf(k,i)-Tc(kc)) + dRho_dS(k)*(Sf(k,i)-Sc(kc))) * & - (Hc(kc) + Hf(k,i)) < 2.0 * tol2*drxh_sum) then - ! Merge this layer with the one above and backtrack. - I_Hnew = 1.0 / (Hc(kc) + Hf(k,i)) - Tc(kc) = (Hc(kc)*Tc(kc) + Hf(k,i)*Tf(k,i)) * I_Hnew - Sc(kc) = (Hc(kc)*Sc(kc) + Hf(k,i)*Sf(k,i)) * I_Hnew - Hc(kc) = (Hc(kc) + Hf(k,i)) - ! Backtrack to remove any convective instabilities above... Note - ! that the tolerance is a factor of two larger, to avoid limit how - ! far back we go. - do k2=kc,2,-1 - if ((dRho_dT(k2)*(Tc(k2)-Tc(k2-1)) + dRho_dS(k2)*(Sc(k2)-Sc(k2-1))) * & - (Hc(k2) + Hc(k2-1)) < tol2*drxh_sum) then - ! Merge the two bottommost layers. At this point kc = k2. - I_Hnew = 1.0 / (Hc(kc) + Hc(kc-1)) - Tc(kc-1) = (Hc(kc)*Tc(kc) + Hc(kc-1)*Tc(kc-1)) * I_Hnew - Sc(kc-1) = (Hc(kc)*Sc(kc) + Hc(kc-1)*Sc(kc-1)) * I_Hnew - Hc(kc-1) = (Hc(kc) + Hc(kc-1)) - kc = kc - 1 - else ; exit ; endif - enddo - else - ! Add a new layer to the column. - kc = kc + 1 - drho_dS(kc) = drho_dS(k) ; drho_dT(kc) = drho_dT(k) - Tc(kc) = Tf(k,i) ; Sc(kc) = Sf(k,i) ; Hc(kc) = Hf(k,i) - endif - enddo - ! At this point there are kc layers and the gprimes should be positive. - do k=2,kc ! Revisit this if non-Boussinesq. - gprime(k) = g_Rho0 * (dRho_dT(k)*(Tc(k)-Tc(k-1)) + & - dRho_dS(k)*(Sc(k)-Sc(k-1))) - enddo - else ! .not.use_EOS - ! Do the same with density directly... - kc = 1 - Hc(1) = Hf(1,i) ; Rc(1) = Rf(1,i) - do k=2,kf(i) - if ((Rf(k,i) - Rc(kc)) * (Hc(kc) + Hf(k,i)) < 2.0*tol2*drxh_sum) then - ! Merge this layer with the one above and backtrack. - Rc(kc) = (Hc(kc)*Rc(kc) + Hf(k,i)*Rf(k,i)) / (Hc(kc) + Hf(k,i)) - Hc(kc) = (Hc(kc) + Hf(k,i)) - ! Backtrack to remove any convective instabilities above... Note - ! that the tolerance is a factor of two larger, to avoid limit how - ! far back we go. - do k2=kc,2,-1 - if ((Rc(k2)-Rc(k2-1)) * (Hc(k2)+Hc(k2-1)) < tol2*drxh_sum) then - ! Merge the two bottommost layers. At this point kc = k2. - Rc(kc-1) = (Hc(kc)*Rc(kc) + Hc(kc-1)*Rc(kc-1)) / (Hc(kc) + Hc(kc-1)) - Hc(kc-1) = (Hc(kc) + Hc(kc-1)) - kc = kc - 1 - else ; exit ; endif - enddo - else - ! Add a new layer to the column. - kc = kc + 1 - Rc(kc) = Rf(k,i) ; Hc(kc) = Hf(k,i) - endif - enddo - ! At this point there are kc layers and the gprimes should be positive. - do k=2,kc ! Revisit this if non-Boussinesq. - gprime(k) = g_Rho0 * (Rc(k)-Rc(k-1)) - enddo - endif ! use_EOS? - - !-----------------NOW FIND WAVE STRUCTURE------------------------------------- - ! Construct and solve tridiagonal system for the interior interfaces - ! Note that kc = number of layers, - ! kc+1 = nzm = number of interfaces, - ! kc-1 = number of interior interfaces (excluding surface and bottom) - ! Also, note that "K" refers to an interface, while "k" refers to the layer below. - ! Need at least 3 layers (2 internal interfaces) to generate a matrix, also - ! need number of layers to be greater than the mode number - if (kc >= max(3, ModeNum + 1)) then - ! Set depth at surface - z_int(1) = 0.0 - ! Calculate Igu, Igl, depth, and N2 at each interior interface - ! [excludes surface (K=1) and bottom (K=kc+1)] - do K=2,kc - Igl(K) = 1.0/(gprime(K)*Hc(k)) ; Igu(K) = 1.0/(gprime(K)*Hc(k-1)) - z_int(K) = z_int(K-1) + Hc(k-1) - N2(K) = US%L_to_Z**2*gprime(K)/(0.5*(Hc(k)+Hc(k-1))) - enddo - ! Set stratification for surface and bottom (setting equal to nearest interface for now) - N2(1) = N2(2) ; N2(kc+1) = N2(kc) - ! Calcualte depth at bottom - z_int(kc+1) = z_int(kc)+Hc(kc) - ! check that thicknesses sum to total depth - if (abs(z_int(kc+1)-htot(i,j)) > 1.e-14*htot(i,j)) then - call MOM_error(FATAL, "wave_structure: mismatch in total depths") - endif - - ! Note that many of the calcluation from here on revert to using vertical - ! distances in m, not Z. - - ! Populate interior rows of tridiagonal matrix; must multiply through by - ! gprime to get tridiagonal matrix to the symmetrical form: - ! [-1/H(k-1)]e(k-1) + [1/H(k-1)+1/H(k)-lam_z]e(k) + [-1/H(k)]e(k+1) = 0, - ! where lam_z = lam*gprime is now a function of depth. - ! Frist, populate interior rows - - ! init the values in matrix: since number of layers is variable, values need - ! to be reset - lam_z(:) = 0.0 - a_diag(:) = 0.0 - b_diag(:) = 0.0 - c_diag(:) = 0.0 - e_guess(:) = 0.0 - e_itt(:) = 0.0 - w_strct(:) = 0.0 - do K=3,kc-1 - row = K-1 ! indexing for TD matrix rows - gp_unscaled = gprime(K) - lam_z(row) = lam*gp_unscaled - a_diag(row) = gp_unscaled*(-Igu(K)) - b_diag(row) = gp_unscaled*(Igu(K)+Igl(K)) - lam_z(row) - c_diag(row) = gp_unscaled*(-Igl(K)) - if (isnan(lam_z(row)))then ; print *, "Wave_structure: lam_z(row) is NAN" ; endif - if (isnan(a_diag(row)))then ; print *, "Wave_structure: a(k) is NAN" ; endif - if (isnan(b_diag(row)))then ; print *, "Wave_structure: b(k) is NAN" ; endif - if (isnan(c_diag(row)))then ; print *, "Wave_structure: c(k) is NAN" ; endif - enddo - ! Populate top row of tridiagonal matrix - K=2 ; row = K-1 ; - gp_unscaled = gprime(K) - lam_z(row) = lam*gp_unscaled - a_diag(row) = 0.0 - b_diag(row) = gp_unscaled*(Igu(K)+Igl(K)) - lam_z(row) - c_diag(row) = gp_unscaled*(-Igl(K)) - ! Populate bottom row of tridiagonal matrix - K=kc ; row = K-1 - gp_unscaled = gprime(K) - lam_z(row) = lam*gp_unscaled - a_diag(row) = gp_unscaled*(-Igu(K)) - b_diag(row) = gp_unscaled*(Igu(K)+Igl(K)) - lam_z(row) - c_diag(row) = 0.0 - - ! Guess a vector shape to start with (excludes surface and bottom) - e_guess(1:kc-1) = sin((z_int(2:kc)/htot(i,j)) *Pi) - e_guess(1:kc-1) = e_guess(1:kc-1)/sqrt(sum(e_guess(1:kc-1)**2)) - - ! Perform inverse iteration with tri-diag solver - do itt=1,max_itt - ! this solver becomes unstable very quickly - !call tridiag_solver(a_diag(1:kc-1),b_diag(1:kc-1),c_diag(1:kc-1), & - ! -lam_z(1:kc-1),e_guess(1:kc-1),"TDMA_T",e_itt) - - call solve_diag_dominant_tridiag( a_diag(1:kc-1), -lam_z(1:kc-1), & - c_diag(1:kc-1), e_guess(1:kc-1), & - e_itt, kc-1 ) - e_guess(1:kc-1) = e_itt(1:kc-1) / sqrt(sum(e_itt(1:kc-1)**2)) - enddo ! itt-loop - w_strct(2:kc) = e_guess(1:kc-1) - w_strct(1) = 0.0 ! rigid lid at surface - w_strct(kc+1) = 0.0 ! zero-flux at bottom - - ! Check to see if solver worked - ig_stop = 0 ; jg_stop = 0 - if (isnan(sum(w_strct(1:kc+1))))then - print *, "Wave_structure: w_strct has a NAN at ig=", ig, ", jg=", jg - if (iG%iec .or. jG%jec)then - print *, "This is occuring at a halo point." - endif - ig_stop = ig ; jg_stop = jg - endif - - ! Normalize vertical structure function of w such that - ! \int(w_strct)^2dz = a_int (a_int could be any value, e.g., 0.5) - nzm = kc+1 ! number of layer interfaces after merging - !(including surface and bottom) - w2avg = 0.0 - do k=1,nzm-1 - dz(k) = Hc(k) - w2avg = w2avg + 0.5*(w_strct(K)**2+w_strct(K+1)**2)*dz(k) - enddo - ! correct renormalization: - w_strct(:) = w_strct(:) * sqrt(htot(i,j)*a_int/w2avg) - - ! Calculate vertical structure function of u (i.e. dw/dz) - do K=2,nzm-1 - u_strct(K) = 0.5*((w_strct(K-1) - w_strct(K) )/dz(k-1) + & - (w_strct(K) - w_strct(K+1))/dz(k)) - enddo - u_strct(1) = (w_strct(1) - w_strct(2) )/dz(1) - u_strct(nzm) = (w_strct(nzm-1)- w_strct(nzm))/dz(nzm-1) - - ! Calculate wavenumber magnitude - f2 = (0.25*(G%CoriolisBu(I,J) + G%CoriolisBu(max(I-1,1),max(J-1,1)) + & - G%CoriolisBu(I,max(J-1,1)) + G%CoriolisBu(max(I-1,1),J)))**2 - Kmag2 = (freq**2 - f2) / (cn(i,j)**2 + cg_subRO**2) - - ! Calculate terms in vertically integrated energy equation - int_dwdz2 = 0.0 ; int_w2 = 0.0 ; int_N2w2 = 0.0 - u_strct2(1:nzm) = u_strct(1:nzm)**2 - w_strct2(1:nzm) = w_strct(1:nzm)**2 - ! vertical integration with Trapezoidal rule - do k=1,nzm-1 - int_dwdz2 = int_dwdz2 + 0.5*(u_strct2(K)+u_strct2(K+1)) * dz(k) - int_w2 = int_w2 + 0.5*(w_strct2(K)+w_strct2(K+1)) * dz(k) - int_N2w2 = int_N2w2 + 0.5*(w_strct2(K)*N2(K)+w_strct2(K+1)*N2(K+1)) * dz(k) - enddo - - ! Back-calculate amplitude from energy equation - if (present(En) .and. (freq**2*Kmag2 > 0.0)) then - ! Units here are [R Z ~> kg m-2] - KE_term = 0.25*GV%Rho0*( ((freq**2 + f2) / (freq**2*Kmag2))*int_dwdz2 + int_w2 ) - PE_term = 0.25*GV%Rho0*( int_N2w2 / freq**2 ) - if (En(i,j) >= 0.0) then - W0 = sqrt( En(i,j) / (KE_term + PE_term) ) - else - call MOM_error(WARNING, "wave_structure: En < 0.0; setting to W0 to 0.0") - print *, "En(i,j)=", En(i,j), " at ig=", ig, ", jg=", jg - W0 = 0.0 - endif - ! Calculate actual vertical velocity profile and derivative - W_profile(:) = W0*w_strct(:) - ! dWdz_profile(:) = W0*u_strct(:) - ! Calculate average magnitude of actual horizontal velocity over a period - Uavg_profile(:) = abs(W0*u_strct(:)) * sqrt((freq**2 + f2) / (2.0*freq**2*Kmag2)) - else - W_profile(:) = 0.0 - ! dWdz_profile(:) = 0.0 - Uavg_profile(:) = 0.0 - endif - - ! Store values in control structure - CS%w_strct(i,j,1:nzm) = w_strct(1:nzm) - CS%u_strct(i,j,1:nzm) = u_strct(1:nzm) - CS%W_profile(i,j,1:nzm) = W_profile(1:nzm) - CS%Uavg_profile(i,j,1:nzm)= Uavg_profile(1:nzm) - CS%z_depths(i,j,1:nzm) = z_int(1:nzm) - CS%N2(i,j,1:nzm) = N2(1:nzm) - CS%num_intfaces(i,j) = nzm - else - ! If not enough layers, default to zero - nzm = kc+1 - CS%w_strct(i,j,1:nzm) = 0.0 - CS%u_strct(i,j,1:nzm) = 0.0 - CS%W_profile(i,j,1:nzm) = 0.0 - CS%Uavg_profile(i,j,1:nzm)= 0.0 - CS%z_depths(i,j,1:nzm) = 0.0 ! could use actual values - CS%N2(i,j,1:nzm) = 0.0 ! could use with actual values - CS%num_intfaces(i,j) = nzm - endif ! kc >= 3 and kc > ModeNum + 1? - endif ! drxh_sum >= 0? - !else ! if at test point - delete later - ! return ! if at test point - delete later - !endif ! if at test point - delete later - endif ! mask2dT > 0.5? - else - ! if cn=0.0, default to zero - nzm = nz+1! could use actual values - CS%w_strct(i,j,1:nzm) = 0.0 - CS%u_strct(i,j,1:nzm) = 0.0 - CS%W_profile(i,j,1:nzm) = 0.0 - CS%Uavg_profile(i,j,1:nzm)= 0.0 - CS%z_depths(i,j,1:nzm) = 0.0 ! could use actual values - CS%N2(i,j,1:nzm) = 0.0 ! could use with actual values - CS%num_intfaces(i,j) = nzm - endif ; enddo ! if cn>0.0? ; i-loop - enddo ! j-loop - - if (CS%debug) call hchksum(CS%N2, 'N2 in wave_struct', G%HI, scale=US%s_to_T**2) - if (CS%debug) call hchksum(cn, 'cn in wave_struct', G%HI, scale=US%L_T_to_m_s) - if (CS%debug) call hchksum(CS%W_profile, 'Wprofile in wave_struct', G%HI, scale=US%Z_to_L*US%L_T_to_m_s) - if (CS%debug) call hchksum(CS%Uavg_profile, 'Uavg_profile in wave_struct', G%HI, scale=US%L_T_to_m_s) - -end subroutine wave_structure - -!> Solves a tri-diagonal system Ax=y using either the standard -!! Thomas algorithm (TDMA_T) or its more stable variant that invokes the -!! "Hallberg substitution" (TDMA_H). -subroutine tridiag_solver(a, b, c, h, y, method, x) - real, dimension(:), intent(in) :: a !< lower diagonal with first entry equal to zero. - real, dimension(:), intent(in) :: b !< middle diagonal. - real, dimension(:), intent(in) :: c !< upper diagonal with last entry equal to zero. - real, dimension(:), intent(in) :: h !< vector of values that have already been added to b; used - !! for systems of the form (e.g. average layer thickness in vertical diffusion case): - !! [ -alpha(k-1/2) ] * e(k-1) + - !! [ alpha(k-1/2) + alpha(k+1/2) + h(k) ] * e(k) + - !! [ -alpha(k+1/2) ] * e(k+1) = y(k) - !! where a(k)=[-alpha(k-1/2)], b(k)=[alpha(k-1/2)+alpha(k+1/2) + h(k)], - !! and c(k)=[-alpha(k+1/2)]. Only used with TDMA_H method. - real, dimension(:), intent(in) :: y !< vector of known values on right hand side. - character(len=*), intent(in) :: method !< A string describing the algorithm to use - real, dimension(:), intent(out) :: x !< vector of unknown values to solve for. - ! Local variables - integer :: nrow ! number of rows in A matrix -! real, allocatable, dimension(:,:) :: A_check ! for solution checking -! real, allocatable, dimension(:) :: y_check ! for solution checking - real, allocatable, dimension(:) :: c_prime, y_prime, q, alpha - ! intermediate values for solvers - real :: Q_prime, beta ! intermediate values for solver - integer :: k ! row (e.g. interface) index - integer :: i,j - - nrow = size(y) - allocate(c_prime(nrow)) - allocate(y_prime(nrow)) - allocate(q(nrow)) - allocate(alpha(nrow)) -! allocate(A_check(nrow,nrow)) -! allocate(y_check(nrow)) - - if (method == 'TDMA_T') then - ! Standard Thomas algoritim (4th variant). - ! Note: Requires A to be non-singular for accuracy/stability - c_prime(:) = 0.0 ; y_prime(:) = 0.0 - c_prime(1) = c(1)/b(1) ; y_prime(1) = y(1)/b(1) - - ! Forward sweep - do k=2,nrow-1 - c_prime(k) = c(k)/(b(k)-a(k)*c_prime(k-1)) - enddo - !print *, 'c_prime=', c_prime(1:nrow) - do k=2,nrow - y_prime(k) = (y(k)-a(k)*y_prime(k-1))/(b(k)-a(k)*c_prime(k-1)) - enddo - !print *, 'y_prime=', y_prime(1:nrow) - x(nrow) = y_prime(nrow) - - ! Backward sweep - do k=nrow-1,1,-1 - x(k) = y_prime(k)-c_prime(k)*x(k+1) - enddo - !print *, 'x=',x(1:nrow) - - ! Check results - delete later - !do j=1,nrow ; do i=1,nrow - ! if (i==j)then ; A_check(i,j) = b(i) - ! elseif (i==j+1)then ; A_check(i,j) = a(i) - ! elseif (i==j-1)then ; A_check(i,j) = c(i) - ! endif - !enddo ; enddo - !print *, 'A(2,1),A(2,2),A(1,2)=', A_check(2,1), A_check(2,2), A_check(1,2) - !y_check = matmul(A_check,x) - !if (all(y_check /= y))then - ! print *, "tridiag_solver: Uh oh, something's not right!" - ! print *, "y=", y - ! print *, "y_check=", y_check - !endif - - elseif (method == 'TDMA_H') then - ! Thomas algoritim (4th variant) w/ Hallberg substitution. - ! For a layered system where k is at interfaces, alpha{k+1/2} refers to - ! some property (e.g. inverse thickness for mode-structure problem) of the - ! layer below and alpha{k-1/2} refers to the layer above. - ! Here, alpha(k)=alpha{k+1/2} and alpha(k-1)=alpha{k-1/2}. - ! Strictly speaking, this formulation requires A to be a non-singular, - ! symmetric, diagonally dominant matrix, with h>0. - ! Need to add a check for these conditions. - do k=1,nrow-1 - if (abs(a(k+1)-c(k)) > 1.e-10*(abs(a(k+1))+abs(c(k)))) then - call MOM_error(FATAL, "tridiag_solver: matrix not symmetric; need symmetry when invoking TDMA_H") - endif - enddo - alpha = -c - ! Alpha of the bottom-most layer is not necessarily zero. Therefore, - ! back out the value from the provided b(nrow and h(nrow) values - alpha(nrow) = b(nrow)-h(nrow)-alpha(nrow-1) - ! Prime other variables - beta = 1/b(1) - y_prime(:) = 0.0 ; q(:) = 0.0 - y_prime(1) = beta*y(1) ; q(1) = beta*alpha(1) - Q_prime = 1-q(1) - - ! Forward sweep - do k=2,nrow-1 - beta = 1/(h(k)+alpha(k-1)*Q_prime+alpha(k)) - if (isnan(beta))then ; print *, "Tridiag_solver: beta is NAN" ; endif - q(k) = beta*alpha(k) - y_prime(k) = beta*(y(k)+alpha(k-1)*y_prime(k-1)) - Q_prime = beta*(h(k)+alpha(k-1)*Q_prime) - enddo - if ((h(nrow)+alpha(nrow-1)*Q_prime+alpha(nrow)) == 0.0)then - call MOM_error(FATAL, "Tridiag_solver: this system is not stable.") ! ; overriding beta(nrow) - ! This has hard-coded dimensions: beta = 1/(1e-15) ! place holder for unstable systems - delete later - else - beta = 1/(h(nrow)+alpha(nrow-1)*Q_prime+alpha(nrow)) - endif - y_prime(nrow) = beta*(y(nrow)+alpha(nrow-1)*y_prime(nrow-1)) - x(nrow) = y_prime(nrow) - ! Backward sweep - do k=nrow-1,1,-1 - x(k) = y_prime(k)+q(k)*x(k+1) - enddo - !print *, 'yprime=',y_prime(1:nrow) - !print *, 'x=',x(1:nrow) - endif - - deallocate(c_prime,y_prime,q,alpha) -! deallocate(A_check,y_check) - -end subroutine tridiag_solver - -!> Allocate memory associated with the wave structure module and read parameters. -subroutine wave_structure_init(Time, G, GV, param_file, diag, CS) - type(time_type), intent(in) :: Time !< The current model time. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time - !! parameters. - type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate - !! diagnostic output. - type(wave_structure_CS), intent(inout) :: CS !< Wave structure control struct - -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mdl = "MOM_wave_structure" ! This module's name. - integer :: isd, ied, jsd, jed, nz - - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke - - CS%initialized = .true. - - call get_param(param_file, mdl, "INTERNAL_TIDE_SOURCE_X", CS%int_tide_source_x, & - "X Location of generation site for internal tide", default=1.) - call get_param(param_file, mdl, "INTERNAL_TIDE_SOURCE_Y", CS%int_tide_source_y, & - "Y Location of generation site for internal tide", default=1.) - call get_param(param_file, mdl, "DEBUG", CS%debug, & - "debugging prints", default=.false.) - - CS%diag => diag - - ! Allocate memory for variable in control structure; note, - ! not all rows will be filled if layers get merged! - allocate(CS%w_strct(isd:ied,jsd:jed,nz+1)) - allocate(CS%u_strct(isd:ied,jsd:jed,nz+1)) - allocate(CS%W_profile(isd:ied,jsd:jed,nz+1)) - allocate(CS%Uavg_profile(isd:ied,jsd:jed,nz+1)) - allocate(CS%z_depths(isd:ied,jsd:jed,nz+1)) - allocate(CS%N2(isd:ied,jsd:jed,nz+1)) - allocate(CS%num_intfaces(isd:ied,jsd:jed)) - - ! Write all relevant parameters to the model log. - call log_version(param_file, mdl, version, "") - -end subroutine wave_structure_init - -end module MOM_wave_structure diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 39b626985a..f576118fb6 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1,50 +1,49 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Provides subroutines for quantities specific to the equation of state module MOM_EOS -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_EOS_linear, only : calculate_density_linear, calculate_spec_vol_linear -use MOM_EOS_linear, only : calculate_density_derivs_linear -use MOM_EOS_linear, only : calculate_specvol_derivs_linear, int_density_dz_linear -use MOM_EOS_linear, only : calculate_density_second_derivs_linear -use MOM_EOS_linear, only : calculate_compress_linear, int_spec_vol_dp_linear -use MOM_EOS_Wright, only : calculate_density_wright, calculate_spec_vol_wright -use MOM_EOS_Wright, only : calculate_density_derivs_wright -use MOM_EOS_Wright, only : calculate_specvol_derivs_wright, int_density_dz_wright -use MOM_EOS_Wright, only : calculate_compress_wright, int_spec_vol_dp_wright -use MOM_EOS_Wright, only : calculate_density_second_derivs_wright -use MOM_EOS_UNESCO, only : calculate_density_unesco, calculate_spec_vol_unesco -use MOM_EOS_UNESCO, only : calculate_density_derivs_unesco, calculate_density_unesco -use MOM_EOS_UNESCO, only : calculate_compress_unesco -use MOM_EOS_NEMO, only : calculate_density_nemo -use MOM_EOS_NEMO, only : calculate_density_derivs_nemo, calculate_density_nemo -use MOM_EOS_NEMO, only : calculate_compress_nemo -use MOM_EOS_TEOS10, only : calculate_density_teos10, calculate_spec_vol_teos10 -use MOM_EOS_TEOS10, only : calculate_density_derivs_teos10 -use MOM_EOS_TEOS10, only : calculate_specvol_derivs_teos10 -use MOM_EOS_TEOS10, only : calculate_density_second_derivs_teos10 -use MOM_EOS_TEOS10, only : calculate_compress_teos10 -use MOM_EOS_TEOS10, only : gsw_sp_from_sr, gsw_pt_from_ct +use MOM_EOS_base_type, only : EOS_base +use MOM_EOS_linear, only : linear_EOS, avg_spec_vol_linear +use MOM_EOS_linear, only : int_density_dz_linear, int_spec_vol_dp_linear +use MOM_EOS_Wright, only : buggy_Wright_EOS, avg_spec_vol_buggy_Wright +use MOM_EOS_Wright, only : int_density_dz_wright, int_spec_vol_dp_wright +use MOM_EOS_Wright_full, only : Wright_full_EOS, avg_spec_vol_Wright_full +use MOM_EOS_Wright_full, only : int_density_dz_wright_full, int_spec_vol_dp_wright_full +use MOM_EOS_Wright_red, only : Wright_red_EOS, avg_spec_vol_Wright_red +use MOM_EOS_Wright_red, only : int_density_dz_wright_red, int_spec_vol_dp_wright_red +use MOM_EOS_Jackett06, only : Jackett06_EOS +use MOM_EOS_UNESCO, only : UNESCO_EOS +use MOM_EOS_Roquet_rho, only : Roquet_rho_EOS +use MOM_EOS_Roquet_SpV, only : Roquet_SpV_EOS +use MOM_EOS_TEOS10, only : TEOS10_EOS +use MOM_EOS_TEOS10, only : gsw_sp_from_sr, gsw_pt_from_ct, gsw_sr_from_sp, gsw_ct_from_pt +use MOM_temperature_convert, only : poTemp_to_consTemp, consTemp_to_poTemp use MOM_TFreeze, only : calculate_TFreeze_linear, calculate_TFreeze_Millero -use MOM_TFreeze, only : calculate_TFreeze_teos10 +use MOM_TFreeze, only : calculate_TFreeze_teos10, calculate_TFreeze_TEOS_poly use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_hor_index, only : hor_index_type +use MOM_io, only : stdout, stderr use MOM_string_functions, only : uppercase use MOM_unit_scaling, only : unit_scale_type implicit none ; private -#include - public EOS_domain public EOS_init public EOS_manual_init public EOS_quadrature -public EOS_use_linear +! public EOS_use_linear +public EOS_fit_range +public EOS_unit_tests public analytic_int_density_dz public analytic_int_specific_vol_dp +public average_specific_vol public calculate_compress +public calculate_density_elem public calculate_density public calculate_density_derivs public calculate_density_second_derivs @@ -52,10 +51,15 @@ module MOM_EOS public calculate_specific_vol_derivs public calculate_TFreeze public convert_temp_salt_for_TEOS10 -public extract_member_EOS +public cons_temp_to_pot_temp +public pot_temp_to_cons_temp +public abs_saln_to_prac_saln +public prac_saln_to_abs_saln public gsw_sp_from_sr +public gsw_sr_from_sp public gsw_pt_from_ct public query_compressible +public get_EOS_name ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -64,42 +68,43 @@ module MOM_EOS !> Calculates density of sea water from T, S and P interface calculate_density - module procedure calculate_density_scalar, calculate_density_array, calculate_density_1d - module procedure calculate_stanley_density_scalar, calculate_stanley_density_array + module procedure calculate_density_scalar + module procedure calculate_density_1d + module procedure calculate_stanley_density_scalar module procedure calculate_stanley_density_1d end interface calculate_density !> Calculates specific volume of sea water from T, S and P interface calculate_spec_vol - module procedure calc_spec_vol_scalar, calculate_spec_vol_array, & - calc_spec_vol_1d + module procedure calc_spec_vol_scalar + module procedure calc_spec_vol_1d end interface calculate_spec_vol !> Calculate the derivatives of density with temperature and salinity from T, S, and P interface calculate_density_derivs - module procedure calculate_density_derivs_scalar, calculate_density_derivs_array, & - calculate_density_derivs_1d + module procedure calculate_density_derivs_scalar, calculate_density_derivs_array + module procedure calculate_density_derivs_1d end interface calculate_density_derivs !> Calculate the derivatives of specific volume with temperature and salinity from T, S, and P interface calculate_specific_vol_derivs - module procedure calculate_spec_vol_derivs_array, calc_spec_vol_derivs_1d + module procedure calc_spec_vol_derivs_1d end interface calculate_specific_vol_derivs !> Calculates the second derivatives of density with various combinations of temperature, !! salinity, and pressure from T, S and P interface calculate_density_second_derivs - module procedure calculate_density_second_derivs_scalar, calculate_density_second_derivs_array + module procedure calculate_density_second_derivs_scalar, calculate_density_second_derivs_1d end interface calculate_density_second_derivs !> Calculates the freezing point of sea water from T, S and P interface calculate_TFreeze - module procedure calculate_TFreeze_scalar, calculate_TFreeze_array + module procedure calculate_TFreeze_scalar, calculate_TFreeze_1d, calculate_TFreeze_array end interface calculate_TFreeze !> Calculates the compressibility of water from T, S, and P interface calculate_compress - module procedure calculate_compress_scalar, calculate_compress_array + module procedure calculate_compress_scalar, calculate_compress_1d end interface calculate_compress !> A control structure for the equation of state @@ -114,86 +119,155 @@ module MOM_EOS real :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3] real :: dRho_dT !< The partial derivative of density with temperature [kg m-3 degC-1] real :: dRho_dS !< The partial derivative of density with salinity [kg m-3 ppt-1] + real :: dRho_dp !< The partial derivative of density with pressure [s2 m-2] ! The following parameters are use with the linear expression for the freezing ! point only. real :: TFr_S0_P0 !< The freezing potential temperature at S=0, P=0 [degC] real :: dTFr_dS !< The derivative of freezing point with salinity [degC ppt-1] real :: dTFr_dp !< The derivative of freezing point with pressure [degC Pa-1] +! The following are logicals pertaining to definitions of the thermodynamic state variables + logical :: use_conT_absS =.false. !< True if the model internal temperature is the conservative temperature and + !! the salinity is absolute salinity. These could be separated into two flags, + !! but right now it is controlled by one input parameter and there is no known + !! need to have one True and one False. + logical :: TFreeze_S_is_pracS =.true. !< True if the freezing point expression is formulated from practical salinity + logical :: TFreeze_T_is_potT = .true. !< True if the freezing point expression yields a potential temperature + + logical :: use_Wright_2nd_deriv_bug = .false. !< If true, use a separate subroutine that + !! retains a buggy version of the calculations of the second + !! derivative of density with temperature and with temperature and + !! pressure. This bug is corrected in the default version. ! Unit conversion factors (normally used for dimensional testing but could also allow for ! change of units of arguments to functions) - real :: m_to_Z = 1. !< A constant that translates distances in meters to the units of depth. - real :: kg_m3_to_R = 1. !< A constant that translates kilograms per meter cubed to the units of density. - real :: R_to_kg_m3 = 1. !< A constant that translates the units of density to kilograms per meter cubed. - real :: RL2_T2_to_Pa = 1.!< Convert pressures from R L2 T-2 to Pa. - real :: L_T_to_m_s = 1. !< Convert lateral velocities from L T-1 to m s-1. + real :: m_to_Z = 1. !< A constant that translates distances in meters to the units of depth [Z m-1 ~> 1] + real :: kg_m3_to_R = 1. !< A constant that translates kilograms per meter cubed to the + !! units of density [R m3 kg-1 ~> 1] + real :: R_to_kg_m3 = 1. !< A constant that translates the units of density to + !! kilograms per meter cubed [kg m-3 R-1 ~> 1] + real :: RL2_T2_to_Pa = 1.!< Convert pressures from R L2 T-2 to Pa [Pa T2 R-1 L-2 ~> 1] + real :: L_T_to_m_s = 1. !< Convert lateral velocities from L T-1 to m s-1 [m T s-1 L-1 ~> 1] + real :: degC_to_C = 1. !< A constant that translates degrees Celsius to the units of temperature [C degC-1 ~> 1] + real :: C_to_degC = 1. !< A constant that translates the units of temperature to degrees Celsius [degC C-1 ~> 1] + real :: ppt_to_S = 1. !< A constant that translates parts per thousand to the units of salinity [S ppt-1 ~> 1] + real :: S_to_ppt = 1. !< A constant that translates the units of salinity to parts per thousand [ppt S-1 ~> 1] + + !> The instance of the actual equation of state + class(EOS_base), allocatable :: type -! logical :: test_EOS = .true. ! If true, test the equation of state end type EOS_type ! The named integers that might be stored in eqn_of_state_type%form_of_EOS. integer, parameter, public :: EOS_LINEAR = 1 !< A named integer specifying an equation of state integer, parameter, public :: EOS_UNESCO = 2 !< A named integer specifying an equation of state integer, parameter, public :: EOS_WRIGHT = 3 !< A named integer specifying an equation of state -integer, parameter, public :: EOS_TEOS10 = 4 !< A named integer specifying an equation of state -integer, parameter, public :: EOS_NEMO = 5 !< A named integer specifying an equation of state - -character*(10), parameter :: EOS_LINEAR_STRING = "LINEAR" !< A string for specifying the equation of state -character*(10), parameter :: EOS_UNESCO_STRING = "UNESCO" !< A string for specifying the equation of state -character*(10), parameter :: EOS_WRIGHT_STRING = "WRIGHT" !< A string for specifying the equation of state -character*(10), parameter :: EOS_TEOS10_STRING = "TEOS10" !< A string for specifying the equation of state -character*(10), parameter :: EOS_NEMO_STRING = "NEMO" !< A string for specifying the equation of state -character*(10), parameter :: EOS_DEFAULT = EOS_WRIGHT_STRING !< The default equation of state +integer, parameter, public :: EOS_WRIGHT_FULL = 4 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_WRIGHT_REDUCED = 5 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_TEOS10 = 6 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_ROQUET_RHO = 7 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_ROQUET_SPV = 8 !< A named integer specifying an equation of state +integer, parameter, public :: EOS_JACKETT06 = 9 !< A named integer specifying an equation of state +!> A list of all the available EOS +integer, dimension(9), public :: list_of_EOS = (/ EOS_LINEAR, EOS_UNESCO, & + EOS_WRIGHT, EOS_WRIGHT_FULL, EOS_WRIGHT_REDUCED, & + EOS_TEOS10, EOS_ROQUET_RHO, EOS_ROQUET_SPV, EOS_JACKETT06 /) + +character*(12), parameter :: EOS_LINEAR_STRING = "LINEAR" !< A string for specifying the equation of state +character*(12), parameter :: EOS_UNESCO_STRING = "UNESCO" !< A string for specifying the equation of state +character*(12), parameter :: EOS_JACKETT_STRING = "JACKETT_MCD" !< A string for specifying the equation of state +character*(12), parameter :: EOS_WRIGHT_STRING = "WRIGHT" !< A string for specifying the equation of state +character*(16), parameter :: EOS_WRIGHT_RED_STRING = "WRIGHT_REDUCED" !< A string for specifying the equation of state +character*(12), parameter :: EOS_WRIGHT_FULL_STRING = "WRIGHT_FULL" !< A string for specifying the equation of state +character*(12), parameter :: EOS_TEOS10_STRING = "TEOS10" !< A string for specifying the equation of state +character*(12), parameter :: EOS_NEMO_STRING = "NEMO" !< A string for specifying the equation of state +character*(12), parameter :: EOS_ROQUET_RHO_STRING = "ROQUET_RHO" !< A string for specifying the equation of state +character*(12), parameter :: EOS_ROQUET_SPV_STRING = "ROQUET_SPV" !< A string for specifying the equation of state +character*(12), parameter :: EOS_JACKETT06_STRING = "JACKETT_06" !< A string for specifying the equation of state +character*(12), parameter :: EOS_DEFAULT = EOS_WRIGHT_FULL_STRING !< The default equation of state integer, parameter :: TFREEZE_LINEAR = 1 !< A named integer specifying a freezing point expression integer, parameter :: TFREEZE_MILLERO = 2 !< A named integer specifying a freezing point expression integer, parameter :: TFREEZE_TEOS10 = 3 !< A named integer specifying a freezing point expression +integer, parameter :: TFREEZE_TEOSPOLY = 4 !< A named integer specifying a freezing point expression character*(10), parameter :: TFREEZE_LINEAR_STRING = "LINEAR" !< A string for specifying the freezing point expression -character*(10), parameter :: TFREEZE_MILLERO_STRING = "MILLERO_78" !< A string for specifying +character*(10), parameter :: TFREEZE_MILLERO_STRING = "MILLERO_78" !< A string for specifying the + !! freezing point expression +character*(10), parameter :: TFREEZE_TEOSPOLY_STRING = "TEOS_POLY" !< A string for specifying the !! freezing point expression character*(10), parameter :: TFREEZE_TEOS10_STRING = "TEOS10" !< A string for specifying the freezing point expression -character*(10), parameter :: TFREEZE_DEFAULT = TFREEZE_LINEAR_STRING !< The default freezing point expression contains -!> Calls the appropriate subroutine to calculate density of sea water for scalar inputs. +!> Density of sea water (in-situ if pressure is local) [R ~> kg m-3] +!! !! If rho_ref is present, the anomaly with respect to rho_ref is returned. The pressure and -!! density can be rescaled with the US. If both the US and scale arguments are present the density +!! density can be rescaled with the values stored in EOS. If the scale argument is present the density !! scaling uses the product of the two scaling factors. -subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref, scale) - real, intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, intent(in) :: S !< Salinity [ppt] - real, intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] - real, intent(out) :: rho !< Density (in-situ if pressure is local) [kg m-3] or [R ~> kg m-3] +real elemental function calculate_density_elem(EOS, T, S, pressure, rho_ref, scale) type(EOS_type), intent(in) :: EOS !< Equation of state structure - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density in - !! combination with scaling given by US [various] + real, intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, intent(in) :: S !< Salinity [S ~> ppt] + real, intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, optional, intent(in) :: rho_ref !< A reference density [R ~> kg m-3] + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale output density in + !! combination with scaling stored in EOS [various] + real :: Ta ! An array of temperatures [degC] + real :: Sa ! An array of salinities [ppt] + real :: pres ! An mks version of the pressure to use [Pa] + real :: rho_mks ! An mks version of the density to be returned [kg m-3] + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] + + pres = EOS%RL2_T2_to_Pa * pressure + Ta = EOS%C_to_degC * T + Sa = EOS%S_to_ppt * S + + if (present(rho_ref)) then + rho_mks = EOS%type%density_anomaly_elem(Ta, Sa, pres, EOS%R_to_kg_m3*rho_ref) + else + rho_mks = EOS%type%density_elem(Ta, Sa, pres) + endif - real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] - real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + ! Rescale the output density to the desired units. + rho_scale = EOS%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + calculate_density_elem = rho_scale * rho_mks - p_scale = EOS%RL2_T2_to_Pa +end function calculate_density_elem - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_density_linear(T, S, p_scale*pressure, rho, & - EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) - case (EOS_UNESCO) - call calculate_density_unesco(T, S, p_scale*pressure, rho, rho_ref) - case (EOS_WRIGHT) - call calculate_density_wright(T, S, p_scale*pressure, rho, rho_ref) - case (EOS_TEOS10) - call calculate_density_teos10(T, S, p_scale*pressure, rho, rho_ref) - case (EOS_NEMO) - call calculate_density_nemo(T, S, p_scale*pressure, rho, rho_ref) - case default - call MOM_error(FATAL, "calculate_density_scalar: EOS is not valid.") - end select +!> Calls the appropriate subroutine to calculate density of sea water for scalar inputs. +!! If rho_ref is present, the anomaly with respect to rho_ref is returned. The pressure and +!! density can be rescaled with the values stored in EOS. If the scale argument is present the density +!! scaling uses the product of the two scaling factors. +subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref, scale) + real, intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, intent(in) :: S !< Salinity [S ~> ppt] + real, intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, intent(out) :: rho !< Density (in-situ if pressure is local) [R ~> kg m-3] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + real, optional, intent(in) :: rho_ref !< A reference density [R ~> kg m-3] + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale output density in + !! combination with scaling stored in EOS [various] + + real :: Ta ! An array of temperatures [degC] + real :: Sa ! An array of salinities [ppt] + real :: pres ! An mks version of the pressure to use [Pa] + real :: rho_mks ! An mks version of the density to be returned [kg m-3] + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] + + pres = EOS%RL2_T2_to_Pa * pressure + Ta = EOS%C_to_degC * T + Sa = EOS%S_to_ppt * S + + if (present(rho_ref)) then + rho_mks = EOS%type%density_anomaly_elem(Ta, Sa, pres, EOS%R_to_kg_m3*rho_ref) + else + rho_mks = EOS%type%density_elem(Ta, Sa, pres) + endif + ! Rescale the output density to the desired units. rho_scale = EOS%kg_m3_to_R if (present(scale)) rho_scale = rho_scale * scale - rho = rho_scale * rho + rho = rho_scale * rho_mks end subroutine calculate_density_scalar @@ -204,161 +278,53 @@ end subroutine calculate_density_scalar !! If rho_ref is present, the anomaly with respect to rho_ref is returned. The !! density can be rescaled using rho_ref. subroutine calculate_stanley_density_scalar(T, S, pressure, Tvar, TScov, Svar, rho, EOS, rho_ref, scale) - real, intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, intent(in) :: S !< Salinity [ppt] - real, intent(in) :: Tvar !< Variance of potential temperature referenced to the surface [degC2] - real, intent(in) :: TScov !< Covariance of potential temperature and salinity [degC ppt] - real, intent(in) :: Svar !< Variance of salinity [ppt2] - real, intent(in) :: pressure !< Pressure [Pa] - real, intent(out) :: rho !< Density (in-situ if pressure is local) [kg m-3] or [R ~> kg m-3] + real, intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, intent(in) :: S !< Salinity [S ~> ppt] + real, intent(in) :: Tvar !< Variance of potential temperature referenced to the surface [C2 ~> degC2] + real, intent(in) :: TScov !< Covariance of potential temperature and salinity [C S ~> degC ppt] + real, intent(in) :: Svar !< Variance of salinity [S2 ~> ppt2] + real, intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, intent(out) :: rho !< Density (in-situ if pressure is local) [R ~> kg m-3] type(EOS_type), intent(in) :: EOS !< Equation of state structure - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! from kg m-3 to the desired units [R m3 kg-1] + real, optional, intent(in) :: rho_ref !< A reference density [R ~> kg m-3]. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale output density in + !! combination with scaling stored in EOS [various] ! Local variables - real :: d2RdTT, d2RdST, d2RdSS, d2RdSp, d2RdTp ! Second derivatives of density wrt T,S,p - real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] - real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] - - p_scale = EOS%RL2_T2_to_Pa + real :: d2RdTT ! Second derivative of density with temperature [R C-2 ~> kg m-3 degC-2] + real :: d2RdST ! Second derivative of density with temperature and salinity [R S-1 C-1 ~> kg m-3 degC-1 ppt-1] + real :: d2RdSS ! Second derivative of density with salinity [R S-2 ~> kg m-3 ppt-2] + real :: d2RdSp ! Second derivative of density with salinity and pressure [T2 S-1 L-2 ~> kg m-3 ppt-1 Pa-1] + real :: d2RdTp ! Second derivative of density with temperature and pressure [T2 C-1 L-2 ~> kg m-3 degC-1 Pa-1] - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_density_linear(T, S, p_scale*pressure, rho, & - EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) - call calculate_density_second_derivs_linear(T, S, pressure, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP) - case (EOS_WRIGHT) - call calculate_density_wright(T, S, p_scale*pressure, rho, rho_ref) - call calculate_density_second_derivs_wright(T, S, pressure, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP) - case (EOS_TEOS10) - call calculate_density_teos10(T, S, p_scale*pressure, rho, rho_ref) - call calculate_density_second_derivs_teos10(T, S, pressure, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP) - case default - call MOM_error(FATAL, "calculate_stanley_density_scalar: EOS is not valid.") - end select + call calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref) + call calculate_density_second_derivs_scalar(T, S, pressure, d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP, EOS) ! Equation 25 of Stanley et al., 2020. rho = rho + ( 0.5 * d2RdTT * Tvar + ( d2RdST * TScov + 0.5 * d2RdSS * Svar ) ) - rho_scale = EOS%kg_m3_to_R - if (present(scale)) rho_scale = rho_scale * scale - rho = rho_scale * rho + if (present(scale)) rho = rho * scale end subroutine calculate_stanley_density_scalar -!> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs. -!! If rho_ref is present, the anomaly with respect to rho_ref is returned. -subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_ref, scale) - real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(:), intent(in) :: S !< Salinity [ppt] - real, dimension(:), intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] - real, dimension(:), intent(inout) :: rho !< Density (in-situ if pressure is local) [kg m-3] or [R ~> kg m-3] - integer, intent(in) :: start !< Start index for computation - integer, intent(in) :: npts !< Number of point to compute - type(EOS_type), intent(in) :: EOS !< Equation of state structure - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! in combination with scaling given by US [various] - integer :: j - - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_density_linear(T, S, pressure, rho, start, npts, & - EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) - case (EOS_UNESCO) - call calculate_density_unesco(T, S, pressure, rho, start, npts, rho_ref) - case (EOS_WRIGHT) - call calculate_density_wright(T, S, pressure, rho, start, npts, rho_ref) - case (EOS_TEOS10) - call calculate_density_teos10(T, S, pressure, rho, start, npts, rho_ref) - case (EOS_NEMO) - call calculate_density_nemo(T, S, pressure, rho, start, npts, rho_ref) - case default - call MOM_error(FATAL, "calculate_density_array: EOS%form_of_EOS is not valid.") - end select - - if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 - rho(j) = scale * rho(j) - enddo ; endif ; endif - -end subroutine calculate_density_array - -!> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs -!! including the variance of T, S and covariance of T-S. -!! The calculation uses only the second order correction in a series as discussed -!! in Stanley et al., 2020. -!! If rho_ref is present, the anomaly with respect to rho_ref is returned. -subroutine calculate_stanley_density_array(T, S, pressure, Tvar, TScov, Svar, rho, start, npts, EOS, rho_ref, scale) - real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(:), intent(in) :: S !< Salinity [ppt] - real, dimension(:), intent(in) :: pressure !< Pressure [Pa] - real, dimension(:), intent(in) :: Tvar !< Variance of potential temperature referenced to the surface [degC2] - real, dimension(:), intent(in) :: TScov !< Covariance of potential temperature and salinity [degC ppt] - real, dimension(:), intent(in) :: Svar !< Variance of salinity [ppt2] - real, dimension(:), intent(inout) :: rho !< Density (in-situ if pressure is local) [kg m-3] - integer, intent(in) :: start !< Start index for computation - integer, intent(in) :: npts !< Number of point to compute - type(EOS_type), intent(in) :: EOS !< Equation of state structure - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! from kg m-3 to the desired units [R m3 kg-1] - ! Local variables - real, dimension(size(T)) :: d2RdTT, d2RdST, d2RdSS, d2RdSp, d2RdTp ! Second derivatives of density wrt T,S,p - integer :: j - - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_density_linear(T, S, pressure, rho, start, npts, & - EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) - call calculate_density_second_derivs_linear(T, S, pressure, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP, start, npts) - case (EOS_WRIGHT) - call calculate_density_wright(T, S, pressure, rho, start, npts, rho_ref) - call calculate_density_second_derivs_wright(T, S, pressure, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP, start, npts) - case (EOS_TEOS10) - call calculate_density_teos10(T, S, pressure, rho, start, npts, rho_ref) - call calculate_density_second_derivs_teos10(T, S, pressure, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP, start, npts) - case default - call MOM_error(FATAL, "calculate_stanley_density_array: EOS%form_of_EOS is not valid.") - end select - - ! Equation 25 of Stanley et al., 2020. - do j=start,start+npts-1 - rho(j) = rho(j) & - + ( 0.5 * d2RdTT(j) * Tvar(j) + ( d2RdST(j) * TScov(j) + 0.5 * d2RdSS(j) * Svar(j) ) ) - enddo - - if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 - rho(j) = scale * rho(j) - enddo ; endif ; endif - -end subroutine calculate_stanley_density_array - !> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs, !! potentially limiting the domain of indices that are worked on. !! If rho_ref is present, the anomaly with respect to rho_ref is returned. subroutine calculate_density_1d(T, S, pressure, rho, EOS, dom, rho_ref, scale) - real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, dimension(:), intent(in) :: S !< Salinity [S ~> ppt] real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] real, dimension(:), intent(inout) :: rho !< Density (in-situ if pressure is local) [R ~> kg m-3] type(EOS_type), intent(in) :: EOS !< Equation of state structure integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking !! into account that arrays start at 1. - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + real, optional, intent(in) :: rho_ref !< A reference density [R ~> kg m-3] real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! in combination with scaling given by US [various] + !! in combination with scaling stored in EOS [various] ! Local variables - real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] - real :: rho_unscale ! A factor to convert density from R to kg m-3 [kg m-3 R-1 ~> 1] - real :: rho_reference ! rho_ref converted to [kg m-3] real, dimension(size(rho)) :: pres ! Pressure converted to [Pa] + real, dimension(size(rho)) :: Ta ! Temperature converted to [degC] + real, dimension(size(rho)) :: Sa ! Salinity converted to [ppt] integer :: i, is, ie, npts if (present(dom)) then @@ -367,19 +333,20 @@ subroutine calculate_density_1d(T, S, pressure, rho, EOS, dom, rho_ref, scale) is = 1 ; ie = size(rho) ; npts = 1 + ie - is endif - p_scale = EOS%RL2_T2_to_Pa - rho_unscale = EOS%R_to_kg_m3 - - if ((p_scale == 1.0) .and. (rho_unscale == 1.0)) then - call calculate_density_array(T, S, pressure, rho, is, npts, EOS, rho_ref=rho_ref) - elseif (present(rho_ref)) then ! This is the same as above, but with some extra work to rescale variables. - do i=is,ie ; pres(i) = p_scale * pressure(i) ; enddo - rho_reference = rho_unscale*rho_ref - call calculate_density_array(T, S, pres, rho, is, npts, EOS, rho_ref=rho_reference) - else ! There is rescaling of variables, but rho_ref is not present. Passing a 0 value of rho_ref - ! changes answers at roundoff for some equations of state, like Wright and UNESCO. - do i=is,ie ; pres(i) = p_scale * pressure(i) ; enddo - call calculate_density_array(T, S, pres, rho, is, npts, EOS) + if ((EOS%RL2_T2_to_Pa == 1.0) .and. (EOS%R_to_kg_m3 == 1.0) .and. & + (EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then + call EOS%type%calculate_density_array(T, S, pressure, rho, is, npts, rho_ref=rho_ref) + else ! This is the same as above, but with some extra work to rescale variables. + do i=is,ie + pres(i) = EOS%RL2_T2_to_Pa * pressure(i) + Ta(i) = EOS%C_to_degC * T(i) + Sa(i) = EOS%S_to_ppt * S(i) + enddo + if (present(rho_ref)) then + call EOS%type%calculate_density_array(Ta, Sa, pres, rho, is, npts, rho_ref=EOS%R_to_kg_m3*rho_ref) + else + call EOS%type%calculate_density_array(Ta, Sa, pres, rho, is, npts) + endif endif rho_scale = EOS%kg_m3_to_R @@ -397,24 +364,26 @@ end subroutine calculate_density_1d !! in Stanley et al., 2020. !! If rho_ref is present, the anomaly with respect to rho_ref is returned. subroutine calculate_stanley_density_1d(T, S, pressure, Tvar, TScov, Svar, rho, EOS, dom, rho_ref, scale) - real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, dimension(:), intent(in) :: S !< Salinity [S ~> ppt] real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] - real, dimension(:), intent(in) :: Tvar !< Variance of potential temperature [degC2] - real, dimension(:), intent(in) :: TScov !< Covariance of potential temperature and salinity [degC ppt] - real, dimension(:), intent(in) :: Svar !< Variance of salinity [ppt2] + real, dimension(:), intent(in) :: Tvar !< Variance of potential temperature [C2 ~> degC2] + real, dimension(:), intent(in) :: TScov !< Covariance of potential temperature and salinity [C S ~> degC ppt] + real, dimension(:), intent(in) :: Svar !< Variance of salinity [S2 ~> ppt2] real, dimension(:), intent(inout) :: rho !< Density (in-situ if pressure is local) [R ~> kg m-3] type(EOS_type), intent(in) :: EOS !< Equation of state structure integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking !! into account that arrays start at 1. - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + real, optional, intent(in) :: rho_ref !< A reference density [R ~> kg m-3] real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! in combination with scaling given by US [various] + !! in combination with scaling stored in EOS [various] ! Local variables - real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] - real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] - real, dimension(size(rho)) :: pres ! Pressure converted to [Pa] - real, dimension(size(T)) :: d2RdTT, d2RdST, d2RdSS, d2RdSp, d2RdTp ! Second derivatives of density wrt T,S,p + real, dimension(size(T)) :: & + d2RdTT, & ! Second derivative of density with temperature [R C-2 ~> kg m-3 degC-2] + d2RdST, & ! Second derivative of density with temperature and salinity [R S-1 C-1 ~> kg m-3 degC-1 ppt-1] + d2RdSS, & ! Second derivative of density with salinity [R S-2 ~> kg m-3 ppt-2] + d2RdSp, & ! Second derivative of density with salinity and pressure [T2 S-1 L-2 ~> kg m-3 ppt-1 Pa-1] + d2RdTp ! Second derivative of density with temperature and pressure [T2 C-1 L-2 ~> kg m-3 degC-1 Pa-1] integer :: i, is, ie, npts if (present(dom)) then @@ -423,40 +392,17 @@ subroutine calculate_stanley_density_1d(T, S, pressure, Tvar, TScov, Svar, rho, is = 1 ; ie = size(rho) ; npts = 1 + ie - is endif - p_scale = EOS%RL2_T2_to_Pa - do i=is,ie - pres(i) = p_scale * pressure(i) - enddo - - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_density_linear(T, S, pres, rho, 1, npts, & - EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) - call calculate_density_second_derivs_linear(T, S, pres, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP, 1, npts) - case (EOS_WRIGHT) - call calculate_density_wright(T, S, pres, rho, 1, npts, rho_ref) - call calculate_density_second_derivs_wright(T, S, pres, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP, 1, npts) - case (EOS_TEOS10) - call calculate_density_teos10(T, S, pres, rho, 1, npts, rho_ref) - call calculate_density_second_derivs_teos10(T, S, pres, d2RdSS, d2RdST, & - d2RdTT, d2RdSp, d2RdTP, 1, npts) - case default - call MOM_error(FATAL, "calculate_stanley_density_scalar: EOS is not valid.") - end select + call calculate_density_1d(T, S, pressure, rho, EOS, dom, rho_ref) + call calculate_density_second_derivs_1d(T, S, pressure, d2RdSS, d2RdST, d2RdTT, d2RdSp, d2RdTP, EOS, dom) ! Equation 25 of Stanley et al., 2020. do i=is,ie - rho(i) = rho(i) & - + ( 0.5 * d2RdTT(i) * Tvar(i) + ( d2RdST(i) * TScov(i) + 0.5 * d2RdSS(i) * Svar(i) ) ) + rho(i) = rho(i) + ( 0.5 * d2RdTT(i) * Tvar(i) + ( d2RdST(i) * TScov(i) + 0.5 * d2RdSS(i) * Svar(i) ) ) enddo - rho_scale = EOS%kg_m3_to_R - if (present(scale)) rho_scale = rho_scale * scale - if (rho_scale /= 1.0) then ; do i=is,ie - rho(i) = rho_scale * rho(i) - enddo ; endif + if (present(scale)) then ; if (scale /= 1.0) then ; do i=is,ie + rho(i) = scale * rho(i) + enddo ; endif ; endif end subroutine calculate_stanley_density_1d @@ -472,31 +418,14 @@ subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, s type(EOS_type), intent(in) :: EOS !< Equation of state structure real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific - !! volume in combination with scaling given by US [various] + !! volume in combination with scaling stored in EOS [various] - real, dimension(size(specvol)) :: rho ! Density [kg m-3] integer :: j - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_spec_vol_linear(T, S, pressure, specvol, start, npts, & - EOS%rho_T0_S0, EOS%drho_dT, EOS%drho_dS, spv_ref) - case (EOS_UNESCO) - call calculate_spec_vol_unesco(T, S, pressure, specvol, start, npts, spv_ref) - case (EOS_WRIGHT) - call calculate_spec_vol_wright(T, S, pressure, specvol, start, npts, spv_ref) - case (EOS_TEOS10) - call calculate_spec_vol_teos10(T, S, pressure, specvol, start, npts, spv_ref) - case (EOS_NEMO) - call calculate_density_nemo(T, S, pressure, rho, start, npts) - if (present(spv_ref)) then - specvol(:) = 1.0 / rho(:) - spv_ref - else - specvol(:) = 1.0 / rho(:) - endif - case default - call MOM_error(FATAL, "calculate_spec_vol_array: EOS%form_of_EOS is not valid.") - end select + if (.not. allocated(EOS%type)) call MOM_error(FATAL, & + "calculate_spec_vol_array: EOS%form_of_EOS is not valid.") + + call EOS%type%calculate_spec_vol_array(T, S, pressure, specvol, start, npts, spv_ref) if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 specvol(j) = scale * specvol(j) @@ -507,25 +436,27 @@ end subroutine calculate_spec_vol_array !> Calls the appropriate subroutine to calculate specific volume of sea water !! for scalar inputs. subroutine calc_spec_vol_scalar(T, S, pressure, specvol, EOS, spv_ref, scale) - real, intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, intent(in) :: S !< Salinity [ppt] - real, intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] - real, intent(out) :: specvol !< In situ? specific volume [m3 kg-1] or [R-1 ~> m3 kg-1] + real, intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, intent(in) :: S !< Salinity [S ~> ppt] + real, intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, intent(out) :: specvol !< In situ or potential specific volume [R-1 ~> m3 kg-1] + !! or other units determined by the scale argument type(EOS_type), intent(in) :: EOS !< Equation of state structure - real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] or [R-1 m3 kg-1] + real, optional, intent(in) :: spv_ref !< A reference specific volume [R-1 ~> m3 kg-1] real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific - !! volume in combination with scaling given by US [various] + !! volume in combination with scaling stored in EOS [various] - real, dimension(1) :: Ta, Sa, pres, spv ! Rescaled single element array versions of the arguments. - real :: spv_reference ! spv_ref converted to [m3 kg-1] + real, dimension(1) :: Ta ! Rescaled single element array version of temperature [degC] + real, dimension(1) :: Sa ! Rescaled single element array version of salinity [ppt] + real, dimension(1) :: pres ! Rescaled single element array version of pressure [Pa] + real, dimension(1) :: spv ! Rescaled single element array version of specific volume [m3 kg-1] real :: spv_scale ! A factor to convert specific volume from m3 kg-1 to the desired units [kg R-1 m-3 ~> 1] - pres(1) = EOS%RL2_T2_to_Pa*pressure - Ta(1) = T ; Sa(1) = S + pres(1) = EOS%RL2_T2_to_Pa * pressure + Ta(1) = EOS%C_to_degC * T ; Sa(1) = EOS%S_to_ppt * S if (present(spv_ref)) then - spv_reference = EOS%kg_m3_to_R*spv_ref - call calculate_spec_vol_array(Ta, Sa, pres, spv, 1, 1, EOS, spv_reference) + call calculate_spec_vol_array(Ta, Sa, pres, spv, 1, 1, EOS, EOS%kg_m3_to_R*spv_ref) else call calculate_spec_vol_array(Ta, Sa, pres, spv, 1, 1, EOS) endif @@ -542,8 +473,8 @@ end subroutine calc_spec_vol_scalar !> Calls the appropriate subroutine to calculate the specific volume of sea water for 1-D array !! inputs, potentially limiting the domain of indices that are worked on. subroutine calc_spec_vol_1d(T, S, pressure, specvol, EOS, dom, spv_ref, scale) - real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, dimension(:), intent(in) :: S !< Salinity [S ~> ppt] real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] real, dimension(:), intent(inout) :: specvol !< In situ specific volume [R-1 ~> m3 kg-1] type(EOS_type), intent(in) :: EOS !< Equation of state structure @@ -552,13 +483,12 @@ subroutine calc_spec_vol_1d(T, S, pressure, specvol, EOS, dom, spv_ref, scale) real, optional, intent(in) :: spv_ref !< A reference specific volume [R-1 ~> m3 kg-1] real, optional, intent(in) :: scale !< A multiplicative factor by which to scale !! output specific volume in combination with - !! scaling given by US [various] + !! scaling stored in EOS [various] ! Local variables - real, dimension(size(specvol)) :: pres ! Pressure converted to [Pa] - real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] - real :: spv_unscale ! A factor to convert specific volume from R-1 to m3 kg-1 [m3 kg-1 R ~> 1] + real, dimension(size(T)) :: pres ! Pressure converted to [Pa] + real, dimension(size(T)) :: Ta ! Temperature converted to [degC] + real, dimension(size(T)) :: Sa ! Salinity converted to [ppt] real :: spv_scale ! A factor to convert specific volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] - real :: spv_reference ! spv_ref converted to [m3 kg-1] integer :: i, is, ie, npts if (present(dom)) then @@ -567,19 +497,22 @@ subroutine calc_spec_vol_1d(T, S, pressure, specvol, EOS, dom, spv_ref, scale) is = 1 ; ie = size(specvol) ; npts = 1 + ie - is endif - p_scale = EOS%RL2_T2_to_Pa - spv_unscale = EOS%kg_m3_to_R - - if ((p_scale == 1.0) .and. (spv_unscale == 1.0)) then + if ((EOS%RL2_T2_to_Pa == 1.0) .and. (EOS%kg_m3_to_R == 1.0) .and. & + (EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then call calculate_spec_vol_array(T, S, pressure, specvol, is, npts, EOS, spv_ref) - elseif (present(spv_ref)) then ! This is the same as above, but with some extra work to rescale variables. - do i=is,ie ; pres(i) = p_scale * pressure(i) ; enddo - spv_reference = spv_unscale*spv_ref - call calculate_spec_vol_array(T, S, pres, specvol, is, npts, EOS, spv_reference) - else ! There is rescaling of variables, but spv_ref is not present. Passing a 0 value of spv_ref - ! changes answers at roundoff for some equations of state, like Wright and UNESCO. - do i=is,ie ; pres(i) = p_scale * pressure(i) ; enddo - call calculate_spec_vol_array(T, S, pres, specvol, is, npts, EOS) + else ! This is the same as above, but with some extra work to rescale variables. + do i=is,ie + pres(i) = EOS%RL2_T2_to_Pa * pressure(i) + Ta(i) = EOS%C_to_degC * T(i) + Sa(i) = EOS%S_to_ppt * S(i) + enddo + if (present(spv_ref)) then + call calculate_spec_vol_array(Ta, Sa, pres, specvol, is, npts, EOS, EOS%kg_m3_to_R*spv_ref) + else + ! There is rescaling of variables, but spv_ref is not present. Passing a 0 value of spv_ref + ! changes answers at roundoff for some equations of state, like Wright and UNESCO. + call calculate_spec_vol_array(Ta, Sa, pres, specvol, is, npts, EOS) + endif endif spv_scale = EOS%R_to_kg_m3 @@ -592,60 +525,115 @@ end subroutine calc_spec_vol_1d !> Calls the appropriate subroutine to calculate the freezing point for scalar inputs. -subroutine calculate_TFreeze_scalar(S, pressure, T_fr, EOS, pres_scale) - real, intent(in) :: S !< Salinity [ppt] - real, intent(in) :: pressure !< Pressure [Pa] or [other] - real, intent(out) :: T_fr !< Freezing point potential temperature referenced - !! to the surface [degC] - type(EOS_type), intent(in) :: EOS !< Equation of state structure - real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa +subroutine calculate_TFreeze_scalar(S, pressure, T_fr, EOS, pres_scale, scale_from_EOS) + real, intent(in) :: S !< Salinity, [ppt] or [S ~> ppt] depending on scale_from_EOS + real, intent(in) :: pressure !< Pressure, in [Pa] or [R L2 T-2 ~> Pa] depending on + !! pres_scale or scale_from_EOS + real, intent(out) :: T_fr !< Freezing point potential temperature referenced to the + !! surface [degC] or [C ~> degC] depending on scale_from_EOS + type(EOS_type), intent(in) :: EOS !< Equation of state structure + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [Pa T2 R-1 L-2 ~> 1]. + logical, optional, intent(in) :: scale_from_EOS !< If present true use the dimensional scaling + !! factors stored in EOS. Omission is the same .false. ! Local variables - real :: p_scale ! A factor to convert pressure to units of Pa. - - p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + real :: S_scale ! A factor to convert salinity to units of ppt [ppt S-1 ~> 1] + real :: iS_scale! A factor to convert salinity to units of S [S ppt-1 ~> 1] + real :: absS ! A salinity converted to absolute salinity, only used in specific scenarios [ppt] + real :: TFreeze_S ! The salinity for the freezing equation in model units [S ~> PSU or ppt] + + p_scale = 1.0 ; S_scale = 1.0 ; iS_scale = 1.0 + if (present(pres_scale)) p_scale = pres_scale + if (present(scale_from_EOS)) then ; if (scale_from_EOS) then + p_scale = EOS%RL2_T2_to_Pa + S_scale = EOS%S_to_ppt + iS_scale = EOS%ppt_to_S + endif ; endif + + if (EOS%use_conT_absS) then + ! Otherwise absS is unneeded and therefore unset + absS = S*S_scale + if (EOS%TFreeze_S_is_pracS) then + TFreeze_S = gsw_sp_from_sr(absS)*iS_scale + else + TFreeze_S = S + endif + else + TFreeze_S = S + endif select case (EOS%form_of_TFreeze) case (TFREEZE_LINEAR) - call calculate_TFreeze_linear(S, p_scale*pressure, T_fr, EOS%TFr_S0_P0, & + call calculate_TFreeze_linear(S_scale*TFreeze_S, p_scale*pressure, T_fr, EOS%TFr_S0_P0, & EOS%dTFr_dS, EOS%dTFr_dp) case (TFREEZE_MILLERO) - call calculate_TFreeze_Millero(S, p_scale*pressure, T_fr) + call calculate_TFreeze_Millero(S_scale*TFreeze_S, p_scale*pressure, T_fr) + case (TFREEZE_TEOSPOLY) + call calculate_TFreeze_TEOS_poly(S_scale*TFreeze_S, p_scale*pressure, T_fr) case (TFREEZE_TEOS10) - call calculate_TFreeze_teos10(S, p_scale*pressure, T_fr) + call calculate_TFreeze_teos10(S_scale*TFreeze_S, p_scale*pressure, T_fr) case default call MOM_error(FATAL, "calculate_TFreeze_scalar: form_of_TFreeze is not valid.") end select + if (EOS%use_conT_absS .and. EOS%TFreeze_T_is_potT) then + ! absS is set only if EOS%use_conT_absS is True + ! absS and T_fr have physical units here and don't need converted + T_fr = gsw_ct_from_pt(absS,T_fr) + endif + + if (present(scale_from_EOS)) then ; if (scale_from_EOS) then + T_fr = EOS%degC_to_C * T_fr + endif ; endif + end subroutine calculate_TFreeze_scalar !> Calls the appropriate subroutine to calculate the freezing point for a 1-D array. subroutine calculate_TFreeze_array(S, pressure, T_fr, start, npts, EOS, pres_scale) real, dimension(:), intent(in) :: S !< Salinity [ppt] - real, dimension(:), intent(in) :: pressure !< Pressure [Pa] or [other] - real, dimension(:), intent(inout) :: T_fr !< Freezing point potential temperature referenced - !! to the surface [degC] + real, dimension(:), intent(in) :: pressure !< Pressure, in [Pa] or [R L2 T-2 ~> Pa] depending on pres_scale + real, dimension(:), intent(inout) :: T_fr !< Freezing point, either potential temperature referenced to the + !! surface or conservative temperature depending on settings [degC] integer, intent(in) :: start !< Starting index within the array integer, intent(in) :: npts !< The number of values to calculate type(EOS_type), intent(in) :: EOS !< Equation of state structure - real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure into Pa. + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [Pa T2 R-1 L-2 ~> 1]. ! Local variables real, dimension(size(pressure)) :: pres ! Pressure converted to [Pa] - real :: p_scale ! A factor to convert pressure to units of Pa. + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + real, dimension(size(S)) :: absS ! A salinity converted to absolute salinity, only used in specific scenarios [ppt] + real, dimension(size(S)) :: TFreeze_S ! The salinity for the freezing equation in model units [S ~> PSU or ppt] integer :: j p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale + if (EOS%use_conT_absS) then + ! Otherwise absS is unneeded and therefore unset + absS(:) = S(:) + if (EOS%TFreeze_S_is_pracS) then + TFreeze_S(:) = gsw_sp_from_sr(absS(:)) + else + TFreeze_S(:) = S(:) + endif + else + TFreeze_S(:) = S(:) + endif + if (p_scale == 1.0) then select case (EOS%form_of_TFreeze) case (TFREEZE_LINEAR) - call calculate_TFreeze_linear(S, pressure, T_fr, start, npts, & + call calculate_TFreeze_linear(TFreeze_S, pressure, T_fr, start, npts, & EOS%TFr_S0_P0, EOS%dTFr_dS, EOS%dTFr_dp) case (TFREEZE_MILLERO) - call calculate_TFreeze_Millero(S, pressure, T_fr, start, npts) + call calculate_TFreeze_Millero(TFreeze_S, pressure, T_fr, start, npts) + case (TFREEZE_TEOSPOLY) + call calculate_TFreeze_TEOS_poly(TFreeze_S, pressure, T_fr, start, npts) case (TFREEZE_TEOS10) - call calculate_TFreeze_teos10(S, pressure, T_fr, start, npts) + call calculate_TFreeze_teos10(TFreeze_S, pressure, T_fr, start, npts) case default call MOM_error(FATAL, "calculate_TFreeze_scalar: form_of_TFreeze is not valid.") end select @@ -653,52 +641,136 @@ subroutine calculate_TFreeze_array(S, pressure, T_fr, start, npts, EOS, pres_sca do j=start,start+npts-1 ; pres(j) = p_scale * pressure(j) ; enddo select case (EOS%form_of_TFreeze) case (TFREEZE_LINEAR) - call calculate_TFreeze_linear(S, pres, T_fr, start, npts, & + call calculate_TFreeze_linear(TFreeze_S, pres, T_fr, start, npts, & EOS%TFr_S0_P0, EOS%dTFr_dS, EOS%dTFr_dp) case (TFREEZE_MILLERO) - call calculate_TFreeze_Millero(S, pres, T_fr, start, npts) + call calculate_TFreeze_Millero(TFreeze_S, pres, T_fr, start, npts) case (TFREEZE_TEOS10) - call calculate_TFreeze_teos10(S, pres, T_fr, start, npts) + call calculate_TFreeze_teos10(TFreeze_S, pres, T_fr, start, npts) + case (TFREEZE_TEOSPOLY) + call calculate_TFreeze_TEOS_poly(TFreeze_S, pres, T_fr, start, npts) case default call MOM_error(FATAL, "calculate_TFreeze_scalar: form_of_TFreeze is not valid.") end select endif + if (EOS%use_conT_absS .and. EOS%TFreeze_T_is_potT) then + ! absS is set only if EOS%use_conT_absS is True! + T_fr(:) = gsw_ct_from_pt(absS(:),T_fr(:)) + endif + + end subroutine calculate_TFreeze_array +!> Calls the appropriate subroutine to calculate the freezing point for a 1-D array, taking +!! dimensionally rescaled arguments with factors stored in EOS. +subroutine calculate_TFreeze_1d(S, pressure, T_fr, EOS, dom) + real, dimension(:), intent(in) :: S !< Salinity [S ~> ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, dimension(:), intent(inout) :: T_fr !< Freezing point, either potential temperature referenced to the + !! surface or conservative temperature depending on settings + !! [C ~> degC] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + + ! Local variables + real, dimension(size(T_fr)) :: pres ! Pressure converted to [Pa] + real, dimension(size(T_fr)) :: Sa ! Salinity converted to [ppt] + real, dimension(size(T_fr)) :: absS ! Salinity converted to absoluate salinity [ppt] + real, dimension(size(T_fr)) :: TFreeze_S ! The salinity for the freezing equation in model units [S ~> PSU or ppt] + integer :: i, is, ie, npts + + if (present(dom)) then + is = dom(1) ; ie = dom(2) ; npts = 1 + ie - is + else + is = 1 ; ie = size(T_Fr) ; npts = 1 + ie - is + endif + + if (EOS%use_conT_absS) then + ! Otherwise absS is unneeded and therefore unset + absS(:) = S(:)*EOS%S_to_ppt + if (EOS%TFreeze_S_is_pracS) then + TFreeze_S(:) = gsw_sp_from_sr(absS(:))*EOS%ppt_to_S + else + TFreeze_S(:) = S(:) + endif + else + TFreeze_S(:) = S(:) + endif + + if ((EOS%RL2_T2_to_Pa == 1.0) .and. (EOS%S_to_ppt == 1.0)) then + select case (EOS%form_of_TFreeze) + case (TFREEZE_LINEAR) + call calculate_TFreeze_linear(TFreeze_S, pressure, T_fr, is, npts, & + EOS%TFr_S0_P0, EOS%dTFr_dS, EOS%dTFr_dp) + case (TFREEZE_MILLERO) + call calculate_TFreeze_Millero(TFreeze_S, pressure, T_fr, is, npts) + case (TFREEZE_TEOSPOLY) + call calculate_TFreeze_TEOS_poly(TFreeze_S, pressure, T_fr, is, npts) + case (TFREEZE_TEOS10) + call calculate_TFreeze_teos10(TFreeze_S, pressure, T_fr, is, npts) + case default + call MOM_error(FATAL, "calculate_TFreeze_scalar: form_of_TFreeze is not valid.") + end select + else + do i=is,ie + pres(i) = EOS%RL2_T2_to_Pa * pressure(i) + Sa(i) = EOS%S_to_ppt * TFreeze_S(i) + enddo + select case (EOS%form_of_TFreeze) + case (TFREEZE_LINEAR) + call calculate_TFreeze_linear(Sa, pres, T_fr, is, npts, & + EOS%TFr_S0_P0, EOS%dTFr_dS, EOS%dTFr_dp) + case (TFREEZE_MILLERO) + call calculate_TFreeze_Millero(Sa, pres, T_fr, is, npts) + case (TFREEZE_TEOSPOLY) + call calculate_TFreeze_TEOS_poly(Sa, pres, T_fr, is, npts) + case (TFREEZE_TEOS10) + call calculate_TFreeze_teos10(Sa, pres, T_fr, is, npts) + case default + call MOM_error(FATAL, "calculate_TFreeze_scalar: form_of_TFreeze is not valid.") + end select + endif + + if (EOS%use_conT_absS .and. EOS%TFreeze_T_is_potT) then + ! absS is set only if EOS%use_conT_absS is True! + ! absS is in ppt and T_fr is in degC at this point. + T_fr(:) = gsw_ct_from_pt(absS(:),T_fr(:)) + endif + + + if (EOS%degC_to_C /= 1.0) then + do i=is,ie ; T_fr(i) = EOS%degC_to_C * T_fr(i) ; enddo + endif + +end subroutine calculate_TFreeze_1d + + !> Calls the appropriate subroutine to calculate density derivatives for 1-D array inputs. subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, start, npts, EOS, scale) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] real, dimension(:), intent(in) :: S !< Salinity [ppt] - real, dimension(:), intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] real, dimension(:), intent(inout) :: drho_dT !< The partial derivative of density with potential - !! temperature [kg m-3 degC-1] or [R degC-1 ~> kg m-3 degC-1] + !! temperature [kg m-3 degC-1] or other units determined + !! by the optional scale argument real, dimension(:), intent(inout) :: drho_dS !< The partial derivative of density with salinity, - !! in [kg m-3 ppt-1] or [R ppt-1 ~> kg m-3 ppt-1] + !! in [kg m-3 ppt-1] or other units determined + !! by the optional scale argument integer, intent(in) :: start !< Starting index within the array integer, intent(in) :: npts !< The number of values to calculate type(EOS_type), intent(in) :: EOS !< Equation of state structure - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! in combination with scaling given by US [various] + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! in combination with scaling stored in EOS [various] ! Local variables integer :: j - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_density_derivs_linear(T, S, pressure, drho_dT, drho_dS, EOS%Rho_T0_S0, & - EOS%dRho_dT, EOS%dRho_dS, start, npts) - case (EOS_UNESCO) - call calculate_density_derivs_unesco(T, S, pressure, drho_dT, drho_dS, start, npts) - case (EOS_WRIGHT) - call calculate_density_derivs_wright(T, S, pressure, drho_dT, drho_dS, start, npts) - case (EOS_TEOS10) - call calculate_density_derivs_teos10(T, S, pressure, drho_dT, drho_dS, start, npts) - case (EOS_NEMO) - call calculate_density_derivs_nemo(T, S, pressure, drho_dT, drho_dS, start, npts) - case default - call MOM_error(FATAL, "calculate_density_derivs_array: EOS%form_of_EOS is not valid.") - end select + if (.not. allocated(EOS%type)) call MOM_error(FATAL, & + "calculate_density_derivs_array: EOS%form_of_EOS is not valid.") + + call EOS%type%calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, start, npts) if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 drho_dT(j) = scale * drho_dT(j) @@ -710,22 +782,25 @@ end subroutine calculate_density_derivs_array !> Calls the appropriate subroutine to calculate density derivatives for 1-D array inputs. subroutine calculate_density_derivs_1d(T, S, pressure, drho_dT, drho_dS, EOS, dom, scale) - real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, dimension(:), intent(in) :: S !< Salinity [S ~> ppt] real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] real, dimension(:), intent(inout) :: drho_dT !< The partial derivative of density with potential - !! temperature [R degC-1 ~> kg m-3 degC-1] + !! temperature [R C-1 ~> kg m-3 degC-1] real, dimension(:), intent(inout) :: drho_dS !< The partial derivative of density with salinity - !! [R ppt-1 ~> kg m-3 ppt-1] + !! [R S-1 ~> kg m-3 ppt-1] type(EOS_type), intent(in) :: EOS !< Equation of state structure integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking !! into account that arrays start at 1. real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! in combination with scaling given by US [various] + !! in combination with scaling stored in EOS [various] ! Local variables real, dimension(size(drho_dT)) :: pres ! Pressure converted to [Pa] + real, dimension(size(drho_dT)) :: Ta ! Temperature converted to [degC] + real, dimension(size(drho_dT)) :: Sa ! Salinity converted to [ppt] real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] - real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + real :: dRdT_scale ! A factor to convert drho_dT to the desired units [R degC m3 C-1 kg-1 ~> 1] + real :: dRdS_scale ! A factor to convert drho_dS to the desired units [R ppt m3 S-1 kg-1 ~> 1] integer :: i, is, ie, npts if (present(dom)) then @@ -734,20 +809,24 @@ subroutine calculate_density_derivs_1d(T, S, pressure, drho_dT, drho_dS, EOS, do is = 1 ; ie = size(drho_dT) ; npts = 1 + ie - is endif - p_scale = EOS%RL2_T2_to_Pa - - if (p_scale == 1.0) then + if ((EOS%RL2_T2_to_Pa == 1.0) .and. (EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then call calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, is, npts, EOS) else - do i=is,ie ; pres(i) = p_scale * pressure(i) ; enddo - call calculate_density_derivs_array(T, S, pres, drho_dT, drho_dS, is, npts, EOS) + do i=is,ie + pres(i) = EOS%RL2_T2_to_Pa * pressure(i) + Ta(i) = EOS%C_to_degC * T(i) + Sa(i) = EOS%S_to_ppt * S(i) + enddo + call calculate_density_derivs_array(Ta, Sa, pres, drho_dT, drho_dS, is, npts, EOS) endif rho_scale = EOS%kg_m3_to_R if (present(scale)) rho_scale = rho_scale * scale - if (rho_scale /= 1.0) then ; do i=is,ie - drho_dT(i) = rho_scale * drho_dT(i) - drho_dS(i) = rho_scale * drho_dS(i) + dRdT_scale = rho_scale * EOS%C_to_degC + dRdS_scale = rho_scale * EOS%S_to_ppt + if ((dRdT_scale /= 1.0) .or. (dRdS_scale /= 1.0)) then ; do i=is,ie + drho_dT(i) = dRdT_scale * drho_dT(i) + drho_dS(i) = dRdS_scale * drho_dS(i) enddo ; endif end subroutine calculate_density_derivs_1d @@ -756,164 +835,156 @@ end subroutine calculate_density_derivs_1d !> Calls the appropriate subroutines to calculate density derivatives by promoting a scalar !! to a one-element array subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS, scale) - real, intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, intent(in) :: S !< Salinity [ppt] - real, intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] + real, intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, intent(in) :: S !< Salinity [S ~> ppt] + real, intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] real, intent(out) :: drho_dT !< The partial derivative of density with potential - !! temperature [kg m-3 degC-1] or [R degC-1 ~> kg m-3 degC-1] + !! temperature [R C-1 ~> kg m-3 degC-1] or other + !! units determined by the optional scale argument real, intent(out) :: drho_dS !< The partial derivative of density with salinity, - !! in [kg m-3 ppt-1] or [R ppt-1 ~> kg m-3 ppt-1] + !! in [R S-1 ~> kg m-3 ppt-1] or other units + !! determined by the optional scale argument type(EOS_type), intent(in) :: EOS !< Equation of state structure real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! in combination with scaling given by US [various] + !! in combination with scaling stored in EOS [various] ! Local variables real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] - real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] - integer :: j + real :: dRdT_scale ! A factor to convert drho_dT to the desired units [R degC m3 C-1 kg-1 ~> 1] + real :: dRdS_scale ! A factor to convert drho_dS to the desired units [R ppt m3 S-1 kg-1 ~> 1] + real :: pres(1) ! Pressure converted to [Pa] + real :: Ta(1) ! Temperature converted to [degC] + real :: Sa(1) ! Salinity converted to [ppt] - p_scale = EOS%RL2_T2_to_Pa + pres(1) = EOS%RL2_T2_to_Pa*pressure + Ta(1) = EOS%C_to_degC * T + Sa(1) = EOS%S_to_ppt * S - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_density_derivs_linear(T, S, p_scale*pressure, drho_dT, drho_dS, & - EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS) - case (EOS_WRIGHT) - call calculate_density_derivs_wright(T, S, p_scale*pressure, drho_dT, drho_dS) - case (EOS_TEOS10) - call calculate_density_derivs_teos10(T, S, p_scale*pressure, drho_dT, drho_dS) - case default - call MOM_error(FATAL, "calculate_density_derivs_scalar: EOS%form_of_EOS is not valid.") - end select + call EOS%type%calculate_density_derivs_scalar(Ta(1), Sa(1), pres(1), drho_dT, drho_dS) rho_scale = EOS%kg_m3_to_R if (present(scale)) rho_scale = rho_scale * scale - if (rho_scale /= 1.0) then - drho_dT = rho_scale * drho_dT - drho_dS = rho_scale * drho_dS + dRdT_scale = rho_scale * EOS%C_to_degC + dRdS_scale = rho_scale * EOS%S_to_ppt + if ((dRdT_scale /= 1.0) .or. (dRdS_scale /= 1.0)) then + drho_dT = dRdT_scale * drho_dT + drho_dS = dRdS_scale * drho_dS endif end subroutine calculate_density_derivs_scalar !> Calls the appropriate subroutine to calculate density second derivatives for 1-D array inputs. -subroutine calculate_density_second_derivs_array(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, & - drho_dS_dP, drho_dT_dP, start, npts, EOS, scale) - real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(:), intent(in) :: S !< Salinity [ppt] - real, dimension(:), intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] +subroutine calculate_density_second_derivs_1d(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, & + drho_dS_dP, drho_dT_dP, EOS, dom, scale) + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, dimension(:), intent(in) :: S !< Salinity [S ~> ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] real, dimension(:), intent(inout) :: drho_dS_dS !< Partial derivative of beta with respect to S - !! [kg m-3 ppt-2] or [R ppt-2 ~> kg m-3 ppt-2] + !! [R S-2 ~> kg m-3 ppt-2] real, dimension(:), intent(inout) :: drho_dS_dT !< Partial derivative of beta with respect to T - !! [kg m-3 ppt-1 degC-1] or [R ppt-1 degC-1 ~> kg m-3 ppt-1 degC-1] + !! [R S-1 C-1 ~> kg m-3 ppt-1 degC-1] real, dimension(:), intent(inout) :: drho_dT_dT !< Partial derivative of alpha with respect to T - !! [kg m-3 degC-2] or [R degC-2 ~> kg m-3 degC-2] + !! [R C-2 ~> kg m-3 degC-2] real, dimension(:), intent(inout) :: drho_dS_dP !< Partial derivative of beta with respect to pressure - !! [kg m-3 ppt-1 Pa-1] or [R ppt-1 Pa-1 ~> kg m-3 ppt-1 Pa-1] + !! [T2 S-1 L-2 ~> kg m-3 ppt-1 Pa-1] real, dimension(:), intent(inout) :: drho_dT_dP !< Partial derivative of alpha with respect to pressure - !! [kg m-3 degC-1 Pa-1] or [R degC-1 Pa-1 ~> kg m-3 degC-1 Pa-1] - integer, intent(in) :: start !< Starting index within the array - integer, intent(in) :: npts !< The number of values to calculate - type(EOS_type), intent(in) :: EOS !< Equation of state structure - real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! in combination with scaling given by US [various] + !! [T2 C-1 L-2 ~> kg m-3 degC-1 Pa-1] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density + !! in combination with scaling stored in EOS [various] ! Local variables - real, dimension(size(pressure)) :: pres ! Pressure converted to [Pa] + real, dimension(size(T)) :: pres ! Pressure converted to [Pa] + real, dimension(size(T)) :: Ta ! Temperature converted to [degC] + real, dimension(size(T)) :: Sa ! Salinity converted to [ppt] real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] - real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] - real :: I_p_scale ! The inverse of the factor to convert pressure to units of Pa [R L2 T-2 Pa-1 ~> 1] - integer :: j + integer :: i, is, ie, npts - p_scale = EOS%RL2_T2_to_Pa + if (.not. allocated(EOS%type)) call MOM_error(FATAL, & + "calculate_density_second_derivs: EOS%form_of_EOS is not valid.") - if (p_scale == 1.0) then - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_density_second_derivs_linear(T, S, pressure, drho_dS_dS, drho_dS_dT, & - drho_dT_dT, drho_dS_dP, drho_dT_dP, start, npts) - case (EOS_WRIGHT) - call calculate_density_second_derivs_wright(T, S, pressure, drho_dS_dS, drho_dS_dT, & - drho_dT_dT, drho_dS_dP, drho_dT_dP, start, npts) - case (EOS_TEOS10) - call calculate_density_second_derivs_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, & - drho_dT_dT, drho_dS_dP, drho_dT_dP, start, npts) - case default - call MOM_error(FATAL, "calculate_density_derivs: EOS%form_of_EOS is not valid.") - end select + if (present(dom)) then + is = dom(1) ; ie = dom(2) ; npts = 1 + ie - is else - do j=start,start+npts-1 ; pres(j) = p_scale * pressure(j) ; enddo - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_density_second_derivs_linear(T, S, pres, drho_dS_dS, drho_dS_dT, & - drho_dT_dT, drho_dS_dP, drho_dT_dP, start, npts) - case (EOS_WRIGHT) - call calculate_density_second_derivs_wright(T, S, pres, drho_dS_dS, drho_dS_dT, & - drho_dT_dT, drho_dS_dP, drho_dT_dP, start, npts) - case (EOS_TEOS10) - call calculate_density_second_derivs_teos10(T, S, pres, drho_dS_dS, drho_dS_dT, & - drho_dT_dT, drho_dS_dP, drho_dT_dP, start, npts) - case default - call MOM_error(FATAL, "calculate_density_derivs: EOS%form_of_EOS is not valid.") - end select + is = 1 ; ie = size(T) ; npts = 1 + ie - is + endif + + if ((EOS%RL2_T2_to_Pa == 1.0) .and. (EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then + call EOS%type%calculate_density_second_derivs_array(T, S, pressure, & + drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) + else + do i=is,ie + pres(i) = EOS%RL2_T2_to_Pa * pressure(i) + Ta(i) = EOS%C_to_degC * T(i) + Sa(i) = EOS%S_to_ppt * S(i) + enddo + call EOS%type%calculate_density_second_derivs_array(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) endif rho_scale = EOS%kg_m3_to_R if (present(scale)) rho_scale = rho_scale * scale - if (rho_scale /= 1.0) then ; do j=start,start+npts-1 - drho_dS_dS(j) = rho_scale * drho_dS_dS(j) - drho_dS_dT(j) = rho_scale * drho_dS_dT(j) - drho_dT_dT(j) = rho_scale * drho_dT_dT(j) - drho_dS_dP(j) = rho_scale * drho_dS_dP(j) - drho_dT_dP(j) = rho_scale * drho_dT_dP(j) + if (rho_scale /= 1.0) then ; do i=is,ie + drho_dS_dS(i) = rho_scale * drho_dS_dS(i) + drho_dS_dT(i) = rho_scale * drho_dS_dT(i) + drho_dT_dT(i) = rho_scale * drho_dT_dT(i) + drho_dS_dP(i) = rho_scale * drho_dS_dP(i) + drho_dT_dP(i) = rho_scale * drho_dT_dP(i) enddo ; endif - if (p_scale /= 1.0) then - I_p_scale = 1.0 / p_scale - do j=start,start+npts-1 - drho_dS_dP(j) = I_p_scale * drho_dS_dP(j) - drho_dT_dP(j) = I_p_scale * drho_dT_dP(j) - enddo - endif + if (EOS%RL2_T2_to_Pa /= 1.0) then ; do i=is,ie + drho_dS_dP(i) = EOS%RL2_T2_to_Pa * drho_dS_dP(i) + drho_dT_dP(i) = EOS%RL2_T2_to_Pa * drho_dT_dP(i) + enddo ; endif + + if (EOS%C_to_degC /= 1.0) then ; do i=is,ie + drho_dS_dT(i) = EOS%C_to_degC * drho_dS_dT(i) + drho_dT_dT(i) = EOS%C_to_degC**2 * drho_dT_dT(i) + drho_dT_dP(i) = EOS%C_to_degC * drho_dT_dP(i) + enddo ; endif -end subroutine calculate_density_second_derivs_array + if (EOS%S_to_ppt /= 1.0) then ; do i=is,ie + drho_dS_dS(i) = EOS%S_to_ppt**2 * drho_dS_dS(i) + drho_dS_dT(i) = EOS%S_to_ppt * drho_dS_dT(i) + drho_dS_dP(i) = EOS%S_to_ppt * drho_dS_dP(i) + enddo ; endif + +end subroutine calculate_density_second_derivs_1d -!> Calls the appropriate subroutine to calculate density second derivatives for scalar nputs. +!> Calls the appropriate subroutine to calculate density second derivatives for scalar inputs. subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, & drho_dS_dP, drho_dT_dP, EOS, scale) - real, intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, intent(in) :: S !< Salinity [ppt] - real, intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] + real, intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, intent(in) :: S !< Salinity [S ~> ppt] + real, intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] real, intent(out) :: drho_dS_dS !< Partial derivative of beta with respect to S - !! [kg m-3 ppt-2] or [R ppt-2 ~> kg m-3 ppt-2] + !! [R S-2 ~> kg m-3 ppt-2] real, intent(out) :: drho_dS_dT !< Partial derivative of beta with respect to T - !! [kg m-3 ppt-1 degC-1] or [R ppt-1 degC-1 ~> kg m-3 ppt-1 degC-1] + !! [R S-1 C-1 ~> kg m-3 ppt-1 degC-1] real, intent(out) :: drho_dT_dT !< Partial derivative of alpha with respect to T - !! [kg m-3 degC-2] or [R degC-2 ~> kg m-3 degC-2] + !! [R C-2 ~> kg m-3 degC-2] real, intent(out) :: drho_dS_dP !< Partial derivative of beta with respect to pressure - !! [kg m-3 ppt-1 Pa-1] or [R ppt-1 Pa-1 ~> kg m-3 ppt-1 Pa-1] + !! [T2 S-1 L-2 ~> kg m-3 ppt-1 Pa-1] real, intent(out) :: drho_dT_dP !< Partial derivative of alpha with respect to pressure - !! [kg m-3 degC-1 Pa-1] or [R degC-1 Pa-1 ~> kg m-3 degC-1 Pa-1] + !! [T2 C-1 L-2 ~> kg m-3 degC-1 Pa-1] type(EOS_type), intent(in) :: EOS !< Equation of state structure real, optional, intent(in) :: scale !< A multiplicative factor by which to scale density - !! in combination with scaling given by US [various] + !! in combination with scaling stored in EOS [various] ! Local variables real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] - real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] - real :: I_p_scale ! The inverse of the factor to convert pressure to units of Pa [R L2 T-2 Pa-1 ~> 1] + real :: pres ! Pressure converted to [Pa] + real :: Ta ! Temperature converted to [degC] + real :: Sa ! Salinity converted to [ppt] - p_scale = EOS%RL2_T2_to_Pa + if (.not. allocated(EOS%type)) call MOM_error(FATAL, & + "calculate_density_second_derivs: EOS%form_of_EOS is not valid.") - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_density_second_derivs_linear(T, S, p_scale*pressure, drho_dS_dS, drho_dS_dT, & - drho_dT_dT, drho_dS_dP, drho_dT_dP) - case (EOS_WRIGHT) - call calculate_density_second_derivs_wright(T, S, p_scale*pressure, drho_dS_dS, drho_dS_dT, & - drho_dT_dT, drho_dS_dP, drho_dT_dP) - case (EOS_TEOS10) - call calculate_density_second_derivs_teos10(T, S, p_scale*pressure, drho_dS_dS, drho_dS_dT, & - drho_dT_dT, drho_dS_dP, drho_dT_dP) - case default - call MOM_error(FATAL, "calculate_density_derivs: EOS%form_of_EOS is not valid.") - end select + pres = EOS%RL2_T2_to_Pa*pressure + Ta = EOS%C_to_degC * T + Sa = EOS%S_to_ppt * S + + call EOS%type%calculate_density_second_derivs_scalar(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP) rho_scale = EOS%kg_m3_to_R if (present(scale)) rho_scale = rho_scale * scale @@ -925,10 +996,21 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr drho_dT_dP = rho_scale * drho_dT_dP endif - if (p_scale /= 1.0) then - I_p_scale = 1.0 / p_scale - drho_dS_dP = I_p_scale * drho_dS_dP - drho_dT_dP = I_p_scale * drho_dT_dP + if (EOS%RL2_T2_to_Pa /= 1.0) then + drho_dS_dP = EOS%RL2_T2_to_Pa * drho_dS_dP + drho_dT_dP = EOS%RL2_T2_to_Pa * drho_dT_dP + endif + + if (EOS%C_to_degC /= 1.0) then + drho_dS_dT = EOS%C_to_degC * drho_dS_dT + drho_dT_dT = EOS%C_to_degC**2 * drho_dT_dT + drho_dT_dP = EOS%C_to_degC * drho_dT_dP + endif + + if (EOS%S_to_ppt /= 1.0) then + drho_dS_dS = EOS%S_to_ppt**2 * drho_dS_dS + drho_dS_dT = EOS%S_to_ppt * drho_dS_dT + drho_dS_dP = EOS%S_to_ppt * drho_dS_dP endif end subroutine calculate_density_second_derivs_scalar @@ -946,61 +1028,36 @@ subroutine calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start integer, intent(in) :: npts !< The number of values to calculate type(EOS_type), intent(in) :: EOS !< Equation of state structure - ! Local variables - real, dimension(size(T)) :: press ! Pressure converted to [Pa] - real, dimension(size(T)) :: rho ! In situ density [kg m-3] - real, dimension(size(T)) :: dRho_dT ! Derivative of density with temperature [kg m-3 degC-1] - real, dimension(size(T)) :: dRho_dS ! Derivative of density with salinity [kg m-3 ppt-1] - integer :: j + if (.not. allocated(EOS%type)) call MOM_error(FATAL, & + "calculate_spec_vol_derivs_array: EOS%form_of_EOS is not valid.") - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_specvol_derivs_linear(T, S, pressure, dSV_dT, dSV_dS, start, & - npts, EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS) - case (EOS_UNESCO) - call calculate_density_unesco(T, S, pressure, rho, start, npts) - call calculate_density_derivs_unesco(T, S, pressure, drho_dT, drho_dS, start, npts) - do j=start,start+npts-1 - dSV_dT(j) = -dRho_DT(j)/(rho(j)**2) - dSV_dS(j) = -dRho_DS(j)/(rho(j)**2) - enddo - case (EOS_WRIGHT) - call calculate_specvol_derivs_wright(T, S, pressure, dSV_dT, dSV_dS, start, npts) - case (EOS_TEOS10) - call calculate_specvol_derivs_teos10(T, S, pressure, dSV_dT, dSV_dS, start, npts) - case (EOS_NEMO) - call calculate_density_nemo(T, S, pressure, rho, start, npts) - call calculate_density_derivs_nemo(T, S, pressure, drho_dT, drho_dS, start, npts) - do j=start,start+npts-1 - dSV_dT(j) = -dRho_DT(j)/(rho(j)**2) - dSV_dS(j) = -dRho_DS(j)/(rho(j)**2) - enddo - case default - call MOM_error(FATAL, "calculate_spec_vol_derivs_array: EOS%form_of_EOS is not valid.") - end select + call EOS%type%calculate_specvol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start, npts) end subroutine calculate_spec_vol_derivs_array !> Calls the appropriate subroutine to calculate specific volume derivatives for 1-d array inputs, !! potentially limiting the domain of indices that are worked on. subroutine calc_spec_vol_derivs_1d(T, S, pressure, dSV_dT, dSV_dS, EOS, dom, scale) - real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, dimension(:), intent(in) :: S !< Salinity [S ~> ppt] real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] real, dimension(:), intent(inout) :: dSV_dT !< The partial derivative of specific volume with potential - !! temperature [R-1 degC-1 ~> m3 kg-1 degC-1] + !! temperature [R-1 C-1 ~> m3 kg-1 degC-1] real, dimension(:), intent(inout) :: dSV_dS !< The partial derivative of specific volume with salinity - !! [R-1 ppt-1 ~> m3 kg-1 ppt-1] + !! [R-1 S-1 ~> m3 kg-1 ppt-1] type(EOS_type), intent(in) :: EOS !< Equation of state structure integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking !! into account that arrays start at 1. real, optional, intent(in) :: scale !< A multiplicative factor by which to scale specific - !! volume in combination with scaling given by US [various] + !! volume in combination with scaling stored in EOS [various] ! Local variables - real, dimension(size(dSV_dT)) :: press ! Pressure converted to [Pa] + real, dimension(size(T)) :: pres ! Pressure converted to [Pa] + real, dimension(size(T)) :: Ta ! Temperature converted to [degC] + real, dimension(size(T)) :: Sa ! Salinity converted to [ppt] real :: spv_scale ! A factor to convert specific volume from m3 kg-1 to the desired units [kg R-1 m-3 ~> 1] - real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] + real :: dSVdT_scale ! A factor to convert dSV_dT to the desired units [kg degC R-1 C-1 m-3 ~> 1] + real :: dSVdS_scale ! A factor to convert dSV_dS to the desired units [kg ppt R-1 S-1 m-3 ~> 1] integer :: i, is, ie, npts if (present(dom)) then @@ -1008,61 +1065,66 @@ subroutine calc_spec_vol_derivs_1d(T, S, pressure, dSV_dT, dSV_dS, EOS, dom, sca else is = 1 ; ie = size(dSV_dT) ; npts = 1 + ie - is endif - p_scale = EOS%RL2_T2_to_Pa - if (p_scale == 1.0) then + if ((EOS%RL2_T2_to_Pa == 1.0) .and. (EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then call calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, is, npts, EOS) else - do i=is,ie ; press(i) = p_scale * pressure(i) ; enddo - call calculate_spec_vol_derivs_array(T, S, press, dSV_dT, dSV_dS, is, npts, EOS) + do i=is,ie + pres(i) = EOS%RL2_T2_to_Pa * pressure(i) + Ta(i) = EOS%C_to_degC * T(i) + Sa(i) = EOS%S_to_ppt * S(i) + enddo + call calculate_spec_vol_derivs_array(Ta, Sa, pres, dSV_dT, dSV_dS, is, npts, EOS) endif spv_scale = EOS%R_to_kg_m3 if (present(scale)) spv_scale = spv_scale * scale - if (spv_scale /= 1.0) then ; do i=is,ie - dSV_dT(i) = spv_scale * dSV_dT(i) - dSV_dS(i) = spv_scale * dSV_dS(i) + dSVdT_scale = spv_scale * EOS%C_to_degC + dSVdS_scale = spv_scale * EOS%S_to_ppt + if ((dSVdT_scale /= 1.0) .or. (dSVdS_scale /= 1.0)) then ; do i=is,ie + dSV_dT(i) = dSVdT_scale * dSV_dT(i) + dSV_dS(i) = dSVdS_scale * dSV_dS(i) enddo ; endif end subroutine calc_spec_vol_derivs_1d !> Calls the appropriate subroutine to calculate the density and compressibility for 1-D array -!! inputs. If US is present, the units of the inputs and outputs are rescaled. -subroutine calculate_compress_array(T, S, press, rho, drho_dp, start, npts, EOS) - real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, dimension(:), intent(in) :: S !< Salinity [PSU] - real, dimension(:), intent(in) :: press !< Pressure [Pa] or [R L2 T-2 ~> Pa] - real, dimension(:), intent(inout) :: rho !< In situ density [kg m-3] or [R ~> kg m-3] +!! inputs. The inputs and outputs use dimensionally rescaled units. +subroutine calculate_compress_1d(T, S, pressure, rho, drho_dp, EOS, dom) + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, dimension(:), intent(in) :: S !< Salinity [S ~> ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, dimension(:), intent(inout) :: rho !< In situ density [R ~> kg m-3] real, dimension(:), intent(inout) :: drho_dp !< The partial derivative of density with pressure !! (also the inverse of the square of sound speed) - !! [s2 m-2] or [T2 L-2] - integer, intent(in) :: start !< Starting index within the array - integer, intent(in) :: npts !< The number of values to calculate + !! [T2 L-2 ~> s2 m-2] type(EOS_type), intent(in) :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. ! Local variables - real, dimension(size(press)) :: pressure ! Pressure converted to [Pa] - integer :: i, is, ie + real, dimension(size(T)) :: pres ! Pressure converted to [Pa] + real, dimension(size(T)) :: Ta ! Temperature converted to [degC] + real, dimension(size(T)) :: Sa ! Salinity converted to [ppt] + integer :: i, is, ie, npts - is = start ; ie = is + npts - 1 - do i=is,ie ; pressure(i) = EOS%RL2_T2_to_Pa * press(i) ; enddo + if (.not. allocated(EOS%type)) call MOM_error(FATAL, & + "calculate_compress_1d: EOS%form_of_EOS is not valid.") - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_compress_linear(T, S, pressure, rho, drho_dp, start, npts, & - EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS) - case (EOS_UNESCO) - call calculate_compress_unesco(T, S, pressure, rho, drho_dp, start, npts) - case (EOS_WRIGHT) - call calculate_compress_wright(T, S, pressure, rho, drho_dp, start, npts) - case (EOS_TEOS10) - call calculate_compress_teos10(T, S, pressure, rho, drho_dp, start, npts) - case (EOS_NEMO) - call calculate_compress_nemo(T, S, pressure, rho, drho_dp, start, npts) - case default - call MOM_error(FATAL, "calculate_compress: EOS%form_of_EOS is not valid.") - end select + if (present(dom)) then + is = dom(1) ; ie = dom(2) ; npts = 1 + ie - is + else + is = 1 ; ie = size(rho) ; npts = 1 + ie - is + endif + + do i=is,ie + pres(i) = EOS%RL2_T2_to_Pa * pressure(i) + Ta(i) = EOS%C_to_degC * T(i) + Sa(i) = EOS%S_to_ppt * S(i) + enddo + + call EOS%type%calculate_compress_array(Ta, Sa, pres, rho, drho_dp, is, npts) if (EOS%kg_m3_to_R /= 1.0) then ; do i=is,ie rho(i) = EOS%kg_m3_to_R * rho(i) @@ -1071,30 +1133,146 @@ subroutine calculate_compress_array(T, S, press, rho, drho_dp, start, npts, EOS) drho_dp(i) = EOS%L_T_to_m_s**2 * drho_dp(i) enddo ; endif -end subroutine calculate_compress_array +end subroutine calculate_compress_1d !> Calculate density and compressibility for a scalar. This just promotes the scalar to an array -!! with a singleton dimension and calls calculate_compress_array. If US is present, the units of -!! the inputs and outputs are rescaled. +!! with a singleton dimension and calls calculate_compress_1d. The inputs and outputs use +!! dimensionally rescaled units. subroutine calculate_compress_scalar(T, S, pressure, rho, drho_dp, EOS) - real, intent(in) :: T !< Potential temperature referenced to the surface [degC] - real, intent(in) :: S !< Salinity [ppt] - real, intent(in) :: pressure !< Pressure [Pa] or [R L2 T-2 ~> Pa] - real, intent(out) :: rho !< In situ density [kg m-3] or [R ~> kg m-3] + real, intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, intent(in) :: S !< Salinity [S ~> ppt] + real, intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, intent(out) :: rho !< In situ density [R ~> kg m-3] real, intent(out) :: drho_dp !< The partial derivative of density with pressure (also the - !! inverse of the square of sound speed) [s2 m-2] or [T2 L-2] + !! inverse of the square of sound speed) [T2 L-2 ~> s2 m-2] type(EOS_type), intent(in) :: EOS !< Equation of state structure ! Local variables - real, dimension(1) :: Ta, Sa, pa, rhoa, drho_dpa + ! These arrays use the same units as their counterparts in calculate_compress_1d. + real, dimension(1) :: pa ! Pressure in a size-1 1d array [R L2 T-2 ~> Pa] + real, dimension(1) :: Ta ! Temperature in a size-1 1d array [C ~> degC] + real, dimension(1) :: Sa ! Salinity in a size-1 1d array [S ~> ppt] + real, dimension(1) :: rhoa ! In situ density in a size-1 1d array [R ~> kg m-3] + real, dimension(1) :: drho_dpa ! The partial derivative of density with pressure (also the + ! inverse of the square of sound speed) in a 1d array [T2 L-2 ~> s2 m-2] - Ta(1) = T ; Sa(1) = S; pa(1) = pressure + Ta(1) = T ; Sa(1) = S ; pa(1) = pressure - call calculate_compress_array(Ta, Sa, pa, rhoa, drho_dpa, 1, 1, EOS) + call calculate_compress_1d(Ta, Sa, pa, rhoa, drho_dpa, EOS) rho = rhoa(1) ; drho_dp = drho_dpa(1) end subroutine calculate_compress_scalar +!> Calls the appropriate subroutine to calculate the layer averaged specific volume either using +!! Boole's rule quadrature or analytical and nearly-analytical averages in pressure. +subroutine average_specific_vol(T, S, p_t, dp, SpV_avg, EOS, dom, scale) + real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, dimension(:), intent(in) :: S !< Salinity [S ~> ppt] + real, dimension(:), intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] + real, dimension(:), intent(in) :: dp !< Pressure change in the layer [R L2 T-2 ~> Pa] + real, dimension(:), intent(inout) :: SpV_avg !< The vertical average specific volume + !! in the layer [R-1 ~> m3 kg-1] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale + !! output specific volume in combination with + !! scaling stored in EOS [various] + + ! Local variables + real, dimension(size(T)) :: pres ! Layer-top pressure converted to [Pa] + real, dimension(size(T)) :: dpres ! Pressure change converted to [Pa] + real, dimension(size(T)) :: Ta ! Temperature converted to [degC] + real, dimension(size(T)) :: Sa ! Salinity converted to [ppt] + real :: T5(5) ! Temperatures at five quadrature points [C ~> degC] + real :: S5(5) ! Salinities at five quadrature points [S ~> ppt] + real :: p5(5) ! Pressures at five quadrature points [R L2 T-2 ~> Pa] + real :: a5(5) ! Specific volumes at five quadrature points [R-1 ~> m3 kg-1] + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] + real :: spv_scale ! A factor to convert specific volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] + integer :: i, n, is, ie, npts + + if (present(dom)) then + is = dom(1) ; ie = dom(2) ; npts = 1 + ie - is + else + is = 1 ; ie = size(T) ; npts = 1 + ie - is + endif + + if (EOS%EOS_quadrature) then + do i=is,ie + do n=1,5 + T5(n) = T(i) ; S5(n) = S(i) + p5(n) = p_t(i) + 0.25*real(5-n)*dp(i) + enddo + call calculate_spec_vol(T5, S5, p5, a5, EOS) + + ! Use Boole's rule to estimate the average specific volume. + SpV_avg(i) = C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + 12.0*a5(3)) + enddo + elseif ((EOS%RL2_T2_to_Pa == 1.0) .and. (EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call avg_spec_vol_linear(T, S, p_t, dp, SpV_avg, is, npts, EOS%Rho_T0_S0, & + EOS%dRho_dT, EOS%dRho_dS, EOS%dRho_dp) + case (EOS_WRIGHT) + call avg_spec_vol_buggy_wright(T, S, p_t, dp, SpV_avg, is, npts) + case (EOS_WRIGHT_FULL) + call avg_spec_vol_wright_full(T, S, p_t, dp, SpV_avg, is, npts) + case (EOS_WRIGHT_REDUCED) + call avg_spec_vol_wright_red(T, S, p_t, dp, SpV_avg, is, npts) + case default + call MOM_error(FATAL, "No analytic average specific volume option is available with this EOS!") + end select + else + do i=is,ie + pres(i) = EOS%RL2_T2_to_Pa * p_t(i) + dpres(i) = EOS%RL2_T2_to_Pa * dp(i) + Ta(i) = EOS%C_to_degC * T(i) + Sa(i) = EOS%S_to_ppt * S(i) + enddo + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call avg_spec_vol_linear(Ta, Sa, pres, dpres, SpV_avg, is, npts, EOS%Rho_T0_S0, & + EOS%dRho_dT, EOS%dRho_dS, EOS%dRho_dp) + case (EOS_WRIGHT) + call avg_spec_vol_buggy_wright(Ta, Sa, pres, dpres, SpV_avg, is, npts) + case (EOS_WRIGHT_FULL) + call avg_spec_vol_wright_full(Ta, Sa, pres, dpres, SpV_avg, is, npts) + case (EOS_WRIGHT_REDUCED) + call avg_spec_vol_wright_red(Ta, Sa, pres, dpres, SpV_avg, is, npts) + case default + call MOM_error(FATAL, "No analytic average specific volume option is available with this EOS!") + end select + endif + + spv_scale = EOS%R_to_kg_m3 + if (EOS%EOS_quadrature) spv_scale = 1.0 + if (present(scale)) spv_scale = spv_scale * scale + if (spv_scale /= 1.0) then ; do i=is,ie + SpV_avg(i) = spv_scale * SpV_avg(i) + enddo ; endif + +end subroutine average_specific_vol + +!> Return the range of temperatures, salinities and pressures for which the equation of state that +!! is being used has been fitted to observations. Care should be taken when applying +!! this equation of state outside of its fit range. +subroutine EoS_fit_range(EOS, T_min, T_max, S_min, S_max, p_min, p_max) + type(EOS_type), intent(in) :: EOS !< Equation of state structure + real, optional, intent(out) :: T_min !< The minimum temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum salinity over which this EoS is fitted [ppt] + real, optional, intent(out) :: S_max !< The maximum salinity over which this EoS is fitted [ppt] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + if (.not. allocated(EOS%type)) call MOM_error(FATAL, & + "calculate_compress: EOS%form_of_EOS is not valid.") + + call EOS%type%EoS_fit_range(T_min, T_max, S_min, S_max, p_min, p_max) + +end subroutine EoS_fit_range + !> This subroutine returns a two point integer array indicating the domain of i-indices !! to work on in EOS calls based on information from a hor_index type @@ -1114,7 +1292,6 @@ function EOS_domain(HI, halo) result(EOSdom) end function EOS_domain - !> Calls the appropriate subroutine to calculate analytical and nearly-analytical !! integrals in pressure across layers of geopotential anomalies, which are !! required for calculating the finite-volume form pressure accelerations in a @@ -1123,16 +1300,16 @@ end function EOS_domain !! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. subroutine analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) + bathyP, P_surf, dP_tiny, MassWghtInterp) type(hor_index_type), intent(in) :: HI !< The horizontal index structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T !< Potential temperature referenced to the surface [degC] + intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S !< Salinity [ppt] + intent(in) :: S !< Salinity [S ~> ppt] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] or [Pa] + intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_b !< Pressure at the bottom of the layer [R L2 T-2 ~> Pa] or [Pa] + intent(in) :: p_b !< Pressure at the bottom of the layer [R L2 T-2 ~> Pa] real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1] !! The calculation is mathematically identical with different values of @@ -1140,30 +1317,33 @@ subroutine analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & type(EOS_type), intent(in) :: EOS !< Equation of state structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(inout) :: dza !< The change in the geopotential anomaly across - !! the layer [L2 T-2 ~> m2 s-2] or [m2 s-2] + !! the layer [L2 T-2 ~> m2 s-2] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of the !! geopotential anomaly relative to the anomaly at the bottom of the - !! layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2] + !! layer [R L4 T-4 ~> Pa m2 s-2] real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & optional, intent(inout) :: intx_dza !< The integral in x of the difference between the !! geopotential anomaly at the top and bottom of the layer divided by - !! the x grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] + !! the x grid spacing [L2 T-2 ~> m2 s-2] real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & optional, intent(inout) :: inty_dza !< The integral in y of the difference between the !! geopotential anomaly at the top and bottom of the layer divided by - !! the y grid spacing [L2 T-2 ~> m2 s-2] or [m2 s-2] + !! the y grid spacing [L2 T-2 ~> m2 s-2] integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] real, optional, intent(in) :: dP_tiny !< A miniscule pressure change with - !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. + !! the same units as p_t [R L2 T-2 ~> Pa] + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals + ! Local variables - real :: pres_scale ! A unit conversion factor from the rescaled units of pressure to Pa [Pa T2 R-1 L-2 ~> 1] - real :: SV_scale ! A multiplicative factor by which to scale specific - ! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] + real :: dRdT_scale ! A factor to convert drho_dT to the desired units [R degC m3 C-1 kg-1 ~> 1] + real :: dRdS_scale ! A factor to convert drho_dS to the desired units [R ppt m3 S-1 kg-1 ~> 1] + real :: dRdp_scale ! A factor to convert drho_dp to the desired units [T-2 L2 s2 m-2 ~> 1] ! We should never reach this point with quadrature. EOS_quadrature indicates that numerical ! integration be used instead of analytic. This is a safety check. @@ -1171,14 +1351,28 @@ subroutine analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & select case (EOS%form_of_EOS) case (EOS_LINEAR) + dRdT_scale = EOS%kg_m3_to_R * EOS%C_to_degC + dRdS_scale = EOS%kg_m3_to_R * EOS%S_to_ppt + dRdp_scale = EOS%kg_m3_to_R * EOS%RL2_T2_to_Pa call int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, EOS%kg_m3_to_R*EOS%Rho_T0_S0, & - EOS%kg_m3_to_R*EOS%dRho_dT, EOS%kg_m3_to_R*EOS%dRho_dS, dza, & - intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_tiny, useMassWghtInterp) + dRdT_scale*EOS%dRho_dT, dRdS_scale*EOS%dRho_dS, dRdp_scale*EOS%dRho_dp, & + dza, intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, P_surf, dP_tiny, MassWghtInterp) case (EOS_WRIGHT) call int_spec_vol_dp_wright(T, S, p_t, p_b, alpha_ref, HI, dza, intp_dza, intx_dza, & - inty_dza, halo_size, bathyP, dP_tiny, useMassWghtInterp, & - SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa) + inty_dza, halo_size, bathyP, P_surf, dP_tiny, MassWghtInterp, & + SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa, & + temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt) + case (EOS_WRIGHT_FULL) + call int_spec_vol_dp_wright_full(T, S, p_t, p_b, alpha_ref, HI, dza, intp_dza, intx_dza, & + inty_dza, halo_size, bathyP, P_surf, dP_tiny, MassWghtInterp, & + SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa, & + temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt) + case (EOS_WRIGHT_REDUCED) + call int_spec_vol_dp_wright_red(T, S, p_t, p_b, alpha_ref, HI, dza, intp_dza, intx_dza, & + inty_dza, halo_size, bathyP, P_surf, dP_tiny, MassWghtInterp, & + SV_scale=EOS%R_to_kg_m3, pres_scale=EOS%RL2_T2_to_Pa, & + temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt) case default call MOM_error(FATAL, "No analytic integration option is available with this EOS!") end select @@ -1189,28 +1383,28 @@ end subroutine analytic_int_specific_vol_dp !! pressure anomalies across layers, which are required for calculating the !! finite-volume form pressure accelerations in a Boussinesq model. subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, & - intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp, Z_0p) + intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, MassWghtInterp, Z_0p) type(hor_index_type), intent(in) :: HI !< Ocean horizontal index structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T !< Potential temperature referenced to the surface [degC] + intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S !< Salinity [ppt] + intent(in) :: S !< Salinity [S ~> ppt] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: z_b !< Height at the bottom of the layer [Z ~> m] - real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that is !! subtracted out to reduce the magnitude of each of the !! integrals. - real, intent(in) :: rho_0 !< A density [R ~> kg m-3] or [kg m-3], that is used + real, intent(in) :: rho_0 !< A density [R ~> kg m-3], that is used !! to calculate the pressure (as p~=-z*rho_0*G_e) !! used in the equation of state. real, intent(in) :: G_e !< The Earth's gravitational acceleration - !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2] + !! [L2 Z-1 T-2 ~> m s-2] type(EOS_type), intent(in) :: EOS !< Equation of state structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(inout) :: dpa !< The change in the pressure anomaly - !! across the layer [R L2 T-2 ~> Pa] or [Pa] + !! across the layer [R L2 T-2 ~> Pa] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(inout) :: intz_dpa !< The integral through the thickness of the !! layer of the pressure anomaly relative to the @@ -1225,14 +1419,20 @@ subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: SSH !< The sea surface height [Z ~> m] real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! Local variables real :: rho_scale ! A multiplicative factor by which to scale density from kg m-3 to the ! desired units [R m3 kg-1 ~> 1] + real :: dRdT_scale ! A factor to convert drho_dT to the desired units [R degC m3 C-1 kg-1 ~> 1] + real :: dRdS_scale ! A factor to convert drho_dS to the desired units [R ppt m3 S-1 kg-1 ~> 1] + real :: dRdp_scale ! A factor to convert drho_dp to the desired units [T-2 L2 s2 m-2 ~> 1] real :: pres_scale ! A multiplicative factor to convert pressure into Pa [Pa T2 R-1 L-2 ~> 1] ! We should never reach this point with quadrature. EOS_quadrature indicates that numerical @@ -1242,26 +1442,56 @@ subroutine analytic_int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, EOS, select case (EOS%form_of_EOS) case (EOS_LINEAR) rho_scale = EOS%kg_m3_to_R - if (rho_scale /= 1.0) then - call int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - rho_scale*EOS%Rho_T0_S0, rho_scale*EOS%dRho_dT, rho_scale*EOS%dRho_dS, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) + dRdT_scale = EOS%kg_m3_to_R * EOS%C_to_degC + dRdS_scale = EOS%kg_m3_to_R * EOS%S_to_ppt + dRdp_scale = EOS%kg_m3_to_R * EOS%RL2_T2_to_Pa + if ((rho_scale /= 1.0) .or. (dRdT_scale /= 1.0) .or. (dRdS_scale /= 1.0) .or. (dRdp_scale /= 1.0)) then + call int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, rho_scale*EOS%Rho_T0_S0, & + dRdT_scale*EOS%dRho_dT, dRdS_scale*EOS%dRho_dS, dRdp_scale*EOS%dRho_dp, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, MassWghtInterp, Z_0p=Z_0p) else call int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, dz_neglect, useMassWghtInterp) + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, EOS%dRho_dp, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, MassWghtInterp, Z_0p=Z_0p) endif case (EOS_WRIGHT) rho_scale = EOS%kg_m3_to_R pres_scale = EOS%RL2_T2_to_Pa - if ((rho_scale /= 1.0) .or. (pres_scale /= 1.0)) then + if ((rho_scale /= 1.0) .or. (pres_scale /= 1.0) .or. (EOS%C_to_degC /= 1.0) .or. (EOS%S_to_ppt /= 1.0)) then call int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & - dz_neglect, useMassWghtInterp, rho_scale, pres_scale, Z_0p=Z_0p) + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, & + dz_neglect, MassWghtInterp, rho_scale, pres_scale, & + temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt, Z_0p=Z_0p) else call int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, & - dz_neglect, useMassWghtInterp, Z_0p=Z_0p) + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, & + dz_neglect, MassWghtInterp, Z_0p=Z_0p) + endif + case (EOS_WRIGHT_FULL) + rho_scale = EOS%kg_m3_to_R + pres_scale = EOS%RL2_T2_to_Pa + if ((rho_scale /= 1.0) .or. (pres_scale /= 1.0) .or. (EOS%C_to_degC /= 1.0) .or. (EOS%S_to_ppt /= 1.0)) then + call int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, & + dz_neglect, MassWghtInterp, rho_scale, pres_scale, & + temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt, Z_0p=Z_0p) + else + call int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, & + dz_neglect, MassWghtInterp, Z_0p=Z_0p) + endif + case (EOS_WRIGHT_REDUCED) + rho_scale = EOS%kg_m3_to_R + pres_scale = EOS%RL2_T2_to_Pa + if ((rho_scale /= 1.0) .or. (pres_scale /= 1.0) .or. (EOS%C_to_degC /= 1.0) .or. (EOS%S_to_ppt /= 1.0)) then + call int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, & + dz_neglect, MassWghtInterp, rho_scale, pres_scale, & + temp_scale=EOS%C_to_degC, saln_scale=EOS%S_to_ppt, Z_0p=Z_0p) + else + call int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, & + dz_neglect, MassWghtInterp, Z_0p=Z_0p) endif case default call MOM_error(FATAL, "No analytic integration option is available with this EOS!") @@ -1276,73 +1506,172 @@ logical function query_compressible(EOS) query_compressible = EOS%compressible end function query_compressible -!> Initializes EOS_type by allocating and reading parameters -subroutine EOS_init(param_file, EOS, US) +!> Returns the string identifying the equation of state with enumeration "id" +function get_EOS_name(id) result (eos_name) + integer, optional, intent(in) :: id !< Enumerated ID + character(:), allocatable :: eos_name !< The name of the EOS + + select case (id) + case (EOS_LINEAR) + eos_name = EOS_LINEAR_STRING + case (EOS_UNESCO) + eos_name = EOS_UNESCO_STRING + case (EOS_WRIGHT) + eos_name = EOS_WRIGHT_STRING + case (EOS_WRIGHT_REDUCED) + eos_name = EOS_WRIGHT_RED_STRING + case (EOS_WRIGHT_FULL) + eos_name = EOS_WRIGHT_FULL_STRING + case (EOS_TEOS10) + eos_name = EOS_TEOS10_STRING + case (EOS_ROQUET_RHO) + eos_name = EOS_ROQUET_RHO_STRING + case (EOS_ROQUET_SPV) + eos_name = EOS_ROQUET_SPV_STRING + case (EOS_JACKETT06) + eos_name = EOS_JACKETT06_STRING + case default + call MOM_error(FATAL, "get_EOS_name: something went wrong internally - enumeration is not valid.") + end select + +end function get_EOS_name + +!> Initializes EOS_type by allocating and reading parameters. The scaling factors in +!! US are stored in EOS for later use. +subroutine EOS_init(param_file, EOS, US, use_conT_absS) type(param_file_type), intent(in) :: param_file !< Parameter file structure type(EOS_type), intent(inout) :: EOS !< Equation of state structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + logical, intent(in), optional :: use_conT_absS !< True if the model is formulated for + !! conservative temp and absolute salinity optional :: US ! Local variables -#include "version_variable.h" +# include "version_variable.h" character(len=40) :: mdl = "MOM_EOS" ! This module's name. + character(len=12) :: TFREEZE_DEFAULT ! The default freezing point expression character(len=40) :: tmpstr + logical :: EOS_quad_default, EOS_TS_default + real :: Rho_Tref_Sref ! Density at Tref degC and Sref ppt [kg m-3] + real :: Tref ! Reference temperature [degC] + real :: Sref ! Reference salinity [psu] + real :: pref ! Reference pressure [Pa] + real :: rho0 ! Density at T=0, S=0 and p=0 [kg m-3] ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "EQN_OF_STATE", tmpstr, & - "EQN_OF_STATE determines which ocean equation of state "//& - "should be used. Currently, the valid choices are "//& - '"LINEAR", "UNESCO", "WRIGHT", "NEMO" and "TEOS10". '//& - "This is only used if USE_EOS is true.", default=EOS_DEFAULT) + "EQN_OF_STATE determines which ocean equation of state should be used. "//& + 'Currently, the valid choices are "LINEAR", "UNESCO", "JACKETT_MCD", '//& + '"WRIGHT", "WRIGHT_REDUCED", "WRIGHT_FULL", "NEMO", "ROQUET_RHO", "ROQUET_SPV" '//& + 'and "TEOS10". This is only used if USE_EOS is true.', default=EOS_DEFAULT) select case (uppercase(tmpstr)) case (EOS_LINEAR_STRING) - EOS%form_of_EOS = EOS_LINEAR + call EOS_manual_init(EOS, form_of_EOS=EOS_LINEAR) case (EOS_UNESCO_STRING) - EOS%form_of_EOS = EOS_UNESCO + call EOS_manual_init(EOS, form_of_EOS=EOS_UNESCO) + case (EOS_JACKETT_STRING) + call EOS_manual_init(EOS, form_of_EOS=EOS_UNESCO) case (EOS_WRIGHT_STRING) - EOS%form_of_EOS = EOS_WRIGHT + call EOS_manual_init(EOS, form_of_EOS=EOS_WRIGHT) + case (EOS_WRIGHT_RED_STRING) + call EOS_manual_init(EOS, form_of_EOS=EOS_WRIGHT_REDUCED) + case (EOS_WRIGHT_FULL_STRING) + call EOS_manual_init(EOS, form_of_EOS=EOS_WRIGHT_FULL) case (EOS_TEOS10_STRING) - EOS%form_of_EOS = EOS_TEOS10 + call EOS_manual_init(EOS, form_of_EOS=EOS_TEOS10) case (EOS_NEMO_STRING) - EOS%form_of_EOS = EOS_NEMO + call EOS_manual_init(EOS, form_of_EOS=EOS_ROQUET_RHO) + case (EOS_ROQUET_RHO_STRING) + call EOS_manual_init(EOS, form_of_EOS=EOS_ROQUET_RHO) + case (EOS_ROQUET_SPV_STRING) + call EOS_manual_init(EOS, form_of_EOS=EOS_ROQUET_SPV) + case (EOS_JACKETT06_STRING) + call EOS_manual_init(EOS, form_of_EOS=EOS_JACKETT06) case default call MOM_error(FATAL, "interpret_eos_selection: EQN_OF_STATE "//& - trim(tmpstr) // "in input file is invalid.") + trim(tmpstr) // " in input file is invalid.") end select call MOM_mesg('interpret_eos_selection: equation of state set to "' // & trim(tmpstr)//'"', 5) if (EOS%form_of_EOS == EOS_LINEAR) then - EOS%Compressible = .false. - call get_param(param_file, mdl, "RHO_T0_S0", EOS%Rho_T0_S0, & - "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", "//& - "this is the density at T=0, S=0.", units="kg m-3", & - default=1000.0) + ! RHO(T,S) = RHO_REF + DRHO_DT*(T-T_REF) + DRHO_DS*(S-S_REF) + DRHO_DP*(P-P_REF) + ! = RHO_REF - (DRHO_DT*T_REF + DRHO_DS*SREF + DRHO_DP*PREF) + (DRHO_DT*T + DRHO_DS*S + DRHO_DP*P) + ! = RHO_T0_S0 + (DRHO_DT*T + DRHO_DS*S + DRHO_DP*P) + call get_param(param_file, mdl, "RHO_REF_LINEAR_EOS", Rho_Tref_Sref, & + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", this is the density "//& + "at T=T_REF_LINEAR_EOS, S=S_REF_LINEAR_EOS and p=P_REF_LINEAR_EOS", & + units="kg m-3", default=1000.0, old_name="RHO_TREF_SREF") + call get_param(param_file, mdl, "T_REF_LINEAR_EOS", Tref, & + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", this is the reference "//& + "temperature.", units="degC", default=0.0, old_name="TREF") + call get_param(param_file, mdl, "S_REF_LINEAR_EOS", Sref, & + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", this is the reference "//& + "salinity.", units="psu", default=0.0, old_name="SREF") + call get_param(param_file, mdl, "P_REF_LINEAR_EOS", pref, & + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", this is the reference "//& + "pressure.", units="Pa", default=0.0) call get_param(param_file, mdl, "DRHO_DT", EOS%dRho_dT, & - "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", "//& - "this is the partial derivative of density with "//& - "temperature.", units="kg m-3 K-1", default=-0.2) + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", this is "//& + "the partial derivative of density with temperature.", & + units="kg m-3 K-1", default=-0.2) call get_param(param_file, mdl, "DRHO_DS", EOS%dRho_dS, & - "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", "//& - "this is the partial derivative of density with "//& - "salinity.", units="kg m-3 PSU-1", default=0.8) + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", this is "//& + "the partial derivative of density with salinity.", & + units="kg m-3 ppt-1", default=0.8) + call get_param(param_file, mdl, "DRHO_DP", EOS%dRho_dp, & + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", this is "//& + "the partial derivative of density with pressure (the inverse of "//& + "sound speed squared).", units="s2 m-2", default=0.0) + rho0 = Rho_Tref_Sref - ((EOS%dRho_dT * Tref + EOS%dRho_dS * Sref) + EOS%dRho_dp * pref) + call get_param(param_file, mdl, "RHO_T0_S0", EOS%Rho_T0_S0, & + "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", this is the density "//& + "at T=0, S=0 and p=0. If RHO_TO_SO is specified, RHO_REF_LINEAR_EOS, "//& + "T_REF_LINEAR_EOS, S_REF_LINEAR_EOS and P_REF_LINEAR_EOS are not used.", & + units="kg m-3", default=rho0) + EOS%Compressible = (EOS%dRho_dp/=0.0) + call EOS_manual_init(EOS, form_of_EOS=EOS_LINEAR, Rho_T0_S0=EOS%Rho_T0_S0, & + dRho_dT=EOS%dRho_dT, dRho_dS=EOS%dRho_dS, dRho_dp=EOS%dRho_dp) + endif + if (EOS%form_of_EOS == EOS_WRIGHT) then + call get_param(param_file, mdl, "USE_WRIGHT_2ND_DERIV_BUG", EOS%use_Wright_2nd_deriv_bug, & + "If true, use a bug in the calculation of the second derivatives of density "//& + "with temperature and with temperature and pressure that causes some terms "//& + "to be only 2/3 of what they should be.", default=.false.) + call EOS_manual_init(EOS, form_of_EOS=EOS_WRIGHT, use_Wright_2nd_deriv_bug=EOS%use_Wright_2nd_deriv_bug) + endif + + if (present(use_conT_absS)) then + EOS%use_conT_absS = use_conT_absS + else + EOS%use_conT_absS = .false. ! Assuming it is not needed, it is set to false endif + EOS_quad_default = .not.((EOS%form_of_EOS == EOS_LINEAR) .or. & + (EOS%form_of_EOS == EOS_WRIGHT) .or. & + (EOS%form_of_EOS == EOS_WRIGHT_REDUCED) .or. & + (EOS%form_of_EOS == EOS_WRIGHT_FULL)) call get_param(param_file, mdl, "EOS_QUADRATURE", EOS%EOS_quadrature, & "If true, always use the generic (quadrature) code "//& - "code for the integrals of density.", default=.false.) + "code for the integrals of density.", default=EOS_quad_default) + TFREEZE_DEFAULT = TFREEZE_LINEAR_STRING + if ((EOS%form_of_EOS == EOS_TEOS10 .or. EOS%form_of_EOS == EOS_ROQUET_RHO .or. & + EOS%form_of_EOS == EOS_ROQUET_SPV)) & + TFREEZE_DEFAULT = TFREEZE_TEOS10_STRING call get_param(param_file, mdl, "TFREEZE_FORM", tmpstr, & "TFREEZE_FORM determines which expression should be "//& "used for the freezing point. Currently, the valid "//& - 'choices are "LINEAR", "MILLERO_78", "TEOS10"', & + 'choices are "LINEAR", "MILLERO_78", "TEOS_POLY", "TEOS10"', & default=TFREEZE_DEFAULT) select case (uppercase(tmpstr)) case (TFREEZE_LINEAR_STRING) EOS%form_of_TFreeze = TFREEZE_LINEAR case (TFREEZE_MILLERO_STRING) EOS%form_of_TFreeze = TFREEZE_MILLERO + case (TFREEZE_TEOSPOLY_STRING) + EOS%form_of_TFreeze = TFREEZE_TEOSPOLY case (TFREEZE_TEOS10_STRING) EOS%form_of_TFreeze = TFREEZE_TEOS10 case default @@ -1354,23 +1683,39 @@ subroutine EOS_init(param_file, EOS, US) call get_param(param_file, mdl, "TFREEZE_S0_P0",EOS%TFr_S0_P0, & "When TFREEZE_FORM="//trim(TFREEZE_LINEAR_STRING)//", "//& "this is the freezing potential temperature at "//& - "S=0, P=0.", units="deg C", default=0.0) + "S=0, P=0.", units="degC", default=0.0) call get_param(param_file, mdl, "DTFREEZE_DS",EOS%dTFr_dS, & "When TFREEZE_FORM="//trim(TFREEZE_LINEAR_STRING)//", "//& "this is the derivative of the freezing potential "//& "temperature with salinity.", & - units="deg C PSU-1", default=-0.054) + units="degC ppt-1", default=-0.054) call get_param(param_file, mdl, "DTFREEZE_DP",EOS%dTFr_dP, & "When TFREEZE_FORM="//trim(TFREEZE_LINEAR_STRING)//", "//& "this is the derivative of the freezing potential "//& "temperature with pressure.", & - units="deg C Pa-1", default=0.0) + units="degC Pa-1", default=0.0) endif - if ((EOS%form_of_EOS == EOS_TEOS10 .OR. EOS%form_of_EOS == EOS_NEMO) .AND. & - EOS%form_of_TFreeze /= TFREEZE_TEOS10) then - call MOM_error(FATAL, "interpret_eos_selection: EOS_TEOS10 or EOS_NEMO \n" //& - "should only be used along with TFREEZE_FORM = TFREEZE_TEOS10 .") + if ((EOS%form_of_TFreeze==TFREEZE_TEOSPOLY) .or. (EOS%form_of_TFreeze==TFREEZE_TEOS10)) then + ! Which default is appropriate for Millero? + EOS_TS_default = .false. + else + EOS_TS_default = .true. + endif + call get_param(param_file, mdl, "TFREEZE_S_IS_PRACS", EOS%TFreeze_S_is_pracS, & + "When True, the model will check if the model internal salinity is "//& + "practical salinity. If the model uses absolute salinity, a "//& + "conversion will be applied.", default=EOS_TS_default) + call get_param(param_file, mdl, "TFREEZE_T_IS_POTT", EOS%TFreeze_T_is_potT, & + "When True, the model will check if the model internal temperature is "//& + "potential temperature. If the model uses conservative temperature, a "//& + "conversion will be applied.", default=EOS_TS_default) + + if ((EOS%form_of_EOS == EOS_TEOS10 .or. EOS%form_of_EOS == EOS_ROQUET_RHO .or. & + EOS%form_of_EOS == EOS_ROQUET_SPV) .and. & + .not.((EOS%form_of_TFreeze == TFREEZE_TEOS10) .or. (EOS%form_of_TFreeze == TFREEZE_TEOSPOLY)) ) then + call MOM_error(WARNING, "interpret_eos_selection: EOS_TEOS10 or EOS_ROQUET_RHO or EOS_ROQUET_SPV "//& + "should only be used along with TFREEZE_FORM = TFREEZE_TEOS10 or TFREEZE_TEOSPOLY.") endif ! Unit conversions @@ -1379,12 +1724,17 @@ subroutine EOS_init(param_file, EOS, US) EOS%R_to_kg_m3 = 1. ; if (present(US)) EOS%R_to_kg_m3 = US%R_to_kg_m3 EOS%RL2_T2_to_Pa = 1. ; if (present(US)) EOS%RL2_T2_to_Pa = US%RL2_T2_to_Pa EOS%L_T_to_m_s = 1. ; if (present(US)) EOS%L_T_to_m_s = US%L_T_to_m_s + EOS%degC_to_C = 1. ; if (present(US)) EOS%degC_to_C = US%degC_to_C + EOS%C_to_degC = 1. ; if (present(US)) EOS%C_to_degC = US%C_to_degC + EOS%ppt_to_S = 1. ; if (present(US)) EOS%ppt_to_S = US%ppt_to_S + EOS%S_to_ppt = 1. ; if (present(US)) EOS%S_to_ppt = US%S_to_ppt end subroutine EOS_init !> Manually initialized an EOS type (intended for unit testing of routines which need a specific EOS) subroutine EOS_manual_init(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Compressible, & - Rho_T0_S0, drho_dT, dRho_dS, TFr_S0_P0, dTFr_dS, dTFr_dp) + Rho_T0_S0, drho_dT, dRho_dS, dRho_dp, TFr_S0_P0, dTFr_dS, dTFr_dp, & + use_Wright_2nd_deriv_bug) type(EOS_type), intent(inout) :: EOS !< Equation of state structure integer, optional, intent(in) :: form_of_EOS !< A coded integer indicating the equation of state to use. integer, optional, intent(in) :: form_of_TFreeze !< A coded integer indicating the expression for @@ -1397,79 +1747,281 @@ subroutine EOS_manual_init(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Co !! in [kg m-3 degC-1] real , optional, intent(in) :: dRho_dS !< Partial derivative of density with salinity !! in [kg m-3 ppt-1] + real , optional, intent(in) :: dRho_dp !< Partial derivative of density with pressure + !! in [s2 m-2] real , optional, intent(in) :: TFr_S0_P0 !< The freezing potential temperature at S=0, P=0 [degC] real , optional, intent(in) :: dTFr_dS !< The derivative of freezing point with salinity !! in [degC ppt-1] real , optional, intent(in) :: dTFr_dp !< The derivative of freezing point with pressure !! in [degC Pa-1] + logical, optional, intent(in) :: use_Wright_2nd_deriv_bug !< Allow the Wright 2nd deriv bug - if (present(form_of_EOS )) EOS%form_of_EOS = form_of_EOS + if (present(form_of_EOS)) then + EOS%form_of_EOS = form_of_EOS + if (allocated(EOS%type)) deallocate(EOS%type) ! Needed during testing which re-initializes + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + allocate(linear_EOS :: EOS%type) + case (EOS_UNESCO) + allocate(UNESCO_EOS :: EOS%type) + case (EOS_WRIGHT) + allocate(buggy_Wright_EOS :: EOS%type) + case (EOS_WRIGHT_FULL) + allocate(Wright_full_EOS :: EOS%type) + case (EOS_WRIGHT_REDUCED) + allocate(Wright_red_EOS :: EOS%type) + case (EOS_JACKETT06) + allocate(Jackett06_EOS :: EOS%type) + case (EOS_TEOS10) + allocate(TEOS10_EOS :: EOS%type) + case (EOS_ROQUET_RHO) + allocate(Roquet_rho_EOS :: EOS%type) + case (EOS_ROQUET_SPV) + allocate(Roquet_SpV_EOS :: EOS%type) + end select + select type (t => EOS%type) + type is (linear_EOS) + call t%set_params_linear(Rho_T0_S0, dRho_dT, dRho_dS, dRho_dp) + type is (buggy_Wright_EOS) + call t%set_params_buggy_Wright(use_Wright_2nd_deriv_bug) + end select + endif if (present(form_of_TFreeze)) EOS%form_of_TFreeze = form_of_TFreeze if (present(EOS_quadrature )) EOS%EOS_quadrature = EOS_quadrature if (present(Compressible )) EOS%Compressible = Compressible if (present(Rho_T0_S0 )) EOS%Rho_T0_S0 = Rho_T0_S0 if (present(drho_dT )) EOS%drho_dT = drho_dT if (present(dRho_dS )) EOS%dRho_dS = dRho_dS + if (present(dRho_dp )) EOS%dRho_dp = dRho_dp if (present(TFr_S0_P0 )) EOS%TFr_S0_P0 = TFr_S0_P0 if (present(dTFr_dS )) EOS%dTFr_dS = dTFr_dS if (present(dTFr_dp )) EOS%dTFr_dp = dTFr_dp + if (present(use_Wright_2nd_deriv_bug)) EOS%use_Wright_2nd_deriv_bug = use_Wright_2nd_deriv_bug end subroutine EOS_manual_init -!> Set equation of state structure (EOS) to linear with given coefficients -!! -!! \note This routine is primarily for testing and allows a local copy of the -!! EOS_type (EOS argument) to be set to use the linear equation of state -!! independent from the rest of the model. -subroutine EOS_use_linear(Rho_T0_S0, dRho_dT, dRho_dS, EOS, use_quadrature) - real, intent(in) :: Rho_T0_S0 !< Density at T=0 degC and S=0 ppt [kg m-3] - real, intent(in) :: dRho_dT !< Partial derivative of density with temperature [kg m-3 degC-1] - real, intent(in) :: dRho_dS !< Partial derivative of density with salinity [kg m-3 ppt-1] - logical, optional, intent(in) :: use_quadrature !< If true, always use the generic (quadrature) - !! code for the integrals of density. - type(EOS_type), intent(inout) :: EOS !< Equation of state structure - - EOS%form_of_EOS = EOS_LINEAR - EOS%Compressible = .false. - EOS%Rho_T0_S0 = Rho_T0_S0 - EOS%dRho_dT = dRho_dT - EOS%dRho_dS = dRho_dS - EOS%EOS_quadrature = .false. - if (present(use_quadrature)) EOS%EOS_quadrature = use_quadrature - -end subroutine EOS_use_linear - +! !> Set equation of state structure (EOS) to linear with given coefficients +! !! +! !! \note This routine is primarily for testing and allows a local copy of the +! !! EOS_type (EOS argument) to be set to use the linear equation of state +! !! independent from the rest of the model. +! subroutine EOS_use_linear(Rho_T0_S0, dRho_dT, dRho_dS, EOS, use_quadrature) +! real, intent(in) :: Rho_T0_S0 !< Density at T=0 degC and S=0 ppt [kg m-3] +! real, intent(in) :: dRho_dT !< Partial derivative of density with temperature [kg m-3 degC-1] +! real, intent(in) :: dRho_dS !< Partial derivative of density with salinity [kg m-3 ppt-1] +! logical, optional, intent(in) :: use_quadrature !< If true, always use the generic (quadrature) +! !! code for the integrals of density. +! type(EOS_type), intent(inout) :: EOS !< Equation of state structure + +! call EOS_manual_init(EOS, form_of_EOS=EOS_LINEAR, Rho_T0_S0=Rho_T0_S0, dRho_dT=dRho_dT, dRho_dS=dRho_dS) +! EOS%Compressible = .false. +! EOS%EOS_quadrature = .false. +! if (present(use_quadrature)) EOS%EOS_quadrature = use_quadrature + +! end subroutine EOS_use_linear !> Convert T&S to Absolute Salinity and Conservative Temperature if using TEOS10 subroutine convert_temp_salt_for_TEOS10(T, S, HI, kd, mask_z, EOS) integer, intent(in) :: kd !< The number of layers to work on type(hor_index_type), intent(in) :: HI !< The horizontal index structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed,kd), & - intent(inout) :: T !< Potential temperature referenced to the surface [degC] + intent(inout) :: T !< Potential temperature referenced to the surface [C ~> degC] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed,kd), & - intent(inout) :: S !< Salinity [ppt] + intent(inout) :: S !< Salinity [S ~> ppt] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed,kd), & - intent(in) :: mask_z !< 3d mask regulating which points to convert. + intent(in) :: mask_z !< 3d mask regulating which points to convert [nondim] type(EOS_type), intent(in) :: EOS !< Equation of state structure + real, parameter :: Sref_Sprac = (35.16504/35.0) ! The TEOS 10 conversion factor to go from + ! practical salinity to reference salinity [PSU ppt-1] integer :: i, j, k - real :: gsw_sr_from_sp, gsw_ct_from_pt, gsw_sa_from_sp - real :: p - if ((EOS%form_of_EOS /= EOS_TEOS10) .and. (EOS%form_of_EOS /= EOS_NEMO)) return + if ((EOS%form_of_EOS /= EOS_TEOS10) .and. (EOS%form_of_EOS /= EOS_ROQUET_RHO) .and. & + (EOS%form_of_EOS /= EOS_ROQUET_SPV)) return do k=1,kd ; do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec if (mask_z(i,j,k) >= 1.0) then - S(i,j,k) = gsw_sr_from_sp(S(i,j,k)) -! Get absolute salinity from practical salinity, converting pressures from Pascal to dbar. -! If this option is activated, pressure will need to be added as an argument, and it should be -! moved out into module that is not shared between components, where the ocean_grid can be used. -! S(i,j,k) = gsw_sa_from_sp(S(i,j,k),pres(i,j,k)*1.0e-4,G%geoLonT(i,j),G%geoLatT(i,j)) - T(i,j,k) = gsw_ct_from_pt(S(i,j,k), T(i,j,k)) + S(i,j,k) = Sref_Sprac * S(i,j,k) + T(i,j,k) = EOS%degC_to_C*poTemp_to_consTemp(EOS%C_to_degC*T(i,j,k), EOS%S_to_ppt*S(i,j,k)) endif enddo ; enddo ; enddo end subroutine convert_temp_salt_for_TEOS10 + +!> Converts an array of conservative temperatures to potential temperatures. The input arguments +!! use the dimensionally rescaling as specified within the EOS type. The output potential +!! temperature uses this same scaling, but this can be replaced by the factor given by scale. +subroutine cons_temp_to_pot_temp(T, S, poTemp, EOS, dom, scale) + real, dimension(:), intent(in) :: T !< Conservative temperature [C ~> degC] + real, dimension(:), intent(in) :: S !< Absolute salinity [S ~> ppt] + real, dimension(:), intent(inout) :: poTemp !< The potential temperature with a reference pressure + !! of 0 Pa, [C ~> degC] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale the output + !! potential temperature in place of with scaling stored + !! in EOS. A value of 1.0 returns temperatures in [degC], + !! while the default is equivalent to EOS%degC_to_C. + + ! Local variables + real, dimension(size(T)) :: Ta ! Temperature converted to [degC] + real, dimension(size(S)) :: Sa ! Salinity converted to [ppt] + real :: T_scale ! A factor to convert potential temperature from degC to the desired units [C degC-1 ~> 1] + integer :: i, is, ie + + if (present(dom)) then + is = dom(1) ; ie = dom(2) + else + is = 1 ; ie = size(T) + endif + + if ((EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then + poTemp(is:ie) = consTemp_to_poTemp(T(is:ie), S(is:ie)) + else + do i=is,ie + Ta(i) = EOS%C_to_degC * T(i) + Sa(i) = EOS%S_to_ppt * S(i) + enddo + poTemp(is:ie) = consTemp_to_poTemp(Ta(is:ie), Sa(is:ie)) + endif + + T_scale = EOS%degC_to_C + if (present(scale)) T_scale = scale + if (T_scale /= 1.0) then ; do i=is,ie + poTemp(i) = T_scale * poTemp(i) + enddo ; endif + +end subroutine cons_temp_to_pot_temp + + +!> Converts an array of potential temperatures to conservative temperatures. The input arguments +!! use the dimensionally rescaling as specified within the EOS type. The output potential +!! temperature uses this same scaling, but this can be replaced by the factor given by scale. +subroutine pot_temp_to_cons_temp(T, S, consTemp, EOS, dom, scale) + real, dimension(:), intent(in) :: T !< Potential temperature [C ~> degC] + real, dimension(:), intent(in) :: S !< Absolute salinity [S ~> ppt] + real, dimension(:), intent(inout) :: consTemp !< The conservative temperature [C ~> degC] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale the output + !! potential temperature in place of with scaling stored + !! in EOS. A value of 1.0 returns temperatures in [degC], + !! while the default is equivalent to EOS%degC_to_C. + + ! Local variables + real, dimension(size(T)) :: Tp ! Potential temperature converted to [degC] + real, dimension(size(S)) :: Sa ! Absolute salinity converted to [ppt] + real :: T_scale ! A factor to convert potential temperature from degC to the desired units [C degC-1 ~> 1] + integer :: i, is, ie + + if (present(dom)) then + is = dom(1) ; ie = dom(2) + else + is = 1 ; ie = size(T) + endif + + + if ((EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then + consTemp(is:ie) = poTemp_to_consTemp(T(is:ie), S(is:ie)) + else + do i=is,ie + Tp(i) = EOS%C_to_degC * T(i) + Sa(i) = EOS%S_to_ppt * S(i) + enddo + consTemp(is:ie) = poTemp_to_consTemp(Tp(is:ie), Sa(is:ie)) + endif + + T_scale = EOS%degC_to_C + if (present(scale)) T_scale = scale + if (T_scale /= 1.0) then ; do i=is,ie + consTemp(i) = T_scale * consTemp(i) + enddo ; endif + +end subroutine pot_temp_to_cons_temp + + +!> Converts an array of absolute salinity to practical salinity. The input arguments +!! use the dimensionally rescaling as specified within the EOS type. The output potential +!! temperature uses this same scaling, but this can be replaced by the factor given by scale. +subroutine abs_saln_to_prac_saln(S, prSaln, EOS, dom, scale) + real, dimension(:), intent(in) :: S !< Absolute salinity [S ~> ppt] + real, dimension(:), intent(inout) :: prSaln !< Practical salinity [S ~> PSU] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale the output + !! practical salinities in place of with scaling stored + !! in EOS. A value of 1.0 returns salinities in [PSU], + !! while the default is equivalent to EOS%ppt_to_S. + + ! Local variables + real :: S_scale ! A factor to convert practical salinity from ppt to the desired units [S PSU-1 ~> 1] + real, parameter :: Sprac_Sref = (35.0/35.16504) ! The TEOS 10 conversion factor to go from + ! reference salinity to practical salinity [PSU ppt-1] + integer :: i, is, ie + + if (present(dom)) then + is = dom(1) ; ie = dom(2) + else + is = 1 ; ie = size(S) + endif + + if (present(scale)) then + S_scale = Sprac_Sref * scale + do i=is,ie + prSaln(i) = S_scale * S(i) + enddo + else + do i=is,ie + prSaln(i) = Sprac_Sref * S(i) + enddo + endif + +end subroutine abs_saln_to_prac_saln + + +!> Converts an array of absolute salinity to practical salinity. The input arguments +!! use the dimensionally rescaling as specified within the EOS type. The output potential +!! temperature uses this same scaling, but this can be replaced by the factor given by scale. +subroutine prac_saln_to_abs_saln(S, absSaln, EOS, dom, scale) + real, dimension(:), intent(in) :: S !< Practical salinity [S ~> PSU] + real, dimension(:), intent(inout) :: absSaln !< Absolute salinity [S ~> ppt] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + integer, dimension(2), optional, intent(in) :: dom !< The domain of indices to work on, taking + !! into account that arrays start at 1. + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale the output + !! absolute salnities in place of with scaling stored + !! in EOS. A value of 1.0 returns salinities in [ppt], + !! while the default is equivalent to EOS%ppt_to_S. + + ! Local variables + real :: S_scale ! A factor to convert absolute salinity from ppt to the desired units [S ppt-1 ~> 1] + real, parameter :: Sref_Sprac = (35.16504/35.0) ! The TEOS 10 conversion factor to go from + ! practical salinity to reference salinity [PSU ppt-1] + integer :: i, is, ie + + if (present(dom)) then + is = dom(1) ; ie = dom(2) + else + is = 1 ; ie = size(S) + endif + + if (present(scale)) then + S_scale = Sref_Sprac * scale + do i=is,ie + absSaln(i) = S_scale * S(i) + enddo + else + do i=is,ie + absSaln(i) = Sref_Sprac * S(i) + enddo + endif + +end subroutine prac_saln_to_abs_saln + + !> Return value of EOS_quadrature logical function EOS_quadrature(EOS) type(EOS_type), intent(in) :: EOS !< Equation of state structure @@ -1478,44 +2030,634 @@ logical function EOS_quadrature(EOS) end function EOS_quadrature -!> Extractor routine for the EOS type if the members need to be accessed outside this module -subroutine extract_member_EOS(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Compressible, & - Rho_T0_S0, drho_dT, dRho_dS, TFr_S0_P0, dTFr_dS, dTFr_dp) - type(EOS_type), intent(in) :: EOS !< Equation of state structure - integer, optional, intent(out) :: form_of_EOS !< A coded integer indicating the equation of state to use. - integer, optional, intent(out) :: form_of_TFreeze !< A coded integer indicating the expression for - !! the potential temperature of the freezing point. - logical, optional, intent(out) :: EOS_quadrature !< If true, always use the generic (quadrature) - !! code for the integrals of density. - logical, optional, intent(out) :: Compressible !< If true, in situ density is a function of pressure. - real , optional, intent(out) :: Rho_T0_S0 !< Density at T=0 degC and S=0 ppt [kg m-3] - real , optional, intent(out) :: drho_dT !< Partial derivative of density with temperature - !! in [kg m-3 degC-1] - real , optional, intent(out) :: dRho_dS !< Partial derivative of density with salinity - !! in [kg m-3 ppt-1] - real , optional, intent(out) :: TFr_S0_P0 !< The freezing potential temperature at S=0, P=0 [degC] - real , optional, intent(out) :: dTFr_dS !< The derivative of freezing point with salinity - !! [degC PSU-1] - real , optional, intent(out) :: dTFr_dp !< The derivative of freezing point with pressure - !! [degC Pa-1] - - if (present(form_of_EOS )) form_of_EOS = EOS%form_of_EOS - if (present(form_of_TFreeze)) form_of_TFreeze = EOS%form_of_TFreeze - if (present(EOS_quadrature )) EOS_quadrature = EOS%EOS_quadrature - if (present(Compressible )) Compressible = EOS%Compressible - if (present(Rho_T0_S0 )) Rho_T0_S0 = EOS%Rho_T0_S0 - if (present(drho_dT )) drho_dT = EOS%drho_dT - if (present(dRho_dS )) dRho_dS = EOS%dRho_dS - if (present(TFr_S0_P0 )) TFr_S0_P0 = EOS%TFr_S0_P0 - if (present(dTFr_dS )) dTFr_dS = EOS%dTFr_dS - if (present(dTFr_dp )) dTFr_dp = EOS%dTFr_dp - -end subroutine extract_member_EOS +!> Runs unit tests for consistency on the equations of state. +!! This should only be called from a single/root thread. +!! It returns True if any test fails, otherwise it returns False. +logical function EOS_unit_tests(verbose) + logical, intent(in) :: verbose !< If true, write results to stdout + ! Local variables + type(EOS_type) :: EOS_tmp + logical :: fail + + if (verbose) write(stdout,*) '==== MOM_EOS: EOS_unit_tests ====' + EOS_unit_tests = .false. ! Normally return false + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_TEOS10) + fail = test_TS_conversion_consistency(T_cons=9.989811727177308, S_abs=35.16504, & + T_pot=10.0, S_prac=35.0, EOS=EOS_tmp, verbose=verbose) + if (verbose .and. fail) call MOM_error(WARNING, "Some EOS variable conversions tests have failed.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_UNESCO) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "UNESCO", & + rho_check=1027.54345796120*EOS_tmp%kg_m3_to_R) + if (verbose .and. fail) call MOM_error(WARNING, "UNESCO EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_WRIGHT_FULL) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "WRIGHT_FULL", & + rho_check=1027.55177447616*EOS_tmp%kg_m3_to_R, avg_Sv_check=.true.) + if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT_FULL EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_WRIGHT_REDUCED) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "WRIGHT_REDUCED", & + rho_check=1027.54303596346*EOS_tmp%kg_m3_to_R, avg_Sv_check=.true.) + if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT_REDUCED EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + ! This test is deliberately outside of the fit range for WRIGHT_REDUCED, and it results in the expected warnings. + ! call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_WRIGHT_REDUCED) + ! fail = test_EOS_consistency(25.0, 15.0, 1.0e7, EOS_tmp, verbose, "WRIGHT_REDUCED", & + ! rho_check=1012.625699301455*EOS_tmp%kg_m3_to_R) + ! if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT_REDUCED EOS has failed some self-consistency tests.") + ! EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_WRIGHT, use_Wright_2nd_deriv_bug=.true.) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "WRIGHT", & + rho_check=1027.54303596346*EOS_tmp%kg_m3_to_R, avg_Sv_check=.true.) + ! These last test is a known failure and since MPI is not necessarily initializaed when running these tests + ! we need to avoid flagging the fails. + !if (verbose .and. fail) call MOM_error(WARNING, "WRIGHT EOS has failed some self-consistency tests.") + !EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_ROQUET_RHO) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "ROQUET_RHO", & + rho_check=1027.42385663668*EOS_tmp%kg_m3_to_R) + if (verbose .and. fail) call MOM_error(WARNING, "ROQUET_RHO EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_ROQUET_SPV) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "ROQUET_SPV", & + rho_check=1027.42387475199*EOS_tmp%kg_m3_to_R) + if (verbose .and. fail) call MOM_error(WARNING, "ROQUET_SPV EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_JACKETT06) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "JACKETT06", & + rho_check=1027.539690758425*EOS_tmp%kg_m3_to_R) + if (verbose .and. fail) call MOM_error(WARNING, "JACKETT06 EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + ! The TEOS10 equation of state is not passing the self consistency tests for dho_dS_dp due + ! to a bug (a missing division by the square root of offset-salinity) on line 111 of + ! pkg/GSW-Fortan/toolbox/gsw_specvol_second_derivatives.f90. This bug has been highlighted in an + ! issue posted to the TEOS-10/GSW-Fortran page at github.com/TEOS-10/GSW-Fortran/issues/26, and + ! it will be corrected by github.com/mom-ocean/GSW-Fortran/pull/1 . + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_TEOS10) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "TEOS10", skip_2nd=.true., & + rho_check=1027.42355961492*EOS_tmp%kg_m3_to_R) + if (verbose .and. fail) call MOM_error(WARNING, "TEOS10 EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_ROQUET_RHO) + fail = test_EOS_consistency(10.0, 30.0, 1.0e7, EOS_tmp, verbose, "ROQUET_RHO", & + rho_check=1027.45140117152*EOS_tmp%kg_m3_to_R) + ! The corresponding check value published by Roquet et al. (2015) is 1027.45140 [kg m-3]. + if (verbose .and. fail) call MOM_error(WARNING, "Roquet_rho EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_ROQUET_SPV) + fail = test_EOS_consistency(10.0, 30.0, 1.0e7, EOS_tmp, verbose, "ROQUET_SPV", & + spv_check=9.73282046614623e-04*EOS_tmp%R_to_kg_m3) + ! The corresponding check value here published by Roquet et al. (2015) is 9.732819628e-04 [m3 kg-1], + ! but the order of arithmetic there was not completely specified with parentheses. + if (verbose .and. fail) call MOM_error(WARNING, "ROQUET_SPV EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_LINEAR, Rho_T0_S0=1000.0, drho_dT=-0.2, dRho_dS=0.8, dRho_dp=5.0e-7) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "LINEAR", & + rho_check=1028.0*EOS_tmp%kg_m3_to_R, avg_Sv_check=.true.) + if (verbose .and. fail) call MOM_error(WARNING, "LINEAR EOS has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + ! Test the freezing point calculations + + call EOS_manual_init(EOS_tmp, form_of_TFreeze=TFREEZE_LINEAR, TFr_S0_P0=0.0, dTFr_dS=-0.054, & + dTFr_dP=-7.6e-8) + fail = test_TFr_consistency(35.0, 1.0e7, EOS_tmp, verbose, "LINEAR", TFr_check=-2.65*EOS_tmp%degC_to_C) + if (verbose .and. fail) call MOM_error(WARNING, "LINEAR TFr has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_TFreeze=TFREEZE_MILLERO) + fail = test_TFr_consistency(35.0, 1.0e7, EOS_tmp, verbose, "MILLERO_78", & + TFr_check=-2.69730134114106*EOS_tmp%degC_to_C) + if (verbose .and. fail) call MOM_error(WARNING, "MILLERO_78 TFr has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_TFreeze=TFREEZE_TEOS10) + fail = test_TFr_consistency(35.0, 1.0e7, EOS_tmp, verbose, "TEOS10", & + TFr_check=-2.69099996992861*EOS_tmp%degC_to_C) + if (verbose .and. fail) call MOM_error(WARNING, "TEOS10 TFr has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + call EOS_manual_init(EOS_tmp, form_of_TFreeze=TFREEZE_TEOSPOLY) + fail = test_TFr_consistency(35.0, 1.0e7, EOS_tmp, verbose, "TEOS_POLY", & + TFr_check=-2.691165259327735*EOS_tmp%degC_to_C) + if (verbose .and. fail) call MOM_error(WARNING, "TEOS_POLY TFr has failed some self-consistency tests.") + EOS_unit_tests = EOS_unit_tests .or. fail + + if (EOS_unit_tests) then + call MOM_error(WARNING, "EOS_unit_tests: One or more EOS tests have failed!") + else + if (verbose) call MOM_mesg("EOS_unit_tests: All EOS consistency tests have passed.") + endif + +end function EOS_unit_tests + +logical function test_TS_conversion_consistency(T_cons, S_abs, T_pot, S_prac, EOS, verbose) & + result(inconsistent) + real, intent(in) :: T_cons !< Conservative temperature [degC] + real, intent(in) :: S_abs !< Absolute salinity [g kg-1] + real, intent(in) :: T_pot !< Potential temperature [degC] + real, intent(in) :: S_prac !< Practical salinity [PSU] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + logical, intent(in) :: verbose !< If true, write results to stdout + + ! Local variables + real :: Sabs(1) ! Absolute or reference salinity [g kg-1] + real :: Sprac(1) ! Practical salinity [PSU] + real :: Stest(1) ! A converted salinity [ppt] + real :: Tcons(1) ! Conservative temperature [degC] + real :: Tpot(1) ! Potential temperature [degC] + real :: Ttest(1) ! A converted temperature [degC] + real :: Stol ! Roundoff error on a typical value of salinities [ppt] + real :: Ttol ! Roundoff error on a typical value of temperatures [degC] + logical :: test_OK ! True if a particular test is consistent. + logical :: OK ! True if all checks so far are consistent. + + OK = .true. + + ! Copy scalar input values into the corresponding arrays + Sabs(1) = S_abs ; Sprac(1) = S_prac ; Tcons(1) = T_cons ; Tpot(1) = T_pot + + ! Set tolerances for the conversions. + Ttol = 2.0 * 400.0*epsilon(Ttol) + Stol = 35.0 * 400.0*epsilon(Stol) + + ! Check that the converted salinities agree + call abs_saln_to_prac_saln(Sabs, Stest, EOS) + test_OK = (abs(Stest(1) - Sprac(1)) <= Stol) + if (verbose) call write_check_msg("MOM6 Sprac", Stest(1), Sprac(1), Stol, test_OK) + OK = OK .and. test_OK + + call prac_saln_to_abs_saln(Sprac, Stest, EOS) + test_OK = (abs(Stest(1) - Sabs(1)) <= Stol) + if (verbose) call write_check_msg("MOM6 Sabs", Stest(1), Sabs(1), Stol, test_OK) + OK = OK .and. test_OK + + call cons_temp_to_pot_temp(Tcons, Sabs, Ttest, EOS) + test_OK = (abs(Ttest(1) - Tpot(1)) <= Ttol) + if (verbose) call write_check_msg("MOM6 Tpot", Ttest(1), Tpot(1), Ttol, test_OK) + OK = OK .and. test_OK + + call pot_temp_to_cons_temp(Tpot, Sabs, Ttest, EOS) + test_OK = (abs(Ttest(1) - Tcons(1)) <= Ttol) + if (verbose) call write_check_msg("MOM6 Tcons", Ttest(1), Tcons(1), Ttol, test_OK) + OK = OK .and. test_OK + + inconsistent = .not.OK +end function test_TS_conversion_consistency + +logical function test_TFr_consistency(S_test, p_test, EOS, verbose, EOS_name, TFr_check) & + result(inconsistent) + real, intent(in) :: S_test !< Salinity or absolute salinity [S ~> ppt] + real, intent(in) :: p_test !< Pressure [R L2 T-2 ~> Pa] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + logical, intent(in) :: verbose !< If true, write results to stdout + character(len=*), intent(in) :: EOS_name !< A name used in error messages to describe the EoS + real, optional, intent(in) :: TFr_check !< A check value for the Freezing point [C ~> degC] + + ! Local variables + real, dimension(-3:3,-3:3) :: S ! Salinities at the test value and perturbed points [S ~> ppt] + real, dimension(-3:3,-3:3) :: P ! Pressures at the test value and perturbed points [R L2 T-2 ~> Pa] + real, dimension(-3:3,-3:3,2) :: TFr ! Freezing point at the test value and perturbed points [C ~> degC] + real :: dS ! Magnitude of salinity perturbations [S ~> ppt] + real :: dp ! Magnitude of pressure perturbations [R L2 T-2 ~> Pa] + ! real :: tol ! The nondimensional tolerance from roundoff [nondim] + real :: TFr_tol ! Roundoff error on a typical value of TFreeze [C ~> degC] + logical :: test_OK ! True if a particular test is consistent. + logical :: OK ! True if all checks so far are consistent. + integer :: i, j, n + + OK = .true. + + dS = 0.5*EOS%ppt_to_S ! Salinity perturbations [S ~> ppt] + dp = 10.0e4 / EOS%RL2_T2_to_Pa ! Pressure perturbations [R L2 T-2 ~> Pa] + + ! TEOS 10 requires a tolerance that is ~20 times larger than other freezing point + ! expressions because it lacks parentheses. + TFr_tol = 2.0*EOS%degC_to_C * 400.0*epsilon(TFr_tol) + + do n=1,2 + ! Calculate density values with a wide enough stencil to estimate first and second derivatives + ! with up to 6th order accuracy. Doing this twice with different sizes of perturbations allows + ! the evaluation of whether the finite differences are converging to the calculated values at a + ! rate that is consistent with the order of accuracy of the finite difference forms, and hence + ! the consistency of the calculated values. + do j=-3,3 ; do i=-3,3 + S(i,j) = max(S_test + n*dS*i, 0.0) + p(i,j) = max(p_test + n*dp*j, 0.0) + enddo ; enddo + do j=-3,3 + call calculate_TFreeze(S(:,j), p(:,j), TFr(:,j,n), EOS) + enddo + enddo + + ! Check that the freezing point agrees with the provided check value + if (present(TFr_check)) then + test_OK = (abs(TFr_check - TFr(0,0,1)) <= TFr_tol) + OK = OK .and. test_OK + if (verbose) call write_check_msg(trim(EOS_name)//" TFr", TFr(0,0,1), TFr_check, Tfr_tol, test_OK) + endif + + inconsistent = .not.OK +end function test_TFr_consistency + +!> Write a message indicating how well a value matches its check value. +subroutine write_check_msg(var_name, val, val_chk, val_tol, test_OK) + character(len=*), intent(in) :: var_name !< The name of the variable being tested. + real, intent(in) :: val !< The value being checked [various] + real, intent(in) :: val_chk !< The value being checked [various] + real, intent(in) :: val_tol !< The value being checked [various] + logical, intent(in) :: test_OK !< True if the values are within their tolerance + + character(len=200) :: mesg + + write(mesg, '(ES24.16," vs. ",ES24.16,", diff=",ES12.4,", tol=",ES12.4)') & + val, val_chk, val-val_chk, val_tol + if (test_OK) then + write(stdout,*) trim(var_name)//" agrees with its check value :"//trim(mesg) + else + write(stderr,*) trim(var_name)//" disagrees with its check value :"//trim(mesg) + endif +end subroutine write_check_msg + +!> Test an equation of state for self-consistency and consistency with check values, returning false +!! if it is consistent by all tests, and true if it fails any test. +logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & + EOS_name, rho_check, spv_check, skip_2nd, avg_Sv_check) result(inconsistent) + real, intent(in) :: T_test !< Potential temperature or conservative temperature [C ~> degC] + real, intent(in) :: S_test !< Salinity or absolute salinity [S ~> ppt] + real, intent(in) :: p_test !< Pressure [R L2 T-2 ~> Pa] + type(EOS_type), intent(in) :: EOS !< Equation of state structure + logical, intent(in) :: verbose !< If true, write results to stdout + character(len=*), intent(in) :: EOS_name !< A name used in error messages to describe the EoS + real, optional, intent(in) :: rho_check !< A check value for the density [R ~> kg m-3] + real, optional, intent(in) :: spv_check !< A check value for the specific volume [R-1 ~> m3 kg-1] + logical, optional, intent(in) :: skip_2nd !< If present and true, do not check the 2nd derivatives. + logical, optional, intent(in) :: avg_Sv_check !< If present and true, compare analytical and numerical + !! quadrature estimates of the layer-averaged specific volume. + + ! Local variables + real, dimension(-3:3,-3:3,-3:3) :: T ! Temperatures at the test value and perturbed points [C ~> degC] + real, dimension(-3:3,-3:3,-3:3) :: S ! Salinities at the test value and perturbed points [S ~> ppt] + real, dimension(-3:3,-3:3,-3:3) :: P ! Pressures at the test value and perturbed points [R L2 T-2 ~> Pa] + real, dimension(-3:3,-3:3,-3:3,2) :: rho ! Densities relative to rho_ref at the test value and + ! perturbed points [R ~> kg m-3] + real, dimension(-3:3,-3:3,-3:3,2) :: spv ! Specific volumes relative to spv_ref at the test value and + ! perturbed points [R-1 ~> m3 kg-1] + real :: dT ! Magnitude of temperature perturbations [C ~> degC] + real :: dS ! Magnitude of salinity perturbations [S ~> ppt] + real :: dp ! Magnitude of pressure perturbations [R L2 T-2 ~> Pa] + real :: rho_ref ! A reference density that is extracted for greater accuracy [R ~> kg m-3] + real :: spv_ref ! A reference specific volume that is extracted for greater accuracy [R-1 ~> m3 kg-1] + real :: rho_nooff ! Density with no reference offset [R ~> kg m-3] + real :: spv_nooff ! Specific volume with no reference offset [R-1 ~> m3 kg-1] + real :: drho_dT ! The partial derivative of density with potential + ! temperature [R C-1 ~> kg m-3 degC-1] + real :: drho_dS ! The partial derivative of density with salinity + ! in [R S-1 ~> kg m-3 ppt-1] + real :: drho_dp ! The partial derivative of density with pressure (also the + ! inverse of the square of sound speed) [T2 L-2 ~> s2 m-2] + real :: dSV_dT(1) ! The partial derivative of specific volume with potential + ! temperature [R-1 C-1 ~> m3 kg-1 degC-1] + real :: dSV_dS(1) ! The partial derivative of specific volume with salinity + ! [R-1 S-1 ~> m3 kg-1 ppt-1] + real :: SpV_avg_a(1) ! The pressure-averaged specific volume determined analytically [R-1 ~> m3 kg-1] + real :: SpV_avg_q(1) ! The pressure-averaged specific volume determined via quadrature [R-1 ~> m3 kg-1] + real :: drho_dS_dS ! Second derivative of density with respect to S [R S-2 ~> kg m-3 ppt-2] + real :: drho_dS_dT ! Second derivative of density with respect to T and S [R S-1 C-1 ~> kg m-3 ppt-1 degC-1] + real :: drho_dT_dT ! Second derivative of density with respect to T [R C-2 ~> kg m-3 degC-2] + real :: drho_dS_dP ! Second derivative of density with respect to salinity and pressure + ! [T2 S-1 L-2 ~> kg m-3 ppt-1 Pa-1] + real :: drho_dT_dP ! Second derivative of density with respect to temperature and pressure + ! [T2 C-1 L-2 ~> kg m-3 degC-1 Pa-1] + + real :: drho_dT_fd(2) ! Two 6th order finite difference estimates of the partial derivative of density + ! with potential temperature [R C-1 ~> kg m-3 degC-1] + real :: drho_dS_fd(2) ! Two 6th order finite difference estimates of the partial derivative of density + ! with salinity [R S-1 ~> kg m-3 ppt-1] + real :: drho_dp_fd(2) ! Two 6th order finite difference estimates of the partial derivative of density + ! with pressure (also the inverse of the square of sound speed) [T2 L-2 ~> s2 m-2] + real :: dSV_dT_fd(2) ! Two 6th order finite difference estimates of the partial derivative of + ! specific volume with potential temperature [R-1 C-1 ~> m3 kg-1 degC-1] + real :: dSV_dS_fd(2) ! Two 6th order finite difference estimates of the partial derivative of + ! specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1] + real :: drho_dS_dS_fd(2) ! Two 6th order finite difference estimates of the second derivative of + ! density with respect to salinity [R S-2 ~> kg m-3 ppt-2] + real :: drho_dS_dT_fd(2) ! Two 6th order finite difference estimates of the second derivative of density + ! with respect to temperature and salinity [R S-1 C-1 ~> kg m-3 ppt-1 degC-1] + real :: drho_dT_dT_fd(2) ! Two 6th order finite difference estimates of the second derivative of + ! density with respect to temperature [R C-2 ~> kg m-3 degC-2] + real :: drho_dS_dP_fd(2) ! Two 6th order finite difference estimates of the second derivative of density + ! with respect to salinity and pressure [T2 S-1 L-2 ~> kg m-3 ppt-1 Pa-1] + real :: drho_dT_dP_fd(2) ! Two 6th order finite difference estimates of the second derivative of density + ! with respect to temperature and pressure [T2 C-1 L-2 ~> kg m-3 degC-1 Pa-1] + real :: rho_tmp ! A temporary copy of the situ density [R ~> kg m-3] + real :: tol ! The nondimensional tolerance from roundoff [nondim] + real :: r_tol ! Roundoff error on a typical value of density anomaly [R ~> kg m-3] + real :: sv_tol ! Roundoff error on a typical value of specific volume anomaly [R-1 ~> m3 kg-1] + real :: tol_here ! The tolerance for each check, in various units [various] + real :: T_min, T_max ! The minimum and maximum temperature over which this EoS is fitted [degC] + real :: S_min, S_max ! The minimum and maximum temperature over which this EoS is fitted [ppt] + real :: p_min, p_max ! The minimum and maximum temperature over which this EoS is fitted [Pa] + real :: count_fac ! A factor in the roundoff estimates based on the factors in the numerator and + ! denominator in the finite difference derivative expression [nondim] + real :: count_fac2 ! A factor in the roundoff estimates based on the factors in the numerator and + ! denominator in the finite difference second derivative expression [nondim] + character(len=200) :: mesg + type(EOS_type) :: EOS_tmp + logical :: test_OK ! True if a particular test is consistent. + logical :: OK ! True if all checks so far are consistent. + logical :: test_2nd ! If true, do tests on the 2nd derivative calculations + logical :: test_avg_Sv ! If true, compare numerical and analytical estimates of the vertically + ! averaged specific volume + integer :: order ! The order of accuracy of the centered finite difference estimates (2, 4 or 6). + integer :: i, j, k, n + + test_2nd = .true. ; if (present(skip_2nd)) test_2nd = .not.skip_2nd + test_avg_Sv = .false. ; if (present(avg_Sv_check)) test_avg_Sv = avg_Sv_check + + dT = 0.1*EOS%degC_to_C ! Temperature perturbations [C ~> degC] + dS = 0.5*EOS%ppt_to_S ! Salinity perturbations [S ~> ppt] + dp = 10.0e4 / EOS%RL2_T2_to_Pa ! Pressure perturbations [R L2 T-2 ~> Pa] + + r_tol = 50.0*EOS%kg_m3_to_R * 10.*epsilon(r_tol) + sv_tol = 5.0e-5*EOS%R_to_kg_m3 * 10.*epsilon(sv_tol) + rho_ref = 1000.0*EOS%kg_m3_to_R + spv_ref = 1.0 / rho_ref + + order = 4 ! This should be 2, 4 or 6. + + ! Check whether the consistency test is being applied outside of the value range of this EoS. + call EoS_fit_range(EOS, T_min, T_max, S_min, S_max, p_min, p_max) + if ((T_test < T_min) .or. (T_test > T_max)) then + write(mesg, '(ES12.4," [degC] which is outside of the fit range of ",ES12.4," to ",ES12.4)') T_test, T_min, T_max + call MOM_error(WARNING, trim(EOS_name)//" is being evaluated at a temperature of "//trim(mesg)) + endif + if ((S_test < S_min) .or. (S_test > S_max)) then + write(mesg, '(ES12.4," [ppt] which is outside of the fit range of ",ES12.4," to ",ES12.4)') S_test, S_min, S_max + call MOM_error(WARNING, trim(EOS_name)//" is being evaluated at a salinity of "//trim(mesg)) + endif + if ((p_test < p_min) .or. (p_test > p_max)) then + write(mesg, '(ES12.4," [Pa] which is outside of the fit range of ",ES12.4," to ",ES12.4)') p_test, p_min, p_max + call MOM_error(WARNING, trim(EOS_name)//" is being evaluated at a pressure of "//trim(mesg)) + endif + + do n=1,2 + ! Calculate density values with a wide enough stencil to estimate first and second derivatives + ! with up to 6th order accuracy. Doing this twice with different sizes of perturbations allows + ! the evaluation of whether the finite differences are converging to the calculated values at a + ! rate that is consistent with the order of accuracy of the finite difference forms, and hence + ! the consistency of the calculated values. + do k=-3,3 ; do j=-3,3 ; do i=-3,3 + T(i,j,k) = T_test + n*dT*i + S(i,j,k) = S_test + n*dS*j + p(i,j,k) = p_test + n*dp*k + enddo ; enddo ; enddo + do k=-3,3 ; do j=-3,3 + call calculate_density(T(:,j,k), S(:,j,k), p(:,j,k), rho(:,j,k,n), EOS, rho_ref=rho_ref) + call calculate_spec_vol(T(:,j,k), S(:,j,k), p(:,j,k), spv(:,j,k,n), EOS, spv_ref=spv_ref) + enddo ; enddo + + drho_dT_fd(n) = first_deriv(rho(:,0,0,n), n*dT, order) + drho_dS_fd(n) = first_deriv(rho(0,:,0,n), n*dS, order) + drho_dp_fd(n) = first_deriv(rho(0,0,:,n), n*dp, order) + dSV_dT_fd(n) = first_deriv(spv(:,0,0,n), n*dT, order) + dSV_dS_fd(n) = first_deriv(spv(0,:,0,n), n*dS, order) + if (test_2nd) then + drho_dT_dT_fd(n) = second_deriv(rho(:,0,0,n), n*dT, order) + drho_dS_dS_fd(n) = second_deriv(rho(0,:,0,n), n*dS, order) + drho_dS_dT_fd(n) = derivs_2d(rho(:,:,0,n), n**2*dT*dS, order) + drho_dT_dP_fd(n) = derivs_2d(rho(:,0,:,n), n**2*dT*dP, order) + drho_dS_dP_fd(n) = derivs_2d(rho(0,:,:,n), n**2*dS*dP, order) + endif + enddo + + call calculate_density_derivs(T(0,0,0), S(0,0,0), p(0,0,0), drho_dT, drho_dS, EOS) + ! The first indices here are "0:0" because there is no scalar form of calculate_specific_vol_derivs. + call calculate_specific_vol_derivs(T(0:0,0,0), S(0:0,0,0), p(0:0,0,0), dSV_dT, dSV_dS, EOS) + if (test_2nd) & + call calculate_density_second_derivs(T(0,0,0), S(0,0,0), p(0,0,0), & + drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, EOS) + call calculate_compress(T(0,0,0), S(0,0,0), p(0,0,0), rho_tmp, drho_dp, EOS) + + if (test_avg_Sv) then + EOS_tmp = EOS + call EOS_manual_init(EOS_tmp, EOS_quadrature=.false.) + call average_specific_vol(T(0:0,0,0), S(0:0,0,0), p(0:0,0,0), p(0:0,0,0), SpV_avg_a, EOS_tmp) + call EOS_manual_init(EOS_tmp, EOS_quadrature=.true.) + call average_specific_vol(T(0:0,0,0), S(0:0,0,0), p(0:0,0,0), p(0:0,0,0), SpV_avg_q, EOS_tmp) + endif + + OK = .true. + + tol = 1000.0*epsilon(tol) + + ! Check that the density agrees with the provided check value + if (present(rho_check)) then + test_OK = (abs(rho_check - (rho_ref + rho(0,0,0,1))) < tol*(rho_ref + rho(0,0,0,1))) + OK = OK .and. test_OK + if (verbose) & + call write_check_msg(trim(EOS_name)//" rho", rho_ref+rho(0,0,0,1), rho_check, tol*rho(0,0,0,1), test_OK) + endif + + ! Check that the specific volume agrees with the provided check value or the inverse of density + if (present(spv_check)) then + test_OK = (abs(spv_check - (spv_ref + spv(0,0,0,1))) < tol*abs(spv_ref + spv(0,0,0,1))) + if (verbose) & + call write_check_msg(trim(EOS_name)//" spv", spv_ref+spv(0,0,0,1), spv_check, tol*spv(0,0,0,1), test_OK) + OK = OK .and. test_OK + else + test_OK = (abs((rho_ref+rho(0,0,0,1)) * (spv_ref + spv(0,0,0,1)) - 1.0) < tol) + OK = OK .and. test_OK + if (verbose) then + write(mesg, '(ES16.8," and ",ES16.8,", ratio - 1 = ",ES16.8)') & + rho_ref+rho(0,0,0,1), 1.0/(spv_ref + spv(0,0,0,1)), & + (rho_ref+rho(0,0,0,1)) * (spv_ref + spv(0,0,0,1)) - 1.0 + if (test_OK) then + write(stdout,*) "The values of "//trim(EOS_name)//" rho and 1/spv agree. "//trim(mesg) + else + write(stderr,*) "The values of "//trim(EOS_name)//" rho and 1/spv disagree. "//trim(mesg) + endif + endif + endif + + ! Check that the densities are consistent when the reference value is extracted + call calculate_density(T(0,0,0), S(0,0,0), p(0,0,0), rho_nooff, EOS) + test_OK = (abs(rho_nooff - (rho_ref + rho(0,0,0,1))) < tol*rho_nooff) + OK = OK .and. test_OK + if (verbose .and. .not.test_OK) then + write(mesg, '(ES24.16," vs. ",ES24.16," with tolerance ",ES12.4)') & + rho_ref+rho(0,0,0,1), rho_nooff, tol*rho_nooff + write(stderr,*) "For "//trim(EOS_name)//& + " rho with and without a reference value disagree: "//trim(mesg) + endif + + ! Check that the specific volumes are consistent when the reference value is extracted + call calculate_spec_vol(T(0,0,0), S(0,0,0), p(0,0,0), spv_nooff, EOS) + test_OK = (abs(spv_nooff - (spv_ref + spv(0,0,0,1))) < tol*rho_nooff) + OK = OK .and. test_OK + if (verbose .and. .not.test_OK) then + write(mesg, '(ES24.16," vs. ",ES24.16," with tolerance ",ES12.4)') & + spv_ref + spv(0,0,0,1), spv_nooff, tol*spv_nooff + write(stderr,*) "For "//trim(EOS_name)//& + " spv with and without a reference value disagree: "//trim(mesg) + endif + + ! Account for the factors of terms in the numerator and denominator when estimating roundoff + if (order == 6) then + count_fac = 110.0/60.0 ; count_fac2 = 1088.0/180.0 + elseif (order == 4) then ! Use values appropriate for 4th order schemes. + count_fac = 18.0/12.0 ; count_fac2 = 64.0/12.0 + else ! Use values appropriate for 2nd order schemes. + count_fac = 2.0/2.0 ; count_fac2 = 4.0 + endif + + ! Check for the rate of convergence expected with a 4th or 6th order accurate discretization + ! with a 20% margin of error and a tolerance for contributions from roundoff. + tol_here = tol*abs(drho_dT) + count_fac*r_tol/dT + OK = OK .and. check_FD(drho_dT, drho_dT_fd, tol_here, verbose, trim(EOS_name)//" drho_dT", order) + tol_here = tol*abs(drho_dS) + count_fac*r_tol/dS + OK = OK .and. check_FD(drho_dS, drho_dS_fd, tol_here, verbose, trim(EOS_name)//" drho_dS", order) + tol_here = tol*abs(drho_dp) + count_fac*r_tol/dp + OK = OK .and. check_FD(drho_dp, drho_dp_fd, tol_here, verbose, trim(EOS_name)//" drho_dp", order) + tol_here = tol*abs(dSV_dT(1)) + count_fac*sv_tol/dT + OK = OK .and. check_FD(dSV_dT(1), dSV_dT_fd, tol_here, verbose, trim(EOS_name)//" dSV_dT", order) + tol_here = tol*abs(dSV_dS(1)) + count_fac*sv_tol/dS + OK = OK .and. check_FD(dSV_dS(1), dSV_dS_fd, tol_here, verbose, trim(EOS_name)//" dSV_dS", order) + if (test_2nd) then + tol_here = tol*abs(drho_dT_dT) + count_fac2*r_tol/dT**2 + OK = OK .and. check_FD(drho_dT_dT, drho_dT_dT_fd, tol_here, verbose, trim(EOS_name)//" drho_dT_dT", order) + ! The curvature in salinity is relatively weak, so looser tolerances are needed for some forms of EOS? + tol_here = 10.0*(tol*abs(drho_dS_dS) + count_fac2*r_tol/dS**2) + OK = OK .and. check_FD(drho_dS_dS, drho_dS_dS_fd, tol_here, verbose, trim(EOS_name)//" drho_dS_dS", order) + tol_here = tol*abs(drho_dS_dT) + count_fac**2*r_tol/(dS*dT) + OK = OK .and. check_FD(drho_dS_dT, drho_dS_dT_fd, tol_here, verbose, trim(EOS_name)//" drho_dS_dT", order) + tol_here = tol*abs(drho_dT_dP) + count_fac**2*r_tol/(dT*dp) + OK = OK .and. check_FD(drho_dT_dP, drho_dT_dP_fd, tol_here, verbose, trim(EOS_name)//" drho_dT_dP", order) + tol_here = tol*abs(drho_dS_dP) + count_fac**2*r_tol/(dS*dp) + OK = OK .and. check_FD(drho_dS_dP, drho_dS_dP_fd, tol_here, verbose, trim(EOS_name)//" drho_dS_dP", order) + endif + + if (test_avg_Sv) then + tol_here = 0.5*tol*(abs(SpV_avg_a(1)) + abs(SpV_avg_q(1))) + test_OK = (abs(SpV_avg_a(1) - SpV_avg_q(1)) < tol_here) + if (verbose) then + write(mesg, '(ES24.16," and ",ES24.16," differ by ",ES16.8," (",ES10.2,"), tol=",ES16.8)') & + SpV_avg_a(1), SpV_avg_q(1), SpV_avg_a(1) - SpV_avg_q(1), & + 2.0*(SpV_avg_a(1) - SpV_avg_q(1)) / (abs(SpV_avg_a(1)) + abs(SpV_avg_q(1)) + tiny(SpV_avg_a(1))), & + tol_here + if (verbose .and. .not.test_OK) then + write(stderr,*) "The values of "//trim(EOS_name)//" SpV_avg disagree. "//trim(mesg) + elseif (verbose) then + write(stdout,*) "The values of "//trim(EOS_name)//" SpV_avg agree: "//trim(mesg) + endif + endif + OK = OK .and. test_OK + endif + + inconsistent = .not.OK + + contains + + !> Return a finite difference estimate of the first derivative of a field in arbitrary units [A B-1] + real function first_deriv(R, dx, order) + real, intent(in) :: R(-3:3) !< The field whose derivative is being taken, in arbitrary units [A] + real, intent(in) :: dx !< The spacing in parameter space, in different arbitrary units [B] + integer, intent(in) :: order !< The order of accuracy of the centered finite difference estimates (2, 4 or 6) + + if (order == 6) then ! Find a 6th order accurate first derivative on a regular grid. + first_deriv = (45.0*(R(1)-R(-1)) + (-9.0*(R(2)-R(-2)) + (R(3)-R(-3))) ) / (60.0 * dx) + elseif (order == 4) then ! Find a 4th order accurate first derivative on a regular grid. + first_deriv = (8.0*(R(1)-R(-1)) - (R(2)-R(-2)) ) / (12.0 * dx) + else ! Find a 2nd order accurate first derivative on a regular grid. + first_deriv = (R(1)-R(-1)) / (2.0 * dx) + endif + end function first_deriv + + !> Return a finite difference estimate of the second derivative of a field in arbitrary units [A B-2] + real function second_deriv(R, dx, order) + real, intent(in) :: R(-3:3) !< The field whose derivative is being taken, in arbitrary units [A] + real, intent(in) :: dx !< The spacing in parameter space, in different arbitrary units [B] + integer, intent(in) :: order !< The order of accuracy of the centered finite difference estimates (2, 4 or 6) + + if (order == 6) then ! Find a 6th order accurate second derivative on a regular grid. + second_deriv = ( -490.0*R(0) + (270.0*(R(1)+R(-1)) + (-27.0*(R(2)+R(-2)) + 2.0*(R(3)+R(-3))) )) / (180.0 * dx**2) + elseif (order == 4) then ! Find a 4th order accurate second derivative on a regular grid. + second_deriv = ( -30.0*R(0) + (16.0*(R(1)+R(-1)) - (R(2)+R(-2))) ) / (12.0 * dx**2) + else ! Find a 2nd order accurate second derivative on a regular grid. + second_deriv = ( -2.0*R(0) + (R(1)+R(-1)) ) / dx**2 + endif + end function second_deriv + + !> Return a finite difference estimate of the second derivative with respect to two different + !! parameters of a field in arbitrary units [A B-1 C-1] + real function derivs_2d(R, dxdy, order) + real, intent(in) :: R(-3:3,-3:3) !< The field whose derivative is being taken in arbitrary units [A] + real, intent(in) :: dxdy !< The spacing in two directions in parameter space in different arbitrary units [B C] + integer, intent(in) :: order !< The order of accuracy of the centered finite difference estimates (2, 4 or 6) + + real :: dRdx(-3:3) ! The first derivative in one direction times the grid spacing in that direction [A] + integer :: i + + do i=-3,3 + dRdx(i) = first_deriv(R(:,i), 1.0, order) + enddo + derivs_2d = first_deriv(dRdx, dxdy, order) + + end function derivs_2d + + !> Check for the rate of convergence expected with a finite difference discretization + !! with a 20% margin of error and a tolerance for contributions from roundoff. + logical function check_FD(val, val_fd, tol, verbose, field_name, order) + real, intent(in) :: val !< The derivative being checked, in arbitrary units [arbitrary] + real, intent(in) :: val_fd(2) !< Two finite difference estimates of val taken with a spacing + !! in parameter space and twice this spacing, in the same + !! arbitrary units as val [arbitrary] + real, intent(in) :: tol !< An estimated fractional tolerance due to roundoff [arbitrary] + logical, intent(in) :: verbose !< If true, write results to stdout + character(len=*), intent(in) :: field_name !< A name used to describe the field in error messages + integer, intent(in) :: order !< The order of accuracy of the centered finite difference estimates (2, 4 or 6) + + character(len=200) :: mesg + + check_FD = ( abs(val_fd(1) - val) < (1.2*abs(val_fd(2) - val)/2**order + abs(tol)) ) + + write(mesg, '(ES24.16," and ",ES24.16," differ by ",ES16.8," (",ES10.2,"), tol=",ES16.8)') & + val, val_fd(1), val - val_fd(1), & + 2.0*(val - val_fd(1)) / (abs(val) + abs(val_fd(1)) + tiny(val)), & + (1.2*abs(val_fd(2) - val)/2**order + abs(tol)) + ! This message is useful for debugging the two estimates: + ! write(mesg, '(ES16.8," and ",ES16.8," or ",ES16.8," differ by ",2ES16.8," (",2ES10.2"), tol=",ES16.8)') & + ! val, val_fd(1), val_fd(2), val - val_fd(1), val - val_fd(2), & + ! 2.0*(val - val_fd(1)) / (abs(val) + abs(val_fd(1)) + tiny(val)), & + ! 2.0*(val - val_fd(2)) / (abs(val) + abs(val_fd(2)) + tiny(val)), & + ! (1.2*abs(val_fd(2) - val)/2**order + abs(tol)) + if (verbose .and. .not.check_FD) then + write(stderr,*) "The values of "//trim(field_name)//" disagree. "//trim(mesg) + elseif (verbose) then + write(stdout,*) "The values of "//trim(field_name)//" agree: "//trim(mesg) + endif + end function check_FD + +end function test_EOS_consistency end module MOM_EOS !> \namespace mom_eos !! -!! The MOM_EOS module is a wrapper for various equations of state (e.g. Linear, -!! Wright, UNESCO) and provides a uniform interface to the rest of the model -!! independent of which equation of state is being used. +!! The MOM_EOS module is a wrapper for various equations of state (i.e. Linear, Wright, +!! Wright_full, Wright_red, UNESCO, TEOS10, Roquet_SpV or Roquet_rho) and provides a uniform +!! interface to the rest of the model independent of which equation of state is being used. diff --git a/src/equation_of_state/MOM_EOS_Jackett06.F90 b/src/equation_of_state/MOM_EOS_Jackett06.F90 new file mode 100644 index 0000000000..4c0705f717 --- /dev/null +++ b/src/equation_of_state/MOM_EOS_Jackett06.F90 @@ -0,0 +1,510 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> The equation of state using the Jackett et al 2006 expressions that are often used in Hycom +module MOM_EOS_Jackett06 + +use MOM_EOS_base_type, only : EOS_base + +implicit none ; private + +public Jackett06_EOS + +!>@{ Parameters in the Jackett et al. equation of state, which is a fit to the Fiestel (2003) +! equation of state for the range: -2 < theta < 40 [degC], 0 < S < 42 [PSU], 0 < p < 1e8 [Pa]. +! The notation here is for terms in the numerator of the expression for density of +! RNabc for terms proportional to S**a * T**b * P**c, and terms in the denominator as RDabc. +! For terms proportional to S**1.5, 6 is used in this notation. + +! --- coefficients for 25-term rational function sigloc(). +real, parameter :: & + RN000 = 9.9984085444849347d+02, & ! Density numerator constant coefficient [kg m-3] + RN001 = 1.1798263740430364d-06, & ! Density numerator P coefficient [kg m-3 Pa-1] + RN002 = -2.5862187075154352d-16, & ! Density numerator P^2 coefficient [kg m-3 Pa-2] + RN010 = 7.3471625860981584d+00, & ! Density numerator T coefficient [kg m-3 degC-1] + RN020 = -5.3211231792841769d-02, & ! Density numerator T^2 coefficient [kg m-3 degC-2] + RN021 = 9.8920219266399117d-12, & ! Density numerator T^2 P coefficient [kg m-3 degC-2 Pa-1] + RN022 = -3.2921414007960662d-20, & ! Density numerator T^2 P^2 coefficient [kg m-3 degC-2 Pa-2] + RN030 = 3.6492439109814549d-04, & ! Density numerator T^3 coefficient [kg m-3 degC-3] + RN100 = 2.5880571023991390d+00, & ! Density numerator S coefficient [kg m-3 PSU-1] + RN101 = 4.6996642771754730d-10, & ! Density numerator S P coefficient [kg m-3 PSU-1 Pa-1] + RN110 = -6.7168282786692355d-03, & ! Density numerator S T coefficient [kg m-3 degC-1 PSU-1] + RN200 = 1.9203202055760151d-03, & ! Density numerator S^2 coefficient [kg m-3] + + RD001 = 6.7103246285651894d-10, & ! Density denominator P coefficient [Pa-1] + RD010 = 7.2815210113327091d-03, & ! Density denominator T coefficient [degC-1] + RD013 = -9.1534417604289062d-30, & ! Density denominator T P^3 coefficient [degC-1 Pa-3] + RD020 = -4.4787265461983921d-05, & ! Density denominator T^2 coefficient [degC-2] + RD030 = 3.3851002965802430d-07, & ! Density denominator T^3 coefficient [degC-3] + RD032 = -2.4461698007024582d-25, & ! Density denominator T^3 P^2 coefficient [degC-3 Pa-2] + RD040 = 1.3651202389758572d-10, & ! Density denominator T^4 coefficient [degC-4] + RD100 = 1.7632126669040377d-03, & ! Density denominator S coefficient [PSU-1] + RD110 = -8.8066583251206474d-06, & ! Density denominator S T coefficient [degC-1 PSU-1] + RD130 = -1.8832689434804897d-10, & ! Density denominator S T^3 coefficient [degC-3 PSU-1] + RD600 = 5.7463776745432097d-06, & ! Density denominator S^1.5 coefficient [PSU-1.5] + RD620 = 1.4716275472242334d-09 ! Density denominator S^1.5 T^2 coefficient [degC-2 PSU-1.5] +!>@} + +!> The EOS_base implementation of the Jackett et al, 2006, equation of state +type, extends (EOS_base) :: Jackett06_EOS + +contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_Jackett06 + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_Jackett06 + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_Jackett06 + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_Jackett06 + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_Jackett06 + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_Jackett06 + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_Jackett06 + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_Jackett06 + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_Jackett06 + +end type Jackett06_EOS + +contains + +!> In situ density of sea water using Jackett et al., 2006 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_elem_Jackett06(this, T, S, pressure) + class(Jackett06_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [PSU]. + real, intent(in) :: pressure !< Pressure [Pa]. + + ! Local variables + real :: num_STP ! State dependent part of the numerator of the rational expresion + ! for density [kg m-3] + real :: den ! Denominator of the rational expresion for density [nondim] + real :: den_STP ! State dependent part of the denominator of the rational expresion + ! for density [nondim] + real :: I_den ! The inverse of the denominator of the rational expresion for density [nondim] + real :: T2 ! Temperature squared [degC2] + real :: S1_2 ! Limited square root of salinity [PSU1/2] + + S1_2 = sqrt(max(0.0,s)) + T2 = T*T + + num_STP = (T*(RN010 + T*(RN020 + T*RN030)) + & + S*(RN100 + (T*RN110 + S*RN200)) ) + & + pressure*(RN001 + ((T2*RN021 + S*RN101) + pressure*(RN002 + T2*RN022))) + den = 1.0 + ((T*(RD010 + T*(RD020 + T*(RD030 + T* RD040))) + & + S*(RD100 + (T*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pressure*(RD001 + pressure*T*(T2*RD032 + pressure*RD013)) ) + I_den = 1.0 / den + + density_elem_Jackett06 = (RN000 + num_STP)*I_den + +end function density_elem_Jackett06 + +!> In situ density anomaly of sea water using Jackett et al., 2006 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_anomaly_elem_Jackett06(this, T, S, pressure, rho_ref) + class(Jackett06_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [PSU]. + real, intent(in) :: pressure !< Pressure [Pa]. + real, intent(in) :: rho_ref !< A reference density [kg m-3]. + + ! Local variables + real :: num_STP ! State dependent part of the numerator of the rational expresion + ! for density [kg m-3] + real :: den ! Denominator of the rational expresion for density [nondim] + real :: den_STP ! State dependent part of the denominator of the rational expresion + ! for density [nondim] + real :: I_den ! The inverse of the denominator of the rational expresion for density [nondim] + real :: T2 ! Temperature squared [degC2] + real :: S1_2 ! Limited square root of salinity [PSU1/2] + real :: rho0 ! The surface density of fresh water at 0 degC, perhaps less the refernce density [kg m-3] + + S1_2 = sqrt(max(0.0,s)) + T2 = T*T + + num_STP = (T*(RN010 + T*(RN020 + T*RN030)) + & + S*(RN100 + (T*RN110 + S*RN200)) ) + & + pressure*(RN001 + ((T2*RN021 + S*RN101) + pressure*(RN002 + T2*RN022))) + den = 1.0 + ((T*(RD010 + T*(RD020 + T*(RD030 + T* RD040))) + & + S*(RD100 + (T*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pressure*(RD001 + pressure*T*(T2*RD032 + pressure*RD013)) ) + I_den = 1.0 / den + + rho0 = RN000 - rho_ref*den + + density_anomaly_elem_Jackett06 = (rho0 + num_STP)*I_den + +end function density_anomaly_elem_Jackett06 + +!> In situ specific volume of sea water using Jackett et al., 2006 [m3 kg-1] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_elem_Jackett06(this, T, S, pressure) + class(Jackett06_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< potential temperature relative to the surface [degC]. + real, intent(in) :: S !< salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + + ! Local variables + real :: num_STP ! State dependent part of the numerator of the rational expresion + ! for density (not specific volume) [kg m-3] + real :: den_STP ! State dependent part of the denominator of the rational expresion + ! for density (not specific volume) [nondim] + real :: I_num ! The inverse of the numerator of the rational expresion for density [nondim] + real :: T2 ! Temperature squared [degC2] + real :: S1_2 ! Limited square root of salinity [PSU1/2] + + S1_2 = sqrt(max(0.0,s)) + T2 = T*T + + num_STP = (T*(RN010 + T*(RN020 + T*RN030)) + & + S*(RN100 + (T*RN110 + S*RN200)) ) + & + pressure*(RN001 + ((T2*RN021 + S*RN101) + pressure*(RN002 + T2*RN022))) + den_STP = (T*(RD010 + T*(RD020 + T*(RD030 + T* RD040))) + & + S*(RD100 + (T*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pressure*(RD001 + pressure*T*(T2*RD032 + pressure*RD013)) + I_num = 1.0 / (RN000 + num_STP) + + spec_vol_elem_Jackett06 = (1.0 + den_STP) * I_num + +end function spec_vol_elem_Jackett06 + +!> In situ specific volume anomaly of sea water using Jackett et al., 2006 [m3 kg-1] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_anomaly_elem_Jackett06(this, T, S, pressure, spv_ref) + class(Jackett06_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< potential temperature relative to the surface [degC]. + real, intent(in) :: S !< salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + + ! Local variables + real :: num_STP ! State dependent part of the numerator of the rational expresion + ! for density (not specific volume) [kg m-3] + real :: den_STP ! State dependent part of the denominator of the rational expresion + ! for density (not specific volume) [nondim] + real :: I_num ! The inverse of the numerator of the rational expresion for density [nondim] + real :: T2 ! Temperature squared [degC2] + real :: S1_2 ! Limited square root of salinity [PSU1/2] + + S1_2 = sqrt(max(0.0,s)) + T2 = T*T + + num_STP = (T*(RN010 + T*(RN020 + T*RN030)) + & + S*(RN100 + (T*RN110 + S*RN200)) ) + & + pressure*(RN001 + ((T2*RN021 + S*RN101) + pressure*(RN002 + T2*RN022))) + den_STP = (T*(RD010 + T*(RD020 + T*(RD030 + T* RD040))) + & + S*(RD100 + (T*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pressure*(RD001 + pressure*T*(T2*RD032 + pressure*RD013)) + I_num = 1.0 / (RN000 + num_STP) + + ! This form is slightly more complicated, but it cancels the leading terms better. + spec_vol_anomaly_elem_Jackett06 = ((1.0 - spv_ref*RN000) + (den_STP - spv_ref*num_STP)) * I_num + +end function spec_vol_anomaly_elem_Jackett06 + +!> Calculate the partial derivatives of density with potential temperature and salinity +!! using Jackett et al., 2006 +elemental subroutine calculate_density_derivs_elem_Jackett06(this, T, S, pressure, drho_dT, drho_dS) + class(Jackett06_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1] + real, intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 PSU-1] + ! Local variables + real :: num ! Numerator of the rational expresion for density [kg m-3] + real :: den ! Denominator of the rational expresion for density [nondim] + real :: I_denom2 ! The inverse of the square of the denominator of the rational expression + ! for density [nondim] + real :: dnum_dT ! The derivative of num with potential temperature [kg m-3 degC-1] + real :: dnum_dS ! The derivative of num with salinity [kg m-3 PSU-1] + real :: dden_dT ! The derivative of den with potential temperature [degC-1] + real :: dden_dS ! The derivative of den with salinity PSU-1] + real :: T2 ! Temperature squared [degC2] + real :: S1_2 ! Limited square root of salinity [PSU1/2] + + S1_2 = sqrt(max(0.0,s)) + T2 = T*T + + num = RN000 + ((T*(RN010 + T*(RN020 + T*RN030)) + & + S*(RN100 + (T*RN110 + S*RN200)) ) + & + pressure*(RN001 + ((T2*RN021 + S*RN101) + pressure*(RN002 + T2*RN022))) ) + den = 1.0 + ((T*(RD010 + T*(RD020 + T*(RD030 + T* RD040))) + & + S*(RD100 + (T*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pressure*(RD001 + pressure*T*(T2*RD032 + pressure*RD013)) ) + + dnum_dT = ((RN010 + T*(2.*RN020 + T*(3.*RN030))) + S*RN110) + & + pressure*T*(2.*RN021 + pressure*(2.*RN022)) + dnum_dS = (RN100 + (T*RN110 + S*(2.*RN200))) + pressure*RN101 + dden_dT = ((RD010 + T*((2.*RD020) + T*((3.*RD030) + T*(4.*RD040)))) + & + S*((RD110 + T2*(3.*RD130)) + S1_2*T*(2.*RD620)) ) + & + pressure**2*(T2*3.*RD032 + pressure*RD013) + dden_dS = RD100 + (T*(RD110 + T2*RD130) + S1_2*(1.5*RD600 + T2*(1.5*RD620))) + I_denom2 = 1.0 / den**2 + + ! rho = num / den + drho_dT = (dnum_dT * den - num * dden_dT) * I_denom2 + drho_dS = (dnum_dS * den - num * dden_dS) * I_denom2 + +end subroutine calculate_density_derivs_elem_Jackett06 + +!> Calculate second derivatives of density with respect to temperature, salinity, and pressure, +!! using Jackett et al., 2006 +elemental subroutine calculate_density_second_derivs_elem_Jackett06(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + class(Jackett06_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature referenced to 0 dbar [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, intent(inout) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, intent(inout) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + + ! Local variables + real :: num ! Numerator of the rational expresion for density [kg m-3] + real :: den ! Denominator of the rational expresion for density [nondim] + real :: I_num2 ! The inverse of the square of the numerator of the rational expression + ! for density [nondim] + real :: dnum_dT ! The derivative of num with potential temperature [kg m-3 degC-1] + real :: dnum_dS ! The derivative of num with salinity [kg m-3 PSU-1] + real :: dden_dT ! The derivative of den with potential temperature [degC-1] + real :: dden_dS ! The derivative of den with salinity PSU-1] + real :: dnum_dp ! The derivative of num with pressure [kg m-3 dbar-1] + real :: dden_dp ! The derivative of det with pressure [dbar-1] + real :: d2num_dT2 ! The second derivative of num with potential temperature [kg m-3 degC-2] + real :: d2num_dT_dS ! The second derivative of num with potential temperature and + ! salinity [kg m-3 degC-1 PSU-1] + real :: d2num_dS2 ! The second derivative of num with salinity [kg m-3 PSU-2] + real :: d2num_dT_dp ! The second derivative of num with potential temperature and + ! pressure [kg m-3 degC-1 dbar-1] + real :: d2num_dS_dp ! The second derivative of num with salinity and + ! pressure [kg m-3 PSU-1 dbar-1] + real :: d2den_dT2 ! The second derivative of den with potential temperature [degC-2] + real :: d2den_dT_dS ! The second derivative of den with potential temperature and salinity [degC-1 PSU-1] + real :: d2den_dS2 ! The second derivative of den with salinity [PSU-2] + real :: d2den_dT_dp ! The second derivative of den with potential temperature and pressure [degC-1 dbar-1] + real :: d2den_dS_dp ! The second derivative of den with salinity and pressure [PSU-1 dbar-1] + real :: T2 ! Temperature squared [degC2] + real :: S1_2 ! Limited square root of salinity [PSU1/2] + real :: I_s12 ! The inverse of the square root of salinity [PSU-1/2] + real :: I_denom2 ! The inverse of the square of the denominator of the rational expression + ! for density [nondim] + real :: I_denom3 ! The inverse of the cube of the denominator of the rational expression + ! for density [nondim] + + S1_2 = sqrt(max(0.0,s)) + T2 = T*T + + num = RN000 + ((T*(RN010 + T*(RN020 + T*RN030)) + & + S*(RN100 + (T*RN110 + S*RN200)) ) + & + pressure*(RN001 + ((T2*RN021 + S*RN101) + pressure*(RN002 + T2*RN022))) ) + den = 1.0 + ((T*(RD010 + T*(RD020 + T*(RD030 + T* RD040))) + & + S*(RD100 + (T*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pressure*(RD001 + pressure*T*(T2*RD032 + pressure*RD013)) ) + ! rho = num*I_den + + dnum_dT = ((RN010 + T*(2.*RN020 + T*(3.*RN030))) + S*RN110) + & + pressure*T*(2.*RN021 + pressure*(2.*RN022)) + dnum_dS = (RN100 + (T*RN110 + S*(2.*RN200))) + pressure*RN101 + dnum_dp = RN001 + ((T2*RN021 + S*RN101) + pressure*(2.*RN002 + T2*(2.*RN022))) + d2num_dT2 = 2.*RN020 + T*(6.*RN030) + pressure*(2.*RN021 + pressure*(2.*RN022)) + d2num_dT_dS = RN110 + d2num_dS2 = 2.*RN200 + d2num_dT_dp = T*(2.*RN021 + pressure*(4.*RN022)) + d2num_dS_dp = RN101 + + dden_dT = ((RD010 + T*((2.*RD020) + T*((3.*RD030) + T*(4.*RD040)))) + & + S*((RD110 + T2*(3.*RD130)) + S1_2*T*(2.*RD620)) ) + & + pressure**2*(T2*3.*RD032 + pressure*RD013) + dden_dS = RD100 + (T*(RD110 + T2*RD130) + S1_2*(1.5*RD600 + T2*(1.5*RD620))) + dden_dp = RD001 + pressure*T*(T2*(2.*RD032) + pressure*(3.*RD013)) + + d2den_dT2 = (((2.*RD020) + T*((6.*RD030) + T*(12.*RD040))) + & + S*(T*(6.*RD130) + S1_2*(2.*RD620)) ) + pressure**2*(T*(6.*RD032)) + d2den_dT_dS = (RD110 + T2*3.*RD130) + (T*S1_2)*(3.0*RD620) + d2den_dT_dp = pressure*(T2*(6.*RD032) + pressure*(3.*RD013)) + d2den_dS_dp = 0.0 + + ! The Jackett et al. 2006 equation of state is a fit to density, but it chooses a form that + ! exhibits a singularity in the second derivatives with salinity for fresh water. To avoid + ! this, the square root of salinity can be treated with a floor such that the contribution from + ! the S**1.5 terms to both the surface density and the secant bulk modulus are lost to roundoff. + ! This salinity is given by (~1e-16/RD600)**(2/3) ~= 7e-8 PSU, or S1_2 ~= 2.6e-4 + I_S12 = 1.0 / (max(S1_2, 1.0e-4)) + d2den_dS2 = (0.75*RD600 + T2*(0.75*RD620)) * I_S12 + + I_denom3 = 1.0 / den**3 + + ! In deriving the following, it is useful to note that: + ! drho_dp = (dnum_dp * den - num * dden_dp) / den**2 + ! drho_dT = (dnum_dT * den - num * dden_dT) / den**2 + ! drho_dS = (dnum_dS * den - num * dden_dS) / den**2 + drho_dS_dS = (den*(den*d2num_dS2 - 2.*dnum_dS*dden_dS) + num*(2.*dden_dS**2 - den*d2den_dS2)) * I_denom3 + drho_dS_dt = (den*(den*d2num_dT_dS - (dnum_dT*dden_dS + dnum_dS*dden_dT)) + & + num*(2.*dden_dT*dden_dS - den*d2den_dT_dS)) * I_denom3 + drho_dT_dT = (den*(den*d2num_dT2 - 2.*dnum_dT*dden_dT) + num*(2.*dden_dT**2 - den*d2den_dT2)) * I_denom3 + + drho_dS_dp = (den*(den*d2num_dS_dp - (dnum_dp*dden_dS + dnum_dS*dden_dp)) + & + num*(2.*dden_dS*dden_dp - den*d2den_dS_dp)) * I_denom3 + drho_dT_dp = (den*(den*d2num_dT_dp - (dnum_dp*dden_dT + dnum_dT*dden_dp)) + & + num*(2.*dden_dT*dden_dp - den*d2den_dT_dp)) * I_denom3 + +end subroutine calculate_density_second_derivs_elem_Jackett06 + +!> Calculate second derivatives of density with respect to temperature, salinity, and pressure, +!! using Jackett et al., 2006 +elemental subroutine calculate_specvol_derivs_elem_Jackett06(this, T, S, pressure, dSV_dT, dSV_dS) + class(Jackett06_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1] + + ! Local variables + real :: num ! Numerator of the rational expresion for density (not specific volume) [kg m-3] + real :: den ! Denominator of the rational expresion for density (not specific volume) [nondim] + real :: I_num2 ! The inverse of the square of the numerator of the rational expression + ! for density [nondim] + real :: dnum_dT ! The derivative of num with potential temperature [kg m-3 degC-1] + real :: dnum_dS ! The derivative of num with salinity [kg m-3 PSU-1] + real :: dden_dT ! The derivative of den with potential temperature [degC-1] + real :: dden_dS ! The derivative of den with salinity PSU-1] + real :: T2 ! Temperature squared [degC2] + real :: S1_2 ! Limited square root of salinity [PSU1/2] + + S1_2 = sqrt(max(0.0,s)) + T2 = T*T + + num = RN000 + ((T*(RN010 + T*(RN020 + T*RN030)) + & + S*(RN100 + (T*RN110 + S*RN200)) ) + & + pressure*(RN001 + ((T2*RN021 + S*RN101) + pressure*(RN002 + T2*RN022))) ) + den = 1.0 + ((T*(RD010 + T*(RD020 + T*(RD030 + T* RD040))) + & + S*(RD100 + (T*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pressure*(RD001 + pressure*T*(T2*RD032 + pressure*RD013)) ) + + dnum_dT = ((RN010 + T*(2.*RN020 + T*(3.*RN030))) + S*RN110) + & + pressure*T*(2.*RN021 + pressure*(2.*RN022)) + dnum_dS = (RN100 + (T*RN110 + S*(2.*RN200))) + pressure*RN101 + dden_dT = ((RD010 + T*((2.*RD020) + T*((3.*RD030) + T*(4.*RD040)))) + & + S*((RD110 + T2*(3.*RD130)) + S1_2*T*(2.*RD620)) ) + & + pressure**2*(T2*3.*RD032 + pressure*RD013) + dden_dS = RD100 + (T*(RD110 + T2*RD130) + S1_2*(1.5*RD600 + T2*(1.5*RD620))) + I_num2 = 1.0 / num**2 + + ! SV = den / num + dSV_dT = (num * dden_dT - dnum_dT * den) * I_num2 + dSV_dS = (num * dden_dS - dnum_dS * den) * I_num2 + +end subroutine calculate_specvol_derivs_elem_Jackett06 + +!> Compute the in situ density of sea water (rho) and the compressibility (drho/dp == C_sound^-2) +!! at the given salinity, potential temperature and pressure using Jackett et al., 2006 +elemental subroutine calculate_compress_elem_Jackett06(this, T, S, pressure, rho, drho_dp) + class(Jackett06_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: rho !< In situ density [kg m-3] + real, intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [s2 m-2] + ! Local variables + real :: num ! Numerator of the rational expresion for density [kg m-3] + real :: den ! Denominator of the rational expresion for density [nondim] + real :: I_den ! The inverse of the denominator of the rational expression for density [nondim] + real :: dnum_dp ! The derivative of num with pressure [kg m-3 dbar-1] + real :: dden_dp ! The derivative of den with pressure [dbar-1] + real :: T2 ! Temperature squared [degC2] + real :: S1_2 ! Limited square root of salinity [PSU1/2] + integer :: j + + S1_2 = sqrt(max(0.0,s)) + T2 = T*T + + num = RN000 + ((T*(RN010 + T*(RN020 + T*RN030)) + & + S*(RN100 + (T*RN110 + S*RN200)) ) + & + pressure*(RN001 + ((T2*RN021 + S*RN101) + pressure*(RN002 + T2*RN022))) ) + den = 1.0 + ((T*(RD010 + T*(RD020 + T*(RD030 + T* RD040))) + & + S*(RD100 + (T*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pressure*(RD001 + pressure*T*(T2*RD032 + pressure*RD013)) ) + dnum_dp = RN001 + ((T2*RN021 + S*RN101) + pressure*(2.*RN002 + T2*(2.*RN022))) + dden_dp = RD001 + pressure*T*(T2*(2.*RD032) + pressure*(3.*RD013)) + + I_den = 1.0 / den + rho = num * I_den + drho_dp = (dnum_dp * den - num * dden_dp) * I_den**2 + +end subroutine calculate_compress_elem_Jackett06 + +!> Return the range of temperatures, salinities and pressures for which the Jackett et al. (2006) +!! equation of state has been fitted to observations. Care should be taken when applying this +!! equation of state outside of its fit range. +subroutine EoS_fit_range_Jackett06(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(Jackett06_EOS), intent(in) :: this !< This EOS + real, optional, intent(out) :: T_min !< The minimum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: S_max !< The maximum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + ! Note that the actual fit range is given for the surface range of temperatures and salinities, + ! but Jackett et al. use a more limited range of properties at higher pressures. + if (present(T_min)) T_min = -4.5 + if (present(T_max)) T_max = 40.0 + if (present(S_min)) S_min = 0.0 + if (present(S_max)) S_max = 42.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 8.5e7 + +end subroutine EoS_fit_range_Jackett06 + + +!> \namespace mom_eos_Jackett06 +!! +!! \section section_EOS_Jackett06 Jackett et al. 2006 (Hycom-25-term) equation of state +!! +!! Jackett et al. (2006) provide an approximation for the in situ density as a function of +!! potential temperature, salinity, and pressure. This 25 term equation of state is +!! frequently used in Hycom for a potential density, at which point it only has 17 terms +!! and so is commonly called the "17-term equation of state" there. Here the full expressions +!! for the in situ densities are used. +!! +!! The functional form of this equation of state includes terms proportional to salinity to the +!! 3/2 power. This introduces a singularity in the second derivative of density with salinity +!! at a salinity of 0, but this has been addressed here by setting a floor of 1e-8 PSU on the +!! salinity that is used in the denominator of these second derivative expressions. This value +!! was chosen to imply a contribution that is smaller than numerical roundoff in the expression for +!! density, which is the field for which the Jackett et al. equation of state was originally derived. +!! +!! \subsection section_EOS_Jackett06_references References +!! +!! Jackett, D., T. McDougall, R. Feistel, D. Wright and S. Griffies (2006), +!! Algorithms for density, potential temperature, conservative +!! temperature, and the freezing temperature of seawater, JAOT +!! doi.org/10.1175/JTECH1946.1 + +end module MOM_EOS_Jackett06 diff --git a/src/equation_of_state/MOM_EOS_NEMO.F90 b/src/equation_of_state/MOM_EOS_NEMO.F90 deleted file mode 100644 index 68488881bb..0000000000 --- a/src/equation_of_state/MOM_EOS_NEMO.F90 +++ /dev/null @@ -1,397 +0,0 @@ -!> The equation of state using the expressions of Roquet et al. that are used in NEMO -module MOM_EOS_NEMO - -! This file is part of MOM6. See LICENSE.md for the license. - -!*********************************************************************** -!* The subroutines in this file implement the equation of state for * -!* sea water using the formulae provided by NEMO developer Roquet * -!* in a private communication , Roquet et al, Ocean Modelling (2015) * -!* Roquet, F., Madec, G., McDougall, T. J., and Barker, P. M., 2015. * -!* Accurate polynomial expressions for the density and specific volume* -!* of seawater using the TEOS-10 standard. Ocean Modelling, 90:29-43. * -!* These algorithms are NOT from the standard NEMO package!! * -!*********************************************************************** - -!use gsw_mod_toolbox, only : gsw_sr_from_sp, gsw_ct_from_pt -use gsw_mod_toolbox, only : gsw_rho_first_derivatives - -implicit none ; private - -public calculate_compress_nemo, calculate_density_nemo -public calculate_density_derivs_nemo -public calculate_density_scalar_nemo, calculate_density_array_nemo - -!> Compute the in situ density of sea water ([kg m-3]), or its anomaly with respect to -!! a reference density, from absolute salinity (g/kg), conservative temperature (in deg C), -!! and pressure [Pa], using the expressions derived for use with NEMO -interface calculate_density_nemo - module procedure calculate_density_scalar_nemo, calculate_density_array_nemo -end interface calculate_density_nemo - -!> For a given thermodynamic state, return the derivatives of density with conservative temperature -!! and absolute salinity, the expressions derived for use with NEMO -interface calculate_density_derivs_nemo - module procedure calculate_density_derivs_scalar_nemo, calculate_density_derivs_array_nemo -end interface calculate_density_derivs_nemo - -real, parameter :: Pa2db = 1.e-4 !< Conversion factor between Pa and dbar -!>@{ Parameters in the NEMO equation of state -real, parameter :: rdeltaS = 32. -real, parameter :: r1_S0 = 0.875/35.16504 -real, parameter :: r1_T0 = 1./40. -real, parameter :: r1_P0 = 1.e-4 -real, parameter :: R00 = 4.6494977072e+01 -real, parameter :: R01 = -5.2099962525 -real, parameter :: R02 = 2.2601900708e-01 -real, parameter :: R03 = 6.4326772569e-02 -real, parameter :: R04 = 1.5616995503e-02 -real, parameter :: R05 = -1.7243708991e-03 -real, parameter :: EOS000 = 8.0189615746e+02 -real, parameter :: EOS100 = 8.6672408165e+02 -real, parameter :: EOS200 = -1.7864682637e+03 -real, parameter :: EOS300 = 2.0375295546e+03 -real, parameter :: EOS400 = -1.2849161071e+03 -real, parameter :: EOS500 = 4.3227585684e+02 -real, parameter :: EOS600 = -6.0579916612e+01 -real, parameter :: EOS010 = 2.6010145068e+01 -real, parameter :: EOS110 = -6.5281885265e+01 -real, parameter :: EOS210 = 8.1770425108e+01 -real, parameter :: EOS310 = -5.6888046321e+01 -real, parameter :: EOS410 = 1.7681814114e+01 -real, parameter :: EOS510 = -1.9193502195 -real, parameter :: EOS020 = -3.7074170417e+01 -real, parameter :: EOS120 = 6.1548258127e+01 -real, parameter :: EOS220 = -6.0362551501e+01 -real, parameter :: EOS320 = 2.9130021253e+01 -real, parameter :: EOS420 = -5.4723692739 -real, parameter :: EOS030 = 2.1661789529e+01 -real, parameter :: EOS130 = -3.3449108469e+01 -real, parameter :: EOS230 = 1.9717078466e+01 -real, parameter :: EOS330 = -3.1742946532 -real, parameter :: EOS040 = -8.3627885467 -real, parameter :: EOS140 = 1.1311538584e+01 -real, parameter :: EOS240 = -5.3563304045 -real, parameter :: EOS050 = 5.4048723791e-01 -real, parameter :: EOS150 = 4.8169980163e-01 -real, parameter :: EOS060 = -1.9083568888e-01 -real, parameter :: EOS001 = 1.9681925209e+01 -real, parameter :: EOS101 = -4.2549998214e+01 -real, parameter :: EOS201 = 5.0774768218e+01 -real, parameter :: EOS301 = -3.0938076334e+01 -real, parameter :: EOS401 = 6.6051753097 -real, parameter :: EOS011 = -1.3336301113e+01 -real, parameter :: EOS111 = -4.4870114575 -real, parameter :: EOS211 = 5.0042598061 -real, parameter :: EOS311 = -6.5399043664e-01 -real, parameter :: EOS021 = 6.7080479603 -real, parameter :: EOS121 = 3.5063081279 -real, parameter :: EOS221 = -1.8795372996 -real, parameter :: EOS031 = -2.4649669534 -real, parameter :: EOS131 = -5.5077101279e-01 -real, parameter :: EOS041 = 5.5927935970e-01 -real, parameter :: EOS002 = 2.0660924175 -real, parameter :: EOS102 = -4.9527603989 -real, parameter :: EOS202 = 2.5019633244 -real, parameter :: EOS012 = 2.0564311499 -real, parameter :: EOS112 = -2.1311365518e-01 -real, parameter :: EOS022 = -1.2419983026 -real, parameter :: EOS003 = -2.3342758797e-02 -real, parameter :: EOS103 = -1.8507636718e-02 -real, parameter :: EOS013 = 3.7969820455e-01 -real, parameter :: ALP000 = -6.5025362670e-01 -real, parameter :: ALP100 = 1.6320471316 -real, parameter :: ALP200 = -2.0442606277 -real, parameter :: ALP300 = 1.4222011580 -real, parameter :: ALP400 = -4.4204535284e-01 -real, parameter :: ALP500 = 4.7983755487e-02 -real, parameter :: ALP010 = 1.8537085209 -real, parameter :: ALP110 = -3.0774129064 -real, parameter :: ALP210 = 3.0181275751 -real, parameter :: ALP310 = -1.4565010626 -real, parameter :: ALP410 = 2.7361846370e-01 -real, parameter :: ALP020 = -1.6246342147 -real, parameter :: ALP120 = 2.5086831352 -real, parameter :: ALP220 = -1.4787808849 -real, parameter :: ALP320 = 2.3807209899e-01 -real, parameter :: ALP030 = 8.3627885467e-01 -real, parameter :: ALP130 = -1.1311538584 -real, parameter :: ALP230 = 5.3563304045e-01 -real, parameter :: ALP040 = -6.7560904739e-02 -real, parameter :: ALP140 = -6.0212475204e-02 -real, parameter :: ALP050 = 2.8625353333e-02 -real, parameter :: ALP001 = 3.3340752782e-01 -real, parameter :: ALP101 = 1.1217528644e-01 -real, parameter :: ALP201 = -1.2510649515e-01 -real, parameter :: ALP301 = 1.6349760916e-02 -real, parameter :: ALP011 = -3.3540239802e-01 -real, parameter :: ALP111 = -1.7531540640e-01 -real, parameter :: ALP211 = 9.3976864981e-02 -real, parameter :: ALP021 = 1.8487252150e-01 -real, parameter :: ALP121 = 4.1307825959e-02 -real, parameter :: ALP031 = -5.5927935970e-02 -real, parameter :: ALP002 = -5.1410778748e-02 -real, parameter :: ALP102 = 5.3278413794e-03 -real, parameter :: ALP012 = 6.2099915132e-02 -real, parameter :: ALP003 = -9.4924551138e-03 -real, parameter :: BET000 = 1.0783203594e+01 -real, parameter :: BET100 = -4.4452095908e+01 -real, parameter :: BET200 = 7.6048755820e+01 -real, parameter :: BET300 = -6.3944280668e+01 -real, parameter :: BET400 = 2.6890441098e+01 -real, parameter :: BET500 = -4.5221697773 -real, parameter :: BET010 = -8.1219372432e-01 -real, parameter :: BET110 = 2.0346663041 -real, parameter :: BET210 = -2.1232895170 -real, parameter :: BET310 = 8.7994140485e-01 -real, parameter :: BET410 = -1.1939638360e-01 -real, parameter :: BET020 = 7.6574242289e-01 -real, parameter :: BET120 = -1.5019813020 -real, parameter :: BET220 = 1.0872489522 -real, parameter :: BET320 = -2.7233429080e-01 -real, parameter :: BET030 = -4.1615152308e-01 -real, parameter :: BET130 = 4.9061350869e-01 -real, parameter :: BET230 = -1.1847737788e-01 -real, parameter :: BET040 = 1.4073062708e-01 -real, parameter :: BET140 = -1.3327978879e-01 -real, parameter :: BET050 = 5.9929880134e-03 -real, parameter :: BET001 = -5.2937873009e-01 -real, parameter :: BET101 = 1.2634116779 -real, parameter :: BET201 = -1.1547328025 -real, parameter :: BET301 = 3.2870876279e-01 -real, parameter :: BET011 = -5.5824407214e-02 -real, parameter :: BET111 = 1.2451933313e-01 -real, parameter :: BET211 = -2.4409539932e-02 -real, parameter :: BET021 = 4.3623149752e-02 -real, parameter :: BET121 = -4.6767901790e-02 -real, parameter :: BET031 = -6.8523260060e-03 -real, parameter :: BET002 = -6.1618945251e-02 -real, parameter :: BET102 = 6.2255521644e-02 -real, parameter :: BET012 = -2.6514181169e-03 -real, parameter :: BET003 = -2.3025968587e-04 -!>@} - -contains - -!> This subroutine computes the in situ density of sea water (rho in -!! [kg m-3]) from absolute salinity (S [g kg-1]), conservative temperature -!! (T [degC]), and pressure [Pa]. It uses the expressions derived for use -!! with NEMO. -subroutine calculate_density_scalar_nemo(T, S, pressure, rho, rho_ref) - real, intent(in) :: T !< Conservative temperature [degC]. - real, intent(in) :: S !< Absolute salinity [g kg-1]. - real, intent(in) :: pressure !< pressure [Pa]. - real, intent(out) :: rho !< In situ density [kg m-3]. - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. - - real :: al0, p0, lambda - integer :: j - real, dimension(1) :: T0, S0, pressure0 - real, dimension(1) :: rho0 - - T0(1) = T - S0(1) = S - pressure0(1) = pressure - - call calculate_density_array_nemo(T0, S0, pressure0, rho0, 1, 1, rho_ref) - rho = rho0(1) - -end subroutine calculate_density_scalar_nemo - -!> This subroutine computes the in situ density of sea water (rho in -!! [kg m-3]) from absolute salinity (S [g kg-1]), conservative temperature -!! (T [degC]), and pressure [Pa]. It uses the expressions derived for use -!! with NEMO. -subroutine calculate_density_array_nemo(T, S, pressure, rho, start, npts, rho_ref) - real, dimension(:), intent(in) :: T !< Conservative temperature [degC]. - real, dimension(:), intent(in) :: S !< Absolute salinity [g kg-1]. - real, dimension(:), intent(in) :: pressure !< pressure [Pa]. - real, dimension(:), intent(out) :: rho !< in situ density [kg m-3]. - integer, intent(in) :: start !< the starting point in the arrays. - integer, intent(in) :: npts !< the number of values to calculate. - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. - - ! Local variables - real :: zp, zt, zh, zs, zr0, zn, zn0, zn1, zn2, zn3, zs0 - integer :: j - - do j=start,start+npts-1 - !Conversions - zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity - zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potential temp to conservative temp - zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar - - !The following algorithm was provided by Roquet in a private communication. - !It is not necessarily the algorithm used in NEMO ocean! - zp = zp * r1_P0 !pressure - zt = zt * r1_T0 !temperature - zs = SQRT( ABS( zs + rdeltaS ) * r1_S0 ) ! square root salinity - - zn3 = EOS013*zt & - & + EOS103*zs+EOS003 - - zn2 = (EOS022*zt & - & + EOS112*zs+EOS012)*zt & - & + (EOS202*zs+EOS102)*zs+EOS002 - - zn1 = (((EOS041*zt & - & + EOS131*zs+EOS031)*zt & - & + (EOS221*zs+EOS121)*zs+EOS021)*zt & - & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & - & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 - - zn0 = (((((EOS060*zt & - & + EOS150*zs+EOS050)*zt & - & + (EOS240*zs+EOS140)*zs+EOS040)*zt & - & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & - & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & - & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt - - zs0 = (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs + EOS000 - - zr0 = (((((R05 * zp+R04) * zp+R03 ) * zp+R02 ) * zp+R01) * zp+R00) * zp - - if (present(rho_ref)) then - zn = ( ( zn3 * zp + zn2 ) * zp + zn1 ) * zp + (zn0 + (zs0 - rho_ref)) - rho(j) = ( zn + zr0 ) ! density - else - zn = ( ( zn3 * zp + zn2 ) * zp + zn1 ) * zp + (zn0 + zs0) - rho(j) = ( zn + zr0 ) ! density - endif - - enddo -end subroutine calculate_density_array_nemo - -!> For a given thermodynamic state, calculate the derivatives of density with conservative -!! temperature and absolute salinity, using the expressions derived for use with NEMO. -subroutine calculate_density_derivs_array_nemo(T, S, pressure, drho_dT, drho_dS, start, npts) - real, intent(in), dimension(:) :: T !< Conservative temperature [degC]. - real, intent(in), dimension(:) :: S !< Absolute salinity [g kg-1]. - real, intent(in), dimension(:) :: pressure !< pressure [Pa]. - real, intent(out), dimension(:) :: drho_dT !< The partial derivative of density with potential - !! temperature [kg m-3 degC-1]. - real, intent(out), dimension(:) :: drho_dS !< The partial derivative of density with salinity, - !! in [kg m-3 ppt-1]. - integer, intent(in) :: start !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. - - ! Local variables - real :: zp,zt , zh , zs , zr0, zn , zn0, zn1, zn2, zn3 - integer :: j - - do j=start,start+npts-1 - !Conversions - zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity - zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potantial temp to conservative temp - zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar - - !The following algorithm was provided by Roquet in a private communication. - !It is not necessarily the algorithm used in NEMO ocean! - zp = zp * r1_P0 ! pressure (first converted to decibar) - zt = zt * r1_T0 ! temperature - zs = SQRT( ABS( zs + rdeltaS ) * r1_S0 ) ! square root salinity - ! - ! alpha - zn3 = ALP003 - ! - zn2 = ALP012*zt + ALP102*zs+ALP002 - ! - zn1 = ((ALP031*zt & - & + ALP121*zs+ALP021)*zt & - & + (ALP211*zs+ALP111)*zs+ALP011)*zt & - & + ((ALP301*zs+ALP201)*zs+ALP101)*zs+ALP001 - ! - zn0 = ((((ALP050*zt & - & + ALP140*zs+ALP040)*zt & - & + (ALP230*zs+ALP130)*zs+ALP030)*zt & - & + ((ALP320*zs+ALP220)*zs+ALP120)*zs+ALP020)*zt & - & + (((ALP410*zs+ALP310)*zs+ALP210)*zs+ALP110)*zs+ALP010)*zt & - & + ((((ALP500*zs+ALP400)*zs+ALP300)*zs+ALP200)*zs+ALP100)*zs+ALP000 - ! - zn = ( ( zn3 * zp + zn2 ) * zp + zn1 ) * zp + zn0 - ! - drho_dT(j) = -zn - ! - ! beta - ! - zn3 = BET003 - ! - zn2 = BET012*zt + BET102*zs+BET002 - ! - zn1 = ((BET031*zt & - & + BET121*zs+BET021)*zt & - & + (BET211*zs+BET111)*zs+BET011)*zt & - & + ((BET301*zs+BET201)*zs+BET101)*zs+BET001 - ! - zn0 = ((((BET050*zt & - & + BET140*zs+BET040)*zt & - & + (BET230*zs+BET130)*zs+BET030)*zt & - & + ((BET320*zs+BET220)*zs+BET120)*zs+BET020)*zt & - & + (((BET410*zs+BET310)*zs+BET210)*zs+BET110)*zs+BET010)*zt & - & + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 - ! - zn = ( ( zn3 * zp + zn2 ) * zp + zn1 ) * zp + zn0 - ! - drho_dS(j) = zn / zs - enddo - -end subroutine calculate_density_derivs_array_nemo - -!> Wrapper to calculate_density_derivs_array for scalar inputs -subroutine calculate_density_derivs_scalar_nemo(T, S, pressure, drho_dt, drho_ds) - real, intent(in) :: T !< Potential temperature relative to the surface [degC]. - real, intent(in) :: S !< Salinity [g kg-1]. - real, intent(in) :: pressure !< Pressure [Pa]. - real, intent(out) :: drho_dT !< The partial derivative of density with potential - !! temperature [kg m-3 degC-1]. - real, intent(out) :: drho_dS !< The partial derivative of density with salinity, - !! in [kg m-3 ppt-1]. - ! Local variables - real :: al0, p0, lambda - integer :: j - real, dimension(1) :: T0, S0, pressure0 - real, dimension(1) :: drdt0, drds0 - - T0(1) = T - S0(1) = S - pressure0(1) = pressure - - call calculate_density_derivs_array_nemo(T0, S0, pressure0, drdt0, drds0, 1, 1) - drho_dt = drdt0(1) - drho_ds = drds0(1) -end subroutine calculate_density_derivs_scalar_nemo - -!> Compute the in situ density of sea water (rho in [kg m-3]) and the compressibility -!! (drho/dp = C_sound^-2, stored as drho_dp [s2 m-2]) from absolute salinity -!! (sal in g/kg), conservative temperature (T [degC]), and pressure [Pa], using the expressions -!! derived for use with NEMO. -subroutine calculate_compress_nemo(T, S, pressure, rho, drho_dp, start, npts) - real, intent(in), dimension(:) :: T !< Conservative temperature [degC]. - real, intent(in), dimension(:) :: S !< Absolute salinity [g/kg]. - real, intent(in), dimension(:) :: pressure !< pressure [Pa]. - real, intent(out), dimension(:) :: rho !< In situ density [kg m-3]. - real, intent(out), dimension(:) :: drho_dp !< The partial derivative of density with pressure - !! (also the inverse of the square of sound speed) - !! [s2 m-2]. - integer, intent(in) :: start !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. - - ! Local variables - real :: zs,zt,zp - integer :: j - - call calculate_density_array_nemo(T, S, pressure, rho, start, npts) - ! - !NOTE: The following calculates the TEOS10 approximation to compressibility - ! since the corresponding NEMO approximation is not available yet. - ! - do j=start,start+npts-1 - !Conversions - zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity - zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potantial temp to conservative temp - zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar - call gsw_rho_first_derivatives(zs,zt,zp, drho_dp=drho_dp(j)) - enddo -end subroutine calculate_compress_nemo - -end module MOM_EOS_NEMO diff --git a/src/equation_of_state/MOM_EOS_Roquet_SpV.F90 b/src/equation_of_state/MOM_EOS_Roquet_SpV.F90 new file mode 100644 index 0000000000..852f62fb73 --- /dev/null +++ b/src/equation_of_state/MOM_EOS_Roquet_SpV.F90 @@ -0,0 +1,776 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> The equation of state for specific volume (SpV) using the expressions of Roquet et al. 2015 +module MOM_EOS_Roquet_Spv + +use MOM_EOS_base_type, only : EOS_base + +implicit none ; private + +public Roquet_SpV_EOS + +real, parameter :: Pa2kb = 1.e-8 !< Conversion factor between Pa and kbar [kbar Pa-1] +!>@{ Parameters in the Roquet specific volume polynomial equation of state +real, parameter :: rdeltaS = 24. ! An offset to salinity before taking its square root [g kg-1] +real, parameter :: r1_S0 = 0.875/35.16504 ! The inverse of a plausible range of oceanic salinities [kg g-1] +real, parameter :: I_Ts = 0.025 ! The inverse of a plausible range of oceanic temperatures [degC-1] +! The following are the coefficients of the fit to the reference density profile (rho00p) as a function of +! pressure (P), with a contribution R0c * P**(c+1). The nomenclature follows Roquet. +real, parameter :: V00 = -4.4015007269e-05*Pa2kb ! SpV00p P coef. [m3 kg-1 Pa-1] +real, parameter :: V01 = 6.9232335784e-06*Pa2kb**2 ! SpV00p P**2 coef. [m3 kg-1 Pa-2] +real, parameter :: V02 = -7.5004675975e-07*Pa2kb**3 ! SpV00p P**3 coef. [m3 kg-1 Pa-3] +real, parameter :: V03 = 1.7009109288e-08*Pa2kb**4 ! SpV00p P**4 coef. [m3 kg-1 Pa-4] +real, parameter :: V04 = -1.6884162004e-08*Pa2kb**5 ! SpV00p P**5 coef. [m3 kg-1 Pa-5] +real, parameter :: V05 = 1.9613503930e-09*Pa2kb**6 ! SpV00p P**6 coef. [m3 kg-1 Pa-6] + +! The following terms are contributions to specific volume (SpV) as a function of the square root of +! normalized absolute salinity with an offset (zs), temperature (T) and pressure (P), with a contribution +! SPVabc * zs**a * T**b * P**c. The numbers here are copied directly from Roquet et al. (2015), but +! the expressions here do not use the same nondimensionalization for pressure or temperature as they do. +real, parameter :: SPV000 = 1.0772899069e-03 ! Constant SpV contribution [m3 kg-1] +real, parameter :: SPV100 = -3.1263658781e-04 ! SpV zs coef. [m3 kg-1] +real, parameter :: SPV200 = 6.7615860683e-04 ! SpV zs**2 coef. [m3 kg-1] +real, parameter :: SPV300 = -8.6127884515e-04 ! SpV zs**3 coef. [m3 kg-1] +real, parameter :: SPV400 = 5.9010812596e-04 ! SpV zs**4 coef. [m3 kg-1] +real, parameter :: SPV500 = -2.1503943538e-04 ! SpV zs**5 coef. [m3 kg-1] +real, parameter :: SPV600 = 3.2678954455e-05 ! SpV zs**6 coef. [m3 kg-1] +real, parameter :: SPV010 = -1.4949652640e-05*I_Ts ! SpV T coef. [m3 kg-1 degC-1] +real, parameter :: SPV110 = 3.1866349188e-05*I_Ts ! SpV zs * T coef. [m3 kg-1 degC-1] +real, parameter :: SPV210 = -3.8070687610e-05*I_Ts ! SpV zs**2 * T coef. [m3 kg-1 degC-1] +real, parameter :: SPV310 = 2.9818473563e-05*I_Ts ! SpV zs**3 * T coef. [m3 kg-1 degC-1] +real, parameter :: SPV410 = -1.0011321965e-05*I_Ts ! SpV zs**4 * T coef. [m3 kg-1 degC-1] +real, parameter :: SPV510 = 1.0751931163e-06*I_Ts ! SpV zs**5 * T coef. [m3 kg-1 degC-1] +real, parameter :: SPV020 = 2.7546851539e-05*I_Ts**2 ! SpV T**2 coef. [m3 kg-1 degC-2] +real, parameter :: SPV120 = -3.6597334199e-05*I_Ts**2 ! SpV zs * T**2 coef. [m3 kg-1 degC-2] +real, parameter :: SPV220 = 3.4489154625e-05*I_Ts**2 ! SpV zs**2 * T**2 coef. [m3 kg-1 degC-2] +real, parameter :: SPV320 = -1.7663254122e-05*I_Ts**2 ! SpV zs**3 * T**2 coef. [m3 kg-1 degC-2] +real, parameter :: SPV420 = 3.5965131935e-06*I_Ts**2 ! SpV zs**4 * T**2 coef. [m3 kg-1 degC-2] +real, parameter :: SPV030 = -1.6506828994e-05*I_Ts**3 ! SpV T**3 coef. [m3 kg-1 degC-3] +real, parameter :: SPV130 = 2.4412359055e-05*I_Ts**3 ! SpV zs * T**3 coef. [m3 kg-1 degC-3] +real, parameter :: SPV230 = -1.4606740723e-05*I_Ts**3 ! SpV zs**2 * T**3 coef. [m3 kg-1 degC-3] +real, parameter :: SPV330 = 2.3293406656e-06*I_Ts**3 ! SpV zs**3 * T**3 coef. [m3 kg-1 degC-3] +real, parameter :: SPV040 = 6.7896174634e-06*I_Ts**4 ! SpV T**4 coef. [m3 kg-1 degC-4] +real, parameter :: SPV140 = -8.7951832993e-06*I_Ts**4 ! SpV zs * T**4 coef. [m3 kg-1 degC-4] +real, parameter :: SPV240 = 4.4249040774e-06*I_Ts**4 ! SpV zs**2 * T**4 coef. [m3 kg-1 degC-4] +real, parameter :: SPV050 = -7.2535743349e-07*I_Ts**5 ! SpV T**5 coef. [m3 kg-1 degC-5] +real, parameter :: SPV150 = -3.4680559205e-07*I_Ts**5 ! SpV zs * T**5 coef. [m3 kg-1 degC-5] +real, parameter :: SPV060 = 1.9041365570e-07*I_Ts**6 ! SpV T**6 coef. [m3 kg-1 degC-6] +real, parameter :: SPV001 = -1.6889436589e-05*Pa2kb ! SpV P coef. [m3 kg-1 Pa-1] +real, parameter :: SPV101 = 2.1106556158e-05*Pa2kb ! SpV zs * P coef. [m3 kg-1 Pa-1] +real, parameter :: SPV201 = -2.1322804368e-05*Pa2kb ! SpV zs**2 * P coef. [m3 kg-1 Pa-1] +real, parameter :: SPV301 = 1.7347655458e-05*Pa2kb ! SpV zs**3 * P coef. [m3 kg-1 Pa-1] +real, parameter :: SPV401 = -4.3209400767e-06*Pa2kb ! SpV zs**4 * P coef. [m3 kg-1 Pa-1] +real, parameter :: SPV011 = 1.5355844621e-05*(I_Ts*Pa2kb) ! SpV T * P coef. [m3 kg-1 degC-1 Pa-1] +real, parameter :: SPV111 = 2.0914122241e-06*(I_Ts*Pa2kb) ! SpV zs * T * P coef. [m3 kg-1 degC-1 Pa-1] +real, parameter :: SPV211 = -5.7751479725e-06*(I_Ts*Pa2kb) ! SpV zs**2 * T * P coef. [m3 kg-1 degC-1 Pa-1] +real, parameter :: SPV311 = 1.0767234341e-06*(I_Ts*Pa2kb) ! SpV zs**3 * T * P coef. [m3 kg-1 degC-1 Pa-1] +real, parameter :: SPV021 = -9.6659393016e-06*(I_Ts**2*Pa2kb) ! SpV T**2 * P coef. [m3 kg-1 degC-2 Pa-1] +real, parameter :: SPV121 = -7.0686982208e-07*(I_Ts**2*Pa2kb) ! SpV zs * T**2 * P coef. [m3 kg-1 degC-2 Pa-1] +real, parameter :: SPV221 = 1.4488066593e-06*(I_Ts**2*Pa2kb) ! SpV zs**2 * T**2 * P coef. [m3 kg-1 degC-2 Pa-1] +real, parameter :: SPV031 = 3.1134283336e-06*(I_Ts**3*Pa2kb) ! SpV T**3 * P coef. [m3 kg-1 degC-3 Pa-1] +real, parameter :: SPV131 = 7.9562529879e-08*(I_Ts**3*Pa2kb) ! SpV zs * T**3 * P coef. [m3 kg-1 degC-3 Pa-1] +real, parameter :: SPV041 = -5.6590253863e-07*(I_Ts**4*Pa2kb) ! SpV T**4 * P coef. [m3 kg-1 degC-4 Pa-1] +real, parameter :: SPV002 = 1.0500241168e-06*Pa2kb**2 ! SpV P**2 coef. [m3 kg-1 Pa-2] +real, parameter :: SPV102 = 1.9600661704e-06*Pa2kb**2 ! SpV zs * P**2 coef. [m3 kg-1 Pa-2] +real, parameter :: SPV202 = -2.1666693382e-06*Pa2kb**2 ! SpV zs**2 * P**2 coef. [m3 kg-1 Pa-2] +real, parameter :: SPV012 = -3.8541359685e-06*(I_Ts*Pa2kb**2) ! SpV T * P**2 coef. [m3 kg-1 degC-1 Pa-2] +real, parameter :: SPV112 = 1.0157632247e-06*(I_Ts*Pa2kb**2) ! SpV zs * T * P**2 coef. [m3 kg-1 degC-1 Pa-2] +real, parameter :: SPV022 = 1.7178343158e-06*(I_Ts**2*Pa2kb**2) ! SpV T**2 * P**2 coef. [m3 kg-1 degC-2 Pa-2] +real, parameter :: SPV003 = -4.1503454190e-07*Pa2kb**3 ! SpV P**3 coef. [m3 kg-1 Pa-3] +real, parameter :: SPV103 = 3.5627020989e-07*Pa2kb**3 ! SpV zs * P**3 coef. [m3 kg-1 Pa-3] +real, parameter :: SPV013 = -1.1293871415e-07*(I_Ts*Pa2kb**3) ! SpV T * P**3 coef. [m3 kg-1 degC-1 Pa-3] + +real, parameter :: ALP000 = SPV010 ! Constant in the dSpV_dT fit [m3 kg-1 degC-1] +real, parameter :: ALP100 = SPV110 ! dSpV_dT fit zs coef. [m3 kg-1 degC-1] +real, parameter :: ALP200 = SPV210 ! dSpV_dT fit zs**2 coef. [m3 kg-1 degC-1] +real, parameter :: ALP300 = SPV310 ! dSpV_dT fit zs**3 coef. [m3 kg-1 degC-1] +real, parameter :: ALP400 = SPV410 ! dSpV_dT fit zs**4 coef. [m3 kg-1 degC-1] +real, parameter :: ALP500 = SPV510 ! dSpV_dT fit zs**5 coef. [m3 kg-1 degC-1] +real, parameter :: ALP010 = 2.*SPV020 ! dSpV_dT fit T coef. [m3 kg-1 degC-2] +real, parameter :: ALP110 = 2.*SPV120 ! dSpV_dT fit zs * T coef. [m3 kg-1 degC-2] +real, parameter :: ALP210 = 2.*SPV220 ! dSpV_dT fit zs**2 * T coef. [m3 kg-1 degC-2] +real, parameter :: ALP310 = 2.*SPV320 ! dSpV_dT fit zs**3 * T coef. [m3 kg-1 degC-2] +real, parameter :: ALP410 = 2.*SPV420 ! dSpV_dT fit zs**4 * T coef. [m3 kg-1 degC-2] +real, parameter :: ALP020 = 3.*SPV030 ! dSpV_dT fit T**2 coef. [m3 kg-1 degC-3] +real, parameter :: ALP120 = 3.*SPV130 ! dSpV_dT fit zs * T**2 coef. [m3 kg-1 degC-3] +real, parameter :: ALP220 = 3.*SPV230 ! dSpV_dT fit zs**2 * T**2 coef. [m3 kg-1 degC-3] +real, parameter :: ALP320 = 3.*SPV330 ! dSpV_dT fit zs**3 * T**2 coef. [m3 kg-1 degC-3] +real, parameter :: ALP030 = 4.*SPV040 ! dSpV_dT fit T**3 coef. [m3 kg-1 degC-4] +real, parameter :: ALP130 = 4.*SPV140 ! dSpV_dT fit zs * T**3 coef. [m3 kg-1 degC-4] +real, parameter :: ALP230 = 4.*SPV240 ! dSpV_dT fit zs**2 * T**3 coef. [m3 kg-1 degC-4] +real, parameter :: ALP040 = 5.*SPV050 ! dSpV_dT fit T**4 coef. [m3 kg-1 degC-5] +real, parameter :: ALP140 = 5.*SPV150 ! dSpV_dT fit zs* * T**4 coef. [m3 kg-1 degC-5] +real, parameter :: ALP050 = 6.*SPV060 ! dSpV_dT fit T**5 coef. [m3 kg-1 degC-6] +real, parameter :: ALP001 = SPV011 ! dSpV_dT fit P coef. [m3 kg-1 degC-1 Pa-1] +real, parameter :: ALP101 = SPV111 ! dSpV_dT fit zs * P coef. [m3 kg-1 degC-1 Pa-1] +real, parameter :: ALP201 = SPV211 ! dSpV_dT fit zs**2 * P coef. [m3 kg-1 degC-1 Pa-1] +real, parameter :: ALP301 = SPV311 ! dSpV_dT fit zs**3 * P coef. [m3 kg-1 degC-1 Pa-1] +real, parameter :: ALP011 = 2.*SPV021 ! dSpV_dT fit T * P coef. [m3 kg-1 degC-2 Pa-1] +real, parameter :: ALP111 = 2.*SPV121 ! dSpV_dT fit zs * T * P coef. [m3 kg-1 degC-2 Pa-1] +real, parameter :: ALP211 = 2.*SPV221 ! dSpV_dT fit zs**2 * T * P coef. [m3 kg-1 degC-2 Pa-1] +real, parameter :: ALP021 = 3.*SPV031 ! dSpV_dT fit T**2 * P coef. [m3 kg-1 degC-3 Pa-1] +real, parameter :: ALP121 = 3.*SPV131 ! dSpV_dT fit zs * T**2 * P coef. [m3 kg-1 degC-3 Pa-1] +real, parameter :: ALP031 = 4.*SPV041 ! dSpV_dT fit T**3 * P coef. [m3 kg-1 degC-4 Pa-1] +real, parameter :: ALP002 = SPV012 ! dSpV_dT fit P**2 coef. [m3 kg-1 degC-1 Pa-2] +real, parameter :: ALP102 = SPV112 ! dSpV_dT fit zs * P**2 coef. [m3 kg-1 degC-1 Pa-2] +real, parameter :: ALP012 = 2.*SPV022 ! dSpV_dT fit T * P**2 coef. [m3 kg-1 degC-2 Pa-2] +real, parameter :: ALP003 = SPV013 ! dSpV_dT fit P**3 coef. [m3 kg-1 degC-1 Pa-3] + +real, parameter :: BET000 = 0.5*SPV100*r1_S0 ! Constant in the dSpV_dS fit [m3 kg-1 ppt-1] +real, parameter :: BET100 = SPV200*r1_S0 ! dSpV_dS fit zs coef. [m3 kg-1 ppt-1] +real, parameter :: BET200 = 1.5*SPV300*r1_S0 ! dSpV_dS fit zs**2 coef. [m3 kg-1 ppt-1] +real, parameter :: BET300 = 2.0*SPV400*r1_S0 ! dSpV_dS fit zs**3 coef. [m3 kg-1 ppt-1] +real, parameter :: BET400 = 2.5*SPV500*r1_S0 ! dSpV_dS fit zs**4 coef. [m3 kg-1 ppt-1] +real, parameter :: BET500 = 3.0*SPV600*r1_S0 ! dSpV_dS fit zs**5 coef. [m3 kg-1 ppt-1] +real, parameter :: BET010 = 0.5*SPV110*r1_S0 ! dSpV_dS fit T coef. [m3 kg-1 ppt-1 degC-1] +real, parameter :: BET110 = SPV210*r1_S0 ! dSpV_dS fit zs * T coef. [m3 kg-1 ppt-1 degC-1] +real, parameter :: BET210 = 1.5*SPV310*r1_S0 ! dSpV_dS fit zs**2 * T coef. [m3 kg-1 ppt-1 degC-1] +real, parameter :: BET310 = 2.0*SPV410*r1_S0 ! dSpV_dS fit zs**3 * T coef. [m3 kg-1 ppt-1 degC-1] +real, parameter :: BET410 = 2.5*SPV510*r1_S0 ! dSpV_dS fit zs**4 * T coef. [m3 kg-1 ppt-1 degC-1] +real, parameter :: BET020 = 0.5*SPV120*r1_S0 ! dSpV_dS fit T**2 coef. [m3 kg-1 ppt-1 degC-2] +real, parameter :: BET120 = SPV220*r1_S0 ! dSpV_dS fit zs * T**2 coef. [m3 kg-1 ppt-1 degC-2] +real, parameter :: BET220 = 1.5*SPV320*r1_S0 ! dSpV_dS fit zs**2 * T**2 coef. [m3 kg-1 ppt-1 degC-2] +real, parameter :: BET320 = 2.0*SPV420*r1_S0 ! dSpV_dS fit zs**3 * T**2 coef. [m3 kg-1 ppt-1 degC-2] +real, parameter :: BET030 = 0.5*SPV130*r1_S0 ! dSpV_dS fit T**3 coef. [m3 kg-1 ppt-1 degC-3] +real, parameter :: BET130 = SPV230*r1_S0 ! dSpV_dS fit zs * T**3 coef. [m3 kg-1 ppt-1 degC-3] +real, parameter :: BET230 = 1.5*SPV330*r1_S0 ! dSpV_dS fit zs**2 * T**3 coef. [m3 kg-1 ppt-1 degC-3] +real, parameter :: BET040 = 0.5*SPV140*r1_S0 ! dSpV_dS fit T**4 coef. [m3 kg-1 ppt-1 degC-4] +real, parameter :: BET140 = SPV240*r1_S0 ! dSpV_dS fit zs * T**4 coef. [m3 kg-1 ppt-1 degC-4] +real, parameter :: BET050 = 0.5*SPV150*r1_S0 ! dSpV_dS fit T**5 coef. [m3 kg-1 ppt-1 degC-5] +real, parameter :: BET001 = 0.5*SPV101*r1_S0 ! dSpV_dS fit P coef. [m3 kg-1 ppt-1 Pa-1] +real, parameter :: BET101 = SPV201*r1_S0 ! dSpV_dS fit zs * P coef. [m3 kg-1 ppt-1 Pa-1] +real, parameter :: BET201 = 1.5*SPV301*r1_S0 ! dSpV_dS fit zs**2 * P coef. [m3 kg-1 ppt-1 Pa-1] +real, parameter :: BET301 = 2.0*SPV401*r1_S0 ! dSpV_dS fit zs**3 * P coef. [m3 kg-1 ppt-1 Pa-1] +real, parameter :: BET011 = 0.5*SPV111*r1_S0 ! dSpV_dS fit T * P coef. [m3 kg-1 ppt-1 degC-1 Pa-1] +real, parameter :: BET111 = SPV211*r1_S0 ! dSpV_dS fit zs * T * P coef. [m3 kg-1 ppt-1 degC-1 Pa-1] +real, parameter :: BET211 = 1.5*SPV311*r1_S0 ! dSpV_dS fit zs**2 * T * P coef. [m3 kg-1 ppt-1 degC-1 Pa-1] +real, parameter :: BET021 = 0.5*SPV121*r1_S0 ! dSpV_dS fit T**2 * P coef. [m3 kg-1 ppt-1 degC-2 Pa-1] +real, parameter :: BET121 = SPV221*r1_S0 ! dSpV_dS fit zs * T**2 * P coef. [m3 kg-1 ppt-1 degC-2 Pa-1] +real, parameter :: BET031 = 0.5*SPV131*r1_S0 ! dSpV_dS fit T**3 * P coef. [m3 kg-1 ppt-1 degC-3 Pa-1] +real, parameter :: BET002 = 0.5*SPV102*r1_S0 ! dSpV_dS fit P**2 coef. [m3 kg-1 ppt-1 Pa-2] +real, parameter :: BET102 = SPV202*r1_S0 ! dSpV_dS fit zs * P**2 coef. [m3 kg-1 ppt-1 Pa-2] +real, parameter :: BET012 = 0.5*SPV112*r1_S0 ! dSpV_dS fit T * P**2 coef. [m3 kg-1 ppt-1 degC-1 Pa-2] +real, parameter :: BET003 = 0.5*SPV103*r1_S0 ! dSpV_dS fit P**3 coef. [m3 kg-1 ppt-1 Pa-3] +!>@} + +!> The EOS_base implementation of the Roquet et al., 2015, equation of state +type, extends (EOS_base) :: Roquet_SpV_EOS + +contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_Roquet_SpV + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_Roquet_SpV + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_Roquet_SpV + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_Roquet_SpV + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_Roquet_SpV + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_Roquet_SpV + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_Roquet_SpV + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_Roquet_SpV + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_Roquet_SpV + + !> Local implementation of generic calculate_density_array for efficiency + procedure :: calculate_density_array => calculate_density_array_Roquet_SpV + !> Local implementation of generic calculate_spec_vol_array for efficiency + procedure :: calculate_spec_vol_array => calculate_spec_vol_array_Roquet_SpV + +end type Roquet_SpV_EOS + +contains + +!> Roquet et al. in situ specific volume of sea water [m3 kg-1] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_elem_Roquet_SpV(this, T, S, pressure) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< pressure [Pa] + + ! Local variables + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: SV_00p ! A pressure-dependent but temperature and salinity independent contribution to + ! specific volume at the reference temperature and salinity [m3 kg-1] + real :: SV_TS ! Specific volume without a pressure-dependent contribution [m3 kg-1] + real :: SV_TS0 ! A contribution to specific volume from temperature and salinity anomalies at + ! the surface pressure [m3 kg-1] + real :: SV_TS1 ! A temperature and salinity dependent specific volume contribution that is + ! proportional to pressure [m3 kg-1 Pa-1] + real :: SV_TS2 ! A temperature and salinity dependent specific volume contribution that is + ! proportional to pressure**2 [m3 kg-1 Pa-2] + real :: SV_TS3 ! A temperature and salinity dependent specific volume contribution that is + ! proportional to pressure**3 [m3 kg-1 Pa-3] + real :: SV_0S0 ! Salinity dependent specific volume at the surface pressure and zero temperature [m3 kg-1] + + ! The following algorithm was published by Roquet et al. (2015), intended for use in non-Boussinesq ocean models. + + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! practical salinity to conservative temperature and absolute salinity. + ! zt = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + SV_TS3 = SPV003 + (zs*SPV103 + zt*SPV013) + SV_TS2 = SPV002 + (zs*(SPV102 + zs*SPV202) & + + zt*(SPV012 + (zs*SPV112 + zt*SPV022)) ) + SV_TS1 = SPV001 + (zs*(SPV101 + zs*(SPV201 + zs*(SPV301 + zs*SPV401))) & + + zt*(SPV011 + (zs*(SPV111 + zs*(SPV211 + zs*SPV311)) & + + zt*(SPV021 + (zs*(SPV121 + zs*SPV221) & + + zt*(SPV031 + (zs*SPV131 + zt*SPV041)) )) )) ) + SV_TS0 = zt*(SPV010 & + + (zs*(SPV110 + zs*(SPV210 + zs*(SPV310 + zs*(SPV410 + zs*SPV510)))) & + + zt*(SPV020 + (zs*(SPV120 + zs*(SPV220 + zs*(SPV320 + zs*SPV420))) & + + zt*(SPV030 + (zs*(SPV130 + zs*(SPV230 + zs*SPV330)) & + + zt*(SPV040 + (zs*(SPV140 + zs*SPV240) & + + zt*(SPV050 + (zs*SPV150 + zt*SPV060)) )) )) )) ) ) + + SV_0S0 = SPV000 + zs*(SPV100 + zs*(SPV200 + zs*(SPV300 + zs*(SPV400 + zs*(SPV500 + zs*SPV600))))) + + SV_00p = zp*(V00 + zp*(V01 + zp*(V02 + zp*(V03 + zp*(V04 + zp*V05))))) + + SV_TS = (SV_TS0 + SV_0S0) + zp*(SV_TS1 + zp*(SV_TS2 + zp*SV_TS3)) + spec_vol_elem_Roquet_SpV = SV_TS + SV_00p ! In situ specific volume [m3 kg-1] + +end function spec_vol_elem_Roquet_SpV + +!> Roquet et al. in situ specific volume anomaly of sea water [m3 kg-1] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_anomaly_elem_Roquet_SpV(this, T, S, pressure, spv_ref) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< pressure [Pa] + real, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + ! Local variables + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: SV_00p ! A pressure-dependent but temperature and salinity independent contribution to + ! specific volume at the reference temperature and salinity [m3 kg-1] + real :: SV_TS ! Specific volume without a pressure-dependent contribution [m3 kg-1] + real :: SV_TS0 ! A contribution to specific volume from temperature and salinity anomalies at + ! the surface pressure [m3 kg-1] + real :: SV_TS1 ! A temperature and salinity dependent specific volume contribution that is + ! proportional to pressure [m3 kg-1 Pa-1] + real :: SV_TS2 ! A temperature and salinity dependent specific volume contribution that is + ! proportional to pressure**2 [m3 kg-1 Pa-2] + real :: SV_TS3 ! A temperature and salinity dependent specific volume contribution that is + ! proportional to pressure**3 [m3 kg-1 Pa-3] + real :: SV_0S0 ! Salinity dependent specific volume at the surface pressure and zero temperature [m3 kg-1] + + ! The following algorithm was published by Roquet et al. (2015), intended for use in non-Boussinesq ocean models. + + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! practical salinity to conservative temperature and absolute salinity. + ! zt = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + SV_TS3 = SPV003 + (zs*SPV103 + zt*SPV013) + SV_TS2 = SPV002 + (zs*(SPV102 + zs*SPV202) & + + zt*(SPV012 + (zs*SPV112 + zt*SPV022)) ) + SV_TS1 = SPV001 + (zs*(SPV101 + zs*(SPV201 + zs*(SPV301 + zs*SPV401))) & + + zt*(SPV011 + (zs*(SPV111 + zs*(SPV211 + zs*SPV311)) & + + zt*(SPV021 + (zs*(SPV121 + zs*SPV221) & + + zt*(SPV031 + (zs*SPV131 + zt*SPV041)) )) )) ) + SV_TS0 = zt*(SPV010 & + + (zs*(SPV110 + zs*(SPV210 + zs*(SPV310 + zs*(SPV410 + zs*SPV510)))) & + + zt*(SPV020 + (zs*(SPV120 + zs*(SPV220 + zs*(SPV320 + zs*SPV420))) & + + zt*(SPV030 + (zs*(SPV130 + zs*(SPV230 + zs*SPV330)) & + + zt*(SPV040 + (zs*(SPV140 + zs*SPV240) & + + zt*(SPV050 + (zs*SPV150 + zt*SPV060)) )) )) )) ) ) + + SV_0S0 = SPV000 + zs*(SPV100 + zs*(SPV200 + zs*(SPV300 + zs*(SPV400 + zs*(SPV500 + zs*SPV600))))) + + SV_00p = zp*(V00 + zp*(V01 + zp*(V02 + zp*(V03 + zp*(V04 + zp*V05))))) + + SV_0S0 = SV_0S0 - spv_ref + + SV_TS = (SV_TS0 + SV_0S0) + zp*(SV_TS1 + zp*(SV_TS2 + zp*SV_TS3)) + spec_vol_anomaly_elem_Roquet_SpV = SV_TS + SV_00p ! In situ specific volume [m3 kg-1] + +end function spec_vol_anomaly_elem_Roquet_SpV + +!> Roquet in situ density [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_elem_Roquet_SpV(this, T, S, pressure) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + + ! Local variables + real :: spv ! The specific volume [m3 kg-1] + + spv = spec_vol_elem_Roquet_SpV(this, T, S, pressure) + density_elem_Roquet_SpV = 1.0 / spv ! In situ density [kg m-3] + +end function density_elem_Roquet_SpV + +!> Roquet in situ density anomaly [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_anomaly_elem_Roquet_SpV(this, T, S, pressure, rho_ref) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: rho_ref !< A reference density [kg m-3] + + ! Local variables + real :: spv ! The specific volume [m3 kg-1] + + spv = spec_vol_anomaly_elem_Roquet_SpV(this, T, S, pressure, spv_ref=1.0/rho_ref) + density_anomaly_elem_Roquet_SpV = -rho_ref**2*spv / (rho_ref*spv + 1.0) ! In situ density [kg m-3] + +end function density_anomaly_elem_Roquet_SpV + +!> Return the partial derivatives of specific volume with temperature and salinity for 1-d array +!! inputs and outputs, using the specific volume polynomial fit from Roquet et al. (2015). +elemental subroutine calculate_specvol_derivs_elem_Roquet_SpV(this, T, S, pressure, dSV_dT, dSV_dS) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! conservative temperature [m3 kg-1 degC-1] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! absolute salinity [m3 kg-1 ppt-1] + + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: dSVdzt0 ! A contribution to the partial derivative of specific volume with temperature + ! from temperature anomalies at the surface pressure [m3 kg-1 degC-1] + real :: dSVdzt1 ! A contribution to the partial derivative of specific volume with temperature + ! that is proportional to pressure [m3 kg-1 degC-1 Pa-1] + real :: dSVdzt2 ! A contribution to the partial derivative of specific volume with temperature + ! that is proportional to pressure**2 [m3 kg-1 degC-1 Pa-2] + real :: dSVdzt3 ! A contribution to the partial derivative of specific volume with temperature + ! that is proportional to pressure**3 [m3 kg-1 degC-1 Pa-3] + real :: dSVdzs0 ! A contribution to the partial derivative of specific volume with + ! salinity [m3 kg-1 ppt-1] from temperature anomalies at the surface pressure + real :: dSVdzs1 ! A contribution to the partial derivative of specific volume with + ! salinity [m3 kg-1 ppt-1 Pa-1] proportional to pressure + real :: dSVdzs2 ! A contribution to the partial derivative of specific volume with + ! salinity [m3 kg-1 ppt-1 Pa-2] proportional to pressure**2 + real :: dSVdzs3 ! A contribution to the partial derivative of specific volume with + ! salinity [m3 kg-1 ppt-1 Pa-3] proportional to pressure**3 + + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! practical salinity to conservative temperature and absolute salinity. + ! zt = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + ! Find the partial derivative of specific volume with temperature + dSVdzt3 = ALP003 + dSVdzt2 = ALP002 + (zs*ALP102 + zt*ALP012) + dSVdzt1 = ALP001 + (zs*(ALP101 + zs*(ALP201 + zs*ALP301)) & + + zt*(ALP011 + (zs*(ALP111 + zs*ALP211) & + + zt*(ALP021 + (zs*ALP121 + zt*ALP031)) )) ) + dSVdzt0 = ALP000 + (zs*(ALP100 + zs*(ALP200 + zs*(ALP300 + zs*(ALP400 + zs*ALP500)))) & + + zt*(ALP010 + (zs*(ALP110 + zs*(ALP210 + zs*(ALP310 + zs*ALP410))) & + + zt*(ALP020 + (zs*(ALP120 + zs*(ALP220 + zs*ALP320)) & + + zt*(ALP030 + (zt*(ALP040 + (zs*ALP140 + zt*ALP050)) & + + zs*(ALP130 + zs*ALP230) )) )) )) ) + + dSV_dT = dSVdzt0 + zp*(dSVdzt1 + zp*(dSVdzt2 + zp*dSVdzt3)) + + ! Find the partial derivative of specific volume with salinity + dSVdzs3 = BET003 + dSVdzs2 = BET002 + (zs*BET102 + zt*BET012) + dSVdzs1 = BET001 + (zs*(BET101 + zs*(BET201 + zs*BET301)) & + + zt*(BET011 + (zs*(BET111 + zs*BET211) & + + zt*(BET021 + (zs*BET121 + zt*BET031)) )) ) + dSVdzs0 = BET000 + (zs*(BET100 + zs*(BET200 + zs*(BET300 + zs*(BET400 + zs*BET500)))) & + + zt*(BET010 + (zs*(BET110 + zs*(BET210 + zs*(BET310 + zs*BET410))) & + + zt*(BET020 + (zs*(BET120 + zs*(BET220 + zs*BET320)) & + + zt*(BET030 + (zt*(BET040 + (zs*BET140 + zt*BET050)) & + + zs*(BET130 + zs*BET230) )) )) )) ) + + ! The division by zs here is because zs = sqrt(S + S0), so dSV_dS = dzs_dS * dSV_dzs = (0.5 / zs) * dSV_dzs + dSV_dS = (dSVdzs0 + zp*(dSVdzs1 + zp*(dSVdzs2 + zp * dSVdzs3))) / zs + +end subroutine calculate_specvol_derivs_elem_Roquet_SpV + +!> Compute an array of derivatives of densities of sea water with temperature (drho_dT in [kg m-3 degC-1]) +!! and salinity (drho_dS in [kg m-3 ppt-1]) from absolute salinity (S [g kg-1]), conservative temperature +!! (T [degC]) and pressure [Pa], using the specific volume polynomial fit from Roquet et al. (2015). +elemental subroutine calculate_density_derivs_elem_Roquet_SpV(this, T, S, pressure, drho_dT, drho_dS) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< pressure [Pa] + real, intent(out) :: drho_dT !< The partial derivative of density with + !! conservative temperature [kg m-3 degC-1] + real, intent(out) :: drho_dS !< The partial derivative of density with + !! absolute salinity [kg m-3 ppt-1] + + ! Local variables + real :: dSV_dT ! The partial derivative of specific volume with + ! conservative temperature [m3 kg-1 degC-1] + real :: dSV_dS ! The partial derivative of specific volume with + ! absolute salinity [m3 kg-1 ppt-1] + real :: specvol ! The specific volume [m3 kg-1] + real :: rho ! The in situ density [kg m-3] + + call this%calculate_specvol_derivs_elem(T, S, pressure, dSV_dT, dSV_dS) + + specvol = this%spec_vol_elem(T, S, pressure) + rho = 1.0 / specvol + drho_dT = -dSv_dT * rho**2 + drho_dS = -dSv_dS * rho**2 + +end subroutine calculate_density_derivs_elem_Roquet_SpV + +!> Compute the in situ density of sea water (rho in [kg m-3]) and the compressibility +!! (drho/dp = C_sound^-2, stored as drho_dp [s2 m-2]) from absolute salinity (sal [g kg-1]), +!! conservative temperature (T [degC]), and pressure [Pa], using the specific volume +!! polynomial fit from Roquet et al. (2015). +elemental subroutine calculate_compress_elem_Roquet_SpV(this, T, S, pressure, rho, drho_dp) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< pressure [Pa] + real, intent(out) :: rho !< In situ density [kg m-3] + real, intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [s2 m-2] + + ! Local variables + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: dSV_00p_dp ! Derivative of the pressure-dependent reference specific volume profile with + ! pressure [m3 kg-1 Pa-1] + real :: dSV_TS_dp ! Derivative of the specific volume anomaly from the reference profile with + ! pressure [m3 kg-1 Pa-1] + real :: SV_00p ! A pressure-dependent but temperature and salinity independent contribution to + ! specific volume at the reference temperature and salinity [m3 kg-1] + real :: SV_TS ! specific volume without a pressure-dependent contribution [m3 kg-1] + real :: SV_TS0 ! A contribution to specific volume from temperature and salinity anomalies at + ! the surface pressure [m3 kg-1] + real :: SV_TS1 ! A temperature and salinity dependent specific volume contribution that is + ! proportional to pressure [m3 kg-1 Pa-1] + real :: SV_TS2 ! A temperature and salinity dependent specific volume contribution that is + ! proportional to pressure**2 [m3 kg-1 Pa-2] + real :: SV_TS3 ! A temperature and salinity dependent specific volume contribution that is + ! proportional to pressure**3 [m3 kg-1 Pa-3] + real :: SV_0S0 ! Salinity dependent specific volume at the surface pressure and zero temperature [m3 kg-1] + real :: dSpecVol_dp ! The partial derivative of specific volume with pressure [m3 kg-1 Pa-1] + + ! The following algorithm was published by Roquet et al. (2015), intended for use + ! with NEMO, but it is not necessarily the algorithm used in NEMO ocean model. + + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! practical salinity to conservative temperature and absolute salinity. + ! zt = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + SV_TS3 = SPV003 + (zs*SPV103 + zt*SPV013) + SV_TS2 = SPV002 + (zs*(SPV102 + zs*SPV202) & + + zt*(SPV012 + (zs*SPV112 + zt*SPV022)) ) + SV_TS1 = SPV001 + (zs*(SPV101 + zs*(SPV201 + zs*(SPV301 + zs*SPV401))) & + + zt*(SPV011 + (zs*(SPV111 + zs*(SPV211 + zs*SPV311)) & + + zt*(SPV021 + (zs*(SPV121 + zs*SPV221) & + + zt*(SPV031 + (zs*SPV131 + zt*SPV041)) )) )) ) + + SV_TS0 = zt*(SPV010 & + + (zs*(SPV110 + zs*(SPV210 + zs*(SPV310 + zs*(SPV410 + zs*SPV510)))) & + + zt*(SPV020 + (zs*(SPV120 + zs*(SPV220 + zs*(SPV320 + zs*SPV420))) & + + zt*(SPV030 + (zs*(SPV130 + zs*(SPV230 + zs*SPV330)) & + + zt*(SPV040 + (zs*(SPV140 + zs*SPV240) & + + zt*(SPV050 + (zs*SPV150 + zt*SPV060)) )) )) )) ) ) + + SV_0S0 = SPV000 + zs*(SPV100 + zs*(SPV200 + zs*(SPV300 + zs*(SPV400 + zs*(SPV500 + zs*SPV600))))) + + SV_00p = zp*(V00 + zp*(V01 + zp*(V02 + zp*(V03 + zp*(V04 + zp*V05))))) + + SV_TS = (SV_TS0 + SV_0S0) + zp*(SV_TS1 + zp*(SV_TS2 + zp*SV_TS3)) + ! specvol = SV_TS + SV_00p ! In situ specific volume [m3 kg-1] + rho = 1.0 / (SV_TS + SV_00p) ! In situ density [kg m-3] + + dSV_00p_dp = V00 + zp*(2.*V01 + zp*(3.*V02 + zp*(4.*V03 + zp*(5.*V04 + zp*(6.*V05))))) + dSV_TS_dp = SV_TS1 + zp*(2.*SV_TS2 + zp*(3.*SV_TS3)) + dSpecVol_dp = dSV_TS_dp + dSV_00p_dp ! [m3 kg-1 Pa-1] + drho_dp = -dSpecVol_dp * rho**2 ! Compressibility [s2 m-2] + +end subroutine calculate_compress_elem_Roquet_SpV + +!> Second derivatives of specific volume with respect to temperature, salinity, and pressure for a +!! 1-d array inputs and outputs using the specific volume polynomial fit from Roquet et al. (2015). +elemental subroutine calc_spec_vol_second_derivs_elem_Roquet_SpV(T, S, P, & + dSV_ds_ds, dSV_ds_dt, dSV_dt_dt, dSV_ds_dp, dSV_dt_dp) + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: P !< Pressure [Pa] + real, intent(inout) :: dSV_ds_ds !< Second derivative of specific volume with respect + !! to salinity [m3 kg-1 ppt-2] + real, intent(inout) :: dSV_ds_dt !< Second derivative of specific volume with respect + !! to salinity and temperature [m3 kg-1 ppt-1 degC-1] + real, intent(inout) :: dSV_dt_dt !< Second derivative of specific volume with respect + !! to temperature [m3 kg-1 degC-2] + real, intent(inout) :: dSV_ds_dp !< Second derivative of specific volume with respect to pressure + !! and salinity [m3 kg-1 ppt-1 Pa-1] + real, intent(inout) :: dSV_dt_dp !< Second derivative of specific volume with respect to pressure + !! and temperature [m3 kg-1 degC-1 Pa-1] + ! Local variables + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: I_s ! The inverse of zs [nondim] + real :: d2SV_p0 ! A contribution to one of the second derivatives that is independent of pressure [various] + real :: d2SV_p1 ! A contribution to one of the second derivatives that is proportional to pressure [various] + real :: d2SV_p2 ! A contribution to one of the second derivatives that is proportional to pressure**2 [various] + real :: d2SV_p3 ! A contribution to one of the second derivatives that is proportional to pressure**3 [various] + + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = P + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! practical salinity to conservative temperature and absolute salinity. + ! zt = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + I_s = 1.0 / zs + + ! Find dSV_ds_ds + d2SV_p3 = -SPV103*I_s**2 + d2SV_p2 = -(SPV102 + zt*SPV112)*I_s**2 + d2SV_p1 = (3.*SPV301 + (zt*(3.*SPV311) + zs*(8.*SPV401))) & + - ( SPV101 + zt*(SPV111 + zt*(SPV121 + zt*SPV131)) )*I_s**2 + d2SV_p0 = (3.*SPV300 + (zs*(8.*SPV400 + zs*(15.*SPV500 + zs*(24.*SPV600))) & + + zt*(3.*SPV310 + (zs*(8.*SPV410 + zs*(15.*SPV510)) & + + zt*(3.*SPV320 + (zs*(8.*SPV420) + zt*(3.*SPV330))) )) )) & + - (SPV100 + zt*(SPV110 + zt*(SPV120 + zt*(SPV130 + zt*(SPV140 + zt*SPV150)))) )*I_s**2 + dSV_dS_dS = (0.5*r1_S0)**2 * ((d2SV_p0 + zp*(d2SV_p1 + zp*(d2SV_p2 + zp*d2SV_p3))) * I_s) + + ! Find dSV_ds_dt + d2SV_p2 = SPV112 + d2SV_p1 = SPV111 + (zs*(2.*SPV211 + zs*(3.*SPV311)) & + + zt*(2.*SPV121 + (zs*(4.*SPV221) + zt*(3.*SPV131))) ) + d2SV_p0 = SPV110 + (zs*(2.*SPV210 + zs*(3.*SPV310 + zs*(4.*SPV410 + zs*(5.*SPV510)))) & + + zt*(2.*SPV120 + (zs*(4.*SPV220 + zs*(6.*SPV320 + zs*(8.*SPV420))) & + + zt*(3.*SPV130 + (zs*(6.*SPV230 + zs*(9.*SPV330)) & + + zt*(4.*SPV140 + (zs*(8.*SPV240) & + + zt*(5.*SPV150))) )) )) ) + dSV_ds_dt = (0.5*r1_S0) * ((d2SV_p0 + zp*(d2SV_p1 + zp*d2SV_p2)) * I_s) + + ! Find dSV_dt_dt + d2SV_p2 = 2.*SPV022 + d2SV_p1 = 2.*SPV021 + (zs*(2.*SPV121 + zs*(2.*SPV221)) & + + zt*(6.*SPV031 + (zs*(6.*SPV131) + zt*(12.*SPV041))) ) + d2SV_p0 = 2.*SPV020 + (zs*(2.*SPV120 + zs*( 2.*SPV220 + zs*( 2.*SPV320 + zs * (2.*SPV420)))) & + + zt*(6.*SPV030 + (zs*( 6.*SPV130 + zs*( 6.*SPV230 + zs * (6.*SPV330))) & + + zt*(12.*SPV040 + (zs*(12.*SPV140 + zs *(12.*SPV240)) & + + zt*(20.*SPV050 + (zs*(20.*SPV150) & + + zt*(30.*SPV060) )) )) )) ) + dSV_dt_dt = d2SV_p0 + zp*(d2SV_p1 + zp*d2SV_p2) + + ! Find dSV_ds_dp + d2SV_p2 = 3.*SPV103 + d2SV_p1 = 2.*SPV102 + (zs*(4.*SPV202) + zt*(2.*SPV112)) + d2SV_p0 = SPV101 + (zs*(2.*SPV201 + zs*(3.*SPV301 + zs*(4.*SPV401))) & + + zt*(SPV111 + (zs*(2.*SPV211 + zs*(3.*SPV311)) & + + zt*( SPV121 + (zs*(2.*SPV221) + zt*SPV131)) )) ) + dSV_ds_dp = ((d2SV_p0 + zp*(d2SV_p1 + zp*d2SV_p2)) * I_s) * (0.5*r1_S0) + + ! Find dSV_dt_dp + d2SV_p2 = 3.*SPV013 + d2SV_p1 = 2.*SPV012 + (zs*(2.*SPV112) + zt*(4.*SPV022)) + d2SV_p0 = SPV011 + (zs*(SPV111 + zs*( SPV211 + zs* SPV311)) & + + zt*(2.*SPV021 + (zs*(2.*SPV121 + zs*(2.*SPV221)) & + + zt*(3.*SPV031 + (zs*(3.*SPV131) + zt*(4.*SPV041))) )) ) + dSV_dt_dp = d2SV_p0 + zp*(d2SV_p1 + zp*d2SV_p2) + +end subroutine calc_spec_vol_second_derivs_elem_Roquet_SpV + +!> Second derivatives of density with respect to temperature, salinity, and pressure for a +!! 1-d array inputs and outputs using the specific volume polynomial fit from Roquet et al. (2015). +elemental subroutine calculate_density_second_derivs_elem_Roquet_SpV(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: drho_ds_ds !< Second derivative of density with respect + !! to salinity [kg m-3 ppt-2] + real, intent(inout) :: drho_ds_dt !< Second derivative of density with respect + !! to salinity and temperature [kg m-3 ppt-1 degC-1] + real, intent(inout) :: drho_dt_dt !< Second derivative of density with respect + !! to temperature [kg m-3 degC-2] + real, intent(inout) :: drho_ds_dp !< Second derivative of density with respect to pressure + !! and salinity [kg m-3 ppt-1 Pa-1] = [s2 m-2 ppt-1] + real, intent(inout) :: drho_dt_dp !< Second derivative of density with respect to pressure + !! and temperature [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + + ! Local variables + real :: rho ! The in situ density [kg m-3] + real :: drho_dp ! The partial derivative of density with pressure + ! (also the inverse of the square of sound speed) [s2 m-2] + real :: dSV_dT ! The partial derivative of specific volume with + ! conservative temperature [m3 kg-1 degC-1] + real :: dSV_dS ! The partial derivative of specific volume with + ! absolute salinity [m3 kg-1 ppt-1] + real :: dSV_ds_ds ! Second derivative of specific volume with respect + ! to salinity [m3 kg-1 ppt-2] + real :: dSV_ds_dt ! Second derivative of specific volume with respect + ! to salinity and temperature [m3 kg-1 ppt-1 degC-1] + real :: dSV_dt_dt ! Second derivative of specific volume with respect + ! to temperature [m3 kg-1 degC-2] + real :: dSV_ds_dp ! Second derivative of specific volume with respect to pressure + ! and salinity [m3 kg-1 ppt-1 Pa-1] + real :: dSV_dt_dp ! Second derivative of specific volume with respect to pressure + ! and temperature [m3 kg-1 degC-1 Pa-1] + + call calc_spec_vol_second_derivs_elem_Roquet_SpV(T, S, pressure, & + dSV_ds_ds, dSV_ds_dt, dSV_dt_dt, dSV_ds_dp, dSV_dt_dp) + call this%calculate_specvol_derivs_elem(T, S, pressure, dSV_dT, dSV_dS) + call this%calculate_compress_elem(T, S, pressure, rho, drho_dp) + + ! Find drho_ds_ds + drho_dS_dS = rho**2 * (2.0*rho*dSV_dS**2 - dSV_dS_dS) + + ! Find drho_ds_dt + drho_ds_dt = rho**2 * (2.0*rho*(dSV_dT*dSV_dS) - dSV_dS_dT) + + ! Find drho_dt_dt + drho_dT_dT = rho**2 * (2.0*rho*dSV_dT**2 - dSV_dT_dT) + + ! Find drho_ds_dp + drho_ds_dp = -rho * (2.0*dSV_dS * drho_dp + rho * dSV_dS_dp) + + ! Find drho_dt_dp + drho_dt_dp = -rho * (2.0*dSV_dT * drho_dp + rho * dSV_dT_dp) + +end subroutine calculate_density_second_derivs_elem_Roquet_SpV + +!> Return the range of temperatures, salinities and pressures for which the Roquet et al. (2015) +!! expression for specific volume has been fitted to observations. Care should be taken when +!! applying this equation of state outside of its fit range. +subroutine EoS_fit_range_Roquet_SpV(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + real, optional, intent(out) :: T_min !< The minimum conservative temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum conservative temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum absolute salinity over which this EoS is fitted [g kg-1] + real, optional, intent(out) :: S_max !< The maximum absolute salinity over which this EoS is fitted [g kg-1] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + if (present(T_min)) T_min = -6.0 + if (present(T_max)) T_max = 40.0 + if (present(S_min)) S_min = 0.0 + if (present(S_max)) S_max = 42.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 1.0e8 + +end subroutine EoS_fit_range_Roquet_SpV + +!> Calculate the in-situ density for 1D arraya inputs and outputs. +subroutine calculate_density_array_Roquet_SpV(this, T, S, pressure, rho, start, npts, rho_ref) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: rho !< In situ density [kg m-3] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + + ! Local variables + integer :: j + + if (present(rho_ref)) then + do j = start, start+npts-1 + rho(j) = density_anomaly_elem_Roquet_SpV(this, T(j), S(j), pressure(j), rho_ref) + enddo + else + do j = start, start+npts-1 + rho(j) = density_elem_Roquet_SpV(this, T(j), S(j), pressure(j)) + enddo + endif + +end subroutine calculate_density_array_Roquet_SpV + +!> Calculate the in-situ specific volume for 1D array inputs and outputs. +subroutine calculate_spec_vol_array_Roquet_SpV(this, T, S, pressure, specvol, start, npts, spv_ref) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: specvol !< In situ specific volume [m3 kg-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + ! Local variables + integer :: j + + if (present(spv_ref)) then + do j = start, start+npts-1 + specvol(j) = spec_vol_anomaly_elem_Roquet_SpV(this, T(j), S(j), pressure(j), spv_ref) + enddo + else + do j = start, start+npts-1 + specvol(j) = spec_vol_elem_Roquet_SpV(this, T(j), S(j), pressure(j) ) + enddo + endif + +end subroutine calculate_spec_vol_array_Roquet_SpV + +!> \namespace mom_eos_Roquet_SpV +!! +!! \section section_EOS_Roquet_SpV NEMO equation of state +!! +!! Fabien Roquet and colleagues developed this equation of state using a simple polynomial fit +!! to the TEOS-10 equation of state expressions for specific, for efficiency when used with a +!! non-Boussinesq ocean model. This particular equation of state is a balance between an +!! accuracy that matches the TEOS-10 density to better than observational uncertainty with a +!! polynomial form that can be evaluated quickly despite having 55 terms. +!! +!! \subsection section_EOS_Roquet_Spv_references References +!! +!! Roquet, F., Madec, G., McDougall, T. J., and Barker, P. M., 2015: +!! Accurate polynomial expressions for the density and specific volume +!! of seawater using the TEOS-10 standard. Ocean Modelling, 90:29-43. + +end module MOM_EOS_Roquet_Spv diff --git a/src/equation_of_state/MOM_EOS_Roquet_rho.F90 b/src/equation_of_state/MOM_EOS_Roquet_rho.F90 new file mode 100644 index 0000000000..1e80c63c5a --- /dev/null +++ b/src/equation_of_state/MOM_EOS_Roquet_rho.F90 @@ -0,0 +1,691 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> The equation of state using the expressions of Roquet et al. (2015) that are used in NEMO +module MOM_EOS_Roquet_rho + +use MOM_EOS_base_type, only : EOS_base + +implicit none ; private + +public Roquet_rho_EOS + +real, parameter :: Pa2kb = 1.e-8 !< Conversion factor between Pa and kbar [kbar Pa-1] +!>@{ Parameters in the Roquet_rho (Roquet density) equation of state +real, parameter :: rdeltaS = 32. ! An offset to salinity before taking its square root [g kg-1] +real, parameter :: r1_S0 = 0.875/35.16504 ! The inverse of a plausible range of oceanic salinities [kg g-1] +real, parameter :: I_Ts = 0.025 ! The inverse of a plausible range of oceanic temperatures [degC-1] + +! The following are the coefficients of the fit to the reference density profile (rho00p) as a function of +! pressure (P), with a contribution R0c * P**(c+1). The nomenclature follows Roquet. +real, parameter :: R00 = 4.6494977072e+01*Pa2kb ! rho00p P coef. [kg m-3 Pa-1] +real, parameter :: R01 = -5.2099962525*Pa2kb**2 ! rho00p P**2 coef. [kg m-3 Pa-2] +real, parameter :: R02 = 2.2601900708e-01*Pa2kb**3 ! rho00p P**3 coef. [kg m-3 Pa-3] +real, parameter :: R03 = 6.4326772569e-02*Pa2kb**4 ! rho00p P**4 coef. [kg m-3 Pa-4] +real, parameter :: R04 = 1.5616995503e-02*Pa2kb**5 ! rho00p P**5 coef. [kg m-3 Pa-5] +real, parameter :: R05 = -1.7243708991e-03*Pa2kb**6 ! rho00p P**6 coef. [kg m-3 Pa-6] + +! The following are coefficients of contributions to density as a function of the square root +! of normalized salinity with an offset (zs), temperature (T) and pressure (P), with a contribution +! EOSabc * zs**a * T**b * P**c. The numbers here are copied directly from Roquet et al. (2015), but +! the expressions here do not use the same nondimensionalization for pressure or temperature as they do. +real, parameter :: EOS000 = 8.0189615746e+02 ! A constant density contribution [kg m-3] +real, parameter :: EOS100 = 8.6672408165e+02 ! EoS zs coef. [kg m-3] +real, parameter :: EOS200 = -1.7864682637e+03 ! EoS zs**2 coef. [kg m-3] +real, parameter :: EOS300 = 2.0375295546e+03 ! EoS zs**3 coef. [kg m-3] +real, parameter :: EOS400 = -1.2849161071e+03 ! EoS zs**4 coef. [kg m-3] +real, parameter :: EOS500 = 4.3227585684e+02 ! EoS zs**5 coef. [kg m-3] +real, parameter :: EOS600 = -6.0579916612e+01 ! EoS zs**6 coef. [kg m-3] +real, parameter :: EOS010 = 2.6010145068e+01*I_Ts ! EoS T coef. [kg m-3 degC-1] +real, parameter :: EOS110 = -6.5281885265e+01*I_Ts ! EoS zs * T coef. [kg m-3 degC-1] +real, parameter :: EOS210 = 8.1770425108e+01*I_Ts ! EoS zs**2 * T coef. [kg m-3 degC-1] +real, parameter :: EOS310 = -5.6888046321e+01*I_Ts ! EoS zs**3 * T coef. [kg m-3 degC-1] +real, parameter :: EOS410 = 1.7681814114e+01*I_Ts ! EoS zs**2 * T coef. [kg m-3 degC-1] +real, parameter :: EOS510 = -1.9193502195*I_Ts ! EoS zs**5 * T coef. [kg m-3 degC-1] +real, parameter :: EOS020 = -3.7074170417e+01*I_Ts**2 ! EoS T**2 coef. [kg m-3 degC-2] +real, parameter :: EOS120 = 6.1548258127e+01*I_Ts**2 ! EoS zs * T**2 coef. [kg m-3 degC-2] +real, parameter :: EOS220 = -6.0362551501e+01*I_Ts**2 ! EoS zs**2 * T**2 coef. [kg m-3 degC-2] +real, parameter :: EOS320 = 2.9130021253e+01*I_Ts**2 ! EoS zs**3 * T**2 coef. [kg m-3 degC-2] +real, parameter :: EOS420 = -5.4723692739*I_Ts**2 ! EoS zs**4 * T**2 coef. [kg m-3 degC-2] +real, parameter :: EOS030 = 2.1661789529e+01*I_Ts**3 ! EoS T**3 coef. [kg m-3 degC-3] +real, parameter :: EOS130 = -3.3449108469e+01*I_Ts**3 ! EoS zs * T**3 coef. [kg m-3 degC-3] +real, parameter :: EOS230 = 1.9717078466e+01*I_Ts**3 ! EoS zs**2 * T**3 coef. [kg m-3 degC-3] +real, parameter :: EOS330 = -3.1742946532*I_Ts**3 ! EoS zs**3 * T**3 coef. [kg m-3 degC-3] +real, parameter :: EOS040 = -8.3627885467*I_Ts**4 ! EoS T**4 coef. [kg m-3 degC-4] +real, parameter :: EOS140 = 1.1311538584e+01*I_Ts**4 ! EoS zs * T**4 coef. [kg m-3 degC-4] +real, parameter :: EOS240 = -5.3563304045*I_Ts**4 ! EoS zs**2 * T**4 coef. [kg m-3 degC-4] +real, parameter :: EOS050 = 5.4048723791e-01*I_Ts**5 ! EoS T**5 coef. [kg m-3 degC-5] +real, parameter :: EOS150 = 4.8169980163e-01*I_Ts**5 ! EoS zs * T**5 coef. [kg m-3 degC-5] +real, parameter :: EOS060 = -1.9083568888e-01*I_Ts**6 ! EoS T**6 [kg m-3 degC-6] +real, parameter :: EOS001 = 1.9681925209e+01*Pa2kb ! EoS P coef. [kg m-3 Pa-1] +real, parameter :: EOS101 = -4.2549998214e+01*Pa2kb ! EoS zs * P coef. [kg m-3 Pa-1] +real, parameter :: EOS201 = 5.0774768218e+01*Pa2kb ! EoS zs**2 * P coef. [kg m-3 Pa-1] +real, parameter :: EOS301 = -3.0938076334e+01*Pa2kb ! EoS zs**3 * P coef. [kg m-3 Pa-1] +real, parameter :: EOS401 = 6.6051753097*Pa2kb ! EoS zs**4 * P coef. [kg m-3 Pa-1] +real, parameter :: EOS011 = -1.3336301113e+01*(I_Ts*Pa2kb) ! EoS T * P coef. [kg m-3 degC-1 Pa-1] +real, parameter :: EOS111 = -4.4870114575*(I_Ts*Pa2kb) ! EoS zs * T * P coef. [kg m-3 degC-1 Pa-1] +real, parameter :: EOS211 = 5.0042598061*(I_Ts*Pa2kb) ! EoS zs**2 * T * P coef. [kg m-3 degC-1 Pa-1] +real, parameter :: EOS311 = -6.5399043664e-01*(I_Ts*Pa2kb) ! EoS zs**3 * T * P coef. [kg m-3 degC-1 Pa-1] +real, parameter :: EOS021 = 6.7080479603*(I_Ts**2*Pa2kb) ! EoS T**2 * P coef. [kg m-3 degC-2 Pa-1] +real, parameter :: EOS121 = 3.5063081279*(I_Ts**2*Pa2kb) ! EoS zs * T**2 * P coef. [kg m-3 degC-2 Pa-1] +real, parameter :: EOS221 = -1.8795372996*(I_Ts**2*Pa2kb) ! EoS zs**2 * T**2 * P coef. [kg m-3 degC-2 Pa-1] +real, parameter :: EOS031 = -2.4649669534*(I_Ts**3*Pa2kb) ! EoS T**3 * P coef. [kg m-3 degC-3 Pa-1] +real, parameter :: EOS131 = -5.5077101279e-01*(I_Ts**3*Pa2kb) ! EoS zs * T**3 * P coef. [kg m-3 degC-3 Pa-1] +real, parameter :: EOS041 = 5.5927935970e-01*(I_Ts**4*Pa2kb) ! EoS T**4 * P coef. [kg m-3 degC-4 Pa-1] +real, parameter :: EOS002 = 2.0660924175*Pa2kb**2 ! EoS P**2 coef. [kg m-3 Pa-2] +real, parameter :: EOS102 = -4.9527603989*Pa2kb**2 ! EoS zs * P**2 coef. [kg m-3 Pa-2] +real, parameter :: EOS202 = 2.5019633244*Pa2kb**2 ! EoS zs**2 * P**2 coef. [kg m-3 Pa-2] +real, parameter :: EOS012 = 2.0564311499*(I_Ts*Pa2kb**2) ! EoS T * P**2 coef. [kg m-3 degC-1 Pa-2] +real, parameter :: EOS112 = -2.1311365518e-01*(I_Ts*Pa2kb**2) ! EoS zs * T * P**2 coef. [kg m-3 degC-1 Pa-2] +real, parameter :: EOS022 = -1.2419983026*(I_Ts**2*Pa2kb**2) ! EoS T**2 * P**2 coef. [kg m-3 degC-2 Pa-2] +real, parameter :: EOS003 = -2.3342758797e-02*Pa2kb**3 ! EoS P**3 coef. [kg m-3 Pa-3] +real, parameter :: EOS103 = -1.8507636718e-02*Pa2kb**3 ! EoS zs * P**3 coef. [kg m-3 Pa-3] +real, parameter :: EOS013 = 3.7969820455e-01*(I_Ts*Pa2kb**3) ! EoS T * P**3 coef. [kg m-3 degC-1 Pa-3] + +real, parameter :: ALP000 = EOS010 ! Constant in the drho_dT fit [kg m-3 degC-1] +real, parameter :: ALP100 = EOS110 ! drho_dT fit zs coef. [kg m-3 degC-1] +real, parameter :: ALP200 = EOS210 ! drho_dT fit zs**2 coef. [kg m-3 degC-1] +real, parameter :: ALP300 = EOS310 ! drho_dT fit zs**3 coef. [kg m-3 degC-1] +real, parameter :: ALP400 = EOS410 ! drho_dT fit zs**4 coef. [kg m-3 degC-1] +real, parameter :: ALP500 = EOS510 ! drho_dT fit zs**5 coef. [kg m-3 degC-1] +real, parameter :: ALP010 = 2.*EOS020 ! drho_dT fit T coef. [kg m-3 degC-2] +real, parameter :: ALP110 = 2.*EOS120 ! drho_dT fit zs * T coef. [kg m-3 degC-2] +real, parameter :: ALP210 = 2.*EOS220 ! drho_dT fit zs**2 * T coef. [kg m-3 degC-2] +real, parameter :: ALP310 = 2.*EOS320 ! drho_dT fit zs**3 * T coef. [kg m-3 degC-2] +real, parameter :: ALP410 = 2.*EOS420 ! drho_dT fit zs**4 * T coef. [kg m-3 degC-2] +real, parameter :: ALP020 = 3.*EOS030 ! drho_dT fit T**2 coef. [kg m-3 degC-3] +real, parameter :: ALP120 = 3.*EOS130 ! drho_dT fit zs * T**2 coef. [kg m-3 degC-3] +real, parameter :: ALP220 = 3.*EOS230 ! drho_dT fit zs**2 * T**2 coef. [kg m-3 degC-3] +real, parameter :: ALP320 = 3.*EOS330 ! drho_dT fit zs**3 * T**2 coef. [kg m-3 degC-3] +real, parameter :: ALP030 = 4.*EOS040 ! drho_dT fit T**3 coef. [kg m-3 degC-4] +real, parameter :: ALP130 = 4.*EOS140 ! drho_dT fit zs * T**3 coef. [kg m-3 degC-4] +real, parameter :: ALP230 = 4.*EOS240 ! drho_dT fit zs**2 * T**3 coef. [kg m-3 degC-4] +real, parameter :: ALP040 = 5.*EOS050 ! drho_dT fit T**4 coef. [kg m-3 degC-5] +real, parameter :: ALP140 = 5.*EOS150 ! drho_dT fit zs* * T**4 coef. [kg m-3 degC-5] +real, parameter :: ALP050 = 6.*EOS060 ! drho_dT fit T**5 coef. [kg m-3 degC-6] +real, parameter :: ALP001 = EOS011 ! drho_dT fit P coef. [kg m-3 degC-1 Pa-1] +real, parameter :: ALP101 = EOS111 ! drho_dT fit zs * P coef. [kg m-3 degC-1 Pa-1] +real, parameter :: ALP201 = EOS211 ! drho_dT fit zs**2 * P coef. [kg m-3 degC-1 Pa-1] +real, parameter :: ALP301 = EOS311 ! drho_dT fit zs**3 * P coef. [kg m-3 degC-1 Pa-1] +real, parameter :: ALP011 = 2.*EOS021 ! drho_dT fit T * P coef. [kg m-3 degC-2 Pa-1] +real, parameter :: ALP111 = 2.*EOS121 ! drho_dT fit zs * T * P coef. [kg m-3 degC-2 Pa-1] +real, parameter :: ALP211 = 2.*EOS221 ! drho_dT fit zs**2 * T * P coef. [kg m-3 degC-2 Pa-1] +real, parameter :: ALP021 = 3.*EOS031 ! drho_dT fit T**2 * P coef. [kg m-3 degC-3 Pa-1] +real, parameter :: ALP121 = 3.*EOS131 ! drho_dT fit zs * T**2 * P coef. [kg m-3 degC-3 Pa-1] +real, parameter :: ALP031 = 4.*EOS041 ! drho_dT fit T**3 * P coef. [kg m-3 degC-4 Pa-1] +real, parameter :: ALP002 = EOS012 ! drho_dT fit P**2 coef. [kg m-3 degC-1 Pa-2] +real, parameter :: ALP102 = EOS112 ! drho_dT fit zs * P**2 coef. [kg m-3 degC-1 Pa-2] +real, parameter :: ALP012 = 2.*EOS022 ! drho_dT fit T * P**2 coef. [kg m-3 degC-2 Pa-2] +real, parameter :: ALP003 = EOS013 ! drho_dT fit P**3 coef. [kg m-3 degC-1 Pa-3] + +real, parameter :: BET000 = 0.5*EOS100*r1_S0 ! Constant in the drho_dS fit [kg m-3 ppt-1] +real, parameter :: BET100 = EOS200*r1_S0 ! drho_dS fit zs coef. [kg m-3 ppt-1] +real, parameter :: BET200 = 1.5*EOS300*r1_S0 ! drho_dS fit zs**2 coef. [kg m-3 ppt-1] +real, parameter :: BET300 = 2.0*EOS400*r1_S0 ! drho_dS fit zs**3 coef. [kg m-3 ppt-1] +real, parameter :: BET400 = 2.5*EOS500*r1_S0 ! drho_dS fit zs**4 coef. [kg m-3 ppt-1] +real, parameter :: BET500 = 3.0*EOS600*r1_S0 ! drho_dS fit zs**5 coef. [kg m-3 ppt-1] +real, parameter :: BET010 = 0.5*EOS110*r1_S0 ! drho_dS fit T coef. [kg m-3 ppt-1 degC-1] +real, parameter :: BET110 = EOS210*r1_S0 ! drho_dS fit zs * T coef. [kg m-3 ppt-1 degC-1] +real, parameter :: BET210 = 1.5*EOS310*r1_S0 ! drho_dS fit zs**2 * T coef. [kg m-3 ppt-1 degC-1] +real, parameter :: BET310 = 2.0*EOS410*r1_S0 ! drho_dS fit zs**3 * T coef. [kg m-3 ppt-1 degC-1] +real, parameter :: BET410 = 2.5*EOS510*r1_S0 ! drho_dS fit zs**4 * T coef. [kg m-3 ppt-1 degC-1] +real, parameter :: BET020 = 0.5*EOS120*r1_S0 ! drho_dS fit T**2 coef. [kg m-3 ppt-1 degC-2] +real, parameter :: BET120 = EOS220*r1_S0 ! drho_dS fit zs * T**2 coef. [kg m-3 ppt-1 degC-2] +real, parameter :: BET220 = 1.5*EOS320*r1_S0 ! drho_dS fit zs**2 * T**2 coef. [kg m-3 ppt-1 degC-2] +real, parameter :: BET320 = 2.0*EOS420*r1_S0 ! drho_dS fit zs**3 * T**2 coef. [kg m-3 ppt-1 degC-2] +real, parameter :: BET030 = 0.5*EOS130*r1_S0 ! drho_dS fit T**3 coef. [kg m-3 ppt-1 degC-3] +real, parameter :: BET130 = EOS230*r1_S0 ! drho_dS fit zs * T**3 coef. [kg m-3 ppt-1 degC-3] +real, parameter :: BET230 = 1.5*EOS330*r1_S0 ! drho_dS fit zs**2 * T**3 coef. [kg m-3 ppt-1 degC-3] +real, parameter :: BET040 = 0.5*EOS140*r1_S0 ! drho_dS fit T**4 coef. [kg m-3 ppt-1 degC-4] +real, parameter :: BET140 = EOS240*r1_S0 ! drho_dS fit zs * T**4 coef. [kg m-3 ppt-1 degC-4] +real, parameter :: BET050 = 0.5*EOS150*r1_S0 ! drho_dS fit T**5 coef. [kg m-3 ppt-1 degC-5] +real, parameter :: BET001 = 0.5*EOS101*r1_S0 ! drho_dS fit P coef. [kg m-3 ppt-1 Pa-1] +real, parameter :: BET101 = EOS201*r1_S0 ! drho_dS fit zs * P coef. [kg m-3 ppt-1 Pa-1] +real, parameter :: BET201 = 1.5*EOS301*r1_S0 ! drho_dS fit zs**2 * P coef. [kg m-3 ppt-1 Pa-1] +real, parameter :: BET301 = 2.0*EOS401*r1_S0 ! drho_dS fit zs**3 * P coef. [kg m-3 ppt-1 Pa-1] +real, parameter :: BET011 = 0.5*EOS111*r1_S0 ! drho_dS fit T * P coef. [kg m-3 ppt-1 degC-1 Pa-1] +real, parameter :: BET111 = EOS211*r1_S0 ! drho_dS fit zs * T * P coef. [kg m-3 ppt-1 degC-1 Pa-1] +real, parameter :: BET211 = 1.5*EOS311*r1_S0 ! drho_dS fit zs**2 * T * P coef. [kg m-3 ppt-1 degC-1 Pa-1] +real, parameter :: BET021 = 0.5*EOS121*r1_S0 ! drho_dS fit T**2 * P coef. [kg m-3 ppt-1 degC-2 Pa-1] +real, parameter :: BET121 = EOS221*r1_S0 ! drho_dS fit zs * T**2 * P coef. [kg m-3 ppt-1 degC-2 Pa-1] +real, parameter :: BET031 = 0.5*EOS131*r1_S0 ! drho_dS fit T**3 * P coef. [kg m-3 ppt-1 degC-3 Pa-1] +real, parameter :: BET002 = 0.5*EOS102*r1_S0 ! drho_dS fit P**2 coef. [kg m-3 ppt-1 Pa-2] +real, parameter :: BET102 = EOS202*r1_S0 ! drho_dS fit zs * P**2 coef. [kg m-3 ppt-1 Pa-2] +real, parameter :: BET012 = 0.5*EOS112*r1_S0 ! drho_dS fit T * P**2 coef. [kg m-3 ppt-1 degC-1 Pa-2] +real, parameter :: BET003 = 0.5*EOS103*r1_S0 ! drho_dS fit P**3 coef. [kg m-3 ppt-1 Pa-3] +!>@} + +!> The EOS_base implementation of the Roquet et al., 2015, equation of state +type, extends (EOS_base) :: Roquet_rho_EOS + +contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_Roquet_rho + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_Roquet_rho + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_Roquet_rho + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_Roquet_rho + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_Roquet_rho + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_Roquet_rho + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_Roquet_rho + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_Roquet_rho + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_Roquet_rho + + !> Local implementation of generic calculate_density_array for efficiency + procedure :: calculate_density_array => calculate_density_array_Roquet_rho + !> Local implementation of generic calculate_spec_vol_array for efficiency + procedure :: calculate_spec_vol_array => calculate_spec_vol_array_Roquet_rho + +end type Roquet_rho_EOS + +contains + +!> In situ density of sea water from Roquet et al., 2015 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_elem_Roquet_rho(this, T, S, pressure) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + + ! Local variables + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: rho00p ! A pressure-dependent but temperature and salinity independent contribution to + ! density at the reference temperature and salinity [kg m-3] + real :: rhoTS ! Density without a pressure-dependent contribution [kg m-3] + real :: rhoTS0 ! A contribution to density from temperature and salinity anomalies at the + ! surface pressure [kg m-3] + real :: rhoTS1 ! A density contribution proportional to pressure [kg m-3 Pa-1] + real :: rhoTS2 ! A density contribution proportional to pressure**2 [kg m-3 Pa-2] + real :: rhoTS3 ! A density contribution proportional to pressure**3 [kg m-3 Pa-3] + real :: rho0S0 ! Salinity dependent density at the surface pressure and zero temperature [kg m-3] + + ! The following algorithm was published by Roquet et al. (2015), intended for use with NEMO. + + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! practical salinity to conservative temperature and absolute salinity. + ! zt = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + rhoTS3 = EOS003 + (zs*EOS103 + zt*EOS013) + rhoTS2 = EOS002 + (zs*(EOS102 + zs*EOS202) & + + zt*(EOS012 + (zs*EOS112 + zt*EOS022)) ) + rhoTS1 = EOS001 + (zs*(EOS101 + zs*(EOS201 + zs*(EOS301 + zs*EOS401))) & + + zt*(EOS011 + (zs*(EOS111 + zs*(EOS211 + zs*EOS311)) & + + zt*(EOS021 + (zs*(EOS121 + zs*EOS221) & + + zt*(EOS031 + (zs*EOS131 + zt*EOS041)) )) )) ) + rhoTS0 = zt*(EOS010 & + + (zs*(EOS110 + zs*(EOS210 + zs*(EOS310 + zs*(EOS410 + zs*EOS510)))) & + + zt*(EOS020 + (zs*(EOS120 + zs*(EOS220 + zs*(EOS320 + zs*EOS420))) & + + zt*(EOS030 + (zs*(EOS130 + zs*(EOS230 + zs*EOS330)) & + + zt*(EOS040 + (zs*(EOS140 + zs*EOS240) & + + zt*(EOS050 + (zs*EOS150 + zt*EOS060)) )) )) )) ) ) + + rho0S0 = EOS000 + zs*(EOS100 + zs*(EOS200 + zs*(EOS300 + zs*(EOS400 + zs*(EOS500 + zs*EOS600))))) + + rho00p = zp*(R00 + zp*(R01 + zp*(R02 + zp*(R03 + zp*(R04 + zp*R05))))) + + rhoTS = (rhoTS0 + rho0S0) + zp*(rhoTS1 + zp*(rhoTS2 + zp*rhoTS3)) + density_elem_Roquet_rho = rhoTS + rho00p ! In situ density [kg m-3] + +end function density_elem_Roquet_rho + +!> In situ density anomaly of sea water from Roquet et al., 2015 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_anomaly_elem_Roquet_rho(this, T, S, pressure, rho_ref) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: rho_ref !< A reference density [kg m-3] + + ! Local variables + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: rho00p ! A pressure-dependent but temperature and salinity independent contribution to + ! density at the reference temperature and salinity [kg m-3] + real :: rhoTS ! Density without a pressure-dependent contribution [kg m-3] + real :: rhoTS0 ! A contribution to density from temperature and salinity anomalies at the + ! surface pressure [kg m-3] + real :: rhoTS1 ! A density contribution proportional to pressure [kg m-3 Pa-1] + real :: rhoTS2 ! A density contribution proportional to pressure**2 [kg m-3 Pa-2] + real :: rhoTS3 ! A density contribution proportional to pressure**3 [kg m-3 Pa-3] + real :: rho0S0 ! Salinity dependent density at the surface pressure and zero temperature [kg m-3] + + ! The following algorithm was published by Roquet et al. (2015), intended for use with NEMO. + + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! practical salinity to conservative temperature and absolute salinity. + ! zt = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + rhoTS3 = EOS003 + (zs*EOS103 + zt*EOS013) + rhoTS2 = EOS002 + (zs*(EOS102 + zs*EOS202) & + + zt*(EOS012 + (zs*EOS112 + zt*EOS022)) ) + rhoTS1 = EOS001 + (zs*(EOS101 + zs*(EOS201 + zs*(EOS301 + zs*EOS401))) & + + zt*(EOS011 + (zs*(EOS111 + zs*(EOS211 + zs*EOS311)) & + + zt*(EOS021 + (zs*(EOS121 + zs*EOS221) & + + zt*(EOS031 + (zs*EOS131 + zt*EOS041)) )) )) ) + rhoTS0 = zt*(EOS010 & + + (zs*(EOS110 + zs*(EOS210 + zs*(EOS310 + zs*(EOS410 + zs*EOS510)))) & + + zt*(EOS020 + (zs*(EOS120 + zs*(EOS220 + zs*(EOS320 + zs*EOS420))) & + + zt*(EOS030 + (zs*(EOS130 + zs*(EOS230 + zs*EOS330)) & + + zt*(EOS040 + (zs*(EOS140 + zs*EOS240) & + + zt*(EOS050 + (zs*EOS150 + zt*EOS060)) )) )) )) ) ) + + rho0S0 = EOS000 + zs*(EOS100 + zs*(EOS200 + zs*(EOS300 + zs*(EOS400 + zs*(EOS500 + zs*EOS600))))) + + rho00p = zp*(R00 + zp*(R01 + zp*(R02 + zp*(R03 + zp*(R04 + zp*R05))))) + + rho0S0 = rho0S0 - rho_ref + + rhoTS = (rhoTS0 + rho0S0) + zp*(rhoTS1 + zp*(rhoTS2 + zp*rhoTS3)) + density_anomaly_elem_Roquet_rho = rhoTS + rho00p ! In situ density [kg m-3] + +end function density_anomaly_elem_Roquet_rho + +!> In situ specific volume of sea water from Roquet et al., 2015 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_elem_Roquet_rho(this, T, S, pressure) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + + spec_vol_elem_Roquet_rho = 1. / density_elem_Roquet_rho(this, T, S, pressure) + +end function spec_vol_elem_Roquet_rho + +!> In situ specific volume anomaly of sea water from Roquet et al., 2015 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_anomaly_elem_Roquet_rho(this, T, S, pressure, spv_ref) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + spec_vol_anomaly_elem_Roquet_rho = 1. / density_elem_Roquet_rho(this, T, S, pressure) + spec_vol_anomaly_elem_Roquet_rho = spec_vol_anomaly_elem_Roquet_rho - spv_ref + +end function spec_vol_anomaly_elem_Roquet_rho + +!> For a given thermodynamic state, calculate the derivatives of density with conservative +!! temperature and absolute salinity, using the density polynomial fit EOS from Roquet et al. (2015). +elemental subroutine calculate_density_derivs_elem_Roquet_rho(this, T, S, pressure, drho_dT, drho_dS) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1] + real, intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 ppt-1] + + ! Local variables + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: dRdzt0 ! A contribution to the partial derivative of density with temperature [kg m-3 degC-1] + ! from temperature anomalies at the surface pressure + real :: dRdzt1 ! A contribution to the partial derivative of density with temperature [kg m-3 degC-1 Pa-1] + ! proportional to pressure + real :: dRdzt2 ! A contribution to the partial derivative of density with temperature [kg m-3 degC-1 Pa-2] + ! proportional to pressure**2 + real :: dRdzt3 ! A contribution to the partial derivative of density with temperature [kg m-3 degC-1 Pa-3] + ! proportional to pressure**3 + real :: dRdzs0 ! A contribution to the partial derivative of density with + ! salinity [kg m-3 ppt-1] from temperature anomalies at the surface pressure + real :: dRdzs1 ! A contribution to the partial derivative of density with + ! salinity [kg m-3 ppt-1 Pa-1] proportional to pressure + real :: dRdzs2 ! A contribution to the partial derivative of density with + ! salinity [kg m-3 ppt-1 Pa-2] proportional to pressure**2 + real :: dRdzs3 ! A contribution to the partial derivative of density with + ! salinity [kg m-3 ppt-1 Pa-3] proportional to pressure**3 + + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! practical salinity to conservative temperature and absolute salinity. + ! zt = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + ! Find the partial derivative of density with temperature + dRdzt3 = ALP003 + dRdzt2 = ALP002 + (zs*ALP102 + zt*ALP012) + dRdzt1 = ALP001 + (zs*(ALP101 + zs*(ALP201 + zs*ALP301)) & + + zt*(ALP011 + (zs*(ALP111 + zs*ALP211) & + + zt*(ALP021 + (zs*ALP121 + zt*ALP031)) )) ) + dRdzt0 = ALP000 + (zs*(ALP100 + zs*(ALP200 + zs*(ALP300 + zs*(ALP400 + zs*ALP500)))) & + + zt*(ALP010 + (zs*(ALP110 + zs*(ALP210 + zs*(ALP310 + zs*ALP410))) & + + zt*(ALP020 + (zs*(ALP120 + zs*(ALP220 + zs*ALP320)) & + + zt*(ALP030 + (zt*(ALP040 + (zs*ALP140 + zt*ALP050)) & + + zs*(ALP130 + zs*ALP230) )) )) )) ) + + drho_dT = dRdzt0 + zp*(dRdzt1 + zp*(dRdzt2 + zp*dRdzt3)) + + ! Find the partial derivative of density with salinity + dRdzs3 = BET003 + dRdzs2 = BET002 + (zs*BET102 + zt*BET012) + dRdzs1 = BET001 + (zs*(BET101 + zs*(BET201 + zs*BET301)) & + + zt*(BET011 + (zs*(BET111 + zs*BET211) & + + zt*(BET021 + (zs*BET121 + zt*BET031)) )) ) + dRdzs0 = BET000 + (zs*(BET100 + zs*(BET200 + zs*(BET300 + zs*(BET400 + zs*BET500)))) & + + zt*(BET010 + (zs*(BET110 + zs*(BET210 + zs*(BET310 + zs*BET410))) & + + zt*(BET020 + (zs*(BET120 + zs*(BET220 + zs*BET320)) & + + zt*(BET030 + (zt*(BET040 + (zs*BET140 + zt*BET050)) & + + zs*(BET130 + zs*BET230) )) )) )) ) + + ! The division by zs here is because zs = sqrt(S + S0), so drho_dS = dzs_dS * drho_dzs = (0.5 / zs) * drho_dzs + drho_dS = (dRdzs0 + zp*(dRdzs1 + zp*(dRdzs2 + zp * dRdzs3))) / zs + +end subroutine calculate_density_derivs_elem_Roquet_rho + +!> Second derivatives of density with respect to temperature, salinity, and pressure +elemental subroutine calculate_density_second_derivs_elem_Roquet_rho(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 ppt-2] + real, intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 ppt-1 degC-1] + real, intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, intent(inout) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 ppt-1 Pa-1] = [s2 m-2 ppt-1] + real, intent(inout) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + + ! Local variables + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: I_s ! The inverse of zs [nondim] + real :: d2R_p0 ! A contribution to one of the second derivatives that is independent of pressure [various] + real :: d2R_p1 ! A contribution to one of the second derivatives that is proportional to pressure [various] + real :: d2R_p2 ! A contribution to one of the second derivatives that is proportional to pressure**2 [various] + real :: d2R_p3 ! A contribution to one of the second derivatives that is proportional to pressure**3 [various] + + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! practical salinity to conservative temperature and absolute salinity. + ! zt = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + I_s = 1.0 / zs + + ! Find drho_ds_ds + d2R_p3 = -EOS103*I_s**2 + d2R_p2 = -(EOS102 + zt*EOS112)*I_s**2 + d2R_p1 = (3.*EOS301 + (zt*(3.*EOS311) + zs*(8.*EOS401))) & + - ( EOS101 + zt*(EOS111 + zt*(EOS121 + zt*EOS131)) )*I_s**2 + d2R_p0 = (3.*EOS300 + (zs*(8.*EOS400 + zs*(15.*EOS500 + zs*(24.*EOS600))) & + + zt*(3.*EOS310 + (zs*(8.*EOS410 + zs*(15.*EOS510)) & + + zt*(3.*EOS320 + (zs*(8.*EOS420) + zt*(3.*EOS330))) )) )) & + - (EOS100 + zt*(EOS110 + zt*(EOS120 + zt*(EOS130 + zt*(EOS140 + zt*EOS150)))) )*I_s**2 + drho_dS_dS = (0.5*r1_S0)**2 * ((d2R_p0 + zp*(d2R_p1 + zp*(d2R_p2 + zp*d2R_p3))) * I_s) + + ! Find drho_ds_dt + d2R_p2 = EOS112 + d2R_p1 = EOS111 + (zs*(2.*EOS211 + zs*(3.*EOS311)) & + + zt*(2.*EOS121 + (zs*(4.*EOS221) + zt*(3.*EOS131))) ) + d2R_p0 = EOS110 + (zs*(2.*EOS210 + zs*(3.*EOS310 + zs*(4.*EOS410 + zs*(5.*EOS510)))) & + + zt*(2.*EOS120 + (zs*(4.*EOS220 + zs*(6.*EOS320 + zs*(8.*EOS420))) & + + zt*(3.*EOS130 + (zs*(6.*EOS230 + zs*(9.*EOS330)) & + + zt*(4.*EOS140 + (zs*(8.*EOS240) & + + zt*(5.*EOS150))) )) )) ) + drho_ds_dt = (0.5*r1_S0) * ((d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) * I_s) + + ! Find drho_dt_dt + d2R_p2 = 2.*EOS022 + d2R_p1 = 2.*EOS021 + (zs*(2.*EOS121 + zs*(2.*EOS221)) & + + zt*(6.*EOS031 + (zs*(6.*EOS131) + zt*(12.*EOS041))) ) + d2R_p0 = 2.*EOS020 + (zs*(2.*EOS120 + zs*( 2.*EOS220 + zs*( 2.*EOS320 + zs * (2.*EOS420)))) & + + zt*(6.*EOS030 + (zs*( 6.*EOS130 + zs*( 6.*EOS230 + zs * (6.*EOS330))) & + + zt*(12.*EOS040 + (zs*(12.*EOS140 + zs *(12.*EOS240)) & + + zt*(20.*EOS050 + (zs*(20.*EOS150) & + + zt*(30.*EOS060) )) )) )) ) + drho_dt_dt = (d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) + + ! Find drho_ds_dp + d2R_p2 = 3.*EOS103 + d2R_p1 = 2.*EOS102 + (zs*(4.*EOS202) + zt*(2.*EOS112)) + d2R_p0 = EOS101 + (zs*(2.*EOS201 + zs*(3.*EOS301 + zs*(4.*EOS401))) & + + zt*(EOS111 + (zs*(2.*EOS211 + zs*(3.*EOS311)) & + + zt*( EOS121 + (zs*(2.*EOS221) + zt*EOS131)) )) ) + drho_ds_dp = ((d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) * I_s) * (0.5*r1_S0) + + ! Find drho_dt_dp + d2R_p2 = 3.*EOS013 + d2R_p1 = 2.*EOS012 + (zs*(2.*EOS112) + zt*(4.*EOS022)) + d2R_p0 = EOS011 + (zs*(EOS111 + zs*( EOS211 + zs* EOS311)) & + + zt*(2.*EOS021 + (zs*(2.*EOS121 + zs*(2.*EOS221)) & + + zt*(3.*EOS031 + (zs*(3.*EOS131) + zt*(4.*EOS041))) )) ) + drho_dt_dp = (d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) + +end subroutine calculate_density_second_derivs_elem_Roquet_rho + +!> Calculate the partial derivatives of specific volume with temperature and salinity +!! using the density polynomial fit EOS from Roquet et al. (2015). +elemental subroutine calculate_specvol_derivs_elem_Roquet_rho(this, T, S, pressure, dSV_dT, dSV_dS) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 ppt-1] + ! Local variables + real :: rho ! In situ density [kg m-3] + real :: dRho_dT ! Derivative of density with temperature [kg m-3 degC-1] + real :: dRho_dS ! Derivative of density with salinity [kg m-3 ppt-1] + + call this%calculate_density_derivs_elem(T, S, pressure, drho_dT, drho_dS) + rho = this%density_elem(T, S, pressure) + dSV_dT = -dRho_DT/(rho**2) + dSV_dS = -dRho_DS/(rho**2) + +end subroutine calculate_specvol_derivs_elem_Roquet_rho + +!> Compute the in situ density of sea water (rho in [kg m-3]) and the compressibility +!! (drho/dp = C_sound^-2, stored as drho_dp [s2 m-2]) from absolute salinity (sal [g kg-1]), +!! conservative temperature (T [degC]), and pressure [Pa], using the density polynomial +!! fit EOS from Roquet et al. (2015). +elemental subroutine calculate_compress_elem_Roquet_rho(this, T, S, pressure, rho, drho_dp) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: rho !< In situ density [kg m-3] + real, intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [s2 m-2] + ! Local variables + real :: zp ! Pressure [Pa] + real :: zt ! Conservative temperature [degC] + real :: zs ! The square root of absolute salinity with an offset normalized + ! by an assumed salinity range [nondim] + real :: drho00p_dp ! Derivative of the pressure-dependent reference density profile with pressure [kg m-3 Pa-1] + real :: drhoTS_dp ! Derivative of the density anomaly from the reference profile with pressure [kg m-3 Pa-1] + real :: rho00p ! The pressure-dependent (but temperature and salinity independent) reference + ! density profile [kg m-3] + real :: rhoTS ! Density anomaly from the reference profile [kg m-3] + real :: rhoTS0 ! A contribution to density from temperature and salinity anomalies at the + ! surface pressure [kg m-3] + real :: rhoTS1 ! A density contribution proportional to pressure [kg m-3 Pa-1] + real :: rhoTS2 ! A density contribution proportional to pressure**2 [kg m-3 Pa-2] + real :: rhoTS3 ! A density contribution proportional to pressure**3 [kg m-3 Pa-3] + real :: rho0S0 ! Salinity dependent density at the surface pressure and zero temperature [kg m-3] + + ! The following algorithm was published by Roquet et al. (2015), intended for use with NEMO. + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure + + ! The next two lines should be used if it is necessary to convert potential temperature and + ! practical salinity to conservative temperature and absolute salinity. + ! zt = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + rhoTS3 = EOS003 + (zs*EOS103 + zt*EOS013) + rhoTS2 = EOS002 + (zs*(EOS102 + zs*EOS202) & + + zt*(EOS012 + (zs*EOS112 + zt*EOS022)) ) + rhoTS1 = EOS001 + (zs*(EOS101 + zs*(EOS201 + zs*(EOS301 + zs*EOS401))) & + + zt*(EOS011 + (zs*(EOS111 + zs*(EOS211 + zs*EOS311)) & + + zt*(EOS021 + (zs*(EOS121 + zs*EOS221) & + + zt*(EOS031 + (zs*EOS131 + zt*EOS041)) )) )) ) + + rhoTS0 = zt*(EOS010 & + + (zs*(EOS110 + zs*(EOS210 + zs*(EOS310 + zs*(EOS410 + zs*EOS510)))) & + + zt*(EOS020 + (zs*(EOS120 + zs*(EOS220 + zs*(EOS320 + zs*EOS420))) & + + zt*(EOS030 + (zs*(EOS130 + zs*(EOS230 + zs*EOS330)) & + + zt*(EOS040 + (zs*(EOS140 + zs*EOS240) & + + zt*(EOS050 + (zs*EOS150 + zt*EOS060)) )) )) )) ) ) + + rho0S0 = EOS000 + zs*(EOS100 + zs*(EOS200 + zs*(EOS300 + zs*(EOS400 + zs*(EOS500 + zs*EOS600))))) + + rho00p = zp*(R00 + zp*(R01 + zp*(R02 + zp*(R03 + zp*(R04 + zp*R05))))) + + rhoTS = (rhoTS0 + rho0S0) + zp*(rhoTS1 + zp*(rhoTS2 + zp*rhoTS3)) + rho = rhoTS + rho00p ! In situ density [kg m-3] + + drho00p_dp = R00 + zp*(2.*R01 + zp*(3.*R02 + zp*(4.*R03 + zp*(5.*R04 + zp*(6.*R05))))) + drhoTS_dp = rhoTS1 + zp*(2.*rhoTS2 + zp*(3.*rhoTS3)) + drho_dp = drhoTS_dp + drho00p_dp ! Compressibility [s2 m-2] + +end subroutine calculate_compress_elem_Roquet_rho + +!> Return the range of temperatures, salinities and pressures for which the Roquet et al. (2015) +!! expression for in situ density has been fitted to observations. Care should be taken when +!! applying this equation of state outside of its fit range. +subroutine EoS_fit_range_Roquet_rho(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + real, optional, intent(out) :: T_min !< The minimum conservative temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum conservative temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum absolute salinity over which this EoS is fitted [g kg-1] + real, optional, intent(out) :: S_max !< The maximum absolute salinity over which this EoS is fitted [g kg-1] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + if (present(T_min)) T_min = -6.0 + if (present(T_max)) T_max = 40.0 + if (present(S_min)) S_min = 0.0 + if (present(S_max)) S_max = 42.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 1.0e8 + +end subroutine EoS_fit_range_Roquet_rho + +!> Calculate the in-situ density for 1D arraya inputs and outputs. +subroutine calculate_density_array_Roquet_rho(this, T, S, pressure, rho, start, npts, rho_ref) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: rho !< In situ density [kg m-3] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + + ! Local variables + integer :: j + + if (present(rho_ref)) then + do j = start, start+npts-1 + rho(j) = density_anomaly_elem_Roquet_rho(this, T(j), S(j), pressure(j), rho_ref) + enddo + else + do j = start, start+npts-1 + rho(j) = density_elem_Roquet_rho(this, T(j), S(j), pressure(j)) + enddo + endif + +end subroutine calculate_density_array_Roquet_rho + +!> Calculate the in-situ specific volume for 1D array inputs and outputs. +subroutine calculate_spec_vol_array_Roquet_rho(this, T, S, pressure, specvol, start, npts, spv_ref) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: specvol !< In situ specific volume [m3 kg-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + ! Local variables + integer :: j + + if (present(spv_ref)) then + do j = start, start+npts-1 + specvol(j) = spec_vol_anomaly_elem_Roquet_rho(this, T(j), S(j), pressure(j), spv_ref) + enddo + else + do j = start, start+npts-1 + specvol(j) = spec_vol_elem_Roquet_rho(this, T(j), S(j), pressure(j) ) + enddo + endif + +end subroutine calculate_spec_vol_array_Roquet_rho + +!> \namespace mom_eos_Roquet_rho +!! +!! \section section_EOS_Roquet_rho Roquet_rho equation of state +!! +!! Fabien Roquet and colleagues developed this equation of state using a simple polynomial fit +!! to the TEOS-10 equation of state, for efficiency when used in the NEMO ocean model. Fabien +!! Roquet also graciously provided the MOM6 team with the original code implementing this +!! equation of state, although it has since been modified and extended to have capabilities +!! mirroring those available with other equations of state in MOM6. This particular equation +!! of state is a balance between an accuracy that matches the TEOS-10 density to better than +!! observational uncertainty with a polynomial form that can be evaluated quickly despite having +!! 52 terms. +!! +!! \subsection section_EOS_Roquet_rho_references References +!! +!! Roquet, F., Madec, G., McDougall, T. J., and Barker, P. M., 2015: +!! Accurate polynomial expressions for the density and specific volume +!! of seawater using the TEOS-10 standard. Ocean Modelling, 90:29-43. + +end module MOM_EOS_Roquet_rho diff --git a/src/equation_of_state/MOM_EOS_TEOS10.F90 b/src/equation_of_state/MOM_EOS_TEOS10.F90 index bbe9982b6f..9f63dd9b3b 100644 --- a/src/equation_of_state/MOM_EOS_TEOS10.F90 +++ b/src/equation_of_state/MOM_EOS_TEOS10.F90 @@ -1,342 +1,247 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> The equation of state using the TEOS10 expressions module MOM_EOS_TEOS10 -! This file is part of MOM6. See LICENSE.md for the license. - -!*********************************************************************** -!* The subroutines in this file implement the equation of state for * -!* sea water using the TEOS10 functions * -!*********************************************************************** - -use gsw_mod_toolbox, only : gsw_sp_from_sr, gsw_pt_from_ct +use gsw_mod_toolbox, only : gsw_sp_from_sr, gsw_pt_from_ct, gsw_sr_from_sp, gsw_ct_from_pt use gsw_mod_toolbox, only : gsw_rho, gsw_specvol use gsw_mod_toolbox, only : gsw_rho_first_derivatives, gsw_specvol_first_derivatives use gsw_mod_toolbox, only : gsw_rho_second_derivatives -!use gsw_mod_toolbox, only : gsw_sr_from_sp, gsw_ct_from_pt +use MOM_EOS_base_type, only : EOS_base implicit none ; private -public calculate_compress_teos10, calculate_density_teos10, calculate_spec_vol_teos10 -public calculate_density_derivs_teos10 -public calculate_specvol_derivs_teos10 -public calculate_density_second_derivs_teos10 -public gsw_sp_from_sr, gsw_pt_from_ct - -!> Compute the in situ density of sea water ([kg m-3]), or its anomaly with respect to -!! a reference density, from absolute salinity (g/kg), conservative temperature (in deg C), -!! and pressure [Pa], using the TEOS10 expressions. -interface calculate_density_teos10 - module procedure calculate_density_scalar_teos10, calculate_density_array_teos10 -end interface calculate_density_teos10 - -!> Compute the in situ specific volume of sea water (in [m3 kg-1]), or an anomaly with respect -!! to a reference specific volume, from absolute salinity (in g/kg), conservative temperature -!! (in deg C), and pressure [Pa], using the TEOS10 expressions. -interface calculate_spec_vol_teos10 - module procedure calculate_spec_vol_scalar_teos10, calculate_spec_vol_array_teos10 -end interface calculate_spec_vol_teos10 - -!> For a given thermodynamic state, return the derivatives of density with conservative temperature -!! and absolute salinity, using the TEOS10 expressions. -interface calculate_density_derivs_teos10 - module procedure calculate_density_derivs_scalar_teos10, calculate_density_derivs_array_teos10 -end interface calculate_density_derivs_teos10 - -!> For a given thermodynamic state, return the second derivatives of density with various combinations -!! of conservative temperature, absolute salinity, and pressure, using the TEOS10 expressions. -interface calculate_density_second_derivs_teos10 - module procedure calculate_density_second_derivs_scalar_teos10, calculate_density_second_derivs_array_teos10 -end interface calculate_density_second_derivs_teos10 - -real, parameter :: Pa2db = 1.e-4 !< The conversion factor from Pa to dbar. - -contains +public gsw_sp_from_sr, gsw_pt_from_ct, gsw_sr_from_sp, gsw_ct_from_pt +public TEOS10_EOS -!> This subroutine computes the in situ density of sea water (rho in -!! [kg m-3]) from absolute salinity (S [g kg-1]), conservative temperature -!! (T [degC]), and pressure [Pa]. It uses the expression from the -!! TEOS10 website. -subroutine calculate_density_scalar_teos10(T, S, pressure, rho, rho_ref) - real, intent(in) :: T !< Conservative temperature [degC]. - real, intent(in) :: S !< Absolute salinity [g kg-1]. - real, intent(in) :: pressure !< pressure [Pa]. - real, intent(out) :: rho !< In situ density [kg m-3]. - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. +real, parameter :: Pa2db = 1.e-4 !< The conversion factor from Pa to dbar [dbar Pa-1] - ! Local variables - real, dimension(1) :: T0, S0, pressure0 - real, dimension(1) :: rho0 +!> The EOS_base implementation of the TEOS10 equation of state +type, extends (EOS_base) :: TEOS10_EOS - T0(1) = T - S0(1) = S - pressure0(1) = pressure +contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_TEOS10 + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_TEOS10 + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_TEOS10 + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_TEOS10 + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_TEOS10 + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_TEOS10 + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_TEOS10 + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_TEOS10 + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_TEOS10 + +end type TEOS10_EOS - call calculate_density_array_teos10(T0, S0, pressure0, rho0, 1, 1, rho_ref) - rho = rho0(1) +contains -end subroutine calculate_density_scalar_teos10 +!> GSW in situ density [kg m-3] +real elemental function density_elem_TEOS10(this, T, S, pressure) + class(TEOS10_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC]. + real, intent(in) :: S !< Absolute salinity [g kg-1]. + real, intent(in) :: pressure !< pressure [Pa]. -!> This subroutine computes the in situ density of sea water (rho in -!! [kg m-3]) from absolute salinity (S [g kg-1]), conservative temperature -!! (T [degC]), and pressure [Pa]. It uses the expression from the -!! TEOS10 website. -subroutine calculate_density_array_teos10(T, S, pressure, rho, start, npts, rho_ref) - real, dimension(:), intent(in) :: T !< Conservative temperature [degC]. - real, dimension(:), intent(in) :: S !< Absolute salinity [g kg-1] - real, dimension(:), intent(in) :: pressure !< pressure [Pa]. - real, dimension(:), intent(out) :: rho !< in situ density [kg m-3]. - integer, intent(in) :: start !< the starting point in the arrays. - integer, intent(in) :: npts !< the number of values to calculate. - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. + density_elem_TEOS10 = gsw_rho(S, T, pressure * Pa2db) - ! Local variables - real :: zs, zt, zp - integer :: j - - do j=start,start+npts-1 - !Conversions - zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity - zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potantial temp to conservative temp - zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar - - if (S(j) < -1.0e-10) then !Can we assume safely that this is a missing value? - rho(j) = 1000.0 - else - rho(j) = gsw_rho(zs,zt,zp) - endif - if (present(rho_ref)) rho(j) = rho(j) - rho_ref - enddo -end subroutine calculate_density_array_teos10 - -!> This subroutine computes the in situ specific volume of sea water (specvol in -!! [m3 kg-1]) from absolute salinity (S [g kg-1]), conservative temperature (T [degC]) -!! and pressure [Pa], using the TEOS10 equation of state. -!! If spv_ref is present, specvol is an anomaly from spv_ref. -subroutine calculate_spec_vol_scalar_teos10(T, S, pressure, specvol, spv_ref) - real, intent(in) :: T !< Conservative temperature [degC]. - real, intent(in) :: S !< Absolute salinity [g kg-1] - real, intent(in) :: pressure !< pressure [Pa]. - real, intent(out) :: specvol !< in situ specific volume [m3 kg-1]. - real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. +end function density_elem_TEOS10 - ! Local variables - real, dimension(1) :: T0, S0, pressure0, spv0 +!> GSW in situ density anomaly [kg m-3] +real elemental function density_anomaly_elem_TEOS10(this, T, S, pressure, rho_ref) + class(TEOS10_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC]. + real, intent(in) :: S !< Absolute salinity [g kg-1]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(in) :: rho_ref !< A reference density [kg m-3]. - T0(1) = T ; S0(1) = S ; pressure0(1) = pressure + density_anomaly_elem_TEOS10 = gsw_rho(S, T, pressure * Pa2db) + density_anomaly_elem_TEOS10 = density_anomaly_elem_TEOS10 - rho_ref - call calculate_spec_vol_array_teos10(T0, S0, pressure0, spv0, 1, 1, spv_ref) - specvol = spv0(1) -end subroutine calculate_spec_vol_scalar_teos10 +end function density_anomaly_elem_TEOS10 +!> GSW in situ specific volume [m3 kg-1] +real elemental function spec_vol_elem_TEOS10(this, T, S, pressure) + class(TEOS10_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC]. + real, intent(in) :: S !< Absolute salinity [g kg-1]. + real, intent(in) :: pressure !< pressure [Pa]. -!> This subroutine computes the in situ specific volume of sea water (specvol in -!! [m3 kg-1]) from absolute salinity (S [g kg-1]), conservative temperature (T [degC]) -!! and pressure [Pa], using the TEOS10 equation of state. -!! If spv_ref is present, specvol is an anomaly from spv_ref. -subroutine calculate_spec_vol_array_teos10(T, S, pressure, specvol, start, npts, spv_ref) - real, dimension(:), intent(in) :: T !< Conservative temperature relative to the surface - !! [degC]. - real, dimension(:), intent(in) :: S !< salinity [g kg-1]. - real, dimension(:), intent(in) :: pressure !< pressure [Pa]. - real, dimension(:), intent(out) :: specvol !< in situ specific volume [m3 kg-1]. - integer, intent(in) :: start !< the starting point in the arrays. - integer, intent(in) :: npts !< the number of values to calculate. - real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + spec_vol_elem_TEOS10 = gsw_specvol(S, T, pressure * Pa2db) - ! Local variables - real :: zs, zt, zp - integer :: j +end function spec_vol_elem_TEOS10 - do j=start,start+npts-1 - !Conversions - zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity - zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potantial temp to conservative temp - zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar +!> GSW in situ specific volume anomaly [m3 kg-1] +real elemental function spec_vol_anomaly_elem_TEOS10(this, T, S, pressure, spv_ref) + class(TEOS10_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC]. + real, intent(in) :: S !< Absolute salinity [g kg-1]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. - if (S(j) < -1.0e-10) then - specvol(j) = 0.001 !Can we assume safely that this is a missing value? - else - specvol(j) = gsw_specvol(zs,zt,zp) - endif - if (present(spv_ref)) specvol(j) = specvol(j) - spv_ref - enddo + spec_vol_anomaly_elem_TEOS10 = gsw_specvol(S, T, pressure * Pa2db) - spv_ref -end subroutine calculate_spec_vol_array_teos10 +end function spec_vol_anomaly_elem_TEOS10 !> For a given thermodynamic state, calculate the derivatives of density with conservative !! temperature and absolute salinity, using the TEOS10 expressions. -subroutine calculate_density_derivs_array_teos10(T, S, pressure, drho_dT, drho_dS, start, npts) - real, intent(in), dimension(:) :: T !< Conservative temperature [degC]. - real, intent(in), dimension(:) :: S !< Absolute salinity [g kg-1]. - real, intent(in), dimension(:) :: pressure !< pressure [Pa]. - real, intent(out), dimension(:) :: drho_dT !< The partial derivative of density with conservative - !! temperature [kg m-3 degC-1]. - real, intent(out), dimension(:) :: drho_dS !< The partial derivative of density with absolute salinity, - !! [kg m-3 (g/kg)-1]. - integer, intent(in) :: start !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. - +elemental subroutine calculate_density_derivs_elem_TEOS10(this, T, S, pressure, drho_dT, drho_dS) + class(TEOS10_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] = [ppt] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: drho_dT !< The partial derivative of density with conservative + !! temperature [kg m-3 degC-1] + real, intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 ppt-1] ! Local variables - real :: zs, zt, zp - integer :: j - - do j=start,start+npts-1 - !Conversions - zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity - zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potantial temp to conservative temp - zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar - if (S(j) < -1.0e-10) then ; !Can we assume safely that this is a missing value? - drho_dT(j) = 0.0 ; drho_dS(j) = 0.0 - else - call gsw_rho_first_derivatives(zs, zt, zp, drho_dsa=drho_dS(j), drho_dct=drho_dT(j)) - endif - enddo - -end subroutine calculate_density_derivs_array_teos10 - -!> For a given thermodynamic state, calculate the derivatives of density with conservative -!! temperature and absolute salinity, using the TEOS10 expressions. -subroutine calculate_density_derivs_scalar_teos10(T, S, pressure, drho_dT, drho_dS) - real, intent(in) :: T !< Conservative temperature [degC] - real, intent(in) :: S !< Absolute Salinity [g kg-1] - real, intent(in) :: pressure !< pressure [Pa]. - real, intent(out) :: drho_dT !< The partial derivative of density with conservative - !! temperature [kg m-3 degC-1]. - real, intent(out) :: drho_dS !< The partial derivative of density with absolute salinity, - !! [kg m-3 (g/kg)-1]. + real :: zs ! Absolute salinity [g kg-1] + real :: zt ! Conservative temperature [degC] + real :: zp ! Pressure converted to decibars [dbar] + + ! Conversions + zs = S + zt = T + zp = pressure * Pa2db ! Convert pressure from Pascal to decibar + ! The following conversions are unnecessary because the arguments are already the right variables. + ! zs = gsw_sr_from_sp(S) ! Uncomment to convert practical salinity to absolute salinity + ! zt = gsw_ct_from_pt(S,T) ! Uncomment to convert potential temp to conservative temp - ! Local variables - real :: zs, zt, zp - !Conversions - zs = S !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity - zt = T !gsw_ct_from_pt(S,T) !Convert potantial temp to conservative temp - zp = pressure* Pa2db !Convert pressure from Pascal to decibar - if (S < -1.0e-10) return !Can we assume safely that this is a missing value? call gsw_rho_first_derivatives(zs, zt, zp, drho_dsa=drho_dS, drho_dct=drho_dT) -end subroutine calculate_density_derivs_scalar_teos10 - -!> For a given thermodynamic state, calculate the derivatives of specific volume with conservative -!! temperature and absolute salinity, using the TEOS10 expressions. -subroutine calculate_specvol_derivs_teos10(T, S, pressure, dSV_dT, dSV_dS, start, npts) - real, intent(in), dimension(:) :: T !< Conservative temperature [degC]. - real, intent(in), dimension(:) :: S !< Absolute salinity [g kg-1]. - real, intent(in), dimension(:) :: pressure !< pressure [Pa]. - real, intent(out), dimension(:) :: dSV_dT !< The partial derivative of specific volume with - !! conservative temperature [m3 kg-1 degC-1]. - real, intent(out), dimension(:) :: dSV_dS !< The partial derivative of specific volume with - !! absolute salinity [m3 kg-1 (g/kg)-1]. - integer, intent(in) :: start !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. - ! Local variables - real :: zs, zt, zp - integer :: j - - do j=start,start+npts-1 - !Conversions - zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity - zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potantial temp to conservative temp - zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar - if (S(j) < -1.0e-10) then ; !Can we assume safely that this is a missing value? - dSV_dT(j) = 0.0 ; dSV_dS(j) = 0.0 - else - call gsw_specvol_first_derivatives(zs,zt,zp, v_sa=dSV_dS(j), v_ct=dSV_dT(j)) - endif - enddo - -end subroutine calculate_specvol_derivs_teos10 +end subroutine calculate_density_derivs_elem_TEOS10 !> Calculate the 5 second derivatives of the equation of state for scalar inputs -subroutine calculate_density_second_derivs_scalar_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, & - drho_dT_dT, drho_dS_dP, drho_dT_dP) - real, intent(in) :: T !< Conservative temperature [degC] - real, intent(in) :: S !< Absolute Salinity [g kg-1] - real, intent(in) :: pressure !< pressure [Pa]. - real, intent(out) :: drho_dS_dS !< Partial derivative of beta with respect to S - real, intent(out) :: drho_dS_dT !< Partial derivative of beta with resepct to T - real, intent(out) :: drho_dT_dT !< Partial derivative of alpha with respect to T - real, intent(out) :: drho_dS_dP !< Partial derivative of beta with respect to pressure - real, intent(out) :: drho_dT_dP !< Partial derivative of alpha with respect to pressure - +elemental subroutine calculate_density_second_derivs_elem_TEOS10(this, T, S, pressure, & + drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP) + class(TEOS10_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] = [ppt] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 ppt-2] + real, intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 ppt-1 degC-1] + real, intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, intent(inout) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 ppt-1 Pa-1] = [s2 m-2 ppt-1] + real, intent(inout) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] ! Local variables - real :: zs, zt, zp + real :: zs ! Absolute salinity [g kg-1] + real :: zt ! Conservative temperature [degC] + real :: zp ! Pressure converted to decibars [dbar] + + ! Conversions + zs = S + zt = T + zp = pressure * Pa2db ! Convert pressure from Pascal to decibar + ! The following conversions are unnecessary because the arguments are already the right variables. + ! zs = gsw_sr_from_sp(S) ! Uncomment to convert practical salinity to absolute salinity + ! zt = gsw_ct_from_pt(S,T) ! Uncomment to convert potential temp to conservative temp - !Conversions - zs = S !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity - zt = T !gsw_ct_from_pt(S,T) !Convert potantial temp to conservative temp - zp = pressure* Pa2db !Convert pressure from Pascal to decibar - if (S < -1.0e-10) return !Can we assume safely that this is a missing value? call gsw_rho_second_derivatives(zs, zt, zp, rho_sa_sa=drho_dS_dS, rho_sa_ct=drho_dS_dT, & - rho_ct_ct=drho_dT_dT, rho_sa_p=drho_dS_dP, rho_ct_p=drho_dT_dP) + rho_ct_ct=drho_dT_dT, rho_sa_p=drho_dS_dP, rho_ct_p=drho_dT_dP) -end subroutine calculate_density_second_derivs_scalar_teos10 - -!> Calculate the 5 second derivatives of the equation of state for scalar inputs -subroutine calculate_density_second_derivs_array_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, & - drho_dT_dT, drho_dS_dP, drho_dT_dP, start, npts) - real, dimension(:), intent(in) :: T !< Conservative temperature [degC] - real, dimension(:), intent(in) :: S !< Absolute Salinity [g kg-1] - real, dimension(:), intent(in) :: pressure !< pressure [Pa]. - real, dimension(:), intent(out) :: drho_dS_dS !< Partial derivative of beta with respect to S - real, dimension(:), intent(out) :: drho_dS_dT !< Partial derivative of beta with resepct to T - real, dimension(:), intent(out) :: drho_dT_dT !< Partial derivative of alpha with respect to T - real, dimension(:), intent(out) :: drho_dS_dP !< Partial derivative of beta with respect to pressure - real, dimension(:), intent(out) :: drho_dT_dP !< Partial derivative of alpha with respect to pressure - integer, intent(in) :: start !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. +end subroutine calculate_density_second_derivs_elem_TEOS10 +!> For a given thermodynamic state, calculate the derivatives of specific volume with conservative +!! temperature and absolute salinity, using the TEOS10 expressions. +elemental subroutine calculate_specvol_derivs_elem_TEOS10(this, T, S, pressure, dSV_dT, dSV_dS) + class(TEOS10_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] = [ppt] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! conservative temperature [m3 kg-1 degC-1] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! absolute salinity [m3 kg-1 ppt-1] ! Local variables - real :: zs, zt, zp - integer :: j - - do j=start,start+npts-1 - !Conversions - zs = S(j) !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity - zt = T(j) !gsw_ct_from_pt(S,T) !Convert potantial temp to conservative temp - zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar - if (S(j) < -1.0e-10) then ; !Can we assume safely that this is a missing value? - drho_dS_dS(j) = 0.0 ; drho_dS_dT(j) = 0.0 ; drho_dT_dT(j) = 0.0 - drho_dS_dP(j) = 0.0 ; drho_dT_dP(j) = 0.0 - else - call gsw_rho_second_derivatives(zs, zt, zp, rho_sa_sa=drho_dS_dS(j), rho_sa_ct=drho_dS_dT(j), & - rho_ct_ct=drho_dT_dT(j), rho_sa_p=drho_dS_dP(j), rho_ct_p=drho_dT_dP(j)) - endif - enddo - -end subroutine calculate_density_second_derivs_array_teos10 + real :: zs ! Absolute salinity [g kg-1] + real :: zt ! Conservative temperature [degC] + real :: zp ! Pressure converted to decibars [dbar] + + ! Conversions + zs = S + zt = T + zp = pressure * Pa2db ! Convert pressure from Pascal to decibar + ! The following conversions are unnecessary because the arguments are already the right variables. + ! zs = gsw_sr_from_sp(S) ! Uncomment to convert practical salinity to absolute salinity + ! zt = gsw_ct_from_pt(S,T) ! Uncomment to convert potential temp to conservative temp + + call gsw_specvol_first_derivatives(zs, zt, zp, v_sa=dSV_dS, v_ct=dSV_dT) + +end subroutine calculate_specvol_derivs_elem_TEOS10 !> This subroutine computes the in situ density of sea water (rho in !! [kg m-3]) and the compressibility (drho/dp = C_sound^-2) -!! (drho_dp [s2 m-2]) from absolute salinity (sal in g/kg), +!! (drho_dp [s2 m-2]) from absolute salinity (sal [g kg-1]), !! conservative temperature (T [degC]), and pressure [Pa]. It uses the !! subroutines from TEOS10 website -subroutine calculate_compress_teos10(T, S, pressure, rho, drho_dp, start, npts) - real, intent(in), dimension(:) :: T !< Conservative temperature [degC]. - real, intent(in), dimension(:) :: S !< Absolute salinity [g kg-1]. - real, intent(in), dimension(:) :: pressure !< Pressure [Pa]. - real, intent(out), dimension(:) :: rho !< In situ density [kg m-3]. - real, intent(out), dimension(:) :: drho_dp !< The partial derivative of density with pressure - !! (also the inverse of the square of sound speed) - !! [s2 m-2]. - integer, intent(in) :: start !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. +elemental subroutine calculate_compress_elem_TEOS10(this, T, S, pressure, rho, drho_dp) + class(TEOS10_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: rho !< In situ density [kg m-3] + real, intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [s2 m-2] ! Local variables - real :: zs,zt,zp - integer :: j - - do j=start,start+npts-1 - !Conversions - zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity - zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potantial temp to conservative temp - zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar - if (S(j) < -1.0e-10) then ; !Can we assume safely that this is a missing value? - rho(j) = 1000.0 ; drho_dp(j) = 0.0 - else - rho(j) = gsw_rho(zs,zt,zp) - call gsw_rho_first_derivatives(zs,zt,zp, drho_dp=drho_dp(j)) - endif - enddo -end subroutine calculate_compress_teos10 + real :: zs ! Absolute salinity [g kg-1] + real :: zt ! Conservative temperature [degC] + real :: zp ! Pressure converted to decibars [dbar] + + ! Conversions + zs = S + zt = T + zp = pressure * Pa2db ! Convert pressure from Pascal to decibar + ! The following conversions are unnecessary because the arguments are already the right variables. + ! zs = gsw_sr_from_sp(S) ! Uncomment to convert practical salinity to absolute salinity + ! zt = gsw_ct_from_pt(S,T) ! Uncomment to convert potential temp to conservative temp + + rho = gsw_rho(zs, zt, zp) + call gsw_rho_first_derivatives(zs, zt, zp, drho_dp=drho_dp) + +end subroutine calculate_compress_elem_TEOS10 + +!> Return the range of temperatures, salinities and pressures for which the TEOS-10 +!! equation of state has been fitted to observations. Care should be taken when +!! applying this equation of state outside of its fit range. +subroutine EoS_fit_range_teos10(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(TEOS10_EOS), intent(in) :: this !< This EOS + real, optional, intent(out) :: T_min !< The minimum conservative temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum conservative temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum absolute salinity over which this EoS is fitted [g kg-1] + real, optional, intent(out) :: S_max !< The maximum absolute salinity over which this EoS is fitted [g kg-1] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + if (present(T_min)) T_min = -6.0 + if (present(T_max)) T_max = 40.0 + if (present(S_min)) S_min = 0.0 + if (present(S_max)) S_max = 42.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 1.0e8 + +end subroutine EoS_fit_range_teos10 + +!> \namespace mom_eos_teos10 +!! +!! \section section_EOS_TEOS10 TEOS10 equation of state +!! +!! The TEOS10 equation of state is implemented via the GSW toolbox. We recommend using the +!! Roquet et al. forms of this equation of state. end module MOM_EOS_TEOS10 diff --git a/src/equation_of_state/MOM_EOS_UNESCO.F90 b/src/equation_of_state/MOM_EOS_UNESCO.F90 index a296cfc382..93ac54d0ac 100644 --- a/src/equation_of_state/MOM_EOS_UNESCO.F90 +++ b/src/equation_of_state/MOM_EOS_UNESCO.F90 @@ -1,339 +1,586 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> The equation of state using the Jackett and McDougall fits to the UNESCO EOS module MOM_EOS_UNESCO -! This file is part of MOM6. See LICENSE.md for the license. - -!*********************************************************************** -!* The subroutines in this file implement the equation of state for * -!* sea water using the fit to the UNESCO equation of state given by * -!* the expressions from Jackett and McDougall, 1995, J. Atmos. * -!* Ocean. Tech., 12, 381-389. Coded by J. Stephens, 9/99. * -!*********************************************************************** +use MOM_EOS_base_type, only : EOS_base implicit none ; private -public calculate_compress_UNESCO, calculate_density_UNESCO, calculate_spec_vol_UNESCO -public calculate_density_derivs_UNESCO -public calculate_density_scalar_UNESCO, calculate_density_array_UNESCO - -!> Compute the in situ density of sea water (in [kg m-3]), or its anomaly with respect to -!! a reference density, from salinity [PSU], potential temperature [degC], and pressure [Pa], -!! using the UNESCO (1981) equation of state. -interface calculate_density_UNESCO - module procedure calculate_density_scalar_UNESCO, calculate_density_array_UNESCO -end interface calculate_density_UNESCO - -!> Compute the in situ specific volume of sea water (in [m3 kg-1]), or an anomaly with respect -!! to a reference specific volume, from salinity [PSU], potential temperature [degC], and -!! pressure [Pa], using the UNESCO (1981) equation of state. -interface calculate_spec_vol_UNESCO - module procedure calculate_spec_vol_scalar_UNESCO, calculate_spec_vol_array_UNESCO -end interface calculate_spec_vol_UNESCO - -!>@{ Parameters in the UNESCO equation of state -! The following constants are used to calculate rho0. The notation -! is Rab for the contribution to rho0 from T^aS^b. -real, parameter :: R00 = 999.842594, R10 = 6.793952e-2, R20 = -9.095290e-3, & - R30 = 1.001685e-4, R40 = -1.120083e-6, R50 = 6.536332e-9, R01 = 0.824493, & - R11 = -4.0899e-3, R21 = 7.6438e-5, R31 = -8.2467e-7, R41 = 5.3875e-9, & - R032 = -5.72466e-3, R132 = 1.0227e-4, R232 = -1.6546e-6, R02 = 4.8314e-4 - -! The following constants are used to calculate the secant bulk mod- -! ulus. The notation here is Sab for terms proportional to T^a*S^b, -! Spab for terms proportional to p*T^a*S^b, and SPab for terms -! proportional to p^2*T^a*S^b. -real, parameter :: S00 = 1.965933e4, S10 = 1.444304e2, S20 = -1.706103, & - S30 = 9.648704e-3, S40 = -4.190253e-5, S01 = 52.84855, S11 = -3.101089e-1, & - S21 = 6.283263e-3, S31 = -5.084188e-5, S032 = 3.886640e-1, S132 = 9.085835e-3, & - S232 = -4.619924e-4, Sp00 = 3.186519, Sp10 = 2.212276e-2, Sp20 = -2.984642e-4, & - Sp30 = 1.956415e-6, Sp01 = 6.704388e-3, Sp11 = -1.847318e-4, Sp21 = 2.059331e-7, & - Sp032 = 1.480266e-4, SP000 = 2.102898e-4, SP010 = -1.202016e-5, SP020 = 1.394680e-7, & - SP001 = -2.040237e-6, SP011 = 6.128773e-8, SP021 = 6.207323e-10 +public UNESCO_EOS + +!>@{ Parameters in the UNESCO equation of state, as published in appendix A3 of Gill, 1982. +! The following constants are used to calculate rho0, the density of seawater at 1 atmosphere pressure. +! The notation is Rab for the contribution to rho0 from S^a*T^b, with 6 used for the 1.5 power. +real, parameter :: R00 = 999.842594 ! A coefficient in the fit for rho0 [kg m-3] +real, parameter :: R01 = 6.793952e-2 ! A coefficient in the fit for rho0 [kg m-3 degC-1] +real, parameter :: R02 = -9.095290e-3 ! A coefficient in the fit for rho0 [kg m-3 degC-2] +real, parameter :: R03 = 1.001685e-4 ! A coefficient in the fit for rho0 [kg m-3 degC-3] +real, parameter :: R04 = -1.120083e-6 ! A coefficient in the fit for rho0 [kg m-3 degC-4] +real, parameter :: R05 = 6.536332e-9 ! A coefficient in the fit for rho0 [kg m-3 degC-5] +real, parameter :: R10 = 0.824493 ! A coefficient in the fit for rho0 [kg m-3 PSU-1] +real, parameter :: R11 = -4.0899e-3 ! A coefficient in the fit for rho0 [kg m-3 degC-1 PSU-1] +real, parameter :: R12 = 7.6438e-5 ! A coefficient in the fit for rho0 [kg m-3 degC-2 PSU-1] +real, parameter :: R13 = -8.2467e-7 ! A coefficient in the fit for rho0 [kg m-3 degC-3 PSU-1] +real, parameter :: R14 = 5.3875e-9 ! A coefficient in the fit for rho0 [kg m-3 degC-4 PSU-1] +real, parameter :: R60 = -5.72466e-3 ! A coefficient in the fit for rho0 [kg m-3 PSU-1.5] +real, parameter :: R61 = 1.0227e-4 ! A coefficient in the fit for rho0 [kg m-3 degC-1 PSU-1.5] +real, parameter :: R62 = -1.6546e-6 ! A coefficient in the fit for rho0 [kg m-3 degC-2 PSU-1.5] +real, parameter :: R20 = 4.8314e-4 ! A coefficient in the fit for rho0 [kg m-3 PSU-2] + +! The following constants are used to calculate the secant bulk modulus. +! The notation here is Sabc for terms proportional to S^a*T^b*P^c, with 6 used for the 1.5 power. +! Note that these values differ from those in Appendix 3 of Gill (1982) because the expressions +! from Jackett and MacDougall (1995) use potential temperature, rather than in situ temperature. +real, parameter :: S000 = 1.965933e4 ! A coefficient in the secant bulk modulus fit [bar] +real, parameter :: S010 = 1.444304e2 ! A coefficient in the secant bulk modulus fit [bar degC-1] +real, parameter :: S020 = -1.706103 ! A coefficient in the secant bulk modulus fit [bar degC-2] +real, parameter :: S030 = 9.648704e-3 ! A coefficient in the secant bulk modulus fit [bar degC-3] +real, parameter :: S040 = -4.190253e-5 ! A coefficient in the secant bulk modulus fit [bar degC-4] +real, parameter :: S100 = 52.84855 ! A coefficient in the secant bulk modulus fit [bar PSU-1] +real, parameter :: S110 = -3.101089e-1 ! A coefficient in the secant bulk modulus fit [bar degC-1 PSU-1] +real, parameter :: S120 = 6.283263e-3 ! A coefficient in the secant bulk modulus fit [bar degC-2 PSU-1] +real, parameter :: S130 = -5.084188e-5 ! A coefficient in the secant bulk modulus fit [bar degC-3 PSU-1] +real, parameter :: S600 = 3.886640e-1 ! A coefficient in the secant bulk modulus fit [bar PSU-1.5] +real, parameter :: S610 = 9.085835e-3 ! A coefficient in the secant bulk modulus fit [bar degC-1 PSU-1.5] +real, parameter :: S620 = -4.619924e-4 ! A coefficient in the secant bulk modulus fit [bar degC-2 PSU-1.5] + +real, parameter :: S001 = 3.186519 ! A coefficient in the secant bulk modulus fit [nondim] +real, parameter :: S011 = 2.212276e-2 ! A coefficient in the secant bulk modulus fit [degC-1] +real, parameter :: S021 = -2.984642e-4 ! A coefficient in the secant bulk modulus fit [degC-2] +real, parameter :: S031 = 1.956415e-6 ! A coefficient in the secant bulk modulus fit [degC-3] +real, parameter :: S101 = 6.704388e-3 ! A coefficient in the secant bulk modulus fit [PSU-1] +real, parameter :: S111 = -1.847318e-4 ! A coefficient in the secant bulk modulus fit [degC-1 PSU-1] +real, parameter :: S121 = 2.059331e-7 ! A coefficient in the secant bulk modulus fit [degC-2 PSU-1] +real, parameter :: S601 = 1.480266e-4 ! A coefficient in the secant bulk modulus fit [PSU-1.5] + +real, parameter :: S002 = 2.102898e-4 ! A coefficient in the secant bulk modulus fit [bar-1] +real, parameter :: S012 = -1.202016e-5 ! A coefficient in the secant bulk modulus fit [bar-1 degC-1] +real, parameter :: S022 = 1.394680e-7 ! A coefficient in the secant bulk modulus fit [bar-1 degC-2] +real, parameter :: S102 = -2.040237e-6 ! A coefficient in the secant bulk modulus fit [bar-1 PSU-1] +real, parameter :: S112 = 6.128773e-8 ! A coefficient in the secant bulk modulus fit [bar-1 degC-1 PSU-1] +real, parameter :: S122 = 6.207323e-10 ! A coefficient in the secant bulk modulus fit [bar-1 degC-2 PSU-1] !>@} +!> The EOS_base implementation of the UNESCO equation of state +type, extends (EOS_base) :: UNESCO_EOS + contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_UNESCO + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_UNESCO + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_UNESCO + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_UNESCO + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_UNESCO + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_UNESCO + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_UNESCO + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_UNESCO + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_UNESCO + +end type UNESCO_EOS -!> This subroutine computes the in situ density of sea water (rho in -!! [kg m-3]) from salinity (S [PSU]), potential temperature -!! (T [degC]), and pressure [Pa], using the UNESCO (1981) equation of state. -subroutine calculate_density_scalar_UNESCO(T, S, pressure, rho, rho_ref) - real, intent(in) :: T !< Potential temperature relative to the surface [degC]. - real, intent(in) :: S !< Salinity [PSU]. - real, intent(in) :: pressure !< pressure [Pa]. - real, intent(out) :: rho !< In situ density [kg m-3]. - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. +contains - ! Local variables - real, dimension(1) :: T0, S0, pressure0 - real, dimension(1) :: rho0 - - T0(1) = T - S0(1) = S - pressure0(1) = pressure - - call calculate_density_array_UNESCO(T0, S0, pressure0, rho0, 1, 1, rho_ref) - rho = rho0(1) - -end subroutine calculate_density_scalar_UNESCO - -!> This subroutine computes the in situ density of sea water (rho in -!! [kg m-3]) from salinity (S [PSU]), potential temperature -!! (T [degC]), and pressure [Pa], using the UNESCO (1981) equation of state. -subroutine calculate_density_array_UNESCO(T, S, pressure, rho, start, npts, rho_ref) - real, dimension(:), intent(in) :: T !< potential temperature relative to the surface [degC]. - real, dimension(:), intent(in) :: S !< salinity [PSU]. - real, dimension(:), intent(in) :: pressure !< pressure [Pa]. - real, dimension(:), intent(out) :: rho !< in situ density [kg m-3]. - integer, intent(in) :: start !< the starting point in the arrays. - integer, intent(in) :: npts !< the number of values to calculate. - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. +!> In situ density as fit by Jackett and McDougall, 1995 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_elem_UNESCO(this, T, S, pressure) + class(UNESCO_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] ! Local variables - real :: t_local, t2, t3, t4, t5 ! Temperature to the 1st - 5th power [degC^n]. - real :: s_local, s32, s2 ! Salinity to the 1st, 3/2, & 2nd power [PSU^n]. - real :: p1, p2 ! Pressure (in bars) to the 1st and 2nd power [bar] and [bar2]. - real :: rho0 ! Density at 1 bar pressure [kg m-3]. - real :: sig0 ! The anomaly of rho0 from R00 [kg m-3]. - real :: ks ! The secant bulk modulus [bar]. - integer :: j - - do j=start,start+npts-1 - if (S(j) < -1.0e-10) then !Can we assume safely that this is a missing value? - rho(j) = 1000.0 - cycle - endif - - p1 = pressure(j)*1.0e-5; p2 = p1*p1 - t_local = T(j); t2 = t_local*t_local; t3 = t_local*t2; t4 = t2*t2; t5 = t3*t2 - s_local = S(j); s2 = s_local*s_local; s32 = s_local*sqrt(s_local) - -! Compute rho(s,theta,p=0) - (same as rho(s,t_insitu,p=0) ). - - sig0 = R10*t_local + R20*t2 + R30*t3 + R40*t4 + R50*t5 + & - s_local*(R01 + R11*t_local + R21*t2 + R31*t3 + R41*t4) + & - s32*(R032 + R132*t_local + R232*t2) + R02*s2 - rho0 = R00 + sig0 - -! Compute rho(s,theta,p), first calculating the secant bulk modulus. - - ks = S00 + S10*t_local + S20*t2 + S30*t3 + S40*t4 + s_local*(S01 + S11*t_local + S21*t2 + S31*t3) + & - s32*(S032 + S132*t_local + S232*t2) + & - p1*(Sp00 + Sp10*t_local + Sp20*t2 + Sp30*t3 + & - s_local*(Sp01 + Sp11*t_local + Sp21*t2) + Sp032*s32) + & - p2*(SP000 + SP010*t_local + SP020*t2 + s_local*(SP001 + SP011*t_local + SP021*t2)) - - if (present(rho_ref)) then - rho(j) = ((R00 - rho_ref)*ks + (sig0*ks + p1*rho_ref)) / (ks - p1) - else - rho(j) = rho0*ks / (ks - p1) - endif - enddo -end subroutine calculate_density_array_UNESCO - -!> This subroutine computes the in situ specific volume of sea water (specvol in -!! [m3 kg-1]) from salinity (S [PSU]), potential temperature (T [degC]) -!! and pressure [Pa], using the UNESCO (1981) equation of state. -!! If spv_ref is present, specvol is an anomaly from spv_ref. -subroutine calculate_spec_vol_scalar_UNESCO(T, S, pressure, specvol, spv_ref) - real, intent(in) :: T !< potential temperature relative to the surface - !! [degC]. - real, intent(in) :: S !< salinity [PSU]. - real, intent(in) :: pressure !< pressure [Pa]. - real, intent(out) :: specvol !< in situ specific volume [m3 kg-1]. - real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + real :: t1 ! A copy of the temperature at a point [degC] + real :: s1 ! A copy of the salinity at a point [PSU] + real :: p1 ! Pressure converted to bars [bar] + real :: s12 ! The square root of salinity [PSU1/2] + real :: rho0 ! Density at 1 bar pressure [kg m-3] + real :: sig0 ! The anomaly of rho0 from R00 [kg m-3] + real :: ks ! The secant bulk modulus [bar] + + p1 = pressure*1.0e-5 ; t1 = T + s1 = max(S, 0.0) ; s12 = sqrt(s1) + + ! Compute rho(s,theta,p=0) - (same as rho(s,t_insitu,p=0) ). + sig0 = ( t1*(R01 + t1*(R02 + t1*(R03 + t1*(R04 + t1*R05)))) + & + s1*((R10 + t1*(R11 + t1*(R12 + t1*(R13 + t1*R14)))) + & + (s12*(R60 + t1*(R61 + t1*R62)) + s1*R20)) ) + rho0 = R00 + sig0 + + ! Compute rho(s,theta,p), first calculating the secant bulk modulus. + ks = (S000 + ( t1*(S010 + t1*(S020 + t1*(S030 + t1*S040))) + & + s1*((S100 + t1*(S110 + t1*(S120 + t1*S130))) + s12*(S600 + t1*(S610 + t1*S620))) )) + & + p1*( (S001 + ( t1*(S011 + t1*(S021 + t1*S031)) + & + s1*((S101 + t1*(S111 + t1*S121)) + s12*S601) )) + & + p1*(S002 + ( t1*(S012 + t1*S022) + s1*(S102 + t1*(S112 + t1*S122)) )) ) + + density_elem_UNESCO = rho0*ks / (ks - p1) + +end function density_elem_UNESCO + +!> In situ density anomaly as fit by Jackett and McDougall, 1995 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_anomaly_elem_UNESCO(this, T, S, pressure, rho_ref) + class(UNESCO_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: rho_ref !< A reference density [kg m-3] ! Local variables - real, dimension(1) :: T0, S0, pressure0, spv0 - - T0(1) = T ; S0(1) = S ; pressure0(1) = pressure - - call calculate_spec_vol_array_UNESCO(T0, S0, pressure0, spv0, 1, 1, spv_ref) - specvol = spv0(1) -end subroutine calculate_spec_vol_scalar_UNESCO - -!> This subroutine computes the in situ specific volume of sea water (specvol in -!! [m3 kg-1]) from salinity (S [PSU]), potential temperature (T [degC]) -!! and pressure [Pa], using the UNESCO (1981) equation of state. -!! If spv_ref is present, specvol is an anomaly from spv_ref. -subroutine calculate_spec_vol_array_UNESCO(T, S, pressure, specvol, start, npts, spv_ref) - real, dimension(:), intent(in) :: T !< potential temperature relative to the surface - !! [degC]. - real, dimension(:), intent(in) :: S !< salinity [PSU]. - real, dimension(:), intent(in) :: pressure !< pressure [Pa]. - real, dimension(:), intent(out) :: specvol !< in situ specific volume [m3 kg-1]. - integer, intent(in) :: start !< the starting point in the arrays. - integer, intent(in) :: npts !< the number of values to calculate. - real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + real :: t1 ! A copy of the temperature at a point [degC] + real :: s1 ! A copy of the salinity at a point [PSU] + real :: p1 ! Pressure converted to bars [bar] + real :: s12 ! The square root of salinity [PSU1/2] + real :: rho0 ! Density at 1 bar pressure [kg m-3] + real :: sig0 ! The anomaly of rho0 from R00 [kg m-3] + real :: ks ! The secant bulk modulus [bar] + + p1 = pressure*1.0e-5 ; t1 = T + s1 = max(S, 0.0) ; s12 = sqrt(s1) + + ! Compute rho(s,theta,p=0) - (same as rho(s,t_insitu,p=0) ). + sig0 = ( t1*(R01 + t1*(R02 + t1*(R03 + t1*(R04 + t1*R05)))) + & + s1*((R10 + t1*(R11 + t1*(R12 + t1*(R13 + t1*R14)))) + & + (s12*(R60 + t1*(R61 + t1*R62)) + s1*R20)) ) + rho0 = R00 + sig0 + + ! Compute rho(s,theta,p), first calculating the secant bulk modulus. + ks = (S000 + ( t1*(S010 + t1*(S020 + t1*(S030 + t1*S040))) + & + s1*((S100 + t1*(S110 + t1*(S120 + t1*S130))) + s12*(S600 + t1*(S610 + t1*S620))) )) + & + p1*( (S001 + ( t1*(S011 + t1*(S021 + t1*S031)) + & + s1*((S101 + t1*(S111 + t1*S121)) + s12*S601) )) + & + p1*(S002 + ( t1*(S012 + t1*S022) + s1*(S102 + t1*(S112 + t1*S122)) )) ) + + density_anomaly_elem_UNESCO = ((R00 - rho_ref)*ks + (sig0*ks + p1*rho_ref)) / (ks - p1) + +end function density_anomaly_elem_UNESCO + +!> In situ specific volume as fit by Jackett and McDougall, 1995 [m3 kg-1] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_elem_UNESCO(this, T, S, pressure) + class(UNESCO_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] ! Local variables - real :: t_local, t2, t3, t4, t5 ! Temperature to the 1st - 5th power [degC^n]. - real :: s_local, s32, s2 ! Salinity to the 1st, 3/2, & 2nd power [PSU^n]. - real :: p1, p2 ! Pressure (in bars) to the 1st and 2nd power [bar] and [bar2]. - real :: rho0 ! Density at 1 bar pressure [kg m-3]. - real :: ks ! The secant bulk modulus [bar]. - integer :: j - - do j=start,start+npts-1 - if (S(j) < -1.0e-10) then !Can we assume safely that this is a missing value? - specvol(j) = 0.001 - if (present(spv_ref)) specvol(j) = 0.001 - spv_ref - cycle - endif - - p1 = pressure(j)*1.0e-5; p2 = p1*p1 - t_local = T(j); t2 = t_local*t_local; t3 = t_local*t2; t4 = t2*t2; t5 = t3*t2 - s_local = S(j); s2 = s_local*s_local; s32 = s_local*sqrt(s_local) - -! Compute rho(s,theta,p=0) - (same as rho(s,t_insitu,p=0) ). - - rho0 = R00 + R10*t_local + R20*t2 + R30*t3 + R40*t4 + R50*t5 + & - s_local*(R01 + R11*t_local + R21*t2 + R31*t3 + R41*t4) + & - s32*(R032 + R132*t_local + R232*t2) + R02*s2 - -! Compute rho(s,theta,p), first calculating the secant bulk modulus. - - ks = S00 + S10*t_local + S20*t2 + S30*t3 + S40*t4 + s_local*(S01 + S11*t_local + S21*t2 + S31*t3) + & - s32*(S032 + S132*t_local + S232*t2) + & - p1*(Sp00 + Sp10*t_local + Sp20*t2 + Sp30*t3 + & - s_local*(Sp01 + Sp11*t_local + Sp21*t2) + Sp032*s32) + & - p2*(SP000 + SP010*t_local + SP020*t2 + s_local*(SP001 + SP011*t_local + SP021*t2)) - - if (present(spv_ref)) then - specvol(j) = (ks*(1.0 - (rho0*spv_ref)) - p1) / (rho0*ks) - else - specvol(j) = (ks - p1) / (rho0*ks) - endif - enddo -end subroutine calculate_spec_vol_array_UNESCO - - -!> This subroutine calculates the partial derivatives of density -!! with potential temperature and salinity. -subroutine calculate_density_derivs_UNESCO(T, S, pressure, drho_dT, drho_dS, start, npts) - real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface - !! [degC]. - real, intent(in), dimension(:) :: S !< Salinity [PSU]. - real, intent(in), dimension(:) :: pressure !< Pressure [Pa]. - real, intent(out), dimension(:) :: drho_dT !< The partial derivative of density with potential - !! temperature [kg m-3 degC-1]. - real, intent(out), dimension(:) :: drho_dS !< The partial derivative of density with salinity, - !! in [kg m-3 PSU-1]. - integer, intent(in) :: start !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. + real :: t1 ! A copy of the temperature at a point [degC] + real :: s1 ! A copy of the salinity at a point [PSU] + real :: p1 ! Pressure converted to bars [bar] + real :: s12 ! The square root of salinity [PSU1/2]l553 + real :: rho0 ! Density at 1 bar pressure [kg m-3] + real :: ks ! The secant bulk modulus [bar] + + p1 = pressure*1.0e-5 ; t1 = T + s1 = max(S, 0.0) ; s12 = sqrt(s1) + + ! Compute rho(s,theta,p=0), which is the same as rho(s,t_insitu,p=0). + rho0 = R00 + ( t1*(R01 + t1*(R02 + t1*(R03 + t1*(R04 + t1*R05)))) + & + s1*((R10 + t1*(R11 + t1*(R12 + t1*(R13 + t1*R14)))) + & + (s12*(R60 + t1*(R61 + t1*R62)) + s1*R20)) ) + + ! Compute rho(s,theta,p), first calculating the secant bulk modulus. + ks = (S000 + ( t1*(S010 + t1*(S020 + t1*(S030 + t1*S040))) + & + s1*((S100 + t1*(S110 + t1*(S120 + t1*S130))) + s12*(S600 + t1*(S610 + t1*S620))) )) + & + p1*( (S001 + ( t1*(S011 + t1*(S021 + t1*S031)) + & + s1*((S101 + t1*(S111 + t1*S121)) + s12*S601) )) + & + p1*(S002 + ( t1*(S012 + t1*S022) + s1*(S102 + t1*(S112 + t1*S122)) )) ) + + spec_vol_elem_UNESCO = (ks - p1) / (rho0*ks) + +end function spec_vol_elem_UNESCO + +!> In situ specific volume anomaly as fit by Jackett and McDougall, 1995 [m3 kg-1] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_anomaly_elem_UNESCO(this, T, S, pressure, spv_ref) + class(UNESCO_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] ! Local variables - real :: t_local, t2, t3, t4, t5 ! Temperature to the 1st - 5th power [degC^n]. - real :: s12, s_local, s32, s2 ! Salinity to the 1/2 - 2nd powers [PSU^n]. - real :: p1, p2 ! Pressure to the 1st & 2nd power [bar] and [bar2]. - real :: rho0 ! Density at 1 bar pressure [kg m-3]. - real :: ks ! The secant bulk modulus [bar]. - real :: drho0_dT ! Derivative of rho0 with T [kg m-3 degC-1]. - real :: drho0_dS ! Derivative of rho0 with S [kg m-3 PSU-1]. - real :: dks_dT ! Derivative of ks with T [bar degC-1]. - real :: dks_dS ! Derivative of ks with S [bar psu-1]. - real :: denom ! 1.0 / (ks - p1) [bar-1]. - integer :: j - - do j=start,start+npts-1 - if (S(j) < -1.0e-10) then !Can we assume safely that this is a missing value? - drho_dT(j) = 0.0 ; drho_dS(j) = 0.0 - cycle - endif - - p1 = pressure(j)*1.0e-5; p2 = p1*p1 - t_local = T(j); t2 = t_local*t_local; t3 = t_local*t2; t4 = t2*t2; t5 = t3*t2 - s_local = S(j); s2 = s_local*s_local; s12 = sqrt(s_local); s32 = s_local*s12 - -! compute rho(s,theta,p=0) - (same as rho(s,t_insitu,p=0) ) - - rho0 = R00 + R10*t_local + R20*t2 + R30*t3 + R40*t4 + R50*t5 + & - s_local*(R01 + R11*t_local + R21*t2 + R31*t3 + R41*t4) + & - s32*(R032 + R132*t_local + R232*t2) + R02*s2 - drho0_dT = R10 + 2.0*R20*t_local + 3.0*R30*t2 + 4.0*R40*t3 + 5.0*R50*t4 + & - s_local*(R11 + 2.0*R21*t_local + 3.0*R31*t2 + 4.0*R41*t3) + & - s32*(R132 + 2.0*R232*t_local) - drho0_dS = (R01 + R11*t_local + R21*t2 + R31*t3 + R41*t4) + & - 1.5*s12*(R032 + R132*t_local + R232*t2) + 2.0*R02*s_local - -! compute rho(s,theta,p) - - ks = S00 + S10*t_local + S20*t2 + S30*t3 + S40*t4 + s_local*(S01 + S11*t_local + S21*t2 + S31*t3) + & - s32*(S032 + S132*t_local + S232*t2) + & - p1*(Sp00 + Sp10*t_local + Sp20*t2 + Sp30*t3 + & - s_local*(Sp01 + Sp11*t_local + Sp21*t2) + Sp032*s32) + & - p2*(SP000 + SP010*t_local + SP020*t2 + s_local*(SP001 + SP011*t_local + SP021*t2)) - dks_dT = S10 + 2.0*S20*t_local + 3.0*S30*t2 + 4.0*S40*t3 + & - s_local*(S11 + 2.0*S21*t_local + 3.0*S31*t2) + s32*(S132 + 2.0*S232*t_local) + & - p1*(Sp10 + 2.0*Sp20*t_local + 3.0*Sp30*t2 + s_local*(Sp11 + 2.0*Sp21*t_local)) + & - p2*(SP010 + 2.0*SP020*t_local + s_local*(SP011 + 2.0*SP021*t_local)) - dks_dS = (S01 + S11*t_local + S21*t2 + S31*t3) + 1.5*s12*(S032 + S132*t_local + S232*t2) + & - p1*(Sp01 + Sp11*t_local + Sp21*t2 + 1.5*Sp032*s12) + & - p2*(SP001 + SP011*t_local + SP021*t2) - - denom = 1.0 / (ks - p1) - drho_dT(j) = denom*(ks*drho0_dT - rho0*p1*denom*dks_dT) - drho_dS(j) = denom*(ks*drho0_dS - rho0*p1*denom*dks_dS) - enddo - -end subroutine calculate_density_derivs_UNESCO - -!> This subroutine computes the in situ density of sea water (rho) -!! and the compressibility (drho/dp == C_sound^-2) at the given -!! salinity, potential temperature, and pressure. -subroutine calculate_compress_UNESCO(T, S, pressure, rho, drho_dp, start, npts) - real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface - !! [degC]. - real, intent(in), dimension(:) :: S !< Salinity [PSU]. - real, intent(in), dimension(:) :: pressure !< Pressure [Pa]. - real, intent(out), dimension(:) :: rho !< In situ density [kg m-3]. - real, intent(out), dimension(:) :: drho_dp !< The partial derivative of density with pressure - !! (also the inverse of the square of sound speed) - !! [s2 m-2]. - integer, intent(in) :: start !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. - + real :: t1 ! A copy of the temperature at a point [degC] + real :: s1 ! A copy of the salinity at a point [PSU] + real :: p1 ! Pressure converted to bars [bar] + real :: s12 ! The square root of salinity [PSU1/2] + real :: rho0 ! Density at 1 bar pressure [kg m-3] + real :: ks ! The secant bulk modulus [bar] + + p1 = pressure*1.0e-5 ; t1 = T + s1 = max(S, 0.0) ; s12 = sqrt(s1) + + ! Compute rho(s,theta,p=0), which is the same as rho(s,t_insitu,p=0). + rho0 = R00 + ( t1*(R01 + t1*(R02 + t1*(R03 + t1*(R04 + t1*R05)))) + & + s1*((R10 + t1*(R11 + t1*(R12 + t1*(R13 + t1*R14)))) + & + (s12*(R60 + t1*(R61 + t1*R62)) + s1*R20)) ) + + ! Compute rho(s,theta,p), first calculating the secant bulk modulus. + ks = (S000 + ( t1*(S010 + t1*(S020 + t1*(S030 + t1*S040))) + & + s1*((S100 + t1*(S110 + t1*(S120 + t1*S130))) + s12*(S600 + t1*(S610 + t1*S620))) )) + & + p1*( (S001 + ( t1*(S011 + t1*(S021 + t1*S031)) + & + s1*((S101 + t1*(S111 + t1*S121)) + s12*S601) )) + & + p1*(S002 + ( t1*(S012 + t1*S022) + s1*(S102 + t1*(S112 + t1*S122)) )) ) + + spec_vol_anomaly_elem_UNESCO = (ks*(1.0 - (rho0*spv_ref)) - p1) / (rho0*ks) + +end function spec_vol_anomaly_elem_UNESCO + +!> Calculate the partial derivatives of density with potential temperature and salinity +!! using the UNESCO (1981) equation of state, as refit by Jackett and McDougall (1995). +elemental subroutine calculate_density_derivs_elem_UNESCO(this, T, S, pressure, drho_dT, drho_dS) + class(UNESCO_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1] + real, intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 PSU-1] ! Local variables - real :: t_local, t2, t3, t4, t5 ! Temperature to the 1st - 5th power [degC^n]. - real :: s_local, s32, s2 ! Salinity to the 1st, 3/2, & 2nd power [PSU^n]. - real :: p1, p2 ! Pressure to the 1st & 2nd power [bar] and [bar2]. - real :: rho0 ! Density at 1 bar pressure [kg m-3]. - real :: ks ! The secant bulk modulus [bar]. - real :: ks_0, ks_1, ks_2 - real :: dks_dp ! The derivative of the secant bulk modulus - ! with pressure, nondimensional. - integer :: j - - do j=start,start+npts-1 - if (S(j) < -1.0e-10) then !Can we assume safely that this is a missing value? - rho(j) = 1000.0 ; drho_dP(j) = 0.0 - cycle - endif - - p1 = pressure(j)*1.0e-5; p2 = p1*p1 - t_local = T(j); t2 = t_local*t_local; t3 = t_local*t2; t4 = t2*t2; t5 = t3*t2 - s_local = S(j); s2 = s_local*s_local; s32 = s_local*sqrt(s_local) - -! Compute rho(s,theta,p=0) - (same as rho(s,t_insitu,p=0) ). - - rho0 = R00 + R10*t_local + R20*t2 + R30*t3 + R40*t4 + R50*t5 + & - s_local*(R01 + R11*t_local + R21*t2 + R31*t3 + R41*t4) + & - s32*(R032 + R132*t_local + R232*t2) + R02*s2 - -! Compute rho(s,theta,p), first calculating the secant bulk modulus. - ks_0 = S00 + S10*t_local + S20*t2 + S30*t3 + S40*t4 + & - s_local*(S01 + S11*t_local + S21*t2 + S31*t3) + s32*(S032 + S132*t_local + S232*t2) - ks_1 = Sp00 + Sp10*t_local + Sp20*t2 + Sp30*t3 + & - s_local*(Sp01 + Sp11*t_local + Sp21*t2) + Sp032*s32 - ks_2 = SP000 + SP010*t_local + SP020*t2 + s_local*(SP001 + SP011*t_local + SP021*t2) - - ks = ks_0 + p1*ks_1 + p2*ks_2 - dks_dp = ks_1 + 2.0*p1*ks_2 - - rho(j) = rho0*ks / (ks - p1) -! The factor of 1.0e-5 is because pressure here is in bars, not Pa. - drho_dp(j) = 1.0e-5 * (rho(j) / (ks - p1)) * (1.0 - dks_dp*p1/ks) - enddo -end subroutine calculate_compress_UNESCO + real :: t1 ! A copy of the temperature at a point [degC] + real :: s1 ! A copy of the salinity at a point [PSU] + real :: p1 ! Pressure converted to bars [bar] + real :: s12 ! The square root of salinity [PSU1/2] + real :: rho0 ! Density at 1 bar pressure [kg m-3] + real :: ks ! The secant bulk modulus [bar] + real :: drho0_dT ! Derivative of rho0 with T [kg m-3 degC-1] + real :: drho0_dS ! Derivative of rho0 with S [kg m-3 PSU-1] + real :: dks_dT ! Derivative of ks with T [bar degC-1] + real :: dks_dS ! Derivative of ks with S [bar psu-1] + real :: I_denom ! 1.0 / (ks - p1) [bar-1] + + p1 = pressure*1.0e-5 ; t1 = T + s1 = max(S, 0.0) ; s12 = sqrt(s1) + + ! Compute rho(s,theta,p=0) and its derivatives with temperature and salinity + rho0 = R00 + ( t1*(R01 + t1*(R02 + t1*(R03 + t1*(R04 + t1*R05)))) + & + s1*((R10 + t1*(R11 + t1*(R12 + t1*(R13 + t1*R14)))) + & + (s12*(R60 + t1*(R61 + t1*R62)) + s1*R20)) ) + drho0_dT = R01 + ( t1*(2.0*R02 + t1*(3.0*R03 + t1*(4.0*R04 + t1*(5.0*R05)))) + & + s1*(R11 + (t1*(2.0*R12 + t1*(3.0*R13 + t1*(4.0*R14))) + & + s12*(R61 + t1*(2.0*R62)) )) ) + drho0_dS = R10 + ( t1*(R11 + t1*(R12 + t1*(R13 + t1*R14))) + & + (1.5*(s12*(R60 + t1*(R61 + t1*R62))) + s1*(2.0*R20)) ) + + ! Compute the secant bulk modulus and its derivatives with temperature and salinity + ks = ( S000 + (t1*(S010 + t1*(S020 + t1*(S030 + t1*S040))) + & + s1*((S100 + t1*(S110 + t1*(S120 + t1*S130))) + s12*(S600 + t1*(S610 + t1*S620)))) ) + & + p1*( (S001 + ( t1*(S011 + t1*(S021 + t1*S031)) + & + s1*((S101 + t1*(S111 + t1*S121)) + s12*S601) )) + & + p1*(S002 + ( t1*(S012 + t1*S022) + s1*(S102 + t1*(S112 + t1*S122)) )) ) + dks_dT = ( S010 + (t1*(2.0*S020 + t1*(3.0*S030 + t1*(4.0*S040))) + & + s1*((S110 + t1*(2.0*S120 + t1*(3.0*S130))) + s12*(S610 + t1*(2.0*S620)))) ) + & + p1*(((S011 + t1*(2.0*S021 + t1*(3.0*S031))) + s1*(S111 + t1*(2.0*S121)) ) + & + p1*(S012 + t1*(2.0*S022) + s1*(S112 + t1*(2.0*S122))) ) + dks_dS = ( S100 + (t1*(S110 + t1*(S120 + t1*S130)) + 1.5*(s12*(S600 + t1*(S610 + t1*S620)))) ) + & + p1*((S101 + t1*(S111 + t1*S121) + s12*(1.5*S601)) + & + p1*(S102 + t1*(S112 + t1*S122)) ) + + I_denom = 1.0 / (ks - p1) + drho_dT = (ks*drho0_dT - dks_dT*((rho0*p1)*I_denom)) * I_denom + drho_dS = (ks*drho0_dS - dks_dS*((rho0*p1)*I_denom)) * I_denom + +end subroutine calculate_density_derivs_elem_UNESCO + +!> Calculate second derivatives of density with respect to temperature, salinity, and pressure, +!! using the UNESCO (1981) equation of state, as refit by Jackett and McDougall (1995) +elemental subroutine calculate_density_second_derivs_elem_UNESCO(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + class(UNESCO_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature referenced to 0 dbar [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, intent(inout) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, intent(inout) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + ! Local variables + real :: t1 ! A copy of the temperature at a point [degC] + real :: s1 ! A copy of the salinity at a point [PSU] + real :: p1 ! Pressure converted to bars [bar] + real :: s12 ! The square root of salinity [PSU1/2] + real :: I_s12 ! The inverse of the square root of salinity [PSU-1/2] + real :: rho0 ! Density at 1 bar pressure [kg m-3] + real :: drho0_dT ! Derivative of rho0 with T [kg m-3 degC-1] + real :: drho0_dS ! Derivative of rho0 with S [kg m-3 PSU-1] + real :: d2rho0_dS2 ! Second derivative of rho0 with salinity [kg m-3 PSU-1] + real :: d2rho0_dSdT ! Second derivative of rho0 with temperature and salinity [kg m-3 degC-1 PSU-1] + real :: d2rho0_dT2 ! Second derivative of rho0 with temperature [kg m-3 degC-2] + real :: ks ! The secant bulk modulus [bar] + real :: ks_0 ! The secant bulk modulus at zero pressure [bar] + real :: ks_1 ! The linear pressure dependence of the secant bulk modulus at zero pressure [nondim] + real :: ks_2 ! The quadratic pressure dependence of the secant bulk modulus at zero pressure [bar-1] + real :: dks_dp ! The derivative of the secant bulk modulus with pressure [nondim] + real :: dks_dT ! Derivative of the secant bulk modulus with temperature [bar degC-1] + real :: dks_dS ! Derivative of the secant bulk modulus with salinity [bar psu-1] + real :: d2ks_dT2 ! Second derivative of the secant bulk modulus with temperature [bar degC-2] + real :: d2ks_dSdT ! Second derivative of the secant bulk modulus with salinity and temperature [bar psu-1 degC-1] + real :: d2ks_dS2 ! Second derivative of the secant bulk modulus with salinity [bar psu-2] + real :: d2ks_dSdp ! Second derivative of the secant bulk modulus with salinity and pressure [psu-1] + real :: d2ks_dTdp ! Second derivative of the secant bulk modulus with temperature and pressure [degC-1] + real :: I_denom ! The inverse of the denominator of the expression for density [bar-1] + + p1 = pressure*1.0e-5 ; t1 = T + s1 = max(S, 0.0) ; s12 = sqrt(s1) + ! The UNESCO equation of state is a fit to density, but it chooses a form that exhibits a + ! singularity in the second derivatives with salinity for fresh water. To avoid this, the + ! square root of salinity can be treated with a floor such that the contribution from the + ! S**1.5 terms to both the surface density and the secant bulk modulus are lost to roundoff. + ! This salinity is given by (~1e-16*S000/S600)**(2/3) ~= 3e-8 PSU, or S12 ~= 1.7e-4 + I_s12 = 1.0 / (max(s12, 1.0e-4)) + + ! Calculate the density at sea level pressure and its derivatives + rho0 = R00 + ( t1*(R01 + t1*(R02 + t1*(R03 + t1*(R04 + t1*R05)))) + & + s1*((R10 + t1*(R11 + t1*(R12 + t1*(R13 + t1*R14)))) + & + (s12*(R60 + t1*(R61 + t1*R62)) + s1*R20)) ) + drho0_dT = R01 + ( t1*(2.0*R02 + t1*(3.0*R03 + t1*(4.0*R04 + t1*(5.0*R05)))) + & + s1*(R11 + ( t1*(2.0*R12 + t1*(3.0*R13 + t1*(4.0*R14))) + & + s12*(R61 + t1*(2.0*R62)) ) ) ) + drho0_dS = R10 + ( t1*(R11 + t1*(R12 + t1*(R13 + t1*R14))) + & + (1.5*(s12*(R60 + t1*(R61 + t1*R62))) + s1*(2.0*R20)) ) + d2rho0_dS2 = 0.75*(R60 + t1*(R61 + t1*R62))*I_s12 + 2.0*R20 + d2rho0_dSdT = R11 + ( t1*(2.0*R12 + t1*(3.0*R13 + t1*(4.0*R14))) + s12*(1.5*R61 + t1*(3.0*R62)) ) + d2rho0_dT2 = 2.0*R02 + ( t1*(6.0*R03 + t1*(12.0*R04 + t1*(20.0*R05))) + & + s1*((2.0*R12 + t1*(6.0*R13 + t1*(12.0*R14))) + s12*(2.0*R62)) ) + + ! Calculate the secant bulk modulus and its derivatives + ks_0 = S000 + ( t1*( S010 + t1*(S020 + t1*(S030 + t1*S040))) + & + s1*((S100 + t1*(S110 + t1*(S120 + t1*S130))) + s12*(S600 + t1*(S610 + t1*S620))) ) + ks_1 = S001 + ( t1*( S011 + t1*(S021 + t1*S031)) + & + s1*((S101 + t1*(S111 + t1*S121)) + s12*S601) ) + ks_2 = S002 + ( t1*( S012 + t1*S022) + s1*(S102 + t1*(S112 + t1*S122)) ) + + ks = ks_0 + p1*(ks_1 + p1*ks_2) + dks_dp = ks_1 + 2.0*p1*ks_2 + dks_dT = (S010 + ( t1*(2.0*S020 + t1*(3.0*S030 + t1*(4.0*S040))) + & + s1*((S110 + t1*(2.0*S120 + t1*(3.0*S130))) + s12*(S610 + t1*(2.0*S620))) )) + & + p1*((S011 + t1*(2.0*S021 + t1*(3.0*S031)) + s1*(S111 + t1*(2.0*S121))) + & + p1*(S012 + t1*(2.0*S022) + s1*(S112 + t1*(2.0*S122)))) + dks_dS = (S100 + ( t1*(S110 + t1*(S120 + t1*S130)) + 1.5*(s12*(S600 + t1*(S610 + t1*S620))) )) + & + p1*((S101 + t1*(S111 + t1*S121) + s12*(1.5*S601)) + & + p1*(S102 + t1*(S112 + t1*S122))) + d2ks_dS2 = 0.75*((S600 + t1*(S610 + t1*S620)) + p1*S601)*I_s12 + d2ks_dSdT = (S110 + ( t1*(2.0*S120 + t1*(3.0*S130)) + s12*(1.5*S610 + t1*(3.0*S620)) )) + & + p1*((S111 + t1*(2.0*S121)) + p1*(S112 + t1*(2.0*S122))) + d2ks_dT2 = 2.0*(S020 + ( t1*(3.0*S030 + t1*(6.0*S040)) + s1*((S120 + t1*(3.0*S130)) + s12*S620) )) + & + 2.0*p1*((S021 + (t1*(3.0*S031) + s1*S121)) + p1*(S022 + s1*S122)) + + d2ks_dSdp = (S101 + (t1*(S111 + t1*S121) + s12*(1.5*S601))) + & + 2.0*p1*(S102 + t1*(S112 + t1*S122)) + d2ks_dTdp = (S011 + (t1*(2.0*S021 + t1*(3.0*S031)) + s1*(S111 + t1*(2.0*S121)))) + & + 2.0*p1*(S012 + t1*(2.0*S022) + s1*(S112 + t1*(2.0*S122))) + I_denom = 1.0 / (ks - p1) + + ! Expressions for density and its first derivatives are copied here for reference: + ! rho = rho0*ks * I_denom + ! drho_dT = I_denom*(ks*drho0_dT - p1*rho0*I_denom*dks_dT) + ! drho_dS = I_denom*(ks*drho0_dS - p1*rho0*I_denom*dks_dS) + ! drho_dp = 1.0e-5 * (rho0 * I_denom**2) * (ks - dks_dp*p1) + + ! Finally calculate the second derivatives + drho_dS_dS = I_denom * ( ks*d2rho0_dS2 - (p1*I_denom) * & + (2.0*drho0_dS*dks_dS + rho0*(d2ks_dS2 - 2.0*dks_dS**2*I_denom)) ) + drho_dS_dT = I_denom * (ks * d2rho0_dSdT - (p1*I_denom) * & + ((drho0_dT*dks_dS + drho0_dS*dks_dT) + & + rho0*(d2ks_dSdT - 2.0*(dks_dS*dks_dT)*I_denom)) ) + drho_dT_dT = I_denom * ( ks*d2rho0_dT2 - (p1*I_denom) * & + (2.0*drho0_dT*dks_dT + rho0*(d2ks_dT2 - 2.0*dks_dT**2*I_denom)) ) + + ! The factor of 1.0e-5 is because pressure here is in bars, not Pa. + drho_dS_dp = (1.0e-5 * I_denom**2) * ( (ks*drho0_dS - rho0*dks_dS) - & + p1*( (dks_dp*drho0_dS + rho0*d2ks_dSdp) - & + 2.0*(rho0*dks_dS) * ((dks_dp - 1.0)*I_denom) ) ) + drho_dT_dp = (1.0e-5 * I_denom**2) * ( (ks*drho0_dT - rho0*dks_dT) - & + p1*( (dks_dp*drho0_dT + rho0*d2ks_dTdp) - & + 2.0*(rho0*dks_dT) * ((dks_dp - 1.0)*I_denom) ) ) + +end subroutine calculate_density_second_derivs_elem_UNESCO + +!> Calculate the partial derivatives of specific volume with temperature and salinity +!! using the UNESCO (1981) equation of state, as refit by Jackett and McDougall (1995). +elemental subroutine calculate_specvol_derivs_elem_UNESCO(this, T, S, pressure, dSV_dT, dSV_dS) + class(UNESCO_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1] + ! Local variables + real :: t1 ! A copy of the temperature at a point [degC] + real :: s1 ! A copy of the salinity at a point [PSU] + real :: p1 ! Pressure converted to bars [bar] + real :: s12 ! The square root of salinity [PSU1/2] + real :: rho0 ! Density at 1 bar pressure [kg m-3] + real :: ks ! The secant bulk modulus [bar] + real :: drho0_dT ! Derivative of rho0 with T [kg m-3 degC-1] + real :: drho0_dS ! Derivative of rho0 with S [kg m-3 PSU-1] + real :: dks_dT ! Derivative of ks with T [bar degC-1] + real :: dks_dS ! Derivative of ks with S [bar psu-1] + real :: I_denom2 ! 1.0 / (rho0*ks)**2 [m6 kg-2 bar-2] + + p1 = pressure*1.0e-5 ; t1 = T + s1 = max(S, 0.0) ; s12 = sqrt(s1) + + ! Compute rho(s,theta,p=0) and its derivatives with temperature and salinity + rho0 = R00 + ( t1*(R01 + t1*(R02 + t1*(R03 + t1*(R04 + t1*R05)))) + & + s1*((R10 + t1*(R11 + t1*(R12 + t1*(R13 + t1*R14)))) + & + (s12*(R60 + t1*(R61 + t1*R62)) + s1*R20)) ) + drho0_dT = R01 + ( t1*(2.0*R02 + t1*(3.0*R03 + t1*(4.0*R04 + t1*(5.0*R05)))) + & + s1*(R11 + (t1*(2.0*R12 + t1*(3.0*R13 + t1*(4.0*R14))) + & + s12*(R61 + t1*(2.0*R62)) )) ) + drho0_dS = R10 + ( t1*(R11 + t1*(R12 + t1*(R13 + t1*R14))) + & + (1.5*(s12*(R60 + t1*(R61 + t1*R62))) + s1*(2.0*R20)) ) + + ! Compute the secant bulk modulus and its derivatives with temperature and salinity + ks = ( S000 + (t1*(S010 + t1*(S020 + t1*(S030 + t1*S040))) + & + s1*((S100 + t1*(S110 + t1*(S120 + t1*S130))) + s12*(S600 + t1*(S610 + t1*S620)))) ) + & + p1*( (S001 + ( t1*(S011 + t1*(S021 + t1*S031)) + & + s1*((S101 + t1*(S111 + t1*S121)) + s12*S601) )) + & + p1*(S002 + ( t1*(S012 + t1*S022) + s1*(S102 + t1*(S112 + t1*S122)) )) ) + dks_dT = ( S010 + (t1*(2.0*S020 + t1*(3.0*S030 + t1*(4.0*S040))) + & + s1*((S110 + t1*(2.0*S120 + t1*(3.0*S130))) + s12*(S610 + t1*(2.0*S620)))) ) + & + p1*(((S011 + t1*(2.0*S021 + t1*(3.0*S031))) + s1*(S111 + t1*(2.0*S121)) ) + & + p1*(S012 + t1*(2.0*S022) + s1*(S112 + t1*(2.0*S122))) ) + dks_dS = ( S100 + (t1*(S110 + t1*(S120 + t1*S130)) + 1.5*(s12*(S600 + t1*(S610 + t1*S620)))) ) + & + p1*((S101 + t1*(S111 + t1*S121) + s12*(1.5*S601)) + & + p1*(S102 + t1*(S112 + t1*S122)) ) + + ! specvol = (ks - p1) / (rho0*ks) = 1/rho0 - p1/(rho0*ks) + I_denom2 = 1.0 / (rho0*ks)**2 + dSV_dT = ((p1*rho0)*dks_dT + ((p1 - ks)*ks)*drho0_dT) * I_denom2 + dSV_dS = ((p1*rho0)*dks_dS + ((p1 - ks)*ks)*drho0_dS) * I_denom2 + +end subroutine calculate_specvol_derivs_elem_UNESCO + +!> Compute the in situ density of sea water (rho) and the compressibility (drho/dp == C_sound^-2) +!! at the given salinity, potential temperature and pressure using the UNESCO (1981) +!! equation of state, as refit by Jackett and McDougall (1995). +elemental subroutine calculate_compress_elem_UNESCO(this, T, S, pressure, rho, drho_dp) + class(UNESCO_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: rho !< In situ density [kg m-3] + real, intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [s2 m-2] + ! Local variables + real :: t1 ! A copy of the temperature at a point [degC] + real :: s1 ! A copy of the salinity at a point [PSU] + real :: p1 ! Pressure converted to bars [bar] + real :: s12 ! The square root of salinity [PSU1/2] + real :: rho0 ! Density at 1 bar pressure [kg m-3] + real :: ks ! The secant bulk modulus [bar] + real :: ks_0 ! The secant bulk modulus at zero pressure [bar] + real :: ks_1 ! The linear pressure dependence of the secant bulk modulus at zero pressure [nondim] + real :: ks_2 ! The quadratic pressure dependence of the secant bulk modulus at zero pressure [bar-1] + real :: dks_dp ! The derivative of the secant bulk modulus with pressure [nondim] + real :: I_denom ! 1.0 / (ks - p1) [bar-1] + + p1 = pressure*1.0e-5 ; t1 = T + s1 = max(S, 0.0) ; s12 = sqrt(s1) + + ! Compute rho(s,theta,p=0), which is the same as rho(s,t_insitu,p=0). + + rho0 = R00 + ( t1*(R01 + t1*(R02 + t1*(R03 + t1*(R04 + t1*R05)))) + & + s1*((R10 + t1*(R11 + t1*(R12 + t1*(R13 + t1*R14)))) + & + (s12*(R60 + t1*(R61 + t1*R62)) + s1*R20)) ) + + ! Calculate the secant bulk modulus and its derivative with pressure. + ks_0 = S000 + ( t1*( S010 + t1*(S020 + t1*(S030 + t1*S040))) + & + s1*((S100 + t1*(S110 + t1*(S120 + t1*S130))) + s12*(S600 + t1*(S610 + t1*S620))) ) + ks_1 = S001 + ( t1*( S011 + t1*(S021 + t1*S031)) + & + s1*((S101 + t1*(S111 + t1*S121)) + s12*S601) ) + ks_2 = S002 + ( t1*( S012 + t1*S022) + s1*(S102 + t1*(S112 + t1*S122)) ) + + ks = ks_0 + p1*(ks_1 + p1*ks_2) + dks_dp = ks_1 + 2.0*p1*ks_2 + I_denom = 1.0 / (ks - p1) + + ! Compute the in situ density, rho(s,theta,p), and its derivative with pressure. + rho = rho0*ks * I_denom + ! The factor of 1.0e-5 is because pressure here is in bars, not Pa. + drho_dp = 1.0e-5 * ((rho0 * (ks - p1*dks_dp)) * I_denom**2) + +end subroutine calculate_compress_elem_UNESCO + +!> Return the range of temperatures, salinities and pressures for which Jackett and McDougall (1995) +!! refit the UNESCO equation of state has been fitted to observations. Care should be taken when +!! applying this equation of state outside of its fit range. +subroutine EoS_fit_range_UNESCO(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(UNESCO_EOS), intent(in) :: this !< This EOS + real, optional, intent(out) :: T_min !< The minimum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: S_max !< The maximum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + if (present(T_min)) T_min = -2.5 + if (present(T_max)) T_max = 40.0 + if (present(S_min)) S_min = 0.0 + if (present(S_max)) S_max = 42.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 1.0e8 + +end subroutine EoS_fit_range_UNESCO + +!> \namespace mom_eos_UNESCO +!! +!! \section section_EOS_UNESCO UNESCO (Jackett & McDougall) equation of state +!! +!! The UNESCO (1981) equation of state is an internationally defined standard fit valid over the +!! range of pressures up to 10000 dbar, temperatures between the freezing point and 40 degC, and +!! salinities between 0 and 42 PSU. Unfortunately, these expressions used in situ temperatures, +!! whereas ocean models (including MOM6) effectively use potential temperatures as their state +!! variables. To avoid needing multiple conversions, Jackett and McDougall (1995) refit the +!! UNESCO equation of state to take potential temperature as a state variable, over the same +!! valid range and functional form as the original UNESCO expressions. It is this refit from +!! Jackett and McDougall (1995) that is coded up in this module. +!! +!! The functional form of the equation of state includes terms proportional to salinity to the +!! 3/2 power. This introduces a singularity in the second derivative of density with salinity +!! at a salinity of 0, but this has been addressed here by setting a floor of 1e-8 PSU on the +!! salinity that is used in the denominator of these second derivative expressions. This value +!! was chosen to imply a contribution that is smaller than numerical roundoff in the expression +!! for density, which is the field for which the UNESCO equation of state was originally derived. +!! +!! Originally coded in 1999 by J. Stephens, revised in 2023 to unambiguously specify the order +!! of arithmetic with parenthesis in every real sum of three or more terms. +!! +!! \subsection section_EOS_UNESCO_references References +!! +!! Gill, A. E., 1982: Atmosphere-Ocean Dynamics. Academic Press, 662 pp. +!! +!! Jackett, D. and T. McDougall, 1995: Minimal adjustment of hydrographic profiles to +!! achieve static stability. J. Atmos. Ocean. Tech., 12, 381-389. +!! +!! UNESCO, 1981: Tenth report of the joint panel on oceanographic tables and standards. +!! UNESCO Technical Papers in Marine Sci. No. 36, UNESCO, Paris. end module MOM_EOS_UNESCO diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index 730687fbf6..3314b6f460 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -1,435 +1,417 @@ -!> The equation of state using the Wright 1997 expressions -module MOM_EOS_Wright - -! This file is part of MOM6. See LICENSE.md for the license. +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 -!*********************************************************************** -!* The subroutines in this file implement the equation of state for * -!* sea water using the formulae given by Wright, 1997, J. Atmos. * -!* Ocean. Tech., 14, 735-740. Coded by R. Hallberg, 7/00. * -!*********************************************************************** +!> The equation of state using a poor implementation (missing parenthesis and bugs) of the +!! reduced range Wright 1997 expressions +module MOM_EOS_Wright +use MOM_EOS_base_type, only : EOS_base use MOM_hor_index, only : hor_index_type implicit none ; private -#include - -public calculate_compress_wright, calculate_density_wright, calculate_spec_vol_wright -public calculate_density_derivs_wright, calculate_specvol_derivs_wright -public calculate_density_second_derivs_wright +public buggy_Wright_EOS public int_density_dz_wright, int_spec_vol_dp_wright - -! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional -! consistency testing. These are noted in comments with units like Z, H, L, and T, along with -! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units -! vary with the Boussinesq approximation, the Boussinesq variant is given first. - - -!> Compute the in situ density of sea water (in [kg m-3]), or its anomaly with respect to -!! a reference density, from salinity (in psu), potential temperature (in deg C), and pressure [Pa], -!! using the expressions from Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. -interface calculate_density_wright - module procedure calculate_density_scalar_wright, calculate_density_array_wright -end interface calculate_density_wright - -!> Compute the in situ specific volume of sea water (in [m3 kg-1]), or an anomaly with respect -!! to a reference specific volume, from salinity (in psu), potential temperature (in deg C), and -!! pressure [Pa], using the expressions from Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. -interface calculate_spec_vol_wright - module procedure calculate_spec_vol_scalar_wright, calculate_spec_vol_array_wright -end interface calculate_spec_vol_wright - -!> For a given thermodynamic state, return the derivatives of density with temperature and salinity -interface calculate_density_derivs_wright - module procedure calculate_density_derivs_scalar_wright, calculate_density_derivs_array_wright -end interface - -!> For a given thermodynamic state, return the second derivatives of density with various combinations -!! of temperature, salinity, and pressure -interface calculate_density_second_derivs_wright - module procedure calculate_density_second_derivs_scalar_wright, calculate_density_second_derivs_array_wright -end interface - -!>@{ Parameters in the Wright equation of state -!real :: a0, a1, a2, b0, b1, b2, b3, b4, b5, c0, c1, c2, c3, c4, c5 -! One of the two following blocks of values should be commented out. -! Following are the values for the full range formula. -! -!real, parameter :: a0 = 7.133718e-4, a1 = 2.724670e-7, a2 = -1.646582e-7 -!real, parameter :: b0 = 5.613770e8, b1 = 3.600337e6, b2 = -3.727194e4 -!real, parameter :: b3 = 1.660557e2, b4 = 6.844158e5, b5 = -8.389457e3 -!real, parameter :: c0 = 1.609893e5, c1 = 8.427815e2, c2 = -6.931554 -!real, parameter :: c3 = 3.869318e-2, c4 = -1.664201e2, c5 = -2.765195 - - -! Following are the values for the reduced range formula. -real, parameter :: a0 = 7.057924e-4, a1 = 3.480336e-7, a2 = -1.112733e-7 ! a0/a1 ~= 2028 ; a0/a2 ~= -6343 -real, parameter :: b0 = 5.790749e8, b1 = 3.516535e6, b2 = -4.002714e4 ! b0/b1 ~= 165 ; b0/b4 ~= 974 -real, parameter :: b3 = 2.084372e2, b4 = 5.944068e5, b5 = -9.643486e3 -real, parameter :: c0 = 1.704853e5, c1 = 7.904722e2, c2 = -7.984422 ! c0/c1 ~= 216 ; c0/c4 ~= -740 -real, parameter :: c3 = 5.140652e-2, c4 = -2.302158e2, c5 = -3.079464 +public avg_spec_vol_buggy_Wright +public set_params_buggy_Wright + +!>@{ Parameters in the Wright equation of state using the reduced range formula, which is a fit to the UNESCO +! equation of state for the restricted range: -2 < theta < 30 [degC], 28 < S < 38 [PSU], 0 < p < 5e7 [Pa]. + + ! Note that a0/a1 ~= 2028 [degC] ; a0/a2 ~= -6343 [PSU] + ! b0/b1 ~= 165 [degC] ; b0/b4 ~= 974 [PSU] + ! c0/c1 ~= 216 [degC] ; c0/c4 ~= -740 [PSU] +real, parameter :: a0 = 7.057924e-4 ! A parameter in the Wright alpha_0 fit [m3 kg-1] +real, parameter :: a1 = 3.480336e-7 ! A parameter in the Wright alpha_0 fit [m3 kg-1 degC-1] +real, parameter :: a2 = -1.112733e-7 ! A parameter in the Wright alpha_0 fit [m3 kg-1 PSU-1] +real, parameter :: b0 = 5.790749e8 ! A parameter in the Wright p_0 fit [Pa] +real, parameter :: b1 = 3.516535e6 ! A parameter in the Wright p_0 fit [Pa degC-1] +real, parameter :: b2 = -4.002714e4 ! A parameter in the Wright p_0 fit [Pa degC-2] +real, parameter :: b3 = 2.084372e2 ! A parameter in the Wright p_0 fit [Pa degC-3] +real, parameter :: b4 = 5.944068e5 ! A parameter in the Wright p_0 fit [Pa PSU-1] +real, parameter :: b5 = -9.643486e3 ! A parameter in the Wright p_0 fit [Pa degC-1 PSU-1] +real, parameter :: c0 = 1.704853e5 ! A parameter in the Wright lambda fit [m2 s-2] +real, parameter :: c1 = 7.904722e2 ! A parameter in the Wright lambda fit [m2 s-2 degC-1] +real, parameter :: c2 = -7.984422 ! A parameter in the Wright lambda fit [m2 s-2 degC-2] +real, parameter :: c3 = 5.140652e-2 ! A parameter in the Wright lambda fit [m2 s-2 degC-3] +real, parameter :: c4 = -2.302158e2 ! A parameter in the Wright lambda fit [m2 s-2 PSU-1] +real, parameter :: c5 = -3.079464 ! A parameter in the Wright lambda fit [m2 s-2 degC-1 PSU-1] !>@} +!> The EOS_base implementation of the Wright 1997 equation of state with some bugs +type, extends (EOS_base) :: buggy_Wright_EOS + + real :: three = 3.0 !< A constant that can be adjusted to recreate some bugs [nondim] + contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_buggy_Wright + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_buggy_Wright + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_buggy_Wright + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_buggy_Wright + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_buggy_Wright + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_buggy_Wright + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_buggy_Wright + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_buggy_Wright + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_buggy_Wright + + !> Instance specific function to set internal parameters + procedure :: set_params_buggy_Wright => set_params_buggy_Wright + + !> Local implementation of generic calculate_density_array for efficiency + procedure :: calculate_density_array => calculate_density_array_buggy_Wright + !> Local implementation of generic calculate_spec_vol_array for efficiency + procedure :: calculate_spec_vol_array => calculate_spec_vol_array_buggy_Wright + +end type buggy_Wright_EOS -!> This subroutine computes the in situ density of sea water (rho in -!! [kg m-3]) from salinity (S [PSU]), potential temperature -!! (T [degC]), and pressure [Pa]. It uses the expression from -!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. -subroutine calculate_density_scalar_wright(T, S, pressure, rho, rho_ref) - real, intent(in) :: T !< Potential temperature relative to the surface [degC]. - real, intent(in) :: S !< Salinity [PSU]. - real, intent(in) :: pressure !< pressure [Pa]. - real, intent(out) :: rho !< In situ density [kg m-3]. - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. - -! *====================================================================* -! * This subroutine computes the in situ density of sea water (rho in * -! * [kg m-3]) from salinity (S [PSU]), potential temperature * -! * (T [degC]), and pressure [Pa]. It uses the expression from * -! * Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. * -! * Coded by R. Hallberg, 7/00 * -! *====================================================================* - - real, dimension(1) :: T0, S0, pressure0, rho0 - - T0(1) = T - S0(1) = S - pressure0(1) = pressure - - call calculate_density_array_wright(T0, S0, pressure0, rho0, 1, 1, rho_ref) - rho = rho0(1) - -end subroutine calculate_density_scalar_wright - -!> This subroutine computes the in situ density of sea water (rho in -!! [kg m-3]) from salinity (S [PSU]), potential temperature -!! (T [degC]), and pressure [Pa]. It uses the expression from -!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. -subroutine calculate_density_array_wright(T, S, pressure, rho, start, npts, rho_ref) - real, dimension(:), intent(in) :: T !< potential temperature relative to the surface [degC]. - real, dimension(:), intent(in) :: S !< salinity [PSU]. - real, dimension(:), intent(in) :: pressure !< pressure [Pa]. - real, dimension(:), intent(inout) :: rho !< in situ density [kg m-3]. - integer, intent(in) :: start !< the starting point in the arrays. - integer, intent(in) :: npts !< the number of values to calculate. - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. - - ! Original coded by R. Hallberg, 7/00, anomaly coded in 3/18. - ! Local variables - real :: al0, p0, lambda - real :: al_TS, p_TSp, lam_TS, pa_000 - integer :: j +contains - if (present(rho_ref)) pa_000 = (b0*(1.0 - a0*rho_ref) - rho_ref*c0) - if (present(rho_ref)) then ; do j=start,start+npts-1 - al_TS = a1*T(j) +a2*S(j) - al0 = a0 + al_TS - p_TSp = pressure(j) + (b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j)))) - lam_TS = c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) - - ! The following two expressions are mathematically equivalent. - ! rho(j) = (b0 + p0_TSp) / ((c0 + lam_TS) + al0*(b0 + p0_TSp)) - rho_ref - rho(j) = (pa_000 + (p_TSp - rho_ref*(p_TSp*al0 + (b0*al_TS + lam_TS)))) / & - ( (c0 + lam_TS) + al0*(b0 + p_TSp) ) - enddo ; else ; do j=start,start+npts-1 - al0 = (a0 + a1*T(j)) +a2*S(j) - p0 = (b0 + b4*S(j)) + T(j) * (b1 + T(j)*(b2 + b3*T(j)) + b5*S(j)) - lambda = (c0 +c4*S(j)) + T(j) * (c1 + T(j)*(c2 + c3*T(j)) + c5*S(j)) - rho(j) = (pressure(j) + p0) / (lambda + al0*(pressure(j) + p0)) - enddo ; endif - -end subroutine calculate_density_array_wright - -!> This subroutine computes the in situ specific volume of sea water (specvol in -!! [m3 kg-1]) from salinity (S [PSU]), potential temperature (T [degC]) -!! and pressure [Pa]. It uses the expression from -!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. -!! If spv_ref is present, specvol is an anomaly from spv_ref. -subroutine calculate_spec_vol_scalar_wright(T, S, pressure, specvol, spv_ref) - real, intent(in) :: T !< potential temperature relative to the surface [degC]. - real, intent(in) :: S !< salinity [PSU]. - real, intent(in) :: pressure !< pressure [Pa]. - real, intent(out) :: specvol !< in situ specific volume [m3 kg-1]. - real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. +!> In situ density of sea water using a buggy implementation of Wright, 1997 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_elem_buggy_Wright(this, T, S, pressure) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< potential temperature relative to the surface [degC]. + real, intent(in) :: S !< salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. ! Local variables - real, dimension(1) :: T0, S0, pressure0, spv0 - - T0(1) = T ; S0(1) = S ; pressure0(1) = pressure - - call calculate_spec_vol_array_wright(T0, S0, pressure0, spv0, 1, 1, spv_ref) - specvol = spv0(1) -end subroutine calculate_spec_vol_scalar_wright - -!> This subroutine computes the in situ specific volume of sea water (specvol in -!! [m3 kg-1]) from salinity (S [PSU]), potential temperature (T [degC]) -!! and pressure [Pa]. It uses the expression from -!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. -!! If spv_ref is present, specvol is an anomaly from spv_ref. -subroutine calculate_spec_vol_array_wright(T, S, pressure, specvol, start, npts, spv_ref) - real, dimension(:), intent(in) :: T !< potential temperature relative to the - !! surface [degC]. - real, dimension(:), intent(in) :: S !< salinity [PSU]. - real, dimension(:), intent(in) :: pressure !< pressure [Pa]. - real, dimension(:), intent(inout) :: specvol !< in situ specific volume [m3 kg-1]. - integer, intent(in) :: start !< the starting point in the arrays. - integer, intent(in) :: npts !< the number of values to calculate. - real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + + al0 = (a0 + a1*T) +a2*S + p0 = (b0 + b4*S) + T * (b1 + T*(b2 + b3*T) + b5*S) + lambda = (c0 +c4*S) + T * (c1 + T*(c2 + c3*T) + c5*S) + density_elem_buggy_Wright = (pressure + p0) / (lambda + al0*(pressure + p0)) + +end function density_elem_buggy_Wright + +!> In situ density anomaly of sea water using a buggy implementation of Wright, 1997 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_anomaly_elem_buggy_Wright(this, T, S, pressure, rho_ref) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< potential temperature relative to the surface [degC]. + real, intent(in) :: S !< salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(in) :: rho_ref !< A reference density [kg m-3]. ! Local variables - real :: al0, p0, lambda - integer :: j + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: al_TS ! The contributions of temperature and salinity to al0 [m3 kg-1] + real :: p_TSp ! A combination of the pressure and the temperature and salinity contributions to p0 [Pa] + real :: lam_TS ! The contributions of temperature and salinity to lambda [m2 s-2] + real :: pa_000 ! A corrected offset to the pressure, including contributions from rho_ref [Pa] + + pa_000 = (b0*(1.0 - a0*rho_ref) - rho_ref*c0) + al_TS = a1*T +a2*S + al0 = a0 + al_TS + p_TSp = pressure + (b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S))) + lam_TS = c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) + + ! The following two expressions are mathematically equivalent. + ! wright_density = (b0 + p0_TSp) / ((c0 + lam_TS) + al0*(b0 + p0_TSp)) - rho_ref + density_anomaly_elem_buggy_Wright = & + (pa_000 + (p_TSp - rho_ref*(p_TSp*al0 + (b0*al_TS + lam_TS)))) / & + ( (c0 + lam_TS) + al0*(b0 + p_TSp) ) + +end function density_anomaly_elem_buggy_Wright + +!> In situ specific volume of sea water using a buggy implementation of Wright, 1997 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_elem_buggy_Wright(this, T, S, pressure) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< potential temperature relative to the surface [degC]. + real, intent(in) :: S !< salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. - do j=start,start+npts-1 - al0 = (a0 + a1*T(j)) +a2*S(j) - p0 = (b0 + b4*S(j)) + T(j) * (b1 + T(j)*((b2 + b3*T(j))) + b5*S(j)) - lambda = (c0 +c4*S(j)) + T(j) * (c1 + T(j)*((c2 + c3*T(j))) + c5*S(j)) + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] - if (present(spv_ref)) then - specvol(j) = (lambda + (al0 - spv_ref)*(pressure(j) + p0)) / (pressure(j) + p0) - else - specvol(j) = (lambda + al0*(pressure(j) + p0)) / (pressure(j) + p0) - endif - enddo -end subroutine calculate_spec_vol_array_wright - -!> For a given thermodynamic state, return the thermal/haline expansion coefficients -subroutine calculate_density_derivs_array_wright(T, S, pressure, drho_dT, drho_dS, start, npts) - real, intent(in), dimension(:) :: T !< Potential temperature relative to the - !! surface [degC]. - real, intent(in), dimension(:) :: S !< Salinity [PSU]. - real, intent(in), dimension(:) :: pressure !< pressure [Pa]. - real, intent(inout), dimension(:) :: drho_dT !< The partial derivative of density with potential - !! temperature [kg m-3 degC-1]. - real, intent(inout), dimension(:) :: drho_dS !< The partial derivative of density with salinity, - !! in [kg m-3 PSU-1]. - integer, intent(in) :: start !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. + al0 = (a0 + a1*T) +a2*S + p0 = (b0 + b4*S) + T * (b1 + T*((b2 + b3*T)) + b5*S) + lambda = (c0 +c4*S) + T * (c1 + T*((c2 + c3*T)) + c5*S) - ! Local variables - real :: al0, p0, lambda, I_denom2 - integer :: j + spec_vol_elem_buggy_Wright = (lambda + al0*(pressure + p0)) / (pressure + p0) - do j=start,start+npts-1 - al0 = (a0 + a1*T(j)) + a2*S(j) - p0 = (b0 + b4*S(j)) + T(j) * (b1 + T(j)*((b2 + b3*T(j))) + b5*S(j)) - lambda = (c0 +c4*S(j)) + T(j) * (c1 + T(j)*((c2 + c3*T(j))) + c5*S(j)) - - I_denom2 = 1.0 / (lambda + al0*(pressure(j) + p0)) - I_denom2 = I_denom2 *I_denom2 - drho_dT(j) = I_denom2 * & - (lambda* (b1 + T(j)*(2.0*b2 + 3.0*b3*T(j)) + b5*S(j)) - & - (pressure(j)+p0) * ( (pressure(j)+p0)*a1 + & - (c1 + T(j)*(c2*2.0 + c3*3.0*T(j)) + c5*S(j)) )) - drho_dS(j) = I_denom2 * (lambda* (b4 + b5*T(j)) - & - (pressure(j)+p0) * ( (pressure(j)+p0)*a2 + (c4 + c5*T(j)) )) - enddo +end function spec_vol_elem_buggy_Wright + +!> In situ specific volume anomaly of sea water using a buggy implementation of Wright, 1997 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_anomaly_elem_buggy_Wright(this, T, S, pressure, spv_ref) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< potential temperature relative to the surface [degC]. + real, intent(in) :: S !< salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. -end subroutine calculate_density_derivs_array_wright - -!> The scalar version of calculate_density_derivs which promotes scalar inputs to a 1-element array and then -!! demotes the output back to a scalar -subroutine calculate_density_derivs_scalar_wright(T, S, pressure, drho_dT, drho_dS) - real, intent(in) :: T !< Potential temperature relative to the surface [degC]. - real, intent(in) :: S !< Salinity [PSU]. - real, intent(in) :: pressure !< pressure [Pa]. - real, intent(out) :: drho_dT !< The partial derivative of density with potential - !! temperature [kg m-3 degC-1]. - real, intent(out) :: drho_dS !< The partial derivative of density with salinity, - !! in [kg m-3 PSU-1]. - - ! Local variables needed to promote the input/output scalars to 1-element arrays - real, dimension(1) :: T0, S0, P0 - real, dimension(1) :: drdt0, drds0 - - T0(1) = T - S0(1) = S - P0(1) = pressure - call calculate_density_derivs_array_wright(T0, S0, P0, drdt0, drds0, 1, 1) - drho_dT = drdt0(1) - drho_dS = drds0(1) - -end subroutine calculate_density_derivs_scalar_wright - -!> Second derivatives of density with respect to temperature, salinity, and pressure -subroutine calculate_density_second_derivs_array_wright(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & - drho_ds_dp, drho_dt_dp, start, npts) - real, dimension(:), intent(in ) :: T !< Potential temperature referenced to 0 dbar [degC] - real, dimension(:), intent(in ) :: S !< Salinity [PSU] - real, dimension(:), intent(in ) :: P !< Pressure [Pa] - real, dimension(:), intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + + al0 = (a0 + a1*T) +a2*S + p0 = (b0 + b4*S) + T * (b1 + T*((b2 + b3*T)) + b5*S) + lambda = (c0 +c4*S) + T * (c1 + T*((c2 + c3*T)) + c5*S) + + spec_vol_anomaly_elem_buggy_Wright = (lambda + (al0 - spv_ref)*(pressure + p0)) / (pressure + p0) + +end function spec_vol_anomaly_elem_buggy_Wright + +!> Calculate the partial derivatives of density with potential temperature and salinity +!! using the buggy implementation of the equation of state, as fit by Wright, 1997 +elemental subroutine calculate_density_derivs_elem_buggy_Wright(this, T, S, pressure, drho_dT, drho_dS) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1] + real, intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 PSU-1] + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: I_denom2 ! The inverse of the square of the denominator of density in the Wright EOS [s4 m-4] + + al0 = (a0 + a1*T) + a2*S + p0 = (b0 + b4*S) + T * (b1 + T*((b2 + b3*T)) + b5*S) + lambda = (c0 +c4*S) + T * (c1 + T*((c2 + c3*T)) + c5*S) + + I_denom2 = 1.0 / (lambda + al0*(pressure + p0)) + I_denom2 = I_denom2 *I_denom2 + drho_dT = I_denom2 * & + (lambda* (b1 + T*(2.0*b2 + 3.0*b3*T) + b5*S) - & + (pressure+p0) * ( (pressure+p0)*a1 + & + (c1 + T*(c2*2.0 + c3*3.0*T) + c5*S) )) + drho_dS = I_denom2 * (lambda* (b4 + b5*T) - & + (pressure+p0) * ( (pressure+p0)*a2 + (c4 + c5*T) )) + +end subroutine calculate_density_derivs_elem_buggy_Wright + +!> Second derivatives of density with respect to temperature, salinity, and pressure, +!! using the poor implementation of the equation of state, as fit by Wright, 1997 +elemental subroutine calculate_density_second_derivs_elem_buggy_Wright(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature referenced to 0 dbar [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect !! to S [kg m-3 PSU-2] - real, dimension(:), intent(inout) :: drho_ds_dt !< Partial derivative of beta with respcct + real, intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect !! to T [kg m-3 PSU-1 degC-1] - real, dimension(:), intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + real, intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect !! to T [kg m-3 degC-2] - real, dimension(:), intent(inout) :: drho_ds_dp !< Partial derivative of beta with respect - !! to pressure [kg m-3 PSU-1 Pa-1] - real, dimension(:), intent(inout) :: drho_dt_dp !< Partial derivative of alpha with respect - !! to pressure [kg m-3 degC-1 Pa-1] - integer, intent(in ) :: start !< Starting index in T,S,P - integer, intent(in ) :: npts !< Number of points to loop over - + real, intent(inout) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, intent(inout) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] ! Local variables - real :: z0, z1, z2, z3, z4, z5, z6 ,z7, z8, z9, z10, z11, z2_2, z2_3 - integer :: j + real :: z0, z1 ! Local work variables [Pa] + real :: z2, z4 ! Local work variables [m2 s-2] + real :: z3, z5 ! Local work variables [Pa degC-1] + real :: z6, z8 ! Local work variables [m2 s-2 degC-1] + real :: z7 ! A local work variable [m2 s-2 PSU-1] + real :: z9 ! A local work variable [m3 kg-1] + real :: z10 ! A local work variable [Pa PSU-1] + real :: z11 ! A local work variable [Pa m2 s-2 PSU-1] = [kg m s-4 PSU-1] + real :: z2_2 ! A local work variable [m4 s-4] + real :: z2_3 ! A local work variable [m6 s-6] + real :: six ! A constant that can be adjusted from 6. to 4. to recreate a bug [nondim] + ! Based on the above expression with common terms factored, there probably exists a more numerically stable ! and/or efficient expression - do j = start,start+npts-1 - z0 = T(j)*(b1 + b5*S(j) + T(j)*(b2 + b3*T(j))) - z1 = (b0 + P(j) + b4*S(j) + z0) - z3 = (b1 + b5*S(j) + T(j)*(2.*b2 + 2.*b3*T(j))) - z4 = (c0 + c4*S(j) + T(j)*(c1 + c5*S(j) + T(j)*(c2 + c3*T(j)))) - z5 = (b1 + b5*S(j) + T(j)*(b2 + b3*T(j)) + T(j)*(b2 + 2.*b3*T(j))) - z6 = c1 + c5*S(j) + T(j)*(c2 + c3*T(j)) + T(j)*(c2 + 2.*c3*T(j)) - z7 = (c4 + c5*T(j) + a2*z1) - z8 = (c1 + c5*S(j) + T(j)*(2.*c2 + 3.*c3*T(j)) + a1*z1) - z9 = (a0 + a2*S(j) + a1*T(j)) - z10 = (b4 + b5*T(j)) - z11 = (z10*z4 - z1*z7) - z2 = (c0 + c4*S(j) + T(j)*(c1 + c5*S(j) + T(j)*(c2 + c3*T(j))) + z9*z1) - z2_2 = z2*z2 - z2_3 = z2_2*z2 - - drho_ds_ds(j) = (z10*(c4 + c5*T(j)) - a2*z10*z1 - z10*z7)/z2_2 - (2.*(c4 + c5*T(j) + z9*z10 + a2*z1)*z11)/z2_3 - drho_ds_dt(j) = (z10*z6 - z1*(c5 + a2*z5) + b5*z4 - z5*z7)/z2_2 - (2.*(z6 + z9*z5 + a1*z1)*z11)/z2_3 - drho_dt_dt(j) = (z3*z6 - z1*(2.*c2 + 6.*c3*T(j) + a1*z5) + (2.*b2 + 4.*b3*T(j))*z4 - z5*z8)/z2_2 - & - (2.*(z6 + z9*z5 + a1*z1)*(z3*z4 - z1*z8))/z2_3 - drho_ds_dp(j) = (-c4 - c5*T(j) - 2.*a2*z1)/z2_2 - (2.*z9*z11)/z2_3 - drho_dt_dp(j) = (-c1 - c5*S(j) - T(j)*(2.*c2 + 3.*c3*T(j)) - 2.*a1*z1)/z2_2 - (2.*z9*(z3*z4 - z1*z8))/z2_3 - enddo - -end subroutine calculate_density_second_derivs_array_wright - -!> Second derivatives of density with respect to temperature, salinity, and pressure for scalar inputs. Inputs -!! promoted to 1-element array and output demoted to scalar -subroutine calculate_density_second_derivs_scalar_wright(T, S, P, drho_ds_ds, drho_ds_dt, drho_dt_dt, & - drho_ds_dp, drho_dt_dp) - real, intent(in ) :: T !< Potential temperature referenced to 0 dbar - real, intent(in ) :: S !< Salinity [PSU] - real, intent(in ) :: P !< pressure [Pa] - real, intent( out) :: drho_ds_ds !< Partial derivative of beta with respect - !! to S [kg m-3 PSU-2] - real, intent( out) :: drho_ds_dt !< Partial derivative of beta with respcct - !! to T [kg m-3 PSU-1 degC-1] - real, intent( out) :: drho_dt_dt !< Partial derivative of alpha with respect - !! to T [kg m-3 degC-2] - real, intent( out) :: drho_ds_dp !< Partial derivative of beta with respect - !! to pressure [kg m-3 PSU-1 Pa-1] - real, intent( out) :: drho_dt_dp !< Partial derivative of alpha with respect - !! to pressure [kg m-3 degC-1 Pa-1] + six = 2.0*this%three ! When recreating a bug from the original version of this routine, six = 4. + + z0 = T*(b1 + b5*S + T*(b2 + b3*T)) + z1 = (b0 + pressure + b4*S + z0) + z3 = (b1 + b5*S + T*(2.*b2 + this%three*b3*T)) ! When recreating a bug here this%three = 2. + z4 = (c0 + c4*S + T*(c1 + c5*S + T*(c2 + c3*T))) + z5 = (b1 + b5*S + T*(b2 + b3*T) + T*(b2 + 2.*b3*T)) + z6 = c1 + c5*S + T*(c2 + c3*T) + T*(c2 + 2.*c3*T) + z7 = (c4 + c5*T + a2*z1) + z8 = (c1 + c5*S + T*(2.*c2 + 3.*c3*T) + a1*z1) + z9 = (a0 + a2*S + a1*T) + z10 = (b4 + b5*T) + z11 = (z10*z4 - z1*z7) + z2 = (c0 + c4*S + T*(c1 + c5*S + T*(c2 + c3*T)) + z9*z1) + z2_2 = z2*z2 + z2_3 = z2_2*z2 + + drho_ds_ds = (z10*(c4 + c5*T) - a2*z10*z1 - z10*z7)/z2_2 - (2.*(c4 + c5*T + z9*z10 + a2*z1)*z11)/z2_3 + drho_ds_dt = (z10*z6 - z1*(c5 + a2*z5) + b5*z4 - z5*z7)/z2_2 - (2.*(z6 + z9*z5 + a1*z1)*z11)/z2_3 + drho_dt_dt = (z3*z6 - z1*(2.*c2 + 6.*c3*T + a1*z5) + (2.*b2 + six*b3*T)*z4 - z5*z8)/z2_2 - & + (2.*(z6 + z9*z5 + a1*z1)*(z3*z4 - z1*z8))/z2_3 + drho_ds_dp = (-c4 - c5*T - 2.*a2*z1)/z2_2 - (2.*z9*z11)/z2_3 + drho_dt_dp = (-c1 - c5*S - T*(2.*c2 + 3.*c3*T) - 2.*a1*z1)/z2_2 - (2.*z9*(z3*z4 - z1*z8))/z2_3 + +end subroutine calculate_density_second_derivs_elem_buggy_Wright + +!> Calculate the partial derivatives of specific volume with temperature and salinity +!! using the poor implementation of the equation of state, as fit by Wright, 1997 +elemental subroutine calculate_specvol_derivs_elem_buggy_Wright(this, T, S, pressure, dSV_dT, dSV_dS) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1] ! Local variables - real, dimension(1) :: T0, S0, P0 - real, dimension(1) :: drdsds, drdsdt, drdtdt, drdsdp, drdtdp - - T0(1) = T - S0(1) = S - P0(1) = P - call calculate_density_second_derivs_array_wright(T0, S0, P0, drdsds, drdsdt, drdtdt, drdsdp, drdtdp, 1, 1) - drho_ds_ds = drdsds(1) - drho_ds_dt = drdsdt(1) - drho_dt_dt = drdtdt(1) - drho_ds_dp = drdsdp(1) - drho_dt_dp = drdtdp(1) - -end subroutine calculate_density_second_derivs_scalar_wright - -!> For a given thermodynamic state, return the partial derivatives of specific volume -!! with temperature and salinity -subroutine calculate_specvol_derivs_wright(T, S, pressure, dSV_dT, dSV_dS, start, npts) - real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface [degC]. - real, intent(in), dimension(:) :: S !< Salinity [PSU]. - real, intent(in), dimension(:) :: pressure !< pressure [Pa]. - real, intent(inout), dimension(:) :: dSV_dT !< The partial derivative of specific volume with - !! potential temperature [m3 kg-1 degC-1]. - real, intent(inout), dimension(:) :: dSV_dS !< The partial derivative of specific volume with - !! salinity [m3 kg-1 / Pa]. - integer, intent(in) :: start !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: I_denom ! The inverse of the denominator of specific volume in the Wright EOS [Pa-1] + +! al0 = (a0 + a1*T) + a2*S + p0 = (b0 + b4*S) + T * (b1 + T*((b2 + b3*T)) + b5*S) + lambda = (c0 +c4*S) + T * (c1 + T*((c2 + c3*T)) + c5*S) + + ! SV = al0 + lambda / (pressure + p0) + + I_denom = 1.0 / (pressure + p0) + dSV_dT = (a1 + I_denom * (c1 + T*((2.0*c2 + 3.0*c3*T)) + c5*S)) - & + (I_denom**2 * lambda) * (b1 + T*((2.0*b2 + 3.0*b3*T)) + b5*S) + dSV_dS = (a2 + I_denom * (c4 + c5*T)) - & + (I_denom**2 * lambda) * (b4 + b5*T) + +end subroutine calculate_specvol_derivs_elem_buggy_Wright + +!> Compute the in situ density of sea water (rho) and the compressibility (drho/dp == C_sound^-2) +!! at the given salinity, potential temperature and pressure +!! using the poor implementation of the equation of state, as fit by Wright, 1997 +elemental subroutine calculate_compress_elem_buggy_Wright(this, T, S, pressure, rho, drho_dp) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: rho !< In situ density [kg m-3] + real, intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [s2 m-2]. ! Local variables - real :: al0, p0, lambda, I_denom - integer :: j - - do j=start,start+npts-1 -! al0 = (a0 + a1*T(j)) + a2*S(j) - p0 = (b0 + b4*S(j)) + T(j) * (b1 + T(j)*((b2 + b3*T(j))) + b5*S(j)) - lambda = (c0 +c4*S(j)) + T(j) * (c1 + T(j)*((c2 + c3*T(j))) + c5*S(j)) - - ! SV = al0 + lambda / (pressure(j) + p0) - - I_denom = 1.0 / (pressure(j) + p0) - dSV_dT(j) = (a1 + I_denom * (c1 + T(j)*((2.0*c2 + 3.0*c3*T(j))) + c5*S(j))) - & - (I_denom**2 * lambda) * (b1 + T(j)*((2.0*b2 + 3.0*b3*T(j))) + b5*S(j)) - dSV_dS(j) = (a2 + I_denom * (c4 + c5*T(j))) - & - (I_denom**2 * lambda) * (b4 + b5*T(j)) - enddo + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: I_denom ! The inverse of the denominator of density in the Wright EOS [s2 m-2] + + al0 = (a0 + a1*T) +a2*S + p0 = (b0 + b4*S) + T * (b1 + T*((b2 + b3*T)) + b5*S) + lambda = (c0 +c4*S) + T * (c1 + T*((c2 + c3*T)) + c5*S) + + I_denom = 1.0 / (lambda + al0*(pressure + p0)) + rho = (pressure + p0) * I_denom + drho_dp = lambda * I_denom * I_denom + +end subroutine calculate_compress_elem_buggy_Wright + +!> Calculates analytical and nearly-analytical integrals, in pressure across layers, to determine +!! the layer-average specific volumes. There are essentially no free assumptions, apart from a +!! truncation in the series for log(1-eps/1+eps) that assumes that |eps| < 0.34. +subroutine avg_spec_vol_buggy_Wright(T, S, p_t, dp, SpV_avg, start, npts) + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface + !! [degC]. + real, dimension(:), intent(in) :: S !< Salinity [PSU]. + real, dimension(:), intent(in) :: p_t !< Pressure at the top of the layer [Pa] + real, dimension(:), intent(in) :: dp !< Pressure change in the layer [Pa] + real, dimension(:), intent(inout) :: SpV_avg !< The vertical average specific volume + !! in the layer [m3 kg-1] + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. -end subroutine calculate_specvol_derivs_wright - -!> This subroutine computes the in situ density of sea water (rho in -!! [kg m-3]) and the compressibility (drho/dp = C_sound^-2) -!! (drho_dp [s2 m-2]) from salinity (sal in psu), potential -!! temperature (T [degC]), and pressure [Pa]. It uses the expressions -!! from Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. -!! Coded by R. Hallberg, 1/01 -subroutine calculate_compress_wright(T, S, pressure, rho, drho_dp, start, npts) - real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface [degC]. - real, intent(in), dimension(:) :: S !< Salinity [PSU]. - real, intent(in), dimension(:) :: pressure !< pressure [Pa]. - real, intent(inout), dimension(:) :: rho !< In situ density [kg m-3]. - real, intent(inout), dimension(:) :: drho_dp !< The partial derivative of density with pressure - !! (also the inverse of the square of sound speed) - !! [s2 m-2]. - integer, intent(in) :: start !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. - - ! Coded by R. Hallberg, 1/01 ! Local variables - real :: al0, p0, lambda, I_denom + real :: al0 ! A term in the Wright EOS [m3 kg-1] + real :: p0 ! A term in the Wright EOS [Pa] + real :: lambda ! A term in the Wright EOS [m2 s-2] + real :: eps2 ! The square of a nondimensional ratio [nondim] + real :: I_pterm ! The inverse of p0 plus p_ave [Pa-1]. + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0, C1_9 = 1.0/9.0 ! Rational constants [nondim] integer :: j + ! alpha(j) = al0 + lambda / (pressure(j) + p0) do j=start,start+npts-1 - al0 = (a0 + a1*T(j)) +a2*S(j) - p0 = (b0 + b4*S(j)) + T(j) * (b1 + T(j)*((b2 + b3*T(j))) + b5*S(j)) - lambda = (c0 +c4*S(j)) + T(j) * (c1 + T(j)*((c2 + c3*T(j))) + c5*S(j)) - - I_denom = 1.0 / (lambda + al0*(pressure(j) + p0)) - rho(j) = (pressure(j) + p0) * I_denom - drho_dp(j) = lambda * I_denom * I_denom + al0 = a0 + (a1*T(j) + a2*S(j)) + p0 = b0 + ( b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j))) ) + lambda = c0 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) + + I_pterm = 1.0 / (p0 + (p_t(j) + 0.5*dp(j))) + eps2 = (0.5 * dp(j) * I_pterm)**2 + SpV_avg(j) = al0 + (lambda * I_pterm) * & + (1.0 + eps2*(C1_3 + eps2*(0.2 + eps2*(C1_7 + eps2*C1_9)))) enddo -end subroutine calculate_compress_wright - -!> This subroutine calculates analytical and nearly-analytical integrals of -!! pressure anomalies across layers, which are required for calculating the -!! finite-volume form pressure accelerations in a Boussinesq model. +end subroutine avg_spec_vol_buggy_Wright + +!> Return the range of temperatures, salinities and pressures for which the reduced-range equation +!! of state from Wright (1997) has been fitted to observations. Care should be taken when applying +!! this equation of state outside of its fit range. +subroutine EoS_fit_range_buggy_Wright(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + real, optional, intent(out) :: T_min !< The minimum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: S_max !< The maximum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + if (present(T_min)) T_min = -2.0 + if (present(T_max)) T_max = 30.0 + if (present(S_min)) S_min = 28.0 + if (present(S_max)) S_max = 38.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 5.0e7 + +end subroutine EoS_fit_range_buggy_Wright + +!> Calculates analytical and nearly-analytical integrals, in geopotential across layers, of pressure +!! anomalies, which are required for calculating the finite-volume form pressure accelerations in a +!! Boussinesq model. There are essentially no free assumptions, apart from the use of Boole's rule +!! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) +!! that assumes that |eps| < 0.34. subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & - dpa, intz_dpa, intx_dpa, inty_dpa, & - bathyT, dz_neglect, useMassWghtInterp, rho_scale, pres_scale, Z_0p) + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, & + MassWghtInterp, rho_scale, pres_scale, temp_scale, saln_scale, Z_0p) type(hor_index_type), intent(in) :: HI !< The horizontal index type for the arrays. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface - !! [degC]. + !! [C ~> degC]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S !< Salinity [PSU]. + intent(in) :: S !< Salinity [S ~> PSU]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: z_b !< Height at the top of the layer [Z ~> m]. - real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that is subtracted + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that is subtracted !! out to reduce the magnitude of each of the integrals. - !! (The pressure is calucated as p~=-z*rho_0*G_e.) - real, intent(in) :: rho_0 !< Density [R ~> kg m-3] or [kg m-3], that is used + !! (The pressure is calculated as p~=-z*rho_0*G_e.) + real, intent(in) :: rho_0 !< Density [R ~> kg m-3], that is used !! to calculate the pressure (as p~=-z*rho_0*G_e) !! used in the equation of state. real, intent(in) :: G_e !< The Earth's gravitational acceleration - !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2]. + !! [L2 Z-1 T-2 ~> m s-2]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(inout) :: dpa !< The change in the pressure anomaly across the - !! layer [R L2 T-2 ~> Pa] or [Pa]. + !! layer [R L2 T-2 ~> Pa]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer !! of the pressure anomaly relative to the anomaly @@ -444,26 +426,40 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & !! layer divided by the y grid spacing [R L2 T-2 ~> Pa]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: SSH !< The sea surface height [Z ~> m] real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals real, optional, intent(in) :: rho_scale !< A multiplicative factor by which to scale density !! from kg m-3 to the desired units [R m3 kg-1 ~> 1] real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure !! into Pa [Pa T2 R-1 L-2 ~> 1]. - real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + real, optional, intent(in) :: temp_scale !< A multiplicative factor by which to scale + !! temperature into degC [degC C-1 ~> 1] + real, optional, intent(in) :: saln_scale !< A multiplicative factor to convert pressure + !! into PSU [PSU S-1 ~> 1]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! Local variables - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d, p0_2d, lambda_2d - real :: al0, p0, lambda + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d ! A term in the Wright EOS [m3 kg-1] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: p0_2d ! A term in the Wright EOS [Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: lambda_2d ! A term in the Wright EOS [m2 s-2] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: z0pres ! The height at which the pressure is zero [Z ~> m] + real :: al0 ! A term in the Wright EOS [m3 kg-1] + real :: p0 ! A term in the Wright EOS [Pa] + real :: lambda ! A term in the Wright EOS [m2 s-2] real :: rho_anom ! The density anomaly from rho_ref [kg m-3]. - real :: eps, eps2, rem + real :: eps, eps2 ! A nondimensional ratio and its square [nondim] + real :: rem ! [kg m-1 s-2] real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] real :: g_Earth ! The gravitational acceleration [m2 Z-1 s-2 ~> m s-2] real :: I_Rho ! The inverse of the Boussinesq density [m3 kg-1] - real :: rho_ref_mks ! The reference density in MKS units, never rescaled from kg m-3 [kg m-3] + real :: rho_ref_mks ! The reference density in MKS units [kg m-3] real :: p_ave ! The layer averaged pressure [Pa] - real :: I_al0, I_Lzz + real :: I_al0 ! The inverse of al0 [kg m-3] + real :: I_Lzz ! The inverse of the denominator [Pa-1] real :: dz ! The layer thickness [Z ~> m]. real :: hWght ! A pressure-thickness below topography [Z ~> m]. real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m]. @@ -473,13 +469,25 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. real :: intz(5) ! The gravitational acceleration times the integrals of density - ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa]. + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa]. real :: Pa_to_RL2_T2 ! A conversion factor of pressures from Pa to the output units indicated by - ! pres_scale [R L2 T-2 Pa-1 ~> 1] or [1]. - real :: z0pres ! The height at which the pressure is zero [Z ~> m] + ! pres_scale [R L2 T-2 Pa-1 ~> 1]. + real :: a1s ! Partly rescaled version of a1 [m3 kg-1 C-1 ~> m3 kg-1 degC-1] + real :: a2s ! Partly rescaled version of a2 [m3 kg-1 S-1 ~> m3 kg-1 PSU-1] + real :: b1s ! Partly rescaled version of b1 [Pa C-1 ~> Pa degC-1] + real :: b2s ! Partly rescaled version of b2 [Pa C-2 ~> Pa degC-2] + real :: b3s ! Partly rescaled version of b3 [Pa C-3 ~> Pa degC-3] + real :: b4s ! Partly rescaled version of b4 [Pa S-1 ~> Pa PSU-1] + real :: b5s ! Partly rescaled version of b5 [Pa C-1 S-1 ~> Pa degC-1 PSU-1] + real :: c1s ! Partly rescaled version of c1 [m2 s-2 C-1 ~> m2 s-2 degC-1] + real :: c2s ! Partly rescaled version of c2 [m2 s-2 C-2 ~> m2 s-2 degC-2] + real :: c3s ! Partly rescaled version of c3 [m2 s-2 C-3 ~> m2 s-2 degC-3] + real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] + real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] logical :: do_massWeight ! Indicates whether to do mass weighting. - real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants. - real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] + real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m ! These array bounds work for the indexing convention of the input arrays, but @@ -502,26 +510,47 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & else rho_ref_mks = rho_ref ; I_Rho = 1.0 / rho_0 endif - z0pres = 0.0 ; if (present(Z_0p)) z0pres = Z_0p - - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. - ! if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "bathyT must be present if useMassWghtInterp is present and true.") - ! if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "dz_neglect must be present if useMassWghtInterp is present and true.") + if (present(Z_0p)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + z0pres(i,j) = Z_0p(i,j) + enddo ; enddo + else + z0pres(:,:) = 0.0 + endif + + a1s = a1 ; a2s = a2 + b1s = b1 ; b2s = b2 ; b3s = b3 ; b4s = b4 ; b5s = b5 + c1s = c1 ; c2s = c2 ; c3s = c3 ; c4s = c4 ; c5s = c5 + + if (present(temp_scale)) then ; if (temp_scale /= 1.0) then + a1s = a1s * temp_scale + b1s = b1s * temp_scale ; b2s = b2s * temp_scale**2 + b3s = b3s * temp_scale**3 ; b5s = b5s * temp_scale + c1s = c1s * temp_scale ; c2s = c2s * temp_scale**2 + c3s = c3s * temp_scale**3 ; c5s = c5s * temp_scale + endif ; endif + + if (present(saln_scale)) then ; if (saln_scale /= 1.0) then + a2s = a2s * saln_scale + b4s = b4s * saln_scale ; b5s = b5s * saln_scale + c4s = c4s * saln_scale ; c5s = c5s * saln_scale endif ; endif + do_massWeight = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + endif + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - al0_2d(i,j) = (a0 + a1*T(i,j)) + a2*S(i,j) - p0_2d(i,j) = (b0 + b4*S(i,j)) + T(i,j) * (b1 + T(i,j)*((b2 + b3*T(i,j))) + b5*S(i,j)) - lambda_2d(i,j) = (c0 +c4*S(i,j)) + T(i,j) * (c1 + T(i,j)*((c2 + c3*T(i,j))) + c5*S(i,j)) + al0_2d(i,j) = (a0 + a1s*T(i,j)) + a2s*S(i,j) + p0_2d(i,j) = (b0 + b4s*S(i,j)) + T(i,j) * (b1s + T(i,j)*((b2s + b3s*T(i,j))) + b5s*S(i,j)) + lambda_2d(i,j) = (c0 +c4s*S(i,j)) + T(i,j) * (c1s + T(i,j)*((c2s + c3s*T(i,j))) + c5s*S(i,j)) al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) dz = z_t(i,j) - z_b(i,j) - p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres) + p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres(i,j)) I_al0 = 1.0 / al0 I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) @@ -544,6 +573,8 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & hWght = 0.0 if (do_massWeight) & hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i+1,j)-SSH(i,j), z_b(i,j)-SSH(i+1,j)) if (hWght > 0.) then hL = (z_t(i,j) - z_b(i,j)) + dz_neglect hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect @@ -558,14 +589,15 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) do m=2,4 wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR) - al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i+1,j) - p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i+1,j) - lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i+1,j) + al0 = (wtT_L*al0_2d(i,j)) + (wtT_R*al0_2d(i+1,j)) + p0 = (wtT_L*p0_2d(i,j)) + (wtT_R*p0_2d(i+1,j)) + lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j)) - dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j)) - p_ave = -GxRho*(0.5*(wt_L*(z_t(i,j)+z_b(i,j)) + wt_R*(z_t(i+1,j)+z_b(i+1,j))) - z0pres) + dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j))) + p_ave = -GxRho*((wt_L * (0.5*(z_t(i,j)+z_b(i,j)) - z0pres(i,j))) + & + (wt_R * (0.5*(z_t(i+1,j)+z_b(i+1,j)) - z0pres(i+1,j)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) @@ -585,6 +617,8 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & hWght = 0.0 if (do_massWeight) & hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i,j+1)-SSH(i,j), z_b(i,j)-SSH(i,j+1)) if (hWght > 0.) then hL = (z_t(i,j) - z_b(i,j)) + dz_neglect hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect @@ -599,14 +633,15 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) do m=2,4 wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR) - al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i,j+1) - p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i,j+1) - lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i,j+1) + al0 = (wtT_L*al0_2d(i,j)) + (wtT_R*al0_2d(i,j+1)) + p0 = (wtT_L*p0_2d(i,j)) + (wtT_R*p0_2d(i,j+1)) + lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i,j+1)) - dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1)) - p_ave = -GxRho*(0.5*(wt_L*(z_t(i,j)+z_b(i,j)) + wt_R*(z_t(i,j+1)+z_b(i,j+1))) - z0pres) + dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1))) + p_ave = -GxRho*((wt_L*(0.5*(z_t(i,j)+z_b(i,j))-z0pres(i,j))) + & + (wt_R*(0.5*(z_t(i,j+1)+z_b(i,j+1))-z0pres(i,j+1)))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) @@ -621,66 +656,72 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & end subroutine int_density_dz_wright -!> This subroutine calculates analytical and nearly-analytical integrals in -!! pressure across layers of geopotential anomalies, which are required for -!! calculating the finite-volume form pressure accelerations in a non-Boussinesq -!! model. There are essentially no free assumptions, apart from the use of -!! Boole's rule to do the horizontal integrals, and from a truncation in the -!! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. +!> Calculates analytical and nearly-analytical integrals, in pressure across layers, of geopotential +!! anomalies, which are required for calculating the finite-volume form pressure accelerations in a +!! non-Boussinesq model. There are essentially no free assumptions, apart from the use of Boole's +!! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) +!! that assumes that |eps| < 0.34. subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & - intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_neglect, useMassWghtInterp, SV_scale, pres_scale) + intp_dza, intx_dza, inty_dza, halo_size, bathyP, P_surf, dP_neglect, & + MassWghtInterp, SV_scale, pres_scale, temp_scale, saln_scale) type(hor_index_type), intent(in) :: HI !< The ocean's horizontal index type. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface - !! [degC]. + !! [C ~> degC]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S !< Salinity [PSU]. + intent(in) :: S !< Salinity [S ~> PSU]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] or [Pa]. + intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_b !< Pressure at the top of the layer [R L2 T-2 ~> Pa] or [Pa]. + intent(in) :: p_b !< Pressure at the top of the layer [R L2 T-2 ~> Pa] real, intent(in) :: spv_ref !< A mean specific volume that is subtracted out !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1]. !! The calculation is mathematically identical with different values of !! spv_ref, but this reduces the effects of roundoff. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(inout) :: dza !< The change in the geopotential anomaly across - !! the layer [T-2 ~> m2 s-2] or [m2 s-2]. + !! the layer [L2 T-2 ~> m2 s-2]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of !! the geopotential anomaly relative to the anomaly !! at the bottom of the layer [R L4 T-4 ~> Pa m2 s-2] - !! or [Pa m2 s-2]. real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & optional, intent(inout) :: intx_dza !< The integral in x of the difference between the !! geopotential anomaly at the top and bottom of !! the layer divided by the x grid spacing - !! [L2 T-2 ~> m2 s-2] or [m2 s-2]. + !! [L2 T-2 ~> m2 s-2]. real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & optional, intent(inout) :: inty_dza !< The integral in y of the difference between the !! geopotential anomaly at the top and bottom of !! the layer divided by the y grid spacing - !! [L2 T-2 ~> m2 s-2] or [m2 s-2]. + !! [L2 T-2 ~> m2 s-2]. integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate !! dza. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with - !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. + !! the same units as p_t [R L2 T-2 ~> Pa] + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals real, optional, intent(in) :: SV_scale !< A multiplicative factor by which to scale specific !! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure !! into Pa [Pa T2 R-1 L-2 ~> 1]. + real, optional, intent(in) :: temp_scale !< A multiplicative factor by which to scale + !! temperature into degC [degC C-1 ~> 1] + real, optional, intent(in) :: saln_scale !< A multiplicative factor to convert pressure + !! into PSU [PSU S-1 ~> 1]. ! Local variables - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d, p0_2d, lambda_2d + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d ! A term in the Wright EOS [R-1 ~> m3 kg-1] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: p0_2d ! A term in the Wright EOS [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: lambda_2d ! A term in the Wright EOS [L2 T-2 ~> m2 s-2] real :: al0 ! A term in the Wright EOS [R-1 ~> m3 kg-1] real :: p0 ! A term in the Wright EOS [R L2 T-2 ~> Pa] real :: lambda ! A term in the Wright EOS [L2 T-2 ~> m2 s-2] - real :: al0_scale ! Scaling factor to convert al0 from MKS units [R-1 kg m-3 ~> 1] + real :: al0_scale ! Scaling factor to convert al0 from MKS units [kg m-3 R-1 ~> 1] real :: p0_scale ! Scaling factor to convert p0 from MKS units [R L2 T-2 Pa-1 ~> 1] real :: lam_scale ! Scaling factor to convert lambda from MKS units [L2 s2 T-2 m-2 ~> 1] real :: p_ave ! The layer average pressure [R L2 T-2 ~> Pa] @@ -697,16 +738,30 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. real :: intp(5) ! The integrals of specific volume with pressure at the ! 5 sub-column locations [L2 T-2 ~> m2 s-2]. + real :: a1s ! Partly rescaled version of a1 [m3 kg-1 C-1 ~> m3 kg-1 degC-1] + real :: a2s ! Partly rescaled version of a2 [m3 kg-1 S-1 ~> m3 kg-1 PSU-1] + real :: b1s ! Partly rescaled version of b1 [Pa C-1 ~> Pa degC-1] + real :: b2s ! Partly rescaled version of b2 [Pa C-2 ~> Pa degC-2] + real :: b3s ! Partly rescaled version of b3 [Pa C-3 ~> Pa degC-3] + real :: b4s ! Partly rescaled version of b4 [Pa S-1 ~> Pa PSU-1] + real :: b5s ! Partly rescaled version of b5 [Pa C-1 S-1 ~> Pa degC-1 PSU-1] + real :: c1s ! Partly rescaled version of c1 [m2 s-2 C-1 ~> m2 s-2 degC-1] + real :: c2s ! Partly rescaled version of c2 [m2 s-2 C-2 ~> m2 s-2 degC-2] + real :: c3s ! Partly rescaled version of c3 [m2 s-2 C-3 ~> m2 s-2 degC-3] + real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] + real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] logical :: do_massWeight ! Indicates whether to do mass weighting. - real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants. - real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface + logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] + real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, halo Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB halo = 0 ; if (present(halo_size)) halo = MAX(halo_size,0) ish = HI%isc-halo ; ieh = HI%iec+halo ; jsh = HI%jsc-halo ; jeh = HI%jec+halo - if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh); endif - if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh); endif + if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh) ; endif + if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh) ; endif al0_scale = 1.0 ; if (present(SV_scale)) al0_scale = SV_scale @@ -716,20 +771,36 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & endif ; endif lam_scale = al0_scale * p0_scale - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. -! if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "bathyP must be present if useMassWghtInterp is present and true.") -! if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "dP_neglect must be present if useMassWghtInterp is present and true.") + a1s = a1 ; a2s = a2 + b1s = b1 ; b2s = b2 ; b3s = b3 ; b4s = b4 ; b5s = b5 + c1s = c1 ; c2s = c2 ; c3s = c3 ; c4s = c4 ; c5s = c5 + + if (present(temp_scale)) then ; if (temp_scale /= 1.0) then + a1s = a1s * temp_scale + b1s = b1s * temp_scale ; b2s = b2s * temp_scale**2 + b3s = b3s * temp_scale**3 ; b5s = b5s * temp_scale + c1s = c1s * temp_scale ; c2s = c2s * temp_scale**2 + c3s = c3s * temp_scale**3 ; c5s = c5s * temp_scale + endif ; endif + + if (present(saln_scale)) then ; if (saln_scale /= 1.0) then + a2s = a2s * saln_scale + b4s = b4s * saln_scale ; b5s = b5s * saln_scale + c4s = c4s * saln_scale ; c5s = c5s * saln_scale endif ; endif + do_massWeight = .false. ; massWeight_bug = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set + endif + ! alpha(j) = (lambda + al0*(pressure(j) + p0)) / (pressure(j) + p0) do j=jsh,jeh ; do i=ish,ieh - al0_2d(i,j) = al0_scale * ( (a0 + a1*T(i,j)) + a2*S(i,j) ) - p0_2d(i,j) = p0_scale * ( (b0 + b4*S(i,j)) + T(i,j) * (b1 + T(i,j)*((b2 + b3*T(i,j))) + b5*S(i,j)) ) - lambda_2d(i,j) = lam_scale * ( (c0 + c4*S(i,j)) + T(i,j) * (c1 + T(i,j)*((c2 + c3*T(i,j))) + c5*S(i,j)) ) + al0_2d(i,j) = al0_scale * ( (a0 + a1s*T(i,j)) + a2s*S(i,j) ) + p0_2d(i,j) = p0_scale * ( (b0 + b4s*S(i,j)) + T(i,j) * (b1s + T(i,j)*((b2s + b3s*T(i,j))) + b5s*S(i,j)) ) + lambda_2d(i,j) = lam_scale * ( (c0 + c4s*S(i,j)) + T(i,j) * (c1s + T(i,j)*((c2s + c3s*T(i,j))) + c5s*S(i,j)) ) al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) dp = p_b(i,j) - p_t(i,j) @@ -748,8 +819,13 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & ! hydrostatic consistency. For large hWght we bias the interpolation of ! T & S along the top and bottom integrals, akin to thickness weighting. hWght = 0.0 - if (do_massWeight) & + if (do_massWeight .and. massWeight_bug) then hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i+1,j), P_surf(i+1,j)-p_b(i,j)) if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect @@ -764,16 +840,16 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) do m=2,4 wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR) - ! T, S, and p are interpolated in the horizontal. The p interpolation - ! is linear, but for T and S it may be thickness wekghted. - al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i+1,j) - p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i+1,j) - lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i+1,j) + ! T, S and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + al0 = (wtT_L*al0_2d(i,j)) + (wtT_R*al0_2d(i+1,j)) + p0 = (wtT_L*p0_2d(i,j)) + (wtT_R*p0_2d(i+1,j)) + lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j)) - dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(i+1,j)) - p_ave = 0.5*(wt_L*(p_t(i,j)+p_b(i,j)) + wt_R*(p_t(i+1,j)+p_b(i+1,j))) + dp = (wt_L*(p_b(i,j) - p_t(i,j))) + (wt_R*(p_b(i+1,j) - p_t(i+1,j))) + p_ave = 0.5*((wt_L*(p_t(i,j)+p_b(i,j))) + (wt_R*(p_t(i+1,j)+p_b(i+1,j)))) eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps intp(m) = (al0 + lambda / (p0 + p_ave) - spv_ref)*dp + 2.0*eps* & @@ -789,8 +865,13 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & ! hydrostatic consistency. For large hWght we bias the interpolation of ! T & S along the top and bottom integrals, akin to thickness weighting. hWght = 0.0 - if (do_massWeight) & + if (do_massWeight .and. massWeight_bug) then hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i,j+1), P_surf(i,j+1)-p_b(i,j)) if (hWght > 0.) then hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect @@ -805,16 +886,16 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) do m=2,4 wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR) - ! T, S, and p are interpolated in the horizontal. The p interpolation - ! is linear, but for T and S it may be thickness wekghted. - al0 = wt_L*al0_2d(i,j) + wt_R*al0_2d(i,j+1) - p0 = wt_L*p0_2d(i,j) + wt_R*p0_2d(i,j+1) - lambda = wt_L*lambda_2d(i,j) + wt_R*lambda_2d(i,j+1) + ! T, S and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + al0 = (wt_L*al0_2d(i,j)) + (wt_R*al0_2d(i,j+1)) + p0 = (wt_L*p0_2d(i,j)) + (wt_R*p0_2d(i,j+1)) + lambda = (wt_L*lambda_2d(i,j)) + (wt_R*lambda_2d(i,j+1)) - dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(i,j+1)) - p_ave = 0.5*(wt_L*(p_t(i,j)+p_b(i,j)) + wt_R*(p_t(i,j+1)+p_b(i,j+1))) + dp = (wt_L*(p_b(i,j) - p_t(i,j))) + (wt_R*(p_b(i,j+1) - p_t(i,j+1))) + p_ave = 0.5*((wt_L*(p_t(i,j)+p_b(i,j))) + (wt_R*(p_t(i,j+1)+p_b(i,j+1)))) eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps intp(m) = (al0 + lambda / (p0 + p_ave) - spv_ref)*dp + 2.0*eps* & @@ -826,4 +907,94 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & enddo ; enddo ; endif end subroutine int_spec_vol_dp_wright +!> Calculate the in-situ density for 1D arraya inputs and outputs. +subroutine calculate_density_array_buggy_Wright(this, T, S, pressure, rho, start, npts, rho_ref) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: rho !< In situ density [kg m-3] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + + ! Local variables + integer :: j + + if (present(rho_ref)) then + do j = start, start+npts-1 + rho(j) = density_anomaly_elem_buggy_Wright(this, T(j), S(j), pressure(j), rho_ref) + enddo + else + do j = start, start+npts-1 + rho(j) = density_elem_buggy_Wright(this, T(j), S(j), pressure(j)) + enddo + endif + +end subroutine calculate_density_array_buggy_Wright + +!> Calculate the in-situ specific volume for 1D array inputs and outputs. +subroutine calculate_spec_vol_array_buggy_Wright(this, T, S, pressure, specvol, start, npts, spv_ref) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: specvol !< In situ specific volume [m3 kg-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + ! Local variables + integer :: j + + if (present(spv_ref)) then + do j = start, start+npts-1 + specvol(j) = spec_vol_anomaly_elem_buggy_Wright(this, T(j), S(j), pressure(j), spv_ref) + enddo + else + do j = start, start+npts-1 + specvol(j) = spec_vol_elem_buggy_Wright(this, T(j), S(j), pressure(j) ) + enddo + endif + +end subroutine calculate_spec_vol_array_buggy_Wright + + +!> Set coefficients that can correct bugs un the buggy Wright equation of state. +subroutine set_params_buggy_Wright(this, use_Wright_2nd_deriv_bug) + class(buggy_Wright_EOS), intent(inout) :: this !< This EOS + logical, optional, intent(in) :: use_Wright_2nd_deriv_bug !< If true, use a buggy + !! buggy version of the calculations of the second + !! derivative of density with temperature and with temperature and + !! pressure. This bug is corrected in the default version. + + this%three = 3.0 + if (present(use_Wright_2nd_deriv_bug)) then + if (use_Wright_2nd_deriv_bug) then ; this%three = 2.0 + else ; this%three = 3.0 ; endif + endif + +end subroutine set_params_buggy_Wright + + +!> \namespace mom_eos_wright +!! +!! \section section_EOS_Wright Wright equation of state +!! +!! Wright, 1997, provide an approximation for the in situ density as a function of +!! potential temperature, salinity and pressure. The formula follow the Tumlirz +!! equation of state which are easier to evaluate and make efficient. +!! +!! Two ranges are provided by Wright: a "full" range and "reduced" range. The version in this +!! module uses the reduced range. +!! +!! Originally coded in 2000 by R. Hallberg. +!! Anomaly form coded in 3/18. +!! +!! \subsection section_EOS_Wright_references References +!! +!! Wright, D., 1997: An Equation of State for Use in Ocean Models: Eckart's Formula Revisited. +!! J. Ocean. Atmosph. Tech., 14 (3), 735-740. +!! https://journals.ametsoc.org/doi/abs/10.1175/1520-0426%281997%29014%3C0735%3AAEOSFU%3E2.0.CO%3B2 + end module MOM_EOS_Wright diff --git a/src/equation_of_state/MOM_EOS_Wright_full.F90 b/src/equation_of_state/MOM_EOS_Wright_full.F90 new file mode 100644 index 0000000000..e80af3fdf9 --- /dev/null +++ b/src/equation_of_state/MOM_EOS_Wright_full.F90 @@ -0,0 +1,992 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> The equation of state using the Wright 1997 expressions with full range of data. +module MOM_EOS_Wright_full + +use MOM_EOS_base_type, only : EOS_base +use MOM_hor_index, only : hor_index_type + +implicit none ; private + +public Wright_full_EOS +public int_density_dz_wright_full, int_spec_vol_dp_wright_full +public avg_spec_vol_Wright_full + +!>@{ Parameters in the Wright equation of state using the full range formula, which is a fit to the UNESCO +! equation of state for the full range: -2 < theta < 40 [degC], 0 < S < 40 [PSU], 0 < p < 1e8 [Pa]. + + ! Note that a0/a1 ~= 2618 [degC] ; a0/a2 ~= -4333 [PSU] + ! b0/b1 ~= 156 [degC] ; b0/b4 ~= 974 [PSU] + ! c0/c1 ~= 216 [degC] ; c0/c4 ~= -741 [PSU] +real, parameter :: a0 = 7.133718e-4 ! A parameter in the Wright alpha_0 fit [m3 kg-1] +real, parameter :: a1 = 2.724670e-7 ! A parameter in the Wright alpha_0 fit [m3 kg-1 degC-1] +real, parameter :: a2 = -1.646582e-7 ! A parameter in the Wright alpha_0 fit [m3 kg-1 PSU-1] +real, parameter :: b0 = 5.613770e8 ! A parameter in the Wright p_0 fit [Pa] +real, parameter :: b1 = 3.600337e6 ! A parameter in the Wright p_0 fit [Pa degC-1] +real, parameter :: b2 = -3.727194e4 ! A parameter in the Wright p_0 fit [Pa degC-2] +real, parameter :: b3 = 1.660557e2 ! A parameter in the Wright p_0 fit [Pa degC-3] +real, parameter :: b4 = 6.844158e5 ! A parameter in the Wright p_0 fit [Pa PSU-1] +real, parameter :: b5 = -8.389457e3 ! A parameter in the Wright p_0 fit [Pa degC-1 PSU-1] +real, parameter :: c0 = 1.609893e5 ! A parameter in the Wright lambda fit [m2 s-2] +real, parameter :: c1 = 8.427815e2 ! A parameter in the Wright lambda fit [m2 s-2 degC-1] +real, parameter :: c2 = -6.931554 ! A parameter in the Wright lambda fit [m2 s-2 degC-2] +real, parameter :: c3 = 3.869318e-2 ! A parameter in the Wright lambda fit [m2 s-2 degC-3] +real, parameter :: c4 = -1.664201e2 ! A parameter in the Wright lambda fit [m2 s-2 PSU-1] +real, parameter :: c5 = -2.765195 ! A parameter in the Wright lambda fit [m2 s-2 degC-1 PSU-1] +!>@} + +!> The EOS_base implementation of the full range Wright 1997 equation of state +type, extends (EOS_base) :: Wright_full_EOS + +contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_Wright_full + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_Wright_full + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_Wright_full + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_Wright_full + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_Wright_full + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_Wright_full + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_Wright_full + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_Wright_full + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_Wright_full + + !> Local implementation of generic calculate_density_array for efficiency + procedure :: calculate_density_array => calculate_density_array_Wright_full + !> Local implementation of generic calculate_spec_vol_array for efficiency + procedure :: calculate_spec_vol_array => calculate_spec_vol_array_Wright_full + +end type Wright_full_EOS + +contains + +!> In situ density of sea water using a full range fit by Wright, 1997 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_elem_Wright_full(this, T, S, pressure) + class(Wright_full_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + + al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + density_elem_Wright_full = (pressure + p0) / (lambda + al0*(pressure + p0)) + +end function density_elem_Wright_full + +!> In situ density anomaly of sea water using a full range fit by Wright, 1997 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_anomaly_elem_Wright_full(this, T, S, pressure, rho_ref) + class(Wright_full_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: rho_ref !< A reference density [kg m-3] + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: al_TS ! The contributions of temperature and salinity to al0 [m3 kg-1] + real :: p_TSp ! A combination of the pressure and the temperature and salinity contributions to p0 [Pa] + real :: lam_TS ! The contributions of temperature and salinity to lambda [m2 s-2] + real :: pa_000 ! A corrected offset to the pressure, including contributions from rho_ref [Pa] + + pa_000 = b0*(1.0 - a0*rho_ref) - rho_ref*c0 + al_TS = a1*T + a2*S + al0 = a0 + al_TS + p_TSp = pressure + (b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S))) + lam_TS = c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) + + ! The following two expressions are mathematically equivalent. + ! rho = (b0 + p0_TSp) / ((c0 + lam_TS) + al0*(b0 + p0_TSp)) - rho_ref + density_anomaly_elem_Wright_full = & + (pa_000 + (p_TSp - rho_ref*(p_TSp*al0 + (b0*al_TS + lam_TS)))) / & + ( (c0 + lam_TS) + al0*(b0 + p_TSp) ) + +end function density_anomaly_elem_Wright_full + +!> In situ specific volume of sea water using a full range fit by Wright, 1997 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_elem_Wright_full(this, T, S, pressure) + class(Wright_full_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2], perhaps with + ! an offset to account for spv_ref + real :: al_TS ! The contributions of temperature and salinity to al0 [m3 kg-1] + real :: p_TSp ! A combination of the pressure and the temperature and salinity contributions to p0 [Pa] + real :: lam_000 ! A corrected offset to lambda, including contributions from spv_ref [m2 s-2] + + al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + spec_vol_elem_Wright_full = al0 + lambda / (pressure + p0) + +end function spec_vol_elem_Wright_full + +!> In situ specific volume anomaly of sea water using a full range fit by Wright, 1997 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_anomaly_elem_Wright_full(this, T, S, pressure, spv_ref) + class(Wright_full_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2], perhaps with + ! an offset to account for spv_ref + real :: al_TS ! The contributions of temperature and salinity to al0 [m3 kg-1] + real :: p_TSp ! A combination of the pressure and the temperature and salinity contributions to p0 [Pa] + real :: lam_000 ! A corrected offset to lambda, including contributions from spv_ref [m2 s-2] + + lam_000 = c0 + (a0 - spv_ref)*b0 + al_TS = a1*T + a2*S + p_TSp = pressure + (b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S))) + lambda = lam_000 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + ! This is equivalent to the expression below minus spv_ref, but less sensitive to roundoff. + spec_vol_anomaly_elem_Wright_full = al_TS + (lambda + (a0 - spv_ref)*p_TSp) / (b0 + p_TSp) + +end function spec_vol_anomaly_elem_Wright_full + +!> Calculate the partial derivatives of density with potential temperature and salinity +!! using the full range equation of state, as fit by Wright, 1997 +elemental subroutine calculate_density_derivs_elem_Wright_full(this, T, S, pressure, drho_dT, drho_dS) + class(Wright_full_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1] + real, intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 PSU-1] + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: I_denom2 ! The inverse of the square of the denominator of density in the Wright EOS [s4 m-4] + + al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + + I_denom2 = 1.0 / (lambda + al0*(pressure + p0))**2 + drho_dT = I_denom2 * (lambda * (b1 + (T*(2.0*b2 + 3.0*b3*T) + b5*S)) - & + (pressure+p0) * ( (pressure+p0)*a1 + (c1 + (T*(c2*2.0 + c3*3.0*T) + c5*S)) )) + drho_dS = I_denom2 * (lambda * (b4 + b5*T) - & + (pressure+p0) * ( (pressure+p0)*a2 + (c4 + c5*T) )) + +end subroutine calculate_density_derivs_elem_Wright_full + +!> Second derivatives of density with respect to temperature, salinity, and pressure, +!! using the full range equation of state, as fit by Wright, 1997 +elemental subroutine calculate_density_second_derivs_elem_Wright_full(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + class(Wright_full_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature referenced to 0 dbar [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, intent(inout) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, intent(inout) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: p_p0 ! A local work variable combining the pressure and pressure + ! offset (p0 elsewhere) in the Wright EOS [Pa] + real :: dp0_dT ! The partial derivative of p0 with temperature [Pa degC-1] + real :: dp0_dS ! The partial derivative of p0 with salinity [Pa PSU-1] + real :: dlam_dT ! The partial derivative of lambda with temperature [m2 s-2 degC-1] + real :: dlam_dS ! The partial derivative of lambda with salinity [m2 s-2 degC-1] + real :: dRdT_num ! The numerator in the expression for drho_dT [Pa m2 s-2 degC-1] = [kg m s-4 degC-1] + real :: dRdS_num ! The numerator in the expression for drho_ds [Pa m2 s-2 PSU-1] = [kg m s-4 PSU-1] + real :: ddenom_dT ! The derivative of the denominator of density in the Wright EOS with temperature [m2 s-2 deg-1] + real :: ddenom_dS ! The derivative of the denominator of density in the Wright EOS with salinity [m2 s-2 PSU-1] + real :: I_denom ! The inverse of the denominator of density in the Wright EOS [s2 m-2] + real :: I_denom2 ! The inverse of the square of the denominator of density in the Wright EOS [s4 m-4] + real :: I_denom3 ! The inverse of the cube of the denominator of density in the Wright EOS [s6 m-6] + + al0 = a0 + (a1*T + a2*S) + p_p0 = pressure + ( b0 + (b4*S + T*(b1 + (b5*S + T*(b2 + b3*T)))) ) ! P + p0 + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + dp0_dT = b1 + (b5*S + T*(2.*b2 + 3.*b3*T)) + dp0_dS = b4 + b5*T + dlam_dT = c1 + (c5*S + T*(2.*c2 + 3.*c3*T)) + dlam_dS = c4 + c5*T + I_denom = 1.0 / (lambda + al0*p_p0) + I_denom2 = I_denom*I_denom + I_denom3 = I_denom*I_denom2 + + ddenom_dS = (dlam_dS + a2*p_p0) + al0*dp0_dS + ddenom_dT = (dlam_dT + a1*p_p0) + al0*dp0_dT + dRdS_num = dp0_dS*lambda - p_p0*(dlam_dS + a2*p_p0) + dRdT_num = dp0_dT*lambda - p_p0*(dlam_dT + a1*p_p0) + + ! In deriving the following, it is useful to note that: + ! rho = p_p0 / (lambda + al0*p_p0) + ! drho_dp = lambda * I_denom2 + ! drho_dT = (dp0_dT*lambda - p_p0*(dlam_dT + a1*p_p0)) * I_denom2 = dRdT_num * I_denom2 + ! drho_dS = (dp0_dS*lambda - p_p0*(dlam_dS + a2*p_p0)) * I_denom2 = dRdS_num * I_denom2 + drho_ds_ds = -2.*(p_p0*(a2*dp0_dS)) * I_denom2 - 2.*(dRdS_num*ddenom_dS) * I_denom3 + drho_ds_dt = ((b5*lambda - p_p0*(c5 + 2.*a2*dp0_dT)) + (dp0_dS*dlam_dT - dp0_dT*dlam_dS))*I_denom2 - & + 2.*(ddenom_dT*dRdS_num) * I_denom3 + drho_dt_dt = 2.*((b2 + 3.*b3*T)*lambda - p_p0*((c2 + 3.*c3*T) + a1*dp0_dT))*I_denom2 - & + 2.*(dRdT_num * ddenom_dT) * I_denom3 + + ! The following is a rearranged form that is equivalent to + ! drho_ds_dp = dlam_dS * I_denom2 - 2.0 * lambda * (dlam_dS + a2*p_p0 + al0*dp0_ds) * Idenom3 + drho_ds_dp = (-dlam_dS - 2.*a2*p_p0) * I_denom2 - (2.*al0*dRdS_num) * I_denom3 + drho_dt_dp = (-dlam_dT - 2.*a1*p_p0) * I_denom2 - (2.*al0*dRdT_num) * I_denom3 + +end subroutine calculate_density_second_derivs_elem_Wright_full + +!> Calculate the partial derivatives of specific volume with temperature and salinity +!! using the full range equation of state, as fit by Wright, 1997 +elemental subroutine calculate_specvol_derivs_elem_Wright_full(this,T, S, pressure, dSV_dT, dSV_dS) + class(Wright_full_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1] + ! Local variables + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: I_denom ! The inverse of the denominator of specific volume in the Wright EOS [Pa-1] + + ! al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + + ! SV = al0 + lambda / (pressure + p0) + + I_denom = 1.0 / (pressure + p0) + dSV_dT = a1 + I_denom * ((c1 + (T*(2.0*c2 + 3.0*c3*T) + c5*S)) - & + (I_denom * lambda) * (b1 + (T*(2.0*b2 + 3.0*b3*T) + b5*S))) + dSV_dS = a2 + I_denom * ((c4 + c5*T) - & + (I_denom * lambda) * (b4 + b5*T)) + +end subroutine calculate_specvol_derivs_elem_Wright_full + +!> Compute the in situ density of sea water (rho) and the compressibility (drho/dp == C_sound^-2) +!! at the given salinity, potential temperature and pressure +!! using the full range equation of state, as fit by Wright, 1997 +elemental subroutine calculate_compress_elem_Wright_full(this, T, S, pressure, rho, drho_dp) + class(Wright_full_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: rho !< In situ density [kg m-3] + real, intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [s2 m-2] + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: I_denom ! The inverse of the denominator of density in the Wright EOS [s2 m-2] + + al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + + I_denom = 1.0 / (lambda + al0*(pressure + p0)) + rho = (pressure + p0) * I_denom + drho_dp = lambda * I_denom**2 + +end subroutine calculate_compress_elem_Wright_full + +!> Calculates analytical and nearly-analytical integrals, in pressure across layers, to determine +!! the layer-average specific volumes. There are essentially no free assumptions, apart from a +!! truncation in the series for log(1-eps/1+eps) that assumes that |eps| < 0.34. +subroutine avg_spec_vol_Wright_full(T, S, p_t, dp, SpV_avg, start, npts) + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface + !! [degC]. + real, dimension(:), intent(in) :: S !< Salinity [PSU]. + real, dimension(:), intent(in) :: p_t !< Pressure at the top of the layer [Pa] + real, dimension(:), intent(in) :: dp !< Pressure change in the layer [Pa] + real, dimension(:), intent(inout) :: SpV_avg !< The vertical average specific volume + !! in the layer [m3 kg-1] + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + + ! Local variables + real :: al0 ! A term in the Wright EOS [m3 kg-1] + real :: p0 ! A term in the Wright EOS [Pa] + real :: lambda ! A term in the Wright EOS [m2 s-2] + real :: eps2 ! The square of a nondimensional ratio [nondim] + real :: I_pterm ! The inverse of p0 plus p_ave [Pa-1]. + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0, C1_9 = 1.0/9.0 ! Rational constants [nondim] + integer :: j + + ! alpha = al0 + lambda / (pressure + p0) + do j=start,start+npts-1 + al0 = a0 + (a1*T(j) + a2*S(j)) + p0 = b0 + ( b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j))) ) + lambda = c0 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) + + I_pterm = 1.0 / (p0 + (p_t(j) + 0.5*dp(j))) + eps2 = (0.5 * dp(j) * I_pterm)**2 + SpV_avg(j) = al0 + (lambda * I_pterm) * & + (1.0 + eps2*(C1_3 + eps2*(0.2 + eps2*(C1_7 + eps2*C1_9)))) + enddo + +end subroutine avg_spec_vol_Wright_full + +!> Return the range of temperatures, salinities and pressures for which full-range equation +!! of state from Wright (1997) has been fitted to observations. Care should be taken when applying +!! this equation of state outside of its fit range. +subroutine EoS_fit_range_Wright_full(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(Wright_full_EOS), intent(in) :: this !< This EOS + real, optional, intent(out) :: T_min !< The minimum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: S_max !< The maximum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + if (present(T_min)) T_min = -2.0 + if (present(T_max)) T_max = 40.0 + if (present(S_min)) S_min = 0.0 + if (present(S_max)) S_max = 40.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 1.0e8 + +end subroutine EoS_fit_range_Wright_full + +!> Calculates analytical and nearly-analytical integrals, in geopotential across layers, of pressure +!! anomalies, which are required for calculating the finite-volume form pressure accelerations in a +!! Boussinesq model. There are essentially no free assumptions, apart from the use of Boole's rule +!! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) +!! that assumes that |eps| < 0.34. +subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, & + MassWghtInterp, rho_scale, pres_scale, temp_scale, saln_scale, Z_0p) + type(hor_index_type), intent(in) :: HI !< The horizontal index type for the arrays. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T !< Potential temperature relative to the surface + !! [C ~> degC]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S !< Salinity [S ~> PSU]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_b !< Height at the top of the layer [Z ~> m]. + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that is subtracted + !! out to reduce the magnitude of each of the integrals. + !! (The pressure is calculated as p~=-z*rho_0*G_e.) + real, intent(in) :: rho_0 !< Density [R ~> kg m-3], that is used + !! to calculate the pressure (as p~=-z*rho_0*G_e) + !! used in the equation of state. + real, intent(in) :: G_e !< The Earth's gravitational acceleration + !! [L2 Z-1 T-2 ~> m s-2]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(inout) :: dpa !< The change in the pressure anomaly across the + !! layer [R L2 T-2 ~> Pa]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer + !! of the pressure anomaly relative to the anomaly + !! at the top of the layer [R Z L2 T-2 ~> Pa m]. + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(inout) :: intx_dpa !< The integral in x of the difference between the + !! pressure anomaly at the top and bottom of the + !! layer divided by the x grid spacing [R L2 T-2 ~> Pa]. + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(inout) :: inty_dpa !< The integral in y of the difference between the + !! pressure anomaly at the top and bottom of the + !! layer divided by the y grid spacing [R L2 T-2 ~> Pa]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: SSH !< The sea surface height [Z ~> m] + real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals + real, optional, intent(in) :: rho_scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [Pa T2 R-1 L-2 ~> 1]. + real, optional, intent(in) :: temp_scale !< A multiplicative factor by which to scale + !! temperature into degC [degC C-1 ~> 1] + real, optional, intent(in) :: saln_scale !< A multiplicative factor to convert pressure + !! into PSU [PSU S-1 ~> 1]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + + ! Local variables + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d ! A term in the Wright EOS [m3 kg-1] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: p0_2d ! A term in the Wright EOS [Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: lambda_2d ! A term in the Wright EOS [m2 s-2] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: z0pres ! The height at which the pressure is zero [Z ~> m] + real :: al0 ! A term in the Wright EOS [m3 kg-1] + real :: p0 ! A term in the Wright EOS [Pa] + real :: lambda ! A term in the Wright EOS [m2 s-2] + real :: rho_anom ! The density anomaly from rho_ref [kg m-3]. + real :: eps, eps2 ! A nondimensional ratio and its square [nondim] + real :: rem ! [kg m-1 s-2] + real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] + real :: g_Earth ! The gravitational acceleration [m2 Z-1 s-2 ~> m s-2] + real :: I_Rho ! The inverse of the Boussinesq density [m3 kg-1] + real :: rho_ref_mks ! The reference density in MKS units [kg m-3] + real :: p_ave ! The layer averaged pressure [Pa] + real :: I_al0 ! The inverse of al0 [kg m-3] + real :: I_Lzz ! The inverse of the denominator [Pa-1] + real :: dz ! The layer thickness [Z ~> m]. + real :: hWght ! A pressure-thickness below topography [Z ~> m]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m]. + real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> m-2]. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim]. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim]. + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. + real :: intz(5) ! The gravitational acceleration times the integrals of density + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa]. + real :: Pa_to_RL2_T2 ! A conversion factor of pressures from Pa to the output units indicated by + ! pres_scale [R L2 T-2 Pa-1 ~> 1]. + real :: a1s ! Partly rescaled version of a1 [m3 kg-1 C-1 ~> m3 kg-1 degC-1] + real :: a2s ! Partly rescaled version of a2 [m3 kg-1 S-1 ~> m3 kg-1 PSU-1] + real :: b1s ! Partly rescaled version of b1 [Pa C-1 ~> Pa degC-1] + real :: b2s ! Partly rescaled version of b2 [Pa C-2 ~> Pa degC-2] + real :: b3s ! Partly rescaled version of b3 [Pa C-3 ~> Pa degC-3] + real :: b4s ! Partly rescaled version of b4 [Pa S-1 ~> Pa PSU-1] + real :: b5s ! Partly rescaled version of b5 [Pa C-1 S-1 ~> Pa degC-1 PSU-1] + real :: c1s ! Partly rescaled version of c1 [m2 s-2 C-1 ~> m2 s-2 degC-1] + real :: c2s ! Partly rescaled version of c2 [m2 s-2 C-2 ~> m2 s-2 degC-2] + real :: c3s ! Partly rescaled version of c3 [m2 s-2 C-3 ~> m2 s-2 degC-3] + real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] + real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] + logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] + real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m + + ! These array bounds work for the indexing convention of the input arrays, but + ! on the computational domain defined for the output arrays. + Isq = HI%IscB ; Ieq = HI%IecB + Jsq = HI%JscB ; Jeq = HI%JecB + is = HI%isc ; ie = HI%iec + js = HI%jsc ; je = HI%jec + + if (present(pres_scale)) then + GxRho = pres_scale * G_e * rho_0 ; g_Earth = pres_scale * G_e + Pa_to_RL2_T2 = 1.0 / pres_scale + else + GxRho = G_e * rho_0 ; g_Earth = G_e + Pa_to_RL2_T2 = 1.0 + endif + if (present(rho_scale)) then + g_Earth = g_Earth * rho_scale + rho_ref_mks = rho_ref / rho_scale ; I_Rho = rho_scale / rho_0 + else + rho_ref_mks = rho_ref ; I_Rho = 1.0 / rho_0 + endif + if (present(Z_0p)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + z0pres(i,j) = Z_0p(i,j) + enddo ; enddo + else + z0pres(:,:) = 0.0 + endif + + a1s = a1 ; a2s = a2 + b1s = b1 ; b2s = b2 ; b3s = b3 ; b4s = b4 ; b5s = b5 + c1s = c1 ; c2s = c2 ; c3s = c3 ; c4s = c4 ; c5s = c5 + + if (present(temp_scale)) then ; if (temp_scale /= 1.0) then + a1s = a1s * temp_scale + b1s = b1s * temp_scale ; b2s = b2s * temp_scale**2 + b3s = b3s * temp_scale**3 ; b5s = b5s * temp_scale + c1s = c1s * temp_scale ; c2s = c2s * temp_scale**2 + c3s = c3s * temp_scale**3 ; c5s = c5s * temp_scale + endif ; endif + + if (present(saln_scale)) then ; if (saln_scale /= 1.0) then + a2s = a2s * saln_scale + b4s = b4s * saln_scale ; b5s = b5s * saln_scale + c4s = c4s * saln_scale ; c5s = c5s * saln_scale + endif ; endif + + do_massWeight = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + endif + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + al0_2d(i,j) = a0 + (a1s*T(i,j) + a2s*S(i,j)) + p0_2d(i,j) = b0 + ( b4s*S(i,j) + T(i,j) * (b1s + (T(i,j)*(b2s + b3s*T(i,j)) + b5s*S(i,j))) ) + lambda_2d(i,j) = c0 + ( c4s*S(i,j) + T(i,j) * (c1s + (T(i,j)*(c2s + c3s*T(i,j)) + c5s*S(i,j))) ) + + al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) + + dz = z_t(i,j) - z_b(i,j) + p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres(i,j)) + + I_al0 = 1.0 / al0 + I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) + eps = 0.5*(GxRho*dz)*I_Lzz ; eps2 = eps*eps + +! rho = (pressure + p0) / (lambda + al0*(pressure + p0)) + + rho_anom = (p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks + rem = (I_Rho * (lambda * I_al0**2)) * (eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2)))) + dpa(i,j) = Pa_to_RL2_T2 * ((g_Earth*rho_anom)*dz - 2.0*eps*rem) + if (present(intz_dpa)) & + intz_dpa(i,j) = Pa_to_RL2_T2 * (0.5*(g_Earth*rho_anom)*dz**2 - dz*((1.0+eps)*rem)) + enddo ; enddo + + if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i+1,j)-SSH(i,j), z_b(i,j)-SSH(i+1,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR) + + al0 = (wtT_L*al0_2d(i,j)) + (wtT_R*al0_2d(i+1,j)) + p0 = (wtT_L*p0_2d(i,j)) + (wtT_R*p0_2d(i+1,j)) + lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j)) + + dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j))) + p_ave = -GxRho*((wt_L * (0.5*(z_t(i,j)+z_b(i,j)) - z0pres(i,j))) + & + (wt_R * (0.5*(z_t(i+1,j)+z_b(i+1,j)) - z0pres(i+1,j)))) + + I_al0 = 1.0 / al0 + I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) + eps = 0.5*(GxRho*dz)*I_Lzz ; eps2 = eps*eps + + intz(m) = Pa_to_RL2_T2 * ( (g_Earth*dz) * ((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks) - 2.0*eps * & + (I_Rho * (lambda * I_al0**2)) * (eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2)))) ) + enddo + ! Use Boole's rule to integrate the values. + intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) + enddo ; enddo ; endif + + if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=is,ie + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i,j+1)-SSH(i,j), z_b(i,j)-SSH(i,j+1)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR) + + al0 = (wtT_L*al0_2d(i,j)) + (wtT_R*al0_2d(i,j+1)) + p0 = (wtT_L*p0_2d(i,j)) + (wtT_R*p0_2d(i,j+1)) + lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i,j+1)) + + dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1))) + p_ave = -GxRho*((wt_L*(0.5*(z_t(i,j)+z_b(i,j))-z0pres(i,j))) + & + (wt_R*(0.5*(z_t(i,j+1)+z_b(i,j+1))-z0pres(i,j+1)))) + + I_al0 = 1.0 / al0 + I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) + eps = 0.5*(GxRho*dz)*I_Lzz ; eps2 = eps*eps + + intz(m) = Pa_to_RL2_T2 * ( (g_Earth*dz) * ((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks) - 2.0*eps * & + (I_Rho * (lambda * I_al0**2)) * (eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2)))) ) + enddo + ! Use Boole's rule to integrate the values. + inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) + enddo ; enddo ; endif + +end subroutine int_density_dz_wright_full + +!> Calculates analytical and nearly-analytical integrals, in pressure across layers, of geopotential +!! anomalies, which are required for calculating the finite-volume form pressure accelerations in a +!! non-Boussinesq model. There are essentially no free assumptions, apart from the use of Boole's +!! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) +!! that assumes that |eps| < 0.34. +subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & + intp_dza, intx_dza, inty_dza, halo_size, bathyP, P_surf, dP_neglect, & + MassWghtInterp, SV_scale, pres_scale, temp_scale, saln_scale) + type(hor_index_type), intent(in) :: HI !< The ocean's horizontal index type. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T !< Potential temperature relative to the surface + !! [C ~> degC]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S !< Salinity [S ~> PSU]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_b !< Pressure at the top of the layer [R L2 T-2 ~> Pa] + real, intent(in) :: spv_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1]. + !! The calculation is mathematically identical with different values of + !! spv_ref, but this reduces the effects of roundoff. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(inout) :: dza !< The change in the geopotential anomaly across + !! the layer [L2 T-2 ~> m2 s-2]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of + !! the geopotential anomaly relative to the anomaly + !! at the bottom of the layer [R L4 T-4 ~> Pa m2 s-2] + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(inout) :: intx_dza !< The integral in x of the difference between the + !! geopotential anomaly at the top and bottom of + !! the layer divided by the x grid spacing + !! [L2 T-2 ~> m2 s-2]. + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(inout) :: inty_dza !< The integral in y of the difference between the + !! geopotential anomaly at the top and bottom of + !! the layer divided by the y grid spacing + !! [L2 T-2 ~> m2 s-2]. + integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate + !! dza. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] + real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with + !! the same units as p_t [R L2 T-2 ~> Pa] + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals + real, optional, intent(in) :: SV_scale !< A multiplicative factor by which to scale specific + !! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [Pa T2 R-1 L-2 ~> 1]. + real, optional, intent(in) :: temp_scale !< A multiplicative factor by which to scale + !! temperature into degC [degC C-1 ~> 1] + real, optional, intent(in) :: saln_scale !< A multiplicative factor to convert pressure + !! into PSU [PSU S-1 ~> 1]. + + ! Local variables + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d ! A term in the Wright EOS [R-1 ~> m3 kg-1] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: p0_2d ! A term in the Wright EOS [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: lambda_2d ! A term in the Wright EOS [L2 T-2 ~> m2 s-2] + real :: al0 ! A term in the Wright EOS [R-1 ~> m3 kg-1] + real :: p0 ! A term in the Wright EOS [R L2 T-2 ~> Pa] + real :: lambda ! A term in the Wright EOS [L2 T-2 ~> m2 s-2] + real :: al0_scale ! Scaling factor to convert al0 from MKS units [kg m-3 R-1 ~> 1] + real :: p0_scale ! Scaling factor to convert p0 from MKS units [R L2 T-2 Pa-1 ~> 1] + real :: lam_scale ! Scaling factor to convert lambda from MKS units [L2 s2 T-2 m-2 ~> 1] + real :: p_ave ! The layer average pressure [R L2 T-2 ~> Pa] + real :: rem ! [L2 T-2 ~> m2 s-2] + real :: eps, eps2 ! A nondimensional ratio and its square [nondim] + real :: alpha_anom ! The depth averaged specific volume anomaly [R-1 ~> m3 kg-1]. + real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa]. + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa]. + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> Pa-2]. + real :: I_pterm ! The inverse of p0 plus p_ave [T2 R-1 L-2 ~> Pa-1]. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim]. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim]. + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. + real :: intp(5) ! The integrals of specific volume with pressure at the + ! 5 sub-column locations [L2 T-2 ~> m2 s-2]. + real :: a1s ! Partly rescaled version of a1 [m3 kg-1 C-1 ~> m3 kg-1 degC-1] + real :: a2s ! Partly rescaled version of a2 [m3 kg-1 S-1 ~> m3 kg-1 PSU-1] + real :: b1s ! Partly rescaled version of b1 [Pa C-1 ~> Pa degC-1] + real :: b2s ! Partly rescaled version of b2 [Pa C-2 ~> Pa degC-2] + real :: b3s ! Partly rescaled version of b3 [Pa C-3 ~> Pa degC-3] + real :: b4s ! Partly rescaled version of b4 [Pa S-1 ~> Pa PSU-1] + real :: b5s ! Partly rescaled version of b5 [Pa C-1 S-1 ~> Pa degC-1 PSU-1] + real :: c1s ! Partly rescaled version of c1 [m2 s-2 C-1 ~> m2 s-2 degC-1] + real :: c2s ! Partly rescaled version of c2 [m2 s-2 C-2 ~> m2 s-2 degC-2] + real :: c3s ! Partly rescaled version of c3 [m2 s-2 C-3 ~> m2 s-2 degC-3] + real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] + real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] + logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface + logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] + real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] + integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, halo + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + halo = 0 ; if (present(halo_size)) halo = MAX(halo_size,0) + ish = HI%isc-halo ; ieh = HI%iec+halo ; jsh = HI%jsc-halo ; jeh = HI%jec+halo + if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh) ; endif + if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh) ; endif + + + al0_scale = 1.0 ; if (present(SV_scale)) al0_scale = SV_scale + p0_scale = 1.0 + if (present(pres_scale)) then ; if (pres_scale /= 1.0) then + p0_scale = 1.0 / pres_scale + endif ; endif + lam_scale = al0_scale * p0_scale + + a1s = a1 ; a2s = a2 + b1s = b1 ; b2s = b2 ; b3s = b3 ; b4s = b4 ; b5s = b5 + c1s = c1 ; c2s = c2 ; c3s = c3 ; c4s = c4 ; c5s = c5 + + if (present(temp_scale)) then ; if (temp_scale /= 1.0) then + a1s = a1s * temp_scale + b1s = b1s * temp_scale ; b2s = b2s * temp_scale**2 + b3s = b3s * temp_scale**3 ; b5s = b5s * temp_scale + c1s = c1s * temp_scale ; c2s = c2s * temp_scale**2 + c3s = c3s * temp_scale**3 ; c5s = c5s * temp_scale + endif ; endif + + if (present(saln_scale)) then ; if (saln_scale /= 1.0) then + a2s = a2s * saln_scale + b4s = b4s * saln_scale ; b5s = b5s * saln_scale + c4s = c4s * saln_scale ; c5s = c5s * saln_scale + endif ; endif + + do_massWeight = .false. ; massWeight_bug = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set + endif + + ! alpha = (lambda + al0*(pressure + p0)) / (pressure + p0) + do j=jsh,jeh ; do i=ish,ieh + al0_2d(i,j) = al0_scale * ( a0 + (a1s*T(i,j) + a2s*S(i,j)) ) + p0_2d(i,j) = p0_scale * ( b0 + ( b4s*S(i,j) + T(i,j) * (b1s + (T(i,j)*(b2s + b3s*T(i,j)) + b5s*S(i,j))) ) ) + lambda_2d(i,j) = lam_scale * ( c0 + ( c4s*S(i,j) + T(i,j) * (c1s + (T(i,j)*(c2s + c3s*T(i,j)) + c5s*S(i,j))) ) ) + + al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) + dp = p_b(i,j) - p_t(i,j) + p_ave = 0.5*(p_t(i,j)+p_b(i,j)) + I_pterm = 1.0 / (p0 + p_ave) + + eps = 0.5 * dp * I_pterm ; eps2 = eps*eps + alpha_anom = (al0 - spv_ref) + lambda * I_pterm + rem = (lambda * eps2) * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + dza(i,j) = alpha_anom*dp + 2.0*eps*rem + if (present(intp_dza)) & + intp_dza(i,j) = 0.5*alpha_anom*dp**2 - dp*((1.0-eps)*rem) + enddo ; enddo + + if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight .and. massWeight_bug) then + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i+1,j), P_surf(i+1,j)-p_b(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR) + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + al0 = (wtT_L*al0_2d(i,j)) + (wtT_R*al0_2d(i+1,j)) + p0 = (wtT_L*p0_2d(i,j)) + (wtT_R*p0_2d(i+1,j)) + lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j)) + + dp = (wt_L*(p_b(i,j) - p_t(i,j))) + (wt_R*(p_b(i+1,j) - p_t(i+1,j))) + p_ave = 0.5*((wt_L*(p_t(i,j)+p_b(i,j))) + (wt_R*(p_t(i+1,j)+p_b(i+1,j)))) + I_pterm = 1.0 / (p0 + p_ave) + + eps = 0.5 * dp * I_pterm ; eps2 = eps*eps + intp(m) = ((al0 - spv_ref) + lambda * I_pterm)*dp + 2.0*eps* & + lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + enddo + ! Use Boole's rule to integrate the values. + intx_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + enddo ; enddo ; endif + + if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight .and. massWeight_bug) then + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i,j+1), P_surf(i,j+1)-p_b(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR) + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + al0 = (wt_L*al0_2d(i,j)) + (wt_R*al0_2d(i,j+1)) + p0 = (wt_L*p0_2d(i,j)) + (wt_R*p0_2d(i,j+1)) + lambda = (wt_L*lambda_2d(i,j)) + (wt_R*lambda_2d(i,j+1)) + + dp = (wt_L*(p_b(i,j) - p_t(i,j))) + (wt_R*(p_b(i,j+1) - p_t(i,j+1))) + p_ave = 0.5*((wt_L*(p_t(i,j)+p_b(i,j))) + (wt_R*(p_t(i,j+1)+p_b(i,j+1)))) + I_pterm = 1.0 / (p0 + p_ave) + + eps = 0.5 * dp * I_pterm ; eps2 = eps*eps + intp(m) = ((al0 - spv_ref) + lambda * I_pterm)*dp + 2.0*eps* & + lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + enddo + ! Use Boole's rule to integrate the values. + inty_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + enddo ; enddo ; endif +end subroutine int_spec_vol_dp_wright_full + +!> Calculate the in-situ density for 1D arraya inputs and outputs. +subroutine calculate_density_array_Wright_full(this, T, S, pressure, rho, start, npts, rho_ref) + class(Wright_full_EOS), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: rho !< In situ density [kg m-3] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + + ! Local variables + integer :: j + + if (present(rho_ref)) then + do j = start, start+npts-1 + rho(j) = density_anomaly_elem_Wright_full(this, T(j), S(j), pressure(j), rho_ref) + enddo + else + do j = start, start+npts-1 + rho(j) = density_elem_Wright_full(this, T(j), S(j), pressure(j)) + enddo + endif + +end subroutine calculate_density_array_Wright_full + +!> Calculate the in-situ specific volume for 1D array inputs and outputs. +subroutine calculate_spec_vol_array_Wright_full(this, T, S, pressure, specvol, start, npts, spv_ref) + class(Wright_full_EOS), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: specvol !< In situ specific volume [m3 kg-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + ! Local variables + integer :: j + + if (present(spv_ref)) then + do j = start, start+npts-1 + specvol(j) = spec_vol_anomaly_elem_Wright_full(this, T(j), S(j), pressure(j), spv_ref) + enddo + else + do j = start, start+npts-1 + specvol(j) = spec_vol_elem_Wright_full(this, T(j), S(j), pressure(j) ) + enddo + endif + +end subroutine calculate_spec_vol_array_Wright_full + + +!> \namespace mom_eos_wright_full +!! +!! \section section_EOS_Wright_full Wright equation of state +!! +!! Wright, 1997, provide an approximation for the in situ density as a function of +!! potential temperature, salinity, and pressure. The formula follow the Tumlirz +!! equation of state which are easier to evaluate and make efficient. +!! +!! Two ranges are provided by Wright: a "full" range and "reduced" range. The version in this +!! module uses the full range. +!! +!! Originally coded in 2000 by R. Hallberg. +!! Anomaly form coded in 3/18. +!! +!! \subsection section_EOS_Wright_full_references References +!! +!! Wright, D., 1997: An Equation of State for Use in Ocean Models: Eckart's Formula Revisited. +!! J. Ocean. Atmosph. Tech., 14 (3), 735-740. +!! https://journals.ametsoc.org/doi/abs/10.1175/1520-0426%281997%29014%3C0735%3AAEOSFU%3E2.0.CO%3B2 + +end module MOM_EOS_Wright_full diff --git a/src/equation_of_state/MOM_EOS_Wright_red.F90 b/src/equation_of_state/MOM_EOS_Wright_red.F90 new file mode 100644 index 0000000000..af7f1dc936 --- /dev/null +++ b/src/equation_of_state/MOM_EOS_Wright_red.F90 @@ -0,0 +1,994 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> The equation of state using the Wright 1997 expressions with reduced range of data. +module MOM_EOS_Wright_red + +use MOM_EOS_base_type, only : EOS_base +use MOM_hor_index, only : hor_index_type + +implicit none ; private + +public Wright_red_EOS +public int_density_dz_wright_red, int_spec_vol_dp_wright_red +public avg_spec_vol_Wright_red + +!>@{ Parameters in the Wright equation of state using the reduced range formula, which is a fit to the UNESCO +! equation of state for the restricted range: -2 < theta < 30 [degC], 28 < S < 38 [PSU], 0 < p < 5e7 [Pa]. + + ! Note that a0/a1 ~= 2028 [degC] ; a0/a2 ~= -6343 [PSU] + ! b0/b1 ~= 165 [degC] ; b0/b4 ~= 974 [PSU] + ! c0/c1 ~= 216 [degC] ; c0/c4 ~= -740 [PSU] +real, parameter :: a0 = 7.057924e-4 ! A parameter in the Wright alpha_0 fit [m3 kg-1] +real, parameter :: a1 = 3.480336e-7 ! A parameter in the Wright alpha_0 fit [m3 kg-1 degC-1] +real, parameter :: a2 = -1.112733e-7 ! A parameter in the Wright alpha_0 fit [m3 kg-1 PSU-1] +real, parameter :: b0 = 5.790749e8 ! A parameter in the Wright p_0 fit [Pa] +real, parameter :: b1 = 3.516535e6 ! A parameter in the Wright p_0 fit [Pa degC-1] +real, parameter :: b2 = -4.002714e4 ! A parameter in the Wright p_0 fit [Pa degC-2] +real, parameter :: b3 = 2.084372e2 ! A parameter in the Wright p_0 fit [Pa degC-3] +real, parameter :: b4 = 5.944068e5 ! A parameter in the Wright p_0 fit [Pa PSU-1] +real, parameter :: b5 = -9.643486e3 ! A parameter in the Wright p_0 fit [Pa degC-1 PSU-1] +real, parameter :: c0 = 1.704853e5 ! A parameter in the Wright lambda fit [m2 s-2] +real, parameter :: c1 = 7.904722e2 ! A parameter in the Wright lambda fit [m2 s-2 degC-1] +real, parameter :: c2 = -7.984422 ! A parameter in the Wright lambda fit [m2 s-2 degC-2] +real, parameter :: c3 = 5.140652e-2 ! A parameter in the Wright lambda fit [m2 s-2 degC-3] +real, parameter :: c4 = -2.302158e2 ! A parameter in the Wright lambda fit [m2 s-2 PSU-1] +real, parameter :: c5 = -3.079464 ! A parameter in the Wright lambda fit [m2 s-2 degC-1 PSU-1] +!>@} + +!> The EOS_base implementation of the reduced range Wright 1997 equation of state +type, extends (EOS_base) :: Wright_red_EOS + +contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_Wright_red + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_Wright_red + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_Wright_red + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_Wright_red + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_Wright_red + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_Wright_red + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_Wright_red + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_Wright_red + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_Wright_red + + !> Local implementation of generic calculate_density_array for efficiency + procedure :: calculate_density_array => calculate_density_array_Wright_red + !> Local implementation of generic calculate_spec_vol_array for efficiency + procedure :: calculate_spec_vol_array => calculate_spec_vol_array_Wright_red + +end type Wright_red_EOS + +contains + +!> In situ density of sea water using a reduced range fit by Wright, 1997 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_elem_Wright_red(this, T, S, pressure) + class(Wright_red_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< potential temperature relative to the surface [degC]. + real, intent(in) :: S !< salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + + al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + density_elem_Wright_red = (pressure + p0) / (lambda + al0*(pressure + p0)) + +end function density_elem_Wright_red + +!> In situ density anomaly of sea water using a reduced range fit by Wright, 1997 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_anomaly_elem_Wright_red(this, T, S, pressure, rho_ref) + class(Wright_red_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< potential temperature relative to the surface [degC]. + real, intent(in) :: S !< salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(in) :: rho_ref !< A reference density [kg m-3]. + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: al_TS ! The contributions of temperature and salinity to al0 [m3 kg-1] + real :: p_TSp ! A combination of the pressure and the temperature and salinity contributions to p0 [Pa] + real :: lam_TS ! The contributions of temperature and salinity to lambda [m2 s-2] + real :: pa_000 ! A corrected offset to the pressure, including contributions from rho_ref [Pa] + + pa_000 = b0*(1.0 - a0*rho_ref) - rho_ref*c0 + al_TS = a1*T + a2*S + al0 = a0 + al_TS + p_TSp = pressure + (b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S))) + lam_TS = c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) + + ! The following two expressions are mathematically equivalent. + ! rho = (b0 + p0_TSp) / ((c0 + lam_TS) + al0*(b0 + p0_TSp)) - rho_ref + density_anomaly_elem_Wright_red = & + (pa_000 + (p_TSp - rho_ref*(p_TSp*al0 + (b0*al_TS + lam_TS)))) / & + ( (c0 + lam_TS) + al0*(b0 + p_TSp) ) + +end function density_anomaly_elem_Wright_red + +!> In situ specific volume of sea water using a reduced range fit by Wright, 1997 [m3 kg-1] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_elem_Wright_red(this, T, S, pressure) + class(Wright_red_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< potential temperature relative to the surface [degC] + real, intent(in) :: S !< salinity [PSU] + real, intent(in) :: pressure !< pressure [Pa] + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2], perhaps with + ! an offset to account for spv_ref + real :: al_TS ! The contributions of temperature and salinity to al0 [m3 kg-1] + real :: p_TSp ! A combination of the pressure and the temperature and salinity contributions to p0 [Pa] + real :: lam_000 ! A corrected offset to lambda, including contributions from spv_ref [m2 s-2] + + al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + spec_vol_elem_Wright_red = al0 + lambda / (pressure + p0) + +end function spec_vol_elem_Wright_red + +!> In situ specific volume anomaly of sea water using a reduced range fit by Wright, 1997 [m3 kg-1] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_anomaly_elem_Wright_red(this, T, S, pressure, spv_ref) + class(Wright_red_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< potential temperature relative to the surface [degC] + real, intent(in) :: S !< salinity [PSU] + real, intent(in) :: pressure !< pressure [Pa] + real, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2], perhaps with + ! an offset to account for spv_ref + real :: al_TS ! The contributions of temperature and salinity to al0 [m3 kg-1] + real :: p_TSp ! A combination of the pressure and the temperature and salinity contributions to p0 [Pa] + real :: lam_000 ! A corrected offset to lambda, including contributions from spv_ref [m2 s-2] + + lam_000 = c0 + (a0 - spv_ref)*b0 + al_TS = a1*T + a2*S + p_TSp = pressure + (b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S))) + lambda = lam_000 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + ! This is equivalent to the expression below minus spv_ref, but less sensitive to roundoff. + spec_vol_anomaly_elem_Wright_red = al_TS + (lambda + (a0 - spv_ref)*p_TSp) / (b0 + p_TSp) + +end function spec_vol_anomaly_elem_Wright_red + +!> Calculate the partial derivatives of density with potential temperature and salinity +!! using the reduced range equation of state, as fit by Wright, 1997 +elemental subroutine calculate_density_derivs_elem_Wright_red(this, T, S, pressure, drho_dT, drho_dS) + class(Wright_red_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1] + real, intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 PSU-1] + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: I_denom2 ! The inverse of the square of the denominator of density in the Wright EOS [s4 m-4] + + al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + + I_denom2 = 1.0 / (lambda + al0*(pressure + p0))**2 + drho_dT = I_denom2 * (lambda * (b1 + (T*(2.0*b2 + 3.0*b3*T) + b5*S)) - & + (pressure+p0) * ( (pressure+p0)*a1 + (c1 + (T*(c2*2.0 + c3*3.0*T) + c5*S)) )) + drho_dS = I_denom2 * (lambda * (b4 + b5*T) - & + (pressure+p0) * ( (pressure+p0)*a2 + (c4 + c5*T) )) + +end subroutine calculate_density_derivs_elem_Wright_red + +!> Second derivatives of density with respect to temperature, salinity, and pressure, +!! using the reduced range equation of state, as fit by Wright, 1997 +elemental subroutine calculate_density_second_derivs_elem_Wright_red(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + class(Wright_red_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature referenced to 0 dbar [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, intent(inout) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, intent(inout) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: p_p0 ! A local work variable combining the pressure and pressure + ! offset (p0 elsewhere) in the Wright EOS [Pa] + real :: dp0_dT ! The partial derivative of p0 with temperature [Pa degC-1] + real :: dp0_dS ! The partial derivative of p0 with salinity [Pa PSU-1] + real :: dlam_dT ! The partial derivative of lambda with temperature [m2 s-2 degC-1] + real :: dlam_dS ! The partial derivative of lambda with salinity [m2 s-2 degC-1] + real :: dRdT_num ! The numerator in the expression for drho_dT [Pa m2 s-2 degC-1] = [kg m s-4 degC-1] + real :: dRdS_num ! The numerator in the expression for drho_ds [Pa m2 s-2 PSU-1] = [kg m s-4 PSU-1] + real :: ddenom_dT ! The derivative of the denominator of density in the Wright EOS with temperature [m2 s-2 deg-1] + real :: ddenom_dS ! The derivative of the denominator of density in the Wright EOS with salinity [m2 s-2 PSU-1] + real :: I_denom ! The inverse of the denominator of density in the Wright EOS [s2 m-2] + real :: I_denom2 ! The inverse of the square of the denominator of density in the Wright EOS [s4 m-4] + real :: I_denom3 ! The inverse of the cube of the denominator of density in the Wright EOS [s6 m-6] + + al0 = a0 + (a1*T + a2*S) + p_p0 = pressure + ( b0 + (b4*S + T*(b1 + (b5*S + T*(b2 + b3*T)))) ) ! P + p0 + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + dp0_dT = b1 + (b5*S + T*(2.*b2 + 3.*b3*T)) + dp0_dS = b4 + b5*T + dlam_dT = c1 + (c5*S + T*(2.*c2 + 3.*c3*T)) + dlam_dS = c4 + c5*T + I_denom = 1.0 / (lambda + al0*p_p0) + I_denom2 = I_denom*I_denom + I_denom3 = I_denom*I_denom2 + + ddenom_dS = (dlam_dS + a2*p_p0) + al0*dp0_dS + ddenom_dT = (dlam_dT + a1*p_p0) + al0*dp0_dT + dRdS_num = dp0_dS*lambda - p_p0*(dlam_dS + a2*p_p0) + dRdT_num = dp0_dT*lambda - p_p0*(dlam_dT + a1*p_p0) + + ! In deriving the following, it is useful to note that: + ! rho = p_p0 / (lambda + al0*p_p0) + ! drho_dp = lambda * I_denom2 + ! drho_dT = (dp0_dT*lambda - p_p0*(dlam_dT + a1*p_p0)) * I_denom2 = dRdT_num * I_denom2 + ! drho_dS = (dp0_dS*lambda - p_p0*(dlam_dS + a2*p_p0)) * I_denom2 = dRdS_num * I_denom2 + drho_ds_ds = -2.*(p_p0*(a2*dp0_dS)) * I_denom2 - 2.*(dRdS_num*ddenom_dS) * I_denom3 + drho_ds_dt = ((b5*lambda - p_p0*(c5 + 2.*a2*dp0_dT)) + (dp0_dS*dlam_dT - dp0_dT*dlam_dS))*I_denom2 - & + 2.*(ddenom_dT*dRdS_num) * I_denom3 + drho_dt_dt = 2.*((b2 + 3.*b3*T)*lambda - p_p0*((c2 + 3.*c3*T) + a1*dp0_dT))*I_denom2 - & + 2.*(dRdT_num * ddenom_dT) * I_denom3 + + ! The following is a rearranged form that is equivalent to + ! drho_ds_dp = dlam_dS * I_denom2 - 2.0 * lambda * (dlam_dS + a2*p_p0 + al0*dp0_ds) * Idenom3 + drho_ds_dp = (-dlam_dS - 2.*a2*p_p0) * I_denom2 - (2.*al0*dRdS_num) * I_denom3 + drho_dt_dp = (-dlam_dT - 2.*a1*p_p0) * I_denom2 - (2.*al0*dRdT_num) * I_denom3 + +end subroutine calculate_density_second_derivs_elem_Wright_red + +!> Calculate the partial derivatives of specific volume with temperature and salinity +!! using the reduced range equation of state, as fit by Wright, 1997 +elemental subroutine calculate_specvol_derivs_elem_Wright_red(this, T, S, pressure, dSV_dT, dSV_dS) + class(Wright_red_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1] + + ! Local variables + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: I_denom ! The inverse of the denominator of specific volume in the Wright EOS [Pa-1] + + !al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + + ! SV = al0 + lambda / (pressure + p0) + + I_denom = 1.0 / (pressure + p0) + dSV_dT = a1 + I_denom * ((c1 + (T*(2.0*c2 + 3.0*c3*T) + c5*S)) - & + (I_denom * lambda) * (b1 + (T*(2.0*b2 + 3.0*b3*T) + b5*S))) + dSV_dS = a2 + I_denom * ((c4 + c5*T) - & + (I_denom * lambda) * (b4 + b5*T)) + +end subroutine calculate_specvol_derivs_elem_Wright_red + +!> Compute the in situ density of sea water (rho) and the compressibility (drho/dp == C_sound^-2) +!! at the given salinity, potential temperature and pressure +!! using the reduced range equation of state, as fit by Wright, 1997 +elemental subroutine calculate_compress_elem_Wright_red(this, T, S, pressure, rho, drho_dp) + class(Wright_red_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: rho !< In situ density [kg m-3] + real, intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [s2 m-2]. + + ! Local variables + real :: al0 ! The specific volume at 0 lambda in the Wright EOS [m3 kg-1] + real :: p0 ! The pressure offset in the Wright EOS [Pa] + real :: lambda ! The sound speed squared at 0 alpha in the Wright EOS [m2 s-2] + real :: I_denom ! The inverse of the denominator of density in the Wright EOS [s2 m-2] + + al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + + I_denom = 1.0 / (lambda + al0*(pressure + p0)) + rho = (pressure + p0) * I_denom + drho_dp = lambda * I_denom**2 + +end subroutine calculate_compress_elem_Wright_red + +!> Calculates analytical and nearly-analytical integrals, in pressure across layers, to determine +!! the layer-average specific volumes. There are essentially no free assumptions, apart from a +!! truncation in the series for log(1-eps/1+eps) that assumes that |eps| < 0.34. +subroutine avg_spec_vol_Wright_red(T, S, p_t, dp, SpV_avg, start, npts) + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface + !! [degC]. + real, dimension(:), intent(in) :: S !< Salinity [PSU]. + real, dimension(:), intent(in) :: p_t !< Pressure at the top of the layer [Pa] + real, dimension(:), intent(in) :: dp !< Pressure change in the layer [Pa] + real, dimension(:), intent(inout) :: SpV_avg !< The vertical average specific volume + !! in the layer [m3 kg-1] + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + + ! Local variables + real :: al0 ! A term in the Wright EOS [m3 kg-1] + real :: p0 ! A term in the Wright EOS [Pa] + real :: lambda ! A term in the Wright EOS [m2 s-2] + real :: eps2 ! The square of a nondimensional ratio [nondim] + real :: I_pterm ! The inverse of p0 plus p_ave [Pa-1]. + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0, C1_9 = 1.0/9.0 ! Rational constants [nondim] + integer :: j + + ! alpha(j) = al0 + lambda / (pressure(j) + p0) + do j=start,start+npts-1 + al0 = a0 + (a1*T(j) + a2*S(j)) + p0 = b0 + ( b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j))) ) + lambda = c0 + ( c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) ) + + I_pterm = 1.0 / (p0 + (p_t(j) + 0.5*dp(j))) + eps2 = (0.5 * dp(j) * I_pterm)**2 + SpV_avg(j) = al0 + (lambda * I_pterm) * & + (1.0 + eps2*(C1_3 + eps2*(0.2 + eps2*(C1_7 + eps2*C1_9)))) + enddo +end subroutine avg_spec_vol_Wright_red + +!> Return the range of temperatures, salinities and pressures for which the reduced-range equation +!! of state from Wright (1997) has been fitted to observations. Care should be taken when applying +!! this equation of state outside of its fit range. +subroutine EoS_fit_range_Wright_red(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(Wright_red_EOS), intent(in) :: this !< This EOS + real, optional, intent(out) :: T_min !< The minimum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: S_max !< The maximum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + if (present(T_min)) T_min = -2.0 + if (present(T_max)) T_max = 30.0 + if (present(S_min)) S_min = 28.0 + if (present(S_max)) S_max = 38.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 5.0e7 + +end subroutine EoS_fit_range_Wright_red + +!> Calculates analytical and nearly-analytical integrals, in geopotential across layers, of pressure +!! anomalies, which are required for calculating the finite-volume form pressure accelerations in a +!! Boussinesq model. There are essentially no free assumptions, apart from the use of Boole's rule +!! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) +!! that assumes that |eps| < 0.34. +subroutine int_density_dz_wright_red(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + dpa, intz_dpa, intx_dpa, inty_dpa, bathyT, SSH, dz_neglect, & + MassWghtInterp, rho_scale, pres_scale, temp_scale, saln_scale, Z_0p) + type(hor_index_type), intent(in) :: HI !< The horizontal index type for the arrays. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T !< Potential temperature relative to the surface + !! [C ~> degC]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S !< Salinity [S ~> PSU]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: z_b !< Height at the top of the layer [Z ~> m]. + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that is subtracted + !! out to reduce the magnitude of each of the integrals. + !! (The pressure is calculated as p~=-z*rho_0*G_e.) + real, intent(in) :: rho_0 !< Density [R ~> kg m-3], that is used + !! to calculate the pressure (as p~=-z*rho_0*G_e) + !! used in the equation of state. + real, intent(in) :: G_e !< The Earth's gravitational acceleration + !! [L2 Z-1 T-2 ~> m s-2]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(inout) :: dpa !< The change in the pressure anomaly across the + !! layer [R L2 T-2 ~> Pa]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(inout) :: intz_dpa !< The integral through the thickness of the layer + !! of the pressure anomaly relative to the anomaly + !! at the top of the layer [R Z L2 T-2 ~> Pa m]. + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(inout) :: intx_dpa !< The integral in x of the difference between the + !! pressure anomaly at the top and bottom of the + !! layer divided by the x grid spacing [R L2 T-2 ~> Pa]. + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(inout) :: inty_dpa !< The integral in y of the difference between the + !! pressure anomaly at the top and bottom of the + !! layer divided by the y grid spacing [R L2 T-2 ~> Pa]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: SSH !< The sea surface height [Z ~> m] + real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals + real, optional, intent(in) :: rho_scale !< A multiplicative factor by which to scale density + !! from kg m-3 to the desired units [R m3 kg-1 ~> 1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [Pa T2 R-1 L-2 ~> 1]. + real, optional, intent(in) :: temp_scale !< A multiplicative factor by which to scale + !! temperature into degC [degC C-1 ~> 1] + real, optional, intent(in) :: saln_scale !< A multiplicative factor to convert pressure + !! into PSU [PSU S-1 ~> 1]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] + + ! Local variables + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d ! A term in the Wright EOS [m3 kg-1] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: p0_2d ! A term in the Wright EOS [Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: lambda_2d ! A term in the Wright EOS [m2 s-2] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: z0pres ! The height at which the pressure is zero [Z ~> m] + real :: al0 ! A term in the Wright EOS [m3 kg-1] + real :: p0 ! A term in the Wright EOS [Pa] + real :: lambda ! A term in the Wright EOS [m2 s-2] + real :: rho_anom ! The density anomaly from rho_ref [kg m-3]. + real :: eps, eps2 ! A nondimensional ratio and its square [nondim] + real :: rem ! [kg m-1 s-2] + real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] + real :: g_Earth ! The gravitational acceleration [m2 Z-1 s-2 ~> m s-2] + real :: I_Rho ! The inverse of the Boussinesq density [m3 kg-1] + real :: rho_ref_mks ! The reference density in MKS units [kg m-3] + real :: p_ave ! The layer averaged pressure [Pa] + real :: I_al0 ! The inverse of al0 [kg m-3] + real :: I_Lzz ! The inverse of the denominator [Pa-1] + real :: dz ! The layer thickness [Z ~> m]. + real :: hWght ! A pressure-thickness below topography [Z ~> m]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m]. + real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> m-2]. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim]. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim]. + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. + real :: intz(5) ! The gravitational acceleration times the integrals of density + ! with height at the 5 sub-column locations [R L2 T-2 ~> Pa]. + real :: Pa_to_RL2_T2 ! A conversion factor of pressures from Pa to the output units indicated by + ! pres_scale [R L2 T-2 Pa-1 ~> 1]. + real :: a1s ! Partly rescaled version of a1 [m3 kg-1 C-1 ~> m3 kg-1 degC-1] + real :: a2s ! Partly rescaled version of a2 [m3 kg-1 S-1 ~> m3 kg-1 PSU-1] + real :: b1s ! Partly rescaled version of b1 [Pa C-1 ~> Pa degC-1] + real :: b2s ! Partly rescaled version of b2 [Pa C-2 ~> Pa degC-2] + real :: b3s ! Partly rescaled version of b3 [Pa C-3 ~> Pa degC-3] + real :: b4s ! Partly rescaled version of b4 [Pa S-1 ~> Pa PSU-1] + real :: b5s ! Partly rescaled version of b5 [Pa C-1 S-1 ~> Pa degC-1 PSU-1] + real :: c1s ! Partly rescaled version of c1 [m2 s-2 C-1 ~> m2 s-2 degC-1] + real :: c2s ! Partly rescaled version of c2 [m2 s-2 C-2 ~> m2 s-2 degC-2] + real :: c3s ! Partly rescaled version of c3 [m2 s-2 C-3 ~> m2 s-2 degC-3] + real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] + real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] + logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] + real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m + + ! These array bounds work for the indexing convention of the input arrays, but + ! on the computational domain defined for the output arrays. + Isq = HI%IscB ; Ieq = HI%IecB + Jsq = HI%JscB ; Jeq = HI%JecB + is = HI%isc ; ie = HI%iec + js = HI%jsc ; je = HI%jec + + if (present(pres_scale)) then + GxRho = pres_scale * G_e * rho_0 ; g_Earth = pres_scale * G_e + Pa_to_RL2_T2 = 1.0 / pres_scale + else + GxRho = G_e * rho_0 ; g_Earth = G_e + Pa_to_RL2_T2 = 1.0 + endif + if (present(rho_scale)) then + g_Earth = g_Earth * rho_scale + rho_ref_mks = rho_ref / rho_scale ; I_Rho = rho_scale / rho_0 + else + rho_ref_mks = rho_ref ; I_Rho = 1.0 / rho_0 + endif + if (present(Z_0p)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + z0pres(i,j) = Z_0p(i,j) + enddo ; enddo + else + z0pres(:,:) = 0.0 + endif + + a1s = a1 ; a2s = a2 + b1s = b1 ; b2s = b2 ; b3s = b3 ; b4s = b4 ; b5s = b5 + c1s = c1 ; c2s = c2 ; c3s = c3 ; c4s = c4 ; c5s = c5 + + if (present(temp_scale)) then ; if (temp_scale /= 1.0) then + a1s = a1s * temp_scale + b1s = b1s * temp_scale ; b2s = b2s * temp_scale**2 + b3s = b3s * temp_scale**3 ; b5s = b5s * temp_scale + c1s = c1s * temp_scale ; c2s = c2s * temp_scale**2 + c3s = c3s * temp_scale**3 ; c5s = c5s * temp_scale + endif ; endif + + if (present(saln_scale)) then ; if (saln_scale /= 1.0) then + a2s = a2s * saln_scale + b4s = b4s * saln_scale ; b5s = b5s * saln_scale + c4s = c4s * saln_scale ; c5s = c5s * saln_scale + endif ; endif + + do_massWeight = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + endif + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + al0_2d(i,j) = a0 + (a1s*T(i,j) + a2s*S(i,j)) + p0_2d(i,j) = b0 + ( b4s*S(i,j) + T(i,j) * (b1s + (T(i,j)*(b2s + b3s*T(i,j)) + b5s*S(i,j))) ) + lambda_2d(i,j) = c0 + ( c4s*S(i,j) + T(i,j) * (c1s + (T(i,j)*(c2s + c3s*T(i,j)) + c5s*S(i,j))) ) + + al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) + + dz = z_t(i,j) - z_b(i,j) + p_ave = -GxRho*(0.5*(z_t(i,j)+z_b(i,j)) - z0pres(i,j)) + + I_al0 = 1.0 / al0 + I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) + eps = 0.5*(GxRho*dz)*I_Lzz ; eps2 = eps*eps + +! rho(j) = (pressure(j) + p0) / (lambda + al0*(pressure(j) + p0)) + + rho_anom = (p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks + rem = (I_Rho * (lambda * I_al0**2)) * (eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2)))) + dpa(i,j) = Pa_to_RL2_T2 * ((g_Earth*rho_anom)*dz - 2.0*eps*rem) + if (present(intz_dpa)) & + intz_dpa(i,j) = Pa_to_RL2_T2 * (0.5*(g_Earth*rho_anom)*dz**2 - dz*((1.0+eps)*rem)) + enddo ; enddo + + if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i+1,j)-SSH(i,j), z_b(i,j)-SSH(i+1,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR) + + al0 = (wtT_L*al0_2d(i,j)) + (wtT_R*al0_2d(i+1,j)) + p0 = (wtT_L*p0_2d(i,j)) + (wtT_R*p0_2d(i+1,j)) + lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j)) + + dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j))) + p_ave = -GxRho*((wt_L * (0.5*(z_t(i,j)+z_b(i,j)) - z0pres(i,j))) + & + (wt_R * (0.5*(z_t(i+1,j)+z_b(i+1,j)) - z0pres(i+1,j)))) + + I_al0 = 1.0 / al0 + I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) + eps = 0.5*(GxRho*dz)*I_Lzz ; eps2 = eps*eps + + intz(m) = Pa_to_RL2_T2 * ( (g_Earth*dz) * ((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks) - 2.0*eps * & + (I_Rho * (lambda * I_al0**2)) * (eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2)))) ) + enddo + ! Use Boole's rule to integrate the values. + intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) + enddo ; enddo ; endif + + if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=is,ie + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i,j+1)-SSH(i,j), z_b(i,j)-SSH(i,j+1)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR) + + al0 = (wtT_L*al0_2d(i,j)) + (wtT_R*al0_2d(i,j+1)) + p0 = (wtT_L*p0_2d(i,j)) + (wtT_R*p0_2d(i,j+1)) + lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i,j+1)) + + dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1))) + p_ave = -GxRho*((wt_L*(0.5*(z_t(i,j)+z_b(i,j))-z0pres(i,j))) + & + (wt_R*(0.5*(z_t(i,j+1)+z_b(i,j+1))-z0pres(i,j+1)))) + + I_al0 = 1.0 / al0 + I_Lzz = 1.0 / ((p0 + p_ave) + lambda * I_al0) + eps = 0.5*(GxRho*dz)*I_Lzz ; eps2 = eps*eps + + intz(m) = Pa_to_RL2_T2 * ( (g_Earth*dz) * ((p0 + p_ave)*(I_Lzz*I_al0) - rho_ref_mks) - 2.0*eps * & + (I_Rho * (lambda * I_al0**2)) * (eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2)))) ) + enddo + ! Use Boole's rule to integrate the values. + inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) + enddo ; enddo ; endif + +end subroutine int_density_dz_wright_red + +!> Calculates analytical and nearly-analytical integrals, in pressure across layers, of geopotential +!! anomalies, which are required for calculating the finite-volume form pressure accelerations in a +!! non-Boussinesq model. There are essentially no free assumptions, apart from the use of Boole's +!! rule to do the horizontal integrals, and from a truncation in the series for log(1-eps/1+eps) +!! that assumes that |eps| < 0.34. +subroutine int_spec_vol_dp_wright_red(T, S, p_t, p_b, spv_ref, HI, dza, & + intp_dza, intx_dza, inty_dza, halo_size, bathyP, P_surf, dP_neglect, & + MassWghtInterp, SV_scale, pres_scale, temp_scale, saln_scale) + type(hor_index_type), intent(in) :: HI !< The ocean's horizontal index type. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T !< Potential temperature relative to the surface + !! [C ~> degC]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S !< Salinity [S ~> PSU]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_b !< Pressure at the top of the layer [R L2 T-2 ~> Pa] + real, intent(in) :: spv_ref !< A mean specific volume that is subtracted out + !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1]. + !! The calculation is mathematically identical with different values of + !! spv_ref, but this reduces the effects of roundoff. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(inout) :: dza !< The change in the geopotential anomaly across + !! the layer [L2 T-2 ~> m2 s-2]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(inout) :: intp_dza !< The integral in pressure through the layer of + !! the geopotential anomaly relative to the anomaly + !! at the bottom of the layer [R L4 T-4 ~> Pa m2 s-2] + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(inout) :: intx_dza !< The integral in x of the difference between the + !! geopotential anomaly at the top and bottom of + !! the layer divided by the x grid spacing + !! [L2 T-2 ~> m2 s-2]. + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(inout) :: inty_dza !< The integral in y of the difference between the + !! geopotential anomaly at the top and bottom of + !! the layer divided by the y grid spacing + !! [L2 T-2 ~> m2 s-2]. + integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate + !! dza. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] + real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with + !! the same units as p_t [R L2 T-2 ~> Pa] + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals + real, optional, intent(in) :: SV_scale !< A multiplicative factor by which to scale specific + !! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] + real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure + !! into Pa [Pa T2 R-1 L-2 ~> 1]. + real, optional, intent(in) :: temp_scale !< A multiplicative factor by which to scale + !! temperature into degC [degC C-1 ~> 1] + real, optional, intent(in) :: saln_scale !< A multiplicative factor to convert pressure + !! into PSU [PSU S-1 ~> 1]. + + ! Local variables + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d ! A term in the Wright EOS [R-1 ~> m3 kg-1] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: p0_2d ! A term in the Wright EOS [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: lambda_2d ! A term in the Wright EOS [L2 T-2 ~> m2 s-2] + real :: al0 ! A term in the Wright EOS [R-1 ~> m3 kg-1] + real :: p0 ! A term in the Wright EOS [R L2 T-2 ~> Pa] + real :: lambda ! A term in the Wright EOS [L2 T-2 ~> m2 s-2] + real :: al0_scale ! Scaling factor to convert al0 from MKS units [kg m-3 R-1 ~> 1] + real :: p0_scale ! Scaling factor to convert p0 from MKS units [R L2 T-2 Pa-1 ~> 1] + real :: lam_scale ! Scaling factor to convert lambda from MKS units [L2 s2 T-2 m-2 ~> 1] + real :: p_ave ! The layer average pressure [R L2 T-2 ~> Pa] + real :: rem ! [L2 T-2 ~> m2 s-2] + real :: eps, eps2 ! A nondimensional ratio and its square [nondim] + real :: alpha_anom ! The depth averaged specific volume anomaly [R-1 ~> m3 kg-1]. + real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa]. + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa]. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa]. + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> Pa-2]. + real :: I_pterm ! The inverse of p0 plus p_ave [T2 R-1 L-2 ~> Pa-1]. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim]. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim]. + real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. + real :: intp(5) ! The integrals of specific volume with pressure at the + ! 5 sub-column locations [L2 T-2 ~> m2 s-2]. + real :: a1s ! Partly rescaled version of a1 [m3 kg-1 C-1 ~> m3 kg-1 degC-1] + real :: a2s ! Partly rescaled version of a2 [m3 kg-1 S-1 ~> m3 kg-1 PSU-1] + real :: b1s ! Partly rescaled version of b1 [Pa C-1 ~> Pa degC-1] + real :: b2s ! Partly rescaled version of b2 [Pa C-2 ~> Pa degC-2] + real :: b3s ! Partly rescaled version of b3 [Pa C-3 ~> Pa degC-3] + real :: b4s ! Partly rescaled version of b4 [Pa S-1 ~> Pa PSU-1] + real :: b5s ! Partly rescaled version of b5 [Pa C-1 S-1 ~> Pa degC-1 PSU-1] + real :: c1s ! Partly rescaled version of c1 [m2 s-2 C-1 ~> m2 s-2 degC-1] + real :: c2s ! Partly rescaled version of c2 [m2 s-2 C-2 ~> m2 s-2 degC-2] + real :: c3s ! Partly rescaled version of c3 [m2 s-2 C-3 ~> m2 s-2 degC-3] + real :: c4s ! Partly rescaled version of c4 [m2 s-2 S-1 ~> m2 s-2 PSU-1] + real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 PSU-1] + logical :: do_massWeight ! Indicates whether to do mass weighting. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface + logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants [nondim] + real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants [nondim] + integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, halo + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + halo = 0 ; if (present(halo_size)) halo = MAX(halo_size,0) + ish = HI%isc-halo ; ieh = HI%iec+halo ; jsh = HI%jsc-halo ; jeh = HI%jec+halo + if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh) ; endif + if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh) ; endif + + + al0_scale = 1.0 ; if (present(SV_scale)) al0_scale = SV_scale + p0_scale = 1.0 + if (present(pres_scale)) then ; if (pres_scale /= 1.0) then + p0_scale = 1.0 / pres_scale + endif ; endif + lam_scale = al0_scale * p0_scale + + a1s = a1 ; a2s = a2 + b1s = b1 ; b2s = b2 ; b3s = b3 ; b4s = b4 ; b5s = b5 + c1s = c1 ; c2s = c2 ; c3s = c3 ; c4s = c4 ; c5s = c5 + + if (present(temp_scale)) then ; if (temp_scale /= 1.0) then + a1s = a1s * temp_scale + b1s = b1s * temp_scale ; b2s = b2s * temp_scale**2 + b3s = b3s * temp_scale**3 ; b5s = b5s * temp_scale + c1s = c1s * temp_scale ; c2s = c2s * temp_scale**2 + c3s = c3s * temp_scale**3 ; c5s = c5s * temp_scale + endif ; endif + + if (present(saln_scale)) then ; if (saln_scale /= 1.0) then + a2s = a2s * saln_scale + b4s = b4s * saln_scale ; b5s = b5s * saln_scale + c4s = c4s * saln_scale ; c5s = c5s * saln_scale + endif ; endif + + do_massWeight = .false. ; massWeight_bug = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set + endif + + ! alpha(j) = (lambda + al0*(pressure(j) + p0)) / (pressure(j) + p0) + do j=jsh,jeh ; do i=ish,ieh + al0_2d(i,j) = al0_scale * ( a0 + (a1s*T(i,j) + a2s*S(i,j)) ) + p0_2d(i,j) = p0_scale * ( b0 + ( b4s*S(i,j) + T(i,j) * (b1s + (T(i,j)*(b2s + b3s*T(i,j)) + b5s*S(i,j))) ) ) + lambda_2d(i,j) = lam_scale * ( c0 + ( c4s*S(i,j) + T(i,j) * (c1s + (T(i,j)*(c2s + c3s*T(i,j)) + c5s*S(i,j))) ) ) + + al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) + dp = p_b(i,j) - p_t(i,j) + p_ave = 0.5*(p_t(i,j)+p_b(i,j)) + I_pterm = 1.0 / (p0 + p_ave) + + eps = 0.5 * dp * I_pterm ; eps2 = eps*eps + alpha_anom = (al0 - spv_ref) + lambda * I_pterm + rem = (lambda * eps2) * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + dza(i,j) = alpha_anom*dp + 2.0*eps*rem + if (present(intp_dza)) & + intp_dza(i,j) = 0.5*alpha_anom*dp**2 - dp*((1.0-eps)*rem) + enddo ; enddo + + if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight .and. massWeight_bug) then + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i+1,j), P_surf(i+1,j)-p_b(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR) + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + al0 = (wtT_L*al0_2d(i,j)) + (wtT_R*al0_2d(i+1,j)) + p0 = (wtT_L*p0_2d(i,j)) + (wtT_R*p0_2d(i+1,j)) + lambda = (wtT_L*lambda_2d(i,j)) + (wtT_R*lambda_2d(i+1,j)) + + dp = (wt_L*(p_b(i,j) - p_t(i,j))) + (wt_R*(p_b(i+1,j) - p_t(i+1,j))) + p_ave = 0.5*((wt_L*(p_t(i,j)+p_b(i,j))) + (wt_R*(p_t(i+1,j)+p_b(i+1,j)))) + I_pterm = 1.0 / (p0 + p_ave) + + eps = 0.5 * dp * I_pterm ; eps2 = eps*eps + intp(m) = ((al0 - spv_ref) + lambda * I_pterm)*dp + 2.0*eps* & + lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + enddo + ! Use Boole's rule to integrate the values. + intx_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + enddo ; enddo ; endif + + if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight .and. massWeight_bug) then + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i,j+1), P_surf(i,j+1)-p_b(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR) + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + al0 = (wt_L*al0_2d(i,j)) + (wt_R*al0_2d(i,j+1)) + p0 = (wt_L*p0_2d(i,j)) + (wt_R*p0_2d(i,j+1)) + lambda = (wt_L*lambda_2d(i,j)) + (wt_R*lambda_2d(i,j+1)) + + dp = (wt_L*(p_b(i,j) - p_t(i,j))) + (wt_R*(p_b(i,j+1) - p_t(i,j+1))) + p_ave = 0.5*((wt_L*(p_t(i,j)+p_b(i,j))) + (wt_R*(p_t(i,j+1)+p_b(i,j+1)))) + I_pterm = 1.0 / (p0 + p_ave) + + eps = 0.5 * dp * I_pterm ; eps2 = eps*eps + intp(m) = ((al0 - spv_ref) + lambda * I_pterm)*dp + 2.0*eps* & + lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + enddo + ! Use Boole's rule to integrate the values. + inty_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + enddo ; enddo ; endif +end subroutine int_spec_vol_dp_wright_red + +!> Calculate the in-situ density for 1D arraya inputs and outputs. +subroutine calculate_density_array_Wright_red(this, T, S, pressure, rho, start, npts, rho_ref) + class(Wright_red_EOS), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: rho !< In situ density [kg m-3] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + + ! Local variables + integer :: j + + if (present(rho_ref)) then + do j = start, start+npts-1 + rho(j) = density_anomaly_elem_Wright_red(this, T(j), S(j), pressure(j), rho_ref) + enddo + else + do j = start, start+npts-1 + rho(j) = density_elem_Wright_red(this, T(j), S(j), pressure(j)) + enddo + endif + +end subroutine calculate_density_array_Wright_red + +!> Calculate the in-situ specific volume for 1D array inputs and outputs. +subroutine calculate_spec_vol_array_Wright_red(this, T, S, pressure, specvol, start, npts, spv_ref) + class(Wright_red_EOS), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: specvol !< In situ specific volume [m3 kg-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + ! Local variables + integer :: j + + if (present(spv_ref)) then + do j = start, start+npts-1 + specvol(j) = spec_vol_anomaly_elem_Wright_red(this, T(j), S(j), pressure(j), spv_ref) + enddo + else + do j = start, start+npts-1 + specvol(j) = spec_vol_elem_Wright_red(this, T(j), S(j), pressure(j) ) + enddo + endif + +end subroutine calculate_spec_vol_array_Wright_red + + +!> \namespace mom_eos_wright_red +!! +!! \section section_EOS_Wright_red Wright equation of state +!! +!! Wright, 1997, provide an approximation for the in situ density as a function of +!! potential temperature, salinity, and pressure. The formula follow the Tumlirz +!! equation of state which are easier to evaluate and make efficient. +!! +!! Two ranges are provided by Wright: a "full" range and "reduced" range. The version in this +!! module uses the reduced range. +!! +!! Originally coded in 2000 by R. Hallberg. +!! Anomaly form coded in 3/18. +!! +!! \subsection section_EOS_Wright_red_references References +!! +!! Wright, D., 1997: An Equation of State for Use in Ocean Models: Eckart's Formula Revisited. +!! J. Ocean. Atmosph. Tech., 14 (3), 735-740. +!! https://journals.ametsoc.org/doi/abs/10.1175/1520-0426%281997%29014%3C0735%3AAEOSFU%3E2.0.CO%3B2 + +end module MOM_EOS_Wright_red diff --git a/src/equation_of_state/MOM_EOS_base_type.F90 b/src/equation_of_state/MOM_EOS_base_type.F90 new file mode 100644 index 0000000000..5728dfa2f2 --- /dev/null +++ b/src/equation_of_state/MOM_EOS_base_type.F90 @@ -0,0 +1,466 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> A generic type for equations of state +module MOM_EOS_base_type + +implicit none ; private + +public EOS_base + +!> The base class for implementations of the equation of state +type, abstract :: EOS_base + +contains + + ! The following functions/subroutines are deferred and must be provided specifically by each EOS + + !> Deferred implementation of the in-situ density as an elemental function [kg m-3] + procedure(i_density_elem), deferred :: density_elem + !> Deferred implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure(i_density_anomaly_elem), deferred :: density_anomaly_elem + !> Deferred implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure(i_spec_vol_elem), deferred :: spec_vol_elem + !> Deferred implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure(i_spec_vol_anomaly_elem), deferred :: spec_vol_anomaly_elem + !> Deferred implementation of the calculation of derivatives of density + procedure(i_calculate_density_derivs_elem), deferred :: calculate_density_derivs_elem + !> Deferred implementation of the calculation of second derivatives of density + procedure(i_calculate_density_second_derivs_elem), deferred :: calculate_density_second_derivs_elem + !> Deferred implementation of the calculation of derivatives of specific volume + procedure(i_calculate_specvol_derivs_elem), deferred :: calculate_specvol_derivs_elem + !> Deferred implementation of the calculation of compressibility + procedure(i_calculate_compress_elem), deferred :: calculate_compress_elem + !> Deferred implementation of the range query function + procedure(i_EOS_fit_range), deferred :: EOS_fit_range + + ! The following functions/subroutines are shared across all EOS and provided by this module + !> Returns the in-situ density or density anomaly [kg m-3] + procedure :: density_fn => a_density_fn + !> Returns the in-situ specific volume or specific volume anomaly [m3 kg-1] + procedure :: spec_vol_fn => a_spec_vol_fn + !> Calculates the in-situ density or density anomaly for scalar inputs [m3 kg-1] + procedure :: calculate_density_scalar => a_calculate_density_scalar + !> Calculates the in-situ density or density anomaly for array inputs [m3 kg-1] + procedure :: calculate_density_array => a_calculate_density_array + !> Calculates the in-situ specific volume or specific volume anomaly for scalar inputs [m3 kg-1] + procedure :: calculate_spec_vol_scalar => a_calculate_spec_vol_scalar + !> Calculates the in-situ specific volume or specific volume anomaly for array inputs [m3 kg-1] + procedure :: calculate_spec_vol_array => a_calculate_spec_vol_array + !> Calculates the derivatives of density for scalar inputs + procedure :: calculate_density_derivs_scalar => a_calculate_density_derivs_scalar + !> Calculates the derivatives of density for array inputs + procedure :: calculate_density_derivs_array => a_calculate_density_derivs_array + !> Calculates the second derivatives of density for scalar inputs + procedure :: calculate_density_second_derivs_scalar => a_calculate_density_second_derivs_scalar + !> Calculates the second derivatives of density for array inputs + procedure :: calculate_density_second_derivs_array => a_calculate_density_second_derivs_array + !> Calculates the derivatives of specific volume for array inputs + procedure :: calculate_specvol_derivs_array => a_calculate_specvol_derivs_array + !> Calculates the compressibility for array inputs + procedure :: calculate_compress_array => a_calculate_compress_array + +end type EOS_base + +interface + + !> In situ density [kg m-3] + !! + !! This is an elemental function that can be applied to any combination of scalar and array inputs. + real elemental function i_density_elem(this, T, S, pressure) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + + end function i_density_elem + + !> In situ density anomaly [kg m-3] + !! + !! This is an elemental function that can be applied to any combination of scalar and array inputs. + real elemental function i_density_anomaly_elem(this, T, S, pressure, rho_ref) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: rho_ref !< A reference density [kg m-3] + + end function i_density_anomaly_elem + + !> In situ specific volume [m3 kg-1] + !! + !! This is an elemental function that can be applied to any combination of scalar and array inputs. + real elemental function i_spec_vol_elem(this, T, S, pressure) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + + end function i_spec_vol_elem + + !> In situ specific volume anomaly [m3 kg-1] + !! + !! This is an elemental function that can be applied to any combination of scalar and array inputs. + real elemental function i_spec_vol_anomaly_elem(this, T, S, pressure, spv_ref) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + end function i_spec_vol_anomaly_elem + + !> Calculate the partial derivatives of density with potential temperature and salinity + elemental subroutine i_calculate_density_derivs_elem(this, T, S, pressure, drho_dT, drho_dS) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1] + real, intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 PSU-1] + + end subroutine i_calculate_density_derivs_elem + + !> Calculate the partial derivatives of specific volume with temperature and salinity + elemental subroutine i_calculate_specvol_derivs_elem(this, T, S, pressure, dSV_dT, dSV_dS) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1] + + end subroutine i_calculate_specvol_derivs_elem + + !> Calculate second derivatives of density with respect to temperature, salinity, and pressure + elemental subroutine i_calculate_density_second_derivs_elem(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature referenced to 0 dbar [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, intent(inout) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, intent(inout) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + + end subroutine i_calculate_density_second_derivs_elem + + !> Compute the in situ density of sea water (rho) and the compressibility (drho/dp == C_sound^-2) + !! at the given salinity, potential temperature and pressure + elemental subroutine i_calculate_compress_elem(this, T, S, pressure, rho, drho_dp) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: rho !< In situ density [kg m-3] + real, intent(out) :: drho_dp !< The partial derivative of density with pressure (or + !! the inverse of the square of sound speed) [s2 m-2] + + end subroutine i_calculate_compress_elem + + !> Return the range of temperatures, salinities and pressures for which the equations of state has been + !! fitted or is valid. Care should be taken when applying this equation of state outside of its fit range. + subroutine i_EOS_fit_range(this, T_min, T_max, S_min, S_max, p_min, p_max) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + real, optional, intent(out) :: T_min !< The minimum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: S_max !< The maximum practical salinity over which this EoS is fitted [PSU] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + end subroutine i_EOS_fit_range + +end interface + +contains + + !> In situ density [kg m-3] + real function a_density_fn(this, T, S, pressure, rho_ref) + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + + if (present(rho_ref)) then + a_density_fn = this%density_anomaly_elem(T, S, pressure, rho_ref) + else + a_density_fn = this%density_elem(T, S, pressure) + endif + + end function a_density_fn + + !> Calculate the in-situ density for scalar inputs and outputs. + subroutine a_calculate_density_scalar(this, T, S, pressure, rho, rho_ref) + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: rho !< In situ density [kg m-3] + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + + if (present(rho_ref)) then + rho = this%density_anomaly_elem(T, S, pressure, rho_ref) + else + rho = this%density_elem(T, S, pressure) + endif + + end subroutine a_calculate_density_scalar + + !> Calculate the in-situ density for 1D arraya inputs and outputs. + subroutine a_calculate_density_array(this, T, S, pressure, rho, start, npts, rho_ref) + class(EOS_base), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: rho !< In situ density [kg m-3] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + + ! Local variables + integer :: js, je + + js = start + je = start+npts-1 + + if (present(rho_ref)) then + rho(js:je) = this%density_anomaly_elem(T(js:je), S(js:je), pressure(js:je), rho_ref) + else + rho(js:je) = this%density_elem(T(js:je), S(js:je), pressure(js:je)) + endif + + end subroutine a_calculate_density_array + + !> In situ specific volume [m3 kg-1] + real function a_spec_vol_fn(this, T, S, pressure, spv_ref) + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + if (present(spv_ref)) then + a_spec_vol_fn = this%spec_vol_anomaly_elem(T, S, pressure, spv_ref) + else + a_spec_vol_fn = this%spec_vol_elem(T, S, pressure) + endif + + end function a_spec_vol_fn + + !> Calculate the in-situ specific volume for scalar inputs and outputs. + subroutine a_calculate_spec_vol_scalar(this, T, S, pressure, specvol, spv_ref) + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: specvol !< In situ specific volume [m3 kg-1] + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + if (present(spv_ref)) then + specvol = this%spec_vol_anomaly_elem(T, S, pressure, spv_ref) + else + specvol = this%spec_vol_elem(T, S, pressure) + endif + + end subroutine a_calculate_spec_vol_scalar + + !> Calculate the in-situ specific volume for 1D array inputs and outputs. + subroutine a_calculate_spec_vol_array(this, T, S, pressure, specvol, start, npts, spv_ref) + class(EOS_base), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: specvol !< In situ specific volume [m3 kg-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + ! Local variables + integer :: js, je + + js = start + je = start+npts-1 + + if (present(spv_ref)) then + specvol(js:je) = this%spec_vol_anomaly_elem(T(js:je), S(js:je), pressure(js:je), spv_ref) + else + specvol(js:je) = this%spec_vol_elem(T(js:je), S(js:je), pressure(js:je) ) + endif + + end subroutine a_calculate_spec_vol_array + + !> Calculate the derivatives of density with respect to temperature, salinity and pressure + !! for scalar inputs + subroutine a_calculate_density_derivs_scalar(this, T, S, P, drho_dT, drho_dS) + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature referenced to 0 dbar + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: P !< Pressure [Pa] + real, intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1] + real, intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 PSU-1] + + call this%calculate_density_derivs_elem(T, S, P, drho_dt, drho_ds) + + end subroutine a_calculate_density_derivs_scalar + + !> Calculate the derivatives of density with respect to temperature, salinity and pressure + !! for array inputs + subroutine a_calculate_density_derivs_array(this, T, S, pressure, drho_dT, drho_dS, start, npts) + class(EOS_base), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1] + real, dimension(:), intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in [kg m-3 PSU-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + + ! Local variables + integer :: js, je + + js = start + je = start+npts-1 + + call this%calculate_density_derivs_elem(T(js:je), S(js:je), pressure(js:je), drho_dt(js:je), drho_ds(js:je)) + + end subroutine a_calculate_density_derivs_array + + !> Calculate the second derivatives of density with respect to temperature, salinity and pressure + !! for scalar inputs + subroutine a_calculate_density_second_derivs_scalar(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature referenced to 0 dbar + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(out) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, intent(out) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, intent(out) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, intent(out) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, intent(out) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + + call this%calculate_density_second_derivs_elem(T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + + end subroutine a_calculate_density_second_derivs_scalar + + !> Calculate the second derivatives of density with respect to temperature, salinity and pressure + !! for array inputs + subroutine a_calculate_density_second_derivs_array(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp, start, npts) + class(EOS_base), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature referenced to 0 dbar + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, dimension(:), intent(out) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, dimension(:), intent(out) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, dimension(:), intent(out) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, dimension(:), intent(out) :: drho_dt_dp !< Partial derivative of alpha with respect + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + + ! Local variables + integer :: js, je + + js = start + je = start+npts-1 + + call this%calculate_density_second_derivs_elem(T(js:je), S(js:je), pressure(js:je), & + drho_ds_ds(js:je), drho_ds_dt(js:je), drho_dt_dt(js:je), & + drho_ds_dp(js:je), drho_dt_dp(js:je)) + + end subroutine a_calculate_density_second_derivs_array + + !> Calculate the partial derivatives of specific volume with temperature and salinity + !! for array inputs + subroutine a_calculate_specvol_derivs_array(this, T, S, pressure, dSV_dT, dSV_dS, start, npts) + class(EOS_base), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + real, dimension(:), intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + + ! Local variables + integer :: js, je + + js = start + je = start+npts-1 + + call this%calculate_specvol_derivs_elem(T(js:je), S(js:je), pressure(js:je), & + dSV_dT(js:je), dSV_dS(js:je)) + + end subroutine a_calculate_specvol_derivs_array + + !> Compute the in situ density of sea water (rho) and the compressibility (drho/dp == C_sound^-2) + !! at the given salinity, potential temperature and pressure for array inputs + subroutine a_calculate_compress_array(this, T, S, pressure, rho, drho_dp, start, npts) + class(EOS_base), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: rho !< In situ density [kg m-3] + real, dimension(:), intent(out) :: drho_dp !< The partial derivative of density with pressure (or + !! the inverse of the square of sound speed) [s2 m-2] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + + ! Local variables + integer :: js, je + + js = start + je = start+npts-1 + + call this%calculate_compress_elem(T(js:je), S(js:je), pressure(js:je), & + rho(js:je), drho_dp(js:je)) + + end subroutine a_calculate_compress_array + +!> \namespace mom_eos_base_type +!! +!! \section section_EOS_base_type Generic EOS type +!! + +end module MOM_EOS_base_type diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index 5ab2874175..28d3ba68a0 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -1,227 +1,158 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> A simple linear equation of state for sea water with constant coefficients module MOM_EOS_linear -! This file is part of MOM6. See LICENSE.md for the license. - +use MOM_EOS_base_type, only : EOS_base use MOM_hor_index, only : hor_index_type implicit none ; private -#include - -public calculate_compress_linear, calculate_density_linear, calculate_spec_vol_linear -public calculate_density_derivs_linear, calculate_density_derivs_scalar_linear -public calculate_specvol_derivs_linear -public calculate_density_scalar_linear, calculate_density_array_linear -public calculate_density_second_derivs_linear -public int_density_dz_linear, int_spec_vol_dp_linear - -! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional -! consistency testing. These are noted in comments with units like Z, H, L, and T, along with -! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units -! vary with the Boussinesq approximation, the Boussinesq variant is given first. - -!> Compute the density of sea water (in kg/m^3), or its anomaly from a reference density, -!! using a simple linear equation of state from salinity (in psu), potential temperature (in deg C) -!! and pressure [Pa]. -interface calculate_density_linear - module procedure calculate_density_scalar_linear, calculate_density_array_linear -end interface calculate_density_linear - -!> Compute the specific volume of sea water (in m^3/kg), or its anomaly from a reference value, -!! using a simple linear equation of state from salinity (in psu), potential temperature (in deg C) -!! and pressure [Pa]. -interface calculate_spec_vol_linear - module procedure calculate_spec_vol_scalar_linear, calculate_spec_vol_array_linear -end interface calculate_spec_vol_linear - -!> For a given thermodynamic state, return the derivatives of density with temperature and -!! salinity using the simple linear equation of state -interface calculate_density_derivs_linear - module procedure calculate_density_derivs_scalar_linear, calculate_density_derivs_array_linear -end interface calculate_density_derivs_linear - -!> For a given thermodynamic state, return the second derivatives of density with various -!! combinations of temperature, salinity, and pressure. Note that with a simple linear -!! equation of state these second derivatives are all 0. -interface calculate_density_second_derivs_linear - module procedure calculate_density_second_derivs_scalar_linear, calculate_density_second_derivs_array_linear -end interface calculate_density_second_derivs_linear - -contains - -!> This subroutine computes the density of sea water with a trivial -!! linear equation of state (in [kg m-3]) from salinity (sal [PSU]), -!! potential temperature (T [degC]), and pressure [Pa]. -subroutine calculate_density_scalar_linear(T, S, pressure, rho, & - Rho_T0_S0, dRho_dT, dRho_dS, rho_ref) - real, intent(in) :: T !< Potential temperature relative to the surface [degC]. - real, intent(in) :: S !< Salinity [PSU]. - real, intent(in) :: pressure !< pressure [Pa]. - real, intent(out) :: rho !< In situ density [kg m-3]. - real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. - real, intent(in) :: dRho_dT !< The derivatives of density with temperature - !! [kg m-3 degC-1]. - real, intent(in) :: dRho_dS !< The derivatives of density with salinity - !! in [kg m-3 ppt-1]. - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. - - if (present(rho_ref)) then - rho = (Rho_T0_S0 - rho_ref) + (dRho_dT*T + dRho_dS*S) - else - rho = Rho_T0_S0 + dRho_dT*T + dRho_dS*S - endif - -end subroutine calculate_density_scalar_linear - -!> This subroutine computes the density of sea water with a trivial -!! linear equation of state (in kg/m^3) from salinity (sal in psu), -!! potential temperature (T [degC]), and pressure [Pa]. -subroutine calculate_density_array_linear(T, S, pressure, rho, start, npts, & - Rho_T0_S0, dRho_dT, dRho_dS, rho_ref) - real, dimension(:), intent(in) :: T !< potential temperature relative to the surface [degC]. - real, dimension(:), intent(in) :: S !< salinity [PSU]. - real, dimension(:), intent(in) :: pressure !< pressure [Pa]. - real, dimension(:), intent(out) :: rho !< in situ density [kg m-3]. - integer, intent(in) :: start !< the starting point in the arrays. - integer, intent(in) :: npts !< the number of values to calculate. - real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. - real, intent(in) :: dRho_dT !< The derivatives of density with temperature - !! [kg m-3 degC-1]. - real, intent(in) :: dRho_dS !< The derivatives of density with salinity - !! in [kg m-3 ppt-1]. - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. - ! Local variables - integer :: j - - if (present(rho_ref)) then ; do j=start,start+npts-1 - rho(j) = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(j) + dRho_dS*S(j)) - enddo ; else ; do j=start,start+npts-1 - rho(j) = Rho_T0_S0 + dRho_dT*T(j) + dRho_dS*S(j) - enddo ; endif - -end subroutine calculate_density_array_linear +public linear_EOS +public int_density_dz_linear +public int_spec_vol_dp_linear +public avg_spec_vol_linear -!> This subroutine computes the in situ specific volume of sea water (specvol in -!! [m3 kg-1]) from salinity (S [PSU]), potential temperature (T [degC]) -!! and pressure [Pa], using a trivial linear equation of state for density. -!! If spv_ref is present, specvol is an anomaly from spv_ref. -subroutine calculate_spec_vol_scalar_linear(T, S, pressure, specvol, & - Rho_T0_S0, dRho_dT, dRho_dS, spv_ref) - real, intent(in) :: T !< potential temperature relative to the surface - !! [degC]. - real, intent(in) :: S !< Salinity [PSU]. - real, intent(in) :: pressure !< Pressure [Pa]. - real, intent(out) :: specvol !< In situ specific volume [m3 kg-1]. - real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. - real, intent(in) :: dRho_dT !< The derivatives of density with temperature [kg m-3 degC-1]. - real, intent(in) :: dRho_dS !< The derivatives of density with salinity [kg m-3 ppt-1]. - real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. - ! Local variables - integer :: j - - if (present(spv_ref)) then - specvol = ((1.0 - Rho_T0_S0*spv_ref) + spv_ref*(dRho_dT*T + dRho_dS*S)) / & - ( Rho_T0_S0 + (dRho_dT*T + dRho_dS*S)) - else - specvol = 1.0 / ( Rho_T0_S0 + (dRho_dT*T + dRho_dS*S)) - endif +!> The EOS_base implementation of a linear equation of state +type, extends (EOS_base) :: linear_EOS -end subroutine calculate_spec_vol_scalar_linear - -!> This subroutine computes the in situ specific volume of sea water (specvol in -!! [m3 kg-1]) from salinity (S [PSU]), potential temperature (T [degC]) -!! and pressure [Pa], using a trivial linear equation of state for density. -!! If spv_ref is present, specvol is an anomaly from spv_ref. -subroutine calculate_spec_vol_array_linear(T, S, pressure, specvol, start, npts, & - Rho_T0_S0, dRho_dT, dRho_dS, spv_ref) - real, dimension(:), intent(in) :: T !< potential temperature relative to the surface - !! [degC]. - real, dimension(:), intent(in) :: S !< Salinity [PSU]. - real, dimension(:), intent(in) :: pressure !< Pressure [Pa]. - real, dimension(:), intent(out) :: specvol !< in situ specific volume [m3 kg-1]. - integer, intent(in) :: start !< the starting point in the arrays. - integer, intent(in) :: npts !< the number of values to calculate. - real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. - real, intent(in) :: dRho_dT !< The derivatives of density with temperature [kg m-3 degC-1]. - real, intent(in) :: dRho_dS !< The derivatives of density with salinity [kg m-3 ppt-1]. - real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. - ! Local variables - integer :: j + real :: Rho_T0_S0 !< The density at T=0, S=0 and p=0 [kg m-3]. + real :: dRho_dT !< The derivative of density with temperature [kg m-3 degC-1]. + real :: dRho_dS !< The derivative of density with salinity [kg m-3 ppt-1]. + real :: dRho_dp !< The derivative of density with pressure [s2 m-2]. - if (present(spv_ref)) then ; do j=start,start+npts-1 - specvol(j) = ((1.0 - Rho_T0_S0*spv_ref) + spv_ref*(dRho_dT*T(j) + dRho_dS*S(j))) / & - ( Rho_T0_S0 + (dRho_dT*T(j) + dRho_dS*S(j))) - enddo ; else ; do j=start,start+npts-1 - specvol(j) = 1.0 / ( Rho_T0_S0 + (dRho_dT*T(j) + dRho_dS*S(j))) - enddo ; endif +contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_linear + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_linear + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_linear + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_linear + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_linear + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_linear + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_linear + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_linear + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_linear + + !> Instance specific function to set internal parameters + procedure :: set_params_linear => set_params_linear + + !> Local implementation of generic calculate_density_array for efficiency + procedure :: calculate_density_array => calculate_density_array_linear + !> Local implementation of generic calculate_spec_vol_array for efficiency + procedure :: calculate_spec_vol_array => calculate_spec_vol_array_linear + +end type linear_EOS -end subroutine calculate_spec_vol_array_linear +contains -!> This subroutine calculates the partial derivatives of density * +!> Density computed as a linear function of T and S [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of +!! scalar and array inputs. +real elemental function density_elem_linear(this, T, S, pressure) + class(linear_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [ppt] + real, intent(in) :: pressure !< Pressure [Pa] + + density_elem_linear = this%Rho_T0_S0 + this%dRho_dT*T + this%dRho_dS*S + this%dRho_dp*pressure + +end function density_elem_linear + +!> Density anomaly computed as a linear function of T and S [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of +!! scalar and array inputs. +real elemental function density_anomaly_elem_linear(this, T, S, pressure, rho_ref) + class(linear_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [ppt] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(in) :: rho_ref !< A reference density [kg m-3] + + density_anomaly_elem_linear = & + (this%Rho_T0_S0 - rho_ref) + ((this%dRho_dT*T + this%dRho_dS*S) + this%dRho_dp*pressure) + +end function density_anomaly_elem_linear + +!> Specific volume using a linear equation of state for density [m3 kg-1] +!! +!! This is an elemental function that can be applied to any combination of +!! scalar and array inputs. +real elemental function spec_vol_elem_linear(this, T, S, pressure) + class(linear_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [ppt]. + real, intent(in) :: pressure !< Pressure [Pa]. + + spec_vol_elem_linear = & + 1.0 / ( this%Rho_T0_S0 + ((this%dRho_dT*T + this%dRho_dS*S) + this%dRho_dp*pressure) ) + +end function spec_vol_elem_linear + +!> Specific volume anomaly using a linear equation of state for density [m3 kg-1] +!! +!! This is an elemental function that can be applied to any combination of +!! scalar and array inputs. +real elemental function spec_vol_anomaly_elem_linear(this, T, S, pressure, spv_ref) + class(linear_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [ppt]. + real, intent(in) :: pressure !< Pressure [Pa]. + real, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + + spec_vol_anomaly_elem_linear = & + ((1.0 - this%Rho_T0_S0*spv_ref) - & + spv_ref*((this%dRho_dT*T + this%dRho_dS*S) + this%dRho_dp*pressure)) / & + ( this%Rho_T0_S0 + ((this%dRho_dT*T + this%dRho_dS*S) + this%dRho_dp*pressure) ) + +end function spec_vol_anomaly_elem_linear + +!> This subroutine calculates the partial derivatives of density !! with potential temperature and salinity. -subroutine calculate_density_derivs_array_linear(T, S, pressure, drho_dT_out, & - drho_dS_out, Rho_T0_S0, dRho_dT, dRho_dS, start, npts) - real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface - !! [degC]. - real, intent(in), dimension(:) :: S !< Salinity [PSU]. - real, intent(in), dimension(:) :: pressure !< Pressure [Pa]. - real, intent(out), dimension(:) :: drho_dT_out !< The partial derivative of density with - !! potential temperature [kg m-3 degC-1]. - real, intent(out), dimension(:) :: drho_dS_out !< The partial derivative of density with - !! salinity [kg m-3 ppt-1]. - real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. - real, intent(in) :: dRho_dT !< The derivative of density with temperature [kg m-3 degC-1]. - real, intent(in) :: dRho_dS !< The derivative of density with salinity [kg m-3 ppt-1]. - integer, intent(in) :: start !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. - ! Local variables - integer :: j +elemental subroutine calculate_density_derivs_elem_linear(this, T, S, pressure, dRho_dT, dRho_dS) + class(linear_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [ppt]. + real, intent(in) :: pressure !< Pressure [Pa]. + real, intent(out) :: drho_dT !< The partial derivative of density with + !! potential temperature [kg m-3 degC-1]. + real, intent(out) :: drho_dS !< The partial derivative of density with + !! salinity [kg m-3 ppt-1]. - do j=start,start+npts-1 - drho_dT_out(j) = dRho_dT - drho_dS_out(j) = dRho_dS - enddo + drho_dT = this%dRho_dT + drho_dS = this%dRho_dS -end subroutine calculate_density_derivs_array_linear - -!> This subroutine calculates the partial derivatives of density * -!! with potential temperature and salinity for a single point. -subroutine calculate_density_derivs_scalar_linear(T, S, pressure, drho_dT_out, & - drho_dS_out, Rho_T0_S0, dRho_dT, dRho_dS) - real, intent(in) :: T !< Potential temperature relative to the surface - !! [degC]. - real, intent(in) :: S !< Salinity [PSU]. - real, intent(in) :: pressure !< pressure [Pa]. - real, intent(out) :: drho_dT_out !< The partial derivative of density with - !! potential temperature [kg m-3 degC-1]. - real, intent(out) :: drho_dS_out !< The partial derivative of density with - !! salinity [kg m-3 ppt-1]. - real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. - real, intent(in) :: dRho_dT !< The derivatives of density with temperature [kg m-3 degC-1]. - real, intent(in) :: dRho_dS !< The derivatives of density with salinity [kg m-3 ppt-1]. - drho_dT_out = dRho_dT - drho_dS_out = dRho_dS - -end subroutine calculate_density_derivs_scalar_linear +end subroutine calculate_density_derivs_elem_linear !> This subroutine calculates the five, partial second derivatives of density w.r.t. !! potential temperature and salinity and pressure which for a linear equation of state should all be 0. -subroutine calculate_density_second_derivs_scalar_linear(T, S, pressure, drho_dS_dS, drho_dS_dT, & - drho_dT_dT, drho_dS_dP, drho_dT_dP) - real, intent(in) :: T !< Potential temperature relative to the surface [degC]. - real, intent(in) :: S !< Salinity [PSU]. - real, intent(in) :: pressure !< pressure [Pa]. - real, intent(out) :: drho_dS_dS !< The second derivative of density with - !! salinity [kg m-3 PSU-2]. - real, intent(out) :: drho_dS_dT !< The second derivative of density with - !! temperature and salinity [kg m-3 ppt-1 degC-1]. - real, intent(out) :: drho_dT_dT !< The second derivative of density with - !! temperature [kg m-3 degC-2]. - real, intent(out) :: drho_dS_dP !< The second derivative of density with - !! salinity and pressure [kg m-3 PSU-1 Pa-1]. - real, intent(out) :: drho_dT_dP !< The second derivative of density with - !! temperature and pressure [kg m-3 degC-1 Pa-1]. +elemental subroutine calculate_density_second_derivs_elem_linear(this, T, S, pressure, & + drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP) + class(linear_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [ppt]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(inout) :: drho_dS_dS !< The second derivative of density with + !! salinity [kg m-3 ppt-2]. + real, intent(inout) :: drho_dS_dT !< The second derivative of density with + !! temperature and salinity [kg m-3 ppt-1 degC-1]. + real, intent(inout) :: drho_dT_dT !< The second derivative of density with + !! temperature [kg m-3 degC-2]. + real, intent(inout) :: drho_dS_dP !< The second derivative of density with + !! salinity and pressure [kg m-3 ppt-1 Pa-1]. + real, intent(inout) :: drho_dT_dP !< The second derivative of density with + !! temperature and pressure [kg m-3 degC-1 Pa-1]. drho_dS_dS = 0. drho_dS_dT = 0. @@ -229,153 +160,180 @@ subroutine calculate_density_second_derivs_scalar_linear(T, S, pressure, drho_dS drho_dS_dP = 0. drho_dT_dP = 0. -end subroutine calculate_density_second_derivs_scalar_linear - -!> This subroutine calculates the five, partial second derivatives of density w.r.t. -!! potential temperature and salinity and pressure which for a linear equation of state should all be 0. -subroutine calculate_density_second_derivs_array_linear(T, S,pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT,& - drho_dS_dP, drho_dT_dP, start, npts) - real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC]. - real, dimension(:), intent(in) :: S !< Salinity [PSU]. - real, dimension(:), intent(in) :: pressure !< pressure [Pa]. - real, dimension(:), intent(out) :: drho_dS_dS !< The second derivative of density with - !! salinity [kg m-3 PSU-2]. - real, dimension(:), intent(out) :: drho_dS_dT !< The second derivative of density with - !! temperature and salinity [kg m-3 ppt-1 degC-1]. - real, dimension(:), intent(out) :: drho_dT_dT !< The second derivative of density with - !! temperature [kg m-3 degC-2]. - real, dimension(:), intent(out) :: drho_dS_dP !< The second derivative of density with - !! salinity and pressure [kg m-3 PSU-1 Pa-1]. - real, dimension(:), intent(out) :: drho_dT_dP !< The second derivative of density with - !! temperature and pressure [kg m-3 degC-1 Pa-1]. - integer, intent(in) :: start !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. - ! Local variables - integer :: j - do j=start,start+npts-1 - drho_dS_dS(j) = 0. - drho_dS_dT(j) = 0. - drho_dT_dT(j) = 0. - drho_dS_dP(j) = 0. - drho_dT_dP(j) = 0. - enddo - -end subroutine calculate_density_second_derivs_array_linear +end subroutine calculate_density_second_derivs_elem_linear !> Calculate the derivatives of specific volume with temperature and salinity -subroutine calculate_specvol_derivs_linear(T, S, pressure, dSV_dT, dSV_dS, & - start, npts, Rho_T0_S0, dRho_dT, dRho_dS) - real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface - !! [degC]. - real, intent(in), dimension(:) :: S !< Salinity [PSU]. - real, intent(in), dimension(:) :: pressure !< pressure [Pa]. - real, intent(out), dimension(:) :: dSV_dS !< The partial derivative of specific volume with - !! salinity [m3 kg-1 PSU-1]. - real, intent(out), dimension(:) :: dSV_dT !< The partial derivative of specific volume with - !! potential temperature [m3 kg-1 degC-1]. - integer, intent(in) :: start !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. - real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. - real, intent(in) :: dRho_dT !< The derivative of density with - !! temperature, [kg m-3 degC-1]. - real, intent(in) :: dRho_dS !< The derivative of density with - !! salinity [kg m-3 ppt-1]. +elemental subroutine calculate_specvol_derivs_elem_linear(this, T, S, pressure, dSV_dT, dSV_dS) + class(linear_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: S !< Salinity [ppt] + real, intent(in) :: pressure !< pressure [Pa] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 ppt-1] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] ! Local variables - real :: I_rho2 - integer :: j + real :: I_rho2 ! The inverse of density squared [m6 kg-2] - do j=start,start+npts-1 - ! Sv = 1.0 / (Rho_T0_S0 + dRho_dT*T(j) + dRho_dS*S(j)) - I_rho2 = 1.0 / (Rho_T0_S0 + (dRho_dT*T(j) + dRho_dS*S(j)))**2 - dSV_dT(j) = -dRho_dT * I_rho2 - dSV_dS(j) = -dRho_dS * I_rho2 - enddo + ! Sv = 1.0 / (Rho_T0_S0 + dRho_dT*T + dRho_dS*S) + I_rho2 = 1.0 / (this%Rho_T0_S0 + ((this%dRho_dT*T + this%dRho_dS*S) + this%dRho_dp*pressure))**2 + dSV_dT = -this%dRho_dT * I_rho2 + dSV_dS = -this%dRho_dS * I_rho2 -end subroutine calculate_specvol_derivs_linear +end subroutine calculate_specvol_derivs_elem_linear !> This subroutine computes the in situ density of sea water (rho) !! and the compressibility (drho/dp == C_sound^-2) at the given !! salinity, potential temperature, and pressure. -subroutine calculate_compress_linear(T, S, pressure, rho, drho_dp, start, npts,& - Rho_T0_S0, dRho_dT, dRho_dS) - real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface - !! [degC]. - real, intent(in), dimension(:) :: S !< Salinity [PSU]. - real, intent(in), dimension(:) :: pressure !< pressure [Pa]. - real, intent(out), dimension(:) :: rho !< In situ density [kg m-3]. - real, intent(out), dimension(:) :: drho_dp !< The partial derivative of density with pressure - !! (also the inverse of the square of sound speed) - !! [s2 m-2]. - integer, intent(in) :: start !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. - real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. - real, intent(in) :: dRho_dT !< The derivative of density with - !! temperature [kg m-3 degC-1]. - real, intent(in) :: dRho_dS !< The derivative of density with - !! salinity [kg m-3 ppt-1]. - ! Local variables +elemental subroutine calculate_compress_elem_linear(this, T, S, pressure, rho, drho_dp) + class(linear_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [ppt]. + real, intent(in) :: pressure !< pressure [Pa]. + real, intent(out) :: rho !< In situ density [kg m-3]. + real, intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [s2 m-2]. + + rho = this%Rho_T0_S0 + this%dRho_dT*T + this%dRho_dS*S + this%dRho_dp*pressure + drho_dp = this%dRho_dp + +end subroutine calculate_compress_elem_linear + +!> Calculates the layer average specific volumes. The analytical solution is +!! SpV_avg = 1 / (drho_dp*dp) * ln[(1+eps)/(1-eps)] and the expression here is the first five terms of its +!! Taylor series with a trunction error of O(eps**10). |eps|<0.02 for real ocean parameters. +subroutine avg_spec_vol_linear(T, S, p_t, dp, SpV_avg, start, npts, Rho_T0_S0, dRho_dT, dRho_dS, dRho_dp) + real, dimension(:), intent(in) :: T !< Potential temperature [degC] + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: p_t !< Pressure at the top of the layer [Pa] + real, dimension(:), intent(in) :: dp !< Pressure change in the layer [Pa] + real, dimension(:), intent(inout) :: SpV_avg !< The vertical average specific volume + !! in the layer [m3 kg-1] + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3] + real, intent(in) :: dRho_dT !< The derivative of density with temperature + !! [kg m-3 degC-1] + real, intent(in) :: dRho_dS !< The derivative of density with salinity + !! [kg m-3 ppt-1] + real, intent(in) :: dRho_dp !< The derivative of density with pressure + !! [s2 m-2] + ! Local variables + real :: eps2 ! The square of a nondimensional ratio [nondim] + real :: alpha_p_ave ! The specific volume at pressure mid-point [R-1 ~> m3 kg-1] + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0, C1_9 = 1.0/9.0 ! Rational constants [nondim] integer :: j do j=start,start+npts-1 - rho(j) = Rho_T0_S0 + dRho_dT*T(j) + dRho_dS*S(j) - drho_dp(j) = 0.0 + alpha_p_ave = & + 1.0 / (Rho_T0_S0 + ((dRho_dT*T(j) + dRho_dS*S(j)) + dRho_dp*(p_t(j) + 0.5 * dp(j)))) + eps2 = (0.5 * (dRho_dp * dp(j)) * alpha_p_ave)**2 + SpV_avg(j) = alpha_p_ave * (1.0 + eps2 * (C1_3 + eps2 * (0.2 + eps2 * (C1_7 + C1_9 * eps2)))) enddo -end subroutine calculate_compress_linear +end subroutine avg_spec_vol_linear + +!> Return the range of temperatures, salinities and pressures permitted for linear equation of state. +!! Care should be taken when applying this equation of state outside of its fit range. +subroutine EoS_fit_range_linear(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(linear_EOS), intent(in) :: this !< This EOS + real, optional, intent(out) :: T_min !< The minimum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: T_max !< The maximum potential temperature over which this EoS is fitted [degC] + real, optional, intent(out) :: S_min !< The minimum salinity over which this EoS is fitted [ppt] + real, optional, intent(out) :: S_max !< The maximum salinity over which this EoS is fitted [ppt] + real, optional, intent(out) :: p_min !< The minimum pressure over which this EoS is fitted [Pa] + real, optional, intent(out) :: p_max !< The maximum pressure over which this EoS is fitted [Pa] + + if (present(T_min)) T_min = -273.0 + if (present(T_max)) T_max = 100.0 + if (present(S_min)) S_min = 0.0 + if (present(S_max)) S_max = 1000.0 + if (present(p_min)) p_min = 0.0 + if (present(p_max)) p_max = 1.0e9 + +end subroutine EoS_fit_range_linear + +!> Set coefficients for the linear equation of state +subroutine set_params_linear(this, Rho_T0_S0, dRho_dT, dRho_dS, dRho_dp) + class(linear_EOS), intent(inout) :: this !< This EOS + real, optional, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3] + real, optional, intent(in) :: dRho_dT !< The derivative of density with temperature, + !! [kg m-3 degC-1] + real, optional, intent(in) :: dRho_dS !< The derivative of density with salinity, + !! in [kg m-3 ppt-1] + real, optional, intent(in) :: dRho_dp !< The derivative of density with pressure, + !! in [s2 m-2] + + if (present(Rho_T0_S0)) this%Rho_T0_S0 = Rho_T0_S0 + if (present(dRho_dT)) this%dRho_dT = dRho_dT + if (present(dRho_dS)) this%dRho_dS = dRho_dS + if (present(dRho_dp)) this%dRho_dp = dRho_dp + +end subroutine set_params_linear !> This subroutine calculates analytical and nearly-analytical integrals of !! pressure anomalies across layers, which are required for calculating the !! finite-volume form pressure accelerations in a Boussinesq model. -subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & - Rho_T0_S0, dRho_dT, dRho_dS, dpa, intz_dpa, intx_dpa, inty_dpa, & - bathyT, dz_neglect, useMassWghtInterp) +subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & + Rho_T0_S0, dRho_dT, dRho_dS, dRho_dp, dpa, intz_dpa, intx_dpa, inty_dpa, & + bathyT, SSH, dz_neglect, MassWghtInterp, Z_0p) type(hor_index_type), intent(in) :: HI !< The horizontal index type for the arrays. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface - !! [degC]. + !! [C ~> degC]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S !< Salinity [PSU]. + intent(in) :: S !< Salinity [S ~> ppt]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: z_t !< Height at the top of the layer in depth units [Z ~> m]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: z_b !< Height at the top of the layer [Z ~> m]. - real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3] or [kg m-3], that + real, intent(in) :: rho_ref !< A mean density [R ~> kg m-3], that !! is subtracted out to reduce the magnitude of !! each of the integrals. - real, intent(in) :: rho_0_pres !< A density [R ~> kg m-3], used to calculate - !! the pressure (as p~=-z*rho_0_pres*G_e) used in - !! the equation of state. rho_0_pres is not used. + real, intent(in) :: rho_0 !< A density [R ~> kg m-3], used to calculate + !! the pressure (as p~=-z*rho_0*G_e) used in + !! the equation of state. real, intent(in) :: G_e !< The Earth's gravitational acceleration - !! [L2 Z-1 T-2 ~> m s-2] or [m2 Z-1 s-2 ~> m s-2]. - real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [R ~> kg m-3] or [kg m-3]. + !! [L2 Z-1 T-2 ~> m s-2] + real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [R ~> kg m-3] real, intent(in) :: dRho_dT !< The derivative of density with temperature, - !! [R degC-1 ~> kg m-3 degC-1] or [kg m-3 degC-1]. + !! [R C-1 ~> kg m-3 degC-1] real, intent(in) :: dRho_dS !< The derivative of density with salinity, - !! in [R ppt-1 ~> kg m-3 ppt-1] or [kg m-3 ppt-1]. + !! in [R S-1 ~> kg m-3 ppt-1] + real, intent(in) :: dRho_dp !< The derivative of density with pressure, + !! in [L-2 T2 ~> m-2 s2] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(out) :: dpa !< The change in the pressure anomaly across the - !! layer [R L2 T-2 ~> Pa] or [Pa]. + !! layer [R L2 T-2 ~> Pa] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(out) :: intz_dpa !< The integral through the thickness of the layer !! of the pressure anomaly relative to the anomaly - !! at the top of the layer [R L2 Z T-2 ~> Pa m] or [Pa m]. + !! at the top of the layer [R L2 Z T-2 ~> Pa m] real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & optional, intent(out) :: intx_dpa !< The integral in x of the difference between the !! pressure anomaly at the top and bottom of the - !! layer divided by the x grid spacing [R L2 T-2 ~> Pa] or [Pa]. + !! layer divided by the x grid spacing [R L2 T-2 ~> Pa] real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & optional, intent(out) :: inty_dpa !< The integral in y of the difference between the !! pressure anomaly at the top and bottom of the - !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] or [Pa]. + !! layer divided by the y grid spacing [R L2 T-2 ~> Pa] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(in) :: bathyT !< The depth of the bathymetry [Z ~> m]. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: SSH !< The sea surface height [Z ~> m] real, optional, intent(in) :: dz_neglect !< A miniscule thickness change [Z ~> m]. - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to - !! interpolate T/S for top and bottom integrals. + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! Local variables + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: z0pres ! The height at which the pressure is zero [Z ~> m] real :: rho_anom ! The density anomaly from rho_ref [R ~> kg m-3]. real :: raL, raR ! rho_anom to the left and right [R ~> kg m-3]. real :: dz, dzL, dzR ! Layer thicknesses [Z ~> m]. + real :: GxRho ! The gravitational acceleration times mean ocean density [R L2 Z-1 T-2 ~> Pa m-1] + real :: p_ave ! The layer averaged pressure [R L2 T-2 ~> Pa] real :: hWght ! A pressure-thickness below topography [Z ~> m]. real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [Z ~> m]. real :: iDenom ! The inverse of the denominator in the weights [Z-2 ~> m-2]. @@ -384,9 +342,10 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. real :: intz(5) ! The integrals of density with height at the - ! 5 sub-column locations [R L2 T-2 ~> Pa] or [Pa]. + ! 5 sub-column locations [R L2 T-2 ~> Pa] logical :: do_massWeight ! Indicates whether to do mass weighting. - real, parameter :: C1_6 = 1.0/6.0, C1_90 = 1.0/90.0 ! Rational constants. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface + real, parameter :: C1_6 = 1.0/6.0, C1_90 = 1.0/90.0 ! Rational constants [nondim]. integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m ! These array bounds work for the indexing convention of the input arrays, but @@ -396,20 +355,29 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & is = HI%isc ; ie = HI%iec js = HI%jsc ; je = HI%jec - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. - ! if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "bathyT must be present if useMassWghtInterp is present and true.") - ! if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& - ! "dz_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif + GxRho = G_e * rho_0 + + if (present(Z_0p)) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + z0pres(i,j) = Z_0p(i,j) + enddo ; enddo + else + z0pres(:,:) = 0.0 + endif + + do_massWeight = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + endif do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 dz = z_t(i,j) - z_b(i,j) - rho_anom = (Rho_T0_S0 - rho_ref) + dRho_dT*T(i,j) + dRho_dS*S(i,j) - dpa(i,j) = G_e*rho_anom*dz - if (present(intz_dpa)) intz_dpa(i,j) = 0.5*G_e*rho_anom*dz**2 + p_ave = -GxRho * (0.5 * (z_t(i,j) + z_b(i,j)) - z0pres(i,j)) + rho_anom = (Rho_T0_S0 - rho_ref) + dRho_dT * T(i,j) + dRho_dS * S(i,j) + dRho_dp * p_ave + dpa(i,j) = G_e * rho_anom * dz + if (present(intz_dpa)) & + intz_dpa(i,j) = 0.5 * G_e * (rho_anom - C1_6 * dRho_dp * (GxRho * dz)) * dz**2 enddo ; enddo if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq @@ -419,13 +387,19 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & hWght = 0.0 if (do_massWeight) & hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i+1,j)-SSH(i,j), z_b(i,j)-SSH(i+1,j)) if (hWght <= 0.0) then dzL = z_t(i,j) - z_b(i,j) ; dzR = z_t(i+1,j) - z_b(i+1,j) - raL = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(i,j) + dRho_dS*S(i,j)) - raR = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(i+1,j) + dRho_dS*S(i+1,j)) - intx_dpa(i,j) = G_e*C1_6 * (dzL*(2.0*raL + raR) + dzR*(2.0*raR + raL)) + p_ave = -GxRho * (0.5 * (z_t(i,j) + z_b(i,j)) - z0pres(i,j)) + raL = (Rho_T0_S0 - rho_ref) + ((dRho_dT*T(i,j) + dRho_dS*S(i,j)) + dRho_dp*p_ave) + + p_ave = -GxRho * (0.5 * (z_t(i+1,j) + z_b(i+1,j)) - z0pres(i+1,j)) + raR = (Rho_T0_S0 - rho_ref) + ((dRho_dT*T(i+1,j) + dRho_dS*S(i+1,j)) + dRho_dp*p_ave) + + intx_dpa(i,j) = G_e*C1_6 * ((dzL*(2.0*raL + raR)) + (dzR*(2.0*raR + raL))) else hL = (z_t(i,j) - z_b(i,j)) + dz_neglect hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect @@ -437,12 +411,14 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) do m=2,4 wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR) - dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j)) + dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i+1,j) - z_b(i+1,j))) + p_ave = -GxRho * ((wt_L * (0.5 * (z_t(i,j) + z_b(i,j)) - z0pres(i,j))) + & + (wt_R * (0.5 * (z_t(i+1,j) + z_b(i+1,j)) - z0pres(i+1,j)))) rho_anom = (Rho_T0_S0 - rho_ref) + & - (dRho_dT * (wtT_L*T(i,j) + wtT_R*T(i+1,j)) + & - dRho_dS * (wtT_L*S(i,j) + wtT_R*S(i+1,j))) + ((dRho_dT * ((wtT_L*T(i,j)) + (wtT_R*T(i+1,j))) + & + dRho_dS * ((wtT_L*S(i,j)) + (wtT_R*S(i+1,j)))) + dRho_dp * p_ave) intz(m) = G_e*rho_anom*dz enddo ! Use Boole's rule to integrate the values. @@ -458,13 +434,19 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & hWght = 0.0 if (do_massWeight) & hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (top_massWeight) & + hWght = max(hWght, z_b(i,j+1)-SSH(i,j), z_b(i,j)-SSH(i,j+1)) if (hWght <= 0.0) then dzL = z_t(i,j) - z_b(i,j) ; dzR = z_t(i,j+1) - z_b(i,j+1) - raL = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(i,j) + dRho_dS*S(i,j)) - raR = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(i,j+1) + dRho_dS*S(i,j+1)) - inty_dpa(i,j) = G_e*C1_6 * (dzL*(2.0*raL + raR) + dzR*(2.0*raR + raL)) + p_ave = -GxRho * (0.5 * (z_t(i,j) + z_b(i,j)) - z0pres(i,j)) + raL = (Rho_T0_S0 - rho_ref) + ((dRho_dT*T(i,j) + dRho_dS*S(i,j)) + dRho_dp*p_ave) + + p_ave = -GxRho * (0.5 * (z_t(i,j+1) + z_b(i,j+1)) - z0pres(i,j+1)) + raR = (Rho_T0_S0 - rho_ref) + ((dRho_dT*T(i,j+1) + dRho_dS*S(i,j+1)) + dRho_dp*p_ave) + + inty_dpa(i,j) = G_e*C1_6 * ((dzL*(2.0*raL + raR)) + (dzR*(2.0*raR + raL))) else hL = (z_t(i,j) - z_b(i,j)) + dz_neglect hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect @@ -476,12 +458,14 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) do m=2,4 wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR) - dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1)) + dz = (wt_L*(z_t(i,j) - z_b(i,j))) + (wt_R*(z_t(i,j+1) - z_b(i,j+1))) + p_ave = -GxRho * ((wt_L * (0.5 * (z_t(i,j) + z_b(i,j)) - z0pres(i,j))) + & + (wt_R * (0.5 * (z_t(i,j+1) + z_b(i,j+1)) - z0pres(i,j+1)))) rho_anom = (Rho_T0_S0 - rho_ref) + & - (dRho_dT * (wtT_L*T(i,j) + wtT_R*T(i,j+1)) + & - dRho_dS * (wtT_L*S(i,j) + wtT_R*S(i,j+1))) + ((dRho_dT * ((wtT_L*T(i,j)) + (wtT_R*T(i,j+1))) + & + dRho_dS * ((wtT_L*S(i,j)) + (wtT_R*S(i,j+1)))) + dRho_dp * p_ave) intz(m) = G_e*rho_anom*dz enddo ! Use Boole's rule to integrate the values. @@ -497,91 +481,116 @@ end subroutine int_density_dz_linear !! calculating the finite-volume form pressure accelerations in a non-Boussinesq !! model. Specific volume is assumed to vary linearly between adjacent points. subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & - dRho_dT, dRho_dS, dza, intp_dza, intx_dza, inty_dza, halo_size, & - bathyP, dP_neglect, useMassWghtInterp) + dRho_dT, dRho_dS, dRho_dp, dza, intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, P_surf, dP_neglect, MassWghtInterp) type(hor_index_type), intent(in) :: HI !< The ocean's horizontal index type. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface - !! [degC]. + !! [C ~> degC]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: S !< Salinity [PSU]. + intent(in) :: S !< Salinity [S ~> ppt]. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] or [Pa]. + intent(in) :: p_t !< Pressure at the top of the layer [R L2 T-2 ~> Pa] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: p_b !< Pressure at the top of the layer [R L2 T-2 ~> Pa] or [Pa]. + intent(in) :: p_b !< Pressure at the top of the layer [R L2 T-2 ~> Pa] real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out !! to reduce the magnitude of each of the integrals [R-1 ~> m3 kg-1]. !! The calculation is mathematically identical with different values of !! alpha_ref, but this reduces the effects of roundoff. - real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [R ~> kg m-3] or [kg m-3]. + real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [R ~> kg m-3] real, intent(in) :: dRho_dT !< The derivative of density with temperature - !! [R degC-1 ~> kg m-3 degC-1] or [kg m-3 degC-1]. + !! [R C-1 ~> kg m-3 degC-1] real, intent(in) :: dRho_dS !< The derivative of density with salinity, - !! in [R ppt-1 ~> kg m-3 ppt-1] or [kg m-3 ppt-1]. + !! in [R S-1 ~> kg m-3 ppt-1] + real, intent(in) :: dRho_dp !< The derivative of density with pressure, + !! in [L-2 T2 ~> m-2 s2] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(out) :: dza !< The change in the geopotential anomaly across - !! the layer [L2 T-2 ~> m2 s-2] or [m2 s-2]. + !! the layer [L2 T-2 ~> m2 s-2] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & optional, intent(out) :: intp_dza !< The integral in pressure through the layer of the !! geopotential anomaly relative to the anomaly at the - !! bottom of the layer [R L4 T-4 ~> Pa m2 s-2] or [Pa m2 s-2]. + !! bottom of the layer [R L4 T-4 ~> Pa m2 s-2] real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & optional, intent(out) :: intx_dza !< The integral in x of the difference between the !! geopotential anomaly at the top and bottom of !! the layer divided by the x grid spacing - !! [L2 T-2 ~> m2 s-2] or [m2 s-2]. + !! [L2 T-2 ~> m2 s-2] real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & optional, intent(out) :: inty_dza !< The integral in y of the difference between the !! geopotential anomaly at the top and bottom of !! the layer divided by the y grid spacing - !! [L2 T-2 ~> m2 s-2] or [m2 s-2]. + !! [L2 T-2 ~> m2 s-2] integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] or [Pa] + optional, intent(in) :: bathyP !< The pressure at the bathymetry [R L2 T-2 ~> Pa] + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: P_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with - !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] - logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting - !! to interpolate T/S for top and bottom integrals. + !! the same units as p_t [R L2 T-2 ~> Pa] + integer, optional, intent(in) :: MassWghtInterp !< A flag indicating whether and how to use + !! mass weighting to interpolate T/S in integrals ! Local variables - real :: dRho_TS ! The density anomaly due to T and S [R ~> kg m-3] or [kg m-3]. - real :: alpha_anom ! The specific volume anomaly from 1/rho_ref [R-1 ~> m3 kg-1] or [m3 kg-1]. - real :: aaL, aaR ! The specific volume anomaly to the left and right [R-1 ~> m3 kg-1] or [m3 kg-1]. - real :: dp, dpL, dpR ! Layer pressure thicknesses [R L2 T-2 ~> Pa] or [Pa]. - real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa] or [Pa]. - real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa] or [Pa]. - real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> Pa-2] or [Pa-2]. + real :: dRho ! The density anomaly due to T, S and p [R ~> kg m-3] + real :: lambda ! The sound speed squared [L2 T-2 ~> m2 s-2] + real :: eps, eps2 ! A nondimensional ratio and its square [nondim] + real :: rem ! [L2 T-2 ~> m2 s-2] + real :: p_ave ! The layer averaged pressure [R L2 T-2 ~> Pa] + real :: alpha_p_ave ! The specific volume at p_ave [R-1 ~> m3 kg-1] + real :: alpha_anom ! The specific volume anomaly from 1/rho_ref [R-1 ~> m3 kg-1] + real :: aaL, aaR ! The specific volume anomaly to the left and right [R-1 ~> m3 kg-1] + real :: dp, dpL, dpR ! Layer pressure thicknesses [R L2 T-2 ~> Pa] + real :: hWght ! A pressure-thickness below topography [R L2 T-2 ~> Pa] + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right [R L2 T-2 ~> Pa] + real :: iDenom ! The inverse of the denominator in the weights [T4 R-2 L-4 ~> Pa-2] real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column [nondim]. real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column [nondim]. real :: wt_L, wt_R ! The linear weights of the left and right columns [nondim]. real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns [nondim]. real :: intp(5) ! The integrals of specific volume with pressure at the - ! 5 sub-column locations [L2 T-2 ~> m2 s-2] or [m2 s-2]. + ! 5 sub-column locations [L2 T-2 ~> m2 s-2] logical :: do_massWeight ! Indicates whether to do mass weighting. - real, parameter :: C1_6 = 1.0/6.0, C1_90 = 1.0/90.0 ! Rational constants. + logical :: top_massWeight ! Indicates whether to do mass weighting the sea surface + logical :: massWeight_bug ! If true, use an incorrect expression to determine where to apply mass weighting + real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0, C1_9 = 1.0/9.0 ! Rational constants [nondim] + real, parameter :: C1_6 = 1.0/6.0, C1_90 = 1.0/90.0 ! Rational constants [nondim]. integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, halo Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB halo = 0 ; if (present(halo_size)) halo = MAX(halo_size,0) ish = HI%isc-halo ; ieh = HI%iec+halo ; jsh = HI%jsc-halo ; jeh = HI%jec+halo - if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh); endif - if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh); endif - - do_massWeight = .false. - if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then - do_massWeight = .true. -! if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "bathyP must be present if useMassWghtInterp is present and true.") -! if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& -! "dP_neglect must be present if useMassWghtInterp is present and true.") - endif ; endif + if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh) ; endif + if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh) ; endif + + do_massWeight = .false. ; massWeight_bug = .false. ; top_massWeight = .false. + if (present(MassWghtInterp)) then + do_massWeight = BTEST(MassWghtInterp, 0) ! True for odd values + top_massWeight = BTEST(MassWghtInterp, 1) ! True if the 2 bit is set + massWeight_bug = BTEST(MassWghtInterp, 3) ! True if the 8 bit is set + endif + lambda = 0.0 ; if (dRho_dp/=0.0) lambda = 1.0 / dRho_dp do j=jsh,jeh ; do i=ish,ieh dp = p_b(i,j) - p_t(i,j) - dRho_TS = dRho_dT*T(i,j) + dRho_dS*S(i,j) - ! alpha_anom = 1.0/(Rho_T0_S0 + dRho_TS)) - alpha_ref - alpha_anom = ((1.0-Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) - dza(i,j) = alpha_anom*dp - if (present(intp_dza)) intp_dza(i,j) = 0.5*alpha_anom*dp**2 + p_ave = 0.5 * (p_t(i,j) + p_b(i,j)) + + drho = (dRho_dT * T(i,j) + dRho_dS * S(i,j)) + dRho_dp * p_ave + alpha_p_ave = 1.0 / (Rho_T0_S0 + drho) + + ! A realistic upbound of eps is ~0.02, using dRho_dp ~ (1500 m/s)**(-2), alpha_p_ave ~ 1/(1030 kg/m3) + ! and dp ~ 1e8 Pa [~dz=10000m]. And if we use dp ~ 1e6 [~dz=100m], eps ~ 2e-4. + ! Analytically dza = 1/dRho_dp * ln[(1+eps)/(1-eps)] - alpha_ref * dp, and the expression here gives the first + ! five terms from its Taylor series with a truncation error of O(eps**11), which is beyond double floating + ! point precision. + eps = 0.5 * (dRho_dp * dp) * alpha_p_ave ; eps2 = eps * eps + ! alpha_anom = 1.0/(Rho_T0_S0 + dRho) - alpha_ref + alpha_anom = ((1.0 - Rho_T0_S0 * alpha_ref) - drho * alpha_ref) / (Rho_T0_S0 + drho) + ! The following expression would be more efficient but I suspect it changes answer. + ! alpha_anom = ((1.0 - Rho_T0_S0 * alpha_ref) - drho * alpha_ref) * alpha_p_ave + rem = (lambda * eps2) * (C1_3 + eps2 * (0.2 + eps2 * (C1_7 + C1_9 * eps2))) + dza(i,j) = alpha_anom * dp + 2.0 * eps * rem + if (present(intp_dza)) & + intp_dza(i,j) = 0.5 * alpha_anom * dp**2 - dp * ((1.0 - eps) * rem) enddo ; enddo if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq @@ -589,17 +598,26 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & ! hydrostatic consistency. For large hWght we bias the interpolation of ! T & S along the top and bottom integrals, akin to thickness weighting. hWght = 0.0 - if (do_massWeight) & + if (do_massWeight .and. massWeight_bug) then hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i+1,j)-bathyP(i,j), p_t(i,j)-bathyP(i+1,j)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i+1,j), P_surf(i+1,j)-p_b(i,j)) if (hWght <= 0.0) then dpL = p_b(i,j) - p_t(i,j) ; dpR = p_b(i+1,j) - p_t(i+1,j) - dRho_TS = dRho_dT*T(i,j) + dRho_dS*S(i,j) - aaL = ((1.0 - Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) - dRho_TS = dRho_dT*T(i+1,j) + dRho_dS*S(i+1,j) - aaR = ((1.0 - Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) - intx_dza(i,j) = C1_6 * (2.0*(dpL*aaL + dpR*aaR) + (dpL*aaR + dpR*aaL)) + p_ave = 0.5 * (p_b(i,j) + p_t(i,j)) + drho = (dRho_dT*T(i,j) + dRho_dS*S(i,j)) + dRho_dp * p_ave + aaL = ((1.0 - Rho_T0_S0*alpha_ref) - drho*alpha_ref) / (Rho_T0_S0 + drho) + + p_ave = 0.5 * (p_b(i+1,j) + p_t(i+1,j)) + drho = (dRho_dT*T(i+1,j) + dRho_dS*S(i+1,j)) + dRho_dp * p_ave + aaR = ((1.0 - Rho_T0_S0*alpha_ref) - drho*alpha_ref) / (Rho_T0_S0 + drho) + + intx_dza(i,j) = C1_6 * (2.0*((dpL*aaL) + (dpR*aaR)) + ((dpL*aaR) + (dpR*aaL))) else hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect @@ -611,16 +629,17 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) do m=2,4 wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR) ! T, S, and p are interpolated in the horizontal. The p interpolation - ! is linear, but for T and S it may be thickness wekghted. - dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(i+1,j)) - - dRho_TS = dRho_dT*(wtT_L*T(i,j) + wtT_R*T(i+1,j)) + & - dRho_dS*(wtT_L*S(i,j) + wtT_R*S(i+1,j)) - ! alpha_anom = 1.0/(Rho_T0_S0 + dRho_TS)) - alpha_ref - alpha_anom = ((1.0-Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) + ! is linear, but for T and S it may be thickness weighted. + dp = (wt_L*(p_b(i,j) - p_t(i,j))) + (wt_R*(p_b(i+1,j) - p_t(i+1,j))) + p_ave = 0.5*((wt_L*(p_t(i,j)+p_b(i,j))) + (wt_R*(p_t(i+1,j)+p_b(i+1,j)))) + + drho = (dRho_dT*((wtT_L*T(i,j)) + (wtT_R*T(i+1,j))) + & + dRho_dS*((wtT_L*S(i,j)) + (wtT_R*S(i+1,j)))) + dRho_dp * p_ave + ! alpha_anom = 1.0/(Rho_T0_S0 + drho)) - alpha_ref + alpha_anom = ((1.0-Rho_T0_S0*alpha_ref) - drho*alpha_ref) / (Rho_T0_S0 + drho) intp(m) = alpha_anom*dp enddo ! Use Boole's rule to integrate the interface height anomaly values in y. @@ -634,17 +653,26 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & ! hydrostatic consistency. For large hWght we bias the interpolation of ! T & S along the top and bottom integrals, akin to thickness weighting. hWght = 0.0 - if (do_massWeight) & + if (do_massWeight .and. massWeight_bug) then hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + elseif (do_massWeight) then + hWght = max(0., p_t(i,j+1)-bathyP(i,j), p_t(i,j)-bathyP(i,j+1)) + endif + if (top_massWeight) & + hWght = max(hWght, P_surf(i,j)-p_b(i,j+1), P_surf(i,j+1)-p_b(i,j)) if (hWght <= 0.0) then dpL = p_b(i,j) - p_t(i,j) ; dpR = p_b(i,j+1) - p_t(i,j+1) - dRho_TS = dRho_dT*T(i,j) + dRho_dS*S(i,j) - aaL = ((1.0 - Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) - dRho_TS = dRho_dT*T(i,j+1) + dRho_dS*S(i,j+1) - aaR = ((1.0 - Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) - inty_dza(i,j) = C1_6 * (2.0*(dpL*aaL + dpR*aaR) + (dpL*aaR + dpR*aaL)) + p_ave = 0.5 * (p_b(i,j) + p_t(i,j)) + dRho_dp * p_ave + drho = (dRho_dT*T(i,j) + dRho_dS*S(i,j)) + dRho_dp * p_ave + aaL = ((1.0 - Rho_T0_S0*alpha_ref) - drho*alpha_ref) / (Rho_T0_S0 + drho) + + p_ave = 0.5 * (p_b(i,j+1) + p_t(i,j+1)) + dRho_dp * p_ave + drho = (dRho_dT*T(i,j+1) + dRho_dS*S(i,j+1)) + dRho_dp * p_ave + aaR = ((1.0 - Rho_T0_S0*alpha_ref) - drho*alpha_ref) / (Rho_T0_S0 + drho) + + inty_dza(i,j) = C1_6 * (2.0*((dpL*aaL) + (dpR*aaR)) + ((dpL*aaR) + (dpR*aaL))) else hL = (p_b(i,j) - p_t(i,j)) + dP_neglect hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect @@ -656,16 +684,17 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) do m=2,4 wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L - wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + wtT_L = (wt_L*hWt_LL) + (wt_R*hWt_RL) ; wtT_R = (wt_L*hWt_LR) + (wt_R*hWt_RR) ! T, S, and p are interpolated in the horizontal. The p interpolation - ! is linear, but for T and S it may be thickness wekghted. - dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(i,j+1)) - - dRho_TS = dRho_dT*(wtT_L*T(i,j) + wtT_R*T(i,j+1)) + & - dRho_dS*(wtT_L*S(i,j) + wtT_R*S(i,j+1)) - ! alpha_anom = 1.0/(Rho_T0_S0 + dRho_TS)) - alpha_ref - alpha_anom = ((1.0-Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) + ! is linear, but for T and S it may be thickness weighted. + dp = (wt_L*(p_b(i,j) - p_t(i,j))) + (wt_R*(p_b(i,j+1) - p_t(i,j+1))) + p_ave = 0.5*((wt_L*(p_t(i,j)+p_b(i,j))) + (wt_R*(p_t(i,j+1)+p_b(i,j+1)))) + + drho = (dRho_dT*((wtT_L*T(i,j)) + (wtT_R*T(i,j+1))) + & + dRho_dS*((wtT_L*S(i,j)) + (wtT_R*S(i,j+1)))) + dRho_dp * p_ave + ! alpha_anom = 1.0/(Rho_T0_S0 + drho)) - alpha_ref + alpha_anom = ((1.0-Rho_T0_S0*alpha_ref) - drho*alpha_ref) / (Rho_T0_S0 + drho) intp(m) = alpha_anom*dp enddo ! Use Boole's rule to integrate the interface height anomaly values in y. @@ -675,4 +704,56 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & enddo ; enddo ; endif end subroutine int_spec_vol_dp_linear +!> Calculate the in-situ density for 1D arraya inputs and outputs. +subroutine calculate_density_array_linear(this, T, S, pressure, rho, start, npts, rho_ref) + class(linear_EOS), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: rho !< In situ density [kg m-3] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + + ! Local variables + integer :: j + + if (present(rho_ref)) then + do j = start, start+npts-1 + rho(j) = density_anomaly_elem_linear(this, T(j), S(j), pressure(j), rho_ref) + enddo + else + do j = start, start+npts-1 + rho(j) = density_elem_linear(this, T(j), S(j), pressure(j)) + enddo + endif + +end subroutine calculate_density_array_linear + +!> Calculate the in-situ specific volume for 1D array inputs and outputs. +subroutine calculate_spec_vol_array_linear(this, T, S, pressure, specvol, start, npts, spv_ref) + class(linear_EOS), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] + real, dimension(:), intent(in) :: S !< Salinity [ppt] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: specvol !< In situ specific volume [m3 kg-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + ! Local variables + integer :: j + + if (present(spv_ref)) then + do j = start, start+npts-1 + specvol(j) = spec_vol_anomaly_elem_linear(this, T(j), S(j), pressure(j), spv_ref) + enddo + else + do j = start, start+npts-1 + specvol(j) = spec_vol_elem_linear(this, T(j), S(j), pressure(j) ) + enddo + endif + +end subroutine calculate_spec_vol_array_linear + end module MOM_EOS_linear diff --git a/src/equation_of_state/MOM_TFreeze.F90 b/src/equation_of_state/MOM_TFreeze.F90 index 50233cae60..d55fd0a2b0 100644 --- a/src/equation_of_state/MOM_TFreeze.F90 +++ b/src/equation_of_state/MOM_TFreeze.F90 @@ -1,17 +1,20 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Freezing point expressions module MOM_TFreeze -! This file is part of MOM6. See LICENSE.md for the license. - !********+*********+*********+*********+*********+*********+*********+** !* The subroutines in this file determine the potential temperature * -!* at which sea-water freezes. * +!* or conservative temperature at which sea-water freezes. * !********+*********+*********+*********+*********+*********+*********+** use gsw_mod_toolbox, only : gsw_ct_freezing_exact implicit none ; private public calculate_TFreeze_linear, calculate_TFreeze_Millero, calculate_TFreeze_teos10 +public calculate_TFreeze_TEOS_poly !> Compute the freezing point potential temperature [degC] from salinity [ppt] and !! pressure [Pa] using a simple linear expression, with coefficients passed in as arguments. @@ -28,17 +31,23 @@ module MOM_TFreeze module procedure calculate_TFreeze_Millero_scalar, calculate_TFreeze_Millero_array end interface calculate_TFreeze_Millero -!> Compute the freezing point conservative temperature [degC] from absolute salinity [g/kg] +!> Compute the freezing point conservative temperature [degC] from absolute salinity [g kg-1] !! and pressure [Pa] using the TEOS10 package. interface calculate_TFreeze_teos10 module procedure calculate_TFreeze_teos10_scalar, calculate_TFreeze_teos10_array end interface calculate_TFreeze_teos10 +!> Compute the freezing point conservative temperature [degC] from absolute salinity [g kg-1] and +!! pressure [Pa] using a rescaled and refactored version of the expressions from the TEOS10 package. +interface calculate_TFreeze_TEOS_poly + module procedure calculate_TFreeze_TEOS_poly_scalar, calculate_TFreeze_TEOS_poly_array +end interface calculate_TFreeze_TEOS_poly + contains -!> This subroutine computes the freezing point potential temperature -!! [degC] from salinity [ppt], and pressure [Pa] using a simple -!! linear expression, with coefficients passed in as arguments. +!> This subroutine computes the freezing point potential temperature [degC] from +!! salinity [ppt], and pressure [Pa] using a simple linear expression, +!! with coefficients passed in as arguments. subroutine calculate_TFreeze_linear_scalar(S, pres, T_Fr, TFr_S0_P0, & dTFr_dS, dTFr_dp) real, intent(in) :: S !< salinity [ppt]. @@ -66,7 +75,7 @@ subroutine calculate_TFreeze_linear_array(S, pres, T_Fr, start, npts, & integer, intent(in) :: npts !< the number of values to calculate. real, intent(in) :: TFr_S0_P0 !< The freezing point at S=0, p=0, [degC]. real, intent(in) :: dTFr_dS !< The derivative of freezing point with salinity, - !! [degC PSU-1]. + !! [degC ppt-1]. real, intent(in) :: dTFr_dp !< The derivative of freezing point with pressure, !! [degC Pa-1]. integer :: j @@ -84,21 +93,23 @@ end subroutine calculate_TFreeze_linear_array !! expression for potential temperature (not in situ temperature), using a !! value that is correct at the freezing point at 35 PSU and 5e6 Pa (500 dbar). subroutine calculate_TFreeze_Millero_scalar(S, pres, T_Fr) - real, intent(in) :: S !< Salinity in PSU. - real, intent(in) :: pres !< Pressure [Pa]. - real, intent(out) :: T_Fr !< Freezing point potential temperature [degC]. + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pres !< Pressure [Pa] + real, intent(out) :: T_Fr !< Freezing point potential temperature [degC] ! Local variables - real, parameter :: cS1 = -0.0575, cS3_2 = 1.710523e-3, cS2 = -2.154996e-4 - real, parameter :: dTFr_dp = -7.75e-8 + real, parameter :: cS1 = -0.0575 ! A term in the freezing point fit [degC PSU-1] + real, parameter :: cS3_2 = 1.710523e-3 ! A term in the freezing point fit [degC PSU-3/2] + real, parameter :: cS2 = -2.154996e-4 ! A term in the freezing point fit [degC PSU-2] + real, parameter :: dTFr_dp = -7.75e-8 ! Derivative of freezing point with pressure [degC Pa-1] - T_Fr = S*(cS1 + (cS3_2 * sqrt(max(S,0.0)) + cS2 * S)) + dTFr_dp*pres + T_Fr = S*(cS1 + (cS3_2 * sqrt(max(S, 0.0)) + cS2 * S)) + dTFr_dp*pres end subroutine calculate_TFreeze_Millero_scalar !> This subroutine computes the freezing point potential temperature !! [degC] from salinity [ppt], and pressure [Pa] using the expression -!! from Millero (1978) (and in appendix A of Gill 1982), but with the of the +!! from Millero (1978) (and in appendix A of Gill 1982), but with the !! pressure dependence changed from 7.53e-8 to 7.75e-8 to make this an !! expression for potential temperature (not in situ temperature), using a !! value that is correct at the freezing point at 35 PSU and 5e6 Pa (500 dbar). @@ -110,28 +121,101 @@ subroutine calculate_TFreeze_Millero_array(S, pres, T_Fr, start, npts) integer, intent(in) :: npts !< The number of values to calculate. ! Local variables - real, parameter :: cS1 = -0.0575, cS3_2 = 1.710523e-3, cS2 = -2.154996e-4 - real, parameter :: dTFr_dp = -7.75e-8 + real, parameter :: cS1 = -0.0575 ! A term in the freezing point fit [degC PSU-1] + real, parameter :: cS3_2 = 1.710523e-3 ! A term in the freezing point fit [degC PSU-3/2] + real, parameter :: cS2 = -2.154996e-4 ! A term in the freezing point fit [degC PSU-2] + real, parameter :: dTFr_dp = -7.75e-8 ! Derivative of freezing point with pressure [degC Pa-1] integer :: j do j=start,start+npts-1 - T_Fr(j) = S(j)*(cS1 + (cS3_2 * sqrt(max(S(j),0.0)) + cS2 * S(j))) + & + T_Fr(j) = S(j)*(cS1 + (cS3_2 * sqrt(max(S(j), 0.0)) + cS2 * S(j))) + & dTFr_dp*pres(j) enddo end subroutine calculate_TFreeze_Millero_array -!> This subroutine computes the freezing point conservative temperature -!! [degC] from absolute salinity [g/kg], and pressure [Pa] using the +!> This subroutine computes the freezing point conservative temperature [degC] +!! from absolute salinity [g kg-1], and pressure [Pa] using a rescaled and +!! refactored version of the polynomial expressions from the TEOS10 package. +subroutine calculate_TFreeze_TEOS_poly_scalar(S, pres, T_Fr) + real, intent(in) :: S !< Absolute salinity [g kg-1]. + real, intent(in) :: pres !< Pressure [Pa]. + real, intent(out) :: T_Fr !< Freezing point conservative temperature [degC]. + + ! Local variables + real, dimension(1) :: S0 ! Salinity at a point [g kg-1] + real, dimension(1) :: pres0 ! Pressure at a point [Pa] + real, dimension(1) :: tfr0 ! The freezing temperature [degC] + + S0(1) = S + pres0(1) = pres + + call calculate_TFreeze_TEOS_poly_array(S0, pres0, tfr0, 1, 1) + T_Fr = tfr0(1) + +end subroutine calculate_TFreeze_TEOS_poly_scalar + +!> This subroutine computes the freezing point conservative temperature [degC] +!! from absolute salinity [g kg-1], and pressure [Pa] using a rescaled and +!! refactored version of the polynomial expressions from the TEOS10 package. +subroutine calculate_TFreeze_TEOS_poly_array(S, pres, T_Fr, start, npts) + real, dimension(:), intent(in) :: S !< absolute salinity [g kg-1]. + real, dimension(:), intent(in) :: pres !< Pressure [Pa]. + real, dimension(:), intent(out) :: T_Fr !< Freezing point conservative temperature [degC]. + integer, intent(in) :: start !< The starting point in the arrays + integer, intent(in) :: npts !< The number of values to calculate + + ! Local variables + real :: Sa ! Absolute salinity [g kg-1] = [ppt] + real :: rS ! Square root of salinity [ppt1/2] + ! The coefficients here use the notation TFab for contributions proportional to S**a/2 * P**b. + real, parameter :: TF00 = 0.017947064327968736 ! Freezing point coefficient [degC] + real, parameter :: TF20 = -6.076099099929818e-2 ! Freezing point coefficient [degC ppt-1] + real, parameter :: TF30 = 4.883198653547851e-3 ! Freezing point coefficient [degC ppt-3/2] + real, parameter :: TF40 = -1.188081601230542e-3 ! Freezing point coefficient [degC ppt-2] + real, parameter :: TF50 = 1.334658511480257e-4 ! Freezing point coefficient [degC ppt-5/2] + real, parameter :: TF60 = -8.722761043208607e-6 ! Freezing point coefficient [degC ppt-3] + real, parameter :: TF70 = 2.082038908808201e-7 ! Freezing point coefficient [degC ppt-7/2] + real, parameter :: TF01 = -7.389420998107497e-8 ! Freezing point coefficient [degC Pa-1] + real, parameter :: TF21 = -9.891538123307282e-11 ! Freezing point coefficient [degC ppt-1 Pa-1] + real, parameter :: TF31 = -8.987150128406496e-13 ! Freezing point coefficient [degC ppt-3/2 Pa-1] + real, parameter :: TF41 = 1.054318231187074e-12 ! Freezing point coefficient [degC ppt-2 Pa-1] + real, parameter :: TF51 = 3.850133554097069e-14 ! Freezing point coefficient [degC ppt-5/2 Pa-1] + real, parameter :: TF61 = -2.079022768390933e-14 ! Freezing point coefficient [degC ppt-3 Pa-1] + real, parameter :: TF71 = 1.242891021876471e-15 ! Freezing point coefficient [degC ppt-7/2 Pa-1] + real, parameter :: TF02 = -2.110913185058476e-16 ! Freezing point coefficient [degC Pa-2] + real, parameter :: TF22 = 3.831132432071728e-19 ! Freezing point coefficient [degC ppt-1 Pa-2] + real, parameter :: TF32 = 1.065556599652796e-19 ! Freezing point coefficient [degC ppt-3/2 Pa-2] + real, parameter :: TF42 = -2.078616693017569e-20 ! Freezing point coefficient [degC ppt-2 Pa-2] + real, parameter :: TF52 = 1.596435439942262e-21 ! Freezing point coefficient [degC ppt-5/2 Pa-2] + real, parameter :: TF03 = 2.295491578006229e-25 ! Freezing point coefficient [degC Pa-3] + real, parameter :: TF23 = -7.997496801694032e-27 ! Freezing point coefficient [degC ppt-1 Pa-3] + real, parameter :: TF33 = 8.756340772729538e-28 ! Freezing point coefficient [degC ppt-3/2 Pa-3] + real, parameter :: TF43 = 1.338002171109174e-29 ! Freezing point coefficient [degC ppt-2 Pa-3] + integer :: j + + do j=start,start+npts-1 + rS = sqrt(max(S(j), 0.0)) + T_Fr(j) = (TF00 + S(j)*(TF20 + rS*(TF30 + rS*(TF40 + rS*(TF50 + rS*(TF60 + rS*TF70)))))) & + + pres(j)*( (TF01 + S(j)*(TF21 + rS*(TF31 + rS*(TF41 + rS*(TF51 + rS*(TF61 + rS*TF71)))))) & + + pres(j)*((TF02 + S(j)*(TF22 + rS*(TF32 + rS*(TF42 + rS* TF52)))) & + + pres(j)*(TF03 + S(j)*(TF23 + rS*(TF33 + rS* TF43))) ) ) + enddo + +end subroutine calculate_TFreeze_TEOS_poly_array + +!> This subroutine computes the freezing point conservative temperature [degC] +!! from absolute salinity [g kg-1], and pressure [Pa] using the !! TEOS10 package. subroutine calculate_TFreeze_teos10_scalar(S, pres, T_Fr) - real, intent(in) :: S !< Absolute salinity [g/kg]. + real, intent(in) :: S !< Absolute salinity [g kg-1]. real, intent(in) :: pres !< Pressure [Pa]. real, intent(out) :: T_Fr !< Freezing point conservative temperature [degC]. ! Local variables - real, dimension(1) :: S0, pres0 - real, dimension(1) :: tfr0 + real, dimension(1) :: S0 ! Salinity at a point [g kg-1] + real, dimension(1) :: pres0 ! Pressure at a point [Pa] + real, dimension(1) :: tfr0 ! The freezing temperature [degC] S0(1) = S pres0(1) = pres @@ -141,31 +225,30 @@ subroutine calculate_TFreeze_teos10_scalar(S, pres, T_Fr) end subroutine calculate_TFreeze_teos10_scalar -!> This subroutine computes the freezing point conservative temperature -!! [degC] from absolute salinity [g/kg], and pressure [Pa] using the +!> This subroutine computes the freezing point conservative temperature [degC] +!! from absolute salinity [g kg-1], and pressure [Pa] using the !! TEOS10 package. subroutine calculate_TFreeze_teos10_array(S, pres, T_Fr, start, npts) - real, dimension(:), intent(in) :: S !< absolute salinity [g/kg]. + real, dimension(:), intent(in) :: S !< absolute salinity [g kg-1]. real, dimension(:), intent(in) :: pres !< pressure [Pa]. real, dimension(:), intent(out) :: T_Fr !< Freezing point conservative temperature [degC]. integer, intent(in) :: start !< the starting point in the arrays. integer, intent(in) :: npts !< the number of values to calculate. ! Local variables - real, parameter :: Pa2db = 1.e-4 ! The conversion factor from Pa to dbar. - real :: zs,zp + real, parameter :: Pa2db = 1.e-4 ! The conversion factor from Pa to dbar [dbar Pa-1] + real :: zp ! Pressures in [dbar] integer :: j ! Assume sea-water contains no dissolved air. - real, parameter :: saturation_fraction = 0.0 + real, parameter :: saturation_fraction = 0.0 ! Air saturation fraction in seawater [nondim] do j=start,start+npts-1 !Conversions - zs = S(j) zp = pres(j)* Pa2db !Convert pressure from Pascal to decibar if (S(j) < -1.0e-10) cycle !Can we assume safely that this is a missing value? - T_Fr(j) = gsw_ct_freezing_exact(zs,zp,saturation_fraction) - enddo + T_Fr(j) = gsw_ct_freezing_exact(S(j), zp, saturation_fraction) + enddo end subroutine calculate_TFreeze_teos10_array diff --git a/src/equation_of_state/MOM_temperature_convert.F90 b/src/equation_of_state/MOM_temperature_convert.F90 new file mode 100644 index 0000000000..e1cc3b899d --- /dev/null +++ b/src/equation_of_state/MOM_temperature_convert.F90 @@ -0,0 +1,168 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Functions to convert between conservative and potential temperature +module MOM_temperature_convert + +implicit none ; private + +public poTemp_to_consTemp, consTemp_to_poTemp + +!>@{ Parameters in the temperature conversion code +real, parameter :: Sprac_Sref = (35.0/35.16504) ! The TEOS 10 conversion factor to go from + ! reference salinity to practical salinity [nondim] +real, parameter :: I_S0 = 0.025*Sprac_Sref ! The inverse of a plausible range of oceanic salinities [kg g-1] +real, parameter :: I_Ts = 0.025 ! The inverse of a plausible range of oceanic temperatures [degC-1] +real, parameter :: I_cp0 = 1.0/3991.86795711963 ! The inverse of the "specific heat" for use + ! with Conservative Temperature, as defined with TEOS10 [degC kg J-1] + +! The following are coefficients of contributions to conservative temperature as a function of the square root +! of normalized absolute salinity with an offset (zS) and potential temperature (T) with a contribution +! Hab * zS**a * T**b. The numbers here are copied directly from the corresponding gsw module, but +! the expressions here do not use the same nondimensionalization for pressure or temperature as they do. + +real, parameter :: H00 = 61.01362420681071*I_cp0 ! Tp to Tc fit constant [degC] +real, parameter :: H01 = 168776.46138048015*(I_cp0*I_Ts) ! Tp to Tc fit T coef. [nondim] +real, parameter :: H02 = -2735.2785605119625*(I_cp0*I_Ts**2) ! Tp to Tc fit T**2 coef. [degC-1] +real, parameter :: H03 = 2574.2164453821433*(I_cp0*I_Ts**3) ! Tp to Tc fit T**3 coef. [degC-2] +real, parameter :: H04 = -1536.6644434977543*(I_cp0*I_Ts**4) ! Tp to Tc fit T**4 coef. [degC-3] +real, parameter :: H05 = 545.7340497931629*(I_cp0*I_Ts**5) ! Tp to Tc fit T**5 coef. [degC-4] +real, parameter :: H06 = -50.91091728474331*(I_cp0*I_Ts**6) ! Tp to Tc fit T**6 coef. [degC-5] +real, parameter :: H07 = -18.30489878927802*(I_cp0*I_Ts**7) ! Tp to Tc fit T**7 coef. [degC-6] +real, parameter :: H20 = 268.5520265845071*I_cp0 ! Tp to Tc fit zS**2 coef. [degC] +real, parameter :: H21 = -12019.028203559312*(I_cp0*I_Ts) ! Tp to Tc fit zS**2 * T coef. [nondim] +real, parameter :: H22 = 3734.858026725145*(I_cp0*I_Ts**2) ! Tp to Tc fit zS**2 * T**2 coef. [degC-1] +real, parameter :: H23 = -2046.7671145057618*(I_cp0*I_Ts**3) ! Tp to Tc fit zS**2 * T**3 coef. [degC-2] +real, parameter :: H24 = 465.28655623826234*(I_cp0*I_Ts**4) ! Tp to Tc fit zS**2 * T**4 coef. [degC-3] +real, parameter :: H25 = -0.6370820302376359*(I_cp0*I_Ts**5) ! Tp to Tc fit zS**2 * T**5 coef. [degC-4] +real, parameter :: H26 = -10.650848542359153*(I_cp0*I_Ts**6) ! Tp to Tc fit zS**2 * T**6 coef. [degC-5] +real, parameter :: H30 = 937.2099110620707*I_cp0 ! Tp to Tc fit zS**3 coef. [degC] +real, parameter :: H31 = 588.1802812170108*(I_cp0*I_Ts) ! Tp to Tc fit zS** 3* T coef. [nondim] +real, parameter :: H32 = 248.39476522971285*(I_cp0*I_Ts**2) ! Tp to Tc fit zS**3 * T**2 coef. [degC-1] +real, parameter :: H33 = -3.871557904936333*(I_cp0*I_Ts**3) ! Tp to Tc fit zS**3 * T**3 coef. [degC-2] +real, parameter :: H34 = -2.6268019854268356*(I_cp0*I_Ts**4) ! Tp to Tc fit zS**3 * T**4 coef. [degC-3] +real, parameter :: H40 = -1687.914374187449*I_cp0 ! Tp to Tc fit zS**4 coef. [degC] +real, parameter :: H41 = 936.3206544460336*(I_cp0*I_Ts) ! Tp to Tc fit zS**4 * T coef. [nondim] +real, parameter :: H42 = -942.7827304544439*(I_cp0*I_Ts**2) ! Tp to Tc fit zS**4 * T**2 coef. [degC-1] +real, parameter :: H43 = 369.4389437509002*(I_cp0*I_Ts**3) ! Tp to Tc fit zS**4 * T**3 coef. [degC-2] +real, parameter :: H44 = -33.83664947895248*(I_cp0*I_Ts**4) ! Tp to Tc fit zS**4 * T**4 coef. [degC-3] +real, parameter :: H45 = -9.987880382780322*(I_cp0*I_Ts**5) ! Tp to Tc fit zS**4 * T**5 coef. [degC-4] +real, parameter :: H50 = 246.9598888781377*I_cp0 ! Tp to Tc fit zS**5 coef. [degC] +real, parameter :: H60 = 123.59576582457964*I_cp0 ! Tp to Tc fit zS**6 coef. [degC] +real, parameter :: H70 = -48.5891069025409*I_cp0 ! Tp to Tc fit zS**7 coef. [degC] + +!>@} + +contains + +!> Convert input potential temperature [degC] and absolute salinity [g kg-1] to returned +!! conservative temperature [degC] using the polynomial expressions from TEOS-10. +elemental real function poTemp_to_consTemp(T, Sa) result(Tc) + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: Sa !< Absolute salinity [g kg-1] + + ! Local variables + real :: x2 ! Absolute salinity normalized by a plausible salinity range [nondim] + real :: x ! Square root of normalized absolute salinity [nondim] + + x2 = max(I_S0 * Sa, 0.0) + x = sqrt(x2) + + Tc = H00 + (T*(H01 + T*(H02 + T*(H03 + T*(H04 + T*(H05 + T*(H06 + T* H07)))))) & + + x2*(H20 + (T*(H21 + T*(H22 + T*(H23 + T*(H24 + T*(H25 + T*H26))))) & + + x*(H30 + (T*(H31 + T*(H32 + T*(H33 + T* H34))) & + + x*(H40 + (T*(H41 + T*(H42 + T*(H43 + T*(H44 + T*H45)))) & + + x*(H50 + x*(H60 + x* H70)) )) )) )) ) + +end function poTemp_to_consTemp + + +!> Return the partial derivative of conservative temperature with potential temperature [nondim] +!! based on the polynomial expressions from TEOS-10. +elemental real function dTc_dTp(T, Sa) + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: Sa !< Absolute salinity [g kg-1] + + ! Local variables + real :: x2 ! Absolute salinity normalized by a plausible salinity range [nondim] + real :: x ! Square root of normalized absolute salinity [nondim] + + x2 = max(I_S0 * Sa, 0.0) + x = sqrt(x2) + + dTc_dTp = ( H01 + T*(2.*H02 + T*(3.*H03 + T*(4.*H04 + T*(5.*H05 + T*(6.*H06 + T*(7.*H07)))))) ) & + + x2*( (H21 + T*(2.*H22 + T*(3.*H23 + T*(4.*H24 + T*(5.*H25 + T*(6.*H26)))))) & + + x*( (H31 + T*(2.*H32 + T*(3.*H33 + T*(4.*H34)))) & + + x*(H41 + T*(2.*H42 + T*(3.*H43 + T*(4.*H44 + T*(5.*H45))))) ) ) + +end function dTc_dTp + + + +!> Convert input potential temperature [degC] and absolute salinity [g kg-1] to returned +!! conservative temperature [degC] by inverting the polynomial expressions from TEOS-10. +elemental real function consTemp_to_poTemp(Tc, Sa) result(Tp) + real, intent(in) :: Tc !< Conservative temperature [degC] + real, intent(in) :: Sa !< Absolute salinity [g kg-1] + + real :: Tp_num ! The numerator of a simple expression for potential temperature [degC] + real :: I_Tp_den ! The inverse of the denominator of a simple expression for potential temperature [nondim] + real :: Tc_diff ! The difference between an estimate of conservative temperature and its target [degC] + real :: Tp_old ! A previous estimate of the potential tempearture [degC] + real :: dTp_dTc ! The partial derivative of potential temperature with conservative temperature [nondim] + ! The following are coefficients in the nominator (TPNxx) or denominator (TPDxx) of a simple rational + ! expression that approximately converts conservative temperature to potential temperature. + real, parameter :: TPN00 = -1.446013646344788e-2 ! Simple fit numerator constant [degC] + real, parameter :: TPN10 = -3.305308995852924e-3*Sprac_Sref ! Simple fit numerator Sa coef. [degC ppt-1] + real, parameter :: TPN20 = 1.062415929128982e-4*Sprac_Sref**2 ! Simple fit numerator Sa**2 coef. [degC ppt-2] + real, parameter :: TPN01 = 9.477566673794488e-1 ! Simple fit numerator Tc coef. [nondim] + real, parameter :: TPN11 = 2.166591947736613e-3*Sprac_Sref ! Simple fit numerator Sa * Tc coef. [ppt-1] + real, parameter :: TPN02 = 3.828842955039902e-3 ! Simple fit numerator Tc**2 coef. [degC-1] + real, parameter :: TPD10 = 6.506097115635800e-4*Sprac_Sref ! Simple fit denominator Sa coef. [ppt-1] + real, parameter :: TPD01 = 3.830289486850898e-3 ! Simple fit denominator Tc coef. [degC-1] + real, parameter :: TPD02 = 1.247811760368034e-6 ! Simple fit denominator Tc**2 coef. [degC-2] + + ! Estimate the potential temperature and its derivative from an approximate rational function fit. + Tp_num = TPN00 + (Sa*(TPN10 + TPN20*Sa) + Tc*(TPN01 + (TPN11*Sa + TPN02*Tc))) + I_Tp_den = 1.0 / (1.0 + (TPD10*Sa + Tc*(TPD01 + TPD02*Tc))) + Tp = Tp_num*I_Tp_den + dTp_dTc = ((TPN01 + (TPN11*Sa + 2.*TPN02*Tc)) - (TPD01 + 2.*TPD02*Tc)*Tp)*I_Tp_den + + ! Start the 1.5 iterations through the modified Newton-Raphson iterative method, which is also known + ! as the Newton-McDougall method. In this case 1.5 iterations converge to 64-bit machine precision + ! for oceanographically relevant temperatures and salinities. + + Tc_diff = poTemp_to_consTemp(Tp, Sa) - Tc + Tp_old = Tp + Tp = Tp_old - Tc_diff*dTp_dTc + + dTp_dTc = 1.0 / dTc_dTp(0.5*(Tp + Tp_old), Sa) + + Tp = Tp_old - Tc_diff*dTp_dTc + Tc_diff = poTemp_to_consTemp(Tp, Sa) - Tc + Tp_old = Tp + + Tp = Tp_old - Tc_diff*dTp_dTc + +end function consTemp_to_poTemp + +!> \namespace MOM_temperature_conv +!! +!! \section MOM_temperature_conv Temperature conversions +!! +!! This module has functions that convert potential temperature to conservative temperature +!! and the reverse, as described in the TEOS-10 manual. This code was originally derived +!! from their corresponding routines in the gsw code package, but has had some refactoring so that the +!! answers are more likely to reproduce across compilers and levels of optimization. A complete +!! discussion of the thermodynamics of seawater and the definition of conservative temperature +!! can be found in IOC et al. (2010). +!! +!! \subsection section_temperature_conv_references References +!! +!! IOC, SCOR and IAPSO, 2010: The international thermodynamic equation of seawater - 2010: +!! Calculation and use of thermodynamic properties. Intergovernmental Oceanographic Commission, +!! Manuals and Guides No. 56, UNESCO (English), 196 pp. +!! (Available from www.teos-10.org/pubs/TEOS-10_Manual.pdf) + +end module MOM_temperature_convert diff --git a/src/equation_of_state/TEOS10/gsw_mod_error_functions.f90 b/src/equation_of_state/TEOS10/gsw_mod_error_functions.f90 new file mode 120000 index 0000000000..1c3b7bfb3c --- /dev/null +++ b/src/equation_of_state/TEOS10/gsw_mod_error_functions.f90 @@ -0,0 +1 @@ +../../../pkg/GSW-Fortran/modules/gsw_mod_error_functions.f90 \ No newline at end of file diff --git a/src/equation_of_state/_Equation_of_State.dox b/src/equation_of_state/_Equation_of_State.dox index 791c7001b1..0e80c9652a 100644 --- a/src/equation_of_state/_Equation_of_State.dox +++ b/src/equation_of_state/_Equation_of_State.dox @@ -2,9 +2,10 @@ Within MOM6, there is a wrapper for the equation of state, so that all calls look the same from the rest of the model. The equation of state code has to calculate -not just in situ density, but also the compressibility and various derivatives of -the density. There is also code for computing specific volume and the -freezing temperature. +not just in situ or potential density, but also the compressibility and various +derivatives of the density. There is also code for computing specific volume and the +freezing temperature, and for converting between potential and conservative +temperatures and between practical and reference (or absolute) salinity. \section Linear_EOS Linear Equation of State @@ -12,51 +13,96 @@ Compute the required quantities with uniform values for \f$\alpha = \frac{\parti \rho}{\partial T}\f$ and \f$\beta = \frac{\partial \rho}{\partial S}\f$, (DRHO_DT, DRHO_DS in MOM_input, also uses RHO_T0_S0). -\section Wright_EOS Wright Equation of State +\section Wright_EOS Wright reduced range Equation of State -Compute the required quantities using the equation of state from \cite wright1997. -This equation of state is in the form: +Compute the required quantities using the equation of state from \cite wright1997 +as a function of potential temperature and practical salinity, with +coefficients based on the reduced-range (salinity from 28 to 38 PSU, temperature +from -2 to 30 degC and pressure up to 5000 dbar) fit to the UNESCO 1981 data. This +equation of state is in the form: \f[ \alpha(s, \theta, p) = A(s, \theta) + \frac{\lambda(s, \theta)}{P(s, \theta) + p} \f] where \f$A, \lambda\f$ and \f$P\f$ are functions only of \f$s\f$ and \f$\theta\f$ and \f$\alpha = 1/ \rho\f$ is the specific volume. This form is useful for the -pressure gradient computation as discussed in \ref section_PG. +pressure gradient computation as discussed in \ref section_PG. This EoS is selected +by setting EQN_OF_STATE = WRIGHT or WRIGHT_RED, which are mathematically equivalent, +but the latter is refactored for consistent answers between compiler settings. + +\section Wright_full_EOS Wright full range Equation of State + +Compute the required quantities using the equation of state from \cite wright1997 +as a function of potential temperature and practical salinity, with +coefficients based on a fit to the UNESCO 1981 data over the full range of +validity of that data (salinity from 0 to 40 PSU, temperatures from -2 to 40 +degC, and pressures up to 10000 dbar). The functional form of the WRIGHT_FULL +equation of state is the same as for WRIGHT or WRIGHT_RED, but with different +coefficients. + +\section Jackett06_EOS Jackett et al. (2006) Equation of State + +Compute the required quantities using the equation of state from Jackett et al. +(2006) as a function of potential temperature and practical salinity, with +coefficients based on a fit to the updated data that were later used to define +the TEOS-10 equation of state over the full range of validity of that data +(salinity from 0 to 42 PSU, temperatures from the freezing point to 40 degC, and +pressures up to 8500 dbar), but focused on the "oceanographic funnel" of +thermodynamic properties observed in the ocean. This equation of state is +commonly used in realistic Hycom simulations. -\section NEMO_EOS NEMO Equation of State +\section UNESCO_EOS UNESCO Equation of State -Compute the required quantities using the equation of state from \cite roquet2015. +Compute the required quantities using the equation of state from \cite jackett1995, +which uses potential temperature and practical salinity as state variables and is +a fit to the 1981 UNESCO equation of state with the same functional form but a +replacement of the temperature variable (the original uses in situ temperature). -\section UNESCO_EOS UNESCO Equation of State +\section ROQUET_RHO_EOS ROQUET_RHO Equation of State + +Compute the required quantities using the equation of state from \cite roquet2015, +which uses a 75-member polynomial for density as a function of conservative temperature +and absolute salinity, in a fit to the output from the full TEOS-10 equation of state. -Compute the required quantities using the equation of state from \cite jackett1995. +\section ROQUET_SPV_EOS ROQUET_SPV Equation of State + +Compute the required quantities using the specific volume oriented equation of state from +\cite roquet2015, which uses a 75-member polynomial for specific volume as a function of +conservative temperature and absolute salinity, in a fit to the output from the full +TEOS-10 equation of state. \section TEOS-10_EOS TEOS-10 Equation of State Compute the required quantities using the equation of state from -[TEOS-10](http://www.teos-10.org/). +[TEOS-10](http://www.teos-10.org/), with calls directly to the subroutines +in that code package. \section section_TFREEZE Freezing Temperature of Sea Water -There are three choices for computing the freezing point of sea water: +There are four choices for computing the freezing point of sea water: \li Linear The freezing temperature is a linear function of the salinity and pressure: \f[ T_{Fr} = (T_{Fr0} + a\,S) + b\,P \f] -where \f$T_{Fr0},a,b\f$ are contants which can be set in MOM_input (TFREEZE_S0_P0, +where \f$T_{Fr0},a,b\f$ are constants which can be set in MOM_input (TFREEZE_S0_P0, DTFREEZE_DS, DTFREEZE_DP). -\li Millero The \cite millero1978 equation is used, but modified so that it is a function -of potential temperature rather than in situ temperature: +\li Millero The \cite millero1978 equation is used to calculate the freezing +point from practical salinity and pressure, but modified so that returns a +potential temperature rather than an in situ temperature: \f[ T_{Fr} = S(a + (b \sqrt{\max(S,0.0)} + c\, S)) + d\,P \f] -where \f$a,b, c, d\f$ are fixed contants. +where \f$a,b, c, d\f$ are fixed constants. + +\li TEOS-10 The TEOS-10 package is used to compute the freezing conservative +temperature [degC] from absolute salinity [g/kg], and pressure [Pa]. This one or +TEOS_poly must be used if you are using the ROQUET_RHO, ROQUET_SPV or TEOS-10 +equation of state. -\li TEOS-10 The TEOS-10 package is used to compute the freezing conservative temperature -[degC] from absolute salinity [g/kg], and pressure [Pa]. This one must be used -if you are using the NEMO or TEOS-10 equation of state. +\li TEOS_poly A 23-term polynomial fit refactored from the TEOS-10 package is +used to compute the freezing conservative temperature [degC] from absolute +salinity [g/kg], and pressure [Pa]. */ diff --git a/src/framework/MOM_ANN.F90 b/src/framework/MOM_ANN.F90 new file mode 100644 index 0000000000..3086f4e92e --- /dev/null +++ b/src/framework/MOM_ANN.F90 @@ -0,0 +1,738 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Implements the general purpose Artificial Neural Network (ANN). +module MOM_ANN + +! This file is part of MOM6. See LICENSE.md for the license + +use MOM_io, only : MOM_read_data, field_exists +use MOM_error_handler, only : MOM_error, FATAL, MOM_mesg +use numerical_testing_type, only : testing + +implicit none ; private + +!#include + +public ANN_init, ANN_allocate, ANN_apply, ANN_end, ANN_unit_tests +public ANN_apply_vector_orig, ANN_apply_vector_oi, ANN_apply_array_sio +public set_layer, set_input_normalization, set_output_normalization +public ANN_random, randomize_layer + +!> Applies ANN to x, returning results in y +interface ANN_apply + module procedure ANN_apply_vector_oi + module procedure ANN_apply_array_sio +end interface ANN_apply + +!> Type for a single Linear layer of ANN, +!! i.e. stores the matrix A and bias b +!! for matrix-vector multiplication +!! y = A*x + b. +type, private :: layer_type ; private + integer :: output_width !< Number of rows in matrix A + integer :: input_width !< Number of columns in matrix A + logical :: activation = .True. !< If true, apply the default activation function + + real, allocatable :: A(:,:) !< Matrix in column-major order + !! of size A(output_width, input_width) [nondim] + real, allocatable :: b(:) !< bias vector of size output_width [nondim] +end type layer_type + +!> Control structure/type for ANN +type, public :: ANN_CS ; private + ! Parameters + integer :: num_layers !< Number of layers in the ANN, including the input and output. + !! For example, for ANN with one hidden layer, num_layers = 3. + integer, allocatable & + :: layer_sizes(:) !< Array of length num_layers, storing the number of neurons in + !! each layer. + + type(layer_type), allocatable & + :: layers(:) !< Array of length num_layers-1, where each element is the Linear + !! transformation between layers defined by Matrix A and vias b. + + real, allocatable :: & + input_means(:), & !< Array of length layer_sizes(1) containing the mean of each input feature + !! prior to normalization by input_norms [arbitrary]. + input_norms(:), & !< Array of length layer_sizes(1) containing the *inverse* of the standard + !! deviation for each input feature used to normalize (multiply) before + !! feeding into the ANN [arbitrary] + output_means(:), & !< Array of length layer_sizes(num_layers) containing the mean of each + !! output prior to normalization by output_norms [arbitrary]. + output_norms(:) !< Array of length layer_sizes(num_layers) containing the standard deviation + !! each output of the ANN will be multiplied [arbitrary] + + integer, public :: parameters = 0 !< Count of number of parameters +end type ANN_CS + +contains + +!> Initialization of ANN. Allocates memory and reads ANN parameters from NetCDF file. +!! The NetCDF file must contain: +!! Integer num_layers. +!! Integer arrays: layer_sizes, input_norms, output_norms +!! Matrices and biases for Linear layers can be Real(4) or Real(8) and +!! are named as: A0, b0 for the first layer; A1, b1 for the second layer and so on. +subroutine ANN_init(CS, NNfile) + type(ANN_CS), intent(inout) :: CS !< ANN control structure. + character(*), intent(in) :: NNfile !< The name of NetCDF file having neural network parameters + ! Local variables + integer :: i + integer :: num_layers ! Number of layers, including input and output layers + integer, allocatable :: layer_sizes(:) ! Number of neurons in each layer + character(len=1) :: layer_num_str + character(len=3) :: fieldname + + call MOM_mesg('ANN: init from ' // trim(NNfile), 2) + + ! Read the number of layers + call MOM_read_data(NNfile, "num_layers", num_layers) + + ! Read size of layers + allocate( layer_sizes(num_layers) ) + call MOM_read_data(NNfile, "layer_sizes", layer_sizes) + + ! Allocates the memory for storing normalization, weights and biases + call ANN_allocate(CS, num_layers, layer_sizes) + deallocate( layer_sizes ) + + ! Read normalization factors + if (field_exists(NNfile, 'input_means')) & + call MOM_read_data(NNfile, 'input_means', CS%input_means) + if (field_exists(NNfile, 'input_norms')) then + call MOM_read_data(NNfile, 'input_norms', CS%input_norms) + ! We calculate the reciprocal here to avoid repeated divisions later + CS%input_norms(:) = 1. / CS%input_norms(:) + endif + if (field_exists(NNfile, 'output_means')) & + call MOM_read_data(NNfile, 'output_means', CS%output_means) + if (field_exists(NNfile, 'output_norms')) & + call MOM_read_data(NNfile, 'output_norms', CS%output_norms) + + ! Allocate and read matrix A and bias b for each layer + do i = 1,CS%num_layers-1 + CS%layers(i)%input_width = CS%layer_sizes(i) + CS%layers(i)%output_width = CS%layer_sizes(i+1) + + ! Reading matrix A + write(layer_num_str, '(I0)') i-1 + fieldname = trim('A') // trim(layer_num_str) + call MOM_read_data(NNfile, fieldname, CS%layers(i)%A, & + (/1,1,1,1/),(/CS%layers(i)%output_width,CS%layers(i)%input_width,1,1/)) + + ! Reading bias b + fieldname = trim('b') // trim(layer_num_str) + call MOM_read_data(NNfile, fieldname, CS%layers(i)%b) + enddo + + ! No activation function for the last layer + CS%layers(CS%num_layers-1)%activation = .False. + + if (field_exists(NNfile, 'x_test') .and. field_exists(NNfile, 'y_test') ) & + call ANN_test(CS, NNfile) + + call MOM_mesg('ANN: have been read from ' // trim(NNfile), 2) + +end subroutine ANN_init + +!> Allocate an ANN +!! +!! This creates the memory for storing weights and intermediate work arrays, but does not set +!! the values of weights or biases (not even initializing with zeros). +subroutine ANN_allocate(CS, num_layers, layer_sizes) + type(ANN_CS), intent(inout) :: CS !< ANN control structure + integer, intent(in) :: num_layers !< The number of layers, including the input and output layer + integer, intent(in) :: layer_sizes(num_layers) !< The number of neurons in each layer + ! Local variables + integer :: l ! Layer number + + ! Assert that there is always an input and output layer + if (num_layers < 2) call MOM_error(FATAL, "The number of layers in an ANN must be >=2") + + CS%num_layers = num_layers + + ! Layers + allocate( CS%layer_sizes(CS%num_layers) ) + CS%layer_sizes(:) = layer_sizes(:) + + ! Input and output normalization values + allocate( CS%input_means(CS%layer_sizes(1)), source=0. ) ! Assume zero mean by default + allocate( CS%input_norms(CS%layer_sizes(1)), source=1. ) ! Assume unit variance by default + allocate( CS%output_means(CS%layer_sizes(CS%num_layers)), source=0. ) ! Assume zero mean by default + allocate( CS%output_norms(CS%layer_sizes(CS%num_layers)), source=1. ) ! Assume unit variance by default + + ! Allocate the Linear transformations between layers + allocate(CS%layers(CS%num_layers-1)) + CS%parameters = 2 * CS%layer_sizes(1) ! For input normalization + + ! Allocate matrix A and bias b for each layer + do l = 1, CS%num_layers-1 + CS%layers(l)%input_width = CS%layer_sizes(l) + CS%layers(l)%output_width = CS%layer_sizes(l+1) + + allocate( CS%layers(l)%A(CS%layers(l)%output_width, CS%layers(l)%input_width) ) + allocate( CS%layers(l)%b(CS%layers(l)%output_width) ) + + CS%parameters = CS%parameters & + + CS%layer_sizes(l) * CS%layer_sizes(l+1) & ! For weights + + CS%layer_sizes(l+1) ! For bias + enddo + CS%parameters = CS%parameters & + + 2 * CS%layer_sizes(CS%num_layers) ! For output normalization + +end subroutine ANN_allocate + +!> Test ANN by comparing the prediction with the test data. +subroutine ANN_test(CS, NNfile) + type(ANN_CS), intent(inout) :: CS !< ANN control structure. + character(*), intent(in) :: NNfile !< The name of NetCDF file having neural network parameters + ! Local variables + real, dimension(:), allocatable :: x_test, y_test, y_pred ! [arbitrary] + real :: relative_error ! [arbitrary] + character(len=200) :: relative_error_str + + ! Allocate data + allocate(x_test(CS%layer_sizes(1))) + allocate(y_test(CS%layer_sizes(CS%num_layers))) + allocate(y_pred(CS%layer_sizes(CS%num_layers))) + + ! Read test vectors + call MOM_read_data(NNfile, 'x_test', x_test) + call MOM_read_data(NNfile, 'y_test', y_test) + + ! Compute prediction + call ANN_apply_vector_oi(x_test, y_pred, CS) + + relative_error = maxval(abs(y_pred(:) - y_test(:))) / maxval(abs(y_test(:))) + + if (relative_error > 1e-5) then + write(relative_error_str, '(ES12.4)') relative_error + call MOM_error(FATAL, 'Relative error in ANN prediction is too large: ' // trim(relative_error_str)) + endif + + deallocate(x_test) + deallocate(y_test) + deallocate(y_pred) +end subroutine ANN_test + +!> Deallocates memory of ANN +subroutine ANN_end(CS) + type(ANN_CS), intent(inout) :: CS !< ANN control structure. + ! Local variables + integer :: i + + deallocate(CS%layer_sizes) + deallocate(CS%input_means) + deallocate(CS%input_norms) + deallocate(CS%output_means) + deallocate(CS%output_norms) + + do i = 1, CS%num_layers-1 + deallocate(CS%layers(i)%A) + deallocate(CS%layers(i)%b) + enddo + deallocate(CS%layers) + +end subroutine ANN_end + +!> The default activation function +pure elemental function activation_fn(x) result (y) + real, intent(in) :: x !< Scalar input value [nondim] + real :: y !< Scalar output value [nondim] + + y = max(x, 0.0) ! ReLU activation + +end function activation_fn + +!> Single application of ANN inference using vector input and output +!! +!! This implementation is the simplest using allocation and de-allocation +!! of temporary arrays +subroutine ANN_apply_vector_orig(x, y, CS) + type(ANN_CS), intent(in) :: CS !< ANN instance + real, intent(in) :: x(CS%layer_sizes(1)) !< Inputs [arbitrary] + real, intent(inout) :: y(CS%layer_sizes(CS%num_layers)) !< Outputs [arbitrary] + ! Local variables + real, allocatable :: x_1(:), x_2(:) ! intermediate states [nondim] + integer :: i, o ! Input, output indices + + ! Normalize input + allocate(x_1(CS%layer_sizes(1))) + do i = 1,CS%layer_sizes(1) + x_1(i) = ( x(i) - CS%input_means(i) ) * CS%input_norms(i) + enddo + + ! Apply Linear layers + do i = 1, CS%num_layers-1 + allocate(x_2(CS%layer_sizes(i+1))) + call layer_apply_orig(x_1, x_2, CS%layers(i)) + deallocate(x_1) + allocate(x_1(CS%layer_sizes(i+1))) + x_1(:) = x_2(:) + deallocate(x_2) + enddo + + ! Un-normalize output + do o = 1, CS%layer_sizes(CS%num_layers) + y(o) = ( x_1(o) * CS%output_norms(o) ) + CS%output_means(o) + enddo + + deallocate(x_1) + + contains + + !> Applies linear layer to input data x and stores the result in y with + !! y = A*x + b with optional application of the activation function so the + !! overall operations is ReLU(A*x + b) + subroutine layer_apply_orig(x, y, layer) + type(layer_type), intent(in) :: layer !< Linear layer + real, intent(in) :: x(layer%input_width) !< Input vector [nondim] + real, intent(inout) :: y(layer%output_width) !< Output vector [nondim] + ! Local variables + integer :: i, o ! Input, output indices + + ! Add bias + y(:) = layer%b(:) + ! Multiply by kernel + do i=1,layer%input_width + do o=1,layer%output_width + y(o) = y(o) + x(i) * layer%A(o, i) + enddo + enddo + ! Apply activation function + if (layer%activation) y(:) = activation_fn(y(:)) + + end subroutine layer_apply_orig +end subroutine ANN_apply_vector_orig + +!> Single application of ANN inference using vector input and output +!! +!! This implementation avoids repeated reallocation of work arrays and uses the +!! output index for the fastest (inner-most) loop in the layer matrix multiply. +subroutine ANN_apply_vector_oi(x, y, CS) + type(ANN_CS), intent(in) :: CS !< ANN instance + real, intent(in) :: x(CS%layer_sizes(1)) !< Inputs [arbitrary] + real, intent(inout) :: y(CS%layer_sizes(CS%num_layers)) !< Outputs [arbitrary] + ! Local variables + real, allocatable :: x_1(:), x_2(:) ! intermediate states [nondim] + integer :: i, o ! Input, output indices + + allocate( x_1( maxval( CS%layer_sizes(:) ) ) ) + allocate( x_2( maxval( CS%layer_sizes(:) ) ) ) + + ! Normalize input + do i = 1,CS%layer_sizes(1) + x_1(i) = ( x(i) - CS%input_means(i) ) * CS%input_norms(i) + enddo + + ! Apply Linear layers + do i = 1, CS%num_layers-2, 2 + call layer_apply_oi(x_1, x_2, CS%layers(i)) + call layer_apply_oi(x_2, x_1, CS%layers(i+1)) + enddo + if (mod(CS%num_layers,2)==0) then + call layer_apply_oi(x_1, x_2, CS%layers(CS%num_layers-1)) + ! Un-normalize output + do o = 1, CS%layer_sizes(CS%num_layers) + y(o) = x_2(o) * CS%output_norms(o) + CS%output_means(o) + enddo + else + ! Un-normalize output + do o = 1, CS%layer_sizes(CS%num_layers) + y(o) = x_1(o) * CS%output_norms(o) + CS%output_means(o) + enddo + endif + + deallocate(x_1, x_2) + + contains + + !> Applies linear layer to input data x and stores the result in y with + !! y = A*x + b with optional application of the activation function so the + !! overall operations is ReLU(A*x + b) + subroutine layer_apply_oi(x, y, layer) + type(layer_type), intent(in) :: layer !< Linear layer + real, intent(in) :: x(layer%input_width) !< Input vector [nondim] + real, intent(inout) :: y(layer%output_width) !< Output vector [nondim] + ! Local variables + integer :: i, o ! Input, output indices + + ! Add bias + y(:) = layer%b(:) + ! Multiply by kernel + do i=1,layer%input_width + do o=1,layer%output_width + y(o) = y(o) + x(i) * layer%A(o, i) + enddo + enddo + ! Apply activation function + if (layer%activation) y(:) = activation_fn(y(:)) + + end subroutine layer_apply_oi +end subroutine ANN_apply_vector_oi + +!> Single application of ANN inference using array input and output +!! with (space,feature) indexing +!! +!! This implementation uses the space index for the fastest (inner-most) loop +!! in the layer matrix multiply, with the input index as the next fastest loop, +!! and uses the weights matrix A(output,index). It also applies the activation +!! function within the outer loop of the matrix multiply. +subroutine ANN_apply_array_sio(nij, x, y, CS) + type(ANN_CS), intent(in) :: CS !< ANN control structure + integer, intent(in) :: nij !< Size of spatial dimension + real, intent(in) :: x(nij, CS%layer_sizes(1)) !< input [arbitrary] + real, intent(inout) :: y(nij, CS%layer_sizes(CS%num_layers)) !< output [arbitrary] + ! Local variables + real, allocatable :: x_1(:,:), x_2(:,:) ! intermediate states [nondim] + integer :: l, i, o ! Layer, input, output index + + allocate( x_1( nij, maxval( CS%layer_sizes(:) ) ) ) + allocate( x_2( nij, maxval( CS%layer_sizes(:) ) ) ) + + ! Normalize input + do i = 1, CS%layer_sizes(1) + x_1(:,i) = ( x(:,i) - CS%input_means(i) ) * CS%input_norms(i) + enddo + + ! Apply Linear layers + do l = 1, CS%num_layers-2, 2 + call layer_apply_sio(nij, x_1, x_2, CS%layers(l)) + call layer_apply_sio(nij, x_2, x_1, CS%layers(l+1)) + enddo + if (mod(CS%num_layers,2)==0) then + call layer_apply_sio(nij, x_1, x_2, CS%layers(CS%num_layers-1)) + ! Un-normalize output + do o = 1, CS%layer_sizes(CS%num_layers) + y(:,o) = x_2(:,o) * CS%output_norms(o) + CS%output_means(o) + enddo + else + ! Un-normalize output + do o = 1, CS%layer_sizes(CS%num_layers) + y(:,o) = x_1(:,o) * CS%output_norms(o) + CS%output_means(o) + enddo + endif + + deallocate(x_1, x_2) + + contains + + !> Applies linear layer to input data x and stores the result in y with + !! y = A*x + b with optional application of the activation function so the + !! overall operations is ReLU(A*x + b) + subroutine layer_apply_sio(nij, x, y, layer) + type(layer_type), intent(in) :: layer !< Linear layer + integer, intent(in) :: nij !< Size of spatial dimension + real, intent(in) :: x(nij, layer%input_width) !< Input vector [nondim] + real, intent(inout) :: y(nij, layer%output_width) !< Output vector [nondim] + ! Local variables + integer :: i, o ! Input, output indices + + do o = 1, layer%output_width + ! Add bias + y(:,o) = layer%b(o) + ! Multiply by kernel + do i = 1, layer%input_width + y(:,o) = y(:,o) + x(:,i) * layer%A(o, i) + enddo + ! Apply activation function + if (layer%activation) y(:,o) = activation_fn(y(:,o)) + enddo + + end subroutine layer_apply_sio +end subroutine ANN_apply_array_sio + +!> Sets weights and bias for a single layer +subroutine set_layer(ANN, layer, weights, biases, activation) + type(ANN_CS), intent(inout) :: ANN !< ANN control structure + integer, intent(in) :: layer !< The number of the layer being adjusted + real, intent(in) :: weights(:,:) !< The weights to assign + real, intent(in) :: biases(:) !< The biases to assign + logical, intent(in) :: activation !< Turn on the activation function + + if ( layer >= ANN%num_layers ) & + call MOM_error(FATAL, "MOM_ANN, set_layer: layer is out of range") + if ( layer < 1 ) & + call MOM_error(FATAL, "MOM_ANN, set_layer: layer should be >= 1") + + if ( size(biases) /= size(ANN%layers(layer)%b) ) & + call MOM_error(FATAL, "MOM_ANN, set_layer: mismatch in size of biases") + ANN%layers(layer)%b(:) = biases(:) + + if ( size(weights,1) /= size(ANN%layers(layer)%A,1) ) & + call MOM_error(FATAL, "MOM_ANN, set_layer: mismatch in size of weights (first dim)") + if ( size(weights,2) /= size(ANN%layers(layer)%A,2) ) & + call MOM_error(FATAL, "MOM_ANN, set_layer: mismatch in size of weights (second dim)") + ANN%layers(layer)%A(:,:) = weights(:,:) + + ANN%layers(layer)%activation = activation +end subroutine set_layer + +!> Sets input normalization +subroutine set_input_normalization(ANN, means, norms) + type(ANN_CS), intent(inout) :: ANN !< ANN control structure + real, optional, intent(in) :: means(:) !< The mean of each input + real, optional, intent(in) :: norms(:) !< The standard deviation of each input + + if (present(means)) then + if ( size(means) /= size(ANN%input_means) ) & + call MOM_error(FATAL, "MOM_ANN, set_input_normalization: mismatch in size of means") + ANN%input_means(:) = means(:) + endif + + if (present(norms)) then + if ( size(norms) /= size(ANN%input_norms) ) & + call MOM_error(FATAL, "MOM_ANN, set_input_normalization: mismatch in size of norms") + ANN%input_norms(:) = norms(:) + endif + +end subroutine set_input_normalization + +!> Sets output normalization +subroutine set_output_normalization(ANN, means, norms) + type(ANN_CS), intent(inout) :: ANN !< ANN control structure + real, optional, intent(in) :: means(:) !< The mean of each output + real, optional, intent(in) :: norms(:) !< The standard deviation of each output + + if (present(means)) then + if ( size(means) /= size(ANN%output_means) ) & + call MOM_error(FATAL, "MOM_ANN, set_output_normalization: mismatch in size of means") + ANN%output_means(:) = means(:) + endif + + if (present(norms)) then + if ( size(norms) /= size(ANN%output_norms) ) & + call MOM_error(FATAL, "MOM_ANN, set_output_normalization: mismatch in size of norms") + ANN%output_norms(:) = norms(:) + endif + +end subroutine set_output_normalization + +!> Create a random ANN +subroutine ANN_random(ANN, nlayers, widths) + type(ANN_CS), intent(inout) :: ANN !< ANN control structure + integer, intent(in) :: nlayers !< Number of layers + integer, intent(in) :: widths(nlayers) !< Width of each layer + ! Local variables + integer :: l + + call ANN_allocate(ANN, nlayers, widths) + + do l = 1, nlayers-1 + call randomize_layer(ANN, nlayers, l, widths) + enddo + +end subroutine ANN_random + +!> Fill a layer with random numbers +subroutine randomize_layer(ANN, nlayers, layer, widths) + type(ANN_CS), intent(inout) :: ANN !< ANN control structure + integer, intent(in) :: nlayers !< Number of layers + integer, intent(in) :: layer !< Layer number to randomize + integer, intent(in) :: widths(nlayers) !< Width of each layer + ! Local variables + real :: weights(widths(layer+1),widths(layer)) ! Weights + real :: biases(widths(layer+1)) ! Biases + + call random_number(weights) + weights(:,:) = 2. * weights(:,:) - 1. + + call random_number(biases) + biases(:) = 2. * biases(:) - 1. + + call set_layer(ANN, layer, weights, biases, layer Runs unit tests on ANN functions. +!! +!! Should only be called from a single/root thread. +!! Returns True if a test fails, otherwise False. +logical function ANN_unit_tests(verbose) + logical, intent(in) :: verbose !< If true, write results to stdout + ! Local variables + type(ANN_CS) :: ANN ! An ANN + type(testing) :: test ! Manage tests + real, allocatable :: x(:), y(:), y_good(:), x2(:,:), y2(:,:) ! Inputs, outputs [arbitrary] + integer, parameter :: max_rand_nlay = 10 ! Deepest random ANN to generate + integer :: widths(max_rand_nlay) ! Number of layers for random ANN + integer :: nlay ! Number of layers for random ANN + integer :: i, iter ! Loop counters + logical :: rand_res ! Status of random tests + + ANN_unit_tests = .false. ! Start by assuming all is well + call test%set(verbose=verbose) ! Pass verbose mode to test + + ! Identity ANN for one input + allocate( y(1) ) + call ANN_allocate(ANN, 2, [1,1]) + call set_layer(ANN, 1, reshape([1.],[1,1]), [0.], .false.) + call ANN_apply([1.], y, ANN) + call test%real_scalar(y(1), 1., 'Scalar identity') + deallocate( y ) + call ANN_end(ANN) + + ! Summation ANN + allocate( y(1) ) + call ANN_allocate(ANN, 2, [4,1]) + call set_layer(ANN, 1, reshape([1.,1.,1.,1.], [1,4]), [0.], .false.) + call ANN_apply([-1.,0.,1.,2.], y, ANN) + call test%real_scalar(y(1), 2., 'Summation') + deallocate( y ) + call ANN_end(ANN) + + ! Identity ANN for vector input/output + call ANN_allocate(ANN, 2, [3,3]) + allocate( y(3) ) + call set_layer(ANN, 1, reshape([1.,0.,0., & + 0.,1.,0., & + 0.,0.,1.], [3,3]), [0.,0.,0.], .false.) + call ANN_apply([-1.,0.,1.], y, ANN) + call test%real_arr(3, y, [-1.,0.,1.], 'Vector identity') + deallocate( y ) + call ANN_end(ANN) + + ! Rectifying ANN for vector input/output + allocate( y(3) ) + call ANN_allocate(ANN, 2, [3,3]) + call set_layer(ANN, 1, reshape([1.,0.,0., & + 0.,1.,0., & + 0.,0.,1.], [3,3]), [0.,0.,0.], .true.) + call ANN_apply([-1.,0.,1.], y, ANN) + call test%real_arr(3, y, [0.,0.,1.], 'Rectifier') + deallocate( y ) + call ANN_end(ANN) + + ! The next 3 tests re-use the same network with 4 inputs, a 4-wide hidden layer, and one output + allocate( y(1) ) + call ANN_allocate(ANN, 3, [4,4,1]) + + ! 1 hidden layer: rectifier followed by summation + ! Inputs: [-1,0,1,2] + ! Rectified: [0,0,1,2] + ! Sum: 3 + ! Outputs: 3 + call set_layer(ANN, 1, reshape([1.,0.,0.,0., & + 0.,1.,0.,0., & + 0.,0.,1.,0., & + 0.,0.,0.,1.], [4,4]), [0.,0.,0.,0.], .true.) + call set_layer(ANN, 2, reshape([1.,1.,1.,1.], [1,4]), [0.], .false.) + call ANN_apply_vector_orig([-1.,0.,1.,2.], y, ANN) + call test%real_scalar(y(1), 3., 'Rectifier+summation') + + ! as above but with biases + ! Inputs: [-2,-1,0,1] + ! After bias: [-1,0,1,2] with b=1 + ! Rectified: [0,0,1,2] + ! Sum: 3 + ! After bias: 6 with b=3 + ! Outputs: 6 + call set_layer(ANN, 1, reshape([1.,0.,0.,0., & + 0.,1.,0.,0., & + 0.,0.,1.,0., & + 0.,0.,0.,1.], [4,4]), [1.,1.,1.,1.], .true.) + call set_layer(ANN, 2, reshape([1.,1.,1.,1.], [1,4]), [3.], .false.) + call ANN_apply_vector_orig([-2.,-1.,0.,1.], y, ANN) + call test%real_scalar(y(1), 6., 'Rectifier+summation+bias') + + ! as above but with normalization of inputs and outputs + ! Inputs: [0,2,4,6] + ! Normalized inputs: [-2,-1,0,1] (using mean=-4, norm=2) + ! Normalized outputs: 6 + ! De-normalized output: 2 (using mean=-10, norm=2) + call set_input_normalization(ANN, means=[4.,4.,4.,4.], norms=[0.5,0.5,0.5,0.5]) + call set_output_normalization(ANN, norms=[2.], means=[-10.]) + call ANN_apply_vector_orig([0.,2.,4.,6.], y, ANN) + call test%real_scalar(y(1), 2., 'Rectifier+summation+bias+norms') + + deallocate( y ) + call ANN_end(ANN) + + ! as above with a 1x1 4th identity layer (to check loop combinations) + allocate( y(1) ) + call ANN_allocate(ANN, 4, [4,4,1,1]) + call set_layer(ANN, 1, reshape([1.,0.,0.,0., & + 0.,1.,0.,0., & + 0.,0.,1.,0., & + 0.,0.,0.,1.], [4,4]), [1.,1.,1.,1.], .true.) + call set_layer(ANN, 2, reshape([1.,1.,1.,1.], [1,4]), [3.], .false.) + call set_layer(ANN, 3, reshape([1.],[1,1]), [0.], .false.) + call set_input_normalization(ANN, means=[4.,4.,4.,4.], norms=[0.5,0.5,0.5,0.5]) + call set_output_normalization(ANN, norms=[2.], means=[-10.]) + call ANN_apply_vector_orig([0.,2.,4.,6.], y, ANN) + call test%real_scalar(y(1), 2., 'Rectifier+summation+bias+norms 4-layer') + + ! as above with v2 of ANN_apply + call ANN_apply_vector_oi([0.,2.,4.,6.], y, ANN) + call test%real_scalar(y(1), 2., 'Rectifier+summation+bias+norms 4-layer v2') + deallocate( y ) + + allocate( y2(1,2) ) + ! as above with v5 of ANN_apply applied to 2d inputs, x(space,feature) + call ANN_apply_array_sio(2, reshape([0.,1.,2.,3.,4.,5.,6.,7.],[2,4]), y2, ANN) + call test%real_arr(2, y2, [2.,5.], 'Rectifier+summation+bias+norms 4-layer array v2') + deallocate( y2 ) + + call ANN_end(ANN) + + ! The following block checks that for random ANN (weights and layers widths) + ! each of the various implementations of inference give identical results. + ! This helped catch loop and allocation errors. + rand_res = .false. + do iter = 1, 1000 + allocate( y(max_rand_nlay+1) ) + call random_number(y) ! Vector of random numbers 0..1 + nlay = 2 + floor( y(max_rand_nlay+1) * ( max_rand_nlay - 1 ) ) ! 2 < nlay < max_rand_nlay + widths(:) = 1 + floor( y(1:nlay) * 8 ) ! 1 < layer width < 8 + deallocate( y ) + call ANN_random(ANN, nlay, widths) + allocate( x(widths(1)), y(widths(nlay)), y_good(widths(nlay)) ) + call ANN_apply_vector_orig(x, y_good, ANN) + call ANN_apply_vector_oi(x, y, ANN) + rand_res = rand_res .or. maxval( abs( y(:) - y_good(:) ) ) > 0. ! Check results from v2 = v1 + allocate( x2(20,widths(1)), y2(20,widths(nlay)) ) ! 2D input, output + do i = 1, 20 + x2(i,:) = x(:) + enddo + call ANN_apply_array_sio(20, x2, y2, ANN) + rand_res = rand_res .or. maxval( abs( maxval(y2(:,:),1) - y_good(:) ) ) > 0. ! Check results from array v2 = v1 + rand_res = rand_res .or. maxval( abs( minval(y2(:,:),1) - y_good(:) ) ) > 0. ! Check results from array v2 = v1 + deallocate( x, y, y_good, x2, y2 ) + call ANN_end(ANN) + enddo + call test%test(rand_res, 'Equivalence between inference variants with random results') + + ANN_unit_tests = test%summarize('ANN_unit_tests') + +end function ANN_unit_tests + +!> \namespace mom_ann +!! +!! The mom_ann module is a pure fortran implementation of fully-connected feed-forward +!! networks to facilitate easy evaluation of data-driven functions in MOM6. For performant +!! implementations or for novel architectires, using machine-learning libraries (e.g. via +!! mom_database_comms) are necessary, or at least likely to be more efficient. +!! +!! The artificial neural network (ANN) understood by this MOM6 module has \f$ N \f$ layers, +!! including the input-layer and output-layer, thus requireing \f$ N \geq 2\f$. +!! +!! The output values (neurons or nodes) of any layer other than the input layer (i.e. \f$ l>1 \f$) are +!! \f[ +!! y_{l,j} = f_l( b_{l,j} + A_{l,j,i} x_{l-1,i} ) +!! \f] +!! where \f$ f(x) = max(0, x) \f$ is the ReLU activation function, \f$b_{l,j}\f$ is a bias for each neuron, +!! \f$A_{l,j,i}\f$ are a rectangular matrix of weights for each layer, and \f$x_{l-1,i}\f$ are the outputs +!! of the previous layer, \f$l-1\f$. The subscript on \f$ f_l() \f$ indicates the activation function is +!! optional for each layer. +!! +!! Currently, the performance of various implementations is dependent on the shape/size of the network and +!! the size of input data. For this reason we provide several versions that all yield the same result but +!! for differently shaped inputs. +!! +!! \image html https://upload.wikimedia.org/wikipedia/commons/4/46/Colored_neural_network.svg +!! Fig: A three layer network with 3 inputs, 2 outputs, and 1 hidden layer. There are two rectanglar +!! matrices of weights (black arrows). The bias for each neuron is implied." + +end module MOM_ANN diff --git a/src/framework/MOM_array_transform.F90 b/src/framework/MOM_array_transform.F90 index d524f618a3..5b59220ba1 100644 --- a/src/framework/MOM_array_transform.F90 +++ b/src/framework/MOM_array_transform.F90 @@ -1,3 +1,7 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Module for supporting the rotation of a field's index map. !! The implementation of each angle is described below. !! @@ -10,15 +14,22 @@ !! !! 90 degree rotations change the shape of the field, and are handled !! separately from 180 degree rotations. +!! +!! It also provides the symmetric_sum functions to do a rotationally invariant +!! sum of the contents of a 1d or 2d array. module MOM_array_transform +use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit + implicit none ; private public rotate_array public rotate_array_pair public rotate_vector public allocate_rotated_array +public symmetric_sum +public symmetric_sum_unit_tests !> Rotate the elements of an array to the rotated set of indices. @@ -58,8 +69,7 @@ module MOM_array_transform end interface rotate_vector -!> Allocate an array based on the rotated index map of an unrotated reference -!! array. +!> Allocate an array based on the rotated index map of an unrotated reference array. interface allocate_rotated_array module procedure allocate_rotated_array_real_2d module procedure allocate_rotated_array_real_3d @@ -67,13 +77,20 @@ module MOM_array_transform module procedure allocate_rotated_array_integer end interface allocate_rotated_array + +!> Return a rotationally symmetric sum of the elements of an array. +interface symmetric_sum + module procedure symmetric_sum_1d, symmetric_sum_2d +end interface symmetric_sum + + contains !> Rotate the elements of a 2d real array along first and second axes. subroutine rotate_array_real_2d(A_in, turns, A) - real, intent(in) :: A_in(:,:) !< Unrotated array + real, intent(in) :: A_in(:,:) !< Unrotated array [arbitrary] integer, intent(in) :: turns !< Number of quarter turns - real, intent(out) :: A(:,:) !< Rotated array + real, intent(out) :: A(:,:) !< Rotated array [arbitrary] integer :: m, n @@ -96,9 +113,9 @@ end subroutine rotate_array_real_2d !> Rotate the elements of a 3d real array along first and second axes. subroutine rotate_array_real_3d(A_in, turns, A) - real, intent(in) :: A_in(:,:,:) !< Unrotated array + real, intent(in) :: A_in(:,:,:) !< Unrotated array [arbitrary] integer, intent(in) :: turns !< Number of quarter turns - real, intent(out) :: A(:,:,:) !< Rotated array + real, intent(out) :: A(:,:,:) !< Rotated array [arbitrary] integer :: k @@ -110,9 +127,9 @@ end subroutine rotate_array_real_3d !> Rotate the elements of a 4d real array along first and second axes. subroutine rotate_array_real_4d(A_in, turns, A) - real, intent(in) :: A_in(:,:,:,:) !< Unrotated array + real, intent(in) :: A_in(:,:,:,:) !< Unrotated array [arbitrary] integer, intent(in) :: turns !< Number of quarter turns - real, intent(out) :: A(:,:,:,:) !< Rotated array + real, intent(out) :: A(:,:,:,:) !< Rotated array [arbitrary] integer :: n @@ -174,11 +191,11 @@ end subroutine rotate_array_logical !> Rotate the elements of a 2d real array pair along first and second axes. subroutine rotate_array_pair_real_2d(A_in, B_in, turns, A, B) - real, intent(in) :: A_in(:,:) !< Unrotated scalar array pair - real, intent(in) :: B_in(:,:) !< Unrotated scalar array pair + real, intent(in) :: A_in(:,:) !< Unrotated scalar array pair [arbitrary] + real, intent(in) :: B_in(:,:) !< Unrotated scalar array pair [arbitrary] integer, intent(in) :: turns !< Number of quarter turns - real, intent(out) :: A(:,:) !< Rotated scalar array pair - real, intent(out) :: B(:,:) !< Rotated scalar array pair + real, intent(out) :: A(:,:) !< Rotated scalar array pair [arbitrary] + real, intent(out) :: B(:,:) !< Rotated scalar array pair [arbitrary] if (modulo(turns, 2) /= 0) then call rotate_array(B_in, turns, A) @@ -192,11 +209,11 @@ end subroutine rotate_array_pair_real_2d !> Rotate the elements of a 3d real array pair along first and second axes. subroutine rotate_array_pair_real_3d(A_in, B_in, turns, A, B) - real, intent(in) :: A_in(:,:,:) !< Unrotated scalar array pair - real, intent(in) :: B_in(:,:,:) !< Unrotated scalar array pair + real, intent(in) :: A_in(:,:,:) !< Unrotated scalar array pair [arbitrary] + real, intent(in) :: B_in(:,:,:) !< Unrotated scalar array pair [arbitrary] integer, intent(in) :: turns !< Number of quarter turns - real, intent(out) :: A(:,:,:) !< Rotated scalar array pair - real, intent(out) :: B(:,:,:) !< Rotated scalar array pair + real, intent(out) :: A(:,:,:) !< Rotated scalar array pair [arbitrary] + real, intent(out) :: B(:,:,:) !< Rotated scalar array pair [arbitrary] integer :: k @@ -227,11 +244,11 @@ end subroutine rotate_array_pair_integer !> Rotate the elements of a 2d real vector along first and second axes. subroutine rotate_vector_real_2d(A_in, B_in, turns, A, B) - real, intent(in) :: A_in(:,:) !< First component of unrotated vector - real, intent(in) :: B_in(:,:) !< Second component of unrotated vector + real, intent(in) :: A_in(:,:) !< First component of unrotated vector [arbitrary] + real, intent(in) :: B_in(:,:) !< Second component of unrotated vector [arbitrary] integer, intent(in) :: turns !< Number of quarter turns - real, intent(out) :: A(:,:) !< First component of rotated vector - real, intent(out) :: B(:,:) !< Second component of unrotated vector + real, intent(out) :: A(:,:) !< First component of rotated vector [arbitrary] + real, intent(out) :: B(:,:) !< Second component of unrotated vector [arbitrary] call rotate_array_pair(A_in, B_in, turns, A, B) @@ -245,11 +262,11 @@ end subroutine rotate_vector_real_2d !> Rotate the elements of a 3d real vector along first and second axes. subroutine rotate_vector_real_3d(A_in, B_in, turns, A, B) - real, intent(in) :: A_in(:,:,:) !< First component of unrotated vector - real, intent(in) :: B_in(:,:,:) !< Second component of unrotated vector + real, intent(in) :: A_in(:,:,:) !< First component of unrotated vector [arbitrary] + real, intent(in) :: B_in(:,:,:) !< Second component of unrotated vector [arbitrary] integer, intent(in) :: turns !< Number of quarter turns - real, intent(out) :: A(:,:,:) !< First component of rotated vector - real, intent(out) :: B(:,:,:) !< Second component of unrotated vector + real, intent(out) :: A(:,:,:) !< First component of rotated vector [arbitrary] + real, intent(out) :: B(:,:,:) !< Second component of unrotated vector [arbitrary] integer :: k @@ -261,11 +278,11 @@ end subroutine rotate_vector_real_3d !> Rotate the elements of a 4d real vector along first and second axes. subroutine rotate_vector_real_4d(A_in, B_in, turns, A, B) - real, intent(in) :: A_in(:,:,:,:) !< First component of unrotated vector - real, intent(in) :: B_in(:,:,:,:) !< Second component of unrotated vector + real, intent(in) :: A_in(:,:,:,:) !< First component of unrotated vector [arbitrary] + real, intent(in) :: B_in(:,:,:,:) !< Second component of unrotated vector [arbitrary] integer, intent(in) :: turns !< Number of quarter turns - real, intent(out) :: A(:,:,:,:) !< First component of rotated vector - real, intent(out) :: B(:,:,:,:) !< Second component of unrotated vector + real, intent(out) :: A(:,:,:,:) !< First component of rotated vector [arbitrary] + real, intent(out) :: B(:,:,:,:) !< Second component of unrotated vector [arbitrary] integer :: n @@ -280,9 +297,9 @@ end subroutine rotate_vector_real_4d subroutine allocate_rotated_array_real_2d(A_in, lb, turns, A) ! NOTE: lb must be declared before A_in integer, intent(in) :: lb(2) !< Lower index bounds of A_in - real, intent(in) :: A_in(lb(1):, lb(2):) !< Reference array + real, intent(in) :: A_in(lb(1):, lb(2):) !< Reference array [arbitrary] integer, intent(in) :: turns !< Number of quarter turns - real, allocatable, intent(inout) :: A(:,:) !< Array on rotated index + real, allocatable, intent(inout) :: A(:,:) !< Array on rotated index [arbitrary] integer :: ub(2) @@ -300,9 +317,9 @@ end subroutine allocate_rotated_array_real_2d subroutine allocate_rotated_array_real_3d(A_in, lb, turns, A) ! NOTE: lb must be declared before A_in integer, intent(in) :: lb(3) !< Lower index bounds of A_in - real, intent(in) :: A_in(lb(1):, lb(2):, lb(3):) !< Reference array + real, intent(in) :: A_in(lb(1):, lb(2):, lb(3):) !< Reference array [arbitrary] integer, intent(in) :: turns !< Number of quarter turns - real, allocatable, intent(inout) :: A(:,:,:) !< Array on rotated index + real, allocatable, intent(inout) :: A(:,:,:) !< Array on rotated index [arbitrary] integer :: ub(3) @@ -320,9 +337,9 @@ end subroutine allocate_rotated_array_real_3d subroutine allocate_rotated_array_real_4d(A_in, lb, turns, A) ! NOTE: lb must be declared before A_in integer, intent(in) :: lb(4) !< Lower index bounds of A_in - real, intent(in) :: A_in(lb(1):,lb(2):,lb(3):,lb(4):) !< Reference array + real, intent(in) :: A_in(lb(1):,lb(2):,lb(3):,lb(4):) !< Reference array [arbitrary] integer, intent(in) :: turns !< Number of quarter turns - real, allocatable, intent(inout) :: A(:,:,:,:) !< Array on rotated index + real, allocatable, intent(inout) :: A(:,:,:,:) !< Array on rotated index [arbitrary] integer:: ub(4) @@ -354,4 +371,206 @@ subroutine allocate_rotated_array_integer(A_in, lb, turns, A) endif end subroutine allocate_rotated_array_integer + +!> Do a rotationally symmetric sum of a 1-d array +function symmetric_sum_1d(field) result(sum) + real, dimension(1:), intent(in) :: field !< The field to sum in arbitrary units [A ~> a] + real :: sum !< The rotationally symmetric sum of the entries in field [A ~> a] + + ! Local variables + integer :: i, szi, szi_2 + + szi = size(field, 1) + szi_2 = szi / 2 ! Note that for an odd number szi_2 is rounded down. + sum = 0.0 + if (2*szi_2 < szi) sum = field(szi_2+1) + ! Add pairs of values, working from the inside out. + do i=szi_2,1,-1 + sum = sum + (field(i) + field(szi+1-i)) + enddo +end function symmetric_sum_1d + + +!> Do a rotationally symmetric sum of a 2-d array using a recursive "Union-Jack" pattern of addition. +recursive function symmetric_sum_2d(field) result(sum) + real, dimension(1:,1:), intent(in) :: field !< The field to sum in arbitrary units [A ~> a] + real :: sum !< The rotationally symmetric sum of the entries in field [A ~> a] + + ! Local variables + real :: quad_sum(2,2) ! The sums in each of the quadrants [A ~> a] + logical :: odd_i, odd_j + integer :: ij, szi, szj, szi_2, szj_2, ic, jc + + szi = size(field, 1) ; szj = size(field, 2) + ! These 5 special cases are equivalent to the general case, but they reduce the use + ! of complicated logic for common simple cases. + if ((szi == 1) .and. (szj == 1)) then + sum = field(1,1) + elseif ((szi == 2) .and. (szj == 2)) then + sum = (field(1,1) + field(2,2)) + (field(2,1) + field(1,2)) + elseif ((szi == 3) .and. (szj == 3)) then + sum = (field(2,2) + ((field(1,2) + field(3,2)) + (field(2,1) + field(2,3)))) + & + ((field(1,1) + field(3,3)) + (field(3,1) + field(1,3))) + elseif (szi == 1) then + sum = symmetric_sum_1d(field(1,:)) + elseif (szj == 1) then + sum = symmetric_sum_1d(field(:,1)) + else + ! This is the general case. + ! Note that for odd numbers szi_2 and szj_2 are rounded down. + szi_2 = szi / 2 + szj_2 = szj / 2 + + odd_i = (2*szi_2 < szi) ! This could be (modulo(szi,2) == 1) + odd_j = (2*szj_2 < szj) + ! Start by finding the sums along the central axes if there are an odd number of points. + if (odd_i .and. odd_j) then + ic = szi_2+1 ; jc = szj_2+1 ! The index of the central point + sum = field(ic,jc) + ! Add pairs of pairs of values, working from the inside out. + do ij=1,min(szi_2,szj_2) + sum = sum + ((field(ic-ij,jc) + field(ic+ij,jc)) + (field(ic,jc-ij) + field(ic,jc+ij))) + enddo + ! Add extra pairs of values, working from the inside out. + if (szi_2 > szj_2) then + do ij=szj_2+1,szi_2 + sum = sum + (field(ic-ij,jc) + field(ic+ij,jc)) + enddo + elseif (szj_2 > szi_2) then + do ij=szi_2+1,szj_2 + sum = sum + (field(ic,jc-ij) + field(ic,jc+ij)) + enddo + endif + elseif (odd_i) then + sum = symmetric_sum_1d(field(szi_2+1,1:szj)) + elseif (odd_j) then + sum = symmetric_sum_1d(field(1:szi,szj_2+1)) + else + sum = 0.0 + endif + + ! Find the sums in the four quadrants of the array. + if ((szi_2 > 1) .and. (szj_2 > 1)) then + ! Use a recursive call to symmetric_sum_2d to determine the sums in the corner quadrants. + quad_sum(1,1) = symmetric_sum_2d(field(1:szi_2,1:szj_2)) + quad_sum(2,1) = symmetric_sum_2d(field(szi+1-szi_2:szi,1:szj_2)) + quad_sum(1,2) = symmetric_sum_2d(field(1:szi_2,szj+1-szj_2:szj)) + quad_sum(2,2) = symmetric_sum_2d(field(szi+1-szi_2:szi,szj+1-szj_2:szj)) + elseif (szi_2 > 1) then + quad_sum(1,1) = symmetric_sum_1d(field(1:szi_2,1)) + quad_sum(2,1) = symmetric_sum_1d(field(szi+1-szi_2:szi,1)) + quad_sum(1,2) = symmetric_sum_1d(field(1:szi_2,szj)) + quad_sum(2,2) = symmetric_sum_1d(field(szi+1-szi_2:szi,szj)) + elseif (szj_2 > 1) then + quad_sum(1,1) = symmetric_sum_1d(field(1,1:szj_2)) + quad_sum(2,1) = symmetric_sum_1d(field(szi,1:szj_2)) + quad_sum(1,2) = symmetric_sum_1d(field(1,szj+1-szj_2:szj)) + quad_sum(2,2) = symmetric_sum_1d(field(szi,szj+1-szj_2:szj)) + else + quad_sum(1,1) = field(1,1) + quad_sum(2,1) = field(szi,1) + quad_sum(1,2) = field(1,szj) + quad_sum(2,2) = field(szi,szj) + endif + + sum = sum + ((quad_sum(1,1) + quad_sum(2,2)) + (quad_sum(2,1) + quad_sum(1,2))) + endif +end function symmetric_sum_2d + + +!> Do a naive non-rotationally symmetric sum of a 2-d array. This function is only here for testing. +function naive_sum_2d(field, abs_val) result(sum) + real, dimension(1:,1:), intent(in) :: field !< The field to sum in arbitrary units [A ~> a] + logical, optional, intent(in) :: abs_val !< If present and true, sum the absolute values + real :: sum !< The rotation dependent sum of the entries in field [A ~> a] + + ! Local variables + logical :: sum_abs_val + integer :: i, j, szi, szj + + szi = size(field, 1) ; szj = size(field, 2) + sum_abs_val = .false. ; if (present(abs_val)) sum_abs_val = abs_val + sum = 0.0 + if (sum_abs_val) then + do j=1,szj ; do i=1,szi + sum = sum + abs(field(i,j)) + enddo ; enddo + else + do j=1,szj ; do i=1,szi + sum = sum + field(i,j) + enddo ; enddo + endif +end function naive_sum_2d + + +!> Returns true if a unit test of the symmetric sums fails. +logical function symmetric_sum_unit_tests(verbose) + ! Arguments + logical, intent(in) :: verbose !< If true, write results to stdout + ! Local variables + character(len=120) :: fail_message !< Blank or a description of the first failed test. + integer, parameter :: sz=13 ! The maximum size of the test arrays + real :: array(sz,sz) ! An array of inexact real values for testing in arbitrary units [A] + real :: ar_90(sz,sz) ! Array rotated by 90 degrees in arbitrary units [A] + real :: ar_180(sz,sz) ! Array rotated by 180 degrees in arbitrary units [A] + real :: ar_270(sz,sz) ! Array rotated by 270 degrees in arbitrary units [A] + real :: sum(5) ! Different versions of sums over a sub-array [A] + real :: abs_sum ! The sum of the absolute values of the array [A] + real :: tol ! The tolerance for an inexact test [A] + + character(len=120) :: mesg + integer :: i, j, n, m, r + logical :: fail + + fail = .false. + fail_message = "" + + if (verbose) write(stdout,*) '==== MOM_array_transform: symmetric_sum_unit_tests ====' + + ! Fill the array with real numbers that can not be represented exactly. + do j=1,sz ; do i=1,sz + array(i,j) = 1.0 / (2.0*(j*sz + i) + 1.0) + ! Combining positive and negative numbers amplifies differences from the order of arithmetic. + if (modulo(i+j, 2) == 0) array(i,j) = -array(i,j) + enddo ; enddo + call rotate_array_real_2d(array, 1, ar_90) + call rotate_array_real_2d(array, 2, ar_180) + call rotate_array_real_2d(array, 3, ar_270) + + do n = 1, sz ; do m = 1, sz + sum(1) = symmetric_sum(array(1:n,1:m)) + sum(2) = symmetric_sum(ar_90(sz+1-m:sz,1:n)) + sum(3) = symmetric_sum(ar_180(sz+1-n:sz,sz+1-m:sz)) + sum(4) = symmetric_sum(ar_270(1:m,sz+1-n:sz)) + sum(5) = naive_sum_2d(array(1:n,1:m)) + abs_sum = naive_sum_2d(array(1:n,1:m), abs_val=.true.) + tol = 2.0 * abs_sum * epsilon(abs_sum) + if (abs(sum(1) - sum(5)) > tol) then + write(mesg,'(i0," x ",i0," symmetric vs naive sum, sum=",ES13.5," diff=",ES13.5)') & + n, m, sum(1), sum(5) - sum(1) + write(stdout,*) "Symmetric_sum_failure: "//trim(mesg) + write(stderr,*) "Symmetric_sum_failure: "//trim(mesg) + if (.not.fail) fail_message = mesg ! This is the first failed test. + fail = .true. + endif + do r = 2, 4 ; if (abs(sum(1) - sum(r)) > 0.0) then + write(mesg,'(i0," x ",i0," with ",i0," degree rotation, sum=",ES13.5," diff=",ES13.5)') & + n, m, 90*(r-1), sum(1), sum(r) - sum(1) + write(stdout,*) "Symmetric_sum_failure: "//trim(mesg) + write(stderr,*) "Symmetric_sum_failure: "//trim(mesg) + if (.not.fail) fail_message = mesg ! This is the first failed test. + fail = .true. + endif ; enddo + enddo ; enddo + + if (fail) then + write(stdout,*) "MOM_array_transform: One or more symmetric sum tests has failed." + write(stderr,*) "MOM_array_transform: One or more symmetric sum tests has failed." + else + if (verbose) write(stdout,*) ("MOM_array_transform: All symmetric sum tests have passed.") + endif + symmetric_sum_unit_tests = fail + +end function symmetric_sum_unit_tests + end module MOM_array_transform diff --git a/src/framework/MOM_checksums.F90 b/src/framework/MOM_checksums.F90 index 718a796802..123eeeb675 100644 --- a/src/framework/MOM_checksums.F90 +++ b/src/framework/MOM_checksums.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Routines to calculate checksums of various array and vector types module MOM_checksums -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_array_transform, only : rotate_array, rotate_array_pair, rotate_vector use MOM_array_transform, only : allocate_rotated_array use MOM_coms, only : PE_here, root_PE, num_PEs, sum_across_PEs @@ -11,16 +13,24 @@ module MOM_checksums use MOM_error_handler, only : MOM_error, FATAL, is_root_pe use MOM_file_parser, only : log_version, param_file_type use MOM_hor_index, only : hor_index_type, rotate_hor_index +use MOM_murmur_hash, only : murmur_hash use iso_fortran_env, only : error_unit, int32, int64 implicit none ; private -public :: chksum0, zchksum, rotated_field_chksum +public :: chksum0, zchksum, rotated_field_chksum, field_checksum public :: hchksum, Bchksum, uchksum, vchksum, qchksum, is_NaN, chksum public :: hchksum_pair, uvchksum, Bchksum_pair public :: MOM_checksums_init +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. +! The functions in this module work with variables with arbitrary units, in which case the +! arbitrary rescaled units are indicated with [A ~> a], while the unscaled units are just [a]. + !> Checksums a pair of arrays (2d or 3d) staggered at tracer points interface hchksum_pair module procedure chksum_pair_h_2d, chksum_pair_h_3d @@ -76,41 +86,70 @@ module MOM_checksums module procedure is_NaN_0d, is_NaN_1d, is_NaN_2d, is_NaN_3d end interface -!> Rotate and compute the checksum of a field +!> Compute the checksum on all elements of a field that may need to be rotated or unscaled. +!! This interface uses the field_chksum function that is used to verify file contents, which +!! may differ from the bitcount function used for other checksums in this module. interface rotated_field_chksum - module procedure rotated_field_chksum_real_0d - module procedure rotated_field_chksum_real_1d - module procedure rotated_field_chksum_real_2d - module procedure rotated_field_chksum_real_3d - module procedure rotated_field_chksum_real_4d + module procedure field_checksum_real_0d + module procedure field_checksum_real_1d + module procedure field_checksum_real_2d + module procedure field_checksum_real_3d + module procedure field_checksum_real_4d end interface rotated_field_chksum + +!> Compute the checksum on all elements of a field that may need to be rotated or unscaled. +!! This interface uses the field_chksum function that is used to verify file contents, which +!! may differ from the bitcount function used for other checksums in this module. +interface field_checksum + module procedure field_checksum_real_0d + module procedure field_checksum_real_1d + module procedure field_checksum_real_2d + module procedure field_checksum_real_3d + module procedure field_checksum_real_4d +end interface field_checksum + integer, parameter :: bc_modulus = 1000000000 !< Modulus of checksum bitcount integer, parameter :: default_shift=0 !< The default array shift logical :: calculateStatistics=.true. !< If true, report min, max and mean. logical :: writeChksums=.true. !< If true, report the bitcount checksum logical :: checkForNaNs=.true. !< If true, checks array for NaNs and cause - !! FATAL error is any are found + !! FATAL error if any are found +logical :: writeHash = .false. !< If true, report the murmur hash + !! NOTE: writeHash is currently disabled due to non-compliant diagnostics. contains !> Checksum a scalar field (consistent with array checksums) -subroutine chksum0(scalar, mesg, scale, logunit) - real, intent(in) :: scalar !< The array to be checksummed - character(len=*), intent(in) :: mesg !< An identifying message - real, optional, intent(in) :: scale !< A scaling factor for this array. +subroutine chksum0(scalar, mesg, scale, logunit, unscale) + real, intent(in) :: scalar !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. - real :: scaling !< Explicit rescaling factor + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real :: scaling !< Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit - real :: rs !< Rescaled scalar + real :: rs !< Rescaled scalar [a] integer :: bc !< Scalar bitcount if (checkForNaNs .and. is_NaN(scalar)) & call chksum_error(FATAL, 'NaN detected: '//trim(mesg)) - scaling = 1.0 ; if (present(scale)) scaling = scale - iounit = error_unit; if(present(logunit)) iounit = logunit + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + + iounit = error_unit ; if (present(logunit)) iounit = logunit if (calculateStatistics) then rs = scaling * scalar @@ -124,21 +163,34 @@ subroutine chksum0(scalar, mesg, scale, logunit) if (is_root_pe()) & call chk_sum_msg(" scalar:", bc, mesg, iounit) + if (writeHash .and. is_root_pe()) & + write(iounit, '(" scalar: hash=", z8, 1x, a)') & + murmur_hash(scaling * scalar), mesg end subroutine chksum0 !> Checksum a 1d array (typically a column). -subroutine zchksum(array, mesg, scale, logunit) - real, dimension(:), intent(in) :: array !< The array to be checksummed - character(len=*), intent(in) :: mesg !< An identifying message - real, optional, intent(in) :: scale !< A scaling factor for this array. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging +subroutine zchksum(array, mesg, scale, logunit, unscale) + real, dimension(:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. - real, allocatable, dimension(:) :: rescaled_array - real :: scaling + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, allocatable, dimension(:) :: rescaled_array ! The array with scaling undone [a] + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit integer :: k - real :: aMean, aMin, aMax + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] integer :: bc0 if (checkForNaNs) then @@ -146,14 +198,17 @@ subroutine zchksum(array, mesg, scale, logunit) call chksum_error(FATAL, 'NaN detected: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale - iounit = error_unit; if(present(logunit)) iounit = logunit + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + + iounit = error_unit ; if (present(logunit)) iounit = logunit if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate(rescaled_array(LBOUND(array,1):UBOUND(array,1)), source=0.0) do k=1, size(array, 1) - rescaled_array(k) = scale * array(k) + rescaled_array(k) = scaling * array(k) enddo call subStats(rescaled_array, aMean, aMin, aMax) @@ -171,25 +226,31 @@ subroutine zchksum(array, mesg, scale, logunit) bc0 = subchk(array, scaling) if (is_root_pe()) call chk_sum_msg(" column:", bc0, mesg, iounit) + if (writeHash .and. is_root_pe()) & + write(iounit, '(" column: hash=", z8, 1x, a)') & + murmur_hash(scaling * array), mesg + contains - integer function subchk(array, scale) - real, dimension(:), intent(in) :: array !< The array to be checksummed - real, intent(in) :: scale !< A scaling factor for this array. + integer function subchk(array, unscale) + real, dimension(:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] integer :: k, bc subchk = 0 do k=LBOUND(array, 1), UBOUND(array, 1) - bc = bitcount(abs(scale * array(k))) + bc = bitcount(abs(unscale * array(k))) subchk = subchk + bc enddo subchk=mod(subchk, bc_modulus) end function subchk subroutine subStats(array, aMean, aMin, aMax) - real, dimension(:), intent(in) :: array !< The array to be checksummed - real, intent(out) :: aMean !< Array mean - real, intent(out) :: aMin !< Array minimum - real, intent(out) :: aMax !< Array maximum + real, dimension(:), intent(in) :: array !< The array to be checksummed [a] + real, intent(out) :: aMean !< Array mean [a] + real, intent(out) :: aMin !< Array minimum [a] + real, intent(out) :: aMax !< Array maximum [a] integer :: k, n @@ -207,21 +268,28 @@ end subroutine zchksum !> Checksums on a pair of 2d arrays staggered at tracer points. subroutine chksum_pair_h_2d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, & - scale, logunit, scalar_pair) + scale, logunit, scalar_pair, unscale) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), target, intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayA !< The first array to be checksummed - real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayB !< The second array to be checksummed + real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayA !< The first array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayB !< The second array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for this array. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: scale !< A factor to convert these arrays back to unscaled + !! units for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe - !! a scalar, rather than vector + !! a scalar, rather than vector + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. logical :: vector_pair integer :: turns type(hor_index_type), pointer :: HI_in - real, dimension(:,:), pointer :: arrayA_in, arrayB_in + real, dimension(:,:), pointer :: arrayA_in, arrayB_in ! Rotated arrays [A ~> a] vector_pair = .true. if (present(scalar_pair)) vector_pair = .not. scalar_pair @@ -247,33 +315,40 @@ subroutine chksum_pair_h_2d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, & if (present(haloshift)) then call chksum_h_2d(arrayA_in, 'x '//mesg, HI_in, haloshift, omit_corners, & - scale=scale, logunit=logunit) + scale=scale, logunit=logunit, unscale=unscale) call chksum_h_2d(arrayB_in, 'y '//mesg, HI_in, haloshift, omit_corners, & - scale=scale, logunit=logunit) + scale=scale, logunit=logunit, unscale=unscale) else - call chksum_h_2d(arrayA_in, 'x '//mesg, HI_in, scale=scale, logunit=logunit) - call chksum_h_2d(arrayB_in, 'y '//mesg, HI_in, scale=scale, logunit=logunit) + call chksum_h_2d(arrayA_in, 'x '//mesg, HI_in, scale=scale, logunit=logunit, unscale=unscale) + call chksum_h_2d(arrayB_in, 'y '//mesg, HI_in, scale=scale, logunit=logunit, unscale=unscale) endif end subroutine chksum_pair_h_2d !> Checksums on a pair of 3d arrays staggered at tracer points. subroutine chksum_pair_h_3d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, & - scale, logunit, scalar_pair) + scale, logunit, scalar_pair, unscale) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), target, intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%jsd:, :), target, intent(in) :: arrayA !< The first array to be checksummed - real, dimension(HI%isd:,HI%jsd:, :), target, intent(in) :: arrayB !< The second array to be checksummed + real, dimension(HI%isd:,HI%jsd:, :), target, intent(in) :: arrayA !< The first array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + real, dimension(HI%isd:,HI%jsd:, :), target, intent(in) :: arrayB !< The second array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for this array. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging - - logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe - !! a scalar, rather than vector + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe + !! a scalar, rather than vector + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + ! Local variables logical :: vector_pair integer :: turns type(hor_index_type), pointer :: HI_in - real, dimension(:,:,:), pointer :: arrayA_in, arrayB_in + real, dimension(:,:,:), pointer :: arrayA_in, arrayB_in ! Rotated arrays [A ~> a] vector_pair = .true. if (present(scalar_pair)) vector_pair = .not. scalar_pair @@ -299,39 +374,51 @@ subroutine chksum_pair_h_3d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, & if (present(haloshift)) then call chksum_h_3d(arrayA_in, 'x '//mesg, HI_in, haloshift, omit_corners, & - scale=scale, logunit=logunit) + scale=scale, logunit=logunit, unscale=unscale) call chksum_h_3d(arrayB_in, 'y '//mesg, HI_in, haloshift, omit_corners, & - scale=scale, logunit=logunit) + scale=scale, logunit=logunit, unscale=unscale) else - call chksum_h_3d(arrayA_in, 'x '//mesg, HI_in, scale=scale, logunit=logunit) - call chksum_h_3d(arrayB_in, 'y '//mesg, HI_in, scale=scale, logunit=logunit) + call chksum_h_3d(arrayA_in, 'x '//mesg, HI_in, scale=scale, logunit=logunit, unscale=unscale) + call chksum_h_3d(arrayB_in, 'y '//mesg, HI_in, scale=scale, logunit=logunit, unscale=unscale) endif ! NOTE: automatic deallocation of array[AB]_in end subroutine chksum_pair_h_3d !> Checksums a 2d array staggered at tracer points. -subroutine chksum_h_2d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logunit) - type(hor_index_type), target, intent(in) :: HI_m !< Horizontal index bounds of the model grid - real, dimension(HI_m%isd:,HI_m%jsd:), target, intent(in) :: array_m !< Field array on the model grid - character(len=*), intent(in) :: mesg !< An identifying message +subroutine chksum_h_2d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logunit, unscale) + type(hor_index_type), target, intent(in) :: HI_m !< Horizontal index bounds of the model grid + real, dimension(HI_m%isd:,HI_m%jsd:), target, intent(in) :: array_m !< Field array on the model grid in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for this array. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. - real, pointer :: array(:,:) ! Field array on the input grid - real, allocatable, dimension(:,:) :: rescaled_array + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, pointer :: array(:,:) ! Field array on the input grid [A ~> a] + real, allocatable, dimension(:,:) :: rescaled_array ! The array with scaling undone [a] + real, allocatable :: hash_array(:,:) ! Subarray used to compute hash [a] type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid - real :: scaling + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit integer :: i, j - real :: aMean, aMin, aMax + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners integer :: turns ! Quarter turns from input to model grid + ! Rotate array to the input grid turns = HI_m%turns if (modulo(turns, 4) /= 0) then @@ -351,15 +438,18 @@ subroutine chksum_h_2d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logu ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale - iounit = error_unit; if(present(logunit)) iounit = logunit + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + + iounit = error_unit ; if (present(logunit)) iounit = logunit if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & LBOUND(array,2):UBOUND(array,2)), source=0.0 ) do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec - rescaled_array(i,j) = scale*array(i,j) + rescaled_array(i,j) = scaling*array(i,j) enddo ; enddo call subStats(HI, rescaled_array, aMean, aMin, aMax) deallocate(rescaled_array) @@ -389,40 +479,51 @@ subroutine chksum_h_2d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logu if (hshift==0) then if (is_root_pe()) call chk_sum_msg("h-point:", bc0, mesg, iounit) - return - endif + else + do_corners = .true. + if (present(omit_corners)) do_corners = .not. omit_corners + + if (do_corners) then + bcSW = subchk(array, HI, -hshift, -hshift, scaling) + bcSE = subchk(array, HI, hshift, -hshift, scaling) + bcNW = subchk(array, HI, -hshift, hshift, scaling) + bcNE = subchk(array, HI, hshift, hshift, scaling) - do_corners = .true. ; if (present(omit_corners)) do_corners = .not.omit_corners + if (is_root_pe()) & + call chk_sum_msg("h-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) + else + bcS = subchk(array, HI, 0, -hshift, scaling) + bcE = subchk(array, HI, hshift, 0, scaling) + bcW = subchk(array, HI, -hshift, 0, scaling) + bcN = subchk(array, HI, 0, hshift, scaling) - if (do_corners) then - bcSW = subchk(array, HI, -hshift, -hshift, scaling) - bcSE = subchk(array, HI, hshift, -hshift, scaling) - bcNW = subchk(array, HI, -hshift, hshift, scaling) - bcNE = subchk(array, HI, hshift, hshift, scaling) + if (is_root_pe()) & + call chk_sum_msg_NSEW("h-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) + endif + endif - if (is_root_pe()) & - call chk_sum_msg("h-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) - else - bcS = subchk(array, HI, 0, -hshift, scaling) - bcE = subchk(array, HI, hshift, 0, scaling) - bcW = subchk(array, HI, -hshift, 0, scaling) - bcN = subchk(array, HI, 0, hshift, scaling) + if (writeHash .and. is_root_pe()) then + allocate(hash_array(HI%isc:HI%iec, HI%jsc:HI%jec)) + hash_array(:,:) = scaling * array(HI%isc:HI%iec, HI%jsc:HI%jec) - if (is_root_pe()) & - call chk_sum_msg_NSEW("h-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) + write(iounit, '("h-point: hash=", z8, 1x, a)') & + murmur_hash(hash_array), mesg + deallocate(hash_array) endif contains - integer function subchk(array, HI, di, dj, scale) + integer function subchk(array, HI, di, dj, unscale) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%jsd:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%isd:,HI%jsd:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A scaling factor for this array. + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] integer :: i, j, bc subchk = 0 do j=HI%jsc+dj,HI%jec+dj ; do i=HI%isc+di,HI%iec+di - bc = bitcount(abs(scale*array(i,j))) + bc = bitcount(abs(unscale*array(i,j))) subchk = subchk + bc enddo ; enddo call sum_across_PEs(subchk) @@ -431,10 +532,10 @@ end function subchk subroutine subStats(HI, array, aMean, aMin, aMax) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%jsd:), intent(in) :: array !< The array to be checksummed - real, intent(out) :: aMean !< Array mean - real, intent(out) :: aMin !< Array minimum - real, intent(out) :: aMax !< Array maximum + real, dimension(HI%isd:,HI%jsd:), intent(in) :: array !< The array to be checksummed [a] + real, intent(out) :: aMean !< Array mean [a] + real, intent(out) :: aMin !< Array minimum [a] + real, intent(out) :: aMax !< Array maximum [a] integer :: i, j, n @@ -457,25 +558,32 @@ end subroutine chksum_h_2d !> Checksums on a pair of 2d arrays staggered at q-points. subroutine chksum_pair_B_2d(mesg, arrayA, arrayB, HI, haloshift, symmetric, & - omit_corners, scale, logunit, scalar_pair) + omit_corners, scale, logunit, scalar_pair, unscale) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), target, intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayA !< The first array to be checksummed - real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayB !< The second array to be checksummed + real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayA !< The first array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayB !< The second array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full !! symmetric computational domain. integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for this array. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe - !! a scalar, rather than vector + !! a scalar, rather than vector + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. logical :: sym logical :: vector_pair integer :: turns type(hor_index_type), pointer :: HI_in - real, dimension(:,:), pointer :: arrayA_in, arrayB_in + real, dimension(:,:), pointer :: arrayA_in, arrayB_in ! Rotated arrays [A ~> a] vector_pair = .true. if (present(scalar_pair)) vector_pair = .not. scalar_pair @@ -503,39 +611,45 @@ subroutine chksum_pair_B_2d(mesg, arrayA, arrayB, HI, haloshift, symmetric, & if (present(haloshift)) then call chksum_B_2d(arrayA_in, 'x '//mesg, HI_in, haloshift, symmetric=sym, & - omit_corners=omit_corners, scale=scale, logunit=logunit) + omit_corners=omit_corners, scale=scale, logunit=logunit, unscale=unscale) call chksum_B_2d(arrayB_in, 'y '//mesg, HI_in, haloshift, symmetric=sym, & - omit_corners=omit_corners, scale=scale, logunit=logunit) + omit_corners=omit_corners, scale=scale, logunit=logunit, unscale=unscale) else - call chksum_B_2d(arrayA_in, 'x '//mesg, HI_in, symmetric=sym, scale=scale, & - logunit=logunit) - call chksum_B_2d(arrayB_in, 'y '//mesg, HI_in, symmetric=sym, scale=scale, & - logunit=logunit) + call chksum_B_2d(arrayA_in, 'x '//mesg, HI_in, symmetric=sym, & + scale=scale, logunit=logunit, unscale=unscale) + call chksum_B_2d(arrayB_in, 'y '//mesg, HI_in, symmetric=sym, & + scale=scale, logunit=logunit, unscale=unscale) endif end subroutine chksum_pair_B_2d !> Checksums on a pair of 3d arrays staggered at q-points. subroutine chksum_pair_B_3d(mesg, arrayA, arrayB, HI, haloshift, symmetric, & - omit_corners, scale, logunit, scalar_pair) + omit_corners, scale, logunit, scalar_pair, unscale) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), target, intent(in) :: HI !< A horizontal index type - real, dimension(HI%IsdB:,HI%JsdB:, :), target, intent(in) :: arrayA !< The first array to be checksummed - real, dimension(HI%IsdB:,HI%JsdB:, :), target, intent(in) :: arrayB !< The second array to be checksummed + real, dimension(HI%IsdB:,HI%JsdB:, :), target, intent(in) :: arrayA !< The first array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + real, dimension(HI%IsdB:,HI%JsdB:, :), target, intent(in) :: arrayB !< The second array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for this array. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe - !! a scalar, rather than vector - - logical :: sym + !! a scalar, rather than vector + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + ! Local variables logical :: vector_pair integer :: turns type(hor_index_type), pointer :: HI_in - real, dimension(:,:,:), pointer :: arrayA_in, arrayB_in + real, dimension(:,:,:), pointer :: arrayA_in, arrayB_in ! Rotated arrays [A ~> a] vector_pair = .true. if (present(scalar_pair)) vector_pair = .not. scalar_pair @@ -561,38 +675,49 @@ subroutine chksum_pair_B_3d(mesg, arrayA, arrayB, HI, haloshift, symmetric, & if (present(haloshift)) then call chksum_B_3d(arrayA_in, 'x '//mesg, HI_in, haloshift, symmetric, & - omit_corners, scale=scale, logunit=logunit) + omit_corners, scale=scale, logunit=logunit, unscale=unscale) call chksum_B_3d(arrayB_in, 'y '//mesg, HI_in, haloshift, symmetric, & - omit_corners, scale=scale, logunit=logunit) + omit_corners, scale=scale, logunit=logunit, unscale=unscale) else - call chksum_B_3d(arrayA_in, 'x '//mesg, HI_in, symmetric=symmetric, scale=scale, & - logunit=logunit) - call chksum_B_3d(arrayB_in, 'y '//mesg, HI_in, symmetric=symmetric, scale=scale, & - logunit=logunit) + call chksum_B_3d(arrayA_in, 'x '//mesg, HI_in, symmetric=symmetric, & + scale=scale, logunit=logunit, unscale=unscale) + call chksum_B_3d(arrayB_in, 'y '//mesg, HI_in, symmetric=symmetric, & + scale=scale, logunit=logunit, unscale=unscale) endif end subroutine chksum_pair_B_3d !> Checksums a 2d array staggered at corner points. subroutine chksum_B_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & - scale, logunit) + scale, logunit, unscale) type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type real, dimension(HI_m%IsdB:,HI_m%JsdB:), & - target, intent(in) :: array_m !< The array to be checksummed - character(len=*), intent(in) :: mesg !< An identifying message + target, intent(in) :: array_m !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: symmetric !< If true, do the checksums on the !! full symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for this array. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. - real, pointer :: array(:,:) ! Field array on the input grid - real, allocatable, dimension(:,:) :: rescaled_array + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, pointer :: array(:,:) ! Field array on the input grid [A ~> a] + real, allocatable, dimension(:,:) :: rescaled_array ! The array with scaling undone [a] + real, allocatable :: hash_array(:,:) ! Subarray used to compute hash [a] type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid - real :: scaling + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit integer :: i, j, Is, Js - real :: aMean, aMin, aMax + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners, sym, sym_stats @@ -617,19 +742,22 @@ subroutine chksum_B_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale - iounit = error_unit; if(present(logunit)) iounit = logunit + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + + iounit = error_unit ; if (present(logunit)) iounit = logunit sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & LBOUND(array,2):UBOUND(array,2)), source=0.0 ) Is = HI%isc ; if (sym_stats) Is = HI%isc-1 Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 do J=Js,HI%JecB ; do I=Is,HI%IecB - rescaled_array(I,J) = scale*array(I,J) + rescaled_array(I,J) = scaling*array(I,J) enddo ; enddo call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) deallocate(rescaled_array) @@ -660,48 +788,59 @@ subroutine chksum_B_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, if ((hshift==0) .and. .not.sym) then if (is_root_pe()) call chk_sum_msg("B-point:", bc0, mesg, iounit) - return - endif - - do_corners = .true. ; if (present(omit_corners)) do_corners = .not.omit_corners - - if (do_corners) then - if (sym) then - bcSW = subchk(array, HI, -hshift-1, -hshift-1, scaling) - bcSE = subchk(array, HI, hshift, -hshift-1, scaling) - bcNW = subchk(array, HI, -hshift-1, hshift, scaling) + else + do_corners = .true. + if (present(omit_corners)) do_corners = .not. omit_corners + + if (do_corners) then + if (sym) then + bcSW = subchk(array, HI, -hshift-1, -hshift-1, scaling) + bcSE = subchk(array, HI, hshift, -hshift-1, scaling) + bcNW = subchk(array, HI, -hshift-1, hshift, scaling) + else + bcSW = subchk(array, HI, -hshift, -hshift, scaling) + bcSE = subchk(array, HI, hshift, -hshift, scaling) + bcNW = subchk(array, HI, -hshift, hshift, scaling) + endif + bcNE = subchk(array, HI, hshift, hshift, scaling) + + if (is_root_pe()) & + call chk_sum_msg("B-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) else - bcSW = subchk(array, HI, -hshift, -hshift, scaling) - bcSE = subchk(array, HI, hshift, -hshift, scaling) - bcNW = subchk(array, HI, -hshift, hshift, scaling) + bcS = subchk(array, HI, 0, -hshift, scaling) + bcE = subchk(array, HI, hshift, 0, scaling) + bcW = subchk(array, HI, -hshift, 0, scaling) + bcN = subchk(array, HI, 0, hshift, scaling) + + if (is_root_pe()) & + call chk_sum_msg_NSEW("B-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) endif - bcNE = subchk(array, HI, hshift, hshift, scaling) + endif - if (is_root_pe()) & - call chk_sum_msg("B-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) - else - bcS = subchk(array, HI, 0, -hshift, scaling) - bcE = subchk(array, HI, hshift, 0, scaling) - bcW = subchk(array, HI, -hshift, 0, scaling) - bcN = subchk(array, HI, 0, hshift, scaling) + if (writeHash .and. is_root_pe()) then + allocate(hash_array(HI%isc:HI%iec, HI%jsc:HI%jec)) + hash_array(:,:) = scaling * array(HI%isc:HI%iec, HI%jsc:HI%jec) - if (is_root_pe()) & - call chk_sum_msg_NSEW("B-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) + write(iounit, '("B-point: hash=", z8, 1x, a)') & + murmur_hash(hash_array), mesg + deallocate(hash_array) endif contains - integer function subchk(array, HI, di, dj, scale) + integer function subchk(array, HI, di, dj, unscale) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%IsdB:,HI%JsdB:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%IsdB:,HI%JsdB:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A scaling factor for this array. + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] integer :: i, j, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do J=HI%jsc+dj,HI%jec+dj ; do I=HI%isc+di,HI%iec+di - bc = bitcount(abs(scale*array(I,J))) + bc = bitcount(abs(unscale*array(I,J))) subchk = subchk + bc enddo ; enddo call sum_across_PEs(subchk) @@ -710,12 +849,12 @@ end function subchk subroutine subStats(HI, array, sym_stats, aMean, aMin, aMax) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%IsdB:,HI%JsdB:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%IsdB:,HI%JsdB:), intent(in) :: array !< The array to be checksummed [a] logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the !! full symmetric computational domain. - real, intent(out) :: aMean !< Array mean - real, intent(out) :: aMin !< Array minimum - real, intent(out) :: aMax !< Array maximum + real, intent(out) :: aMean !< Array mean [a] + real, intent(out) :: aMin !< Array minimum [a] + real, intent(out) :: aMax !< Array maximum [a] integer :: i, j, n, IsB, JsB @@ -740,23 +879,31 @@ end subroutine chksum_B_2d !> Checksums a pair of 2d velocity arrays staggered at C-grid locations subroutine chksum_uv_2d(mesg, arrayU, arrayV, HI, haloshift, symmetric, & - omit_corners, scale, logunit, scalar_pair) + omit_corners, scale, logunit, scalar_pair, unscale) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), target, intent(in) :: HI !< A horizontal index type - real, dimension(HI%IsdB:,HI%jsd:), target, intent(in) :: arrayU !< The u-component array to be checksummed - real, dimension(HI%isd:,HI%JsdB:), target, intent(in) :: arrayV !< The v-component array to be checksummed + real, dimension(HI%IsdB:,HI%jsd:), target, intent(in) :: arrayU !< The u-component array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + real, dimension(HI%isd:,HI%JsdB:), target, intent(in) :: arrayV !< The v-component array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for these arrays. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: scale !< A factor to convert these arrays back to unscaled + !! units for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe a - !! a scalar, rather than vector + !! a scalar, rather than vector + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + ! Local variables logical :: vector_pair integer :: turns type(hor_index_type), pointer :: HI_in - real, dimension(:,:), pointer :: arrayU_in, arrayV_in + real, dimension(:,:), pointer :: arrayU_in, arrayV_in ! Rotated arrays [A ~> a] vector_pair = .true. if (present(scalar_pair)) vector_pair = .not. scalar_pair @@ -782,36 +929,44 @@ subroutine chksum_uv_2d(mesg, arrayU, arrayV, HI, haloshift, symmetric, & if (present(haloshift)) then call chksum_u_2d(arrayU_in, 'u '//mesg, HI_in, haloshift, symmetric, & - omit_corners, scale=scale, logunit=logunit) + omit_corners, scale=scale, logunit=logunit, unscale=unscale) call chksum_v_2d(arrayV_in, 'v '//mesg, HI_in, haloshift, symmetric, & - omit_corners, scale=scale, logunit=logunit) + omit_corners, scale=scale, logunit=logunit, unscale=unscale) else call chksum_u_2d(arrayU_in, 'u '//mesg, HI_in, symmetric=symmetric, & - scale=scale, logunit=logunit) + scale=scale, logunit=logunit, unscale=unscale) call chksum_v_2d(arrayV_in, 'v '//mesg, HI_in, symmetric=symmetric, & - scale=scale, logunit=logunit) + scale=scale, logunit=logunit, unscale=unscale) endif end subroutine chksum_uv_2d !> Checksums a pair of 3d velocity arrays staggered at C-grid locations subroutine chksum_uv_3d(mesg, arrayU, arrayV, HI, haloshift, symmetric, & - omit_corners, scale, logunit, scalar_pair) + omit_corners, scale, logunit, scalar_pair, unscale) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), target, intent(in) :: HI !< A horizontal index type - real, dimension(HI%IsdB:,HI%jsd:,:), target, intent(in) :: arrayU !< The u-component array to be checksummed - real, dimension(HI%isd:,HI%JsdB:,:), target, intent(in) :: arrayV !< The v-component array to be checksummed + real, dimension(HI%IsdB:,HI%jsd:,:), target, intent(in) :: arrayU !< The u-component array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + real, dimension(HI%isd:,HI%JsdB:,:), target, intent(in) :: arrayV !< The v-component array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for these arrays. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: scale !< A factor to convert these arrays back to unscaled + !! units for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe a !! a scalar, rather than vector + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + ! Local variables logical :: vector_pair integer :: turns type(hor_index_type), pointer :: HI_in - real, dimension(:,:,:), pointer :: arrayU_in, arrayV_in + real, dimension(:,:,:), pointer :: arrayU_in, arrayV_in ! Rotated arrays [A ~> a] vector_pair = .true. if (present(scalar_pair)) vector_pair = .not. scalar_pair @@ -837,37 +992,48 @@ subroutine chksum_uv_3d(mesg, arrayU, arrayV, HI, haloshift, symmetric, & if (present(haloshift)) then call chksum_u_3d(arrayU_in, 'u '//mesg, HI_in, haloshift, symmetric, & - omit_corners, scale=scale, logunit=logunit) + omit_corners, scale=scale, logunit=logunit, unscale=unscale) call chksum_v_3d(arrayV_in, 'v '//mesg, HI_in, haloshift, symmetric, & - omit_corners, scale=scale, logunit=logunit) + omit_corners, scale=scale, logunit=logunit, unscale=unscale) else call chksum_u_3d(arrayU_in, 'u '//mesg, HI_in, symmetric=symmetric, & - scale=scale, logunit=logunit) + scale=scale, logunit=logunit, unscale=unscale) call chksum_v_3d(arrayV_in, 'v '//mesg, HI_in, symmetric=symmetric, & - scale=scale, logunit=logunit) + scale=scale, logunit=logunit, unscale=unscale) endif end subroutine chksum_uv_3d !> Checksums a 2d array staggered at C-grid u points. subroutine chksum_u_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & - scale, logunit) - type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type - real, dimension(HI_m%IsdB:,HI_m%jsd:), target, intent(in) :: array_m !< The array to be checksummed - character(len=*), intent(in) :: mesg !< An identifying message + scale, logunit, unscale) + type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type + real, dimension(HI_m%IsdB:,HI_m%jsd:), target, intent(in) :: array_m !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for this array. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. - real, pointer :: array(:,:) ! Field array on the input grid - real, allocatable, dimension(:,:) :: rescaled_array + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, pointer :: array(:,:) ! Field array on the input grid [A ~> a] + real, allocatable, dimension(:,:) :: rescaled_array ! The array with scaling undone [a] + real, allocatable :: hash_array(:,:) ! Subarray used to compute hash [a] type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid - real :: scaling + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit integer :: i, j, Is - real :: aMean, aMin, aMax + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners, sym, sym_stats @@ -882,7 +1048,8 @@ subroutine chksum_u_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! Arrays originating from v-points must be handled by vchksum allocate(array(HI%isd:HI%ied, HI%JsdB:HI%JedB)) call rotate_array(array_m, -turns, array) - call vchksum(array, mesg, HI, haloshift, symmetric, omit_corners, scale, logunit) + call vchksum(array, mesg, HI, haloshift, symmetric, omit_corners, & + scale=scale, logunit=logunit, unscale=unscale) return else allocate(array(HI%IsdB:HI%IedB, HI%jsd:HI%jed)) @@ -900,18 +1067,21 @@ subroutine chksum_u_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale - iounit = error_unit; if(present(logunit)) iounit = logunit + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + + iounit = error_unit ; if (present(logunit)) iounit = logunit sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & LBOUND(array,2):UBOUND(array,2)), source=0.0 ) Is = HI%isc ; if (sym_stats) Is = HI%isc-1 do j=HI%jsc,HI%jec ; do I=Is,HI%IecB - rescaled_array(I,j) = scale*array(I,j) + rescaled_array(I,j) = scaling*array(I,j) enddo ; enddo call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) deallocate(rescaled_array) @@ -943,54 +1113,65 @@ subroutine chksum_u_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, if ((hshift==0) .and. .not.sym) then if (is_root_pe()) call chk_sum_msg("u-point:", bc0, mesg, iounit) - return - endif + else + do_corners = .true. + if (present(omit_corners)) do_corners = .not. omit_corners - do_corners = .true. ; if (present(omit_corners)) do_corners = .not.omit_corners + if (hshift==0) then + bcW = subchk(array, HI, -hshift-1, 0, scaling) + if (is_root_pe()) call chk_sum_msg_W("u-point:", bc0, bcW, mesg, iounit) + elseif (do_corners) then + if (sym) then + bcSW = subchk(array, HI, -hshift-1, -hshift, scaling) + bcNW = subchk(array, HI, -hshift-1, hshift, scaling) + else + bcSW = subchk(array, HI, -hshift, -hshift, scaling) + bcNW = subchk(array, HI, -hshift, hshift, scaling) + endif + bcSE = subchk(array, HI, hshift, -hshift, scaling) + bcNE = subchk(array, HI, hshift, hshift, scaling) - if (hshift==0) then - bcW = subchk(array, HI, -hshift-1, 0, scaling) - if (is_root_pe()) call chk_sum_msg_W("u-point:", bc0, bcW, mesg, iounit) - elseif (do_corners) then - if (sym) then - bcSW = subchk(array, HI, -hshift-1, -hshift, scaling) - bcNW = subchk(array, HI, -hshift-1, hshift, scaling) + if (is_root_pe()) & + call chk_sum_msg("u-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) else - bcSW = subchk(array, HI, -hshift, -hshift, scaling) - bcNW = subchk(array, HI, -hshift, hshift, scaling) + bcS = subchk(array, HI, 0, -hshift, scaling) + bcE = subchk(array, HI, hshift, 0, scaling) + if (sym) then + bcW = subchk(array, HI, -hshift-1, 0, scaling) + else + bcW = subchk(array, HI, -hshift, 0, scaling) + endif + bcN = subchk(array, HI, 0, hshift, scaling) + + if (is_root_pe()) & + call chk_sum_msg_NSEW("u-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) endif - bcSE = subchk(array, HI, hshift, -hshift, scaling) - bcNE = subchk(array, HI, hshift, hshift, scaling) + endif - if (is_root_pe()) & - call chk_sum_msg("u-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) - else - bcS = subchk(array, HI, 0, -hshift, scaling) - bcE = subchk(array, HI, hshift, 0, scaling) - if (sym) then - bcW = subchk(array, HI, -hshift-1, 0, scaling) - else - bcW = subchk(array, HI, -hshift, 0, scaling) - endif - bcN = subchk(array, HI, 0, hshift, scaling) + if (writeHash .and. is_root_pe()) then + allocate(hash_array(HI%isc:HI%iec, HI%jsc:HI%jec)) + hash_array(:,:) = scaling * array(HI%isc:HI%iec, HI%jsc:HI%jec) - if (is_root_pe()) & - call chk_sum_msg_NSEW("u-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) + write(iounit, '("u-point: hash=", z8, 1x, a)') & + murmur_hash(hash_array), mesg + deallocate(hash_array) endif contains - integer function subchk(array, HI, di, dj, scale) + integer function subchk(array, HI, di, dj, unscale) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A scaling factor for this array. + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] integer :: i, j, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do j=HI%jsc+dj,HI%jec+dj ; do I=HI%isc+di,HI%iec+di - bc = bitcount(abs(scale*array(I,j))) + bc = bitcount(abs(unscale*array(I,j))) subchk = subchk + bc enddo ; enddo call sum_across_PEs(subchk) @@ -999,12 +1180,12 @@ end function subchk subroutine subStats(HI, array, sym_stats, aMean, aMin, aMax) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: array !< The array to be checksummed [a] logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the !! full symmetric computational domain. - real, intent(out) :: aMean !< Array mean - real, intent(out) :: aMin !< Array minimum - real, intent(out) :: aMax !< Array maximum + real, intent(out) :: aMean !< Array mean [a] + real, intent(out) :: aMin !< Array minimum [a] + real, intent(out) :: aMax !< Array maximum [a] integer :: i, j, n, IsB @@ -1028,24 +1209,35 @@ end subroutine chksum_u_2d !> Checksums a 2d array staggered at C-grid v points. subroutine chksum_v_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & - scale, logunit) + scale, logunit, unscale) type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type - real, dimension(HI_m%isd:,HI_m%JsdB:), target, intent(in) :: array_m !< The array to be checksummed - character(len=*), intent(in) :: mesg !< An identifying message + real, dimension(HI_m%isd:,HI_m%JsdB:), target, intent(in) :: array_m !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for this array. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. - real, pointer :: array(:,:) ! Field array on the input grid - real, allocatable, dimension(:,:) :: rescaled_array + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, pointer :: array(:,:) ! Field array on the input grid [A ~> a] + real, allocatable, dimension(:,:) :: rescaled_array ! The array with scaling undone [a] + real, allocatable :: hash_array(:,:) ! Subarray used to compute hash [a] type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid - real :: scaling + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit integer :: i, j, Js - real :: aMean, aMin, aMax + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners, sym, sym_stats @@ -1060,7 +1252,8 @@ subroutine chksum_v_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! Arrays originating from u-points must be handled by uchksum allocate(array(HI%IsdB:HI%IedB, HI%jsd:HI%jed)) call rotate_array(array_m, -turns, array) - call uchksum(array, mesg, HI, haloshift, symmetric, omit_corners, scale, logunit) + call uchksum(array, mesg, HI, haloshift, symmetric, omit_corners, & + scale=scale, logunit=logunit, unscale=unscale) return else allocate(array(HI%isd:HI%ied, HI%JsdB:HI%JedB)) @@ -1078,18 +1271,21 @@ subroutine chksum_v_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale - iounit = error_unit; if(present(logunit)) iounit = logunit + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + + iounit = error_unit ; if (present(logunit)) iounit = logunit sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & LBOUND(array,2):UBOUND(array,2)), source=0.0 ) Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 do J=Js,HI%JecB ; do i=HI%isc,HI%iec - rescaled_array(i,J) = scale*array(i,J) + rescaled_array(i,J) = scaling*array(i,J) enddo ; enddo call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) deallocate(rescaled_array) @@ -1121,54 +1317,65 @@ subroutine chksum_v_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, if ((hshift==0) .and. .not.sym) then if (is_root_pe()) call chk_sum_msg("v-point:", bc0, mesg, iounit) - return - endif + else + do_corners = .true. + if (present(omit_corners)) do_corners = .not. omit_corners - do_corners = .true. ; if (present(omit_corners)) do_corners = .not.omit_corners + if (hshift==0) then + bcS = subchk(array, HI, 0, -hshift-1, scaling) + if (is_root_pe()) call chk_sum_msg_S("v-point:", bc0, bcS, mesg, iounit) + elseif (do_corners) then + if (sym) then + bcSW = subchk(array, HI, -hshift, -hshift-1, scaling) + bcSE = subchk(array, HI, hshift, -hshift-1, scaling) + else + bcSW = subchk(array, HI, -hshift, -hshift, scaling) + bcSE = subchk(array, HI, hshift, -hshift, scaling) + endif + bcNW = subchk(array, HI, -hshift, hshift, scaling) + bcNE = subchk(array, HI, hshift, hshift, scaling) - if (hshift==0) then - bcS = subchk(array, HI, 0, -hshift-1, scaling) - if (is_root_pe()) call chk_sum_msg_S("v-point:", bc0, bcS, mesg, iounit) - elseif (do_corners) then - if (sym) then - bcSW = subchk(array, HI, -hshift, -hshift-1, scaling) - bcSE = subchk(array, HI, hshift, -hshift-1, scaling) + if (is_root_pe()) & + call chk_sum_msg("v-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) else - bcSW = subchk(array, HI, -hshift, -hshift, scaling) - bcSE = subchk(array, HI, hshift, -hshift, scaling) - endif - bcNW = subchk(array, HI, -hshift, hshift, scaling) - bcNE = subchk(array, HI, hshift, hshift, scaling) + if (sym) then + bcS = subchk(array, HI, 0, -hshift-1, scaling) + else + bcS = subchk(array, HI, 0, -hshift, scaling) + endif + bcE = subchk(array, HI, hshift, 0, scaling) + bcW = subchk(array, HI, -hshift, 0, scaling) + bcN = subchk(array, HI, 0, hshift, scaling) - if (is_root_pe()) & - call chk_sum_msg("v-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) - else - if (sym) then - bcS = subchk(array, HI, 0, -hshift-1, scaling) - else - bcS = subchk(array, HI, 0, -hshift, scaling) + if (is_root_pe()) & + call chk_sum_msg_NSEW("v-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) endif - bcE = subchk(array, HI, hshift, 0, scaling) - bcW = subchk(array, HI, -hshift, 0, scaling) - bcN = subchk(array, HI, 0, hshift, scaling) + endif - if (is_root_pe()) & - call chk_sum_msg_NSEW("v-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) + if (writeHash .and. is_root_pe()) then + allocate(hash_array(HI%isc:HI%iec, HI%jsc:HI%jec)) + hash_array(:,:) = scaling * array(HI%isc:HI%iec, HI%jsc:HI%jec) + + write(iounit, '("v-point: hash=", z8, 1x, a)') & + murmur_hash(hash_array), mesg + deallocate(hash_array) endif contains - integer function subchk(array, HI, di, dj, scale) + integer function subchk(array, HI, di, dj, unscale) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%JsdB:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%isd:,HI%JsdB:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A scaling factor for this array. + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] integer :: i, j, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do J=HI%jsc+dj,HI%jec+dj ; do i=HI%isc+di,HI%iec+di - bc = bitcount(abs(scale*array(i,J))) + bc = bitcount(abs(unscale*array(i,J))) subchk = subchk + bc enddo ; enddo call sum_across_PEs(subchk) @@ -1177,12 +1384,12 @@ end function subchk subroutine subStats(HI, array, sym_stats, aMean, aMin, aMax) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%JsdB:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%isd:,HI%JsdB:), intent(in) :: array !< The array to be checksummed [a] logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the !! full symmetric computational domain. - real, intent(out) :: aMean !< Array mean - real, intent(out) :: aMin !< Array minimum - real, intent(out) :: aMax !< Array maximum + real, intent(out) :: aMean !< Array mean [a] + real, intent(out) :: aMin !< Array minimum [a] + real, intent(out) :: aMax !< Array maximum [a] integer :: i, j, n, JsB @@ -1205,22 +1412,33 @@ end subroutine subStats end subroutine chksum_v_2d !> Checksums a 3d array staggered at tracer points. -subroutine chksum_h_3d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logunit) +subroutine chksum_h_3d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logunit, unscale) type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type - real, dimension(HI_m%isd:,HI_m%jsd:,:), target, intent(in) :: array_m !< The array to be checksummed - character(len=*), intent(in) :: mesg !< An identifying message + real, dimension(HI_m%isd:,HI_m%jsd:,:), target, intent(in) :: array_m !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for this array. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. - real, pointer :: array(:,:,:) ! Field array on the input grid - real, allocatable, dimension(:,:,:) :: rescaled_array + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, pointer :: array(:,:,:) ! Field array on the input grid [A ~> a] + real, allocatable, dimension(:,:,:) :: rescaled_array ! The array with scaling undone [a] + real, allocatable :: hash_array(:,:,:) ! Subarray used to compute hash [a] type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid - real :: scaling + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit integer :: i, j, k - real :: aMean, aMin, aMax + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners @@ -1245,16 +1463,19 @@ subroutine chksum_h_3d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logu ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale - iounit = error_unit; if(present(logunit)) iounit = logunit + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + + iounit = error_unit ; if (present(logunit)) iounit = logunit if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & LBOUND(array,2):UBOUND(array,2), & LBOUND(array,3):UBOUND(array,3)), source=0.0 ) do k=1,size(array,3) ; do j=HI%jsc,HI%jec ; do i=HI%isc,HI%iec - rescaled_array(i,j,k) = scale*array(i,j,k) + rescaled_array(i,j,k) = scaling*array(i,j,k) enddo ; enddo ; enddo call subStats(HI, rescaled_array, aMean, aMin, aMax) @@ -1285,41 +1506,52 @@ subroutine chksum_h_3d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logu if (hshift==0) then if (is_root_pe()) call chk_sum_msg("h-point:", bc0, mesg, iounit) - return - endif + else + do_corners = .true. + if (present(omit_corners)) do_corners = .not. omit_corners + + if (do_corners) then + bcSW = subchk(array, HI, -hshift, -hshift, scaling) + bcSE = subchk(array, HI, hshift, -hshift, scaling) + bcNW = subchk(array, HI, -hshift, hshift, scaling) + bcNE = subchk(array, HI, hshift, hshift, scaling) - do_corners = .true. ; if (present(omit_corners)) do_corners = .not.omit_corners + if (is_root_pe()) & + call chk_sum_msg("h-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) + else + bcS = subchk(array, HI, 0, -hshift, scaling) + bcE = subchk(array, HI, hshift, 0, scaling) + bcW = subchk(array, HI, -hshift, 0, scaling) + bcN = subchk(array, HI, 0, hshift, scaling) - if (do_corners) then - bcSW = subchk(array, HI, -hshift, -hshift, scaling) - bcSE = subchk(array, HI, hshift, -hshift, scaling) - bcNW = subchk(array, HI, -hshift, hshift, scaling) - bcNE = subchk(array, HI, hshift, hshift, scaling) + if (is_root_pe()) & + call chk_sum_msg_NSEW("h-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) + endif + endif - if (is_root_pe()) & - call chk_sum_msg("h-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) - else - bcS = subchk(array, HI, 0, -hshift, scaling) - bcE = subchk(array, HI, hshift, 0, scaling) - bcW = subchk(array, HI, -hshift, 0, scaling) - bcN = subchk(array, HI, 0, hshift, scaling) + if (writeHash .and. is_root_pe()) then + allocate(hash_array(HI%isc:HI%iec, HI%jsc:HI%jec, size(array, 3))) + hash_array(:,:,:) = scaling * array(HI%isc:HI%iec, HI%jsc:HI%jec, :) - if (is_root_pe()) & - call chk_sum_msg_NSEW("h-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) + write(iounit, '("h-point: hash=", z8, 1x, a)') & + murmur_hash(hash_array), mesg + deallocate(hash_array) endif contains - integer function subchk(array, HI, di, dj, scale) + integer function subchk(array, HI, di, dj, unscale) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A scaling factor for this array. + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] integer :: i, j, k, bc subchk = 0 do k=LBOUND(array,3),UBOUND(array,3) ; do j=HI%jsc+dj,HI%jec+dj ; do i=HI%isc+di,HI%iec+di - bc = bitcount(abs(scale*array(i,j,k))) + bc = bitcount(abs(unscale*array(i,j,k))) subchk = subchk + bc enddo ; enddo ; enddo call sum_across_PEs(subchk) @@ -1328,10 +1560,10 @@ end function subchk subroutine subStats(HI, array, aMean, aMin, aMax) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed - real, intent(out) :: aMean !< Array mean - real, intent(out) :: aMin !< Array minimum - real, intent(out) :: aMax !< Array maximum + real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed [a] + real, intent(out) :: aMean !< Array mean [a] + real, intent(out) :: aMin !< Array minimum [a] + real, intent(out) :: aMax !< Array maximum [a] integer :: i, j, k, n @@ -1354,24 +1586,35 @@ end subroutine chksum_h_3d !> Checksums a 3d array staggered at corner points. subroutine chksum_B_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & - scale, logunit) + scale, logunit, unscale) type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type - real, dimension(HI_m%IsdB:,HI_m%JsdB:,:), target, intent(in) :: array_m !< The array to be checksummed - character(len=*), intent(in) :: mesg !< An identifying message + real, dimension(HI_m%IsdB:,HI_m%JsdB:,:), target, intent(in) :: array_m !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for this array. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. - real, pointer :: array(:,:,:) ! Field array on the input grid - real, allocatable, dimension(:,:,:) :: rescaled_array + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, pointer :: array(:,:,:) ! Field array on the input grid [A ~> a] + real, allocatable, dimension(:,:,:) :: rescaled_array ! The array with scaling undone [a] + real, allocatable :: hash_array(:,:,:) ! Subarray used to compute hash [a] type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid - real :: scaling + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit integer :: i, j, k, Is, Js - real :: aMean, aMin, aMax + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners, sym, sym_stats @@ -1396,20 +1639,23 @@ subroutine chksum_B_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale - iounit = error_unit; if(present(logunit)) iounit = logunit + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + + iounit = error_unit ; if (present(logunit)) iounit = logunit sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & LBOUND(array,2):UBOUND(array,2), & LBOUND(array,3):UBOUND(array,3)), source=0.0 ) Is = HI%isc ; if (sym_stats) Is = HI%isc-1 Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 do k=1,size(array,3) ; do J=Js,HI%JecB ; do I=Is,HI%IecB - rescaled_array(I,J,k) = scale*array(I,J,k) + rescaled_array(I,J,k) = scaling*array(I,J,k) enddo ; enddo ; enddo call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) deallocate(rescaled_array) @@ -1441,53 +1687,64 @@ subroutine chksum_B_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, if ((hshift==0) .and. .not.sym) then if (is_root_pe()) call chk_sum_msg("B-point:", bc0, mesg, iounit) - return - endif - - do_corners = .true. ; if (present(omit_corners)) do_corners = .not.omit_corners - - if (do_corners) then - if (sym) then - bcSW = subchk(array, HI, -hshift-1, -hshift-1, scaling) - bcSE = subchk(array, HI, hshift, -hshift-1, scaling) - bcNW = subchk(array, HI, -hshift-1, hshift, scaling) - else - bcSW = subchk(array, HI, -hshift-1, -hshift-1, scaling) - bcSE = subchk(array, HI, hshift, -hshift-1, scaling) - bcNW = subchk(array, HI, -hshift-1, hshift, scaling) - endif - bcNE = subchk(array, HI, hshift, hshift, scaling) - - if (is_root_pe()) & - call chk_sum_msg("B-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) else - if (sym) then - bcS = subchk(array, HI, 0, -hshift-1, scaling) - bcW = subchk(array, HI, -hshift-1, 0, scaling) + do_corners = .true. + if (present(omit_corners)) do_corners = .not. omit_corners + + if (do_corners) then + if (sym) then + bcSW = subchk(array, HI, -hshift-1, -hshift-1, scaling) + bcSE = subchk(array, HI, hshift, -hshift-1, scaling) + bcNW = subchk(array, HI, -hshift-1, hshift, scaling) + else + bcSW = subchk(array, HI, -hshift-1, -hshift-1, scaling) + bcSE = subchk(array, HI, hshift, -hshift-1, scaling) + bcNW = subchk(array, HI, -hshift-1, hshift, scaling) + endif + bcNE = subchk(array, HI, hshift, hshift, scaling) + + if (is_root_pe()) & + call chk_sum_msg("B-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) else - bcS = subchk(array, HI, 0, -hshift, scaling) - bcW = subchk(array, HI, -hshift, 0, scaling) + if (sym) then + bcS = subchk(array, HI, 0, -hshift-1, scaling) + bcW = subchk(array, HI, -hshift-1, 0, scaling) + else + bcS = subchk(array, HI, 0, -hshift, scaling) + bcW = subchk(array, HI, -hshift, 0, scaling) + endif + bcE = subchk(array, HI, hshift, 0, scaling) + bcN = subchk(array, HI, 0, hshift, scaling) + + if (is_root_pe()) & + call chk_sum_msg_NSEW("B-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) endif - bcE = subchk(array, HI, hshift, 0, scaling) - bcN = subchk(array, HI, 0, hshift, scaling) + endif - if (is_root_pe()) & - call chk_sum_msg_NSEW("B-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) + if (writeHash .and. is_root_pe()) then + allocate(hash_array(HI%isc:HI%iec, HI%jsc:HI%jec, size(array, 3))) + hash_array(:,:,:) = scaling * array(HI%isc:HI%iec, HI%jsc:HI%jec, :) + + write(iounit, '("B-point: hash=", z8, 1x, a)') & + murmur_hash(hash_array), mesg + deallocate(hash_array) endif contains - integer function subchk(array, HI, di, dj, scale) + integer function subchk(array, HI, di, dj, unscale) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%IsdB:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%IsdB:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A scaling factor for this array. + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] integer :: i, j, k, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do k=LBOUND(array,3),UBOUND(array,3) ; do J=HI%jsc+dj,HI%jec+dj ; do I=HI%isc+di,HI%iec+di - bc = bitcount(abs(scale*array(I,J,k))) + bc = bitcount(abs(unscale*array(I,J,k))) subchk = subchk + bc enddo ; enddo ; enddo call sum_across_PEs(subchk) @@ -1496,12 +1753,12 @@ end function subchk subroutine subStats(HI, array, sym_stats, aMean, aMin, aMax) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%IsdB:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%IsdB:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed [a] logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the !! full symmetric computational domain. - real, intent(out) :: aMean !< Array mean - real, intent(out) :: aMin !< Array minimum - real, intent(out) :: aMax !< Array maximum + real, intent(out) :: aMean !< Array mean [a] + real, intent(out) :: aMin !< Array minimum [a] + real, intent(out) :: aMax !< Array maximum [a] integer :: i, j, k, n, IsB, JsB @@ -1525,24 +1782,35 @@ end subroutine chksum_B_3d !> Checksums a 3d array staggered at C-grid u points. subroutine chksum_u_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & - scale, logunit) + scale, logunit, unscale) type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type - real, dimension(HI_m%isdB:,HI_m%Jsd:,:), target, intent(in) :: array_m !< The array to be checksummed - character(len=*), intent(in) :: mesg !< An identifying message + real, dimension(HI_m%isdB:,HI_m%Jsd:,:), target, intent(in) :: array_m !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for this array. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. - real, pointer :: array(:,:,:) ! Field array on the input grid - real, allocatable, dimension(:,:,:) :: rescaled_array + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, pointer :: array(:,:,:) ! Field array on the input grid [A ~> a] + real, allocatable, dimension(:,:,:) :: rescaled_array ! The array with scaling undone [a] + real, allocatable :: hash_array(:,:,:) ! Subarray used to compute hash [a] type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid - real :: scaling + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit integer :: i, j, k, Is - real :: aMean, aMin, aMax + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners, sym, sym_stats @@ -1557,7 +1825,8 @@ subroutine chksum_u_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! Arrays originating from v-points must be handled by vchksum allocate(array(HI%isd:HI%ied, HI%JsdB:HI%JedB, size(array_m, 3))) call rotate_array(array_m, -turns, array) - call vchksum(array, mesg, HI, haloshift, symmetric, omit_corners, scale, logunit) + call vchksum(array, mesg, HI, haloshift, symmetric, omit_corners, & + scale=scale, logunit=logunit, unscale=unscale) return else allocate(array(HI%IsdB:HI%IedB, HI%jsd:HI%jed, size(array_m, 3))) @@ -1575,19 +1844,22 @@ subroutine chksum_u_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale - iounit = error_unit; if(present(logunit)) iounit = logunit + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + + iounit = error_unit ; if (present(logunit)) iounit = logunit sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & LBOUND(array,2):UBOUND(array,2), & LBOUND(array,3):UBOUND(array,3)), source=0.0 ) Is = HI%isc ; if (sym_stats) Is = HI%isc-1 do k=1,size(array,3) ; do j=HI%jsc,HI%jec ; do I=Is,HI%IecB - rescaled_array(I,j,k) = scale*array(I,j,k) + rescaled_array(I,j,k) = scaling*array(I,j,k) enddo ; enddo ; enddo call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) deallocate(rescaled_array) @@ -1618,54 +1890,65 @@ subroutine chksum_u_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, if ((hshift==0) .and. .not.sym) then if (is_root_pe()) call chk_sum_msg("u-point:", bc0, mesg, iounit) - return - endif + else + do_corners = .true. + if (present(omit_corners)) do_corners = .not. omit_corners - do_corners = .true. ; if (present(omit_corners)) do_corners = .not.omit_corners + if (hshift==0) then + bcW = subchk(array, HI, -hshift-1, 0, scaling) + if (is_root_pe()) call chk_sum_msg_W("u-point:", bc0, bcW, mesg, iounit) + elseif (do_corners) then + if (sym) then + bcSW = subchk(array, HI, -hshift-1, -hshift, scaling) + bcNW = subchk(array, HI, -hshift-1, hshift, scaling) + else + bcSW = subchk(array, HI, -hshift, -hshift, scaling) + bcNW = subchk(array, HI, -hshift, hshift, scaling) + endif + bcSE = subchk(array, HI, hshift, -hshift, scaling) + bcNE = subchk(array, HI, hshift, hshift, scaling) - if (hshift==0) then - bcW = subchk(array, HI, -hshift-1, 0, scaling) - if (is_root_pe()) call chk_sum_msg_W("u-point:", bc0, bcW, mesg, iounit) - elseif (do_corners) then - if (sym) then - bcSW = subchk(array, HI, -hshift-1, -hshift, scaling) - bcNW = subchk(array, HI, -hshift-1, hshift, scaling) + if (is_root_pe()) & + call chk_sum_msg("u-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) else - bcSW = subchk(array, HI, -hshift, -hshift, scaling) - bcNW = subchk(array, HI, -hshift, hshift, scaling) + bcS = subchk(array, HI, 0, -hshift, scaling) + bcE = subchk(array, HI, hshift, 0, scaling) + if (sym) then + bcW = subchk(array, HI, -hshift-1, 0, scaling) + else + bcW = subchk(array, HI, -hshift, 0, scaling) + endif + bcN = subchk(array, HI, 0, hshift, scaling) + + if (is_root_pe()) & + call chk_sum_msg_NSEW("u-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) endif - bcSE = subchk(array, HI, hshift, -hshift, scaling) - bcNE = subchk(array, HI, hshift, hshift, scaling) + endif - if (is_root_pe()) & - call chk_sum_msg("u-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) - else - bcS = subchk(array, HI, 0, -hshift, scaling) - bcE = subchk(array, HI, hshift, 0, scaling) - if (sym) then - bcW = subchk(array, HI, -hshift-1, 0, scaling) - else - bcW = subchk(array, HI, -hshift, 0, scaling) - endif - bcN = subchk(array, HI, 0, hshift, scaling) + if (writeHash .and. is_root_pe()) then + allocate(hash_array(HI%isc:HI%iec, HI%jsc:HI%jec, size(array, 3))) + hash_array(:,:,:) = scaling * array(HI%isc:HI%iec, HI%jsc:HI%jec, :) - if (is_root_pe()) & - call chk_sum_msg_NSEW("u-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) + write(iounit, '("u-point: hash=", z8, 1x, a)') & + murmur_hash(hash_array), mesg + deallocate(hash_array) endif contains - integer function subchk(array, HI, di, dj, scale) + integer function subchk(array, HI, di, dj, unscale) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A scaling factor for this array. + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] integer :: i, j, k, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do k=LBOUND(array,3),UBOUND(array,3) ; do j=HI%jsc+dj,HI%jec+dj ; do I=HI%isc+di,HI%iec+di - bc = bitcount(abs(scale*array(I,j,k))) + bc = bitcount(abs(unscale*array(I,j,k))) subchk = subchk + bc enddo ; enddo ; enddo call sum_across_PEs(subchk) @@ -1674,12 +1957,12 @@ end function subchk subroutine subStats(HI, array, sym_stats, aMean, aMin, aMax) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed [a] logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the !! full symmetric computational domain. - real, intent(out) :: aMean !< Array mean - real, intent(out) :: aMin !< Array minimum - real, intent(out) :: aMax !< Array maximum + real, intent(out) :: aMean !< Array mean [a] + real, intent(out) :: aMin !< Array minimum [a] + real, intent(out) :: aMax !< Array maximum [a] integer :: i, j, k, n, IsB @@ -1703,26 +1986,37 @@ end subroutine chksum_u_3d !> Checksums a 3d array staggered at C-grid v points. subroutine chksum_v_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & - scale, logunit) - type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type - real, dimension(HI_m%isd:,HI_m%JsdB:,:), target, intent(in) :: array_m !< The array to be checksummed - character(len=*), intent(in) :: mesg !< An identifying message + scale, logunit, unscale) + type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type + real, dimension(HI_m%isd:,HI_m%JsdB:,:), target, intent(in) :: array_m !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for this array. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1]. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. - real, pointer :: array(:,:,:) ! Field array on the input grid - real, allocatable, dimension(:,:,:) :: rescaled_array + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, pointer :: array(:,:,:) ! Field array on the input grid [A ~> a] + real, allocatable, dimension(:,:,:) :: rescaled_array ! The array with scaling undone [a] + real, allocatable :: hash_array(:,:,:) ! Subarray used to compute hash [a] type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid - real :: scaling + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit integer :: i, j, k, Js integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW - real :: aMean, aMin, aMax + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] logical :: do_corners, sym, sym_stats integer :: turns ! Quarter turns from input to model grid @@ -1735,7 +2029,8 @@ subroutine chksum_v_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! Arrays originating from u-points must be handled by uchksum allocate(array(HI%IsdB:HI%IedB, HI%jsd:HI%jed, size(array_m, 3))) call rotate_array(array_m, -turns, array) - call uchksum(array, mesg, HI, haloshift, symmetric, omit_corners, scale, logunit) + call uchksum(array, mesg, HI, haloshift, symmetric, omit_corners, & + scale=scale, logunit=logunit, unscale=unscale) return else allocate(array(HI%isd:HI%ied, HI%JsdB:HI%JedB, size(array_m, 3))) @@ -1753,19 +2048,22 @@ subroutine chksum_v_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, ! call chksum_error(FATAL, 'NaN detected in halo: '//trim(mesg)) endif - scaling = 1.0 ; if (present(scale)) scaling = scale - iounit = error_unit; if(present(logunit)) iounit = logunit + scaling = 1.0 + if (present(unscale)) then ; scaling = unscale + elseif (present(scale)) then ; scaling = scale ; endif + + iounit = error_unit ; if (present(logunit)) iounit = logunit sym_stats = .false. ; if (present(symmetric)) sym_stats = symmetric if (present(haloshift)) then ; if (haloshift > 0) sym_stats = .true. ; endif if (calculateStatistics) then - if (present(scale)) then + if (present(unscale) .or. present(scale)) then allocate( rescaled_array(LBOUND(array,1):UBOUND(array,1), & LBOUND(array,2):UBOUND(array,2), & LBOUND(array,3):UBOUND(array,3)), source=0.0 ) Js = HI%jsc ; if (sym_stats) Js = HI%jsc-1 do k=1,size(array,3) ; do J=Js,HI%JecB ; do i=HI%isc,HI%iec - rescaled_array(i,J,k) = scale*array(i,J,k) + rescaled_array(i,J,k) = scaling*array(i,J,k) enddo ; enddo ; enddo call subStats(HI, rescaled_array, sym_stats, aMean, aMin, aMax) deallocate(rescaled_array) @@ -1796,54 +2094,65 @@ subroutine chksum_v_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, if ((hshift==0) .and. .not.sym) then if (is_root_pe()) call chk_sum_msg("v-point:", bc0, mesg, iounit) - return - endif + else + do_corners = .true. + if (present(omit_corners)) do_corners = .not. omit_corners - do_corners = .true. ; if (present(omit_corners)) do_corners = .not.omit_corners + if (hshift==0) then + bcS = subchk(array, HI, 0, -hshift-1, scaling) + if (is_root_pe()) call chk_sum_msg_S("v-point:", bc0, bcS, mesg, iounit) + elseif (do_corners) then + if (sym) then + bcSW = subchk(array, HI, -hshift, -hshift-1, scaling) + bcSE = subchk(array, HI, hshift, -hshift-1, scaling) + else + bcSW = subchk(array, HI, -hshift, -hshift, scaling) + bcSE = subchk(array, HI, hshift, -hshift, scaling) + endif + bcNW = subchk(array, HI, -hshift, hshift, scaling) + bcNE = subchk(array, HI, hshift, hshift, scaling) - if (hshift==0) then - bcS = subchk(array, HI, 0, -hshift-1, scaling) - if (is_root_pe()) call chk_sum_msg_S("v-point:", bc0, bcS, mesg, iounit) - elseif (do_corners) then - if (sym) then - bcSW = subchk(array, HI, -hshift, -hshift-1, scaling) - bcSE = subchk(array, HI, hshift, -hshift-1, scaling) + if (is_root_pe()) & + call chk_sum_msg("v-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) else - bcSW = subchk(array, HI, -hshift, -hshift, scaling) - bcSE = subchk(array, HI, hshift, -hshift, scaling) - endif - bcNW = subchk(array, HI, -hshift, hshift, scaling) - bcNE = subchk(array, HI, hshift, hshift, scaling) + if (sym) then + bcS = subchk(array, HI, 0, -hshift-1, scaling) + else + bcS = subchk(array, HI, 0, -hshift, scaling) + endif + bcE = subchk(array, HI, hshift, 0, scaling) + bcW = subchk(array, HI, -hshift, 0, scaling) + bcN = subchk(array, HI, 0, hshift, scaling) - if (is_root_pe()) & - call chk_sum_msg("v-point:", bc0, bcSW, bcSE, bcNW, bcNE, mesg, iounit) - else - if (sym) then - bcS = subchk(array, HI, 0, -hshift-1, scaling) - else - bcS = subchk(array, HI, 0, -hshift, scaling) + if (is_root_pe()) & + call chk_sum_msg_NSEW("v-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) endif - bcE = subchk(array, HI, hshift, 0, scaling) - bcW = subchk(array, HI, -hshift, 0, scaling) - bcN = subchk(array, HI, 0, hshift, scaling) + endif - if (is_root_pe()) & - call chk_sum_msg_NSEW("v-point:", bc0, bcN, bcS, bcE, bcW, mesg, iounit) + if (writeHash .and. is_root_pe()) then + allocate(hash_array(HI%isc:HI%iec, HI%jsc:HI%jec, size(array, 3))) + hash_array(:,:,:) = scaling * array(HI%isc:HI%iec, HI%jsc:HI%jec, :) + + write(iounit, '("v-point: hash=", z8, 1x, a)') & + murmur_hash(hash_array), mesg + deallocate(hash_array) endif contains - integer function subchk(array, HI, di, dj, scale) + integer function subchk(array, HI, di, dj, unscale) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A scaling factor for this array. + real, intent(in) :: unscale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] integer :: i, j, k, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do k=LBOUND(array,3),UBOUND(array,3) ; do J=HI%jsc+dj,HI%jec+dj ; do i=HI%isc+di,HI%iec+di - bc = bitcount(abs(scale*array(i,J,k))) + bc = bitcount(abs(unscale*array(i,J,k))) subchk = subchk + bc enddo ; enddo ; enddo call sum_across_PEs(subchk) @@ -1853,12 +2162,12 @@ end function subchk !subroutine subStats(HI, array, mesg, sym_stats) subroutine subStats(HI, array, sym_stats, aMean, aMin, aMax) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed [a] logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the !! full symmetric computational domain. - real, intent(out) :: aMean !< Mean of array over domain - real, intent(out) :: aMin !< Minimum of array over domain - real, intent(out) :: aMax !< Maximum of array over domain + real, intent(out) :: aMean !< Mean of array over domain [a] + real, intent(out) :: aMin !< Minimum of array over domain [a] + real, intent(out) :: aMax !< Maximum of array over domain [a] integer :: i, j, k, n, JsB @@ -1884,17 +2193,18 @@ end subroutine chksum_v_3d ! into account. !> chksum1d does a checksum of a 1-dimensional array. -subroutine chksum1d(array, mesg, start_i, end_i, compare_PEs) - real, dimension(:), intent(in) :: array !< The array to be summed (index starts at 1). +subroutine chksum1d(array, mesg, start_i, end_i, compare_PEs, logunit) + real, dimension(:), intent(in) :: array !< The array to be summed (index starts at 1) in arbitrary units [A]. character(len=*), intent(in) :: mesg !< An identifying message. integer, optional, intent(in) :: start_i !< The starting index for the sum (default 1) integer, optional, intent(in) :: end_i !< The ending index for the sum (default all) logical, optional, intent(in) :: compare_PEs !< If true, compare across PEs instead of summing !! and list the root_PE value (default true) + integer, optional, intent(in) :: logunit !< IO unit for checksum logging - integer :: is, ie, i, bc, sum1, sum_bc - real :: sum - real, allocatable :: sum_here(:) + integer :: is, ie, i, bc, sum1, sum_bc, ioUnit + real :: sum ! The global sum of the array [A] + real, allocatable :: sum_here(:) ! The sum on each PE [A] logical :: compare integer :: pe_num ! pe number of the data integer :: nPEs ! Total number of processsors @@ -1903,6 +2213,7 @@ subroutine chksum1d(array, mesg, start_i, end_i, compare_PEs) if (present(start_i)) is = start_i if (present(end_i)) ie = end_i compare = .true. ; if (present(compare_PEs)) compare = compare_PEs + iounit = error_unit ; if (present(logunit)) iounit = logunit sum = 0.0 ; sum_bc = 0 do i=is,ie @@ -1924,17 +2235,17 @@ subroutine chksum1d(array, mesg, start_i, end_i, compare_PEs) sum_bc = sum1 elseif (is_root_pe()) then if (sum1 /= nPEs*sum_bc) & - write(0, '(A40," bitcounts do not match across PEs: ",I12,1X,I12)') & + write(iounit, '(A40," bitcounts do not match across PEs: ",I12,1X,I12)') & mesg, sum1, nPEs*sum_bc do i=1,nPEs ; if (sum /= sum_here(i)) then - write(0, '(A40," PE ",i4," sum mismatches root_PE: ",3(ES22.13,1X))') & + write(iounit, '(A40," PE ",I0," sum mismatches root_PE: ",3(ES22.13,1X))') & mesg, i, sum_here(i), sum, sum_here(i)-sum endif ; enddo endif deallocate(sum_here) if (is_root_pe()) & - write(0,'(A50,1X,ES25.16,1X,I12)') mesg, sum, sum_bc + write(iounit,'(A50,1X,ES25.16,1X,I12)') mesg, sum, sum_bc end subroutine chksum1d @@ -1942,13 +2253,16 @@ end subroutine chksum1d ! into account. !> chksum2d does a checksum of all data in a 2-d array. -subroutine chksum2d(array, mesg) +subroutine chksum2d(array, mesg, logunit) + + real, dimension(:,:), intent(in) :: array !< The array to be checksummed in arbitrary units [A] + character(len=*), intent(in) :: mesg !< An identifying message + integer, optional, intent(in) :: logunit !< IO unit for checksum logging - real, dimension(:,:) :: array !< The array to be checksummed - character(len=*) :: mesg !< An identifying message + integer :: xs, xe, ys, ye, i, j, sum1, bc, iounit + real :: sum ! The global sum of the array [A] - integer :: xs,xe,ys,ye,i,j,sum1,bc - real :: sum + iounit = error_unit ; if (present(logunit)) iounit = logunit xs = LBOUND(array,1) ; xe = UBOUND(array,1) ys = LBOUND(array,2) ; ye = UBOUND(array,2) @@ -1963,20 +2277,23 @@ subroutine chksum2d(array, mesg) sum = reproducing_sum(array(:,:)) if (is_root_pe()) & - write(0,'(A50,1X,ES25.16,1X,I12)') mesg, sum, sum1 -! write(0,'(A40,1X,Z16.16,1X,Z16.16,1X,ES25.16,1X,I12)') & + write(iounit,'(A50,1X,ES25.16,1X,I12)') mesg, sum, sum1 +! write(iounit,'(A40,1X,Z16.16,1X,Z16.16,1X,ES25.16,1X,I12)') & ! mesg, sum, sum1, sum, sum1 end subroutine chksum2d !> chksum3d does a checksum of all data in a 2-d array. -subroutine chksum3d(array, mesg) +subroutine chksum3d(array, mesg, logunit) - real, dimension(:,:,:) :: array !< The array to be checksummed - character(len=*) :: mesg !< An identifying message + real, dimension(:,:,:), intent(in) :: array !< The array to be checksummed in arbitrary units [A] + character(len=*), intent(in) :: mesg !< An identifying message + integer, optional, intent(in) :: logunit !< IO unit for checksum logging - integer :: xs,xe,ys,ye,zs,ze,i,j,k, bc,sum1 - real :: sum + integer :: xs, xe, ys, ye, zs, ze, i, j, k, bc, sum1, iounit + real :: sum ! The global sum of the array [A] + + iounit = error_unit ; if (present(logunit)) iounit = logunit xs = LBOUND(array,1) ; xe = UBOUND(array,1) ys = LBOUND(array,2) ; ye = UBOUND(array,2) @@ -1992,15 +2309,15 @@ subroutine chksum3d(array, mesg) sum = reproducing_sum(array(:,:,:)) if (is_root_pe()) & - write(0,'(A50,1X,ES25.16,1X,I12)') mesg, sum, sum1 -! write(0,'(A40,1X,Z16.16,1X,Z16.16,1X,ES25.16,1X,I12)') & + write(iounit, '(A50,1X,ES25.16,1X,I12)') mesg, sum, sum1 +! write(iounit, '(A40,1X,Z16.16,1X,Z16.16,1X,ES25.16,1X,I12)') & ! mesg, sum, sum1, sum, sum1 end subroutine chksum3d !> This function returns .true. if x is a NaN, and .false. otherwise. function is_NaN_0d(x) - real, intent(in) :: x !< The value to be checked for NaNs. + real, intent(in) :: x !< The value to be checked for NaNs in arbitrary units [A] logical :: is_NaN_0d !is_NaN_0d = (((x < 0.0) .and. (x >= 0.0)) .or. & @@ -2016,7 +2333,7 @@ end function is_NaN_0d !> Returns .true. if any element of x is a NaN, and .false. otherwise. function is_NaN_1d(x, skip_mpp) - real, dimension(:), intent(in) :: x !< The array to be checked for NaNs. + real, dimension(:), intent(in) :: x !< The array to be checked for NaNs in arbitrary units [A] logical, optional, intent(in) :: skip_mpp !< If true, only check this array only !! on the local PE (default false). logical :: is_NaN_1d @@ -2039,7 +2356,7 @@ end function is_NaN_1d !> Returns .true. if any element of x is a NaN, and .false. otherwise. function is_NaN_2d(x) - real, dimension(:,:), intent(in) :: x !< The array to be checked for NaNs. + real, dimension(:,:), intent(in) :: x !< The array to be checked for NaNs in arbitrary units [A] logical :: is_NaN_2d integer :: i, j, n @@ -2056,7 +2373,7 @@ end function is_NaN_2d !> Returns .true. if any element of x is a NaN, and .false. otherwise. function is_NaN_3d(x) - real, dimension(:,:,:), intent(in) :: x !< The array to be checked for NaNs. + real, dimension(:,:,:), intent(in) :: x !< The array to be checked for NaNs in arbitrary units [A] logical :: is_NaN_3d integer :: i, j, k, n @@ -2073,119 +2390,176 @@ function is_NaN_3d(x) end function is_NaN_3d -! The following set of routines do a checksum across the computational domain of -! a field, with the potential for rotation of this field and masking. +! The following set of routines do a checksum across all elements of a field, +! with the potential for the unscaling and rotation of this field and masking. -!> Compute the field checksum of a scalar. -function rotated_field_chksum_real_0d(field, pelist, mask_val, turns) & +!> Compute the field checksum of a scalar that may need to be unscaled. +!! This uses the field_chksum function that is used to verify file contents, which may differ +!! from the bitcount function used for other checksums in this module. +function field_checksum_real_0d(field, pelist, mask_val, turns, unscale) & result(chksum) - real, intent(in) :: field !< Input scalar + real, intent(in) :: field !< Input scalar to be checksummed in arbitrary, + !! possibly rescaled units [A ~> a] integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum - real, optional, intent(in) :: mask_val !< FMS mask value + real, optional, intent(in) :: mask_val !< FMS mask value [nondim] integer, optional, intent(in) :: turns !< Number of quarter turns + real, optional, intent(in) :: unscale !< A factor to convert this array back to + !! unscaled units for checksums [a A-1 ~> 1] integer(kind=int64) :: chksum !< checksum of scalar + real :: scale_fac ! A local copy of unscale if it is present [a A-1 ~> 1] or 1 otherwise + if (present(turns)) call MOM_error(FATAL, "Rotation not supported for 0d fields.") - chksum = field_chksum(field, pelist=pelist, mask_val=mask_val) -end function rotated_field_chksum_real_0d + scale_fac = 1.0 ; if (present(unscale)) scale_fac = unscale + + chksum = field_chksum(scale_fac*field, pelist=pelist, mask_val=mask_val) +end function field_checksum_real_0d -!> Compute the field checksum of a 1d field. -function rotated_field_chksum_real_1d(field, pelist, mask_val, turns) & +!> Compute the field checksum of an entire 1d array that may need to be unscaled. +!! This uses the field_chksum function that is used to verify file contents, which may differ +!! from the bitcount function used for other checksums in this module. +function field_checksum_real_1d(field, pelist, mask_val, turns, unscale) & result(chksum) - real, dimension(:), intent(in) :: field !< Input array + real, dimension(:), intent(in) :: field !< Input array to be checksummed in arbitrary, + !! possibly rescaled units [A ~> a] integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum - real, optional, intent(in) :: mask_val !< FMS mask value + real, optional, intent(in) :: mask_val !< FMS mask value [nondim] integer, optional, intent(in) :: turns !< Number of quarter turns + real, optional, intent(in) :: unscale !< A factor to convert this array back to + !! unscaled units for checksums [a A-1 ~> 1] integer(kind=int64) :: chksum !< checksum of array + real :: scale_fac ! A local copy of unscale if it is present [a A-1 ~> 1] or 1 otherwise + if (present(turns)) call MOM_error(FATAL, "Rotation not supported for 1d fields.") - chksum = field_chksum(field, pelist=pelist, mask_val=mask_val) -end function rotated_field_chksum_real_1d + scale_fac = 1.0 ; if (present(unscale)) scale_fac = unscale + + chksum = field_chksum(scale_fac*field(:), pelist=pelist, mask_val=mask_val) +end function field_checksum_real_1d -!> Compute the field checksum of a rotated 2d field. -function rotated_field_chksum_real_2d(field, pelist, mask_val, turns) & +!> Compute the field checksum of an entire 2d array that may need to be rotated or unscaled. +!! This uses the field_chksum function that is used to verify file contents, which may differ +!! from the bitcount function used for other checksums in this module. +function field_checksum_real_2d(field, pelist, mask_val, turns, unscale) & result(chksum) - real, dimension(:,:), intent(in) :: field !< Unrotated input field + real, dimension(:,:), intent(in) :: field !< Unrotated input field to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum - real, optional, intent(in) :: mask_val !< FMS mask value + real, optional, intent(in) :: mask_val !< FMS mask value [nondim] integer, optional, intent(in) :: turns !< Number of quarter turns + real, optional, intent(in) :: unscale !< A factor to convert this array back to + !! unscaled units for checksums [a A-1 ~> 1] integer(kind=int64) :: chksum !< checksum of array ! Local variables - real, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units + real, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units [A ~> a] integer :: qturns ! The number of quarter turns through which to rotate field + logical :: do_unscale ! If true, unscale the variable before it is checksummed qturns = 0 if (present(turns)) & qturns = modulo(turns, 4) + do_unscale = .false. ; if (present(unscale)) do_unscale = (unscale /= 1.0) + if (qturns == 0) then - chksum = field_chksum(field, pelist=pelist, mask_val=mask_val) + if (do_unscale) then + chksum = field_chksum(unscale*field(:,:), pelist=pelist, mask_val=mask_val) + else + chksum = field_chksum(field, pelist=pelist, mask_val=mask_val) + endif else call allocate_rotated_array(field, [1,1], qturns, field_rot) call rotate_array(field, qturns, field_rot) + if (do_unscale) field_rot(:,:) = unscale*field_rot(:,:) chksum = field_chksum(field_rot, pelist=pelist, mask_val=mask_val) deallocate(field_rot) endif -end function rotated_field_chksum_real_2d +end function field_checksum_real_2d -!> Compute the field checksum of a rotated 3d field. -function rotated_field_chksum_real_3d(field, pelist, mask_val, turns) & +!> Compute the field checksum of an entire 3d array that may need to be rotated or unscaled. +!! This uses the field_chksum function that is used to verify file contents, which may differ +!! from the bitcount function used for other checksums in this module. +function field_checksum_real_3d(field, pelist, mask_val, turns, unscale) & result(chksum) - real, dimension(:,:,:), intent(in) :: field !< Unrotated input field + real, dimension(:,:,:), intent(in) :: field !< Unrotated input field to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum - real, optional, intent(in) :: mask_val !< FMS mask value + real, optional, intent(in) :: mask_val !< FMS mask value [nondim] integer, optional, intent(in) :: turns !< Number of quarter turns + real, optional, intent(in) :: unscale !< A factor to convert this array back to + !! unscaled units for checksums [a A-1 ~> 1] integer(kind=int64) :: chksum !< checksum of array ! Local variables - real, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units + real, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units [A ~> a] integer :: qturns ! The number of quarter turns through which to rotate field + logical :: do_unscale ! If true, unscale the variable before it is checksummed qturns = 0 if (present(turns)) & qturns = modulo(turns, 4) + do_unscale = .false. ; if (present(unscale)) do_unscale = (unscale /= 1.0) + if (qturns == 0) then - chksum = field_chksum(field, pelist=pelist, mask_val=mask_val) + if (do_unscale) then + chksum = field_chksum(unscale*field(:,:,:), pelist=pelist, mask_val=mask_val) + else + chksum = field_chksum(field, pelist=pelist, mask_val=mask_val) + endif else call allocate_rotated_array(field, [1,1,1], qturns, field_rot) call rotate_array(field, qturns, field_rot) + if (do_unscale) field_rot(:,:,:) = unscale*field_rot(:,:,:) chksum = field_chksum(field_rot, pelist=pelist, mask_val=mask_val) deallocate(field_rot) endif -end function rotated_field_chksum_real_3d +end function field_checksum_real_3d -!> Compute the field checksum of a rotated 4d field. -function rotated_field_chksum_real_4d(field, pelist, mask_val, turns) & +!> Compute the field checksum of an entire 4d array that may need to be rotated or unscaled. +!! This uses the field_chksum function that is used to verify file contents, which may differ +!! from the bitcount function used for other checksums in this module. +function field_checksum_real_4d(field, pelist, mask_val, turns, unscale) & result(chksum) - real, dimension(:,:,:,:), intent(in) :: field !< Unrotated input field + real, dimension(:,:,:,:), intent(in) :: field !< Unrotated input field to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum - real, optional, intent(in) :: mask_val !< FMS mask value + real, optional, intent(in) :: mask_val !< FMS mask value [nondim] integer, optional, intent(in) :: turns !< Number of quarter turns + real, optional, intent(in) :: unscale !< A factor to convert this array back to + !! unscaled units for checksums [a A-1 ~> 1] integer(kind=int64) :: chksum !< checksum of array ! Local variables - real, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units + real, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units [A ~> a] integer :: qturns ! The number of quarter turns through which to rotate field + logical :: do_unscale ! If true, unscale the variable before it is checksummed qturns = 0 if (present(turns)) & qturns = modulo(turns, 4) + do_unscale = .false. ; if (present(unscale)) do_unscale = (unscale /= 1.0) + if (qturns == 0) then - chksum = field_chksum(field, pelist=pelist, mask_val=mask_val) + if (do_unscale) then + chksum = field_chksum(unscale*field(:,:,:,:), pelist=pelist, mask_val=mask_val) + else + chksum = field_chksum(field, pelist=pelist, mask_val=mask_val) + endif else call allocate_rotated_array(field, [1,1,1,1], qturns, field_rot) call rotate_array(field, qturns, field_rot) + if (do_unscale) field_rot(:,:,:,:) = unscale*field_rot(:,:,:,:) chksum = field_chksum(field_rot, pelist=pelist, mask_val=mask_val) deallocate(field_rot) endif -end function rotated_field_chksum_real_4d +end function field_checksum_real_4d !> Write a message including the checksum of the non-shifted array @@ -2196,7 +2570,7 @@ subroutine chk_sum_msg1(fmsg, bc0, mesg, iounit) integer, intent(in) :: iounit !< Checksum logger IO unit if (is_root_pe()) & - write(iounit, '(A,1(A,I10,X),A)') fmsg, " c=", bc0, trim(mesg) + write(iounit, '(a,1(a,i10,1x),a)') fmsg, " c=", bc0, trim(mesg) end subroutine chk_sum_msg1 !> Write a message including checksums of non-shifted and diagonally shifted arrays @@ -2269,9 +2643,9 @@ end subroutine chk_sum_msg2 subroutine chk_sum_msg3(fmsg, aMean, aMin, aMax, mesg, iounit) character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller - real, intent(in) :: aMean !< The mean value of the array - real, intent(in) :: aMin !< The minimum value of the array - real, intent(in) :: aMax !< The maximum value of the array + real, intent(in) :: aMean !< The mean value of the array in arbitrary units [A] + real, intent(in) :: aMin !< The minimum value of the array [A] + real, intent(in) :: aMax !< The maximum value of the array [A] integer, intent(in) :: iounit !< Checksum logger IO unit ! NOTE: We add zero to aMin and aMax to remove any negative zeros. @@ -2285,8 +2659,8 @@ end subroutine chk_sum_msg3 !! only thing that it does is to log the version of this module. subroutine MOM_checksums_init(param_file) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_checksums" ! This module's name. call log_version(param_file, mdl, version) @@ -2304,7 +2678,7 @@ end subroutine chksum_error !> Does a bitcount of a number by first casting to an integer and then using BTEST !! to check bit by bit integer function bitcount(x) - real, intent(in) :: x !< Number to be bitcount + real, intent(in) :: x !< Number to be bitcount in arbitrary units [A] integer, parameter :: xk = kind(x) !< Kind type of x diff --git a/src/framework/MOM_coms.F90 b/src/framework/MOM_coms.F90 index c3ed3ba7b3..e577d68b82 100644 --- a/src/framework/MOM_coms.F90 +++ b/src/framework/MOM_coms.F90 @@ -1,29 +1,37 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Interfaces to non-domain-oriented communication subroutines, including the !! MOM6 reproducing sums facility module MOM_coms -! This file is part of MOM6. See LICENSE.md for the license. - +use, intrinsic :: iso_fortran_env, only : int64 use MOM_coms_infra, only : PE_here, root_PE, num_PEs, set_rootPE, Set_PElist, Get_PElist use MOM_coms_infra, only : broadcast, field_chksum, MOM_infra_init, MOM_infra_end use MOM_coms_infra, only : sum_across_PEs, max_across_PEs, min_across_PEs +use MOM_coms_infra, only : all_across_PEs, any_across_PEs use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING +use MOM_coms_infra, only : sync_PEs implicit none ; private public :: PE_here, root_PE, num_PEs, MOM_infra_init, MOM_infra_end +public :: sync_PEs public :: broadcast, sum_across_PEs, min_across_PEs, max_across_PEs, field_chksum +public :: all_across_PEs, any_across_PEs public :: set_PElist, Get_PElist, Set_rootPE public :: reproducing_sum, reproducing_sum_EFP, EFP_sum_across_PEs, EFP_list_sum_across_PEs public :: EFP_plus, EFP_minus, EFP_to_real, real_to_EFP, EFP_real_diff public :: operator(+), operator(-), assignment(=) public :: query_EFP_overflow_error, reset_EFP_overflow_error +public :: max_count_prec ! This module provides interfaces to the non-domain-oriented communication subroutines. -integer(kind=8), parameter :: prec=2_8**46 !< The precision of each integer. -real, parameter :: r_prec=2.0**46 !< A real version of prec. -real, parameter :: I_prec=1.0/(2.0**46) !< The inverse of prec. +integer(kind=int64), parameter :: prec = (2_int64)**46 !< The precision of each integer. +real, parameter :: r_prec=2.0**46 !< A real version of prec [nondim]. +real, parameter :: I_prec=1.0/(2.0**46) !< The inverse of prec [nondim]. integer, parameter :: max_count_prec=2**(63-46)-1 !< The number of values that can be added together !! with the current value of prec before there will @@ -33,12 +41,12 @@ module MOM_coms !< a real number. real, parameter, dimension(ni) :: & pr = (/ r_prec**2, r_prec, 1.0, 1.0/r_prec, 1.0/r_prec**2, 1.0/r_prec**3 /) - !< An array of the real precision of each of the integers + !< An array of the real precision of each of the integers in arbitrary units [a] real, parameter, dimension(ni) :: & I_pr = (/ 1.0/r_prec**2, 1.0/r_prec, 1.0, r_prec, r_prec**2, r_prec**3 /) - !< An array of the inverse of the real precision of each of the integers + !< An array of the inverse of the real precision of each of the integers in arbitrary units [a-1] real, parameter :: max_efp_float = pr(1) * (2.**63 - 1.) - !< The largest float with an EFP representation. + !< The largest float with an EFP representation in arbitrary units [a]. !! NOTE: Only the first bin can exceed precision, !! but is bounded by the largest signed integer. @@ -46,7 +54,8 @@ module MOM_coms logical :: NaN_error = .false. !< This becomes true if a NaN is encountered. logical :: debug = .false. !< Making this true enables debugging output. -!> Find an accurate and order-invariant sum of a distributed 2d or 3d field +!> Find an accurate and order-invariant sum of a distributed 2d or 3d field, in some cases after +!! undoing the scaling of the input array and restoring that scaling in the returned value interface reproducing_sum module procedure reproducing_sum_2d, reproducing_sum_3d end interface reproducing_sum @@ -69,7 +78,7 @@ module MOM_coms !! Hallberg, R. & A. Adcroft, 2014: An Order-invariant Real-to-Integer Conversion Sum. !! Parallel Computing, 40(5-6), doi:10.1016/j.parco.2014.04.007. type, public :: EFP_type ; private - integer(kind=8), dimension(ni) :: v !< The value in this type + integer(kind=int64), dimension(ni) :: v !< The value in this type end type EFP_type !> Add two extended-fixed-point numbers @@ -86,8 +95,9 @@ module MOM_coms !! the result returned as an extended fixed point type that can be converted back to a real number !! using EFP_to_real. This technique is described in Hallberg & Adcroft, 2014, Parallel Computing, !! doi:10.1016/j.parco.2014.04.007. -function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, only_on_PE) result(EFP_sum) - real, dimension(:,:), intent(in) :: array !< The array to be summed +function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, only_on_PE, unscale) result(EFP_sum) + real, dimension(:,:), intent(in) :: array !< The array to be summed in arbitrary units [a], or in + !! arbitrary scaled units [A ~> a] if unscale is present integer, optional, intent(in) :: isr !< The starting i-index of the sum, noting !! that the array indices starts at 1 integer, optional, intent(in) :: ier !< The ending i-index of the sum, noting @@ -97,25 +107,28 @@ function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, integer, optional, intent(in) :: jer !< The ending j-index of the sum, noting !! that the array indices starts at 1 logical, optional, intent(in) :: overflow_check !< If present and false, disable - !! checking for overflows in incremental results. - !! This can speed up calculations if the number - !! of values being summed is small enough - integer, optional, intent(out) :: err !< If present, return an error code instead of - !! triggering any fatal errors directly from - !! this routine. + !! checking for overflows in incremental results. + !! This can speed up calculations if the number + !! of values being summed is small enough + integer, optional, intent(out) :: err !< If present, return an error code instead of + !! triggering any fatal errors directly from + !! this routine. logical, optional, intent(in) :: only_on_PE !< If present and true, do not do the sum - !! across processors, only reporting the local sum - type(EFP_type) :: EFP_sum !< The result in extended fixed point format + !! across processors, only reporting the local sum + real, optional, intent(in) :: unscale !< A factor that is used to undo scaling of array before it is + !! summed, often to compensate for the scaling in [a A-1 ~> 1] + type(EFP_type) :: EFP_sum !< The result in extended fixed point format ! This subroutine uses a conversion to an integer representation ! of real numbers to give order-invariant sums that will reproduce ! across PE count. This idea comes from R. Hallberg and A. Adcroft. - integer(kind=8), dimension(ni) :: ints_sum - integer(kind=8) :: ival, prec_error - real :: rs - real :: max_mag_term - logical :: over_check, do_sum_across_PEs + integer(kind=int64), dimension(ni) :: ints_sum + integer(kind=int64) :: ival, prec_error + real :: rs ! The remaining value to add, in arbitrary units [a] + real :: max_mag_term ! A running maximum magnitude of the values in arbitrary units [a] + real :: descale ! A local copy of unscale if it is present [a A-1 ~> 1] or 1 + logical :: over_check, do_sum_across_PEs, do_unscale character(len=256) :: mesg integer :: i, j, n, is, ie, js, je, sgn @@ -123,9 +136,9 @@ function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, "reproducing_sum: Too many processors are being used for the value of "//& "prec. Reduce prec to (2^63-1)/num_PEs.") - prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + prec_error = ((2_int64)**62 + ((2_int64)**62 - 1)) / num_PEs() - is = 1 ; ie = size(array,1) ; js = 1 ; je = size(array,2 ) + is = 1 ; ie = size(array,1) ; js = 1 ; je = size(array,2) if (present(isr)) then if (isr < is) call MOM_error(FATAL, "Value of isr too small in reproducing_EFP_sum_2d.") is = isr @@ -145,34 +158,42 @@ function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, over_check = .true. ; if (present(overflow_check)) over_check = overflow_check do_sum_across_PEs = .true. ; if (present(only_on_PE)) do_sum_across_PEs = .not.only_on_PE + do_unscale = .false. ; if (present(unscale)) do_unscale = (unscale /= 1.0) + descale = 1.0 ; if (do_unscale) descale = unscale overflow_error = .false. ; NaN_error = .false. ; max_mag_term = 0.0 ints_sum(:) = 0 if (over_check) then if ((je+1-js)*(ie+1-is) < max_count_prec) then - do j=js,je ; do i=is,ie - call increment_ints_faster(ints_sum, array(i,j), max_mag_term) - enddo ; enddo + ! This is the most common case, so handle the do_unscale case separately for efficiency. + if (do_unscale) then + do j=js,je ; do i=is,ie + call increment_ints_faster(ints_sum, unscale*array(i,j), max_mag_term) + enddo ; enddo + else + do j=js,je ; do i=is,ie + call increment_ints_faster(ints_sum, array(i,j), max_mag_term) + enddo ; enddo + endif call carry_overflow(ints_sum, prec_error) elseif ((ie+1-is) < max_count_prec) then do j=js,je do i=is,ie - call increment_ints_faster(ints_sum, array(i,j), max_mag_term) + call increment_ints_faster(ints_sum, descale*array(i,j), max_mag_term) enddo call carry_overflow(ints_sum, prec_error) enddo else do j=js,je ; do i=is,ie - call increment_ints(ints_sum, real_to_ints(array(i,j), prec_error), & - prec_error) + call increment_ints(ints_sum, real_to_ints(descale*array(i,j), prec_error), prec_error) enddo ; enddo endif else do j=js,je ; do i=is,ie sgn = 1 ; if (array(i,j)<0.0) sgn = -1 - rs = abs(array(i,j)) + rs = abs(descale*array(i,j)) do n=1,ni - ival = int(rs*I_pr(n), 8) + ival = int(rs*I_pr(n), kind=int64) rs = rs - ival*pr(n) ints_sum(n) = ints_sum(n) + sgn*ival enddo @@ -208,13 +229,15 @@ function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, end function reproducing_EFP_sum_2d + !> This subroutine uses a conversion to an integer representation of real numbers to give an !! order-invariant sum of distributed 2-D arrays that reproduces across domain decomposition. !! This technique is described in Hallberg & Adcroft, 2014, Parallel Computing, !! doi:10.1016/j.parco.2014.04.007. function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & - overflow_check, err, only_on_PE) result(sum) - real, dimension(:,:), intent(in) :: array !< The array to be summed + overflow_check, err, only_on_PE, unscale) result(sum) + real, dimension(:,:), intent(in) :: array !< The array to be summed in arbitrary units [a], or in + !! arbitrary scaled units [A ~> a] if unscale is present integer, optional, intent(in) :: isr !< The starting i-index of the sum, noting !! that the array indices starts at 1 integer, optional, intent(in) :: ier !< The ending i-index of the sum, noting @@ -223,7 +246,7 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & !! that the array indices starts at 1 integer, optional, intent(in) :: jer !< The ending j-index of the sum, noting !! that the array indices starts at 1 - type(EFP_type), optional, intent(out) :: EFP_sum !< The result in extended fixed point format + type(EFP_type), optional, intent(out) :: EFP_sum !< The result in extended fixed point format logical, optional, intent(in) :: reproducing !< If present and false, do the sum !! using the naive non-reproducing approach logical, optional, intent(in) :: overflow_check !< If present and false, disable @@ -235,27 +258,29 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & !! this routine. logical, optional, intent(in) :: only_on_PE !< If present and true, do not do the sum !! across processors, only reporting the local sum - real :: sum !< Result - - ! This subroutine uses a conversion to an integer representation - ! of real numbers to give order-invariant sums that will reproduce - ! across PE count. This idea comes from R. Hallberg and A. Adcroft. - - integer(kind=8), dimension(ni) :: ints_sum - integer(kind=8) :: prec_error - real :: rsum(1), rs - logical :: repro, do_sum_across_PEs + real, optional, intent(in) :: unscale !< A factor that is used to undo scaling of array before it is + !! summed, often to compensate for the scaling in [a A-1 ~> 1] + real :: sum !< The sum of the values in array in the same + !! arbitrary units as array [a] or [A ~> a] + + ! Local variables + integer(kind=int64), dimension(ni) :: ints_sum + integer(kind=int64) :: prec_error + real :: rsum(1) ! The running sum, in arbitrary units [a] + real :: descale ! A local copy of unscale if it is present [a A-1 ~> 1] or 1 + real :: I_unscale ! The reciprocal of unscale [A a-1 ~> 1] + logical :: repro, do_sum_across_PEs, do_unscale character(len=256) :: mesg type(EFP_type) :: EFP_val ! An extended fixed point version of the sum - integer :: i, j, n, is, ie, js, je + integer :: i, j, is, ie, js, je if (num_PEs() > max_count_prec) call MOM_error(FATAL, & "reproducing_sum: Too many processors are being used for the value of "//& "prec. Reduce prec to (2^63-1)/num_PEs.") - prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + prec_error = ((2_int64)**62 + ((2_int64)**62 - 1)) / num_PEs() - is = 1 ; ie = size(array,1) ; js = 1 ; je = size(array,2 ) + is = 1 ; ie = size(array,1) ; js = 1 ; je = size(array,2) if (present(isr)) then if (isr < is) call MOM_error(FATAL, "Value of isr too small in reproducing_sum_2d.") is = isr @@ -275,19 +300,25 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & repro = .true. ; if (present(reproducing)) repro = reproducing do_sum_across_PEs = .true. ; if (present(only_on_PE)) do_sum_across_PEs = .not.only_on_PE + do_unscale = .false. ; if (present(unscale)) do_unscale = (unscale /= 1.0) + descale = 1.0 ; I_unscale = 1.0 + if (do_unscale) then + descale = unscale + if (abs(unscale) > 0.0) I_unscale = 1.0 / unscale + endif if (repro) then - EFP_val = reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, only_on_PE) - sum = ints_to_real(EFP_val%v) + EFP_val = reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, only_on_PE, unscale) + sum = ints_to_real(EFP_val%v) * I_unscale if (present(EFP_sum)) EFP_sum = EFP_val if (debug) ints_sum(:) = EFP_sum%v(:) else rsum(1) = 0.0 do j=js,je ; do i=is,ie - rsum(1) = rsum(1) + array(i,j) + rsum(1) = rsum(1) + descale*array(i,j) enddo ; enddo if (do_sum_across_PEs) call sum_across_PEs(rsum,1) - sum = rsum(1) + sum = rsum(1) * I_unscale if (present(err)) then ; err = 0 ; endif @@ -307,7 +338,7 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & endif if (debug) then - write(mesg,'("2d RS: ", ES24.16, 6 Z17.16)') sum, ints_sum(1:ni) + write(mesg,'("2d RS: ", ES24.16, 6 Z17.16)') sum*descale, ints_sum(1:ni) call MOM_mesg(mesg, 3) endif @@ -317,9 +348,10 @@ end function reproducing_sum_2d !! order-invariant sum of distributed 3-D arrays that reproduces across domain decomposition. !! This technique is described in Hallberg & Adcroft, 2014, Parallel Computing, !! doi:10.1016/j.parco.2014.04.007. -function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_sums, err, only_on_PE) & +function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_sums, err, only_on_PE, unscale) & result(sum) - real, dimension(:,:,:), intent(in) :: array !< The array to be summed + real, dimension(:,:,:), intent(in) :: array !< The array to be summed in arbitrary units [a], or in + !! arbitrary scaled units [A ~> a] if unscale is present integer, optional, intent(in) :: isr !< The starting i-index of the sum, noting !! that the array indices starts at 1 integer, optional, intent(in) :: ier !< The ending i-index of the sum, noting @@ -328,34 +360,38 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_su !! that the array indices starts at 1 integer, optional, intent(in) :: jer !< The ending j-index of the sum, noting !! that the array indices starts at 1 - real, dimension(:), optional, intent(out) :: sums !< The sums by vertical layer + real, dimension(:), optional, intent(out) :: sums !< The sums by vertical layer in the same + !! arbitrary units as array [a] or [A ~> a] type(EFP_type), optional, intent(out) :: EFP_sum !< The result in extended fixed point format type(EFP_type), dimension(:), & optional, intent(out) :: EFP_lay_sums !< The sums by vertical layer in EFP format - integer, optional, intent(out) :: err !< If present, return an error code instead of - !! triggering any fatal errors directly from - !! this routine. + integer, optional, intent(out) :: err !< If present, return an error code instead of + !! triggering any fatal errors directly from + !! this routine. logical, optional, intent(in) :: only_on_PE !< If present and true, do not do the sum - !! across processors, only reporting the local sum - real :: sum !< Result - - ! This subroutine uses a conversion to an integer representation - ! of real numbers to give order-invariant sums that will reproduce - ! across PE count. This idea comes from R. Hallberg and A. Adcroft. - - real :: val, max_mag_term - integer(kind=8), dimension(ni) :: ints_sum - integer(kind=8), dimension(ni,size(array,3)) :: ints_sums - integer(kind=8) :: prec_error + !! across processors, only reporting the local sum + real, optional, intent(in) :: unscale !< A factor that is used to undo scaling of array before it is + !! summed, often to compensate for the scaling in [a A-1 ~> 1] + real :: sum !< The sum of the values in array in the same + !! arbitrary units as array [a] or [A ~> a] + + ! Local variables + real :: val ! The real number that is extracted in arbitrary units [a] + real :: max_mag_term ! A running maximum magnitude of the val's in arbitrary units [a] + real :: descale ! A local copy of unscale if it is present [a A-1 ~> 1] or 1 + real :: I_unscale ! The Adcroft reciprocal of unscale [A a-1 ~> 1] + integer(kind=int64), dimension(ni) :: ints_sum + integer(kind=int64), dimension(ni,size(array,3)) :: ints_sums + integer(kind=int64) :: prec_error character(len=256) :: mesg - logical :: do_sum_across_PEs + logical :: do_sum_across_PEs, do_unscale integer :: i, j, k, is, ie, js, je, ke, isz, jsz, n if (num_PEs() > max_count_prec) call MOM_error(FATAL, & "reproducing_sum: Too many processors are being used for the value of "//& "prec. Reduce prec to (2^63-1)/num_PEs.") - prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + prec_error = ((2_int64)**62 + ((2_int64)**62 - 1)) / num_PEs() max_mag_term = 0.0 is = 1 ; ie = size(array,1) ; js = 1 ; je = size(array,2) ; ke = size(array,3) @@ -375,9 +411,11 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_su if (jer > je) call MOM_error(FATAL, "Value of jer too large in reproducing_sum(_3d).") je = jer endif - jsz = je+1-js; isz = ie+1-is + jsz = je+1-js ; isz = ie+1-is do_sum_across_PEs = .true. ; if (present(only_on_PE)) do_sum_across_PEs = .not.only_on_PE + do_unscale = .false. ; if (present(unscale)) do_unscale = (unscale /= 1.0) + descale = 1.0 ; if (do_unscale) descale = unscale if (present(sums) .or. present(EFP_lay_sums)) then if (present(sums)) then ; if (size(sums) < ke) then @@ -390,22 +428,28 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_su overflow_error = .false. ; NaN_error = .false. ; max_mag_term = 0.0 if (jsz*isz < max_count_prec) then do k=1,ke - do j=js,je ; do i=is,ie - call increment_ints_faster(ints_sums(:,k), array(i,j,k), max_mag_term) - enddo ; enddo + if (do_unscale) then + do j=js,je ; do i=is,ie + call increment_ints_faster(ints_sums(:,k), unscale*array(i,j,k), max_mag_term) + enddo ; enddo + else + do j=js,je ; do i=is,ie + call increment_ints_faster(ints_sums(:,k), array(i,j,k), max_mag_term) + enddo ; enddo + endif call carry_overflow(ints_sums(:,k), prec_error) enddo elseif (isz < max_count_prec) then do k=1,ke ; do j=js,je do i=is,ie - call increment_ints_faster(ints_sums(:,k), array(i,j,k), max_mag_term) + call increment_ints_faster(ints_sums(:,k), descale*array(i,j,k), max_mag_term) enddo call carry_overflow(ints_sums(:,k), prec_error) enddo ; enddo else do k=1,ke ; do j=js,je ; do i=is,ie call increment_ints(ints_sums(:,k), & - real_to_ints(array(i,j,k), prec_error), prec_error) + real_to_ints(descale*array(i,j,k), prec_error), prec_error) enddo ; enddo ; enddo endif if (present(err)) then @@ -452,21 +496,27 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_su overflow_error = .false. ; NaN_error = .false. ; max_mag_term = 0.0 if (jsz*isz < max_count_prec) then do k=1,ke - do j=js,je ; do i=is,ie - call increment_ints_faster(ints_sum, array(i,j,k), max_mag_term) - enddo ; enddo + if (do_unscale) then + do j=js,je ; do i=is,ie + call increment_ints_faster(ints_sum, unscale*array(i,j,k), max_mag_term) + enddo ; enddo + else + do j=js,je ; do i=is,ie + call increment_ints_faster(ints_sum, array(i,j,k), max_mag_term) + enddo ; enddo + endif call carry_overflow(ints_sum, prec_error) enddo elseif (isz < max_count_prec) then do k=1,ke ; do j=js,je do i=is,ie - call increment_ints_faster(ints_sum, array(i,j,k), max_mag_term) + call increment_ints_faster(ints_sum, descale*array(i,j,k), max_mag_term) enddo call carry_overflow(ints_sum, prec_error) enddo ; enddo else do k=1,ke ; do j=js,je ; do i=is,ie - call increment_ints(ints_sum, real_to_ints(array(i,j,k), prec_error), & + call increment_ints(ints_sum, real_to_ints(descale*array(i,j,k), prec_error), & prec_error) enddo ; enddo ; enddo endif @@ -498,28 +548,39 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_su endif endif + if (do_unscale) then + ! Revise the sum to restore the scaling of input array before it is returned + I_unscale = 0.0 ; if (abs(unscale) > 0.0) I_unscale = 1.0 / unscale + sum = sum * I_unscale + if (present(sums)) then + do k=1,ke ; sums(k) = sums(k) * I_unscale ; enddo + endif + endif + end function reproducing_sum_3d !> Convert a real number into the array of integers constitute its extended-fixed-point representation function real_to_ints(r, prec_error, overflow) result(ints) - real, intent(in) :: r !< The real number being converted - integer(kind=8), optional, intent(in) :: prec_error !< The PE-count dependent precision of the + real, intent(in) :: r !< The real number being converted in arbitrary units [a] + integer(kind=int64), optional, intent(in) :: prec_error !< The PE-count dependent precision of the !! integers that is safe from overflows during global !! sums. This will be larger than the compile-time !! precision parameter, and is used to detect overflows. logical, optional, intent(inout) :: overflow !< Returns true if the conversion is being !! done on a value that is too large to be represented - integer(kind=8), dimension(ni) :: ints + integer(kind=int64), dimension(ni) :: ints + ! This subroutine converts a real number to an equivalent representation ! using several long integers. - real :: rs + ! Local variables + real :: rs ! The remaining value to add, in arbitrary units [a] character(len=80) :: mesg - integer(kind=8) :: ival, prec_err + integer(kind=int64) :: ival, prec_err integer :: sgn, i prec_err = prec ; if (present(prec_error)) prec_err = prec_error - ints(:) = 0_8 + ints(:) = 0 if ((r >= 1e30) .eqv. (r < 1e30)) then ; NaN_error = .true. ; return ; endif sgn = 1 ; if (r<0.0) sgn = -1 @@ -534,7 +595,7 @@ function real_to_ints(r, prec_error, overflow) result(ints) endif do i=1,ni - ival = int(rs*I_pr(i), 8) + ival = int(rs*I_pr(i), kind=int64) rs = rs - ival*pr(i) ints(i) = sgn*ival enddo @@ -544,8 +605,8 @@ end function real_to_ints !> Convert the array of integers that constitute an extended-fixed-point !! representation into a real number function ints_to_real(ints) result(r) - integer(kind=8), dimension(ni), intent(in) :: ints !< The array of EFP integers - real :: r + integer(kind=int64), dimension(ni), intent(in) :: ints !< The array of EFP integers + real :: r ! The real number that is extracted in arbitrary units [a] ! This subroutine reverses the conversion in real_to_ints. integer :: i @@ -557,9 +618,9 @@ end function ints_to_real !> Increment an array of integers that constitutes an extended-fixed-point !! representation with a another EFP number subroutine increment_ints(int_sum, int2, prec_error) - integer(kind=8), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented - integer(kind=8), dimension(ni), intent(in) :: int2 !< The array of EFP integers being added - integer(kind=8), optional, intent(in) :: prec_error !< The PE-count dependent precision of the + integer(kind=int64), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented + integer(kind=int64), dimension(ni), intent(in) :: int2 !< The array of EFP integers being added + integer(kind=int64), optional, intent(in) :: prec_error !< The PE-count dependent precision of the !! integers that is safe from overflows during global !! sums. This will be larger than the compile-time !! precision parameter, and is used to detect overflows. @@ -591,15 +652,16 @@ end subroutine increment_ints !> Increment an EFP number with a real number without doing any carrying of !! of overflows and using only minimal error checking. subroutine increment_ints_faster(int_sum, r, max_mag_term) - integer(kind=8), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented - real, intent(in) :: r !< The real number being added. - real, intent(inout) :: max_mag_term !< A running maximum magnitude of the r's. + integer(kind=int64), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented + real, intent(in) :: r !< The real number being added in arbitrary units [a] + real, intent(inout) :: max_mag_term !< A running maximum magnitude of the r's + !! in arbitrary units [a] ! This subroutine increments a number with another, both using the integer ! representation in real_to_ints, but without doing any carrying of overflow. ! The entire operation is embedded in a single call for greater speed. - real :: rs - integer(kind=8) :: ival + real :: rs ! The remaining value to add, in arbitrary units [a] + integer(kind=int64) :: ival integer :: sgn, i if ((r >= 1e30) .eqv. (r < 1e30)) then ; NaN_error = .true. ; return ; endif @@ -614,7 +676,7 @@ subroutine increment_ints_faster(int_sum, r, max_mag_term) endif do i=1,ni - ival = int(rs*I_pr(i), 8) + ival = int(rs*I_pr(i), kind=int64) rs = rs - ival*pr(i) int_sum(i) = int_sum(i) + sgn*ival enddo @@ -623,9 +685,9 @@ end subroutine increment_ints_faster !> This subroutine handles carrying of the overflow. subroutine carry_overflow(int_sum, prec_error) - integer(kind=8), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being + integer(kind=int64), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being !! modified by carries, but without changing value. - integer(kind=8), intent(in) :: prec_error !< The PE-count dependent precision of the + integer(kind=int64), intent(in) :: prec_error !< The PE-count dependent precision of the !! integers that is safe from overflows during global !! sums. This will be larger than the compile-time !! precision parameter, and is used to detect overflows. @@ -647,7 +709,7 @@ end subroutine carry_overflow !> This subroutine carries the overflow, and then makes sure that !! all integers are of the same sign as the overall value. subroutine regularize_ints(int_sum) - integer(kind=8), dimension(ni), & + integer(kind=int64), dimension(ni), & intent(inout) :: int_sum !< The array of integers being modified to take a !! regular form with all integers of the same sign, !! but without changing value. @@ -736,7 +798,7 @@ end subroutine EFP_assign !> Return the real number that an extended-fixed-point number corresponds with function EFP_to_real(EFP1) type(EFP_type), intent(inout) :: EFP1 !< The extended fixed point number being converted - real :: EFP_to_real + real :: EFP_to_real !< The real version of the number in arbitrary units [a] call regularize_ints(EFP1%v) EFP_to_real = ints_to_real(EFP1%v) @@ -748,7 +810,7 @@ function EFP_real_diff(EFP1, EFP2) type(EFP_type), intent(in) :: EFP1 !< The first extended fixed point number type(EFP_type), intent(in) :: EFP2 !< The extended fixed point number being !! subtracted from the first extended fixed point number - real :: EFP_real_diff !< The real result + real :: EFP_real_diff !< The real result in arbitrary units [a] type(EFP_type) :: EFP_diff @@ -759,7 +821,7 @@ end function EFP_real_diff !> Return the extended-fixed-point number that a real number corresponds with function real_to_EFP(val, overflow) - real, intent(in) :: val !< The real number being converted + real, intent(in) :: val !< The real number being converted in arbitrary units [a] logical, optional, intent(inout) :: overflow !< Returns true if the conversion is being !! done on a value that is too large to be represented type(EFP_type) :: real_to_EFP @@ -793,8 +855,8 @@ subroutine EFP_list_sum_across_PEs(EFPs, nval, errors) ! This subroutine does a sum across PEs of a list of EFP variables, ! returning the sums in place, with all overflows carried. - integer(kind=8), dimension(ni,nval) :: ints - integer(kind=8) :: prec_error + integer(kind=int64), dimension(ni,nval) :: ints + integer(kind=int64) :: prec_error logical :: error_found character(len=256) :: mesg integer :: i, n @@ -803,7 +865,7 @@ subroutine EFP_list_sum_across_PEs(EFPs, nval, errors) "reproducing_sum: Too many processors are being used for the value of "//& "prec. Reduce prec to (2^63-1)/num_PEs.") - prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + prec_error = ((2_int64)**62 + ((2_int64)**62 - 1)) / num_PEs() ! overflow_error is an overflow error flag for the whole module. overflow_error = .false. ; error_found = .false. @@ -818,7 +880,7 @@ subroutine EFP_list_sum_across_PEs(EFPs, nval, errors) do n=1,ni ; EFPs(i)%v(n) = ints(n,i) ; enddo if (present(errors)) errors(i) = overflow_error if (overflow_error) then - write (mesg,'("EFP_list_sum_across_PEs error at ",i6," val was ",ES12.6, ", prec_error = ",ES12.6)') & + write (mesg,'("EFP_list_sum_across_PEs error at ",i0," val was ",ES12.6, ", prec_error = ",ES12.6)') & i, EFP_to_real(EFPs(i)), real(prec_error) call MOM_error(WARNING, mesg) endif @@ -840,8 +902,8 @@ subroutine EFP_val_sum_across_PEs(EFP, error) ! This subroutine does a sum across PEs of a list of EFP variables, ! returning the sums in place, with all overflows carried. - integer(kind=8), dimension(ni) :: ints - integer(kind=8) :: prec_error + integer(kind=int64), dimension(ni) :: ints + integer(kind=int64) :: prec_error logical :: error_found character(len=256) :: mesg integer :: n @@ -850,7 +912,7 @@ subroutine EFP_val_sum_across_PEs(EFP, error) "reproducing_sum: Too many processors are being used for the value of "//& "prec. Reduce prec to (2^63-1)/num_PEs.") - prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + prec_error = ((2_int64)**62 + ((2_int64)**62 - 1)) / num_PEs() ! overflow_error is an overflow error flag for the whole module. overflow_error = .false. ; error_found = .false. diff --git a/src/framework/MOM_coupler_types.F90 b/src/framework/MOM_coupler_types.F90 index 73304f7fe8..cc8b2427da 100644 --- a/src/framework/MOM_coupler_types.F90 +++ b/src/framework/MOM_coupler_types.F90 @@ -1,8 +1,11 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> This module provides coupler type interfaces for use by MOM6 module MOM_coupler_types -! This file is part of MOM6. See LICENSE.md for the license. - +use MOM_array_transform, only : allocate_rotated_array, rotate_array use MOM_couplertype_infra, only : CT_spawn, CT_initialized, CT_destructor, atmos_ocn_coupler_flux use MOM_couplertype_infra, only : CT_set_diags, CT_send_data, CT_write_chksums, CT_data_override use MOM_couplertype_infra, only : CT_copy_data, CT_increment_data, CT_rescale_data @@ -19,8 +22,10 @@ module MOM_coupler_types public :: set_coupler_type_data, extract_coupler_type_data, coupler_type_redistribute_data public :: coupler_type_copy_data, coupler_type_increment_data, coupler_type_rescale_data public :: atmos_ocn_coupler_flux, coupler_type_data_override -public :: ind_flux, ind_alpha, ind_csurf public :: coupler_1d_bc_type, coupler_2d_bc_type, coupler_3d_bc_type +! These are encoding constant parameters that indicate whether a flux, solubility or +! surface ocean concentration are being set or accessed with an inquiry. +public :: ind_flux, ind_alpha, ind_csurf !> This is the interface to spawn one coupler_bc_type into another. interface coupler_type_spawn @@ -244,11 +249,15 @@ end subroutine CT_copy_data_2d_3d !> Increment data in all elements of one coupler_2d_bc_type with the data from another. Both !! must have the same array sizes. subroutine CT_increment_data_2d(var_in, var, halo_size, scale_factor, scale_prev) - type(coupler_2d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type - type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + type(coupler_2d_bc_type), intent(in) :: var_in !< A coupler_type structure with data in arbitrary + !! arbitrary units [A] to add to the other type + type(coupler_2d_bc_type), intent(inout) :: var !< A coupler_type structure with data in arbitrary + !! units [B] whose fields are being incremented integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + !! in arbitrary units [C A-1] real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here + !! in arbitrary units [C B-1] call CT_increment_data(var_in, var, halo_size=halo_size, scale_factor=scale_factor, & scale_prev=scale_prev) @@ -258,11 +267,15 @@ end subroutine CT_increment_data_2d !> Increment data in all elements of one coupler_3d_bc_type with the data from another. Both !! must have the same array sizes. subroutine CT_increment_data_3d(var_in, var, halo_size, scale_factor, scale_prev, exclude_flux_type, only_flux_type) - type(coupler_3d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type - type(coupler_3d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented + type(coupler_3d_bc_type), intent(in) :: var_in !< A coupler_type structure with data in arbitrary + !! arbitrary units [A] to add to the other type + type(coupler_3d_bc_type), intent(inout) :: var !< A coupler_type structure with data in arbitrary + !! units [B] whose fields are being incremented integer, optional, intent(in) :: halo_size !< The extent of the halo to increment; 0 by default real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + !! in arbitrary units [C A-1] real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here + !! in arbitrary units [C B-1] character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types !! of fluxes to exclude from this increment. character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types @@ -279,7 +292,7 @@ end subroutine CT_increment_data_3d subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size) type(coupler_3d_bc_type), intent(in) :: var_in !< coupler_type structure with the data to add to the other type real, dimension(:,:,:), intent(in) :: weights !< An array of normalized weights for the 3d-data to - !! increment the 2d-data. There is no renormalization, + !! increment the 2d-data [nondim]. There is no renormalization, !! so if the weights do not sum to 1 in the 3rd dimension !! there may be adverse consequences! type(coupler_2d_bc_type), intent(inout) :: var !< The coupler_type structure whose fields are being incremented @@ -292,8 +305,11 @@ end subroutine CT_increment_data_2d_3d !> Rescales the fields in the elements of a coupler_2d_bc_type by multiplying by a factor scale. !! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. subroutine CT_rescale_data_2d(var, scale) - type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled - real, intent(in) :: scale !< A scaling factor to multiply fields by + type(coupler_2d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled, + !! with the internal data units perhaps changing from + !! arbitrary units [A] to other arbitrary units [B] + real, intent(in) :: scale !< A scaling factor to multiply fields by in + !! arbitrary units [B A-1] call CT_rescale_data(var, scale) @@ -302,8 +318,11 @@ end subroutine CT_rescale_data_2d !> Rescales the fields in the elements of a coupler_3d_bc_type by multiplying by a factor scale. !! If scale is 0, this is a direct assignment to 0, so that NaNs will not persist. subroutine CT_rescale_data_3d(var, scale) - type(coupler_3d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled - real, intent(in) :: scale !< A scaling factor to multiply fields by + type(coupler_3d_bc_type), intent(inout) :: var !< The BC_type structure whose fields are being rescaled, + !! with the internal data units perhaps changing from + !! arbitrary units [A] to other arbitrary units [B] + real, intent(in) :: scale !< A scaling factor to multiply fields by in + !! arbitrary units [B A-1] call CT_rescale_data(var, scale) @@ -347,14 +366,17 @@ end subroutine coupler_type_data_override !> Extract a 2d field from a coupler_2d_bc_type into a two-dimensional array, using a !! MOM-specific interface. subroutine extract_coupler_type_data(var_in, bc_index, array_out, scale_factor, & - halo_size, idim, jdim, field_index) + halo_size, idim, jdim, field_index, turns) type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract + !! The internal data has arbitrary units [B]. integer, intent(in) :: bc_index !< The index of the boundary condition !! that is being copied - real, dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field; its size + real, dimension(1:,1:), intent(out) :: array_out !< The recipient array for the field in + !! arbitrary units [A]; the size of this array !! must match the size of the data being copied !! unless idim and jdim are supplied. - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being + !! extracted, in arbitrary units [A B-1] integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of !! the first dimension of the output array @@ -365,13 +387,41 @@ subroutine extract_coupler_type_data(var_in, bc_index, array_out, scale_factor, integer, optional, intent(in) :: field_index !< The index of the field in the boundary !! condition that is being copied, or the !! surface flux by default. - - if (present(field_index)) then - call CT_extract_data(var_in, bc_index, field_index, array_out, & - scale_factor=scale_factor, halo_size=halo_size, idim=idim, jdim=jdim) + integer, optional, intent(in) :: turns !< The number of quarter-turns from the unrotated + !! coupler_2d_bt_type to model grid + + ! Local variables + real, allocatable :: array_unrot(:,:) ! Array on the unrotated grid in arbitrary units [A] + integer :: q_turns ! The number of quarter turns through which array_out is to be rotated + integer :: index + + index = ind_flux ; if (present(field_index)) index = field_index + q_turns = 0 ; if (present(turns)) q_turns = modulo(turns, 4) + + ! The case with non-trivial grid rotation is complicated by the fact that the data fields + ! in the coupler_2d_bc_type are never rotated, so they need to be handled separately. + if (q_turns == 0) then + call CT_extract_data(var_in, bc_index, index, array_out, & + scale_factor=scale_factor, halo_size=halo_size, idim=idim, jdim=jdim) + elseif (present(idim) .and. present(jdim)) then + call allocate_rotated_array(array_out, [1,1], -q_turns, array_unrot) + + if (modulo(q_turns, 2) /= 0) then + call CT_extract_data(var_in, bc_index, index, array_unrot, & + idim=jdim, jdim=idim, scale_factor=scale_factor, halo_size=halo_size) + else + call CT_extract_data(var_in, bc_index, index, array_unrot, & + idim=idim, jdim=jdim, scale_factor=scale_factor, halo_size=halo_size) + endif + + call rotate_array(array_unrot, q_turns, array_out) + deallocate(array_unrot) else - call CT_extract_data(var_in, bc_index, ind_flux, array_out, & - scale_factor=scale_factor, halo_size=halo_size, idim=idim, jdim=jdim) + call allocate_rotated_array(array_out, [1,1], -q_turns, array_unrot) + call CT_extract_data(var_in, bc_index, index, array_unrot, & + scale_factor=scale_factor, halo_size=halo_size) + call rotate_array(array_unrot, q_turns, array_out) + deallocate(array_unrot) endif end subroutine extract_coupler_type_data @@ -379,17 +429,20 @@ end subroutine extract_coupler_type_data !> Set single 2d field in coupler_2d_bc_type from a two-dimensional array, using a !! MOM-specific interface. subroutine set_coupler_type_data(array_in, bc_index, var, solubility, scale_factor, & - halo_size, idim, jdim, field_index) - real, dimension(1:,1:), intent(in) :: array_in !< The source array for the field; its size + halo_size, idim, jdim, field_index, turns) + real, dimension(1:,1:), intent(in) :: array_in !< The source array for the field in + !! arbitrary units [A]; the size of this array !! must match the size of the data being copied !! unless idim and jdim are supplied. integer, intent(in) :: bc_index !< The index of the boundary condition !! that is being copied type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure with the data to set + !! The internal data has arbitrary units [B]. logical, optional, intent(in) :: solubility !< If true and field index is missing, set !! the solubility field. Otherwise set the !! surface concentration (the default). - real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added + real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being + !! set, in arbitrary units [B A-1] integer, optional, intent(in) :: halo_size !< The extent of the halo to copy; 0 by default integer, dimension(4), optional, intent(in) :: idim !< The data and computational domain extents of !! the first dimension of the output array @@ -400,15 +453,48 @@ subroutine set_coupler_type_data(array_in, bc_index, var, solubility, scale_fact integer, optional, intent(in) :: field_index !< The index of the field in the !! boundary condition that is being set. The !! surface concentration is set by default. + integer, optional, intent(in) :: turns !< The number of quarter-turns from the unrotated + !! coupler_2d_bt_type to model grid + ! Local variables + real, allocatable :: array_unrot(:,:) ! Array on the unrotated grid in the same arbitrary units + ! as array_in [A] integer :: subfield ! An integer indicating which field to set. + integer :: q_turns ! The number of quarter turns through which array_in is rotated + + q_turns = 0 ; if (present(turns)) q_turns = modulo(turns, 4) subfield = ind_csurf if (present(solubility)) then ; if (solubility) subfield = ind_alpha ; endif if (present(field_index)) subfield = field_index - call CT_set_data(array_in, bc_index, subfield, var, & - scale_factor=scale_factor, halo_size=halo_size, idim=idim, jdim=jdim) + ! The case with non-trivial grid rotation is complicated by the fact that the data fields + ! in the coupler_2d_bc_type are never rotated, so they need to be handled separately. + if (q_turns == 0) then + call CT_set_data(array_in, bc_index, subfield, var, & + scale_factor=scale_factor, halo_size=halo_size, idim=idim, jdim=jdim) + elseif (present(idim) .and. present(jdim)) then + call allocate_rotated_array(array_in, [1,1], -q_turns, array_unrot) + call rotate_array(array_in, -q_turns, array_unrot) + + if (modulo(q_turns, 2) /= 0) then + call CT_set_data(array_unrot, bc_index, subfield, var, & + idim=jdim, jdim=idim, & + scale_factor=scale_factor, halo_size=halo_size) + else + call CT_set_data(array_unrot, bc_index, subfield, var, & + idim=idim, jdim=jdim, & + scale_factor=scale_factor, halo_size=halo_size) + endif + + deallocate(array_unrot) + else + call allocate_rotated_array(array_in, [1,1], -q_turns, array_unrot) + call rotate_array(array_in, -q_turns, array_unrot) + call CT_set_data(array_in, bc_index, subfield, var, & + scale_factor=scale_factor, halo_size=halo_size) + deallocate(array_unrot) + endif end subroutine set_coupler_type_data diff --git a/src/framework/MOM_cpu_clock.F90 b/src/framework/MOM_cpu_clock.F90 index f4e605a06c..91d1c2085a 100644 --- a/src/framework/MOM_cpu_clock.F90 +++ b/src/framework/MOM_cpu_clock.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Provides cpu clock functions module MOM_cpu_clock -! This file is part of MOM6. See LICENSE.md for the license. - ! These interfaces and constants from MPP/FMS will not be directly exposed outside of this module use MOM_cpu_clock_infra, only : cpu_clock_begin use MOM_cpu_clock_infra, only : cpu_clock_end diff --git a/src/framework/MOM_data_override.F90 b/src/framework/MOM_data_override.F90 index 39841913e1..1ff145c0d7 100644 --- a/src/framework/MOM_data_override.F90 +++ b/src/framework/MOM_data_override.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> These interfaces allow for ocean or sea-ice variables to be replaced with data. module MOM_data_override -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_data_override_infra, only : data_override_init => impose_data_init use MOM_data_override_infra, only : data_override => impose_data use MOM_data_override_infra, only : data_override_unset_domains => impose_data_unset_domains diff --git a/src/framework/MOM_diag_buffers.F90 b/src/framework/MOM_diag_buffers.F90 new file mode 100644 index 0000000000..bc3695155a --- /dev/null +++ b/src/framework/MOM_diag_buffers.F90 @@ -0,0 +1,551 @@ +!> Provides buffers that can dynamically grow as needed. These are primarily intended for the +!! diagnostics which need to store intermediate or partial states of state variables +module MOM_diag_buffers + +use MOM_io, only : stdout, stderr + +! This file is part of MOM6. See LICENSE.md for the license. + +implicit none ; private + +public :: diag_buffer_unit_tests_2d, diag_buffer_unit_tests_3d + +type, abstract :: buffer_base +end type buffer_base + +!> Holds a 2d field +type, extends(buffer_base) :: buffer_2d + real, dimension(:,:), allocatable :: field !< The actual 2d field to be stored [arbitrary] +end type buffer_2d + +!> Holds a 3d field +type, extends(buffer_base) :: buffer_3d + real, dimension(:,:,:), allocatable :: field !< The actual 3d field to be stored [arbitrary] +end type buffer_3d + +!> The base class for the diagnostic buffers in this module +type, abstract :: diag_buffer_base ; private + integer :: is !< The start slot of the array i-direction + integer :: js !< The start slot of the array j-direction + integer :: ie !< The end slot of the array i-direction + integer :: je !< The end slot of the array j-direction + real :: fill_value = 0. !< Set the fill value to use when growing the buffer [arbitrary] + + integer, allocatable, dimension(:) :: ids !< List of diagnostic ids whose slot corresponds to the row in the buffer + integer :: length = 0 !< The number of slots in the buffer + + contains + + procedure(a_grow), deferred :: grow !< Increase the size of the buffer + procedure, public :: set_fill_value !< Set the fill value to use when growing the buffer + procedure, public :: check_capacity_by_id !< Check the size size of the buffer and increase if necessary + procedure, public :: set_horizontal_extents !< Define the horizontal extents of the arrays + procedure, public :: mark_available !< Mark that a slot in the buffer can be reused + procedure, public :: grow_ids !< Increase the size of the vector storing diagnostic ids + procedure, public :: find_buffer_slot !< Find the slot corresponding to a specific diagnostic id +end type diag_buffer_base + +!> Dynamically growing buffer for 2D arrays. +type, extends(diag_buffer_base), public :: diag_buffer_2d ; private + type(buffer_2d), public, dimension(:), allocatable :: buffer !< The actual 2D buffer which will dynamically grow + + contains + + procedure, public :: grow => grow_2d !< Increase the size of the buffer + procedure, public :: store => store_2d !< Store a field in the buffer, increasing as necessary + procedure, public :: set_extents_from_array => set_extents_from_array_2d !< Set extents from array bounds +end type diag_buffer_2d + +!> Dynamically growing buffer for 3D arrays. +type, extends(diag_buffer_base), public :: diag_buffer_3d ; private + type(buffer_3d), public, dimension(:), allocatable :: buffer !< The actual 2D buffer which will dynamically grow + integer :: ks !< The start slot in the k-dimension + integer :: ke !< The last slot in the k-dimension + + contains + + procedure, public :: set_vertical_extent !< Set the vertical extents of the buffer + procedure, public :: grow => grow_3d !< Increase the size of the buffer + procedure, public :: store => store_3d !< Store a field in the buffer, increasing as necessary + procedure, public :: set_extents_from_array => set_extents_from_array_3d !< Set extents from array bounds +end type diag_buffer_3d + +contains + +!> Signature for the grow methods on n-dimension diagnostic buffer types +subroutine a_grow(this) + class(diag_buffer_base), intent(inout) :: this !< The diagnostic buffer +end subroutine + +!> Set the fill value to use when growing the buffer +subroutine set_fill_value(this, fill_value) + class(diag_buffer_base), intent(inout) :: this !< The diagnostic buffer + real, intent(in) :: fill_value !< The fill value to use when growing the buffer [arbitrary] + + this%fill_value = fill_value +end subroutine set_fill_value + +!> Mark a slot in the buffer as unused based on a diagnostic id. For example, +!! the data in that slot has already been consumed and can thus be overwritten +subroutine mark_available(this, id) + class(diag_buffer_base), intent(inout) :: this !< The diagnostic buffer + integer, intent(in) :: id !< The diagnostic id + integer :: slot + + slot = this%find_buffer_slot(id) + this%ids(slot) = 0 +end subroutine mark_available + +!> Return the slot of the buffer corresponding to the diagnostic id +pure function find_buffer_slot(this, id) result(slot) + class(diag_buffer_base), intent(in) :: this !< The diagnostic buffer + integer, intent(in) :: id !< The diagnostic id + + integer, dimension(1) :: temp + integer :: slot !< The slot in the buffer corresponding to the diagnostic id + + if (allocated(this%ids)) then + !NOTE: Alternatively could do slot = SUM(findloc(...)) + temp = findloc(this%ids(:), id) + slot = temp(1) + else + slot = 0 + endif + +end function find_buffer_slot + +!> Grow the ids array by one +subroutine grow_ids(this) + class(diag_buffer_base), intent(inout) :: this !< This buffer + + integer, allocatable, dimension(:) :: temp + integer :: n + + n = this%length + + allocate(temp(n+1)) + if (n>0) temp(1:n) = this%ids(:) + call move_alloc(temp, this%ids) +end subroutine grow_ids + +!> Check whether the id already has a slot reserved. If not, find a new empty slot and if +!! need be, grow the buffer. +impure function check_capacity_by_id(this, id) result(slot) + class(diag_buffer_base), intent(inout) :: this !< This 2d buffer + integer, intent(in) :: id !< The diagnostic id + integer :: slot + + slot = this%find_buffer_slot(id) + if (slot==0) then + ! Check to see if there is an open slot + if (allocated(this%ids)) slot = this%find_buffer_slot(0) + ! If slot is still 0, then the buffer must grow + if (slot==0) then + call this%grow() + slot = this%length + endif + this%ids(slot) = id + endif +end function check_capacity_by_id + +!> Set the horizontal extents of the buffer +subroutine set_horizontal_extents(this, is, ie, js, je) + class(diag_buffer_base), intent(inout) :: this !< The diagnostic buffer + integer, intent(in) :: is !< The start slot of the array i-direction + integer, intent(in) :: ie !< The end slot of the array i-direction + integer, intent(in) :: js !< The start slot of the array j-direction + integer, intent(in) :: je !< The end slot of the array j-direction + + this%is = is ; this%ie = ie ; this%js = js ; this%je = je +end subroutine set_horizontal_extents + +!> Set the vertical extent of the buffer +subroutine set_vertical_extent(this, ks, ke) + class(diag_buffer_3d), intent(inout) :: this !< The diagnostic buffer + integer, intent(in) :: ks !< The start slot of the array i-direction + integer, intent(in) :: ke !< The end slot of the array i-direction + + this%ks = ks ; this%ke = ke +end subroutine set_vertical_extent + +!> Set the extents of a 2D buffer from the bounds of a 2D array +subroutine set_extents_from_array_2d(this, array, fill_value_in) + class(diag_buffer_2d), intent(inout) :: this !< The diagnostic buffer + real, dimension(:,:), intent(in) :: array !< The array whose bounds define the buffer extents + real, optional, intent(in) :: fill_value_in !< Optional fill value + + call this%set_horizontal_extents(lbound(array,1), ubound(array,1), & + lbound(array,2), ubound(array,2)) + if (present(fill_value_in)) call this%set_fill_value(fill_value_in) +end subroutine set_extents_from_array_2d + +!> Set the extents of a 3D buffer from the bounds of a 3D array +subroutine set_extents_from_array_3d(this, array, fill_value_in) + class(diag_buffer_3d), intent(inout) :: this !< The diagnostic buffer + real, dimension(:,:,:), intent(in) :: array !< The array whose bounds define the buffer extents + real, optional, intent(in) :: fill_value_in !< Optional fill value + + call this%set_horizontal_extents(lbound(array,1), ubound(array,1), & + lbound(array,2), ubound(array,2)) + call this%set_vertical_extent(lbound(array,3), ubound(array,3)) + if (present(fill_value_in)) call this%set_fill_value(fill_value_in) +end subroutine set_extents_from_array_3d + +!> Grow a 2d diagnostic buffer +subroutine grow_2d(this) + class(diag_buffer_2d), intent(inout) :: this + + integer :: i, n + integer :: is, ie, js, je + type(buffer_2d), dimension(:), allocatable :: new_buffer + + ! Grow the ID array + call this%grow_ids() + + is = this%is ; ie = this%ie ; js = this%js ; je = this%je + n = this%length + + allocate(new_buffer(n+1)) + do i=1,n + allocate(new_buffer(i)%field(is:ie,js:je)) + new_buffer(i)%field(:,:) = this%buffer(i)%field(:,:) + enddo + allocate(new_buffer(n+1)%field(is:ie,js:je), source=this%fill_value) + call move_alloc(new_buffer, this%buffer) + this%length = n+1 + +end subroutine grow_2d + +!> Store a 2D array into this buffer +subroutine store_2d(this, data, id) + class(diag_buffer_2d), intent(inout) :: this !< This 2d buffer + real, dimension(:,:), intent(in) :: data !< The data to be stored in the buffer [arbitrary] + integer, intent(in) :: id !< The diagnostic id + + integer :: slot + + slot = this%check_capacity_by_id(id) + this%buffer(slot)%field(:,:) = data(:,:) +end subroutine store_2d + +!> Grow a 2d diagnostic buffer +subroutine grow_3d(this) + class(diag_buffer_3d), intent(inout) :: this + + integer :: i, n + integer :: is, ie, js, je, ks, ke + type(buffer_3d), dimension(:), allocatable :: new_buffer + + ! Grow the ID array + call this%grow_ids() + + is = this%is ; ie = this%ie ; js = this%js ; je = this%je ; ks = this%ks ; ke = this%ke + n = this%length + + allocate(new_buffer(n+1)) + do i=1,n + allocate(new_buffer(i)%field(is:ie,js:je,ks:ke)) + new_buffer(i)%field(:,:,:) = this%buffer(i)%field(:,:,:) + enddo + allocate(new_buffer(n+1)%field(is:ie,js:je,ks:ke), source=this%fill_value) + call move_alloc(new_buffer, this%buffer) + this%length = n+1 + +end subroutine grow_3d + +!> Store a 3d array into this buffer +subroutine store_3d(this, data, id) + class(diag_buffer_3d), intent(inout) :: this !< This 3d buffer + real, dimension(:,:,:), intent(in) :: data !< The data to be stored in the buffer [arbitrary] + integer, intent(in) :: id !< The diagnostic id + + integer :: slot + + ! Find the first slot in the ids array that is 0, i.e. this is a portion of the buffer that can be reused + slot = this%check_capacity_by_id(id) + this%buffer(slot)%field(:,:,:) = data(:,:,:) +end subroutine store_3d + +!> Unit tests for the 2d version of the diag buffer +function diag_buffer_unit_tests_2d(verbose) result(fail) + logical, intent(in) :: verbose !< If true, write results to stdout + logical :: fail !< True if any of the unit tests fail + + fail = .false. + write(stdout,*) '==== MOM_diag_buffers: diag_buffers_unit_tests_2d ===' + fail = fail .or. new_buffer_2d() + fail = fail .or. grow_buffer_2d() + fail = fail .or. fill_value_2d() + fail = fail .or. store_buffer_2d() + fail = fail .or. reuse_buffer_2d() + + contains + + !> Ensure properties of a newly initialized buffer + function new_buffer_2d() result(local_fail) + type(diag_buffer_2d) :: buffer + logical :: local_fail !< True if any of the unit tests fail + local_fail = .false. + local_fail = local_fail .or. allocated(buffer%buffer) + if (verbose) write(stdout,*) "new_buffer_2d: ", local_fail + local_fail = local_fail .or. allocated(buffer%ids) + if (verbose) write(stdout,*) "new_buffer_2d: ", local_fail + local_fail = local_fail .or. buffer%length /= 0 + if (verbose) write(stdout,*) "new_buffer_2d: ", local_fail + end function new_buffer_2d + + !> Test the growing of a buffer + function grow_buffer_2d() result(local_fail) + type(diag_buffer_2d) :: buffer + logical :: local_fail !< True if any of the unit tests fail + integer, parameter :: is=1, ie=2, js=3, je=6 + integer :: i + + local_fail = .false. + + call buffer%set_horizontal_extents(is=is, ie=ie, js=js, je=je) + ! Grow the buffer 3 times + do i=1,3 + call buffer%grow() + local_fail = local_fail .or. (buffer%length /= i) + local_fail = local_fail .or. (lbound(buffer%buffer(i)%field, 1) /= is) + local_fail = local_fail .or. (ubound(buffer%buffer(i)%field, 1) /= ie) + local_fail = local_fail .or. (lbound(buffer%buffer(i)%field, 2) /= js) + local_fail = local_fail .or. (ubound(buffer%buffer(i)%field, 2) /= je) + enddo + if (verbose) write(stdout,*) "grow_buffer_2d: ", local_fail + end function grow_buffer_2d + + !> Test that growing new buffer fills the array with a set fill value + function fill_value_2d() result(local_fail) + type(diag_buffer_2d) :: buffer + logical :: local_fail !< True if any of the unit tests fail + integer, parameter :: is=1, ie=2, js=3, je=6 + real, parameter :: fill_value = -123.456 + integer :: i + + + local_fail = .false. + + call buffer%set_horizontal_extents(is=is, ie=ie, js=js, je=je) + call buffer%set_fill_value(fill_value) + ! Grow the buffer 3 times + call buffer%grow() + if (any(buffer%buffer(1)%field(:,:) /= fill_value)) local_fail = .true. + if (verbose) write(stdout,*) "fill_value_2d: ", local_fail + end function fill_value_2d + + !> Test storing a buffer based on a unique id + function store_buffer_2d() result(local_fail) + type(diag_buffer_2d) :: buffer + logical :: local_fail !< True if any of the unit tests fail + + integer, parameter :: is=1, ie=2, js=3, je=6, nlen=3 + integer :: i, slot + real, allocatable, dimension(:,:,:) :: test_2d + + local_fail = .false. + + allocate(test_2d(nlen, is:ie, js:je)) + call random_number(test_2d) + buffer%is = is + buffer%ie = ie + buffer%js = js + buffer%je = je + + do i=1,nlen + call buffer%store(test_2d(i,:,:), i*3) + slot = buffer%find_buffer_slot(i*3) + local_fail = local_fail .or. ANY(buffer%buffer(slot)%field(:,:) /= test_2d(i,:,:)) + enddo + + if (verbose) write(stdout,*) "store_buffer_2d: ", local_fail + end function store_buffer_2d + + !> Test the reuse of a buffer. Fill it first like store_buffer_2d. Then, + !! loop through again, but use the slots of the buffer in the following + !! order: 2, 1, 3 + function reuse_buffer_2d() result(local_fail) + type(diag_buffer_2d) :: buffer + logical :: local_fail !< True if any of the unit tests fail + + integer, parameter :: is=1, ie=2, js=3, je=6, nlen=3 + integer :: i, new_i, id, new_id + real, dimension(nlen, is:ie, js:je) :: test_2d_first, test_2d_second + integer, dimension(nlen) :: reorder = [2,1,3] + + local_fail = .false. + call random_number(test_2d_first) + call random_number(test_2d_second) + + call buffer%set_horizontal_extents(is=is, ie=ie, js=js, je=je) + + do i=1,nlen + call buffer%store(test_2d_first(i,:,:), id=i*3) + enddo + + do i=1,nlen + new_i = reorder(i) + ! id and new_id are multiplied by primes to make sure they are unique + id = reorder(i)*3 + new_id = i*7 + call buffer%mark_available(id=reorder(i)*3) + call buffer%store(test_2d_second(i,:,:), id=new_id) + local_fail = local_fail .or. buffer%find_buffer_slot(new_id) /= new_i + test_2d_first(new_i,:,:) = test_2d_second(i,:,:) + enddo + local_fail = local_fail .or. any(buffer%ids /= [14, 7, 21]) + do i=1,nlen + local_fail = local_fail .or. any(buffer%buffer(i)%field(:,:) /= test_2d_first(i,:,:)) + enddo + if (verbose) write(stdout,*) "reuse_buffer_2d: ", local_fail + end function reuse_buffer_2d + +end function diag_buffer_unit_tests_2d + +!> Test the 3d version of the buffer +function diag_buffer_unit_tests_3d(verbose) result(fail) + logical, intent(in) :: verbose !< If true, write results to stdout + logical :: fail !< True if any of the unit tests fail + + fail = .false. + write(stdout,*) '==== MOM_diag_buffers: diag_buffers_unit_tests_3d ===' + fail = fail .or. new_buffer_3d() + fail = fail .or. grow_buffer_3d() + fail = fail .or. fill_value_3d() + fail = fail .or. store_buffer_3d() + fail = fail .or. reuse_buffer_3d() + + contains + + !> Ensure properties of a newly initialized buffer + function new_buffer_3d() result(local_fail) + type(diag_buffer_3d) :: buffer + logical :: local_fail !< True if any of the unit tests fail + local_fail = .false. + local_fail = local_fail .or. allocated(buffer%buffer) + local_fail = local_fail .or. allocated(buffer%ids) + local_fail = local_fail .or. buffer%length /= 0 + if (verbose) write(stdout,*) "new_buffer_3d: ", local_fail + end function new_buffer_3d + + !> Test the growing of a buffer + function grow_buffer_3d() result(local_fail) + type(diag_buffer_3d) :: buffer + logical :: local_fail !< True if any of the unit tests fail + integer, parameter :: is=1, ie=2, js=3, je=6, ks=1, ke=10 + integer :: i + + local_fail = .false. + + call buffer%set_horizontal_extents(is=is, ie=ie, js=js, je=je) + call buffer%set_vertical_extent(ks=ks, ke=ke) + ! Grow the buffer 3 times + do i=1,3 + call buffer%grow() + local_fail = local_fail .or. (buffer%length /= i) + local_fail = local_fail .or. (lbound(buffer%buffer(i)%field, 1) /= is) + local_fail = local_fail .or. (ubound(buffer%buffer(i)%field, 1) /= ie) + local_fail = local_fail .or. (lbound(buffer%buffer(i)%field, 2) /= js) + local_fail = local_fail .or. (ubound(buffer%buffer(i)%field, 2) /= je) + local_fail = local_fail .or. (lbound(buffer%buffer(i)%field, 3) /= ks) + local_fail = local_fail .or. (ubound(buffer%buffer(i)%field, 3) /= ke) + if (verbose) write(stdout,*) "grow_buffer_3d: ", local_fail + enddo + if (verbose) write(stdout,*) "grow_buffer_3d: ", local_fail + end function grow_buffer_3d + + !> Test that growing new buffer fills the array with a set fill value + function fill_value_3d() result(local_fail) + type(diag_buffer_3d) :: buffer + logical :: local_fail !< True if any of the unit tests fail + integer, parameter :: is=1, ie=2, js=3, je=6 + real, parameter :: fill_value = -123.456 + integer :: i + + + local_fail = .false. + + call buffer%set_horizontal_extents(is=is, ie=ie, js=js, je=je) + call buffer%set_fill_value(fill_value) + ! Grow the buffer 3 times + call buffer%grow() + if (any(buffer%buffer(1)%field(:,:,:) /= fill_value)) local_fail = .true. + if (verbose) write(stdout,*) "fill_value_3d: ", local_fail + end function fill_value_3d + + !> Test storing a buffer based on a unique id + function store_buffer_3d() result(local_fail) + type(diag_buffer_3d) :: buffer + logical :: local_fail !< True if any of the unit tests fail + + integer, parameter :: is=1, ie=2, js=3, je=6, ks=1, ke=10, nlen=3 + integer :: i, slot + real, dimension(nlen,is:ie,js:je,ks:ke) :: test_3d + + local_fail = .false. + call random_number(test_3d) + buffer%is = is + buffer%ie = ie + buffer%js = js + buffer%je = je + buffer%ks = ks + buffer%ke = ke + + do i=1,nlen + call buffer%store(test_3d(i,:,:,:), i*3) + slot = buffer%find_buffer_slot(i*3) + local_fail = local_fail .or. ANY(buffer%buffer(slot)%field(:,:,:) /= test_3d(i,:,:,:)) + enddo + + if (verbose) write(stdout,*) "store_buffer_3d: ", local_fail + end function store_buffer_3d + + !> Test the reuse of a buffer. Fill it first like store_buffer_3d. Then, + !! loop through again, but use the slots of the buffer in the following + !! order: 2, 1, 3 + function reuse_buffer_3d() result(local_fail) + type(diag_buffer_3d) :: buffer + logical :: local_fail !< True if any of the unit tests fail + + integer, parameter :: is=1, ie=2, js=3, je=6, ks=1, ke=10, nlen=3 + integer :: i, new_i, id, new_id + real, dimension(nlen, is:ie, js:je, ks:ke) :: test_3d_first, test_3d_second + integer, dimension(nlen) :: reorder = [2,1,3] + + local_fail = .false. + call random_number(test_3d_first) + call random_number(test_3d_second) + + buffer%is = is + buffer%ie = ie + buffer%js = js + buffer%je = je + buffer%ks = ks + buffer%ke = ke + + do i=1,nlen + call buffer%store(test_3d_first(i,:,:,:), id=i*3) + enddo + + do i=1,nlen + new_i = reorder(i) + ! id and new_id are multiplied by primes to make sure they are unique + id = reorder(i)*3 + new_id = i*7 + call buffer%mark_available(id=reorder(i)*3) + call buffer%store(test_3d_second(i,:,:,:), id=new_id) + local_fail = local_fail .or. buffer%find_buffer_slot(new_id) /= new_i + test_3d_first(new_i,:,:,:) = test_3d_second(i,:,:,:) + enddo + local_fail = local_fail .or. any(buffer%ids /= [14, 7, 21]) + do i=1,nlen + local_fail = local_fail .or. any(buffer%buffer(i)%field(:,:,:) /= test_3d_first(i,:,:,:)) + enddo + if (verbose) write(stdout,*) "reuse_buffer_3d: ", local_fail + end function reuse_buffer_3d + +end function diag_buffer_unit_tests_3d + +end module MOM_diag_buffers + diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index eb24c994f8..86d6015598 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -1,19 +1,22 @@ -!> The subroutines here provide convenient wrappers to the fms diag_manager -!! interfaces with additional diagnostic capabilies. -module MOM_diag_mediator +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 -! This file is part of MOM6. See LICENSE.md for the license. +!> The subroutines here provide convenient wrappers to the FMS diag_manager +!! interfaces with additional diagnostic capabilities. +module MOM_diag_mediator -use MOM_checksums, only : chksum0, zchksum -use MOM_checksums, only : hchksum, uchksum, vchksum, Bchksum +use MOM_checksums, only : chksum0, zchksum, hchksum, uchksum, vchksum, Bchksum use MOM_coms, only : PE_here use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diag_buffers, only : diag_buffer_2d, diag_buffer_3d use MOM_diag_manager_infra, only : MOM_diag_manager_init, MOM_diag_manager_end use MOM_diag_manager_infra, only : diag_axis_init=>MOM_diag_axis_init, get_MOM_diag_axis_name use MOM_diag_manager_infra, only : send_data_infra, MOM_diag_field_add_attribute, EAST, NORTH use MOM_diag_manager_infra, only : register_diag_field_infra, register_static_field_infra use MOM_diag_manager_infra, only : get_MOM_diag_field_id, DIAG_FIELD_NOT_FOUND +use MOM_diag_manager_infra, only : diag_send_complete_infra use MOM_diag_remap, only : diag_remap_ctrl, diag_remap_update, diag_remap_calc_hmask use MOM_diag_remap, only : diag_remap_init, diag_remap_end, diag_remap_do_remap use MOM_diag_remap, only : vertically_reintegrate_diag_field, vertically_interpolate_diag_field @@ -21,15 +24,18 @@ module MOM_diag_mediator use MOM_diag_remap, only : diag_remap_configure_axes, diag_remap_axes_configured use MOM_diag_remap, only : diag_remap_diag_registration_closed, diag_remap_set_active use MOM_EOS, only : EOS_type -use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe, assert +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe, assert, callTree_showQuery +use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_io, only : slasher, vardesc, query_vardesc, MOM_read_data +use MOM_interface_heights, only : thickness_to_dz +use MOM_io, only : vardesc, query_vardesc use MOM_io, only : get_filename_appendix use MOM_safe_alloc, only : safe_alloc_ptr, safe_alloc_alloc -use MOM_string_functions, only : lowercase -use MOM_time_manager, only : time_type +use MOM_string_functions, only : lowercase, slasher, ints_to_string, trim_trailing_commas +use MOM_time_manager, only : time_type, get_time use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -39,8 +45,11 @@ module MOM_diag_mediator #define MAX_DSAMP_LEV 2 public set_axes_info, post_data, register_diag_field, time_type +public post_data_3d_by_column, post_data_3d_final public post_product_u, post_product_sum_u, post_product_v, post_product_sum_v -public set_masks_for_axes +public set_masks_for_axes, MOM_diag_send_complete +! post_data_1d_k is a deprecated interface that can be replaced by a call to post_data, but +! it is being retained for backward compatibility to older versions of the ocean_BGC code. public post_data_1d_k public safe_alloc_ptr, safe_alloc_alloc public enable_averaging, enable_averages, disable_averaging, query_averaging_enabled @@ -50,6 +59,7 @@ module MOM_diag_mediator public diag_axis_init, ocean_register_diag, register_static_field public register_scalar_field public define_axes_group, diag_masks_set +public set_piecemeal_extents public diag_register_area_ids public register_cell_measure, diag_associate_volume_cell_measure public diag_get_volume_cell_measure_dm_id @@ -64,6 +74,11 @@ module MOM_diag_mediator module procedure post_data_3d, post_data_2d, post_data_1d_k, post_data_0d end interface post_data +!> Registers a non-array scalar diagnostic, returning an integer handle +interface register_scalar_field + module procedure register_scalar_field_CS, register_scalar_field_axes +end interface register_scalar_field + !> Down sample a field interface downsample_field module procedure downsample_field_2d, downsample_field_3d @@ -81,8 +96,8 @@ module MOM_diag_mediator !> Contained for down sampled masks type, private :: diag_dsamp - real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes - real, pointer, dimension(:,:,:) :: mask3d => null() !< Mask for 3d axes + real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes [nondim] + real, pointer, dimension(:,:,:) :: mask3d => null() !< Mask for 3d axes [nondim] end type diag_dsamp !> A group of 1D axes that comprise a 1D/2D/3D mesh @@ -118,21 +133,25 @@ module MOM_diag_mediator !! interface-located field that must be interpolated to !! these axes. Used for rank>2. integer :: downsample_level = 1 !< If greater than 1, the factor by which this diagnostic/axes/masks be downsampled - ! For horizontally averaged diagnositcs (applies to 2d and 3d fields only) - type(axes_grp), pointer :: xyave_axes => null() !< The associated 1d axes for horizontall area-averaged diagnostics + ! For horizontally averaged diagnostics (applies to 2d and 3d fields only) + type(axes_grp), pointer :: xyave_axes => null() !< The associated 1d axes for horizontally area-averaged diagnostics ! ID's for cell_measures integer :: id_area = -1 !< The diag_manager id for area to be used for cell_measure of variables with this axes_grp. integer :: id_volume = -1 !< The diag_manager id for volume to be used for cell_measure of variables !! with this axes_grp. ! For masking - real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes - real, pointer, dimension(:,:,:) :: mask3d => null() !< Mask for 3d axes + real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes [nondim] + real, pointer, dimension(:,:,:) :: mask3d => null() !< Mask for 3d axes [nondim] type(diag_dsamp), dimension(2:MAX_DSAMP_LEV) :: dsamp !< Downsample container + + ! For diagnostics posted piecemeal + type(diag_buffer_2d) :: piecemeal_2d !< A dynamically reallocated buffer for 2d piecemeal diagnostics + type(diag_buffer_3d) :: piecemeal_3d !< A dynamically reallocated buffer for 3d piecemeal diagnostics end type axes_grp !> Contains an array to store a diagnostic target grid type, private :: diag_grids_type - real, dimension(:,:,:), allocatable :: h !< Target grid for remapped coordinate + real, dimension(:,:,:), allocatable :: h !< Target grid for remapped coordinate [H ~> m or kg m-2] or [Z ~> m] end type diag_grids_type !> Stores all the remapping grids and the model's native space thicknesses @@ -154,7 +173,7 @@ module MOM_diag_mediator integer :: PMM=133 !< x:point,y:mean,z:mean integer :: SPP=211 !< x:sum,y:point,z:point integer :: SPS=212 !< x:sum,y:point,z:sum -integer :: SSP=221 !< x:sum;y:sum,z:point +integer :: SSP=221 !< x:sum,y:sum,z:point integer :: MPP=311 !< x:mean,y:point,z:point integer :: MPM=313 !< x:mean,y:point,z:mean integer :: MMP=331 !< x:mean,y:mean,z:point @@ -165,7 +184,7 @@ module MOM_diag_mediator !> This type is used to represent a diagnostic at the diag_mediator level. !! -!! There can be both 'primary' and 'seconday' diagnostics. The primaries +!! There can be both 'primary' and 'secondary' diagnostics. The primaries !! reside in the diag_cs%diags array. They have an id which is an index !! into this array. The secondaries are 'variations' on the primary diagnostic. !! For example the CMOR diagnostics are secondary. The secondary diagnostics @@ -175,10 +194,11 @@ module MOM_diag_mediator integer :: fms_diag_id !< Underlying FMS diag_manager id. integer :: fms_xyave_diag_id = -1 !< For a horizontally area-averaged diagnostic. integer :: downsample_diag_id = -1 !< For a horizontally area-downsampled diagnostic. - character(64) :: debug_str = '' !< For FATAL errors and debugging. + character(len=64) :: debug_str = '' !< The diagnostic name and module for FATAL errors and debugging. type(axes_grp), pointer :: axes => null() !< The axis group for this diagnostic type(diag_type), pointer :: next => null() !< Pointer to the next diagnostic - real :: conversion_factor = 0. !< A factor to multiply data by before posting to FMS, if non-zero. + real :: conversion_factor = 0. !< If non-zero, a factor to multiply data by before posting to FMS, + !! often including factors to undo internal scaling in units of [a A-1 ~> 1] logical :: v_extensive = .false. !< True for vertically extensive fields (vertically integrated). !! False for intensive (concentrations). integer :: xyz_method = 0 !< A 3 digit integer encoding the diagnostics cell method @@ -212,11 +232,11 @@ module MOM_diag_mediator type(axes_grp), dimension(:), allocatable :: remap_axesTi, remap_axesBi, remap_axesCui, remap_axesCvi !>@} - real, dimension(:,:), pointer :: mask2dT => null() !< 2D mask array for cell-center points - real, dimension(:,:), pointer :: mask2dBu => null() !< 2D mask array for cell-corner points - real, dimension(:,:), pointer :: mask2dCu => null() !< 2D mask array for east-face points - real, dimension(:,:), pointer :: mask2dCv => null() !< 2D mask array for north-face points - !>@{ 3D mask arrays for diagnostics at layers (mask...L) and interfaces (mask...i) + real, dimension(:,:), pointer :: mask2dT => null() !< 2D mask array for cell-center points [nondim] + real, dimension(:,:), pointer :: mask2dBu => null() !< 2D mask array for cell-corner points [nondim] + real, dimension(:,:), pointer :: mask2dCu => null() !< 2D mask array for east-face points [nondim] + real, dimension(:,:), pointer :: mask2dCv => null() !< 2D mask array for north-face points [nondim] + !>@{ 3D mask arrays for diagnostics at layers (mask...L) and interfaces (mask...i), all [nondim] real, dimension(:,:,:), pointer :: mask3dTL => null() real, dimension(:,:,:), pointer :: mask3dBL => null() real, dimension(:,:,:), pointer :: mask3dCuL => null() @@ -236,21 +256,24 @@ module MOM_diag_mediator integer :: chksum_iounit = -1 !< The unit number of a diagnostic documentation file. !! This file is open if available_diag_doc_unit is > 0. logical :: diag_as_chksum !< If true, log chksums in a text file instead of posting diagnostics - logical :: grid_space_axes !< If true, diagnostic horizontal coordinates axes are in grid space. -! The following fields are used for the output of the data. + logical :: show_call_tree !< Display the call tree while running. Set by VERBOSITY level. + logical :: index_space_axes !< If true, diagnostic horizontal coordinates axes are in index space. + + ! The following fields are used for the output of the data. + ! These give the computational-domain sizes, and are relative to a start value + ! of 1 in memory for the tracer-point arrays. integer :: is !< The start i-index of cell centers within the computational domain integer :: ie !< The end i-index of cell centers within the computational domain integer :: js !< The start j-index of cell centers within the computational domain integer :: je !< The end j-index of cell centers within the computational domain - + ! These give the memory-domain sizes, and can start at any value on each PE. integer :: isd !< The start i-index of cell centers within the data domain integer :: ied !< The end i-index of cell centers within the data domain integer :: jsd !< The start j-index of cell centers within the data domain integer :: jed !< The end j-index of cell centers within the data domain real :: time_int !< The time interval for any fields !! that are offered for averaging [s]. - type(time_type) :: time_end !< The end time of the valid - !! interval for any offered field. + type(time_type) :: time_end !< The end time of the valid interval for any offered field. logical :: ave_enabled = .false. !< True if averaging is enabled. !>@{ The following are 3D and 2D axis groups defined for output. The names @@ -263,11 +286,12 @@ module MOM_diag_mediator type(axes_grp) :: axesZL !< A 1-D z-space axis at layer centers type(axes_grp) :: axesNull !< An axis group for scalars - real, dimension(:,:), pointer :: mask2dT => null() !< 2D mask array for cell-center points - real, dimension(:,:), pointer :: mask2dBu => null() !< 2D mask array for cell-corner points - real, dimension(:,:), pointer :: mask2dCu => null() !< 2D mask array for east-face points - real, dimension(:,:), pointer :: mask2dCv => null() !< 2D mask array for north-face points - !>@{ 3D mask arrays for diagnostics at layers (mask...L) and interfaces (mask...i) + ! Mask arrays for 2D diagnostics + real, dimension(:,:), pointer :: mask2dT => null() !< 2D mask array for cell-center points [nondim] + real, dimension(:,:), pointer :: mask2dBu => null() !< 2D mask array for cell-corner points [nondim] + real, dimension(:,:), pointer :: mask2dCu => null() !< 2D mask array for east-face points [nondim] + real, dimension(:,:), pointer :: mask2dCv => null() !< 2D mask array for north-face points [nondim] + !>@{ 3D mask arrays for diagnostics at layers (mask...L) and interfaces (mask...i) all [nondim] real, dimension(:,:,:), pointer :: mask3dTL => null() real, dimension(:,:,:), pointer :: mask3dBL => null() real, dimension(:,:,:), pointer :: mask3dCuL => null() @@ -287,8 +311,8 @@ module MOM_diag_mediator type(diag_type), dimension(:), allocatable :: diags !< The list of diagnostics integer :: next_free_diag_id !< The next unused diagnostic ID - !> default missing value to be sent to ALL diagnostics registrations - real :: missing_value = -1.0e+34 + !> default missing value to be sent to ALL diagnostics registrations [various] + real :: missing_value = -1.0e34 !> Number of diagnostic vertical coordinates (remapped) integer :: num_diag_coords @@ -307,9 +331,11 @@ module MOM_diag_mediator ! Pointer to H, G and T&S needed for remapping real, dimension(:,:,:), pointer :: h => null() !< The thicknesses needed for remapping [H ~> m or kg m-2] - real, dimension(:,:,:), pointer :: T => null() !< The temperatures needed for remapping [degC] - real, dimension(:,:,:), pointer :: S => null() !< The salinities needed for remapping [ppt] - type(EOS_type), pointer :: eqn_of_state => null() !< The equation of state type + real, dimension(:,:,:), pointer :: T => null() !< The temperatures needed for remapping [C ~> degC] + real, dimension(:,:,:), pointer :: S => null() !< The salinities needed for remapping [S ~> ppt] + type(EOS_type), pointer :: eqn_of_state => null() !< The equation of state type + type(thermo_var_ptrs), pointer :: tv => null() !< A structure with thermodynamic variables that are + !! used to convert thicknesses to vertical extents type(ocean_grid_type), pointer :: G => null() !< The ocean grid type type(verticalGrid_type), pointer :: GV => null() !< The model's vertical ocean grid type(unit_scale_type), pointer :: US => null() !< A dimensional unit scaling type @@ -327,7 +353,9 @@ module MOM_diag_mediator integer :: num_chksum_diags real, dimension(:,:,:), allocatable :: h_begin !< Layer thicknesses at the beginning of the timestep used - !! for remapping of extensive variables + !! for remapping of extensive variables [H ~> m or kg m-2] + real, dimension(:,:,:), allocatable :: dz_begin !< Layer vertical extents at the beginning of the timestep used + !! for remapping of extensive variables [Z ~> m] end type diag_ctrl @@ -349,68 +377,65 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) ! Local variables integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh, id_null integer :: id_zl_native, id_zi_native - integer :: i, j, k, nz - real :: zlev(GV%ke), zinter(GV%ke+1) + integer :: i, j, nz + real :: zlev(GV%ke) ! Numerical values for layer vertical coordinates, in unscaled units + ! that might be [m], [kg m-3] or [nondim], depending on the coordinate. + real :: zinter(GV%ke+1) ! Numerical values for interface vertical coordinates, in unscaled units + ! that might be [m], [kg m-3] or [nondim], depending on the coordinate. logical :: set_vert - real, allocatable, dimension(:) :: IaxB,iax - real, allocatable, dimension(:) :: JaxB,jax - + real, allocatable, dimension(:) :: IaxB, iax ! Index-based integer and half-integer i-axis labels [nondim] + real, allocatable, dimension(:) :: JaxB, jax ! Index-based integer and half-integer j-axis labels [nondim] set_vert = .true. ; if (present(set_vertical)) set_vert = set_vertical - - if (diag_cs%grid_space_axes) then + if (diag_cs%index_space_axes) then allocate(IaxB(G%IsgB:G%IegB)) - do i=G%IsgB, G%IegB - Iaxb(i)=real(i) + do I=G%IsgB,G%IegB + Iaxb(I) = real(I) enddo allocate(iax(G%isg:G%ieg)) - do i=G%isg, G%ieg - iax(i)=real(i)-0.5 + do i=G%isg,G%ieg + iax(i) = real(i)-0.5 enddo allocate(JaxB(G%JsgB:G%JegB)) - do j=G%JsgB, G%JegB - JaxB(j)=real(j) + do J=G%JsgB,G%JegB + JaxB(J) = real(J) enddo allocate(jax(G%jsg:G%jeg)) - do j=G%jsg, G%jeg - jax(j)=real(j)-0.5 + do j=G%jsg,G%jeg + jax(j) = real(j)-0.5 enddo endif ! Horizontal axes for the native grids - if (G%symmetric) then - if (diag_cs%grid_space_axes) then - id_xq = diag_axis_init('iq', IaxB(G%isgB:G%iegB), 'none', 'x', & - 'q point grid-space longitude', G%Domain, position=EAST) - id_yq = diag_axis_init('jq', JaxB(G%jsgB:G%jegB), 'none', 'y', & - 'q point grid space latitude', G%Domain, position=NORTH) + if (diag_cs%index_space_axes) then + if (G%symmetric) then + id_xq = diag_axis_init('Iq', IaxB(G%IsgB:G%IegB), 'none', 'x', & + 'Boundary (q) point grid-space longitude', G%Domain, position=EAST) + id_yq = diag_axis_init('Jq', JaxB(G%JsgB:G%JegB), 'none', 'y', & + 'Boundary (q) point grid-space latitude', G%Domain, position=NORTH) else - id_xq = diag_axis_init('xq', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & - 'q point nominal longitude', G%Domain, position=EAST) - id_yq = diag_axis_init('yq', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & - 'q point nominal latitude', G%Domain, position=NORTH) - endif - else - if (diag_cs%grid_space_axes) then id_xq = diag_axis_init('Iq', IaxB(G%isg:G%ieg), 'none', 'x', & - 'q point grid-space longitude', G%Domain, position=EAST) + 'Boundary (q) point grid-space longitude', G%Domain, position=EAST) id_yq = diag_axis_init('Jq', JaxB(G%jsg:G%jeg), 'none', 'y', & - 'q point grid space latitude', G%Domain, position=NORTH) + 'Boundary (q) point grid-space latitude', G%Domain, position=NORTH) + endif + id_xh = diag_axis_init('ih', iax(G%isg:G%ieg), 'none', 'x', & + 'Tracer (h) point grid-space longitude', G%Domain) + id_yh = diag_axis_init('jh', jax(G%jsg:G%jeg), 'none', 'y', & + 'Tracer (h) point grid-space latitude', G%Domain) + else + if (G%symmetric) then + id_xq = diag_axis_init('xq', G%gridLonB(G%IsgB:G%IegB), G%x_axis_units, 'x', & + 'q point nominal longitude', G%Domain, position=EAST) + id_yq = diag_axis_init('yq', G%gridLatB(G%JsgB:G%JegB), G%y_axis_units, 'y', & + 'q point nominal latitude', G%Domain, position=NORTH) else id_xq = diag_axis_init('xq', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', & 'q point nominal longitude', G%Domain, position=EAST) id_yq = diag_axis_init('yq', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', & 'q point nominal latitude', G%Domain, position=NORTH) endif - endif - - if (diag_cs%grid_space_axes) then - id_xh = diag_axis_init('ih', iax(G%isg:G%ieg), 'none', 'x', & - 'h point grid-space longitude', G%Domain, position=EAST) - id_yh = diag_axis_init('jh', jax(G%jsg:G%jeg), 'none', 'y', & - 'h point grid space latitude', G%Domain, position=NORTH) - else id_xh = diag_axis_init('xh', G%gridLonT(G%isg:G%ieg), G%x_axis_units, 'x', & 'h point nominal longitude', G%Domain) id_yh = diag_axis_init('yh', G%gridLatT(G%jsg:G%jeg), G%y_axis_units, 'y', & @@ -473,11 +498,14 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) call define_axes_group(diag_cs, (/ id_xh, id_yq /), diag_cs%axesCv1, & x_cell_method='mean', y_cell_method='point', is_v_point=.true.) - ! Axis group for special null axis from diag manager. + ! Define array extents for all piecemeal buffers + call set_piecemeal_extents(diag_cs) + + ! Axis group for special null axis for scalars from diag manager. id_null = diag_axis_init('scalar_axis', (/0./), 'none', 'N', 'none', null_axis=.true.) call define_axes_group(diag_cs, (/ id_null /), diag_cs%axesNull) - !Non-native Non-downsampled + ! Set axis groups for non-native, non-downsampled grids if (diag_cs%num_diag_coords>0) then allocate(diag_cs%remap_axesZL(diag_cs%num_diag_coords)) allocate(diag_cs%remap_axesTL(diag_cs%num_diag_coords)) @@ -493,7 +521,7 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) do i=1, diag_cs%num_diag_coords ! For each possible diagnostic coordinate - call diag_remap_configure_axes(diag_cs%diag_remap_cs(i), GV, US, param_file) + call diag_remap_configure_axes(diag_cs%diag_remap_cs(i), G, GV, US, param_file) ! Allocate these arrays since the size of the diagnostic array is now known allocate(diag_cs%diag_remap_cs(i)%h(G%isd:G%ied,G%jsd:G%jed, diag_cs%diag_remap_cs(i)%nz)) @@ -567,10 +595,10 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) endif enddo - if (diag_cs%grid_space_axes) then + if (diag_cs%index_space_axes) then deallocate(IaxB, iax, JaxB, jax) endif - !Define the downsampled axes + ! Define the downsampled axes call set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_native) call diag_grid_storage_init(diag_CS%diag_grid_temp, G, GV, diag_CS) @@ -587,48 +615,57 @@ subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_n ! Local variables integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh - integer :: i, j, k, nz, dl - real, dimension(:), pointer :: gridLonT_dsamp =>NULL() - real, dimension(:), pointer :: gridLatT_dsamp =>NULL() - real, dimension(:), pointer :: gridLonB_dsamp =>NULL() - real, dimension(:), pointer :: gridLatB_dsamp =>NULL() + integer :: i, j, nz, dl + real, dimension(:), pointer :: gridLonT_dsamp =>NULL() ! The longitude of downsampled T points for labeling + ! the output axes, often in units of [degrees_N] or + ! [km] or [m] or [gridpoints]. + real, dimension(:), pointer :: gridLatT_dsamp =>NULL() ! The latitude of downsampled T points for labeling + ! the output axes, often in units of [degrees_N] or + ! [km] or [m] or [gridpoints]. + real, dimension(:), pointer :: gridLonB_dsamp =>NULL() ! The longitude of downsampled B points for labeling + ! the output axes, often in units of [degrees_N] or + ! [km] or [m] or [gridpoints]. + real, dimension(:), pointer :: gridLatB_dsamp =>NULL() ! The latitude of downsampled B points for labeling + ! the output axes, often in units of [degrees_N] or + ! [km] or [m] or [gridpoints]. + id_zl = id_zl_native ; id_zi = id_zi_native - !Axes group for native downsampled diagnostics + ! Axes group for native downsampled diagnostics do dl=2,MAX_DSAMP_LEV if (dl /= 2) call MOM_error(FATAL, "set_axes_info_dsamp: Downsample level other than 2 is not supported yet!") if (G%symmetric) then allocate(gridLonB_dsamp(diag_cs%dsamp(dl)%isgB:diag_cs%dsamp(dl)%iegB)) allocate(gridLatB_dsamp(diag_cs%dsamp(dl)%jsgB:diag_cs%dsamp(dl)%jegB)) - do i=diag_cs%dsamp(dl)%isgB,diag_cs%dsamp(dl)%iegB; gridLonB_dsamp(i) = G%gridLonB(G%isgB+dl*i); enddo - do j=diag_cs%dsamp(dl)%jsgB,diag_cs%dsamp(dl)%jegB; gridLatB_dsamp(j) = G%gridLatB(G%jsgB+dl*j); enddo + do i=diag_cs%dsamp(dl)%isgB,diag_cs%dsamp(dl)%iegB ; gridLonB_dsamp(i) = G%gridLonB(G%isgB+dl*i) ; enddo + do j=diag_cs%dsamp(dl)%jsgB,diag_cs%dsamp(dl)%jegB ; gridLatB_dsamp(j) = G%gridLatB(G%jsgB+dl*j) ; enddo id_xq = diag_axis_init('xq', gridLonB_dsamp, G%x_axis_units, 'x', & 'q point nominal longitude', G%Domain, coarsen=2) id_yq = diag_axis_init('yq', gridLatB_dsamp, G%y_axis_units, 'y', & 'q point nominal latitude', G%Domain, coarsen=2) - deallocate(gridLonB_dsamp,gridLatB_dsamp) + deallocate(gridLonB_dsamp, gridLatB_dsamp) else allocate(gridLonB_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg)) allocate(gridLatB_dsamp(diag_cs%dsamp(dl)%jsg:diag_cs%dsamp(dl)%jeg)) - do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridLonB_dsamp(i) = G%gridLonB(G%isg+dl*i-2); enddo - do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridLatB_dsamp(j) = G%gridLatB(G%jsg+dl*j-2); enddo + do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg ; gridLonB_dsamp(i) = G%gridLonB(G%isg+dl*i-2) ; enddo + do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg ; gridLatB_dsamp(j) = G%gridLatB(G%jsg+dl*j-2) ; enddo id_xq = diag_axis_init('xq', gridLonB_dsamp, G%x_axis_units, 'x', & 'q point nominal longitude', G%Domain, coarsen=2) id_yq = diag_axis_init('yq', gridLatB_dsamp, G%y_axis_units, 'y', & 'q point nominal latitude', G%Domain, coarsen=2) - deallocate(gridLonB_dsamp,gridLatB_dsamp) + deallocate(gridLonB_dsamp, gridLatB_dsamp) endif allocate(gridLonT_dsamp(diag_cs%dsamp(dl)%isg:diag_cs%dsamp(dl)%ieg)) allocate(gridLatT_dsamp(diag_cs%dsamp(dl)%jsg:diag_cs%dsamp(dl)%jeg)) - do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg; gridLonT_dsamp(i) = G%gridLonT(G%isg+dl*i-2); enddo - do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg; gridLatT_dsamp(j) = G%gridLatT(G%jsg+dl*j-2); enddo + do i=diag_cs%dsamp(dl)%isg,diag_cs%dsamp(dl)%ieg ; gridLonT_dsamp(i) = G%gridLonT(G%isg+dl*i-2) ; enddo + do j=diag_cs%dsamp(dl)%jsg,diag_cs%dsamp(dl)%jeg ; gridLatT_dsamp(j) = G%gridLatT(G%jsg+dl*j-2) ; enddo id_xh = diag_axis_init('xh', gridLonT_dsamp, G%x_axis_units, 'x', & 'h point nominal longitude', G%Domain, coarsen=2) id_yh = diag_axis_init('yh', gridLatT_dsamp, G%y_axis_units, 'y', & 'h point nominal latitude', G%Domain, coarsen=2) - deallocate(gridLonT_dsamp,gridLatT_dsamp) + deallocate(gridLonT_dsamp, gridLatT_dsamp) ! Axis groupings for the model layers call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yh, id_zL /), diag_cs%dsamp(dl)%axesTL, dl, & @@ -668,7 +705,7 @@ subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_n call define_axes_group_dsamp(diag_cs, (/ id_xh, id_yq /), diag_cs%dsamp(dl)%axesCv1, dl, & x_cell_method='mean', y_cell_method='point', is_v_point=.true.) - !Non-native axes + ! Axis groupings with a non-native vertical coordinate if (diag_cs%num_diag_coords>0) then allocate(diag_cs%dsamp(dl)%remap_axesTL(diag_cs%num_diag_coords)) allocate(diag_cs%dsamp(dl)%remap_axesBL(diag_cs%num_diag_coords)) @@ -682,7 +719,7 @@ subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_n do i=1, diag_cs%num_diag_coords ! For each possible diagnostic coordinate - !call diag_remap_configure_axes(diag_cs%diag_remap_cs(i), GV, param_file) + ! call diag_remap_configure_axes(diag_cs%diag_remap_cs(i), G, GV, param_file) ! This vertical coordinate has been configured so can be used. if (diag_remap_axes_configured(diag_cs%diag_remap_cs(i))) then @@ -755,7 +792,7 @@ subroutine set_masks_for_axes(G, diag_cs) type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables !! used for diagnostics ! Local variables - integer :: c, nk, i, j, k, ii, jj + integer :: c, nk, i, j, k type(axes_grp), pointer :: axes => NULL(), h_axes => NULL() ! Current axes, for convenience do c=1, diag_cs%num_diag_coords @@ -843,7 +880,7 @@ subroutine set_masks_for_axes(G, diag_cs) endif enddo - !Allocate and initialize the downsampled masks for the axes + ! Allocate and initialize the downsampled masks for the axes call set_masks_for_axes_dsamp(G, diag_cs) end subroutine set_masks_for_axes @@ -853,56 +890,63 @@ subroutine set_masks_for_axes_dsamp(G, diag_cs) type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables !! used for diagnostics ! Local variables - integer :: c, nk, i, j, k, ii, jj - integer :: dl - type(axes_grp), pointer :: axes => NULL(), h_axes => NULL() ! Current axes, for convenience + integer :: c, dl + type(axes_grp), pointer :: axes => NULL() ! Current axes, for convenience - !Each downsampled axis needs both downsampled and non-downsampled mask - !The downsampled mask is needed for sending out the diagnostics output via diag_manager - !The non-downsampled mask is needed for downsampling the diagnostics field + ! Each downsampled axis needs both downsampled and non-downsampled masks. + ! The downsampled mask is needed for sending out the diagnostics output via diag_manager. + ! The non-downsampled mask is needed for downsampling the diagnostics field. do dl=2,MAX_DSAMP_LEV if (dl /= 2) call MOM_error(FATAL, "set_masks_for_axes_dsamp: Downsample level other than 2 is not supported!") do c=1, diag_cs%num_diag_coords ! Level/layer h-points in diagnostic coordinate axes => diag_cs%remap_axesTL(c) - call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTL(c)%dsamp(dl)%mask3d, dl,G%isc, G%jsc, & + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTL(c)%dsamp(dl)%mask3d, & + dl, G%isc, G%jsc, G%isd, G%jsd, & G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec, G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed) - diag_cs%dsamp(dl)%remap_axesTL(c)%mask3d => axes%mask3d !set non-downsampled mask + diag_cs%dsamp(dl)%remap_axesTL(c)%mask3d => axes%mask3d ! Set a pointer to the non-downsampled mask ! Level/layer u-points in diagnostic coordinate axes => diag_cs%remap_axesCuL(c) - call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCuL(c)%dsamp(dl)%mask3d, dl,G%IscB,G%JscB, & - G%HId2%IscB,G%HId2%IecB,G%HId2%jsc, G%HId2%jec,G%HId2%IsdB,G%HId2%IedB,G%HId2%jsd, G%HId2%jed) - diag_cs%dsamp(dl)%remap_axesCul(c)%mask3d => axes%mask3d !set non-downsampled mask + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCuL(c)%dsamp(dl)%mask3d, & + dl, G%IscB, G%jsc, G%IsdB, G%jsd, & + G%HId2%IscB, G%HId2%IecB, G%HId2%jsc, G%HId2%jec, G%HId2%IsdB, G%HId2%IedB, G%HId2%jsd, G%HId2%jed) + diag_cs%dsamp(dl)%remap_axesCul(c)%mask3d => axes%mask3d ! Set a pointer to the non-downsampled mask ! Level/layer v-points in diagnostic coordinate axes => diag_cs%remap_axesCvL(c) - call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvL(c)%dsamp(dl)%mask3d, dl,G%isc ,G%JscB, & - G%HId2%isc ,G%HId2%iec, G%HId2%JscB,G%HId2%JecB,G%HId2%isd ,G%HId2%ied, G%HId2%JsdB,G%HId2%JedB) - diag_cs%dsamp(dl)%remap_axesCvL(c)%mask3d => axes%mask3d !set non-downsampled mask + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvL(c)%dsamp(dl)%mask3d, & + dl, G%isc, G%JscB, G%isd, G%JsdB, & + G%HId2%isc, G%HId2%iec, G%HId2%JscB, G%HId2%JecB, G%HId2%isd, G%HId2%ied, G%HId2%JsdB, G%HId2%JedB) + diag_cs%dsamp(dl)%remap_axesCvL(c)%mask3d => axes%mask3d ! Set a pointer to the non-downsampled mask ! Level/layer q-points in diagnostic coordinate axes => diag_cs%remap_axesBL(c) - call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBL(c)%dsamp(dl)%mask3d, dl,G%IscB,G%JscB, & - G%HId2%IscB,G%HId2%IecB,G%HId2%JscB,G%HId2%JecB,G%HId2%IsdB,G%HId2%IedB,G%HId2%JsdB,G%HId2%JedB) - diag_cs%dsamp(dl)%remap_axesBL(c)%mask3d => axes%mask3d !set non-downsampled mask + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBL(c)%dsamp(dl)%mask3d, & + dl, G%IscB, G%JscB, G%IsdB, G%JsdB, & + G%HId2%IscB, G%HId2%IecB, G%HId2%JscB, G%HId2%JecB, G%HId2%IsdB, G%HId2%IedB, G%HId2%JsdB, G%HId2%JedB) + diag_cs%dsamp(dl)%remap_axesBL(c)%mask3d => axes%mask3d ! Set a pointer to the non-downsampled mask ! Interface h-points in diagnostic coordinate (w-point) axes => diag_cs%remap_axesTi(c) - call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTi(c)%dsamp(dl)%mask3d, dl,G%isc, G%jsc, & + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTi(c)%dsamp(dl)%mask3d, & + dl, G%isc, G%jsc, G%isd, G%jsd, & G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec, G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed) - diag_cs%dsamp(dl)%remap_axesTi(c)%mask3d => axes%mask3d !set non-downsampled mask + diag_cs%dsamp(dl)%remap_axesTi(c)%mask3d => axes%mask3d ! Set a pointer to the non-downsampled mask ! Interface u-points in diagnostic coordinate axes => diag_cs%remap_axesCui(c) - call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCui(c)%dsamp(dl)%mask3d, dl,G%IscB,G%JscB, & - G%HId2%IscB,G%HId2%IecB,G%HId2%jsc, G%HId2%jec,G%HId2%IsdB,G%HId2%IedB,G%HId2%jsd, G%HId2%jed) - diag_cs%dsamp(dl)%remap_axesCui(c)%mask3d => axes%mask3d !set non-downsampled mask + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCui(c)%dsamp(dl)%mask3d, & + dl, G%IscB, G%jsc, G%IsdB, G%jsd, & + G%HId2%IscB, G%HId2%IecB, G%HId2%jsc, G%HId2%jec, G%HId2%IsdB, G%HId2%IedB, G%HId2%jsd, G%HId2%jed) + diag_cs%dsamp(dl)%remap_axesCui(c)%mask3d => axes%mask3d ! Set a pointer to the non-downsampled mask ! Interface v-points in diagnostic coordinate axes => diag_cs%remap_axesCvi(c) - call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvi(c)%dsamp(dl)%mask3d, dl,G%isc ,G%JscB, & - G%HId2%isc ,G%HId2%iec, G%HId2%JscB,G%HId2%JecB,G%HId2%isd ,G%HId2%ied, G%HId2%JsdB,G%HId2%JedB) - diag_cs%dsamp(dl)%remap_axesCvi(c)%mask3d => axes%mask3d !set non-downsampled mask + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvi(c)%dsamp(dl)%mask3d, & + dl, G%isc, G%JscB, G%isd, G%JsdB, & + G%HId2%isc, G%HId2%iec, G%HId2%JscB, G%HId2%JecB, G%HId2%isd, G%HId2%ied, G%HId2%JsdB, G%HId2%JedB) + diag_cs%dsamp(dl)%remap_axesCvi(c)%mask3d => axes%mask3d ! Set a pointer to the non-downsampled mask ! Interface q-points in diagnostic coordinate axes => diag_cs%remap_axesBi(c) - call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBi(c)%dsamp(dl)%mask3d, dl,G%IscB,G%JscB, & - G%HId2%IscB,G%HId2%IecB,G%HId2%JscB,G%HId2%JecB,G%HId2%IsdB,G%HId2%IedB,G%HId2%JsdB,G%HId2%JedB) - diag_cs%dsamp(dl)%remap_axesBi(c)%mask3d => axes%mask3d !set non-downsampled mask + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBi(c)%dsamp(dl)%mask3d, & + dl, G%IscB, G%JscB, G%IsdB, G%JsdB, & + G%HId2%IscB, G%HId2%IecB, G%HId2%JscB, G%HId2%JecB, G%HId2%IsdB, G%HId2%IedB, G%HId2%JsdB, G%HId2%JedB) + diag_cs%dsamp(dl)%remap_axesBi(c)%mask3d => axes%mask3d ! Set a pointer to the non-downsampled mask enddo enddo end subroutine set_masks_for_axes_dsamp @@ -944,7 +988,7 @@ subroutine register_cell_measure(G, diag, Time) ! Local variables integer :: id id = register_diag_field('ocean_model', 'volcello', diag%axesTL, & - Time, 'Ocean grid-cell volume', 'm3', & + Time, 'Ocean grid-cell volume', units='m3', conversion=1.0, & standard_name='ocean_volume', v_extensive=.true., & x_cell_method='sum', y_cell_method='sum') call diag_associate_volume_cell_measure(diag, id) @@ -981,7 +1025,7 @@ integer function diag_get_volume_cell_measure_dm_id(diag_cs) end function diag_get_volume_cell_measure_dm_id -!> Defines a group of "axes" from list of handles +!> Define a group of "axes" from a list of handles and associate a mask with it subroutine define_axes_group(diag_cs, handles, axes, nz, vertical_coordinate_number, & x_cell_method, y_cell_method, v_cell_method, & is_h_point, is_q_point, is_u_point, is_v_point, & @@ -1027,10 +1071,10 @@ subroutine define_axes_group(diag_cs, handles, axes, nz, vertical_coordinate_num n = size(handles) if (n<1 .or. n>3) call MOM_error(FATAL, "define_axes_group: wrong size for list of handles!") allocate( axes%handles(n) ) - axes%id = i2s(handles, n) ! Identifying string + axes%id = ints_to_string(handles, max(n,3)) ! Identifying string axes%rank = n axes%handles(:) = handles(:) - axes%diag_cs => diag_cs ! A [circular] link back to the diag_cs structure + axes%diag_cs => diag_cs ! A (circular) link back to the diag_cs structure if (present(x_cell_method)) then if (axes%rank<2) call MOM_error(FATAL, 'define_axes_group: ' // & 'Can not set x_cell_method for rank<2.') @@ -1091,6 +1135,7 @@ subroutine define_axes_group(diag_cs, handles, axes, nz, vertical_coordinate_num endif endif + end subroutine define_axes_group !> Defines a group of downsampled "axes" from list of handles @@ -1140,10 +1185,10 @@ subroutine define_axes_group_dsamp(diag_cs, handles, axes, dl, nz, vertical_coor n = size(handles) if (n<1 .or. n>3) call MOM_error(FATAL, "define_axes_group: wrong size for list of handles!") allocate( axes%handles(n) ) - axes%id = i2s(handles, n) ! Identifying string + axes%id = ints_to_string(handles, max(n,3)) ! Identifying string axes%rank = n axes%handles(:) = handles(:) - axes%diag_cs => diag_cs ! A [circular] link back to the diag_cs structure + axes%diag_cs => diag_cs ! A (circular) link back to the diag_cs structure if (present(x_cell_method)) then if (axes%rank<2) call MOM_error(FATAL, 'define_axes_group: ' // & 'Can not set x_cell_method for rank<2.') @@ -1248,14 +1293,19 @@ subroutine post_data_0d(diag_field_id, field, diag_cs, is_static) integer, intent(in) :: diag_field_id !< The id for an output variable returned by a !! previous call to register_diag_field. real, intent(in) :: field !< real value being offered for output or averaging + !! in internally scaled arbitrary units [A ~> a] type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. ! Local variables - real :: locfield + real :: locfield ! The field being offered in arbitrary unscaled units [a] logical :: used, is_stat type(diag_type), pointer :: diag => null() + integer :: time_days + integer :: time_seconds + character(len=300) :: debug_mesg + if (id_clock_diag_mediator>0) call cpu_clock_begin(id_clock_diag_mediator) is_stat = .false. ; if (present(is_static)) is_stat = is_static @@ -1271,7 +1321,12 @@ subroutine post_data_0d(diag_field_id, field, diag_cs, is_static) locfield = locfield * diag%conversion_factor if (diag_cs%diag_as_chksum) then - call chksum0(locfield, diag%debug_str, logunit=diag_cs%chksum_iounit) + ! Append timestep to mesg + call get_time(diag_cs%time_end, time_seconds, days=time_days) + write(debug_mesg, '(a, 1x, i0, 1x, i0)') & + trim(diag%debug_str), time_days, time_seconds + + call chksum0(locfield, debug_mesg, logunit=diag_cs%chksum_iounit) elseif (is_stat) then used = send_data_infra(diag%fms_diag_id, locfield) elseif (diag_cs%ave_enabled) then @@ -1288,16 +1343,21 @@ subroutine post_data_1d_k(diag_field_id, field, diag_cs, is_static) integer, intent(in) :: diag_field_id !< The id for an output variable returned by a !! previous call to register_diag_field. real, target, intent(in) :: field(:) !< 1-d array being offered for output or averaging + !! in internally scaled arbitrary units [A ~> a] type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. ! Local variables logical :: used ! The return value of send_data is not used for anything. - real, dimension(:), pointer :: locfield => NULL() + real, dimension(:), pointer :: locfield => NULL() ! The field being offered in arbitrary unscaled units [a] logical :: is_stat integer :: k, ks, ke type(diag_type), pointer :: diag => null() + integer :: time_days + integer :: time_seconds + character(len=300) :: debug_mesg + if (id_clock_diag_mediator>0) call cpu_clock_begin(id_clock_diag_mediator) is_stat = .false. ; if (present(is_static)) is_stat = is_static @@ -1312,18 +1372,19 @@ subroutine post_data_1d_k(diag_field_id, field, diag_cs, is_static) allocate( locfield( ks:ke ) ) do k=ks,ke - if (field(k) == diag_cs%missing_value) then - locfield(k) = diag_cs%missing_value - else - locfield(k) = field(k) * diag%conversion_factor - endif + locfield(k) = field(k) * diag%conversion_factor enddo else locfield => field endif if (diag_cs%diag_as_chksum) then - call zchksum(locfield, diag%debug_str, logunit=diag_cs%chksum_iounit) + ! Append timestep to mesg + call get_time(diag_cs%time_end, time_seconds, days=time_days) + write(debug_mesg, '(a, 1x, i0, 1x, i0)') & + trim(diag%debug_str), time_days, time_seconds + + call zchksum(locfield, debug_mesg, logunit=diag_cs%chksum_iounit) elseif (is_stat) then used = send_data_infra(diag%fms_diag_id, locfield) elseif (diag_cs%ave_enabled) then @@ -1342,9 +1403,10 @@ subroutine post_data_2d(diag_field_id, field, diag_cs, is_static, mask) integer, intent(in) :: diag_field_id !< The id for an output variable returned by a !! previous call to register_diag_field. real, intent(in) :: field(:,:) !< 2-d array being offered for output or averaging + !! in internally scaled arbitrary units [A ~> a] type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. - real, optional, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. + real, optional, intent(in) :: mask(:,:) !< If present, use this real array as the data mask [nondim] ! Local variables type(diag_type), pointer :: diag => null() @@ -1368,26 +1430,32 @@ end subroutine post_data_2d subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post real, target, intent(in) :: field(:,:) !< 2-d array being offered for output or averaging + !! in internally scaled arbitrary units [A ~> a] type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. - real, optional,target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. + real, optional, target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask [nondim] ! Local variables - real, dimension(:,:), pointer :: locfield - real, dimension(:,:), pointer :: locmask - character(len=300) :: mesg - logical :: used, is_stat + real, dimension(:,:), pointer :: locfield ! The field being offered in arbitrary unscaled units [a] + real, dimension(:,:), pointer :: locmask ! A pointer to the data mask to use [nondim] + logical :: used ! The return value of send_data is not used for anything. + logical :: is_stat, not_static integer :: cszi, cszj, dszi, dszj - integer :: isv, iev, jsv, jev, i, j, chksum, isv_o,jsv_o - real, dimension(:,:), allocatable, target :: locfield_dsamp - real, dimension(:,:), allocatable, target :: locmask_dsamp + integer :: isv, iev, jsv, jev, i, j, isv_o, jsv_o + real, dimension(:,:), allocatable, target :: locfield_dsamp ! A downsampled version of locfield [a] + real, dimension(:,:), allocatable, target :: locmask_dsamp ! A downsampled version of locmask [nondim] integer :: dl + integer :: time_days + integer :: time_seconds + character(len=300) :: mesg + character(len=300) :: debug_mesg locfield => NULL() locmask => NULL() is_stat = .false. ; if (present(is_static)) is_stat = is_static + not_static = .not. is_stat - ! Determine the propery array indices, noting that because of the (:,:) + ! Determine the proper array indices, noting that because of the (:,:) ! declaration of field, symmetric arrays are using a SW-grid indexing, ! but non-symmetric arrays are using a NE-grid indexing. Send_data ! actually only uses the difference between ie and is to determine @@ -1427,73 +1495,72 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then allocate( locfield( lbound(field,1):ubound(field,1), lbound(field,2):ubound(field,2) ) ) do j=jsv,jev ; do i=isv,iev - if (field(i,j) == diag_cs%missing_value) then - locfield(i,j) = diag_cs%missing_value - else - locfield(i,j) = field(i,j) * diag%conversion_factor - endif + locfield(i,j) = field(i,j) * diag%conversion_factor enddo ; enddo - locfield(isv:iev,jsv:jev) = field(isv:iev,jsv:jev) * diag%conversion_factor else locfield => field endif if (present(mask)) then locmask => mask - elseif (.NOT. is_stat) then + elseif (not_static .and. associated(diag%axes)) then + ! If we were to decide to allow masking of static diagnostics, we could do so by changing the line above to + ! elseif (associated(diag%axes) .and. (diag_CS%mask_static_diags .or. not_static)) then if (associated(diag%axes%mask2d)) locmask => diag%axes%mask2d endif - dl=1 - if (.NOT. is_stat) dl = diag%axes%downsample_level !static field downsample i not supported yet - !Downsample the diag field and mask (if present) + dl = 1 + if (not_static .and. associated(diag%axes)) & + dl = diag%axes%downsample_level ! Static field downsampling is not supported yet. + ! Downsample the diag field and mask as appropriate. if (dl > 1) then isv_o = isv ; jsv_o = jsv - call downsample_diag_field(locfield, locfield_dsamp, dl, diag_cs, diag,isv,iev,jsv,jev, mask) + call downsample_diag_field(locfield, locfield_dsamp, dl, diag_cs, diag, isv, iev, jsv, jev, mask) if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) deallocate( locfield ) locfield => locfield_dsamp if (present(mask)) then - call downsample_field_2d(locmask, locmask_dsamp, dl, MSK, locmask, diag_cs,diag,isv_o,jsv_o,isv,iev,jsv,jev) + call downsample_field_2d(locmask, locmask_dsamp, dl, MSK, locmask, diag_cs, diag, & + isv_o, jsv_o, isv, iev, jsv, jev) locmask => locmask_dsamp elseif (associated(diag%axes%dsamp(dl)%mask2d)) then locmask => diag%axes%dsamp(dl)%mask2d endif endif + if (associated(locmask)) call assert(size(locfield) == size(locmask), & + 'post_data_2d_low: mask size mismatch: '//trim(diag%debug_str)) if (diag_cs%diag_as_chksum) then + ! Append timestep to mesg + call get_time(diag_cs%time_end, time_seconds, days=time_days) + write(debug_mesg, '(a, 1x, i0, 1x, i0)') & + trim(diag%debug_str), time_days, time_seconds + if (diag%axes%is_h_point) then - call hchksum(locfield, diag%debug_str, diag_cs%G%HI, & + call hchksum(locfield, debug_mesg, diag_cs%G%HI, & logunit=diag_cs%chksum_iounit) elseif (diag%axes%is_u_point) then - call uchksum(locfield, diag%debug_str, diag_cs%G%HI, & + call uchksum(locfield, debug_mesg, diag_cs%G%HI, & logunit=diag_cs%chksum_iounit) elseif (diag%axes%is_v_point) then - call vchksum(locfield, diag%debug_str, diag_cs%G%HI, & + call vchksum(locfield, debug_mesg, diag_cs%G%HI, & logunit=diag_cs%chksum_iounit) elseif (diag%axes%is_q_point) then - call Bchksum(locfield, diag%debug_str, diag_cs%G%HI, & + call Bchksum(locfield, debug_mesg, diag_cs%G%HI, & logunit=diag_cs%chksum_iounit) else call MOM_error(FATAL, "post_data_2d_low: unknown axis type.") endif else if (is_stat) then - if (present(mask)) then - call assert(size(locfield) == size(locmask), & - 'post_data_2d_low is_stat: mask size mismatch: '//diag%debug_str) + if (associated(locmask)) then used = send_data_infra(diag%fms_diag_id, locfield, & is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, rmask=locmask) - !elseif (associated(diag%axes%mask2d)) then - ! used = send_data(diag%fms_diag_id, locfield, & - ! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, rmask=diag%axes%mask2d) else used = send_data_infra(diag%fms_diag_id, locfield, & is_in=isv, ie_in=iev, js_in=jsv, je_in=jev) endif elseif (diag_cs%ave_enabled) then if (associated(locmask)) then - call assert(size(locfield) == size(locmask), & - 'post_data_2d_low: mask size mismatch: '//diag%debug_str) used = send_data_infra(diag%fms_diag_id, locfield, & is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & time=diag_cs%time_end, weight=diag_cs%time_int, rmask=locmask) @@ -1514,24 +1581,27 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) integer, intent(in) :: diag_field_id !< The id for an output variable returned by a !! previous call to register_diag_field. real, intent(in) :: field(:,:,:) !< 3-d array being offered for output or averaging + !! in internally scaled arbitrary units [A ~> a] type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. - real, optional, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. + real, optional, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask [nondim] real, dimension(:,:,:), & target, optional, intent(in) :: alt_h !< An alternate thickness to use for vertically !! remapping this diagnostic [H ~> m or kg m-2]. ! Local variables type(diag_type), pointer :: diag => null() - integer :: nz, i, j, k - real, dimension(:,:,:), allocatable :: remapped_field - logical :: staggered_in_x, staggered_in_y - real, dimension(:,:,:), pointer :: h_diag => NULL() + real, dimension(:,:,:), allocatable :: remapped_field !< The vertically remapped diagnostic [A ~> a] + logical :: staggered_in_x, staggered_in_y, dz_diag_needed, dz_begin_needed + real, dimension(:,:,:), pointer :: h_diag => NULL() !< A pointer to the thickness to use for vertically + !! remapping this diagnostic [H ~> m or kg m-2]. + + real, dimension(diag_cs%G%isd:diag_cS%G%ied, diag_cs%G%jsd:diag_cS%G%jed, diag_cs%GV%ke) :: & + dz_diag ! Layer vertical extents for remapping [Z ~> m] if (id_clock_diag_mediator>0) call cpu_clock_begin(id_clock_diag_mediator) - ! For intensive variables only, we can choose to use a different diagnostic grid - ! to map to + ! For intensive variables only, we can choose to use a different diagnostic grid to map to if (present(alt_h)) then h_diag => alt_h else @@ -1542,6 +1612,26 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) ! grids, and post each. call assert(diag_field_id < diag_cs%next_free_diag_id, & 'post_data_3d: Unregistered diagnostic id') + + if (diag_cs%show_call_tree) & + call callTree_enter("post_data_3d("//trim(diag_cs%diags(diag_field_id)%debug_str)//")") + + ! Find out whether there are any z-based diagnostics + diag => diag_cs%diags(diag_field_id) + dz_diag_needed = .false. + do while (associated(diag)) + if (diag%axes%needs_remapping .or. diag%axes%needs_interpolating) then + if (diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%Z_based_coord) & + dz_diag_needed = .true. + endif + diag => diag%next + enddo + + ! Determine the diagnostic grid spacing in height units, if it is needed. + if (dz_diag_needed) then + call thickness_to_dz(h_diag, diag_cs%tv, dz_diag, diag_cs%G, diag_cs%GV, diag_cs%US, halo_size=1) + endif + diag => diag_cs%diags(diag_field_id) do while (associated(diag)) call assert(associated(diag%axes), 'post_data_3d: axes is not associated') @@ -1557,11 +1647,17 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) if (id_clock_diag_remap>0) call cpu_clock_begin(id_clock_diag_remap) allocate(remapped_field(size(field,1), size(field,2), diag%axes%nz)) - call vertically_reintegrate_diag_field( & - diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), diag_cs%G, & - diag_cs%h_begin, & - diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%h_extensive, & - staggered_in_x, staggered_in_y, diag%axes%mask3d, field, remapped_field) + if (diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%Z_based_coord) then + call vertically_reintegrate_diag_field( & + diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), diag_cs%G, & + diag_cs%dz_begin, diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%h_extensive, & + staggered_in_x, staggered_in_y, diag%axes%mask3d, field, remapped_field) + else + call vertically_reintegrate_diag_field( & + diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), diag_cs%G, & + diag_cs%h_begin, diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%h_extensive, & + staggered_in_x, staggered_in_y, diag%axes%mask3d, field, remapped_field) + endif if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap) if (associated(diag%axes%mask3d)) then ! Since 3d masks do not vary in the vertical, just use as much as is @@ -1582,9 +1678,15 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) if (id_clock_diag_remap>0) call cpu_clock_begin(id_clock_diag_remap) allocate(remapped_field(size(field,1), size(field,2), diag%axes%nz)) - call diag_remap_do_remap(diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), & - diag_cs%G, diag_cs%GV, h_diag, staggered_in_x, staggered_in_y, & - diag%axes%mask3d, field, remapped_field) + if (diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%Z_based_coord) then + call diag_remap_do_remap(diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), & + diag_cs%G, diag_cs%GV, diag_cs%US, dz_diag, staggered_in_x, staggered_in_y, & + diag%axes%mask3d, field, remapped_field) + else + call diag_remap_do_remap(diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), & + diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, staggered_in_x, staggered_in_y, & + diag%axes%mask3d, field, remapped_field) + endif if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap) if (associated(diag%axes%mask3d)) then ! Since 3d masks do not vary in the vertical, just use as much as is @@ -1605,14 +1707,18 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) if (id_clock_diag_remap>0) call cpu_clock_begin(id_clock_diag_remap) allocate(remapped_field(size(field,1), size(field,2), diag%axes%nz+1)) - call vertically_interpolate_diag_field(diag_cs%diag_remap_cs( & - diag%axes%vertical_coordinate_number), & - diag_cs%G, h_diag, staggered_in_x, staggered_in_y, & - diag%axes%mask3d, field, remapped_field) + if (diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%Z_based_coord) then + call vertically_interpolate_diag_field(diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), & + diag_cs%G, dz_diag, staggered_in_x, staggered_in_y, & + diag%axes%mask3d, field, remapped_field) + else + call vertically_interpolate_diag_field(diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), & + diag_cs%G, h_diag, staggered_in_x, staggered_in_y, & + diag%axes%mask3d, field, remapped_field) + endif if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap) if (associated(diag%axes%mask3d)) then - ! Since 3d masks do not vary in the vertical, just use as much as is - ! needed. + ! Since 3d masks do not vary in the vertical, just use as much as is needed. call post_data_3d_low(diag, remapped_field, diag_cs, is_static, & mask=diag%axes%mask3d) else @@ -1628,6 +1734,9 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) enddo if (id_clock_diag_mediator>0) call cpu_clock_end(id_clock_diag_mediator) + if (diag_cs%show_call_tree) & + call callTree_leave("post_data_3d("//trim(diag_cs%diags(diag_field_id)%debug_str)//")") + end subroutine post_data_3d !> Make a real 3-d array diagnostic available for averaging or output @@ -1635,27 +1744,32 @@ end subroutine post_data_3d subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post real, target, intent(in) :: field(:,:,:) !< 3-d array being offered for output or averaging + !! in internally scaled arbitrary units [A ~> a] type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. - real, optional,target, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. + real, optional,target, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask [nondim] ! Local variables - real, dimension(:,:,:), pointer :: locfield - real, dimension(:,:,:), pointer :: locmask + real, dimension(:,:,:), pointer :: locfield ! The field being offered in arbitrary unscaled units [a] + real, dimension(:,:,:), pointer :: locmask ! A pointer to the data mask to use [nondim] character(len=300) :: mesg logical :: used ! The return value of send_data is not used for anything. logical :: staggered_in_x, staggered_in_y - logical :: is_stat + logical :: is_stat, not_static integer :: cszi, cszj, dszi, dszj - integer :: isv, iev, jsv, jev, ks, ke, i, j, k, isv_c, jsv_c, isv_o,jsv_o - integer :: chksum - real, dimension(:,:,:), allocatable, target :: locfield_dsamp - real, dimension(:,:,:), allocatable, target :: locmask_dsamp + integer :: isv, iev, jsv, jev, ks, ke, i, j, k, isv_c, jsv_c, isv_o, jsv_o + real, dimension(:,:,:), allocatable, target :: locfield_dsamp ! A downsampled version of locfield [a] + real, dimension(:,:,:), allocatable, target :: locmask_dsamp ! A downsampled version of locmask [nondim] integer :: dl + integer :: time_days + integer :: time_seconds + character(len=300) :: debug_mesg + locfield => NULL() locmask => NULL() is_stat = .false. ; if (present(is_static)) is_stat = is_static + not_static = .not. is_stat ! Determine the proper array indices, noting that because of the (:,:) ! declaration of field, symmetric arrays are using a SW-grid indexing, @@ -1715,11 +1829,7 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) endif do k=ks,ke ; do j=jsv,jev ; do i=isv,iev - if (field(i,j,k) == diag_cs%missing_value) then - locfield(i,j,k) = diag_cs%missing_value - else - locfield(i,j,k) = field(i,j,k) * diag%conversion_factor - endif + locfield(i,j,k) = field(i,j,k) * diag%conversion_factor enddo ; enddo ; enddo else locfield => field @@ -1727,61 +1837,65 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) if (present(mask)) then locmask => mask - elseif (associated(diag%axes%mask3d)) then - locmask => diag%axes%mask3d + elseif (associated(diag%axes) .and. (not_static)) then + ! If we were to decide to allow masking of static diagnostics, we could do so by changing the line above to + ! elseif (associated(diag%axes) .and. (diag_CS%mask_static_diags .or. not_static)) then + if (associated(diag%axes%mask3d)) locmask => diag%axes%mask3d endif - dl=1 - if (.NOT. is_stat) dl = diag%axes%downsample_level !static field downsample i not supported yet - !Downsample the diag field and mask (if present) + dl = 1 + if (not_static .and. associated(diag%axes)) & + dl = diag%axes%downsample_level ! Static field downsampling is not supported yet. + ! Downsample the diag field and mask as appropriate. if (dl > 1) then isv_o = isv ; jsv_o = jsv - call downsample_diag_field(locfield, locfield_dsamp, dl, diag_cs, diag,isv,iev,jsv,jev, mask) + call downsample_diag_field(locfield, locfield_dsamp, dl, diag_cs, diag, isv, iev, jsv, jev, mask) if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) deallocate( locfield ) locfield => locfield_dsamp if (present(mask)) then - call downsample_field_3d(locmask, locmask_dsamp, dl, MSK, locmask, diag_cs,diag,isv_o,jsv_o,isv,iev,jsv,jev) + call downsample_field_3d(locmask, locmask_dsamp, dl, MSK, locmask, diag_cs, diag, & + isv_o, jsv_o, isv, iev, jsv, jev) locmask => locmask_dsamp elseif (associated(diag%axes%dsamp(dl)%mask3d)) then locmask => diag%axes%dsamp(dl)%mask3d endif endif + if (associated(locmask)) call assert(size(locfield) == size(locmask), & + 'post_data_3d_low: mask size mismatch: '//trim(diag%debug_str)) if (diag%fms_diag_id>0) then if (diag_cs%diag_as_chksum) then + ! Append timestep to mesg + call get_time(diag_cs%time_end, time_seconds, days=time_days) + write(debug_mesg, '(a, 1x, i0, 1x, i0)') & + trim(diag%debug_str), time_days, time_seconds + if (diag%axes%is_h_point) then - call hchksum(locfield, diag%debug_str, diag_cs%G%HI, & + call hchksum(locfield, debug_mesg, diag_cs%G%HI, & logunit=diag_cs%chksum_iounit) elseif (diag%axes%is_u_point) then - call uchksum(locfield, diag%debug_str, diag_cs%G%HI, & + call uchksum(locfield, debug_mesg, diag_cs%G%HI, & logunit=diag_cs%chksum_iounit) elseif (diag%axes%is_v_point) then - call vchksum(locfield, diag%debug_str, diag_cs%G%HI, & + call vchksum(locfield, debug_mesg, diag_cs%G%HI, & logunit=diag_cs%chksum_iounit) elseif (diag%axes%is_q_point) then - call Bchksum(locfield, diag%debug_str, diag_cs%G%HI, & + call Bchksum(locfield, debug_mesg, diag_cs%G%HI, & logunit=diag_cs%chksum_iounit) else call MOM_error(FATAL, "post_data_3d_low: unknown axis type.") endif else if (is_stat) then - if (present(mask)) then - call assert(size(locfield) == size(locmask), & - 'post_data_3d_low is_stat: mask size mismatch: '//diag%debug_str) + if (associated(locmask)) then used = send_data_infra(diag%fms_diag_id, locfield, & is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, rmask=locmask) - !elseif (associated(diag%axes%mask2d)) then - ! used = send_data(diag%fms_diag_id, locfield, & - ! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, rmask=diag%axes%mask2d) else used = send_data_infra(diag%fms_diag_id, locfield, & is_in=isv, ie_in=iev, js_in=jsv, je_in=jev) endif elseif (diag_cs%ave_enabled) then if (associated(locmask)) then - call assert(size(locfield) == size(locmask), & - 'post_data_3d_low: mask size mismatch: '//diag%debug_str) used = send_data_infra(diag%fms_diag_id, locfield, & is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & time=diag_cs%time_end, weight=diag_cs%time_int, rmask=locmask) @@ -1803,6 +1917,61 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) end subroutine post_data_3d_low +!> Put data into the buffer for a diagnostic one column at a time +subroutine post_data_3d_by_column(diag_field_id, field, diag_cs, i, j) + integer, intent(in) :: diag_field_id !< The id for an output variable returned by a + !! previous call to register_diag_field. + real, dimension(:), intent(in) :: field !< 3-d array being offered for output or averaging + !! in internally scaled arbitrary units [A ~> a] + type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output + integer, intent(in) :: i !< The i-index to post the data in the buffer + integer, intent(in) :: j !< The j-index to post the data in the buffer + + type(diag_type), pointer :: diag => null() + integer :: buffer_slot + + diag => diag_cs%diags(diag_field_id) + buffer_slot = diag%axes%piecemeal_3d%check_capacity_by_id(diag_field_id) + diag%axes%piecemeal_3d%buffer(buffer_slot)%field(i,j,:) = field(:) +end subroutine post_data_3d_by_column + +!> Put data into the buffer for a diagnostic one point at a time +subroutine post_data_3d_by_point(diag_field_id, field, diag_cs, i, j, k) + integer, intent(in) :: diag_field_id !< The id for an output variable returned by a + !! previous call to register_diag_field. + real, intent(in) :: field !< 3-d array being offered for output or averaging + !! in internally scaled arbitrary units [A ~> a] + type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output + integer, intent(in) :: i !< The i-index to post the data in the buffer + integer, intent(in) :: j !< The j-index to post the data in the buffer + integer, intent(in) :: k !< The k-index to post the data in the buffer + + type(diag_type), pointer :: diag => null() + integer :: buffer_slot + + diag => diag_cs%diags(diag_field_id) + buffer_slot = diag%axes%piecemeal_3d%check_capacity_by_id(diag_field_id) + diag%axes%piecemeal_3d%buffer(buffer_slot)%field(i,j,k) = field +end subroutine post_data_3d_by_point + +!> Post the final buffer using the standard post_data interface +subroutine post_data_3d_final(diag_field_id, diag_cs) + integer, intent(in) :: diag_field_id !< The id for an output variable returned by a + !! previous call to register_diag_field. + type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output + + type(diag_type), pointer :: diag => null() + integer :: buffer_slot + + diag => diag_cs%diags(diag_field_id) + buffer_slot = diag%axes%piecemeal_3d%find_buffer_slot(diag_field_id) + ! Only perform an action if the buffer slot was actually used + if (buffer_slot>0) then + call post_data(diag_field_id, diag%axes%piecemeal_3d%buffer(buffer_slot)%field(:,:,:), diag_CS) + call diag%axes%piecemeal_3d%mark_available(diag_field_id) + endif +end subroutine post_data_3d_final + !> Calculate and write out diagnostics that are the product of two 3-d arrays at u-points subroutine post_product_u(id, u_a, u_b, G, nz, diag, mask, alt_h) integer, intent(in) :: id !< The ID for this diagnostic @@ -1908,14 +2077,18 @@ end subroutine post_product_sum_v !> Post the horizontally area-averaged diagnostic subroutine post_xy_average(diag_cs, diag, field) type(diag_type), intent(in) :: diag !< This diagnostic - real, target, intent(in) :: field(:,:,:) !< Diagnostic field + real, target, intent(in) :: field(:,:,:) !< Diagnostic field in arbitrary units [A ~> a] type(diag_ctrl), intent(in) :: diag_cs !< Diagnostics mediator control structure ! Local variable - real, dimension(size(field,3)) :: averaged_field + real, dimension(size(field,3)) :: averaged_field ! The horizontally averaged field [A ~> a] logical, dimension(size(field,3)) :: averaged_mask logical :: staggered_in_x, staggered_in_y, used integer :: nz, remap_nz, coord + integer :: time_days + integer :: time_seconds + character(len=300) :: debug_mesg + if (.not. diag_cs%ave_enabled) then return endif @@ -1927,8 +2100,7 @@ subroutine post_xy_average(diag_cs, diag, field) call horizontally_average_diag_field(diag_cs%G, diag_cs%GV, diag_cs%h, & staggered_in_x, staggered_in_y, & diag%axes%is_layer, diag%v_extensive, & - field, & - averaged_field, averaged_mask) + field, averaged_field, averaged_mask) else nz = size(field, 3) coord = diag%axes%vertical_coordinate_number @@ -1950,8 +2122,12 @@ subroutine post_xy_average(diag_cs, diag, field) endif if (diag_cs%diag_as_chksum) then - call zchksum(averaged_field, trim(diag%debug_str)//'_xyave', & - logunit=diag_CS%chksum_iounit) + ! Append timestep to mesg + call get_time(diag_cs%time_end, time_seconds, days=time_days) + write(debug_mesg, '(a, 1x, i0, 1x, i0)') & + trim(diag%debug_str)//'_xyave', time_days, time_seconds + + call zchksum(averaged_field, debug_mesg, logunit=diag_CS%chksum_iounit) else used = send_data_infra(diag%fms_xyave_diag_id, averaged_field, & time=diag_cs%time_end, weight=diag_cs%time_int, mask=averaged_mask) @@ -1961,9 +2137,9 @@ end subroutine post_xy_average !> This subroutine enables the accumulation of time averages over the specified time interval. subroutine enable_averaging(time_int_in, time_end_in, diag_cs) real, intent(in) :: time_int_in !< The time interval [s] over which any - !! values that are offered are valid. + !! values that are offered are valid. type(time_type), intent(in) :: time_end_in !< The end time of the valid interval - type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output ! This subroutine enables the accumulation of time averages over the specified time interval. @@ -1979,8 +2155,8 @@ subroutine enable_averages(time_int, time_end, diag_CS, T_to_s) !! that are offered are valid [T ~> s]. type(time_type), intent(in) :: time_end !< The end time of the valid interval. type(diag_ctrl), intent(inout) :: diag_CS !< A structure that is used to regulate diagnostic output - real, optional, intent(in) :: T_to_s !< A conversion factor for time_int to [s]. -! This subroutine enables the accumulation of time averages over the specified time interval. + real, optional, intent(in) :: T_to_s !< A conversion factor for time_int to seconds [s T-1 ~> 1]. + ! This subroutine enables the accumulation of time averages over the specified time interval. if (present(T_to_s)) then diag_cs%time_int = time_int*T_to_s @@ -1999,7 +2175,6 @@ subroutine disable_averaging(diag_cs) diag_cs%time_int = 0.0 diag_cs%ave_enabled = .false. - end subroutine disable_averaging !> Call this subroutine to determine whether the averaging is @@ -2042,8 +2217,10 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time character(len=*), optional, intent(in) :: long_name !< Long name of a field. character(len=*), optional, intent(in) :: units !< Units of a field. character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field - real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: missing_value !< A value that indicates missing values in + !! output files, in unscaled arbitrary units [a] real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + !! in arbitrary units [a] logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with !! post_data calls (not used in MOM?) logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) @@ -2067,12 +2244,14 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time !! Use '' have no method. character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. !! Use '' have no method. - real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file - logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields (vertically + real, optional, intent(in) :: conversion !< A value to multiply data by before writing to files, + !! often including factors to undo internal scaling and + !! in units of [a A-1 ~> 1] + logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields (vertically !! integrated). Default/absent for intensive. ! Local variables - real :: MOM_missing_value - type(diag_ctrl), pointer :: diag_cs + real :: MOM_missing_value ! A value used to indicate missing values in output files, in arbitrary units [a] + type(diag_ctrl), pointer :: diag_cs => NULL() ! A structure that is used to regulate diagnostic output type(axes_grp), pointer :: remap_axes type(axes_grp), pointer :: axes type(axes_grp), pointer :: axes_d2 @@ -2080,6 +2259,7 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time character(len=256) :: msg, cm_string character(len=256) :: new_module_name character(len=480) :: module_list, var_list + character(len=24) :: dimensions integer :: num_modnm, num_varnm logical :: active @@ -2103,6 +2283,14 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time axes => diag_cs%axesCui elseif (axes_in%id == diag_cs%axesCvi%id) then axes => diag_cs%axesCvi + elseif (axes_in%id == diag_cs%axesT1%id) then + axes => diag_cs%axesT1 + elseif (axes_in%id == diag_cs%axesB1%id) then + axes => diag_cs%axesB1 + elseif (axes_in%id == diag_cs%axesCu1%id) then + axes => diag_cs%axesCu1 + elseif (axes_in%id == diag_cs%axesCv1%id) then + axes => diag_cs%axesCv1 else allocate(axes) axes = axes_in @@ -2193,7 +2381,7 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time endif ! axes%rank == 3 enddo ! i - !Register downsampled diagnostics + ! Register downsampled diagnostics do dl=2,MAX_DSAMP_LEV ! Do not attempt to checksum the downsampled diagnostics if (diag_cs%diag_as_chksum) cycle @@ -2235,7 +2423,7 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time ! Register the native diagnostic if (associated(axes_d2)) then - active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, axes_d2, & + active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, axes_d2, & init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & @@ -2300,6 +2488,15 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time enddo ! i enddo + dimensions = "" + if (axes_in%is_h_point) dimensions = trim(dimensions)//" xh, yh," + if (axes_in%is_q_point) dimensions = trim(dimensions)//" xq, yq," + if (axes_in%is_u_point) dimensions = trim(dimensions)//" xq, yh," + if (axes_in%is_v_point) dimensions = trim(dimensions)//" xh, yq," + if (axes_in%is_layer) dimensions = trim(dimensions)//" zl," + if (axes_in%is_interface) dimensions = trim(dimensions)//" zi," + if (len_trim(dimensions) > 0) dimensions = trim_trailing_commas(dimensions) + if (is_root_pe() .and. (diag_CS%available_diag_doc_unit > 0)) then msg = '' if (present(cmor_field_name)) msg = 'CMOR equivalent is "'//trim(cmor_field_name)//'"' @@ -2311,14 +2508,14 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time if (num_varnm <= 1) var_list = '' call log_available_diag(dm_id>0, module_list, field_name, cm_string, msg, diag_CS, & - long_name, units, standard_name, variants=var_list) + long_name, units, standard_name, variants=var_list, dimensions=dimensions) endif register_diag_field = dm_id end function register_diag_field -!> Returns True if either the native or CMOr version of the diagnostic were registered. Updates 'dm_id' +!> Returns True if either the native or CMOR version of the diagnostic were registered. Updates 'dm_id' !! after calling register_diag_field_expand_axes() for both native and CMOR variants of the field. logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, axes, init_time, & long_name, units, missing_value, range, mask_variant, standard_name, & @@ -2328,14 +2525,16 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, integer, intent(inout) :: dm_id !< The diag_mediator ID for this diagnostic group character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of the diagnostic field - type(axes_grp), intent(in) :: axes !< Container w/ up to 3 integer handles that indicates axes + type(axes_grp), intent(in) :: axes !< Container with up to 3 integer handles that indicates axes !! for this field type(time_type), intent(in) :: init_time !< Time at which a field is first available? character(len=*), optional, intent(in) :: long_name !< Long name of a field. character(len=*), optional, intent(in) :: units !< Units of a field. character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field - real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: missing_value !< A value that indicates missing values in + !! output files, in unscaled arbitrary units [a] real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + !! in arbitrary units [a] logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided !! with post_data calls (not used in MOM?) logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) @@ -2359,15 +2558,17 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, !! Use '' have no method. character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. !! Use '' have no method. - real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file + real, optional, intent(in) :: conversion !< A value to multiply data by before writing to files, + !! often including factors to undo internal scaling and + !! in units of [a A-1 ~> 1] logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields (vertically !! integrated). Default/absent for intensive. ! Local variables - real :: MOM_missing_value + real :: MOM_missing_value ! A value used to indicate missing values in output files, in arbitrary units [a] type(diag_ctrl), pointer :: diag_cs => null() type(diag_type), pointer :: this_diag => null() integer :: fms_id, fms_xyave_id - character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name, cm_string, msg + character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name, cm_string MOM_missing_value = axes%diag_cs%missing_value if (present(missing_value)) MOM_missing_value = missing_value @@ -2400,9 +2601,9 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, endif this_diag => null() if (fms_id /= DIAG_FIELD_NOT_FOUND .or. fms_xyave_id /= DIAG_FIELD_NOT_FOUND) then - call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg) + call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name) this_diag%fms_xyave_diag_id = fms_xyave_id - !Encode and save the cell methods for this diag + ! Encode and save the cell methods for this diagnostic call add_xyz_method(this_diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive) if (present(v_extensive)) this_diag%v_extensive = v_extensive if (present(conversion)) this_diag%conversion_factor = conversion @@ -2417,7 +2618,7 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, posted_cmor_long_name = "not provided" ! ! If attributes are present for MOM variable names, use them first for the register_diag_field - ! call for CMOR verison of the variable + ! call for CMOR version of the variable if (present(units)) posted_cmor_units = units if (present(standard_name)) posted_cmor_standard_name = standard_name if (present(long_name)) posted_cmor_long_name = long_name @@ -2449,9 +2650,9 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, endif this_diag => null() if (fms_id /= DIAG_FIELD_NOT_FOUND .or. fms_xyave_id /= DIAG_FIELD_NOT_FOUND) then - call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg) + call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name) this_diag%fms_xyave_diag_id = fms_xyave_id - !Encode and save the cell methods for this diag + ! Encode and save the cell methods for this diagnostic call add_xyz_method(this_diag, axes, x_cell_method, y_cell_method, v_cell_method, v_extensive) if (present(v_extensive)) this_diag%v_extensive = v_extensive if (present(conversion)) this_diag%conversion_factor = conversion @@ -2469,14 +2670,16 @@ integer function register_diag_field_expand_axes(module_name, field_name, axes, character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" !! or "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of the diagnostic field - type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that indicates + type(axes_grp), target, intent(in) :: axes !< Container with up to 3 integer handles that indicates !! axes for this field type(time_type), intent(in) :: init_time !< Time at which a field is first available? character(len=*), optional, intent(in) :: long_name !< Long name of a field. character(len=*), optional, intent(in) :: units !< Units of a field. character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field - real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: missing_value !< A value that indicates missing values in + !! output files, in unscaled arbitrary units [a] real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + !! in arbitrary units [a] logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided !! with post_data calls (not used in MOM?) logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) @@ -2567,23 +2770,22 @@ integer function register_diag_field_expand_axes(module_name, field_name, axes, end function register_diag_field_expand_axes !> Create a diagnostic type and attached to list -subroutine add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name, msg) +subroutine add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name) type(diag_ctrl), pointer :: diag_cs !< Diagnostics mediator control structure integer, intent(inout) :: dm_id !< The diag_mediator ID for this diagnostic group integer, intent(in) :: fms_id !< The FMS diag_manager ID for this diagnostic type(diag_type), pointer :: this_diag !< This diagnostic - type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that + type(axes_grp), target, intent(in) :: axes !< Container with up to 3 integer handles that !! indicates axes for this field character(len=*), intent(in) :: module_name !< Name of this module, usually !! "ocean_model" or "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of diagnostic - character(len=*), intent(in) :: msg !< Message for errors ! If the diagnostic is needed obtain a diag_mediator ID (if needed) if (dm_id == -1) dm_id = get_new_diag_id(diag_cs) ! Create a new diag_type to store links in call alloc_diag_with_id(dm_id, diag_cs, this_diag) - call assert(associated(this_diag), trim(msg)//': diag_type allocation failed') + call assert(associated(this_diag), 'add_diag_to_list: allocation failed for '//trim(field_name)) ! Record FMS id, masks and conversion factor, in diag_type this_diag%fms_diag_id = fms_id this_diag%debug_str = trim(module_name)//"-"//trim(field_name) @@ -2608,12 +2810,12 @@ subroutine add_xyz_method(diag, axes, x_cell_method, y_cell_method, v_cell_metho integer :: xyz_method character(len=9) :: mstr - !This is a simple way to encode the cell method information made from 3 strings - !(x_cell_method,y_cell_method,v_cell_method) in a 3 digit integer xyz - !x_cell_method,y_cell_method,v_cell_method can each be 'point' or 'sum' or 'mean' - !We can encode these with setting 1 for 'point', 2 for 'sum, 3 for 'mean' in - !the 100s position for x, 10s position for y, 1s position for z - !E.g., x:sum,y:point,z:mean is 213 + ! This is a simple way to encode the cell method information made from 3 strings + ! (x_cell_method,y_cell_method,v_cell_method) in a 3 digit integer xyz + ! x_cell_method,y_cell_method,v_cell_method can each be 'point' or 'sum' or 'mean' + ! We can encode these with setting 1 for 'point', 2 for 'sum, 3 for 'mean' in + ! the 100s position for x, 10s position for y, 1s position for z + ! E.g., x:sum,y:point,z:mean is 213 xyz_method = 111 @@ -2658,7 +2860,7 @@ end subroutine add_xyz_method subroutine attach_cell_methods(id, axes, ostring, cell_methods, & x_cell_method, y_cell_method, v_cell_method, v_extensive) integer, intent(in) :: id !< Handle to diagnostic - type(axes_grp), intent(in) :: axes !< Container w/ up to 3 integer handles that indicates + type(axes_grp), intent(in) :: axes !< Container with up to 3 integer handles that indicates !! axes for this field character(len=*), intent(out) :: ostring !< The cell_methods strings that would appear in the file character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute. @@ -2772,10 +2974,52 @@ subroutine attach_cell_methods(id, axes, ostring, cell_methods, & ostring = adjustl(ostring) end subroutine attach_cell_methods -function register_scalar_field(module_name, field_name, init_time, diag_cs, & + +!> Registers a non-array scalar diagnostic, returning an integer handle +function register_scalar_field_axes(module_name, field_name, axes, init_time, & + long_name, units, missing_value, range, standard_name, & + do_not_log, err_msg, interp_method, cmor_field_name, & + cmor_long_name, cmor_units, cmor_standard_name, conversion) result (register_scalar_field) + integer :: register_scalar_field !< An integer handle for a diagnostic array. + character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" + !! or "ice_shelf_model" + character(len=*), intent(in) :: field_name !< Name of the diagnostic field + type(axes_grp), target, intent(in) :: axes !< Container with up to 3 integer handles that + !! indicates axes for this field + type(time_type), intent(in) :: init_time !< Time at which a field is first available? + character(len=*), optional, intent(in) :: long_name !< Long name of a field. + character(len=*), optional, intent(in) :: units !< Units of a field. + character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field + real, optional, intent(in) :: missing_value !< A value that indicates missing values in + !! output files, in unscaled arbitrary units [a] + real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + !! in arbitrary units [a] + logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) + character(len=*), optional, intent(out):: err_msg !< String into which an error message might be + !! placed (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not + !! be interpolated as a scalar + character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field + character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field + character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field + character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field + real, optional, intent(in) :: conversion !< A value to multiply data by before writing to files, + !! often including factors to undo internal scaling and + !! in units of [a A-1 ~> 1] + + register_scalar_field = register_scalar_field_CS(module_name, field_name, init_time, axes%diag_cs, & long_name, units, missing_value, range, standard_name, & do_not_log, err_msg, interp_method, cmor_field_name, & - cmor_long_name, cmor_units, cmor_standard_name) + cmor_long_name, cmor_units, cmor_standard_name, conversion) + +end function register_scalar_field_axes + + +!> Registers a scalar diagnostic, returning an integer handle +function register_scalar_field_CS(module_name, field_name, init_time, diag_cs, & + long_name, units, missing_value, range, standard_name, & + do_not_log, err_msg, interp_method, cmor_field_name, & + cmor_long_name, cmor_units, cmor_standard_name, conversion) result (register_scalar_field) integer :: register_scalar_field !< An integer handle for a diagnostic array. character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" !! or "ice_shelf_model" @@ -2785,8 +3029,10 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, & character(len=*), optional, intent(in) :: long_name !< Long name of a field. character(len=*), optional, intent(in) :: units !< Units of a field. character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field - real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: missing_value !< A value that indicates missing values in + !! output files, in unscaled arbitrary units [a] real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + !! in arbitrary units [a] logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) character(len=*), optional, intent(out):: err_msg !< String into which an error message might be !! placed (not used in MOM?) @@ -2796,12 +3042,16 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, & character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field + real, optional, intent(in) :: conversion !< A value to multiply data by before writing to files, + !! often including factors to undo internal scaling and + !! in units of [a A-1 ~> 1] ! Local variables - real :: MOM_missing_value + real :: MOM_missing_value ! A value used to indicate missing values in output files, in arbitrary units [a] integer :: dm_id, fms_id type(diag_type), pointer :: diag => null(), cmor_diag => null() character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name + character(len=16) :: dimensions MOM_missing_value = diag_cs%missing_value if (present(missing_value)) MOM_missing_value = missing_value @@ -2826,6 +3076,7 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, & call assert(associated(diag), 'register_scalar_field: diag allocation failed') diag%fms_diag_id = fms_id diag%debug_str = trim(module_name)//"-"//trim(field_name) + if (present(conversion)) diag%conversion_factor = conversion endif if (present(cmor_field_name)) then @@ -2834,13 +3085,13 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, & posted_cmor_standard_name = "not provided" posted_cmor_long_name = "not provided" - ! If attributes are present for MOM variable names, use them first for the register_static_field - ! call for CMOR verison of the variable + ! If attributes are present for MOM variable names, use them as defaults for the + ! register_diag_field_infra call for CMOR version of the variable if (present(units)) posted_cmor_units = units if (present(standard_name)) posted_cmor_standard_name = standard_name if (present(long_name)) posted_cmor_long_name = long_name - ! If specified in the call to register_static_field, override attributes with the CMOR versions + ! If specified in the call to register_scalar_field, override attributes with the CMOR versions if (present(cmor_units)) posted_cmor_units = cmor_units if (present(cmor_standard_name)) posted_cmor_standard_name = cmor_standard_name if (present(cmor_long_name)) posted_cmor_long_name = cmor_long_name @@ -2856,24 +3107,28 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, & call alloc_diag_with_id(dm_id, diag_cs, cmor_diag) cmor_diag%fms_diag_id = fms_id cmor_diag%debug_str = trim(module_name)//"-"//trim(cmor_field_name) + if (present(conversion)) cmor_diag%conversion_factor = conversion endif endif + dimensions = "scalar" + ! Document diagnostics in list of available diagnostics if (is_root_pe() .and. diag_CS%available_diag_doc_unit > 0) then if (present(cmor_field_name)) then call log_available_diag(associated(diag), module_name, field_name, '', '', diag_CS, & long_name, units, standard_name, & - variants="{"//trim(field_name)//","//trim(cmor_field_name)//"}") + variants="{"//trim(field_name)//","//trim(cmor_field_name)//"}", & + dimensions=dimensions) else call log_available_diag(associated(diag), module_name, field_name, '', '', diag_CS, & - long_name, units, standard_name) + long_name, units, standard_name, dimensions=dimensions) endif endif register_scalar_field = dm_id -end function register_scalar_field +end function register_scalar_field_CS !> Registers a static diagnostic, returning an integer handle function register_static_field(module_name, field_name, axes, & @@ -2885,13 +3140,15 @@ function register_static_field(module_name, field_name, axes, & character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" !! or "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of the diagnostic field - type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that + type(axes_grp), target, intent(in) :: axes !< Container with up to 3 integer handles that !! indicates axes for this field character(len=*), optional, intent(in) :: long_name !< Long name of a field. character(len=*), optional, intent(in) :: units !< Units of a field. character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field - real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: missing_value !< A value that indicates missing values in + !! output files, in unscaled arbitrary units [a] real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + !! in arbitrary units [a] logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with !! post_data calls (not used in MOM?) logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) @@ -2906,15 +3163,18 @@ function register_static_field(module_name, field_name, axes, & character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. character(len=*), optional, intent(in) :: area_cell_method !< Specifies the cell method for area - real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file + real, optional, intent(in) :: conversion !< A value to multiply data by before writing to files, + !! often including factors to undo internal scaling and + !! in units of [a A-1 ~> 1] ! Local variables - real :: MOM_missing_value - type(diag_ctrl), pointer :: diag_cs => null() + real :: MOM_missing_value ! A value used to indicate missing values in output files, in arbitrary units [a] + type(diag_ctrl), pointer :: diag_cs => null() !< A structure that is used to regulate diagnostic output type(diag_type), pointer :: diag => null(), cmor_diag => null() - integer :: dm_id, fms_id, cmor_id + integer :: dm_id, fms_id character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name character(len=9) :: axis_name + character(len=24) :: dimensions MOM_missing_value = axes%diag_cs%missing_value if (present(missing_value)) MOM_missing_value = missing_value @@ -2970,7 +3230,7 @@ function register_static_field(module_name, field_name, axes, & posted_cmor_long_name = "not provided" ! If attributes are present for MOM variable names, use them first for the register_static_field - ! call for CMOR verison of the variable + ! call for CMOR version of the variable if (present(units)) posted_cmor_units = units if (present(standard_name)) posted_cmor_standard_name = standard_name if (present(long_name)) posted_cmor_long_name = long_name @@ -3007,15 +3267,25 @@ function register_static_field(module_name, field_name, axes, & endif endif + dimensions = "" + if (axes%is_h_point) dimensions = trim(dimensions)//" xh, yh," + if (axes%is_q_point) dimensions = trim(dimensions)//" xq, yq," + if (axes%is_u_point) dimensions = trim(dimensions)//" xq, yh," + if (axes%is_v_point) dimensions = trim(dimensions)//" xh, yq," + if (axes%is_layer) dimensions = trim(dimensions)//" zl," + if (axes%is_interface) dimensions = trim(dimensions)//" zi," + if (len_trim(dimensions) > 0) dimensions = trim_trailing_commas(dimensions) + ! Document diagnostics in list of available diagnostics if (is_root_pe() .and. diag_CS%available_diag_doc_unit > 0) then if (present(cmor_field_name)) then call log_available_diag(associated(diag), module_name, field_name, '', '', diag_CS, & long_name, units, standard_name, & - variants="{"//trim(field_name)//","//trim(cmor_field_name)//"}") + variants="{"//trim(field_name)//","//trim(cmor_field_name)//"}", & + dimensions=dimensions) else call log_available_diag(associated(diag), module_name, field_name, '', '', diag_CS, & - long_name, units, standard_name) + long_name, units, standard_name, dimensions=dimensions) endif endif @@ -3039,23 +3309,26 @@ subroutine describe_option(opt_name, value, diag_CS) end subroutine describe_option !> Registers a diagnostic using the information encapsulated in the vardesc -!! type argument and returns an integer handle to this diagostic. That +!! type argument and returns an integer handle to this diagnostic. That !! integer handle is negative if the diagnostic is unused. function ocean_register_diag(var_desc, G, diag_CS, day) integer :: ocean_register_diag !< An integer handle to this diagnostic. type(vardesc), intent(in) :: var_desc !< The vardesc type describing the diagnostic type(ocean_grid_type), intent(in) :: G !< The ocean's grid type - type(diag_ctrl), intent(in), target :: diag_CS !< The diagnotic control structure + type(diag_ctrl), intent(in), target :: diag_CS !< The diagnostic control structure type(time_type), intent(in) :: day !< The current model time character(len=64) :: var_name ! A variable's name. character(len=48) :: units ! A variable's units. character(len=240) :: longname ! A variable's longname. character(len=8) :: hor_grid, z_grid ! Variable grid info. + real :: conversion ! A multiplicative factor for unit conversions for output, + ! as might be needed to convert from intensive to extensive + ! or for dimensional consistency testing [various] or [a A-1 ~> 1] type(axes_grp), pointer :: axes => NULL() call query_vardesc(var_desc, units=units, longname=longname, hor_grid=hor_grid, & - z_grid=z_grid, caller="ocean_register_diag") + z_grid=z_grid, conversion=conversion, caller="ocean_register_diag") ! Use the hor_grid and z_grid components of vardesc to determine the ! desired axes to register the diagnostic field for. @@ -3110,8 +3383,8 @@ function ocean_register_diag(var_desc, G, diag_CS, day) "ocean_register_diag: unknown z_grid component "//trim(z_grid)) end select - ocean_register_diag = register_diag_field("ocean_model", trim(var_name), & - axes, day, trim(longname), trim(units), missing_value=-1.0e+34) + ocean_register_diag = register_diag_field("ocean_model", trim(var_name), axes, day, & + trim(longname), units=trim(units), conversion=conversion, missing_value=-1.0e+34) end function ocean_register_diag @@ -3142,14 +3415,20 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) ! Local variables integer :: ios, i, new_unit logical :: opened, new_file - logical :: answers_2018, default_2018_answers + integer :: 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. + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: om4_remap_via_sub_cells ! Use the OM4-era ramap_via_sub_cells for diagnostics + logical :: dz_diag_needed ! Logical set True if we need to store dz_begin for reintegrating character(len=8) :: this_pe character(len=240) :: doc_file, doc_file_dflt, doc_path character(len=240), allocatable :: diag_coords(:) ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_diag_mediator" ! This module's name. - character(len=32) :: filename_appendix = '' !fms appendix to filename for ensemble runs + character(len=32) :: filename_appendix = '' ! FMS appendix to filename for ensemble runs id_clock_diag_mediator = cpu_clock_id('(Ocean diagnostics framework)', grain=CLOCK_MODULE) id_clock_diag_remap = cpu_clock_id('(Ocean diagnostics remapping)', grain=CLOCK_ROUTINE) @@ -3162,6 +3441,8 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) call initialize_diag_type(diag_cs%diags(i)) enddo + diag_cs%show_call_tree = callTree_showQuery() + ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") @@ -3169,17 +3450,27 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) 'The number of diagnostic vertical coordinates to use. '//& 'For each coordinate, an entry in DIAG_COORDS must be provided.', & default=1) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) - call get_param(param_file, mdl, 'USE_GRID_SPACE_DIAGNOSTIC_AXES', diag_cs%grid_space_axes, & + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + do_not_log=.true., default=.true.) + call get_param(param_file, mdl, "DIAG_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for diagnostics. "//& + "See REMAPPING_USE_OM4_SUBCELLS for details. "//& + "We recommend setting this option to false.", default=om4_remap_via_sub_cells) + call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & + "The vintage of the expressions and order of arithmetic to use for remapping. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) + call get_param(param_file, mdl, 'USE_INDEX_DIAGNOSTIC_AXES', diag_cs%index_space_axes, & 'If true, use a grid index coordinate convention for diagnostic axes. ',& default=.false.) + dz_diag_needed = .false. if (diag_cs%num_diag_coords>0) then allocate(diag_coords(diag_cs%num_diag_coords)) if (diag_cs%num_diag_coords==1) then ! The default is to provide just one instance of Z* @@ -3198,14 +3489,15 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) allocate(diag_cs%diag_remap_cs(diag_cs%num_diag_coords)) ! Initialize each diagnostic vertical coordinate do i=1, diag_cs%num_diag_coords - call diag_remap_init(diag_cs%diag_remap_cs(i), diag_coords(i), answers_2018=answers_2018) + call diag_remap_init(diag_cs%diag_remap_cs(i), diag_coords(i), om4_remap_via_sub_cells, remap_answer_date, GV) + if (diag_cs%diag_remap_cs(i)%Z_based_coord) dz_diag_needed = .true. enddo deallocate(diag_coords) endif call get_param(param_file, mdl, 'DIAG_MISVAL', diag_cs%missing_value, & 'Set the default missing value to use for diagnostics.', & - default=1.e20) + units="various", default=1.e20) call get_param(param_file, mdl, 'DIAG_AS_CHKSUM', diag_cs%diag_as_chksum, & 'Instead of writing diagnostics to the diag manager, write '//& 'a text file containing the checksum (bitcount) of the array.', & @@ -3214,7 +3506,7 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) if (diag_cs%diag_as_chksum) & diag_cs%num_chksum_diags = 0 - ! Keep pointers grid, h, T, S needed diagnostic remapping + ! Keep pointers to the grid, h, T, S needed for diagnostic remapping diag_cs%G => G diag_cs%GV => GV diag_cs%US => US @@ -3222,8 +3514,10 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) diag_cs%T => null() diag_cs%S => null() diag_cs%eqn_of_state => null() + diag_cs%tv => null() allocate(diag_cs%h_begin(G%isd:G%ied,G%jsd:G%jed,nz)) + if (dz_diag_needed) allocate(diag_cs%dz_begin(G%isd:G%ied,G%jsd:G%jed,nz)) #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__) allocate(diag_cs%h_old(G%isd:G%ied,G%jsd:G%jed,nz)) diag_cs%h_old(:,:,:) = 0.0 @@ -3234,7 +3528,7 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) diag_cs%isd = G%isd ; diag_cs%ied = G%ied diag_cs%jsd = G%jsd ; diag_cs%jed = G%jed - !Downsample indices for dl=2 (should be generalized to arbitrary dl, perhaps via a G array) + ! Downsample indices for dl=2 (should be generalized to arbitrary dl, perhaps via a G array) diag_cs%dsamp(2)%isc = G%HId2%isc - (G%HId2%isd-1) ; diag_cs%dsamp(2)%iec = G%HId2%iec - (G%HId2%isd-1) diag_cs%dsamp(2)%jsc = G%HId2%jsc - (G%HId2%jsd-1) ; diag_cs%dsamp(2)%jec = G%HId2%jec - (G%HId2%jsd-1) diag_cs%dsamp(2)%isd = G%HId2%isd ; diag_cs%dsamp(2)%ied = G%HId2%ied @@ -3284,8 +3578,8 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) endif if (is_root_pe() .and. (diag_CS%chksum_iounit < 0) .and. diag_CS%diag_as_chksum) then - !write(this_pe,'(i6.6)') PE_here() - !doc_file_dflt = "chksum_diag."//this_pe + ! write(this_pe,'(i6.6)') PE_here() + ! doc_file_dflt = "chksum_diag."//this_pe doc_file_dflt = "chksum_diag" call get_param(param_file, mdl, "CHKSUM_DIAG_FILE", doc_file, & "A file into which to write all checksums of the "//& @@ -3334,18 +3628,18 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) end subroutine diag_mediator_init !> Set pointers to the default state fields used to remap diagnostics. -subroutine diag_set_state_ptrs(h, T, S, eqn_of_state, diag_cs) +subroutine diag_set_state_ptrs(h, tv, diag_cs) real, dimension(:,:,:), target, intent(in ) :: h !< the model thickness array [H ~> m or kg m-2] - real, dimension(:,:,:), target, intent(in ) :: T !< the model temperature array - real, dimension(:,:,:), target, intent(in ) :: S !< the model salinity array - type(EOS_type), target, intent(in ) :: eqn_of_state !< Equation of state structure + type(thermo_var_ptrs), target, intent(in ) :: tv !< A structure with thermodynamic variables that are + !! used to convert thicknesses to vertical extents type(diag_ctrl), intent(inout) :: diag_cs !< diag mediator control structure ! Keep pointers to h, T, S needed for the diagnostic remapping diag_cs%h => h - diag_cs%T => T - diag_cs%S => S - diag_cs%eqn_of_state => eqn_of_state + diag_cs%T => tv%T + diag_cs%S => tv%S + diag_cs%eqn_of_state => tv%eqn_of_state + diag_cs%tv => tv end subroutine @@ -3357,18 +3651,23 @@ subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S, update_intensiv real, target, optional, intent(in ) :: alt_h(:,:,:) !< Used if remapped grids should be something other than !! the current thicknesses [H ~> m or kg m-2] real, target, optional, intent(in ) :: alt_T(:,:,:) !< Used if remapped grids should be something other than - !! the current temperatures + !! the current temperatures [C ~> degC] real, target, optional, intent(in ) :: alt_S(:,:,:) !< Used if remapped grids should be something other than - !! the current salinity + !! the current salinity [S ~> ppt] logical, optional, intent(in ) :: update_intensive !< If true (default), update the grids used for !! intensive diagnostics logical, optional, intent(in ) :: update_extensive !< If true (not default), update the grids used for !! intensive diagnostics ! Local variables - integer :: i - real, dimension(:,:,:), pointer :: h_diag => NULL() ! The layer thickneses for diagnostics [H ~> m or kg m-2] - real, dimension(:,:,:), pointer :: T_diag => NULL(), S_diag => NULL() - logical :: update_intensive_local, update_extensive_local + integer :: m + real, dimension(:,:,:), pointer :: h_diag => NULL() ! The layer thicknesses for diagnostics [H ~> m or kg m-2] + real, dimension(:,:,:), pointer :: T_diag => NULL() ! The layer temperatures for diagnostics [C ~> degC] + real, dimension(:,:,:), pointer :: S_diag => NULL() ! The layer salinities for diagnostics [S ~> ppt] + real, dimension(diag_cs%G%isd:diag_cS%G%ied, diag_cs%G%jsd:diag_cS%G%jed, diag_cs%GV%ke) :: & + dz_diag ! Layer vertical extents for remapping [Z ~> m] + logical :: update_intensive_local, update_extensive_local, dz_diag_needed + + if (diag_cs%show_call_tree) call callTree_enter("diag_update_remap_grids()") ! Set values based on optional input arguments if (present(alt_h)) then @@ -3405,17 +3704,39 @@ subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S, update_intensiv "diagnostic structure have been overridden") endif + ! Determine the diagnostic grid spacing in height units, if it is needed. + dz_diag_needed = .false. + if (update_intensive_local .or. update_extensive_local) then + do m=1, diag_cs%num_diag_coords + if (diag_cs%diag_remap_cs(m)%Z_based_coord) dz_diag_needed = .true. + enddo + endif + if (dz_diag_needed) then + call thickness_to_dz(h_diag, diag_cs%tv, dz_diag, diag_cs%G, diag_cs%GV, diag_cs%US, halo_size=1) + endif + if (update_intensive_local) then - do i=1, diag_cs%num_diag_coords - call diag_remap_update(diag_cs%diag_remap_cs(i), diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, T_diag, S_diag, & - diag_cs%eqn_of_state, diag_cs%diag_remap_cs(i)%h) + do m=1, diag_cs%num_diag_coords + if (diag_cs%diag_remap_cs(m)%Z_based_coord) then + call diag_remap_update(diag_cs%diag_remap_cs(m), diag_cs%G, diag_cs%GV, diag_cs%US, dz_diag, T_diag, S_diag, & + diag_cs%eqn_of_state, diag_cs%diag_remap_cs(m)%h) + else + call diag_remap_update(diag_cs%diag_remap_cs(m), diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, T_diag, S_diag, & + diag_cs%eqn_of_state, diag_cs%diag_remap_cs(m)%h) + endif enddo endif if (update_extensive_local) then diag_cs%h_begin(:,:,:) = diag_cs%h(:,:,:) - do i=1, diag_cs%num_diag_coords - call diag_remap_update(diag_cs%diag_remap_cs(i), diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, T_diag, S_diag, & - diag_cs%eqn_of_state, diag_cs%diag_remap_cs(i)%h_extensive) + if (dz_diag_needed) diag_cs%dz_begin(:,:,:) = dz_diag(:,:,:) + do m=1, diag_cs%num_diag_coords + if (diag_cs%diag_remap_cs(m)%Z_based_coord) then + call diag_remap_update(diag_cs%diag_remap_cs(m), diag_cs%G, diag_cs%GV, diag_cs%US, dz_diag, T_diag, S_diag, & + diag_cs%eqn_of_state, diag_cs%diag_remap_cs(m)%h_extensive) + else + call diag_remap_update(diag_cs%diag_remap_cs(m), diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, T_diag, S_diag, & + diag_cs%eqn_of_state, diag_cs%diag_remap_cs(m)%h_extensive) + endif enddo endif @@ -3427,6 +3748,8 @@ subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S, update_intensiv if (id_clock_diag_grid_updates>0) call cpu_clock_end(id_clock_diag_grid_updates) + if (diag_cs%show_call_tree) call callTree_leave("diag_update_remap_grids()") + end subroutine diag_update_remap_grids !> Sets up the 2d and 3d masks for native diagnostics @@ -3467,11 +3790,34 @@ subroutine diag_masks_set(G, nz, diag_cs) diag_cs%mask3dCvi(:,:,k) = diag_cs%mask2dCv(:,:) enddo - !Allocate and initialize the downsampled masks + ! Allocate and initialize the downsampled masks call downsample_diag_masks_set(G, nz, diag_cs) end subroutine diag_masks_set +!> Set the extents and fill values for the piecemeal buffers for all axes +subroutine set_piecemeal_extents(diag_cs) + type(diag_ctrl), intent(inout) :: diag_cs !< A pointer to a type with many variables + !! used for diagnostics + + ! Piecemeal buffers for 2d axes + call diag_cs%axesT1%piecemeal_2d%set_extents_from_array(diag_cs%mask2dT, diag_cs%missing_value) + call diag_cs%axesB1%piecemeal_2d%set_extents_from_array(diag_cs%mask2dBu, diag_cs%missing_value) + call diag_cs%axesCu1%piecemeal_2d%set_extents_from_array(diag_cs%mask2dCu, diag_cs%missing_value) + call diag_cs%axesCv1%piecemeal_2d%set_extents_from_array(diag_cs%mask2dCv, diag_cs%missing_value) + + ! Piecemeal buffers for 3d axes + call diag_cs%axesTL%piecemeal_3d%set_extents_from_array(diag_cs%mask3dTL, diag_cs%missing_value) + call diag_cs%axesBL%piecemeal_3d%set_extents_from_array(diag_cs%mask3dBL, diag_cs%missing_value) + call diag_cs%axesCuL%piecemeal_3d%set_extents_from_array(diag_cs%mask3dCuL, diag_cs%missing_value) + call diag_cs%axesCvL%piecemeal_3d%set_extents_from_array(diag_cs%mask3dCvL, diag_cs%missing_value) + call diag_cs%axesTi%piecemeal_3d%set_extents_from_array(diag_cs%mask3dTi, diag_cs%missing_value) + call diag_cs%axesBi%piecemeal_3d%set_extents_from_array(diag_cs%mask3dBi, diag_cs%missing_value) + call diag_cs%axesCui%piecemeal_3d%set_extents_from_array(diag_cs%mask3dCui, diag_cs%missing_value) + call diag_cs%axesCvi%piecemeal_3d%set_extents_from_array(diag_cs%mask3dCvi, diag_cs%missing_value) + +end subroutine set_piecemeal_extents + subroutine diag_mediator_close_registration(diag_CS) type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output @@ -3529,37 +3875,45 @@ subroutine diag_mediator_end(time, diag_CS, end_diag_manager) enddo call diag_grid_storage_end(diag_cs%diag_grid_temp) - deallocate(diag_cs%mask3dTL) - deallocate(diag_cs%mask3dBL) - deallocate(diag_cs%mask3dCuL) - deallocate(diag_cs%mask3dCvL) - deallocate(diag_cs%mask3dTi) - deallocate(diag_cs%mask3dBi) - deallocate(diag_cs%mask3dCui) - deallocate(diag_cs%mask3dCvi) + if (associated(diag_cs%mask3dTL)) deallocate(diag_cs%mask3dTL) + if (associated(diag_cs%mask3dBL)) deallocate(diag_cs%mask3dBL) + if (associated(diag_cs%mask3dCuL)) deallocate(diag_cs%mask3dCuL) + if (associated(diag_cs%mask3dCvL)) deallocate(diag_cs%mask3dCvL) + if (associated(diag_cs%mask3dTi)) deallocate(diag_cs%mask3dTi) + if (associated(diag_cs%mask3dBi)) deallocate(diag_cs%mask3dBi) + if (associated(diag_cs%mask3dCui)) deallocate(diag_cs%mask3dCui) + if (associated(diag_cs%mask3dCvi)) deallocate(diag_cs%mask3dCvi) do dl=2,MAX_DSAMP_LEV - deallocate(diag_cs%dsamp(dl)%mask2dT) - deallocate(diag_cs%dsamp(dl)%mask2dBu) - deallocate(diag_cs%dsamp(dl)%mask2dCu) - deallocate(diag_cs%dsamp(dl)%mask2dCv) - deallocate(diag_cs%dsamp(dl)%mask3dTL) - deallocate(diag_cs%dsamp(dl)%mask3dBL) - deallocate(diag_cs%dsamp(dl)%mask3dCuL) - deallocate(diag_cs%dsamp(dl)%mask3dCvL) - deallocate(diag_cs%dsamp(dl)%mask3dTi) - deallocate(diag_cs%dsamp(dl)%mask3dBi) - deallocate(diag_cs%dsamp(dl)%mask3dCui) - deallocate(diag_cs%dsamp(dl)%mask3dCvi) + if (associated(diag_cs%dsamp(dl)%mask2dT)) deallocate(diag_cs%dsamp(dl)%mask2dT) + if (associated(diag_cs%dsamp(dl)%mask2dBu)) deallocate(diag_cs%dsamp(dl)%mask2dBu) + if (associated(diag_cs%dsamp(dl)%mask2dCu)) deallocate(diag_cs%dsamp(dl)%mask2dCu) + if (associated(diag_cs%dsamp(dl)%mask2dCv)) deallocate(diag_cs%dsamp(dl)%mask2dCv) + if (associated(diag_cs%dsamp(dl)%mask3dTL)) deallocate(diag_cs%dsamp(dl)%mask3dTL) + if (associated(diag_cs%dsamp(dl)%mask3dBL)) deallocate(diag_cs%dsamp(dl)%mask3dBL) + if (associated(diag_cs%dsamp(dl)%mask3dCuL)) deallocate(diag_cs%dsamp(dl)%mask3dCuL) + if (associated(diag_cs%dsamp(dl)%mask3dCvL)) deallocate(diag_cs%dsamp(dl)%mask3dCvL) + if (associated(diag_cs%dsamp(dl)%mask3dTi)) deallocate(diag_cs%dsamp(dl)%mask3dTi) + if (associated(diag_cs%dsamp(dl)%mask3dBi)) deallocate(diag_cs%dsamp(dl)%mask3dBi) + if (associated(diag_cs%dsamp(dl)%mask3dCui)) deallocate(diag_cs%dsamp(dl)%mask3dCui) + if (associated(diag_cs%dsamp(dl)%mask3dCvi)) deallocate(diag_cs%dsamp(dl)%mask3dCvi) do i=1,diag_cs%num_diag_coords - deallocate(diag_cs%dsamp(dl)%remap_axesTL(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesCuL(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesCvL(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesBL(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesTi(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesCui(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesCvi(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesBi(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesTL(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesTL(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesCuL(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCuL(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesCvL(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCvL(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesBL(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesBL(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesTi(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesTi(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesCui(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCui(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesCvi(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCvi(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesBi(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesBi(i)%dsamp(dl)%mask3d) enddo enddo @@ -3620,28 +3974,6 @@ subroutine diag_mediator_end(time, diag_CS, end_diag_manager) end subroutine diag_mediator_end -!> Convert the first n elements (up to 3) of an integer array to an underscore delimited string. -function i2s(a,n_in) - ! "Convert the first n elements of an integer array to a string." - ! Perhaps this belongs elsewhere in the MOM6 code? - integer, dimension(:), intent(in) :: a !< The array of integers to translate - integer, optional , intent(in) :: n_in !< The number of elements to translate, by default all - character(len=15) :: i2s !< The returned string - - character(len=15) :: i2s_temp - integer :: i,n - - n=size(a) - if (present(n_in)) n = n_in - - i2s = '' - do i=1,min(n,3) - write (i2s_temp, '(I4.4)') a(i) - i2s = trim(i2s) //'_'// trim(i2s_temp) - enddo - i2s = adjustl(i2s) -end function i2s - !> Returns a new diagnostic id, it may be necessary to expand the diagnostics array. integer function get_new_diag_id(diag_cs) type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure @@ -3686,7 +4018,7 @@ subroutine initialize_diag_type(diag) end subroutine initialize_diag_type !> Make a new diagnostic. Either use memory which is in the array of 'primary' -!! diagnostics, or if that is in use, insert it to the list of secondary diags. +!! diagnostics, or if that is in use, insert it to the list of secondary diagnostics. subroutine alloc_diag_with_id(diag_id, diag_cs, diag) integer, intent(in ) :: diag_id !< id for the diagnostic type(diag_ctrl), target, intent(inout) :: diag_cs !< structure used to regulate diagnostic output @@ -3708,13 +4040,14 @@ end subroutine alloc_diag_with_id !> Log a diagnostic to the available diagnostics file. subroutine log_available_diag(used, module_name, field_name, cell_methods_string, comment, & - diag_CS, long_name, units, standard_name, variants) + diag_CS, long_name, units, standard_name, variants, dimensions) logical, intent(in) :: used !< Whether this diagnostic was in the diag_table or not character(len=*), intent(in) :: module_name !< Name of the diagnostic module character(len=*), intent(in) :: field_name !< Name of this diagnostic field character(len=*), intent(in) :: cell_methods_string !< The spatial component of the CF cell_methods attribute character(len=*), intent(in) :: comment !< A comment to append after [Used|Unused] - type(diag_ctrl), intent(in) :: diag_CS !< The diagnotics control structure + type(diag_ctrl), intent(in) :: diag_CS !< The diagnostics control structure + character(len=*), optional, intent(in) :: dimensions !< Descriptor of the horizontal and vertical dimensions character(len=*), optional, intent(in) :: long_name !< CF long name of diagnostic character(len=*), optional, intent(in) :: units !< Units for diagnostic character(len=*), optional, intent(in) :: standard_name !< CF standardized name of diagnostic @@ -3729,11 +4062,16 @@ subroutine log_available_diag(used, module_name, field_name, cell_methods_string mesg = '"'//trim(field_name)//'" [Unused]' endif if (len(trim((comment)))>0) then - write(diag_CS%available_diag_doc_unit, '(a,x,"(",a,")")') trim(mesg),trim(comment) + write(diag_CS%available_diag_doc_unit, '(a,1x,"(",a,")")') trim(mesg),trim(comment) else write(diag_CS%available_diag_doc_unit, '(a)') trim(mesg) endif call describe_option("modules", module_name, diag_CS) + if (present(dimensions)) then + if (len(trim(dimensions)) > 0) then + call describe_option("dimensions", dimensions, diag_CS) + endif + endif if (present(long_name)) call describe_option("long_name", long_name, diag_CS) if (present(units)) call describe_option("units", units, diag_CS) if (present(standard_name)) & @@ -3751,7 +4089,7 @@ subroutine log_chksum_diag(docunit, description, chksum) character(len=*), intent(in) :: description !< Name of the diagnostic module integer, intent(in) :: chksum !< chksum of the diagnostic - write(docunit, '(a,x,i9.8)') description, chksum + write(docunit, '(a,1x,i9.8)') description, chksum flush(docunit) end subroutine log_chksum_diag @@ -3761,7 +4099,7 @@ subroutine diag_grid_storage_init(grid_storage, G, GV, diag) type(diag_grid_storage), intent(inout) :: grid_storage !< Structure containing a snapshot of the target grids type(ocean_grid_type), intent(in) :: G !< Horizontal grid type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(diag_ctrl), intent(in) :: diag !< Diagnostic control structure used as the contructor + type(diag_ctrl), intent(in) :: diag !< Diagnostic control structure used as the constructor !! template for this routine integer :: m, nz @@ -3786,7 +4124,7 @@ end subroutine diag_grid_storage_init subroutine diag_copy_diag_to_storage(grid_storage, h_state, diag) type(diag_grid_storage), intent(inout) :: grid_storage !< Structure containing a snapshot of the target grids real, dimension(:,:,:), intent(in) :: h_state !< Current model thicknesses [H ~> m or kg m-2] - type(diag_ctrl), intent(in) :: diag !< Diagnostic control structure used as the contructor + type(diag_ctrl), intent(in) :: diag !< Diagnostic control structure used as the constructor integer :: m @@ -3803,7 +4141,7 @@ end subroutine diag_copy_diag_to_storage !> Copy from the stored diagnostic arrays to the main diagnostic grids subroutine diag_copy_storage_to_diag(diag, grid_storage) - type(diag_ctrl), intent(inout) :: diag !< Diagnostic control structure used as the contructor + type(diag_ctrl), intent(inout) :: diag !< Diagnostic control structure used as the constructor type(diag_grid_storage), intent(in) :: grid_storage !< Structure containing a snapshot of the target grids integer :: m @@ -3821,7 +4159,7 @@ end subroutine diag_copy_storage_to_diag !> Save the current diagnostic grids in the temporary structure within diag subroutine diag_save_grids(diag) - type(diag_ctrl), intent(inout) :: diag !< Diagnostic control structure used as the contructor + type(diag_ctrl), intent(inout) :: diag !< Diagnostic control structure used as the constructor integer :: m @@ -3837,7 +4175,7 @@ end subroutine diag_save_grids !> Restore the diagnostic grids from the temporary structure within diag subroutine diag_restore_grids(diag) - type(diag_ctrl), intent(inout) :: diag !< Diagnostic control structure used as the contructor + type(diag_ctrl), intent(inout) :: diag !< Diagnostic control structure used as the constructor integer :: m @@ -3856,7 +4194,7 @@ end subroutine diag_restore_grids subroutine diag_grid_storage_end(grid_storage) type(diag_grid_storage), intent(inout) :: grid_storage !< Structure containing a snapshot of the target grids ! Local variables - integer :: m, nz + integer :: m ! Don't do anything else if there are no remapped coordinates if (grid_storage%num_diag_coords < 1) return @@ -3871,7 +4209,7 @@ subroutine diag_grid_storage_end(grid_storage) deallocate(grid_storage%diag_grids) end subroutine diag_grid_storage_end -!< Allocate and initialize the masks for downsampled diagostics in diag_cs +!< Allocate and initialize the masks for downsampled diagnostics in diag_cs !! The downsampled masks in the axes would later "point" to these. subroutine downsample_diag_masks_set(G, nz, diag_cs) type(ocean_grid_type), target, intent(in) :: G !< The ocean grid type. @@ -3879,7 +4217,7 @@ subroutine downsample_diag_masks_set(G, nz, diag_cs) type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables !! used for diagnostics ! Local variables - integer :: i,j,k,ii,jj,dl + integer :: k, dl !print*,'original c extents ',G%isc,G%iec,G%jsc,G%jec !print*,'original c extents ',G%iscb,G%iecb,G%jscb,G%jecb @@ -3897,13 +4235,13 @@ subroutine downsample_diag_masks_set(G, nz, diag_cs) do dl=2,MAX_DSAMP_LEV ! 2d mask - call downsample_mask(G%mask2dT, diag_cs%dsamp(dl)%mask2dT, dl,G%isc, G%jsc, & + call downsample_mask(G%mask2dT, diag_cs%dsamp(dl)%mask2dT, dl, G%isc, G%jsc, G%isd, G%jsd, & G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec, G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed) - call downsample_mask(G%mask2dBu,diag_cs%dsamp(dl)%mask2dBu, dl,G%IscB,G%JscB, & - G%HId2%IscB,G%HId2%IecB,G%HId2%JscB,G%HId2%JecB,G%HId2%IsdB,G%HId2%IedB,G%HId2%JsdB,G%HId2%JedB) - call downsample_mask(G%mask2dCu,diag_cs%dsamp(dl)%mask2dCu, dl,G%IscB,G%JscB, & - G%HId2%IscB,G%HId2%IecB,G%HId2%jsc, G%HId2%jec,G%HId2%IsdB,G%HId2%IedB,G%HId2%jsd, G%HId2%jed) - call downsample_mask(G%mask2dCv,diag_cs%dsamp(dl)%mask2dCv, dl,G%isc ,G%JscB, & + call downsample_mask(G%mask2dBu, diag_cs%dsamp(dl)%mask2dBu, dl,G%IscB, G%JscB, G%IsdB, G%JsdB, & + G%HId2%IscB,G%HId2%IecB, G%HId2%JscB,G%HId2%JecB,G%HId2%IsdB,G%HId2%IedB,G%HId2%JsdB,G%HId2%JedB) + call downsample_mask(G%mask2dCu, diag_cs%dsamp(dl)%mask2dCu, dl, G%IscB, G%jsc, G%IsdB, G%jsd, & + G%HId2%IscB,G%HId2%IecB, G%HId2%jsc, G%HId2%jec,G%HId2%IsdB,G%HId2%IedB,G%HId2%jsd, G%HId2%jed) + call downsample_mask(G%mask2dCv, diag_cs%dsamp(dl)%mask2dCv, dl,G %isc ,G%JscB, G%isd, G%JsdB, & G%HId2%isc ,G%HId2%iec, G%HId2%JscB,G%HId2%JecB,G%HId2%isd ,G%HId2%ied, G%HId2%JsdB,G%HId2%JedB) ! 3d native masks are needed by diag_manager but the native variables ! can only be masked 2d - for ocean points, all layers exists. @@ -3931,7 +4269,7 @@ subroutine downsample_diag_masks_set(G, nz, diag_cs) end subroutine downsample_diag_masks_set !> Get the diagnostics-compute indices (to be passed to send_data) based on the shape of -!! the diag field (the same way they are deduced for non-downsampled fields) +!! the diagnostic field (the same way they are deduced for non-downsampled fields) subroutine downsample_diag_indices_get(fo1, fo2, dl, diag_cs, isv, iev, jsv, jev) integer, intent(in) :: fo1 !< The size of the diag field in x integer, intent(in) :: fo2 !< The size of the diag field in y @@ -3942,16 +4280,15 @@ subroutine downsample_diag_indices_get(fo1, fo2, dl, diag_cs, isv, iev, jsv, jev integer, intent(out) :: jsv !< j-start index for diagnostics integer, intent(out) :: jev !< j-end index for diagnostics ! Local variables - integer :: dszi,cszi,dszj,cszj,f1,f2 + integer :: dszi, cszi, dszj, cszj, f1, f2 character(len=500) :: mesg logical, save :: first_check = .true. - !Check ONCE that the downsampled diag-compute domain is commensurate with the original - !non-downsampled diag-compute domain. - !This is a major limitation of the current implementation of the downsampled diagnostics. - !We assume that the compute domain can be subdivided to dl*dl cells, hence avoiding the need of halo updates. - !We want this check to error out only if there was a downsampled diagnostics requested and about to post that is - !why the check is here and not in the init routines. This check need to be done only once, hence the outer if. + ! The current implementation of the downsampled diagnostics assumes that the tracer-point + ! computational domain on each processor can be evenly divided by dL in each direction, which + ! avoids the need for halo updates or checks that the halo regions are up-to-date. The following + ! check that this assumption is true is only relevant if there are in fact downsampled diagnostics, + ! which is why it occurs during the first call to this routine instead of during initialization. if (first_check) then if (mod(diag_cs%ie-diag_cs%is+1, dl) /= 0 .OR. mod(diag_cs%je-diag_cs%js+1, dl) /= 0) then write (mesg,*) "Non-commensurate downsampled domain is not supported. "//& @@ -3968,14 +4305,15 @@ subroutine downsample_diag_indices_get(fo1, fo2, dl, diag_cs, isv, iev, jsv, jev jsv = diag_cs%dsamp(dl)%jsc ; jev = diag_cs%dsamp(dl)%jec f1 = fo1/dl f2 = fo2/dl - !Correction for the symmetric case + ! Correction for the symmetric case if (diag_cs%G%symmetric) then f1 = f1 + mod(fo1,dl) f2 = f2 + mod(fo2,dl) endif + + ! Find the range of indices in the downscaled computational domain. if ( f1 == dszi ) then - isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec ! field on Data domain, take compute domain indcies - !The rest is not taken with the full MOM6 diag_table + isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec ! Field on Data domain, take compute domain indices elseif ( f1 == dszi + 1 ) then isv = diag_cs%dsamp(dl)%isc ; iev = diag_cs%dsamp(dl)%iec+1 ! Symmetric data domain elseif ( f1 == cszi) then @@ -4002,12 +4340,12 @@ subroutine downsample_diag_indices_get(fo1, fo2, dl, diag_cs, isv, iev, jsv, jev endif end subroutine downsample_diag_indices_get -!> This subroutine allocates and computes a downsampled array from an input array -!! It also determines the diagnostics-compurte indices for the downsampled array +!> This subroutine allocates and computes a downsampled array from an input array. +!! It also determines the diagnostic computational grid indices for the downsampled array. !! 3d interface subroutine downsample_diag_field_3d(locfield, locfield_dsamp, dl, diag_cs, diag, isv, iev, jsv, jev, mask) - real, dimension(:,:,:), pointer :: locfield !< Input array pointer - real, dimension(:,:,:), allocatable, intent(inout) :: locfield_dsamp !< Output (downsampled) array + real, dimension(:,:,:), pointer :: locfield !< Input array pointer in arbitrary units [A ~> a] + real, dimension(:,:,:), allocatable, intent(inout) :: locfield_dsamp !< Output (downsampled) array [A ~> a] type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post integer, intent(in) :: dl !< Level of down sampling @@ -4015,21 +4353,20 @@ subroutine downsample_diag_field_3d(locfield, locfield_dsamp, dl, diag_cs, diag, integer, intent(inout) :: iev !< i-end index for diagnostics integer, intent(inout) :: jsv !< j-start index for diagnostics integer, intent(inout) :: jev !< j-end index for diagnostics - real, optional,target, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. - ! Locals - real, dimension(:,:,:), pointer :: locmask - integer :: f1,f2,isv_o,jsv_o + real, optional,target, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask [nondim] + ! Local variables + real, dimension(:,:,:), pointer :: locmask ! A pointer to the mask [nondim] + integer :: f1, f2, isv_o, jsv_o locmask => NULL() - !Get the correct indices corresponding to input field - !Shape of the input diag field + ! Get the correct indices corresponding to input field based on its shape. f1 = size(locfield, 1) f2 = size(locfield, 2) - !Save the extents of the original (fine) domain + ! Save the extents of the original (fine) domain isv_o = isv ; jsv_o = jsv - !Get the shape of the downsampled field and overwrite isv,iev,jsv,jev with them + ! Get the shape of the downsampled field and overwrite isv, iev, jsv and jev with them call downsample_diag_indices_get(f1, f2, dl, diag_cs, isv, iev, jsv, jev) - !Set the non-downsampled mask, it must be associated and initialized + ! Set the pointer to the non-downsampled mask, which must be associated and initialized if (present(mask)) then locmask => mask elseif (associated(diag%axes%mask3d)) then @@ -4043,12 +4380,12 @@ subroutine downsample_diag_field_3d(locfield, locfield_dsamp, dl, diag_cs, diag, end subroutine downsample_diag_field_3d -!> This subroutine allocates and computes a downsampled array from an input array -!! It also determines the diagnostics-compurte indices for the downsampled array +!> This subroutine allocates and computes a downsampled array from an input array. +!! It also determines the diagnostic computational grid indices for the downsampled array. !! 2d interface subroutine downsample_diag_field_2d(locfield, locfield_dsamp, dl, diag_cs, diag, isv, iev, jsv, jev, mask) - real, dimension(:,:), pointer :: locfield !< Input array pointer - real, dimension(:,:), allocatable, intent(inout) :: locfield_dsamp !< Output (downsampled) array + real, dimension(:,:), pointer :: locfield !< Input array pointer in arbitrary units [A ~> a] + real, dimension(:,:), allocatable, intent(inout) :: locfield_dsamp !< Output (downsampled) array [A ~> a] type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post integer, intent(in) :: dl !< Level of down sampling @@ -4056,21 +4393,20 @@ subroutine downsample_diag_field_2d(locfield, locfield_dsamp, dl, diag_cs, diag, integer, intent(inout) :: iev !< i-end index for diagnostics integer, intent(inout) :: jsv !< j-start index for diagnostics integer, intent(inout) :: jev !< j-end index for diagnostics - real, optional,target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. - ! Locals - real, dimension(:,:), pointer :: locmask - integer :: f1,f2,isv_o,jsv_o + real, optional,target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask [nondim]. + ! Local variables + real, dimension(:,:), pointer :: locmask ! A pointer to the mask [nondim] + integer :: f1, f2, isv_o, jsv_o locmask => NULL() - !Get the correct indices corresponding to input field - !Shape of the input diag field + ! Get the correct indices corresponding to input field based on its shape. f1 = size(locfield,1) f2 = size(locfield,2) - !Save the extents of the original (fine) domain + ! Save the extents of the original (fine) domain isv_o = isv ; jsv_o = jsv - !Get the shape of the downsampled field and overwrite isv,iev,jsv,jev with them - call downsample_diag_indices_get(f1,f2, dl, diag_cs,isv,iev,jsv,jev) - !Set the non-downsampled mask, it must be associated and initialized + ! Get the shape of the downsampled field and overwrite isv, iev, jsv and jev with them + call downsample_diag_indices_get(f1, f2, dl, diag_cs, isv, iev, jsv, jev) + ! Set the non-downsampled mask, it must be associated and initialized if (present(mask)) then locmask => mask elseif (associated(diag%axes%mask2d)) then @@ -4080,7 +4416,7 @@ subroutine downsample_diag_field_2d(locfield, locfield_dsamp, dl, diag_cs, diag, endif call downsample_field(locfield, locfield_dsamp, dl, diag%xyz_method, locmask, diag_cs,diag, & - isv_o,jsv_o,isv,iev,jsv,jev) + isv_o, jsv_o, isv, iev, jsv, jev) end subroutine downsample_diag_field_2d @@ -4089,7 +4425,7 @@ end subroutine downsample_diag_field_2d !! The down sample method could be deduced (before send_data call) !! from the diag%x_cell_method, diag%y_cell_method and diag%v_cell_method !! -!! This is the summary of the down sample algoritm for a diagnostic field f: +!! This is the summary of the down sample algorithm for a diagnostic field f: !! \f[ !! f(Id,Jd) = \sum_{i,j} f(Id+i,Jd+j) * weight(Id+i,Jd+j) / [ \sum_{i,j} weight(Id+i,Jd+j)] !! \f] @@ -4121,12 +4457,13 @@ end subroutine downsample_diag_field_2d !> This subroutine allocates and computes a down sampled 3d array given an input array !! The down sample method is based on the "cell_methods" for the diagnostics as explained !! in the above table -subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, diag,isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d) - real, dimension(:,:,:), pointer :: field_in !< Original field to be down sampled - real, dimension(:,:,:), allocatable :: field_out !< down sampled field +subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, diag, & + isv_o, jsv_o, isv_d, iev_d, jsv_d, jev_d) + real, dimension(:,:,:), pointer :: field_in !< Original field to be downsampled in arbitrary units [A ~> a] + real, dimension(:,:,:), allocatable :: field_out !< Downsampled field in the same arbitrary units [A ~> a] integer, intent(in) :: dl !< Level of down sampling integer, intent(in) :: method !< Sampling method - real, dimension(:,:,:), pointer :: mask !< Mask for field + real, dimension(:,:,:), pointer :: mask !< Mask for field [nondim] type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post integer, intent(in) :: isv_o !< Original i-start index @@ -4135,11 +4472,16 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d integer, intent(in) :: iev_d !< i-end index of down sampled data integer, intent(in) :: jsv_d !< j-start index of down sampled data integer, intent(in) :: jev_d !< j-end index of down sampled data - ! Locals + ! Local variables character(len=240) :: mesg - integer :: i,j,ii,jj,i0,j0,f1,f2,f_in1,f_in2 - integer :: k,ks,ke - real :: ave,total_weight,weight + integer :: i, j, ii, jj, i0, j0, f1, f2, f_in1, f_in2 + integer :: k, ks, ke + real :: ave ! The running sum of the average, in [A ~> a], [A L2 ~> a m2], + ! [A H L ~> a m2 or a kg m-1] or [A H L2 ~> a m3 or a kg] + real :: weight ! The nondimensional, area-, volume- or mass-based weight for an input + ! value [nondim], [L2 ~> m2], [H L ~> m2 or kg m-1] or [H L2 ~> m3 or kg] + real :: total_weight ! The sum of weights contributing to a point [nondim], [L2 ~> m2], + ! [H L ~> m2 or kg m-1] or [H L2 ~> m3 or kg] real :: eps_vol ! A negligibly small volume or mass [H L2 ~> m3 or kg] real :: eps_area ! A negligibly small area [L2 ~> m2] real :: eps_face ! A negligibly small face area [H L ~> m2 or kg m-1] @@ -4156,14 +4498,16 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d f_in2 = size(field_in,2) f1 = f_in1/dl f2 = f_in2/dl - !Correction for the symmetric case + ! Correction for the symmetric case if (diag_cs%G%symmetric) then f1 = f1 + mod(f_in1,dl) f2 = f2 + mod(f_in2,dl) endif allocate(field_out(1:f1,1:f2,ks:ke)) - ! Fill the down sampled field on the down sampled diagnostics (almost always compuate) domain + ! Fill the down sampled field on the down sampled diagnostics (almost always compute) domain + !### The averaging used here is not rotationally invariant. + ! Also, it would be better to use a max with eps_vol instead of adding it in the denominator. if (method == MMM) then do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) @@ -4171,14 +4515,13 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d ave = 0.0 total_weight = 0.0 do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 -! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 !This seems to be faster!!!! weight = mask(ii,jj,k) * diag_cs%G%areaT(ii,jj) * diag_cs%h(ii,jj,k) total_weight = total_weight + weight ave = ave+field_in(ii,jj,k) * weight enddo ; enddo - field_out(i,j,k) = ave/(total_weight + eps_vol) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j,k) = ave / (total_weight + eps_vol) ! Eps_vol avoids division by 0. enddo ; enddo ; enddo - elseif (method == SSS) then !e.g., volcello + elseif (method == SSS) then ! e.g., volcello do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -4187,21 +4530,20 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d weight = mask(ii,jj,k) ave = ave+field_in(ii,jj,k)*weight enddo ; enddo - field_out(i,j,k) = ave !Masked Sum (total_weight=1) + field_out(i,j,k) = ave ! This is a masked sum, and total_weight = 1. enddo ; enddo ; enddo - elseif (method == MMP .or. method == MMS) then !e.g., T_advection_xy + elseif (method == MMP .or. method == MMS) then ! e.g., T_advection_xy do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 total_weight = 0.0 do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 -! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 weight = mask(ii,jj,k) * diag_cs%G%areaT(ii,jj) total_weight = total_weight + weight - ave = ave+field_in(ii,jj,k)*weight + ave = ave+field_in(ii,jj,k) * weight enddo ; enddo - field_out(i,j,k) = ave / (total_weight+eps_area) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j,k) = ave / (total_weight + eps_area) ! Eps_area avoids division by 0. enddo ; enddo ; enddo elseif (method == PMM) then do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d @@ -4212,12 +4554,12 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d ii=i0 do jj=j0,j0+dl-1 weight = mask(ii,jj,k) * diag_cs%G%dyCu(ii,jj) * diag_cs%h(ii,jj,k) - total_weight = total_weight +weight - ave = ave+field_in(ii,jj,k)*weight + total_weight = total_weight + weight + ave = ave+field_in(ii,jj,k) * weight enddo - field_out(i,j,k) = ave/(total_weight+eps_face) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j,k) = ave / (total_weight + eps_face) ! Eps_face avoids division by 0. enddo ; enddo ; enddo - elseif (method == PSS) then !e.g. umo + elseif (method == PSS) then ! e.g. umo do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -4227,9 +4569,9 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d weight = mask(ii,jj,k) ave = ave+field_in(ii,jj,k)*weight enddo - field_out(i,j,k) = ave !Masked Sum (total_weight=1) + field_out(i,j,k) = ave ! This is a masked sum, and total_weight = 1. enddo ; enddo ; enddo - elseif (method == SPS) then !e.g. vmo + elseif (method == SPS) then ! e.g. vmo do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) j0 = jsv_o+dl*(j-jsv_d) @@ -4239,7 +4581,7 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d weight = mask(ii,jj,k) ave = ave+field_in(ii,jj,k)*weight enddo - field_out(i,j,k) = ave !Masked Sum (total_weight=1) + field_out(i,j,k) = ave ! This is a masked sum, and total_weight = 1. enddo ; enddo ; enddo elseif (method == MPM) then do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d @@ -4251,11 +4593,11 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d do ii=i0,i0+dl-1 weight = mask(ii,jj,k) * diag_cs%G%dxCv(ii,jj) * diag_cs%h(ii,jj,k) total_weight = total_weight + weight - ave = ave+field_in(ii,jj,k)*weight + ave = ave+field_in(ii,jj,k) * weight enddo - field_out(i,j,k) = ave/(total_weight+eps_face) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j,k) = ave / (total_weight + eps_face) ! Eps_face avoids division by 0. enddo ; enddo ; enddo - elseif (method == MSK) then !The input field is a mask, subsample + elseif (method == MSK) then ! The input field is a mask, so subsample it instead of averaging. field_out(:,:,:) = 0.0 do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) @@ -4278,11 +4620,11 @@ end subroutine downsample_field_3d !! in the above table subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, diag, & isv_o, jsv_o, isv_d, iev_d, jsv_d, jev_d) - real, dimension(:,:), pointer :: field_in !< Original field to be down sampled - real, dimension(:,:), allocatable :: field_out !< Down sampled field + real, dimension(:,:), pointer :: field_in !< Original field to be downsampled in arbitrary units [A ~> a] + real, dimension(:,:), allocatable :: field_out !< Downsampled field in the same arbitrary units [A ~> a] integer, intent(in) :: dl !< Level of down sampling integer, intent(in) :: method !< Sampling method - real, dimension(:,:), pointer :: mask !< Mask for field + real, dimension(:,:), pointer :: mask !< Mask for field [nondim] type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post integer, intent(in) :: isv_o !< Original i-start index @@ -4291,11 +4633,12 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d integer, intent(in) :: iev_d !< i-end index of down sampled data integer, intent(in) :: jsv_d !< j-start index of down sampled data integer, intent(in) :: jev_d !< j-end index of down sampled data - ! Locals + ! Local variables character(len=240) :: mesg - integer :: i,j,ii,jj,i0,j0,f1,f2,f_in1,f_in2 - real :: ave, total_weight, weight - real :: epsilon = 1.0e-20 ! A negligibly small count of weights [nondim] + integer :: i, j, ii, jj, i0, j0, f1, f2, f_in1, f_in2 + real :: ave ! The running sum of the average, in [A ~> a] or [A L2 ~> a m2] + real :: weight ! The nondimensional or area-weighted weight for an input value [nondim] or [L2 ~> m2] + real :: total_weight ! The sum of weights contributing to a point [nondim] or [L2 ~> m2] real :: eps_area ! A negligibly small area [L2 ~> m2] real :: eps_len ! A negligibly small horizontal length [L ~> m] @@ -4305,7 +4648,7 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d ! Allocate the down sampled field on the down sampled data domain ! allocate(field_out(diag_cs%dsamp(dl)%isd:diag_cs%dsamp(dl)%ied,diag_cs%dsamp(dl)%jsd:diag_cs%dsamp(dl)%jed)) ! allocate(field_out(1:size(field_in,1)/dl,1:size(field_in,2)/dl)) - ! Fill the down sampled field on the down sampled diagnostics (almost always compuate) domain + ! Fill the down sampled field on the down sampled diagnostics (almost always compute) domain f_in1 = size(field_in,1) f_in2 = size(field_in,2) f1 = f_in1/dl @@ -4324,12 +4667,11 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d ave = 0.0 total_weight = 0.0 do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 -! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 weight = mask(ii,jj)*diag_cs%G%areaT(ii,jj) total_weight = total_weight + weight - ave = ave+field_in(ii,jj)*weight + ave = ave+field_in(ii,jj) * weight enddo ; enddo - field_out(i,j) = ave/(total_weight + eps_area) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j) = ave / (total_weight + eps_area) ! Eps_area avoids division by 0. enddo ; enddo elseif (method == SSP) then ! e.g., T_dfxy_cont_tendency_2d do j=jsv_d,jev_d ; do i=isv_d,iev_d @@ -4337,11 +4679,10 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d j0 = jsv_o+dl*(j-jsv_d) ave = 0.0 do jj=j0,j0+dl-1 ; do ii=i0,i0+dl-1 -! do ii=i0,i0+dl-1 ; do jj=j0,j0+dl-1 weight = mask(ii,jj) ave = ave+field_in(ii,jj)*weight enddo ; enddo - field_out(i,j) = ave !Masked Sum (total_weight=1) + field_out(i,j) = ave ! This is a masked sum, and total_weight = 1. enddo ; enddo elseif (method == PSP) then ! e.g., umo_2d do j=jsv_d,jev_d ; do i=isv_d,iev_d @@ -4353,7 +4694,7 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d weight = mask(ii,jj) ave = ave+field_in(ii,jj)*weight enddo - field_out(i,j) = ave !Masked Sum (total_weight=1) + field_out(i,j) = ave ! This is a masked sum, and total_weight = 1. enddo ; enddo elseif (method == SPP) then ! e.g., vmo_2d do j=jsv_d,jev_d ; do i=isv_d,iev_d @@ -4365,7 +4706,7 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d weight = mask(ii,jj) ave = ave+field_in(ii,jj)*weight enddo - field_out(i,j) = ave !Masked Sum (total_weight=1) + field_out(i,j) = ave ! This is a masked sum, and total_weight = 1. enddo ; enddo elseif (method == PMP) then do j=jsv_d,jev_d ; do i=isv_d,iev_d @@ -4376,10 +4717,10 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d ii=i0 do jj=j0,j0+dl-1 weight = mask(ii,jj) * diag_cs%G%dyCu(ii,jj)!*diag_cs%h(ii,jj,1) !Niki? - total_weight = total_weight +weight - ave = ave+field_in(ii,jj)*weight + total_weight = total_weight + weight + ave = ave+field_in(ii,jj) * weight enddo - field_out(i,j) = ave/(total_weight+eps_len) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j) = ave / (total_weight + eps_len) ! Eps_len avoids division by 0. enddo ; enddo elseif (method == MPP) then do j=jsv_d,jev_d ; do i=isv_d,iev_d @@ -4393,9 +4734,9 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d total_weight = total_weight +weight ave = ave+field_in(ii,jj)*weight enddo - field_out(i,j) = ave/(total_weight+eps_len) !Avoid zero mask at all aggregating cells where ave=0.0 + field_out(i,j) = ave / (total_weight + eps_len) ! Eps_len avoids division by 0. enddo ; enddo - elseif (method == MSK) then !The input field is a mask, subsample + elseif (method == MSK) then ! The input field is a mask, so subsample it instead of averaging. field_out(:,:) = 0.0 do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) @@ -4416,10 +4757,12 @@ end subroutine downsample_field_2d !> Allocate and compute the 2d down sampled mask !! The masks are down sampled based on a minority rule, i.e., a coarse cell is open (1) !! if at least one of the sub-cells are open, otherwise it's closed (0) -subroutine downsample_mask_2d(field_in, field_out, dl, isc_o, jsc_o, isc_d, iec_d, jsc_d, jec_d, & - isd_d, ied_d, jsd_d, jed_d) - real, dimension(:,:), intent(in) :: field_in !< Original field to be down sampled - real, dimension(:,:), pointer :: field_out !< Down sampled field +subroutine downsample_mask_2d(field_in, field_out, dl, isc_o, jsc_o, isd_o, jsd_o, & + isc_d, iec_d, jsc_d, jec_d, isd_d, ied_d, jsd_d, jed_d) + integer, intent(in) :: isd_o !< Original data domain i-start index + integer, intent(in) :: jsd_o !< Original data domain j-start index + real, dimension(isd_o:,jsd_o:), intent(in) :: field_in !< Original field to be down sampled in arbitrary units [A] + real, dimension(:,:), pointer :: field_out !< Down sampled field mask [nondim] integer, intent(in) :: dl !< Level of down sampling integer, intent(in) :: isc_o !< Original i-start index integer, intent(in) :: jsc_o !< Original j-start index @@ -4427,13 +4770,14 @@ subroutine downsample_mask_2d(field_in, field_out, dl, isc_o, jsc_o, isc_d, iec_ integer, intent(in) :: iec_d !< Computational i-end index of down sampled data integer, intent(in) :: jsc_d !< Computational j-start index of down sampled data integer, intent(in) :: jec_d !< Computational j-end index of down sampled data - integer, intent(in) :: isd_d !< Computational i-start index of down sampled data - integer, intent(in) :: ied_d !< Computational i-end index of down sampled data - integer, intent(in) :: jsd_d !< Computational j-start index of down sampled data - integer, intent(in) :: jed_d !< Computational j-end index of down sampled data - ! Locals - integer :: i,j,ii,jj,i0,j0 - real :: tot_non_zero + integer, intent(in) :: isd_d !< Data domain i-start index of down sampled data + integer, intent(in) :: ied_d !< Data domain i-end index of down sampled data + integer, intent(in) :: jsd_d !< Data domain j-start index of down sampled data + integer, intent(in) :: jed_d !< Data domain j-end index of down sampled data + ! Local variables + integer :: i, j, ii, jj, i0, j0 + real :: tot_non_zero ! The sum of values in the down-scaled cell [A] + ! down sampled mask = 0 unless the mask value of one of the down sampling cells is 1 allocate(field_out(isd_d:ied_d,jsd_d:jed_d)) field_out(:,:) = 0.0 @@ -4451,10 +4795,12 @@ end subroutine downsample_mask_2d !> Allocate and compute the 3d down sampled mask !! The masks are down sampled based on a minority rule, i.e., a coarse cell is open (1) !! if at least one of the sub-cells are open, otherwise it's closed (0) -subroutine downsample_mask_3d(field_in, field_out, dl, isc_o, jsc_o, isc_d, iec_d, jsc_d, jec_d, & - isd_d, ied_d, jsd_d, jed_d) - real, dimension(:,:,:), intent(in) :: field_in !< Original field to be down sampled - real, dimension(:,:,:), pointer :: field_out !< down sampled field +subroutine downsample_mask_3d(field_in, field_out, dl, isc_o, jsc_o, isd_o, jsd_o, & + isc_d, iec_d, jsc_d, jec_d, isd_d, ied_d, jsd_d, jed_d) + integer, intent(in) :: isd_o !< Original data domain i-start index + integer, intent(in) :: jsd_o !< Original data domain j-start index + real, dimension(isd_o:,jsd_o:,:), intent(in) :: field_in !< Original field to be down sampled in arbitrary units [A] + real, dimension(:,:,:), pointer :: field_out !< down sampled field mask [nondim] integer, intent(in) :: dl !< Level of down sampling integer, intent(in) :: isc_o !< Original i-start index integer, intent(in) :: jsc_o !< Original j-start index @@ -4466,9 +4812,11 @@ subroutine downsample_mask_3d(field_in, field_out, dl, isc_o, jsc_o, isc_d, iec_ integer, intent(in) :: ied_d !< Computational i-end index of down sampled data integer, intent(in) :: jsd_d !< Computational j-start index of down sampled data integer, intent(in) :: jed_d !< Computational j-end index of down sampled data - ! Locals - integer :: i,j,ii,jj,i0,j0,k,ks,ke - real :: tot_non_zero + + ! Local variables + integer :: i, j, ii, jj, i0, j0, k, ks, ke + real :: tot_non_zero ! The sum of values in the down-scaled cell [A] + ! down sampled mask = 0 unless the mask value of one of the down sampling cells is 1 ks = lbound(field_in,3) ; ke = ubound(field_in,3) allocate(field_out(isd_d:ied_d,jsd_d:jed_d,ks:ke)) @@ -4500,4 +4848,9 @@ logical function found_in_diagtable(diag, varName) end function found_in_diagtable +!> Finishes the diag manager reduction methods as needed for the time_step +subroutine MOM_diag_send_complete() + call diag_send_complete_infra() +end subroutine MOM_diag_send_complete + end module MOM_diag_mediator diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index f9e5a35a09..c63e50ef9b 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -1,3 +1,7 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> provides runtime remapping of diagnostics to z star, sigma and !! rho vertical coordinates. !! @@ -15,66 +19,34 @@ !! the diagnostic is written out. -! NOTE: In the following functions, the fields are passed using 1-based -! indexing, which requires special handling within the grid index loops. -! -! * diag_remap_do_remap -! * vertically_reintegrate_diag_field -! * vertically_interpolate_diag_field -! * horizontally_average_diag_field -! -! Symmetric grids add an additional row of western and southern points to u- -! and v-grids. Non-symmetric grids are 1-based and symmetric grids are -! zero-based, allowing the same expressions to be used when accessing the -! fields. But if u- or v-points become 1-indexed, as in these functions, then -! the stencils must be re-assessed. -! -! For interpolation between h and u grids, we use the following relations: -! -! h->u: f_u(ig) = 0.5 * (f_h( ig ) + f_h(ig+1)) -! f_u(i1) = 0.5 * (f_h(i1-1) + f_h( i1 )) -! -! u->h: f_h(ig) = 0.5 * (f_u(ig-1) + f_u( ig )) -! f_h(i1) = 0.5 * (f_u( i1 ) + f_u(i1+1)) -! -! where ig is the grid index and i1 is the 1-based index. That is, a 1-based -! u-point is ahead of its matching h-point in non-symmetric mode, but behind -! its matching h-point in non-symmetric mode. -! -! We can combine these expressions by applying to ig a -1 shift on u-grids and -! a +1 shift on h-grids in symmetric mode. +! NOTE: In the following functions, the fields are initially passed using 1-based +! indexing, which are then passed to separate private internal routines that shift +! the indexing to use the same indexing conventions used elsewhere in the MOM6 code. ! -! We do not adjust the h-point indices, since they are assumed to be 1-based. -! This is only correct when global indexing is disabled. If global indexing is -! enabled, then all indices will need to be defined relative to the data -! domain. -! -! Finally, note that the mask input fields are pointers to arrays which are -! zero-indexed, and do not need any corrections over grid index loops. +! * diag_remap_do_remap, which calls do_remap +! * vertically_reintegrate_diag_field, which calls vertically_reintegrate_field +! * vertically_interpolate_diag_field, which calls vertically_interpolate_field +! * horizontally_average_diag_field, which calls horizontally_average_field module MOM_diag_remap -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_coms, only : reproducing_sum_EFP, EFP_to_real use MOM_coms, only : EFP_type, assignment(=), EFP_sum_across_PEs use MOM_error_handler, only : MOM_error, FATAL, assert, WARNING use MOM_debugging, only : check_column_integrals use MOM_diag_manager_infra,only : MOM_diag_axis_init -use MOM_diag_vkernels, only : interpolate_column, reintegrate_column use MOM_file_parser, only : get_param, log_param, param_file_type use MOM_string_functions, only : lowercase, extractWord use MOM_grid, only : ocean_grid_type use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : EOS_type -use MOM_remapping, only : remapping_CS, initialize_remapping -use MOM_remapping, only : remapping_core_h -use MOM_regridding, only : regridding_CS, initialize_regridding -use MOM_regridding, only : end_regridding +use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h +use MOM_remapping, only : interpolate_column, reintegrate_column +use MOM_regridding, only : regridding_CS, initialize_regridding, end_regridding use MOM_regridding, only : set_regrid_params, get_regrid_size -use MOM_regridding, only : getCoordinateInterfaces +use MOM_regridding, only : getCoordinateInterfaces, set_h_neglect, set_dz_neglect use MOM_regridding, only : get_zlike_CS, get_sigma_CS, get_rho_CS use regrid_consts, only : coordinateMode use coord_zlike, only : build_zstar_column @@ -84,6 +56,8 @@ module MOM_diag_remap implicit none ; private +#include "MOM_memory.h" + public diag_remap_ctrl public diag_remap_init, diag_remap_end, diag_remap_update, diag_remap_do_remap public diag_remap_configure_axes, diag_remap_axes_configured @@ -105,40 +79,60 @@ module MOM_diag_remap logical :: used = .false. !< Whether this coordinate actually gets used. integer :: vertical_coord = 0 !< The vertical coordinate that we remap to character(len=10) :: vertical_coord_name ='' !< The coordinate name as understood by ALE + logical :: Z_based_coord = .false. !< If true, this coordinate is based on remapping of + !! geometric distances across layers (in [Z ~> m]) rather + !! than layer thicknesses (in [H ~> m or kg m-2]). This + !! distinction only matters in non-Boussinesq mode. character(len=16) :: diag_coord_name = '' !< A name for the purpose of run-time parameters character(len=8) :: diag_module_suffix = '' !< The suffix for the module to appear in diag_table type(remapping_CS) :: remap_cs !< Remapping control structure use for this axes type(regridding_CS) :: regrid_cs !< Regridding control structure that defines the coordinates for this axes integer :: nz = 0 !< Number of vertical levels used for remapping - real, dimension(:,:,:), allocatable :: h !< Remap grid thicknesses [H ~> m or kg m-2] - real, dimension(:,:,:), allocatable :: h_extensive !< Remap grid thicknesses for extensive - !! variables [H ~> m or kg m-2] + real, dimension(:,:,:), allocatable :: h !< Remap grid thicknesses in [H ~> m or kg m-2] or + !! vertical extents in [Z ~> m], depending on the setting of Z_based_coord. + real, dimension(:,:,:), allocatable :: h_extensive !< Remap grid thicknesses in [H ~> m or kg m-2] or + !! vertical extents in [Z ~> m] for remapping extensive variables integer :: interface_axes_id = 0 !< Vertical axes id for remapping at interfaces integer :: layer_axes_id = 0 !< Vertical axes id for remapping on layers - logical :: answers_2018 !< If true, use the order of arithmetic and expressions for remapping - !! that recover the answers from the end of 2018. Otherwise, use - !! updated more robust forms of the same expressions. + logical :: om4_remap_via_sub_cells !< Use the OM4-era ramap_via_sub_cells + integer :: answer_date !< The vintage of the order of arithmetic and expressions + !! to use for remapping. Values below 20190101 recover + !! the answers from 2018, while higher values use more + !! robust forms of the same remapping expressions. + end type diag_remap_ctrl contains !> Initialize a diagnostic remapping type with the given vertical coordinate. -subroutine diag_remap_init(remap_cs, coord_tuple, answers_2018) - type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diag remapping control structure +subroutine diag_remap_init(remap_cs, coord_tuple, om4_remap_via_sub_cells, answer_date, GV) + type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diag remapping control structure character(len=*), intent(in) :: coord_tuple !< A string in form of !! MODULE_SUFFIX PARAMETER_SUFFIX COORDINATE_NAME - logical, intent(in) :: answers_2018 !< If true, use the order of arithmetic and expressions - !! for remapping that recover the answers from the end of 2018. - !! Otherwise, use more robust forms of the same expressions. + logical, intent(in) :: om4_remap_via_sub_cells !< Use the OM4-era ramap_via_sub_cells + integer, intent(in) :: answer_date !< The vintage of the order of arithmetic and expressions + !! to use for remapping. Values below 20190101 recover + !! the answers from 2018, while higher values use more + !! robust forms of the same remapping expressions. + type(verticalGrid_type), intent(in) :: GV !< The ocean vertical grid structure, used here to evaluate + !! whether the model is in non-Boussinesq mode. remap_cs%diag_module_suffix = trim(extractWord(coord_tuple, 1)) remap_cs%diag_coord_name = trim(extractWord(coord_tuple, 2)) remap_cs%vertical_coord_name = trim(extractWord(coord_tuple, 3)) remap_cs%vertical_coord = coordinateMode(remap_cs%vertical_coord_name) + remap_cs%Z_based_coord = .false. + if (.not.(GV%Boussinesq .or. GV%semi_Boussinesq) .and. & + ((remap_cs%vertical_coord == coordinateMode('ZSTAR')) .or. & + (remap_cs%vertical_coord == coordinateMode('SIGMA')) .or. & + (remap_cs%vertical_coord == coordinateMode('RHO'))) ) & + remap_cs%Z_based_coord = .true. + remap_cs%configured = .false. remap_cs%initialized = .false. remap_cs%used = .false. - remap_cs%answers_2018 = answers_2018 + remap_cs%om4_remap_via_sub_cells = om4_remap_via_sub_cells + remap_cs%answer_date = answer_date remap_cs%nz = 0 end subroutine diag_remap_init @@ -184,24 +178,24 @@ end subroutine diag_remap_set_active !> Configure the vertical axes for a diagnostic remapping control structure. !! Reads a configuration parameters to determine coordinate generation. -subroutine diag_remap_configure_axes(remap_cs, GV, US, param_file) +subroutine diag_remap_configure_axes(remap_cs, G, GV, US, param_file) type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diag remap control structure + type(ocean_grid_type), intent(in) :: G !< The ocean's grid type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file structure + ! Local variables - integer :: nzi(4), nzl(4), k - character(len=200) :: inputdir, string, filename, int_varname, layer_varname character(len=40) :: mod = "MOM_diag_remap" ! This module's name. - character(len=8) :: units, expected_units - character(len=34) :: longname, string2 - - character(len=256) :: err_msg - logical :: ierr - - real, allocatable, dimension(:) :: interfaces, layers - - call initialize_regridding(remap_cs%regrid_cs, GV, US, GV%max_depth, param_file, mod, & + character(len=8) :: units + character(len=34) :: longname + real, allocatable, dimension(:) :: & + interfaces, & ! Numerical values for interface vertical coordinates, in unscaled units + ! that might be [m], [kg m-3] or [nondim], depending on the coordinate. + layers ! Numerical values for layer vertical coordinates, in unscaled units + ! that might be [m], [kg m-3] or [nondim], depending on the coordinate. + + call initialize_regridding(remap_cs%regrid_cs, G, GV, US, GV%max_depth, param_file, mod, & trim(remap_cs%vertical_coord_name), "DIAG_COORD", trim(remap_cs%diag_coord_name)) call set_regrid_params(remap_cs%regrid_cs, min_thickness=0., integrate_downward_for_e=.false.) @@ -222,7 +216,7 @@ subroutine diag_remap_configure_axes(remap_cs, GV, US, param_file) allocate(interfaces(remap_cs%nz+1)) allocate(layers(remap_cs%nz)) - interfaces(:) = getCoordinateInterfaces(remap_cs%regrid_cs) + interfaces(:) = getCoordinateInterfaces(remap_cs%regrid_cs, undo_scaling=.true.) layers(:) = 0.5 * ( interfaces(1:remap_cs%nz) + interfaces(2:remap_cs%nz+1) ) remap_cs%interface_axes_id = MOM_diag_axis_init(lowercase(trim(remap_cs%diag_coord_name))//'_i', & @@ -277,182 +271,244 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, h_targe type(ocean_grid_type), pointer :: G !< The ocean's grid type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(:,:,:), intent(in) :: h !< New thickness [H ~> m or kg m-2] - real, dimension(:,:,:), intent(in) :: T !< New temperatures [degC] - real, dimension(:,:,:), intent(in) :: S !< New salinities [ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< New thickness in [H ~> m or kg m-2] or [Z ~> m], depending + !! on the value of remap_cs%Z_based_coord + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: T !< New temperatures [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: S !< New salinities [S ~> ppt] type(EOS_type), intent(in) :: eqn_of_state !< A pointer to the equation of state - real, dimension(:,:,:), intent(inout) :: h_target !< The new diagnostic thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),remap_cs%nz), & + intent(inout) :: h_target !< The new diagnostic thicknesses in [H ~> m or kg m-2] + !! or [Z ~> m], depending on the value of remap_cs%Z_based_coord ! Local variables - real, dimension(remap_cs%nz + 1) :: zInterfaces ! Interface positions [H ~> m or kg m-2] - real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] - integer :: i, j, k, nz - - ! Note that coordinateMode('LAYER') is never 'configured' so will - ! always return here. - if (.not. remap_cs%configured) then - return - endif - - if (.not.remap_cs%answers_2018) then - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - elseif (GV%Boussinesq) then - h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + real, dimension(remap_cs%nz + 1) :: zInterfaces ! Interface positions [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] + real :: bottom_depth(SZI_(G),SZJ_(G)) ! The depth of the bathymetry in [H ~> m or kg m-2] or [Z ~> m] + real :: h_tot(SZI_(G),SZJ_(G)) ! The total thickness of the water column [H ~> m or kg m-2] or [Z ~> m] + real :: Z_unit_scale ! A conversion factor from Z-units the internal work units in this routine, + ! in units of [H Z-1 ~> 1 or kg m-3] or [nondim], depending on remap_cs%Z_based_coord. + integer :: i, j, k, is, ie, js, je, nz + + ! Note that coordinateMode('LAYER') is never 'configured' so will always return here. + if (.not. remap_cs%configured) return + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + ! Set the bottom depth and negligible thicknesses used in the coordinate remapping in the right units. + if (remap_cs%Z_based_coord) then + h_neglect = set_dz_neglect(GV, US, remap_cs%answer_date, h_neglect_edge) + Z_unit_scale = 1.0 + do j=js-1,je+1 ; do i=is-1,ie+1 + bottom_depth(i,j) = G%bathyT(i,j) + G%Z_ref + enddo ; enddo else - h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + h_neglect = set_h_neglect(GV, remap_cs%answer_date, h_neglect_edge) + Z_unit_scale = GV%Z_to_H ! This branch is not used in fully non-Boussinesq mode. + do j=js-1,je+1 ; do i=is-1,ie+1 + bottom_depth(i,j) = GV%Z_to_H * (G%bathyT(i,j) + G%Z_ref) + enddo ; enddo endif - nz = remap_cs%nz if (.not. remap_cs%initialized) then ! Initialize remapping and regridding on the first call call initialize_remapping(remap_cs%remap_cs, 'PPM_IH4', boundary_extrapolation=.false., & - answers_2018=remap_cs%answers_2018) + om4_remap_via_sub_cells=remap_cs%om4_remap_via_sub_cells, & + answer_date=remap_cs%answer_date, & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) remap_cs%initialized = .true. endif + ! Calculate the total thickness of the water column, if it is needed, + if ((remap_cs%vertical_coord == coordinateMode('ZSTAR')) .or. & + (remap_cs%vertical_coord == coordinateMode('SIGMA'))) then + if (remap_CS%answer_date >= 20240201) then + ! Avoid using sum to have a specific order for the vertical sums. + ! For some compilers, the explicit expression gives the same answers as the sum function. + h_tot(:,:) = 0.0 + do k=1,GV%ke ; do j=js-1,je+1 ; do i=is-1,ie+1 + h_tot(i,j) = h_tot(i,j) + h(i,j,k) + enddo ; enddo ; enddo + else + do j=js-1,je+1 ; do i=is-1,ie+1 + h_tot(i,j) = sum(h(i,j,:)) + enddo ; enddo + endif + endif + ! Calculate remapping thicknesses for different target grids based on ! nominal/target interface locations. This happens for every call on the ! assumption that h, T, S has changed. - do j=G%jsc-1, G%jec+1 ; do i=G%isc-1, G%iec+1 - if (G%mask2dT(i,j)==0.) then - h_target(i,j,:) = 0. - cycle - endif + h_target(:,:,:) = 0.0 - if (remap_cs%vertical_coord == coordinateMode('ZSTAR')) then + nz = remap_cs%nz + if (remap_cs%vertical_coord == coordinateMode('ZSTAR')) then + do j=js-1,je+1 ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.0) then + ! This function call can work with the last 4 arguments all in units of [Z ~> m] or [H ~> kg m-2]. call build_zstar_column(get_zlike_CS(remap_cs%regrid_cs), & - GV%Z_to_H*(G%bathyT(i,j)+G%Z_ref), sum(h(i,j,:)), & - zInterfaces, zScale=GV%Z_to_H) - elseif (remap_cs%vertical_coord == coordinateMode('SIGMA')) then + bottom_depth(i,j), h_tot(i,j), zInterfaces, zScale=Z_unit_scale) + do k=1,nz ; h_target(i,j,k) = zInterfaces(K) - zInterfaces(K+1) ; enddo + endif ; enddo ; enddo + elseif (remap_cs%vertical_coord == coordinateMode('SIGMA')) then + do j=js-1, je+1 ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.0) then + ! This function call can work with the last 3 arguments all in units of [Z ~> m] or [H ~> kg m-2]. call build_sigma_column(get_sigma_CS(remap_cs%regrid_cs), & - GV%Z_to_H*(G%bathyT(i,j)+G%Z_ref), sum(h(i,j,:)), zInterfaces) - elseif (remap_cs%vertical_coord == coordinateMode('RHO')) then + bottom_depth(i,j), h_tot(i,j), zInterfaces) + do k=1,nz ; h_target(i,j,k) = zInterfaces(K) - zInterfaces(K+1) ; enddo + endif ; enddo ; enddo + elseif (remap_cs%vertical_coord == coordinateMode('RHO')) then + do j=js-1,je+1 ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.0) then + ! This function call can work with 5 arguments in units of [Z ~> m] or [H ~> kg m-2]. call build_rho_column(get_rho_CS(remap_cs%regrid_cs), GV%ke, & - GV%Z_to_H*(G%bathyT(i,j)+G%Z_ref), h(i,j,:), T(i,j,:), S(i,j,:), & - eqn_of_state, zInterfaces, h_neglect, h_neglect_edge) - elseif (remap_cs%vertical_coord == coordinateMode('SLIGHT')) then -! call build_slight_column(remap_cs%regrid_cs,remap_cs%remap_cs, nz, & -! GV%Z_to_H*(G%bathyT(i,j)+G%Z_ref), sum(h(i,j,:)), zInterfaces) - call MOM_error(FATAL,"diag_remap_update: SLIGHT coordinate not coded for diagnostics yet!") - elseif (remap_cs%vertical_coord == coordinateMode('HYCOM1')) then -! call build_hycom1_column(remap_cs%regrid_cs, nz, & -! GV%Z_to_H*(G%bathyT(i,j)+G%Z_ref), sum(h(i,j,:)), zInterfaces) - call MOM_error(FATAL,"diag_remap_update: HYCOM1 coordinate not coded for diagnostics yet!") - endif - do k = 1,nz - h_target(i,j,k) = zInterfaces(k) - zInterfaces(k+1) - enddo - enddo ; enddo + bottom_depth(i,j), h(i,j,:), T(i,j,:), S(i,j,:), & + eqn_of_state, zInterfaces, h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + do k=1,nz ; h_target(i,j,k) = zInterfaces(K) - zInterfaces(K+1) ; enddo + endif ; enddo ; enddo + elseif (remap_cs%vertical_coord == coordinateMode('HYCOM1')) then + call MOM_error(FATAL,"diag_remap_update: HYCOM1 coordinate not coded for diagnostics yet!") +! do j=js-1,je+1 ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.0) then +! call build_hycom1_column(remap_cs%regrid_cs, nz, & +! bottom_depth(i,j), h_tot(i,j), zInterfaces) +! do k=1,nz ; h_target(i,j,k) = zInterfaces(K) - zInterfaces(K+1) ; enddo +! endif ; enddo ; enddo + endif end subroutine diag_remap_update !> Remap diagnostic field to alternative vertical grid. -subroutine diag_remap_do_remap(remap_cs, G, GV, h, staggered_in_x, staggered_in_y, & +subroutine diag_remap_do_remap(remap_cs, G, GV, US, h, staggered_in_x, staggered_in_y, & mask, field, remapped_field) - type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coodinate control structure - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, dimension(:,:,:), intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] - logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points - logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points - real, dimension(:,:,:), pointer :: mask !< A mask for the field [nondim] - real, dimension(:,:,:), intent(in) :: field(:,:,:) !< The diagnostic field to be remapped [A] - real, dimension(:,:,:), intent(inout) :: remapped_field !< Field remapped to new coordinate [A] + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(:,:,:), intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] or [Z ~> m], + !! depending on the value of remap_CS%Z_based_coord + logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points + logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points + real, dimension(:,:,:), pointer :: mask !< A mask for the field [nondim]. + real, dimension(:,:,:), intent(in) :: field(:,:,:) !< The diagnostic field to be remapped [A] + real, dimension(:,:,:), intent(out) :: remapped_field !< Field remapped to new coordinate [A] + ! Local variables - real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] - real, dimension(size(h,3)) :: h_src ! A column of source thicknesses [H ~> m or kg m-2] - real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] - integer :: nz_src, nz_dest - integer :: i, j, k !< Grid index - integer :: i1, j1 !< 1-based index - integer :: i_lo, i_hi, j_lo, j_hi !< (uv->h) interpolation indices - integer :: shift !< Symmetric offset for 1-based indexing + integer :: isdf, jsdf !< The starting i- and j-indices in memory for field call assert(remap_cs%initialized, 'diag_remap_do_remap: remap_cs not initialized.') call assert(size(field, 3) == size(h, 3), & 'diag_remap_do_remap: Remap field and thickness z-axes do not match.') - if (.not.remap_cs%answers_2018) then - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - elseif (GV%Boussinesq) then - h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + isdf = G%isd ; if (staggered_in_x) Isdf = G%IsdB + jsdf = G%jsd ; if (staggered_in_y) Jsdf = G%JsdB + + if (associated(mask)) then + call do_remap(remap_cs, G, GV, US, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + field, remapped_field, mask(:,:,1)) else - h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + call do_remap(remap_cs, G, GV, US, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + field, remapped_field) endif +end subroutine diag_remap_do_remap + +!> The internal routine to remap a diagnostic field to an alternative vertical grid. +subroutine do_remap(remap_cs, G, GV, US, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + field, remapped_field, mask) + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: isdf !< The starting i-index in memory for field + integer, intent(in) :: jsdf !< The starting j-index in memory for field + real, dimension(G%isd:,G%jsd:,:), & + intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] or [Z ~> m], + !! depending on the value of remap_CS%Z_based_coord + logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points + logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points + real, dimension(isdf:,jsdf:,:), & + intent(in) :: field !< The diagnostic field to be remapped [A] + real, dimension(isdf:,jsdf:,:), & + intent(out) :: remapped_field !< Field remapped to new coordinate [A] + real, dimension(isdf:,jsdf:), & + optional, intent(in) :: mask !< A mask for the field [nondim] + + ! 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] + integer :: nz_src, nz_dest ! The number of layers on the native and remapped grids + integer :: i, j ! Grid index + nz_src = size(field,3) nz_dest = remap_cs%nz remapped_field(:,:,:) = 0. - ! Symmetric grid offset under 1-based indexing; see header for details. - shift = 0 ; if (G%symmetric) shift = 1 - if (staggered_in_x .and. .not. staggered_in_y) then ! U-points - do j=G%jsc, G%jec - do I=G%iscB, G%iecB - I1 = I - G%isdB + 1 - i_lo = I1 - shift; i_hi = i_lo + 1 - if (associated(mask)) then - if (mask(I,j,1) == 0.) cycle - endif - h_src(:) = 0.5 * (h(i_lo,j,:) + h(i_hi,j,:)) - h_dest(:) = 0.5 * (remap_cs%h(i_lo,j,:) + remap_cs%h(i_hi,j,:)) - call remapping_core_h(remap_cs%remap_cs, & - nz_src, h_src(:), field(I1,j,:), & - nz_dest, h_dest(:), remapped_field(I1,j,:), & - h_neglect, h_neglect_edge) - enddo - enddo + if (present(mask)) then + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (mask(I,j) > 0.) then + 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,:)) + 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,:)) + enddo ; enddo + endif elseif (staggered_in_y .and. .not. staggered_in_x) then ! V-points - do J=G%jscB, G%jecB - J1 = J - G%jsdB + 1 - j_lo = J1 - shift; j_hi = j_lo + 1 - do i=G%isc, G%iec - if (associated(mask)) then - if (mask(i,J,1) == 0.) cycle - endif - h_src(:) = 0.5 * (h(i,j_lo,:) + h(i,j_hi,:)) - h_dest(:) = 0.5 * (remap_cs%h(i,j_lo,:) + remap_cs%h(i,j_hi,:)) - call remapping_core_h(remap_cs%remap_cs, & - nz_src, h_src(:), field(i,J1,:), & - nz_dest, h_dest(:), remapped_field(i,J1,:), & - h_neglect, h_neglect_edge) - enddo - enddo + if (present(mask)) then + do J=G%jscB,G%jecB ; do i=G%isc,G%iec ; if (mask(i,j) > 0.) then + 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,:)) + 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,:)) + enddo ; enddo + endif elseif ((.not. staggered_in_x) .and. (.not. staggered_in_y)) then ! H-points - do j=G%jsc, G%jec - do i=G%isc, G%iec - if (associated(mask)) then - if (mask(i,j,1) == 0.) cycle - endif - h_src(:) = h(i,j,:) - h_dest(:) = remap_cs%h(i,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) - enddo - enddo + 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,:)) + 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,:)) + enddo ; enddo + endif else call assert(.false., 'diag_remap_do_remap: Unsupported axis combination') endif -end subroutine diag_remap_do_remap +end subroutine do_remap !> Calculate masks for target grid subroutine diag_remap_calc_hmask(remap_cs, G, mask) - type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coodinate control structure + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - real, dimension(:,:,:), intent(out) :: mask !< h-point mask for target grid [nondim] + real, dimension(G%isd:,G%jsd:,:), & + intent(out) :: mask !< h-point mask for target grid [nondim] + ! Local variables - real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] + real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] or [Z ~> m] integer :: i, j, k logical :: mask_vanished_layers - real :: h_tot ! Sum of all thicknesses [H ~> m or kg m-2] - real :: h_err ! An estimate of a negligible thickness [H ~> m or kg m-2] + real :: h_tot ! Sum of all thicknesses [H ~> m or kg m-2] or [Z ~> m] + real :: h_err ! An estimate of a negligible thickness [H ~> m or kg m-2] or [Z ~> m] call assert(remap_cs%initialized, 'diag_remap_calc_hmask: remap_cs not initialized.') @@ -460,7 +516,7 @@ subroutine diag_remap_calc_hmask(remap_cs, G, mask) mask_vanished_layers = (remap_cs%vertical_coord == coordinateMode('ZSTAR')) mask(:,:,:) = 0. - do j=G%jsc-1, G%jec+1 ; do i=G%isc-1, G%iec+1 + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 if (G%mask2dT(i,j)>0.) then if (mask_vanished_layers) then h_dest(:) = remap_cs%h(i,j,:) @@ -489,166 +545,239 @@ end subroutine diag_remap_calc_hmask !> Vertically re-grid an already vertically-integrated diagnostic field to alternative vertical grid. subroutine vertically_reintegrate_diag_field(remap_cs, G, h, h_target, staggered_in_x, staggered_in_y, & mask, field, reintegrated_field) - type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coodinate control structure - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - real, dimension(:,:,:), intent(in) :: h !< The thicknesses of the source grid [H ~> m or kg m-2] - real, dimension(:,:,:), intent(in) :: h_target !< The thicknesses of the target grid [H ~> m or kg m-2] - logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points - logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points - real, dimension(:,:,:), pointer :: mask !< A mask for the field [nondim] - real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped [A] - real, dimension(:,:,:), intent(inout) :: reintegrated_field !< Field argument remapped to alternative coordinate [A] + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + real, dimension(:,:,:), intent(in) :: h !< The thicknesses of the source grid [H ~> m or kg m-2] or [Z ~> m] + real, dimension(:,:,:), intent(in) :: h_target !< The thicknesses of the target grid [H ~> m or kg m-2] or [Z ~> m] + logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points + logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points + real, dimension(:,:,:), pointer :: mask !< A mask for the field [nondim]. Note that because this + !! is a pointer it retains its declared indexing conventions. + real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped [A] + real, dimension(:,:,:), intent(out) :: reintegrated_field !< Field argument remapped to alternative coordinate [A] + ! Local variables - real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] - real, dimension(size(h,3)) :: h_src ! A column of source thicknesses [H ~> m or kg m-2] - integer :: nz_src, nz_dest - integer :: i, j, k !< Grid index - integer :: i1, j1 !< 1-based index - integer :: i_lo, i_hi, j_lo, j_hi !< (uv->h) interpolation indices - integer :: shift !< Symmetric offset for 1-based indexing + integer :: isdf, jsdf !< The starting i- and j-indices in memory for field call assert(remap_cs%initialized, 'vertically_reintegrate_diag_field: remap_cs not initialized.') call assert(size(field, 3) == size(h, 3), & 'vertically_reintegrate_diag_field: Remap field and thickness z-axes do not match.') + isdf = G%isd ; if (staggered_in_x) Isdf = G%IsdB + jsdf = G%jsd ; if (staggered_in_y) Jsdf = G%JsdB + + if (associated(mask)) then + call vertically_reintegrate_field(remap_cs, G, isdf, jsdf, h, h_target, staggered_in_x, staggered_in_y, & + field, reintegrated_field, mask(:,:,1)) + else + call vertically_reintegrate_field(remap_cs, G, isdf, jsdf, h, h_target, staggered_in_x, staggered_in_y, & + field, reintegrated_field) + endif + +end subroutine vertically_reintegrate_diag_field + +!> The internal routine to vertically re-grid an already vertically-integrated diagnostic field to +!! an alternative vertical grid. +subroutine vertically_reintegrate_field(remap_cs, G, isdf, jsdf, h, h_target, staggered_in_x, staggered_in_y, & + field, reintegrated_field, mask) + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + integer, intent(in) :: isdf !< The starting i-index in memory for field + integer, intent(in) :: jsdf !< The starting j-index in memory for field + real, dimension(G%isd:,G%jsd:,:), & + intent(in) :: h !< The thicknesses of the source grid [H ~> m or kg m-2] or [Z ~> m] + real, dimension(G%isd:,G%jsd:,:), & + intent(in) :: h_target !< The thicknesses of the target grid [H ~> m or kg m-2] or [Z ~> m] + logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points + logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points + real, dimension(isdf:,jsdf:,:), & + intent(in) :: field !< The diagnostic field to be remapped [A] + real, dimension(isdf:,jsdf:,:), & + intent(out) :: reintegrated_field !< Field argument remapped to alternative coordinate [A] + real, dimension(isdf:,jsdf:), & + optional, intent(in) :: mask !< A mask for the field [nondim] + + ! 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] + integer :: nz_src, nz_dest ! The number of layers on the native and remapped grids + integer :: i, j ! Grid index + nz_src = size(field,3) nz_dest = remap_cs%nz reintegrated_field(:,:,:) = 0. - ! Symmetric grid offset under 1-based indexing; see header for details. - shift = 0 ; if (G%symmetric) shift = 1 - if (staggered_in_x .and. .not. staggered_in_y) then ! U-points - do j=G%jsc, G%jec - do I=G%iscB, G%iecB - I1 = I - G%isdB + 1 - i_lo = I1 - shift; i_hi = i_lo + 1 - if (associated(mask)) then - if (mask(I,j,1) == 0.) cycle - endif - h_src(:) = 0.5 * (h(i_lo,j,:) + h(i_hi,j,:)) - h_dest(:) = 0.5 * (h_target(i_lo,j,:) + h_target(i_hi,j,:)) - call reintegrate_column(nz_src, h_src, field(I1,j,:), & - nz_dest, h_dest, 0., reintegrated_field(I1,j,:)) - enddo - enddo + if (present(mask)) then + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (mask(I,j) > 0.0) then + h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) + h_dest(:) = 0.5 * (h_target(i,j,:) + h_target(i+1,j,:)) + call reintegrate_column(nz_src, h_src, field(I,j,:), & + nz_dest, h_dest, reintegrated_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 * (h_target(i,j,:) + h_target(i+1,j,:)) + call reintegrate_column(nz_src, h_src, field(I,j,:), & + nz_dest, h_dest, reintegrated_field(I,j,:)) + enddo ; enddo + endif elseif (staggered_in_y .and. .not. staggered_in_x) then ! V-points - do J=G%jscB, G%jecB - J1 = J - G%jsdB + 1 - j_lo = J1 - shift; j_hi = j_lo + 1 - do i=G%isc, G%iec - if (associated(mask)) then - if (mask(i,J,1) == 0.) cycle - endif - h_src(:) = 0.5 * (h(i,j_lo,:) + h(i,j_hi,:)) - h_dest(:) = 0.5 * (h_target(i,j_lo,:) + h_target(i,j_hi,:)) - call reintegrate_column(nz_src, h_src, field(i,J1,:), & - nz_dest, h_dest, 0., reintegrated_field(i,J1,:)) - enddo - enddo + if (present(mask)) then + do J=G%jscB,G%jecB ; do i=G%isc,G%iec ; if (mask(i,J) > 0.0) then + h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) + h_dest(:) = 0.5 * (h_target(i,j,:) + h_target(i,j+1,:)) + call reintegrate_column(nz_src, h_src, field(i,J,:), & + nz_dest, h_dest, reintegrated_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 * (h_target(i,j,:) + h_target(i,j+1,:)) + call reintegrate_column(nz_src, h_src, field(i,J,:), & + nz_dest, h_dest, reintegrated_field(i,J,:)) + enddo ; enddo + endif elseif ((.not. staggered_in_x) .and. (.not. staggered_in_y)) then ! H-points - do j=G%jsc, G%jec - do i=G%isc, G%iec - if (associated(mask)) then - if (mask(i,j,1) == 0.) cycle - endif - h_src(:) = h(i,j,:) - h_dest(:) = h_target(i,j,:) - call reintegrate_column(nz_src, h_src, field(i,j,:), & - nz_dest, h_dest, 0., reintegrated_field(i,j,:)) - enddo - enddo + if (present(mask)) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (mask(i,J) > 0.0) then + call reintegrate_column(nz_src, h(i,j,:), field(i,j,:), & + nz_dest, h_target(i,j,:), reintegrated_field(i,j,:)) + endif ; enddo ; enddo + else + do j=G%jsc,G%jec ; do i=G%isc,G%iec + call reintegrate_column(nz_src, h(i,j,:), field(i,j,:), & + nz_dest, h_target(i,j,:), reintegrated_field(i,j,:)) + enddo ; enddo + endif else call assert(.false., 'vertically_reintegrate_diag_field: Q point remapping is not coded yet.') endif -end subroutine vertically_reintegrate_diag_field +end subroutine vertically_reintegrate_field !> Vertically interpolate diagnostic field to alternative vertical grid. subroutine vertically_interpolate_diag_field(remap_cs, G, h, staggered_in_x, staggered_in_y, & mask, field, interpolated_field) - type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coodinate control structure + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - real, dimension(:,:,:), intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] + real, dimension(:,:,:), intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] or [Z ~> m], + !! depending on the value of remap_cs%Z_based_coord logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points - real, dimension(:,:,:), pointer :: mask !< A mask for the field [nondim] + real, dimension(:,:,:), pointer :: mask !< A mask for the field [nondim]. Note that because this + !! is a pointer it retains its declared indexing conventions. real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped [A] real, dimension(:,:,:), intent(inout) :: interpolated_field !< Field argument remapped to alternative coordinate [A] + ! Local variables - real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] - real, dimension(size(h,3)) :: h_src ! A column of source thicknesses [H ~> m or kg m-2] - integer :: nz_src, nz_dest - integer :: i, j, k !< Grid index - integer :: i1, j1 !< 1-based index - integer :: i_lo, i_hi, j_lo, j_hi !< (uv->h) interpolation indices - integer :: shift !< Symmetric offset for 1-based indexing + integer :: isdf, jsdf !< The starting i- and j-indices in memory for field call assert(remap_cs%initialized, 'vertically_interpolate_diag_field: remap_cs not initialized.') call assert(size(field, 3) == size(h, 3)+1, & 'vertically_interpolate_diag_field: Remap field and thickness z-axes do not match.') + isdf = G%isd ; if (staggered_in_x) Isdf = G%IsdB + jsdf = G%jsd ; if (staggered_in_y) Jsdf = G%JsdB + + if (associated(mask)) then + call vertically_interpolate_field(remap_cs, G, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + field, interpolated_field, mask(:,:,1)) + else + call vertically_interpolate_field(remap_cs, G, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + field, interpolated_field) + endif + +end subroutine vertically_interpolate_diag_field + +!> Internal routine to vertically interpolate a diagnostic field to an alternative vertical grid. +subroutine vertically_interpolate_field(remap_cs, G, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + field, interpolated_field, mask) + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + integer, intent(in) :: isdf !< The starting i-index in memory for field + integer, intent(in) :: jsdf !< The starting j-index in memory for field + real, dimension(G%isd:,G%jsd:,:), & + intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] or [Z ~> m], + !! depending on the value of remap_cs%Z_based_coord + logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points + logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points + real, dimension(isdf:,jsdf:,:), & + intent(in) :: field !< The diagnostic field to be remapped [A] + real, dimension(isdf:,jsdf:,:), & + intent(out) :: interpolated_field !< Field argument remapped to alternative coordinate [A] + real, dimension(isdf:,jsdf:), & + optional, intent(in) :: mask !< A mask for the field [nondim] + + ! 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] + integer :: nz_src, nz_dest ! The number of layers on the native and remapped grids + integer :: i, j !< Grid index + interpolated_field(:,:,:) = 0. nz_src = size(h,3) nz_dest = remap_cs%nz - ! Symmetric grid offset under 1-based indexing; see header for details. - shift = 0 ; if (G%symmetric) shift = 1 - if (staggered_in_x .and. .not. staggered_in_y) then ! U-points - do j=G%jsc, G%jec - do I=G%iscB, G%iecB - I1 = I - G%isdB + 1 - i_lo = I1 - shift; i_hi = i_lo + 1 - if (associated(mask)) then - if (mask(I,j,1) == 0.) cycle - endif - h_src(:) = 0.5 * (h(i_lo,j,:) + h(i_hi,j,:)) - h_dest(:) = 0.5 * (remap_cs%h(i_lo,j,:) + remap_cs%h(i_hi,j,:)) - call interpolate_column(nz_src, h_src, field(I1,j,:), & - nz_dest, h_dest, 0., interpolated_field(I1,j,:)) - enddo - enddo + if (present(mask)) then + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (mask(I,j) > 0.0) then + 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 interpolate_column(nz_src, h_src, field(I,j,:), & + nz_dest, h_dest, interpolated_field(I,j,:), .true.) + 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 interpolate_column(nz_src, h_src, field(I,j,:), & + nz_dest, h_dest, interpolated_field(I,j,:), .true.) + enddo ; enddo + endif elseif (staggered_in_y .and. .not. staggered_in_x) then ! V-points - do J=G%jscB, G%jecB - J1 = J - G%jsdB + 1 - j_lo = J1 - shift; j_hi = j_lo + 1 - do i=G%isc, G%iec - if (associated(mask)) then - if (mask(i,J,1) == 0.) cycle - endif - h_src(:) = 0.5 * (h(i,j_lo,:) + h(i,j_hi,:)) - h_dest(:) = 0.5 * (remap_cs%h(i,j_lo,:) + remap_cs%h(i,j_hi,:)) - call interpolate_column(nz_src, h_src, field(i,J1,:), & - nz_dest, h_dest, 0., interpolated_field(i,J1,:)) - enddo - enddo + if (present(mask)) then + do J=G%jscB,G%jecB ; do i=G%isc,G%iec ; if (mask(I,j) > 0.0) then + 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 interpolate_column(nz_src, h_src, field(i,J,:), & + nz_dest, h_dest, interpolated_field(i,J,:), .true.) + 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 interpolate_column(nz_src, h_src, field(i,J,:), & + nz_dest, h_dest, interpolated_field(i,J,:), .true.) + enddo ; enddo + endif elseif ((.not. staggered_in_x) .and. (.not. staggered_in_y)) then ! H-points - do j=G%jsc, G%jec - do i=G%isc, G%iec - if (associated(mask)) then - if (mask(i,j,1) == 0.) cycle - endif - h_src(:) = h(i,j,:) - h_dest(:) = remap_cs%h(i,j,:) - call interpolate_column(nz_src, h_src, field(i,j,:), & - nz_dest, h_dest, 0., interpolated_field(i,j,:)) - enddo - enddo + if (present(mask)) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (mask(i,j) > 0.0) then + call interpolate_column(nz_src, h(i,j,:), field(i,j,:), & + nz_dest, remap_cs%h(i,j,:), interpolated_field(i,j,:), .true.) + endif ; enddo ; enddo + else + do j=G%jsc,G%jec ; do i=G%isc,G%iec + call interpolate_column(nz_src, h(i,j,:), field(i,j,:), & + nz_dest, remap_cs%h(i,j,:), interpolated_field(i,j,:), .true.) + enddo ; enddo + endif else call assert(.false., 'vertically_interpolate_diag_field: Q point remapping is not coded yet.') endif -end subroutine vertically_interpolate_diag_field +end subroutine vertically_interpolate_field -!> Horizontally average field +!> Horizontally average a diagnostic field subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_in_y, & is_layer, is_extensive, & field, averaged_field, & @@ -661,16 +790,53 @@ subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_i logical, intent(in) :: is_layer !< True if the z-axis location is at h points logical, intent(in) :: is_extensive !< True if the z-direction is spatially integrated (over layers) real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped [A] - real, dimension(:), intent(inout) :: averaged_field !< Field argument horizontally averaged [A] - logical, dimension(:), intent(inout) :: averaged_mask !< Mask for horizontally averaged field [nondim] + real, dimension(:), intent(out) :: averaged_field !< Field argument horizontally averaged [A] + logical, dimension(:), intent(out) :: averaged_mask !< Mask for horizontally averaged field [nondim] + + ! Local variables + integer :: isdf, jsdf !< The starting i- and j-indices in memory for field + + isdf = G%isd ; if (staggered_in_x) Isdf = G%IsdB + jsdf = G%jsd ; if (staggered_in_y) Jsdf = G%JsdB + + call horizontally_average_field(G, GV, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + is_layer, is_extensive, field, averaged_field, averaged_mask) + +end subroutine horizontally_average_diag_field + +!> Horizontally average a diagnostic field +subroutine horizontally_average_field(G, GV, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + is_layer, is_extensive, field, averaged_field, averaged_mask) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean vertical grid structure + integer, intent(in) :: isdf !< The starting i-index in memory for field + integer, intent(in) :: jsdf !< The starting j-index in memory for field + real, dimension(G%isd:,G%jsd:,:), & + intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] + logical, intent(in) :: staggered_in_x !< True if the x-axis location is at u or q points + logical, intent(in) :: staggered_in_y !< True if the y-axis location is at v or q points + logical, intent(in) :: is_layer !< True if the z-axis location is at h points + logical, intent(in) :: is_extensive !< True if the z-direction is spatially integrated (over layers) + real, dimension(isdf:,jsdf:,:), & + intent(in) :: field !< The diagnostic field to be remapped [A] + real, dimension(:), intent(out) :: averaged_field !< Field argument horizontally averaged [A] + logical, dimension(:), intent(out) :: averaged_mask !< Mask for horizontally averaged field [nondim] ! Local variables - real, dimension(G%isc:G%iec, G%jsc:G%jec, size(field,3)) :: volume, stuff - real, dimension(size(field, 3)) :: vol_sum, stuff_sum ! nz+1 is needed for interface averages + real :: volume(G%isc:G%iec, G%jsc:G%jec, size(field,3)) ! The area [L2 ~> m2], volume [L2 m ~> m3] + ! or mass [L2 kg m-2 ~> kg] of each cell. + real :: stuff(G%isc:G%iec, G%jsc:G%jec, size(field,3)) ! The area, volume or mass-weighted integral of the + ! field being averaged in each cell, in [L2 a ~> m2 A], + ! [L2 m a ~> m3 A] or [L2 kg m-2 A ~> kg A], + ! depending on the weighting for the averages and whether the + ! model makes the Boussinesq approximation. + real, dimension(size(field, 3)) :: vol_sum ! The global sum of the areas [m2], volumes [m3] or mass [kg] + ! in the cells that used in the weighted averages. + real, dimension(size(field, 3)) :: stuff_sum ! The global sum of the weighted field in all cells, in + ! [A m2], [A m3] or [A kg] type(EFP_type), dimension(2*size(field,3)) :: sums_EFP ! Sums of volume or stuff by layer real :: height ! An average thickness attributed to an velocity point [H ~> m or kg m-2] integer :: i, j, k, nz - integer :: i1, j1 !< 1-based index nz = size(field, 3) @@ -686,26 +852,22 @@ subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_i stuff_sum(k) = 0. if (is_extensive) then do j=G%jsc, G%jec ; do I=G%isc, G%iec - I1 = I - G%isdB + 1 - volume(I,j,k) = (G%US%L_to_m**2 * G%areaCu(I,j)) * G%mask2dCu(I,j) - stuff(I,j,k) = volume(I,j,k) * field(I1,j,k) + volume(I,j,k) = G%areaCu(I,j) * G%mask2dCu(I,j) + stuff(I,j,k) = volume(I,j,k) * field(I,j,k) enddo ; enddo else ! Intensive do j=G%jsc, G%jec ; do I=G%isc, G%iec - I1 = i - G%isdB + 1 height = 0.5 * (h(i,j,k) + h(i+1,j,k)) - volume(I,j,k) = (G%US%L_to_m**2 * G%areaCu(I,j)) & - * (GV%H_to_m * height) * G%mask2dCu(I,j) - stuff(I,j,k) = volume(I,j,k) * field(I1,j,k) + volume(I,j,k) = G%areaCu(I,j) * (GV%H_to_MKS * height) * G%mask2dCu(I,j) + stuff(I,j,k) = volume(I,j,k) * field(I,j,k) enddo ; enddo endif enddo else ! Interface do k=1,nz do j=G%jsc, G%jec ; do I=G%isc, G%iec - I1 = I - G%isdB + 1 - volume(I,j,k) = (G%US%L_to_m**2 * G%areaCu(I,j)) * G%mask2dCu(I,j) - stuff(I,j,k) = volume(I,j,k) * field(I1,j,k) + volume(I,j,k) = G%areaCu(I,j) * G%mask2dCu(I,j) + stuff(I,j,k) = volume(I,j,k) * field(I,j,k) enddo ; enddo enddo endif @@ -715,26 +877,22 @@ subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_i do k=1,nz if (is_extensive) then do J=G%jsc, G%jec ; do i=G%isc, G%iec - J1 = J - G%jsdB + 1 - volume(i,J,k) = (G%US%L_to_m**2 * G%areaCv(i,J)) * G%mask2dCv(i,J) - stuff(i,J,k) = volume(i,J,k) * field(i,J1,k) + volume(i,J,k) = G%areaCv(i,J) * G%mask2dCv(i,J) + stuff(i,J,k) = volume(i,J,k) * field(i,J,k) enddo ; enddo else ! Intensive do J=G%jsc, G%jec ; do i=G%isc, G%iec - J1 = J - G%jsdB + 1 height = 0.5 * (h(i,j,k) + h(i,j+1,k)) - volume(i,J,k) = (G%US%L_to_m**2 * G%areaCv(i,J)) & - * (GV%H_to_m * height) * G%mask2dCv(i,J) - stuff(i,J,k) = volume(i,J,k) * field(i,J1,k) + volume(i,J,k) = G%areaCv(i,J) * (GV%H_to_MKS * height) * G%mask2dCv(i,J) + stuff(i,J,k) = volume(i,J,k) * field(i,J,k) enddo ; enddo endif enddo else ! Interface do k=1,nz do J=G%jsc, G%jec ; do i=G%isc, G%iec - J1 = J - G%jsdB + 1 - volume(i,J,k) = (G%US%L_to_m**2 * G%areaCv(i,J)) * G%mask2dCv(i,J) - stuff(i,J,k) = volume(i,J,k) * field(i,J1,k) + volume(i,J,k) = G%areaCv(i,J) * G%mask2dCv(i,J) + stuff(i,J,k) = volume(i,J,k) * field(i,J,k) enddo ; enddo enddo endif @@ -745,7 +903,7 @@ subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_i if (is_extensive) then do j=G%jsc, G%jec ; do i=G%isc, G%iec if (h(i,j,k) > 0.) then - volume(i,j,k) = (G%US%L_to_m**2 * G%areaT(i,j)) * G%mask2dT(i,j) + volume(i,j,k) = G%areaT(i,j) * G%mask2dT(i,j) stuff(i,j,k) = volume(i,j,k) * field(i,j,k) else volume(i,j,k) = 0. @@ -754,8 +912,7 @@ subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_i enddo ; enddo else ! Intensive do j=G%jsc, G%jec ; do i=G%isc, G%iec - volume(i,j,k) = (G%US%L_to_m**2 * G%areaT(i,j)) & - * (GV%H_to_m * h(i,j,k)) * G%mask2dT(i,j) + volume(i,j,k) = G%areaT(i,j) * (GV%H_to_MKS * h(i,j,k)) * G%mask2dT(i,j) stuff(i,j,k) = volume(i,j,k) * field(i,j,k) enddo ; enddo endif @@ -763,7 +920,7 @@ subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_i else ! Interface do k=1,nz do j=G%jsc, G%jec ; do i=G%isc, G%iec - volume(i,j,k) = (G%US%L_to_m**2 * G%areaT(i,j)) * G%mask2dT(i,j) + volume(i,j,k) = G%areaT(i,j) * G%mask2dT(i,j) stuff(i,j,k) = volume(i,j,k) * field(i,j,k) enddo ; enddo enddo @@ -775,8 +932,8 @@ subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_i ! Packing the sums into a single array with a single call to sum across PEs saves reduces ! the costs of communication. do k=1,nz - sums_EFP(2*k-1) = reproducing_sum_EFP(volume(:,:,k), only_on_PE=.true.) - sums_EFP(2*k) = reproducing_sum_EFP(stuff(:,:,k), only_on_PE=.true.) + sums_EFP(2*k-1) = reproducing_sum_EFP(volume(:,:,k), only_on_PE=.true., unscale=G%US%L_to_m**2) + sums_EFP(2*k) = reproducing_sum_EFP(stuff(:,:,k), only_on_PE=.true., unscale=G%US%L_to_m**2) enddo call EFP_sum_across_PEs(sums_EFP, 2*nz) do k=1,nz @@ -794,6 +951,6 @@ subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_i endif enddo -end subroutine horizontally_average_diag_field +end subroutine horizontally_average_field end module MOM_diag_remap diff --git a/src/framework/MOM_diag_vkernels.F90 b/src/framework/MOM_diag_vkernels.F90 deleted file mode 100644 index 3d6e3e3f65..0000000000 --- a/src/framework/MOM_diag_vkernels.F90 +++ /dev/null @@ -1,360 +0,0 @@ -!> Provides kernels for single-column interpolation, re-integration (re-mapping of integrated quantities) -!! and intensive-variable remapping in the vertical -module MOM_diag_vkernels - -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_io, only : stdout, stderr - -implicit none ; private - -public diag_vkernels_unit_tests -public interpolate_column -public reintegrate_column - -contains - -!> Linearly interpolate interface data, u_src, from grid h_src to a grid h_dest -subroutine interpolate_column(nsrc, h_src, u_src, ndest, h_dest, missing_value, u_dest) - integer, intent(in) :: nsrc !< Number of source cells - real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells - real, dimension(nsrc+1), intent(in) :: u_src !< Values at source cell interfaces - integer, intent(in) :: ndest !< Number of destination cells - real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells - real, intent(in) :: missing_value !< Value to assign in vanished cells - real, dimension(ndest+1), intent(inout) :: u_dest !< Interpolated value at destination cell interfaces - ! Local variables - real :: x_dest ! Relative position of target interface - real :: dh ! Source cell thickness - real :: u1, u2 ! Values to interpolate between - real :: weight_a, weight_b ! Weights for interpolation - integer :: k_src, k_dest ! Index of cell in src and dest columns - logical :: still_vanished ! Used for figuring out what to mask as missing - - ! Initial values for the loop - still_vanished = .true. - - ! The following forces the "do while" loop to do one cycle that will set u1, u2, dh. - k_src = 0 - dh = 0. - x_dest = 0. - - do k_dest=1, ndest+1 - do while (dh<=x_dest .and. k_src0.) then - weight_a = max(0., ( dh - x_dest ) / dh) ! Weight of u1 - weight_b = min(1., x_dest / dh) ! Weight of u2 - u_dest(k_dest) = weight_a * u1 + weight_b * u2 ! Linear interpolation between u1 and u2 - else - u_dest(k_dest) = 0.5 * ( u1 + u2 ) ! For a vanished layer we need to do something reasonable... - endif - - ! Mask vanished layers at the surface which would be under an ice-shelf. - ! TODO: Need to figure out what to do for an isopycnal coordinate diagnostic that could - ! also have vanished layers at the surface. - if (k_dest<=ndest) then - x_dest = x_dest + h_dest(k_dest) ! Position of interface k_dest+1 - if (still_vanished .and. h_dest(k_dest)==0.) then - ! When the layer k_dest is vanished and all layers above are also vanished, the k_dest - ! interface value should be missing. - u_dest(k_dest) = missing_value - else - still_vanished = .false. - endif - endif - - enddo - - ! Mask vanished layers on topography - still_vanished = .true. - do k_dest=ndest, 1, -1 - if (still_vanished .and. h_dest(k_dest)==0.) then - ! When the layer k_dest is vanished and all layers below are also vanished, the k_dest+1 - ! interface value should be missing. - u_dest(k_dest+1) = missing_value - else - exit - endif - enddo - -end subroutine interpolate_column - -!> Conservatively calculate integrated data, uh_dest, on grid h_dest, from layer-integrated data, uh_src, on grid h_src -subroutine reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, missing_value, uh_dest) - integer, intent(in) :: nsrc !< Number of source cells - real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells - real, dimension(nsrc), intent(in) :: uh_src !< Values at source cell interfaces - integer, intent(in) :: ndest !< Number of destination cells - real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells - real, intent(in) :: missing_value !< Value to assign in vanished cells - real, dimension(ndest), intent(inout) :: uh_dest !< Interpolated value at destination cell interfaces - ! Local variables - real :: x_dest ! Relative position of target interface - real :: h_src_rem, h_dest_rem, dh ! Incremental thicknesses - real :: uh_src_rem, uh_dest_rem, duh ! Incremental amounts of stuff - integer :: k_src, k_dest ! Index of cell in src and dest columns - integer :: iter - logical :: src_ran_out, src_exists - - uh_dest(:) = missing_value - - k_src = 0 - k_dest = 0 - h_dest_rem = 0. - h_src_rem = 0. - src_ran_out = .false. - src_exists = .false. - - do while(.true.) - if (h_src_rem==0. .and. k_src0.) duh = uh_src_rem - h_src_rem = 0. - uh_src_rem = 0. - h_dest_rem = max(0., h_dest_rem - dh) - elseif (h_src_rem>h_dest_rem) then - ! Only part of the source cell can be used up - dh = h_dest_rem - duh = (dh / h_src_rem) * uh_src_rem - h_src_rem = max(0., h_src_rem - dh) - uh_src_rem = uh_src_rem - duh - h_dest_rem = 0. - else ! h_src_rem==h_dest_rem - ! The source cell exactly fits the destination cell - duh = uh_src_rem - h_src_rem = 0. - uh_src_rem = 0. - h_dest_rem = 0. - endif - uh_dest(k_dest) = uh_dest(k_dest) + duh - if (k_dest==ndest .and. (k_src==nsrc .or. h_dest_rem==0.)) exit - enddo - - if (.not. src_exists) uh_dest(1:ndest) = missing_value - -end subroutine reintegrate_column - -!> Returns true if any unit tests for module MOM_diag_vkernels fail -logical function diag_vkernels_unit_tests(verbose) - logical, intent(in) :: verbose !< If true, write results to stdout - ! Local variables - real, parameter :: mv=-9.999999999E9 ! Value to use for vanished layers - logical :: fail, v - - v = verbose - - write(stdout,*) '==== MOM_diag_kernels: diag_vkernels_unit_tests ==========' - if (v) write(stdout,*) '- - - - - - - - - - interpolation tests - - - - - - - - -' - - fail = test_interp(v,mv,'Identity: 3 layer', & - 3, (/1.,2.,3./), (/1.,2.,3.,4./), & - 3, (/1.,2.,3./), (/1.,2.,3.,4./) ) - diag_vkernels_unit_tests = fail - - fail = test_interp(v,mv,'A: 3 layer to 2', & - 3, (/1.,1.,1./), (/1.,2.,3.,4./), & - 2, (/1.5,1.5/), (/1.,2.5,4./) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_interp(v,mv,'B: 2 layer to 3', & - 2, (/1.5,1.5/), (/1.,4.,7./), & - 3, (/1.,1.,1./), (/1.,3.,5.,7./) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_interp(v,mv,'C: 3 layer (vanished middle) to 2', & - 3, (/1.,0.,2./), (/1.,2.,2.,3./), & - 2, (/1.,2./), (/1.,2.,3./) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_interp(v,mv,'D: 3 layer (deep) to 3', & - 3, (/1.,2.,3./), (/1.,2.,4.,7./), & - 2, (/2.,2./), (/1.,3.,5./) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_interp(v,mv,'E: 3 layer to 3 (deep)', & - 3, (/1.,2.,4./), (/1.,2.,4.,8./), & - 3, (/2.,3.,4./), (/1.,3.,6.,8./) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_interp(v,mv,'F: 3 layer to 4 with vanished top/botton', & - 3, (/1.,2.,4./), (/1.,2.,4.,8./), & - 4, (/0.,2.,5.,0./), (/mv,1.,3.,8.,mv/) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_interp(v,mv,'Fs: 3 layer to 4 with vanished top/botton (shallow)', & - 3, (/1.,2.,4./), (/1.,2.,4.,8./), & - 4, (/0.,2.,4.,0./), (/mv,1.,3.,7.,mv/) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_interp(v,mv,'Fd: 3 layer to 4 with vanished top/botton (deep)', & - 3, (/1.,2.,4./), (/1.,2.,4.,8./), & - 4, (/0.,2.,6.,0./), (/mv,1.,3.,8.,mv/) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - if (v) write(stdout,*) '- - - - - - - - - - reintegration tests - - - - - - - - -' - - fail = test_reintegrate(v,mv,'Identity: 3 layer', & - 3, (/1.,2.,3./), (/-5.,2.,1./), & - 3, (/1.,2.,3./), (/-5.,2.,1./) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_reintegrate(v,mv,'A: 3 layer to 2', & - 3, (/2.,2.,2./), (/-5.,2.,1./), & - 2, (/3.,3./), (/-4.,2./) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_reintegrate(v,mv,'A: 3 layer to 2 (deep)', & - 3, (/2.,2.,2./), (/-5.,2.,1./), & - 2, (/3.,4./), (/-4.,2./) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_reintegrate(v,mv,'A: 3 layer to 2 (shallow)', & - 3, (/2.,2.,2./), (/-5.,2.,1./), & - 2, (/3.,2./), (/-4.,1.5/) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_reintegrate(v,mv,'B: 3 layer to 4 with vanished top/bottom', & - 3, (/2.,2.,2./), (/-5.,2.,1./), & - 4, (/0.,3.,3.,0./), (/0.,-4.,2.,0./) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_reintegrate(v,mv,'C: 3 layer to 4 with vanished top//middle/bottom', & - 3, (/2.,2.,2./), (/-5.,2.,1./), & - 5, (/0.,3.,0.,3.,0./), (/0.,-4.,0.,2.,0./) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_reintegrate(v,mv,'D: 3 layer to 3 (vanished)', & - 3, (/2.,2.,2./), (/-5.,2.,1./), & - 3, (/0.,0.,0./), (/0.,0.,0./) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_reintegrate(v,mv,'D: 3 layer (vanished) to 3', & - 3, (/0.,0.,0./), (/-5.,2.,1./), & - 3, (/2.,2.,2./), (/mv, mv, mv/) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_reintegrate(v,mv,'D: 3 layer (vanished) to 3 (vanished)', & - 3, (/0.,0.,0./), (/-5.,2.,1./), & - 3, (/0.,0.,0./), (/mv, mv, mv/) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_reintegrate(v,mv,'D: 3 layer (vanished) to 3 (vanished)', & - 3, (/0.,0.,0./), (/0.,0.,0./), & - 3, (/0.,0.,0./), (/mv, mv, mv/) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - if (.not. fail) write(stdout,*) 'Pass' - -end function diag_vkernels_unit_tests - -!> Returns true if a test of interpolate_column() produces the wrong answer -logical function test_interp(verbose, missing_value, msg, nsrc, h_src, u_src, ndest, h_dest, u_true) - logical, intent(in) :: verbose !< If true, write results to stdout - real, intent(in) :: missing_value !< Value to indicate missing data - character(len=*), intent(in) :: msg !< Message to label test - integer, intent(in) :: nsrc !< Number of source cells - real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells - real, dimension(nsrc+1), intent(in) :: u_src !< Values at source cell interfaces - integer, intent(in) :: ndest !< Number of destination cells - real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells - real, dimension(ndest+1), intent(in) :: u_true !< Correct value at destination cell interfaces - ! Local variables - real, dimension(ndest+1) :: u_dest ! Interpolated value at destination cell interfaces - integer :: k - real :: error - logical :: print_results - - ! Interpolate from src to dest - call interpolate_column(nsrc, h_src, u_src, ndest, h_dest, missing_value, u_dest) - - test_interp = .false. - do k=1,ndest+1 - if (u_dest(k)/=u_true(k)) test_interp = .true. - enddo - if (verbose .or. test_interp) then - write(stdout,'(2a)') ' Test: ',msg - write(stdout,'(a3,3(a24))') 'k','u_result','u_true','error' - do k=1,ndest+1 - error = u_dest(k)-u_true(k) - if (error==0.) then - write(stdout,'(i3,3(1pe24.16))') k,u_dest(k),u_true(k),u_dest(k)-u_true(k) - else - write(stdout,'(i3,3(1pe24.16),x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' - write(stderr,'(i3,3(1pe24.16),x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' - endif - enddo - endif -end function test_interp - -!> Returns true if a test of reintegrate_column() produces the wrong answer -logical function test_reintegrate(verbose, missing_value, msg, nsrc, h_src, uh_src, ndest, h_dest, uh_true) - logical, intent(in) :: verbose !< If true, write results to stdout - real, intent(in) :: missing_value !< Value to indicate missing data - character(len=*), intent(in) :: msg !< Message to label test - integer, intent(in) :: nsrc !< Number of source cells - real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells - real, dimension(nsrc), intent(in) :: uh_src !< Values of source cell stuff - integer, intent(in) :: ndest !< Number of destination cells - real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells - real, dimension(ndest), intent(in) :: uh_true !< Correct value of destination cell stuff - ! Local variables - real, dimension(ndest) :: uh_dest ! Reintegrated value on destination cells - integer :: k - real :: error - logical :: print_results - - ! Interpolate from src to dest - call reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, missing_value, uh_dest) - - test_reintegrate = .false. - do k=1,ndest - if (uh_dest(k)/=uh_true(k)) test_reintegrate = .true. - enddo - if (verbose .or. test_reintegrate) then - write(stdout,'(2a)') ' Test: ',msg - write(stdout,'(a3,3(a24))') 'k','uh_result','uh_true','error' - do k=1,ndest - error = uh_dest(k)-uh_true(k) - if (error==0.) then - write(stdout,'(i3,3(1pe24.16))') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k) - else - write(stdout,'(i3,3(1pe24.16),x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' - write(stderr,'(i3,3(1pe24.16),x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' - endif - enddo - endif -end function test_reintegrate - -end module MOM_diag_vkernels diff --git a/src/framework/MOM_document.F90 b/src/framework/MOM_document.F90 index ff0934ac55..ef7d22596a 100644 --- a/src/framework/MOM_document.F90 +++ b/src/framework/MOM_document.F90 @@ -1,9 +1,11 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> The subroutines here provide hooks for document generation functions at !! various levels of granularity. module MOM_document -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_time_manager, only : time_type, operator(==), get_time, get_ticks_per_second use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe @@ -221,7 +223,7 @@ subroutine doc_param_int(doc, varname, desc, units, val, default, & end subroutine doc_param_int !> This subroutine handles parameter documentation for arrays of integers. -subroutine doc_param_int_array(doc, varname, desc, units, vals, default, & +subroutine doc_param_int_array(doc, varname, desc, units, vals, default, defaults, & layoutParam, debuggingParam, like_default) type(doc_type), pointer :: doc !< A pointer to a structure that controls where the !! documentation occurs and its formatting @@ -229,7 +231,8 @@ subroutine doc_param_int_array(doc, varname, desc, units, vals, default, & character(len=*), intent(in) :: desc !< A description of the parameter being documented character(len=*), intent(in) :: units !< The units of the parameter being documented integer, intent(in) :: vals(:) !< The array of values to record - integer, optional, intent(in) :: default !< The default value of this parameter + integer, optional, intent(in) :: default !< The uniform default value of this parameter + integer, optional, intent(in) :: defaults(:) !< The element-wise default values of this parameter logical, optional, intent(in) :: layoutParam !< If present and true, this is a layout parameter. logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though @@ -257,6 +260,11 @@ subroutine doc_param_int_array(doc, varname, desc, units, vals, default, & do i=1,size(vals) ; if (vals(i) /= default) equalsDefault = .false. ; enddo mesg = trim(mesg)//" default = "//(trim(int_string(default))) endif + if (present(defaults)) then + equalsDefault = .true. + do i=1,size(vals) ; if (vals(i) /= defaults(i)) equalsDefault = .false. ; enddo + mesg = trim(mesg)//" default = "//trim(int_array_string(defaults)) + endif if (present(like_default)) then ; if (like_default) equalsDefault = .true. ; endif if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates @@ -303,14 +311,16 @@ subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingPara end subroutine doc_param_real !> This subroutine handles parameter documentation for arrays of reals. -subroutine doc_param_real_array(doc, varname, desc, units, vals, default, debuggingParam, like_default) +subroutine doc_param_real_array(doc, varname, desc, units, vals, default, defaults, & + debuggingParam, like_default) type(doc_type), pointer :: doc !< A pointer to a structure that controls where the !! documentation occurs and its formatting character(len=*), intent(in) :: varname !< The name of the parameter being documented character(len=*), intent(in) :: desc !< A description of the parameter being documented character(len=*), intent(in) :: units !< The units of the parameter being documented real, intent(in) :: vals(:) !< The array of values to record - real, optional, intent(in) :: default !< The default value of this parameter + real, optional, intent(in) :: default !< A uniform default value of this parameter + real, optional, intent(in) :: defaults(:) !< The element-wise default values of this parameter logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. logical, optional, intent(in) :: like_default !< If present and true, log this parameter as though !! it has the default value, even if there is no default. @@ -334,6 +344,11 @@ subroutine doc_param_real_array(doc, varname, desc, units, vals, default, debugg do i=1,size(vals) ; if (vals(i) /= default) equalsDefault = .false. ; enddo mesg = trim(mesg)//" default = "//trim(real_string(default)) endif + if (present(defaults)) then + equalsDefault = .true. + do i=1,size(vals) ; if (vals(i) /= defaults(i)) equalsDefault = .false. ; enddo + mesg = trim(mesg)//" default = "//trim(real_array_string(defaults)) + endif if (present(like_default)) then ; if (like_default) equalsDefault = .true. ; endif if (mesgHasBeenDocumented(doc, varName, mesg)) return ! Avoid duplicates @@ -389,7 +404,6 @@ subroutine doc_openBlock(doc, blockName, desc) character(len=*), optional, intent(in) :: desc !< A description of the parameter block being opened ! This subroutine handles documentation for opening a parameter block. character(len=mLen) :: mesg - character(len=doc%commentColumn) :: valstring if (.not. (is_root_pe() .and. associated(doc))) return call open_doc_file(doc) @@ -413,7 +427,6 @@ subroutine doc_closeBlock(doc, blockName) character(len=*), intent(in) :: blockName !< The name of the parameter block being closed ! This subroutine handles documentation for closing a parameter block. character(len=mLen) :: mesg - character(len=doc%commentColumn) :: valstring integer :: i if (.not. (is_root_pe() .and. associated(doc))) return @@ -474,7 +487,7 @@ subroutine doc_param_time(doc, varname, desc, val, default, units, debuggingPara end subroutine doc_param_time -!> This subroutine writes out the message and description to the documetation files. +!> This subroutine writes out the message and description to the documentation files. subroutine writeMessageAndDesc(doc, vmesg, desc, valueWasDefault, indent, & layoutParam, debuggingParam) type(doc_type), intent(in) :: doc !< A pointer to a structure that controls where the @@ -639,19 +652,33 @@ function real_string(val) elseif (val == 0.) then real_string = "0.0" else - if ((abs(val) <= 1.0e-100) .or. (abs(val) >= 1.0e100)) then - write(real_string(1:32), '(ES24.14E3)') val - if (.not.testFormattedFloatIsReal(real_string,val)) & - write(real_string(1:32), '(ES24.15E3)') val + if ((abs(val) < 1.0e-99) .or. (abs(val) >= 1.0e100)) then + write(real_string(1:32), '(ES24.14E4)') val + if (scan(real_string, "eE") == 0) then ! Fix a bug with a missing E in PGI formatting + ind = scan(real_string, "-+", back=.true.) + if (ind > index(real_string, ".") ) & ! Avoid changing a leading sign. + real_string = real_string(1:ind-1)//"E"//real_string(ind:) + endif + if (.not.testFormattedFloatIsReal(real_string, val)) then + write(real_string(1:32), '(ES25.15E4)') val + if (scan(real_string, "eE") == 0) then ! Fix a bug with a missing E in PGI formatting + ind = scan(real_string, "-+", back=.true.) + if (ind > index(real_string, ".") ) & ! Avoid changing a leading sign. + real_string = real_string(1:ind-1)//"E"//real_string(ind:) + endif + endif + ! Remove a leading 0 from the exponent, if it is there. + ind = max(index(real_string, "E+0"), index(real_string, "E-0")) + if (ind > 0) real_string = real_string(1:ind+1)//real_string(ind+3:) else write(real_string(1:32), '(ES23.14)') val - if (.not.testFormattedFloatIsReal(real_string,val)) & + if (.not.testFormattedFloatIsReal(real_string, val)) & write(real_string(1:32), '(ES23.15)') val endif - do - ind = index(real_string,"0E") + do ! Remove extra trailing 0s before the exponent. + ind = index(real_string, "0E") if (ind == 0) exit - if (real_string(ind-1:ind-1) == ".") exit + if (real_string(ind-1:ind-1) == ".") exit ! Leave at least one digit after the decimal point. real_string = real_string(1:ind-1)//real_string(ind+1:) enddo endif @@ -672,22 +699,22 @@ function real_array_string(vals, sep) integer :: j, n, ns logical :: doWrite character(len=10) :: separator - n=1 ; doWrite=.true. ; real_array_string='' + n = 1 ; doWrite = .true. ; real_array_string = '' if (present(sep)) then - separator=sep ; ns=len(sep) + separator = sep ; ns = len(sep) else - separator=', ' ; ns=2 + separator = ', ' ; ns = 2 endif do j=1,size(vals) - doWrite=.true. - if (j0) then ! Write separator if a number has already been written + if (len(real_array_string) > 0) then ! Write separator if a number has already been written real_array_string = real_array_string // separator(1:ns) endif if (n>1) then @@ -700,6 +727,55 @@ function real_array_string(vals, sep) enddo end function real_array_string + +!> Returns a character string of a comma-separated, compact formatted, integers +!> e.g. "1, 2, 7*3, 500", that give the list of values. +function int_array_string(vals, sep) + character(len=:), allocatable :: int_array_string !< The output string listing vals + integer, intent(in) :: vals(:) !< The array of values to record + character(len=*), & + optional, intent(in) :: sep !< The separator between successive values, + !! by default it is ', '. + + ! Local variables + integer :: j, m, n, ns + logical :: doWrite + character(len=10) :: separator + n = 1 ; doWrite = .true. ; int_array_string = '' + if (present(sep)) then + separator = sep ; ns = len(sep) + else + separator = ', ' ; ns = 2 + endif + do j=1,size(vals) + doWrite = .true. + if (j < size(vals)) then + if (vals(j) == vals(j+1)) then + n = n+1 + doWrite = .false. + endif + endif + if (doWrite) then + if (len(int_array_string) > 0) then ! Write separator if a number has already been written + int_array_string = int_array_string // separator(1:ns) + endif + if (n>1) then + if (size(vals) > 6) then ! The n*val syntax is convenient in long lists of integers. + int_array_string = int_array_string // trim(int_string(n)) // "*" // trim(int_string(vals(j))) + else ! For short lists of integers, do not use the n*val syntax as it is less convenient. + do m=1,n-1 + int_array_string = int_array_string // trim(int_string(vals(j))) // separator(1:ns) + enddo + int_array_string = int_array_string // trim(int_string(vals(j))) + endif + else + int_array_string = int_array_string // trim(int_string(vals(j))) + endif + n=1 + endif + enddo +end function int_array_string + !> This function tests whether a real value is encoded in a string. function testFormattedFloatIsReal(str, val) character(len=*), intent(in) :: str !< The string that match val @@ -988,7 +1064,7 @@ function find_unused_unit_number() "doc_init failed to find an unused unit number.") end function find_unused_unit_number -!> This subroutine closes the the files controlled by doc, and sets flags in +!> This subroutine closes the files controlled by doc, and sets flags in !! doc to indicate that parameterization is no longer permitted. subroutine doc_end(doc) type(doc_type), pointer :: doc !< A pointer to a structure that controls where the diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 0cdcc455fc..d8a528f5bf 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Describes the decomposed MOM domain and has routines for communications across PEs module MOM_domains -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_coms_infra, only : MOM_infra_init, MOM_infra_end use MOM_coms_infra, only : PE_here, root_PE, num_PEs, broadcast use MOM_coms_infra, only : sum_across_PEs, min_across_PEs, max_across_PEs @@ -10,20 +12,23 @@ module MOM_domains use MOM_domain_infra, only : create_MOM_domain, clone_MOM_domain, deallocate_MOM_domain use MOM_domain_infra, only : get_domain_extent, get_domain_components, same_domain use MOM_domain_infra, only : compute_block_extent, get_global_shape -use MOM_domain_infra, only : pass_var, pass_vector, fill_symmetric_edges, global_field_sum +use MOM_domain_infra, only : pass_var, pass_vector, fill_symmetric_edges use MOM_domain_infra, only : pass_var_start, pass_var_complete use MOM_domain_infra, only : pass_vector_start, pass_vector_complete use MOM_domain_infra, only : create_group_pass, do_group_pass use MOM_domain_infra, only : start_group_pass, complete_group_pass use MOM_domain_infra, only : rescale_comp_data, global_field, redistribute_array, broadcast_domain use MOM_domain_infra, only : MOM_thread_affinity_set, set_MOM_thread_affinity -use MOM_domain_infra, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM +use MOM_domain_infra, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR use MOM_domain_infra, only : CORNER, CENTER, NORTH_FACE, EAST_FACE use MOM_domain_infra, only : To_East, To_West, To_North, To_South, To_All, Omit_Corners -use MOM_error_handler, only : MOM_error, MOM_mesg, NOTE, WARNING, FATAL +use MOM_domain_infra, only : compute_extent +use MOM_error_handler, only : MOM_error, MOM_mesg, NOTE, WARNING, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_io_infra, only : file_exists +use MOM_io_infra, only : file_exists, read_field, open_ASCII_file, close_file, WRITEONLY_FILE use MOM_string_functions, only : slasher +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_unit_scaling, only : unit_scale_type implicit none ; private @@ -32,6 +37,7 @@ module MOM_domains public :: MOM_domain_type, domain2D, domain1D public :: MOM_domains_init, create_MOM_domain, clone_MOM_domain, deallocate_MOM_domain public :: MOM_thread_affinity_set, set_MOM_thread_affinity +public :: MOM_define_layout ! Domain query routines public :: get_domain_extent, get_domain_components, get_global_shape, same_domain public :: PE_here, root_PE, num_PEs @@ -54,9 +60,6 @@ module MOM_domains public :: CORNER, CENTER, NORTH_FACE, EAST_FACE !> These encoding constants indicate communication patterns. In practice they can be added. public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners -! These are no longer used by MOM6 because the reproducing sum works so well, but they are -! still referenced by some of the non-GFDL couplers. -public :: global_field_sum, BITWISE_EXACT_SUM contains @@ -65,7 +68,7 @@ module MOM_domains !! properties of the domain type. subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & NIHALO, NJHALO, NIGLOBAL, NJGLOBAL, NIPROC, NJPROC, & - min_halo, domain_name, include_name, param_suffix) + min_halo, domain_name, include_name, param_suffix, US, MOM_dom_unmasked) type(MOM_domain_type), pointer :: MOM_dom !< A pointer to the MOM_domain_type !! being defined here. type(param_file_type), intent(in) :: param_file !< A structure to parse for @@ -98,9 +101,14 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & !! "MOM_memory.h" if missing. character(len=*), optional, intent(in) :: param_suffix !< A suffix to apply to !! layout-specific parameters. + type(unit_scale_type), optional, pointer :: US !< A dimensional unit scaling type + type(MOM_domain_type), optional, pointer :: MOM_dom_unmasked !< Unmasked MOM domain instance. + !! Set to null if masking is not enabled. ! Local variables integer, dimension(2) :: layout ! The number of logical processors in the i- and j- directions + integer, dimension(2) :: auto_layout ! The layout determined by the auto masking routine + integer, dimension(2) :: layout_unmasked ! A temporary layout for unmasked domain integer, dimension(2) :: io_layout ! The layout of logical processors for input and output !$ integer :: ocean_nthreads ! Number of openMP threads !$ logical :: ocean_omp_hyper_thread ! If true use openMP hyper-threads @@ -115,7 +123,10 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & logical :: nonblocking ! If true, nonblocking halo updates will be used. logical :: thin_halos ! If true, If true, optional arguments may be used to specify the ! width of the halos that are updated with each call. + logical :: auto_mask_table ! Runtime flag that turns on automatic mask table generator + integer :: auto_io_layout_fac ! Used to compute IO layout when auto_mask_table is True. logical :: mask_table_exists ! True if there is a mask table file + logical :: is_MOM_domain ! True if this domain is being set for MOM, and not another component like SIS2. character(len=128) :: inputdir ! The directory in which to find the diag table character(len=200) :: mask_table ! The file name and later the full path to the diag table character(len=64) :: inc_nm ! The name of the memory include file @@ -125,6 +136,10 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & character(len=8) :: char_xsiz, char_ysiz, char_niglobal, char_njglobal character(len=40) :: nihalo_nm, njhalo_nm, layout_nm, io_layout_nm, masktable_nm character(len=40) :: niproc_nm, njproc_nm + character(len=200) :: topo_config + integer :: id_clock_auto_mask + character(len=:), allocatable :: masktable_desc + character(len=:), allocatable :: auto_mask_table_fname ! Auto-generated mask table file name ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl ! This module's name. @@ -183,9 +198,9 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & !$ if (.not.MOM_thread_affinity_set()) then !$ call get_param(param_file, mdl, "OCEAN_OMP_THREADS", ocean_nthreads, & !$ "The number of OpenMP threads that MOM6 will use.", & - !$ default = 1, layoutParam=.true.) + !$ default=1, layoutParam=.true.) !$ call get_param(param_file, mdl, "OCEAN_OMP_HYPER_THREAD", ocean_omp_hyper_thread, & - !$ "If True, use hyper-threading.", default = .false., layoutParam=.true.) + !$ "If True, use hyper-threading.", default=.false., layoutParam=.true.) !$ call set_MOM_thread_affinity(ocean_nthreads, ocean_omp_hyper_thread) !$ endif # endif @@ -220,11 +235,11 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & call get_param(param_file, mdl, "NIGLOBAL", n_global(1), & "The total number of thickness grid points in the x-direction in the physical "//& "domain. With STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.", & - static_value=NIGLOBAL) + default=NIGLOBAL) call get_param(param_file, mdl, "NJGLOBAL", n_global(2), & "The total number of thickness grid points in the y-direction in the physical "//& "domain. With STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.", & - static_value=NJGLOBAL) + default=NJGLOBAL) if (n_global(1) /= NIGLOBAL) call MOM_error(FATAL,"MOM_domains_init: " // & "static mismatch for NIGLOBAL_ domain size. Header file does not match input namelist") if (n_global(2) /= NJGLOBAL) call MOM_error(FATAL,"MOM_domains_init: " // & @@ -232,10 +247,10 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & ! Check the requirement of equal sized compute domains when STATIC_MEMORY_ is used. if ((MOD(NIGLOBAL, NIPROC) /= 0) .OR. (MOD(NJGLOBAL, NJPROC) /= 0)) then - write( char_xsiz, '(i4)' ) NIPROC - write( char_ysiz, '(i4)' ) NJPROC - write( char_niglobal, '(i4)' ) NIGLOBAL - write( char_njglobal, '(i4)' ) NJGLOBAL + write( char_xsiz, '(I0)' ) NIPROC + write( char_ysiz, '(I0)' ) NJPROC + write( char_niglobal, '(I0)' ) NIGLOBAL + write( char_njglobal, '(I0)' ) NJGLOBAL call MOM_error(WARNING, 'MOM_domains: Processor decomposition (NIPROC_,NJPROC_) = ('//& trim(char_xsiz)//','//trim(char_ysiz)//') does not evenly divide size '//& 'set by preprocessor macro ('//trim(char_niglobal)//','//trim(char_njglobal)//').') @@ -256,11 +271,11 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & call get_param(param_file, mdl, trim(nihalo_nm), n_halo(1), & "The number of halo points on each side in the x-direction. How this is set "//& "varies with the calling component and static or dynamic memory configuration.", & - default=nihalo_dflt, static_value=nihalo_dflt) + default=nihalo_dflt) call get_param(param_file, mdl, trim(njhalo_nm), n_halo(2), & "The number of halo points on each side in the y-direction. How this is set "//& "varies with the calling component and static or dynamic memory configuration.", & - default=njhalo_dflt, static_value=njhalo_dflt) + default=njhalo_dflt) if (present(min_halo)) then n_halo(1) = max(n_halo(1), min_halo(1)) min_halo(1) = n_halo(1) @@ -280,25 +295,68 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & call get_param(param_file, mdl, "INPUTDIR", inputdir, do_not_log=.true., default=".") inputdir = slasher(inputdir) - call get_param(param_file, mdl, trim(masktable_nm), mask_table, & - "A text file to specify n_mask, layout and mask_list. This feature masks out "//& - "processors that contain only land points. The first line of mask_table is the "//& - "number of regions to be masked out. The second line is the layout of the "//& - "model and must be consistent with the actual model layout. The following "//& - "(n_mask) lines give the logical positions of the processors that are masked "//& - "out. The mask_table can be created by tools like check_mask. The following "//& - "example of mask_table masks out 2 processors, (1,2) and (3,6), out of the 24 "//& - "in a 4x6 layout: \n 2\n 4,6\n 1,2\n 3,6\n", default="MOM_mask_table", & - layoutParam=.true.) - mask_table = trim(inputdir)//trim(mask_table) - mask_table_exists = file_exists(mask_table) + is_MOM_domain = .true. + if (present(domain_name)) then + is_MOM_domain = (index(domain_name, "MOM") > 1) + endif + + if (is_MOM_domain) then + call get_param(param_file, mdl, "TOPO_CONFIG", topo_config, do_not_log=.true., fail_if_missing=.true.) + else ! SIS2 has a default value for TOPO_CONFIG. + call get_param(param_file, mdl, "TOPO_CONFIG", topo_config, default="file", do_not_log=.true.) + endif + + auto_mask_table = .false. + if (.not. present(param_suffix) .and. .not. is_static .and. trim(topo_config) == 'file') then + call get_param(param_file, mdl, 'AUTO_MASKTABLE', auto_mask_table, & + "Turn on automatic mask table generation to eliminate land blocks.", & + default=.false., layoutParam=.true.) + endif + + masktable_desc = "A text file to specify n_mask, layout and mask_list. This feature masks out "//& + "processors that contain only land points. The first line of mask_table is the "//& + "number of regions to be masked out. The second line is the layout of the "//& + "model and must be consistent with the actual model layout. The following "//& + "(n_mask) lines give the logical positions of the processors that are masked "//& + "out. The mask_table can be created by tools like check_mask. The following "//& + "example of mask_table masks out 2 processors, (1,2) and (3,6), out of the 24 "//& + "in a 4x6 layout: \n 2\n 4,6\n 1,2\n 3,6\n" + + if (auto_mask_table) then + id_clock_auto_mask = cpu_clock_id('(Ocean gen_auto_mask_table)', grain=CLOCK_ROUTINE) + auto_mask_table_fname = "MOM_auto_mask_table" + + ! Auto-generate a mask file and determine the layout + call cpu_clock_begin(id_clock_auto_mask) + if (is_root_PE()) then + call gen_auto_mask_table(n_global, reentrant, tripolar_N, PEs_used, param_file, inputdir, & + auto_mask_table_fname, auto_layout, US) + endif + call broadcast(auto_layout, length=2) + call cpu_clock_end(id_clock_auto_mask) + + mask_table = auto_mask_table_fname + call log_param(param_file, mdl, trim(masktable_nm), mask_table, masktable_desc, & + default="MOM_mask_table", layoutParam=.true.) + else + call get_param(param_file, mdl, trim(masktable_nm), mask_table, masktable_desc, & + default="MOM_mask_table", layoutParam=.true.) + endif + + ! First, check the run directory for the mask_table input file. + mask_table_exists = file_exists(trim(mask_table)) + ! If not found, check the input directory + if (.not. mask_table_exists) then + mask_table = trim(inputdir)//trim(mask_table) + mask_table_exists = file_exists(mask_table) + endif if (is_static) then layout(1) = NIPROC ; layout(2) = NJPROC else call get_param(param_file, mdl, trim(layout_nm), layout, & "The processor layout to be used, or 0, 0 to automatically set the layout "//& - "based on the number of processors.", default=0, do_not_log=.true.) + "based on the number of processors.", defaults=(/0, 0/), do_not_log=.true.) call get_param(param_file, mdl, trim(niproc_nm), nip_parsed, & "The number of processors in the x-direction.", default=-1, do_not_log=.true.) call get_param(param_file, mdl, trim(njproc_nm), njp_parsed, & @@ -320,6 +378,16 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & "Shift to using "//trim(layout_nm)//" instead.") endif + if (auto_mask_table) then + if (layout(1) /= 0 .and. layout(1) /= auto_layout(1)) then + call MOM_error(FATAL, "Cannot set LAYOUT or NIPROC when AUTO_MASKTABLE is enabled.") + endif + if (layout(2) /= 0 .and. layout(2) /= auto_layout(2)) then + call MOM_error(FATAL, "Cannot set LAYOUT or NJPROC when AUTO_MASKTABLE is enabled.") + endif + layout(:) = auto_layout(:) + endif + if ( (layout(1) == 0) .and. (layout(2) == 0) ) & call MOM_define_layout(n_global, PEs_used, layout) if ( (layout(1) /= 0) .and. (layout(2) == 0) ) layout(2) = PEs_used / layout(1) @@ -327,7 +395,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & if (layout(1)*layout(2) /= PEs_used .and. (.not. mask_table_exists) ) then write(mesg,'("MOM_domains_init: The product of the two components of layout, ", & - & 2i4,", is not the number of PEs used, ",i5,".")') & + & I0,", ",I0,", is not the number of PEs used, ",I0,".")') & layout(1), layout(2), PEs_used call MOM_error(FATAL, mesg) endif @@ -343,8 +411,8 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & ! Idiot check that fewer PEs than columns have been requested if (layout(1)*layout(2) > n_global(1)*n_global(2)) then - write(mesg,'(a,2(i5,x,a))') 'You requested to use',layout(1)*layout(2), & - 'PEs but there are only', n_global(1)*n_global(2), 'columns in the model' + write(mesg,'(a,I0,a,I0,a)') 'You requested to use ', layout(1)*layout(2), & + ' PEs but there are only ', n_global(1)*n_global(2), ' columns in the model' call MOM_error(FATAL, mesg) endif @@ -354,9 +422,36 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & ! Set up the I/O layout, it will be checked later that it uses an even multiple of the number of ! PEs in each direction. io_layout(:) = (/ 1, 1 /) - call get_param(param_file, mdl, trim(io_layout_nm), io_layout, & - "The processor layout to be used, or 0,0 to automatically set the io_layout "//& - "to be the same as the layout.", default=1, layoutParam=.true.) + + ! Compute a valid IO layout if auto_mask_table is on. Otherwise, read in IO_LAYOUT parameter, + if (auto_mask_table) then + call get_param(param_file, mdl, "AUTO_IO_LAYOUT_FAC", auto_io_layout_fac, & + "When AUTO_MASKTABLE is enabled, io layout is calculated by performing integer "//& + "division of the runtime-determined domain layout with this factor. If the factor "//& + "is set to 0 (default), the io layout is set to 1,1.", & + default=0, layoutParam=.true.) + if (auto_io_layout_fac>0) then + io_layout(1) = max(layout(1)/auto_io_layout_fac, 1) + io_layout(2) = max(layout(2)/auto_io_layout_fac, 1) + elseif (auto_io_layout_fac<0) then + call MOM_error(FATAL, 'AUTO_IO_LAYOUT_FAC must be a nonnegative integer.') + endif + call log_param(param_file, mdl, trim(io_layout_nm), io_layout, & + "The processor layout to be used, or 0,0 to automatically set the io_layout "//& + "to be the same as the layout.", layoutParam=.true.) + else + call get_param(param_file, mdl, trim(io_layout_nm), io_layout, & + "The processor layout to be used, or 0,0 to automatically set the io_layout "//& + "to be the same as the layout.", defaults=(/1, 1/), layoutParam=.true.) + endif + + ! Create an unmasked domain if requested. This is used for writing out unmasked ocean geometry. + if (present(MOM_dom_unmasked) .and. mask_table_exists) then + call MOM_define_layout(n_global, PEs_used, layout_unmasked) + call create_MOM_domain(MOM_dom_unmasked, n_global, n_halo, reentrant, tripolar_N, layout_unmasked, & + domain_name=domain_name, symmetric=symmetric, thin_halos=thin_halos, & + nonblocking=nonblocking) + endif call create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, layout, & io_layout=io_layout, domain_name=domain_name, mask_table=mask_table, & @@ -390,4 +485,221 @@ subroutine MOM_define_layout(n_global, ndivs, layout) layout = (/ idiv, jdiv /) end subroutine MOM_define_layout +!> Given a desired number of active npes, generate a layout and mask_table +subroutine gen_auto_mask_table(n_global, reentrant, tripolar_N, npes, param_file, inputdir, filename, layout, US) + integer, dimension(2), intent(in) :: n_global !< The total number of gridpoints in 2 directions + logical, dimension(2), intent(in) :: reentrant !< True if the x- and y- directions are periodic. + logical, intent(in) :: tripolar_N !< A flag indicating whether there is n. tripolar connectivity + integer, intent(in) :: npes !< The desired number of active PEs. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + character(len=128), intent(in) :: inputdir !< INPUTDIR parameter + character(len=:), allocatable, intent(in) :: filename !< Mask table file path (to be auto-generated.) + integer, dimension(2), intent(out) :: layout !< The generated layout of PEs (incl. masked blocks) + type(unit_scale_type), optional, pointer :: US !< A dimensional unit scaling type + + ! Local variables + real, dimension(n_global(1), n_global(2)) :: D ! Bathymetric depth (to be read in from TOPO_FILE) [Z ~> m] + integer, dimension(:,:), allocatable :: mask ! Cell masks (based on D and MINIMUM_DEPTH) + character(len=200) :: topo_filepath, topo_file ! Strings for file/path + character(len=200) :: topo_varname ! Variable name in file + character(len=200) :: topo_config + character(len=40) :: mdl = "gen_auto_mask_table" ! This subroutine's name. + integer :: i, j, p + real :: Dmask ! The depth for masking in the same units as D [Z ~> m] + real :: min_depth ! The minimum ocean depth in the same units as D [Z ~> m] + real :: mask_depth ! The depth shallower than which to mask a point as land. [Z ~> m] + real :: glob_ocn_frac ! ratio of ocean points to total number of points [nondim] + real :: r_p ! aspect ratio for division count p. [nondim] + real :: m_to_Z ! A conversion factor from m to height units [Z m-1 ~> 1] + integer :: nx, ny ! global domain sizes + integer, parameter :: ibuf=2, jbuf=2 + real, parameter :: r_extreme = 4.0 ! aspect ratio limit (>1) for a layout to be considered [nondim] + integer :: num_masked_blocks + integer, allocatable :: mask_table(:,:) + + m_to_Z = 1.0 ; if (present(US)) m_to_Z = US%m_to_Z + + ! Read in params necessary for auto-masking + call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & + units="m", default=0.0, scale=m_to_Z, do_not_log=.true.) + call get_param(param_file, mdl, "MASKING_DEPTH", mask_depth, & + units="m", default=-9999.0, scale=m_to_Z, do_not_log=.true.) + call get_param(param_file, mdl, "TOPO_CONFIG", topo_config, default="file", do_not_log=.true.) + call get_param(param_file, mdl, "TOPO_FILE", topo_file, do_not_log=.true., default="topog.nc") + call get_param(param_file, mdl, "TOPO_VARNAME", topo_varname, do_not_log=.true., default="depth") + topo_filepath = trim(inputdir)//trim(topo_file) + + ! Sanity checks + if (.not. is_root_pe()) then + call MOM_error(FATAL, 'gen_auto_mask_table should only be called by the root PE.') + endif + if (trim(topo_config) /= "file") then + call MOM_error(FATAL, 'Auto mask table only works with TOPO_CONFIG="file"') + endif + if (.not.file_exists(topo_filepath)) then + call MOM_error(FATAL, " gen_auto_mask_table: Unable to open "//trim(topo_filepath)) + endif + + nx = n_global(1) + ny = n_global(2) + + ! Read in bathymetric depth. + D(:,:) = -9.0e30 * m_to_Z ! Initializing to a very large negative depth (tall mountains) everywhere. + call read_field(topo_filepath, trim(topo_varname), D, start=(/1, 1/), nread=n_global, no_domain=.true., & + scale=m_to_Z) + + allocate(mask(nx+2*ibuf, ny+2*jbuf), source=0) + + ! Determine cell masks + Dmask = mask_depth + if (mask_depth == -9999.0*m_to_Z) Dmask = min_depth + do i=1,nx ; do j=1,ny + if (D(i,j) <= Dmask) then + mask(i+ibuf,j+jbuf) = 0 + else + mask(i+ibuf,j+jbuf) = 1 + endif + enddo ; enddo + + ! fill in buffer cells + + if (reentrant(1)) then ! REENTRANT_X + mask(1:ibuf, :) = mask(nx+1:nx+ibuf, :) + mask(ibuf+nx+1:nx+2*ibuf, :) = mask(ibuf+1:2*ibuf, :) + endif + + if (reentrant(2)) then ! REENTRANT_Y + mask(:, 1:jbuf) = mask(:, ny+1:ny+jbuf) + mask(:, jbuf+ny+1:ny+2*jbuf) = mask(:, jbuf+1:2*jbuf) + endif + + if (tripolar_N) then ! TRIPOLAR_N + do i=1,nx+2*ibuf + do j=1,jbuf + mask(i, jbuf+ny+j) = mask(nx+2*ibuf+1-i, jbuf+ny+1-j) + enddo + enddo + endif + + ! Tripolar Stitch Fix: In cases where masking is asymmetrical across the tripolar stitch, there's a possibility + ! that certain unmasked blocks won't be able to obtain grid metrics from the halo points. This occurs when the + ! neighboring block on the opposite side of the tripolar stitch is masked. As a consequence, certain metrics like + ! dxT and dyT may be calculated through extrapolation (refer to extrapolate_metric), potentially leading to the + ! generation of non-positive values. This can result in divide-by-zero errors elsewhere, e.g., in MOM_hor_visc.F90. + ! Currently, the safest and most general solution is to prohibit masking along the tripolar stitch: + if (tripolar_N) then + mask(:, jbuf+ny) = 1 + endif + + glob_ocn_frac = real(sum(mask(1+ibuf:nx+ibuf, 1+jbuf:ny+jbuf))) / (nx * ny) + + ! Iteratively check for all possible division counts starting from the upper bound of npes/glob_ocn_frac, + ! which is over-optimistic for realistic domains, but may be satisfied with idealized domains. + do p = ceiling(npes/glob_ocn_frac), npes, -1 + + ! compute the layout for the current division count, p + call MOM_define_layout(n_global, p, layout) + + ! don't bother checking this p if the aspect ratio is extreme + r_p = (real(nx)/layout(1)) / (real(ny)/layout(2)) + if ( r_p * r_extreme < 1 .or. r_extreme < r_p ) cycle + + ! Get the number of masked_blocks for this particular division count + call determine_land_blocks(mask, nx, ny, layout(1), layout(2), ibuf, jbuf, num_masked_blocks) + + ! If we can eliminate enough blocks to reach the target npes, adopt + ! this p (and the associated layout) and terminate the iteration. + if (p-num_masked_blocks <= npes) then + call MOM_error(NOTE, "Found the optimum layout for auto-masking. Terminating iteration...") + exit + endif + enddo + + if (num_masked_blocks == 0) then + call MOM_error(FATAL, "Couldn't auto-eliminate any land blocks. Try to increase the number "//& + "of MOM6 PEs or set AUTO_MASKTABLE to False.") + endif + + ! Call determine_land_blocks once again, this time to retrieve and write out the mask_table. + allocate(mask_table(num_masked_blocks,2)) + call determine_land_blocks(mask, nx, ny, layout(1), layout(2), ibuf, jbuf, num_masked_blocks, mask_table) + call write_auto_mask_file(mask_table, layout, npes, filename) + deallocate(mask_table) + deallocate(mask) + +end subroutine gen_auto_mask_table + +!> Given a number of domain divisions, compute the max number of land blocks that can be eliminated, +!! and return the resulting mask table if requested. +subroutine determine_land_blocks(mask, nx, ny, idiv, jdiv, ibuf, jbuf, num_masked_blocks, mask_table) + integer, dimension(:,:), intent(in) :: mask !< cell masks based on depth and MINIMUM_DEPTH + integer, intent(in) :: nx !< Total number of gridpoints in x-dir (global) + integer, intent(in) :: ny !< Total number of gridpoints in y-dir (global) + integer, intent(in) :: idiv !< number of divisions along x-dir + integer, intent(in) :: jdiv !< number of divisions along y-dir + integer, intent(in) :: ibuf !< number of buffer cells in x-dir. + !! (not necessarily the same as NIHALO) + integer, intent(in) :: jbuf !< number of buffer cells in y-dir. + !! (not necessarily the same as NJHALO) + integer, intent(out) :: num_masked_blocks !< the final number of masked blocks + integer, intent(out), optional :: mask_table(:,:) !< the resulting array of mask_table + ! integer + integer, dimension(idiv) :: ibegin !< The starting index of each division along x axis + integer, dimension(idiv) :: iend !< The ending index of each division along x axis + integer, dimension(jdiv) :: jbegin !< The starting index of each division along y axis + integer, dimension(jdiv) :: jend !< The ending index of each division along y axis + integer :: i, j, ib, ie, jb,je + + call compute_extent(1, nx, idiv, ibegin, iend) + call compute_extent(1, ny, jdiv, jbegin, jend) + + num_masked_blocks = 0 + + do i=1,idiv + ib = ibegin(i) + ie = iend(i) + 2 * ibuf + do j=1,jdiv + jb = jbegin(j) + je = jend(j) + 2 * jbuf + + if (any(mask(ib:ie,jb:je)==1)) cycle + + num_masked_blocks = num_masked_blocks + 1 + + if (present(mask_table)) then + if ( num_masked_blocks > size(mask_table, dim=1)) then + call MOM_error(FATAL, "The mask_table argument passed to determine_land_blocks() has insufficient size.") + endif + + mask_table(num_masked_blocks,1) = i + mask_table(num_masked_blocks,2) = j + endif + enddo + enddo + +end subroutine determine_land_blocks + +!> Write out the auto-generated mask information to a file in the run directory. +subroutine write_auto_mask_file(mask_table, layout, npes, filename) + integer, intent(in) :: mask_table(:,:) !> mask table array to be written out. + integer, dimension(2), intent(in) :: layout !> PE layout + integer, intent(in) :: npes !> Number of divisions (incl. eliminated ones) + character(len=:), allocatable, intent(in) :: filename !> file name for the mask_table to be written + ! local + integer :: file_ascii= -1 !< The unit number of the auto-generated mask_file file. + integer :: true_num_masked_blocks + integer :: p + + ! Eliminate only enough blocks to ensure that the number of active blocks precisely matches the target npes. + true_num_masked_blocks = layout(1) * layout(2) - npes + + call open_ASCII_file(file_ascii, trim(filename), action=WRITEONLY_FILE) + write(file_ascii, '(I0)') true_num_masked_blocks + write(file_ascii, '(I0,",",I0)') layout(1), layout(2) + do p = 1, true_num_masked_blocks + write(file_ascii, '(I0,",",I0)') mask_table(p,1), mask_table(p,2) + enddo + call close_file(file_ascii) +end subroutine write_auto_mask_file + end module MOM_domains diff --git a/src/framework/MOM_dyn_horgrid.F90 b/src/framework/MOM_dyn_horgrid.F90 index 8264a903cf..d72d877b98 100644 --- a/src/framework/MOM_dyn_horgrid.F90 +++ b/src/framework/MOM_dyn_horgrid.F90 @@ -1,9 +1,11 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Contains a shareable dynamic type for describing horizontal grids and metric data !! and utilty routines that work on this type. module MOM_dyn_horgrid -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_array_transform, only : rotate_array, rotate_array_pair use MOM_domains, only : MOM_domain_type, deallocate_MOM_domain use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING @@ -87,10 +89,12 @@ module MOM_dyn_horgrid real, allocatable, dimension(:,:) :: & mask2dCu, & !< 0 for boundary points and 1 for ocean points on the u grid [nondim]. + OBCmaskCu, & !< 0 for boundary or OBC points and 1 for ocean points on the u grid [nondim]. geoLatCu, & !< The geographic latitude at u points [degrees of latitude] or [m]. geoLonCu, & !< The geographic longitude at u points [degrees of longitude] or [m]. dxCu, & !< dxCu is delta x at u points [L ~> m]. IdxCu, & !< 1/dxCu [L-1 ~> m-1]. + IdxCu_OBCmask, & !< 1/dxCu or 0 at boundary or OBC points [L-1 ~> m-1]. dyCu, & !< dyCu is delta y at u points [L ~> m]. IdyCu, & !< 1/dyCu [L-1 ~> m-1]. dy_Cu, & !< The unblocked lengths of the u-faces of the h-cell [L ~> m]. @@ -99,24 +103,26 @@ module MOM_dyn_horgrid real, allocatable, dimension(:,:) :: & mask2dCv, & !< 0 for boundary points and 1 for ocean points on the v grid [nondim]. + OBCmaskCv, & !< 0 for boundary or OBC points and 1 for ocean points on the v grid [nondim]. geoLatCv, & !< The geographic latitude at v points [degrees of latitude] or [m]. geoLonCv, & !< The geographic longitude at v points [degrees of longitude] or [m]. dxCv, & !< dxCv is delta x at v points [L ~> m]. IdxCv, & !< 1/dxCv [L-1 ~> m-1]. dyCv, & !< dyCv is delta y at v points [L ~> m]. IdyCv, & !< 1/dyCv [L-1 ~> m-1]. + IdyCv_OBCmask, & !< 1/dxCv or 0 at boundary or OBC points [L-1 ~> m-1]. dx_Cv, & !< The unblocked lengths of the v-faces of the h-cell [L ~> m]. IareaCv, & !< The masked inverse areas of v-grid cells [L-2 ~> m-2]. areaCv !< The areas of the v-grid cells [L2 ~> m2]. real, allocatable, dimension(:,:) :: & - porous_DminU, & !< minimum topographic height of U-face [Z ~> m] - porous_DmaxU, & !< maximum topographic height of U-face [Z ~> m] + porous_DminU, & !< minimum topographic height (deepest) of U-face [Z ~> m] + porous_DmaxU, & !< maximum topographic height (shallowest) of U-face [Z ~> m] porous_DavgU !< average topographic height of U-face [Z ~> m] real, allocatable, dimension(:,:) :: & - porous_DminV, & !< minimum topographic height of V-face [Z ~> m] - porous_DmaxV, & !< maximum topographic height of V-face [Z ~> m] + porous_DminV, & !< minimum topographic height (deepest) of V-face [Z ~> m] + porous_DmaxV, & !< maximum topographic height (shallowest) of V-face [Z ~> m] porous_DavgV !< average topographic height of V-face [Z ~> m] real, allocatable, dimension(:,:) :: & @@ -131,24 +137,40 @@ module MOM_dyn_horgrid IareaBu !< IareaBu = 1/areaBu [L-2 ~> m-2]. real, pointer, dimension(:) :: gridLatT => NULL() - !< The latitude of T points for the purpose of labeling the output axes. + !< The latitude of T points for the purpose of labeling the output axes, + !! often in units of [degrees_N] or [km] or [m] or [gridpoints]. !! On many grids this is the same as geoLatT. real, pointer, dimension(:) :: gridLatB => NULL() - !< The latitude of B points for the purpose of labeling the output axes. + !< The latitude of B points for the purpose of labeling the output axes, + !! often in units of [degrees_N] or [km] or [m] or [gridpoints]. !! On many grids this is the same as geoLatBu. real, pointer, dimension(:) :: gridLonT => NULL() - !< The longitude of T points for the purpose of labeling the output axes. + !< The longitude of T points for the purpose of labeling the output axes, + !! often in units of [degrees_E] or [km] or [m] or [gridpoints]. !! On many grids this is the same as geoLonT. real, pointer, dimension(:) :: gridLonB => NULL() - !< The longitude of B points for the purpose of labeling the output axes. + !< The longitude of B points for the purpose of labeling the output axes, + !! often in units of [degrees_E] or [km] or [m] or [gridpoints]. !! On many grids this is the same as geoLonBu. character(len=40) :: & + ! Except on a Cartesian grid, these are usually some variant of "degrees". x_axis_units, & !< The units that are used in labeling the x coordinate axes. - y_axis_units !< The units that are used in labeling the y coordinate axes. - ! Except on a Cartesian grid, these are usually some variant of "degrees". + y_axis_units, & !< The units that are used in labeling the y coordinate axes. + ! These are internally generated names, including "m", "km", "deg_E" and "deg_N". + x_ax_unit_short, & !< A short description of the x-axis units for documenting parameter units + y_ax_unit_short !< A short description of the y-axis units for documenting parameter units real, allocatable, dimension(:,:) :: & - bathyT !< Ocean bottom depth at tracer points, in depth units [Z ~> m]. + bathyT !< Ocean bottom depth, referenced to a zero reference height at tracer points. + !! bathyT is in depth units and positive *below* the reference height [Z ~> m]. + real, allocatable, dimension(:,:) :: & + meanSL !< Spatially varying time mean sea level, referenced to a zero reference height + !! at tracer points. meanSL is in height units and positive *above* zero. It is used + !! a) as the height where p = p_atm or zero; + !! b) to calculate time mean thickness of the water column, where + !! mean thickness = max(meanSL + bathyT, 0.0). + !! meanSL is 2D for the consideration of a domain with spatically varying mean + !! height, e.g. the Great Lakes system [Z ~> m]. logical :: bathymetry_at_vel !< If true, there are separate values for the !! basin depths at velocity points. Otherwise the effects of @@ -160,22 +182,26 @@ module MOM_dyn_horgrid Dblock_v, & !< Topographic depths at v-points at which the flow is blocked [Z ~> m]. Dopen_v !< Topographic depths at v-points at which the flow is open at width dx_Cv [Z ~> m]. real, allocatable, dimension(:,:) :: & - CoriolisBu !< The Coriolis parameter at corner points [T-1 ~> s-1]. + CoriolisBu, & !< The Coriolis parameter at corner points [T-1 ~> s-1]. + Coriolis2Bu !< The square of the Coriolis parameter at corner points [T-2 ~> s-2]. real, allocatable, dimension(:,:) :: & df_dx, & !< Derivative d/dx f (Coriolis parameter) at h-points [T-1 L-1 ~> s-1 m-1]. df_dy !< Derivative d/dy f (Coriolis parameter) at h-points [T-1 L-1 ~> s-1 m-1]. - ! These variables are global sums that are useful for 1-d diagnostics and should not be rescaled. - real :: areaT_global !< Global sum of h-cell area [m2] - real :: IareaT_global !< Global sum of inverse h-cell area (1/areaT_global) [m-2] + ! These variables are global sums that are useful for 1-d diagnostics. + real :: areaT_global !< Global sum of h-cell area [L2 ~> m2] + real :: IareaT_global !< Global sum of inverse h-cell area (1/areaT_global) [L-2 ~> m-2] ! These parameters are run-time parameters that are used during some ! initialization routines (but not all) - real :: south_lat !< The latitude (or y-coordinate) of the first v-line - real :: west_lon !< The longitude (or x-coordinate) of the first u-line - real :: len_lat !< The latitudinal (or y-coord) extent of physical domain - real :: len_lon !< The longitudinal (or x-coord) extent of physical domain - real :: Rad_Earth !< The radius of the planet [m] + real :: grid_unit_to_L !< A factor that converts a the geoLat and geoLon variables and related + !! variables like len_lat and len_lon into rescaled horizontal distance + !! units on a Cartesian grid, in [L km ~> 1000] or [L m-1 ~> 1] or + !! is 0 for a non-Cartesian grid. + real :: south_lat !< The latitude (or y-coordinate) of the first v-line [degrees_N] or [km] or [m] + real :: west_lon !< The longitude (or x-coordinate) of the first u-line [degrees_E] or [km] or [m] + real :: len_lat !< The latitudinal (or y-coord) extent of physical domain [degrees_N] or [km] or [m] + real :: len_lon !< The longitudinal (or x-coord) extent of physical domain [degrees_E] or [km] or [m] real :: Rad_Earth_L !< The radius of the planet in rescaled units [L ~> m] real :: max_depth !< The maximum depth of the ocean [Z ~> m] end type dyn_horgrid_type @@ -229,6 +255,7 @@ subroutine create_dyn_horgrid(G, HI, bathymetry_at_vel) allocate(G%dxBu(IsdB:IedB,JsdB:JedB), source=0.0) allocate(G%IdxT(isd:ied,jsd:jed), source=0.0) allocate(G%IdxCu(IsdB:IedB,jsd:jed), source=0.0) + allocate(G%IdxCu_OBCmask(IsdB:IedB,jsd:jed), source=0.0) allocate(G%IdxCv(isd:ied,JsdB:JedB), source=0.0) allocate(G%IdxBu(IsdB:IedB,JsdB:JedB), source=0.0) @@ -239,6 +266,7 @@ subroutine create_dyn_horgrid(G, HI, bathymetry_at_vel) allocate(G%IdyT(isd:ied,jsd:jed), source=0.0) allocate(G%IdyCu(IsdB:IedB,jsd:jed), source=0.0) allocate(G%IdyCv(isd:ied,JsdB:JedB), source=0.0) + allocate(G%IdyCv_OBCmask(isd:ied,JsdB:JedB), source=0.0) allocate(G%IdyBu(IsdB:IedB,JsdB:JedB), source=0.0) allocate(G%areaT(isd:ied,jsd:jed), source=0.0) @@ -250,6 +278,8 @@ subroutine create_dyn_horgrid(G, HI, bathymetry_at_vel) allocate(G%mask2dCu(IsdB:IedB,jsd:jed), source=0.0) allocate(G%mask2dCv(isd:ied,JsdB:JedB), source=0.0) allocate(G%mask2dBu(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(G%OBCmaskCu(IsdB:IedB,jsd:jed), source=0.0) + allocate(G%OBCmaskCv(isd:ied,JsdB:JedB), source=0.0) allocate(G%geoLatT(isd:ied,jsd:jed), source=0.0) allocate(G%geoLatCu(IsdB:IedB,jsd:jed), source=0.0) allocate(G%geoLatCv(isd:ied,JsdB:JedB), source=0.0) @@ -275,9 +305,10 @@ subroutine create_dyn_horgrid(G, HI, bathymetry_at_vel) allocate(G%porous_DmaxV(isd:ied,JsdB:JedB), source=0.0) allocate(G%porous_DavgV(isd:ied,JsdB:JedB), source=0.0) - allocate(G%bathyT(isd:ied, jsd:jed), source=0.0) + allocate(G%meanSL(isd:ied, jsd:jed), source=0.0) allocate(G%CoriolisBu(IsdB:IedB, JsdB:JedB), source=0.0) + allocate(G%Coriolis2Bu(IsdB:IedB, JsdB:JedB), source=0.0) allocate(G%dF_dx(isd:ied, jsd:jed), source=0.0) allocate(G%dF_dy(isd:ied, jsd:jed), source=0.0) @@ -311,15 +342,13 @@ subroutine rotate_dyn_horgrid(G_in, G, US, turns) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: turns !< Number of quarter turns - integer :: jsc, jec, jscB, jecB - integer :: qturn - ! Center point call rotate_array(G_in%geoLonT, turns, G%geoLonT) call rotate_array(G_in%geoLatT, turns, G%geoLatT) call rotate_array_pair(G_in%dxT, G_in%dyT, turns, G%dxT, G%dyT) call rotate_array(G_in%areaT, turns, G%areaT) call rotate_array(G_in%bathyT, turns, G%bathyT) + call rotate_array(G_in%meanSL, turns, G%meanSL) call rotate_array_pair(G_in%df_dx, G_in%df_dy, turns, G%df_dx, G%df_dy) call rotate_array(G_in%sin_rot, turns, G%sin_rot) @@ -334,6 +363,7 @@ subroutine rotate_dyn_horgrid(G_in, G, US, turns) call rotate_array_pair(G_in%dx_Cv, G_in%dy_Cu, turns, G%dx_Cv, G%dy_Cu) call rotate_array_pair(G_in%mask2dCu, G_in%mask2dCv, turns, G%mask2dCu, G%mask2dCv) + call rotate_array_pair(G_in%OBCmaskCu, G_in%OBCmaskCv, turns, G%OBCmaskCu, G%OBCmaskCv) call rotate_array_pair(G_in%areaCu, G_in%areaCv, turns, G%areaCu, G%areaCv) call rotate_array_pair(G_in%IareaCu, G_in%IareaCv, turns, G%IareaCu, G%IareaCv) @@ -351,6 +381,7 @@ subroutine rotate_dyn_horgrid(G_in, G, US, turns) call rotate_array_pair(G_in%dxBu, G_in%dyBu, turns, G%dxBu, G%dyBu) call rotate_array(G_in%areaBu, turns, G%areaBu) call rotate_array(G_in%CoriolisBu, turns, G%CoriolisBu) + call rotate_array(G_in%Coriolis2Bu, turns, G%Coriolis2Bu) call rotate_array(G_in%mask2dBu, turns, G%mask2dBu) ! Topography at the cell faces @@ -380,15 +411,17 @@ subroutine rotate_dyn_horgrid(G_in, G, US, turns) G%x_axis_units = G_in%y_axis_units G%y_axis_units = G_in%x_axis_units + G%x_ax_unit_short = G_in%y_ax_unit_short + G%y_ax_unit_short = G_in%x_ax_unit_short G%south_lat = G_in%south_lat G%west_lon = G_in%west_lon G%len_lat = G_in%len_lat G%len_lon = G_in%len_lon ! Rotation-invariant fields + G%grid_unit_to_L = G_in%grid_unit_to_L G%areaT_global = G_in%areaT_global G%IareaT_global = G_in%IareaT_global - G%Rad_Earth = G_in%Rad_Earth G%Rad_Earth_L = G_in%Rad_Earth_L G%max_depth = G_in%max_depth @@ -400,10 +433,10 @@ end subroutine rotate_dyn_horgrid !! grid, both rescaling the depths and recording the new internal depth units. subroutine rescale_dyn_horgrid_bathymetry(G, m_in_new_units) type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type - real, intent(in) :: m_in_new_units !< The new internal representation of 1 m depth. + real, intent(in) :: m_in_new_units !< The new internal representation of 1 m depth [m Z-1 ~> 1] ! Local variables - real :: rescale + real :: rescale ! The inverse of m_in_new_units, used in rescaling bathymetry [Z m-1 ~> 1] integer :: i, j, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -418,6 +451,7 @@ subroutine rescale_dyn_horgrid_bathymetry(G, m_in_new_units) rescale = 1.0 / m_in_new_units do j=jsd,jed ; do i=isd,ied G%bathyT(i,j) = rescale*G%bathyT(i,j) + G%meanSL(i,j) = rescale*G%meanSL(i,j) enddo ; enddo if (G%bathymetry_at_vel) then ; do j=jsd,jed ; do I=IsdB,IedB G%Dblock_u(I,j) = rescale*G%Dblock_u(I,j) ; G%Dopen_u(I,j) = rescale*G%Dopen_u(I,j) @@ -454,6 +488,7 @@ subroutine set_derived_dyn_horgrid(G, US) if (G%dyCu(I,j) < 0.0) G%dyCu(I,j) = 0.0 G%IdxCu(I,j) = Adcroft_reciprocal(G%dxCu(I,j)) G%IdyCu(I,j) = Adcroft_reciprocal(G%dyCu(I,j)) + G%IdxCu_OBCmask(I,j) = G%OBCmaskCu(I,j) * G%IdxCu(I,j) ! This may be reset when the masks are set. enddo ; enddo do J=JsdB,JedB ; do i=isd,ied @@ -461,6 +496,7 @@ subroutine set_derived_dyn_horgrid(G, US) if (G%dyCv(i,J) < 0.0) G%dyCv(i,J) = 0.0 G%IdxCv(i,J) = Adcroft_reciprocal(G%dxCv(i,J)) G%IdyCv(i,J) = Adcroft_reciprocal(G%dyCv(i,J)) + G%IdyCv_OBCmask(i,J) = G%OBCmaskCv(i,J) * G%IdyCv(i,J) ! This may be reset when the masks are set. enddo ; enddo do J=JsdB,JedB ; do I=IsdB,IedB @@ -478,8 +514,8 @@ end subroutine set_derived_dyn_horgrid !> Adcroft_reciprocal(x) = 1/x for |x|>0 or 0 for x=0. function Adcroft_reciprocal(val) result(I_val) - real, intent(in) :: val !< The value being inverted. - real :: I_val !< The Adcroft reciprocal of val. + real, intent(in) :: val !< The value being inverted in arbitrary units [A ~> a] + real :: I_val !< The Adcroft reciprocal of val [A-1 ~> a-1]. I_val = 0.0 ; if (val /= 0.0) I_val = 1.0/val end function Adcroft_reciprocal @@ -502,10 +538,11 @@ subroutine destroy_dyn_horgrid(G) deallocate(G%areaT) ; deallocate(G%IareaT) deallocate(G%areaBu) ; deallocate(G%IareaBu) deallocate(G%areaCu) ; deallocate(G%IareaCu) - deallocate(G%areaCv) ; deallocate(G%IareaCv) + deallocate(G%areaCv) ; deallocate(G%IareaCv) - deallocate(G%mask2dT) ; deallocate(G%mask2dCu) - deallocate(G%mask2dCv) ; deallocate(G%mask2dBu) + deallocate(G%mask2dT) ; deallocate(G%mask2dCu) ; deallocate(G%OBCmaskCu) + deallocate(G%mask2dCv) ; deallocate(G%OBCmaskCv) ; deallocate(G%mask2dBu) + deallocate(G%IdxCu_OBCmask) ; deallocate(G%IdyCv_OBCmask) deallocate(G%geoLatT) ; deallocate(G%geoLatCu) deallocate(G%geoLatCv) ; deallocate(G%geoLatBu) @@ -517,9 +554,10 @@ subroutine destroy_dyn_horgrid(G) deallocate(G%porous_DminU) ; deallocate(G%porous_DmaxU) ; deallocate(G%porous_DavgU) deallocate(G%porous_DminV) ; deallocate(G%porous_DmaxV) ; deallocate(G%porous_DavgV) - deallocate(G%bathyT) ; deallocate(G%CoriolisBu) - deallocate(G%dF_dx) ; deallocate(G%dF_dy) - deallocate(G%sin_rot) ; deallocate(G%cos_rot) + deallocate(G%bathyT) ; deallocate(G%meanSL) + deallocate(G%CoriolisBu) ; deallocate(G%Coriolis2Bu) + deallocate(G%dF_dx) ; deallocate(G%dF_dy) + deallocate(G%sin_rot) ; deallocate(G%cos_rot) if (allocated(G%Dblock_u)) deallocate(G%Dblock_u) if (allocated(G%Dopen_u)) deallocate(G%Dopen_u) diff --git a/src/framework/MOM_ensemble_manager.F90 b/src/framework/MOM_ensemble_manager.F90 index e431212524..62fb32a9dd 100644 --- a/src/framework/MOM_ensemble_manager.F90 +++ b/src/framework/MOM_ensemble_manager.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Manages ensemble member layout information module MOM_ensemble_manager -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_ensemble_manager_infra, only : ensemble_manager_init use MOM_ensemble_manager_infra, only : ensemble_pelist_setup use MOM_ensemble_manager_infra, only : get_ensemble_id diff --git a/src/framework/MOM_error_handler.F90 b/src/framework/MOM_error_handler.F90 index 6051fed08b..eb097b32f0 100644 --- a/src/framework/MOM_error_handler.F90 +++ b/src/framework/MOM_error_handler.F90 @@ -1,9 +1,21 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Routines for error handling and I/O management module MOM_error_handler -! This file is part of MOM6. See LICENSE.md for the license. - +use MOM_coms_infra, only : num_PEs use MOM_error_infra, only : MOM_err, is_root_pe, stdlog, stdout, NOTE, WARNING, FATAL +use posix, only : getpid, getppid, handler_interface +use posix, only : signal, kill, SIGUSR1 +use posix, only : sigjmp_buf, siglongjmp +use posix, only : sleep + +! MOM_error_infra does not provide stderr . We only use stderr in this module +! *IF* FMS has not been initialized. Further, stderr is only used internally and +! not made public. Other modules should obtain stderr from MOM_io. +use iso_fortran_env, only : stderr=>error_unit implicit none ; private @@ -15,6 +27,7 @@ module MOM_error_handler public :: is_root_pe, stdlog, stdout !> Integer parameters encoding the severity of an error message public :: NOTE, WARNING, FATAL +public :: disable_fatal_errors, enable_fatal_errors, set_skip_mpi integer :: verbosity = 6 !< Verbosity level: @@ -40,6 +53,24 @@ module MOM_error_handler integer :: callTreeIndentLevel = 0 !< The level of calling within the call tree +! Error handling + +logical :: ignore_fatal = .false. + !< If true, ignore FATAL errors and jump to a prior state. +integer, parameter :: err_signal = SIGUSR1 + !< Signal used to trigger the error handler +integer :: err_pid + !< Process ID for the error handler (either self or MPI launcher) +procedure(handler_interface), pointer :: prior_handler + !< The default signal handler used before signal() setup (usually SIG_DFT) +type(sigjmp_buf) :: prior_env + !< Buffer containing the program state to be recovered by longjmp +logical :: skip_mpi_dep = .false. + !< If true, bypass any calls that require FMS (MPI) to have been initialized. + !! Use s/r set_skip_mpi() to change this flag. By default, set_skip_mpi() does not + !! need to be called and this flag is false so that FMS (and MPI) should be + !! initialized. + contains !> This provides a convenient interface for writing an informative comment, depending @@ -53,14 +84,67 @@ subroutine MOM_mesg(message, verb, all_print) integer :: verb_msg logical :: write_msg - write_msg = is_root_pe() + if (skip_mpi_dep) then + write_msg = .true. + else + write_msg = is_root_pe() + endif if (present(all_print)) write_msg = write_msg .or. all_print verb_msg = 2 ; if (present(verb)) verb_msg = verb - if (write_msg .and. (verbosity >= verb_msg)) call MOM_err(NOTE, message) + if (write_msg .and. (verbosity >= verb_msg)) call loc_MOM_err(NOTE, message) end subroutine MOM_mesg +!> Enable error handling, replacing FATALs in MOM_error with err_handler. +subroutine disable_fatal_errors(env) + type(sigjmp_buf), intent(in) :: env + !> Process recovery state after FATAL errors + + integer :: sig + + ignore_fatal = .true. + + ! TODO: Only need to call this once; move to an init() function? + if (num_PEs() > 1) then + err_pid = getppid() + else + err_pid = getpid() + endif + + ! Store the program state + prior_env = env + + ! Setup the signal handler + ! NOTE: Passing parameters to signal() in GFortran causes a compiler error. + ! We avert this by copying err_signal to a variable. + sig = err_signal + ! TODO: Use sigaction() in place of signal() + prior_handler => signal(sig, err_handler) +end subroutine disable_fatal_errors + +!> Disable the error handler and abort on FATAL +subroutine enable_fatal_errors() + integer :: sig + procedure(handler_interface), pointer :: dummy + + ignore_fatal = .false. + err_pid = -1 ! NOTE: 0 might be safer, since it's unusable. + + ! Restore the original signal handler (usually SIG_DFT). + sig = err_signal + ! NOTE: As above, we copy the err_signal to accommodate GFortran. + dummy => signal(sig, prior_handler) +end subroutine enable_fatal_errors + +!> Enable/disable skipping MPI dependent behaviors +subroutine set_skip_mpi(skip) + logical, intent(in) :: skip !< State to assign + + skip_mpi_dep = skip + +end subroutine set_skip_mpi + !> This provides a convenient interface for writing an error message !! with run-time filter based on a verbosity and the severity of the error. subroutine MOM_error(level, message, all_print) @@ -68,25 +152,58 @@ subroutine MOM_error(level, message, all_print) character(len=*), intent(in) :: message !< A message to write out logical, optional, intent(in) :: all_print !< If present and true, any PEs are !! able to write this message. - ! This provides a convenient interface for writing an error message - ! with run-time filter based on a verbosity. logical :: write_msg + integer :: rc - write_msg = is_root_pe() + if (skip_mpi_dep) then + write_msg = .true. + else + write_msg = is_root_pe() + endif if (present(all_print)) write_msg = write_msg .or. all_print select case (level) case (NOTE) - if (write_msg.and.verbosity>=2) call MOM_err(NOTE, message) + if (write_msg.and.verbosity>=2) call loc_MOM_err(NOTE, message) case (WARNING) - if (write_msg.and.verbosity>=1) call MOM_err(WARNING, message) + if (write_msg.and.verbosity>=1) call loc_MOM_err(WARNING, message) case (FATAL) - if (verbosity>=0) call MOM_err(FATAL, message) + if (ignore_fatal) then + print *, "(FATAL): " // message + rc = kill(err_pid, err_signal) + ! NOTE: MPI launchers require, in their words, "a few seconds" to + ! propagate the signal to the nodes, so we wait here to avoid + ! anomalous FATAL calls. + ! In practice, the signal will take control before sleep() completes. + rc = sleep(3) + endif + if (verbosity>=0) call loc_MOM_err(FATAL, message) case default - call MOM_err(level, message) + call loc_MOM_err(level, message) end select end subroutine MOM_error +!> A private routine through which all error/warning/note messages are written +!! by this module. +subroutine loc_MOM_err(level, message) + integer, intent(in) :: level !< The severity level of this message + character(len=*), intent(in) :: message !< A message to write out + + if (.not. skip_mpi_dep) then + call MOM_err(level, message) + else + ! FMS (and therefore MPI) have not been initialized + write(stdout(),'(a)') trim(message) ! Send message to stdout + select case (level) + case (WARNING) + write(stderr,'("WARNING ",a)') trim(message) ! Additionally send message to stderr + case (FATAL) + write(stderr,'("ERROR: ",a)') trim(message) ! Additionally send message to stderr + end select + endif + +end subroutine loc_MOM_err + !> This subroutine sets the level of verbosity filtering MOM error messages subroutine MOM_set_verbosity(verb) integer, intent(in) :: verb !< A level of verbosity to set @@ -132,10 +249,10 @@ subroutine callTree_enter(mesg,n) nAsString = '' if (present(n)) then write(nAsString(1:8),'(i8)') n - call MOM_err(NOTE, 'callTree: '// & + call loc_MOM_err(NOTE, 'callTree: '// & repeat(' ',callTreeIndentLevel-1)//'loop '//trim(mesg)//trim(nAsString)) else - call MOM_err(NOTE, 'callTree: '// & + call loc_MOM_err(NOTE, 'callTree: '// & repeat(' ',callTreeIndentLevel-1)//'---> '//trim(mesg)) endif endif @@ -147,7 +264,7 @@ subroutine callTree_leave(mesg) if (callTreeIndentLevel<1) write(0,*) 'callTree_leave: error callTreeIndentLevel=',callTreeIndentLevel,trim(mesg) callTreeIndentLevel = callTreeIndentLevel - 1 if (verbosity<6) return - if (is_root_pe()) call MOM_err(NOTE, 'callTree: '// & + if (is_root_pe()) call loc_MOM_err(NOTE, 'callTree: '// & repeat(' ',callTreeIndentLevel)//'<--- '//trim(mesg)) end subroutine callTree_leave @@ -163,10 +280,10 @@ subroutine callTree_waypoint(mesg,n) nAsString = '' if (present(n)) then write(nAsString(1:8),'(i8)') n - call MOM_err(NOTE, 'callTree: '// & + call loc_MOM_err(NOTE, 'callTree: '// & repeat(' ',callTreeIndentLevel)//'loop '//trim(mesg)//trim(nAsString)) else - call MOM_err(NOTE, 'callTree: '// & + call loc_MOM_err(NOTE, 'callTree: '// & repeat(' ',callTreeIndentLevel)//'o '//trim(mesg)) endif endif @@ -180,7 +297,13 @@ subroutine assert(logical_arg, msg) if (.not. logical_arg) then call MOM_error(FATAL, msg) endif - end subroutine assert +!> Restore the process state via longjmp after receiving a signal. +subroutine err_handler(sig) + integer, intent(in) :: sig + !< Signal passed to the handler (unused) + call siglongjmp(prior_env, 1) +end subroutine + end module MOM_error_handler diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 07e9138594..501629491a 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -1,13 +1,16 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> The MOM6 facility to parse input files for runtime parameters module MOM_file_parser -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_coms, only : root_PE, broadcast -use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg +use MOM_coms, only : any_across_PEs +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, assert use MOM_error_handler, only : is_root_pe, stdlog, stdout use MOM_time_manager, only : get_time, time_type, get_ticks_per_second -use MOM_time_manager, only : set_date, get_date, real_to_time, operator(-), set_time +use MOM_time_manager, only : set_date, get_date, real_to_time, operator(-), operator(==), set_time use MOM_document, only : doc_param, doc_module, doc_init, doc_end, doc_type use MOM_document, only : doc_openBlock, doc_closeBlock use MOM_string_functions, only : left_int, left_ints, slasher @@ -15,13 +18,14 @@ module MOM_file_parser implicit none ; private +! These are hard-coded limits that are used in the following code. They should be set +! generously enough not to impose any significant limitations. integer, parameter, public :: MAX_PARAM_FILES = 5 !< Maximum number of parameter files. -integer, parameter :: INPUT_STR_LENGTH = 320 !< Maximum line length in parameter file. -integer, parameter :: FILENAME_LENGTH = 200 !< Maximum number of characters in file names. +integer, parameter :: INPUT_STR_LENGTH = 1024 !< Maximum line length in parameter file. Lines that + !! are combined by ending in '\' or '&' can exceed + !! this limit after merging. +integer, parameter :: FILENAME_LENGTH = 200 !< Maximum number of characters in file names. -! The all_PEs_read option should be eliminated with post-riga shared code. -logical :: all_PEs_read = .false. !< If true, all PEs read the input files - !! TODO: Eliminate this parameter !>@{ Default values for parameters logical, parameter :: report_unused_default = .true. @@ -31,23 +35,31 @@ module MOM_file_parser logical, parameter :: minimal_doc_default = .true. !>@} + +!> A simple type to allow lines in an array to be allocated with variable sizes. +type, private :: file_line_type ; private + character(len=:), allocatable :: line !< An allocatable line with content +end type file_line_type + !> The valid lines extracted from an input parameter file without comments type, private :: file_data_type ; private integer :: num_lines = 0 !< The number of lines in this type - character(len=INPUT_STR_LENGTH), pointer, dimension(:) :: line => NULL() !< The line content - logical, pointer, dimension(:) :: line_used => NULL() !< If true, the line has been read + type(file_line_type), allocatable, dimension(:) :: fln !< Lines with the input content. + logical, pointer, dimension(:) :: line_used => NULL() !< If true, the line has been read end type file_data_type !> A link in the list of variables that have already had override warnings issued -type :: link_parameter ; private +type, private :: link_parameter ; private type(link_parameter), pointer :: next => NULL() !< Facilitates linked list character(len=80) :: name !< Parameter name logical :: hasIssuedOverrideWarning = .false. !< Has a default value end type link_parameter !> Specify the active parameter block -type :: parameter_block ; private +type, private :: parameter_block ; private character(len=240) :: name = '' !< The active parameter block name + logical :: log_access = .true. + !< Log the entry and exit of the block (but not its contents) end type parameter_block !> A structure that can be parsed to read and document run-time parameters. @@ -68,6 +80,9 @@ module MOM_file_parser logical :: log_to_stdout = log_to_stdout_default !< If true, all log !! messages are also sent to stdout. logical :: log_open = .false. !< True if the log file has been opened. + integer :: max_line_len = 4 !< The maximum number of characters in the lines + !! in any of the files in this param_file_type after + !! any continued lines have been combined. integer :: stdout !< The unit number from stdout(). integer :: stdlog !< The unit number from stdlog(). character(len=240) :: doc_file !< A file where all run-time parameters, their @@ -112,8 +127,8 @@ module MOM_file_parser contains -!> Make the contents of a parameter input file availalble in a param_file_type -subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) +!> Make the contents of a parameter input file available in a param_file_type +subroutine open_param_file(filename, CS, checkable, component, doc_file_dir, ensemble_num) character(len=*), intent(in) :: filename !< An input file name, optionally with the full path type(param_file_type), intent(inout) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters @@ -123,11 +138,13 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) !! to generate parameter documentation file names; the default is"MOM" character(len=*), optional, intent(in) :: doc_file_dir !< An optional directory in which to write out !! the documentation files. The default is effectively './'. + integer, optional, intent(in) :: ensemble_num !< ensemble number to be appended to _doc filenames (optional) ! Local variables - logical :: file_exists, unit_in_use, Netcdf_file, may_check + logical :: file_exists, Netcdf_file, may_check, reopened_file integer :: ios, iounit, strlen, i character(len=240) :: doc_path + character(len=5) :: ensemble_suffix type(parameter_block), pointer :: block => NULL() may_check = .true. ; if (present(checkable)) may_check = checkable @@ -140,30 +157,35 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) ! Check that this file has not already been opened if (CS%nfiles > 0) then - inquire(file=trim(filename), number=iounit) - if (iounit /= -1) then - do i = 1, CS%nfiles - if (CS%iounit(i) == iounit) then - if (trim(CS%filename(1)) /= trim(filename)) then - call MOM_error(FATAL, & - "open_param_file: internal inconsistency! "//trim(filename)// & - " is registered as open but has the wrong unit number!") - else + reopened_file = .false. + + if (is_root_pe()) then + inquire(file=trim(filename), number=iounit) + if (iounit /= -1) then + do i = 1, CS%nfiles + if (CS%iounit(i) == iounit) then + call assert(trim(CS%filename(1)) == trim(filename), & + "open_param_file: internal inconsistency! "//trim(filename)// & + " is registered as open but has the wrong unit number!") call MOM_error(WARNING, & - "open_param_file: file "//trim(filename)// & - " has already been opened. This should NOT happen!"// & - " Did you specify the same file twice in a namelist?") - return - endif ! filenames - endif ! unit numbers - enddo ! i + "open_param_file: file "//trim(filename)// & + " has already been opened. This should NOT happen!"// & + " Did you specify the same file twice in a namelist?") + reopened_file = .true. + endif ! unit numbers + enddo ! i + endif endif + + if (any_across_PEs(reopened_file)) return endif ! Check that the file exists to readstdlog - inquire(file=trim(filename), exist=file_exists) - if (.not.file_exists) call MOM_error(FATAL, & - "open_param_file: Input file "// trim(filename)//" does not exist.") + if (is_root_pe()) then + inquire(file=trim(filename), exist=file_exists) + if (.not.file_exists) call MOM_error(FATAL, & + "open_param_file: Input file '"// trim(filename)//"' does not exist.") + endif Netcdf_file = .false. if (strlen > 3) then @@ -173,19 +195,10 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) if (Netcdf_file) & call MOM_error(FATAL,"open_param_file: NetCDF files are not yet supported.") - if (all_PEs_read .or. is_root_pe()) then - ! Find an unused unit number. - do iounit=10,512 - INQUIRE(iounit,OPENED=unit_in_use) ; if (.not.unit_in_use) exit - enddo - if (iounit >= 512) call MOM_error(FATAL, & - "open_param_file: No unused file unit could be found.") - - ! Open the parameter file. - open(iounit, file=trim(filename), access='SEQUENTIAL', & + if (is_root_pe()) then + open(newunit=iounit, file=trim(filename), access='SEQUENTIAL', & form='FORMATTED', action='READ', position='REWIND', iostat=ios) - if (ios /= 0) call MOM_error(FATAL, "open_param_file: Error opening "// & - trim(filename)) + if (ios /= 0) call MOM_error(FATAL, "open_param_file: Error opening '"//trim(filename)//"'.") else iounit = 1 endif @@ -200,15 +213,21 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) if (associated(CS%blockName)) deallocate(CS%blockName) allocate(block) ; block%name = '' ; CS%blockName => block - call MOM_mesg("open_param_file: "// trim(filename)// & - " has been opened successfully.", 5) + call MOM_mesg("open_param_file: "// trim(filename)//" has been opened successfully.", 5) call populate_param_data(iounit, filename, CS%param_data(i)) + ! Increment the maximum line length, but always report values in blocks of 4 characters. + CS%max_line_len = max(CS%max_line_len, 4 + 4*(max_input_line_length(CS, i) - 1) / 4) call read_param(CS,"SEND_LOG_TO_STDOUT",CS%log_to_stdout) call read_param(CS,"REPORT_UNUSED_PARAMS",CS%report_unused) call read_param(CS,"FATAL_UNUSED_PARAMS",CS%unused_params_fatal) CS%doc_file = "MOM_parameter_doc" + if (present(ensemble_num)) then + ! append instance suffix to doc_file + write(ensemble_suffix,'(A,I0.4)') '_', ensemble_num + CS%doc_file = trim(CS%doc_file)//ensemble_suffix + endif if (present(component)) CS%doc_file = trim(component)//"_parameter_doc" call read_param(CS,"DOCUMENT_FILE", CS%doc_file) if (.not.may_check) then @@ -257,17 +276,19 @@ subroutine close_param_file(CS, quiet_close, component) if (present(quiet_close)) then ; if (quiet_close) then do i = 1, CS%nfiles - if (all_PEs_read .or. is_root_pe()) close(CS%iounit(i)) + if (is_root_pe()) close(CS%iounit(i)) call MOM_mesg("close_param_file: "// trim(CS%filename(i))// & " has been closed successfully.", 5) CS%iounit(i) = -1 CS%filename(i) = '' CS%NetCDF_file(i) = .false. - deallocate (CS%param_data(i)%line) + do n=1,CS%param_data(i)%num_lines ; deallocate(CS%param_data(i)%fln(n)%line) ; enddo + deallocate (CS%param_data(i)%fln) deallocate (CS%param_data(i)%line_used) enddo CS%log_open = .false. call doc_end(CS%doc) + deallocate(CS%doc) return endif ; endif @@ -320,18 +341,18 @@ subroutine close_param_file(CS, quiet_close, component) num_unused = num_unused + 1 if (CS%report_unused) & call MOM_error(WARNING, "Unused line in "//trim(CS%filename(i))// & - " : "//trim(CS%param_data(i)%line(n))) + " : "//trim(CS%param_data(i)%fln(n)%line)) endif enddo endif - if (all_PEs_read .or. is_root_pe()) close(CS%iounit(i)) - call MOM_mesg("close_param_file: "// trim(CS%filename(i))// & - " has been closed successfully.", 5) + if (is_root_pe()) close(CS%iounit(i)) + call MOM_mesg("close_param_file: "// trim(CS%filename(i))//" has been closed successfully.", 5) CS%iounit(i) = -1 CS%filename(i) = '' CS%NetCDF_file(i) = .false. - deallocate (CS%param_data(i)%line) + do n=1,CS%param_data(i)%num_lines ; deallocate(CS%param_data(i)%fln(n)%line) ; enddo + deallocate (CS%param_data(i)%fln) deallocate (CS%param_data(i)%line_used) enddo deallocate(CS%blockName) @@ -341,7 +362,7 @@ subroutine close_param_file(CS, quiet_close, component) CS%log_open = .false. call doc_end(CS%doc) - + deallocate(CS%doc) end subroutine close_param_file !> Read the contents of a parameter input file, and store the contents in a @@ -354,29 +375,32 @@ subroutine populate_param_data(iounit, filename, param_data) ! Local variables character(len=INPUT_STR_LENGTH) :: line - integer :: num_lines + character(len=1), allocatable, dimension(:) :: char_buf + integer, allocatable, dimension(:) :: line_len ! The trimmed length of each processed input line + integer :: n, num_lines, total_chars, ch, rsc, llen, int_buf(2) logical :: inMultiLineComment ! Find the number of keyword lines in a parameter file - ! Allocate the space to hold the lines in param_data%line - ! Populate param_data%line with the keyword lines from parameter file - - if (iounit <= 0) return - - if (all_PEs_read .or. is_root_pe()) then + if (is_root_pe()) then ! rewind the parameter file rewind(iounit) ! count the number of valid entries in the parameter file num_lines = 0 + total_chars = 0 inMultiLineComment = .false. do while(.true.) - read(iounit, '(a)', end=8, err=9) line + read(iounit, '(a)', end=8) line line = replaceTabs(line) if (inMultiLineComment) then if (closeMultiLineComment(line)) inMultiLineComment=.false. else - if (lastNonCommentNonBlank(line)>0) num_lines = num_lines + 1 + if (lastNonCommentNonBlank(line)>0) then + line = removeComments(line) + line = simplifyWhiteSpace(line(:len_trim(line))) + num_lines = num_lines + 1 + total_chars = total_chars + len_trim(line) + endif if (openMultiLineComment(line)) inMultiLineComment=.true. endif enddo ! while (.true.) @@ -386,60 +410,76 @@ subroutine populate_param_data(iounit, filename, param_data) call MOM_error(FATAL, 'MOM_file_parser : A C-style multi-line comment '// & '(/* ... */) was not closed before the end of '//trim(filename)) - ! allocate space to hold contents of the parameter file - param_data%num_lines = num_lines + + int_buf(1) = num_lines + int_buf(2) = total_chars endif ! (is_root_pe()) ! Broadcast the number of valid entries in parameter file - if (.not. all_PEs_read) then - call broadcast(param_data%num_lines, root_pe()) - endif + call broadcast(int_buf, 2, root_pe()) + num_lines = int_buf(1) + total_chars = int_buf(2) ! Set up the space for storing the actual lines. - num_lines = param_data%num_lines - allocate (param_data%line(num_lines)) - allocate (param_data%line_used(num_lines)) - param_data%line(:) = ' ' - param_data%line_used(:) = .false. + param_data%num_lines = num_lines + allocate (line_len(num_lines), source=0) + allocate (char_buf(total_chars), source=" ") ! Read the actual lines. - if (all_PEs_read .or. is_root_pe()) then + if (is_root_pe()) then ! rewind the parameter file rewind(iounit) - ! Populate param_data%line + ! Populate param_data%fln%line num_lines = 0 + rsc = 0 do while(.true.) - read(iounit, '(a)', end=18, err=9) line + read(iounit, '(a)', end=18) line line = replaceTabs(line) if (inMultiLineComment) then if (closeMultiLineComment(line)) inMultiLineComment=.false. else if (lastNonCommentNonBlank(line)>0) then line = removeComments(line) + if ((len_trim(line) > 1000) .and. is_root_PE()) then + call MOM_error(WARNING, "MOM_file_parser: Consider using continuation to split up "//& + "the excessivley long parameter input line "//trim(line)) + endif line = simplifyWhiteSpace(line(:len_trim(line))) num_lines = num_lines + 1 - param_data%line(num_lines) = line + llen = len_trim(line) + line_len(num_lines) = llen + do ch=1,llen ; char_buf(rsc+ch)(1:1) = line(ch:ch) ; enddo + rsc = rsc + llen endif if (openMultiLineComment(line)) inMultiLineComment=.true. endif enddo ! while (.true.) 18 continue ! get here when read() reaches EOF - if (num_lines /= param_data%num_lines) & - call MOM_error(FATAL, 'MOM_file_parser : Found different number of '// & - 'valid lines on second reading of '//trim(filename)) + call assert(num_lines == param_data%num_lines, & + 'MOM_file_parser: Found different number of valid lines on second ' & + // 'reading of '//trim(filename)) endif ! (is_root_pe()) - ! Broadcast the populated array param_data%line - if (.not. all_PEs_read) then - call broadcast(param_data%line, INPUT_STR_LENGTH, root_pe()) - endif + ! Broadcast the populated arrays line_len and char_buf + call broadcast(line_len, num_lines, root_pe()) + call broadcast(char_buf(1:total_chars), 1, root_pe()) - return + ! Allocate space to hold contents of the parameter file, including the lines in param_data%fln + allocate(param_data%fln(num_lines)) + allocate(param_data%line_used(num_lines)) + param_data%line_used(:) = .false. + ! Populate param_data%fln%line with the keyword lines from parameter file + rsc = 0 + do n=1,num_lines + line(1:INPUT_STR_LENGTH) = " " + do ch=1,line_len(n) ; line(ch:ch) = char_buf(rsc+ch)(1:1) ; enddo + param_data%fln(n)%line = trim(line) + rsc = rsc + line_len(n) + enddo -9 call MOM_error(FATAL, "MOM_file_parser : "//& - "Error while reading file "//trim(filename)) + deallocate(char_buf) ; deallocate(line_len) end subroutine populate_param_data @@ -524,18 +564,18 @@ function removeComments(string) removeComments(:last)=adjustl(string(:last)) ! Copy only the non-comment part of string end function removeComments -!> Constructs a string with all repeated whitespace replaced with single blanks +!> Constructs a string with all repeated white space replaced with single blanks !! and insert white space where it helps delineate tokens (e.g. around =) function simplifyWhiteSpace(string) - character(len=*), intent(in) :: string !< A string to modify to simpify white space + character(len=*), intent(in) :: string !< A string to modify to simplify white space character(len=len(string)+16) :: simplifyWhiteSpace ! Local variables - integer :: i,j + integer :: i, j logical :: nonBlank = .false., insideString = .false. character(len=1) :: quoteChar=" " - nonBlank = .false.; insideString = .false. ! NOTE: For some reason this line is needed?? + nonBlank = .false. ; insideString = .false. ! NOTE: For some reason this line is needed?? i=0 simplifyWhiteSpace=repeat(" ",len(string)+16) do j=1,len_trim(string) @@ -545,7 +585,7 @@ function simplifyWhiteSpace(string) if (string(j:j)==quoteChar) insideString=.false. ! End of string else ! The following is outside of string delimiters if (string(j:j)==" " .or. string(j:j)==achar(9)) then ! Space or tab - if (nonBlank) then ! Only copy a blank if the preceeding character was non-blank + if (nonBlank) then ! Only copy a blank if the preceding character was non-blank i=i+1 simplifyWhiteSpace(i:i)=" " ! Not string(j:j) so that tabs are replace by blanks nonBlank=.false. @@ -580,7 +620,7 @@ function simplifyWhiteSpace(string) end function simplifyWhiteSpace !> This subroutine reads the value of an integer model parameter from a parameter file. -subroutine read_param_int(CS, varname, value, fail_if_missing) +subroutine read_param_int(CS, varname, value, fail_if_missing, set) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read @@ -588,13 +628,16 @@ subroutine read_param_int(CS, varname, value, fail_if_missing) !! read from the parameter file logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file + logical, optional, intent(out) :: set !< If present, this indicates whether this parameter + !! has been found and successfully set in the input files. ! Local variables - character(len=INPUT_STR_LENGTH) :: value_string(1) + character(len=CS%max_line_len) :: value_string(1) logical :: found, defined call get_variable_line(CS, varname, found, defined, value_string) if (found .and. defined .and. (LEN_TRIM(value_string(1)) > 0)) then read(value_string(1),*,err = 1001) value + if (present(set)) set = .true. else if (present(fail_if_missing)) then ; if (fail_if_missing) then if (.not.found) then @@ -605,6 +648,7 @@ subroutine read_param_int(CS, varname, value, fail_if_missing) ' found but not set in input files.') endif endif ; endif + if (present(set)) set = .false. endif return 1001 call MOM_error(FATAL,'read_param_int: read error for integer variable '//trim(varname)// & @@ -612,7 +656,7 @@ subroutine read_param_int(CS, varname, value, fail_if_missing) end subroutine read_param_int !> This subroutine reads the values of an array of integer model parameters from a parameter file. -subroutine read_param_int_array(CS, varname, value, fail_if_missing) +subroutine read_param_int_array(CS, varname, value, fail_if_missing, set) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read @@ -620,12 +664,15 @@ subroutine read_param_int_array(CS, varname, value, fail_if_missing) !! read from the parameter file logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file + logical, optional, intent(out) :: set !< If present, this indicates whether this parameter + !! has been found and successfully set in the input files. ! Local variables - character(len=INPUT_STR_LENGTH) :: value_string(1) + character(len=CS%max_line_len) :: value_string(1) logical :: found, defined call get_variable_line(CS, varname, found, defined, value_string) if (found .and. defined .and. (LEN_TRIM(value_string(1)) > 0)) then + if (present(set)) set = .true. read(value_string(1),*,end=991,err=1002) value 991 return else @@ -638,6 +685,7 @@ subroutine read_param_int_array(CS, varname, value, fail_if_missing) ' found but not set in input files.') endif endif ; endif + if (present(set)) set = .false. endif return 1002 call MOM_error(FATAL,'read_param_int_array: read error for integer array '//trim(varname)// & @@ -645,7 +693,7 @@ subroutine read_param_int_array(CS, varname, value, fail_if_missing) end subroutine read_param_int_array !> This subroutine reads the value of a real model parameter from a parameter file. -subroutine read_param_real(CS, varname, value, fail_if_missing, scale) +subroutine read_param_real(CS, varname, value, fail_if_missing, scale, set) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read @@ -655,15 +703,18 @@ subroutine read_param_real(CS, varname, value, fail_if_missing, scale) !! if this variable is not found in the parameter file real, optional, intent(in) :: scale !< A scaling factor that the parameter is multiplied !! by before it is returned. + logical, optional, intent(out) :: set !< If present, this indicates whether this parameter + !! has been found and successfully set in the input files. ! Local variables - character(len=INPUT_STR_LENGTH) :: value_string(1) + character(len=CS%max_line_len) :: value_string(1) logical :: found, defined call get_variable_line(CS, varname, found, defined, value_string) if (found .and. defined .and. (LEN_TRIM(value_string(1)) > 0)) then read(value_string(1),*,err=1003) value if (present(scale)) value = scale*value + if (present(set)) set = .true. else if (present(fail_if_missing)) then ; if (fail_if_missing) then if (.not.found) then @@ -674,6 +725,7 @@ subroutine read_param_real(CS, varname, value, fail_if_missing, scale) ' found but not set in input files.') endif endif ; endif + if (present(set)) set = .false. endif return 1003 call MOM_error(FATAL,'read_param_real: read error for real variable '//trim(varname)// & @@ -681,7 +733,7 @@ subroutine read_param_real(CS, varname, value, fail_if_missing, scale) end subroutine read_param_real !> This subroutine reads the values of an array of real model parameters from a parameter file. -subroutine read_param_real_array(CS, varname, value, fail_if_missing, scale) +subroutine read_param_real_array(CS, varname, value, fail_if_missing, scale, set) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read @@ -691,17 +743,19 @@ subroutine read_param_real_array(CS, varname, value, fail_if_missing, scale) !! if this variable is not found in the parameter file real, optional, intent(in) :: scale !< A scaling factor that the parameter is multiplied !! by before it is returned. + logical, optional, intent(out) :: set !< If present, this indicates whether this parameter + !! has been found and successfully set in the input files. ! Local variables - character(len=INPUT_STR_LENGTH) :: value_string(1) - logical :: found, defined + character(len=CS%max_line_len) :: value_string(1) + logical :: found, defined call get_variable_line(CS, varname, found, defined, value_string) if (found .and. defined .and. (LEN_TRIM(value_string(1)) > 0)) then read(value_string(1),*,end=991,err=1004) value 991 continue if (present(scale)) value(:) = scale*value(:) - return + if (present(set)) set = .true. else if (present(fail_if_missing)) then ; if (fail_if_missing) then if (.not.found) then @@ -712,6 +766,7 @@ subroutine read_param_real_array(CS, varname, value, fail_if_missing, scale) ' found but not set in input files.') endif endif ; endif + if (present(set)) set = .false. endif return 1004 call MOM_error(FATAL,'read_param_real_array: read error for real array '//trim(varname)// & @@ -719,7 +774,7 @@ subroutine read_param_real_array(CS, varname, value, fail_if_missing, scale) end subroutine read_param_real_array !> This subroutine reads the value of a character string model parameter from a parameter file. -subroutine read_param_char(CS, varname, value, fail_if_missing) +subroutine read_param_char(CS, varname, value, fail_if_missing, set) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read @@ -727,22 +782,25 @@ subroutine read_param_char(CS, varname, value, fail_if_missing) !! read from the parameter file logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file + logical, optional, intent(out) :: set !< If present, this indicates whether this parameter + !! has been found and successfully set in the input files. ! Local variables - character(len=INPUT_STR_LENGTH) :: value_string(1) + character(len=CS%max_line_len) :: value_string(1) logical :: found, defined call get_variable_line(CS, varname, found, defined, value_string) if (found) then value = trim(strip_quotes(value_string(1))) elseif (present(fail_if_missing)) then ; if (fail_if_missing) then - call MOM_error(FATAL,'Unable to find variable '//trim(varname)// & - ' in any input files.') + call MOM_error(FATAL, 'Unable to find variable '//trim(varname)//' in any input files.') endif ; endif + if (present(set)) set = found + end subroutine read_param_char !> This subroutine reads the values of an array of character string model parameters from a parameter file. -subroutine read_param_char_array(CS, varname, value, fail_if_missing) +subroutine read_param_char_array(CS, varname, value, fail_if_missing, set) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read @@ -750,9 +808,11 @@ subroutine read_param_char_array(CS, varname, value, fail_if_missing) !! read from the parameter file logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file + logical, optional, intent(out) :: set !< If present, this indicates whether this parameter + !! has been found and successfully set in the input files. ! Local variables - character(len=INPUT_STR_LENGTH) :: value_string(1), loc_string + character(len=CS%max_line_len) :: value_string(1), loc_string logical :: found, defined integer :: i, i_out @@ -773,14 +833,15 @@ subroutine read_param_char_array(CS, varname, value, fail_if_missing) endif do i=i_out,SIZE(value) ; value(i) = " " ; enddo elseif (present(fail_if_missing)) then ; if (fail_if_missing) then - call MOM_error(FATAL,'Unable to find variable '//trim(varname)// & - ' in any input files.') + call MOM_error(FATAL, 'Unable to find variable '//trim(varname)//' in any input files.') endif ; endif + if (present(set)) set = found + end subroutine read_param_char_array !> This subroutine reads the value of a logical model parameter from a parameter file. -subroutine read_param_logical(CS, varname, value, fail_if_missing) +subroutine read_param_logical(CS, varname, value, fail_if_missing, set) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read @@ -788,22 +849,26 @@ subroutine read_param_logical(CS, varname, value, fail_if_missing) !! read from the parameter file logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file + logical, optional, intent(out) :: set !< If present, this indicates whether this parameter + !! has been found and successfully set in the input files. ! Local variables - character(len=INPUT_STR_LENGTH) :: value_string(1) + character(len=CS%max_line_len) :: value_string(1) logical :: found, defined call get_variable_line(CS, varname, found, defined, value_string, paramIsLogical=.true.) if (found) then value = defined elseif (present(fail_if_missing)) then ; if (fail_if_missing) then - call MOM_error(FATAL,'Unable to find variable '//trim(varname)// & - ' in any input files.') + call MOM_error(FATAL, 'Unable to find variable '//trim(varname)//' in any input files.') endif ; endif + + if (present(set)) set = found + end subroutine read_param_logical !> This subroutine reads the value of a time_type model parameter from a parameter file. -subroutine read_param_time(CS, varname, value, timeunit, fail_if_missing, date_format) +subroutine read_param_time(CS, varname, value, timeunit, fail_if_missing, date_format, set) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read @@ -815,9 +880,11 @@ subroutine read_param_time(CS, varname, value, timeunit, fail_if_missing, date_f logical, optional, intent(out) :: date_format !< If present, this indicates whether this !! parameter was read in a date format, so that it can !! later be logged in the same format. + logical, optional, intent(out) :: set !< If present, this indicates whether this parameter + !! has been found and successfully set in the input files. ! Local variables - character(len=INPUT_STR_LENGTH) :: value_string(1) + character(len=CS%max_line_len) :: value_string(1) character(len=240) :: err_msg logical :: found, defined real :: real_time, time_unit @@ -856,16 +923,16 @@ subroutine read_param_time(CS, varname, value, timeunit, fail_if_missing, date_f read( value_string(1), *) real_time value = real_to_time(real_time*time_unit) endif + if (present(set)) set = .true. else if (present(fail_if_missing)) then ; if (fail_if_missing) then if (.not.found) then - call MOM_error(FATAL,'Unable to find variable '//trim(varname)// & - ' in any input files.') + call MOM_error(FATAL, 'Unable to find variable '//trim(varname)//' in any input files.') else - call MOM_error(FATAL,'Variable '//trim(varname)// & - ' found but not set in input files.') + call MOM_error(FATAL, 'Variable '//trim(varname)//' found but not set in input files.') endif endif ; endif + if (present(set)) set = .false. endif return @@ -875,8 +942,8 @@ end subroutine read_param_time !> This function removes single and double quotes from a character string function strip_quotes(val_str) - character(len=*) :: val_str !< The character string to work on - character(len=INPUT_STR_LENGTH) :: strip_quotes + character(len=*), intent(in) :: val_str !< The character string to work on + character(len=len(val_str)) :: strip_quotes ! Local variables integer :: i strip_quotes = val_str @@ -894,8 +961,69 @@ function strip_quotes(val_str) enddo end function strip_quotes -!> This subtoutine extracts the contents of lines in the param_file_type that refer to -!! a named parameter. The value_string that is returned must be interepreted in a way +!> This function returns the maximum number of characters in any input lines after they +!! have been combined by any line continuation. +function max_input_line_length(CS, pf_num) result(max_len) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + integer, optional, intent(in) :: pf_num !< If present, only work on a single file in the + !! param_file_type, or return 0 if this exceeds the + !! number of files in the param_file_type. + integer :: max_len !< The maximum number of characters in any input lines after they + !! have been combined by any line continuation. + + ! Local variables + character(len=FILENAME_LENGTH) :: filename + character :: last_char + integer :: ipf, ipf_s, ipf_e + integer :: last, line_len, count, contBufSize + logical :: continuedLine + + max_len = 0 + ipf_s = 1 ; ipf_e = CS%nfiles + if (present(pf_num)) then + if (pf_num > CS%nfiles) return + ipf_s = pf_num ; ipf_e = pf_num + endif + + paramfile_loop: do ipf = ipf_s, ipf_e + filename = CS%filename(ipf) + contBufSize = 0 + continuedLine = .false. + + ! Scan through each line of the file + do count = 1, CS%param_data(ipf)%num_lines + ! line = CS%param_data(ipf)%fln(count)%line + last = len_trim(CS%param_data(ipf)%fln(count)%line) + last_char = " " + if (last > 0) last_char = CS%param_data(ipf)%fln(count)%line(last:last) + ! Check if line ends in continuation character (either & or \) + ! Note achar(92) is a backslash + if (last_char == achar(92) .or. last_char == "&") then + contBufSize = contBufSize + last - 1 + continuedLine = .true. + if (count==CS%param_data(ipf)%num_lines .and. is_root_pe()) & + call MOM_error(FATAL, "MOM_file_parser : the last line of the file ends in a"// & + " continuation character but there are no more lines to read. "// & + " Line: '"//trim(CS%param_data(ipf)%fln(count)%line(:last))//"'"// & + " in file "//trim(filename)//".") + cycle ! cycle inorder to append the next line of the file + elseif (continuedLine) then + ! If we reached this point then this is the end of line continuation + line_len = contBufSize + last + contBufSize = 0 + continuedLine = .false. + else ! This is a simple line with no continuation. + line_len = last + endif + max_len = max(max_len, line_len) + enddo ! CS%param_data(ipf)%num_lines + enddo paramfile_loop + +end function max_input_line_length + +!> This subroutine extracts the contents of lines in the param_file_type that refer to +!! a named parameter. The value_string that is returned must be interpreted in a way !! that depends on the type of this variable. subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsLogical) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, @@ -908,10 +1036,11 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL !! that can be simply defined without parsing a value_string. ! Local variables - character(len=INPUT_STR_LENGTH) :: val_str, lname, origLine - character(len=INPUT_STR_LENGTH) :: line, continuationBuffer, blockName - character(len=FILENAME_LENGTH) :: filename - integer :: is, id, isd, isu, ise, iso, verbose, ipf + character(len=CS%max_line_len) :: val_str, lname, origLine + character(len=CS%max_line_len) :: line, continuationBuffer + character(len=240) :: blockName + character(len=FILENAME_LENGTH) :: filename + integer :: is, id, isd, isu, ise, iso, ipf integer :: last, last1, ival, oval, max_vals, count, contBufSize character(len=52) :: set logical :: found_override, found_equals @@ -920,10 +1049,10 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL logical :: variableKindIsLogical, valueIsSame logical :: inWrongBlock, fullPathParameter logical, parameter :: requireNamedClose = .false. + integer, parameter :: verbose = 1 set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" - continuationBuffer = repeat(" ",INPUT_STR_LENGTH) + continuationBuffer = repeat(" ", CS%max_line_len) contBufSize = 0 - verbose = 1 variableKindIsLogical=.false. if (present(paramIsLogical)) variableKindIsLogical = paramIsLogical @@ -932,7 +1061,7 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL ! return variables indicating whether this variable is defined and the string ! that contains the value of this variable. found = .false. - oval = 0; ival = 0 + oval = 0 ; ival = 0 max_vals = SIZE(value_string) do is=1,max_vals ; value_string(is) = " " ; enddo @@ -943,7 +1072,7 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL ! Scan through each line of the file do count = 1, CS%param_data(ipf)%num_lines - line = CS%param_data(ipf)%line(count) + line = CS%param_data(ipf)%fln(count)%line last = len_trim(line) last1 = max(1,last) @@ -964,7 +1093,7 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL ! If we reached this point then this is the end of line continuation continuationBuffer(contBufSize+1:contBufSize+len_trim(line))=line(:last) line = continuationBuffer - continuationBuffer=repeat(" ",INPUT_STR_LENGTH) ! Clear for next use + continuationBuffer=repeat(" ",CS%max_line_len) ! Clear for next use contBufSize = 0 continuedLine = .false. last = len_trim(line) @@ -973,8 +1102,8 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL origLine = trim(line) ! Keep original for error messages ! Check for '#override' at start of line - found_override = .false.; found_define = .false.; found_undef = .false. - iso = index(line(:last), "#override " )!; if (is > 0) found_override = .true. + found_override = .false. ; found_define = .false. ; found_undef = .false. + iso = index(line(:last), "#override " )! ; if (is > 0) found_override = .true. if (iso>1) call MOM_error(FATAL, "MOM_file_parser : #override was found "// & " but was not the first keyword."// & " Line: '"//trim(line(:last))//"'"//& @@ -983,26 +1112,7 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL found_override = .true. if (index(line(:last), "#override define ")==1) found_define = .true. if (index(line(:last), "#override undef ")==1) found_undef = .true. - line = trim(adjustl(line(iso+10:last))); last = len_trim(line) - endif - - ! Check for start of fortran namelist, ie. '&namelist' - if (index(line(:last),'&')==1) then - iso=index(line(:last),' ') - if (iso>0) then ! possibly simething else on this line - blockName = pushBlockLevel(blockName,line(2:iso-1)) - line=trim(adjustl(line(iso:last))) - last=len_trim(line) - if (last==0) cycle ! nothing else on this line - else ! just the namelist on this line - if (len_trim(blockName)>0) then - blockName = trim(blockName) // '%' //trim(line(2:last)) - else - blockName = trim(line(2:last)) - endif - call flag_line_as_read(CS%param_data(ipf)%line_used,count) - cycle - endif + line = trim(adjustl(line(iso+10:last))) ; last = len_trim(line) endif ! Newer form of parameter block, block%, %block or block%param or @@ -1042,14 +1152,6 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL if (trim(CS%blockName%name)/=trim(blockName)) inWrongBlock = .true. ! Not in the required block endif - ! Check for termination of a fortran namelist (with a '/') - if (line(last:last)=='/') then - if (len_trim(blockName)==0 .and. is_root_pe()) call MOM_error(FATAL, & - 'get_variable_line: An extra namelist/block end was encountered. Line="'// & - trim(line(:last))//'"' ) - blockName = popBlockLevel(blockName) - last = last - 1 ! Ignore the termination character from here on - endif if (inWrongBlock .and. .not. fullPathParameter) then if (index(" "//line(:last+1), " "//trim(varname)//" ")>0) & call MOM_error(WARNING,"MOM_file_parser : "//trim(varname)// & @@ -1062,36 +1164,35 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL ! Detect keywords found_equals = .false. - isd = index(line(:last), "define" )!; if (isd > 0) found_define = .true. - isu = index(line(:last), "undef" )!; if (isu > 0) found_undef = .true. - ise = index(line(:last), " = " ); if (ise > 1) found_equals = .true. + isd = index(line(:last), "define" )! ; if (isd > 0) found_define = .true. + isu = index(line(:last), "undef" )! ; if (isu > 0) found_undef = .true. + ise = index(line(:last), " = " ) ; if (ise > 1) found_equals = .true. if (index(line(:last), "#define ")==1) found_define = .true. if (index(line(:last), "#undef ")==1) found_undef = .true. ! Check for missing, mutually exclusive or incomplete keywords - if (is_root_pe()) then - if (.not. (found_define .or. found_undef .or. found_equals)) & - call MOM_error(FATAL, "MOM_file_parser : the parameter name '"// & - trim(varname)//"' was found without define or undef."// & - " Line: '"//trim(line(:last))//"'"//& - " in file "//trim(filename)//".") - if (found_define .and. found_undef) call MOM_error(FATAL, & - "MOM_file_parser : Both 'undef' and 'define' occur."// & - " Line: '"//trim(line(:last))//"'"//& - " in file "//trim(filename)//".") - if (found_equals .and. (found_define .or. found_undef)) & - call MOM_error(FATAL, & - "MOM_file_parser : Both 'a=b' and 'undef/define' syntax occur."// & - " Line: '"//trim(line(:last))//"'"//& - " in file "//trim(filename)//".") - if (found_override .and. .not. (found_define .or. found_undef .or. found_equals)) & - call MOM_error(FATAL, "MOM_file_parser : override was found "// & - " without a define or undef."// & - " Line: '"//trim(line(:last))//"'"//& - " in file "//trim(filename)//".") + if (.not. (found_define .or. found_undef .or. found_equals)) then + if (found_override) then + call MOM_error(FATAL, "MOM_file_parser : override was found " // & + " without a define or undef." // & + " Line: '" // trim(line(:last)) // "'" // & + " in file " // trim(filename) // ".") + else + call MOM_error(FATAL, "MOM_file_parser : the parameter name '" // & + trim(varname) // "' was found without define or undef." // & + " Line: '" // trim(line(:last)) // "'" // & + " in file " // trim(filename) // ".") + endif endif + if (found_equals .and. (found_define .or. found_undef)) & + call MOM_error(FATAL, & + "MOM_file_parser : Both 'a=b' and 'undef/define' syntax occur."// & + " Line: '"//trim(line(:last))//"'"//& + " in file "//trim(filename)//".") + ! Interpret the line and collect values, if any + ! NOTE: At least one of these must be true if (found_define) then ! Move starting pointer to first letter of defined name. is = isd + 5 + scan(line(isd+6:last), set) @@ -1131,10 +1232,6 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL defined_in_line = .true. endif found = .true. - else - call MOM_error(FATAL, "MOM_file_parser (non-root PE?): the parameter name '"// & - trim(varname)//"' was found without an assignment, define or undef."// & - " Line: '"//trim(line(:last))//"'"//" in file "//trim(filename)//".") endif ! This line has now been used. @@ -1201,6 +1298,7 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL ival = ival + 1 value_string(ival) = trim(val_str) defined = defined_in_line + if (verbose > 1 .and. is_root_pe()) & call MOM_error(WARNING,"MOM_file_parser : "//trim(varname)// & " set. Line: '"//trim(line(:last))//"'"//& @@ -1219,8 +1317,8 @@ end subroutine get_variable_line !> Record that a line has been used to set a parameter subroutine flag_line_as_read(line_used, count) - logical, dimension(:), pointer :: line_used !< A structure indicating which lines have been read - integer, intent(in) :: count !< The parameter on this line number has been read + logical, dimension(:), pointer :: line_used !< A structure indicating which lines have been read + integer, intent(in) :: count !< The parameter on this line number has been read line_used(count) = .true. end subroutine flag_line_as_read @@ -1318,7 +1416,7 @@ subroutine log_param_int(CS, modulename, varname, value, desc, units, & if (CS%log_to_stdout) write(CS%stdout,'(a)') trim(mesg) endif - myunits=" "; if (present(units)) write(myunits(1:240),'(A)') trim(units) + myunits = " " ; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) @@ -1327,7 +1425,7 @@ end subroutine log_param_int !> Log the name and values of an array of integer model parameter in documentation files. subroutine log_param_int_array(CS, modulename, varname, value, desc, & - units, default, layoutParam, debuggingParam, like_default) + units, default, defaults, layoutParam, debuggingParam, like_default) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the module using this parameter @@ -1336,7 +1434,8 @@ subroutine log_param_int_array(CS, modulename, varname, value, desc, & character(len=*), optional, intent(in) :: desc !< A description of this variable; if not !! present, this parameter is not written to a doc file character(len=*), optional, intent(in) :: units !< The units of this parameter - integer, optional, intent(in) :: default !< The default value of the parameter + integer, optional, intent(in) :: default !< The uniform default value of this parameter + integer, optional, intent(in) :: defaults(:) !< The element-wise default values of this parameter logical, optional, intent(in) :: layoutParam !< If present and true, this parameter is !! logged in the layout parameter file logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is @@ -1344,7 +1443,7 @@ subroutine log_param_int_array(CS, modulename, varname, value, desc, & logical, optional, intent(in) :: like_default !< If present and true, log this parameter as !! though it has the default value, even if there is no default. - character(len=1320) :: mesg + character(len=CS%max_line_len+120) :: mesg character(len=240) :: myunits write(mesg, '(" ",a," ",a,": ",A)') trim(modulename), trim(varname), trim(left_ints(value)) @@ -1353,16 +1452,16 @@ subroutine log_param_int_array(CS, modulename, varname, value, desc, & if (CS%log_to_stdout) write(CS%stdout,'(a)') trim(mesg) endif - myunits=" "; if (present(units)) write(myunits(1:240),'(A)') trim(units) + myunits = " " ; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & - call doc_param(CS%doc, varname, desc, myunits, value, default, & + call doc_param(CS%doc, varname, desc, myunits, value, default, defaults, & layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) end subroutine log_param_int_array !> Log the name and value of a real model parameter in documentation files. subroutine log_param_real(CS, modulename, varname, value, desc, units, & - default, debuggingParam, like_default) + default, debuggingParam, like_default, unscale) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1370,32 +1469,37 @@ subroutine log_param_real(CS, modulename, varname, value, desc, units, & real, intent(in) :: value !< The value of the parameter to log character(len=*), optional, intent(in) :: desc !< A description of this variable; if not !! present, this parameter is not written to a doc file - character(len=*), optional, intent(in) :: units !< The units of this parameter + character(len=*), intent(in) :: units !< The units of this parameter real, optional, intent(in) :: default !< The default value of the parameter logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file logical, optional, intent(in) :: like_default !< If present and true, log this parameter as !! though it has the default value, even if there is no default. + real, optional, intent(in) :: unscale !< A reciprocal scaling factor that the parameter is + !! multiplied by before it is logged + real :: log_val ! The parameter value that is written out character(len=240) :: mesg, myunits + log_val = value ; if (present(unscale)) log_val = unscale * value + write(mesg, '(" ",a," ",a,": ",a)') & - trim(modulename), trim(varname), trim(left_real(value)) + trim(modulename), trim(varname), trim(left_real(log_val)) if (is_root_pe()) then if (CS%log_open) write(CS%stdlog,'(a)') trim(mesg) if (CS%log_to_stdout) write(CS%stdout,'(a)') trim(mesg) endif - myunits="not defined"; if (present(units)) write(myunits(1:240),'(A)') trim(units) + write(myunits(1:240),'(A)') trim(units) if (present(desc)) & - call doc_param(CS%doc, varname, desc, myunits, value, default, & + call doc_param(CS%doc, varname, desc, myunits, log_val, default, & debuggingParam=debuggingParam, like_default=like_default) end subroutine log_param_real !> Log the name and values of an array of real model parameter in documentation files. subroutine log_param_real_array(CS, modulename, varname, value, desc, & - units, default, debuggingParam, like_default) + units, default, defaults, debuggingParam, like_default, unscale) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1403,28 +1507,34 @@ subroutine log_param_real_array(CS, modulename, varname, value, desc, & real, dimension(:), intent(in) :: value !< The value of the parameter to log character(len=*), optional, intent(in) :: desc !< A description of this variable; if not !! present, this parameter is not written to a doc file - character(len=*), optional, intent(in) :: units !< The units of this parameter - real, optional, intent(in) :: default !< The default value of the parameter + character(len=*), intent(in) :: units !< The units of this parameter + real, optional, intent(in) :: default !< A uniform default value of the parameter + real, optional, intent(in) :: defaults(:) !< The element-wise defaults of the parameter logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file logical, optional, intent(in) :: like_default !< If present and true, log this parameter as !! though it has the default value, even if there is no default. + real, optional, intent(in) :: unscale !< A reciprocal scaling factor that the parameter is + !! multiplied by before it is logged + real, dimension(size(value)) :: log_val ! The array of parameter values that is written out character(len=:), allocatable :: mesg character(len=240) :: myunits + log_val(:) = value(:) ; if (present(unscale)) log_val(:) = unscale * value(:) + !write(mesg, '(" ",a," ",a,": ",ES19.12,99(",",ES19.12))') & !write(mesg, '(" ",a," ",a,": ",G,99(",",G))') & ! trim(modulename), trim(varname), value - mesg = " " // trim(modulename) // " " // trim(varname) // ": " // trim(left_reals(value)) + mesg = " " // trim(modulename) // " " // trim(varname) // ": " // trim(left_reals(log_val)) if (is_root_pe()) then if (CS%log_open) write(CS%stdlog,'(a)') trim(mesg) if (CS%log_to_stdout) write(CS%stdout,'(a)') trim(mesg) endif - myunits="not defined"; if (present(units)) write(myunits(1:240),'(A)') trim(units) + write(myunits(1:240),'(A)') trim(units) if (present(desc)) & - call doc_param(CS%doc, varname, desc, myunits, value, default, & + call doc_param(CS%doc, varname, desc, myunits, log_val, default, defaults, & debuggingParam=debuggingParam, like_default=like_default) end subroutine log_param_real_array @@ -1460,7 +1570,7 @@ subroutine log_param_logical(CS, modulename, varname, value, desc, & if (CS%log_to_stdout) write(CS%stdout,'(a)') trim(mesg) endif - myunits="Boolean"; if (present(units)) write(myunits(1:240),'(A)') trim(units) + myunits = "Boolean" ; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) @@ -1486,16 +1596,16 @@ subroutine log_param_char(CS, modulename, varname, value, desc, units, & logical, optional, intent(in) :: like_default !< If present and true, log this parameter as !! though it has the default value, even if there is no default. - character(len=1024) :: mesg, myunits + character(len=:), allocatable :: mesg + character(len=240) :: myunits - write(mesg, '(" ",a," ",a,": ",a)') & - trim(modulename), trim(varname), trim(value) + mesg = " " // trim(modulename) // " " // trim(varname) // ": " // trim(value) if (is_root_pe()) then if (CS%log_open) write(CS%stdlog,'(a)') trim(mesg) if (CS%log_to_stdout) write(CS%stdout,'(a)') trim(mesg) endif - myunits=" "; if (present(units)) write(myunits(1:1024),'(A)') trim(units) + myunits = " " ; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) @@ -1531,7 +1641,7 @@ subroutine log_param_time(CS, modulename, varname, value, desc, units, & logical :: use_timeunit, date_format character(len=240) :: mesg, myunits character(len=80) :: date_string, default_string - integer :: days, secs, ticks, ticks_per_sec + integer :: days, secs, ticks use_timeunit = .false. date_format = .false. ; if (present(log_date)) date_format = log_date @@ -1628,7 +1738,7 @@ end function convert_date_to_string !! and logs it in documentation files. subroutine get_param_int(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & - static_value, layoutParam, debuggingParam) + layoutParam, debuggingParam, old_name) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1639,9 +1749,6 @@ subroutine get_param_int(CS, modulename, varname, value, desc, units, & !! present, this parameter is not written to a doc file character(len=*), optional, intent(in) :: units !< The units of this parameter integer, optional, intent(in) :: default !< The default value of the parameter - integer, optional, intent(in) :: static_value !< If this parameter is static, it takes - !! this value, which can be compared for consistency with - !! what is in the parameter file. logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file logical, optional, intent(in) :: do_not_read !< If present and true, do not read a @@ -1652,16 +1759,37 @@ subroutine get_param_int(CS, modulename, varname, value, desc, units, & !! logged in the layout parameter file logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file + character(len=*), optional, intent(in) :: old_name !< A case-sensitive archaic name of the parameter + !! to read. Errors or warnings are issued if the old name + !! is being used. + ! Local variables logical :: do_read, do_log + logical :: new_name_used, old_name_used, same_value + integer :: new_name_value ! The value that is set when the standard name is used. do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read do_log = .true. ; if (present(do_not_log)) do_log = .not.do_not_log if (do_read) then if (present(default)) value = default - if (present(static_value)) value = static_value - call read_param_int(CS, varname, value, fail_if_missing) + + old_name_used = .false. + if (present(old_name)) then + new_name_value = value + call read_param_int(CS, old_name, value, set=old_name_used) + if (old_name_used) then + call read_param_int(CS, varname, new_name_value, set=new_name_used) + + ! Issue appropriate warnings or error messages. + same_value = (value == new_name_value) + call archaic_param_name_message(varname, old_name, new_name_used, same_value) + endif + endif + + if (.not.old_name_used) then ! Old name is either not present or not set. + call read_param_int(CS, varname, value, fail_if_missing) + endif endif if (do_log) then @@ -1674,8 +1802,8 @@ end subroutine get_param_int !> This subroutine reads the values of an array of integer model parameters from a parameter file !! and logs them in documentation files. subroutine get_param_int_array(CS, modulename, varname, value, desc, units, & - default, fail_if_missing, do_not_read, do_not_log, & - static_value, layoutParam, debuggingParam) + default, defaults, fail_if_missing, do_not_read, do_not_log, & + layoutParam, debuggingParam, old_name) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1685,10 +1813,8 @@ subroutine get_param_int_array(CS, modulename, varname, value, desc, units, & character(len=*), optional, intent(in) :: desc !< A description of this variable; if not !! present, this parameter is not written to a doc file character(len=*), optional, intent(in) :: units !< The units of this parameter - integer, optional, intent(in) :: default !< The default value of the parameter - integer, optional, intent(in) :: static_value !< If this parameter is static, it takes - !! this value, which can be compared for consistency with - !! what is in the parameter file. + integer, optional, intent(in) :: default !< The uniform default value of this parameter + integer, optional, intent(in) :: defaults(:) !< The element-wise default values of this parameter logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file logical, optional, intent(in) :: do_not_read !< If present and true, do not read a @@ -1699,21 +1825,52 @@ subroutine get_param_int_array(CS, modulename, varname, value, desc, units, & !! logged in the layout parameter file logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file + character(len=*), optional, intent(in) :: old_name !< A case-sensitive archaic name of the parameter + !! to read. Errors or warnings are issued if the old name + !! is being used. + ! Local variables logical :: do_read, do_log + logical :: new_name_used, old_name_used, same_value + integer :: new_name_value(size(value)) ! The values that are set when the old name is used. + integer :: m do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read do_log = .true. ; if (present(do_not_log)) do_log = .not.do_not_log + if (present(defaults)) then + if (present(default)) call MOM_error(FATAL, & + "get_param_int_array: Only one of default and defaults can be specified at a time.") + if (size(defaults) /= size(value)) call MOM_error(FATAL, & + "get_param_int_array: The size of defaults and value are not the same.") + endif + if (do_read) then - if (present(default)) then ; value(:) = default ; endif - if (present(static_value)) then ; value(:) = static_value ; endif - call read_param_int_array(CS, varname, value, fail_if_missing) + if (present(default)) value(:) = default + if (present(defaults)) value(:) = defaults(:) + + old_name_used = .false. + if (present(old_name)) then + new_name_value(:) = value(:) + call read_param_int_array(CS, old_name, value, set=old_name_used) + if (old_name_used) then + call read_param_int_array(CS, varname, new_name_value, set=new_name_used) + + ! Issue appropriate warnings or error messages. + same_value = .true. + do m=1,size(value) ; if (value(m) /= new_name_value(m)) same_value = .false. ; enddo + call archaic_param_name_message(varname, old_name, new_name_used, same_value) + endif + endif + + if (.not.old_name_used) then ! Old name is either not present or not set. + call read_param_int_array(CS, varname, value, fail_if_missing) + endif endif if (do_log) then - call log_param_int_array(CS, modulename, varname, value, desc, & - units, default, layoutParam, debuggingParam) + call log_param_int_array(CS, modulename, varname, value, desc, units, & + default, defaults, layoutParam, debuggingParam) endif end subroutine get_param_int_array @@ -1722,7 +1879,7 @@ end subroutine get_param_int_array !! and logs it in documentation files. subroutine get_param_real(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & - static_value, debuggingParam, scale, unscaled) + debuggingParam, scale, unscaled, old_name) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1731,11 +1888,8 @@ subroutine get_param_real(CS, modulename, varname, value, desc, units, & !! read from the parameter file and logged character(len=*), optional, intent(in) :: desc !< A description of this variable; if not !! present, this parameter is not written to a doc file - character(len=*), optional, intent(in) :: units !< The units of this parameter + character(len=*), intent(in) :: units !< The units of this parameter real, optional, intent(in) :: default !< The default value of the parameter - real, optional, intent(in) :: static_value !< If this parameter is static, it takes - !! this value, which can be compared for consistency with - !! what is in the parameter file. logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file logical, optional, intent(in) :: do_not_read !< If present and true, do not read a @@ -1748,16 +1902,37 @@ subroutine get_param_real(CS, modulename, varname, value, desc, units, & !! multiplied by before it is returned. real, optional, intent(out) :: unscaled !< The value of the parameter that would be !! returned without any multiplication by a scaling factor. + character(len=*), optional, intent(in) :: old_name !< A case-sensitive archaic name of the parameter + !! to read. Errors or warnings are issued if the old name + !! is being used. + ! Local variables logical :: do_read, do_log + logical :: new_name_used, old_name_used, same_value + real :: new_name_value ! The value that is set when the old name is used. do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read do_log = .true. ; if (present(do_not_log)) do_log = .not.do_not_log if (do_read) then if (present(default)) value = default - if (present(static_value)) value = static_value - call read_param_real(CS, varname, value, fail_if_missing) + + old_name_used = .false. + if (present(old_name)) then + new_name_value = value + call read_param_real(CS, old_name, value, set=old_name_used) + if (old_name_used) then + call read_param_real(CS, varname, new_name_value, set=new_name_used) + + ! Issue appropriate warnings or error messages. + same_value = (new_name_used .and. old_name_used .and. (value == new_name_value)) + call archaic_param_name_message(varname, old_name, new_name_used, same_value) + endif + endif + + if (.not.old_name_used) then ! Old name is either not present or not set. + call read_param_real(CS, varname, value, fail_if_missing) + endif endif if (do_log) then @@ -1773,8 +1948,8 @@ end subroutine get_param_real !> This subroutine reads the values of an array of real model parameters from a parameter file !! and logs them in documentation files. subroutine get_param_real_array(CS, modulename, varname, value, desc, units, & - default, fail_if_missing, do_not_read, do_not_log, debuggingParam, & - static_value, scale, unscaled) + default, defaults, fail_if_missing, do_not_read, do_not_log, debuggingParam, & + scale, unscaled, old_name) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1783,11 +1958,9 @@ subroutine get_param_real_array(CS, modulename, varname, value, desc, units, & !! read from the parameter file and logged character(len=*), optional, intent(in) :: desc !< A description of this variable; if not !! present, this parameter is not written to a doc file - character(len=*), optional, intent(in) :: units !< The units of this parameter - real, optional, intent(in) :: default !< The default value of the parameter - real, optional, intent(in) :: static_value !< If this parameter is static, it takes - !! this value, which can be compared for consistency with - !! what is in the parameter file. + character(len=*), intent(in) :: units !< The units of this parameter + real, optional, intent(in) :: default !< A uniform default value of the parameter + real, optional, intent(in) :: defaults(:) !< The element-wise defaults of the parameter logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file logical, optional, intent(in) :: do_not_read !< If present and true, do not read a @@ -1800,21 +1973,52 @@ subroutine get_param_real_array(CS, modulename, varname, value, desc, units, & !! multiplied by before it is returned. real, dimension(:), optional, intent(out) :: unscaled !< The value of the parameter that would be !! returned without any multiplication by a scaling factor. + character(len=*), optional, intent(in) :: old_name !< A case-sensitive archaic name of the parameter + !! to read. Errors or warnings are issued if the old name + !! is being used. + ! Local variables logical :: do_read, do_log + logical :: new_name_used, old_name_used, same_value + real :: new_name_value(size(value)) ! The values that are set when the standard name is used. + integer :: m do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read do_log = .true. ; if (present(do_not_log)) do_log = .not.do_not_log + if (present(defaults)) then + if (present(default)) call MOM_error(FATAL, & + "get_param_real_array: Only one of default and defaults can be specified at a time.") + if (size(defaults) /= size(value)) call MOM_error(FATAL, & + "get_param_real_array: The size of defaults and value are not the same.") + endif + if (do_read) then - if (present(default)) then ; value(:) = default ; endif - if (present(static_value)) then ; value(:) = static_value ; endif - call read_param_real_array(CS, varname, value, fail_if_missing) + if (present(default)) value(:) = default + if (present(defaults)) value(:) = defaults(:) + + old_name_used = .false. + if (present(old_name)) then + new_name_value(:) = value(:) + call read_param_real_array(CS, old_name, value, set=old_name_used) + if (old_name_used) then + call read_param_real_array(CS, varname, new_name_value, set=new_name_used) + + ! Issue appropriate warnings or error messages. + same_value = .true. + do m=1,size(value) ; if (value(m) /= new_name_value(m)) same_value = .false. ; enddo + call archaic_param_name_message(varname, old_name, new_name_used, same_value) + endif + endif + + if (.not.old_name_used) then ! Old name is either not present or not set. + call read_param_real_array(CS, varname, value, fail_if_missing) + endif endif if (do_log) then call log_param_real_array(CS, modulename, varname, value, desc, & - units, default, debuggingParam) + units, default, defaults, debuggingParam) endif if (present(unscaled)) unscaled(:) = value(:) @@ -1826,7 +2030,7 @@ end subroutine get_param_real_array !! and logs it in documentation files. subroutine get_param_char(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & - static_value, layoutParam, debuggingParam) + layoutParam, debuggingParam, old_name) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1837,9 +2041,6 @@ subroutine get_param_char(CS, modulename, varname, value, desc, units, & !! present, this parameter is not written to a doc file character(len=*), optional, intent(in) :: units !< The units of this parameter character(len=*), optional, intent(in) :: default !< The default value of the parameter - character(len=*), optional, intent(in) :: static_value !< If this parameter is static, it takes - !! this value, which can be compared for consistency with - !! what is in the parameter file. logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file logical, optional, intent(in) :: do_not_read !< If present and true, do not read a @@ -1850,16 +2051,37 @@ subroutine get_param_char(CS, modulename, varname, value, desc, units, & !! logged in the layout parameter file logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file + character(len=*), optional, intent(in) :: old_name !< A case-sensitive archaic name of the parameter + !! to read. Errors or warnings are issued if the old name + !! is being used. + ! Local variables logical :: do_read, do_log + logical :: new_name_used, old_name_used, same_value + character(len=:), allocatable :: new_name_value ! The value that is set when the standard name is used. do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read do_log = .true. ; if (present(do_not_log)) do_log = .not.do_not_log if (do_read) then if (present(default)) value = default - if (present(static_value)) value = static_value - call read_param_char(CS, varname, value, fail_if_missing) + + old_name_used = .false. + if (present(old_name)) then + new_name_value = value + call read_param_char(CS, old_name, value, set=old_name_used) + if (old_name_used) then + call read_param_char(CS, varname, new_name_value, set=new_name_used) + + ! Issue appropriate warnings or error messages. + same_value = (trim(value) == trim(new_name_value)) + call archaic_param_name_message(varname, old_name, new_name_used, same_value) + endif + endif + + if (.not.old_name_used) then ! Old name is either not present or not set. + call read_param_char(CS, varname, value, fail_if_missing) + endif endif if (do_log) then @@ -1872,7 +2094,7 @@ end subroutine get_param_char !> This subroutine reads the values of an array of character string model parameters !! from a parameter file and logs them in documentation files. subroutine get_param_char_array(CS, modulename, varname, value, desc, units, & - default, fail_if_missing, do_not_read, do_not_log, static_value) + default, fail_if_missing, do_not_read, do_not_log, old_name) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1883,32 +2105,50 @@ subroutine get_param_char_array(CS, modulename, varname, value, desc, units, & !! present, this parameter is not written to a doc file character(len=*), optional, intent(in) :: units !< The units of this parameter character(len=*), optional, intent(in) :: default !< The default value of the parameter - character(len=*), optional, intent(in) :: static_value !< If this parameter is static, it takes - !! this value, which can be compared for consistency with - !! what is in the parameter file. logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file logical, optional, intent(in) :: do_not_read !< If present and true, do not read a !! value for this parameter, although it might be logged. logical, optional, intent(in) :: do_not_log !< If present and true, do not log this !! parameter to the documentation files + character(len=*), optional, intent(in) :: old_name !< A case-sensitive archaic name of the parameter + !! to read. Errors or warnings are issued if the old name + !! is being used. ! Local variables logical :: do_read, do_log - integer :: i, len_tot, len_val - character(len=1024) :: cat_val + logical :: new_name_used, old_name_used, same_value + integer :: i, m, len_tot, len_val + character(len=:), allocatable :: cat_val + character(len=:), allocatable :: new_name_value(:) ! The value that is set when the standard name is used. do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read do_log = .true. ; if (present(do_not_log)) do_log = .not.do_not_log if (do_read) then - if (present(default)) then ; value(:) = default ; endif - if (present(static_value)) then ; value(:) = static_value ; endif - call read_param_char_array(CS, varname, value, fail_if_missing) + if (present(default)) value(:) = default + + old_name_used = .false. + if (present(old_name)) then + new_name_value(:) = value(:) + call read_param_char_array(CS, old_name, value, set=old_name_used) + if (old_name_used) then + call read_param_char_array(CS, varname, new_name_value, set=new_name_used) + + ! Issue appropriate warnings or error messages. + same_value = .true. + do m=1,size(value) ; if (trim(value(m)) /= trim(new_name_value(m))) same_value = .false. ; enddo + call archaic_param_name_message(varname, old_name, new_name_used, same_value) + endif + endif + + if (.not.old_name_used) then ! Old name is either not present or not set. + call read_param_char_array(CS, varname, value, fail_if_missing) + endif endif if (do_log) then - cat_val = trim(value(1)); len_tot = len_trim(value(1)) + cat_val = trim(value(1)) ; len_tot = len_trim(value(1)) do i=2,size(value) len_val = len_trim(value(i)) if ((len_val > 0) .and. (len_tot + len_val + 2 < 240)) then @@ -1926,7 +2166,7 @@ end subroutine get_param_char_array !! and logs it in documentation files. subroutine get_param_logical(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & - static_value, layoutParam, debuggingParam) + layoutParam, debuggingParam, old_name) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1937,9 +2177,6 @@ subroutine get_param_logical(CS, modulename, varname, value, desc, units, & !! present, this parameter is not written to a doc file character(len=*), optional, intent(in) :: units !< The units of this parameter logical, optional, intent(in) :: default !< The default value of the parameter - logical, optional, intent(in) :: static_value !< If this parameter is static, it takes - !! this value, which can be compared for consistency with - !! what is in the parameter file. logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file logical, optional, intent(in) :: do_not_read !< If present and true, do not read a @@ -1950,16 +2187,37 @@ subroutine get_param_logical(CS, modulename, varname, value, desc, units, & !! logged in the layout parameter file logical, optional, intent(in) :: debuggingParam !< If present and true, this parameter is !! logged in the debugging parameter file + character(len=*), optional, intent(in) :: old_name !< A case-sensitive archaic name of the parameter + !! to read. Errors or warnings are issued if the old name + !! is being used. + ! Local variables logical :: do_read, do_log + logical :: new_name_used, old_name_used, same_value + logical :: new_name_value ! The value that is set when the standard name is used. do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read do_log = .true. ; if (present(do_not_log)) do_log = .not.do_not_log if (do_read) then if (present(default)) value = default - if (present(static_value)) value = static_value - call read_param_logical(CS, varname, value, fail_if_missing) + + old_name_used = .false. + if (present(old_name)) then + new_name_value = value + call read_param_logical(CS, old_name, value, set=old_name_used) + if (old_name_used) then + call read_param_logical(CS, varname, new_name_value, set=new_name_used) + + ! Issue appropriate warnings or error messages. + same_value = (value .eqv. new_name_value) + call archaic_param_name_message(varname, old_name, new_name_used, same_value) + endif + endif + + if (.not.old_name_used) then ! Old name is either not present or not set. + call read_param_logical(CS, varname, value, fail_if_missing) + endif endif if (do_log) then @@ -1973,8 +2231,8 @@ end subroutine get_param_logical !! and logs it in documentation files. subroutine get_param_time(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & - timeunit, static_value, layoutParam, debuggingParam, & - log_as_date) + timeunit, layoutParam, debuggingParam, & + log_as_date, old_name) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1985,9 +2243,6 @@ subroutine get_param_time(CS, modulename, varname, value, desc, units, & !! present, this parameter is not written to a doc file character(len=*), optional, intent(in) :: units !< The units of this parameter type(time_type), optional, intent(in) :: default !< The default value of the parameter - type(time_type), optional, intent(in) :: static_value !< If this parameter is static, it takes - !! this value, which can be compared for consistency with - !! what is in the parameter file. logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file logical, optional, intent(in) :: do_not_read !< If present and true, do not read a @@ -2002,8 +2257,14 @@ subroutine get_param_time(CS, modulename, varname, value, desc, units, & !! logged in the debugging parameter file logical, optional, intent(in) :: log_as_date !< If true, log the time_type in date !! format. The default is false. + character(len=*), optional, intent(in) :: old_name !< A case-sensitive archaic name of the parameter + !! to read. Errors or warnings are issued if the old name + !! is being used. - logical :: do_read, do_log, date_format, log_date + ! Local variables + logical :: do_read, do_log, log_date + logical :: new_name_used, old_name_used, same_value + type(time_type) :: new_name_value ! The value that is set when the standard name is used. do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read do_log = .true. ; if (present(do_not_log)) do_log = .not.do_not_log @@ -2011,8 +2272,23 @@ subroutine get_param_time(CS, modulename, varname, value, desc, units, & if (do_read) then if (present(default)) value = default - if (present(static_value)) value = static_value - call read_param_time(CS, varname, value, timeunit, fail_if_missing, date_format=log_date) + + old_name_used = .false. + if (present(old_name)) then + new_name_value = value + call read_param_time(CS, old_name, value, timeunit, date_format=log_date, set=old_name_used) + if (old_name_used) then + call read_param_time(CS, varname, new_name_value, timeunit, date_format=log_date, set=new_name_used) + + ! Issue appropriate warnings or error messages. + same_value = (value == new_name_value) + call archaic_param_name_message(varname, old_name, new_name_used, same_value) + endif + endif + + if (.not.old_name_used) then ! Old name is either not present or not set. + call read_param_time(CS, varname, value, timeunit, fail_if_missing, date_format=log_date) + endif endif if (do_log) then @@ -2024,6 +2300,28 @@ subroutine get_param_time(CS, modulename, varname, value, desc, units, & end subroutine get_param_time +!> Issue error messages or warnings about the use of an archaic parameter name. +subroutine archaic_param_name_message(varname, old_name, new_name_used, same_value) + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + character(len=*), intent(in) :: old_name !< The case-sensitive archaic name of the parameter + logical, intent(in) :: new_name_used !< True if varname is used in the parameter file. + logical, intent(in) :: same_value !< True if varname and old_name give the same values. + + if (new_name_used .and. same_value) then + call MOM_error(WARNING, "The runtime parameter "//trim(varname)//& + " is also being set consistently via its older name of "//trim(old_name)//& + ". Please migrate to only using "//trim(varname)//".") + elseif (new_name_used .and. .not.same_value) then + call MOM_error(FATAL, "The runtime parameter "//trim(varname)//& + " is also being set inconsistently via its older name of "//trim(old_name)//& + ". Only use "//trim(varname)//".") + else + call MOM_error(WARNING, "The runtime parameter "//trim(varname)//& + " is being set via its soon to be obsolete name of "//trim(old_name)//& + ". Please migrate to using "//trim(varname)//".") + endif +end subroutine archaic_param_name_message + ! ----------------------------------------------------------------------------- !> Resets the parameter block name to blank @@ -2042,17 +2340,29 @@ subroutine clearParameterBlock(CS) end subroutine clearParameterBlock !> Tags blockName onto the end of the active parameter block name -subroutine openParameterBlock(CS,blockName,desc) +subroutine openParameterBlock(CS, blockName, desc, do_not_log) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: blockName !< The name of a parameter block being added character(len=*), optional, intent(in) :: desc !< A description of the parameter block being added + logical, optional, intent(in) :: do_not_log + !< Log block entry if true. This only prevents logging of entry to the block, and not the contents. type(parameter_block), pointer :: block => NULL() + logical :: do_log + + do_log = .true. + if (present(do_not_log)) do_log = .not. do_not_log + if (associated(CS%blockName)) then block => CS%blockName block%name = pushBlockLevel(block%name,blockName) - call doc_openBlock(CS%doc,block%name,desc) + if (do_log) then + call doc_openBlock(CS%doc, block%name, desc) + block%log_access = .true. + else + block%log_access = .false. + endif else if (is_root_pe()) call MOM_error(FATAL, & 'openParameterBlock: A push was attempted before allocation.') @@ -2071,7 +2381,7 @@ subroutine closeParameterBlock(CS) if (is_root_pe().and.len_trim(block%name)==0) call MOM_error(FATAL, & 'closeParameterBlock: A pop was attempted on an empty stack. ("'//& trim(block%name)//'")') - call doc_closeBlock(CS%doc,block%name) + if (block%log_access) call doc_closeBlock(CS%doc, block%name) else if (is_root_pe()) call MOM_error(FATAL, & 'closeParameterBlock: A pop was attempted before allocation.') diff --git a/src/framework/MOM_get_input.F90 b/src/framework/MOM_get_input.F90 index b6b5b89be9..8000558b06 100644 --- a/src/framework/MOM_get_input.F90 +++ b/src/framework/MOM_get_input.F90 @@ -1,3 +1,7 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> \brief Reads the only Fortran name list needed to boot-strap the model. !! !! The name list parameters indicate which directories to use for @@ -5,12 +9,11 @@ !! the full parsable input parameter file(s). module MOM_get_input -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : open_param_file, param_file_type use MOM_io, only : file_exists, close_file, slasher, ensembler use MOM_io, only : open_namelist_file, check_nml_error +use posix, only : mkdir, stat, stat_buf implicit none ; private @@ -54,6 +57,8 @@ subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename, character(len=240) :: output_dir integer :: unit, io, ierr, valid_param_files + type(stat_buf) :: buf + namelist /MOM_input_nml/ output_directory, input_filename, parameter_filename, & restart_input_dir, restart_output_dir @@ -73,6 +78,7 @@ subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename, endif ! Read namelist parameters + ! NOTE: Every rank is reading MOM_input_nml ierr=1 ; do while (ierr /= 0) read(unit, nml=MOM_input_nml, iostat=io, end=10) ierr = check_nml_error(io, 'MOM_input_nml') @@ -92,6 +98,15 @@ subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename, dirs%restart_input_dir = slasher(ensembler(restart_input_dir)) dirs%input_filename = ensembler(input_filename) endif + + ! Create the RESTART directory if absent + if (is_root_PE()) then + if (stat(trim(dirs%restart_output_dir), buf) == -1) then + ierr = mkdir(trim(dirs%restart_output_dir), int(o'700')) + if (ierr == -1) & + call MOM_error(FATAL, 'Restart directory could not be created.') + endif + endif endif ! Open run-time parameter file(s) @@ -102,7 +117,7 @@ subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename, if (len_trim(trim(parameter_filename(io))) > 0) then if (present(ensemble_num)) then call open_param_file(ensembler(parameter_filename(io),ensemble_num), param_file, & - check_params, doc_file_dir=output_dir) + check_params, doc_file_dir=output_dir, ensemble_num=ensemble_num) else call open_param_file(ensembler(parameter_filename(io)), param_file, & check_params, doc_file_dir=output_dir) diff --git a/src/framework/MOM_hor_index.F90 b/src/framework/MOM_hor_index.F90 index 4e8cb2c43b..2bc832e90a 100644 --- a/src/framework/MOM_hor_index.F90 +++ b/src/framework/MOM_hor_index.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Defines the horizontal index type (hor_index_type) used for providing index ranges module MOM_hor_index -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_domains, only : MOM_domain_type, get_domain_extent, get_global_shape use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL use MOM_file_parser, only : get_param, log_param, log_version, param_file_type @@ -55,7 +57,7 @@ module MOM_hor_index end type hor_index_type !> Copy the contents of one horizontal index type into another -interface assignment(=); module procedure HIT_assign ; end interface +interface assignment(=) ; module procedure HIT_assign ; end interface contains @@ -63,7 +65,7 @@ module MOM_hor_index subroutine hor_index_init(Domain, HI, param_file, local_indexing, index_offset) type(MOM_domain_type), intent(in) :: Domain !< The MOM domain from which to extract information. type(hor_index_type), intent(inout) :: HI !< A horizontal index type to populate with data - type(param_file_type), intent(in) :: param_file !< Parameter file handle + type(param_file_type), optional, intent(in) :: param_file !< Parameter file handle logical, optional, intent(in) :: local_indexing !< If true, all tracer data domains start at 1 integer, optional, intent(in) :: index_offset !< A fixed additional offset to all indices @@ -80,8 +82,9 @@ subroutine hor_index_init(Domain, HI, param_file, local_indexing, index_offset) call get_global_shape(Domain, HI%niglobal, HI%njglobal) ! Read all relevant parameters and write them to the model log. - call log_version(param_file, "MOM_hor_index", version, & - "Sets the horizontal array index types.", all_default=.true.) + if (present(param_file)) & + call log_version(param_file, "MOM_hor_index", version, & + "Sets the horizontal array index types.", all_default=.true.) HI%IscB = HI%isc ; HI%JscB = HI%jsc HI%IsdB = HI%isd ; HI%JsdB = HI%jsd diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 0f16a5b301..4f3a4854f0 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -1,10 +1,13 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Horizontal interpolation module MOM_horizontal_regridding -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_debugging, only : hchksum use MOM_coms, only : max_across_PEs, min_across_PEs, sum_across_PEs, broadcast +use MOM_coms, only : reproducing_sum use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_LOOP use MOM_domains, only : pass_var use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe @@ -12,19 +15,20 @@ module MOM_horizontal_regridding use MOM_error_handler, only : MOM_get_verbosity use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_interpolate, only : time_interp_external, horiz_interp_init -use MOM_interpolate, only : build_horiz_interp_weights, run_horiz_interp, horiz_interp_type -use MOM_interp_infra, only : axistype, get_external_field_info, get_axis_data +use MOM_interpolate, only : time_interp_external +use MOM_interp_infra, only : run_horiz_interp, build_horiz_interp_weights +use MOM_interp_infra, only : horiz_interp_type, horizontal_interp_init +use MOM_interpolate, only : get_external_field_info +use MOM_interp_infra, only : external_field use MOM_time_manager, only : time_type - -use netcdf, only : NF90_OPEN, NF90_NOWRITE, NF90_GET_ATT, NF90_GET_VAR -use netcdf, only : NF90_INQ_VARID, NF90_INQUIRE_VARIABLE, NF90_INQUIRE_DIMENSION +use MOM_io, only : axis_info, get_axis_info, get_var_axes_info, MOM_read_data +use MOM_io, only : read_attribute, read_variable implicit none ; private #include -public :: horiz_interp_and_extrap_tracer, myStats +public :: horiz_interp_and_extrap_tracer, myStats, homogenize_field !> Extrapolate and interpolate data interface horiz_interp_and_extrap_tracer @@ -32,24 +36,42 @@ module MOM_horizontal_regridding module procedure horiz_interp_and_extrap_tracer_fms_id end interface +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. +! The functions in this module work with variables with arbitrary units, in which case the +! arbitrary rescaled units are indicated with [A ~> a], while the unscaled units are just [a]. + contains !> Write to the terminal some basic statistics about the k-th level of an array -subroutine myStats(array, missing, is, ie, js, je, k, mesg) - real, dimension(:,:), intent(in) :: array !< input array (ND) - real, intent(in) :: missing !< missing value (ND) - integer :: is !< Start index in i - integer :: ie !< End index in i - integer :: js !< Start index in j - integer :: je !< End index in j - integer :: k !< Level to calculate statistics for - character(len=*) :: mesg !< Label to use in message +subroutine myStats(array, missing, G, k, mesg, unscale, full_halo) + type(ocean_grid_type), intent(in) :: G !< Ocean grid type + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: array !< input array in arbitrary units [A ~> a] + real, intent(in) :: missing !< missing value in arbitrary units [A ~> a] + integer, intent(in) :: k !< Level to calculate statistics for + character(len=*), intent(in) :: mesg !< Label to use in message + real, optional, intent(in) :: unscale !< A scaling factor for output that countacts + !! any internal dimesional scaling [a A-1 ~> 1] + logical, optional, intent(in) :: full_halo !< If present and true, test values on the whole + !! array rather than just the computational domain. ! Local variables - real :: minA, maxA - integer :: i,j + real :: minA ! Minimum value in the array in the arbitrary units of the input array [A ~> a] + real :: maxA ! Maximum value in the array in the arbitrary units of the input array [A ~> a] + real :: scl ! A factor for undoing any scaling of the array statistics for output [a A-1 ~> 1] + integer :: i, j, is, ie, js, je logical :: found character(len=120) :: lMesg - minA = 9.E24 ; maxA = -9.E24 ; found = .false. + + scl = 1.0 ; if (present(unscale)) scl = unscale + minA = 9.E24 / scl ; maxA = -9.E24 / scl ; found = .false. + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + if (present(full_halo)) then ; if (full_halo) then + is = G%isd ; ie = G%ied ; js = G%jsd ; je = G%jed + endif ; endif do j=js,je ; do i=is,ie if (array(i,j) /= array(i,j)) stop 'Nan!' @@ -67,8 +89,8 @@ subroutine myStats(array, missing, is, ie, js, je, k, mesg) call min_across_PEs(minA) call max_across_PEs(maxA) if (is_root_pe()) then - write(lMesg(1:120),'(2(a,es12.4),a,i3,x,a)') & - 'init_from_Z: min=',minA,' max=',maxA,' Level=',k,trim(mesg) + write(lMesg(1:120),'(2(a,es12.4),a,I0,1x,a)') & + 'init_from_Z: min=',minA*scl,' max=',maxA*scl,' Level=',k,trim(mesg) call MOM_mesg(lMesg,2) endif @@ -77,50 +99,48 @@ end subroutine myStats !> Use ICE-9 algorithm to populate points (fill=1) with valid data (good=1). If no information !! is available, use a previous guess (prev). Optionally (smooth) blend the filled points to !! achieve a more desirable result. -subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, debug, answers_2018) - use MOM_coms, only : sum_across_PEs - +subroutine fill_miss_2d(aout, good, fill, prev, G, acrit, num_pass, relc, debug, answer_date) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. real, dimension(SZI_(G),SZJ_(G)), & - intent(inout) :: aout !< The array with missing values to fill + intent(inout) :: aout !< The array with missing values to fill [arbitrary] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: good !< Valid data mask for incoming array - !! (1==good data; 0==missing data). + !! (1==good data; 0==missing data) [nondim]. real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: fill !< Same shape array of points which need - !! filling (1==fill;0==dont fill) + !! filling (1==fill;0==dont fill) [nondim] real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(in) :: prev !< First guess where isolated holes exist. - logical, optional, intent(in) :: smooth !< If present and true, apply a number of - !! Laplacian iterations to the interpolated data + intent(in) :: prev !< First guess where isolated holes exist [arbitrary] + real, intent(in) :: acrit !< A minimal value for deltas between iterations that + !! determines when the smoothing has converged [arbitrary]. integer, optional, intent(in) :: num_pass !< The maximum number of iterations - real, optional, intent(in) :: relc !< A relaxation coefficient for Laplacian (ND) - real, optional, intent(in) :: crit !< A minimal value for deltas between iterations. + real, optional, intent(in) :: relc !< A relaxation coefficient for Laplacian [nondim] logical, optional, intent(in) :: debug !< If true, write verbose debugging messages. - logical, optional, intent(in) :: answers_2018 !< If true, use expressions that give the same - !! answers as the code did in late 2018. Otherwise + integer, optional, intent(in) :: answer_date !< The vintage of the expressions in the code. + !! Dates before 20190101 give the same answers + !! as the code did in late 2018, while later versions !! add parentheses for rotational symmetry. - real, dimension(SZI_(G),SZJ_(G)) :: a_filled ! The aout with missing values filled in - real, dimension(SZI_(G),SZJ_(G)) :: a_chg ! The change in aout due to an iteration of smoothing - real, dimension(SZI_(G),SZJ_(G)) :: fill_pts ! 1 for points that still need to be filled - real, dimension(SZI_(G),SZJ_(G)) :: good_ ! The values that are valid for the current iteration - real, dimension(SZI_(G),SZJ_(G)) :: good_new ! The values of good_ to use for the next iteration - - real :: east, west, north, south ! Valid neighboring values or 0 for invalid values - real :: ge, gw, gn, gs ! Flags indicating which neighbors have valid values - real :: ngood ! The number of valid values in neighboring points - logical :: do_smooth ! Indicates whether to do smoothing of the array - real :: nfill ! The remaining number of points to fill - real :: nfill_prev ! The previous value of nfill + real, dimension(SZI_(G),SZJ_(G)) :: a_filled ! The aout with missing values filled in [arbitrary] + real, dimension(SZI_(G),SZJ_(G)) :: a_chg ! The change in aout due to an iteration of smoothing [arbitrary] + real, dimension(SZI_(G),SZJ_(G)) :: fill_pts ! 1 for points that still need to be filled [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: good_ ! The values that are valid for the current iteration [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: good_new ! The values of good_ to use for the next iteration [nondim] + + real :: east, west, north, south ! Valid neighboring values or 0 for invalid values [arbitrary] + real :: ge, gw, gn, gs ! Flags set to 0 or 1 indicating which neighbors have valid values [nondim] + real :: ngood ! The number of valid values in neighboring points [nondim] + real :: nfill ! The remaining number of points to fill [nondim] + real :: nfill_prev ! The previous value of nfill [nondim] character(len=256) :: mesg ! The text of an error message integer :: i, j, k integer, parameter :: num_pass_default = 10000 - real, parameter :: relc_default = 0.25, crit_default = 1.e-3 + real, parameter :: relc_default = 0.25 ! The default relaxation coefficient [nondim] - integer :: npass + integer :: npass ! The maximum number of passes of the Laplacian smoother integer :: is, ie, js, je - real :: relax_coeff, acrit, ares + real :: relax_coeff ! The grid-scale Laplacian relaxation coefficient per timestep [nondim] + real :: ares ! The maximum magnitude change in aout [A] logical :: debug_it, ans_2018 debug_it=.false. @@ -134,13 +154,7 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, relax_coeff = relc_default if (PRESENT(relc)) relax_coeff = relc - acrit = crit_default - if (PRESENT(crit)) acrit = crit - - do_smooth=.false. - if (PRESENT(smooth)) do_smooth=smooth - - ans_2018 = .true. ; if (PRESENT(answers_2018)) ans_2018 = answers_2018 + ans_2018 = .true. ; if (PRESENT(answer_date)) ans_2018 = (answer_date < 20190101) fill_pts(:,:) = fill(:,:) @@ -193,15 +207,15 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, nfill = sum(fill_pts(is:ie,js:je)) call sum_across_PEs(nfill) - if (nfill == nfill_prev .and. PRESENT(prev)) then + if (nfill == nfill_prev) then do j=js,je ; do i=is,ie ; if (fill_pts(i,j) == 1.0) then aout(i,j) = prev(i,j) fill_pts(i,j) = 0.0 endif ; enddo ; enddo elseif (nfill == nfill_prev) then call MOM_error(WARNING, & - 'Unable to fill missing points using either data at the same vertical level from a connected basin'//& - 'or using a point from a previous vertical level. Make sure that the original data has some valid'//& + 'Unable to fill missing points using either data at the same vertical level from a connected basin '//& + 'or using a point from a previous vertical level. Make sure that the original data has some valid '//& 'data in all basins.', .true.) write(mesg,*) 'nfill=',nfill call MOM_error(WARNING, mesg, .true.) @@ -214,25 +228,32 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, enddo ! while block for remaining points to fill. ! Do Laplacian smoothing for the points that have been filled in. - if (do_smooth) then ; do k=1,npass + do k=1,npass call pass_var(aout,G%Domain) - do j=js,je ; do i=is,ie - if (fill(i,j) == 1) then - east = max(good(i+1,j),fill(i+1,j)) ; west = max(good(i-1,j),fill(i-1,j)) - north = max(good(i,j+1),fill(i,j+1)) ; south = max(good(i,j-1),fill(i,j-1)) - if (ans_2018) then + + a_chg(:,:) = 0.0 + if (ans_2018) then + do j=js,je ; do i=is,ie + if (fill(i,j) == 1) then + east = max(good(i+1,j),fill(i+1,j)) ; west = max(good(i-1,j),fill(i-1,j)) + north = max(good(i,j+1),fill(i,j+1)) ; south = max(good(i,j-1),fill(i,j-1)) a_chg(i,j) = relax_coeff*(south*aout(i,j-1)+north*aout(i,j+1) + & west*aout(i-1,j)+east*aout(i+1,j) - & (south+north+west+east)*aout(i,j)) - else - a_chg(i,j) = relax_coeff*( ((south*aout(i,j-1) + north*aout(i,j+1)) + & - (west*aout(i-1,j)+east*aout(i+1,j))) - & - ((south+north)+(west+east))*aout(i,j) ) endif - else - a_chg(i,j) = 0. - endif - enddo ; enddo + enddo ; enddo + else + do j=js,je ; do i=is,ie + if (fill(i,j) == 1) then + ge = max(good(i+1,j),fill(i+1,j)) ; gw = max(good(i-1,j),fill(i-1,j)) + gn = max(good(i,j+1),fill(i,j+1)) ; gs = max(good(i,j-1),fill(i,j-1)) + a_chg(i,j) = relax_coeff*( ((gs*aout(i,j-1) + gn*aout(i,j+1)) + & + (gw*aout(i-1,j) + ge*aout(i+1,j))) - & + ((gs + gn) + (gw + ge))*aout(i,j) ) + endif + enddo ; enddo + endif + ares = 0.0 do j=js,je ; do i=is,ie aout(i,j) = a_chg(i,j) + aout(i,j) @@ -240,7 +261,7 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, enddo ; enddo call max_across_PEs(ares) if (ares <= acrit) exit - enddo ; endif + enddo do j=js,je ; do i=is,ie if (good_(i,j) == 0.0 .and. fill_pts(i,j) == 1.0) then @@ -249,81 +270,108 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, call MOM_error(FATAL,"MOM_initialize: "// & "fill is true and good is false after fill_miss, how did this happen? ") endif - enddo ; enddo + enddo ; enddo end subroutine fill_miss_2d !> Extrapolate and interpolate from a file record -subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, recnum, G, tr_z, & - mask_z, z_in, z_edges_in, missing_value, reentrant_x, & - tripolar_n, homogenize, m_to_Z, answers_2018, ongrid) +subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr_z, mask_z, & + z_in, z_edges_in, missing_value, scale, & + homogenize, m_to_Z, answers_2018, ongrid, tr_iter_tol, answer_date) character(len=*), intent(in) :: filename !< Path to file containing tracer to be !! interpolated. character(len=*), intent(in) :: varnam !< Name of tracer in file. - real, intent(in) :: conversion !< Conversion factor for tracer. integer, intent(in) :: recnum !< Record number of tracer to be read. type(ocean_grid_type), intent(inout) :: G !< Grid object real, allocatable, dimension(:,:,:), intent(out) :: tr_z - !< pointer to allocatable tracer array on local - !! model grid and input-file vertical levels. + !< Allocatable tracer array on the horizontal + !! model grid and input-file vertical levels + !! in arbitrary units [A ~> a] real, allocatable, dimension(:,:,:), intent(out) :: mask_z - !< pointer to allocatable tracer mask array on - !! local model grid and input-file vertical levels. + !< Allocatable tracer mask array on the horizontal + !! model grid and input-file vertical levels [nondim] real, allocatable, dimension(:), intent(out) :: z_in - !< Cell grid values for input data. + !< Cell grid values for input data [Z ~> m] real, allocatable, dimension(:), intent(out) :: z_edges_in - !< Cell grid edge values for input data. - real, intent(out) :: missing_value !< The missing value in the returned array. - logical, intent(in) :: reentrant_x !< If true, this grid is reentrant in the x-direction - logical, intent(in) :: tripolar_n !< If true, this is a northern tripolar grid + !< Cell grid edge values for input data [Z ~> m] + real, intent(out) :: missing_value !< The missing value in the returned array, scaled + !! to avoid accidentally having valid values match + !! missing values in the same units as tr_z [A ~> a] + real, intent(in) :: scale !< Scaling factor for tracer into the internal + !! units of the model for the units in the file [A a-1 ~> 1] logical, optional, intent(in) :: homogenize !< If present and true, horizontally homogenize data !! to produce perfectly "flat" initial conditions real, optional, intent(in) :: m_to_Z !< A conversion factor from meters to the units - !! of depth. If missing, G%bathyT must be in m. + !! of depth [Z m-1 ~> 1]. If missing, G%bathyT must be in m. logical, optional, intent(in) :: answers_2018 !< If true, use expressions that give the same !! answers as the code did in late 2018. Otherwise !! add parentheses for rotational symmetry. logical, optional, intent(in) :: ongrid !< If true, then data are assumed to have been interpolated !! to the model horizontal grid. In this case, only !! extrapolation is performed by this routine + real, optional, intent(in) :: tr_iter_tol !< The tolerance for changes in tracer concentrations + !! between smoothing iterations that determines when to + !! stop iterating in the same units as tr_z [A ~> a] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions in the code. + !! Dates before 20190101 give the same answers + !! as the code did in late 2018, while later versions + !! add parentheses for rotational symmetry. ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums real, dimension(:,:), allocatable :: tr_in !< A 2-d array for holding input data on its - !! native horizontal grid. - real, dimension(:,:), allocatable :: tr_inp !< Native horizontal grid data extended to the poles. - real, dimension(:,:), allocatable :: mask_in ! A 2-d mask for extended input grid. - - real :: PI_180 - integer :: rcode, ncid, varid, ndims, id, jd, kd, jdp + !! native horizontal grid, with units that change + !! as the input data is interpreted [a] then [A ~> a] + real, dimension(:,:,:), allocatable :: tr_in_full !< A 3-d array for holding input data on the + !! model horizontal grid, with units that change + !! as the input data is interpreted [a] then [A ~> a] + real, dimension(:,:), allocatable :: tr_inp !< Native horizontal grid data extended to the poles + !! with units that change as the input data is + !! interpreted [a] then [A ~> a] + real, dimension(:,:), allocatable :: mask_in ! A 2-d mask for extended input grid [nondim] + + real :: PI_180 ! A conversion factor from degrees to radians [radians degree-1] + integer :: id, jd, kd, jdp ! Input dataset data sizes integer :: i, j, k - integer, dimension(4) :: start, count, dims, dim_id - real, dimension(:,:), allocatable :: x_in, y_in - real, dimension(:), allocatable :: lon_in, lat_in ! The longitude and latitude in the input file - real, dimension(:), allocatable :: lat_inp ! The input file latitudes expanded to the pole - real :: max_lat, min_lat, pole, max_depth, npole - real :: roundoff ! The magnitude of roundoff, usually ~2e-16. - real :: add_offset, scale_factor + integer, dimension(4) :: start, count + real, dimension(:,:), allocatable :: x_in ! Input file longitudes [radians] + real, dimension(:,:), allocatable :: y_in ! Input file latitudes [radians] + real, dimension(:), allocatable :: lon_in ! The longitudes in the input file [degreesE] then [radians] + real, dimension(:), allocatable :: lat_in ! The latitudes in the input file [degreesN] then [radians] + real, dimension(:), allocatable :: lat_inp ! The input file latitudes expanded to the pole [degreesN] then [radians] + real :: max_lat ! The maximum latitude on the input grid [degreesN] + real :: pole ! The sum of tracer values at the pole [a] + real :: max_depth ! The maximum depth of the ocean [Z ~> m] + real :: npole ! The number of points contributing to the pole value [nondim] + real :: missing_val_in ! The missing value in the input field [a] + real :: roundoff ! The magnitude of roundoff, usually ~2e-16 [nondim] + real :: add_offset, scale_factor ! File-specific conversion factors [a] or [nondim] + integer :: ans_date ! The vintage of the expressions and order of arithmetic to use + logical :: found_attr logical :: add_np logical :: is_ongrid - character(len=8) :: laynum type(horiz_interp_type) :: Interp + type(axis_info), dimension(4) :: axes_info ! Axis information used for regridding integer :: is, ie, js, je ! compute domain indices - integer :: isc, iec, jsc, jec ! global compute domain indices integer :: isg, ieg, jsg, jeg ! global extent integer :: isd, ied, jsd, jed ! data domain indices integer :: id_clock_read - character(len=12) :: dim_name(4) logical :: debug=.false. - real :: npoints, varAvg - real, dimension(SZI_(G),SZJ_(G)) :: lon_out, lat_out ! The longitude and latitude of points on the model grid - real, dimension(SZI_(G),SZJ_(G)) :: tr_out, mask_out ! The tracer and mask on the model grid - real, dimension(SZI_(G),SZJ_(G)) :: good ! Where the data is valid, this is 1. - real, dimension(SZI_(G),SZJ_(G)) :: fill ! 1 where the data needs to be filled in - real, dimension(SZI_(G),SZJ_(G)) :: tr_outf ! The tracer concentrations after Ice-9 - real, dimension(SZI_(G),SZJ_(G)) :: tr_prev ! The tracer concentrations in the layer above - real, dimension(SZI_(G),SZJ_(G)) :: good2 ! 1 where the data is valid after Ice-9 - real, dimension(SZI_(G),SZJ_(G)) :: fill2 ! 1 for points that still need to be filled after Ice-9 + real :: I_scale ! The inverse of the scale factor for diagnostic output [a A-1 ~> 1] + real :: dtr_iter_stop ! The tolerance for changes in tracer concentrations between smoothing + ! iterations that determines when to stop iterating [A ~> a] + real, dimension(SZI_(G),SZJ_(G)) :: lon_out ! The longitude of points on the model grid [radians] + real, dimension(SZI_(G),SZJ_(G)) :: lat_out ! The latitude of points on the model grid [radians] + real, dimension(SZI_(G),SZJ_(G)) :: tr_out ! The tracer on the model grid [A ~> a] + real, dimension(SZI_(G),SZJ_(G)) :: mask_out ! The mask on the model grid [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: good ! Where the data is valid, this is 1 [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: fill ! 1 where the data needs to be filled in [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: tr_outf ! The tracer concentrations after Ice-9 [A ~> a] + real, dimension(SZI_(G),SZJ_(G)) :: tr_prev ! The tracer concentrations in the layer above [A ~> a] + real, dimension(SZI_(G),SZJ_(G)) :: good2 ! 1 where the data is valid after Ice-9 [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: fill2 ! 1 for points that still need to be filled after Ice-9 [nondim] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -334,82 +382,54 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, is_ongrid = .false. if (present(ongrid)) is_ongrid = ongrid + dtr_iter_stop = 1.0e-3*scale + if (present(tr_iter_tol)) dtr_iter_stop = tr_iter_tol + + I_scale = 1.0 / scale + PI_180 = atan(1.0)/45. + ans_date = 20181231 + if (present(answers_2018)) then ; if (.not.answers_2018) ans_date = 20190101 ; endif + if (present(answer_date)) ans_date = answer_date + ! Open NetCDF file and if present, extract data and spatial coordinate information ! The convention adopted here requires that the data be written in (i,j,k) ordering. call cpu_clock_begin(id_clock_read) - rcode = NF90_OPEN(filename, NF90_NOWRITE, ncid) - if (rcode /= 0) call MOM_error(FATAL,"error opening file "//trim(filename)//& - " in hinterp_extrap") - rcode = NF90_INQ_VARID(ncid, varnam, varid) - if (rcode /= 0) call MOM_error(FATAL,"error finding variable "//trim(varnam)//& - " in file "//trim(filename)//" in hinterp_extrap") - - rcode = NF90_INQUIRE_VARIABLE(ncid, varid, ndims=ndims, dimids=dims) - if (rcode /= 0) call MOM_error(FATAL, "Error inquiring about the dimensions of "//trim(varnam)//& - " in file "//trim(filename)//" in hinterp_extrap") - if (ndims < 3) call MOM_error(FATAL,"Variable "//trim(varnam)//" in file "//trim(filename)// & - " has too few dimensions to be read as a 3-d array.") - - rcode = NF90_INQUIRE_DIMENSION(ncid, dims(1), dim_name(1), len=id) - if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 1 data for "// & - trim(varnam)//" in file "// trim(filename)//" in hinterp_extrap") - rcode = NF90_INQ_VARID(ncid, dim_name(1), dim_id(1)) - if (rcode /= 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(1))//& - " in file "//trim(filename)//" in hinterp_extrap") - rcode = NF90_INQUIRE_DIMENSION(ncid, dims(2), dim_name(2), len=jd) - if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 2 data for "// & - trim(varnam)//" in file "// trim(filename)//" in hinterp_extrap") - rcode = NF90_INQ_VARID(ncid, dim_name(2), dim_id(2)) - if (rcode /= 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(2))//& - " in file "//trim(filename)//" in hinterp_extrap") - rcode = NF90_INQUIRE_DIMENSION(ncid, dims(3), dim_name(3), len=kd) - if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 3 data for "// & - trim(varnam)//" in file "// trim(filename)//" in hinterp_extrap") - rcode = NF90_INQ_VARID(ncid, dim_name(3), dim_id(3)) - if (rcode /= 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(3))//& - " in file "//trim(filename)//" in hinterp_extrap") - - missing_value=0.0 - rcode = NF90_GET_ATT(ncid, varid, "_FillValue", missing_value) - if (rcode /= 0) call MOM_error(FATAL,"error finding missing value for "//trim(varnam)//& - " in file "// trim(filename)//" in hinterp_extrap") - - rcode = NF90_GET_ATT(ncid, varid, "add_offset", add_offset) - if (rcode /= 0) add_offset = 0.0 - - rcode = NF90_GET_ATT(ncid, varid, "scale_factor", scale_factor) - if (rcode /= 0) scale_factor = 1.0 + ! A note by MJH copied from elsewhere suggests that this code may be using the model connectivity + ! (e.g., reentrant or tripolar) but should use the dataset's connectivity instead. + + call get_var_axes_info(trim(filename), trim(varnam), axes_info) + + if (allocated(z_in)) deallocate(z_in) + if (allocated(z_edges_in)) deallocate(z_edges_in) + if (allocated(tr_z)) deallocate(tr_z) + if (allocated(mask_z)) deallocate(mask_z) + + call get_axis_info(axes_info(1),ax_size=id) + call get_axis_info(axes_info(2),ax_size=jd) + call get_axis_info(axes_info(3),ax_size=kd) allocate(lon_in(id), lat_in(jd), z_in(kd), z_edges_in(kd+1)) - allocate(tr_z(isd:ied,jsd:jed,kd), mask_z(isd:ied,jsd:jed,kd)) - - start = 1 ; count = 1 ; count(1) = id - rcode = NF90_GET_VAR(ncid, dim_id(1), lon_in, start, count) - if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 1 values for var_name "// & - trim(varnam)//",dim_name "//trim(dim_name(1))//" in file "// trim(filename)//" in hinterp_extrap") - start = 1 ; count = 1 ; count(1) = jd - rcode = NF90_GET_VAR(ncid, dim_id(2), lat_in, start, count) - if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 2 values for var_name "// & - trim(varnam)//",dim_name "//trim(dim_name(2))//" in file "// trim(filename)//" in hinterp_extrap") - start = 1 ; count = 1 ; count(1) = kd - rcode = NF90_GET_VAR(ncid, dim_id(3), z_in, start, count) - if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 3 values for var_name "// & - trim(varnam//",dim_name "//trim(dim_name(3)))//" in file "// trim(filename)//" in hinterp_extrap") + allocate(tr_z(isd:ied,jsd:jed,kd), source=0.0) + allocate(mask_z(isd:ied,jsd:jed,kd), source=0.0) + + call get_axis_info(axes_info(1),ax_data=lon_in) + call get_axis_info(axes_info(2),ax_data=lat_in) + call get_axis_info(axes_info(3),ax_data=z_in) call cpu_clock_end(id_clock_read) if (present(m_to_Z)) then ; do k=1,kd ; z_in(k) = m_to_Z * z_in(k) ; enddo ; endif - ! extrapolate the input data to the north pole using the northern-most latitude add_np = .false. jdp = jd if (.not. is_ongrid) then max_lat = maxval(lat_in) if (max_lat < 90.0) then + ! Extrapolate the input data to the north pole using the northern-most latitude. add_np = .true. jdp = jd+1 allocate(lat_inp(jdp)) @@ -422,6 +442,22 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, endif ! construct level cell boundaries as the mid-point between adjacent centers + ! Set the I/O attributes + call read_attribute(trim(filename), "_FillValue", missing_val_in, & + varname=trim(varnam), found=found_attr) + if (.not. found_attr) call MOM_error(FATAL, & + "error finding missing value for " // trim(varnam) // & + " in file " // trim(filename) // " in hinterp_extrap") + missing_value = scale * missing_val_in + + call read_attribute(trim(filename), "scale_factor", scale_factor, & + varname=trim(varnam), found=found_attr) + if (.not. found_attr) scale_factor = 1. + + call read_attribute(trim(filename), "add_offset", add_offset, & + varname=trim(varnam), found=found_attr) + if (.not. found_attr) add_offset = 0. + z_edges_in(1) = 0.0 do K=2,kd z_edges_in(K) = 0.5*(z_in(k-1)+z_in(k)) @@ -430,9 +466,10 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, if (is_ongrid) then allocate(tr_in(is:ie,js:je), source=0.0) + allocate(tr_in_full(is:ie,js:je,kd), source=0.0) allocate(mask_in(is:ie,js:je), source=0.0) else - call horiz_interp_init() + call horizontal_interp_init() lon_in = lon_in*PI_180 lat_in = lat_in*PI_180 allocate(x_in(id,jdp), y_in(id,jdp)) @@ -448,53 +485,55 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, call max_across_PEs(max_depth) if (z_edges_in(kd+1) < max_depth) z_edges_in(kd+1) = max_depth - roundoff = 3.0*EPSILON(missing_value) + roundoff = 3.0*EPSILON(missing_val_in) + + ! Loop through each data level and interpolate to model grid. + ! After interpolating, fill in points which will be needed to define the layers. + + if (is_ongrid) then + start(1) = is+G%HI%idg_offset ; start(2) = js+G%HI%jdg_offset ; start(3) = 1 + count(1) = ie-is+1 ; count(2) = je-js+1 ; count(3) = kd ; start(4) = 1 ; count(4) = 1 + call MOM_read_data(trim(filename), trim(varnam), tr_in_full, start, count, G%Domain) + endif - ! loop through each data level and interpolate to model grid. - ! after interpolating, fill in points which will be needed - ! to define the layers do k=1,kd - write(laynum,'(I8)') k ; laynum = adjustl(laynum) - mask_in = 0.0 - if (is_ongrid) then - start(1) = is+G%HI%idg_offset ; start(2) = js+G%HI%jdg_offset ; start(3) = k - count(1) = ie-is+1 ; count(2) = je-js+1; count(3) = 1 - rcode = NF90_GET_VAR(ncid,varid, tr_in, start, count) - if (rcode /= 0) call MOM_error(FATAL,"horiz_interp_and_extrap_tracer_record: "//& - "error reading level "//trim(laynum)//" of variable "//& - trim(varnam)//" in file "// trim(filename)) + mask_in(:,:) = 0.0 + tr_out(:,:) = 0.0 + if (is_ongrid) then + tr_in(is:ie,js:je) = tr_in_full(is:ie,js:je,k) do j=js,je do i=is,ie - if (abs(tr_in(i,j)-missing_value) > abs(roundoff*missing_value)) then + if (abs(tr_in(i,j)-missing_val_in) > abs(roundoff*missing_val_in)) then mask_in(i,j) = 1.0 - tr_in(i,j) = (tr_in(i,j)*scale_factor+add_offset) * conversion + tr_in(i,j) = (tr_in(i,j)*scale_factor+add_offset) * scale else tr_in(i,j) = missing_value endif enddo enddo - else - if (is_root_pe()) then - start = 1 ; start(3) = k ; count(:) = 1 ; count(1) = id ; count(2) = jd - rcode = NF90_GET_VAR(ncid,varid, tr_in, start, count) - if (rcode /= 0) call MOM_error(FATAL,"horiz_interp_and_extrap_tracer_record: "//& - "error reading level "//trim(laynum)//" of variable "//& - trim(varnam)//" in file "// trim(filename)) + tr_out(is:ie,js:je) = tr_in(is:ie,js:je) + + else ! .not.is_ongrid + + start(:) = 1 ; start(3) = k + count(:) = 1 ; count(1) = id ; count(2) = jd + call read_variable(trim(filename), trim(varnam), tr_in, start=start, nread=count) + if (is_root_pe()) then if (add_np) then pole = 0.0 ; npole = 0.0 do i=1,id - if (abs(tr_in(i,jd)-missing_value) > abs(roundoff*missing_value)) then + if (abs(tr_in(i,jd)-missing_val_in) > abs(roundoff*missing_val_in)) then pole = pole + tr_in(i,jd) npole = npole + 1.0 endif enddo if (npole > 0) then - pole=pole/npole + pole = pole / npole else - pole=missing_value + pole = missing_val_in endif tr_inp(:,1:jd) = tr_in(:,:) tr_inp(:,jdp) = pole @@ -505,80 +544,57 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, call broadcast(tr_inp, id*jdp, blocking=.true.) - do j=1,jdp - do i=1,id - if (abs(tr_inp(i,j)-missing_value) > abs(roundoff*missing_value)) then - mask_in(i,j) = 1.0 - tr_inp(i,j) = (tr_inp(i,j)*scale_factor+add_offset) * conversion - else - tr_inp(i,j) = missing_value - endif - enddo - enddo - - endif + do j=1,jdp ; do i=1,id + if (abs(tr_inp(i,j)-missing_val_in) > abs(roundoff*missing_val_in)) then + mask_in(i,j) = 1.0 + tr_inp(i,j) = (tr_inp(i,j)*scale_factor+add_offset) * scale + else + tr_inp(i,j) = missing_value + endif + enddo ; enddo -! call fms routine horiz_interp to interpolate input level data to model horizontal grid - if (.not. is_ongrid) then + ! call fms routine horiz_interp to interpolate input level data to model horizontal grid if (k == 1) then call build_horiz_interp_weights(Interp, x_in, y_in, lon_out(is:ie,js:je), lat_out(is:ie,js:je), & interp_method='bilinear', src_modulo=.true.) endif if (debug) then - call myStats(tr_inp,missing_value, is, ie, js, je, k,'Tracer from file') + call myStats(tr_inp, missing_value, G, k, 'Tracer from file', unscale=I_scale, full_halo=.true.) endif - endif - tr_out(:,:) = 0.0 - if (is_ongrid) then - tr_out(is:ie,js:je)=tr_in(is:ie,js:je) - else call run_horiz_interp(Interp, tr_inp, tr_out(is:ie,js:je), missing_value=missing_value) - endif + endif ! End of .not.is_ongrid - mask_out=1.0 - do j=js,je - do i=is,ie - if (abs(tr_out(i,j)-missing_value) < abs(roundoff*missing_value)) mask_out(i,j)=0. - enddo - enddo + mask_out(:,:) = 1.0 + do j=js,je ; do i=is,ie + if (abs(tr_out(i,j)-missing_value) < abs(roundoff*missing_value)) mask_out(i,j) = 0. + enddo ; enddo - fill = 0.0; good = 0.0 + fill(:,:) = 0.0 ; good(:,:) = 0.0 - nPoints = 0 ; varAvg = 0. - do j=js,je - do i=is,ie - if (mask_out(i,j) < 1.0) then - tr_out(i,j)=missing_value - else - good(i,j)=1.0 - nPoints = nPoints + 1 - varAvg = varAvg + tr_out(i,j) - endif - if ((G%mask2dT(i,j) == 1.0) .and. (z_edges_in(k) <= G%bathyT(i,j) + G%Z_ref) .and. & - (mask_out(i,j) < 1.0)) & - fill(i,j)=1.0 - enddo - enddo - call pass_var(fill,G%Domain) - call pass_var(good,G%Domain) + do j=js,je ; do i=is,ie + if (mask_out(i,j) < 1.0) then + tr_out(i,j) = missing_value + else + good(i,j) = 1.0 + endif + if ((G%mask2dT(i,j) == 1.0) .and. (z_edges_in(k) <= G%bathyT(i,j) + G%Z_ref) .and. & + (mask_out(i,j) < 1.0)) & + fill(i,j) = 1.0 + enddo ; enddo + + call pass_var(fill, G%Domain) + call pass_var(good, G%Domain) if (debug) then - call myStats(tr_out,missing_value, is,ie,js,je,k,'variable from horiz_interp()') + call myStats(tr_out, missing_value, G, k, 'variable from horiz_interp()', unscale=I_scale) endif ! Horizontally homogenize data to produce perfectly "flat" initial conditions - if (PRESENT(homogenize)) then - if (homogenize) then - call sum_across_PEs(nPoints) - call sum_across_PEs(varAvg) - if (nPoints>0) then - varAvg = varAvg/real(nPoints) - endif - tr_out(:,:) = varAvg - endif - endif + if (PRESENT(homogenize)) then ; if (homogenize) then + call homogenize_field(tr_out, G, tmp_scale=I_scale, weights=mask_out, answer_date=answer_date) + endif ; endif ! tr_out contains input z-space data on the model grid with missing values ! now fill in missing values using "ICE-nine" algorithm. @@ -587,9 +603,9 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, good2(:,:) = good(:,:) fill2(:,:) = fill(:,:) - call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, smooth=.true., answers_2018=answers_2018) + call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, dtr_iter_stop, answer_date=ans_date) if (debug) then - call myStats(tr_outf, missing_value, is, ie, js, je, k, 'field from fill_miss_2d()') + call myStats(tr_outf, missing_value, G, k, 'field from fill_miss_2d()', unscale=I_scale) endif tr_z(:,:,k) = tr_outf(:,:) * G%mask2dT(:,:) @@ -598,84 +614,112 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, tr_prev(:,:) = tr_z(:,:,k) if (debug) then - call hchksum(tr_prev,'field after fill ',G%HI) + call hchksum(tr_prev, 'field after fill ', G%HI, unscale=I_scale) endif enddo ! kd + if (allocated(lat_inp)) deallocate(lat_inp) + deallocate(tr_in) + if (allocated(tr_inp)) deallocate(tr_inp) + if (allocated(tr_in_full)) deallocate(tr_in_full) + end subroutine horiz_interp_and_extrap_tracer_record !> Extrapolate and interpolate using a FMS time interpolation handle -subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, tr_z, mask_z, & - z_in, z_edges_in, missing_value, reentrant_x, & - tripolar_n, homogenize, spongeOngrid, m_to_Z, answers_2018) +subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & + z_in, z_edges_in, missing_value, scale, & + homogenize, spongeOngrid, m_to_Z, & + answers_2018, tr_iter_tol, answer_date, & + axes) - integer, intent(in) :: fms_id !< A unique id used by the FMS time interpolator + type(external_field), intent(in) :: field !< Handle for the time interpolated field type(time_type), intent(in) :: Time !< A FMS time type - real, intent(in) :: conversion !< Conversion factor for tracer. type(ocean_grid_type), intent(inout) :: G !< Grid object real, allocatable, dimension(:,:,:), intent(out) :: tr_z - !< pointer to allocatable tracer array on local - !! model grid and native vertical levels. + !< Allocatable tracer array on the horizontal + !! model grid and input-file vertical levels + !! in arbitrary units [A ~> a] real, allocatable, dimension(:,:,:), intent(out) :: mask_z - !< pointer to allocatable tracer mask array on - !! local model grid and native vertical levels. + !< Allocatable tracer mask array on the horizontal + !! model grid and input-file vertical levels [nondim] real, allocatable, dimension(:), intent(out) :: z_in - !< Cell grid values for input data. + !< Cell grid values for input data [Z ~> m] real, allocatable, dimension(:), intent(out) :: z_edges_in - !< Cell grid edge values for input data. - real, intent(out) :: missing_value !< The missing value in the returned array. - logical, intent(in) :: reentrant_x !< If true, this grid is reentrant in the x-direction - logical, intent(in) :: tripolar_n !< If true, this is a northern tripolar grid + !< Cell grid edge values for input data [Z ~> m] + real, intent(out) :: missing_value !< The missing value in the returned array, scaled + !! to avoid accidentally having valid values match + !! missing values, in the same arbitrary units as tr_z [A ~> a] + real, intent(in) :: scale !< Scaling factor for tracer into the internal + !! units of the model [A a-1 ~> 1] logical, optional, intent(in) :: homogenize !< If present and true, horizontally homogenize data !! to produce perfectly "flat" initial conditions logical, optional, intent(in) :: spongeOngrid !< If present and true, the sponge data are on the model grid real, optional, intent(in) :: m_to_Z !< A conversion factor from meters to the units - !! of depth. If missing, G%bathyT must be in m. + !! of depth [Z m-1 ~> 1]. If missing, G%bathyT must be in m. logical, optional, intent(in) :: answers_2018 !< If true, use expressions that give the same !! answers as the code did in late 2018. Otherwise !! add parentheses for rotational symmetry. + real, optional, intent(in) :: tr_iter_tol !< The tolerance for changes in tracer concentrations + !! between smoothing iterations that determines when to + !! stop iterating, in the same arbitrary units as tr_z [A ~> a] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions in the code. + !! Dates before 20190101 give the same answers + !! as the code did in late 2018, while later versions + !! add parentheses for rotational symmetry. + type(axis_info), allocatable, dimension(:), optional, intent(inout) :: axes !< Axis types for the input data ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums real, dimension(:,:), allocatable :: tr_in !< A 2-d array for holding input data on its - !! native horizontal grid. - real, dimension(:,:), allocatable :: tr_inp !< Native horizontal grid data extended to the poles. + !! native horizontal grid, with units that change + !! as the input data is interpreted [a] then [A ~> a] + real, dimension(:,:), allocatable :: tr_inp !< Native horizontal grid data extended to the poles + !! with units that change as the input data is + !! interpreted [a] then [A ~> a] real, dimension(:,:,:), allocatable :: data_in !< A buffer for storing the full 3-d time-interpolated array - !! on the original grid - real, dimension(:,:), allocatable :: mask_in !< A 2-d mask for extended input grid. - - real :: PI_180 - integer :: rcode, ncid, varid, ndims, id, jd, kd, jdp - integer :: i,j,k - integer, dimension(4) :: start, count, dims, dim_id - real, dimension(:,:), allocatable :: x_in, y_in - real, dimension(:), allocatable :: lon_in, lat_in ! The longitude and latitude in the input file - real, dimension(:), allocatable :: lat_inp ! The input file latitudes expanded to the pole - real :: max_lat, min_lat, pole, max_depth, npole - real :: roundoff ! The magnitude of roundoff, usually ~2e-16. + !! on the original grid [a] + real, dimension(:,:), allocatable :: mask_in !< A 2-d mask for extended input grid [nondim] + + real :: PI_180 ! A conversion factor from degrees to radians [radians degree-1] + integer :: id, jd, kd, jdp ! Input dataset data sizes + integer :: i, j, k + real, dimension(:,:), allocatable :: x_in ! Input file longitudes [radians] + real, dimension(:,:), allocatable :: y_in ! Input file latitudes [radians] + real, dimension(:), allocatable :: lon_in ! The longitudes in the input file [degreesE] then [radians] + real, dimension(:), allocatable :: lat_in ! The latitudes in the input file [degreesN] then [radians] + real, dimension(:), allocatable :: lat_inp ! The input file latitudes expanded to the pole [degreesN] then [radians] + real :: max_lat ! The maximum latitude on the input grid [degreesN] + real :: pole ! The sum of tracer values at the pole [a] + real :: max_depth ! The maximum depth of the ocean [Z ~> m] + real :: npole ! The number of points contributing to the pole value [nondim] + real :: missing_val_in ! The missing value in the input field [a] + real :: roundoff ! The magnitude of roundoff, usually ~2e-16 [nondim] logical :: add_np - character(len=8) :: laynum type(horiz_interp_type) :: Interp - type(axistype), dimension(4) :: axes_data + type(axis_info), dimension(4) :: axes_data integer :: is, ie, js, je ! compute domain indices - integer :: isc,iec,jsc,jec ! global compute domain indices integer :: isg, ieg, jsg, jeg ! global extent integer :: isd, ied, jsd, jed ! data domain indices integer :: id_clock_read integer, dimension(4) :: fld_sz - character(len=12) :: dim_name(4) logical :: debug=.false. - logical :: spongeDataOngrid - logical :: ans_2018 - real :: npoints, varAvg - real, dimension(SZI_(G),SZJ_(G)) :: lon_out, lat_out ! The longitude and latitude of points on the model grid - real, dimension(SZI_(G),SZJ_(G)) :: tr_out, mask_out ! The tracer and mask on the model grid - real, dimension(SZI_(G),SZJ_(G)) :: good ! Where the data is valid, this is 1. - real, dimension(SZI_(G),SZJ_(G)) :: fill ! 1 where the data needs to be filled in - real, dimension(SZI_(G),SZJ_(G)) :: tr_outf ! The tracer concentrations after Ice-9 - real, dimension(SZI_(G),SZJ_(G)) :: tr_prev ! The tracer concentrations in the layer above - real, dimension(SZI_(G),SZJ_(G)) :: good2 ! 1 where the data is valid after Ice-9 - real, dimension(SZI_(G),SZJ_(G)) :: fill2 ! 1 for points that still need to be filled after Ice-9 + logical :: is_ongrid + integer :: ans_date ! The vintage of the expressions and order of arithmetic to use + real :: I_scale ! The inverse of the scale factor for diagnostic output [a A-1 ~> 1] + real :: dtr_iter_stop ! The tolerance for changes in tracer concentrations between smoothing + ! iterations that determines when to stop iterating [A ~> a] + real, dimension(SZI_(G),SZJ_(G)) :: lon_out ! The longitude of points on the model grid [radians] + real, dimension(SZI_(G),SZJ_(G)) :: lat_out ! The latitude of points on the model grid [radians] + real, dimension(SZI_(G),SZJ_(G)) :: tr_out ! The tracer on the model grid [A ~> a] + real, dimension(SZI_(G),SZJ_(G)) :: mask_out ! The mask on the model grid [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: good ! Where the data is valid, this is 1 [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: fill ! 1 where the data needs to be filled in [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: tr_outf ! The tracer concentrations after Ice-9 [A ~> a] + real, dimension(SZI_(G),SZJ_(G)) :: tr_prev ! The tracer concentrations in the layer above [A ~> a] + real, dimension(SZI_(G),SZJ_(G)) :: good2 ! 1 where the data is valid after Ice-9 [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: fill2 ! 1 for points that still need to be filled after Ice-9 [nondim] integer :: turns integer :: verbosity @@ -687,44 +731,62 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t id_clock_read = cpu_clock_id('(Initialize tracer from Z) read', grain=CLOCK_LOOP) + dtr_iter_stop = 1.0e-3*scale + if (present(tr_iter_tol)) dtr_iter_stop = tr_iter_tol + + I_scale = 1.0 / scale + PI_180 = atan(1.0)/45. - ans_2018 = .true.;if (present(answers_2018)) ans_2018 = answers_2018 + ans_date = 20181231 + if (present(answers_2018)) then ; if (.not.answers_2018) ans_date = 20190101 ; endif + if (present(answer_date)) ans_date = answer_date ! Open NetCDF file and if present, extract data and spatial coordinate information ! The convention adopted here requires that the data be written in (i,j,k) ordering. call cpu_clock_begin(id_clock_read) - call get_external_field_info(fms_id, size=fld_sz, axes=axes_data, missing=missing_value) + if (present(axes) .and. allocated(axes)) then + call get_external_field_info(field, size=fld_sz, missing=missing_val_in) + axes_data = axes + else + call get_external_field_info(field, size=fld_sz, axes=axes_data, missing=missing_val_in) + if (present(axes)) then + allocate(axes(4)) + axes = axes_data + endif + endif + missing_value = scale*missing_val_in verbosity = MOM_get_verbosity() id = fld_sz(1) ; jd = fld_sz(2) ; kd = fld_sz(3) - spongeDataOngrid = .false. - if (PRESENT(spongeOngrid)) spongeDataOngrid = spongeOngrid - if (.not. spongeDataOngrid) then + is_ongrid = .false. + if (PRESENT(spongeOngrid)) is_ongrid = spongeOngrid + if (.not. is_ongrid) then allocate(lon_in(id), lat_in(jd)) - call get_axis_data(axes_data(1), lon_in) - call get_axis_data(axes_data(2), lat_in) + call get_axis_info(axes_data(1), ax_data=lon_in) + call get_axis_info(axes_data(2), ax_data=lat_in) endif allocate(z_in(kd), z_edges_in(kd+1)) - allocate(tr_z(isd:ied,jsd:jed,kd), mask_z(isd:ied,jsd:jed,kd)) + allocate(tr_z(isd:ied,jsd:jed,kd), source=0.0) + allocate(mask_z(isd:ied,jsd:jed,kd), source=0.0) - call get_axis_data(axes_data(3), z_in) + call get_axis_info(axes_data(3), ax_data=z_in) if (present(m_to_Z)) then ; do k=1,kd ; z_in(k) = m_to_Z * z_in(k) ; enddo ; endif call cpu_clock_end(id_clock_read) - if (.not. spongeDataOngrid) then - ! Extrapolate the input data to the north pole using the northerm-most latitude. + if (.not. is_ongrid) then max_lat = maxval(lat_in) add_np = .false. if (max_lat < 90.0) then + ! Extrapolate the input data to the north pole using the northern-most latitude. add_np = .true. jdp = jd+1 allocate(lat_inp(jdp)) @@ -736,7 +798,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t else jdp = jd endif - call horiz_interp_init() + call horizontal_interp_init() lon_in = lon_in*PI_180 lat_in = lat_in*PI_180 allocate(x_in(id,jdp), y_in(id,jdp)) @@ -750,43 +812,43 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t else allocate(data_in(isd:ied,jsd:jed,kd)) endif - ! construct level cell boundaries as the mid-point between adjacent centers + + ! Construct level cell boundaries as the mid-point between adjacent centers. z_edges_in(1) = 0.0 - do k=2,kd - z_edges_in(k) = 0.5*(z_in(k-1)+z_in(k)) + do K=2,kd + z_edges_in(K) = 0.5*(z_in(k-1)+z_in(k)) enddo z_edges_in(kd+1) = 2.0*z_in(kd) - z_in(kd-1) - - max_depth = maxval(G%bathyT) + G%Z_ref + max_depth = maxval(G%bathyT(:,:)) + G%Z_ref call max_across_PEs(max_depth) - if (z_edges_in(kd+1)5), turns=turns) + call time_interp_external(field, Time, data_in, verbose=(verbosity>5), turns=turns) + ! Loop through each data level and interpolate to model grid. ! After interpolating, fill in points which will be needed to define the layers. do k=1,kd - write(laynum,'(I8)') k ; laynum = adjustl(laynum) if (is_root_pe()) then tr_in(1:id,1:jd) = data_in(1:id,1:jd,k) if (add_np) then pole = 0.0 ; npole = 0.0 do i=1,id - if (abs(tr_in(i,jd)-missing_value) > abs(roundoff*missing_value)) then + if (abs(tr_in(i,jd)-missing_val_in) > abs(roundoff*missing_val_in)) then pole = pole + tr_in(i,jd) - npole = npole+1.0 + npole = npole + 1.0 endif enddo if (npole > 0) then pole = pole / npole else - pole = missing_value + pole = missing_val_in endif tr_inp(:,1:jd) = tr_in(:,:) tr_inp(:,jdp) = pole @@ -800,9 +862,9 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t mask_in(:,:) = 0.0 do j=1,jdp ; do i=1,id - if (abs(tr_inp(i,j)-missing_value) > abs(roundoff*missing_value)) then + if (abs(tr_inp(i,j)-missing_val_in) > abs(roundoff*missing_val_in)) then mask_in(i,j) = 1.0 - tr_inp(i,j) = tr_inp(i,j) * conversion + tr_inp(i,j) = tr_inp(i,j) * scale else tr_inp(i,j) = missing_value endif @@ -815,7 +877,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t endif if (debug) then - call myStats(tr_in, missing_value, 1, id, 1, jd, k, 'Tracer from file') + call myStats(tr_inp, missing_value, G, k, 'Tracer from file', unscale=I_scale, full_halo=.true.) endif tr_out(:,:) = 0.0 @@ -829,14 +891,11 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t fill(:,:) = 0.0 ; good(:,:) = 0.0 - nPoints = 0 ; varAvg = 0. do j=js,je ; do i=is,ie if (mask_out(i,j) < 1.0) then tr_out(i,j) = missing_value else good(i,j) = 1.0 - nPoints = nPoints + 1 - varAvg = varAvg + tr_out(i,j) endif if ((G%mask2dT(i,j) == 1.0) .and. (z_edges_in(k) <= G%bathyT(i,j) + G%Z_ref) .and. & (mask_out(i,j) < 1.0)) & @@ -846,17 +905,12 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t call pass_var(good, G%Domain) if (debug) then - call myStats(tr_out, missing_value, is, ie, js, je, k, 'variable from horiz_interp()') + call myStats(tr_out, missing_value, G, k, 'variable from horiz_interp()', unscale=I_scale) endif ! Horizontally homogenize data to produce perfectly "flat" initial conditions if (PRESENT(homogenize)) then ; if (homogenize) then - call sum_across_PEs(nPoints) - call sum_across_PEs(varAvg) - if (nPoints>0) then - varAvg = varAvg/real(nPoints) - endif - tr_out(:,:) = varAvg + call homogenize_field(tr_out, G, tmp_scale=I_scale, weights=mask_out, answer_date=answer_date) endif ; endif ! tr_out contains input z-space data on the model grid with missing values @@ -866,43 +920,130 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t good2(:,:) = good(:,:) fill2(:,:) = fill(:,:) - call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, smooth=.true., answers_2018=answers_2018) + call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, dtr_iter_stop, answer_date=ans_date) ! if (debug) then -! call hchksum(tr_outf, 'field from fill_miss_2d ', G%HI) +! call hchksum(tr_outf, 'field from fill_miss_2d ', G%HI, unscale=I_scale) +! call myStats(tr_outf, missing_value, G, k, 'field from fill_miss_2d()', unscale=I_scale) ! endif -! call myStats(tr_outf, missing_value, is, ie, js, je, k, 'field from fill_miss_2d()') - - tr_z(:,:,k) = tr_outf(:,:)*G%mask2dT(:,:) + tr_z(:,:,k) = tr_outf(:,:) * G%mask2dT(:,:) mask_z(:,:,k) = good2(:,:) + fill2(:,:) tr_prev(:,:) = tr_z(:,:,k) if (debug) then - call hchksum(tr_prev,'field after fill ',G%HI) + call hchksum(tr_prev, 'field after fill ', G%HI, unscale=I_scale) endif enddo ! kd else - call time_interp_external(fms_id, Time, data_in, verbose=(verbosity>5), turns=turns) - do k=1,kd - do j=js,je - do i=is,ie - tr_z(i,j,k)=data_in(i,j,k) - if (.not. ans_2018) mask_z(i,j,k) = 1. - if (abs(tr_z(i,j,k)-missing_value) < abs(roundoff*missing_value)) mask_z(i,j,k) = 0. - enddo + call time_interp_external(field, Time, data_in, verbose=(verbosity>5), turns=turns) + do k=1,kd + do j=js,je + do i=is,ie + tr_z(i,j,k) = data_in(i,j,k) * scale + if (ans_date >= 20190101) mask_z(i,j,k) = 1. + if (abs(tr_z(i,j,k)-missing_value) < abs(roundoff*missing_value)) mask_z(i,j,k) = 0. enddo enddo + enddo endif + end subroutine horiz_interp_and_extrap_tracer_fms_id +!> Replace all values of a 2-d field with the weighted average over the valid points. +subroutine homogenize_field(field, G, tmp_scale, weights, answer_date, wt_unscale) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid type + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: field !< The tracer on the model grid in arbitrary units [A ~> a] + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the + !! return value [a A-1 ~> 1] + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: weights !< The weights for the tracer in arbitrary units that + !! typically differ from those used by field [B ~> b] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions in the code. + !! Dates before 20230101 use non-reproducing sums + !! in their averages, while later versions use + !! reproducing sums for rotational symmetry and + !! consistency across PE layouts. + real, optional, intent(in) :: wt_unscale !< A factor that undoes any dimensional scaling + !! of the weights so that they can be used with + !! reproducing sums [b B-1 ~> 1] + + ! Local variables + ! In the following comments, [A] and [B] are used to indicate the arbitrary, possibly rescaled + ! units of the input field and the weighting array, while [a] and [b] indicate the corresponding + ! unscaled (e.g., mks) units that can be used with the reproducing sums + real, dimension(G%isc:G%iec, G%jsc:G%jec) :: field_for_Sums ! The field times the weights [A B ~> a b] + real, dimension(G%isc:G%iec, G%jsc:G%jec) :: weight ! A copy of weights, if it is present, or the + ! tracer-point grid mask if it weights is absent [B ~> b] + real :: var_unscale ! The reciprocal of the scaling factor for the field and weights [a b A-1 B-1 ~> 1] + real :: wt_sum ! The sum of the weights, in [B ~> b] + real :: varsum ! The weighted sum of field being averaged [A B ~> a b] + real :: varAvg ! The average of the field [A ~> a] + logical :: use_repro_sums ! If true, use reproducing sums. + integer :: i, j, is, ie, js, je + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + varAvg = 0.0 ! This value will be used if wt_sum is 0. + + use_repro_sums = .false. ; if (present(answer_date)) use_repro_sums = (answer_date >= 20230101) + + if (present(weights)) then + do j=js,je ; do i=is,ie + weight(i,j) = weights(i,j) + enddo ; enddo + else + do j=js,je ; do i=is,ie + weight(i,j) = G%mask2dT(i,j) + enddo ; enddo + endif + + if (use_repro_sums) then + var_unscale = 1.0 ; if (present(tmp_scale)) var_unscale = tmp_scale + if (present(wt_unscale)) var_unscale = wt_unscale * var_unscale + + do j=js,je ; do i=is,ie + field_for_Sums(i,j) = field(i,j) * weight(i,j) + enddo ; enddo + + wt_sum = reproducing_sum(weight, unscale=wt_unscale) + if (abs(wt_sum) > 0.0) & + varAvg = reproducing_sum(field_for_Sums, unscale=var_unscale) * (1.0 / wt_sum) + + else ! Do the averages with order-dependent sums to reproduce older answers. + wt_sum = 0 ; varsum = 0. + do j=js,je ; do i=is,ie + if (weight(i,j) > 0.0) then + wt_sum = wt_sum + weight(i,j) + varsum = varsum + field(i,j) * weight(i,j) + endif + enddo ; enddo + + ! Note that these averages will not reproduce across PE layouts or grid rotation. + call sum_across_PEs(wt_sum) + if (wt_sum > 0.0) then + call sum_across_PEs(varsum) + varAvg = varsum / wt_sum + endif + + endif + + ! This seems like an unlikely case to ever be used, but it is needed to recreate previous behavior. + if (present(tmp_scale)) then ; if (tmp_scale == 0.0) varAvg = 0.0 ; endif + + field(:,:) = varAvg + +end subroutine homogenize_field + + !> Create a 2d-mesh of grid coordinates from 1-d arrays. subroutine meshgrid(x, y, x_T, y_T) - real, dimension(:), intent(in) :: x !< input 1-dimensional vector - real, dimension(:), intent(in) :: y !< input 1-dimensional vector - real, dimension(size(x,1),size(y,1)), intent(inout) :: x_T !< output 2-dimensional array - real, dimension(size(x,1),size(y,1)), intent(inout) :: y_T !< output 2-dimensional array + real, dimension(:), intent(in) :: x !< input 1-dimensional vector [arbitrary] + real, dimension(:), intent(in) :: y !< input 1-dimensional vector [arbitrary] + real, dimension(size(x,1),size(y,1)), intent(inout) :: x_T !< output 2-dimensional array [arbitrary] + real, dimension(size(x,1),size(y,1)), intent(inout) :: y_T !< output 2-dimensional array [arbitrary] integer :: ni, nj, i, j diff --git a/src/framework/MOM_interpolate.F90 b/src/framework/MOM_interpolate.F90 index 4a931d0bf3..1ef2618ab3 100644 --- a/src/framework/MOM_interpolate.F90 +++ b/src/framework/MOM_interpolate.F90 @@ -1,20 +1,43 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> This module provides added functionality to the FMS temporal and spatial interpolation routines module MOM_interpolate -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_array_transform, only : allocate_rotated_array, rotate_array use MOM_error_handler, only : MOM_error, FATAL use MOM_interp_infra, only : time_interp_extern, init_external_field=>init_extern_field -use MOM_interp_infra, only : time_interp_external_init, get_external_field_info -use MOM_interp_infra, only : horiz_interp_type, horiz_interp_init +use MOM_interp_infra, only : time_interp_external_init=>time_interp_extern_init +use MOM_interp_infra, only : horiz_interp_type +use MOM_interp_infra, only : get_external_field_info_infra => get_external_field_info use MOM_interp_infra, only : run_horiz_interp, build_horiz_interp_weights -use MOM_time_manager, only : time_type +use MOM_interp_infra, only : external_field +use MOM_io_infra, only : axistype +use MOM_io_infra, only : get_axis_size, get_axis_data +use MOM_io, only : axis_info, set_axis_info +use MOM_time_manager, only : time_type, set_date, operator(+), operator(<), operator(>) implicit none ; private -public :: time_interp_external, init_external_field, time_interp_external_init, get_external_field_info -public :: horiz_interp_type, horiz_interp_init, run_horiz_interp, build_horiz_interp_weights +!> Data type used to store information about forcing datasets that are time series +!! E.g. how do we align the data in the model with the time axis in the file? +type, public :: forcing_timeseries_dataset + character(len=200) :: file_name !< name of file containing river flux forcing + logical :: l_time_varying !< .true. => forcing is dependent on model time, .false. => static forcing + ! logical :: l_FMS_modulo !< .true. => let FMS handle determining time level to read (e.g. for climatologies) + type(time_type) :: data_forcing !< convert data_forcing_year to time type + type(time_type) :: data_start !< convert data_start_year to time type + type(time_type) :: data_end !< convert data_end_year to time type + type(time_type) :: m2d_offset !< add to model time to get data time +end type forcing_timeseries_dataset + +public :: time_interp_external, init_external_field, time_interp_external_init +public :: get_external_field_info +public :: horiz_interp_type, run_horiz_interp, build_horiz_interp_weights +public :: external_field +public :: forcing_timeseries_set_time_type_vars +public :: map_model_time_to_forcing_time !> Read a field based on model time, and rotate to the model domain. interface time_interp_external @@ -26,23 +49,48 @@ module MOM_interpolate contains !> Read a scalar field based on model time. -subroutine time_interp_external_0d(field_id, time, data_in, verbose) - integer, intent(in) :: field_id !< The integer index of the external field returned - !! from a previous call to init_external_field() +subroutine time_interp_external_0d(field, time, data_in, verbose, scale) + type(external_field), intent(in) :: field !< Handle for time interpolated field type(time_type), intent(in) :: time !< The target time for the data - real, intent(inout) :: data_in !< The interpolated value + real, intent(inout) :: data_in !< The interpolated value in arbitrary units [A ~> a] logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging + real, optional, intent(in) :: scale !< A scaling factor that new values of data_in are + !! multiplied by before it is returned [A a-1 ~> 1] + real :: data_in_pre_scale ! The input data before rescaling [a] + real :: I_scale ! The inverse of scale [a A-1 ~> 1] + + ! Store the input value in case the scaling factor is perfectly invertable. + data_in_pre_scale = data_in + I_scale = 1.0 + if (present(scale)) then ; if ((scale /= 1.0) .and. (scale /= 0.0)) then + ! Because time_interp_extern has the ability to only set some values, but no clear + ! mechanism to determine which values have been set, the input data has to + ! be unscaled so that it will have the right values when it is returned. + I_scale = 1.0 / scale + data_in = data_in * I_scale + endif ; endif + + call time_interp_extern(field, time, data_in, verbose=verbose) + + if (present(scale)) then ; if (scale /= 1.0) then + ! Rescale data that has been newly set and restore the scaling of unset data. + if (data_in == I_scale * data_in_pre_scale) then + data_in = data_in_pre_scale + else + data_in = scale * data_in + endif + endif ; endif - call time_interp_extern(field_id, time, data_in, verbose=verbose) end subroutine time_interp_external_0d !> Read a 2d field from an external based on model time, potentially including horizontal !! interpolation and rotation of the data -subroutine time_interp_external_2d(field_id, time, data_in, interp, verbose, horz_interp, mask_out, turns) - integer, intent(in) :: field_id !< The integer index of the external field returned - !! from a previous call to init_external_field() +subroutine time_interp_external_2d(field, time, data_in, interp, & + verbose, horz_interp, mask_out, turns, scale) + type(external_field), intent(in) :: field !< Handle for time interpolated field type(time_type), intent(in) :: time !< The target time for the data - real, dimension(:,:), intent(inout) :: data_in !< The array in which to store the interpolated values + real, dimension(:,:), intent(inout) :: data_in !< The array in which to store the interpolated + !! values in arbitrary units [A ~> a] integer, optional, intent(in) :: interp !< A flag indicating the temporal interpolation method logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging type(horiz_interp_type), & @@ -50,36 +98,72 @@ subroutine time_interp_external_2d(field_id, time, data_in, interp, verbose, hor logical, dimension(:,:), & optional, intent(out) :: mask_out !< An array that is true where there is valid data integer, optional, intent(in) :: turns !< Number of quarter turns to rotate the data + real, optional, intent(in) :: scale !< A scaling factor that new values of data_in are + !! multiplied by before it is returned [A a-1 ~> 1] - real, allocatable :: data_pre_rot(:,:) ! The input data before rotation + real, allocatable :: data_in_pre_scale(:,:) ! The input data before rescaling [a] + real, allocatable :: data_pre_rot(:,:) ! The unscaled input data before rotation [a] + real :: I_scale ! The inverse of scale [a A-1 ~> 1] integer :: qturns ! The number of quarter turns to rotate the data + integer :: i, j ! TODO: Mask rotation requires logical array rotation support if (present(mask_out)) & call MOM_error(FATAL, "Rotation of masked output not yet support") + if (present(scale)) then ; if ((scale /= 1.0) .and. (scale /= 0.0)) then + ! Because time_interp_extern has the ability to only set some values, but no clear mechanism + ! to determine which values have been set, the input data has to be unscaled so that it will + ! have the right values when it is returned. It may be a problem for some compiler settings + ! if there are NaNs in data_in, but they will not spread. + if (abs(fraction(scale)) /= 1.0) then + ! This scaling factor may not be perfectly invertable, so store the input value + allocate(data_in_pre_scale, source=data_in) + endif + I_scale = 1.0 / scale + data_in(:,:) = I_scale * data_in(:,:) + endif ; endif + qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) if (qturns == 0) then - call time_interp_extern(field_id, time, data_in, interp=interp, & + call time_interp_extern(field, time, data_in, interp=interp, & verbose=verbose, horz_interp=horz_interp) else call allocate_rotated_array(data_in, [1,1], -qturns, data_pre_rot) - call time_interp_extern(field_id, time, data_pre_rot, interp=interp, & + call time_interp_extern(field, time, data_pre_rot, interp=interp, & verbose=verbose, horz_interp=horz_interp) call rotate_array(data_pre_rot, turns, data_in) deallocate(data_pre_rot) endif + + if (present(scale)) then ; if (scale /= 1.0) then + ! Rescale data that has been newly set and restore the scaling of unset data. + if ((abs(fraction(scale)) /= 1.0) .and. (scale /= 0.0)) then + do j=LBOUND(data_in,2),UBOUND(data_in,2) ; do i=LBOUND(data_in,1),UBOUND(data_in,1) + ! This handles the case where scale is not exactly invertable for data + ! values that have not been modified by time_interp_extern. + if (data_in(i,j) == I_scale * data_in_pre_scale(i,j)) then + data_in(i,j) = data_in_pre_scale(i,j) + else + data_in(i,j) = scale * data_in(i,j) + endif + enddo ; enddo + else + data_in(:,:) = scale * data_in(:,:) + endif + endif ; endif + end subroutine time_interp_external_2d !> Read a 3d field based on model time, and rotate to the model grid -subroutine time_interp_external_3d(field_id, time, data_in, interp, & - verbose, horz_interp, mask_out, turns) - integer, intent(in) :: field_id !< The integer index of the external field returned - !! from a previous call to init_external_field() +subroutine time_interp_external_3d(field, time, data_in, interp, & + verbose, horz_interp, mask_out, turns, scale) + type(external_field), intent(in) :: field !< Handle for time interpolated field type(time_type), intent(in) :: time !< The target time for the data - real, dimension(:,:,:), intent(inout) :: data_in !< The array in which to store the interpolated values + real, dimension(:,:,:), intent(inout) :: data_in !< The array in which to store the interpolated + !! values in arbitrary units [A ~> a] integer, optional, intent(in) :: interp !< A flag indicating the temporal interpolation method logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging type(horiz_interp_type), & @@ -87,26 +171,159 @@ subroutine time_interp_external_3d(field_id, time, data_in, interp, & logical, dimension(:,:,:), & optional, intent(out) :: mask_out !< An array that is true where there is valid data integer, optional, intent(in) :: turns !< Number of quarter turns to rotate the data + real, optional, intent(in) :: scale !< A scaling factor that new values of data_in are + !! multiplied by before it is returned [A a-1 ~> 1] - real, allocatable :: data_pre_rot(:,:,:) ! The input data before rotation + real, allocatable :: data_in_pre_scale(:,:,:) ! The input data before rescaling [a] + real, allocatable :: data_pre_rot(:,:,:) ! The unscaled input data before rotation [a] + real :: I_scale ! The inverse of scale [a A-1 ~> 1] integer :: qturns ! The number of quarter turns to rotate the data + integer :: i, j, k ! TODO: Mask rotation requires logical array rotation support if (present(mask_out)) & call MOM_error(FATAL, "Rotation of masked output not yet support") + if (present(scale)) then ; if ((scale /= 1.0) .and. (scale /= 0.0)) then + ! Because time_interp_extern has the ability to only set some values, but no clear mechanism + ! to determine which values have been set, the input data has to be unscaled so that it will + ! have the right values when it is returned. It may be a problem for some compiler settings + ! if there are NaNs in data_in, but they will not spread. + if (abs(fraction(scale)) /= 1.0) then + ! This scaling factor may not be perfectly invertable, so store the input value + allocate(data_in_pre_scale, source=data_in) + endif + I_scale = 1.0 / scale + data_in(:,:,:) = I_scale * data_in(:,:,:) + endif ; endif + qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) if (qturns == 0) then - call time_interp_extern(field_id, time, data_in, interp=interp, & + call time_interp_extern(field, time, data_in, interp=interp, & verbose=verbose, horz_interp=horz_interp) else call allocate_rotated_array(data_in, [1,1,1], -qturns, data_pre_rot) - call time_interp_extern(field_id, time, data_pre_rot, interp=interp, & + call time_interp_extern(field, time, data_pre_rot, interp=interp, & verbose=verbose, horz_interp=horz_interp) call rotate_array(data_pre_rot, turns, data_in) deallocate(data_pre_rot) endif + + if (present(scale)) then ; if (scale /= 1.0) then + ! Rescale data that has been newly set and restore the scaling of unset data. + if ((abs(fraction(scale)) /= 1.0) .and. (scale /= 0.0)) then + do k=LBOUND(data_in,3),UBOUND(data_in,3) + do j=LBOUND(data_in,2),UBOUND(data_in,2) + do i=LBOUND(data_in,1),UBOUND(data_in,1) + ! This handles the case where scale is not exactly invertable for data + ! values that have not been modified by time_interp_extern. + if (data_in(i,j,k) == I_scale * data_in_pre_scale(i,j,k)) then + data_in(i,j,k) = data_in_pre_scale(i,j,k) + else + data_in(i,j,k) = scale * data_in(i,j,k) + endif + enddo + enddo + enddo + else + data_in(:,:,:) = scale * data_in(:,:,:) + endif + endif ; endif + end subroutine time_interp_external_3d +!> Set time_type variables in forcing_timeseries_dataset type based on integer input +!! TODO: make this part of forcing_timeseries_dataset class if OO is okay in MOM6? +subroutine forcing_timeseries_set_time_type_vars(data_start_year, data_end_year, data_ref_year, & + model_ref_year, data_forcing_year, forcing_dataset) + + integer, intent(in) :: data_start_year !< first year of data to read + !! (this is ignored for static forcing) + integer, intent(in) :: data_end_year !< last year of data to read + !! (this is ignored for static forcing) + integer, intent(in) :: data_ref_year !< for time-varying forcing, align + !! data_ref_year in file with + !! model_ref_year in model + integer, intent(in) :: model_ref_year !< for time-varying forcing, align + !! data_ref_year in file with + !! model_ref_year in model + integer, intent(in) :: data_forcing_year !< for static forcing, read file at this + !! date (this is ignored for time-varying + !! forcing) + type(forcing_timeseries_dataset), intent(inout) :: forcing_dataset !< information about forcing file + + if (forcing_dataset%l_time_varying) then + forcing_dataset%data_start = set_date(data_start_year, 1, 1) + forcing_dataset%data_end = set_date(data_end_year, 1, 1) + forcing_dataset%m2d_offset = set_date(data_ref_year - model_ref_year, 1, 1) + else + forcing_dataset%data_forcing = set_date(data_forcing_year, 1, 1) + endif + +end subroutine forcing_timeseries_set_time_type_vars + +!> If necessary, apply an offset to convert from model time to forcing time and then +!! ensure result is within acceptable bounds +function map_model_time_to_forcing_time(Time, forcing_dataset) + + type(time_type), intent(in) :: Time !< Model time + type(forcing_timeseries_dataset), intent(in) :: forcing_dataset !< information about forcing file + type(time_type) :: map_model_time_to_forcing_time !< time to read forcing file + + if (forcing_dataset%l_time_varying) then + map_model_time_to_forcing_time = Time + forcing_dataset%m2d_offset + ! If Time + offset is not between data_start and data_end, use whichever of those values is closer + if (map_model_time_to_forcing_time < forcing_dataset%data_start) & + map_model_time_to_forcing_time = forcing_dataset%data_start + if (map_model_time_to_forcing_time > forcing_dataset%data_end) & + map_model_time_to_forcing_time = forcing_dataset%data_end + else + map_model_time_to_forcing_time = forcing_dataset%data_forcing + endif + +end function map_model_time_to_forcing_time + + +subroutine get_external_field_info(field, size, axes, missing) + type(external_field), intent(in) :: field + !< Handle for time interpolated external field returned from a previous + !! call to init_external_field() + integer, optional, intent(inout) :: size(4) + !< Dimension sizes for the input data + type(axis_info), optional, intent(inout) :: axes(4) + !< Axis types for the input data + real, optional, intent(inout) :: missing + !< Missing value for the input data + + type(axistype) :: axes_infra(4) + ! Axis as represented in the infra + character(len=256) :: axis_name + ! Axis name + real, allocatable :: ax_data(:) + ! Axis points + + integer :: n + ! Axis index + integer :: ax_size + ! Axis size + + if (present(axes)) then + call get_external_field_info_infra(field, size=size, axes=axes_infra, & + missing=missing) + ! TODO: Most of these methods were written to expect four dimensions. + do n=1,4 + ! Convert axistype to axis_info + ax_size = get_axis_size(axes_infra(n)) + allocate(ax_data(ax_size)) + call get_axis_data(axes_infra(n), axis_name, ax_data) + call set_axis_info(axes(n), trim(axis_name), ax_data=ax_data) + deallocate(ax_data) + enddo + else + call get_external_field_info_infra(field, size=size, missing=missing) + endif +end subroutine get_external_field_info + + end module MOM_interpolate diff --git a/src/framework/MOM_intrinsic_functions.F90 b/src/framework/MOM_intrinsic_functions.F90 index fdda8849ae..0c0e79a182 100644 --- a/src/framework/MOM_intrinsic_functions.F90 +++ b/src/framework/MOM_intrinsic_functions.F90 @@ -1,21 +1,40 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> A module with intrinsic functions that are used by MOM but are not supported !! by some compilers. module MOM_intrinsic_functions -! This file is part of MOM6. See LICENSE.md for the license. +use iso_fortran_env, only : stdout => output_unit, stderr => error_unit +use iso_fortran_env, only : int64, real64 implicit none ; private -public :: invcosh +public :: invcosh, cuberoot +public :: intrinsic_functions_unit_tests + +! Floating point model, if bit layout from high to low is (sign, exp, frac) + +integer, parameter :: bias = maxexponent(1.) - 1 + !< The double precision exponent offset +integer, parameter :: signbit = storage_size(1.) - 1 + !< Position of sign bit +integer, parameter :: explen = 1 + ceiling(log(real(bias))/log(2.)) + !< Bit size of exponent +integer, parameter :: expbit = signbit - explen + !< Position of lowest exponent bit +integer, parameter :: fraclen = expbit + !< Length of fractional part contains !> Evaluate the inverse cosh, either using a math library or an !! equivalent expression function invcosh(x) - real, intent(in) :: x !< The argument of the inverse of cosh. NaNs will + real, intent(in) :: x !< The argument of the inverse of cosh [nondim]. NaNs will !! occur if x<1, but there is no error checking - real :: invcosh + real :: invcosh ! The inverse of cosh of x [nondim] #ifdef __INTEL_COMPILER invcosh = acosh(x) @@ -25,4 +44,197 @@ function invcosh(x) end function invcosh + +!> Returns the cube root of a real argument at roundoff accuracy, in a form that works properly with +!! rescaling of the argument by integer powers of 8. If the argument is a NaN, a NaN is returned. +elemental function cuberoot(x) result(root) + real, intent(in) :: x !< The argument of cuberoot in arbitrary units cubed [A3] + real :: root !< The real cube root of x in arbitrary units [A] + + real :: asx ! The absolute value of x rescaled by an integer power of 8 to put it into + ! the range from 0.125 < asx <= 1.0, in ambiguous units cubed [B3] + real :: root_asx ! The cube root of asx [B] + real :: ra_3 ! root_asx cubed [B3] + real :: num ! The numerator of an expression for the evolving estimate of the cube root of asx + ! in arbitrary units that can grow or shrink with each iteration [B C] + real :: den ! The denominator of an expression for the evolving estimate of the cube root of asx + ! in arbitrary units that can grow or shrink with each iteration [C] + real :: num_prev ! The numerator of an expression for the previous iteration of the evolving estimate + ! of the cube root of asx in arbitrary units that can grow or shrink with each iteration [B D] + real :: np_3 ! num_prev cubed [B3 D3] + real :: den_prev ! The denominator of an expression for the previous iteration of the evolving estimate of + ! the cube root of asx in arbitrary units that can grow or shrink with each iteration [D] + real :: dp_3 ! den_prev cubed [C3] + real :: r0 ! Initial value of the iterative solver. [B C] + real :: r0_3 ! r0 cubed [B3 C3] + integer :: itt + + integer(kind=int64) :: e_x, s_x + + if ((x >= 0.0) .eqv. (x <= 0.0)) then + ! Return 0 for an input of 0, or NaN for a NaN input. + root = x + else + call rescale_cbrt(x, asx, e_x, s_x) + + ! Iteratively determine root_asx = asx**1/3 using Halley's method and then Newton's method, + ! noting that Halley's method onverges monotonically and needs no bounding. Halley's method is + ! slightly more complicated that Newton's method, but converges in a third fewer iterations. + ! Keeping the estimates in a fractional form Root = num / den allows this calculation with + ! no real divisions during the iterations before doing a single real division at the end, + ! and it is therefore more computationally efficient. + + ! This first estimate gives the same magnitude of errors for 0.125 and 1.0 after two iterations. + ! The first iteration is applied explicitly. + r0 = 0.707106 + r0_3 = r0 * r0 * r0 + num = r0 * (r0_3 + 2.0 * asx) + den = 2.0 * r0_3 + asx + + do itt=1,2 + ! Halley's method iterates estimates as Root = Root * (Root**3 + 2.*asx) / (2.*Root**3 + asx). + num_prev = num ; den_prev = den + + ! Pre-compute these as integer powers, to avoid `pow()`-like intrinsics. + np_3 = num_prev * num_prev * num_prev + dp_3 = den_prev * den_prev * den_prev + + num = num_prev * (np_3 + 2.0 * asx * dp_3) + den = den_prev * (2.0 * np_3 + asx * dp_3) + ! Equivalent to: root_asx = root_asx * (root_asx**3 + 2.*asx) / (2.*root_asx**3 + asx) + enddo + ! At this point the error in root_asx is better than 1 part in 3e14. + root_asx = num / den + + ! One final iteration with Newton's method polishes up the root and gives a solution + ! that is within the last bit of the true solution. + ra_3 = root_asx * root_asx * root_asx + root_asx = root_asx - (ra_3 - asx) / (3.0 * (root_asx * root_asx)) + + root = descale(root_asx, e_x, s_x) + endif +end function cuberoot + + +!> Rescale `a` to the range [0.125, 1) and compute its cube-root exponent. +pure subroutine rescale_cbrt(a, x, e_r, s_a) + real, intent(in) :: a + !< The real parameter to be rescaled for cube root in arbitrary units cubed [A3] + real, intent(out) :: x + !< The rescaled value of a in the range from 0.125 < asx <= 1.0, in ambiguous units cubed [B3] + integer(kind=int64), intent(out) :: e_r + !< Cube root of the exponent of the rescaling of `a` + integer(kind=int64), intent(out) :: s_a + !< The sign bit of a + + integer(kind=int64) :: xb + ! Floating point value of a, bit-packed as an integer + integer(kind=int64) :: e_a + ! Unscaled exponent of a + integer(kind=int64) :: e_x + ! Exponent of x + integer(kind=int64) :: e_div, e_mod + ! Quotient and remainder of e in e = 3*(e/3) + modulo(e,3). + + ! Pack bits of a into xb and extract its exponent and sign. + xb = transfer(a, 1_int64) + s_a = ibits(xb, signbit, 1) + e_a = ibits(xb, expbit, explen) - bias + + ! Compute terms of exponent decomposition e = 3*(e/3) + modulo(e,3). + ! (Fortran division is round-to-zero, so we must emulate floor division.) + e_mod = modulo(e_a, 3_int64) + e_div = (e_a - e_mod)/3 + + ! Our scaling decomposes e_a into e = {3*(e/3) + 3} + {modulo(e,3) - 3}. + + ! The first term is a perfect cube, whose cube root is computed below. + e_r = e_div + 1 + + ! The second term ensures that x is shifted to [0.125, 1). + e_x = e_mod - 3 + + ! Insert the new 11-bit exponent into xb and write to x and extend the + ! bitcount to 12, so that the sign bit is zero and x is always positive. + call mvbits(e_x + bias, 0, explen + 1, xb, fraclen) + x = transfer(xb, 1.) +end subroutine rescale_cbrt + + +!> Undo the rescaling of a real number back to its original base. +pure function descale(x, e_a, s_a) result(a) + real, intent(in) :: x + !< The rescaled value which is to be restored in ambiguous units [B] + integer(kind=int64), intent(in) :: e_a + !< Exponent of the unscaled value + integer(kind=int64), intent(in) :: s_a + !< Sign bit of the unscaled value + real :: a + !< Restored value with the corrected exponent and sign in arbitrary units [A] + + integer(kind=int64) :: xb + ! Bit-packed real number into integer form + integer(kind=int64) :: e_x + ! Biased exponent of x + + ! Apply the corrected exponent and sign to x. + xb = transfer(x, 1_int64) + e_x = ibits(xb, expbit, explen) + call mvbits(e_a + e_x, 0, explen, xb, expbit) + call mvbits(s_a, 0, 1, xb, signbit) + a = transfer(xb, 1.) +end function descale + + +!> Returns true if any unit test of intrinsic_functions fails, or false if they all pass. +function intrinsic_functions_unit_tests(verbose) result(fail) + logical, intent(in) :: verbose !< If true, write results to stdout + logical :: fail !< True if any of the unit tests fail + + ! Local variables + real :: testval ! A test value for self-consistency testing [nondim] + logical :: v + integer :: n + + fail = .false. + v = verbose + write(stdout,*) '==== MOM_intrinsic_functions: intrinsic_functions_unit_tests ===' + + fail = fail .or. Test_cuberoot(v, 1.2345678901234e9) + fail = fail .or. Test_cuberoot(v, -9.8765432109876e-21) + fail = fail .or. Test_cuberoot(v, 64.0) + fail = fail .or. Test_cuberoot(v, -0.5000000000001) + fail = fail .or. Test_cuberoot(v, 0.0) + fail = fail .or. Test_cuberoot(v, 1.0) + fail = fail .or. Test_cuberoot(v, 0.125) + fail = fail .or. Test_cuberoot(v, 0.965) + fail = fail .or. Test_cuberoot(v, 1.0 - epsilon(1.0)) + fail = fail .or. Test_cuberoot(v, 1.0 - 0.5*epsilon(1.0)) + + testval = 1.0e-99 + v = .false. + do n=-160,160 + fail = fail .or. Test_cuberoot(v, testval) + testval = (-2.908 * (1.414213562373 + 1.2345678901234e-5*n)) * testval + enddo +end function intrinsic_functions_unit_tests + +!> True if the cube of cuberoot(val) does not closely match val. False otherwise. +logical function Test_cuberoot(verbose, val) + logical, intent(in) :: verbose !< If true, write results to stdout + real, intent(in) :: val !< The real value to test, in arbitrary units [A] + ! Local variables + real :: diff ! The difference between val and the cube root of its cube [A]. + + diff = val - cuberoot(val)**3 + Test_cuberoot = (abs(diff) > 2.0e-15*abs(val)) + + if (Test_cuberoot) then + write(stdout, '("For val = ",ES22.15,", (val - cuberoot(val**3))) = ",ES9.2," <-- FAIL")') val, diff + elseif (verbose) then + write(stdout, '("For val = ",ES22.15,", (val - cuberoot(val**3))) = ",ES9.2)') val, diff + + endif +end function Test_cuberoot + end module MOM_intrinsic_functions diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 563f9f9f8a..24adafba65 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> This module contains I/O framework code module MOM_io -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_array_transform, only : allocate_rotated_array, rotate_array use MOM_array_transform, only : rotate_array_pair, rotate_vector use MOM_domains, only : MOM_domain_type, domain1D, broadcast, get_domain_components @@ -15,16 +17,17 @@ module MOM_io use MOM_io_infra, only : read_field, read_vector use MOM_io_infra, only : read_data => read_field ! Deprecated use MOM_io_infra, only : read_field_chksum -use MOM_io_infra, only : file_type, file_exists, get_file_info, get_file_fields -use MOM_io_infra, only : open_file, open_ASCII_file, close_file, flush_file, file_is_open -use MOM_io_infra, only : get_field_size, fieldtype, field_exists, get_field_atts -use MOM_io_infra, only : get_file_times, axistype, get_axis_data, get_filename_suffix -use MOM_io_infra, only : write_field, write_metadata, write_version +use MOM_io_infra, only : file_exists +use MOM_io_infra, only : open_ASCII_file, close_file, file_is_open +use MOM_io_infra, only : get_field_size, field_exists, get_field_atts +use MOM_io_infra, only : get_axis_data, get_filename_suffix +use MOM_io_infra, only : write_version use MOM_io_infra, only : MOM_namelist_file, check_namelist_error, io_infra_init, io_infra_end -use MOM_io_infra, only : stdout_if_root use MOM_io_infra, only : APPEND_FILE, ASCII_FILE, MULTIPLE, NETCDF_FILE, OVERWRITE_FILE use MOM_io_infra, only : READONLY_FILE, SINGLE_FILE, WRITEONLY_FILE use MOM_io_infra, only : CENTER, CORNER, NORTH_FACE, EAST_FACE +use MOM_io_file, only : MOM_file, MOM_infra_file, MOM_netcdf_file +use MOM_io_file, only : MOM_axis, MOM_field use MOM_string_functions, only : lowercase, slasher use MOM_verticalGrid, only : verticalGrid_type @@ -34,23 +37,38 @@ module MOM_io use netcdf, only : NF90_strerror, NF90_inquire_dimension use netcdf, only : NF90_NOWRITE, NF90_NOERR, NF90_GLOBAL, NF90_ENOTATT, NF90_CHAR +! The following are not used in MOM6, but may be used by externals (e.g. SIS2). +use MOM_io_infra, only : axistype ! still used but soon to be nuked +use MOM_io_infra, only : fieldtype +use MOM_io_infra, only : file_type +use MOM_io_infra, only : get_file_info +use MOM_io_infra, only : get_file_fields +use MOM_io_infra, only : get_file_times +use MOM_io_infra, only : open_file +use MOM_io_infra, only : write_field + implicit none ; private ! These interfaces are actually implemented in this file. -public :: create_file, reopen_file, cmor_long_std, ensembler, MOM_io_init +public :: create_MOM_file, reopen_MOM_file, cmor_long_std, ensembler, MOM_io_init +public :: MOM_field public :: MOM_write_field, var_desc, modify_vardesc, query_vardesc, position_from_horgrid public :: open_namelist_file, check_namelist_error, check_nml_error public :: get_var_sizes, verify_variable_units, num_timelevels, read_variable, read_attribute public :: open_file_to_read, close_file_to_read ! The following are simple pass throughs of routines from MOM_io_infra or other modules. -public :: file_exists, open_file, open_ASCII_file, close_file, flush_file, file_type -public :: get_file_info, field_exists, get_file_fields, get_file_times, get_filename_appendix +public :: file_exists, open_ASCII_file, close_file +public :: MOM_file, MOM_infra_file, MOM_netcdf_file +public :: field_exists, get_filename_appendix public :: fieldtype, field_size, get_field_atts public :: axistype, get_axis_data public :: MOM_read_data, MOM_read_vector, read_field_chksum -public :: slasher, write_field, write_version_number +public :: read_netCDF_data +public :: slasher, write_version_number public :: io_infra_init, io_infra_end public :: stdout_if_root +public :: get_var_axes_info +public :: get_axis_info ! This is used to set up information descibing non-domain-decomposed axes. public :: axis_info, set_axis_info, delete_axis_info ! This is used to set up global file attributes @@ -66,6 +84,15 @@ module MOM_io !> These encoding constants are used to indicate the discretization position of a variable public :: CENTER, CORNER, NORTH_FACE, EAST_FACE +! The following are not used in MOM6, but may be used by externals (e.g. SIS2). +public :: create_file +public :: reopen_file +public :: file_type +public :: open_file +public :: get_file_info +public :: get_file_fields +public :: get_file_times + !> Read a field from file using the infrastructure I/O. interface MOM_read_data module procedure MOM_read_data_0d @@ -75,6 +102,7 @@ module MOM_io module procedure MOM_read_data_2d module procedure MOM_read_data_2d_region module procedure MOM_read_data_3d + module procedure MOM_read_data_3d_region module procedure MOM_read_data_4d end interface MOM_read_data @@ -84,8 +112,22 @@ module MOM_io module procedure MOM_read_vector_3d end interface MOM_read_vector +!> Read a field using native netCDF I/O +!! +!! This function is primarily used for unstructured data which may contain +!! content that cannot be parsed by infrastructure I/O. +interface read_netCDF_data + ! NOTE: Only 2D I/O is currently used; this should be expanded as needed. + module procedure read_netCDF_data_2d +end interface read_netCDF_data + !> Write a registered field to an output file, potentially with rotation interface MOM_write_field + module procedure MOM_write_field_legacy_4d + module procedure MOM_write_field_legacy_3d + module procedure MOM_write_field_legacy_2d + module procedure MOM_write_field_legacy_1d + module procedure MOM_write_field_legacy_0d module procedure MOM_write_field_4d module procedure MOM_write_field_3d module procedure MOM_write_field_2d @@ -98,6 +140,7 @@ module MOM_io interface read_variable module procedure read_variable_0d, read_variable_0d_int module procedure read_variable_1d, read_variable_1d_int + module procedure read_variable_2d, read_variable_3d end interface read_variable !> Read a global or variable attribute from a named netCDF file using netCDF calls @@ -107,6 +150,20 @@ module MOM_io module procedure read_attribute_int32, read_attribute_int64 end interface read_attribute +!> Type that stores information that can be used to create a non-decomposed axis. +type :: axis_info + character(len=32) :: name = "" !< The name of this axis for use in files + character(len=256) :: longname = "" !< A longer name describing this axis + character(len=48) :: units = "" !< The units of the axis labels + character(len=8) :: cartesian = "N" !< A variable indicating which direction + !! this axis corresponds with. Valid values + !! include 'X', 'Y', 'Z', 'T', and 'N' for none. + integer :: sense = 0 !< This is 1 for axes whose values increase upward, or -1 + !! if they increase downward. The default, 0, is ignored. + integer :: ax_size = 0 !< The number of elements in this axis + real, allocatable, dimension(:) :: ax_data !< The values of the data on the axis [arbitrary] +end type axis_info + !> Type for describing a 3-d variable for output type, public :: vardesc character(len=64) :: name !< Variable name in a NetCDF file @@ -118,50 +175,92 @@ module MOM_io character(len=64) :: cmor_field_name !< CMOR name character(len=64) :: cmor_units !< CMOR physical dimensions of the variable character(len=240) :: cmor_longname !< CMOR long name of the variable - real :: conversion !< for unit conversions, such as needed to - !! convert from intensive to extensive + real :: conversion !< for unit conversions, such as needed to convert + !! from intensive to extensive [various] or [a A-1 ~> 1] + !! to undo internal dimensional rescaling character(len=32) :: dim_names(5) !< The names in the file of the axes for this variable integer :: position = -1 !< An integer encoding the horizontal position, it may !! CENTER, CORNER, EAST_FACE, NORTH_FACE, or 0. + type(axis_info) :: extra_axes(5) !< dimensions other than space-time end type vardesc -!> Type that stores information that can be used to create a non-decomposed axis. -type :: axis_info ; private - character(len=32) :: name = "" !< The name of this axis for use in files - character(len=256) :: longname = "" !< A longer name describing this axis - character(len=48) :: units = "" !< The units of the axis labels - character(len=8) :: cartesian = "N" !< A variable indicating which direction - !! this axis corresponds with. Valid values - !! include 'X', 'Y', 'Z', 'T', and 'N' for none. - integer :: sense = 0 !< This is 1 for axes whose values increase upward, or -1 - !! if they increase downward. The default, 0, is ignored. - integer :: ax_size = 0 !< The number of elements in this axis - real, allocatable, dimension(:) :: ax_data !< The values of the data on the axis. -end type axis_info - !> Type that stores for a global file attribute type :: attribute_info ; private character(len=:), allocatable :: name !< The name of this attribute character(len=:), allocatable :: att_val !< The values of this attribute end type attribute_info - integer, public :: stdout = stdout_iso !< standard output unit integer, public :: stderr = stderr_iso !< standard output unit +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. +! The functions in this module work with variables with arbitrary units, in which case the +! arbitrary rescaled units are indicated with [A ~> a], while the unscaled units are just [a]. + contains -!> Routine creates a new NetCDF file. It also sets up fieldtype -!! structures that describe this file and variables that will -!! later be written to this file. -subroutine create_file(IO_handle, filename, vars, novars, fields, threading, timeunit, & - G, dG, GV, checksums, extra_axes, global_atts) - type(file_type), intent(inout) :: IO_handle !< Handle for a files or fileset that is to be +!> `create_MOM_file` wrapper for the legacy file handle, `file_type`. +!! NOTE: This function may be removed in a future release. +subroutine create_file(IO_handle, filename, vars, novars, fields, threading, & + timeunit, G, dG, GV, checksums, extra_axes, global_atts) + type(file_type), intent(inout) :: IO_handle + !< Handle for a files or fileset that is to be opened or reopened for + !! writing + character(len=*), intent(in) :: filename + !< full path to the file to create + type(vardesc), intent(in) :: vars(:) + !< structures describing fields written to filename + integer, intent(in) :: novars + !< number of fields written to filename + type(fieldtype), intent(inout) :: fields(:) + !< array of fieldtypes for each variable + integer, optional, intent(in) :: threading + !< SINGLE_FILE or MULTIPLE + real, optional, intent(in) :: timeunit + !< length of the units for time [s]. The default value is 86400.0, for 1 + !! day. + type(ocean_grid_type), optional, intent(in) :: G + !< ocean horizontal grid structure; G or dG is required if the new file + !! uses any horizontal grid axes. + type(dyn_horgrid_type), optional, intent(in) :: dG + !< dynamic horizontal grid structure; G or dG is required if the new file + !! uses any horizontal grid axes. + type(verticalGrid_type), optional, intent(in) :: GV + !< ocean vertical grid structure, which is ! required if the new file uses + !! any vertical grid axes. + integer(kind=int64), optional, intent(in) :: checksums(:,:) + !< checksums of vars + type(axis_info), optional, intent(in) :: extra_axes(:) + !< Types with information about some axes that might be used in this file + type(attribute_info), optional, intent(in) :: global_atts(:) + !< Global attributes to write to this file + + type(MOM_infra_file) :: new_file + type(MOM_field) :: new_fields(novars) + + new_file%handle_infra = IO_handle + + call create_MOM_file(new_file, filename, vars, novars, new_fields, & + threading=threading, timeunit=timeunit, G=G, dG=dG, GV=GV, & + checksums=checksums, extra_axes=extra_axes, global_atts=global_atts) + + IO_handle = new_file%handle_infra + call new_file%get_file_fieldtypes(fields(:novars)) +end subroutine create_file + + +!! Create a new netCDF file and register the MOM_fields to be written. +subroutine create_MOM_file(IO_handle, filename, vars, novars, fields, & + threading, timeunit, G, dG, GV, checksums, extra_axes, global_atts) + class(MOM_file), intent(inout) :: IO_handle !< Handle for a files or fileset that is to be !! opened or reopened for writing character(len=*), intent(in) :: filename !< full path to the file to create type(vardesc), intent(in) :: vars(:) !< structures describing fields written to filename integer, intent(in) :: novars !< number of fields written to filename - type(fieldtype), intent(inout) :: fields(:) !< array of fieldtypes for each variable + type(MOM_field), intent(inout) :: fields(:) !< array of fieldtypes for each variable integer, optional, intent(in) :: threading !< SINGLE_FILE or MULTIPLE real, optional, intent(in) :: timeunit !< length of the units for time [s]. The !! default value is 86400.0, for 1 day. @@ -175,7 +274,8 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim !! required if the new file uses any !! vertical grid axes. integer(kind=int64), optional, intent(in) :: checksums(:,:) !< checksums of vars - type(axis_info), optional, intent(in) :: extra_axes(:) !< Types with information about + type(axis_info), dimension(:), & + optional, intent(in) :: extra_axes !< Types with information about !! some axes that might be used in this file type(attribute_info), optional, intent(in) :: global_atts(:) !< Global attributes to !! write to this file @@ -184,21 +284,22 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim logical :: use_layer, use_int, use_periodic logical :: one_file, domain_set, dim_found logical, dimension(:), allocatable :: use_extra_axis - type(axistype) :: axis_lath, axis_latq, axis_lonh, axis_lonq - type(axistype) :: axis_layer, axis_int, axis_time, axis_periodic - type(axistype), dimension(:), allocatable :: more_axes ! Axes generated from extra_axes - type(axistype) :: axes(5) ! The axes of a variable + type(MOM_axis) :: axis_lath, axis_latq, axis_lonh, axis_lonq + type(MOM_axis) :: axis_layer, axis_int, axis_time, axis_periodic + type(MOM_axis), dimension(:), allocatable :: more_axes ! Axes generated from extra_axes + type(MOM_axis) :: axes(5) ! The axes of a variable type(MOM_domain_type), pointer :: Domain => NULL() type(domain1d) :: x_domain, y_domain integer :: position, numaxes, pack, thread, k, n, m integer :: num_extra_dims ! The number of extra possible dimensions from extra_axes integer :: isg, ieg, jsg, jeg, IsgB, IegB, JsgB, JegB integer :: var_periods, num_periods=0 - real, dimension(:), allocatable :: axis_val + real, dimension(:), allocatable :: axis_val ! Axis label values [various] real, pointer, dimension(:) :: & - gridLatT => NULL(), & ! The latitude or longitude of T or B points for - gridLatB => NULL(), & ! the purpose of labeling the output axes. - gridLonT => NULL(), gridLonB => NULL() + gridLatT => NULL(), & ! The latitude of T or B points for the purpose of labeling + gridLatB => NULL(), & ! the output axes, often in units of [degrees_N] or [km] or [m]. + gridLonT => NULL(), & ! The longitude of T or B points for the purpose of labeling + gridLonB => NULL() ! the output axes, often in units of [degrees_E] or [km] or [m]. character(len=40) :: time_units, x_axis_units, y_axis_units character(len=8) :: t_grid, t_grid_read character(len=64) :: ax_name(5) ! The axis names of a variable @@ -236,15 +337,20 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim IsgB = dG%IsgB ; IegB = dG%IegB ; JsgB = dG%JsgB ; JegB = dG%JegB endif - if (domain_set .and. (num_PEs() == 1)) thread = SINGLE_FILE - one_file = .true. if (domain_set) one_file = (thread == SINGLE_FILE) if (one_file) then - call open_file(IO_handle, filename, OVERWRITE_FILE, threading=thread) + if (domain_set) then + call IO_handle%open(filename, action=OVERWRITE_FILE, & + MOM_domain=domain, threading=thread, fileset=SINGLE_FILE) + else + call IO_handle%open(filename, action=OVERWRITE_FILE, threading=thread, & + fileset=SINGLE_FILE) + endif else - call open_file(IO_handle, filename, OVERWRITE_FILE, MOM_domain=Domain) + call IO_handle%open(filename, action=OVERWRITE_FILE, MOM_domain=Domain, & + threading=thread, fileset=thread) endif ! Define the coordinates. @@ -324,28 +430,23 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim "create_file: A vertical grid type is required to create a file with a vertical coordinate.") if (use_lath) & - call write_metadata(IO_handle, axis_lath, name="lath", units=y_axis_units, longname="Latitude", & + axis_lath = IO_handle%register_axis("lath", units=y_axis_units, longname="Latitude", & cartesian='Y', domain=y_domain, data=gridLatT(jsg:jeg)) - if (use_lonh) & - call write_metadata(IO_handle, axis_lonh, name="lonh", units=x_axis_units, longname="Longitude", & + axis_lonh = IO_handle%register_axis("lonh", units=x_axis_units, longname="Longitude", & cartesian='X', domain=x_domain, data=gridLonT(isg:ieg)) - if (use_latq) & - call write_metadata(IO_handle, axis_latq, name="latq", units=y_axis_units, longname="Latitude", & + axis_latq = IO_handle%register_axis("latq", units=y_axis_units, longname="Latitude", & cartesian='Y', domain=y_domain, data=gridLatB(JsgB:JegB), edge_axis=.true.) - if (use_lonq) & - call write_metadata(IO_handle, axis_lonq, name="lonq", units=x_axis_units, longname="Longitude", & + axis_lonq = IO_handle%register_axis("lonq", units=x_axis_units, longname="Longitude", & cartesian='X', domain=x_domain, data=gridLonB(IsgB:IegB), edge_axis=.true.) - if (use_layer) & - call write_metadata(IO_handle, axis_layer, name="Layer", units=trim(GV%zAxisUnits), & + axis_layer = IO_handle%register_axis("Layer", units=trim(GV%zAxisUnits), & longname="Layer "//trim(GV%zAxisLongName), cartesian='Z', & sense=1, data=GV%sLayer(1:GV%ke)) - if (use_int) & - call write_metadata(IO_handle, axis_int, name="Interface", units=trim(GV%zAxisUnits), & + axis_int = IO_handle%register_axis("Interface", units=trim(GV%zAxisUnits), & longname="Interface "//trim(GV%zAxisLongName), cartesian='Z', & sense=1, data=GV%sInterface(1:GV%ke+1)) @@ -365,9 +466,9 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim write(time_units,'(es8.2," s")') timeunit endif - call write_metadata(IO_handle, axis_time, name="Time", units=time_units, longname="Time", cartesian='T') + axis_time = IO_handle%register_axis("Time", units=time_units, longname="Time", cartesian='T') else - call write_metadata(IO_handle, axis_time, name="Time", units="days", longname="Time", cartesian='T') + axis_time = IO_handle%register_axis("Time", units="days", longname="Time", cartesian='T') endif ; endif if (use_periodic) then @@ -376,24 +477,24 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim ! Define a periodic axis with unit labels. allocate(axis_val(num_periods)) do k=1,num_periods ; axis_val(k) = real(k) ; enddo - call write_metadata(IO_handle, axis_periodic, name="Period", units="nondimensional", & - longname="Periods for cyclical variables", cartesian='T', data=axis_val) + axis_periodic = IO_handle%register_axis("Period", units="nondimensional", & + longname="Periods for cyclical variables", cartesian='T', data=axis_val) deallocate(axis_val) endif do m=1,num_extra_dims ; if (use_extra_axis(m)) then if (allocated(extra_axes(m)%ax_data)) then - call write_metadata(IO_handle, more_axes(m), name=extra_axes(m)%name, units=extra_axes(m)%units, & + more_axes(m) = IO_handle%register_axis(extra_axes(m)%name, units=extra_axes(m)%units, & longname=extra_axes(m)%longname, cartesian=extra_axes(m)%cartesian, & sense=extra_axes(m)%sense, data=extra_axes(m)%ax_data) elseif (trim(extra_axes(m)%cartesian) == "T") then - call write_metadata(IO_handle, more_axes(m), name=extra_axes(m)%name, units=extra_axes(m)%units, & + more_axes(m) = IO_handle%register_axis(extra_axes(m)%name, units=extra_axes(m)%units, & longname=extra_axes(m)%longname, cartesian=extra_axes(m)%cartesian) else ! FMS requires that non-time axes have variables that label their values, even if they are trivial. allocate (axis_val(extra_axes(m)%ax_size)) do k=1,extra_axes(m)%ax_size ; axis_val(k) = real(k) ; enddo - call write_metadata(IO_handle, more_axes(m), name=extra_axes(m)%name, units=extra_axes(m)%units, & + more_axes(m) = IO_handle%register_axis(extra_axes(m)%name, units=extra_axes(m)%units, & longname=extra_axes(m)%longname, cartesian=extra_axes(m)%cartesian, & sense=extra_axes(m)%sense, data=axis_val) deallocate(axis_val) @@ -455,52 +556,103 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim pack = 1 if (present(checksums)) then - call write_metadata(IO_handle, fields(k), axes(1:numaxes), vars(k)%name, vars(k)%units, & - vars(k)%longname, pack=pack, checksum=checksums(k,:)) + fields(k) = IO_handle%register_field(axes(1:numaxes), vars(k)%name, vars(k)%units, & + vars(k)%longname, pack=pack, checksum=checksums(k,:), conversion=vars(k)%conversion) else - call write_metadata(IO_handle, fields(k), axes(1:numaxes), vars(k)%name, vars(k)%units, & - vars(k)%longname, pack=pack) + fields(k) = IO_handle%register_field(axes(1:numaxes), vars(k)%name, vars(k)%units, & + vars(k)%longname, pack=pack, conversion=vars(k)%conversion) endif enddo if (present(global_atts)) then do n=1,size(global_atts) if (allocated(global_atts(n)%name) .and. allocated(global_atts(n)%att_val)) & - call write_metadata(IO_handle, global_atts(n)%name, global_atts(n)%att_val) + call IO_handle%write_attribute(global_atts(n)%name, global_atts(n)%att_val) enddo endif - ! Now actualy write the variables with the axis label values - if (use_lath) call write_field(IO_handle, axis_lath) - if (use_latq) call write_field(IO_handle, axis_latq) - if (use_lonh) call write_field(IO_handle, axis_lonh) - if (use_lonq) call write_field(IO_handle, axis_lonq) - if (use_layer) call write_field(IO_handle, axis_layer) - if (use_int) call write_field(IO_handle, axis_int) - if (use_periodic) call write_field(IO_handle, axis_periodic) + ! Now write the variables with the axis label values + if (use_lath) call IO_handle%write_field(axis_lath) + if (use_latq) call IO_handle%write_field(axis_latq) + if (use_lonh) call IO_handle%write_field(axis_lonh) + if (use_lonq) call IO_handle%write_field(axis_lonq) + if (use_layer) call IO_handle%write_field(axis_layer) + if (use_int) call IO_handle%write_field(axis_int) + if (use_periodic) call IO_handle%write_field(axis_periodic) do m=1,num_extra_dims ; if (use_extra_axis(m)) then - call write_field(IO_handle, more_axes(m)) + call IO_handle%write_field(more_axes(m)) endif ; enddo if (num_extra_dims > 0) then deallocate(use_extra_axis, more_axes) endif +end subroutine create_MOM_file + + +!> `reopen_MOM_file` wrapper for the legacy file handle, `file_type`. +!! NOTE: This function may be removed in a future release. +subroutine reopen_file(IO_handle, filename, vars, novars, fields, threading, & + timeunit, G, dG, GV, extra_axes, global_atts) + type(file_type), intent(inout) :: IO_handle + !< Handle for a file or fileset that is to be opened or reopened for + !! writing + character(len=*), intent(in) :: filename + !< full path to the file to create + type(vardesc), intent(in) :: vars(:) + !< structures describing fields written to filename + integer, intent(in) :: novars + !< number of fields written to filename + type(fieldtype), intent(inout) :: fields(:) + !< array of fieldtypes for each variable + integer, optional, intent(in) :: threading + !< SINGLE_FILE or MULTIPLE + real, optional, intent(in) :: timeunit + !< length of the units for time [s]. The default value is 86400.0, for 1 + !! day. + type(ocean_grid_type), optional, intent(in) :: G + !< ocean horizontal grid structure; G or dG is required if a new file uses + !! any horizontal grid axes. + type(dyn_horgrid_type), optional, intent(in) :: dG + !< dynamic horizontal grid structure; G or dG is required if a new file + !! uses any horizontal grid axes. + type(verticalGrid_type), optional, intent(in) :: GV + !< ocean vertical grid structure, which is required if a new file uses any + !! vertical grid axes. + type(axis_info), optional, intent(in) :: extra_axes(:) + !< Types with information about some axes that might be used in this file + type(attribute_info), optional, intent(in) :: global_atts(:) + !< Global attributes to write to this file + + type(MOM_infra_file) :: mfile + !< Wrapper to MOM file + type(MOM_field), allocatable :: mfields(:) + !< Wrapper to MOM fields + integer :: i -end subroutine create_file + mfile%handle_infra = IO_handle + allocate(mfields(size(fields))) + + call reopen_MOM_file(mfile, filename, vars, novars, mfields, & + threading=threading, timeunit=timeunit, G=G, dG=dG, GV=GV, & + extra_axes=extra_axes, global_atts=global_atts) + + IO_handle = mfile%handle_infra + call get_file_fields(IO_handle, fields) +end subroutine reopen_file !> This routine opens an existing NetCDF file for output. If it !! does not find the file, a new file is created. It also sets up !! structures that describe this file and the variables that will !! later be written to this file. -subroutine reopen_file(IO_handle, filename, vars, novars, fields, threading, timeunit, & - G, dG, GV, extra_axes, global_atts) - type(file_type), intent(inout) :: IO_handle !< Handle for a file or fileset that is to be +subroutine reopen_MOM_file(IO_handle, filename, vars, novars, fields, & + threading, timeunit, G, dG, GV, extra_axes, global_atts) + class(MOM_file), intent(inout) :: IO_handle !< Handle for a file or fileset that is to be !! opened or reopened for writing character(len=*), intent(in) :: filename !< full path to the file to create type(vardesc), intent(in) :: vars(:) !< structures describing fields written to filename integer, intent(in) :: novars !< number of fields written to filename - type(fieldtype), intent(inout) :: fields(:) !< array of fieldtypes for each variable + type(MOM_field), intent(inout) :: fields(:) !< array of fieldtypes for each variable integer, optional, intent(in) :: threading !< SINGLE_FILE or MULTIPLE real, optional, intent(in) :: timeunit !< length of the units for time [s]. The !! default value is 86400.0, for 1 day. @@ -526,6 +678,20 @@ subroutine reopen_file(IO_handle, filename, vars, novars, fields, threading, tim thread = SINGLE_FILE if (PRESENT(threading)) thread = threading + ! For single-file IO, only the root PE is required to set up the fields. + ! This permits calls by either the root PE or all PEs + if (.not. is_root_PE() .and. thread == SINGLE_FILE) return + + ! For multiple IO domains, we would need additional functionality: + ! * Identify ranks as IO PEs + ! * Determine the filename of + ! Neither of these tasks should be handed by MOM6, so we cannot safely use + ! this function. A framework-specific `inquire()` function is needed. + ! Until it exists, we will disable this function. + if (thread == MULTIPLE) & + call MOM_error(FATAL, 'reopen_MOM_file does not yet support files with ' & + // 'multiple I/O domains.') + check_name = filename length = len(trim(check_name)) if (check_name(length-2:length) /= ".nc") check_name = trim(check_name)//".nc" @@ -534,8 +700,9 @@ subroutine reopen_file(IO_handle, filename, vars, novars, fields, threading, tim inquire(file=check_name,EXIST=exists) if (.not.exists) then - call create_file(IO_handle, filename, vars, novars, fields, threading, timeunit, & - G=G, dG=dG, GV=GV, extra_axes=extra_axes, global_atts=global_atts) + call create_MOM_file(IO_handle, filename, vars, novars, fields, & + threading, timeunit, G=G, dG=dG, GV=GV, extra_axes=extra_axes, & + global_atts=global_atts) else domain_set = .false. @@ -549,41 +716,37 @@ subroutine reopen_file(IO_handle, filename, vars, novars, fields, threading, tim if (domain_set) one_file = (thread == SINGLE_FILE) if (one_file) then - call open_file(IO_handle, filename, APPEND_FILE, threading=thread) + call IO_handle%open(filename, APPEND_FILE, threading=thread) else - call open_file(IO_handle, filename, APPEND_FILE, MOM_domain=Domain) + call IO_handle%open(filename, APPEND_FILE, MOM_domain=Domain) endif - if (.not.file_is_open(IO_handle)) return + if (.not. IO_handle%file_is_open()) return - call get_file_info(IO_handle, nvar=nvar) + call IO_handle%get_file_info(nvar=nvar) if (nvar == -1) then write (mesg,*) "Reopening file ",trim(filename)," apparently had ",nvar,& " variables. Clobbering and creating file with ",novars," instead." call MOM_error(WARNING,"MOM_io: "//mesg) - call create_file(IO_handle, filename, vars, novars, fields, threading, timeunit, & - G=G, dG=dG, GV=GV, extra_axes=extra_axes, global_atts=global_atts) + call create_MOM_file(IO_handle, filename, vars, novars, fields, & + threading, timeunit, G=G, dG=dG, GV=GV, extra_axes=extra_axes, & + global_atts=global_atts) elseif (nvar /= novars) then write (mesg,*) "Reopening file ",trim(filename)," with ",novars,& " variables instead of ",nvar,"." call MOM_error(FATAL,"MOM_io: "//mesg) endif - if (nvar > 0) call get_file_fields(IO_handle, fields(1:nvar)) - - ! Check for inconsistent field names... -! do i=1,nvar -! call get_field_atts(fields(i), name) -! !if (trim(name) /= trim(vars%name)) then -! ! write (mesg, '("Reopening file ",a," variable ",a," is called ",a,".")',& -! ! trim(filename), trim(vars%name), trim(name)) -! ! call MOM_error(NOTE, "MOM_io: "//trim(mesg)) -! !endif -! enddo + if (nvar > 0) call IO_handle%get_file_fields(fields(1:nvar)) endif +end subroutine reopen_MOM_file -end subroutine reopen_file +!> Return the index of sdtout if called from the root PE, or 0 for other PEs. +integer function stdout_if_root() + stdout_if_root = 0 + if (is_root_PE()) stdout_if_root = stdout +end function stdout_if_root !> This function determines how many time levels a variable has in a file. function num_timelevels(filename, varname, min_dims) result(n_time) @@ -596,7 +759,7 @@ function num_timelevels(filename, varname, min_dims) result(n_time) integer :: n_time !< number of time levels varname has in filename character(len=256) :: msg - integer :: ncid, status, varid, ndims + integer :: ndims integer :: sizes(8) n_time = -1 @@ -612,13 +775,13 @@ function num_timelevels(filename, varname, min_dims) result(n_time) call get_var_sizes(filename, varname, ndims, sizes, match_case=.false., caller="num_timelevels") - n_time = sizes(ndims) + if (ndims > 0) n_time = sizes(ndims) if (present(min_dims)) then if (ndims < min_dims-1) then - write(msg, '(I3)') min_dims + write(msg, '(I0)') min_dims call MOM_error(WARNING, "num_timelevels: variable "//trim(varname)//" in file "//& - trim(filename)//" has fewer than min_dims = "//trim(msg)//" dimensions.") + trim(filename)//" has fewer than min_dims = "//trim(msg)//" dimensions.") n_time = -1 elseif (ndims == min_dims - 1) then n_time = 0 @@ -708,12 +871,18 @@ subroutine read_var_sizes(filename, varname, ndims, sizes, match_case, caller, d ncid = ncid_in else call open_file_to_read(filename, ncid, success=success) - if (.not.success) return + if (.not.success) then + call MOM_error(WARNING, "Unsuccessfully attempted to open file "//trim(filename)) + return + endif endif ! Get the dimension sizes of the variable varname. call get_varid(varname, ncid, filename, varid, match_case=match_case, found=found) - if (.not.found) return + if (.not.found) then + call MOM_error(WARNING, "Could not find variable "//trim(varname)//" in file "//trim(filename)) + return + endif status = NF90_inquire_variable(ncid, varid, ndims=ndims) if (status /= NF90_NOERR) then @@ -750,11 +919,12 @@ end subroutine read_var_sizes subroutine read_variable_0d(filename, varname, var, ncid_in, scale) character(len=*), intent(in) :: filename !< The name of the file to read character(len=*), intent(in) :: varname !< The variable name of the data in the file - real, intent(inout) :: var !< The scalar into which to read the data + real, intent(inout) :: var !< The scalar into which to read the data in arbitrary units [A ~> a] integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the !! file is opened and closed within this routine - real, optional, intent(in) :: scale !< A scaling factor that the variable is - !! multiplied by before it is returned + real, optional, intent(in) :: scale !< A scaling factor that the variable is multiplied by + !! before it is returned to convert from the units in the file + !! to the internal units for this variable [A a-1 ~> 1] integer :: varid, ncid, rc character(len=256) :: hdr @@ -787,11 +957,12 @@ end subroutine read_variable_0d subroutine read_variable_1d(filename, varname, var, ncid_in, scale) character(len=*), intent(in) :: filename !< The name of the file to read character(len=*), intent(in) :: varname !< The variable name of the data in the file - real, dimension(:), intent(inout) :: var !< The 1-d array into which to read the data + real, dimension(:), intent(inout) :: var !< The 1-d array into which to read the data in arbitrary units [A ~> a] integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the !! file is opened and closed within this routine - real, optional, intent(in) :: scale !< A scaling factor that the variable is - !! multiplied by before it is returned + real, optional, intent(in) :: scale !< A scaling factor that the variable is multiplied by + !! before it is returned to convert from the units in the file + !! to the internal units for this variable [A a-1 ~> 1] integer :: varid, ncid, rc character(len=256) :: hdr @@ -887,6 +1058,248 @@ subroutine read_variable_1d_int(filename, varname, var, ncid_in) call broadcast(var, size(var), blocking=.true.) end subroutine read_variable_1d_int +!> Read a 2d array from a netCDF input file and save to a variable. +!! +!! Start and nread lenths may exceed var rank. This allows for reading slices +!! of larger arrays. +!! +!! Previous versions of the model required a time axis on IO fields. This +!! constraint was dropped in later versions. As a result, versions both with +!! and without a time axis now exist. In order to support all such versions, +!! we use a reshaped version of start and nread in order to read the variable +!! as it exists in the file. +!! +!! Certain constraints are still applied to start and nread in order to ensure +!! that varname is a valid 2d array, or contains valid 2d slices. +!! +!! I/O occurs only on the root PE, and data is broadcast to other ranks. +!! Due to potentially large memory communication and storage, this subroutine +!! should only be used when domain-decomposition is unavaialable. +subroutine read_variable_2d(filename, varname, var, start, nread, ncid_in) + character(len=*), intent(in) :: filename !< Name of file to be read + character(len=*), intent(in) :: varname !< Name of variable to be read + real, intent(out) :: var(:,:) !< Output array of variable [arbitrary] + integer, optional, intent(in) :: start(:) !< Starting index on each axis. + integer, optional, intent(in) :: nread(:) !< Number of values to be read along each axis + integer, optional, intent(in) :: ncid_in !< netCDF ID of an opened file. + !! If absent, the file is opened and closed within this routine. + + integer :: ncid, varid + integer :: field_ndims, dim_len + integer, allocatable :: field_dimids(:), field_shape(:) + integer, allocatable :: field_start(:), field_nread(:) + integer :: i, rc + character(len=*), parameter :: hdr = "read_variable_2d: " + + ! Validate shape of start and nread + if (present(start)) then + if (size(start) < 2) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // " start must have at least two dimensions.") + endif + + if (present(nread)) then + if (size(nread) < 2) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // " nread must have at least two dimensions.") + + if (any(nread(3:) > 1)) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // " nread may only read a single level in higher dimensions.") + endif + + ! Since start and nread may be reshaped, we cannot rely on netCDF to ensure + ! that their lengths are equivalent, and must do it here. + if (present(start) .and. present(nread)) then + if (size(start) /= size(nread)) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // " start and nread must have the same length.") + endif + + ! Open and read `varname` from `filename` + if (is_root_pe()) then + if (present(ncid_in)) then + ncid = ncid_in + else + call open_file_to_Read(filename, ncid) + endif + + call get_varid(varname, ncid, filename, varid, match_case=.false.) + if (varid < 0) call MOM_error(FATAL, "Unable to get netCDF varid for "//trim(varname)//& + " in "//trim(filename)) + + ! Query for the dimensionality of the input field + rc = nf90_inquire_variable(ncid, varid, ndims=field_ndims) + if (rc /= NF90_NOERR) call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) //& + ": Difficulties reading "//trim(varname)//" from "//trim(filename)) + + ! Confirm that field is at least 2d + if (field_ndims < 2) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) // " " // & + trim(varname) // " from " // trim(filename) // " is not a 2D field.") + + ! If start and nread are present, then reshape them to match field dims + if (present(start) .or. present(nread)) then + allocate(field_shape(field_ndims)) + allocate(field_dimids(field_ndims)) + + rc = nf90_inquire_variable(ncid, varid, dimids=field_dimids) + if (rc /= NF90_NOERR) call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) //& + ": Difficulties reading "//trim(varname)//" from "//trim(filename)) + + do i = 1, field_ndims + rc = nf90_inquire_dimension(ncid, field_dimids(i), len=dim_len) + if (rc /= NF90_NOERR) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // ": Difficulties reading dimensions from " // trim(filename)) + field_shape(i) = dim_len + enddo + + ! Reshape start(:) and nreads(:) in case ranks differ + allocate(field_start(field_ndims)) + field_start(:) = 1 + if (present(start)) then + dim_len = min(size(start), size(field_start)) + field_start(:dim_len) = start(:dim_len) + endif + + allocate(field_nread(field_ndims)) + field_nread(:2) = field_shape(:2) + field_nread(3:) = 1 + if (present(nread)) field_nread(:2) = nread(:2) + + rc = nf90_get_var(ncid, varid, var, field_start, field_nread) + + deallocate(field_start) + deallocate(field_nread) + deallocate(field_shape) + deallocate(field_dimids) + else + rc = nf90_get_var(ncid, varid, var) + endif + + if (rc /= NF90_NOERR) call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) //& + " Difficulties reading "//trim(varname)//" from "//trim(filename)) + + if (.not.present(ncid_in)) call close_file_to_read(ncid, filename) + endif + + call broadcast(var, size(var), blocking=.true.) +end subroutine read_variable_2d + + +subroutine read_variable_3d(filename, varname, var, start, nread, ncid_in) + character(len=*), intent(in) :: filename !< Name of file to be read + character(len=*), intent(in) :: varname !< Name of variable to be read + real, intent(out) :: var(:,:,:) !< Output array of variable [arbitrary] + integer, optional, intent(in) :: start(:) !< Starting index on each axis. + integer, optional, intent(in) :: nread(:) !< Number of values to be read along each axis + integer, optional, intent(in) :: ncid_in !< netCDF ID of an opened file. + !! If absent, the file is opened and closed within this routine. + + integer :: ncid, varid + integer :: field_ndims, dim_len + integer, allocatable :: field_dimids(:), field_shape(:) + integer, allocatable :: field_start(:), field_nread(:) + integer :: i, rc + character(len=*), parameter :: hdr = "read_variable_3d: " + + ! Validate shape of start and nread + if (present(start)) then + if (size(start) < 2) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // " start must have at least two dimensions.") + endif + + if (present(nread)) then + if (size(nread) < 2) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // " nread must have at least two dimensions.") + + if (any(nread(3:) > 1)) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // " nread may only read a single level in higher dimensions.") + endif + + ! Since start and nread may be reshaped, we cannot rely on netCDF to ensure + ! that their lengths are equivalent, and must do it here. + if (present(start) .and. present(nread)) then + if (size(start) /= size(nread)) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // " start and nread must have the same length.") + endif + + ! Open and read `varname` from `filename` + if (is_root_pe()) then + if (present(ncid_in)) then + ncid = ncid_in + else + call open_file_to_Read(filename, ncid) + endif + + call get_varid(varname, ncid, filename, varid, match_case=.false.) + if (varid < 0) call MOM_error(FATAL, "Unable to get netCDF varid for "//trim(varname)//& + " in "//trim(filename)) + + ! Query for the dimensionality of the input field + rc = nf90_inquire_variable(ncid, varid, ndims=field_ndims) + if (rc /= NF90_NOERR) call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) //& + ": Difficulties reading "//trim(varname)//" from "//trim(filename)) + + ! Confirm that field is at least 2d + if (field_ndims < 2) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) // " " // & + trim(varname) // " from " // trim(filename) // " is not a 2D field.") + + ! If start and nread are present, then reshape them to match field dims + if (present(start) .or. present(nread)) then + allocate(field_shape(field_ndims)) + allocate(field_dimids(field_ndims)) + + rc = nf90_inquire_variable(ncid, varid, dimids=field_dimids) + if (rc /= NF90_NOERR) call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) //& + ": Difficulties reading "//trim(varname)//" from "//trim(filename)) + + do i = 1, field_ndims + rc = nf90_inquire_dimension(ncid, field_dimids(i), len=dim_len) + if (rc /= NF90_NOERR) & + call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) & + // ": Difficulties reading dimensions from " // trim(filename)) + field_shape(i) = dim_len + enddo + + ! Reshape start(:) and nreads(:) in case ranks differ + allocate(field_start(field_ndims)) + field_start(:) = 1 + if (present(start)) then + dim_len = min(size(start), size(field_start)) + field_start(:dim_len) = start(:dim_len) + endif + + allocate(field_nread(field_ndims)) + field_nread(:3) = field_shape(:3) + !field_nread(3:) = 1 + if (present(nread)) field_nread(:3) = nread(:3) + + rc = nf90_get_var(ncid, varid, var, field_start, field_nread) + + deallocate(field_start) + deallocate(field_nread) + deallocate(field_shape) + deallocate(field_dimids) + else + rc = nf90_get_var(ncid, varid, var) + endif + + if (rc /= NF90_NOERR) call MOM_error(FATAL, hdr // trim(nf90_strerror(rc)) //& + " Difficulties reading "//trim(varname)//" from "//trim(filename)) + + if (.not.present(ncid_in)) call close_file_to_read(ncid, filename) + endif + + call broadcast(var, size(var), blocking=.true.) +end subroutine read_variable_3d + !> Read a character-string global or variable attribute subroutine read_attribute_str(filename, attname, att_val, varname, found, all_read, ncid_in) character(len=*), intent(in) :: filename !< Name of the file to read @@ -1111,7 +1524,7 @@ end subroutine read_attribute_int64 subroutine read_attribute_real(filename, attname, att_val, varname, found, all_read, ncid_in) character(len=*), intent(in) :: filename !< Name of the file to read character(len=*), intent(in) :: attname !< Name of the attribute to read - real, intent(out) :: att_val !< The value of the attribute + real, intent(out) :: att_val !< The value of the attribute [arbitrary] character(len=*), optional, intent(in) :: varname !< The name of the variable whose attribute will !! be read. If missing, read a global attribute. logical, optional, intent(out) :: found !< Returns true if the attribute is found @@ -1342,7 +1755,8 @@ end subroutine verify_variable_units !! have default values that are empty strings or are appropriate for a 3-d !! tracer field at the tracer cell centers. function var_desc(name, units, longname, hor_grid, z_grid, t_grid, cmor_field_name, & - cmor_units, cmor_longname, conversion, caller, position, dim_names, fixed) result(vd) + cmor_units, cmor_longname, conversion, caller, position, dim_names, & + extra_axes, fixed) result(vd) character(len=*), intent(in) :: name !< variable name character(len=*), optional, intent(in) :: units !< variable units character(len=*), optional, intent(in) :: longname !< variable long name @@ -1355,6 +1769,7 @@ function var_desc(name, units, longname, hor_grid, z_grid, t_grid, cmor_field_na character(len=*), optional, intent(in) :: cmor_longname !< CMOR long name real , optional, intent(in) :: conversion !< for unit conversions, such as needed to !! convert from intensive to extensive + !! [various] or [a A-1 ~> 1] character(len=*), optional, intent(in) :: caller !< The calling routine for error messages integer, optional, intent(in) :: position !< A coded integer indicating the horizontal position !! of this variable if it has such dimensions. @@ -1362,6 +1777,8 @@ function var_desc(name, units, longname, hor_grid, z_grid, t_grid, cmor_field_na !! NORTH_FACE, and 0 for no horizontal dimensions. character(len=*), dimension(:), & optional, intent(in) :: dim_names !< The names of the dimensions of this variable + type(axis_info), dimension(:), & + optional, intent(in) :: extra_axes !< dimensions other than space-time logical, optional, intent(in) :: fixed !< If true, this does not evolve with time type(vardesc) :: vd !< vardesc type that is created @@ -1385,7 +1802,8 @@ function var_desc(name, units, longname, hor_grid, z_grid, t_grid, cmor_field_na call modify_vardesc(vd, units=units, longname=longname, hor_grid=hor_grid, & z_grid=z_grid, t_grid=t_grid, position=position, dim_names=dim_names, & cmor_field_name=cmor_field_name, cmor_units=cmor_units, & - cmor_longname=cmor_longname, conversion=conversion, caller=cllr) + cmor_longname=cmor_longname, conversion=conversion, caller=cllr, & + extra_axes=extra_axes) end function var_desc @@ -1393,7 +1811,8 @@ end function var_desc !> This routine modifies the named elements of a vardesc type. !! All arguments are optional, except the vardesc type to be modified. subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & - cmor_field_name, cmor_units, cmor_longname, conversion, caller, position, dim_names) + cmor_field_name, cmor_units, cmor_longname, conversion, caller, position, dim_names, & + extra_axes) type(vardesc), intent(inout) :: vd !< vardesc type that is modified character(len=*), optional, intent(in) :: name !< name of variable character(len=*), optional, intent(in) :: units !< units of variable @@ -1407,6 +1826,7 @@ subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & real , optional, intent(in) :: conversion !< A multiplicative factor for unit conversions, !! such as needed to convert from intensive to !! extensive or dimensional consistency testing + !! [various] or [a A-1 ~> 1] character(len=*), optional, intent(in) :: caller !< The calling routine for error messages integer, optional, intent(in) :: position !< A coded integer indicating the horizontal position !! of this variable if it has such dimensions. @@ -1414,6 +1834,8 @@ subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & !! NORTH_FACE, and 0 for no horizontal dimensions. character(len=*), dimension(:), & optional, intent(in) :: dim_names !< The names of the dimensions of this variable + type(axis_info), dimension(:), & + optional, intent(in) :: extra_axes !< dimensions other than space-time character(len=120) :: cllr integer :: n @@ -1460,12 +1882,20 @@ subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & if (present(cmor_longname)) call safe_string_copy(cmor_longname, vd%cmor_longname, & "vd%cmor_longname of "//trim(vd%name), cllr) + if (present(conversion)) vd%conversion = conversion + if (present(dim_names)) then do n=1,min(5,size(dim_names)) ; if (len_trim(dim_names(n)) > 0) then call safe_string_copy(dim_names(n), vd%dim_names(n), "vd%dim_names of "//trim(vd%name), cllr) endif ; enddo endif + if (present(extra_axes)) then + do n=1,size(extra_axes) ; if (len_trim(extra_axes(n)%name) > 0) then + vd%extra_axes(n) = extra_axes(n) + endif ; enddo + endif + end subroutine modify_vardesc integer function position_from_horgrid(hor_grid) @@ -1492,7 +1922,7 @@ subroutine set_axis_info(axis, name, units, longname, ax_size, ax_data, cartesia character(len=*), optional, intent(in) :: units !< The units of the axis labels character(len=*), optional, intent(in) :: longname !< Long name of the axis variable integer, optional, intent(in) :: ax_size !< The number of elements in this axis - real, dimension(:), optional, intent(in) :: ax_data !< The values of the data on the axis + real, dimension(:), optional, intent(in) :: ax_data !< The values of the data on the axis [arbitrary] character(len=*), optional, intent(in) :: cartesian !< A variable indicating which direction this axis !! axis corresponds with. Valid values !! include 'X', 'Y', 'Z', 'T', and 'N' (the default) for none. @@ -1542,6 +1972,32 @@ subroutine delete_axis_info(axes) enddo end subroutine delete_axis_info + +!> Retrieve the information from an axis_info type. +subroutine get_axis_info(axis,name,longname,units,cartesian,ax_size,ax_data) + type(axis_info), intent(in) :: axis !< An axis type + character(len=*), intent(out), optional :: name !< The axis name. + character(len=*), intent(out), optional :: longname !< The axis longname. + character(len=*), intent(out), optional :: units !< The axis units. + character(len=*), intent(out), optional :: cartesian !< The cartesian attribute + !! of the axis [X,Y,Z,T]. + integer, intent(out), optional :: ax_size !< The size of the axis. + real, optional, allocatable, dimension(:), intent(out) :: ax_data !< The axis label data [arbitrary] + + if (present(ax_data)) then + if (allocated(ax_data)) deallocate(ax_data) + allocate(ax_data(axis%ax_size)) + ax_data(:) = axis%ax_data + endif + + if (present(name)) name = axis%name + if (present(longname)) longname = axis%longname + if (present(units)) units = axis%units + if (present(cartesian)) cartesian = axis%cartesian + if (present(ax_size)) ax_size = axis%ax_size + +end subroutine get_axis_info + !> Store information that can be used to create an attribute in a subsequent call to create_file. subroutine set_attribute_info(attribute, name, str_value) type(attribute_info), intent(inout) :: attribute !< A type with information about a named attribute @@ -1583,7 +2039,7 @@ end function cmor_long_std !> This routine queries vardesc subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & cmor_field_name, cmor_units, cmor_longname, conversion, caller, & - position, dim_names) + extra_axes, position, dim_names) type(vardesc), intent(in) :: vd !< vardesc type that is queried character(len=*), optional, intent(out) :: name !< name of variable character(len=*), optional, intent(out) :: units !< units of variable @@ -1596,7 +2052,10 @@ subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & character(len=*), optional, intent(out) :: cmor_longname !< CMOR long name real , optional, intent(out) :: conversion !< for unit conversions, such as needed to !! convert from intensive to extensive + !! [various] or [a A-1 ~> 1] character(len=*), optional, intent(in) :: caller !< calling routine? + type(axis_info), dimension(5), & + optional, intent(out) :: extra_axes !< dimensions other than space-time integer, optional, intent(out) :: position !< A coded integer indicating the horizontal position !! of this variable if it has such dimensions. !! Valid values include CORNER, CENTER, EAST_FACE @@ -1605,7 +2064,8 @@ subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & optional, intent(out) :: dim_names !< The names of the dimensions of this variable integer :: n - character(len=120) :: cllr + integer, parameter :: nmax_extraaxes = 5 + character(len=120) :: cllr, varname cllr = "mod_vardesc" if (present(caller)) cllr = trim(caller) @@ -1628,6 +2088,9 @@ subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & "vd%cmor_units of "//trim(vd%name), cllr) if (present(cmor_longname)) call safe_string_copy(vd%cmor_longname, cmor_longname, & "vd%cmor_longname of "//trim(vd%name), cllr) + + if (present(conversion)) conversion = vd%conversion + if (present(position)) then position = vd%position if (position == -1) position = position_from_horgrid(vd%hor_grid) @@ -1638,6 +2101,19 @@ subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & enddo endif + if (present(extra_axes)) then + ! save_restart expects 5 extra axes (can be empty) + do n=1, nmax_extraaxes + if (vd%extra_axes(n)%ax_size>=1) then + extra_axes(n) = vd%extra_axes(n) + else + ! return an empty axis + write(varname,"('dummy',i1.1)") n + call set_axis_info(extra_axes(n), name=trim(varname), ax_size=1) + endif + enddo + endif + end subroutine query_vardesc @@ -1646,18 +2122,19 @@ subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale, MOM_Dom global_file, file_may_be_4d) character(len=*), intent(in) :: filename !< Input filename character(len=*), intent(in) :: fieldname !< Field variable name - real, intent(inout) :: data !< Field value + real, intent(inout) :: data !< Field value in arbitrary units [A ~> a] integer, optional, intent(in) :: timelevel !< Time level to read in file - real, optional, intent(in) :: scale !< Rescale factor + real, optional, intent(in) :: scale !< A scaling factor that the variable is multiplied by + !! before it is returned to convert from the units in the file + !! to the internal units for this variable [A a-1 ~> 1] type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< Model domain decomposition logical, optional, intent(in) :: global_file !< If true, read from a single file logical, optional, intent(in) :: file_may_be_4d !< If true, fields may be stored !! as 4d arrays in the file. call read_field(filename, fieldname, data, & - timelevel=timelevel, scale=scale, MOM_Domain=MOM_Domain, & - global_file=global_file, file_may_be_4d=file_may_be_4d & - ) + timelevel=timelevel, scale=scale, MOM_Domain=MOM_Domain, & + global_file=global_file, file_may_be_4d=file_may_be_4d) end subroutine MOM_read_data_0d @@ -1677,18 +2154,20 @@ subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale, MOM_Dom global_file, file_may_be_4d) character(len=*), intent(in) :: filename !< Input filename character(len=*), intent(in) :: fieldname !< Field variable name - real, dimension(:), intent(inout) :: data !< Field value + real, dimension(:), intent(inout) :: data !< Field value in arbitrary units [A ~> a] integer, optional, intent(in) :: timelevel !< Time level to read in file - real, optional, intent(in) :: scale !< Rescale factor + real, optional, intent(in) :: scale !< A scaling factor that the variable is multiplied by + !! before it is returned to convert from the units in the file + !! to the internal units for this variable [A a-1 ~> 1] type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< Model domain decomposition logical, optional, intent(in) :: global_file !< If true, read from a single file logical, optional, intent(in) :: file_may_be_4d !< If true, fields may be stored !! as 4d arrays in the file. call read_field(filename, fieldname, data, & - timelevel=timelevel, scale=scale, MOM_Domain=MOM_Domain, & - global_file=global_file, file_may_be_4d=file_may_be_4d & - ) + timelevel=timelevel, scale=scale, MOM_Domain=MOM_Domain, & + global_file=global_file, file_may_be_4d=file_may_be_4d) + end subroutine MOM_read_data_1d @@ -1704,46 +2183,116 @@ end subroutine MOM_read_data_1d_int !> Read a 2d array from file using infrastructure I/O. -subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & - timelevel, position, scale, global_file, file_may_be_4d) +subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, timelevel, position, & + scale, global_file, file_may_be_4d, turns) character(len=*), intent(in) :: filename !< Input filename character(len=*), intent(in) :: fieldname !< Field variable name - real, dimension(:,:), intent(inout) :: data !< Field value - type(MOM_domain_type), intent(in) :: MOM_Domain !< Model domain decomposition + real, dimension(:,:), intent(inout) :: data !< Field value in arbitrary units [A ~> a] + type(MOM_domain_type), target, & + intent(in) :: MOM_Domain !< Model domain decomposition integer, optional, intent(in) :: timelevel !< Time level to read in file integer, optional, intent(in) :: position !< Grid positioning flag - real, optional, intent(in) :: scale !< Rescale factor + real, optional, intent(in) :: scale !< A scaling factor that the variable is multiplied by + !! before it is returned to convert from the units in the file + !! to the internal units for this variable [A a-1 ~> 1] logical, optional, intent(in) :: global_file !< If true, read from a single file logical, optional, intent(in) :: file_may_be_4d !< If true, fields may be stored !! as 4d arrays in the file. + integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data. If absent + !! the number of turns is taken from MOM_Domain. + + ! Local variables + integer :: qturns ! Number of quarter-turns from input to model grid + real, allocatable :: data_in(:,:) ! Field array on the input grid in arbitrary units [A ~> a] + type(MOM_domain_type), pointer :: domain_ptr => NULL() ! Pointer to the unrotated domain for reading - integer :: turns ! Number of quarter-turns from input to model grid - real, allocatable :: data_in(:,:) ! Field array on the input grid + qturns = MOM_domain%turns ; if (present(turns)) qturns = modulo(turns, 4) - turns = MOM_domain%turns - if (turns == 0) then + domain_ptr => MOM_Domain + if (associated(MOM_Domain%domain_in) .and. (qturns /= 0)) domain_ptr => MOM_Domain%domain_in + + if (qturns == 0) then call read_field(filename, fieldname, data, MOM_Domain, & - timelevel=timelevel, position=position, scale=scale, & - global_file=global_file, file_may_be_4d=file_may_be_4d & - ) + timelevel=timelevel, position=position, scale=scale, & + global_file=global_file, file_may_be_4d=file_may_be_4d) else - call allocate_rotated_array(data, [1,1], -turns, data_in) - call read_field(filename, fieldname, data_in, MOM_Domain%domain_in, & - timelevel=timelevel, position=position, scale=scale, & - global_file=global_file, file_may_be_4d=file_may_be_4d & - ) - call rotate_array(data_in, turns, data) + call allocate_rotated_array(data, [1,1], -qturns, data_in) + call rotate_array(data, -qturns, data_in) + call read_field(filename, fieldname, data_in, domain_ptr, & + timelevel=timelevel, position=position, scale=scale, & + global_file=global_file, file_may_be_4d=file_may_be_4d) + call rotate_array(data_in, qturns, data) deallocate(data_in) endif + end subroutine MOM_read_data_2d +!> Read a 2d array (which might have halos) from a file using native netCDF I/O. +subroutine read_netCDF_data_2d(filename, fieldname, values, MOM_Domain, & + timelevel, position, rescale, turns) + character(len=*), intent(in) :: filename + !< Input filename + character(len=*), intent(in) :: fieldname + !< Field variable name + real, intent(inout) :: values(:,:) + !< Field values read from the file. It would be intent(out) but for the + !! need to preserve any initialized values in the halo regions. + type(MOM_domain_type), intent(in) :: MOM_Domain + !< Model domain decomposition + integer, optional, intent(in) :: timelevel + !< Time level to read in file + integer, optional, intent(in) :: position + !< Grid positioning flag + real, optional, intent(in) :: rescale + !< Rescale factor, omitting this is the same as setting it to 1. + integer, optional, intent(in) :: turns + !< Number of quarter-turns to rotate the data. If absent the number of turns is taken + !! from MOM_Domain. + + integer :: qturns + ! Number of quarter-turns from input to model grid + real, allocatable :: values_in(:,:) + ! Field array on the unrotated input grid + type(MOM_netcdf_file) :: handle + ! netCDF file handle + + ! General-purpose IO will require the following arguments, but they are not + ! yet implemented, so we raise an error if they are present. + + ! Fields are currently assumed on cell centers, and position is unsupported + if (present(position)) & + call MOM_error(FATAL, 'read_netCDF_data: position is not yet supported.') + + ! Timelevels are not yet supported + if (present(timelevel)) & + call MOM_error(FATAL, 'read_netCDF_data: timelevel is not yet supported.') + + call handle%open(filename, action=READONLY_FILE, MOM_domain=MOM_domain) + call handle%update() + + qturns = MOM_domain%turns ; if (present(turns)) qturns = modulo(turns, 4) + + if (qturns == 0) then + call handle%read(fieldname, values, rescale=rescale) + else + call allocate_rotated_array(values, [1,1], -qturns, values_in) + call rotate_array(values, -qturns, values_in) + call handle%read(fieldname, values_in, rescale=rescale) + call rotate_array(values_in, qturns, values) + deallocate(values_in) + endif + + call handle%close() +end subroutine read_netCDF_data_2d + + !> Read a 2d region array from file using infrastructure I/O. subroutine MOM_read_data_2d_region(filename, fieldname, data, start, nread, MOM_domain, & no_domain, scale, turns) character(len=*), intent(in) :: filename !< Input filename character(len=*), intent(in) :: fieldname !< Field variable name - real, dimension(:,:), intent(inout) :: data !< Field value + real, dimension(:,:), intent(inout) :: data !< Field value in arbitrary units [A ~> a] integer, dimension(:), intent(in) :: start !< Starting index for each axis. !! In 2d, start(3:4) must be 1. integer, dimension(:), intent(in) :: nread !< Number of values to read along each axis. @@ -1751,25 +2300,31 @@ subroutine MOM_read_data_2d_region(filename, fieldname, data, start, nread, MOM_ type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< Model domain decomposition logical, optional, intent(in) :: no_domain !< If true, field does not use !! domain decomposion. - real, optional, intent(in) :: scale !< Rescale factor + real, optional, intent(in) :: scale !< A scaling factor that the variable is multiplied by + !! before it is returned to convert from the units in the file + !! to the internal units for this variable [A a-1 ~> 1] integer, optional, intent(in) :: turns !< Number of quarter turns from !! input to model grid integer :: qturns ! Number of quarter turns - real, allocatable :: data_in(:,:) ! Field array on the input grid + real, allocatable :: data_in(:,:) ! Field array on the input grid in arbitrary units [A ~> a] qturns = 0 if (present(turns)) qturns = modulo(turns, 4) if (qturns == 0) then call read_field(filename, fieldname, data, start, nread, & - MOM_Domain=MOM_Domain, no_domain=no_domain, scale=scale & - ) + MOM_Domain=MOM_Domain, no_domain=no_domain, scale=scale) else call allocate_rotated_array(data, [1,1], -qturns, data_in) - call read_field(filename, fieldname, data_in, start, nread, & - MOM_Domain=MOM_Domain%domain_in, no_domain=no_domain, scale=scale & - ) + call rotate_array(data, -qturns, data_in) + if (associated(MOM_Domain%domain_in)) then + call read_field(filename, fieldname, data_in, start, nread, & + MOM_Domain=MOM_Domain%domain_in, no_domain=no_domain, scale=scale) + else + call read_field(filename, fieldname, data_in, start, nread, & + MOM_Domain=MOM_Domain, no_domain=no_domain, scale=scale) + endif call rotate_array(data_in, qturns, data) deallocate(data_in) endif @@ -1777,279 +2332,413 @@ end subroutine MOM_read_data_2d_region !> Read a 3d array from file using infrastructure I/O. -subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & - timelevel, position, scale, global_file, file_may_be_4d) +subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, timelevel, position, & + scale, global_file, file_may_be_4d, turns) character(len=*), intent(in) :: filename !< Input filename character(len=*), intent(in) :: fieldname !< Field variable name - real, dimension(:,:,:), intent(inout) :: data !< Field value - type(MOM_domain_type), intent(in) :: MOM_Domain !< Model domain decomposition + real, dimension(:,:,:), intent(inout) :: data !< Field value in arbitrary units [A ~> a] + type(MOM_domain_type), target, & + intent(in) :: MOM_Domain !< Model domain decomposition integer, optional, intent(in) :: timelevel !< Time level to read in file integer, optional, intent(in) :: position !< Grid positioning flag - real, optional, intent(in) :: scale !< Rescale factor + real, optional, intent(in) :: scale !< A scaling factor that the variable is multiplied by + !! before it is returned to convert from the units in the file + !! to the internal units for this variable [A a-1 ~> 1] logical, optional, intent(in) :: global_file !< If true, read from a single file logical, optional, intent(in) :: file_may_be_4d !< If true, fields may be stored !! as 4d arrays in the file. + integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data. If absent + !! the number of turns is taken from MOM_Domain. + + ! Local variables + integer :: qturns ! Number of quarter-turns from input to model grid + real, allocatable :: data_in(:,:,:) ! Field array on the input grid in arbitrary units [A ~> a] + type(MOM_domain_type), pointer :: domain_ptr => NULL() ! Pointer to the unrotated domain for reading - integer :: turns ! Number of quarter-turns from input to model grid - real, allocatable :: data_in(:,:,:) ! Field array on the input grid + domain_ptr => MOM_Domain + if (associated(MOM_Domain%domain_in) .and. (qturns /= 0)) domain_ptr => MOM_Domain%domain_in - turns = MOM_domain%turns - if (turns == 0) then + qturns = MOM_domain%turns ; if (present(turns)) qturns = modulo(turns, 4) + if (qturns == 0) then call read_field(filename, fieldname, data, MOM_Domain, & - timelevel=timelevel, position=position, scale=scale, & - global_file=global_file, file_may_be_4d=file_may_be_4d & - ) + timelevel=timelevel, position=position, scale=scale, & + global_file=global_file, file_may_be_4d=file_may_be_4d) else - call allocate_rotated_array(data, [1,1,1], -turns, data_in) - call read_field(filename, fieldname, data_in, MOM_Domain%domain_in, & - timelevel=timelevel, position=position, scale=scale, & - global_file=global_file, file_may_be_4d=file_may_be_4d & - ) - call rotate_array(data_in, turns, data) + call allocate_rotated_array(data, [1,1,1], -qturns, data_in) + call rotate_array(data, -qturns, data_in) + call read_field(filename, fieldname, data_in, domain_ptr, & + timelevel=timelevel, position=position, scale=scale, & + global_file=global_file, file_may_be_4d=file_may_be_4d) + call rotate_array(data_in, qturns, data) deallocate(data_in) endif + end subroutine MOM_read_data_3d +!> Read a 3d region array from file using infrastructure I/O. +subroutine MOM_read_data_3d_region(filename, fieldname, data, start, nread, MOM_domain, & + no_domain, scale, turns) + character(len=*), intent(in) :: filename !< Input filename + character(len=*), intent(in) :: fieldname !< Field variable name + real, dimension(:,:,:), intent(inout) :: data !< Field value in arbitrary units [A ~> a] + integer, dimension(:), intent(in) :: start !< Starting index for each axis. + integer, dimension(:), intent(in) :: nread !< Number of values to read along each axis. + type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< Model domain decomposition + logical, optional, intent(in) :: no_domain !< If true, field does not use + !! domain decomposion. + real, optional, intent(in) :: scale !< A scaling factor that the variable is multiplied by + !! before it is returned to convert from the units in the file + !! to the internal units for this variable [A a-1 ~> 1] + integer, optional, intent(in) :: turns !< Number of quarter turns from + !! input to model grid + + integer :: qturns ! Number of quarter turns + real, allocatable :: data_in(:,:,:) ! Field array on the input grid in arbitrary units [A ~> a] + + qturns = 0 + if (present(turns)) qturns = modulo(turns, 4) + + if (qturns == 0) then + call read_field(filename, fieldname, data, start, nread, & + MOM_Domain=MOM_Domain, no_domain=no_domain, scale=scale) + else + call allocate_rotated_array(data, [1,1,1], -qturns, data_in) + call rotate_array(data, -qturns, data_in) + if (associated(MOM_Domain%domain_in)) then + call read_field(filename, fieldname, data_in, start, nread, & + MOM_Domain=MOM_Domain%domain_in, no_domain=no_domain, scale=scale) + else + call read_field(filename, fieldname, data_in, start, nread, & + MOM_Domain=MOM_Domain, no_domain=no_domain, scale=scale) + endif + call rotate_array(data_in, qturns, data) + deallocate(data_in) + endif +end subroutine MOM_read_data_3d_region !> Read a 4d array from file using infrastructure I/O. subroutine MOM_read_data_4d(filename, fieldname, data, MOM_Domain, & - timelevel, position, scale, global_file) + timelevel, position, scale, global_file, turns) character(len=*), intent(in) :: filename !< Input filename character(len=*), intent(in) :: fieldname !< Field variable name - real, dimension(:,:,:,:), intent(inout) :: data !< Field value - type(MOM_domain_type), intent(in) :: MOM_Domain !< Model domain decomposition + real, dimension(:,:,:,:), intent(inout) :: data !< Field value in arbitrary units [A ~> a] + type(MOM_domain_type), target, & + intent(in) :: MOM_Domain !< Model domain decomposition integer, optional, intent(in) :: timelevel !< Time level to read in file integer, optional, intent(in) :: position !< Grid positioning flag - real, optional, intent(in) :: scale !< Rescale factor + real, optional, intent(in) :: scale !< A scaling factor that the variable is multiplied by + !! before it is returned to convert from the units in the file + !! to the internal units for this variable [A a-1 ~> 1] logical, optional, intent(in) :: global_file !< If true, read from a single file + integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data. If absent + !! the number of turns is taken from MOM_Domain. + + ! Local variables + integer :: qturns ! Number of quarter-turns from input to model grid + real, allocatable :: data_in(:,:,:,:) ! Field array on the input grid in arbitrary units [A ~> a] + type(MOM_domain_type), pointer :: domain_ptr => NULL() ! Pointer to the unrotated domain for reading - integer :: turns ! Number of quarter-turns from input to model grid - real, allocatable :: data_in(:,:,:,:) ! Field array on the input grid + qturns = MOM_domain%turns ; if (present(turns)) qturns = modulo(turns, 4) - turns = MOM_domain%turns + domain_ptr => MOM_Domain + if (associated(MOM_Domain%domain_in) .and. (qturns /= 0)) domain_ptr => MOM_Domain%domain_in - if (turns == 0) then + if (qturns == 0) then call read_field(filename, fieldname, data, MOM_Domain, & - timelevel=timelevel, position=position, scale=scale, & - global_file=global_file & - ) + timelevel=timelevel, position=position, scale=scale, & + global_file=global_file) else ! Read field along the input grid and rotate to the model grid - call allocate_rotated_array(data, [1,1,1,1], -turns, data_in) - call read_field(filename, fieldname, data_in, MOM_Domain%domain_in, & - timelevel=timelevel, position=position, scale=scale, & - global_file=global_file & - ) - call rotate_array(data_in, turns, data) + call allocate_rotated_array(data, [1,1,1,1], -qturns, data_in) + call rotate_array(data, -qturns, data_in) + call read_field(filename, fieldname, data_in, domain_ptr, timelevel=timelevel, & + position=position, scale=scale, global_file=global_file) + call rotate_array(data_in, qturns, data) deallocate(data_in) endif + end subroutine MOM_read_data_4d !> Read a 2d vector tuple from file using infrastructure I/O. subroutine MOM_read_vector_2d(filename, u_fieldname, v_fieldname, u_data, v_data, MOM_Domain, & - timelevel, stagger, scalar_pair, scale) + timelevel, stagger, scalar_pair, scale, turns) character(len=*), intent(in) :: filename !< Input filename character(len=*), intent(in) :: u_fieldname !< Field variable name in u character(len=*), intent(in) :: v_fieldname !< Field variable name in v - real, dimension(:,:), intent(inout) :: u_data !< Field value in u - real, dimension(:,:), intent(inout) :: v_data !< Field value in v - type(MOM_domain_type), intent(in) :: MOM_Domain !< Model domain decomposition + real, dimension(:,:), intent(inout) :: u_data !< Field value at u points in arbitrary units [A ~> a] + real, dimension(:,:), intent(inout) :: v_data !< Field value at v points in arbitrary units [A ~> a] + type(MOM_domain_type), target, & + intent(in) :: MOM_Domain !< Model domain decomposition integer, optional, intent(in) :: timelevel !< Time level to read in file integer, optional, intent(in) :: stagger !< Grid staggering flag logical, optional, intent(in) :: scalar_pair !< True if tuple is not a vector - real, optional, intent(in) :: scale !< Rescale factor + real, optional, intent(in) :: scale !< A scaling factor that the vector is multiplied by + !! before it is returned to convert from the units in the file + !! to the internal units for this variable [A a-1 ~> 1] + integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data. If absent + !! the number of turns is taken from MOM_Domain. + + ! Local variables + integer :: qturns ! Number of quarter-turns from input to model grid + real, allocatable :: u_data_in(:,:), v_data_in(:,:) ! [uv] on the input grid in arbitrary units [A ~> a] + type(MOM_domain_type), pointer :: domain_ptr => NULL() ! Pointer to the unrotated domain for reading - integer :: turns ! Number of quarter-turns from input to model grid - real, allocatable :: u_data_in(:,:), v_data_in(:,:) ! [uv] on the input grid + qturns = MOM_domain%turns ; if (present(turns)) qturns = modulo(turns, 4) - turns = MOM_Domain%turns - if (turns == 0) then + domain_ptr => MOM_Domain + if (associated(MOM_Domain%domain_in) .and. (qturns /= 0)) domain_ptr => MOM_Domain%domain_in + + if (qturns == 0) then call read_vector(filename, u_fieldname, v_fieldname, & - u_data, v_data, MOM_domain, timelevel=timelevel, stagger=stagger, & - scalar_pair=scalar_pair, scale=scale & - ) + u_data, v_data, MOM_domain, timelevel=timelevel, stagger=stagger, & + scalar_pair=scalar_pair, scale=scale) else - call allocate_rotated_array(u_data, [1,1], -turns, u_data_in) - call allocate_rotated_array(v_data, [1,1], -turns, v_data_in) - call read_vector(filename, u_fieldname, v_fieldname, & - u_data_in, v_data_in, MOM_domain%domain_in, timelevel=timelevel, & - stagger=stagger, scalar_pair=scalar_pair, scale=scale & - ) + call allocate_rotated_array(u_data, [1,1], -qturns, u_data_in) + call allocate_rotated_array(v_data, [1,1], -qturns, v_data_in) + if (scalar_pair) then + call rotate_array_pair(u_data, v_data, -qturns, u_data_in, v_data_in) + else + call rotate_vector(u_data, v_data, -qturns, u_data_in, v_data_in) + endif + call read_vector(filename, u_fieldname, v_fieldname, u_data_in, v_data_in, & + domain_ptr, timelevel=timelevel, & + stagger=stagger, scalar_pair=scalar_pair, scale=scale) if (scalar_pair) then - call rotate_array_pair(u_data_in, v_data_in, turns, u_data, v_data) + call rotate_array_pair(u_data_in, v_data_in, qturns, u_data, v_data) else - call rotate_vector(u_data_in, v_data_in, turns, u_data, v_data) + call rotate_vector(u_data_in, v_data_in, qturns, u_data, v_data) endif deallocate(v_data_in) deallocate(u_data_in) endif + end subroutine MOM_read_vector_2d !> Read a 3d vector tuple from file using infrastructure I/O. subroutine MOM_read_vector_3d(filename, u_fieldname, v_fieldname, u_data, v_data, MOM_Domain, & - timelevel, stagger, scalar_pair, scale) + timelevel, stagger, scalar_pair, scale, turns) character(len=*), intent(in) :: filename !< Input filename character(len=*), intent(in) :: u_fieldname !< Field variable name in u character(len=*), intent(in) :: v_fieldname !< Field variable name in v - real, dimension(:,:,:), intent(inout) :: u_data !< Field value in u - real, dimension(:,:,:), intent(inout) :: v_data !< Field value in v - type(MOM_domain_type), intent(in) :: MOM_Domain !< Model domain decomposition + real, dimension(:,:,:), intent(inout) :: u_data !< Field value in u in arbitrary units [A ~> a] + real, dimension(:,:,:), intent(inout) :: v_data !< Field value in v in arbitrary units [A ~> a] + type(MOM_domain_type), target, & + intent(in) :: MOM_Domain !< Model domain decomposition integer, optional, intent(in) :: timelevel !< Time level to read in file integer, optional, intent(in) :: stagger !< Grid staggering flag logical, optional, intent(in) :: scalar_pair !< True if tuple is not a vector - real, optional, intent(in) :: scale !< Rescale factor + real, optional, intent(in) :: scale !< A scaling factor that the vector is multiplied by + !! before it is returned to convert from the units in the file + !! to the internal units for this variable [A a-1 ~> 1] + integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data. If absent + !! the number of turns is taken from MOM_Domain. + + ! Local variables + integer :: qturns ! Number of quarter-turns from input to model grid + real, allocatable :: u_data_in(:,:,:), v_data_in(:,:,:) ! [uv] on the input grid in arbitrary units [A ~> a] + type(MOM_domain_type), pointer :: domain_ptr => NULL() ! Pointer to the unrotated domain for reading + + qturns = MOM_domain%turns ; if (present(turns)) qturns = modulo(turns, 4) - integer :: turns ! Number of quarter-turns from input to model grid - real, allocatable :: u_data_in(:,:,:), v_data_in(:,:,:) ! [uv] on the input grid + domain_ptr => MOM_Domain + if (associated(MOM_Domain%domain_in) .and. (qturns /= 0)) domain_ptr => MOM_Domain%domain_in - turns = MOM_Domain%turns - if (turns == 0) then + if (qturns == 0) then call read_vector(filename, u_fieldname, v_fieldname, & - u_data, v_data, MOM_domain, timelevel=timelevel, stagger=stagger, & - scalar_pair=scalar_pair, scale=scale & - ) + u_data, v_data, MOM_domain, timelevel=timelevel, stagger=stagger, & + scalar_pair=scalar_pair, scale=scale) else - call allocate_rotated_array(u_data, [1,1,1], -turns, u_data_in) - call allocate_rotated_array(v_data, [1,1,1], -turns, v_data_in) - call read_vector(filename, u_fieldname, v_fieldname, & - u_data_in, v_data_in, MOM_domain%domain_in, timelevel=timelevel, & - stagger=stagger, scalar_pair=scalar_pair, scale=scale & - ) + call allocate_rotated_array(u_data, [1,1,1], -qturns, u_data_in) + call allocate_rotated_array(v_data, [1,1,1], -qturns, v_data_in) + if (scalar_pair) then + call rotate_array_pair(u_data, v_data, -qturns, u_data_in, v_data_in) + else + call rotate_vector(u_data, v_data, -qturns, u_data_in, v_data_in) + endif + call read_vector(filename, u_fieldname, v_fieldname, u_data_in, v_data_in, & + domain_ptr, timelevel=timelevel, & + stagger=stagger, scalar_pair=scalar_pair, scale=scale) if (scalar_pair) then - call rotate_array_pair(u_data_in, v_data_in, turns, u_data, v_data) + call rotate_array_pair(u_data_in, v_data_in, qturns, u_data, v_data) else - call rotate_vector(u_data_in, v_data_in, turns, u_data, v_data) + call rotate_vector(u_data_in, v_data_in, qturns, u_data, v_data) endif deallocate(v_data_in) deallocate(u_data_in) endif -end subroutine MOM_read_vector_3d +end subroutine MOM_read_vector_3d !> Write a 4d field to an output file, potentially with rotation -subroutine MOM_write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns, scale) +subroutine MOM_write_field_legacy_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & + fill_value, turns, scale, unscale, zero_zeros) type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition - real, dimension(:,:,:,:), intent(inout) :: field !< Unrotated field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, dimension(:,:,:,:), intent(inout) :: field !< Unrotated field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) - real, optional, intent(in) :: fill_value !< Missing data fill value + real, optional, intent(in) :: fill_value !< Missing data fill value in the units used in the file [a] integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data - real, optional, intent(in) :: scale !< A scaling factor that the field is - !! multiplied by before it is written + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + logical, optional, intent(in) :: zero_zeros !< If present and true, convert negative zeros + !! into ordinary signless zeros. - real, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units or rescaled - real :: scale_fac ! A scaling factor to use before writing the array + ! Local variables + real, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units [a] or + ! rescaled [A ~> a] then [a] + real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] integer :: qturns ! The number of quarter turns through which to rotate field - integer :: is, ie, js, je ! The extent of the computational domain qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale - if ((qturns == 0) .and. (scale_fac == 1.0)) then + if ((qturns == 0) .and. (scale_fac == 1.0) .and. .not.present(zero_zeros)) then call write_field(IO_handle, field_md, MOM_domain, field, tstamp=tstamp, & tile_count=tile_count, fill_value=fill_value) else call allocate_rotated_array(field, [1,1,1,1], qturns, field_rot) call rotate_array(field, qturns, field_rot) - if (scale_fac /= 1.0) call rescale_comp_data(MOM_Domain, field_rot, scale_fac) + call rescale_comp_data(MOM_Domain, field_rot, scale_fac, zero_zeros) call write_field(IO_handle, field_md, MOM_domain, field_rot, tstamp=tstamp, & tile_count=tile_count, fill_value=fill_value) deallocate(field_rot) endif -end subroutine MOM_write_field_4d +end subroutine MOM_write_field_legacy_4d + !> Write a 3d field to an output file, potentially with rotation -subroutine MOM_write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns, scale) +subroutine MOM_write_field_legacy_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & + fill_value, turns, scale, unscale, zero_zeros) type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition - real, dimension(:,:,:), intent(inout) :: field !< Unrotated field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, dimension(:,:,:), intent(inout) :: field !< Unrotated field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) - real, optional, intent(in) :: fill_value !< Missing data fill value + real, optional, intent(in) :: fill_value !< Missing data fill value in the units used in the file [a] integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data - real, optional, intent(in) :: scale !< A scaling factor that the field is - !! multiplied by before it is written + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + logical, optional, intent(in) :: zero_zeros !< If present and true, convert negative zeros + !! into ordinary signless zeros. - real, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units or rescaled - real :: scale_fac ! A scaling factor to use before writing the array + ! Local variables + real, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units [a] or + ! rescaled [A ~> a] then [a] + real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] integer :: qturns ! The number of quarter turns through which to rotate field - integer :: is, ie, js, je ! The extent of the computational domain qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale - if ((qturns == 0) .and. (scale_fac == 1.0)) then + if ((qturns == 0) .and. (scale_fac == 1.0) .and. .not.present(zero_zeros)) then call write_field(IO_handle, field_md, MOM_domain, field, tstamp=tstamp, & tile_count=tile_count, fill_value=fill_value) else call allocate_rotated_array(field, [1,1,1], qturns, field_rot) call rotate_array(field, qturns, field_rot) - if (scale_fac /= 1.0) call rescale_comp_data(MOM_Domain, field_rot, scale_fac) + call rescale_comp_data(MOM_Domain, field_rot, scale_fac, zero_zeros) call write_field(IO_handle, field_md, MOM_domain, field_rot, tstamp=tstamp, & tile_count=tile_count, fill_value=fill_value) deallocate(field_rot) endif -end subroutine MOM_write_field_3d +end subroutine MOM_write_field_legacy_3d + !> Write a 2d field to an output file, potentially with rotation -subroutine MOM_write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & - fill_value, turns, scale) +subroutine MOM_write_field_legacy_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & + fill_value, turns, scale, unscale, zero_zeros) type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition - real, dimension(:,:), intent(inout) :: field !< Unrotated field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, dimension(:,:), intent(inout) :: field !< Unrotated field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) real, optional, intent(in) :: fill_value !< Missing data fill value integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data - real, optional, intent(in) :: scale !< A scaling factor that the field is - !! multiplied by before it is written + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + logical, optional, intent(in) :: zero_zeros !< If present and true, convert negative zeros + !! into ordinary signless zeros. - real, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units - real :: scale_fac ! A scaling factor to use before writing the array + ! Local variables + real, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units [a] or + ! rescaled [A ~> a] then [a] + real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] integer :: qturns ! The number of quarter turns through which to rotate field - integer :: is, ie, js, je ! The extent of the computational domain qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale - if ((qturns == 0) .and. (scale_fac == 1.0)) then + if ((qturns == 0) .and. (scale_fac == 1.0) .and. .not.present(zero_zeros)) then call write_field(IO_handle, field_md, MOM_domain, field, tstamp=tstamp, & tile_count=tile_count, fill_value=fill_value) else call allocate_rotated_array(field, [1,1], qturns, field_rot) call rotate_array(field, qturns, field_rot) - if (scale_fac /= 1.0) call rescale_comp_data(MOM_Domain, field_rot, scale_fac) + call rescale_comp_data(MOM_Domain, field_rot, scale_fac, zero_zeros) call write_field(IO_handle, field_md, MOM_domain, field_rot, tstamp=tstamp, & tile_count=tile_count, fill_value=fill_value) deallocate(field_rot) endif -end subroutine MOM_write_field_2d +end subroutine MOM_write_field_legacy_2d + !> Write a 1d field to an output file -subroutine MOM_write_field_1d(IO_handle, field_md, field, tstamp, fill_value, scale) +subroutine MOM_write_field_legacy_1d(IO_handle, field_md, field, tstamp, fill_value, scale, unscale, zero_zeros) type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata - real, dimension(:), intent(in) :: field !< Field to write - real, optional, intent(in) :: tstamp !< Model timestamp - real, optional, intent(in) :: fill_value !< Missing data fill value - real, optional, intent(in) :: scale !< A scaling factor that the field is - !! multiplied by before it is written + real, dimension(:), intent(in) :: field !< Field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] + real, optional, intent(in) :: fill_value !< Missing data fill value [a] + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + logical, optional, intent(in) :: zero_zeros !< If present and true, convert negative zeros + !! into ordinary signless zeros. - real, dimension(:), allocatable :: array ! A rescaled copy of field - real :: scale_fac ! A scaling factor to use before writing the array + ! Local variables + real, dimension(:), allocatable :: array ! A rescaled copy of field [a] + real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] + logical :: design_zeros ! If true, convert negative zeros into ordinary signless zeros. integer :: i scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale + + design_zeros = .false. ; if (present(zero_zeros)) design_zeros = zero_zeros - if (scale_fac == 1.0) then + if ((scale_fac == 1.0) .and. (.not.design_zeros)) then call write_field(IO_handle, field_md, field, tstamp=tstamp) else allocate(array(size(field))) @@ -2057,27 +2746,257 @@ subroutine MOM_write_field_1d(IO_handle, field_md, field, tstamp, fill_value, sc if (present(fill_value)) then do i=1,size(field) ; if (field(i) == fill_value) array(i) = fill_value ; enddo endif + if (design_zeros) then ! Convert negative zeros into zeros + do i=1,size(field) ; if (array(i) == 0.0) array(i) = 0.0 ; enddo + endif call write_field(IO_handle, field_md, array, tstamp=tstamp) deallocate(array) endif -end subroutine MOM_write_field_1d +end subroutine MOM_write_field_legacy_1d + !> Write a 0d field to an output file -subroutine MOM_write_field_0d(IO_handle, field_md, field, tstamp, fill_value, scale) +subroutine MOM_write_field_legacy_0d(IO_handle, field_md, field, tstamp, fill_value, scale, unscale, zero_zeros) type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata - real, intent(in) :: field !< Field to write - real, optional, intent(in) :: tstamp !< Model timestamp - real, optional, intent(in) :: fill_value !< Missing data fill value - real, optional, intent(in) :: scale !< A scaling factor that the field is - !! multiplied by before it is written - real :: scaled_val ! A rescaled copy of field + real, intent(in) :: field !< Field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] + real, optional, intent(in) :: fill_value !< Missing data fill value [a] + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + logical, optional, intent(in) :: zero_zeros !< If present and true, convert negative zeros + !! into ordinary signless zeros. + + ! Local variables + real :: scale_fac ! A scaling factor to use before writing the field [a A-1 ~> 1] + real :: scaled_val ! A rescaled copy of field [a] + + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale + + scaled_val = field * scale_fac - scaled_val = field - if (present(scale)) scaled_val = scale*field if (present(fill_value)) then ; if (field == fill_value) scaled_val = fill_value ; endif + if (present(zero_zeros)) then ; if (zero_zeros .and. (scaled_val == 0.0)) scaled_val = 0.0 ; endif call write_field(IO_handle, field_md, scaled_val, tstamp=tstamp) +end subroutine MOM_write_field_legacy_0d + + +!> Write a 4d field to an output file, potentially with rotation +subroutine MOM_write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & + fill_value, turns, scale, unscale, zero_zeros) + class(MOM_file), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition + real, dimension(:,:,:,:), intent(inout) :: field !< Unrotated field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] + integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value !< Missing data fill value [a] + integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + logical, optional, intent(in) :: zero_zeros !< If present and true, convert negative zeros + !! into ordinary signless zeros. + + ! Local variables + real, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units or rescaled [a] + real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale + + if ((qturns == 0) .and. (scale_fac == 1.0) .and. .not.present(zero_zeros)) then + call IO_handle%write_field(field_md, MOM_domain, field, tstamp=tstamp, & + tile_count=tile_count, fill_value=fill_value) + else + call allocate_rotated_array(field, [1,1,1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + call rescale_comp_data(MOM_Domain, field_rot, scale_fac, zero_zeros) + call IO_handle%write_field(field_md, MOM_domain, field_rot, tstamp=tstamp, & + tile_count=tile_count, fill_value=fill_value) + deallocate(field_rot) + endif +end subroutine MOM_write_field_4d + +!> Write a 3d field to an output file, potentially with rotation +subroutine MOM_write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & + fill_value, turns, scale, unscale, zero_zeros) + class(MOM_file), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition + real, dimension(:,:,:), intent(inout) :: field !< Unrotated field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] + integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value !< Missing data fill value [a] + integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + logical, optional, intent(in) :: zero_zeros !< If present and true, convert negative zeros + !! into ordinary signless zeros. + + ! Local variables + real, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units or rescaled [a] + real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale + + if ((qturns == 0) .and. (scale_fac == 1.0) .and. .not.present(zero_zeros)) then + call IO_handle%write_field(field_md, MOM_domain, field, tstamp=tstamp, & + tile_count=tile_count, fill_value=fill_value) + else + call allocate_rotated_array(field, [1,1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + call rescale_comp_data(MOM_Domain, field_rot, scale_fac, zero_zeros) + call IO_handle%write_field(field_md, MOM_domain, field_rot, tstamp=tstamp, & + tile_count=tile_count, fill_value=fill_value) + deallocate(field_rot) + endif +end subroutine MOM_write_field_3d + +!> Write a 2d field to an output file, potentially with rotation +subroutine MOM_write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & + fill_value, turns, scale, unscale, zero_zeros) + class(MOM_file), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition + real, dimension(:,:), intent(inout) :: field !< Unrotated field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] + integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value !< Missing data fill value [a] + integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + logical, optional, intent(in) :: zero_zeros !< If present and true, convert negative zeros + !! into ordinary signless zeros. + + ! Local variables + real, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units or rescaled [a] + real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale + + if ((qturns == 0) .and. (scale_fac == 1.0) .and. .not.present(zero_zeros)) then + call IO_handle%write_field(field_md, MOM_domain, field, tstamp=tstamp, & + tile_count=tile_count, fill_value=fill_value) + else + call allocate_rotated_array(field, [1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + call rescale_comp_data(MOM_Domain, field_rot, scale_fac, zero_zeros) + call IO_handle%write_field(field_md, MOM_domain, field_rot, tstamp=tstamp, & + tile_count=tile_count, fill_value=fill_value) + deallocate(field_rot) + endif +end subroutine MOM_write_field_2d + +!> Write a 1d field to an output file +subroutine MOM_write_field_1d(IO_handle, field_md, field, tstamp, fill_value, scale, unscale, zero_zeros) + class(MOM_file), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md !< Field type with metadata + real, dimension(:), intent(in) :: field !< Field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] + real, optional, intent(in) :: fill_value !< Missing data fill value [a] + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + logical, optional, intent(in) :: zero_zeros !< If present and true, convert negative zeros + !! into ordinary signless zeros. + + ! Local variables + real, dimension(:), allocatable :: array ! A rescaled copy of field in arbtrary unscaled units [a] + real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] + logical :: design_zeros ! If true, convert negative zeros into ordinary signless zeros. + integer :: i + + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale + + design_zeros = .false. ; if (present(zero_zeros)) design_zeros = zero_zeros + + if ((scale_fac == 1.0) .and. (.not.design_zeros)) then + call IO_handle%write_field(field_md, field, tstamp=tstamp) + else + allocate(array(size(field))) + array(:) = scale_fac * field(:) + if (present(fill_value)) then + do i=1,size(field) ; if (field(i) == fill_value) array(i) = fill_value ; enddo + endif + if (design_zeros) then ! Convert negative zeros into zeros + do i=1,size(field) ; if (array(i) == 0.0) array(i) = 0.0 ; enddo + endif + call IO_handle%write_field(field_md, array, tstamp=tstamp) + deallocate(array) + endif +end subroutine MOM_write_field_1d + +!> Write a 0d field to an output file +subroutine MOM_write_field_0d(IO_handle, field_md, field, tstamp, fill_value, scale, unscale, zero_zeros) + class(MOM_file), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md !< Field type with metadata + real, intent(in) :: field !< Field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] + real, optional, intent(in) :: fill_value !< Missing data fill value [a] + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output + real, optional, intent(in) :: unscale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output. + !! Here scale and unscale are synonymous, but unscale + !! takes precedence if both are present. + logical, optional, intent(in) :: zero_zeros !< If present and true, convert negative zeros + !! into ordinary signless zeros. + + ! Local variables + real :: scale_fac ! A scaling factor to use before writing the field [a A-1 ~> 1] + real :: scaled_val ! A rescaled copy of field in arbtrary unscaled units [a] + + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + if (present(unscale)) scale_fac = unscale + + scaled_val = field * scale_fac + + if (present(fill_value)) then ; if (field == fill_value) scaled_val = fill_value ; endif + if (present(zero_zeros)) then ; if (zero_zeros .and. (scaled_val == 0.0)) scaled_val = 0.0 ; endif + + call IO_handle%write_field(field_md, scaled_val, tstamp=tstamp) end subroutine MOM_write_field_0d !> Given filename and fieldname, this subroutine returns the size of the field in the file @@ -2120,8 +3039,8 @@ subroutine safe_string_copy(str1, str2, fieldnm, caller) if (len(trim(str1)) > len(str2)) then if (present(fieldnm) .and. present(caller)) then - call MOM_error(FATAL, trim(caller)//" attempted to copy the overly long"//& - " string "//trim(str1)//" into "//trim(fieldnm)) + call MOM_error(FATAL, trim(caller)//" attempted to copy the overly long string "//& + trim(str1)//" into "//trim(fieldnm)) else call MOM_error(FATAL, "safe_string_copy: The string "//trim(str1)//& " is longer than its intended target.") @@ -2144,7 +3063,7 @@ function ensembler(name, ens_no_in) result(en_nm) character(10) :: ens_num_char character(3) :: code_str integer :: ens_no - integer :: n, is, ie + integer :: n, is en_nm = trim(name) if (index(name,"%") == 0) return @@ -2155,7 +3074,7 @@ function ensembler(name, ens_no_in) result(en_nm) ens_no = get_ensemble_id() endif - write(ens_num_char, '(I10)') ens_no ; ens_num_char = adjustl(ens_num_char) + write(ens_num_char, '(I0)') ens_no do is = index(en_nm,"%E") if (is == 0) exit @@ -2233,7 +3152,79 @@ subroutine MOM_io_init(param_file) call log_version(param_file, mdl, version) end subroutine MOM_io_init - +!> Returns the dimension variable information for a netCDF variable +subroutine get_var_axes_info(filename, fieldname, axes_info) + character(len=*), intent(in) :: filename !< A filename from which to read + character(len=*), intent(in) :: fieldname !< The name of the field to read + type(axis_info), dimension(4), intent(inout) :: axes_info !< A returned array of field axis information + + !! local variables + integer :: rcode + logical :: success + integer :: ncid, varid, ndims + integer :: id, jd, kd + integer, dimension(4) :: dims, dim_id + character(len=128) :: dim_name(4) + integer, dimension(1) :: start, count + !! cartesian axis data + real, allocatable, dimension(:) :: x ! x-axis labels, often [degrees_E] or [km] or [m] + real, allocatable, dimension(:) :: y ! y-axis labels, often [degrees_N] or [km] or [m] + real, allocatable, dimension(:) :: z ! vertical axis labels [various], often [m] or [kg m-3] + + + call open_file_to_read(filename, ncid, success=success) + + rcode = NF90_INQ_VARID(ncid, trim(fieldname), varid) + if (rcode /= 0) call MOM_error(FATAL,"error finding variable "//trim(fieldname)//& + " in file "//trim(filename)//" in hinterp_extrap") + + rcode = NF90_INQUIRE_VARIABLE(ncid, varid, ndims=ndims, dimids=dims) + if (rcode /= 0) call MOM_error(FATAL, "Error inquiring about the dimensions of "//trim(fieldname)//& + " in file "//trim(filename)//" in hinterp_extrap") + if (ndims < 3) call MOM_error(FATAL,"Variable "//trim(fieldname)//" in file "//trim(filename)// & + " has too few dimensions to be read as a 3-d array.") + rcode = NF90_INQUIRE_DIMENSION(ncid, dims(1), dim_name(1), len=id) + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 1 data for "// & + trim(fieldname)//" in file "// trim(filename)//" in hinterp_extrap") + rcode = NF90_INQ_VARID(ncid, dim_name(1), dim_id(1)) + if (rcode /= 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(1))//& + " in file "//trim(filename)//" in hinterp_extrap") + rcode = NF90_INQUIRE_DIMENSION(ncid, dims(2), dim_name(2), len=jd) + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 2 data for "// & + trim(fieldname)//" in file "// trim(filename)//" in hinterp_extrap") + rcode = NF90_INQ_VARID(ncid, dim_name(2), dim_id(2)) + if (rcode /= 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(2))//& + " in file "//trim(filename)//" in hinterp_extrap") + rcode = NF90_INQUIRE_DIMENSION(ncid, dims(3), dim_name(3), len=kd) + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 3 data for "// & + trim(fieldname)//" in file "// trim(filename)//" in hinterp_extrap") + rcode = NF90_INQ_VARID(ncid, dim_name(3), dim_id(3)) + if (rcode /= 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(3))//& + " in file "//trim(filename)//" in hinterp_extrap") + allocate(x(id), y(jd), z(kd)) + + start = 1 ; count = 1 ; count(1) = id + rcode = NF90_GET_VAR(ncid, dim_id(1), x, start, count) + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 1 values for var_name "// & + trim(fieldname)//",dim_name "//trim(dim_name(1))//" in file "// trim(filename)//" in hinterp_extrap") + start = 1 ; count = 1 ; count(1) = jd + rcode = NF90_GET_VAR(ncid, dim_id(2), y, start, count) + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 2 values for var_name "// & + trim(fieldname)//",dim_name "//trim(dim_name(2))//" in file "// trim(filename)//" in hinterp_extrap") + start = 1 ; count = 1 ; count(1) = kd + rcode = NF90_GET_VAR(ncid, dim_id(3), z, start, count) + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 3 values for var_name "// & + trim(fieldname//",dim_name "//trim(dim_name(3)))//" in file "// trim(filename)//" in hinterp_extrap") + + call set_axis_info(axes_info(1), name=trim(dim_name(1)), ax_size=id, ax_data=x,cartesian='X') + call set_axis_info(axes_info(2), name=trim(dim_name(2)), ax_size=jd, ax_data=y,cartesian='Y') + call set_axis_info(axes_info(3), name=trim(dim_name(3)), ax_size=kd, ax_data=z,cartesian='Z') + + call close_file_to_read(ncid, filename) + + deallocate(x,y,z) + +end subroutine get_var_axes_info !> \namespace mom_io !! !! This file contains a number of subroutines that manipulate diff --git a/src/framework/MOM_io_file.F90 b/src/framework/MOM_io_file.F90 new file mode 100644 index 0000000000..9da83fd338 --- /dev/null +++ b/src/framework/MOM_io_file.F90 @@ -0,0 +1,1911 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> This module contains the MOM file handler types +module MOM_io_file + +use, intrinsic :: iso_fortran_env, only : int64 + +use MOM_domains, only : MOM_domain_type, domain1D +use MOM_domains, only : clone_MOM_domain +use MOM_domains, only : deallocate_MOM_domain +use MOM_io_infra, only : file_type, get_file_info, get_file_fields +use MOM_io_infra, only : open_file, close_file, flush_file +use MOM_io_infra, only : fms2_file_is_open => file_is_open +use MOM_io_infra, only : fieldtype +use MOM_io_infra, only : get_file_times, axistype +use MOM_io_infra, only : write_field, write_metadata +use MOM_io_infra, only : get_field_atts +use MOM_io_infra, only : read_field_chksum +use MOM_io_infra, only : SINGLE_FILE + +use MOM_hor_index, only : hor_index_type +use MOM_hor_index, only : hor_index_init + +use MOM_netcdf, only : netcdf_file_type +use MOM_netcdf, only : netcdf_axis +use MOM_netcdf, only : netcdf_field +use MOM_netcdf, only : open_netcdf_file +use MOM_netcdf, only : close_netcdf_file +use MOM_netcdf, only : flush_netcdf_file +use MOM_netcdf, only : register_netcdf_axis +use MOM_netcdf, only : register_netcdf_field +use MOM_netcdf, only : write_netcdf_field +use MOM_netcdf, only : write_netcdf_axis +use MOM_netcdf, only : write_netcdf_attribute +use MOM_netcdf, only : get_netcdf_size +use MOM_netcdf, only : get_netcdf_fields +use MOM_netcdf, only : get_netcdf_filename +use MOM_netcdf, only : read_netcdf_field + +use MOM_error_handler, only : MOM_error, FATAL +use MOM_error_handler, only : is_root_PE + +implicit none ; private + +public :: MOM_file +public :: MOM_infra_file +public :: MOM_netcdf_file +public :: MOM_axis +public :: MOM_field + + +! Internal types + +! NOTE: MOM_axis and MOM_field do not contain the actual axes and fields stored +! in the file. They are very thin wrappers to the keys (as strings) used to +! reference the associated object inside of the MOM_file. + +!> Handle for axis in MOM file +type :: MOM_axis + character(len=:), allocatable :: label + !< Identifier for the axis in handle's list +end type MOM_axis + + +!> Linked list of framework axes +type :: axis_list_infra + private + type(axis_node_infra), pointer :: head => null() + !< Head of axis linked list + type(axis_node_infra), pointer :: tail => null() + !< Tail of axis linked list +contains + !> Initialize the framework axis list + procedure :: init => initialize_axis_list_infra + !> Append a new axis to the framework axis list + procedure :: append => append_axis_list_infra + !> Get an axis from the framework axis list + procedure :: get => get_axis_list_infra + !> Deallocate the framework axis list + procedure :: finalize => finalize_axis_list_infra +end type axis_list_infra + + +!> Framework axis linked list node +type :: axis_node_infra + private + character(len=:), allocatable :: label + !< Axis identifier + type(axis_node_infra), pointer :: next => null() + !< Pointer to next axis node + type(axistype) :: axis + !< Axis node contents +end type axis_node_infra + + +!> Linked list of framework axes +type :: axis_list_nc + private + type(axis_node_nc), pointer :: head => null() + !< Head of axis linked list + type(axis_node_nc), pointer :: tail => null() + !< Tail of axis linked list +contains + !> Initialize the netCDF axis list + procedure :: init => initialize_axis_list_nc + !> Append a new axis to the netCDF axis list + procedure :: append => append_axis_list_nc + !> Get an axis from the netCDF axis list + procedure :: get => get_axis_list_nc + !> Deallocate the netCDF axis list + procedure :: finalize => finalize_axis_list_nc +end type axis_list_nc + + +!> Framework axis linked list node +type :: axis_node_nc + private + character(len=:), allocatable :: label + !< Axis identifier + type(axis_node_nc), pointer :: next => null() + !< Pointer to next axis node + type(netcdf_axis) :: axis + !< Axis node contents +end type axis_node_nc + + +!> Handle for field in MOM file +type :: MOM_field + character(len=:), allocatable :: label + !< Identifier for the field in the handle's list + real :: conversion + !< A factor to use to rescale the field before output [a A-1 ~> 1] +end type MOM_field + + +!> Linked list of framework fields +type :: field_list_infra + private + type(field_node_infra), pointer :: head => null() + !< Head of field linked list + type(field_node_infra), pointer :: tail => null() + !< Tail of field linked list +contains + !> Initialize the framework field list + procedure :: init => initialize_field_list_infra + !> Append a new axis to the framework field list + procedure :: append => append_field_list_infra + !> Get an axis from the framework field list + procedure :: get => get_field_list_infra + !> Deallocate the framework field list + procedure :: finalize => finalize_field_list_infra +end type field_list_infra + + +!> Framework field linked list node +type :: field_node_infra + private + character(len=:), allocatable :: label + !< Field identifier + type(fieldtype) :: field + !< Field node contents + type(field_node_infra), pointer :: next => null() + !< Pointer to next field node +end type field_node_infra + + +!> Linked list of framework fields +type :: field_list_nc + private + type(field_node_nc), pointer :: head => null() + !< Head of field linked list + type(field_node_nc), pointer :: tail => null() + !< Tail of field linked list +contains + !> Initialize the netCDF field list + procedure :: init => initialize_field_list_nc + !> Append a new axis to the netCDF field list + procedure :: append => append_field_list_nc + !> Get an axis from the netCDF field list + procedure :: get => get_field_list_nc + !> Deallocate the netCDF field list + procedure :: finalize => finalize_field_list_nc +end type field_list_nc + + +!> Framework field linked list node +type :: field_node_nc + private + character(len=:), allocatable :: label + !< Field identifier + type(netcdf_field) :: field + !< Field node contents + type(field_node_nc), pointer :: next => null() + !< Pointer to next field node +end type field_node_nc + + +!> Generic MOM file abstraction for common operations +type, abstract :: MOM_file + private + + contains + + !> Open a file and connect to the MOM_file object + procedure(i_open_file), deferred :: open + !> Close the MOM file + procedure(i_close_file), deferred :: close + !> Flush buffered output to the MOM file + procedure(i_flush_file), deferred :: flush + + !> Register an axis to the MOM file + procedure(i_register_axis), deferred :: register_axis + !> Register a field to the MOM file + procedure(i_register_field), deferred :: register_field + !> Write metadata to the MOM file + procedure(i_write_attribute), deferred :: write_attribute + + !> Write field to a MOM file + generic :: write_field => & + write_field_4d, & + write_field_3d, & + write_field_2d, & + write_field_1d, & + write_field_0d, & + write_field_axis + + !> Write a 4D field to the MOM file + procedure(i_write_field_4d), deferred :: write_field_4d + !> Write a 3D field to the MOM file + procedure(i_write_field_3d), deferred :: write_field_3d + !> Write a 2D field to the MOM file + procedure(i_write_field_2d), deferred :: write_field_2d + !> Write a 1D field to the MOM file + procedure(i_write_field_1d), deferred :: write_field_1d + !> Write a 0D field to the MOM file + procedure(i_write_field_0d), deferred :: write_field_0d + !> Write an axis field to the MOM file + procedure(i_write_field_axis), deferred :: write_field_axis + + !> Return true if MOM file has been opened + procedure(i_file_is_open), deferred :: file_is_open + !> Return number of dimensions, variables, or time levels in a MOM file + procedure(i_get_file_info), deferred :: get_file_info + !> Get field objects from a MOM file + procedure(i_get_file_fields), deferred :: get_file_fields + !> Get attributes from a field + procedure(i_get_field_atts), deferred :: get_field_atts + !> Get checksum from a field + procedure(i_read_field_chksum), deferred :: read_field_chksum +end type MOM_file + + +!> MOM file from the supporting framework ("infra") layer +type, extends(MOM_file) :: MOM_infra_file + private + + type(MOM_domain_type), public, pointer :: domain => null() + !< Internal domain used for single-file IO + + ! NOTE: This will be made private after the API transition + type(file_type), public :: handle_infra + !< Framework-specific file handler content + type(axis_list_infra) :: axes + !< List of axes in file + type(field_list_infra) :: fields + !< List of fields in file + + contains + + !> Open a framework file and connect to the MOM_file object + procedure :: open => open_file_infra + !> Close the MOM framework file + procedure :: close => close_file_infra + !> Flush buffered output to the MOM framework file + procedure :: flush => flush_file_infra + + !> Register an axis to the MOM framework file + procedure :: register_axis => register_axis_infra + !> Register a field to the MOM framework file + procedure :: register_field => register_field_infra + !> Write global metadata to the MOM framework file + procedure :: write_attribute => write_attribute_infra + + !> Write a 4D field to the MOM framework file + procedure :: write_field_4d => write_field_4d_infra + !> Write a 3D field to the MOM framework file + procedure :: write_field_3d => write_field_3d_infra + !> Write a 2D field to the MOM framework file + procedure :: write_field_2d => write_field_2d_infra + !> Write a 1D field to the MOM framework file + procedure :: write_field_1d => write_field_1d_infra + !> Write a 0D field to the MOM framework file + procedure :: write_field_0d => write_field_0d_infra + !> Write an axis field to the MOM framework file + procedure :: write_field_axis => write_field_axis_infra + + !> Return true if MOM infra file has been opened + procedure :: file_is_open => file_is_open_infra + !> Return number of dimensions, variables, or time levels in a MOM infra file + procedure :: get_file_info => get_file_info_infra + !> Get field metadata from a MOM infra file + procedure :: get_file_fields => get_file_fields_infra + !> Get attributes from a field + procedure :: get_field_atts => get_field_atts_infra + !> Get checksum from a field + procedure :: read_field_chksum => read_field_chksum_infra + + ! MOM_infra_file methods + ! NOTE: These could naturally reside in MOM_file but is currently not needed. + + !> Get time levels of a MOM framework file + procedure :: get_file_times => get_file_times_infra + + !> Get the fields as fieldtypes from a file + procedure :: get_file_fieldtypes + ! NOTE: This is provided to support the legacy API and may be removed. +end type MOM_infra_file + + +!> MOM file using netCDF backend +type, extends(MOM_file) :: MOM_netcdf_file + private + + !> Framework-specific file handler content + type(netcdf_file_type) :: handle_nc + !> List of netCDF axes + type(axis_list_nc) :: axes + !> List of netCDF fields + type(field_list_nc) :: fields + !> True if the file has been opened + logical :: is_open = .false. + !> True if I/O content is domain-decomposed + logical :: domain_decomposed = .false. + !> True if I/O content is domain-decomposed + type(hor_index_type) :: HI + + contains + + !> Open a framework file and connect to the MOM_netcdf_file object + procedure :: open => open_file_nc + !> Close the MOM netcdf file + procedure :: close => close_file_nc + !> Flush buffered output to the MOM netcdf file + procedure :: flush => flush_file_nc + + !> Register an axis to the MOM netcdf file + procedure :: register_axis => register_axis_nc + !> Register a field to the MOM netcdf file + procedure :: register_field => register_field_nc + !> Write global metadata to the MOM netcdf file + procedure :: write_attribute => write_attribute_nc + + !> Write a 4D field to the MOM netcdf file + procedure :: write_field_4d => write_field_4d_nc + !> Write a 3D field to the MOM netcdf file + procedure :: write_field_3d => write_field_3d_nc + !> Write a 2D field to the MOM netcdf file + procedure :: write_field_2d => write_field_2d_nc + !> Write a 1D field to the MOM netcdf file + procedure :: write_field_1d => write_field_1d_nc + !> Write a 0D field to the MOM netcdf file + procedure :: write_field_0d => write_field_0d_nc + !> Write an axis field to the MOM netcdf file + procedure :: write_field_axis => write_field_axis_nc + + !> Return true if MOM netcdf file has been opened + procedure :: file_is_open => file_is_open_nc + !> Return number of dimensions, variables, or time levels in a MOM netcdf file + procedure :: get_file_info => get_file_info_nc + !> Get field metadata from a MOM netcdf file + procedure :: get_file_fields => get_file_fields_nc + !> Get attributes from a netCDF field + procedure :: get_field_atts => get_field_atts_nc + !> Get checksum from a netCDF field + procedure :: read_field_chksum => read_field_chksum_nc + + ! NOTE: These are currently exclusive to netCDF I/O but could be generalized + !> Read the values of a netCDF field + procedure :: read => get_field_nc + !> Update the axes and fields descriptors of a MOM netCDF file + procedure :: update => update_file_contents_nc +end type MOM_netcdf_file + + +interface + !> Interface for opening a MOM file + subroutine i_open_file(handle, filename, action, MOM_domain, threading, fileset) + import :: MOM_file, MOM_domain_type + + class(MOM_file), intent(inout) :: handle + !< The handle for the opened file + character(len=*), intent(in) :: filename + !< The path name of the file being opened + integer, optional, intent(in) :: action + !< A flag indicating whether the file can be read or written to and how + !! to handle existing files. The default is WRITE_ONLY. + type(MOM_domain_type), optional, intent(in) :: MOM_Domain + !< A MOM_Domain that describes the decomposition + integer, optional, intent(in) :: threading + !< A flag indicating whether one (SINGLE_FILE) or multiple PEs (MULTIPLE) + !! participate in I/O. With the default, the root PE does I/O. + integer, optional, intent(in) :: fileset + !< A flag indicating whether multiple PEs doing I/O due to + !! threading=MULTIPLE write to the same file (SINGLE_FILE) or to one file + !! per PE (MULTIPLE, the default). + end subroutine i_open_file + + + !> Interface for closing a MOM file + subroutine i_close_file(handle) + import :: MOM_file + class(MOM_file), intent(inout) :: handle + !< The MOM file to be closed + end subroutine i_close_file + + + !> Interface for flushing I/O in a MOM file + subroutine i_flush_file(handle) + import :: MOM_file + class(MOM_file), intent(in) :: handle + !< The MOM file to be flushed + end subroutine i_flush_file + + + !> Interface to register an axis to a MOM file + function i_register_axis(handle, label, units, longname, cartesian, sense, & + domain, data, edge_axis, calendar) result(axis) + import :: MOM_file, MOM_axis, domain1D + + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for writing + character(len=*), intent(in) :: label + !< The name in the file of this axis + character(len=*), intent(in) :: units + !< The units of this axis + character(len=*), intent(in) :: longname + !< The long description of this axis + character(len=*), optional, intent(in) :: cartesian + !< A variable indicating which direction this axis corresponds with. + !! Valid values include 'X', 'Y', 'Z', 'T', and 'N' for none. + integer, optional, intent(in) :: sense + !< This is 1 for axes whose values increase upward, or -1 if they + !! increase downward. + type(domain1D), optional, intent(in) :: domain + !< The domain decomposion for this axis + real, dimension(:), optional, intent(in) :: data + !< The coordinate values of the points on this axis + logical, optional, intent(in) :: edge_axis + !< If true, this axis marks an edge of the tracer cells + character(len=*), optional, intent(in) :: calendar + !< The name of the calendar used with a time axis + type(MOM_axis) :: axis + !< IO handle for axis in MOM_file + end function i_register_axis + + + !> Interface to register a field to a netCDF file + function i_register_field(handle, axes, label, units, longname, & + pack, standard_name, checksum, conversion) result(field) + import :: MOM_file, MOM_axis, MOM_field, int64 + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_axis), intent(in) :: axes(:) + !< Handles for the axis used for this variable + character(len=*), intent(in) :: label + !< The name in the file of this variable + character(len=*), intent(in) :: units + !< The units of this variable + character(len=*), intent(in) :: longname + !< The long description of this variable + integer, optional, intent(in) :: pack + !< A precision reduction factor with which the variable. The default, 1, + !! has no reduction, but 2 is not uncommon. + character(len=*), optional, intent(in) :: standard_name + !< The standard (e.g., CMOR) name for this variable + integer(kind=int64), dimension(:), optional, intent(in) :: checksum + !< Checksum values that can be used to verify reads. + real, optional, intent(in) :: conversion + !< A factor to use to rescale the field before output [a A-1 ~> 1] + type(MOM_field) :: field + !< IO handle for field in MOM_file + end function i_register_field + + + !> Interface for writing global metata to a MOM file + subroutine i_write_attribute(handle, name, attribute) + import :: MOM_file + class(MOM_file), intent(in) :: handle + !< Handle for a file that is open for writing + character(len=*), intent(in) :: name + !< The name in the file of this global attribute + character(len=*), intent(in) :: attribute + !< The value of this attribute + end subroutine i_write_attribute + + + !> Interface to write_field_4d() + subroutine i_write_field_4d(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + import :: MOM_file, MOM_field, MOM_domain_type + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, intent(inout) :: field(:,:,:,:) + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + end subroutine i_write_field_4d + + + !> Interface to write_field_3d() + subroutine i_write_field_3d(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + import :: MOM_file, MOM_field, MOM_domain_type + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, intent(inout) :: field(:,:,:) + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + end subroutine i_write_field_3d + + + !> Interface to write_field_2d() + subroutine i_write_field_2d(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + import :: MOM_file, MOM_field, MOM_domain_type + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, dimension(:,:), intent(inout) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + end subroutine i_write_field_2d + + + !> Interface to write_field_1d() + subroutine i_write_field_1d(handle, field_md, field, tstamp) + import :: MOM_file, MOM_field + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + real, dimension(:), intent(in) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + end subroutine i_write_field_1d + + + !> Interface to write_field_0d() + subroutine i_write_field_0d(handle, field_md, field, tstamp) + import :: MOM_file, MOM_field + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + real, intent(in) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + end subroutine i_write_field_0d + + + !> Interface to write_field_axis() + subroutine i_write_field_axis(handle, axis) + import :: MOM_file, MOM_axis + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_axis), intent(in) :: axis + !< An axis type variable with information to write + end subroutine i_write_field_axis + + + !> Interface to file_is_open() + logical function i_file_is_open(handle) + import :: MOM_file + class(MOM_file), intent(in) :: handle + !< Handle to a file to inquire about + end function i_file_is_open + + + !> Interface to get_file_info() + subroutine i_get_file_info(handle, ndim, nvar, ntime) + import :: MOM_file + class(MOM_file), intent(in) :: handle + !< Handle for a file that is open for I/O + integer, optional, intent(out) :: ndim + !< The number of dimensions in the file + integer, optional, intent(out) :: nvar + !< The number of variables in the file + integer, optional, intent(out) :: ntime + !< The number of time levels in the file + end subroutine i_get_file_info + + + !> Interface to get_file_fields() + subroutine i_get_file_fields(handle, fields) + import :: MOM_file, MOM_field + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for I/O + type(MOM_field), dimension(:), intent(inout) :: fields + !< Field-type descriptions of all of the variables in a file. + end subroutine i_get_file_fields + + + !> Interface to get_field_atts() + subroutine i_get_field_atts(handle, field, name, units, longname, checksum) + import :: MOM_file, MOM_field, int64 + class(MOM_file), intent(in) :: handle + !< File where field is stored + type(MOM_field), intent(in) :: field + !< The field to extract information from + character(len=*), optional, intent(out) :: name + !< The variable name + character(len=*), optional, intent(out) :: units + !< The units of the variable + character(len=*), optional, intent(out) :: longname + !< The long name of the variable + integer(kind=int64), optional, intent(out) :: checksum(:) + !< The checksums of the variable in a file + end subroutine i_get_field_atts + + + !> Interface to read_field_chksum + subroutine i_read_field_chksum(handle, field, chksum, valid_chksum) + import :: MOM_file, MOM_field, int64 + class(MOM_file), intent(in) :: handle + !< File where field is stored + type(MOM_field), intent(in) :: field + !< The field whose checksum attribute is to be read + integer(kind=int64), intent(out) :: chksum + !< The checksum for the field. + logical, intent(out) :: valid_chksum + !< If true, chksum has been successfully read + end subroutine i_read_field_chksum +end interface + +contains + +!> Initialize the linked list of framework axes +subroutine initialize_axis_list_infra(list) + class(axis_list_infra), intent(inout) :: list + + ! Pre-allocate the first node and set the tail to this empty node + allocate(list%head) + list%tail => list%head +end subroutine initialize_axis_list_infra + + +!> Append a new axis to the list +subroutine append_axis_list_infra(list, axis, label) + class(axis_list_infra), intent(inout) :: list + type(axistype), intent(in) :: axis + character(len=*), intent(in) :: label + + type(axis_node_infra), pointer :: empty_node + + ! Transfer value to tail + list%tail%label = label + list%tail%axis = axis + + ! Extend list to next empty node + allocate(empty_node) + list%tail%next => empty_node + list%tail => empty_node +end subroutine append_axis_list_infra + + +!> Get axis based on label +function get_axis_list_infra(list, label) result(axis) + class(axis_list_infra), intent(in) :: list + character(len=*), intent(in) :: label + type(axistype) :: axis + + type(axis_node_infra), pointer :: node + + ! NOTE: The tail is a pre-allocated empty node, so we check node%next + node => list%head + do while(associated(node%next)) + if (node%label == label) exit + node => node%next + enddo + if (.not. associated(node)) & + call MOM_error(FATAL, "axis associated with " // label // " not found.") + + axis = node%axis +end function get_axis_list_infra + + +!> Deallocate axes of list +subroutine finalize_axis_list_infra(list) + class(axis_list_infra), intent(inout) :: list + + type(axis_node_infra), pointer :: node, next_node + + node => list%head + do while(associated(node)) + next_node => node + node => node%next + deallocate(next_node) + enddo +end subroutine finalize_axis_list_infra + + +!> Initialize the linked list of framework axes +subroutine initialize_axis_list_nc(list) + class(axis_list_nc), intent(inout) :: list + + ! Pre-allocate the first node and set the tail to this empty node + allocate(list%head) + list%tail => list%head +end subroutine initialize_axis_list_nc + + +!> Append a new axis to the list +subroutine append_axis_list_nc(list, axis, label) + class(axis_list_nc), intent(inout) :: list + type(netcdf_axis), intent(in) :: axis + character(len=*), intent(in) :: label + + type(axis_node_nc), pointer :: empty_node + + ! Transfer value to tail + list%tail%label = label + list%tail%axis = axis + + ! Extend list to next empty node + allocate(empty_node) + list%tail%next => empty_node + list%tail => empty_node +end subroutine append_axis_list_nc + + +!> Get axis based on label +function get_axis_list_nc(list, label) result(axis) + class(axis_list_nc), intent(in) :: list + character(len=*), intent(in) :: label + type(netcdf_axis) :: axis + + type(axis_node_nc), pointer :: node + + ! NOTE: The tail is a pre-allocated empty node, so we check node%next + node => list%head + do while(associated(node%next)) + if (node%label == label) exit + node => node%next + enddo + if (.not. associated(node)) & + call MOM_error(FATAL, "axis associated with " // label // " not found.") + + axis = node%axis +end function get_axis_list_nc + + +!> Deallocate axes of list +subroutine finalize_axis_list_nc(list) + class(axis_list_nc), intent(inout) :: list + + type(axis_node_nc), pointer :: node, next_node + + node => list%head + do while(associated(node)) + next_node => node + node => node%next + deallocate(next_node) + enddo +end subroutine finalize_axis_list_nc + + +!> Initialize the linked list of framework axes +subroutine initialize_field_list_infra(list) + class(field_list_infra), intent(inout) :: list + + ! Pre-allocate the first node and set the tail to this empty node + allocate(list%head) + list%tail => list%head +end subroutine initialize_field_list_infra + + +!> Append a new field to the list +subroutine append_field_list_infra(list, field, label) + class(field_list_infra), intent(inout) :: list + type(fieldtype), intent(in) :: field + character(len=*), intent(in) :: label + + type(field_node_infra), pointer :: empty_node + + ! Transfer value to tail + list%tail%label = label + list%tail%field = field + + ! Extend list to next empty node + allocate(empty_node) + list%tail%next => empty_node + list%tail => empty_node +end subroutine append_field_list_infra + + +!> Get axis based on label +function get_field_list_infra(list, label) result(field) + class(field_list_infra), intent(in) :: list + character(len=*), intent(in) :: label + type(fieldtype) :: field + + type(field_node_infra), pointer :: node + + ! NOTE: The tail is a pre-allocated empty node, so we check node%next + node => list%head + do while(associated(node%next)) + if (node%label == label) exit + node => node%next + enddo + if (.not. associated(node)) & + call MOM_error(FATAL, "field associated with " // label // " not found.") + + field = node%field +end function get_field_list_infra + + +!> Deallocate fields of list +subroutine finalize_field_list_infra(list) + class(field_list_infra), intent(inout) :: list + + type(field_node_infra), pointer :: node, next_node + + node => list%head + do while(associated(node)) + next_node => node + node => node%next + deallocate(next_node) + enddo +end subroutine finalize_field_list_infra + + +!> Initialize the linked list of framework axes +subroutine initialize_field_list_nc(list) + class(field_list_nc), intent(inout) :: list + + ! Pre-allocate the first node and set the tail to this empty node + allocate(list%head) + list%tail => list%head +end subroutine initialize_field_list_nc + + +!> Append a new field to the list +subroutine append_field_list_nc(list, field, label) + class(field_list_nc), intent(inout) :: list + type(netcdf_field), intent(in) :: field + character(len=*), intent(in) :: label + + type(field_node_nc), pointer :: empty_node + + ! Transfer value to tail + list%tail%label = label + list%tail%field = field + + ! Extend list to next empty node + allocate(empty_node) + list%tail%next => empty_node + list%tail => empty_node +end subroutine append_field_list_nc + + +!> Get axis based on label +function get_field_list_nc(list, label) result(field) + class(field_list_nc), intent(in) :: list + character(len=*), intent(in) :: label + type(netcdf_field) :: field + + type(field_node_nc), pointer :: node + + ! NOTE: The tail is a pre-allocated empty node, so we check node%next + node => list%head + do while(associated(node%next)) + if (node%label == label) exit + node => node%next + enddo + if (.not. associated(node)) & + call MOM_error(FATAL, "field associated with " // label // " not found.") + + field = node%field +end function get_field_list_nc + + +!> Deallocate fields of list +subroutine finalize_field_list_nc(list) + class(field_list_nc), intent(inout) :: list + + type(field_node_nc), pointer :: node, next_node + + node => list%head + do while(associated(node)) + next_node => node + node => node%next + deallocate(next_node) + enddo +end subroutine finalize_field_list_nc + + +!> Open a MOM framework file +subroutine open_file_infra(handle, filename, action, MOM_domain, threading, fileset) + class(MOM_infra_file), intent(inout) :: handle + character(len=*), intent(in) :: filename + integer, intent(in), optional :: action + type(MOM_domain_type), optional, intent(in) :: MOM_domain + integer, intent(in), optional :: threading + integer, intent(in), optional :: fileset + + logical :: use_single_file_domain + ! True if the domain is replaced with a single-file IO layout. + + use_single_file_domain = .false. + if (present(MOM_domain) .and. present(fileset)) then + if (fileset == SINGLE_FILE) & + use_single_file_domain = .true. + endif + + if (use_single_file_domain) then + call clone_MOM_domain(MOM_domain, handle%domain, io_layout=[1,1]) + call open_file(handle%handle_infra, filename, action=action, & + MOM_domain=handle%domain, threading=threading, fileset=fileset) + else + call open_file(handle%handle_infra, filename, action=action, & + MOM_domain=MOM_domain, threading=threading, fileset=fileset) + endif + + call handle%axes%init() + call handle%fields%init() +end subroutine open_file_infra + +!> Close a MOM framework file +subroutine close_file_infra(handle) + class(MOM_infra_file), intent(inout) :: handle + + if (associated(handle%domain)) & + call deallocate_MOM_domain(handle%domain) + + call close_file(handle%handle_infra) + call handle%axes%finalize() + call handle%fields%finalize() +end subroutine close_file_infra + +!> Flush the buffer of a MOM framework file +subroutine flush_file_infra(handle) + class(MOM_infra_file), intent(in) :: handle + + call flush_file(handle%handle_infra) +end subroutine flush_file_infra + + +!> Register an axis to the MOM framework file +function register_axis_infra(handle, label, units, longname, & + cartesian, sense, domain, data, edge_axis, calendar) result(axis) + + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for writing + character(len=*), intent(in) :: label + !< The name in the file of this axis + character(len=*), intent(in) :: units + !< The units of this axis + character(len=*), intent(in) :: longname + !< The long description of this axis + character(len=*), optional, intent(in) :: cartesian + !< A variable indicating which direction this axis corresponds with. + !! Valid values include 'X', 'Y', 'Z', 'T', and 'N' for none. + integer, optional, intent(in) :: sense + !< This is 1 for axes whose values increase upward, or -1 if they increase + !! downward. + type(domain1D), optional, intent(in) :: domain + !< The domain decomposion for this axis + real, dimension(:), optional, intent(in) :: data + !< The coordinate values of the points on this axis + logical, optional, intent(in) :: edge_axis + !< If true, this axis marks an edge of the tracer cells + character(len=*), optional, intent(in) :: calendar + !< The name of the calendar used with a time axis + type(MOM_axis) :: axis + !< The axis type where this information is stored + + type(axistype) :: ax_infra + + ! Create new infra axis and assign to pre-allocated tail of axes + call write_metadata(handle%handle_infra, ax_infra, label, units, longname, & + cartesian=cartesian, sense=sense, domain=domain, data=data, & + edge_axis=edge_axis, calendar=calendar) + + call handle%axes%append(ax_infra, label) + axis%label = label +end function register_axis_infra + + +!> Register a field to the MOM framework file +function register_field_infra(handle, axes, label, units, longname, pack, & + standard_name, checksum, conversion) result(field) + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_axis), dimension(:), intent(in) :: axes + !< Handles for the axis used for this variable + character(len=*), intent(in) :: label + !< The name in the file of this variable + character(len=*), intent(in) :: units + !< The units of this variable + character(len=*), intent(in) :: longname + !< The long description of this variable + integer, optional, intent(in) :: pack + !< A precision reduction factor with which the variable. The default, 1, + !! has no reduction, but 2 is not uncommon. + character(len=*), optional, intent(in) :: standard_name + !< The standard (e.g., CMOR) name for this variable + integer(kind=int64), dimension(:), optional, intent(in) :: checksum + !< Checksum values that can be used to verify reads. + real, optional, intent(in) :: conversion + !< A factor to use to rescale the field before output [a A-1 ~> 1] + type(MOM_field) :: field + !< The field type where this information is stored + + type(fieldtype) :: field_infra + type(axistype), allocatable :: field_axes(:) + integer :: i + + ! Construct array of framework axes + allocate(field_axes(size(axes))) + do i = 1, size(axes) + field_axes(i) = handle%axes%get(axes(i)%label) + enddo + + call write_metadata(handle%handle_infra, field_infra, field_axes, label, & + units, longname, pack=pack, standard_name=standard_name, checksum=checksum) + + call handle%fields%append(field_infra, label) + field%label = label + field%conversion = 1.0 ; if (present(conversion)) field%conversion = conversion +end function register_field_infra + + +!> Write a 4D field to the MOM framework file +subroutine write_field_4d_infra(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, intent(inout) :: field(:,:,:,:) + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + + type(fieldtype) :: field_infra + real, allocatable :: unscaled_field(:,:,:,:) ! An unscaled version of field for output [a] + + field_infra = handle%fields%get(field_md%label) + if (field_md%conversion == 1.0) then + call write_field(handle%handle_infra, field_infra, MOM_domain, field, & + tstamp=tstamp, tile_count=tile_count, fill_value=fill_value) + else + allocate(unscaled_field, source=field) + unscaled_field(:,:,:,:) = field_md%conversion * field(:,:,:,:) + call write_field(handle%handle_infra, field_infra, MOM_domain, unscaled_field, & + tstamp=tstamp, tile_count=tile_count, fill_value=fill_value) + deallocate(unscaled_field) + endif +end subroutine write_field_4d_infra + + +!> Write a 3D field to the MOM framework file +subroutine write_field_3d_infra(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, intent(inout) :: field(:,:,:) + !< Field to write, perhaps in arbitrary rescaled units [A ~> a] + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + + type(fieldtype) :: field_infra + real, allocatable :: unscaled_field(:,:,:) ! An unscaled version of field for output [a] + + field_infra = handle%fields%get(field_md%label) + if (field_md%conversion == 1.0) then + call write_field(handle%handle_infra, field_infra, MOM_domain, field, & + tstamp=tstamp, tile_count=tile_count, fill_value=fill_value) + else + allocate(unscaled_field, source=field) + unscaled_field(:,:,:) = field_md%conversion * field(:,:,:) + call write_field(handle%handle_infra, field_infra, MOM_domain, unscaled_field, & + tstamp=tstamp, tile_count=tile_count, fill_value=fill_value) + deallocate(unscaled_field) + endif + +end subroutine write_field_3d_infra + + +!> Write a 2D field to the MOM framework file +subroutine write_field_2d_infra(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, dimension(:,:), intent(inout) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + + type(fieldtype) :: field_infra + real, allocatable :: unscaled_field(:,:) ! An unscaled version of field for output [a] + + field_infra = handle%fields%get(field_md%label) + if (field_md%conversion == 1.0) then + call write_field(handle%handle_infra, field_infra, MOM_domain, field, & + tstamp=tstamp, tile_count=tile_count, fill_value=fill_value) + else + allocate(unscaled_field, source=field) + unscaled_field(:,:) = field_md%conversion * field(:,:) + call write_field(handle%handle_infra, field_infra, MOM_domain, unscaled_field, & + tstamp=tstamp, tile_count=tile_count, fill_value=fill_value) + deallocate(unscaled_field) + endif +end subroutine write_field_2d_infra + + +!> Write a 1D field to the MOM framework file +subroutine write_field_1d_infra(handle, field_md, field, tstamp) + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + real, dimension(:), intent(in) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + + type(fieldtype) :: field_infra + real, allocatable :: unscaled_field(:) ! An unscaled version of field for output [a] + + field_infra = handle%fields%get(field_md%label) + if (field_md%conversion == 1.0) then + call write_field(handle%handle_infra, field_infra, field, tstamp=tstamp) + else + allocate(unscaled_field, source=field) + unscaled_field(:) = field_md%conversion * field(:) + call write_field(handle%handle_infra, field_infra, unscaled_field, tstamp=tstamp) + deallocate(unscaled_field) + endif +end subroutine write_field_1d_infra + + +!> Write a 0D field to the MOM framework file +subroutine write_field_0d_infra(handle, field_md, field, tstamp) + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + real, intent(in) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + + type(fieldtype) :: field_infra + real :: unscaled_field ! An unscaled version of field for output [a] + + field_infra = handle%fields%get(field_md%label) + unscaled_field = field_md%conversion*field + call write_field(handle%handle_infra, field_infra, unscaled_field, tstamp=tstamp) +end subroutine write_field_0d_infra + + +!> Write an axis field to the MOM framework file +subroutine write_field_axis_infra(handle, axis) + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_axis), intent(in) :: axis + !< An axis type variable with information to write + + type(axistype) :: axis_infra + !< An axis type variable with information to write + + axis_infra = handle%axes%get(axis%label) + call write_field(handle%handle_infra, axis_infra) +end subroutine write_field_axis_infra + + +!> Write global metadata to the MOM framework file +subroutine write_attribute_infra(handle, name, attribute) + class(MOM_infra_file), intent(in) :: handle + !< Handle for a file that is open for writing + character(len=*), intent(in) :: name + !< The name in the file of this global attribute + character(len=*), intent(in) :: attribute + !< The value of this attribute + + call write_metadata(handle%handle_infra, name, attribute) +end subroutine write_attribute_infra + + +!> True if the framework file has been opened +logical function file_is_open_infra(handle) + class(MOM_infra_file), intent(in) :: handle + !< Handle to a file to inquire about + + file_is_open_infra = fms2_file_is_open(handle%handle_infra) +end function file_is_open_infra + + +!> Return number of dimensions, variables, or time levels in a MOM infra file +subroutine get_file_info_infra(handle, ndim, nvar, ntime) + class(MOM_infra_file), intent(in) :: handle + !< Handle for a file that is open for I/O + integer, optional, intent(out) :: ndim + !< The number of dimensions in the file + integer, optional, intent(out) :: nvar + !< The number of variables in the file + integer, optional, intent(out) :: ntime + !< The number of time levels in the file + + call get_file_info(handle%handle_infra, ndim, nvar, ntime) +end subroutine get_file_info_infra + + +!> Return the field metadata associated with a MOM framework file +subroutine get_file_fields_infra(handle, fields) + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for I/O + type(MOM_field), intent(inout) :: fields(:) + !< Field-type descriptions of all of the variables in a file. + + type(fieldtype), allocatable :: fields_infra(:) + integer :: i + character(len=64) :: label + + allocate(fields_infra(size(fields))) + call get_file_fields(handle%handle_infra, fields_infra) + + do i = 1, size(fields) + call get_field_atts(fields_infra(i), name=label) + call handle%fields%append(fields_infra(i), trim(label)) + fields(i)%label = trim(label) + enddo +end subroutine get_file_fields_infra + + +!> Get time levels of a MOM framework file +subroutine get_file_times_infra(handle, time_values, ntime) + class(MOM_infra_file), intent(in) :: handle + !< Handle for a file that is open for I/O + real, allocatable, dimension(:), intent(inout) :: time_values + !< The real times for the records in file. + integer, optional, intent(out) :: ntime + !< The number of time levels in the file + + call get_file_times(handle%handle_infra, time_values, ntime=ntime) +end subroutine get_file_times_infra + + +!> Get attributes from a field +subroutine get_field_atts_infra(handle, field, name, units, longname, checksum) + class(MOM_infra_file), intent(in) :: handle + !< File where field is stored + type(MOM_field), intent(in) :: field + !< The field to extract information from + character(len=*), optional, intent(out) :: name + !< The variable name + character(len=*), optional, intent(out) :: units + !< The units of the variable + character(len=*), optional, intent(out) :: longname + !< The long name of the variable + integer(kind=int64), optional, intent(out) :: checksum(:) + !< The checksums of the variable in a file + + type(fieldtype) :: field_infra + + field_infra = handle%fields%get(field%label) + call get_field_atts(field_infra, name, units, longname, checksum) +end subroutine get_field_atts_infra + + +!> Interface to read_field_chksum +subroutine read_field_chksum_infra(handle, field, chksum, valid_chksum) + class(MOM_infra_file), intent(in) :: handle + !< File where field is stored + type(MOM_field), intent(in) :: field + !< The field whose checksum attribute is to be read + integer(kind=int64), intent(out) :: chksum + !< The checksum for the field. + logical, intent(out) :: valid_chksum + !< If true, chksum has been successfully read + + type(fieldtype) :: field_infra + + field_infra = handle%fields%get(field%label) + call read_field_chksum(field_infra, chksum, valid_chksum) +end subroutine read_field_chksum_infra + +!> Get the native (fieldtype) fields of a MOM framework file +subroutine get_file_fieldtypes(handle, fields) + class(MOM_infra_file), intent(in) :: handle + type(fieldtype), intent(out) :: fields(:) + + type(field_node_infra), pointer :: node + integer :: i + + ! NOTE: The tail is a pre-allocated empty node, so we check node%next + node => handle%fields%head + do i = 1, size(fields) + if (.not. associated(node%next)) & + call MOM_error(FATAL, 'fields(:) size exceeds number of registered fields.') + fields(i) = node%field + node => node%next + enddo +end subroutine get_file_fieldtypes + + +! MOM_netcdf_file methods + +!> Open a MOM netCDF file +subroutine open_file_nc(handle, filename, action, MOM_domain, threading, fileset) + class(MOM_netcdf_file), intent(inout) :: handle + character(len=*), intent(in) :: filename + integer, intent(in), optional :: action + type(MOM_domain_type), optional, intent(in) :: MOM_domain + integer, intent(in), optional :: threading + integer, intent(in), optional :: fileset + + if (.not. present(MOM_domain) .and. .not. is_root_PE()) return + + call open_netcdf_file(handle%handle_nc, filename, action) + handle%is_open = .true. + + if (present(MOM_domain)) then + handle%domain_decomposed = .true. + + ! Input files use unrotated indexing. + if (associated(MOM_domain%domain_in)) then + call hor_index_init(MOM_domain%domain_in, handle%HI) + else + call hor_index_init(MOM_domain, handle%HI) + endif + endif + + call handle%axes%init() + call handle%fields%init() +end subroutine open_file_nc + + +!> Close a MOM netCDF file +subroutine close_file_nc(handle) + class(MOM_netcdf_file), intent(inout) :: handle + + if (.not. handle%domain_decomposed .and. .not. is_root_PE()) return + + handle%is_open = .false. + call close_netcdf_file(handle%handle_nc) +end subroutine close_file_nc + + +!> Flush the buffer of a MOM netCDF file +subroutine flush_file_nc(handle) + class(MOM_netcdf_file), intent(in) :: handle + + if (.not. is_root_PE()) return + + call flush_netcdf_file(handle%handle_nc) +end subroutine flush_file_nc + + +!> Register an axis to the MOM netcdf file +function register_axis_nc(handle, label, units, longname, cartesian, sense, & + domain, data, edge_axis, calendar) result(axis) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a netCDF file that is open for writing + character(len=*), intent(in) :: label + !< The name in the file of this axis + character(len=*), intent(in) :: units + !< The units of this axis + character(len=*), intent(in) :: longname + !< The long description of this axis + character(len=*), optional, intent(in) :: cartesian + !< A variable indicating which direction this axis corresponds with. + !! Valid values include 'X', 'Y', 'Z', 'T', and 'N' for none. + integer, optional, intent(in) :: sense + !< This is 1 for axes whose values increase upward, or -1 if they increase + !! downward. + type(domain1D), optional, intent(in) :: domain + !< The domain decomposion for this axis + real, dimension(:), optional, intent(in) :: data + !< The coordinate values of the points on this axis + logical, optional, intent(in) :: edge_axis + !< If true, this axis marks an edge of the tracer cells + character(len=*), optional, intent(in) :: calendar + !< The name of the calendar used with a time axis + type(MOM_axis) :: axis + + type(netcdf_axis) :: axis_nc + + if (is_root_PE()) then + axis_nc = register_netcdf_axis(handle%handle_nc, label, units, longname, & + data, cartesian, sense) + + call handle%axes%append(axis_nc, label) + endif + axis%label = label +end function register_axis_nc + + +!> Register a field to the MOM netcdf file +function register_field_nc(handle, axes, label, units, longname, pack, & + standard_name, checksum, conversion) result(field) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_axis), intent(in) :: axes(:) + !< Handles for the axis used for this variable + character(len=*), intent(in) :: label + !< The name in the file of this variable + character(len=*), intent(in) :: units + !< The units of this variable + character(len=*), intent(in) :: longname + !< The long description of this variable + integer, optional, intent(in) :: pack + !< A precision reduction factor with which the variable. The default, 1, + !! has no reduction, but 2 is not uncommon. + character(len=*), optional, intent(in) :: standard_name + !< The standard (e.g., CMOR) name for this variable + integer(kind=int64), dimension(:), optional, intent(in) :: checksum + !< Checksum values that can be used to verify reads. + real, optional, intent(in) :: conversion + !< A factor to use to rescale the field before output [a A-1 ~> 1] + type(MOM_field) :: field + + type(netcdf_field) :: field_nc + type(netcdf_axis), allocatable :: axes_nc(:) + integer :: i + + if (is_root_PE()) then + allocate(axes_nc(size(axes))) + do i = 1, size(axes) + axes_nc(i) = handle%axes%get(axes(i)%label) + enddo + + field_nc = register_netcdf_field(handle%handle_nc, label, axes_nc, longname, units) + + call handle%fields%append(field_nc, label) + endif + field%label = label + field%conversion = 1.0 ; if (present(conversion)) field%conversion = conversion +end function register_field_nc + + +!> Write global metadata to the MOM netcdf file +subroutine write_attribute_nc(handle, name, attribute) + class(MOM_netcdf_file), intent(in) :: handle + !< Handle for a file that is open for writing + character(len=*), intent(in) :: name + !< The name in the file of this global attribute + character(len=*), intent(in) :: attribute + !< The value of this attribute + + if (.not. is_root_PE()) return + + call write_netcdf_attribute(handle%handle_nc, name, attribute) +end subroutine write_attribute_nc + + +!> Write a 4D field to the MOM netcdf file +subroutine write_field_4d_nc(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, intent(inout) :: field(:,:,:,:) + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + + type(netcdf_field) :: field_nc + real, allocatable :: unscaled_field(:,:,:,:) ! An unscaled version of field for output [a] + + if (.not. is_root_PE()) return + + field_nc = handle%fields%get(field_md%label) + if (field_md%conversion == 1.0) then + call write_netcdf_field(handle%handle_nc, field_nc, field, time=tstamp) + else + allocate(unscaled_field, source=field) + unscaled_field(:,:,:,:) = field_md%conversion * field(:,:,:,:) + call write_netcdf_field(handle%handle_nc, field_nc, unscaled_field, time=tstamp) + deallocate(unscaled_field) + endif +end subroutine write_field_4d_nc + + +!> Write a 3D field to the MOM netcdf file +subroutine write_field_3d_nc(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, intent(inout) :: field(:,:,:) + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + + type(netcdf_field) :: field_nc + real, allocatable :: unscaled_field(:,:,:) ! An unscaled version of field for output [a] + + if (.not. is_root_PE()) return + + field_nc = handle%fields%get(field_md%label) + if (field_md%conversion == 1.0) then + call write_netcdf_field(handle%handle_nc, field_nc, field, time=tstamp) + else + allocate(unscaled_field, source=field) + unscaled_field(:,:,:) = field_md%conversion * field(:,:,:) + call write_netcdf_field(handle%handle_nc, field_nc, unscaled_field, time=tstamp) + deallocate(unscaled_field) + endif +end subroutine write_field_3d_nc + + +!> Write a 2D field to the MOM netcdf file +subroutine write_field_2d_nc(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, dimension(:,:), intent(inout) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + + type(netcdf_field) :: field_nc + real, allocatable :: unscaled_field(:,:) ! An unscaled version of field for output [a] + + if (.not. is_root_PE()) return + + field_nc = handle%fields%get(field_md%label) + if (field_md%conversion == 1.0) then + call write_netcdf_field(handle%handle_nc, field_nc, field, time=tstamp) + else + allocate(unscaled_field, source=field) + unscaled_field(:,:) = field_md%conversion * field(:,:) + call write_netcdf_field(handle%handle_nc, field_nc, unscaled_field, time=tstamp) + deallocate(unscaled_field) + endif +end subroutine write_field_2d_nc + + +!> Write a 1D field to the MOM netcdf file +subroutine write_field_1d_nc(handle, field_md, field, tstamp) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + real, dimension(:), intent(in) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + + type(netcdf_field) :: field_nc + real, allocatable :: unscaled_field(:) ! An unscaled version of field for output [a] + + if (.not. is_root_PE()) return + + field_nc = handle%fields%get(field_md%label) + if (field_md%conversion == 1.0) then + call write_netcdf_field(handle%handle_nc, field_nc, field, time=tstamp) + else + allocate(unscaled_field, source=field) + unscaled_field(:) = field_md%conversion * field(:) + call write_netcdf_field(handle%handle_nc, field_nc, unscaled_field, time=tstamp) + deallocate(unscaled_field) + endif +end subroutine write_field_1d_nc + + +!> Write a 0D field to the MOM netcdf file +subroutine write_field_0d_nc(handle, field_md, field, tstamp) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + real, intent(in) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + + type(netcdf_field) :: field_nc + real :: unscaled_field ! An unscaled version of field for output [a] + + if (.not. is_root_PE()) return + + field_nc = handle%fields%get(field_md%label) + unscaled_field = field_md%conversion * field + call write_netcdf_field(handle%handle_nc, field_nc, unscaled_field, time=tstamp) +end subroutine write_field_0d_nc + + +!> Write an axis field to the MOM netcdf file +subroutine write_field_axis_nc(handle, axis) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_axis), intent(in) :: axis + !< An axis type variable with information to write + + type(netcdf_axis) :: axis_nc + + if (.not. is_root_PE()) return + + axis_nc = handle%axes%get(axis%label) + call write_netcdf_axis(handle%handle_nc, axis_nc) +end subroutine write_field_axis_nc + + +!> True if the framework file has been opened +logical function file_is_open_nc(handle) + class(MOM_netcdf_file), intent(in) :: handle + !< Handle to a file to inquire about + + file_is_open_nc = handle%is_open +end function file_is_open_nc + + +!> Return number of dimensions, variables, or time levels in a MOM netcdf file +subroutine get_file_info_nc(handle, ndim, nvar, ntime) + class(MOM_netcdf_file), intent(in) :: handle + !< Handle for a file that is open for I/O + integer, optional, intent(out) :: ndim + !< The number of dimensions in the file + integer, optional, intent(out) :: nvar + !< The number of variables in the file + integer, optional, intent(out) :: ntime + !< The number of time levels in the file + + integer :: ndim_nc, nvar_nc + + if (.not. is_root_PE()) return + + call get_netcdf_size(handle%handle_nc, ndims=ndim_nc, nvars=nvar_nc, nsteps=ntime) + + ! MOM I/O follows legacy FMS behavior and excludes axes from field count + if (present(ndim)) ndim = ndim_nc + if (present(nvar)) nvar = nvar_nc - ndim_nc +end subroutine get_file_info_nc + + +!> Update the axes and fields descriptors of a MOM netCDF file +subroutine update_file_contents_nc(handle) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for I/O + + type(netcdf_axis), allocatable :: axes_nc(:) + ! netCDF axis descriptors + type(netcdf_field), allocatable :: fields_nc(:) + ! netCDF field descriptors + integer :: i + ! Index counter + + if (.not. handle%domain_decomposed .and. .not. is_root_PE()) return + + call get_netcdf_fields(handle%handle_nc, axes_nc, fields_nc) + + do i = 1, size(axes_nc) + call handle%axes%append(axes_nc(i), axes_nc(i)%label) + enddo + + do i = 1, size(fields_nc) + call handle%fields%append(fields_nc(i), fields_nc(i)%label) + enddo +end subroutine update_file_contents_nc + + +!> Return the field descriptors of a MOM netCDF file +subroutine get_file_fields_nc(handle, fields) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for I/O + type(MOM_field), intent(inout) :: fields(:) + !< Field-type descriptions of all of the variables in a file. + + type(field_node_nc), pointer :: node => null() + ! Current field list node + integer :: n + ! Field counter + + if (.not. is_root_PE()) return + + ! Generate the manifest of axes and fields + call handle%update() + + n = 0 + node => handle%fields%head + do while (associated(node%next)) + n = n + 1 + fields(n)%label = trim(node%label) + node => node%next + enddo +end subroutine get_file_fields_nc + + +!> Get attributes from a netCDF field +subroutine get_field_atts_nc(handle, field, name, units, longname, checksum) + class(MOM_netcdf_file), intent(in) :: handle + !< File where field is stored + type(MOM_field), intent(in) :: field + !< The field to extract information from + character(len=*), optional, intent(out) :: name + !< The variable name + character(len=*), optional, intent(out) :: units + !< The units of the variable + character(len=*), optional, intent(out) :: longname + !< The long name of the variable + integer(kind=int64), optional, intent(out) :: checksum(:) + !< The checksums of the variable in a file + + call MOM_error(FATAL, 'get_field_atts over netCDF is not yet implemented.') +end subroutine get_field_atts_nc + + +!> Interface to read_field_chksum +subroutine read_field_chksum_nc(handle, field, chksum, valid_chksum) + class(MOM_netcdf_file), intent(in) :: handle + !< File where field is stored + type(MOM_field), intent(in) :: field + !< The field whose checksum attribute is to be read + integer(kind=int64), intent(out) :: chksum + !< The checksum for the field. + logical, intent(out) :: valid_chksum + !< If true, chksum has been successfully read + + call MOM_error(FATAL, 'read_field_chksum over netCDF is not yet implemented.') + chksum = -1_int64 + valid_chksum = .false. +end subroutine read_field_chksum_nc + + +!> Read the values of a netCDF field into an array that might have halos +subroutine get_field_nc(handle, label, values, rescale) + class(MOM_netcdf_file), intent(in) :: handle + !< Handle of netCDF file to be read + character(len=*), intent(in) :: label + !< Field variable name + real, intent(inout) :: values(:,:) + !< Field values read from the file. It would be intent(out) but for the + !! need to preserve any initialized values in the halo regions. + real, optional, intent(in) :: rescale + !< A multiplicative rescaling factor for the values that are read. + !! Omitting this is the same as setting it to 1. + + logical :: data_domain + ! True if values matches the data domain size + logical :: compute_domain + ! True if values matches the compute domain size + type(netcdf_field) :: field_nc + ! netCDF field associated with label + integer :: isc, iec, jsc, jec + ! Index bounds of compute domain + integer :: isd, ied, jsd, jed + ! Index bounds of data domain + integer :: iscl, iecl, jscl, jecl + ! Local 1-based index bounds of compute domain + integer :: bounds(2,2) + ! Index bounds of domain + real, allocatable :: values_c(:,:) + ! Field values on the compute domain, used for copying to a data domain + + isc = handle%HI%isc + iec = handle%HI%iec + jsc = handle%HI%jsc + jec = handle%HI%jec + + isd = handle%HI%isd + ied = handle%HI%ied + jsd = handle%HI%jsd + jed = handle%HI%jed + + data_domain = all(shape(values) == [ied-isd+1, jed-jsd+1]) + compute_domain = all(shape(values) == [iec-isc+1, jec-jsc+1]) + + ! NOTE: Data on face and vertex points is not yet supported. This is a + ! temporary check to detect such cases, but may be removed in the future. + if (.not. (compute_domain .or. data_domain)) & + call MOM_error(FATAL, 'get_field_nc trying to read '//trim(label)//' from '//& + trim(get_netcdf_filename(handle%handle_nc))//& + ': Only compute and data domains are currently supported.') + + field_nc = handle%fields%get(label) + + if (data_domain) & + allocate(values_c(1:iec-isc+1,1:jec-jsc+1)) + + if (handle%domain_decomposed) then + bounds(1,:) = [isc, jsc] + [handle%HI%idg_offset, handle%HI%jdg_offset] + bounds(2,:) = [iec, jec] + [handle%HI%idg_offset, handle%HI%jdg_offset] + if (data_domain) then + call read_netcdf_field(handle%handle_nc, field_nc, values_c, bounds=bounds) + else + call read_netcdf_field(handle%handle_nc, field_nc, values, bounds=bounds) + endif + else + if (data_domain) then + call read_netcdf_field(handle%handle_nc, field_nc, values_c) + else + call read_netcdf_field(handle%handle_nc, field_nc, values) + endif + endif + + if (data_domain) then + iscl = isc - isd + 1 + iecl = iec - isd + 1 + jscl = jsc - jsd + 1 + jecl = jec - jsd + 1 + + values(iscl:iecl,jscl:jecl) = values_c(:,:) + else + iscl = 1 + iecl = iec - isc + 1 + jscl = 1 + jecl = jec - jsc + 1 + endif + + ! NOTE: It is more efficient to do the rescale in-place while copying + ! values_c(:,:) to values(:,:). But since rescale is only present for + ! debugging, we can probably disregard this impact on performance. + if (present(rescale)) then + if (rescale /= 1.0) then + values(iscl:iecl,jscl:jecl) = rescale * values(iscl:iecl,jscl:jecl) + endif + endif +end subroutine get_field_nc + + +!> \namespace MOM_IO_file +!! +!! This file defines the MOM_file classes used to inferface with the internal +!! IO handlers, such as the configured "infra" layer (FMS) or native netCDF. +!! +!! `MOM_file`: The generic class used to reference any file type +!! Cannot be used in a variable declaration. +!! +!! `MOM_infra_file`: A file handler for use by the infra layer. Currently this +!! means an FMS file, such a restart or diagnostic output. +!! +!! `MOM_netcdf_file`: A netCDF file handler for MOM-specific I/O. This may +!! include operations outside the scope of FMS or other infra frameworks. + +end module MOM_io_file diff --git a/src/framework/MOM_memory_macros.h b/src/framework/MOM_memory_macros.h index 6ac3e7566b..4919fe4123 100644 --- a/src/framework/MOM_memory_macros.h +++ b/src/framework/MOM_memory_macros.h @@ -1,3 +1,7 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !//! \brief Memory macros !//! \details This is a header file to define macros for static and dynamic memory allocation. !//! Define STATIC_MEMORY_ in MOM_memory.h for static memory allocation. diff --git a/src/framework/MOM_murmur_hash.F90 b/src/framework/MOM_murmur_hash.F90 new file mode 100644 index 0000000000..1016fa0ee4 --- /dev/null +++ b/src/framework/MOM_murmur_hash.F90 @@ -0,0 +1,255 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> MurmurHash is a non-cryptographic hash function developed by Austin Appleby. +!! +!! This module provides an implementation of the 32-bit MurmurHash3 algorithm. +!! It is used in MOM6 to generate unique hashes of field arrays. The hash is +!! sensitive to order of elements and can detect changes that would otherwise +!! be missed by the mean/min/max/bitcount tests. +!! +!! Sensitivity to order means that it must be used with care for tests such as +!! processor layout. +!! +!! This implementation assumes data sizes of either 32 or 64 bits. It cannot +!! be used for smaller types such as strings. +!! +!! https://github.com/aappleby/smhasher +module MOM_murmur_hash + +use, intrinsic :: iso_fortran_env, only : int32, int64, real32, real64 + +implicit none ; private + +public :: murmur_hash + +!> Return the murmur3 hash of an array. +interface murmur_hash + procedure murmurhash3_i32 + procedure murmurhash3_i64 + procedure murmurhash3_r32 + procedure murmurhash3_r32_1d + procedure murmurhash3_r32_2d + procedure murmurhash3_r32_3d + procedure murmurhash3_r32_4d + procedure murmurhash3_r64 + procedure murmurhash3_r64_1d + procedure murmurhash3_r64_2d + procedure murmurhash3_r64_3d + procedure murmurhash3_r64_4d +end interface murmur_hash + +contains + +!> Return the murmur3 hash for a 32-bit integer array. +function murmurhash3_i32(key, seed) result(hash) + integer(int32), intent(in) :: key(:) + !< Input array + integer(int32), intent(in), optional :: seed + !< Hash seed + integer(int32) :: hash + !< Murmur hash of array + + integer(int32), parameter :: c1 = int(z'cc9e2d51', kind=int32) + integer(int32), parameter :: c2 = int(z'1b873593', kind=int32) + integer(int32), parameter :: c3 = int(z'e6546b64', kind=int32) + + integer(int32), parameter :: c4 = int(z'85ebca6b', kind=int32) + integer(int32), parameter :: c5 = int(z'c2b2ae35', kind=int32) + + integer :: i + integer(int32) :: k + + hash = 0 + if (present(seed)) hash = seed + + do i = 1, size(key) + k = key(i) + k = k * c1 + k = ishftc(k, 15) + k = k * c2 + + hash = ieor(hash, k) + hash = ishftc(hash, 13) + hash = 5 * hash + c3 + enddo + + ! NOTE: This is the point where the algorithm would handle trailing bytes. + ! Since our arrays are comprised of 4 or 8 byte elements, we skip this part. + + hash = ieor(hash, 4*size(key)) + + hash = ieor(hash, ishft(hash, -16)) + hash = hash * c4 + hash = ieor(hash, ishft(hash, -13)) + hash = hash * c5 + hash = ieor(hash, ishft(hash, -16)) +end function murmurhash3_i32 + + +!> Return the murmur3 hash for a 64-bit integer array. +function murmurhash3_i64(key, seed) result(hash) + integer(int64), intent(in) :: key(:) + !< Input array + integer(int32), intent(in), optional :: seed + !< Hash seed + integer(int32) :: hash + !< Murmur hash of array + + integer(int32) :: ikey(2*size(key)) + + hash = murmur_hash(transfer(key, ikey), seed=seed) +end function murmurhash3_i64 + + +!> Return the murmur3 hash for a 32-bit real array. +function murmurhash3_r32(key, seed) result(hash) + real(real32), intent(in) :: key + !< Input array [arbitrary] + integer(int32), intent(in), optional :: seed + !< Hash seed + integer(int32) :: hash + !< Murmur hash of array + + integer(int32) :: ikey(1) + + hash = murmur_hash(transfer(key, ikey), seed=seed) +end function murmurhash3_r32 + + +!> Return the murmur3 hash for a 32-bit real array. +function murmurhash3_r32_1d(key, seed) result(hash) + real(real32), intent(in) :: key(:) + !< Input array [arbitrary] + integer(int32), intent(in), optional :: seed + !< Hash seed + integer(int32) :: hash + !< Murmur hash of array + + integer(int32) :: ikey(size(key)) + + hash = murmur_hash(transfer(key, ikey), seed=seed) +end function murmurhash3_r32_1d + + +!> Return the murmur3 hash for a 32-bit real 2D array. +function murmurhash3_r32_2d(key, seed) result(hash) + real(real32), intent(in) :: key(:,:) + !< Input array [arbitrary] + integer(int32), intent(in), optional :: seed + !< Hash seed + integer(int32) :: hash + !< Murmur hash of array + + integer(int32) :: ikey(size(key)) + + hash = murmur_hash(transfer(key, ikey), seed=seed) +end function murmurhash3_r32_2d + + +!> Return the murmur3 hash for a 32-bit real 3D array. +function murmurhash3_r32_3d(key, seed) result(hash) + real(real32), intent(in) :: key(:,:,:) + !< Input array [arbitrary] + integer(int32), intent(in), optional :: seed + !< Hash seed + integer(int32) :: hash + !< Murmur hash of array + + integer(int32) :: ikey(size(key)) + + hash = murmur_hash(transfer(key, ikey), seed=seed) +end function murmurhash3_r32_3d + + +!> Return the murmur3 hash for a 32-bit real 4D array. +function murmurhash3_r32_4d(key, seed) result(hash) + real(real32), intent(in) :: key(:,:,:,:) + !< Input array [arbitrary] + integer(int32), intent(in), optional :: seed + !< Hash seed + integer(int32) :: hash + !< Murmur hash of array + + integer(int32) :: ikey(size(key)) + + hash = murmur_hash(transfer(key, ikey), seed=seed) +end function murmurhash3_r32_4d + + +!> Return the murmur3 hash for a 64-bit real array. +function murmurhash3_r64(key, seed) result(hash) + real(real64), intent(in) :: key + !< Input array [arbitrary] + integer(int32), intent(in), optional :: seed + !< Hash seed + integer(int32) :: hash + !< Murmur hash of array + + integer(int32) :: ikey(2) + + hash = murmur_hash(transfer(key, ikey), seed=seed) +end function murmurhash3_r64 + + +!> Return the murmur3 hash for a 64-bit real array. +function murmurhash3_r64_1d(key, seed) result(hash) + real(real64), intent(in) :: key(:) + !< Input array [arbitrary] + integer(int32), intent(in), optional :: seed + !< Hash seed + integer(int32) :: hash + !< Murmur hash of array + + integer(int32) :: ikey(2*size(key)) + + hash = murmur_hash(transfer(key, ikey), seed=seed) +end function murmurhash3_r64_1d + + +!> Return the murmur3 hash for a 64-bit real 2D array. +function murmurhash3_r64_2d(key, seed) result(hash) + real(real64), intent(in) :: key(:,:) + !< Input array [arbitrary] + integer(int32), intent(in), optional :: seed + !< Hash seed + integer(int32) :: hash + !< Murmur hash of array + + integer(int32) :: ikey(2*size(key)) + + hash = murmur_hash(transfer(key, ikey), seed=seed) +end function murmurhash3_r64_2d + + +!> Return the murmur3 hash for a 64-bit real 3D array. +function murmurhash3_r64_3d(key, seed) result(hash) + real(real64), intent(in) :: key(:,:,:) + !< Input array [arbitrary] + integer(int32), intent(in), optional :: seed + !< Hash seed + integer(int32) :: hash + !< Murmur hash of array + + integer(int32) :: ikey(2*size(key)) + + hash = murmur_hash(transfer(key, ikey), seed=seed) +end function murmurhash3_r64_3d + + +!> Return the murmur3 hash for a 64-bit real 4D array. +function murmurhash3_r64_4d(key, seed) result(hash) + real(real64), intent(in) :: key(:,:,:,:) + !< Input array [arbitrary] + integer(int32), intent(in), optional :: seed + !< Hash seed + integer(int32) :: hash + !< Murmur hash of array + + integer(int32) :: ikey(2*size(key)) + + hash = murmur_hash(transfer(key, ikey), seed=seed) +end function murmurhash3_r64_4d + +end module MOM_murmur_hash diff --git a/src/framework/MOM_netcdf.F90 b/src/framework/MOM_netcdf.F90 new file mode 100644 index 0000000000..a3cfcad113 --- /dev/null +++ b/src/framework/MOM_netcdf.F90 @@ -0,0 +1,811 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> MOM6 interface to netCDF operations +module MOM_netcdf + +use, intrinsic :: iso_fortran_env, only : real32, real64 + +use netcdf, only : nf90_create, nf90_open, nf90_close +use netcdf, only : nf90_sync +use netcdf, only : NF90_CLOBBER, NF90_NOCLOBBER, NF90_WRITE, NF90_NOWRITE +use netcdf, only : nf90_enddef +use netcdf, only : nf90_def_dim, nf90_def_var +use netcdf, only : NF90_UNLIMITED +use netcdf, only : nf90_get_var +use netcdf, only : nf90_put_var, nf90_put_att +use netcdf, only : NF90_FLOAT, NF90_DOUBLE +use netcdf, only : nf90_strerror, NF90_NOERR +use netcdf, only : NF90_GLOBAL +use netcdf, only : nf90_inquire, nf90_inquire_dimension, nf90_inquire_variable +use netcdf, only : nf90_inq_dimids, nf90_inq_varids +use netcdf, only : NF90_MAX_NAME + +use MOM_error_handler, only : MOM_error, FATAL +use MOM_io_infra, only : READONLY_FILE, WRITEONLY_FILE +use MOM_io_infra, only : APPEND_FILE, OVERWRITE_FILE + +implicit none ; private + +public :: netcdf_file_type +public :: netcdf_axis +public :: netcdf_field +public :: open_netcdf_file +public :: close_netcdf_file +public :: flush_netcdf_file +public :: register_netcdf_axis +public :: register_netcdf_field +public :: write_netcdf_field +public :: write_netcdf_axis +public :: write_netcdf_attribute +public :: get_netcdf_size +public :: get_netcdf_fields +public :: get_netcdf_filename +public :: read_netcdf_field + + +!> Internal time value used to indicate an uninitialized time +real, parameter :: NULLTIME = -1 +! NOTE: For now, we use the FMS-compatible value, but may change in the future. + + +!> netCDF file abstraction +type :: netcdf_file_type + private + integer :: ncid + !< netCDF file ID + character(len=:), allocatable :: filename + !< netCDF filename + logical :: define_mode + !< True if file is in define mode. + integer :: time_id + !< Time axis variable ID + real :: time + !< Current model time + integer :: time_level + !< Current time level for output +end type netcdf_file_type + + +!> Dimension axis for a netCDF file +type :: netcdf_axis + private + character(len=:), allocatable, public :: label + !< Axis label name + real, allocatable :: points(:) + !< Grid points along the axis + integer :: dimid + !< netCDF dimension ID associated with axis + integer :: varid + !< netCDF variable ID associated with axis +end type netcdf_axis + + +!> Field variable for a netCDF file +type netcdf_field + private + character(len=:), allocatable, public :: label + !< Variable name + integer :: varid + !< netCDF variable ID for field +end type netcdf_field + + +!> Write values to a field of a netCDF file +interface write_netcdf_field + module procedure write_netcdf_field_4d + module procedure write_netcdf_field_3d + module procedure write_netcdf_field_2d + module procedure write_netcdf_field_1d + module procedure write_netcdf_field_0d +end interface write_netcdf_field + +contains + +subroutine open_netcdf_file(handle, filename, mode) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + character(len=*), intent(in) :: filename + !< netCDF filename + integer, intent(in), optional :: mode + !< Input MOM I/O mode + + integer :: io_mode + ! MOM I/O mode + integer :: cmode + ! netCDF creation mode + integer :: rc + ! nf90_create return code + character(len=:), allocatable :: msg + ! netCDF error message buffer + + ! I/O configuration + io_mode = WRITEONLY_FILE + if (present(mode)) io_mode = mode + + ! Translate the MOM I/O config to the netCDF mode + select case(io_mode) + case (WRITEONLY_FILE) + rc = nf90_create(filename, nf90_noclobber, handle%ncid) + handle%define_mode = .true. + case (OVERWRITE_FILE) + rc = nf90_create(filename, nf90_clobber, handle%ncid) + handle%define_mode = .true. + case (APPEND_FILE) + rc = nf90_open(filename, nf90_write, handle%ncid) + handle%define_mode = .false. + case (READONLY_FILE) + rc = nf90_open(filename, nf90_nowrite, handle%ncid) + handle%define_mode = .false. + case default + call MOM_error(FATAL, & + 'open_netcdf_file: File ' // filename // ': Unknown mode.') + end select + call check_netcdf_call(rc, 'open_netcdf_file', 'File ' // filename) + + handle%filename = filename + + ! FMS writes the filename as an attribute + if (any(io_mode == [WRITEONLY_FILE, OVERWRITE_FILE])) & + call write_netcdf_attribute(handle, 'filename', filename) +end subroutine open_netcdf_file + + +!> Close an opened netCDF file. +subroutine close_netcdf_file(handle) + type(netcdf_file_type), intent(in) :: handle + + integer :: rc + + rc = nf90_close(handle%ncid) + call check_netcdf_call(rc, 'close_netcdf_file', & + 'File "' // handle%filename // '"') +end subroutine close_netcdf_file + + +!> Flush buffered output to the netCDF file +subroutine flush_netcdf_file(handle) + type(netcdf_file_type), intent(in) :: handle + + integer :: rc + + rc = nf90_sync(handle%ncid) + call check_netcdf_call(rc, 'flush_netcdf_file', & + 'File "' // handle%filename // '"') +end subroutine flush_netcdf_file + + +!> Change netCDF mode of handle from 'define' to 'write'. +subroutine enable_netcdf_write(handle) + type(netcdf_file_type), intent(inout) :: handle + + integer :: rc + + if (handle%define_mode) then + rc = nf90_enddef(handle%ncid) + call check_netcdf_call(rc, 'enable_netcdf_write', & + 'File "' // handle%filename // '"') + handle%define_mode = .false. + endif +end subroutine enable_netcdf_write + + +!> Register a netCDF variable +function register_netcdf_field(handle, label, axes, longname, units) & + result(field) + type(netcdf_file_type), intent(in) :: handle + !< netCDF file handle + character(len=*), intent(in) :: label + !< netCDF field name in the file + type(netcdf_axis), intent(in) :: axes(:) + !< Axes along which field is defined + character(len=*), intent(in) :: longname + !< Long name of the netCDF field + character(len=*), intent(in) :: units + !< Field units of measurement + type(netcdf_field) :: field + !< netCDF field + + integer :: rc + ! netCDF function return code + integer :: i + ! Loop index + integer, allocatable :: dimids(:) + ! netCDF dimension IDs of axes + integer :: xtype + ! netCDF data type + + ! Gather the axis netCDF dimension IDs + allocate(dimids(size(axes))) + dimids(:) = [(axes(i)%dimid, i = 1, size(axes))] + + field%label = label + + ! Determine the corresponding netCDF data type + ! TODO: Support a `pack`-like argument + select case (kind(1.0)) + case (real32) + xtype = NF90_FLOAT + case (real64) + xtype = NF90_DOUBLE + case default + call MOM_error(FATAL, "register_netcdf_field: Unknown kind(real).") + end select + + ! Register the field variable + rc = nf90_def_var(handle%ncid, label, xtype, dimids, field%varid) + call check_netcdf_call(rc, 'register_netcdf_field', & + 'File "' // handle%filename // '", Field "' // label // '"') + + ! Assign attributes + + rc = nf90_put_att(handle%ncid, field%varid, 'long_name', longname) + call check_netcdf_call(rc, 'register_netcdf_field', & + 'Attribute "long_name" of variable "' // label // '" in file "' & + // handle%filename // '"') + + rc = nf90_put_att(handle%ncid, field%varid, 'units', units) + call check_netcdf_call(rc, 'register_netcdf_field', & + 'Attribute "units" of variable "' // label // '" in file "' & + // handle%filename // '"') +end function register_netcdf_field + + +!> Create an axis and associated dimension in a netCDF file +function register_netcdf_axis(handle, label, units, longname, points, & + cartesian, sense) result(axis) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + character(len=*), intent(in) :: label + !< netCDF axis name in the file + character(len=*), intent(in), optional :: units + !< Axis units of measurement + character(len=*), intent(in), optional :: longname + !< Long name of the axis + real, intent(in), optional :: points(:) + !< Values of axis points (for fixed axes) + character(len=*), intent(in), optional :: cartesian + !< Character denoting axis direction: X, Y, Z, T, or N for none + integer, intent(in), optional :: sense + !< Axis direction; +1 if axis increases upward or -1 if downward + + type(netcdf_axis) :: axis + !< netCDF coordinate axis + + integer :: xtype + ! netCDF external data type + integer :: rc + ! netCDF function return code + logical :: unlimited + ! True if the axis is unlimited in size (e.g. time) + integer :: axis_size + ! Either the number of points in the axis, or unlimited flag + integer :: axis_sense + ! Axis direction; +1 if axis increases upward or -1 if downward + character(len=:), allocatable :: sense_attr + ! CF-compiant value of sense attribute (as 'positive') + + ! Create the axis dimension + unlimited = .false. + if (present(cartesian)) then + if (cartesian == 'T') unlimited = .true. + endif + + ! Either the axis is explicitly set with data or is declared as unlimited + if (present(points) .eqv. unlimited) then + call MOM_error(FATAL, & + "Axis must either have explicit points or be a time axis ('T').") + endif + + axis%label = label + + if (present(points)) then + axis_size = size(points) + allocate(axis%points(axis_size)) + axis%points(:) = points(:) + else + axis_size = NF90_UNLIMITED + endif + + rc = nf90_def_dim(handle%ncid, label, axis_size, axis%dimid) + call check_netcdf_call(rc, 'register_netcdf_axis', & + 'Dimension "' // label // '" in file "' // handle%filename // '"') + + ! Determine the corresponding netCDF data type + ! TODO: Support a `pack`-like argument + select case (kind(1.0)) + case (real32) + xtype = NF90_FLOAT + case (real64) + xtype = NF90_DOUBLE + case default + call MOM_error(FATAL, "register_netcdf_axis: Unknown kind(real).") + end select + + ! Create a variable corresponding to the axis + rc = nf90_def_var(handle%ncid, label, xtype, axis%dimid, axis%varid) + call check_netcdf_call(rc, 'register_netcdf_axis', & + 'Variable ' // label // ' in file ' // handle%filename) + + ! Define the time axis, if available + if (unlimited) then + handle%time_id = axis%varid + handle%time_level = 0 + handle%time = NULLTIME + endif + + ! Assign attributes if present + if (present(longname)) then + rc = nf90_put_att(handle%ncid, axis%varid, 'long_name', longname) + call check_netcdf_call(rc, 'register_netcdf_axis', & + 'Attribute ''long_name'' of variable ' // label // ' in file ' & + // handle%filename) + endif + + if (present(units)) then + rc = nf90_put_att(handle%ncid, axis%varid, 'units', units) + call check_netcdf_call(rc, 'register_netcdf_axis', & + 'Attribute ''units'' of variable ' // label // ' in file ' & + // handle%filename) + endif + + if (present(cartesian)) then + rc = nf90_put_att(handle%ncid, axis%varid, 'cartesian_axis', cartesian) + call check_netcdf_call(rc, 'register_netcdf_axis', & + 'Attribute ''cartesian_axis'' of variable ' // label // ' in file ' & + // handle%filename) + endif + + axis_sense = 0 + if (present(sense)) axis_sense = sense + + if (axis_sense /= 0) then + select case (axis_sense) + case (1) + sense_attr = 'up' + case (-1) + sense_attr = 'down' + case default + call MOM_error(FATAL, 'register_netcdf_axis: sense must be either ' & + // '0, 1, or -1.') + end select + rc = nf90_put_att(handle%ncid, axis%varid, 'positive', sense_attr) + call check_netcdf_call(rc, 'register_netcdf_axis', & + 'Attribute "positive" of variable "' // label // '" in file "' & + // handle%filename // '"') + endif +end function register_netcdf_axis + + +!> Write a 4D array to a compatible netCDF field +subroutine write_netcdf_field_4d(handle, field, values, time) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + type(netcdf_field), intent(in) :: field + !< Field metadata + real, intent(in) :: values(:,:,:,:) + !< Field values + real, intent(in), optional :: time + !< Timestep index to write data + + integer :: rc + ! netCDF return code + integer :: start(5) + ! Start indices, if timestep is included + + ! Verify write mode + if (handle%define_mode) & + call enable_netcdf_write(handle) + + if (present(time)) then + call update_netcdf_timestep(handle, time) + start(:4) = 1 + start(5) = handle%time_level + rc = nf90_put_var(handle%ncid, field%varid, values, start) + else + rc = nf90_put_var(handle%ncid, field%varid, values) + endif + call check_netcdf_call(rc, 'write_netcdf_file', & + 'File "' // handle%filename // '", Field "' // field%label // '"') +end subroutine write_netcdf_field_4d + + +!> Write a 3D array to a compatible netCDF field +subroutine write_netcdf_field_3d(handle, field, values, time) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + type(netcdf_field), intent(in) :: field + !< Field metadata + real, intent(in) :: values(:,:,:) + !< Field values + real, intent(in), optional :: time + !< Timestep index to write data + + integer :: rc + ! netCDF return code + integer :: start(4) + ! Start indices, if timestep is included + + ! Verify write mode + if (handle%define_mode) & + call enable_netcdf_write(handle) + + if (present(time)) then + call update_netcdf_timestep(handle, time) + start(:3) = 1 + start(4) = handle%time_level + rc = nf90_put_var(handle%ncid, field%varid, values, start) + else + rc = nf90_put_var(handle%ncid, field%varid, values) + endif + call check_netcdf_call(rc, 'write_netcdf_file', & + 'File "' // handle%filename // '", Field "' // field%label // '"') +end subroutine write_netcdf_field_3d + + +!> Write a 2D array to a compatible netCDF field +subroutine write_netcdf_field_2d(handle, field, values, time) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + type(netcdf_field), intent(in) :: field + !< Field metadata + real, intent(in) :: values(:,:) + !< Field values + real, intent(in), optional :: time + !< Timestep index to write data + + integer :: rc + ! netCDF return code + integer :: start(3) + ! Start indices, if timestep is included + + ! Verify write mode + if (handle%define_mode) & + call enable_netcdf_write(handle) + + if (present(time)) then + call update_netcdf_timestep(handle, time) + start(:2) = 1 + start(3) = handle%time_level + rc = nf90_put_var(handle%ncid, field%varid, values, start) + else + rc = nf90_put_var(handle%ncid, field%varid, values) + endif + call check_netcdf_call(rc, 'write_netcdf_file', & + 'File "' // handle%filename // '", Field "' // field%label // '"') +end subroutine write_netcdf_field_2d + + +!> Write a 1D array to a compatible netCDF field +subroutine write_netcdf_field_1d(handle, field, values, time) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + type(netcdf_field), intent(in) :: field + !< Field metadata + real, intent(in) :: values(:) + !< Field values + real, intent(in), optional :: time + !< Timestep index to write data + + integer :: rc + ! netCDF return code + integer :: start(2) + ! Start indices, if timestep is included + + ! Verify write mode + if (handle%define_mode) & + call enable_netcdf_write(handle) + + if (present(time)) then + call update_netcdf_timestep(handle, time) + start(1) = 1 + start(2) = handle%time_level + rc = nf90_put_var(handle%ncid, field%varid, values, start) + else + rc = nf90_put_var(handle%ncid, field%varid, values) + endif + call check_netcdf_call(rc, 'write_netcdf_file', & + 'File "' // handle%filename // '", Field "' // field%label // '"') +end subroutine write_netcdf_field_1d + + +!> Write a scalar to a compatible netCDF field +subroutine write_netcdf_field_0d(handle, field, scalar, time) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + type(netcdf_field), intent(in) :: field + !< Field metadata + real, intent(in) :: scalar + !< Field values + real, intent(in), optional :: time + !< Timestep index to write data + + integer :: rc + ! netCDF return code + integer :: start(1) + ! Start indices, if timestep is included + + ! Verify write mode + if (handle%define_mode) & + call enable_netcdf_write(handle) + + if (present(time)) then + call update_netcdf_timestep(handle, time) + start(1) = handle%time_level + rc = nf90_put_var(handle%ncid, field%varid, scalar, start) + else + rc = nf90_put_var(handle%ncid, field%varid, scalar) + endif + call check_netcdf_call(rc, 'write_netcdf_file', & + 'File "' // handle%filename // '", Field "' // field%label // '"') +end subroutine write_netcdf_field_0d + + +!> Write axis points to associated netCDF variable +subroutine write_netcdf_axis(handle, axis) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + type(netcdf_axis), intent(in) :: axis + !< field variable + + integer :: rc + ! netCDF return code + + ! Verify write mode + if (handle%define_mode) & + call enable_netcdf_write(handle) + + rc = nf90_put_var(handle%ncid, axis%varid, axis%points) + call check_netcdf_call(rc, 'write_netcdf_axis', & + 'File "' // handle%filename // '", Axis "' // axis%label // '"') +end subroutine write_netcdf_axis + + +!> Write a global attribute to a netCDF file +subroutine write_netcdf_attribute(handle, label, attribute) + type(netcdf_file_type), intent(in) :: handle + !< netCDF file handle + character(len=*), intent(in) :: label + !< File attribute + character(len=*), intent(in) :: attribute + !< File attribute value + + integer :: rc + ! netCDF return code + + rc = nf90_put_att(handle%ncid, NF90_GLOBAL, label, attribute) + call check_netcdf_call(rc, 'write_netcdf_attribute', & + 'File "' // handle%filename // '", Attribute "' // label // '"') +end subroutine write_netcdf_attribute + + +! This is a thin interface to nf90_inquire, designed to mirror the existing +! I/O API. A more axis-aware system might not need this, but for now it's here +!> Get the number of dimensions, variables, and timesteps in a netCDF file +subroutine get_netcdf_size(handle, ndims, nvars, nsteps) + type(netcdf_file_type), intent(in) :: handle + !< netCDF input file + integer, intent(out), optional :: ndims + !< number of dimensions in the file + integer, intent(out), optional :: nvars + !< number of variables in the file + integer, intent(out), optional :: nsteps + !< number of values in the file's unlimited axis + + integer :: rc + ! netCDF return code + integer :: unlimited_dimid + ! netCDF dimension ID for unlimited time axis + + rc = nf90_inquire(handle%ncid, & + nDimensions=ndims, & + nVariables=nvars, & + unlimitedDimId=unlimited_dimid & + ) + call check_netcdf_call(rc, 'get_netcdf_size', & + 'File "' // handle%filename // '"') + + rc = nf90_inquire_dimension(handle%ncid, unlimited_dimid, len=nsteps) + call check_netcdf_call(rc, 'get_netcdf_size', & + 'File "' // handle%filename // '"') +end subroutine get_netcdf_size + + +!> Get the metadata of the registered fields in a netCDF file +subroutine get_netcdf_fields(handle, axes, fields) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + type(netcdf_axis), intent(inout), allocatable :: axes(:) + !< netCDF file axes + type(netcdf_field), intent(inout), allocatable :: fields(:) + !< netCDF file fields + + integer :: ndims + ! Number of netCDF dimensions + integer :: nvars + ! Number of netCDF dimensions + type(netcdf_field), allocatable :: vars(:) + ! netCDF variables in handle + integer :: nfields + ! Number of fields in the file (i.e. non-axis variables) + integer, allocatable :: dimids(:) + ! netCDF dimension IDs of file + integer, allocatable :: varids(:) + ! netCDF variable IDs of file + integer :: unlim_dimid + ! netCDF dimension ID for the unlimited axis variable, if present + integer :: unlim_index + ! Index of the unlimited axis in axes(:), if present + character(len=NF90_MAX_NAME) :: label + ! Current dimension or variable label + integer :: len + ! Current dimension length + integer :: rc + ! netCDF return code + integer :: grp_ndims, grp_nvars + ! Group-based counts for nf90_inq_* (unused) + logical :: is_axis + ! True if the current variable is an axis + integer :: i, j, n + + integer, save :: no_parent_groups = 0 + ! Flag indicating exclusion of parent groups in netCDF file + ! NOTE: This must be passed as a variable, and cannot be declared as a + ! parameter. + + rc = nf90_inquire(handle%ncid, & + nDimensions=ndims, & + nVariables=nvars, & + unlimitedDimId=unlim_dimid & + ) + call check_netcdf_call(rc, 'get_netcdf_fields', & + 'File "' // handle%filename // '"') + + allocate(dimids(ndims)) + rc = nf90_inq_dimids(handle%ncid, grp_ndims, dimids, no_parent_groups) + call check_netcdf_call(rc, 'get_netcdf_fields', & + 'File "' // handle%filename // '"') + + allocate(varids(nvars)) + rc = nf90_inq_varids(handle%ncid, grp_nvars, varids) + call check_netcdf_call(rc, 'get_netcdf_fields', & + 'File "' // trim(handle%filename) // '"') + + ! Initialize unlim_index with an unreachable value (outside [1,ndims]) + unlim_index = -1 + + allocate(axes(ndims)) + do i = 1, ndims + rc = nf90_inquire_dimension(handle%ncid, dimids(i), name=label, len=len) + call check_netcdf_call(rc, 'get_netcdf_fields', & + 'File "' // trim(handle%filename) // '"') + + ! Check for the unlimited axis + if (dimids(i) == unlim_dimid) unlim_index = i + + axes(i)%dimid = dimids(i) + axes(i)%label = trim(label) + allocate(axes(i)%points(len)) + enddo + + ! We cannot know if every axis also has a variable representation, so we + ! over-allocate vars(:) and fill as fields are identified. + allocate(vars(nvars)) + + nfields = 0 + do i = 1, nvars + rc = nf90_inquire_variable(handle%ncid, varids(i), name=label) + call check_netcdf_call(rc, 'get_netcdf_fields', & + 'File "' // trim(handle%filename) // '"') + + ! Check if variable is an axis + is_axis = .false. + do j = 1, ndims + if (label == axes(j)%label) then + rc = nf90_get_var(handle%ncid, varids(i), axes(j)%points) + call check_netcdf_call(rc, 'get_netcdf_fields', & + 'File "' // trim(handle%filename) // '"') + axes(j)%varid = varids(i) + + if (j == unlim_index) then + handle%time_id = varids(i) + handle%time_level = size(axes(j)%points) + handle%time = NULLTIME + endif + + is_axis = .true. + exit + endif + enddo + if (is_axis) cycle + + nfields = nfields + 1 + vars(nfields)%label = trim(label) + vars(nfields)%varid = varids(i) + enddo + + allocate(fields(nfields)) + fields(:) = vars(:nfields) +end subroutine get_netcdf_fields + +!> Return the name of a file from a netCDF handle +function get_netcdf_filename(handle) + type(netcdf_file_type), intent(in) :: handle !< A netCDF file handle + character(len=:), allocatable :: get_netcdf_filename !< The name of the file that this handle refers to. + + get_netcdf_filename = handle%filename + +end function + +!> Read the values of a field from a netCDF file +subroutine read_netcdf_field(handle, field, values, bounds) + type(netcdf_file_type), intent(in) :: handle + type(netcdf_field), intent(in) :: field + real, intent(out) :: values(:,:) + integer, optional, intent(in) :: bounds(2,2) + + integer :: rc + ! netCDF return code + integer :: istart(2) + ! Axis start index + integer :: icount(2) + ! Axis index count + + if (present(bounds)) then + istart(:) = bounds(1,:) + icount(:) = bounds(2,:) - bounds(1,:) + 1 + rc = nf90_get_var(handle%ncid, field%varid, values, start=istart, count=icount) + else + rc = nf90_get_var(handle%ncid, field%varid, values) + endif + call check_netcdf_call(rc, 'read_netcdf_field', & + 'File "' // trim(handle%filename) // '", Field "' // trim(field%label) // '"') +end subroutine read_netcdf_field + + +!> Set the current timestep of an open netCDF file +subroutine update_netcdf_timestep(handle, time) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + real, intent(in) :: time + !< New model time + + integer :: start(1) + !< Time axis start index array + integer :: rc + !< netCDF return code + + if (time > handle%time + epsilon(time)) then + handle%time = time + handle%time_level = handle%time_level + 1 + + ! Write new value to time axis + start = [handle%time_level] + rc = nf90_put_var(handle%ncid, handle%time_id, time, start=start) + call check_netcdf_call(rc, 'update_netcdf_timestep', & + 'File "' // handle%filename // '"') + endif +end subroutine update_netcdf_timestep + + +!> Check netCDF function return codes, report the error log, and abort the run. +subroutine check_netcdf_call(ncerr, header, message) + integer, intent(in) :: ncerr + !< netCDF error code + character(len=*), intent(in) :: header + !< Message header (usually calling subroutine) + character(len=*), intent(in) :: message + !< Error message (usually action which instigated the error) + + character(len=:), allocatable :: errmsg + ! Full error message, including netCDF message + + if (ncerr /= NF90_NOERR) then + errmsg = trim(header) // ": " // trim(message) // new_line('/') & + // trim(nf90_strerror(ncerr)) + call MOM_error(FATAL, errmsg) + endif +end subroutine check_netcdf_call + +end module MOM_netcdf diff --git a/src/framework/MOM_random.F90 b/src/framework/MOM_random.F90 index 709fd27731..9cd774cf88 100644 --- a/src/framework/MOM_random.F90 +++ b/src/framework/MOM_random.F90 @@ -1,12 +1,15 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Provides gridded random number capability module MOM_random -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_hor_index, only : hor_index_type use MOM_time_manager, only : time_type, set_date, get_date use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit +use iso_fortran_env, only : int32 implicit none ; private @@ -20,11 +23,13 @@ module MOM_random public :: random_unit_tests ! Private period parameters for the Mersenne Twister -integer, parameter :: blockSize = 624, & !< Size of the state vector - M = 397, & !< Pivot element in state vector - MATRIX_A = -1727483681, & !< constant vector a (0x9908b0dfUL) - UMASK = -2147483648_8, & !< most significant w-r bits (0x80000000UL) - LMASK = 2147483647 !< least significant r bits (0x7fffffffUL) +integer, parameter :: & + blockSize = 624, & !< Size of the state vector + M = 397, & !< Pivot element in state vector + MATRIX_A = -1727483681, & !< constant vector a (0x9908b0dfUL) + UMASK = ibset(0, 31), & !< most significant w-r bits (0x80000000UL) + LMASK = 2147483647 !< least significant r bits (0x7fffffffUL) + ! Private tempering parameters for the Mersenne Twister integer, parameter :: TMASKB= -1658038656, & !< (0x9d2c5680UL) TMASKC= -272236544 !< (0xefc60000UL) @@ -96,7 +101,7 @@ end function random_norm subroutine random_2d_01(CS, HI, rand) type(PRNG), intent(inout) :: CS !< Container for pseudo-random number generators type(hor_index_type), intent(in) :: HI !< Horizontal index structure - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), intent(out) :: rand !< Random numbers between 0 and 1 + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), intent(out) :: rand !< Random numbers between 0 and 1 [nondim] ! Local variables integer :: i,j @@ -113,7 +118,7 @@ end subroutine random_2d_01 subroutine random_2d_norm(CS, HI, rand) type(PRNG), intent(inout) :: CS !< Container for pseudo-random number generators type(hor_index_type), intent(in) :: HI !< Horizontal index structure - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), intent(out) :: rand !< Random numbers between 0 and 1 + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), intent(out) :: rand !< Random numbers between 0 and 1 [nondim] ! Local variables integer :: i,j,n @@ -156,6 +161,7 @@ subroutine random_2d_constructor(CS, HI, Time, seed) if (.not. allocated(CS%stream2d)) allocate( CS%stream2d(HI%isd:HI%ied,HI%jsd:HI%jed) ) tseed = seed_from_time(Time) + tseed = ieor(tseed*9007, seed) do j = HI%jsd,HI%jed do i = HI%isd,HI%ied @@ -189,7 +195,7 @@ integer function seed_from_index(HI, i, j) integer, intent(in) :: i !< i-index (of h-cell) integer, intent(in) :: j !< j-index (of h-cell) ! Local variables - integer :: ig, jg, ni, nj, ij + integer :: ig, jg, ni, nj ni = HI%niglobal nj = HI%njglobal @@ -223,10 +229,10 @@ function new_RandomNumberSequence(seed) result(twister) twister%state(0) = iand(seed, -1) do i = 1, blockSize - 1 ! ubound(twister%state) - twister%state(i) = 1812433253 * ieor(twister%state(i-1), & - ishft(twister%state(i-1), -30)) + i - twister%state(i) = iand(twister%state(i), -1) ! for >32 bit machines - end do + twister%state(i) = 1812433253 * ieor(twister%state(i-1), & + ishft(twister%state(i-1), -30)) + i + twister%state(i) = iand(twister%state(i), -1) ! for >32 bit machines + enddo twister%currentElement = blockSize end function new_RandomNumberSequence @@ -236,7 +242,7 @@ end function new_RandomNumberSequence integer function getRandomInt(twister) type(randomNumberSequence), intent(inout) :: twister !< The Mersenne Twister container - if(twister%currentElement >= blockSize) call nextState(twister) + if (twister%currentElement >= blockSize) call nextState(twister) getRandomInt = temper(twister%state(twister%currentElement)) twister%currentElement = twister%currentElement + 1 @@ -251,11 +257,11 @@ double precision function getRandomReal(twister) integer :: localInt localInt = getRandomInt(twister) - if(localInt < 0) then + if (localInt < 0) then getRandomReal = dble(localInt + 2.0d0**32)/(2.0d0**32 - 1.0d0) else getRandomReal = dble(localInt )/(2.0d0**32 - 1.0d0) - end if + endif end function getRandomReal !> Merge bits of u and v @@ -286,11 +292,11 @@ subroutine nextState(twister) do k = 0, blockSize - M - 1 twister%state(k) = ieor(twister%state(k + M), & twist(twister%state(k), twister%state(k + 1))) - end do + enddo do k = blockSize - M, blockSize - 2 twister%state(k) = ieor(twister%state(k + M - blockSize), & twist(twister%state(k), twister%state(k + 1))) - end do + enddo twister%state(blockSize - 1) = ieor(twister%state(M - 1), & twist(twister%state(blockSize - 1), twister%state(0))) twister%currentElement = 0 @@ -314,14 +320,14 @@ logical function random_unit_tests(verbose) ! Local variables type(PRNG) :: test_rng ! Generator type(time_type) :: Time ! Model time - real :: r1, r2, r3 ! Some random numbers and re-used work variables - real :: mean, var, ar1, std ! Some statistics + real :: r1, r2, r3 ! Some random numbers and re-used work variables [nondim] + real :: mean, var, ar1, std ! Some statistics [nondim] integer :: stdunit ! For messages integer, parameter :: n_samples = 800 integer :: i, j, ni, nj ! Fake being on a decomposed domain type(hor_index_type), pointer :: HI => null() !< Not the real HI - real, dimension(:,:), allocatable :: r2d ! Random numbers + real, dimension(:,:), allocatable :: r2d ! Random numbers [nondim] ! Fake a decomposed domain ni = 6 @@ -543,7 +549,7 @@ logical function test_fn(verbose, good, label, rvalue, ivalue) logical, intent(in) :: verbose !< Verbosity logical, intent(in) :: good !< True if pass, false otherwise character(len=*), intent(in) :: label !< Label for messages - real, intent(in) :: rvalue !< Result of calculation + real, intent(in) :: rvalue !< Result of calculation [nondim] integer, intent(in) :: ivalue !< Result of calculation optional :: rvalue, ivalue diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 1328fd676c..ef4adb193a 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -1,19 +1,24 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> The MOM6 facility for reading and writing restart files, and querying what has been read. module MOM_restart -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_checksums, only : chksum => rotated_field_chksum -use MOM_domains, only : PE_here, num_PEs -use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE, is_root_pe +use, intrinsic :: iso_fortran_env, only : int64 +use MOM_array_transform, only : rotate_array, rotate_vector, rotate_array_pair +use MOM_checksums, only : chksum => field_checksum +use MOM_domains, only : PE_here, num_PEs, AGRID, BGRID_NE, CGRID_NE +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, NOTE, is_root_pe, MOM_get_verbosity use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_io, only : create_file, file_type, fieldtype, file_exists, open_file, close_file -use MOM_io, only : MOM_read_data, read_data, MOM_write_field, read_field_chksum -use MOM_io, only : get_file_info, get_file_fields, get_field_atts, get_file_times +use MOM_io, only : create_MOM_file, file_exists +use MOM_io, only : MOM_infra_file, MOM_field +use MOM_io, only : MOM_read_data, read_data, MOM_write_field, field_exists use MOM_io, only : vardesc, var_desc, query_vardesc, modify_vardesc, get_filename_appendix use MOM_io, only : MULTIPLE, READONLY_FILE, SINGLE_FILE use MOM_io, only : CENTER, CORNER, NORTH_FACE, EAST_FACE +use MOM_io, only : axis_info, get_axis_info use MOM_string_functions, only : lowercase use MOM_time_manager, only : time_type, time_type_to_real, real_to_time use MOM_time_manager, only : days_in_month, get_date, set_date @@ -22,33 +27,43 @@ module MOM_restart implicit none ; private public restart_init, restart_end, restore_state, register_restart_field -public save_restart, query_initialized, restart_registry_lock, restart_init_end, vardesc +public copy_restart_var, copy_restart_vector +public save_restart, query_initialized, set_initialized, only_read_from_restarts +public restart_registry_lock, restart_init_end, vardesc public restart_files_exist, determine_is_new_run, is_new_run public register_restart_field_as_obsolete, register_restart_pair +public lock_check + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. +! The functions in this module work with variables with arbitrary units, in which case the +! arbitrary rescaled units are indicated with [A ~> a], while the unscaled units are just [a]. !> A type for making arrays of pointers to 4-d arrays type p4d - real, dimension(:,:,:,:), pointer :: p => NULL() !< A pointer to a 4d array + real, dimension(:,:,:,:), pointer :: p => NULL() !< A pointer to a 4d array in arbitrary rescaled units [A ~> a] end type p4d !> A type for making arrays of pointers to 3-d arrays type p3d - real, dimension(:,:,:), pointer :: p => NULL() !< A pointer to a 3d array + real, dimension(:,:,:), pointer :: p => NULL() !< A pointer to a 3d array in arbitrary rescaled units [A ~> a] end type p3d !> A type for making arrays of pointers to 2-d arrays type p2d - real, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2d array + real, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2d array in arbitrary rescaled units [A ~> a] end type p2d !> A type for making arrays of pointers to 1-d arrays type p1d - real, dimension(:), pointer :: p => NULL() !< A pointer to a 1d array + real, dimension(:), pointer :: p => NULL() !< A pointer to a 1d array in arbitrary rescaled units [A ~> a] end type p1d !> A type for making arrays of pointers to scalars type p0d - real, pointer :: p => NULL() !< A pointer to a scalar + real, pointer :: p => NULL() !< A pointer to a scalar in arbitrary rescaled units [A ~> a] end type p0d !> A structure with information about a single restart field @@ -59,6 +74,10 @@ module MOM_restart !! read from the restart file. logical :: initialized !< .true. if this field has been read from the restart file. character(len=32) :: var_name !< A name by which a variable may be queried. + real :: conv = 1.0 !< A factor by which a restart field should be multiplied before it + !! is written to a restart file, usually to convert it to MKS or + !! other standard units [a A-1 ~> 1]. When read, the restart field + !! is multiplied by the reciprocal of this factor. end type field_restart !> A structure to store information about restart fields that are no longer used @@ -85,6 +104,17 @@ module MOM_restart !! Users may want to avoid this comparison if for example the restarts are !! made from a run with a different mask_table than the current run, !! in which case the checksums will not match and cause crash. + logical :: symmetric_checksums !< If true, do the restart checksums on all the edge points for + !! a non-reentrant grid. Setting this to true requires that + !! SYMMETRIC_MEMORY_ is defined at compile time. + logical :: unsigned_zeros !< If true, convert any negative zeros that would be written to + !! the restart file into ordinary unsigned zeros. This does not + !! change answers, but it can be helpful in comparing restart + !! files after grid rotation, for example. + logical :: reentrant_x !< If true, the domain is reentrant in the x-direction. This is only + !! used here to determine the extent of the restart checksums. + logical :: reentrant_y !< If true, the domain is reentrant in the y-direction. This is only + !! used here to determine the extent of the restart checksums. character(len=240) :: restartfile !< The name or name root for MOM restart files. integer :: turns !< Number of quarter turns from input to model domain logical :: locked = .false. !< If true this registry has been locked and no further restart @@ -132,6 +162,34 @@ module MOM_restart module procedure query_initialized_4d, query_initialized_4d_name end interface +!> Specify that a field has been initialized, even if it was not read from a restart file +interface set_initialized + module procedure set_initialized_name, set_initialized_0d_name + module procedure set_initialized_1d_name, set_initialized_2d_name + module procedure set_initialized_3d_name, set_initialized_4d_name +end interface + +!> Copy the restart variable with the specified name into an array, perhaps after rotation +interface copy_restart_var + module procedure copy_restart_var_3d +end interface copy_restart_var + +!> Copy the restart vector component variables with the specified names into a pair of arrays, +!! perhaps after rotation +interface copy_restart_vector + module procedure copy_restart_vector_3d +end interface copy_restart_vector + +!> Read optional variables from restart files. +interface only_read_from_restarts + module procedure only_read_restart_field_4d + module procedure only_read_restart_field_3d + module procedure only_read_restart_field_2d +! module procedure only_read_restart_field_1d +! module procedure only_read_restart_field_0d + module procedure only_read_restart_pair_3d +end interface + contains !> Register a restart field as obsolete @@ -146,13 +204,16 @@ subroutine register_restart_field_as_obsolete(field_name, replacement_name, CS) end subroutine register_restart_field_as_obsolete !> Register a 3-d field for restarts, providing the metadata in a structure -subroutine register_restart_field_ptr3d(f_ptr, var_desc, mandatory, CS) +subroutine register_restart_field_ptr3d(f_ptr, var_desc, mandatory, CS, conversion) real, dimension(:,:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") @@ -166,6 +227,8 @@ subroutine register_restart_field_ptr3d(f_ptr, var_desc, mandatory, CS) CS%restart_field(CS%novars)%vars = var_desc CS%restart_field(CS%novars)%mand_var = mandatory CS%restart_field(CS%novars)%initialized = .false. + CS%restart_field(CS%novars)%conv = 1.0 + if (present(conversion)) CS%restart_field(CS%novars)%conv = conversion call query_vardesc(CS%restart_field(CS%novars)%vars, & name=CS%restart_field(CS%novars)%var_name, & caller="register_restart_field_ptr3d") @@ -179,13 +242,16 @@ subroutine register_restart_field_ptr3d(f_ptr, var_desc, mandatory, CS) end subroutine register_restart_field_ptr3d !> Register a 4-d field for restarts, providing the metadata in a structure -subroutine register_restart_field_ptr4d(f_ptr, var_desc, mandatory, CS) +subroutine register_restart_field_ptr4d(f_ptr, var_desc, mandatory, CS, conversion) real, dimension(:,:,:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") @@ -199,6 +265,8 @@ subroutine register_restart_field_ptr4d(f_ptr, var_desc, mandatory, CS) CS%restart_field(CS%novars)%vars = var_desc CS%restart_field(CS%novars)%mand_var = mandatory CS%restart_field(CS%novars)%initialized = .false. + CS%restart_field(CS%novars)%conv = 1.0 + if (present(conversion)) CS%restart_field(CS%novars)%conv = conversion call query_vardesc(CS%restart_field(CS%novars)%vars, & name=CS%restart_field(CS%novars)%var_name, & caller="register_restart_field_ptr4d") @@ -212,13 +280,16 @@ subroutine register_restart_field_ptr4d(f_ptr, var_desc, mandatory, CS) end subroutine register_restart_field_ptr4d !> Register a 2-d field for restarts, providing the metadata in a structure -subroutine register_restart_field_ptr2d(f_ptr, var_desc, mandatory, CS) +subroutine register_restart_field_ptr2d(f_ptr, var_desc, mandatory, CS, conversion) real, dimension(:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") @@ -232,6 +303,8 @@ subroutine register_restart_field_ptr2d(f_ptr, var_desc, mandatory, CS) CS%restart_field(CS%novars)%vars = var_desc CS%restart_field(CS%novars)%mand_var = mandatory CS%restart_field(CS%novars)%initialized = .false. + CS%restart_field(CS%novars)%conv = 1.0 + if (present(conversion)) CS%restart_field(CS%novars)%conv = conversion call query_vardesc(CS%restart_field(CS%novars)%vars, & name=CS%restart_field(CS%novars)%var_name, & caller="register_restart_field_ptr2d") @@ -245,12 +318,15 @@ subroutine register_restart_field_ptr2d(f_ptr, var_desc, mandatory, CS) end subroutine register_restart_field_ptr2d !> Register a 1-d field for restarts, providing the metadata in a structure -subroutine register_restart_field_ptr1d(f_ptr, var_desc, mandatory, CS) +subroutine register_restart_field_ptr1d(f_ptr, var_desc, mandatory, CS, conversion) real, dimension(:), target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") @@ -264,6 +340,8 @@ subroutine register_restart_field_ptr1d(f_ptr, var_desc, mandatory, CS) CS%restart_field(CS%novars)%vars = var_desc CS%restart_field(CS%novars)%mand_var = mandatory CS%restart_field(CS%novars)%initialized = .false. + CS%restart_field(CS%novars)%conv = 1.0 + if (present(conversion)) CS%restart_field(CS%novars)%conv = conversion call query_vardesc(CS%restart_field(CS%novars)%vars, & name=CS%restart_field(CS%novars)%var_name, & caller="register_restart_field_ptr1d") @@ -277,12 +355,15 @@ subroutine register_restart_field_ptr1d(f_ptr, var_desc, mandatory, CS) end subroutine register_restart_field_ptr1d !> Register a 0-d field for restarts, providing the metadata in a structure -subroutine register_restart_field_ptr0d(f_ptr, var_desc, mandatory, CS) +subroutine register_restart_field_ptr0d(f_ptr, var_desc, mandatory, CS, conversion) real, target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") @@ -296,6 +377,8 @@ subroutine register_restart_field_ptr0d(f_ptr, var_desc, mandatory, CS) CS%restart_field(CS%novars)%vars = var_desc CS%restart_field(CS%novars)%mand_var = mandatory CS%restart_field(CS%novars)%initialized = .false. + CS%restart_field(CS%novars)%conv = 1.0 + if (present(conversion)) CS%restart_field(CS%novars)%conv = conversion call query_vardesc(CS%restart_field(CS%novars)%vars, & name=CS%restart_field(CS%novars)%var_name, & caller="register_restart_field_ptr0d") @@ -311,88 +394,181 @@ end subroutine register_restart_field_ptr0d !> Register a pair of rotationally equivalent 2d restart fields subroutine register_restart_pair_ptr2d(a_ptr, b_ptr, a_desc, b_desc, & - mandatory, CS) + mandatory, CS, conversion, scalar_pair) real, dimension(:,:), target, intent(in) :: a_ptr !< First field pointer + !! in arbitrary rescaled units [A ~> a] real, dimension(:,:), target, intent(in) :: b_ptr !< Second field pointer - type(vardesc), intent(in) :: a_desc !< First field descriptor - type(vardesc), intent(in) :: b_desc !< Second field descriptor - logical, intent(in) :: mandatory !< If true, abort if field is missing - type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control structure + !! in arbitrary rescaled units [A ~> a] + type(vardesc), intent(in) :: a_desc !< First field descriptor + type(vardesc), intent(in) :: b_desc !< Second field descriptor + logical, intent(in) :: mandatory !< If true, abort if field is missing + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control structure + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. + logical, optional, intent(in) :: scalar_pair !< If true, the arrays describe a pair of + !! scalars, instead of vector components + !! whose signs change when rotated + + ! Local variables + real :: a_conv, b_conv ! Factors to multipy the a- and b-components by before they are written, + ! including sign changes to account for grid rotation [a A-1 ~> 1] call lock_check(CS, a_desc) + call set_conversion_pair(a_conv, b_conv, CS%turns, conversion, scalar_pair) - if (modulo(CS%turns, 2) /= 0) then - call register_restart_field(b_ptr, a_desc, mandatory, CS) - call register_restart_field(a_ptr, b_desc, mandatory, CS) + if (modulo(CS%turns, 2) == 0) then ! This is the usual case. + call register_restart_field(a_ptr, a_desc, mandatory, CS, conversion=a_conv) + call register_restart_field(b_ptr, b_desc, mandatory, CS, conversion=b_conv) else - call register_restart_field(a_ptr, a_desc, mandatory, CS) - call register_restart_field(b_ptr, b_desc, mandatory, CS) + call register_restart_field(b_ptr, a_desc, mandatory, CS, conversion=a_conv) + call register_restart_field(a_ptr, b_desc, mandatory, CS, conversion=b_conv) endif end subroutine register_restart_pair_ptr2d !> Register a pair of rotationally equivalent 3d restart fields subroutine register_restart_pair_ptr3d(a_ptr, b_ptr, a_desc, b_desc, & - mandatory, CS) - real, dimension(:,:,:), target, intent(in) :: a_ptr !< First field pointer - real, dimension(:,:,:), target, intent(in) :: b_ptr !< Second field pointer - type(vardesc), intent(in) :: a_desc !< First field descriptor - type(vardesc), intent(in) :: b_desc !< Second field descriptor - logical, intent(in) :: mandatory !< If true, abort if field is missing - type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control structure + mandatory, CS, conversion, scalar_pair) + real, dimension(:,:,:), target, intent(in) :: a_ptr !< First field pointer + !! in arbitrary rescaled units [A ~> a] + real, dimension(:,:,:), target, intent(in) :: b_ptr !< Second field pointer + !! in arbitrary rescaled units [A ~> a] + type(vardesc), intent(in) :: a_desc !< First field descriptor + type(vardesc), intent(in) :: b_desc !< Second field descriptor + logical, intent(in) :: mandatory !< If true, abort if field is missing + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control structure + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. + logical, optional, intent(in) :: scalar_pair !< If true, the arrays describe a pair of + !! scalars, instead of vector components + !! whose signs change when rotated + + ! Local variables + real :: a_conv, b_conv ! Factors to multipy the a- and b-components by before they are written, + ! including sign changes to account for grid rotation [a A-1 ~> 1] call lock_check(CS, a_desc) + call set_conversion_pair(a_conv, b_conv, CS%turns, conversion, scalar_pair) - if (modulo(CS%turns, 2) /= 0) then - call register_restart_field(b_ptr, a_desc, mandatory, CS) - call register_restart_field(a_ptr, b_desc, mandatory, CS) + if (modulo(CS%turns, 2) == 0) then ! This is the usual case. + call register_restart_field(a_ptr, a_desc, mandatory, CS, conversion=a_conv) + call register_restart_field(b_ptr, b_desc, mandatory, CS, conversion=b_conv) else - call register_restart_field(a_ptr, a_desc, mandatory, CS) - call register_restart_field(b_ptr, b_desc, mandatory, CS) + call register_restart_field(b_ptr, a_desc, mandatory, CS, conversion=a_conv) + call register_restart_field(a_ptr, b_desc, mandatory, CS, conversion=b_conv) endif end subroutine register_restart_pair_ptr3d !> Register a pair of rotationally equivalent 2d restart fields subroutine register_restart_pair_ptr4d(a_ptr, b_ptr, a_desc, b_desc, & - mandatory, CS) + mandatory, CS, conversion, scalar_pair) real, dimension(:,:,:,:), target, intent(in) :: a_ptr !< First field pointer + !! in arbitrary rescaled units [A ~> a] real, dimension(:,:,:,:), target, intent(in) :: b_ptr !< Second field pointer - type(vardesc), intent(in) :: a_desc !< First field descriptor - type(vardesc), intent(in) :: b_desc !< Second field descriptor - logical, intent(in) :: mandatory !< If true, abort if field is missing - type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control structure + !! in arbitrary rescaled units [A ~> a] + type(vardesc), intent(in) :: a_desc !< First field descriptor + type(vardesc), intent(in) :: b_desc !< Second field descriptor + logical, intent(in) :: mandatory !< If true, abort if field is missing + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control structure + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. + logical, optional, intent(in) :: scalar_pair !< If true, the arrays describe a pair of + !! scalars, instead of vector components + !! whose signs change when rotated + + ! Local variables + real :: a_conv, b_conv ! Factors to multipy the a- and b-components by before they are written, + ! including sign changes to account for grid rotation [a A-1 ~> 1] call lock_check(CS, a_desc) + call set_conversion_pair(a_conv, b_conv, CS%turns, conversion, scalar_pair) - if (modulo(CS%turns, 2) /= 0) then - call register_restart_field(b_ptr, a_desc, mandatory, CS) - call register_restart_field(a_ptr, b_desc, mandatory, CS) + if (modulo(CS%turns, 2) == 0) then ! This is the usual case. + call register_restart_field(a_ptr, a_desc, mandatory, CS, conversion=a_conv) + call register_restart_field(b_ptr, b_desc, mandatory, CS, conversion=b_conv) else - call register_restart_field(a_ptr, a_desc, mandatory, CS) - call register_restart_field(b_ptr, b_desc, mandatory, CS) + call register_restart_field(b_ptr, a_desc, mandatory, CS, conversion=a_conv) + call register_restart_field(a_ptr, b_desc, mandatory, CS, conversion=b_conv) endif end subroutine register_restart_pair_ptr4d +!> Set a pair of factors to multiply by the components of a vector when writing +!! that include any sign changes needed to account for grid rotation. +subroutine set_conversion_pair(u_conv, v_conv, turns, conversion, scalar_pair) + real, intent(out) :: u_conv !< A factor to multiply the u-component of a vector by before it is + !! written, including sign changes due to grid rotation [a A-1 ~> 1] + real, intent(out) :: v_conv !< A factor to multiply the u-component of a vector by before it is + !! written, including sign changes due to grid rotation [a A-1 ~> 1] + integer, intent(in) :: turns !< Number of quarter turns from input to model domain + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. + logical, optional, intent(in) :: scalar_pair !< If true, the arrays describe a pair of scalars, + !! instead of vector components whose signs change when rotated + + ! Local variables + integer :: q_turns + logical :: scalars + + u_conv = 1.0 ; v_conv = 1.0 + if (present(conversion)) then + u_conv = conversion ; v_conv = conversion + endif + + scalars = .false. ; if (present(scalar_pair)) scalars = scalar_pair + if (scalars) return + + q_turns = modulo(turns, 4) + if (q_turns == 1) then + v_conv = -1.0*v_conv + elseif (q_turns == 2) then + u_conv = -1.0*u_conv ; v_conv = -1.0*v_conv + elseif (q_turns == 3) then + u_conv = -1.0*u_conv + endif + +end subroutine set_conversion_pair + ! The following provide alternate interfaces to register restarts. !> Register a 4-d field for restarts, providing the metadata as individual arguments -subroutine register_restart_field_4d(f_ptr, name, mandatory, CS, longname, units, & - hor_grid, z_grid, t_grid) +subroutine register_restart_field_4d(f_ptr, name, mandatory, CS, longname, units, conversion, & + hor_grid, z_grid, t_grid, extra_axes) real, dimension(:,:,:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] character(len=*), intent(in) :: name !< variable name to be used in the restart file logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct character(len=*), optional, intent(in) :: longname !< variable long name character(len=*), optional, intent(in) :: units !< variable units + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. character(len=*), optional, intent(in) :: hor_grid !< variable horizontal staggering, 'h' if absent character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering, 'L' if absent character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent + type(axis_info), dimension(:), & + optional, intent(in) :: extra_axes !< dimensions other than space-time type(vardesc) :: vd + character(len=32), dimension(:), allocatable :: dim_names + integer :: n, n_extradims + + ! first 2 dimensions in dim_names are reserved for i,j + ! so extra_dimensions are shifted to index 3. + ! this is designed not to break the behavior in SIS2 + ! (see register_restart_field_4d in SIS_restart.F90) + if (present(extra_axes)) then + n_extradims = size(extra_axes) + allocate(dim_names(n_extradims+2)) + dim_names(1) = "" + dim_names(2) = "" + do n=3,n_extradims+2 + dim_names(n) = extra_axes(n-2)%name + enddo + endif if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart: " // & "register_restart_field_4d: Module must be initialized before "//& @@ -400,29 +576,55 @@ subroutine register_restart_field_4d(f_ptr, name, mandatory, CS, longname, units call lock_check(CS, name=name) - vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & - z_grid=z_grid, t_grid=t_grid) + if (present(extra_axes)) then + vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & + z_grid=z_grid, t_grid=t_grid, dim_names=dim_names, extra_axes=extra_axes) + else + vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & + z_grid=z_grid, t_grid=t_grid) + endif - call register_restart_field_ptr4d(f_ptr, vd, mandatory, CS) + call register_restart_field_ptr4d(f_ptr, vd, mandatory, CS, conversion) end subroutine register_restart_field_4d !> Register a 3-d field for restarts, providing the metadata as individual arguments -subroutine register_restart_field_3d(f_ptr, name, mandatory, CS, longname, units, & - hor_grid, z_grid, t_grid) +subroutine register_restart_field_3d(f_ptr, name, mandatory, CS, longname, units, conversion, & + hor_grid, z_grid, t_grid, extra_axes) real, dimension(:,:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] character(len=*), intent(in) :: name !< variable name to be used in the restart file logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct character(len=*), optional, intent(in) :: longname !< variable long name character(len=*), optional, intent(in) :: units !< variable units + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. character(len=*), optional, intent(in) :: hor_grid !< variable horizontal staggering, 'h' if absent character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering, 'L' if absent character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent + type(axis_info), dimension(:), & + optional, intent(in) :: extra_axes !< dimensions other than space-time type(vardesc) :: vd + character(len=32), dimension(:), allocatable :: dim_names + integer :: n, n_extradims + + ! first 2 dimensions in dim_names are reserved for i,j + ! so extra_dimensions are shifted to index 3. + ! this is designed not to break the behavior in SIS2 + ! (see register_restart_field_4d in SIS_restart.F90) + if (present(extra_axes)) then + n_extradims = size(extra_axes) + allocate(dim_names(n_extradims+2)) + dim_names(1) = "" + dim_names(2) = "" + do n=3,n_extradims+2 + dim_names(n) = extra_axes(n-2)%name + enddo + endif if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart: " // & "register_restart_field_3d: Module must be initialized before "//& @@ -430,24 +632,32 @@ subroutine register_restart_field_3d(f_ptr, name, mandatory, CS, longname, units call lock_check(CS, name=name) - vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & - z_grid=z_grid, t_grid=t_grid) + if (present(extra_axes)) then + vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & + z_grid=z_grid, t_grid=t_grid, dim_names=dim_names, extra_axes=extra_axes) + else + vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & + z_grid=z_grid, t_grid=t_grid) + endif - call register_restart_field_ptr3d(f_ptr, vd, mandatory, CS) + call register_restart_field_ptr3d(f_ptr, vd, mandatory, CS, conversion) end subroutine register_restart_field_3d !> Register a 2-d field for restarts, providing the metadata as individual arguments -subroutine register_restart_field_2d(f_ptr, name, mandatory, CS, longname, units, & +subroutine register_restart_field_2d(f_ptr, name, mandatory, CS, longname, units, conversion, & hor_grid, z_grid, t_grid) real, dimension(:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] character(len=*), intent(in) :: name !< variable name to be used in the restart file logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct character(len=*), optional, intent(in) :: longname !< variable long name character(len=*), optional, intent(in) :: units !< variable units + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. character(len=*), optional, intent(in) :: hor_grid !< variable horizontal staggering, 'h' if absent character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering, '1' if absent character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent @@ -466,20 +676,23 @@ subroutine register_restart_field_2d(f_ptr, name, mandatory, CS, longname, units vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & z_grid=zgrid, t_grid=t_grid) - call register_restart_field_ptr2d(f_ptr, vd, mandatory, CS) + call register_restart_field_ptr2d(f_ptr, vd, mandatory, CS, conversion) end subroutine register_restart_field_2d !> Register a 1-d field for restarts, providing the metadata as individual arguments -subroutine register_restart_field_1d(f_ptr, name, mandatory, CS, longname, units, & +subroutine register_restart_field_1d(f_ptr, name, mandatory, CS, longname, units, conversion, & hor_grid, z_grid, t_grid) real, dimension(:), target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] character(len=*), intent(in) :: name !< variable name to be used in the restart file logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct character(len=*), optional, intent(in) :: longname !< variable long name character(len=*), optional, intent(in) :: units !< variable units + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. character(len=*), optional, intent(in) :: hor_grid !< variable horizontal staggering, '1' if absent character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering, 'L' if absent character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent @@ -498,20 +711,23 @@ subroutine register_restart_field_1d(f_ptr, name, mandatory, CS, longname, units vd = var_desc(name, units=units, longname=longname, hor_grid=hgrid, & z_grid=z_grid, t_grid=t_grid) - call register_restart_field_ptr1d(f_ptr, vd, mandatory, CS) + call register_restart_field_ptr1d(f_ptr, vd, mandatory, CS, conversion) end subroutine register_restart_field_1d !> Register a 0-d field for restarts, providing the metadata as individual arguments -subroutine register_restart_field_0d(f_ptr, name, mandatory, CS, longname, units, & +subroutine register_restart_field_0d(f_ptr, name, mandatory, CS, longname, units, conversion, & t_grid) real, target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] character(len=*), intent(in) :: name !< variable name to be used in the restart file logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct character(len=*), optional, intent(in) :: longname !< variable long name character(len=*), optional, intent(in) :: units !< variable units + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written [a A-1 ~> 1], 1 by default. character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent type(vardesc) :: vd @@ -525,13 +741,13 @@ subroutine register_restart_field_0d(f_ptr, name, mandatory, CS, longname, units vd = var_desc(name, units=units, longname=longname, hor_grid='1', & z_grid='1', t_grid=t_grid) - call register_restart_field_ptr0d(f_ptr, vd, mandatory, CS) + call register_restart_field_ptr0d(f_ptr, vd, mandatory, CS, conversion) end subroutine register_restart_field_0d !> query_initialized_name determines whether a named field has been successfully -!! read from a restart file yet. +!! read from a restart file or has otherwise been recorded as being initialized. function query_initialized_name(name, CS) result(query_initialized) character(len=*), intent(in) :: name !< The name of the field that is being queried type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct @@ -552,8 +768,6 @@ function query_initialized_name(name, CS) result(query_initialized) n = m ; exit endif enddo - ! Assume that you are going to initialize it now, so set flag to initialized if queried again. - if (n<=CS%novars) CS%restart_field(n)%initialized = .true. if ((n==CS%novars+1) .and. (is_root_pe())) & call MOM_error(NOTE,"MOM_restart: Unknown restart variable "//name// & " queried for initialization.") @@ -566,7 +780,7 @@ end function query_initialized_name !> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. function query_initialized_0d(f_ptr, CS) result(query_initialized) - real, target, intent(in) :: f_ptr !< A pointer to the field that is being queried + real, target, intent(in) :: f_ptr !< A pointer to the field that is being queried [arbitrary] type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct logical :: query_initialized @@ -585,14 +799,12 @@ function query_initialized_0d(f_ptr, CS) result(query_initialized) n = m ; exit endif enddo - ! Assume that you are going to initialize it now, so set flag to initialized if queried again. - if (n<=CS%novars) CS%restart_field(n)%initialized = .true. end function query_initialized_0d !> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. function query_initialized_1d(f_ptr, CS) result(query_initialized) - real, dimension(:), target, intent(in) :: f_ptr !< A pointer to the field that is being queried + real, dimension(:), target, intent(in) :: f_ptr !< A pointer to the field that is being queried [arbitrary] type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct logical :: query_initialized @@ -611,15 +823,13 @@ function query_initialized_1d(f_ptr, CS) result(query_initialized) n = m ; exit endif enddo - ! Assume that you are going to initialize it now, so set flag to initialized if queried again. - if (n<=CS%novars) CS%restart_field(n)%initialized = .true. end function query_initialized_1d !> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. function query_initialized_2d(f_ptr, CS) result(query_initialized) real, dimension(:,:), & - target, intent(in) :: f_ptr !< A pointer to the field that is being queried + target, intent(in) :: f_ptr !< A pointer to the field that is being queried [arbitrary] type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct logical :: query_initialized @@ -638,15 +848,13 @@ function query_initialized_2d(f_ptr, CS) result(query_initialized) n = m ; exit endif enddo - ! Assume that you are going to initialize it now, so set flag to initialized if queried again. - if (n<=CS%novars) CS%restart_field(n)%initialized = .true. end function query_initialized_2d !> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. function query_initialized_3d(f_ptr, CS) result(query_initialized) real, dimension(:,:,:), & - target, intent(in) :: f_ptr !< A pointer to the field that is being queried + target, intent(in) :: f_ptr !< A pointer to the field that is being queried [arbitrary] type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct logical :: query_initialized @@ -665,15 +873,13 @@ function query_initialized_3d(f_ptr, CS) result(query_initialized) n = m ; exit endif enddo - ! Assume that you are going to initialize it now, so set flag to initialized if queried again. - if (n<=CS%novars) CS%restart_field(n)%initialized = .true. end function query_initialized_3d !> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. function query_initialized_4d(f_ptr, CS) result(query_initialized) real, dimension(:,:,:,:), & - target, intent(in) :: f_ptr !< A pointer to the field that is being queried + target, intent(in) :: f_ptr !< A pointer to the field that is being queried [arbitrary] type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct logical :: query_initialized @@ -692,15 +898,13 @@ function query_initialized_4d(f_ptr, CS) result(query_initialized) n = m ; exit endif enddo - ! Assume that you are going to initialize it now, so set flag to initialized if queried again. - if (n<=CS%novars) CS%restart_field(n)%initialized = .true. end function query_initialized_4d -!> Indicate whether the field pointed to by f_ptr or with the specified variable +!> Indicate whether the field stored in f_ptr or with the specified variable !! name has been initialized from a restart file. function query_initialized_0d_name(f_ptr, name, CS) result(query_initialized) - real, target, intent(in) :: f_ptr !< A pointer to the field that is being queried + real, target, intent(in) :: f_ptr !< The field that is being queried [arbitrary] character(len=*), intent(in) :: name !< The name of the field that is being queried type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct logical :: query_initialized @@ -720,8 +924,6 @@ function query_initialized_0d_name(f_ptr, name, CS) result(query_initialized) n = m ; exit endif enddo - ! Assume that you are going to initialize it now, so set flag to initialized if queried again. - if (n<=CS%novars) CS%restart_field(n)%initialized = .true. if (n==CS%novars+1) then if (is_root_pe()) & call MOM_error(NOTE,"MOM_restart: Unable to find "//name//" queried by pointer, "//& @@ -731,11 +933,11 @@ function query_initialized_0d_name(f_ptr, name, CS) result(query_initialized) end function query_initialized_0d_name -!> Indicate whether the field pointed to by f_ptr or with the specified variable +!> Indicate whether the field stored in f_ptr or with the specified variable !! name has been initialized from a restart file. function query_initialized_1d_name(f_ptr, name, CS) result(query_initialized) real, dimension(:), & - target, intent(in) :: f_ptr !< A pointer to the field that is being queried + target, intent(in) :: f_ptr !< The field that is being queried [arbitrary] character(len=*), intent(in) :: name !< The name of the field that is being queried type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct logical :: query_initialized @@ -755,8 +957,6 @@ function query_initialized_1d_name(f_ptr, name, CS) result(query_initialized) n = m ; exit endif enddo - ! Assume that you are going to initialize it now, so set flag to initialized if queried again. - if (n<=CS%novars) CS%restart_field(n)%initialized = .true. if (n==CS%novars+1) then if (is_root_pe()) & call MOM_error(NOTE,"MOM_restart: Unable to find "//name//" queried by pointer, "//& @@ -766,11 +966,11 @@ function query_initialized_1d_name(f_ptr, name, CS) result(query_initialized) end function query_initialized_1d_name -!> Indicate whether the field pointed to by f_ptr or with the specified variable +!> Indicate whether the field stored in f_ptr or with the specified variable !! name has been initialized from a restart file. function query_initialized_2d_name(f_ptr, name, CS) result(query_initialized) real, dimension(:,:), & - target, intent(in) :: f_ptr !< A pointer to the field that is being queried + target, intent(in) :: f_ptr !< The field that is being queried [arbitrary] character(len=*), intent(in) :: name !< The name of the field that is being queried type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct logical :: query_initialized @@ -790,8 +990,6 @@ function query_initialized_2d_name(f_ptr, name, CS) result(query_initialized) n = m ; exit endif enddo - ! Assume that you are going to initialize it now, so set flag to initialized if queried again. - if (n<=CS%novars) CS%restart_field(n)%initialized = .true. if (n==CS%novars+1) then if (is_root_pe()) & call MOM_error(NOTE,"MOM_restart: Unable to find "//name//" queried by pointer, "//& @@ -801,11 +999,11 @@ function query_initialized_2d_name(f_ptr, name, CS) result(query_initialized) end function query_initialized_2d_name -!> Indicate whether the field pointed to by f_ptr or with the specified variable +!> Indicate whether the field stored in f_ptr or with the specified variable !! name has been initialized from a restart file. function query_initialized_3d_name(f_ptr, name, CS) result(query_initialized) real, dimension(:,:,:), & - target, intent(in) :: f_ptr !< A pointer to the field that is being queried + target, intent(in) :: f_ptr !< The field that is being queried [arbitrary] character(len=*), intent(in) :: name !< The name of the field that is being queried type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct logical :: query_initialized @@ -825,8 +1023,6 @@ function query_initialized_3d_name(f_ptr, name, CS) result(query_initialized) n = m ; exit endif enddo - ! Assume that you are going to initialize it now, so set flag to initialized if queried again. - if (n<=CS%novars) CS%restart_field(n)%initialized = .true. if (n==CS%novars+1) then if (is_root_pe()) & call MOM_error(NOTE, "MOM_restart: Unable to find "//name//" queried by pointer, "//& @@ -836,11 +1032,11 @@ function query_initialized_3d_name(f_ptr, name, CS) result(query_initialized) end function query_initialized_3d_name -!> Indicate whether the field pointed to by f_ptr or with the specified variable +!> Indicate whether the field stored in f_ptr or with the specified variable !! name has been initialized from a restart file. function query_initialized_4d_name(f_ptr, name, CS) result(query_initialized) real, dimension(:,:,:,:), & - target, intent(in) :: f_ptr !< A pointer to the field that is being queried + target, intent(in) :: f_ptr !< The field that is being queried [arbitrary] character(len=*), intent(in) :: name !< The name of the field that is being queried type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct logical :: query_initialized @@ -860,8 +1056,6 @@ function query_initialized_4d_name(f_ptr, name, CS) result(query_initialized) n = m ; exit endif enddo - ! Assume that you are going to initialize it now, so set flag to initialized if queried again. - if (n<=CS%novars) CS%restart_field(n)%initialized = .true. if (n==CS%novars+1) then if (is_root_pe()) & call MOM_error(NOTE, "MOM_restart: Unable to find "//name//" queried by pointer, "//& @@ -871,12 +1065,512 @@ function query_initialized_4d_name(f_ptr, name, CS) result(query_initialized) end function query_initialized_4d_name +!> set_initialized_name records that a named field has been initialized. +subroutine set_initialized_name(name, CS) + character(len=*), intent(in) :: name !< The name of the field that is being set + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + + integer :: m + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "set_initialized: Module must be initialized before it is used.") + + do m=1,CS%novars ; if (trim(name) == trim(CS%restart_field(m)%var_name)) then + CS%restart_field(m)%initialized = .true. ; exit + endif ; enddo + + if ((m==CS%novars+1) .and. (is_root_pe())) & + call MOM_error(NOTE,"MOM_restart: Unknown restart variable "//name// & + " used in set_initialized call.") + +end subroutine set_initialized_name + +!> Record that the array in f_ptr with the given name has been initialized. +subroutine set_initialized_0d_name(f_ptr, name, CS) + real, target, intent(in) :: f_ptr !< The variable that has been initialized [arbitrary] + character(len=*), intent(in) :: name !< The name of the field that has been initialized + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + + integer :: m + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "set_initialized: Module must be initialized before it is used.") + + do m=1,CS%novars ; if (associated(CS%var_ptr0d(m)%p,f_ptr)) then + CS%restart_field(m)%initialized = .true. ; exit + endif ; enddo + + if (m==CS%novars+1) then + if (is_root_pe()) & + call MOM_error(NOTE,"MOM_restart: Unable to find "//name//" queried by pointer, "//& + "probably because of the suspect comparison of pointers by ASSOCIATED.") + call set_initialized_name(name, CS) + endif + +end subroutine set_initialized_0d_name + +!> Record that the array in f_ptr with the given name has been initialized. +subroutine set_initialized_1d_name(f_ptr, name, CS) + real, dimension(:), & + target, intent(in) :: f_ptr !< The array that has been initialized [arbitrary] + character(len=*), intent(in) :: name !< The name of the field that has been initialized + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + + integer :: m + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "set_initialized: Module must be initialized before it is used.") + + do m=1,CS%novars ; if (associated(CS%var_ptr1d(m)%p,f_ptr)) then + CS%restart_field(m)%initialized = .true. ; exit + endif ; enddo + + if (m==CS%novars+1) then + if (is_root_pe()) & + call MOM_error(NOTE,"MOM_restart: Unable to find "//name//" queried by pointer, "//& + "probably because of the suspect comparison of pointers by ASSOCIATED.") + call set_initialized_name(name, CS) + endif + +end subroutine set_initialized_1d_name + +!> Record that the array in f_ptr with the given name has been initialized. +subroutine set_initialized_2d_name(f_ptr, name, CS) + real, dimension(:,:), & + target, intent(in) :: f_ptr !< The array that has been initialized [arbitrary] + character(len=*), intent(in) :: name !< The name of the field that has been initialized + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + + integer :: m + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "set_initialized: Module must be initialized before it is used.") + + do m=1,CS%novars ; if (associated(CS%var_ptr2d(m)%p,f_ptr)) then + CS%restart_field(m)%initialized = .true. ; exit + endif ; enddo + + if (m==CS%novars+1) then + if (is_root_pe()) & + call MOM_error(NOTE,"MOM_restart: Unable to find "//name//" queried by pointer, "//& + "probably because of the suspect comparison of pointers by ASSOCIATED.") + call set_initialized_name(name, CS) + endif + +end subroutine set_initialized_2d_name + +!> Record that the array in f_ptr with the given name has been initialized. +subroutine set_initialized_3d_name(f_ptr, name, CS) + real, dimension(:,:,:), & + target, intent(in) :: f_ptr !< The array that has been initialized [arbitrary] + character(len=*), intent(in) :: name !< The name of the field that has been initialized + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + + integer :: m + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "set_initialized: Module must be initialized before it is used.") + + do m=1,CS%novars ; if (associated(CS%var_ptr3d(m)%p,f_ptr)) then + CS%restart_field(m)%initialized = .true. ; exit + endif ; enddo + + if (m==CS%novars+1) then + if (is_root_pe()) & + call MOM_error(NOTE,"MOM_restart: Unable to find "//name//" queried by pointer, "//& + "probably because of the suspect comparison of pointers by ASSOCIATED.") + call set_initialized_name(name, CS) + endif + +end subroutine set_initialized_3d_name + +!> Record that the array in f_ptr with the given name has been initialized. +subroutine set_initialized_4d_name(f_ptr, name, CS) + real, dimension(:,:,:,:), & + target, intent(in) :: f_ptr !< The array that has been initialized [arbitrary] + character(len=*), intent(in) :: name !< The name of the field that has been initialized + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + + integer :: m + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "set_initialized: Module must be initialized before it is used.") + + do m=1,CS%novars ; if (associated(CS%var_ptr4d(m)%p,f_ptr)) then + CS%restart_field(m)%initialized = .true. ; exit + endif ; enddo + + if (m==CS%novars+1) then + if (is_root_pe()) & + call MOM_error(NOTE,"MOM_restart: Unable to find "//name//" queried by pointer, "//& + "probably because of the suspect comparison of pointers by ASSOCIATED.") + call set_initialized_name(name, CS) + endif + +end subroutine set_initialized_4d_name + + +!====================== only_read_from_restarts variants ======================= + +!> Try to read a named 4-d field from the restart files +subroutine only_read_restart_field_4d(varname, f_ptr, G, CS, position, filename, directory, success, scale) + character(len=*), intent(in) :: varname !< The variable name to be used in the restart file + real, dimension(:,:,:,:), intent(inout) :: f_ptr !< The array for the field to be read + !! in arbitrary rescaled units [A ~> a] + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + integer, optional, intent(in) :: position !< A coded integer indicating the horizontal + !! position of this variable + character(len=*), optional, intent(in) :: filename !< The list of restart file names or a single + !! character 'r' to read automatically named files + character(len=*), optional, intent(in) :: directory !< The directory in which to seek restart files. + logical, optional, intent(out) :: success !< True if the field was read successfully + real, optional, intent(in) :: scale !< A factor by which the field will be scaled + !! [A a-1 ~> 1] to convert from the units in + !! the file to the internal units of this field + + ! Local variables + character(len=:), allocatable :: file_path ! The full path to the file with the variable + logical :: found ! True if the variable was found. + logical :: is_global ! True if the variable is in a global file. + + found = find_var_in_restart_files(varname, G, CS, file_path, filename, directory, is_global) + + if (found) then + call MOM_read_data(file_path, varname, f_ptr, G%domain, timelevel=1, position=position, & + scale=scale, global_file=is_global) + endif + if (present(success)) success = found + +end subroutine only_read_restart_field_4d + +!> Try to read a named 3-d field from the restart files +subroutine only_read_restart_field_3d(varname, f_ptr, G, CS, position, filename, directory, success, scale) + character(len=*), intent(in) :: varname !< The variable name to be used in the restart file + real, dimension(:,:,:), intent(inout) :: f_ptr !< The array for the field to be read + !! in arbitrary rescaled units [A ~> a] + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + integer, optional, intent(in) :: position !< A coded integer indicating the horizontal + !! position of this variable + character(len=*), optional, intent(in) :: filename !< The list of restart file names or a single + !! character 'r' to read automatically named files + character(len=*), optional, intent(in) :: directory !< The directory in which to seek restart files. + logical, optional, intent(out) :: success !< True if the field was read successfully + real, optional, intent(in) :: scale !< A factor by which the field will be scaled + !! [A a-1 ~> 1] to convert from the units in + !! the file to the internal units of this field + + ! Local variables + character(len=:), allocatable :: file_path ! The full path to the file with the variable + logical :: found ! True if the variable was found. + logical :: is_global ! True if the variable is in a global file. + + found = find_var_in_restart_files(varname, G, CS, file_path, filename, directory, is_global) + + if (found) then + call MOM_read_data(file_path, varname, f_ptr, G%domain, timelevel=1, position=position, & + scale=scale, global_file=is_global) + endif + if (present(success)) success = found + +end subroutine only_read_restart_field_3d + +!> Try to read a named 2-d field from the restart files +subroutine only_read_restart_field_2d(varname, f_ptr, G, CS, position, filename, directory, success, scale) + character(len=*), intent(in) :: varname !< The variable name to be used in the restart file + real, dimension(:,:), intent(inout) :: f_ptr !< The array for the field to be read + !! in arbitrary rescaled units [A ~> a] + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + integer, optional, intent(in) :: position !< A coded integer indicating the horizontal + !! position of this variable + character(len=*), optional, intent(in) :: filename !< The list of restart file names or a single + !! character 'r' to read automatically named files + character(len=*), optional, intent(in) :: directory !< The directory in which to seek restart files. + logical, optional, intent(out) :: success !< True if the field was read successfully + real, optional, intent(in) :: scale !< A factor by which the field will be scaled + !! [A a-1 ~> 1] to convert from the units in + !! the file to the internal units of this field + + ! Local variables + character(len=:), allocatable :: file_path ! The full path to the file with the variable + logical :: found ! True if the variable was found. + logical :: is_global ! True if the variable is in a global file. + + found = find_var_in_restart_files(varname, G, CS, file_path, filename, directory, is_global) + + if (found) then + call MOM_read_data(file_path, varname, f_ptr, G%domain, timelevel=1, position=position, & + scale=scale, global_file=is_global) + endif + if (present(success)) success = found + +end subroutine only_read_restart_field_2d + + +!> Try to read a named 3-d field from the restart files +subroutine only_read_restart_pair_3d(a_ptr, b_ptr, a_name, b_name, G, CS, & + stagger, filename, directory, success, scale) + real, dimension(:,:,:), intent(inout) :: a_ptr !< The array for the first field to be read + !! in arbitrary rescaled units [A ~> a] + real, dimension(:,:,:), intent(inout) :: b_ptr !< The array for the second field to be read + !! in arbitrary rescaled units [A ~> a] + character(len=*), intent(in) :: a_name !< The first variable name to be used in the restart file + character(len=*), intent(in) :: b_name !< The second variable name to be used in the restart file + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + integer, optional, intent(in) :: stagger !< A coded integer indicating the horizontal + !! position of this pair of variables + character(len=*), optional, intent(in) :: filename !< The list of restart file names or a single + !! character 'r' to read automatically named files + character(len=*), optional, intent(in) :: directory !< The directory in which to seek restart files. + logical, optional, intent(out) :: success !< True if the field was read successfully + real, optional, intent(in) :: scale !< A factor by which the fields will be scaled + !! [A a-1 ~> 1] to convert from the units in + !! the file to the internal units of this field + + ! Local variables + character(len=:), allocatable :: file_path_a ! The full path to the file with the first variable + character(len=:), allocatable :: file_path_b ! The full path to the file with the second variable + integer :: a_pos, b_pos ! A coded position for the two variables. + logical :: a_found, b_found ! True if the variables were found. + logical :: global_a, global_b ! True if the variables are in global files. + + a_found = find_var_in_restart_files(a_name, G, CS, file_path_a, filename, directory, global_a) + b_found = find_var_in_restart_files(b_name, G, CS, file_path_b, filename, directory, global_b) + + a_pos = EAST_FACE ; b_pos = NORTH_FACE + if (present(stagger)) then ; select case (stagger) + case (AGRID) ; a_pos = CENTER ; b_pos = CENTER + case (BGRID_NE) ; a_pos = CORNER ; b_pos = CORNER + case (CGRID_NE) ; a_pos = EAST_FACE ; b_pos = NORTH_FACE + case default ; a_pos = EAST_FACE ; b_pos = NORTH_FACE + end select ; endif + + if (a_found .and. b_found) then + call MOM_read_data(file_path_a, a_name, a_ptr, G%domain, timelevel=1, position=a_pos, & + scale=scale, global_file=global_b, file_may_be_4d=.true.) + call MOM_read_data(file_path_b, b_name, b_ptr, G%domain, timelevel=1, position=b_pos, & + scale=scale, global_file=global_b, file_may_be_4d=.true.) + endif + if (present(success)) success = (a_found .and. b_found) + +end subroutine only_read_restart_pair_3d + +!> Return an indication of whether the named variable is in the restart files, and provide the full path +!! to the restart file in which a variable is found. +function find_var_in_restart_files(varname, G, CS, file_path, filename, directory, is_global) result (found) + character(len=*), intent(in) :: varname !< The variable name to be used in the restart file + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + character(len=:), allocatable, intent(out) :: file_path !< The full path to the file in which the + !! variable is found + character(len=*), optional, intent(in) :: filename !< The list of restart file names or a single + !! character 'r' to read automatically named files + character(len=*), optional, intent(in) :: directory !< The directory in which to seek restart files. + logical, optional, intent(out) :: is_global !< True if the file is global. + logical :: found !< True if the named variable was found in the restart files. + + ! Local variables + character(len=240), allocatable, dimension(:) :: file_paths ! The possible file names. + character(len=:), allocatable :: dir ! The directory to read from. + character(len=:), allocatable :: fname ! The list of file names. + logical, allocatable, dimension(:) :: global_file ! True if the file is global + integer :: n, num_files + + dir = "./INPUT/" ; if (present(directory)) dir = trim(directory) + + ! Set the default return values. + found = .false. + file_path = "" + if (present(is_global)) is_global = .false. + + fname = 'r' + if (present(filename)) then + if (.not.((LEN_TRIM(filename) == 1) .and. (filename(1:1) == 'F'))) fname = filename + endif + + num_files = get_num_restart_files(fname, dir, G, CS) + if (num_files == 0) return + allocate(file_paths(num_files), global_file(num_files)) + num_files = open_restart_units(fname, dir, G, CS, file_paths=file_paths, global_files=global_file) + + do n=1,num_files ; if (field_exists(file_paths(n), varname, MOM_Domain=G%domain)) then + found = .true. + file_path = file_paths(n) + if (present(is_global)) is_global = global_file(n) + exit + endif ; enddo + + deallocate(file_paths, global_file) + +end function find_var_in_restart_files + +!====================== end of the only_read_from_restarts variants ======================= + + +!> Copy the restart variable with the specified name into a 3-d array, perhaps after rotation +subroutine copy_restart_var_3d(var, name, CS, unrotate) + real, dimension(:,:,:), intent(inout) :: var !< The field that is being copied [arbitrary] + character(len=*), intent(in) :: name !< The name of the field that is being copied + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + logical, optional, intent(in) :: unrotate !< If present and true, the output is on an unrotated grid. + + logical :: keep_rotation + character(len=256) :: size_msg !< The array sizes + integer :: m, n + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "query_initialized: Module must be initialized before it is used.") + + if (CS%novars > CS%max_fields) call restart_error(CS) + + keep_rotation = .true. ; if (present(unrotate)) keep_rotation = .not.unrotate + + n = CS%novars+1 + do m=1,CS%novars + if (trim(name) == CS%restart_field(m)%var_name) then + if (.not.associated(CS%var_ptr3d(m)%p)) then + call MOM_error(FATAL, "MOM_restart: copy_restart_var(_3d) "//& + "attempted to copy restart variable "//name//" with the wrong rank.") + elseif (CS%restart_field(m)%initialized) then + if (CS%turns == 0 .or. keep_rotation) then + if ( size_mismatch_3d(var, CS%var_ptr3d(m)%p, CS%turns, size_msg) ) & + call MOM_error(FATAL, "MOM_restart: copy_restart_var(_3d) "//& + "attempted to copy restart variable "//name//" with the wrong sizes, "//trim(size_msg)) + + var(:,:,:) = CS%var_ptr3d(m)%p(:,:,:) + else + call rotate_array(CS%var_ptr3d(m)%p, -CS%turns, var) + endif + else + call MOM_error(NOTE, "MOM_restart: copy_restart_var(_3d) "//& + "attempted to copy uninitialized restart variable "//name//".") + endif + n = m ; exit + endif + enddo + if ((n==CS%novars+1) .and. (is_root_pe())) & + call MOM_error(NOTE, "MOM_restart: copy_restart_var(_3d) "//& + "attempted to copy unknown restart variable "//name//".") + +end subroutine copy_restart_var_3d + + +!> Copy the restart vector component variables with the specified names into a pair +!! of 3-d arrays, perhaps after rotation +subroutine copy_restart_vector_3d(u_var, v_var, u_name, v_name, CS, unrotate, scalar_pair) + real, dimension(:,:,:), intent(inout) :: u_var !< The u-component of the field that is being copied [arbitrary] + real, dimension(:,:,:), intent(inout) :: v_var !< The u-component of the field that is being copied [arbitrary] + character(len=*), intent(in) :: u_name !< The name of the u-component of the field that is being copied + character(len=*), intent(in) :: v_name !< The name of the v-component of the field that is being copied + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct + logical, optional, intent(in) :: unrotate !< If present and true, the output is on an unrotated grid. + logical, optional, intent(in) :: scalar_pair !< If true, the arrays describe a pair of + !! scalars, instead of vector components + !! whose signs change when rotated + + logical :: keep_rotation, scalars + character(len=256) :: size_msg !< The array sizes + integer :: m, n_u, n_v + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & + "query_initialized: Module must be initialized before it is used.") + + if (CS%novars > CS%max_fields) call restart_error(CS) + + keep_rotation = .true. ; if (present(unrotate)) keep_rotation = .not.unrotate + + n_u = CS%novars+1 ; n_v = CS%novars+1 + do m=1,CS%novars + if (trim(u_name) == CS%restart_field(m)%var_name) then + if (.not.associated(CS%var_ptr3d(m)%p)) then + call MOM_error(FATAL, "MOM_restart: copy_restart_vector(_3d) "//& + "attempted to copy restart variable "//trim(u_name)//" with the wrong rank.") + elseif (CS%restart_field(m)%initialized) then + n_u = m + else + call MOM_error(NOTE, "MOM_restart: copy_restart_vector(_3d) "//& + "attempted to copy uninitialized restart variable "//trim(u_name)//".") + n_u = -1 + endif + endif + if (trim(v_name) == CS%restart_field(m)%var_name) then + if (.not.associated(CS%var_ptr3d(m)%p)) then + call MOM_error(FATAL, "MOM_restart: copy_restart_vector(_3d) "//& + "attempted to copy restart variable "//trim(v_name)//" with the wrong rank.") + elseif (CS%restart_field(m)%initialized) then + n_v = m + else + call MOM_error(NOTE, "MOM_restart: copy_restart_vector(_3d) "//& + "attempted to copy uninitialized restart variable "//trim(v_name)//".") + n_v = -1 + endif + endif + enddo + if ((n_u==CS%novars+1) .and. (is_root_pe())) & + call MOM_error(NOTE, "MOM_restart: copy_restart_vector(_3d) "//& + "attempted to copy unknown restart variable "//trim(u_name)//".") + if ((n_v==CS%novars+1) .and. (is_root_pe())) & + call MOM_error(NOTE, "MOM_restart: copy_restart_vector(_3d) "//& + "attempted to copy unknown restart variable "//trim(v_name)//".") + + if ((n_u>0) .and. (n_u<=CS%novars) .and. (n_v>0) .and. (n_v<=CS%novars)) then + ! Now actually update the vector. + if ( size_mismatch_3d(u_var, CS%var_ptr3d(n_u)%p, CS%turns, size_msg) ) & + call MOM_error(FATAL, "MOM_restart: copy_restart_vector(_3d) "//& + "attempted to copy restart variable "//trim(u_name)//" with the wrong sizes, "//trim(size_msg)) + if ( size_mismatch_3d(v_var, CS%var_ptr3d(n_v)%p, CS%turns, size_msg) ) & + call MOM_error(FATAL, "MOM_restart: copy_restart_vector(_3d) "//& + "attempted to copy restart variable "//trim(v_name)//" with the wrong sizes, "//trim(size_msg)) + + if (CS%turns == 0 .or. keep_rotation) then + u_var(:,:,:) = CS%var_ptr3d(n_u)%p(:,:,:) + v_var(:,:,:) = CS%var_ptr3d(n_v)%p(:,:,:) + else + scalars = .false. ; if (present(scalar_pair)) scalars = scalar_pair + if ((modulo(CS%turns, 2) == 0) .and. scalars) then + call rotate_array_pair(CS%var_ptr3d(n_u)%p, CS%var_ptr3d(n_v)%p, -CS%turns, u_var, v_var) + elseif (modulo(CS%turns, 2) == 0) then + call rotate_vector(CS%var_ptr3d(n_u)%p, CS%var_ptr3d(n_v)%p, -CS%turns, u_var, v_var) + elseif (scalars) then ! This is less common + call rotate_array_pair(CS%var_ptr3d(n_v)%p, CS%var_ptr3d(n_u)%p, -CS%turns, u_var, v_var) + else + call rotate_vector(CS%var_ptr3d(n_v)%p, CS%var_ptr3d(n_u)%p, -CS%turns, u_var, v_var) + endif + endif + endif + +end subroutine copy_restart_vector_3d + +!> Indicate if two 3-d arrays are not of the same size after rotation is considered. +logical function size_mismatch_3d(var_a, var_b, turns, size_msg) + real, intent(in) :: var_a(:,:,:) !< The first field being compared + real, intent(in) :: var_b(:,:,:) !< The second field being compared + integer, intent(in) :: turns !< Number of quarter turns from input to model domain + character(len=256), intent(out) :: size_msg !< The array sizes + + if (modulo(turns, 2) == 0) then + size_mismatch_3d = ( (size(var_a,1) /= size(var_b,1)) .or. & + (size(var_a,2) /= size(var_b,2)) .or. & + (size(var_a,3) /= size(var_b,3)) ) + else + size_mismatch_3d = ( (size(var_a,1) /= size(var_b,2)) .or. & + (size(var_a,2) /= size(var_b,1)) .or. & + (size(var_a,3) /= size(var_b,3)) ) + endif + write(size_msg, '(3(1x,I0), " vs ", 3(1x,I0))') size(var_a,1), size(var_a,2), size(var_a,3), & + size(var_b,1), size(var_b,2), size(var_b,3) +end function size_mismatch_3d + + !> save_restart saves all registered variables to restart files. subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_rest_files, write_IC) character(len=*), intent(in) :: directory !< The directory where the restart files !! are to be written type(time_type), intent(in) :: time !< The current model time - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure as seen from the driver. type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct logical, optional, intent(in) :: time_stamped !< If present and true, add time-stamp !! to the restart file names @@ -890,39 +1584,47 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ ! Local variables type(vardesc) :: vars(CS%max_fields) ! Descriptions of the fields that ! are to be read from the restart file. - type(fieldtype) :: fields(CS%max_fields) ! Opaque types containing metadata describing + type(MOM_field) :: fields(CS%max_fields) ! Opaque types containing metadata describing ! each variable that will be written. character(len=512) :: restartpath ! The restart file path (dir/file). character(len=256) :: restartname ! The restart file name (no dir). character(len=8) :: suffix ! A suffix (like _2) that is appended ! to the name of files after the first. - integer(kind=8) :: var_sz, size_in_file ! The size in bytes of each variable + integer(kind=int64) :: var_sz, size_in_file ! The size in bytes of each variable ! and the variables already in a file. - integer(kind=8), parameter :: max_file_size = 4294967292_8 ! The maximum size in bytes for the + integer(kind=int64), parameter :: max_file_size = 4294967292_int64 ! The maximum size in bytes for the ! starting position of each variable in a file's record, ! based on the use of NetCDF 3.6 or later. For earlier - ! versions of NetCDF, the value was 2147483647_8. + ! versions of NetCDF, the value was 2147483647_int64. integer :: start_var, next_var ! The starting variables of the ! current and next files. - type(file_type) :: IO_handle ! The I/O handle of the open fileset - integer :: m, nz + type(MOM_infra_file) :: IO_handle ! The I/O handle of the open fileset + integer :: m, nz, na integer :: num_files ! The number of restart files that will be used. integer :: seconds, days, year, month, hour, minute - character(len=8) :: hor_grid, z_grid, t_grid ! Variable grid info. - character(len=64) :: var_name ! A variable's name. - real :: restart_time + character(len=8) :: z_grid, t_grid ! Variable grid info. + integer :: pos ! A coded integer indicating the horizontal staggering of a variable + real :: conv ! Shorthand for the conversion factor [a A-1 ~> 1] + real :: restart_time ! The model time at whic the restart file is being written [days] character(len=32) :: filename_appendix = '' ! Appendix to filename for ensemble runs integer :: length ! The length of a text string. - integer(kind=8) :: check_val(CS%max_fields,1) - integer :: isL, ieL, jsL, jeL, pos - integer :: turns + character(len=256) :: mesg, var_name + integer(kind=int64) :: check_val(CS%max_fields,1) + logical :: verbose + integer :: isL, ieL, jsL, jeL + integer :: turns ! Number of quarter turns from input to model domain + integer, parameter :: nmax_extradims = 5 + type(axis_info), dimension(:), allocatable :: extra_axes turns = CS%turns + allocate (extra_axes(nmax_extradims)) + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "save_restart: Module must be initialized before it is used.") if (CS%novars > CS%max_fields) call restart_error(CS) + verbose = (is_root_pe() .and. (MOM_get_verbosity() >= 7)) ! With parallel read & write, it is possible to disable the following... num_files = 0 @@ -950,15 +1652,32 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ restartname = trim(CS%restartfile)//trim(restartname) endif ; endif + ! Determine if there is a filename_appendix (used for ensemble runs). + call get_filename_appendix(filename_appendix) + if (len_trim(filename_appendix) > 0) then + length = len_trim(restartname) + if (restartname(length-2:length) == '.nc') then + restartname = restartname(1:length-3)//'.'//trim(filename_appendix)//'.nc' + else + restartname = restartname(1:length) //'.'//trim(filename_appendix) + endif + endif + next_var = 1 do while (next_var <= CS%novars ) start_var = next_var size_in_file = 8*(2*G%Domain%niglobal+2*G%Domain%njglobal+2*nz+1000) do m=start_var,CS%novars - call query_vardesc(CS%restart_field(m)%vars, hor_grid=hor_grid, & - z_grid=z_grid, t_grid=t_grid, caller="save_restart") - var_sz = get_variable_byte_size(hor_grid, z_grid, t_grid, G, nz) + call query_vardesc(CS%restart_field(m)%vars, position=pos, & + z_grid=z_grid, t_grid=t_grid, caller="save_restart", & + extra_axes=extra_axes) + + var_sz = get_variable_byte_size(pos, z_grid, t_grid, G, nz) + ! factor in size of extra axes, or multiply by 1 + do na=1,nmax_extradims + var_sz = var_sz*extra_axes(na)%ax_size + enddo if ((m==start_var) .OR. (size_in_file < max_file_size-var_sz)) then size_in_file = size_in_file + var_sz @@ -968,24 +1687,9 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ enddo next_var = m - ! Determine if there is a filename_appendix (used for ensemble runs). - call get_filename_appendix(filename_appendix) - if (len_trim(filename_appendix) > 0) then - length = len_trim(restartname) - if (restartname(length-2:length) == '.nc') then - restartname = restartname(1:length-3)//'.'//trim(filename_appendix)//'.nc' - else - restartname = restartname(1:length) //'.'//trim(filename_appendix) - endif - endif - restartpath = trim(directory) // trim(restartname) - if (num_files < 10) then - write(suffix,'("_",I1)') num_files - else - write(suffix,'("_",I2)') num_files - endif + write(suffix,'("_",I0)') num_files length = len_trim(restartpath) if (length < 3) then ! This case is very uncommon but this test avoids segmentation-faults. @@ -1001,69 +1705,82 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ do m=start_var,next_var-1 vars(m-start_var+1) = CS%restart_field(m)%vars enddo - call query_vardesc(vars(1), t_grid=t_grid, hor_grid=hor_grid, caller="save_restart") + call query_vardesc(vars(1), t_grid=t_grid, position=pos, caller="save_restart") t_grid = adjustl(t_grid) if (t_grid(1:1) /= 'p') & call modify_vardesc(vars(1), t_grid='s', caller="save_restart") - select case (hor_grid) - case ('q') ; pos = CORNER - case ('h') ; pos = CENTER - case ('u') ; pos = EAST_FACE - case ('v') ; pos = NORTH_FACE - case ('Bu') ; pos = CORNER - case ('T') ; pos = CENTER - case ('Cu') ; pos = EAST_FACE - case ('Cv') ; pos = NORTH_FACE - case ('1') ; pos = 0 - case default ; pos = 0 - end select !Prepare the checksum of the restart fields to be written to restart files - if (modulo(turns, 2) /= 0) then - call get_checksum_loop_ranges(G, pos, jsL, jeL, isL, ieL) - else - call get_checksum_loop_ranges(G, pos, isL, ieL, jsL, jeL) - endif do m=start_var,next_var-1 + + call query_vardesc(vars(m), position=pos, name=var_name, caller="save_restart") + if (modulo(turns, 2) == 0) then + call get_checksum_loop_ranges(G, CS, pos, isL, ieL, jsL, jeL) + else ! Note that G is always the unrotated grid as it is seen by the driver level. + call get_checksum_loop_ranges(G, CS, pos, jsL, jeL, isL, ieL) + endif + if (verbose) then + if (pos == CENTER) then + write(mesg, '(" is in CENTER position, checksum range",4(1x,I0))') isL, ieL, jsL, jeL + elseif (pos == CORNER) then + write(mesg, '(" is in CORNER position, checksum range",4(1x,I0))') isL, ieL, jsL, jeL + elseif (pos == NORTH_FACE) then + write(mesg, '(" is in NORTH_FACE position, checksum range",4(1x,I0))') isL, ieL, jsL, jeL + elseif (pos == EAST_FACE) then + write(mesg, '(" is in EAST_FACE position, checksum range",4(1x,I0))') isL, ieL, jsL, jeL + else + write(mesg, '(" is in another position, ",I0,", checksum range",4(1x,I0))') pos, isL, ieL, jsL, jeL + endif + call MOM_mesg(trim(var_name)//mesg) + endif + + conv = CS%restart_field(m)%conv if (associated(CS%var_ptr3d(m)%p)) then - check_val(m-start_var+1,1) = chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:), turns=-turns) + check_val(m-start_var+1,1) = chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:), turns=-turns, unscale=conv) elseif (associated(CS%var_ptr2d(m)%p)) then - check_val(m-start_var+1,1) = chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL), turns=-turns) + check_val(m-start_var+1,1) = chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL), turns=-turns, unscale=conv) elseif (associated(CS%var_ptr4d(m)%p)) then - check_val(m-start_var+1,1) = chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:), turns=-turns) + check_val(m-start_var+1,1) = chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:), turns=-turns, unscale=conv) elseif (associated(CS%var_ptr1d(m)%p)) then - check_val(m-start_var+1,1) = chksum(CS%var_ptr1d(m)%p) + check_val(m-start_var+1,1) = chksum(CS%var_ptr1d(m)%p(:), unscale=conv) elseif (associated(CS%var_ptr0d(m)%p)) then - check_val(m-start_var+1,1) = chksum(CS%var_ptr0d(m)%p, pelist=(/PE_here()/)) + check_val(m-start_var+1,1) = chksum(CS%var_ptr0d(m)%p, pelist=(/PE_here()/), unscale=conv) endif enddo if (CS%parallel_restartfiles) then - call create_file(IO_handle, trim(restartpath), vars, (next_var-start_var), & - fields, MULTIPLE, G=G, GV=GV, checksums=check_val) + call create_MOM_file(IO_handle, trim(restartpath), vars, next_var-start_var, & + fields, MULTIPLE, G=G, GV=GV, checksums=check_val, extra_axes=extra_axes) else - call create_file(IO_handle, trim(restartpath), vars, (next_var-start_var), & - fields, SINGLE_FILE, G=G, GV=GV, checksums=check_val) + call create_MOM_file(IO_handle, trim(restartpath), vars, next_var-start_var, & + fields, SINGLE_FILE, G=G, GV=GV, checksums=check_val, extra_axes=extra_axes) endif do m=start_var,next_var-1 if (associated(CS%var_ptr3d(m)%p)) then - call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, & - CS%var_ptr3d(m)%p, restart_time, turns=-turns) + call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, CS%var_ptr3d(m)%p, & + restart_time, unscale=CS%restart_field(m)%conv, turns=-turns, & + zero_zeros=CS%unsigned_zeros) elseif (associated(CS%var_ptr2d(m)%p)) then - call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, & - CS%var_ptr2d(m)%p, restart_time, turns=-turns) + call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, CS%var_ptr2d(m)%p, & + restart_time, unscale=CS%restart_field(m)%conv, turns=-turns, & + zero_zeros=CS%unsigned_zeros) elseif (associated(CS%var_ptr4d(m)%p)) then - call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, & - CS%var_ptr4d(m)%p, restart_time, turns=-turns) + call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, CS%var_ptr4d(m)%p, & + restart_time, unscale=CS%restart_field(m)%conv, turns=-turns, & + zero_zeros=CS%unsigned_zeros) elseif (associated(CS%var_ptr1d(m)%p)) then - call MOM_write_field(IO_handle, fields(m-start_var+1), CS%var_ptr1d(m)%p, restart_time) + call MOM_write_field(IO_handle, fields(m-start_var+1), CS%var_ptr1d(m)%p, & + restart_time, unscale=CS%restart_field(m)%conv, & + zero_zeros=CS%unsigned_zeros) elseif (associated(CS%var_ptr0d(m)%p)) then - call MOM_write_field(IO_handle, fields(m-start_var+1), CS%var_ptr0d(m)%p, restart_time) + call MOM_write_field(IO_handle, fields(m-start_var+1), CS%var_ptr0d(m)%p, & + restart_time, unscale=CS%restart_field(m)%conv, & + zero_zeros=CS%unsigned_zeros) endif enddo - call close_file(IO_handle) + call IO_handle%close() num_files = num_files+1 @@ -1085,30 +1802,27 @@ subroutine restore_state(filename, directory, day, G, CS) type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct ! Local variables - character(len=200) :: filepath ! The path (dir/file) to the file being opened. - character(len=80) :: fname ! The name of the current file. - character(len=8) :: suffix ! A suffix (like "_2") that is added to any - ! additional restart files. + real :: scale ! A scaling factor for reading a field [A a-1 ~> 1] to convert + ! from the units in the file to the internal units of this field + real :: conv ! The output conversion factor for writing a field [a A-1 ~> 1] character(len=512) :: mesg ! A message for warnings. character(len=80) :: varname ! A variable's name. integer :: num_file ! The number of files (restart files and others ! explicitly in filename) that are open. integer :: i, n, m, missing_fields - integer :: isL, ieL, jsL, jeL, is0, js0 - integer :: sizes(7) + integer :: isL, ieL, jsL, jeL integer :: nvar, ntime, pos - type(file_type) :: IO_handles(CS%max_fields) ! The I/O units of all open files. + type(MOM_infra_file) :: IO_handles(CS%max_fields) ! The I/O units of all open files. character(len=200) :: unit_path(CS%max_fields) ! The file names. logical :: unit_is_global(CS%max_fields) ! True if the file is global. - character(len=8) :: hor_grid ! Variable grid info. - real :: t1, t2 ! Two times. - real, allocatable :: time_vals(:) - type(fieldtype), allocatable :: fields(:) + real :: t1, t2 ! Two times from the start of different files [days]. + real, allocatable :: time_vals(:) ! Times from a file extracted with getl_file_times [days] + type(MOM_field), allocatable :: fields(:) logical :: is_there_a_checksum ! Is there a valid checksum that should be checked. - integer(kind=8) :: checksum_file ! The checksum value recorded in the input file. - integer(kind=8) :: checksum_data ! The checksum value for the data that was read in. + integer(kind=int64) :: checksum_file ! The checksum value recorded in the input file. + integer(kind=int64) :: checksum_data ! The checksum value for the data that was read in. if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "restore_state: Module must be initialized before it is used.") @@ -1132,7 +1846,7 @@ subroutine restore_state(filename, directory, day, G, CS) ! Get the time from the first file in the list that has one. do n=1,num_file - call get_file_times(IO_handles(n), time_vals, ntime) + call IO_handles(n)%get_file_times(time_vals, ntime) if (ntime < 1) cycle t1 = time_vals(1) @@ -1142,35 +1856,34 @@ subroutine restore_state(filename, directory, day, G, CS) exit enddo - if (n>num_file) call MOM_error(WARNING,"MOM_restart: " // & - "No times found in restart files.") + if (n>num_file) call MOM_error(WARNING, "MOM_restart: No times found in restart files.") ! Check the remaining files for different times and issue a warning ! if they differ from the first time. do m = n+1,num_file - call get_file_times(IO_handles(n), time_vals, ntime) + call IO_handles(n)%get_file_times(time_vals, ntime) if (ntime < 1) cycle t2 = time_vals(1) deallocate(time_vals) if (t1 /= t2 .and. is_root_PE()) then - write(mesg,'("WARNING: Restart file ",I2," has time ",F10.4,"whereas & - &simulation is restarted at ",F10.4," (differing by ",F10.4,").")')& - m,t1,t2,t1-t2 + write(mesg,'("WARNING: Restart file ",I0," has time ",F10.4,"whereas & + &simulation is restarted at ",F10.4," (differing by ",F10.4,").")') & + m, t1, t2, t1-t2 call MOM_error(WARNING, "MOM_restart: "//mesg) endif enddo ! Read each variable from the first file in which it is found. do n=1,num_file - call get_file_info(IO_handles(n), nvar=nvar) + call IO_handles(n)%get_file_info(nvar=nvar) allocate(fields(nvar)) - call get_file_fields(IO_handles(n), fields(1:nvar)) + call IO_handles(n)%get_file_fields(fields(1:nvar)) do m=1, nvar - call get_field_atts(fields(m), name=varname) + call IO_handles(n)%get_field_atts(fields(m), name=varname) do i=1,CS%num_obsolete_vars if (adjustl(lowercase(trim(varname))) == adjustl(lowercase(trim(CS%restart_obsolete(i)%field_name)))) then call MOM_error(FATAL, "MOM_restart restore_state: Attempting to use obsolete restart field "//& @@ -1184,28 +1897,21 @@ subroutine restore_state(filename, directory, day, G, CS) do m=1,CS%novars if (CS%restart_field(m)%initialized) cycle - call query_vardesc(CS%restart_field(m)%vars, hor_grid=hor_grid, & - caller="restore_state") - select case (hor_grid) - case ('q') ; pos = CORNER - case ('h') ; pos = CENTER - case ('u') ; pos = EAST_FACE - case ('v') ; pos = NORTH_FACE - case ('Bu') ; pos = CORNER - case ('T') ; pos = CENTER - case ('Cu') ; pos = EAST_FACE - case ('Cv') ; pos = NORTH_FACE - case ('1') ; pos = 0 - case default ; pos = 0 - end select - - call get_checksum_loop_ranges(G, pos, isL, ieL, jsL, jeL) + call query_vardesc(CS%restart_field(m)%vars, position=pos, caller="restore_state") + conv = CS%restart_field(m)%conv + if (conv == 0.0) then ; scale = 1.0 ; else ; scale = 1.0 / conv ; endif + + if (modulo(CS%turns, 2) == 0) then + call get_checksum_loop_ranges(G, CS, pos, isL, ieL, jsL, jeL) + else ! Note that G is always the unrotated grid as it is used during initialization. + call get_checksum_loop_ranges(G, CS, pos, jsL, jeL, isL, ieL) + endif do i=1, nvar - call get_field_atts(fields(i), name=varname) + call IO_handles(n)%get_field_atts(fields(i), name=varname) if (lowercase(trim(varname)) == lowercase(trim(CS%restart_field(m)%var_name))) then checksum_data = -1 if (CS%checksum_required) then - call read_field_chksum(fields(i), checksum_file, is_there_a_checksum) + call IO_handles(n)%read_field_chksum(fields(i), checksum_file, is_there_a_checksum) else checksum_file = -1 is_there_a_checksum = .false. ! Do not need to do data checksumming. @@ -1214,42 +1920,43 @@ subroutine restore_state(filename, directory, day, G, CS) if (associated(CS%var_ptr1d(m)%p)) then ! Read a 1d array, which should be invariant to domain decomposition. call MOM_read_data(unit_path(n), varname, CS%var_ptr1d(m)%p, & - timelevel=1, MOM_Domain=G%Domain) - if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr1d(m)%p) + timelevel=1, scale=scale, MOM_Domain=G%Domain) + if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr1d(m)%p(:), unscale=conv) elseif (associated(CS%var_ptr0d(m)%p)) then ! Read a scalar... call MOM_read_data(unit_path(n), varname, CS%var_ptr0d(m)%p, & - timelevel=1, MOM_Domain=G%Domain) - if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr0d(m)%p, pelist=(/PE_here()/)) + timelevel=1, scale=scale, MOM_Domain=G%Domain) + if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr0d(m)%p, pelist=(/PE_here()/), unscale=conv) elseif (associated(CS%var_ptr2d(m)%p)) then ! Read a 2d array. if (pos /= 0) then call MOM_read_data(unit_path(n), varname, CS%var_ptr2d(m)%p, & - G%Domain, timelevel=1, position=pos) + G%Domain, timelevel=1, position=pos, scale=scale, turns=CS%turns) else ! This array is not domain-decomposed. This variant may be under-tested. call MOM_error(FATAL, & "MOM_restart does not support 2-d arrays without domain decomposition.") ! call read_data(unit_path(n), varname, CS%var_ptr2d(m)%p,no_domain=.true., timelevel=1) endif - if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL)) + if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL), unscale=conv) elseif (associated(CS%var_ptr3d(m)%p)) then ! Read a 3d array. if (pos /= 0) then call MOM_read_data(unit_path(n), varname, CS%var_ptr3d(m)%p, & - G%Domain, timelevel=1, position=pos) + G%Domain, timelevel=1, position=pos, scale=scale, turns=CS%turns) else ! This array is not domain-decomposed. This variant may be under-tested. call MOM_error(FATAL, & "MOM_restart does not support 3-d arrays without domain decomposition.") ! call read_data(unit_path(n), varname, CS%var_ptr3d(m)%p, no_domain=.true., timelevel=1) endif - if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:)) + if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:), unscale=conv) elseif (associated(CS%var_ptr4d(m)%p)) then ! Read a 4d array. if (pos /= 0) then call MOM_read_data(unit_path(n), varname, CS%var_ptr4d(m)%p, & - G%Domain, timelevel=1, position=pos) + G%Domain, timelevel=1, position=pos, scale=scale, & + global_file=unit_is_global(n), turns=CS%turns) else ! This array is not domain-decomposed. This variant may be under-tested. call MOM_error(FATAL, & "MOM_restart does not support 4-d arrays without domain decomposition.") ! call read_data(unit_path(n), varname, CS%var_ptr4d(m)%p, no_domain=.true., timelevel=1) endif - if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:)) + if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:), unscale=conv) else call MOM_error(FATAL, "MOM_restart restore_state: No pointers set for "//trim(varname)) endif @@ -1273,7 +1980,7 @@ subroutine restore_state(filename, directory, day, G, CS) enddo do n=1,num_file - call close_file(IO_handles(n)) + call IO_handles(n)%close() enddo ! Check whether any mandatory fields have not been found. @@ -1293,6 +2000,8 @@ subroutine restore_state(filename, directory, day, G, CS) end subroutine restore_state + + !> restart_files_exist determines whether any restart files exist. function restart_files_exist(filename, directory, G, CS) character(len=*), intent(in) :: filename !< The list of restart file names or a single @@ -1375,7 +2084,7 @@ function open_restart_units(filename, directory, G, CS, IO_handles, file_paths, type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct - type(file_type), dimension(:), & + type(MOM_infra_file), dimension(:), & optional, intent(out) :: IO_handles !< The I/O handles of all opened files character(len=*), dimension(:), & optional, intent(out) :: file_paths !< The full paths to open files @@ -1437,11 +2146,7 @@ function open_restart_units(filename, directory, G, CS, IO_handles, file_paths, endif filepath = trim(directory) // trim(restartname) - if (num_restart < 10) then - write(suffix,'("_",I1)') num_restart - else - write(suffix,'("_",I2)') num_restart - endif + write(suffix,'("_",I0)') num_restart if (num_restart > 0) filepath = trim(filepath) // suffix filepath = trim(filepath)//".nc" @@ -1452,8 +2157,8 @@ function open_restart_units(filename, directory, G, CS, IO_handles, file_paths, if (fexists) then nf = nf + 1 if (present(IO_handles)) & - call open_file(IO_handles(nf), trim(filepath), READONLY_FILE, & - threading=MULTIPLE, fileset=SINGLE_FILE) + call IO_handles(nf)%open(trim(filepath), READONLY_FILE, & + MOM_domain=G%Domain, threading=MULTIPLE, fileset=SINGLE_FILE) if (present(global_files)) global_files(nf) = .true. if (present(file_paths)) file_paths(nf) = filepath elseif (CS%parallel_restartfiles) then @@ -1462,7 +2167,7 @@ function open_restart_units(filename, directory, G, CS, IO_handles, file_paths, if (fexists) then nf = nf + 1 if (present(IO_handles)) & - call open_file(IO_handles(nf), trim(filepath), READONLY_FILE, MOM_domain=G%Domain) + call IO_handles(nf)%open(trim(filepath), READONLY_FILE, MOM_domain=G%Domain) if (present(global_files)) global_files(nf) = .false. if (present(file_paths)) file_paths(nf) = filepath endif @@ -1484,15 +2189,15 @@ function open_restart_units(filename, directory, G, CS, IO_handles, file_paths, if (fexists) then nf = nf + 1 if (present(IO_handles)) & - call open_file(IO_handles(nf), trim(filepath), READONLY_FILE, & - threading=MULTIPLE, fileset=SINGLE_FILE) + call IO_handles(nf)%open(trim(filepath), READONLY_FILE, & + MOM_Domain=G%Domain, threading=MULTIPLE, fileset=SINGLE_FILE) if (present(global_files)) global_files(nf) = .true. if (present(file_paths)) file_paths(nf) = filepath if (is_root_pe() .and. (present(IO_handles))) & - call MOM_error(NOTE,"MOM_restart: MOM run restarted using : "//trim(filepath)) + call MOM_error(NOTE, "MOM_restart: MOM run restarted using : "//trim(filepath)) else if (present(IO_handles)) & - call MOM_error(WARNING,"MOM_restart: Unable to find restart file : "//trim(filepath)) + call MOM_error(WARNING, "MOM_restart: Unable to find restart file : "//trim(filepath)) endif endif @@ -1556,8 +2261,12 @@ subroutine restart_init(param_file, CS, restart_root) call get_param(param_file, mdl, "MAX_FIELDS", CS%max_fields, default=100, do_not_log=.true.) call get_param(param_file, mdl, "RESTART_CHECKSUMS_REQUIRED", CS%checksum_required, & default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "RESTART_SYMMETRIC_CHECKSUMS", CS%symmetric_checksums, & + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "RESTART_UNSIGNED_ZEROS", CS%unsigned_zeros, & + default=.false., do_not_log=.true.) all_default = ((.not.CS%parallel_restartfiles) .and. (CS%max_fields == 100) .and. & - (CS%checksum_required)) + (CS%checksum_required) .and. (.not.CS%symmetric_checksums) .and. (.not.CS%unsigned_zeros)) if (.not.present(restart_root)) then call get_param(param_file, mdl, "RESTARTFILE", CS%restartfile, & default="MOM.res", do_not_log=.true.) @@ -1588,6 +2297,19 @@ subroutine restart_init(param_file, CS, restart_root) "made from a run with a different mask_table than the current run, "//& "in which case the checksums will not match and cause crash.",& default=.true.) + call get_param(param_file, mdl, "RESTART_SYMMETRIC_CHECKSUMS", CS%symmetric_checksums, & + "If true, do the restart checksums on all the edge points for a non-reentrant "//& + "grid. This requires that SYMMETRIC_MEMORY_ is defined at compile time.", & + default=.false.) + call get_param(param_file, mdl, "RESTART_UNSIGNED_ZEROS", CS%unsigned_zeros, & + "If true, convert any negative zeros that would be written to the restart file "//& + "into ordinary unsigned zeros. This does not change answers, but it can be "//& + "helpful in comparing restart files after grid rotation, for example.", & + default=.false.) + call get_param(param_file, mdl, "REENTRANT_X", CS%reentrant_x, & + "If true, the domain is zonally reentrant.", default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "REENTRANT_Y", CS%reentrant_y, & + "If true, the domain is meridionally reentrant.", default=.false., do_not_log=.true.) ! Maybe not the best place to do this? call get_param(param_file, mdl, "ROTATE_INDEX", rotate_index, & @@ -1676,17 +2398,18 @@ subroutine restart_error(CS) if (CS%novars > CS%max_fields) then write(num,'(I0)') CS%novars call MOM_error(FATAL,"MOM_restart: Too many fields registered for " // & - "restart. Set MAX_FIELDS to be at least " // & - trim(adjustl(num)) // " in the MOM input file.") + "restart. Set MAX_FIELDS to be at least "//trim(num)//" in the MOM input file.") else call MOM_error(FATAL,"MOM_restart: Unspecified fatal error.") endif end subroutine restart_error !> Return bounds for computing checksums to store in restart files -subroutine get_checksum_loop_ranges(G, pos, isL, ieL, jsL, jeL) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - integer, intent(in) :: pos !< An integer indicating staggering of variable +subroutine get_checksum_loop_ranges(G, CS, pos, isL, ieL, jsL, jeL) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(MOM_restart_CS), intent(in) :: CS !< MOM restart control structure + integer, intent(in) :: pos !< A coded integer indicating the horizontal staggering + !! of a variable integer, intent(out) :: isL !< i-start for checksum integer, intent(out) :: ieL !< i-end for checksum integer, intent(out) :: jsL !< j-start for checksum @@ -1699,31 +2422,35 @@ subroutine get_checksum_loop_ranges(G, pos, isL, ieL, jsL, jeL) jeL = G%jec-G%jsd+1 ! Expand range east or south for symmetric arrays - if (G%symmetric) then - if ((pos == EAST_FACE) .or. (pos == CORNER)) then ! For u-, q-points only - if (G%idg_offset == 0) isL = isL - 1 ! include western edge in checksums only for western PEs + if (CS%symmetric_checksums) then + if (.not.G%symmetric) call MOM_error(FATAL, & + "Setting SYMMETRIC_RESTART_CHECKSUMS to true only works with symmetric memory allocation, "//& + "which is specified at compile time by defining the cpp macro SYMMETRIC_MEMORY_.") + + if (((pos == EAST_FACE) .or. (pos == CORNER)) .and. (.not.CS%reentrant_x)) then ! For u-, q-points only + if (G%isc+G%idg_offset == 1) isL = isL - 1 ! Include western edge in checksums only for western PEs endif - if ((pos == NORTH_FACE) .or. (pos == CORNER)) then ! For v-, q-points only - if (G%jdg_offset == 0) jsL = jsL - 1 ! include western edge in checksums only for southern PEs + if (((pos == NORTH_FACE) .or. (pos == CORNER)) .and. (.not.CS%reentrant_y)) then ! For v-, q-points only + if (G%jsc+G%jdg_offset == 1) jsL = jsL - 1 ! Include southern edge in checksums only for southern PEs endif endif end subroutine get_checksum_loop_ranges !> get the size of a variable in bytes -function get_variable_byte_size(hor_grid, z_grid, t_grid, G, num_z) result(var_sz) - character(len=8), intent(in) :: hor_grid !< The horizontal grid string to interpret +function get_variable_byte_size(pos, z_grid, t_grid, G, num_z) result(var_sz) + integer, intent(in) :: pos !< An integer indicating the horizontal staggering position character(len=8), intent(in) :: z_grid !< The vertical grid string to interpret character(len=8), intent(in) :: t_grid !< A time string to interpret type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure integer, intent(in) :: num_z !< The number of vertical layers in the grid - integer(kind=8) :: var_sz !< The function result, the size in bytes of a variable + integer(kind=int64) :: var_sz !< The function result, the size in bytes of a variable ! Local variables integer :: var_periods ! The number of entries in a time-periodic axis character(len=8) :: t_grid_read, t_grid_tmp ! Modified versions of t_grid - if (trim(hor_grid) == '1') then + if (pos == 0) then var_sz = 8 else ! This may be an overestimate, as it is based on symmetric-memory corner points. var_sz = 8*(G%Domain%niglobal+1)*(G%Domain%njglobal+1) diff --git a/src/framework/MOM_safe_alloc.F90 b/src/framework/MOM_safe_alloc.F90 index 8960e8e358..3b5b2b397e 100644 --- a/src/framework/MOM_safe_alloc.F90 +++ b/src/framework/MOM_safe_alloc.F90 @@ -1,9 +1,11 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Convenience functions for safely allocating memory without !! accidentally reallocating pointer and causing memory leaks. module MOM_safe_alloc -! This file is part of MOM6. See LICENSE.md for the license. - implicit none ; private public safe_alloc_ptr, safe_alloc_alloc diff --git a/src/framework/MOM_string_functions.F90 b/src/framework/MOM_string_functions.F90 index ddc1b41290..d890104c23 100644 --- a/src/framework/MOM_string_functions.F90 +++ b/src/framework/MOM_string_functions.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Handy functions for manipulating strings module MOM_string_functions -! This file is part of MOM6. See LICENSE.md for the license. - use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit implicit none ; private @@ -17,7 +19,8 @@ module MOM_string_functions public extract_real public remove_spaces public slasher -public append_substring +public trim_trailing_commas +public ints_to_string contains @@ -87,7 +90,7 @@ end function left_ints !> Returns a left-justified string with a real formatted like '(G)' function left_real(val) - real, intent(in) :: val !< The real variable to convert to a string + real, intent(in) :: val !< The real variable to convert to a string, in arbitrary units [A] character(len=32) :: left_real !< The output string integer :: l, ind @@ -140,7 +143,7 @@ end function left_real !> Returns a character string of a comma-separated, compact formatted, reals !! e.g. "1., 2., 5*3., 5.E2" function left_reals(r,sep) - real, intent(in) :: r(:) !< The array of real variables to convert to a string + real, intent(in) :: r(:) !< The array of real variables to convert to a string, in arbitrary units [A] character(len=*), optional, intent(in) :: sep !< The separator between !! successive values, by default it is ', '. character(len=:), allocatable :: left_reals !< The output string @@ -180,10 +183,10 @@ end function left_reals !> Returns True if the string can be read/parsed to give the exact value of "val" function isFormattedFloatEqualTo(str, val) character(len=*), intent(in) :: str !< The string to parse - real, intent(in) :: val !< The real value to compare with + real, intent(in) :: val !< The real value to compare with, in arbitrary units [A] logical :: isFormattedFloatEqualTo ! Local variables - real :: scannedVal + real :: scannedVal ! The value extraced from str, in arbitrary units [A] isFormattedFloatEqualTo=.false. read(str(1:),*,err=987) scannedVal @@ -215,7 +218,7 @@ end function extractWord extract_word = '' lastCharIsSeperator = .true. ns = len_trim(string) - i = 0; b=0; e=0; nw=0 + i = 0 ; b=0 ; e=0 ; nw=0 do while (i Returns the real corresponding to the nth word in the argument. +!> Returns the real corresponding to the nth word in the argument, in arbitrary units [A]. real function extract_real(string, separators, n, missing_value) character(len=*), intent(in) :: string !< String to scan character(len=*), intent(in) :: separators !< Characters to use for delineation integer, intent(in) :: n !< Number of word to extract - real, optional, intent(in) :: missing_value !< Value to assign if word is missing + real, optional, intent(in) :: missing_value !< Value to assign if word is missing, in arbitrary units [A] ! Local variables - integer :: ns, i, b, e, nw character(len=20) :: word word = extract_word(string, separators, n) @@ -297,7 +298,7 @@ end function extract_real logical :: lastCharIsSeperator lastCharIsSeperator = .true. ns = len_trim(string) - i = 0; o = 0 + i = 0 ; o = 0 do while (i True if r1 is not equal to r2. False otherwise. logical function localTestR(verbose,r1,r2) logical, intent(in) :: verbose !< If true, write results to stdout - real, intent(in) :: r1 !< Float - real, intent(in) :: r2 !< Float + real, intent(in) :: r1 !< The first value to compare, in arbitrary units [A] + real, intent(in) :: r2 !< The first value to compare, in arbitrary units [A] localTestR=.false. if (r1/=r2) localTestR=.true. if (localTestR .or. verbose) then @@ -419,33 +425,48 @@ function slasher(dir) endif end function slasher -!> append a string (substring) to another string (string_in) and return the -!! concatenated string (string_out) -function append_substring(string_in, substring) result(string_out) - character(len=*), intent(in) :: string_in !< input string - character(len=*), intent(in) :: substring !< string to append string_in - ! local - character(len=1024) :: string_out - character(len=1024) :: string_joined - integer :: string_in_length - integer :: substring_length - - string_out = '' - string_joined = '' - string_in_length = 0 - substring_length = 0 - - string_in_length = len_trim(string_in) - substring_length = len_trim(substring) - - if (string_in_length > 0) then - if (substring_length > 0) then - string_joined = trim(string_in)//trim(substring) - string_out(1:len_trim(string_joined)) = trim(string_joined) - endif - endif - -end function append_substring +!> Returns a left-adjusted string with trailing blanks and commas removed. +function trim_trailing_commas(in_str) result(out_str) + character(len=*), intent(in) :: in_str !< A string that is to be left adjusted and have + !! its trailing commas and white space removed. + character(len=len(in_str)) :: out_str !< A left-adjusted version of in_str with + !! trailing commas and white space removed + + out_str = trim(adjustl(in_str)) + if (len_trim(out_str) > 0) then + if (out_str(len_trim(out_str):len_trim(out_str)) == ",") then + out_str = out_str(1:len_trim(out_str) - 1) + endif + out_str = trim(out_str) + endif + +end function trim_trailing_commas + +!> Convert the first n elements (3 by default) of an integer array into an underscore delimited string. +function ints_to_string(a, n) result(i2s) + integer, dimension(:), intent(in) :: a !< The array of integers to translate + integer, optional , intent(in) :: n !< The number of elements to translate, by default the lesser + !! of 3 or all of the integers + character(len=5*size(a)+1) :: i2s !< The returned underscore delimited string of integers + + character(len=8) :: i2s_temp + integer :: i, n_max + + n_max = 3 + if (present(n)) n_max = n + + i2s = '' + do i=1,min(size(a), n_max) + if (a(i) < 0) then + write (i2s_temp, '(I5.4)') a(i) + else + write (i2s_temp, '(I4.4)') a(i) + endif + i2s = trim(i2s) //'_'// trim(i2s_temp) + enddo + i2s = adjustl(i2s) +end function ints_to_string + !> \namespace mom_string_functions !! diff --git a/src/framework/MOM_unique_scales.F90 b/src/framework/MOM_unique_scales.F90 new file mode 100644 index 0000000000..e61a339c8b --- /dev/null +++ b/src/framework/MOM_unique_scales.F90 @@ -0,0 +1,357 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> This module provides tools that can be used to check the uniqueness of the dimensional +!! scaling factors used by the MOM6 ocean model or other models +module MOM_unique_scales + +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, assert, MOM_get_verbosity + +implicit none ; private + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +public check_scaling_uniqueness, scales_to_powers + +contains + +!> This subroutine does a checks whether the provided dimensional scaling factors give a unique +!! overall scaling for each of the combinations of units in description, and suggests a better +!! combination if it is not unique. However, this subroutine does nothing if the verbosity level +!! for this run is below 3. +subroutine check_scaling_uniqueness(component, descs, weights, key, scales, max_powers) + character(len=*), intent(in) :: component !< The name of the component (e.g., MOM6) to use in messages + character(len=*), intent(in) :: descs(:) !< The descriptions for each combination of units + integer, intent(in) :: weights(:) !< A list of the weights for each described combination + character(len=*), intent(in) :: key(:) !< The key for the unit scaling + integer, intent(in) :: scales(:) !< The powers of 2 that give the scaling for each unit in key + integer, optional, intent(in) :: max_powers !< The maximum range of powers of 2 to search for + !! suggestions of better scaling factors, or 0 to avoid + !! suggesting improved factors. + + ! Local variables + integer, dimension(size(key)) :: next_scales, prev_scales, better_scales + character(len=512) :: mesg + character(len=64) :: msg_frag + integer, dimension(size(key), size(weights)) :: list + integer :: verbosity + logical :: same_key + integer :: orig_cost, test_cost, better_cost, prev_cost ! Various squared-weight mismatch costs. + integer :: better_dp ! The absolute change in powers with the better estimate. + integer :: ndims, ns, m, n, i, p, itt, max_itt, max_pow + + call assert((size(scales) == size(key)), "check_scaling_factors: Mismatched scales and key sizes.") + call assert((size(descs) == size(weights)), "check_scaling_factors: Mismatched descs and weights.") + + verbosity = MOM_get_verbosity() + ! Skip the rest of this routine if it would not write anything out. + if (verbosity < 3) return + + ndims = size(key) + ns = size(weights) + max_pow = 0 ; if (present(max_powers)) max_pow = max_powers + + list(:,:) = 0 + do n=1,ns + call encode_dim_powers(descs(n), key, list(:,n)) + enddo + + if (verbosity >= 7) then + write(mesg, '(I0)') ns + call MOM_mesg(trim(component)//": Extracted "//trim(mesg)//" unit combinations from the list.") + mesg = "Dim Key: [" + do i=1,ndims ; mesg = trim(mesg)//" "//trim(key(i)) ; enddo + mesg = trim(mesg)//"]:" + call MOM_mesg(mesg) + do n=1,ns + call MOM_mesg(trim(component)//": Extracted ["//trim(int_array_msg(list(:,n)))//"] from "//trim(descs(n))) + enddo + + do n=1,ns ; do m=1,n-1 + same_key = .true. + do i=1,ndims ; if (list(i,n) /= list(i,m)) same_key = .false. ; enddo + if (same_key) then + call MOM_mesg(trim(component)//": The same powers occur for "//& + trim(descs(n))//" and "//trim(descs(m))//"." ) + endif + enddo ; enddo + endif + + orig_cost = non_unique_scales(scales, list, descs, weights, silent=(verbosity<4)) + + max_itt = 3*ndims ! Do up to 3 iterations for each rescalable dimension. + if (orig_cost /= 0) then + call MOM_mesg(trim(component)//": The dimensional scaling factors are not unique.") + prev_cost = orig_cost + prev_scales(:) = scales(:) + do itt=1,max_itt + ! Iterate to find a better solution. + better_scales(:) = prev_scales(:) + better_cost = prev_cost + better_dp = 0 + do i=1,ndims + if (scales(i) == 0) cycle ! DO not optimize unscaled dimensions. + next_scales(:) = prev_scales(:) + do p=-max_pow,max_pow + if ((p==0) .or. (p==prev_scales(i))) cycle + next_scales(i) = p + test_cost = non_unique_scales(next_scales, list, descs, weights, silent=.true.) + if ((test_cost < better_cost) .or. & + ((test_cost == better_cost) .and. (abs(p-prev_scales(i)) < better_dp))) then + ! This is a better scaling or has the same weighted mismatches but smaller + ! changes in rescaling factors, so it could be the next guess. + better_scales(:) = next_scales(:) + better_cost = test_cost + better_dp = abs(p - prev_scales(i)) + endif + enddo + enddo + if (better_cost < prev_cost) then + ! Store the new best guess and try again. + prev_scales(:) = better_scales(:) + prev_cost = better_cost + else ! No further optimization is possible. + exit + endif + if (better_cost == 0) exit + if (verbosity >= 7) then + write(mesg, '("Iteration ",I0," scaling cost reduced from ",I0," with original scales to ", I0)') & + itt, orig_cost, better_cost + call MOM_mesg(trim(component)//": "//trim(mesg)//" with revised scaling factors.") + endif + enddo + if (prev_cost < orig_cost) then + test_cost = non_unique_scales(prev_scales, list, descs, weights, silent=(verbosity<4)) + mesg = trim(component)//": Suggested improved scales: " + do i=1,ndims ; if ((prev_scales(i) /= scales(i)) .and. (scales(i) /= 0)) then + write(msg_frag, '(I0)') prev_scales(i) + mesg = trim(mesg)//" "//trim(key(i))//"_RESCALE_POWER = "//trim(msg_frag) + endif ; enddo + call MOM_mesg(mesg) + + write(mesg, '(I0)') orig_cost + write(msg_frag, '(I0)') test_cost + mesg = trim(component)//": Scaling overlaps reduced from "//trim(mesg)//& + " with original scales to "//trim(msg_frag)//" with suggested scales." + call MOM_mesg(mesg) + endif + + endif + +end subroutine check_scaling_uniqueness + +!> Convert a unit scaling descriptor into an array of the dimensions of powers given in the key +subroutine encode_dim_powers(scaling, key, dim_powers) + + character(len=*), intent(in) :: scaling !< The unit description that will be converted + character(len=*), dimension(:), intent(in) :: key(:) !< The key for the unit scaling + integer, dimension(size(key)), intent(out) :: dim_powers !< The dimensions in scaling of each + !! element of they key. + + ! Local variables + character(len=:), allocatable :: actstr ! The full active remaining string to be parsed. + character(len=:), allocatable :: fragment ! The space-delimited fragment being parsed. + character(len=:), allocatable :: dimnm ! The probable dimension name + character(len=11) :: numbers ! The list of characters that could make up the exponent. + ! character(len=128) :: mesg + integer :: istart, iend, ieq, ief, ipow ! Positions in strings. + integer :: dp ! The power for this dimension. + integer :: ndim ! The number of dimensional scaling factors to consider. + integer :: n + + dim_powers(:) = 0 + + iend = index(scaling, "~>") - 1 + if (iend < 1) return + + ! Parse the key. + ndim = size(key) + numbers = "-0123456789" + + ! Strip away any leading square brace. + istart = index(scaling(:iend), "[") + 1 + ! If there is an "=" in the string, start after this. + ieq = index(scaling(istart:iend), "=", back=.true.) + if (ieq > 0) istart = istart + ieq + + ! Set up the active string to work on. + actstr = trim(adjustl(scaling(istart:iend))) + do ! Loop over each of the elements in the unit scaling descriptor. + if (len_trim(actstr) == 0) exit + ief = index(actstr, " ") - 1 + if (ief <= 0) ief = len_trim(actstr) + fragment = actstr(:ief) + ipow = scan(fragment, "-") + if (ipow == 0) ipow = scan(fragment, numbers) + + if (ipow == 0) then ! There is no exponent + dimnm = fragment + dp = 1 + ! call MOM_mesg("Parsing powerless fragment "//trim(fragment)//" from "//trim(scaling)) + else + if (verify(fragment(ipow:), numbers) == 0) then + read(fragment(ipow:),*) dp + dimnm = fragment(:ipow-1) + ! write(mesg, '(I0)') dp + ! call MOM_mesg("Parsed fragment "//trim(fragment)//" from "//trim(scaling)//& + ! " as "//trim(dimnm)//trim(mesg)) + else + dimnm = fragment + dp = 1 + ! call MOM_mesg("Unparsed fragment "//trim(fragment)//" from "//trim(scaling)) + endif + endif + + do n=1,ndim + if (trim(dimnm) == trim(key(n))) then + dim_powers(n) = dim_powers(n) + dp + exit + endif + enddo + + ! Remove the leading fragment that has been parsed from actstr + actstr = trim(adjustl(actstr(ief+1:))) + enddo + +end subroutine encode_dim_powers + +!> Find the integer power of two that describe each of the scaling factors, or return 0 for +!! scaling factors that are not exceptionally close to an integer power of 2. +subroutine scales_to_powers(scale, pow2) + real, intent(in) :: scale(:) !< The scaling factor for each dimension + integer, intent(out) :: pow2(:) !< The exact powers of 2 for each scale, or 0 for non-exact powers of 2. + + real :: log2_sc ! The log base 2 of an element of scale + integer :: n, ndim + + ndim = size(scale) + + ! Find the integer power of two for the scaling factors, but skip the analysis of any factors + ! that are not close enough to being integer powers of 2. + do n=1,ndim + if (abs(scale(n)) > 0.0) then + log2_sc = log(abs(scale(n))) / log(2.0) + else + log2_sc = 0.0 + endif + if (abs(log2_sc - nint(log2_sc)) < 1.0e-6) then + ! This is close to an integer power of two. + pow2(n) = nint(log2_sc) + else + ! This is not being scaled by an integer power of 2, so return 0. + pow2(n) = 0 + endif + enddo + +end subroutine scales_to_powers + +!> Determine from the list of scaling factors and the unit combinations that are in use whether +!! all these combinations scale uniquely. +integer function non_unique_scales(scales, list, descs, weights, silent) + integer, intent(in) :: scales(:) !< The power of 2 that gives the scaling factor for each dimension + integer, intent(in) :: list(:,:) !< A list of the integers for each scaling + character(len=*), intent(in) :: descs(:) !< The unit descriptions that have been converted + integer, intent(in) :: weights(:) !< A list of the weights for each scaling + logical, optional, intent(in) :: silent !< If present and true, do not write any output. + + ! Local variables + integer, dimension(size(weights)) :: res_pow ! The net rescaling power for each combination. + integer, dimension(size(weights)) :: wt_merge ! The merged weights of scaling factors with common powers + ! for the dimensions being tested. + logical :: same_key, same_scales, verbose + character(len=256) :: mesg + integer :: nonzero_count ! The number of non-zero scaling factors + integer :: ndim ! The number of dimensional scaling factors to work with + integer :: i, n, m, ns + + non_unique_scales = -9999 ! Set return value to a _dummy_ value + + verbose = .true. ; if (present(silent)) verbose = .not.silent + + ndim = size(scales) + ns = size(descs) + call assert((size(scales) == size(list, 1)), "non_unique_scales: Mismatched scales and list sizes.") + call assert((size(descs) == size(list, 2)), "non_unique_scales: Mismatched descs and list sizes.") + call assert((size(descs) == size(weights)), "non_unique_scales: Mismatched descs and weights.") + + ! Return .true. if all scaling powers are 0, or there is only one scaling factor in use. + nonzero_count = 0 ; do n=1,ndim ; if (scales(n) /= 0) nonzero_count = nonzero_count + 1 ; enddo + if (nonzero_count <= 1) return + + ! Figure out which unit combinations are unique for the set of dimensions and scaling factors + ! that are being tested, and combine the weights for scaling factors. + wt_merge(:) = weights(:) + do n=1,ns ; do m=1,n-1 + same_key = .true. + same_scales = .true. + do i=1,ndim + if (list(i,n) /= list(i,m)) same_key = .false. + if ((scales(i) /= 0) .and. (list(i,n) /= list(i,m))) same_scales = .false. + enddo + if (same_key .or. same_scales) then + if (wt_merge(n) > wt_merge(m)) then + wt_merge(n) = wt_merge(n) + wt_merge(m) + wt_merge(m) = 0 + else + wt_merge(m) = wt_merge(m) + wt_merge(n) + wt_merge(n) = 0 + endif + endif + if (wt_merge(n) == 0) exit ! Go to the next value of n. + enddo ; enddo + + do n=1,ns + res_pow(n) = 0 + do i=1,ndim + res_pow(n) = res_pow(n) + scales(i) * list(i,n) + enddo + enddo + + ! Determine the weighted cost of non-unique scaling factors. + non_unique_scales = 0 + do n=1,ns ; if (wt_merge(n) > 0) then ; do m=1,n-1 ; if (wt_merge(m) > 0) then + if (res_pow(n) == res_pow(m)) then + ! Use the product of the weights as the cost, as this should be vaguely proportional to + ! the likelihood that these factors would be combined in an expression. + non_unique_scales = min(non_unique_scales + wt_merge(n) * wt_merge(m), 99999999) + if (verbose) then + write(mesg, '(I0)') res_pow(n) + call MOM_mesg("The factors "//trim(descs(n))//" and "//trim(descs(m))//" both scale to "//& + trim(mesg)//" for the given powers.") + + ! call MOM_mesg("Powers ["//trim(int_array_msg(list(:,n)))//"] and ["//& + ! trim(int_array_msg(list(:,m)))//"] with rescaling by ["//& + ! trim(int_array_msg(scales))//"]") + endif + endif + endif ; enddo ; endif ; enddo + +end function non_unique_scales + +!> Return a string the elements of an array of integers +function int_array_msg(array) + integer, intent(in) :: array(:) !< The array whose values are to be written. + character(len=16*size(array)) :: int_array_msg + + character(len=12) :: msg_frag + integer :: i, ni + ni = size(array) + + int_array_msg = "" + if (ni < 1) return + + do i=1,ni + write(msg_frag, '(I0)') array(i) + if (i == 1) then + int_array_msg = trim(msg_frag) + else + int_array_msg = trim(int_array_msg)//" "//trim(msg_frag) + endif + enddo +end function int_array_msg + +end module MOM_unique_scales diff --git a/src/framework/MOM_unit_scaling.F90 b/src/framework/MOM_unit_scaling.F90 index cd339f410c..96814d3220 100644 --- a/src/framework/MOM_unit_scaling.F90 +++ b/src/framework/MOM_unit_scaling.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Provides a transparent unit rescaling type to facilitate dimensional consistency testing module MOM_unit_scaling -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL use MOM_file_parser, only : get_param, log_param, log_version, param_file_type @@ -30,6 +32,10 @@ module MOM_unit_scaling real :: kg_m3_to_R !< A constant that translates kilograms per meter cubed to the units of density [R m3 kg-1 ~> 1] real :: Q_to_J_kg !< A constant that translates the units of enthalpy to Joules per kilogram [J kg-1 Q-1 ~> 1] real :: J_kg_to_Q !< A constant that translates Joules per kilogram to the units of enthalpy [Q kg J-1 ~> 1] + real :: C_to_degC !< A constant that translates the units of temperature to degrees Celsius [degC C-1 ~> 1] + real :: degC_to_C !< A constant that translates degrees Celsius to the units of temperature [C degC-1 ~> 1] + real :: S_to_ppt !< A constant that translates the units of salinity to parts per thousand [ppt S-1 ~> 1] + real :: ppt_to_S !< A constant that translates parts per thousand to the units of salinity [S ppt-1 ~> 1] ! These are useful combinations of the fundamental scale conversion factors above. real :: Z_to_L !< Convert vertical distances to lateral lengths [L Z-1 ~> 1] @@ -37,25 +43,28 @@ module MOM_unit_scaling real :: L_T_to_m_s !< Convert lateral velocities from L T-1 to m s-1 [T m L-1 s-1 ~> 1] real :: m_s_to_L_T !< Convert lateral velocities from m s-1 to L T-1 [L s T-1 m-1 ~> 1] real :: L_T2_to_m_s2 !< Convert lateral accelerations from L T-2 to m s-2 [L s2 T-2 m-1 ~> 1] - real :: Z2_T_to_m2_s !< Convert vertical diffusivities from Z2 T-1 to m2 s-1 [T1 m2 Z-2 s-1 ~> 1] + real :: Z2_T_to_m2_s !< Convert vertical diffusivities from Z2 T-1 to m2 s-1 [T m2 Z-2 s-1 ~> 1] real :: m2_s_to_Z2_T !< Convert vertical diffusivities from m2 s-1 to Z2 T-1 [Z2 s T-1 m-2 ~> 1] real :: W_m2_to_QRZ_T !< Convert heat fluxes from W m-2 to Q R Z T-1 [Q R Z m2 T-1 W-1 ~> 1] real :: QRZ_T_to_W_m2 !< Convert heat fluxes from Q R Z T-1 to W m-2 [W T Q-1 R-1 Z-1 m-2 ~> 1] ! Not used enough: real :: kg_m2_to_RZ !< Convert mass loads from kg m-2 to R Z [R Z m2 kg-1 ~> 1] real :: RZ_to_kg_m2 !< Convert mass loads from R Z to kg m-2 [kg R-1 Z-1 m-2 ~> 1] + real :: RZL2_to_kg !< Convert masses from R Z L2 to kg [kg R-1 Z-1 L-2 ~> 1] real :: kg_m2s_to_RZ_T !< Convert mass fluxes from kg m-2 s-1 to R Z T-1 [R Z m2 s T-1 kg-1 ~> 1] real :: RZ_T_to_kg_m2s !< Convert mass fluxes from R Z T-1 to kg m-2 s-1 [T kg R-1 Z-1 m-2 s-1 ~> 1] real :: RZ3_T3_to_W_m2 !< Convert turbulent kinetic energy fluxes from R Z3 T-3 to W m-2 [W T3 R-1 Z-3 m-2 ~> 1] real :: W_m2_to_RZ3_T3 !< Convert turbulent kinetic energy fluxes from W m-2 to R Z3 T-3 [R Z3 m2 T-3 W-1 ~> 1] real :: RL2_T2_to_Pa !< Convert pressures from R L2 T-2 to Pa [Pa T2 R-1 L-2 ~> 1] - ! Not used enough: real :: Pa_to_RL2_T2 !< Convert pressures from Pa to R L2 T-2 [R L2 T-2 Pa-1 ~> 1] - - ! These are used for changing scaling across restarts. - real :: m_to_Z_restart = 0.0 !< A copy of the m_to_Z that is used in restart files. - real :: m_to_L_restart = 0.0 !< A copy of the m_to_L that is used in restart files. - real :: s_to_T_restart = 0.0 !< A copy of the s_to_T that is used in restart files. - real :: kg_m3_to_R_restart = 0.0 !< A copy of the kg_m3_to_R that is used in restart files. - real :: J_kg_to_Q_restart = 0.0 !< A copy of the J_kg_to_Q that is used in restart files. + real :: RLZ_T2_to_Pa !< Convert wind stresses from R L Z T-2 to Pa [Pa T2 R-1 L-1 Z-1 ~> 1] + real :: Pa_to_RL2_T2 !< Convert pressures from Pa to R L2 T-2 [R L2 T-2 Pa-1 ~> 1] + real :: Pa_to_RLZ_T2 !< Convert wind stresses from Pa to R L Z T-2 [R L Z T-2 Pa-1 ~> 1] + + ! These are no longer used for changing scaling across restarts. + real :: m_to_Z_restart = 1.0 !< A copy of the m_to_Z that is used in restart files. + real :: m_to_L_restart = 1.0 !< A copy of the m_to_L that is used in restart files. + real :: s_to_T_restart = 1.0 !< A copy of the s_to_T that is used in restart files. + real :: kg_m3_to_R_restart = 1.0 !< A copy of the kg_m3_to_R that is used in restart files. + real :: J_kg_to_Q_restart = 1.0 !< A copy of the J_kg_to_Q that is used in restart files. end type unit_scale_type contains @@ -68,8 +77,9 @@ subroutine unit_scaling_init( param_file, US ) ! This routine initializes a unit_scale_type structure (US). ! Local variables - integer :: Z_power, L_power, T_power, R_power, Q_power + integer :: Z_power, L_power, T_power, R_power, Q_power, C_power, S_power real :: Z_rescale_factor, L_rescale_factor, T_rescale_factor, R_rescale_factor, Q_rescale_factor + real :: C_rescale_factor, S_rescale_factor ! This include declares and sets the variable "version". # include "version_variable.h" character(len=16) :: mdl = "MOM_unit_scaling" @@ -84,23 +94,31 @@ subroutine unit_scaling_init( param_file, US ) call get_param(param_file, mdl, "Z_RESCALE_POWER", Z_power, & "An integer power of 2 that is used to rescale the model's "//& "internal units of depths and heights. Valid values range from -300 to 300.", & - units="nondim", default=0, debuggingParam=.true.) + default=0, debuggingParam=.true.) call get_param(param_file, mdl, "L_RESCALE_POWER", L_power, & "An integer power of 2 that is used to rescale the model's "//& "internal units of lateral distances. Valid values range from -300 to 300.", & - units="nondim", default=0, debuggingParam=.true.) + default=0, debuggingParam=.true.) call get_param(param_file, mdl, "T_RESCALE_POWER", T_power, & "An integer power of 2 that is used to rescale the model's "//& "internal units of time. Valid values range from -300 to 300.", & - units="nondim", default=0, debuggingParam=.true.) + default=0, debuggingParam=.true.) call get_param(param_file, mdl, "R_RESCALE_POWER", R_power, & "An integer power of 2 that is used to rescale the model's "//& "internal units of density. Valid values range from -300 to 300.", & - units="nondim", default=0, debuggingParam=.true.) + default=0, debuggingParam=.true.) call get_param(param_file, mdl, "Q_RESCALE_POWER", Q_power, & "An integer power of 2 that is used to rescale the model's "//& - "internal units of heat content. Valid values range from -300 to 300.", & - units="nondim", default=0, debuggingParam=.true.) + "internal units of heat content. Valid values range from -300 to 300.", & + default=0, debuggingParam=.true.) + call get_param(param_file, mdl, "C_RESCALE_POWER", C_power, & + "An integer power of 2 that is used to rescale the model's "//& + "internal units of temperature. Valid values range from -300 to 300.", & + default=0, debuggingParam=.true.) + call get_param(param_file, mdl, "S_RESCALE_POWER", S_power, & + "An integer power of 2 that is used to rescale the model's "//& + "internal units of salinity. Valid values range from -300 to 300.", & + default=0, debuggingParam=.true.) if (abs(Z_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& "Z_RESCALE_POWER is outside of the valid range of -300 to 300.") @@ -112,6 +130,10 @@ subroutine unit_scaling_init( param_file, US ) "R_RESCALE_POWER is outside of the valid range of -300 to 300.") if (abs(Q_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& "Q_RESCALE_POWER is outside of the valid range of -300 to 300.") + if (abs(C_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& + "C_RESCALE_POWER is outside of the valid range of -300 to 300.") + if (abs(S_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& + "S_RESCALE_POWER is outside of the valid range of -300 to 300.") Z_rescale_factor = 1.0 if (Z_power /= 0) Z_rescale_factor = 2.0**Z_power @@ -138,6 +160,16 @@ subroutine unit_scaling_init( param_file, US ) US%Q_to_J_kg = 1.0 * Q_Rescale_factor US%J_kg_to_Q = 1.0 / Q_Rescale_factor + C_Rescale_factor = 1.0 + if (C_power /= 0) C_Rescale_factor = 2.0**C_power + US%C_to_degC = 1.0 * C_Rescale_factor + US%degC_to_C = 1.0 / C_Rescale_factor + + S_Rescale_factor = 1.0 + if (S_power /= 0) S_Rescale_factor = 2.0**S_power + US%S_to_ppt = 1.0 * S_Rescale_factor + US%ppt_to_S = 1.0 / S_Rescale_factor + call set_unit_scaling_combos(US) end subroutine unit_scaling_init @@ -154,6 +186,8 @@ subroutine unit_no_scaling_init(US) US%T_to_s = 1.0 ; US%s_to_T = 1.0 US%R_to_kg_m3 = 1.0 ; US%kg_m3_to_R = 1.0 US%Q_to_J_kg = 1.0 ; US%J_kg_to_Q = 1.0 + US%C_to_degC = 1.0 ; US%degC_to_C = 1.0 + US%S_to_ppt = 1.0 ; US%ppt_to_S = 1.0 call set_unit_scaling_combos(US) end subroutine unit_no_scaling_init @@ -189,21 +223,36 @@ subroutine set_unit_scaling_combos(US) US%QRZ_T_to_W_m2 = US%Q_to_J_kg * US%R_to_kg_m3 * US%Z_to_m * US%s_to_T ! Pressures: US%RL2_T2_to_Pa = US%R_to_kg_m3 * US%L_T_to_m_s**2 - ! It does not seem like US%Pa_to_RL2_T2 would be used enough in MOM6 to justify its existence. - ! US%Pa_to_RL2_T2 = US%kg_m3_to_R * US%m_s_to_L_T**2 + US%Pa_to_RL2_T2 = US%kg_m3_to_R * US%m_s_to_L_T**2 + ! Wind stresses: + US%RLZ_T2_to_Pa = US%R_to_kg_m3 * US%L_T_to_m_s**2 * US%Z_to_L + US%Pa_to_RLZ_T2 = US%kg_m3_to_R * US%m_s_to_L_T**2 * US%L_to_Z + ! Masses: + US%RZL2_to_kg = US%R_to_kg_m3 * US%Z_to_m * US%L_to_m**2 end subroutine set_unit_scaling_combos !> Set the unit scaling factors for output to restart files to the unit scaling !! factors for this run. -subroutine fix_restart_unit_scaling(US) +subroutine fix_restart_unit_scaling(US, unscaled) type(unit_scale_type), intent(inout) :: US !< A dimensional unit scaling type - - US%m_to_Z_restart = US%m_to_Z - US%m_to_L_restart = US%m_to_L - US%s_to_T_restart = US%s_to_T - US%kg_m3_to_R_restart = US%kg_m3_to_R - US%J_kg_to_Q_restart = US%J_kg_to_Q + logical, optional, intent(in) :: unscaled !< If true, set the restart factors as though the + !! model would be unscaled, which is appropriate if the + !! scaling is undone when writing a restart file. + + US%m_to_Z_restart = 1.0 ! US%m_to_Z + US%m_to_L_restart = 1.0 ! US%m_to_L + US%s_to_T_restart = 1.0 ! US%s_to_T + US%kg_m3_to_R_restart = 1.0 ! US%kg_m3_to_R + US%J_kg_to_Q_restart = 1.0 ! US%J_kg_to_Q + + if (present(unscaled)) then ; if (unscaled) then + US%m_to_Z_restart = 1.0 + US%m_to_L_restart = 1.0 + US%s_to_T_restart = 1.0 + US%kg_m3_to_R_restart = 1.0 + US%J_kg_to_Q_restart = 1.0 + endif ; endif end subroutine fix_restart_unit_scaling diff --git a/src/framework/MOM_unit_testing.F90 b/src/framework/MOM_unit_testing.F90 new file mode 100644 index 0000000000..aeef8aa882 --- /dev/null +++ b/src/framework/MOM_unit_testing.F90 @@ -0,0 +1,310 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +module MOM_unit_testing + +use posix, only : chmod +use posix, only : sigsetjmp +use posix, only : sigjmp_buf + +use MOM_coms, only : num_PEs, sync_PEs +use MOM_error_handler, only : is_root_pe +use MOM_error_handler, only : disable_fatal_errors +use MOM_error_handler, only : enable_fatal_errors + +implicit none ; private + +public :: string +public :: create_test_file +public :: delete_test_file +public :: TestSuite + + +!> String container type +type :: string + character(len=:), allocatable :: s + !< Internal character array of string +end type string + + +!> String constructor +interface string + module procedure init_string_char + module procedure init_string_int +end interface string + + +!> A generalized instance of a unit test function +type :: UnitTest + private + procedure(), nopass, pointer :: proc => null() + !< Unit test function/subroutine + procedure(), nopass, pointer :: cleanup => null() + !< Cleanup function to be run after proc + character(len=:), allocatable :: name + !< Unit test name (usually set to name of proc) + logical :: is_fatal + !< True if proc() is expected to fail +contains + procedure :: run => run_unit_test + !< Run the unit test function, proc +end type UnitTest + + +!> Unit test constructor +interface UnitTest + module procedure create_unit_test_basic + module procedure create_unit_test_full +end interface UnitTest + + +!> Collection of unit tests +type :: TestSuite + private + type(UnitTestNode), pointer :: head => null() + !< Head of the unit test linked list + type(UnitTestNode), pointer :: tail => null() + !< Tail of the unit test linked list (pre-allocated and unconfigured) + + ! Public API + procedure(), nopass, pointer, public :: cleanup => null() + !< Default cleanup function for unit tests in suite +contains + private + procedure :: add_basic => add_unit_test_basic + !< Add a unit test without a cleanup function + procedure :: add_full => add_unit_test_full + !< Add a unit test with an explicit cleanup function + generic, public :: add => add_basic, add_full + !< Add a unit test to the test suite + procedure, public :: run => run_test_suite + !< Run all unit tests in the suite +end type TestSuite + + +!> TestSuite constructor +interface TestSuite + module procedure create_test_suite +end interface TestSuite + + +!> UnitTest node of TestSuite's linked list +type :: UnitTestNode + private + type(UnitTest), pointer :: test => null() + !< Node contents + type(UnitTestNode), pointer :: next => null() + !< Pointer to next node in list +end type UnitTestNode + +contains + +!> Return a new unit test without a cleanup function +function create_unit_test_basic(proc, name, fatal) result(test) + procedure() :: proc + !< Subroutine which defines the unit test + character(len=*), intent(in) :: name + !< Name of the unit test + logical, intent(in), optional :: fatal + !< True if the test is expected to raise a FATAL error + type(UnitTest) :: test + + procedure(), pointer :: cleanup + cleanup => null() + + test = create_unit_test_full(proc, name, fatal, cleanup) +end function create_unit_test_basic + + +!> Return a new unit test with an explicit cleanup function +function create_unit_test_full(proc, name, fatal, cleanup) result(test) + procedure() :: proc + !< Subroutine which defines the unit test + character(len=*), intent(in) :: name + !< Name of the unit test + logical, optional :: fatal + !< True if the test is expected to raise a FATAL error + procedure() :: cleanup + !< Cleanup subroutine, called after test + type(UnitTest) :: test + + test%proc => proc + test%name = name + test%is_fatal = .false. + if (present(fatal)) test%is_fatal = fatal + test%cleanup => cleanup +end function create_unit_test_full + + +!> Launch a unit test with a custom cleanup procedure +subroutine run_unit_test(test) + class(UnitTest), intent(in) :: test + + type(sigjmp_buf) :: env + integer :: rc + + call sync_PEs + + ! FIXME: Some FATAL tests under MPI are unable to recover after jumpback, so + ! we disable these tests for now. + if (test%is_fatal .and. num_PEs() > 1) return + + if (test%is_fatal) then + rc = sigsetjmp(env, 1) + if (rc == 0) then + call disable_fatal_errors(env) + call test%proc + endif + call enable_fatal_errors + else + call test%proc + endif + + if (associated(test%cleanup)) call test%cleanup +end subroutine run_unit_test + + +!> Return a new test suite +function create_test_suite() result(suite) + type(TestSuite) :: suite + + ! Setup the head node, but do not populate it + allocate(suite%head) + suite%tail => suite%head +end function create_test_suite + + +subroutine add_unit_test_basic(suite, test, name, fatal) + class(TestSuite), intent(inout) :: suite + procedure() :: test + character(len=*), intent(in) :: name + logical, intent(in), optional :: fatal + + procedure(), pointer :: cleanup + + cleanup => null() + if (associated(suite%cleanup)) cleanup => suite%cleanup + + call add_unit_test_full(suite, test, name, fatal, cleanup) +end subroutine add_unit_test_basic + + +subroutine add_unit_test_full(suite, test, name, fatal, cleanup) + class(TestSuite), intent(inout) :: suite + procedure() :: test + character(len=*), intent(in) :: name + procedure() :: cleanup + logical, intent(in), optional :: fatal + + type(UnitTest), pointer :: utest + type(UnitTestNode), pointer :: node + + ! Populate the current tail + allocate(utest) + utest = UnitTest(test, name, fatal, cleanup) + suite%tail%test => utest + + ! Create and append the new (empty) node, and update the tail + allocate(node) + suite%tail%next => node + suite%tail => node +end subroutine add_unit_test_full + + +subroutine run_test_suite(suite) + class(TestSuite), intent(in) :: suite + + type(UnitTestNode), pointer :: node + + node => suite%head + do while(associated(node%test)) + ! TODO: Capture FMS stdout/stderr + print '(/a)', "=== "//node%test%name + + call node%test%run + if (associated(node%test%cleanup)) call node%test%cleanup + + node => node%next + enddo +end subroutine run_test_suite + + +!> Initialize string with a character array. +function init_string_char(c) result(str) + character(len=*), dimension(:), intent(in) :: c + !< List of character arrays + type(string), dimension(size(c)) :: str + !< String output + + integer :: i + + do i = 1, size(c) + str(i)%s = c(i) + enddo +end function init_string_char + + +!> Convert an integer to a string +function init_string_int(n) result(str) + integer, intent(in) :: n + !< Integer input + type(string) :: str + !< String output + + ! TODO: Estimate this with integer arithmetic + character(1 + floor(log10(real(abs(n)))) + (1 - sign(1, n))/2) :: chr + + write(chr, '(i0)') n + str = string(chr) +end function init_string_int + + +!> Create a text file for unit testing +subroutine create_test_file(filename, lines, mode) + character(len=*), intent(in) :: filename + !< Name of file to be created + type(string), intent(in), optional :: lines(:) + !< list of strings to write to file + integer, optional, intent(in) :: mode + !< Permissions of new file + + integer :: param_unit + integer :: i + integer :: rc + logical :: sync + + if (is_root_PE()) then + open(newunit=param_unit, file=filename, status='replace') + if (present(lines)) then + do i = 1, size(lines) + write(param_unit, '(a)') lines(i)%s + enddo + endif + close(param_unit) + if (present(mode)) rc = chmod(filename, mode) + endif + call sync_PEs +end subroutine create_test_file + + +!> Delete a file created during testing +subroutine delete_test_file(filename) + character(len=*), intent(in) :: filename + !< Name of file to be deleted + + logical :: is_file, is_open + integer :: io_unit + + if (is_root_PE()) then + inquire(file=filename, exist=is_file, opened=is_open, number=io_unit) + + if (is_file) then + if (.not. is_open) open(newunit=io_unit, file=filename) + close(io_unit, status='delete') + endif + endif + call sync_PEs +end subroutine delete_test_file + +end module MOM_unit_testing diff --git a/src/framework/MOM_write_cputime.F90 b/src/framework/MOM_write_cputime.F90 index 9df994448b..52cc924574 100644 --- a/src/framework/MOM_write_cputime.F90 +++ b/src/framework/MOM_write_cputime.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> A module to monitor the overall CPU time used by MOM6 and project when to stop the model module MOM_write_cputime -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_coms, only : sum_across_PEs, num_pes use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, is_root_pe use MOM_io, only : open_ASCII_file, close_file, APPEND_FILE, WRITEONLY_FILE @@ -21,17 +23,17 @@ module MOM_write_cputime !> A control structure that regulates the writing of CPU time type, public :: write_cputime_CS ; private logical :: initialized = .false. !< True if this control structure has been initialized. - real :: maxcpu !< The maximum amount of cpu time per processor + real :: maxcpu !< The maximum amount of CPU time per processor !! for which MOM should run before saving a restart - !! file and quiting with a return value that + !! file and quitting with a return value that !! indicates that further execution is required to - !! complete the simulation, in wall-clock seconds. + !! complete the simulation [wall-clock seconds]. type(time_type) :: Start_time !< The start time of the simulation. !! Start_time is set in MOM_initialization.F90 - real :: startup_cputime !< The CPU time used in the startup phase of the model. - real :: prev_cputime = 0.0 !< The last measured CPU time. - real :: dn_dcpu_min = -1.0 !< The minimum derivative of timestep with CPU time. - real :: cputime2 = 0.0 !< The accumulated cpu time. + real :: startup_cputime !< The CPU time used in the startup phase of the model [clock_cycles]. + real :: prev_cputime = 0.0 !< The last measured CPU time [clock_cycles]. + real :: dn_dcpu_min = -1.0 !< The minimum derivative of timestep with CPU time [steps clock_cycles-1]. + real :: cputime2 = 0.0 !< The accumulated CPU time [clock_cycles]. integer :: previous_calls = 0 !< The number of times write_CPUtime has been called. integer :: prev_n = 0 !< The value of n from the last call. integer :: fileCPU_ascii= -1 !< The unit number of the CPU time file. @@ -76,8 +78,8 @@ subroutine MOM_write_cputime_init(param_file, directory, Input_start_time, CS) ! Read all relevant parameters and write them to the model log. - ! Determine whether all paramters are set to their default values. - call get_param(param_file, mdl, "MAXCPU", CS%maxcpu, default=-1.0, do_not_log=.true.) + ! Determine whether all parameters are set to their default values. + call get_param(param_file, mdl, "MAXCPU", CS%maxcpu, units="wall-clock seconds", default=-1.0, do_not_log=.true.) call get_param(param_file, mdl, "CPU_TIME_FILE", CS%CPUfile, default="CPU_stats", do_not_log=.true.) all_default = (CS%maxcpu == -1.0) .and. (trim(CS%CPUfile) == trim("CPU_stats")) @@ -135,11 +137,11 @@ subroutine write_cputime(day, n, CS, nmax, call_end) ! Local variables real :: d_cputime ! The change in CPU time since the last call - ! this subroutine. - integer :: new_cputime ! The CPU time returned by SYSTEM_CLOCK - real :: reday ! A real version of day. - character(len=256) :: mesg ! The text of an error message - integer :: start_of_day, num_days + ! this subroutine [clock_cycles] + integer :: new_cputime ! The CPU time returned by SYSTEM_CLOCK [clock_cycles] + real :: reday ! The time in days, including fractional days [days] + integer :: start_of_day ! The number of seconds since the start of the day + integer :: num_days ! The number of days in the time if (.not.associated(CS)) call MOM_error(FATAL, & "write_energy: Module must be initialized before it is used.") @@ -200,7 +202,7 @@ subroutine write_cputime(day, n, CS, nmax, call_end) (CS%startup_cputime / CLOCKS_PER_SEC), num_pes() write(CS%fileCPU_ascii,*)" Day, Step number, CPU time, CPU time change" endif - write(CS%fileCPU_ascii,'(F12.3,", "I11,", ", F12.3,", ", F12.3)') & + write(CS%fileCPU_ascii,'(F12.3,", ",I11,", ",F12.3,", ",F12.3)') & reday, n, (CS%cputime2 / real(CLOCKS_PER_SEC)), & d_cputime / real(CLOCKS_PER_SEC) diff --git a/src/framework/_Diagnostics.dox b/src/framework/_Diagnostics.dox index 3db345ca1a..0be318f580 100644 --- a/src/framework/_Diagnostics.dox +++ b/src/framework/_Diagnostics.dox @@ -90,7 +90,7 @@ An arbitrary number of lines, one per diagnostic field: "average" or "mean" performs a time-average. "min" or "max" diagnose the minium or maxium over each time period. -- `regional_section` : "none" means global output. A string of six space separated numbers, "lat_min, lat_max, lon_min, lon_max, vert_min, vert_max", limits the diagnostic to a region. +- `regional_section` : "none" means global output. A string of six space separated numbers, "lon_min lon_max lat_min lat_max vert_min vert_max", limits the diagnostic to a region. - `packing` : Data representation in the file. 1 means "real*8", 2 means "real*4", 4 mean 16-bit integers, 8 means 1-byte. diff --git a/src/framework/_Dimensional_consistency.dox b/src/framework/_Dimensional_consistency.dox new file mode 100644 index 0000000000..0657724381 --- /dev/null +++ b/src/framework/_Dimensional_consistency.dox @@ -0,0 +1,85 @@ +/*! \page Dimensional_consistency Dimensional Consistency Testing + +\section section_Dimensional_consistency Dimensional Consistency Testing + + MOM6 uses a unique system for testing the dimensional consistency of all of +its expressions. The internal representations of dimensional variables are +rescaled by integer powers of 2 that depend on their units, with all input and +output being rescaled back to their original MKS units. By choosing different +powers of 2 for different units, the internal representations with different +units scale differently, so dimensionally inconsistent expressions will not +reproduce, but dimensionally inconsistent expressions give bitwise identical +results. So, for example, if horizontal lengths scale by a factor of 2^6=64, +and time is scaled by a factor of 2^4=16, horizontal velocities will scale by a +factor of 2^(6-4)=4. In this case, expressions that combine velocities, all +terms would scale by the same factor of 4. By contrast, if there were an +expression where a variable with units of length were added to one with the +units of a velocity, the results would scale inconsistently, and answers would +change with different scaling factors. + + What makes these integer powers of 2 special is the way that floating point +numbers are written as an O(1) mantissa times 2 raised to an integer exponent +between +/-1024. Multiplication by an integer power of 2 is just an integer +shift in the exponent, so as long as the model is not rescaled by an overly +large factor to encounter overflows and the model is not relying on automatic +underflows being converted to 0, all floating point operations can be carried +with one scale, and then rescaled to obtain identical answers. MOM6 has the +option to explicitly handle all relevant cases of underflows, and it can be +demonstrated to give identical answers when each of its units are scaled by +factors ranging from 2^-140 ~= 7.2e-43 to 2^140 ~= 1.4e42. + + When running with rescaling factors other than 2^0 = 1, there are some extra +array copies and multiplies of input fields or diagnostic output, so it is +slightly more efficient not to actively use the dimensional rescaling. For +production runs, we typically set all of the rescaling powers to 0, but for +debugging code problems, this rescaling can be an invaluable tool, especially +when combined with the very verbose runtime setting DEBUG=True in a MOM_input or +MOM_override file. Diffs of the output from runs with different scaling factors +readily highlights the earliest instances of differences, which can be used to +track down any dimensionally inconsistent expressions. Similarly, dimensional +inconsistencies in diagnostics is easily tracked down by comparing the output +from a pair of runs. + + All real variables in MOM6 should have comments describing their purpose, +along with their rescaled units and their mks counterparts with notation like +"! A velocity [L T-1 ~> m s-1]". If the units vary with the Boussinesq +approximation, the Boussinesq variant is given first. When variables are read +in, their dimensions are usually specified with a 'scale=' optional argument on +the MOM_get_param or MOM_read_data call, while the unscaling of diagnostics is +specified with a 'conversion=' factor. In both cases, these arguments it next +to a text string specifying the variable's units, which can then be check easily +for self-consistency. + + Currently in MOM6, the following dimensions have unique scaling, along with +the notation used to describe these variables in comments: + +\li Time, scaled by 2^T_RESCALE_POWER, denoted as [T ~> s] +\li Horizontal length, scaled by 2^L_RESCALE_POWER, denoted as [L ~> m] +\li Vertical height, scaled by 2^Z_RESCALE_POWER, denoted as [Z ~> m] +\li Vertical thickness, scaled by 2^H_RESCALE_POWER, denoted as [H ~> m or kg m-2] +\li Density, scaled by 2^R_RESCALE_POWER, denoted as [R ~> kg m-3] +\li Enthalpy (or heat content), scaled by 2^Q_RESCALE_POWER, denoted as [Q ~> J kg-1] + + These rescaling capabilities are also used by the SIS2 sea ice model, but it +does uses a non-Boussinesq mass scale of [R Z ~> kg m-2] for ice thicknesses, +rather than having a separate scaling factor (of [H ~> m or kg m-2]) that varies +between the Boussinesq and non-Boussinesq modes like MOM6 does. The actual +powers used in the scaling are specified separately for MOM6 and SIS2 and +need not be the same. + + Each of these units can be scaled in separate test runs, or all of them can be +rescaled simultaneously. In the latter case, MOM_unique_scales.F90 provides +tools to evaluate whether the specific combinations of units used by a model +scale by unique powers, and it can suggest scaling factors that provides unique +combinations of rescaling factors for the dimensions being tested, using a +cost-function based on the frequency with which units are used in the model (and +specified inside of MOM_check_scaling.F90), with a cost going as the product of +the frequency of units that resolve to the same scaling factor. + + A separate set of scaling factors could also be used for different chemical +tracer concentrations, for example. In this case, the tools in +MOM_unique_scales.F90 could still be used, but there would need to be a separate +equivalent of the unit_scaling_type with variables that are appropriate to the +units of the tracers. + +*/ diff --git a/src/framework/_Horizontal_indexing.dox b/src/framework/_Horizontal_indexing.dox index e68c38ac0f..509679e4b5 100644 --- a/src/framework/_Horizontal_indexing.dox +++ b/src/framework/_Horizontal_indexing.dox @@ -25,12 +25,12 @@ For example, when a loop is over h-points collocated variables - the do-loop statements will be for lower-case `i,j` variables - references to h-point variables will be `h(i,j)`, `D(i+1,j)`, etc. - references to u-point variables will be `u(I,j)` (meaning \f$u_{i+\frac{1}{2},j}\f$), `u(I-1,j)` (meaning \f$u_{i-\frac{1}{2},j}\f$), etc. -- references to v-point variables will be `v(i,J)` (meaning \f$v_{i,j+\frac{1}{2}}\f$), `u(I-1,j)` (meaning \f$u_{i,j-\frac{1}{2}}\f$), etc. +- references to v-point variables will be `v(i,J)` (meaning \f$v_{i,j+\frac{1}{2}}\f$), `v(i,J-1)` (meaning \f$v_{i,j-\frac{1}{2}}\f$), etc. - references to q-point variables will be `q(I,J)` (meaning \f$q_{i+\frac{1}{2},j+\frac{1}{2}}\f$), etc. In contrast, when a loop is over u-points collocated variables - the do-loop statements will be for upper-case `I` and lower-case `j` variables -- the expression \f$ u_{i+\frac{1}{2},j} ( h_{i,j} + h_{i+1,j} ) \f$ is `u(I,j) * ( h(i,j) + h(i+1,j)`. +- the expression \f$ u_{i+\frac{1}{2},j} ( h_{i,j} + h_{i+1,j} ) \f$ is `u(I,j) * ( h(i,j) + h(i+1,j) )`. \section section_Memory Declaration of variables diff --git a/src/framework/numerical_testing_type.F90 b/src/framework/numerical_testing_type.F90 new file mode 100644 index 0000000000..23ed4630f0 --- /dev/null +++ b/src/framework/numerical_testing_type.F90 @@ -0,0 +1,409 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> A simple type for keeping track of numerical tests +module numerical_testing_type + +implicit none ; private + +public testing +public numerical_testing_type_unit_tests + +!> Class to assist in unit tests, not to be used outside of Recon1d types +type :: testing + private + !> True if any fail has been encountered since this instance of "testing" was created + logical :: state = .false. + !> Count of tests checked + integer :: num_tests_checked = 0 + !> Count of tests failed + integer :: num_tests_failed = 0 + !> If true, be verbose and write results to stdout. Default True. + logical :: verbose = .true. + !> Error channel + integer, public :: stderr = 0 + !> Standard output channel + integer, public :: stdout = 6 + !> If true, stop instantly + logical :: stop_instantly = .false. + !> If true, ignore fails until ignore_fail=.false. + logical :: ignore_fail = .false. + !> Record instances that fail + integer :: ifailed(100) = 0. + !> Record label of first instance that failed + character(len=:), allocatable :: label_first_fail + + contains + procedure :: test => test !< Update the testing state + procedure :: set => set !< Set attributes + procedure :: summarize => summarize !< Summarize testing state + procedure :: real_scalar => real_scalar !< Compare two reals + procedure :: real_arr => real_arr !< Compare array of reals + procedure :: int_arr => int_arr !< Compare array of integers +end type + +contains + +!> Update the state with "test" +subroutine test(this, state, label, ignore) + class(testing), intent(inout) :: this !< This testing class + logical, intent(in) :: state !< True to indicate a fail, false otherwise + character(len=*), intent(in) :: label !< Message + logical, optional, intent(in) :: ignore !< If present and true, ignore a fail + ! Local variables + logical :: ignore_this_fail + + ignore_this_fail = this%ignore_fail + if (present(ignore)) ignore_this_fail = ignore + + this%num_tests_checked = this%num_tests_checked + 1 + if (state) then + if (.not. ignore_this_fail) then + this%state = .true. + this%num_tests_failed = this%num_tests_failed + 1 + if (this%num_tests_failed<=100) this%ifailed(this%num_tests_failed) = this%num_tests_checked + if (this%num_tests_failed == 1) this%label_first_fail = label + write(this%stdout, '(2x,3a)') 'Test "',trim(label),'" FAILED!' + write(this%stderr, '(2x,3a)') 'Test "',trim(label),'" FAILED!' + else + write(this%stdout, '(2x,3a)') 'Test "',trim(label),'" IGNORED!' + write(this%stderr, '(2x,3a)') 'Test "',trim(label),'" IGNORED!' + endif + elseif (this%verbose) then + write(this%stdout, '(2x,3a)') 'Test "',trim(label),'" passed' + endif + if (this%stop_instantly .and. this%state .and. .not. ignore_this_fail) stop 1 +end subroutine test + +!> Set attributes +subroutine set(this, verbose, stdout, stderr, stop_instantly, ignore_fail) + class(testing), intent(inout) :: this !< This testing class + logical, optional, intent(in) :: verbose !< True or false setting to assign to verbosity + integer, optional, intent(in) :: stdout !< The stdout channel to use + integer, optional, intent(in) :: stderr !< The stderr channel to use + logical, optional, intent(in) :: stop_instantly !< If true, stop immediately on error detection + logical, optional, intent(in) :: ignore_fail !< If true, ignore fails until this option is set false + + if (present(verbose)) then + this%verbose = verbose + endif + if (present(stdout)) then + this%stdout = stdout + endif + if (present(stderr)) then + this%stderr = stderr + endif + if (present(stop_instantly)) then + this%stop_instantly = stop_instantly + endif + if (present(ignore_fail)) then + this%ignore_fail = ignore_fail + endif +end subroutine set + +!> Summarize results +logical function summarize(this, label) + class(testing), intent(inout) :: this !< This testing class + character(len=*), intent(in) :: label !< Message + integer :: i + + if (this%state) then + write(this%stdout,'(a," : ",a,", ",i4," failed of ",i4," tested")') & + 'FAIL', trim(label), this%num_tests_failed, this%num_tests_checked + write(this%stdout,'(a,100i4)') 'Failed tests:',(this%ifailed(i),i=1,min(100,this%num_tests_failed)) + write(this%stdout,'(a,a)') 'First failed test: ',trim(this%label_first_fail) + write(this%stderr,'(a,100i4)') 'Failed tests:',(this%ifailed(i),i=1,min(100,this%num_tests_failed)) + write(this%stderr,'(a,a)') 'First failed test: ',trim(this%label_first_fail) + write(this%stderr,'(a," : ",a)') trim(label),'FAILED' + else + write(this%stdout,'(a," : ",a,", all ",i4," tests passed")') & + 'Pass', trim(label), this%num_tests_checked + endif + summarize = this%state +end function summarize + +!> Compare u_test to u_true, report, and return true if a difference larger than tol is measured +!! +!! If in verbose mode, display results to stdout +!! If a difference is measured, display results to stdout and stderr +subroutine real_scalar(this, u_test, u_true, label, tol, robits, ignore) + class(testing), intent(inout) :: this !< This testing class + real, intent(in) :: u_test !< Value to test [A] + real, intent(in) :: u_true !< Value to test against (correct answer) [A] + character(len=*), intent(in) :: label !< Message + real, optional, intent(in) :: tol !< The tolerance for differences between u and u_true [A] + integer, optional, intent(in) :: robits !< Number of bits of round-off to allow + logical, optional, intent(in) :: ignore !< If present and true, ignore a fail + ! Local variables + logical :: this_test, ignore_this_fail + real :: tolerance, err ! Tolerance and error [A] + + tolerance = 0.0 + if (present(tol)) tolerance = tol + ignore_this_fail = this%ignore_fail + if (present(ignore)) ignore_this_fail = ignore + this_test = .false. + + ! Scan for any mismatch between u_test and u_true + if (present(robits)) tolerance = abs(u_true) * float(robits) * epsilon(err) + if (abs(u_test - u_true) > tolerance) this_test = .true. + + if (this_test) then + if (ignore_this_fail) then + if (this%verbose) then + write(this%stdout,'(3(a,1p1e24.16,1x),2a)') "Calculated value =",u_test,"Correct value =",u_true, & + "err =",u_test - u_true, label, " <--- IGNORING" + write(this%stderr,'(3(a,1p1e24.16,1x),2a)') "Calculated value =",u_test,"Correct value =",u_true, & + "err =",u_test - u_true, label, " <--- IGNORING" + endif + this_test = .false. + else + write(this%stdout,'(3(a,1p1e24.16,1x),2a)') "Calculated value =",u_test,"Correct value =",u_true, & + "err =",u_test - u_true, label, " <--- WRONG" + write(this%stderr,'(3(a,1p1e24.16,1x),2a)') "Calculated value =",u_test,"Correct value =",u_true, & + "err =",u_test - u_true, label, " <--- WRONG" + endif + elseif (this%verbose) then + write(this%stdout,'(2(a,1p1e24.16,1x),a)') "Calculated value =",u_test,"Correct value =",u_true,label + endif + + call this%test( this_test, label, ignore=ignore_this_fail ) ! Updates state and counters in this +end subroutine real_scalar + +!> Compare u_test to u_true, report, and return true if a difference larger than tol is measured +!! +!! If in verbose mode, display results to stdout +!! If a difference is measured, display results to stdout and stderr +subroutine real_arr(this, n, u_test, u_true, label, tol, robits, ignore) + class(testing), intent(inout) :: this !< This testing class + integer, intent(in) :: n !< Number of cells in u + real, dimension(n), intent(in) :: u_test !< Values to test [A] + real, dimension(n), intent(in) :: u_true !< Values to test against (correct answer) [A] + character(len=*), intent(in) :: label !< Message + real, optional, intent(in) :: tol !< The tolerance for differences between u and u_true [A] + integer, optional, intent(in) :: robits !< Number of bits of round-off to allow + logical, optional, intent(in) :: ignore !< If present and true, ignore a fail + ! Local variables + integer :: k + logical :: this_test, ignore_this_fail + real :: tolerance, err ! Tolerance and error [A] + + tolerance = 0.0 + if (present(tol)) tolerance = tol + ignore_this_fail = this%ignore_fail + if (present(ignore)) ignore_this_fail = ignore + this_test = .false. + + ! Scan for any mismatch between u_test and u_true + do k = 1, n + if (present(robits)) tolerance = abs(u_true(k)) * float(robits) * epsilon(err) + if (abs(u_test(k) - u_true(k)) > tolerance) this_test = .true. + enddo + + ! If either being verbose, or an error was measured then display results + if (this_test .or. this%verbose) then + write(this%stdout,'(a4,2a24,1x,a)') 'k','Calculated value','Correct value',label + if (this_test) write(this%stderr,'(a4,2a24,1x,a)') 'k','Calculated value','Correct value',label + do k = 1, n + if (present(robits)) tolerance = abs(u_true(k)) * float(robits) * epsilon(err) + err = u_test(k) - u_true(k) + if ( ( abs(err) > tolerance .and. ignore_this_fail ) .or. & + ( abs(err) > 0. .and. abs(err) <= tolerance ) ) then + write(this%stdout,'(i4,1p2e24.16,a,1pe24.16,a)') k, u_test(k), u_true(k), & + ' err=', err, ' <--- IGNORING' + elseif (abs(err) > tolerance) then + write(this%stdout,'(i4,1p2e24.16,a,1pe24.16,a)') k, u_test(k), u_true(k), & + ' err=', err, ' <--- WRONG' + write(this%stderr,'(i4,1p2e24.16,a,1pe24.16,a)') k, u_test(k), u_true(k), & + ' err=', err, ' <--- WRONG' + else + write(this%stdout,'(i4,1p2e24.16)') k, u_test(k), u_true(k) + endif + enddo + endif + + call this%test( this_test, label, ignore=ignore_this_fail ) ! Updates state and counters in this +end subroutine real_arr + +!> Compare i_test to i_true and report and return true if a difference is found +!! +!! If in verbose mode, display results to stdout +!! If a difference is measured, display results to stdout and stderr +subroutine int_arr(this, n, i_test, i_true, label, ignore) + class(testing), intent(inout) :: this !< This testing class + integer, intent(in) :: n !< Number of cells in u + integer, dimension(n), intent(in) :: i_test !< Values to test [A] + integer, dimension(n), intent(in) :: i_true !< Values to test against (correct answer) [A] + character(len=*), intent(in) :: label !< Message + logical, optional, intent(in) :: ignore !< If present and true, ignore a fail + ! Local variables + integer :: k + logical :: this_test, ignore_this_fail + + ignore_this_fail = this%ignore_fail + if (present(ignore)) ignore_this_fail = ignore + this_test = .false. + + ! Scan for any mismatch between u_test and u_true + do k = 1, n + if (i_test(k) /= i_true(k)) this_test = .true. + enddo + + if (this%verbose) then + write(this%stdout,'(a14," : calculated =",30i3)') label, i_test + write(this%stdout,'(14x," correct =",30i3)') i_true + if (this_test) then + if (ignore_this_fail) then + write(this%stdout,'(3x,a,8x,"error =",30i3)') 'IGNORE --->', i_test(:) - i_true(:) + else + write(this%stdout,'(3x,a,8x,"error =",30i3)') ' FAIL --->', i_test(:) - i_true(:) + endif + endif + endif + + if (ignore_this_fail) this_test = .false. + + if (this_test) then + write(this%stderr,'(a14," : calculated =",30i3)') label, i_test + write(this%stderr,'(14x," correct =",30i3)') i_true + write(this%stderr,'(" FAIL ---> error =",30i3)') i_test(:) - i_true(:) + endif + + call this%test( this_test, label ) ! Updates state and counters in this +end subroutine int_arr + +!> Tests the testing type itself +logical function numerical_testing_type_unit_tests(verbose) + logical, intent(in) :: verbose !< If true, write results to stdout + ! Local variables + type(testing) :: tester ! An instance to record tests + type(testing) :: test ! The instance used for testing (is mutable) + logical :: tmpflag ! Temporary for return flags + + numerical_testing_type_unit_tests = .false. ! Assume all is well at the outset + if (verbose) write(test%stdout,*) " ===== testing_type: numerical_testing_type_unit_tests =====" + call tester%set( verbose=verbose ) ! Sets the verbosity flag in tester + + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + call test%set( stderr=6 ) ! Sets stderr (redirect errors for "test" since they are not real) + call test%set( stdout=6 ) ! Sets stdout + call test%set( stop_instantly=.false. ) ! Sets stop_instantly + call test%set( ignore_fail=.false. ) ! Sets ignore_fail + + ! Check that %summary() reports nothing when %state is unset + ! (note this has to be confirmed visually since everything is in stdout) + tmpflag = test%summarize("Summary is for a passing state") + call tester%test(tmpflag, "test%summarize() with no fails") + + ! Check that %test(.false.,...) leaves %state unchanged + call test%test( .false., "test(F) should pass" ) + call tester%test(test%state, "test%test(F)") + + ! Check that %test(.true.,...,ignore=.true.) leaves %state unchanged + call test%test( .true., "test(T) should fail but be ignored", ignore=.true. ) + call tester%test(test%state, "test%test(T,ignore)") + + ! Check that %test(.true.,...) sets %state + call test%test( .true., "test(T) should fail" ) + call tester%test(.not. test%state, "test%test(T,ignore)") + test%state = .false. ! reset + + ! Check that %real_scalar(a,a,...) leaves %state unchanged + call test%real_scalar(1., 1., "real_scalar(s,s) should pass", robits=0, tol=0.) + call tester%test(test%state, "test%real_scalar(s,s)") + + ! Check that %real_scalar(a,b,...,ignore=.true.) leaves %state unchanged + call test%real_scalar(1., 2., "real_scalar(s,t) should fail but be ignored", ignore=.true.) + call tester%test(test%state, "test%real_scalar(s,t,ignore)") + + ! Check that %real_scalar(a,a,...) sets %state + call test%real_scalar(1., 2., "s != t should fail") + call tester%test(.not. test%state, "test%real_scalar(s,t)") + test%state = .false. ! reset + + ! Check that %real_arr(a,a,...) leaves %state unchanged + call test%real_arr(2, (/1.,2./), (/1.,2./), "real_arr(a,a) should pass", robits=0, tol=0.) + call tester%test(test%state, "test%real_arr(a,a)") + + ! Check that %real_arr(a,b,...,ignore=.true.) leaves %state unchanged + call test%real_arr(2, (/1.,2./), (/3.,4./), "real_arr(a,b) should fail but be ignored", ignore=.true.) + call tester%test(test%state, "test%real_arr(a,b,ignore)") + + ! Check that %real_arr(a,b,...) sets %state + call test%real_arr(2, (/1.,2./), (/3.,4./), "real(a,b) should fail") + call tester%test(.not. test%state, "test%real_arr(a,b)") + test%state = .false. ! reset + + ! Check that %int_arr(a,a,...) leaves %state unchanged + call test%int_arr(2, (/1,2/), (/1,2/), "int_arr(i,i) should pass") + call tester%test(test%state, "test%int_arr(i,i)") + + ! Check that %int_arr(a,b,...,ignore=.true.) leaves %state unchanged + call test%int_arr(2, (/1,2/), (/3,4/), "int_arr(i,j) should fail but be ignored", ignore=.true.) + call tester%test(test%state, "test%int_arr(i,j,ignore)") + + ! Check that %int_arr(a,b,...) sets %state + call test%int_arr(2, (/1,2/), (/3,4/), "int(arr(i,j) should fail") + call tester%test(.not. test%state, "test%int_arr(i,j)") + test%state = .false. ! reset + + ! Check that %summary() reports nothing when %state is set + ! (note this has to be confirmed visually since everything is in stdout) + test%state = .true. ! reset to fail for testing %summary() + tmpflag = test%summarize("This summary should report 4 fails") + call tester%test(.not. tmpflag, "test%summarize() with fails") + + numerical_testing_type_unit_tests = tester%summarize("numerical_testing_type_unit_tests") + +end function numerical_testing_type_unit_tests + +!> \namespace numerical_testing_type +!! +!! numerical_testing_type is a helper class to facilitate implementing +!! tests of a numerical nature. +!! The class helps hide the logic and code associated with handling the +!! results of a test, essentially reducing the multiple lines of `if +!! ... then ... print ... else ... error_mesg ...` into one line. +!! +!! The class is light weight, meaning is does not depend on anything else, +!! allowing to be particularly useful in unit tests and small drivers. +!! However, this means it is up to the user to do something with the results, +!! e.g. `call MOM_error()` appropriately. +!! +!! Each test, e.g. real_scalar(), is expected to pass. +!! If a fail is encountered, it is immediately reported to stderr and stdour, +!! recorded internally, but does not terminate execuation unless +!! `set(stop_instantly=.true.)` was called previously. +!! Most tests take the form of `f(a,b)` where `a` should equal `b`. +!! Only test() takes a single input (boolean) which is expected to +!! be false for the test to pass. +!! +!! summarize() is used to "finalize" the tests. +!! It prints a summary of how many and which tests faield, and returns a logical +!! that is set to .true. if any test failed. +!! +!! Usage by example: +!! \verbatim +!! use numerical_testing_type, only : testing +!! ... +!! +!! !> Runs my unit_tests. Returns .true. if a test fails, .false. otherwise +!! logical function my_unit_tests(verbose) +!! logical, intent(in) :: verbose !< If true, write results to stdout +!! ... +!! type(testing) :: test ! An instance of the numerical_testing_type +!! ... +!! call test%set( verbose=.true. ) ! Show intermediate results rather than just the fails +!! ... +!! +!! call test%test(flag, 'Flag is not set') ! Check flag=.false. +!! call test%real_scalar(a, 1., 'u = 1') ! Check a=1 +!! call test%real_arr(3, u, (/1.,2.,3./), 'u = [1,2,3]') ! Check u(:)=[1,2,3] +!! call test%int_arr(2, iv, (/1,2/), 'iv = [1,2]') ! Check that iv(:)=[1,2] +!! +!! my_unit_tests = test%summarize('my_unit_tests') ! Return true if a fail occurs +!! end function my_unit_tests(verbose) +!! \endverbatim + +end module numerical_testing_type diff --git a/src/framework/posix.F90 b/src/framework/posix.F90 new file mode 100644 index 0000000000..4eb5969b3a --- /dev/null +++ b/src/framework/posix.F90 @@ -0,0 +1,496 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Interface to the libc POSIX API +#include "posix.h" + +module posix + +use, intrinsic :: iso_c_binding, only : c_char +use, intrinsic :: iso_c_binding, only : c_int +use, intrinsic :: iso_c_binding, only : c_long +use, intrinsic :: iso_c_binding, only : c_null_char +use, intrinsic :: iso_c_binding, only : c_funptr +use, intrinsic :: iso_c_binding, only : c_funloc +use, intrinsic :: iso_c_binding, only : c_f_procpointer + +implicit none + +!> Container for file metadata from stat +!! +!! NOTE: This is currently just a placeholder containing fields, such as size, +!! uid, mode, etc. A readable Fortran type may be used in the future. +type, bind(c) :: stat_buf + private + character(kind=c_char) :: state(SIZEOF_STAT_BUF) + !< Byte array containing file metadata +end type stat_buf + +!> Container for the jump point buffer created by setjmp(). +!! +!! The buffer typically contains the current register values, stack pointers, +!! and any information required to restore the process state. +type, bind(c) :: jmp_buf + private + character(kind=c_char) :: state(SIZEOF_JMP_BUF) + !< Unstructured array of bytes used to store the process state +end type jmp_buf + +!> Container for the jump point buffer (with signals) created by sigsetjmp() +!! +!! In addition to the content stored by `jmp_buf`, it also stores signal state. +type, bind(c) :: sigjmp_buf + private + character(kind=c_char) :: state(SIZEOF_SIGJMP_BUF) + !< Unstructured array of bytes used to store the process state +end type sigjmp_buf + +! POSIX signals +integer, parameter :: SIGUSR1 = POSIX_SIGUSR1 + !< Signal number for SIGUSR1 (user-defined signal 1) + +interface + !> C interface to POSIX chmod() + !! Users should use the Fortran-defined chmod() function. + function chmod_posix(path, mode) result(rc) bind(c, name="chmod") + ! #include + ! int chmod(const char *path, mode_t mode); + import :: c_char, c_int + + character(kind=c_char), dimension(*), intent(in) :: path + !< Zero-delimited file path + integer(kind=c_int), value, intent(in) :: mode + !< File permission to be assigned to file. + integer(kind=c_int) :: rc + !< Function return code + end function chmod_posix + + !> C interface to POSIX mkdir() + !! Users should use the Fortran-defined mkdir() function. + function mkdir_posix(path, mode) result(rc) bind(c, name="mkdir") + ! #include + ! int mkdir(const char *path, mode_t mode); + import :: c_char, c_int + + character(kind=c_char), dimension(*), intent(in) :: path + !< Zero-delimited file path + integer(kind=c_int), value, intent(in) :: mode + !< File permission to be assigned to file. + integer(kind=c_int) :: rc + !< Function return code + end function mkdir_posix + + !> C interface to POSIX stat() + !! Users should use the Fortran-defined stat() function. + function stat_posix(path, buf) result(rc) bind(c, name="stat") + import :: c_char, stat_buf, c_int + + character(kind=c_char), dimension(*), intent(in) :: path + !< Pathname of a POSIX file + type(stat_buf), intent(inout) :: buf + !< Information describing the file if it exists + integer(kind=c_int) :: rc + !< Function return code + end function + + !> C interface to POSIX signal() + !! Users should use the Fortran-defined signal() function. + function signal_posix(sig, func) result(handle) bind(c, name="signal") + ! #include + ! void (*signal(int sig, void (*func)(int)))(int); + import :: c_int, c_funptr + + integer(kind=c_int), value, intent(in) :: sig + !< Signal to be configured + type(c_funptr), value, intent(in) :: func + !< Function handle to be called when `sig` is raised + type(c_funptr) :: handle + !< Prior handle for sig to be replaced by `func` + end function signal_posix + + !> C interface to POSIX kill() + !! Users should use the Fortran-defined kill() function. + function kill_posix(pid, sig) result(rc) bind(c, name="kill") + ! #include + ! int kill(pid_t pid, int sig); + import :: c_int + + integer(kind=c_int), value, intent(in) :: pid + !< Process ID which is to receive the signal + integer(kind=c_int), value, intent(in) :: sig + !< Signal to be sent to the process + integer(kind=c_int) :: rc + !< Function return code + end function kill_posix + + !> C interface to POSIX getpid() + !! Users should use the Fortran-defined getpid() function. + function getpid_posix() result(pid) bind(c, name="getpid") + ! #include + ! pid_t getpid(void); + import :: c_long + + integer(kind=c_long) :: pid + !< Process ID of the current process. + end function getpid_posix + + !> C interface to POSIX getppid() + !! Users should use the Fortran-defined getppid() function. + function getppid_posix() result(pid) bind(c, name="getppid") + ! #include + ! pid_t getppid(void); + import :: c_long + + integer(kind=c_long) :: pid + !< Process ID of the parent process to the current process. + end function getppid_posix + + !> C interface to POSIX sleep() + !! Users should use the Fortran-defined sleep() function. + function sleep_posix(seconds) result(rc) bind(c, name="sleep") + ! #include + ! unsigned int sleep(unsigned int seconds); + import :: c_int + + integer(kind=c_int), value, intent(in) :: seconds + !< Number of real-time seconds which the thread should sleep + integer(kind=c_int) :: rc + !< Function return code + end function + + ! NOTE: The C setjmp and sigsetjmp functions *must* be called explicitly by + ! the Fortran code, rather than through a wrapper Fortran function. + ! + ! Otherwise, setjmp() will capture the stack inside the wrapper, rather than + ! the point where setjmp() is called. + ! + ! Hence, we remove the `_posix` suffix and call these explicitly. + ! (The integer kind <-> c_int conversion will need to be addressed.) + + ! NOTE: POSIX explicitly says setjmp/sigsetjmp may be either a function or a + ! macro, and thus bind() may point to a nonexistent function. + ! e.g. sigsetjmp is a macro to __sigsetjmp in glibc, so we use a macro. + + !> Save the current program execution state to `env`. + !! + !! This function creates a snapshot of the process state to `env`, which can + !! be restored by calling `longjmp`. When `setjmp` is called, the function + !! returns 0. When `longjmp` is later called, the program is restored to the + !! point where `setjmp` was called, except it now returns a value (rc) as + !! specified by `longjmp`. + function setjmp(env) result(rc) bind(c, name=SETJMP_NAME) + ! #include + ! int setjmp(jmp_buf env); + import :: jmp_buf, c_int + + type(jmp_buf), intent(in) :: env + !< Current process state + integer(kind=c_int) :: rc + !< Function return code; set to 0 if setjmp() was called, otherwise + !! specified by the corresponding longjmp() call. + end function setjmp + + !> Save the current execution and ,optionally, the signal state to `env`. + !! + !! This function creates a snapshot of the process state to `env`, which can + !! be restored by calling `longjmp`. When `setjmp` is called, the function + !! returns 0. When `longjmp` is later called, the program is restored to the + !! point where `setjmp` was called, except it now returns a value (rc) as + !! specified by `longjmp`. + !! + !! If `savesigs` is set to a nonzero value, then the signal state is included + !! in the program state. + function sigsetjmp(env, savesigs) result(rc) bind(c, name=SIGSETJMP_NAME) + ! #include + ! int sigsetjmp(jmp_buf env, int savesigs); + import :: sigjmp_buf, c_int + + type(sigjmp_buf), intent(in) :: env + !< Current process state + integer(kind=c_int), value, intent(in) :: savesigs + !< Flag to enable signal state when set to a nonzero value + integer(kind=c_int) :: rc + !< Function return code; set to 0 if sigsetjmp() was called, otherwise + !! specified by the corresponding siglongjmp() call. + end function sigsetjmp + + !> C interface to POSIX longjmp() + !! Users should use the Fortran-defined longjmp() function. + subroutine longjmp_posix(env, val) bind(c, name=LONGJMP_NAME) + ! #include + ! int longjmp(jmp_buf env, int val); + import :: jmp_buf, c_int + + type(jmp_buf), intent(in) :: env + !< Process state to restore + integer(kind=c_int), value, intent(in) :: val + !< Return code sent to setjmp() + end subroutine longjmp_posix + + !> C interface to POSIX siglongjmp() + !! Users should use the Fortran-defined siglongjmp() function. + subroutine siglongjmp_posix(env, val) bind(c, name=SIGLONGJMP_NAME) + ! #include + ! int siglongjmp(jmp_buf env, int val); + import :: sigjmp_buf, c_int + + type(sigjmp_buf), intent(in) :: env + !< Process state to restore + integer(kind=c_int), value, intent(in) :: val + !< Return code sent to sigsetjmp() + end subroutine siglongjmp_posix + + ! Note on types: + ! mode_t: + ! "According to POSIX, it shall be an integer type." + ! pid_t: + ! "According to POSIX, it shall be a signed integer type, and the + ! implementation shall support one or more programming environments where + ! the width of pid_t is no greater than the width of the type long. + ! jmp_buf: + ! This is a strongly platform-dependent variable, large enough to contain + ! a complete copy of the process execution state (registers, stack, etc). + ! sigjmp_buf: + ! A more comprehensive version of jmp_buf which contains signal state. +end interface + +abstract interface + !> Function interface for signal handlers + subroutine handler_interface(sig) + integer, intent(in) :: sig + !> Input signal to handler + end subroutine +end interface + +contains + +!> Change mode of a file +!! +!! This changes the file permission of file `path` to `mode` following POSIX +!! conventions. If successful, it returns zero. Otherwise, it returns -1. +function chmod(path, mode) result(rc) + character(len=*), intent(in) :: path + integer, intent(in) :: mode + integer :: rc + + integer(kind=c_int) :: mode_c + integer(kind=c_int) :: rc_c + + mode_c = int(mode, kind=c_int) + rc_c = chmod_posix(path//c_null_char, mode_c) + rc = int(rc_c) +end function chmod + +!> Create a file directory +!! +!! This creates a new directory named `path` with permissons set by `mode`. +!! If successful, it returns zero. Otherwise, it returns -1. +function mkdir(path, mode) result(rc) + character(len=*), intent(in) :: path + integer, intent(in) :: mode + integer :: rc + + integer(kind=c_int) :: mode_c + integer(kind=c_int) :: rc_c + + mode_c = int(mode, kind=c_int) + rc_c = mkdir_posix(path//c_null_char, mode_c) + rc = int(rc_c) +end function mkdir + +!> Get file status +!! +!! This obtains information about the named file and writes it to buf. +!! If found, it returns zero. Otherwise, it returns -1. +function stat(path, buf) result(rc) + character(len=*), intent(in) :: path + !< Pathname of file to be inspected + type(stat_buf), intent(out) :: buf + !< Buffer containing information about the file if it exists + ! NOTE: Currently the contents of buf are not readable, but we could move + ! the contents into a readable Fortran type. + integer :: rc + !< Function return code + + integer(kind=c_int) :: rc_c + + rc_c = stat_posix(path//c_null_char, buf) + + rc = int(rc_c) +end function stat + +!> Create a signal handler `handle` to be called when `sig` is detected. +!! +!! If successful, the previous handler for `sig` is returned. Otherwise, +!! SIG_ERR is returned. +function signal(sig, func) result(handle) + integer, intent(in) :: sig + procedure(handler_interface) :: func + procedure(handler_interface), pointer :: handle + + integer(kind=c_int) :: sig_c + type(c_funptr) :: handle_c + + sig_c = int(sig, kind=c_int) + handle_c = signal_posix(sig_c, c_funloc(func)) + call c_f_procpointer(handle_c, handle) +end function signal + +!> Send signal `sig` to process `pid`. +!! +!! If successful, this function returns 0. Otherwise, it returns -1. +function kill(pid, sig) result(rc) + integer, intent(in) :: pid + integer, intent(in) :: sig + integer :: rc + + integer(kind=c_int) :: pid_c, sig_c, rc_c + + pid_c = int(pid, kind=c_int) + sig_c = int(sig, kind=c_int) + rc_c = kill_posix(pid_c, sig_c) + rc = int(rc_c) +end function kill + +!> Get the ID of the current process. +function getpid() result(pid) + integer :: pid + + integer(kind=c_long) :: pid_c + + pid_c = getpid_posix() + pid = int(pid_c) +end function getpid + +!> Get the ID of the parent process of the current process. +function getppid() result(pid) + integer :: pid + + integer(kind=c_long) :: pid_c + + pid_c = getppid_posix() + pid = int(pid_c) +end function getppid + +!> Force the process to a sleep state for `seconds` seconds. +!! +!! The sleep state may be interrupted by a signal. If it sleeps for the entire +!! duration, then it returns 0. Otherwise, it returns the number of seconds +!! remaining at the point of interruption. +function sleep(seconds) result(rc) + ! NOTE: This function may replace an existing compiler `sleep()` extension. + integer, intent(in) :: seconds + integer :: rc + + integer(kind=c_int) :: seconds_c + integer(kind=c_int) :: rc_c + + seconds_c = int(seconds, kind=c_int) + rc_c = sleep_posix(seconds_c) + rc = int(rc_c) +end function sleep + +!> Restore program to state saved by `env`, and return the value `val`. +!! +!! This "nonlocal goto" alters program execution to the state stored in `env` +!! produced by a prior execution of `setjmp`. Program execution is moved +!! back to this `setjmp`, except the function will now return `val`. +subroutine longjmp(env, val) + type(jmp_buf), intent(in) :: env + integer, intent(in) :: val + + integer(kind=c_int) :: val_c + + val_c = int(val, kind=c_int) + call longjmp_posix(env, val_c) +end subroutine longjmp + +!> Restore program to state saved by `env`, and return the value `val`. +!! +!! This "nonlocal goto" alters program execution to the state stored in `env` +!! produced by a prior execution of `setjmp`. Program execution is moved back +!! to this `setjmp`, except the function will now return `val`. +!! +!! `siglongjmp` behaves in the same manner as `longjmp`, but also provides +!! predictable handling of the signal state. +subroutine siglongjmp(env, val) + type(sigjmp_buf), intent(in) :: env + integer, intent(in) :: val + + integer(kind=c_int) :: val_c + + val_c = int(val, kind=c_int) + call siglongjmp_posix(env, val_c) +end subroutine siglongjmp + + +! Symbols in may be platform-dependent and may not exist if defined +! as a macro. The following functions permit compilation when they are +! unavailable, and report a runtime error if used in the program. + +!> Placeholder function for a missing or unconfigured setjmp +function setjmp_missing(env) result(rc) bind(c) + type(jmp_buf), intent(in) :: env + !< Current process state (unused) + integer(kind=c_int) :: rc + !< Function return code (unused) + + print '(a)', 'ERROR: setjmp() is not implemented in this build.' + print '(a)', 'Recompile with autoconf or -DSETJMP_NAME=\"\".' + error stop + + ! NOTE: compilers may expect a return value, even if it is unreachable + read env%state + rc = -1 +end function setjmp_missing + +!> Placeholder function for a missing or unconfigured longjmp +subroutine longjmp_missing(env, val) bind(c) + type(jmp_buf), intent(in) :: env + !< Current process state (unused) + integer(kind=c_int), value, intent(in) :: val + !< Enable signal state flag (unused) + + print '(a)', 'ERROR: longjmp() is not implemented in this build.' + print '(a)', 'Recompile with autoconf or -DLONGJMP_NAME=\"\".' + error stop + + read env%state + read char(val) +end subroutine longjmp_missing + +!> Placeholder function for a missing or unconfigured sigsetjmp +function sigsetjmp_missing(env, savesigs) result(rc) bind(c) + type(sigjmp_buf), intent(in) :: env + !< Current process state (unused) + integer(kind=c_int), value, intent(in) :: savesigs + !< Enable signal state flag (unused) + integer(kind=c_int) :: rc + !< Function return code (unused) + + print '(a)', 'ERROR: sigsetjmp() is not implemented in this build.' + print '(a)', 'Recompile with autoconf or -DSIGSETJMP_NAME=\"\".' + error stop + + ! NOTE: compilers may expect a return value, even if it is unreachable + read env%state + read char(savesigs) + rc = -1 +end function sigsetjmp_missing + +!> Placeholder function for a missing or unconfigured siglongjmp +subroutine siglongjmp_missing(env, val) bind(c) + type(sigjmp_buf), intent(in) :: env + !< Current process state (unused) + integer(kind=c_int), value, intent(in) :: val + !< Enable signal state flag (unused) + + print '(a)', 'ERROR: siglongjmp() is not implemented in this build.' + print '(a)', 'Recompile with autoconf or -DSIGLONGJMP_NAME=\"\".' + read env%state + read char(val) + error stop +end subroutine siglongjmp_missing + +end module posix diff --git a/src/framework/posix.h b/src/framework/posix.h new file mode 100644 index 0000000000..2ccdfde126 --- /dev/null +++ b/src/framework/posix.h @@ -0,0 +1,48 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +#ifndef MOM6_POSIX_H_ +#define MOM6_POSIX_H_ + +! STAT_BUF_SIZE should be set to sizeof(stat). +! The default value is based on glibc 2.28. +#ifndef SIZEOF_STAT_BUF +#define SIZEOF_STAT_BUF 144 +#endif + +! JMP_BUF_SIZE should be set to sizeof(jmp_buf). +! If unset, then use a typical glibc value (25 long ints) +#ifndef SIZEOF_JMP_BUF +#define SIZEOF_JMP_BUF 200 +#endif + +! If unset, assume jmp_buf and sigjmp_buf are equivalent (as in glibc). +#ifndef SIZEOF_SIGJMP_BUF +#define SIZEOF_SIGJMP_BUF SIZEOF_JMP_BUF +#endif + +! Wrappers to are disabled on default. +#ifndef SETJMP_NAME +#define SETJMP_NAME "setjmp_missing" +#endif + +#ifndef LONGJMP_NAME +#define LONGJMP_NAME "longjmp_missing" +#endif + +#ifndef SIGSETJMP_NAME +#define SIGSETJMP_NAME "sigsetjmp_missing" +#endif + +#ifndef SIGLONGJMP_NAME +#define SIGLONGJMP_NAME "siglongjmp_missing" +#endif + +! This should be defined by ; +! If unset, we use the most common (x86) value +#ifndef POSIX_SIGUSR1 +#define POSIX_SIGUSR1 10 +#endif + +#endif diff --git a/src/framework/testing/MOM_file_parser_tests.F90 b/src/framework/testing/MOM_file_parser_tests.F90 new file mode 100644 index 0000000000..586037f5d9 --- /dev/null +++ b/src/framework/testing/MOM_file_parser_tests.F90 @@ -0,0 +1,1928 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +module MOM_file_parser_tests + +use posix, only : chmod + +use MOM_file_parser, only : param_file_type +use MOM_file_parser, only : open_param_file +use MOM_file_parser, only : close_param_file +use MOM_file_parser, only : read_param +use MOM_file_parser, only : log_param +use MOM_file_parser, only : get_param +use MOM_file_parser, only : log_version +use MOM_file_parser, only : clearParameterBlock +use MOM_file_parser, only : openParameterBlock +use MOM_file_parser, only : closeParameterBlock + +use MOM_time_manager, only : time_type +use MOM_time_manager, only : set_date +use MOM_time_manager, only : set_ticks_per_second +use MOM_time_manager, only : set_calendar_type +use MOM_time_manager, only : NOLEAP, NO_CALENDAR + +use MOM_error_handler, only : assert +use MOM_error_handler, only : MOM_error +use MOM_error_handler, only : FATAL + +use MOM_unit_testing, only : TestSuite +use MOM_unit_testing, only : string +use MOM_unit_testing, only : create_test_file +use MOM_unit_testing, only : delete_test_file + +implicit none ; private + +public :: run_file_parser_tests + +character(len=*), parameter :: param_filename = 'TEST_input' +character(len=*), parameter :: missing_param_filename = 'MISSING_input' +character(len=*), parameter :: netcdf_param_filename = 'TEST_input.nc' + +character(len=*), parameter :: sample_param_name = 'SAMPLE_PARAMETER' +character(len=*), parameter :: missing_param_name = 'MISSING_PARAMETER' + +character(len=*), parameter :: module_name = "SAMPLE_module" +character(len=*), parameter :: module_version = "SAMPLE_version" +character(len=*), parameter :: module_desc = "Description here" + +character(len=9), parameter :: param_docfiles(4) = [ & + "all ", & + "debugging", & + "layout ", & + "short " & +] + +contains + +subroutine test_open_param_file + type(param_file_type) :: param + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call close_param_file(param) +end subroutine test_open_param_file + + +subroutine test_close_param_file_quiet + type(param_file_type) :: param + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call close_param_file(param, quiet_close=.true.) +end subroutine test_close_param_file_quiet + + +subroutine test_open_param_file_component + type(param_file_type) :: param + integer :: i + + call create_test_file(param_filename) + + call open_param_file(param_filename, param, component="TEST") + call close_param_file(param, component="TEST") +end subroutine test_open_param_file_component + + +subroutine cleanup_open_param_file_component + integer :: i + + call delete_test_file(param_filename) + do i = 1, 4 + call delete_test_file("TEST_parameter_doc."//param_docfiles(i)) + enddo +end subroutine cleanup_open_param_file_component + + +subroutine test_open_param_file_docdir + ! TODO: Make a new directory...? + type(param_file_type) :: param + + call create_test_file(param_filename) + + call open_param_file(param_filename, param, doc_file_dir='./') + call close_param_file(param) +end subroutine test_open_param_file_docdir + + +subroutine test_open_param_file_empty_filename + type(param_file_type) :: param + + call open_param_file('', param) + ! FATAL; return to program +end subroutine test_open_param_file_empty_filename + + +subroutine test_open_param_file_long_name + !> Store filename in a variable longer than FILENAME_LENGTH + type(param_file_type) :: param + character(len=250) :: long_filename + + long_filename = param_filename + + call create_test_file(long_filename) + + call open_param_file(long_filename, param) + call close_param_file(param) +end subroutine test_open_param_file_long_name + + +subroutine test_missing_param_file + type(param_file_type) :: param + logical :: file_exists + + inquire(file=missing_param_filename, exist=file_exists) + if (file_exists) call MOM_error(FATAL, "Missing file already exists!") + + call open_param_file(missing_param_filename, param) + ! FATAL; return to program +end subroutine test_missing_param_file + + +subroutine test_open_param_file_ioerr + type(param_file_type) :: param + ! NOTE: Induce an I/O error in open() by making the file unreadable + + call create_test_file(param_filename, mode=int(o'000')) + + call open_param_file(param_filename, param) + ! FATAL; return to program +end subroutine test_open_param_file_ioerr + + +subroutine cleanup_open_param_file_ioerr + integer :: rc + + rc = chmod(param_filename, int(o'700')) + call cleanup_file_parser() +end subroutine cleanup_open_param_file_ioerr + + +subroutine test_open_param_file_netcdf + type(param_file_type) :: param + + call create_test_file(netcdf_param_filename) + + call open_param_file(netcdf_param_filename, param) + ! FATAL; return to program +end subroutine test_open_param_file_netcdf + + +subroutine cleanup_open_param_file_netcdf + integer :: param_unit + logical :: is_open + + call delete_test_file(netcdf_param_filename) +end subroutine cleanup_open_param_file_netcdf + + +subroutine test_open_param_file_checkable + type(param_file_type) :: param + + call create_test_file(param_filename) + + call open_param_file(param_filename, param, checkable=.false.) + call close_param_file(param) +end subroutine test_open_param_file_checkable + + +subroutine test_reopen_param_file + type(param_file_type) :: param + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call open_param_file(param_filename, param) + call close_param_file(param) +end subroutine test_reopen_param_file + + +subroutine test_open_param_file_no_doc + type(param_file_type) :: param + type(string) :: lines(1) + + lines(1) = string('DOCUMENT_FILE = ""') + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call close_param_file(param) +end subroutine test_open_param_file_no_doc + + +subroutine test_read_param_int + type(param_file_type) :: param + integer :: sample + type(string) :: lines(1) + character(len=*), parameter :: sample_input = '123' + integer, parameter :: sample_result = 123 + + lines = string(sample_param_name // ' = ' // sample_input) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(sample == sample_result, 'Incorrect value') +end subroutine test_read_param_int + + +subroutine test_read_param_int_missing + type(param_file_type) :: param + integer :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call read_param(param, missing_param_name, sample, fail_if_missing=.true.) + ! FATAL; return to program +end subroutine test_read_param_int_missing + + +subroutine test_read_param_int_undefined + type(param_file_type) :: param + integer :: sample + type(string) :: lines(1) + + lines = string('#undef ' // sample_param_name) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample, fail_if_missing=.true.) + ! FATAL; return to program +end subroutine test_read_param_int_undefined + + +subroutine test_read_param_int_type_err + type(param_file_type) :: param + integer :: sample + type(string) :: lines(1) + + lines = string(sample_param_name // ' = not_an_integer') + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_int_type_err + + +subroutine test_read_param_int_array + type(param_file_type) :: param + integer :: sample(3) + type(string) :: lines(1) + character(len=*), parameter :: sample_input = '1, 2, 3' + integer, parameter :: sample_result(3) = [1, 2, 3] + + lines = string(sample_param_name // ' = ' // sample_input) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(all(sample == sample_result), 'Incorrect value') +end subroutine test_read_param_int_array + + +subroutine test_read_param_int_array_missing + type(param_file_type) :: param + integer :: sample(3) + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call read_param(param, missing_param_name, sample, fail_if_missing=.true.) + ! FATAL; return to program +end subroutine test_read_param_int_array_missing + + +subroutine test_read_param_int_array_undefined + type(param_file_type) :: param + integer :: sample(3) + type(string) :: lines(1) + + lines = string('#undef ' // sample_param_name) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample, fail_if_missing=.true.) + ! FATAL; return to program +end subroutine test_read_param_int_array_undefined + + +subroutine test_read_param_int_array_type_err + type(param_file_type) :: param + integer :: sample(3) + type(string) :: lines(1) + + lines = string(sample_param_name // ' = not_an_int_array') + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_int_array_type_err + + +subroutine test_read_param_real + type(param_file_type) :: param + real :: sample + type(string) :: lines(1) + character(len=*), parameter :: sample_input = '3.14' + real, parameter :: sample_result = 3.14 + + lines = string(sample_param_name // ' = ' // sample_input) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(sample == sample_result, 'Incorrect value') +end subroutine test_read_param_real + + +subroutine test_read_param_real_missing + type(param_file_type) :: param + real :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call read_param(param, missing_param_name, sample, fail_if_missing=.true.) + ! FATAL; return to program +end subroutine test_read_param_real_missing + + +subroutine test_read_param_real_undefined + type(param_file_type) :: param + real :: sample + type(string) :: lines(1) + + lines = string('#undef ' // sample_param_name) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample, fail_if_missing=.true.) + ! FATAL; return to program +end subroutine test_read_param_real_undefined + + +subroutine test_read_param_real_type_err + type(param_file_type) :: param + real :: sample + type(string) :: lines(1) + + lines = string(sample_param_name // ' = not_a_real') + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_real_type_err + + +subroutine test_read_param_real_array + type(param_file_type) :: param + real :: sample(3) + type(string) :: lines(1) + character(len=*), parameter :: sample_input = '1., 2., 3.' + real, parameter :: sample_result(3) = [1., 2., 3.] + + lines = string(sample_param_name // ' = ' // sample_input) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(all(sample == sample_result), 'Incorrect value') +end subroutine test_read_param_real_array + + +subroutine test_read_param_real_array_missing + type(param_file_type) :: param + real :: sample(3) + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call read_param(param, missing_param_name, sample, fail_if_missing=.true.) + ! FATAL; return to program +end subroutine test_read_param_real_array_missing + + +subroutine test_read_param_real_array_undefined + type(param_file_type) :: param + real :: sample(3) + type(string) :: lines(1) + + lines = string('#undef ' // sample_param_name) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample, fail_if_missing=.true.) + ! FATAL; return to program +end subroutine test_read_param_real_array_undefined + + +subroutine test_read_param_real_array_type_err + type(param_file_type) :: param + real :: sample(3) + type(string) :: lines(1) + + lines = string(sample_param_name // ' = not_a_real_array') + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_real_array_type_err + + +subroutine test_read_param_logical + type(param_file_type) :: param + logical :: sample + type(string) :: lines(1) + character(len=*), parameter :: sample_input = 'True' + logical, parameter :: sample_result = .true. + + lines = string(sample_param_name // ' = ' // sample_input) + + !lines = string(sample_param_name // ' = True') + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(sample .eqv. sample_result, 'Incorrect value') +end subroutine test_read_param_logical + + +subroutine test_read_param_logical_missing + type(param_file_type) :: param + logical :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call read_param(param, missing_param_name, sample, fail_if_missing=.true.) + ! FATAL; return to program +end subroutine test_read_param_logical_missing + + +subroutine test_read_param_char_no_delim + type(param_file_type) :: param + character(len=8) :: sample + type(string) :: lines(1) + character(len=*), parameter :: sample_input = "abcdefgh" + character(len=*), parameter :: sample_result = "abcdefgh" + + lines = string(sample_param_name // ' = ' // sample_input) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(sample == sample_result, 'Incorrect value') +end subroutine test_read_param_char_no_delim + + +subroutine test_read_param_char_quote_delim + type(param_file_type) :: param + character(len=8) :: sample + type(string) :: lines(1) + character(len=*), parameter :: sample_input = '"abcdefgh"' + character(len=*), parameter :: sample_result = "abcdefgh" + + lines = string(sample_param_name // ' = ' // sample_input) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(sample == sample_result, 'Incorrect value') +end subroutine test_read_param_char_quote_delim + + +subroutine test_read_param_char_apostrophe_delim + type(param_file_type) :: param + character(len=8) :: sample + type(string) :: lines(1) + character(len=*), parameter :: sample_input = "'abcdefgh'" + character(len=*), parameter :: sample_result = "abcdefgh" + + lines = string(sample_param_name // " = " // sample_input) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(sample == sample_result, 'Incorrect value') +end subroutine test_read_param_char_apostrophe_delim + + +subroutine test_read_param_char_missing + type(param_file_type) :: param + character(len=8) :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call read_param(param, missing_param_name, sample, fail_if_missing=.true.) + ! FATAL; return to program +end subroutine test_read_param_char_missing + + +subroutine test_read_param_char_array + type(param_file_type) :: param + character(len=3) :: sample(3) + type(string) :: lines(1) + character(len=*), parameter :: sample_input = '"abc", "def", "ghi"' + character(len=*), parameter :: sample_result(3) = ["abc", "def", "ghi"] + + lines = string(sample_param_name // ' = ' // sample_input) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(all(sample == sample_result), 'Incorrect value') +end subroutine test_read_param_char_array + + +subroutine test_read_param_char_array_missing + type(param_file_type) :: param + character(len=8) :: sample(3) + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call read_param(param, missing_param_name, sample, fail_if_missing=.true.) + ! FATAL; return to program +end subroutine test_read_param_char_array_missing + + +subroutine test_read_param_time_date + type(param_file_type) :: param + type(time_type) :: sample + type(string) :: lines(1) + + lines = string(sample_param_name // ' = 1980-01-01 00:00:00') + call create_test_file(param_filename, lines) + + call set_calendar_type(NOLEAP) + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) +end subroutine test_read_param_time_date + + +subroutine test_read_param_time_date_bad_format + type(param_file_type) :: param + type(time_type) :: sample + type(string) :: lines(1) + + lines = string(sample_param_name // ' = 1980--01--01 00::00::00') + call create_test_file(param_filename, lines) + + call set_calendar_type(NOLEAP) + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_time_date_bad_format + + +subroutine test_read_param_time_tuple + type(param_file_type) :: param + type(time_type) :: sample + type(string) :: lines(1) + + lines = string(sample_param_name // ' = 1980,1,1,0,0,0') + call create_test_file(param_filename, lines) + + call set_calendar_type(NOLEAP) + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) +end subroutine test_read_param_time_tuple + + +subroutine test_read_param_time_bad_tuple + type(param_file_type) :: param + type(time_type) :: sample + type(string) :: lines(1) + + lines = string(sample_param_name // ' = 1980, 1') + call create_test_file(param_filename, lines) + + call set_calendar_type(NOLEAP) + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_time_bad_tuple + + +subroutine test_read_param_time_bad_tuple_values + type(param_file_type) :: param + type(time_type) :: sample + type(string) :: lines(1) + + lines = string(sample_param_name // ' = 0, 0, 0, 0, 0, 0') + call create_test_file(param_filename, lines) + + call set_calendar_type(NOLEAP) + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_time_bad_tuple_values + + +subroutine test_read_param_time_unit + type(param_file_type) :: param + type(time_type) :: sample + type(string) :: lines(1) + + lines = string(sample_param_name // ' = 0.5') + call create_test_file(param_filename, lines) + + call set_calendar_type(NOLEAP) + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample, timeunit=86400.) + call close_param_file(param) +end subroutine test_read_param_time_unit + + +subroutine test_read_param_time_missing + type(param_file_type) :: param + type(time_type) :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call read_param(param, missing_param_name, sample, fail_if_missing=.true.) + ! FATAL; return to program +end subroutine test_read_param_time_missing + + +subroutine test_read_param_time_undefined + type(param_file_type) :: param + type(time_type) :: sample + type(string) :: lines(1) + + lines = string('#undef ' // sample_param_name) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample, fail_if_missing=.true.) + ! FATAL; return to program +end subroutine test_read_param_time_undefined + + +subroutine test_read_param_time_type_err + type(param_file_type) :: param + type(time_type) :: sample + type(string) :: lines(1) + + lines = string(sample_param_name // ' = 1., 2., 3., 4., 5., 6.') + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_time_type_err + +! Generic parameter tests + +subroutine test_read_param_unused_fatal + type(param_file_type) :: param + type(string) :: lines(2) + + lines = [ & + string('FATAL_UNUSED_PARAMS = True'), & + string(sample_param_name // ' = 1') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call close_param_file(param) + ! FATAL; return to program +end subroutine test_read_param_unused_fatal + + +subroutine test_read_param_replace_tabs + type(param_file_type) :: param + integer :: sample + type(string) :: lines(1) + character(len=*), parameter :: sample_input = "1" + integer, parameter :: sample_result = 1 + character, parameter :: tab = achar(9) + + lines = string(sample_param_name // tab // '=' // tab // sample_input) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(sample == sample_result, 'Incorrect value') +end subroutine test_read_param_replace_tabs + + +subroutine test_read_param_pad_equals + type(param_file_type) :: param + integer :: sample + type(string) :: lines(1) + character(len=*), parameter :: sample_input = "1" + integer, parameter :: sample_result = 1 + + lines = string(sample_param_name // '=' // sample_input) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(sample == sample_result, 'Incorrect value') +end subroutine test_read_param_pad_equals + + +subroutine test_read_param_multiline_param + type(param_file_type) :: param + integer :: sample + type(string) :: lines(2) + integer, parameter :: sample_result = 1 + character, parameter :: backslash = achar(92) + + lines = [ & + string(sample_param_name // ' = ' // backslash), & + string(' 1') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(sample == sample_result, 'Incorrect result') +end subroutine test_read_param_multiline_param + + +subroutine test_read_param_multiline_param_unclosed + type(param_file_type) :: param + integer :: sample + type(string) :: lines(1) + character, parameter :: backslash = achar(92) + + lines = string(sample_param_name // ' = ' // backslash) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + ! FATAL; return to program +end subroutine test_read_param_multiline_param_unclosed + + +subroutine test_read_param_multiline_comment + type(param_file_type) :: param + integer :: sample + + type(string) :: lines(6) + + lines = [ & + string('/* First C comment line'), & + string(' Second C comment line */'), & + string('// First C++ comment line'), & + string('// Second C++ comment line'), & + string('! First Fortran comment line'), & + string('! Second Fortran comment line') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call close_param_file(param) +end subroutine test_read_param_multiline_comment + + +subroutine test_read_param_multiline_comment_unclosed + type(param_file_type) :: param + integer :: sample + type(string) :: lines(1) + + lines = string('/* Unclosed C comment') + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + ! FATAL; return to program +end subroutine test_read_param_multiline_comment_unclosed + + +subroutine test_read_param_misplaced_quote + type(param_file_type) :: param + character(len=20) :: sample + type(string) :: lines(1) + + lines = string(sample_param_name // ' = "abc') + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + ! FATAL; return to program +end subroutine test_read_param_misplaced_quote + + +subroutine test_read_param_define + type(param_file_type) :: param + integer :: sample + type(string) :: lines(1) + integer, parameter :: sample_result = 2 + + lines = string('#define ' // sample_param_name // ' 2') + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(sample == sample_result, 'Incorrect value') +end subroutine test_read_param_define + + +subroutine test_read_param_define_as_flag + type(param_file_type) :: param + integer :: sample + type(string) :: lines(1) + + lines = string('#define ' // sample_param_name) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) +end subroutine test_read_param_define_as_flag + + +subroutine test_read_param_override + type(param_file_type) :: param + integer :: sample + type(string) :: lines(2) + integer, parameter :: sample_result = 2 + + lines = [ & + string(sample_param_name // ' = 1'), & + string('#override ' // sample_param_name // ' = 2') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) + + call assert(sample == sample_result, 'Incorrect value') +end subroutine test_read_param_override + + +subroutine test_read_param_override_misplaced + type(param_file_type) :: param + integer :: sample + type(string) :: lines(1) + + lines(1) = string('#define #override ' // sample_param_name // ' = 1') + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + ! FATAL; return to program +end subroutine test_read_param_override_misplaced + + +subroutine test_read_param_override_twice + type(param_file_type) :: param + integer :: sample + type(string) :: lines(3) + + lines = [ & + string(sample_param_name // ' = 1'), & + string('#override ' // sample_param_name // ' = 2'), & + string('#override ' // sample_param_name // ' = 3') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_override_twice + + +subroutine test_read_param_override_repeat + type(param_file_type) :: param + integer :: sample + type(string) :: lines(3) + + lines = [ & + string(sample_param_name // ' = 1'), & + string('#override ' // sample_param_name // ' = 2'), & + string('#override ' // sample_param_name // ' = 2') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_override_repeat + + +subroutine test_read_param_override_warn_chain + type(param_file_type) :: param + integer :: sample + character(len=*), parameter :: other_param_name = 'OTHER_PARAMETER' + type(string) :: lines(4) + + lines = [ & + string(other_param_name // ' = 1'), & + string(sample_param_name // ' = 2'), & + string('#override ' // other_param_name // ' = 3'), & + string('#override ' // sample_param_name // ' = 4') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + ! First invoke the "other" override, adding it to the chain + call read_param(param, other_param_name, sample) + ! Now invoke the "sample" override, with "other" in the chain + call read_param(param, sample_param_name, sample) + ! Finally, re-invoke the "other" override, having already been issued. + call read_param(param, other_param_name, sample) + call close_param_file(param) +end subroutine test_read_param_override_warn_chain + + +subroutine test_read_param_assign_after_override + type(param_file_type) :: param + integer :: sample + type(string) :: lines(2) + + lines = [ & + string('#override ' // sample_param_name // ' = 2'), & + string(sample_param_name // ' = 3') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) +end subroutine test_read_param_assign_after_override + + +subroutine test_read_param_override_no_def + type(param_file_type) :: param + integer :: sample + type(string) :: lines(1) + + lines(1) = string('#override ' // sample_param_name) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_override_no_def + + +subroutine test_read_param_assign_twice + type(param_file_type) :: param + integer :: sample + type(string) :: lines(2) + + lines = [ & + string(sample_param_name // ' = 1'), & + string(sample_param_name // ' = 2') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_assign_twice + + +subroutine test_read_param_assign_repeat + type(param_file_type) :: param + integer :: sample + type(string) :: lines(2) + + lines = [ & + string(sample_param_name // ' = 1'), & + string(sample_param_name // ' = 1') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call close_param_file(param) +end subroutine test_read_param_assign_repeat + + +subroutine test_read_param_null_stmt + type(param_file_type) :: param + integer :: sample + type(string) :: lines(1) + + lines(1) = string(sample_param_name) + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_null_stmt + + +subroutine test_read_param_assign_in_define + type(param_file_type) :: param + integer :: sample + type(string) :: lines(1) + + lines = string('#define ' // sample_param_name // ' = 1') + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + ! FATAL; return to program +end subroutine test_read_param_assign_in_define + +!-- Blocks + +subroutine test_read_param_block + type(param_file_type) :: param + integer :: sample + type(string) :: lines(3) + integer, parameter :: sample_result = 123 + + lines = [ & + string('ABC%'), & + string('ABC%' // sample_param_name // ' = 123'), & + string('%ABC') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call openParameterBlock(param, 'ABC') + call read_param(param, sample_param_name, sample) + call closeParameterBlock(param) + call clearParameterBlock(param) + call close_param_file(param) + + call assert(sample == sample_result, 'Incorrect value') +end subroutine test_read_param_block + + +! TODO: This test fails due to an implementation issue. +subroutine test_read_param_block_stack + type(param_file_type) :: param + integer :: sample + type(string) :: lines(5) + + lines = [ & + string('ABC%'), & + string('DEF%'), & + string(sample_param_name // ' = 123'), & + string('DEF%'), & + string('%ABC') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call openParameterBlock(param, 'ABC') + call openParameterBlock(param, 'DEF') + call read_param(param, sample_param_name, sample) + call closeParameterBlock(param) + call clearParameterBlock(param) + call close_param_file(param) +end subroutine test_read_param_block_stack + + +! NOTE: This is a simpler version of the block_stack test which works +subroutine test_read_param_block_inline_stack + type(param_file_type) :: param + integer :: sample + type(string) :: lines(3) + + lines = [ & + string('ABC%'), & + string('DEF%' // sample_param_name // ' = 123'), & + string('%ABC') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call openParameterBlock(param, 'ABC') + call openParameterBlock(param, 'DEF') + call read_param(param, sample_param_name, sample) + call closeParameterBlock(param) + call clearParameterBlock(param) + call close_param_file(param) +end subroutine test_read_param_block_inline_stack + + +subroutine test_read_param_block_empty_pop + type(param_file_type) :: param + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call openParameterBlock(param, '%') + call openParameterBlock(param, 'ABC') + call closeParameterBlock(param) + call closeParameterBlock(param) + ! FATAL; return to program +end subroutine test_read_param_block_empty_pop + + +subroutine test_read_param_block_close_unnamed + type(param_file_type) :: param + type(string) :: lines(2) + + lines = [ & + string('ABC%'), & + string('%ABC') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call openParameterBlock(param, 'ABC') + call closeParameterBlock(param) + call closeParameterBlock(param) + ! FATAL; return to program +end subroutine test_read_param_block_close_unnamed + + +subroutine test_read_param_block_close_unopened + type(param_file_type) :: param + type(string) :: lines(1) + + lines = string('%CBA') + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + ! FATAL; return to program +end subroutine test_read_param_block_close_unopened + + +subroutine test_read_param_block_unmatched + type(param_file_type) :: param + type(string) :: lines(2) + + lines = [ & + string('ABC%'), & + string('%CBA') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + ! FATAL; return to program +end subroutine test_read_param_block_unmatched + + +subroutine test_open_unallocated_block + type(param_file_type) :: param + character(len=*), parameter :: block_name = "ABC" + + call openParameterBlock(param, block_name) + ! FATAL; return to program +end subroutine test_open_unallocated_block + + +subroutine test_close_unallocated_block + type(param_file_type) :: param + + call closeParameterBlock(param) + ! FATAL; return to program +end subroutine test_close_unallocated_block + + +subroutine test_clear_unallocated_block + type(param_file_type) :: param + + call clearParameterBlock(param) + ! FATAL; return to program +end subroutine test_clear_unallocated_block + + +subroutine test_read_param_block_outside_block + type(param_file_type) :: param + integer :: sample + type(string) :: lines(3) + + lines = [ & + string('ABC%'), & + string(sample_param_name // ' = 1'), & + string('%ABC') & + ] + call create_test_file(param_filename, lines) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) +end subroutine test_read_param_block_outside_block + +!--- + +subroutine test_log_version_cs + type(param_file_type) :: param + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call log_version(param, module_name, module_version, desc=module_desc) + call close_param_file(param) +end subroutine test_log_version_cs + + +subroutine test_log_version_plain + call log_version(module_name, module_version) +end subroutine test_log_version_plain + + +subroutine test_log_param_int + type(param_file_type) :: param + integer, parameter :: sample = 1 + character(len=*), parameter :: desc = "Parameter description" + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call log_param(param, module_name, sample_param_name, sample, desc=desc) + call close_param_file(param) +end subroutine test_log_param_int + + +subroutine test_log_param_int_array + type(param_file_type) :: param + integer, parameter :: sample(3) = [1, 2, 3] + character(len=*), parameter :: desc = "Parameter description" + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call log_param(param, module_name, sample_param_name, sample, desc=desc) + call close_param_file(param) +end subroutine test_log_param_int_array + + +subroutine test_log_param_real + type(param_file_type) :: param + real, parameter :: sample = 1. + character(len=*), parameter :: desc = "Parameter description" + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call log_param(param, module_name, sample_param_name, sample, desc=desc, units="") + call close_param_file(param) +end subroutine test_log_param_real + + +subroutine test_log_param_real_array + type(param_file_type) :: param + real, parameter :: sample(3) = [1., 2., 3.] + character(len=*), parameter :: desc = "Parameter description" + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call log_param(param, module_name, sample_param_name, sample, desc=desc, units="") + call close_param_file(param) +end subroutine test_log_param_real_array + + +subroutine test_log_param_time + type(param_file_type) :: param + type(time_type) :: sample + character(len=*), parameter :: desc = "Parameter description" + type(string) :: lines(1) + + lines = string(sample_param_name // ' = 1980,1,1,0,0,0') + + call set_calendar_type(NOLEAP) + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call read_param(param, sample_param_name, sample) + call log_param(param, module_name, sample_param_name, sample, desc=desc) + call close_param_file(param) +end subroutine test_log_param_time + + +subroutine test_log_param_time_as_date + type(param_file_type) :: param + type(time_type) :: sample + character(len=*), parameter :: desc = "Parameter description" + + call set_calendar_type(NOLEAP) + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + sample = set_date(1980, 1, 1, 0, 0, 0) + call log_param(param, module_name, sample_param_name, sample, desc=desc, & + log_date=.true.) + call close_param_file(param) +end subroutine test_log_param_time_as_date + + +subroutine test_log_param_time_as_date_default + type(param_file_type) :: param + type(time_type) :: sample + type(time_type) :: default_date + character(len=*), parameter :: desc = "Parameter description" + + call set_calendar_type(NOLEAP) + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + + call set_ticks_per_second(60) + default_date = set_date(1980, 1, 1, 0, 0, 0, 30) + call log_param(param, module_name, sample_param_name, sample, desc=desc, & + log_date=.true., default=default_date) + + call set_ticks_per_second(300) + default_date = set_date(1980, 1, 1, 0, 0, 0, 150) + call log_param(param, module_name, sample_param_name, sample, desc=desc, & + log_date=.true., default=default_date) + + call close_param_file(param) +end subroutine test_log_param_time_as_date_default + + +subroutine test_log_param_time_as_date_tick + type(param_file_type) :: param + type(time_type) :: sample + character(len=*), parameter :: desc = "Parameter description" + + call set_calendar_type(NOLEAP) + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call log_param(param, module_name, sample_param_name, sample, desc=desc, & + log_date=.true.) + call close_param_file(param) +end subroutine test_log_param_time_as_date_tick + + +subroutine test_log_param_time_with_unit + type(param_file_type) :: param + type(time_type) :: sample + type(time_type) :: default_date + character(len=*), parameter :: desc = "Parameter description" + character(len=*), parameter :: sample_units = "days since whatever" + + call set_calendar_type(NOLEAP) + call create_test_file(param_filename) + + call set_ticks_per_second(60) + sample = set_date(1980, 1, 1, 0, 0, 0, 30) + + default_date = set_date(1980, 1, 1, 0, 0, 0, 30) + + call open_param_file(param_filename, param) + call log_param(param, module_name, sample_param_name, sample, desc=desc, & + units=sample_units, timeunit=86400., default=default_date) + call close_param_file(param) +end subroutine test_log_param_time_with_unit + + +subroutine test_log_param_time_with_timeunit + type(param_file_type) :: param + type(time_type) :: sample + integer :: i + character(len=*), parameter :: desc = "Parameter description" + real, parameter :: timeunits(5) = [1., 3600., 86400., 3.1e7, 1e8] + + call set_calendar_type(NOLEAP) + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + do i = 1,5 + call log_param(param, module_name, sample_param_name, sample, desc=desc, & + timeunit=timeunits(i)) + enddo + call close_param_file(param) +end subroutine test_log_param_time_with_timeunit + +!---- + +subroutine test_get_param_int + type(param_file_type) :: param + integer :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample) + call close_param_file(param) +end subroutine test_get_param_int + + +subroutine test_get_param_int_no_read_no_log + type(param_file_type) :: param + integer :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample, & + do_not_read=.true., do_not_log=.true.) + call close_param_file(param) +end subroutine test_get_param_int_no_read_no_log + + +subroutine test_get_param_int_array + type(param_file_type) :: param + integer :: sample(3) + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample) + call close_param_file(param) +end subroutine test_get_param_int_array + + +subroutine test_get_param_int_array_no_read_no_log + type(param_file_type) :: param + integer :: sample(3) + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample, & + do_not_read=.true., do_not_log=.true.) + call close_param_file(param) +end subroutine test_get_param_int_array_no_read_no_log + + +subroutine test_get_param_real + type(param_file_type) :: param + real :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample, units="") + call close_param_file(param) +end subroutine test_get_param_real + + +subroutine test_get_param_real_no_read_no_log + type(param_file_type) :: param + real :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample, units="", & + do_not_read=.true., do_not_log=.true.) + call close_param_file(param) +end subroutine test_get_param_real_no_read_no_log + + +subroutine test_get_param_real_array + type(param_file_type) :: param + real :: sample(3) + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample, units="") + call close_param_file(param) +end subroutine test_get_param_real_array + + +subroutine test_get_param_real_array_no_read_no_log + type(param_file_type) :: param + real :: sample(3) + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample, units="", & + do_not_read=.true., do_not_log=.true.) + call close_param_file(param) +end subroutine test_get_param_real_array_no_read_no_log + + +subroutine test_get_param_char + type(param_file_type) :: param + character(len=8) :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample) + call close_param_file(param) +end subroutine test_get_param_char + + +subroutine test_get_param_char_no_read_no_log + type(param_file_type) :: param + character(len=8) :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample, & + do_not_read=.true., do_not_log=.true.) + call close_param_file(param) +end subroutine test_get_param_char_no_read_no_log + + +subroutine test_get_param_char_array + type(param_file_type) :: param + character(len=8) :: sample(3) + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample) + call close_param_file(param) +end subroutine test_get_param_char_array + + +subroutine test_get_param_logical + type(param_file_type) :: param + logical :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample) + call close_param_file(param) +end subroutine test_get_param_logical + + +subroutine test_get_param_logical_no_read_no_log + type(param_file_type) :: param + logical :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample, & + do_not_read=.true., do_not_log=.true.) + call close_param_file(param) +end subroutine test_get_param_logical_no_read_no_log + + +subroutine test_get_param_logical_default + type(param_file_type) :: param + logical :: sample + logical, parameter :: default_value = .false. + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample, & + default=default_value) + call close_param_file(param) +end subroutine test_get_param_logical_default + + +subroutine test_get_param_time + type(param_file_type) :: param + type(time_type) :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample) + call close_param_file(param) +end subroutine test_get_param_time + + +subroutine test_get_param_time_no_read_no_log + type(param_file_type) :: param + type(time_type) :: sample + + call create_test_file(param_filename) + + call open_param_file(param_filename, param) + call get_param(param, module_name, sample_param_name, sample, & + do_not_read=.true., do_not_log=.true.) + call close_param_file(param) +end subroutine test_get_param_time_no_read_no_log + + +! Utility functions +! TODO: Move to a generic testing module + +subroutine cleanup_file_parser + integer :: i + + call delete_test_file(param_filename) + do i = 1, 4 + call delete_test_file("MOM_parameter_doc."//param_docfiles(i)) + enddo + + call set_calendar_type(NO_CALENDAR) +end subroutine cleanup_file_parser + + +subroutine run_file_parser_tests + ! testing... + type(TestSuite) :: suite + + ! Delete any pre-existing test parameter files + call cleanup_file_parser + + ! Build the test suite + suite = TestSuite() + suite%cleanup => cleanup_file_parser + + call suite%add(test_open_param_file, "test_open_param_file") + + call suite%add(test_close_param_file_quiet, "test_close_param_file_quiet") + + call suite%add(test_open_param_file_component, "test_open_param_file_component", & + cleanup=cleanup_open_param_file_component) + + call suite%add(test_open_param_file_docdir, "test_open_param_file_docdir") + + call suite%add(test_open_param_file_empty_filename, & + "test_open_param_file_empty_filename", fatal=.true.) + + call suite%add(test_open_param_file_long_name, & + "test_open_param_file_longname") + + call suite%add(test_missing_param_file, "test_missing_param_file", & + fatal=.true.) + + call suite%add(test_open_param_file_ioerr, "test_open_param_file_ioerr", & + fatal=.true., cleanup=cleanup_open_param_file_ioerr) + + call suite%add(test_open_param_file_checkable, & + "test_open_param_file_checkable") + + call suite%add(test_reopen_param_file, "test_reopen_param_file") + + call suite%add(test_open_param_file_netcdf, "test_open_param_file_netcdf", & + fatal=.true., cleanup=cleanup_open_param_file_netcdf) + + call suite%add(test_open_param_file_no_doc, "test_open_param_file_no_doc") + + call suite%add(test_read_param_int, "test_read_param_int") + + call suite%add(test_read_param_int_missing, "test_read_param_int_missing", & + fatal=.true.) + + call suite%add(test_read_param_int_undefined, & + "test_read_param_int_undefined", fatal=.true.) + + call suite%add(test_read_param_int_type_err, & + "test_read_param_int_type_err", fatal=.true.) + + call suite%add(test_read_param_int_array, "test_read_param_int_array") + + call suite%add(test_read_param_int_array_missing, & + "test_read_param_int_array_missing", fatal=.true.) + + call suite%add(test_read_param_int_array_undefined, & + "test_read_param_int_array_undefined", fatal=.true.) + + call suite%add(test_read_param_int_array_type_err, & + "test_read_param_int_array_type_err", fatal=.true.) + + call suite%add(test_read_param_real, "test_read_param_real") + + call suite%add(test_read_param_real_missing, & + "test_read_param_real_missing", fatal=.true.) + + call suite%add(test_read_param_real_undefined, & + "test_read_param_real_undefined", fatal=.true.) + + call suite%add(test_read_param_real_type_err, & + "test_read_param_real_type_err", fatal=.true.) + + call suite%add(test_read_param_real_array, "test_read_param_real_array") + + call suite%add(test_read_param_real_array_missing, & + "test_read_param_real_array_missing", fatal=.true.) + + call suite%add(test_read_param_real_array_undefined, & + "test_read_param_real_array_undefined", fatal=.true.) + + call suite%add(test_read_param_real_array_type_err, & + "test_read_param_real_array_type_err", fatal=.true.) + + call suite%add(test_read_param_logical, "test_read_param_logical") + + call suite%add(test_read_param_logical_missing, & + "test_read_param_logical_missing", fatal=.true.) + + call suite%add(test_read_param_char_no_delim, & + "test_read_param_char_no_delim") + + call suite%add(test_read_param_char_quote_delim, & + "test_read_param_char_quote_delim") + + call suite%add(test_read_param_char_apostrophe_delim, & + "test_read_param_char_apostrophe_delim") + + call suite%add(test_read_param_char_missing, & + "test_read_param_char_missing", fatal=.true.) + + call suite%add(test_read_param_char_array, "test_read_param_char_array") + + call suite%add(test_read_param_char_array_missing, & + "test_read_param_char_array_missing", fatal=.true.) + + call suite%add(test_read_param_time_date, "test_read_param_time_date") + + call suite%add(test_read_param_time_date_bad_format, & + "test_read_param_time_date_bad_format", fatal=.true.) + + call suite%add(test_read_param_time_tuple, "test_read_param_time_tuple") + + call suite%add(test_read_param_time_bad_tuple, & + "test_read_param_time_bad_tuple", fatal=.true.) + + call suite%add(test_read_param_time_bad_tuple_values, & + "test_read_param_time_bad_tuple_values", fatal=.true.) + + call suite%add(test_read_param_time_missing, & + "test_read_param_time_missing", fatal=.true.) + + call suite%add(test_read_param_time_undefined, & + "test_read_param_time_undefined", fatal=.true.) + + call suite%add(test_read_param_time_type_err, & + "test_read_param_time_type_err", fatal=.true.) + + call suite%add(test_read_param_time_unit, "test_read_param_time_unit") + + call suite%add(test_read_param_unused_fatal, & + "test_read_param_unused_fatal", fatal=.true.) + + call suite%add(test_read_param_multiline_comment, & + "test_read_param_multiline_comment") + + call suite%add(test_read_param_multiline_comment_unclosed, & + "test_read_param_multiline_comment_unclosed", fatal=.true.) + + call suite%add(test_read_param_multiline_param, & + "test_read_param_multiline_param") + + call suite%add(test_read_param_multiline_param_unclosed, & + "test_read_param_multiline_param_unclosed", fatal=.true.) + + call suite%add(test_read_param_replace_tabs, "test_read_param_replace_tabs") + + call suite%add(test_read_param_pad_equals, "test_read_param_pad_equals") + + call suite%add(test_read_param_misplaced_quote, & + "test_read_param_misplaced_quote", fatal=.true.) + + call suite%add(test_read_param_define, "test_read_param_define") + + call suite%add(test_read_param_define_as_flag, & + "test_read_param_define_as_flag") + + call suite%add(test_read_param_override, "test_read_param_override") + + call suite%add(test_read_param_override_misplaced, & + "test_read_param_override_misplaced", fatal=.true.) + + call suite%add(test_read_param_override_twice, & + "test_read_param_override_twice", fatal=.true.) + + call suite%add(test_read_param_override_repeat, & + "test_read_param_override_repeat", fatal=.true.) + + call suite%add(test_read_param_override_warn_chain, & + "test_read_param_override_warn_chain") + + call suite%add(test_read_param_override_no_def, & + "test_read_param_override_no_def", fatal=.true.) + + call suite%add(test_read_param_assign_after_override, & + "test_read_param_assign_after_override") + + call suite%add(test_read_param_assign_twice, & + "test_read_param_assign_twice", fatal=.true.) + + call suite%add(test_read_param_assign_repeat, & + "test_read_param_assign_repeat") + + call suite%add(test_read_param_null_stmt, "test_read_param_null_stmt", & + fatal=.true.) + + call suite%add(test_read_param_assign_in_define, & + "test_read_param_assign_in_define", fatal=.true.) + + call suite%add(test_read_param_block, "test_read_param_block") + + ! FIXME: Test does not pass + !call suite%add(test_read_param_block_stack, "test_read_param_block_stack") + + call suite%add(test_read_param_block_inline_stack, & + "test_read_param_block_inline_stack") + + call suite%add(test_read_param_block_empty_pop, & + "test_read_param_block_empty_pop", fatal=.true.) + + call suite%add(test_read_param_block_close_unopened, & + "test_read_param_block_close_unopened", fatal=.true.) + + call suite%add(test_read_param_block_close_unnamed, & + "test_read_param_block_close_unnamed", fatal=.true.) + + call suite%add(test_read_param_block_unmatched, & + "test_read_param_block_unmatched", fatal=.true.) + + call suite%add(test_read_param_block_outside_block, & + "test_read_param_block_outside_block") + + call suite%add(test_open_unallocated_block, "test_open_unallocated_block", & + fatal=.true.) + + call suite%add(test_close_unallocated_block, & + "test_close_unallocated_block", fatal=.true.) + + call suite%add(test_clear_unallocated_block, & + "test_clear_unallocated_block", fatal=.true.) + + call suite%add(test_log_version_cs, "test_log_version_cs") + + call suite%add(test_log_version_plain, "test_log_version_plain") + + call suite%add(test_log_param_int, "test_log_param_int") + + call suite%add(test_log_param_int_array, "test_log_param_int_array") + + call suite%add(test_log_param_real, "test_log_param_real") + + call suite%add(test_log_param_real_array, "test_log_param_real_array") + + call suite%add(test_log_param_time, "test_log_param_time") + + call suite%add(test_log_param_time_as_date, "test_log_param_time_as_date") + + call suite%add(test_log_param_time_as_date_default, & + "test_log_param_time_as_date_default") + + call suite%add(test_log_param_time_as_date_tick, & + "test_log_param_time_as_date_tick") + + call suite%add(test_log_param_time_with_unit, & + "test_log_param_time_with_unit") + + call suite%add(test_log_param_time_with_timeunit, & + "test_log_param_time_with_timeunit") + + call suite%add(test_get_param_int, "test_get_param_int") + + call suite%add(test_get_param_int_no_read_no_log, & + "test_get_param_int_no_read_no_log") + + call suite%add(test_get_param_int_array, "test_get_param_int_array") + + call suite%add(test_get_param_int_array_no_read_no_log, & + "test_get_param_int_array_no_read_no_log") + + call suite%add(test_get_param_real, "test_get_param_real") + + call suite%add(test_get_param_real_no_read_no_log, & + "test_get_param_real_n_read_no_log") + + call suite%add(test_get_param_real_array, "test_get_param_real_array") + + call suite%add(test_get_param_real_array_no_read_no_log, & + "test_get_param_real_array_no_read_no_log") + + call suite%add(test_get_param_char, "test_get_param_char") + + call suite%add(test_get_param_char_no_read_no_log, & + "test_get_param_char_no_read_no_log") + + call suite%add(test_get_param_char_array, "test_get_param_char_array") + + call suite%add(test_get_param_logical, "test_get_param_logical") + + call suite%add(test_get_param_logical_default, & + "test_get_param_logical_default") + + call suite%add(test_get_param_logical_no_read_no_log, & + "test_get_param_logical_no_read_no_log") + + call suite%add(test_get_param_time, "test_get_param_time") + + call suite%add(test_get_param_time_no_read_no_log, & + "test_get_param_time_np_read_no_log") + + call suite%run() +end subroutine run_file_parser_tests + +end module MOM_file_parser_tests diff --git a/src/framework/version_variable.h b/src/framework/version_variable.h index 7cccf999fe..f60afdfc69 100644 --- a/src/framework/version_variable.h +++ b/src/framework/version_variable.h @@ -1,3 +1,7 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + #ifdef _FILE_VERSION character(len=*), parameter :: version = _FILE_VERSION #else diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 9dd3791211..f89c2c4cd5 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1,30 +1,37 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Implements the thermodynamic aspects of ocean / ice-shelf interactions, !! along with a crude placeholder for a later implementation of full !! ice shelf dynamics, all using the MOM framework and coding style. module MOM_ice_shelf -! This file is part of MOM6. See LICENSE.md for the license. use MOM_array_transform, only : rotate_array use MOM_constants, only : hlf use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_ROUTINE -use MOM_coms, only : num_PEs +use MOM_coms, only : num_PEs, reproducing_sum +use MOM_data_override, only : data_override use MOM_diag_mediator, only : MOM_diag_ctrl=>diag_ctrl -use MOM_IS_diag_mediator, only : post_data=>post_IS_data +use MOM_IS_diag_mediator, only : post_data=>post_IS_data, post_scalar_data=>post_IS_data_0d use MOM_IS_diag_mediator, only : register_diag_field=>register_MOM_IS_diag_field, safe_alloc_ptr +use MOM_IS_diag_mediator, only : register_scalar_field=>register_MOM_IS_scalar_field use MOM_IS_diag_mediator, only : set_IS_axes_info, diag_ctrl, time_type use MOM_IS_diag_mediator, only : MOM_IS_diag_mediator_init, MOM_IS_diag_mediator_end use MOM_IS_diag_mediator, only : set_IS_diag_mediator_grid -use MOM_IS_diag_mediator, only : enable_averages, enable_averaging, disable_averaging +use MOM_IS_diag_mediator, only : enable_averages, disable_averaging use MOM_IS_diag_mediator, only : MOM_IS_diag_mediator_infrastructure_init use MOM_IS_diag_mediator, only : MOM_IS_diag_mediator_close_registration use MOM_domains, only : MOM_domains_init, pass_var, pass_vector, clone_MOM_domain use MOM_domains, only : TO_ALL, CGRID_NE, BGRID_NE, CORNER use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : callTree_showQuery +use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_grid, only : MOM_grid_init, ocean_grid_type -use MOM_grid_initialize, only : set_grid_metrics +use MOM_grid_initialize, only : initialize_masks, set_grid_metrics use MOM_hor_index, only : hor_index_type, hor_index_init use MOM_hor_index, only : rotate_hor_index use MOM_fixed_initialization, only : MOM_initialize_topography @@ -32,34 +39,35 @@ module MOM_ice_shelf use user_initialization, only : user_initialize_topography use MOM_io, only : field_exists, file_exists, MOM_read_data, write_version_number use MOM_io, only : slasher, fieldtype, vardesc, var_desc -use MOM_io, only : write_field, close_file, SINGLE_FILE, MULTIPLE -use MOM_restart, only : register_restart_field, query_initialized, save_restart +use MOM_io, only : close_file, SINGLE_FILE, MULTIPLE +use MOM_restart, only : register_restart_field, save_restart use MOM_restart, only : restart_init, restore_state, MOM_restart_CS, register_restart_pair -use MOM_time_manager, only : time_type, time_type_to_real, real_to_time, operator(>), operator(-) +use MOM_time_manager, only : time_type, time_to_real, real_to_time, operator(>), operator(-) use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid -use MOM_transcribe_grid, only : rotate_dyngrid +use MOM_transcribe_grid, only : rotate_dyngrid use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init, fix_restart_unit_scaling -use MOM_variables, only : surface, allocate_surface_state +use MOM_variables, only : surface, allocate_surface_state, deallocate_surface_state use MOM_variables, only : rotate_surface_state -use MOM_forcing_type, only : forcing, allocate_forcing_type, MOM_forcing_chksum -use MOM_forcing_type, only : mech_forcing, allocate_mech_forcing, MOM_mech_forcing_chksum +use MOM_forcing_type, only : forcing, allocate_forcing_type, deallocate_forcing_type, MOM_forcing_chksum +use MOM_forcing_type, only : mech_forcing, allocate_mech_forcing, deallocate_mech_forcing, MOM_mech_forcing_chksum use MOM_forcing_type, only : copy_common_forcing_fields, rotate_forcing, rotate_mech_forcing use MOM_get_input, only : directories, Get_MOM_input use MOM_EOS, only : calculate_density, calculate_density_derivs, calculate_TFreeze, EOS_domain use MOM_EOS, only : EOS_type, EOS_init -use MOM_ice_shelf_dynamics, only : ice_shelf_dyn_CS, update_ice_shelf +use MOM_ice_shelf_dynamics, only : ice_shelf_dyn_CS, update_ice_shelf, write_ice_shelf_energy use MOM_ice_shelf_dynamics, only : register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn -use MOM_ice_shelf_dynamics, only : ice_shelf_min_thickness_calve -use MOM_ice_shelf_dynamics, only : ice_time_step_CFL, ice_shelf_dyn_end +use MOM_ice_shelf_dynamics, only : ice_shelf_min_thickness_calve, change_in_draft +use MOM_ice_shelf_dynamics, only : ice_time_step_CFL, ice_shelf_dyn_end, IS_dynamics_post_data +use MOM_ice_shelf_dynamics, only : volume_above_floatation, masked_var_grounded use MOM_ice_shelf_initialize, only : initialize_ice_thickness !MJH use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary use MOM_ice_shelf_state, only : ice_shelf_state, ice_shelf_state_end, ice_shelf_state_init use user_shelf_init, only : USER_initialize_shelf_mass, USER_update_shelf_mass use user_shelf_init, only : user_ice_shelf_CS -use MOM_coms, only : reproducing_sum use MOM_spatial_means, only : global_area_integral use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum, uvchksum use MOM_interpolate, only : init_external_field, time_interp_external, time_interp_external_init +use MOM_interpolate, only : external_field implicit none ; private @@ -73,6 +81,8 @@ module MOM_ice_shelf public shelf_calc_flux, initialize_ice_shelf, ice_shelf_end, ice_shelf_query public ice_shelf_save_restart, solo_step_ice_shelf, add_shelf_forces public initialize_ice_shelf_fluxes, initialize_ice_shelf_forces +public ice_sheet_calving_to_ocean_sfc +public adjust_ice_sheet_frazil ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -85,10 +95,6 @@ module MOM_ice_shelf type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control !! structure for the ice shelves type(ocean_grid_type), pointer :: Grid_in => NULL() !< un-rotated input grid metric - type(hor_index_type), pointer :: HI_in => NULL() !< Pointer to a horizontal indexing structure for - !! incoming data which has not been rotated. - type(hor_index_type), pointer :: HI => NULL() !< Pointer to a horizontal indexing structure for - !! incoming data which has not been rotated. logical :: rotate_index = .false. !< True if index map is rotated integer :: turns !< The number of quarter turns for rotation testing. type(ocean_grid_type), pointer :: Grid => NULL() !< Grid for the ice-shelf model @@ -111,22 +117,22 @@ module MOM_ice_shelf !! have no limit [Z T-1 ~> m s-1]. real :: cdrag !< drag coefficient under ice shelves [nondim]. real :: g_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] - real :: Cp !< The heat capacity of sea water [Q degC-1 ~> J kg-1 degC-1]. + real :: Cp !< The heat capacity of sea water [Q C-1 ~> J kg-1 degC-1]. real :: Rho_ocn !< A reference ocean density [R ~> kg m-3]. - real :: Cp_ice !< The heat capacity of fresh ice [Q degC-1 ~> J kg-1 degC-1]. + real :: Cp_ice !< The heat capacity of fresh ice [Q C-1 ~> J kg-1 degC-1]. real :: gamma_t !< The (fixed) turbulent exchange velocity in the !< 2-equation formulation [Z T-1 ~> m s-1]. - real :: Salin_ice !< The salinity of shelf ice [ppt]. - real :: Temp_ice !< The core temperature of shelf ice [degC]. + real :: Salin_ice !< The salinity of shelf ice [S ~> ppt]. + real :: Temp_ice !< The core temperature of shelf ice [C ~> degC]. real :: kv_ice !< The viscosity of ice [L4 Z-2 T-1 ~> m2 s-1]. real :: density_ice !< A typical density of ice [R ~> kg m-3]. real :: kv_molec !< The molecular kinematic viscosity of sea water [Z2 T-1 ~> m2 s-1]. real :: kd_molec_salt!< The molecular diffusivity of salt [Z2 T-1 ~> m2 s-1]. real :: kd_molec_temp!< The molecular diffusivity of heat [Z2 T-1 ~> m2 s-1]. real :: Lat_fusion !< The latent heat of fusion [Q ~> J kg-1]. - real :: Gamma_T_3EQ !< Nondimensional heat-transfer coefficient, used in the 3Eq. formulation - real :: Gamma_S_3EQ !< Nondimensional salt-transfer coefficient, used in the 3Eq. formulation - !< This number should be specified by the user. + real :: Gamma_T_3EQ !< Nondimensional heat-transfer coefficient, used in the 3Eq. formulation [nondim] + real :: Gamma_S_3EQ !< Nondimensional salt-transfer coefficient, used in the 3Eq. formulation [nondim] + !< This number should be specified by the user. real :: col_mass_melt_threshold !< An ocean column mass below the iceshelf below which melting !! does not occur [R Z ~> kg m-2] logical :: mass_from_file !< Read the ice shelf mass from a file every dt @@ -135,10 +141,10 @@ module MOM_ice_shelf !!!! PHYSICAL AND NUMERICAL PARAMETERS FOR ICE DYNAMICS !!!!!! - real :: time_step !< this is the shortest timestep that the ice shelf sees, and + real :: time_step !< this is the shortest timestep that the ice shelf sees [T ~> s], and !! is equal to the forcing timestep (it is passed in when the shelf !! is initialized - so need to reorganize MOM driver. - !! it will be the prognistic timestep ... maybe. + !! it will be the prognostic timestep ... maybe. logical :: solo_ice_sheet !< whether the ice model is running without being !! coupled to the ocean @@ -149,17 +155,23 @@ module MOM_ice_shelf !! will be called (note: GL_regularize and GL_couple !! should be exclusive) logical :: calve_to_mask !< If true, calve any ice that passes outside of a masked area + logical :: calve_ice_shelf_bergs=.false. !< If true, flux through a static ice front is converted + !! to point bergs real :: min_thickness_simple_calve !< min. ice shelf thickness criteria for calving [Z ~> m]. - real :: T0 !< temperature at ocean surface in the restoring region [degC] - real :: S0 !< Salinity at ocean surface in the restoring region [ppt]. - real :: input_flux !< Ice volume flux at an upstream open boundary [m3 s-1]. - real :: input_thickness !< Ice thickness at an upstream open boundary [m]. + real :: T0 !< temperature at ocean surface in the restoring region [C ~> degC] + real :: S0 !< Salinity at ocean surface in the restoring region [S ~> ppt]. + real :: input_flux !< The vertically integrated inward ice thickness flux per + !! unit face length at an upstream boundary [Z L T-1 ~> m2 s-1] + real :: input_thickness !< Ice thickness at an upstream open boundary [Z ~> m]. type(time_type) :: Time !< The component's time. - type(EOS_type) :: eqn_of_state !< Type that indicates the - !! equation of state to use. + type(EOS_type) :: eqn_of_state !< Type that indicates the equation of state to use. logical :: active_shelf_dynamics !< True if the ice shelf mass changes as a result !! the dynamic ice-shelf model. + logical :: shelf_mass_is_dynamic !< True if ice shelf mass changes over time. If true, ice + !! shelf dynamics will be initialized + logical :: data_override_shelf_fluxes !< True if the ice shelf surface mass fluxes can be + !! written using the data_override feature (only for MOSAIC grids) logical :: override_shelf_movement !< If true, user code specifies the shelf movement !! instead of using the dynamic ice-shelf mode. logical :: isthermo !< True if the ice shelf can exchange heat and @@ -171,30 +183,60 @@ module MOM_ice_shelf logical :: const_gamma !< If true, gamma_T is specified by the user. logical :: constant_sea_level !< if true, apply an evaporative, heat and salt !! fluxes. It will avoid large increase in sea level. + logical :: constant_sea_level_misomip !< If true, constant_sea_level fluxes are applied only over + !! the surface sponge cells from the ISOMIP/MISOMIP configuration + logical :: smb_diag !< If true, calculate diagnostics related to surface mass balance + logical :: bmb_diag !< If true, calculate diagnostics related to basal mass balance real :: min_ocean_mass_float !< The minimum ocean mass per unit area before the ice !! shelf is considered to float when constant_sea_level !! is used [R Z ~> kg m-2] real :: cutoff_depth !< Depth above which melt is set to zero (>= 0) [Z ~> m]. logical :: find_salt_root !< If true, if true find Sbdry using a quadratic eq. - real :: TFr_0_0 !< The freezing point at 0 pressure and 0 salinity [degC] - real :: dTFr_dS !< Partial derivative of freezing temperature with salinity [degC ppt-1] + real :: TFr_0_0 !< The freezing point at 0 pressure and 0 salinity [C ~> degC] + real :: dTFr_dS !< Partial derivative of freezing temperature with + !! salinity [C S-1 ~> degC ppt-1] real :: dTFr_dp !< Partial derivative of freezing temperature with - !! pressure [degC T2 R-1 L-2 ~> degC Pa-1] + !! pressure [C T2 R-1 L-2 ~> degC Pa-1] + real :: Zeta_N !< The stability constant xi_N = 0.052 from Holland & Jenkins '99 + !! divided by the von Karman constant VK [nondim]. Was 1/8. + real :: Vk !< Von Karman's constant [nondim] + real :: Rc !< critical flux Richardson number [nondim] + logical :: ustar_from_vel_bugfix !< If true, fixes ustar from ocean velocity bug + logical :: buoy_flux_itt_bugfix !< If true, fixes buoyancy iteration bug + logical :: salt_flux_itt_bugfix !< If true, fixes salt iteration bug + real :: buoy_flux_tol !< Fractional buoyancy iteration tolerance for convergence [nondim] + !>@{ Diagnostic handles integer :: id_melt = -1, id_exch_vel_s = -1, id_exch_vel_t = -1, & id_tfreeze = -1, id_tfl_shelf = -1, & id_thermal_driving = -1, id_haline_driving = -1, & id_u_ml = -1, id_v_ml = -1, id_sbdry = -1, & - id_h_shelf = -1, id_h_mask = -1, & + id_h_shelf = -1, id_dhdt_shelf = -1, id_h_mask = -1, id_frazil = -1, & id_surf_elev = -1, id_bathym = -1, & id_area_shelf_h = -1, & - id_ustar_shelf = -1, id_shelf_mass = -1, id_mass_flux = -1 + id_ustar_shelf = -1, id_shelf_mass = -1, id_mass_flux = -1, & + id_shelf_sfc_mass_flux = -1, & + id_vaf = -1, id_g_adott = -1, id_f_adott = -1, id_adott = -1, & + id_bdott_melt = -1, id_bdott_accum = -1, id_bdott = -1, & + id_dvafdt = -1, id_g_adot = -1, id_f_adot = -1, id_adot = -1, & + id_bdot_melt = -1, id_bdot_accum = -1, id_bdot = -1, & + id_t_area = -1, id_g_area = -1, id_f_area = -1, & + id_Ant_vaf = -1, id_Ant_g_adott = -1, id_Ant_f_adott = -1, id_Ant_adott = -1, & + id_Ant_bdott_melt = -1, id_Ant_bdott_accum = -1, id_Ant_bdott = -1, & + id_Ant_dvafdt = -1, id_Ant_g_adot = -1, id_Ant_f_adot = -1, id_Ant_adot = -1, & + id_Ant_bdot_melt = -1, id_Ant_bdot_accum = -1, id_Ant_bdot = -1, & + id_Ant_t_area = -1, id_Ant_g_area = -1, id_Ant_f_area = -1, & + id_Gr_vaf = -1, id_Gr_g_adott = -1, id_Gr_f_adott = -1, id_Gr_adott = -1, & + id_Gr_bdott_melt = -1, id_Gr_bdott_accum = -1, id_Gr_bdott = -1, & + id_Gr_dvafdt = -1, id_Gr_g_adot = -1, id_Gr_f_adot = -1, id_Gr_adot = -1, & + id_Gr_bdot_melt = -1, id_Gr_bdot_accum = -1, id_Gr_bdot = -1, & + id_Gr_t_area = -1, id_Gr_g_area = -1, id_Gr_f_area = -1 !>@} - integer :: id_read_mass !< An integer handle used in time interpolation of - !! the ice shelf mass read from a file - integer :: id_read_area !< An integer handle used in time interpolation of - !! the ice shelf mass read from a file + type(external_field) :: mass_handle + !< Handle for reading the time interpolated ice shelf mass from a file + type(external_field) :: area_handle + !< Handle for reading the time interpolated ice shelf area from a file type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to control diagnostic output. type(user_ice_shelf_CS), pointer :: user_CS => NULL() !< A pointer to the control structure for @@ -214,17 +256,17 @@ module MOM_ice_shelf !> Calculates fluxes between the ocean and ice-shelf using the three-equations !! formulation (optional to use just two equations). !! See \ref section_ICE_SHELF_equations -subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) - type(surface), target, intent(inout) :: sfc_state_in !< A structure containing fields that - !! describe the surface state of the ocean. The - !! intent is only inout to allow for halo updates. - type(forcing), target, intent(inout) :: fluxes_in !< structure containing pointers to any - !! possible thermodynamic or mass-flux forcing fields. - type(time_type), intent(in) :: Time !< Start time of the fluxes. - real, intent(in) :: time_step !< Length of time over which these fluxes - !! will be applied [s]. - type(ice_shelf_CS), pointer :: CS !< A pointer to the control structure returned - !! by a previous call to initialize_ice_shelf. +subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) + type(surface), target, intent(inout) :: sfc_state_in !< A structure containing fields that + !! describe the surface state of the ocean. The + !! intent is only inout to allow for halo updates. + type(forcing), target, intent(inout) :: fluxes_in !< structure containing pointers to any + !! possible thermodynamic or mass-flux forcing fields. + type(time_type), intent(in) :: Time !< Start time of the fluxes. + real, intent(in) :: time_step_in !< Length of time over which these fluxes + !! will be applied [T ~> s]. + type(ice_shelf_CS), pointer :: CS !< A pointer to the control structure returned + !! by a previous call to initialize_ice_shelf. ! Local variables type(ocean_grid_type), pointer :: G => NULL() !< The grid structure used by the ice shelf. @@ -239,80 +281,95 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) real, dimension(SZI_(CS%grid)) :: & Rhoml, & !< Ocean mixed layer density [R ~> kg m-3]. dR0_dT, & !< Partial derivative of the mixed layer density - !< with temperature [R degC-1 ~> kg m-3 degC-1]. + !< with temperature [R C-1 ~> kg m-3 degC-1]. dR0_dS, & !< Partial derivative of the mixed layer density - !< with salinity [R ppt-1 ~> kg m-3 ppt-1]. + !< with salinity [R S-1 ~> kg m-3 ppt-1]. p_int !< The pressure at the ice-ocean interface [R L2 T-2 ~> Pa]. real, dimension(SZI_(CS%grid),SZJ_(CS%grid)) :: & - exch_vel_t, & !< Sub-shelf thermal exchange velocity [Z T-1 ~> m s-1] - exch_vel_s !< Sub-shelf salt exchange velocity [Z T-1 ~> m s-1] - + exch_vel_t, & !< Sub-shelf thermal exchange velocity [Z T-1 ~> m s-1] + exch_vel_s, & !< Sub-shelf salt exchange velocity [Z T-1 ~> m s-1] + dh_bdott, & !< Basal melt/accumulation over a time step, used for diagnostics [Z ~> m] + dh_adott !< Surface melt/accumulation over a time step, used for diagnostics [Z ~> m] real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & mass_flux !< Total mass flux of freshwater across the ice-ocean interface. [R Z L2 T-1 ~> kg s-1] real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & haline_driving !< (SSS - S_boundary) ice-ocean - !! interface, positive for melting and negative for freezing [ppt]. + !! interface, positive for melting and negative for freezing [S ~> ppt]. !! This is computed as part of the ISOMIP diagnostics. - real, parameter :: VK = 0.40 !< Von Karman's constant - dimensionless - real :: ZETA_N = 0.052 !> The fraction of the boundary layer over which the - !! viscosity is linearly increasing [nondim]. (Was 1/8. Why?) - real, parameter :: RC = 0.20 ! critical flux Richardson number. - real :: I_ZETA_N !< The inverse of ZETA_N [nondim]. + real :: time_step !< Length of time over which these fluxes will be applied [T ~> s]. + real :: Itime_step !< Inverse of the length of time over which these fluxes will be applied [T-1 ~> s-1] + real :: VK !< Von Karman's constant [nondim] + real :: ZETA_N !< This is the stability constant xi_N = 0.052 from Holland & Jenkins '99 + !! divided by the von Karman constant VK. Was 1/8. [nondim] + real :: Rf_crit !< critical flux Richardson number [nondim] + real :: I_2Zeta_N !< Half the inverse of Zeta_N [nondim]. real :: I_LF !< The inverse of the latent heat of fusion [Q-1 ~> kg J-1]. + real :: I_dt_LHF ! The inverse of the timestep times the latent heat of fusion [Q-1 T-1 ~> kg J-1 s-1]. real :: I_VK !< The inverse of the Von Karman constant [nondim]. real :: PR, SC !< The Prandtl number and Schmidt number [nondim]. ! 3 equations formulation variables real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & - Sbdry !< Salinities in the ocean at the interface with the ice shelf [ppt]. - real :: Sbdry_it - real :: Sbdry1, Sbdry2 - real :: S_a, S_b, S_c ! Variables used to find salt roots - real :: dS_it !< The interface salinity change during an iteration [ppt]. + Sbdry !< Salinities in the ocean at the interface with the ice shelf [S ~> ppt]. + real :: Sbdry_it ! The boundary salinity at an iteration [S ~> ppt] + real :: S_a ! A variable used to find salt roots [S-1 ~> ppt-1] + real :: S_b ! A variable used to find salt roots [nondim] + real :: S_c ! A variable used to find salt roots [S ~> ppt] + real :: dS_it !< The interface salinity change during an iteration [S ~> ppt]. real :: hBL_neut !< The neutral boundary layer thickness [Z ~> m]. real :: hBL_neut_h_molec !< The ratio of the neutral boundary layer thickness !! to the molecular boundary layer thickness [nondim]. - real :: wT_flux !< The downward vertical flux of heat just inside the ocean [degC Z T-1 ~> degC m s-1]. + real :: wT_flux !< The downward vertical flux of heat just inside the ocean [C Z T-1 ~> degC m s-1]. real :: wB_flux !< The downward vertical flux of buoyancy just inside the ocean [Z2 T-3 ~> m2 s-3]. - real :: dB_dS !< The derivative of buoyancy with salinity [Z T-2 ppt-1 ~> m s-2 ppt-1]. - real :: dB_dT !< The derivative of buoyancy with temperature [Z T-2 degC-1 ~> m s-2 degC-1]. - real :: I_n_star ! [nondim] + real :: dB_dS !< The derivative of buoyancy with salinity [Z T-2 S-1 ~> m s-2 ppt-1]. + real :: dB_dT !< The derivative of buoyancy with temperature [Z T-2 C-1 ~> m s-2 degC-1]. + real :: I_n_star ! The inverse of the ratio of working boundary layer thickness + ! to the neutral thickness [nondim] real :: n_star_term ! A term in the expression for nstar [T3 Z-2 ~> s3 m-2] real :: absf ! The absolute value of the Coriolis parameter [T-1 ~> s-1] real :: dIns_dwB !< The partial derivative of I_n_star with wB_flux, in [T3 Z-2 ~> s3 m-2] - real :: dT_ustar ! The difference between the the freezing point and the ocean boundary layer - ! temperature times the friction velocity [degC Z T-1 ~> degC m s-1] + real :: dT_ustar ! The difference between the freezing point and the ocean boundary layer + ! temperature times the friction velocity [C Z T-1 ~> degC m s-1] real :: dS_ustar ! The difference between the salinity at the ice-ocean interface and the ocean - ! boundary layer salinity times the friction velocity [ppt Z T-1 ~> ppt m s-1] + ! boundary layer salinity times the friction velocity [S Z T-1 ~> ppt m s-1] real :: ustar_h ! The friction velocity in the water below the ice shelf [Z T-1 ~> m s-1] - real :: Gam_turb ! [nondim] - real :: Gam_mol_t, Gam_mol_s ! Relative coefficients of molecular diffusivites [nondim] - real :: RhoCp ! A typical ocean density times the heat capacity of water [Q R ~> J m-3] - real :: ln_neut + real :: Gam_turb ! A relative turbluent diffusivity [nondim] + real :: Gam_mol_t, Gam_mol_s ! Relative coefficients of molecular diffusivities [nondim] + real :: RhoCp ! A typical ocean density times the heat capacity of water [Q R C-1 ~> J m-3 degC-1] + real :: ln_neut ! The log of the ratio of the neutral boundary layer thickness to the molecular + ! boundary layer thickness if it is greater than 1 or 0 otherwise [nondim] real :: mass_exch ! A mass exchange rate [R Z T-1 ~> kg m-2 s-1] - real :: Sb_min, Sb_max - real :: dS_min, dS_max + real :: Sb_min, Sb_max ! Minimum and maximum boundary salinities [S ~> ppt] + real :: dS_min, dS_max ! Minimum and maximum salinity changes [S ~> ppt] ! Variables used in iterating for wB_flux. - real :: wB_flux_new, dDwB_dwB_in - real :: I_Gam_T, I_Gam_S - real :: dG_dwB ! The derivative of Gam_turb with wB [T3 Z-2 ~> s3 m-2] + real :: wB_flux_next ! The next interation's guess for wB_flux [Z2 T-3 ~> m2 s-3] + real :: wB_flux_new ! An updated value of wB_flux when Gam_turb is based on wB_flux [Z2 T-3 ~> m2 s-3] + real :: wB_flux_max ! The upper bound on wB_flux [Z2 T-3 ~> m2 s-3] + real :: wB_flux_min ! The lower bound on wB_flux [Z2 T-3 ~> m2 s-3] + real :: dDwB_dwB ! The slope of the change in wB_flux between iterations with wB_flux [nondim] + real :: DwB_max ! The change in wB_flux when it is wB_flux_max [Z2 T-3 ~> m2 s-3] + real :: DwB_min ! The change in wB_flux when it is wB_flux_min [Z2 T-3 ~> m2 s-3] + real :: I_Gam_T, I_Gam_S ! Terms that vary inversely with Gam_mol_T or Gam_mol_S and Gam_turb [nondim] + real :: dG_dwB ! The derivative of Gam_turb with wB [T3 Z-2 ~> s3 m-2] real :: taux2, tauy2 ! The squared surface stresses [R2 L2 Z2 T-4 ~> Pa2]. real :: u2_av, v2_av ! The ice-area weighted average squared ocean velocities [L2 T-2 ~> m2 s-2] - real :: asu1, asu2 ! Ocean areas covered by ice shelves at neighboring u- - real :: asv1, asv2 ! and v-points [L2 ~> m2]. + real :: asu1, asu2 ! Ocean areas covered by ice shelves at neighboring u-points [L2 ~> m2] + real :: asv1, asv2 ! Ocean areas covered by ice shelves at neighboring v-points [L2 ~> m2] real :: I_au, I_av ! The Adcroft reciprocals of the ice shelf areas at adjacent points [L-2 ~> m-2] real :: Irho0 ! The inverse of the mean density times a unit conversion factor [R-1 L Z-1 ~> m3 kg-1] logical :: Sb_min_set, Sb_max_set + logical :: root_found logical :: update_ice_vel ! If true, it is time to update the ice shelf velocities. - logical :: coupled_GL ! If true, the grouding line position is determined based on + logical :: coupled_GL ! If true, the grounding line position is determined based on ! coupled ice-ocean dynamics. - logical :: use_temperature = .true. ! - - real, parameter :: c2_3 = 2.0/3.0 - character(len=160) :: mesg ! The text of an error message + logical :: add_frazil ! If true, allow frazil formation to modify ice-shelf water flux + real, parameter :: c2_3 = 2.0/3.0 ! Two thirds [nondim] + character(len=320) :: mesg ! The text of an error message integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, is, ie, js, je, ied, jed, it1, it3 + real :: vaf0, vaf0_A, vaf0_G ! The previous volumes above floatation [Z L2 ~> m3] + ! for all ice sheets, Antarctica only, or Greenland only if (.not. associated(CS)) call MOM_error(FATAL, "shelf_calc_flux: "// & "initialize_ice_shelf must be called before shelf_calc_flux.") @@ -320,21 +377,42 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) G => CS%grid ; US => CS%US ISS => CS%ISS + time_step = time_step_in + Itime_step = 1./time_step + + dh_adott(:,:) = 0.0 ; dh_bdott(:,:) = 0.0 + + if (CS%active_shelf_dynamics) then + !calculate previous volumes above floatation + if (CS%id_dvafdt > 0) call volume_above_floatation(CS%dCS, G, ISS, vaf0) !all ice sheet + if (CS%id_Ant_dvafdt > 0) call volume_above_floatation(CS%dCS, G, ISS, vaf0_A, hemisphere=0) !Antarctica only + if (CS%id_Gr_dvafdt > 0) call volume_above_floatation(CS%dCS, G, ISS, vaf0_G, hemisphere=1) !Greenland only + endif + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; ied = G%ied ; jed = G%jed + if (CS%data_override_shelf_fluxes .and. CS%active_shelf_dynamics) then + call data_override(G%Domain, 'shelf_sfc_mass_flux', fluxes_in%shelf_sfc_mass_flux(is:ie,js:je), CS%Time, & + scale=US%kg_m2s_to_RZ_T) + call pass_var(fluxes_in%shelf_sfc_mass_flux, G%domain, complete=.true.) + endif if (CS%rotate_index) then allocate(sfc_state) - call rotate_surface_state(sfc_state_in, CS%Grid_in, sfc_state, CS%Grid, CS%turns) + call rotate_surface_state(sfc_state_in, sfc_state, CS%Grid, CS%turns) allocate(fluxes) - call allocate_forcing_type(fluxes_in, G, fluxes) + call allocate_forcing_type(fluxes_in, G, fluxes, turns=CS%turns) call rotate_forcing(fluxes_in, fluxes, CS%turns) else sfc_state => sfc_state_in fluxes => fluxes_in endif ! useful parameters - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; ied = G%ied ; jed = G%jed - I_ZETA_N = 1.0 / ZETA_N + ZETA_N = CS%Zeta_N + VK = CS%Vk + Rf_crit = CS%Rc + I_2Zeta_N = 0.5 / CS%Zeta_N I_LF = 1.0 / CS%Lat_fusion + I_dt_LHF = 1.0 / (time_step * CS%Lat_fusion) SC = CS%kv_molec/CS%kd_molec_salt PR = CS%kv_molec/CS%kd_molec_temp I_VK = 1.0/VK @@ -366,12 +444,12 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) if (CS%debug) then call hchksum(fluxes_in%frac_shelf_h, "frac_shelf_h before apply melting", CS%Grid_in%HI, haloshift=0) - call hchksum(sfc_state_in%sst, "sst before apply melting", CS%Grid_in%HI, haloshift=0) - call hchksum(sfc_state_in%sss, "sss before apply melting", CS%Grid_in%HI, haloshift=0) - call uvchksum("[uv]_ml before apply melting",sfc_state_in%u, sfc_state_in%v, & - CS%Grid_in%HI, haloshift=0, scale=US%L_T_to_m_s) + call hchksum(sfc_state_in%sst, "sst before apply melting", CS%Grid_in%HI, haloshift=0, unscale=US%C_to_degC) + call hchksum(sfc_state_in%sss, "sss before apply melting", CS%Grid_in%HI, haloshift=0, unscale=US%S_to_ppt) + call uvchksum("[uv]_ml before apply melting", sfc_state_in%u, sfc_state_in%v, & + CS%Grid_in%HI, haloshift=0, unscale=US%L_T_to_m_s) call hchksum(sfc_state_in%ocean_mass, "ocean_mass before apply melting", CS%Grid_in%HI, haloshift=0, & - scale=US%RZ_to_kg_m2) + unscale=US%RZ_to_kg_m2) endif ! Calculate the friction velocity under ice shelves, using taux_shelf and tauy_shelf if possible. @@ -388,11 +466,15 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) I_au = 0.0 ; if (asu1 + asu2 > 0.0) I_au = 1.0 / (asu1 + asu2) I_av = 0.0 ; if (asv1 + asv2 > 0.0) I_av = 1.0 / (asv1 + asv2) if (allocated(sfc_state%taux_shelf) .and. allocated(sfc_state%tauy_shelf)) then - taux2 = (asu1 * sfc_state%taux_shelf(I-1,j)**2 + asu2 * sfc_state%taux_shelf(I,j)**2 ) * I_au - tauy2 = (asv1 * sfc_state%tauy_shelf(i,J-1)**2 + asv2 * sfc_state%tauy_shelf(i,J)**2 ) * I_av + taux2 = (((asu1 * (sfc_state%taux_shelf(I-1,j)**2)) + (asu2 * (sfc_state%taux_shelf(I,j)**2)) ) * I_au) + tauy2 = (((asv1 * (sfc_state%tauy_shelf(i,J-1)**2)) + (asv2 * (sfc_state%tauy_shelf(i,J)**2)) ) * I_av) + endif + u2_av = (((asu1 * (sfc_state%u(I-1,j)**2)) + (asu2 * sfc_state%u(I,j)**2)) * I_au) + if (CS%ustar_from_vel_bugfix) then + v2_av = (((asv1 * (sfc_state%v(i,J-1)**2)) + (asv2 * sfc_state%v(i,J)**2)) * I_av) + else + v2_av = (((asv1 * (sfc_state%v(i,J-1)**2)) + (asu2 * sfc_state%v(i,J)**2)) * I_av) endif - u2_av = (asu1 * sfc_state%u(I-1,j)**2 + asu2 * sfc_state%u(I,j)**2) * I_au - v2_av = (asv1 * sfc_state%v(i,J-1)**2 + asu2 * sfc_state%v(i,J)**2) * I_av if ((taux2 + tauy2 > 0.0) .and. .not.CS%ustar_shelf_from_vel) then if (CS%ustar_max >= 0.0) then @@ -419,12 +501,13 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) ! Calculate insitu densities and expansion coefficients call calculate_density(sfc_state%sst(:,j), sfc_state%sss(:,j), p_int, Rhoml(:), & CS%eqn_of_state, EOSdom) - call calculate_density_derivs(sfc_state%sst(:,j), sfc_state%sss(:,j), p_int, dR0_dT, dR0_dS, & - CS%eqn_of_state, EOSdom) + call calculate_density_derivs(sfc_state%sst(:,j), sfc_state%sss(:,j), p_int, & + dR0_dT, dR0_dS, CS%eqn_of_state, EOSdom) do i=is,ie if ((sfc_state%ocean_mass(i,j) > CS%col_mass_melt_threshold) .and. & - (ISS%area_shelf_h(i,j) > 0.0) .and. CS%isthermo) then + (ISS%area_shelf_h(i,j) > 0.0) .and. CS%isthermo & + .and. ISS%melt_mask(i,j)>0.0) then if (CS%threeeq) then ! Iteratively determine a self-consistent set of fluxes, with the ocean @@ -440,11 +523,12 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) if (absf*sfc_state%Hml(i,j) <= VK*ustar_h) then ; hBL_neut = sfc_state%Hml(i,j) else ; hBL_neut = (VK*ustar_h) / absf ; endif hBL_neut_h_molec = ZETA_N * ((hBL_neut * ustar_h) / (5.0 * CS%kv_molec)) + ln_neut = 0.0 ; if (hBL_neut_h_molec > 1.0) ln_neut = log(hBL_neut_h_molec) + n_star_term = (ZETA_N * hBL_neut * VK) / (Rf_crit * ustar_h**3) ! Determine the mixed layer buoyancy flux, wB_flux. dB_dS = (US%L_to_Z**2*CS%g_Earth / Rhoml(i)) * dR0_dS(i) dB_dT = (US%L_to_Z**2*CS%g_Earth / Rhoml(i)) * dR0_dT(i) - ln_neut = 0.0 ; if (hBL_neut_h_molec > 1.0) ln_neut = log(hBL_neut_h_molec) if (CS%find_salt_root) then ! Solve for the skin salinity using the linearized liquidus parameters and @@ -474,9 +558,8 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) ! Safety check if (Sbdry(i,j) < 0.) then - write(mesg,*) 'sfc_state%sss(i,j) = ',sfc_state%sss(i,j), 'S_a, S_b, S_c', S_a, S_b, S_c - call MOM_error(WARNING, mesg, .true.) - write(mesg,*) 'I,J,Sbdry1,Sbdry2',i,j,Sbdry1,Sbdry2 + write(mesg,*) 'sfc_state%sss(i,j) = ',US%S_to_ppt*sfc_state%sss(i,j), & + 'S_a, S_b, S_c', US%ppt_to_S*S_a, S_b, US%S_to_ppt*S_c call MOM_error(WARNING, mesg, .true.) call MOM_error(FATAL, "shelf_calc_flux: Negative salinity (Sbdry).") endif @@ -488,81 +571,168 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) do it1 = 1,20 ! Determine the potential temperature at the ice-ocean interface. - call calculate_TFreeze(Sbdry(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state, & - pres_scale=US%RL2_T2_to_Pa) + ! The following two lines are equivalent: + ! call calculate_TFreeze(Sbdry(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state, scale_from_EOS=.true.) + call calculate_TFreeze(Sbdry(i:i,j), p_int(i:i), ISS%tfreeze(i:i,j), CS%eqn_of_state) dT_ustar = (ISS%tfreeze(i,j) - sfc_state%sst(i,j)) * ustar_h dS_ustar = (Sbdry(i,j) - sfc_state%sss(i,j)) * ustar_h - ! First, determine the buoyancy flux assuming no effects of stability - ! on the turbulence. Following H & J '99, this limit also applies - ! when the buoyancy flux is destabilizing. - - if (CS%const_gamma) then ! if using a constant gamma_T - ! note the different form, here I_Gam_T is NOT 1/Gam_T! + if (CS%const_gamma) then + ! If using a constant gamma_T, there are no effects of the buoyancy flux on the turbulence. I_Gam_T = CS%Gamma_T_3EQ I_Gam_S = CS%Gamma_S_3EQ - else - Gam_turb = I_VK * (ln_neut + (0.5 * I_ZETA_N - 1.0)) + wT_flux = dT_ustar * CS%Gamma_T_3EQ + wB_flux = dB_dS * (dS_ustar * CS%Gamma_S_3EQ) + dB_dT * wT_flux + elseif (.not.CS%buoy_flux_itt_bugfix) then + ! Gamma_T and gamma_S are a function of the buoyancy flux, and there should have been + ! iteration to find the root where wB_flux is consistent with the values of gamma with + ! that flux, but it was omitted. + Gam_turb = I_VK * (ln_neut + (I_2Zeta_N - 1.0)) I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb) I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb) - endif + wB_flux = dB_dS * (dS_ustar * I_Gam_S) + dB_dT * (dT_ustar * I_Gam_T) - wT_flux = dT_ustar * I_Gam_T - wB_flux = dB_dS * (dS_ustar * I_Gam_S) + dB_dT * wT_flux + if (wB_flux < 0.0) then ! The stabilising buoyancy flux reduces the turbulent fluxes. + I_n_star = sqrt(1.0 - n_star_term * wB_flux) + if (hBL_neut_h_molec > I_n_star**2) then + Gam_turb = I_VK * ((ln_neut - 2.0*log(I_n_star)) + (I_2Zeta_N*I_n_star - 1.0)) + else ! The layer dominated by molecular viscosity is smaller than the boundary layer. + Gam_turb = I_VK * (I_2Zeta_N*I_n_star - 1.0) + endif + I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb) + I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb) + endif + wT_flux = dT_ustar * I_Gam_T + else ! gamma_T and gamma_S are a function of the buoyancy flux with proper iteration. + ! Find the root where wB_flux is consistent with the values of gamma with that flux. + + ! First, determine the buoyancy flux assuming no effects of stability + ! on the turbulence. Following H & J '99, this limit also applies + ! when the buoyancy flux is destabilizing. + Gam_turb = I_VK * (ln_neut + (I_2Zeta_N - 1.0)) + I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb) + I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb) + wB_flux = (dB_dS * dS_ustar) * I_Gam_S + (dB_dT * dT_ustar) * I_Gam_T - if (wB_flux < 0.0) then - ! The buoyancy flux is stabilizing and will reduce the tubulent - ! fluxes, and iteration is required. - n_star_term = (ZETA_N/RC) * (hBL_neut * VK) / (ustar_h)**3 - do it3 = 1,30 - ! n_star <= 1.0 is the ratio of working boundary layer thickness - ! to the neutral thickness. - ! hBL = n_star*hBL_neut ; hSub = 1/8*n_star*hBL + if (wB_flux < 0.0) then + ! The buoyancy flux is stabilizing and will reduce the turbulent + ! fluxes, and iteration is required. + ! n_star <= 1.0 is the ratio of working boundary layer thickness + ! to the neutral thickness. I_n_star is its inverse. I_n_star = sqrt(1.0 - n_star_term * wB_flux) - dIns_dwB = 0.5 * n_star_term / I_n_star if (hBL_neut_h_molec > I_n_star**2) then - Gam_turb = I_VK * ((ln_neut - 2.0*log(I_n_star)) + & - (0.5*I_ZETA_N*I_n_star - 1.0)) - dG_dwB = I_VK * ( -2.0 / I_n_star + (0.5 * I_ZETA_N)) * dIns_dwB - else - ! The layer dominated by molecular viscosity is smaller than - ! the assumed boundary layer. This should be rare! - Gam_turb = I_VK * (0.5 * I_ZETA_N*I_n_star - 1.0) - dG_dwB = I_VK * (0.5 * I_ZETA_N) * dIns_dwB + Gam_turb = I_VK * ((ln_neut - 2.0*log(I_n_star)) + (I_2Zeta_N*I_n_star - 1.0)) + else ! The layer dominated by molecular viscosity is smaller than the boundary layer. + Gam_turb = I_VK * (I_2Zeta_N*I_n_star - 1.0) endif - - if (CS%const_gamma) then ! if using a constant gamma_T - ! note the different form, here I_Gam_T is NOT 1/Gam_T! - I_Gam_T = CS%Gamma_T_3EQ - I_Gam_S = CS%Gamma_S_3EQ - else - I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb) - I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb) + I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb) + I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb) + + wB_flux_new = (dB_dS * dS_ustar) * I_Gam_S + (dB_dT * dT_ustar) * I_Gam_T + root_found = (abs(wB_flux_new - wB_flux) < CS%buoy_flux_tol*(abs(wB_flux_new) + abs(wB_flux))) + ! Do not update the flux if its maagnitude would be increased by the otherwise + ! stabilizing buoyancy fluxes. This can happen when the buoyancy flux + ! is stabilizing when one of the heat or salt fluxes are destabilizing due + ! to their different molecular properties. + if (wB_flux_new <= wB_flux) root_found = .true. + + if (.not.root_found) then + wB_flux_max = 0.0 ; DwB_max = wB_flux + wB_flux_min = wB_flux ; DwB_min = wB_flux_new - wB_flux + + if ((wB_flux_min*n_star_term < (1.0 - hBL_neut_h_molec)) .and. & + ((1.0 - hBL_neut_h_molec) < wB_flux_max*n_star_term)) then + ! The derivative of Gam_turb with wB_flux has a discontinuous change within the + ! bracketed range of values. Take this discontinous slope value for a first + ! guess, because Newton's method and the false position method may not converge + ! quickly when this discontinuity is between a guess and the solution. + wB_flux = (1.0 - hBL_neut_h_molec) / n_star_term + I_n_star = sqrt(hBL_neut_h_molec) + Gam_turb = I_VK * (I_2Zeta_N*I_n_star - 1.0) + I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb) + I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb) + wB_flux_new = (dB_dS * dS_ustar) * I_Gam_S + (dB_dT * dT_ustar) * I_Gam_T + + if (abs(wB_flux_new - wB_flux) <= CS%buoy_flux_tol*(abs(wB_flux_new) + abs(wB_flux))) then + ! The root has been found to within the tolerance at the kink. This should be very rare. + root_found = .true. + elseif (wB_flux_new > wB_flux) then + ! The solution is in the limit where abs(wB_flux) is small and + ! Gam_turb = I_VK * ((ln_neut - 2.0*log(I_n_star)) + (I_2Zeta_N*I_n_star - 1.0)) + wB_flux_min = wB_flux ; DwB_min = wB_flux_new - wB_flux + else + ! The solution is in the limt where abs(wB_flux) is large and + ! Gam_turb = I_VK * (I_2Zeta_N*I_n_star - 1.0) + wB_flux_max = wB_flux ; DwB_max = wB_flux_new - wB_flux + endif + endif endif - wT_flux = dT_ustar * I_Gam_T - wB_flux_new = dB_dS * (dS_ustar * I_Gam_S) + dB_dT * wT_flux - - ! Find the root where wB_flux_new = wB_flux. Make the 1.0e-4 below into a parameter? - if (abs(wB_flux_new - wB_flux) < 1.0e-4*(abs(wB_flux_new) + abs(wB_flux))) exit + if (.not.root_found) then + ! Use the false position for the next guess. + wB_flux = wB_flux_min + (wB_flux_max-wB_flux_min) * (DwB_min / (DwB_min - DwB_max)) + + do it3 = 1,30 + ! Iterate using Newton's method with bounds or the false position method to find the root. + + I_n_star = sqrt(1.0 - n_star_term * wB_flux) + dIns_dwB = -0.5 * n_star_term / I_n_star + if (hBL_neut_h_molec > I_n_star**2) then + Gam_turb = I_VK * ((ln_neut - 2.0*log(I_n_star)) + (I_2Zeta_N*I_n_star - 1.0)) + dG_dwB = I_VK * (( -2.0 / I_n_star + I_2Zeta_N) * dIns_dwB) + else + ! The layer dominated by molecular viscosity is smaller than the boundary layer. + Gam_turb = I_VK * (I_2Zeta_N*I_n_star - 1.0) + dG_dwB = I_VK * (I_2Zeta_N * dIns_dwB) + endif + I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb) + I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb) + wB_flux_new = (dB_dS * dS_ustar) * I_Gam_S + (dB_dT * dT_ustar) * I_Gam_T + + ! Test for convergence to within tolerance at the point where wB_flux_new = wB_flux. + if (abs(wB_flux_new - wB_flux) <= CS%buoy_flux_tol*(abs(wB_flux_new) + abs(wB_flux))) & + root_found = .true. + if (root_found) exit + + dDwB_dwB = -dG_dwB * ((dB_dS * dS_ustar) * I_Gam_S**2 + & + (dB_dT * dT_ustar) * I_Gam_T**2) - 1.0 + if ((dDwB_dwB >= 0.0) .or. & + ( wB_flux - wB_flux_new >= abs(dDwB_dwB)*(wB_flux_max - wB_flux)) .or. & + ( wB_flux - wB_flux_new <= abs(dDwB_dwB)*(wB_flux_min - wB_flux)) ) then + ! Use the False position method to determine the guess for the next iteration when + ! Newton's method would go out of bounds + wB_flux_next = wB_flux_min + (wB_flux_max-wB_flux_min) * (DwB_min / (DwB_min - DwB_max)) + else + ! Use Newton's method for the next guess. + wB_flux_next = wB_flux - (wB_flux_new - wB_flux) / dDwB_dwB + endif + + ! Reset one of the bounds inward. + if (wB_flux_new - wB_flux > 0) then + wB_flux_min = wB_flux ; DwB_min = wB_flux_new - wB_flux + else + wB_flux_max = wB_flux ; DwB_max = wB_flux_new - wB_flux + endif + + ! Update wB_flux + wB_flux = wB_flux_next + enddo ! it3 + endif - dDwB_dwB_in = dG_dwB * (dB_dS * (dS_ustar * I_Gam_S**2) + & - dB_dT * (dT_ustar * I_Gam_T**2)) - 1.0 - ! This is Newton's method without any bounds. Should bounds be needed? - wB_flux_new = wB_flux - (wB_flux_new - wB_flux) / dDwB_dwB_in - enddo !it3 - endif + endif ! End of test for first guess of wB_flux < 0. + wT_flux = dT_ustar * I_Gam_T + endif ! End of test for CS%const_gamma ISS%tflux_ocn(i,j) = RhoCp * wT_flux exch_vel_t(i,j) = ustar_h * I_Gam_T exch_vel_s(i,j) = ustar_h * I_Gam_S ! Calculate the heat flux inside the ice shelf. - ! Vertical adv/diff as in H+J 1999, eqns (26) & approx from (31). + ! Vertical adv/diff as in H+J 1999, equations (26) & approx from (31). ! Q_ice = density_ice * CS%Cp_ice * K_ice * dT/dz (at interface) - ! vertical adv/diff as in H+J 1999, eqs (31) & (26)... + ! vertical adv/diff as in H+J 1999, equations (31) & (26)... ! dT/dz ~= min( (lprec/(density_ice*K_ice))*(CS%Temp_Ice-T_freeze) , 0.0 ) ! If this approximation is not made, iterations are required... See H+J Fig 3. @@ -601,8 +771,7 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) Sbdry_it = (sfc_state%sss(i,j) * mass_exch + CS%Salin_ice * ISS%water_flux(i,j)) / & (mass_exch + ISS%water_flux(i,j)) dS_it = Sbdry_it - Sbdry(i,j) - if (abs(dS_it) < 1.0e-4*(0.5*(sfc_state%sss(i,j) + Sbdry(i,j) + 1.0e-10))) exit - + if (abs(dS_it) < 1.0e-4*(0.5*(sfc_state%sss(i,j) + Sbdry(i,j) + 1.0e-10*US%ppt_to_S))) exit if (dS_it < 0.0) then ! Sbdry is now the upper bound. if (Sb_max_set) then @@ -625,7 +794,8 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) Sbdry(i,j) = Sbdry_it endif ! Sb_min_set - Sbdry(i,j) = Sbdry_it + if (.not.CS%salt_flux_itt_bugfix) Sbdry(i,j) = Sbdry_it + endif ! CS%find_salt_root enddo !it1 @@ -635,9 +805,9 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) ! In the 2-equation form, the mixed layer turbulent exchange velocity ! is specified and large enough that the ocean salinity at the interface ! is about the same as the boundary layer salinity. - - call calculate_TFreeze(sfc_state%sss(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state, & - pres_scale=US%RL2_T2_to_Pa) + ! The following two lines are equivalent: + ! call calculate_TFreeze(Sbdry(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state, scale_from_EOS=.true.) + call calculate_TFreeze(sfc_state%SSS(i:i,j), p_int(i:i), ISS%tfreeze(i:i,j), CS%eqn_of_state) exch_vel_t(i,j) = CS%gamma_t ISS%tflux_ocn(i,j) = RhoCp * exch_vel_t(i,j) * (ISS%tfreeze(i,j) - sfc_state%sst(i,j)) @@ -656,10 +826,20 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) enddo ! i-loop enddo ! j-loop + if (allocated(sfc_state%frazil)) then + add_frazil = .true. + else + add_frazil = .false. + endif do j=js,je ; do i=is,ie ! ISS%water_flux = net liquid water into the ocean [R Z T-1 ~> kg m-2 s-1] - fluxes%iceshelf_melt(i,j) = ISS%water_flux(i,j) * CS%flux_factor + if (CS%flux_factor/=1.0) then + ISS%water_flux(i,j) = ISS%water_flux(i,j) * CS%flux_factor + ISS%tflux_ocn(i,j) = ISS%tflux_ocn(i,j) * CS%flux_factor + if (CS%threeeq .and. ISS%tflux_ocn(i,j) < 0.0 .and. (.not. CS%insulator)) & + ISS%tflux_shelf(i,j)=ISS%tflux_ocn(i,j) + CS%Lat_fusion * ISS%water_flux(i,j) + endif if ((sfc_state%ocean_mass(i,j) > CS%col_mass_melt_threshold) .and. & (ISS%area_shelf_h(i,j) > 0.0) .and. (CS%isthermo)) then @@ -668,7 +848,6 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) ! This is needed for the ISOMIP test case. if (ISS%mass_shelf(i,j) < CS%Rho_ocn*CS%cutoff_depth) then ISS%water_flux(i,j) = 0.0 - fluxes%iceshelf_melt(i,j) = 0.0 endif ! Compute haline driving, which is one of the diags. used in ISOMIP if (exch_vel_s(i,j)>0.) haline_driving(i,j) = (ISS%water_flux(i,j) * Sbdry(i,j)) / (CS%Rho_ocn * exch_vel_s(i,j)) @@ -676,10 +855,10 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) !!!!!!!!!!!!!!!!!!!!!!!!!!!!Safety checks !!!!!!!!!!!!!!!!!!!!!!!!! !1)Check if haline_driving computed above is consistent with ! haline_driving = sfc_state%sss - Sbdry - !if (fluxes%iceshelf_melt(i,j) /= 0.0) then + !if (ISS%water_flux(i,j) /= 0.0) then ! if (haline_driving(i,j) /= (sfc_state%sss(i,j) - Sbdry(i,j))) then - ! write(mesg,*) 'at i,j=',i,j,' haline_driving, sss-Sbdry',haline_driving(i,j), & - ! (sfc_state%sss(i,j) - Sbdry(i,j)) + ! write(mesg,*) 'at i,j=',i,j,' haline_driving, sss-Sbdry',US%S_to_ppt*haline_driving(i,j), & + ! US%S_to_ppt*(sfc_state%sss(i,j) - Sbdry(i,j)) ! call MOM_error(FATAL, & ! "shelf_calc_flux: Inconsistency in melt and haline_driving"//trim(mesg)) ! endif @@ -687,8 +866,8 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) ! 2) check if |melt| > 0 when ustar_shelf = 0. ! this should never happen - if ((abs(fluxes%iceshelf_melt(i,j))>0.0) .and. (fluxes%ustar_shelf(i,j) == 0.0)) then - write(mesg,*) "|melt| = ",fluxes%iceshelf_melt(i,j)," > 0 and ustar_shelf = 0. at i,j", i, j + if ((abs(ISS%water_flux(i,j))>0.0) .and. (fluxes%ustar_shelf(i,j) == 0.0)) then + write(mesg,*) "|melt| = ",ISS%water_flux(i,j)," > 0 and ustar_shelf = 0. at i,j", i, j call MOM_error(FATAL, "shelf_calc_flux: "//trim(mesg)) endif !!!!!!!!!!!!!!!!!!!!!!!!!!!!End of safety checks !!!!!!!!!!!!!!!!!!! @@ -696,11 +875,15 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) ! This is grounded ice, that could be modified to melt if a geothermal heat flux were used. haline_driving(i,j) = 0.0 ISS%water_flux(i,j) = 0.0 - fluxes%iceshelf_melt(i,j) = 0.0 endif ! area_shelf_h ! mass flux [R Z L2 T-1 ~> kg s-1], part of ISOMIP diags. mass_flux(i,j) = ISS%water_flux(i,j) * ISS%area_shelf_h(i,j) + + !Add frazil formation + if (add_frazil .and. (ISS%hmask(i,j) == 1 .or. ISS%hmask(i,j) == 2)) & + ISS%water_flux(i,j) = ISS%water_flux(i,j) - ISS%frazil(i,j) * I_dt_LHF + fluxes%iceshelf_melt(i,j) = ISS%water_flux(i,j) enddo ; enddo ! i- and j-loops if (CS%active_shelf_dynamics .or. CS%override_shelf_movement) then @@ -712,47 +895,72 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) ! Melting has been computed, now is time to update thickness and mass if ( CS%override_shelf_movement .and. (.not.CS%mass_from_file)) then - call change_thickness_using_melt(ISS, G, US, US%s_to_T*time_step, fluxes, CS%density_ice, CS%debug) + if (CS%bmb_diag) dh_bdott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) + call change_thickness_using_melt(ISS, G, US, time_step, fluxes, CS%density_ice, CS%debug) + if (CS%bmb_diag) dh_bdott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) - dh_bdott(is:ie,js:je) if (CS%debug) then - call hchksum(ISS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0, scale=US%Z_to_m) + call hchksum(ISS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0, unscale=US%Z_to_m) call hchksum(ISS%mass_shelf, "mass_shelf after change thickness using melt", G%HI, haloshift=0, & - scale=US%RZ_to_kg_m2) + unscale=US%RZ_to_kg_m2) endif endif ! Melting has been computed, now is time to update thickness and mass with dynamic ice shelf if (CS%active_shelf_dynamics) then - call change_thickness_using_melt(ISS, G, US, US%s_to_T*time_step, fluxes, CS%density_ice, CS%debug) + + ISS%dhdt_shelf(:,:) = ISS%h_shelf(:,:) + + if (CS%bmb_diag) dh_bdott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) + call change_thickness_using_melt(ISS, G, US, time_step, fluxes, CS%density_ice, CS%debug) + if (CS%bmb_diag) dh_bdott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) - dh_bdott(is:ie,js:je) if (CS%debug) then - call hchksum(ISS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0, scale=US%Z_to_m) + call hchksum(ISS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0, unscale=US%Z_to_m) call hchksum(ISS%mass_shelf, "mass_shelf after change thickness using melt", G%HI, haloshift=0, & - scale=US%RZ_to_kg_m2) + unscale=US%RZ_to_kg_m2) endif - endif - - if (CS%debug) call MOM_forcing_chksum("Before add shelf flux", fluxes, G, CS%US, haloshift=0) - call add_shelf_flux(G, US, CS, sfc_state, fluxes) + if (CS%smb_diag) dh_adott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) + call change_thickness_using_precip(CS, ISS, G, US, fluxes, time_step, Time) + if (CS%smb_diag) dh_adott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) - dh_adott(is:ie,js:je) - ! now the thermodynamic data is passed on... time to update the ice dynamic quantities + if (CS%debug) then + call hchksum(ISS%h_shelf, "h_shelf after change thickness using surf acc", G%HI, haloshift=0, unscale=US%Z_to_m) + call hchksum(ISS%mass_shelf, "mass_shelf after change thickness using surf acc", G%HI, haloshift=0, & + unscale=US%RZ_to_kg_m2) + endif - if (CS%active_shelf_dynamics) then update_ice_vel = .false. - coupled_GL = (CS%GL_couple .and. .not.CS%solo_ice_sheet) + coupled_GL = (CS%GL_couple .and. .not. CS%solo_ice_sheet) ! advect the ice shelf, and advance the front. Calving will be in here somewhere as well.. ! when we decide on how to do it - call update_ice_shelf(CS%dCS, ISS, G, US, US%s_to_T*time_step, Time, & + call update_ice_shelf(CS%dCS, ISS, G, US, time_step, Time, CS%calve_ice_shelf_bergs, & sfc_state%ocean_mass, coupled_GL) + do j=js,je ; do i=is,ie + ISS%dhdt_shelf(i,j) = (ISS%h_shelf(i,j) - ISS%dhdt_shelf(i,j))*Itime_step + enddo ; enddo + + call IS_dynamics_post_data(time_step, Time, CS%dCS, ISS, G) endif - call enable_averaging(time_step,Time,CS%diag) + if (CS%shelf_mass_is_dynamic) & + call write_ice_shelf_energy(CS%dCS, G, US, ISS%mass_shelf, ISS%area_shelf_h, Time, & + time_step=real_to_time(time_step, unscale=US%T_to_s) ) + + if (CS%debug) call MOM_forcing_chksum("Before add shelf flux", fluxes, G, CS%US, haloshift=0) + + ! pass on the updated ice sheet geometry (for pressure on ocean) and thermodynamic data + call add_shelf_flux(G, US, CS, sfc_state, fluxes, time_step) + + call enable_averages(time_step, Time, CS%diag) if (CS%id_shelf_mass > 0) call post_data(CS%id_shelf_mass, ISS%mass_shelf, CS%diag) if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, ISS%area_shelf_h, CS%diag) if (CS%id_ustar_shelf > 0) call post_data(CS%id_ustar_shelf, fluxes%ustar_shelf, CS%diag) + if (CS%id_shelf_sfc_mass_flux > 0) call post_data(CS%id_shelf_sfc_mass_flux, fluxes%shelf_sfc_mass_flux, CS%diag) + if (CS%id_melt > 0) call post_data(CS%id_melt, fluxes%iceshelf_melt, CS%diag) if (CS%id_thermal_driving > 0) call post_data(CS%id_thermal_driving, (sfc_state%sst-ISS%tfreeze), CS%diag) if (CS%id_Sbdry > 0) call post_data(CS%id_Sbdry, Sbdry, CS%diag) @@ -765,21 +973,150 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) if (CS%id_exch_vel_t > 0) call post_data(CS%id_exch_vel_t, exch_vel_t, CS%diag) if (CS%id_exch_vel_s > 0) call post_data(CS%id_exch_vel_s, exch_vel_s, CS%diag) if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf, ISS%h_shelf, CS%diag) + if (CS%id_dhdt_shelf > 0) call post_data(CS%id_dhdt_shelf, ISS%dhdt_shelf, CS%diag) if (CS%id_h_mask > 0) call post_data(CS%id_h_mask,ISS%hmask,CS%diag) + if (CS%id_frazil > 0) call post_data(CS%id_frazil,ISS%frazil,CS%diag) + if (CS%active_shelf_dynamics) & + call process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh_adott, dh_bdott) call disable_averaging(CS%diag) + !reset used frazil + if (add_frazil) ISS%frazil(:,:) = 0.0 call cpu_clock_end(id_clock_shelf) + if (CS%debug) call MOM_forcing_chksum("End of shelf calc flux", fluxes, G, CS%US, haloshift=0) + if (CS%rotate_index) then -! call rotate_surface_state(sfc_state,CS%Grid, sfc_state_in,CS%Grid_in,-CS%turns) - call rotate_forcing(fluxes,fluxes_in,-CS%turns) +! call rotate_surface_state(sfc_state, sfc_state_in, CS%Grid_in, -CS%turns) + call rotate_forcing(fluxes, fluxes_in, -CS%turns) + call deallocate_surface_state(sfc_state) + deallocate(sfc_state) + call deallocate_forcing_type(fluxes) + deallocate(fluxes) endif +end subroutine shelf_calc_flux - if (CS%debug) call MOM_forcing_chksum("End of shelf calc flux", fluxes, G, CS%US, haloshift=0) +!> Copies frazil from the ocean surface state to the ice sheet state. Removes frazil that will +!! be used by the ice sheet from the ocean surface state +subroutine adjust_ice_sheet_frazil(sfc_state_in, fluxes_in, CS) + type(surface), target, intent(inout) :: sfc_state_in !< A structure containing fields that + !! describe the surface state of the ocean. The + !! intent is only inout to allow for halo updates. + type(forcing), target, intent(in) :: fluxes_in !< structure containing pointers to any + !! possible thermodynamic or mass-flux forcing fields. + type(ice_shelf_CS), pointer :: CS !< A pointer to the control structure returned + !! by a previous call to initialize_ice_shelf. + ! Local variables + type(ocean_grid_type), pointer :: G => NULL() !< The grid structure used by the ice shelf. + type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe + !! the ice-shelf state + type(surface), pointer :: sfc_state => NULL() + type(forcing), pointer :: fluxes => NULL() + integer :: i,j,is,ie,js,je -end subroutine shelf_calc_flux + G => CS%grid ; ISS => CS%ISS + + if (CS%rotate_index) then + allocate(sfc_state) + call rotate_surface_state(sfc_state_in, sfc_state, G, CS%turns) + allocate(fluxes) + call allocate_forcing_type(fluxes_in, G, fluxes, turns=CS%turns) + call rotate_forcing(fluxes_in, fluxes, CS%turns) + else + sfc_state => sfc_state_in + fluxes => fluxes_in + endif + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + do j=js,je ; do i=is,ie + !Copy frazil to the ice sheet module where ice sheet is present. + !No scaling to account for partial ice-sheet cells is necessary here, as + !this is taken care of when applied to the ice sheet. + if (fluxes%frac_shelf_h(i,j)>0.0) ISS%frazil(i,j) = sfc_state%frazil(i,j) + !Remove the frazil that is used by the ice sheet from sfc_state%frazil + !The sfc_state%frazil is sent to the sea-ice module + sfc_state%frazil(i,j) = sfc_state%frazil(i,j) * (1.0-fluxes%frac_shelf_h(i,j)) + enddo ; enddo + + if (CS%rotate_index) then + call rotate_surface_state(sfc_state, sfc_state_in, G, -CS%turns) + ! call rotate_forcing(fluxes, fluxes_in, -CS%turns) + call deallocate_surface_state(sfc_state) + deallocate(sfc_state) + call deallocate_forcing_type(fluxes) + deallocate(fluxes) + endif +end subroutine adjust_ice_sheet_frazil + +function integrate_over_ice_sheet_area(G, ISS, var, unscale, hemisphere) result(var_out) + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe the ice-shelf state + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: var !< Ice variable to integrate in arbitrary units [A ~> a] + real, intent(in) :: unscale !< Dimensional scaling for variable to integrate [a A-1 ~> 1] + integer, optional, intent(in) :: hemisphere !< 0 for Antarctica only, 1 for Greenland only. Otherwise, all ice sheets + real :: var_out !< Variable integrated over the area of the ice sheet in arbitrary scaled units [A L2 ~> a m2] + + ! Local variables + integer :: IS_ID ! local copy of hemisphere + real, dimension(SZI_(G),SZJ_(G)) :: var_cell !< Variable integrated over the ice-sheet area of each cell + !! in arbitrary units [A L2 ~> a m2] + integer, dimension(SZI_(G),SZJ_(G)) :: mask ! a mask for active cells depending on hemisphere indicated + integer :: i, j + + if (present(hemisphere)) then + IS_ID = hemisphere + else + IS_ID = -1 + endif + + mask(:,:) = 0 + if (IS_ID==0) then !Antarctica (S. Hemisphere) only + do j = G%jsc,G%jec ; do i = G%isc,G%iec + if (ISS%hmask(i,j)>0 .and. G%geoLatT(i,j)<=0.0) mask(i,j)=1 + enddo ; enddo + elseif (IS_ID==1) then !Greenland (N. Hemisphere) only + do j = G%jsc,G%jec ; do i = G%isc,G%iec + if (ISS%hmask(i,j)>0 .and. G%geoLatT(i,j)>0.0) mask(i,j)=1 + enddo ; enddo + else !All ice sheets + mask(G%isc:G%iec,G%jsc:G%jec) = ISS%hmask(G%isc:G%iec,G%jsc:G%jec) + endif + + var_cell(:,:) = 0.0 + do j = G%jsc,G%jec ; do i = G%isc,G%iec + if (mask(i,j)>0) var_cell(i,j) = var(i,j) * ISS%area_shelf_h(i,j) + enddo ; enddo + + var_out = reproducing_sum(var_cell, unscale=unscale*G%US%L_to_m**2) +end function integrate_over_ice_sheet_area + +!> Converts the ice-shelf-to-ocean calving and calving_hflx variables from the ice-shelf state (ISS) type +!! to the ocean public type +subroutine ice_sheet_calving_to_ocean_sfc(CS,US,calving,calving_hflx) + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(:,:), intent(inout) :: calving !< The mass flux per unit area of the ice shelf + !! to convert to bergs [R Z T-1 ~> kg m-2 s-1]. + real, dimension(:,:), intent(inout) :: calving_hflx !< Calving heat flux [Q R Z T-1 ~> W m-2]. + ! Local variables + type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), pointer :: G => NULL() !< A pointer to the ocean grid metric. + integer :: is, ie, js, je + + G=>CS%Grid + ISS => CS%ISS + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + calving = US%RZ_T_to_kg_m2s * ISS%calving(is:ie,js:je) + calving_hflx = US%QRZ_T_to_W_m2 * ISS%calving_hflx(is:ie,js:je) + + !CS%calve_ice_shelf_bergs=.true. + +end subroutine ice_sheet_calving_to_ocean_sfc !> Changes the thickness (mass) of the ice shelf based on sub-ice-shelf melting subroutine change_thickness_using_melt(ISS, G, US, time_step, fluxes, density_ice, debug) @@ -821,27 +1158,27 @@ subroutine change_thickness_using_melt(ISS, G, US, time_step, fluxes, density_ic endif enddo ; enddo - call pass_var(ISS%area_shelf_h, G%domain) - call pass_var(ISS%h_shelf, G%domain) - call pass_var(ISS%hmask, G%domain) + call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) + call pass_var(ISS%h_shelf, G%domain, complete=.false.) + call pass_var(ISS%hmask, G%domain, complete=.false.) call pass_var(ISS%mass_shelf, G%domain) end subroutine change_thickness_using_melt !> This subroutine adds the mechanical forcing fields and perhaps shelf areas, based on !! the ice state in ice_shelf_CS. -subroutine add_shelf_forces(Ocn_grid, US, CS, forces, do_shelf_area, external_call) +subroutine add_shelf_forces(Ocn_grid, US, CS, forces_in, do_shelf_area, external_call) type(ocean_grid_type), intent(in) :: Ocn_grid !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ice_shelf_CS), pointer :: CS !< This module's control structure. - type(mech_forcing), intent(inout) :: forces !< A structure with the + type(mech_forcing), target, intent(inout) :: forces_in !< A structure with the !! driving mechanical forces logical, optional, intent(in) :: do_shelf_area !< If true find the shelf-covered areas. logical, optional, intent(in) :: external_call !< If true the incoming forcing type - !! is using the input grid metric and needs + !! is using the unrotated input grid and may need !! to be rotated. type(ocean_grid_type), pointer :: G => NULL() !< A pointer to the ocean grid metric. -! type(mech_forcing), target :: forces !< A structure with the driving mechanical forces + type(mech_forcing), pointer :: forces !< A structure with the driving mechanical forces real :: kv_rho_ice ! The viscosity of ice divided by its density [L4 T-1 R-1 Z-2 ~> m5 kg-1 s-1]. real :: press_ice ! The pressure of the ice shelf per unit area of ocean (not ice) [R L2 T-2 ~> Pa]. logical :: find_area ! If true find the shelf areas at u & v points. @@ -851,29 +1188,25 @@ subroutine add_shelf_forces(Ocn_grid, US, CS, forces, do_shelf_area, external_ca integer :: i, j, is, ie, js, je, isd, ied, jsd, jed - if (present(external_call)) rotate=external_call - - if ((Ocn_grid%isc /= CS%Grid_in%isc) .or. (Ocn_grid%iec /= CS%Grid_in%iec) .or. & - (Ocn_grid%jsc /= CS%Grid_in%jsc) .or. (Ocn_grid%jec /= CS%Grid_in%jec)) & - call MOM_error(FATAL,"add_shelf_forces: Incompatible Ocean and Ice shelf grids.") + rotate = .false. ; if (present(external_call)) rotate = external_call if (CS%rotate_index .and. rotate) then - call MOM_error(FATAL,"add_shelf_forces: Rotation not implemented for ice shelves.") - ! allocate(forces) - ! call allocate_mech_forcing(forces_in, CS%Grid, forces) - ! call rotate_mech_forcing(forces_in, CS%turns, forces) - ! else - ! if ((Ocn_grid%isc /= CS%Grid%isc) .or. (Ocn_grid%iec /= CS%Grid%iec) .or. & - ! (Ocn_grid%jsc /= CS%Grid%jsc) .or. (Ocn_grid%jec /= CS%Grid%jec)) & - ! call MOM_error(FATAL,"add_shelf_forces: Incompatible Ocean and Ice shelf grids.") + if ((Ocn_grid%isc /= CS%Grid_in%isc) .or. (Ocn_grid%iec /= CS%Grid_in%iec) .or. & + (Ocn_grid%jsc /= CS%Grid_in%jsc) .or. (Ocn_grid%jec /= CS%Grid_in%jec)) & + call MOM_error(FATAL,"add_shelf_forces: Incompatible Ocean and external Ice shelf grids.") + allocate(forces) + call allocate_mech_forcing(forces_in, CS%Grid, forces) + call rotate_mech_forcing(forces_in, CS%turns, forces) + else + if ((Ocn_grid%isc /= CS%Grid%isc) .or. (Ocn_grid%iec /= CS%Grid%iec) .or. & + (Ocn_grid%jsc /= CS%Grid%jsc) .or. (Ocn_grid%jec /= CS%Grid%jec)) & + call MOM_error(FATAL,"add_shelf_forces: Incompatible Ocean and internal Ice shelf grids.") - ! forces=>forces_in + forces=>forces_in endif G=>CS%Grid - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed @@ -929,16 +1262,16 @@ subroutine add_shelf_forces(Ocn_grid, US, CS, forces, do_shelf_area, external_ca if (CS%debug) then call uvchksum("rigidity_ice_[uv]", forces%rigidity_ice_u, & forces%rigidity_ice_v, CS%Grid%HI, symmetric=.true., & - scale=US%L_to_m**3*US%L_to_Z*US%s_to_T, scalar_pair=.true.) + unscale=US%L_to_m**3*US%L_to_Z*US%s_to_T, scalar_pair=.true.) call uvchksum("frac_shelf_[uv]", forces%frac_shelf_u, & forces%frac_shelf_v, CS%Grid%HI, symmetric=.true., & scalar_pair=.true.) endif - ! if (CS%rotate_index .and. rotate) then - ! call rotate_mech_forcing(forces, -CS%turns, forces_in) - ! ! TODO: deallocate mech forcing? - ! endif + if (CS%rotate_index .and. rotate) then + call rotate_mech_forcing(forces, -CS%turns, forces_in) + call deallocate_mech_forcing(forces) + endif end subroutine add_shelf_forces @@ -951,8 +1284,7 @@ subroutine add_shelf_pressure(Ocn_grid, US, CS, fluxes) type(ocean_grid_type), pointer :: G => NULL() ! A pointer to ocean's grid structure. real :: press_ice !< The pressure of the ice shelf per unit area of ocean (not ice) [R L2 T-2 ~> Pa]. - integer :: i, j, is, ie, js, je, isd, ied, jsd, jed - + integer :: i, j, is, ie, js, je G=>CS%Grid is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -976,22 +1308,22 @@ subroutine add_shelf_pressure(Ocn_grid, US, CS, fluxes) end subroutine add_shelf_pressure !> Updates surface fluxes that are influenced by sub-ice-shelf melting -subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) +subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes, time_step) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ice_shelf_CS), pointer :: CS !< This module's control structure. type(surface), intent(inout) :: sfc_state !< Surface ocean state type(forcing), intent(inout) :: fluxes !< A structure of surface fluxes that may be used/updated. - + real, intent(in) :: time_step !< Time step over which fluxes are applied [T ~> s] ! local variables real :: frac_shelf !< The fractional area covered by the ice shelf [nondim]. real :: frac_open !< The fractional area of the ocean that is not covered by the ice shelf [nondim]. - real :: delta_mass_shelf !< Change in ice shelf mass over one time step [R Z m2 T-1 ~> kg s-1] + real :: delta_mass_shelf !< Change in ice shelf mass over one time step [R Z L2 T-1 ~> kg s-1] real :: balancing_flux !< The fresh water flux that balances the integrated melt flux [R Z T-1 ~> kg m-2 s-1] - real :: balancing_area !< total area where the balancing flux is applied [m2] + real :: balancing_area !< total area where the balancing flux is applied [L2 ~> m2] type(time_type) :: dTime !< The time step as a time_type type(time_type) :: Time0 !< The previous time (Time-dt) - real, dimension(SZDI_(G),SZDJ_(G)) :: bal_frac !< Fraction of the cel1 where the mass flux + real, dimension(SZDI_(G),SZDJ_(G)) :: bal_frac !< Fraction of the cell where the mass flux !! balancing the net melt flux occurs, 0 to 1 [nondim] real, dimension(SZDI_(G),SZDJ_(G)) :: last_mass_shelf !< Ice shelf mass !! at at previous time (Time-dt) [R Z ~> kg m-2] @@ -1003,6 +1335,8 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) !! at at previous time (Time-dt) real, dimension(SZDI_(G),SZDJ_(G)) :: last_area_shelf_h !< Ice shelf area [L2 ~> m2] !! at at previous time (Time-dt) + real, dimension(SZDI_(G),SZDJ_(G)) :: delta_draft !< change in ice shelf draft thickness [L ~> m] + !! since previous time (Time-dt) type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe !! the ice-shelf state @@ -1027,7 +1361,7 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) if (CS%debug) then if (allocated(sfc_state%taux_shelf) .and. allocated(sfc_state%tauy_shelf)) then call uvchksum("tau[xy]_shelf", sfc_state%taux_shelf, sfc_state%tauy_shelf, & - G%HI, haloshift=0, scale=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) + G%HI, haloshift=0, unscale=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) endif endif @@ -1057,23 +1391,23 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) if (associated(fluxes%evap)) fluxes%evap(i,j) = frac_open * fluxes%evap(i,j) if (associated(fluxes%lprec)) then if (ISS%water_flux(i,j) > 0.0) then - fluxes%lprec(i,j) = frac_shelf*ISS%water_flux(i,j)*CS%flux_factor + frac_open * fluxes%lprec(i,j) + fluxes%lprec(i,j) = frac_shelf*ISS%water_flux(i,j) + frac_open * fluxes%lprec(i,j) else fluxes%lprec(i,j) = frac_open * fluxes%lprec(i,j) - fluxes%evap(i,j) = fluxes%evap(i,j) + frac_shelf*ISS%water_flux(i,j)*CS%flux_factor + fluxes%evap(i,j) = fluxes%evap(i,j) + frac_shelf*ISS%water_flux(i,j) endif endif if (associated(fluxes%sens)) & - fluxes%sens(i,j) = frac_shelf*ISS%tflux_ocn(i,j)*CS%flux_factor + frac_open * fluxes%sens(i,j) + fluxes%sens(i,j) = frac_shelf*ISS%tflux_ocn(i,j) + frac_open * fluxes%sens(i,j) ! The salt flux should be mostly from sea ice, so perhaps none should be intercepted and this should be changed. if (associated(fluxes%salt_flux)) & fluxes%salt_flux(i,j) = frac_shelf * ISS%salt_flux(i,j)*CS%flux_factor + frac_open * fluxes%salt_flux(i,j) endif ; enddo ; enddo if (CS%debug) then - call hchksum(ISS%water_flux, "water_flux add shelf fluxes", G%HI, haloshift=0, scale=US%RZ_T_to_kg_m2s) - call hchksum(ISS%tflux_ocn, "tflux_ocn add shelf fluxes", G%HI, haloshift=0, scale=US%QRZ_T_to_W_m2) + call hchksum(ISS%water_flux, "water_flux add shelf fluxes", G%HI, haloshift=0, unscale=US%RZ_T_to_kg_m2s) + call hchksum(ISS%tflux_ocn, "tflux_ocn add shelf fluxes", G%HI, haloshift=0, unscale=US%QRZ_T_to_W_m2) call MOM_forcing_chksum("After adding shelf fluxes", fluxes, G, CS%US, haloshift=0) endif @@ -1089,7 +1423,7 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) ! take into account changes in mass (or thickness) when imposing ice shelf mass if (CS%override_shelf_movement .and. CS%mass_from_file) then - dTime = real_to_time(CS%time_step) + dTime = real_to_time(CS%time_step, unscale=US%T_to_s) ! Compute changes in mass after at least one full time step if (CS%Time > dTime) then @@ -1097,10 +1431,8 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) do j=js,je ; do i=is,ie last_hmask(i,j) = ISS%hmask(i,j) ; last_area_shelf_h(i,j) = ISS%area_shelf_h(i,j) enddo ; enddo - call time_interp_external(CS%id_read_mass, Time0, last_mass_shelf) + call time_interp_external(CS%mass_handle, Time0, last_mass_shelf, scale=US%kg_m3_to_R*US%m_to_Z) do j=js,je ; do i=is,ie - ! This should only be done if time_interp_extern did an update. - last_mass_shelf(i,j) = US%kg_m3_to_R*US%m_to_Z * last_mass_shelf(i,j) ! Rescale after time_interp last_h_shelf(i,j) = last_mass_shelf(i,j) / CS%density_ice enddo ; enddo @@ -1124,30 +1456,46 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) delta_float_mass(i,j) = 0.0 endif enddo ; enddo - delta_mass_shelf = US%kg_m2s_to_RZ_T*(global_area_integral(delta_float_mass, G, scale=US%RZ_to_kg_m2, & - area=ISS%area_shelf_h) / CS%time_step) + delta_mass_shelf = global_area_integral(delta_float_mass, G, tmp_scale=US%RZ_to_kg_m2, & + area=ISS%area_shelf_h) / CS%time_step else! first time step delta_mass_shelf = 0.0 endif - else ! ice shelf mass does not change - delta_mass_shelf = 0.0 + else + if (CS%active_shelf_dynamics) then ! change in ice_shelf draft + do j=js,je ; do i=is,ie + last_h_shelf(i,j) = ISS%h_shelf(i,j) - time_step * ISS%dhdt_shelf(i,j) + enddo ; enddo + call change_in_draft(CS%dCS, G, last_h_shelf, ISS%h_shelf, delta_draft) + + !this currently assumes area_shelf_h is constant over the time step + delta_mass_shelf = global_area_integral(delta_draft, G, tmp_scale=US%RZ_to_kg_m2, & + area=ISS%area_shelf_h) & + * CS%Rho_ocn / CS%time_step + else ! ice shelf mass does not change + delta_mass_shelf = 0.0 + endif endif - ! average total melt flux over sponge area + ! average total melt flux over sponge area (ISOMIP/MISOMIP only) or open ocean (general case) do j=js,je ; do i=is,ie - if ((G%mask2dT(i,j) > 0.0) .AND. (ISS%area_shelf_h(i,j) * G%IareaT(i,j) < 1.0)) then - ! Uncomment this for some ISOMIP cases: - ! .AND. (G%geoLonT(i,j) >= 790.0) .AND. (G%geoLonT(i,j) <= 800.0)) then + if (CS%constant_sea_level_misomip) then !for ismip/misomip only + if (G%geoLonT(i,j) >= 790.0) then + bal_frac(i,j) = max(1.0 - ISS%area_shelf_h(i,j) * G%IareaT(i,j), 0.0) + else + bal_frac(i,j) = 0.0 + endif + elseif ((G%mask2dT(i,j) > 0.0) .and. (ISS%area_shelf_h(i,j) * G%IareaT(i,j) < 1.0)) then !general case bal_frac(i,j) = max(1.0 - ISS%area_shelf_h(i,j) * G%IareaT(i,j), 0.0) else bal_frac(i,j) = 0.0 endif enddo ; enddo - balancing_area = global_area_integral(bal_frac, G) + balancing_area = global_area_integral(bal_frac, G, area=G%areaT, tmp_scale=1.0) if (balancing_area > 0.0) then - balancing_flux = ( US%kg_m2s_to_RZ_T*global_area_integral(ISS%water_flux, G, scale=US%RZ_T_to_kg_m2s, & - area=ISS%area_shelf_h) + & + balancing_flux = ( global_area_integral(ISS%water_flux, G, tmp_scale=US%RZ_T_to_kg_m2s, & + area=ISS%area_shelf_h) + & delta_mass_shelf ) / balancing_area else balancing_flux = 0.0 @@ -1159,12 +1507,12 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) ! evap is negative, and vprec has units of [R Z T-1 ~> kg m-2 s-1] fluxes%vprec(i,j) = -balancing_flux fluxes%sens(i,j) = fluxes%vprec(i,j) * CS%Cp * CS%T0 ! [Q R Z T-1 ~> W m-2] - fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! [kgSalt/kg R Z T-1 ~> kgSalt m-2 s-1] + fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3*US%S_to_ppt ! [1e-3 S R Z T-1 ~> kgSalt m-2 s-1] endif enddo ; enddo if (CS%debug) then - write(mesg,*) 'Balancing flux (kg/(m^2 s)), dt = ', balancing_flux*US%RZ_T_to_kg_m2s, CS%time_step + write(mesg,*) 'Balancing flux (kg/(m^2 s)), dt = ', balancing_flux*US%RZ_T_to_kg_m2s, US%T_to_s*CS%time_step call MOM_mesg(mesg) call MOM_forcing_chksum("After constant sea level", fluxes, G, CS%US, haloshift=0) endif @@ -1175,14 +1523,16 @@ end subroutine add_shelf_flux !> Initializes shelf model data, parameters and diagnostics -subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, & - fluxes_in, sfc_state_in, Time_in, solo_ice_sheet_in) +subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, directory, forces_in, & + fluxes_in, sfc_state_in, solo_ice_sheet_in, calve_ice_shelf_bergs) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(ocean_grid_type), pointer :: ocn_grid !< The calling ocean model's horizontal grid structure type(time_type), intent(inout) :: Time !< The clock that that will indicate the model time type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure type(MOM_diag_ctrl), pointer :: diag !< This is a pointer to the MOM diag CS !! which will be discarded + type(time_type), intent(in) :: Time_init !< The time at initialization. + character(len=*), intent(in) :: directory !< The directory where the energy file goes. type(mech_forcing), optional, target, intent(inout) :: forces_in !< A structure with the driving mechanical forces type(forcing), optional, target, intent(inout) :: fluxes_in !< A structure containing pointers to any @@ -1190,9 +1540,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, type(surface), target, optional, intent(inout) :: sfc_state_in !< A structure containing fields that !! describe the surface state of the ocean. The !! intent is only inout to allow for halo updates. - type(time_type), optional, intent(in) :: Time_in !< The time at initialization. logical, optional, intent(in) :: solo_ice_sheet_in !< If present, this indicates whether !! a solo ice-sheet driver. + logical, optional :: calve_ice_shelf_bergs !< If true, will add point iceberg calving variables to the ice + !! shelf restart type(ocean_grid_type), pointer :: G => NULL(), OG => NULL() ! Pointers to grids for convenience. type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing @@ -1202,34 +1553,30 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, type(directories) :: dirs type(dyn_horgrid_type), pointer :: dG => NULL() type(dyn_horgrid_type), pointer :: dG_in => NULL() - real :: Z_rescale ! A rescaling factor for heights from the representation in - ! a restart file to the internal representation in this run. - real :: RZ_rescale ! A rescaling factor for mass loads from the representation in - ! a restart file to the internal representation in this run. - real :: L_rescale ! A rescaling factor for horizontal lengths from the representation in - ! a restart file to the internal representation in this run. - real :: meltrate_conversion ! The conversion factor to use for in the melt rate diagnostic. + real :: meltrate_conversion ! The conversion factor to use for in the melt rate diagnostic + ! [T kg R-1 Z-1 m-2 s-1 ~> nondim] real :: dz_ocean_min_float ! The minimum ocean thickness above which the ice shelf is considered ! to be floating when CONST_SEA_LEVEL = True [Z ~> m]. - real :: cdrag, drag_bg_vel - logical :: new_sim, save_IC, var_force + real :: cdrag ! The drag coefficient at the ice-ocean interface [nondim] + real :: drag_bg_vel ! A background velocity used in the quadratic drag [Z T-1 ~> m s-1] + logical :: new_sim, save_IC !This include declares and sets the variable "version". # include "version_variable.h" - character(len=200) :: config - character(len=200) :: IC_file,filename,inputdir + character(len=200) :: IC_file, inputdir ! Input file names or paths character(len=40) :: mdl = "MOM_ice_shelf" ! This module's name. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq integer :: wd_halos(2) - logical :: read_TideAmp, shelf_mass_is_dynamic, debug + logical :: showCallTree + logical :: read_TideAmp, debug logical :: global_indexing - character(len=240) :: Tideamp_file + character(len=240) :: Tideamp_file ! Input file names + character(len=80) :: tideamp_var ! Input file variable names real :: utide ! A tidal velocity [L T-1 ~> m s-1] real :: col_thick_melt_thresh ! An ocean column thickness below which iceshelf melting ! does not occur [Z ~> m] - real, allocatable, dimension(:,:) :: tmp2d ! Temporary array for storing ice shelf input data + real, allocatable, dimension(:,:) :: tmp2d ! Temporary array for ice shelf input data [L T-1 ~> m s-1] + real, allocatable, dimension(:,:) :: maskT ! Temporary array for the tracer points masks [nondim] - type(mech_forcing), pointer :: forces => NULL() - type(forcing), pointer :: fluxes => NULL() type(surface), pointer :: sfc_state => NULL() type(vardesc) :: u_desc, v_desc @@ -1262,61 +1609,75 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, ! Set up the ice-shelf domain and grid wd_halos(:)=0 - allocate(CS%Grid) - call MOM_domains_init(CS%Grid%domain, param_file, min_halo=wd_halos, symmetric=GRID_SYM_,& - domain_name='MOM_Ice_Shelf_in') -! allocate(CS%Grid_in%HI) + allocate(CS%Grid_in) + call MOM_domains_init(CS%Grid_in%domain, param_file, min_halo=wd_halos, symmetric=GRID_SYM_,& + domain_name='MOM_Ice_Shelf_in', US=CS%US) + !allocate(CS%Grid_in%HI) !call hor_index_init(CS%Grid%Domain, CS%Grid%HI, param_file, & ! local_indexing=.not.global_indexing) - call MOM_grid_init(CS%Grid, param_file, CS%US) + call MOM_grid_init(CS%Grid_in, param_file, CS%US) - ! if (CS%rotate_index) then + if (CS%rotate_index) then ! ! TODO: Index rotation currently only works when index rotation does not ! ! change the MPI rank of each domain. Resolving this will require a ! ! modification to FMS PE assignment. ! ! For now, we only permit single-core runs. - ! if (num_PEs() /= 1) & - ! call MOM_error(FATAL, "Index rotation is only supported on one PE.") - - ! call get_param(param_file, mdl, "INDEX_TURNS", CS%turns, & - ! "Number of counterclockwise quarter-turn index rotations.", & - ! default=1, debuggingParam=.true.) - ! ! NOTE: If indices are rotated, then CS%Grid and CS%Grid_in must both be initialized. - ! ! If not rotated, then CS%Grid_in and CS%Ggrid are the same grid. - ! allocate(CS%Grid) - ! !allocate(CS%HI) - ! call clone_MOM_domain(CS%Grid_in%Domain, CS%Grid%Domain,turns=CS%turns) - ! call rotate_hor_index(CS%Grid_in%HI, CS%turns, CS%Grid%HI) - ! call MOM_grid_init(CS%Grid, param_file, CS%US, CS%HI) - ! call create_dyn_horgrid(dG, CS%Grid%HI) - ! call create_dyn_horgrid(dG_in, CS%Grid_in%HI) - ! call clone_MOM_domain(CS%Grid_in%Domain, dG_in%Domain) - ! ! Set up the bottom depth, G%D either analytically or from file - ! call set_grid_metrics(dG_in,param_file,CS%US) - ! call MOM_initialize_topography(dG_in%bathyT, CS%Grid_in%max_depth, dG_in, param_file) - ! call rescale_dyn_horgrid_bathymetry(dG_in, CS%US%Z_to_m) - ! call rotate_dyngrid(dG_in, dG, CS%US, CS%turns) - ! call copy_dyngrid_to_MOM_grid(dG,CS%Grid,CS%US) - ! else - !CS%Grid=>CS%Grid_in - dG => NULL() - !CS%Grid%HI=>CS%Grid_in%HI - call create_dyn_horgrid(dG, CS%Grid%HI) - call clone_MOM_domain(CS%Grid%Domain,dG%Domain) - call set_grid_metrics(dG,param_file,CS%US) - ! Set up the bottom depth, dG%bathyT, either analytically or from file - call MOM_initialize_topography(dG%bathyT, CS%Grid%max_depth, dG, param_file, CS%US) - call copy_dyngrid_to_MOM_grid(dG, CS%Grid, CS%US) - call destroy_dyn_horgrid(dG) -! endif - G => CS%Grid ; CS%Grid_in => CS%Grid + if (num_PEs() /= 1) call MOM_error(FATAL, "Index rotation is only supported on one PE.") + + call get_param(param_file, mdl, "INDEX_TURNS", CS%turns, & + "Number of counterclockwise quarter-turn index rotations.", & + default=1, debuggingParam=.true.) + ! NOTE: If indices are rotated, then CS%Grid and CS%Grid_in must both be initialized. + ! If not rotated, then CS%Grid_in and CS%Ggrid are the same grid. + call create_dyn_horgrid(dG_in, CS%Grid_in%HI) + call clone_MOM_domain(CS%Grid_in%Domain, dG_in%Domain) + call set_grid_metrics(dG_in, param_file, CS%US) + ! Set up the bottom depth, dG_in%bathyT, either analytically or from file + call MOM_initialize_topography(dG_in%bathyT, CS%Grid_in%max_depth, dG_in, param_file, CS%US) + + ! The use of maskT here sets all ice shelf points to be unmasked. + allocate(maskT(dG_in%isd:dG_in%ied,dG_in%jsd:dG_in%jed), source=1.0) + call initialize_masks(dG_in, param_file, CS%US, maskT=maskT) + deallocate(maskT) + + call copy_dyngrid_to_MOM_grid(dG_in, CS%Grid_in, CS%US) + + ! Now set up the rotated ice-shelf grid. + allocate(CS%Grid) + call clone_MOM_domain(CS%Grid_in%Domain, CS%Grid%Domain, turns=CS%turns) + call rotate_hor_index(CS%Grid_in%HI, CS%turns, CS%Grid%HI) + call MOM_grid_init(CS%Grid, param_file, CS%US, CS%Grid%HI) + call create_dyn_horgrid(dG, CS%Grid%HI) + call rotate_dyngrid(dG_in, dG, CS%US, CS%turns) + call copy_dyngrid_to_MOM_grid(dG, CS%Grid, CS%US) + + call destroy_dyn_horgrid(dG_in) + call destroy_dyn_horgrid(dG) + else + CS%Grid => CS%Grid_in + dG => NULL() + call create_dyn_horgrid(dG, CS%Grid%HI) + call clone_MOM_domain(CS%Grid%Domain, dG%Domain) + call set_grid_metrics(dG, param_file, CS%US) + ! Set up the bottom depth, dG%bathyT, either analytically or from file + call MOM_initialize_topography(dG%bathyT, CS%Grid%max_depth, dG, param_file, CS%US) + + ! The use of maskT here sets all ice shelf points to be unmasked. + allocate(maskT(dG%isd:dG%ied,dG%jsd:dG%jed), source=1.0) + call initialize_masks(dG, param_file, CS%US, maskT=maskT) + deallocate(maskT) + + call copy_dyngrid_to_MOM_grid(dG, CS%Grid, CS%US) + call destroy_dyn_horgrid(dG) + endif + G => CS%Grid allocate(CS%diag) - call MOM_IS_diag_mediator_init(G, param_file, CS%diag, component='MOM_IceShelf') + call MOM_IS_diag_mediator_init(G, CS%US, param_file, CS%diag, component='MOM_IceShelf') ! This call sets up the diagnostic axes. These are needed, ! e.g. to generate the target grids below. - call set_IS_axes_info(G, param_file, CS%diag) + call set_IS_axes_info(G, CS%diag) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -1336,7 +1697,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, CS%solo_ice_sheet = .false. if (present(solo_ice_sheet_in)) CS%solo_ice_sheet = solo_ice_sheet_in - if (present(Time_in)) Time = Time_in + !if (present(Time_in)) Time = Time_in CS%override_shelf_movement = .false. ; CS%active_shelf_dynamics = .false. @@ -1346,14 +1707,19 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, call get_param(param_file, mdl, "DEBUG_IS", CS%debug, & "If true, write verbose debugging messages for the ice shelf.", & default=debug) - call get_param(param_file, mdl, "DYNAMIC_SHELF_MASS", shelf_mass_is_dynamic, & + call get_param(param_file, mdl, "DYNAMIC_SHELF_MASS", CS%shelf_mass_is_dynamic, & "If true, the ice sheet mass can evolve with time.", & default=.false.) - if (shelf_mass_is_dynamic) then + if (CS%shelf_mass_is_dynamic) then call get_param(param_file, mdl, "OVERRIDE_SHELF_MOVEMENT", CS%override_shelf_movement, & "If true, user provided code specifies the ice-shelf "//& "movement instead of the dynamic ice model.", default=.false.) CS%active_shelf_dynamics = .not.CS%override_shelf_movement + call get_param(param_file, mdl, "DATA_OVERRIDE_SHELF_FLUXES", & + CS%data_override_shelf_fluxes, & + "If true, the data override feature is used to write "//& + "the surface mass flux deposition. This option is only "//& + "available for MOSAIC grid types.", default=.false.) call get_param(param_file, mdl, "GROUNDING_LINE_INTERPOLATE", CS%GL_regularize, & "If true, regularize the floatation condition at the "//& "grounding line as in Goldberg Holland Schoof 2009.", default=.false.) @@ -1363,6 +1729,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, "will be called. GL_REGULARIZE and GL_COUPLE are exclusive.", & default=.false., do_not_log=CS%GL_regularize) if (CS%GL_regularize) CS%GL_couple = .false. + if (CS%solo_ice_sheet) CS%GL_couple = .false. endif call get_param(param_file, mdl, "SHELF_THERMO", CS%isthermo, & @@ -1375,7 +1742,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, "consistency to calculate the fluxes at the ice-ocean "//& "interface.", default=.true.) call get_param(param_file, mdl, "SHELF_INSULATOR", CS%insulator, & - "If true, the ice shelf is a perfect insulatior "//& + "If true, the ice shelf is a perfect insulator "//& "(no conduction).", default=.false.) call get_param(param_file, mdl, "MELTING_CUTOFF_DEPTH", CS%cutoff_depth, & "Depth above which the melt is set to zero (it must be >= 0) "//& @@ -1390,6 +1757,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, "ISOMIP+ experiments (Ocean3 and Ocean4). "//& "IMPORTANT: it is not currently possible to do "//& "prefect restarts using this flag.", default=.false.) + call get_param(param_file, mdl, "CONST_SEA_LEVEL_MISOMIP", CS%constant_sea_level_misomip, & + "If true, constant_sea_level fluxes are applied only over "//& + "the surface sponge cells from the ISOMIP/MISOMIP configuration", default=.false.) call get_param(param_file, mdl, "MIN_OCEAN_FLOAT_THICK", dz_ocean_min_float, & "The minimum ocean thickness above which the ice shelf is considered to be "//& "floating when CONST_SEA_LEVEL = True.", & @@ -1397,11 +1767,11 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, call get_param(param_file, mdl, "ISOMIP_S_SUR_SPONGE", CS%S0, & "Surface salinity in the restoring region.", & - default=33.8, units='ppt', do_not_log=.true.) + default=33.8, units='ppt', scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "ISOMIP_T_SUR_SPONGE", CS%T0, & "Surface temperature in the restoring region.", & - default=-1.9, units='degC', do_not_log=.true.) + default=-1.9, units='degC', scale=US%degC_to_C, do_not_log=.true.) call get_param(param_file, mdl, "SHELF_3EQ_GAMMA", CS%const_gamma, & "If true, user specifies a constant nondimensional heat-transfer coefficient "//& @@ -1434,49 +1804,49 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, if (CS%find_salt_root) then ! read liquidus coeffs. call get_param(param_file, mdl, "TFREEZE_S0_P0", CS%TFr_0_0, & "this is the freezing potential temperature at "//& - "S=0, P=0.", units="degC", default=0.0, do_not_log=.true.) + "S=0, P=0.", units="degC", default=0.0, scale=US%degC_to_C, do_not_log=.true.) call get_param(param_file, mdl, "DTFREEZE_DS", CS%dTFr_dS, & "this is the derivative of the freezing potential temperature with salinity.", & - units="degC psu-1", default=-0.054, do_not_log=.true.) + units="degC psu-1", default=-0.054, scale=US%degC_to_C*US%S_to_ppt, do_not_log=.true.) call get_param(param_file, mdl, "DTFREEZE_DP", CS%dTFr_dp, & "this is the derivative of the freezing potential temperature with pressure.", & - units="degC Pa-1", default=0.0, scale=US%RL2_T2_to_Pa, do_not_log=.true.) + units="degC Pa-1", default=0.0, scale=US%degC_to_C*US%RL2_T2_to_Pa, do_not_log=.true.) endif call get_param(param_file, mdl, "G_EARTH", CS%g_Earth, & "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80, scale=US%m_s_to_L_T**2*US%Z_to_m) + units="m s-2", default=9.80, scale=US%m_s_to_L_T**2*US%Z_to_m) call get_param(param_file, mdl, "C_P", CS%Cp, & "The heat capacity of sea water, approximated as a constant. "//& "The default value is from the TEOS-10 definition of conservative temperature.", & - units="J kg-1 K-1", default=3991.86795711963, scale=US%J_kg_to_Q) + units="J kg-1 K-1", default=3991.86795711963, scale=US%J_kg_to_Q*US%C_to_degC) call get_param(param_file, mdl, "RHO_0", CS%Rho_ocn, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& + "properties, or with BOUSSINESQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "C_P_ICE", CS%Cp_ice, & - "The heat capacity of ice.", units="J kg-1 K-1", scale=US%J_kg_to_Q, & + "The heat capacity of ice.", units="J kg-1 K-1", scale=US%J_kg_to_Q*US%C_to_degC, & default=2.10e3) if (CS%constant_sea_level) CS%min_ocean_mass_float = dz_ocean_min_float*CS%Rho_ocn call get_param(param_file, mdl, "ICE_SHELF_FLUX_FACTOR", CS%flux_factor, & - "Non-dimensional factor applied to shelf thermodynamic "//& - "fluxes.", units="none", default=1.0) + "Non-dimensional factor applied to shelf thermodynamic fluxes.", & + units="none", default=1.0) call get_param(param_file, mdl, "KV_ICE", CS%kv_ice, & "The viscosity of the ice.", & units="m2 s-1", default=1.0e10, scale=US%Z_to_L**2*US%m_to_L**2*US%T_to_s) call get_param(param_file, mdl, "KV_MOLECULAR", CS%kv_molec, & - "The molecular kinimatic viscosity of sea water at the "//& - "freezing temperature.", units="m2 s-1", default=1.95e-6, scale=US%m2_s_to_Z2_T) + "The molecular kinematic viscosity of sea water at the freezing temperature.", & + units="m2 s-1", default=1.95e-6, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "ICE_SHELF_SALINITY", CS%Salin_ice, & - "The salinity of the ice inside the ice shelf.", units="psu", & - default=0.0) + "The salinity of the ice inside the ice shelf.", & + units="psu", default=0.0, scale=US%ppt_to_S) call get_param(param_file, mdl, "ICE_SHELF_TEMPERATURE", CS%Temp_ice, & "The temperature at the center of the ice shelf.", & - units = "degC", default=-15.0) + units="degC", default=-15.0, scale=US%degC_to_C) call get_param(param_file, mdl, "KD_SALT_MOLECULAR", CS%kd_molec_salt, & "The molecular diffusivity of salt in sea water at the "//& "freezing point.", units="m2 s-1", default=8.02e-10, scale=US%m2_s_to_Z2_T) @@ -1486,7 +1856,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, call get_param(param_file, mdl, "DT_FORCING", CS%time_step, & "The time step for changing forcing, coupling with other "//& "components, or potentially writing certain diagnostics. "//& - "The default value is given by DT.", units="s", default=0.0) + "The default value is given by DT.", units="s", default=0.0, scale=US%s_to_T) call get_param(param_file, mdl, "COL_THICK_MELT_THRESHOLD", col_thick_melt_thresh, & "The minimum ocean column thickness where melting is allowed.", & @@ -1496,17 +1866,37 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, call get_param(param_file, mdl, "READ_TIDEAMP", read_TIDEAMP, & "If true, read a file (given by TIDEAMP_FILE) containing "//& "the tidal amplitude with INT_TIDE_DISSIPATION.", default=.false.) - + call get_param(param_file, mdl, "ICE_SHELF_LINEAR_SHELF_FRAC", CS%Zeta_N, & + "Ratio of HJ99 stability constant xi_N (ratio of maximum "//& + "mixing length to planetary boundary layer depth in "//& + "neutrally stable conditions) to the von Karman constant", & + units="nondim", default=0.13) + call get_param(param_file, mdl, "ICE_SHELF_VK_CNST", CS%Vk, & + "Von Karman constant.", & + units="nondim", default=0.40) + call get_param(param_file, mdl, "ICE_SHELF_RC", CS%Rc, & + "Critical flux Richardson number for ice melt ", & + units="nondim", default=0.20) + call get_param(param_file, mdl, "ICE_SHELF_USTAR_FROM_VEL_BUGFIX", CS%ustar_from_vel_bugfix, & + "Bug fix for ice-area weighting of squared ocean velocities "//& + "used to calculate friction velocity under ice shelves", default=.false.) + call get_param(param_file, mdl, "ICE_SHELF_BUOYANCY_FLUX_ITT_BUGFIX", CS%buoy_flux_itt_bugfix, & + "Bug fix of buoyancy iteration", default=.true., old_name="ICE_SHELF_BUOYANCY_FLUX_ITT_BUG") + call get_param(param_file, mdl, "ICE_SHELF_SALT_FLUX_ITT_BUGFIX", CS%salt_flux_itt_bugfix, & + "Bug fix of salt iteration", default=.true., old_name="ICE_SHELF_SALT_FLUX_ITT_BUG") + call get_param(param_file, mdl, "ICE_SHELF_BUOYANCY_FLUX_ITT_THRESHOLD", CS%buoy_flux_tol, & + "Convergence criterion of Newton's method for ice shelf "//& + "buoyancy iteration.", units="nondim", default=1.0e-4) if (PRESENT(sfc_state_in)) then - allocate(sfc_state) ! assuming frazil is enabled in ocean. This could break some configurations? call allocate_surface_state(sfc_state_in, CS%Grid_in, use_temperature=.true., & do_integrals=.true., omit_frazil=.false., use_iceshelves=.true.) if (CS%rotate_index) then - call rotate_surface_state(sfc_state_in, CS%Grid_in, sfc_state,CS%Grid,CS%turns) + allocate(sfc_state) + call rotate_surface_state(sfc_state_in, sfc_state, CS%Grid, CS%turns) else - sfc_state=>sfc_state_in + sfc_state => sfc_state_in endif endif @@ -1515,19 +1905,21 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, if (read_TIDEAMP) then call get_param(param_file, mdl, "TIDEAMP_FILE", TideAmp_file, & - "The path to the file containing the spatially varying "//& - "tidal amplitudes.", & + "The path to the file containing the spatially varying tidal amplitudes.", & default="tideamp.nc") - call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + call get_param(param_file, mdl, "TIDEAMP_VARNAME", tideamp_var, & + "The name of the tidal amplitude variable in the input file.", & + default="tideamp") + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) TideAmp_file = trim(inputdir) // trim(TideAmp_file) if (CS%rotate_index) then allocate(tmp2d(CS%Grid_in%isd:CS%Grid_in%ied,CS%Grid_in%jsd:CS%Grid_in%jed), source=0.0) - call MOM_read_data(TideAmp_file, 'tideamp', tmp2d, CS%Grid_in%domain, timelevel=1, scale=US%m_s_to_L_T) + call MOM_read_data(TideAmp_file, tideamp_var, tmp2d, CS%Grid_in%domain, timelevel=1, scale=US%m_s_to_L_T) call rotate_array(tmp2d, CS%turns, CS%utide) deallocate(tmp2d) else - call MOM_read_data(TideAmp_file, 'tideamp', CS%utide, CS%Grid%domain, timelevel=1, scale=US%m_s_to_L_T) + call MOM_read_data(TideAmp_file, tideamp_var, CS%utide, CS%Grid%domain, timelevel=1, scale=US%m_s_to_L_T) endif else call get_param(param_file, mdl, "UTIDE", utide, & @@ -1536,7 +1928,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, CS%utide(:,:) = utide endif - call EOS_init(param_file, CS%eqn_of_state) + call EOS_init(param_file, CS%eqn_of_state, US) !! new parameters that need to be in MOM_input @@ -1546,9 +1938,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, "A typical density of ice.", units="kg m-3", default=917.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "INPUT_FLUX_ICE_SHELF", CS%input_flux, & - "volume flux at upstream boundary", units="m2 s-1", default=0.) + "volume flux at upstream boundary", units="m2 s-1", default=0., scale=US%m_to_Z*US%m_s_to_L_T) call get_param(param_file, mdl, "INPUT_THICK_ICE_SHELF", CS%input_thickness, & - "flux thickness at upstream boundary", units="m", default=1000.) + "flux thickness at upstream boundary", units="m", default=1000., scale=US%m_to_Z) else ! This is here because of inconsistent defaults. I don't know why. RWH call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & @@ -1584,6 +1976,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, units="m s-1", default=-1.0, scale=US%m_to_Z*US%T_to_s, & do_not_log=CS%ustar_shelf_from_vel) + if (present(calve_ice_shelf_bergs)) CS%calve_ice_shelf_bergs=calve_ice_shelf_bergs + ! Allocate and initialize state variables to default values call ice_shelf_state_init(CS%ISS, CS%grid) ISS => CS%ISS @@ -1604,12 +1998,12 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, if (new_sim) then ! new simulation, initialize ice thickness as in the static case - call initialize_ice_thickness(ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, CS%Grid, CS%Grid_in, US, param_file, & - CS%rotate_index, CS%turns) + call initialize_ice_thickness(ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, ISS%melt_mask, CS%Grid, CS%Grid_in, & + US, param_file, CS%rotate_index, CS%turns) ! next make sure mass is consistent with thickness do j=G%jsd,G%jed ; do i=G%isd,G%ied - if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2) .or. (ISS%hmask(i,j)==3)) then ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*CS%density_ice endif enddo ; enddo @@ -1634,11 +2028,20 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, call restart_init(param_file, CS%restart_CSp, "Shelf.res") call register_restart_field(ISS%mass_shelf, "shelf_mass", .true., CS%restart_CSp, & - "Ice shelf mass", "kg m-2") + "Ice shelf mass", "kg m-2", conversion=US%RZ_to_kg_m2) call register_restart_field(ISS%area_shelf_h, "shelf_area", .true., CS%restart_CSp, & - "Ice shelf area in cell", "m2") + "Ice shelf area in cell", "m2", conversion=US%L_to_m**2) call register_restart_field(ISS%h_shelf, "h_shelf", .true., CS%restart_CSp, & - "ice sheet/shelf thickness", "m") + "ice sheet/shelf thickness", "m", conversion=US%Z_to_m) + call register_restart_field(ISS%melt_mask, "melt_mask", .false., CS%restart_CSp, & + "Mask that is >0 where ice-shelf melting is allowed", "none") + if (CS%calve_ice_shelf_bergs) then + call register_restart_field(ISS%calving, "shelf_calving", .true., CS%restart_CSp, & + "Calving flux from ice shelf into icebergs", "kg m-2", conversion=US%RZ_to_kg_m2) + call register_restart_field(ISS%calving_hflx, "shelf_calving_hflx", .true., CS%restart_CSp, & + "Calving heat flux from ice shelf into icebergs", "W m-2", conversion=US%QRZ_T_to_W_m2) + endif + if (PRESENT(sfc_state_in)) then if (allocated(sfc_state%taux_shelf) .and. allocated(sfc_state%tauy_shelf)) then u_desc = var_desc("taux_shelf", "Pa", "the zonal stress on the ocean under ice shelves", & @@ -1646,16 +2049,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, v_desc = var_desc("tauy_shelf", "Pa", "the meridional stress on the ocean under ice shelves", & hor_grid='Cv',z_grid='1') call register_restart_pair(sfc_state%taux_shelf, sfc_state%tauy_shelf, u_desc, v_desc, & - .false., CS%restart_CSp) + .false., CS%restart_CSp, conversion=US%RLZ_T2_to_Pa) endif endif - call register_restart_field(US%m_to_Z_restart, "m_to_Z", .false., CS%restart_CSp, & - "Height unit conversion factor", "Z meter-1") - call register_restart_field(US%m_to_L_restart, "m_to_L", .false., CS%restart_CSp, & - "Length unit conversion factor", "L meter-1") - call register_restart_field(US%kg_m3_to_R_restart, "kg_m3_to_R", .false., CS%restart_CSp, & - "Density unit conversion factor", "R m3 kg-1") if (CS%active_shelf_dynamics) then call register_restart_field(ISS%hmask, "h_mask", .true., CS%restart_CSp, & "ice sheet/shelf thickness mask" ,"none") @@ -1663,32 +2060,37 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, if (CS%active_shelf_dynamics) then ! Allocate CS%dCS and specify additional restarts for ice shelf dynamics - call register_ice_shelf_dyn_restarts(CS%Grid_in, param_file, CS%dCS, CS%restart_CSp) + call register_ice_shelf_dyn_restarts(CS%Grid_in, US, param_file, CS%dCS, CS%restart_CSp) endif !GMM - I think we do not need to save ustar_shelf and iceshelf_melt in the restart file !if (.not. CS%solo_ice_sheet) then ! call register_restart_field(fluxes%ustar_shelf, "ustar_shelf", .false., CS%restart_CSp, & - ! "Friction velocity under ice shelves", "m s-1") + ! "Friction velocity under ice shelves", "m s-1", conversion=US%Z_to_m*US%s_to_T) !endif CS%restart_output_dir = dirs%restart_output_dir - + if (present(fluxes_in)) then + call initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) + call register_restart_field(fluxes_in%shelf_sfc_mass_flux, "sfc_mass_flux", .true., CS%restart_CSp, & + "ice shelf surface mass flux deposition from atmosphere", & + 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) + endif if (new_sim .and. (.not. (CS%override_shelf_movement .and. CS%mass_from_file))) then ! This model is initialized internally or from a file. - call initialize_ice_thickness(ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, CS%Grid, CS%Grid_in, US, param_file,& - CS%rotate_index, CS%turns) + call initialize_ice_thickness(ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, ISS%melt_mask, CS%Grid, CS%Grid_in, & + US, param_file, CS%rotate_index, CS%turns) ! next make sure mass is consistent with thickness do j=G%jsd,G%jed ; do i=G%isd,G%ied - if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2) .or. (ISS%hmask(i,j) == 3)) then ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*CS%density_ice endif enddo ; enddo if (CS%debug) then - call hchksum(ISS%mass_shelf, "IS init: mass_shelf", G%HI, haloshift=0, scale=US%RZ_to_kg_m2) - call hchksum(ISS%area_shelf_h, "IS init: area_shelf", G%HI, haloshift=0, scale=US%L_to_m*US%L_to_m) + call hchksum(ISS%mass_shelf, "IS init: mass_shelf", G%HI, haloshift=0, unscale=US%RZ_to_kg_m2) + call hchksum(ISS%area_shelf_h, "IS init: area_shelf", G%HI, haloshift=0, unscale=US%L_to_m*US%L_to_m) call hchksum(ISS%hmask, "IS init: hmask", G%HI, haloshift=0) endif @@ -1698,28 +2100,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: Restoring ice shelf from file.") call restore_state(dirs%input_filename, dirs%restart_input_dir, Time, G, CS%restart_CSp) - if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= US%m_to_Z)) then - Z_rescale = US%m_to_Z / US%m_to_Z_restart - do j=G%jsc,G%jec ; do i=G%isc,G%iec - ISS%h_shelf(i,j) = Z_rescale * ISS%h_shelf(i,j) - enddo ; enddo - endif - - if ((US%m_to_Z_restart*US%kg_m3_to_R_restart /= 0.0) .and. & - (US%m_to_Z*US%kg_m3_to_R /= US%m_to_Z_restart * US%kg_m3_to_R_restart)) then - RZ_rescale = US%m_to_Z*US%kg_m3_to_R / (US%m_to_Z_restart * US%kg_m3_to_R_restart) - do j=G%jsc,G%jec ; do i=G%isc,G%iec - ISS%mass_shelf(i,j) = RZ_rescale * ISS%mass_shelf(i,j) - enddo ; enddo - endif - - if ((US%m_to_L_restart /= 0.0) .and. (US%m_to_L_restart /= US%m_to_L)) then - L_rescale = US%m_to_L / US%m_to_L_restart - do j=G%jsc,G%jec ; do i=G%isc,G%iec - ISS%area_shelf_h(i,j) = L_rescale**2 * ISS%area_shelf_h(i,j) - enddo ; enddo - endif - endif ! .not. new_sim ! do j=G%jsc,G%jec ; do i=G%isc,G%iec @@ -1730,10 +2110,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, id_clock_pass = cpu_clock_id(' Ice shelf halo updates', grain=CLOCK_ROUTINE) call cpu_clock_begin(id_clock_pass) - call pass_var(ISS%area_shelf_h, G%domain) - call pass_var(ISS%h_shelf, G%domain) - call pass_var(ISS%mass_shelf, G%domain) - call pass_var(ISS%hmask, G%domain) + call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) + call pass_var(ISS%h_shelf, G%domain, complete=.false.) + call pass_var(ISS%mass_shelf, G%domain, complete=.false.) + call pass_var(ISS%hmask, G%domain, complete=.false.) call pass_var(G%bathyT, G%domain) call cpu_clock_end(id_clock_pass) @@ -1745,22 +2125,20 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, enddo ; enddo if (CS%debug) then - call hchksum(ISS%area_shelf_h, "IS init: area_shelf_h", G%HI, haloshift=0, scale=US%L_to_m*US%L_to_m) + call hchksum(ISS%area_shelf_h, "IS init: area_shelf_h", G%HI, haloshift=0, unscale=US%L_to_m*US%L_to_m) endif - - CS%Time = Time - if (CS%active_shelf_dynamics .and. .not.CS%isthermo) then ISS%water_flux(:,:) = 0.0 endif - if (shelf_mass_is_dynamic) & - call initialize_ice_shelf_dyn(param_file, Time, ISS, CS%dCS, G, US, CS%diag, new_sim, solo_ice_sheet_in) + if (CS%shelf_mass_is_dynamic) & + call initialize_ice_shelf_dyn(param_file, Time, ISS, CS%dCS, G, US, CS%diag, new_sim, CS%Cp_ice, & + Time_init, directory, solo_ice_sheet_in) - call fix_restart_unit_scaling(US) + call fix_restart_unit_scaling(US, unscaled=.true.) call get_param(param_file, mdl, "SAVE_INITIAL_CONDS", save_IC, & "If true, save the ice shelf initial conditions.", default=.false.) @@ -1770,17 +2148,21 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, if (save_IC .and. .not.((dirs%input_filename(1:1) == 'r') .and. & (LEN_TRIM(dirs%input_filename) == 1))) then + showCallTree = callTree_showQuery() + if (showCallTree) call callTree_waypoint("About to call save_restart (MOM_ice_shelf)") call save_restart(dirs%output_directory, CS%Time, CS%Grid_in, CS%restart_CSp, & filename=IC_file, write_ic=.true.) + if (showCallTree) call callTree_waypoint("Done with call to save_restart (MOM_ice_shelf)") endif - CS%id_area_shelf_h = register_diag_field('ice_shelf_model', 'area_shelf_h', CS%diag%axesT1, CS%Time, & - 'Ice Shelf Area in cell', 'meter-2', conversion=US%L_to_m**2) + 'Ice Shelf Area in cell', 'meter2', conversion=US%L_to_m**2) CS%id_shelf_mass = register_diag_field('ice_shelf_model', 'shelf_mass', CS%diag%axesT1, CS%Time, & 'mass of shelf', 'kg/m^2', conversion=US%RZ_to_kg_m2) CS%id_h_shelf = register_diag_field('ice_shelf_model', 'h_shelf', CS%diag%axesT1, CS%Time, & 'ice shelf thickness', 'm', conversion=US%Z_to_m) + CS%id_dhdt_shelf = register_diag_field('ice_shelf_model', 'dhdt_shelf', CS%diag%axesT1, CS%Time, & + 'change in ice shelf thickness over time', 'm s-1', conversion=US%Z_to_m*US%s_to_T) CS%id_mass_flux = register_diag_field('ice_shelf_model', 'mass_flux', CS%diag%axesT1,& CS%Time, 'Total mass flux of freshwater across the ice-ocean interface.', & 'kg/s', conversion=US%RZ_T_to_kg_m2s*US%L_to_m**2) @@ -1793,11 +2175,13 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, CS%id_melt = register_diag_field('ice_shelf_model', 'melt', CS%diag%axesT1, CS%Time, & 'Ice Shelf Melt Rate', 'm yr-1', conversion=meltrate_conversion) CS%id_thermal_driving = register_diag_field('ice_shelf_model', 'thermal_driving', CS%diag%axesT1, CS%Time, & - 'pot. temp. in the boundary layer minus freezing pot. temp. at the ice-ocean interface.', 'Celsius') + 'pot. temp. in the boundary layer minus freezing pot. temp. at the ice-ocean interface.', & + 'Celsius', conversion=US%C_to_degC) CS%id_haline_driving = register_diag_field('ice_shelf_model', 'haline_driving', CS%diag%axesT1, CS%Time, & - 'salinity in the boundary layer minus salinity at the ice-ocean interface.', 'psu') + 'salinity in the boundary layer minus salinity at the ice-ocean interface.', & + 'psu', conversion=US%S_to_ppt) CS%id_Sbdry = register_diag_field('ice_shelf_model', 'sbdry', CS%diag%axesT1, CS%Time, & - 'salinity at the ice-ocean interface.', 'psu') + 'salinity at the ice-ocean interface.', 'psu', conversion=US%S_to_ppt) CS%id_u_ml = register_diag_field('ice_shelf_model', 'u_ml', CS%diag%axesCu1, CS%Time, & 'Eastward vel. in the boundary layer (used to compute ustar)', 'm s-1', conversion=US%L_T_to_m_s) CS%id_v_ml = register_diag_field('ice_shelf_model', 'v_ml', CS%diag%axesCv1, CS%Time, & @@ -1807,18 +2191,197 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, CS%id_exch_vel_t = register_diag_field('ice_shelf_model', 'exch_vel_t', CS%diag%axesT1, CS%Time, & 'Sub-shelf thermal exchange velocity', 'm s-1' , conversion=US%Z_to_m*US%s_to_T) CS%id_tfreeze = register_diag_field('ice_shelf_model', 'tfreeze', CS%diag%axesT1, CS%Time, & - 'In Situ Freezing point at ice shelf interface', 'degC') + 'In Situ Freezing point at ice shelf interface', 'degC', conversion=US%C_to_degC) CS%id_tfl_shelf = register_diag_field('ice_shelf_model', 'tflux_shelf', CS%diag%axesT1, CS%Time, & 'Heat conduction into ice shelf', 'W m-2', conversion=-US%QRZ_T_to_W_m2) CS%id_ustar_shelf = register_diag_field('ice_shelf_model', 'ustar_shelf', CS%diag%axesT1, CS%Time, & 'Fric vel under shelf', 'm/s', conversion=US%Z_to_m*US%s_to_T) + CS%id_frazil = register_diag_field('ice_shelf_model', 'frazil', CS%diag%axesT1, CS%Time, & + 'Frazil heat rejected by the ocean', 'J m-2', conversion=US%Q_to_J_kg*US%RZ_to_kg_m2) if (CS%active_shelf_dynamics) then CS%id_h_mask = register_diag_field('ice_shelf_model', 'h_mask', CS%diag%axesT1, CS%Time, & - 'ice shelf thickness mask', 'none') + 'ice shelf thickness mask', 'none', conversion=1.0) endif + + CS%id_shelf_sfc_mass_flux = register_diag_field('ice_shelf_model', 'sfc_mass_flux', CS%diag%axesT1, CS%Time, & + 'ice shelf surface mass flux deposition from atmosphere', & + 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) + + ! Scalars (area integrated over all ice sheets) + CS%id_vaf = register_scalar_field('ice_shelf_model', 'int_vaf', CS%diag%axesT1, CS%Time, & + 'Area integrated ice sheet volume above floatation', 'm3', conversion=US%Z_to_m*US%L_to_m**2) + CS%id_adott = register_scalar_field('ice_shelf_model', 'int_a', CS%diag%axesT1, CS%Time, & + 'Area integrated change in ice-sheet thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3', conversion=US%Z_to_m*US%L_to_m**2) + CS%id_g_adott = register_scalar_field('ice_shelf_model', 'int_a_ground', CS%diag%axesT1, CS%Time, & + 'Area integrated change in grounded ice-sheet thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3', conversion=US%Z_to_m*US%L_to_m**2) + CS%id_f_adott = register_scalar_field('ice_shelf_model', 'int_a_float', CS%diag%axesT1, CS%Time, & + 'Area integrated change in floating ice-shelf thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3', conversion=US%Z_to_m*US%L_to_m**2) + CS%id_bdott = register_scalar_field('ice_shelf_model', 'int_b', CS%diag%axesT1, CS%Time, & + 'Area integrated change in floating ice-shelf thickness '//& + 'due to basal accum+melt during a DT_THERM time step', 'm3', conversion=US%Z_to_m*US%L_to_m**2) + CS%id_bdott_melt = register_scalar_field('ice_shelf_model', 'int_b_melt', CS%diag%axesT1, CS%Time, & + 'Area integrated basal melt over ice shelves during a DT_THERM time step', & + units='m3', conversion=US%Z_to_m*US%L_to_m**2) + CS%id_bdott_accum = register_scalar_field('ice_shelf_model', 'int_b_accum', CS%diag%axesT1, CS%Time, & + 'Area integrated basal accumulation over ice shelves during a DT_THERM a time step', & + units='m3', conversion=US%Z_to_m*US%L_to_m**2) + CS%id_t_area = register_scalar_field('ice_shelf_model', 'tot_area', CS%diag%axesT1, CS%Time, & + 'Total ice-sheet area', 'm2', conversion=US%L_to_m**2) + CS%id_f_area = register_scalar_field('ice_shelf_model', 'tot_area_float', CS%diag%axesT1, CS%Time, & + 'Total area of floating ice shelves', 'm2', conversion=US%L_to_m**2) + CS%id_g_area = register_scalar_field('ice_shelf_model', 'tot_area_ground', CS%diag%axesT1, CS%Time, & + 'Total area of grounded ice sheets', 'm2', conversion=US%L_to_m**2) + !scalars (area integrated rates over all ice sheets) + CS%id_dvafdt = register_scalar_field('ice_shelf_model', 'int_vafdot', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in ice-sheet volume above floatation', & + units='m3 s-1', conversion=US%Z_to_m*US%L_to_m**2*US%s_to_T) + CS%id_adot = register_scalar_field('ice_shelf_model', 'int_adot', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in ice-sheet thickness due to surface accum+melt', & + units='m3 s-1', conversion=US%Z_to_m*US%L_to_m**2*US%s_to_T) + CS%id_g_adot = register_scalar_field('ice_shelf_model', 'int_adot_ground', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in grounded ice-sheet thickness due to surface accum+melt', & + units='m3 s-1', conversion=US%Z_to_m*US%L_to_m**2*US%s_to_T) + CS%id_f_adot = register_scalar_field('ice_shelf_model', 'int_adot_float', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in floating ice-shelf thickness due to surface accum+melt', & + units='m3 s-1', conversion=US%Z_to_m*US%L_to_m**2*US%s_to_T) + CS%id_bdot = register_scalar_field('ice_shelf_model', 'int_bdot', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in ice-shelf thickness due to basal accum+melt', & + units='m3 s-1', conversion=US%Z_to_m*US%L_to_m**2*US%s_to_T) + CS%id_bdot_melt = register_scalar_field('ice_shelf_model', 'int_bdot_melt', CS%diag%axesT1, CS%Time, & + 'Area integrated basal melt rate over ice shelves', & + units='m3 s-1', conversion=US%Z_to_m*US%L_to_m**2*US%s_to_T) + CS%id_bdot_accum = register_scalar_field('ice_shelf_model', 'int_bdot_accum', CS%diag%axesT1, CS%Time, & + 'Area integrated basal accumulation rate over ice shelves', & + units='m3 s-1', conversion=US%Z_to_m*US%L_to_m**2*US%s_to_T) + + !scalars (area integrated over the Antarctic ice sheet) + CS%id_Ant_vaf = register_scalar_field('ice_shelf_model', 'int_vaf_A', CS%diag%axesT1, CS%Time, & + 'Area integrated Antarctic ice sheet volume above floatation', 'm3', conversion=US%Z_to_m*US%L_to_m**2) + CS%id_Ant_adott = register_scalar_field('ice_shelf_model', 'int_a_A', CS%diag%axesT1, CS%Time, & + 'Area integrated (Antarctic ice sheet) change in ice-sheet thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3', conversion=US%Z_to_m*US%L_to_m**2) + CS%id_Ant_g_adott = register_scalar_field('ice_shelf_model', 'int_a_ground_A', CS%diag%axesT1, CS%Time, & + 'Area integrated change in Antarctic grounded ice-sheet thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3', conversion=US%Z_to_m*US%L_to_m**2) + CS%id_Ant_f_adott = register_scalar_field('ice_shelf_model', 'int_a_float_A', CS%diag%axesT1, CS%Time, & + 'Area integrated change in Antarctic floating ice-shelf thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3', conversion=US%Z_to_m*US%L_to_m**2) + CS%id_Ant_bdott = register_scalar_field('ice_shelf_model', 'int_b_A', CS%diag%axesT1, CS%Time, & + 'Area integrated change in Antarctic floating ice-shelf thickness '//& + 'due to basal accum+melt during a DT_THERM time step', 'm3', conversion=US%Z_to_m*US%L_to_m**2) + CS%id_Ant_bdott_melt = register_scalar_field('ice_shelf_model', 'int_b_melt_A', CS%diag%axesT1, CS%Time, & + 'Area integrated basal melt over Antarctic ice shelves during a DT_THERM time step', & + units='m3', conversion=US%Z_to_m*US%L_to_m**2) + CS%id_Ant_bdott_accum = register_scalar_field('ice_shelf_model', 'int_b_accum_A', CS%diag%axesT1, CS%Time, & + 'Area integrated basal accumulation over Antarctic ice shelves during a DT_THERM a time step', & + units='m3', conversion=US%Z_to_m*US%L_to_m**2) + CS%id_Ant_t_area = register_scalar_field('ice_shelf_model', 'tot_area_A', CS%diag%axesT1, CS%Time, & + 'Total area of Antarctic ice sheet', 'm2', conversion=US%L_to_m**2) + CS%id_Ant_f_area = register_scalar_field('ice_shelf_model', 'tot_area_float_A', CS%diag%axesT1, CS%Time, & + 'Total area of Antarctic floating ice shelves', 'm2', conversion=US%L_to_m**2) + CS%id_Ant_g_area = register_scalar_field('ice_shelf_model', 'tot_area_ground_A', CS%diag%axesT1, CS%Time, & + 'Total area of Antarctic grounded ice sheet', 'm2', conversion=US%L_to_m**2) + !scalars (area integrated rates over the Antarctic ice sheet) + CS%id_Ant_dvafdt = register_scalar_field('ice_shelf_model', 'int_vafdot_A', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Antarctic ice-sheet volume above floatation', & + units='m3 s-1', conversion=US%Z_to_m*US%L_to_m**2*US%s_to_T) + CS%id_Ant_adot = register_scalar_field('ice_shelf_model', 'int_adot_A', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Antarctic ice-sheet thickness due to surface accum+melt', & + units='m3 s-1', conversion=US%Z_to_m*US%L_to_m**2*US%s_to_T) + CS%id_Ant_g_adot = register_scalar_field('ice_shelf_model', 'int_adot_ground_A', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Antarctic grounded ice-sheet thickness due to surface accum+melt', & + units='m3 s-1', conversion=US%Z_to_m*US%L_to_m**2*US%s_to_T) + CS%id_Ant_f_adot = register_scalar_field('ice_shelf_model', 'int_adot_float_A', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Antarctic floating ice-shelf thickness due to surface accum+melt', & + units='m3 s-1', conversion=US%Z_to_m*US%L_to_m**2*US%s_to_T) + CS%id_Ant_bdot = register_scalar_field('ice_shelf_model', 'int_bdot_A', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Antarctic ice-shelf thickness due to basal accum+melt', & + units='m3 s-1', conversion=US%Z_to_m*US%L_to_m**2*US%s_to_T) + CS%id_Ant_bdot_melt = register_scalar_field('ice_shelf_model', 'int_bdot_melt_A', CS%diag%axesT1, CS%Time, & + 'Area integrated basal melt rate over Antarctic ice shelves', & + units='m3 s-1', conversion=US%Z_to_m*US%L_to_m**2*US%s_to_T) + CS%id_Ant_bdot_accum = register_scalar_field('ice_shelf_model', 'int_bdot_accum_A', CS%diag%axesT1, CS%Time, & + 'Area integrated basal accumulation rate over Antarctic ice shelves', & + units='m3 s-1', conversion=US%Z_to_m*US%L_to_m**2*US%s_to_T) + + !scalars (area integrated over the Greenland ice sheet) + CS%id_Gr_vaf = register_scalar_field('ice_shelf_model', 'int_vaf_G', CS%diag%axesT1, CS%Time, & + 'Area integrated Greenland ice sheet volume above floatation', 'm3', conversion=US%Z_to_m*US%L_to_m**2) + CS%id_Gr_adott = register_scalar_field('ice_shelf_model', 'int_a_G', CS%diag%axesT1, CS%Time, & + 'Area integrated (Greenland ice sheet) change in ice-sheet thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3', conversion=US%Z_to_m*US%L_to_m**2) + CS%id_Gr_g_adott = register_scalar_field('ice_shelf_model', 'int_a_ground_G', CS%diag%axesT1, CS%Time, & + 'Area integrated change in Greenland grounded ice-sheet thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3', conversion=US%Z_to_m*US%L_to_m**2) + CS%id_Gr_f_adott = register_scalar_field('ice_shelf_model', 'int_a_float_G', CS%diag%axesT1, CS%Time, & + 'Area integrated change in Greenland floating ice-shelf thickness ' //& + 'due to surface accum+melt during a DT_THERM time step', 'm3', conversion=US%Z_to_m*US%L_to_m**2) + CS%id_Gr_bdott = register_scalar_field('ice_shelf_model', 'int_b_G', CS%diag%axesT1, CS%Time, & + 'Area integrated change in Greenland floating ice-shelf thickness '//& + 'due to basal accum+melt during a DT_THERM time step', 'm3', conversion=US%Z_to_m*US%L_to_m**2) + CS%id_Gr_bdott_melt = register_scalar_field('ice_shelf_model', 'int_b_melt_G', CS%diag%axesT1, CS%Time, & + 'Area integrated basal melt over Greenland ice shelves during a DT_THERM time step', & + units='m3', conversion=US%Z_to_m*US%L_to_m**2) + CS%id_Gr_bdott_accum = register_scalar_field('ice_shelf_model', 'int_b_accum_G', CS%diag%axesT1, CS%Time, & + 'Area integrated basal accumulation over Greenland ice shelves during a DT_THERM a time step', & + units='m3', conversion=US%Z_to_m*US%L_to_m**2) + CS%id_Gr_t_area = register_scalar_field('ice_shelf_model', 'tot_area_G', CS%diag%axesT1, CS%Time, & + 'Total area of Greenland ice sheet', 'm2', conversion=US%L_to_m**2) + CS%id_Gr_f_area = register_scalar_field('ice_shelf_model', 'tot_area_float_G', CS%diag%axesT1, CS%Time, & + 'Total area of Greenland floating ice shelves', 'm2', conversion=US%L_to_m**2) + CS%id_Gr_g_area = register_scalar_field('ice_shelf_model', 'tot_area_ground_G', CS%diag%axesT1, CS%Time, & + 'Total area of Greenland grounded ice sheet', 'm2', conversion=US%L_to_m**2) + !scalars (area integrated rates over the Greenland ice sheet) + CS%id_Gr_dvafdt = register_scalar_field('ice_shelf_model', 'int_vafdot_G', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Greenland ice-sheet volume above floatation', & + units='m3 s-1', conversion=US%Z_to_m*US%L_to_m**2*US%s_to_T) + CS%id_Gr_adot = register_scalar_field('ice_shelf_model', 'int_adot_G', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Greenland ice-sheet thickness due to surface accum+melt', & + units='m3 s-1', conversion=US%Z_to_m*US%L_to_m**2*US%s_to_T) + CS%id_Gr_g_adot = register_scalar_field('ice_shelf_model', 'int_adot_ground_G', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Greenland grounded ice-sheet thickness due to surface accum+melt', & + units='m3 s-1', conversion=US%Z_to_m*US%L_to_m**2*US%s_to_T) + CS%id_Gr_f_adot = register_scalar_field('ice_shelf_model', 'int_adot_float_G', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Greenland floating ice-shelf thickness due to surface accum+melt', & + units='m3 s-1', conversion=US%Z_to_m*US%L_to_m**2*US%s_to_T) + CS%id_Gr_bdot = register_scalar_field('ice_shelf_model', 'int_bdot_G', CS%diag%axesT1, CS%Time, & + 'Area integrated rate of change in Greenland ice-shelf thickness due to basal accum+melt', & + units='m3 s-1', conversion=US%Z_to_m*US%L_to_m**2*US%s_to_T) + CS%id_Gr_bdot_melt = register_scalar_field('ice_shelf_model', 'int_bdot_melt_G', CS%diag%axesT1, CS%Time, & + 'Area integrated basal melt rate over Greenland ice shelves', & + units='m3 s-1', conversion=US%Z_to_m*US%L_to_m**2*US%s_to_T) + CS%id_Gr_bdot_accum = register_scalar_field('ice_shelf_model', 'int_bdot_accum_G', CS%diag%axesT1, CS%Time, & + 'Area integrated basal accumulation rate over Greenland ice shelves', & + units='m3 s-1', conversion=US%Z_to_m*US%L_to_m**2*US%s_to_T) + + !Flags to calculate diagnostics related to surface/basal mass balance + if (CS%id_adott>0 .or. CS%id_g_adott>0 .or. CS%id_f_adott>0 .or. & + CS%id_adot >0 .or. CS%id_g_adot >0 .or. CS%id_f_adot >0 .or. & + CS%id_Ant_adott>0 .or. CS%id_Ant_g_adott>0 .or. CS%id_Ant_f_adott>0 .or. & + CS%id_Ant_adot >0 .or. CS%id_Ant_g_adot >0 .or. CS%id_Ant_f_adot >0 .or. & + CS%id_Gr_adott>0 .or. CS%id_Gr_g_adott>0 .or. CS%id_Gr_f_adott>0 .or. & + CS%id_Gr_adot >0 .or. CS%id_Gr_g_adot >0 .or. CS%id_Gr_f_adot >0) then + CS%smb_diag=.true. + else + CS%smb_diag=.false. + endif + + if (CS%id_bdott>0 .or. CS%id_bdott_melt>0 .or. CS%id_bdott_accum>0 .or. & + CS%id_bdot >0 .or. CS%id_bdot_melt >0 .or. CS%id_bdot_accum >0 .or. & + CS%id_Ant_bdott>0 .or. CS%id_Ant_bdott_melt>0 .or. CS%id_Ant_bdott_accum>0 .or. & + CS%id_Ant_bdot >0 .or. CS%id_Ant_bdot_melt >0 .or. CS%id_Ant_bdot_accum >0 .or. & + CS%id_Gr_bdott>0 .or. CS%id_Gr_bdott_melt>0 .or. CS%id_Gr_bdott_accum>0 .or. & + CS%id_Gr_bdot >0 .or. CS%id_Gr_bdot_melt >0 .or. CS%id_Gr_bdot_accum >0) then + CS%bmb_diag=.true. + else + CS%bmb_diag=.false. + endif + call MOM_IS_diag_mediator_close_registration(CS%diag) - if (present(fluxes_in)) call initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) if (present(forces_in)) call initialize_ice_shelf_forces(CS, ocn_grid, US, forces_in) end subroutine initialize_ice_shelf @@ -1845,17 +2408,19 @@ subroutine initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) ! when SHELF_THERMO = True. These fluxes are necessary if one wants to ! use either ENERGETICS_SFC_PBL (ALE mode) or BULKMIXEDLAYER (layer mode). call allocate_forcing_type(CS%Grid_in, fluxes_in, ustar=.true., shelf=.true., & - press=.true., water=CS%isthermo, heat=CS%isthermo) + press=.true., water=CS%isthermo, heat=CS%isthermo, shelf_sfc_accumulation=CS%active_shelf_dynamics, & + tau_mag=.true.) else call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating fluxes in solo mode.") - call allocate_forcing_type(CS%Grid_in, fluxes_in, ustar=.true., shelf=.true., press=.true.) + call allocate_forcing_type(CS%Grid_in, fluxes_in, ustar=.true., shelf=.true., & + press=.true., shelf_sfc_accumulation=CS%active_shelf_dynamics, tau_mag=.true.) endif if (CS%rotate_index) then allocate(fluxes) - call allocate_forcing_type(fluxes_in, CS%Grid, fluxes) + call allocate_forcing_type(fluxes_in, CS%Grid, fluxes, turns=CS%turns) call rotate_forcing(fluxes_in, fluxes, CS%turns) else - fluxes=>fluxes_in + fluxes => fluxes_in endif do j=jsd,jed ; do i=isd,ied @@ -1864,22 +2429,32 @@ subroutine initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) if (CS%debug) call hchksum(fluxes%frac_shelf_h, "IS init: frac_shelf_h", G%HI, haloshift=0) call add_shelf_pressure(ocn_grid, US, CS, fluxes) - if (CS%rotate_index) & + if (CS%rotate_index) then call rotate_forcing(fluxes, fluxes_in, -CS%turns) + call deallocate_forcing_type(fluxes) + deallocate(fluxes) + endif end subroutine initialize_ice_shelf_fluxes +!> Allocate and initialize the ice-shelf forcing elements of a mechanical forcing type. +!! This forcing type is on the unrotated grid that is used outside of the MOM6 ice shelf code. subroutine initialize_ice_shelf_forces(CS, ocn_grid, US, forces_in) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure type(ocean_grid_type), pointer :: ocn_grid !< The calling ocean model's horizontal grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(mech_forcing), target, intent(inout) :: forces_in !< A structure with the driving mechanical forces ! Local variables type(mech_forcing), pointer :: forces => NULL() call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating forces.") - call allocate_mech_forcing(CS%Grid_in, forces_in, ustar=.true., shelf=.true., press=.true.) + + if ((Ocn_grid%isc /= CS%Grid_in%isc) .or. (Ocn_grid%iec /= CS%Grid_in%iec) .or. & + (Ocn_grid%jsc /= CS%Grid_in%jsc) .or. (Ocn_grid%jec /= CS%Grid_in%jec)) & + call MOM_error(FATAL,"initialize_ice_shelf_forces: Incompatible ocean and external ice shelf grids.") + + call allocate_mech_forcing(CS%Grid_in, forces_in, ustar=.true., shelf=.true., press=.true., tau_mag=.true.) if (CS%rotate_index) then allocate(forces) call allocate_mech_forcing(forces_in, CS%Grid, forces) @@ -1888,10 +2463,13 @@ subroutine initialize_ice_shelf_forces(CS, ocn_grid, US, forces_in) forces=>forces_in endif - call add_shelf_forces(ocn_grid, US, CS, forces, do_shelf_area=.not.CS%solo_ice_sheet) + call add_shelf_forces(CS%grid, US, CS, forces, do_shelf_area=.not.CS%solo_ice_sheet, & + external_call=.false.) - if (CS%rotate_index) & + if (CS%rotate_index) then call rotate_mech_forcing(forces, -CS%turns, forces_in) + call deallocate_mech_forcing(forces) + endif end subroutine initialize_ice_shelf_forces @@ -1945,7 +2523,7 @@ subroutine initialize_shelf_mass(G, param_file, CS, ISS, new_sim) filename = trim(slasher(inputdir))//trim(shelf_file) call log_param(param_file, mdl, "INPUTDIR/SHELF_FILE", filename) - CS%id_read_mass = init_external_field(filename, shelf_mass_var, & + CS%mass_handle = init_external_field(filename, shelf_mass_var, & MOM_domain=CS%Grid_in%Domain, verbose=CS%debug) if (read_shelf_area) then @@ -1953,7 +2531,7 @@ subroutine initialize_shelf_mass(G, param_file, CS, ISS, new_sim) "The variable in SHELF_FILE with the shelf area.", & default="shelf_area") - CS%id_read_area = init_external_field(filename, shelf_area_var, & + CS%area_handle = init_external_field(filename, shelf_area_var, & MOM_domain=CS%Grid_in%Domain) endif @@ -1976,6 +2554,57 @@ subroutine initialize_shelf_mass(G, param_file, CS, ISS, new_sim) end subroutine initialize_shelf_mass +!> This subroutine applies net accumulation/ablation at the top surface to the dynamic ice shelf. +!! acc_rate[m-s]=surf_mass_flux/density_ice is ablation/accumulation rate +!! positive for accumulation negative for ablation +subroutine change_thickness_using_precip(CS, ISS, G, US, fluxes, time_step, Time) + type(ice_shelf_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(forcing), intent(in) :: fluxes !< A structure of surface fluxes that + !! includes surface mass flux + type(time_type), intent(in) :: Time !< The current model time + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: time_step !< The time step for this update [T ~> s]. + + ! locals + integer :: i, j + real :: I_rho_ice ! The specific volume of ice [R-1 ~> m3 kg-1] + + I_rho_ice = 1.0 / CS%density_ice + + !update time +! CS%Time = Time + +! CS%time_step = time_step + ! update surface mass flux rate +! if (CS%surf_mass_flux_from_file) call update_surf_mass_flux(G, US, CS, ISS, Time) + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + + if (-fluxes%shelf_sfc_mass_flux(i,j) * time_step * I_rho_ice < ISS%h_shelf(i,j)) then + ISS%h_shelf(i,j) = ISS%h_shelf(i,j) + fluxes%shelf_sfc_mass_flux(i,j) * time_step * I_rho_ice + else + ! the ice is about to ablate, so set thickness, area, and mask to zero + ! NOTE: this is not mass conservative should maybe scale salt & heat flux for this cell + ISS%h_shelf(i,j) = 0.0 + ISS%hmask(i,j) = 0.0 + ISS%area_shelf_h(i,j) = 0.0 + endif + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * CS%density_ice + endif + enddo ; enddo + + call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) + call pass_var(ISS%h_shelf, G%domain, complete=.false.) + call pass_var(ISS%hmask, G%domain, complete=.false.) + call pass_var(ISS%mass_shelf, G%domain, complete=.true.) + +end subroutine change_thickness_using_precip + + !> Updates the ice shelf mass using data from a file. subroutine update_shelf_mass(G, US, CS, ISS, Time) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. @@ -1986,7 +2615,7 @@ subroutine update_shelf_mass(G, US, CS, ISS, Time) ! local variables integer :: i, j, is, ie, js, je - real, allocatable, dimension(:,:) :: tmp2d ! Temporary array for storing ice shelf input data + real, allocatable, dimension(:,:) :: tmp2d ! Temporary array for storing ice shelf input data [R Z ~> kg m-2] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -1997,15 +2626,10 @@ subroutine update_shelf_mass(G, US, CS, ISS, Time) allocate(tmp2d(is:ie,js:je), source=0.0) endif - call time_interp_external(CS%id_read_mass, Time, tmp2d) + call time_interp_external(CS%mass_handle, Time, tmp2d, scale=US%kg_m3_to_R*US%m_to_Z) call rotate_array(tmp2d, CS%turns, ISS%mass_shelf) deallocate(tmp2d) - ! This should only be done if time_interp_external did an update. - do j=js,je ; do i=is,ie - ISS%mass_shelf(i,j) = US%kg_m3_to_R*US%m_to_Z * ISS%mass_shelf(i,j) ! Rescale after time_interp - enddo ; enddo - do j=js,je ; do i=is,ie ISS%area_shelf_h(i,j) = 0.0 ISS%hmask(i,j) = 0. @@ -2024,19 +2648,21 @@ subroutine update_shelf_mass(G, US, CS, ISS, Time) CS%min_thickness_simple_calve, halo=0) endif - call pass_var(ISS%area_shelf_h, G%domain) - call pass_var(ISS%h_shelf, G%domain) - call pass_var(ISS%hmask, G%domain) - call pass_var(ISS%mass_shelf, G%domain) + call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) + call pass_var(ISS%h_shelf, G%domain, complete=.false.) + call pass_var(ISS%hmask, G%domain, complete=.false.) + call pass_var(ISS%mass_shelf, G%domain, complete=.true.) end subroutine update_shelf_mass !> Save the ice shelf restart file -subroutine ice_shelf_query(CS, G, frac_shelf_h) +subroutine ice_shelf_query(CS, G, frac_shelf_h, mass_shelf, data_override_shelf_fluxes) type(ice_shelf_CS), pointer :: CS !< ice shelf control structure type(ocean_grid_type), intent(in) :: G !< A pointer to an ocean grid control structure. - real, optional, dimension(SZI_(G),SZJ_(G)) :: frac_shelf_h !< - !< Ice shelf area fraction [nodim]. + real, optional, dimension(SZI_(G),SZJ_(G)), intent(out) :: frac_shelf_h !< Ice shelf area fraction [nondim]. + real, optional, dimension(SZI_(G),SZJ_(G)), intent(out) :: mass_shelf !< Ice shelf mass [R Z ~> kg m-2] + logical, optional :: data_override_shelf_fluxes !< If true, shelf fluxes can be written using + !! the data_override capability (only for MOSAIC grids) integer :: i, j @@ -2047,6 +2673,18 @@ subroutine ice_shelf_query(CS, G, frac_shelf_h) enddo ; enddo endif + if (present(mass_shelf)) then + do j=G%jsd,G%jed ; do i=G%isd,G%ied + mass_shelf(i,j) = 0.0 + if (G%areaT(i,j)>0.) mass_shelf(i,j) = CS%ISS%mass_shelf(i,j) + enddo ; enddo + endif + + if (present(data_override_shelf_fluxes)) then + data_override_shelf_fluxes=.false. + if (CS%active_shelf_dynamics) data_override_shelf_fluxes = CS%data_override_shelf_fluxes + endif + end subroutine ice_shelf_query !> Save the ice shelf restart file @@ -2088,13 +2726,14 @@ subroutine ice_shelf_end(CS) end subroutine ice_shelf_end !> This routine is for stepping a stand-alone ice shelf model without an ocean. -subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in) +subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in, fluxes_in) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure type(time_type), intent(in) :: time_interval !< The time interval for this update [s]. integer, intent(inout) :: nsteps !< The running number of ice shelf steps. type(time_type), intent(inout) :: Time !< The current model time real, optional, intent(in) :: min_time_step_in !< The minimum permitted time step [T ~> s]. - + type(forcing), optional, target, intent(inout) :: fluxes_in !< A structure containing pointers to any + !! possible thermodynamic or mass-flux forcing fields. type(ocean_grid_type), pointer :: G => NULL() ! A pointer to the ocean's grid structure type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing ! various unit conversion factors @@ -2102,19 +2741,28 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in !! the ice-shelf state real :: remaining_time ! The remaining time in this call [T ~> s] real :: time_step ! The internal time step during this call [T ~> s] + real :: full_time_step ! The external time step (sum of internal time steps) during this call [T ~> s] + real :: Ifull_time_step ! The inverse of the external time step [T-1 ~> s-1] real :: min_time_step ! The minimal required timestep that would indicate a fatal problem [T ~> s] character(len=240) :: mesg logical :: update_ice_vel ! If true, it is time to update the ice shelf velocities. - logical :: coupled_GL ! If true the grouding line position is determined based on + logical :: coupled_GL ! If true the grounding line position is determined based on ! coupled ice-ocean dynamics. - integer :: is, iec, js, jec, i, j + integer :: is, ie, js, je, i, j + real :: vaf0, vaf0_A, vaf0_G !The previous volumes above floatation + !for all ice sheets, Antarctica only, or Greenland only [Z L2 ~> m3] + real, dimension(SZI_(CS%grid),SZJ_(CS%grid)) :: & + dh_adott_sum, & ! Surface melt/accumulation over a full time step, used for diagnostics [Z ~> m] + dh_adott ! Surface melt/accumulation over a partial time step, used for diagnostics [Z ~> m] G => CS%grid US => CS%US ISS => CS%ISS - is = G%isc ; iec = G%iec ; js = G%jsc ; jec = G%jec + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - remaining_time = US%s_to_T*time_type_to_real(time_interval) + remaining_time = time_to_real(time_interval, scale=US%s_to_T) + full_time_step = remaining_time + Ifull_time_step = 1./full_time_step if (present (min_time_step_in)) then min_time_step = min_time_step_in @@ -2122,9 +2770,20 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in min_time_step = 1000.0*US%s_to_T ! At 1 km resolution this would imply ice is moving at ~1 meter per second endif - write (mesg,*) "TIME in ice shelf call, yrs: ", time_type_to_real(Time)/(365. * 86400.) + write (mesg,*) "TIME in ice shelf call, yrs: ", time_to_real(Time)/(365. * 86400.) call MOM_mesg("solo_step_ice_shelf: "//mesg, 5) + ISS%dhdt_shelf(:,:) = ISS%h_shelf(:,:) + + dh_adott(:,:)=0.0 + + if (CS%smb_diag) dh_adott_sum(:,:) = 0.0 + + !calculate previous volumes above floatation + if (CS%id_dvafdt > 0) call volume_above_floatation(CS%dCS, G, ISS, vaf0) !all ice sheet + if (CS%id_Ant_dvafdt > 0) call volume_above_floatation(CS%dCS, G, ISS, vaf0_A, hemisphere=0) !Antarctica only + if (CS%id_Gr_dvafdt > 0) call volume_above_floatation(CS%dCS, G, ISS, vaf0_G, hemisphere=1) !Greenland only + do while (remaining_time > 0.0) nsteps = nsteps+1 @@ -2138,6 +2797,11 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in call MOM_mesg("solo_step_ice_shelf: "//mesg, 5) endif + if (CS%smb_diag) dh_adott(is:ie,js:je) = ISS%h_shelf(is:ie,js:je) + call change_thickness_using_precip(CS, ISS, G, US, fluxes_in, time_step, Time) + if (CS%smb_diag) dh_adott_sum(is:ie,js:je) = dh_adott_sum(is:ie,js:je) + & + (ISS%h_shelf(is:ie,js:je) - dh_adott(is:ie,js:je)) + remaining_time = remaining_time - time_step ! If the last mini-timestep is a day or less, we cannot expect velocities to change by much. @@ -2145,18 +2809,248 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in update_ice_vel = ((time_step > min_time_step) .or. (remaining_time > 0.0)) coupled_GL = .false. - call update_ice_shelf(CS%dCS, ISS, G, US, time_step, Time, must_update_vel=update_ice_vel) - - call enable_averages(time_step, Time, CS%diag) - if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, ISS%area_shelf_h, CS%diag) - if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf, ISS%h_shelf, CS%diag) - if (CS%id_h_mask > 0) call post_data(CS%id_h_mask, ISS%hmask, CS%diag) - call disable_averaging(CS%diag) + call update_ice_shelf(CS%dCS, ISS, G, US, time_step, Time, CS%calve_ice_shelf_bergs, & + must_update_vel=update_ice_vel) enddo + call write_ice_shelf_energy(CS%dCS, G, US, ISS%mass_shelf, ISS%area_shelf_h, Time, & + time_step=time_interval) + do j=js,je ; do i=is,ie + ISS%dhdt_shelf(i,j) = (ISS%h_shelf(i,j) - ISS%dhdt_shelf(i,j)) * Ifull_time_step + enddo ; enddo + + call enable_averages(full_time_step, Time, CS%diag) + if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h ,ISS%area_shelf_h,CS%diag) + if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf ,ISS%h_shelf ,CS%diag) + if (CS%id_dhdt_shelf > 0) call post_data(CS%id_dhdt_shelf ,ISS%dhdt_shelf ,CS%diag) + if (CS%id_h_mask > 0) call post_data(CS%id_h_mask ,ISS%hmask ,CS%diag) + call process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Ifull_time_step, dh_adott, dh_adott*0.0) + call disable_averaging(CS%diag) + + call IS_dynamics_post_data(full_time_step, Time, CS%dCS, ISS, G) end subroutine solo_step_ice_shelf +!> Post_data calls for ice-sheet scalars +subroutine process_and_post_scalar_data(CS, vaf0, vaf0_A, vaf0_G, Itime_step, dh_adott, dh_bdott) + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + real :: vaf0 !< The previous volumes above floatation for all ice sheets [Z L2 ~> m3] + real :: vaf0_A !< The previous volumes above floatation for the Antarctic ice sheet [Z L2 ~> m3] + real :: vaf0_G !< The previous volumes above floatation for the Greenland ice sheet [Z L2 ~> m3] + real :: Itime_step !< Inverse of the time step [T-1 ~> s-1] + real, dimension(SZI_(CS%grid),SZJ_(CS%grid)) :: dh_adott !< Surface (plus basal if solo shelf mode) + !! melt/accumulation over a time step [Z ~> m] + real, dimension(SZI_(CS%grid),SZJ_(CS%grid)) :: dh_bdott !< Surface (plus basal if solo shelf mode) + !! melt/accumulation over a time step [Z ~> m] + + ! Local variables + real, dimension(SZI_(CS%grid),SZJ_(CS%grid)) :: tmp ! Temporary field used when calculating diagnostics [various] + real, dimension(SZI_(CS%grid),SZJ_(CS%grid)) :: ones ! Temporary field used when calculating diagnostics [various] + real :: vaf ! The current ice-sheet volume above floatation [Z L2 ~> m3] + real :: val ! Temporary value when calculating scalar diagnostics [various] + type(ocean_grid_type), pointer :: G => NULL() ! A pointer to the ocean's grid structure + type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing various unit conversion factors + type(ice_shelf_state), pointer :: ISS => NULL() ! A structure with elements that describe the ice-shelf state + integer :: is, ie, js, je, i, j + + G => CS%grid + US => CS%US + ISS => CS%ISS + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + !---ALL ICE SHEET---! + if (CS%id_vaf > 0 .or. CS%id_dvafdt > 0) & !calculate current volume above floatation (vaf) + call volume_above_floatation(CS%dCS, G, ISS, vaf) + if (CS%id_vaf > 0) call post_scalar_data(CS%id_vaf ,vaf ,CS%diag) !current vaf + if (CS%id_dvafdt > 0) call post_scalar_data(CS%id_dvafdt,(vaf-vaf0)*Itime_step,CS%diag) !d(vaf)/dt + if (CS%id_adott > 0 .or. CS%id_adot > 0) then !surface accumulation - surface melt + val = integrate_over_ice_sheet_area(G, ISS, dh_adott, unscale=US%Z_to_m) + if (CS%id_adott > 0) call post_scalar_data(CS%id_adott,val ,CS%diag) + if (CS%id_adot > 0) call post_scalar_data(CS%id_adot ,val*Itime_step,CS%diag) + endif + if (CS%id_g_adott > 0 .or. CS%id_g_adot > 0) then !grounded only: surface accumulation - surface melt + call masked_var_grounded(G,CS%dCS,dh_adott,tmp) + val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=US%Z_to_m) + if (CS%id_g_adott > 0) call post_scalar_data(CS%id_g_adott,val ,CS%diag) + if (CS%id_g_adot > 0) call post_scalar_data(CS%id_g_adot ,val*Itime_step,CS%diag) + endif + if (CS%id_f_adott > 0 .or. CS%id_f_adot > 0) then !floating only: surface accumulation - surface melt + call masked_var_grounded(G,CS%dCS,dh_adott,tmp) + do j=js,je ; do i=is,ie + tmp(i,j) = dh_adott(i,j) - tmp(i,j) + enddo ; enddo + val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=US%Z_to_m) + if (CS%id_f_adott > 0) call post_scalar_data(CS%id_f_adott,val ,CS%diag) + if (CS%id_f_adot > 0) call post_scalar_data(CS%id_f_adot ,val*Itime_step,CS%diag) + endif + if (CS%id_bdott > 0 .or. CS%id_bdot > 0) then !bottom accumulation - bottom melt + val = integrate_over_ice_sheet_area(G, ISS, dh_bdott, unscale=US%Z_to_m) + if (CS%id_bdott > 0) call post_scalar_data(CS%id_bdott,val ,CS%diag) + if (CS%id_bdot > 0) call post_scalar_data(CS%id_bdot ,val*Itime_step,CS%diag) + endif + if (CS%id_bdott_melt > 0 .or. CS%id_bdot_melt > 0) then !bottom melt + tmp(:,:)=0.0 + do j=js,je ; do i=is,ie + if (dh_bdott(i,j) < 0) tmp(i,j) = -dh_bdott(i,j) + enddo ; enddo + val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=US%Z_to_m) + if (CS%id_bdott_melt > 0) call post_scalar_data(CS%id_bdott_melt,val ,CS%diag) + if (CS%id_bdot_melt > 0) call post_scalar_data(CS%id_bdot_melt ,val*Itime_step,CS%diag) + endif + if (CS%id_bdott_accum > 0 .or. CS%id_bdot_accum > 0) then !bottom accumulation + tmp(:,:)=0.0 + do j=js,je ; do i=is,ie + if (dh_bdott(i,j) > 0) tmp(i,j) = dh_bdott(i,j) + enddo ; enddo + val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=US%Z_to_m) + if (CS%id_bdott_accum > 0) call post_scalar_data(CS%id_bdott_accum,val ,CS%diag) + if (CS%id_bdot_accum > 0) call post_scalar_data(CS%id_bdot_accum ,val*Itime_step,CS%diag) + endif + if (CS%id_t_area > 0) then !ice sheet area + tmp(:,:) = 1.0 ; val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=1.0) + call post_scalar_data(CS%id_t_area,val,CS%diag) + endif + if (CS%id_g_area > 0 .or. CS%id_f_area > 0) then + ones(:,:) = 1.0 ; call masked_var_grounded(G, CS%dCS, ones, tmp) + if (CS%id_g_area > 0) then !grounded only ice sheet area + val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=1.0) + call post_scalar_data(CS%id_g_area,val,CS%diag) + endif + if (CS%id_f_area > 0) then !floating only ice sheet area (ice shelf area) + val = integrate_over_ice_sheet_area(G, ISS, 1.0-tmp, unscale=1.0) + call post_scalar_data(CS%id_f_area,val,CS%diag) + endif + endif + + !---ANTARCTICA ONLY---! + if (CS%id_Ant_vaf > 0 .or. CS%id_Ant_dvafdt > 0) & !calculate current volume above floatation (vaf) + call volume_above_floatation(CS%dCS, G, ISS, vaf, hemisphere=0) + if (CS%id_Ant_vaf > 0) call post_scalar_data(CS%id_Ant_vaf ,vaf ,CS%diag) !current vaf + if (CS%id_Ant_dvafdt > 0) call post_scalar_data(CS%id_Ant_dvafdt,(vaf-vaf0_A)*Itime_step,CS%diag) !d(vaf)/dt + if (CS%id_Ant_adott > 0 .or. CS%id_Ant_adot > 0) then !surface accumulation - surface melt + val = integrate_over_ice_sheet_area(G, ISS, dh_adott, unscale=US%Z_to_m, hemisphere=0) + if (CS%id_Ant_adott > 0) call post_scalar_data(CS%id_Ant_adott,val ,CS%diag) + if (CS%id_Ant_adot > 0) call post_scalar_data(CS%id_Ant_adot ,val*Itime_step,CS%diag) + endif + if (CS%id_Ant_g_adott > 0 .or. CS%id_Ant_g_adot > 0) then !grounded only: surface accumulation - surface melt + call masked_var_grounded(G,CS%dCS,dh_adott,tmp) + val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=US%Z_to_m, hemisphere=0) + if (CS%id_Ant_g_adott > 0) call post_scalar_data(CS%id_Ant_g_adott,val ,CS%diag) + if (CS%id_Ant_g_adot > 0) call post_scalar_data(CS%id_Ant_g_adot ,val*Itime_step,CS%diag) + endif + if (CS%id_Ant_f_adott > 0 .or. CS%id_Ant_f_adot > 0) then !floating only: surface accumulation - surface melt + call masked_var_grounded(G,CS%dCS,dh_adott,tmp) + do j=js,je ; do i=is,ie + tmp(i,j) = dh_adott(i,j) - tmp(i,j) + enddo ; enddo + val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=US%Z_to_m, hemisphere=0) + if (CS%id_Ant_f_adott > 0) call post_scalar_data(CS%id_Ant_f_adott,val ,CS%diag) + if (CS%id_Ant_f_adot > 0) call post_scalar_data(CS%id_Ant_f_adot ,val*Itime_step,CS%diag) + endif + if (CS%id_Ant_bdott > 0 .or. CS%id_Ant_bdot > 0) then !bottom accumulation - bottom melt + val = integrate_over_ice_sheet_area(G, ISS, dh_bdott, unscale=US%Z_to_m, hemisphere=0) + if (CS%id_Ant_bdott > 0) call post_scalar_data(CS%id_Ant_bdott,val ,CS%diag) + if (CS%id_Ant_bdot > 0) call post_scalar_data(CS%id_Ant_bdot ,val*Itime_step,CS%diag) + endif + if (CS%id_Ant_bdott_melt > 0 .or. CS%id_Ant_bdot_melt > 0) then !bottom melt + tmp(:,:)=0.0 + do j=js,je ; do i=is,ie + if (dh_bdott(i,j) < 0) tmp(i,j) = -dh_bdott(i,j) + enddo ; enddo + val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=US%Z_to_m, hemisphere=0) + if (CS%id_Ant_bdott_melt > 0) call post_scalar_data(CS%id_Ant_bdott_melt,val ,CS%diag) + if (CS%id_Ant_bdot_melt > 0) call post_scalar_data(CS%id_Ant_bdot_melt ,val*Itime_step,CS%diag) + endif + if (CS%id_Ant_bdott_accum > 0 .or. CS%id_Ant_bdot_accum > 0) then !bottom accumulation + tmp(:,:)=0.0 + do j=js,je ; do i=is,ie + if (dh_bdott(i,j) > 0) tmp(i,j) = dh_bdott(i,j) + enddo ; enddo + val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=US%Z_to_m, hemisphere=0) + if (CS%id_Ant_bdott_accum > 0) call post_scalar_data(CS%id_Ant_bdott_accum,val ,CS%diag) + if (CS%id_Ant_bdot_accum > 0) call post_scalar_data(CS%id_Ant_bdot_accum ,val*Itime_step,CS%diag) + endif + if (CS%id_Ant_t_area > 0) then !ice sheet area + tmp(:,:) = 1.0 ; val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=1.0, hemisphere=0) + call post_scalar_data(CS%id_Ant_t_area,val,CS%diag) + endif + if (CS%id_Ant_g_area > 0 .or. CS%id_Ant_f_area > 0) then + ones(:,:) = 1.0 ; call masked_var_grounded(G, CS%dCS, ones, tmp) + if (CS%id_Ant_g_area > 0) then !grounded only ice sheet area + val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=1.0, hemisphere=0) + call post_scalar_data(CS%id_Ant_g_area,val,CS%diag) + endif + if (CS%id_Ant_f_area > 0) then !floating only ice sheet area (ice shelf area) + val = integrate_over_ice_sheet_area(G, ISS, 1.0-tmp, unscale=1.0, hemisphere=0) + call post_scalar_data(CS%id_Ant_f_area,val,CS%diag) + endif + endif + + !---GREENLAND ONLY---! + if (CS%id_Gr_vaf > 0 .or. CS%id_Gr_dvafdt > 0) & !calculate current volume above floatation (vaf) + call volume_above_floatation(CS%dCS, G, ISS, vaf, hemisphere=1) + if (CS%id_Gr_vaf > 0) call post_scalar_data(CS%id_Gr_vaf ,vaf ,CS%diag) !current vaf + if (CS%id_Gr_dvafdt > 0) call post_scalar_data(CS%id_Gr_dvafdt,(vaf-vaf0_A)*Itime_step,CS%diag) !d(vaf)/dt + if (CS%id_Gr_adott > 0 .or. CS%id_Gr_adot > 0) then !surface accumulation - surface melt + val = integrate_over_ice_sheet_area(G, ISS, dh_adott, unscale=US%Z_to_m, hemisphere=1) + if (CS%id_Gr_adott > 0) call post_scalar_data(CS%id_Gr_adott,val ,CS%diag) + if (CS%id_Gr_adot > 0) call post_scalar_data(CS%id_Gr_adot ,val*Itime_step,CS%diag) + endif + if (CS%id_Gr_g_adott > 0 .or. CS%id_Gr_g_adot > 0) then !grounded only: surface accumulation - surface melt + call masked_var_grounded(G,CS%dCS,dh_adott,tmp) + val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=US%Z_to_m, hemisphere=1) + if (CS%id_Gr_g_adott > 0) call post_scalar_data(CS%id_Gr_g_adott,val ,CS%diag) + if (CS%id_Gr_g_adot > 0) call post_scalar_data(CS%id_Gr_g_adot ,val*Itime_step,CS%diag) + endif + if (CS%id_Gr_f_adott > 0 .or. CS%id_Gr_f_adot > 0) then !floating only: surface accumulation - surface melt + call masked_var_grounded(G,CS%dCS,dh_adott,tmp) + do j=js,je ; do i=is,ie + tmp(i,j) = dh_adott(i,j) - tmp(i,j) + enddo ; enddo + val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=US%Z_to_m, hemisphere=1) + if (CS%id_Gr_f_adott > 0) call post_scalar_data(CS%id_Gr_f_adott,val ,CS%diag) + if (CS%id_Gr_f_adot > 0) call post_scalar_data(CS%id_Gr_f_adot ,val*Itime_step,CS%diag) + endif + if (CS%id_Gr_bdott > 0 .or. CS%id_Gr_bdot > 0) then !bottom accumulation - bottom melt + val = integrate_over_ice_sheet_area(G, ISS, dh_bdott, unscale=US%Z_to_m, hemisphere=1) + if (CS%id_Gr_bdott > 0) call post_scalar_data(CS%id_Gr_bdott,val ,CS%diag) + if (CS%id_Gr_bdot > 0) call post_scalar_data(CS%id_Gr_bdot ,val*Itime_step,CS%diag) + endif + if (CS%id_Gr_bdott_melt > 0 .or. CS%id_Gr_bdot_melt > 0) then !bottom melt + tmp(:,:)=0.0 + do j=js,je ; do i=is,ie + if (dh_bdott(i,j) < 0) tmp(i,j) = -dh_bdott(i,j) + enddo ; enddo + val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=US%Z_to_m, hemisphere=1) + if (CS%id_Gr_bdott_melt > 0) call post_scalar_data(CS%id_Gr_bdott_melt,val ,CS%diag) + if (CS%id_Gr_bdot_melt > 0) call post_scalar_data(CS%id_Gr_bdot_melt ,val*Itime_step,CS%diag) + endif + if (CS%id_Gr_bdott_accum > 0 .or. CS%id_Gr_bdot_accum > 0) then !bottom accumulation + tmp(:,:)=0.0 + do j=js,je ; do i=is,ie + if (dh_bdott(i,j) > 0) tmp(i,j) = dh_bdott(i,j) + enddo ; enddo + val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=US%Z_to_m, hemisphere=1) + if (CS%id_Gr_bdott_accum > 0) call post_scalar_data(CS%id_Gr_bdott_accum,val ,CS%diag) + if (CS%id_Gr_bdot_accum > 0) call post_scalar_data(CS%id_Gr_bdot_accum ,val*Itime_step,CS%diag) + endif + if (CS%id_Gr_t_area > 0) then !ice sheet area + tmp(:,:) = 1.0 ; val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=1.0, hemisphere=1) + call post_scalar_data(CS%id_Gr_t_area,val,CS%diag) + endif + if (CS%id_Gr_g_area > 0 .or. CS%id_Gr_f_area > 0) then + ones(:,:) = 1.0 ; call masked_var_grounded(G, CS%dCS, ones, tmp) + if (CS%id_Gr_g_area > 0) then !grounded only ice sheet area + val = integrate_over_ice_sheet_area(G, ISS, tmp, unscale=1.0, hemisphere=1) + call post_scalar_data(CS%id_Gr_g_area,val,CS%diag) + endif + if (CS%id_Gr_f_area > 0) then !floating only ice sheet area (ice shelf area) + val = integrate_over_ice_sheet_area(G, ISS, 1.0-tmp, unscale=1.0, hemisphere=1) + call post_scalar_data(CS%id_Gr_f_area,val,CS%diag) + endif + endif +end subroutine process_and_post_scalar_data + !> \namespace mom_ice_shelf !! !! \section section_ICE_SHELF @@ -2174,7 +3068,7 @@ end subroutine solo_step_ice_shelf !! update_shelf_mass - updates ice shelf mass via netCDF file !! USER_update_shelf_mass (TODO). !! solo_step_ice_shelf - called only in ice-only mode. -!! shelf_calc_flux - after melt rate & fluxes are calculated, ice dynamics are done. currently mass_shelf is +!! shelf_calc_flux - after melt rate & fluxes are calculated, ice dynamics are done. Currently mass_shelf is !! updated immediately after ice_shelf_advect in fully dynamic mode. !! !! NOTES: be aware that hmask(:,:) has a number of functions; it is used for front advancement, diff --git a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 index 2a3066dfbd..7023a564b7 100644 --- a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 +++ b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 @@ -1,55 +1,109 @@ -!> Convenient wrappers to the FMS diag_manager interfaces with additional diagnostic capabilies. -module MOM_IS_diag_mediator +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 -! This file is a part of SIS2. See LICENSE.md for the license. +!> The subroutines here provide convenient wrappers to the FMS diag_manager +!! interfaces with additional diagnostic capabilities. +module MOM_IS_diag_mediator -use MOM_coms, only : PE_here -use MOM_diag_manager_infra, only : MOM_diag_manager_init, send_data_infra, MOM_diag_axis_init -use MOM_diag_manager_infra, only : EAST, NORTH -use MOM_diag_manager_infra, only : register_static_field_infra -use MOM_diag_manager_infra, only : register_diag_field_infra -use MOM_error_handler, only : MOM_error, FATAL, is_root_pe, assert -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_grid, only : ocean_grid_type -use MOM_safe_alloc, only : safe_alloc_ptr, safe_alloc_alloc -use MOM_string_functions, only : lowercase, uppercase, slasher -use MOM_time_manager, only : time_type +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_checksums, only : chksum0, hchksum, uchksum, vchksum, Bchksum +use MOM_coms, only : PE_here +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diag_manager_infra, only : MOM_diag_manager_init +use MOM_diag_manager_infra, only : MOM_diag_axis_init, get_MOM_diag_axis_name +use MOM_diag_manager_infra, only : send_data_infra, MOM_diag_field_add_attribute, EAST, NORTH +use MOM_diag_manager_infra, only : register_diag_field_infra, register_static_field_infra +use MOM_diag_manager_infra, only : get_MOM_diag_field_id, DIAG_FIELD_NOT_FOUND +use MOM_diag_manager_infra, only : diag_send_complete_infra +use MOM_error_handler, only : MOM_error, FATAL, is_root_pe, assert, callTree_showQuery +use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_io, only : get_filename_appendix +use MOM_safe_alloc, only : safe_alloc_ptr, safe_alloc_alloc +use MOM_string_functions, only : lowercase, uppercase, slasher, ints_to_string, trim_trailing_commas +use MOM_time_manager, only : time_type, get_time +use MOM_unit_scaling, only : unit_scale_type implicit none ; private public MOM_IS_diag_mediator_infrastructure_init -public set_IS_axes_info, post_IS_data, register_MOM_IS_diag_field, time_type -public register_MOM_IS_static_field -public safe_alloc_ptr, safe_alloc_alloc -public enable_averaging, disable_averaging, query_averaging_enabled -public enable_averages public MOM_IS_diag_mediator_init, MOM_IS_diag_mediator_end, set_IS_diag_mediator_grid +public set_IS_axes_info, MOM_diag_axis_init +public register_MOM_IS_diag_field, register_MOM_IS_static_field, register_MOM_IS_scalar_field +public post_IS_data, post_IS_data_0d, MOM_IS_diag_send_complete +public safe_alloc_ptr, safe_alloc_alloc, time_type +public enable_averaging, enable_averages, disable_averaging, query_averaging_enabled public MOM_IS_diag_mediator_close_registration, get_diag_time_end -public MOM_diag_axis_init, register_static_field_infra +public define_axes_group, diag_masks_set +public diag_register_area_ids, found_in_diagtable + +!> Make a diagnostic available for averaging or output. +interface post_IS_data + module procedure post_IS_data_2d, post_IS_data_0d +end interface post_IS_data -!> 2D/3D axes type to contain 1D axes handles and pointers to masks -type, public :: axesType +!> Registers a non-array scalar diagnostic, returning an integer handle +interface register_MOM_IS_scalar_field + module procedure register_scalar_field_CS, register_scalar_field_axes +end interface register_MOM_IS_scalar_field + +!> A group of 1D axes that comprise a 1D/2D/3D mesh +type, public :: axes_grp character(len=15) :: id !< The id string for this particular combination of handles. integer :: rank !< Number of dimensions in the list of axes. integer, dimension(:), allocatable :: handles !< Handles to 1D axes. - type(diag_ctrl), pointer :: diag_cs => null() !< A structure that is used to regulate diagnostic output -end type axesType + type(diag_ctrl), pointer :: diag_cs => null() !< Circular link back to the main diagnostics control structure + !! (Used to avoid passing said structure into every possible call). + ! ID's for cell_methods + character(len=9) :: x_cell_method = '' !< Default nature of data representation, if axes group + !! includes x-direction. + character(len=9) :: y_cell_method = '' !< Default nature of data representation, if axes group + !! includes y-direction. + ! For detecting position on the grid + logical :: is_h_point = .false. !< If true, indicates that this axes group is for an h-point located field. + logical :: is_q_point = .false. !< If true, indicates that this axes group is for a q-point located field. + logical :: is_u_point = .false. !< If true, indicates that this axes group is for a u-point located field. + logical :: is_v_point = .false. !< If true, indicates that this axes group is for a v-point located field. + + ! ID's for cell_measures + integer :: id_area = -1 !< The diag_manager id for area to be used for cell_measure of variables with this axes_grp. + ! For masking + real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes [nondim] + real, pointer, dimension(:,:) :: mask2d_comp => null() !< Mask for 2-d axes on the computational + !! domain for this diagnostic [nondim] +end type axes_grp !> This type is used to represent a diagnostic at the diag_mediator level. +!! +!! There can be both 'primary' and 'secondary' diagnostics. The primaries +!! reside in the diag_cs%diags array. They have an id which is an index +!! into this array. The secondaries are 'variations' on the primary diagnostic. +!! For example the CMOR diagnostics are secondary. The secondary diagnostics +!! are kept in a list with the primary diagnostic as the head. type, private :: diag_type - logical :: in_use !< This diagnostic is in use - integer :: fms_diag_id !< underlying FMS diag id - character(len=24) :: name !< The diagnostic name - real :: conversion_factor = 0. !< A factor to multiply data by before posting to FMS, if non-zero. - real, pointer, dimension(:,:) :: mask2d => null() !< A 2-d mask on the data domain for this diagnostic - real, pointer, dimension(:,:) :: mask2d_comp => null() !< A 2-d mask on the computational domain for this diagnostic + logical :: in_use !< True if this entry is being used. + integer :: fms_diag_id !< Underlying FMS diag_manager id. + character(len=64) :: debug_str = '' !< The diagnostic name and module for FATAL errors and debugging. + type(axes_grp), pointer :: axes => null() !< The axis group for this diagnostic + type(diag_type), pointer :: next => null() !< Pointer to the next diagnostic + real :: conversion_factor = 0. !< If non-zero, a factor to multiply data by before posting to FMS, + !! often including factors to undo internal scaling in units of [a A-1 ~> 1] end type diag_type -!> The SIS_diag_ctrl data type contains times to regulate diagnostics along with masks and +!> The diag_ctrl data type contains times to regulate diagnostics along with masks and !! axes to use with diagnostics, and a list of structures with data about each diagnostic. type, public :: diag_ctrl - integer :: doc_unit = -1 !< The unit number of a diagnostic documentation file. - !! This file is open if doc_unit is > 0. + integer :: available_diag_doc_unit = -1 !< The unit number of a diagnostic documentation file. + !! This file is open if available_diag_doc_unit is > 0. + integer :: chksum_iounit = -1 !< The unit number of a diagnostic documentation file. + !! This file is open if available_diag_doc_unit is > 0. + logical :: diag_as_chksum !< If true, log chksums in a text file instead of posting diagnostics + logical :: show_call_tree !< Display the call tree while running. Set by VERBOSITY level. + logical :: index_space_axes !< If true, diagnostic horizontal coordinates axes are in index space. ! The following fields are used for the output of the data. ! These give the computational-domain sizes, and are relative to a start value @@ -63,170 +117,327 @@ module MOM_IS_diag_mediator integer :: ied !< The end i-index of cell centers within the data domain integer :: jsd !< The start j-index of cell centers within the data domain integer :: jed !< The end j-index of cell centers within the data domain - real :: time_int !< The time interval in s for any fields that are offered for averaging. + real :: time_int !< The time interval for any fields + !! that are offered for averaging [s]. type(time_type) :: time_end !< The end time of the valid interval for any offered field. - logical :: ave_enabled = .false. !< .true. if averaging is enabled. + logical :: ave_enabled = .false. !< True if averaging is enabled. !>@{ The following are 3D and 2D axis groups defined for output. The names indicate - !! the horizontal locations (B, T, Cu, or Cv), vertical locations (L, i, or 1) and - !! thickness categories (c, c0, or 1). - type(axesType) :: axesBL, axesTL, axesCuL, axesCvL - type(axesType) :: axesBi, axesTi, axesCui, axesCvi - type(axesType) :: axesBc, axesTc, axesCuc, axesCvc - type(axesType) :: axesBc0, axesTc0, axesCuc0, axesCvc0 - type(axesType) :: axesB1, axesT1, axesCu1, axesCv1 - !!@} - - ! Mask arrays for diagnostics - real, dimension(:,:), pointer :: mask2dT => null() !< 2D mask array for cell-center points - real, dimension(:,:), pointer :: mask2dBu => null() !< 2D mask array for cell-corners - real, dimension(:,:), pointer :: mask2dCu => null() !< 2D mask array for east-faces - real, dimension(:,:), pointer :: mask2dCv => null() !< 2D mask array for north-faces - !> Computational domain mask arrays for diagnostics. - real, dimension(:,:), pointer :: mask2dT_comp => null() - + !! the horizontal locations (B, T, Cu, or Cv) and vertical locations (here just 1). + type(axes_grp) :: axesB1, axesT1, axesCu1, axesCv1 + !>@} + type(axes_grp) :: axesNull !< An axis group for scalars + + ! Mask arrays for 2D diagnostics + real, dimension(:,:), pointer :: mask2dT => null() !< 2D mask array for cell-center points [nondim] + real, dimension(:,:), pointer :: mask2dBu => null() !< 2D mask array for cell-corner points [nondim] + real, dimension(:,:), pointer :: mask2dCu => null() !< 2D mask array for east-face points [nondim] + real, dimension(:,:), pointer :: mask2dCv => null() !< 2D mask array for north-face points [nondim] + real, dimension(:,:), pointer :: mask2dT_comp => null() !< 2D cell-center mask on the computational domain [nondim] + +! Space for diagnostics is dynamically allocated as it is needed. +! The chunk size is how much the array should grow on each new allocation. #define DIAG_ALLOC_CHUNK_SIZE 15 - type(diag_type), dimension(:), allocatable :: diags !< The array of diagnostics + type(diag_type), dimension(:), allocatable :: diags !< The list of diagnostics integer :: next_free_diag_id !< The next unused diagnostic ID - !> default missing value to be sent to ALL diagnostics registerations + + !> default missing value to be sent to ALL diagnostics registrations [various] real :: missing_value = -1.0e34 + type(ocean_grid_type), pointer :: G => null() !< The ocean grid type + type(unit_scale_type), pointer :: US => null() !< A dimensional unit scaling type + + !> Number of checksum-only diagnostics + integer :: num_chksum_diags + end type diag_ctrl +!>@{ CPU clocks +integer :: id_clock_diag_mediator +!>@} + contains !> Set up the grid and axis information for use by the ice shelf model. -subroutine set_IS_axes_info(G, param_file, diag_cs, axes_set_name) - type(ocean_grid_type), intent(inout) :: G !< The horizontal grid type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output +subroutine set_IS_axes_info(G, diag_cs, axes_set_name) + type(ocean_grid_type), intent(in) :: G !< The horizontal grid type + type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output character(len=*), optional, intent(in) :: axes_set_name !< A name to use for this set of axes. !! The default is "ice". ! This subroutine sets up the grid and axis information for use by the ice shelf model. ! Local variables - integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh, id_ct, id_ct0 - integer :: k - logical :: Cartesian_grid - character(len=80) :: grid_config, units_temp, set_name -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mdl = "MOM_IS_diag_mediator" ! This module's name. + integer :: id_xq, id_yq, id_xh, id_yh, id_null + integer :: i, j + character(len=80) :: set_name + real, allocatable, dimension(:) :: IaxB, iax ! Index-based integer and half-integer i-axis labels [nondim] + real, allocatable, dimension(:) :: JaxB, jax ! Index-based integer and half-integer j-axis labels [nondim] set_name = "ice_shelf" ; if (present(axes_set_name)) set_name = trim(axes_set_name) - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version) - call get_param(param_file, mdl, "GRID_CONFIG", grid_config, & - "The method for defining the horizontal grid. Valid "//& - "entries include:\n"//& - "\t file - read the grid from GRID_FILE \n"//& - "\t mosaic - read the grid from a mosaic grid file \n"//& - "\t cartesian - a Cartesian grid \n"//& - "\t spherical - a spherical grid \n"//& - "\t mercator - a Mercator grid", fail_if_missing=.true.) - - G%x_axis_units = "degrees_E" - G%y_axis_units = "degrees_N" - if (index(lowercase(trim(grid_config)),"cartesian") > 0) then - ! This is a cartesian grid, and may have different axis units. - Cartesian_grid = .true. - call get_param(param_file, mdl, "AXIS_UNITS", units_temp, & - "The units for the x- and y- axis labels. AXIS_UNITS "//& - "should be defined as 'k' for km, 'm' for m, or 'd' "//& - "for degrees of latitude and longitude (the default). "//& - "Except on a Cartesian grid, only degrees are currently "//& - "implemented.", default='degrees') - if (units_temp(1:1) == 'k') then - G%x_axis_units = "kilometers" ; G%y_axis_units = "kilometers" - elseif (units_temp(1:1) == 'm') then - G%x_axis_units = "meters" ; G%y_axis_units = "meters" - endif - call log_param(param_file, mdl, "explicit AXIS_UNITS", G%x_axis_units) - else - Cartesian_grid = .false. + if (diag_cs%index_space_axes) then + allocate(IaxB(G%IsgB:G%IegB)) + do I=G%IsgB,G%IegB + Iaxb(I) = real(I) + enddo + allocate(iax(G%isg:G%ieg)) + do i=G%isg,G%ieg + iax(i) = real(i)-0.5 + enddo + allocate(JaxB(G%JsgB:G%JegB)) + do J=G%JsgB,G%JegB + JaxB(J) = real(J) + enddo + allocate(jax(G%jsg:G%jeg)) + do j=G%jsg,G%jeg + jax(j) = real(j)-0.5 + enddo endif - if (G%symmetric) then - id_xq = MOM_diag_axis_init('xB', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & + ! Horizontal axes for the native grids. + if (diag_cs%index_space_axes) then + if (G%symmetric) then + id_xq = MOM_diag_axis_init('Iq', IaxB(G%IsgB:G%IegB), 'none', 'x', & + 'Boundary (q) point grid-space longitude', G%Domain, position=EAST, set_name=set_name) + id_yq = MOM_diag_axis_init('Jq', JaxB(G%JsgB:G%JegB), 'none', 'y', & + 'Boundary (q) point grid-space latitude', G%Domain, position=NORTH, set_name=set_name) + else + id_xq = MOM_diag_axis_init('Iq', IaxB(G%isg:G%ieg), 'none', 'x', & + 'Boundary (q) point grid-space longitude', G%Domain, position=EAST, set_name=set_name) + id_yq = MOM_diag_axis_init('Jq', JaxB(G%jsg:G%jeg), 'none', 'y', & + 'Boundary (q) point grid-space latitude', G%Domain, position=NORTH, set_name=set_name) + endif + + id_xh = MOM_diag_axis_init('ih', iax, 'none', 'x', & + 'Tracer (h) point grid-space longitude', G%Domain, set_name=set_name) + id_yh = MOM_diag_axis_init('jh', jax, 'none', 'y', & + 'Tracer (h) point grid-space latitude', G%Domain, set_name=set_name) + else + if (G%symmetric) then + id_xq = MOM_diag_axis_init('xB', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & 'Boundary point nominal longitude', G%Domain, position=EAST, set_name=set_name) - id_yq = MOM_diag_axis_init('yB', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & + id_yq = MOM_diag_axis_init('yB', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & 'Boundary point nominal latitude', G%Domain, position=NORTH, set_name=set_name) - else - id_xq = MOM_diag_axis_init('xB', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', & + else + id_xq = MOM_diag_axis_init('xB', G%gridLonB(G%isg:G%ieg), G%x_axis_units, 'x', & 'Boundary point nominal longitude', G%Domain, position=EAST, set_name=set_name) - id_yq = MOM_diag_axis_init('yB', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', & + id_yq = MOM_diag_axis_init('yB', G%gridLatB(G%jsg:G%jeg), G%y_axis_units, 'y', & 'Boundary point nominal latitude', G%Domain, position=NORTH, set_name=set_name) + endif + id_xh = MOM_diag_axis_init('xT', G%gridLonT(G%isg:G%ieg), G%x_axis_units, 'x', & + 'Tracer point nominal longitude', G%Domain, set_name=set_name) + id_yh = MOM_diag_axis_init('yT', G%gridLatT(G%jsg:G%jeg), G%y_axis_units, 'y', & + 'Tracer point nominal latitude', G%Domain, set_name=set_name) endif - id_xh = MOM_diag_axis_init('xT', G%gridLonT(G%isg:G%ieg), G%x_axis_units, 'x', & - 'T point nominal longitude', G%Domain, set_name=set_name) - id_yh = MOM_diag_axis_init('yT', G%gridLatT(G%jsg:G%jeg), G%y_axis_units, 'y', & - 'T point nominal latitude', G%Domain, set_name=set_name) - ! Axis groupings for 2-D arrays. - call defineAxes(diag_cs, [id_xh, id_yh], diag_cs%axesT1) - call defineAxes(diag_cs, [id_xq, id_yq], diag_cs%axesB1) - call defineAxes(diag_cs, [id_xq, id_yh], diag_cs%axesCu1) - call defineAxes(diag_cs, [id_xh, id_yq], diag_cs%axesCv1) + ! Axis groupings for 2-D arrays + call define_axes_group(diag_cs, (/id_xh, id_yh/), diag_cs%axesT1, & + x_cell_method='mean', y_cell_method='mean', is_h_point=.true.) + call define_axes_group(diag_cs, (/id_xq, id_yq/), diag_cs%axesB1, & + x_cell_method='point', y_cell_method='point', is_q_point=.true.) + call define_axes_group(diag_cs, (/id_xq, id_yh/), diag_cs%axesCu1, & + x_cell_method='point', y_cell_method='mean', is_u_point=.true.) + call define_axes_group(diag_cs, (/id_xh, id_yq/), diag_cs%axesCv1, & + x_cell_method='mean', y_cell_method='point', is_v_point=.true.) + + ! Axis group for special null axis for scalars from diag manager. + id_null = MOM_diag_axis_init('scalar_axis', (/0./), 'none', 'N', 'none', null_axis=.true.) + call define_axes_group(diag_cs, (/ id_null /), diag_cs%axesNull) + + if (diag_cs%index_space_axes) then + deallocate(IaxB, iax, JaxB, jax) + endif end subroutine set_IS_axes_info -!> Define an a group of axes from a list of handles -subroutine defineAxes(diag_cs, handles, axes) - ! Defines "axes" from list of handle and associates mask - type(diag_ctrl), target, intent(in) :: diag_cs !< A structure that is used to regulate diagnostic output - integer, dimension(:), intent(in) :: handles !< A set of axis handles that define the axis group - type(axesType), intent(out) :: axes !< A group of axes that is set up here +!> Attaches the id of cell areas to axes groups for use with cell_measures +subroutine diag_register_area_ids(diag_cs, id_area_t, id_area_q) + type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure + integer, optional, intent(in) :: id_area_t !< Diag_mediator id for area of h-cells + integer, optional, intent(in) :: id_area_q !< Diag_mediator id for area of q-cells + ! Local variables + integer :: fms_id, i + if (present(id_area_t)) then + fms_id = diag_cs%diags(id_area_t)%fms_diag_id + diag_cs%axesT1%id_area = fms_id + endif + if (present(id_area_q)) then + fms_id = diag_cs%diags(id_area_q)%fms_diag_id + diag_cs%axesB1%id_area = fms_id + endif +end subroutine diag_register_area_ids + +!> Define a group of "axes" from a list of handles and associate a mask with it +subroutine define_axes_group(diag_cs, handles, axes, & + x_cell_method, y_cell_method, & + is_h_point, is_q_point, is_u_point, is_v_point) + type(diag_ctrl), target, intent(in) :: diag_cs !< Structure used to regulate diagnostic output + integer, dimension(:), intent(in) :: handles !< A list of 1D axis handles that define the axis group + type(axes_grp), intent(out) :: axes !< The group of axes that is set up here + character(len=*), optional, intent(in) :: x_cell_method !< A x-direction cell method used to construct the + !! "cell_methods" attribute in CF convention + character(len=*), optional, intent(in) :: y_cell_method !< A y-direction cell method used to construct the + !! "cell_methods" attribute in CF convention + logical, optional, intent(in) :: is_h_point !< If true, indicates this axes group for h-point + !! located fields + logical, optional, intent(in) :: is_q_point !< If true, indicates this axes group for q-point + !! located fields + logical, optional, intent(in) :: is_u_point !< If true, indicates this axes group for + !! u-point located fields + logical, optional, intent(in) :: is_v_point !< If true, indicates this axes group for + !! v-point located fields ! Local variables integer :: n + n = size(handles) - if (n<1 .or. n>3) call MOM_error(FATAL,"defineAxes: wrong size for list of handles!") + if (n<1 .or. n>2) call MOM_error(FATAL, "define_axes_group: wrong size for list of handles!") allocate( axes%handles(n) ) - axes%id = i2s(handles, n) ! Identifying string + axes%id = ints_to_string(handles, max(n,2)) ! Identifying string axes%rank = n axes%handles(:) = handles(:) - axes%diag_cs => diag_cs ! A (circular) link back to the MOM_IS_diag_ctrl structure -end subroutine defineAxes + axes%diag_cs => diag_cs ! A (circular) link back to the diag_ctrl structure + + if ((axes%rank<2) .and. (present(x_cell_method) .or. present(x_cell_method))) & + call MOM_error(FATAL, 'define_axes_group: Can not set x_cell_method or y_cell_method for rank<2.') + axes%x_cell_method = '' ; if (present(x_cell_method)) axes%x_cell_method = trim(x_cell_method) + axes%y_cell_method = '' ; if (present(y_cell_method)) axes%y_cell_method = trim(y_cell_method) + + if (present(is_h_point)) axes%is_h_point = is_h_point + if (present(is_q_point)) axes%is_q_point = is_q_point + if (present(is_u_point)) axes%is_u_point = is_u_point + if (present(is_v_point)) axes%is_v_point = is_v_point + + ! Setup masks for this axes group + axes%mask2d => null() + if (axes%rank==2) then + if (axes%is_h_point) axes%mask2d => diag_cs%mask2dT + if (axes%is_h_point) axes%mask2d_comp => diag_cs%mask2dT_comp + if (axes%is_u_point) axes%mask2d => diag_cs%mask2dCu + if (axes%is_v_point) axes%mask2d => diag_cs%mask2dCv + if (axes%is_q_point) axes%mask2d => diag_cs%mask2dBu + endif -!> Set up the current grid for the diag mediator +end subroutine define_axes_group + +!> Set up the array extents for doing diagnostics subroutine set_IS_diag_mediator_grid(G, diag_cs) type(ocean_grid_type), intent(inout) :: G !< The horizontal grid type - type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output + type(diag_ctrl), intent(inout) :: diag_cs !< Structure used to regulate diagnostic output diag_cs%is = G%isc - (G%isd-1) ; diag_cs%ie = G%iec - (G%isd-1) diag_cs%js = G%jsc - (G%jsd-1) ; diag_cs%je = G%jec - (G%jsd-1) - diag_cs%isd = G%isd ; diag_cs%ied = G%ied ; diag_cs%jsd = G%jsd ; diag_cs%jed = G%jed + diag_cs%isd = G%isd ; diag_cs%ied = G%ied + diag_cs%jsd = G%jsd ; diag_cs%jed = G%jed + end subroutine set_IS_diag_mediator_grid -!> Offer a 2d diagnostic field for output or averaging -subroutine post_IS_data(diag_field_id, field, diag_cs, is_static, mask) - integer, intent(in) :: diag_field_id !< the id for an output variable returned by a - !! previous call to register_diag_field. - real, target, intent(in) :: field(:,:) !< The 2-d array being offered for output or averaging. - type(diag_ctrl), target, & - intent(in) :: diag_cs !< A structure that is used to regulate diagnostic output +!> Make a real ice shelf scalar diagnostic available for averaging or output +subroutine post_IS_data_0d(diag_field_id, field, diag_cs, is_static) + integer, intent(in) :: diag_field_id !< The id for an output variable returned by a + !! previous call to register_MOM_IS_diag_field. + real, intent(in) :: field !< real value being offered for output or averaging + !! in internally scaled arbitrary units [A ~> a] + type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. - logical, optional, intent(in) :: mask(:,:) !< If present, use this logical array as the data mask. ! Local variables - real, dimension(:,:), pointer :: locfield + real :: locfield ! The field being offered in arbitrary unscaled units [a] logical :: used, is_stat - logical :: i_data, j_data - integer :: isv, iev, jsv, jev, i, j - integer :: fms_diag_id - type(diag_type), pointer :: diag => NULL() + type(diag_type), pointer :: diag => null() - locfield => NULL() + integer :: time_days + integer :: time_seconds + character(len=300) :: debug_mesg + + if (id_clock_diag_mediator>0) call cpu_clock_begin(id_clock_diag_mediator) is_stat = .false. ; if (present(is_static)) is_stat = is_static - ! Get a pointer to the diag type for this id, and the FMS-level diag id. + ! Iterate over list of diag 'variants', e.g. CMOR aliases, call send_data + ! for each one. + call assert(diag_field_id < diag_cs%next_free_diag_id, & + 'post_IS_data_0d: Unregistered diagnostic id') + diag => diag_cs%diags(diag_field_id) + + do while (associated(diag)) + locfield = field + if (diag%conversion_factor /= 0.) & + locfield = locfield * diag%conversion_factor + + if (diag_cs%diag_as_chksum) then + ! Append timestep to mesg + call get_time(diag_cs%time_end, time_seconds, days=time_days) + write(debug_mesg, '(a, 1x, i0, 1x, i0)') & + trim(diag%debug_str), time_days, time_seconds + + call chksum0(locfield, debug_mesg, logunit=diag_cs%chksum_iounit) + elseif (is_stat) then + used = send_data_infra(diag%fms_diag_id, locfield) + elseif (diag_cs%ave_enabled) then + used = send_data_infra(diag%fms_diag_id, locfield, diag_cs%time_end) + endif + + diag => diag%next + enddo + + if (id_clock_diag_mediator>0) call cpu_clock_end(id_clock_diag_mediator) +end subroutine post_IS_data_0d + + +!> Make a real 2-d array diagnostic available for averaging or output +subroutine post_IS_data_2d(diag_field_id, field, diag_cs, is_static, mask) + integer, intent(in) :: diag_field_id !< The id for an output variable returned by a + !! previous call to register_MOM_IS_diag_field. + real, target, intent(in) :: field(:,:) !< 2-d array being offered for output or averaging + !! in internally scaled arbitrary units [A ~> a] + type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. + real, optional, intent(in) :: mask(:,:) !< If present, use this real array as the data mask [nondim] + + ! Local variables + type(diag_type), pointer :: diag => NULL() + + if (id_clock_diag_mediator>0) call cpu_clock_begin(id_clock_diag_mediator) + + ! Iterate over list of diag 'variants' (e.g. CMOR aliases) and post each. call assert(diag_field_id < diag_cs%next_free_diag_id, & - 'post_IS_data: Unregistered diagnostic id') + 'post_IS_data_2d: Unregistered diagnostic id') diag => diag_cs%diags(diag_field_id) - fms_diag_id = diag%fms_diag_id + do while (associated(diag)) + call post_data_2d_low(diag, field, diag_cs, is_static, mask) + diag => diag%next + enddo + + if (id_clock_diag_mediator>0) call cpu_clock_end(id_clock_diag_mediator) +end subroutine post_IS_data_2d + +!> Make a real 2-d array diagnostic available for averaging or output +!! using a diag_type instead of an integer id. +subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) + type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post + real, target, intent(in) :: field(:,:) !< 2-d array being offered for output or averaging + !! in internally scaled arbitrary units [A ~> a] + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. + real, optional, target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask [nondim] + + ! Local variables + real, dimension(:,:), pointer :: locfield ! The field being offered in arbitrary unscaled units [a] + real, dimension(:,:), pointer :: locmask ! A pointer to the data mask to use [nondim] + logical :: used ! The return value of send_data is not used for anything. + logical :: is_stat + logical :: i_data, j_data ! True if the field is on the data domain in the i or j directions. + integer :: cszi, cszj, dszi, dszj + integer :: isv, iev, jsv, jev, i, j + integer :: time_days, time_seconds + character(len=300) :: mesg + character(len=300) :: debug_mesg + + locfield => NULL() + locmask => NULL() + is_stat = .false. ; if (present(is_static)) is_stat = is_static ! Determine the proper array indices, noting that because of the (:,:) ! declaration of field, symmetric arrays are using a SW-grid indexing, @@ -235,27 +446,35 @@ subroutine post_IS_data(diag_field_id, field, diag_cs, is_static, mask) ! the output data size and assumes that halos are symmetric. isv = diag_cs%is ; iev = diag_cs%ie ; jsv = diag_cs%js ; jev = diag_cs%je - if ( size(field,1) == diag_cs%ied-diag_cs%isd +1 ) then + cszi = (diag_cs%ie-diag_cs%is) +1 ; dszi = (diag_cs%ied-diag_cs%isd) +1 + cszj = (diag_cs%je-diag_cs%js) +1 ; dszj = (diag_cs%jed-diag_cs%jsd) +1 + if ( size(field,1) == dszi ) then isv = diag_cs%is ; iev = diag_cs%ie ; i_data = .true. ! Data domain - elseif ( size(field,1) == diag_cs%ied-diag_cs%isd +2 ) then + elseif ( size(field,1) == dszi + 1 ) then isv = diag_cs%is ; iev = diag_cs%ie+1 ; i_data = .true. ! Symmetric data domain - elseif ( size(field,1) == diag_cs%ie-diag_cs%is +1 ) then - isv = 1 ; iev = diag_cs%ie + 1-diag_cs%is ; i_data = .false. ! Computational domain - elseif ( size(field,1) == diag_cs%ie-diag_cs%is +2 ) then - isv = 1 ; iev = diag_cs%ie + 2-diag_cs%is ; i_data = .false. ! Symmetric computational domain + elseif ( size(field,1) == cszi ) then + isv = 1 ; iev = cszi ; i_data = .false. ! Computational domain + elseif ( size(field,1) == cszi + 1 ) then + isv = 1 ; iev = cszi+1 ; i_data = .false. ! Symmetric computational domain else - call MOM_error(FATAL,"post_MOM_IS_data_2d: peculiar size in i-direction of "//trim(diag%name)) + write (mesg,*) " peculiar size ",size(field,1)," in i-direction\n"//& + "does not match one of ", cszi, cszi+1, dszi, dszi+1 + call MOM_error(FATAL,"post_IS_data_2d_low: "//trim(diag%debug_str)//trim(mesg)) endif - if ( size(field,2) == diag_cs%jed-diag_cs%jsd +1 ) then + + if ( size(field,2) == dszj ) then jsv = diag_cs%js ; jev = diag_cs%je ; j_data = .true. ! Data domain - elseif ( size(field,2) == diag_cs%jed-diag_cs%jsd +2 ) then + elseif ( size(field,2) == dszj + 1 ) then jsv = diag_cs%js ; jev = diag_cs%je+1 ; j_data = .true. ! Symmetric data domain - elseif ( size(field,2) == diag_cs%je-diag_cs%js +1 ) then - jsv = 1 ; jev = diag_cs%je + 1-diag_cs%js ; j_data = .false. ! Computational domain - elseif ( size(field,1) == diag_cs%je-diag_cs%js +2 ) then - jsv = 1 ; jev = diag_cs%je + 2-diag_cs%js ; j_data = .false. ! Symmetric computational domain + elseif ( size(field,2) == cszj ) then + jsv = 1 ; jev = cszj ; j_data = .false. ! Computational domain + ! This was: elseif ( size(field,1) == cszj + 1 ) then + elseif ( size(field,2) == cszj + 1 ) then + jsv = 1 ; jev = cszj+1 ; j_data = .false. ! Symmetric computational domain else - call MOM_error(FATAL,"post_MOM_IS_data_2d: peculiar size in j-direction "//trim(diag%name)) + write (mesg,*) " peculiar size ",size(field,2)," in j-direction\n"//& + "does not match one of ", cszj, cszj+1, dszj, dszj+1 + call MOM_error(FATAL,"post_IS_data_2d_low: "//trim(diag%debug_str)//trim(mesg)) endif if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then @@ -275,78 +494,77 @@ subroutine post_IS_data(diag_field_id, field, diag_cs, is_static, mask) ! Handle cases where the data and computational domain are the same size. if (diag_cs%ied-diag_cs%isd == diag_cs%ie-diag_cs%is) i_data = j_data if (diag_cs%jed-diag_cs%jsd == diag_cs%je-diag_cs%js) j_data = i_data + if ( i_data .NEQV. j_data ) then + call MOM_error(FATAL, "post_IS_data_2d: post_IS_data called for "//& + trim(diag%debug_str)//" with mixed computational and data domain array sizes.") + endif if (present(mask)) then - if ((size(field,1) /= size(mask,1)) .or. & - (size(field,2) /= size(mask,2))) then - call MOM_error(FATAL, "post_MOM_IS_data_2d: post_MOM_IS_data called with a mask "//& - "that does not match the size of field "//trim(diag%name)) + locmask => mask + elseif (.not.is_stat) then ! Static fields do not have assigned axes. + if (i_data .and. associated(diag%axes%mask2d)) then + locmask => diag%axes%mask2d + elseif ((.not.i_data) .and. associated(diag%axes%mask2d_comp)) then + locmask => diag%axes%mask2d_comp endif - elseif ( i_data .NEQV. j_data ) then - call MOM_error(FATAL, "post_MOM_IS_data_2d: post_MOM_IS_data called for "//& - trim(diag%name)//" with mixed computational and data domain array sizes.") - endif - - if (is_stat) then - if (present(mask)) then - used = send_data_infra(fms_diag_id, locfield, & - is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, mask=mask) - elseif(i_data .and. associated(diag%mask2d)) then -! used = send_data(fms_diag_id, locfield, & -! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, rmask=diag%mask2d) - used = send_data_infra(fms_diag_id, locfield, & - is_in=isv, ie_in=iev, js_in=jsv, je_in=jev) - elseif((.not.i_data) .and. associated(diag%mask2d_comp)) then -! used = send_data(fms_diag_id, locfield, & -! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, rmask=diag%mask2d_comp) - used = send_data_infra(fms_diag_id, locfield, & - is_in=isv, ie_in=iev, js_in=jsv, je_in=jev) + endif + if (associated(locmask)) call assert(size(locfield) == size(locmask), & + 'post_data_2d_low: mask size mismatch: '//trim(diag%debug_str)) + + if (diag_cs%diag_as_chksum) then + ! Append timestep to mesg + call get_time(diag_cs%time_end, time_seconds, days=time_days) + write(debug_mesg, '(a, 1x, i0, 1x, i0)') & + trim(diag%debug_str), time_days, time_seconds + + if (diag%axes%is_h_point) then + call hchksum(locfield, debug_mesg, diag_cs%G%HI, & + logunit=diag_cs%chksum_iounit) + elseif (diag%axes%is_u_point) then + call uchksum(locfield, debug_mesg, diag_cs%G%HI, & + logunit=diag_cs%chksum_iounit) + elseif (diag%axes%is_v_point) then + call vchksum(locfield, debug_mesg, diag_cs%G%HI, & + logunit=diag_cs%chksum_iounit) + elseif (diag%axes%is_q_point) then + call Bchksum(locfield, debug_mesg, diag_cs%G%HI, & + logunit=diag_cs%chksum_iounit) else - used = send_data_infra(fms_diag_id, locfield, & - is_in=isv, ie_in=iev, js_in=jsv, je_in=jev) + call MOM_error(FATAL, "post_data_2d_low: unknown axis type.") endif - elseif (diag_cs%ave_enabled) then - if (present(mask)) then - used = send_data_infra(fms_diag_id, locfield, & - is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & - time=diag_cs%time_end, weight=diag_cs%time_int, mask=mask) -! used = send_data(fms_diag_id, locfield, & -! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & -! time=diag_cs%time_end, weight=diag_cs%time_int) - elseif(i_data .and. associated(diag%mask2d)) then -! used = send_data(fms_diag_id, locfield, & -! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & -! time=diag_cs%time_end, weight=diag_cs%time_int, rmask=diag%mask2d) - used = send_data_infra(fms_diag_id, locfield, & - is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & - time=diag_cs%time_end, weight=diag_cs%time_int) - elseif((.not.i_data) .and. associated(diag%mask2d_comp)) then -! used = send_data(fms_diag_id, locfield, & -! is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & -! time=diag_cs%time_end, weight=diag_cs%time_int, rmask=diag%mask2d_comp) - used = send_data_infra(fms_diag_id, locfield, & - is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & - time=diag_cs%time_end, weight=diag_cs%time_int) - else - used = send_data_infra(fms_diag_id, locfield, & - is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & - time=diag_cs%time_end, weight=diag_cs%time_int) + else + if (is_stat) then + if (associated(locmask)) then + used = send_data_infra(diag%fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, rmask=locmask) + else + used = send_data_infra(diag%fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev) + endif + elseif (diag_cs%ave_enabled) then + if (associated(locmask)) then + used = send_data_infra(diag%fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & + time=diag_cs%time_end, weight=diag_cs%time_int, rmask=locmask) + else + used = send_data_infra(diag%fms_diag_id, locfield, & + is_in=isv, ie_in=iev, js_in=jsv, je_in=jev, & + time=diag_cs%time_end, weight=diag_cs%time_int) + endif endif endif - if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.) ) deallocate( locfield ) - -end subroutine post_IS_data + if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) deallocate( locfield ) +end subroutine post_data_2d_low !> Enable the accumulation of time averages over the specified time interval. subroutine enable_averaging(time_int_in, time_end_in, diag_cs) - real, intent(in) :: time_int_in !< The time interval over which any values -! !! that are offered are valid [s]. - type(time_type), intent(in) :: time_end_in !< The end time of the valid interval. - type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output -! This subroutine enables the accumulation of time averages over the -! specified time interval. + real, intent(in) :: time_int_in !< The time interval [s] over which any + !! values that are offered are valid. + type(time_type), intent(in) :: time_end_in !< The end time of the valid interval + type(diag_ctrl), intent(inout) :: diag_cs !< Structure used to regulate diagnostic output + ! This subroutine enables the accumulation of time averages over the specified time interval. ! if (num_file==0) return diag_cs%time_int = time_int_in @@ -354,28 +572,19 @@ subroutine enable_averaging(time_int_in, time_end_in, diag_cs) diag_cs%ave_enabled = .true. end subroutine enable_averaging -! Put a block on averaging any offered fields. -subroutine disable_averaging(diag_cs) - type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output - - diag_cs%time_int = 0.0 - diag_cs%ave_enabled = .false. - -end subroutine disable_averaging - !> Enable the accumulation of time averages over the specified time interval in time units. subroutine enable_averages(time_int, time_end, diag_CS, T_to_s) real, intent(in) :: time_int !< The time interval over which any values !! that are offered are valid [T ~> s]. type(time_type), intent(in) :: time_end !< The end time of the valid interval. type(diag_ctrl), intent(inout) :: diag_CS !< A structure that is used to regulate diagnostic output - real, optional, intent(in) :: T_to_s !< A conversion factor for time_int to [s]. -! This subroutine enables the accumulation of time averages over the specified time interval. + real, optional, intent(in) :: T_to_s !< A conversion factor for time_int to seconds [s T-1 ~> 1]. + ! This subroutine enables the accumulation of time averages over the specified time interval. if (present(T_to_s)) then diag_cs%time_int = time_int*T_to_s -! elseif (associated(diag_CS%US)) then -! diag_cs%time_int = time_int*diag_CS%US%T_to_s + elseif (associated(diag_CS%US)) then + diag_cs%time_int = time_int*diag_CS%US%T_to_s else diag_cs%time_int = time_int endif @@ -383,176 +592,765 @@ subroutine enable_averages(time_int, time_end, diag_CS, T_to_s) diag_cs%ave_enabled = .true. end subroutine enable_averages +!> Call this subroutine to avoid averaging any offered fields. +subroutine disable_averaging(diag_cs) + type(diag_ctrl), intent(inout) :: diag_cs !< Structure used to regulate diagnostic output + + diag_cs%time_int = 0.0 + diag_cs%ave_enabled = .false. +end subroutine disable_averaging + !> Indicate whether averaging diagnostics is currently enabled logical function query_averaging_enabled(diag_cs, time_int, time_end) - type(diag_ctrl), intent(in) :: diag_cs !< A structure that is used to regulate diagnostic output - real, optional, intent(out) :: time_int !< The current setting of diag_cs%time_int [s]. - type(time_type), optional, intent(out) :: time_end !< The current setting of diag_cs%time_end. + type(diag_ctrl), intent(in) :: diag_cs !< Structure used to regulate diagnostic output + real, optional, intent(out) :: time_int !< Current setting of diag_cs%time_int [s] + type(time_type), optional, intent(out) :: time_end !< Current setting of diag_cs%time_end if (present(time_int)) time_int = diag_cs%time_int if (present(time_end)) time_end = diag_cs%time_end query_averaging_enabled = diag_cs%ave_enabled end function query_averaging_enabled +!> This subroutine initializes the diag_manager via the MOM6 infrastructure subroutine MOM_IS_diag_mediator_infrastructure_init(err_msg) - ! This subroutine initializes the FMS diag_manager. character(len=*), optional, intent(out) :: err_msg !< An error message call MOM_diag_manager_init(err_msg=err_msg) end subroutine MOM_IS_diag_mediator_infrastructure_init -!> diag_mediator_init initializes the MOM diag_mediator and opens the available - -!> Return the currently specified valid end time for diagnostics +!> This function returns the valid end time for use with diagnostics that are +!! handled outside of the MOM6 diagnostics infrastructure. function get_diag_time_end(diag_cs) - type(diag_ctrl), intent(in) :: diag_cs !< A structure that is used to regulate diagnostic output + type(diag_ctrl), intent(in) :: diag_cs !< Structure used to regulate diagnostic output type(time_type) :: get_diag_time_end - -! This function returns the valid end time for diagnostics that are handled -! outside of the MOM6 infrastructure, such as via the generic tracer code. + ! This function returns the valid end time for diagnostics that are handled + ! outside of the MOM6 infrastructure, such as via the generic tracer code. get_diag_time_end = diag_cs%time_end end function get_diag_time_end -!> Returns the "MOM_IS_diag_mediator" handle for a group of diagnostics derived from one field. -function register_MOM_IS_diag_field(module_name, field_name, axes, init_time, & +!> Returns the "diag_mediator" handle for a group (native, CMOR, ...) of diagnostics +!! derived from one field. +function register_MOM_IS_diag_field(module_name, field_name, axes_in, init_time, & long_name, units, missing_value, range, mask_variant, standard_name, & - verbose, do_not_log, err_msg, interp_method, tile_count, conversion) result (register_diag_field) + verbose, do_not_log, err_msg, interp_method, tile_count, cmor_field_name, & + cmor_long_name, cmor_units, cmor_standard_name, cell_methods, & + x_cell_method, y_cell_method, conversion) result (register_diag_field) integer :: register_diag_field !< The returned diagnostic handle - character(len=*), intent(in) :: module_name !< Name of this module, usually "ice_model" - character(len=*), intent(in) :: field_name !< Name of the diagnostic field - type(axesType), intent(in) :: axes !< The axis group for this field - type(time_type), intent(in) :: init_time !< Time at which a field is first available? + character(len=*), intent(in) :: module_name !< Name of this module, usually "ice_model" + character(len=*), intent(in) :: field_name !< Name of the diagnostic field + type(axes_grp), target, intent(in) :: axes_in !< Container with up to 3 integer handles that + !! indicates axes for this field + type(time_type), intent(in) :: init_time !< Time at which a field is first available? character(len=*), optional, intent(in) :: long_name !< Long name of a field. character(len=*), optional, intent(in) :: units !< Units of a field. character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field - real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: missing_value !< A value that indicates missing values in + !! output files, in unscaled arbitrary units [a] real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + !! in arbitrary units [a] logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with !! post_IS_data calls (not used in MOM?) logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) character(len=*), optional, intent(out):: err_msg !< String into which an error message might be - !! placed (not used in MOM?) + !! placed (not used in MOM?) character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not - !! be interpolated as a scalar - integer, optional, intent(in) :: tile_count !< no clue (not used in MOM_IS?) - real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file + !! be interpolated as a scalar + integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) + character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field + character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field + character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field + character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field + character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute. Use '' to + !! have no attribute. If present, this overrides the + !! default constructed from the default for + !! each individual axis direction. + character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. + !! Use '' have no method. + real, optional, intent(in) :: conversion !< A value to multiply data by before writing to files, + !! often including factors to undo internal scaling and + !! in units of [a A-1 ~> 1] ! Local variables - character(len=240) :: mesg - real :: MOM_missing_value - integer :: primary_id, fms_id - type(diag_ctrl), pointer :: diag_cs => NULL() ! A structure that is used - ! to regulate diagnostic output - type(diag_type), pointer :: diag => NULL() + real :: MOM_missing_value ! A value used to indicate missing values in output files, in arbitrary units [a] + type(diag_ctrl), pointer :: diag_cs => NULL() ! A structure that is used to regulate diagnostic output + type(axes_grp), pointer :: axes + integer :: dm_id + character(len=256) :: msg + character(len=256) :: cm_string ! A string describing the cell methods returned from attach_cell_methods. + character(len=256) :: new_module_name + character(len=480) :: module_list, var_list + character(len=24) :: dimensions + integer :: num_modnm, num_varnm + logical :: active + + diag_cs => axes_in%diag_cs + + ! Check if the axes match a standard grid axis. + ! If not, allocate the new axis and copy the contents. + if (axes_in%id == diag_cs%axesT1%id) then + axes => diag_cs%axesT1 + elseif (axes_in%id == diag_cs%axesB1%id) then + axes => diag_cs%axesB1 + elseif (axes_in%id == diag_cs%axesCu1%id) then + axes => diag_cs%axesCu1 + elseif (axes_in%id == diag_cs%axesCv1%id) then + axes => diag_cs%axesCv1 + else + allocate(axes) + axes = axes_in + endif MOM_missing_value = axes%diag_cs%missing_value - if(present(missing_value)) MOM_missing_value = missing_value + if (present(missing_value)) MOM_missing_value = missing_value diag_cs => axes%diag_cs - primary_id = -1 - - fms_id = register_diag_field_infra(module_name, field_name, axes%handles, & - init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & - range=range, mask_variant=mask_variant, standard_name=standard_name, & - verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & - interp_method=interp_method, tile_count=tile_count) - if (fms_id > 0) then - primary_id = get_new_diag_id(diag_cs) - diag => diag_cs%diags(primary_id) - diag%fms_diag_id = fms_id - if (len(field_name) > len(diag%name)) then - diag%name = field_name(1:len(diag%name)) - else ; diag%name = field_name ; endif + dm_id = -1 + + module_list = "{"//trim(module_name) + num_modnm = 1 + + ! Register the native diagnostic + active = register_diag_field_expand_cmor(dm_id, module_name, field_name, axes, & + init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method=interp_method, tile_count=tile_count, & + cmor_field_name=cmor_field_name, cmor_long_name=cmor_long_name, & + cmor_units=cmor_units, cmor_standard_name=cmor_standard_name, & + cell_methods=cell_methods, x_cell_method=x_cell_method, y_cell_method=y_cell_method, & + conversion=conversion) + num_varnm = 1 ; var_list = "{"//trim(field_name) + if (present(cmor_field_name)) then + num_varnm = num_varnm + 1 + var_list = trim(var_list)//","//trim(cmor_field_name) + endif + var_list = trim(var_list)//"}" + + dimensions = "" + if (axes_in%is_h_point) dimensions = trim(dimensions)//" xh, yh," + if (axes_in%is_q_point) dimensions = trim(dimensions)//" xq, yq," + if (axes_in%is_u_point) dimensions = trim(dimensions)//" xq, yh," + if (axes_in%is_v_point) dimensions = trim(dimensions)//" xh, yq," + if (len_trim(dimensions) > 0) dimensions = trim_trailing_commas(dimensions) + + if (is_root_pe() .and. (diag_CS%available_diag_doc_unit > 0)) then + msg = '' + if (present(cmor_field_name)) msg = 'CMOR equivalent is "'//trim(cmor_field_name)//'"' + call attach_cell_methods(-1, axes, cm_string, cell_methods, x_cell_method, y_cell_method) + module_list = trim(module_list)//"}" + if (num_modnm <= 1) module_list = module_name + if (num_varnm <= 1) var_list = '' + + call log_available_diag(dm_id>0, module_list, field_name, cm_string, msg, diag_CS, & + long_name, units, standard_name, variants=var_list, dimensions=dimensions) + endif - if (present(conversion)) diag%conversion_factor = conversion + register_diag_field = dm_id + +end function register_MOM_IS_diag_field + +!> Returns True if either the native or CMOR version of the diagnostic were registered. Updates 'dm_id' +!! after calling register_diag_field_expand_axes() for both native and CMOR variants of the field. +logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, axes, init_time, & + long_name, units, missing_value, range, mask_variant, standard_name, & + verbose, do_not_log, err_msg, interp_method, tile_count, cmor_field_name, & + cmor_long_name, cmor_units, cmor_standard_name, cell_methods, & + x_cell_method, y_cell_method, conversion) + integer, intent(inout) :: dm_id !< The diag_mediator ID for this diagnostic group + character(len=*), intent(in) :: module_name !< Name of this module, usually "ice_model" or "ice_model_fast" + character(len=*), intent(in) :: field_name !< Name of the diagnostic field + type(axes_grp), intent(in) :: axes !< Container with up to 3 integer handles that indicates axes + !! for this field + type(time_type), intent(in) :: init_time !< Time at which a field is first available? + character(len=*), optional, intent(in) :: long_name !< Long name of a field. + character(len=*), optional, intent(in) :: units !< Units of a field. + character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field + real, optional, intent(in) :: missing_value !< A value that indicates missing values in + !! output files, in unscaled arbitrary units [a] + real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + !! in arbitrary units [a] + logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided + !! with post_data calls (not used in MOM?) + logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) + logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) + character(len=*), optional, intent(out):: err_msg !< String into which an error message might be + !! placed (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should + !! not be interpolated as a scalar + integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) + character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field + character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field + character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field + character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field + character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute. + !! Use '' to have no attribute. If present, this + !! overrides the default constructed from the default + !! for each individual axis direction. + character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. + !! Use '' have no method. + real, optional, intent(in) :: conversion !< A value to multiply data by before writing to files, + !! often including factors to undo internal scaling and + !! in units of [a A-1 ~> 1] + ! Local variables + real :: MOM_missing_value ! A value used to indicate missing values in output files, in arbitrary units [a] + type(diag_ctrl), pointer :: diag_cs => null() + type(diag_type), pointer :: this_diag => null() + integer :: fms_id + character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name + character(len=256) :: cm_string ! A string describing the cell methods returned from attach_cell_methods. + + MOM_missing_value = axes%diag_cs%missing_value + if (present(missing_value)) MOM_missing_value = missing_value + + register_diag_field_expand_cmor = .false. + diag_cs => axes%diag_cs + + ! Set up the 'primary' diagnostic, first get an underlying FMS id + fms_id = register_diag_field_expand_axes(module_name, field_name, axes, init_time, & + long_name=long_name, units=units, missing_value=MOM_missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method=interp_method, tile_count=tile_count) + if (.not. diag_cs%diag_as_chksum) & + call attach_cell_methods(fms_id, axes, cm_string, cell_methods, x_cell_method, y_cell_method) + + this_diag => null() + if (fms_id /= DIAG_FIELD_NOT_FOUND) then + call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name) + if (present(conversion)) this_diag%conversion_factor = conversion + register_diag_field_expand_cmor = .true. + endif + + ! For the CMOR variation of the above diagnostic + if (present(cmor_field_name) .and. .not. diag_cs%diag_as_chksum) then + ! Fallback values for strings set to "NULL" + posted_cmor_units = "not provided" ! + posted_cmor_standard_name = "not provided" ! Values might be able to be replaced with a CS%missing field? + posted_cmor_long_name = "not provided" ! + + ! If attributes are present for MOM variable names, use them first for the register_MOM_IS_diag_field + ! call for CMOR verison of the variable + if (present(units)) posted_cmor_units = units + if (present(standard_name)) posted_cmor_standard_name = standard_name + if (present(long_name)) posted_cmor_long_name = long_name + + ! If specified in the call to register_MOM_IS_diag_field, override attributes with the CMOR versions + if (present(cmor_units)) posted_cmor_units = cmor_units + if (present(cmor_standard_name)) posted_cmor_standard_name = cmor_standard_name + if (present(cmor_long_name)) posted_cmor_long_name = cmor_long_name + + fms_id = register_diag_field_expand_axes(module_name, cmor_field_name, axes, init_time, & + long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), & + missing_value=MOM_missing_value, range=range, mask_variant=mask_variant, & + standard_name=trim(posted_cmor_standard_name), verbose=verbose, do_not_log=do_not_log, & + err_msg=err_msg, interp_method=interp_method, tile_count=tile_count) + call attach_cell_methods(fms_id, axes, cm_string, cell_methods, x_cell_method, y_cell_method) + + this_diag => null() + if (fms_id /= DIAG_FIELD_NOT_FOUND) then + call add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name) + if (present(conversion)) this_diag%conversion_factor = conversion + register_diag_field_expand_cmor = .true. + endif endif - if (is_root_pe() .and. diag_CS%doc_unit > 0) then - if (primary_id > 0) then - mesg = '"'//trim(module_name)//'", "'//trim(field_name)//'" [Used]' +end function register_diag_field_expand_cmor + +!> Returns an FMS id from register_diag_field_fms (the diag_manager routine) after expanding axes +!! (axes-group) into handles and conditionally adding an FMS area_id for cell_measures. +integer function register_diag_field_expand_axes(module_name, field_name, axes, init_time, & + long_name, units, missing_value, range, mask_variant, standard_name, & + verbose, do_not_log, err_msg, interp_method, tile_count) + character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" + !! or "ice_shelf_model" + character(len=*), intent(in) :: field_name !< Name of the diagnostic field + type(axes_grp), target, intent(in) :: axes !< Container with up to 3 integer handles that indicates + !! axes for this field + type(time_type), intent(in) :: init_time !< Time at which a field is first available? + character(len=*), optional, intent(in) :: long_name !< Long name of a field. + character(len=*), optional, intent(in) :: units !< Units of a field. + character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field + real, optional, intent(in) :: missing_value !< A value that indicates missing values in + !! output files, in unscaled arbitrary units [a] + real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + !! in arbitrary units [a] + logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided + !! with post_data calls (not used in MOM?) + logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) + logical, optional, intent(in) :: do_not_log !< If true, do not log something + !! (not used in MOM?) + character(len=*), optional, intent(out):: err_msg !< String into which an error message might be + !! placed (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should + !! not be interpolated as a scalar + integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) + ! Local variables + integer :: fms_id, area_id + + ! This gets the cell area associated with the grid location of this variable + area_id = axes%id_area + + ! Get the FMS diagnostic id + if (axes%diag_cs%diag_as_chksum) then + fms_id = axes%diag_cs%num_chksum_diags + 1 + axes%diag_cs%num_chksum_diags = fms_id + elseif (present(interp_method) .or. axes%is_h_point) then + ! If interp_method is provided we must use it + if (area_id>0) then + fms_id = register_diag_field_infra(module_name, field_name, axes%handles, & + init_time, long_name=long_name, units=units, missing_value=missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method=interp_method, tile_count=tile_count, area=area_id) else - mesg = '"'//trim(module_name)//'", "'//trim(field_name)//'" [Unused]' + fms_id = register_diag_field_infra(module_name, field_name, axes%handles, & + init_time, long_name=long_name, units=units, missing_value=missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method=interp_method, tile_count=tile_count) endif - write(diag_CS%doc_unit, '(a)') trim(mesg) - if (present(long_name)) call describe_option("long_name", long_name, diag_CS) - if (present(units)) call describe_option("units", units, diag_CS) - if (present(standard_name)) & - call describe_option("standard_name", standard_name, diag_CS) - endif - - !Decide what mask to use based on the axes info - if (primary_id > 0) then - !2d masks - if (axes%rank == 2) then - diag%mask2d => null() ; diag%mask2d_comp => null() - if (axes%id == diag_cs%axesT1%id) then - diag%mask2d => diag_cs%mask2dT - diag%mask2d_comp => diag_cs%mask2dT_comp - elseif (axes%id == diag_cs%axesB1%id) then - diag%mask2d => diag_cs%mask2dBu - elseif (axes%id == diag_cs%axesCu1%id) then - diag%mask2d => diag_cs%mask2dCu - elseif (axes%id == diag_cs%axesCv1%id) then - diag%mask2d => diag_cs%mask2dCv - ! else - ! call SIS_error(FATAL, "SIS_diag_mediator:register_diag_field: " // & - ! "unknown axes for diagnostic variable "//trim(field_name)) + else + ! If interp_method is not provided and the field is not at an h-point then interp_method='none' + if (area_id>0) then + fms_id = register_diag_field_infra(module_name, field_name, axes%handles, & + init_time, long_name=long_name, units=units, missing_value=missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method='none', tile_count=tile_count, area=area_id) + else + fms_id = register_diag_field_infra(module_name, field_name, axes%handles, & + init_time, long_name=long_name, units=units, missing_value=missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & + interp_method='none', tile_count=tile_count) + endif + endif + + register_diag_field_expand_axes = fms_id + +end function register_diag_field_expand_axes + +!> Create a diagnostic type and attached to list +subroutine add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name, field_name) + type(diag_ctrl), pointer :: diag_cs !< Diagnostics mediator control structure + integer, intent(inout) :: dm_id !< The diag_mediator ID for this diagnostic group + integer, intent(in) :: fms_id !< The FMS diag_manager ID for this diagnostic + type(diag_type), pointer :: this_diag !< This diagnostic + type(axes_grp), target, intent(in) :: axes !< Container with up to 3 integer handles that + !! indicates axes for this field + character(len=*), intent(in) :: module_name !< Name of this module, usually + !! "ocean_model" or "ice_shelf_model" + character(len=*), intent(in) :: field_name !< Name of diagnostic + + ! If the diagnostic is needed obtain a diag_mediator ID (if needed) + if (dm_id == -1) dm_id = get_new_diag_id(diag_cs) + ! Create a new diag_type to store links in + call alloc_diag_with_id(dm_id, diag_cs, this_diag) + call assert(associated(this_diag), 'add_diag_to_list: allocation failed for '//trim(field_name)) + ! Record FMS id, masks and conversion factor, in diag_type + this_diag%fms_diag_id = fms_id + this_diag%debug_str = trim(module_name)//"-"//trim(field_name) + this_diag%axes => axes + +end subroutine add_diag_to_list + + +!> Attaches "cell_methods" attribute to a variable based on defaults for axes_grp or optional arguments. +subroutine attach_cell_methods(id, axes, ostring, cell_methods, x_cell_method, y_cell_method) + integer, intent(in) :: id !< Handle to diagnostic + type(axes_grp), intent(in) :: axes !< Container with up to 3 integer handles that indicates + !! axes for this field + character(len=*), intent(out) :: ostring !< The cell_methods strings that would appear in the file + character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute. + !! Use '' to have no attribute. If present, this + !! overrides the default constructed from the default + !! for each individual axis direction. + character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. + !! Use '' have no method. + ! Local variables + character(len=9) :: axis_name + logical :: x_mean, y_mean, x_sum, y_sum + + x_mean = .false. + y_mean = .false. + x_sum = .false. + y_sum = .false. + + ostring = '' + if (present(cell_methods)) then + if (present(x_cell_method) .or. present(y_cell_method)) then + call MOM_error(FATAL, "attach_cell_methods: " // & + 'Individual direction cell method was specified along with a "cell_methods" string.') + endif + if (len(trim(cell_methods))>0) then + call MOM_diag_field_add_attribute(id, 'cell_methods', trim(cell_methods)) + ostring = trim(cell_methods) + endif + else + if (present(x_cell_method)) then + if (len(trim(x_cell_method))>0) then + call get_MOM_diag_axis_name(axes%handles(1), axis_name) + call MOM_diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(x_cell_method)) + ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(x_cell_method) + if (trim(x_cell_method)=='mean') x_mean=.true. + if (trim(x_cell_method)=='sum') x_sum=.true. endif else - call MOM_error(FATAL, "MOM_IS_diag_mediator:register_diag_field: " // & - "unknown axes for diagnostic variable "//trim(field_name)) + if (len(trim(axes%x_cell_method))>0) then + call get_MOM_diag_axis_name(axes%handles(1), axis_name) + call MOM_diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(axes%x_cell_method)) + ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(axes%x_cell_method) + if (trim(axes%x_cell_method)=='mean') x_mean=.true. + if (trim(axes%x_cell_method)=='sum') x_sum=.true. + endif endif - endif ! if (primary_id>-1) + if (present(y_cell_method)) then + if (len(trim(y_cell_method))>0) then + call get_MOM_diag_axis_name(axes%handles(2), axis_name) + call MOM_diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(y_cell_method)) + ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(y_cell_method) + if (trim(y_cell_method)=='mean') y_mean=.true. + if (trim(y_cell_method)=='sum') y_sum=.true. + endif + else + if (len(trim(axes%y_cell_method))>0) then + call get_MOM_diag_axis_name(axes%handles(2), axis_name) + call MOM_diag_field_add_attribute(id, 'cell_methods', trim(axis_name)//':'//trim(axes%y_cell_method)) + ostring = trim(adjustl(ostring))//' '//trim(axis_name)//':'//trim(axes%y_cell_method) + if (trim(axes%y_cell_method)=='mean') y_mean=.true. + if (trim(axes%y_cell_method)=='sum') y_sum=.true. + endif + endif + if (x_mean .and. y_mean) then + call MOM_diag_field_add_attribute(id, 'cell_methods', 'area:mean') + ostring = trim(adjustl(ostring))//' area:mean' + elseif (x_sum .and. y_sum) then + call MOM_diag_field_add_attribute(id, 'cell_methods', 'area:sum') + ostring = trim(adjustl(ostring))//' area:sum' + endif + endif + ostring = adjustl(ostring) +end subroutine attach_cell_methods + +!> Registers a non-array scalar diagnostic, returning an integer handle +function register_scalar_field_axes(module_name, field_name, axes, init_time, & + long_name, units, missing_value, range, standard_name, & + do_not_log, err_msg, interp_method, cmor_field_name, & + cmor_long_name, cmor_units, cmor_standard_name, conversion) result (register_scalar_field) + integer :: register_scalar_field !< An integer handle for a diagnostic array. + character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" + !! or "ice_shelf_model" + character(len=*), intent(in) :: field_name !< Name of the diagnostic field + type(axes_grp), target, intent(in) :: axes !< Container with up to 3 integer handles that + !! indicates axes for this field + type(time_type), intent(in) :: init_time !< Time at which a field is first available? + character(len=*), optional, intent(in) :: long_name !< Long name of a field. + character(len=*), optional, intent(in) :: units !< Units of a field. + character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field + real, optional, intent(in) :: missing_value !< A value that indicates missing values in + !! output files, in unscaled arbitrary units [a] + real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + !! in arbitrary units [a] + logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) + character(len=*), optional, intent(out):: err_msg !< String into which an error message might be + !! placed (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not + !! be interpolated as a scalar + character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field + character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field + character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field + character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field + real, optional, intent(in) :: conversion !< A value to multiply data by before writing to files, + !! often including factors to undo internal scaling and + !! in units of [a A-1 ~> 1] + + register_scalar_field = register_scalar_field_CS(module_name, field_name, init_time, axes%diag_cs, & + long_name, units, missing_value, range, standard_name, & + do_not_log, err_msg, interp_method, cmor_field_name, & + cmor_long_name, cmor_units, cmor_standard_name, conversion) + +end function register_scalar_field_axes + +!> Registers a non-array scalar diagnostic, returning an integer handle +function register_scalar_field_CS(module_name, field_name, init_time, diag_cs, & + long_name, units, missing_value, range, standard_name, & + do_not_log, err_msg, interp_method, cmor_field_name, & + cmor_long_name, cmor_units, cmor_standard_name, conversion) result (register_scalar_field) + integer :: register_scalar_field !< An integer handle for a diagnostic array. + character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" + !! or "ice_shelf_model" + character(len=*), intent(in) :: field_name !< Name of the diagnostic field + type(time_type), intent(in) :: init_time !< Time at which a field is first available? + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output + character(len=*), optional, intent(in) :: long_name !< Long name of a field. + character(len=*), optional, intent(in) :: units !< Units of a field. + character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field + real, optional, intent(in) :: missing_value !< A value that indicates missing values in + !! output files, in unscaled arbitrary units [a] + real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + !! in arbitrary units [a] + logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) + character(len=*), optional, intent(out):: err_msg !< String into which an error message might be + !! placed (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not + !! be interpolated as a scalar + character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field + character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field + character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field + character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field + real, optional, intent(in) :: conversion !< A value to multiply data by before writing to files, + !! often including factors to undo internal scaling and + !! in units of [a A-1 ~> 1] - register_diag_field = primary_id + ! Local variables + real :: MOM_missing_value ! A value used to indicate missing values in output files, in arbitrary units [a] + integer :: dm_id, fms_id + type(diag_type), pointer :: diag => null(), cmor_diag => null() + character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name + character(len=16) :: dimensions + + MOM_missing_value = diag_cs%missing_value + if (present(missing_value)) MOM_missing_value = missing_value + + dm_id = -1 + diag => null() + cmor_diag => null() + + if (diag_cs%diag_as_chksum) then + fms_id = diag_cs%num_chksum_diags + 1 + diag_cs%num_chksum_diags = fms_id + else + fms_id = register_diag_field_infra(module_name, field_name, init_time, & + long_name=long_name, units=units, missing_value=MOM_missing_value, & + range=range, standard_name=standard_name, do_not_log=do_not_log, & + err_msg=err_msg) + endif -end function register_MOM_IS_diag_field + if (fms_id /= DIAG_FIELD_NOT_FOUND) then + dm_id = get_new_diag_id(diag_cs) + call alloc_diag_with_id(dm_id, diag_cs, diag) + call assert(associated(diag), 'register_scalar_field: diag allocation failed') + diag%fms_diag_id = fms_id + diag%debug_str = trim(module_name)//"-"//trim(field_name) + if (present(conversion)) diag%conversion_factor = conversion + endif + + if (present(cmor_field_name)) then + ! Fallback values for strings set to "not provided" + posted_cmor_units = "not provided" + posted_cmor_standard_name = "not provided" + posted_cmor_long_name = "not provided" + + ! If attributes are present for MOM variable names, use them as defaults for the + ! register_diag_field_infra call for CMOR verison of the variable + if (present(units)) posted_cmor_units = units + if (present(standard_name)) posted_cmor_standard_name = standard_name + if (present(long_name)) posted_cmor_long_name = long_name + + ! If specified in the call to register_MOM_IS_scalar_field, override attributes with the CMOR versions + if (present(cmor_units)) posted_cmor_units = cmor_units + if (present(cmor_standard_name)) posted_cmor_standard_name = cmor_standard_name + if (present(cmor_long_name)) posted_cmor_long_name = cmor_long_name + + fms_id = register_diag_field_infra(module_name, cmor_field_name, init_time, & + long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), & + missing_value=MOM_missing_value, range=range, & + standard_name=trim(posted_cmor_standard_name), do_not_log=do_not_log, err_msg=err_msg) + if (fms_id /= DIAG_FIELD_NOT_FOUND) then + if (dm_id == -1) then + dm_id = get_new_diag_id(diag_cs) + endif + call alloc_diag_with_id(dm_id, diag_cs, cmor_diag) + cmor_diag%fms_diag_id = fms_id + cmor_diag%debug_str = trim(module_name)//"-"//trim(cmor_field_name) + if (present(conversion)) cmor_diag%conversion_factor = conversion + endif + endif + + dimensions = "scalar" + + ! Document diagnostics in list of available diagnostics + if (is_root_pe() .and. diag_CS%available_diag_doc_unit > 0) then + if (present(cmor_field_name)) then + call log_available_diag(associated(diag), module_name, field_name, '', '', diag_CS, & + long_name, units, standard_name, & + variants="{"//trim(field_name)//","//trim(cmor_field_name)//"}", & + dimensions=dimensions) + else + call log_available_diag(associated(diag), module_name, field_name, '', '', diag_CS, & + long_name, units, standard_name, dimensions=dimensions) + endif + endif + + register_scalar_field = dm_id + +end function register_scalar_field_CS !> Registers a static diagnostic, returning an integer handle -integer function register_MOM_IS_static_field(module_name, field_name, axes, & +function register_MOM_IS_static_field(module_name, field_name, axes, & long_name, units, missing_value, range, mask_variant, standard_name, & - do_not_log, interp_method, tile_count) - integer :: register_static_field !< The returned diagnostic handle - character(len=*), intent(in) :: module_name !< Name of this module, usually "ice_model" + do_not_log, interp_method, tile_count, & + cmor_field_name, cmor_long_name, cmor_units, cmor_standard_name, area, & + x_cell_method, y_cell_method, area_cell_method, conversion) result(register_static_field) + integer :: register_static_field !< An integer handle for a diagnostic array. + character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" + !! or "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of the diagnostic field - type(axesType), intent(in) :: axes !< The axis group for this field + type(axes_grp), target, intent(in) :: axes !< Container with up to 3 integer handles that + !! indicates axes for this field character(len=*), optional, intent(in) :: long_name !< Long name of a field. character(len=*), optional, intent(in) :: units !< Units of a field. character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field - real, optional, intent(in) :: missing_value !< A value that indicates missing values. - real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + real, optional, intent(in) :: missing_value !< A value that indicates missing values in + !! output files, in unscaled arbitrary units [a] + real, optional, intent(in) :: range(2) !< Valid range of a variable in arbitrary units [a] logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with !! post_IS_data calls (not used in MOM?) logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not !! be interpolated as a scalar - integer, optional, intent(in) :: tile_count !< no clue (not used in MOM_IS?) + integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) + character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field + character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field + character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field + character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field + integer, optional, intent(in) :: area !< fms_id for area_t + character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. + character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. + character(len=*), optional, intent(in) :: area_cell_method !< Specifies the cell method for area + real, optional, intent(in) :: conversion !< A value to multiply data by before writing to files, + !! often including factors to undo internal scaling and + !! in units of [a A-1 ~> 1] ! Local variables - character(len=240) :: mesg - real :: MOM_missing_value - integer :: primary_id, fms_id - type(diag_ctrl), pointer :: diag_cs !< A structure that is used to regulate diagnostic output + real :: MOM_missing_value ! A value used to indicate missing values in output files, in arbitrary units [a] + type(diag_ctrl), pointer :: diag_cs => null() !< A structure that is used to regulate diagnostic output + type(diag_type), pointer :: diag => null(), cmor_diag => null() + integer :: dm_id, fms_id + character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name + character(len=9) :: axis_name + character(len=24) :: dimensions MOM_missing_value = axes%diag_cs%missing_value - if(present(missing_value)) MOM_missing_value = missing_value + if (present(missing_value)) MOM_missing_value = missing_value diag_cs => axes%diag_cs - primary_id = -1 + dm_id = -1 + diag => null() + cmor_diag => null() - fms_id = register_static_field_infra(module_name, field_name, axes%handles, & - long_name=long_name, units=units, missing_value=MOM_missing_value, & - range=range, mask_variant=mask_variant, standard_name=standard_name, & - do_not_log=do_not_log, & - interp_method=interp_method, tile_count=tile_count) - if (fms_id > 0) then - primary_id = get_new_diag_id(diag_cs) - diag_cs%diags(primary_id)%fms_diag_id = fms_id + if (diag_cs%diag_as_chksum) then + fms_id = diag_cs%num_chksum_diags + 1 + diag_cs%num_chksum_diags = fms_id + else + fms_id = register_static_field_infra(module_name, field_name, axes%handles, & + long_name=long_name, units=units, missing_value=MOM_missing_value, & + range=range, mask_variant=mask_variant, standard_name=standard_name, & + do_not_log=do_not_log, & + interp_method=interp_method, tile_count=tile_count, area=area) + endif + + if (fms_id /= DIAG_FIELD_NOT_FOUND) then + dm_id = get_new_diag_id(diag_cs) + call alloc_diag_with_id(dm_id, diag_cs, diag) + call assert(associated(diag), 'register_static_field: diag allocation failed') + diag%fms_diag_id = fms_id + diag%debug_str = trim(module_name)//"-"//trim(field_name) + if (present(conversion)) diag%conversion_factor = conversion + + if (diag_cs%diag_as_chksum) then + diag%axes => axes + else + if (present(x_cell_method)) then + call get_MOM_diag_axis_name(axes%handles(1), axis_name) + call MOM_diag_field_add_attribute(fms_id, 'cell_methods', & + trim(axis_name)//':'//trim(x_cell_method)) + endif + if (present(y_cell_method)) then + call get_MOM_diag_axis_name(axes%handles(2), axis_name) + call MOM_diag_field_add_attribute(fms_id, 'cell_methods', & + trim(axis_name)//':'//trim(y_cell_method)) + endif + if (present(area_cell_method)) then + call MOM_diag_field_add_attribute(fms_id, 'cell_methods', & + 'area:'//trim(area_cell_method)) + endif + endif + endif + + if (present(cmor_field_name) .and. .not. diag_cs%diag_as_chksum) then + ! Fallback values for strings set to "not provided" + posted_cmor_units = "not provided" + posted_cmor_standard_name = "not provided" + posted_cmor_long_name = "not provided" + + ! If attributes are present for MOM variable names, use them first for the register_static_field + ! call for CMOR verison of the variable + if (present(units)) posted_cmor_units = units + if (present(standard_name)) posted_cmor_standard_name = standard_name + if (present(long_name)) posted_cmor_long_name = long_name + + ! If specified in the call to register_static_field, override attributes with the CMOR versions + if (present(cmor_units)) posted_cmor_units = cmor_units + if (present(cmor_standard_name)) posted_cmor_standard_name = cmor_standard_name + if (present(cmor_long_name)) posted_cmor_long_name = cmor_long_name + + fms_id = register_static_field_infra(module_name, cmor_field_name, axes%handles, & + long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), & + missing_value=MOM_missing_value, range=range, mask_variant=mask_variant, & + standard_name=trim(posted_cmor_standard_name), do_not_log=do_not_log, & + interp_method=interp_method, tile_count=tile_count, area=area) + if (fms_id /= DIAG_FIELD_NOT_FOUND) then + if (dm_id == -1) then + dm_id = get_new_diag_id(diag_cs) + endif + call alloc_diag_with_id(dm_id, diag_cs, cmor_diag) + cmor_diag%fms_diag_id = fms_id + cmor_diag%debug_str = trim(module_name)//"-"//trim(cmor_field_name) + if (present(conversion)) cmor_diag%conversion_factor = conversion + if (present(x_cell_method)) then + call get_MOM_diag_axis_name(axes%handles(1), axis_name) + call MOM_diag_field_add_attribute(fms_id, 'cell_methods', trim(axis_name)//':'//trim(x_cell_method)) + endif + if (present(y_cell_method)) then + call get_MOM_diag_axis_name(axes%handles(2), axis_name) + call MOM_diag_field_add_attribute(fms_id, 'cell_methods', trim(axis_name)//':'//trim(y_cell_method)) + endif + if (present(area_cell_method)) then + call MOM_diag_field_add_attribute(fms_id, 'cell_methods', 'area:'//trim(area_cell_method)) + endif + endif + endif + + dimensions = "" + if (axes%is_h_point) dimensions = trim(dimensions)//" xh, yh," + if (axes%is_q_point) dimensions = trim(dimensions)//" xq, yq," + if (axes%is_u_point) dimensions = trim(dimensions)//" xq, yh," + if (axes%is_v_point) dimensions = trim(dimensions)//" xh, yq," + if (len_trim(dimensions) > 0) dimensions = trim_trailing_commas(dimensions) + + ! Document diagnostics in list of available diagnostics + if (is_root_pe() .and. diag_CS%available_diag_doc_unit > 0) then + if (present(cmor_field_name)) then + call log_available_diag(associated(diag), module_name, field_name, '', '', diag_CS, & + long_name, units, standard_name, & + variants="{"//trim(field_name)//","//trim(cmor_field_name)//"}", & + dimensions=dimensions) + else + call log_available_diag(associated(diag), module_name, field_name, '', '', diag_CS, & + long_name, units, standard_name, dimensions=dimensions) + endif endif - register_static_field = primary_id + register_static_field = dm_id end function register_MOM_IS_static_field @@ -560,46 +1358,26 @@ end function register_MOM_IS_static_field subroutine describe_option(opt_name, value, diag_CS) character(len=*), intent(in) :: opt_name !< The name of the option character(len=*), intent(in) :: value !< The value of the option - type(diag_ctrl), intent(in) :: diag_CS !< Diagnostic being documented + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output ! Local variables - character(len=240) :: mesg - integer :: start_ind = 1, end_ind, len_ind + character(len=480) :: mesg + integer :: len_ind len_ind = len_trim(value) mesg = " ! "//trim(opt_name)//": "//trim(value) - write(diag_CS%doc_unit, '(a)') trim(mesg) + write(diag_CS%available_diag_doc_unit, '(a)') trim(mesg) end subroutine describe_option -!> Convert the first n elements (up to 3) of an integer array to an underscore delimited string. -function i2s(a, n_in) - integer, dimension(:), intent(in) :: a !< The array of integers to translate - integer, optional , intent(in) :: n_in !< The number of elements to translate, by default all - character(len=15) :: i2s !< The returned string - - ! Local variables - character(len=15) :: i2s_temp - integer :: i,n - - n=size(a) - if(present(n_in)) n = n_in - - i2s = '' - do i=1,n - write (i2s_temp, '(I4.4)') a(i) - i2s = trim(i2s) //'_'// trim(i2s_temp) - enddo - i2s = adjustl(i2s) -end function i2s - -!> Initialize the MOM_IS diag_mediator and opens the available diagnostics file. -subroutine MOM_IS_diag_mediator_init(G, param_file, diag_cs, component, err_msg, & +!> Initialize the MOM_IS diag_mediator and opens the available diagnostics file, if appropriate. +subroutine MOM_IS_diag_mediator_init(G, US, param_file, diag_cs, component, err_msg, & doc_file_dir) - type(ocean_grid_type), intent(inout) :: G !< The horizontal grid type + type(ocean_grid_type), target, intent(inout) :: G !< The horizontal grid type + type(unit_scale_type), target, intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output - character(len=*), optional, intent(in) :: component !< An opitonal component name + type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output + character(len=*), optional, intent(in) :: component !< An optional component name character(len=*), optional, intent(out) :: err_msg !< A string for a returned error message character(len=*), optional, intent(in) :: doc_file_dir !< A directory in which to create the file @@ -608,25 +1386,58 @@ subroutine MOM_IS_diag_mediator_init(G, param_file, diag_cs, component, err_msg, ! is not necessary that the metrics and axis labels be set up yet. ! Local variables - integer :: ios, new_unit + integer :: ios, i, new_unit logical :: opened, new_file character(len=8) :: this_pe character(len=240) :: doc_file, doc_file_dflt, doc_path character(len=40) :: doc_file_param - character(len=40) :: mdl = "MOM_IS_diag_mediator" ! This module's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_IS_diag_mediator" ! This module's name. + character(len=32) :: filename_appendix = '' !fms appendix to filename for ensemble runs call MOM_diag_manager_init(err_msg=err_msg) - ! Allocate list of all diagnostics + id_clock_diag_mediator = cpu_clock_id('(Ice shelf diagnostics framework)', grain=CLOCK_MODULE) + + ! Allocate and initialize list of all diagnostics (and variants) allocate(diag_cs%diags(DIAG_ALLOC_CHUNK_SIZE)) diag_cs%next_free_diag_id = 1 - diag_cs%diags(:)%in_use = .false. + do i=1, DIAG_ALLOC_CHUNK_SIZE + call initialize_diag_type(diag_cs%diags(i)) + enddo + + diag_cs%show_call_tree = callTree_showQuery() + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + + call get_param(param_file, mdl, 'USE_INDEX_DIAGNOSTIC_AXES', diag_cs%index_space_axes, & + 'If true, use a grid index coordinate convention for diagnostic axes. ',& + default=.false.) + + call get_param(param_file, mdl, 'DIAG_MISVAL', diag_cs%missing_value, & + 'Set the default missing value to use for diagnostics.', & + units="various", default=-1.e34) + call get_param(param_file, mdl, 'DIAG_AS_CHKSUM', diag_cs%diag_as_chksum, & + 'Instead of writing diagnostics to the diag manager, write '//& + 'a text file containing the checksum (bitcount) of the array.', & + default=.false.) + + if (diag_cs%diag_as_chksum) & + diag_cs%num_chksum_diags = 0 + + ! Keep pointers to the grid for diagnostic checksums + diag_cs%G => G + diag_cs%US => US diag_cs%is = G%isc - (G%isd-1) ; diag_cs%ie = G%iec - (G%isd-1) diag_cs%js = G%jsc - (G%jsd-1) ; diag_cs%je = G%jec - (G%jsd-1) - diag_cs%isd = G%isd ; diag_cs%ied = G%ied ; diag_cs%jsd = G%jsd ; diag_cs%jed = G%jed + diag_cs%isd = G%isd ; diag_cs%ied = G%ied + diag_cs%jsd = G%jsd ; diag_cs%jed = G%jed - if (is_root_pe() .and. (diag_CS%doc_unit < 0)) then + ! Initialize available diagnostic log file + if (is_root_pe() .and. (diag_CS%available_diag_doc_unit < 0)) then if (present(component)) then doc_file_dflt = trim(component)//".available_diags" doc_file_param = trim(uppercase(component))//"_AVAILABLE_DIAGS_FILE" @@ -638,15 +1449,14 @@ subroutine MOM_IS_diag_mediator_init(G, param_file, diag_cs, component, err_msg, call get_param(param_file, mdl, trim(doc_file_param), doc_file, & "A file into which to write a list of all available "//& "ice shelf diagnostics that can be included in a diag_table.", & - default=doc_file_dflt) + default=doc_file_dflt, do_not_log=(diag_CS%available_diag_doc_unit/=-1)) if (len_trim(doc_file) > 0) then - new_file = .true. ; if (diag_CS%doc_unit /= -1) new_file = .false. + new_file = .true. ; if (diag_CS%available_diag_doc_unit /= -1) new_file = .false. ! Find an unused unit number. do new_unit=512,42,-1 inquire( new_unit, opened=opened) if (.not.opened) exit enddo - if (opened) call MOM_error(FATAL, & "diag_mediator_init failed to find an unused unit number.") @@ -655,36 +1465,84 @@ subroutine MOM_IS_diag_mediator_init(G, param_file, diag_cs, component, err_msg, doc_path = trim(slasher(doc_file_dir))//trim(doc_file) endif ; endif - diag_CS%doc_unit = new_unit + diag_CS%available_diag_doc_unit = new_unit if (new_file) then - open(diag_CS%doc_unit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', & + open(diag_CS%available_diag_doc_unit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', & action='WRITE', status='REPLACE', iostat=ios) else ! This file is being reopened, and should be appended. - open(diag_CS%doc_unit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', & + open(diag_CS%available_diag_doc_unit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', & action='WRITE', status='OLD', position='APPEND', iostat=ios) endif - inquire(diag_CS%doc_unit, opened=opened) + inquire(diag_CS%available_diag_doc_unit, opened=opened) if ((.not.opened) .or. (ios /= 0)) then call MOM_error(FATAL, "Failed to open available diags file "//trim(doc_path)//".") endif endif endif - call diag_masks_set(G, -1.0e34, diag_cs) + if (is_root_pe() .and. (diag_CS%chksum_iounit < 0) .and. diag_CS%diag_as_chksum) then + !write(this_pe,'(i6.6)') PE_here() + !doc_file_dflt = "chksum_diag."//this_pe + doc_file_dflt = "chksum_diag" + call get_param(param_file, mdl, "CHKSUM_DIAG_FILE", doc_file, & + "A file into which to write all checksums of the "//& + "diagnostics listed in the diag_table.", & + default=doc_file_dflt, do_not_log=(diag_CS%chksum_iounit/=-1)) + + call get_filename_appendix(filename_appendix) + if (len_trim(filename_appendix) > 0) then + doc_file = trim(doc_file) //'.'//trim(filename_appendix) + endif +#ifdef STATSLABEL + doc_file = trim(doc_file)//"."//trim(adjustl(STATSLABEL)) +#endif + + if (len_trim(doc_file) > 0) then + new_file = .true. ; if (diag_CS%chksum_iounit /= -1) new_file = .false. + ! Find an unused unit number. + do new_unit=512,42,-1 + inquire( new_unit, opened=opened) + if (.not.opened) exit + enddo + if (opened) call MOM_error(FATAL, & + "diag_mediator_init failed to find an unused unit number.") + + doc_path = doc_file + if (present(doc_file_dir)) then ; if (len_trim(doc_file_dir) > 0) then + doc_path = trim(slasher(doc_file_dir))//trim(doc_file) + endif ; endif + + diag_CS%chksum_iounit = new_unit + + if (new_file) then + open(diag_CS%chksum_iounit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', & + action='WRITE', status='REPLACE', iostat=ios) + else ! This file is being reopened, and should be appended. + open(diag_CS%chksum_iounit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', & + action='WRITE', status='OLD', position='APPEND', iostat=ios) + endif + inquire(diag_CS%chksum_iounit, opened=opened) + if ((.not.opened) .or. (ios /= 0)) then + call MOM_error(FATAL, "Failed to open checksum diags file "//trim(doc_path)//".") + endif + endif + endif + + call diag_masks_set(G, diag_cs%missing_value, diag_cs) end subroutine MOM_IS_diag_mediator_init +!> Sets up the 2d masks for native diagnostics subroutine diag_masks_set(G, missing_value, diag_cs) -! Setup the 2d masks for diagnostics type(ocean_grid_type), target, intent(in) :: G !< The horizontal grid type - real, intent(in) :: missing_value !< A fill value for missing points - type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output + real, intent(in) :: missing_value !< A fill value for missing points + type(diag_ctrl), intent(inout) :: diag_cs !< Structure used to regulate diagnostic output ! Local variables integer :: i, j - + ! 2d masks point to the model masks since they are identical diag_cs%mask2dT => G%mask2dT diag_cs%mask2dBu => G%mask2dBu diag_cs%mask2dCu => G%mask2dCu @@ -695,37 +1553,60 @@ subroutine diag_masks_set(G, missing_value, diag_cs) diag_cs%mask2dT_comp(i,j) = diag_cs%mask2dT(i,j) enddo ; enddo - diag_cs%missing_value = missing_value end subroutine diag_masks_set !> Prevent the registration of additional diagnostics, so that the creation of files can occur subroutine MOM_IS_diag_mediator_close_registration(diag_CS) - type(diag_ctrl), intent(inout) :: diag_CS !< A structure that is used to regulate diagnostic output + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output - if (diag_CS%doc_unit > -1) then - close(diag_CS%doc_unit) ; diag_CS%doc_unit = -2 + if (diag_CS%available_diag_doc_unit > -1) then + close(diag_CS%available_diag_doc_unit) ; diag_CS%available_diag_doc_unit = -2 endif end subroutine MOM_IS_diag_mediator_close_registration !> Deallocate memory associated with the MOM_IS diag mediator subroutine MOM_IS_diag_mediator_end(diag_CS) - type(diag_ctrl), intent(inout) :: diag_CS !< A structure that is used to regulate diagnostic output + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output - if (diag_CS%doc_unit > -1) then - close(diag_CS%doc_unit) ; diag_CS%doc_unit = -3 + ! Local variables + type(diag_type), pointer :: diag, next_diag + integer :: i + + if (diag_CS%available_diag_doc_unit > -1) then + close(diag_CS%available_diag_doc_unit) ; diag_CS%available_diag_doc_unit = -3 + endif + if (diag_CS%chksum_iounit > -1) then + close(diag_CS%chksum_iounit) ; diag_CS%chksum_iounit = -3 endif -end subroutine MOM_IS_diag_mediator_end + do i=1, diag_cs%next_free_diag_id - 1 + if (associated(diag_cs%diags(i)%next)) then + next_diag => diag_cs%diags(i)%next + do while (associated(next_diag)) + diag => next_diag + next_diag => diag%next + deallocate(diag) + enddo + endif + enddo -!> Allocate a new diagnostic id, noting that it may be necessary to expand the diagnostics array. -function get_new_diag_id(diag_cs) + deallocate(diag_cs%diags) - integer :: get_new_diag_id !< The returned ID for the new diagnostic - type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output + ! These points to arrays in the grid type, so they can not be deallocated here. + if (associated(diag_cs%mask2dT)) diag_cs%mask2dT => NULL() + if (associated(diag_cs%mask2dBu)) diag_cs%mask2dBu => NULL() + if (associated(diag_cs%mask2dCu)) diag_cs%mask2dCu => NULL() + if (associated(diag_cs%mask2dCv)) diag_cs%mask2dCv => NULL() + if (associated(diag_cs%mask2dT_comp)) deallocate(diag_cs%mask2dT_comp) +end subroutine MOM_IS_diag_mediator_end + +!> Returns a new diagnostic id, it may be necessary to expand the diagnostics array. +integer function get_new_diag_id(diag_cs) + type(diag_ctrl), intent(inout) :: diag_cs !< Diagnostics control structure ! Local variables type(diag_type), dimension(:), allocatable :: tmp integer :: i @@ -743,9 +1624,9 @@ function get_new_diag_id(diag_cs) diag_cs%diags(1:size(tmp)) = tmp(:) deallocate(tmp) - ! Initialise new part of the diag array. + ! Initialize new part of the diag array. do i=diag_cs%next_free_diag_id, size(diag_cs%diags) - diag_cs%diags(i)%in_use = .false. + call initialize_diag_type(diag_cs%diags(i)) enddo endif @@ -754,4 +1635,112 @@ function get_new_diag_id(diag_cs) end function get_new_diag_id +!> Initializes a diag_type (used after allocating new memory) +subroutine initialize_diag_type(diag) + type(diag_type), intent(inout) :: diag !< diag_type to be initialized + + diag%in_use = .false. + diag%fms_diag_id = -1 + diag%axes => null() + diag%next => null() + diag%conversion_factor = 0. + +end subroutine initialize_diag_type + +!> Make a new diagnostic. Either use memory which is in the array of 'primary' +!! diagnostics, or if that is in use, insert it to the list of secondary diags. +subroutine alloc_diag_with_id(diag_id, diag_cs, diag) + integer, intent(in ) :: diag_id !< id for the diagnostic + type(diag_ctrl), target, intent(inout) :: diag_cs !< structure used to regulate diagnostic output + type(diag_type), pointer :: diag !< structure representing a diagnostic (inout) + + type(diag_type), pointer :: tmp => NULL() + + if (.not. diag_cs%diags(diag_id)%in_use) then + diag => diag_cs%diags(diag_id) + else + allocate(diag) + tmp => diag_cs%diags(diag_id)%next + diag_cs%diags(diag_id)%next => diag + diag%next => tmp + endif + diag%in_use = .true. + +end subroutine alloc_diag_with_id + +!> Log a diagnostic to the available diagnostics file. +subroutine log_available_diag(used, module_name, field_name, cell_methods_string, comment, & + diag_CS, long_name, units, standard_name, variants, dimensions) + logical, intent(in) :: used !< Whether this diagnostic was in the diag_table or not + character(len=*), intent(in) :: module_name !< Name of the diagnostic module + character(len=*), intent(in) :: field_name !< Name of this diagnostic field + character(len=*), intent(in) :: cell_methods_string !< The spatial component of the CF cell_methods attribute + character(len=*), intent(in) :: comment !< A comment to append after [Used|Unused] + type(diag_ctrl), intent(in) :: diag_CS !< The diagnotics control structure + character(len=*), optional, intent(in) :: dimensions !< Descriptor of the horizontal and vertical dimensions + character(len=*), optional, intent(in) :: long_name !< CF long name of diagnostic + character(len=*), optional, intent(in) :: units !< Units for diagnostic + character(len=*), optional, intent(in) :: standard_name !< CF standardized name of diagnostic + character(len=*), optional, intent(in) :: variants !< Alternate modules and variable names for + !! this diagnostic and derived diagnostics + ! Local variables + character(len=240) :: mesg + + if (used) then + mesg = '"'//trim(field_name)//'" [Used]' + else + mesg = '"'//trim(field_name)//'" [Unused]' + endif + if (len(trim((comment)))>0) then + write(diag_CS%available_diag_doc_unit, '(a,1x,"(",a,")")') trim(mesg),trim(comment) + else + write(diag_CS%available_diag_doc_unit, '(a)') trim(mesg) + endif + call describe_option("modules", module_name, diag_CS) + if (present(dimensions)) then ; if (len(trim(dimensions)) > 0) then + call describe_option("dimensions", dimensions, diag_CS) + endif ; endif + if (present(long_name)) call describe_option("long_name", long_name, diag_CS) + if (present(units)) call describe_option("units", units, diag_CS) + if (present(standard_name)) & + call describe_option("standard_name", standard_name, diag_CS) + if (len(trim((cell_methods_string)))>0) & + call describe_option("cell_methods", trim(cell_methods_string), diag_CS) + if (present(variants)) then ; if (len(trim(variants)) > 0) then + call describe_option("variants", variants, diag_CS) + endif ; endif +end subroutine log_available_diag + +!> Log the diagnostic chksum to the chksum diag file +subroutine log_chksum_diag(docunit, description, chksum) + integer, intent(in) :: docunit !< Handle of the log file + character(len=*), intent(in) :: description !< Name of the diagnostic module + integer, intent(in) :: chksum !< chksum of the diagnostic + + write(docunit, '(a,1x,i9.8)') description, chksum + flush(docunit) + +end subroutine log_chksum_diag + +!> Fakes a register of a diagnostic to find out if an obsolete +!! parameter appears in the diag_table. +logical function found_in_diagtable(diag, varName) + type(diag_ctrl), intent(in) :: diag !< A structure used to control diagnostics. + character(len=*), intent(in) :: varName !< The obsolete diagnostic name + ! Local + integer :: handle ! Integer handle returned from diag_manager + + ! We use register_static_field_fms() instead of register_static_field() so + ! that the diagnostic does not appear in the available diagnostics list. + handle = register_static_field_infra('ice_shelf_model', varName, diag%axesT1%handles) + + found_in_diagtable = (handle>0) + +end function found_in_diagtable + +!> Finishes the diag manager reduction methods as needed for the time_step +subroutine MOM_IS_diag_send_complete() + call diag_send_complete_infra() +end subroutine MOM_IS_diag_send_complete + end module MOM_IS_diag_mediator diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 8fb674e36c..ab0b1db776 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -1,9 +1,11 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Implements a crude placeholder for a later implementation of full !! ice shelf dynamics. module MOM_ice_shelf_dynamics -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_ROUTINE use MOM_IS_diag_mediator, only : post_data=>post_IS_data @@ -11,18 +13,21 @@ module MOM_ice_shelf_dynamics !use MOM_IS_diag_mediator, only : MOM_IS_diag_mediator_init, set_IS_diag_mediator_grid use MOM_IS_diag_mediator, only : diag_ctrl, time_type, enable_averages, disable_averaging use MOM_domains, only : MOM_domains_init, clone_MOM_domain -use MOM_domains, only : pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE, CORNER, CENTER +use MOM_domains, only : pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE, AGRID, CORNER, CENTER use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_grid, only : MOM_grid_init, ocean_grid_type use MOM_io, only : file_exists, slasher, MOM_read_data -use MOM_restart, only : register_restart_field, query_initialized -use MOM_restart, only : MOM_restart_CS -use MOM_time_manager, only : time_type, set_time +use MOM_io, only : open_ASCII_file, get_filename_appendix +use MOM_io, only : APPEND_FILE, WRITEONLY_FILE +use MOM_restart, only : register_restart_field, MOM_restart_CS +use MOM_time_manager, only : time_type, get_time, set_time, time_type_to_real, operator(>) +use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) +use MOM_time_manager, only : operator(/=), operator(<=), operator(>=), operator(<) use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init !MJH use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary use MOM_ice_shelf_state, only : ice_shelf_state -use MOM_coms, only : reproducing_sum, sum_across_PEs, max_across_PEs, min_across_PEs +use MOM_coms, only : reproducing_sum, max_across_PEs, min_across_PEs use MOM_checksums, only : hchksum, qchksum use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary_channel,initialize_ice_flow_from_file use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary_from_file,initialize_ice_C_basal_friction @@ -31,9 +36,15 @@ module MOM_ice_shelf_dynamics #include -public register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn, update_ice_shelf -public ice_time_step_CFL, ice_shelf_dyn_end -public shelf_advance_front, ice_shelf_min_thickness_calve, calve_to_mask +public register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn, update_ice_shelf, IS_dynamics_post_data +public ice_time_step_CFL, ice_shelf_dyn_end, change_in_draft, write_ice_shelf_energy +public shelf_advance_front, ice_shelf_min_thickness_calve, calve_to_mask, volume_above_floatation +public masked_var_grounded + +! SSA inner solver flags +integer, parameter :: INNER_CG = 1 !< Conjugate gradient (default) +integer, parameter :: INNER_MINRES = 2 !< MINRES +integer, parameter :: INNER_CR = 3 !< Conjugate residual ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -46,20 +57,27 @@ module MOM_ice_shelf_dynamics !! on q-points (B grid) [L T-1 ~> m s-1] real, pointer, dimension(:,:) :: v_shelf => NULL() !< the meridional velocity of the ice shelf/sheet !! on q-points (B grid) [L T-1 ~> m s-1] - real, pointer, dimension(:,:) :: taudx_shelf => NULL() !< the driving stress of the ice shelf/sheet - !! on q-points (C grid) [Pa ~> Pa] - real, pointer, dimension(:,:) :: taudy_shelf => NULL() !< the meridional stress of the ice shelf/sheet - !! on q-points (C grid) [Pa ~> Pa] + real, pointer, dimension(:,:) :: taudx_shelf => NULL() !< the zonal driving stress of the ice shelf/sheet + !! on q-points (C grid) [R L2 T-2 ~> Pa] + real, pointer, dimension(:,:) :: taudy_shelf => NULL() !< the meridional driving stress of the ice shelf/sheet + !! on q-points (C grid) [R L2 T-2 ~> Pa] + real, pointer, dimension(:,:) :: sx_shelf => NULL() !< the zonal surface slope of the ice shelf/sheet + !! on q-points (B grid) [nondim] + real, pointer, dimension(:,:) :: sy_shelf => NULL() !< the meridional surface slope of the ice shelf/sheet + !! on q-points (B grid) [nondim] real, pointer, dimension(:,:) :: u_face_mask => NULL() !< mask for velocity boundary conditions on the C-grid !! u-face - this is because the FEM cares about FACES THAT GET INTEGRATED OVER, !! not vertices. Will represent boundary conditions on computational boundary !! (or permanent boundary between fast-moving and near-stagnant ice !! FOR NOW: 1=interior bdry, 0=no-flow boundary, 2=stress bdry condition, - !! 3=inhomogeneous Dirichlet boundary, 4=flux boundary: at these faces a flux - !! will be specified which will override velocities; a homogeneous velocity - !! condition will be specified (this seems to give the solver less difficulty) + !! 3=inhomogeneous Dirichlet boundary for u and v, 4=flux boundary: at these + !! faces a flux will be specified which will override velocities; a homogeneous + !! velocity condition will be specified (this seems to give the solver less + !! difficulty) 5=inhomogenous Dirichlet boundary for u only. 6=inhomogenous + !! Dirichlet boundary for v only real, pointer, dimension(:,:) :: v_face_mask => NULL() !< A mask for velocity boundary conditions on the C-grid - !! v-face, with valued defined similarly to u_face_mask. + !! v-face, with valued defined similarly to u_face_mask, but 5 is Dirichlet for v + !! and 6 is Dirichlet for u real, pointer, dimension(:,:) :: u_face_mask_bdry => NULL() !< A duplicate copy of u_face_mask? real, pointer, dimension(:,:) :: v_face_mask_bdry => NULL() !< A duplicate copy of v_face_mask? real, pointer, dimension(:,:) :: u_flux_bdry_val => NULL() !< The ice volume flux per unit face length into the cell @@ -76,35 +94,65 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: calve_mask => NULL() !< a mask to prevent the ice shelf front from !! advancing past its initial position (but it may retreat) real, pointer, dimension(:,:) :: t_shelf => NULL() !< Vertically integrated temperature in the ice shelf/stream, - !! on corner-points (B grid) [degC] + !! on corner-points (B grid) [C ~> degC] real, pointer, dimension(:,:) :: tmask => NULL() !< A mask on tracer points that is 1 where there is ice. - real, pointer, dimension(:,:) :: ice_visc => NULL() !< Glen's law ice viscosity, often in [R L4 Z T-1 ~> kg m2 s-1]. + real, pointer, dimension(:,:,:) :: ice_visc => NULL() !< Area and depth-integrated Glen's law ice viscosity + !! (Pa m3 s) in [R L4 Z T-1 ~> kg m2 s-1]. + !! at either 1 (cell-centered) or 4 quadrature points per cell + real, pointer, dimension(:,:,:) :: newton_visc_factor => NULL() !< Newton tangent stiffness coefficient: + !! (1/n_glen - 1)/2 * ice_visc / eps_e2 at each + !! viscosity quadrature point [R L4 Z T ~> kg m2 s] + real, pointer, dimension(:,:,:) :: newton_str_ux => NULL() !< Longitudinal x-strain-rate ux at each viscosity + !! quadrature point for Newton iterations [T-1 ~> s-1] + real, pointer, dimension(:,:,:) :: newton_str_vy => NULL() !< Longitudinal y-strain-rate vy at each viscosity + !! quadrature point for Newton iterations [T-1 ~> s-1] + real, pointer, dimension(:,:,:) :: newton_str_sh => NULL() !< Engineering shear strain-rate uy+vx at each + !! viscosity quadrature point for Newton iterations [T-1 ~> s-1] + real, pointer, dimension(:,:) :: newton_umid => NULL() !< Cell-averaged zonal velocity u at the current outer + !! iterate, for Newton basal drag correction [L T-1 ~> m s-1] + real, pointer, dimension(:,:) :: newton_vmid => NULL() !< Cell-averaged meridional velocity v at the current + !! outer iterate, for Newton basal drag correction [L T-1 ~> m s-1] + real, pointer, dimension(:,:) :: newton_drag_coef => NULL() !< Newton basal drag correction coefficient: + !! 2 * d(basal_trac)/d(|u|^2) * area = d(tau_b_i)/d(u_j) - basal_trac*delta_ij + !! expressed as the u_i*u_j tensor coefficient [R Z T ~> kg m-2 s] real, pointer, dimension(:,:) :: AGlen_visc => NULL() !< Ice-stiffness parameter in Glen's law ice viscosity, - !! often in [kg-1/3 m-1/3 s-1]. - real, pointer, dimension(:,:) :: thickness_bdry_val => NULL() !< The ice thickness at an inflowing boundary [Z ~> m]. + !! often in [Pa-3 s-1] if n_Glen is 3. real, pointer, dimension(:,:) :: u_bdry_val => NULL() !< The zonal ice velocity at inflowing boundaries !! [L yr-1 ~> m yr-1] real, pointer, dimension(:,:) :: v_bdry_val => NULL() !< The meridional ice velocity at inflowing boundaries !! [L yr-1 ~> m yr-1] - real, pointer, dimension(:,:) :: h_bdry_val => NULL() !< The ice thickness at inflowing boundaries [m]. - real, pointer, dimension(:,:) :: t_bdry_val => NULL() !< The ice temperature at inflowing boundaries [degC]. + real, pointer, dimension(:,:) :: h_bdry_val => NULL() !< The ice thickness at inflowing boundaries [Z ~> m]. + real, pointer, dimension(:,:) :: t_bdry_val => NULL() !< The ice temperature at inflowing boundaries [C ~> degC]. real, pointer, dimension(:,:) :: bed_elev => NULL() !< The bed elevation used for ice dynamics [Z ~> m], !! relative to mean sea-level. This is !! the same as G%bathyT+Z_ref, when below sea-level. !! Sign convention: positive below sea-level, negative above. - real, pointer, dimension(:,:) :: basal_traction => NULL() !< The area integrated nonlinear part of "linearized" - !! basal stress [R Z L2 T-1 ~> kg s-1]. + real, pointer, dimension(:,:) :: basal_traction => NULL() !< The area-integrated taub_beta field + !! (m2 Pa s m-1, or kg s-1) related to the nonlinear part + !! of "linearized" basal stress (Pa) [R Z L2 T-1 ~> kg s-1] !! The exact form depends on basal law exponent and/or whether flow is "hybridized" a la Goldberg 2011 real, pointer, dimension(:,:) :: C_basal_friction => NULL()!< Coefficient in sliding law tau_b = C u^(n_basal_fric), - !! units= Pa (m yr-1)-(n_basal_fric) - real, pointer, dimension(:,:) :: OD_rt => NULL() !< A running total for calculating OD_av. + !! units of [R L Z T-2 (s m-1)^(n_basal_fric) ~> Pa (s m-1)^(n_basal_fric)] + real, pointer, dimension(:,:) :: OD_rt => NULL() !< A running total for calculating OD_av [Z ~> m]. real, pointer, dimension(:,:) :: ground_frac_rt => NULL() !< A running total for calculating ground_frac. real, pointer, dimension(:,:) :: OD_av => NULL() !< The time average open ocean depth [Z ~> m]. real, pointer, dimension(:,:) :: ground_frac => NULL() !< Fraction of the time a cell is "exposed", i.e. the column !! thickness is below a threshold and interacting with the rock [nondim]. When this !! is 1, the ice-shelf is grounded + real, pointer, dimension(:,:) :: float_cond => NULL() !< If GL_regularize=true, indicates cells containing + !! the grounding line (float_cond=1) or not (float_cond=0) + real, pointer, dimension(:,:,:,:) :: Phi => NULL() !< The gradients of bilinear basis elements at Gaussian + !! 4 quadrature points surrounding the cell vertices [L-1 ~> m-1]. + real, pointer, dimension(:,:,:) :: PhiC => NULL() !< The gradients of bilinear basis elements at 1 cell-centered + !! quadrature point per cell [L-1 ~> m-1]. + real, pointer, dimension(:,:,:) :: Jac => NULL() !< Jacobian determinant |J_q| = a_q*d_q of the element + !! mapping at each of the 4 Gaussian quadrature points [L2 ~> m2]. + !! Equal to G%areaT only for rectangular elements; differs when + !! opposite cell edges have unequal lengths (non-rectangular quads). + real, pointer, dimension(:,:,:,:,:,:) :: Phisub => NULL() !< Quadrature structure weights at subgridscale + !! locations for finite element calculations [nondim] integer :: OD_rt_counter = 0 !< A counter of the number of contributions to OD_rt. real :: velocity_update_time_step !< The time interval over which to update the ice shelf velocity @@ -117,7 +165,24 @@ module MOM_ice_shelf_dynamics real :: g_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. real :: density_ice !< A typical density of ice [R ~> kg m-3]. - + real :: Cp_ice !< The heat capacity of fresh ice [Q C-1 ~> J kg-1 degC-1]. + + logical :: advect_shelf !< If true (default), advect ice shelf and evolve thickness + logical :: reentrant_x !< If true, the domain is zonally reentrant + logical :: reentrant_y !< If true, the domain is meridionally reentrant + logical :: alternate_first_direction_IS !< If true, alternate whether the x- or y-direction + !! updates occur first in directionally split parts of the calculation. + integer :: first_direction_IS !< An integer that indicates which direction is + !! to be updated first in directionally split + !! parts of the ice sheet calculation (e.g. advection). + real :: first_dir_restart_IS = -1.0 !< A real copy of CS%first_direction_IS for use in restart files + integer :: visc_qps !< The number of quadrature points per cell (1 or 4) on which to calculate ice viscosity. + character(len=40) :: ice_viscosity_compute !< Specifies whether the ice viscosity is computed internally + !! according to Glen's flow law; is constant (for debugging purposes) + !! or using observed strain rates and read from a file + logical :: shelf_top_slope_bugs !< If true, use directionally inconsistent estimates of the grid + !! spacing when calculating the ice shelf surface slope, and underestimate + !! slopes near the edge of the ice shelf by a factor of 2. logical :: GL_regularize !< Specifies whether to regularize the floatation condition !! at the grounding line as in Goldberg Holland Schoof 2009 integer :: n_sub_regularize @@ -131,11 +196,20 @@ module MOM_ice_shelf_dynamics !! should be exclusive) real :: CFL_factor !< A factor used to limit subcycled advective timestep in uncoupled runs - !! i.e. dt <= CFL_factor * min(dx / u) - - real :: n_glen !< Nonlinearity exponent in Glen's Law - real :: eps_glen_min !< Min. strain rate to avoid infinite Glen's law viscosity, [year-1]. - real :: n_basal_fric !< Exponent in sliding law tau_b = C u^(m_slide) + !! i.e. dt <= CFL_factor * min(dx / u) [nondim] + + real :: min_h_shelf !< The minimum ice thickness used during ice dynamics [Z ~> m]. + real :: min_basal_traction !< The minimum basal traction for grounded ice (Pa m-1 s) [R Z T-1 ~> kg m-2 s-1] + real :: max_surface_slope !< The maximum allowed ice-sheet surface slope (to ignore, set to zero) [nondim] + real :: min_ice_visc !< The minimum allowed Glen's law ice viscosity (Pa s), in [R L2 T-1 ~> kg m-1 s-1]. + + real :: n_glen !< Nonlinearity exponent in Glen's Law [nondim] + real :: eps_glen_min !< Min. strain rate to avoid infinite Glen's law viscosity, [T-1 ~> s-1]. + real :: n_basal_fric !< Exponent in sliding law tau_b = C u^(m_slide) [nondim] + logical :: CoulombFriction !< Use Coulomb friction law (Schoof 2005, Gagliardini et al 2007) + real :: CF_MinN !< Minimum Coulomb friction effective pressure [R Z L T-2 ~> Pa] + real :: CF_PostPeak !< Coulomb friction post peak exponent [nondim] + real :: CF_Max !< Coulomb friction maximum coefficient [nondim] real :: density_ocean_avg !< A typical ocean density [R ~> kg m-3]. This does not affect ocean !! circulation or thermodynamics. It is used to estimate the !! gravitational driving force at the shelf front (until we think of @@ -144,27 +218,65 @@ module MOM_ice_shelf_dynamics logical :: moving_shelf_front !< Specify whether to advance shelf front (and calve). logical :: calve_to_mask !< If true, calve off the ice shelf when it passes the edge of a mask. real :: min_thickness_simple_calve !< min. ice shelf thickness criteria for calving [Z ~> m]. - + real :: T_shelf_missing !< An ice shelf temperature to use where there is no ice shelf [C ~> degC] real :: cg_tolerance !< The tolerance in the CG solver, relative to initial residual, that - !! determines when to stop the conjugate gradient iterations. + !! determines when to stop the conjugate gradient iterations [nondim]. + real :: cg_tol_newton !< Working CG tolerance for the current inner solve [nondim]. real :: nonlinear_tolerance !< The fractional nonlinear tolerance, relative to the initial error, - !! that sets when to stop the iterative velocity solver + !! that sets when to stop the iterative velocity solver [nondim] + real :: newton_after_tolerance !< The fractional nonlinear tolerance, relative to the initial error, at + !! which to switch from Picard to Newton iterations in the velocity solver [nondim] + logical :: newton_adapt_cg_tol !< Use an adaptive CG tolerance during Newton iterations integer :: cg_max_iterations !< The maximum number of iterations that can be used in the CG solver integer :: nonlin_solve_err_mode !< 1: exit vel solve based on nonlin residual !! 2: exit based on "fixed point" metric (|u - u_last| / |u| < tol) where | | is infty-norm + !! 3: exit based on change of norm + + ! for write_ice_shelf_energy + type(time_type) :: energysavedays !< The interval between writing the energies + !! and other integral quantities of the run. + type(time_type) :: energysavedays_geometric !< The starting interval for computing a geometric + !! progression of time deltas between calls to + !! write_energy. This interval will increase by a factor of 2. + !! after each call to write_energy. + logical :: energysave_geometric !< Logical to control whether calls to write_energy should + !! follow a geometric progression + type(time_type) :: write_energy_time !< The next time to write to the energy file. + type(time_type) :: geometric_end_time !< Time at which to stop the geometric progression + !! of calls to write_energy and revert to the standard + !! energysavedays interval + real :: timeunit !< The length of the units for the time axis and certain input parameters + !! including ENERGYSAVEDAYS [s]. + type(time_type) :: Start_time !< The start time of the simulation. + ! Start_time is set in MOM_initialization.F90 + integer :: prev_IS_energy_calls = 0 !< The number of times write_ice_shelf_energy has been called. + integer :: IS_fileenergy_ascii !< The unit number of the ascii version of the energy file. + character(len=200) :: IS_energyfile !< The name of the ice sheet energy file with path. ! ids for outputting intermediate thickness in advection subroutine (debugging) !integer :: id_h_after_uflux = -1, id_h_after_vflux = -1, id_h_after_adv = -1 logical :: debug !< If true, write verbose checksums for debugging purposes !! and use reproducible sums + logical :: doing_newton = .false. !< If true, the outer iteration is using Newton (tangent) linearization + !! instead of Picard (secant) linearization for the ice viscosity + integer :: inner_solver !< The inner linear solver: INNER_CG (1),INNER_MINRES (2), or INNER_CR (3) + logical :: cg_halo_shrink = .true. !< If true, CG uses halo-shrinking to defer pass_vector calls; + !! if false, uses fixed CG_action range with 1 pass_vector per iteration logical :: module_is_initialized = .false. !< True if this module has been initialized. !>@{ Diagnostic handles - integer :: id_u_shelf = -1, id_v_shelf = -1, id_t_shelf = -1, & - id_taudx_shelf = -1, id_taudy_shelf = -1, id_bed_elev = -1, & - id_ground_frac = -1, id_col_thick = -1, id_OD_av = -1, & - id_u_mask = -1, id_v_mask = -1, id_ufb_mask =-1, id_vfb_mask = -1, id_t_mask = -1 + integer :: id_u_shelf = -1, id_v_shelf = -1, id_shelf_speed, id_t_shelf = -1, & + id_taudx_shelf = -1, id_taudy_shelf = -1, id_taud_shelf = -1, id_bed_elev = -1, & + id_ground_frac = -1, id_col_thick = -1, id_OD_av = -1, id_float_cond = -1, & + id_u_mask = -1, id_v_mask = -1, id_ufb_mask =-1, id_vfb_mask = -1, id_t_mask = -1, & + id_sx_shelf = -1, id_sy_shelf = -1, id_surf_slope_mag_shelf, & + id_duHdx = -1, id_dvHdy = -1, id_fluxdiv = -1, & + id_strainrate_xx = -1, id_strainrate_yy = -1, id_strainrate_xy = -1, & + id_pstrainrate_1 = -1, id_pstrainrate_2, & + id_devstress_xx = -1, id_devstress_yy = -1, id_devstress_xy = -1, & + id_pdevstress_1 = -1, id_pdevstress_2 = -1 + !>@} ! ids for outputting intermediate thickness in advection subroutine (debugging) !>@{ Diagnostic handles for debugging @@ -177,9 +289,10 @@ module MOM_ice_shelf_dynamics !> A container for loop bounds type :: loop_bounds_type ; private - !>@{ Loop bounds - integer :: ish, ieh, jsh, jeh - !>@} + integer :: ish !< Starting i-index of the computational domain [nondim] + integer :: ieh !< Ending i-index of the computational domain [nondim] + integer :: jsh !< Starting j-index of the computational domain [nondim] + integer :: jeh !< Ending j-index of the computational domain [nondim] end type loop_bounds_type contains @@ -215,21 +328,24 @@ function quad_area (X, Y) ! | | ! 1 - 2 - p2 = (X(4)-X(1))**2 + (Y(4)-Y(1))**2 ; q2 = (X(3)-X(2))**2 + (Y(3)-Y(2))**2 - a2 = (X(3)-X(4))**2 + (Y(3)-Y(4))**2 ; c2 = (X(1)-X(2))**2 + (Y(1)-Y(2))**2 - b2 = (X(2)-X(4))**2 + (Y(2)-Y(4))**2 ; d2 = (X(3)-X(1))**2 + (Y(3)-Y(1))**2 + p2 = ( ((X(4)-X(1))**2) + ((Y(4)-Y(1))**2) ) ; q2 = ( ((X(3)-X(2))**2) + ((Y(3)-Y(2))**2) ) + a2 = ( ((X(3)-X(4))**2) + ((Y(3)-Y(4))**2) ) ; c2 = ( ((X(1)-X(2))**2) + ((Y(1)-Y(2))**2) ) + b2 = ( ((X(2)-X(4))**2) + ((Y(2)-Y(4))**2) ) ; d2 = ( ((X(3)-X(1))**2) + ((Y(3)-Y(1))**2) ) quad_area = .25 * sqrt(4*P2*Q2-(B2+D2-A2-C2)**2) end function quad_area !> This subroutine is used to register any fields related to the ice shelf !! dynamics that should be written to or read from the restart file. -subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) +subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) type(ocean_grid_type), intent(inout) :: G !< The grid type describing the ice shelf grid. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(ice_shelf_dyn_CS), pointer :: CS !< A pointer to the ice shelf dynamics control structure type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct + ! Local variables + real :: T_shelf_missing ! An ice shelf temperature to use where there is no ice shelf [C ~> degC] logical :: shelf_mass_is_dynamic, override_shelf_movement, active_shelf_dynamics character(len=40) :: mdl = "MOM_ice_shelf_dyn" ! This module's name. integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -256,55 +372,95 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) endif if (active_shelf_dynamics) then - allocate( CS%u_shelf(IsdB:IedB,JsdB:JedB), source=0.0 ) - allocate( CS%v_shelf(IsdB:IedB,JsdB:JedB), source=0.0 ) - allocate( CS%t_shelf(isd:ied,jsd:jed), source=-10.0 ) ! [degC] - allocate( CS%ice_visc(isd:ied,jsd:jed), source=0.0 ) - allocate( CS%AGlen_visc(isd:ied,jsd:jed), source=2.261e-25 ) ! [Pa-3s-1] - allocate( CS%basal_traction(isd:ied,jsd:jed), source=0.0 ) - allocate( CS%C_basal_friction(isd:ied,jsd:jed), source=5.0e10 ) ! [Pa (m-1 s)^n_sliding] - allocate( CS%OD_av(isd:ied,jsd:jed), source=0.0 ) - allocate( CS%ground_frac(isd:ied,jsd:jed), source=0.0 ) - allocate( CS%taudx_shelf(IsdB:IedB,JsdB:JedB), source=0.0 ) - allocate( CS%taudy_shelf(IsdB:IedB,JsdB:JedB), source=0.0 ) - allocate( CS%bed_elev(isd:ied,jsd:jed) ) ; CS%bed_elev(:,:) = G%bathyT(:,:) + G%Z_ref - allocate( CS%u_bdry_val(IsdB:IedB,JsdB:JedB), source=0.0 ) - allocate( CS%v_bdry_val(IsdB:IedB,JsdB:JedB), source=0.0 ) - allocate( CS%u_face_mask_bdry(IsdB:IedB,JsdB:JedB), source=-2.0 ) - allocate( CS%v_face_mask_bdry(IsdB:iedB,JsdB:JedB), source=-2.0 ) - allocate( CS%h_bdry_val(isd:ied,jsd:jed), source=0.0 ) + call get_param(param_file, mdl, "MISSING_SHELF_TEMPERATURE", T_shelf_missing, & + "An ice shelf temperature to use where there is no ice shelf.",& + units="degC", default=-10.0, scale=US%degC_to_C, do_not_log=.true.) + + call get_param(param_file, mdl, "NUMBER_OF_ICE_VISCOSITY_QUADRATURE_POINTS", CS%visc_qps, & + "Number of ice viscosity quadrature points. Either 1 (cell-centered) for 4", & + units="none", default=1) + if (CS%visc_qps/=1 .and. CS%visc_qps/=4) call MOM_error (FATAL, & + "NUMBER OF ICE_VISCOSITY_QUADRATURE_POINTS must be 1 or 4") + + call get_param(param_file, mdl, "FIRST_DIRECTION_IS", CS%first_direction_IS, & + "An integer that indicates which direction goes first "//& + "in parts of the code that use directionally split "//& + "updates (e.g. advection), with even numbers (or 0) used for x- first "//& + "and odd numbers used for y-first.", default=0) + call get_param(param_file, mdl, "ALTERNATE_FIRST_DIRECTION_IS", CS%alternate_first_direction_IS, & + "If true, after every advection call, alternate whether the x- or y- "//& + "direction advection updates occur first. "//& + "If this is true, FIRST_DIRECTION applies at the start of a new run or if "//& + "the next first direction can not be found in the restart file.", default=.false.) + + allocate(CS%u_shelf(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%v_shelf(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%t_shelf(isd:ied,jsd:jed), source=T_shelf_missing) ! [C ~> degC] + allocate(CS%ice_visc(isd:ied,jsd:jed,CS%visc_qps), source=0.0) + allocate(CS%newton_visc_factor(isd:ied,jsd:jed,CS%visc_qps), source=0.0) + allocate(CS%newton_str_ux(isd:ied,jsd:jed,CS%visc_qps), source=0.0) + allocate(CS%newton_str_vy(isd:ied,jsd:jed,CS%visc_qps), source=0.0) + allocate(CS%newton_str_sh(isd:ied,jsd:jed,CS%visc_qps), source=0.0) + allocate(CS%newton_umid(isd:ied,jsd:jed), source=0.0) + allocate(CS%newton_vmid(isd:ied,jsd:jed), source=0.0) + allocate(CS%newton_drag_coef(isd:ied,jsd:jed), source=0.0) + allocate(CS%AGlen_visc(isd:ied,jsd:jed), source=2.261e-25) ! [Pa-3 s-1] + allocate(CS%basal_traction(isd:ied,jsd:jed), source=0.0) ! [R Z L2 T-1 ~> kg s-1] + allocate(CS%C_basal_friction(isd:ied,jsd:jed), source=5.0e10*US%Pa_to_RLZ_T2) + ! Units of [R L Z T-2 (s m-1)^n_sliding ~> Pa (s m-1)^n_sliding] + allocate(CS%OD_av(isd:ied,jsd:jed), source=0.0) + allocate(CS%ground_frac(isd:ied,jsd:jed), source=0.0) + allocate(CS%taudx_shelf(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%taudy_shelf(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%sx_shelf(isd:ied,jsd:jed), source=0.0) + allocate(CS%sy_shelf(isd:ied,jsd:jed), source=0.0) + allocate(CS%bed_elev(isd:ied,jsd:jed), source=0.0) + allocate(CS%u_bdry_val(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%v_bdry_val(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%u_face_mask_bdry(IsdB:IedB,JsdB:JedB), source=-2.0) + allocate(CS%v_face_mask_bdry(IsdB:iedB,JsdB:JedB), source=-2.0) + allocate(CS%h_bdry_val(isd:ied,jsd:jed), source=0.0) + ! additional restarts for ice shelf state call register_restart_field(CS%u_shelf, "u_shelf", .false., restart_CS, & - "ice sheet/shelf u-velocity", "m s-1", hor_grid='Bu') + "ice sheet/shelf u-velocity", & + units="m s-1", conversion=US%L_T_to_m_s, hor_grid='Bu') call register_restart_field(CS%v_shelf, "v_shelf", .false., restart_CS, & - "ice sheet/shelf v-velocity", "m s-1", hor_grid='Bu') + "ice sheet/shelf v-velocity", & + units="m s-1", conversion=US%L_T_to_m_s, hor_grid='Bu') call register_restart_field(CS%u_bdry_val, "u_bdry_val", .false., restart_CS, & - "ice sheet/shelf boundary u-velocity", "m s-1", hor_grid='Bu') + "ice sheet/shelf boundary u-velocity", & + units="m s-1", conversion=US%L_T_to_m_s, hor_grid='Bu') call register_restart_field(CS%v_bdry_val, "v_bdry_val", .false., restart_CS, & - "ice sheet/shelf boundary v-velocity", "m s-1", hor_grid='Bu') + "ice sheet/shelf boundary v-velocity", & + units="m s-1", conversion=US%L_T_to_m_s, hor_grid='Bu') call register_restart_field(CS%u_face_mask_bdry, "u_face_mask_bdry", .false., restart_CS, & "ice sheet/shelf boundary u-mask", "nondim", hor_grid='Bu') call register_restart_field(CS%v_face_mask_bdry, "v_face_mask_bdry", .false., restart_CS, & "ice sheet/shelf boundary v-mask", "nondim", hor_grid='Bu') call register_restart_field(CS%OD_av, "OD_av", .true., restart_CS, & - "Average open ocean depth in a cell","m") + "Average open ocean depth in a cell", "m", conversion=US%Z_to_m) call register_restart_field(CS%ground_frac, "ground_frac", .true., restart_CS, & "fractional degree of grounding", "nondim") call register_restart_field(CS%C_basal_friction, "C_basal_friction", .true., restart_CS, & - "basal sliding coefficients", "Pa (m s-1)^n_sliding") + "basal sliding coefficients", "Pa (s m-1)^n_sliding", conversion=US%RLZ_T2_to_Pa) call register_restart_field(CS%AGlen_visc, "AGlen_visc", .true., restart_CS, & "ice-stiffness parameter", "Pa-3 s-1") call register_restart_field(CS%h_bdry_val, "h_bdry_val", .false., restart_CS, & - "ice thickness at the boundary","m") + "ice thickness at the boundary", "m", conversion=US%Z_to_m) + call register_restart_field(CS%bed_elev, "bed elevation", .true., restart_CS, & + "bed elevation", "m", conversion=US%Z_to_m) + call register_restart_field(CS%first_dir_restart_IS, "first_direction_IS", .false., restart_CS, & + "Indicator of the first direction in split ice shelf calculations.", "nondim") endif end subroutine register_ice_shelf_dyn_restarts !> Initializes shelf model data, parameters and diagnostics -subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_sim, solo_ice_sheet_in) +subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_sim, Cp_ice, & + Input_start_time, directory, solo_ice_sheet_in) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(ocean_grid_type), pointer :: ocn_grid !< The calling ocean model's horizontal grid structure type(time_type), intent(inout) :: Time !< The clock that that will indicate the model time type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe !! the ice-shelf state @@ -314,23 +470,28 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate the diagnostic output. logical, intent(in) :: new_sim !< If true this is a new simulation, otherwise !! has been started from a restart file. + real, intent(in) :: Cp_ice !< Heat capacity of ice [Q C-1 ~> J kg-1 degC-1] + type(time_type), intent(in) :: Input_start_time !< The start time of the simulation. + character(len=*), intent(in) :: directory !< The directory where the ice sheet energy file goes. logical, optional, intent(in) :: solo_ice_sheet_in !< If present, this indicates whether !! a solo ice-sheet driver. ! Local variables - real :: Z_rescale ! A rescaling factor for heights from the representation in - ! a restart file to the internal representation in this run. - real :: vel_rescale ! A rescaling factor for horizontal velocities from the representation - ! in a restart file to the internal representation in this run. + real :: T_shelf_bdry ! A default ice shelf temperature to use for ice flowing + ! in through open boundaries [C ~> degC] !This include declares and sets the variable "version". # include "version_variable.h" - character(len=200) :: config character(len=200) :: IC_file,filename,inputdir character(len=40) :: var_name character(len=40) :: mdl = "MOM_ice_shelf_dyn" ! This module's name. logical :: shelf_mass_is_dynamic, override_shelf_movement, active_shelf_dynamics + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. logical :: debug - integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq, iters + integer :: i, j, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq, iters + character(len=200) :: IS_energyfile ! The name of the energy file. + character(len=32) :: filename_appendix = '' ! FMS appendix to filename for ensemble runs + character(len=16) :: inner_solver_str ! The type of inner solver to use for the SSA Isdq = G%isdB ; Iedq = G%iedB ; Jsdq = G%jsdB ; Jedq = G%jedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -379,11 +540,14 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ "will be called. GL_REGULARIZE and GL_COUPLE are exclusive.", & default=.false., do_not_log=CS%GL_regularize) if (CS%GL_regularize) CS%GL_couple = .false. + if (present(solo_ice_sheet_in)) then + if (solo_ice_sheet_in) CS%GL_couple = .false. + endif if (CS%GL_regularize .and. (CS%n_sub_regularize == 0)) call MOM_error (FATAL, & "GROUNDING_LINE_INTERP_SUBGRID_N must be a positive integer if GL regularization is used") call get_param(param_file, mdl, "ICE_SHELF_CFL_FACTOR", CS%CFL_factor, & "A factor used to limit timestep as CFL_FACTOR * min (\Delta x / u). "//& - "This is only used with an ice-only model.", default=0.25) + "This is only used with an ice-only model.", units="nondim", default=0.25) endif call get_param(param_file, mdl, "RHO_0", CS%density_ocean_avg, & "avg ocean density used in floatation cond", & @@ -394,7 +558,20 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ fail_if_missing=.true.) call get_param(param_file, mdl, "G_EARTH", CS%g_Earth, & "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80, scale=US%m_s_to_L_T**2*US%Z_to_m) + units="m s-2", default=9.80, scale=US%m_s_to_L_T**2*US%Z_to_m) + + call get_param(param_file, mdl, "MIN_H_SHELF", CS%min_h_shelf, & + "min. ice thickness used during ice dynamics", & + units="m", default=0.,scale=US%m_to_Z) + call get_param(param_file, mdl, "MIN_BASAL_TRACTION", CS%min_basal_traction, & + "min. allowed basal traction. Input is in [Pa m-1 yr], but is converted when read in to [Pa m-1 s]", & + units="Pa m-1 yr", default=0., scale=365.0*86400.0*US%Pa_to_RLZ_T2*US%L_T_to_m_s) + call get_param(param_file, mdl, "MAX_SURFACE_SLOPE", CS%max_surface_slope, & + "max. allowed ice-sheet surface slope. To ignore, set to zero.", & + units="none", default=0., scale=US%m_to_Z/US%m_to_L) + call get_param(param_file, mdl, "MIN_ICE_VISC", CS%min_ice_visc, & + "min. allowed Glen's law ice viscosity", & + units="Pa s", default=0., scale=US%Pa_to_RL2_T2*US%s_to_T) call get_param(param_file, mdl, "GLEN_EXPONENT", CS%n_glen, & "nonlinearity exponent in Glen's Law", & @@ -405,12 +582,49 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call get_param(param_file, mdl, "BASAL_FRICTION_EXP", CS%n_basal_fric, & "Exponent in sliding law \tau_b = C u^(n_basal_fric)", & units="none", fail_if_missing=.true.) + call get_param(param_file, mdl, "USE_COULOMB_FRICTION", CS%CoulombFriction, & + "Use Coulomb Friction Law", & + units="none", default=.false., fail_if_missing=.false.) + call get_param(param_file, mdl, "CF_MinN", CS%CF_MinN, & + "Minimum Coulomb friction effective pressure", & + units="Pa", default=1.0, scale=US%Pa_to_RLZ_T2, fail_if_missing=.false.) + call get_param(param_file, mdl, "CF_PostPeak", CS%CF_PostPeak, & + "Coulomb friction post peak exponent", & + units="none", default=1.0, fail_if_missing=.false.) + call get_param(param_file, mdl, "CF_Max", CS%CF_Max, & + "Coulomb friction maximum coefficient", & + units="none", default=0.5, fail_if_missing=.false.) + call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & "A typical density of ice.", units="kg m-3", default=917.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "CONJUGATE_GRADIENT_TOLERANCE", CS%cg_tolerance, & - "tolerance in CG solver, relative to initial residual", default=1.e-6) + "tolerance in CG solver, relative to initial residual", units="nondim", default=1.e-6) + CS%cg_tol_newton = CS%cg_tolerance ! Will be tightened adaptively during Newton iterations call get_param(param_file, mdl, "ICE_NONLINEAR_TOLERANCE", CS%nonlinear_tolerance, & - "nonlin tolerance in iterative velocity solve",default=1.e-6) + "nonlin tolerance in iterative velocity solve", units="nondim", default=1.e-6) + call get_param(param_file, mdl, "NEWTON_AFTER_TOLERANCE", CS%newton_after_tolerance, & + "Switch from Picard to Newton iterations in the nonlinear ice velocity solve when "//& + "the fractional nonlinear residual falls below this tolerance.",& + units="none", default=CS%nonlinear_tolerance) + call get_param(param_file, mdl, "NEWTON_ADAPT_CG_TOL", CS%newton_adapt_cg_tol, & + "Use an adaptive CG tolerance during Newton iterations.", default=.true.) + call get_param(param_file, mdl, "ICE_SHELF_INNER_SOLVER", inner_solver_str, & + "Choice of inner linear solver for the ice-shelf SSA velocity system. "//& + "Valid choices are CG (default), CR, and MINRES.", & + default="CG") + select case (trim(inner_solver_str)) + case ("CG") + CS%inner_solver = INNER_CG + case ("MINRES") + CS%inner_solver = INNER_MINRES + case ("CR") + CS%inner_solver = INNER_CR + end select + call get_param(param_file, mdl, "CG_HALO_SHRINK", CS%cg_halo_shrink, & + "If true, CG uses halo-shrinking to defer pass_vector calls. "//& + "If false, uses a fixed CG_action range with one pass_vector(D) per iteration, "//& + "which may reduce total communication for typical halo widths.", & + default=.true.) call get_param(param_file, mdl, "CONJUGATE_GRADIENT_MAXIT", CS%cg_max_iterations, & "max iteratiions in CG solver", default=2000) call get_param(param_file, mdl, "THRESH_FLOAT_COL_DEPTH", CS%thresh_float_col_depth, & @@ -419,7 +633,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ units="m", default=1.e-3, scale=US%m_to_Z) call get_param(param_file, mdl, "NONLIN_SOLVE_ERR_MODE", CS%nonlin_solve_err_mode, & "Choose whether nonlin error in vel solve is based on nonlinear "//& - "residual (1) or relative change since last iteration (2)", default=1) + "residual (1), relative change since last iteration (2), or change in norm (3)", default=3) call get_param(param_file, mdl, "SHELF_MOVING_FRONT", CS%moving_shelf_front, & "Specify whether to advance shelf front (and calve).", & @@ -427,18 +641,85 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call get_param(param_file, mdl, "CALVE_TO_MASK", CS%calve_to_mask, & "If true, do not allow an ice shelf where prohibited by a mask.", & default=.false.) - + call get_param(param_file, mdl, "ADVECT_SHELF", CS%advect_shelf, & + "If true, advect ice shelf and evolve thickness", & + default=.true.) + call get_param(param_file, mdl, "REENTRANT_X", CS%reentrant_x, & + " If true, the domain is zonally reentrant.", & + default=.false.) + call get_param(param_file, mdl, "REENTRANT_Y", CS%reentrant_y, & + " If true, the domain is meridionally reentrant.", & + default=.false.) + call get_param(param_file, mdl, "ICE_VISCOSITY_COMPUTE", CS%ice_viscosity_compute, & + "If MODEL, compute ice viscosity internally using 1 or 4 quadrature points, "//& + "if OBS read from a file, "//& + "if CONSTANT a constant value (for debugging).", & + default="MODEL") + + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. + call get_param(param_file, mdl, "ICE_SHELF_TOP_SLOPE_BUG", CS%shelf_top_slope_bugs, & + "If true, use directionally inconsistent estimates of the grid spacing when "//& + "calculating the ice shelf surface slope, and underestimate slopes near the "//& + "edge of the ice shelf by a factor of 2.", default=enable_bugs) + + if ((CS%visc_qps/=1) .and. (trim(CS%ice_viscosity_compute) /= "MODEL")) then + call MOM_error(FATAL, "NUMBER_OF_ICE_VISCOSITY_QUADRATURE_POINTS must be 1 unless ICE_VISCOSITY_COMPUTE==MODEL.") + endif + call get_param(param_file, mdl, "INFLOW_SHELF_TEMPERATURE", T_shelf_bdry, & + "A default ice shelf temperature to use for ice flowing in through "//& + "open boundaries.", units="degC", default=-15.0, scale=US%degC_to_C) endif + call get_param(param_file, mdl, "MISSING_SHELF_TEMPERATURE", CS%T_shelf_missing, & + "An ice shelf temperature to use where there is no ice shelf.",& + units="degC", default=-10.0, scale=US%degC_to_C) call get_param(param_file, mdl, "MIN_THICKNESS_SIMPLE_CALVE", CS%min_thickness_simple_calve, & "Min thickness rule for the VERY simple calving law",& units="m", default=0.0, scale=US%m_to_Z) + CS%Cp_ice = Cp_ice !Heat capacity of ice (J kg-1 K-1), needed for heat flux of any bergs calved from + !the ice shelf and for ice sheet temperature solver + !for write_ice_shelf_energy + ! Note that the units of CS%Timeunit are the MKS units of [s]. + call get_param(param_file, mdl, "TIMEUNIT", CS%Timeunit, & + "The time unit in seconds a number of input fields", & + units="s", default=86400.0) + if (CS%Timeunit < 0.0) CS%Timeunit = 86400.0 + call get_param(param_file, mdl, "ENERGYSAVEDAYS",CS%energysavedays, & + "The interval in units of TIMEUNIT between saves of the "//& + "energies of the run and other globally summed diagnostics.",& + default=set_time(0,days=1), timeunit=CS%Timeunit) + call get_param(param_file, mdl, "ENERGYSAVEDAYS_GEOMETRIC",CS%energysavedays_geometric, & + "The starting interval in units of TIMEUNIT for the first call "//& + "to save the energies of the run and other globally summed diagnostics. "//& + "The interval increases by a factor of 2. after each call to write_ice_shelf_energy.",& + default=set_time(seconds=0), timeunit=CS%Timeunit) + if ((time_type_to_real(CS%energysavedays_geometric) > 0.) .and. & + (CS%energysavedays_geometric < CS%energysavedays)) then + CS%energysave_geometric = .true. + else + CS%energysave_geometric = .false. + endif + CS%Start_time = Input_start_time + call get_param(param_file, mdl, "ICE_SHELF_ENERGYFILE", IS_energyfile, & + "The file to use to write the energies and globally "//& + "summed diagnostics.", default="ice_shelf.stats") + !query fms_io if there is a filename_appendix (for ensemble runs) + call get_filename_appendix(filename_appendix) + if (len_trim(filename_appendix) > 0) then + IS_energyfile = trim(IS_energyfile) //'.'//trim(filename_appendix) + endif + + CS%IS_energyfile = trim(slasher(directory))//trim(IS_energyfile) + call log_param(param_file, mdl, "output_path/ENERGYFILE", CS%IS_energyfile) +#ifdef STATSLABEL + CS%IS_energyfile = trim(CS%IS_energyfile)//"."//trim(adjustl(STATSLABEL)) +#endif ! Allocate memory in the ice shelf dynamics control structure that was not ! previously allocated for registration for restarts. if (active_shelf_dynamics) then - allocate( CS%t_bdry_val(isd:ied,jsd:jed), source=-15.0) ! [degC] - allocate( CS%thickness_bdry_val(isd:ied,jsd:jed), source=0.0) + allocate( CS%t_bdry_val(isd:ied,jsd:jed), source=T_shelf_bdry) ! [C ~> degC] allocate( CS%u_face_mask(Isdq:Iedq,Jsdq:Jedq), source=0.0) allocate( CS%v_face_mask(Isdq:Iedq,Jsdq:Jedq), source=0.0) allocate( CS%u_flux_bdry_val(Isdq:Iedq,jsd:jed), source=0.0) @@ -446,6 +727,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ allocate( CS%umask(Isdq:Iedq,Jsdq:Jedq), source=-1.0) allocate( CS%vmask(Isdq:Iedq,Jsdq:Jedq), source=-1.0) allocate( CS%tmask(Isdq:Iedq,Jsdq:Jedq), source=-1.0) + allocate( CS%float_cond(isd:ied,jsd:jed)) CS%OD_rt_counter = 0 allocate( CS%OD_rt(isd:ied,jsd:jed), source=0.0) @@ -455,6 +737,25 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ allocate( CS%calve_mask(isd:ied,jsd:jed), source=0.0) endif + allocate(CS%Phi(1:8,1:4,isd:ied,jsd:jed), source=0.0) + allocate(CS%Jac(1:4,isd:ied,jsd:jed), source=0.0) + do j=G%jsd,G%jed ; do i=G%isd,G%ied + call bilinear_shape_fn_grid(G, i, j, CS%Phi(:,:,i,j), CS%Jac(:,i,j)) + enddo ; enddo + + if (CS%GL_regularize) then + allocate(CS%Phisub(2,2,CS%n_sub_regularize,CS%n_sub_regularize,2,2), source=0.0) + call bilinear_shape_functions_subgrid(CS%Phisub, CS%n_sub_regularize) + endif + + if ((trim(CS%ice_viscosity_compute) == "MODEL") .and. CS%visc_qps==1) then + !for calculating viscosity and 1 cell-centered quadrature point per cell + allocate(CS%PhiC(1:8,G%isc:G%iec,G%jsc:G%jec), source=0.0) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + call bilinear_shape_fn_grid_1qp(G, i, j, CS%PhiC(:,i,j)) + enddo ; enddo + endif + CS%elapsed_velocity_time = 0.0 call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) @@ -462,53 +763,67 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! Take additional initialization steps, for example of dependent variables. if (active_shelf_dynamics .and. .not.new_sim) then - if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= US%m_to_Z)) then - Z_rescale = US%m_to_Z / US%m_to_Z_restart - do j=G%jsc,G%jec ; do i=G%isc,G%iec - CS%OD_av(i,j) = Z_rescale * CS%OD_av(i,j) - enddo ; enddo - endif - if ((US%m_to_L_restart*US%s_to_T_restart /= 0.0) .and. & - (US%m_to_L_restart /= US%m_s_to_L_T*US%s_to_T_restart)) then - vel_rescale = US%m_s_to_L_T*US%s_to_T_restart / US%m_to_L_restart - do J=G%jsc-1,G%jec ; do I=G%isc-1,G%iec - CS%u_shelf(I,J) = vel_rescale * CS%u_shelf(I,J) - CS%v_shelf(I,J) = vel_rescale * CS%v_shelf(I,J) - enddo ; enddo - endif + call pass_var(CS%OD_av,G%domain, complete=.false.) + call pass_var(CS%ground_frac, G%domain, complete=.false.) + call pass_var(CS%basal_traction, G%domain, complete=.false.) + call pass_var(CS%AGlen_visc, G%domain, complete=.false.) + call pass_var(CS%bed_elev, G%domain, complete=.false.) + call pass_var(CS%C_basal_friction, G%domain, complete=.false.) + call pass_var(CS%h_bdry_val, G%domain, complete=.true.) + call pass_var(CS%ice_visc, G%domain) + + call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE, complete=.true.) + call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) - ! this is unfortunately necessary; if grid is not symmetric the boundary values - ! of u and v are otherwise not set till the end of the first linear solve, and so - ! viscosity is not calculated correctly. + ! This is unfortunately necessary (?); if grid is not symmetric the boundary values + ! of u and v are otherwise not set till the end of the first linear solve, and so + ! viscosity is not calculated correctly. ! This has to occur after init_boundary_values or some of the arrays on the ! right hand side have not been set up yet. if (.not. G%symmetric) then do j=G%jsd,G%jed ; do i=G%isd,G%ied - if (((i+G%idg_offset) == (G%domain%nihalo+1)).and.(CS%u_face_mask(I-1,j) == 3)) then - CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) - CS%u_shelf(I-1,J) = CS%u_bdry_val(I-1,J) - CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) - CS%v_shelf(I-1,J) = CS%v_bdry_val(I-1,J) + if ((i+G%idg_offset) == (G%domain%nihalo+1)) then + if (CS%u_face_mask(I-1,j) == 3) then + CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) + CS%u_shelf(I-1,J) = CS%u_bdry_val(I-1,J) + CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) + CS%v_shelf(I-1,J) = CS%v_bdry_val(I-1,J) + elseif (CS%u_face_mask(I-1,j) == 5) then + CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) + CS%u_shelf(I-1,J) = CS%u_bdry_val(I-1,J) + elseif (CS%u_face_mask(I-1,j) == 6) then + CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) + CS%v_shelf(I-1,J) = CS%v_bdry_val(I-1,J) + endif endif - if (((j+G%jdg_offset) == (G%domain%njhalo+1)).and.(CS%v_face_mask(i,J-1) == 3)) then - CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) - CS%u_shelf(I,J-1) = CS%u_bdry_val(I,J-1) - CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) - CS%v_shelf(I,J-1) = CS%v_bdry_val(I,J-1) + if ((j+G%jdg_offset) == (G%domain%njhalo+1)) then + if (CS%v_face_mask(i,J-1) == 3) then + CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) + CS%v_shelf(I,J-1) = CS%v_bdry_val(I,J-1) + CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) + CS%u_shelf(I,J-1) = CS%u_bdry_val(I,J-1) + elseif (CS%v_face_mask(i,J-1) == 5) then + CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) + CS%v_shelf(I,J-1) = CS%v_bdry_val(I,J-1) + elseif (CS%v_face_mask(i,J-1) == 6) then + CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) + CS%u_shelf(I,J-1) = CS%u_bdry_val(I,J-1) + endif endif enddo ; enddo endif - - call pass_var(CS%OD_av,G%domain) - call pass_var(CS%ground_frac,G%domain) - call pass_var(CS%ice_visc,G%domain) - call pass_var(CS%basal_traction, G%domain) - call pass_var(CS%AGlen_visc, G%domain) call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) endif if (active_shelf_dynamics) then + if (CS%first_dir_restart_IS > -1.0) then + CS%first_direction_IS = modulo(NINT(CS%first_dir_restart_IS), 2) + else + CS%first_dir_restart_IS = real(modulo(CS%first_direction_IS, 2)) + endif + ! If we are calving to a mask, i.e. if a mask exists where a shelf cannot, read the mask from a file. if (CS%calve_to_mask) then call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading calving_mask") @@ -535,59 +850,121 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ endif ! initialize basal friction coefficients - if (new_sim) then - call initialize_ice_C_basal_friction(CS%C_basal_friction, G, US, param_file) - call pass_var(CS%C_basal_friction, G%domain) - - ! initialize ice-stiffness AGlen - call initialize_ice_AGlen(CS%AGlen_visc, G, US, param_file) - call pass_var(CS%AGlen_visc, G%domain) - - !initialize boundary conditions - call initialize_ice_shelf_boundary_from_file(CS%u_face_mask_bdry, CS%v_face_mask_bdry, & - CS%u_bdry_val, CS%v_bdry_val, CS%umask, CS%vmask, CS%h_bdry_val, & - CS%thickness_bdry_val, ISS%hmask, ISS%h_shelf, G, US, param_file ) - call pass_var(ISS%hmask, G%domain) - call pass_var(CS%h_bdry_val, G%domain) - call pass_var(CS%thickness_bdry_val, G%domain) - call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE) - call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE) - - !initialize ice flow characteristic (velocities, bed elevation under the grounded part, etc) from file - call initialize_ice_flow_from_file(CS%bed_elev,CS%u_shelf, CS%v_shelf,CS%ground_frac, & - G, US, param_file) - call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) - call pass_var(CS%bed_elev, G%domain,CENTER) - call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) - endif + if (new_sim) then + call initialize_ice_C_basal_friction(CS%C_basal_friction, G, US, param_file) + call pass_var(CS%C_basal_friction, G%domain, complete=.false.) + + ! initialize ice-stiffness AGlen + call initialize_ice_AGlen(CS%AGlen_visc, CS%ice_viscosity_compute, G, US, param_file) + call pass_var(CS%AGlen_visc, G%domain, complete=.false.) + + !initialize boundary conditions + call initialize_ice_shelf_boundary_from_file(CS%u_face_mask_bdry, CS%v_face_mask_bdry, & + CS%u_bdry_val, CS%v_bdry_val, CS%umask, CS%vmask, CS%h_bdry_val, & + ISS%hmask, ISS%h_shelf, G, US, param_file ) + call pass_var(ISS%hmask, G%domain, complete=.false.) + call pass_var(CS%h_bdry_val, G%domain, complete=.true.) + call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE, complete=.false.) + + !initialize ice flow characteristic (velocities, bed elevation under the grounded part, etc) from file + call initialize_ice_flow_from_file(CS%bed_elev,CS%u_shelf, CS%v_shelf, CS%ground_frac, & + G, US, param_file) + call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE, complete=.true.) + call pass_var(CS%ground_frac, G%domain, complete=.false.) + call pass_var(CS%bed_elev, G%domain, complete=.true.) + call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) + + do J=Jsdq,Jedq ; do I=Isdq,Iedq + if (CS%umask(I,J) == 3) then + CS%u_shelf(I,J) = CS%u_bdry_val(I,J) + elseif (CS%umask(I,J) == 0) then + CS%u_shelf(I,J) = 0 + endif + if (CS%vmask(I,J) == 3) then + CS%v_shelf(I,J) = CS%v_bdry_val(I,J) + elseif (CS%vmask(I,J) == 0) then + CS%v_shelf(I,J) = 0 + endif + enddo ; enddo + endif + ! Register diagnostics. CS%id_u_shelf = register_diag_field('ice_shelf_model','u_shelf',CS%diag%axesB1, Time, & 'x-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) CS%id_v_shelf = register_diag_field('ice_shelf_model','v_shelf',CS%diag%axesB1, Time, & 'y-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) - ! I think that the conversion factors for the next two diagnostics are wrong. - RWH + CS%id_shelf_speed = register_diag_field('ice_shelf_model','shelf_speed',CS%diag%axesB1, Time, & + 'speed of of ice shelf', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) CS%id_taudx_shelf = register_diag_field('ice_shelf_model','taudx_shelf',CS%diag%axesB1, Time, & - 'x-driving stress of ice', 'kPa', conversion=1.e-3*US%RL2_T2_to_Pa) + 'x-driving stress of ice', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) CS%id_taudy_shelf = register_diag_field('ice_shelf_model','taudy_shelf',CS%diag%axesB1, Time, & - 'y-driving stress of ice', 'kPa', conversion=1.e-3*US%RL2_T2_to_Pa) + 'y-driving stress of ice', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) + CS%id_taud_shelf = register_diag_field('ice_shelf_model','taud_shelf',CS%diag%axesB1, Time, & + 'magnitude of driving stress of ice', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) + CS%id_sx_shelf = register_diag_field('ice_shelf_model', 'sx_shelf', CS%diag%axesT1, Time, & + 'x-surface slope of ice', 'none') + CS%id_sy_shelf = register_diag_field('ice_shelf_model', 'sy_shelf', CS%diag%axesT1, Time, & + 'y-surface slope of ice', 'none') + CS%id_surf_slope_mag_shelf = register_diag_field('ice_shelf_model', 'surf_slope_mag_shelf', CS%diag%axesT1, Time, & + 'magnitude of surface slope of ice', 'none') CS%id_u_mask = register_diag_field('ice_shelf_model','u_mask',CS%diag%axesB1, Time, & 'mask for u-nodes', 'none') CS%id_v_mask = register_diag_field('ice_shelf_model','v_mask',CS%diag%axesB1, Time, & 'mask for v-nodes', 'none') CS%id_ground_frac = register_diag_field('ice_shelf_model','ice_ground_frac',CS%diag%axesT1, Time, & 'fraction of cell that is grounded', 'none') + CS%id_float_cond = register_diag_field('ice_shelf_model','float_cond',CS%diag%axesT1, Time, & + 'sub-cell grounding cells', 'none') CS%id_col_thick = register_diag_field('ice_shelf_model','col_thick',CS%diag%axesT1, Time, & 'ocean column thickness passed to ice model', 'm', conversion=US%Z_to_m) CS%id_visc_shelf = register_diag_field('ice_shelf_model','ice_visc',CS%diag%axesT1, Time, & - 'vi-viscosity', 'Pa s-1 m', conversion=US%RL2_T2_to_Pa*US%L_T_to_m_s) !vertically integrated viscosity + 'vi-viscosity', 'Pa m s', conversion=US%RL2_T2_to_Pa*US%Z_to_m*US%T_to_s) !vertically integrated viscosity CS%id_taub = register_diag_field('ice_shelf_model','taub_beta',CS%diag%axesT1, Time, & - 'taub', 'MPa', conversion=1e-6*US%RL2_T2_to_Pa) + 'taub', units='MPa yr m-1', conversion=1e-6*US%RLZ_T2_to_Pa/(365.0*86400.0*US%L_T_to_m_s)) CS%id_OD_av = register_diag_field('ice_shelf_model','OD_av',CS%diag%axesT1, Time, & 'intermediate ocean column thickness passed to ice model', 'm', conversion=US%Z_to_m) + + CS%id_duHdx = register_diag_field('ice_shelf_model','duHdx',CS%diag%axesT1, Time, & + 'x-component of ice-sheet flux divergence', 'm yr-1', conversion=365.0*86400.0*US%Z_to_m*US%s_to_T) + CS%id_dvHdy = register_diag_field('ice_shelf_model','dvHdy',CS%diag%axesT1, Time, & + 'y-component of ice-sheet flux divergence', 'm yr-1', conversion=365.0*86400.0*US%Z_to_m*US%s_to_T) + CS%id_fluxdiv = register_diag_field('ice_shelf_model','fluxdiv',CS%diag%axesT1, Time, & + 'ice-sheet flux divergence', 'm yr-1', conversion=365.0*86400.0*US%Z_to_m*US%s_to_T) + CS%id_strainrate_xx = register_diag_field('ice_shelf_model','strainrate_xx',CS%diag%axesT1, Time, & + 'x-component of ice-shelf strain-rate', 'yr-1', conversion=365.0*86400.0*US%s_to_T) + CS%id_strainrate_yy = register_diag_field('ice_shelf_model','strainrate_yy',CS%diag%axesT1, Time, & + 'y-component of ice-shelf strain-rate', 'yr-1', conversion=365.0*86400.0*US%s_to_T) + CS%id_strainrate_xy = register_diag_field('ice_shelf_model','strainrate_xy',CS%diag%axesT1, Time, & + 'xy-component of ice-shelf strain-rate', 'yr-1', conversion=365.0*86400.0*US%s_to_T) + CS%id_pstrainrate_1 = register_diag_field('ice_shelf_model','pstrainrate_1',CS%diag%axesT1, Time, & + 'max principal horizontal ice-shelf strain-rate', 'yr-1', conversion=365.0*86400.0*US%s_to_T) + CS%id_pstrainrate_2 = register_diag_field('ice_shelf_model','pstrainrate_2',CS%diag%axesT1, Time, & + 'min principal horizontal ice-shelf strain-rate', 'yr-1', conversion=365.0*86400.0*US%s_to_T) + CS%id_devstress_xx = register_diag_field('ice_shelf_model','devstress_xx',CS%diag%axesT1, Time, & + 'x-component of ice-shelf deviatoric stress', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) + CS%id_devstress_yy = register_diag_field('ice_shelf_model','devstress_yy',CS%diag%axesT1, Time, & + 'y-component of ice-shelf deviatoric stress', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) + CS%id_devstress_xy = register_diag_field('ice_shelf_model','devstress_xy',CS%diag%axesT1, Time, & + 'xy-component of ice-shelf deviatoric stress', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) + CS%id_pdevstress_1 = register_diag_field('ice_shelf_model','pdevstress_1',CS%diag%axesT1, Time, & + 'max principal horizontal ice-shelf deviatoric stress', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) + CS%id_pdevstress_2 = register_diag_field('ice_shelf_model','pdevstress_2',CS%diag%axesT1, Time, & + 'min principal ice-shelf deviatoric stress', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) + + !Update these variables so that they are nonzero in case + !IS_dynamics_post_data is called before update_ice_shelf + if (CS%id_taudx_shelf>0 .or. CS%id_taudy_shelf>0) & + call calc_shelf_driving_stress(CS, ISS, G, US, CS%taudx_shelf, CS%taudy_shelf, CS%OD_av) + if (CS%id_taub>0) & + call calc_shelf_taub(CS, ISS, G, US, CS%u_shelf, CS%v_shelf) + if (CS%id_visc_shelf>0) & + call calc_shelf_visc(CS, ISS, G, US, CS%u_shelf, CS%v_shelf) + endif + + if (new_sim) then + call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf(:,:)) endif - call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: initialize ice velocity.") - call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf(:,:)) - call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf,CS%taudx_shelf,CS%taudy_shelf, iters, Time) end subroutine initialize_ice_shelf_dyn @@ -611,7 +988,7 @@ subroutine initialize_diagnostic_fields(CS, ISS, G, US, Time) do j=jsd,jed do i=isd,ied - OD = CS%bed_elev(i,j) - rhoi_rhow * ISS%h_shelf(i,j) + OD = CS%bed_elev(i,j) - rhoi_rhow * max(ISS%h_shelf(i,j),CS%min_h_shelf) if (OD >= 0) then ! ice thickness does not take up whole ocean column -> floating CS%OD_av(i,j) = OD @@ -623,7 +1000,7 @@ subroutine initialize_diagnostic_fields(CS, ISS, G, US, Time) enddo enddo - call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf,CS%taudx_shelf,CS%taudy_shelf, iters, Time) + call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf,CS%taudx_shelf,CS%taudy_shelf, iters, Time) end subroutine initialize_diagnostic_fields !> This function returns the global maximum advective timestep that can be taken based on the current @@ -641,12 +1018,12 @@ function ice_time_step_CFL(CS, ISS, G) min_dt = 5.0e17*G%US%s_to_T ! The starting maximum is roughly the lifetime of the universe. min_vel = (1.0e-12/(365.0*86400.0)) * G%US%m_s_to_L_T - do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (ISS%hmask(i,j) == 1.0) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (ISS%hmask(i,j) == 1.0 .or. ISS%hmask(i,j)==3) then dt_local = 2.0*G%areaT(i,j) / & - ((G%dyCu(I,j) * max(abs(CS%u_shelf(I,J) + CS%u_shelf(I,j-1)), min_vel) + & - G%dyCu(I-1,j)* max(abs(CS%u_shelf(I-1,J)+ CS%u_shelf(I-1,j-1)), min_vel)) + & - (G%dxCv(i,J) * max(abs(CS%v_shelf(i,J) + CS%v_shelf(i-1,J)), min_vel) + & - G%dxCv(i,J-1)* max(abs(CS%v_shelf(i,J-1)+ CS%v_shelf(i-1,J-1)), min_vel))) + (((G%dyCu(I,j) * max(abs(CS%u_shelf(I,J) + CS%u_shelf(I,j-1)), min_vel)) + & + (G%dyCu(I-1,j)* max(abs(CS%u_shelf(I-1,J)+ CS%u_shelf(I-1,j-1)), min_vel))) + & + ((G%dxCv(i,J) * max(abs(CS%v_shelf(i,J) + CS%v_shelf(i-1,J)), min_vel)) + & + (G%dxCv(i,J-1)* max(abs(CS%v_shelf(i,J-1)+ CS%v_shelf(i-1,J-1)), min_vel)))) min_dt = min(min_dt, dt_local) endif ; enddo ; enddo ! i- and j- loops @@ -659,7 +1036,8 @@ end function ice_time_step_CFL !> This subroutine updates the ice shelf velocities, mass, stresses and properties due to the !! ice shelf dynamics. -subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled_grounding, must_update_vel) +subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, calve_ice_shelf_bergs, & + ocean_mass, coupled_grounding, must_update_vel) type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe !! the ice-shelf state @@ -667,16 +1045,14 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, intent(in) :: time_step !< time step [T ~> s] type(time_type), intent(in) :: Time !< The current model time + logical, intent(in) :: calve_ice_shelf_bergs !< To convert ice flux through front + !! to bergs real, dimension(SZDI_(G),SZDJ_(G)), & optional, intent(in) :: ocean_mass !< If present this is the mass per unit area !! of the ocean [R Z ~> kg m-2]. logical, optional, intent(in) :: coupled_grounding !< If true, the grounding line is !! determined by coupled ice-ocean dynamics logical, optional, intent(in) :: must_update_vel !< Always update the ice velocities if true. - real, dimension(SZDIB_(G),SZDJB_(G)) ::taud_x,taud_y ! Pa] - real, dimension(SZDI_(G),SZDJ_(G)) :: ice_visc ! Pa s-1 m] - real, dimension(SZDI_(G),SZDJ_(G)) :: basal_tr ! Pa] integer :: iters logical :: update_ice_vel, coupled_GL @@ -686,72 +1062,348 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled coupled_GL = .false. if (present(ocean_mass) .and. present(coupled_grounding)) coupled_GL = coupled_grounding ! - call ice_shelf_advect(CS, ISS, G, time_step, Time) - CS%elapsed_velocity_time = CS%elapsed_velocity_time + time_step - if (CS%elapsed_velocity_time >= CS%velocity_update_time_step) update_ice_vel = .true. - - if (coupled_GL) then - call update_OD_ffrac(CS, G, US, ocean_mass, update_ice_vel) - elseif (update_ice_vel) then - call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf(:,:)) - endif - - - if (update_ice_vel) then - call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf,CS%taudx_shelf,CS%taudy_shelf, iters, Time) - endif - -! call ice_shelf_temp(CS, ISS, G, US, time_step, ISS%water_flux, Time) - - if (update_ice_vel) then - call enable_averages(CS%elapsed_velocity_time, Time, CS%diag) - if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, CS%OD_av, CS%diag) - if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf, CS%u_shelf, CS%diag) - if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf, CS%v_shelf, CS%diag) -! if (CS%id_t_shelf > 0) call post_data(CS%id_t_shelf,CS%t_shelf,CS%diag) - if (CS%id_taudx_shelf > 0) then - taud_x(:,:) = CS%taudx_shelf(:,:)*G%IareaT(:,:) - call post_data(CS%id_taudx_shelf,taud_x , CS%diag) - endif - if (CS%id_taudy_shelf > 0) then - taud_y(:,:) = CS%taudy_shelf(:,:)*G%IareaT(:,:) - call post_data(CS%id_taudy_shelf,taud_y , CS%diag) - endif - if (CS%id_ground_frac > 0) call post_data(CS%id_ground_frac, CS%ground_frac,CS%diag) - if (CS%id_OD_av >0) call post_data(CS%id_OD_av, CS%OD_av,CS%diag) - if (CS%id_visc_shelf > 0) then - ice_visc(:,:)=CS%ice_visc(:,:)*G%IareaT(:,:) - call post_data(CS%id_visc_shelf, ice_visc,CS%diag) - endif - if (CS%id_taub > 0) then - basal_tr(:,:) = CS%basal_traction(:,:)*G%IareaT(:,:) - call post_data(CS%id_taub, basal_tr,CS%diag) - endif -!! - if (CS%id_u_mask > 0) call post_data(CS%id_u_mask,CS%umask,CS%diag) - if (CS%id_v_mask > 0) call post_data(CS%id_v_mask,CS%vmask,CS%diag) - if (CS%id_ufb_mask > 0) call post_data(CS%id_ufb_mask,CS%u_face_mask_bdry,CS%diag) - if (CS%id_vfb_mask > 0) call post_data(CS%id_vfb_mask,CS%v_face_mask_bdry,CS%diag) -! if (CS%id_t_mask > 0) call post_data(CS%id_t_mask,CS%tmask,CS%diag) + if (CS%advect_shelf) then + call ice_shelf_advect(CS, ISS, G, time_step, Time, calve_ice_shelf_bergs) + if (CS%alternate_first_direction_IS) then + CS%first_direction_IS = modulo(CS%first_direction_IS+1,2) + CS%first_dir_restart_IS = real(CS%first_direction_IS) + endif + endif + CS%elapsed_velocity_time = CS%elapsed_velocity_time + time_step + if (CS%elapsed_velocity_time >= CS%velocity_update_time_step) update_ice_vel = .true. + + if (coupled_GL) then + call update_OD_ffrac(CS, G, US, ocean_mass, update_ice_vel) + elseif (update_ice_vel) then + call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf(:,:)) + CS%GL_couple=.false. + endif - call disable_averaging(CS%diag) + if (update_ice_vel) then + call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf,CS%taudx_shelf,CS%taudy_shelf, iters, Time) + CS%elapsed_velocity_time = 0.0 + endif - CS%elapsed_velocity_time = 0.0 - endif +! call ice_shelf_temp(CS, ISS, G, US, time_step, ISS%water_flux, Time) end subroutine update_ice_shelf +subroutine volume_above_floatation(CS, G, ISS, vaf, hemisphere) + type(ice_shelf_dyn_CS), intent(in) :: CS !< The ice shelf dynamics control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + real, intent(out) :: vaf !< area integrated volume above floatation [Z L2 ~> m3] + integer, optional, intent(in) :: hemisphere !< 0 for Antarctica only, 1 for Greenland only. Otherwise, all ice sheets + integer :: IS_ID ! local copy of hemisphere + real, dimension(SZI_(G),SZJ_(G)) :: vaf_cell !< cell-wise volume above floatation [Z L2 ~> m3] + integer, dimension(SZI_(G),SZJ_(G)) :: mask ! a mask for active cells depending on hemisphere indicated + integer :: is,ie,js,je,i,j + real :: rhoi_rhow, rhow_rhoi + + if (CS%GL_couple) & + call MOM_error(FATAL, "MOM_ice_shelf_dyn, volume above floatation calculation assumes GL_couple=.FALSE..") + + rhoi_rhow = CS%density_ice / CS%density_ocean_avg + rhow_rhoi = CS%density_ocean_avg / CS%density_ice + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + if (present(hemisphere)) then + IS_ID=hemisphere + else + IS_ID=-1 + endif + + mask(:,:)=0 + if (IS_ID==0) then !Antarctica (S. Hemisphere) only + do j = js,je ; do i = is,ie + if (ISS%hmask(i,j)>0 .and. G%geoLatT(i,j)<=0.0) mask(i,j)=1 + enddo ; enddo + elseif (IS_ID==1) then !Greenland (N. Hemisphere) only + do j = js,je ; do i = is,ie + if (ISS%hmask(i,j)>0 .and. G%geoLatT(i,j)>0.0) mask(i,j)=1 + enddo ; enddo + else !All ice sheets + mask(is:ie,js:je)=ISS%hmask(is:ie,js:je) + endif + + vaf_cell(:,:)=0.0 + do j = js,je ; do i = is,ie + if (mask(i,j)>0) then + if (CS%bed_elev(i,j) <= 0) then + !grounded above sea level + vaf_cell(i,j) = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) + else + !grounded if vaf_cell(i,j) > 0 + vaf_cell(i,j) = max(ISS%h_shelf(i,j) - rhow_rhoi * CS%bed_elev(i,j), 0.0) * ISS%area_shelf_h(i,j) + endif + endif + enddo ; enddo + + vaf = reproducing_sum(vaf_cell, unscale=G%US%Z_to_m*G%US%L_to_m**2) +end subroutine volume_above_floatation + +!> multiplies a variable with the ice sheet grounding fraction +subroutine masked_var_grounded(G,CS,var,varout) + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + type(ice_shelf_dyn_CS), intent(in) :: CS !< The ice shelf dynamics control structure + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: var !< variable in + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: varout ! Ice shelf dynamics post_data calls +subroutine IS_dynamics_post_data(time_step, Time, CS, ISS, G) + real :: time_step !< Length of time for post data averaging [T ~> s]. + type(time_type), intent(in) :: Time !< The current model time + type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDIB_(G),SZDJB_(G)) :: taud_x, taud_y, taud ! area-averaged driving stress [R L2 T-2 ~> Pa] + real, dimension(SZDI_(G),SZDJ_(G)) :: ice_visc ! area-averaged vertically integrated ice viscosity + !! [R L2 Z T-1 ~> Pa s m] + real, dimension(SZDI_(G),SZDJ_(G)) :: basal_tr ! area-averaged taub_beta field related to basal traction, + !! [R L T-1 ~> Pa s m-1] + real, dimension(SZDI_(G),SZDJ_(G)) :: surf_slope ! the surface slope of the ice shelf/sheet [nondim] + real, dimension(SZDIB_(G),SZDJB_(G)) :: ice_speed ! ice sheet flow speed [L T-1 ~> m s-1] + + integer :: i, j + + call enable_averages(time_step, Time, CS%diag) + if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, CS%OD_av, CS%diag) + if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf, CS%u_shelf, CS%diag) + if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf, CS%v_shelf, CS%diag) + if (CS%id_shelf_speed > 0) then + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + ice_speed(I,J) = sqrt((CS%u_shelf(I,J)**2) + (CS%v_shelf(I,J)**2)) + enddo ; enddo + call post_data(CS%id_shelf_speed, ice_speed, CS%diag) + endif +! if (CS%id_t_shelf > 0) call post_data(CS%id_t_shelf, CS%t_shelf, CS%diag) + if (CS%id_taudx_shelf > 0) then + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + taud_x(I,J) = CS%taudx_shelf(I,J)*G%IareaBu(I,J) + enddo ; enddo + call post_data(CS%id_taudx_shelf, taud_x, CS%diag) + endif + if (CS%id_taudy_shelf > 0) then + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + taud_y(I,J) = CS%taudy_shelf(I,J)*G%IareaBu(I,J) + enddo ; enddo + call post_data(CS%id_taudy_shelf, taud_y, CS%diag) + endif + if (CS%id_taud_shelf > 0) then + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + taud(I,J) = sqrt((CS%taudx_shelf(I,J)**2)+(CS%taudy_shelf(I,J)**2))*G%IareaBu(I,J) + enddo ; enddo + call post_data(CS%id_taud_shelf, taud, CS%diag) + endif + if (CS%id_sx_shelf > 0) call post_data(CS%id_sx_shelf, CS%sx_shelf, CS%diag) + if (CS%id_sy_shelf > 0) call post_data(CS%id_sy_shelf, CS%sy_shelf, CS%diag) + if (CS%id_surf_slope_mag_shelf > 0) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + surf_slope(i,j) = sqrt((CS%sx_shelf(i,j)**2)+(CS%sy_shelf(i,j)**2)) + enddo ; enddo + call post_data(CS%id_surf_slope_mag_shelf, surf_slope, CS%diag) + endif + if (CS%id_ground_frac > 0) call post_data(CS%id_ground_frac, CS%ground_frac, CS%diag) + if (CS%id_float_cond > 0) call post_data(CS%id_float_cond, CS%float_cond, CS%diag) + if (CS%id_OD_av >0) call post_data(CS%id_OD_av, CS%OD_av,CS%diag) + if (CS%id_visc_shelf > 0) then + call ice_visc_diag(CS,G,ice_visc) + call post_data(CS%id_visc_shelf, ice_visc, CS%diag) + endif + if (CS%id_taub > 0) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + basal_tr(i,j) = CS%basal_traction(i,j)*G%IareaT(i,j) + enddo ; enddo + call post_data(CS%id_taub, basal_tr, CS%diag) + endif + if (CS%id_u_mask > 0) call post_data(CS%id_u_mask, CS%umask, CS%diag) + if (CS%id_v_mask > 0) call post_data(CS%id_v_mask, CS%vmask, CS%diag) + if (CS%id_ufb_mask > 0) call post_data(CS%id_ufb_mask, CS%u_face_mask_bdry, CS%diag) + if (CS%id_vfb_mask > 0) call post_data(CS%id_vfb_mask, CS%v_face_mask_bdry, CS%diag) +! if (CS%id_t_mask > 0) call post_data(CS%id_t_mask, CS%tmask, CS%diag) + + if (CS%id_duHdx > 0 .or. CS%id_dvHdy > 0 .or. CS%id_fluxdiv > 0 .or. & + CS%id_devstress_xx > 0 .or. CS%id_devstress_yy > 0 .or. CS%id_devstress_xy > 0 .or. & + CS%id_strainrate_xx > 0 .or. CS%id_strainrate_yy > 0 .or. CS%id_strainrate_xy > 0 .or. & + CS%id_pdevstress_1 > 0 .or. CS%id_pdevstress_2 > 0 .or. & + CS%id_pstrainrate_1 > 0 .or. CS%id_pstrainrate_2 > 0) then + call IS_dynamics_post_data_2(CS, ISS, G) + endif + + call disable_averaging(CS%diag) +end subroutine IS_dynamics_post_data + +!> Calculate cell-centered, area-averaged, vertically integrated ice viscosity for diagnostics +subroutine ice_visc_diag(CS,G,ice_visc) + type(ice_shelf_dyn_CS), intent(in) :: CS !< The ice shelf dynamics control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), intent(out) :: ice_visc !< area-averaged vertically integrated ice viscosity + !! [R L2 Z T-1 ~> Pa s m] + integer :: i,j + + ice_visc(:,:)=0.0 + if (CS%visc_qps==4) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + ice_visc(i,j) = (0.25 * G%IareaT(i,j)) * & + ((CS%ice_visc(i,j,1) + CS%ice_visc(i,j,4)) + (CS%ice_visc(i,j,2) + CS%ice_visc(i,j,3))) + enddo ; enddo + else + do j=G%jsc,G%jec ; do i=G%isc,G%iec + ice_visc(i,j) = CS%ice_visc(i,j,1)*G%IareaT(i,j) + enddo ; enddo + endif +end subroutine ice_visc_diag + +!> Writes the total ice shelf kinetic energy and mass to an ascii file +subroutine write_ice_shelf_energy(CS, G, US, mass, area, day, time_step) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: mass !< The mass per unit area of the ice shelf + !! or sheet [R Z ~> kg m-2] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: area !< The ice shelf or ice sheet area [L2 ~> m2] + type(time_type), intent(in) :: day !< The current model time. + type(time_type), optional, intent(in) :: time_step !< The current time step + ! Local variables + type(time_type) :: dt ! A time_type version of the timestep. + real, dimension(SZDI_(G),SZDJ_(G)) :: tmp1 ! A temporary array used in reproducing sums [various] + real :: KE_tot ! The total kinetic energy [R Z L4 T-2 ~> J] + real :: mass_tot ! The total mass [R Z L2 ~> kg] + integer :: is, ie, js, je, isr, ier, jsr, jer, i, j + character(len=32) :: mesg_intro, time_units, day_str, n_str, date_str + integer :: start_of_day, num_days + real :: reday ! Time in units given by CS%Timeunit, but often [days] + + ! write_energy_time is the next integral multiple of energysavedays. + if (present(time_step)) then + dt = time_step + else + dt = set_time(seconds=2) + endif + + !CS%prev_IS_energy_calls tracks the ice sheet step, which is outputted in the energy file. + if (CS%prev_IS_energy_calls == 0) then + if (CS%energysave_geometric) then + if (CS%energysavedays_geometric < CS%energysavedays) then + CS%write_energy_time = day + CS%energysavedays_geometric + CS%geometric_end_time = CS%Start_time + CS%energysavedays * & + (1 + (day - CS%Start_time) / CS%energysavedays) + else + CS%write_energy_time = CS%Start_time + CS%energysavedays * & + (1 + (day - CS%Start_time) / CS%energysavedays) + endif + else + CS%write_energy_time = CS%Start_time + CS%energysavedays * & + (1 + (day - CS%Start_time) / CS%energysavedays) + endif + elseif (day + (dt/2) <= CS%write_energy_time) then + CS%prev_IS_energy_calls = CS%prev_IS_energy_calls + 1 + return ! Do not write this step + else ! Determine the next write time before proceeding + if (CS%energysave_geometric) then + if (CS%write_energy_time + CS%energysavedays_geometric >= & + CS%geometric_end_time) then + CS%write_energy_time = CS%geometric_end_time + CS%energysave_geometric = .false. ! stop geometric progression + else + CS%write_energy_time = CS%write_energy_time + CS%energysavedays_geometric + endif + CS%energysavedays_geometric = CS%energysavedays_geometric*2 + else + CS%write_energy_time = CS%write_energy_time + CS%energysavedays + endif + endif + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isr = is - (G%isd-1) ; ier = ie - (G%isd-1) ; jsr = js - (G%jsd-1) ; jer = je - (G%jsd-1) + + !calculate KE using cell-centered ice shelf velocity + tmp1(:,:) = 0.0 + do j=js,je ; do i=is,ie + tmp1(i,j) = 0.03125 * (mass(i,j) * area(i,j)) * & + ((((CS%u_shelf(I-1,J-1)+CS%u_shelf(I,J))+(CS%u_shelf(I,J-1)+CS%u_shelf(I-1,J)))**2) + & + (((CS%v_shelf(I-1,J-1)+CS%v_shelf(I,J))+(CS%v_shelf(I,J-1)+CS%v_shelf(I-1,J)))**2)) + enddo ; enddo + + KE_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, unscale=(US%RZL2_to_kg*US%L_T_to_m_s**2)) + + !calculate mass + tmp1(:,:) = 0.0 + do j=js,je ; do i=is,ie + tmp1(i,j) = mass(i,j) * area(i,j) + enddo ; enddo + + mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, unscale=US%RZL2_to_kg) + + if (is_root_pe()) then ! Only the root PE actually writes anything. + if (day > CS%Start_time) then + call open_ASCII_file(CS%IS_fileenergy_ascii, trim(CS%IS_energyfile), action=APPEND_FILE) + else + call open_ASCII_file(CS%IS_fileenergy_ascii, trim(CS%IS_energyfile), action=WRITEONLY_FILE) + if (abs(CS%timeunit - 86400.0) < 1.0) then + write(CS%IS_fileenergy_ascii,'(" Step,",7x,"Day,",8x,"Energy/Mass,",13x,"Total Mass")') + write(CS%IS_fileenergy_ascii,'(12x,"[days]",10x,"[m2 s-2]",17x,"[kg]")') + else + if ((CS%timeunit >= 0.99) .and. (CS%timeunit < 1.01)) then + time_units = " [seconds] " + elseif ((CS%timeunit >= 3599.0) .and. (CS%timeunit < 3601.0)) then + time_units = " [hours] " + elseif ((CS%timeunit >= 86399.0) .and. (CS%timeunit < 86401.0)) then + time_units = " [days] " + elseif ((CS%timeunit >= 3.0e7) .and. (CS%timeunit < 3.2e7)) then + time_units = " [years] " + else + write(time_units,'(9x,"[",es8.2," s] ")') CS%timeunit + endif + + write(CS%IS_fileenergy_ascii,'(" Step,",7x,"Time,",7x,"Energy/Mass,",13x,"Total Mass")') + write(CS%IS_fileenergy_ascii,'(A25,3x,"[m2 s-2]",17x,"[kg]")') time_units + endif + endif + + call get_time(day, start_of_day, num_days) + + if (abs(CS%timeunit - 86400.0) < 1.0) then + reday = REAL(num_days)+ (REAL(start_of_day)/86400.0) + else + reday = REAL(num_days)*(86400.0/CS%timeunit) + REAL(start_of_day)/abs(CS%timeunit) + endif + + if (reday < 1.0e8) then ; write(day_str, '(F12.3)') reday + elseif (reday < 1.0e11) then ; write(day_str, '(F15.3)') reday + else ; write(day_str, '(ES15.9)') reday ; endif + + if (CS%prev_IS_energy_calls < 1000000) then ; write(n_str, '(I6)') CS%prev_IS_energy_calls + else ; write(n_str, '(I0)') CS%prev_IS_energy_calls ; endif + + write(CS%IS_fileenergy_ascii,'(A,",",A,", En ",ES22.16,", M ",ES11.5)') & + trim(n_str), trim(day_str), US%L_T_to_m_s**2*KE_tot/mass_tot, US%RZL2_to_kg*mass_tot + endif + + CS%prev_IS_energy_calls = CS%prev_IS_energy_calls + 1 +end subroutine write_ice_shelf_energy + !> This subroutine takes the velocity (on the Bgrid) and timesteps h_t = - div (uh) once. !! Additionally, it will update the volume of ice in partially-filled cells, and update !! hmask accordingly -subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) +subroutine ice_shelf_advect(CS, ISS, G, time_step, Time, calve_ice_shelf_bergs) type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe !! the ice-shelf state type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. real, intent(in) :: time_step !< time step [T ~> s] type(time_type), intent(in) :: Time !< The current model time - + logical, intent(in) :: calve_ice_shelf_bergs !< If true, track ice shelf flux through a + !! static ice shelf, so that it can be converted into icebergs ! 3/8/11 DNG ! @@ -762,7 +1414,7 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) ! The flux overflows are included here. That is because they will be used to advect 3D scalars ! into partial cells - real, dimension(SZDI_(G),SZDJ_(G)) :: h_after_uflux, h_after_vflux ! Ice thicknesses [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)) :: h_after_flux1, h_after_flux2 ! Ice thicknesses [Z ~> m]. real, dimension(SZDIB_(G),SZDJ_(G)) :: uh_ice ! The accumulated zonal ice volume flux [Z L2 ~> m3] real, dimension(SZDI_(G),SZDJB_(G)) :: vh_ice ! The accumulated meridional ice volume flux [Z L2 ~> m3] type(loop_bounds_type) :: LB @@ -774,37 +1426,39 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) uh_ice(:,:) = 0.0 vh_ice(:,:) = 0.0 - h_after_uflux(:,:) = 0.0 - h_after_vflux(:,:) = 0.0 + h_after_flux1(:,:) = 0.0 + h_after_flux2(:,:) = 0.0 ! call MOM_mesg("MOM_ice_shelf.F90: ice_shelf_advect called") - do j=jsd,jed ; do i=isd,ied ; if (CS%thickness_bdry_val(i,j) /= 0.0) then - ISS%h_shelf(i,j) = CS%thickness_bdry_val(i,j) + do j=jsd,jed ; do i=isd,ied ; if (CS%h_bdry_val(i,j) /= 0.0) then + ISS%h_shelf(i,j) = CS%h_bdry_val(i,j) endif ; enddo ; enddo stencil = 2 - LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc-stencil ; LB%jeh = G%jec+stencil - if (LB%jsh < jsd) call MOM_error(FATAL, & - "ice_shelf_advect: Halo is too small for the ice thickness advection stencil.") - - call ice_shelf_advect_thickness_x(CS, G, LB, time_step, ISS%hmask, ISS%h_shelf, h_after_uflux, uh_ice) - -! call enable_averages(time_step, Time, CS%diag) - call pass_var(h_after_uflux, G%domain) -! if (CS%id_h_after_uflux > 0) call post_data(CS%id_h_after_uflux, h_after_uflux, CS%diag) -! call disable_averaging(CS%diag) - - LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec - call ice_shelf_advect_thickness_y(CS, G, LB, time_step, ISS%hmask, h_after_uflux, h_after_vflux, vh_ice) - -! call enable_averages(time_step, Time, CS%diag) - call pass_var(h_after_vflux, G%domain) -! if (CS%id_h_after_vflux > 0) call post_data(CS%id_h_after_vflux, h_after_vflux, CS%diag) -! call disable_averaging(CS%diag) + if (modulo(CS%first_direction_IS,2)==0) then + !x first + LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc-stencil ; LB%jeh = G%jec+stencil + if (LB%jsh < jsd) call MOM_error(FATAL, & + "ice_shelf_advect: Halo is too small for the ice thickness advection stencil.") + call ice_shelf_advect_thickness_x(CS, G, LB, time_step, ISS%hmask, ISS%h_shelf, h_after_flux1, uh_ice) + call pass_var(h_after_flux1, G%domain) + LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec + call ice_shelf_advect_thickness_y(CS, G, LB, time_step, ISS%hmask, h_after_flux1, h_after_flux2, vh_ice) + else + ! y first + LB%ish = G%isc-stencil ; LB%ieh = G%iec+stencil ; LB%jsh = G%jsc ; LB%jeh = G%jec + if (LB%ish < isd) call MOM_error(FATAL, & + "ice_shelf_advect: Halo is too small for the ice thickness advection stencil.") + call ice_shelf_advect_thickness_y(CS, G, LB, time_step, ISS%hmask, ISS%h_shelf, h_after_flux1, vh_ice) + call pass_var(h_after_flux1, G%domain) + LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec + call ice_shelf_advect_thickness_x(CS, G, LB, time_step, ISS%hmask, h_after_flux1, h_after_flux2, uh_ice) + endif + call pass_var(h_after_flux2, G%domain) do j=jsd,jed do i=isd,ied - if (ISS%hmask(i,j) == 1) ISS%h_shelf(i,j) = h_after_vflux(i,j) + if (ISS%hmask(i,j) == 1) ISS%h_shelf(i,j) = h_after_flux2(i,j) enddo enddo @@ -817,13 +1471,33 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) if (CS%calve_to_mask) then call calve_to_mask(G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, CS%calve_mask) endif + elseif (calve_ice_shelf_bergs) then + !advect the front to create partially-filled cells + call shelf_advance_front(CS, ISS, G, ISS%hmask, uh_ice, vh_ice) + !add mass of the partially-filled cells to calving field, which is used to initialize icebergs + !Then, remove the partially-filled cells from the ice shelf + ISS%calving(:,:) = 0.0 + ISS%calving_hflx(:,:) = 0.0 + do j=jsc,jec ; do i=isc,iec + if (ISS%hmask(i,j)==2) then + ISS%calving(i,j) = (ISS%h_shelf(i,j) * CS%density_ice) * & + (ISS%area_shelf_h(i,j) * G%IareaT(i,j)) / time_step + ISS%calving_hflx(i,j) = (CS%Cp_ice * CS%t_shelf(i,j)) * & + ((ISS%h_shelf(i,j) * CS%density_ice) * & + (ISS%area_shelf_h(i,j) * G%IareaT(i,j))) + ISS%h_shelf(i,j) = 0.0 ; ISS%area_shelf_h(i,j) = 0.0 ; ISS%hmask(i,j) = 0.0 + endif + enddo ; enddo endif - !call enable_averages(time_step, Time, CS%diag) - !if (CS%id_h_after_adv > 0) call post_data(CS%id_h_after_adv, ISS%h_shelf, CS%diag) - !call disable_averaging(CS%diag) + do j=jsc,jec ; do i=isc,iec + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * CS%density_ice + enddo ; enddo - !call change_thickness_using_melt(ISS, G, time_step, fluxes, CS%density_ice) + call pass_var(ISS%mass_shelf, G%domain, complete=.false.) + call pass_var(ISS%h_shelf, G%domain, complete=.false.) + call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) + call pass_var(ISS%hmask, G%domain, complete=.true.) call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) @@ -831,7 +1505,7 @@ end subroutine ice_shelf_advect !>This subroutine computes u- and v-velocities of the ice shelf iterating on non-linear ice viscosity !subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) - subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, iters, Time) +subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, iters, Time) type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe !! the ice-shelf state @@ -848,54 +1522,51 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i intent(out) :: taudx !< Driving x-stress at q-points [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)), & intent(out) :: taudy !< Driving y-stress at q-points [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDIB_(G),SZDJB_(G)) :: u_bdry_cont ! Boundary u-stress contribution [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDIB_(G),SZDJB_(G)) :: v_bdry_cont ! Boundary v-stress contribution [R L3 Z T-2 ~> kg m s-2] + !real, dimension(SZDIB_(G),SZDJB_(G)) :: u_bdry_cont ! Boundary u-stress contribution [R L3 Z T-2 ~> kg m s-2] + !real, dimension(SZDIB_(G),SZDJB_(G)) :: v_bdry_cont ! Boundary v-stress contribution [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)) :: Au, Av ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDIB_(G),SZDJB_(G)) :: err_u, err_v real, dimension(SZDIB_(G),SZDJB_(G)) :: u_last, v_last ! Previous velocities [L T-1 ~> m s-1] real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thickness at corners [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G)) :: float_cond ! An array indicating where the ice - ! shelf is floating: 0 if floating, 1 if not. + real, dimension(SZDI_(G),SZDJ_(G)) :: float_cond ! If GL_regularize=true, indicates cells containing + ! the grounding line (float_cond=1) or not (float_cond=0) + real, dimension(SZDIB_(G),SZDJB_(G)) :: Normvec ! Velocities used for convergence [L2 T-2 ~> m2 s-2] character(len=160) :: mesg ! The text of an error message - integer :: conv_flag, i, j, k,l, iter - integer :: isdq, iedq, jsdq, jedq, isd, ied, jsd, jed, nodefloat, nsub - real :: err_max, err_tempu, err_tempv, err_init, area, max_vel, tempu, tempv + integer :: conv_flag, i, j, k,l, iter, nodefloat + integer :: Isdq, Iedq, Jsdq, Jedq, isd, ied, jsd, jed + integer :: Iscq, Iecq, Jscq, Jecq, isc, iec, jsc, jec + real :: err_max, err_tempu, err_tempv, err_init ! Errors in [R L3 Z T-2 ~> kg m s-2] or [L T-1 ~> m s-1] + real :: ew_prev_err ! Previous outer residual for Eisenstat-Walker CG tolerance (same units as err_max) + real :: max_vel ! The maximum velocity magnitude [L T-1 ~> m s-1] + real :: tempu, tempv ! Temporary variables with velocity magnitudes [L T-1 ~> m s-1] + real :: Norm, PrevNorm ! Velocities used to assess convergence [L T-1 ~> m s-1] real :: rhoi_rhow ! The density of ice divided by a typical water density [nondim] - real, pointer, dimension(:,:,:,:) :: Phi => NULL() ! The gradients of bilinear basis elements at Gaussian - ! quadrature points surrounding the cell vertices [m-1]. - real, pointer, dimension(:,:,:,:,:,:) :: Phisub => NULL() ! Quadrature structure weights at subgridscale - ! locations for finite element calculations [nondim] - character(2) :: iternum - character(2) :: numproc - - ! for GL interpolation - nsub = CS%n_sub_regularize + integer :: Is_sum, Js_sum, Ie_sum, Je_sum ! Loop bounds for global sums or arrays starting at 1. + integer :: Iscq_sv, Jscq_sv ! Starting loop bound for sum_vec - isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB + Isdq = G%IsdB ; Iedq = G%IedB ; Jsdq = G%JsdB ; Jedq = G%JedB + Iscq = G%IscB ; Iecq = G%IecB ; Jscq = G%JscB ; Jecq = G%JecB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec rhoi_rhow = CS%density_ice / CS%density_ocean_avg taudx(:,:) = 0.0 ; taudy(:,:) = 0.0 - u_bdry_cont(:,:) = 0.0 ; v_bdry_cont(:,:) = 0.0 Au(:,:) = 0.0 ; Av(:,:) = 0.0 ! need to make these conditional on GL interpolation - float_cond(:,:) = 0.0 ; H_node(:,:) = 0.0 - CS%ground_frac(:,:) = 0.0 - allocate(Phisub(nsub,nsub,2,2,2,2), source=0.0) - - do j=G%jsc,G%jec - do i=G%isc,G%iec - if (rhoi_rhow * ISS%h_shelf(i,j) - CS%bed_elev(i,j) > 0) then - float_cond(i,j) = 1.0 + CS%float_cond(:,:) = 0.0 ; H_node(:,:) = 0.0 + !CS%ground_frac(:,:) = 0.0 + + if (.not. CS%GL_couple) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (rhoi_rhow * max(ISS%h_shelf(i,j),CS%min_h_shelf) - CS%bed_elev(i,j) > 0) then CS%ground_frac(i,j) = 1.0 CS%OD_av(i,j) =0.0 endif - enddo - enddo + enddo ; enddo + endif call calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, CS%OD_av) -! call pass_vector(taudx, taudy, G%domain, TO_ALL, BGRID_NE) + call pass_vector(taudx, taudy, G%domain, TO_ALL, BGRID_NE) ! This is to determine which cells contain the grounding line, the criterion being that the cell ! is ice-covered, with some nodes floating and some grounded flotation condition is estimated by ! assuming topography is cellwise constant and H is bilinear in a cell; floating where @@ -905,123 +1576,148 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i if (CS%GL_regularize) then - call interpolate_H_to_B(G, ISS%h_shelf, ISS%hmask, H_node) + call interpolate_H_to_B(G, ISS%h_shelf, ISS%hmask, H_node, CS%min_h_shelf) do j=G%jsc,G%jec ; do i=G%isc,G%iec nodefloat = 0 do l=0,1 ; do k=0,1 - if ((ISS%hmask(i,j) == 1) .and. & + if ((ISS%hmask(i,j) == 1 .or. ISS%hmask(i,j)==3) .and. & (rhoi_rhow * H_node(i-1+k,j-1+l) - CS%bed_elev(i,j) <= 0)) then nodefloat = nodefloat + 1 endif enddo ; enddo if ((nodefloat > 0) .and. (nodefloat < 4)) then - float_cond(i,j) = 1.0 + CS%float_cond(i,j) = 1.0 CS%ground_frac(i,j) = 1.0 endif enddo ; enddo - call pass_var(float_cond, G%Domain) - - call bilinear_shape_functions_subgrid(Phisub, nsub) + call pass_var(CS%float_cond, G%Domain, complete=.false.) + call pass_var(CS%ground_frac, G%domain, complete=.false.) endif - ! must prepare Phi - allocate(Phi(1:8,1:4,isd:ied,jsd:jed), source=0.0) - - do j=jsd,jed ; do i=isd,ied - call bilinear_shape_fn_grid(G, i, j, Phi(:,:,i,j)) - enddo ; enddo - + call calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) + call pass_var(CS%basal_traction, G%domain, complete=.true.) call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) call pass_var(CS%ice_visc, G%domain) - call calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) - call pass_var(CS%basal_traction, G%domain) ! This makes sure basal stress is only applied when it is supposed to be - do j=G%jsd,G%jed ; do i=G%isd,G%ied -! CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) - CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) - enddo ; enddo + if (CS%GL_regularize) then + do j=G%jsd,G%jed ; do i=G%isd,G%ied + if (CS%ground_frac(i,j)/=1.0) CS%basal_traction(i,j) = 0.0 + enddo ; enddo + else + do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) + enddo ; enddo + endif - call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & - CS%basal_traction, float_cond, rhoi_rhow, u_bdry_cont, v_bdry_cont) + if (CS%nonlin_solve_err_mode == 1) then - Au(:,:) = 0.0 ; Av(:,:) = 0.0 + Au(:,:) = 0.0 ; Av(:,:) = 0.0 - call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & - CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & - G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) - call pass_vector(Au,Av,G%domain,TO_ALL,BGRID_NE) + call CG_action(CS, Au, Av, u_shlf, v_shlf, CS%Phi, CS%Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & + CS%ice_visc, CS%float_cond, CS%bed_elev, CS%basal_traction, & + G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow, use_newton_in=.false.) + call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) - if (CS%nonlin_solve_err_mode == 1) then err_init = 0 ; err_tempu = 0 ; err_tempv = 0 - do J=G%IscB,G%JecB ; do I=G%IscB,G%IecB + do J=G%JscB,G%JecB ; do I=G%IscB,G%IecB if (CS%umask(I,J) == 1) then - err_tempu = ABS(Au(I,J) + u_bdry_cont(I,J) - taudx(I,J)) + err_tempu = ABS(Au(I,J) - taudx(I,J)) if (err_tempu >= err_init) err_init = err_tempu endif if (CS%vmask(I,J) == 1) then - err_tempv = ABS(Av(I,J) + v_bdry_cont(I,J) - taudy(I,J)) + err_tempv = ABS(Av(I,J) - taudy(I,J)) if (err_tempv >= err_init) err_init = err_tempv endif enddo ; enddo call max_across_PEs(err_init) + elseif (CS%nonlin_solve_err_mode == 3) then + Normvec(:,:) = 0.0 + + ! Determine the loop limits for sums, bearing in mind that the arrays will be starting at 1. + ! Includes the edge of the tile is at the western/southern bdry (if symmetric) + if ((isc+G%idg_offset==G%isg) .and. (.not. CS%reentrant_x)) then + Is_sum = Iscq + (1-Isdq) ; Iscq_sv = Iscq + else + Is_sum = isc + (1-Isdq) ; Iscq_sv = isc + endif + if ((jsc+G%jdg_offset==G%jsg) .and. (.not. CS%reentrant_y)) then + Js_sum = Jscq + (1-Jsdq) ; Jscq_sv = Jscq + else + Js_sum = jsc + (1-Jsdq) ; Jscq_sv = jsc + endif + Ie_sum = Iecq + (1-Isdq) ; Je_sum = Jecq + (1-Jsdq) + + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq + if (CS%umask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + u_shlf(I,J)**2 + if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + v_shlf(I,J)**2 + enddo ; enddo + Norm = sqrt( reproducing_sum( Normvec, Is_sum, Ie_sum, Js_sum, Je_sum, unscale=US%L_T_to_m_s**2 ) ) endif u_last(:,:) = u_shlf(:,:) ; v_last(:,:) = v_shlf(:,:) + CS%cg_tol_newton = CS%cg_tolerance !! begin loop do iter=1,50 - call ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H_node, float_cond, & - ISS%hmask, conv_flag, iters, time, Phi, Phisub) + call ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H_node, CS%float_cond, & + ISS%hmask, conv_flag, iters, time, CS%Phi, CS%Phisub) if (CS%debug) then - call qchksum(u_shlf, "u shelf", G%HI, haloshift=2, scale=US%L_T_to_m_s) - call qchksum(v_shlf, "v shelf", G%HI, haloshift=2, scale=US%L_T_to_m_s) + call qchksum(u_shlf, "u shelf", G%HI, haloshift=2, unscale=US%L_T_to_m_s) + call qchksum(v_shlf, "v shelf", G%HI, haloshift=2, unscale=US%L_T_to_m_s) endif write(mesg,*) "ice_shelf_solve_outer: linear solve done in ",iters," iterations" call MOM_mesg(mesg, 5) - call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) - call pass_var(CS%ice_visc, G%domain) call calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) - call pass_var(CS%basal_traction, G%domain) - ! makes sure basal stress is only applied when it is supposed to be - - do j=G%jsd,G%jed ; do i=G%isd,G%ied -! CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) - CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) - enddo ; enddo + call pass_var(CS%basal_traction, G%domain, complete=.true.) + call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) + call pass_var(CS%ice_visc, G%domain, complete=.false.) + call pass_var(CS%newton_str_sh, G%domain, complete=.false.) + call pass_var(CS%newton_visc_factor, G%domain, complete=.true.) + call pass_var(CS%newton_drag_coef, G%domain) + call pass_vector(CS%newton_str_ux, CS%newton_str_vy, G%domain, TO_ALL, AGRID) + call pass_vector(CS%newton_umid, CS%newton_vmid, G%domain, TO_ALL, AGRID) - u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 + ! makes sure basal stress is only applied when it is supposed to be + if (CS%GL_regularize) then + do j=G%jsd,G%jed ; do i=G%isd,G%ied + if (CS%ground_frac(i,j)/=1.0) CS%basal_traction(i,j) = 0.0 + enddo ; enddo + else + do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) + enddo ; enddo + endif - call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & - CS%basal_traction, float_cond, rhoi_rhow, u_bdry_cont, v_bdry_cont) + if (CS%nonlin_solve_err_mode == 1) then - Au(:,:) = 0 ; Av(:,:) = 0 + Au(:,:) = 0 ; Av(:,:) = 0 - call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & - CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & - G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) + call CG_action(CS, Au, Av, u_shlf, v_shlf, CS%Phi, CS%Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & + CS%ice_visc, CS%float_cond, CS%bed_elev, CS%basal_traction, & + G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow, use_newton_in=.false.) - err_max = 0 + call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) - if (CS%nonlin_solve_err_mode == 1) then + err_max = 0 - do J=G%jscB,G%jecB ; do I=G%jscB,G%iecB + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB if (CS%umask(I,J) == 1) then - err_tempu = ABS(Au(I,J) + u_bdry_cont(I,J) - taudx(I,J)) + err_tempu = ABS(Au(I,J) - taudx(I,J)) if (err_tempu >= err_max) err_max = err_tempu endif if (CS%vmask(I,J) == 1) then - err_tempv = ABS(Av(I,J) + v_bdry_cont(I,J) - taudy(I,J)) + err_tempv = ABS(Av(I,J) - taudy(I,J)) if (err_tempv >= err_max) err_max = err_tempv endif enddo ; enddo @@ -1030,7 +1726,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i elseif (CS%nonlin_solve_err_mode == 2) then - max_vel = 0 ; tempu = 0 ; tempv = 0 + err_max=0. ; max_vel = 0 ; tempu = 0 ; tempv = 0 ; err_tempu = 0 do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB if (CS%umask(I,J) == 1) then err_tempu = ABS(u_last(I,J)-u_shlf(I,J)) @@ -1042,7 +1738,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i if (CS%vmask(I,J) == 1) then err_tempv = MAX(ABS(v_last(I,J)-v_shlf(I,J)), err_tempu) if (err_tempv >= err_max) err_max = err_tempv - tempv = SQRT(v_shlf(I,J)**2 + tempu**2) + tempv = SQRT((v_shlf(I,J)**2) + (tempu**2)) endif if (tempv >= max_vel) max_vel = tempv enddo ; enddo @@ -1053,31 +1749,59 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i call max_across_PEs(max_vel) call max_across_PEs(err_max) err_init = max_vel + + elseif (CS%nonlin_solve_err_mode == 3) then + PrevNorm = Norm ; Norm = 0.0 ; Normvec=0.0 + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq + if (CS%umask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + u_shlf(I,J)**2 + if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + v_shlf(I,J)**2 + enddo ; enddo + Norm = sqrt( reproducing_sum( Normvec, Is_sum, Ie_sum, Js_sum, Je_sum, unscale=US%L_T_to_m_s**2 ) ) + err_max = 2.*abs(Norm-PrevNorm) ; err_init = Norm+PrevNorm endif write(mesg,*) "ice_shelf_solve_outer: nonlinear fractional residual = ", err_max/err_init call MOM_mesg(mesg, 5) + if (err_max <= CS%newton_after_tolerance * err_init .and. .not. CS%doing_newton) then + CS%doing_newton = .true. + ew_prev_err = err_max ! seed Eisenstat-Walker with residual at the Newton switch point + write(mesg,*) "ice_shelf_solve_outer: switching to Newton iterations at iter = ", iter + call MOM_mesg(mesg, 5) + endif + + ! Eisenstat-Walker Choice II (Eisenstat & Walker 1994): η_k = γ*(||F_k||/||F_{k-1}||)^α + ! with γ=0.9, α=2. Uses the ratio of consecutive outer residuals so that the CG + ! tolerance scales linearly with the current error (enabling quadratic outer convergence) + ! without over-tightening at later Newton steps. The first Newton step uses the standard + ! cg_tolerance (ratio = 1 on entry). + if (CS%doing_newton .and. CS%newton_adapt_cg_tol) then + CS%cg_tol_newton = min(CS%cg_tolerance, 0.9 * (err_max / ew_prev_err)**2) + ew_prev_err = err_max + endif + if (err_max <= CS%nonlinear_tolerance * err_init) then exit endif enddo + CS%doing_newton = .false. + CS%cg_tol_newton = CS%cg_tolerance write(mesg,*) "ice_shelf_solve_outer: nonlinear fractional residual = ", err_max/err_init call MOM_mesg(mesg) write(mesg,*) "ice_shelf_solve_outer: exiting nonlinear solve after ",iter," iterations" call MOM_mesg(mesg) - deallocate(Phi) - deallocate(Phisub) end subroutine ice_shelf_solve_outer +!> Unified inner linear solver for ice shelf velocity. +!! Performs shared setup (RHS, preconditioner, initial matrix-vector product), +!! dispatches to the selected Krylov method, and applies boundary conditions. subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H_node, float_cond, & hmask, conv_flag, iters, time, Phi, Phisub) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure - type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe - !! the ice-shelf state + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe the ice-shelf state type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(SZDIB_(G),SZDJB_(G)), & @@ -1089,288 +1813,802 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: taudy !< The y-direction driving stress [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: H_node !< The ice shelf thickness at nodal (corner) - !! points [Z ~> m]. + intent(in) :: H_node !< The ice shelf thickness at nodal (corner) points [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: float_cond !< An array indicating where the ice - !! shelf is floating: 0 if floating, 1 if not. + intent(in) :: float_cond !< If GL_regularize=true, indicates cells containing + !! the grounding line (float_cond=1) or not (float_cond=0) real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are - !! partly or fully covered by an ice-shelf + !! partly or fully covered by an ice-shelf integer, intent(out) :: conv_flag !< A flag indicating whether (1) or not (0) the - !! iterations have converged to the specified tolerance + !! iterations have converged to the specified tolerance integer, intent(out) :: iters !< The number of iterations used in the solver. type(time_type), intent(in) :: Time !< The current model time - character(len=160) :: mesg ! The text of an error message real, dimension(8,4,SZDI_(G),SZDJ_(G)), & intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian - !! quadrature points surrounding the cell vertices [L-1 ~> m-1]. + !! quadrature points surrounding the cell vertices [L-1 ~> m-1]. real, dimension(:,:,:,:,:,:), & intent(in) :: Phisub !< Quadrature structure weights at subgridscale - !! locations for finite element calculations [nondim] -! one linear solve (nonlinear iteration) of the solution for velocity - -! in this subroutine: -! boundary contributions are added to taud to get the RHS -! diagonal of matrix is found (for Jacobi precondition) -! CG iteration is carried out for max. iterations or until convergence - -! assumed - u, v, taud, visc, basal_traction are valid on the halo - - real, dimension(SZDIB_(G),SZDJB_(G)) :: & - Ru, Rv, & ! Residuals in the stress calculations [R L3 Z T-2 ~> m kg s-2] - Ru_old, Rv_old, & ! Previous values of Ru and Rv [R L3 Z T-2 ~> m kg s-2] - Zu, Zv, & ! Contributions to velocity changes [L T-1 ~> m s-1] - Zu_old, Zv_old, & ! Previous values of Zu and Zv [L T-1 ~> m s-1] - DIAGu, DIAGv, & ! Diagonals with units like Ru/Zu [R L2 Z T-1 ~> kg s-1] - RHSu, RHSv, & ! Right hand side of the stress balance [R L3 Z T-2 ~> m kg s-2] - ubd, vbd, & ! Boundary stress contributions [R L3 Z T-2 ~> kg m s-2] - Au, Av, & ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] - Du, Dv, & ! Velocity changes [L T-1 ~> m s-1] - sum_vec, sum_vec_2 - real :: tol, beta_k, area, dot_p1, resid0, cg_halo - real :: num, denom - real :: alpha_k ! A scaling factor for iterative corrections [nondim] - real :: resid_scale ! A scaling factor for redimensionalizing the global residuals [m2 L-2 ~> 1] - ! [m2 L-2 ~> 1] [R L3 Z T-2 ~> m kg s-2] - real :: resid2_scale ! A scaling factor for redimensionalizing the global squared residuals - ! [m2 L-2 ~> 1] [R L3 Z T-2 ~> m kg s-2] - real :: rhoi_rhow ! The density of ice divided by a typical water density [nondim] - integer :: iter, i, j, isd, ied, jsd, jed, isc, iec, jsc, jec, is, js, ie, je + !! locations for finite element calculations [nondim] + + real, dimension(SZDIB_(G),SZDJB_(G)) :: & + RHSu, RHSv, & ! Right hand side of the stress balance [R L3 Z T-2 ~> m kg s-2] + Au, Av, & ! Matrix-vector product A*x [R L3 Z T-2 ~> kg m s-2] + DIAGu, DIAGv, & ! Diagonals [R L2 Z T-1 ~> kg s-1] + IDIAGu, IDIAGv ! Reciprocal diagonals [R-1 L-2 Z-1 T ~> kg-1 s] + real :: rhoi_rhow ! The density of ice divided by a typical water density [nondim] + real :: resid_scale ! A scaling factor for redimensionalizing the global residuals + ! [T3 kg m2 R-1 Z-1 L-4 s-3 ~> 1] integer :: Is_sum, Js_sum, Ie_sum, Je_sum ! Loop bounds for global sums or arrays starting at 1. - integer :: isdq, iedq, jsdq, jedq, iscq, iecq, jscq, jecq, nx_halo, ny_halo + integer :: Iscq_sv, Jscq_sv ! Starting loop bound for sum_vec arrays + integer :: I, J + integer :: Isdq, Iedq, Jsdq, Jedq, Iscq, Iecq, Jscq, Jecq + integer :: isc, iec, jsc, jec - isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB - iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB - ny_halo = G%domain%njhalo ; nx_halo = G%domain%nihalo - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + Isdq = G%IsdB ; Iedq = G%IedB ; Jsdq = G%JsdB ; Jedq = G%JedB + Iscq = G%IscB ; Iecq = G%IecB ; Jscq = G%JscB ; Jecq = G%JecB isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec rhoi_rhow = CS%density_ice / CS%density_ocean_avg - Zu(:,:) = 0 ; Zv(:,:) = 0 ; DIAGu(:,:) = 0 ; DIAGv(:,:) = 0 - Ru(:,:) = 0 ; Rv(:,:) = 0 ; Au(:,:) = 0 ; Av(:,:) = 0 ; RHSu(:,:) = 0 ; RHSv(:,:) = 0 - Du(:,:) = 0 ; Dv(:,:) = 0 ; ubd(:,:) = 0 ; vbd(:,:) = 0 - dot_p1 = 0 + ! Initialize shared arrays + Au(:,:) = 0 ; Av(:,:) = 0 ; DIAGu(:,:) = 0 ; DIAGv(:,:) = 0 ! Determine the loop limits for sums, bearing in mind that the arrays will be starting at 1. - Is_sum = G%isc + (1-G%IsdB) - Ie_sum = G%iecB + (1-G%IsdB) - ! Include the edge if tile is at the western bdry; Should add a test to avoid this if reentrant. - if (G%isc+G%idg_offset==G%isg) Is_sum = G%IscB + (1-G%IsdB) + ! Includes the edge of the tile is at the western/southern bdry (if symmetric) + if ((isc+G%idg_offset==G%isg) .and. (.not. CS%reentrant_x)) then + Is_sum = Iscq + (1-Isdq) ; Iscq_sv = Iscq + else + Is_sum = isc + (1-Isdq) ; Iscq_sv = isc + endif + if ((jsc+G%jdg_offset==G%jsg) .and. (.not. CS%reentrant_y)) then + Js_sum = Jscq + (1-Jsdq) ; Jscq_sv = Jscq + else + Js_sum = jsc + (1-Jsdq) ; Jscq_sv = jsc + endif + Ie_sum = Iecq + (1-Isdq) ; Je_sum = Jecq + (1-Jsdq) - Js_sum = G%jsc + (1-G%JsdB) - Je_sum = G%jecB + (1-G%JsdB) - ! Include the edge if tile is at the southern bdry; Should add a test to avoid this if reentrant. - if (G%jsc+G%jdg_offset==G%jsg) Js_sum = G%JscB + (1-G%JsdB) + RHSu(:,:) = taudx(:,:) ; RHSv(:,:) = taudy(:,:) + call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE, complete=.false.) - call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & - CS%basal_traction, float_cond, rhoi_rhow, ubd, vbd) + call matrix_diagonal(CS, G, US, float_cond, H_node, CS%ice_visc, CS%basal_traction, & + hmask, rhoi_rhow, Phi, Phisub, DIAGu, DIAGv) + call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, BGRID_NE, complete=.false.) - RHSu(:,:) = taudx(:,:) - ubd(:,:) - RHSv(:,:) = taudy(:,:) - vbd(:,:) + call CG_action(CS, Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, hmask, & + H_node, CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & + G, US, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow, use_newton_in=.false.) + call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE, complete=.true.) + + ! Precompute reciprocal diagonal + IDIAGu(:,:) = 0.0 ; IDIAGv(:,:) = 0.0 + do J=Jsdq,Jedq ; do I=Isdq,Iedq + if (CS%umask(I,J)==1 .AND. DIAGu(I,J)/=0) IDIAGu(I,J) = 1.0 / DIAGu(I,J) + if (CS%vmask(I,J)==1 .AND. DIAGv(I,J)/=0) IDIAGv(I,J) = 1.0 / DIAGv(I,J) + enddo ; enddo - call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE) + resid_scale = US%s_to_T*(US%RZL2_to_kg*US%L_T_to_m_s**2) + + ! Dispatch to selected solver + select case (CS%inner_solver) + case (INNER_CG) + call ice_shelf_solve_inner_CG(CS, G, US, u_shlf, v_shlf, RHSu, RHSv, Au, Av, & + IDIAGu, IDIAGv, H_node, float_cond, hmask, & + rhoi_rhow, resid_scale, Phi, Phisub, conv_flag, iters, & + Is_sum, Js_sum, Ie_sum, Je_sum, Iscq_sv, Jscq_sv) + case (INNER_MINRES) + call ice_shelf_solve_inner_MINRES(CS, G, US, u_shlf, v_shlf, RHSu, RHSv, Au, Av, & + IDIAGu, IDIAGv, H_node, float_cond, hmask, & + rhoi_rhow, resid_scale, Phi, Phisub, conv_flag, iters, & + Is_sum, Js_sum, Ie_sum, Je_sum, Iscq_sv, Jscq_sv) + case (INNER_CR) + call ice_shelf_solve_inner_CR(CS, G, US, u_shlf, v_shlf, RHSu, RHSv, Au, Av, & + IDIAGu, IDIAGv, H_node, float_cond, hmask, & + rhoi_rhow, resid_scale, Phi, Phisub, conv_flag, iters, & + Is_sum, Js_sum, Ie_sum, Je_sum, Iscq_sv, Jscq_sv) + end select + + ! Shared teardown: Apply boundary conditions + do J=Jsdq,Jedq ; do I=Isdq,Iedq + if (CS%umask(I,J) == 3) then + u_shlf(I,J) = CS%u_bdry_val(I,J) + elseif (CS%umask(I,J) == 0) then + u_shlf(I,J) = 0 + endif - call matrix_diagonal(CS, G, US, float_cond, H_node, CS%ice_visc, CS%basal_traction, & - hmask, rhoi_rhow, Phisub, DIAGu, DIAGv) + if (CS%vmask(I,J) == 3) then + v_shlf(I,J) = CS%v_bdry_val(I,J) + elseif (CS%vmask(I,J) == 0) then + v_shlf(I,J) = 0 + endif + enddo ; enddo - call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, BGRID_NE) + call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) - call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, hmask, & - H_node, CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & - G, US, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow) + if (conv_flag == 0) then + iters = CS%cg_max_iterations + endif - call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) +end subroutine ice_shelf_solve_inner - Ru(:,:) = (RHSu(:,:) - Au(:,:)) - Rv(:,:) = (RHSv(:,:) - Av(:,:)) +!> CG (Conjugate Gradient) inner Krylov solve for ice shelf velocity. +subroutine ice_shelf_solve_inner_CG(CS, G, US, u_shlf, v_shlf, RHSu, RHSv, Au, Av, & + IDIAGu, IDIAGv, H_node, float_cond, hmask, & + rhoi_rhow, resid_scale, Phi, Phisub, conv_flag, iters, & + Is_sum, Js_sum, Ie_sum, Je_sum, Iscq_sv, Jscq_sv) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: RHSu !< Right hand side, x [R L3 Z T-2 ~> m kg s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: RHSv !< Right hand side, y [R L3 Z T-2 ~> m kg s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: Au !< Matrix-vector product workspace, x [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: Av !< Matrix-vector product workspace, y [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: IDIAGu !< Reciprocal Jacobi diagonal, x [R-1 L-2 Z-1 T ~> kg-1 s] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: IDIAGv !< Reciprocal Jacobi diagonal, y [R-1 L-2 Z-1 T ~> kg-1 s] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: H_node !< The ice shelf thickness at nodal points [Z ~> m] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: float_cond !< Grounding line indicator [nondim] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< Ice shelf coverage mask + real, intent(in) :: rhoi_rhow !< Ice-to-ocean density ratio [nondim] + real, intent(in) :: resid_scale !< Scaling for inner products + !! [T3 kg m2 R-1 Z-1 L-4 s-3 ~> 1] + real, dimension(8,4,SZDI_(G),SZDJ_(G)), & + intent(in) :: Phi !< Basis element gradients at quadrature points [L-1 ~> m-1] + real, dimension(:,:,:,:,:,:), & + intent(in) :: Phisub !< Subgridscale quadrature weights [nondim] + integer, intent(out) :: conv_flag !< Convergence flag: 1=converged, 0=not + integer, intent(out) :: iters !< The number of iterations used + integer, intent(in) :: Is_sum !< Starting i-index for global sums + integer, intent(in) :: Js_sum !< Starting j-index for global sums + integer, intent(in) :: Ie_sum !< Ending i-index for global sums + integer, intent(in) :: Je_sum !< Ending j-index for global sums + integer, intent(in) :: Iscq_sv !< Starting i-index for sum_vec arrays + integer, intent(in) :: Jscq_sv !< Starting j-index for sum_vec arrays - resid_scale = US%L_to_m**2*US%s_to_T*US%RZ_to_kg_m2*US%L_T_to_m_s**2 - resid2_scale = (US%RZ_to_kg_m2*US%L_to_m*US%L_T_to_m_s**2)**2 + real, dimension(SZDIB_(G),SZDJB_(G)) :: & + Ru, Rv, & ! Residuals [R L3 Z T-2 ~> m kg s-2] + Zu, Zv, & ! Preconditioned residuals [L T-1 ~> m s-1] + Du, Dv ! Search directions [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)) :: sum_vec ! Pointwise D·A products for the alpha_k global sum + ! [kg m2 s-3] + real, dimension(SZDIB_(G),SZDJB_(G),2) :: sum_vec_3d ! Array used for various residuals + ! sum_vec_3d(:,:,1) [kg m2 s-3] + ! sum_vec_3d(:,:,2) [kg2 m2 s-4] + real :: beta_k ! Ratio of residuals used to update search direction [nondim] + real :: resid0tol2 ! Convergence tolerance times the initial residual [m2 kg2 s-4] + real :: sv3dsum ! An unused variable returned when taking global sum of residuals [various] + real :: sv3dsums(2) ! The index-wise global sums of sum_vec_3d + ! sv3dsums(1) [kg m2 s-3] + ! sv3dsums(2) [kg2 m2 s-4] + real :: alpha_k ! A scaling factor for iterative corrections [nondim] + real :: rho_old ! The preconditioned residual inner product Z·R from the previous CG + ! iteration, scaled by resid_scale [kg m2 s-3] + real :: resid2_scale ! A scaling factor for redimensionalizing the global squared residuals + ! [T4 kg2 m2 R-2 Z-2 L-6 s-4 ~> 1] + integer :: cg_halo ! Number of halo vertices to include during a CG iteration + integer :: max_cg_halo ! Maximum possible number of halo vertices to include in the CG iterations + integer :: iter, i, j, isc, iec, jsc, jec, is, js, ie, je, is2, ie2, js2, je2 + integer :: Isdq, Iedq, Jsdq, Jedq, Iscq, Iecq, Jscq, Jecq, nx_halo, ny_halo + + Isdq = G%IsdB ; Iedq = G%IedB ; Jsdq = G%JsdB ; Jedq = G%JedB + Iscq = G%IscB ; Iecq = G%IecB ; Jscq = G%JscB ; Jecq = G%JecB + ny_halo = G%domain%njhalo ; nx_halo = G%domain%nihalo + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec - sum_vec(:,:) = 0.0 - do j=jscq,jecq ; do i=iscq,iecq - if (CS%umask(I,J) == 1) sum_vec(I,J) = resid2_scale*Ru(I,J)**2 - if (CS%vmask(I,J) == 1) sum_vec(I,J) = sum_vec(I,J) + resid2_scale*Rv(I,J)**2 - enddo ; enddo + resid2_scale = ((US%RZ_to_kg_m2*US%L_to_m)*US%L_T_to_m_s**2)**2 - dot_p1 = reproducing_sum( sum_vec, Js_sum, Ie_sum, Js_sum, Je_sum ) + Ru(:,:) = 0 ; Rv(:,:) = 0 ; Zu(:,:) = 0 ; Zv(:,:) = 0 ; Du(:,:) = 0 ; Dv(:,:) = 0 - resid0 = sqrt(dot_p1) + Ru(:,:) = (RHSu(:,:) - Au(:,:)) ; Rv(:,:) = (RHSv(:,:) - Av(:,:)) - do j=jsdq,jedq - do i=isdq,iedq - if (CS%umask(I,J) == 1 .AND.(DIAGu(I,J)/=0)) Zu(I,J) = Ru(I,J) / DIAGu(I,J) - if (CS%vmask(I,J) == 1 .AND.(DIAGv(I,J)/=0)) Zv(I,J) = Rv(I,J) / DIAGv(I,J) - enddo - enddo + do J=Jsdq,Jedq ; do I=Isdq,Iedq + if (CS%umask(I,J) == 1) Zu(I,J) = Ru(I,J) * IDIAGu(I,J) + if (CS%vmask(I,J) == 1) Zv(I,J) = Rv(I,J) * IDIAGv(I,J) + Du(I,J) = Zu(I,J) + Dv(I,J) = Zv(I,J) + enddo ; enddo - Du(:,:) = Zu(:,:) ; Dv(:,:) = Zv(:,:) + ! Compute rho_old = Z·R and resid0tol2 before the CG loop + sum_vec_3d(:,:,:) = 0.0 + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq + if (CS%umask(I,J) == 1) then + sum_vec_3d(I,J,1) = resid_scale * (Zu(I,J) * Ru(I,J)) + sum_vec_3d(I,J,2) = resid2_scale * Ru(I,J)**2 + endif + if (CS%vmask(I,J) == 1) then + sum_vec_3d(I,J,1) = sum_vec_3d(I,J,1) + resid_scale * (Zv(I,J) * Rv(I,J)) + sum_vec_3d(I,J,2) = sum_vec_3d(I,J,2) + resid2_scale * Rv(I,J)**2 + endif + enddo ; enddo - cg_halo = 3 + sv3dsum = reproducing_sum( sum_vec_3d(:,:,1:2), Is_sum, Ie_sum, Js_sum, Je_sum, sums=sv3dsums(1:2) ) + + rho_old = sv3dsums(1) + !resid0 = sqrt(sv3dsums(2)) + resid0tol2 = CS%cg_tol_newton**2 * sv3dsums(2) + + if (G%symmetric) then + max_cg_halo=min(nx_halo,ny_halo) + else + max_cg_halo=min(nx_halo,ny_halo)-1 + endif + cg_halo = max_cg_halo conv_flag = 0 + if (CS%cg_halo_shrink) then + is = isc - cg_halo ; ie = Iecq + cg_halo + js = jsc - cg_halo ; je = Jecq + cg_halo + is2 = is ; ie2 = ie-1 + js2 = js ; je2 = je-1 + else + is = isc - 1 ; ie = iec + 1 + js = jsc - 1 ; je = jec + 1 + is2 = Iscq ; ie2 = Iecq + js2 = Jscq ; je2 = Jecq + endif + !!!!!!!!!!!!!!!!!! !! !! !! MAIN CG LOOP !! !! !! !!!!!!!!!!!!!!!!!! - ! initially, c-grid data is valid up to 3 halo nodes out - do iter = 1,CS%cg_max_iterations - ! assume asymmetry - ! thus we can never assume that any arrays are legit more than 3 vertices past - ! the computational domain - this is their state in the initial iteration - - - is = isc - cg_halo ; ie = iecq + cg_halo - js = jscq - cg_halo ; je = jecq + cg_halo - Au(:,:) = 0 ; Av(:,:) = 0 - call CG_action(Au, Av, Du, Dv, Phi, Phisub, CS%umask, CS%vmask, hmask, & + call CG_action(CS, Au, Av, Du, Dv, Phi, Phisub, CS%umask, CS%vmask, hmask, & H_node, CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & G, US, is, ie, js, je, rhoi_rhow) - ! Au, Av valid region moves in by 1 + sum_vec(:,:) = 0.0 + + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq + if (CS%umask(I,J) == 1) sum_vec(I,J) = resid_scale * (Du(I,J) * Au(I,J)) + if (CS%vmask(I,J) == 1) sum_vec(I,J) = sum_vec(I,J) + resid_scale * (Dv(I,J) * Av(I,J)) + enddo ; enddo + + sv3dsum = reproducing_sum( sum_vec(:,:), Is_sum, Ie_sum, Js_sum, Je_sum ) - call pass_vector(Au,Av,G%domain, TO_ALL, BGRID_NE) + if (sv3dsum == 0.0) then + iters = iter + conv_flag = 1 + exit + endif - sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 + alpha_k = rho_old / sv3dsum - do j=jscq,jecq ; do i=iscq,iecq + do J=js2,je2 ; do I=is2,ie2 if (CS%umask(I,J) == 1) then - sum_vec(I,J) = resid_scale * Zu(I,J) * Ru(I,J) - sum_vec_2(I,J) = resid_scale * Du(I,J) * Au(I,J) + u_shlf(I,J) = u_shlf(I,J) + alpha_k * Du(I,J) + Ru(I,J) = Ru(I,J) - alpha_k * Au(I,J) + Zu(I,J) = Ru(I,J) * IDIAGu(I,J) endif if (CS%vmask(I,J) == 1) then - sum_vec(I,J) = sum_vec(I,J) + resid_scale * Zv(I,J) * Rv(I,J) - sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * Dv(I,J) * Av(I,J) + v_shlf(I,J) = v_shlf(I,J) + alpha_k * Dv(I,J) + Rv(I,J) = Rv(I,J) - alpha_k * Av(I,J) + Zv(I,J) = Rv(I,J) * IDIAGv(I,J) endif enddo ; enddo - alpha_k = reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) / & - reproducing_sum( sum_vec_2, Is_sum, Ie_sum, Js_sum, Je_sum ) - + ! beta_k = (Z \dot R) / (Z_prev \dot R_prev) + sum_vec_3d(:,:,:) = 0.0 ; sv3dsums(:)=0.0 - do j=jsd,jed ; do i=isd,ied - if (CS%umask(I,J) == 1) u_shlf(I,J) = u_shlf(I,J) + alpha_k * Du(I,J) - if (CS%vmask(I,J) == 1) v_shlf(I,J) = v_shlf(I,J) + alpha_k * Dv(I,J) - enddo ; enddo - - do j=jsd,jed ; do i=isd,ied + do J=jscq_sv,jecq ; do i=iscq_sv,iecq if (CS%umask(I,J) == 1) then - Ru_old(I,J) = Ru(I,J) ; Zu_old(I,J) = Zu(I,J) + sum_vec_3d(I,J,1) = resid_scale * (Zu(I,J) * Ru(I,J)) + sum_vec_3d(I,J,2) = resid2_scale * Ru(I,J)**2 endif if (CS%vmask(I,J) == 1) then - Rv_old(I,J) = Rv(I,J) ; Zv_old(I,J) = Zv(I,J) + sum_vec_3d(I,J,1) = sum_vec_3d(I,J,1) + resid_scale * (Zv(I,J) * Rv(I,J)) + sum_vec_3d(I,J,2) = sum_vec_3d(I,J,2) + resid2_scale * Rv(I,J)**2 endif enddo ; enddo -! Ru(:,:) = Ru(:,:) - alpha_k * Au(:,:) -! Rv(:,:) = Rv(:,:) - alpha_k * Av(:,:) + sv3dsum = reproducing_sum( sum_vec_3d(:,:,1:2), Is_sum, Ie_sum, Js_sum, Je_sum, sums=sv3dsums(1:2) ) - do j=jsd,jed - do i=isd,ied - if (CS%umask(I,J) == 1) Ru(I,J) = Ru(I,J) - alpha_k * Au(I,J) - if (CS%vmask(I,J) == 1) Rv(I,J) = Rv(I,J) - alpha_k * Av(I,J) - enddo - enddo + beta_k = sv3dsums(1) / rho_old - do j=jsdq,jedq - do i=isdq,iedq - if (CS%umask(I,J) == 1 .AND.(DIAGu(I,J)/=0)) then - Zu(I,J) = Ru(I,J) / DIAGu(I,J) - endif - if (CS%vmask(I,J) == 1 .AND.(DIAGv(I,J)/=0)) then - Zv(I,J) = Rv(I,J) / DIAGv(I,J) - endif - enddo - enddo + if (sv3dsums(2) <= resid0tol2) then + iters = iter + conv_flag = 1 + exit + endif - ! R,u,v,Z valid region moves in by 1 + do J=js2,je2 ; do I=is2,ie2 + if (CS%umask(I,J) == 1) Du(I,J) = Zu(I,J) + beta_k * Du(I,J) + if (CS%vmask(I,J) == 1) Dv(I,J) = Zv(I,J) + beta_k * Dv(I,J) + enddo ; enddo - ! beta_k = (Z \dot R) / (Zold \dot Rold} - sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 + rho_old = sv3dsums(1) - do j=jscq,jecq ; do i=iscq,iecq - if (CS%umask(I,J) == 1) then - sum_vec(I,J) = resid_scale * Zu(I,J) * Ru(I,J) - sum_vec_2(I,J) = resid_scale * Zu_old(I,J) * Ru_old(I,J) + if (CS%cg_halo_shrink) then + cg_halo = cg_halo - 1 + if (cg_halo == 0) then + call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(Zu, Zv, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(Ru, Rv, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE, complete=.true.) + cg_halo = max_cg_halo endif - if (CS%vmask(I,J) == 1) then - sum_vec(I,J) = sum_vec(I,J) + resid_scale * Zv(I,J) * Rv(I,J) - sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * Zv_old(I,J) * Rv_old(I,J) - endif - enddo ; enddo + is = isc - cg_halo ; ie = Iecq + cg_halo + js = jsc - cg_halo ; je = Jecq + cg_halo + is2 = is ; ie2 = ie-1 + js2 = js ; je2 = je-1 + else + call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE) + endif - beta_k = reproducing_sum(sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) / & - reproducing_sum(sum_vec_2, Is_sum, Ie_sum, Js_sum, Je_sum ) + enddo ! end of CG loop -! Du(:,:) = Zu(:,:) + beta_k * Du(:,:) -! Dv(:,:) = Zv(:,:) + beta_k * Dv(:,:) +end subroutine ice_shelf_solve_inner_CG - do j=jsd,jed - do i=isd,ied - if (CS%umask(I,J) == 1) Du(I,J) = Zu(I,J) + beta_k * Du(I,J) - if (CS%vmask(I,J) == 1) Dv(I,J) = Zv(I,J) + beta_k * Dv(I,J) - enddo - enddo +!> MINRES inner Krylov solve for ice shelf velocity. +subroutine ice_shelf_solve_inner_MINRES(CS, G, US, u_shlf, v_shlf, RHSu, RHSv, Au, Av, & + IDIAGu, IDIAGv, H_node, float_cond, hmask, & + rhoi_rhow, resid_scale, Phi, Phisub, conv_flag, iters, & + Is_sum, Js_sum, Ie_sum, Je_sum, Iscq_sv, Jscq_sv) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: RHSu !< Right hand side, x [R L3 Z T-2 ~> m kg s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: RHSv !< Right hand side, y [R L3 Z T-2 ~> m kg s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: Au !< Matrix-vector product workspace, x [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: Av !< Matrix-vector product workspace, y [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: IDIAGu !< Reciprocal Jacobi diagonal, x [R-1 L-2 Z-1 T ~> kg-1 s] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: IDIAGv !< Reciprocal Jacobi diagonal, y [R-1 L-2 Z-1 T ~> kg-1 s] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: H_node !< The ice shelf thickness at nodal points [Z ~> m] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: float_cond !< Grounding line indicator [nondim] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< Ice shelf coverage mask + real, intent(in) :: rhoi_rhow !< Ice-to-ocean density ratio [nondim] + real, intent(in) :: resid_scale !< Scaling for inner products + !! [T3 kg m2 R-1 Z-1 L-4 s-3 ~> 1] + real, dimension(8,4,SZDI_(G),SZDJ_(G)), & + intent(in) :: Phi !< Basis element gradients at quadrature points [L-1 ~> m-1] + real, dimension(:,:,:,:,:,:), & + intent(in) :: Phisub !< Subgridscale quadrature weights [nondim] + integer, intent(out) :: conv_flag !< Convergence flag: 1=converged, 0=not + integer, intent(out) :: iters !< The number of iterations used + integer, intent(in) :: Is_sum !< Starting i-index for global sums + integer, intent(in) :: Js_sum !< Starting j-index for global sums + integer, intent(in) :: Ie_sum !< Ending i-index for global sums + integer, intent(in) :: Je_sum !< Ending j-index for global sums + integer, intent(in) :: Iscq_sv !< Starting i-index for sum_vec arrays + integer, intent(in) :: Jscq_sv !< Starting j-index for sum_vec arrays - ! D valid region moves in by 1 + real, dimension(SZDIB_(G),SZDJB_(G)) :: & + V_old_u, V_old_v, V_curr_u, V_curr_v, V_new_u, V_new_v, & ! Lanczos basis vectors [R L3 Z T-2 ~> m kg s-2] + Z_curr_u, Z_curr_v, Z_new_u, Z_new_v, & ! Preconditioned Lanczos vectors [L T-1 ~> m s-1] + W_old_u, W_old_v, W_curr_u, W_curr_v, W_new_u, W_new_v, & ! MINRES search directions [L T-1 ~> m s-1] + Qu, Qv ! A * Z_curr [R L3 Z T-2 ~> m kg s-2] + real, dimension(SZDIB_(G),SZDJB_(G)) :: sum_vec_3d ! Pointwise products for global sums + ! [kg m2 s-3] before normalization; + ! [nondim] inside loop (after Lanczos normalization) + real :: alpha ! Lanczos diagonal element (Rayleigh quotient) [nondim] + real :: beta1 ! Current Lanczos off-diagonal coefficient; + ! initial value [kg^1/2 m s^-3/2], then [nondim] after iter 1 + real :: beta2 ! Next Lanczos off-diagonal coefficient [nondim] + real :: eta ! MINRES residual norm estimate [kg^1/2 m s^-3/2] + real :: eta_curr ! Effective step magnitude for current iteration [kg^1/2 m s^-3/2] + real :: c0, s0, c1, s1, c2, s2 ! Givens rotation cosines and sines [nondim] + real :: d0, d1, d2 ! Tridiagonal QR factorization coefficients [nondim] + real :: resid0tol ! Convergence tolerance (CS%cg_tol_newton * beta1) [kg^1/2 m s^-3/2] + real :: current_norm ! Current MINRES residual norm estimate [kg^1/2 m s^-3/2] + real :: sv3dsum ! Global reproducing sum of sum_vec_3d; + ! [kg m2 s-3] before normalization, [nondim] inside loop + real :: Ibeta1 ! Reciprocal of initial beta1 [kg^-1/2 m-1 s^3/2] + real :: Ibeta2 ! Reciprocal of beta2 [nondim] + real :: Id1 ! Reciprocal of d1 [nondim] + integer :: iter, i, j, isc, iec, jsc, jec + integer :: Isdq, Iedq, Jsdq, Jedq, Iscq, Iecq, Jscq, Jecq + + Isdq = G%IsdB ; Iedq = G%IedB ; Jsdq = G%JsdB ; Jedq = G%JedB + Iscq = G%IscB ; Iecq = G%IecB ; Jscq = G%JscB ; Jecq = G%JecB + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec - sum_vec(:,:) = 0.0 - do j=jscq,jecq ; do i=iscq,iecq - if (CS%umask(I,J) == 1) sum_vec(I,J) = resid2_scale*Ru(I,J)**2 - if (CS%vmask(I,J) == 1) sum_vec(I,J) = sum_vec(I,J) + resid2_scale*Rv(I,J)**2 + ! Initialize MINRES-specific arrays + V_old_u(:,:) = 0 ; V_old_v(:,:) = 0 ; V_curr_u(:,:) = 0 ; V_curr_v(:,:) = 0 + Z_curr_u(:,:) = 0 ; Z_curr_v(:,:) = 0 + W_old_u(:,:) = 0 ; W_old_v(:,:) = 0 ; W_curr_u(:,:) = 0 ; W_curr_v(:,:) = 0 + Qu(:,:) = 0 ; Qv(:,:) = 0 + + ! Initial Residual + V_curr_u(:,:) = (RHSu(:,:) - Au(:,:)) ; V_curr_v(:,:) = (RHSv(:,:) - Av(:,:)) + + do J=Jscq,Jecq ; do I=Iscq,Iecq + if (CS%umask(I,J) == 1) Z_curr_u(I,J) = V_curr_u(I,J) * IDIAGu(I,J) + if (CS%vmask(I,J) == 1) Z_curr_v(I,J) = V_curr_v(I,J) * IDIAGv(I,J) + enddo ; enddo + + sum_vec_3d(:,:) = 0.0 + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq + if (CS%umask(I,J) == 1) sum_vec_3d(I,J) = resid_scale * (V_curr_u(I,J) * Z_curr_u(I,J)) + if (CS%vmask(I,J) == 1) sum_vec_3d(I,J) = sum_vec_3d(I,J) + resid_scale * (V_curr_v(I,J) * Z_curr_v(I,J)) + enddo ; enddo + sv3dsum = reproducing_sum( sum_vec_3d(:,:), Is_sum, Ie_sum, Js_sum, Je_sum ) + + beta1 = sqrt(abs(sv3dsum)) + + if (beta1 == 0.0) then + conv_flag = 1 + iters = 0 + return + endif + + Ibeta1 = 1.0/beta1 + + ! Normalize initial Lanczos vectors + do J=Jscq,Jecq ; do I=Iscq,Iecq + if (CS%umask(I,J) == 1) then + V_curr_u(I,J) = V_curr_u(I,J) * Ibeta1 + Z_curr_u(I,J) = Z_curr_u(I,J) * Ibeta1 + endif + if (CS%vmask(I,J) == 1) then + V_curr_v(I,J) = V_curr_v(I,J) * Ibeta1 + Z_curr_v(I,J) = Z_curr_v(I,J) * Ibeta1 + endif + enddo ; enddo + + ! Sync Z_curr prior to entering the loop + call pass_vector(Z_curr_u, Z_curr_v, G%domain, TO_ALL, BGRID_NE) + + eta = beta1 + resid0tol = CS%cg_tol_newton * beta1 + conv_flag = 0 + + c0 = 1.0 ; s0 = 0.0 ; c1 = 1.0 ; s1 = 0.0 + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! !! + !! MAIN MINRES LANCZOS LOOP !! + !! !! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + do iter = 1, CS%cg_max_iterations + + ! --- STEP 1: Matrix Vector Product --- + Qu(:,:) = 0 ; Qv(:,:) = 0 + call CG_action(CS, Qu, Qv, Z_curr_u, Z_curr_v, Phi, Phisub, CS%umask, CS%vmask, hmask, & + H_node, CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & + G, US, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow) + ! --- STEP 2: alpha = q dot z_curr --- + sum_vec_3d(:,:) = 0.0 + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq + if (CS%umask(I,J) == 1) sum_vec_3d(I,J) = resid_scale * (Qu(I,J) * Z_curr_u(I,J)) + if (CS%vmask(I,J) == 1) sum_vec_3d(I,J) = sum_vec_3d(I,J) + resid_scale * (Qv(I,J) * Z_curr_v(I,J)) + enddo ; enddo + sv3dsum = reproducing_sum( sum_vec_3d(:,:), Is_sum, Ie_sum, Js_sum, Je_sum ) + alpha = sv3dsum + + ! --- FUSED STEPS 3 & 4: Update V_new and Precondition to Z_new --- + do J=Jscq,Jecq ; do I=Iscq,Iecq + if (CS%umask(I,J) == 1) then + V_new_u(I,J) = Qu(I,J) - alpha * V_curr_u(I,J) - beta1 * V_old_u(I,J) + Z_new_u(I,J) = V_new_u(I,J) * IDIAGu(I,J) + endif + if (CS%vmask(I,J) == 1) then + V_new_v(I,J) = Qv(I,J) - alpha * V_curr_v(I,J) - beta1 * V_old_v(I,J) + Z_new_v(I,J) = V_new_v(I,J) * IDIAGv(I,J) + endif + enddo ; enddo + + ! --- STEP 5: beta2 = sqrt(v_new dot z_new) --- + sum_vec_3d(:,:) = 0.0 + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq + if (CS%umask(I,J) == 1) sum_vec_3d(I,J) = resid_scale * (V_new_u(I,J) * Z_new_u(I,J)) + if (CS%vmask(I,J) == 1) sum_vec_3d(I,J) = sum_vec_3d(I,J) + resid_scale * (V_new_v(I,J) * Z_new_v(I,J)) enddo ; enddo + sv3dsum = reproducing_sum( sum_vec_3d(:,:), Is_sum, Ie_sum, Js_sum, Je_sum ) + beta2 = sqrt(abs(sv3dsum)) - dot_p1 = reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) - dot_p1 = sqrt(dot_p1) + ! --- STEP 6: Apply Givens Rotations --- + d0 = c1 * alpha - c0 * s1 * beta1 + d1 = sqrt(d0**2 + beta2**2) - if (dot_p1 <= CS%cg_tolerance * resid0) then + if (d1 == 0.0) then iters = iter conv_flag = 1 exit endif - cg_halo = cg_halo - 1 + Id1 = 1.0 / d1 + if (beta2 > 0) Ibeta2 = 1.0 / beta2 + + d2 = s1 * alpha + c0 * c1 * beta1 + c2 = d0 * Id1 + s2 = beta2 * Id1 + + eta_curr = c2 * eta + eta = -s2 * eta + current_norm = abs(eta) + + ! --- FUSED STEPS 7 & 9: Update u/v, Check Convergence, and Shift Vectors --- + do J=Jscq,Jecq ; do I=Iscq,Iecq + if (CS%umask(I,J) == 1) then + W_new_u(I,J) = (Z_curr_u(I,J) - (d2 * W_curr_u(I,J) + beta1 * s0 * W_old_u(I,J))) * Id1 + u_shlf(I,J) = u_shlf(I,J) + eta_curr * W_new_u(I,J) + if (beta2 > 0.0) then + V_old_u(I,J) = V_curr_u(I,J) + V_curr_u(I,J) = V_new_u(I,J) * Ibeta2 + Z_curr_u(I,J) = Z_new_u(I,J) * Ibeta2 + W_old_u(I,J) = W_curr_u(I,J) + W_curr_u(I,J) = W_new_u(I,J) + endif + endif + if (CS%vmask(I,J) == 1) then + W_new_v(I,J) = (Z_curr_v(I,J) - (d2 * W_curr_v(I,J) + beta1 * s0 * W_old_v(I,J))) * Id1 + v_shlf(I,J) = v_shlf(I,J) + eta_curr * W_new_v(I,J) + if (beta2 > 0.0) then + V_old_v(I,J) = V_curr_v(I,J) + V_curr_v(I,J) = V_new_v(I,J) * Ibeta2 + Z_curr_v(I,J) = Z_new_v(I,J) * Ibeta2 + W_old_v(I,J) = W_curr_v(I,J) + W_curr_v(I,J) = W_new_v(I,J) + endif + endif + enddo ; enddo - if (cg_halo == 0) then - ! pass vectors - call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE) - call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) - call pass_vector(Ru, Rv, G%domain, TO_ALL, BGRID_NE) - cg_halo = 3 + ! --- STEP 8: Check Convergence --- + if (current_norm <= resid0tol .or. beta2 == 0.0) then + iters = iter + conv_flag = 1 + exit endif - enddo ! end of CG loop + ! Sync Z_curr for the next iteration's CG_action + call pass_vector(Z_curr_u, Z_curr_v, G%domain, TO_ALL, BGRID_NE) - do j=jsdq,jedq - do i=isdq,iedq - if (CS%umask(I,J) == 3) then - u_shlf(I,J) = CS%u_bdry_val(I,J) - elseif (CS%umask(I,J) == 0) then - u_shlf(I,J) = 0 - endif + beta1 = beta2 + c0 = c1 ; c1 = c2 + s0 = s1 ; s1 = s2 - if (CS%vmask(I,J) == 3) then - v_shlf(I,J) = CS%v_bdry_val(I,J) - elseif (CS%vmask(I,J) == 0) then - v_shlf(I,J) = 0 - endif - enddo - enddo + enddo ! end of MINRES loop - call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) - if (conv_flag == 0) then - iters = CS%cg_max_iterations - endif +end subroutine ice_shelf_solve_inner_MINRES -end subroutine ice_shelf_solve_inner +!> CR (Conjugate Residual) inner Krylov solve for ice shelf velocity. +subroutine ice_shelf_solve_inner_CR(CS, G, US, u_shlf, v_shlf, RHSu, RHSv, Au, Av, & + IDIAGu, IDIAGv, H_node, float_cond, hmask, & + rhoi_rhow, resid_scale, Phi, Phisub, conv_flag, iters, & + Is_sum, Js_sum, Ie_sum, Je_sum, Iscq_sv, Jscq_sv) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: RHSu !< Right hand side, x [R L3 Z T-2 ~> m kg s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: RHSv !< Right hand side, y [R L3 Z T-2 ~> m kg s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: Au !< Matrix-vector product workspace, x [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: Av !< Matrix-vector product workspace, y [R L3 Z T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: IDIAGu !< Reciprocal Jacobi diagonal, x [R-1 L-2 Z-1 T ~> kg-1 s] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: IDIAGv !< Reciprocal Jacobi diagonal, y [R-1 L-2 Z-1 T ~> kg-1 s] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: H_node !< The ice shelf thickness at nodal points [Z ~> m] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: float_cond !< Grounding line indicator [nondim] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: hmask !< Ice shelf coverage mask + real, intent(in) :: rhoi_rhow !< Ice-to-ocean density ratio [nondim] + real, intent(in) :: resid_scale !< Scaling for inner products + !! [T3 kg m2 R-1 Z-1 L-4 s-3 ~> 1] + real, dimension(8,4,SZDI_(G),SZDJ_(G)), & + intent(in) :: Phi !< Basis element gradients at quadrature points [L-1 ~> m-1] + real, dimension(:,:,:,:,:,:), & + intent(in) :: Phisub !< Subgridscale quadrature weights [nondim] + integer, intent(out) :: conv_flag !< Convergence flag: 1=converged, 0=not + integer, intent(out) :: iters !< The number of iterations used + integer, intent(in) :: Is_sum !< Starting i-index for global sums + integer, intent(in) :: Js_sum !< Starting j-index for global sums + integer, intent(in) :: Ie_sum !< Ending i-index for global sums + integer, intent(in) :: Je_sum !< Ending j-index for global sums + integer, intent(in) :: Iscq_sv !< Starting i-index for sum_vec arrays + integer, intent(in) :: Jscq_sv !< Starting j-index for sum_vec arrays + + real, dimension(SZDIB_(G),SZDJB_(G)) :: & + Ru, Rv, & ! Residuals (r) [R L3 Z T-2 ~> m kg s-2] + Zu, Zv, & ! Preconditioned residuals (z = M^-1 r) [L T-1 ~> m s-1] + Du, Dv, & ! Search directions (p) [L T-1 ~> m s-1] + Qu, Qv ! A * p [R L3 Z T-2 ~> m kg s-2] + real, dimension(SZDIB_(G),SZDJB_(G),2) :: sum_vec_3d ! Pointwise products for global sums. + ! sum_vec_3d(:,:,1): r^2 [kg2 m2 s-4] or z·q [kg m2 s-3] (context-dependent) + ! sum_vec_3d(:,:,2): z·w or q·(M^-1 q) [kg m2 s-3] + real :: alpha ! Step length [nondim] + real :: beta ! Direction update coefficient [nondim] + real :: r_norm_sq ! Squared residual norm [kg2 m2 s-4] + real :: z_w_sum ! Inner product (z_k, A z_k); beta denominator [kg m2 s-3] + real :: z_w_sum_new ! Inner product (z_{k+1}, A z_{k+1}); beta numerator [kg m2 s-3] + real :: z_q_sum ! Inner product (z_k, A p_k); alpha numerator [kg m2 s-3] + real :: q_s_sum ! Inner product (A p_k, M^-1 A p_k); alpha denom [kg m2 s-3] + real :: resid0tol2 ! Convergence threshold: tol^2 * ||r_0||^2 [kg2 m2 s-4] + real :: sv3dsum ! Unused scalar return from reproducing_sum [various] + real :: sv3dsums(2) ! Component sums from reproducing_sum + ! sv3dsums(1): r^2 or z·q [kg2 m2 s-4 or kg m2 s-3] (context-dependent) + ! sv3dsums(2): z·w or q·M^-1 q [kg m2 s-3] + real :: resid2_scale ! Scaling for squared-stress inner products [T4 kg2 m2 R-2 Z-2 L-6 s-4 ~> 1] + integer :: iter, i, j, isc, iec, jsc, jec + integer :: Isdq, Iedq, Jsdq, Jedq, Iscq, Iecq, Jscq, Jecq + + Isdq = G%IsdB ; Iedq = G%IedB ; Jsdq = G%JsdB ; Jedq = G%JedB + Iscq = G%IscB ; Iecq = G%IecB ; Jscq = G%JscB ; Jecq = G%JecB + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + + resid2_scale = ((US%RZ_to_kg_m2*US%L_to_m)*US%L_T_to_m_s**2)**2 + + ! Initialize CR-specific arrays + Ru(:,:) = 0 ; Rv(:,:) = 0 ; Zu(:,:) = 0 ; Zv(:,:) = 0 + Du(:,:) = 0 ; Dv(:,:) = 0 ; Qu(:,:) = 0 ; Qv(:,:) = 0 + + ! r_0 = b - A*x_0 + Ru(:,:) = (RHSu(:,:) - Au(:,:)) ; Rv(:,:) = (RHSv(:,:) - Av(:,:)) + + ! z_0 = M^-1 r_0 + do J=Jsdq,Jedq ; do I=Isdq,Iedq + if (CS%umask(I,J) == 1) Zu(I,J) = Ru(I,J) * IDIAGu(I,J) + if (CS%vmask(I,J) == 1) Zv(I,J) = Rv(I,J) * IDIAGv(I,J) + enddo ; enddo + + ! p_0 = z_0 + Du(:,:) = Zu(:,:) ; Dv(:,:) = Zv(:,:) + + ! Compute A * z_0 + Au(:,:) = 0 ; Av(:,:) = 0 + call CG_action(CS, Au, Av, Zu, Zv, Phi, Phisub, CS%umask, CS%vmask, hmask, & + H_node, CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & + G, US, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow) + call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) + + ! q_0 = A * p_0 + Qu(:,:) = Au(:,:) ; Qv(:,:) = Av(:,:) + + ! Initial Norms + sum_vec_3d(:,:,:) = 0.0 ; sv3dsums(1:2) = 0.0 + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq + if (CS%umask(I,J) == 1) then + sum_vec_3d(I,J,1) = resid2_scale * Ru(I,J)**2 + sum_vec_3d(I,J,2) = resid_scale * (Zu(I,J) * Au(I,J)) + endif + if (CS%vmask(I,J) == 1) then + sum_vec_3d(I,J,1) = sum_vec_3d(I,J,1) + resid2_scale * Rv(I,J)**2 + sum_vec_3d(I,J,2) = sum_vec_3d(I,J,2) + resid_scale * (Zv(I,J) * Av(I,J)) + endif + enddo ; enddo + sv3dsum = reproducing_sum( sum_vec_3d(:,:,1:2), Is_sum, Ie_sum, Js_sum, Je_sum, sums=sv3dsums(1:2) ) + + r_norm_sq = sv3dsums(1) + z_w_sum = sv3dsums(2) + + resid0tol2 = CS%cg_tol_newton**2 * r_norm_sq + conv_flag = 0 + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! !! + !! MAIN CONJUGATE RESIDUAL LOOP !! + !! !! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + do iter = 1, CS%cg_max_iterations + + ! --- STEP 1: alpha = (z_k, q_k) / (q_k, M^-1 q_k) --- + sum_vec_3d(:,:,:) = 0.0 ; sv3dsums(1:2) = 0.0 + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq + if (CS%umask(I,J) == 1) then + sum_vec_3d(I,J,1) = resid_scale * (Zu(I,J) * Qu(I,J)) + ! Order matters to prevent float overflow: Q * (Q * IDiag) + sum_vec_3d(I,J,2) = resid_scale * (Qu(I,J) * (Qu(I,J) * IDIAGu(I,J))) + endif + if (CS%vmask(I,J) == 1) then + sum_vec_3d(I,J,1) = sum_vec_3d(I,J,1) + resid_scale * (Zv(I,J) * Qv(I,J)) + sum_vec_3d(I,J,2) = sum_vec_3d(I,J,2) + resid_scale * (Qv(I,J) * (Qv(I,J) * IDIAGv(I,J))) + endif + enddo ; enddo + sv3dsum = reproducing_sum( sum_vec_3d(:,:,1:2), Is_sum, Ie_sum, Js_sum, Je_sum, sums=sv3dsums(1:2) ) + + z_q_sum = sv3dsums(1) + q_s_sum = sv3dsums(2) + + if (q_s_sum == 0.0) then + iters = iter + conv_flag = 1 + exit + endif + alpha = z_q_sum / q_s_sum + + ! --- STEP 2: Update x, r, and z (Fused over Full Domain) --- + ! Zu halos are populated here since the loop covers Jsdq..Jedq; no pass_vector needed. + do J=Jsdq,Jedq ; do I=Isdq,Iedq + if (CS%umask(I,J) == 1) then + u_shlf(I,J) = u_shlf(I,J) + alpha * Du(I,J) + Ru(I,J) = Ru(I,J) - alpha * Qu(I,J) + Zu(I,J) = Ru(I,J) * IDIAGu(I,J) + endif + if (CS%vmask(I,J) == 1) then + v_shlf(I,J) = v_shlf(I,J) + alpha * Dv(I,J) + Rv(I,J) = Rv(I,J) - alpha * Qv(I,J) + Zv(I,J) = Rv(I,J) * IDIAGv(I,J) + endif + enddo ; enddo + + ! --- STEP 3: w_{k+1} = A z_{k+1} --- + Au(:,:) = 0 ; Av(:,:) = 0 + call CG_action(CS, Au, Av, Zu, Zv, Phi, Phisub, CS%umask, CS%vmask, hmask, & + H_node, CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & + G, US, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow) + call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) + + ! --- STEP 4: beta and convergence check --- + sum_vec_3d(:,:,:) = 0.0 ; sv3dsums(1:2) = 0.0 + do J=Jscq_sv,Jecq ; do I=Iscq_sv,Iecq + if (CS%umask(I,J) == 1) then + sum_vec_3d(I,J,1) = resid2_scale * Ru(I,J)**2 + sum_vec_3d(I,J,2) = resid_scale * (Zu(I,J) * Au(I,J)) + endif + if (CS%vmask(I,J) == 1) then + sum_vec_3d(I,J,1) = sum_vec_3d(I,J,1) + resid2_scale * Rv(I,J)**2 + sum_vec_3d(I,J,2) = sum_vec_3d(I,J,2) + resid_scale * (Zv(I,J) * Av(I,J)) + endif + enddo ; enddo + sv3dsum = reproducing_sum( sum_vec_3d(:,:,1:2), Is_sum, Ie_sum, Js_sum, Je_sum, sums=sv3dsums(1:2) ) + + r_norm_sq = sv3dsums(1) + z_w_sum_new = sv3dsums(2) + + if (r_norm_sq <= resid0tol2 .or. z_w_sum==0.0) then + iters = iter + conv_flag = 1 + exit + endif + + beta = z_w_sum_new / z_w_sum + z_w_sum = z_w_sum_new + + ! --- STEP 5: Update p and q --- + do J=Jsdq,Jedq ; do I=Isdq,Iedq + if (CS%umask(I,J) == 1) then + Du(I,J) = Zu(I,J) + beta * Du(I,J) + Qu(I,J) = Au(I,J) + beta * Qu(I,J) + endif + if (CS%vmask(I,J) == 1) then + Dv(I,J) = Zv(I,J) + beta * Dv(I,J) + Qv(I,J) = Av(I,J) + beta * Qv(I,J) + endif + enddo ; enddo + + enddo ! end of CR loop + +end subroutine ice_shelf_solve_inner_CR subroutine ice_shelf_advect_thickness_x(CS, G, LB, time_step, hmask, h0, h_after_uflux, uh_ice) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure @@ -1400,7 +2638,6 @@ subroutine ice_shelf_advect_thickness_x(CS, G, LB, time_step, hmask, h0, h_after ! is = G%isc-2 ; ie = G%iec+2 ; js = G%jsc ; je = G%jec ! isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed -! i_off = G%idg_offset ; j_off = G%jdg_offset ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh @@ -1409,37 +2646,39 @@ subroutine ice_shelf_advect_thickness_x(CS, G, LB, time_step, hmask, h0, h_after do j=jsh,jeh ; do I=ish-1,ieh if (CS%u_face_mask(I,j) == 4.) then ! The flux itself is a specified boundary condition. - uh_ice(I,j) = time_step * G%dyCu(I,j) * CS%u_flux_bdry_val(I,j) - elseif ((hmask(i,j)==1) .or. (hmask(i+1,j) == 1)) then + uh_ice(I,j) = (time_step * G%dyCu(I,j)) * CS%u_flux_bdry_val(I,j) + elseif ((hmask(i,j) == 1 .or. hmask(i,j) == 3) .or. (hmask(i+1,j) == 1 .or. hmask(i+1,j) == 3)) then u_face = 0.5 * (CS%u_shelf(I,J-1) + CS%u_shelf(I,J)) h_face = 0.0 ! This will apply when the source cell is iceless or not fully ice covered. if (u_face > 0) then if (hmask(i,j) == 3) then ! This is a open boundary inflow from the west - h_face = CS%thickness_bdry_val(i,j) + h_face = CS%h_bdry_val(i,j) elseif (hmask(i,j) == 1) then ! There can be eastward flow through this face. - if ((hmask(i-1,j) == 1) .and. (hmask(i+1,j) == 1)) then + if ((hmask(i-1,j) == 1 .or. hmask(i-1,j) == 3) .and. & + (hmask(i+1,j) == 1 .or. hmask(i+1,j) == 3)) then slope_lim = slope_limiter(h0(i,j)-h0(i-1,j), h0(i+1,j)-h0(i,j)) ! This is a 2nd-order centered scheme with a slope limiter. We could try PPM here. - h_face = h0(i,j) - slope_lim * 0.5 * (h0(i,j)-h0(i+1,j)) + h_face = h0(i,j) - slope_lim * (0.5 * (h0(i,j)-h0(i+1,j))) else h_face = h0(i,j) endif endif else if (hmask(i+1,j) == 3) then ! This is a open boundary inflow from the east - h_face = CS%thickness_bdry_val(i+1,j) + h_face = CS%h_bdry_val(i+1,j) elseif (hmask(i+1,j) == 1) then - if ((hmask(i,j) == 1) .and. (hmask(i+2,j) == 1)) then + if ((hmask(i,j) == 1 .or. hmask(i,j) == 3) .and. & + (hmask(i+2,j) == 1 .or. hmask(i+2,j) == 3)) then slope_lim = slope_limiter(h0(i+1,j)-h0(i,j), h0(i+2,j)-h0(i+1,j)) - h_face = h0(i+1,j) - slope_lim * 0.5 * (h0(i+1,j)-h0(i,j)) + h_face = h0(i+1,j) - slope_lim * (0.5 * (h0(i+2,j)-h0(i+1,j))) else h_face = h0(i+1,j) endif endif endif - uh_ice(I,j) = time_step * G%dyCu(I,j) * u_face * h_face + uh_ice(I,j) = (time_step * G%dyCu(I,j)) * (u_face * h_face) else uh_ice(I,j) = 0.0 endif @@ -1488,38 +2727,39 @@ subroutine ice_shelf_advect_thickness_y(CS, G, LB, time_step, hmask, h0, h_after do J=jsh-1,jeh ; do i=ish,ieh if (CS%v_face_mask(i,J) == 4.) then ! The flux itself is a specified boundary condition. - vh_ice(i,J) = time_step * G%dxCv(i,J) * CS%v_flux_bdry_val(i,J) - elseif ((hmask(i,j)==1) .or. (hmask(i,j+1) == 1)) then - + vh_ice(i,J) = (time_step * G%dxCv(i,J)) * CS%v_flux_bdry_val(i,J) + elseif ((hmask(i,j) == 1 .or. hmask(i,j) == 3) .or. (hmask(i,j+1) == 1 .or. hmask(i,j+1) == 3)) then v_face = 0.5 * (CS%v_shelf(I-1,J) + CS%v_shelf(I,J)) h_face = 0.0 ! This will apply when the source cell is iceless or not fully ice covered. if (v_face > 0) then if (hmask(i,j) == 3) then ! This is a open boundary inflow from the south - h_face = CS%thickness_bdry_val(i,j) - elseif (hmask(i,j) == 1) then ! There can be northtward flow through this face. - if ((hmask(i,j-1) == 1) .and. (hmask(i,j+1) == 1)) then + h_face = CS%h_bdry_val(i,j) + elseif (hmask(i,j) == 1) then ! There can be northward flow through this face. + if ((hmask(i,j-1) == 1 .or. hmask(i,j-1) == 3) .and. & + (hmask(i,j+1) == 1 .or. hmask(i,j+1) == 3)) then slope_lim = slope_limiter(h0(i,j)-h0(i,j-1), h0(i,j+1)-h0(i,j)) ! This is a 2nd-order centered scheme with a slope limiter. We could try PPM here. - h_face = h0(i,j) - slope_lim * 0.5 * (h0(i,j)-h0(i,j+1)) + h_face = h0(i,j) - slope_lim * (0.5 * (h0(i,j)-h0(i,j+1))) else h_face = h0(i,j) endif endif else if (hmask(i,j+1) == 3) then ! This is a open boundary inflow from the north - h_face = CS%thickness_bdry_val(i,j+1) + h_face = CS%h_bdry_val(i,j+1) elseif (hmask(i,j+1) == 1) then - if ((hmask(i,j) == 1) .and. (hmask(i,j+2) == 1)) then + if ((hmask(i,j) == 1 .or. hmask(i,j) == 3) .and. & + (hmask(i,j+2) == 1 .or. hmask(i,j+2) == 3)) then slope_lim = slope_limiter(h0(i,j+1)-h0(i,j), h0(i,j+2)-h0(i,j+1)) - h_face = h0(i,j+1) - slope_lim * 0.5 * (h0(i,j+1)-h0(i,j)) + h_face = h0(i,j+1) - slope_lim * (0.5 * (h0(i,j+2)-h0(i,j+1))) else h_face = h0(i,j+1) endif endif endif - vh_ice(i,J) = time_step * G%dxCv(i,J) * v_face * h_face + vh_ice(i,J) = (time_step * G%dxCv(i,J)) * (v_face * h_face) else vh_ice(i,J) = 0.0 endif @@ -1575,12 +2815,16 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) ! o--- (3) ---o ! - integer :: i, j, isc, iec, jsc, jec, n_flux, k, l, iter_count + integer :: i, j, isc, iec, jsc, jec, n_flux, k, iter_count integer :: i_off, j_off integer :: iter_flag real :: h_reference ! A reference thicknesss based on neighboring cells [Z ~> m] + real :: h_reference_ew !contribution to reference thickness from east + west cells [Z ~> m] + real :: h_reference_ns !contribution to reference thickness from north + south cells [Z ~> m] real :: tot_flux ! The total ice mass flux [Z L2 ~> m3] + real :: tot_flux_ew ! The contribution to total ice mass flux from east + west cells [Z L2 ~> m3] + real :: tot_flux_ns ! The contribution to total ice mass flux from north + south cells [Z L2 ~> m3] real :: partial_vol ! The volume covered by ice shelf [Z L2 ~> m3] real :: dxdyh ! Cell area [L2 ~> m2] character(len=160) :: mesg ! The text of an error message @@ -1619,26 +2863,32 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) iter_count = iter_count + 1 ! if iter_count >= 3 then some halo updates need to be done... + if (iter_count==3) then + call MOM_error(FATAL, "MOM_ice_shelf_dyn.F90, shelf_advance_front iter >=3.") + endif do j=jsc-1,jec+1 - if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) >= G%domain%njhalo+1)) then + if (CS%reentrant_y .OR. (((j+j_off) <= G%domain%njglobal) .AND. & + ((j+j_off) >= 1))) then do i=isc-1,iec+1 - if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & - ((i+i_off) >= G%domain%nihalo+1)) then - ! first get reference thickness by averaging over cells that are fluxing into this cell + if (CS%reentrant_x .OR. (((i+i_off) <= G%domain%niglobal) .AND. & + ((i+i_off) >= 1))) then + ! first get reference thickness by averaging over cells that are fluxing into this cell n_flux = 0 - h_reference = 0.0 - tot_flux = 0.0 + h_reference_ew = 0.0 + h_reference_ns = 0.0 + tot_flux_ew = 0.0 + tot_flux_ns = 0.0 do k=1,2 if (flux_enter(i,j,k) > 0) then n_flux = n_flux + 1 - h_reference = h_reference + ISS%h_shelf(i+2*k-3,j) - tot_flux = tot_flux + flux_enter(i,j,k) + h_reference_ew = h_reference_ew + flux_enter(i,j,k) * ISS%h_shelf(i+2*k-3,j) + !h_reference = h_reference + ISS%h_shelf(i+2*k-3,j) + tot_flux_ew = tot_flux_ew + flux_enter(i,j,k) flux_enter(i,j,k) = 0.0 endif enddo @@ -1646,19 +2896,24 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) do k=1,2 if (flux_enter(i,j,k+2) > 0) then n_flux = n_flux + 1 - h_reference = h_reference + ISS%h_shelf(i,j+2*k-3) - tot_flux = tot_flux + flux_enter(i,j,k+2) + h_reference_ns = h_reference_ns + flux_enter(i,j,k+2) * ISS%h_shelf(i,j+2*k-3) + !h_reference = h_reference + ISS%h_shelf(i,j+2*k-3) + tot_flux_ns = tot_flux_ns + flux_enter(i,j,k+2) flux_enter(i,j,k+2) = 0.0 endif enddo + h_reference = h_reference_ew + h_reference_ns + tot_flux = tot_flux_ew + tot_flux_ns + if (n_flux > 0) then dxdyh = G%areaT(i,j) - h_reference = h_reference / real(n_flux) + h_reference = h_reference / tot_flux + !h_reference = h_reference / real(n_flux) partial_vol = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) + tot_flux if ((partial_vol / G%areaT(i,j)) == h_reference) then ! cell is exactly covered, no overflow - ISS%hmask(i,j) = 1 + if (ISS%hmask(i,j)/=3) ISS%hmask(i,j) = 1 ISS%h_shelf(i,j) = h_reference ISS%area_shelf_h(i,j) = G%areaT(i,j) elseif ((partial_vol / G%areaT(i,j)) < h_reference) then @@ -1668,7 +2923,7 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) ISS%h_shelf(i,j) = h_reference else - ISS%hmask(i,j) = 1 + if (ISS%hmask(i,j)/=3) ISS%hmask(i,j) = 1 ISS%area_shelf_h(i,j) = G%areaT(i,j) !h_temp(i,j) = h_reference partial_vol = partial_vol - h_reference * G%areaT(i,j) @@ -1779,6 +3034,7 @@ subroutine calve_to_mask(G, h_shelf, area_shelf_h, hmask, calve_mask) end subroutine calve_to_mask +!> Calculate driving stress using cell-centered bed elevation and ice thickness subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe @@ -1788,10 +3044,10 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: OD !< ocean floor depth at tracer points [Z ~> m]. real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: taudx !< X-direction driving stress at q-points [kg L s-2 ~> kg m s-2] + intent(inout) :: taudx !< X-direction driving stress at q-points [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: taudy !< Y-direction driving stress at q-points [kg L s-2 ~> kg m s-2] - ! This will become [R L3 Z T-2 ~> kg m s-2] + intent(inout) :: taudy !< Y-direction driving stress at q-points [R L3 Z T-2 ~> kg m s-2] + ! driving stress! @@ -1804,31 +3060,27 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) ! "average" ocean depth -- and is needed to find surface elevation ! (it is assumed that base_ice = bed + OD) - real, dimension(SIZE(OD,1),SIZE(OD,2)) :: S, & ! surface elevation [Z ~> m]. - BASE ! basal elevation of shelf/stream [Z ~> m]. - real, pointer, dimension(:,:,:,:) :: Phi => NULL() ! The gradients of bilinear basis elements at Gaussian - ! quadrature points surrounding the cell vertices [m-1]. - - + real, dimension(SIZE(OD,1),SIZE(OD,2)) :: S ! surface elevation [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)) :: sx_e, sy_e !element contributions to driving stress real :: rho, rhow, rhoi_rhow ! Ice and ocean densities [R ~> kg m-3] - real :: sx, sy ! Ice shelf top slopes [Z L-1 ~> nondim] + real :: sx, sy ! Ice shelf top slopes at tracer points [Z L-1 ~> nondim] real :: neumann_val ! [R Z L2 T-2 ~> kg s-2] - real :: dxh, dyh,Dx,Dy ! Local grid spacing [L ~> m] real :: grav ! The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] - - integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, is, js, iegq, jegq - integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec + real :: scale ! Scaling factor used to ensure surface slope magnitude does not exceed CS%max_surface_slope + logical :: valid_N, valid_S, valid_E, valid_W + integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, is, js, iegq, jegq + integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec integer :: i_off, j_off isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB - isd = G%isd ; jsd = G%jsd - iegq = G%iegB ; jegq = G%jegB +! iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed +! iegq = G%iegB ; jegq = G%jegB ! gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 gisc = 1 ; gjsc = 1 ! giec = G%domain%niglobal+G%domain%nihalo ; gjec = G%domain%njglobal+G%domain%njhalo giec = G%domain%niglobal ; gjec = G%domain%njglobal - is = iscq - 1; js = jscq - 1 +! is = iscq - 1 ; js = jscq - 1 i_off = G%idg_offset ; j_off = G%jdg_offset @@ -1838,130 +3090,111 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) rhoi_rhow = rho/rhow ! prelim - go through and calculate S - ! or is this faster? - BASE(:,:) = -CS%bed_elev(:,:) + OD(:,:) - S(:,:) = -CS%bed_elev(:,:) + ISS%h_shelf(:,:) - ! check whether the ice is floating or grounded - do j=jsc-G%domain%njhalo,jec+G%domain%njhalo - do i=isc-G%domain%nihalo,iec+G%domain%nihalo - if (rhoi_rhow * ISS%h_shelf(i,j) - CS%bed_elev(i,j) <= 0) then - S(i,j) = (1 - rhoi_rhow)*ISS%h_shelf(i,j) + if (CS%GL_couple) then + do j=jsc-2,jec+2 ; do i=isc-2,iec+2 + S(i,j) = -CS%bed_elev(i,j) + (OD(i,j) + max(ISS%h_shelf(i,j),CS%min_h_shelf)) + enddo ; enddo + else + ! check whether the ice is floating or grounded + do j=jsc-2,jec+2 ; do i=isc-2,iec+2 + if (rhoi_rhow * max(ISS%h_shelf(i,j),CS%min_h_shelf) - CS%bed_elev(i,j) <= 0) then + S(i,j) = (1 - rhoi_rhow)*max(ISS%h_shelf(i,j),CS%min_h_shelf) else - S(i,j)=ISS%h_shelf(i,j)-CS%bed_elev(i,j) + S(i,j) = max(ISS%h_shelf(i,j),CS%min_h_shelf)-CS%bed_elev(i,j) endif - enddo - enddo + enddo ; enddo + endif + + call pass_var(S, G%domain) + do j=jsc-1,jec+1 do i=isc-1,iec+1 - cnt = 0 - sx = 0 - sy = 0 - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - Dx=dxh - Dy=dyh - if (ISS%hmask(i,j) == 1) then ! we are inside the global computational bdry, at an ice-filled cell - - ! calculate sx - if ((i+i_off) == gisc) then ! at left computational bdry - if (ISS%hmask(i+1,j) == 1) then - sx = (S(i+1,j)-S(i,j))/dxh - else - sx = 0 - endif - elseif ((i+i_off) == giec) then ! at east computational bdry - if (ISS%hmask(i-1,j) == 1) then - sx = (S(i,j)-S(i-1,j))/dxh - else - sx = 0 - endif - else ! interior - if (ISS%hmask(i+1,j) == 1) then - cnt = cnt+1 - Dx =dxh+ G%dxT(i+1,j) - sx = S(i+1,j) - else - sx = S(i,j) - endif - if (ISS%hmask(i-1,j) == 1) then - cnt = cnt+1 - Dx =dxh+ G%dxT(i-1,j) - sx = sx - S(i-1,j) - else - sx = sx - S(i,j) - endif - if (cnt == 0) then - sx = 0 - else - sx = sx / ( Dx) - endif - endif - - cnt = 0 - ! calculate sy, similarly - if ((j+j_off) == gjsc) then ! at south computational bdry - if (ISS%hmask(i,j+1) == 1) then - sy = (S(i,j+1)-S(i,j))/dyh - else - sy = 0 - endif - elseif ((j+j_off) == gjec) then ! at nprth computational bdry - if (ISS%hmask(i,j-1) == 1) then - sy = (S(i,j)-S(i,j-1))/dyh - else - sy = 0 + if (ISS%hmask(i,j) == 1 .or. ISS%hmask(i,j) == 3) then + ! we are inside the global computational bdry, at an ice-filled cell + + ! Calculate the x-direction surface slope at tracer points. + sx = 0.0 + valid_E = (ISS%hmask(i+1,j) == 1 .or. ISS%hmask(i+1,j) == 3) + valid_W = (ISS%hmask(i-1,j) == 1 .or. ISS%hmask(i-1,j) == 3) + if (CS%shelf_top_slope_bugs) then + if (((i+i_off) == gisc) .and. (.not.CS%reentrant_x)) then ! at west computational bdry + if (valid_E) sx = (S(i+1,j)-S(i,j)) / G%dxT(i,j) + elseif (((i+i_off) == giec) .and. (.not.CS%reentrant_x)) then ! at east computational bdry + if (valid_W) sx = (S(i,j)-S(i-1,j)) / G%dxT(i,j) + elseif (valid_E .and. valid_W) then + ! This is the usual interior point + sx = (S(i+1,j) - S(i-1,j)) / (G%dxT(i,j) + G%dxT(i-1,j)) + elseif (valid_E) then + sx = (S(i+1,j) - S(i,j)) / (G%dxT(i,j) + G%dxT(i+1,j)) + elseif (valid_W) then + sx = (S(i,j) - S(i-1,j)) / (G%dxT(i,j) + G%dxT(i-1,j)) endif - else ! interior - if (ISS%hmask(i,j+1) == 1) then - cnt = cnt+1 - Dy =dyh+ G%dyT(i,j+1) - sy = S(i,j+1) - else - sy = S(i,j) - endif - if (ISS%hmask(i,j-1) == 1) then - cnt = cnt+1 - sy = sy - S(i,j-1) - Dy =dyh+ G%dyT(i,j-1) - else - sy = sy - S(i,j) - endif - if (cnt == 0) then - sy = 0 - else - sy = sy / (Dy) + else ! Correct the bugs in the version above. + if (((i+i_off) == gisc) .and. (.not.CS%reentrant_x)) then ! at west computational bdry + if (valid_E) sx = (S(i+1,j) - S(i,j)) * G%IdxCu(I,j) + elseif (((i+i_off) == giec) .and. (.not.CS%reentrant_x)) then ! at east computational bdry + if (valid_W) sx = (S(i,j) - S(i-1,j)) * G%IdxCu(I-1,j) + elseif (valid_E .and. valid_W) then + ! This is the usual interior point + sx = 0.5*(S(i+1,j) - S(i-1,j)) * G%IdxT(i,j) + elseif (valid_E) then ! Use a one-sided estimate from the east. + sx = (S(i+1,j) - S(i,j)) * G%IdxCu(I,j) + elseif (valid_W) then ! Use a one-sided estimate from the west. + sx = (S(i,j) - S(i-1,j)) * G%IdxCu(I-1,j) endif endif - ! SW vertex - if (ISS%hmask(I-1,J-1) == 1) then - taudx(I-1,J-1) = taudx(I-1,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) - taudy(I-1,J-1) = taudy(I-1,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) + ! Calculate the y-direction surface slope at tracer points. + sy = 0.0 + valid_N = (ISS%hmask(i,j+1) == 1 .or. ISS%hmask(i,j+1) == 3) + valid_S = (ISS%hmask(i,j-1) == 1 .or. ISS%hmask(i,j-1) == 3) + if (CS%shelf_top_slope_bugs) then + if (((j+j_off) == gjsc) .and. (.not. CS%reentrant_y)) then ! at south computational bdry + if (valid_N) sy = (S(i,j+1)-S(i,j)) / G%dyT(i,j) + elseif (((j+j_off) == gjec) .and. (.not. CS%reentrant_y)) then ! at north computational bdry + if (valid_S) sy = (S(i,j)-S(i,j-1)) / G%dyT(i,j) + elseif (valid_N .and. valid_S) then + ! This is the usual interior point + sy = (S(i,j+1) - S(i,j-1)) / (G%dyT(i,j) + G%dyT(i,j-1)) + elseif (valid_N) then + sy = (S(i,j+1) - S(i,j)) / (G%dyT(i,j) + G%dyT(i,j+1)) + elseif (valid_S) then + sy = (S(i,j) - S(i,j-1)) / (G%dyT(i,j) + G%dyT(i,j-1)) endif - ! SE vertex - if (ISS%hmask(I,J-1) == 1) then - taudx(I,J-1) = taudx(I,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) - taudy(I,J-1) = taudy(I,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) + else ! Correct the bugs in the version above. + if (((j+j_off) == gjsc) .and. (.not. CS%reentrant_y)) then ! at south computational bdry + if (valid_N) sy = (S(i,j+1) - S(i,j)) * G%IdyCv(i,J) + elseif (((j+j_off) == gjec) .and. (.not. CS%reentrant_y)) then ! at north computational bdry + if (valid_S) sy = (S(i,j) - S(i,j-1)) * G%IdyCv(i,J-1) + elseif (valid_N .and. valid_S) then + ! This is the usual interior point + sy = 0.5*(S(i,j+1) - S(i,j-1)) * G%IdyT(i,j) + elseif (valid_N) then ! Use a one-sided estimate from the north. + sy = (S(i,j+1) - S(i,j)) * G%IdyCv(i,J) + elseif (valid_S) then ! Use a one-sided estimate from the south. + sy = (S(i,j) - S(i,j-1)) * G%IdyCv(i,J-1) endif - ! NW vertex - if (ISS%hmask(I-1,J) == 1) then - taudx(I-1,J) = taudx(I-1,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) - taudy(I-1,J) = taudy(I-1,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) endif - ! NE vertex - if (ISS%hmask(I,J) == 1) then - taudx(I,J) = taudx(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) - taudy(I,J) = taudy(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) + + if (CS%max_surface_slope>0) then + scale = CS%max_surface_slope / max( sqrt((sx**2) + (sy**2)), CS%max_surface_slope ) + sx = scale*sx ; sy = scale*sy endif + + sx_e(i,j) = (-.25 * G%areaT(i,j)) * ((rho * grav) * (max(ISS%h_shelf(i,j),CS%min_h_shelf) * sx)) + sy_e(i,j) = (-.25 * G%areaT(i,j)) * ((rho * grav) * (max(ISS%h_shelf(i,j),CS%min_h_shelf) * sy)) + + CS%sx_shelf(i,j) = sx ; CS%sy_shelf(i,j) = sy + + !Stress (Neumann) boundary conditions if (CS%ground_frac(i,j) == 1) then -! neumann_val = (.5 * grav * (rho * ISS%h_shelf(i,j)**2 - rhow * CS%bed_elev(i,j)**2)) - neumann_val = .5 * grav * (1-rho/rhow) * rho * ISS%h_shelf(i,j)**2 + neumann_val = ((.5 * grav) * (rho * max(ISS%h_shelf(i,j),CS%min_h_shelf)**2 - rhow * CS%bed_elev(i,j)**2)) else - neumann_val = (.5 * grav * (1-rho/rhow) * rho * ISS%h_shelf(i,j)**2) + neumann_val = (.5 * grav) * ((1-rho/rhow) * (rho * max(ISS%h_shelf(i,j),CS%min_h_shelf)**2)) endif - - if ((CS%u_face_mask(I-1,j) == 2) .OR. (ISS%hmask(i-1,j) == 0) .OR. (ISS%hmask(i-1,j) == 2) ) then + if ((CS%u_face_mask_bdry(I-1,j) == 2) .OR. & + ((ISS%hmask(i-1,j) == 0 .OR. ISS%hmask(i-1,j) == 2) .AND. (CS%reentrant_x .OR. (i+i_off /= gisc)))) then ! left face of the cell is at a stress boundary ! the depth-integrated longitudinal stress is equal to the difference of depth-integrated ! pressure on either side of the face @@ -1971,105 +3204,48 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) ! is not above the base of the ice in the current cell ! Note the negative sign due to the direction of the normal vector - taudx(I-1,J-1) = taudx(I-1,J-1) - .5 * dyh * neumann_val - taudx(I-1,J) = taudx(I-1,J) - .5 * dyh * neumann_val + taudx(I-1,J-1) = taudx(I-1,J-1) - .5 * G%dyT(i,j) * neumann_val + taudx(I-1,J) = taudx(I-1,J) - .5 * G%dyT(i,j) * neumann_val endif - if ((CS%u_face_mask(I,j) == 2) .OR. (ISS%hmask(i+1,j) == 0) .OR. (ISS%hmask(i+1,j) == 2) ) then + if ((CS%u_face_mask_bdry(I,j) == 2) .OR. & + ((ISS%hmask(i+1,j) == 0 .OR. ISS%hmask(i+1,j) == 2) .and. (CS%reentrant_x .OR. (i+i_off /= giec)))) then ! east face of the cell is at a stress boundary - taudx(I,J-1) = taudx(I,J-1) + .5 * dyh * neumann_val - taudx(I,J) = taudx(I,J) + .5 * dyh * neumann_val + taudx(I,J-1) = taudx(I,J-1) + .5 * G%dyT(i,j) * neumann_val + taudx(I,J) = taudx(I,J) + .5 * G%dyT(i,j) * neumann_val endif - if ((CS%v_face_mask(i,J-1) == 2) .OR. (ISS%hmask(i,j-1) == 0) .OR. (ISS%hmask(i,j-1) == 2) ) then + if ((CS%v_face_mask_bdry(i,J-1) == 2) .OR. & + ((ISS%hmask(i,j-1) == 0 .OR. ISS%hmask(i,j-1) == 2) .and. (CS%reentrant_y .OR. (j+j_off /= gjsc)))) then ! south face of the cell is at a stress boundary - taudy(I-1,J-1) = taudy(I-1,J-1) - .5 * dxh * neumann_val - taudy(I,J-1) = taudy(I,J-1) - .5 * dxh * neumann_val + taudy(I-1,J-1) = taudy(I-1,J-1) - .5 * G%dxT(i,j) * neumann_val + taudy(I,J-1) = taudy(I,J-1) - .5 * G%dxT(i,j) * neumann_val endif - if ((CS%v_face_mask(i,J) == 2) .OR. (ISS%hmask(i,j+1) == 0) .OR. (ISS%hmask(i,j+1) == 2) ) then + if ((CS%v_face_mask_bdry(i,J) == 2) .OR. & + ((ISS%hmask(i,j+1) == 0 .OR. ISS%hmask(i,j+1) == 2) .and. (CS%reentrant_y .OR. (j+j_off /= gjec)))) then ! north face of the cell is at a stress boundary - taudy(I-1,J) = taudy(I-1,J) + .5 * dxh * neumann_val - taudy(I,J) = taudy(I,J) + .5 * dxh * neumann_val + taudy(I-1,J) = taudy(I-1,J) + .5 * G%dxT(i,j) * neumann_val + taudy(I,J) = taudy(I,J) + .5 * G%dxT(i,j) * neumann_val endif - + else ! This is not an ice-filled cell, so zero out the slopes here + CS%sx_shelf(i,j) = 0.0 ; CS%sy_shelf(i,j) = 0.0 + sx_e(i,j) = 0.0 + sy_e(i,j) = 0.0 endif enddo enddo -end subroutine calc_shelf_driving_stress - -subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new_sim) - type(ice_shelf_dyn_CS),intent(inout) :: CS !< A pointer to the ice shelf control structure - type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. - type(time_type), intent(in) :: Time !< The current model time - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: hmask !< A mask indicating which tracer points are - !! partly or fully covered by an ice-shelf - real, intent(in) :: input_flux !< The integrated inward ice thickness flux per - !! unit face length [Z L T-1 ~> m2 s-1] - real, intent(in) :: input_thick !< The ice thickness at boundaries [Z ~> m]. - logical, optional, intent(in) :: new_sim !< If present and false, this run is being restarted - -! this will be a per-setup function. the boundary values of thickness and velocity -! (and possibly other variables) will be updated in this function - -! FOR RESTARTING PURPOSES: if grid is not symmetric and the model is restarted, we will -! need to update those velocity points not *technically* in any -! computational domain -- if this function gets moves to another module, -! DO NOT TAKE THE RESTARTING BIT WITH IT - integer :: i, j , isd, jsd, ied, jed - integer :: gjec, gisc, gjsc, cnt, isc, jsc, iec, jec - integer :: i_off, j_off - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed - i_off = G%idg_offset ; j_off = G%jdg_offset - - ! this loop results in some values being set twice but... eh. - - do j=jsd,jed - do i=isd,ied - - if (hmask(i,j) == 3) then - CS%thickness_bdry_val(i,j) = input_thick - endif - - if ((hmask(i,j) == 0) .or. (hmask(i,j) == 1) .or. (hmask(i,j) == 2)) then - if ((i <= iec).and.(i >= isc)) then - if (CS%u_face_mask(I-1,j) == 3) then - CS%u_bdry_val(I-1,J-1) = (1 - ((G%geoLatBu(I-1,J-1) - 0.5*G%len_lat)*2./G%len_lat)**2) * & - 1.5 * input_flux / input_thick - CS%u_bdry_val(I-1,J) = (1 - ((G%geoLatBu(I-1,J) - 0.5*G%len_lat)*2./G%len_lat)**2) * & - 1.5 * input_flux / input_thick - endif - endif - endif - - if (.not.(new_sim)) then - if (.not. G%symmetric) then - if (((i+i_off) == (G%domain%nihalo+1)).and.(CS%u_face_mask(I-1,j) == 3)) then - CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) - CS%u_shelf(I-1,J) = CS%u_bdry_val(I-1,J) - CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) - CS%v_shelf(I-1,J) = CS%v_bdry_val(I-1,J) - endif - if (((j+j_off) == (G%domain%njhalo+1)).and.(CS%v_face_mask(i,J-1) == 3)) then - CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) - CS%u_shelf(I,J-1) = CS%u_bdry_val(I,J-1) - CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) - CS%v_shelf(I,J-1) = CS%v_bdry_val(I,J-1) - endif - endif - endif - enddo - enddo - -end subroutine init_boundary_values + do J=jsc-1,jec ; do I=isc-1,iec + taudx(I,J) = taudx(I,J) + ((sx_e(i,j)+sx_e(i+1,j+1)) + (sx_e(i+1,j)+sx_e(i,j+1))) + taudy(I,J) = taudy(I,J) + ((sy_e(i,j)+sy_e(i+1,j+1)) + (sy_e(i+1,j)+sy_e(i,j+1))) + enddo ; enddo +end subroutine calc_shelf_driving_stress -subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmask, H_node, & - ice_visc, float_cond, bathyT, basal_trac, G, US, is, ie, js, je, dens_ratio) +subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmask, H_node, & + ice_visc, float_cond, bathyT, basal_trac, G, US, is, ie, js, je, dens_ratio, use_newton_in) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & intent(inout) :: uret !< The retarding stresses working at u-points [R L3 Z T-2 ~> kg m s-2]. @@ -2097,19 +3273,18 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDI_(G),SZDJ_(G),CS%visc_qps), & intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's - !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form - !! and units depend on the basal law exponent. + !! flow law [R L4 Z T-1 ~> kg m2 s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: float_cond !< An array indicating where the ice - !! shelf is floating: 0 if floating, 1 if not. + intent(in) :: float_cond !< If GL_regularize=true, an array indicating where the ice + !! shelf is floating: 0 if floating, 1 if not real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points !! relative to sea-level [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: basal_trac !< A field related to the nonlinear part of the - !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. + intent(in) :: basal_trac !< Area-integrated taub_beta field related to the nonlinear + !! part of the "linearized" basal stress [R Z L2 T-1 ~> kg s-1]. real, intent(in) :: dens_ratio !< The density of ice divided by the density !! of seawater, nondimensional @@ -2118,6 +3293,7 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas integer, intent(in) :: ie !< The ending i-index to work on integer, intent(in) :: js !< The starting j-index to work on integer, intent(in) :: je !< The ending j-index to work on + logical, optional, intent(in) :: use_newton_in !< If present, overrides CS%doing_newton for Newton correction ! the linear action of the matrix on (u,v) with bilinear finite elements ! as of now everything is passed in so no grid pointers or anything of the sort have to be dereferenced, @@ -2140,86 +3316,199 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas real :: ux, uy, vx, vy ! Components of velocity shears or divergence [T-1 ~> s-1] real :: uq, vq ! Interpolated velocities [L T-1 ~> m s-1] - integer :: iq, jq, iphi, jphi, i, j, ilq, jlq, Itgt, Jtgt - real, dimension(2) :: xquad - real, dimension(2,2) :: Ucell, Vcell, Hcell, Usub, Vsub + real :: strx_n, stry_n, strsh_n, dstrain_n, inner_dot_n ! Newton correction variables [T-1 ~> s-1], [T-2 ~> s-2] + real :: jac_wt ! Per-quadrature-point metric correction |J_q|/areaT [nondim] + integer :: iq, jq, iphi, jphi, i, j, ilq, jlq, Itgt, Jtgt, qp, qpv + logical :: visc_qp4 + logical :: use_newton ! Whether to apply Newton tangent stiffness corrections + logical :: do_newton_visc ! Whether to apply viscosity-related Newton tangent stiffness corrections + real, dimension(2) :: xquad ! Nondimensional quadrature ratios [nondim] + real, dimension(2,2) :: Ucell, Vcell, Usub, Vsub ! Velocities at the nodal points around the cell [L T-1 ~> m s-1] + real, dimension(2,2) :: Hcell ! Ice shelf thickness at notal (corner) points [Z ~> m] + real, dimension(2,2,4) :: uret_qp, vret_qp ! Temporary arrays in [R Z L3 T-2 ~> kg m s-2] + real, dimension(SZDIB_(G),SZDJB_(G),4) :: uret_b, vret_b ! Temporary arrays in [R Z L3 T-2 ~> kg m s-2] xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) - do j=js,je ; do i=is,ie ; if (hmask(i,j) == 1) then + if (CS%visc_qps == 4) then + visc_qp4=.true. + else + visc_qp4=.false. + qpv = 1 + endif + + use_newton = CS%doing_newton + if (present(use_newton_in)) use_newton = use_newton_in + do_newton_visc = use_newton .and. trim(CS%ice_viscosity_compute) == "MODEL" + + uret(:,:) = 0.0 ; vret(:,:) = 0.0 + uret_b(:,:,:) = 0.0 ; vret_b(:,:,:) = 0.0 + + do j=js,je ; do i=is,ie ; if (hmask(i,j) == 1 .or. hmask(i,j)==3) then + + uret_qp(:,:,:) = 0.0 ; vret_qp(:,:,:) = 0.0 + + do iq=1,2 ; do jq=1,2 + + qp = 2*(jq-1)+iq !current quad point + + uq = ((u_shlf(I-1,J-1) * (xquad(3-iq) * xquad(3-jq))) + & + (u_shlf(I,J) * (xquad(iq) * xquad(jq)))) + & + ((u_shlf(I,J-1) * (xquad(iq) * xquad(3-jq))) + & + (u_shlf(I-1,J) * (xquad(3-iq) * xquad(jq)))) + + vq = ((v_shlf(I-1,J-1) * (xquad(3-iq) * xquad(3-jq))) + & + (v_shlf(I,J) * (xquad(iq) * xquad(jq)))) + & + ((v_shlf(I,J-1) * (xquad(iq) * xquad(3-jq))) + & + (v_shlf(I-1,J) * (xquad(3-iq) * xquad(jq)))) + + ux = ((u_shlf(I-1,J-1) * Phi(1,qp,i,j)) + & + (u_shlf(I,J) * Phi(7,qp,i,j))) + & + ((u_shlf(I,J-1) * Phi(3,qp,i,j)) + & + (u_shlf(I-1,J) * Phi(5,qp,i,j))) + + vx = ((v_shlf(I-1,J-1) * Phi(1,qp,i,j)) + & + (v_shlf(I,J) * Phi(7,qp,i,j))) + & + ((v_shlf(I,J-1) * Phi(3,qp,i,j)) + & + (v_shlf(I-1,J) * Phi(5,qp,i,j))) + + uy = ((u_shlf(I-1,J-1) * Phi(2,qp,i,j)) + & + (u_shlf(I,J) * Phi(8,qp,i,j))) + & + ((u_shlf(I,J-1) * Phi(4,qp,i,j)) + & + (u_shlf(I-1,J) * Phi(6,qp,i,j))) + + vy = ((v_shlf(I-1,J-1) * Phi(2,qp,i,j)) + & + (v_shlf(I,J) * Phi(8,qp,i,j))) + & + ((v_shlf(I,J-1) * Phi(4,qp,i,j)) + & + (v_shlf(I-1,J) * Phi(6,qp,i,j))) + + if (visc_qp4) qpv = qp !current quad point for viscosity + + ! Newton correction: compute dstrain scalar once per quadrature point + if (do_newton_visc) then + strx_n = CS%newton_str_ux(i,j,qpv) + stry_n = CS%newton_str_vy(i,j,qpv) + strsh_n = CS%newton_str_sh(i,j,qpv) + dstrain_n = (((2.*strx_n + stry_n)*ux) + ((2.*stry_n + strx_n)*vy)) + & + strsh_n * (uy + vx) * 0.5 + endif - do iq=1,2 ; do jq=1,2 + ! Newton correction for basal drag: compute inner_dot_n once per quadrature point + if (use_newton) then + inner_dot_n = (CS%newton_umid(i,j)*uq) + (CS%newton_vmid(i,j)*vq) + endif - uq = u_shlf(I-1,J-1) * xquad(3-iq) * xquad(3-jq) + & - u_shlf(I,J-1) * xquad(iq) * xquad(3-jq) + & - u_shlf(I-1,J) * xquad(3-iq) * xquad(jq) + & - u_shlf(I,J) * xquad(iq) * xquad(jq) - - vq = v_shlf(I-1,J-1) * xquad(3-iq) * xquad(3-jq) + & - v_shlf(I,J-1) * xquad(iq) * xquad(3-jq) + & - v_shlf(I-1,J) * xquad(3-iq) * xquad(jq) + & - v_shlf(I,J) * xquad(iq) * xquad(jq) - - ux = u_shlf(I-1,J-1) * Phi(1,2*(jq-1)+iq,i,j) + & - u_shlf(I,J-1) * Phi(3,2*(jq-1)+iq,i,j) + & - u_shlf(I-1,J) * Phi(5,2*(jq-1)+iq,i,j) + & - u_shlf(I,J) * Phi(7,2*(jq-1)+iq,i,j) - - vx = v_shlf(I-1,J-1) * Phi(1,2*(jq-1)+iq,i,j) + & - v_shlf(I,J-1) * Phi(3,2*(jq-1)+iq,i,j) + & - v_shlf(I-1,J) * Phi(5,2*(jq-1)+iq,i,j) + & - v_shlf(I,J) * Phi(7,2*(jq-1)+iq,i,j) - - uy = u_shlf(I-1,J-1) * Phi(2,2*(jq-1)+iq,i,j) + & - u_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j) + & - u_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & - u_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j) - - vy = v_shlf(I-1,j-1) * Phi(2,2*(jq-1)+iq,i,j) + & - v_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j) + & - v_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & - v_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j) - - do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; ;Jtgt = J-2+jphi - if (umask(Itgt,Jtgt) == 1) uret(Itgt,Jtgt) = uret(Itgt,Jtgt) + 0.25 * ice_visc(i,j) * & - ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq,i,j) + & - (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq,i,j)) - if (vmask(Itgt,Jtgt) == 1) vret(Itgt,Jtgt) = vret(Itgt,Jtgt) + 0.25 * ice_visc(i,j) * & - ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq,i,j) + & - (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq,i,j)) + ! Ratio |J_q|/areaT corrects the uniform-area weight baked into ice_visc for + ! non-rectangular elements where opposite cell edges have unequal lengths. + jac_wt = CS%Jac(qp,i,j) * G%IareaT(i,j) + + do jphi=1,2 ; Jtgt = J-2+jphi ; do iphi=1,2 ; Itgt = I-2+iphi + if (umask(Itgt,Jtgt) == 1) uret_qp(iphi,jphi,qp) = jac_wt * ice_visc(i,j,qpv) * & + (((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + & + ((uy+vx) * Phi(2*(2*(jphi-1)+iphi),qp,i,j))) + if (vmask(Itgt,Jtgt) == 1) vret_qp(iphi,jphi,qp) = jac_wt * ice_visc(i,j,qpv) * & + (((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + & + ((4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),qp,i,j))) + + ! Newton tangent stiffness correction: add (dη/dε_e^2) * (g·δε) * (g·φ_m) term + if (do_newton_visc) then + if (umask(Itgt,Jtgt) == 1) uret_qp(iphi,jphi,qp) = uret_qp(iphi,jphi,qp) + & + jac_wt * CS%newton_visc_factor(i,j,qpv) * dstrain_n * & + (((2.*strx_n + stry_n) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + & + (strsh_n * 0.5 * Phi(2*(2*(jphi-1)+iphi),qp,i,j))) + if (vmask(Itgt,Jtgt) == 1) vret_qp(iphi,jphi,qp) = vret_qp(iphi,jphi,qp) + & + jac_wt * CS%newton_visc_factor(i,j,qpv) * dstrain_n * & + ((strsh_n * 0.5 * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + & + ((2.*stry_n + strx_n) * Phi(2*(2*(jphi-1)+iphi),qp,i,j))) + endif if (float_cond(i,j) == 0) then ilq = 1 ; if (iq == iphi) ilq = 2 jlq = 1 ; if (jq == jphi) jlq = 2 - if (umask(Itgt,Jtgt) == 1) uret(Itgt,Jtgt) = uret(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * uq * xquad(ilq) * xquad(jlq) - if (vmask(Itgt,Jtgt) == 1) vret(Itgt,Jtgt) = vret(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * vq * xquad(ilq) * xquad(jlq) + if (umask(Itgt,Jtgt) == 1) uret_qp(iphi,jphi,qp) = uret_qp(iphi,jphi,qp) + & + (jac_wt * (basal_trac(i,j) * uq) * (xquad(ilq) * xquad(jlq))) + if (vmask(Itgt,Jtgt) == 1) vret_qp(iphi,jphi,qp) = vret_qp(iphi,jphi,qp) + & + (jac_wt * (basal_trac(i,j) * vq) * (xquad(ilq) * xquad(jlq))) + ! Newton basal drag tangent stiffness: (m-1)*basal_trac/|u|^2 * u_i * (u . delta_u) contribution + if (use_newton) then + if (umask(Itgt,Jtgt) == 1) uret_qp(iphi,jphi,qp) = uret_qp(iphi,jphi,qp) + & + jac_wt * CS%newton_drag_coef(i,j) * CS%newton_umid(i,j) * inner_dot_n * (xquad(ilq) * xquad(jlq)) + if (vmask(Itgt,Jtgt) == 1) vret_qp(iphi,jphi,qp) = vret_qp(iphi,jphi,qp) + & + jac_wt * CS%newton_drag_coef(i,j) * CS%newton_vmid(i,j) * inner_dot_n * (xquad(ilq) * xquad(jlq)) + endif endif enddo ; enddo enddo ; enddo + !element contribution to SW node (node 1, which sees the current element as element 4) + uret_b(I-1,J-1,4) = 0.25*((uret_qp(1,1,1)+uret_qp(1,1,4))+(uret_qp(1,1,2)+uret_qp(1,1,3))) + vret_b(I-1,J-1,4) = 0.25*((vret_qp(1,1,1)+vret_qp(1,1,4))+(vret_qp(1,1,2)+vret_qp(1,1,3))) + + !element contribution to NW node (node 3, which sees the current element as element 2) + uret_b(I-1,J ,2) = 0.25*((uret_qp(1,2,1)+uret_qp(1,2,4))+(uret_qp(1,2,2)+uret_qp(1,2,3))) + vret_b(I-1,J ,2) = 0.25*((vret_qp(1,2,1)+vret_qp(1,2,4))+(vret_qp(1,2,2)+vret_qp(1,2,3))) + + !element contribution to SE node (node 2, which sees the current element as element 3) + uret_b(I ,J-1,3) = 0.25*((uret_qp(2,1,1)+uret_qp(2,1,4))+(uret_qp(2,1,2)+uret_qp(2,1,3))) + vret_b(I ,J-1,3) = 0.25*((vret_qp(2,1,1)+vret_qp(2,1,4))+(vret_qp(2,1,2)+vret_qp(2,1,3))) + + !element contribution to NE node (node 4, which sees the current element as element 1) + uret_b(I ,J ,1) = 0.25*((uret_qp(2,2,1)+uret_qp(2,2,4))+(uret_qp(2,2,2)+uret_qp(2,2,3))) + vret_b(I ,J ,1) = 0.25*((vret_qp(2,2,1)+vret_qp(2,2,4))+(vret_qp(2,2,2)+vret_qp(2,2,3))) + if (float_cond(i,j) == 1) then Ucell(:,:) = u_shlf(I-1:I,J-1:J) ; Vcell(:,:) = v_shlf(I-1:I,J-1:J) - Hcell(:,:) = H_node(i-1:i,j-1:j) - call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, bathyT(i,j), dens_ratio, Usub, Vsub) - - if (umask(I-1,J-1)==1) uret(I-1,J-1) = uret(I-1,J-1) + Usub(1,1) * basal_trac(i,j) - if (umask(I-1,J) == 1) uret(I-1,J) = uret(I-1,J) + Usub(1,2) * basal_trac(i,j) - if (umask(I,J-1) == 1) uret(I,J-1) = uret(I,J-1) + Usub(2,1) * basal_trac(i,j) - if (umask(I,J) == 1) uret(I,J) = uret(I,J) + Usub(2,2) * basal_trac(i,j) - - if (vmask(I-1,J-1)==1) vret(I-1,J-1) = vret(I-1,J-1) + Vsub(1,1) * basal_trac(i,j) - if (vmask(I-1,J) == 1) vret(I-1,J) = vret(I-1,J) + Vsub(1,2) * basal_trac(i,j) - if (vmask(I,J-1) == 1) vret(I,J-1) = vret(I,J-1) + Vsub(2,1) * basal_trac(i,j) - if (vmask(I,J) == 1) vret(I,J) = vret(I,J) + Vsub(2,2) * basal_trac(i,j) + Hcell(:,:) = H_node(I-1:I,J-1:J) + + call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, & + bathyT(i,j), dens_ratio, Usub, Vsub, & + G%dxCv(i,j-1), G%dxCv(i,j), G%dyCu(i-1,j), G%dyCu(i,j), G%IareaT(i,j)) + + if (umask(I-1,J-1) == 1) uret_b(I-1,J-1,4) = uret_b(I-1,J-1,4) + (Usub(1,1) * basal_trac(i,j)) + if (umask(I-1,J ) == 1) uret_b(I-1,J ,2) = uret_b(I-1,J ,2) + (Usub(1,2) * basal_trac(i,j)) + if (umask(I ,J-1) == 1) uret_b(I ,J-1,3) = uret_b(I ,J-1,3) + (Usub(2,1) * basal_trac(i,j)) + if (umask(I ,J ) == 1) uret_b(I ,J ,1) = uret_b(I ,J ,1) + (Usub(2,2) * basal_trac(i,j)) + + if (vmask(I-1,J-1) == 1) vret_b(I-1,J-1,4) = vret_b(I-1,J-1,4) + (Vsub(1,1) * basal_trac(i,j)) + if (vmask(I-1,J ) == 1) vret_b(I-1,J ,2) = vret_b(I-1,J ,2) + (Vsub(1,2) * basal_trac(i,j)) + if (vmask(I ,J-1) == 1) vret_b(I ,J-1,3) = vret_b(I ,J-1,3) + (Vsub(2,1) * basal_trac(i,j)) + if (vmask(I ,J ) == 1) vret_b(I ,J ,1) = vret_b(I ,J ,1) + (Vsub(2,2) * basal_trac(i,j)) + + ! Newton basal drag correction for subgrid grounding line cells. + ! inner_dot_sub(m,n) = sum over grounded sub-QPs of (u^k . delta_u) * phi_{m,n} * weight + ! = newton_umid * Usub(m,n) + newton_vmid * Vsub(m,n) + ! Correction to u-node (m,n): newton_drag_coef * newton_umid * inner_dot_sub(m,n) + ! Correction to v-node (m,n): newton_drag_coef * newton_vmid * inner_dot_sub(m,n) + if (use_newton) then + if (umask(I-1,J-1)==1) uret_b(I-1,J-1,4) = uret_b(I-1,J-1,4) + CS%newton_drag_coef(i,j) * & + CS%newton_umid(i,j) * ((CS%newton_umid(i,j)*Usub(1,1)) + (CS%newton_vmid(i,j)*Vsub(1,1))) + if (umask(I-1,J )==1) uret_b(I-1,J ,2) = uret_b(I-1,J ,2) + CS%newton_drag_coef(i,j) * & + CS%newton_umid(i,j) * ((CS%newton_umid(i,j)*Usub(1,2)) + (CS%newton_vmid(i,j)*Vsub(1,2))) + if (umask(I ,J-1)==1) uret_b(I ,J-1,3) = uret_b(I ,J-1,3) + CS%newton_drag_coef(i,j) * & + CS%newton_umid(i,j) * ((CS%newton_umid(i,j)*Usub(2,1)) + (CS%newton_vmid(i,j)*Vsub(2,1))) + if (umask(I ,J )==1) uret_b(I ,J ,1) = uret_b(I ,J ,1) + CS%newton_drag_coef(i,j) * & + CS%newton_umid(i,j) * ((CS%newton_umid(i,j)*Usub(2,2)) + (CS%newton_vmid(i,j)*Vsub(2,2))) + if (vmask(I-1,J-1)==1) vret_b(I-1,J-1,4) = vret_b(I-1,J-1,4) + CS%newton_drag_coef(i,j) * & + CS%newton_vmid(i,j) * ((CS%newton_umid(i,j)*Usub(1,1)) + (CS%newton_vmid(i,j)*Vsub(1,1))) + if (vmask(I-1,J )==1) vret_b(I-1,J ,2) = vret_b(I-1,J ,2) + CS%newton_drag_coef(i,j) * & + CS%newton_vmid(i,j) * ((CS%newton_umid(i,j)*Usub(1,2)) + (CS%newton_vmid(i,j)*Vsub(1,2))) + if (vmask(I ,J-1)==1) vret_b(I ,J-1,3) = vret_b(I ,J-1,3) + CS%newton_drag_coef(i,j) * & + CS%newton_vmid(i,j) * ((CS%newton_umid(i,j)*Usub(2,1)) + (CS%newton_vmid(i,j)*Vsub(2,1))) + if (vmask(I ,J )==1) vret_b(I ,J ,1) = vret_b(I ,J ,1) + CS%newton_drag_coef(i,j) * & + CS%newton_vmid(i,j) * ((CS%newton_umid(i,j)*Usub(2,2)) + (CS%newton_vmid(i,j)*Vsub(2,2))) + endif endif - endif ; enddo ; enddo + do J=js-1,je ; do I=is-1,ie + uret(I,J) = (uret_b(I,J,1)+uret_b(I,J,4)) + (uret_b(I,J,2)+uret_b(I,J,3)) + vret(I,J) = (vret_b(I,J,1)+vret_b(I,J,4)) + (vret_b(I,J,2)+vret_b(I,J,3)) + enddo ; enddo + end subroutine CG_action -subroutine CG_action_subgrid_basal(Phisub, H, U, V, bathyT, dens_ratio, Ucontr, Vcontr) +subroutine CG_action_subgrid_basal(Phisub, H, U, V, bathyT, dens_ratio, Ucontr, Vcontr, & + dxCv_S, dxCv_N, dyCu_W, dyCu_E, IareaT) real, dimension(:,:,:,:,:,:), & intent(in) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] @@ -2234,58 +3523,136 @@ subroutine CG_action_subgrid_basal(Phisub, H, U, V, bathyT, dens_ratio, Ucontr, !! is grounded, or 0 where it is floating [L T-1 ~> m s-1]. real, dimension(2,2), intent(out) :: Vcontr !< The areal average of v-velocities where the ice shelf !! is grounded, or 0 where it is floating [L T-1 ~> m s-1]. - - real :: subarea ! The fractional sub-cell area [nondim] - real :: hloc ! The local sub-cell ice thickness [Z ~> m] + real, intent(in) :: dxCv_S !< The cell width at the southern (v-point) edge [L ~> m] + real, intent(in) :: dxCv_N !< The cell width at the northern (v-point) edge [L ~> m] + real, intent(in) :: dyCu_W !< The cell height at the western (u-point) edge [L ~> m] + real, intent(in) :: dyCu_E !< The cell height at the eastern (u-point) edge [L ~> m] + real, intent(in) :: IareaT !< The inverse of the cell area at the tracer point [L-2 ~> m-2] + + real, dimension(SIZE(Phisub,3),SIZE(Phisub,3),2,2) :: Ucontr_sub, Vcontr_sub ! The contributions to Ucontr and Vcontr + !! at each sub-cell + real, dimension(2,2,SIZE(Phisub,3),SIZE(Phisub,3)) :: uloc_arr !The local sub-cell u-velocity [L T-1 ~> m s-1] + real, dimension(2,2,SIZE(Phisub,3),SIZE(Phisub,3)) :: vloc_arr !The local sub-cell v-velocity [L T-1 ~> m s-1] + real, dimension(2,2) :: Ucontr_q, Vcontr_q !Contributions to a node from each quadrature point in a sub-grid cell + real :: jac_sub_wt ! Per-sub-cell-QP metric correction |J_sub|/areaT [nondim] + real :: a, d ! Interpolated cell-edge spacings at the sub-cell QP [L ~> m] + real :: subarea ! The fractional sub-cell area in reference space [nondim] + real :: hloc ! The local sub-cell ice thickness [Z ~> m] integer :: nsub, i, j, qx, qy, m, n - nsub = size(Phisub,1) - subarea = 1.0 / (nsub**2) + nsub = size(Phisub,3) + subarea = 1.0 / real(nsub)**2 + + uloc_arr(:,:,:,:) = 0.0 ; vloc_arr(:,:,:,:)=0.0 + + do j=1,nsub ; do i=1,nsub ; do qy=1,2 ; do qx=1,2 + hloc = ((Phisub(qx,qy,i,j,1,1)*H(1,1)) + (Phisub(qx,qy,i,j,2,2)*H(2,2))) + & + ((Phisub(qx,qy,i,j,1,2)*H(1,2)) + (Phisub(qx,qy,i,j,2,1)*H(2,1))) + if (dens_ratio * hloc - bathyT > 0) then + uloc_arr(qx,qy,i,j) = (((Phisub(qx,qy,i,j,1,1) * U(1,1)) + (Phisub(qx,qy,i,j,2,2) * U(2,2))) + & + ((Phisub(qx,qy,i,j,1,2) * U(1,2)) + (Phisub(qx,qy,i,j,2,1) * U(2,1)))) + vloc_arr(qx,qy,i,j) = (((Phisub(qx,qy,i,j,1,1) * V(1,1)) + (Phisub(qx,qy,i,j,2,2) * V(2,2))) + & + ((Phisub(qx,qy,i,j,1,2) * V(1,2)) + (Phisub(qx,qy,i,j,2,1) * V(2,1)))) + endif + enddo ; enddo ; enddo ; enddo + + do n=1,2 ; do m=1,2 ; do j=1,nsub ; do i=1,nsub + do qy=1,2 ; do qx=1,2 + ! Interpolate cell-edge metrics to the sub-cell QP using the bilinear shape function values + ! from bilinear_shape_functions_subgrid. Marginal sums of Phisub give the interpolation + ! weights: sum over k=1 nodes gives (1-y); k=2 gives y; l=1 gives (1-x); l=2 gives x. + ! This is analogous to jac_wt = CS%Jac(qp,i,j) * G%IareaT(i,j) in the regular routines. + a = dxCv_S * (Phisub(qx,qy,i,j,1,1) + Phisub(qx,qy,i,j,2,1)) + & ! (1-y) * dxCv_S + dxCv_N * (Phisub(qx,qy,i,j,1,2) + Phisub(qx,qy,i,j,2,2)) ! + y * dxCv_N + d = dyCu_W * (Phisub(qx,qy,i,j,1,1) + Phisub(qx,qy,i,j,1,2)) + & ! (1-x) * dyCu_W + dyCu_E * (Phisub(qx,qy,i,j,2,1) + Phisub(qx,qy,i,j,2,2)) ! + x * dyCu_E + jac_sub_wt = 0.25 * subarea * (a * d) * IareaT + + !calculate quadrature point contributions for the sub-cell, to each node + Ucontr_q(qx,qy) = jac_sub_wt * Phisub(qx,qy,i,j,m,n) * uloc_arr(qx,qy,i,j) + Vcontr_q(qx,qy) = jac_sub_wt * Phisub(qx,qy,i,j,m,n) * vloc_arr(qx,qy,i,j) + enddo ; enddo + + !calculate sub-cell contribution to each node by summing up quadrature point contributions from the sub-cell + Ucontr_sub(i,j,m,n) = (Ucontr_q(1,1) + Ucontr_q(2,2)) + (Ucontr_q(1,2)+Ucontr_q(2,1)) + Vcontr_sub(i,j,m,n) = (Vcontr_q(1,1) + Vcontr_q(2,2)) + (Vcontr_q(1,2)+Vcontr_q(2,1)) + enddo ; enddo ; enddo ; enddo + !sum up the sub-cell contributions to each node do n=1,2 ; do m=1,2 - Ucontr(m,n) = 0.0 ; Vcontr(m,n) = 0.0 - do qy=1,2 ; do qx=1,2 ; do j=1,nsub ; do i=1,nsub - hloc = (Phisub(i,j,1,1,qx,qy)*H(1,1) + Phisub(i,j,2,2,qx,qy)*H(2,2)) + & - (Phisub(i,j,1,2,qx,qy)*H(1,2) + Phisub(i,j,2,1,qx,qy)*H(2,1)) - if (dens_ratio * hloc - bathyT > 0) then - Ucontr(m,n) = Ucontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * & - ((Phisub(i,j,1,1,qx,qy) * U(1,1) + Phisub(i,j,2,2,qx,qy) * U(2,2)) + & - (Phisub(i,j,1,2,qx,qy) * U(1,2) + Phisub(i,j,2,1,qx,qy) * U(2,1))) - Vcontr(m,n) = Vcontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * & - ((Phisub(i,j,1,1,qx,qy) * V(1,1) + Phisub(i,j,2,2,qx,qy) * V(2,2)) + & - (Phisub(i,j,1,2,qx,qy) * V(1,2) + Phisub(i,j,2,1,qx,qy) * V(2,1))) - endif - enddo ; enddo ; enddo ; enddo + call sum_square_matrix(Ucontr(m,n),Ucontr_sub(:,:,m,n),nsub) + call sum_square_matrix(Vcontr(m,n),Vcontr_sub(:,:,m,n),nsub) enddo ; enddo end subroutine CG_action_subgrid_basal + +!! Returns the sum of the elements in a square matrix. This sum is bitwise identical even if the matrices are rotated. +subroutine sum_square_matrix(sum_out, mat_in, n) + integer, intent(in) :: n !< The length and width of each matrix in mat_in + real, dimension(n,n), intent(in) :: mat_in !< The n x n matrix whose elements will be summed + real, intent(out) :: sum_out !< The sum of the elements of matrix mat_in + integer :: s0, e0, s1, e1 + + sum_out = 0.0 + + s0 = 1 ; e0 = n + + !start by summing elements on outer edges of matrix + do while (s0 returns the diagonal entries of the matrix for a Jacobi preconditioning subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, hmask, dens_ratio, & - Phisub, u_diagonal, v_diagonal) + Phi, Phisub, u_diagonal, v_diagonal) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: float_cond !< An array indicating where the ice - !! shelf is floating: 0 if floating, 1 if not. + intent(in) :: float_cond !< If GL_regularize=true, indicates cells containing + !! the grounding line (float_cond=1) or not (float_cond=0) real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: H_node !< The ice shelf thickness at nodal !! (corner) points [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDI_(G),SZDJ_(G),CS%visc_qps), & intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's - !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form - !! and units depend on the basal law exponent. + !! flow law [R L4 Z T-1 ~> kg m2 s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: basal_trac !< A field related to the nonlinear part of the - !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. - + intent(in) :: basal_trac !< Area-integrated taub_beta field related to the nonlinear + !! part of the "linearized" basal stress [R L3 T-1 ~> kg s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf real, intent(in) :: dens_ratio !< The density of ice divided by the density !! of seawater [nondim] + real, dimension(8,4,SZDI_(G),SZDJ_(G)), & + intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian + !! quadrature points surrounding the cell vertices [L-1 ~> m-1] real, dimension(:,:,:,:,:,:), intent(in) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] real, dimension(SZDIB_(G),SZDJB_(G)), & @@ -2300,78 +3667,192 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, real :: ux, uy, vx, vy ! Interpolated weight gradients [L-1 ~> m-1] real :: uq, vq - real, dimension(8,4) :: Phi ! Weight gradients [L-1 ~> m-1] + real :: jac_wt ! Per-quadrature-point metric correction |J_q|/areaT [nondim] + real :: strx_n, stry_n, strsh_n ! Newton viscosity strain rates [T-1 ~> s-1] + real :: dstrain_diag_u, dstrain_diag_v ! Newton viscosity diagonal correction factors [T-1 L-1 ~> s-1 m-1] + real :: phi_m_sq ! Squared basis function value at quadrature point [nondim] real, dimension(2) :: xquad real, dimension(2,2) :: Hcell, sub_ground - integer :: i, j, is, js, cnt, isc, jsc, iec, jec, iphi, jphi, iq, jq, ilq, jlq, Itgt, Jtgt + real, dimension(2,2,4) :: u_diag_qp, v_diag_qp + real, dimension(SZDIB_(G),SZDJB_(G),4) :: u_diag_b, v_diag_b + logical :: do_newton_visc ! Whether to apply viscosity-related Newton tangent stiffness corrections + logical :: visc_qp4 + integer :: i, j, isc, jsc, iec, jec, iphi, jphi, iq, jq, ilq, jlq, Itgt, Jtgt, qp, qpv isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) - do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) == 1) then + if (CS%visc_qps == 4) then + visc_qp4=.true. + else + visc_qp4=.false. + qpv = 1 + endif + + do_newton_visc = CS%doing_newton .and. trim(CS%ice_viscosity_compute) == "MODEL" - call bilinear_shape_fn_grid(G, i, j, Phi) + u_diag_b(:,:,:)=0.0 + v_diag_b(:,:,:)=0.0 + + do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) == 1 .or. hmask(i,j)==3) then ! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j ! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j - do iq=1,2 ; do jq=1,2 ; do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; Jtgt = J-2+jphi - ilq = 1 ; if (iq == iphi) ilq = 2 - jlq = 1 ; if (jq == jphi) jlq = 2 + u_diag_qp(:,:,:) = 0.0 ; v_diag_qp(:,:,:) = 0.0 - if (CS%umask(Itgt,Jtgt) == 1) then + do iq=1,2 ; do jq=1,2 - ux = Phi(2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) - uy = Phi(2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) - vx = 0. - vy = 0. + qp = 2*(jq-1)+iq !current quad point + if (visc_qp4) qpv = qp !current quad point for viscosity - u_diagonal(Itgt,Jtgt) = u_diagonal(Itgt,Jtgt) + & - 0.25 * ice_visc(i,j) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + ! Ratio |J_q|/areaT corrects the uniform-area weight baked into ice_visc for + ! non-rectangular elements where opposite cell edges have unequal lengths. + jac_wt = CS%Jac(qp,i,j) * G%IareaT(i,j) - if (float_cond(i,j) == 0) then - uq = xquad(ilq) * xquad(jlq) - u_diagonal(Itgt,Jtgt) = u_diagonal(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * uq * xquad(ilq) * xquad(jlq) - endif + ! Pre-compute Newton strain data for this QP (for viscosity diagonal correction) + if (do_newton_visc) then + strx_n = CS%newton_str_ux(i,j,qpv) + stry_n = CS%newton_str_vy(i,j,qpv) + strsh_n = CS%newton_str_sh(i,j,qpv) endif - if (CS%vmask(Itgt,Jtgt) == 1) then + do jphi=1,2 ; Jtgt = J-2+jphi ; do iphi=1,2 ; Itgt = I-2+iphi - vx = Phi(2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) - vy = Phi(2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) - ux = 0. - uy = 0. + ilq = 1 ; if (iq == iphi) ilq = 2 + jlq = 1 ; if (jq == jphi) jlq = 2 + phi_m_sq = (xquad(ilq) * xquad(jlq))**2 - v_diagonal(Itgt,Jtgt) = v_diagonal(Itgt,Jtgt) + & - 0.25 * ice_visc(i,j) * ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + if (CS%umask(Itgt,Jtgt) == 1) then + + ux = Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j) + uy = Phi(2*(2*(jphi-1)+iphi),qp,i,j) + vx = 0. + vy = 0. + + u_diag_qp(iphi,jphi,qp) = jac_wt * & + ice_visc(i,j,qpv) * (((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + & + ((uy+vx) * Phi(2*(2*(jphi-1)+iphi),qp,i,j))) + + ! Newton viscosity diagonal correction: newton_visc_factor * (g . grad_phi_m_u)^2 + ! where grad_phi_m_u = [(2*strx+stry)*Phi_xm + strsh/2*Phi_ym] for u-DOF at node m + if (do_newton_visc) then + dstrain_diag_u = ((2.*strx_n + stry_n) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + & + (strsh_n * 0.5 * Phi(2*(2*(jphi-1)+iphi),qp,i,j)) + u_diag_qp(iphi,jphi,qp) = u_diag_qp(iphi,jphi,qp) + & + jac_wt * CS%newton_visc_factor(i,j,qpv) * dstrain_diag_u**2 + endif - if (float_cond(i,j) == 0) then - vq = xquad(ilq) * xquad(jlq) - v_diagonal(Itgt,Jtgt) = v_diagonal(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * vq * xquad(ilq) * xquad(jlq) + if (float_cond(i,j) == 0) then + uq = xquad(ilq) * xquad(jlq) + u_diag_qp(iphi,jphi,qp) = u_diag_qp(iphi,jphi,qp) + & + jac_wt * (basal_trac(i,j) * uq) * (xquad(ilq) * xquad(jlq)) + ! Newton basal drag diagonal correction: newton_drag_coef * (umid_i)^2 * phi_m^2 + if (CS%doing_newton) then + u_diag_qp(iphi,jphi,qp) = u_diag_qp(iphi,jphi,qp) + & + jac_wt * CS%newton_drag_coef(i,j) * CS%newton_umid(i,j)**2 * phi_m_sq + endif + endif endif - endif - enddo ; enddo ; enddo ; enddo + + if (CS%vmask(Itgt,Jtgt) == 1) then + + vx = Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j) + vy = Phi(2*(2*(jphi-1)+iphi),qp,i,j) + ux = 0. + uy = 0. + + v_diag_qp(iphi,jphi,qp) = jac_wt * & + ice_visc(i,j,qpv) * (((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + & + ((4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),qp,i,j))) + + ! Newton viscosity diagonal correction for v-DOF: uses [strsh/2*Phi_xm + (2*stry+strx)*Phi_ym] + if (do_newton_visc) then + dstrain_diag_v = (strsh_n * 0.5 * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j)) + & + ((2.*stry_n + strx_n) * Phi(2*(2*(jphi-1)+iphi),qp,i,j)) + v_diag_qp(iphi,jphi,qp) = v_diag_qp(iphi,jphi,qp) + & + jac_wt * CS%newton_visc_factor(i,j,qpv) * dstrain_diag_v**2 + endif + + if (float_cond(i,j) == 0) then + vq = xquad(ilq) * xquad(jlq) + v_diag_qp(iphi,jphi,qp) = v_diag_qp(iphi,jphi,qp) + & + jac_wt * (basal_trac(i,j) * vq) * (xquad(ilq) * xquad(jlq)) + ! Newton basal drag diagonal correction: newton_drag_coef * (vmid_i)^2 * phi_m^2 + if (CS%doing_newton) then + v_diag_qp(iphi,jphi,qp) = v_diag_qp(iphi,jphi,qp) + & + jac_wt * CS%newton_drag_coef(i,j) * CS%newton_vmid(i,j)**2 * phi_m_sq + endif + endif + endif + enddo ; enddo + enddo ; enddo + + !element contribution to SW node (node 1, which sees the current element as element 4) + u_diag_b(I-1,J-1,4) = 0.25*((u_diag_qp(1,1,1)+u_diag_qp(1,1,4))+(u_diag_qp(1,1,2)+u_diag_qp(1,1,3))) + v_diag_b(I-1,J-1,4) = 0.25*((v_diag_qp(1,1,1)+v_diag_qp(1,1,4))+(v_diag_qp(1,1,2)+v_diag_qp(1,1,3))) + + !element contribution to NW node (node 3, which sees the current element as element 2) + u_diag_b(I-1,J ,2) = 0.25*((u_diag_qp(1,2,1)+u_diag_qp(1,2,4))+(u_diag_qp(1,2,2)+u_diag_qp(1,2,3))) + v_diag_b(I-1,J ,2) = 0.25*((v_diag_qp(1,2,1)+v_diag_qp(1,2,4))+(v_diag_qp(1,2,2)+v_diag_qp(1,2,3))) + + !element contribution to SE node (node 2, which sees the current element as element 3) + u_diag_b(I ,J-1,3) = 0.25*((u_diag_qp(2,1,1)+u_diag_qp(2,1,4))+(u_diag_qp(2,1,2)+u_diag_qp(2,1,3))) + v_diag_b(I ,J-1,3) = 0.25*((v_diag_qp(2,1,1)+v_diag_qp(2,1,4))+(v_diag_qp(2,1,2)+v_diag_qp(2,1,3))) + + !element contribution to NE node (node 4, which sees the current element as element 1) + u_diag_b(I ,J ,1) = 0.25*((u_diag_qp(2,2,1)+u_diag_qp(2,2,4))+(u_diag_qp(2,2,2)+u_diag_qp(2,2,3))) + v_diag_b(I ,J ,1) = 0.25*((v_diag_qp(2,2,1)+v_diag_qp(2,2,4))+(v_diag_qp(2,2,2)+v_diag_qp(2,2,3))) if (float_cond(i,j) == 1) then Hcell(:,:) = H_node(i-1:i,j-1:j) - call CG_diagonal_subgrid_basal(Phisub, Hcell, CS%bed_elev(i,j), dens_ratio, sub_ground) - do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; Jtgt = J-2+jphi - if (CS%umask(Itgt,Jtgt) == 1) then - u_diagonal(Itgt,Jtgt) = u_diagonal(Itgt,Jtgt) + sub_ground(iphi,jphi) * basal_trac(i,j) - v_diagonal(Itgt,Jtgt) = v_diagonal(Itgt,Jtgt) + sub_ground(iphi,jphi) * basal_trac(i,j) + call CG_diagonal_subgrid_basal(Phisub, Hcell, CS%bed_elev(i,j), dens_ratio, sub_ground, & + G%dxCv(i,j-1), G%dxCv(i,j), G%dyCu(i-1,j), G%dyCu(i,j), G%IareaT(i,j)) + + if (CS%umask(I-1,J-1) == 1) u_diag_b(I-1,J-1,4) = u_diag_b(I-1,J-1,4) + (sub_ground(1,1) * basal_trac(i,j)) + if (CS%umask(I-1,J ) == 1) u_diag_b(I-1,J ,2) = u_diag_b(I-1,J ,2) + (sub_ground(1,2) * basal_trac(i,j)) + if (CS%umask(I ,J-1) == 1) u_diag_b(I ,J-1,3) = u_diag_b(I ,J-1,3) + (sub_ground(2,1) * basal_trac(i,j)) + if (CS%umask(I ,J ) == 1) u_diag_b(I ,J ,1) = u_diag_b(I ,J ,1) + (sub_ground(2,2) * basal_trac(i,j)) + + if (CS%vmask(I-1,J-1) == 1) v_diag_b(I-1,J-1,4) = v_diag_b(I-1,J-1,4) + (sub_ground(1,1) * basal_trac(i,j)) + if (CS%vmask(I-1,J ) == 1) v_diag_b(I-1,J ,2) = v_diag_b(I-1,J ,2) + (sub_ground(1,2) * basal_trac(i,j)) + if (CS%vmask(I ,J-1) == 1) v_diag_b(I ,J-1,3) = v_diag_b(I ,J-1,3) + (sub_ground(2,1) * basal_trac(i,j)) + if (CS%vmask(I ,J ) == 1) v_diag_b(I ,J ,1) = v_diag_b(I ,J ,1) + (sub_ground(2,2) * basal_trac(i,j)) + + ! Newton basal drag diagonal correction for subgrid grounding line cells. + ! sub_ground(m,n) = sum over grounded sub-QPs of phi_{m,n}^2 * weight, computed by + ! CG_diagonal_subgrid_basal. Newton diagonal = newton_drag_coef * umid^2 * sub_ground (for u-block). + if (CS%doing_newton) then + if (CS%umask(I-1,J-1)==1) u_diag_b(I-1,J-1,4) = u_diag_b(I-1,J-1,4) + & + CS%newton_drag_coef(i,j) * CS%newton_umid(i,j)**2 * sub_ground(1,1) + if (CS%umask(I-1,J )==1) u_diag_b(I-1,J ,2) = u_diag_b(I-1,J ,2) + & + CS%newton_drag_coef(i,j) * CS%newton_umid(i,j)**2 * sub_ground(1,2) + if (CS%umask(I ,J-1)==1) u_diag_b(I ,J-1,3) = u_diag_b(I ,J-1,3) + & + CS%newton_drag_coef(i,j) * CS%newton_umid(i,j)**2 * sub_ground(2,1) + if (CS%umask(I ,J )==1) u_diag_b(I ,J ,1) = u_diag_b(I ,J ,1) + & + CS%newton_drag_coef(i,j) * CS%newton_umid(i,j)**2 * sub_ground(2,2) + if (CS%vmask(I-1,J-1)==1) v_diag_b(I-1,J-1,4) = v_diag_b(I-1,J-1,4) + & + CS%newton_drag_coef(i,j) * CS%newton_vmid(i,j)**2 * sub_ground(1,1) + if (CS%vmask(I-1,J )==1) v_diag_b(I-1,J ,2) = v_diag_b(I-1,J ,2) + & + CS%newton_drag_coef(i,j) * CS%newton_vmid(i,j)**2 * sub_ground(1,2) + if (CS%vmask(I ,J-1)==1) v_diag_b(I ,J-1,3) = v_diag_b(I ,J-1,3) + & + CS%newton_drag_coef(i,j) * CS%newton_vmid(i,j)**2 * sub_ground(2,1) + if (CS%vmask(I ,J )==1) v_diag_b(I ,J ,1) = v_diag_b(I ,J ,1) + & + CS%newton_drag_coef(i,j) * CS%newton_vmid(i,j)**2 * sub_ground(2,2) endif - enddo ; enddo endif endif ; enddo ; enddo + do J=jsc-2,jec+1 ; do I=isc-2,iec+1 + u_diagonal(I,J) = (u_diag_b(I,J,1)+u_diag_b(I,J,4)) + (u_diag_b(I,J,2)+u_diag_b(I,J,3)) + v_diagonal(I,J) = (v_diag_b(I,J,1)+v_diag_b(I,J,4)) + (v_diag_b(I,J,2)+v_diag_b(I,J,3)) + enddo ; enddo + end subroutine matrix_diagonal -subroutine CG_diagonal_subgrid_basal (Phisub, H_node, bathyT, dens_ratio, sub_grnd) +subroutine CG_diagonal_subgrid_basal(Phisub, H_node, bathyT, dens_ratio, f_grnd, & + dxCv_S, dxCv_N, dyCu_W, dyCu_E, IareaT) real, dimension(:,:,:,:,:,:), & intent(in) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] @@ -2380,180 +3861,196 @@ subroutine CG_diagonal_subgrid_basal (Phisub, H_node, bathyT, dens_ratio, sub_gr real, intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points [Z ~> m]. real, intent(in) :: dens_ratio !< The density of ice divided by the density !! of seawater [nondim] - real, dimension(2,2), intent(out) :: sub_grnd !< The weighted fraction of the sub-cell where the ice shelf - !! is grounded [nondim] - - ! bathyT = cellwise-constant bed elevation - - real :: subarea ! The fractional sub-cell area [nondim] - real :: hloc ! The local sub-region thickness [Z ~> m] - integer :: nsub, i, j, k, l, qx, qy, m, n - - nsub = size(Phisub,1) - subarea = 1.0 / (nsub**2) - - sub_grnd(:,:) = 0.0 - do m=1,2 ; do n=1,2 ; do j=1,nsub ; do i=1,nsub ; do qx=1,2 ; do qy = 1,2 - - hloc = (Phisub(i,j,1,1,qx,qy)*H_node(1,1) + Phisub(i,j,2,2,qx,qy)*H_node(2,2)) + & - (Phisub(i,j,1,2,qx,qy)*H_node(1,2) + Phisub(i,j,2,1,qx,qy)*H_node(2,1)) + real, dimension(2,2), intent(out) :: f_grnd !< The weighted fraction of the sub-cell where the ice shelf + !! is grounded [nondim] + real, intent(in) :: dxCv_S !< The cell width at the southern (v-point) edge [L ~> m] + real, intent(in) :: dxCv_N !< The cell width at the northern (v-point) edge [L ~> m] + real, intent(in) :: dyCu_W !< The cell height at the western (u-point) edge [L ~> m] + real, intent(in) :: dyCu_E !< The cell height at the eastern (u-point) edge [L ~> m] + real, intent(in) :: IareaT !< The inverse of the cell area at the tracer point [L-2 ~> m-2] + + real, dimension(SIZE(Phisub,3),SIZE(Phisub,3),2,2) :: f_grnd_sub ! The contributions to nodal f_grnd + !! from each sub-cell + integer, dimension(2,2,SIZE(Phisub,3),SIZE(Phisub,3)) :: grnd_stat !0 at floating quad points, 1 at grounded + real, dimension(2,2) :: f_grnd_q !Contributions to a node from each quadrature point in a sub-grid cell + real :: jac_sub_wt ! Per-sub-cell-QP metric correction |J_sub|/areaT [nondim] + real :: a, d ! Interpolated cell-edge spacings at the sub-cell QP [L ~> m] + real :: subarea ! The fractional sub-cell area in reference space [nondim] + real :: hloc ! The local sub-region thickness [Z ~> m] + integer :: nsub, i, j, qx, qy, m, n - if (dens_ratio * hloc - bathyT > 0) then - sub_grnd(m,n) = sub_grnd(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy)**2 - endif + nsub = size(Phisub,3) + subarea = 1.0 / real(nsub)**2 + + grnd_stat(:,:,:,:)=0 + + do j=1,nsub ; do i=1,nsub ; do qy=1,2 ; do qx=1,2 + hloc = ((Phisub(qx,qy,i,j,1,1)*H_node(1,1)) + (Phisub(qx,qy,i,j,2,2)*H_node(2,2))) + & + ((Phisub(qx,qy,i,j,1,2)*H_node(1,2)) + (Phisub(qx,qy,i,j,2,1)*H_node(2,1))) + if (dens_ratio * hloc - bathyT > 0) grnd_stat(qx,qy,i,j) = 1 + enddo ; enddo ; enddo ; enddo + + do n=1,2 ; do m=1,2 ; do j=1,nsub ; do i=1,nsub + do qy=1,2 ; do qx = 1,2 + ! Interpolate cell-edge metrics to the sub-cell QP using the bilinear shape function values + ! from bilinear_shape_functions_subgrid. Marginal sums of Phisub give the interpolation + ! weights: sum over k=1 nodes gives (1-y); k=2 gives y; l=1 gives (1-x); l=2 gives x. + ! This is analogous to jac_wt = CS%Jac(qp,i,j) * G%IareaT(i,j) in the regular routines. + a = dxCv_S * (Phisub(qx,qy,i,j,1,1) + Phisub(qx,qy,i,j,2,1)) + & ! (1-y) * dxCv_S + dxCv_N * (Phisub(qx,qy,i,j,1,2) + Phisub(qx,qy,i,j,2,2)) ! + y * dxCv_N + d = dyCu_W * (Phisub(qx,qy,i,j,1,1) + Phisub(qx,qy,i,j,1,2)) + & ! (1-x) * dyCu_W + dyCu_E * (Phisub(qx,qy,i,j,2,1) + Phisub(qx,qy,i,j,2,2)) ! + x * dyCu_E + jac_sub_wt = 0.25 * subarea * (a * d) * IareaT + + f_grnd_q(qx,qy) = jac_sub_wt * grnd_stat(qx,qy,i,j) * Phisub(qx,qy,i,j,m,n)**2 + enddo ; enddo + !calculate sub-cell contribution to each node by summing up quadrature point contributions from the sub-cell + f_grnd_sub(i,j,m,n) = (f_grnd_q(1,1) + f_grnd_q(2,2)) + (f_grnd_q(1,2)+f_grnd_q(2,1)) + enddo ; enddo ; enddo ; enddo - enddo ; enddo ; enddo ; enddo ; enddo ; enddo + !sum up the sub-cell contributions to each node + do n=1,2 ; do m=1,2 + call sum_square_matrix(f_grnd(m,n),f_grnd_sub(:,:,m,n),nsub) + enddo ; enddo end subroutine CG_diagonal_subgrid_basal - -subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, basal_trac, float_cond, & - dens_ratio, u_bdry_contr, v_bdry_contr) - - type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure +!> Post_data calls related to ice-sheet flux divergence, strain-rate, and deviatoric stress +subroutine IS_dynamics_post_data_2(CS, ISS, G) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe !! the ice-shelf state type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. - type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors - type(time_type), intent(in) :: Time !< The current model time - real, dimension(:,:,:,:,:,:), & - intent(in) :: Phisub !< Quadrature structure weights at subgridscale - !! locations for finite element calculations [nondim] - real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: H_node !< The ice shelf thickness at nodal - !! (corner) points [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's - !! flow law. The exact form and units depend on the - !! basal law exponent. [R L4 Z T-1 ~> kg m2 s-1]. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: basal_trac !< A field related to the nonlinear part of the - !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. + real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thickness at corners [Z ~> m]. + real, dimension(SZDIB_(G),SZDJB_(G)) :: Hu ! Ice shelf u_flux at corners [Z L T-1 ~> m2 s-1]. + real, dimension(SZDIB_(G),SZDJB_(G)) :: Hv ! Ice shelf v_flux at corners [Z L T-1 ~> m2 s-1]. + real, dimension(SZDI_(G),SZDJ_(G)) :: Hux ! Ice shelf d(u_flux)/dx at cell centers [Z T-1 ~> m s-1]. + real, dimension(SZDI_(G),SZDJ_(G)) :: Hvy ! Ice shelf d(v_flux)/dy at cell centers [Z T-1 ~> m s-1]. + real, dimension(SZDI_(G),SZDJ_(G)) :: flux_div ! horizontal flux divergence div(uH) [Z T-1 ~> m s-1]. + real, dimension(SZDI_(G),SZDJ_(G),3) :: strain_rate ! strain-rate components xx,yy, and xy [T-1 ~> s-1] + real, dimension(SZDI_(G),SZDJ_(G),2) :: p_strain_rate ! horizontal principal strain-rates [T-1 ~> s-1] + real, dimension(SZDI_(G),SZDJ_(G),3) :: dev_stress ! deviatoric stress components xx,yy, and xy [R L Z T-2 ~> Pa] + real, dimension(SZDI_(G),SZDJ_(G),2) :: p_dev_stress ! horizontal principal deviatoric stress [R L Z T-2 ~> Pa] + real, dimension(SZDI_(G),SZDJ_(G)) :: ice_visc ! area-averaged ice viscosity [R L2 T-1 ~> Pa s] + real :: p1,p2 ! Used to calculate strain-rate principal components [T-1 ~> s-1] + integer :: i, j - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: float_cond !< An array indicating where the ice - !! shelf is floating: 0 if floating, 1 if not. - real, intent(in) :: dens_ratio !< The density of ice divided by the density - !! of seawater, nondimensional - real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: u_bdry_contr !< Zonal force contributions due to the - !! open boundaries [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: v_bdry_contr !< Meridional force contributions due to the - !! open boundaries [R L3 Z T-2 ~> kg m s-2] + !Allocate the gradient basis functions for 1 cell-centered quadrature point per cell + if (.not. associated(CS%PhiC)) then + allocate(CS%PhiC(1:8,G%isc:G%iec,G%jsc:G%jec), source=0.0) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + call bilinear_shape_fn_grid_1qp(G, i, j, CS%PhiC(:,i,j)) + enddo ; enddo + endif -! this will be a per-setup function. the boundary values of thickness and velocity -! (and possibly other variables) will be updated in this function + !Calculate flux divergence and its components + if (CS%id_duHdx > 0 .or. CS%id_dvHdy > 0 .or. CS%id_fluxdiv > 0) then + call interpolate_H_to_B(G, ISS%h_shelf, ISS%hmask, H_node, CS%min_h_shelf) - real, dimension(8,4) :: Phi - real, dimension(2) :: xquad - real :: ux, uy, vx, vy ! Components of velocity shears or divergence [T-1 ~> s-1] - real :: uq, vq ! Interpolated velocities [L T-1 ~> m s-1] - real :: area - real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr - integer :: i, j, isc, jsc, iec, jec, iq, jq, iphi, jphi, ilq, jlq, Itgt, Jtgt + Hu(:,:) = 0.0 ; Hv(:,:) = 0.0 ; Hux(:,:) = 0.0 ; Hvy(:,:) = 0.0 ; flux_div(:,:) = 0.0 + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + if (CS%umask(I,J) > 0) then + Hu(I,J) = (H_node(I,J) * CS%u_shelf(I,J)) + endif + if (CS%vmask(I,J) > 0) then + Hv(I,J) = (H_node(I,J) * CS%v_shelf(I,J)) + endif + enddo ; enddo - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 3)) then + !components of flux divergence at cell centers + Hux(i,j) = (((Hu(I-1,J-1) * CS%PhiC(1,i,j)) + (Hu(I,J ) * CS%PhiC(7,i,j))) + & + ((Hu(I-1,J ) * CS%PhiC(5,i,j)) + (Hu(I,J-1) * CS%PhiC(3,i,j)))) + + Hvy(i,j) = (((Hv(I-1,J-1) * CS%PhiC(2,i,j)) + (Hv(I,J ) * CS%PhiC(8,i,j))) + & + ((Hv(I-1,J ) * CS%PhiC(6,i,j)) + (Hv(I,J-1) * CS%PhiC(4,i,j)))) + flux_div(i,j) = Hux(i,j) + Hvy(i,j) + endif + enddo ; enddo - xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) + if (CS%id_duHdx > 0) call post_data(CS%id_duHdx, Hux, CS%diag) + if (CS%id_dvHdy > 0) call post_data(CS%id_dvHdy, Hvy, CS%diag) + if (CS%id_fluxdiv > 0) call post_data(CS%id_fluxdiv, flux_div, CS%diag) + endif - do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (ISS%hmask(i,j) == 1) then + if (CS%id_devstress_xx > 0 .or. CS%id_devstress_yy > 0 .or. CS%id_devstress_xy > 0 .or. & + CS%id_strainrate_xx > 0 .or. CS%id_strainrate_yy > 0 .or. CS%id_strainrate_xy > 0 .or. & + CS%id_pdevstress_1 > 0 .or. CS%id_pdevstress_2 > 0 .or. & + CS%id_pstrainrate_1 > 0 .or. CS%id_pstrainrate_2 > 0) then - ! process this cell if any corners have umask set to non-dirichlet bdry. - ! NOTE: vmask not considered, probably should be + strain_rate(:,:,:) = 0.0 + do j=G%jsc,G%jec ; do i=G%isc,G%iec + !strain-rates at cell centers + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 3)) then + !strain_rate(:,:,1) = strain_rate_xx(:,:) = ux(:,:) + strain_rate(i,j,1) = (((CS%u_shelf(I-1,J-1) * CS%PhiC(1,i,j)) + (CS%u_shelf(I,J ) * CS%PhiC(7,i,j))) + & + ((CS%u_shelf(I-1,J ) * CS%PhiC(5,i,j)) + (CS%u_shelf(I,J-1) * CS%PhiC(3,i,j)))) + !strain_rate(:,:,2) = strain_rate_yy(:,:) = uy(:,:) + strain_rate(i,j,2) = (((CS%v_shelf(I-1,J-1) * CS%PhiC(2,i,j)) + (CS%v_shelf(I,J ) * CS%PhiC(8,i,j))) + & + ((CS%v_shelf(I-1,J ) * CS%PhiC(6,i,j)) + (CS%v_shelf(I,J-1) * CS%PhiC(4,i,j)))) + !strain_rate(:,:,3) = strain_rate_xy(:,:) = 0.5 * (uy(:,:) + vy(:,:)) + strain_rate(i,j,3) = 0.5 * ((((CS%u_shelf(I-1,J-1) * CS%PhiC(2,i,j)) + (CS%u_shelf(I,J ) * CS%PhiC(8,i,j))) + & + ((CS%u_shelf(I-1,J ) * CS%PhiC(6,i,j)) + (CS%u_shelf(I,J-1) * CS%PhiC(4,i,j))))+ & + (((CS%v_shelf(I-1,J-1) * CS%PhiC(1,i,j)) + (CS%v_shelf(I,J ) * CS%PhiC(7,i,j))) + & + ((CS%v_shelf(I-1,J ) * CS%PhiC(5,i,j)) + (CS%v_shelf(I,J-1) * CS%PhiC(3,i,j))))) + endif + enddo ; enddo - if ((CS%umask(I-1,J-1) == 3) .OR. (CS%umask(I,J-1) == 3) .OR. & - (CS%umask(I-1,J) == 3) .OR. (CS%umask(I,J) == 3)) then - call bilinear_shape_fn_grid(G, i, j, Phi) + if (CS%id_strainrate_xx > 0) call post_data(CS%id_strainrate_xx, strain_rate(:,:,1), CS%diag) + if (CS%id_strainrate_yy > 0) call post_data(CS%id_strainrate_yy, strain_rate(:,:,2), CS%diag) + if (CS%id_strainrate_xy > 0) call post_data(CS%id_strainrate_xy, strain_rate(:,:,3), CS%diag) - ! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j - ! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j + if (CS%id_pstrainrate_1 > 0 .or. CS%id_pstrainrate_2 > 0 .or. & + CS%id_pdevstress_1 > 0 .or. CS%id_pdevstress_2 > 0) then + p_strain_rate(:,:,:) = 0.0 + do j=G%jsc,G%jec ; do i=G%isc,G%iec + p1 = 0.5*( strain_rate(i,j,1) + strain_rate(i,j,2)) + p2 = sqrt( (( 0.5 * (strain_rate(i,j,1) - strain_rate(i,j,2)) )**2) + (strain_rate(i,j,3)**2) ) + p_strain_rate(i,j,1) = p1+p2 !Max horizontal principal strain-rate + p_strain_rate(i,j,2) = p1-p2 !Min horizontal principal strain-rate + enddo ; enddo - do iq=1,2 ; do jq=1,2 + if (CS%id_pstrainrate_1 > 0) call post_data(CS%id_pstrainrate_1, p_strain_rate(:,:,1), CS%diag) + if (CS%id_pstrainrate_2 > 0) call post_data(CS%id_pstrainrate_2, p_strain_rate(:,:,2), CS%diag) + endif - uq = CS%u_bdry_val(I-1,J-1) * xquad(3-iq) * xquad(3-jq) + & - CS%u_bdry_val(I,J-1) * xquad(iq) * xquad(3-jq) + & - CS%u_bdry_val(I-1,J) * xquad(3-iq) * xquad(jq) + & - CS%u_bdry_val(I,J) * xquad(iq) * xquad(jq) - - vq = CS%v_bdry_val(I-1,J-1) * xquad(3-iq) * xquad(3-jq) + & - CS%v_bdry_val(I,J-1) * xquad(iq) * xquad(3-jq) + & - CS%v_bdry_val(I-1,J) * xquad(3-iq) * xquad(jq) + & - CS%v_bdry_val(I,J) * xquad(iq) * xquad(jq) - - ux = CS%u_bdry_val(I-1,J-1) * Phi(1,2*(jq-1)+iq) + & - CS%u_bdry_val(I,J-1) * Phi(3,2*(jq-1)+iq) + & - CS%u_bdry_val(I-1,J) * Phi(5,2*(jq-1)+iq) + & - CS%u_bdry_val(I,J) * Phi(7,2*(jq-1)+iq) - - vx = CS%v_bdry_val(I-1,J-1) * Phi(1,2*(jq-1)+iq) + & - CS%v_bdry_val(I,J-1) * Phi(3,2*(jq-1)+iq) + & - CS%v_bdry_val(I-1,J) * Phi(5,2*(jq-1)+iq) + & - CS%v_bdry_val(I,J) * Phi(7,2*(jq-1)+iq) - - uy = CS%u_bdry_val(I-1,J-1) * Phi(2,2*(jq-1)+iq) + & - CS%u_bdry_val(I,J-1) * Phi(4,2*(jq-1)+iq) + & - CS%u_bdry_val(I-1,J) * Phi(6,2*(jq-1)+iq) + & - CS%u_bdry_val(I,J) * Phi(8,2*(jq-1)+iq) - - vy = CS%v_bdry_val(I-1,J-1) * Phi(2,2*(jq-1)+iq) + & - CS%v_bdry_val(I,J-1) * Phi(4,2*(jq-1)+iq) + & - CS%v_bdry_val(I-1,J) * Phi(6,2*(jq-1)+iq) + & - CS%v_bdry_val(I,J) * Phi(8,2*(jq-1)+iq) - - do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; Jtgt = J-2+jphi - ilq = 1 ; if (iq == iphi) ilq = 2 - jlq = 1 ; if (jq == jphi) jlq = 2 - - if (CS%umask(Itgt,Jtgt) == 1) then - u_bdry_contr(Itgt,Jtgt) = u_bdry_contr(Itgt,Jtgt) + & - 0.25 * ice_visc(i,j) * ( (4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq) ) - - if (float_cond(i,j) == 0) then - u_bdry_contr(Itgt,Jtgt) = u_bdry_contr(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * uq * xquad(ilq) * xquad(jlq) - endif - endif + if (CS%id_devstress_xx > 0 .or. CS%id_devstress_yy > 0 .or. CS%id_devstress_xy > 0 .or. & + CS%id_pdevstress_1 > 0 .or. CS%id_pdevstress_2 > 0) then - if (CS%vmask(Itgt,Jtgt) == 1) then - v_bdry_contr(Itgt,Jtgt) = v_bdry_contr(Itgt,Jtgt) + & - 0.25 * ice_visc(i,j) * ( (uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq) ) + call ice_visc_diag(CS,G,ice_visc) - if (float_cond(i,j) == 0) then - v_bdry_contr(Itgt,Jtgt) = v_bdry_contr(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * vq * xquad(ilq) * xquad(jlq) - endif + if (CS%id_devstress_xx > 0 .or. CS%id_devstress_yy > 0 .or. CS%id_devstress_xy > 0) then + dev_stress(:,:,:)=0.0 + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (ISS%h_shelf(i,j)>0) then + dev_stress(i,j,1) = 2*ice_visc(i,j)*strain_rate(i,j,1)/ISS%h_shelf(i,j) !deviatoric stress xx + dev_stress(i,j,2) = 2*ice_visc(i,j)*strain_rate(i,j,2)/ISS%h_shelf(i,j) !deviatoric stress yy + dev_stress(i,j,3) = 2*ice_visc(i,j)*strain_rate(i,j,3)/ISS%h_shelf(i,j) !deviatoric stress xy endif enddo ; enddo - enddo ; enddo + if (CS%id_devstress_xx > 0) call post_data(CS%id_devstress_xx, dev_stress(:,:,1), CS%diag) + if (CS%id_devstress_yy > 0) call post_data(CS%id_devstress_yy, dev_stress(:,:,2), CS%diag) + if (CS%id_devstress_xy > 0) call post_data(CS%id_devstress_xy, dev_stress(:,:,3), CS%diag) + endif - if (float_cond(i,j) == 1) then - Ucell(:,:) = CS%u_bdry_val(i-1:i,j-1:j) ; Vcell(:,:) = CS%v_bdry_val(i-1:i,j-1:j) - Hcell(:,:) = H_node(i-1:i,j-1:j) - call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, CS%bed_elev(i,j), & - dens_ratio, Usubcontr, Vsubcontr) - - if (CS%umask(I-1,J-1)==1) u_bdry_contr(I-1,J-1) = u_bdry_contr(I-1,J-1) + Usubcontr(1,1) * basal_trac(i,j) - if (CS%umask(I-1,J) == 1) u_bdry_contr(I-1,J) = u_bdry_contr(I-1,J) + Usubcontr(1,2) * basal_trac(i,j) - if (CS%umask(I,J-1) == 1) u_bdry_contr(I,J-1) = u_bdry_contr(I,J-1) + Usubcontr(2,1) * basal_trac(i,j) - if (CS%umask(I,J) == 1) u_bdry_contr(I,J) = u_bdry_contr(I,J) + Usubcontr(2,2) * basal_trac(i,j) - - if (CS%vmask(I-1,J-1)==1) v_bdry_contr(I-1,J-1) = v_bdry_contr(I-1,J-1) + Vsubcontr(1,1) * basal_trac(i,j) - if (CS%vmask(I-1,J) == 1) v_bdry_contr(I-1,J) = v_bdry_contr(I-1,J) + Vsubcontr(1,2) * basal_trac(i,j) - if (CS%vmask(I,J-1) == 1) v_bdry_contr(I,J-1) = v_bdry_contr(I,J-1) + Vsubcontr(2,1) * basal_trac(i,j) - if (CS%vmask(I,J) == 1) v_bdry_contr(I,J) = v_bdry_contr(I,J) + Vsubcontr(2,2) * basal_trac(i,j) + if (CS%id_pdevstress_1 > 0 .or. CS%id_pdevstress_2 > 0) then + p_dev_stress(:,:,:)=0.0 + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (ISS%h_shelf(i,j)>0) then + p_dev_stress(i,j,1) = 2*ice_visc(i,j)*p_strain_rate(i,j,1)/ISS%h_shelf(i,j) !max horiz principal dev stress + p_dev_stress(i,j,2) = 2*ice_visc(i,j)*p_strain_rate(i,j,2)/ISS%h_shelf(i,j) !min horiz principal dev stress + endif + enddo ; enddo + if (CS%id_pdevstress_1 > 0) call post_data(CS%id_pdevstress_1, p_dev_stress(:,:,1), CS%diag) + if (CS%id_pdevstress_2 > 0) call post_data(CS%id_pdevstress_2, p_dev_stress(:,:,2), CS%diag) endif endif - endif ; enddo ; enddo - - call pass_vector(u_bdry_contr, v_bdry_contr, G%domain, TO_ALL, BGRID_NE) -end subroutine apply_boundary_values - + endif +end subroutine IS_dynamics_post_data_2 -!> Update depth integrated viscosity, based on horizontal strain rates, and also update the +!> Update depth integrated viscosity, based on horizontal strain rates subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe @@ -2564,22 +4061,18 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. - real, pointer, dimension(:,:,:,:) :: Phi => NULL() ! The gradients of bilinear basis elements at Gaussian - ! quadrature points surrounding the cell vertices [m-1]. + ! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for bilinear FEM solve -! also this subroutine updates the nonlinear part of the basal traction ! this may be subject to change later... to make it "hybrid" ! real, dimension(SZDIB_(G),SZDJB_(G)) :: eII, ux, uy, vx, vy integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq, iq, jq - integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec, is, js, i_off, j_off + integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec, is, js real :: Visc_coef, n_g real :: ux, uy, vx, vy - real :: eps_min, dxh, dyh ! Velocity shears [T-1 ~> s-1] -! real, dimension(8,4) :: Phi - real, dimension(2) :: xquad -! real :: umid, vmid, unorm ! Velocities [L T-1 ~> m s-1] + real :: eps_min ! Velocity shears [T-1 ~> s-1] + logical :: model_qp1, model_qp4 isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB @@ -2587,55 +4080,126 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) iegq = G%iegB ; jegq = G%jegB gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc - is = iscq - 1; js = jscq - 1 - i_off = G%idg_offset ; j_off = G%jdg_offset - - allocate(Phi(1:8,1:4,isd:ied,jsd:jed), source=0.0) + is = iscq - 1 ; js = jscq - 1 - do j=jsc,jec ; do i=isc,iec - call bilinear_shape_fn_grid(G, i, j, Phi(:,:,i,j)) - enddo ; enddo + if (trim(CS%ice_viscosity_compute) == "MODEL") then + if (CS%visc_qps==1) then + model_qp1=.true. + model_qp4=.false. + else + model_qp1=.false. + model_qp4=.true. + endif + endif - n_g = CS%n_glen; eps_min = CS%eps_glen_min - CS%ice_visc(:,:)=1e22 -! Visc_coef = US%kg_m2s_to_RZ_T*US%m_to_L*US%Z_to_L*(CS%A_glen_isothermal)**(-1./CS%n_glen) - do j=jsc,jec - do i=isc,iec + n_g = CS%n_glen ; eps_min = CS%eps_glen_min - if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then - Visc_coef = US%kg_m2s_to_RZ_T*US%m_to_L*US%Z_to_L*(CS%AGlen_visc(i,j))**(-1./CS%n_glen) + do j=jsc,jec ; do i=isc,iec - do iq=1,2 ; do jq=1,2 + if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then - ux = ( (u_shlf(I-1,J-1) * Phi(1,2*(jq-1)+iq,i,j) + & - u_shlf(I,J) * Phi(7,2*(jq-1)+iq,i,j)) + & - (u_shlf(I-1,J) * Phi(5,2*(jq-1)+iq,i,j) + & - u_shlf(I,J-1) * Phi(3,2*(jq-1)+iq,i,j)) ) - - vx = ( (v_shlf(I-1,J-1) * Phi(1,2*(jq-1)+iq,i,j) + & - v_shlf(I,J) * Phi(7,2*(jq-1)+iq,i,j)) + & - (v_shlf(I-1,J) * Phi(5,2*(jq-1)+iq,i,j) + & - v_shlf(I,J-1) * Phi(3,2*(jq-1)+iq,i,j)) ) - - uy = ( (u_shlf(I-1,J-1) * Phi(2,2*(jq-1)+iq,i,j) + & - u_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j)) + & - (u_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & - u_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j)) ) - - vy = ( (v_shlf(I-1,j-1) * Phi(2,2*(jq-1)+iq,i,j) + & - v_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j)) + & - (v_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & - v_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j)) ) - enddo ; enddo -! CS%ice_visc(i,j) =1e15*(G%areaT(i,j) * ISS%h_shelf(i,j)) ! constant viscocity for debugging - CS%ice_visc(i,j) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) * & - (US%s_to_T**2 * (ux**2 + vy**2 + ux*vy + 0.25*(uy+vx)**2 + eps_min**2))**((1.-n_g)/(2.*n_g)) + if (trim(CS%ice_viscosity_compute) == "CONSTANT") then + CS%ice_visc(i,j,1) = 1e15 * (US%kg_m3_to_R*US%m_to_L*US%m_s_to_L_T) * & + (G%areaT(i,j) * max(ISS%h_shelf(i,j),CS%min_h_shelf)) + ! constant viscocity for debugging + elseif (trim(CS%ice_viscosity_compute) == "OBS") then + if (CS%AGlen_visc(i,j) >0) then + CS%ice_visc(i,j,1) = (G%areaT(i,j) * max(ISS%h_shelf(i,j),CS%min_h_shelf)) * & + max(CS%AGlen_visc(i,j) ,CS%min_ice_visc) + endif + ! Here CS%Aglen_visc(i,j) is the ice viscosity [R L2 T-1 ~> Pa s] computed from obs and read from a file + elseif (model_qp1) then + ! calculate viscosity at 1 cell-centered quadrature point per cell + + Visc_coef = (CS%AGlen_visc(i,j))**(-1./n_g) + ! Units of Aglen_visc [Pa-(n_g) s-1] + + ux = ((u_shlf(I-1,J-1) * CS%PhiC(1,i,j)) + & + (u_shlf(I,J) * CS%PhiC(7,i,j))) + & + ((u_shlf(I-1,J) * CS%PhiC(5,i,j)) + & + (u_shlf(I,J-1) * CS%PhiC(3,i,j))) + + vx = ((v_shlf(I-1,J-1) * CS%PhiC(1,i,j)) + & + (v_shlf(I,J) * CS%PhiC(7,i,j))) + & + ((v_shlf(I-1,J) * CS%PhiC(5,i,j)) + & + (v_shlf(I,J-1) * CS%PhiC(3,i,j))) + + uy = ((u_shlf(I-1,J-1) * CS%PhiC(2,i,j)) + & + (u_shlf(I,J) * CS%PhiC(8,i,j))) + & + ((u_shlf(I-1,J) * CS%PhiC(6,i,j)) + & + (u_shlf(I,J-1) * CS%PhiC(4,i,j))) + + vy = ((v_shlf(I-1,J-1) * CS%PhiC(2,i,j)) + & + (v_shlf(I,J) * CS%PhiC(8,i,j))) + & + ((v_shlf(I-1,J) * CS%PhiC(6,i,j)) + & + (v_shlf(I,J-1) * CS%PhiC(4,i,j))) + + CS%ice_visc(i,j,1) = (G%areaT(i,j) * max(ISS%h_shelf(i,j),CS%min_h_shelf)) * & + max(0.5 * Visc_coef * & + (US%s_to_T**2 * (((ux**2) + (vy**2)) + ((ux*vy) + 0.25*((uy+vx)**2)) + eps_min**2))**((1.-n_g)/(2.*n_g)) * & + (US%Pa_to_RL2_T2*US%s_to_T),CS%min_ice_visc) ! Rescale after the fractional power law. + ! Store Newton tangent stiffness data: strain rates and coefficient for Newton iterations. + ! The Newton correction coefficient is (1/n-1)/2 * ice_visc / eps_e2, + ! where eps_e2 = ux^2 + vy^2 + ux*vy + (uy+vx)^2/4 + eps_min^2 [T-2]. + ! It is zero where ice_visc is limited by min_ice_visc (viscosity is not smooth there). + CS%newton_str_ux(i,j,1) = ux ; CS%newton_str_vy(i,j,1) = vy + CS%newton_str_sh(i,j,1) = uy + vx + CS%newton_visc_factor(i,j,1) = 0.0 + if (CS%ice_visc(i,j,1) > CS%min_ice_visc * (G%areaT(i,j) * max(ISS%h_shelf(i,j),CS%min_h_shelf))) then + CS%newton_visc_factor(i,j,1) = (0.5*(1./n_g - 1.) / & + (((ux**2) + (vy**2)) + ((ux*vy) + 0.25*((uy+vx)**2)) + eps_min**2)) * & + CS%ice_visc(i,j,1) + endif + elseif (model_qp4) then + !calculate viscosity at 4 quadrature points per cell + + Visc_coef = (CS%AGlen_visc(i,j))**(-1./n_g) + + do iq=1,2 ; do jq=1,2 + + ux = ((u_shlf(I-1,J-1) * CS%Phi(1,2*(jq-1)+iq,i,j)) + & + (u_shlf(I,J) * CS%Phi(7,2*(jq-1)+iq,i,j))) + & + ((u_shlf(I,J-1) * CS%Phi(3,2*(jq-1)+iq,i,j)) + & + (u_shlf(I-1,J) * CS%Phi(5,2*(jq-1)+iq,i,j))) + + vx = ((v_shlf(I-1,J-1) * CS%Phi(1,2*(jq-1)+iq,i,j)) + & + (v_shlf(I,J) * CS%Phi(7,2*(jq-1)+iq,i,j))) + & + ((v_shlf(I,J-1) * CS%Phi(3,2*(jq-1)+iq,i,j)) + & + (v_shlf(I-1,J) * CS%Phi(5,2*(jq-1)+iq,i,j))) + + uy = ((u_shlf(I-1,J-1) * CS%Phi(2,2*(jq-1)+iq,i,j)) + & + (u_shlf(I,J) * CS%Phi(8,2*(jq-1)+iq,i,j))) + & + ((u_shlf(I,J-1) * CS%Phi(4,2*(jq-1)+iq,i,j)) + & + (u_shlf(I-1,J) * CS%Phi(6,2*(jq-1)+iq,i,j))) + + vy = ((v_shlf(I-1,J-1) * CS%Phi(2,2*(jq-1)+iq,i,j)) + & + (v_shlf(I,J) * CS%Phi(8,2*(jq-1)+iq,i,j))) + & + ((v_shlf(I,J-1) * CS%Phi(4,2*(jq-1)+iq,i,j)) + & + (v_shlf(I-1,J) * CS%Phi(6,2*(jq-1)+iq,i,j))) + + CS%ice_visc(i,j,2*(jq-1)+iq) = (G%areaT(i,j) * max(ISS%h_shelf(i,j),CS%min_h_shelf)) * & + max(0.5 * Visc_coef * & + (US%s_to_T**2*(((ux**2) + (vy**2)) + ((ux*vy) + 0.25*((uy+vx)**2)) + eps_min**2))**((1.-n_g)/(2.*n_g)) * & + (US%Pa_to_RL2_T2*US%s_to_T),CS%min_ice_visc) ! Rescale after the fractional power law. + ! Store Newton tangent stiffness data at each quadrature point. + CS%newton_str_ux(i,j,2*(jq-1)+iq) = ux ; CS%newton_str_vy(i,j,2*(jq-1)+iq) = vy + CS%newton_str_sh(i,j,2*(jq-1)+iq) = uy + vx + CS%newton_visc_factor(i,j,2*(jq-1)+iq) = 0.0 + if (CS%ice_visc(i,j,2*(jq-1)+iq) > & + CS%min_ice_visc * (G%areaT(i,j) * max(ISS%h_shelf(i,j),CS%min_h_shelf))) then + CS%newton_visc_factor(i,j,2*(jq-1)+iq) = (0.5*(1./n_g - 1.) / & + (((ux**2) + (vy**2)) + ((ux*vy) + 0.25*((uy+vx)**2)) + eps_min**2)) * & + CS%ice_visc(i,j,2*(jq-1)+iq) + endif + enddo ; enddo endif - enddo - enddo - deallocate(Phi) + endif + enddo ; enddo + end subroutine calc_shelf_visc + +!> Update basal shear subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe @@ -2652,8 +4216,16 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) ! this may be subject to change later... to make it "hybrid" integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq - integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec, is, js - real :: umid, vmid, unorm, eps_min ! Velocities [L T-1 ~> m s-1] + integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec, is, js + real :: umid, vmid ! Velocities [L T-1 ~> m s-1] + real :: eps_min ! A minimal strain rate used in the Glens flow law expression [T-1 ~> s-1] + real :: unorm ! The magnitude of the velocity in mks units for use with fractional powers [m s-1] + real :: alpha ! Coulomb coefficient [nondim] + real :: Hf !"floatation thickness" for Coulomb friction [Z ~> m] + real :: fN ! Effective pressure (ice pressure - ocean pressure) for Coulomb friction [R Z L T-2 ~> Pa] + real :: fB !for Coulomb Friction [(T L-1)^CS%CF_PostPeak ~> (s m-1)^CS%CF_PostPeak] + real :: fBuq ! fB * unorm^CF_PostPeak, for Coulomb Newton correction [nondim] + real :: unorm_code2 ! Squared velocity magnitude in code units [L2 T-2 ~> m2 s-2] isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB @@ -2661,19 +4233,65 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) iegq = G%iegB ; jegq = G%jegB gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc - is = iscq - 1; js = jscq - 1 + is = iscq - 1 ; js = jscq - 1 eps_min = CS%eps_glen_min + if (CS%CoulombFriction) then + if (CS%CF_PostPeak/=1.0) THEN + alpha = (CS%CF_PostPeak-1.0)**(CS%CF_PostPeak-1.0) / CS%CF_PostPeak**CS%CF_PostPeak ![nondim] + else + alpha = 1.0 + endif + endif do j=jsd+1,jed do i=isd+1,ied + CS%newton_drag_coef(i,j) = 0.0 if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then umid = ((u_shlf(I,J) + u_shlf(I-1,J-1)) + (u_shlf(I,J-1) + u_shlf(I-1,J))) * 0.25 vmid = ((v_shlf(I,J) + v_shlf(I-1,J-1)) + (v_shlf(I,J-1) + v_shlf(I-1,J))) * 0.25 - unorm = sqrt(umid**2 + vmid**2 + eps_min**2*(G%dxT(i,j)**2 + G%dyT(i,j)**2)) -! CS%basal_traction(i,j) = G%areaT(i,j) * CS%C_basal_friction * (US%L_T_to_m_s*unorm)**(CS%n_basal_fric-1) - CS%basal_traction(i,j) = G%areaT(i,j) * CS%C_basal_friction(i,j) * (US%L_T_to_m_s*unorm)**(CS%n_basal_fric-1) + unorm_code2 = ((umid**2) + (vmid**2)) + (eps_min**2 * ((G%dxT(i,j)**2) + (G%dyT(i,j)**2))) + unorm = US%L_T_to_m_s * sqrt( unorm_code2 ) + + !Coulomb friction (Schoof 2005, Gagliardini et al 2007) + if (CS%CoulombFriction) then + !Effective pressure + Hf = max((CS%density_ocean_avg/CS%density_ice) * CS%bed_elev(i,j), 0.0) + fN = max((US%L_to_Z*(CS%density_ice * CS%g_Earth) * (max(ISS%h_shelf(i,j),CS%min_h_shelf) - Hf)), CS%CF_MinN) + fB = alpha * (CS%C_basal_friction(i,j) / (CS%CF_Max * fN))**(CS%CF_PostPeak/CS%n_basal_fric) + fBuq = fB * unorm**CS%CF_PostPeak + + CS%basal_traction(i,j) = ((G%areaT(i,j) * CS%C_basal_friction(i,j)) * & + (unorm**(CS%n_basal_fric-1.0) / (1.0 + fBuq)**(CS%n_basal_fric))) * & + US%L_T_to_m_s ! Restore the scaling after the fractional power law. + else + !linear (CS%n_basal_fric=1) or "Weertman"/power-law (CS%n_basal_fric /= 1) + fBuq = 0.0 + CS%basal_traction(i,j) = ((G%areaT(i,j) * CS%C_basal_friction(i,j)) * (unorm**(CS%n_basal_fric-1))) * & + US%L_T_to_m_s ! Rescale after the fractional power law. + endif + + CS%basal_traction(i,j)=max(CS%basal_traction(i,j), CS%min_basal_traction * G%areaT(i,j)) + + ! Store Newton basal drag data for Newton tangent stiffness correction. + ! newton_drag_coef = 2 * d(basal_trac)/d(|u|^2), + ! where d(tau_b_i)/d(u_j) = basal_trac*delta_ij + newton_drag_coef*u_i*u_j + ! This is the coefficient of the rank-1 correction u_i*(u.delta_u) to the Picard basal stiffness. + ! For Weertman: newton_drag_coef = (m-1) * basal_trac/|u|^2 + ! For Coulomb: newton_drag_coef = basal_trac/|u|^2 * [(m-1) - m*q*fB*|u|^q/(1+fB*|u|^q)] + CS%newton_umid(i,j) = umid + CS%newton_vmid(i,j) = vmid + ! unorm_code2: squared velocity magnitude in code units [L2 T-2], including regularization + ! (same expression as inside the sqrt in unorm, without US%L_T_to_m_s factor) + if (CS%CoulombFriction) then + CS%newton_drag_coef(i,j) = (1.0 / max(unorm_code2, epsilon(unorm_code2))) * & + CS%basal_traction(i,j) * ((CS%n_basal_fric - 1.) - & + CS%n_basal_fric * CS%CF_PostPeak * fBuq / (1. + fBuq)) + else + CS%newton_drag_coef(i,j) = real(CS%n_basal_fric - 1.) * CS%basal_traction(i,j) / & + max(unorm_code2, epsilon(unorm_code2)) + endif endif enddo enddo @@ -2685,7 +4303,7 @@ subroutine update_OD_ffrac(CS, G, US, ocean_mass, find_avg) type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: ocean_mass !< The mass per unit area of the ocean [kg m-2]. + intent(in) :: ocean_mass !< The mass per unit area of the ocean [R Z ~> kg m-2]. logical, intent(in) :: find_avg !< If true, find the average of OD and ffrac, and !! reset the underlying running sums to 0. @@ -2711,11 +4329,11 @@ subroutine update_OD_ffrac(CS, G, US, ocean_mass, find_avg) CS%ground_frac(i,j) = 1.0 - (CS%ground_frac_rt(i,j) * I_counter) CS%OD_av(i,j) = CS%OD_rt(i,j) * I_counter - CS%OD_rt(i,j) = 0.0 ; CS%ground_frac_rt(i,j) = 0.0 + CS%OD_rt(i,j) = 0.0 ; CS%ground_frac_rt(i,j) = 0.0 ; CS%OD_rt_counter = 0 enddo ; enddo - call pass_var(CS%ground_frac, G%domain) - call pass_var(CS%OD_av, G%domain) + call pass_var(CS%ground_frac, G%domain, complete=.false.) + call pass_var(CS%OD_av, G%domain, complete=.true.) endif end subroutine update_OD_ffrac @@ -2726,7 +4344,7 @@ subroutine update_OD_ffrac_uncoupled(CS, G, h_shelf) real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: h_shelf !< the thickness of the ice shelf [Z ~> m]. - integer :: i, j, iters, isd, ied, jsd, jed + integer :: i, j, isd, ied, jsd, jed real :: rhoi_rhow, OD rhoi_rhow = CS%density_ice / CS%density_ocean_avg @@ -2734,7 +4352,7 @@ subroutine update_OD_ffrac_uncoupled(CS, G, h_shelf) do j=jsd,jed do i=isd,ied - OD = CS%bed_elev(i,j) - rhoi_rhow * h_shelf(i,j) + OD = CS%bed_elev(i,j) - rhoi_rhow * max(h_shelf(i,j),CS%min_h_shelf) if (OD >= 0) then ! ice thickness does not take up whole ocean column -> floating CS%OD_av(i,j) = OD @@ -2748,6 +4366,53 @@ subroutine update_OD_ffrac_uncoupled(CS, G, h_shelf) end subroutine update_OD_ffrac_uncoupled +subroutine change_in_draft(CS, G, h_shelf0, h_shelf1, ddraft) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h_shelf0 !< the previous thickness of the ice shelf [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h_shelf1 !< the current thickness of the ice shelf [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: ddraft !< the change in shelf draft thickness + real :: b0,b1 + integer :: i, j, isc, iec, jsc, jec + real :: rhoi_rhow, OD + + rhoi_rhow = CS%density_ice / CS%density_ocean_avg + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + ddraft = 0.0 + + do j=jsc,jec + do i=isc,iec + + b0 = 0.0 ; b1 = 0.0 + + if (h_shelf0(i,j)>0.0) then + OD = CS%bed_elev(i,j) - rhoi_rhow * h_shelf0(i,j) + if (OD >= 0) then + !floating + b0 = rhoi_rhow * h_shelf0(i,j) + else + b0 = CS%bed_elev(i,j) + endif + endif + + if (h_shelf1(i,j)>0.0) then + OD = CS%bed_elev(i,j) - rhoi_rhow * h_shelf1(i,j) + if (OD >= 0) then + !floating + b1 = rhoi_rhow * h_shelf1(i,j) + else + b1 = CS%bed_elev(i,j) + endif + endif + + ddraft(i,j) = b1-b0 + enddo + enddo +end subroutine change_in_draft + !> This subroutine calculates the gradients of bilinear basis elements that !! that are centered at the vertices of the cell. Values are calculated at !! points of gaussian quadrature. @@ -2778,17 +4443,17 @@ subroutine bilinear_shape_functions (X, Y, Phi, area) real, dimension(4) :: xquad, yquad ! [nondim] real :: a,b,c,d ! Various lengths [L ~> m] real :: xexp, yexp ! [nondim] - integer :: node, qpoint, xnode, xq, ynode, yq + integer :: node, qpoint, xnode, ynode xquad(1:3:2) = .5 * (1-sqrt(1./3)) ; yquad(1:2) = .5 * (1-sqrt(1./3)) xquad(2:4:2) = .5 * (1+sqrt(1./3)) ; yquad(3:4) = .5 * (1+sqrt(1./3)) do qpoint=1,4 - a = -X(1)*(1-yquad(qpoint)) + X(2)*(1-yquad(qpoint)) - X(3)*yquad(qpoint) + X(4)*yquad(qpoint) ! d(x)/d(x*) - b = -Y(1)*(1-yquad(qpoint)) + Y(2)*(1-yquad(qpoint)) - Y(3)*yquad(qpoint) + Y(4)*yquad(qpoint) ! d(y)/d(x*) - c = -X(1)*(1-xquad(qpoint)) - X(2)*(xquad(qpoint)) + X(3)*(1-xquad(qpoint)) + X(4)*(xquad(qpoint)) ! d(x)/d(y*) - d = -Y(1)*(1-xquad(qpoint)) - Y(2)*(xquad(qpoint)) + Y(3)*(1-xquad(qpoint)) + Y(4)*(xquad(qpoint)) ! d(y)/d(y*) + a = ((-X(1)*(1-yquad(qpoint)))+(X(4)*yquad(qpoint))) + ((X(2)*(1-yquad(qpoint)))-(X(3)*yquad(qpoint))) !d(x)/d(x*) + b = ((-Y(1)*(1-yquad(qpoint)))+(Y(4)*yquad(qpoint))) + ((Y(2)*(1-yquad(qpoint)))-(Y(3)*yquad(qpoint))) !d(y)/d(x*) + c = ((-X(1)*(1-xquad(qpoint)))+(X(4)*xquad(qpoint))) + ((-X(2)*xquad(qpoint))+(X(3)*(1-xquad(qpoint))))!d(x)/d(y*) + d = ((-Y(1)*(1-xquad(qpoint)))+(Y(4)*xquad(qpoint))) + ((-Y(2)*xquad(qpoint))+(Y(3)*(1-xquad(qpoint))))!d(y)/d(y*) do node=1,4 @@ -2806,8 +4471,8 @@ subroutine bilinear_shape_functions (X, Y, Phi, area) xexp = xquad(qpoint) endif - Phi(2*node-1,qpoint) = ( d * (2 * xnode - 3) * yexp - b * (2 * ynode - 3) * xexp) / (a*d-b*c) - Phi(2*node,qpoint) = (-c * (2 * xnode - 3) * yexp + a * (2 * ynode - 3) * xexp) / (a*d-b*c) + Phi(2*node-1,qpoint) = ( d * (2 * xnode - 3) * yexp - b * (2 * ynode - 3) * xexp) / ((a*d)-(b*c)) + Phi(2*node,qpoint) = (-c * (2 * xnode - 3) * yexp + a * (2 * ynode - 3) * xexp) / ((a*d)-(b*c)) enddo enddo @@ -2819,12 +4484,14 @@ end subroutine bilinear_shape_functions !> This subroutine calculates the gradients of bilinear basis elements that are centered at the !! vertices of the cell using a locally orthogoal MOM6 grid. Values are calculated at !! points of gaussian quadrature. -subroutine bilinear_shape_fn_grid(G, i, j, Phi) +subroutine bilinear_shape_fn_grid(G, i, j, Phi, Jac) type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. integer, intent(in) :: i !< The i-index in the grid to work on. integer, intent(in) :: j !< The j-index in the grid to work on. real, dimension(8,4), intent(inout) :: Phi !< The gradients of bilinear basis elements at Gaussian !! quadrature points surrounding the cell vertices [L-1 ~> m-1]. + real, dimension(4), optional, intent(out) :: Jac !< Jacobian determinant |J_q| = a_q*d_q at each + !! Gaussian quadrature point [L2 ~> m2]. ! This subroutine calculates the gradients of bilinear basis elements that ! that are centered at the vertices of the cell. The values are calculated at @@ -2840,22 +4507,22 @@ subroutine bilinear_shape_fn_grid(G, i, j, Phi) real, dimension(4) :: xquad, yquad ! [nondim] real :: a, d ! Interpolated grid spacings [L ~> m] real :: xexp, yexp ! [nondim] - integer :: node, qpoint, xnode, xq, ynode, yq + integer :: node, qpoint, xnode, ynode xquad(1:3:2) = .5 * (1-sqrt(1./3)) ; yquad(1:2) = .5 * (1-sqrt(1./3)) xquad(2:4:2) = .5 * (1+sqrt(1./3)) ; yquad(3:4) = .5 * (1+sqrt(1./3)) do qpoint=1,4 - if (J>1) then - a = G%dxCv(i,J-1) * (1-yquad(qpoint)) + G%dxCv(i,J) * yquad(qpoint) ! d(x)/d(x*) - else - a= G%dxCv(i,J) !* yquad(qpoint) ! d(x)/d(x*) - endif - if (I>1) then - d = G%dyCu(I-1,j) * (1-xquad(qpoint)) + G%dyCu(I,j) * xquad(qpoint) ! d(y)/d(y*) - else + if (J>1) then + a = (G%dxCv(i,J-1) * (1-yquad(qpoint))) + (G%dxCv(i,J) * yquad(qpoint)) ! d(x)/d(x*) + else + a = G%dxCv(i,J) !* yquad(qpoint) ! d(x)/d(x*) + endif + if (I>1) then + d = (G%dyCu(I-1,j) * (1-xquad(qpoint))) + (G%dyCu(I,j) * xquad(qpoint)) ! d(y)/d(y*) + else d = G%dyCu(I,j) !* xquad(qpoint) - endif + endif ! a = G%dxCv(i,J-1) * (1-yquad(qpoint)) + G%dxCv(i,J) * yquad(qpoint) ! d(x)/d(x*) ! d = G%dyCu(I-1,j) * (1-xquad(qpoint)) + G%dyCu(I,j) * xquad(qpoint) ! d(y)/d(y*) @@ -2874,20 +4541,65 @@ subroutine bilinear_shape_fn_grid(G, i, j, Phi) xexp = xquad(qpoint) endif - Phi(2*node-1,qpoint) = ( d * (2 * xnode - 3) * yexp ) / (a*d) - Phi(2*node,qpoint) = ( a * (2 * ynode - 3) * xexp ) / (a*d) + Phi(2*node-1,qpoint) = ( (d * (2 * xnode - 3)) * yexp ) / (a*d) + Phi(2*node,qpoint) = ( (a * (2 * ynode - 3)) * xexp ) / (a*d) enddo + if (present(Jac)) Jac(qpoint) = a * d enddo end subroutine bilinear_shape_fn_grid +!> This subroutine calculates the gradients of bilinear basis elements that are centered at the +!! vertices of the cell using a locally orthogoal MOM6 grid. Values are calculated at +!! a sinlge cell-centered quadrature point, which should match the grid cell h-point +subroutine bilinear_shape_fn_grid_1qp(G, i, j, Phi) + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + integer, intent(in) :: i !< The i-index in the grid to work on. + integer, intent(in) :: j !< The j-index in the grid to work on. + real, dimension(8), intent(inout) :: Phi !< The gradients of bilinear basis elements at Gaussian + !! quadrature points surrounding the cell vertices [L-1 ~> m-1]. + +! This subroutine calculates the gradients of bilinear basis elements that +! that are centered at the vertices of the cell. The values are calculated at +! a cell-cented point of gaussian quadrature. (in 1D: .5 for [0,1]) +! (ordered in same way as vertices) +! +! Phi(2*i-1) gives d(Phi_i)/dx at the quadrature point +! Phi(2*i) gives d(Phi_i)/dy at the quadrature point +! Phi_i is equal to 1 at vertex i, and 0 at vertex k /= i, and bilinear + + real :: a, d ! Interpolated grid spacings [L ~> m] + real :: xexp=0.5, yexp=0.5 ! [nondim] + integer :: node, qpoint, xnode, ynode + + ! d(x)/d(x*) + if (J>1) then + a = 0.5 * (G%dxCv(i,J-1) + G%dxCv(i,J)) + else + a = G%dxCv(i,J) + endif + + ! d(y)/d(y*) + if (I>1) then + d = 0.5 * (G%dyCu(I-1,j) + G%dyCu(I,j)) + else + d = G%dyCu(I,j) + endif + + do node=1,4 + xnode = 2-mod(node,2) ; ynode = ceiling(REAL(node)/2) + Phi(2*node-1) = ( (d * (2 * xnode - 3)) * yexp ) / (a*d) + Phi(2*node) = ( (a * (2 * ynode - 3)) * xexp ) / (a*d) + enddo +end subroutine bilinear_shape_fn_grid_1qp + subroutine bilinear_shape_functions_subgrid(Phisub, nsub) - real, dimension(nsub,nsub,2,2,2,2), & + integer, intent(in) :: nsub !< The number of subgridscale quadrature locations in each direction + real, dimension(2,2,nsub,nsub,2,2), & intent(inout) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] - integer, intent(in) :: nsub !< The number of subgridscale quadrature locations in each direction ! this subroutine is a helper for interpolation of floatation condition ! for the purposes of evaluating the terms \int (u,v) \phi_i dx dy in a cell that is @@ -2897,13 +4609,13 @@ subroutine bilinear_shape_functions_subgrid(Phisub, nsub) ! i think this general approach may not work for nonrectangular elements... ! - ! Phisub(i,j,k,l,q1,q2) + ! Phisub(q1,q2,i,j,k,l) + ! q1: quad point x-index + ! q2: quad point y-index ! i: subgrid index in x-direction ! j: subgrid index in y-direction ! k: basis function x-index ! l: basis function y-index - ! q1: quad point x-index - ! q2: quad point y-index ! e.g. k=1,l=1 => node 1 ! q1=2,q2=1 => quad point 2 @@ -2912,9 +4624,9 @@ subroutine bilinear_shape_functions_subgrid(Phisub, nsub) ! | | ! 1 - 2 - integer :: i, j, k, l, qx, qy, indx, indy + integer :: i, j, qx, qy real,dimension(2) :: xquad - real :: x0, y0, x, y, val, fracx + real :: x0, y0, x, y, fracx xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) fracx = 1.0/real(nsub) @@ -2924,10 +4636,10 @@ subroutine bilinear_shape_functions_subgrid(Phisub, nsub) do qy=1,2 ; do qx=1,2 x = x0 + fracx*xquad(qx) y = y0 + fracx*xquad(qy) - Phisub(i,j,1,1,qx,qy) = (1.0-x) * (1.0-y) - Phisub(i,j,1,2,qx,qy) = (1.0-x) * y - Phisub(i,j,2,1,qx,qy) = x * (1.0-y) - Phisub(i,j,2,2,qx,qy) = x * y + Phisub(qx,qy,i,j,1,1) = (1.0-x) * (1.0-y) + Phisub(qx,qy,i,j,1,2) = (1.0-x) * y + Phisub(qx,qy,i,j,2,1) = x * (1.0-y) + Phisub(qx,qy,i,j,2,2) = x * y enddo ; enddo enddo ; enddo @@ -2946,7 +4658,7 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face real, dimension(SZDIB_(G),SZDJB_(G)), & intent(out) :: vmask !< A coded mask indicating the nature of the !! meridional flow at the corner point -real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(out) :: u_face_mask !< A coded mask for velocities at the C-grid u-face real, dimension(SZDIB_(G),SZDJB_(G)), & intent(out) :: v_face_mask !< A coded mask for velocities at the C-grid v-face @@ -2957,11 +4669,9 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face integer :: i, j, k, iscq, iecq, jscq, jecq, isd, jsd, is, js, iegq, jegq integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec - integer :: i_off, j_off isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB - i_off = G%idg_offset ; j_off = G%jdg_offset isd = G%isd ; jsd = G%jsd iegq = G%iegB ; jegq = G%jegB gisc = G%Domain%nihalo ; gjsc = G%Domain%njhalo @@ -2976,61 +4686,73 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face is = isd+1 ; js = jsd+1 endif + do j=js,G%jed ; do i=is,G%ied + if (hmask(i,j) == 1 .or. hmask(i,j)==3) then + umask(I-1:I,J-1:J)=1 + vmask(I-1:I,J-1:J)=1 + endif + enddo ; enddo + do j=js,G%jed do i=is,G%ied if ((hmask(i,j) == 1) .OR. (hmask(i,j) == 3)) then - umask(I,j) = 1. - vmask(I,j) = 1. - do k=0,1 select case (int(CS%u_face_mask_bdry(I-1+k,j))) + case (5) + umask(I-1+k,J-1:J) = 3. + u_face_mask(I-1+k,j) = 5. case (3) - vmask(I-1+k,J-1)=3. - u_face_mask(I-1+k,j)=3. - umask(I-1+k,J)=3. - vmask(I-1+k,J)=3. - vmask(I-1+k,J)=3. + umask(I-1+k,J-1:J) = 3. + vmask(I-1+k,J-1:J) = 3. + u_face_mask(I-1+k,j) = 3. + case (6) + vmask(I-1+k,J-1:J) = 3. + u_face_mask(I-1+k,j) = 6. case (2) - u_face_mask(I-1+k,j)=2. + u_face_mask(I-1+k,j) = 2. case (4) - umask(I-1+k,J-1:J)=0. - vmask(I-1+k,J-1:J)=0. - u_face_mask(I-1+k,j)=4. + umask(I-1+k,J-1:J) = 0. + u_face_mask(I-1+k,j) = 4. case (0) - umask(I-1+k,J-1:J)=0. - vmask(I-1+k,J-1:J)=0. - u_face_mask(I-1+k,j)=0. + umask(I-1+k,J-1:J) = 0. + u_face_mask(I-1+k,j) = 0. case (1) ! stress free x-boundary - umask(I-1+k,J-1:J)=0. + umask(I-1+k,J-1:J) = 0. case default + umask(I-1+k,J-1) = max(1. , umask(I-1+k,J-1)) + umask(I-1+k,J) = max(1. , umask(I-1+k,J)) end select enddo do k=0,1 select case (int(CS%v_face_mask_bdry(i,J-1+k))) + case (5) + vmask(I-1:I,J-1+k) = 3. + v_face_mask(i,J-1+k) = 5. case (3) - vmask(I-1,J-1+k)=3. - umask(I-1,J-1+k)=3. - vmask(I,J-1+k)=3. - umask(I,J-1+k)=3. - v_face_mask(i,J-1+k)=3. + vmask(I-1:I,J-1+k) = 3. + umask(I-1:I,J-1+k) = 3. + v_face_mask(i,J-1+k) = 3. + case (6) + umask(I-1:I,J-1+k) = 3. + v_face_mask(i,J-1+k) = 6. case (2) - v_face_mask(i,J-1+k)=2. + v_face_mask(i,J-1+k) = 2. case (4) - umask(I-1:I,J-1+k)=0. - vmask(I-1:I,J-1+k)=0. - v_face_mask(i,J-1+k)=4. + vmask(I-1:I,J-1+k) = 0. + v_face_mask(i,J-1+k) = 4. case (0) - umask(I-1:I,J-1+k)=0. - vmask(I-1:I,J-1+k)=0. - v_face_mask(i,J-1+k)=0. + vmask(I-1:I,J-1+k) = 0. + v_face_mask(i,J-1+k) = 0. case (1) ! stress free y-boundary - vmask(I-1:I,J-1+k)=0. + vmask(I-1:I,J-1+k) = 0. case default + vmask(I-1,J-1+k) = max(1. , vmask(I-1,J-1+k)) + vmask(I,J-1+k) = max(1. , vmask(I,J-1+k)) end select enddo @@ -3079,8 +4801,8 @@ end subroutine update_velocity_masks !> Interpolate the ice shelf thickness from tracer point to nodal points, !! subject to a mask. -subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node) - type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. +subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node, min_h_shelf) + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: h_shelf !< The ice shelf thickness at tracer points [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & @@ -3089,9 +4811,10 @@ subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node) real, dimension(SZDIB_(G),SZDJB_(G)), & intent(inout) :: H_node !< The ice shelf thickness at nodal (corner) !! points [Z ~> m]. + real, intent(in) :: min_h_shelf !< The minimum ice thickness used during ice dynamics [Z ~> m]. - integer :: i, j, isc, iec, jsc, jec, num_h, k, l - real :: summ + integer :: i, j, isc, iec, jsc, jec, num_h, k, l, ic, jc + real :: h_arr(2,2) isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec @@ -3102,19 +4825,18 @@ subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node) do j=jsc-1,jec do i=isc-1,iec - summ = 0.0 num_h = 0 - do k=0,1 - do l=0,1 - if (hmask(i+k,j+l) == 1.0) then - summ = summ + h_shelf(i+k,j+l) - num_h = num_h + 1 - endif - enddo - enddo - if (num_h > 0) then - H_node(i,j) = summ / num_h - endif + do l=1,2 ; jc=j-1+l ; do k=1,2 ; ic=i-1+k + if (hmask(ic,jc) == 1.0 .or. hmask(ic,jc) == 3.0) then + h_arr(k,l)=max(h_shelf(ic,jc),min_h_shelf) + num_h = num_h + 1 + else + h_arr(k,l)=0.0 + endif + if (num_h > 0) then + H_node(i,j) = ((h_arr(1,1)+h_arr(2,2))+(h_arr(1,2)+h_arr(2,1))) / num_h + endif + enddo ; enddo enddo enddo @@ -3130,16 +4852,28 @@ subroutine ice_shelf_dyn_end(CS) deallocate(CS%u_shelf, CS%v_shelf) deallocate(CS%taudx_shelf, CS%taudy_shelf) + deallocate(CS%sx_shelf, CS%sy_shelf) deallocate(CS%t_shelf, CS%tmask) deallocate(CS%u_bdry_val, CS%v_bdry_val) deallocate(CS%u_face_mask, CS%v_face_mask) + deallocate(CS%u_flux_bdry_val, CS%v_flux_bdry_val) deallocate(CS%umask, CS%vmask) + deallocate(CS%u_face_mask_bdry, CS%v_face_mask_bdry) + deallocate(CS%h_bdry_val) + deallocate(CS%float_cond) + if (associated(CS%calve_mask)) deallocate(CS%calve_mask) deallocate(CS%ice_visc, CS%AGlen_visc) + deallocate(CS%newton_visc_factor, CS%newton_str_ux, CS%newton_str_vy, CS%newton_str_sh) + deallocate(CS%newton_umid, CS%newton_vmid, CS%newton_drag_coef) deallocate(CS%basal_traction,CS%C_basal_friction) deallocate(CS%OD_rt, CS%OD_av) deallocate(CS%t_bdry_val, CS%bed_elev) deallocate(CS%ground_frac, CS%ground_frac_rt) + if (associated(CS%Jac)) deallocate(CS%Jac) + if (associated(CS%Phi)) deallocate(CS%Phi) + if (associated(CS%Phisub)) deallocate(CS%Phisub) + if (associated(CS%PhiC)) deallocate(CS%PhiC) deallocate(CS) @@ -3164,16 +4898,15 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) ! The flux overflows are included here. That is because they will be used to advect 3D scalars ! into partial cells - real, dimension(SZDI_(G),SZDJ_(G)) :: th_after_uflux, th_after_vflux, TH + real, dimension(SZDI_(G),SZDJ_(G)) :: th_after_uflux, th_after_vflux, TH ! Integrated temperatures [C Z ~> degC m] integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec - real :: Tsurf ! Surface air temperature. This is hard coded but should be an input argument. - real :: adot ! A surface heat exchange coefficient divided by the heat capacity of - ! ice [R Z T-1 degC-1 ~> kg m-2 s-1 degC-1]. + real :: Tsurf ! Surface air temperature [C ~> degC]. This is hard coded but should be an input argument. + real :: adot ! A surface heat exchange coefficient [R Z T-1 ~> kg m-2 s-1]. ! For now adot and Tsurf are defined here adot=surf acc 0.1m/yr, Tsurf=-20oC, vary them later adot = (0.1/(365.0*86400.0))*US%m_to_Z*US%T_to_s * CS%density_ice - Tsurf = -20.0 + Tsurf = -20.0*US%degC_to_C isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec @@ -3203,7 +4936,7 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) if (ISS%h_shelf(i,j) > 0.0) then CS%t_shelf(i,j) = th_after_vflux(i,j) / ISS%h_shelf(i,j) else - CS%t_shelf(i,j) = -10.0 + CS%t_shelf(i,j) = CS%T_shelf_missing endif ! endif @@ -3214,21 +4947,21 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) else ! the ice is about to melt away in this case set thickness, area, and mask to zero ! NOTE: not mass conservative, should maybe scale salt & heat flux for this cell - CS%t_shelf(i,j) = -10.0 + CS%t_shelf(i,j) = CS%T_shelf_missing CS%tmask(i,j) = 0.0 endif elseif (ISS%hmask(i,j) == 0) then - CS%t_shelf(i,j) = -10.0 + CS%t_shelf(i,j) = CS%T_shelf_missing elseif ((ISS%hmask(i,j) == 3) .or. (ISS%hmask(i,j) == -2)) then CS%t_shelf(i,j) = CS%t_bdry_val(i,j) endif enddo ; enddo - call pass_var(CS%t_shelf, G%domain) - call pass_var(CS%tmask, G%domain) + call pass_var(CS%t_shelf, G%domain, complete=.false.) + call pass_var(CS%tmask, G%domain, complete=.true.) if (CS%debug) then - call hchksum(CS%t_shelf, "temp after front", G%HI, haloshift=3) + call hchksum(CS%t_shelf, "temp after front", G%HI, haloshift=3, unscale=US%C_to_degC) endif end subroutine ice_shelf_temp @@ -3242,23 +4975,21 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux) intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: h0 !< The initial ice shelf thicknesses [Z ~> m]. + intent(in) :: h0 !< The initial ice shelf thicknesses times temperature [C Z ~> degC m] real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: h_after_uflux !< The ice shelf thicknesses after - !! the zonal mass fluxes [Z ~> m]. + intent(inout) :: h_after_uflux !< The ice shelf thicknesses times temperature after + !! the zonal mass fluxes [C Z ~> degC m] ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells ! if there is an input bdry condition, the thickness there will be set in initialization - integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed integer :: i_off, j_off - logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry - real, dimension(-2:2) :: stencil - real :: u_face ! Zonal velocity at a face, positive if out {L T-1 ~> m s-1] - real :: flux_diff, phi - - character (len=1) :: debug_str - + logical :: at_east_bdry, at_west_bdry + real, dimension(-2:2) :: stencil ! A copy of the neighboring thicknesses times temperatures [C Z ~> degC m] + real :: u_face ! Zonal velocity at a face, positive if out [L T-1 ~> m s-1] + real :: flux_diff ! The difference in fluxes [C Z ~> degC m] + real :: phi ! A limiting ratio [nondim] is = G%isc-2 ; ie = G%iec+2 ; js = G%jsc ; je = G%jec ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed i_off = G%idg_offset ; j_off = G%jdg_offset @@ -3267,7 +4998,7 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux) if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & ((j+j_off) >= G%domain%njhalo+1)) then ! based on mehmet's code - only if btw north & south boundaries - stencil(:) = -1 + stencil(:) = 0.0 ! This is probably unnecessary, as the code is written ! if (i+i_off == G%domain%nihalo+G%domain%nihalo) do i=is,ie @@ -3315,8 +5046,8 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux) elseif (hmask(i-1,j) * hmask(i-2,j) == 1) then ! h(i-2) and h(i-1) are valid phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff = flux_diff + ABS(u_face) * G%dyCu(I-1,j)* time_step / G%areaT(i,j) * & - (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) + flux_diff = flux_diff + ((ABS(u_face) * G%dyCu(I-1,j)* time_step / G%areaT(i,j)) * & + (stencil(-1) - (phi * (stencil(-1)-stencil(0))/2))) else ! h(i-1) is valid ! (o.w. flux would most likely be out of cell) @@ -3329,8 +5060,8 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux) elseif (u_face < 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff = flux_diff - ABS(u_face) * G%dyCu(I-1,j) * time_step / G%areaT(i,j) * & - (stencil(0) - phi * (stencil(0)-stencil(-1))/2) + flux_diff = flux_diff - ((ABS(u_face) * G%dyCu(I-1,j) * time_step / G%areaT(i,j)) * & + (stencil(0) - (phi * (stencil(0)-stencil(-1))/2))) else flux_diff = flux_diff - ABS(u_face) * G%dyCu(I-1,j) * time_step / G%areaT(i,j) * stencil(0) @@ -3360,8 +5091,8 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux) elseif (hmask(i+1,j) * hmask(i+2,j) == 1) then ! h(i+2) and h(i+1) are valid phi = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff = flux_diff + ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * & - (stencil(1) - phi * (stencil(1)-stencil(0))/2) + flux_diff = flux_diff + ((ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j)) * & + (stencil(1) - (phi * (stencil(1)-stencil(0))/2))) else ! h(i+1) is valid ! (o.w. flux would most likely be out of cell) @@ -3376,8 +5107,8 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux) if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid phi = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff = flux_diff - ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j) * & - (stencil(0) - phi * (stencil(0)-stencil(1))/2) + flux_diff = flux_diff - ((ABS(u_face) * G%dyCu(I,j) * time_step / G%areaT(i,j)) * & + (stencil(0) - (phi * (stencil(0)-stencil(1))/2))) else ! h(i+1) is valid (o.w. flux would most likely be out of cell) but h(i+2) is not @@ -3411,22 +5142,22 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: h_after_uflux !< The ice shelf thicknesses after - !! the zonal mass fluxes [Z ~> m]. + intent(in) :: h_after_uflux !< The ice shelf thicknesses times temperature after + !! the zonal mass fluxes [C Z ~> degC m]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: h_after_vflux !< The ice shelf thicknesses after - !! the meridional mass fluxes [Z ~> m]. + intent(inout) :: h_after_vflux !< The ice shelf thicknesses times temperature after + !! the meridional mass fluxes [C Z ~> degC m] ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells ! if there is an input bdry condition, the thickness there will be set in initialization - integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed integer :: i_off, j_off - logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry - real, dimension(-2:2) :: stencil - real :: v_face ! Pseudo-meridional velocity at a cell face, positive if out {L T-1 ~> m s-1] - real :: flux_diff, phi - character(len=1) :: debug_str + logical :: at_north_bdry, at_south_bdry + real, dimension(-2:2) :: stencil ! A copy of the neighboring thicknesses times temperatures [C Z ~> degC m] + real :: v_face ! Pseudo-meridional velocity at a cell face, positive if out [L T-1 ~> m s-1] + real :: flux_diff ! The difference in fluxes [C Z ~> degC m] + real :: phi is = G%isc ; ie = G%iec ; js = G%jsc-1 ; je = G%jec+1 ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed i_off = G%idg_offset ; j_off = G%jdg_offset @@ -3435,7 +5166,7 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & ((i+i_off) >= G%domain%nihalo+1)) then ! based on mehmet's code - only if btw east & west boundaries - stencil(:) = -1 + stencil(:) = 0.0 ! This is probably unnecessary, as the code is written do j=js,je @@ -3481,8 +5212,8 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft elseif (hmask(i,j-1) * hmask(i,j-2) == 1) then ! h(j-2) and h(j-1) are valid phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * & - (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) + flux_diff = flux_diff + ((ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j)) * & + (stencil(-1) - (phi * (stencil(-1)-stencil(0))/2))) else ! h(j-1) is valid ! (o.w. flux would most likely be out of cell) @@ -3494,8 +5225,8 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * & - (stencil(0) - phi * (stencil(0)-stencil(-1))/2) + flux_diff = flux_diff - ((ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j)) * & + (stencil(0) - (phi * (stencil(0)-stencil(-1))/2))) else flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J-1) * time_step / G%areaT(i,j) * stencil(0) endif @@ -3521,8 +5252,8 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step * stencil(1) / G%areaT(i,j) elseif (hmask(i,j+1) * hmask(i,j+2) == 1) then ! h(j+2) and h(j+1) are valid phi = slope_limiter (stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff = flux_diff + ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * & - (stencil(1) - phi * (stencil(1)-stencil(0))/2) + flux_diff = flux_diff + ((ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j)) * & + (stencil(1) - (phi * (stencil(1)-stencil(0))/2))) else ! h(j+1) is valid ! (o.w. flux would most likely be out of cell) ! but h(j+2) is not @@ -3533,8 +5264,8 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid phi = slope_limiter (stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff = flux_diff - ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j) * & - (stencil(0) - phi * (stencil(0)-stencil(1))/2) + flux_diff = flux_diff - ((ABS(v_face) * G%dxCv(i,J) * time_step / G%areaT(i,j)) * & + (stencil(0) - (phi * (stencil(0)-stencil(1))/2))) else ! h(j+1) is valid ! (o.w. flux would most likely be out of cell) ! but h(j+2) is not diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index 7cc3c020a3..8c06e2b535 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Initialize ice shelf variables module MOM_ice_shelf_initialize -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_grid, only : ocean_grid_type use MOM_array_transform, only : rotate_array use MOM_hor_index, only : hor_index_type @@ -22,6 +24,7 @@ module MOM_ice_shelf_initialize public initialize_ice_shelf_boundary_from_file public initialize_ice_C_basal_friction public initialize_ice_AGlen +public initialize_ice_SMB ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with ! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units @@ -30,7 +33,7 @@ module MOM_ice_shelf_initialize contains !> Initialize ice shelf thickness -subroutine initialize_ice_thickness(h_shelf, area_shelf_h, hmask, G, G_in, US, PF, rotate_index, turns) +subroutine initialize_ice_thickness(h_shelf, area_shelf_h, hmask, melt_mask, G, G_in, US, PF, rotate_index, turns) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(ocean_grid_type), intent(in) :: G_in !< The ocean's unrotated grid structure real, dimension(SZDI_(G),SZDJ_(G)), & @@ -39,19 +42,21 @@ subroutine initialize_ice_thickness(h_shelf, area_shelf_h, hmask, G, G_in, US, P intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [L2 ~> m2]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: hmask !< A mask indicating which tracer points are - !! partly or fully covered by an ice-shelf + !! partly or fully covered by an ice-shelf [nondim] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: melt_mask !< A mask indicating where to allow ice-shelf melting [nondim] type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters logical, intent(in), optional :: rotate_index !< If true, this is a rotation test integer, intent(in), optional :: turns !< Number of turns for rotation test - integer :: i, j character(len=40) :: mdl = "initialize_ice_thickness" ! This subroutine's name. character(len=200) :: config logical :: rotate = .false. - real, allocatable, dimension(:,:) :: tmp1_2d ! Temporary array for storing ice shelf input data - real, allocatable, dimension(:,:) :: tmp2_2d ! Temporary array for storing ice shelf input data - real, allocatable, dimension(:,:) :: tmp3_2d ! Temporary array for storing ice shelf input data + real, allocatable, dimension(:,:) :: tmp1_2d ! Temporary array for storing ice shelf input data [Z~>m] + real, allocatable, dimension(:,:) :: tmp2_2d ! Temporary array for storing ice shelf input data [L2~>m2] + real, allocatable, dimension(:,:) :: tmp3_2d ! Temporary array for storing ice shelf input data [nondim] + real, allocatable, dimension(:,:) :: tmp4_2d ! Temporary array for storing ice shelf input data [nondim] call get_param(PF, mdl, "ICE_PROFILE_CONFIG", config, & "This specifies how the initial ice profile is specified. "//& @@ -64,20 +69,22 @@ subroutine initialize_ice_thickness(h_shelf, area_shelf_h, hmask, G, G_in, US, P allocate(tmp1_2d(G_in%isd:G_in%ied,G_in%jsd:G_in%jed), source=0.0) allocate(tmp2_2d(G_in%isd:G_in%ied,G_in%jsd:G_in%jed), source=0.0) allocate(tmp3_2d(G_in%isd:G_in%ied,G_in%jsd:G_in%jed), source=0.0) + allocate(tmp4_2d(G_in%isd:G_in%ied,G_in%jsd:G_in%jed), source=1.0) select case ( trim(config) ) case ("CHANNEL") ; call initialize_ice_thickness_channel (tmp1_2d, tmp2_2d, tmp3_2d, G_in, US, PF) - case ("FILE") ; call initialize_ice_thickness_from_file (tmp1_2d, tmp2_2d, tmp3_2d, G_in, US, PF) + case ("FILE") ; call initialize_ice_thickness_from_file (tmp1_2d, tmp2_2d, tmp3_2d, tmp4_2d, G_in, US, PF) case ("USER") ; call USER_init_ice_thickness (tmp1_2d, tmp2_2d, tmp3_2d, G_in, US, PF) case default ; call MOM_error(FATAL,"MOM_initialize: Unrecognized ice profile setup "//trim(config)) end select call rotate_array(tmp1_2d,turns, h_shelf) call rotate_array(tmp2_2d,turns, area_shelf_h) call rotate_array(tmp3_2d,turns, hmask) + call rotate_array(tmp4_2d,turns, melt_mask) deallocate(tmp1_2d,tmp2_2d,tmp3_2d) else select case ( trim(config) ) case ("CHANNEL") ; call initialize_ice_thickness_channel (h_shelf, area_shelf_h, hmask, G, US, PF) - case ("FILE") ; call initialize_ice_thickness_from_file (h_shelf, area_shelf_h, hmask, G, US, PF) + case ("FILE") ; call initialize_ice_thickness_from_file (h_shelf, area_shelf_h, hmask, melt_mask, G, US, PF) case ("USER") ; call USER_init_ice_thickness (h_shelf, area_shelf_h, hmask, G, US, PF) case default ; call MOM_error(FATAL,"MOM_initialize: Unrecognized ice profile setup "//trim(config)) end select @@ -86,7 +93,7 @@ subroutine initialize_ice_thickness(h_shelf, area_shelf_h, hmask, G, G_in, US, P end subroutine initialize_ice_thickness !> Initialize ice shelf thickness from file -subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, G, US, PF) +subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, melt_mask, G, US, PF) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. @@ -94,18 +101,20 @@ subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, G, U intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf [L2 ~> m2]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: hmask !< A mask indicating which tracer points are - !! partly or fully covered by an ice-shelf + !! partly or fully covered by an ice-shelf [nondim] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: melt_mask !< A mask indicating where to allow ice-shelf melting [nondim] type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters ! This subroutine reads ice thickness and area from a file and puts it into ! h_shelf [Z ~> m] and area_shelf_h [L2 ~> m2] (and dimensionless) and updates hmask character(len=200) :: filename,thickness_file,inputdir ! Strings for file/path - character(len=200) :: thickness_varname, area_varname, hmask_varname ! Variable name in file + character(len=200) :: thickness_varname, area_varname, hmask_varname, melt_mask_varname ! Variable name in file character(len=40) :: mdl = "initialize_ice_thickness_from_file" ! This subroutine's name. integer :: i, j, isc, jsc, iec, jec logical :: hmask_set - real :: len_sidestress, mask, udh + real :: len_sidestress, udh call MOM_mesg("Initialize_ice_thickness_from_file: reading thickness") @@ -127,6 +136,9 @@ subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, G, U "The name of the area variable in ICE_THICKNESS_FILE.", & default="area_shelf_h") hmask_varname="h_mask" + call get_param(PF, mdl, "MELT_MASK_VARNAME", melt_mask_varname, & + "The name of the melt mask variable in ICE_THICKNESS_FILE.", & + default="melt_mask") if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & " initialize_topography_from_file: Unable to open "//trim(filename)) call MOM_read_data(filename, trim(thickness_varname), h_shelf, G%Domain, scale=US%m_to_Z) @@ -139,6 +151,12 @@ subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, G, U "from variable "//trim(hmask_varname)//", which does not exist in "//trim(filename)) hmask_set = .false. endif + if (field_exists(filename, trim(melt_mask_varname), MOM_domain=G%Domain)) then + call MOM_read_data(filename, trim(melt_mask_varname), melt_mask, G%Domain) + else + melt_mask(:,:)=1.0 + endif + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec if (.not.hmask_set) then @@ -196,7 +214,7 @@ subroutine initialize_ice_thickness_channel(h_shelf, area_shelf_h, hmask, G, US, character(len=40) :: mdl = "initialize_ice_shelf_thickness_channel" ! This subroutine's name. real :: max_draft, min_draft, flat_shelf_width, c1, slope_pos - real :: edge_pos, shelf_slope_scale, Rho_ocean + real :: edge_pos, shelf_slope_scale integer :: i, j, jsc, jec, jsd, jed, jedg, nyh, isc, iec, isd, ied integer :: j_off @@ -220,7 +238,7 @@ subroutine initialize_ice_thickness_channel(h_shelf, area_shelf_h, hmask, G, US, ! call get_param(param_file, mdl, "RHO_0", Rho_ocean, & ! "The mean ocean density used with BOUSSINESQ true to "//& ! "calculate accelerations and the mass for conservation "//& -! "properties, or with BOUSSINSEQ false to convert some "//& +! "properties, or with BOUSSINESQ false to convert some "//& ! "parameters from vertical units of m to kg m-2.", & ! units="kg m-3", default=1035.0, scale=US%Z_to_m) @@ -274,148 +292,135 @@ end subroutine initialize_ice_thickness_channel !> Initialize ice shelf boundary conditions for a channel configuration subroutine initialize_ice_shelf_boundary_channel(u_face_mask_bdry, v_face_mask_bdry, & u_flux_bdry_val, v_flux_bdry_val, u_bdry_val, v_bdry_val, u_shelf, v_shelf, h_bdry_val, & - thickness_bdry_val, hmask, h_shelf, G,& - US, PF ) - - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: u_face_mask_bdry !< A boundary-type mask at C-grid u faces - - real, dimension(SZIB_(G),SZJ_(G)), & - intent(inout) :: u_flux_bdry_val !< The boundary thickness flux through - !! C-grid u faces [L Z T-1 ~> m2 s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: v_face_mask_bdry !< A boundary-type mask at C-grid v faces - - real, dimension(SZI_(G),SZJB_(G)), & - intent(inout) :: v_flux_bdry_val !< The boundary thickness flux through - !! C-grid v faces [L Z T-1 ~> m2 s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open - !! boundary vertices [L T-1 ~> m s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: u_shelf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: v_shelf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: thickness_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] - !! boundary vertices [L T-1 ~> m s-1]. - - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: hmask !< A mask indicating which tracer points are - !! partly or fully covered by an ice-shelf - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: h_shelf !< Ice-shelf thickness - type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors - type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters - - character(len=40) :: mdl = "initialize_ice_shelf_boundary_channel" ! This subroutine's name. - integer :: i, j, isd, jsd, is, js, iegq, jegq, giec, gjec, gisc, gjsc,gisd,gjsd, isc, jsc, iec, jec, ied, jed - real :: input_thick ! The input ice shelf thickness [Z ~> m] - real :: input_vel ! The input ice velocity per [L Z T-1 ~> m s-1] - real :: lenlat, len_stress, westlon, lenlon, southlat ! The input positions of the channel boundarises - - - call get_param(PF, mdl, "LENLAT", lenlat, fail_if_missing=.true.) - - call get_param(PF, mdl, "LENLON", lenlon, fail_if_missing=.true.) - - call get_param(PF, mdl, "WESTLON", westlon, fail_if_missing=.true.) - - call get_param(PF, mdl, "SOUTHLAT", southlat, fail_if_missing=.true.) - - call get_param(PF, mdl, "INPUT_VEL_ICE_SHELF", input_vel, & - "inflow ice velocity at upstream boundary", & - units="m s-1", default=0., scale=US%m_s_to_L_T*US%m_to_Z) - call get_param(PF, mdl, "INPUT_THICK_ICE_SHELF", input_thick, & - "flux thickness at upstream boundary", & - units="m", default=1000., scale=US%m_to_Z) - call get_param(PF, mdl, "LEN_SIDE_STRESS", len_stress, & - "maximum position of no-flow condition in along-flow direction", & - units="km", default=0.) - - call MOM_mesg(mdl//": setting boundary") - - isd = G%isd ; ied = G%ied - jsd = G%jsd ; jed = G%jed - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - gjsd = G%Domain%njglobal ; gisd = G%Domain%niglobal - gisc = G%Domain%nihalo ; gjsc = G%Domain%njhalo - giec = G%Domain%niglobal+gisc ; gjec = G%Domain%njglobal+gjsc - - !---------b.c.s based on geopositions ----------------- - do j=jsc,jec+1 - do i=isc-1,iec+1 - ! upstream boundary - set either dirichlet or flux condition - - if (G%geoLonBu(i,j) == westlon) then - hmask(i+1,j) = 3.0 - h_bdry_val(i+1,j) = h_shelf(i+1,j) - thickness_bdry_val(i+1,j) = h_bdry_val(i+0*1,j) - u_face_mask_bdry(i+1,j) = 3.0 - u_bdry_val(i+1,j) = input_vel*(1-16.0*((G%geoLatBu(i-1,j)/lenlat-0.5))**4) !velocity distribution - endif - - - ! side boundaries: no flow - if (G%geoLatBu(i,j-1) == southlat) then !bot boundary - if (len_stress == 0. .OR. G%geoLonCv(i,j) <= len_stress) then - v_face_mask_bdry(i,j+1) = 0. - u_face_mask_bdry(i,j) = 3. - u_bdry_val(i,j) = 0. - v_bdry_val(i,j) = 0. - else - v_face_mask_bdry(i,j+1) = 1. - u_face_mask_bdry(i,j) = 3. - u_bdry_val(i,j) = 0. - v_bdry_val(i,j) = 0. - endif - elseif (G%geoLatBu(i,j-1) == southlat+lenlat) then !top boundary - if (len_stress == 0. .OR. G%geoLonCv(i,j) <= len_stress) then - v_face_mask_bdry(i,j-1) = 0. - u_face_mask_bdry(i,j-1) = 3. - else - v_face_mask_bdry(i,j-1) = 3. - u_face_mask_bdry(i,j-1) = 3. - endif - endif - - ! downstream boundary - CFBC - if (G%geoLonBu(i,j) == westlon+lenlon) then - u_face_mask_bdry(i-1,j) = 2.0 - endif - - enddo - enddo + hmask, h_shelf, G, US, PF ) + + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_face_mask_bdry !< A boundary-type mask at C-grid u faces + + real, dimension(SZIB_(G),SZJ_(G)), & + intent(inout) :: u_flux_bdry_val !< The boundary thickness flux through + !! C-grid u faces [L Z T-1 ~> m2 s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_face_mask_bdry !< A boundary-type mask at C-grid v faces + + real, dimension(SZI_(G),SZJB_(G)), & + intent(inout) :: v_flux_bdry_val !< The boundary thickness flux through + !! C-grid v faces [L Z T-1 ~> m2 s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open + !! boundary vertices [L T-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_shelf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_shelf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< Ice-shelf thickness [Z ~> m] + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters + + character(len=40) :: mdl = "initialize_ice_shelf_boundary_channel" ! This subroutine's name. + integer :: i, j, isd, jsd, giec, gjec, gisc, gjsc,gisd,gjsd, isc, jsc, iec, jec, ied, jed + real :: input_thick ! The input ice shelf thickness [Z ~> m] + real :: input_vel ! The input ice velocity at the upstream boundary [L T-1 ~> m s-1] + real :: lenlat, len_stress, westlon, lenlon, southlat ! The input positions of the channel boundarises + + lenlat = G%len_lat + lenlon = G%len_lon + westlon = G%west_lon + southlat = G%south_lat + + call get_param(PF, mdl, "INPUT_VEL_ICE_SHELF", input_vel, & + "inflow ice velocity at upstream boundary", & + units="m s-1", default=0., scale=US%m_s_to_L_T) + call get_param(PF, mdl, "INPUT_THICK_ICE_SHELF", input_thick, & + "flux thickness at upstream boundary", & + units="m", default=1000., scale=US%m_to_Z) + call get_param(PF, mdl, "LEN_SIDE_STRESS", len_stress, & + "maximum position of no-flow condition in along-flow direction", & + units="km", default=0.) + + call MOM_mesg(mdl//": setting boundary") + + isd = G%isd ; ied = G%ied + jsd = G%jsd ; jed = G%jed + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + gjsd = G%Domain%njglobal ; gisd = G%Domain%niglobal + gisc = G%Domain%nihalo ; gjsc = G%Domain%njhalo + giec = G%Domain%niglobal+gisc ; gjec = G%Domain%njglobal+gjsc + + !---------b.c.s based on geopositions ----------------- + do j=jsc,jec+1 + do i=isc-1,iec+1 + ! upstream boundary - set either dirichlet or flux condition + + if (G%geoLonBu(i,j) == westlon) then + hmask(i+1,j) = 3.0 + !--- + !OLD: thickness_bdry_val was used for ice dynamics, and h_bdry_val was not used anywhere except here: + !h_bdry_val(i+1,j) = h_shelf(i+1,j) ; thickness_bdry_val(i+1,j) = h_bdry_val(i+0*1,j) + !--- + !NEW: h_bdry_val is used for ice dynamics instead of thickness_bdry_val, which was removed + h_bdry_val(i+1,j) = h_shelf(i+0*1,j) !why 0*1 + !--- + u_face_mask_bdry(i+1,j) = 5.0 + u_bdry_val(i+1,j) = input_vel*(1-16.0*((G%geoLatBu(i-1,j)/lenlat-0.5))**4) !velocity distribution + endif + + + ! side boundaries: no flow + if (G%geoLatBu(i,j-1) == southlat) then !bot boundary + if (len_stress == 0. .OR. G%geoLonCv(i,j) <= len_stress) then + v_face_mask_bdry(i,j+1) = 0. + u_face_mask_bdry(i,j) = 3. + u_bdry_val(i,j) = 0. + v_bdry_val(i,j) = 0. + else + v_face_mask_bdry(i,j+1) = 1. + u_face_mask_bdry(i,j) = 3. + u_bdry_val(i,j) = 0. + v_bdry_val(i,j) = 0. + endif + elseif (G%geoLatBu(i,j-1) == southlat+lenlat) then !top boundary + if (len_stress == 0. .OR. G%geoLonCv(i,j) <= len_stress) then + v_face_mask_bdry(i,j-1) = 0. + u_face_mask_bdry(i,j-1) = 3. + else + v_face_mask_bdry(i,j-1) = 3. + u_face_mask_bdry(i,j-1) = 3. + endif + endif + + ! downstream boundary - CFBC + if (G%geoLonBu(i,j) == westlon+lenlon) then + u_face_mask_bdry(i-1,j) = 2.0 + endif + + enddo + enddo end subroutine initialize_ice_shelf_boundary_channel !> Initialize ice shelf flow from file -!subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& -! hmask,h_shelf, G, US, PF) subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& G, US, PF) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: bed_elev !< The bed elevation [Z ~> m]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: u_shelf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: v_shelf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. - + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_shelf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_shelf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: float_cond !< An array indicating where the ice - !! shelf is floating: 0 if floating, 1 if not. -! real, dimension(SZDI_(G),SZDJ_(G)), & -! intent(in) :: hmask !< A mask indicating which tracer points are - !! partly or fully covered by an ice-shelf -! real, dimension(SZDI_(G),SZDJ_(G)), & -! intent(in) :: h_shelf !< A mask indicating which tracer points are -! !! partly or fully covered by an ice-shelf + !! shelf is floating: 0 if floating, 1 if not. [nondim] type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters @@ -423,10 +428,8 @@ subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& ! h_shelf [Z ~> m] and area_shelf_h [L2 ~> m2] (and dimensionless) and updates hmask character(len=200) :: filename,vel_file,inputdir,bed_topo_file ! Strings for file/path character(len=200) :: ushelf_varname, vshelf_varname, & - ice_visc_varname, floatfr_varname, bed_varname ! Variable name in file + floatfr_varname, bed_varname ! Variable name in file character(len=40) :: mdl = "initialize_ice_velocity_from_file" ! This subroutine's name. - integer :: i, j, isc, jsc, iec, jec - real :: len_sidestress, mask, udh call MOM_mesg(" MOM_ice_shelf_init_profile.F90, initialize_velocity_from_file: reading velocity") @@ -435,86 +438,76 @@ subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& call get_param(PF, mdl, "ICE_VELOCITY_FILE", vel_file, & "The file from which the velocity is read.", & default="ice_shelf_vel.nc") - call get_param(PF, mdl, "LEN_SIDE_STRESS", len_sidestress, & - "position past which shelf sides are stress free.", & - default=0.0, units="axis_units") filename = trim(inputdir)//trim(vel_file) call log_param(PF, mdl, "INPUTDIR/THICKNESS_FILE", filename) call get_param(PF, mdl, "ICE_U_VEL_VARNAME", ushelf_varname, & - "The name of the thickness variable in ICE_VELOCITY_FILE.", & + "The name of the u velocity variable in ICE_VELOCITY_FILE.", & default="u_shelf") call get_param(PF, mdl, "ICE_V_VEL_VARNAME", vshelf_varname, & - "The name of the thickness variable in ICE_VELOCITY_FILE.", & + "The name of the v velocity variable in ICE_VELOCITY_FILE.", & default="v_shelf") - call get_param(PF, mdl, "ICE_VISC_VARNAME", ice_visc_varname, & - "The name of the thickness variable in ICE_VELOCITY_FILE.", & - default="viscosity") + call get_param(PF, mdl, "ICE_FLOAT_FRAC_VARNAME", floatfr_varname, & + "The name of the ice float fraction (grounding fraction) variable in ICE_VELOCITY_FILE.", & + default="float_frac") call get_param(PF, mdl, "BED_TOPO_FILE", bed_topo_file, & "The file from which the bed elevation is read.", & default="ice_shelf_vel.nc") call get_param(PF, mdl, "BED_TOPO_VARNAME", bed_varname, & - "The name of the thickness variable in ICE_INPUT_FILE.", & + "The name of the bed elevation variable in ICE_INPUT_FILE.", & default="depth") if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & " initialize_ice_shelf_velocity_from_file: Unable to open "//trim(filename)) - floatfr_varname = "float_frac" + call MOM_read_data(filename, trim(ushelf_varname), u_shelf, G%Domain, position=CORNER, scale=US%m_s_to_L_T) + call MOM_read_data(filename, trim(vshelf_varname), v_shelf, G%Domain, position=CORNER, scale=US%m_s_to_L_T) + call MOM_read_data(filename, trim(floatfr_varname), float_cond, G%Domain, scale=1.) - call MOM_read_data(filename, trim(ushelf_varname), u_shelf, G%Domain, position=CORNER,scale=1.0) - call MOM_read_data(filename,trim(vshelf_varname), v_shelf, G%Domain, position=CORNER,scale=1.0) -! call MOM_read_data(filename,trim(ice_visc_varname), ice_visc, G%Domain,position=CORNER,scale=1.0) - call MOM_read_data(filename,trim(floatfr_varname), float_cond, G%Domain, scale=1.) - - filename = trim(inputdir)//trim(bed_topo_file) - call MOM_read_data(filename,trim(bed_varname), bed_elev, G%Domain, scale=1.) -! isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + filename = trim(inputdir)//trim(bed_topo_file) + call MOM_read_data(filename, trim(bed_varname), bed_elev, G%Domain, scale=US%m_to_Z) end subroutine initialize_ice_flow_from_file !> Initialize ice shelf b.c.s from file subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask_bdry, & - u_bdry_val, v_bdry_val, umask, vmask, h_bdry_val, thickness_bdry_val, & + u_bdry_val, v_bdry_val, umask, vmask, h_bdry_val, & hmask, h_shelf, G, US, PF ) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: u_face_mask_bdry !< A boundary-type mask at B-grid u faces - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: v_face_mask_bdry !< A boundary-type mask at B-grid v faces - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open - !! boundary vertices [L T-1 ~> m s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open - real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: umask !< A mask foor ice shelf velocity - real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: vmask !< A mask foor ice shelf velocity - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: thickness_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] - !! boundary vertices [L T-1 ~> m s-1]. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: hmask !< A mask indicating which tracer points are - !! partly or fully covered by an ice-shelf - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: h_shelf !< Ice-shelf thickness - type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors - type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_face_mask_bdry !< A boundary-type mask at B-grid u faces [nondim] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_face_mask_bdry !< A boundary-type mask at B-grid v faces [nondim] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open + !! boundary vertices [L T-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open + !! boundary vertices [L T-1 ~> m s-1]. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: umask !< A mask for ice shelf velocity [nondim] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: vmask !< A mask for ice shelf velocity [nondim] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf [nondim] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h_shelf !< Ice-shelf thickness [Z ~> m] + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters character(len=200) :: filename, bc_file, inputdir, icethick_file ! Strings for file/path character(len=200) :: ufcmskbdry_varname, vfcmskbdry_varname, & ubdryv_varname, vbdryv_varname, umask_varname, vmask_varname, & - h_varname,hmsk_varname ! Variable name in file + hmsk_varname ! Variable name in file character(len=40) :: mdl = "initialize_ice_shelf_boundary_from_file" ! This subroutine's name. integer :: i, j, isc, jsc, iec, jec h_bdry_val(:,:) = 0. - thickness_bdry_val(:,:) = 0. call MOM_mesg(" MOM_ice_shelf_init_profile.F90, initialize_b_c_s_from_file: reading b.c.s") @@ -526,9 +519,6 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask call get_param(PF, mdl, "ICE_THICKNESS_FILE", icethick_file, & "The file from which the ice-shelf thickness is read.", & default="ice_shelf_thick.nc") -! call get_param(PF, mdl, "ICE_THICKNESS_VARNAME", h_varname, & -! "The name of the thickness variable in ICE_THICKNESS_FILE.", & -! default="h_shelf") call get_param(PF, mdl, "ICE_THICKNESS_MASK_VARNAME", hmsk_varname, & "The name of the icethickness mask variable in ICE_THICKNESS_FILE.", & default="h_mask") @@ -557,24 +547,24 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask " initialize_ice_shelf_velocity_from_file: Unable to open "//trim(filename)) - call MOM_read_data(filename, trim(ufcmskbdry_varname),u_face_mask_bdry, G%Domain,position=CORNER,scale=1.0) - call MOM_read_data(filename,trim(vfcmskbdry_varname), v_face_mask_bdry, G%Domain, position=CORNER,scale=1.0) - call MOM_read_data(filename,trim(ubdryv_varname), u_bdry_val, G%Domain, position=CORNER,scale=1.0) - call MOM_read_data(filename,trim(vbdryv_varname), v_bdry_val, G%Domain, position=CORNER,scale=1.) - call MOM_read_data(filename,trim(umask_varname), umask, G%Domain, position=CORNER,scale=1.) - call MOM_read_data(filename,trim(vmask_varname), vmask, G%Domain, position=CORNER,scale=1.) - filename = trim(inputdir)//trim(icethick_file) + call MOM_read_data(filename, trim(ufcmskbdry_varname), u_face_mask_bdry, G%Domain, position=CORNER, & + scale=1.) + call MOM_read_data(filename, trim(vfcmskbdry_varname), v_face_mask_bdry, G%Domain, position=CORNER, & + scale=1.) + call MOM_read_data(filename, trim(ubdryv_varname), u_bdry_val, G%Domain, position=CORNER, scale=US%m_s_to_L_T) + call MOM_read_data(filename, trim(vbdryv_varname), v_bdry_val, G%Domain, position=CORNER, scale=US%m_s_to_L_T) + call MOM_read_data(filename, trim(umask_varname), umask, G%Domain, position=CORNER, scale=1.) + call MOM_read_data(filename, trim(vmask_varname), vmask, G%Domain, position=CORNER, scale=1.) + filename = trim(inputdir)//trim(icethick_file) -! call MOM_read_data(filename, trim(h_varname), h_shelf, G%Domain, scale=US%m_to_Z) - call MOM_read_data(filename,trim(hmsk_varname), hmask, G%Domain, scale=1.) + call MOM_read_data(filename,trim(hmsk_varname), hmask, G%Domain, scale=1.) isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec do j=jsc,jec do i=isc,iec - if (hmask(i,j) == 3.) then - thickness_bdry_val(i,j) = h_shelf(i,j) - h_bdry_val(i,j) = h_shelf(i,j) - endif + if (hmask(i,j) == 3.) then + h_bdry_val(i,j) = h_shelf(i,j) + endif enddo enddo @@ -583,13 +573,15 @@ end subroutine initialize_ice_shelf_boundary_from_file !> Initialize ice basal friction subroutine initialize_ice_C_basal_friction(C_basal_friction, G, US, PF) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: C_basal_friction !< Ice-stream basal friction + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: C_basal_friction !< Ice-stream basal friction + !! in units of [R L Z T-2 (s m-1)^n_basal_fric ~> Pa (s m-1)^n_basal_fric] type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters ! integer :: i, j - real :: C_friction + real :: C_friction ! Constant ice-stream basal friction in units of + ! [R L Z T-2 (s m-1)^n_basal_fric ~> Pa (s m-1)^n_basal_fric] character(len=40) :: mdl = "initialize_ice_basal_friction" ! This subroutine's name. character(len=200) :: config character(len=200) :: varname @@ -602,43 +594,45 @@ subroutine initialize_ice_C_basal_friction(C_basal_friction, G, US, PF) if (trim(config)=="CONSTANT") then call get_param(PF, mdl, "BASAL_FRICTION_COEFF", C_friction, & - "Coefficient in sliding law.", units="Pa (m s-1)^(n_basal_fric)", default=5.e10) + "Coefficient in sliding law.", units="Pa (s m-1)^(n_basal_fric)", default=5.e10, scale=US%Pa_to_RLZ_T2) - C_basal_friction(:,:) = C_friction + C_basal_friction(:,:) = C_friction elseif (trim(config)=="FILE") then - call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading friction coefficients") - call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") - inputdir = slasher(inputdir) + call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading friction coefficients") + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) - call get_param(PF, mdl, "BASAL_FRICTION_FILE", C_friction_file, & - "The file from which basal friction coefficients are read.", & - default="ice_basal_friction.nc") - filename = trim(inputdir)//trim(C_friction_file) - call log_param(PF, mdl, "INPUTDIR/BASAL_FRICTION_FILE", filename) + call get_param(PF, mdl, "BASAL_FRICTION_FILE", C_friction_file, & + "The file from which basal friction coefficients are read.", & + default="ice_basal_friction.nc") + filename = trim(inputdir)//trim(C_friction_file) + call log_param(PF, mdl, "INPUTDIR/BASAL_FRICTION_FILE", filename) - call get_param(PF, mdl, "BASAL_FRICTION_VARNAME", varname, & + call get_param(PF, mdl, "BASAL_FRICTION_VARNAME", varname, & "The variable to use in basal traction.", & default="tau_b_beta") if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & " initialize_ice_basal_friction_from_file: Unable to open "//trim(filename)) - call MOM_read_data(filename,trim(varname),C_basal_friction,G%Domain) + call MOM_read_data(filename, trim(varname), C_basal_friction, G%Domain, scale=US%Pa_to_RLZ_T2) endif end subroutine -!> Initialize ice basal friction -subroutine initialize_ice_AGlen(AGlen, G, US, PF) +!> Initialize ice-stiffness parameter +subroutine initialize_ice_AGlen(AGlen, ice_viscosity_compute, G, US, PF) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: AGlen !< The ice-stiffness parameter A_Glen + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: AGlen !< The ice-stiffness parameter A_Glen, often in [Pa-3 s-1] + character(len=40) :: ice_viscosity_compute !< Specifies whether the ice viscosity is computed internally + !! according to Glen's flow law; is constant (for debugging purposes) + !! or using observed strain rates and read from a file type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters -! integer :: i, j - real :: A_Glen + real :: A_Glen ! Ice-stiffness parameter, often in [Pa-3 s-1] character(len=40) :: mdl = "initialize_ice_stiffness" ! This subroutine's name. character(len=200) :: config character(len=200) :: varname @@ -651,28 +645,80 @@ subroutine initialize_ice_AGlen(AGlen, G, US, PF) if (trim(config)=="CONSTANT") then call get_param(PF, mdl, "A_GLEN", A_Glen, & - "Ice-stiffness parameter.", units="Pa-3 s-1", default=2.261e-25) + "Ice-stiffness parameter.", units="Pa-n_g s-1", default=2.261e-25) - AGlen(:,:) = A_Glen + AGlen(:,:) = A_Glen elseif (trim(config)=="FILE") then - call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading ice-stiffness parameter") - call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") - inputdir = slasher(inputdir) + call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading ice-stiffness parameter") + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) - call get_param(PF, mdl, "ICE_STIFFNESS_FILE", AGlen_file, & + call get_param(PF, mdl, "ICE_STIFFNESS_FILE", AGlen_file, & "The file from which the ice-stiffness is read.", & default="ice_AGlen.nc") - filename = trim(inputdir)//trim(AGlen_file) - call log_param(PF, mdl, "INPUTDIR/ICE_STIFFNESS_FILE", filename) - call get_param(PF, mdl, "A_GLEN_VARNAME", varname, & + filename = trim(inputdir)//trim(AGlen_file) + call log_param(PF, mdl, "INPUTDIR/ICE_STIFFNESS_FILE", filename) + call get_param(PF, mdl, "A_GLEN_VARNAME", varname, & "The variable to use as ice-stiffness.", & default="A_GLEN") if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & " initialize_ice_stiffness_from_file: Unable to open "//trim(filename)) - call MOM_read_data(filename,trim(varname),AGlen,G%Domain) + if (trim(ice_viscosity_compute) == "OBS") then + ! AGlen is the ice viscosity [R L2 T-1 ~> Pa s] computed from obs and read from a file + call MOM_read_data(filename, trim(varname), AGlen, G%Domain, scale=US%Pa_to_RL2_T2*US%s_to_T) + else + ! AGlen is the ice stiffness parameter [Pa-n_g s-1] + call MOM_read_data(filename, trim(varname), AGlen, G%Domain) + endif endif -end subroutine +end subroutine initialize_ice_AGlen + +!> Initialize ice surface mass balance field that is held constant over time +subroutine initialize_ice_SMB(SMB, G, US, PF) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: SMB !< Ice surface mass balance parameter, often in [R Z T-1 ~> kg m-2 s-1] + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters + + real :: SMB_val ! Constant ice surface mass balance parameter, often in [R Z T-1 ~> kg m-2 s-1] + character(len=40) :: mdl = "initialize_ice_SMB" ! This subroutine's name. + character(len=200) :: config + character(len=200) :: varname + character(len=200) :: inputdir, filename, SMB_file + + call get_param(PF, mdl, "ICE_SMB_CONFIG", config, & + "This specifies how the initial ice surface mass balance parameter is specified. "//& + "Valid values are: CONSTANT and FILE.", & + default="CONSTANT") + + if (trim(config)=="CONSTANT") then + call get_param(PF, mdl, "SMB", SMB_val, & + "Surface mass balance.", units="kg m-2 s-1", default=0.0, scale=US%kg_m2s_to_RZ_T) + + SMB(:,:) = SMB_val + + elseif (trim(config)=="FILE") then + call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading SMB parameter") + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + + call get_param(PF, mdl, "ICE_SMB_FILE", SMB_file, & + "The file from which the ice surface mass balance is read.", & + default="ice_SMB.nc") + filename = trim(inputdir)//trim(SMB_file) + call log_param(PF, mdl, "INPUTDIR/ICE_SMB_FILE", filename) + call get_param(PF, mdl, "ICE_SMB_VARNAME", varname, & + "The variable to use as surface mass balance.", & + default="SMB") + + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " initialize_ice_SMV_from_file: Unable to open "//trim(filename)) + call MOM_read_data(filename,trim(varname), SMB, G%Domain, scale=US%kg_m2s_to_RZ_T) + + endif +end subroutine initialize_ice_SMB end module MOM_ice_shelf_initialize diff --git a/src/ice_shelf/MOM_ice_shelf_state.F90 b/src/ice_shelf/MOM_ice_shelf_state.F90 index ed3b419c9a..10a3336871 100644 --- a/src/ice_shelf/MOM_ice_shelf_state.F90 +++ b/src/ice_shelf/MOM_ice_shelf_state.F90 @@ -1,10 +1,12 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Implements the thermodynamic aspects of ocean / ice-shelf interactions, !! along with a crude placeholder for a later implementation of full !! ice shelf dynamics, all using the MOM framework and coding style. module MOM_ice_shelf_state -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_ROUTINE use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid @@ -24,15 +26,17 @@ module MOM_ice_shelf_state real, pointer, dimension(:,:) :: & mass_shelf => NULL(), & !< The mass per unit area of the ice shelf or sheet [R Z ~> kg m-2]. area_shelf_h => NULL(), & !< The area per cell covered by the ice shelf [L2 ~> m2]. + melt_mask => NULL(), & !< Mask is > 0 where melting is allowed [nondim] h_shelf => NULL(), & !< the thickness of the shelf [Z ~> m], redundant with mass but may !! make the code more readable + dhdt_shelf => NULL(), & !< the change in thickness of the shelf over time [Z T-1 ~> m s-1] hmask => NULL(),& !< Mask used to indicate ice-covered or partiall-covered cells !! 1: fully covered, solve for velocity here (for now all !! ice-covered cells are treated the same, this may change) !! 2: partially covered, do not solve for velocity !! 0: no ice in cell. - !! 3: bdry condition on thickness set - not in computational domain - !! -2 : default (out of computational boundary, and) not = 3 + !! 3: bdry condition on thickness set + !! -2 : default (out of computational boundary) !! NOTE: hmask will change over time and NEEDS TO BE MAINTAINED !! otherwise the wrong nodes will be included in velocity calcs. @@ -44,10 +48,14 @@ module MOM_ice_shelf_state !! ocean-ice interface [R Z T-1 ~> kg m-2 s-1]. tflux_shelf => NULL(), & !< The downward diffusive heat flux in the ice !! shelf at the ice-ocean interface [Q R Z T-1 ~> W m-2]. - - tfreeze => NULL() !< The freezing point potential temperature - !! an the ice-ocean interface [degC]. - + tfreeze => NULL(), & !< The freezing point potential temperature + !! at the ice-ocean interface [C ~> degC]. + frazil => NULL(), & !< Accumulated heating [J m-2] from frazil formation in the ocean + !! under ice-shelf cells + !only active when calve_ice_shelf_bergs=true: + calving => NULL(), & !< The mass flux per unit area of the ice shelf to convert to + !! bergs [R Z T-1 ~> kg m-2 s-1]. + calving_hflx => NULL() !< Calving heat flux [Q R Z T-1 ~> W m-2]. end type ice_shelf_state contains @@ -69,7 +77,9 @@ subroutine ice_shelf_state_init(ISS, G) allocate(ISS%mass_shelf(isd:ied,jsd:jed), source=0.0 ) allocate(ISS%area_shelf_h(isd:ied,jsd:jed), source=0.0 ) + allocate(ISS%melt_mask(isd:ied,jsd:jed), source=1.0 ) allocate(ISS%h_shelf(isd:ied,jsd:jed), source=0.0 ) + allocate(ISS%dhdt_shelf(isd:ied,jsd:jed), source=0.0 ) allocate(ISS%hmask(isd:ied,jsd:jed), source=-2.0 ) allocate(ISS%tflux_ocn(isd:ied,jsd:jed), source=0.0 ) @@ -78,6 +88,9 @@ subroutine ice_shelf_state_init(ISS, G) allocate(ISS%tflux_shelf(isd:ied,jsd:jed), source=0.0 ) allocate(ISS%tfreeze(isd:ied,jsd:jed), source=0.0 ) + allocate(ISS%frazil(isd:ied,jsd:jed), source=0.0 ) + allocate(ISS%calving(isd:ied,jsd:jed), source=0.0 ) + allocate(ISS%calving_hflx(isd:ied,jsd:jed), source=0.0 ) end subroutine ice_shelf_state_init @@ -87,10 +100,12 @@ subroutine ice_shelf_state_end(ISS) if (.not.associated(ISS)) return - deallocate(ISS%mass_shelf, ISS%area_shelf_h, ISS%h_shelf, ISS%hmask) + deallocate(ISS%mass_shelf, ISS%area_shelf_h, ISS%h_shelf, ISS%dhdt_shelf, ISS%hmask) deallocate(ISS%tflux_ocn, ISS%water_flux, ISS%salt_flux, ISS%tflux_shelf) - deallocate(ISS%tfreeze) + deallocate(ISS%tfreeze, ISS%frazil) + + deallocate(ISS%calving, ISS%calving_hflx) deallocate(ISS) diff --git a/src/ice_shelf/MOM_marine_ice.F90 b/src/ice_shelf/MOM_marine_ice.F90 index 64d4dbfdab..3eec43e335 100644 --- a/src/ice_shelf/MOM_marine_ice.F90 +++ b/src/ice_shelf/MOM_marine_ice.F90 @@ -1,9 +1,11 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Routines incorporating the effects of marine ice (sea-ice and icebergs) into !! the ocean model dynamics and thermodynamics. module MOM_marine_ice -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_constants, only : hlf use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl use MOM_domains, only : pass_var, pass_vector, AGRID, BGRID_NE, CGRID_NE @@ -28,7 +30,7 @@ module MOM_marine_ice type, public :: marine_ice_CS ; private real :: kv_iceberg !< The viscosity of the icebergs [L4 Z-2 T-1 ~> m2 s-1] (for ice rigidity) real :: berg_area_threshold !< Fraction of grid cell which iceberg must occupy - !! so that fluxes below are set to zero. (0.5 is a + !! so that fluxes below are set to zero [nondim]. (0.5 is a !! good value to use.) Not applied for negative values. real :: latent_heat_fusion !< Latent heat of fusion [Q ~> J kg-1] real :: density_iceberg !< A typical density of icebergs [R ~> kg m-3] (for ice rigidity) @@ -48,7 +50,7 @@ subroutine iceberg_forces(G, forces, use_ice_shelf, sfc_state, time_step, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. logical, intent(in) :: use_ice_shelf !< If true, this configuration uses ice shelves. - real, intent(in) :: time_step !< The coupling time step [s]. + real, intent(in) :: time_step !< The coupling time step [T ~> s]. type(marine_ice_CS), pointer :: CS !< Pointer to the control structure for MOM_marine_ice real :: kv_rho_ice ! The viscosity of ice divided by its density [L4 Z-2 T-1 R-1 ~> m5 kg-1 s-1]. @@ -80,7 +82,7 @@ subroutine iceberg_forces(G, forces, use_ice_shelf, sfc_state, time_step, CS) do j=js,je ; do I=is-1,ie if ((G%areaT(i,j) + G%areaT(i+1,j) > 0.0)) & ! .and. (G%dxdy_u(I,j) > 0.0)) & forces%frac_shelf_u(I,j) = forces%frac_shelf_u(I,j) + & - (forces%area_berg(i,j)*G%areaT(i,j) + forces%area_berg(i+1,j)*G%areaT(i+1,j)) / & + ((forces%area_berg(i,j)*G%areaT(i,j)) + (forces%area_berg(i+1,j)*G%areaT(i+1,j))) / & (G%areaT(i,j) + G%areaT(i+1,j)) forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + kv_rho_ice * & min(forces%mass_berg(i,j), forces%mass_berg(i+1,j)) @@ -88,7 +90,7 @@ subroutine iceberg_forces(G, forces, use_ice_shelf, sfc_state, time_step, CS) do J=js-1,je ; do i=is,ie if ((G%areaT(i,j) + G%areaT(i,j+1) > 0.0)) & ! .and. (G%dxdy_v(i,J) > 0.0)) & forces%frac_shelf_v(i,J) = forces%frac_shelf_v(i,J) + & - (forces%area_berg(i,j)*G%areaT(i,j) + forces%area_berg(i,j+1)*G%areaT(i,j+1)) / & + ((forces%area_berg(i,j)*G%areaT(i,j)) + (forces%area_berg(i,j+1)*G%areaT(i,j+1))) / & (G%areaT(i,j) + G%areaT(i,j+1)) forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) + kv_rho_ice * & min(forces%mass_berg(i,j), forces%mass_berg(i,j+1)) @@ -106,11 +108,11 @@ subroutine iceberg_fluxes(G, US, fluxes, use_ice_shelf, sfc_state, time_step, CS type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. logical, intent(in) :: use_ice_shelf !< If true, this configuration uses ice shelves. - real, intent(in) :: time_step !< The coupling time step [s]. + real, intent(in) :: time_step !< The coupling time step [T ~> s]. type(marine_ice_CS), pointer :: CS !< Pointer to the control structure for MOM_marine_ice real :: fraz ! refreezing rate [R Z T-1 ~> kg m-2 s-1] - real :: I_dt_LHF ! The inverse of the timestep times the latent heat of fusion times [Q-1 T-1 ~> kg J-1 s-1]. + real :: I_dt_LHF ! The inverse of the timestep times the latent heat of fusion [Q-1 T-1 ~> kg J-1 s-1]. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed @@ -138,7 +140,7 @@ subroutine iceberg_fluxes(G, US, fluxes, use_ice_shelf, sfc_state, time_step, CS !Zero'ing out other fluxes under the tabular icebergs if (CS%berg_area_threshold >= 0.) then - I_dt_LHF = 1.0 / (US%s_to_T*time_step * CS%latent_heat_fusion) + I_dt_LHF = 1.0 / (time_step * CS%latent_heat_fusion) do j=jsd,jed ; do i=isd,ied if (fluxes%frac_shelf_h(i,j) > CS%berg_area_threshold) then ! Only applying for ice shelf covering most of cell. @@ -176,8 +178,9 @@ subroutine marine_ice_init(Time, G, param_file, diag, CS) type(param_file_type), intent(in) :: param_file !< Runtime parameter handles type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(marine_ice_CS), pointer :: CS !< Pointer to the control structure for MOM_marine_ice -! This include declares and sets the variable "version". -#include "version_variable.h" + + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_marine_ice" ! This module's name. if (associated(CS)) then @@ -197,8 +200,8 @@ subroutine marine_ice_init(Time, G, param_file, diag, CS) "The latent heat of fusion.", units="J/kg", default=hlf, scale=G%US%J_kg_to_Q) call get_param(param_file, mdl, "BERG_AREA_THRESHOLD", CS%berg_area_threshold, & "Fraction of grid cell which iceberg must occupy, so that fluxes "//& - "below berg are set to zero. Not applied for negative "//& - "values.", units="non-dim", default=-1.0) + "below berg are set to zero. Not applied for negative values.", & + units="nondim", default=-1.0) end subroutine marine_ice_init diff --git a/src/ice_shelf/user_shelf_init.F90 b/src/ice_shelf/user_shelf_init.F90 index 9635f51262..57460227c5 100644 --- a/src/ice_shelf/user_shelf_init.F90 +++ b/src/ice_shelf/user_shelf_init.F90 @@ -1,9 +1,11 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> This module specifies the initial values and evolving properties of the !! MOM6 ice shelf, using user-provided code. module user_shelf_init -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type @@ -57,12 +59,7 @@ subroutine USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, !! being started from a restart file. ! This subroutine sets up the initial mass and area covered by the ice shelf. - real :: max_draft ! The maximum ocean draft of the ice shelf [Z ~> m]. - real :: min_draft ! The minimum ocean draft of the ice shelf [Z ~> m]. - real :: flat_shelf_width ! The range over which the shelf is min_draft thick. - real :: c1 ! The maximum depths in m. character(len=40) :: mdl = "USER_initialize_shelf_mass" ! This subroutine's name. - integer :: i, j ! call MOM_error(FATAL, "USER_shelf_init.F90, USER_set_shelf_mass: " // & ! "Unmodified user routine called - you must edit the routine to use it") @@ -75,7 +72,7 @@ subroutine USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, call get_param(param_file, mdl, "RHO_0", CS%Rho_ocean, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& + "properties, or with BOUSSINESQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "SHELF_MAX_DRAFT", CS%max_draft, & @@ -99,18 +96,19 @@ end subroutine USER_initialize_shelf_mass subroutine USER_init_ice_thickness(h_shelf, area_shelf_h, hmask, G, US, param_file) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZDI_(G),SZDJ_(G)), & - intent(out) :: h_shelf !< The ice shelf thickness [m]. + intent(out) :: h_shelf !< The ice shelf thickness [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(out) :: area_shelf_h !< The area per cell covered by the ice shelf [L2 ~> m2]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(out) :: hmask !< A mask indicating which tracer points are - !! partly or fully covered by an ice-shelf + !! partly or fully covered by an ice-shelf [nondim] type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters ! This subroutine initializes the ice shelf thickness. Currently it does so ! calling USER_initialize_shelf_mass, but this can be revised as needed. - real, dimension(SZI_(G),SZJ_(G)) :: mass_shelf + real, dimension(SZI_(G),SZJ_(G)) :: mass_shelf ! The ice shelf mass per unit area averaged + ! over the full ocean cell [R Z ~> kg m-2]. type(user_ice_shelf_CS), pointer :: CS => NULL() call USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, US, CS, param_file, .true.) @@ -129,13 +127,15 @@ subroutine USER_update_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, C intent(inout) :: h_shelf !< The ice shelf thickness [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: hmask !< A mask indicating which tracer points are - !! partly or fully covered by an ice-shelf + !! partly or fully covered by an ice-shelf [nondim] type(user_ice_shelf_CS), pointer :: CS !< A pointer to the user ice shelf control structure type(time_type), intent(in) :: Time !< The current model time logical, intent(in) :: new_sim !< If true, this the start of a new run. - real :: c1, edge_pos, slope_pos + real :: c1 ! The inverse of the range over which the shelf slopes [km-1] + real :: edge_pos ! The time-evolving position the ice shelf edge [km] + real :: slope_pos ! The time-evolving position of the start of the ice shelf slope [km] integer :: i, j edge_pos = CS%pos_shelf_edge_0 + CS%shelf_speed*(time_type_to_real(Time) / 86400.0) diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index 286dfa7d95..571a365937 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -1,16 +1,18 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Initializes fixed aspects of the related to its vertical coordinate. module MOM_coord_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_debugging, only : chksum use MOM_EOS, only : calculate_density, EOS_type use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : get_param, read_param, log_param, param_file_type, log_version -use MOM_io, only : close_file, create_file, file_type, fieldtype, file_exists -use MOM_io, only : MOM_read_data, MOM_write_field, vardesc, var_desc -use MOM_io, only : SINGLE_FILE, MULTIPLE +use MOM_io, only : create_MOM_file, file_exists +use MOM_io, only : MOM_netCDF_file, MOM_field +use MOM_io, only : MOM_read_data, MOM_write_field, vardesc, var_desc, SINGLE_FILE use MOM_string_functions, only : slasher, uppercase use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs @@ -20,7 +22,7 @@ module MOM_coord_initialization implicit none ; private -public MOM_initialize_coord +public MOM_initialize_coord, write_vertgrid_file ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -33,20 +35,18 @@ module MOM_coord_initialization !> MOM_initialize_coord sets up time-invariant quantities related to MOM6's !! vertical coordinate. -subroutine MOM_initialize_coord(GV, US, PF, write_geom, output_dir, tv, max_depth) +subroutine MOM_initialize_coord(GV, US, PF, tv, max_depth) type(verticalGrid_type), intent(inout) :: GV !< Ocean vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: PF !< A structure indicating the open file !! to parse for model parameter values. - logical, intent(in) :: write_geom !< If true, write grid geometry files. - character(len=*), intent(in) :: output_dir !< The directory into which to write files. type(thermo_var_ptrs), intent(inout) :: tv !< The thermodynamic variable structure. real, intent(in) :: max_depth !< The ocean's maximum depth [Z ~> m]. ! Local character(len=200) :: config logical :: debug -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" integer :: nz nz = GV%ke @@ -107,12 +107,9 @@ subroutine MOM_initialize_coord(GV, US, PF, write_geom, output_dir, tv, max_dept if (debug) call chksum(US%m_to_Z*US%L_to_m**2*US%s_to_T**2*GV%g_prime(:), "MOM_initialize_coord: g_prime ", 1, nz) call setVerticalGridAxes( GV%Rlay, GV, scale=US%R_to_kg_m3 ) -! Copy the maximum depth across from the input argument + ! Copy the maximum depth across from the input argument GV%max_depth = max_depth -! Write out all of the grid data used by this run. - if (write_geom) call write_vertgrid_file(GV, US, PF, output_dir) - call callTree_leave('MOM_initialize_coord()') end subroutine MOM_initialize_coord @@ -131,6 +128,7 @@ subroutine set_coord_from_gprime(Rlay, g_prime, GV, US, param_file) ! Local variables real :: g_int ! Reduced gravities across the internal interfaces [L2 Z-1 T-2 ~> m s-2]. real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. + real :: Rlay_Ref ! The target density of the surface layer [R ~> kg m-3]. character(len=40) :: mdl = "set_coord_from_gprime" ! This subroutine's name. integer :: k, nz nz = GV%ke @@ -143,11 +141,20 @@ subroutine set_coord_from_gprime(Rlay, g_prime, GV, US, param_file) call get_param(param_file, mdl, "GINT", g_int, & "The reduced gravity across internal interfaces.", & units="m s-2", fail_if_missing=.true., scale=US%m_s_to_L_T**2*US%Z_to_m) + call get_param(param_file, mdl, "LIGHTEST_DENSITY", Rlay_Ref, & + "The reference potential density used for layer 1.", & + units="kg m-3", default=US%R_to_kg_m3*GV%Rho0, scale=US%kg_m3_to_R) g_prime(1) = g_fs do k=2,nz ; g_prime(k) = g_int ; enddo - Rlay(1) = GV%Rho0 - do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo + Rlay(1) = Rlay_Ref + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo + else + do k=2,nz + Rlay(k) = Rlay(k-1) * ((GV%g_Earth + 0.5*g_prime(k)) / (GV%g_Earth - 0.5*g_prime(k))) + enddo + endif call callTree_leave(trim(mdl)//'()') @@ -189,9 +196,15 @@ subroutine set_coord_from_layer_density(Rlay, g_prime, GV, US, param_file) enddo ! These statements set the interface reduced gravities. ! g_prime(1) = g_fs - do k=2,nz - g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) - enddo + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz + g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) + enddo + else + do k=2,nz + g_prime(k) = 2.0*GV%g_Earth * (Rlay(k) - Rlay(k-1)) / (Rlay(k) + Rlay(k-1)) + enddo + endif call callTree_leave(trim(mdl)//'()') end subroutine set_coord_from_layer_density @@ -210,8 +223,8 @@ subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, US, param_file, eqn_of_state !! [R L2 T-2 ~> Pa]. ! Local variables - real :: T_ref ! Reference temperature - real :: S_ref ! Reference salinity + real :: T_ref ! Reference temperature [C ~> degC] + real :: S_ref ! Reference salinity [S ~> ppt] real :: g_int ! Reduced gravities across the internal interfaces [L2 Z-1 T-2 ~> m s-2]. real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. character(len=40) :: mdl = "set_coord_from_TS_ref" ! This subroutine's name. @@ -220,11 +233,11 @@ subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, US, param_file, eqn_of_state call callTree_enter(trim(mdl)//"(), MOM_coord_initialization.F90") - call get_param(param_file, mdl, "T_REF", T_Ref, & - "The initial temperature of the lightest layer.", units="degC", & - fail_if_missing=.true.) - call get_param(param_file, mdl, "S_REF", S_Ref, & - "The initial salinities.", units="PSU", default=35.0) + call get_param(param_file, mdl, "T_REF", T_ref, & + "The initial temperature of the lightest layer.", & + units="degC", scale=US%degC_to_C, fail_if_missing=.true.) + call get_param(param_file, mdl, "S_REF", S_ref, & + "The initial salinities.", units="ppt", default=35.0, scale=US%ppt_to_S) call get_param(param_file, mdl, "GFS", g_fs, & "The reduced gravity at the free surface.", units="m s-2", & default=GV%g_Earth*US%L_T_to_m_s**2*US%m_to_Z, scale=US%m_s_to_L_T**2*US%Z_to_m) @@ -242,7 +255,13 @@ subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, US, param_file, eqn_of_state call calculate_density(T_ref, S_ref, P_ref, Rlay(1), eqn_of_state) ! These statements set the layer densities. ! - do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo + else + do k=2,nz + Rlay(k) = Rlay(k-1) * ((GV%g_Earth + 0.5*g_prime(k)) / (GV%g_Earth - 0.5*g_prime(k))) + enddo + endif call callTree_leave(trim(mdl)//'()') end subroutine set_coord_from_TS_ref @@ -260,11 +279,15 @@ subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, eqn_of_s !! [R L2 T-2 ~> Pa]. ! Local variables - real, dimension(GV%ke) :: T0, S0, Pref + real, dimension(GV%ke) :: T0 ! A profile of temperatures [C ~> degC] + real, dimension(GV%ke) :: S0 ! A profile of salinities [S ~> ppt] + real, dimension(GV%ke) :: Pref ! A array of reference pressures [R L2 T-2 ~> Pa] real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. integer :: k, nz character(len=40) :: mdl = "set_coord_from_TS_profile" ! This subroutine's name. character(len=200) :: filename, coord_file, inputdir ! Strings for file/path + character(len=64) :: temp_var, salt_var ! Temperature and salinity names in files + nz = GV%ke call callTree_enter(trim(mdl)//"(), MOM_coord_initialization.F90") @@ -273,15 +296,21 @@ subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, eqn_of_s "The reduced gravity at the free surface.", units="m s-2", & default=GV%g_Earth*US%L_T_to_m_s**2*US%m_to_Z, scale=US%m_s_to_L_T**2*US%Z_to_m) call get_param(param_file, mdl, "COORD_FILE", coord_file, & - "The file from which the coordinate temperatures and "//& - "salinities are read.", fail_if_missing=.true.) + "The file from which the coordinate temperatures and salinities are read.", & + fail_if_missing=.true.) + call get_param(param_file, mdl, "TEMP_COORD_VAR", temp_var, & + "The coordinate reference profile variable name for potential temperature.", & + default="PTEMP") + call get_param(param_file, mdl, "SALT_COORD_VAR", salt_var, & + "The coordinate reference profile variable name for salinity.", & + default="SALT") call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") filename = trim(slasher(inputdir))//trim(coord_file) call log_param(param_file, mdl, "INPUTDIR/COORD_FILE", filename) - call MOM_read_data(filename, "PTEMP", T0(:)) - call MOM_read_data(filename, "SALT", S0(:)) + call MOM_read_data(filename, temp_var, T0(:), scale=US%degC_to_C) + call MOM_read_data(filename, salt_var, S0(:), scale=US%ppt_to_S) if (.not.file_exists(filename)) call MOM_error(FATAL, & " set_coord_from_TS_profile: Unable to open " //trim(filename)) @@ -289,7 +318,15 @@ subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, eqn_of_s g_prime(1) = g_fs do k=1,nz ; Pref(k) = P_Ref ; enddo call calculate_density(T0, S0, Pref, Rlay, eqn_of_state, (/1,nz/) ) - do k=2,nz; g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) ; enddo + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz + g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) + enddo + else + do k=2,nz + g_prime(k) = 2.0*GV%g_Earth * (Rlay(k) - Rlay(k-1)) / (Rlay(k) + Rlay(k-1)) + enddo + endif call callTree_leave(trim(mdl)//'()') end subroutine set_coord_from_TS_profile @@ -307,9 +344,13 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, eqn_of_sta !! [R L2 T-2 ~> Pa]. ! Local variables - real, dimension(GV%ke) :: T0, S0, Pref - real :: S_Ref, S_Light, S_Dense ! Salinity range parameters [ppt]. - real :: T_Ref, T_Light, T_Dense ! Temperature range parameters [degC]. + real, dimension(GV%ke) :: T0 ! A profile of temperatures [C ~> degC] + real, dimension(GV%ke) :: S0 ! A profile of salinities [S ~> ppt] + real, dimension(GV%ke) :: Pref ! A array of reference pressures [R L2 T-2 ~> Pa] + real :: S_Ref ! Default salinity range parameters [S ~> ppt]. + real :: T_Ref ! Default temperature range parameters [C ~> degC]. + real :: S_Light, S_Dense ! Salinity range parameters [S ~> ppt]. + real :: T_Light, T_Dense ! Temperature range parameters [C ~> degC]. real :: res_rat ! The ratio of density space resolution in the denser part ! of the range to that in the lighter part of the range. ! Setting this greater than 1 increases the resolution for @@ -318,28 +359,32 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, eqn_of_sta real :: a1, frac_dense, k_frac ! Nondimensional temporary variables [nondim] integer :: k, nz, k_light character(len=40) :: mdl = "set_coord_from_TS_range" ! This subroutine's name. - character(len=200) :: filename, coord_file, inputdir ! Strings for file/path + nz = GV%ke call callTree_enter(trim(mdl)//"(), MOM_coord_initialization.F90") call get_param(param_file, mdl, "T_REF", T_Ref, & - "The default initial temperatures.", units="degC", default=10.0) + "The default initial temperatures.", & + units="degC", default=10.0, scale=US%degC_to_C) call get_param(param_file, mdl, "TS_RANGE_T_LIGHT", T_Light, & "The initial temperature of the lightest layer when "//& - "COORD_CONFIG is set to ts_range.", units="degC", default=T_Ref) + "COORD_CONFIG is set to ts_range.", & + units="degC", default=US%C_to_degC*T_Ref, scale=US%degC_to_C) call get_param(param_file, mdl, "TS_RANGE_T_DENSE", T_Dense, & "The initial temperature of the densest layer when "//& - "COORD_CONFIG is set to ts_range.", units="degC", default=T_Ref) + "COORD_CONFIG is set to ts_range.", & + units="degC", default=US%C_to_degC*T_Ref, scale=US%degC_to_C) call get_param(param_file, mdl, "S_REF", S_Ref, & - "The default initial salinities.", units="PSU", default=35.0) + "The default initial salinities.", & + units="ppt", default=35.0, scale=US%ppt_to_S) call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_Light, & - "The initial lightest salinities when COORD_CONFIG "//& - "is set to ts_range.", default = S_Ref, units="PSU") + "The initial lightest salinities when COORD_CONFIG is set to ts_range.", & + units="ppt", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S) call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_Dense, & - "The initial densest salinities when COORD_CONFIG "//& - "is set to ts_range.", default = S_Ref, units="PSU") + "The initial densest salinities when COORD_CONFIG is set to ts_range.", & + units="ppt", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S) call get_param(param_file, mdl, "TS_RANGE_RESOLN_RATIO", res_rat, & "The ratio of density space resolution in the densest "//& @@ -357,8 +402,8 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, eqn_of_sta k_light = GV%nk_rho_varies + 1 - ! Set T0(k) to range from T_LIGHT to T_DENSE, and simliarly for S0(k). - T0(k_light) = T_light ; S0(k_light) = S_light + ! Set T0(k) to range from T_LIGHT to T_DENSE, and similarly for S0(k). + T0(k_light) = T_Light ; S0(k_light) = S_Light a1 = 2.0 * res_rat / (1.0 + res_rat) do k=k_light+1,nz k_frac = real(k-k_light)/real(nz-k_light) @@ -374,7 +419,15 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, eqn_of_sta do k=k_light-1,1,-1 Rlay(k) = 2.0*Rlay(k+1) - Rlay(k+2) enddo - do k=2,nz ; g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) ; enddo + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz + g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) + enddo + else + do k=2,nz + g_prime(k) = 2.0*GV%g_Earth * (Rlay(k) - Rlay(k-1)) / (Rlay(k) + Rlay(k-1)) + enddo + endif call callTree_leave(trim(mdl)//'()') end subroutine set_coord_from_TS_range @@ -414,10 +467,17 @@ subroutine set_coord_from_file(Rlay, g_prime, GV, US, param_file) if (.not.file_exists(filename)) call MOM_error(FATAL, & " set_coord_from_file: Unable to open "//trim(filename)) - call MOM_read_data(filename, coord_var, Rlay) - do k=1,nz ; Rlay(k) = US%kg_m3_to_R*Rlay(k) ; enddo + call MOM_read_data(filename, coord_var, Rlay, scale=US%kg_m3_to_R) g_prime(1) = g_fs - do k=2,nz ; g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) ; enddo + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz + g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) + enddo + else + do k=2,nz + g_prime(k) = 2.0*GV%g_Earth * (Rlay(k) - Rlay(k-1)) / (Rlay(k) + Rlay(k-1)) + enddo + endif do k=1,nz ; if (g_prime(k) <= 0.0) then call MOM_error(FATAL, "MOM_initialization set_coord_from_file: "//& "Zero or negative g_primes read from variable "//"Layer"//" in file "//& @@ -442,7 +502,8 @@ subroutine set_coord_linear(Rlay, g_prime, GV, US, param_file) ! Local variables character(len=40) :: mdl = "set_coord_linear" ! This subroutine - real :: Rlay_ref, Rlay_range, g_fs + real :: Rlay_ref, Rlay_range ! A reference density and its range [R ~> kg m-3] + real :: g_fs ! The reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2] integer :: k, nz nz = GV%ke @@ -458,7 +519,7 @@ subroutine set_coord_linear(Rlay, g_prime, GV, US, param_file) "The reduced gravity at the free surface.", units="m s-2", & default=GV%g_Earth*US%L_T_to_m_s**2*US%m_to_Z, scale=US%m_s_to_L_T**2*US%Z_to_m) - ! This following sets the target layer densities such that a the + ! This following sets the target layer densities such that the ! surface interface has density Rlay_ref and the bottom ! is Rlay_range larger do k=1,nz @@ -466,9 +527,15 @@ subroutine set_coord_linear(Rlay, g_prime, GV, US, param_file) enddo ! These statements set the interface reduced gravities. g_prime(1) = g_fs - do k=2,nz - g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) - enddo + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz + g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) + enddo + else + do k=2,nz + g_prime(k) = 2.0*GV%g_Earth * (Rlay(k) - Rlay(k-1)) / (Rlay(k) + Rlay(k-1)) + enddo + endif call callTree_leave(trim(mdl)//'()') end subroutine set_coord_linear @@ -485,6 +552,7 @@ subroutine set_coord_to_none(Rlay, g_prime, GV, US, param_file) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters ! Local variables real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. + real :: Rlay_Ref ! The target density of the surface layer [R ~> kg m-3]. character(len=40) :: mdl = "set_coord_to_none" ! This subroutine's name. integer :: k, nz nz = GV%ke @@ -494,11 +562,20 @@ subroutine set_coord_to_none(Rlay, g_prime, GV, US, param_file) call get_param(param_file, mdl, "GFS" , g_fs, & "The reduced gravity at the free surface.", units="m s-2", & default=GV%g_Earth*US%L_T_to_m_s**2*US%m_to_Z, scale=US%m_s_to_L_T**2*US%Z_to_m) + call get_param(param_file, mdl, "LIGHTEST_DENSITY", Rlay_Ref, & + "The reference potential density used for layer 1.", & + units="kg m-3", default=US%R_to_kg_m3*GV%Rho0, scale=US%kg_m3_to_R) g_prime(1) = g_fs do k=2,nz ; g_prime(k) = 0. ; enddo - Rlay(1) = GV%Rho0 - do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo + Rlay(1) = Rlay_Ref + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo + else + do k=2,nz + Rlay(k) = Rlay(k-1) * ((GV%g_Earth + 0.5*g_prime(k)) / (GV%g_Earth - 0.5*g_prime(k))) + enddo + endif call callTree_leave(trim(mdl)//'()') @@ -509,25 +586,26 @@ end subroutine set_coord_to_none subroutine write_vertgrid_file(GV, US, param_file, directory) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - character(len=*), intent(in) :: directory !< The directory into which to place the file. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + character(len=*), intent(in) :: directory !< The directory into which to place the file. ! Local variables character(len=240) :: filepath type(vardesc) :: vars(2) - type(fieldtype) :: fields(2) - type(file_type) :: IO_handle ! The I/O handle of the fileset + type(MOM_field) :: fields(2) + type(MOM_netCDF_file) :: IO_handle ! The I/O handle of the fileset - filepath = trim(directory) // trim("Vertical_coordinate") + filepath = trim(directory) // trim("Vertical_coordinate.nc") vars(1) = var_desc("R","kilogram meter-3","Target Potential Density",'1','L','1') - vars(2) = var_desc("g","meter second-2","Reduced gravity",'1','L','1') + vars(2) = var_desc("g","meter second-2","Reduced gravity",'1','i','1') - call create_file(IO_handle, trim(filepath), vars, 2, fields, SINGLE_FILE, GV=GV) + call create_MOM_file(IO_handle, trim(filepath), vars, 2, fields, & + SINGLE_FILE, GV=GV) - call MOM_write_field(IO_handle, fields(1), GV%Rlay, scale=US%R_to_kg_m3) - call MOM_write_field(IO_handle, fields(2), GV%g_prime, scale=US%L_T_to_m_s**2*US%m_to_Z) + call MOM_write_field(IO_handle, fields(1), GV%Rlay, unscale=US%R_to_kg_m3) + call MOM_write_field(IO_handle, fields(2), GV%g_prime, unscale=US%L_T_to_m_s**2*US%m_to_Z) - call close_file(IO_handle) + call IO_handle%close() end subroutine write_vertgrid_file diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index f0fb1d23f9..605671b0ff 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -1,9 +1,11 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Initializes fixed aspects of the model, such as horizontal grid metrics, !! topography and Coriolis. module MOM_fixed_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_debugging, only : hchksum, qchksum, uvchksum use MOM_domains, only : pass_var use MOM_dyn_horgrid, only : dyn_horgrid_type @@ -23,7 +25,9 @@ module MOM_fixed_initialization use MOM_shared_initialization, only : set_rotation_planetary, set_rotation_beta_plane, initialize_grid_rotation_angle use MOM_shared_initialization, only : reset_face_lengths_named, reset_face_lengths_file, reset_face_lengths_list use MOM_shared_initialization, only : read_face_length_list, set_velocity_depth_max, set_velocity_depth_min -use MOM_shared_initialization, only : compute_global_grid_integrals, write_ocean_geometry_file +use MOM_shared_initialization, only : set_subgrid_topo_at_vel_from_file +use MOM_shared_initialization, only : compute_global_grid_integrals +use MOM_shared_initialization, only : set_meanSL_from_file use MOM_unit_scaling, only : unit_scale_type use user_initialization, only : user_initialize_topography @@ -50,62 +54,89 @@ module MOM_fixed_initialization ! ----------------------------------------------------------------------------- !> MOM_initialize_fixed sets up time-invariant quantities related to MOM6's !! horizontal grid, bathymetry, and the Coriolis parameter. -subroutine MOM_initialize_fixed(G, US, OBC, PF, write_geom, output_dir) +subroutine MOM_initialize_fixed(G, US, OBC, PF) type(dyn_horgrid_type), intent(inout) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ocean_OBC_type), pointer :: OBC !< Open boundary structure. type(param_file_type), intent(in) :: PF !< A structure indicating the open file !! to parse for model parameter values. - logical, intent(in) :: write_geom !< If true, write grid geometry files. - character(len=*), intent(in) :: output_dir !< The directory into which to write files. - ! Local - character(len=200) :: inputdir ! The directory where NetCDF input files are. + ! Local variables character(len=200) :: config + logical :: OBC_projection_bug, open_corners, enable_bugs + logical :: read_porous_file, read_meanSL_file character(len=40) :: mdl = "MOM_fixed_initialization" ! This module's name. + integer :: I, J logical :: debug -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" call callTree_enter("MOM_initialize_fixed(), MOM_fixed_initialization.F90") - call log_version(PF, mdl, version, "") call get_param(PF, mdl, "DEBUG", debug, default=.false.) - call get_param(PF, mdl, "INPUTDIR", inputdir, & - "The directory in which input files are found.", default=".") - inputdir = slasher(inputdir) - ! Set up the parameters of the physical domain (i.e. the grid), G call set_grid_metrics(G, PF, US) + ! Read time mean sea level from file + call get_param(PF, mdl, "READ_MEAN_SEA_LEVEL", read_meanSL_file, & + "If true, use a 2D map for time mean sea level, which is used to calculate "// & + "time mean ocean total thickness.", default=.False.) + if (read_meanSL_file) & + call set_meanSL_from_file(G%meanSL, G, PF, US) + ! Set up the bottom depth, G%bathyT either analytically or from file ! This also sets G%max_depth based on the input parameter MAXIMUM_DEPTH, ! or, if absent, is diagnosed as G%max_depth = max( G%D(:,:) ) - call MOM_initialize_topography(G%bathyT, G%max_depth, G, PF, US) + call MOM_initialize_topography(G%bathyT, G%max_depth, G, PF, US, meanSL=G%meanSL) ! To initialize masks, the bathymetry in halo regions must be filled in call pass_var(G%bathyT, G%Domain) - ! Determine the position of any open boundaries + ! Determine the position of any open boundaries and create OBC call open_boundary_config(G, US, PF, OBC) - ! Make bathymetry consistent with open boundaries - call open_boundary_impose_normal_slope(OBC, G, G%bathyT) - - ! This call sets masks that prohibit flow over any point interpreted as land - call initialize_masks(G, PF, US) - - ! Make OBC mask consistent with land mask - call open_boundary_impose_land_mask(OBC, G, G%areaCu, G%areaCv, US) + ! Make bathymetry (if OBC_PROJECTION_BUG) and masks consistent with open boundaries. + if (associated(OBC)) then + call get_param(PF, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. + call get_param(PF, mdl, "OBC_PROJECTION_BUG", OBC_projection_bug, & + "If false, use only interior ocean points at OBCs to specify several "//& + "calculations at OBC points, and it avoids applying a land mask at the "//& + "bay-like intersection of orthogonal OBC segments. Otherwise the "//& + "calculation of terms like the potential vorticity used in the barotropic "//& + "solver relies on bathymetry or other fields being projected outward across "//& + "OBCs. This option changes answers for some configurations that use OBCs.", & + default=enable_bugs) + open_corners = .not.OBC_projection_bug + + if (OBC_projection_bug .and. read_meanSL_file) & + ! OBC_projection_bug modifies bathyT outside of the open boundaries, so meanSL would have to be + ! modified as well. + call MOM_error(FATAL, "MOM_initialize_fixed: To read mean sea level file, "//& + "OBC_PROJECTION_BUG needs to be False.") + + ! This call sets masks that prohibit flow over any point interpreted as land + if (OBC_projection_bug) & + call open_boundary_impose_normal_slope(OBC, G, G%bathyT) + call initialize_masks(G, PF, US, OBC_dir_u=OBC%segnum_u, OBC_dir_v=OBC%segnum_v, & + open_corner_OBCs=open_corners) + ! Make OBC mask consistent with land mask + call open_boundary_impose_land_mask(OBC, G, G%areaCu, G%areaCv, US) + else + call initialize_masks(G, PF, US) + endif if (debug) then - call hchksum(G%bathyT, 'MOM_initialize_fixed: depth ', G%HI, haloshift=1, scale=US%Z_to_m) + call hchksum(G%bathyT, 'MOM_initialize_fixed: depth ', G%HI, haloshift=1, unscale=US%Z_to_m) call hchksum(G%mask2dT, 'MOM_initialize_fixed: mask2dT ', G%HI) call uvchksum('MOM_initialize_fixed: mask2dC[uv]', G%mask2dCu, & G%mask2dCv, G%HI) call qchksum(G%mask2dBu, 'MOM_initialize_fixed: mask2dBu ', G%HI) endif + ! Set up other fixed quantities + ! Parameters below are logged under "module MOM_fixed_initialization". + call log_version(PF, mdl, version, "") ! Modulate geometric scales according to geography. call get_param(PF, mdl, "CHANNEL_CONFIG", config, & "A parameter that determines which set of channels are \n"//& @@ -142,46 +173,64 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF, write_geom, output_dir) end select endif -! Calculate the value of the Coriolis parameter at the latitude ! -! of the q grid points [T-1 ~> s-1]. + ! Read sub-grid scale topography parameters at velocity points used for porous barrier calculation + ! TODO: The following routine call may eventually be merged as one of the CHANNEL_CONFIG options + call get_param(PF, mdl, "SUBGRID_TOPO_AT_VEL", read_porous_file, & + "If true, use variables from TOPO_AT_VEL_FILE as parameters for porous barrier.", & + default=.False.) + if (read_porous_file) & + call set_subgrid_topo_at_vel_from_file(G, PF, US) + + ! Calculate the value of the Coriolis parameter at the latitude ! + ! of the q grid points [T-1 ~> s-1]. call MOM_initialize_rotation(G%CoriolisBu, G, PF, US=US) -! Calculate the components of grad f (beta) + ! Calculate the components of grad f (beta) call MOM_calculate_grad_Coriolis(G%dF_dx, G%dF_dy, G, US=US) + ! Calculate the square of the Coriolis parameter + do I=G%IsdB,G%IedB ; do J=G%JsdB,G%JedB + G%Coriolis2Bu(I,J) = G%CoriolisBu(I,J)**2 + enddo ; enddo + if (debug) then - call qchksum(G%CoriolisBu, "MOM_initialize_fixed: f ", G%HI, scale=US%s_to_T) - call hchksum(G%dF_dx, "MOM_initialize_fixed: dF_dx ", G%HI, scale=US%m_to_L*US%s_to_T) - call hchksum(G%dF_dy, "MOM_initialize_fixed: dF_dy ", G%HI, scale=US%m_to_L*US%s_to_T) + call qchksum(G%CoriolisBu, "MOM_initialize_fixed: f ", G%HI, unscale=US%s_to_T) + call qchksum(G%Coriolis2Bu, "MOM_initialize_fixed: f2 ", G%HI, unscale=US%s_to_T**2) + call hchksum(G%dF_dx, "MOM_initialize_fixed: dF_dx ", G%HI, unscale=US%m_to_L*US%s_to_T) + call hchksum(G%dF_dy, "MOM_initialize_fixed: dF_dy ", G%HI, unscale=US%m_to_L*US%s_to_T) endif call initialize_grid_rotation_angle(G, PF) -! Compute global integrals of grid values for later use in scalar diagnostics ! + ! Compute global integrals of grid values for later use in scalar diagnostics ! call compute_global_grid_integrals(G, US=US) -! Write out all of the grid data used by this run. - if (write_geom) call write_ocean_geometry_file(G, PF, output_dir, US=US) - call callTree_leave('MOM_initialize_fixed()') end subroutine MOM_initialize_fixed -!> MOM_initialize_topography makes the appropriate call to set up the bathymetry. At this -!! point the topography is in units of [Z ~> m] or [m], depending on the presence of US. -subroutine MOM_initialize_topography(D, max_depth, G, PF, US) +!> MOM_initialize_topography makes the appropriate call to set up the bathymetry in units of [Z ~> m]. +subroutine MOM_initialize_topography(D, max_depth, G, PF, US, meanSL) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth [Z ~> m] or [m] + intent(out) :: D !< Ocean bottom depth [Z ~> m] type(param_file_type), intent(in) :: PF !< Parameter file structure - real, intent(out) :: max_depth !< Maximum depth of model [Z ~> m] or [m] + real, intent(out) :: max_depth !< Maximum depth or geometric thickness, + !! with meanSL present, of model [Z ~> m] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + optional, intent(in) :: meanSL !< Mean sea level [Z ~> m] ! This subroutine makes the appropriate call to set up the bottom depth. ! This is a separate subroutine so that it can be made public and shared with ! the ice-sheet code or other components. ! Local variables + real :: max_depth_default = -1.e9 ! Default value of MAXIMUM_DEPTH parameter [m] character(len=40) :: mdl = "MOM_initialize_topography" ! This subroutine's name. character(len=200) :: config + real, dimension(G%isd:G%ied, G%jsd:G%jed) :: D_meanSL ! depth (positive below meanSL) referenced + ! to meanSL. A temporary field used to diagnose maximum + ! static column thickness. D_meanSL = D + meanSL [Z ~> m]. + integer :: i, j call get_param(PF, mdl, "TOPO_CONFIG", config, & "This specifies how bathymetry is specified: \n"//& @@ -211,7 +260,8 @@ subroutine MOM_initialize_topography(D, max_depth, G, PF, US) " \t dense - Denmark Strait-like dense water formation and overflow.\n"//& " \t USER - call a user modified routine.", & fail_if_missing=.true.) - max_depth = -1.e9*US%m_to_Z ; call read_param(PF, "MAXIMUM_DEPTH", max_depth, scale=US%m_to_Z) + call get_param(PF, mdl, "MAXIMUM_DEPTH", max_depth, units="m", default=max_depth_default, & + scale=US%m_to_Z, do_not_log=.true.) select case ( trim(config) ) case ("file"); call initialize_topography_from_file(D, G, PF, US) case ("flat"); call initialize_topography_named(D, G, PF, config, max_depth, US) @@ -235,16 +285,27 @@ subroutine MOM_initialize_topography(D, max_depth, G, PF, US) case default ; call MOM_error(FATAL,"MOM_initialize_topography: "// & "Unrecognized topography setup '"//trim(config)//"'") end select - if (max_depth>0.) then - call log_param(PF, mdl, "MAXIMUM_DEPTH", max_depth*US%Z_to_m, & - "The maximum depth of the ocean.", units="m") + if (max_depth /= max_depth_default * US%m_to_Z) then + call log_param(PF, mdl, "MAXIMUM_DEPTH", max_depth, & + "The maximum depth of the ocean.", units="m", unscale=US%Z_to_m) + if (trim(config) /= "DOME") then + call limit_topography(D, G, PF, max_depth, US) + endif else - max_depth = diagnoseMaximumDepth(D,G) - call log_param(PF, mdl, "!MAXIMUM_DEPTH", max_depth*US%Z_to_m, & - "The (diagnosed) maximum depth of the ocean.", units="m", like_default=.true.) - endif - if (trim(config) /= "DOME") then - call limit_topography(D, G, PF, max_depth, US) + if (present(meanSL)) then + D_meanSL(:,:) = 0.0 + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; D_meanSL(i,j) = D(i,j) + meanSL(i,j) ; enddo ; enddo + max_depth = diagnoseMaximumDepth(D_meanSL, G) + else + max_depth = diagnoseMaximumDepth(D, G) + endif + call log_param(PF, mdl, "!MAXIMUM_DEPTH", max_depth, & + "The (diagnosed) maximum depth of the ocean.", & + units="m", unscale=US%Z_to_m, like_default=.true.) + if (trim(config) /= "DOME") then + ! MAXIMUM_DEPTH is not set and topography does not need to be trimmed by its maximum depth. + call limit_topography(D, G, PF, -max_depth_default * US%m_to_Z, US) + endif endif end subroutine MOM_initialize_topography diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index 498e1915ba..7bc3838b19 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Initializes horizontal grid module MOM_grid_initialize -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_checksums, only : hchksum, Bchksum, uvchksum, hchksum_pair, Bchksum_pair use MOM_domains, only : pass_var, pass_vector, pe_here, root_PE, broadcast use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All, Scalar_Pair @@ -27,17 +29,17 @@ module MOM_grid_initialize !> Global positioning system (aka container for information to describe the grid) type, private :: GPS ; private - real :: len_lon !< The longitudinal or x-direction length of the domain. - real :: len_lat !< The latitudinal or y-direction length of the domain. + real :: len_lon !< The longitudinal or x-direction length of the domain [degrees_E] or [km] or [m]. + real :: len_lat !< The latitudinal or y-direction length of the domain [degrees_N] or [km] or [m]. real :: west_lon !< The western longitude of the domain or the equivalent - !! starting value for the x-axis. + !! starting value for the x-axis [degrees_E] or [km] or [m]. real :: south_lat !< The southern latitude of the domain or the equivalent - !! starting value for the y-axis. + !! starting value for the y-axis [degrees_N] or [km] or [m]. real :: Rad_Earth_L !< The radius of the Earth in rescaled units [L ~> m] real :: Lat_enhance_factor !< The amount by which the meridional resolution - !! is enhanced within LAT_EQ_ENHANCE of the equator. + !! is enhanced within LAT_EQ_ENHANCE of the equator [nondim] real :: Lat_eq_enhance !< The latitude range to the north and south of the equator - !! over which the resolution is enhanced, in degrees. + !! over which the resolution is enhanced [degrees_N] logical :: isotropic !< If true, an isotropic grid on a sphere (also known as a Mercator grid) !! is used. With an isotropic grid, the meridional extent of the domain !! (LENLAT), the zonal extent (LENLON), and the number of grid points in each @@ -83,6 +85,8 @@ subroutine set_grid_metrics(G, param_file, US) ! These are defaults that may be changed in the next select block. G%x_axis_units = "degrees_east" ; G%y_axis_units = "degrees_north" + G%x_ax_unit_short = "degrees_E" ; G%y_ax_unit_short = "degrees_N" + G%grid_unit_to_L = 0.0 G%Rad_Earth_L = -1.0*US%m_to_L ; G%len_lat = 0.0 ; G%len_lon = 0.0 select case (trim(config)) case ("mosaic"); call set_grid_metrics_from_mosaic(G, param_file, US) @@ -97,13 +101,9 @@ subroutine set_grid_metrics(G, param_file, US) end select if (G%Rad_Earth_L <= 0.0) then ! The grid metrics were set with an option that does not explicitly initialize Rad_Earth. - ! ### Rad_Earth should be read as in: - ! call get_param(param_file, mdl, "RAD_EARTH", G%Rad_Earth_L, & - ! "The radius of the Earth.", units="m", default=6.378e6, scale=US%m_to_L) - ! but for now it is being set via a hard-coded value to reproduce current behavior. - G%Rad_Earth_L = 6.378e6*US%m_to_L + call get_param(param_file, "MOM_grid_init", "RAD_EARTH", G%Rad_Earth_L, & + "The radius of the Earth.", units="m", default=6.378e6, scale=US%m_to_L) endif - G%Rad_Earth = US%L_to_m*G%Rad_Earth_L ! Calculate derived metrics (i.e. reciprocals and products) call callTree_enter("set_derived_metrics(), MOM_grid_initialize.F90") @@ -129,28 +129,28 @@ subroutine grid_metrics_chksum(parent, G, US) halo = min(G%ied-G%iec, G%jed-G%jec, 1) call hchksum_pair(trim(parent)//': d[xy]T', G%dxT, G%dyT, G%HI, & - haloshift=halo, scale=US%L_to_m, scalar_pair=.true.) + haloshift=halo, unscale=US%L_to_m, scalar_pair=.true.) - call uvchksum(trim(parent)//': dxC[uv]', G%dxCu, G%dyCv, G%HI, haloshift=halo, scale=US%L_to_m) + call uvchksum(trim(parent)//': dxC[uv]', G%dxCu, G%dyCv, G%HI, haloshift=halo, unscale=US%L_to_m) - call uvchksum(trim(parent)//': dxC[uv]', G%dyCu, G%dxCv, G%HI, haloshift=halo, scale=US%L_to_m) + call uvchksum(trim(parent)//': dxC[uv]', G%dyCu, G%dxCv, G%HI, haloshift=halo, unscale=US%L_to_m) - call Bchksum_pair(trim(parent)//': dxB[uv]', G%dxBu, G%dyBu, G%HI, haloshift=halo, scale=US%L_to_m) + call Bchksum_pair(trim(parent)//': dxB[uv]', G%dxBu, G%dyBu, G%HI, haloshift=halo, unscale=US%L_to_m) call hchksum_pair(trim(parent)//': Id[xy]T', G%IdxT, G%IdyT, G%HI, & - haloshift=halo, scale=US%m_to_L, scalar_pair=.true.) + haloshift=halo, unscale=US%m_to_L, scalar_pair=.true.) - call uvchksum(trim(parent)//': Id[xy]C[uv]', G%IdxCu, G%IdyCv, G%HI, haloshift=halo, scale=US%m_to_L) + call uvchksum(trim(parent)//': Id[xy]C[uv]', G%IdxCu, G%IdyCv, G%HI, haloshift=halo, unscale=US%m_to_L) - call uvchksum(trim(parent)//': Id[xy]C[uv]', G%IdyCu, G%IdxCv, G%HI, haloshift=halo, scale=US%m_to_L) + call uvchksum(trim(parent)//': Id[xy]C[uv]', G%IdyCu, G%IdxCv, G%HI, haloshift=halo, unscale=US%m_to_L) - call Bchksum_pair(trim(parent)//': Id[xy]B[uv]', G%IdxBu, G%IdyBu, G%HI, haloshift=halo, scale=US%m_to_L) + call Bchksum_pair(trim(parent)//': Id[xy]B[uv]', G%IdxBu, G%IdyBu, G%HI, haloshift=halo, unscale=US%m_to_L) - call hchksum(G%areaT, trim(parent)//': areaT',G%HI, haloshift=halo, scale=US%L_to_m**2) - call Bchksum(G%areaBu, trim(parent)//': areaBu',G%HI, haloshift=halo, scale=US%L_to_m**2) + call hchksum(G%areaT, trim(parent)//': areaT',G%HI, haloshift=halo, unscale=US%L_to_m**2) + call Bchksum(G%areaBu, trim(parent)//': areaBu',G%HI, haloshift=halo, unscale=US%L_to_m**2) - call hchksum(G%IareaT, trim(parent)//': IareaT',G%HI, haloshift=halo, scale=US%m_to_L**2) - call Bchksum(G%IareaBu, trim(parent)//': IareaBu',G%HI, haloshift=halo, scale=US%m_to_L**2) + call hchksum(G%IareaT, trim(parent)//': IareaT',G%HI, haloshift=halo, unscale=US%m_to_L**2) + call Bchksum(G%IareaBu, trim(parent)//': IareaBu',G%HI, haloshift=halo, unscale=US%m_to_L**2) call hchksum(G%geoLonT,trim(parent)//': geoLonT',G%HI, haloshift=halo) call hchksum(G%geoLatT,trim(parent)//': geoLatT',G%HI, haloshift=halo) @@ -170,24 +170,16 @@ end subroutine grid_metrics_chksum subroutine set_grid_metrics_from_mosaic(G, param_file, US) type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type type(param_file_type), intent(in) :: param_file !< Parameter file structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + ! Local variables - real, dimension(G%isd :G%ied ,G%jsd :G%jed ) :: tempH1, tempH2, tempH3, tempH4 - real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB) :: tempQ1, tempQ2, tempQ3, tempQ4 - real, dimension(G%IsdB:G%IedB,G%jsd :G%jed ) :: tempE1, tempE2 - real, dimension(G%isd :G%ied ,G%JsdB:G%JedB) :: tempN1, tempN2 - ! These arrays are a holdover from earlier code in which the arrays in G were - ! macros and may have had reduced dimensions. - real, dimension(G%isd :G%ied ,G%jsd :G%jed ) :: dxT, dyT, areaT - real, dimension(G%IsdB:G%IedB,G%jsd :G%jed ) :: dxCu, dyCu - real, dimension(G%isd :G%ied ,G%JsdB:G%JedB) :: dxCv, dyCv - real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB) :: dxBu, dyBu, areaBu - ! This are symmetric arrays, corresponding to the data in the mosaic file - real, dimension(2*G%isd-2:2*G%ied+1,2*G%jsd-2:2*G%jed+1) :: tmpT - real, dimension(2*G%isd-3:2*G%ied+1,2*G%jsd-2:2*G%jed+1) :: tmpU - real, dimension(2*G%isd-2:2*G%ied+1,2*G%jsd-3:2*G%jed+1) :: tmpV - real, dimension(2*G%isd-3:2*G%ied+1,2*G%jsd-3:2*G%jed+1) :: tmpZ - real, dimension(:,:), allocatable :: tmpGlbl + ! These are symmetric arrays, corresponding to the data in the mosaic file + real, dimension(2*G%isd-2:2*G%ied+1,2*G%jsd-2:2*G%jed+1) :: tmpT ! Areas [L2 ~> m2] + real, dimension(2*G%isd-3:2*G%ied+1,2*G%jsd-2:2*G%jed+1) :: tmpU ! East face supergrid spacing [L ~> m] + real, dimension(2*G%isd-2:2*G%ied+1,2*G%jsd-3:2*G%jed+1) :: tmpV ! North face supergrid spacing [L ~> m] + real, dimension(2*G%isd-3:2*G%ied+1,2*G%jsd-3:2*G%jed+1) :: tmpZ ! Corner latitudes [degrees_N] or + ! longitudes [degrees_E] + real, dimension(:,:), allocatable :: tmpGlbl ! A global array of axis labels [degrees_N] or [km] or [m] character(len=200) :: filename, grid_file, inputdir character(len=64) :: mdl = "MOM_grid_init set_grid_metrics_from_mosaic" type(MOM_domain_type), pointer :: SGdom => NULL() ! Supergrid domain @@ -212,11 +204,6 @@ subroutine set_grid_metrics_from_mosaic(G, param_file, US) call MOM_error(FATAL," set_grid_metrics_from_mosaic: Unable to open "//& trim(filename)) - ! Initialize everything to 0. - dxCu(:,:) = 0.0 ; dyCu(:,:) = 0.0 - dxCv(:,:) = 0.0 ; dyCv(:,:) = 0.0 - dxBu(:,:) = 0.0 ; dyBu(:,:) = 0.0 ; areaBu(:,:) = 0.0 - ! call clone_MOM_domain(G%domain, SGdom, symmetric=.true., domain_name="MOM_MOSAIC", & @@ -266,71 +253,63 @@ subroutine set_grid_metrics_from_mosaic(G, param_file, US) G%geoLatCv(i,J) = tmpZ(i2-1,j2) enddo ; enddo + ! This routine could be modified to support the use of a mosaic using Cartesian grid coordinates, + ! in which case the values of G%x_axis_units, G%y_axis_units and G%grid_unit_to_L would need to be + ! reset appropriately here, but this option has not yet been implemented, and the grid coordinates + ! are assumed to be degrees of longitude and latitude. + ! Read DX,DY from the supergrid tmpU(:,:) = 0. ; tmpV(:,:) = 0. - call MOM_read_data(filename,'dx',tmpV,SGdom,position=NORTH_FACE) - call MOM_read_data(filename,'dy',tmpU,SGdom,position=EAST_FACE) + call MOM_read_data(filename, 'dx', tmpV, SGdom, position=NORTH_FACE, scale=US%m_to_L) + call MOM_read_data(filename, 'dy', tmpU, SGdom, position=EAST_FACE, scale=US%m_to_L) call pass_vector(tmpU, tmpV, SGdom, To_All+Scalar_Pair, CGRID_NE) call extrapolate_metric(tmpV, 2*(G%jsc-G%jsd)+2, missing=0.) call extrapolate_metric(tmpU, 2*(G%jsc-G%jsd)+2, missing=0.) do j=G%jsd,G%jed ; do i=G%isd,G%ied ; i2 = 2*i ; j2 = 2*j - dxT(i,j) = tmpV(i2-1,j2-1) + tmpV(i2,j2-1) - dyT(i,j) = tmpU(i2-1,j2-1) + tmpU(i2-1,j2) + G%dxT(i,j) = tmpV(i2-1,j2-1) + tmpV(i2,j2-1) + G%dyT(i,j) = tmpU(i2-1,j2-1) + tmpU(i2-1,j2) enddo ; enddo do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB ; i2 = 2*i ; j2 = 2*j - dxCu(I,j) = tmpV(i2,j2-1) + tmpV(i2+1,j2-1) - dyCu(I,j) = tmpU(i2,j2-1) + tmpU(i2,j2) + G%dxCu(I,j) = tmpV(i2,j2-1) + tmpV(i2+1,j2-1) + G%dyCu(I,j) = tmpU(i2,j2-1) + tmpU(i2,j2) enddo ; enddo do J=G%JsdB,G%JedB ; do i=G%isd,G%ied ; i2 = 2*i ; j2 = 2*j - dxCv(i,J) = tmpV(i2-1,j2) + tmpV(i2,j2) - dyCv(i,J) = tmpU(i2-1,j2) + tmpU(i2-1,j2+1) + G%dxCv(i,J) = tmpV(i2-1,j2) + tmpV(i2,j2) + G%dyCv(i,J) = tmpU(i2-1,j2) + tmpU(i2-1,j2+1) enddo ; enddo do J=G%JsdB,G%JedB ; do I=G%IsdB,G%IedB ; i2 = 2*i ; j2 = 2*j - dxBu(I,J) = tmpV(i2,j2) + tmpV(i2+1,j2) - dyBu(I,J) = tmpU(i2,j2) + tmpU(i2,j2+1) + G%dxBu(I,J) = tmpV(i2,j2) + tmpV(i2+1,j2) + G%dyBu(I,J) = tmpU(i2,j2) + tmpU(i2,j2+1) enddo ; enddo ! Read AREA from the supergrid tmpT(:,:) = 0. - call MOM_read_data(filename, 'area', tmpT, SGdom) + call MOM_read_data(filename, 'area', tmpT, SGdom, scale=US%m_to_L**2) call pass_var(tmpT, SGdom) call extrapolate_metric(tmpT, 2*(G%jsc-G%jsd)+2, missing=0.) do j=G%jsd,G%jed ; do i=G%isd,G%ied ; i2 = 2*i ; j2 = 2*j - areaT(i,j) = (tmpT(i2-1,j2-1) + tmpT(i2,j2)) + & - (tmpT(i2-1,j2) + tmpT(i2,j2-1)) + G%areaT(i,j) = (tmpT(i2-1,j2-1) + tmpT(i2,j2)) + & + (tmpT(i2-1,j2) + tmpT(i2,j2-1)) enddo ; enddo do J=G%JsdB,G%JedB ; do I=G%IsdB,G%IedB ; i2 = 2*i ; j2 = 2*j - areaBu(I,J) = (tmpT(i2,j2) + tmpT(i2+1,j2+1)) + & - (tmpT(i2,j2+1) + tmpT(i2+1,j2)) + G%areaBu(I,J) = (tmpT(i2,j2) + tmpT(i2+1,j2+1)) + & + (tmpT(i2,j2+1) + tmpT(i2+1,j2)) enddo ; enddo ni = SGdom%niglobal nj = SGdom%njglobal call deallocate_MOM_domain(SGdom) - call pass_vector(dyCu, dxCv, G%Domain, To_All+Scalar_Pair, CGRID_NE) - call pass_vector(dxCu, dyCv, G%Domain, To_All+Scalar_Pair, CGRID_NE) - call pass_vector(dxBu, dyBu, G%Domain, To_All+Scalar_Pair, BGRID_NE) - call pass_var(areaT, G%Domain) - call pass_var(areaBu, G%Domain, position=CORNER) - - do i=G%isd,G%ied ; do j=G%jsd,G%jed - G%dxT(i,j) = US%m_to_L*dxT(i,j) ; G%dyT(i,j) = US%m_to_L*dyT(i,j) ; G%areaT(i,j) = US%m_to_L**2*areaT(i,j) - enddo ; enddo - do I=G%IsdB,G%IedB ; do j=G%jsd,G%jed - G%dxCu(I,j) = US%m_to_L*dxCu(I,j) ; G%dyCu(I,j) = US%m_to_L*dyCu(I,j) - enddo ; enddo - do i=G%isd,G%ied ; do J=G%JsdB,G%JedB - G%dxCv(i,J) = US%m_to_L*dxCv(i,J) ; G%dyCv(i,J) = US%m_to_L*dyCv(i,J) - enddo ; enddo - do I=G%IsdB,G%IedB ; do J=G%JsdB,G%JedB - G%dxBu(I,J) = US%m_to_L*dxBu(I,J) ; G%dyBu(I,J) = US%m_to_L*dyBu(I,J) ; G%areaBu(I,J) = US%m_to_L**2*areaBu(I,J) - enddo ; enddo + call pass_vector(G%dyCu, G%dxCv, G%Domain, To_All+Scalar_Pair, CGRID_NE) + call pass_vector(G%dxCu, G%dyCv, G%Domain, To_All+Scalar_Pair, CGRID_NE) + call pass_vector(G%dxBu, G%dyBu, G%Domain, To_All+Scalar_Pair, BGRID_NE) + call pass_var(G%areaT, G%Domain) + call pass_var(G%areaBu, G%Domain, position=CORNER) ! Construct axes for diagnostic output (only necessary because "ferret" uses ! broken convention for interpretting netCDF files). @@ -389,11 +368,11 @@ subroutine set_grid_metrics_cartesian(G, param_file, US) ! Local variables integer :: i, j, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, I1off, J1off integer :: niglobal, njglobal - real :: grid_latT(G%jsd:G%jed), grid_latB(G%JsdB:G%JedB) - real :: grid_lonT(G%isd:G%ied), grid_lonB(G%IsdB:G%IedB) + real :: grid_latT(G%jsd:G%jed), grid_latB(G%JsdB:G%JedB) ! Axis labels [degrees_N] or [km] or [m] + real :: grid_lonT(G%isd:G%ied), grid_lonB(G%IsdB:G%IedB) ! Axis labels [degrees_E] or [km] or [m] real :: dx_everywhere, dy_everywhere ! Grid spacings [L ~> m]. real :: I_dx, I_dy ! Inverse grid spacings [L-1 ~> m-1]. - real :: PI + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] character(len=80) :: units_temp character(len=48) :: mdl = "MOM_grid_init set_grid_metrics_cartesian" @@ -409,7 +388,10 @@ subroutine set_grid_metrics_cartesian(G, param_file, US) call get_param(param_file, mdl, "AXIS_UNITS", units_temp, & "The units for the Cartesian axes. Valid entries are: \n"//& " \t degrees - degrees of latitude and longitude \n"//& - " \t m - meters \n \t k - kilometers", default="degrees") + " \t m or meter(s) - meters \n"//& + " \t k or km or kilometer(s) - kilometers", default="degrees") + if (trim(units_temp) == "k") units_temp = "km" + call get_param(param_file, mdl, "SOUTHLAT", G%south_lat, & "The southern latitude of the domain or the equivalent "//& "starting value for the y-axis.", units=units_temp, & @@ -429,8 +411,10 @@ subroutine set_grid_metrics_cartesian(G, param_file, US) if (units_temp(1:1) == 'k') then G%x_axis_units = "kilometers" ; G%y_axis_units = "kilometers" + G%x_ax_unit_short = "km" ; G%y_ax_unit_short = "km" elseif (units_temp(1:1) == 'm') then G%x_axis_units = "meters" ; G%y_axis_units = "meters" + G%x_ax_unit_short = "m" ; G%y_ax_unit_short = "m" endif call log_param(param_file, mdl, "explicit AXIS_UNITS", G%x_axis_units) @@ -463,9 +447,11 @@ subroutine set_grid_metrics_cartesian(G, param_file, US) enddo if (units_temp(1:1) == 'k') then ! Axes are measured in km. + G%grid_unit_to_L = 1000.0*US%m_to_L dx_everywhere = 1000.0*US%m_to_L * G%len_lon / (REAL(niglobal)) dy_everywhere = 1000.0*US%m_to_L * G%len_lat / (REAL(njglobal)) elseif (units_temp(1:1) == 'm') then ! Axes are measured in m. + G%grid_unit_to_L = US%m_to_L dx_everywhere = US%m_to_L*G%len_lon / (REAL(niglobal)) dy_everywhere = US%m_to_L*G%len_lat / (REAL(njglobal)) else ! Axes are measured in degrees of latitude and longitude. @@ -521,13 +507,17 @@ subroutine set_grid_metrics_spherical(G, param_file, US) type(param_file_type), intent(in) :: param_file !< Parameter file structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables - real :: PI, PI_180! PI = 3.1415926... as 4*atan(1) + real :: PI ! PI = 3.1415926... as 4*atan(1) [nondim] + real :: PI_180 ! The conversion factor from degrees to radians [radians degree-1] integer :: i, j, isd, ied, jsd, jed integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, IsdB, IedB, JsdB, JedB integer :: i_offset, j_offset - real :: grid_latT(G%jsd:G%jed), grid_latB(G%JsdB:G%JedB) - real :: grid_lonT(G%isd:G%ied), grid_lonB(G%IsdB:G%IedB) - real :: dLon,dLat,latitude,longitude,dL_di + real :: grid_latT(G%jsd:G%jed), grid_latB(G%JsdB:G%JedB) ! Axis labels [degrees_N] + real :: grid_lonT(G%isd:G%ied), grid_lonB(G%IsdB:G%IedB) ! Axis labels [degrees_E] + real :: dLon ! The change in longitude between successive grid points [degrees_E] + real :: dLat ! The change in latitude between successive grid points [degrees_N] + real :: dL_di ! dLon rescaled from degrees to radians [radians] + real :: latitude ! The latitude of a grid point [degrees_N] character(len=48) :: mdl = "MOM_grid_init set_grid_metrics_spherical" is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -540,19 +530,19 @@ subroutine set_grid_metrics_spherical(G, param_file, US) ! Calculate the values of the metric terms that might be used ! and save them in arrays. - PI = 4.0*atan(1.0); PI_180 = atan(1.0)/45. + PI = 4.0*atan(1.0) ; PI_180 = atan(1.0)/45. call get_param(param_file, mdl, "SOUTHLAT", G%south_lat, & - "The southern latitude of the domain.", units="degrees", & + "The southern latitude of the domain.", units="degrees_N", & fail_if_missing=.true.) call get_param(param_file, mdl, "LENLAT", G%len_lat, & - "The latitudinal length of the domain.", units="degrees", & + "The latitudinal length of the domain.", units="degrees_N", & fail_if_missing=.true.) call get_param(param_file, mdl, "WESTLON", G%west_lon, & - "The western longitude of the domain.", units="degrees", & + "The western longitude of the domain.", units="degrees_E", & default=0.0) call get_param(param_file, mdl, "LENLON", G%len_lon, & - "The longitudinal length of the domain.", units="degrees", & + "The longitudinal length of the domain.", units="degrees_E", & fail_if_missing=.true.) call get_param(param_file, mdl, "RAD_EARTH", G%Rad_Earth_L, & "The radius of the Earth.", units="m", default=6.378e6, scale=US%m_to_L) @@ -661,23 +651,26 @@ subroutine set_grid_metrics_mercator(G, param_file, US) integer :: i, j, isd, ied, jsd, jed integer :: I_off, J_off type(GPS) :: GP - character(len=128) :: warnmesg character(len=48) :: mdl = "MOM_grid_init set_grid_metrics_mercator" - real :: PI, PI_2! PI = 3.1415926... as 4*atan(1), PI_2 = (PI) /2.0 - real :: y_q, y_h, jd, x_q, x_h, id + real :: PI, PI_2 ! PI = 3.1415926... as 4*atan(1), PI_2 = (PI) /2.0 [nondim] + real :: y_q, y_h ! Latitudes of a point [radians] + real :: id ! The i-grid space positions whose longitude is being sought [gridpoints] + real :: jd ! The j-grid space positions whose latitude is being sought [gridpoints] + real :: x_q, x_h ! Longitudes of a point [radians] real, dimension(G%isd:G%ied,G%jsd:G%jed) :: & - xh, yh ! Latitude and longitude of h points in radians. + xh, yh ! Latitude and longitude of h points in radians [radians] real, dimension(G%IsdB:G%IedB,G%jsd:G%jed) :: & - xu, yu ! Latitude and longitude of u points in radians. + xu, yu ! Latitude and longitude of u points in radians [radians] real, dimension(G%isd:G%ied,G%JsdB:G%JedB) :: & - xv, yv ! Latitude and longitude of v points in radians. + xv, yv ! Latitude and longitude of v points in radians [radians] real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB) :: & - xq, yq ! Latitude and longitude of q points in radians. + xq, yq ! Latitude and longitude of q points in radians [radians] real :: fnRef ! fnRef is the value of Int_dj_dy or ! Int_dj_dy at a latitude or longitude that is - real :: jRef, iRef ! being set to be at grid index jRef or iRef. + ! being set to be at grid index jRef or iRef [gridpoints] + real :: jRef, iRef ! The grid index at which fnRef is evaluated [gridpoints] integer :: itt1, itt2 - logical :: debug = .FALSE., simple_area = .true. + logical, parameter :: simple_area = .true. integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, IsdB, IedB, JsdB, JedB ! All of the metric terms should be defined over the domain from @@ -699,16 +692,16 @@ subroutine set_grid_metrics_mercator(G, param_file, US) PI = 4.0*atan(1.0) ; PI_2 = 0.5*PI call get_param(param_file, mdl, "SOUTHLAT", GP%south_lat, & - "The southern latitude of the domain.", units="degrees", & + "The southern latitude of the domain.", units="degrees_N", & fail_if_missing=.true.) call get_param(param_file, mdl, "LENLAT", GP%len_lat, & - "The latitudinal length of the domain.", units="degrees", & + "The latitudinal length of the domain.", units="degrees_N", & fail_if_missing=.true.) call get_param(param_file, mdl, "WESTLON", GP%west_lon, & - "The western longitude of the domain.", units="degrees", & + "The western longitude of the domain.", units="degrees_E", & default=0.0) call get_param(param_file, mdl, "LENLON", GP%len_lon, & - "The longitudinal length of the domain.", units="degrees", & + "The longitudinal length of the domain.", units="degrees_E", & fail_if_missing=.true.) call get_param(param_file, mdl, "RAD_EARTH", GP%Rad_Earth_L, & "The radius of the Earth.", units="m", default=6.378e6, scale=US%m_to_L) @@ -735,7 +728,7 @@ subroutine set_grid_metrics_mercator(G, param_file, US) units="nondim", default=1.0) call get_param(param_file, mdl, "LAT_EQ_ENHANCE", GP%Lat_eq_enhance, & "The latitude range to the north and south of the equator "//& - "over which the resolution is enhanced.", units="degrees", & + "over which the resolution is enhanced.", units="degrees_N", & default=0.0) ! With an isotropic grid, the north-south extent of the domain, @@ -755,7 +748,7 @@ subroutine set_grid_metrics_mercator(G, param_file, US) fnRef = Int_dj_dy((GP%south_lat*PI/180.0), GP) endif - ! These calculations no longer depend on the the order in which they + ! These calculations no longer depend on the order in which they ! are performed because they all use the same (poor) starting guess and ! iterate to convergence. ! Note that the dynamic grid always uses symmetric memory for the global @@ -765,14 +758,14 @@ subroutine set_grid_metrics_mercator(G, param_file, US) y_q = find_root(Int_dj_dy, dy_dj, GP, jd, 0.0, -1.0*PI_2, PI_2, itt2) G%gridLatB(J) = y_q*180.0/PI ! if (is_root_pe()) & - ! write(stdout, '("J, y_q = ",I4,ES14.4," itts = ",I4)') j, y_q, itt2 + ! write(stdout, '("J, y_q = ",I0,", ",ES14.4," itts = ",I0)') j, y_q, itt2 enddo do j=G%jsg,G%jeg jd = fnRef + (j - jRef) - 0.5 y_h = find_root(Int_dj_dy, dy_dj, GP, jd, 0.0, -1.0*PI_2, PI_2, itt1) G%gridLatT(j) = y_h*180.0/PI ! if (is_root_pe()) & - ! write(stdout, '("j, y_h = ",I4,ES14.4," itts = ",I4)') j, y_h, itt1 + ! write(stdout, '("j, y_h = ",I0,", ",ES14.4," itts = ",I0)') j, y_h, itt1 enddo do J=JsdB+J_off,JedB+J_off jd = fnRef + (J - jRef) @@ -795,7 +788,7 @@ subroutine set_grid_metrics_mercator(G, param_file, US) iRef = (G%isg-1) + GP%niglobal fnRef = Int_di_dx(((GP%west_lon+GP%len_lon)*PI/180.0), GP) - ! These calculations no longer depend on the the order in which they + ! These calculations no longer depend on the order in which they ! are performed because they all use the same (poor) starting guess and ! iterate to convergence. do I=G%isg-1,G%ieg @@ -862,7 +855,7 @@ subroutine set_grid_metrics_mercator(G, param_file, US) (dL(xq(I-1,J),xq(I,J),yq(I-1,J),yq(I,J)) + & (dL(xq(I,J),xq(I,J-1),yq(I,J),yq(I,J-1)) + & dL(xq(I,J-1),xq(I-1,J-1),yq(I,J-1),yq(I-1,J-1))))) - enddo ;enddo + enddo ; enddo if ((IsdB == isd) .or. (JsdB == jsq)) then ! Fill in row and column 1 to calculate the area in the southernmost ! and westernmost land cells when we are not using symmetric memory. @@ -884,8 +877,8 @@ end subroutine set_grid_metrics_mercator !> This function returns the grid spacing in the logical x direction in [L ~> m]. function ds_di(x, y, GP) - real, intent(in) :: x !< The longitude in question - real, intent(in) :: y !< The latitude in question + real, intent(in) :: x !< The longitude in question [radians] + real, intent(in) :: y !< The latitude in question [radians] type(GPS), intent(in) :: GP !< A structure of grid parameters real :: ds_di ! The returned grid spacing [L ~> m] @@ -898,8 +891,8 @@ end function ds_di !> This function returns the grid spacing in the logical y direction in [L ~> m]. function ds_dj(x, y, GP) - real, intent(in) :: x !< The longitude in question - real, intent(in) :: y !< The latitude in question + real, intent(in) :: x !< The longitude in question [radians] + real, intent(in) :: y !< The latitude in question [radians] type(GPS), intent(in) :: GP !< A structure of grid parameters real :: ds_dj ! The returned grid spacing [L ~> m] @@ -911,16 +904,17 @@ function ds_dj(x, y, GP) end function ds_dj !> This function returns the contribution from the line integral along one of the four sides of a -!! cell face to the area of a cell, assuming that the sides follow a linear path in latitude and -!! longitude (i.e., on a Mercator grid). +!! cell face to the area of a cell, in [radians2], assuming that the sides follow a linear path in +!! latitude and longitude (i.e., on a Mercator grid). function dL(x1, x2, y1, y2) - real, intent(in) :: x1 !< Segment starting longitude, in degrees E. - real, intent(in) :: x2 !< Segment ending longitude, in degrees E. - real, intent(in) :: y1 !< Segment ending latitude, in degrees N. - real, intent(in) :: y2 !< Segment ending latitude, in degrees N. + real, intent(in) :: x1 !< Segment starting longitude [radians] + real, intent(in) :: x2 !< Segment ending longitude [radians] + real, intent(in) :: y1 !< Segment starting latitude [radians] + real, intent(in) :: y2 !< Segment ending latitude [radians] ! Local variables - real :: dL - real :: r, dy + real :: dL ! A contribution to the spanned area the surface of the sphere [radian2] + real :: r ! A contribution from the range of latitudes, including trigonometric factors [radians] + real :: dy ! The spanned range of latitudes [radians] dy = y2 - y1 @@ -937,23 +931,25 @@ end function dL !! function fn takes the value fnval, also returning in ittmax the number of iterations of !! Newton's method that were used to polish the root. function find_root( fn, dy_df, GP, fnval, y1, ymin, ymax, ittmax) - real :: find_root !< The value of y where fn(y) = fnval that will be returned - real, external :: fn !< The external function whose root is being sought - real, external :: dy_df !< The inverse of the derivative of that function - type(GPS), intent(in) :: GP !< A structure of grid parameters - real, intent(in) :: fnval !< The value of fn being sought - real, intent(in) :: y1 !< A first guess for y - real, intent(in) :: ymin !< The minimum permitted value of y - real, intent(in) :: ymax !< The maximum permitted value of y + real :: find_root !< The value of y where fn(y) = fnval that will be returned [radians] + real, external :: fn !< The external function whose root is being sought [gridpoints] + real, external :: dy_df !< The inverse of the derivative of that function [radian gridpoint-1] + type(GPS), intent(in) :: GP !< A structure of grid parameters + real, intent(in) :: fnval !< The value of fn being sought [gridpoints] + real, intent(in) :: y1 !< A first guess for y [radians] + real, intent(in) :: ymin !< The minimum permitted value of y [radians] + real, intent(in) :: ymax !< The maximum permitted value of y [radians] integer, intent(out) :: ittmax !< The number of iterations used to polish the root ! Local variables - real :: y, y_next - real :: ybot, ytop, fnbot, fntop + real :: y, y_next ! Successive guesses at the root position [radians] + real :: ybot, ytop ! Brackets bounding the root [radians] + real :: fnbot, fntop ! Values of fn at the bounding values of y [gridpoints] + real :: dy_dfn ! The inverse of the local derivative of fn with y [radian gridpoint-1] + real :: dy ! The jump to the next guess of y [radians] + real :: fny ! The difference between fn(y) and the target value [gridpoints] integer :: itt character(len=256) :: warnmesg - real :: dy_dfn, dy, fny - ! Bracket the root. Do not use the bounding values because the value at the ! function at the bounds could be infinite, as is the case for the Mercator ! grid recursion relation. (I.e., this is a search on an open interval.) @@ -969,7 +965,7 @@ function find_root( fn, dy_df, GP, fnval, y1, ymin, ymax, ittmax) fnbot = fn(ybot,GP) - fnval if ((itt > 50) .and. (fnbot > 0.0)) then - write(warnmesg, '("PE ",I2," unable to find bottom bound for grid function. & + write(warnmesg, '("PE ",I0," unable to find bottom bound for grid function. & &x = ",ES10.4,", xmax = ",ES10.4,", fn = ",ES10.4,", dfn_dx = ",ES10.4,& &", seeking fn = ",ES10.4," - fn = ",ES10.4,".")') & pe_here(),ybot,ymin,fn(ybot,GP),dy_df(ybot,GP),fnval, fnbot @@ -989,7 +985,7 @@ function find_root( fn, dy_df, GP, fnval, y1, ymin, ymax, ittmax) fntop = fn(ytop,GP) - fnval if ((itt > 50) .and. (fntop < 0.0)) then - write(warnmesg, '("PE ",I2," unable to find top bound for grid function. & + write(warnmesg, '("PE ",I0," unable to find top bound for grid function. & &x = ",ES10.4,", xmax = ",ES10.4,", fn = ",ES10.4,", dfn_dx = ",ES10.4, & &", seeking fn = ",ES10.4," - fn = ",ES10.4,".")') & pe_here(),ytop,ymax,fn(ytop,GP),dy_df(ytop,GP),fnval,fntop @@ -1000,7 +996,7 @@ function find_root( fn, dy_df, GP, fnval, y1, ymin, ymax, ittmax) ! Find the root using a bracketed variant of Newton's method, starting ! with a false-positon method first guess. if ((fntop < 0.0) .or. (fnbot > 0.0) .or. (ytop < ybot)) then - write(warnmesg, '("PE ",I2," find_root failed to bracket function. y = ",& + write(warnmesg, '("PE ",I0," find_root failed to bracket function. y = ",& &2ES10.4,", fn = ",2ES10.4,".")') pe_here(),ybot,ytop,fnbot,fntop call MOM_error(FATAL, warnmesg) endif @@ -1046,40 +1042,40 @@ function find_root( fn, dy_df, GP, fnval, y1, ymin, ymax, ittmax) find_root = y end function find_root -!> This function calculates and returns the value of dx/di, where x is the -!! longitude in Radians, and i is the integral north-south grid index. +!> This function calculates and returns the value of dx/di in [radian gridpoint-1], +!! where x is the longitude in Radians, and i is the integral east-west grid index. function dx_di(x, GP) - real, intent(in) :: x !< The longitude in question + real, intent(in) :: x !< The longitude in question [radians] type(GPS), intent(in) :: GP !< A structure of grid parameters - real :: dx_di + real :: dx_di ! The derivative of zonal position with the grid index [radian gridpoint-1] dx_di = (GP%len_lon * 4.0*atan(1.0)) / (180.0 * GP%niglobal) end function dx_di !> This function calculates and returns the integral of the inverse -!! of dx/di to the point x, in radians. +!! of dx/di to the point x, in radians [gridpoints] function Int_di_dx(x, GP) - real, intent(in) :: x !< The longitude in question + real, intent(in) :: x !< The longitude in question [radians] type(GPS), intent(in) :: GP !< A structure of grid parameters - real :: Int_di_dx + real :: Int_di_dx ! A position in the global i-index space [gridpoints] Int_di_dx = x * ((180.0 * GP%niglobal) / (GP%len_lon * 4.0*atan(1.0))) end function Int_di_dx -!> This subroutine calculates and returns the value of dy/dj, where y is the -!! latitude in Radians, and j is the integral north-south grid index. +!> This subroutine calculates and returns the value of dy/dj in [radian gridpoint-1], +!! where y is the latitude in Radians, and j is the integral north-south grid index. function dy_dj(y, GP) - real, intent(in) :: y !< The latitude in question + real, intent(in) :: y !< The latitude in question [radians] type(GPS), intent(in) :: GP !< A structure of grid parameters - real :: dy_dj + real :: dy_dj ! The derivative of meridional position with the grid index [radian gridpoint-1] ! Local variables - real :: PI ! 3.1415926... calculated as 4*atan(1) + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] real :: C0 ! The constant that converts the nominal y-spacing in - ! gridpoints to the nominal spacing in Radians. + ! gridpoints to the nominal spacing in Radians [radian gridpoint-1] real :: y_eq_enhance ! The latitude in radians within which the resolution - ! is enhanced. + ! is enhanced [radians] PI = 4.0*atan(1.0) if (GP%isotropic) then C0 = (GP%len_lon * PI) / (180.0 * GP%niglobal) @@ -1098,21 +1094,19 @@ function dy_dj(y, GP) end function dy_dj !> This subroutine calculates and returns the integral of the inverse -!! of dy/dj to the point y, in radians. +!! of dy/dj to the point y in radians [gridpoints] function Int_dj_dy(y, GP) - real, intent(in) :: y !< The latitude in question + real, intent(in) :: y !< The latitude in question [radians] type(GPS), intent(in) :: GP !< A structure of grid parameters - real :: Int_dj_dy + real :: Int_dj_dy ! The grid position of latitude y [gridpoints] ! Local variables - real :: I_C0 = 0.0 ! The inverse of the constant that converts the + real :: I_C0 ! The inverse of the constant that converts the ! nominal spacing in gridpoints to the nominal - ! spacing in Radians. - real :: PI ! 3.1415926... calculated as 4*atan(1) - real :: y_eq_enhance ! The latitude in radians from - ! from the equator within which the - ! meridional grid spacing is enhanced by - ! a factor of GP%lat_enhance_factor. - real :: r + ! spacing in Radians [gridpoint radian-1] + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] + real :: y_eq_enhance ! The latitude in radians from from the equator within which the meridional + ! grid spacing is enhanced by a factor of GP%lat_enhance_factor [radians] + real :: r ! The y grid position in the global index space [gridpoints] PI = 4.0*atan(1.0) if (GP%isotropic) then @@ -1143,12 +1137,12 @@ end function Int_dj_dy !> Extrapolates missing metric data into all the halo regions. subroutine extrapolate_metric(var, jh, missing) - real, dimension(:,:), intent(inout) :: var !< The array in which to fill in halos + real, dimension(:,:), intent(inout) :: var !< The array in which to fill in halos in arbitrary units [A] integer, intent(in) :: jh !< The size of the halos to be filled - real, optional, intent(in) :: missing !< The missing data fill value, 0 by default. + real, optional, intent(in) :: missing !< The missing data fill value, 0 by default [A] ! Local variables - real :: badval - integer :: i,j + real :: badval ! A bad data value [A] + integer :: i, j badval = 0.0 ; if (present(missing)) badval = missing @@ -1177,8 +1171,8 @@ end subroutine extrapolate_metric !> This function implements Adcroft's rule for reciprocals, namely that !! Adcroft_Inv(x) = 1/x for |x|>0 or 0 for x=0. function Adcroft_reciprocal(val) result(I_val) - real, intent(in) :: val !< The value being inverted. - real :: I_val !< The Adcroft reciprocal of val. + real, intent(in) :: val !< The value being inverted in arbitrary units [A] + real :: I_val !< The Adcroft reciprocal of val [A-1] I_val = 0.0 if (val /= 0.0) I_val = 1.0/val @@ -1190,16 +1184,37 @@ end function Adcroft_reciprocal !! flow over any points which are shallower than Dmask and permit an !! appropriate treatment of the boundary conditions. mask2dCu and mask2dCv !! are 0.0 at any points adjacent to a land point. mask2dBu is 0.0 at -!! any land or boundary point. For points in the interior, mask2dCu, -!! mask2dCv, and mask2dBu are all 1.0. -subroutine initialize_masks(G, PF, US) +!! any land or boundary point. For points in the ocean interior or at open boundary +!! condition points, mask2dCu, mask2dCv, and mask2dBu are all 1.0. +subroutine initialize_masks(G, PF, US, OBC_dir_u, OBC_dir_v, open_corner_OBCs, maskT) type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type type(param_file_type), intent(in) :: PF !< Parameter file structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, dimension(G%IsdB:G%IedB,G%jsd:G%jed), & + optional, intent(in) :: OBC_dir_u !< Trinary values that indicate whether there + !! is an open boundary condition at zonal velocity + !! faces and their orientation, with 0 for no OBC, + !! a positive value for an Eastern OBC and + !! a negative value for a Western OBC. + integer, dimension(G%isd:G%ied,G%JsdB:G%JedB), & + optional, intent(in) :: OBC_dir_v !< Trinary values that indicate whether there + !! is an open boundary condition at zonal velocity + !! faces and their orientation, with 0 for no OBC, + !! a positive value for a Northern OBC and + !! a negative value for a Southern OBC. + logical, optional, intent(in) :: open_corner_OBCs !< If present and true, the bay-like corner + !! between two orthogonal open boundary segments is open, + !! otherwise it is closed. + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + optional, intent(in) :: maskT !< If present, this array is used to set the + !! the mask at tracer points instead of using the + !! bathymetry to determine the masks [nondim] + ! Local variables real :: Dmask ! The depth for masking in the same units as G%bathyT [Z ~> m]. real :: min_depth ! The minimum ocean depth in the same units as G%bathyT [Z ~> m]. real :: mask_depth ! The depth shallower than which to mask a point as land [Z ~> m]. + logical :: open_corners ! If true, the bay-like corner between two orthogonal open boundary segments is open character(len=40) :: mdl = "MOM_grid_init initialize_masks" integer :: i, j @@ -1215,58 +1230,115 @@ subroutine initialize_masks(G, PF, US) "The depth below which to mask points as land points, for which all "//& "fluxes are zeroed out. MASKING_DEPTH is ignored if it has the special "//& "default value.", & - units="m", default=-9999.0, scale=US%m_to_Z) + units="m", default=-9999.0, scale=US%m_to_Z, do_not_log=present(maskT)) Dmask = mask_depth if (mask_depth == -9999.0*US%m_to_Z) Dmask = min_depth - G%mask2dCu(:,:) = 0.0 ; G%mask2dCv(:,:) = 0.0 ; G%mask2dBu(:,:) = 0.0 + open_corners = .false. ; if (present(open_corner_OBCs)) open_corners = open_corner_OBCs + + G%mask2dT(:,:) = 0.0 ; G%mask2dCu(:,:) = 0.0 ; G%mask2dCv(:,:) = 0.0 ; G%mask2dBu(:,:) = 0.0 ! Construct the h-point or T-point mask - do j=G%jsd,G%jed ; do i=G%isd,G%ied - if (G%bathyT(i,j) <= Dmask) then - G%mask2dT(i,j) = 0.0 - else - G%mask2dT(i,j) = 1.0 - endif + if (present(maskT)) then + do j=G%jsd,G%jed ; do i=G%isd,G%ied + G%mask2dT(i,j) = max(min(maskT(i,j), 1.0), 0.0) + enddo ; enddo + else + do j=G%jsd,G%jed ; do i=G%isd,G%ied + if (G%bathyT(i,j) <= Dmask) then + G%mask2dT(i,j) = 0.0 + else + G%mask2dT(i,j) = 1.0 + endif + enddo ; enddo + endif + + call pass_var(G%mask2dT, G%Domain) + + do j=G%jsd,G%jed ; do I=G%isd,G%ied-1 + G%mask2dCu(I,j) = G%mask2dT(i,j) * G%mask2dT(i+1,j) enddo ; enddo + if (present(OBC_dir_u)) then + do j=G%jsd,G%jed ; do I=G%isd,G%ied-1 + if (OBC_dir_u(I,j) > 0) G%mask2dCu(I,j) = G%mask2dT(i,j) + if (OBC_dir_u(I,j) < 0) G%mask2dCu(I,j) = G%mask2dT(i+1,j) + enddo ; enddo + endif + do j=G%jsd,G%jed ; do I=G%isd,G%ied-1 - if ((G%bathyT(i,j) <= Dmask) .or. (G%bathyT(i+1,j) <= Dmask)) then - G%mask2dCu(I,j) = 0.0 - else - G%mask2dCu(I,j) = 1.0 - endif + ! This mask may be revised later after the open boundary positions are specified. + G%OBCmaskCu(I,j) = G%mask2dCu(I,j) enddo ; enddo do J=G%jsd,G%jed-1 ; do i=G%isd,G%ied - if ((G%bathyT(i,j) <= Dmask) .or. (G%bathyT(i,j+1) <= Dmask)) then - G%mask2dCv(i,J) = 0.0 - else - G%mask2dCv(i,J) = 1.0 - endif + G%mask2dCv(i,J) = G%mask2dT(i,j) * G%mask2dT(i,j+1) + enddo ; enddo + + if (present(OBC_dir_v)) then + do J=G%jsd,G%jed-1 ; do i=G%isd,G%ied + if (OBC_dir_v(i,J) > 0) G%mask2dCv(i,J) = G%mask2dT(i,j) + if (OBC_dir_v(i,J) < 0) G%mask2dCv(i,J) = G%mask2dT(i,j+1) + enddo ; enddo + endif + + do J=G%jsd,G%jed-1 ; do i=G%isd,G%ied + ! This mask may be revised later after the open boundary positions are specified. + G%OBCmaskCv(i,J) = G%mask2dCv(i,J) enddo ; enddo + ! The mask at the vertex can be determined from the masks at the faces. + ! This works at interior ocean points or at convex OBC points. do J=G%jsd,G%jed-1 ; do I=G%isd,G%ied-1 - if ((G%bathyT(i+1,j) <= Dmask) .or. (G%bathyT(i+1,j+1) <= Dmask) .or. & - (G%bathyT(i,j) <= Dmask) .or. (G%bathyT(i,j+1) <= Dmask)) then - G%mask2dBu(I,J) = 0.0 - else - G%mask2dBu(I,J) = 1.0 - endif + G%mask2dBu(I,J) = (G%mask2dCu(I,j) * G%mask2dCu(I,j+1)) * (G%mask2dCv(i,J) * G%mask2dCv(i+1,J)) enddo ; enddo + ! This block resets masks at the vertices when there are OBCs. The right logic is that if there + ! are 2 or more unmasked OBCs, this point should be open, but to recreate the previous answers, + if (present(OBC_dir_u)) then + do J=G%jsd,G%jed-1 ; do I=G%isd,G%ied-1 + ! These are conditions to set open vertex points on a straight north-south coastline + if ((G%mask2dCu(I,j) * OBC_dir_u(I,j)) * (G%mask2dCu(I,j+1) * OBC_dir_u(I,j+1)) > 0.) & + G%mask2dBu(I,J) = 1.0 + enddo ; enddo + endif + if (present(OBC_dir_v)) then + do J=G%jsd,G%jed-1 ; do I=G%isd,G%ied-1 + ! These are conditions to set open vertex points on a straight east-west coastline + if ((G%mask2dCv(i,J) * OBC_dir_v(i,J)) * (G%mask2dCv(i+1,J) * OBC_dir_v(i+1,J)) > 0.) & + G%mask2dBu(I,J) = 1.0 + enddo ; enddo + endif + if (open_corners .and. present(OBC_dir_u) .and. present(OBC_dir_v)) then + do J=G%jsd,G%jed-1 ; do I=G%isd,G%ied-1 + ! These are the 4 conditions to set an open point in a concave (bay-like) corner + if ((G%mask2dCu(I,j+1) * OBC_dir_u(I,j+1) < 0.) .and. (G%mask2dCv(i+1,J) * OBC_dir_v(i+1,J) < 0.)) & + G%mask2dBu(I,J) = 1.0 ! Southwestern corner + if ((G%mask2dCu(I,j+1) * OBC_dir_u(I,j+1) > 0.) .and. (G%mask2dCv(i,J) * OBC_dir_v(i,J) < 0.)) & + G%mask2dBu(I,J) = 1.0 ! Southeastern corner + if ((G%mask2dCu(I,j) * OBC_dir_u(I,j) < 0.) .and. (G%mask2dCv(i+1,J) * OBC_dir_v(i+1,J) > 0.)) & + G%mask2dBu(I,J) = 1.0 ! Northwestern corner + if ((G%mask2dCu(I,j) * OBC_dir_u(I,j) > 0.) .and. (G%mask2dCv(i,J) * OBC_dir_v(i,J) > 0.)) & + G%mask2dBu(I,J) = 1.0 ! Northeastern corner + enddo ; enddo + endif + call pass_var(G%mask2dBu, G%Domain, position=CORNER) call pass_vector(G%mask2dCu, G%mask2dCv, G%Domain, To_All+Scalar_Pair, CGRID_NE) do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB + ! This open face length may be revised later. G%dy_Cu(I,j) = G%mask2dCu(I,j) * G%dyCu(I,j) + G%IdxCu_OBCmask(I,j) = G%OBCmaskCu(I,j) * G%IdxCu(I,j) G%areaCu(I,j) = G%dxCu(I,j) * G%dy_Cu(I,j) G%IareaCu(I,j) = G%mask2dCu(I,j) * Adcroft_reciprocal(G%areaCu(I,j)) enddo ; enddo do J=G%JsdB,G%JedB ; do i=G%isd,G%ied + ! This open face length may be revised later. G%dx_Cv(i,J) = G%mask2dCv(i,J) * G%dxCv(i,J) + G%IdyCv_OBCmask(i,J) = G%OBCmaskCv(i,J) * G%IdyCv(i,J) G%areaCv(i,J) = G%dyCv(i,J) * G%dx_Cv(i,J) G%IareaCv(i,J) = G%mask2dCv(i,J) * Adcroft_reciprocal(G%areaCv(i,J)) enddo ; enddo diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index fc5ceaf3e4..bb534d99d3 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -1,9 +1,11 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Code that initializes fixed aspects of the model grid, such as horizontal !! grid metrics, topography and Coriolis, and can be shared between components. module MOM_shared_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_coms, only : max_across_PEs, reproducing_sum use MOM_domains, only : pass_var, pass_vector, sum_across_PEs, broadcast use MOM_domains, only : root_PE, To_All, SCALAR_PAIR, CGRID_NE, AGRID @@ -11,7 +13,8 @@ module MOM_shared_initialization use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : get_param, log_param, param_file_type, log_version -use MOM_io, only : close_file, create_file, file_type, fieldtype, file_exists, field_size +use MOM_io, only : create_MOM_file, file_exists, field_size, get_filename_appendix +use MOM_io, only : MOM_infra_file, MOM_field use MOM_io, only : MOM_read_data, MOM_read_vector, read_variable, stdout use MOM_io, only : open_file_to_read, close_file_to_read, SINGLE_FILE, MULTIPLE use MOM_io, only : slasher, vardesc, MOM_write_field, var_desc @@ -27,7 +30,9 @@ module MOM_shared_initialization public set_rotation_planetary, set_rotation_beta_plane, initialize_grid_rotation_angle public reset_face_lengths_named, reset_face_lengths_file, reset_face_lengths_list public read_face_length_list, set_velocity_depth_max, set_velocity_depth_min +public set_subgrid_topo_at_vel_from_file public compute_global_grid_integrals, write_ocean_geometry_file +public set_meanSL_from_file ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -94,11 +99,13 @@ subroutine MOM_calculate_grad_Coriolis(dF_dx, dF_dy, G, US) intent(out) :: dF_dy !< y-component of grad f [T-1 L-1 ~> s-1 m-1] type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! Local variables + character(len=40) :: mdl = "MOM_calculate_grad_Coriolis" ! This subroutine's name. integer :: i,j - real :: f1, f2 + real :: f1, f2 ! Average of adjacent Coriolis parameters [T-1 ~> s-1] + call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") if ((LBOUND(G%CoriolisBu,1) > G%isc-1) .or. & - (LBOUND(G%CoriolisBu,2) > G%isc-1)) then + (LBOUND(G%CoriolisBu,2) > G%jsc-1)) then ! The gradient of the Coriolis parameter can not be calculated with this grid. dF_dx(:,:) = 0.0 ; dF_dy(:,:) = 0.0 return @@ -113,6 +120,7 @@ subroutine MOM_calculate_grad_Coriolis(dF_dx, dF_dy, G, US) dF_dy(i,j) = G%IdyT(i,j) * ( f1 - f2 ) enddo ; enddo call pass_vector(dF_dx, dF_dy, G%Domain, stagger=AGRID) + call callTree_leave(trim(mdl)//'()') end subroutine MOM_calculate_grad_Coriolis @@ -120,8 +128,8 @@ end subroutine MOM_calculate_grad_Coriolis function diagnoseMaximumDepth(D, G) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(in) :: D !< Ocean bottom depth in m or Z - real :: diagnoseMaximumDepth !< The global maximum ocean bottom depth in m or Z + intent(in) :: D !< Ocean bottom depth in [m] or [Z ~> m] + real :: diagnoseMaximumDepth !< The global maximum ocean bottom depth in [m] or [Z ~> m] ! Local variables integer :: i,j diagnoseMaximumDepth = D(G%isc,G%jsc) @@ -131,6 +139,41 @@ function diagnoseMaximumDepth(D, G) call max_across_PEs(diagnoseMaximumDepth) end function diagnoseMaximumDepth +!> Read time mean ocean sea level from a file +subroutine set_meanSL_from_file(meanSL, G, param_file, US) + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(out) :: meanSL !< Mean sea level referenced to a zero + !! reference height at tracer points [Z ~> m]. + type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + ! Local variables + character(len=200) :: filename, file, inputdir ! Strings for file/path + character(len=200) :: varname ! Variable name in file + character(len=40) :: mdl = "set_meanSL_from_file" ! This subroutine's name. + integer :: i, j + + call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") + + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + call get_param(param_file, mdl, "MEAN_SEA_LEVEL_FILE", file, & + "The file from which the mean sea level is read.", & + default="mean_sea_level.nc") + call get_param(param_file, mdl, "MEAN_SEA_LEVEL_VARNAME", varname, & + "The name of the mean sea level variable in MEAN_SEA_LEVEL_FILE.", & + default="meanSL") + filename = trim(inputdir)//trim(file) + call log_param(param_file, mdl, "INPUTDIR/TOPO_FILE", filename) + + if (.not.file_exists(filename, G%Domain)) & + call MOM_error(FATAL, " "//mdl//": Unable to open "//trim(filename)) + + call MOM_read_data(filename, trim(varname), meanSL, G%Domain, scale=US%m_to_Z) + call pass_var(meanSL, G%Domain) + + call callTree_leave(trim(mdl)//'()') +end subroutine set_meanSL_from_file !> Read gridded depths from file subroutine initialize_topography_from_file(D, G, param_file, US) @@ -184,7 +227,7 @@ subroutine apply_topography_edits_from_file(D, G, param_file, US) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables - real, dimension(:), allocatable :: new_depth ! The new values of the depths [m] + real, dimension(:), allocatable :: new_depth ! The new values of the depths [Z ~> m] integer, dimension(:), allocatable :: ig, jg ! The global indicies of the points to modify character(len=200) :: topo_edits_file, inputdir ! Strings for file/path character(len=40) :: mdl = "apply_topography_edits_from_file" ! This subroutine's name. @@ -247,22 +290,22 @@ subroutine apply_topography_edits_from_file(D, G, param_file, US) ! Read iEdit, jEdit and zEdit call read_variable(topo_edits_file, 'iEdit', ig, ncid_in=ncid) call read_variable(topo_edits_file, 'jEdit', jg, ncid_in=ncid) - call read_variable(topo_edits_file, 'zEdit', new_depth, ncid_in=ncid) + call read_variable(topo_edits_file, 'zEdit', new_depth, ncid_in=ncid, scale=US%m_to_Z) call close_file_to_read(ncid, topo_edits_file) do n = 1, n_edits - i = ig(n) - G%isd_global + 2 ! +1 for python indexing and +1 for ig-isd_global+1 - j = jg(n) - G%jsd_global + 2 + i = ig(n) - G%idg_offset + 1 ! +1 for python indexing + j = jg(n) - G%jdg_offset + 1 if (i>=G%isc .and. i<=G%iec .and. j>=G%jsc .and. j<=G%jec) then - if (new_depth(n)*US%m_to_Z /= mask_depth) then + if (new_depth(n) /= mask_depth) then write(stdout,'(a,3i5,f8.2,a,f8.2,2i4)') & - 'Ocean topography edit: ', n, ig(n), jg(n), D(i,j)*US%Z_to_m, '->', abs(new_depth(n)), i, j - D(i,j) = abs(US%m_to_Z*new_depth(n)) ! Allows for height-file edits (i.e. converts negatives) + 'Ocean topography edit: ', n, ig(n), jg(n), D(i,j)*US%Z_to_m, '->', abs(US%Z_to_m*new_depth(n)), i, j + D(i,j) = abs(new_depth(n)) ! Allows for height-file edits (i.e. converts negatives) else if (topo_edits_change_mask) then write(stdout,'(a,3i5,f8.2,a,f8.2,2i4)') & - 'Ocean topography edit: ',n,ig(n),jg(n),D(i,j)*US%Z_to_m,'->',abs(new_depth(n)),i,j - D(i,j) = abs(US%m_to_Z*new_depth(n)) ! Allows for height-file edits (i.e. converts negatives) + 'Ocean topography edit: ',n,ig(n),jg(n),D(i,j)*US%Z_to_m,'->',abs(US%Z_to_m*new_depth(n)),i,j + D(i,j) = abs(new_depth(n)) ! Allows for height-file edits (i.e. converts negatives) else call MOM_error(FATAL, ' apply_topography_edits_from_file: '//& "A zero depth edit would change the land mask and is not allowed in"//trim(topo_edits_file)) @@ -291,7 +334,7 @@ subroutine initialize_topography_named(D, G, param_file, topog_config, max_depth ! Local variables real :: min_depth ! The minimum depth [Z ~> m]. - real :: PI ! 3.1415926... calculated as 4*atan(1) + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] real :: D0 ! A constant to make the maximum basin depth MAXIMUM_DEPTH [Z ~> m] real :: expdecay ! A decay scale of associated with the sloping boundaries [L ~> m] real :: Dedge ! The depth at the basin edge [Z ~> m] @@ -322,12 +365,12 @@ subroutine initialize_topography_named(D, G, param_file, topog_config, max_depth PI = 4.0*atan(1.0) if (trim(topog_config) == "flat") then - do i=is,ie ; do j=js,je ; D(i,j) = max_depth ; enddo ; enddo + do j=js,je ; do i=is,ie ; D(i,j) = max_depth ; enddo ; enddo elseif (trim(topog_config) == "spoon") then D0 = (max_depth - Dedge) / & ((1.0 - exp(-0.5*G%len_lat*G%Rad_Earth_L*PI/(180.0 *expdecay))) * & (1.0 - exp(-0.5*G%len_lat*G%Rad_Earth_L*PI/(180.0 *expdecay)))) - do i=is,ie ; do j=js,je + do j=js,je ; do i=is,ie ! This sets a bowl shaped (sort of) bottom topography, with a ! ! maximum depth of max_depth. ! D(i,j) = Dedge + D0 * & @@ -342,7 +385,7 @@ subroutine initialize_topography_named(D, G, param_file, topog_config, max_depth ! This sets a bowl shaped (sort of) bottom topography, with a ! maximum depth of max_depth. - do i=is,ie ; do j=js,je + do j=js,je ; do i=is,ie D(i,j) = Dedge + D0 * & (sin(PI * (G%geoLonT(i,j) - G%west_lon) / G%len_lon) * & ((1.0 - exp(-(G%geoLatT(i,j) - G%south_lat)*G%Rad_Earth_L*PI/ & @@ -352,7 +395,7 @@ subroutine initialize_topography_named(D, G, param_file, topog_config, max_depth enddo ; enddo elseif (trim(topog_config) == "halfpipe") then D0 = max_depth - Dedge - do i=is,ie ; do j=js,je + do j=js,je ; do i=is,ie D(i,j) = Dedge + D0 * ABS(sin(PI*(G%geoLatT(i,j) - G%south_lat)/G%len_lat)) enddo ; enddo else @@ -361,7 +404,7 @@ subroutine initialize_topography_named(D, G, param_file, topog_config, max_depth endif ! This is here just for safety. Hopefully it doesn't do anything. - do i=is,ie ; do j=js,je + do j=js,je ; do i=is,ie if (D(i,j) > max_depth) D(i,j) = max_depth if (D(i,j) < min_depth) D(i,j) = 0.5*min_depth enddo ; enddo @@ -448,14 +491,14 @@ subroutine set_rotation_planetary(f, G, param_file, US) ! This subroutine sets up the Coriolis parameter for a sphere character(len=30) :: mdl = "set_rotation_planetary" ! This subroutine's name. integer :: I, J - real :: PI + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] real :: omega ! The planetary rotation rate [T-1 ~> s-1] call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") call get_param(param_file, "set_rotation_planetary", "OMEGA", omega, & - "The rotation rate of the earth.", units="s-1", & - default=7.2921e-5, scale=US%T_to_s) + "The rotation rate of the earth.", & + units="s-1", default=7.2921e-5, scale=US%T_to_s) PI = 4.0*atan(1.0) do I=G%IsdB,G%IedB ; do J=G%JsdB,G%JedB @@ -479,10 +522,9 @@ subroutine set_rotation_beta_plane(f, G, param_file, US) integer :: I, J real :: f_0 ! The reference value of the Coriolis parameter [T-1 ~> s-1] real :: beta ! The meridional gradient of the Coriolis parameter [T-1 L-1 ~> s-1 m-1] - real :: beta_lat_ref ! The reference latitude for the beta plane [degrees/km/m/cm] - real :: Rad_Earth_L ! The radius of the planet in rescaled units [L ~> m] + real :: beta_lat_ref ! The reference latitude for the beta plane [degrees_N] or [km] or [m] real :: y_scl ! A scaling factor from the units of latitude [L lat-1 ~> m lat-1] - real :: PI + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] character(len=40) :: mdl = "set_rotation_beta_plane" ! This subroutine's name. character(len=200) :: axis_units character(len=40) :: beta_lat_ref_units @@ -498,18 +540,16 @@ subroutine set_rotation_beta_plane(f, G, param_file, US) call get_param(param_file, mdl, "AXIS_UNITS", axis_units, default="degrees") PI = 4.0*atan(1.0) + y_scl = G%grid_unit_to_L + if (G%grid_unit_to_L <= 0.0) y_scl = PI * G%Rad_Earth_L / 180. + select case (axis_units(1:1)) case ("d") - call get_param(param_file, mdl, "RAD_EARTH", Rad_Earth_L, & - "The radius of the Earth.", units="m", default=6.378e6, scale=US%m_to_L) beta_lat_ref_units = "degrees" - y_scl = PI * Rad_Earth_L / 180. case ("k") beta_lat_ref_units = "kilometers" - y_scl = 1.0e3 * US%m_to_L case ("m") beta_lat_ref_units = "meters" - y_scl = 1.0 * US%m_to_L case default ; call MOM_error(FATAL, & " set_rotation_beta_plane: unknown AXIS_UNITS = "//trim(axis_units)) end select @@ -532,10 +572,12 @@ subroutine initialize_grid_rotation_angle(G, PF) type(param_file_type), intent(in) :: PF !< A structure indicating the open file !! to parse for model parameter values. - real :: angle, lon_scale - real :: len_lon ! The periodic range of longitudes, usually 360 degrees. - real :: pi_720deg ! One quarter the conversion factor from degrees to radians. - real :: lonB(2,2) ! The longitude of a point, shifted to have about the same value. + real :: angle ! The clockwise angle of the grid relative to true north [degrees] + real :: lon_scale ! The trigonometric scaling factor converting changes in longitude + ! to equivalent distances in latitudes [nondim] + real :: len_lon ! The periodic range of longitudes, usually 360 degrees [degrees_E]. + real :: pi_720deg ! One quarter the conversion factor from degrees to radians [radian degree-1] + real :: lonB(2,2) ! The longitude of a point, shifted to have about the same value [degrees_E]. character(len=40) :: mdl = "initialize_grid_rotation_angle" ! This subroutine's name. logical :: use_bugs integer :: i, j, m, n @@ -586,10 +628,10 @@ end subroutine initialize_grid_rotation_angle !> Return the modulo value of x in an interval [xc-(Lx/2) xc+(Lx/2)] !! If Lx<=0, then it returns x without applying modulo arithmetic. function modulo_around_point(x, xc, Lx) result(x_mod) - real, intent(in) :: x !< Value to which to apply modulo arithmetic - real, intent(in) :: xc !< Center of modulo range - real, intent(in) :: Lx !< Modulo range width - real :: x_mod !< x shifted by an integer multiple of Lx to be close to xc. + real, intent(in) :: x !< Value to which to apply modulo arithmetic [A] + real, intent(in) :: xc !< Center of modulo range [A] + real, intent(in) :: Lx !< Modulo range width [A] + real :: x_mod !< x shifted by an integer multiple of Lx to be close to xc [A]. if (Lx > 0.0) then x_mod = modulo(x - (xc - 0.5*Lx), Lx) + (xc - 0.5*Lx) @@ -610,9 +652,9 @@ subroutine reset_face_lengths_named(G, param_file, name, US) ! Local variables character(len=256) :: mesg ! Message for error messages. - real :: dx_2 ! Half the local zonal grid spacing [degreesE] - real :: dy_2 ! Half the local meridional grid spacing [degreesN] - real :: pi_180 + real :: dx_2 ! Half the local zonal grid spacing [degrees_E] + real :: dy_2 ! Half the local meridional grid spacing [degrees_N] + real :: pi_180 ! Conversion factor from degrees to radians [nondim] integer :: option integer :: i, j, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -737,7 +779,9 @@ subroutine reset_face_lengths_file(G, param_file, US) character(len=40) :: mdl = "reset_face_lengths_file" ! This subroutine's name. character(len=256) :: mesg ! Message for error messages. character(len=200) :: filename, chan_file, inputdir ! Strings for file/path + character(len=64) :: dxCv_open_var, dyCu_open_var ! Open face length names in files integer :: i, j, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB ! These checks apply regardless of the chosen option. @@ -757,7 +801,14 @@ subroutine reset_face_lengths_file(G, param_file, US) trim(filename)) endif - call MOM_read_vector(filename, "dyCuo", "dxCvo", G%dy_Cu, G%dx_Cv, G%Domain, scale=US%m_to_L) + call get_param(param_file, mdl, "OPEN_DY_CU_VAR", dyCu_open_var, & + "The u-face open face length variable in CHANNEL_WIDTH_FILE.", & + default="dyCuo") + call get_param(param_file, mdl, "OPEN_DX_CV_VAR", dxCv_open_var, & + "The v-face open face length variable in CHANNEL_WIDTH_FILE.", & + default="dxCvo") + + call MOM_read_vector(filename, dyCu_open_var, dxCv_open_var, G%dy_Cu, G%dx_Cv, G%Domain, scale=US%m_to_L) call pass_vector(G%dy_Cu, G%dx_Cv, G%Domain, To_All+SCALAR_PAIR, CGRID_NE) do j=jsd,jed ; do I=IsdB,IedB @@ -802,23 +853,23 @@ subroutine reset_face_lengths_list(G, param_file, US) ! Local variables character(len=120), pointer, dimension(:) :: lines => NULL() character(len=120) :: line - character(len=200) :: filename, chan_file, inputdir, mesg ! Strings for file/path + character(len=200) :: filename, chan_file, inputdir ! Strings for file/path character(len=40) :: mdl = "reset_face_lengths_list" ! This subroutine's name. real, allocatable, dimension(:,:) :: & - u_lat, u_lon, v_lat, v_lon ! The latitude and longitude ranges of faces [degrees] + u_lat, u_lon, v_lat, v_lon ! The latitude and longitude ranges of faces [degrees_N] or [degrees_E] real, allocatable, dimension(:) :: & - u_width, v_width ! The open width of faces [m] + u_width, v_width ! The open width of faces [L ~> m] integer, allocatable, dimension(:) :: & u_line_no, v_line_no, & ! The line numbers in lines of u- and v-face lines u_line_used, v_line_used ! The number of times each u- and v-line is used. real, allocatable, dimension(:) :: & - Dmin_u, Dmax_u, Davg_u ! Porous barrier monomial fit params [m] + Dmin_u, Dmax_u, Davg_u ! Porous barrier monomial fit params [Z ~> m] real, allocatable, dimension(:) :: & - Dmin_v, Dmax_v, Davg_v ! Porous barrier monomial fit params [m] - real :: lat, lon ! The latitude and longitude of a point. - real :: len_lon ! The periodic range of longitudes, usually 360 degrees. - real :: len_lat ! The range of latitudes, usually 180 degrees. - real :: lon_p, lon_m ! The longitude of a point shifted by 360 degrees. + Dmin_v, Dmax_v, Davg_v ! Porous barrier monomial fit params [Z ~> m] + real :: lat, lon ! The latitude and longitude of a point [degrees_N] and [degrees_E]. + real :: len_lon ! The periodic range of longitudes, usually 360 degrees [degrees_E]. + real :: len_lat ! The range of latitudes, usually 180 degrees [degrees_N]. + real :: lon_p, lon_m ! The longitude of a point shifted by 360 degrees [degrees_E]. logical :: check_360 ! If true, check for longitudes that are shifted by ! +/- 360 degrees from the specified range of values. logical :: found_u, found_v @@ -826,7 +877,7 @@ subroutine reset_face_lengths_list(G, param_file, US) logical :: fatal_unused_lengths integer :: unused integer :: ios, iounit, isu, isv - integer :: last, num_lines, nl_read, ln, npt, u_pt, v_pt + integer :: num_lines, nl_read, ln, npt, u_pt, v_pt integer :: i, j, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB integer :: isu_por, isv_por logical :: found_u_por, found_v_por @@ -871,6 +922,8 @@ subroutine reset_face_lengths_list(G, param_file, US) ! Count the number of u_width and v_width entries. call read_face_length_list(iounit, filename, num_lines, lines) + else + num_lines = 0 endif len_lon = 360.0 ; if (G%len_lon > 0.0) len_lon = G%len_lon @@ -893,13 +946,13 @@ subroutine reset_face_lengths_list(G, param_file, US) allocate(v_line_used(num_lines), source=0) allocate(v_line_no(num_lines), source=0) - allocate(Dmin_u(num_lines)) ; Dmin_u(:) = 0.0 - allocate(Dmax_u(num_lines)) ; Dmax_u(:) = 0.0 - allocate(Davg_u(num_lines)) ; Davg_u(:) = 0.0 + allocate(Dmin_u(num_lines), source=0.0) + allocate(Dmax_u(num_lines), source=0.0) + allocate(Davg_u(num_lines), source=0.0) - allocate(Dmin_v(num_lines)) ; Dmin_v(:) = 0.0 - allocate(Dmax_v(num_lines)) ; Dmax_v(:) = 0.0 - allocate(Davg_v(num_lines)) ; Davg_v(:) = 0.0 + allocate(Dmin_v(num_lines), source=0.0) + allocate(Dmax_v(num_lines), source=0.0) + allocate(Davg_v(num_lines), source=0.0) ! Actually read the lines. if (is_root_pe()) then @@ -917,12 +970,12 @@ subroutine reset_face_lengths_list(G, param_file, US) do ln=1,num_lines line = lines(ln) ! Detect keywords - found_u = .false.; found_v = .false. - found_u_por = .false.; found_v_por = .false. - isu = index(uppercase(line), "U_WIDTH" ); if (isu > 0) found_u = .true. - isv = index(uppercase(line), "V_WIDTH" ); if (isv > 0) found_v = .true. - isu_por = index(uppercase(line), "U_WIDTH_POR" ); if (isu_por > 0) found_u_por = .true. - isv_por = index(uppercase(line), "V_WIDTH_POR" ); if (isv_por > 0) found_v_por = .true. + found_u = .false. ; found_v = .false. + found_u_por = .false. ; found_v_por = .false. + isu = index(uppercase(line), "U_WIDTH") ; if (isu > 0) found_u = .true. + isv = index(uppercase(line), "V_WIDTH") ; if (isv > 0) found_v = .true. + isu_por = index(uppercase(line), "U_WIDTH_POR") ; if (isu_por > 0) found_u_por = .true. + isv_por = index(uppercase(line), "V_WIDTH_POR") ; if (isv_por > 0) found_v_por = .true. ! Store and check the relevant values. if (found_u) then @@ -933,6 +986,10 @@ subroutine reset_face_lengths_list(G, param_file, US) read(line(isu_por+12:),*) u_lon(1:2,u_pt), u_lat(1:2,u_pt), u_width(u_pt), & Dmin_u(u_pt), Dmax_u(u_pt), Davg_u(u_pt) endif + u_width(u_pt) = US%m_to_L*u_width(u_pt) ! Rescale units equivalently to scale=US%m_to_L during read. + Dmin_u(u_pt) = US%m_to_Z*Dmin_u(u_pt) ! Rescale units equivalently to scale=US%m_to_Z during read. + Dmax_u(u_pt) = US%m_to_Z*Dmax_u(u_pt) ! Rescale units equivalently to scale=US%m_to_Z during read. + Davg_u(u_pt) = US%m_to_Z*Davg_u(u_pt) ! Rescale units equivalently to scale=US%m_to_Z during read. u_line_no(u_pt) = ln if (is_root_PE()) then if (check_360) then @@ -970,6 +1027,10 @@ subroutine reset_face_lengths_list(G, param_file, US) read(line(isv+12:),*) v_lon(1:2,v_pt), v_lat(1:2,v_pt), v_width(v_pt), & Dmin_v(v_pt), Dmax_v(v_pt), Davg_v(v_pt) endif + v_width(v_pt) = US%m_to_L*v_width(v_pt) ! Rescale units equivalently to scale=US%m_to_L during read. + Dmin_v(v_pt) = US%m_to_Z*Dmin_v(v_pt) ! Rescale units equivalently to scale=US%m_to_Z during read. + Dmax_v(v_pt) = US%m_to_Z*Dmax_v(v_pt) ! Rescale units equivalently to scale=US%m_to_Z during read. + Davg_v(v_pt) = US%m_to_Z*Davg_v(v_pt) ! Rescale units equivalently to scale=US%m_to_Z during read. v_line_no(v_pt) = ln if (is_root_PE()) then if (check_360) then @@ -1015,10 +1076,10 @@ subroutine reset_face_lengths_list(G, param_file, US) ((lon_p >= u_lon(1,npt)) .and. (lon_p <= u_lon(2,npt))) .or. & ((lon_m >= u_lon(1,npt)) .and. (lon_m <= u_lon(2,npt)))) ) then - G%dy_Cu(I,j) = G%mask2dCu(I,j) * min(G%dyCu(I,j), max(US%m_to_L*u_width(npt), 0.0)) - G%porous_DminU(I,j) = US%m_to_Z*Dmin_u(npt) - G%porous_DmaxU(I,j) = US%m_to_Z*Dmax_u(npt) - G%porous_DavgU(I,j) = US%m_to_Z*Davg_u(npt) + G%dy_Cu(I,j) = G%mask2dCu(I,j) * min(G%dyCu(I,j), max(u_width(npt), 0.0)) + G%porous_DminU(I,j) = Dmin_u(npt) + G%porous_DmaxU(I,j) = Dmax_u(npt) + G%porous_DavgU(I,j) = Davg_u(npt) if (j>=G%jsc .and. j<=G%jec .and. I>=G%isc .and. I<=G%iec) then ! Limit messages/checking to compute domain if ( G%mask2dCu(I,j) == 0.0 ) then @@ -1052,10 +1113,10 @@ subroutine reset_face_lengths_list(G, param_file, US) (((lon >= v_lon(1,npt)) .and. (lon <= v_lon(2,npt))) .or. & ((lon_p >= v_lon(1,npt)) .and. (lon_p <= v_lon(2,npt))) .or. & ((lon_m >= v_lon(1,npt)) .and. (lon_m <= v_lon(2,npt)))) ) then - G%dx_Cv(i,J) = G%mask2dCv(i,J) * min(G%dxCv(i,J), max(US%m_to_L*v_width(npt), 0.0)) - G%porous_DminV(i,J) = US%m_to_Z*Dmin_v(npt) - G%porous_DmaxV(i,J) = US%m_to_Z*Dmax_v(npt) - G%porous_DavgV(i,J) = US%m_to_Z*Davg_v(npt) + G%dx_Cv(i,J) = G%mask2dCv(i,J) * min(G%dxCv(i,J), max(v_width(npt), 0.0)) + G%porous_DminV(i,J) = Dmin_v(npt) + G%porous_DmaxV(i,J) = Dmax_v(npt) + G%porous_DavgV(i,J) = Davg_v(npt) if (i>=G%isc .and. i<=G%iec .and. J>=G%jsc .and. J<=G%jec) then ! Limit messages/checking to compute domain if ( G%mask2dCv(i,J) == 0.0 ) then @@ -1124,7 +1185,7 @@ subroutine read_face_length_list(iounit, filename, num_lines, lines) ! list file, after removing comments. character(len=120) :: line, line_up logical :: found_u, found_v - integer :: isu, isv, icom, verbose + integer :: isu, isv, icom integer :: last num_lines = 0 @@ -1141,9 +1202,9 @@ subroutine read_face_length_list(iounit, filename, num_lines, lines) ! Detect keywords line_up = uppercase(line) - found_u = .false.; found_v = .false. - isu = index(line_up(:last), "U_WIDTH" ); if (isu > 0) found_u = .true. - isv = index(line_up(:last), "V_WIDTH" ); if (isv > 0) found_v = .true. + found_u = .false. ; found_v = .false. + isu = index(line_up(:last), "U_WIDTH") ; if (isu > 0) found_u = .true. + isv = index(line_up(:last), "V_WIDTH") ; if (isv > 0) found_v = .true. if (found_u .and. found_v) call MOM_error(FATAL, & "read_face_length_list : both U_WIDTH and V_WIDTH found when "//& @@ -1165,6 +1226,82 @@ subroutine read_face_length_list(iounit, filename, num_lines, lines) end subroutine read_face_length_list ! ----------------------------------------------------------------------------- +! ----------------------------------------------------------------------------- +!> Read from a file the maximum, minimum and average bathymetry at velocity points, +!! for the use of porous barrier. +!! Note that we assume the depth values in the sub-grid bathymetry file of the same +!! convention as in-cell bathymetry file, i.e. positive below the sea surface and +!! increasing downward; while in subroutine reset_face_lengths_list, it is implied +!! that read-in fields min_bathy, max_bathy and avg_bathy from the input file +!! CHANNEL_LIST_FILE all have negative values below the surface. Therefore, to ensure +!! backward compatibility, all signs of the variable are inverted here. +!! And porous_Dmax[UV] = shallowest point, porous_Dmin[UV] = deepest point +subroutine set_subgrid_topo_at_vel_from_file(G, param_file, US) + type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type + type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + character(len=200) :: filename, topo_file, inputdir ! Strings for file/path + character(len=200) :: varname_uhi, varname_ulo, varname_uav, & + varname_vhi, varname_vlo, varname_vav ! Variable names in file + character(len=40) :: mdl = "set_subgrid_topo_at_vel_from_file" ! This subroutine's name. + integer :: i, j + + call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") + + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + call get_param(param_file, mdl, "TOPO_AT_VEL_FILE", topo_file, & + "The file from which the bathymetry parameters at the velocity points are read. "//& + "While the names of the parameters reflect their physical locations, i.e. HIGH is above LOW, "//& + "their signs follow the model's convention, which is positive below the sea surface", & + default="topog_edge.nc") + call get_param(param_file, mdl, "TOPO_AT_VEL_VARNAME_U_HIGH", varname_uhi, & + "The variable name of the highest bathymetry at the u-cells in TOPO_AT_VEL_FILE.", & + default="depthu_hi") + call get_param(param_file, mdl, "TOPO_AT_VEL_VARNAME_U_LOW", varname_ulo, & + "The variable name of the lowest bathymetry at the u-cells in TOPO_AT_VEL_FILE.", & + default="depthu_lo") + call get_param(param_file, mdl, "TOPO_AT_VEL_VARNAME_U_AVE", varname_uav, & + "The variable name of the average bathymetry at the u-cells in TOPO_AT_VEL_FILE.", & + default="depthu_av") + call get_param(param_file, mdl, "TOPO_AT_VEL_VARNAME_V_HIGH", varname_vhi, & + "The variable name of the highest bathymetry at the v-cells in TOPO_AT_VEL_FILE.", & + default="depthv_hi") + call get_param(param_file, mdl, "TOPO_AT_VEL_VARNAME_V_LOW", varname_vlo, & + "The variable name of the lowest bathymetry at the v-cells in TOPO_AT_VEL_FILE.", & + default="depthv_lo") + call get_param(param_file, mdl, "TOPO_AT_VEL_VARNAME_V_AVE", varname_vav, & + "The variable name of the average bathymetry at the v-cells in TOPO_AT_VEL_FILE.", & + default="depthv_av") + + filename = trim(inputdir)//trim(topo_file) + call log_param(param_file, mdl, "INPUTDIR/TOPO_AT_VEL_FILE", filename) + + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " set_subgrid_topo_at_vel_from_file: Unable to open "//trim(filename)) + + call MOM_read_vector(filename, trim(varname_uhi), trim(varname_vhi), & + G%porous_DmaxU, G%porous_DmaxV, G%Domain, stagger=CGRID_NE, scale=US%m_to_Z) + call MOM_read_vector(filename, trim(varname_ulo), trim(varname_vlo), & + G%porous_DminU, G%porous_DminV, G%Domain, stagger=CGRID_NE, scale=US%m_to_Z) + call MOM_read_vector(filename, trim(varname_uav), trim(varname_vav), & + G%porous_DavgU, G%porous_DavgV, G%Domain, stagger=CGRID_NE, scale=US%m_to_Z) + + ! The signs of the depth parameters need to be inverted to be backward compatible with input files + ! used by subroutine reset_face_lengths_list, which assumes depth is negative below the sea surface. + G%porous_DmaxU = -G%porous_DmaxU ; G%porous_DminU = -G%porous_DminU ; G%porous_DavgU = -G%porous_DavgU + G%porous_DmaxV = -G%porous_DmaxV ; G%porous_DminV = -G%porous_DminV ; G%porous_DavgV = -G%porous_DavgV + + call pass_vector(G%porous_DmaxU, G%porous_DmaxV, G%Domain, To_All+SCALAR_PAIR, CGRID_NE) + call pass_vector(G%porous_DminU, G%porous_DminV, G%Domain, To_All+SCALAR_PAIR, CGRID_NE) + call pass_vector(G%porous_DavgU, G%porous_DavgV, G%Domain, To_All+SCALAR_PAIR, CGRID_NE) + + call callTree_leave(trim(mdl)//'()') +end subroutine set_subgrid_topo_at_vel_from_file +! ----------------------------------------------------------------------------- + ! ----------------------------------------------------------------------------- !> Set the bathymetry at velocity points to be the maximum of the depths at the !! neighoring tracer points. @@ -1213,24 +1350,20 @@ subroutine compute_global_grid_integrals(G, US) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables - real, dimension(G%isc:G%iec, G%jsc:G%jec) :: tmpForSumming - real :: area_scale ! A scaling factor for area into MKS units [m2 L-2 ~> 1] - integer :: i,j - - area_scale = US%L_to_m**2 + real, dimension(G%isc:G%iec, G%jsc:G%jec) :: masked_area ! Masked cell areas [L2 ~> m2] + integer :: i, j - tmpForSumming(:,:) = 0. + masked_area(:,:) = 0. G%areaT_global = 0.0 ; G%IareaT_global = 0.0 do j=G%jsc,G%jec ; do i=G%isc,G%iec - tmpForSumming(i,j) = area_scale*G%areaT(i,j) * G%mask2dT(i,j) + masked_area(i,j) = G%areaT(i,j) * G%mask2dT(i,j) enddo ; enddo - G%areaT_global = reproducing_sum(tmpForSumming) + G%areaT_global = reproducing_sum(masked_area, unscale=US%L_to_m**2) if (G%areaT_global == 0.0) & - call MOM_error(FATAL, "compute_global_grid_integrals: "//& - "zero ocean area (check topography?)") + call MOM_error(FATAL, "compute_global_grid_integrals: zero ocean area (check topography?)") - G%IareaT_global = 1.0 / (G%areaT_global) + G%IareaT_global = 1.0 / G%areaT_global end subroutine compute_global_grid_integrals ! ----------------------------------------------------------------------------- @@ -1248,13 +1381,15 @@ subroutine write_ocean_geometry_file(G, param_file, directory, US, geom_file) ! Local variables. character(len=240) :: filepath ! The full path to the file to write character(len=40) :: mdl = "write_ocean_geometry_file" + character(len=32) :: filename_appendix = '' ! Appendix to geom filename for ensemble runs type(vardesc), dimension(:), allocatable :: & vars ! Types with metadata about the variables and their staggering - type(fieldtype), dimension(:), allocatable :: & + type(MOM_field), dimension(:), allocatable :: & fields ! Opaque types used by MOM_io to store variable metadata information - type(file_type) :: IO_handle ! The I/O handle of the fileset + type(MOM_infra_file) :: IO_handle ! The I/O handle of the fileset integer :: nFlds ! The number of variables in this file integer :: file_threading + integer :: geom_file_len ! geometry file name length logical :: multiple_files call callTree_enter('write_ocean_geometry_file()') @@ -1308,6 +1443,17 @@ subroutine write_ocean_geometry_file(G, param_file, directory, US, geom_file) filepath = trim(directory) // "ocean_geometry" endif + ! Append ensemble run number to filename if it is an ensemble run + call get_filename_appendix(filename_appendix) + if (len_trim(filename_appendix) > 0) then + geom_file_len = len_trim(filepath) + if (filepath(geom_file_len-2:geom_file_len) == ".nc") then + filepath = filepath(1:geom_file_len-3) // '.' // trim(filename_appendix) // ".nc" + else + filepath = filepath // '.' // trim(filename_appendix) + endif + endif + call get_param(param_file, mdl, "PARALLEL_RESTARTFILES", multiple_files, & "If true, the IO layout is used to group processors that write to the same "//& "restart file or each processor writes its own (numbered) restart file. "//& @@ -1316,40 +1462,41 @@ subroutine write_ocean_geometry_file(G, param_file, directory, US, geom_file) file_threading = SINGLE_FILE if (multiple_files) file_threading = MULTIPLE - call create_file(IO_handle, trim(filepath), vars, nFlds, fields, file_threading, dG=G) + call create_MOM_file(IO_handle, trim(filepath), vars, nFlds, fields, & + file_threading, dG=G) call MOM_write_field(IO_handle, fields(1), G%Domain, G%geoLatBu) call MOM_write_field(IO_handle, fields(2), G%Domain, G%geoLonBu) call MOM_write_field(IO_handle, fields(3), G%Domain, G%geoLatT) call MOM_write_field(IO_handle, fields(4), G%Domain, G%geoLonT) - call MOM_write_field(IO_handle, fields(5), G%Domain, G%bathyT, scale=US%Z_to_m) - call MOM_write_field(IO_handle, fields(6), G%Domain, G%CoriolisBu, scale=US%s_to_T) + call MOM_write_field(IO_handle, fields(5), G%Domain, G%bathyT, unscale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(6), G%Domain, G%CoriolisBu, unscale=US%s_to_T) - call MOM_write_field(IO_handle, fields(7), G%Domain, G%dxCv, scale=US%L_to_m) - call MOM_write_field(IO_handle, fields(8), G%Domain, G%dyCu, scale=US%L_to_m) - call MOM_write_field(IO_handle, fields(9), G%Domain, G%dxCu, scale=US%L_to_m) - call MOM_write_field(IO_handle, fields(10), G%Domain, G%dyCv, scale=US%L_to_m) - call MOM_write_field(IO_handle, fields(11), G%Domain, G%dxT, scale=US%L_to_m) - call MOM_write_field(IO_handle, fields(12), G%Domain, G%dyT, scale=US%L_to_m) - call MOM_write_field(IO_handle, fields(13), G%Domain, G%dxBu, scale=US%L_to_m) - call MOM_write_field(IO_handle, fields(14), G%Domain, G%dyBu, scale=US%L_to_m) + call MOM_write_field(IO_handle, fields(7), G%Domain, G%dxCv, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(8), G%Domain, G%dyCu, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(9), G%Domain, G%dxCu, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(10), G%Domain, G%dyCv, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(11), G%Domain, G%dxT, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(12), G%Domain, G%dyT, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(13), G%Domain, G%dxBu, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(14), G%Domain, G%dyBu, unscale=US%L_to_m) - call MOM_write_field(IO_handle, fields(15), G%Domain, G%areaT, scale=US%L_to_m**2) - call MOM_write_field(IO_handle, fields(16), G%Domain, G%areaBu, scale=US%L_to_m**2) + call MOM_write_field(IO_handle, fields(15), G%Domain, G%areaT, unscale=US%L_to_m**2) + call MOM_write_field(IO_handle, fields(16), G%Domain, G%areaBu, unscale=US%L_to_m**2) - call MOM_write_field(IO_handle, fields(17), G%Domain, G%dx_Cv, scale=US%L_to_m) - call MOM_write_field(IO_handle, fields(18), G%Domain, G%dy_Cu, scale=US%L_to_m) + call MOM_write_field(IO_handle, fields(17), G%Domain, G%dx_Cv, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(18), G%Domain, G%dy_Cu, unscale=US%L_to_m) call MOM_write_field(IO_handle, fields(19), G%Domain, G%mask2dT) if (G%bathymetry_at_vel) then - call MOM_write_field(IO_handle, fields(20), G%Domain, G%Dblock_u, scale=US%Z_to_m) - call MOM_write_field(IO_handle, fields(21), G%Domain, G%Dopen_u, scale=US%Z_to_m) - call MOM_write_field(IO_handle, fields(22), G%Domain, G%Dblock_v, scale=US%Z_to_m) - call MOM_write_field(IO_handle, fields(23), G%Domain, G%Dopen_v, scale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(20), G%Domain, G%Dblock_u, unscale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(21), G%Domain, G%Dopen_u, unscale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(22), G%Domain, G%Dblock_v, unscale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(23), G%Domain, G%Dopen_v, unscale=US%Z_to_m) endif - call close_file(IO_handle) + call IO_handle%close() deallocate(vars, fields) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 8055440cce..a411b1257c 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Initialization functions for state variables, u, v, h, T and S. module MOM_state_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_debugging, only : hchksum, qchksum, uvchksum use MOM_density_integrals, only : int_specific_vol_dp use MOM_density_integrals, only : find_depth_of_pressure_in_cell @@ -17,18 +19,15 @@ module MOM_state_initialization use MOM_file_parser, only : log_version use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type, isPointInCell -use MOM_interface_heights, only : find_eta +use MOM_interface_heights, only : find_eta, dz_to_thickness, dz_to_thickness_simple +use MOM_interface_heights, only : calc_derived_thermo use MOM_io, only : file_exists, field_size, MOM_read_data, MOM_read_vector, slasher -use MOM_open_boundary, only : ocean_OBC_type, open_boundary_init, set_tracer_data -use MOM_open_boundary, only : OBC_NONE, OBC_SIMPLE -use MOM_open_boundary, only : open_boundary_query -use MOM_open_boundary, only : set_tracer_data, initialize_segment_data -use MOM_open_boundary, only : open_boundary_test_extern_h -use MOM_open_boundary, only : fill_temp_salt_segments -use MOM_open_boundary, only : update_OBC_segment_data -!use MOM_open_boundary, only : set_3D_OBC_data -use MOM_grid_initialize, only : initialize_masks, set_grid_metrics -use MOM_restart, only : restore_state, is_new_run, MOM_restart_CS +use MOM_open_boundary, only : ocean_OBC_type, open_boundary_test_extern_h +use MOM_open_boundary, only : fill_temp_salt_segments, setup_OBC_tracer_reservoirs +use MOM_open_boundary, only : fill_thickness_segments +use MOM_open_boundary, only : set_initialized_OBC_tracer_reservoirs +use MOM_restart, only : restore_state, is_new_run, copy_restart_var, copy_restart_vector +use MOM_restart, only : restart_registry_lock, MOM_restart_CS use MOM_sponge, only : set_up_sponge_field, set_up_sponge_ML_density use MOM_sponge, only : initialize_sponge, sponge_CS use MOM_ALE_sponge, only : set_up_ALE_sponge_field, set_up_ALE_sponge_vel_field @@ -87,13 +86,12 @@ module MOM_state_initialization use dumbbell_initialization, only : dumbbell_initialize_sponges use MOM_tracer_Z_init, only : tracer_Z_init_array, determine_temperature use MOM_ALE, only : ALE_initRegridding, ALE_CS, ALE_initThicknessToCoord -use MOM_ALE, only : ALE_remap_scalar, ALE_build_grid, ALE_regrid_accelerated -use MOM_ALE, only : TS_PLM_edge_values +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 -use MOM_remapping, only : remapping_CS, initialize_remapping -use MOM_remapping, only : remapping_core_h -use MOM_horizontal_regridding, only : horiz_interp_and_extrap_tracer +use MOM_regridding, only : regridding_main, regridding_preadjust_reqs, convective_adjustment +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 use MOM_oda_incupd, only: set_up_oda_incupd_field, set_up_oda_incupd_vel_field use MOM_oda_incupd, only: calc_oda_increments, output_oda_incupd_inc @@ -102,7 +100,7 @@ module MOM_state_initialization #include -public MOM_initialize_state +public MOM_initialize_state, MOM_initialize_OBCs ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -117,7 +115,8 @@ module MOM_state_initialization !! conditions or by reading them from a restart (or saves) file. subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & restart_CS, ALE_CSp, tracer_Reg, sponge_CSp, & - ALE_sponge_CSp, oda_incupd_CSp, OBC, Time_in, frac_shelf_h) + ALE_sponge_CSp, oda_incupd_CSp, OBC_for_remap, & + Time_in, frac_shelf_h, mass_shelf, OBC_for_bug) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -136,33 +135,40 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & !! for model parameter values. type(directories), intent(in) :: dirs !< A structure containing several relevant !! directory paths. - type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure type(ALE_CS), pointer :: ALE_CSp !< The ALE control structure for remapping type(tracer_registry_type), pointer :: tracer_Reg !< A pointer to the tracer registry type(sponge_CS), pointer :: sponge_CSp !< The layerwise sponge control structure. type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< The ALE sponge control structure. - type(ocean_OBC_type), pointer :: OBC !< The open boundary condition control structure. + type(ocean_OBC_type), pointer :: OBC_for_remap !< The open boundary condition control + !! structure that may be used for remapping velocities. + !! This must be on the unrotated grid, but only the + !! position and directions of the OBC faces are used. type(oda_incupd_CS), pointer :: oda_incupd_CSp !< The oda_incupd control structure. type(time_type), optional, intent(in) :: Time_in !< Time at the start of the run segment. real, dimension(SZI_(G),SZJ_(G)), & optional, intent(in) :: frac_shelf_h !< The fraction of the grid cell covered !! by a floating ice shelf [nondim]. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: mass_shelf !< The mass per unit area of the overlying + !! ice shelf [R Z ~> kg m-2] + type(ocean_OBC_type), optional, pointer :: OBC_for_bug !< An open boundary condition control structure + !! that might be used to store OBC temperatures and + !! salinities if OBC_RESERVOIR_INIT_BUG is true. ! Local variables - real :: depth_tot(SZI_(G),SZJ_(G)) ! The nominal total depth of the ocean [Z ~> m] - character(len=200) :: filename ! The name of an input file. - character(len=200) :: filename2 ! The name of an input files. + real :: depth_tot(SZI_(G),SZJ_(G)) ! The nominal total depth of the ocean [Z ~> m] + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! The layer thicknesses in geopotential (z) units [Z ~> m] character(len=200) :: inputdir ! The directory where NetCDF input files are. - character(len=200) :: config - real :: H_rescale ! A rescaling factor for thicknesses from the representation in - ! a restart file to the internal representation in this run. - real :: vel_rescale ! A rescaling factor for velocities from the representation in - ! a restart file to the internal representation in this run. + character(len=200) :: config, h_config real :: dt ! The baroclinic dynamics timestep for this run [T ~> s]. + logical :: from_Z_file, useALE - logical :: new_sim - integer :: write_geom - logical :: use_temperature, use_sponge, use_OBC, use_oda_incupd + logical :: new_sim, rotate_index + logical :: use_temperature, use_sponge, use_oda_incupd logical :: verify_restart_time + logical :: OBC_reservoir_init_bug ! If true, set the OBC tracer reservoirs at the startup of a new + ! run from the interior tracer concentrations regardless of properties that + ! may be explicitly specified for the reservoir concentrations. logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. logical :: depress_sfc ! If true, remove the mass that would be displaced ! by a large surface pressure by squeezing the column. @@ -175,8 +181,9 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! is a run from a restart file; this option ! allows the use of Fatal unused parameters. type(EOS_type), pointer :: eos => NULL() + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. logical :: debug ! If true, write debugging output. - logical :: debug_obc ! If true, do debugging calls related to OBCs. logical :: debug_layers = .false. logical :: use_ice_shelf character(len=80) :: mesg @@ -193,7 +200,6 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & call callTree_enter("MOM_initialize_state(), MOM_state_initialization.F90") call log_version(PF, mdl, version, "") call get_param(PF, mdl, "DEBUG", debug, default=.false.) - call get_param(PF, mdl, "DEBUG_OBC", debug_obc, default=.false.) new_sim = is_new_run(restart_CS) just_read = .not.new_sim @@ -205,9 +211,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & use_temperature = associated(tv%T) useALE = associated(ALE_CSp) use_EOS = associated(tv%eqn_of_state) - use_OBC = associated(OBC) if (use_EOS) eos => tv%eqn_of_state - use_ice_shelf=PRESENT(frac_shelf_h) + use_ice_shelf = PRESENT(frac_shelf_h) !==================================================================== ! Initialize temporally evolving fields, either as initial @@ -226,6 +231,9 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & !do k=1,nz ; do j=js,je ; do i=is,ie ! h(i,j,k) = 0. !enddo + + ! Initialize the layer thicknesses. + dz(:,:,:) = 0.0 endif ! Set the nominal depth of the ocean, which might be different from the bathymetric @@ -250,6 +258,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & "salinities from a Z-space file on a latitude-longitude grid.", & default=.false., do_not_log=just_read) + convert = new_sim ! Thicknesses are initialized in height units in most cases. if (from_Z_file) then ! Initialize thickness and T/S from z-coordinate data in a file. if (.NOT.use_temperature) call MOM_error(FATAL,"MOM_initialize_state : "//& @@ -257,18 +266,23 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & call MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, & just_read=just_read, frac_shelf_h=frac_shelf_h) + convert = .false. else ! Initialize thickness, h. - call get_param(PF, mdl, "THICKNESS_CONFIG", config, & + call get_param(PF, mdl, "THICKNESS_CONFIG", h_config, & "A string that determines how the initial layer "//& "thicknesses are specified for a new run: \n"//& " \t file - read interface heights from the file specified \n"//& + " \t\t by (THICKNESS_FILE).\n"//& " \t thickness_file - read thicknesses from the file specified \n"//& " \t\t by (THICKNESS_FILE).\n"//& + " \t mass_file - read thicknesses in units of mass per unit area from the file \n"//& + " \t\t specified by (THICKNESS_FILE).\n"//& " \t coord - determined by ALE coordinate.\n"//& " \t uniform - uniform thickness layers evenly distributed \n"//& " \t\t between the surface and MAXIMUM_DEPTH. \n"//& " \t list - read a list of positive interface depths. \n"//& + " \t param - use thicknesses from parameter THICKNESS_INIT_VALUES. \n"//& " \t DOME - use a slope and channel configuration for the \n"//& " \t\t DOME sill-overflow test case. \n"//& " \t ISOMIP - use a configuration for the \n"//& @@ -287,62 +301,72 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & " \t rossby_front - a mixed layer front in thermal wind balance.\n"//& " \t USER - call a user modified routine.", & default="uniform", do_not_log=just_read) - select case (trim(config)) + select case (trim(h_config)) case ("file") - call initialize_thickness_from_file(h, depth_tot, G, GV, US, PF, .false., just_read=just_read) + call initialize_thickness_from_file(dz, depth_tot, G, GV, US, PF, file_has_thickness=.false., & + mass_file=.false., just_read=just_read) case ("thickness_file") - call initialize_thickness_from_file(h, depth_tot, G, GV, US, PF, .true., just_read=just_read) + call initialize_thickness_from_file(dz, depth_tot, G, GV, US, PF, file_has_thickness=.true., & + mass_file=.false., just_read=just_read) + case ("mass_file") + call initialize_thickness_from_file(h, depth_tot, G, GV, US, PF, file_has_thickness=.true., & + mass_file=.true., just_read=just_read) + convert = .false. case ("coord") if (new_sim .and. useALE) then - call ALE_initThicknessToCoord( ALE_CSp, G, GV, h ) + call ALE_initThicknessToCoord( ALE_CSp, G, GV, dz, height_units=.true. ) elseif (new_sim) then call MOM_error(FATAL, "MOM_initialize_state: USE_REGRIDDING must be True "//& "for THICKNESS_CONFIG of 'coord'") endif - case ("uniform"); call initialize_thickness_uniform(h, depth_tot, G, GV, PF, & + case ("uniform"); call initialize_thickness_uniform(dz, depth_tot, G, GV, PF, & just_read=just_read) - case ("list"); call initialize_thickness_list(h, depth_tot, G, GV, US, PF, & + case ("list"); call initialize_thickness_list(dz, depth_tot, G, GV, US, PF, & just_read=just_read) - case ("DOME"); call DOME_initialize_thickness(h, depth_tot, G, GV, PF, & + case ("param"); call initialize_thickness_param(dz, depth_tot, G, GV, US, PF, & + just_read=just_read) + case ("DOME"); call DOME_initialize_thickness(dz, depth_tot, G, GV, PF, & just_read=just_read) - case ("ISOMIP"); call ISOMIP_initialize_thickness(h, depth_tot, G, GV, US, PF, tv, & + case ("ISOMIP"); call ISOMIP_initialize_thickness(dz, depth_tot, G, GV, US, PF, tv, & just_read=just_read) - case ("benchmark"); call benchmark_initialize_thickness(h, depth_tot, G, GV, US, PF, & + case ("benchmark"); call benchmark_initialize_thickness(dz, depth_tot, G, GV, US, PF, & tv%eqn_of_state, tv%P_Ref, just_read=just_read) - case ("Neverworld","Neverland"); call Neverworld_initialize_thickness(h, depth_tot, & + case ("Neverworld","Neverland"); call Neverworld_initialize_thickness(dz, depth_tot, & G, GV, US, PF, tv%P_Ref) case ("search"); call initialize_thickness_search() - case ("circle_obcs"); call circle_obcs_initialize_thickness(h, depth_tot, G, GV, PF, & + case ("circle_obcs"); call circle_obcs_initialize_thickness(dz, depth_tot, G, GV, US, PF, & just_read=just_read) - case ("lock_exchange"); call lock_exchange_initialize_thickness(h, G, GV, US, & + case ("lock_exchange"); call lock_exchange_initialize_thickness(dz, G, GV, US, & PF, just_read=just_read) - case ("external_gwave"); call external_gwave_initialize_thickness(h, G, GV, US, & + case ("external_gwave"); call external_gwave_initialize_thickness(dz, G, GV, US, & PF, just_read=just_read) - case ("DOME2D"); call DOME2d_initialize_thickness(h, depth_tot, G, GV, US, PF, & + case ("DOME2D"); call DOME2d_initialize_thickness(dz, depth_tot, G, GV, US, PF, & just_read=just_read) - case ("adjustment2d"); call adjustment_initialize_thickness(h, G, GV, US, & + case ("adjustment2d"); call adjustment_initialize_thickness(dz, G, GV, US, & PF, just_read=just_read) - case ("sloshing"); call sloshing_initialize_thickness(h, depth_tot, G, GV, US, PF, & + case ("sloshing"); call sloshing_initialize_thickness(dz, depth_tot, G, GV, US, PF, & just_read=just_read) - case ("seamount"); call seamount_initialize_thickness(h, depth_tot, G, GV, US, PF, & + case ("seamount"); call seamount_initialize_thickness(dz, depth_tot, G, GV, US, PF, & just_read=just_read) - case ("dumbbell"); call dumbbell_initialize_thickness(h, depth_tot, G, GV, US, PF, & + case ("dumbbell"); call dumbbell_initialize_thickness(dz, depth_tot, G, GV, US, PF, & just_read=just_read) - case ("soliton"); call soliton_initialize_thickness(h, depth_tot, G, GV, US) - case ("phillips"); call Phillips_initialize_thickness(h, depth_tot, G, GV, US, PF, & + case ("soliton"); call soliton_initialize_thickness(dz, depth_tot, G, GV, US, PF, & just_read=just_read) - case ("rossby_front"); call Rossby_front_initialize_thickness(h, G, GV, US, & - PF, just_read=just_read) - case ("USER"); call user_initialize_thickness(h, G, GV, PF, & + case ("phillips"); call Phillips_initialize_thickness(dz, depth_tot, G, GV, US, PF, & + just_read=just_read) + case ("rossby_front") + call Rossby_front_initialize_thickness(h, G, GV, US, PF, just_read=just_read) + convert = .false. ! Rossby_front initialization works directly in thickness units. + case ("USER"); call user_initialize_thickness(dz, G, GV, PF, & just_read=just_read) case default ; call MOM_error(FATAL, "MOM_initialize_state: "//& - "Unrecognized layer thickness configuration "//trim(config)) + "Unrecognized layer thickness configuration "//trim(h_config)) end select ! Initialize temperature and salinity (T and S). if ( use_temperature ) then call get_param(PF, mdl, "TS_CONFIG", config, & - "A string that determines how the initial tempertures "//& + "A string that determines how the initial temperatures "//& "and salinities are specified for a new run: \n"//& " \t file - read velocities from the file specified \n"//& " \t\t by (TS_FILE). \n"//& @@ -363,37 +387,49 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & " \t USER - call a user modified routine.", & fail_if_missing=new_sim, do_not_log=just_read) ! " \t baroclinic_zone - an analytic baroclinic zone. \n"//& + + ! Check for incompatible THICKNESS_CONFIG and TS_CONFIG settings + if (new_sim .and. (.not.convert)) then ; select case (trim(config)) + case ("DOME2D", "ISOMIP", "adjustment2d", "baroclinic_zone", "sloshing", & + "seamount", "dumbbell", "SCM_CVMix_tests", "dense") + call MOM_error(FATAL, "TS_CONFIG = "//trim(config)//" does not work with thicknesses "//& + "that have already been converted to thickness units, as is the case with "//& + "THICKNESS_CONFIG = "//trim(h_config)//".") + end select ; endif + select case (trim(config)) case ("fit"); call initialize_temp_salt_fit(tv%T, tv%S, G, GV, US, PF, & eos, tv%P_Ref, just_read=just_read) - case ("file"); call initialize_temp_salt_from_file(tv%T, tv%S, G, GV, & + case ("file"); call initialize_temp_salt_from_file(tv%T, tv%S, G, GV, US, & PF, just_read=just_read) case ("benchmark"); call benchmark_init_temperature_salinity(tv%T, tv%S, & G, GV, US, PF, eos, tv%P_Ref, just_read=just_read) case ("TS_profile") ; call initialize_temp_salt_from_profile(tv%T, tv%S, & - G, GV, PF, just_read=just_read) - case ("linear"); call initialize_temp_salt_linear(tv%T, tv%S, G, GV, PF, & + G, GV, US, PF, just_read=just_read) + case ("linear"); call initialize_temp_salt_linear(tv%T, tv%S, G, GV, US, PF, & just_read=just_read) - case ("DOME2D"); call DOME2d_initialize_temperature_salinity ( tv%T, & - tv%S, h, G, GV, PF, just_read=just_read) - case ("ISOMIP"); call ISOMIP_initialize_temperature_salinity ( tv%T, & - tv%S, h, depth_tot, G, GV, US, PF, eos, just_read=just_read) + case ("DOME2D"); call DOME2d_initialize_temperature_salinity (tv%T, tv%S, dz, & + G, GV, US, PF, just_read=just_read) + case ("ISOMIP"); call ISOMIP_initialize_temperature_salinity (tv%T, tv%S, dz, & + depth_tot, G, GV, US, PF, eos, just_read=just_read) case ("adjustment2d"); call adjustment_initialize_temperature_salinity ( tv%T, & - tv%S, h, depth_tot, G, GV, PF, just_read=just_read) + tv%S, dz, depth_tot, G, GV, US, PF, just_read=just_read) case ("baroclinic_zone"); call baroclinic_zone_init_temperature_salinity( tv%T, & - tv%S, h, depth_tot, G, GV, US, PF, just_read=just_read) + tv%S, dz, depth_tot, G, GV, US, PF, just_read=just_read) case ("sloshing"); call sloshing_initialize_temperature_salinity(tv%T, & - tv%S, h, G, GV, PF, just_read=just_read) + tv%S, dz, G, GV, US, PF, just_read=just_read) case ("seamount"); call seamount_initialize_temperature_salinity(tv%T, & - tv%S, h, G, GV, PF, just_read=just_read) + tv%S, dz, G, GV, US, PF, just_read=just_read) case ("dumbbell"); call dumbbell_initialize_temperature_salinity(tv%T, & - tv%S, h, G, GV, PF, just_read=just_read) - case ("rossby_front"); call Rossby_front_initialize_temperature_salinity ( tv%T, & - tv%S, h, G, GV, PF, just_read=just_read) - case ("SCM_CVMix_tests"); call SCM_CVMix_tests_TS_init(tv%T, tv%S, h, & + tv%S, dz, G, GV, US, PF, just_read=just_read) + case ("rossby_front") + if (convert .and. .not.just_read) call dz_to_thickness(dz, tv, h, G, GV, US) + call Rossby_front_initialize_temperature_salinity ( tv%T, tv%S, h, & + G, GV, US, PF, just_read=just_read) + case ("SCM_CVMix_tests"); call SCM_CVMix_tests_TS_init(tv%T, tv%S, dz, & G, GV, US, PF, just_read=just_read) - case ("dense"); call dense_water_initialize_TS(G, GV, PF, tv%T, tv%S, & - h, just_read=just_read) + case ("dense"); call dense_water_initialize_TS(G, GV, US, PF, tv%T, tv%S, & + dz, just_read=just_read) case ("USER"); call user_init_temperature_salinity(tv%T, tv%S, G, GV, PF, & just_read=just_read) case default ; call MOM_error(FATAL, "MOM_initialize_state: "//& @@ -401,78 +437,51 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & end select endif endif ! not from_Z_file. - if (use_temperature .and. use_OBC) & - call fill_temp_salt_segments(G, GV, OBC, tv) - - ! The thicknesses in halo points might be needed to initialize the velocities. - if (new_sim) call pass_var(h, G%Domain) - ! Initialize velocity components, u and v - call get_param(PF, mdl, "VELOCITY_CONFIG", config, & - "A string that determines how the initial velocities "//& - "are specified for a new run: \n"//& - " \t file - read velocities from the file specified \n"//& - " \t\t by (VELOCITY_FILE). \n"//& - " \t zero - the fluid is initially at rest. \n"//& - " \t uniform - the flow is uniform (determined by\n"//& - " \t\t parameters INITIAL_U_CONST and INITIAL_V_CONST).\n"//& - " \t rossby_front - a mixed layer front in thermal wind balance.\n"//& - " \t soliton - Equatorial Rossby soliton.\n"//& - " \t USER - call a user modified routine.", default="zero", & - do_not_log=just_read) - select case (trim(config)) - case ("file"); call initialize_velocity_from_file(u, v, G, GV, US, PF, & - just_read=just_read) - case ("zero"); call initialize_velocity_zero(u, v, G, GV, PF, & - just_read=just_read) - case ("uniform"); call initialize_velocity_uniform(u, v, G, GV, US, PF, & - just_read=just_read) - case ("circular"); call initialize_velocity_circular(u, v, G, GV, US, PF, & - just_read=just_read) - case ("phillips"); call Phillips_initialize_velocity(u, v, G, GV, US, PF, & - just_read=just_read) - case ("rossby_front"); call Rossby_front_initialize_velocity(u, v, h, & - G, GV, US, PF, just_read=just_read) - case ("soliton"); call soliton_initialize_velocity(u, v, h, G, GV, US) - case ("USER"); call user_initialize_velocity(u, v, G, GV, US, PF, & - just_read=just_read) - case default ; call MOM_error(FATAL, "MOM_initialize_state: "//& - "Unrecognized velocity configuration "//trim(config)) - end select - - if (new_sim) call pass_vector(u, v, G%Domain) - if (debug .and. new_sim) then - call uvchksum("MOM_initialize_state [uv]", u, v, G%HI, haloshift=1, scale=US%m_s_to_L_T) - endif - - ! Optionally convert the thicknesses from m to kg m-2. This is particularly - ! useful in a non-Boussinesq model. - call get_param(PF, mdl, "CONVERT_THICKNESS_UNITS", convert, & - "If true, convert the thickness initial conditions from "//& - "units of m to kg m-2 or vice versa, depending on whether "//& - "BOUSSINESQ is defined. This does not apply if a restart "//& - "file is read.", default=.not.GV%Boussinesq, do_not_log=just_read) + if (present(OBC_for_bug)) then ; if (use_temperature .and. associated(OBC_for_bug)) then + call get_param(PF, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. + ! Log this parameter later with the other OBC parameters. + call get_param(PF, mdl, "OBC_RESERVOIR_INIT_BUG", OBC_reservoir_init_bug, & + "If true, set the OBC tracer reservoirs at the startup of a new run from the "//& + "interior tracer concentrations regardless of properties that may be explicitly "//& + "specified for the reservoir concentrations.", default=enable_bugs, do_not_log=.true.) + if (OBC_reservoir_init_bug) then + ! These calls should be moved down to join the OBC code, but doing so changes answers because + ! the temperatures and salinities can change due to the remapping and reading from the restarts. + call pass_var(tv%T, G%Domain, complete=.false.) + call pass_var(tv%S, G%Domain, complete=.true.) + call fill_temp_salt_segments(G, GV, US, OBC_for_bug, tv) + endif + endif ; endif - if (new_sim .and. convert .and. .not.GV%Boussinesq) & - ! Convert thicknesses from geomtric distances to mass-per-unit-area. - call convert_thickness(h, G, GV, US, tv) + ! Convert thicknesses from geometric distances in depth units to thickness units or mass-per-unit-area. + if (new_sim .and. convert) call dz_to_thickness(dz, tv, h, G, GV, US) - ! Remove the mass that would be displaced by an ice shelf or inverse barometer. + ! Handle the initial surface displacement under ice shelf call get_param(PF, mdl, "DEPRESS_INITIAL_SURFACE", depress_sfc, & - "If true, depress the initial surface to avoid huge "//& - "tsunamis when a large surface pressure is applied.", & - default=.false., do_not_log=just_read) + "If true, depress the initial surface to avoid huge "//& + "tsunamis when a large surface pressure is applied.", & + default=.false., do_not_log=just_read) call get_param(PF, mdl, "TRIM_IC_FOR_P_SURF", trim_ic_for_p_surf, & - "If true, cuts way the top of the column for initial conditions "//& - "at the depth where the hydrostatic pressure matches the imposed "//& - "surface pressure which is read from file.", default=.false., & - do_not_log=just_read) + "If true, cuts way the top of the column for initial conditions "//& + "at the depth where the hydrostatic pressure matches the imposed "//& + "surface pressure which is read from file.", default=.false., & + do_not_log=just_read) if (depress_sfc .and. trim_ic_for_p_surf) call MOM_error(FATAL, "MOM_initialize_state: "//& "DEPRESS_INITIAL_SURFACE and TRIM_IC_FOR_P_SURF are exclusive and cannot both be True") + if (new_sim .and. debug .and. (depress_sfc .or. trim_ic_for_p_surf)) & - call hchksum(h, "Pre-depress: h ", G%HI, haloshift=1, scale=GV%H_to_m) - if (depress_sfc) call depress_surface(h, G, GV, US, PF, tv, just_read=just_read) - if (trim_ic_for_p_surf) call trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read=just_read) + call hchksum(h, "Pre-depress: h ", G%HI, haloshift=1, unscale=GV%H_to_MKS) + + ! Remove the mass that would be displaced by an ice shelf or inverse barometer. + if (depress_sfc) then + call depress_surface(h, G, GV, US, PF, tv, just_read=just_read) + elseif (trim_ic_for_p_surf) then + call trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read=just_read) + elseif (new_sim .and. use_ice_shelf .and. present(mass_shelf)) then + call calc_sfc_displacement(PF, G, GV, US, mass_shelf, tv, h) + endif ! Perhaps we want to run the regridding coordinate generator for multiple ! iterations here so the initial grid is consistent with the coordinate @@ -488,27 +497,67 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & "an initial grid that is consistent with the initial conditions.", & default=1, do_not_log=just_read) - call get_param(PF, mdl, "DT", dt, "Timestep", fail_if_missing=.true., scale=US%s_to_T) + call get_param(PF, mdl, "DT", dt, "Timestep", & + units="s", scale=US%s_to_T, fail_if_missing=.true.) if (new_sim .and. debug) & - call hchksum(h, "Pre-ALE_regrid: h ", G%HI, haloshift=1, scale=GV%H_to_m) - call ALE_regrid_accelerated(ALE_CSp, G, GV, h, tv, regrid_iterations, u, v, OBC, tracer_Reg, & - dt=dt, initial=.true.) + call hchksum(h, "Pre-ALE_regrid: h ", G%HI, haloshift=1, unscale=GV%H_to_MKS) + ! In this call, OBC_for_remap is only used for the directions of OBCs when setting thicknesses at + ! velocity points. + call ALE_regrid_accelerated(ALE_CSp, G, GV, US, h, tv, regrid_iterations, u, v, OBC_for_remap, & + tracer_Reg, dt=dt, initial=.true.) endif endif + ! The thicknesses in halo points might be needed to initialize the velocities. + if (new_sim) call pass_var(h, G%Domain) + + ! Initialize velocity components, u and v + call get_param(PF, mdl, "VELOCITY_CONFIG", config, & + "A string that determines how the initial velocities "//& + "are specified for a new run: \n"//& + " \t file - read velocities from the file specified \n"//& + " \t\t by (VELOCITY_FILE). \n"//& + " \t zero - the fluid is initially at rest. \n"//& + " \t uniform - the flow is uniform (determined by\n"//& + " \t\t parameters INITIAL_U_CONST and INITIAL_V_CONST).\n"//& + " \t rossby_front - a mixed layer front in thermal wind balance.\n"//& + " \t soliton - Equatorial Rossby soliton.\n"//& + " \t USER - call a user modified routine.", default="zero", & + do_not_log=just_read) + select case (trim(config)) + case ("file"); call initialize_velocity_from_file(u, v, G, GV, US, PF, just_read) + case ("zero"); call initialize_velocity_zero(u, v, G, GV, PF, just_read) + case ("uniform"); call initialize_velocity_uniform(u, v, G, GV, US, PF, just_read) + case ("circular"); call initialize_velocity_circular(u, v, G, GV, US, PF, just_read) + case ("phillips"); call Phillips_initialize_velocity(u, v, G, GV, US, PF, just_read) + case ("rossby_front"); call Rossby_front_initialize_velocity(u, v, h, & + G, GV, US, PF, just_read) + case ("soliton"); call soliton_initialize_velocity(u, v, G, GV, US, PF, just_read) + case ("USER"); call user_initialize_velocity(u, v, G, GV, US, PF, just_read) + case default ; call MOM_error(FATAL, "MOM_initialize_state: "//& + "Unrecognized velocity configuration "//trim(config)) + end select + + if (new_sim) call pass_vector(u, v, G%Domain) + if (debug .and. new_sim) then + call uvchksum("MOM_initialize_state [uv]", u, v, G%HI, haloshift=1, unscale=US%L_T_to_m_s) + endif + + ! This is the end of the block of code that might have initialized fields + ! internally at the start of a new run. + ! Initialized assimilative incremental update (oda_incupd) structure and ! register restart. call get_param(PF, mdl, "ODA_INCUPD", use_oda_incupd, & "If true, oda incremental updates will be applied "//& "everywhere in the domain.", default=.false.) if (use_oda_incupd) then + call restart_registry_lock(restart_CS, unlocked=.true.) call initialize_oda_incupd_fixed(G, GV, US, oda_incupd_CSp, restart_CS) + call restart_registry_lock(restart_CS) endif - ! This is the end of the block of code that might have initialized fields - ! internally at the start of a new run. - if (.not.new_sim) then ! This block restores the state from a restart file. ! This line calls a subroutine that reads the initial conditions ! from a previously generated file. @@ -518,15 +567,17 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & "MOM6 attempted to restart from a file from a different time than given by Time_in.") Time = Time_in endif - if ((GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= GV%m_to_H)) then - H_rescale = GV%m_to_H / GV%m_to_H_restart - do k=1,nz ; do j=js,je ; do i=is,ie ; h(i,j,k) = H_rescale * h(i,j,k) ; enddo ; enddo ; enddo - endif - if ( (US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & - ((US%m_to_L * US%s_to_T_restart) /= (US%m_to_L_restart * US%s_to_T)) ) then - vel_rescale = (US%m_to_L * US%s_to_T_restart) / (US%m_to_L_restart * US%s_to_T) - do k=1,nz ; do j=jsd,jed ; do I=IsdB,IeDB ; u(I,j,k) = vel_rescale * u(I,j,k) ; enddo ; enddo ; enddo - do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied ; v(i,J,k) = vel_rescale * v(i,J,k) ; enddo ; enddo ; enddo + call get_param(PF, mdl, "ROTATE_INDEX", rotate_index, & + "Enable rotation of the horizontal indices.", & + default=.false., debuggingParam=.true., do_not_log=.true.) + if (rotate_index) then + ! This model is using a rotated grid, so the unrotated variables used here have not been set yet. + call copy_restart_var(h, "h", restart_CS, .true.) + call copy_restart_vector(u, v, "u", "v", restart_CS, .true.) + if ( use_temperature ) then + call copy_restart_var(tv%T, "Temp", restart_CS, .true.) + call copy_restart_var(tv%S, "Salt", restart_CS, .true.) + endif endif endif @@ -537,14 +588,14 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & call pass_var(h, G%Domain) if (debug) then - call hchksum(h, "MOM_initialize_state: h ", G%HI, haloshift=1, scale=GV%H_to_m) - if ( use_temperature ) call hchksum(tv%T, "MOM_initialize_state: T ", G%HI, haloshift=1) - if ( use_temperature ) call hchksum(tv%S, "MOM_initialize_state: S ", G%HI, haloshift=1) + call hchksum(h, "MOM_initialize_state: h ", G%HI, haloshift=1, unscale=GV%H_to_MKS) + if ( use_temperature ) call hchksum(tv%T, "MOM_initialize_state: T ", G%HI, haloshift=1, unscale=US%C_to_degC) + if ( use_temperature ) call hchksum(tv%S, "MOM_initialize_state: S ", G%HI, haloshift=1, unscale=US%S_to_ppt) if ( use_temperature .and. debug_layers) then ; do k=1,nz - write(mesg,'("MOM_IS: T[",I2,"]")') k - call hchksum(tv%T(:,:,k), mesg, G%HI, haloshift=1) - write(mesg,'("MOM_IS: S[",I2,"]")') k - call hchksum(tv%S(:,:,k), mesg, G%HI, haloshift=1) + write(mesg,'("MOM_IS: T[",I0,"]")') k + call hchksum(tv%T(:,:,k), mesg, G%HI, haloshift=1, unscale=US%C_to_degC) + write(mesg,'("MOM_IS: S[",I0,"]")') k + call hchksum(tv%S(:,:,k), mesg, G%HI, haloshift=1, unscale=US%S_to_ppt) enddo ; endif endif @@ -570,12 +621,12 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & sponge_CSp, ALE_sponge_CSp) case ("ISOMIP"); call ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, useALE, & sponge_CSp, ALE_sponge_CSp) - case("RGC"); call RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, useALE, & + case ("RGC"); call RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, useALE, & sponge_CSp, ALE_sponge_CSp) case ("USER"); call user_initialize_sponges(G, GV, use_temperature, tv, PF, sponge_CSp, h) case ("BFB"); call BFB_initialize_sponges_southonly(G, GV, US, use_temperature, tv, depth_tot, PF, & sponge_CSp, h) - case ("DUMBBELL"); call dumbbell_initialize_sponges(G, GV, US, tv, depth_tot, PF, useALE, & + case ("DUMBBELL"); call dumbbell_initialize_sponges(G, GV, US, tv, h, depth_tot, PF, useALE, & sponge_CSp, ALE_sponge_CSp) case ("phillips"); call Phillips_initialize_sponges(G, GV, US, tv, PF, sponge_CSp, h) case ("dense"); call dense_water_initialize_sponges(G, GV, US, tv, depth_tot, PF, useALE, & @@ -587,17 +638,72 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & end select endif - ! Reads OBC parameters not pertaining to the location of the boundaries - call open_boundary_init(G, GV, US, PF, OBC, restart_CS) + ! Set-up of data Assimilation with incremental update + if (use_oda_incupd) then + call initialize_oda_incupd_file(G, GV, US, use_temperature, tv, h, u, v, & + PF, oda_incupd_CSp, restart_CS, Time) + endif + + call callTree_leave('MOM_initialize_state()') + +end subroutine MOM_initialize_state - ! This controls user code for setting open boundary data +subroutine MOM_initialize_OBCs(h, tv, OBC, Time, G, GV, US, PF, restart_CS, tracer_Reg) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic + !! variables + type(ocean_OBC_type), pointer :: OBC !< The open boundary condition control structure. + type(time_type), intent(in) :: Time !< Time at the start of the run segment. + type(param_file_type), intent(in) :: PF !< A structure indicating the open file to parse + !! for model parameter values. + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure + type(tracer_registry_type), pointer :: tracer_Reg !< A pointer to the tracer registry + + ! Local variables + character(len=200) :: config + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. + logical :: debug ! If true, write debugging output. + logical :: debug_obc ! If true, do additional calls resetting values to help debug the correctness + ! of the open boundary condition code. + logical :: OBC_reservoir_init_bug ! If true, set the OBC tracer reservoirs at the startup of a new + ! run from the interior tracer concentrations regardless of properties that + ! may be explicitly specified for the reservoir concentrations. + + call callTree_enter('MOM_initialize_OBCs()') if (associated(OBC)) then - call initialize_segment_data(G, OBC, PF) ! call initialize_segment_data(G, OBC, param_file) -! call open_boundary_config(G, US, PF, OBC) - ! Call this once to fill boundary arrays from fixed values - if (.not. OBC%needs_IO_for_data) & - call update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) + call get_param(PF, mdl, "DEBUG", debug, default=.false.) + call get_param(PF, mdl, "OBC_DEBUGGING_TESTS", debug_obc, & + "If true, do additional calls resetting values to help verify the correctness "//& + "of the open boundary condition code.", default=.false., & + do_not_log=.true., old_name="DEBUG_OBC", debuggingParam=.true.) + call get_param(PF, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. + call get_param(PF, mdl, "OBC_RESERVOIR_INIT_BUG", OBC_reservoir_init_bug, & + "If true, set the OBC tracer reservoirs at the startup of a new run from the "//& + "interior tracer concentrations regardless of properties that may be explicitly "//& + "specified for the reservoir concentrations.", default=enable_bugs) + if (associated(tv%T)) then + if (OBC_reservoir_init_bug) then + if (is_new_run(restart_CS)) then + ! Set up OBC%trex_x and OBC%tres_y as they have not been read from a restart file. + call setup_OBC_tracer_reservoirs(G, GV, OBC) + ! Ensure that the values of the tracer reservoirs that have just been set will not be revised. + call set_initialized_OBC_tracer_reservoirs(G, OBC, restart_CS) + endif + else + ! Store the updated temperatures and salinities at the open boundaries, noting that they may + ! still be updated by the calls in the next 50 lines, so the code setting the tracer + ! reservoir values will come later in the calling routine. + call fill_temp_salt_segments(G, GV, US, OBC, tv) + endif + endif + ! This controls user code for setting open boundary data call get_param(PF, mdl, "OBC_USER_CONFIG", config, & "A string that sets how the user code is invoked to set open boundary data: \n"//& " DOME - specified inflow on northern boundary\n"//& @@ -629,39 +735,32 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & call MOM_error(FATAL, "The open boundary conditions specified by "//& "OBC_USER_CONFIG = "//trim(config)//" have not been fully implemented.") endif - if (open_boundary_query(OBC, apply_open_OBC=.true.)) then - call set_tracer_data(OBC, tv, h, G, GV, PF) + + if (debug) then + call hchksum(G%mask2dT, 'MOM_initialize_OBCs: mask2dT ', G%HI) + call uvchksum('MOM_initialize_OBCs: mask2dC[uv]', G%mask2dCu, G%mask2dCv, G%HI) + call qchksum(G%mask2dBu, 'MOM_initialize_OBCs: mask2dBu ', G%HI) endif - endif -! if (open_boundary_query(OBC, apply_nudged_OBC=.true.)) then -! call set_3D_OBC_data(OBC, tv, h, G, PF, tracer_Reg) -! endif - ! Still need a way to specify the boundary values - if (debug.and.associated(OBC)) then - call hchksum(G%mask2dT, 'MOM_initialize_state: mask2dT ', G%HI) - call uvchksum('MOM_initialize_state: mask2dC[uv]', G%mask2dCu, & - G%mask2dCv, G%HI) - call qchksum(G%mask2dBu, 'MOM_initialize_state: mask2dBu ', G%HI) + if (debug_OBC) call open_boundary_test_extern_h(G, GV, OBC, h) + + if (OBC%use_h_res) & + call fill_thickness_segments(G, GV, US, OBC, h) endif - if (debug_OBC) call open_boundary_test_extern_h(G, GV, OBC, h) - call callTree_leave('MOM_initialize_state()') + call callTree_leave('MOM_initialize_OBCs()') - ! Set-up of data Assimilation with incremental update - if (use_oda_incupd) then - call initialize_oda_incupd_file(G, GV, US, use_temperature, tv, h, u, v, & - PF, oda_incupd_CSp, restart_CS, Time) - endif -end subroutine MOM_initialize_state +end subroutine MOM_initialize_OBCs !> Reads the layer thicknesses or interface heights from a file. subroutine initialize_thickness_from_file(h, depth_tot, G, GV, US, param_file, file_has_thickness, & - just_read) + just_read, mass_file) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized, in height + !! or thickness units, depending on the value of + !! mass_file [Z ~> m] or [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file @@ -671,13 +770,25 @@ subroutine initialize_thickness_from_file(h, depth_tot, G, GV, US, param_file, f !! interface heights. logical, intent(in) :: just_read !< If true, this call will only read !! parameters without changing h. + logical, intent(in) :: mass_file !< If true, this file contains layer thicknesses in + !! units of mass per unit area. ! Local variables real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! Interface heights, in depth units [Z ~> m]. - integer :: inconsistent = 0 + real :: h_rescale ! A factor by which to rescale the initial thickness variable in the input + ! file to convert it to units of m [various] + real :: eta_rescale ! A factor by which to rescale the initial interface heights to convert + ! them to units of m or correct sign conventions to positive upward [various] + real :: h_tolerance ! A parameter that controls the tolerance when adjusting the + ! thickness to fit the bathymetry [Z ~> m]. + real :: tol_dz_bot ! A tolerance for detecting inconsistent bottom depths when + ! correct_thickness is false [Z ~> m] + integer :: inconsistent ! The total number of cells with in consistent topography and layer thicknesses. logical :: correct_thickness character(len=40) :: mdl = "initialize_thickness_from_file" ! This subroutine's name. character(len=200) :: filename, thickness_file, inputdir, mesg ! Strings for file/path + character(len=80) :: eta_var ! The interface height variable name in the input file + character(len=80) :: h_var ! The thickness variable name in the input file integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -691,46 +802,81 @@ subroutine initialize_thickness_from_file(h, depth_tot, G, GV, US, param_file, f "The name of the thickness file.", & fail_if_missing=.not.just_read, do_not_log=just_read) - filename = trim(inputdir)//trim(thickness_file) + filename = trim(thickness_file) + if (scan(thickness_file, "/") == 0) then ! prepend inputdir if only a filename is given + filename = trim(inputdir)//trim(thickness_file) + endif if (.not.just_read) call log_param(param_file, mdl, "INPUTDIR/THICKNESS_FILE", filename) if ((.not.just_read) .and. (.not.file_exists(filename, G%Domain))) call MOM_error(FATAL, & " initialize_thickness_from_file: Unable to open "//trim(filename)) if (file_has_thickness) then - !### Consider adding a parameter to use to rescale h. + call get_param(param_file, mdl, "THICKNESS_IC_VAR", h_var, & + "The variable name for layer thickness initial conditions.", & + default="h", do_not_log=just_read) + call get_param(param_file, mdl, "THICKNESS_IC_RESCALE", h_rescale, & + 'A factor by which to rescale the initial thicknesses in the input file to '//& + 'convert them to units of kg/m2 (if THICKNESS_CONFIG="mass_file") or m.', & + default=1.0, units="various", do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. - call MOM_read_data(filename, "h", h(:,:,:), G%Domain, scale=GV%m_to_H) + + if (mass_file) then + h_rescale = h_rescale*GV%kg_m2_to_H + else + h_rescale = h_rescale*US%m_to_Z + endif + call MOM_read_data(filename, h_var, h(:,:,:), G%Domain, scale=h_rescale) else call get_param(param_file, mdl, "ADJUST_THICKNESS", correct_thickness, & "If true, all mass below the bottom removed if the "//& "topography is shallower than the thickness input file "//& "would indicate.", default=.false., do_not_log=just_read) + if (correct_thickness) then + call get_param(param_file, mdl, "THICKNESS_TOLERANCE", h_tolerance, & + "A parameter that controls the tolerance when adjusting the "//& + "thickness to fit the bathymetry. Used when ADJUST_THICKNESS=True.", & + units="m", default=0.1, scale=US%m_to_Z, do_not_log=just_read) + endif + call get_param(param_file, mdl, "DZ_BOTTOM_TOLERANCE", tol_dz_bot, & + "A tolerance for detecting inconsistent topography and input layer "//& + "thicknesses when ADJUST_THICKNESS is false.", & + units="m", default=1.0, scale=US%m_to_Z, & + do_not_log=(just_read.or.correct_thickness)) + call get_param(param_file, mdl, "INTERFACE_IC_VAR", eta_var, & + "The variable name for initial conditions for interface heights "//& + "relative to mean sea level, positive upward unless otherwise rescaled.", & + default="eta", do_not_log=just_read) + call get_param(param_file, mdl, "INTERFACE_IC_RESCALE", eta_rescale, & + "A factor by which to rescale the initial interface heights to convert "//& + "them to units of m or correct sign conventions to positive upward.", & + default=1.0, units="various", do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. - call MOM_read_data(filename, "eta", eta(:,:,:), G%Domain, scale=US%m_to_Z) + call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain, scale=US%m_to_Z*eta_rescale) if (correct_thickness) then - call adjustEtaToFitBathymetry(G, GV, US, eta, h, dZ_ref_eta=G%Z_ref) + call adjustEtaToFitBathymetry(G, GV, US, eta, h, h_tolerance, dZ_ref_eta=G%Z_ref) else do k=nz,1,-1 ; do j=js,je ; do i=is,ie if (eta(i,j,K) < (eta(i,j,K+1) + GV%Angstrom_Z)) then eta(i,j,K) = eta(i,j,K+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + h(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H * (eta(i,j,K) - eta(i,j,K+1)) + h(i,j,k) = eta(i,j,K) - eta(i,j,K+1) endif enddo ; enddo ; enddo + inconsistent = 0 do j=js,je ; do i=is,ie - if (abs(eta(i,j,nz+1) + depth_tot(i,j)) > 1.0*US%m_to_Z) & + if (abs(eta(i,j,nz+1) + depth_tot(i,j)) > tol_dz_bot) & inconsistent = inconsistent + 1 enddo ; enddo call sum_across_PEs(inconsistent) if ((inconsistent > 0) .and. (is_root_pe())) then write(mesg,'("Thickness initial conditions are inconsistent ",'// & - '"with topography in ",I8," places.")') inconsistent + '"with topography in ",I0," places.")') inconsistent call MOM_error(WARNING, mesg) endif endif @@ -745,31 +891,29 @@ end subroutine initialize_thickness_from_file !! layers are contracted to ANGSTROM thickness (which may be 0). !! If the bottom most interface is above the topography then the entire column !! is dilated (expanded) to fill the void. -!! @remark{There is a (hard-wired) "tolerance" parameter such that the -!! criteria for adjustment must equal or exceed 10cm.} -subroutine adjustEtaToFitBathymetry(G, GV, US, eta, h, dZ_ref_eta) +subroutine adjustEtaToFitBathymetry(G, GV, US, eta, h, ht, dZ_ref_eta) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: eta !< Interface heights [Z ~> m]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thicknesses [Z ~> m] + real, intent(in) :: ht !< Tolerance to exceed adjustment + !! criteria [Z ~> m] real, optional, intent(in) :: dZ_ref_eta !< The difference between the !! reference heights for bathyT and !! eta [Z ~> m], 0 by default. ! Local variables integer :: i, j, k, is, ie, js, je, nz, contractions, dilations - real :: hTolerance = 0.1 !< Tolerance to exceed adjustment criteria [Z ~> m] real :: dilate ! A factor by which the column is dilated [nondim] real :: dZ_ref ! The difference in the reference heights for G%bathyT and eta [Z ~> m] character(len=100) :: mesg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - hTolerance = 0.1*US%m_to_Z dZ_ref = 0.0 ; if (present(dZ_ref_eta)) dZ_ref = dZ_ref_eta contractions = 0 do j=js,je ; do i=is,ie - if (-eta(i,j,nz+1) > (G%bathyT(i,j) + dZ_ref) + hTolerance) then + if (-eta(i,j,nz+1) > (G%bathyT(i,j) + dZ_ref) + ht) then eta(i,j,nz+1) = -(G%bathyT(i,j) + dZ_ref) contractions = contractions + 1 endif @@ -777,7 +921,7 @@ subroutine adjustEtaToFitBathymetry(G, GV, US, eta, h, dZ_ref_eta) call sum_across_PEs(contractions) if ((contractions > 0) .and. (is_root_pe())) then write(mesg,'("Thickness initial conditions were contracted ",'// & - '"to fit topography in ",I8," places.")') contractions + '"to fit topography in ",I0," places.")') contractions call MOM_error(WARNING, 'adjustEtaToFitBathymetry: '//mesg) endif @@ -799,7 +943,7 @@ subroutine adjustEtaToFitBathymetry(G, GV, US, eta, h, dZ_ref_eta) ! The whole column is dilated to accommodate deeper topography than ! the bathymetry would indicate. ! This should be... if ((G%mask2dt(i,j)*(eta(i,j,1)-eta(i,j,nz+1)) > 0.0) .and. & - if (-eta(i,j,nz+1) < (G%bathyT(i,j) + dZ_ref) - hTolerance) then + if (-eta(i,j,nz+1) < (G%bathyT(i,j) + dZ_ref) - ht) then dilations = dilations + 1 if (eta(i,j,1) <= eta(i,j,nz+1)) then do k=1,nz ; h(i,j,k) = (eta(i,j,1) + (G%bathyT(i,j) + dZ_ref)) / real(nz) ; enddo @@ -811,15 +955,11 @@ subroutine adjustEtaToFitBathymetry(G, GV, US, eta, h, dZ_ref_eta) endif enddo ; enddo - ! Now convert thicknesses to units of H. - do k=1,nz ; do j=js,je ; do i=is,ie - h(i,j,k) = h(i,j,k)*GV%Z_to_H - enddo ; enddo ; enddo call sum_across_PEs(dilations) if ((dilations > 0) .and. (is_root_pe())) then write(mesg,'("Thickness initial conditions were dilated ",'// & - '"to fit topography in ",I8," places.")') dilations + '"to fit topography in ",I0," places.")') dilations call MOM_error(WARNING, 'adjustEtaToFitBathymetry: '//mesg) endif @@ -830,7 +970,7 @@ subroutine initialize_thickness_uniform(h, depth_tot, G, GV, param_file, just_re type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file @@ -839,10 +979,10 @@ subroutine initialize_thickness_uniform(h, depth_tot, G, GV, param_file, just_re !! parameters without changing h. ! Local variables character(len=40) :: mdl = "initialize_thickness_uniform" ! This subroutine's name. - real :: e0(SZK_(GV)+1) ! The resting interface heights, in depth units, usually + real :: e0(SZK_(GV)+1) ! The resting interface heights [Z ~> m], usually ! negative because it is positive upward. - real :: eta1D(SZK_(GV)+1)! Interface height relative to the sea surface - ! positive upward, in depth units. + real :: eta1D(SZK_(GV)+1)! Interface height relative to the sea surface, + ! positive upward [Z ~> 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 @@ -852,7 +992,7 @@ subroutine initialize_thickness_uniform(h, depth_tot, G, GV, param_file, just_re call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") if (G%max_depth<=0.) call MOM_error(FATAL,"initialize_thickness_uniform: "// & - "MAXIMUM_DEPTH has a non-sensical value! Was it set?") + "MAXIMUM_DEPTH has a nonsensical value! Was it set?") do k=1,nz e0(K) = -G%max_depth * real(k-1) / real(nz) @@ -869,9 +1009,9 @@ subroutine initialize_thickness_uniform(h, depth_tot, G, GV, param_file, just_re eta1D(K) = e0(K) if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_Z)) then eta1D(K) = eta1D(K+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + h(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H * (eta1D(K) - eta1D(K+1)) + h(i,j,k) = eta1D(K) - eta1D(K+1) endif enddo enddo ; enddo @@ -883,9 +1023,9 @@ end subroutine initialize_thickness_uniform subroutine initialize_thickness_list(h, depth_tot, G, GV, US, param_file, just_read) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file @@ -899,7 +1039,7 @@ subroutine initialize_thickness_list(h, depth_tot, G, GV, US, param_file, just_r real :: eta1D(SZK_(GV)+1)! Interface height relative to the sea surface ! positive upward, in depth units [Z ~> m]. character(len=200) :: filename, eta_file, inputdir ! Strings for file/path - character(len=72) :: eta_var + character(len=72) :: eta_var ! The interface height variable name in the input file integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -944,9 +1084,9 @@ subroutine initialize_thickness_list(h, depth_tot, G, GV, US, param_file, just_r eta1D(K) = e0(K) if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_Z)) then eta1D(K) = eta1D(K+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + h(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H * (eta1D(K) - eta1D(K+1)) + h(i,j,k) = eta1D(K) - eta1D(K+1) endif enddo enddo ; enddo @@ -954,88 +1094,75 @@ subroutine initialize_thickness_list(h, depth_tot, G, GV, US, param_file, just_r call callTree_leave(trim(mdl)//'()') end subroutine initialize_thickness_list -!> Search density space for location of layers (not implemented!) -subroutine initialize_thickness_search - call MOM_error(FATAL," MOM_state_initialization.F90, initialize_thickness_search: NOT IMPLEMENTED") -end subroutine initialize_thickness_search - -!> Converts thickness from geometric to pressure units -subroutine convert_thickness(h, G, GV, US, tv) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type +!> Initializes thickness based on a run-time parameter with nominal thickness +!! for each layer +subroutine initialize_thickness_param(h, depth_tot, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: h !< Input geometric layer thicknesses being converted - !! to layer pressure [H ~> m or kg m-2]. - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various - !! thermodynamic variables + intent(out) :: h !< The thickness that is being initialized [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing h. ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: & - p_top, p_bot ! Pressure at the interfaces above and below a layer [R L2 T-2 ~> Pa] - real :: dz_geo(SZI_(G),SZJ_(G)) ! The change in geopotential height across a layer [L2 T-2 ~> m2 s-2] - real :: rho(SZI_(G)) ! The in situ density [R ~> kg m-3] - real :: I_gEarth ! Unit conversion factors divided by the gravitational acceleration - ! [H T2 R-1 L-2 ~> s2 m2 kg-1 or s2 m-1] - real :: HR_to_pres ! A conversion factor from the input geometric thicknesses times the layer - ! densities into pressure units [L2 T-2 H-1 ~> m s-2 or m4 kg-1 s-2]. - integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state - integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - integer :: itt, max_itt + character(len=40) :: mdl = "initialize_thickness_param" ! This subroutine's name. + real :: e0(SZK_(GV)+1) ! The resting interface heights [Z ~> m], usually + ! negative because it is positive upward. + real :: eta1D(SZK_(GV)+1)! Interface height relative to the sea surface, + ! positive upward [Z ~> m]. + real :: dz(SZK_(GV)) ! The nominal initial layer thickness [Z ~> m], usually + real :: h0_def(SZK_(GV)) ! Uniform default values for dz [Z ~> m], usually + integer :: i, j, k, is, ie, js, je, nz + + call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") + if (G%max_depth<=0.) call MOM_error(FATAL, "initialize_thickness_param: "// & + "MAXIMUM_DEPTH has a nonsensical value! Was it set?") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - max_itt = 10 - if (GV%Boussinesq) then - call MOM_error(FATAL,"Not yet converting thickness with Boussinesq approx.") - else - I_gEarth = GV%RZ_to_H / GV%g_Earth - HR_to_pres = GV%g_Earth * GV%H_to_Z + h0_def(:) = ( G%max_depth / real(nz) ) * US%Z_to_m + call get_param(param_file, mdl, "THICKNESS_INIT_VALUES", dz, & + "A list of nominal thickness for each layer to initialize with", & + units="m", scale=US%m_to_Z, defaults=h0_def, do_not_log=just_read) + if (just_read) return ! This subroutine has no run-time parameters. - if (associated(tv%eqn_of_state)) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - p_bot(i,j) = 0.0 ; p_top(i,j) = 0.0 - enddo ; enddo - EOSdom(:) = EOS_domain(G%HI) - do k=1,nz - do j=js,je - do i=is,ie ; p_top(i,j) = p_bot(i,j) ; enddo - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_top(:,j), rho, & - tv%eqn_of_state, EOSdom) - do i=is,ie - p_bot(i,j) = p_top(i,j) + HR_to_pres * (h(i,j,k) * rho(i)) - enddo - enddo + e0(nz+1) = -G%max_depth + do k=nz, 1, -1 + e0(K) = e0(K+1) + dz(k) + enddo - do itt=1,max_itt - call int_specific_vol_dp(tv%T(:,:,k), tv%S(:,:,k), p_top, p_bot, 0.0, G%HI, & - tv%eqn_of_state, US, dz_geo) - if (itt < max_itt) then ; do j=js,je - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_bot(:,j), rho, & - tv%eqn_of_state, EOSdom) - ! Use Newton's method to correct the bottom value. - ! The hydrostatic equation is sufficiently linear that no bounds-checking is needed. - do i=is,ie - p_bot(i,j) = p_bot(i,j) + rho(i) * (HR_to_pres*h(i,j,k) - dz_geo(i,j)) - enddo - enddo ; endif - enddo + do j=js,je ; do i=is,ie + ! This sets the initial thickness (in m) of the layers. The + ! thicknesses are set to insure that: 1. each layer is at least an + ! Angstrom thick, and 2. the interfaces are where they should be + ! based on the resting depths and interface height perturbations, + ! as long at this doesn't interfere with 1. + eta1D(nz+1) = -depth_tot(i,j) + do k=nz,1,-1 + eta1D(K) = e0(K) + if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_Z)) then + eta1D(K) = eta1D(K+1) + GV%Angstrom_Z + h(i,j,k) = GV%Angstrom_Z + else + h(i,j,k) = eta1D(K) - eta1D(K+1) + endif + enddo + enddo ; enddo - do j=js,je ; do i=is,ie - h(i,j,k) = (p_bot(i,j) - p_top(i,j)) * I_gEarth - enddo ; enddo - enddo - else - do k=1,nz ; do j=js,je ; do i=is,ie - h(i,j,k) = h(i,j,k) * (GV%Rlay(k) / GV%Rho0) - enddo ; enddo ; enddo - endif - endif + call callTree_leave(trim(mdl)//'()') +end subroutine initialize_thickness_param -end subroutine convert_thickness +!> Search density space for location of layers (not implemented!) +subroutine initialize_thickness_search + call MOM_error(FATAL," MOM_state_initialization.F90, initialize_thickness_search: NOT IMPLEMENTED") +end subroutine initialize_thickness_search !> Depress the sea-surface based on an initial condition file -subroutine depress_surface(h, G, GV, US, param_file, tv, just_read) +subroutine depress_surface(h, G, GV, US, param_file, tv, just_read, z_top_shelf) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -1045,42 +1172,54 @@ subroutine depress_surface(h, G, GV, US, param_file, tv, just_read) type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables logical, intent(in) :: just_read !< If true, this call will only read !! parameters without changing h. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: z_top_shelf !< Top interface position under ice shelf [Z ~> m] ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & eta_sfc ! The free surface height that the model should use [Z ~> m]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & eta ! The free surface height that the model should use [Z ~> m]. real :: dilate ! A ratio by which layers are dilated [nondim]. - real :: scale_factor ! A scaling factor for the eta_sfc values that are read - ! in, which can be used to change units, for example. + real :: scale_factor ! A scaling factor for the eta_sfc values that are read in, + ! which can be used to change units, for example, often [Z m-1 ~> 1]. character(len=40) :: mdl = "depress_surface" ! This subroutine's name. character(len=200) :: inputdir, eta_srf_file ! Strings for file/path character(len=200) :: filename, eta_srf_var ! Strings for file/path integer :: i, j, k, is, ie, js, je, nz + logical :: use_z_shelf is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - ! Read the surface height (or pressure) from a file. + use_z_shelf = present(z_top_shelf) - call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") - inputdir = slasher(inputdir) - call get_param(param_file, mdl, "SURFACE_HEIGHT_IC_FILE", eta_srf_file,& - "The initial condition file for the surface height.", & - fail_if_missing=.not.just_read, do_not_log=just_read) - call get_param(param_file, mdl, "SURFACE_HEIGHT_IC_VAR", eta_srf_var, & - "The initial condition variable for the surface height.",& - default="SSH", do_not_log=just_read) - filename = trim(inputdir)//trim(eta_srf_file) - if (.not.just_read) & - call log_param(param_file, mdl, "INPUTDIR/SURFACE_HEIGHT_IC_FILE", filename) - call get_param(param_file, mdl, "SURFACE_HEIGHT_IC_SCALE", scale_factor, & - "A scaling factor to convert SURFACE_HEIGHT_IC_VAR into units of m", & - units="variable", default=1.0, scale=US%m_to_Z, do_not_log=just_read) + if (.not. use_z_shelf) then + ! Read the surface height (or pressure) from a file. - if (just_read) return ! All run-time parameters have been read, so return. + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + call get_param(param_file, mdl, "SURFACE_HEIGHT_IC_FILE", eta_srf_file, & + "The initial condition file for the surface height.", & + fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "SURFACE_HEIGHT_IC_VAR", eta_srf_var, & + "The initial condition variable for the surface height.", & + default="SSH", do_not_log=just_read) + filename = trim(inputdir)//trim(eta_srf_file) + if (.not.just_read) & + call log_param(param_file, mdl, "INPUTDIR/SURFACE_HEIGHT_IC_FILE", filename) + + call get_param(param_file, mdl, "SURFACE_HEIGHT_IC_SCALE", scale_factor, & + "A scaling factor to convert SURFACE_HEIGHT_IC_VAR into units of m", & + units="variable", default=1.0, scale=US%m_to_Z, do_not_log=just_read) - call MOM_read_data(filename, eta_srf_var, eta_sfc, G%Domain, scale=scale_factor) + if (just_read) return ! All run-time parameters have been read, so return. + + call MOM_read_data(filename, eta_srf_var, eta_sfc, G%Domain, scale=scale_factor) + else + do j=js,je ; do i=is,ie + eta_sfc(i,j) = z_top_shelf(i,j) + enddo ; enddo + endif ! Convert thicknesses to interface heights. call find_eta(h, tv, G, GV, US, eta, dZref=G%Z_ref) @@ -1132,13 +1271,21 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) character(len=200) :: mdl = "trim_for_ice" real, dimension(SZI_(G),SZJ_(G)) :: p_surf ! Imposed pressure on ocean at surface [R L2 T-2 ~> Pa] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: S_t, S_b ! Top and bottom edge values for reconstructions - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: T_t, T_b ! of salinity [ppt] and temperature [degC] within each layer. + ! of salinity within each layer [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: T_t, T_b ! Top and bottom edge values for reconstructions + ! of temperature within each layer [C ~> degC] character(len=200) :: inputdir, filename, p_surf_file, p_surf_var ! Strings for file/path - real :: scale_factor ! A file-dependent scaling factor for the input pressure. - real :: min_thickness ! The minimum layer thickness, recast into Z units [Z ~> m]. + real :: scale_factor ! A file-dependent scaling factor for the input pressure [various]. + real :: min_thickness ! The minimum layer thickness [H ~> m or kg m-2]. + real :: z_tolerance ! The tolerance with which to find the depth matching a specified pressure [Z ~> m]. integer :: i, j, k - logical :: default_2018_answers, remap_answers_2018 + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + integer :: 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. logical :: use_remapping ! If true, remap the initial conditions. + logical :: use_frac_dp_bugfix ! If true, use bugfix. Otherwise, pressure input to EOS is negative. type(remapping_CS), pointer :: remap_CS => NULL() call get_param(PF, mdl, "SURFACE_PRESSURE_FILE", p_surf_file, & @@ -1146,7 +1293,7 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(PF, mdl, "SURFACE_PRESSURE_VAR", p_surf_var, & "The initial condition variable for the surface pressure exerted by ice.", & - units="Pa", default="", do_not_log=just_read) + default="", do_not_log=just_read) call get_param(PF, mdl, "INPUTDIR", inputdir, default=".", do_not_log=.true.) filename = trim(slasher(inputdir))//trim(p_surf_file) if (.not.just_read) call log_param(PF, mdl, "!INPUTDIR/SURFACE_HEIGHT_IC_FILE", filename) @@ -1156,29 +1303,48 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) "file SURFACE_PRESSURE_FILE into a surface pressure.", & units="file dependent", default=1., do_not_log=just_read) call get_param(PF, mdl, "MIN_THICKNESS", min_thickness, 'Minimum layer thickness', & - units='m', default=1.e-3, do_not_log=just_read, scale=US%m_to_Z) + units='m', default=1.e-3, scale=GV%m_to_H, do_not_log=just_read) + call get_param(PF, mdl, "TRIM_IC_Z_TOLERANCE", z_tolerance, & + "The tolerance with which to find the depth matching the specified "//& + "surface pressure with TRIM_IC_FOR_P_SURF.", & + units="m", default=1.0e-5, scale=US%m_to_Z, do_not_log=just_read) + call get_param(PF, mdl, "FRAC_DP_AT_POS_NEGATIVE_P_BUGFIX", use_frac_dp_bugfix, & + "If true, use bugfix in ice shelf TRIM_IC initialization. "//& + "Otherwise, pressure input to density EOS is negative.", & + default=.false., do_not_log=just_read) call get_param(PF, mdl, "TRIMMING_USES_REMAPPING", use_remapping, & 'When trimming the column, also remap T and S.', & default=.false., do_not_log=just_read) - remap_answers_2018 = .true. if (use_remapping) then - call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) - call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) + call get_param(PF, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231, do_not_log=just_read) + call get_param(PF, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & + "The vintage of the expressions and order of arithmetic to use for remapping. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=just_read.or.(.not.GV%Boussinesq)) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) + else + remap_answer_date = 20181231 + if (.not.GV%Boussinesq) remap_answer_date = 20230701 endif if (just_read) return ! All run-time parameters have been read, so return. call MOM_read_data(filename, p_surf_var, p_surf, G%Domain, & - scale=scale_factor*US%kg_m3_to_R*US%m_s_to_L_T**2) + scale=scale_factor*US%Pa_to_RL2_T2) 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 @@ -1193,91 +1359,194 @@ 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=1.0e-5*US%m_to_Z, remap_answers_2018=remap_answers_2018) + 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, & + frac_dp_bugfix=use_frac_dp_bugfix) enddo ; enddo end subroutine trim_for_ice +!> Calculate the hydrostatic equilibrium position of the surface under an ice shelf +subroutine calc_sfc_displacement(PF, G, GV, US, mass_shelf, tv, h) + type(param_file_type), intent(in) :: PF !< Parameter file structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: mass_shelf !< Ice shelf mass [R Z ~> kg m-2] + type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + + real :: z_top_shelf(SZI_(G),SZJ_(G)) ! The depth of the top interface under ice shelves [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & + eta ! The free surface height that the model should use [Z ~> m]. + ! temporary arrays + real, dimension(SZK_(GV)) :: rho_col ! potential density in the column for use in ice [R ~> kg m-3] + real, dimension(SZK_(GV)) :: rho_h ! potential density multiplied by thickness [R Z ~> kg m-2] + real, dimension(SZK_(GV)) :: h_tmp ! temporary storage for thicknesses [H ~> m] + real, dimension(SZK_(GV)) :: p_ref ! pressure for density [R Z ~> kg m-2] + real, dimension(SZK_(GV)+1) :: ei_tmp, ei_orig ! temporary storage for interface positions [Z ~> m] + real :: z_top ! An estimate of the height of the ice-ocean interface [Z ~> m] + real :: mass_disp ! The net mass of sea water that has been displaced by the shelf [R Z ~> kg m-2] + real :: residual ! The difference between the displaced ocean mass and the ice shelf + ! mass [R Z ~> kg m-2] + real :: tol ! The initialization tolerance for ice shelf initialization [Z ~> m] + integer :: is, ie, js, je, k, nz, i, j, max_iter, iter + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + call get_param(PF, mdl, "ICE_SHELF_INITIALIZATION_Z_TOLERANCE", tol, & + "A initialization tolerance for the calculation of the static "// & + "ice shelf displacement (m) using initial temperature and salinity profile.", & + default=0.001, units="m", scale=US%m_to_Z) + max_iter = 1e3 + call MOM_mesg("Started calculating initial interface position under ice shelf ") + ! Convert thicknesses to interface heights. + call find_eta(h, tv, G, GV, US, eta, dZref=G%Z_ref) + do j=js,je ; do i=is,ie + iter = 1 + z_top_shelf(i,j) = 0.0 + p_ref(:) = tv%p_ref + if ((G%mask2dT(i,j) > 0.) .and. (mass_shelf(i,j) > 0.)) then + call calculate_density(tv%T(i,j,:), tv%S(i,j,:), P_Ref, rho_col, tv%eqn_of_state) + z_top = min(max(-1.0*mass_shelf(i,j)/rho_col(1), -G%bathyT(i,j)), 0.) + h_tmp(:) = 0.0 + ei_tmp(1:nz+1) = eta(i,j,1:nz+1) + ei_orig(1:nz+1) = eta(i,j,1:nz+1) + do k=1,nz+1 + if (ei_tmp(k) < z_top) ei_tmp(k) = z_top + enddo + mass_disp = 0.0 + do k=1,nz + h_tmp(k) = max(ei_tmp(k)-ei_tmp(k+1), GV%Angstrom_H) + rho_h(k) = h_tmp(k) * rho_col(k) + mass_disp = mass_disp + rho_h(k) + enddo + residual = mass_shelf(i,j) - mass_disp + do while ((abs(residual) > tol) .and. (z_top > -G%bathyT(i,j)) .and. (iter < max_iter)) + z_top = min(max(z_top-(residual*0.5e-3), -G%bathyT(i,j)), 0.0) + h_tmp(:) = 0.0 + ei_tmp(1:nz+1) = ei_orig(1:nz+1) + do k=1,nz+1 + if (ei_tmp(k) < z_top) ei_tmp(k) = z_top + enddo + mass_disp = 0.0 + do k=1,nz + h_tmp(k) = max(ei_tmp(k)-ei_tmp(k+1), GV%Angstrom_H) + rho_h(k) = h_tmp(k) * rho_col(k) + mass_disp = mass_disp + rho_h(k) + enddo + residual = mass_shelf(i,j) - mass_disp + iter = iter+1 + enddo + if (iter >= max_iter) call MOM_mesg("Warning: calc_sfc_displacement too many iterations.") + z_top_shelf(i,j) = z_top + endif + enddo ; enddo + call MOM_mesg("Calling depress_surface ") + call depress_surface(h, G, GV, US, PF, tv, just_read=.false.,z_top_shelf=z_top_shelf) + call MOM_mesg("Finishing calling depress_surface ") +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_answers_2018) + S, S_t, S_b, p_surf, h, remap_CS, z_tol, frac_dp_bugfix) 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. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(in) :: G_earth !< Gravitational acceleration [L2 Z-1 T-2 ~> m s-2] real, intent(in) :: depth !< Depth of ocean column [Z ~> m]. - real, intent(in) :: min_thickness !< Smallest thickness allowed [Z ~> m]. - real, dimension(nk), intent(inout) :: T !< Layer mean temperature [degC] - real, dimension(nk), intent(in) :: T_t !< Temperature at top of layer [degC] - real, dimension(nk), intent(in) :: T_b !< Temperature at bottom of layer [degC] - real, dimension(nk), intent(inout) :: S !< Layer mean salinity [ppt] - real, dimension(nk), intent(in) :: S_t !< Salinity at top of layer [ppt] - real, dimension(nk), intent(in) :: S_b !< Salinity at bottom of layer [ppt] + real, intent(in) :: min_thickness !< Smallest thickness allowed [H ~> m or kg m-2]. + real, dimension(nk), intent(inout) :: T !< Layer mean temperature [C ~> degC] + real, dimension(nk), intent(in) :: T_t !< Temperature at top of layer [C ~> degC] + real, dimension(nk), intent(in) :: T_b !< Temperature at bottom of layer [C ~> degC] + real, dimension(nk), intent(inout) :: S !< Layer mean salinity [S ~> ppt] + real, dimension(nk), intent(in) :: S_t !< Salinity at top of layer [S ~> ppt] + real, dimension(nk), intent(in) :: S_b !< Salinity at bottom of layer [S ~> ppt] real, intent(in) :: p_surf !< Imposed pressure on ocean at surface [R L2 T-2 ~> Pa] real, dimension(nk), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] type(remapping_CS), pointer :: remap_CS !< Remapping structure for remapping T and S, !! if associated - real, optional, intent(in) :: z_tol !< The tolerance with which to find the depth + real, intent(in) :: z_tol !< The tolerance with which to find the depth !! matching the specified pressure [Z ~> m]. - logical, optional, intent(in) :: remap_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. + logical, intent(in) :: frac_dp_bugfix !< If true, use bugfix in frac_dp_at_pos ! Local variables - real, dimension(nk+1) :: e ! Top and bottom edge values for reconstructions [Z ~> m] - real, dimension(nk) :: h0, S0, T0, h1, S1, T1 - real :: P_t, P_b ! Top and bottom pressures [R L2 T-2 ~> Pa] - real :: z_out, e_top - logical :: answers_2018 + real, dimension(nk+1) :: e ! Top and bottom edge positions for reconstructions [Z ~> m] + real, dimension(nk) :: h0, h1 ! Initial and remapped layer thicknesses [H ~> m or kg m-2] + real, dimension(nk) :: S0, S1 ! Initial and remapped layer salinities [S ~> ppt] + real, dimension(nk) :: T0, T1 ! Initial and remapped layer temperatures [C ~> degC] + real :: P_t, P_b ! Top and bottom pressures [R L2 T-2 ~> Pa] + 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] integer :: k - answers_2018 = .true. ; if (present(remap_answers_2018)) answers_2018 = remap_answers_2018 + ! 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 - ! Calculate original interface positions - e(nk+1) = -depth - do k=nk,1,-1 - e(K) = e(K+1) + GV%H_to_Z*h(k) - h0(k) = h(nk+1-k) ! Keep a copy to use in remapping - enddo + if (GV%Boussinesq) then + min_dz = GV%H_to_Z * min_thickness + ! Calculate original interface positions + e(nk+1) = -depth + do k=nk,1,-1 + e(K) = e(K+1) + GV%H_to_Z*h(k) + enddo - P_t = 0. - e_top = e(1) - do k=1,nk - call find_depth_of_pressure_in_cell(T_t(k), T_b(k), S_t(k), S_b(k), e(K), e(K+1), & - P_t, p_surf, GV%Rho0, G_earth, tv%eqn_of_state, & - US, P_b, z_out, z_tol=z_tol) - if (z_out>=e(K)) then - ! Imposed pressure was less that pressure at top of cell - exit - elseif (z_out<=e(K+1)) then - ! Imposed pressure was greater than pressure at bottom of cell - e_top = e(K+1) - else - ! Imposed pressure was fell between pressures at top and bottom of cell - e_top = z_out - exit - endif - P_t = P_b - enddo - if (e_top e_top) then - ! Original e(K) is too high - e(K) = e_top - e_top = e_top - min_thickness ! Next interface must be at least this deep + P_t = 0. + e_top = e(1) + do k=1,nk + call find_depth_of_pressure_in_cell(T_t(k), T_b(k), S_t(k), S_b(k), e(K), e(K+1), & + P_t, p_surf, GV%Rho0, G_earth, tv%eqn_of_state, & + US, P_b, z_out, z_tol=z_tol, & + frac_dp_bugfix=frac_dp_bugfix) + if (z_out>=e(K)) then + ! Imposed pressure was less that pressure at top of cell + exit + elseif (z_out<=e(K+1)) then + ! Imposed pressure was greater than pressure at bottom of cell + e_top = e(K+1) + else + ! Imposed pressure was fell between pressures at top and bottom of cell + e_top = z_out + exit endif - ! This layer needs trimming - h(k) = GV%Z_to_H * max( min_thickness, e(K) - e(K+1) ) - if (e(K) < e_top) exit ! No need to go further + P_t = P_b enddo + if (e_top e_top) then + ! Original e(K) is too high + e(K) = e_top + e_top = e_top - min_dz ! Next interface must be at least this deep + endif + ! This layer needs trimming + h(k) = max( min_thickness, GV%Z_to_H * (e(K) - e(K+1)) ) + if (e(K) < e_top) exit ! No need to go further + enddo + endif + else + ! In non-Bousinesq mode, we are already in mass units so the calculation is much easier. + if (p_surf > 0.0) then + dh_surf_rem = p_surf * GV%RZ_to_H / G_earth + do k=1,nk + if (h(k) <= min_thickness) then ! This layer has no mass to remove. + cycle + elseif ((h(k) - min_thickness) < dh_surf_rem) then ! This layer should be removed entirely. + dh_surf_rem = dh_surf_rem - (h(k) - min_thickness) + h(k) = min_thickness + else ! This is the last layer that should be removed. + h(k) = h(k) - dh_surf_rem + dh_surf_rem = 0.0 + exit + endif + enddo + endif endif ! Now we need to remap but remapping assumes the surface is at the @@ -1288,13 +1557,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) @@ -1318,7 +1582,8 @@ subroutine initialize_velocity_from_file(u, v, G, GV, US, param_file, just_read) !! parameters without changing u or v. ! Local variables character(len=40) :: mdl = "initialize_velocity_from_file" ! This subroutine's name. - character(len=200) :: filename,velocity_file,inputdir ! Strings for file/path + character(len=200) :: filename, velocity_file, inputdir ! Strings for file/path + character(len=64) :: u_IC_var, v_IC_var ! Velocity component names in files if (.not.just_read) call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") @@ -1328,16 +1593,26 @@ subroutine initialize_velocity_from_file(u, v, G, GV, US, param_file, just_read) call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) - if (just_read) return ! All run-time parameters have been read, so return. + filename = trim(velocity_file) + if (scan(velocity_file, '/')== 0) then ! prepend inputdir if only a filename is given + filename = trim(inputdir)//trim(velocity_file) + endif + if (.not.just_read) call log_param(param_file, mdl, "INPUTDIR/VELOCITY_FILE", filename) - filename = trim(inputdir)//trim(velocity_file) - call log_param(param_file, mdl, "INPUTDIR/VELOCITY_FILE", filename) + call get_param(param_file, mdl, "U_IC_VAR", u_IC_var, & + "The initial condition variable for zonal velocity in VELOCITY_FILE.", & + default="u") + call get_param(param_file, mdl, "V_IC_VAR", v_IC_var, & + "The initial condition variable for meridional velocity in VELOCITY_FILE.", & + default="v") + + if (just_read) return ! All run-time parameters have been read, so return. if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & " initialize_velocity_from_file: Unable to open "//trim(filename)) ! Read the velocities from a netcdf file. - call MOM_read_vector(filename, "u", "v", u(:,:,:), v(:,:,:), G%Domain, scale=US%m_s_to_L_T) + call MOM_read_vector(filename, u_IC_var, v_IC_var, u(:,:,:), v(:,:,:), G%Domain, scale=US%m_s_to_L_T) call callTree_leave(trim(mdl)//'()') end subroutine initialize_velocity_from_file @@ -1390,7 +1665,7 @@ subroutine initialize_velocity_uniform(u, v, G, GV, US, param_file, just_read) !! parameters without changing u or v. ! Local variables integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - real :: initial_u_const, initial_v_const + real :: initial_u_const, initial_v_const ! Constant initial velocities [L T-1 ~> m s-1] character(len=200) :: mdl = "initialize_velocity_uniform" ! This subroutine's name. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -1431,7 +1706,7 @@ subroutine initialize_velocity_circular(u, v, G, GV, US, param_file, just_read) ! Local variables character(len=200) :: mdl = "initialize_velocity_circular" real :: circular_max_u ! The amplitude of the zonal flow [L T-1 ~> m s-1] - real :: dpi ! A local variable storing pi = 3.14159265358979... + real :: dpi ! A local variable storing pi = 3.14159265358979... [nondim] real :: psi1, psi2 ! Values of the streamfunction at two points [L2 T-1 ~> m2 s-1] integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -1444,7 +1719,10 @@ subroutine initialize_velocity_circular(u, v, G, GV, US, param_file, just_read) if (just_read) return ! All run-time parameters have been read, so return. - dpi=acos(0.0)*2.0 ! pi + if (G%grid_unit_to_L <= 0.) call MOM_error(FATAL, "MOM_state_initialization.F90: "//& + "initialize_velocity_circular() is only set to work with Cartesian axis units.") + + dpi = acos(0.0)*2.0 ! pi do k=1,nz ; do j=js,je ; do I=Isq,Ieq psi1 = my_psi(I,j) @@ -1468,22 +1746,23 @@ real function my_psi(ig,jg) x = 2.0*(G%geoLonBu(ig,jg)-G%west_lon) / G%len_lon - 1.0 ! -1 Initializes temperature and salinity from file -subroutine initialize_temp_salt_from_file(T, S, G, GV, param_file, just_read) +subroutine initialize_temp_salt_from_file(T, S, G, GV, US, param_file, just_read) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< The potential temperature that is - !! being initialized [degC] + !! being initialized [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< The salinity that is - !! being initialized [ppt] + !! being initialized [S ~> ppt] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters logical, intent(in) :: just_read !< If true, this call will only !! read parameters without changing T or S. @@ -1501,7 +1780,10 @@ subroutine initialize_temp_salt_from_file(T, S, G, GV, param_file, just_read) call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) - filename = trim(inputdir)//trim(ts_file) + filename = trim(ts_file) + if (scan(ts_file, '/')== 0) then ! prepend inputdir if only a filename is given + filename = trim(inputdir)//trim(ts_file) + endif if (.not.just_read) call log_param(param_file, mdl, "INPUTDIR/TS_FILE", filename) call get_param(param_file, mdl, "TEMP_IC_VAR", temp_var, & "The initial condition variable for potential temperature.", & @@ -1519,39 +1801,51 @@ subroutine initialize_temp_salt_from_file(T, S, G, GV, param_file, just_read) " initialize_temp_salt_from_file: Unable to open "//trim(filename)) ! Read the temperatures and salinities from netcdf files. - call MOM_read_data(filename, temp_var, T(:,:,:), G%Domain) + call MOM_read_data(filename, temp_var, T(:,:,:), G%Domain, scale=US%degC_to_C) - salt_filename = trim(inputdir)//trim(salt_file) + salt_filename = trim(salt_file) + if (scan(salt_file, '/')== 0) then ! prepend inputdir if only a filename is given + salt_filename = trim(inputdir)//trim(salt_file) + endif if (.not.file_exists(salt_filename, G%Domain)) call MOM_error(FATAL, & " initialize_temp_salt_from_file: Unable to open "//trim(salt_filename)) - call MOM_read_data(salt_filename, salt_var, S(:,:,:), G%Domain) + call MOM_read_data(salt_filename, salt_var, S(:,:,:), G%Domain, scale=US%ppt_to_S) call callTree_leave(trim(mdl)//'()') end subroutine initialize_temp_salt_from_file !> Initializes temperature and salinity from a 1D profile -subroutine initialize_temp_salt_from_profile(T, S, G, GV, param_file, just_read) +subroutine initialize_temp_salt_from_profile(T, S, G, GV, US, param_file, just_read) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< The potential temperature that is - !! being initialized [degC] + !! being initialized [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< The salinity that is - !! being initialized [ppt] - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - logical, intent(in) :: just_read !< If true, this call will only read + !! being initialized [S ~> ppt] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + logical, intent(in) :: just_read !< If true, this call will only read !! parameters without changing T or S. ! Local variables - real, dimension(SZK_(GV)) :: T0, S0 + real, dimension(SZK_(GV)) :: T0 ! The profile of temperatures [C ~> degC] + real, dimension(SZK_(GV)) :: S0 ! The profile of salinities [S ~> ppt] integer :: i, j, k character(len=200) :: filename, ts_file, inputdir ! Strings for file/path + character(len=64) :: temp_var, salt_var ! Temperature and salinity names in files character(len=40) :: mdl = "initialize_temp_salt_from_profile" if (.not.just_read) call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") call get_param(param_file, mdl, "TS_FILE", ts_file, & - "The file with the reference profiles for temperature "//& - "and salinity.", fail_if_missing=.not.just_read, do_not_log=just_read) + "The file with the reference profiles for temperature and salinity.", & + fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "TEMP_IC_VAR", temp_var, & + "The initial condition variable for potential temperature.", & + default="PTEMP", do_not_log=just_read) + call get_param(param_file, mdl, "SALT_IC_VAR", salt_var, & + "The initial condition variable for salinity.", & + default="SALT", do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -1559,12 +1853,12 @@ subroutine initialize_temp_salt_from_profile(T, S, G, GV, param_file, just_read) inputdir = slasher(inputdir) filename = trim(inputdir)//trim(ts_file) call log_param(param_file, mdl, "INPUTDIR/TS_FILE", filename) - if (.not.file_exists(filename)) call MOM_error(FATAL, & + if (.not.file_exists(filename)) call MOM_error(FATAL, & " initialize_temp_salt_from_profile: Unable to open "//trim(filename)) ! Read the temperatures and salinities from a netcdf file. - call MOM_read_data(filename, "PTEMP", T0(:)) - call MOM_read_data(filename, "SALT", S0(:)) + call MOM_read_data(filename, temp_var, T0(:), scale=US%degC_to_C) + call MOM_read_data(filename, salt_var, S0(:), scale=US%ppt_to_S) do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec T(i,j,k) = T0(k) ; S(i,j,k) = S0(k) @@ -1578,9 +1872,9 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< The potential temperature that is - !! being initialized [degC]. + !! being initialized [C ~> degC]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< The salinity that is being - !! initialized [ppt]. + !! initialized [S ~> ppt]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time !! parameters. @@ -1590,13 +1884,13 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P logical, intent(in) :: just_read !< If true, this call will only read !! parameters without changing T or S. ! Local variables - real :: T0(SZK_(GV)) ! Layer potential temperatures [degC] - real :: S0(SZK_(GV)) ! Layer salinities [degC] - real :: T_Ref ! Reference Temperature [degC] - real :: S_Ref ! Reference Salinity [ppt] + real :: T0(SZK_(GV)) ! Layer potential temperatures [C ~> degC] + real :: S0(SZK_(GV)) ! Layer salinities [S ~> ppt] + real :: T_Ref ! Reference Temperature [C ~> degC] + real :: S_Ref ! Reference Salinity [S ~> ppt] real :: pres(SZK_(GV)) ! An array of the reference pressure [R L2 T-2 ~> Pa]. - real :: drho_dT(SZK_(GV)) ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. - real :: drho_dS(SZK_(GV)) ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. + real :: drho_dT(SZK_(GV)) ! Derivative of density with temperature [R C-1 ~> kg m-3 degC-1]. + real :: drho_dS(SZK_(GV)) ! Derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. real :: rho_guess(SZK_(GV)) ! Potential density at T0 & S0 [R ~> kg m-3]. logical :: fit_salin ! If true, accept the prescribed temperature and fit the salinity. character(len=40) :: mdl = "initialize_temp_salt_fit" ! This subroutine's name. @@ -1607,10 +1901,10 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P call get_param(param_file, mdl, "T_REF", T_Ref, & "A reference temperature used in initialization.", & - units="degC", fail_if_missing=.not.just_read, do_not_log=just_read) + units="degC", scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "S_REF", S_Ref, & - "A reference salinity used in initialization.", units="PSU", & - default=35.0, do_not_log=just_read) + "A reference salinity used in initialization.", & + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "FIT_SALINITY", fit_salin, & "If true, accept the prescribed temperature and fit the "//& "salinity; otherwise take salinity and fit temperature.", & @@ -1665,61 +1959,54 @@ end subroutine initialize_temp_salt_fit !! !! \remark Note that the linear distribution is set up with respect to the layer !! number, not the physical position). -subroutine initialize_temp_salt_linear(T, S, G, GV, param_file, just_read) +subroutine initialize_temp_salt_linear(T, S, G, GV, US, param_file, just_read) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< The potential temperature that is - !! being initialized [degC] + !! being initialized [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< The salinity that is - !! being initialized [ppt] + !! being initialized [S ~> ppt] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for !! run-time parameters logical, intent(in) :: just_read !< If present and true, !! this call will only read parameters !! without changing T or S. - integer :: k - real :: delta_S, delta_T - real :: S_top, T_top ! Reference salinity and temperature within surface layer - real :: S_range, T_range ! Range of salinities and temperatures over the vertical - real :: delta + ! Local variables + real :: S_top, S_range ! Reference salinity in the surface layer and its vertical range [S ~> ppt] + real :: T_top, T_range ! Reference temperature in the surface layer and its vertical range [C ~> degC] character(len=40) :: mdl = "initialize_temp_salt_linear" ! This subroutine's name. + integer :: k if (.not.just_read) call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") call get_param(param_file, mdl, "T_TOP", T_top, & "Initial temperature of the top surface.", & - units="degC", fail_if_missing=.not.just_read, do_not_log=just_read) + units="degC", scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "T_RANGE", T_range, & "Initial temperature difference (top-bottom).", & - units="degC", fail_if_missing=.not.just_read, do_not_log=just_read) + units="degC", scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "S_TOP", S_top, & "Initial salinity of the top surface.", & - units="PSU", fail_if_missing=.not.just_read, do_not_log=just_read) + units="ppt", scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "S_RANGE", S_range, & "Initial salinity difference (top-bottom).", & - units="PSU", fail_if_missing=.not.just_read, do_not_log=just_read) + units="ppt", scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. - ! Prescribe salinity -! delta_S = S_range / ( GV%ke - 1.0 ) -! S(:,:,1) = S_top -! do k=2,GV%ke -! S(:,:,k) = S(:,:,k-1) + delta_S -! enddo + ! Prescribe salinity and temperature, with the extrapolated top interface value prescribed. do k=1,GV%ke S(:,:,k) = S_top - S_range*((real(k)-0.5)/real(GV%ke)) T(:,:,k) = T_top - T_range*((real(k)-0.5)/real(GV%ke)) enddo - ! Prescribe temperature -! delta_T = T_range / ( GV%ke - 1.0 ) -! T(:,:,1) = T_top -! do k=2,GV%ke -! T(:,:,k) = T(:,:,k-1) + delta_T -! enddo -! delta = 1 -! T(:,:,GV%ke/2 - (delta-1):GV%ke/2 + delta) = 1.0 + ! Prescribe salinity and temperature, but with the top layer value matching the surface value. + ! S(:,:,1) = S_top ; T(:,:,1) = T_top + ! do k=2,GV%ke + ! S(:,:,k) = S_top - S_range * (real(k-1) / real(GV%ke-1)) + ! T(:,:,k) = T_top - T_range * (real(k-1) / real(GV%ke-1)) + ! enddo call callTree_leave(trim(mdl)//'()') end subroutine initialize_temp_salt_linear @@ -1754,14 +2041,21 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t !! overrides any value set for Time. ! Local variables real, allocatable, dimension(:,:,:) :: eta ! The target interface heights [Z ~> m]. - real, allocatable, dimension(:,:,:) :: h ! The target interface thicknesses [H ~> m or kg m-2]. + real, allocatable, dimension(:,:,:) :: dz ! The target interface thicknesses in height units [Z ~> m] real, dimension (SZI_(G),SZJ_(G),SZK_(GV)) :: & - tmp, tmp2 ! A temporary array for tracers. + tmp, & ! A temporary array for temperatures [C ~> degC] or other tracers. + tmp2 ! A temporary array for salinities [S ~> ppt] real, dimension (SZI_(G),SZJ_(G)) :: & - tmp_2d ! A temporary array for tracers. - real, allocatable, dimension(:,:,:) :: tmp_tr ! A temporary array for reading sponge fields - real, allocatable, dimension(:,:,:) :: tmp_u,tmp_v ! A temporary array for reading sponge fields + tmp_2d ! A temporary array for mixed layer densities [R ~> kg m-3] + real, allocatable, dimension(:,:,:) :: tmp_T ! A temporary array for reading sponge target temperatures + ! on the vertical grid of the input file [C ~> degC] + real, allocatable, dimension(:,:,:) :: tmp_S ! A temporary array for reading sponge target salinities + ! on the vertical grid of the input file [S ~> ppt] + real, allocatable, dimension(:,:,:) :: tmp_u ! Temporary array for reading sponge target zonal + ! velocities on the vertical grid of the input file [L T-1 ~> m s-1] + real, allocatable, dimension(:,:,:) :: tmp_v ! Temporary array for reading sponge target meridional + ! velocities on the vertical grid of the input file [L T-1 ~> m s-1] real :: Idamp(SZI_(G),SZJ_(G)) ! The sponge damping rate [T-1 ~> s-1] real :: Idamp_u(SZIB_(G),SZJ_(G)) ! The sponge damping rate for velocity fields [T-1 ~> s-1] @@ -1780,10 +2074,8 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t character(len=200) :: filename, inputdir ! Strings for file/path and path. logical :: use_ALE ! True if ALE is being used, False if in layered mode - logical :: time_space_interp_sponge ! True if using sponge data which - ! need to be interpolated from in both the horizontal dimension and in - ! time prior to vertical remapping. - + logical :: time_space_interp_sponge ! If true use sponge data that need to be interpolated in both + ! the horizontal dimension and in time prior to vertical remapping. 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 @@ -1835,25 +2127,17 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t "The name of the inverse damping rate variable in "//& "SPONGE_UV_DAMPING_FILE for the velocities.", default=Idamp_var) endif - call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, do_not_log = .true.) - time_space_interp_sponge = .false. - call get_param(param_file, mdl, "NEW_SPONGES", time_space_interp_sponge, & - "Set True if using the newer sponging code which "//& - "performs on-the-fly regridding in lat-lon-time.",& - "of sponge restoring data.", default=.false.) - if (time_space_interp_sponge) then - call MOM_error(WARNING, " initialize_sponges: NEW_SPONGES has been deprecated. "//& - "Please use INTERPOLATE_SPONGE_TIME_SPACE instead. Setting "//& - "INTERPOLATE_SPONGE_TIME_SPACE = True.") - endif - call get_param(param_file, mdl, "INTERPOLATE_SPONGE_TIME_SPACE", time_space_interp_sponge, & - "Set True if using the newer sponging code which "//& - "performs on-the-fly regridding in lat-lon-time.",& - "of sponge restoring data.", default=time_space_interp_sponge) + call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "INTERPOLATE_SPONGE_TIME_SPACE", time_space_interp_sponge, & + "If True, perform on-the-fly regridding in lat-lon-time of sponge restoring data.", & + default=.false.) ! Read in sponge damping rate for tracers - filename = trim(inputdir)//trim(damping_file) + filename = trim(damping_file) + if (scan(damping_file, '/')== 0) then ! prepend inputdir if only a filename is given + filename = trim(inputdir)//trim(damping_file) + endif call log_param(param_file, mdl, "INPUTDIR/SPONGE_DAMPING_FILE", filename) if (.not.file_exists(filename, G%Domain)) & call MOM_error(FATAL, " initialize_sponges: Unable to open "//trim(filename)) @@ -1874,18 +2158,18 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t call MOM_read_vector(filename, Idamp_u_var,Idamp_v_var,Idamp_u(:,:),Idamp_v(:,:), G%Domain, scale=US%T_to_s) else - ! call MOM_error(FATAL, "Must provide SPONGE_IDAMP_U_var and SPONGE_IDAMP_V_var") - call pass_var(Idamp,G%Domain) - do j=G%jsc,G%jec - do i=G%iscB,G%iecB - Idamp_u(I,j) = 0.5*(Idamp(i,j)+Idamp(i+1,j)) - enddo - enddo - do j=G%jscB,G%jecB - do i=G%isc,G%iec - Idamp_v(i,J) = 0.5*(Idamp(i,j)+Idamp(i,j+1)) - enddo - enddo + ! call MOM_error(FATAL, "Must provide SPONGE_IDAMP_U_var and SPONGE_IDAMP_V_var") + call pass_var(Idamp,G%Domain) + do j=G%jsc,G%jec + do i=G%iscB,G%iecB + Idamp_u(I,j) = 0.5*(Idamp(i,j)+Idamp(i+1,j)) + enddo + enddo + do j=G%jscB,G%jecB + do i=G%isc,G%iec + Idamp_v(i,J) = 0.5*(Idamp(i,j)+Idamp(i,j+1)) + enddo + enddo endif endif @@ -1920,11 +2204,11 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t ! This call to set_up_sponge_ML_density registers the target values of the ! mixed layer density, which is used in determining which layers can be ! inflated without causing static instabilities. - do i=is-1,ie ; pres(i) = tv%P_Ref ; enddo + do i=is,ie ; pres(i) = tv%P_Ref ; enddo EOSdom(:) = EOS_domain(G%HI) - call MOM_read_data(filename, potemp_var, tmp(:,:,:), G%Domain) - call MOM_read_data(filename, salin_var, tmp2(:,:,:), G%Domain) + call MOM_read_data(filename, potemp_var, tmp(:,:,:), G%Domain, scale=US%degC_to_C) + call MOM_read_data(filename, salin_var, tmp2(:,:,:), G%Domain, scale=US%ppt_to_S) do j=js,je call calculate_density(tmp(:,j,1), tmp2(:,j,1), pres, tmp_2d(:,j), tv%eqn_of_state, EOSdom) @@ -1940,18 +2224,18 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t ! The remaining calls to set_up_sponge_field can be in any order. if ( use_temperature) then - call MOM_read_data(filename, potemp_var, tmp(:,:,:), G%Domain) + call MOM_read_data(filename, potemp_var, tmp(:,:,:), G%Domain, scale=US%degC_to_C) call set_up_sponge_field(tmp, tv%T, G, GV, nz, Layer_CSp) - call MOM_read_data(filename, salin_var, tmp(:,:,:), G%Domain) - call set_up_sponge_field(tmp, tv%S, G, GV, nz, Layer_CSp) + call MOM_read_data(filename, salin_var, tmp2(:,:,:), G%Domain, scale=US%ppt_to_S) + call set_up_sponge_field(tmp2, tv%S, G, GV, nz, Layer_CSp) endif ! else ! Initialize sponges without supplying sponge grid ! if (sponge_uv) then -! call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp, Idamp_u, Idamp_v) +! call initialize_ALE_sponge(Idamp, G, GV, US, param_file, ALE_CSp, Idamp_u, Idamp_v) ! else -! call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp) +! call initialize_ALE_sponge(Idamp, G, GV, US, param_file, ALE_CSp) ! endif endif @@ -1963,33 +2247,44 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t call MOM_error(FATAL,"initialize_sponge_file: Array size mismatch for sponge data.") nz_data = siz(3)-1 allocate(eta(isd:ied,jsd:jed,nz_data+1)) - allocate(h(isd:ied,jsd:jed,nz_data)) + allocate(dz(isd:ied,jsd:jed,nz_data)) call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain, scale=US%m_to_Z) do j=js,je ; do i=is,ie - eta(i,j,nz+1) = -depth_tot(i,j) + eta(i,j,nz_data+1) = -depth_tot(i,j) enddo ; enddo - do k=nz,1,-1 ; do j=js,je ; do i=is,ie + do k=nz_data,1,-1 ; do j=js,je ; do i=is,ie if (eta(i,j,K) < (eta(i,j,K+1) + GV%Angstrom_Z)) & eta(i,j,K) = eta(i,j,K+1) + GV%Angstrom_Z enddo ; enddo ; enddo - do k=1,nz ; do j=js,je ; do i=is,ie - h(i,j,k) = GV%Z_to_H*(eta(i,j,k)-eta(i,j,k+1)) - enddo; enddo ; enddo + do k=1,nz_data ; do j=js,je ; do i=is,ie + dz(i,j,k) = eta(i,j,k)-eta(i,j,k+1) + enddo ; enddo ; enddo + deallocate(eta) + + if (use_temperature) then + allocate(tmp_T(isd:ied,jsd:jed,nz_data)) + allocate(tmp_S(isd:ied,jsd:jed,nz_data)) + call MOM_read_data(filename, potemp_var, tmp_T(:,:,:), G%Domain, scale=US%degC_to_C) + call MOM_read_data(filename, salin_var, tmp_S(:,:,:), G%Domain, scale=US%ppt_to_S) + endif + if (sponge_uv) then - call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp, h, nz_data, Idamp_u, Idamp_v) + call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp, dz, nz_data, Idamp_u, Idamp_v, & + data_h_is_Z=.true.) else - call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp, h, nz_data) + call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp, dz, nz_data, & + data_h_is_Z=.true.) endif - deallocate(eta) - deallocate(h) if (use_temperature) then - allocate(tmp_tr(isd:ied,jsd:jed,nz_data)) - call MOM_read_data(filename, potemp_var, tmp_tr(:,:,:), G%Domain) - call set_up_ALE_sponge_field(tmp_tr, G, GV, tv%T, ALE_CSp) - call MOM_read_data(filename, salin_var, tmp_tr(:,:,:), G%Domain) - call set_up_ALE_sponge_field(tmp_tr, G, GV, tv%S, ALE_CSp) - deallocate(tmp_tr) + call set_up_ALE_sponge_field(tmp_T, G, GV, tv%T, ALE_CSp, 'temp', & + sp_long_name='temperature', sp_unit='degC s-1') + call set_up_ALE_sponge_field(tmp_S, G, GV, tv%S, ALE_CSp, 'salt', & + sp_long_name='salinity', sp_unit='g kg-1 s-1') + deallocate(tmp_S) + deallocate(tmp_T) endif + deallocate(dz) + if (sponge_uv) then filename = trim(inputdir)//trim(state_uv_file) call log_param(param_file, mdl, "INPUTDIR/SPONGE_STATE_UV_FILE", filename) @@ -1997,28 +2292,31 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t call MOM_error(FATAL, " initialize_sponges: Unable to open "//trim(filename)) allocate(tmp_u(G%IsdB:G%IedB,jsd:jed,nz_data)) allocate(tmp_v(isd:ied,G%JsdB:G%JedB,nz_data)) - call MOM_read_vector(filename, u_var, v_var, tmp_u(:,:,:), tmp_v(:,:,:), G%Domain,scale=US%m_s_to_L_T) + call MOM_read_vector(filename, u_var, v_var, tmp_u(:,:,:), tmp_v(:,:,:), G%Domain, scale=US%m_s_to_L_T) call set_up_ALE_sponge_vel_field(tmp_u, tmp_v, G, GV, u, v, ALE_CSp) deallocate(tmp_u,tmp_v) endif else ! Initialize sponges without supplying sponge grid if (sponge_uv) then - call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp, Idamp_u, Idamp_v) + call initialize_ALE_sponge(Idamp, G, GV, US, param_file, ALE_CSp, Idamp_u, Idamp_v) else - call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp) + call initialize_ALE_sponge(Idamp, G, GV, US, param_file, ALE_CSp) endif ! The remaining calls to set_up_sponge_field can be in any order. if ( use_temperature) then - call set_up_ALE_sponge_field(filename, potemp_var, Time, G, GV, US, tv%T, ALE_CSp) - call set_up_ALE_sponge_field(filename, salin_var, Time, G, GV, US, tv%S, ALE_CSp) + call set_up_ALE_sponge_field(filename, potemp_var, Time, G, GV, US, tv%T, ALE_CSp, & + 'temp', sp_long_name='temperature', sp_unit='degC s-1', scale=US%degC_to_C) + call set_up_ALE_sponge_field(filename, salin_var, Time, G, GV, US, tv%S, ALE_CSp, & + 'salt', sp_long_name='salinity', sp_unit='g kg-1 s-1', scale=US%ppt_to_S) endif if (sponge_uv) then filename = trim(inputdir)//trim(state_uv_file) call log_param(param_file, mdl, "INPUTDIR/SPONGE_STATE_UV_FILE", filename) if (.not.file_exists(filename, G%Domain)) & call MOM_error(FATAL, " initialize_sponges: Unable to open "//trim(filename)) - call set_up_ALE_sponge_vel_field(filename, u_var, filename, v_var, Time, G, GV, US, ALE_CSp, u, v) + call set_up_ALE_sponge_vel_field(filename, u_var, filename, v_var, Time, G, GV, US, & + ALE_CSp, u, v, scale=US%m_s_to_L_T) endif endif endif @@ -2041,32 +2339,36 @@ subroutine initialize_oda_incupd_file(G, GV, US, use_temperature, tv, h, u, v, p oda_incupd_CSp, restart_CS, Time) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type logical, intent(in) :: use_temperature !< If true, T & S are state variables. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic - !! variables. + !! variables. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] (in) real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: u !< The zonal velocity that is being + intent(in) :: u !< The zonal velocity that is being !! initialized [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(in) :: v !< The meridional velocity that is being - !! initialized [L T-1 ~> m s-1] + intent(in) :: v !< The meridional velocity that is being + !! initialized [L T-1 ~> m s-1] type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. type(oda_incupd_CS), pointer :: oda_incupd_CSp !< A pointer that is set to point to the control - !! structure for this module. - type(MOM_restart_CS), intent(in) :: restart_CS !< MOM restart control struct - type(time_type), intent(in) :: Time !< Time at the start of the run segment. Time_in - !! overrides any value set for - !Time. + !! structure for this module. + type(MOM_restart_CS), intent(in) :: restart_CS !< MOM restart control structure + type(time_type), intent(in) :: Time !< Time at the start of the run segment. Time_in + !! overrides any value set for Time. ! Local variables - real, allocatable, dimension(:,:,:) :: hoda ! The layer thk inc. and oda layer thk [H ~> m or kg m-2]. - real, allocatable, dimension(:,:,:) :: tmp_tr ! A temporary array for reading oda fields - real, allocatable, dimension(:,:,:) :: tmp_u,tmp_v ! A temporary array for reading oda fields - - integer :: i, j, k, is, ie, js, je, nz + real, allocatable, dimension(:,:,:) :: hoda ! The layer thickness increment and oda layer thickness [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: tmp_tr ! A temporary array for reading oda tracer increments + ! on the vertical grid of the input file, used for both + ! temperatures [C ~> degC] and salinities [S ~> ppt] + real, allocatable, dimension(:,:,:) :: tmp_u ! Temporary array for reading oda zonal velocity + ! increments on the vertical grid of the input file [L T-1 ~> m s-1] + real, allocatable, dimension(:,:,:) :: tmp_v ! Temporary array for reading oda meridional velocity + ! increments on the vertical grid of the input file [L T-1 ~> m s-1] + + integer :: is, ie, js, je, nz integer :: isd, ied, jsd, jed integer, dimension(4) :: siz @@ -2101,7 +2403,7 @@ subroutine initialize_oda_incupd_file(G, GV, US, use_temperature, tv, h, u, v, p default=.false.) endif call get_param(param_file, mdl, "ODA_INCUPD_RESET_NCOUNT", reset_ncount, & - "If True, reinitialize number of updates already done, ncount.",& + "If True, reinitialize number of updates already done, ncount.", & default=.true.) if (.not.oda_inc .and. .not.reset_ncount) & call MOM_error(FATAL, " initialize_oda_incupd: restarting during update "// & @@ -2129,10 +2431,13 @@ subroutine initialize_oda_incupd_file(G, GV, US, use_temperature, tv, h, u, v, p "The name of the meridional vel. inc. variable in "//& "ODA_INCUPD_FILE.", default="v_inc") -! call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, do_not_log = .true.) +! call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, default=.false., do_not_log=.true.) ! Read in incremental update for tracers - filename = trim(inputdir)//trim(inc_file) + filename = trim(inc_file) + if (scan(inc_file, '/')== 0) then ! prepend inputdir if only a filename is given + filename = trim(inputdir)//trim(inc_file) + endif call log_param(param_file, mdl, "INPUTDIR/ODA_INCUPD_FILE", filename) if (.not.file_exists(filename, G%Domain)) & call MOM_error(FATAL, " initialize_oda_incupd: Unable to open "//trim(filename)) @@ -2151,10 +2456,10 @@ subroutine initialize_oda_incupd_file(G, GV, US, use_temperature, tv, h, u, v, p if (use_temperature) then allocate(tmp_tr(isd:ied,jsd:jed,nz_data)) ! temperature inc. in array Inc(1) - call MOM_read_data(filename, tempinc_var, tmp_tr(:,:,:), G%Domain) + call MOM_read_data(filename, tempinc_var, tmp_tr(:,:,:), G%Domain, scale=US%degC_to_C) call set_up_oda_incupd_field(tmp_tr, G, GV, oda_incupd_CSp) ! salinity inc. in array Inc(2) - call MOM_read_data(filename, salinc_var, tmp_tr(:,:,:), G%Domain) + call MOM_read_data(filename, salinc_var, tmp_tr(:,:,:), G%Domain, scale=US%ppt_to_S) call set_up_oda_incupd_field(tmp_tr, G, GV, oda_incupd_CSp) deallocate(tmp_tr) endif @@ -2167,9 +2472,9 @@ subroutine initialize_oda_incupd_file(G, GV, US, use_temperature, tv, h, u, v, p call MOM_error(FATAL, " initialize_oda_incupd_uv: Unable to open "//trim(filename)) allocate(tmp_u(G%IsdB:G%IedB,jsd:jed,nz_data), source=0.0) allocate(tmp_v(isd:ied,G%JsdB:G%JedB,nz_data), source=0.0) - call MOM_read_vector(filename, uinc_var, vinc_var, tmp_u, tmp_v, G%Domain,scale=US%m_s_to_L_T) + call MOM_read_vector(filename, uinc_var, vinc_var, tmp_u, tmp_v, G%Domain, scale=US%m_s_to_L_T) call set_up_oda_incupd_vel_field(tmp_u, tmp_v, G, GV, oda_incupd_CSp) - deallocate(tmp_u,tmp_v) + deallocate(tmp_u, tmp_v) endif ! calculate increments if input are full fields @@ -2203,26 +2508,6 @@ subroutine set_velocity_depth_max(G) enddo ; enddo end subroutine set_velocity_depth_max -!> Subroutine to pre-compute global integrals of grid quantities for -!! later use in reporting diagnostics -subroutine compute_global_grid_integrals(G, US) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - ! Local variables - real, dimension(G%isc:G%iec, G%jsc:G%jec) :: tmpForSumming - real :: area_scale - integer :: i,j - - area_scale = US%L_to_m**2 - tmpForSumming(:,:) = 0. - G%areaT_global = 0.0 ; G%IareaT_global = 0.0 - do j=G%jsc,G%jec ; do i=G%isc,G%iec - tmpForSumming(i,j) = area_scale*G%areaT(i,j) * G%mask2dT(i,j) - enddo ; enddo - G%areaT_global = reproducing_sum(tmpForSumming) - G%IareaT_global = 1. / (G%areaT_global) -end subroutine compute_global_grid_integrals - !> This subroutine sets the 4 bottom depths at velocity points to be the !! minimum of the adjacent depths. subroutine set_velocity_depth_min(G) @@ -2266,9 +2551,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just !! and salinity in z-space; by default it is also used for ice shelf area. character(len=200) :: tfilename !< The name of an input file containing temperature in z-space. character(len=200) :: sfilename !< The name of an input file containing salinity in z-space. - character(len=200) :: shelf_file !< The name of an input file used for ice shelf area. character(len=200) :: inputdir !! The directory where NetCDF input files are. - character(len=200) :: mesg, area_varname, ice_shelf_file + character(len=200) :: mesg type(EOS_type), pointer :: eos => NULL() type(thermo_var_ptrs) :: tv_loc ! A temporary thermo_var container @@ -2279,67 +2563,91 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: is, ie, js, je, nz ! compute domain indices - integer :: isc,iec,jsc,jec ! global compute domain indices integer :: isg, ieg, jsg, jeg ! global extent integer :: isd, ied, jsd, jed ! data domain indices - integer :: i, j, k, ks, np, ni, nj + integer :: i, j, k, ks integer :: nkml ! The number of layers in the mixed layer. - integer :: kd, inconsistent + integer :: inconsistent ! The total number of cells with in consistent topography and layer thicknesses. + integer :: kd ! The number of levels in the input data integer :: nkd ! number of levels to use for regridding input arrays real :: eps_Z ! A negligibly thin layer thickness [Z ~> m]. real :: eps_rho ! A negligibly small density difference [R ~> kg m-3]. - real :: PI_180 ! for conversion from degrees to radians - real :: Hmix_default ! The default initial mixed layer depth [m]. + real :: PI_180 ! for conversion from degrees to radians [radian degree-1] + real :: Hmix_default ! The default initial mixed layer depth [Z ~> m]. real :: Hmix_depth ! The mixed layer depth in the initial condition [Z ~> m]. - real :: dilate ! A dilation factor to match topography [nondim] - real :: missing_value_temp, missing_value_salt - logical :: correct_thickness + real :: missing_value_temp ! The missing value in the input temperature field [C ~> degC] + real :: missing_value_salt ! The missing value in the input salinity field [S ~> ppt] + real :: tol_temp ! The tolerance for changes in temperature during the horizontal + ! interpolation from an input dataset [C ~> degC] + real :: tol_sal ! The tolerance for changes in salinity during the horizontal + ! interpolation from an input dataset [S ~> ppt] + logical :: correct_thickness ! If true, correct the column thicknesses to match the topography + real :: h_tolerance ! A parameter that controls the tolerance when adjusting the + ! thickness to fit the bathymetry [Z ~> m]. + real :: tol_dz_bot ! A tolerance for detecting inconsistent bottom depths when + ! correct_thickness is false [Z ~> m] character(len=40) :: potemp_var, salin_var - character(len=8) :: laynum integer, parameter :: niter=10 ! number of iterations for t/s adjustment to layer density logical :: adjust_temperature = .true. ! fit t/s to target densities - real, parameter :: missing_value = -1.e20 - real, parameter :: temp_land_fill = 0.0, salt_land_fill = 35.0 - logical :: reentrant_x, tripolar_n,dbg - logical :: debug = .false. ! manually set this to true for verbose output + real :: temp_land_fill ! A temperature value to use for land points [C ~> degC] + real :: salt_land_fill ! A salinity value to use for land points [C ~> degC] ! data arrays - real, dimension(:), allocatable :: z_edges_in, z_in ! Interface heights [Z ~> m] - real, dimension(:), allocatable :: Rb ! Interface densities [R ~> kg m-3] - real, dimension(:,:,:), allocatable, target :: temp_z, salt_z, mask_z - real, dimension(:,:,:), allocatable :: rho_z ! Densities in Z-space [R ~> kg m-3] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: zi ! Interface heights [Z ~> m]. - real, dimension(SZI_(G),SZJ_(G)) :: Z_bottom ! The (usually negative) height of the seafloor - ! relative to the surface [Z ~> m]. - integer, dimension(SZI_(G),SZJ_(G)) :: nlevs + real, dimension(:), allocatable :: z_edges_in ! Input data interface heights or depths [Z ~> m] + real, dimension(:), allocatable :: z_in ! Input data cell heights or depths [Z ~> m] + real, dimension(:), allocatable :: Rb ! Interface densities [R ~> kg m-3] + real, dimension(:,:,:), allocatable, target :: temp_z ! Input temperatures [C ~> degC] + real, dimension(:,:,:), allocatable, target :: salt_z ! Input salinities [S ~> ppt] + real, dimension(:,:,:), allocatable, target :: mask_z ! 1 for valid data points [nondim] + real, dimension(:,:,:), allocatable :: rho_z ! Densities in Z-space [R ~> kg m-3] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: zi ! Interface heights [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Layer thicknesses in height units [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)) :: Z_bottom ! The (usually negative) height of the seafloor + ! relative to the surface [Z ~> m]. + integer, dimension(SZI_(G),SZJ_(G)) :: nlevs ! The number of levels in each column with valid data real, dimension(SZI_(G)) :: press ! Pressures [R L2 T-2 ~> Pa]. ! Local variables for ALE remapping real, dimension(:), allocatable :: hTarget ! Target thicknesses [Z ~> m]. - real, dimension(:,:,:), allocatable, target :: tmpT1dIn, tmpS1dIn - real, dimension(:,:,:), allocatable :: tmp_mask_in - real, dimension(:,:,:), allocatable :: h1 ! Thicknesses [H ~> m or kg m-2]. - real, dimension(:,:,:), allocatable :: dz_interface ! Change in position of interface due to regridding + real, dimension(:,:,:), allocatable, target :: tmpT1dIn ! Input temperatures on a model-sized grid [C ~> degC] + real, dimension(:,:,:), allocatable, target :: tmpS1dIn ! Input salinities on a model-sized grid [S ~> ppt] + real, dimension(:,:,:), allocatable :: tmp_mask_in ! The valid data mask on a model-sized grid [nondim] + real, dimension(:,:,:), allocatable :: dz1 ! Input grid thicknesses in depth units [Z ~> m] + real, dimension(:,:,:), allocatable :: h1 ! Thicknesses on the input grid [H ~> m or kg m-2]. + real, dimension(:,:,:), allocatable :: dz_interface ! Change in position of interface due to + ! regridding [H ~> m or kg m-2] + real :: dz_neglect ! A negligibly small vertical layer extent used in + ! remapping cell reconstructions [Z ~> m] + real :: dz_neglect_edge ! A negligibly small vertical layer extent used in + ! remapping edge value calculations [Z ~> m] real :: zTopOfCell, zBottomOfCell ! Heights in Z units [Z ~> m]. type(regridding_CS) :: regridCS ! Regridding parameters and work arrays type(remapping_CS) :: remapCS ! Remapping parameters and work arrays logical :: homogenize, useALEremapping, remap_full_column, remap_general, remap_old_alg - logical :: answers_2018, default_2018_answers, hor_regrid_answers_2018 - logical :: use_ice_shelf + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + integer :: 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. + integer :: hor_regrid_answer_date ! The vintage of the order of arithmetic and expressions to use + ! for horizontal regridding. Values below 20190101 recover the + ! answers from 2018, while higher values use expressions that have + ! been rearranged for rotational invariance. logical :: pre_gridded logical :: separate_mixed_layer ! If true, handle the mixed layers differently. logical :: density_extrap_bug ! If true use an expression with a vertical indexing bug for ! extrapolating the densities at the bottom of unstable profiles ! from data when finding the initial interface locations in ! layered mode from a dataset of T and S. - character(len=10) :: remappingScheme - real :: tempAvg, saltAvg - integer :: nPoints, ans - integer :: id_clock_routine, id_clock_read, id_clock_interp, id_clock_fill, id_clock_ALE + character(len=64) :: remappingScheme + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm (only used if useALEremapping) + logical :: do_conv_adj, ignore + logical :: use_depth_based_time_fitler, use_adjust_interface_motion + integer :: id_clock_routine, id_clock_ALE id_clock_routine = cpu_clock_id('(Initialize from Z)', grain=CLOCK_ROUTINE) id_clock_ALE = cpu_clock_id('(Initialize from Z) ALE', grain=CLOCK_LOOP) @@ -2355,16 +2663,11 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just if (.not.just_read) call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") if (.not.just_read) call log_version(PF, mdl, version, "") - inputdir = "." ; call get_param(PF, mdl, "INPUTDIR", inputdir) + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) eos => tv%eqn_of_state - reentrant_x = .false. ; call get_param(PF, mdl, "REENTRANT_X", reentrant_x, default=.true.) - tripolar_n = .false. ; call get_param(PF, mdl, "TRIPOLAR_N", tripolar_n, default=.false.) - - use_ice_shelf = present(frac_shelf_h) - call get_param(PF, mdl, "TEMP_SALT_Z_INIT_FILE", filename, & "The name of the z-space input file used to initialize "//& "temperatures (T) and salinities (S). If T and S are not "//& @@ -2396,8 +2699,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just "is True.", default="PPM_IH4", do_not_log=just_read) call get_param(PF, mdl, "Z_INIT_REMAP_GENERAL", remap_general, & "If false, only initializes to z* coordinates. "//& - "If true, allows initialization directly to general coordinates.",& - default=.false., do_not_log=just_read) + "If true, allows initialization directly to general coordinates.", & + default=.not.(GV%Boussinesq.or.GV%semi_Boussinesq) , do_not_log=just_read) call get_param(PF, mdl, "Z_INIT_REMAP_FULL_COLUMN", remap_full_column, & "If false, only reconstructs profiles for valid data points. "//& "If true, inserts vanished layers below the valid data.", & @@ -2406,29 +2709,52 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just "If false, uses the preferred remapping algorithm for initialization. "//& "If true, use an older, less robust algorithm for remapping.", & default=.false., do_not_log=just_read) - call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) + call get_param(PF, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231, do_not_log=just_read) call get_param(PF, mdl, "TEMP_SALT_INIT_VERTICAL_REMAP_ONLY", pre_gridded, & "If true, initial conditions are on the model horizontal grid. " //& "Extrapolation over missing ocean values is done using an ICE-9 "//& "procedure with vertical ALE remapping .", & - default=.false.) + default=.false., do_not_log=just_read) if (useALEremapping) then - call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) + call get_param(PF, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & + "The vintage of the expressions and order of arithmetic to use for remapping. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=just_read.or.(.not.GV%Boussinesq)) + call get_param(PF, mdl, "REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + do_not_log=.true., default=.true.) + call get_param(PF, mdl, "Z_INIT_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for initialization. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=om4_remap_via_sub_cells) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) endif - call get_param(PF, mdl, "HOR_REGRID_2018_ANSWERS", hor_regrid_answers_2018, & - "If true, use the order of arithmetic for horizonal regridding that recovers "//& - "the answers from the end of 2018. Otherwise, use rotationally symmetric "//& - "forms of the same expressions.", default=default_2018_answers) + call get_param(PF, mdl, "HOR_REGRID_ANSWER_DATE", hor_regrid_answer_date, & + "The vintage of the order of arithmetic for horizontal regridding. "//& + "Dates before 20190101 give the same answers as the code did in late 2018, "//& + "while later versions add parentheses for rotational symmetry. "//& + "Dates after 20230101 use reproducing sums for global averages.", & + default=default_answer_date, do_not_log=just_read.or.(.not.GV%Boussinesq)) + if (.not.GV%Boussinesq) hor_regrid_answer_date = max(hor_regrid_answer_date, 20230701) + if (.not.useALEremapping) then call get_param(PF, mdl, "ADJUST_THICKNESS", correct_thickness, & "If true, all mass below the bottom removed if the "//& "topography is shallower than the thickness input file "//& "would indicate.", default=.false., do_not_log=just_read) + call get_param(PF, mdl, "THICKNESS_TOLERANCE", h_tolerance, & + "A parameter that controls the tolerance when adjusting the "//& + "thickness to fit the bathymetry. Used when ADJUST_THICKNESS=True.", & + units="m", default=0.1, scale=US%m_to_Z, & + do_not_log=(just_read.or..not.correct_thickness)) + call get_param(PF, mdl, "DZ_BOTTOM_TOLERANCE", tol_dz_bot, & + "A tolerance for detecting inconsistent topography and input layer "//& + "thicknesses when ADJUST_THICKNESS is false.", & + units="m", default=1.0, scale=US%m_to_Z, & + do_not_log=(just_read.or.correct_thickness)) call get_param(PF, mdl, "FIT_TO_TARGET_DENSITY_IC", adjust_temperature, & "If true, all the interior layers are adjusted to "//& @@ -2441,26 +2767,55 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just "all layers are initialized based on the depths of their target densities.", & default=.false., do_not_log=just_read.or.(GV%nkml==0)) if (GV%nkml == 0) separate_mixed_layer = .false. - call get_param(PF, mdl, "MINIMUM_DEPTH", Hmix_default, default=0.0) + call get_param(PF, mdl, "MINIMUM_DEPTH", Hmix_default, & + units="m", default=0.0, scale=US%m_to_Z) call get_param(PF, mdl, "Z_INIT_HMIX_DEPTH", Hmix_depth, & "The mixed layer depth in the initial conditions when Z_INIT_SEPARATE_MIXED_LAYER "//& - "is set to true.", default=Hmix_default, units="m", scale=US%m_to_Z, & + "is set to true.", units="m", default=US%Z_to_m*Hmix_default, scale=US%m_to_Z, & do_not_log=(just_read .or. .not.separate_mixed_layer)) + ! Reusing MINIMUM_DEPTH for the default mixed layer depth may be a strange choice, but + ! it reproduces previous answers. + call get_param(PF, mdl, "DENSITY_INTERP_TOLERANCE", eps_rho, & + "A small density tolerance used when finding depths in a density profile.", & + units="kg m-3", default=1.0e-10, scale=US%kg_m3_to_R, & + do_not_log=useALEremapping.or.just_read) call get_param(PF, mdl, "LAYER_Z_INIT_IC_EXTRAP_BUG", density_extrap_bug, & "If true use an expression with a vertical indexing bug for extrapolating the "//& "densities at the bottom of unstable profiles from data when finding the "//& "initial interface locations in layered mode from a dataset of T and S.", & - default=.true., do_not_log=just_read) - ! Reusing MINIMUM_DEPTH for the default mixed layer depth may be a strange choice, but - ! it reproduces previous answers. + default=.false., do_not_log=just_read) endif + call get_param(PF, mdl, "LAND_FILL_TEMP", temp_land_fill, & + "A value to use to fill in ocean temperatures on land points.", & + units="degC", default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(PF, mdl, "LAND_FILL_SALIN", salt_land_fill, & + "A value to use to fill in ocean salinities on land points.", & + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(PF, mdl, "HORIZ_INTERP_TOL_TEMP", tol_temp, & + "The tolerance in temperature changes between iterations when interpolating "//& + "from an input dataset using horiz_interp_and_extrap_tracer. This routine "//& + "converges slowly, so an overly small tolerance can get expensive.", & + units="degC", default=1.0e-3, scale=US%degC_to_C, do_not_log=just_read) + call get_param(PF, mdl, "HORIZ_INTERP_TOL_SALIN", tol_sal, & + "The tolerance in salinity changes between iterations when interpolating "//& + "from an input dataset using horiz_interp_and_extrap_tracer. This routine "//& + "converges slowly, so an overly small tolerance can get expensive.", & + units="ppt", default=1.0e-3, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(PF, mdl, "REGRID_USE_DEPTH_BASED_TIME_FILTER", use_depth_based_time_fitler, & + default=.true., do_not_log=.true.) + call get_param(PF, mdl, "USE_ADJUST_INTERFACE_MOTION", use_adjust_interface_motion, & + default=.true., do_not_log=.true.) + if (just_read) then + if ((.not.useALEremapping) .and. adjust_temperature) & + ! This call is just here to read and log the determine_temperature parameters + call determine_temperature(tv%T, tv%S, GV%Rlay(1:nz), eos, tv%P_Ref, 0, & + 0, G, GV, US, PF, just_read=.true.) call cpu_clock_end(id_clock_routine) return ! All run-time parameters have been read, so return. endif eps_z = GV%Angstrom_Z - eps_rho = 1.0e-10*US%kg_m3_to_R ! Read input grid coordinates for temperature and salinity field ! in z-coordinate dataset. The file is REQUIRED to contain the @@ -2477,35 +2832,24 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just ! to the North/South Pole past the limits of the input data, they are extrapolated using the average ! value at the northernmost/southernmost latitude. - call horiz_interp_and_extrap_tracer(tfilename, potemp_var, 1.0, 1, & - G, temp_z, mask_z, z_in, z_edges_in, missing_value_temp, reentrant_x, & - tripolar_n, homogenize, m_to_Z=US%m_to_Z, answers_2018=hor_regrid_answers_2018, ongrid=pre_gridded) + call horiz_interp_and_extrap_tracer(tfilename, potemp_var, 1, & + G, temp_z, mask_z, z_in, z_edges_in, missing_value_temp, & + scale=US%degC_to_C, homogenize=homogenize, m_to_Z=US%m_to_Z, & + answer_date=hor_regrid_answer_date, ongrid=pre_gridded, tr_iter_tol=tol_temp) - call horiz_interp_and_extrap_tracer(sfilename, salin_var, 1.0, 1, & - G, salt_z, mask_z, z_in, z_edges_in, missing_value_salt, reentrant_x, & - tripolar_n, homogenize, m_to_Z=US%m_to_Z, answers_2018=hor_regrid_answers_2018, ongrid=pre_gridded) + call horiz_interp_and_extrap_tracer(sfilename, salin_var, 1, & + G, salt_z, mask_z, z_in, z_edges_in, missing_value_salt, & + scale=US%ppt_to_S, homogenize=homogenize, m_to_Z=US%m_to_Z, & + answer_date=hor_regrid_answer_date, ongrid=pre_gridded, tr_iter_tol=tol_sal) kd = size(z_in,1) ! Convert the sign convention of Z_edges_in. do k=1,size(Z_edges_in,1) ; Z_edges_in(k) = -Z_edges_in(k) ; enddo - allocate(rho_z(isd:ied,jsd:jed,kd)) - ! Convert T&S to Absolute Salinity and Conservative Temperature if using TEOS10 or NEMO call convert_temp_salt_for_TEOS10(temp_z, salt_z, G%HI, kd, mask_z, eos) - press(:) = tv%P_Ref - EOSdom(:) = EOS_domain(G%HI) - do k=1,kd ; do j=js,je - call calculate_density(temp_z(:,j,k), salt_z(:,j,k), press, rho_z(:,j,k), eos, EOSdom) - enddo ; enddo - - call pass_var(temp_z,G%Domain) - call pass_var(salt_z,G%Domain) - call pass_var(mask_z,G%Domain) - call pass_var(rho_z,G%Domain) - do j=js,je ; do i=is,ie Z_bottom(i,j) = -depth_tot(i,j) enddo ; enddo @@ -2518,15 +2862,16 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just ! Build the source grid and copy data onto model-shaped arrays with vanished layers allocate( tmp_mask_in(isd:ied,jsd:jed,nkd), source=0.0 ) + allocate( dz1(isd:ied,jsd:jed,nkd), source=0.0 ) allocate( h1(isd:ied,jsd:jed,nkd), source=0.0 ) allocate( tmpT1dIn(isd:ied,jsd:jed,nkd), source=0.0 ) allocate( tmpS1dIn(isd:ied,jsd:jed,nkd), source=0.0 ) do j = js, je ; do i = is, ie - if (G%mask2dT(i,j)>0.) then + if (G%mask2dT(i,j) > 0.) then zTopOfCell = 0. ; zBottomOfCell = 0. tmp_mask_in(i,j,1:kd) = mask_z(i,j,:) do k = 1, nkd - if (tmp_mask_in(i,j,k)>0. .and. k<=kd) then + if ((tmp_mask_in(i,j,k) > 0.) .and. (k <= kd)) then zBottomOfCell = max( z_edges_in(k+1), Z_bottom(i,j)) tmpT1dIn(i,j,k) = temp_z(i,j,k) tmpS1dIn(i,j,k) = salt_z(i,j,k) @@ -2535,68 +2880,94 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just tmpT1dIn(i,j,k) = tmpT1dIn(i,j,k-1) tmpS1dIn(i,j,k) = tmpS1dIn(i,j,k-1) else ! This next block should only ever be reached over land - tmpT1dIn(i,j,k) = -99.9 - tmpS1dIn(i,j,k) = -99.9 + tmpT1dIn(i,j,k) = temp_land_fill + tmpS1dIn(i,j,k) = salt_land_fill endif - h1(i,j,k) = GV%Z_to_H * (zTopOfCell - zBottomOfCell) + dz1(i,j,k) = (zTopOfCell - zBottomOfCell) zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k enddo - h1(i,j,kd) = h1(i,j,kd) + GV%Z_to_H * max(0., zTopOfCell - Z_bottom(i,j) ) + dz1(i,j,kd) = dz1(i,j,kd) + max(0., zTopOfCell - Z_bottom(i,j) ) ! The max here is in case the data data is shallower than model endif ! mask2dT enddo ; enddo deallocate( tmp_mask_in ) - call pass_var(h1, G%Domain) - call pass_var(tmpT1dIn, G%Domain) - call pass_var(tmpS1dIn, G%Domain) + + ! Convert input thicknesses to units of H. In non-Boussinesq mode this is done by inverting + ! integrals of specific volume in pressure, so it can be expensive. + tv_loc = tv + tv_loc%T => tmpT1dIn + tv_loc%S => tmpS1dIn + GV_loc = GV + GV_loc%ke = nkd + call dz_to_thickness(dz1, tv_loc, h1, G, GV_loc, US) ! Build the target grid (and set the model thickness to it) - ! This call can be more general but is hard-coded for z* coordinates... ???? - call ALE_initRegridding( GV, US, G%max_depth, PF, mdl, regridCS ) ! sets regridCS - if (.not. remap_general) then + call ALE_initRegridding( G, 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, & + 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 + call set_regrid_params( regridCS, min_thickness=0., & + use_adjust_interface_motion=use_adjust_interface_motion, & + use_depth_based_time_filter=use_depth_based_time_fitler) + allocate( dz_interface(isd:ied,jsd:jed,nkd+1), source=0.) ! Need for argument to regridding_main() but is not used + + call regridding_preadjust_reqs(regridCS, do_conv_adj, ignore) + if (do_conv_adj) call convective_adjustment(G, GV_loc, h1, tv_loc) + call regridding_main( remapCS, regridCS, G, GV_loc, US, h1, tv_loc, h, dz_interface, & + frac_shelf_h=frac_shelf_h ) + + 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 ) + call ALE_remap_scalar(remapCS, G, GV, nkd, h1, tmpS1dIn, h, tv%S, all_cells=remap_full_column, & + old_remap=remap_old_alg ) + else ! This is the old way of initializing to z* coordinates only allocate( hTarget(nz) ) hTarget = getCoordinateResolution( regridCS ) do j = js, je ; do i = is, ie - h(i,j,:) = 0. - if (G%mask2dT(i,j)>0.) then + dz(i,j,:) = 0. + if (G%mask2dT(i,j) > 0.) then ! Build the target grid combining hTarget and topography zTopOfCell = 0. ; zBottomOfCell = 0. do k = 1, nz zBottomOfCell = max( zTopOfCell - hTarget(k), Z_bottom(i,j)) - h(i,j,k) = GV%Z_to_H * (zTopOfCell - zBottomOfCell) + dz(i,j,k) = zTopOfCell - zBottomOfCell zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k enddo else - h(i,j,:) = 0. + dz(i,j,:) = 0. endif ! mask2dT enddo ; enddo - call pass_var(h, G%Domain) deallocate( hTarget ) - endif - ! Now remap from source grid to target grid, first setting reconstruction parameters - call initialize_remapping( remapCS, remappingScheme, boundary_extrapolation=.false., answers_2018=answers_2018 ) - if (remap_general) then - call set_regrid_params( regridCS, min_thickness=0. ) - tv_loc = tv - tv_loc%T => tmpT1dIn - tv_loc%S => tmpS1dIn - GV_loc = GV - GV_loc%ke = nkd - allocate( dz_interface(isd:ied,jsd:jed,nkd+1) ) ! Need for argument to regridding_main() but is not used - if (use_ice_shelf) then - call regridding_main( remapCS, regridCS, G, GV_loc, h1, tv_loc, h, dz_interface, frac_shelf_h ) + 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) + call ALE_remap_scalar(remapCS, G, GV, nkd, dz1, tmpS1dIn, dz, tv%S, all_cells=remap_full_column, & + 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 + ! appropriate in non-Boussinesq mode. + call dz_to_thickness_simple(dz, h, G, GV, US) else - call regridding_main( remapCS, regridCS, G, GV_loc, h1, tv_loc, h, dz_interface ) + ! Convert dz into thicknesses in units of H using the equation of state as appropriate. + call dz_to_thickness(dz, tv, h, G, GV, US) endif - deallocate( dz_interface ) endif - call ALE_remap_scalar(remapCS, G, GV, nkd, h1, tmpT1dIn, h, tv%T, all_cells=remap_full_column, & - old_remap=remap_old_alg, answers_2018=answers_2018 ) - call ALE_remap_scalar(remapCS, G, GV, nkd, h1, tmpS1dIn, h, tv%S, all_cells=remap_full_column, & - old_remap=remap_old_alg, answers_2018=answers_2018 ) + + deallocate( dz1 ) deallocate( h1 ) deallocate( tmpT1dIn ) deallocate( tmpS1dIn ) @@ -2621,80 +2992,68 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just nkml = 0 ; if (separate_mixed_layer) nkml = GV%nkml + press(:) = tv%P_Ref + EOSdom(:) = EOS_domain(G%HI) + allocate(rho_z(isd:ied,jsd:jed,kd)) + do k=1,kd ; do j=js,je + call calculate_density(temp_z(:,j,k), salt_z(:,j,k), press, rho_z(:,j,k), eos, EOSdom) + enddo ; enddo + call find_interfaces(rho_z, z_in, kd, Rb, Z_bottom, zi, G, GV, US, nlevs, nkml, & Hmix_depth, eps_z, eps_rho, density_extrap_bug) + deallocate(rho_z, Rb) + + dz(:,:,:) = 0.0 if (correct_thickness) then - call adjustEtaToFitBathymetry(G, GV, US, zi, h, dZ_ref_eta=G%Z_ref) + call adjustEtaToFitBathymetry(G, GV, US, zi, dz, h_tolerance, dZ_ref_eta=G%Z_ref) else do k=nz,1,-1 ; do j=js,je ; do i=is,ie if (zi(i,j,K) < (zi(i,j,K+1) + GV%Angstrom_Z)) then zi(i,j,K) = zi(i,j,K+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + dz(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H * (zi(i,j,K) - zi(i,j,K+1)) + dz(i,j,k) = zi(i,j,K) - zi(i,j,K+1) endif enddo ; enddo ; enddo - inconsistent=0 + inconsistent = 0 do j=js,je ; do i=is,ie - if (abs(zi(i,j,nz+1) - Z_bottom(i,j)) > 1.0*US%m_to_Z) & + if (abs(zi(i,j,nz+1) - Z_bottom(i,j)) > tol_dz_bot) & inconsistent = inconsistent + 1 enddo ; enddo call sum_across_PEs(inconsistent) if ((inconsistent > 0) .and. (is_root_pe())) then write(mesg, '("Thickness initial conditions are inconsistent ",'// & - '"with topography in ",I5," places.")') inconsistent + '"with topography in ",I0," places.")') inconsistent call MOM_error(WARNING, mesg) endif endif - call tracer_z_init_array(temp_z, z_edges_in, kd, zi, missing_value, G, nz, nlevs, eps_z, tv%T) - call tracer_z_init_array(salt_z, z_edges_in, kd, zi, missing_value, G, nz, nlevs, eps_z, tv%S) - - do k=1,nz - nPoints = 0 ; tempAvg = 0. ; saltAvg = 0. - do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) >= 1.0) then - nPoints = nPoints + 1 - tempAvg = tempAvg + tv%T(i,j,k) - saltAvg = saltAvg + tv%S(i,j,k) - endif ; enddo ; enddo + call tracer_z_init_array(temp_z, z_edges_in, kd, zi, temp_land_fill, G, nz, nlevs, eps_z, tv%T) + call tracer_z_init_array(salt_z, z_edges_in, kd, zi, salt_land_fill, G, nz, nlevs, eps_z, tv%S) + if (homogenize) then ! Horizontally homogenize data to produce perfectly "flat" initial conditions - if (homogenize) then - call sum_across_PEs(nPoints) - call sum_across_PEs(tempAvg) - call sum_across_PEs(saltAvg) - if (nPoints>0) then - tempAvg = tempAvg / real(nPoints) - saltAvg = saltAvg / real(nPoints) - endif - tv%T(:,:,k) = tempAvg - tv%S(:,:,k) = saltAvg - endif - enddo - - endif ! useALEremapping + do k=1,nz + call homogenize_field(tv%T(:,:,k), G, tmp_scale=US%C_to_degC, answer_date=hor_regrid_answer_date) + call homogenize_field(tv%S(:,:,k), G, tmp_scale=US%S_to_ppt, answer_date=hor_regrid_answer_date) + enddo + endif - ! Fill land values - do k=1,nz ; do j=js,je ; do i=is,ie - if (tv%T(i,j,k) == missing_value) then - tv%T(i,j,k) = temp_land_fill - tv%S(i,j,k) = salt_land_fill + if (adjust_temperature) then + ! Finally adjust to target density + ks = 1 ; if (separate_mixed_layer) ks = GV%nk_rho_varies + 1 + call determine_temperature(tv%T, tv%S, GV%Rlay(1:nz), eos, tv%P_Ref, niter, & + ks, G, GV, US, PF, just_read) endif - enddo ; enddo ; enddo + ! Now convert dz into thicknesses in units of H. + call dz_to_thickness(dz, tv, h, G, GV, US) - if (adjust_temperature .and. .not. useALEremapping) then - ! Finally adjust to target density - ks = 1 ; if (separate_mixed_layer) ks = GV%nk_rho_varies + 1 - call determine_temperature(tv%T, tv%S, GV%Rlay(1:nz), tv%P_Ref, niter, & - missing_value, h, ks, G, GV, US, eos) - endif + endif ! useALEremapping deallocate(z_in, z_edges_in, temp_z, salt_z, mask_z) - deallocate(rho_z) - call pass_var(h, G%Domain) call pass_var(tv%T, G%Domain) @@ -2740,7 +3099,7 @@ subroutine find_interfaces(rho, zin, nk_data, Rb, Z_bot, zi, G, GV, US, nlevs, n real, dimension(SZK_(GV)+1) :: zi_ ! A column interface heights (negative downward) [Z ~> m]. real :: slope ! The rate of change of height with density [Z R-1 ~> m4 kg-1] real :: drhodz ! A local vertical density gradient [R Z-1 ~> kg m-4] - real, parameter :: zoff=0.999 + real, parameter :: zoff = 0.999 ! A small fractional adjustment to the density differences [nondim] logical :: unstable ! True if the column is statically unstable anywhere. integer :: nlevs_data ! The number of data values in a column. logical :: work_down ! This indicates whether this pass goes up or down the water column. @@ -2755,18 +3114,18 @@ subroutine find_interfaces(rho, zin, nk_data, Rb, Z_bot, zi, G, GV, US, nlevs, n nlevs_data = nlevs(i,j) do k=1,nlevs_data ; rho_(k) = rho(i,j,k) ; enddo - unstable=.true. + unstable = .true. work_down = .true. do while (unstable) ! Modify the input profile until it no longer has densities that decrease with depth. - unstable=.false. + unstable = .false. if (work_down) then - do k=2,nlevs_data-1 ; if (rho_(k) - rho_(k-1) < 0.0 ) then + do k=2,nlevs_data-1 ; if (rho_(k) - rho_(k-1) < 0.0) then if (k == 2) then rho_(k-1) = rho_(k) - eps_rho else drhodz = (rho_(k+1)-rho_(k-1)) / (zin(k+1)-zin(k-1)) - if (drhodz < 0.0) unstable=.true. + if (drhodz < 0.0) unstable = .true. rho_(k) = rho_(k-1) + drhodz*zoff*(zin(k)-zin(k-1)) endif endif ; enddo @@ -2781,7 +3140,7 @@ subroutine find_interfaces(rho, zin, nk_data, Rb, Z_bot, zi, G, GV, US, nlevs, n endif else drhodz = (rho_(k+1)-rho_(k-1)) / (zin(k+1)-zin(k-1)) - if (drhodz < 0.0) unstable=.true. + if (drhodz < 0.0) unstable = .true. rho_(k) = rho_(k+1) - drhodz*(zin(k+1)-zin(k)) endif endif ; enddo @@ -2845,16 +3204,19 @@ subroutine MOM_state_init_tests(G, GV, US, tv) ! Local variables integer, parameter :: nk=5 - real, dimension(nk) :: T, T_t, T_b ! Temperatures [degC] - real, dimension(nk) :: S, S_t, S_b ! Salinities [ppt] + real, dimension(nk) :: T, T_t, T_b ! Temperatures [C ~> degC] + real, dimension(nk) :: S, S_t, S_b ! Salinities [S ~> ppt] real, dimension(nk) :: rho ! Layer density [R ~> kg m-3] real, dimension(nk) :: h ! Layer thicknesses [H ~> m or kg m-2] real, dimension(nk) :: z ! Height of layer center [Z ~> m] real, dimension(nk+1) :: e ! Interface heights [Z ~> m] - integer :: k + real :: T_ref ! A reference temperature [C ~> degC] + real :: S_ref ! A reference salinity [S ~> ppt] real :: P_tot, P_t, P_b ! Pressures [R L2 T-2 ~> Pa] real :: z_out ! Output height [Z ~> m] real :: I_z_scale ! The inverse of the height scale for prescribed gradients [Z-1 ~> m-1] + real :: z_tol ! The tolerance with which to find the depth matching a specified pressure [Z ~> m]. + integer :: k type(remapping_CS), pointer :: remap_CS => NULL() I_z_scale = 1.0 / (500.0*US%m_to_Z) @@ -2866,14 +3228,17 @@ subroutine MOM_state_init_tests(G, GV, US, tv) e(K+1) = e(K) - GV%H_to_Z * h(k) enddo P_tot = 0. + T_ref = 20.0*US%degC_to_C + S_ref = 35.0*US%ppt_to_S + z_tol = 1.0e-5*US%m_to_Z do k = 1, nk z(k) = 0.5 * ( e(K) + e(K+1) ) - T_t(k) = 20. + (0. * I_z_scale) * e(k) - T(k) = 20. + (0. * I_z_scale)*z(k) - T_b(k) = 20. + (0. * I_z_scale)*e(k+1) - S_t(k) = 35. - (0. * I_z_scale)*e(k) - S(k) = 35. + (0. * I_z_scale)*z(k) - S_b(k) = 35. - (0. * I_z_scale)*e(k+1) + T_t(k) = T_ref + (0. * I_z_scale) * e(k) + T(k) = T_ref + (0. * I_z_scale)*z(k) + T_b(k) = T_ref + (0. * I_z_scale)*e(k+1) + S_t(k) = S_ref - (0. * I_z_scale)*e(k) + S(k) = S_ref + (0. * I_z_scale)*z(k) + S_b(k) = S_ref - (0. * I_z_scale)*e(k+1) call calculate_density(0.5*(T_t(k)+T_b(k)), 0.5*(S_t(k)+S_b(k)), -GV%Rho0*GV%g_Earth*z(k), & rho(k), tv%eqn_of_state) P_tot = P_tot + GV%g_Earth * rho(k) * GV%H_to_Z*h(k) @@ -2882,7 +3247,8 @@ subroutine MOM_state_init_tests(G, GV, US, tv) P_t = 0. do k = 1, nk call find_depth_of_pressure_in_cell(T_t(k), T_b(k), S_t(k), S_b(k), e(K), e(K+1), P_t, 0.5*P_tot, & - GV%Rho0, GV%g_Earth, tv%eqn_of_state, US, P_b, z_out) + GV%Rho0, GV%g_Earth, tv%eqn_of_state, US, P_b, z_out, z_tol=z_tol, & + frac_dp_bugfix=.false.) write(0,*) k, US%RL2_T2_to_Pa*P_t, US%RL2_T2_to_Pa*P_b, 0.5*US%RL2_T2_to_Pa*P_tot, & US%Z_to_m*e(K), US%Z_to_m*e(K+1), US%Z_to_m*z_out P_t = P_b @@ -2893,9 +3259,18 @@ subroutine MOM_state_init_tests(G, GV, US, tv) write(0,*) ' ==================================================================== ' write(0,*) '' write(0,*) GV%H_to_m*h(:) - call cut_off_column_top(nk, tv, GV, US, GV%g_Earth, -e(nk+1), GV%Angstrom_Z, & - T, T_t, T_b, S, S_t, S_b, 0.5*P_tot, h, remap_CS) + + ! 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, & + frac_dp_bugfix=.false.) 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 8a67d71fe2..d444fafdd9 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -1,21 +1,25 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Initializes hydrography from z-coordinate climatology files module MOM_tracer_initialization_from_Z -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_debugging, only : hchksum -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end -use MOM_cpu_clock, only : CLOCK_ROUTINE, CLOCK_LOOP -use MOM_domains, only : pass_var +use MOM_debugging, only : hchksum +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_ROUTINE, CLOCK_LOOP +use MOM_domains, only : pass_var use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint -use MOM_file_parser, only : get_param, param_file_type, log_version -use MOM_grid, only : ocean_grid_type +use MOM_file_parser, only : get_param, param_file_type, log_version +use MOM_grid, only : ocean_grid_type use MOM_horizontal_regridding, only : myStats, horiz_interp_and_extrap_tracer -use MOM_remapping, only : remapping_CS, initialize_remapping -use MOM_unit_scaling, only : unit_scale_type -use MOM_verticalGrid, only : verticalGrid_type -use MOM_ALE, only : ALE_remap_scalar +use MOM_interface_heights, only : dz_to_thickness_simple +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 +use MOM_ALE, only : ALE_remap_scalar implicit none ; private @@ -35,31 +39,41 @@ module MOM_tracer_initialization_from_Z !> Initializes a tracer from a z-space data file, including any lateral regridding that is needed. subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_nam, & src_var_unit_conversion, src_var_record, homogenize, & - useALEremapping, remappingScheme, src_var_gridspec ) + useALEremapping, remappingScheme, src_var_gridspec, h_in_Z_units, & + ongrid) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean 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]. - real, dimension(:,:,:), pointer :: tr !< Pointer to array to be initialized + intent(in) :: h !< Layer thicknesses, in [H ~> m or kg m-2] or + !! [Z ~> m] depending on the value of h_in_Z_units. + real, dimension(:,:,:), pointer :: tr !< Pointer to array to be initialized [CU ~> conc] type(param_file_type), intent(in) :: PF !< parameter file character(len=*), intent(in) :: src_file !< source filename character(len=*), intent(in) :: src_var_nam !< variable name in file - real, optional, intent(in) :: src_var_unit_conversion !< optional multiplicative unit conversion + real, optional, intent(in) :: src_var_unit_conversion !< optional multiplicative unit conversion, + !! often used for rescaling into model units [CU conc-1 ~> 1] integer, optional, intent(in) :: src_var_record !< record to read for multiple time-level files logical, optional, intent(in) :: homogenize !< optionally homogenize to mean value logical, optional, intent(in) :: useALEremapping !< to remap or not (optional) character(len=*), optional, intent(in) :: remappingScheme !< remapping scheme to use. character(len=*), optional, intent(in) :: src_var_gridspec !< Source variable name in a gridspec file. !! This is not implemented yet. + logical, optional, intent(in) :: h_in_Z_units !< If present and true, the input grid + !! thicknesses are in the units of height + !! ([Z ~> m]) instead of the usual units of + !! thicknesses ([H ~> m or kg m-2]) + logical, optional, intent(in) :: ongrid !< If true, then data are assumed to have been + !! interpolated to the model horizontal grid. In this case, + !! only extrapolation is performed by + !! horiz_interp_and_extrap_tracer() ! Local variables - real :: land_fill = 0.0 - character(len=200) :: inputdir ! The directory where NetCDF input files are. - character(len=200) :: mesg - real :: convert + real :: land_fill = 0.0 ! A value to use to replace missing values [CU ~> conc] + real :: convert ! A conversion factor into the model's internal units [CU conc-1 ~> 1] integer :: recnum - character(len=10) :: remapScheme - logical :: homog,useALE + character(len=64) :: remapScheme + logical :: homog, useALE + logical :: h_is_in_Z_units ! This include declares and sets the variable "version". # include "version_variable.h" @@ -68,20 +82,38 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ integer :: is, ie, js, je, nz ! compute domain indices integer :: isd, ied, jsd, jed ! data domain indices integer :: i, j, k, kd - real, allocatable, dimension(:,:,:), target :: tr_z, mask_z - real, allocatable, dimension(:), target :: z_edges_in, z_in + real, allocatable, dimension(:,:,:), target :: tr_z ! Tracer array on the horizontal model grid + ! and input-file vertical levels [CU ~> conc] + real, allocatable, dimension(:,:,:), target :: mask_z ! Missing value mask on the horizontal model grid + ! and input-file vertical levels [nondim] + real, allocatable, dimension(:), target :: z_edges_in ! Cell edge depths for input data [Z ~> m] + real, allocatable, dimension(:), target :: z_in ! Cell center depths for input data [Z ~> m] ! Local variables for ALE remapping - real, dimension(:,:,:), allocatable :: hSrc ! Source thicknesses [H ~> m or kg m-2]. + real, dimension(:,:,:), allocatable :: dzSrc ! Source thicknesses in height units [Z ~> m] + real, dimension(:,:,:), allocatable :: hSrc ! Source thicknesses [H ~> m or kg m-2] real, dimension(:), allocatable :: h1 ! A 1-d column of source thicknesses [Z ~> m]. real :: zTopOfCell, zBottomOfCell, z_bathy ! Heights [Z ~> m]. type(remapping_CS) :: remapCS ! Remapping parameters and work arrays + type(verticalGrid_type) :: GV_loc ! A temporary vertical grid structure - real :: missing_value - integer :: nPoints + 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] 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] 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 - logical :: answers_2018, default_2018_answers, hor_regrid_answers_2018 - logical :: reentrant_x, tripolar_n + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + integer :: 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. + integer :: hor_regrid_answer_date ! The vintage of the order of arithmetic and expressions to use + ! for horizontal regridding. Values below 20190101 recover the + ! answers from 2018, while higher values use expressions that have + ! been rearranged for rotational invariance. id_clock_routine = cpu_clock_id('(Initialize tracer from Z)', grain=CLOCK_ROUTINE) id_clock_ALE = cpu_clock_id('(Initialize tracer from Z) ALE', grain=CLOCK_LOOP) @@ -91,47 +123,57 @@ 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 "//& "initial conditions.", default=.false.) call get_param(PF, mdl, "Z_INIT_ALE_REMAPPING", useALE, & "If True, then remap straight to model coordinate from file.",& - default=.true.) + default=.false.) call get_param(PF, mdl, "Z_INIT_REMAPPING_SCHEME", remapScheme, & "The remapping scheme to use if using Z_INIT_ALE_REMAPPING is True.", & - default="PLM") - call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) + default="PPM_IH4") + call get_param(PF, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) if (useALE) then - call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) + call get_param(PF, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & + "The vintage of the expressions and order of arithmetic to use for remapping. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + call get_param(PF, mdl, "REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + do_not_log=.true., default=.true.) + call get_param(PF, mdl, "Z_INIT_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for initialization. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=om4_remap_via_sub_cells) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) endif - call get_param(PF, mdl, "HOR_REGRID_2018_ANSWERS", hor_regrid_answers_2018, & - "If true, use the order of arithmetic for horizonal regridding that recovers "//& - "the answers from the end of 2018. Otherwise, use rotationally symmetric "//& - "forms of the same expressions.", default=default_2018_answers) - - ! These are model grid properties, but being applied to the data grid for now. - ! need to revisit this (mjh) - reentrant_x = .false. ; call get_param(PF, mdl, "REENTRANT_X", reentrant_x,default=.true.) - tripolar_n = .false. ; call get_param(PF, mdl, "TRIPOLAR_N", tripolar_n, default=.false.) + call get_param(PF, mdl, "HOR_REGRID_ANSWER_DATE", hor_regrid_answer_date, & + "The vintage of the order of arithmetic for horizontal regridding. "//& + "Dates before 20190101 give the same answers as the code did in late 2018, "//& + "while later versions add parentheses for rotational symmetry. "//& + "Dates after 20230101 use reproducing sums for global averages.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) hor_regrid_answer_date = max(hor_regrid_answer_date, 20230701) if (PRESENT(homogenize)) homog=homogenize if (PRESENT(useALEremapping)) useALE=useALEremapping if (PRESENT(remappingScheme)) remapScheme=remappingScheme - recnum=1 + recnum = 1 if (PRESENT(src_var_record)) recnum = src_var_record - convert=1.0 + convert = 1.0 if (PRESENT(src_var_unit_conversion)) convert = src_var_unit_conversion - call horiz_interp_and_extrap_tracer(src_file, src_var_nam, convert, recnum, & - G, tr_z, mask_z, z_in, z_edges_in, missing_value, reentrant_x, tripolar_n, & - homog, m_to_Z=US%m_to_Z, answers_2018=hor_regrid_answers_2018) + h_is_in_Z_units = .false. ; if (present(h_in_Z_units)) h_is_in_Z_units = h_in_Z_units + + call horiz_interp_and_extrap_tracer(src_file, src_var_nam, recnum, & + G, tr_z, mask_z, z_in, z_edges_in, missing_value, & + scale=convert, homogenize=homog, m_to_Z=US%m_to_Z, & + answer_date=hor_regrid_answer_date, ongrid=ongrid) kd = size(z_edges_in,1)-1 call pass_var(tr_z,G%Domain) @@ -143,9 +185,17 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ call cpu_clock_begin(id_clock_ALE) ! First we reserve a work space for reconstructions of the source data allocate( h1(kd) ) + allocate( dzSrc(isd:ied,jsd:jed,kd) ) allocate( hSrc(isd:ied,jsd:jed,kd) ) - ! Set parameters for reconstructions - call initialize_remapping( remapCS, remapScheme, boundary_extrapolation=.false., answers_2018=answers_2018 ) + ! Set parameters for reconstructions in the right units + if (h_is_in_Z_units) then + dz_neglect = set_dz_neglect(GV, US, remap_answer_date, dz_neglect_edge) + else + dz_neglect = set_h_neglect(GV, remap_answer_date, dz_neglect_edge) + endif + call initialize_remapping( remapCS, remapScheme, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, answer_date=remap_answer_date, & + H_neglect=dz_neglect, H_neglect_edge=dz_neglect_edge ) ! Next we initialize the regridding package so that it knows about the target grid do j = js, je ; do i = is, ie @@ -167,16 +217,27 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ else tr(i,j,:) = 0. endif ! mask2dT - hSrc(i,j,:) = GV%Z_to_H * h1(:) + dzSrc(i,j,:) = h1(:) enddo ; enddo - call ALE_remap_scalar(remapCS, G, GV, kd, hSrc, tr_z, h, tr, all_cells=.false., answers_2018=answers_2018 ) + if (h_is_in_Z_units) then + ! 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.) + endif deallocate( hSrc ) + deallocate( dzSrc ) deallocate( h1 ) do k=1,nz - call myStats(tr(:,:,k), missing_value, is, ie, js, je, k, 'Tracer from ALE()') + call myStats(tr(:,:,k), missing_value, G, k, 'Tracer from ALE()') enddo call cpu_clock_end(id_clock_ALE) endif ! useALEremapping @@ -184,7 +245,7 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ ! Fill land values do k=1,nz ; do j=js,je ; do i=is,ie if (tr(i,j,k) == missing_value) then - tr(i,j,k)=land_fill + tr(i,j,k) = land_fill endif enddo ; enddo ; enddo diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index d5259d760a..7ab89310b4 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -1,3 +1,7 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Interfaces for MOM6 ensembles and data assimilation. module MOM_oda_driver_mod @@ -15,8 +19,10 @@ module MOM_oda_driver_mod use MOM_ensemble_manager, only : get_ensemble_pelist, get_ensemble_filter_pelist use MOM_error_handler, only : stdout, stdlog, MOM_error use MOM_io, only : SINGLE_FILE -use MOM_interp_infra, only : init_extern_field, get_external_field_info +use MOM_interp_infra, only : init_extern_field use MOM_interp_infra, only : time_interp_extern +use MOM_interpolate, only : external_field +use MOM_interpolate, only : get_external_field_info use MOM_remapping, only : remappingSchemesDoc use MOM_time_manager, only : time_type, real_to_time, get_date use MOM_time_manager, only : operator(+), operator(>=), operator(/=) @@ -46,7 +52,7 @@ module MOM_oda_driver_mod use MOM_hor_index, only : hor_index_type, hor_index_init use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid -use MOM_fixed_initialization, only : MOM_initialize_fixed, MOM_initialize_topography +use MOM_fixed_initialization, only : MOM_initialize_topography use MOM_coord_initialization, only : MOM_initialize_coord use MOM_file_parser, only : read_param, get_param, param_file_type use MOM_string_functions, only : lowercase @@ -54,7 +60,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 @@ -79,9 +85,9 @@ module MOM_oda_driver_mod !> A structure containing integer handles for bias adjustment of tracers type :: INC_CS - integer :: fldno = 0 !< The number of tracers - integer :: T_id !< The integer handle for the temperature file - integer :: S_id !< The integer handle for the salinity file + integer :: fldno = 0 !< The number of tracers + type(external_field) :: T !< The handle for the temperature file + type(external_field) :: S !< The handle for the salinity file end type INC_CS !> Control structure that contains a transpose of the ocean state across ensemble members. @@ -103,8 +109,12 @@ module MOM_oda_driver_mod type(domain2d), pointer :: mpp_domain => NULL() !< Pointer to a mpp domain object for DA type(grid_type), pointer :: oda_grid !< local tracer grid real, pointer, dimension(:,:,:) :: h => NULL() ! m or kg m-2] for DA - type(thermo_var_ptrs), pointer :: tv => NULL() !< pointer to thermodynamic variables - type(thermo_var_ptrs), pointer :: tv_bc => NULL() !< pointer to thermodynamic bias correction + real, pointer, dimension(:,:,:) :: T_tend => NULL() ! degC s-1] + real, pointer, dimension(:,:,:) :: S_tend => NULL() ! ppt s-1] + real, pointer, dimension(:,:,:) :: T_bc_tend => NULL() !< The layer temperature tendency due + !! to bias adjustment [C T-1 ~> degC s-1] + real, pointer, dimension(:,:,:) :: S_bc_tend => NULL() !< The layer salinity tendency due + !! to bias adjustment [S T-1 ~> ppt s-1] integer :: ni !< global i-direction grid size integer :: nj !< global j-direction grid size logical :: reentrant_x !< grid is reentrant in the x direction @@ -114,13 +124,13 @@ module MOM_oda_driver_mod logical :: use_basin_mask !< If true, use a basin file to delineate weakly coupled ocean basins logical :: do_bias_adjustment !< If true, use spatio-temporally varying climatological tendency !! adjustment for Temperature and Salinity - real :: bias_adjustment_multiplier !< A scaling for the bias adjustment + real :: bias_adjustment_multiplier !< A scaling for the bias adjustment [nondim] integer :: assim_method !< Method: NO_ASSIM,EAKF_ASSIM or OI_ASSIM integer :: ensemble_size !< Size of the ensemble integer :: ensemble_id = 0 !< id of the current ensemble member integer, pointer, dimension(:,:) :: ensemble_pelist !< PE list for ensemble members integer, pointer, dimension(:) :: filter_pelist !< PE list for ensemble members - integer :: assim_frequency !< analysis interval in hours + real :: assim_interval !< analysis interval [T ~> s] ! Profiles local to the analysis domain type(ocean_profile_type), pointer :: Profiles => NULL() !< pointer to linked list of all available profiles type(ocean_profile_type), pointer :: CProfiles => NULL()!< pointer to linked list of current profiles @@ -134,6 +144,11 @@ module MOM_oda_driver_mod type(INC_CS) :: INC_CS !< A Structure containing integer file handles for bias adjustment integer :: id_inc_t !< A diagnostic handle for the temperature climatological adjustment integer :: id_inc_s !< A diagnostic handle for the salinity climatological adjustment + integer :: answer_date !< The vintage of the order of arithmetic and expressions in the + !! remapping invoked by the ODA driver. Values below 20190101 recover + !! the answers from the end of 2018, while higher values use updated + !! and more robust forms of the same expressions. + logical :: reproduce_2018_nmme !< true if reproducing older NMME answers. end type ODA_CS @@ -146,11 +161,12 @@ module MOM_oda_driver_mod !> initialize First_guess (prior) and Analysis grid !! information for all ensemble members -subroutine init_oda(Time, G, GV, diag_CS, CS) +subroutine init_oda(Time, G, GV, US, diag_CS, CS) type(time_type), intent(in) :: Time !< The current model time. type(ocean_grid_type), pointer :: G !< domain and grid information for ocean model type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diag_ctrl), target, intent(inout) :: diag_CS !< A pointer to a diagnostic control structure type(ODA_CS), pointer, intent(inout) :: CS !< The DA control structure @@ -161,24 +177,22 @@ subroutine init_oda(Time, G, GV, diag_CS, CS) type(directories) :: dirs type(grid_type), pointer :: T_grid !< global tracer grid - real, dimension(:,:), allocatable :: global2D, global2D_old - real, dimension(:), allocatable :: lon1D, lat1D, glon1D, glat1D type(param_file_type) :: PF - integer :: n, m, k, i, j, nk - integer :: is,ie,js,je,isd,ied,jsd,jed - integer :: isg,ieg,jsg,jeg - integer :: idg_offset, jdg_offset - integer :: stdout_unit + integer :: n + integer :: isd, ied, jsd, jed + integer :: is_oda, ie_oda, js_oda, je_oda + integer :: isd_oda, ied_oda, jsd_oda, jed_oda integer, dimension(4) :: fld_sz character(len=32) :: assim_method - integer :: npes_pm, ens_info(6), ni, nj - character(len=128) :: mesg - character(len=32) :: fldnam + integer :: npes_pm, ens_info(6) character(len=30) :: coord_mode character(len=200) :: inputdir, basin_file - logical :: reentrant_x, reentrant_y, tripolar_N, symmetric + character(len=80) :: basin_var character(len=80) :: remap_scheme character(len=80) :: bias_correction_file, inc_file + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm + real :: h_neglect, h_neglect_edge ! small thicknesses [H ~> m or kg m-2] if (associated(CS)) call MOM_error(FATAL, 'Calling oda_init with associated control structure') allocate(CS) @@ -195,8 +209,15 @@ subroutine init_oda(Time, G, GV, diag_CS, CS) call get_param(PF, mdl, "ASSIM_METHOD", assim_method, & "String which determines the data assimilation method "//& "Valid methods are: \'EAKF\',\'OI\', and \'NO_ASSIM\'", default='NO_ASSIM') - call get_param(PF, mdl, "ASSIM_FREQUENCY", CS%assim_frequency, & - "data assimilation frequency in hours") + call get_param(PF, mdl, "ASSIM_INTERVAL", CS%assim_interval, & + "data assimilation update interval in hours",default=-1.0,units="hours",scale=3600.*US%s_to_T) + if (CS%assim_interval < 0.) then + call get_param(PF, mdl, "ASSIM_FREQUENCY", CS%assim_interval, & + "data assimilation update in hours. This parameter name will \n"//& + "be deprecated in the future. ASSIM_INTERVAL should be used instead.",default=-1.0, & + units="hours",scale=3600.*US%s_to_T) + endif + call get_param(PF, mdl, "USE_REGRIDDING", CS%use_ALE_algorithm , & "If True, use the ALE algorithm (regridding/remapping).\n"//& "If False, use the layered isopycnal algorithm.", default=.false. ) @@ -216,7 +237,7 @@ subroutine init_oda(Time, G, GV, diag_CS, CS) if (CS%do_bias_adjustment) then call get_param(PF, mdl, "TRACER_ADJUSTMENT_FACTOR", CS%bias_adjustment_multiplier, & "A multiplicative scaling factor for the climatological tracer tendency adjustment ", & - default=1.0) + units="nondim", default=1.0) endif call get_param(PF, mdl, "USE_BASIN_MASK", CS%use_basin_mask, & "If true, add a basin mask to delineate weakly connected "//& @@ -232,9 +253,24 @@ subroutine init_oda(Time, G, GV, 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, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(PF, mdl, "ODA_ANSWER_DATE", CS%answer_date, & + "The vintage of the order of arithmetic and expressions used by the ODA driver "//& + "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) + + call get_param(PF, mdl, "REPRODUCE_2018_NMME_ANSWERS", CS%reproduce_2018_nmme, & + "Logical flag needed to reproduce older NMME forecast answers. "//& + "True gives old answers, the default of false gives different answers.", & + default=.false.) + inputdir = slasher(inputdir) select case(lowercase(trim(assim_method))) @@ -271,7 +307,7 @@ subroutine init_oda(Time, G, GV, diag_CS, CS) CS%G => G allocate(CS%Grid) ! params NIHALO_ODA, NJHALO_ODA set the DA halo size - call MOM_domains_init(CS%Grid%Domain,PF,param_suffix='_ODA') + call MOM_domains_init(CS%Grid%Domain, PF, param_suffix='_ODA', US=CS%US) allocate(HI) call hor_index_init(CS%Grid%Domain, HI, PF) call verticalGridInit( PF, CS%GV, CS%US ) @@ -280,9 +316,8 @@ subroutine init_oda(Time, G, GV, diag_CS, CS) call clone_MOM_domain(CS%Grid%Domain, dG%Domain,symmetric=.false.) call set_grid_metrics(dG, PF, CS%US) call MOM_initialize_topography(dG%bathyT, dG%max_depth, dG, PF, CS%US) - call MOM_initialize_coord(CS%GV, CS%US, PF, .false., & - dirs%output_directory, tv_dummy, dG%max_depth) - call ALE_init(PF, CS%GV, CS%US, dG%max_depth, CS%ALE_CS) + call MOM_initialize_coord(CS%GV, CS%US, PF, tv_dummy, dG%max_depth) + call ALE_init(PF, CS%G, CS%GV, CS%US, dG%max_depth, CS%ALE_CS) call MOM_grid_init(CS%Grid, PF, global_indexing=.false.) call ALE_updateVerticalGridType(CS%ALE_CS, CS%GV) call copy_dyngrid_to_MOM_grid(dG, CS%Grid, CS%US) @@ -301,25 +336,34 @@ subroutine init_oda(Time, G, GV, diag_CS, CS) call get_param(PF, 'oda_driver', "REGRIDDING_COORDINATE_MODE", coord_mode, & "Coordinate mode for vertical regridding.", & default="ZSTAR", fail_if_missing=.false.) - call initialize_regridding(CS%regridCS, CS%GV, CS%US, dG%max_depth,PF,'oda_driver',coord_mode,'','') - call initialize_remapping(CS%remapCS,remap_scheme) + 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%G, CS%GV, CS%US, dG%max_depth,PF,'oda_driver',coord_mode,'','') + + 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, answer_date=CS%answer_date) call set_regrid_params(CS%regridCS, min_thickness=0.) - isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ! breaking with the MOM6 convention and using global indices !call get_domain_extent(G%Domain,is,ie,js,je,isd,ied,jsd,jed,& ! isg,ieg,jsg,jeg,idg_offset,jdg_offset,symmetric) - !isd=isd+idg_offset; ied=ied+idg_offset ! using global indexing within the DA module - !jsd=jsd+jdg_offset; jed=jed+jdg_offset ! TODO: switch to local indexing? (mjh) + !isd = isd+idg_offset ; ied = ied+idg_offset ! using global indexing within the DA module + !jsd = jsd+jdg_offset ; jed = jed+jdg_offset ! TODO: switch to local indexing? (mjh) if (.not. associated(CS%h)) then allocate(CS%h(isd:ied,jsd:jed,CS%GV%ke), source=CS%GV%Angstrom_H) ! assign thicknesses call ALE_initThicknessToCoord(CS%ALE_CS, G, CS%GV, CS%h) endif - allocate(CS%tv) - allocate(CS%tv%T(isd:ied,jsd:jed,CS%GV%ke), source=0.0) - allocate(CS%tv%S(isd:ied,jsd:jed,CS%GV%ke), source=0.0) + + allocate(CS%T_tend(isd:ied,jsd:jed,CS%GV%ke), source=0.0) + allocate(CS%S_tend(isd:ied,jsd:jed,CS%GV%ke), source=0.0) ! call set_axes_info(CS%Grid, CS%GV, CS%US, PF, CS%diag_cs, set_vertical=.true.) ! missing in Feiyu's fork allocate(CS%oda_grid) CS%oda_grid%x => CS%Grid%geolonT @@ -328,54 +372,57 @@ subroutine init_oda(Time, G, GV, diag_CS, CS) if (CS%use_basin_mask) then call get_param(PF, 'oda_driver', "BASIN_FILE", basin_file, & - "A file in which to find the basin masks, in variable 'basin'.", & - default="basin.nc") + "A file in which to find the basin masks.", default="basin.nc") basin_file = trim(inputdir) // trim(basin_file) - allocate(CS%oda_grid%basin_mask(isd:ied,jsd:jed), source=0.0) - call MOM_read_data(basin_file,'basin',CS%oda_grid%basin_mask,CS%Grid%domain, timelevel=1) + call get_param(PF, 'oda_driver', "BASIN_VAR", basin_var, & + "The basin mask variable in BASIN_FILE.", default="basin") + ! Need different data domain indices for the ODA ensemble basin mask. + call get_domain_extent(CS%Grid%Domain, is_oda, ie_oda, js_oda, je_oda, isd_oda, ied_oda, jsd_oda, jed_oda) + allocate(CS%oda_grid%basin_mask(isd_oda:ied_oda,jsd_oda:jed_oda), source=0.0) + call MOM_read_data(basin_file, basin_var, CS%oda_grid%basin_mask, CS%Grid%domain, timelevel=1) endif ! set up diag variables for analysis increments CS%diag_CS => diag_CS - CS%id_inc_t=register_diag_field('ocean_model','temp_increment',diag_CS%axesTL,& - Time,'ocean potential temperature increments','degC') - CS%id_inc_s=register_diag_field('ocean_model','salt_increment',diag_CS%axesTL,& - Time,'ocean salinity increments','psu') + CS%id_inc_t = register_diag_field('ocean_model', 'temp_increment', diag_CS%axesTL, & + Time, 'ocean potential temperature increments', 'degC', conversion=US%C_to_degC) + CS%id_inc_s = register_diag_field('ocean_model', 'salt_increment', diag_CS%axesTL, & + Time, 'ocean salinity increments', 'psu', conversion=US%S_to_ppt) !! get global grid information from ocean model needed for ODA initialization - T_grid=>NULL() + T_grid => NULL() call set_up_global_tgrid(T_grid, CS, G) call ocean_da_core_init(CS%mpp_domain, T_grid, CS%Profiles, Time) deallocate(T_grid) - CS%Time=Time + CS%Time = Time !! switch back to ensemble member pelist call set_PElist(CS%ensemble_pelist(CS%ensemble_id,:)) if (CS%do_bias_adjustment) then - call get_param(PF, mdl, "TEMP_SALT_ADJUSTMENT_FILE", bias_correction_file, & - "The name of the file containing temperature and salinity "//& - "tendency adjustments", default='temp_salt_adjustment.nc') + call get_param(PF, mdl, "TEMP_SALT_ADJUSTMENT_FILE", bias_correction_file, & + "The name of the file containing temperature and salinity "//& + "tendency adjustments", default='temp_salt_adjustment.nc') - inc_file = trim(inputdir) // trim(bias_correction_file) - CS%INC_CS%T_id = init_extern_field(inc_file, "temp_increment", & + inc_file = trim(inputdir) // trim(bias_correction_file) + CS%INC_CS%T = init_extern_field(inc_file, "temp_increment", & correct_leap_year_inconsistency=.true.,verbose=.true.,domain=G%Domain%mpp_domain) - CS%INC_CS%S_id = init_extern_field(inc_file, "salt_increment", & + CS%INC_CS%S = init_extern_field(inc_file, "salt_increment", & correct_leap_year_inconsistency=.true.,verbose=.true.,domain=G%Domain%mpp_domain) - call get_external_field_info(CS%INC_CS%T_id,size=fld_sz) - CS%INC_CS%fldno = 2 - if (CS%nk .ne. fld_sz(3)) call MOM_error(FATAL,'Increment levels /= ODA levels') - allocate(CS%tv_bc) ! storage for increment - allocate(CS%tv_bc%T(G%isd:G%ied,G%jsd:G%jed,CS%GV%ke), source=0.0) - allocate(CS%tv_bc%S(G%isd:G%ied,G%jsd:G%jed,CS%GV%ke), source=0.0) + call get_external_field_info(CS%INC_CS%T, size=fld_sz) + CS%INC_CS%fldno = 2 + if (CS%nk /= fld_sz(3)) call MOM_error(FATAL,'Increment levels /= ODA levels') + + allocate(CS%T_bc_tend(G%isd:G%ied,G%jsd:G%jed,CS%GV%ke), source=0.0) + allocate(CS%S_bc_tend(G%isd:G%ied,G%jsd:G%jed,CS%GV%ke), source=0.0) endif call cpu_clock_end(id_clock_oda_init) ! if (CS%write_obs) then -! temp_fid = open_profile_file("temp_"//trim(obs_file)) -! salt_fid = open_profile_file("salt_"//trim(obs_file)) -! end if +! temp_fid = open_profile_file("temp_"//trim(obs_file)) +! salt_fid = open_profile_file("salt_"//trim(obs_file)) +! endif end subroutine init_oda @@ -388,15 +435,10 @@ subroutine set_prior_tracer(Time, G, GV, h, tv, CS) type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables type(ODA_CS), pointer :: CS !< ocean DA control structure - real, dimension(SZI_(G),SZJ_(G),CS%nk) :: T, S - type(ocean_grid_type), pointer :: Grid=>NULL() - integer :: i,j, m, n, ss - integer :: is, ie, js, je + real, dimension(SZI_(G),SZJ_(G),CS%nk) :: T ! Temperature on the analysis grid [C ~> degC] + 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 - integer :: isd, ied, jsd, jed - integer :: isg, ieg, jsg, jeg, idg_offset, jdg_offset - integer :: id - logical :: used, symmetric ! return if not time for analysis if (Time < CS%Time) return @@ -409,16 +451,16 @@ subroutine set_prior_tracer(Time, G, GV, h, tv, CS) !call MOM_mesg('Setting prior') ! computational domain for the analysis grid - isc=CS%Grid%isc;iec=CS%Grid%iec;jsc=CS%Grid%jsc;jec=CS%Grid%jec + isc = CS%Grid%isc ; iec = CS%Grid%iec ; jsc = CS%Grid%jsc ; jec = CS%Grid%jec ! array extents for the ensemble member !call get_domain_extent(CS%domains(CS%ensemble_id),is,ie,js,je,isd,ied,jsd,jed,& ! isg,ieg,jsg,jeg,idg_offset,jdg_offset,symmetric) ! 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,:)) + 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,:)) + CS%nk, CS%h(i,j,:), S(i,j,:)) enddo ; enddo ! cast ensemble members to the analysis domain do m=1,CS%ensemble_size @@ -442,63 +484,59 @@ end subroutine set_prior_tracer !> Returns posterior adjustments or full state !!Note that only those PEs associated with an ensemble member receive data -subroutine get_posterior_tracer(Time, CS, h, tv, increment) +subroutine get_posterior_tracer(Time, CS, increment) type(time_type), intent(in) :: Time !< the current model time type(ODA_CS), pointer :: CS !< ocean DA control structure - real, dimension(:,:,:), pointer, optional :: h !< Layer thicknesses [H ~> m or kg m-2] - type(thermo_var_ptrs), pointer, optional :: tv !< A structure pointing to various thermodynamic variables logical, optional, intent(in) :: increment !< True if returning increment only type(ocean_control_struct), pointer :: Ocean_increment=>NULL() - integer :: i, j, m - logical :: used, get_inc - integer :: seconds_per_hour = 3600. + integer :: m + logical :: get_inc + ! return if not analysis time (retain pointers for h and tv) - if (Time < CS%Time .or. CS%assim_method .eq. NO_ASSIM) return + if (Time < CS%Time .or. CS%assim_method == NO_ASSIM) return !! switch to global pelist call set_PElist(CS%filter_pelist) call MOM_mesg('Getting posterior') - if (present(h)) h => CS%h ! get analysis thickness + !! Calculate and redistribute increments to CS%tv right after assimilation !! Retain CS%tv to calculate increments for IAU updates CS%tv_inc otherwise get_inc = .true. if (present(increment)) get_inc = increment if (get_inc) then - allocate(Ocean_increment) - Ocean_increment%T = CS%Ocean_posterior%T - CS%Ocean_prior%T - Ocean_increment%S = CS%Ocean_posterior%S - CS%Ocean_prior%S + CS%Ocean_increment%T = CS%Ocean_posterior%T - CS%Ocean_prior%T + CS%Ocean_increment%S = CS%Ocean_posterior%S - CS%Ocean_prior%S endif + ! It may be necessary to check whether the increment and ocean state have the + ! same dimensionally rescaled units. do m=1,CS%ensemble_size if (get_inc) then - call redistribute_array(CS%mpp_domain, Ocean_increment%T(:,:,:,m),& - CS%domains(m)%mpp_domain, CS%tv%T, complete=.true.) - call redistribute_array(CS%mpp_domain, Ocean_increment%S(:,:,:,m),& - CS%domains(m)%mpp_domain, CS%tv%S, complete=.true.) + call redistribute_array(CS%mpp_domain, CS%Ocean_increment%T(:,:,:,m),& + CS%domains(m)%mpp_domain, CS%T_tend, complete=.true.) + call redistribute_array(CS%mpp_domain, CS%Ocean_increment%S(:,:,:,m),& + CS%domains(m)%mpp_domain, CS%S_tend, complete=.true.) else call redistribute_array(CS%mpp_domain, CS%Ocean_posterior%T(:,:,:,m),& - CS%domains(m)%mpp_domain, CS%tv%T, complete=.true.) + CS%domains(m)%mpp_domain, CS%T_tend, complete=.true.) call redistribute_array(CS%mpp_domain, CS%Ocean_posterior%S(:,:,:,m),& - CS%domains(m)%mpp_domain, CS%tv%S, complete=.true.) + CS%domains(m)%mpp_domain, CS%S_tend, complete=.true.) endif enddo - if (present(tv)) tv => CS%tv - if (present(h)) h => CS%h - !! switch back to ensemble member pelist call set_PElist(CS%ensemble_pelist(CS%ensemble_id,:)) - call pass_var(CS%tv%T,CS%domains(CS%ensemble_id)) - call pass_var(CS%tv%S,CS%domains(CS%ensemble_id)) + call pass_var(CS%T_tend,CS%domains(CS%ensemble_id)) + call pass_var(CS%S_tend,CS%domains(CS%ensemble_id)) !convert to a tendency (degC or PSU per second) - CS%tv%T = CS%tv%T / (CS%assim_frequency * seconds_per_hour) - CS%tv%S = CS%tv%S / (CS%assim_frequency * seconds_per_hour) + CS%T_tend = CS%T_tend / (CS%assim_interval) + CS%S_tend = CS%S_tend / (CS%assim_interval) end subroutine get_posterior_tracer @@ -508,10 +546,6 @@ subroutine oda(Time, CS) type(time_type), intent(in) :: Time !< the current model time type(oda_CS), pointer :: CS !< A pointer the ocean DA control structure - integer :: i, j - integer :: m - integer :: yr, mon, day, hr, min, sec - if ( Time >= CS%Time ) then !! switch to global pelist @@ -523,51 +557,74 @@ subroutine oda(Time, CS) !! switch back to ensemble member pelist call set_PElist(CS%ensemble_pelist(CS%ensemble_id,:)) call get_posterior_tracer(Time, CS, increment=.true.) - if (CS%do_bias_adjustment) call get_bias_correction_tracer(Time, CS) + if (CS%do_bias_adjustment) call get_bias_correction_tracer(Time, CS%US, CS) endif return end subroutine oda -subroutine get_bias_correction_tracer(Time, CS) - type(time_type), intent(in) :: Time !< the current model time - type(ODA_CS), pointer :: CS !< ocean DA control structure - - integer :: i,j,k - real, allocatable, dimension(:,:,:) :: T_bias, S_bias - real, allocatable, dimension(:,:,:) :: mask_z - real, allocatable, dimension(:), target :: z_in, z_edges_in - real :: missing_value - integer,dimension(3) :: fld_sz - - call cpu_clock_begin(id_clock_bias_adjustment) - call horiz_interp_and_extrap_tracer(CS%INC_CS%T_id,Time,1.0,CS%G,T_bias,& - mask_z,z_in,z_edges_in,missing_value,.true.,.false.,.false.,.true.) - call horiz_interp_and_extrap_tracer(CS%INC_CS%S_id,Time,1.0,CS%G,S_bias,& - mask_z,z_in,z_edges_in,missing_value,.true.,.false.,.false.,.true.) - - ! This should be replaced to use mask_z instead of the following lines - ! which are intended to zero land values using an arbitrary limit. - fld_sz=shape(T_bias) +subroutine get_bias_correction_tracer(Time, US, CS) + type(time_type), intent(in) :: Time !< the current model time + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(ODA_CS), pointer :: CS !< ocean DA control structure + + ! Local variables + real, allocatable, dimension(:,:,:) :: T_bias ! Estimated temperature tendency bias [C T-1 ~> degC s-1] + real, allocatable, dimension(:,:,:) :: S_bias ! Estimated salinity tendency bias [S T-1 ~> ppt s-1] + real, allocatable, dimension(:,:,:) :: valid_flag ! Valid value flag on the horizontal model grid + ! and input-file vertical levels [nondim] + real, allocatable, dimension(:), target :: z_in ! Cell center depths for input data [Z ~> m] + real, allocatable, dimension(:), target :: z_edges_in ! Cell edge depths for input data [Z ~> m] + real :: missing_value ! A value indicating that there is no valid input data at this point [CU ~> conc] + integer, dimension(3) :: fld_sz + integer :: i,j,k + + + call cpu_clock_begin(id_clock_bias_adjustment) + call horiz_interp_and_extrap_tracer(CS%INC_CS%T, Time, CS%G, T_bias, & + valid_flag, z_in, z_edges_in, missing_value, scale=US%degC_to_C*US%s_to_T, spongeOngrid=.true., & + answer_date=CS%answer_date) + call horiz_interp_and_extrap_tracer(CS%INC_CS%S, Time, CS%G, S_bias, & + valid_flag, z_in, z_edges_in, missing_value, scale=US%ppt_to_S*US%s_to_T, spongeOngrid=.true., & + answer_date=CS%answer_date) + + ! This should be replaced to use mask_z instead of the following lines + ! which are intended to zero land values using an arbitrary limit. + fld_sz=shape(T_bias) + if (CS%reproduce_2018_nmme) then do i=1,fld_sz(1) - do j=1,fld_sz(2) - do k=1,fld_sz(3) - if (T_bias(i,j,k) .gt. 1.0E-3) T_bias(i,j,k) = 0.0 - if (S_bias(i,j,k) .gt. 1.0E-3) S_bias(i,j,k) = 0.0 - enddo - enddo + do j=1,fld_sz(2) + do k=1,fld_sz(3) + ! The following two lines are needed for backward compatibility for NMME answers (2018 vintage) + ! These were implemented to catch missing values, so large values are excluded. + if (T_bias(i,j,k) > 1.0E-3*US%degC_to_C) T_bias(i,j,k) = 0.0 + if (S_bias(i,j,k) > 1.0E-3*US%ppt_to_S) S_bias(i,j,k) = 0.0 + enddo + enddo enddo + else + do i=1,fld_sz(1) + do j=1,fld_sz(2) + do k=1,fld_sz(3) + if (valid_flag(i,j,k)==0.) then + T_bias(i,j,k)=0.0 + S_bias(i,j,k)=0.0 + endif + enddo + enddo + enddo + endif - CS%tv_bc%T = T_bias * CS%bias_adjustment_multiplier - CS%tv_bc%S = S_bias * CS%bias_adjustment_multiplier + CS%T_bc_tend = T_bias * CS%bias_adjustment_multiplier + CS%S_bc_tend = S_bias * CS%bias_adjustment_multiplier - call pass_var(CS%tv_bc%T, CS%domains(CS%ensemble_id)) - call pass_var(CS%tv_bc%S, CS%domains(CS%ensemble_id)) + call pass_var(CS%T_bc_tend, CS%domains(CS%ensemble_id)) + call pass_var(CS%S_bc_tend, CS%domains(CS%ensemble_id)) - call cpu_clock_end(id_clock_bias_adjustment) + call cpu_clock_end(id_clock_bias_adjustment) - end subroutine get_bias_correction_tracer +end subroutine get_bias_correction_tracer !> Finalize DA module subroutine oda_end(CS) @@ -576,18 +633,18 @@ subroutine oda_end(CS) end subroutine oda_end !> Initialize DA module -subroutine init_ocean_ensemble(CS,Grid,GV,ens_size) +subroutine init_ocean_ensemble(CS, Grid, GV, ens_size) type(ocean_control_struct), pointer :: CS !< Pointer to ODA control structure type(ocean_grid_type), pointer :: Grid !< Pointer to ocean analysis grid type(verticalGrid_type), pointer :: GV !< Pointer to DA vertical grid integer, intent(in) :: ens_size !< ensemble size - integer :: n,is,ie,js,je,nk + integer :: is, ie, js, je, nk - nk=GV%ke - is=Grid%isd;ie=Grid%ied - js=Grid%jsd;je=Grid%jed - CS%ensemble_size=ens_size + nk = GV%ke + is = Grid%isd ; ie = Grid%ied + js = Grid%jsd ; je = Grid%jed + CS%ensemble_size = ens_size allocate(CS%T(is:ie,js:je,nk,ens_size)) allocate(CS%S(is:ie,js:je,nk,ens_size)) allocate(CS%SSH(is:ie,js:je,ens_size)) @@ -603,7 +660,7 @@ subroutine init_ocean_ensemble(CS,Grid,GV,ens_size) end subroutine init_ocean_ensemble !> Set the next analysis time -subroutine set_analysis_time(Time,CS) +subroutine set_analysis_time(Time, CS) type(time_type), intent(in) :: Time !< the current model time type(ODA_CS), pointer, intent(inout) :: CS !< the DA control structure @@ -611,8 +668,8 @@ subroutine set_analysis_time(Time,CS) integer :: yr, mon, day, hr, min, sec if (Time >= CS%Time) then - ! increment the analysis time to the next step converting to seconds - CS%Time = CS%Time + real_to_time(CS%US%T_to_s*(CS%assim_frequency*3600.)) + ! increment the analysis time to the next step + CS%Time = CS%Time + real_to_time(CS%assim_interval, unscale=CS%US%T_to_s) call get_date(Time, yr, mon, day, hr, min, sec) write(mesg,*) 'Model Time: ', yr, mon, day, hr, min, sec @@ -633,7 +690,7 @@ end subroutine set_analysis_time !> Apply increments to tracers subroutine apply_oda_tracer_increments(dt, Time_end, G, GV, tv, h, CS) - real, intent(in) :: dt !< The tracer timestep [s] + real, intent(in) :: dt !< The tracer timestep [T ~> s] type(time_type), intent(in) :: Time_end !< Time at the end of the interval type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -643,53 +700,53 @@ subroutine apply_oda_tracer_increments(dt, Time_end, G, GV, tv, h, CS) type(ODA_CS), pointer :: CS !< the data assimilation structure !! local variables - integer :: yr, mon, day, hr, min, sec - integer :: i, j, k + integer :: i, j integer :: isc, iec, jsc, jec - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: T_inc !< an adjustment to the temperature - !! tendency [degC T-1 -> degC s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: S_inc !< an adjustment to the salinity - !! tendency [g kg-1 T-1 -> g kg-1 s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(CS%Grid)) :: T !< The updated temperature [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(CS%Grid)) :: S !< The updated salinity [g kg-1] - real :: missing_value + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: T_tend_inc !< an adjustment to the temperature + !! tendency [C T-1 ~> degC s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: S_tend_inc !< an adjustment to the salinity + !! tendency [S T-1 ~> ppt s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(CS%Grid)) :: T_tend !< The temperature tendency adjustment from + !! 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] if (.not. associated(CS)) return - if (CS%assim_method .eq. NO_ASSIM .and. (.not. CS%do_bias_adjustment)) return + if (CS%assim_method == NO_ASSIM .and. (.not. CS%do_bias_adjustment)) return call cpu_clock_begin(id_clock_apply_increments) - T_inc(:,:,:) = 0.0; S_inc(:,:,:) = 0.0; T(:,:,:) = 0.0; S(:,:,:) = 0.0 + T_tend_inc(:,:,:) = 0.0 ; S_tend_inc(:,:,:) = 0.0 ; T_tend(:,:,:) = 0.0 ; S_tend(:,:,:) = 0.0 if (CS%assim_method > 0 ) then - T = T + CS%tv%T - S = S + CS%tv%S + T_tend = T_tend + CS%T_tend + S_tend = S_tend + CS%S_tend endif if (CS%do_bias_adjustment ) then - T = T + CS%tv_bc%T - S = S + CS%tv_bc%S + T_tend = T_tend + CS%T_bc_tend + S_tend = S_tend + CS%S_bc_tend 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(i,j,:), & - G%ke, h(i,j,:), T_inc(i,j,:)) - call remapping_core_h(CS%remapCS, CS%nk, CS%h(i,j,:), S(i,j,:), & - G%ke, h(i,j,:), S_inc(i,j,:)) - enddo; enddo + 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,:)) + 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,:)) + enddo ; enddo - call pass_var(T_inc, G%Domain) - call pass_var(S_inc, G%Domain) + call pass_var(T_tend_inc, G%Domain) + call pass_var(S_tend_inc, G%Domain) - tv%T(isc:iec,jsc:jec,:)=tv%T(isc:iec,jsc:jec,:)+T_inc(isc:iec,jsc:jec,:)*dt - tv%S(isc:iec,jsc:jec,:)=tv%S(isc:iec,jsc:jec,:)+S_inc(isc:iec,jsc:jec,:)*dt + tv%T(isc:iec,jsc:jec,:) = tv%T(isc:iec,jsc:jec,:) + T_tend_inc(isc:iec,jsc:jec,:)*dt + tv%S(isc:iec,jsc:jec,:) = tv%S(isc:iec,jsc:jec,:) + S_tend_inc(isc:iec,jsc:jec,:)*dt call pass_var(tv%T, G%Domain) call pass_var(tv%S, G%Domain) call enable_averaging(dt, Time_end, CS%diag_CS) - if (CS%id_inc_t > 0) call post_data(CS%id_inc_t, T_inc, CS%diag_CS) - if (CS%id_inc_s > 0) call post_data(CS%id_inc_s, S_inc, CS%diag_CS) + if (CS%id_inc_t > 0) call post_data(CS%id_inc_t, T_tend_inc, CS%diag_CS) + if (CS%id_inc_s > 0) call post_data(CS%id_inc_s, S_tend_inc, CS%diag_CS) call disable_averaging(CS%diag_CS) call diag_update_remap_grids(CS%diag_CS) @@ -698,13 +755,17 @@ subroutine apply_oda_tracer_increments(dt, Time_end, G, GV, tv, h, CS) end subroutine apply_oda_tracer_increments +!> Set up the grid of thicknesses at tracer points throughout the global domain subroutine set_up_global_tgrid(T_grid, CS, G) type(grid_type), pointer :: T_grid !< global tracer grid type(ODA_CS), pointer, intent(in) :: CS !< A pointer to DA control structure. type(ocean_grid_type), pointer :: G !< domain and grid information for ocean model ! local variables - real, dimension(:,:), allocatable :: global2D, global2D_old + real, dimension(:,:), allocatable :: & + global2D, & ! A layer thickness in the entire global domain [H ~> m or kg m-2] + global2D_old ! The thickness of the layer above the one in global2D in the entire + ! global domain [H ~> m or kg m-2] integer :: i, j, k ! get global grid information from ocean_model @@ -733,10 +794,12 @@ subroutine set_up_global_tgrid(T_grid, CS, G) do k = 1, CS%nk call global_field(G%Domain%mpp_domain, CS%h(:,:,k), global2D) do i=1,CS%ni ; do j=1,CS%nj + ! ###Does the next line need to be revised? Perhaps it should be + ! if ( global2D(i,j) > 1.0*GV%H_to_m ) then if ( global2D(i,j) > 1 ) then T_grid%mask(i,j,k) = 1.0 endif - enddo; enddo + enddo ; enddo if (k == 1) then T_grid%z(:,:,k) = global2D/2 else diff --git a/src/ocean_data_assim/MOM_oda_incupd.F90 b/src/ocean_data_assim/MOM_oda_incupd.F90 index ab3621296f..e0823999ef 100644 --- a/src/ocean_data_assim/MOM_oda_incupd.F90 +++ b/src/ocean_data_assim/MOM_oda_incupd.F90 @@ -1,6 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> This module contains the routines used to apply incremental updates !! from data assimilation. -!! +! !! Applying incremental updates requires the following: !! 1. initialize_oda_incupd_fixed and initialize_oda_incupd !! 2. set_up_oda_incupd_field (tracers) and set_up_oda_incupd_vel_field (vel) @@ -13,7 +17,6 @@ module MOM_oda_incupd -! This file is part of MOM6. See LICENSE.md for the license. use MOM_array_transform, only : rotate_array use MOM_coms, only : sum_across_PEs use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field @@ -25,6 +28,7 @@ module MOM_oda_incupd use MOM_grid, only : ocean_grid_type use MOM_io, only : vardesc, var_desc use MOM_remapping, only : remapping_cs, remapping_core_h, initialize_remapping +use MOM_remapping, only : remappingSchemesDoc use MOM_restart, only : register_restart_field, register_restart_pair, MOM_restart_CS use MOM_restart, only : restart_init, save_restart, query_initialized use MOM_spatial_means, only : global_i_mean @@ -52,9 +56,11 @@ module MOM_oda_incupd type :: p3d integer :: id !< id for FMS external time interpolator integer :: nz_data !< The number of vertical levels in the input field. - real, dimension(:,:,:), pointer :: mask_in => NULL() !< pointer to the data mask. - real, dimension(:,:,:), pointer :: p => NULL() !< pointer to the data. - real, dimension(:,:,:), pointer :: h => NULL() !< pointer to the data grid. + real, dimension(:,:,:), pointer :: mask_in => NULL() !< pointer to the data mask (perhaps unused) [nondim] + real, dimension(:,:,:), pointer :: p => NULL() !< pointer to the data, in units that depend + !! on the field it refers to [various]. + real, dimension(:,:,:), pointer :: h => NULL() !< pointer to the data grid (perhaps unused) + !! in [H ~> m or kg m-2] end type p3d !> oda incupd control structure @@ -65,13 +71,14 @@ module MOM_oda_incupd !! registered by calls to set_up_oda_incupd_field type(p3d) :: Inc(MAX_FIELDS_) !< The increments to be applied to the field - type(p3d) :: Inc_u !< The increments to be applied to the u-velocities - type(p3d) :: Inc_v !< The increments to be applied to the v-velocities - type(p3d) :: Ref_h !< Vertical grid on which the increments are provided + type(p3d) :: Inc_u !< The increments to be applied to the u-velocities, with data in [L T-1 ~> m s-1] + type(p3d) :: Inc_v !< The increments to be applied to the v-velocities, with data in [L T-1 ~> m s-1] + type(p3d) :: Ref_h !< Vertical grid on which the increments are provided, with data in [H ~> m or kg m-2] integer :: nstep_incupd !< number of time step for full update - real :: ncount = 0.0 !< increment time step counter + real :: ncount = 0.0 !< increment time step counter [nondim]. This could be an integer + !! but a real variable works better with the existing restarts. type(remapping_cs) :: remap_cs !< Remapping parameters and work arrays logical :: incupdDataOngrid !< True if the incupd data are on the model horizontal grid logical :: uv_inc !< use u and v increments @@ -99,9 +106,6 @@ subroutine initialize_oda_incupd_fixed( G, GV, US, CS, restart_CS) !! structure for this module (in/out). type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=256) :: mesg if (associated(CS)) then call MOM_error(WARNING, "initialize_oda_incupd_fixed called with an associated "// & "control structure.") @@ -119,7 +123,7 @@ end subroutine initialize_oda_incupd_fixed !> This subroutine defined the number of time step for full update, stores the layer pressure !! increments and initialize remap structure. -subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h,nz_data, restart_CS) +subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, restart_CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -132,17 +136,20 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h,nz_data, res !! [H ~> m or kg m-2]. type(MOM_restart_CS), intent(in) :: restart_CS !< MOM restart control struct -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_oda" ! This module's name. logical :: use_oda_incupd logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries logical :: reset_ncount integer :: i, j, k - real :: nhours_incupd, dt, dt_therm - type(vardesc) :: vd + real :: incupd_timescale ! The amount of timer over which to apply the full update [T ~> s] + real :: dt, dt_therm ! Model timesteps [T ~> s] character(len=256) :: mesg - character(len=10) :: remapScheme + character(len=64) :: remapScheme + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm + real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] + if (.not.associated(CS)) then call MOM_error(WARNING, "initialize_oda_incupd called without an associated "// & "control structure.") @@ -157,9 +164,9 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h,nz_data, res if (.not.use_oda_incupd) return - call get_param(param_file, mdl, "ODA_INCUPD_NHOURS", nhours_incupd, & + call get_param(param_file, mdl, "ODA_INCUPD_NHOURS", incupd_timescale, & "Number of hours for full update (0=direct insertion).", & - default=3.0,units="h", scale=US%s_to_T) + default=3.0, units="h", scale=3600.0*US%s_to_T) call get_param(param_file, mdl, "ODA_INCUPD_RESET_NCOUNT", reset_ncount, & "If True, reinitialize number of updates already done, ncount.", & default=.true.) @@ -181,20 +188,29 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h,nz_data, res "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 @@ -203,15 +219,15 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h,nz_data, res 'The oda_incupd code only applies ODA increments on the same horizontal grid. ') ! get number of timestep for full update - if (nhours_incupd == 0) then - CS%nstep_incupd = 1 !! direct insertion + if (incupd_timescale == 0) then + CS%nstep_incupd = 1 !! direct insertion else - CS%nstep_incupd = floor( nhours_incupd * 3600. / dt_therm + 0.001 ) - 1 + CS%nstep_incupd = floor( incupd_timescale / dt_therm + 0.001 ) - 1 endif write(mesg,'(i12)') CS%nstep_incupd if (is_root_pe()) & - call MOM_error(NOTE,"initialize_oda_incupd: Number of Timestep of inc. update:"//& - trim(mesg)) + call MOM_error(NOTE, "initialize_oda_incupd: Number of Timestep of inc. update: "//& + trim(mesg)) ! number of inc. update already done, CS%ncount, either from restart or set to 0.0 if (query_initialized(CS%ncount, "oda_incupd_ncount", restart_CS) .and. & @@ -222,19 +238,28 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h,nz_data, res endif write(mesg,'(f4.1)') CS%ncount if (is_root_pe()) & - call MOM_error(NOTE,"initialize_oda_incupd: Inc. update already done:"//& - trim(mesg)) + call MOM_error(NOTE, "initialize_oda_incupd: Inc. update already done: "//& + trim(mesg)) ! get the vertical grid (h_obs) of the increments CS%nz_data = nz_data allocate(CS%Ref_h%p(G%isd:G%ied,G%jsd:G%jed,CS%nz_data), source=0.0) - do j=G%jsc,G%jec; do i=G%isc,G%iec ; do k=1,CS%nz_data - CS%Ref_h%p(i,j,k) = data_h(i,j,k) - enddo; enddo ; enddo + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; do k=1,CS%nz_data + CS%Ref_h%p(i,j,k) = data_h(i,j,k) + enddo ; enddo ; enddo + !### Doing a halo update here on CS%Ref_h%p would avoid needing halo updates each timestep. ! 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, & - answers_2018=.false.) + 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 @@ -245,8 +270,9 @@ subroutine set_up_oda_incupd_field(sp_val, G, GV, CS) type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(oda_incupd_CS), pointer :: CS !< oda_incupd control structure (in/out). real, dimension(SZI_(G),SZJ_(G),CS%nz_data), & - intent(in) :: sp_val !< increment field, it can have an - !! arbitrary number of layers. + intent(in) :: sp_val !< increment field, it can have an arbitrary number + !! of layers, in various units depending on the + !! field it refers to [various]. integer :: i, j, k character(len=256) :: mesg ! String for error messages @@ -255,7 +281,7 @@ subroutine set_up_oda_incupd_field(sp_val, G, GV, CS) CS%fldno = CS%fldno + 1 if (CS%fldno > MAX_FIELDS_) then - write(mesg,'("Increase MAX_FIELDS_ to at least ",I3," in MOM_memory.h or decrease & + write(mesg,'("Increase MAX_FIELDS_ to at least ",I0," in MOM_memory.h or decrease & &the number of fields increments in the call to & &initialize_oda_incupd." )') CS%fldno call MOM_error(FATAL,"set_up_oda_incupd_field: "//mesg) @@ -265,7 +291,7 @@ subroutine set_up_oda_incupd_field(sp_val, G, GV, CS) CS%Inc(CS%fldno)%nz_data = CS%nz_data allocate(CS%Inc(CS%fldno)%p(G%isd:G%ied,G%jsd:G%jed,CS%nz_data), source=0.0) do k=1,CS%nz_data ; do j=G%jsc,G%jec ; do i=G%isc,G%iec - CS%Inc(CS%fldno)%p(i,j,k) = sp_val(i,j,k) + CS%Inc(CS%fldno)%p(i,j,k) = sp_val(i,j,k) enddo ; enddo ; enddo end subroutine set_up_oda_incupd_field @@ -327,19 +353,20 @@ subroutine calc_oda_increments(h, tv, u, v, G, GV, US, CS) !! that is set by a previous call to initialize_oda_incupd (in). - real, dimension(SZK_(GV)) :: tmp_val1 ! data values on the model grid - real, allocatable, dimension(:) :: tmp_val2 ! data values remapped to increment grid - real, allocatable, dimension(:,:,:) :: h_obs !< h of increments - real, allocatable, dimension(:) :: tmp_h ! temporary array for corrected h_obs - real, allocatable, dimension(:) :: hu_obs,hv_obs ! A column of thicknesses at h points [H ~> m or kg m-2] - real, dimension(SZK_(GV)) :: hu, hv ! A column of thicknesses at h, u or v points [H ~> m or kg m-2] + real, dimension(SZK_(GV)) :: tmp_val1 ! data values on the model grid, in rescaled units + ! like [S ~> ppt] for salinity. + real, allocatable, dimension(:) :: tmp_val2 ! data values remapped to increment grid, in rescaled units + ! like [S ~> ppt] for salinity. + real, allocatable, dimension(:,:,:) :: h_obs !< Layer-thicknesses of increments [H ~> m or kg m-2] + real, allocatable, dimension(:) :: tmp_h ! temporary array for corrected h_obs [H ~> m or kg m-2] + real, allocatable, dimension(:) :: hu_obs ! A column of observation-grid thicknesses at u points [H ~> m or kg m-2] + real, allocatable, dimension(:) :: hv_obs ! A column of observation-grid thicknesses at v points [H ~> m or kg m-2] + real, dimension(SZK_(GV)) :: hu, hv ! A column of thicknesses at u or v points [H ~> m or kg m-2] integer :: i, j, k, is, ie, js, je, nz, nz_data integer :: isB, ieB, jsB, jeB - real :: h_neglect, h_neglect_edge - real :: sum_h1, sum_h2 !vertical sums of h's - character(len=256) :: mesg + 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 isB = G%iscB ; ieB = G%iecB ; jsB = G%jscB ; jeB = G%jecB @@ -350,13 +377,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) @@ -375,122 +395,118 @@ subroutine calc_oda_increments(h, tv, u, v, G, GV, US, CS) ! remap t,s (on h_init) to h_obs to get increment tmp_val1(:) = 0.0 do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) == 1) then + if (G%mask2dT(i,j) == 1) then + ! account for the different SSH + sum_h1 = 0.0 + sum_h2 = 0.0 + do k=1,nz + sum_h1 = sum_h1+h(i,j,k) + enddo + + do k=1,nz_data + sum_h2 = sum_h2+h_obs(i,j,k) + enddo + do k=1,nz_data + tmp_h(k)=(sum_h1/sum_h2)*h_obs(i,j,k) + enddo + ! get temperature + do k=1,nz + tmp_val1(k) = tv%T(i,j,k) + 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) + ! 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) + enddo + + ! get salinity + do k=1,nz + tmp_val1(k) = tv%S(i,j,k) + 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) + ! 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) + enddo + endif + enddo ; enddo + + ! remap u to h_obs to get increment + if (CS%uv_inc) then + call pass_var(h, G%Domain) + + hu(:) = 0.0 + do j=js,je ; do i=isB,ieB + if (G%mask2dCu(i,j) == 1) then + ! get u-velocity + do k=1,nz + tmp_val1(k) = u(i,j,k) + ! get the h and h_obs at u points + hu(k) = 0.5*( h(i,j,k)+ h(i+1,j,k)) + enddo + do k=1,nz_data + hu_obs(k) = 0.5*(h_obs(i,j,k)+h_obs(i+1,j,k)) + enddo ! account for the different SSH sum_h1 = 0.0 - sum_h2 = 0.0 do k=1,nz - sum_h1 = sum_h1+h(i,j,k) + sum_h1 = sum_h1+hu(k) enddo - + sum_h2 = 0.0 do k=1,nz_data - sum_h2 = sum_h2+h_obs(i,j,k) + sum_h2 = sum_h2+hu_obs(k) enddo do k=1,nz_data - tmp_h(k)=(sum_h1/sum_h2)*h_obs(i,j,k) + hu_obs(k)=(sum_h1/sum_h2)*hu_obs(k) enddo - ! get temperature + ! 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) + ! 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) + enddo + endif + enddo ; enddo + + ! remap v to h_obs to get increment + hv(:) = 0.0 + do j=jsB,jeB ; do i=is,ie + if (G%mask2dCv(i,j) == 1) then + ! get v-velocity do k=1,nz - tmp_val1(k) = tv%T(i,j,k) + tmp_val1(k) = v(i,j,k) + ! get the h and h_obs at v points + hv(k) = 0.5*(h(i,j,k)+h(i,j+1,k)) 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) - ! 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) + hv_obs(k) = 0.5*(h_obs(i,j,k)+h_obs(i,j+1,k)) enddo - - ! get salinity + ! account for the different SSH + sum_h1 = 0.0 do k=1,nz - tmp_val1(k) = tv%S(i,j,k) + sum_h1 = sum_h1+hv(k) 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) + sum_h2 = 0.0 + do k=1,nz_data + sum_h2 = sum_h2+hv_obs(k) + enddo + do k=1,nz_data + hv_obs(k)=(sum_h1/sum_h2)*hv_obs(k) + 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) ! 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) + CS%Inc_v%p(i,j,k) = CS%Inc_v%p(i,j,k) - tmp_val2(k) enddo - endif - enddo; enddo - - ! remap u to h_obs to get increment - if (CS%uv_inc) then - call pass_var(h, G%Domain) - - hu(:) = 0.0 - do j=js,je ; do i=isB,ieB - if (G%mask2dCu(i,j) == 1) then - ! get u-velocity - do k=1,nz - tmp_val1(k) = u(i,j,k) - ! get the h and h_obs at u points - hu(k) = 0.5*( h(i,j,k)+ h(i+1,j,k)) - enddo - do k=1,nz_data - hu_obs(k) = 0.5*(h_obs(i,j,k)+h_obs(i+1,j,k)) - enddo - ! account for the different SSH - sum_h1 = 0.0 - do k=1,nz - sum_h1 = sum_h1+hu(k) - enddo - sum_h2 = 0.0 - do k=1,nz_data - sum_h2 = sum_h2+hu_obs(k) - enddo - do k=1,nz_data - hu_obs(k)=(sum_h1/sum_h2)*hu_obs(k) - 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) - ! 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) - enddo - endif - enddo; enddo - - ! remap v to h_obs to get increment - hv(:) = 0.0; - do j=jsB,jeB ; do i=is,ie - if (G%mask2dCv(i,j) == 1) then - ! get v-velocity - do k=1,nz - tmp_val1(k) = v(i,j,k) - ! get the h and h_obs at v points - hv(k) = 0.5*(h(i,j,k)+h(i,j+1,k)) - enddo - do k=1,nz_data - hv_obs(k) = 0.5*(h_obs(i,j,k)+h_obs(i,j+1,k)) - enddo - ! account for the different SSH - sum_h1 = 0.0 - do k=1,nz - sum_h1 = sum_h1+hv(k) - enddo - sum_h2 = 0.0 - do k=1,nz_data - sum_h2 = sum_h2+hv_obs(k) - enddo - do k=1,nz_data - hv_obs(k)=(sum_h1/sum_h2)*hv_obs(k) - 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) - ! 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) - enddo - endif - enddo; enddo + endif + enddo ; enddo endif ! uv_inc call pass_var(CS%Inc(1)%p, G%Domain) @@ -524,26 +540,28 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) type(oda_incupd_CS), pointer :: CS !< A pointer to the control structure for this module !! that is set by a previous call to initialize_oda_incupd (in). - real :: m_to_Z ! A unit conversion factor from m to Z. - real, allocatable, dimension(:) :: tmp_val2 ! data values on the increment grid - real, dimension(SZK_(GV)) :: tmp_val1 ! data values remapped to model grid - real, dimension(SZK_(GV)) :: hu, hv ! A column of thicknesses at h, u or v points [H ~> m or kg m-2] + ! Local variables + real, allocatable, dimension(:) :: tmp_val2 ! data values remapped to increment grid, in rescaled units + ! like [S ~> ppt] for salinity. + real, dimension(SZK_(GV)) :: tmp_val1 ! data values on the model grid, in rescaled units + ! like [S ~> ppt] for salinity. + real, dimension(SZK_(GV)) :: hu, hv ! A column of thicknesses at u or v points [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tmp_t !< A temporary array for t inc. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tmp_s !< A temporary array for s inc. - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: tmp_u !< A temporary array for u inc. - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: tmp_v !< A temporary array for v inc. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tmp_t !< A temporary array for t increments [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tmp_s !< A temporary array for s increments [S ~> ppt] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: tmp_u !< A temporary array for u increments [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: tmp_v !< A temporary array for v increments [L T-1 ~> m s-1] - real, allocatable, dimension(:,:,:) :: h_obs !< h of increments - real, allocatable, dimension(:) :: tmp_h !< temporary array for corrected h_obs - real, allocatable, dimension(:) :: hu_obs,hv_obs ! A column of thicknesses at h points [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: h_obs !< h of increments [H ~> m or kg m-2] + real, allocatable, dimension(:) :: tmp_h !< temporary array for corrected h_obs [H ~> m or kg m-2] + real, allocatable, dimension(:) :: hu_obs ! A column of observation-grid thicknesses at u points [H ~> m or kg m-2] + real, allocatable, dimension(:) :: hv_obs ! A column of observation-grid thicknesses at v points [H ~> m or kg m-2] integer :: i, j, k, is, ie, js, je, nz, nz_data integer :: isB, ieB, jsB, jeB ! integer :: ncount ! time step counter - real :: inc_wt ! weight of the update for this time-step - real :: h_neglect, h_neglect_edge - real :: sum_h1, sum_h2 !vertical sums of h's + real :: inc_wt ! weight of the update for this time-step [nondim] + real :: sum_h1, sum_h2 ! vertical sums of h's [H ~> m or kg m-2] character(len=256) :: mesg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -566,12 +584,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) @@ -590,131 +602,131 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) tmp_val1(:) = 0.0 tmp_t(:,:,:) = 0.0 ; tmp_s(:,:,:) = 0.0 ! diagnostics do j=js,je ; do i=is,ie - ! account for the different SSH - sum_h1 = 0.0 - do k=1,nz - sum_h1 = sum_h1+h(i,j,k) - enddo - sum_h2 = 0.0 - do k=1,nz_data - sum_h2 = sum_h2+h_obs(i,j,k) - enddo - do k=1,nz_data - tmp_h(k) = ( sum_h1 / sum_h2 ) * h_obs(i,j,k) - enddo if (G%mask2dT(i,j) == 1) then - ! get temperature increment - do k=1,nz_data - tmp_val2(k) = CS%Inc(1)%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) - 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) - tmp_t(i,j,k) = tmp_val1(k) ! store T increment for diagnostics - enddo - - ! get salinity increment - do k=1,nz_data - 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) - ! 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) - tmp_s(i,j,k) = tmp_val1(k) ! store S increment for diagnostics - ! bound salinity values ! check if it is correct to do that or if it hides - ! other problems ... - tv%S(i,j,k) = max(0.0 , tv%S(i,j,k)) - enddo + ! account for the different SSH + sum_h1 = 0.0 + do k=1,nz + sum_h1 = sum_h1+h(i,j,k) + enddo + sum_h2 = 0.0 + do k=1,nz_data + sum_h2 = sum_h2+h_obs(i,j,k) + enddo + do k=1,nz_data + tmp_h(k) = ( sum_h1 / sum_h2 ) * h_obs(i,j,k) + enddo + ! get temperature increment + do k=1,nz_data + tmp_val2(k) = CS%Inc(1)%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) + 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) + tmp_t(i,j,k) = tmp_val1(k) ! store T increment for diagnostics + enddo + + ! get salinity increment + do k=1,nz_data + 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) + ! 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) + tmp_s(i,j,k) = tmp_val1(k) ! store S increment for diagnostics + ! bound salinity values ! check if it is correct to do that or if it hides + ! other problems ... + tv%S(i,j,k) = max(0.0 , tv%S(i,j,k)) + enddo endif - enddo; enddo + enddo ; enddo ! add u and v increments if (CS%uv_inc) then - call pass_var(h,G%Domain) ! to ensure reproducibility - - ! add increments to u - hu(:) = 0.0 - tmp_u(:,:,:) = 0.0 ! diagnostics - do j=js,je ; do i=isB,ieB - if (G%mask2dCu(i,j) == 1) then - do k=1,nz_data - ! get u increment - tmp_val2(k) = CS%Inc_u%p(i,j,k) - ! get the h and h_obs at u points - hu_obs(k) = 0.5 * ( h_obs(i,j,k) + h_obs(i+1,j,k) ) - enddo - do k=1,nz - hu(k) = 0.5 * ( h(i,j,k) + h(i+1,j,k) ) - enddo - ! account for different SSH - sum_h1 = 0.0 - do k=1,nz - sum_h1 = sum_h1 + hu(k) - enddo - sum_h2 = 0.0 - do k=1,nz_data - sum_h2 = sum_h2 + hu_obs(k) - enddo - do k=1,nz_data - hu_obs(k)=( sum_h1 / sum_h2 ) * hu_obs(k) - 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) - ! add increment to u-velocity on hu - do k=1,nz - u(i,j,k) = u(i,j,k) + inc_wt * tmp_val1(k) - ! store increment for diagnostics - tmp_u(i,j,k) = tmp_val1(k) - enddo - endif - enddo; enddo - - ! add increments to v - hv(:) = 0.0 - tmp_v(:,:,:) = 0.0 ! diagnostics - do j=jsB,jeB ; do i=is,ie - if (G%mask2dCv(i,j) == 1) then - ! get v increment - do k=1,nz_data - tmp_val2(k) = CS%Inc_v%p(i,j,k) - ! get the h and h_obs at v points - hv_obs(k) = 0.5 * ( h_obs(i,j,k) + h_obs(i,j+1,k) ) - enddo - do k=1,nz - hv(k) = 0.5 * (h(i,j,k) + h(i,j+1,k) ) - enddo - ! account for different SSH - sum_h1 = 0.0 - do k=1,nz - sum_h1 = sum_h1 + hv(k) - enddo - sum_h2 = 0.0 - do k=1,nz_data - sum_h2 = sum_h2 + hv_obs(k) - enddo - do k=1,nz_data - hv_obs(k)=( sum_h1 / sum_h2 ) * hv_obs(k) - 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) - ! add increment to v-velocity on hv - do k=1,nz - v(i,j,k) = v(i,j,k) + inc_wt * tmp_val1(k) - ! store increment for diagnostics - tmp_v(i,j,k) = tmp_val1(k) - enddo - endif - enddo; enddo + call pass_var(h,G%Domain) ! to ensure reproducibility + + ! add increments to u + hu(:) = 0.0 + tmp_u(:,:,:) = 0.0 ! diagnostics + do j=js,je ; do i=isB,ieB + if (G%mask2dCu(i,j) == 1) then + do k=1,nz_data + ! get u increment + tmp_val2(k) = CS%Inc_u%p(i,j,k) + ! get the h and h_obs at u points + hu_obs(k) = 0.5 * ( h_obs(i,j,k) + h_obs(i+1,j,k) ) + enddo + do k=1,nz + hu(k) = 0.5 * ( h(i,j,k) + h(i+1,j,k) ) + enddo + ! account for different SSH + sum_h1 = 0.0 + do k=1,nz + sum_h1 = sum_h1 + hu(k) + enddo + sum_h2 = 0.0 + do k=1,nz_data + sum_h2 = sum_h2 + hu_obs(k) + enddo + do k=1,nz_data + hu_obs(k) = ( sum_h1 / sum_h2 ) * hu_obs(k) + 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) + ! add increment to u-velocity on hu + do k=1,nz + u(i,j,k) = u(i,j,k) + inc_wt * tmp_val1(k) + ! store increment for diagnostics + tmp_u(i,j,k) = tmp_val1(k) + enddo + endif + enddo ; enddo + + ! add increments to v + hv(:) = 0.0 + tmp_v(:,:,:) = 0.0 ! diagnostics + do j=jsB,jeB ; do i=is,ie + if (G%mask2dCv(i,j) == 1) then + ! get v increment + do k=1,nz_data + tmp_val2(k) = CS%Inc_v%p(i,j,k) + ! get the h and h_obs at v points + hv_obs(k) = 0.5 * ( h_obs(i,j,k) + h_obs(i,j+1,k) ) + enddo + do k=1,nz + hv(k) = 0.5 * (h(i,j,k) + h(i,j+1,k) ) + enddo + ! account for different SSH + sum_h1 = 0.0 + do k=1,nz + sum_h1 = sum_h1 + hv(k) + enddo + sum_h2 = 0.0 + do k=1,nz_data + sum_h2 = sum_h2 + hv_obs(k) + enddo + do k=1,nz_data + hv_obs(k)=( sum_h1 / sum_h2 ) * hv_obs(k) + 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) + ! add increment to v-velocity on hv + do k=1,nz + v(i,j,k) = v(i,j,k) + inc_wt * tmp_val1(k) + ! store increment for diagnostics + tmp_v(i,j,k) = tmp_val1(k) + enddo + endif + enddo ; enddo endif ! uv_inc @@ -727,6 +739,7 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) if (CS%id_u_oda_inc > 0) call post_data(CS%id_u_oda_inc, tmp_u, CS%diag) if (CS%id_v_oda_inc > 0) call post_data(CS%id_v_oda_inc, tmp_v, CS%diag) endif + !### The argument here seems wrong. if (CS%id_h_oda_inc > 0) call post_data(CS%id_h_oda_inc, h , CS%diag) if (CS%id_T_oda_inc > 0) call post_data(CS%id_T_oda_inc, tmp_t, CS%diag) if (CS%id_S_oda_inc > 0) call post_data(CS%id_S_oda_inc, tmp_s, CS%diag) @@ -735,7 +748,7 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) deallocate(tmp_h,tmp_val2,hu_obs,hv_obs) deallocate(h_obs) - end subroutine apply_oda_incupd +end subroutine apply_oda_incupd !> Output increment if using full fields for the oda_incupd module. subroutine output_oda_incupd_inc(Time, G, GV, param_file, CS, US) @@ -767,16 +780,16 @@ subroutine output_oda_incupd_inc(Time, G, GV, param_file, CS, US) ! register the variables to write call register_restart_field(CS%Inc(1)%p, "T_inc", .true., restart_CSp_tmp, & - "Pot. T. increment", "degC") + "Pot. T. increment", "degC", conversion=US%C_to_degC) call register_restart_field(CS%Inc(2)%p, "S_inc", .true., restart_CSp_tmp, & - "Salinity increment", "psu") + "Salinity increment", "psu", conversion=US%S_to_ppt) call register_restart_field(CS%Ref_h%p, "h_obs", .true., restart_CSp_tmp, & - "Observational h", "m") + "Observational h", units=get_thickness_units(GV), conversion=GV%H_to_MKS) if (CS%uv_inc) then u_desc = var_desc("u_inc", "m s-1", "U-vel increment", hor_grid='Cu') v_desc = var_desc("v_inc", "m s-1", "V-vel increment", hor_grid='Cv') call register_restart_pair(CS%Inc_u%p, CS%Inc_v%p, u_desc, v_desc, & - .false., restart_CSp_tmp) + .false., restart_CSp_tmp, conversion=US%L_T_to_m_s) endif ! get the name of the output file @@ -796,7 +809,7 @@ end subroutine output_oda_incupd_inc subroutine init_oda_incupd_diags(Time, G, GV, diag, CS, US) type(time_type), target, intent(in) :: Time !< The current model time type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic !! output. type(oda_incupd_CS), pointer :: CS !< ALE sponge control structure @@ -805,18 +818,17 @@ subroutine init_oda_incupd_diags(Time, G, GV, diag, CS, US) if (.not.associated(CS)) return CS%diag => diag - ! These diagnostics of the state variables increments,useful for debugging the - ! ODA code. + ! These diagnostics of the state variables increments are useful for debugging the ODA code. CS%id_u_oda_inc = register_diag_field('ocean_model', 'u_oda_inc', diag%axesCuL, Time, & - 'Zonal velocity ODA inc.', 'm s-1') + 'Zonal velocity ODA inc.', 'm s-1', conversion=US%L_T_to_m_s) CS%id_v_oda_inc = register_diag_field('ocean_model', 'v_oda_inc', diag%axesCvL, Time, & - 'Meridional velocity ODA inc.', 'm s-1') + 'Meridional velocity ODA inc.', 'm s-1', conversion=US%L_T_to_m_s) CS%id_h_oda_inc = register_diag_field('ocean_model', 'h_oda_inc', diag%axesTL, Time, & - 'Layer Thickness ODA inc.', get_thickness_units(GV)) + 'Layer Thickness ODA inc.', get_thickness_units(GV), conversion=GV%H_to_mks) CS%id_T_oda_inc = register_diag_field('ocean_model', 'T_oda_inc', diag%axesTL, Time, & - 'Temperature ODA inc.', 'degC') + 'Temperature ODA inc.', 'degC', conversion=US%C_to_degC) CS%id_S_oda_inc = register_diag_field('ocean_model', 'S_oda_inc', diag%axesTL, Time, & - 'Salinity ODA inc.', 'PSU') + 'Salinity ODA inc.', 'PSU', conversion=US%S_to_ppt) end subroutine init_oda_incupd_diags diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index c786f395cf..ec0b28f49d 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -1,25 +1,40 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Implements the Mesoscale Eddy Kinetic Energy framework !! with topographic beta effect included in computing beta in Rhines scale module MOM_MEKE -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_debugging, only : hchksum, uvchksum -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE -use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr -use MOM_diag_mediator, only : diag_ctrl, time_type -use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type -use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE, MOM_mesg -use MOM_file_parser, only : read_param, get_param, log_version, param_file_type -use MOM_grid, only : ocean_grid_type -use MOM_hor_index, only : hor_index_type -use MOM_io, only : vardesc, var_desc -use MOM_restart, only : MOM_restart_CS, register_restart_field, query_initialized -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : vertvisc_type -use MOM_verticalGrid, only : verticalGrid_type -use MOM_MEKE_types, only : MEKE_type +use iso_fortran_env, only : real32 + +use MOM_coms, only : PE_here +use MOM_database_comms, only : dbclient_type, dbcomms_CS_type +use MOM_debugging, only : hchksum, uvchksum +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr +use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_domains, only : pass_vector, pass_var +use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE, MOM_mesg, is_root_pe +use MOM_file_parser, only : read_param, get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_interface_heights, only : find_eta +use MOM_interpolate, only : init_external_field, time_interp_external +use MOM_interpolate, only : time_interp_external_init +use MOM_interpolate, only : external_field +use MOM_io, only : vardesc, var_desc, slasher +use MOM_isopycnal_slopes, only : calc_isoneutral_slopes +use MOM_restart, only : MOM_restart_CS, register_restart_field, query_initialized +use MOM_string_functions, only : lowercase +use MOM_time_manager, only : time_type_to_real +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : vertvisc_type, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_MEKE_types, only : MEKE_type + implicit none ; private @@ -27,16 +42,28 @@ module MOM_MEKE public step_forward_MEKE, MEKE_init, MEKE_alloc_register_restart, MEKE_end +! Constants for this module +integer, parameter :: NUM_FEATURES = 4 !< How many features used to predict EKE +integer, parameter :: MKE_IDX = 1 !< Index of mean kinetic energy in the feature array +integer, parameter :: SLOPE_Z_IDX = 2 !< Index of vertically averaged isopycnal slope in the feature array +integer, parameter :: RV_IDX = 3 !< Index of surface relative vorticity in the feature array +integer, parameter :: RD_DX_Z_IDX = 4 !< Index of the radius of deformation over the grid size in the feature array + +integer, parameter :: EKE_PROG = 1 !< Use prognostic equation to calculate EKE +integer, parameter :: EKE_FILE = 2 !< Read in EKE from a file +integer, parameter :: EKE_DBCLIENT = 3 !< Infer EKE using a neural network + !> Control structure that contains MEKE parameters and diagnostics handles type, public :: MEKE_CS ; private logical :: initialized = .false. !< True if this control structure has been initialized. ! Parameters real :: MEKE_FrCoeff !< Efficiency of conversion of ME into MEKE [nondim] + real :: MEKE_bhFrCoeff!< Efficiency of conversion of ME into MEKE by the biharmonic dissipation [nondim] real :: MEKE_GMcoeff !< Efficiency of conversion of PE into MEKE [nondim] real :: MEKE_GMECoeff !< Efficiency of conversion of MEKE into ME by GME [nondim] real :: MEKE_damping !< Local depth-independent MEKE dissipation rate [T-1 ~> s-1]. real :: MEKE_Cd_scale !< The ratio of the bottom eddy velocity to the column mean - !! eddy velocity, i.e. sqrt(2*MEKE). This should be less than 1 + !! eddy velocity, i.e. sqrt(2*MEKE), [nondim]. This should be less than 1 !! to account for the surface intensification of MEKE. real :: MEKE_Cb !< Coefficient in the \f$\gamma_{bot}\f$ expression [nondim] real :: MEKE_min_gamma!< Minimum value of gamma_b^2 allowed [nondim] @@ -45,18 +72,23 @@ module MOM_MEKE logical :: MEKE_GEOMETRIC !< If true, uses the GM coefficient formulation from the GEOMETRIC !! framework (Marshall et al., 2012) real :: MEKE_GEOMETRIC_alpha !< The nondimensional coefficient governing the efficiency of the - !! GEOMETRIC thickness diffusion. + !! GEOMETRIC thickness diffusion [nondim]. logical :: MEKE_equilibrium_alt !< If true, use an alternative calculation for the !! equilibrium value of MEKE. logical :: MEKE_equilibrium_restoring !< If true, restore MEKE back to its equilibrium value, !! which is calculated at each time step. logical :: GM_src_alt !< If true, use the GM energy conversion form S^2*N^2*kappa rather !! than the streamfunction for the MEKE GM source term. + real :: MEKE_min_depth_tot !< The minimum total thickness over which to distribute MEKE energy + !! sources from GM energy conversion [H ~> m or kg m-2]. When the total + !! thickness is less than this, the sources are scaled away. logical :: Rd_as_max_scale !< If true the length scale can not exceed the !! first baroclinic deformation radius. logical :: use_old_lscale !< Use the old formula for mixing length scale. logical :: use_min_lscale !< Use simple minimum for mixing length scale. - real :: cdrag !< The bottom drag coefficient for MEKE [nondim]. + logical :: MEKE_positive !< If true, it guarantees that MEKE will always be >= 0. + real :: lscale_maxval !< The ceiling on the MEKE mixing length scale when use_min_lscale is true [L ~> m]. + real :: cdrag !< The bottom drag coefficient for MEKE, times rescaling factors [H L-1 ~> nondim or kg m-3] real :: MEKE_BGsrc !< Background energy source for MEKE [L2 T-3 ~> W kg-1] (= m2 s-3). real :: MEKE_dtScale !< Scale factor to accelerate time-stepping [nondim] real :: MEKE_KhCoeff !< Scaling factor to convert MEKE into Kh [nondim] @@ -67,10 +99,10 @@ module MOM_MEKE !! MEKE itself [nondim]. real :: viscosity_coeff_Ku !< The scaling coefficient in the expression for !! viscosity used to parameterize lateral harmonic momentum mixing - !! by unresolved eddies represented by MEKE. + !! by unresolved eddies represented by MEKE [nondim]. real :: viscosity_coeff_Au !< The scaling coefficient in the expression for !! viscosity used to parameterize lateral biharmonic momentum mixing - !! by unresolved eddies represented by MEKE. + !! by unresolved eddies represented by MEKE [nondim]. real :: Lfixed !< Fixed mixing length scale [L ~> m]. real :: aDeform !< Weighting towards deformation scale of mixing length [nondim] real :: aRhines !< Weighting towards Rhines scale of mixing length [nondim] @@ -88,33 +120,62 @@ module MOM_MEKE logical :: fixed_total_depth !< If true, use the nominal bathymetric depth as the estimate of !! the time-varying ocean depth. Otherwise base the depth on the total !! ocean mass per unit area. + real :: rho_fixed_total_depth !< A density used to translate the nominal bathymetric depth into an + !! estimate of the total ocean mass per unit area when MEKE_FIXED_TOTAL_DEPTH + !! is true [R ~> kg m-3] logical :: kh_flux_enabled !< If true, lateral diffusive MEKE flux is enabled. logical :: initialize !< If True, invokes a steady state solver to calculate MEKE. logical :: debug !< If true, write out checksums of data for debugging - + integer :: eke_src !< Enum specifying whether EKE is stepped forward prognostically (default), + !! read in from a file, or inferred via a neural network + logical :: sqg_use_MEKE !< If True, use MEKE%Le for the SQG vertical structure. type(diag_ctrl), pointer :: diag => NULL() !< A type that regulates diagnostics output !>@{ Diagnostic handles integer :: id_MEKE = -1, id_Ue = -1, id_Kh = -1, id_src = -1 + integer :: id_src_adv = -1, id_src_mom_K4 = -1, id_src_btm_drag = -1 + integer :: id_src_GM = -1, id_src_mom_lp = -1, id_src_mom_bh = -1 integer :: id_Ub = -1, id_Ut = -1 - integer :: id_GM_src = -1, id_mom_src = -1, id_GME_snk = -1, id_decay = -1 + integer :: id_GM_src = -1, id_mom_src = -1, id_mom_src_bh = -1, id_GME_snk = -1, id_decay = -1 integer :: id_KhMEKE_u = -1, id_KhMEKE_v = -1, id_Ku = -1, id_Au = -1 integer :: id_Le = -1, id_gamma_b = -1, id_gamma_t = -1 integer :: id_Lrhines = -1, id_Leady = -1 integer :: id_MEKE_equilibrium = -1 !>@} - + type(external_field) :: eke_handle !< Handle for reading in EKE from a file ! Infrastructure integer :: id_clock_pass !< Clock for group pass calls type(group_pass_type) :: pass_MEKE !< Group halo pass handle for MEKE%MEKE and maybe MEKE%Kh_diff type(group_pass_type) :: pass_Kh !< Group halo pass handle for MEKE%Kh, MEKE%Ku, and/or MEKE%Au + + ! MEKE via Machine Learning + type(dbclient_type), pointer :: client => NULL() !< Pointer to the database client + + logical :: online_analysis !< If true, post the EKE used in MOM6 at every timestep + character(len=5) :: model_key = 'mleke' !< Key where the ML-model is stored + character(len=7) :: key_suffix !< Suffix appended to every key sent to Redis + real :: eke_max !< The maximum value of EKE considered physically reasonable [L2 T-2 ~> m2 s-2] + + ! Clock ids + integer :: id_client_init !< Clock id to time initialization of the client + integer :: id_put_tensor !< Clock id to time put_tensor routine + integer :: id_run_model !< Clock id to time running of the ML model + integer :: id_unpack_tensor !< Clock id to time retrieval of EKE prediction + + ! Diagnostic ids + integer :: id_mke = -1 !< Diagnostic id for surface mean kinetic energy + integer :: id_slope_z = -1 !< Diagnostic id for vertically averaged horizontal slope magnitude + integer :: id_slope_x = -1 !< Diagnostic id for isopycnal slope in the x-direction + integer :: id_slope_y = -1 !< Diagnostic id for isopycnal slope in the y-direction + integer :: id_rv = -1 !< Diagnostic id for surface relative vorticity + end type MEKE_CS contains !> Integrates forward-in-time the MEKE eddy energy equation. !! See \ref section_MEKE_equations. -subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, hv) - type(MEKE_type), intent(inout) :: MEKE !< MEKE fields +subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, hv, u, v, tv, Time) + type(MEKE_type), intent(inout) :: MEKE !< MEKE data. type(ocean_grid_type), intent(inout) :: G !< Ocean grid. type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -124,55 +185,72 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h type(vertvisc_type), intent(in) :: visc !< The vertical viscosity type. real, intent(in) :: dt !< Model(baroclinic) time-step [T ~> s]. type(MEKE_CS), intent(inout) :: CS !< MEKE control structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: hu !< Accumlated zonal mass flux [H L2 ~> m3 or kg] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: hv !< Accumlated meridional mass flux [H L2 ~> m3 or kg] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: hu !< Accumulated zonal mass flux [H L2 ~> m3 or kg]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: hv !< Accumulated meridional mass flux [H L2 ~> m3 or kg] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< Meridional velocity [L T-1 ~> m s-1] + type(thermo_var_ptrs), intent(in) :: tv !< Type containing thermodynamic variables + type(time_type), intent(in) :: Time !< The time used for interpolating EKE ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & + data_eke, & ! EKE from file [L2 T-2 ~> m2 s-2] mass, & ! The total mass of the water column [R Z ~> kg m-2]. I_mass, & ! The inverse of mass [R-1 Z-1 ~> m2 kg-1]. - depth_tot, & ! The depth of the water column [Z ~> m]. + depth_tot, & ! The depth of the water column [H ~> m or kg m-2]. src, & ! The sum of all MEKE sources [L2 T-3 ~> W kg-1] (= m2 s-3). MEKE_decay, & ! A diagnostic of the MEKE decay timescale [T-1 ~> s-1]. - drag_rate_visc, & ! Near-bottom velocity contribution to bottom dratg [L T-1 ~> m s-1] + src_adv, & ! The MEKE source/tendency from the horizontal advection of MEKE [L2 T-3 ~> W kg-1] (= m2 s-3). + src_mom_K4, & ! The MEKE source/tendency from the bihamornic of MEKE [L2 T-3 ~> W kg-1] (= m2 s-3). + src_btm_drag, & ! The MEKE source/tendency from the bottom drag acting on MEKE [L2 T-3 ~> W kg-1] (= m2 s-3). + src_GM, & ! The MEKE source/tendency from the thickness mixing (GM) [L2 T-3 ~> W kg-1] (= m2 s-3). + src_mom_lp, & ! The MEKE source/tendency from the Laplacian of the resolved flow [L2 T-3 ~> W kg-1] (= m2 s-3). + src_mom_bh, & ! The MEKE source/tendency from the biharmonic of the resolved flow [L2 T-3 ~> W kg-1] (= m2 s-3). + damp_rate_s1, & ! The MEKE damping rate computed at the 1st Strang splitting stage [T-1 ~> s-1]. + MEKE_current, & ! A copy of MEKE for use in computing the MEKE damping [L2 T-2 ~> m2 s-2]. + drag_rate_visc, & ! Near-bottom velocity contribution to bottom drag [H T-1 ~> m s-1 or kg m-2 s-1] drag_rate, & ! The MEKE spindown timescale due to bottom drag [T-1 ~> s-1]. del2MEKE, & ! Laplacian of MEKE, used for bi-harmonic diffusion [T-2 ~> s-2]. del4MEKE, & ! Time-integrated MEKE tendency arising from the biharmonic of MEKE [L2 T-2 ~> m2 s-2]. LmixScale, & ! Eddy mixing length [L ~> m]. barotrFac2, & ! Ratio of EKE_barotropic / EKE [nondim] bottomFac2, & ! Ratio of EKE_bottom / EKE [nondim] - tmp, & ! Temporary variable for diagnostic computation - equilibrium_value ! The equilbrium value of MEKE to be calculated at each - ! time step [L2 T-2 ~> m2 s-2] + tmp, & ! Temporary variable for computation of diagnostic velocities [L T-1 ~> m s-1] + equilibrium_value, & ! The equilibrium value of MEKE to be calculated at + ! each time step [L2 T-2 ~> m2 s-2] + damp_rate, & ! The MEKE damping rate [T-1 ~> s-1] + damping ! The net damping of a field after sdt_damp [nondim] real, dimension(SZIB_(G),SZJ_(G)) :: & MEKE_uflux, & ! The zonal advective and diffusive flux of MEKE with units of [R Z L4 T-3 ~> kg m2 s-3]. ! In one place, MEKE_uflux is used as temporary work space with units of [L2 T-2 ~> m2 s-2]. Kh_u, & ! The zonal diffusivity that is actually used [L2 T-1 ~> m2 s-1]. baroHu, & ! Depth integrated accumulated zonal mass flux [R Z L2 ~> kg]. - drag_vel_u ! A (vertical) viscosity associated with bottom drag at - ! u-points [Z T-1 ~> m s-1]. + drag_vel_u ! A piston velocity associated with bottom drag at u-points [H T-1 ~> m s-1 or kg m-2 s-1] real, dimension(SZI_(G),SZJB_(G)) :: & MEKE_vflux, & ! The meridional advective and diffusive flux of MEKE with units of [R Z L4 T-3 ~> kg m2 s-3]. ! In one place, MEKE_vflux is used as temporary work space with units of [L2 T-2 ~> m2 s-2]. Kh_v, & ! The meridional diffusivity that is actually used [L2 T-1 ~> m2 s-1]. baroHv, & ! Depth integrated accumulated meridional mass flux [R Z L2 ~> kg]. - drag_vel_v ! A (vertical) viscosity associated with bottom drag at - ! v-points [Z T-1 ~> m s-1]. + drag_vel_v ! A piston velocity associated with bottom drag at v-points [H T-1 ~> m s-1 or kg m-2 s-1] + real :: bh_coeff ! Biharmonic part of efficiency conversion in total MEKE [nondim] real :: Kh_here ! The local horizontal viscosity [L2 T-1 ~> m2 s-1] real :: Inv_Kh_max ! The inverse of the local horizontal viscosity [T L-2 ~> s m-2] real :: K4_here ! The local horizontal biharmonic viscosity [L4 T-1 ~> m4 s-1] real :: Inv_K4_max ! The inverse of the local horizontal biharmonic viscosity [T L-4 ~> s m-4] - real :: cdrag2 + real :: cdrag2 ! The square of the drag coefficient times unit conversion factors [H2 L-2 ~> nondim or kg2 m-6] real :: advFac ! The product of the advection scaling factor and 1/dt [T-1 ~> s-1] real :: mass_neglect ! A negligible mass [R Z ~> kg m-2]. - real :: ldamping ! The MEKE damping rate [T-1 ~> s-1]. - real :: Rho0 ! A density used to convert mass to distance [R ~> kg m-3] - real :: I_Rho0 ! The inverse of the density used to convert mass to distance [R-1 ~> m3 kg-1] real :: sdt ! dt to use locally [T ~> s] (could be scaled to accelerate) real :: sdt_damp ! dt for damping [T ~> s] (sdt could be split). + real :: damp_step ! Size of damping timestep relative to sdt [nondim] logical :: use_drag_rate ! Flag to indicate drag_rate is finite + logical :: any_damping_diags_s1 ! True if any damped diagnostics are enabled in first stage + logical :: any_damping_diags ! True if any damped diagnostics are enabled integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + real(kind=real32), dimension(size(MEKE%MEKE),NUM_FEATURES) :: features_array ! The array of features + ! needed for the machine learning inference, with different + ! units for the various subarrays [various] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -192,30 +270,34 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h return endif + select case(CS%eke_src) + case(EKE_PROG) if (CS%debug) then if (allocated(MEKE%mom_src)) & - call hchksum(MEKE%mom_src, 'MEKE mom_src', G%HI, scale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + call hchksum(MEKE%mom_src, 'MEKE mom_src', G%HI, unscale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + if (allocated(MEKE%mom_src_bh)) & + call hchksum(MEKE%mom_src_bh, 'MEKE mom_src_bh', G%HI, unscale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) if (allocated(MEKE%GME_snk)) & - call hchksum(MEKE%GME_snk, 'MEKE GME_snk', G%HI, scale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + call hchksum(MEKE%GME_snk, 'MEKE GME_snk', G%HI, unscale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) if (allocated(MEKE%GM_src)) & - call hchksum(MEKE%GM_src, 'MEKE GM_src', G%HI, scale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + call hchksum(MEKE%GM_src, 'MEKE GM_src', G%HI, unscale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) if (allocated(MEKE%MEKE)) & - call hchksum(MEKE%MEKE, 'MEKE MEKE', G%HI, scale=US%L_T_to_m_s**2) - call uvchksum("MEKE SN_[uv]", SN_u, SN_v, G%HI, scale=US%s_to_T, & + call hchksum(MEKE%MEKE, 'MEKE MEKE', G%HI, unscale=US%L_T_to_m_s**2) + call uvchksum("MEKE SN_[uv]", SN_u, SN_v, G%HI, unscale=US%s_to_T, & scalar_pair=.true.) - call uvchksum("MEKE h[uv]", hu, hv, G%HI, haloshift=1, & - scale=GV%H_to_m*(US%L_to_m**2)) + call uvchksum("MEKE h[uv]", hu, hv, G%HI, haloshift=0, symmetric=.true., & + unscale=GV%H_to_m*US%L_to_m**2) endif sdt = dt*CS%MEKE_dtScale ! Scaled dt to use for time-stepping - Rho0 = GV%Rho0 - I_Rho0 = 1.0 / GV%Rho0 mass_neglect = GV%H_to_RZ * GV%H_subroundoff cdrag2 = CS%cdrag**2 ! With a depth-dependent (and possibly strong) damping, it seems ! advisable to use Strang splitting between the damping and diffusion. - sdt_damp = sdt ; if (CS%MEKE_KH >= 0.0 .or. CS%MEKE_K4 >= 0.) sdt_damp = 0.5*sdt + damp_step = 1. + if (CS%MEKE_KH >= 0. .or. CS%MEKE_K4 >= 0.) damp_step = 0.5 + sdt_damp = sdt * damp_step ! Calculate depth integrated mass exchange if doing advection [R Z L2 ~> kg] if (CS%MEKE_advection_factor>0.) then @@ -236,7 +318,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h enddo ; enddo enddo if (CS%MEKE_advection_bug) then - ! This code obviously incorrect code reproduces a bug in the original implementation of + ! This obviously incorrect code reproduces a bug in the original implementation of ! the MEKE advection. do j=js,je ; do I=is-1,ie baroHu(I,j) = hu(I,j,nz) * GV%H_to_RZ @@ -247,9 +329,8 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h endif endif - ! Calculate drag_rate_visc(i,j) which accounts for the model bottom mean flow - if (CS%visc_drag) then + if (CS%visc_drag .and. allocated(visc%Kv_bbl_u) .and. allocated(visc%Kv_bbl_v)) then !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie drag_vel_u(I,j) = 0.0 @@ -265,11 +346,11 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - drag_rate_visc(i,j) = (0.25*G%IareaT(i,j) * US%Z_to_L * & - ((G%areaCu(I-1,j)*drag_vel_u(I-1,j) + & - G%areaCu(I,j)*drag_vel_u(I,j)) + & - (G%areaCv(i,J-1)*drag_vel_v(i,J-1) + & - G%areaCv(i,J)*drag_vel_v(i,J)) ) ) + drag_rate_visc(i,j) = (0.25*G%IareaT(i,j) * & + (((G%areaCu(I-1,j)*drag_vel_u(I-1,j)) + & + (G%areaCu(I,j)*drag_vel_u(I,j))) + & + ((G%areaCv(i,J-1)*drag_vel_v(i,J-1)) + & + (G%areaCv(i,J)*drag_vel_v(i,J))) ) ) enddo ; enddo else !$OMP parallel do default(shared) @@ -291,14 +372,21 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h enddo if (CS%fixed_total_depth) then - !$OMP parallel do default(shared) - do j=js-1,je+1 ; do i=is-1,ie+1 - depth_tot(i,j) = G%bathyT(i,j) + G%Z_ref - enddo ; enddo + if (GV%Boussinesq) then + !$OMP parallel do default(shared) + do j=js-1,je+1 ; do i=is-1,ie+1 + depth_tot(i,j) = max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) * GV%Z_to_H + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=js-1,je+1 ; do i=is-1,ie+1 + depth_tot(i,j) = max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) * CS%rho_fixed_total_depth * GV%RZ_to_H + enddo ; enddo + endif else !$OMP parallel do default(shared) do j=js-1,je+1 ; do i=is-1,ie+1 - depth_tot(i,j) = mass(i,j) * I_Rho0 + depth_tot(i,j) = mass(i,j) * GV%RZ_to_H enddo ; enddo endif @@ -312,12 +400,19 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (CS%debug) then if (CS%visc_drag) & call uvchksum("MEKE drag_vel_[uv]", drag_vel_u, drag_vel_v, G%HI, & - scale=US%Z_to_m*US%s_to_T, scalar_pair=.true.) - call hchksum(mass, 'MEKE mass',G%HI,haloshift=1, scale=US%RZ_to_kg_m2) - call hchksum(drag_rate_visc, 'MEKE drag_rate_visc', G%HI, scale=US%L_T_to_m_s) + unscale=GV%H_to_mks*US%s_to_T, scalar_pair=.true.) + call hchksum(mass, 'MEKE mass',G%HI,haloshift=1, unscale=US%RZ_to_kg_m2) + call hchksum(drag_rate_visc, 'MEKE drag_rate_visc', G%HI, unscale=GV%H_to_mks*US%s_to_T) call hchksum(bottomFac2, 'MEKE bottomFac2', G%HI) call hchksum(barotrFac2, 'MEKE barotrFac2', G%HI) - call hchksum(LmixScale, 'MEKE LmixScale', G%HI,scale=US%L_to_m) + call hchksum(LmixScale, 'MEKE LmixScale', G%HI, unscale=US%L_to_m) + endif + + if (allocated(MEKE%Le)) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE%Le(i,j) = LmixScale(i,j) + enddo ; enddo endif ! Aggregate sources of MEKE (background, frictional and GM) @@ -326,13 +421,64 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h src(i,j) = CS%MEKE_BGsrc enddo ; enddo - if (allocated(MEKE%mom_src)) then + ! Initialize diagnostics + if (CS%id_src_adv > 0) src_adv(is:ie, js:je) = 0. + if (CS%id_src_GM > 0) src_GM(is:ie, js:je) = 0. + if (CS%id_src_mom_lp > 0) src_mom_lp(is:ie, js:je) = 0. + if (CS%id_src_mom_bh > 0) src_mom_bh(is:ie, js:je) = 0. + if (CS%id_src_mom_K4 > 0) src_mom_K4(is:ie, js:je) = 0. + if (CS%id_src_btm_drag > 0) src_btm_drag(is:ie, js:je) = 0. + + ! Identify any damped diagnostics in first stage of Strang splitting + any_damping_diags_s1 = any([ & + CS%id_src_GM > 0, & + CS%id_src_mom_lp > 0, & + CS%id_src_mom_bh > 0, & + CS%id_src_btm_drag > 0 & + ]) + + ! Identify any damped diagnostics + any_damping_diags = any([ & + any_damping_diags_s1, & + CS%id_src_adv > 0, & + CS%id_src_mom_K4 > 0 & + ]) + + if (CS%MEKE_FrCoeff > 0.) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - src(i,j) = src(i,j) - CS%MEKE_FrCoeff*I_mass(i,j)*MEKE%mom_src(i,j) + src(i,j) = src(i,j) - CS%MEKE_FrCoeff * I_mass(i,j) * MEKE%mom_src(i,j) enddo ; enddo endif + if (allocated(MEKE%mom_src_bh)) then + if (CS%MEKE_bhFrCoeff > 0. .and. CS%MEKE_FrCoeff > 0.) then + bh_coeff = CS%MEKE_bhFrCoeff - CS%MEKE_FrCoeff + else + bh_coeff = CS%MEKE_bhFrCoeff + endif + + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src(i,j) = src(i,j) - bh_coeff * I_mass(i,j) * MEKE%mom_src_bh(i,j) + enddo ; enddo + + if (CS%id_src_mom_lp > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_mom_lp(i,j) = -CS%MEKE_FrCoeff * I_mass(i,j) & + * (MEKE%mom_src(i,j) - MEKE%mom_src_bh(i,j)) + enddo ; enddo + endif + + if (CS%id_src_mom_bh > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_mom_bh(i,j) = -CS%MEKE_bhFrCoeff * I_mass(i,j) * MEKE%mom_src_bh(i,j) + enddo ; enddo + endif + endif + if (allocated(MEKE%GME_snk)) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie @@ -345,18 +491,22 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h !$OMP parallel do default(shared) do j=js,je ; do i=is,ie src(i,j) = src(i,j) - CS%MEKE_GMcoeff*MEKE%GM_src(i,j) / & - (GV%Rho0 * MAX(1.0*US%m_to_Z, depth_tot(i,j))) + (GV%H_to_RZ * MAX(CS%MEKE_min_depth_tot, depth_tot(i,j))) enddo ; enddo else !$OMP parallel do default(shared) do j=js,je ; do i=is,ie src(i,j) = src(i,j) - CS%MEKE_GMcoeff*I_mass(i,j)*MEKE%GM_src(i,j) enddo ; enddo + + do j=js,je ; do i=is,ie + src_GM(i,j) = -CS%MEKE_GMcoeff*I_mass(i,j)*MEKE%GM_src(i,j) + enddo ; enddo endif endif if (CS%MEKE_equilibrium_restoring) then - call MEKE_equilibrium_restoring(CS, G, US, SN_u, SN_v, depth_tot, & + call MEKE_equilibrium_restoring(CS, G, GV, US, SN_u, SN_v, depth_tot, & equilibrium_value) do j=js,je ; do i=is,ie src(i,j) = src(i,j) - CS%MEKE_restoring_rate*(MEKE%MEKE(i,j) - equilibrium_value(i,j)) @@ -364,12 +514,13 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h endif if (CS%debug) then - call hchksum(src, "MEKE src", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T**3) + call hchksum(src, "MEKE src", G%HI, haloshift=0, unscale=US%L_to_m**2*US%s_to_T**3) endif ! Increase EKE by a full time-steps worth of source !$OMP parallel do default(shared) do j=js,je ; do i=is,ie + MEKE_current(i,j) = MEKE%MEKE(i,j) MEKE%MEKE(i,j) = (MEKE%MEKE(i,j) + sdt*src(i,j))*G%mask2dT(i,j) enddo ; enddo @@ -377,7 +528,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h ! Calculate a viscous drag rate (includes BBL contributions from mean flow and eddies) !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - drag_rate(i,j) = (US%L_to_Z*Rho0 * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 + & + drag_rate(i,j) = (GV%H_to_RZ * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 + & cdrag2 * ( max(0.0, 2.0*bottomFac2(i,j)*MEKE%MEKE(i,j)) + CS%MEKE_Uscale**2 ) ) enddo ; enddo else @@ -388,16 +539,75 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h endif ! First stage of Strang splitting + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - ldamping = CS%MEKE_damping + drag_rate(i,j) * bottomFac2(i,j) - if (MEKE%MEKE(i,j) < 0.) ldamping = 0. + damp_rate(i,j) = CS%MEKE_damping + drag_rate(i,j) * bottomFac2(i,j) + + if (MEKE%MEKE(i,j) < 0.) damp_rate(i,j) = 0. ! notice that the above line ensures a damping only if MEKE is positive, ! while leaving MEKE unchanged if it is negative - MEKE%MEKE(i,j) = MEKE%MEKE(i,j) / (1.0 + sdt_damp*ldamping) - MEKE_decay(i,j) = ldamping*G%mask2dT(i,j) enddo ; enddo + ! NOTE: MEKE%MEKE cannot use `damping` since we must preserve the existing + ! bit-reproducible solution. + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE%MEKE(i,j) = MEKE%MEKE(i,j) / (1. + sdt_damp * damp_rate(i,j)) + enddo ; enddo + + if (any_damping_diags_s1) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + damping(i,j) = 1. / (1. + sdt_damp * damp_rate(i,j)) + enddo ; enddo + + if (CS%id_decay > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE_decay(i,j) = damp_rate(i,j) * G%mask2dT(i,j) + enddo ; enddo + endif + + if (CS%id_src_GM > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_GM(i,j) = src_GM(i,j) * damping(i,j) + enddo ; enddo + endif + + if (CS%id_src_mom_lp > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_mom_lp(i,j) = src_mom_lp(i,j) * damping(i,j) + enddo ; enddo + endif + + if (CS%id_src_mom_bh > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_mom_bh(i,j) = src_mom_bh(i,j) * damping(i,j) + enddo ; enddo + endif + + if (CS%id_src_btm_drag > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_btm_drag(i,j) = -MEKE_current(i,j) * ( & + damp_step * (damp_rate(i,j) * damping(i,j)) & + ) + enddo ; enddo + + ! Store the effective damping rate if sdt is split + if (CS%MEKE_KH >= 0. .or. CS%MEKE_K4 >= 0.) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + damp_rate_s1(i,j) = damp_rate(i,j) * damping(i,j) + enddo ; enddo + endif + endif + endif + if (CS%kh_flux_enabled .or. CS%MEKE_K4 >= 0.0) then ! Update MEKE in the halos for lateral or bi-harmonic diffusion call cpu_clock_begin(CS%id_clock_pass) @@ -410,7 +620,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h !$OMP parallel do default(shared) do j=js-1,je+1 ; do I=is-2,ie+1 ! MEKE_uflux is used here as workspace with units of [L2 T-2 ~> m2 s-2]. - MEKE_uflux(I,j) = ((G%dy_Cu(I,j)*G%IdxCu(I,j)) * G%mask2dCu(I,j)) * & + MEKE_uflux(I,j) = (G%dy_Cu(I,j)*G%IdxCu_OBCmask(I,j)) * & (MEKE%MEKE(i+1,j) - MEKE%MEKE(i,j)) ! This would have units of [R Z L2 T-2 ~> kg s-2] ! MEKE_uflux(I,j) = ((G%dy_Cu(I,j)*G%IdxCu(I,j)) * & @@ -420,7 +630,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h !$OMP parallel do default(shared) do J=js-2,je+1 ; do i=is-1,ie+1 ! MEKE_vflux is used here as workspace with units of [L2 T-2 ~> m2 s-2]. - MEKE_vflux(i,J) = ((G%dx_Cv(i,J)*G%IdyCv(i,J)) * G%mask2dCv(i,J)) * & + MEKE_vflux(i,J) = (G%dx_Cv(i,J)*G%IdyCv_OBCmask(i,J)) * & (MEKE%MEKE(i,j+1) - MEKE%MEKE(i,j)) ! This would have units of [R Z L2 T-2 ~> kg s-2] ! MEKE_vflux(i,J) = ((G%dx_Cv(i,J)*G%IdyCv(i,J)) * & @@ -465,6 +675,9 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h del4MEKE(i,j) = (sdt*(G%IareaT(i,j)*I_mass(i,j))) * & ((MEKE_uflux(I-1,j) - MEKE_uflux(I,j)) + & (MEKE_vflux(i,J-1) - MEKE_vflux(i,J))) + src_mom_K4(i,j) = (G%IareaT(i,j)*I_mass(i,j)) * & + ((MEKE_uflux(I-1,j) - MEKE_uflux(I,j)) + & + (MEKE_vflux(i,J-1) - MEKE_vflux(i,J))) enddo ; enddo endif ! @@ -533,6 +746,15 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h ((MEKE_uflux(I-1,j) - MEKE_uflux(I,j)) + & (MEKE_vflux(i,J-1) - MEKE_vflux(i,J))) enddo ; enddo + + if (CS%id_src_adv > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_adv(i,j) = (G%IareaT(i,j)*I_mass(i,j)) * & + ((MEKE_uflux(I-1,j) - MEKE_uflux(I,j)) + & + (MEKE_vflux(i,J-1) - MEKE_vflux(i,J))) + enddo ; enddo + endif endif ! MEKE_KH>0 ! Add on bi-harmonic tendency @@ -545,127 +767,220 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h ! Second stage of Strang splitting if (CS%MEKE_KH >= 0.0 .or. CS%MEKE_K4 >= 0.0) then - if (sdt>sdt_damp) then - ! Recalculate the drag rate, since MEKE has changed. - if (use_drag_rate) then + ! Recalculate the drag rate, since MEKE has changed. + if (use_drag_rate) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + drag_rate(i,j) = (GV%H_to_RZ * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 + & + cdrag2 * ( max(0.0, 2.0*bottomFac2(i,j)*MEKE%MEKE(i,j)) + CS%MEKE_Uscale**2 ) ) + enddo ; enddo + endif + + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + damp_rate(i,j) = CS%MEKE_damping + drag_rate(i,j) * bottomFac2(i,j) + + if (MEKE%MEKE(i,j) < 0.) damp_rate(i,j) = 0. + ! notice that the above line ensures a damping only if MEKE is positive, + ! while leaving MEKE unchanged if it is negative + enddo ; enddo + + ! NOTE: MEKE%MEKE cannot use `damping` since we must preserve the + ! existing bit-reproducible solution. + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE%MEKE(i,j) = MEKE%MEKE(i,j) / (1. + sdt_damp * damp_rate(i,j)) + enddo ; enddo + + if (any_damping_diags) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + damping(i,j) = 1. / (1. + sdt_damp * damp_rate(i,j)) + enddo ; enddo + + if (CS%id_decay > 0) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - drag_rate(i,j) = (US%L_to_Z*Rho0 * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 + & - cdrag2 * ( max(0.0, 2.0*bottomFac2(i,j)*MEKE%MEKE(i,j)) + CS%MEKE_Uscale**2 ) ) + MEKE_decay(i,j) = damp_rate(i,j) * G%mask2dT(i,j) + enddo ; enddo + endif + + if (CS%id_src_GM > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_GM(i,j) = src_GM(i,j) * damping(i,j) + enddo ; enddo + endif + + if (CS%id_src_mom_lp > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_mom_lp(i,j) = src_mom_lp(i,j) * damping(i,j) + enddo ; enddo + endif + + if (CS%id_src_mom_bh > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_mom_bh(i,j) = src_mom_bh(i,j) * damping(i,j) + enddo ; enddo + endif + + if (CS%id_src_adv > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_adv(i,j) = src_adv(i,j) * damping(i,j) + enddo ; enddo + endif + + if (CS%id_src_mom_K4 > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_mom_K4(i,j) = src_mom_K4(i,j) * damping(i,j) + enddo ; enddo + endif + + if (CS%id_src_btm_drag > 0) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + src_btm_drag(i,j) = -MEKE_current(i,j) * (damp_step & + * ((damp_rate(i,j) + damp_rate_s1(i,j)) * damping(i,j)) & + ) enddo ; enddo endif - !$OMP parallel do default(shared) - do j=js,je ; do i=is,ie - ldamping = CS%MEKE_damping + drag_rate(i,j) * bottomFac2(i,j) - if (MEKE%MEKE(i,j) < 0.) ldamping = 0. - ! notice that the above line ensures a damping only if MEKE is positive, - ! while leaving MEKE unchanged if it is negative - MEKE%MEKE(i,j) = MEKE%MEKE(i,j) / (1.0 + sdt_damp*ldamping) - MEKE_decay(i,j) = ldamping*G%mask2dT(i,j) - enddo ; enddo endif endif ! MEKE_KH>=0 if (CS%debug) then - call hchksum(MEKE%MEKE, "MEKE post-update MEKE", G%HI, haloshift=0, scale=US%L_T_to_m_s**2) + call hchksum(MEKE%MEKE, "MEKE post-update MEKE", G%HI, haloshift=0, unscale=US%L_T_to_m_s**2) endif - call cpu_clock_begin(CS%id_clock_pass) - call do_group_pass(CS%pass_MEKE, G%Domain) - call cpu_clock_end(CS%id_clock_pass) + case(EKE_FILE) + call time_interp_external(CS%eke_handle, Time, data_eke, scale=US%m_s_to_L_T**2) + do j=js,je ; do i=is,ie + MEKE%MEKE(i,j) = data_eke(i,j) * G%mask2dT(i,j) + enddo ; enddo + call MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, MEKE%MEKE, depth_tot, bottomFac2, barotrFac2, LmixScale) + case(EKE_DBCLIENT) + call pass_vector(u, v, G%Domain) + call MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, MEKE%MEKE, depth_tot, bottomFac2, barotrFac2, LmixScale) + call ML_MEKE_calculate_features(G, GV, US, CS, MEKE%Rd_dx_h, u, v, tv, h, dt, features_array) + call predict_MEKE(G, US, CS, SIZE(h), Time, features_array, MEKE%MEKE) + case default + call MOM_error(FATAL,"Invalid method specified for calculating EKE") + end select - ! Calculate diffusivity for main model to use - if (CS%MEKE_KhCoeff>0.) then - if (.not.CS%MEKE_GEOMETRIC) then - if (CS%use_old_lscale) then - if (CS%Rd_as_max_scale) then - !$OMP parallel do default(shared) - do j=js,je ; do i=is,ie - MEKE%Kh(i,j) = (CS%MEKE_KhCoeff * & - sqrt(2.*max(0.,barotrFac2(i,j)*MEKE%MEKE(i,j))*G%areaT(i,j)) ) * & - min(MEKE%Rd_dx_h(i,j), 1.0) - enddo ; enddo - else - !$OMP parallel do default(shared) - do j=js,je ; do i=is,ie - MEKE%Kh(i,j) = CS%MEKE_KhCoeff * & - sqrt(2.*max(0., barotrFac2(i,j)*MEKE%MEKE(i,j))*G%areaT(i,j)) - enddo ; enddo - endif + if (CS%MEKE_positive) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE%MEKE(i,j) = MAX(0., MEKE%MEKE(i,j)) + enddo ; enddo + endif + + call cpu_clock_begin(CS%id_clock_pass) + call do_group_pass(CS%pass_MEKE, G%Domain) + call cpu_clock_end(CS%id_clock_pass) + + ! Calculate diffusivity for main model to use + if (CS%MEKE_KhCoeff>0.) then + if (.not.CS%MEKE_GEOMETRIC) then + if (CS%use_old_lscale) then + if (CS%Rd_as_max_scale) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE%Kh(i,j) = (CS%MEKE_KhCoeff * & + sqrt(2.*max(0.,barotrFac2(i,j)*MEKE%MEKE(i,j))*G%areaT(i,j)) ) * & + min(MEKE%Rd_dx_h(i,j), 1.0) + enddo ; enddo else !$OMP parallel do default(shared) do j=js,je ; do i=is,ie MEKE%Kh(i,j) = CS%MEKE_KhCoeff * & - sqrt(2.*max(0., barotrFac2(i,j)*MEKE%MEKE(i,j))) * LmixScale(i,j) + sqrt(2.*max(0., barotrFac2(i,j)*MEKE%MEKE(i,j))*G%areaT(i,j)) enddo ; enddo endif + else + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE%Kh(i,j) = CS%MEKE_KhCoeff * & + sqrt(2.*max(0., barotrFac2(i,j)*MEKE%MEKE(i,j))) * LmixScale(i,j) + enddo ; enddo endif endif + endif - ! Calculate viscosity for the main model to use - if (CS%viscosity_coeff_Ku /=0.) then - do j=js,je ; do i=is,ie - MEKE%Ku(i,j) = CS%viscosity_coeff_Ku * sqrt(2.*max(0.,MEKE%MEKE(i,j))) * LmixScale(i,j) - enddo ; enddo - endif + ! Calculate viscosity for the main model to use + if (CS%viscosity_coeff_Ku /=0.) then + do j=js,je ; do i=is,ie + MEKE%Ku(i,j) = CS%viscosity_coeff_Ku * sqrt(2.*max(0.,MEKE%MEKE(i,j))) * LmixScale(i,j) + enddo ; enddo + endif - if (CS%viscosity_coeff_Au /=0.) then - do j=js,je ; do i=is,ie - MEKE%Au(i,j) = CS%viscosity_coeff_Au * sqrt(2.*max(0.,MEKE%MEKE(i,j))) * LmixScale(i,j)**3 - enddo ; enddo - endif + if (CS%viscosity_coeff_Au /=0.) then + do j=js,je ; do i=is,ie + MEKE%Au(i,j) = CS%viscosity_coeff_Au * sqrt(2.*max(0.,MEKE%MEKE(i,j))) * LmixScale(i,j)**3 + enddo ; enddo + endif - if (allocated(MEKE%Kh) .or. allocated(MEKE%Ku) .or. allocated(MEKE%Au)) 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) - endif + 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) + endif - ! Offer fields for averaging. - if (any([CS%id_Ue, CS%id_Ub, CS%id_Ut] > 0)) & - tmp(:,:) = 0. - if (CS%id_MEKE>0) call post_data(CS%id_MEKE, MEKE%MEKE, CS%diag) - if (CS%id_Ue>0) then - do j=js,je ; do i=is,ie - tmp(i,j) = sqrt(max(0., 2. * MEKE%MEKE(i,j))) - enddo ; enddo - call post_data(CS%id_Ue, tmp, CS%diag) - endif - if (CS%id_Ub>0) then - do j=js,je ; do i=is,ie - tmp(i,j) = sqrt(max(0., 2. * MEKE%MEKE(i,j) * bottomFac2(i,j))) - enddo ; enddo - call post_data(CS%id_Ub, tmp, CS%diag) - endif - if (CS%id_Ut>0) then - do j=js,je ; do i=is,ie - tmp(i,j) = sqrt(max(0., 2. * MEKE%MEKE(i,j) * barotrFac2(i,j))) - enddo ; enddo - call post_data(CS%id_Ut, tmp, CS%diag) - endif - if (CS%id_Kh>0) call post_data(CS%id_Kh, MEKE%Kh, CS%diag) - if (CS%id_Ku>0) call post_data(CS%id_Ku, MEKE%Ku, CS%diag) - if (CS%id_Au>0) call post_data(CS%id_Au, MEKE%Au, CS%diag) - if (CS%id_KhMEKE_u>0) call post_data(CS%id_KhMEKE_u, Kh_u, CS%diag) - if (CS%id_KhMEKE_v>0) call post_data(CS%id_KhMEKE_v, Kh_v, CS%diag) - if (CS%id_src>0) call post_data(CS%id_src, src, CS%diag) - if (CS%id_decay>0) call post_data(CS%id_decay, MEKE_decay, CS%diag) - if (CS%id_GM_src>0) call post_data(CS%id_GM_src, MEKE%GM_src, CS%diag) - if (CS%id_mom_src>0) call post_data(CS%id_mom_src, MEKE%mom_src, CS%diag) - if (CS%id_GME_snk>0) call post_data(CS%id_GME_snk, MEKE%GME_snk, CS%diag) - if (CS%id_Le>0) call post_data(CS%id_Le, LmixScale, CS%diag) - if (CS%id_gamma_b>0) then - do j=js,je ; do i=is,ie - bottomFac2(i,j) = sqrt(bottomFac2(i,j)) - enddo ; enddo - call post_data(CS%id_gamma_b, bottomFac2, CS%diag) - endif - if (CS%id_gamma_t>0) then - do j=js,je ; do i=is,ie - barotrFac2(i,j) = sqrt(barotrFac2(i,j)) - enddo ; enddo - call post_data(CS%id_gamma_t, barotrFac2, CS%diag) - endif + ! Offer fields for averaging. + if (any([CS%id_Ue, CS%id_Ub, CS%id_Ut] > 0)) & + tmp(:,:) = 0. + if (CS%id_MEKE>0) call post_data(CS%id_MEKE, MEKE%MEKE, CS%diag) + if (CS%id_Ue>0) then + do j=js,je ; do i=is,ie + tmp(i,j) = sqrt(max(0., 2. * MEKE%MEKE(i,j))) + enddo ; enddo + call post_data(CS%id_Ue, tmp, CS%diag) + endif + if (CS%id_Ub>0) then + do j=js,je ; do i=is,ie + tmp(i,j) = sqrt(max(0., 2. * MEKE%MEKE(i,j) * bottomFac2(i,j))) + enddo ; enddo + call post_data(CS%id_Ub, tmp, CS%diag) + endif + if (CS%id_Ut>0) then + do j=js,je ; do i=is,ie + tmp(i,j) = sqrt(max(0., 2. * MEKE%MEKE(i,j) * barotrFac2(i,j))) + enddo ; enddo + call post_data(CS%id_Ut, tmp, CS%diag) + endif + if (CS%id_Kh>0) call post_data(CS%id_Kh, MEKE%Kh, CS%diag) + if (CS%id_Ku>0) call post_data(CS%id_Ku, MEKE%Ku, CS%diag) + if (CS%id_Au>0) call post_data(CS%id_Au, MEKE%Au, CS%diag) + if (CS%id_KhMEKE_u>0) call post_data(CS%id_KhMEKE_u, Kh_u, CS%diag) + if (CS%id_KhMEKE_v>0) call post_data(CS%id_KhMEKE_v, Kh_v, CS%diag) + if (CS%id_src>0) call post_data(CS%id_src, src, CS%diag) + if (CS%id_src_adv>0) call post_data(CS%id_src_adv, src_adv, CS%diag) + if (CS%id_src_mom_K4>0) call post_data(CS%id_src_mom_K4, src_mom_K4, CS%diag) + if (CS%id_src_btm_drag>0) call post_data(CS%id_src_btm_drag, src_btm_drag, CS%diag) + if (CS%id_src_GM>0) call post_data(CS%id_src_GM, src_GM, CS%diag) + if (CS%id_src_mom_lp>0) call post_data(CS%id_src_mom_lp, src_mom_lp, CS%diag) + if (CS%id_src_mom_bh>0) call post_data(CS%id_src_mom_bh, src_mom_bh, CS%diag) + if (CS%id_decay>0) call post_data(CS%id_decay, MEKE_decay, CS%diag) + if (CS%id_GM_src>0) call post_data(CS%id_GM_src, MEKE%GM_src, CS%diag) + if (CS%id_mom_src>0) call post_data(CS%id_mom_src, MEKE%mom_src, CS%diag) + if (CS%id_mom_src_bh>0) call post_data(CS%id_mom_src_bh, MEKE%mom_src_bh, CS%diag) + if (CS%id_GME_snk>0) call post_data(CS%id_GME_snk, MEKE%GME_snk, CS%diag) + if (CS%id_Le>0) call post_data(CS%id_Le, LmixScale, CS%diag) + if (CS%id_gamma_b>0) then + do j=js,je ; do i=is,ie + bottomFac2(i,j) = sqrt(bottomFac2(i,j)) + enddo ; enddo + call post_data(CS%id_gamma_b, bottomFac2, CS%diag) + endif + if (CS%id_gamma_t>0) then + do j=js,je ; do i=is,ie + barotrFac2(i,j) = sqrt(barotrFac2(i,j)) + enddo ; enddo + call post_data(CS%id_gamma_t, barotrFac2, CS%diag) + endif end subroutine step_forward_MEKE @@ -681,33 +996,31 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: SN_u !< Eady growth rate at u-points [T-1 ~> s-1]. real, dimension(SZI_(G),SZJB_(G)), intent(in) :: SN_v !< Eady growth rate at v-points [T-1 ~> s-1]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: drag_rate_visc !< Mean flow velocity contribution - !! to the MEKE drag rate [L T-1 ~> m s-1] + !! to the MEKE drag rate [H T-1 ~> m s-1 or kg m-2 s-1] real, dimension(SZI_(G),SZJ_(G)), intent(in) :: I_mass !< Inverse of column mass [R-1 Z-1 ~> m2 kg-1]. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: depth_tot !< The depth of the water column [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: depth_tot !< The thickness of the water column [H ~> m or kg m-2]. ! Local variables - real :: beta ! Combined topograpic and planetary vorticity gradient [T-1 L-1 ~> s-1 m-1] + real :: beta ! Combined topographic and planetary vorticity gradient [T-1 L-1 ~> s-1 m-1] real :: SN ! The local Eady growth rate [T-1 ~> s-1] real :: bottomFac2, barotrFac2 ! Vertical structure factors [nondim] real :: LmixScale, LRhines, LEady ! Various mixing length scales [L ~> m] - real :: I_H, KhCoeff + real :: KhCoeff ! A copy of MEKE_KhCoeff from the control structure [nondim] real :: Kh ! A lateral diffusivity [L2 T-1 ~> m2 s-1] real :: Ubg2 ! Background (tidal?) velocity squared [L2 T-2 ~> m2 s-2] - real :: cd2 + real :: cd2 ! The square of the drag coefficient times unit conversion factors [H2 L-2 ~> nondim or kg2 m-6] real :: drag_rate ! The MEKE spindown timescale due to bottom drag [T-1 ~> s-1]. real :: src ! The sum of MEKE sources [L2 T-3 ~> W kg-1] real :: ldamping ! The MEKE damping rate [T-1 ~> s-1]. real :: EKE, EKEmin, EKEmax, EKEerr ! [L2 T-2 ~> m2 s-2] real :: resid, ResMin, ResMax ! Residuals [L2 T-3 ~> W kg-1] - real :: FatH ! Coriolis parameter at h points; to compute topographic beta [T-1 ~> s-1] + real :: FatH ! Coriolis parameter at h points, used to compute topographic beta [T-1 ~> s-1] real :: beta_topo_x, beta_topo_y ! Topographic PV gradients in x and y [T-1 L-1 ~> s-1 m-1] - real :: dZ_neglect ! A negligible change in height [Z ~> m] + real :: h_neglect ! A negligible thickness [H ~> m or kg m-2] integer :: i, j, is, ie, js, je, n1, n2 real :: tolerance ! Width of EKE bracket [L2 T-2 ~> m2 s-2]. logical :: useSecant, debugIteration - real :: Lgrid, Ldeform, Lfrict - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec debugIteration = .false. @@ -715,7 +1028,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m Ubg2 = CS%MEKE_Uscale**2 cd2 = CS%cdrag**2 tolerance = 1.0e-12*US%m_s_to_L_T**2 - dZ_neglect = GV%H_to_Z*GV%H_subroundoff + h_neglect = GV%H_subroundoff !$OMP do do j=js,je ; do i=is,ie @@ -724,7 +1037,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m SN = min(SN_u(I,j), SN_u(I-1,j), SN_v(i,J), SN_v(i,J-1)) if (CS%MEKE_equilibrium_alt) then - MEKE%MEKE(i,j) = (CS%MEKE_GEOMETRIC_alpha * SN * US%Z_to_m*depth_tot(i,j))**2 / cd2 + MEKE%MEKE(i,j) = (CS%MEKE_GEOMETRIC_alpha * SN * depth_tot(i,j))**2 / cd2 else FatH = 0.25*((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) + & (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J-1))) ! Coriolis parameter at h points @@ -736,21 +1049,19 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m !### Consider different combinations of these estimates of topographic beta. beta_topo_x = -CS%MEKE_topographic_beta * FatH * 0.5 * ( & (depth_tot(i+1,j)-depth_tot(i,j)) * G%IdxCu(I,j) & - / max(depth_tot(i+1,j), depth_tot(i,j), dZ_neglect) & + / max(depth_tot(i+1,j), depth_tot(i,j), h_neglect) & + (depth_tot(i,j)-depth_tot(i-1,j)) * G%IdxCu(I-1,j) & - / max(depth_tot(i,j), depth_tot(i-1,j), dZ_neglect) ) + / max(depth_tot(i,j), depth_tot(i-1,j), h_neglect) ) beta_topo_y = -CS%MEKE_topographic_beta * FatH * 0.5 * ( & (depth_tot(i,j+1)-depth_tot(i,j)) * G%IdyCv(i,J) & - / max(depth_tot(i,j+1), depth_tot(i,j), dZ_neglect) + & + / max(depth_tot(i,j+1), depth_tot(i,j), h_neglect) + & (depth_tot(i,j)-depth_tot(i,j-1)) * G%IdyCv(i,J-1) & - / max(depth_tot(i,j), depth_tot(i,j-1), dZ_neglect) ) + / max(depth_tot(i,j), depth_tot(i,j-1), h_neglect) ) endif - beta = sqrt((G%dF_dx(i,j) + beta_topo_x)**2 + & - (G%dF_dy(i,j) + beta_topo_y)**2 ) - - I_H = US%L_to_Z*GV%Rho0 * I_mass(i,j) + beta = sqrt(((G%dF_dx(i,j) + beta_topo_x)**2) + & + ((G%dF_dy(i,j) + beta_topo_y)**2) ) - if (KhCoeff*SN*I_H>0.) then + if (KhCoeff*SN*I_mass(i,j)>0.) then ! Solve resid(E) = 0, where resid = Kh(E) * (SN)^2 - damp_rate(E) E EKEmin = 0. ! Use the trivial root as the left bracket ResMin = 0. ! Need to detect direction of left residual @@ -768,7 +1079,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m ! TODO: Should include resolution function in Kh Kh = (KhCoeff * sqrt(2.*barotrFac2*EKE) * LmixScale) src = Kh * (SN * SN) - drag_rate = I_H * sqrt(drag_rate_visc(i,j)**2 + cd2 * ( 2.0*bottomFac2*EKE + Ubg2 ) ) + drag_rate = (GV%H_to_RZ * I_mass(i,j)) * sqrt(drag_rate_visc(i,j)**2 + cd2 * ( 2.0*bottomFac2*EKE + Ubg2 ) ) ldamping = CS%MEKE_damping + drag_rate * bottomFac2 resid = src - ldamping * EKE ! if (debugIteration) then @@ -808,7 +1119,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m ! TODO: Should include resolution function in Kh Kh = (KhCoeff * sqrt(2.*barotrFac2*EKE) * LmixScale) src = Kh * (SN * SN) - drag_rate = I_H * sqrt( drag_rate_visc(i,j)**2 + cd2 * ( 2.0*bottomFac2*EKE + Ubg2 ) ) + drag_rate = (GV%H_to_RZ * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 + cd2 * ( 2.0*bottomFac2*EKE + Ubg2 ) ) ldamping = CS%MEKE_damping + drag_rate * bottomFac2 resid = src - ldamping * EKE if (useSecant .and. resid>ResMin) useSecant = .false. @@ -837,21 +1148,22 @@ end subroutine MEKE_equilibrium !< This subroutine calculates a new equilibrium value for MEKE at each time step. This is not copied into !! MEKE%MEKE; rather, it is used as a restoring term to nudge MEKE%MEKE back to an equilibrium value -subroutine MEKE_equilibrium_restoring(CS, G, US, SN_u, SN_v, depth_tot, & +subroutine MEKE_equilibrium_restoring(CS, G, GV, US, SN_u, SN_v, depth_tot, & equilibrium_value) type(ocean_grid_type), intent(inout) :: G !< Ocean grid. + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type. type(MEKE_CS), intent(in) :: CS !< MEKE control structure. real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: SN_u !< Eady growth rate at u-points [T-1 ~> s-1]. real, dimension(SZI_(G),SZJB_(G)), intent(in) :: SN_v !< Eady growth rate at v-points [T-1 ~> s-1]. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: depth_tot !< The depth of the water column [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: depth_tot !< The thickness of the water column [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(out) :: equilibrium_value !< Equilbrium value of MEKE to be calculated at each time step [L2 T-2 ~> m2 s-2] ! Local variables real :: SN ! The local Eady growth rate [T-1 ~> s-1] integer :: i, j, is, ie, js, je ! local indices - real :: cd2 ! bottom drag + real :: cd2 ! The square of the drag coefficient [nondim] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec cd2 = CS%cdrag**2 @@ -862,7 +1174,7 @@ subroutine MEKE_equilibrium_restoring(CS, G, US, SN_u, SN_v, depth_tot, & ! SN = 0.25*max( (SN_u(I,j) + SN_u(I-1,j)) + (SN_v(i,J) + SN_v(i,J-1)), 0.) ! This avoids extremes values in equilibrium solution due to bad values in SN_u, SN_v SN = min(SN_u(I,j), SN_u(I-1,j), SN_v(i,J), SN_v(i,J-1)) - equilibrium_value(i,j) = (CS%MEKE_GEOMETRIC_alpha * SN * US%Z_to_L*depth_tot(i,j))**2 / cd2 + equilibrium_value(i,j) = (CS%MEKE_GEOMETRIC_alpha * SN * depth_tot(i,j))**2 / cd2 enddo ; enddo if (CS%id_MEKE_equilibrium>0) call post_data(CS%id_MEKE_equilibrium, equilibrium_value, CS%diag) @@ -881,21 +1193,21 @@ subroutine MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, EKE, depth_tot, & real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: SN_u !< Eady growth rate at u-points [T-1 ~> s-1]. real, dimension(SZI_(G),SZJB_(G)), intent(in) :: SN_v !< Eady growth rate at v-points [T-1 ~> s-1]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: EKE !< Eddy kinetic energy [L2 T-2 ~> m2 s-2]. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: depth_tot !< The depth of the water column [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: depth_tot !< The thickness of the water column [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(out) :: bottomFac2 !< gamma_b^2 [nondim] real, dimension(SZI_(G),SZJ_(G)), intent(out) :: barotrFac2 !< gamma_t^2 [nondim] real, dimension(SZI_(G),SZJ_(G)), intent(out) :: LmixScale !< Eddy mixing length [L ~> m]. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: LRhines, LEady ! Possible mixing length scales [L ~> m] - real :: beta ! Combined topograpic and planetary vorticity gradient [T-1 L-1 ~> s-1 m-1] + real :: beta ! Combined topographic and planetary vorticity gradient [T-1 L-1 ~> s-1 m-1] real :: SN ! The local Eady growth rate [T-1 ~> s-1] real :: FatH ! Coriolis parameter at h points [T-1 ~> s-1] real :: beta_topo_x, beta_topo_y ! Topographic PV gradients in x and y [T-1 L-1 ~> s-1 m-1] - real :: dZ_neglect ! A negligible change in height [Z ~> m] + real :: h_neglect ! A negligible thickness [H ~> m or kg m-2] integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - dZ_neglect = GV%H_to_Z*GV%H_subroundoff + h_neglect = GV%H_subroundoff !$OMP do do j=js,je ; do i=is,ie @@ -917,17 +1229,17 @@ subroutine MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, EKE, depth_tot, & !### Consider different combinations of these estimates of topographic beta. beta_topo_x = -CS%MEKE_topographic_beta * FatH * 0.5 * ( & (depth_tot(i+1,j)-depth_tot(i,j)) * G%IdxCu(I,j) & - / max(depth_tot(i+1,j), depth_tot(i,j), dZ_neglect) & + / max(depth_tot(i+1,j), depth_tot(i,j), h_neglect) & + (depth_tot(i,j)-depth_tot(i-1,j)) * G%IdxCu(I-1,j) & - / max(depth_tot(i,j), depth_tot(i-1,j), dZ_neglect) ) + / max(depth_tot(i,j), depth_tot(i-1,j), h_neglect) ) beta_topo_y = -CS%MEKE_topographic_beta * FatH * 0.5 * ( & (depth_tot(i,j+1)-depth_tot(i,j)) * G%IdyCv(i,J) & - / max(depth_tot(i,j+1), depth_tot(i,j), dZ_neglect) + & + / max(depth_tot(i,j+1), depth_tot(i,j), h_neglect) + & (depth_tot(i,j)-depth_tot(i,j-1)) * G%IdyCv(i,J-1) & - / max(depth_tot(i,j), depth_tot(i,j-1), dZ_neglect) ) + / max(depth_tot(i,j), depth_tot(i,j-1), h_neglect) ) endif - beta = sqrt((G%dF_dx(i,j) + beta_topo_x)**2 + & - (G%dF_dy(i,j) + beta_topo_y)**2 ) + beta = sqrt(((G%dF_dx(i,j) + beta_topo_x)**2) + & + ((G%dF_dy(i,j) + beta_topo_y)**2) ) else beta = 0. @@ -946,20 +1258,18 @@ end subroutine MEKE_lengthScales !> Calculates the eddy mixing length scale and \f$\gamma_b\f$ and \f$\gamma_t\f$ !! functions that are ratios of either bottom or barotropic eddy energy to the !! column eddy energy, respectively. See \ref section_MEKE_equations. -subroutine MEKE_lengthScales_0d(CS, US, area, beta, depth, Rd_dx, SN, EKE, & ! Z_to_L, & +subroutine MEKE_lengthScales_0d(CS, US, area, beta, depth_tot, Rd_dx, SN, EKE, & bottomFac2, barotrFac2, LmixScale, Lrhines, Leady) type(MEKE_CS), intent(in) :: CS !< MEKE control structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(in) :: area !< Grid cell area [L2 ~> m2] real, intent(in) :: beta !< Planetary beta = \f$ \nabla f\f$ [T-1 L-1 ~> s-1 m-1] - real, intent(in) :: depth !< Ocean depth [Z ~> m] + real, intent(in) :: depth_tot !< The total thickness of the water column [H ~> m or kg m-2] real, intent(in) :: Rd_dx !< Resolution Ld/dx [nondim]. real, intent(in) :: SN !< Eady growth rate [T-1 ~> s-1]. real, intent(in) :: EKE !< Eddy kinetic energy [L2 T-2 ~> m2 s-2]. -! real, intent(in) :: Z_to_L !< A conversion factor from depth units (Z) to -! !! the units for lateral distances (L). - real, intent(out) :: bottomFac2 !< gamma_b^2 - real, intent(out) :: barotrFac2 !< gamma_t^2 + real, intent(out) :: bottomFac2 !< gamma_b^2 [nondim] + real, intent(out) :: barotrFac2 !< gamma_t^2 [nondim] real, intent(out) :: LmixScale !< Eddy mixing length [L ~> m]. real, intent(out) :: Lrhines !< Rhines length scale [L ~> m]. real, intent(out) :: Leady !< Eady length scale [L ~> m]. @@ -970,7 +1280,7 @@ subroutine MEKE_lengthScales_0d(CS, US, area, beta, depth, Rd_dx, SN, EKE, & ! Z ! Length scale for MEKE derived diffusivity Lgrid = sqrt(area) ! Grid scale Ldeform = Lgrid * Rd_dx ! Deformation scale - Lfrict = (US%Z_to_L * depth) / CS%cdrag ! Frictional arrest scale + Lfrict = depth_tot / CS%cdrag ! Frictional arrest scale ! gamma_b^2 is the ratio of bottom eddy energy to mean column eddy energy ! used in calculating bottom drag bottomFac2 = CS%MEKE_CD_SCALE**2 @@ -996,7 +1306,7 @@ subroutine MEKE_lengthScales_0d(CS, US, area, beta, depth, Rd_dx, SN, EKE, & ! Z Leady = 0. endif if (CS%use_min_lscale) then - LmixScale = 1.e7*US%m_to_L + LmixScale = CS%lscale_maxval if (CS%aDeform*Ldeform > 0.) LmixScale = min(LmixScale,CS%aDeform*Ldeform) if (CS%aFrict *Lfrict > 0.) LmixScale = min(LmixScale,CS%aFrict *Lfrict) if (CS%aRhines*Lrhines > 0.) LmixScale = min(LmixScale,CS%aRhines*Lrhines) @@ -1019,25 +1329,27 @@ end subroutine MEKE_lengthScales_0d !> Initializes the MOM_MEKE module and reads parameters. !! Returns True if module is to be used, otherwise returns False. -logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) +logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, MEKE, restart_CS, meke_in_dynamics) type(time_type), intent(in) :: Time !< The current model time. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file parser structure. + type(dbcomms_CS_type), intent(in) :: dbcomms_CS !< Database communications control structure type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics structure. type(MEKE_CS), intent(inout) :: CS !< MEKE control structure. type(MEKE_type), intent(inout) :: MEKE !< MEKE fields - type(MOM_restart_CS), intent(in) :: restart_CS !< MOM restart control struct + type(MOM_restart_CS), intent(in) :: restart_CS !< MOM restart control structure + logical, intent( out) :: meke_in_dynamics !< If true, MEKE is stepped forward in dynamics + !! otherwise in tracer dynamics ! Local variables - real :: I_T_rescale ! A rescaling factor for time from the internal representation in this - ! run to the representation in a restart file. - real :: L_rescale ! A rescaling factor for length from the internal representation in this - ! run to the representation in a restart file. - real :: MEKE_restoring_timescale ! The timescale used to nudge MEKE toward its equilibrium value. + real :: MEKE_restoring_timescale ! The timescale used to nudge MEKE toward its equilibrium value [T ~> s] real :: cdrag ! The default bottom drag coefficient [nondim]. + character(len=200) :: eke_filename, eke_varname, inputdir + character(len=16) :: eke_source_str integer :: i, j, is, ie, js, je, isd, ied, jsd, jed - logical :: laplacian, biharmonic, useVarMix, coldStart + logical :: laplacian, biharmonic, coldStart ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_MEKE" ! This module's name. @@ -1054,75 +1366,120 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) default=.false.) if (.not. MEKE_init) return CS%initialized = .true. + call get_param(param_file, mdl, "MEKE_IN_DYNAMICS", meke_in_dynamics, & + "If true, step MEKE forward with the dynamics "// & + "otherwise with the tracer timestep.", & + default=.true.) + + call get_param(param_file, mdl, "EKE_SOURCE", eke_source_str, & + "Determine the where EKE comes from:\n" // & + " 'prog': Calculated solving EKE equation\n"// & + " 'file': Read in from a file\n" // & + " 'dbclient': Retrieved from ML-database", default='prog') call MOM_mesg("MEKE_init: reading parameters ", 5) - ! Read all relevant parameters and write them to the model log. - call get_param(param_file, mdl, "MEKE_DAMPING", CS%MEKE_damping, & - "The local depth-independent MEKE dissipation rate.", & - units="s-1", default=0.0, scale=US%T_to_s) - call get_param(param_file, mdl, "MEKE_CD_SCALE", CS%MEKE_Cd_scale, & - "The ratio of the bottom eddy velocity to the column mean "//& - "eddy velocity, i.e. sqrt(2*MEKE). This should be less than 1 "//& - "to account for the surface intensification of MEKE.", & - units="nondim", default=0.) - call get_param(param_file, mdl, "MEKE_CB", CS%MEKE_Cb, & - "A coefficient in the expression for the ratio of bottom projected "//& - "eddy energy and mean column energy (see Jansen et al. 2015).",& - units="nondim", default=25.) - call get_param(param_file, mdl, "MEKE_MIN_GAMMA2", CS%MEKE_min_gamma, & - "The minimum allowed value of gamma_b^2.",& - units="nondim", default=0.0001) - call get_param(param_file, mdl, "MEKE_CT", CS%MEKE_Ct, & - "A coefficient in the expression for the ratio of barotropic "//& - "eddy energy and mean column energy (see Jansen et al. 2015).",& - units="nondim", default=50.) - call get_param(param_file, mdl, "MEKE_GMCOEFF", CS%MEKE_GMcoeff, & - "The efficiency of the conversion of potential energy "//& - "into MEKE by the thickness mixing parameterization. "//& - "If MEKE_GMCOEFF is negative, this conversion is not "//& - "used or calculated.", units="nondim", default=-1.0) - call get_param(param_file, mdl, "MEKE_GEOMETRIC", CS%MEKE_GEOMETRIC, & - "If MEKE_GEOMETRIC is true, uses the GM coefficient formulation "//& - "from the GEOMETRIC framework (Marshall et al., 2012).", default=.false.) - call get_param(param_file, mdl, "MEKE_GEOMETRIC_ALPHA", CS%MEKE_GEOMETRIC_alpha, & - "The nondimensional coefficient governing the efficiency of the GEOMETRIC \n"//& - "thickness diffusion.", units="nondim", default=0.05) - call get_param(param_file, mdl, "MEKE_EQUILIBRIUM_ALT", CS%MEKE_equilibrium_alt, & - "If true, use an alternative formula for computing the (equilibrium)"//& - "initial value of MEKE.", default=.false.) - call get_param(param_file, mdl, "MEKE_EQUILIBRIUM_RESTORING", CS%MEKE_equilibrium_restoring, & - "If true, restore MEKE back to its equilibrium value, which is calculated at "//& - "each time step.", default=.false.) - if (CS%MEKE_equilibrium_restoring) then - call get_param(param_file, mdl, "MEKE_RESTORING_TIMESCALE", MEKE_restoring_timescale, & - "The timescale used to nudge MEKE toward its equilibrium value.", units="s", & - default=1e6, scale=US%s_to_T) - CS%MEKE_restoring_rate = 1.0 / MEKE_restoring_timescale - endif + select case (lowercase(eke_source_str)) + case("file") + CS%eke_src = EKE_FILE + call time_interp_external_init + call get_param(param_file, mdl, "EKE_FILE", eke_filename, & + "A file in which to find the eddy kineteic energy variable.", & + default="eke_file.nc") + call get_param(param_file, mdl, "EKE_VARIABLE", eke_varname, & + "The name of the eddy kinetic energy variable to read from "//& + "EKE_FILE to use in MEKE.", & + default="eke") + call get_param(param_file, mdl, "INPUTDIR", inputdir, & + "The directory in which all input files are found.", & + default=".", do_not_log=.true.) + inputdir = slasher(inputdir) + + eke_filename = trim(inputdir) // trim(eke_filename) + CS%eke_handle = init_external_field(eke_filename, eke_varname, domain=G%Domain%mpp_domain) + case("prog") + CS%eke_src = EKE_PROG + ! Read all relevant parameters and write them to the model log. + call get_param(param_file, mdl, "MEKE_DAMPING", CS%MEKE_damping, & + "The local depth-independent MEKE dissipation rate.", & + units="s-1", default=0.0, scale=US%T_to_s) + call get_param(param_file, mdl, "MEKE_CD_SCALE", CS%MEKE_Cd_scale, & + "The ratio of the bottom eddy velocity to the column mean "//& + "eddy velocity, i.e. sqrt(2*MEKE). This should be less than 1 "//& + "to account for the surface intensification of MEKE.", & + units="nondim", default=0.) + call get_param(param_file, mdl, "MEKE_CB", CS%MEKE_Cb, & + "A coefficient in the expression for the ratio of bottom projected "//& + "eddy energy and mean column energy (see Jansen et al. 2015).",& + units="nondim", default=25.) + call get_param(param_file, mdl, "MEKE_MIN_GAMMA2", CS%MEKE_min_gamma, & + "The minimum allowed value of gamma_b^2.",& + units="nondim", default=0.0001) + call get_param(param_file, mdl, "MEKE_CT", CS%MEKE_Ct, & + "A coefficient in the expression for the ratio of barotropic "//& + "eddy energy and mean column energy (see Jansen et al. 2015).",& + units="nondim", default=50.) + call get_param(param_file, mdl, "MEKE_GMCOEFF", CS%MEKE_GMcoeff, & + "The efficiency of the conversion of potential energy "//& + "into MEKE by the thickness mixing parameterization. "//& + "If MEKE_GMCOEFF is negative, this conversion is not "//& + "used or calculated.", units="nondim", default=-1.0) + call get_param(param_file, mdl, "MEKE_GEOMETRIC", CS%MEKE_GEOMETRIC, & + "If MEKE_GEOMETRIC is true, uses the GM coefficient formulation "//& + "from the GEOMETRIC framework (Marshall et al., 2012).", default=.false.) + call get_param(param_file, mdl, "MEKE_GEOMETRIC_ALPHA", CS%MEKE_GEOMETRIC_alpha, & + "The nondimensional coefficient governing the efficiency of the GEOMETRIC \n"//& + "thickness diffusion.", units="nondim", default=0.05) + call get_param(param_file, mdl, "MEKE_EQUILIBRIUM_ALT", CS%MEKE_equilibrium_alt, & + "If true, use an alternative formula for computing the (equilibrium) "//& + "initial value of MEKE.", default=.false.) + call get_param(param_file, mdl, "MEKE_EQUILIBRIUM_RESTORING", CS%MEKE_equilibrium_restoring, & + "If true, restore MEKE back to its equilibrium value, which is calculated at "//& + "each time step.", default=.false.) + if (CS%MEKE_equilibrium_restoring) then + call get_param(param_file, mdl, "MEKE_RESTORING_TIMESCALE", MEKE_restoring_timescale, & + "The timescale used to nudge MEKE toward its equilibrium value.", & + units="s", default=1e6, scale=US%s_to_T) + CS%MEKE_restoring_rate = 1.0 / MEKE_restoring_timescale + endif - call get_param(param_file, mdl, "MEKE_FRCOEFF", CS%MEKE_FrCoeff, & + call get_param(param_file, mdl, "MEKE_FRCOEFF", CS%MEKE_FrCoeff, & + "The efficiency of the conversion of mean energy into "//& + "MEKE. If MEKE_FRCOEFF is negative, this conversion "//& + "is not used or calculated.", units="nondim", default=-1.0) + call get_param(param_file, mdl, "MEKE_BHFRCOEFF", CS%MEKE_bhFrCoeff, & "The efficiency of the conversion of mean energy into "//& - "MEKE. If MEKE_FRCOEFF is negative, this conversion "//& - "is not used or calculated.", units="nondim", default=-1.0) - call get_param(param_file, mdl, "MEKE_GMECOEFF", CS%MEKE_GMECoeff, & - "The efficiency of the conversion of MEKE into mean energy "//& - "by GME. If MEKE_GMECOEFF is negative, this conversion "//& + "MEKE by the biharmonic dissipation. If MEKE_bhFRCOEFF is negative, this conversion "//& "is not used or calculated.", units="nondim", default=-1.0) - call get_param(param_file, mdl, "MEKE_BGSRC", CS%MEKE_BGsrc, & - "A background energy source for MEKE.", units="W kg-1", & - default=0.0, scale=US%m_to_L**2*US%T_to_s**3) - call get_param(param_file, mdl, "MEKE_KH", CS%MEKE_Kh, & - "A background lateral diffusivity of MEKE. "//& - "Use a negative value to not apply lateral diffusion to MEKE.", & - units="m2 s-1", default=-1.0, scale=US%m_to_L**2*US%T_to_s) - call get_param(param_file, mdl, "MEKE_K4", CS%MEKE_K4, & - "A lateral bi-harmonic diffusivity of MEKE. "//& - "Use a negative value to not apply bi-harmonic diffusion to MEKE.", & - units="m4 s-1", default=-1.0, scale=US%m_to_L**4*US%T_to_s) - call get_param(param_file, mdl, "MEKE_DTSCALE", CS%MEKE_dtScale, & - "A scaling factor to accelerate the time evolution of MEKE.", & - units="nondim", default=1.0) + call get_param(param_file, mdl, "MEKE_GMECOEFF", CS%MEKE_GMECoeff, & + "The efficiency of the conversion of MEKE into mean energy "//& + "by GME. If MEKE_GMECOEFF is negative, this conversion "//& + "is not used or calculated.", units="nondim", default=-1.0) + call get_param(param_file, mdl, "MEKE_BGSRC", CS%MEKE_BGsrc, & + "A background energy source for MEKE.", & + units="W kg-1", default=0.0, scale=US%m_to_L**2*US%T_to_s**3) + call get_param(param_file, mdl, "MEKE_KH", CS%MEKE_Kh, & + "A background lateral diffusivity of MEKE. "//& + "Use a negative value to not apply lateral diffusion to MEKE.", & + units="m2 s-1", default=-1.0, scale=US%m_to_L**2*US%T_to_s) + call get_param(param_file, mdl, "MEKE_K4", CS%MEKE_K4, & + "A lateral bi-harmonic diffusivity of MEKE. "//& + "Use a negative value to not apply bi-harmonic diffusion to MEKE.", & + units="m4 s-1", default=-1.0, scale=US%m_to_L**4*US%T_to_s) + call get_param(param_file, mdl, "MEKE_DTSCALE", CS%MEKE_dtScale, & + "A scaling factor to accelerate the time evolution of MEKE.", & + units="nondim", default=1.0) + call get_param(param_file, mdl, "MEKE_POSITIVE", CS%MEKE_positive, & + "If true, it guarantees that MEKE will always be >= 0.", & + default=.false.) + case("dbclient") + CS%eke_src = EKE_DBCLIENT + call ML_MEKE_init(diag, G, US, Time, param_file, dbcomms_CS, CS) + case default + call MOM_error(FATAL, "Invalid method selected for calculating EKE") + end select + ! GMM, make sure all parameters used to calculated MEKE are within the above if + call get_param(param_file, mdl, "MEKE_KHCOEFF", CS%MEKE_KhCoeff, & "A scaling factor in the expression for eddy diffusivity "//& "which is otherwise proportional to the MEKE velocity- "//& @@ -1136,15 +1493,17 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) call get_param(param_file, mdl, "MEKE_GM_SRC_ALT", CS%GM_src_alt, & "If true, use the GM energy conversion form S^2*N^2*kappa rather "//& "than the streamfunction for the MEKE GM source term.", default=.false.) + call get_param(param_file, mdl, "MEKE_MIN_DEPTH_TOT", CS%MEKE_min_depth_tot, & + "The minimum total depth over which to distribute MEKE energy sources. "//& + "When the total depth is less than this, the sources are scaled away.", & + units="m", default=1.0, scale=GV%m_to_H, do_not_log=.not.CS%GM_src_alt) call get_param(param_file, mdl, "MEKE_VISC_DRAG", CS%visc_drag, & "If true, use the vertvisc_type to calculate the bottom "//& "drag acting on MEKE.", default=.true.) call get_param(param_file, mdl, "MEKE_KHTH_FAC", MEKE%KhTh_fac, & - "A factor that maps MEKE%Kh to KhTh.", units="nondim", & - default=0.0) + "A factor that maps MEKE%Kh to KhTh.", units="nondim", default=0.0) call get_param(param_file, mdl, "MEKE_KHTR_FAC", MEKE%KhTr_fac, & - "A factor that maps MEKE%Kh to KhTr.", units="nondim", & - default=0.0) + "A factor that maps MEKE%Kh to KhTr.", units="nondim", default=0.0) call get_param(param_file, mdl, "MEKE_KHMEKE_FAC", CS%KhMEKE_Fac, & "A factor that maps MEKE%Kh to Kh for MEKE itself.", & units="nondim", default=0.0) @@ -1156,20 +1515,25 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) "If true, use a strict minimum of provided length scales "//& "rather than harmonic mean.", & default=.false.) + call get_param(param_file, mdl, "MEKE_LSCALE_MAX_VAL", CS%lscale_maxval, & + "The ceiling on the value of the MEKE length scale when MEKE_MIN_LSCALE=True. "//& + "The default is the distance from the equator to the pole on Earth, as "//& + "estimated by enlightenment era scientists, but should probably scale with RAD_EARTH.", & + units="m", default=1.0e7, scale=US%m_to_L, do_not_log=.not.CS%use_min_lscale) call get_param(param_file, mdl, "MEKE_RD_MAX_SCALE", CS%Rd_as_max_scale, & "If true, the length scale used by MEKE is the minimum of "//& "the deformation radius or grid-spacing. Only used if "//& - "MEKE_OLD_LSCALE=True", units="nondim", default=.false.) + "MEKE_OLD_LSCALE=True", default=.false.) call get_param(param_file, mdl, "MEKE_VISCOSITY_COEFF_KU", CS%viscosity_coeff_Ku, & - "If non-zero, is the scaling coefficient in the expression for"//& - "viscosity used to parameterize harmonic lateral momentum mixing by"//& - "unresolved eddies represented by MEKE. Can be negative to"//& + "If non-zero, is the scaling coefficient in the expression for "//& + "viscosity used to parameterize harmonic lateral momentum mixing by "//& + "unresolved eddies represented by MEKE. Can be negative to "//& "represent backscatter from the unresolved eddies.", & units="nondim", default=0.0) call get_param(param_file, mdl, "MEKE_VISCOSITY_COEFF_AU", CS%viscosity_coeff_Au, & - "If non-zero, is the scaling coefficient in the expression for"//& - "viscosity used to parameterize biharmonic lateral momentum mixing by"//& - "unresolved eddies represented by MEKE. Can be negative to"//& + "If non-zero, is the scaling coefficient in the expression for "//& + "viscosity used to parameterize biharmonic lateral momentum mixing by "//& + "unresolved eddies represented by MEKE. Can be negative to "//& "represent backscatter from the unresolved eddies.", & units="nondim", default=0.0) call get_param(param_file, mdl, "MEKE_FIXED_MIXING_LENGTH", CS%Lfixed, & @@ -1178,8 +1542,13 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) units="m", default=0.0, scale=US%m_to_L) call get_param(param_file, mdl, "MEKE_FIXED_TOTAL_DEPTH", CS%fixed_total_depth, & "If true, use the nominal bathymetric depth as the estimate of the "//& - "time-varying ocean depth. Otherwise base the depth on the total ocean mass"//& + "time-varying ocean depth. Otherwise base the depth on the total ocean mass "//& "per unit area.", default=.true.) + call get_param(param_file, mdl, "MEKE_TOTAL_DEPTH_RHO", CS%rho_fixed_total_depth, & + "A density used to translate the nominal bathymetric depth into an estimate "//& + "of the total ocean mass per unit area when MEKE_FIXED_TOTAL_DEPTH is true.", & + units="kg m-3", default=GV%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=(GV%Boussinesq.or.(.not.CS%fixed_total_depth))) call get_param(param_file, mdl, "MEKE_ALPHA_DEFORM", CS%aDeform, & "If positive, is a coefficient weighting the deformation scale "//& @@ -1225,16 +1594,17 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) "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, & - "CDRAG is the drag coefficient relating the magnitude of "//& - "the velocity field to the bottom stress.", units="nondim", & - default=0.003) + "CDRAG is the drag coefficient relating the magnitude of the velocity "//& + "field to the bottom stress.", units="nondim", default=0.003) call get_param(param_file, mdl, "MEKE_CDRAG", CS%cdrag, & "Drag coefficient relating the magnitude of the velocity "//& - "field to the bottom stress in MEKE.", units="nondim", & - default=cdrag) + "field to the bottom stress in MEKE.", units="nondim", default=cdrag, scale=US%L_to_m*GV%m_to_H) call get_param(param_file, mdl, "LAPLACIAN", laplacian, default=.false., do_not_log=.true.) call get_param(param_file, mdl, "BIHARMONIC", biharmonic, default=.false., do_not_log=.true.) @@ -1276,6 +1646,33 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) if (.not. allocated(MEKE%MEKE)) CS%id_Ut = -1 CS%id_src = register_diag_field('ocean_model', 'MEKE_src', diag%axesT1, Time, & 'MEKE energy source', 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + + CS%id_src_adv = register_diag_field('ocean_model', 'MEKE_src_adv', diag%axesT1, Time, & + 'MEKE energy source from the horizontal advection of MEKE', 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + + CS%id_src_btm_drag = register_diag_field('ocean_model', 'MEKE_src_btm_drag', diag%axesT1, Time, & + 'MEKE energy source from the bottom drag acting on MEKE', 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + + if (CS%MEKE_K4 >= 0.) & + CS%id_src_mom_K4 = register_diag_field('ocean_model', 'MEKE_src_mom_K4', & + diag%axesT1, Time, 'MEKE energy source from the biharmonic of MEKE', & + 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + + if (CS%MEKE_GMcoeff >= 0.) & + CS%id_src_GM = register_diag_field('ocean_model', 'MEKE_src_GM', & + diag%axesT1, Time, 'MEKE energy source from the thickness mixing (GM scheme)', & + 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + + if (CS%MEKE_FrCoeff >= 0.) & + CS%id_src_mom_lp = register_diag_field('ocean_model', 'MEKE_src_mom_lp', & + diag%axesT1, Time, 'MEKE energy source from the Laplacian of resolved flows', & + 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + + if (CS%MEKE_bhFrCoeff >= 0.) & + CS%id_src_mom_bh = register_diag_field('ocean_model', 'MEKE_src_mom_bh', & + diag%axesT1, Time, 'MEKE energy source from the biharmonic of resolved flows', & + 'm2 s-3', conversion=(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_decay = register_diag_field('ocean_model', 'MEKE_decay', diag%axesT1, Time, & 'MEKE decay rate', 's-1', conversion=US%s_to_T) CS%id_GM_src = register_diag_field('ocean_model', 'MEKE_GM_src', diag%axesT1, Time, & @@ -1286,6 +1683,10 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) 'MEKE energy available from momentum', & 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) if (.not. allocated(MEKE%mom_src)) CS%id_mom_src = -1 + CS%id_mom_src_bh = register_diag_field('ocean_model', 'MEKE_mom_src_bh',diag%axesT1, Time, & + 'MEKE energy available from the biharmonic dissipation of momentum', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + if (.not. allocated(MEKE%mom_src_bh)) CS%id_mom_src_bh = -1 CS%id_GME_snk = register_diag_field('ocean_model', 'MEKE_GME_snk',diag%axesT1, Time, & 'MEKE energy lost to GME backscatter', & 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) @@ -1315,6 +1716,7 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) 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. @@ -1322,46 +1724,13 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) if (coldStart) CS%initialize = .false. if (CS%initialize) call MOM_error(WARNING, & "MEKE_init: Initializing MEKE with a local equilibrium balance.") - - ! Account for possible changes in dimensional scaling for variables that have been - ! read from a restart file. - I_T_rescale = 1.0 - if ((US%s_to_T_restart /= 0.0) .and. (US%s_to_T_restart /= US%s_to_T)) & - I_T_rescale = US%s_to_T_restart / US%s_to_T - L_rescale = 1.0 - if ((US%m_to_L_restart /= 0.0) .and. (US%m_to_L_restart /= US%m_to_L)) & - L_rescale = US%m_to_L / US%m_to_L_restart - - if (L_rescale*I_T_rescale /= 1.0) then - if (allocated(MEKE%MEKE)) then ; if (query_initialized(MEKE%MEKE, "MEKE_MEKE", restart_CS)) then - do j=js,je ; do i=is,ie - MEKE%MEKE(i,j) = L_rescale*I_T_rescale * MEKE%MEKE(i,j) - enddo ; enddo - endif ; endif - endif - if (L_rescale**2*I_T_rescale /= 1.0) then - if (allocated(MEKE%Kh)) then ; if (query_initialized(MEKE%Kh, "MEKE_Kh", restart_CS)) then - do j=js,je ; do i=is,ie - MEKE%Kh(i,j) = L_rescale**2*I_T_rescale * MEKE%Kh(i,j) - enddo ; enddo - endif ; endif - if (allocated(MEKE%Ku)) then ; if (query_initialized(MEKE%Ku, "MEKE_Ku", restart_CS)) then - do j=js,je ; do i=is,ie - MEKE%Ku(i,j) = L_rescale**2*I_T_rescale * MEKE%Ku(i,j) - enddo ; enddo - endif ; endif - if (allocated(MEKE%Kh_diff)) then ; if (query_initialized(MEKE%Kh, "MEKE_Kh_diff", restart_CS)) then - do j=js,je ; do i=is,ie - MEKE%Kh_diff(i,j) = L_rescale**2*I_T_rescale * MEKE%Kh_diff(i,j) - enddo ; enddo - endif ; endif - endif - if (L_rescale**4*I_T_rescale /= 1.0) then - if (allocated(MEKE%Au)) then ; if (query_initialized(MEKE%Au, "MEKE_Au", restart_CS)) then + if (allocated(MEKE%Le)) then + if (.not.query_initialized(MEKE%Le, "MEKE_Le", restart_CS)) then + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - MEKE%Au(i,j) = L_rescale**4*I_T_rescale * MEKE%Au(i,j) + MEKE%Le(i,j) = sqrt(G%areaT(i,j)) enddo ; enddo - endif ; endif + endif endif ! Set up group passes. In the case of a restart, these fields need a halo update now. @@ -1373,37 +1742,330 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) 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 +!> Initializer for the variant of MEKE that uses ML to predict eddy kinetic energy +subroutine ML_MEKE_init(diag, G, US, Time, param_file, dbcomms_CS, CS) + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics structure. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(time_type), intent(in) :: Time !< The current model time. + type(param_file_type), intent(in) :: param_file !< Parameter file parser structure. + type(dbcomms_CS_type), intent(in) :: dbcomms_CS !< Control structure for database communication + type(MEKE_CS), intent(inout) :: CS !< Control structure for this module + + character(len=200) :: inputdir, backend, model_filename + integer :: db_return_code, batch_size + character(len=40) :: mdl = "MOM_ML_MEKE" + + ! Store pointers in control structure + write(CS%key_suffix, '(A,I6.6)') '_', PE_here() + ! Put some basic information into the database + db_return_code = 0 + db_return_code = CS%client%put_tensor("meta"//CS%key_suffix, & + REAL([G%isd_global, G%idg_offset, G%jsd_global, G%jdg_offset]),[4]) + db_return_code + db_return_code = CS%client%put_tensor("geolat"//CS%key_suffix, G%geoLatT, shape(G%geoLatT)) + db_return_code + db_return_code = CS%client%put_tensor("geolon"//CS%key_suffix, G%geoLonT, shape(G%geoLonT)) + db_return_code + db_return_code = CS%client%put_tensor("EKE_shape"//CS%key_suffix, shape(G%geolonT), [2]) + db_return_code + + if (CS%client%SR_error_parser(db_return_code)) call MOM_error(FATAL, "Putting metadata into the database failed") + + call read_param(param_file, "INPUTDIR", inputdir) + inputdir = slasher(inputdir) + + call get_param(param_file, mdl, "BATCH_SIZE", batch_size, "Batch size to use for inference", default=1) + call get_param(param_file, mdl, "EKE_BACKEND", backend, & + "The computational backend to use for EKE inference (CPU or GPU)", default="GPU") + call get_param(param_file, mdl, "EKE_MODEL", model_filename, & + "Filename of the a saved pyTorch model to use", fail_if_missing = .true.) + call get_param(param_file, mdl, "EKE_MAX", CS%eke_max, & + "Maximum value of EKE allowed when inferring EKE", & + units="m2 s-2", default=2., scale=US%m_s_to_L_T**2) + + ! Set the machine learning model + if (dbcomms_CS%colocated) then + if (modulo(PE_here(),dbcomms_CS%colocated_stride) == 0) then + db_return_code = CS%client%set_model_from_file(CS%model_key, trim(inputdir)//trim(model_filename), & + "TORCH", backend, batch_size=batch_size) + endif + else + if (is_root_pe()) then + db_return_code = CS%client%set_model_from_file(CS%model_key, trim(inputdir)//trim(model_filename), & + "TORCH", backend, batch_size=batch_size) + endif + endif + if (CS%client%SR_error_parser(db_return_code)) then + call MOM_error(FATAL, "MEKE: set_model failed") + endif + + call get_param(param_file, mdl, "ONLINE_ANALYSIS", CS%online_analysis, & + "If true, post EKE used in MOM6 to the database for analysis", default=.true.) + + ! Set various clock ids + CS%id_client_init = cpu_clock_id('(ML_MEKE client init)', grain=CLOCK_ROUTINE) + CS%id_put_tensor = cpu_clock_id('(ML_MEKE put tensor)', grain=CLOCK_ROUTINE) + CS%id_run_model = cpu_clock_id('(ML_MEKE run model)', grain=CLOCK_ROUTINE) + CS%id_unpack_tensor = cpu_clock_id('(ML_MEKE unpack tensor )', grain=CLOCK_ROUTINE) + + ! Diagnostics for ML_MEKE + CS%id_mke = register_diag_field('ocean_model', 'MEKE_MKE', diag%axesT1, Time, & + 'Surface mean (resolved) kinetic energy used in MEKE', 'm2 s-2', conversion=US%L_T_to_m_s**2) + CS%id_slope_z= register_diag_field('ocean_model', 'MEKE_slope_z', diag%axesT1, Time, & + 'Vertically averaged isopyncal slope magnitude used in MEKE', 'nondim', conversion=US%Z_to_L) + CS%id_slope_x= register_diag_field('ocean_model', 'MEKE_slope_x', diag%axesCui, Time, & + 'Isopycnal slope in the x-direction used in MEKE', 'nondim', conversion=US%Z_to_L) + CS%id_slope_y= register_diag_field('ocean_model', 'MEKE_slope_y', diag%axesCvi, Time, & + 'Isopycnal slope in the y-direction used in MEKE', 'nondim', conversion=US%Z_to_L) + CS%id_rv = register_diag_field('ocean_model', 'MEKE_RV', diag%axesT1, Time, & + 'Surface relative vorticity used in MEKE', 's-1', conversion=US%s_to_T) + +end subroutine ML_MEKE_init + +!> Calculate the various features used for the machine learning prediction +subroutine ML_MEKE_calculate_features(G, GV, US, CS, Rd_dx_h, u, v, tv, h, dt, features_array) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(MEKE_CS), intent(in) :: CS !< Control structure for MEKE + real, dimension(SZI_(G),SZJ_(G)), intent(in ) :: Rd_dx_h !< Rossby radius of deformation over + !! the grid length scale [nondim] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] + type(thermo_var_ptrs), intent(in) :: tv !< Type containing thermodynamic variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + real, intent(in) :: dt !< Model(baroclinic) time-step [T ~> s]. + real(kind=real32), dimension(SIZE(h),num_features), intent( out) :: features_array + !< The array of features needed for machine + !! learning inference, with different units + !! for the various subarrays [various] + + real, dimension(SZI_(G),SZJ_(G)) :: mke ! Surface kinetic energy per unit mass [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJ_(G)) :: slope_z ! Vertically averaged isoneutral slopes [Z L-1 ~> nondim] + real, dimension(SZIB_(G),SZJB_(G)) :: rv_z ! Surface relative vorticity [T-1 ~> s-1] + real, dimension(SZIB_(G),SZJB_(G)) :: rv_z_t ! Surface relative vorticity interpolated to tracer points [T-1 ~> s-1] + + real, dimension(SZIB_(G),SZJ_(G), SZK_(G)) :: h_u ! Thickness at u point [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G), SZK_(G)) :: h_v ! Thickness at v point [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1) :: slope_x ! Isoneutral slope at U point [Z L-1 ~> nondim] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1) :: slope_y ! Isoneutral slope at V point [Z L-1 ~> nondim] + real, dimension(SZIB_(G),SZJ_(G)) :: slope_x_vert_avg ! Isoneutral slope at U point [Z L-1 ~> nondim] + real, dimension(SZI_(G),SZJB_(G)) :: slope_y_vert_avg ! Isoneutral slope at V point [Z L-1 ~> nondim] + real, dimension(SZI_(G), SZJ_(G), SZK_(G)+1) :: e ! The interface heights relative to mean sea level [Z ~> m]. + real :: slope_t ! Slope interpolated to thickness points [Z L-1 ~> nondim] + real :: u_t, v_t ! u and v interpolated to thickness points [L T-1 ~> m s-1] + real :: dvdx, dudy ! Components of relative vorticity [T-1 ~> s-1] + real :: a_e, a_w, a_n, a_s ! Fractional areas of neighboring cells for interpolating velocities [nondim] + real :: Idenom ! A normalizing factor in calculating weighted averages of areas [L-2 ~> m-2] + real :: sum_area ! A sum of adjacent cell areas [L2 ~> m2] + + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + ! Calculate various features for used to infer eddy kinetic energy + ! Linear interpolation to estimate thickness at a velocity points + do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + h_u(I,j,k) = 0.5*(h(i,j,k)*G%mask2dT(i,j) + h(i+1,j,k)*G%mask2dT(i+1,j)) + GV%Angstrom_H + h_v(i,J,k) = 0.5*(h(i,j,k)*G%mask2dT(i,j) + h(i,j+1,k)*G%mask2dT(i,j+1)) + GV%Angstrom_H + enddo ; enddo ; enddo + call find_eta(h, tv, G, GV, US, e, halo_size=2) + ! Note the hard-coded dimenisional constant in the following line. + call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*1.e-7*GV%m2_s_to_HZ_T, .false., slope_x, slope_y) + call pass_vector(slope_x, slope_y, G%Domain) + do j=js-1,je+1 ; do i=is-1,ie+1 + slope_x_vert_avg(I,j) = vertical_average_interface(slope_x(i,j,:), h_u(i,j,:), GV%H_subroundoff) + slope_y_vert_avg(i,J) = vertical_average_interface(slope_y(i,j,:), h_v(i,j,:), GV%H_subroundoff) + enddo ; enddo + slope_z(:,:) = 0. + + call pass_vector(slope_x_vert_avg, slope_y_vert_avg, G%Domain) + do j=js,je ; do i=is,ie + ! Calculate weights for interpolation from velocity points to h points + sum_area = G%areaCu(I-1,j) + G%areaCu(I,j) + if (sum_area>0.0) then + Idenom = sqrt(0.5*G%IareaT(i,j) / sum_area) + a_w = G%areaCu(I-1,j) * Idenom + a_e = G%areaCu(I,j) * Idenom + else + a_w = 0.0 ; a_e = 0.0 + endif + + sum_area = G%areaCv(i,J-1) + G%areaCv(i,J) + if (sum_area>0.0) then + Idenom = sqrt(0.5*G%IareaT(i,j) / sum_area) + a_s = G%areaCv(i,J-1) * Idenom + a_n = G%areaCv(i,J) * Idenom + else + a_s = 0.0 ; a_n = 0.0 + endif + + ! Calculate mean kinetic energy + u_t = (a_e*u(I,j,1)) + (a_w*u(I-1,j,1)) + v_t = (a_n*v(i,J,1)) + (a_s*v(i,J-1,1)) + mke(i,j) = 0.5*( (u_t*u_t) + (v_t*v_t) ) + + ! Calculate the magnitude of the slope + slope_t = slope_x_vert_avg(I,j)*a_e+slope_x_vert_avg(I-1,j)*a_w + slope_z(i,j) = sqrt(slope_t*slope_t) + slope_t = slope_y_vert_avg(i,J)*a_n+slope_y_vert_avg(i,J-1)*a_s + slope_z(i,j) = 0.5*(slope_z(i,j) + sqrt(slope_t*slope_t))*G%mask2dT(i,j) + enddo ; enddo + call pass_var(slope_z, G%Domain) + + ! Calculate relative vorticity + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + dvdx = ((v(i+1,J,1)*G%dyCv(i+1,J)) - (v(i,J,1)*G%dyCv(i,J))) + dudy = ((u(I,j+1,1)*G%dxCu(I,j+1)) - (u(I,j,1)*G%dxCu(I,j))) + ! Assumed no slip + rv_z(I,J) = (2.0-G%mask2dBu(I,J)) * (dvdx - dudy) * G%IareaBu(I,J) + enddo ; enddo + ! Interpolate RV to t-point, revisit this calculation to include metrics + do j=js,je ; do i=is,ie + rv_z_t(i,j) = 0.25*(rv_z(i-1,j) + rv_z(i,j) + rv_z(i-1,j-1) + rv_z(i,j-1)) + enddo ; enddo + + + ! Construct the feature array + features_array(:,mke_idx) = pack(mke,.true.) + features_array(:,slope_z_idx) = pack(slope_z,.true.) + features_array(:,rd_dx_z_idx) = pack(Rd_dx_h,.true.) + features_array(:,rv_idx) = pack(rv_z_t,.true.) + + if (CS%id_rv>0) call post_data(CS%id_rv, rv_z, CS%diag) + if (CS%id_mke>0) call post_data(CS%id_mke, mke, CS%diag) + if (CS%id_slope_z>0) call post_data(CS%id_slope_z, slope_z, CS%diag) + if (CS%id_slope_x>0) call post_data(CS%id_slope_x, slope_x, CS%diag) + if (CS%id_slope_y>0) call post_data(CS%id_slope_y, slope_y, CS%diag) +end subroutine ML_MEKE_calculate_features + +!> Use the machine learning interface to predict EKE +subroutine predict_MEKE(G, US, CS, npts, Time, features_array, MEKE) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(MEKE_CS), intent(in ) :: CS !< Control structure for MEKE + integer, intent(in ) :: npts !< Number of T-grid cells on the local + !! domain + type(time_type), intent(in ) :: Time !< The current model time + real(kind=real32), dimension(npts,num_features), intent(in ) :: features_array + !< The array of features needed for machine + !! learning inference, with different units + !! for the various subarrays [various] + real, dimension(SZI_(G),SZJ_(G)), intent( out) :: MEKE !< Eddy kinetic energy [L2 T-2 ~> m2 s-2] + + ! Local variables + integer :: db_return_code + character(len=255), dimension(1) :: model_out, model_in + character(len=255) :: time_suffix + real(kind=real32), dimension(SIZE(MEKE)) :: MEKE_vec ! A one-dimensional array of the natural log of eddy kinetic + ! energy in mks units [m2 s-2] + real, dimension(size(MEKE,1),size(MEKE,2)) :: ln_MEKE ! the natural log of eddy kinetic energy + ! in mks units [m2 s-2] + real, dimension(size(MEKE,1),size(MEKE,2)) :: MEKE_mks ! The eddy kinetic energy in mks units [m2 s-2] + integer :: i, j, is, ie, js, je + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec +!> Use the database client to call a machine learning model to predict eddy kinetic energy + call cpu_clock_begin(CS%id_put_tensor) + db_return_code = CS%client%put_tensor("features"//CS%key_suffix, features_array, shape(features_array)) + call cpu_clock_end(CS%id_put_tensor) + + ! Run the ML model to predict EKE and return the result + model_out(1) = "EKE"//CS%key_suffix + model_in(1) = "features"//CS%key_suffix + call cpu_clock_begin(CS%id_run_model) + db_return_code = CS%client%run_model(CS%model_key, model_in, model_out) + call cpu_clock_end(CS%id_run_model) + if (CS%client%SR_error_parser(db_return_code)) then + call MOM_error(FATAL, "MEKE: run_model failed") + endif + call cpu_clock_begin(CS%id_unpack_tensor) + db_return_code = CS%client%unpack_tensor( model_out(1), MEKE_vec, shape(MEKE_vec) ) + call cpu_clock_end(CS%id_unpack_tensor) + + ln_MEKE = reshape(MEKE_vec, shape(MEKE)) + ! Zero out the halos. These will usually be reset by the pass_var in a few lines. + MEKE_mks(:,:) = 0.0 + do j=js,je ; do i=is,ie + MEKE_mks(i,j) = MIN(exp(ln_MEKE(i,j)), US%L_T_to_m_s**2*CS%eke_max) + enddo ; enddo + call pass_var(MEKE_mks, G%Domain, halo=1) + + if (CS%online_analysis) then + write(time_suffix,"(F16.0)") time_type_to_real(Time) + db_return_code = CS%client%put_tensor(trim("EKE_")//trim(adjustl(time_suffix))//CS%key_suffix, & + MEKE_mks, shape(MEKE)) + endif + + ! Copy MEKE_mks into the argument in rescaled units. + ! MEKE(:,:) = 0.0 ! This would fill in the wider halos of this intent(out) array. + do j=js-1,je+1 ; do i=is-1,ie+1 + MEKE(i,j) = US%m_s_to_L_T**2 * MEKE_mks(i,j) + enddo ; enddo + +end subroutine predict_MEKE + +!> Compute average of interface quantities weighted by the thickness of the surrounding +!! layers [arbitrary] +real function vertical_average_interface(h, w, h_min) + + real, dimension(:), intent(in) :: h !< Layer Thicknesses [H ~> m or kg m-2] + real, dimension(:), intent(in) :: w !< Quantity to average [arbitrary] + real, intent(in) :: h_min !< The vanishingly small layer thickness [H ~> m or kg m-2] + + real :: htot ! Twice the sum of the layer thicknesses interpolated to interior interfaces [H ~> m or kg m-2] + real :: inv_htot ! The inverse of htot [H-1 ~> m-1 or m2 kg-1] + integer :: k, nk + + nk = size(h) + htot = h_min + do k=2,nk + htot = htot + (h(k-1)+h(k)) + enddo + inv_htot = 1./htot + + vertical_average_interface = 0. + do K=2,nk + vertical_average_interface = vertical_average_interface + (w(k)*(h(k-1)+h(k)))*inv_htot + enddo +end function vertical_average_interface + !> Allocates memory and register restart fields for the MOM_MEKE module. -subroutine MEKE_alloc_register_restart(HI, param_file, MEKE, restart_CS) +subroutine MEKE_alloc_register_restart(HI, US, param_file, MEKE, restart_CS) ! Arguments type(hor_index_type), intent(in) :: HI !< Horizontal index structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file parser structure. type(MEKE_type), intent(inout) :: MEKE !< MEKE fields type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct -! Local variables - type(vardesc) :: vd - real :: MEKE_GMcoeff, MEKE_FrCoeff, MEKE_GMECoeff, MEKE_KHCoeff, MEKE_viscCoeff_Ku, MEKE_viscCoeff_Au + + ! Local variables + real :: MEKE_GMcoeff, MEKE_FrCoeff, MEKE_bhFrCoeff, MEKE_GMECoeff ! Coefficients for various terms [nondim] + real :: MEKE_KHCoeff, MEKE_viscCoeff_Ku, MEKE_viscCoeff_Au ! Coefficients for various terms [nondim] logical :: Use_KH_in_MEKE logical :: useMEKE + logical :: sqg_use_MEKE integer :: isd, ied, jsd, jed ! Determine whether this module will be used - useMEKE = .false.; call read_param(param_file,"USE_MEKE",useMEKE) + useMEKE = .false. ; call read_param(param_file,"USE_MEKE",useMEKE) ! Read these parameters to determine what should be in the restarts - MEKE_GMcoeff =-1.; call read_param(param_file,"MEKE_GMCOEFF",MEKE_GMcoeff) - MEKE_FrCoeff =-1.; call read_param(param_file,"MEKE_FRCOEFF",MEKE_FrCoeff) - MEKE_GMEcoeff =-1.; call read_param(param_file,"MEKE_GMECOEFF",MEKE_GMEcoeff) - MEKE_KhCoeff =1.; call read_param(param_file,"MEKE_KHCOEFF",MEKE_KhCoeff) - MEKE_viscCoeff_Ku =0.; call read_param(param_file,"MEKE_VISCOSITY_COEFF_KU",MEKE_viscCoeff_Ku) - MEKE_viscCoeff_Au =0.; call read_param(param_file,"MEKE_VISCOSITY_COEFF_AU",MEKE_viscCoeff_Au) - Use_KH_in_MEKE = .false.; call read_param(param_file,"USE_KH_IN_MEKE", Use_KH_in_MEKE) + MEKE_GMcoeff = -1. ; call read_param(param_file,"MEKE_GMCOEFF",MEKE_GMcoeff) + MEKE_FrCoeff = -1. ; call read_param(param_file,"MEKE_FRCOEFF",MEKE_FrCoeff) + MEKE_bhFrCoeff = -1. ; call read_param(param_file,"MEKE_bhFRCOEFF",MEKE_bhFrCoeff) + MEKE_GMEcoeff = -1. ; call read_param(param_file,"MEKE_GMECOEFF",MEKE_GMEcoeff) + MEKE_KhCoeff = 1. ; call read_param(param_file,"MEKE_KHCOEFF",MEKE_KhCoeff) + MEKE_viscCoeff_Ku = 0. ; call read_param(param_file,"MEKE_VISCOSITY_COEFF_KU",MEKE_viscCoeff_Ku) + MEKE_viscCoeff_Au = 0. ; call read_param(param_file,"MEKE_VISCOSITY_COEFF_AU",MEKE_viscCoeff_Au) + Use_KH_in_MEKE = .false. ; call read_param(param_file,"USE_KH_IN_MEKE", Use_KH_in_MEKE) + sqg_use_MEKE = .false. ; call read_param(param_file,"SQG_USE_MEKE", sqg_use_MEKE) if (.not. useMEKE) return @@ -1411,38 +2073,48 @@ subroutine MEKE_alloc_register_restart(HI, param_file, MEKE, restart_CS) call MOM_mesg("MEKE_alloc_register_restart: allocating and registering", 5) isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed allocate(MEKE%MEKE(isd:ied,jsd:jed), source=0.0) - vd = var_desc("MEKE", "m2 s-2", hor_grid='h', z_grid='1', & - longname="Mesoscale Eddy Kinetic Energy") - call register_restart_field(MEKE%MEKE, vd, .false., restart_CS) + call register_restart_field(MEKE%MEKE, "MEKE", .false., restart_CS, & + longname="Mesoscale Eddy Kinetic Energy", units="m2 s-2", conversion=US%L_T_to_m_s**2) + if (MEKE_GMcoeff>=0.) allocate(MEKE%GM_src(isd:ied,jsd:jed), source=0.0) - if (MEKE_FrCoeff>=0. .or. MEKE_GMECoeff>=0.) & + if (MEKE_FrCoeff>=0. .or. MEKE_bhFrCoeff>=0. .or. MEKE_GMECoeff>=0.) & allocate(MEKE%mom_src(isd:ied,jsd:jed), source=0.0) + if (MEKE_bhFrCoeff >= 0.) & + allocate(MEKE%mom_src_bh(isd:ied,jsd:jed), source=0.0) + if (MEKE_FrCoeff<0.) MEKE_FrCoeff = 0. + if (MEKE_bhFrCoeff<0.) MEKE_bhFrCoeff = 0. if (MEKE_GMECoeff>=0.) allocate(MEKE%GME_snk(isd:ied,jsd:jed), source=0.0) if (MEKE_KhCoeff>=0.) then allocate(MEKE%Kh(isd:ied,jsd:jed), source=0.0) - vd = var_desc("MEKE_Kh", "m2 s-1", hor_grid='h', z_grid='1', & - longname="Lateral diffusivity from Mesoscale Eddy Kinetic Energy") - call register_restart_field(MEKE%Kh, vd, .false., restart_CS) + call register_restart_field(MEKE%Kh, "MEKE_Kh", .false., restart_CS, & + longname="Lateral diffusivity from Mesoscale Eddy Kinetic Energy", & + units="m2 s-1", conversion=US%L_to_m**2*US%s_to_T) endif allocate(MEKE%Rd_dx_h(isd:ied,jsd:jed), source=0.0) if (MEKE_viscCoeff_Ku/=0.) then allocate(MEKE%Ku(isd:ied,jsd:jed), source=0.0) - vd = var_desc("MEKE_Ku", "m2 s-1", hor_grid='h', z_grid='1', & - longname="Lateral viscosity from Mesoscale Eddy Kinetic Energy") - call register_restart_field(MEKE%Ku, vd, .false., restart_CS) + call register_restart_field(MEKE%Ku, "MEKE_Ku", .false., 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) - vd = var_desc("MEKE_Kh_diff", "m2 s-1",hor_grid='h',z_grid='1', & - longname="Copy of thickness diffusivity for diffusing MEKE") - call register_restart_field(MEKE%Kh_diff, vd, .false., restart_CS) + call register_restart_field(MEKE%Kh_diff, "MEKE_Kh_diff", .false., restart_CS, & + longname="Copy of thickness diffusivity for diffusing MEKE", & + units="m2 s-1", conversion=US%L_to_m**2*US%s_to_T) endif if (MEKE_viscCoeff_Au/=0.) then allocate(MEKE%Au(isd:ied,jsd:jed), source=0.0) - vd = var_desc("MEKE_Au", "m4 s-1", hor_grid='h', z_grid='1', & - longname="Lateral biharmonic viscosity from Mesoscale Eddy Kinetic Energy") - call register_restart_field(MEKE%Au, vd, .false., restart_CS) + call register_restart_field(MEKE%Au, "MEKE_Au", .false., restart_CS, & + longname="Lateral biharmonic viscosity from Mesoscale Eddy Kinetic Energy", & + units="m4 s-1", conversion=US%L_to_m**4*US%s_to_T) endif end subroutine MEKE_alloc_register_restart @@ -1462,8 +2134,10 @@ subroutine MEKE_end(MEKE) if (allocated(MEKE%Kh)) deallocate(MEKE%Kh) if (allocated(MEKE%GME_snk)) deallocate(MEKE%GME_snk) if (allocated(MEKE%mom_src)) deallocate(MEKE%mom_src) + if (allocated(MEKE%mom_src_bh)) deallocate(MEKE%mom_src_bh) if (allocated(MEKE%GM_src)) deallocate(MEKE%GM_src) if (allocated(MEKE%MEKE)) deallocate(MEKE%MEKE) + if (allocated(MEKE%Le)) deallocate(MEKE%Le) end subroutine MEKE_end !> \namespace mom_meke @@ -1524,7 +2198,7 @@ end subroutine MEKE_end !! The local dissipation of \f$ E \f$ is parameterized through a linear !! damping, \f$\lambda\f$, and bottom drag, \f$ C_d | U_d | \gamma_b^2 \f$. !! The \f$ \gamma_b \f$ accounts for the weak projection of the column-mean -!! eddy velocty to the bottom. In other words, the bottom velocity is +!! eddy velocity to the bottom. In other words, the bottom velocity is !! estimated as \f$ \gamma_b U_e \f$. !! The bottom drag coefficient, \f$ C_d \f$ is the same as that used in the bottom !! friction in the mean model equations. @@ -1537,7 +2211,7 @@ end subroutine MEKE_end !! \f$ U_b \f$ is a constant background bottom velocity scale and is !! typically not used (i.e. set to zero). !! -!! Following Jansen et al., 2015, the projection of eddy energy on to the bottom +!! Following \cite jansen2015, the projection of eddy energy on to the bottom !! is given by the ratio of bottom energy to column mean energy: !! \f[ !! \gamma_b^2 = \frac{E_b}{E} = \gamma_{d0} @@ -1569,12 +2243,12 @@ end subroutine MEKE_end !! \f[ \kappa_M = \gamma_\kappa \sqrt{ \gamma_t^2 U_e^2 A_\Delta } \f] !! !! where \f$ A_\Delta \f$ is the area of the grid cell. -!! Following Jansen et al., 2015, we now use +!! Following \cite jansen2015, we now use !! !! \f[ \kappa_M = \gamma_\kappa l_M \sqrt{ \gamma_t^2 U_e^2 } \f] !! !! where \f$ \gamma_\kappa \in [0,1] \f$ is a non-dimensional factor and, -!! following Jansen et al., 2015, \f$\gamma_t^2\f$ is the ratio of barotropic +!! following \cite jansen2015, \f$\gamma_t^2\f$ is the ratio of barotropic !! eddy energy to column mean eddy energy given by !! \f[ !! \gamma_t^2 = \frac{E_t}{E} = \left( 1 + c_{t} \frac{L_d}{L_f} \right)^{-\frac{1}{4}} diff --git a/src/parameterizations/lateral/MOM_MEKE_types.F90 b/src/parameterizations/lateral/MOM_MEKE_types.F90 index 57de7c0b02..26bc168730 100644 --- a/src/parameterizations/lateral/MOM_MEKE_types.F90 +++ b/src/parameterizations/lateral/MOM_MEKE_types.F90 @@ -1,6 +1,8 @@ -module MOM_MEKE_types +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 -! This file is part of MOM6. See LICENSE.md for the license. +module MOM_MEKE_types implicit none ; private @@ -11,6 +13,8 @@ module MOM_MEKE_types real, allocatable :: GM_src(:,:) !< MEKE source due to thickness mixing (GM) [R Z L2 T-3 ~> W m-2]. real, allocatable :: mom_src(:,:) !< MEKE source from lateral friction in the !! momentum equations [R Z L2 T-3 ~> W m-2]. + real, allocatable :: mom_src_bh(:,:) !< MEKE source from the biharmonic part of the lateral friction in the + !! momentum equations [R Z L2 T-3 ~> W m-2]. real, allocatable :: GME_snk(:,:) !< MEKE sink from GME backscatter in the momentum equations [R Z L2 T-3 ~> W m-2]. real, allocatable :: Kh(:,:) !< The MEKE-derived lateral mixing coefficient [L2 T-1 ~> m2 s-1]. real, allocatable :: Kh_diff(:,:) !< Uses the non-MEKE-derived thickness diffusion coefficient to diffuse @@ -22,12 +26,13 @@ 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] real :: KhTr_fac = 1.0 !< Multiplier to map Kh(MEKE) to KhTr [nondim]. - real :: backscatter_Ro_pow = 0.0 !< Power in Rossby number function for backscatter. - real :: backscatter_Ro_c = 0.0 !< Coefficient in Rossby number function for backscatter. + real :: backscatter_Ro_pow = 0.0 !< Power in Rossby number function for backscatter [nondim]. + real :: backscatter_Ro_c = 0.0 !< Coefficient in Rossby number function for backscatter [nondim]. end type MEKE_type diff --git a/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 new file mode 100644 index 0000000000..8473c58b35 --- /dev/null +++ b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 @@ -0,0 +1,1260 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Calculates Zanna and Bolton 2020 parameterization +!! Implemented by Perezhogin P.A. Contact: pperezhogin@gmail.com +module MOM_Zanna_Bolton + +use MOM_grid, only : ocean_grid_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_diag_mediator, only : post_data, register_diag_field +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type, & + start_group_pass, complete_group_pass +use MOM_domains, only : To_North, To_East +use MOM_domains, only : pass_var, CORNER +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE +use MOM_ANN, only : ANN_init, ANN_apply_array_sio, ANN_end, ANN_CS + +implicit none ; private + +#include + +public ZB2020_lateral_stress, ZB2020_init, ZB2020_end, ZB2020_copy_gradient_and_thickness + +!> Control structure for Zanna-Bolton-2020 parameterization. +type, public :: ZB2020_CS ; private + ! Parameters + real :: amplitude !< The nondimensional scaling factor in ZB model, + !! typically 0.1 - 10 [nondim]. + integer :: ZB_type !< Select how to compute the trace part of ZB model: + !! 0 - both deviatoric and trace components are computed + !! 1 - only deviatoric component is computed + !! 2 - only trace component is computed + integer :: ZB_cons !< Select a discretization scheme for ZB model + !! 0 - non-conservative scheme + !! 1 - conservative scheme for deviatoric component + integer :: HPF_iter !< Number of sharpening passes for the Velocity Gradient (VG) components + !! in ZB model. + integer :: Stress_iter !< Number of smoothing passes for the Stress tensor components + !! in ZB model. + real :: Klower_R_diss !< Attenuation of + !! the ZB parameterization in the regions of + !! geostrophically-unbalanced flows (Klower 2018, Juricke2020,2019) + !! Subgrid stress is multiplied by 1/(1+(shear/(f*R_diss))) + !! R_diss=-1: attenuation is not used; typical value R_diss=1.0 [nondim] + integer :: Klower_shear !< Type of expression for shear in Klower formula + !! 0: sqrt(sh_xx**2 + sh_xy**2) + !! 1: sqrt(sh_xx**2 + sh_xy**2 + vort_xy**2) + integer :: Marching_halo !< The number of filter iterations per a single MPI + !! exchange + + real, dimension(:,:,:), allocatable :: & + sh_xx, & !< Horizontal tension (du/dx - dv/dy) in h (CENTER) + !! points including metric terms [T-1 ~> s-1] + sh_xy, & !< Horizontal shearing strain (du/dy + dv/dx) in q (CORNER) + !! points including metric terms [T-1 ~> s-1] + vort_xy, & !< Vertical vorticity (dv/dx - du/dy) in q (CORNER) + !! points including metric terms [T-1 ~> s-1] + hq !< Thickness in CORNER points [H ~> m or kg m-2] + + real, dimension(:,:,:), allocatable :: & + Txx, & !< Subgrid stress xx component in h [L2 T-2 ~> m2 s-2] + Tyy, & !< Subgrid stress yy component in h [L2 T-2 ~> m2 s-2] + Txy !< Subgrid stress xy component in q [L2 T-2 ~> m2 s-2] + + real, dimension(:,:), allocatable :: & + kappa_h, & !< Scaling coefficient in h points [L2 ~> m2] + kappa_q !< Scaling coefficient in q points [L2 ~> m2] + + real, allocatable :: & + ICoriolis_h(:,:), & !< Inverse Coriolis parameter at h points [T ~> s] + c_diss(:,:,:) !< Attenuation parameter at h points + !! (Klower 2018, Juricke2019,2020) [nondim] + + real, dimension(:,:), allocatable :: & + maskw_h, & !< Mask of land point at h points multiplied by filter weight [nondim] + maskw_q !< Same mask but for q points [nondim] + + logical :: use_ann !< If True, momentum fluxes are inferred with ANN + integer :: stencil_size !< Default is 3x3 + type(ANN_CS) :: ann_Tall !< ANN instance for off-diagonal and diagonal stress + character(len=200) :: ann_file_Tall !< Path to netcdf file with ANN + real :: subroundoff_shear !< Small dimensional constant for save division by zero [T-1 ~> s-1] + + type(diag_ctrl), pointer :: diag => NULL() !< A type that regulates diagnostics output + !>@{ Diagnostic handles + integer :: id_ZB2020u = -1, id_ZB2020v = -1, id_KE_ZB2020 = -1 + integer :: id_Txx = -1 + integer :: id_Tyy = -1 + integer :: id_Txy = -1 + integer :: id_cdiss = -1 + !>@} + + !>@{ CPU time clock IDs + integer :: id_clock_module + integer :: id_clock_copy + integer :: id_clock_cdiss + integer :: id_clock_stress + integer :: id_clock_stress_ANN + integer :: id_clock_divergence + integer :: id_clock_mpi + integer :: id_clock_filter + integer :: id_clock_post + integer :: id_clock_source + !>@} + + !>@{ MPI group passes + type(group_pass_type) :: & + pass_Tq, pass_Th, & !< handles for halo passes of Txy and Txx, Tyy + pass_xx, pass_xy !< handles for halo passes of sh_xx and sh_xy, vort_xy + integer :: Stress_halo = -1, & !< The halo size in filter of the stress tensor + HPF_halo = -1 !< The halo size in filter of the velocity gradient + !>@} + +end type ZB2020_CS + +contains + +!> Read parameters, allocate and precompute arrays, +!! register diagnosicts used in Zanna_Bolton_2020(). +subroutine ZB2020_init(Time, G, GV, US, param_file, diag, CS, use_ZB2020) + type(time_type), intent(in) :: Time !< The current model time. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file parser structure. + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics structure. + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. + logical, intent(out) :: use_ZB2020 !< If true, turns on ZB scheme. + + real :: subroundoff_Cor ! A negligible parameter which avoids division by zero + ! but small compared to Coriolis parameter [T-1 ~> s-1] + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq + integer :: i, j + + ! This include declares and sets the variable "version". +#include "version_variable.h" + character(len=40) :: mdl = "MOM_Zanna_Bolton" ! This module's name. + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + call log_version(param_file, mdl, version, "") + + call get_param(param_file, mdl, "USE_ZB2020", use_ZB2020, & + "If true, turns on Zanna-Bolton-2020 (ZB) " //& + "subgrid momentum parameterization of mesoscale eddies.", default=.false.) + if (.not. use_ZB2020) return + + call get_param(param_file, mdl, "ZB2020_USE_ANN", CS%use_ann, & + "ANN inference of momentum fluxes", default=.false.) + + call get_param(param_file, mdl, "ZB2020_ANN_STENCIL_SIZE", CS%stencil_size, & + "ANN stencil size", default=3) + + call get_param(param_file, mdl, "ZB2020_ANN_FILE_TALL", CS%ann_file_Tall, & + "ANN parameters for prediction of Txy, Txx and Tyy netcdf input", & + default="INPUT/EXP1/Tall.nc") + + call get_param(param_file, mdl, "ZB_SCALING", CS%amplitude, & + "The nondimensional scaling factor in ZB model, " //& + "typically 0.5-2.5", units="nondim", default=0.5) + + call get_param(param_file, mdl, "ZB_TRACE_MODE", CS%ZB_type, & + "Select how to compute the trace part of ZB model:\n" //& + "\t 0 - both deviatoric and trace components are computed\n" //& + "\t 1 - only deviatoric component is computed\n" //& + "\t 2 - only trace component is computed", default=0) + + call get_param(param_file, mdl, "ZB_SCHEME", CS%ZB_cons, & + "Select a discretization scheme for ZB model:\n" //& + "\t 0 - non-conservative scheme\n" //& + "\t 1 - conservative scheme for deviatoric component", default=1) + + call get_param(param_file, mdl, "VG_SHARP_PASS", CS%HPF_iter, & + "Number of sharpening passes for the Velocity Gradient (VG) components " //& + "in ZB model.", default=0) + + call get_param(param_file, mdl, "STRESS_SMOOTH_PASS", CS%Stress_iter, & + "Number of smoothing passes for the Stress tensor components " //& + "in ZB model.", default=0) + + call get_param(param_file, mdl, "ZB_KLOWER_R_DISS", CS%Klower_R_diss, & + "Attenuation of " //& + "the ZB parameterization in the regions of " //& + "geostrophically-unbalanced flows (Klower 2018, Juricke2020,2019). " //& + "Subgrid stress is multiplied by 1/(1+(shear/(f*R_diss))):\n" //& + "\t R_diss=-1. - attenuation is not used\n\t R_diss= 1. - typical value", & + units="nondim", default=-1.) + + call get_param(param_file, mdl, "ZB_KLOWER_SHEAR", CS%Klower_shear, & + "Type of expression for shear in Klower formula:\n" //& + "\t 0: sqrt(sh_xx**2 + sh_xy**2)\n" //& + "\t 1: sqrt(sh_xx**2 + sh_xy**2 + vort_xy**2)", & + default=1, do_not_log=.not.CS%Klower_R_diss>0) + + call get_param(param_file, mdl, "ZB_MARCHING_HALO", CS%Marching_halo, & + "The number of filter iterations per single MPI " //& + "exchange", default=4, do_not_log=(CS%Stress_iter==0).and.(CS%HPF_iter==0)) + + ! Register fields for output from this module. + CS%diag => diag + + CS%id_ZB2020u = register_diag_field('ocean_model', 'ZB2020u', diag%axesCuL, Time, & + 'Zonal Acceleration from Zanna-Bolton 2020', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_ZB2020v = register_diag_field('ocean_model', 'ZB2020v', diag%axesCvL, Time, & + 'Meridional Acceleration from Zanna-Bolton 2020', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_KE_ZB2020 = register_diag_field('ocean_model', 'KE_ZB2020', diag%axesTL, Time, & + 'Kinetic Energy Source from Horizontal Viscosity', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + + CS%id_Txx = register_diag_field('ocean_model', 'Txx', diag%axesTL, Time, & + 'Diagonal term (Txx) in the ZB stress tensor', 'm2 s-2', conversion=US%L_T_to_m_s**2) + + CS%id_Tyy = register_diag_field('ocean_model', 'Tyy', diag%axesTL, Time, & + 'Diagonal term (Tyy) in the ZB stress tensor', 'm2 s-2', conversion=US%L_T_to_m_s**2) + + CS%id_Txy = register_diag_field('ocean_model', 'Txy', diag%axesBL, Time, & + 'Off-diagonal term (Txy) in the ZB stress tensor', 'm2 s-2', conversion=US%L_T_to_m_s**2) + + if (CS%Klower_R_diss > 0) then + CS%id_cdiss = register_diag_field('ocean_model', 'c_diss', diag%axesTL, Time, & + 'Klower (2018) attenuation coefficient', 'nondim') + endif + + ! Clock IDs + ! Only module is measured with syncronization. While smaller + ! parts are measured without - because these are nested clocks. + CS%id_clock_module = cpu_clock_id('(Ocean Zanna-Bolton-2020)', grain=CLOCK_MODULE) + CS%id_clock_copy = cpu_clock_id('(ZB2020 copy fields)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_cdiss = cpu_clock_id('(ZB2020 compute c_diss)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_stress = cpu_clock_id('(ZB2020 compute stress)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_stress_ANN = cpu_clock_id('(ZB2020 compute stress ANN)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_divergence = cpu_clock_id('(ZB2020 compute divergence)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_mpi = cpu_clock_id('(ZB2020 filter MPI exchanges)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_filter = cpu_clock_id('(ZB2020 filter no MPI)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_post = cpu_clock_id('(ZB2020 post data)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_source = cpu_clock_id('(ZB2020 compute energy source)', grain=CLOCK_ROUTINE, sync=.false.) + + CS%subroundoff_shear = 1e-30 * US%T_to_s + if (CS%use_ann) then + call ANN_init(CS%ann_Tall, CS%ann_file_Tall) + endif + + ! Allocate memory + ! We set the stress tensor and velocity gradient tensor to zero + ! with full halo because they potentially may be filtered + ! with marching halo algorithm + allocate(CS%sh_xx(SZI_(G),SZJ_(G),SZK_(GV)), source=0.) + allocate(CS%sh_xy(SZIB_(G),SZJB_(G),SZK_(GV)), source=0.) + allocate(CS%vort_xy(SZIB_(G),SZJB_(G),SZK_(GV)), source=0.) + allocate(CS%hq(SZIB_(G),SZJB_(G),SZK_(GV))) + + allocate(CS%Txx(SZI_(G),SZJ_(G),SZK_(GV)), source=0.) + allocate(CS%Tyy(SZI_(G),SZJ_(G),SZK_(GV)), source=0.) + allocate(CS%Txy(SZIB_(G),SZJB_(G),SZK_(GV)), source=0.) + allocate(CS%kappa_h(SZI_(G),SZJ_(G))) + allocate(CS%kappa_q(SZIB_(G),SZJB_(G))) + + ! Precomputing the scaling coefficient + ! Mask is included to automatically satisfy B.C. + do j=js-2,je+2 ; do i=is-2,ie+2 + CS%kappa_h(i,j) = -CS%amplitude * G%areaT(i,j) * G%mask2dT(i,j) + enddo ; enddo + + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + CS%kappa_q(I,J) = -CS%amplitude * G%areaBu(I,J) * G%mask2dBu(I,J) + enddo ; enddo + + if (CS%Klower_R_diss > 0) then + allocate(CS%ICoriolis_h(SZI_(G),SZJ_(G))) + allocate(CS%c_diss(SZI_(G),SZJ_(G),SZK_(GV))) + + subroundoff_Cor = 1e-30 * US%T_to_s + ! Precomputing 1/(f * R_diss) + do j=js-1,je+1 ; do i=is-1,ie+1 + CS%ICoriolis_h(i,j) = 1. / ((abs(0.25 * ((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) & + + (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J-1)))) + subroundoff_Cor) & + * CS%Klower_R_diss) + enddo ; enddo + endif + + if (CS%Stress_iter > 0 .or. CS%HPF_iter > 0) then + ! Include 1/16. factor to the mask for filter implementation + allocate(CS%maskw_h(SZI_(G),SZJ_(G))) ; CS%maskw_h(:,:) = G%mask2dT(:,:) * 0.0625 + allocate(CS%maskw_q(SZIB_(G),SZJB_(G))) ; CS%maskw_q(:,:) = G%mask2dBu(:,:) * 0.0625 + endif + + ! Initialize MPI group passes + if (CS%Stress_iter > 0) then + ! reduce size of halo exchange accordingly to + ! Marching halo, number of iterations and the array size + ! But let exchange width be at least 1 + CS%Stress_halo = max(min(CS%Marching_halo, CS%Stress_iter, & + G%Domain%nihalo, G%Domain%njhalo), 1) + + call create_group_pass(CS%pass_Tq, CS%Txy, G%Domain, halo=CS%Stress_halo, & + position=CORNER) + call create_group_pass(CS%pass_Th, CS%Txx, G%Domain, halo=CS%Stress_halo) + call create_group_pass(CS%pass_Th, CS%Tyy, G%Domain, halo=CS%Stress_halo) + endif + + if (CS%HPF_iter > 0) then + ! The minimum halo size is 2 because it is requirement for the + ! outputs of function filter_velocity_gradients + CS%HPF_halo = max(min(CS%Marching_halo, CS%HPF_iter, & + G%Domain%nihalo, G%Domain%njhalo), 2) + + call create_group_pass(CS%pass_xx, CS%sh_xx, G%Domain, halo=CS%HPF_halo) + call create_group_pass(CS%pass_xy, CS%sh_xy, G%Domain, halo=CS%HPF_halo, & + position=CORNER) + call create_group_pass(CS%pass_xy, CS%vort_xy, G%Domain, halo=CS%HPF_halo, & + position=CORNER) + endif + +end subroutine ZB2020_init + +!> Deallocate any variables allocated in ZB_2020_init +subroutine ZB2020_end(CS) + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. + + deallocate(CS%sh_xx) + deallocate(CS%sh_xy) + deallocate(CS%vort_xy) + deallocate(CS%hq) + + deallocate(CS%Txx) + deallocate(CS%Tyy) + deallocate(CS%Txy) + deallocate(CS%kappa_h) + deallocate(CS%kappa_q) + + if (CS%Klower_R_diss > 0) then + deallocate(CS%ICoriolis_h) + deallocate(CS%c_diss) + endif + + if (CS%Stress_iter > 0 .or. CS%HPF_iter > 0) then + deallocate(CS%maskw_h) + deallocate(CS%maskw_q) + endif + + if (CS%use_ann) then + call ANN_end(CS%ann_Tall) + endif + +end subroutine ZB2020_end + +!> Save precomputed velocity gradients and thickness +!! from the horizontal eddy viscosity module +!! We save as much halo for velocity gradients as possible +!! In symmetric (preferable) memory model: halo 2 for sh_xx +!! and halo 1 for sh_xy and vort_xy +!! We apply zero boundary conditions to velocity gradients +!! which is required for filtering operations +subroutine ZB2020_copy_gradient_and_thickness(sh_xx, sh_xy, vort_xy, hq, & + G, GV, CS, k) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. + + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: sh_xy !< horizontal shearing strain (du/dy + dv/dx) + !! including metric terms [T-1 ~> s-1] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: vort_xy !< Vertical vorticity (dv/dx - du/dy) + !! including metric terms [T-1 ~> s-1] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: hq !< harmonic mean of the harmonic means + !! of the u- & v point thicknesses [H ~> m or kg m-2] + + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: sh_xx !< horizontal tension (du/dx - dv/dy) + !! including metric terms [T-1 ~> s-1] + + integer, intent(in) :: k !< The vertical index of the layer to be passed. + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq + integer :: i, j + + call cpu_clock_begin(CS%id_clock_copy) + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + do J=js-1,Jeq ; do I=is-1,Ieq + CS%hq(I,J,k) = hq(I,J) + enddo ; enddo + + ! No physical B.C. is required for + ! sh_xx in ZB2020. However, filtering + ! may require BC + do j=Jsq-1,je+2 ; do i=Isq-1,ie+2 + CS%sh_xx(i,j,k) = sh_xx(i,j) * G%mask2dT(i,j) + enddo ; enddo + + ! We multiply by mask to remove + ! implicit dependence on CS%no_slip + ! flag in hor_visc module + do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + CS%sh_xy(I,J,k) = sh_xy(I,J) * G%mask2dBu(I,J) + enddo ; enddo + + do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + CS%vort_xy(I,J,k) = vort_xy(I,J) * G%mask2dBu(I,J) + enddo ; enddo + + call cpu_clock_end(CS%id_clock_copy) + +end subroutine ZB2020_copy_gradient_and_thickness + +!> Baroclinic Zanna-Bolton-2020 parameterization, see +!! eq. 6 in https://laurezanna.github.io/files/Zanna-Bolton-2020.pdf +!! We compute the lateral stress tensor according to ZB2020 model +!! and update the acceleration due to eddy viscosity (diffu, diffv) +!! as follows: +!! diffu = diffu + ZB2020u +!! diffv = diffv + ZB2020v +subroutine ZB2020_lateral_stress(u, v, h, diffu, diffv, G, GV, CS, & + dx2h, dy2h, dx2q, dy2q) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: diffu !< Zonal acceleration due to eddy viscosity. + !! It is updated with ZB closure [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: diffv !< Meridional acceleration due to eddy viscosity. + !! It is updated with ZB closure [L T-2 ~> m s-2] + + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: dx2h !< dx^2 at h points [L2 ~> m2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: dy2h !< dy^2 at h points [L2 ~> m2] + + real, dimension(SZIB_(G),SZJB_(G)), intent(in) :: dx2q !< dx^2 at q points [L2 ~> m2] + real, dimension(SZIB_(G),SZJB_(G)), intent(in) :: dy2q !< dy^2 at q points [L2 ~> m2] + + call cpu_clock_begin(CS%id_clock_module) + + ! Compute attenuation if specified + call compute_c_diss(G, GV, CS) + + ! Sharpen velocity gradients if specified + call filter_velocity_gradients(G, GV, CS) + + ! Compute the stress tensor given the + ! (optionally sharpened) velocity gradients + if (CS%use_ann) then + call compute_stress_ANN_collocated(G, GV, CS) + else + call compute_stress(G, GV, CS) + endif + + ! Smooth the stress tensor if specified + call filter_stress(G, GV, CS) + + ! Update the acceleration due to eddy viscosity (diffu, diffv) + ! with the ZB2020 lateral parameterization + call compute_stress_divergence(u, v, h, diffu, diffv, & + dx2h, dy2h, dx2q, dy2q, & + G, GV, CS) + + call cpu_clock_begin(CS%id_clock_post) + if (CS%id_Txx>0) call post_data(CS%id_Txx, CS%Txx, CS%diag) + if (CS%id_Tyy>0) call post_data(CS%id_Tyy, CS%Tyy, CS%diag) + if (CS%id_Txy>0) call post_data(CS%id_Txy, CS%Txy, CS%diag) + + if (CS%id_cdiss>0) call post_data(CS%id_cdiss, CS%c_diss, CS%diag) + call cpu_clock_end(CS%id_clock_post) + + call cpu_clock_end(CS%id_clock_module) + +end subroutine ZB2020_lateral_stress + +!> Compute the attenuation parameter similarly +!! to Klower2018, Juricke2019,2020: c_diss = 1/(1+(shear/(f*R_diss))) +!! where shear = sqrt(sh_xx**2 + sh_xy**2) or shear = sqrt(sh_xx**2 + sh_xy**2 + vort_xy**2) +!! In symmetric memory model, components of velocity gradient tensor +!! should have halo 1 and zero boundary conditions. The result: c_diss having halo 1. +subroutine compute_c_diss(G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k + + real :: shear ! Shear in Klower2018 formula at h points [T-1 ~> s-1] + + if (.not. CS%Klower_R_diss > 0) & + return + + call cpu_clock_begin(CS%id_clock_cdiss) + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + do k=1,nz + + ! sqrt(sh_xx**2 + sh_xy**2) + if (CS%Klower_shear == 0) then + do j=js-1,je+1 ; do i=is-1,ie+1 + shear = sqrt(CS%sh_xx(i,j,k)**2 + 0.25 * ( & + ((CS%sh_xy(I-1,J-1,k)**2) + (CS%sh_xy(I,J ,k)**2)) & + + ((CS%sh_xy(I-1,J ,k)**2) + (CS%sh_xy(I,J-1,k)**2)) & + )) + CS%c_diss(i,j,k) = 1. / (1. + shear * CS%ICoriolis_h(i,j)) + enddo ; enddo + + ! sqrt(sh_xx**2 + sh_xy**2 + vort_xy**2) + elseif (CS%Klower_shear == 1) then + do j=js-1,je+1 ; do i=is-1,ie+1 + shear = sqrt(CS%sh_xx(i,j,k)**2 + 0.25 * ( & + ((CS%sh_xy(I-1,J-1,k)**2 + CS%vort_xy(I-1,J-1,k)**2) & + + (CS%sh_xy(I,J,k)**2 + CS%vort_xy(I,J,k)**2)) & + + ((CS%sh_xy(I-1,J,k)**2 + CS%vort_xy(I-1,J,k)**2) & + + (CS%sh_xy(I,J-1,k)**2 + CS%vort_xy(I,J-1,k)**2)) & + )) + CS%c_diss(i,j,k) = 1. / (1. + shear * CS%ICoriolis_h(i,j)) + enddo ; enddo + endif + + enddo ! end of k loop + + call cpu_clock_end(CS%id_clock_cdiss) + +end subroutine compute_c_diss + +!> Compute stress tensor T = +!! (Txx, Txy; +!! Txy, Tyy) +!! Which consists of the deviatoric and trace components, respectively: +!! T = (-vort_xy * sh_xy, vort_xy * sh_xx; +!! vort_xy * sh_xx, vort_xy * sh_xy) + +!! 1/2 * (vort_xy^2 + sh_xy^2 + sh_xx^2, 0; +!! 0, vort_xy^2 + sh_xy^2 + sh_xx^2) +!! This stress tensor is multiplied by precomputed kappa=-CS%amplitude * G%area: +!! T -> T * kappa +!! The sign of the stress tensor is such that (neglecting h): +!! (du/dt, dv/dt) = div(T) +!! In symmetric memory model: sh_xy and vort_xy should have halo 1 +!! and zero B.C.; sh_xx should have halo 2 and zero B.C. +!! Result: Txx, Tyy, Txy with halo 1 and zero B.C. +subroutine compute_stress(G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. + + real :: & + vort_xy_h, & ! Vorticity interpolated to h point [T-1 ~> s-1] + sh_xy_h ! Shearing strain interpolated to h point [T-1 ~> s-1] + + real :: & + sh_xx_q ! Horizontal tension interpolated to q point [T-1 ~> s-1] + + ! Local variables + real :: sum_sq ! 1/2*(vort_xy^2 + sh_xy^2 + sh_xx^2) in h point [T-2 ~> s-2] + real :: vort_sh ! vort_xy*sh_xy in h point [T-2 ~> s-2] + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k + + logical :: sum_sq_flag ! Flag to compute trace + logical :: vort_sh_scheme_0, vort_sh_scheme_1 ! Flags to compute diagonal trace-free part + + call cpu_clock_begin(CS%id_clock_stress) + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + sum_sq = 0. + vort_sh = 0. + + sum_sq_flag = CS%ZB_type /= 1 + vort_sh_scheme_0 = CS%ZB_type /= 2 .and. CS%ZB_cons == 0 + vort_sh_scheme_1 = CS%ZB_type /= 2 .and. CS%ZB_cons == 1 + + do k=1,nz + + ! compute Txx, Tyy tensor + do j=js-1,je+1 ; do i=is-1,ie+1 + ! It is assumed that B.C. is applied to sh_xy and vort_xy + sh_xy_h = 0.25 * ( (CS%sh_xy(I-1,J-1,k) + CS%sh_xy(I,J,k)) & + + (CS%sh_xy(I-1,J,k) + CS%sh_xy(I,J-1,k)) ) + + vort_xy_h = 0.25 * ( (CS%vort_xy(I-1,J-1,k) + CS%vort_xy(I,J,k)) & + + (CS%vort_xy(I-1,J,k) + CS%vort_xy(I,J-1,k)) ) + + if (sum_sq_flag) then + sum_sq = 0.5 * & + ((vort_xy_h * vort_xy_h & + + sh_xy_h * sh_xy_h) & + + CS%sh_xx(i,j,k) * CS%sh_xx(i,j,k) & + ) + endif + + if (vort_sh_scheme_0) & + vort_sh = vort_xy_h * sh_xy_h + + if (vort_sh_scheme_1) then + ! It is assumed that B.C. is applied to sh_xy and vort_xy + vort_sh = 0.25 * ( & + (((G%areaBu(I-1,J-1) * CS%vort_xy(I-1,J-1,k)) * CS%sh_xy(I-1,J-1,k)) + & + ((G%areaBu(I ,J ) * CS%vort_xy(I ,J ,k)) * CS%sh_xy(I ,J ,k))) + & + (((G%areaBu(I-1,J ) * CS%vort_xy(I-1,J ,k)) * CS%sh_xy(I-1,J ,k)) + & + ((G%areaBu(I ,J-1) * CS%vort_xy(I ,J-1,k)) * CS%sh_xy(I ,J-1,k))) & + ) * G%IareaT(i,j) + endif + + ! B.C. is already applied in kappa_h + CS%Txx(i,j,k) = CS%kappa_h(i,j) * (- vort_sh + sum_sq) + CS%Tyy(i,j,k) = CS%kappa_h(i,j) * (+ vort_sh + sum_sq) + + enddo ; enddo + + ! Here we assume that Txy is initialized to zero + if (CS%ZB_type /= 2) then + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + sh_xx_q = 0.25 * ( (CS%sh_xx(i+1,j+1,k) + CS%sh_xx(i,j,k)) & + + (CS%sh_xx(i+1,j,k) + CS%sh_xx(i,j+1,k))) + ! B.C. is already applied in kappa_q + CS%Txy(I,J,k) = CS%kappa_q(I,J) * (CS%vort_xy(I,J,k) * sh_xx_q) + + enddo ; enddo + endif + + enddo ! end of k loop + + call cpu_clock_end(CS%id_clock_stress) + +end subroutine compute_stress + +!> Compute stress tensor T = +!! (Txx, Txy; +!! Txy, Tyy) +!! with ANN in non-dimensional form: +!! T = dx^2 * |grad V|^2 * ANN(grad V / |grad V|) +!! The sign of the stress tensor is such that: +!! (du/dt, dv/dt) = 1/h * div(h * T) +!! Algorithm: +!! 1) Interpolate input features (sh_xy, sh_xx, vort_xy) to grid centers +!! 2) Compute norm of velocity gradients on a stencil +!! 3) Non-dimensionalize input features +!! 4) Make ANN inference in grid centers +!! 5) Restore physical dimensionality and interpolate Txy back to corners +subroutine compute_stress_ANN_collocated(G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k, m + integer :: ii, jj + integer :: nij + + real, allocatable :: x(:,:) ! Vector of non-dimensional input features + ! number of horizontal grid points x + ! (sh_xy, sh_xx, vort_xy) on a stencil [nondim] + real, allocatable :: y(:,:) ! Vector of nondimensional + ! output features number of horizontal grid points x + ! (Txy,Txx,Tyy) [nondim] + real :: yy(3) ! Vector of dimensional + ! output features (Txy,Txx,Tyy) [L2 T-2 ~> m2 s-2] + real :: tmp ! Temporal value of squared norm [T-2 ~> s-2] + integer :: offset ! Half the stencil size. Used for selection + integer :: stencil_points ! The number of points after flattening + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + sh_xy_h, & ! sh_xy interpolated to the center [T-1 ~> s-1] + vort_xy_h, & ! vort_xy interpolated to the center [T-1 ~> s-1] + norm_h ! Norm of input feautres in center points [T-1 ~> s-1] + + real, dimension(SZI_(G),SZJ_(G)) :: & + sqr_h, & ! Squared norm of velocity gradients in center points [T-2 ~> s-2] + Txy ! Predicted Txy in center points [T-1 ~> s-1] + + call cpu_clock_begin(CS%id_clock_stress_ANN) + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + ! Number of horizontal grid points in ANN inference loop below + nij = (ie - is + 5) * (je - js + 5) + allocate(x(nij, 3 * CS%stencil_size**2)) + allocate(y(nij, 3)) + + sh_xy_h = 0. + vort_xy_h = 0. + norm_h = 0. + + call pass_var(CS%sh_xy, G%Domain, clock=CS%id_clock_mpi, position=CORNER) + call pass_var(CS%sh_xx, G%Domain, clock=CS%id_clock_mpi) + call pass_var(CS%vort_xy, G%Domain, clock=CS%id_clock_mpi, position=CORNER) + + offset = (CS%stencil_size-1)/2 + stencil_points = CS%stencil_size**2 + + ! Interpolate input features + do k=1,nz + do j=js-2,je+2 ; do i=is-2,ie+2 + ! It is assumed that B.C. is applied to sh_xy and vort_xy + sh_xy_h(i,j,k) = 0.25 * ( (CS%sh_xy(I-1,J-1,k) + CS%sh_xy(I,J,k)) & + + (CS%sh_xy(I-1,J,k) + CS%sh_xy(I,J-1,k)) ) + + vort_xy_h(i,j,k) = 0.25 * ( (CS%vort_xy(I-1,J-1,k) + CS%vort_xy(I,J,k)) & + + (CS%vort_xy(I-1,J,k) + CS%vort_xy(I,J-1,k)) ) + + sqr_h(i,j) = (((CS%sh_xx(i,j,k)**2) + (sh_xy_h(i,j,k)**2)) + (vort_xy_h(i,j,k)**2)) * G%mask2dT(i,j) + enddo ; enddo + + do j=js,je ; do i=is,ie + tmp = 0.0 + do jj=j-offset,j+offset ; do ii=i-offset,i+offset + tmp = tmp + sqr_h(ii,jj) + enddo ; enddo + norm_h(i,j,k) = sqrt(tmp) + enddo ; enddo + enddo + + call pass_var(sh_xy_h, G%Domain, clock=CS%id_clock_mpi) + call pass_var(vort_xy_h, G%Domain, clock=CS%id_clock_mpi) + call pass_var(norm_h, G%Domain, clock=CS%id_clock_mpi) + + do k=1,nz + m = 0 + do j=js-2,je+2 ; do i=is-2,ie+2 + m = m + 1 + x(m,1:stencil_points) = & + RESHAPE(sh_xy_h(i-offset:i+offset, & + j-offset:j+offset,k), (/stencil_points/)) + x(m,stencil_points+1:2*stencil_points) = & + RESHAPE(CS%sh_xx(i-offset:i+offset, & + j-offset:j+offset,k), (/stencil_points/)) + x(m,2*stencil_points+1:3*stencil_points) = & + RESHAPE(vort_xy_h(i-offset:i+offset, & + j-offset:j+offset,k), (/stencil_points/)) + + x(m,:) = x(m,:) / (norm_h(i,j,k) + CS%subroundoff_shear) + enddo ; enddo + + call ANN_apply_array_sio(nij, x, y, CS%ann_Tall) + + m = 0 + do j=js-2,je+2 ; do i=is-2,ie+2 + m = m+1 + yy(:) = y(m, :) * norm_h(i,j,k) * norm_h(i,j,k) * CS%kappa_h(i,j) + + Txy(i,j) = yy(1) + CS%Txx(i,j,k) = yy(2) + CS%Tyy(i,j,k) = yy(3) + enddo ; enddo + + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + CS%Txy(I,J,k) = 0.25 * ( (Txy(i+1,j+1) + Txy(i,j)) & + + (Txy(i+1,j) + Txy(i,j+1))) * G%mask2dBu(I,J) + enddo ; enddo + + enddo ! end of k loop + + call pass_var(CS%Txy, G%Domain, clock=CS%id_clock_mpi, position=CORNER) + call pass_var(CS%Txx, G%Domain, clock=CS%id_clock_mpi) + call pass_var(CS%Tyy, G%Domain, clock=CS%id_clock_mpi) + + deallocate(x) + deallocate(y) + + call cpu_clock_end(CS%id_clock_stress_ANN) + +end subroutine compute_stress_ANN_collocated + +!> Compute the divergence of subgrid stress +!! weighted with thickness, i.e. +!! (fx,fy) = 1/h Div(h * [Txx, Txy; Txy, Tyy]) +!! and update the acceleration due to eddy viscosity as +!! diffu = diffu + dx; diffv = diffv + dy +!! Optionally, before computing the divergence, we attenuate the stress +!! according to the Klower formula. +!! In symmetric memory model: Txx, Tyy, Txy, c_diss should have halo 1 +!! with applied zero B.C. +subroutine compute_stress_divergence(u, v, h, diffu, diffv, dx2h, dy2h, dx2q, dy2q, G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ZB2020_CS), intent(in) :: CS !< ZB2020 control structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: diffu !< Zonal acceleration due to convergence of + !! along-coordinate stress tensor [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(out) :: diffv !< Meridional acceleration due to convergence + !! of along-coordinate stress tensor [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: dx2h !< dx^2 at h points [L2 ~> m2] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: dy2h !< dy^2 at h points [L2 ~> m2] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: dx2q !< dx^2 at q points [L2 ~> m2] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: dy2q !< dy^2 at q points [L2 ~> m2] + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: & + Mxx, & ! Subgrid stress Txx multiplied by thickness and dy^2 [H L4 T-2 ~> m5 s-2] + Myy ! Subgrid stress Tyy multiplied by thickness and dx^2 [H L4 T-2 ~> m5 s-2] + + real, dimension(SZIB_(G),SZJB_(G)) :: & + Mxy ! Subgrid stress Txy multiplied by thickness [H L2 T-2 ~> m3 s-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & + ZB2020u !< Zonal acceleration due to convergence of + !! along-coordinate stress tensor for ZB model + !! [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & + ZB2020v !< Meridional acceleration due to convergence + !! of along-coordinate stress tensor for ZB model + !! [L T-2 ~> m s-2] + + real :: h_u ! Thickness interpolated to u points [H ~> m or kg m-2]. + real :: h_v ! Thickness interpolated to v points [H ~> m or kg m-2]. + real :: fx ! Zonal acceleration [L T-2 ~> m s-2] + real :: fy ! Meridional acceleration [L T-2 ~> m s-2] + + real :: h_neglect ! Thickness so small it can be lost in + ! roundoff and so neglected [H ~> m or kg m-2] + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k + logical :: save_ZB2020u, save_ZB2020v ! Save the acceleration due to ZB2020 model + + call cpu_clock_begin(CS%id_clock_divergence) + + save_ZB2020u = (CS%id_ZB2020u > 0) .or. (CS%id_KE_ZB2020 > 0) + save_ZB2020v = (CS%id_ZB2020v > 0) .or. (CS%id_KE_ZB2020 > 0) + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + h_neglect = GV%H_subroundoff + + do k=1,nz + if (CS%Klower_R_diss > 0) then + do J=js-1,Jeq ; do I=is-1,Ieq + Mxy(I,J) = (CS%Txy(I,J,k) * & + (0.25 * ( (CS%c_diss(i,j ,k) + CS%c_diss(i+1,j+1,k)) & + + (CS%c_diss(i,j+1,k) + CS%c_diss(i+1,j ,k))) & + ) & + ) * CS%hq(I,J,k) + enddo ; enddo + else + do J=js-1,Jeq ; do I=is-1,Ieq + Mxy(I,J) = CS%Txy(I,J,k) * CS%hq(I,J,k) + enddo ; enddo + endif + + if (CS%Klower_R_diss > 0) then + do j=js-1,je+1 ; do i=is-1,ie+1 + Mxx(i,j) = ((CS%Txx(i,j,k) * CS%c_diss(i,j,k)) * h(i,j,k)) * dy2h(i,j) + Myy(i,j) = ((CS%Tyy(i,j,k) * CS%c_diss(i,j,k)) * h(i,j,k)) * dx2h(i,j) + enddo ; enddo + else + do j=js-1,je+1 ; do i=is-1,ie+1 + Mxx(i,j) = ((CS%Txx(i,j,k)) * h(i,j,k)) * dy2h(i,j) + Myy(i,j) = ((CS%Tyy(i,j,k)) * h(i,j,k)) * dx2h(i,j) + enddo ; enddo + endif + + ! Evaluate du/dt=1/h x.Div(h T) (Line 1495 of MOM_hor_visc.F90) + do j=js,je ; do I=Isq,Ieq + h_u = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i+1,j)*h(i+1,j,k)) + h_neglect + fx = ((G%IdyCu(I,j)*(Mxx(i+1,j) - Mxx(i,j)) + & + G%IdxCu(I,j)*((dx2q(I,J)*Mxy(I,J)) - (dx2q(I,J-1)*Mxy(I,J-1)))) * & + G%IareaCu(I,j)) / h_u + diffu(I,j,k) = diffu(I,j,k) + fx + if (save_ZB2020u) & + ZB2020u(I,j,k) = fx + enddo ; enddo + + ! Evaluate dv/dt=1/h y.Div(h T) (Line 1517 of MOM_hor_visc.F90) + do J=Jsq,Jeq ; do i=is,ie + h_v = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i,j+1)*h(i,j+1,k)) + h_neglect + fy = ((G%IdxCv(i,J)*(Myy(i,j+1) - Myy(i,j)) + & + G%IdyCv(i,J)*((dy2q(I,J)*Mxy(I,J)) - (dy2q(I-1,J)*Mxy(I-1,J)))) * & + G%IareaCv(i,J)) / h_v + diffv(i,J,k) = diffv(i,J,k) + fy + if (save_ZB2020v) & + ZB2020v(i,J,k) = fy + enddo ; enddo + + enddo ! end of k loop + + call cpu_clock_end(CS%id_clock_divergence) + + call cpu_clock_begin(CS%id_clock_post) + if (CS%id_ZB2020u>0) call post_data(CS%id_ZB2020u, ZB2020u, CS%diag) + if (CS%id_ZB2020v>0) call post_data(CS%id_ZB2020v, ZB2020v, CS%diag) + call cpu_clock_end(CS%id_clock_post) + + call compute_energy_source(u, v, h, ZB2020u, ZB2020v, G, GV, CS) + +end subroutine compute_stress_divergence + +!> Filtering of the velocity gradients sh_xx, sh_xy, vort_xy. +!! Here instead of smoothing we do sharpening, i.e. +!! return (initial - smoothed) fields. +!! The algorithm: marching halo with non-blocking grouped MPI +!! exchanges. The input array sh_xx should have halo 2 with +!! applied zero B.C. The arrays sh_xy and vort_xy should have +!! halo 1 with applied B.C. The output have the same halo and B.C. +subroutine filter_velocity_gradients(G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. + + real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: & + sh_xx ! Copy of CS%sh_xx [T-1 ~> s-1] + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)) :: & + sh_xy, vort_xy ! Copy of CS%sh_xy and CS%vort_xy [T-1 ~> s-1] + + integer :: xx_halo, xy_halo, vort_halo ! currently available halo for gradient components + integer :: xx_iter, xy_iter, vort_iter ! remaining number of iterations + integer :: niter ! required number of iterations + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k + + niter = CS%HPF_iter + + if (niter == 0) return + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + if (.not. G%symmetric) & + call do_group_pass(CS%pass_xx, G%Domain, & + clock=CS%id_clock_mpi) + + ! This is just copy of the array + call cpu_clock_begin(CS%id_clock_filter) + do k=1,nz + ! Halo of size 2 is valid + do j=js-2,je+2 ; do i=is-2,ie+2 + sh_xx(i,j,k) = CS%sh_xx(i,j,k) + enddo ; enddo + ! Only halo of size 1 is valid + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + sh_xy(I,J,k) = CS%sh_xy(I,J,k) + vort_xy(I,J,k) = CS%vort_xy(I,J,k) + enddo ; enddo + enddo + call cpu_clock_end(CS%id_clock_filter) + + xx_halo = 2 ; xy_halo = 1 ; vort_halo = 1 + xx_iter = niter ; xy_iter = niter ; vort_iter = niter + + do while & + (xx_iter > 0 .or. xy_iter > 0 .or. & ! filter iterations remain to be done + xx_halo < 2 .or. xy_halo < 1) ! there is no halo for VG tensor + + ! ---------- filtering sh_xx --------- + if (xx_halo < 2) then + call complete_group_pass(CS%pass_xx, G%Domain, clock=CS%id_clock_mpi) + xx_halo = CS%HPF_halo + endif + + call filter_hq(G, GV, CS, xx_halo, xx_iter, h=CS%sh_xx) + + if (xx_halo < 2) & + call start_group_pass(CS%pass_xx, G%Domain, clock=CS%id_clock_mpi) + + ! ------ filtering sh_xy, vort_xy ---- + if (xy_halo < 1) then + call complete_group_pass(CS%pass_xy, G%Domain, clock=CS%id_clock_mpi) + xy_halo = CS%HPF_halo ; vort_halo = CS%HPF_halo + endif + + call filter_hq(G, GV, CS, xy_halo, xy_iter, q=CS%sh_xy) + call filter_hq(G, GV, CS, vort_halo, vort_iter, q=CS%vort_xy) + + if (xy_halo < 1) & + call start_group_pass(CS%pass_xy, G%Domain, clock=CS%id_clock_mpi) + + enddo + + ! We implement sharpening by computing residual + ! B.C. are already applied to all fields + call cpu_clock_begin(CS%id_clock_filter) + do k=1,nz + do j=js-2,je+2 ; do i=is-2,ie+2 + CS%sh_xx(i,j,k) = sh_xx(i,j,k) - CS%sh_xx(i,j,k) + enddo ; enddo + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + CS%sh_xy(I,J,k) = sh_xy(I,J,k) - CS%sh_xy(I,J,k) + CS%vort_xy(I,J,k) = vort_xy(I,J,k) - CS%vort_xy(I,J,k) + enddo ; enddo + enddo + call cpu_clock_end(CS%id_clock_filter) + + if (.not. G%symmetric) & + call do_group_pass(CS%pass_xy, G%Domain, & + clock=CS%id_clock_mpi) + +end subroutine filter_velocity_gradients + +!> Filtering of the stress tensor Txx, Tyy, Txy. +!! The algorithm: marching halo with non-blocking grouped MPI +!! exchanges. The input arrays (Txx, Tyy, Txy) must have halo 1 +!! with zero B.C. applied. The output have the same halo and B.C. +subroutine filter_stress(G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. + + integer :: Txx_halo, Tyy_halo, Txy_halo ! currently available halo for stress components + integer :: Txx_iter, Tyy_iter, Txy_iter ! remaining number of iterations + integer :: niter ! required number of iterations + + niter = CS%Stress_iter + + if (niter == 0) return + + Txx_halo = 1 ; Tyy_halo = 1 ; Txy_halo = 1 ; ! these are required halo for Txx, Tyy, Txy + Txx_iter = niter ; Tyy_iter = niter ; Txy_iter = niter + + do while & + (Txx_iter > 0 .or. Txy_iter > 0 .or. & ! filter iterations remain to be done + Txx_halo < 1 .or. Txy_halo < 1) ! there is no halo for Txx or Txy + + ! ---------- filtering Txy ----------- + if (Txy_halo < 1) then + call complete_group_pass(CS%pass_Tq, G%Domain, clock=CS%id_clock_mpi) + Txy_halo = CS%Stress_halo + endif + + call filter_hq(G, GV, CS, Txy_halo, Txy_iter, q=CS%Txy) + + if (Txy_halo < 1) & + call start_group_pass(CS%pass_Tq, G%Domain, clock=CS%id_clock_mpi) + + ! ------- filtering Txx, Tyy --------- + if (Txx_halo < 1) then + call complete_group_pass(CS%pass_Th, G%Domain, clock=CS%id_clock_mpi) + Txx_halo = CS%Stress_halo ; Tyy_halo = CS%Stress_halo + endif + + call filter_hq(G, GV, CS, Txx_halo, Txx_iter, h=CS%Txx) + call filter_hq(G, GV, CS, Tyy_halo, Tyy_iter, h=CS%Tyy) + + if (Txx_halo < 1) & + call start_group_pass(CS%pass_Th, G%Domain, clock=CS%id_clock_mpi) + + enddo + +end subroutine filter_stress + +!> Wrapper for filter_3D function. The border indices for q and h +!! arrays are substituted. +subroutine filter_hq(G, GV, CS, current_halo, remaining_iterations, q, h) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ZB2020_CS), intent(in) :: CS !< ZB2020 control structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, & + intent(inout) :: h !< Input/output array in h points [arbitrary] + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)), optional, & + intent(inout) :: q !< Input/output array in q points [arbitrary] + integer, intent(inout) :: current_halo !< Currently available halo points + integer, intent(inout) :: remaining_iterations !< The number of iterations to perform + + logical :: direction ! The direction of the first 1D filter + + direction = (MOD(G%first_direction,2) == 0) + + call cpu_clock_begin(CS%id_clock_filter) + + if (present(h)) then + call filter_3D(h, CS%maskw_h, & + G%isd, G%ied, G%jsd, G%jed, & + G%isc, G%iec, G%jsc, G%jec, GV%ke, & + current_halo, remaining_iterations, & + direction) + endif + + if (present(q)) then + call filter_3D(q, CS%maskw_q, & + G%IsdB, G%IedB, G%JsdB, G%JedB, & + G%IscB, G%IecB, G%JscB, G%JecB, GV%ke, & + current_halo, remaining_iterations, & + direction) + endif + + call cpu_clock_end(CS%id_clock_filter) +end subroutine filter_hq + +!> Spatial lateral filter applied to 3D array. The lateral filter is given +!! by the convolutional kernel: +!! [1 2 1] +!! C = |2 4 2| * 1/16 +!! [1 2 1] +!! The fast algorithm decomposes the 2D filter into two 1D filters as follows: +!! [1] +!! C = |2| * [1 2 1] * 1/16 +!! [1] +!! The input array must have zero B.C. applied. B.C. is applied for output array. +!! Note that maskw contains both land mask and 1/16 factor. +!! Filter implements marching halo. The available halo is specified and as many +!! filter iterations as possible and as needed are performed. +subroutine filter_3D(x, maskw, isd, ied, jsd, jed, is, ie, js, je, nz, & + current_halo, remaining_iterations, & + direction) + integer, intent(in) :: isd !< Indices of array size + integer, intent(in) :: ied !< Indices of array size + integer, intent(in) :: jsd !< Indices of array size + integer, intent(in) :: jed !< Indices of array size + integer, intent(in) :: is !< Indices of owned points + integer, intent(in) :: ie !< Indices of owned points + integer, intent(in) :: js !< Indices of owned points + integer, intent(in) :: je !< Indices of owned points + integer, intent(in) :: nz !< Vertical array size + real, dimension(isd:ied,jsd:jed,nz), & + intent(inout) :: x !< Input/output array [arbitrary] + real, dimension(isd:ied,jsd:jed), & + intent(in) :: maskw !< Mask array of land points divided by 16 [nondim] + integer, intent(inout) :: current_halo !< Currently available halo points + integer, intent(inout) :: remaining_iterations !< The number of iterations to perform + logical, intent(in) :: direction !< The direction of the first 1D filter + + real, parameter :: weight = 2. ! Filter weight [nondim] + integer :: i, j, k, iter, niter, halo + + real :: tmp(isd:ied, jsd:jed) ! Array with temporary results [arbitrary] + + ! Do as many iterations as needed and possible + niter = min(current_halo, remaining_iterations) + if (niter == 0) return ! nothing to do + + ! Update remaining iterations + remaining_iterations = remaining_iterations - niter + ! Update halo information + current_halo = current_halo - niter + + do k=1,Nz + halo = niter-1 + & + current_halo ! Save as many halo points as possible + do iter=1,niter + + if (direction) then + do j = js-halo, je+halo ; do i = is-halo-1, ie+halo+1 + tmp(i,j) = weight * x(i,j,k) + (x(i,j-1,k) + x(i,j+1,k)) + enddo ; enddo + + do j = js-halo, je+halo ; do i = is-halo, ie+halo + x(i,j,k) = (weight * tmp(i,j) + (tmp(i-1,j) + tmp(i+1,j))) * maskw(i,j) + enddo ; enddo + else + do j = js-halo-1, je+halo+1 ; do i = is-halo, ie+halo + tmp(i,j) = weight * x(i,j,k) + (x(i-1,j,k) + x(i+1,j,k)) + enddo ; enddo + + do j = js-halo, je+halo ; do i = is-halo, ie+halo + x(i,j,k) = (weight * tmp(i,j) + (tmp(i,j-1) + tmp(i,j+1))) * maskw(i,j) + enddo ; enddo + endif + + halo = halo - 1 + enddo + enddo + +end subroutine filter_3D + +!> Computes the 3D energy source term for the ZB2020 scheme +!! similarly to MOM_diagnostics.F90, specifically 1125 line. +subroutine compute_energy_source(u, v, h, fx, fy, G, GV, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(ZB2020_CS), intent(in) :: CS !< ZB2020 control structure. + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: fx !< Zonal acceleration due to convergence of + !! along-coordinate stress tensor [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: fy !< Meridional acceleration due to convergence + !! of along-coordinate stress tensor [L T-2 ~> m s-2] + + real :: KE_term(SZI_(G),SZJ_(G),SZK_(GV)) ! A term in the kinetic energy budget + ! [H L2 T-3 ~> m3 s-3 or W m-2] + real :: KE_u(SZIB_(G),SZJ_(G)) ! The area integral of a KE term in a layer at u-points + ! [H L4 T-3 ~> m5 s-3 or kg m2 s-3] + real :: KE_v(SZI_(G),SZJB_(G)) ! The area integral of a KE term in a layer at v-points + ! [H L4 T-3 ~> m5 s-3 or kg m2 s-3] + + real :: uh ! Transport through zonal faces = u*h*dy, + ! [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: vh ! Transport through meridional faces = v*h*dx, + ! [H L2 T-1 ~> m3 s-1 or kg s-1]. + + type(group_pass_type) :: pass_KE_uv ! A handle used for group halo passes + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k + + if (CS%id_KE_ZB2020 > 0) then + call cpu_clock_begin(CS%id_clock_source) + call create_group_pass(pass_KE_uv, KE_u, KE_v, G%Domain, To_North+To_East) + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + KE_term(:,:,:) = 0. + ! Calculate the KE source from Zanna-Bolton2020 [H L2 T-3 ~> m3 s-3]. + do k=1,nz + KE_u(:,:) = 0. + KE_v(:,:) = 0. + do j=js,je ; do I=Isq,Ieq + uh = u(I,j,k) * 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i+1,j)*h(i+1,j,k)) * & + G%dyCu(I,j) + KE_u(I,j) = uh * G%dxCu(I,j) * fx(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + vh = v(i,J,k) * 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i,j+1)*h(i,j+1,k)) * & + G%dxCv(i,J) + KE_v(i,J) = vh * G%dyCv(i,J) * fy(i,J,k) + enddo ; enddo + call do_group_pass(pass_KE_uv, G%domain, clock=CS%id_clock_mpi) + do j=js,je ; do i=is,ie + KE_term(i,j,k) = 0.5 * G%IareaT(i,j) & + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) + enddo ; enddo + enddo + + call cpu_clock_end(CS%id_clock_source) + + call cpu_clock_begin(CS%id_clock_post) + call post_data(CS%id_KE_ZB2020, KE_term, CS%diag) + call cpu_clock_end(CS%id_clock_post) + endif + +end subroutine compute_energy_source + +end module MOM_Zanna_Bolton diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 6a9b49683c..33798b41b4 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -1,34 +1,43 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Calculates horizontal viscosity and viscous stresses module MOM_hor_visc -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_checksums, only : hchksum, Bchksum +use MOM_checksums, only : hchksum, Bchksum, uvchksum use MOM_coms, only : min_across_PEs use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : post_product_u, post_product_sum_u use MOM_diag_mediator, only : post_product_v, post_product_sum_v use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_domains, only : pass_var, CORNER, pass_vector, AGRID, BGRID_NE +use MOM_domains, only : To_All, Scalar_Pair use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_lateral_mixing_coeffs, only : VarMix_CS, calc_QG_Leith_viscosity +use MOM_interface_heights, only : thickness_to_dz +use MOM_lateral_mixing_coeffs, only : VarMix_CS, calc_QG_slopes, calc_QG_Leith_viscosity use MOM_barotropic, only : barotropic_CS, barotropic_get_tav use MOM_thickness_diffuse, only : thickness_diffuse_CS, thickness_diffuse_get_KH use MOM_io, only : MOM_read_data, slasher use MOM_MEKE_types, only : MEKE_type use MOM_open_boundary, only : ocean_OBC_type, OBC_DIRECTION_E, OBC_DIRECTION_W -use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S, OBC_NONE +use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S +use MOM_open_boundary, only : OBC_STRAIN_NONE, OBC_STRAIN_ZERO, OBC_STRAIN_FREESLIP +use MOM_open_boundary, only : OBC_STRAIN_COMPUTED, OBC_STRAIN_SPECIFIED +use MOM_stochastics, only : stochastic_CS use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type -use MOM_variables, only : accel_diag_ptrs +use MOM_variables, only : accel_diag_ptrs, thermo_var_ptrs +use MOM_Zanna_Bolton, only : ZB2020_lateral_stress, ZB2020_init, ZB2020_end +use MOM_Zanna_Bolton, only : ZB2020_CS, ZB2020_copy_gradient_and_thickness implicit none ; private #include -public horizontal_viscosity, hor_visc_init, hor_visc_end +public horizontal_viscosity, hor_visc_init, hor_visc_end, hor_visc_vel_stencil !> Control structure for horizontal viscosity type, public :: hor_visc_CS ; private @@ -45,18 +54,26 @@ module MOM_hor_visc !! are not implemented with the biharmonic viscosity. logical :: bound_Kh !< If true, the Laplacian coefficient is locally !! limited to guarantee stability. - logical :: better_bound_Kh !< If true, use a more careful bounding of the - !! Laplacian viscosity to guarantee stability. + logical :: EY24_EBT_BS !! If true, use an equivalent barotropic backscatter + !! with a stabilizing kill switch in MEKE, + !< developed by Yankovsky et al. 2024 logical :: bound_Ah !< If true, the biharmonic coefficient is locally !! limited to guarantee stability. - logical :: better_bound_Ah !< If true, use a more careful bounding of the - !! biharmonic viscosity to guarantee stability. real :: Re_Ah !! If nonzero, the biharmonic coefficient is scaled - !< so that the biharmonic Reynolds number is equal to this. + !< so that the biharmonic Reynolds number is equal to this [nondim]. real :: bound_coef !< The nondimensional coefficient of the ratio of !! the viscosity bounds to the theoretical maximum !! for stability without considering other terms [nondim]. !! The default is 0.8. + real :: KS_coef !< A nondimensional coefficient on the biharmonic viscosity that sets the + !! kill switch for backscatter. Default is 1.0 [nondim]. + real :: KS_timescale !< A timescale for computing CFL limit for turning off backscatter [T ~> s]. + logical :: backscatter_underbound !< If true, the bounds on the biharmonic viscosity are allowed + !! to increase where the Laplacian viscosity is negative (due to + !! backscatter parameterizations) beyond the largest timestep-dependent + !! stable values of biharmonic viscosity when no Laplacian viscosity is + !! applied. The default is true for historical reasons, but this option + !! probably should not be used as it can lead to numerical instabilities. logical :: Smagorinsky_Kh !< If true, use Smagorinsky nonlinear eddy !! viscosity. KH is the background value. logical :: Smagorinsky_Ah !< If true, use a biharmonic form of Smagorinsky @@ -68,6 +85,13 @@ module MOM_hor_visc logical :: use_beta_in_Leith !< If true, includes the beta term in the Leith viscosity logical :: Leith_Ah !< If true, use a biharmonic form of 2D Leith !! nonlinear eddy viscosity. AH is the background. + logical :: use_Leithy !< If true, use a biharmonic form of 2D Leith + !! nonlinear eddy viscosity with harmonic backscatter. + !! Ah is the background. Leithy = Leith+E + real :: c_K !< Fraction of energy dissipated by the biharmonic term + !! that gets backscattered in the Leith+E scheme. [nondim] + logical :: smooth_Ah !< If true (default), then Ah and m_leithy are smoothed. + !! This smoothing requires a lot of blocking communication. logical :: use_QG_Leith_visc !< If true, use QG Leith nonlinear eddy viscosity. !! KH is the background value. logical :: bound_Coriolis !< If true & SMAGORINSKY_AH is used, the biharmonic @@ -78,6 +102,10 @@ module MOM_hor_visc !! in setting the corner-point viscosities when USE_KH_BG_2D=True. real :: Kh_bg_min !< The minimum value allowed for Laplacian horizontal !! viscosity [L2 T-1 ~> m2 s-1]. The default is 0.0. + logical :: FrictWork_bug !< If true, retain an answer-changing bug in calculating FrictWork, + !! which cancels the h in thickness flux and the h at velocity point. + logical :: OBC_strain_bug !< If true, recover a bug that specified shear strain option at open + !! boundaries cannot be applied. logical :: use_land_mask !< Use the land mask for the computation of thicknesses !! at velocity locations. This eliminates the dependence on !! arbitrary values over land or outside of the domain. @@ -92,23 +120,29 @@ module MOM_hor_visc logical :: res_scale_MEKE !< If true, the viscosity contribution from MEKE is scaled by !! the resolution function. logical :: use_GME !< If true, use GME backscatter scheme. - logical :: answers_2018 !< If true, use the order of arithmetic and expressions that recover the - !! answers from the end of 2018. Otherwise, use updated and more robust - !! forms of the same expressions. + integer :: 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. real :: GME_h0 !< The strength of GME tapers quadratically to zero when the bathymetric - !! depth is shallower than GME_H0 [Z ~> m] + !! total water column thickness is less than GME_H0 [H ~> m or kg m-2] real :: GME_efficiency !< The nondimensional prefactor multiplying the GME coefficient [nondim] real :: GME_limiter !< The absolute maximum value the GME coefficient is allowed to take [L2 T-1 ~> m2 s-1]. real :: min_grid_Kh !< Minimum horizontal Laplacian viscosity used to !! limit the grid Reynolds number [L2 T-1 ~> m2 s-1] real :: min_grid_Ah !< Minimun horizontal biharmonic viscosity used to !! limit grid Reynolds number [L4 T-1 ~> m4 s-1] + logical :: use_cont_thick !< If true, thickness at velocity points adopts h[uv] in BT_cont from continuity solver. + logical :: use_cont_thick_bug !< If true, retain an answer-changing bug for thickness at velocity points. + type(ZB2020_CS) :: ZB2020 !< Zanna-Bolton 2020 control structure. + logical :: use_ZB2020 !< If true, use Zanna-Bolton 2020 parameterization. + logical :: use_circulation !< If true, use circulation theorem to compute vorticity (for ZB20 or Leith) real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Kh_bg_xx !< The background Laplacian viscosity at h points [L2 T-1 ~> m2 s-1]. !! The actual viscosity may be the larger of this !! viscosity and the Smagorinsky and Leith viscosities. - real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Kh_bg_2d + real, allocatable :: Kh_bg_2d(:,:) !< The background Laplacian viscosity at h points [L2 T-1 ~> m2 s-1]. !! The actual viscosity may be the larger of this !! viscosity and the Smagorinsky and Leith viscosities. @@ -119,11 +153,13 @@ module MOM_hor_visc real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: reduction_xx !< The amount by which stresses through h points are reduced !! due to partial barriers [nondim]. + real, allocatable :: Kh_Max_xx(:,:) !< The maximum permitted Laplacian viscosity [L2 T-1 ~> m2 s-1]. + real, allocatable :: Ah_Max_xx(:,:) !< The maximum permitted biharmonic viscosity [L4 T-1 ~> m4 s-1]. + real, allocatable :: Ah_Max_xx_KS(:,:) !< The maximum permitted biharmonic viscosity for + !! the kill switch [L4 T-1 ~> m4 s-1]. + real, allocatable :: n1n2_h(:,:) !< Factor n1*n2 in the anisotropic direction tensor at h-points [nondim] + real, allocatable :: n1n1_m_n2n2_h(:,:) !< Factor n1**2-n2**2 in the anisotropic direction tensor at h-points [nondim] real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & - Kh_Max_xx, & !< The maximum permitted Laplacian viscosity [L2 T-1 ~> m2 s-1]. - Ah_Max_xx, & !< The maximum permitted biharmonic viscosity [L4 T-1 ~> m4 s-1]. - n1n2_h, & !< Factor n1*n2 in the anisotropic direction tensor at h-points - n1n1_m_n2n2_h, & !< Factor n1**2-n2**2 in the anisotropic direction tensor at h-points grid_sp_h2, & !< Harmonic mean of the squares of the grid [L2 ~> m2] grid_sp_h3 !< Harmonic mean of the squares of the grid^(3/2) [L3 ~> m3] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: Kh_bg_xy @@ -137,17 +173,20 @@ module MOM_hor_visc real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: reduction_xy !< The amount by which stresses through q points are reduced !! due to partial barriers [nondim]. - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & - Kh_Max_xy, & !< The maximum permitted Laplacian viscosity [L2 T-1 ~> m2 s-1]. - Ah_Max_xy, & !< The maximum permitted biharmonic viscosity [L4 T-1 ~> m4 s-1]. - n1n2_q, & !< Factor n1*n2 in the anisotropic direction tensor at q-points - n1n1_m_n2n2_q !< Factor n1**2-n2**2 in the anisotropic direction tensor at q-points + real, allocatable :: Kh_Max_xy(:,:) !< The maximum permitted Laplacian viscosity [L2 T-1 ~> m2 s-1]. + real, allocatable :: Ah_Max_xy(:,:) !< The maximum permitted biharmonic viscosity [L4 T-1 ~> m4 s-1]. + real, allocatable :: Ah_Max_xy_KS(:,:) !< The maximum permitted biharmonic viscosity for + !! the kill switch [L4 T-1 ~> m4 s-1]. + real, allocatable :: n1n2_q(:,:) !< Factor n1*n2 in the anisotropic direction tensor at q-points [nondim] + real, allocatable :: n1n1_m_n2n2_q(:,:) !< Factor n1**2-n2**2 in the anisotropic direction tensor at q-points [nondim] real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & - dx2h, & !< Pre-calculated dx^2 at h points [L2 ~> m2] - dy2h, & !< Pre-calculated dy^2 at h points [L2 ~> m2] - dx_dyT, & !< Pre-calculated dx/dy at h points [nondim] - dy_dxT !< Pre-calculated dy/dx at h points [nondim] + dx2h, & !< Pre-calculated dx^2 at h points [L2 ~> m2] + dy2h, & !< Pre-calculated dy^2 at h points [L2 ~> m2] + dx_dyT, & !< Pre-calculated dx/dy at h points [nondim] + dy_dxT !< Pre-calculated dy/dx at h points [nondim] + real, allocatable :: m_const_leithy(:,:) !< Pre-calculated .5*sqrt(c_K)*max{dx,dy} [L ~> m] + real, allocatable :: m_leithy_max(:,:) !< Pre-calculated 4./max(dx,dy)^2 at h points [L-2 ~> m-2] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & dx2q, & !< Pre-calculated dx^2 at q points [L2 ~> m2] dy2q, & !< Pre-calculated dy^2 at q points [L2 ~> m2] @@ -162,29 +201,30 @@ module MOM_hor_visc ! The following variables are precalculated time-invariant combinations of ! parameters and metric terms. - real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & - Laplac2_const_xx, & !< Laplacian metric-dependent constants [L2 ~> m2] - Biharm6_const_xx, & !< Biharmonic metric-dependent constants [L6 ~> m6] - Laplac3_const_xx, & !< Laplacian metric-dependent constants [L3 ~> m3] - Biharm_const_xx, & !< Biharmonic metric-dependent constants [L4 ~> m4] - Biharm_const2_xx, & !< Biharmonic metric-dependent constants [T L4 ~> s m4] - Re_Ah_const_xx !< Biharmonic metric-dependent constants [L3 ~> m3] - - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & - Laplac2_const_xy, & !< Laplacian metric-dependent constants [L2 ~> m2] - Biharm6_const_xy, & !< Biharmonic metric-dependent constants [L6 ~> m6] - Laplac3_const_xy, & !< Laplacian metric-dependent constants [L3 ~> m3] - Biharm_const_xy, & !< Biharmonic metric-dependent constants [L4 ~> m4] - Biharm_const2_xy, & !< Biharmonic metric-dependent constants [T L4 ~> s m4] - Re_Ah_const_xy !< Biharmonic metric-dependent constants [L3 ~> m3] + real, allocatable :: Laplac2_const_xx(:,:) !< Laplacian metric-dependent constants [L2 ~> m2] + real, allocatable :: Biharm6_const_xx(:,:) !< Biharmonic metric-dependent constants [L6 ~> m6] + real, allocatable :: Laplac3_const_xx(:,:) !< Laplacian metric-dependent constants [L3 ~> m3] + real, allocatable :: Biharm_const_xx(:,:) !< Biharmonic metric-dependent constants [L4 ~> m4] + real, allocatable :: Biharm_const2_xx(:,:) !< Biharmonic metric-dependent constants [T L4 ~> s m4] + real, allocatable :: Re_Ah_const_xx(:,:) !< Biharmonic metric-dependent constants [L3 ~> m3] + + real, allocatable :: Laplac2_const_xy(:,:) !< Laplacian metric-dependent constants [L2 ~> m2] + real, allocatable :: Biharm6_const_xy(:,:) !< Biharmonic metric-dependent constants [L6 ~> m6] + real, allocatable :: Laplac3_const_xy(:,:) !< Laplacian metric-dependent constants [L3 ~> m3] + real, allocatable :: Biharm_const_xy(:,:) !< Biharmonic metric-dependent constants [L4 ~> m4] + real, allocatable :: Biharm_const2_xy(:,:) !< Biharmonic metric-dependent constants [T L4 ~> s m4] + real, allocatable :: Re_Ah_const_xy(:,:) !< Biharmonic metric-dependent constants [L3 ~> m3] type(diag_ctrl), pointer :: diag => NULL() !< structure to regulate diagnostics - ! real, allocatable :: hf_diffu(:,:,:) ! Zonal hor. visc. accel. x fract. thickness [L T-2 ~> m s-2]. - ! real, allocatable :: hf_diffv(:,:,:) ! Merdional hor. visc. accel. x fract. thickness [L T-2 ~> m s-2]. + ! real, allocatable :: hf_diffu(:,:,:) ! Zonal horizontal viscous acceleleration times + ! ! fractional thickness [L T-2 ~> m s-2]. + ! real, allocatable :: hf_diffv(:,:,:) ! Meridional horizontal viscous acceleleration times + ! ! fractional thickness [L T-2 ~> m s-2]. ! 3D diagnostics hf_diffu(diffv) are commented because there is no clarity on proper remapping grid option. - ! The code is retained for degugging purposes in the future. + ! The code is retained for debugging purposes in the future. + integer :: num_smooth_gme !< number of smoothing passes for the GME fluxes. !>@{ !! Diagnostic id integer :: id_grid_Re_Ah = -1, id_grid_Re_Kh = -1 @@ -197,11 +237,18 @@ module MOM_hor_visc integer :: id_Ah_h = -1, id_Ah_q = -1 integer :: id_Kh_h = -1, id_Kh_q = -1 integer :: id_GME_coeff_h = -1, id_GME_coeff_q = -1 + integer :: id_dudx_bt = -1, id_dvdy_bt = -1 + integer :: id_dudy_bt = -1, id_dvdx_bt = -1 integer :: id_vort_xy_q = -1, id_div_xx_h = -1 integer :: id_sh_xy_q = -1, id_sh_xx_h = -1 integer :: id_FrictWork = -1, id_FrictWorkIntz = -1 + integer :: id_FrictWork_bh = -1, id_FrictWorkIntz_bh = -1 integer :: id_FrictWork_GME = -1 integer :: id_normstress = -1, id_shearstress = -1 + integer :: id_visc_limit_h = -1, id_visc_limit_q = -1 + integer :: id_visc_limit_h_flag = -1, id_visc_limit_q_flag = -1 + integer :: id_visc_limit_h_frac = -1, id_visc_limit_q_frac = -1 + integer :: id_BS_coeff_h = -1, id_BS_coeff_q = -1 !>@} end type hor_visc_CS @@ -217,11 +264,11 @@ module MOM_hor_visc !! !! To work, the following fields must be set outside of the usual !! is:ie range before this subroutine is called: -!! u[is-2:ie+2,js-2:je+2] -!! v[is-2:ie+2,js-2:je+2] -!! h[is-1:ie+1,js-1:je+1] -subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, & - CS, OBC, BT, TD, ADp) +!! u(is-2:ie+2,js-2:je+2) +!! v(is-2:ie+2,js-2:je+2) +!! h(is-1:ie+1,js-1:je+1) or up to h(is-2:ie+2,js-2:je+2) with some Leith options. +subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, GV, US, & + CS, tv, dt, OBC, BT, TD, ADp, hu_cont, hv_cont, STOCH) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & @@ -230,6 +277,10 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: uh !< The zonal volume transport [H L2 T-1 ~> m3 s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: vh !< The meridional volume transport [H L2 T-1 ~> m3 s-1]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(out) :: diffu !< Zonal acceleration due to convergence of !! along-coordinate stress tensor [L T-2 ~> m s-2] @@ -238,75 +289,87 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !! of along-coordinate stress tensor [L T-2 ~> m s-2]. type(MEKE_type), intent(inout) :: MEKE !< MEKE fields !! related to Mesoscale Eddy Kinetic Energy. - type(VarMix_CS), intent(inout) :: VarMix !< Variable mixing control struct - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(hor_visc_CS), intent(in) :: CS !< Horizontal viscosity control struct - type(ocean_OBC_type), optional, pointer :: OBC !< Pointer to an open boundary condition type - type(barotropic_CS), intent(in), optional :: BT !< Barotropic control struct - type(thickness_diffuse_CS), intent(in), optional :: TD !< Thickness diffusion control struct - type(accel_diag_ptrs), intent(in), optional :: ADp !< Acceleration diagnostics + type(VarMix_CS), intent(inout) :: VarMix !< Variable mixing control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(hor_visc_CS), intent(inout) :: CS !< Horizontal viscosity control structure + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + real, intent(in) :: dt !< Time increment [T ~> s] + type(ocean_OBC_type), optional, pointer :: OBC !< Pointer to an open boundary condition type + type(barotropic_CS), optional, intent(in) :: BT !< Barotropic control structure + type(thickness_diffuse_CS), optional, intent(in) :: TD !< Thickness diffusion control structure + type(accel_diag_ptrs), optional, intent(in) :: ADp !< Acceleration diagnostics + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + optional, intent(inout) :: hu_cont !< Layer thickness at u-points [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + optional, intent(inout) :: hv_cont !< Layer thickness at v-points [H ~> m or kg m-2]. + type(stochastic_CS), intent(inout), optional :: STOCH !< Stochastic control structure ! Local variables real, dimension(SZIB_(G),SZJ_(G)) :: & - Del2u, & ! The u-compontent of the Laplacian of velocity [L-1 T-1 ~> m-1 s-1] + Del2u, & ! The u-component of the Laplacian of velocity [L-1 T-1 ~> m-1 s-1] h_u, & ! Thickness interpolated to u points [H ~> m or kg m-2]. vort_xy_dy, & ! y-derivative of vertical vorticity (d/dy(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] + vort_xy_dy_smooth, & ! y-derivative of smoothed vertical vorticity [L-1 T-1 ~> m-1 s-1] div_xx_dx, & ! x-derivative of horizontal divergence (d/dx(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1] - ubtav ! zonal barotropic vel. ave. over baroclinic time-step [L T-1 ~> m s-1] + ubtav ! zonal barotropic velocity averaged over a baroclinic time-step [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G)) :: & - Del2v, & ! The v-compontent of the Laplacian of velocity [L-1 T-1 ~> m-1 s-1] + Del2v, & ! The v-component of the Laplacian of velocity [L-1 T-1 ~> m-1 s-1] h_v, & ! Thickness interpolated to v points [H ~> m or kg m-2]. vort_xy_dx, & ! x-derivative of vertical vorticity (d/dx(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] + vort_xy_dx_smooth, & ! x-derivative of smoothed vertical vorticity [L-1 T-1 ~> m-1 s-1] div_xx_dy, & ! y-derivative of horizontal divergence (d/dy(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1] - vbtav ! meridional barotropic vel. ave. over baroclinic time-step [L T-1 ~> m s-1] + vbtav ! meridional barotropic velocity averaged over a baroclinic time-step [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G)) :: & dudx_bt, dvdy_bt, & ! components in the barotropic horizontal tension [T-1 ~> s-1] div_xx, & ! Estimate of horizontal divergence at h-points [T-1 ~> s-1] sh_xx, & ! horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1] + sh_xx_smooth, & ! horizontal tension from smoothed velocity including metric terms [T-1 ~> s-1] sh_xx_bt, & ! barotropic horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1] - str_xx,& ! str_xx is the diagonal term in the stress tensor [H L2 T-2 ~> m3 s-2 or kg s-2] - str_xx_GME,& ! smoothed diagonal term in the stress tensor from GME [H L2 T-2 ~> m3 s-2 or kg s-2] + str_xx,& ! str_xx is the diagonal term in the stress tensor [H L2 T-2 ~> m3 s-2 or kg s-2], but + ! at some points in the code it is not yet layer integrated, so is in [L2 T-2 ~> m2 s-2]. + str_xx_GME,& ! smoothed diagonal term in the stress tensor from GME [L2 T-2 ~> m2 s-2] bhstr_xx, & ! A copy of str_xx that only contains the biharmonic contribution [H L2 T-2 ~> m3 s-2 or kg s-2] - FrictWorkIntz, & ! depth integrated energy dissipated by lateral friction [R L2 T-3 ~> W m-2] + FrictWorkIntz, & ! depth integrated energy dissipated by lateral friction [R Z L2 T-3 ~> W m-2] + FrictWorkIntz_bh, & ! depth integrated energy dissipated by biharmonic lateral friction [R Z L2 T-3 ~> W m-2] grad_vort_mag_h, & ! Magnitude of vorticity gradient at h-points [L-1 T-1 ~> m-1 s-1] grad_vort_mag_h_2d, & ! Magnitude of 2d vorticity gradient at h-points [L-1 T-1 ~> m-1 s-1] - Del2vort_h, & ! Laplacian of vorticity at h-points [L-2 T-1 ~> m-2 s-1] grad_div_mag_h, & ! Magnitude of divergence gradient at h-points [L-1 T-1 ~> m-1 s-1] dudx, dvdy, & ! components in the horizontal tension [T-1 ~> s-1] - grad_vel_mag_h, & ! Magnitude of the velocity gradient tensor squared at h-points [T-2 ~> s-2] - grad_vel_mag_bt_h, & ! Magnitude of the barotropic velocity gradient tensor squared at h-points [T-2 ~> s-2] - grad_d2vel_mag_h, & ! Magnitude of the Laplacian of the velocity vector, squared [L-2 T-2 ~> m-2 s-2] + dudx_smooth, dvdy_smooth, & ! components in the horizontal tension from smoothed velocity [T-1 ~> s-1] GME_effic_h, & ! The filtered efficiency of the GME terms at h points [nondim] - htot, & ! The total thickness of all layers [Z ~> m] - boundary_mask_h ! A mask that zeroes out cells with at least one land edge [nondim] - - real, allocatable, dimension(:,:,:) :: h_diffu ! h x diffu [H L T-2 ~> m2 s-2] - real, allocatable, dimension(:,:,:) :: h_diffv ! h x diffv [H L T-2 ~> m2 s-2] - real, allocatable, dimension(:,:,:) :: diffu_visc_rem ! diffu x visc_rem_u [L T-2 ~> m s-2] - real, allocatable, dimension(:,:,:) :: diffv_visc_rem ! diffv x visc_rem_v [L T-2 ~> m s-2] + m_leithy, & ! Kh=m_leithy*Ah in Leith+E parameterization [L-2 ~> m-2] + Ah_sq, & ! The square of the biharmonic viscosity [L8 T-2 ~> m8 s-2] + htot, & ! The total thickness of all layers [H ~> m or kg m-2] + str_xx_BS ! The diagonal term in the stress tensor due to backscatter [H L2 T-2 ~> m3 s-2 or kg s-2] + real :: Del2vort_h ! Laplacian of vorticity at h-points [L-2 T-1 ~> m-2 s-1] + real :: grad_vel_mag_bt_h ! Magnitude of the barotropic velocity gradient tensor squared at h-points [T-2 ~> s-2] + real :: boundary_mask_h ! A mask that zeroes out cells with at least one land edge [nondim] real, dimension(SZIB_(G),SZJB_(G)) :: & dvdx, dudy, & ! components in the shearing strain [T-1 ~> s-1] + dvdx_smooth, dudy_smooth, & ! components in the shearing strain from smoothed velocity [T-1 ~> s-1] dDel2vdx, dDel2udy, & ! Components in the biharmonic equivalent of the shearing strain [L-2 T-1 ~> m-2 s-1] dvdx_bt, dudy_bt, & ! components in the barotropic shearing strain [T-1 ~> s-1] sh_xy, & ! horizontal shearing strain (du/dy + dv/dx) including metric terms [T-1 ~> s-1] + sh_xy_smooth, & ! horizontal shearing strain from smoothed velocity including metric terms [T-1 ~> s-1] sh_xy_bt, & ! barotropic horizontal shearing strain (du/dy + dv/dx) inc. metric terms [T-1 ~> s-1] - str_xy, & ! str_xy is the cross term in the stress tensor [H L2 T-2 ~> m3 s-2 or kg s-2] - str_xy_GME, & ! smoothed cross term in the stress tensor from GME [H L2 T-2 ~> m3 s-2 or kg s-2] + str_xy, & ! str_xy is the cross term in the stress tensor [H L2 T-2 ~> m3 s-2 or kg s-2], but + ! at some points in the code it is not yet layer integrated, so is in [L2 T-2 ~> m2 s-2]. + str_xy_GME, & ! smoothed cross term in the stress tensor from GME [L2 T-2 ~> m2 s-2] bhstr_xy, & ! A copy of str_xy that only contains the biharmonic contribution [H L2 T-2 ~> m3 s-2 or kg s-2] vort_xy, & ! Vertical vorticity (dv/dx - du/dy) including metric terms [T-1 ~> s-1] - Leith_Kh_q, & ! Leith Laplacian viscosity at q-points [L2 T-1 ~> m2 s-1] - Leith_Ah_q, & ! Leith bi-harmonic viscosity at q-points [L4 T-1 ~> m4 s-1] + vort_xy_smooth, & ! Vertical vorticity including metric terms, smoothed [T-1 ~> s-1] grad_vort_mag_q, & ! Magnitude of vorticity gradient at q-points [L-1 T-1 ~> m-1 s-1] grad_vort_mag_q_2d, & ! Magnitude of 2d vorticity gradient at q-points [L-1 T-1 ~> m-1 s-1] Del2vort_q, & ! Laplacian of vorticity at q-points [L-2 T-1 ~> m-2 s-1] grad_div_mag_q, & ! Magnitude of divergence gradient at q-points [L-1 T-1 ~> m-1 s-1] - grad_vel_mag_q, & ! Magnitude of the velocity gradient tensor squared at q-points [T-2 ~> s-2] - hq, & ! harmonic mean of the harmonic means of the u- & v point thicknesses [H ~> m or kg m-2] - ! This form guarantees that hq/hu < 4. - grad_vel_mag_bt_q, & ! Magnitude of the barotropic velocity gradient tensor squared at q-points [T-2 ~> s-2] - GME_effic_q, & ! The filtered efficiency of the GME terms at q points [nondim] - boundary_mask_q ! A mask that zeroes out cells with at least one land edge [nondim] + hq, & ! harmonic mean of the harmonic means of the u- & v point thicknesses [H ~> m or kg m-2] + ! This form guarantees that hq/hu < 4. + GME_effic_q, & ! The filtered efficiency of the GME terms at q points [nondim] + str_xy_BS ! The cross term in the stress tensor due to backscatter [H L2 T-2 ~> m3 s-2 or kg s-2] + real :: grad_vel_mag_bt_q ! Magnitude of the barotropic velocity gradient tensor squared at q-points [T-2 ~> s-2] + real :: boundary_mask_q ! A mask that zeroes out cells with at least one land edge [nondim] real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)) :: & Ah_q, & ! biharmonic viscosity at corner points [L4 T-1 ~> m4 s-1] @@ -314,28 +377,42 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, vort_xy_q, & ! vertical vorticity at corner points [T-1 ~> s-1] sh_xy_q, & ! horizontal shearing strain at corner points [T-1 ~> s-1] GME_coeff_q, & !< GME coeff. at q-points [L2 T-1 ~> m2 s-1] + visc_limit_q, & ! used to stabilize the EY24_EBT_BS backscatter [nondim] + visc_limit_q_flag, & ! determines whether backscatter is shut off [nondim] + visc_limit_q_frac, & ! determines how close backscatter is to shutting off [nondim] + BS_coeff_q, & ! A diagnostic array of the backscatter coefficient [L2 T-1 ~> m2 s-1] ShSt ! A diagnostic array of shear stress [T-1 ~> s-1]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & - KH_u_GME !< interface height diffusivities in u-columns [L2 T-1 ~> m2 s-1] + KH_u_GME, & !< Isopycnal height diffusivities in u-columns [L2 T-1 ~> m2 s-1] + slope_x !< Isopycnal slope in i-direction [Z L-1 ~> nondim] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & - KH_v_GME !< interface height diffusivities in v-columns [L2 T-1 ~> m2 s-1] + KH_v_GME, & !< Isopycnal height diffusivities in v-columns [L2 T-1 ~> m2 s-1] + slope_y !< Isopycnal slope in j-direction [Z L-1 ~> nondim] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & Ah_h, & ! biharmonic viscosity at thickness points [L4 T-1 ~> m4 s-1] Kh_h, & ! Laplacian viscosity at thickness points [L2 T-1 ~> m2 s-1] - FrictWork, & ! work done by MKE dissipation mechanisms [R L2 T-3 ~> W m-2] - FrictWork_GME, & ! work done by GME [R L2 T-3 ~> W m-2] + dz, & ! Height change across layers [Z ~> m] + FrictWork, & ! work done by MKE dissipation mechanisms [R Z L2 T-3 ~> W m-2] + FrictWork_bh, & ! work done by the biharmonic MKE dissipation mechanisms [R Z L2 T-3 ~> W m-2] + FrictWork_GME, & ! work done by GME [R Z L2 T-3 ~> W m-2] div_xx_h, & ! horizontal divergence [T-1 ~> s-1] sh_xx_h, & ! horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1] - NoSt ! A diagnostic array of normal stress [T-1 ~> s-1]. + NoSt, & ! A diagnostic array of normal stress [T-1 ~> s-1]. + BS_coeff_h ! A diagnostic array of the backscatter coefficient [L2 T-1 ~> m2 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & grid_Re_Kh, & ! Grid Reynolds number for Laplacian horizontal viscosity at h points [nondim] grid_Re_Ah, & ! Grid Reynolds number for Biharmonic horizontal viscosity at h points [nondim] - GME_coeff_h ! GME coeff. at h-points [L2 T-1 ~> m2 s-1] + GME_coeff_h, & ! GME coefficient at h-points [L2 T-1 ~> m2 s-1] + visc_limit_h, & ! Used to stabilize the EY24_EBT_BS backscatter [nondim] + visc_limit_h_flag, & ! determines whether backscatter is shut off [nondim] + visc_limit_h_frac ! determines how close backscatter is to shutting off [nondim] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & + u_smooth ! Zonal velocity, smoothed with a spatial low-pass filter [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & + v_smooth ! Meridional velocity, smoothed with a spatial low-pass filter [L T-1 ~> m s-1] real :: AhSm ! Smagorinsky biharmonic viscosity [L4 T-1 ~> m4 s-1] real :: AhLth ! 2D Leith biharmonic viscosity [L4 T-1 ~> m4 s-1] - real :: mod_Leith ! nondimensional coefficient for divergence part of modified Leith - ! viscosity. Here set equal to nondimensional Laplacian Leith constant. - ! This is set equal to zero if modified Leith is not used. + real :: AhLthy ! 2D Leith+E biharmonic viscosity [L4 T-1 ~> m4 s-1] real :: Shear_mag_bc ! Shear_mag value in backscatter [T-1 ~> s-1] real :: sh_xx_sq ! Square of tension (sh_xx) [T-2 ~> s-2] real :: sh_xy_sq ! Square of shearing strain (sh_xy) [T-2 ~> s-2] @@ -343,81 +420,98 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, real :: hu, hv ! Thicknesses interpolated by arithmetic means to corner ! points; these are first interpolated to u or v velocity ! points where masks are applied [H ~> m or kg m-2]. - real :: h_arith_q ! The arithmetic mean total thickness at q points [Z ~> m] - real :: h_harm_q ! The harmonic mean total thickness at q points [Z ~> m] - real :: I_hq ! The inverse of the arithmetic mean total thickness at q points [Z-1 ~> m-1] - real :: I_GME_h0 ! The inverse of GME tapering scale [Z-1 ~> m-1] + real :: h_arith_q ! The arithmetic mean total thickness at q points [H ~> m or kg m-2] + real :: I_GME_h0 ! The inverse of GME tapering scale [H-1 ~> m-1 or m2 kg-1] real :: h_neglect ! thickness so small it can be lost in roundoff and so neglected [H ~> m or kg m-2] real :: h_neglect3 ! h_neglect^3 [H3 ~> m3 or kg3 m-6] real :: h_min ! Minimum h at the 4 neighboring velocity points [H ~> m] - real :: Kh_scale ! A factor between 0 and 1 by which the horizontal - ! Laplacian viscosity is rescaled [nondim] + real :: Kh_max_here ! The local maximum Laplacian viscosity for stability [L2 T-1 ~> m2 s-1] real :: RoScl ! The scaling function for MEKE source term [nondim] real :: FatH ! abs(f) at h-point for MEKE source term [T-1 ~> s-1] real :: local_strain ! Local variable for interpolating computed strain rates [T-1 ~> s-1]. - real :: meke_res_fn ! A copy of the resolution scaling factor if being applied to MEKE. Otherwise =1. + real :: meke_res_fn ! A copy of the resolution scaling factor if being applied to MEKE [nondim]. Otherwise = 1. real :: GME_coeff ! The GME (negative) viscosity coefficient [L2 T-1 ~> m2 s-1] - real :: GME_coeff_limiter ! Maximum permitted value of the GME coefficient [L2 T-1 ~> m2 s-1] - real :: FWfrac ! Fraction of maximum theoretical energy transfer to use when scaling GME coefficient [nondim] real :: DY_dxBu ! Ratio of meridional over zonal grid spacing at vertices [nondim] - real :: DX_dyBu ! Ratio of zonal over meridiononal grid spacing at vertices [nondim] - real :: DY_dxCv ! Ratio of meridional over zonal grid spacing at faces [nondim] - real :: DX_dyCu ! Ratio of zonal over meridional grid spacing at faces [nondim] + real :: DX_dyBu ! Ratio of zonal over meridional grid spacing at vertices [nondim] real :: Sh_F_pow ! The ratio of shear over the absolute value of f raised to some power and rescaled [nondim] real :: backscat_subround ! The ratio of f over Shear_mag that is so small that the backscatter ! calculation gives the same value as if f were 0 [nondim]. - real :: H0_GME ! Depth used to scale down GME coefficient in shallow areas [Z ~> m] real :: KE ! Local kinetic energy [L2 T-2 ~> m2 s-2] real :: d_del2u ! dy-weighted Laplacian(u) diff in x [L-2 T-1 ~> m-2 s-1] real :: d_del2v ! dx-weighted Laplacian(v) diff in y [L-2 T-1 ~> m-2 s-1] - real :: d_str ! Stress tensor update [H L2 T-2 ~> m3 s-2 or kg s-2] + real :: d_str ! Stress tensor update [L2 T-2 ~> m2 s-2] real :: grad_vort ! Vorticity gradient magnitude [L-1 T-1 ~> m-1 s-1] real :: grad_vort_qg ! QG-based vorticity gradient magnitude [L-1 T-1 ~> m-1 s-1] real :: grid_Kh ! Laplacian viscosity bound by grid [L2 T-1 ~> m2 s-1] real :: grid_Ah ! Biharmonic viscosity bound by grid [L4 T-1 ~> m4 s-1] - logical :: rescale_Kh, legacy_bound + logical :: rescale_Kh logical :: find_FrictWork logical :: apply_OBC = .false. + logical :: apply_OBC_strain logical :: use_MEKE_Ku logical :: use_MEKE_Au + logical :: skeb_use_frict + logical :: use_cont_huv + logical :: use_kh_struct + integer :: is_vort, ie_vort, js_vort, je_vort ! Loop ranges for vorticity terms + integer :: is_Kh, ie_Kh, js_Kh, je_Kh ! Loop ranges for thickness point viscosities integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: i, j, k, n - real :: inv_PI3, inv_PI2, inv_PI6 + real :: inv_PI3, inv_PI2, inv_PI6 ! Powers of the inverse of pi [nondim] + real :: tmp ! Fields evaluated on active layers, used for constructing 3D stress fields ! NOTE: The position of these declarations can impact performance, due to the ! very large number of stack arrays in this function. Move with caution! + ! NOTE: Several of these are declared with the memory extent of q-points, but the + ! same arrays are also used at h-points to reduce the memory footprint of this + ! module, so they should never be used in halo point or checksum calls. real, dimension(SZIB_(G),SZJB_(G)) :: & Ah, & ! biharmonic viscosity (h or q) [L4 T-1 ~> m4 s-1] - Kh, & ! Laplacian viscosity [L2 T-1 ~> m2 s-1] - Shear_mag, & ! magnitude of the shear [T-1 ~> s-1] - vert_vort_mag, & ! magnitude of the vertical vorticity gradient [L-1 T-1 ~> m-1 s-1] + Kh, & ! Laplacian viscosity (h or q) [L2 T-1 ~> m2 s-1] + Kh_BS, & ! Laplacian antiviscosity [L2 T-1 ~> m2 s-1] + Shear_mag, & ! magnitude of the shear (h or q) [T-1 ~> s-1] + vert_vort_mag, & ! magnitude of the vertical vorticity gradient (h or q) [L-1 T-1 ~> m-1 s-1] + vert_vort_mag_smooth, & ! magnitude of gradient of smoothed vertical vorticity (h or q) [L-1 T-1 ~> m-1 s-1] hrat_min, & ! h_min divided by the thickness at the stress point (h or q) [nondim] - visc_bound_rem ! fraction of overall viscous bounds that remain to be applied [nondim] - - real, dimension(SZIB_(G),SZJ_(G)) :: & - hf_diffu_2d, & ! Depth sum of hf_diffu, hf_diffv [L T-2 ~> m s-2] - intz_diffu_2d ! Depth-integral of diffu [H L T-2 ~> m2 s-2] - - real, dimension(SZI_(G),SZJB_(G)) :: & - hf_diffv_2d, & ! Depth sum of hf_diffu, hf_diffv [L T-2 ~> m s-2] - intz_diffv_2d ! Depth-integral of diffv [H L T-2 ~> m2 s-2] + visc_bound_rem ! fraction of overall viscous bounds that remain to be applied (h or q) [nondim] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB h_neglect = GV%H_subroundoff - h_neglect3 = h_neglect**3 + !h_neglect3 = h_neglect**3 + h_neglect3 = h_neglect*h_neglect*h_neglect inv_PI3 = 1.0/((4.0*atan(1.0))**3) inv_PI2 = 1.0/((4.0*atan(1.0))**2) inv_PI6 = inv_PI3 * inv_PI3 + if (CS%EY24_EBT_BS) then + visc_limit_h(:,:,:) = 0. + visc_limit_q(:,:,:) = 0. + visc_limit_h_flag(:,:,:) = 0. + visc_limit_q_flag(:,:,:) = 0. + visc_limit_h_frac(:,:,:) = 0. + visc_limit_q_frac(:,:,:) = 0. + endif + + skeb_use_frict = .false. + if (present(STOCH)) skeb_use_frict = STOCH%skeb_use_frict + + m_leithy(:,:) = 0.0 ! Initialize + if (present(OBC)) then ; if (associated(OBC)) then ; if (OBC%OBC_pe) then apply_OBC = OBC%Flather_u_BCs_exist_globally .or. OBC%Flather_v_BCs_exist_globally apply_OBC = .true. endif ; endif ; endif + apply_OBC_strain = .false. + if (present(OBC)) then ; if (associated(OBC)) then + apply_OBC_strain = (OBC%strain_config /= OBC_STRAIN_NONE) & + .and. ((.not. CS%OBC_strain_bug) .or. (OBC%strain_config /= OBC_STRAIN_SPECIFIED)) + endif ; endif + if (.not.CS%initialized) call MOM_error(FATAL, & "MOM_hor_visc: Module must be initialized before it is used.") @@ -427,6 +521,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%id_FrictWorkIntz > 0) find_FrictWork = .true. if (allocated(MEKE%mom_src)) find_FrictWork = .true. + use_kh_struct = allocated(VarMix%BS_struct) backscat_subround = 0.0 if (find_FrictWork .and. allocated(MEKE%mom_src) .and. (MEKE%backscatter_Ro_c > 0.0) .and. & (MEKE%backscatter_Ro_Pow /= 0.0)) & @@ -436,31 +531,42 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, use_MEKE_Ku = allocated(MEKE%Ku) use_MEKE_Au = allocated(MEKE%Au) + use_cont_huv = CS%use_cont_thick .and. present(hu_cont) .and. present(hv_cont) + if (use_cont_huv .and. .not.CS%use_cont_thick_bug) then + call pass_vector(hu_cont, hv_cont, G%domain, To_All+Scalar_Pair, halo=2) + endif + rescale_Kh = .false. if (VarMix%use_variable_mixing) then rescale_Kh = VarMix%Resoln_scaled_Kh if ((rescale_Kh .or. CS%res_scale_MEKE) & .and. (.not. allocated(VarMix%Res_fn_h) .or. .not. allocated(VarMix%Res_fn_q))) & call MOM_error(FATAL, "MOM_hor_visc: VarMix%Res_fn_h and VarMix%Res_fn_q "//& - "both need to be associated with Resoln_scaled_Kh or RES_SCALE_MEKE_VISC.") + "both need to be associated with Resoln_scaled_Kh or RES_SCALE_MEKE_VISC.") elseif (CS%res_scale_MEKE) then call MOM_error(FATAL, "MOM_hor_visc: VarMix needs to be associated if "//& "RES_SCALE_MEKE_VISC is True.") endif - legacy_bound = (CS%Smagorinsky_Kh .or. CS%Leith_Kh) .and. & - (CS%bound_Kh .and. .not.CS%better_bound_Kh) + ! Set the halo sizes used for the thickness-point viscosities. + if (CS%use_Leithy .or. CS%debug) then + js_Kh = js-1 ; je_Kh = je+1 ; is_Kh = is-1 ; ie_Kh = ie+1 + else + js_Kh = Jsq ; je_Kh = je+1 ; is_Kh = Isq ; ie_Kh = ie+1 + endif - if (CS%use_GME) then - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - boundary_mask_h(i,j) = (G%mask2dCu(I,j) * G%mask2dCv(i,J) * G%mask2dCu(I-1,j) * G%mask2dCv(i,J-1)) - enddo ; enddo + ! Set the halo sizes used for the vorticity calculations. + if ((CS%Leith_Kh) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) then + js_vort = js_Kh-2 ; je_vort = Jeq+2 ; is_vort = is_Kh-2 ; ie_vort = Ieq+2 + if ((G%isc-G%isd < 3) .or. (G%isc-G%isd < 3)) call MOM_error(FATAL, & + "The minimum halo size is 3 when a Leith viscosity is being used.") + else + js_vort = js-2 ; je_vort = Jeq+1 ; is_vort = is-2 ; ie_vort = Ieq+1 + endif - do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 - boundary_mask_q(I,J) = (G%mask2dCv(i,J) * G%mask2dCv(i+1,J) * G%mask2dCu(I,j) * G%mask2dCu(I,j-1)) - enddo ; enddo + if (CS%use_GME) then - ! initialize diag. array with zeros + ! Initialize diagnostic arrays with zeros GME_coeff_h(:,:,:) = 0.0 GME_coeff_q(:,:,:) = 0.0 str_xx_GME(:,:) = 0.0 @@ -468,110 +574,143 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Get barotropic velocities and their gradients call barotropic_get_tav(BT, ubtav, vbtav, G, US) - call pass_vector(ubtav, vbtav, G%Domain) - do j=js-1,je+2 ; do i=is-1,ie+2 - dudx_bt(i,j) = CS%DY_dxT(i,j)*(G%IdyCu(I,j) * ubtav(I,j) - & - G%IdyCu(I-1,j) * ubtav(I-1,j)) - dvdy_bt(i,j) = CS%DX_dyT(i,j)*(G%IdxCv(i,J) * vbtav(i,J) - & - G%IdxCv(i,J-1) * vbtav(i,J-1)) + call pass_vector(ubtav, vbtav, G%Domain) + call pass_var(h, G%domain, halo=2) + + ! Calculate the barotropic horizontal tension + do j=js-2,je+2 ; do i=is-2,ie+2 + dudx_bt(i,j) = CS%DY_dxT(i,j)*((G%IdyCu(I,j) * ubtav(I,j)) - & + (G%IdyCu(I-1,j) * ubtav(I-1,j))) + dvdy_bt(i,j) = CS%DX_dyT(i,j)*((G%IdxCv(i,J) * vbtav(i,J)) - & + (G%IdxCv(i,J-1) * vbtav(i,J-1))) enddo ; enddo - - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 sh_xx_bt(i,j) = dudx_bt(i,j) - dvdy_bt(i,j) enddo ; enddo ! Components for the barotropic shearing strain - do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 - dvdx_bt(I,J) = CS%DY_dxBu(I,J)*(vbtav(i+1,J)*G%IdyCv(i+1,J) & - - vbtav(i,J)*G%IdyCv(i,J)) - dudy_bt(I,J) = CS%DX_dyBu(I,J)*(ubtav(I,j+1)*G%IdxCu(I,j+1) & - - ubtav(I,j)*G%IdxCu(I,j)) + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + dvdx_bt(I,J) = CS%DY_dxBu(I,J)*((vbtav(i+1,J)*G%IdyCv(i+1,J)) & + - (vbtav(i,J)*G%IdyCv(i,J))) + dudy_bt(I,J) = CS%DX_dyBu(I,J)*((ubtav(I,j+1)*G%IdxCu(I,j+1)) & + - (ubtav(I,j)*G%IdxCu(I,j))) enddo ; enddo - call pass_vector(dudx_bt, dvdy_bt, G%Domain, stagger=BGRID_NE) - call pass_vector(dvdx_bt, dudy_bt, G%Domain, stagger=AGRID) - if (CS%no_slip) then - do J=js-1,Jeq ; do I=is-1,Ieq + do J=js-2,je+1 ; do I=is-2,ie+1 sh_xy_bt(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx_bt(I,J) + dudy_bt(I,J) ) enddo ; enddo else - do J=js-1,Jeq ; do I=is-1,Ieq + do J=js-2,je+1 ; do I=is-2,ie+1 sh_xy_bt(I,J) = G%mask2dBu(I,J) * ( dvdx_bt(I,J) + dudy_bt(I,J) ) enddo ; enddo endif - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - grad_vel_mag_bt_h(i,j) = boundary_mask_h(i,j) * (dudx_bt(i,j)**2 + dvdy_bt(i,j)**2 + & - (0.25*((dvdx_bt(I,J)+dvdx_bt(I-1,J-1))+(dvdx_bt(I,J-1)+dvdx_bt(I-1,J))))**2 + & - (0.25*((dudy_bt(I,J)+dudy_bt(I-1,J-1))+(dudy_bt(I,J-1)+dudy_bt(I-1,J))))**2) - enddo ; enddo - - do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 - grad_vel_mag_bt_q(I,J) = boundary_mask_q(I,J) * (dvdx_bt(I,J)**2 + dudy_bt(I,J)**2 + & - (0.25*((dudx_bt(i,j)+dudx_bt(i+1,j+1))+(dudx_bt(i,j+1)+dudx_bt(i+1,j))))**2 + & - (0.25*((dvdy_bt(i,j)+dvdy_bt(i+1,j+1))+(dvdy_bt(i,j+1)+dvdy_bt(i+1,j))))**2) - enddo ; enddo - - do j=js-1,je+1 ; do i=is-1,ie+1 + do j=js-2,je+2 ; do i=is-2,ie+2 htot(i,j) = 0.0 enddo ; enddo - do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 - htot(i,j) = htot(i,j) + GV%H_to_Z*h(i,j,k) + do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + htot(i,j) = htot(i,j) + h(i,j,k) enddo ; enddo ; enddo I_GME_h0 = 1.0 / CS%GME_h0 - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - if (grad_vel_mag_bt_h(i,j)>0) then - GME_effic_h(i,j) = CS%GME_efficiency * boundary_mask_h(i,j) * & - (MIN(htot(i,j) * I_GME_h0, 1.0)**2) + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + boundary_mask_h = (G%mask2dCu(I,j) * G%mask2dCu(I-1,j)) * (G%mask2dCv(i,J) * G%mask2dCv(i,J-1)) + grad_vel_mag_bt_h = G%mask2dT(I,J) * boundary_mask_h * (dudx_bt(i,j)**2 + dvdy_bt(i,j)**2 + & + (0.25*((dvdx_bt(I,J)+dvdx_bt(I-1,J-1)) + (dvdx_bt(I,J-1)+dvdx_bt(I-1,J))))**2 + & + (0.25*((dudy_bt(I,J)+dudy_bt(I-1,J-1)) + (dudy_bt(I,J-1)+dudy_bt(I-1,J))))**2) + ! Probably the following test could be simplified to + ! if (boundary_mask_h * G%mask2dT(I,J) > 0.0) then + if (grad_vel_mag_bt_h > 0.0) then + GME_effic_h(i,j) = CS%GME_efficiency * G%mask2dT(I,J) * (MIN(htot(i,j) * I_GME_h0, 1.0)**2) else GME_effic_h(i,j) = 0.0 endif enddo ; enddo - do J=js-1,Jeq ; do I=is-1,Ieq - if (grad_vel_mag_bt_q(I,J)>0) then + do J=js-2,je+1 ; do I=is-2,ie+1 + boundary_mask_q = (G%mask2dCv(i,J) * G%mask2dCv(i+1,J)) * (G%mask2dCu(I,j) * G%mask2dCu(I,j+1)) + grad_vel_mag_bt_q = G%mask2dBu(I,J) * boundary_mask_q * (dvdx_bt(I,J)**2 + dudy_bt(I,J)**2 + & + (0.25*((dudx_bt(i,j)+dudx_bt(i+1,j+1)) + (dudx_bt(i,j+1)+dudx_bt(i+1,j))))**2 + & + (0.25*((dvdy_bt(i,j)+dvdy_bt(i+1,j+1)) + (dvdy_bt(i,j+1)+dvdy_bt(i+1,j))))**2) + ! Probably the following test could be simplified to + ! if (boundary_mask_q * G%mask2dBu(I,J) > 0.0) then + if (grad_vel_mag_bt_q > 0.0) then h_arith_q = 0.25 * ((htot(i,j) + htot(i+1,j+1)) + (htot(i+1,j) + htot(i,j+1))) - I_hq = 1.0 / h_arith_q - h_harm_q = 0.25 * h_arith_q * ((htot(i,j)*I_hq + htot(i+1,j+1)*I_hq) + & - (htot(i+1,j)*I_hq + htot(i,j+1)*I_hq)) - GME_effic_q(I,J) = CS%GME_efficiency * boundary_mask_q(I,J) * (MIN(h_harm_q * I_GME_h0, 1.0)**2) + GME_effic_q(I,J) = CS%GME_efficiency * G%mask2dBu(I,J) * (MIN(h_arith_q * I_GME_h0, 1.0)**2) else GME_effic_q(I,J) = 0.0 endif enddo ; enddo + call thickness_diffuse_get_KH(TD, KH_u_GME, KH_v_GME, G, GV) + + call pass_vector(KH_u_GME, KH_v_GME, G%domain, To_All+Scalar_Pair) + + if (CS%debug) & + call uvchksum("GME KH[u,v]_GME", KH_u_GME, KH_v_GME, G%HI, haloshift=2, unscale=US%L_to_m**2*US%s_to_T) + endif ! use_GME - !$OMP parallel do default(none) & + if (CS%use_Leithy) then + ! Smooth the velocity. Right now it happens twice. In the future + ! one might make the number of smoothing cycles a user-specified parameter + do k=1,nz + ! One call applies the filter twice + u_smooth(:,:,k) = u(:,:,k) + v_smooth(:,:,k) = v(:,:,k) + call smooth_x9_uv(G, u_smooth(:,:,k), v_smooth(:,:,k), zero_land=.false.) + enddo + call pass_vector(u_smooth, v_smooth, G%Domain) + endif + + if (CS%use_QG_Leith_visc .and. ((CS%Leith_Kh) .or. (CS%Leith_Ah))) then + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=2) + ! Calculate isopycnal slopes that will be used for some forms of viscosity. + call calc_QG_slopes(h, tv, dt, G, GV, US, slope_x, slope_y, VarMix, OBC) + ! If the following halo update is added, the calculations in calc_QG_slopes could work on just + ! the computational domains, and some halo updates outside of this routine could be smaller. + ! call pass_vector(slope_x, slope_y, G%Domain, halo=2) + endif + + !$OMP parallel do default(none) if (.not. CS%smooth_AH) & !$OMP shared( & - !$OMP CS, G, GV, US, OBC, VarMix, MEKE, u, v, h, & + !$OMP CS, G, GV, US, OBC, VarMix, MEKE, u, v, h, uh, vh, & !$OMP is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, & - !$OMP apply_OBC, rescale_Kh, legacy_bound, find_FrictWork, & - !$OMP use_MEKE_Ku, use_MEKE_Au, boundary_mask_h, boundary_mask_q, & - !$OMP backscat_subround, GME_coeff_limiter, GME_effic_h, GME_effic_q, & - !$OMP h_neglect, h_neglect3, FWfrac, inv_PI3, inv_PI6, H0_GME, & - !$OMP diffu, diffv, Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & + !$OMP is_vort, ie_vort, js_vort, je_vort, & + !$OMP is_Kh, ie_Kh, js_Kh, je_Kh, & + !$OMP apply_OBC, apply_OBC_strain, rescale_Kh, find_FrictWork, use_kh_struct, skeb_use_frict, & + !$OMP use_MEKE_Ku, use_MEKE_Au, u_smooth, v_smooth, use_cont_huv, slope_x, slope_y, dz, & + !$OMP backscat_subround, GME_effic_h, GME_effic_q, & + !$OMP h_neglect, h_neglect3, inv_PI3, inv_PI6, & + !$OMP diffu, diffv, Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_bh, FrictWork_GME, & !$OMP div_xx_h, sh_xx_h, vort_xy_q, sh_xy_q, GME_coeff_h, GME_coeff_q, & - !$OMP TD, KH_u_GME, KH_v_GME, grid_Re_Kh, grid_Re_Ah, NoSt, ShSt & + !$OMP KH_u_GME, KH_v_GME, grid_Re_Kh, grid_Re_Ah, NoSt, ShSt, hu_cont, hv_cont, STOCH & !$OMP ) & !$OMP private( & - !$OMP i, j, k, n, & + !$OMP i, j, k, n, tmp, & !$OMP dudx, dudy, dvdx, dvdy, sh_xx, sh_xy, h_u, h_v, & !$OMP Del2u, Del2v, DY_dxBu, DX_dyBu, sh_xx_bt, sh_xy_bt, & !$OMP str_xx, str_xy, bhstr_xx, bhstr_xy, str_xx_GME, str_xy_GME, & !$OMP vort_xy, vort_xy_dx, vort_xy_dy, div_xx, div_xx_dx, div_xx_dy, & !$OMP grad_div_mag_h, grad_div_mag_q, grad_vort_mag_h, grad_vort_mag_q, & !$OMP grad_vort, grad_vort_qg, grad_vort_mag_h_2d, grad_vort_mag_q_2d, & - !$OMP grad_vel_mag_h, grad_vel_mag_q, & - !$OMP grad_vel_mag_bt_h, grad_vel_mag_bt_q, grad_d2vel_mag_h, & - !$OMP meke_res_fn, Shear_mag, Shear_mag_bc, vert_vort_mag, h_min, hrat_min, visc_bound_rem, & - !$OMP sh_xx_sq, sh_xy_sq, grid_Ah, grid_Kh, d_Del2u, d_Del2v, d_str, & + !$OMP sh_xx_sq, sh_xy_sq, meke_res_fn, Shear_mag, Shear_mag_bc, vert_vort_mag, & + !$OMP h_min, hrat_min, visc_bound_rem, Kh_max_here, & + !$OMP grid_Ah, grid_Kh, d_Del2u, d_Del2v, d_str, & !$OMP Kh, Ah, AhSm, AhLth, local_strain, Sh_F_pow, & - !$OMP dDel2vdx, dDel2udy, DY_dxCv, DX_dyCu, Del2vort_q, Del2vort_h, KE, & - !$OMP h2uq, h2vq, hu, hv, hq, FatH, RoScl, GME_coeff & + !$OMP dDel2vdx, dDel2udy, Del2vort_q, Del2vort_h, KE, & + !$OMP h2uq, h2vq, hu, hv, hq, FatH, RoScl, GME_coeff, & + !$OMP dudx_smooth, dudy_smooth, dvdx_smooth, dvdy_smooth, & + !$OMP vort_xy_smooth, vort_xy_dx_smooth, vort_xy_dy_smooth, & + !$OMP sh_xx_smooth, sh_xy_smooth, & + !$OMP vert_vort_mag_smooth, m_leithy, Ah_sq, AhLthy, & + !$OMP Kh_BS, str_xx_bs, str_xy_bs, bs_coeff_h, bs_coeff_q & + !$OMP ) & + !$OMP firstprivate( & + !$OMP visc_limit_h, visc_limit_h_frac, visc_limit_h_flag, & + !$OMP visc_limit_q, visc_limit_q_frac, visc_limit_q_flag & !$OMP ) do k=1,nz @@ -587,21 +726,40 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Calculate horizontal tension do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - dudx(i,j) = CS%DY_dxT(i,j)*(G%IdyCu(I,j) * u(I,j,k) - & - G%IdyCu(I-1,j) * u(I-1,j,k)) - dvdy(i,j) = CS%DX_dyT(i,j)*(G%IdxCv(i,J) * v(i,J,k) - & - G%IdxCv(i,J-1) * v(i,J-1,k)) + dudx(i,j) = CS%DY_dxT(i,j)*((G%IdyCu(I,j) * u(I,j,k)) - & + (G%IdyCu(I-1,j) * u(I-1,j,k))) + dvdy(i,j) = CS%DX_dyT(i,j)*((G%IdxCv(i,J) * v(i,J,k)) - & + (G%IdxCv(i,J-1) * v(i,J-1,k))) sh_xx(i,j) = dudx(i,j) - dvdy(i,j) enddo ; enddo ! Components for the shearing strain - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - dvdx(I,J) = CS%DY_dxBu(I,J)*(v(i+1,J,k)*G%IdyCv(i+1,J) - v(i,J,k)*G%IdyCv(i,J)) - dudy(I,J) = CS%DX_dyBu(I,J)*(u(I,j+1,k)*G%IdxCu(I,j+1) - u(I,j,k)*G%IdxCu(I,j)) + do J=js_vort,je_vort ; do I=is_vort,ie_vort + dvdx(I,J) = CS%DY_dxBu(I,J)*((v(i+1,J,k)*G%IdyCv(i+1,J)) - (v(i,J,k)*G%IdyCv(i,J))) + dudy(I,J) = CS%DX_dyBu(I,J)*((u(I,j+1,k)*G%IdxCu(I,j+1)) - (u(I,j,k)*G%IdxCu(I,j))) enddo ; enddo + if (CS%use_Leithy) then + ! Calculate horizontal tension from smoothed velocity + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dudx_smooth(i,j) = CS%DY_dxT(i,j)*((G%IdyCu(I,j) * u_smooth(I,j,k)) - & + (G%IdyCu(I-1,j) * u_smooth(I-1,j,k))) + dvdy_smooth(i,j) = CS%DX_dyT(i,j)*((G%IdxCv(i,J) * v_smooth(i,J,k)) - & + (G%IdxCv(i,J-1) * v_smooth(i,J-1,k))) + sh_xx_smooth(i,j) = dudx_smooth(i,j) - dvdy_smooth(i,j) + enddo ; enddo + + ! Components for the shearing strain from smoothed velocity + do J=js_Kh-1,je_Kh ; do I=is_Kh-1,ie_Kh + dvdx_smooth(I,J) = CS%DY_dxBu(I,J) * & + ((v_smooth(i+1,J,k)*G%IdyCv(i+1,J)) - (v_smooth(i,J,k)*G%IdyCv(i,J))) + dudy_smooth(I,J) = CS%DX_dyBu(I,J) * & + ((u_smooth(I,j+1,k)*G%IdxCu(I,j+1)) - (u_smooth(I,j,k)*G%IdxCu(I,j))) + enddo ; enddo + endif ! use Leith+E + if (CS%id_normstress > 0) then - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + do j=js,je ; do i=is,ie NoSt(i,j,k) = sh_xx(i,j) enddo ; enddo endif @@ -611,18 +769,25 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! in OBCs, which are not ordinarily be necessary, and might not be necessary ! even with OBCs if the accelerations are zeroed at OBC points, in which ! case the j-loop for h_u could collapse to j=js=1,je+1. -RWH - if (CS%use_land_mask) then + if (use_cont_huv) then do j=js-2,je+2 ; do I=Isq-1,Ieq+1 - h_u(I,j) = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i+1,j)*h(i+1,j,k)) + h_u(I,j) = hu_cont(I,j,k) enddo ; enddo do J=Jsq-1,Jeq+1 ; do i=is-2,ie+2 + h_v(i,J) = hv_cont(i,J,k) + enddo ; enddo + elseif (CS%use_land_mask) then + do j=js-2,je+2 ; do I=is-2,Ieq+1 + h_u(I,j) = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i+1,j)*h(i+1,j,k)) + enddo ; enddo + do J=js-2,Jeq+1 ; do i=is-2,ie+2 h_v(i,J) = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i,j+1)*h(i,j+1,k)) enddo ; enddo else - do j=js-2,je+2 ; do I=Isq-1,Ieq+1 + do j=js-2,je+2 ; do I=is-2,Ieq+1 h_u(I,j) = 0.5 * (h(i,j,k) + h(i+1,j,k)) enddo ; enddo - do J=Jsq-1,Jeq+1 ; do i=is-2,ie+2 + do J=js-2,Jeq+1 ; do i=is-2,ie+2 h_v(i,J) = 0.5 * (h(i,j,k) + h(i,j+1,k)) enddo ; enddo endif @@ -631,49 +796,59 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! thicknesses on open boundaries. if (apply_OBC) then ; do n=1,OBC%number_of_segments J = OBC%segment(n)%HI%JsdB ; I = OBC%segment(n)%HI%IsdB - if (OBC%zero_strain .or. OBC%freeslip_strain .or. OBC%computed_strain) then - if (OBC%segment(n)%is_N_or_S .and. (J >= js-2) .and. (J <= Jeq+1)) then - do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB - if (OBC%zero_strain) then - dvdx(I,J) = 0. ; dudy(I,J) = 0. - elseif (OBC%freeslip_strain) then - dudy(I,J) = 0. - elseif (OBC%computed_strain) then - if (OBC%segment(n)%direction == OBC_DIRECTION_N) then - dudy(I,J) = 2.0*CS%DX_dyBu(I,J)* & - (OBC%segment(n)%tangential_vel(I,J,k) - u(I,j,k))*G%IdxCu(I,j) - else - dudy(I,J) = 2.0*CS%DX_dyBu(I,J)* & - (u(I,j+1,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%IdxCu(I,j+1) - endif - elseif (OBC%specified_strain) then - if (OBC%segment(n)%direction == OBC_DIRECTION_N) then - dudy(I,J) = CS%DX_dyBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdxCu(I,j)*G%dxBu(I,J) - else - dudy(I,J) = CS%DX_dyBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdxCu(I,j+1)*G%dxBu(I,J) - endif + if (apply_OBC_strain) then + if (OBC%segment(n)%is_N_or_S .and. (J >= Js_vort) .and. (J <= Je_vort)) then + do I = max(OBC%segment(n)%HI%IsdB,Is_vort), min(OBC%segment(n)%HI%IedB,Ie_vort) + select case (OBC%strain_config) + case (OBC_STRAIN_ZERO) + dvdx(I,J) = 0. ; dudy(I,J) = 0. + case (OBC_STRAIN_FREESLIP) + dudy(I,J) = 0. + case (OBC_STRAIN_COMPUTED) + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + dudy(I,J) = 2.0*CS%DX_dyBu(I,J)* & + (OBC%segment(n)%tangential_vel(I,J,k) - u(I,j,k))*G%IdxCu(I,j) + else + dudy(I,J) = 2.0*CS%DX_dyBu(I,J)* & + (u(I,j+1,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%IdxCu(I,j+1) + endif + case (OBC_STRAIN_SPECIFIED) + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + dudy(I,J) = CS%DX_dyBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdxCu(I,j)*G%dxBu(I,J) + else + dudy(I,J) = CS%DX_dyBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdxCu(I,j+1)*G%dxBu(I,J) + endif + end select + if (CS%use_Leithy) then + dvdx_smooth(I,J) = dvdx(I,J) + dudy_smooth(I,J) = dudy(I,J) endif enddo - elseif (OBC%segment(n)%is_E_or_W .and. (I >= is-2) .and. (I <= Ieq+1)) then - do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB - if (OBC%zero_strain) then - dvdx(I,J) = 0. ; dudy(I,J) = 0. - elseif (OBC%freeslip_strain) then - dvdx(I,J) = 0. - elseif (OBC%computed_strain) then - if (OBC%segment(n)%direction == OBC_DIRECTION_E) then - dvdx(I,J) = 2.0*CS%DY_dxBu(I,J)* & - (OBC%segment(n)%tangential_vel(I,J,k) - v(i,J,k))*G%IdyCv(i,J) - else - dvdx(I,J) = 2.0*CS%DY_dxBu(I,J)* & - (v(i+1,J,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%IdyCv(i+1,J) - endif - elseif (OBC%specified_strain) then - if (OBC%segment(n)%direction == OBC_DIRECTION_E) then - dvdx(I,J) = CS%DY_dxBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdyCv(i,J)*G%dxBu(I,J) - else - dvdx(I,J) = CS%DY_dxBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdyCv(i+1,J)*G%dxBu(I,J) - endif + elseif (OBC%segment(n)%is_E_or_W .and. (I >= is_vort) .and. (I <= ie_vort)) then + do J = max(OBC%segment(n)%HI%JsdB,js_vort), min(OBC%segment(n)%HI%JedB,je_vort) + select case (OBC%strain_config) + case (OBC_STRAIN_ZERO) + dvdx(I,J) = 0. ; dudy(I,J) = 0. + case (OBC_STRAIN_FREESLIP) + dvdx(I,J) = 0. + case (OBC_STRAIN_COMPUTED) + if (OBC%segment(n)%direction == OBC_DIRECTION_E) then + dvdx(I,J) = 2.0*CS%DY_dxBu(I,J)* & + (OBC%segment(n)%tangential_vel(I,J,k) - v(i,J,k))*G%IdyCv(i,J) + else + dvdx(I,J) = 2.0*CS%DY_dxBu(I,J)* & + (v(i+1,J,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%IdyCv(i+1,J) + endif + case (OBC_STRAIN_SPECIFIED) + if (OBC%segment(n)%direction == OBC_DIRECTION_E) then + dvdx(I,J) = CS%DY_dxBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdyCv(i,J)*G%dxBu(I,J) + else + dvdx(I,J) = CS%DY_dxBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdyCv(i+1,J)*G%dxBu(I,J) + endif + end select + if (CS%use_Leithy) then + dvdx_smooth(I,J) = dvdx(I,J) + dudy_smooth(I,J) = dudy(I,J) endif enddo endif @@ -684,25 +859,25 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! OBC projections, but they might not be necessary if the accelerations ! are always zeroed out at OBC points, in which case the i-loop below ! becomes do i=is-1,ie+1. -RWH - if ((J >= Jsq-1) .and. (J <= Jeq+1)) then + if ((J >= js-2) .and. (J <= Jeq+1)) then do i = max(is-2,OBC%segment(n)%HI%isd), min(ie+2,OBC%segment(n)%HI%ied) h_v(i,J) = h(i,j,k) enddo endif elseif (OBC%segment(n)%direction == OBC_DIRECTION_S) then - if ((J >= Jsq-1) .and. (J <= Jeq+1)) then + if ((J >= js-2) .and. (J <= Jeq+1)) then do i = max(is-2,OBC%segment(n)%HI%isd), min(ie+2,OBC%segment(n)%HI%ied) h_v(i,J) = h(i,j+1,k) enddo endif elseif (OBC%segment(n)%direction == OBC_DIRECTION_E) then - if ((I >= Isq-1) .and. (I <= Ieq+1)) then + if ((I >= is-2) .and. (I <= Ieq+1)) then do j = max(js-2,OBC%segment(n)%HI%jsd), min(je+2,OBC%segment(n)%HI%jed) h_u(I,j) = h(i,j,k) enddo endif elseif (OBC%segment(n)%direction == OBC_DIRECTION_W) then - if ((I >= Isq-1) .and. (I <= Ieq+1)) then + if ((I >= is-2) .and. (I <= Ieq+1)) then do j = max(js-2,OBC%segment(n)%HI%jsd), min(je+2,OBC%segment(n)%HI%jed) h_u(I,j) = h(i+1,j,k) enddo @@ -714,25 +889,25 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, J = OBC%segment(n)%HI%JsdB ; I = OBC%segment(n)%HI%IsdB if (OBC%segment(n)%direction == OBC_DIRECTION_N) then if ((J >= js-2) .and. (J <= je)) then - do I = max(Isq-1,OBC%segment(n)%HI%IsdB), min(Ieq+1,OBC%segment(n)%HI%IedB) + do I = max(is-2,OBC%segment(n)%HI%IsdB), min(Ieq+1,OBC%segment(n)%HI%IedB) h_u(I,j+1) = h_u(I,j) enddo endif elseif (OBC%segment(n)%direction == OBC_DIRECTION_S) then if ((J >= js-1) .and. (J <= je+1)) then - do I = max(Isq-1,OBC%segment(n)%HI%isd), min(Ieq+1,OBC%segment(n)%HI%ied) + do I = max(is-2,OBC%segment(n)%HI%isd), min(Ieq+1,OBC%segment(n)%HI%ied) h_u(I,j) = h_u(I,j+1) enddo endif elseif (OBC%segment(n)%direction == OBC_DIRECTION_E) then if ((I >= is-2) .and. (I <= ie)) then - do J = max(Jsq-1,OBC%segment(n)%HI%jsd), min(Jeq+1,OBC%segment(n)%HI%jed) + do J = max(js-2,OBC%segment(n)%HI%jsd), min(Jeq+1,OBC%segment(n)%HI%jed) h_v(i+1,J) = h_v(i,J) enddo endif elseif (OBC%segment(n)%direction == OBC_DIRECTION_W) then if ((I >= is-1) .and. (I <= ie+1)) then - do J = max(Jsq-1,OBC%segment(n)%HI%jsd), min(Jeq+1,OBC%segment(n)%HI%jed) + do J = max(js-2,OBC%segment(n)%HI%jsd), min(Jeq+1,OBC%segment(n)%HI%jed) h_v(i,J) = h_v(i+1,J) enddo endif @@ -753,15 +928,29 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo endif + if (CS%use_Leithy) then + ! Shearing strain (including no-slip boundary conditions at the 2-D land-sea mask). + ! dudy_smooth and dvdx_smooth do not (yet) include modifications at OBCs from above. + if (CS%no_slip) then + do J=js-1,Jeq ; do I=is-1,Ieq + sh_xy_smooth(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx_smooth(I,J) + dudy_smooth(I,J) ) + enddo ; enddo + else + do J=js-1,Jeq ; do I=is-1,Ieq + sh_xy_smooth(I,J) = G%mask2dBu(I,J) * ( dvdx_smooth(I,J) + dudy_smooth(I,J) ) + enddo ; enddo + endif + endif ! use Leith+E + ! Evaluate Del2u = x.Div(Grad u) and Del2v = y.Div( Grad u) if (CS%biharmonic) then do j=js-1,Jeq+1 ; do I=Isq-1,Ieq+1 - Del2u(I,j) = CS%Idxdy2u(I,j)*(CS%dy2h(i+1,j)*sh_xx(i+1,j) - CS%dy2h(i,j)*sh_xx(i,j)) + & - CS%Idx2dyCu(I,j)*(CS%dx2q(I,J)*sh_xy(I,J) - CS%dx2q(I,J-1)*sh_xy(I,J-1)) + Del2u(I,j) = CS%Idx2dyCu(I,j) * ((CS%dx2q(I,J)*sh_xy(I,J)) - (CS%dx2q(I,J-1)*sh_xy(I,J-1))) + & + CS%Idxdy2u(I,j) * ((CS%dy2h(i+1,j)*sh_xx(i+1,j)) - (CS%dy2h(i,j)*sh_xx(i,j))) enddo ; enddo do J=Jsq-1,Jeq+1 ; do i=is-1,Ieq+1 - Del2v(i,J) = CS%Idxdy2v(i,J)*(CS%dy2q(I,J)*sh_xy(I,J) - CS%dy2q(I-1,J)*sh_xy(I-1,J)) - & - CS%Idx2dyCv(i,J)*(CS%dx2h(i,j+1)*sh_xx(i,j+1) - CS%dx2h(i,j)*sh_xx(i,j)) + Del2v(i,J) = CS%Idxdy2v(i,J) * ((CS%dy2q(I,J)*sh_xy(I,J)) - (CS%dy2q(I-1,J)*sh_xy(I-1,J))) - & + CS%Idx2dyCv(i,J) * ((CS%dx2h(i,j+1)*sh_xx(i,j+1)) - (CS%dx2h(i,j)*sh_xx(i,j))) enddo ; enddo if (apply_OBC) then ; if (OBC%zero_biharmonic) then do n=1,OBC%number_of_segments @@ -780,78 +969,116 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif ! Vorticity - if (CS%no_slip) then - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - vort_xy(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx(I,J) - dudy(I,J) ) - enddo ; enddo - else - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - vort_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) - dudy(I,J) ) - enddo ; enddo + if ((CS%Leith_Kh) .or. (CS%Leith_Ah) .or. (CS%use_Leithy) .or. (CS%id_vort_xy_q>0) .or. CS%use_ZB2020) then + if (CS%no_slip) then + do J=js_vort,je_vort ; do I=is_vort,ie_vort + vort_xy(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx(I,J) - dudy(I,J) ) + enddo ; enddo + else + if (CS%use_circulation) then + do J=js_vort,je_vort ; do I=is_vort,ie_vort + vort_xy(I,J) = G%mask2dBu(I,J) * G%IareaBu(I,J) * ( & + ((v(i+1,J,k)*G%dyCv(i+1,J)) - (v(i,J,k)*G%dyCv(i,J))) & + - ((u(I,j+1,k)*G%dxCu(I,j+1)) - (u(I,j,k)*G%dxCu(I,j))) & + ) + enddo ; enddo + else + do J=js_vort,je_vort ; do I=is_vort,ie_vort + vort_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) - dudy(I,J) ) + enddo ; enddo + endif + endif + endif + + if (CS%use_Leithy) then + if (CS%no_slip) then + do J=js_Kh-1,je_Kh ; do I=is_Kh-1,ie_Kh + vort_xy_smooth(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx_smooth(I,J) - dudy_smooth(I,J) ) + enddo ; enddo + else + do J=js_Kh-1,je_Kh ; do I=is_Kh-1,ie_Kh + vort_xy_smooth(I,J) = G%mask2dBu(I,J) * ( dvdx_smooth(I,J) - dudy_smooth(I,J) ) + enddo ; enddo + endif endif - ! Divergence - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - div_xx(i,j) = dudx(i,j) + dvdy(i,j) - enddo ; enddo - if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then + if ((CS%Leith_Kh) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) then ! Vorticity gradient - do J=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+2 + do J=js-2,je_Kh ; do i=is_Kh-1,ie_Kh+1 DY_dxBu = G%dyBu(I,J) * G%IdxBu(I,J) - vort_xy_dx(i,J) = DY_dxBu * (vort_xy(I,J) * G%IdyCu(I,j) - vort_xy(I-1,J) * G%IdyCu(I-1,j)) + vort_xy_dx(i,J) = DY_dxBu * ((vort_xy(I,J) * G%IdyCu(I,j)) - (vort_xy(I-1,J) * G%IdyCu(I-1,j))) enddo ; enddo - do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+1 + do j=js_Kh-1,je_Kh+1 ; do I=is-2,ie_Kh DX_dyBu = G%dxBu(I,J) * G%IdyBu(I,J) - vort_xy_dy(I,j) = DX_dyBu * (vort_xy(I,J) * G%IdxCv(i,J) - vort_xy(I,J-1) * G%IdxCv(i,J-1)) + vort_xy_dy(I,j) = DX_dyBu * ((vort_xy(I,J) * G%IdxCv(i,J)) - (vort_xy(I,J-1) * G%IdxCv(i,J-1))) enddo ; enddo + if (CS%use_Leithy) then + ! Gradient of smoothed vorticity + do J=js_Kh-1,je_Kh ; do i=is_Kh,ie_Kh + DY_dxBu = G%dyBu(I,J) * G%IdxBu(I,J) + vort_xy_dx_smooth(i,J) = DY_dxBu * & + ((vort_xy_smooth(I,J) * G%IdyCu(I,j)) - (vort_xy_smooth(I-1,J) * G%IdyCu(I-1,j))) + enddo ; enddo + + do j=js_Kh,je_Kh ; do I=is_Kh-1,ie_Kh + DX_dyBu = G%dxBu(I,J) * G%IdyBu(I,J) + vort_xy_dy_smooth(I,j) = DX_dyBu * & + ((vort_xy_smooth(I,J) * G%IdxCv(i,J)) - (vort_xy_smooth(I,J-1) * G%IdxCv(i,J-1))) + enddo ; enddo + endif ! If Leithy + ! Laplacian of vorticity - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + ! if (CS%Leith_Ah .or. CS%use_Leithy) then + do J=js_Kh-1,je_Kh ; do I=is_Kh-1,ie_Kh DY_dxBu = G%dyBu(I,J) * G%IdxBu(I,J) DX_dyBu = G%dxBu(I,J) * G%IdyBu(I,J) - Del2vort_q(I,J) = DY_dxBu * (vort_xy_dx(i+1,J) * G%IdyCv(i+1,J) - vort_xy_dx(i,J) * G%IdyCv(i,J)) + & - DX_dyBu * (vort_xy_dy(I,j+1) * G%IdyCu(I,j+1) - vort_xy_dy(I,j) * G%IdyCu(I,j)) - enddo ; enddo - do J=Jsq,Jeq+1 ; do I=Isq,Ieq+1 - Del2vort_h(i,j) = 0.25*(Del2vort_q(I,J) + Del2vort_q(I-1,J) + Del2vort_q(I,J-1) + Del2vort_q(I-1,J-1)) + Del2vort_q(I,J) = DY_dxBu * ((vort_xy_dx(i+1,J) * G%IdyCv(i+1,J)) - (vort_xy_dx(i,J) * G%IdyCv(i,J))) + & + DX_dyBu * ((vort_xy_dy(I,j+1) * G%IdyCu(I,j+1)) - (vort_xy_dy(I,j) * G%IdyCu(I,j))) enddo ; enddo + ! endif if (CS%modified_Leith) then + ! Divergence + do j=js_Kh-1,je_Kh+1 ; do i=is_Kh-1,ie_Kh+1 + div_xx(i,j) = dudx(i,j) + dvdy(i,j) + enddo ; enddo + ! Divergence gradient - do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+1 + do j=js-1,je+1 ; do I=is_Kh-1,ie_Kh div_xx_dx(I,j) = G%IdxCu(I,j)*(div_xx(i+1,j) - div_xx(i,j)) enddo ; enddo - do J=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+2 + do J=js_Kh-1,je_Kh ; do i=is-1,ie+1 div_xx_dy(i,J) = G%IdyCv(i,J)*(div_xx(i,j+1) - div_xx(i,j)) enddo ; enddo ! Magnitude of divergence gradient - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - grad_div_mag_h(i,j) = sqrt((0.5*(div_xx_dx(I,j) + div_xx_dx(I-1,j)))**2 + & - (0.5*(div_xx_dy(i,J) + div_xx_dy(i,J-1)))**2) + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + grad_div_mag_h(i,j) = sqrt(((0.5*(div_xx_dx(I,j) + div_xx_dx(I-1,j)))**2) + & + ((0.5*(div_xx_dy(i,J) + div_xx_dy(i,J-1)))**2)) enddo ; enddo - do j=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+1 - grad_div_mag_q(I,J) = sqrt((0.5*(div_xx_dx(I,j) + div_xx_dx(I,j+1)))**2 + & - (0.5*(div_xx_dy(i,J) + div_xx_dy(i+1,J)))**2) + do J=js-1,Jeq ; do I=is-1,Ieq + grad_div_mag_q(I,J) = sqrt(((0.5*(div_xx_dx(I,j) + div_xx_dx(I,j+1)))**2) + & + ((0.5*(div_xx_dy(i,J) + div_xx_dy(i+1,J)))**2)) enddo ; enddo else - do j=Jsq-1,Jeq+2 ; do I=is-2,Ieq+1 + do j=js-1,je+1 ; do I=is_Kh-1,ie_Kh div_xx_dx(I,j) = 0.0 enddo ; enddo - do J=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+2 + do J=js_Kh-1,je_Kh ; do i=is-1,ie+1 div_xx_dy(i,J) = 0.0 enddo ; enddo - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh grad_div_mag_h(i,j) = 0.0 enddo ; enddo - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + do J=js-1,Jeq ; do I=is-1,Ieq grad_div_mag_q(I,J) = 0.0 enddo ; enddo @@ -859,90 +1086,94 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Add in beta for the Leith viscosity if (CS%use_beta_in_Leith) then - do J=js-2,Jeq+1 ; do i=is-1,Ieq+1 + do J=js-2,Jeq+1 ; do i=is-1,ie+1 vort_xy_dx(i,J) = vort_xy_dx(i,J) + 0.5 * ( G%dF_dx(i,j) + G%dF_dx(i,j+1)) enddo ; enddo - do j=js-1,Jeq+1 ; do I=is-2,Ieq+1 + do j=js-1,je+1 ; do I=is-2,Ieq+1 vort_xy_dy(I,j) = vort_xy_dy(I,j) + 0.5 * ( G%dF_dy(i,j) + G%dF_dy(i+1,j)) enddo ; enddo endif ! CS%use_beta_in_Leith if (CS%use_QG_Leith_visc) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - grad_vort_mag_h_2d(i,j) = SQRT((0.5*(vort_xy_dx(i,J) + vort_xy_dx(i,J-1)))**2 + & - (0.5*(vort_xy_dy(I,j) + vort_xy_dy(I-1,j)))**2 ) + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + grad_vort_mag_h_2d(i,j) = SQRT(((0.5*(vort_xy_dx(i,J) + vort_xy_dx(i,J-1)))**2) + & + ((0.5*(vort_xy_dy(I,j) + vort_xy_dy(I-1,j)))**2) ) enddo ; enddo do J=js-1,Jeq ; do I=is-1,Ieq - grad_vort_mag_q_2d(I,J) = SQRT((0.5*(vort_xy_dx(i,J) + vort_xy_dx(i+1,J)))**2 + & - (0.5*(vort_xy_dy(I,j) + vort_xy_dy(I,j+1)))**2 ) + grad_vort_mag_q_2d(I,J) = SQRT(((0.5*(vort_xy_dx(i,J) + vort_xy_dx(i+1,J)))**2) + & + ((0.5*(vort_xy_dy(I,j) + vort_xy_dy(I,j+1)))**2) ) enddo ; enddo - ! This accumulates terms, some of which are in VarMix, so rescaling can not be done here. - call calc_QG_Leith_viscosity(VarMix, G, GV, US, h, k, div_xx_dx, div_xx_dy, & - vort_xy_dx, vort_xy_dy) + ! This accumulates terms, some of which are in VarMix. + call calc_QG_Leith_viscosity(VarMix, G, GV, US, h, dz, k, div_xx_dx, div_xx_dy, & + slope_x, slope_y, vort_xy_dx, vort_xy_dy) endif - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - grad_vort_mag_h(i,j) = SQRT((0.5*(vort_xy_dx(i,J) + vort_xy_dx(i,J-1)))**2 + & - (0.5*(vort_xy_dy(I,j) + vort_xy_dy(I-1,j)))**2 ) + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + grad_vort_mag_h(i,j) = SQRT(((0.5*(vort_xy_dx(i,J) + vort_xy_dx(i,J-1)))**2) + & + ((0.5*(vort_xy_dy(I,j) + vort_xy_dy(I-1,j)))**2) ) enddo ; enddo do J=js-1,Jeq ; do I=is-1,Ieq - grad_vort_mag_q(I,J) = SQRT((0.5*(vort_xy_dx(i,J) + vort_xy_dx(i+1,J)))**2 + & - (0.5*(vort_xy_dy(I,j) + vort_xy_dy(I,j+1)))**2 ) + grad_vort_mag_q(I,J) = SQRT(((0.5*(vort_xy_dx(i,J) + vort_xy_dx(i+1,J)))**2) + & + ((0.5*(vort_xy_dy(I,j) + vort_xy_dy(I,j+1)))**2) ) enddo ; enddo + if (CS%use_Leithy) then + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + vert_vort_mag_smooth(i,j) = SQRT(((0.5*(vort_xy_dx_smooth(i,J) + & + vort_xy_dx_smooth(i,J-1)))**2) + & + ((0.5*(vort_xy_dy_smooth(I,j) + & + vort_xy_dy_smooth(I-1,j)))**2) ) + enddo ; enddo + endif ! Leithy + endif ! CS%Leith_Kh if ((CS%Smagorinsky_Kh) .or. (CS%Smagorinsky_Ah)) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh sh_xx_sq = sh_xx(i,j)**2 - sh_xy_sq = 0.25 * ( (sh_xy(I-1,J-1)**2 + sh_xy(I,J)**2) & - + (sh_xy(I-1,J)**2 + sh_xy(I,J-1)**2) ) + sh_xy_sq = 0.25 * ( ((sh_xy(I-1,J-1)**2) + (sh_xy(I,J)**2)) & + + ((sh_xy(I-1,J)**2) + (sh_xy(I,J-1)**2)) ) Shear_mag(i,j) = sqrt(sh_xx_sq + sh_xy_sq) enddo ; enddo endif - if (CS%better_bound_Ah .or. CS%better_bound_Kh) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + if (CS%bound_Ah .or. CS%bound_Kh) then + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh h_min = min(h_u(I,j), h_u(I-1,j), h_v(i,J), h_v(i,J-1)) hrat_min(i,j) = min(1.0, h_min / (h(i,j,k) + h_neglect)) enddo ; enddo - - if (CS%better_bound_Kh) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - visc_bound_rem(i,j) = 1.0 - enddo ; enddo - endif endif if (CS%Laplacian) then - if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then + ! Determine the Laplacian viscosity at h points, using the + ! largest value from several parameterizations. Also get + ! the Laplacian component of str_xx. + + if ((CS%Leith_Kh) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) then if (CS%use_QG_Leith_visc) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh grad_vort = grad_vort_mag_h(i,j) + grad_div_mag_h(i,j) grad_vort_qg = 3. * grad_vort_mag_h_2d(i,j) vert_vort_mag(i,j) = min(grad_vort, grad_vort_qg) enddo ; enddo else - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh vert_vort_mag(i,j) = grad_vort_mag_h(i,j) + grad_div_mag_h(i,j) enddo ; enddo endif endif - ! Determine the Laplacian viscosity at h points, using the - ! largest value from several parameterizations. - ! Static (pre-computed) background viscosity - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Kh(i,j) = CS%Kh_bg_xx(i,j) enddo ; enddo ! NOTE: The following do-block can be decomposed and vectorized after the ! stack size has been reduced. - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh if (CS%add_LES_viscosity) then if (CS%Smagorinsky_Kh) & Kh(i,j) = Kh(i,j) + CS%Laplac2_const_xx(i,j) * Shear_mag(i,j) @@ -959,77 +1190,96 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! All viscosity contributions above are subject to resolution scaling if (rescale_Kh) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Kh(i,j) = VarMix%Res_fn_h(i,j) * Kh(i,j) enddo ; enddo endif - if (legacy_bound) then - ! Older method of bounding for stability - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - Kh(i,j) = min(Kh(i,j), CS%Kh_Max_xx(i,j)) - enddo ; enddo - endif - ! Place a floor on the viscosity, if desired. - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Kh(i,j) = max(Kh(i,j), CS%Kh_bg_min) enddo ; enddo - if (use_MEKE_Ku) then + if (use_MEKE_Ku .and. .not. CS%EY24_EBT_BS) then ! *Add* the MEKE contribution (which might be negative) - if (CS%res_scale_MEKE) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) * VarMix%Res_fn_h(i,j) - enddo ; enddo + if (use_kh_struct) then + if (CS%res_scale_MEKE) then + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) * VarMix%Res_fn_h(i,j) * VarMix%BS_struct(i,j,k) + enddo ; enddo + else + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) * VarMix%BS_struct(i,j,k) + enddo ; enddo + endif else - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) - enddo ; enddo + if (CS%res_scale_MEKE) then + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) * VarMix%Res_fn_h(i,j) + enddo ; enddo + else + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) + enddo ; enddo + endif endif endif if (CS%anisotropic) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh ! *Add* the tension component of anisotropic viscosity Kh(i,j) = Kh(i,j) + CS%Kh_aniso * (1. - CS%n1n2_h(i,j)**2) enddo ; enddo endif ! Newer method of bounding for stability - if (CS%better_bound_Kh) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - if (Kh(i,j) >= hrat_min(i,j) * CS%Kh_Max_xx(i,j)) then + if ((CS%bound_Kh) .and. (CS%bound_Ah)) then + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + visc_bound_rem(i,j) = 1.0 + Kh_max_here = hrat_min(i,j) * CS%Kh_Max_xx(i,j) + if (Kh(i,j) >= Kh_max_here) then visc_bound_rem(i,j) = 0.0 - Kh(i,j) = hrat_min(i,j) * CS%Kh_Max_xx(i,j) - else - visc_bound_rem(i,j) = 1.0 - Kh(i,j) / (hrat_min(i,j) * CS%Kh_Max_xx(i,j)) + Kh(i,j) = Kh_max_here + elseif ((Kh(i,j) > 0.0) .or. (CS%backscatter_underbound .and. (Kh_max_here > 0.0))) then + visc_bound_rem(i,j) = 1.0 - Kh(i,j) / Kh_max_here endif enddo ; enddo + elseif (CS%bound_Kh) then + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Kh(i,j) = min(Kh(i,j), hrat_min(i,j) * CS%Kh_Max_xx(i,j)) + enddo ; enddo + endif + + ! In Leith+E parameterization Kh is computed after Ah in the biharmonic loop. + ! The harmonic component of str_xx is added in the biharmonic loop. + if (CS%use_Leithy) then + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Kh(i,j) = 0. + enddo ; enddo endif if (CS%id_Kh_h>0 .or. CS%debug) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Kh_h(i,j,k) = Kh(i,j) enddo ; enddo endif if (CS%id_grid_Re_Kh>0) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) + do j=js,je ; do i=is,ie + KE = 0.125*(((u(I,j,k)+u(I-1,j,k))**2) + ((v(i,J,k)+v(i,J-1,k))**2)) grid_Kh = max(Kh(i,j), CS%min_grid_Kh) grid_Re_Kh(i,j,k) = (sqrt(KE) * sqrt(CS%grid_sp_h2(i,j))) / grid_Kh enddo ; enddo endif if (CS%id_div_xx_h>0) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - div_xx_h(i,j,k) = div_xx(i,j) + do j=js,je ; do i=is,ie + div_xx_h(i,j,k) = dudx(i,j) + dvdy(i,j) enddo ; enddo endif if (CS%id_sh_xx_h>0) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js,je ; do i=is,ie sh_xx_h(i,j,k) = sh_xx(i,j) enddo ; enddo endif @@ -1041,7 +1291,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 str_xx(i,j) = 0.0 enddo ; enddo - endif + endif ! Get Kh at h points and get Laplacian component of str_xx if (CS%anisotropic) then do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -1054,22 +1304,22 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%biharmonic) then ! Determine the biharmonic viscosity at h points, using the - ! largest value from several parameterizations. - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + ! largest value from several parameterizations. Also get the + ! biharmonic component of str_xx. + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Ah(i,j) = CS%Ah_bg_xx(i,j) enddo ; enddo - if ((CS%Smagorinsky_Ah) .or. (CS%Leith_Ah)) then + if ((CS%Smagorinsky_Ah) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) then if (CS%Smagorinsky_Ah) then if (CS%bound_Coriolis) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh AhSm = Shear_mag(i,j) * (CS%Biharm_const_xx(i,j) & - + CS%Biharm_const2_xx(i,j) * Shear_mag(i,j) & - ) + + CS%Biharm_const2_xx(i,j) * Shear_mag(i,j)) Ah(i,j) = max(Ah(i,j), AhSm) enddo ; enddo else - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh AhSm = CS%Biharm_const_xx(i,j) * Shear_mag(i,j) Ah(i,j) = max(Ah(i,j), AhSm) enddo ; enddo @@ -1077,94 +1327,197 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif if (CS%Leith_Ah) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - AhLth = CS%Biharm6_const_xx(i,j) * abs(Del2vort_h(i,j)) * inv_PI6 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Del2vort_h = 0.25 * ((Del2vort_q(I,J) + Del2vort_q(I-1,J-1)) + & + (Del2vort_q(I-1,J) + Del2vort_q(I,J-1))) + AhLth = CS%Biharm6_const_xx(i,j) * abs(Del2vort_h) * inv_PI6 Ah(i,j) = max(Ah(i,j), AhLth) enddo ; enddo endif - if (CS%bound_Ah .and. .not. CS%better_bound_Ah) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - Ah(i,j) = min(Ah(i,j), CS%Ah_Max_xx(i,j)) + if (CS%use_Leithy) then + ! Get m_leithy + if (CS%smooth_Ah) m_leithy(:,:) = 0.0 ! This is here to initialize domain edge halo values. + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Del2vort_h = 0.25 * ((Del2vort_q(I,J) + Del2vort_q(I-1,J-1)) + & + (Del2vort_q(I-1,J) + Del2vort_q(I,J-1))) + AhLth = CS%Biharm6_const_xx(i,j) * inv_PI6 * abs(Del2vort_h) + if (AhLth <= CS%Ah_bg_xx(i,j)) then + m_leithy(i,j) = 0.0 + else + if ((CS%m_const_leithy(i,j)*vert_vort_mag(i,j)) < abs(vort_xy_smooth(i,j))) then + m_leithy(i,j) = CS%c_K * (vert_vort_mag(i,j) / vort_xy_smooth(i,j))**2 + else + m_leithy(i,j) = CS%m_leithy_max(i,j) + endif + m_leithy(i,j) = G%mask2dBu(i,j) * m_leithy(i,j) + endif enddo ; enddo + + if (CS%smooth_Ah) then + ! Smooth m_leithy. A single call smoothes twice. + call pass_var(m_leithy, G%Domain, halo=2) + call smooth_x9_h(G, m_leithy, zero_land=.true.) + call pass_var(m_leithy, G%Domain) + endif + ! Get Ah + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Del2vort_h = 0.25 * ((Del2vort_q(I,J) + Del2vort_q(I-1,J-1)) + & + (Del2vort_q(I-1,J) + Del2vort_q(I,J-1))) + AhLthy = CS%Biharm6_const_xx(i,j) * inv_PI6 * & + sqrt(max(0.,Del2vort_h**2 - m_leithy(i,j)*vert_vort_mag_smooth(i,j)**2)) + Ah(i,j) = max(CS%Ah_bg_xx(i,j), AhLthy) + enddo ; enddo + if (CS%smooth_Ah) then + ! Smooth Ah before applying upper bound. Square Ah, then smooth, then take its square root. + Ah_sq(:,:) = 0.0 ! This is here to initialize domain edge halo values. + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Ah_sq(i,j) = Ah(i,j)**2 + enddo ; enddo + call pass_var(Ah_sq, G%Domain, halo=2) + ! A single call smoothes twice. + call smooth_x9_h(G, Ah_sq, zero_land=.false.) + call pass_var(Ah_sq, G%Domain) + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Ah_h(i,j,k) = max(CS%Ah_bg_xx(i,j), sqrt(max(0., Ah_sq(i,j)))) + Ah(i,j) = Ah_h(i,j,k) + enddo ; enddo + else + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Ah_h(i,j,k) = Ah(i,j) + enddo ; enddo + endif endif - endif ! Smagorinsky_Ah or Leith_Ah + + endif ! Smagorinsky_Ah or Leith_Ah or Leith+E if (use_MEKE_Au) then ! *Add* the MEKE contribution - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Ah(i,j) = Ah(i,j) + MEKE%Au(i,j) enddo ; enddo endif if (CS%Re_Ah > 0.0) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + KE = 0.125*(((u(I,j,k)+u(I-1,j,k))**2) + ((v(i,J,k)+v(i,J-1,k))**2)) Ah(i,j) = sqrt(KE) * CS%Re_Ah_const_xx(i,j) enddo ; enddo endif - if (CS%better_bound_Ah) then - if (CS%better_bound_Kh) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + if (CS%bound_Ah) then + if (CS%bound_Kh) then + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Ah(i,j) = min(Ah(i,j), visc_bound_rem(i,j) * hrat_min(i,j) * CS%Ah_Max_xx(i,j)) enddo ; enddo else - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Ah(i,j) = min(Ah(i,j), hrat_min(i,j) * CS%Ah_Max_xx(i,j)) enddo ; enddo endif endif - if ((CS%id_Ah_h>0) .or. CS%debug) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + if (CS%EY24_EBT_BS) then + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + tmp = CS%KS_coef * hrat_min(i,j) * CS%Ah_Max_xx_KS(i,j) + visc_limit_h(i,j,k) = tmp + visc_limit_h_frac(i,j,k) = Ah(i,j) / (CS%KS_coef * hrat_min(i,j) * CS%Ah_Max_xx_KS(i,j)) + if (Ah(i,j) >= tmp) then + visc_limit_h_flag(i,j,k) = 1. + endif + enddo ; enddo + endif + + if ((CS%id_Ah_h>0) .or. CS%debug .or. CS%use_Leithy) then + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Ah_h(i,j,k) = Ah(i,j) enddo ; enddo endif - if (CS%id_grid_Re_Ah>0) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - KE = 0.125 * ((u(I,j,k) + u(I-1,j,k))**2 + (v(i,J,k) + v(i,J-1,k))**2) + if (CS%use_Leithy) then + ! Compute Leith+E Kh after bounds have been applied to Ah + ! and after it has been smoothed. Kh = -m_leithy * Ah + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Kh(i,j) = -m_leithy(i,j) * Ah(i,j) + Kh_h(i,j,k) = Kh(i,j) + enddo ; enddo + endif + + if (CS%id_grid_Re_Ah > 0) then + do j=js,je ; do i=is,ie + KE = 0.125 * (((u(I,j,k) + u(I-1,j,k))**2) + ((v(i,J,k) + v(i,J-1,k))**2)) grid_Ah = max(Ah(i,j), CS%min_grid_Ah) grid_Re_Ah(i,j,k) = (sqrt(KE) * CS%grid_sp_h3(i,j)) / grid_Ah enddo ; enddo endif do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - d_del2u = G%IdyCu(I,j) * Del2u(I,j) - G%IdyCu(I-1,j) * Del2u(I-1,j) - d_del2v = G%IdxCv(i,J) * Del2v(i,J) - G%IdxCv(i,J-1) * Del2v(i,J-1) - d_str = Ah(i,j) * (CS%DY_dxT(i,j) * d_del2u - CS%DX_dyT(i,j) * d_del2v) + d_del2u = (G%IdyCu(I,j) * Del2u(I,j)) - (G%IdyCu(I-1,j) * Del2u(I-1,j)) + d_del2v = (G%IdxCv(i,J) * Del2v(i,J)) - (G%IdxCv(i,J-1) * Del2v(i,J-1)) + d_str = Ah(i,j) * ((CS%DY_dxT(i,j) * d_del2u) - (CS%DX_dyT(i,j) * d_del2v)) str_xx(i,j) = str_xx(i,j) + d_str + if (CS%use_Leithy) str_xx(i,j) = str_xx(i,j) - Kh(i,j) * sh_xx_smooth(i,j) + ! Keep a copy of the biharmonic contribution for backscatter parameterization bhstr_xx(i,j) = d_str * (h(i,j,k) * CS%reduction_xx(i,j)) enddo ; enddo - endif + endif ! Get biharmonic coefficient at h points and biharmonic part of str_xx + + ! Backscatter using MEKE + if (CS%EY24_EBT_BS) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + if (visc_limit_h_flag(i,j,k) > 0) then + Kh_BS(i,j) = 0. + else + if (use_kh_struct) then + Kh_BS(i,j) = MEKE%Ku(i,j) * VarMix%BS_struct(i,j,k) + else + Kh_BS(i,j) = MEKE%Ku(i,j) + endif + endif + enddo ; enddo + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + str_xx_BS(i,j) = -Kh_BS(i,j) * sh_xx(i,j) + enddo ; enddo + + if (CS%id_BS_coeff_h>0) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + BS_coeff_h(i,j,k) = Kh_BS(i,j) + enddo ; enddo + endif + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + str_xx(i,j) = str_xx(i,j) + str_xx_BS(i,j) + enddo ; enddo + endif ! Backscatter if (CS%biharmonic) then ! Gradient of Laplacian, for use in bi-harmonic term do J=js-1,Jeq ; do I=is-1,Ieq - dDel2vdx(I,J) = CS%DY_dxBu(I,J)*(Del2v(i+1,J)*G%IdyCv(i+1,J) - Del2v(i,J)*G%IdyCv(i,J)) - dDel2udy(I,J) = CS%DX_dyBu(I,J)*(Del2u(I,j+1)*G%IdxCu(I,j+1) - Del2u(I,j)*G%IdxCu(I,j)) + dDel2vdx(I,J) = CS%DY_dxBu(I,J)*((Del2v(i+1,J)*G%IdyCv(i+1,J)) - (Del2v(i,J)*G%IdyCv(i,J))) + dDel2udy(I,J) = CS%DX_dyBu(I,J)*((Del2u(I,j+1)*G%IdxCu(I,j+1)) - (Del2u(I,j)*G%IdxCu(I,j))) enddo ; enddo ! Adjust contributions to shearing strain on open boundaries. - if (apply_OBC) then ; if (OBC%zero_strain .or. OBC%freeslip_strain) then + if (apply_OBC) then ; if ((OBC%strain_config == OBC_STRAIN_ZERO) .or. & + (OBC%strain_config == OBC_STRAIN_FREESLIP)) then do n=1,OBC%number_of_segments J = OBC%segment(n)%HI%JsdB ; I = OBC%segment(n)%HI%IsdB if (OBC%segment(n)%is_N_or_S .and. (J >= js-1) .and. (J <= Jeq)) then do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB - if (OBC%zero_strain) then + if (OBC%strain_config == OBC_STRAIN_ZERO) then dDel2vdx(I,J) = 0. ; dDel2udy(I,J) = 0. - elseif (OBC%freeslip_strain) then + elseif (OBC%strain_config == OBC_STRAIN_FREESLIP) then dDel2udy(I,J) = 0. endif enddo elseif (OBC%segment(n)%is_E_or_W .and. (I >= is-1) .and. (I <= Ieq)) then do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB - if (OBC%zero_strain) then + if (OBC%strain_config == OBC_STRAIN_ZERO) then dDel2vdx(I,J) = 0. ; dDel2udy(I,J) = 0. - elseif (OBC%freeslip_strain) then + elseif (OBC%strain_config == OBC_STRAIN_FREESLIP) then dDel2vdx(I,J) = 0. endif enddo @@ -1173,13 +1526,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif ; endif endif - meke_res_fn = 1. - if ((CS%Smagorinsky_Kh) .or. (CS%Smagorinsky_Ah)) then do J=js-1,Jeq ; do I=is-1,Ieq sh_xy_sq = sh_xy(I,J)**2 - sh_xx_sq = 0.25 * ( (sh_xx(i,j)**2 + sh_xx(i+1,j+1)**2) & - + (sh_xx(i,j+1)**2 + sh_xx(i+1,j)**2) ) + sh_xx_sq = 0.25 * ( ((sh_xx(i,j)**2) + (sh_xx(i+1,j+1)**2)) & + + ((sh_xx(i,j+1)**2) + (sh_xx(i+1,j)**2)) ) Shear_mag(I,J) = sqrt(sh_xy_sq + sh_xx_sq) enddo ; enddo endif @@ -1191,17 +1542,12 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, / (h_neglect3 + (h2uq + h2vq) * ((h_u(I,j) + h_u(I,j+1)) + (h_v(i,J) + h_v(i+1,J)))) enddo ; enddo - if (CS%better_bound_Ah .or. CS%better_bound_Kh) then + if (CS%bound_Ah .or. CS%bound_Kh) then do J=js-1,Jeq ; do I=is-1,Ieq h_min = min(h_u(I,j), h_u(I,j+1), h_v(i,J), h_v(i+1,J)) - hrat_min(i,j) = min(1.0, h_min / (hq(I,J) + h_neglect)) + hrat_min(I,J) = min(1.0, h_min / (hq(I,J) + h_neglect)) enddo ; enddo - if (CS%better_bound_Kh) then - do J=js-1,Jeq ; do I=is-1,Ieq - visc_bound_rem(i,j) = 1.0 - enddo ; enddo - endif endif if (CS%no_slip) then @@ -1217,48 +1563,54 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, (G%mask2dCv(i,J) + G%mask2dCv(i+1,J)) == 0.0) then ! Only one of hu and hv is nonzero, so just add them. hq(I,J) = hu + hv - hrat_min(i,j) = 1.0 + hrat_min(I,J) = 1.0 else ! Both hu and hv are nonzero, so take the harmonic mean. hq(I,J) = 2.0 * (hu * hv) / ((hu + hv) + h_neglect) - hrat_min(i,j) = min(1.0, min(hu, hv) / (hq(I,J) + h_neglect) ) + hrat_min(I,J) = min(1.0, min(hu, hv) / (hq(I,J) + h_neglect) ) endif endif endif enddo ; enddo endif + ! Pass the velocity gradients and thickness to ZB2020 + if (CS%use_ZB2020) then + call ZB2020_copy_gradient_and_thickness(sh_xx, sh_xy, vort_xy, hq, G, GV, CS%ZB2020, k) + endif + if (CS%Laplacian) then + ! Determine the Laplacian viscosity at q points, using the + ! largest value from several parameterizations. Also get the + ! Laplacian component of str_xy. + if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then if (CS%use_QG_Leith_visc) then do J=js-1,Jeq ; do I=is-1,Ieq grad_vort = grad_vort_mag_q(I,J) + grad_div_mag_q(I,J) grad_vort_qg = 3. * grad_vort_mag_q_2d(I,J) - vert_vort_mag(i,j) = min(grad_vort, grad_vort_qg) + vert_vort_mag(I,J) = min(grad_vort, grad_vort_qg) enddo ; enddo else do J=js-1,Jeq ; do I=is-1,Ieq - vert_vort_mag(i,j) = grad_vort_mag_q(I,J) + grad_div_mag_q(I,J) + vert_vort_mag(I,J) = grad_vort_mag_q(I,J) + grad_div_mag_q(I,J) enddo ; enddo endif endif - ! Determine the Laplacian viscosity at q points, using the - ! largest value from several parameterizations. - ! Static (pre-computed) background viscosity do J=js-1,Jeq ; do I=is-1,Ieq - Kh(i,j) = CS%Kh_bg_xy(i,j) + Kh(I,J) = CS%Kh_bg_xy(I,J) enddo ; enddo if (CS%Smagorinsky_Kh) then if (CS%add_LES_viscosity) then do J=js-1,Jeq ; do I=is-1,Ieq - Kh(i,j) = Kh(i,j) + CS%Laplac2_const_xx(i,j) * Shear_mag(i,j) + Kh(I,J) = Kh(I,J) + CS%Laplac2_const_xy(I,J) * Shear_mag(I,J) enddo ; enddo else do J=js-1,Jeq ; do I=is-1,Ieq - Kh(i,j) = max(Kh(i,j), CS%Laplac2_const_xy(I,J) * Shear_mag(i,j) ) + Kh(I,J) = max(Kh(I,J), CS%Laplac2_const_xy(I,J) * Shear_mag(I,J) ) enddo ; enddo endif endif @@ -1266,101 +1618,143 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%Leith_Kh) then if (CS%add_LES_viscosity) then do J=js-1,Jeq ; do I=is-1,Ieq - Kh(i,j) = Kh(i,j) + CS%Laplac3_const_xx(i,j) * vert_vort_mag(i,j) * inv_PI3 + Kh(I,J) = Kh(I,J) + CS%Laplac3_const_xy(I,J) * vert_vort_mag(I,J) * inv_PI3 ! Is this right? -AJA enddo ; enddo else do J=js-1,Jeq ; do I=is-1,Ieq - Kh(i,j) = max(Kh(i,j), CS%Laplac3_const_xy(I,J) * vert_vort_mag(i,j) * inv_PI3) + Kh(I,J) = max(Kh(I,J), CS%Laplac3_const_xy(I,J) * vert_vort_mag(I,J) * inv_PI3) enddo ; enddo endif endif ! All viscosity contributions above are subject to resolution scaling - ! NOTE: The following do-block can be decomposed and vectorized after the - ! stack size has been reduced. - do J=js-1,Jeq ; do I=is-1,Ieq - if (rescale_Kh) & - Kh(i,j) = VarMix%Res_fn_q(i,j) * Kh(i,j) + if (rescale_Kh) then + do J=js-1,Jeq ; do I=is-1,Ieq + Kh(I,J) = VarMix%Res_fn_q(I,J) * Kh(I,J) + enddo ; enddo + endif - if (CS%res_scale_MEKE) & - meke_res_fn = VarMix%Res_fn_q(i,j) + do J=js-1,Jeq ; do I=is-1,Ieq + Kh(I,J) = max(Kh(I,J), CS%Kh_bg_min) ! Place a floor on the viscosity, if desired. + enddo ; enddo - ! Older method of bounding for stability - if (legacy_bound) & - Kh(i,j) = min(Kh(i,j), CS%Kh_Max_xy(i,j)) + if (use_MEKE_Ku .and. .not. CS%EY24_EBT_BS) then + if (use_kh_struct) then + do J=js-1,Jeq ; do I=is-1,Ieq + meke_res_fn = 1. + if (CS%res_scale_MEKE) meke_res_fn = VarMix%Res_fn_q(I,J) - Kh(i,j) = max(Kh(i,j), CS%Kh_bg_min) ! Place a floor on the viscosity, if desired. + 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 + enddo ; enddo + else + do J=js-1,Jeq ; do I=is-1,Ieq + meke_res_fn = 1. + if (CS%res_scale_MEKE) meke_res_fn = VarMix%Res_fn_q(I,J) - if (use_MEKE_Ku) then - ! *Add* the MEKE contribution (might be negative) - Kh(i,j) = Kh(i,j) + 0.25*( (MEKE%Ku(i,j) + MEKE%Ku(i+1,j+1)) + & - (MEKE%Ku(i+1,j) + MEKE%Ku(i,j+1)) ) * meke_res_fn + 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 + enddo ; enddo endif + endif - ! Older method of bounding for stability - if (CS%anisotropic) & - ! *Add* the shear component of anisotropic viscosity - Kh(i,j) = Kh(i,j) + CS%Kh_aniso * CS%n1n2_q(I,J)**2 + if (CS%anisotropic) then + ! *Add* the shear component of anisotropic viscosity + do J=js-1,Jeq ; do I=is-1,Ieq + Kh(I,J) = Kh(I,J) + CS%Kh_aniso * CS%n1n2_q(I,J)**2 + enddo ; enddo + endif + do J=js-1,Jeq ; do I=is-1,Ieq ! Newer method of bounding for stability - if (CS%better_bound_Kh) then - if (Kh(i,j) >= hrat_min(i,j) * CS%Kh_Max_xy(I,J)) then - visc_bound_rem(i,j) = 0.0 - Kh(i,j) = hrat_min(i,j) * CS%Kh_Max_xy(I,J) - elseif (CS%Kh_Max_xy(I,J)>0.) then - visc_bound_rem(i,j) = 1.0 - Kh(i,j) / (hrat_min(i,j) * CS%Kh_Max_xy(I,J)) + if ((CS%bound_Kh) .and. (CS%bound_Ah)) then + visc_bound_rem(I,J) = 1.0 + Kh_max_here = hrat_min(I,J) * CS%Kh_Max_xy(I,J) + if (Kh(I,J) >= Kh_max_here) then + visc_bound_rem(I,J) = 0.0 + Kh(I,J) = Kh_max_here + elseif ((Kh(I,J) > 0.0) .or. (CS%backscatter_underbound .and. (Kh_max_here > 0.0))) then + visc_bound_rem(I,J) = 1.0 - Kh(I,J) / Kh_max_here endif + elseif (CS%bound_Kh) then + Kh(I,J) = min(Kh(I,J), hrat_min(I,J) * CS%Kh_Max_xy(I,J)) endif + enddo ; enddo + + if (CS%use_Leithy) then + ! Leith+E doesn't recompute Kh at q points, it just interpolates it from h to q points + do J=js-1,Jeq ; do I=is-1,Ieq + Kh(I,J) = 0.25 * ((Kh_h(i,j,k) + Kh_h(i+1,j+1,k)) + (Kh_h(i,j+1,k) + Kh_h(i+1,j,k))) + enddo ; enddo + endif - if (CS%id_Kh_q>0 .or. CS%debug) & - Kh_q(I,J,k) = Kh(i,j) + if (CS%id_Kh_q > 0 .or. CS%debug) then + do J=js-1,Jeq ; do I=is-1,Ieq + Kh_q(I,J,k) = Kh(I,J) + enddo ; enddo + endif - if (CS%id_vort_xy_q>0) & + if (CS%id_vort_xy_q > 0) then + do J=js-1,Jeq ; do I=is-1,Ieq vort_xy_q(I,J,k) = vort_xy(I,J) + enddo ; enddo + endif - if (CS%id_sh_xy_q>0) & + if (CS%id_sh_xy_q > 0) then + do J=js-1,Jeq ; do I=is-1,Ieq sh_xy_q(I,J,k) = sh_xy(I,J) - enddo ; enddo + enddo ; enddo + endif - do J=js-1,Jeq ; do I=is-1,Ieq - str_xy(I,J) = -Kh(i,j) * sh_xy(I,J) - enddo ; enddo + if (.not. CS%use_Leithy) then + do J=js-1,Jeq ; do I=is-1,Ieq + str_xy(I,J) = -Kh(I,J) * sh_xy(I,J) + enddo ; enddo + else + do J=js-1,Jeq ; do I=is-1,Ieq + str_xy(I,J) = -Kh(I,J) * sh_xy_smooth(I,J) + enddo ; enddo + endif else do J=js-1,Jeq ; do I=is-1,Ieq str_xy(I,J) = 0. enddo ; enddo - endif + endif ! get harmonic coefficient Kh at q points and harmonic part of str_xy if (CS%anisotropic) then do J=js-1,Jeq ; do I=is-1,Ieq ! Horizontal-tension averaged to q-points local_strain = 0.25 * ( (sh_xx(i,j) + sh_xx(i+1,j+1)) + (sh_xx(i+1,j) + sh_xx(i,j+1)) ) ! *Add* the tension contribution to the xy-component of stress - str_xy(I,J) = str_xy(I,J) - CS%Kh_aniso * CS%n1n2_q(i,j) * CS%n1n1_m_n2n2_q(i,j) * local_strain + str_xy(I,J) = str_xy(I,J) - CS%Kh_aniso * CS%n1n2_q(I,J) * CS%n1n1_m_n2n2_q(I,J) * local_strain enddo ; enddo endif if (CS%biharmonic) then ! Determine the biharmonic viscosity at q points, using the - ! largest value from several parameterizations. + ! largest value from several parameterizations. Also get the + ! biharmonic component of str_xy. do J=js-1,Jeq ; do I=is-1,Ieq - Ah(i,j) = CS%Ah_bg_xy(I,J) + Ah(I,J) = CS%Ah_bg_xy(I,J) enddo ; enddo if (CS%Smagorinsky_Ah .or. CS%Leith_Ah) then if (CS%Smagorinsky_Ah) then if (CS%bound_Coriolis) then do J=js-1,Jeq ; do I=is-1,Ieq - AhSm = Shear_mag(i,j) * (CS%Biharm_const_xy(I,J) & - + CS%Biharm_const2_xy(I,J) * Shear_mag(i,j) & - ) - Ah(i,j) = max(Ah(I,J), AhSm) + AhSm = Shear_mag(I,J) * (CS%Biharm_const_xy(I,J) & + + CS%Biharm_const2_xy(I,J) * Shear_mag(I,J)) + Ah(I,J) = max(Ah(I,J), AhSm) enddo ; enddo else do J=js-1,Jeq ; do I=is-1,Ieq - AhSm = CS%Biharm_const_xy(I,J) * Shear_mag(i,j) - Ah(i,j) = max(Ah(I,J), AhSm) + AhSm = CS%Biharm_const_xy(I,J) * Shear_mag(I,J) + Ah(I,J) = max(Ah(I,J), AhSm) enddo ; enddo endif endif @@ -1368,13 +1762,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%Leith_Ah) then do J=js-1,Jeq ; do I=is-1,Ieq AhLth = CS%Biharm6_const_xy(I,J) * abs(Del2vort_q(I,J)) * inv_PI6 - Ah(i,j) = max(Ah(I,J), AhLth) - enddo ; enddo - endif - - if (CS%bound_Ah .and. .not.CS%better_bound_Ah) then - do J=js-1,Jeq ; do I=is-1,Ieq - Ah(i,j) = min(Ah(i,j), CS%Ah_Max_xy(I,J)) + Ah(I,J) = max(Ah(I,J), AhLth) enddo ; enddo endif endif ! Smagorinsky_Ah or Leith_Ah @@ -1382,103 +1770,146 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (use_MEKE_Au) then ! *Add* the MEKE contribution do J=js-1,Jeq ; do I=is-1,Ieq - Ah(i,j) = Ah(i,j) + 0.25 * ( & - (MEKE%Au(i,j) + MEKE%Au(i+1,j+1)) + (MEKE%Au(i+1,j) + MEKE%Au(i,j+1)) & - ) + Ah(I,J) = Ah(I,J) + 0.25 * ( & + (MEKE%Au(i,j) + MEKE%Au(i+1,j+1)) + (MEKE%Au(i+1,j) + MEKE%Au(i,j+1)) ) enddo ; enddo endif if (CS%Re_Ah > 0.0) then do J=js-1,Jeq ; do I=is-1,Ieq - KE = 0.125 * ((u(I,j,k) + u(I,j+1,k))**2 + (v(i,J,k) + v(i+1,J,k))**2) - Ah(i,j) = sqrt(KE) * CS%Re_Ah_const_xy(i,j) + KE = 0.125 * (((u(I,j,k) + u(I,j+1,k))**2) + ((v(i,J,k) + v(i+1,J,k))**2)) + Ah(I,J) = sqrt(KE) * CS%Re_Ah_const_xy(I,J) enddo ; enddo endif - if (CS%better_bound_Ah) then - if (CS%better_bound_Kh) then + if (CS%bound_Ah) then + if (CS%bound_Kh) then do J=js-1,Jeq ; do I=is-1,Ieq - Ah(i,j) = min(Ah(i,j), visc_bound_rem(i,j) * hrat_min(i,j) * CS%Ah_Max_xy(I,J)) + Ah(I,J) = min(Ah(I,J), visc_bound_rem(I,J) * hrat_min(I,J) * CS%Ah_Max_xy(I,J)) enddo ; enddo else do J=js-1,Jeq ; do I=is-1,Ieq - Ah(i,j) = min(Ah(i,j), hrat_min(i,j) * CS%Ah_Max_xy(I,J)) + Ah(I,J) = min(Ah(I,J), hrat_min(I,J) * CS%Ah_Max_xy(I,J)) enddo ; enddo endif endif + if (CS%EY24_EBT_BS) then + do J=js-1,Jeq ; do I=is-1,Ieq + tmp = CS%KS_coef *hrat_min(I,J) * CS%Ah_Max_xy_KS(I,J) + visc_limit_q(I,J,k) = tmp + visc_limit_q_frac(i,j,k) = Ah(i,j) / (CS%KS_coef * hrat_min(i,j) * CS%Ah_Max_xy_KS(i,j)) + if (Ah(I,J) >= tmp) then + visc_limit_q_flag(I,J,k) = 1. + endif + enddo ; enddo + endif + + ! Leith+E doesn't recompute Ah at q points, it just interpolates it from h to q points + if (CS%use_Leithy) then + do J=js-1,Jeq ; do I=is-1,Ieq + Ah(I,J) = 0.25 * ((Ah_h(i,j,k) + Ah_h(i+1,j+1,k)) + (Ah_h(i,j+1,k) + Ah_h(i+1,j,k))) + enddo ; enddo + endif + if (CS%id_Ah_q>0 .or. CS%debug) then do J=js-1,Jeq ; do I=is-1,Ieq - Ah_q(I,J,k) = Ah(i,j) + Ah_q(I,J,k) = Ah(I,J) enddo ; enddo endif ! Again, need to initialize str_xy as if its biharmonic do J=js-1,Jeq ; do I=is-1,Ieq - d_str = Ah(i,j) * (dDel2vdx(I,J) + dDel2udy(I,J)) + d_str = Ah(I,J) * (dDel2vdx(I,J) + dDel2udy(I,J)) str_xy(I,J) = str_xy(I,J) + d_str ! Keep a copy of the biharmonic contribution for backscatter parameterization bhstr_xy(I,J) = d_str * (hq(I,J) * G%mask2dBu(I,J) * CS%reduction_xy(I,J)) enddo ; enddo - endif + endif ! Get Ah at q points and biharmonic part of str_xy - if (CS%use_GME) then - !### This call to get the 3-d GME diffusivity arrays and the subsequent blocking halo update - ! should occur outside of the k-loop, and perhaps the halo update should occur outside of - ! this routine altogether! - call thickness_diffuse_get_KH(TD, KH_u_GME, KH_v_GME, G, GV) - call pass_vector(KH_u_GME, KH_v_GME, G%Domain) + ! Backscatter using MEKE + if (CS%EY24_EBT_BS) then + do J=js-1,Jeq ; do I=is-1,Ieq + if (visc_limit_q_flag(I,J,k) > 0) then + Kh_BS(I,J) = 0. + else + if (use_kh_struct) then + Kh_BS(I,J) = 0.25*( ((MEKE%Ku(i,j)*VarMix%BS_struct(i,j,k)) + & + (MEKE%Ku(i+1,j+1)*VarMix%BS_struct(i+1,j+1,k))) + & + ((MEKE%Ku(i+1,j)*VarMix%BS_struct(i+1,j,k)) + & + (MEKE%Ku(i,j+1)*VarMix%BS_struct(i,j+1,k))) ) + else + Kh_BS(I,J) = 0.25*( (MEKE%Ku(i,j) + MEKE%Ku(i+1,j+1)) + & + (MEKE%Ku(i+1,j) + MEKE%Ku(i,j+1)) ) + endif + endif + enddo ; enddo - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do J=js-1,Jeq ; do I=is-1,Ieq + str_xy_BS(I,J) = -Kh_BS(I,J) * (sh_xy(I,J)) + enddo ; enddo + + if (CS%id_BS_coeff_q>0) then + do J=js-1,Jeq ; do I=is-1,Ieq + BS_coeff_q(I,J,k) = Kh_BS(I,J) + enddo ; enddo + endif + + do J=js-1,Jeq ; do I=is-1,Ieq + str_xy(I,J) = str_xy(I,J) + str_xy_BS(I,J) + enddo ; enddo + endif ! Backscatter + + if (CS%use_GME) then + ! The wider halo here is to permit one pass of smoothing without a halo update. + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 GME_coeff = GME_effic_h(i,j) * 0.25 * & ((KH_u_GME(I,j,k)+KH_u_GME(I-1,j,k)) + (KH_v_GME(i,J,k)+KH_v_GME(i,J-1,k))) GME_coeff = MIN(GME_coeff, CS%GME_limiter) if ((CS%id_GME_coeff_h>0) .or. find_FrictWork) GME_coeff_h(i,j,k) = GME_coeff str_xx_GME(i,j) = GME_coeff * sh_xx_bt(i,j) - enddo ; enddo - do J=js-1,Jeq ; do I=is-1,Ieq + ! The wider halo here is to permit one pass of smoothing without a halo update. + do J=js-2,je+1 ; do I=is-2,ie+1 GME_coeff = GME_effic_q(I,J) * 0.25 * & ((KH_u_GME(I,j,k)+KH_u_GME(I,j+1,k)) + (KH_v_GME(i,J,k)+KH_v_GME(i+1,J,k))) GME_coeff = MIN(GME_coeff, CS%GME_limiter) if (CS%id_GME_coeff_q>0) GME_coeff_q(I,J,k) = GME_coeff str_xy_GME(I,J) = GME_coeff * sh_xy_bt(I,J) - enddo ; enddo ! Applying GME diagonal term. This is linear and the arguments can be rescaled. - call smooth_GME(G, GME_flux_h=str_xx_GME) - call smooth_GME(G, GME_flux_q=str_xy_GME) + call smooth_GME(CS, G, GME_flux_h=str_xx_GME) + call smooth_GME(CS, G, GME_flux_q=str_xy_GME) - do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + ! This changes the units of str_xx from [L2 T-2 ~> m2 s-2] to [H L2 T-2 ~> m3 s-2 or kg s-2]. + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 str_xx(i,j) = (str_xx(i,j) + str_xx_GME(i,j)) * (h(i,j,k) * CS%reduction_xx(i,j)) enddo ; enddo - do J=js-1,Jeq ; do I=is-1,Ieq - ! GME is applied below - if (CS%no_slip) then + ! This adds in GME and changes the units of str_xx from [L2 T-2 ~> m2 s-2] to [H L2 T-2 ~> m3 s-2 or kg s-2]. + if (CS%no_slip) then + do J=js-1,Jeq ; do I=is-1,Ieq str_xy(I,J) = (str_xy(I,J) + str_xy_GME(I,J)) * (hq(I,J) * CS%reduction_xy(I,J)) - else + enddo ; enddo + else + do J=js-1,Jeq ; do I=is-1,Ieq str_xy(I,J) = (str_xy(I,J) + str_xy_GME(I,J)) * (hq(I,J) * G%mask2dBu(I,J) * CS%reduction_xy(I,J)) - endif - enddo ; enddo - - if (allocated(MEKE%GME_snk)) then - do j=js,je ; do i=is,ie - FrictWork_GME(i,j,k) = GME_coeff_h(i,j,k) * h(i,j,k) * GV%H_to_kg_m2 * grad_vel_mag_bt_h(i,j) enddo ; enddo endif else ! .not. use_GME - do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + ! This changes the units of str_xx from [L2 T-2 ~> m2 s-2] to [H L2 T-2 ~> m3 s-2 or kg s-2]. + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 str_xx(i,j) = str_xx(i,j) * (h(i,j,k) * CS%reduction_xx(i,j)) enddo ; enddo + ! This changes the units of str_xy from [L2 T-2 ~> m2 s-2] to [H L2 T-2 ~> m3 s-2 or kg s-2]. if (CS%no_slip) then do J=js-1,Jeq ; do I=is-1,Ieq str_xy(I,J) = str_xy(I,J) * (hq(I,J) * CS%reduction_xy(I,J)) @@ -1492,10 +1923,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Evaluate 1/h x.Div(h Grad u) or the biharmonic equivalent. do j=js,je ; do I=Isq,Ieq - diffu(I,j,k) = ((G%IdyCu(I,j)*(CS%dy2h(i,j) *str_xx(i,j) - & - CS%dy2h(i+1,j)*str_xx(i+1,j)) + & - G%IdxCu(I,j)*(CS%dx2q(I,J-1)*str_xy(I,J-1) - & - CS%dx2q(I,J) *str_xy(I,J))) * & + diffu(I,j,k) = ((G%IdxCu(I,j)*((CS%dx2q(I,J-1)*str_xy(I,J-1)) - (CS%dx2q(I,J)*str_xy(I,J))) + & + G%IdyCu(I,j)*((CS%dy2h(i,j)*str_xx(i,j)) - (CS%dy2h(i+1,j)*str_xx(i+1,j)))) * & G%IareaCu(I,j)) / (h_u(I,j) + h_neglect) enddo ; enddo @@ -1514,10 +1943,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Evaluate 1/h y.Div(h Grad u) or the biharmonic equivalent. do J=Jsq,Jeq ; do i=is,ie - diffv(i,J,k) = ((G%IdyCv(i,J)*(CS%dy2q(I-1,J)*str_xy(I-1,J) - & - CS%dy2q(I,J) *str_xy(I,J)) - & - G%IdxCv(i,J)*(CS%dx2h(i,j) *str_xx(i,j) - & - CS%dx2h(i,j+1)*str_xx(i,j+1))) * & + diffv(i,J,k) = ((G%IdyCv(i,J)*((CS%dy2q(I-1,J)*str_xy(I-1,J)) - (CS%dy2q(I,J)*str_xy(I,J))) - & + G%IdxCv(i,J)*((CS%dx2h(i,j)*str_xx(i,j)) - (CS%dx2h(i,j+1)*str_xx(i,j+1)))) * & G%IareaCv(i,J)) / (h_v(i,J) + h_neglect) enddo ; enddo @@ -1534,24 +1961,183 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo endif - if (find_FrictWork) then ; do j=js,je ; do i=is,ie - ! Diagnose str_xx*d_x u - str_yy*d_y v + str_xy*(d_y u + d_x v) + if (find_FrictWork) then + if (CS%FrictWork_bug) then + ! Diagnose str_xx*d_x u - str_yy*d_y v + str_xy*(d_y u + d_x v) + ! This is the old formulation that includes energy diffusion + do j=js,je ; do i=is,ie + FrictWork(i,j,k) = GV%H_to_RZ * ( & + ((str_xx(i,j) * (u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j)) & + - (str_xx(i,j) * (v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j))) & + + 0.25*(( (str_xy(I,J) * & + (((u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J)) & + + ((v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J)))) & + + (str_xy(I-1,J-1) * & + (((u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1)) & + + ((v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1)))) ) & + + ( (str_xy(I-1,J) * & + (((u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J)) & + + ((v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J)))) & + + (str_xy(I,J-1) * & + (((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1)) & + + ((v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)))) ) ) ) + enddo ; enddo + else + do j=js,je ; do i=is,ie + FrictWork(i,j,k) = GV%H_to_RZ * G%IareaT(i,j) * ( & + ((str_xx(i,j)*CS%dy2h(i,j) * ( & + (uh(I,j,k)*G%dxCu(I,j)*G%IdyCu(I,j)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)) & + - (uh(I-1,j,k)*G%dxCu(I-1,j)*G%IdyCu(I-1,j)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)) ) ) & + - (str_xx(i,j)*CS%dx2h(i,j) * ( & + (vh(i,J,k)*G%dyCv(i,J)*G%IdxCv(i,J)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)) & + - (vh(i,J-1,k)*G%dyCv(i,J-1)*G%IdxCv(i,J-1)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)) ) )) & + + (0.25*(((str_xy(I,J)*( & + (CS%dx2q(I,J)*((uh(I,j+1,k)*G%IareaCu(I,j+1)/(h_u(I,j+1)+h_neglect)) & + - (uh(I,j,k)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)))) & + + (CS%dy2q(I,J)*((vh(i+1,J,k)*G%IareaCv(i+1,J)/(h_v(i+1,J)+h_neglect)) & + - (vh(i,J,k)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)))) )) & + +(str_xy(I-1,J-1)*( & + (CS%dx2q(I-1,J-1)*((uh(I-1,j,k)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)) & + - (uh(I-1,j-1,k)*G%IareaCu(I-1,j-1)/(h_u(I-1,j-1)+h_neglect)))) & + + (CS%dy2q(I-1,J-1)*((vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)) & + - (vh(i-1,J-1,k)*G%IareaCv(i-1,J-1)/(h_v(i-1,J-1)+h_neglect)))) )) ) & + +((str_xy(I-1,J)*( & + (CS%dx2q(I-1,J)*((uh(I-1,j+1,k)*G%IareaCu(I-1,j+1)/(h_u(I-1,j+1)+h_neglect)) & + - (uh(I-1,j,k)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)))) & + + (CS%dy2q(I-1,J)*((vh(i,J,k)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)) & + - (vh(i-1,J,k)*G%IareaCv(i-1,J)/(h_v(i-1,J)+h_neglect)))) )) & + +(str_xy(I,J-1)*( & + (CS%dx2q(I,J-1)*((uh(I,j,k)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)) & + - (uh(I,j-1,k)*G%IareaCu(I,j-1)/(h_u(I,j-1)+h_neglect)))) & + + (CS%dy2q(I,J-1)*((vh(i+1,J-1,k)*G%IareaCv(i+1,J-1)/(h_v(i+1,J-1)+h_neglect)) & + - (vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)))) )) ) )) ) + + enddo ; enddo + endif + + if (CS%EY24_EBT_BS) then + do j=js,je ; do i=is,ie + FrictWork(i,j,k) = (1. - visc_limit_h_flag(i,j,k)) * FrictWork(i,j,k) + enddo ; enddo + endif + endif + + if (CS%id_FrictWork_bh>0 .or. CS%id_FrictWorkIntz_bh > 0 .or. allocated(MEKE%mom_src_bh)) then + if (CS%FrictWork_bug) then + ! Diagnose bhstr_xx*d_x u - bhstr_yy*d_y v + bhstr_xy*(d_y u + d_x v) + ! This is the old formulation that includes energy diffusion !cyc + do j=js,je ; do i=is,ie + FrictWork_bh(i,j,k) = GV%H_to_RZ * ( & + ((bhstr_xx(i,j) * (u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j)) & + - (bhstr_xx(i,j) * (v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j))) & + + 0.25*(( (bhstr_xy(I,J) * & + (((u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J)) & + + ((v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J)))) & + + (bhstr_xy(I-1,J-1) * & + (((u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1)) & + + ((v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1)))) ) & + + ( (bhstr_xy(I-1,J) * & + (((u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J)) & + + ((v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J)))) & + + (bhstr_xy(I,J-1) * & + (((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1)) & + + ((v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)))) ) ) ) + enddo ; enddo + else + do j=js,je ; do i=is,ie + ! Diagnose bhstr_xx*d_x u - bhstr_yy*d_y v + bhstr_xy*(d_y u + d_x v) + FrictWork_bh(i,j,k) = GV%H_to_RZ * G%IareaT(i,j) * ( & + ((bhstr_xx(i,j)*CS%dy2h(i,j) * ( & + (uh(I,j,k)*G%dxCu(I,j)*G%IdyCu(I,j)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)) & + - (uh(I-1,j,k)*G%dxCu(I-1,j)*G%IdyCu(I-1,j)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)) ) ) & + - (bhstr_xx(i,j)*CS%dx2h(i,j) * ( & + (vh(i,J,k)*G%dyCv(i,J)*G%IdxCv(i,J)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)) & + - (vh(i,J-1,k)*G%dyCv(i,J-1)*G%IdxCv(i,J-1)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)) ) )) & + + (0.25*(((bhstr_xy(I,J)*( & + (CS%dx2q(I,J)*((uh(I,j+1,k)*G%IareaCu(I,j+1)/(h_u(I,j+1)+h_neglect)) & + - (uh(I,j,k)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)))) & + + (CS%dy2q(I,J)*((vh(i+1,J,k)*G%IareaCv(i+1,J)/(h_v(i+1,J)+h_neglect)) & + - (vh(i,J,k)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)))) )) & + +(bhstr_xy(I-1,J-1)*( & + (CS%dx2q(I-1,J-1)*((uh(I-1,j,k)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)) & + - (uh(I-1,j-1,k)*G%IareaCu(I-1,j-1)/(h_u(I-1,j-1)+h_neglect)))) & + + (CS%dy2q(I-1,J-1)*((vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)) & + - (vh(i-1,J-1,k)*G%IareaCv(i-1,J-1)/(h_v(i-1,J-1)+h_neglect)))) )) ) & + +((bhstr_xy(I-1,J)*( & + (CS%dx2q(I-1,J)*((uh(I-1,j+1,k)*G%IareaCu(I-1,j+1)/(h_u(I-1,j+1)+h_neglect)) & + - (uh(I-1,j,k)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)))) & + + (CS%dy2q(I-1,J)*((vh(i,J,k)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)) & + - (vh(i-1,J,k)*G%IareaCv(i-1,J)/(h_v(i-1,J)+h_neglect)))) )) & + +(bhstr_xy(I,J-1)*( & + (CS%dx2q(I,J-1)*((uh(I,j,k)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)) & + - (uh(I,j-1,k)*G%IareaCu(I,j-1)/(h_u(I,j-1)+h_neglect)))) & + + (CS%dy2q(I,J-1)*((vh(i+1,J-1,k)*G%IareaCv(i+1,J-1)/(h_v(i+1,J-1)+h_neglect)) & + - (vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)))) )) ) )) ) + enddo ; enddo + endif + + if (CS%EY24_EBT_BS) then + do j=js,je ; do i=is,ie + FrictWork_bh(i,j,k) = (1. - visc_limit_h_flag(i,j,k)) * FrictWork_bh(i,j,k) + enddo ; enddo + endif + endif + + if (CS%use_GME) then + if (CS%FrictWork_bug) then ; do j=js,je ; do i=is,ie + ! Diagnose str_xx_GME*d_x u - str_yy_GME*d_y v + str_xy_GME*(d_y u + d_x v) ! This is the old formulation that includes energy diffusion - FrictWork(i,j,k) = GV%H_to_RZ * ( & - (str_xx(i,j)*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & - -str_xx(i,j)*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & - +0.25*((str_xy(I,J)*( & - (u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J) & - +(v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J) ) & - +str_xy(I-1,J-1)*( & - (u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1) & - +(v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1) )) & - +(str_xy(I-1,J)*( & - (u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J) & - +(v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J) ) & - +str_xy(I,J-1)*( & - (u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1) & - +(v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1) )) ) ) + FrictWork_GME(i,j,k) = GV%H_to_RZ * ( & + ((str_xx_GME(i,j)*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j)) & + - (str_xx_GME(i,j)*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j))) & + + 0.25*(( (str_xy_GME(I,J) * & + (((u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J)) & + + ((v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J)))) & + + (str_xy_GME(I-1,J-1) * & + (((u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1)) & + + ((v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1)))) ) & + + ( (str_xy_GME(I-1,J) * & + (((u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J)) & + + ((v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J)))) & + + (str_xy_GME(I,J-1) * & + (((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1)) & + + ((v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)))) ) ) ) + enddo ; enddo + else ; do j=js,je ; do i=is,ie + FrictWork_GME(i,j,k) = GV%H_to_RZ * G%IareaT(i,j) * ( & + ((str_xx_GME(i,j)*CS%dy2h(i,j) * ( & + (uh(I,j,k)*G%dxCu(I,j)*G%IdyCu(I,j)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)) & + - (uh(I-1,j,k)*G%dxCu(I-1,j)*G%IdyCu(I-1,j)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)) ) ) & + - (str_xx_GME(i,j)*CS%dx2h(i,j) * ( & + (vh(i,J,k)*G%dyCv(i,J)*G%IdxCv(i,J)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)) & + - (vh(i,J-1,k)*G%dyCv(i,J-1)*G%IdxCv(i,J-1)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)) ) )) & + + (0.25*(((str_xy_GME(I,J)*( & + (CS%dx2q(I,J)*((uh(I,j+1,k)*G%IareaCu(I,j+1)/(h_u(I,j+1)+h_neglect)) & + - (uh(I,j,k)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)))) & + + (CS%dy2q(I,J)*((vh(i+1,J,k)*G%IareaCv(i+1,J)/(h_v(i+1,J)+h_neglect)) & + - (vh(i,J,k)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)))) )) & + +(str_xy_GME(I-1,J-1)*( & + (CS%dx2q(I-1,J-1)*((uh(I-1,j,k)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)) & + - (uh(I-1,j-1,k)*G%IareaCu(I-1,j-1)/(h_u(I-1,j-1)+h_neglect)))) & + + (CS%dy2q(I-1,J-1)*((vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)) & + - (vh(i-1,J-1,k)*G%IareaCv(i-1,J-1)/(h_v(i-1,J-1)+h_neglect)))) )) ) & + +((str_xy_GME(I-1,J)*( & + (CS%dx2q(I-1,J)*((uh(I-1,j+1,k)*G%IareaCu(I-1,j+1)/(h_u(I-1,j+1)+h_neglect)) & + - (uh(I-1,j,k)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)))) & + + (CS%dy2q(I-1,J)*((vh(i,J,k)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)) & + - (vh(i-1,J,k)*G%IareaCv(i-1,J)/(h_v(i-1,J)+h_neglect)))) )) & + +(str_xy_GME(I,J-1)*( & + (CS%dx2q(I,J-1)*((uh(I,j,k)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)) & + - (uh(I,j-1,k)*G%IareaCu(I,j-1)/(h_u(I,j-1)+h_neglect)))) & + + (CS%dy2q(I,J-1)*((vh(i+1,J-1,k)*G%IareaCv(i+1,J-1)/(h_v(i+1,J-1)+h_neglect)) & + - (vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)))) )) ) )) ) + enddo ; enddo ; endif + endif + + if (skeb_use_frict) then ; do j=js,je ; do i=is,ie + ! Note that the sign convention is FrictWork < 0 means energy dissipation. + STOCH%skeb_diss(i,j,k) = STOCH%skeb_diss(i,j,k) - STOCH%skeb_frict_coef * & + FrictWork(i,j,k) / (GV%H_to_RZ * (h(i,j,k) + h_neglect)) enddo ; enddo ; endif ! Make a similar calculation as for FrictWork above but accumulating into @@ -1562,6 +2148,13 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, do j=js,je ; do i=is,ie MEKE%mom_src(i,j) = 0. enddo ; enddo + + if (allocated(MEKE%mom_src_bh)) then + do j=js,je ; do i=is,ie + MEKE%mom_src_bh(i,j) = 0. + enddo ; enddo + endif + if (allocated(MEKE%GME_snk)) then do j=js,je ; do i=is,ie MEKE%GME_snk(i,j) = 0. @@ -1573,9 +2166,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, FatH = 0.25*( (abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1))) ) 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%answers_2018) then + 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) .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. @@ -1593,36 +2186,30 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif endif - MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + GV%H_to_RZ * ( & - ((str_xx(i,j)-RoScl*bhstr_xx(i,j))*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & - -(str_xx(i,j)-RoScl*bhstr_xx(i,j))*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & - +0.25*(((str_xy(I,J)-RoScl*bhstr_xy(I,J))*( & - (u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J) & - +(v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J) ) & - +(str_xy(I-1,J-1)-RoScl*bhstr_xy(I-1,J-1))*( & - (u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1) & - +(v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1) )) & - +((str_xy(I-1,J)-RoScl*bhstr_xy(I-1,J))*( & - (u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J) & - +(v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J) ) & - +(str_xy(I,J-1)-RoScl*bhstr_xy(I,J-1))*( & - (u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1) & - +(v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1) )) ) ) + MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + (FrictWork(i,j,k) - RoScl*FrictWork_bh(i,j,k)) + + if (allocated(MEKE%mom_src_bh)) & + MEKE%mom_src_bh(i,j) = MEKE%mom_src_bh(i,j) & + + (FrictWork_bh(i,j,k) - RoScl * FrictWork_bh(i,j,k)) + enddo ; enddo + else + do j=js,je ; do i=is,ie + MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + FrictWork(i,j,k) enddo ; enddo - endif ! MEKE%backscatter_Ro_c - do j=js,je ; do i=is,ie - MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + FrictWork(i,j,k) - enddo ; enddo + if (allocated(MEKE%mom_src_bh)) then + do j=js,je ; do i=is,ie + MEKE%mom_src_bh(i,j) = MEKE%mom_src_bh(i,j) + FrictWork_bh(i,j,k) + enddo ; enddo + endif + endif ! MEKE%backscatter_Ro_c if (CS%use_GME .and. allocated(MEKE%GME_snk)) then do j=js,je ; do i=is,ie MEKE%GME_snk(i,j) = MEKE%GME_snk(i,j) + FrictWork_GME(i,j,k) enddo ; enddo endif - endif ! find_FrictWork and associated(mom_src) - enddo ! end of k loop ! Offer fields for diagnostic averaging. @@ -1631,27 +2218,46 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%id_diffu>0) call post_data(CS%id_diffu, diffu, CS%diag) if (CS%id_diffv>0) call post_data(CS%id_diffv, diffv, CS%diag) if (CS%id_FrictWork>0) call post_data(CS%id_FrictWork, FrictWork, CS%diag) - if (CS%id_FrictWork_GME>0) call post_data(CS%id_FrictWork_GME, FrictWork_GME, CS%diag) + if (CS%id_FrictWork_bh>0) call post_data(CS%id_FrictWork_bh, FrictWork_bh, CS%diag) if (CS%id_Ah_h>0) call post_data(CS%id_Ah_h, Ah_h, CS%diag) if (CS%id_grid_Re_Ah>0) call post_data(CS%id_grid_Re_Ah, grid_Re_Ah, CS%diag) if (CS%id_div_xx_h>0) call post_data(CS%id_div_xx_h, div_xx_h, CS%diag) if (CS%id_vort_xy_q>0) call post_data(CS%id_vort_xy_q, vort_xy_q, CS%diag) - if (CS%id_sh_xx_h>0) call post_data(CS%id_sh_xx_h, sh_xx_h, CS%diag) - if (CS%id_sh_xy_q>0) call post_data(CS%id_sh_xy_q, sh_xy_q, CS%diag) + if (CS%id_sh_xx_h>0) call post_data(CS%id_sh_xx_h, sh_xx_h, CS%diag) + if (CS%id_sh_xy_q>0) call post_data(CS%id_sh_xy_q, sh_xy_q, CS%diag) if (CS%id_Ah_q>0) call post_data(CS%id_Ah_q, Ah_q, CS%diag) if (CS%id_Kh_h>0) call post_data(CS%id_Kh_h, Kh_h, CS%diag) if (CS%id_grid_Re_Kh>0) call post_data(CS%id_grid_Re_Kh, grid_Re_Kh, CS%diag) if (CS%id_Kh_q>0) call post_data(CS%id_Kh_q, Kh_q, CS%diag) - if (CS%id_GME_coeff_h > 0) call post_data(CS%id_GME_coeff_h, GME_coeff_h, CS%diag) - if (CS%id_GME_coeff_q > 0) call post_data(CS%id_GME_coeff_q, GME_coeff_q, CS%diag) + if (CS%use_GME) then ! post barotropic tension and strain + if (CS%id_GME_coeff_h > 0) call post_data(CS%id_GME_coeff_h, GME_coeff_h, CS%diag) + if (CS%id_GME_coeff_q > 0) call post_data(CS%id_GME_coeff_q, GME_coeff_q, CS%diag) + if (CS%id_FrictWork_GME>0) call post_data(CS%id_FrictWork_GME, FrictWork_GME, CS%diag) + if (CS%id_dudx_bt > 0) call post_data(CS%id_dudx_bt, dudx_bt, CS%diag) + if (CS%id_dvdy_bt > 0) call post_data(CS%id_dvdy_bt, dvdy_bt, CS%diag) + if (CS%id_dudy_bt > 0) call post_data(CS%id_dudy_bt, dudy_bt, CS%diag) + if (CS%id_dvdx_bt > 0) call post_data(CS%id_dvdx_bt, dvdx_bt, CS%diag) + endif + if (CS%EY24_EBT_BS) then + if (CS%id_visc_limit_h>0) call post_data(CS%id_visc_limit_h, visc_limit_h, CS%diag) + if (CS%id_visc_limit_q>0) call post_data(CS%id_visc_limit_q, visc_limit_q, CS%diag) + if (CS%id_visc_limit_h_frac>0) call post_data(CS%id_visc_limit_h_frac, visc_limit_h_frac, CS%diag) + if (CS%id_visc_limit_q_frac>0) call post_data(CS%id_visc_limit_q_frac, visc_limit_q_frac, CS%diag) + if (CS%id_visc_limit_h_flag>0) call post_data(CS%id_visc_limit_h_flag, visc_limit_h_flag, CS%diag) + if (CS%id_visc_limit_q_flag>0) call post_data(CS%id_visc_limit_q_flag, visc_limit_q_flag, CS%diag) + if (CS%id_BS_coeff_h>0) call post_data(CS%id_BS_coeff_h, BS_coeff_h, CS%diag) + if (CS%id_BS_coeff_q>0) call post_data(CS%id_BS_coeff_q, BS_coeff_q, CS%diag) + endif if (CS%debug) then if (CS%Laplacian) then - call hchksum(Kh_h, "Kh_h", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T) - call Bchksum(Kh_q, "Kh_q", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T) + call hchksum(Kh_h, "Kh_h", G%HI, haloshift=1, unscale=US%L_to_m**2*US%s_to_T) + call Bchksum(Kh_q, "Kh_q", G%HI, haloshift=0, symmetric=.true., unscale=US%L_to_m**2*US%s_to_T) + endif + if (CS%biharmonic) then + call hchksum(Ah_h, "Ah_h", G%HI, haloshift=1, unscale=US%L_to_m**4*US%s_to_T) + call Bchksum(Ah_q, "Ah_q", G%HI, haloshift=0, symmetric=.true., unscale=US%L_to_m**4*US%s_to_T) endif - if (CS%biharmonic) call hchksum(Ah_h, "Ah_h", G%HI, haloshift=0, scale=US%L_to_m**4*US%s_to_T) - if (CS%biharmonic) call Bchksum(Ah_q, "Ah_q", G%HI, haloshift=0, scale=US%L_to_m**4*US%s_to_T) endif if (CS%id_FrictWorkIntz > 0) then @@ -1664,6 +2270,16 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, call post_data(CS%id_FrictWorkIntz, FrictWorkIntz, CS%diag) endif + if (CS%id_FrictWorkIntz_bh > 0) then + do j=js,je + do i=is,ie ; FrictWorkIntz_bh(i,j) = FrictWork_bh(i,j,1) ; enddo + do k=2,nz ; do i=is,ie + FrictWorkIntz_bh(i,j) = FrictWorkIntz_bh(i,j) + FrictWork_bh(i,j,k) + enddo ; enddo + enddo + call post_data(CS%id_FrictWorkIntz_bh, FrictWorkIntz_bh, CS%diag) + endif + if (present(ADp)) then ! Diagnostics of the fractional thicknesses times momentum budget terms ! 3D diagnostics of hf_diffu(diffv) are commented because there is no clarity on proper remapping grid option. @@ -1688,11 +2304,16 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%id_diffv_visc_rem > 0) call post_product_v(CS%id_diffv_visc_rem, diffv, ADp%visc_rem_v, G, nz, CS%diag) endif + if (CS%use_ZB2020) then + call ZB2020_lateral_stress(u, v, h, diffu, diffv, G, GV, CS%ZB2020, & + CS%dx2h, CS%dy2h, CS%dx2q, CS%dy2q) + endif + end subroutine horizontal_viscosity -!> Allocates space for and calculates static variables used by horizontal_viscosity(). +!> Allocates space for and calculates static variables used by horizontal_viscosity. !! hor_visc_init calculates and stores the values of a number of metric functions that -!! are used in horizontal_viscosity(). +!! are used in horizontal_viscosity. subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) type(time_type), intent(in) :: Time !< Current model time. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. @@ -1701,13 +2322,12 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time !! parameters. type(diag_ctrl), target, intent(inout) :: diag !< Structure to regulate diagnostic output. - type(hor_visc_CS), intent(inout) :: CS !< Horizontal viscosity control struct + type(hor_visc_CS), intent(inout) :: CS !< Horizontal viscosity control structure type(accel_diag_ptrs), intent(in), optional :: ADp !< Acceleration diagnostics - real, dimension(SZIB_(G),SZJ_(G)) :: u0u, u0v - real, dimension(SZI_(G),SZJB_(G)) :: v0u, v0v - ! u0v is the Laplacian sensitivities to the v velocities - ! at u points [L-2 ~> m-2], with u0u, v0u, and v0v defined similarly. + ! u0v is the Laplacian sensitivities to the v velocities at u points, with u0u, v0u, and v0v defined analogously. + real, dimension(SZIB_(G),SZJ_(G)) :: u0u, u0v ! Laplacian sensitivities at u points [L-2 ~> m-2] + real, dimension(SZI_(G),SZJB_(G)) :: v0u, v0v ! Laplacian sensitivities at v points [L-2 ~> m-2] real :: grid_sp_h2 ! Harmonic mean of the squares of the grid [L2 ~> m2] real :: grid_sp_h3 ! Harmonic mean of the squares of the grid^(3/2) [L3 ~> m3] real :: grid_sp_q2 ! spacings at h and q points [L2 ~> m2] @@ -1724,31 +2344,35 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) ! grid spacing, to limit biharmonic viscosity real :: Kh ! Lapacian horizontal viscosity [L2 T-1 ~> m2 s-1] real :: Ah ! biharmonic horizontal viscosity [L4 T-1 ~> m4 s-1] - real :: Kh_vel_scale ! this speed [L T-1 ~> m s-1] times grid spacing gives Lap visc - real :: Ah_vel_scale ! this speed [L T-1 ~> m s-1] times grid spacing cubed gives bih visc + real :: Kh_vel_scale ! this speed [L T-1 ~> m s-1] times grid spacing gives Laplacian viscosity + real :: Ah_vel_scale ! this speed [L T-1 ~> m s-1] times grid spacing cubed gives biharmonic viscosity real :: Ah_time_scale ! damping time-scale for biharmonic visc [T ~> s] - real :: Smag_Lap_const ! nondimensional Laplacian Smagorinsky constant - real :: Smag_bi_const ! nondimensional biharmonic Smagorinsky constant - real :: Leith_Lap_const ! nondimensional Laplacian Leith constant - real :: Leith_bi_const ! nondimensional biharmonic Leith constant + real :: Smag_Lap_const ! nondimensional Laplacian Smagorinsky constant [nondim] + real :: Smag_bi_const ! nondimensional biharmonic Smagorinsky constant [nondim] + real :: Leith_Lap_const ! nondimensional Laplacian Leith constant [nondim] + real :: Leith_bi_const ! nondimensional biharmonic Leith constant [nondim] real :: dt ! The dynamics time step [T ~> s] real :: Idt ! The inverse of dt [T-1 ~> s-1] - real :: denom ! work variable; the denominator of a fraction - real :: maxvel ! largest permitted velocity components [m s-1] + real :: denom ! work variable; the denominator of a fraction [L-2 ~> m-2] or [L-4 ~> m-4] + real :: maxvel ! largest permitted velocity components [L T-1 ~> m s-1] real :: bound_Cor_vel ! grid-scale velocity variations at which value ! the quadratically varying biharmonic viscosity ! balances Coriolis acceleration [L T-1 ~> m s-1] real :: Kh_sin_lat ! Amplitude of latitudinally dependent viscosity [L2 T-1 ~> m2 s-1] - real :: Kh_pwr_of_sine ! Power used to raise sin(lat) when using Kh_sin_lat + real :: Kh_pwr_of_sine ! Power used to raise sin(lat) when using Kh_sin_lat [nondim] logical :: bound_Cor_def ! parameter setting of BOUND_CORIOLIS 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. - logical :: default_2018_answers - character(len=64) :: inputdir, filename - real :: deg2rad ! Converts degrees to radians - real :: slat_fn ! sin(lat)**Kh_pwr_of_sine - real :: aniso_grid_dir(2) ! Vector (n1,n2) for anisotropic direction + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. + 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 + real :: deg2rad ! Converts degrees to radians [radians degree-1] + real :: slat_fn ! sin(lat)**Kh_pwr_of_sine [nondim] + real :: aniso_grid_dir(2) ! Vector (n1,n2) for anisotropic direction [nondim] integer :: aniso_mode ! Selects the mode for setting the anisotropic direction integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -1761,21 +2385,50 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + ! init control structure + call ZB2020_init(Time, G, GV, US, param_file, diag, CS%ZB2020, CS%use_ZB2020) + CS%initialized = .true. CS%diag => diag ! Read parameters and write them to the model log. call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "USE_CIRCULATION_IN_HORVISC", CS%use_circulation, & + "Use circulation theorem to compute vorticity in horvisc module (for ZB20 or Leith)", & + default=.False.) + ! All parameters are read in all cases to enable parameter spelling checks. - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) - call get_param(param_file, mdl, "HOR_VISC_2018_ANSWERS", CS%answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) + 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 between 20190102 and 20241201 recover the "//& + "answers from the end of 2018, while higher values use updated and more robust "//& + "forms of the same expressions.", & + default=default_answer_date, do_not_log=(.not.GV%Boussinesq).or.(backscatter_Ro_c==0.0)) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20241201) + call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) + call get_param(param_file, mdl, "USE_CONT_THICKNESS", CS%use_cont_thick, & + "If true, use thickness at velocity points from continuity solver. This option "//& + "currently only works with split mode.", default=.false.) + call get_param(param_file, mdl, "USE_CONT_THICKNESS_BUG", CS%use_cont_thick_bug, & + "If true, retain an answer-changing halo update bug when "//& + "USE_CONT_THICKNESS=True. This is not recommended.", & + default=.false., do_not_log=.not.CS%use_cont_thick) + call get_param(param_file, mdl, "LAPLACIAN", CS%Laplacian, & "If true, use a Laplacian horizontal viscosity.", & default=.false.) @@ -1817,49 +2470,25 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "If true, use a Leith nonlinear eddy viscosity.", & default=.false., do_not_log=.not.CS%Laplacian) if (.not.CS%Laplacian) CS%Leith_Kh = .false. - ! This call duplicates one that occurs 26 lines later, and is probably unneccessary. - call get_param(param_file, mdl, "MODIFIED_LEITH", CS%Modified_Leith, & - "If true, add a term to Leith viscosity which is "//& - "proportional to the gradient of divergence.", & - default=.false., do_not_log=.not.CS%Laplacian) !### (.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, "LEITH_LAP_CONST", Leith_Lap_const, & + "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, "RES_SCALE_MEKE_VISC", CS%res_scale_MEKE, & "If true, the viscosity contribution from MEKE is scaled by "//& "the resolution function.", default=.false., & do_not_log=.not.(CS%Laplacian.and.use_MEKE)) if (.not.(CS%Laplacian.and.use_MEKE)) CS%res_scale_MEKE = .false. - call get_param(param_file, mdl, "LEITH_LAP_CONST", Leith_Lap_const, & - "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_QG_LEITH_VISC", CS%use_QG_Leith_visc, & - "If true, use QG Leith nonlinear eddy viscosity.", & - default=.false., do_not_log=.not.CS%Leith_Kh) - if (CS%use_QG_Leith_visc .and. .not. CS%Leith_Kh) call MOM_error(FATAL, & - "MOM_hor_visc.F90, hor_visc_init:"//& - "LEITH_KH must be True when USE_QG_LEITH_VISC=True.") - - !### The following two get_param_calls need to occur after Leith_Ah is read, but for now it replicates prior code. - CS%Leith_Ah = .false. - call get_param(param_file, mdl, "USE_BETA_IN_LEITH", CS%use_beta_in_Leith, & - "If true, include the beta term in the Leith nonlinear eddy viscosity.", & - default=CS%Leith_Kh, do_not_log=.not.(CS%Leith_Kh .or. CS%Leith_Ah) ) - call get_param(param_file, mdl, "MODIFIED_LEITH", CS%modified_Leith, & - "If true, add a term to Leith viscosity which is "//& - "proportional to the gradient of divergence.", & - default=.false., do_not_log=.not.(CS%Leith_Kh .or. CS%Leith_Ah) ) - call get_param(param_file, mdl, "BOUND_KH", CS%bound_Kh, & "If true, the Laplacian coefficient is locally limited "//& "to be stable.", default=.true., do_not_log=.not.CS%Laplacian) - call get_param(param_file, mdl, "BETTER_BOUND_KH", CS%better_bound_Kh, & - "If true, the Laplacian coefficient is locally limited "//& - "to be stable with a better bounding than just BOUND_KH.", & - default=CS%bound_Kh, do_not_log=.not.CS%Laplacian) + call get_param(param_file, mdl, "EY24_EBT_BS", CS%EY24_EBT_BS, & + "If true, use the backscatter scheme (EBT mode with kill switch) "//& + "developed by Yankovsky et al. (2024). ", & + default=.false., do_not_log=.not.CS%Laplacian) if (.not.CS%Laplacian) CS%bound_Kh = .false. - if (.not.CS%Laplacian) CS%better_bound_Kh = .false. + if (.not.(CS%Laplacian.and.use_MEKE)) CS%EY24_EBT_BS = .false. call get_param(param_file, mdl, "ANISOTROPIC_VISCOSITY", CS%anisotropic, & "If true, allow anistropic viscosity in the Laplacian "//& "horizontal viscosity.", default=.false., & @@ -1875,24 +2504,24 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) units="m2 s-1", default=0.0, scale=US%m_to_L**2*US%T_to_s, & do_not_log=.not.CS%anisotropic) call get_param(param_file, mdl, "ANISOTROPIC_MODE", aniso_mode, & - "Selects the mode for setting the direction of anistropy.\n"//& + "Selects the mode for setting the direction of anisotropy.\n"//& "\t 0 - Points along the grid i-direction.\n"//& "\t 1 - Points towards East.\n"//& "\t 2 - Points along the flow direction, U/|U|.", & default=0, do_not_log=.not.CS%anisotropic) if (aniso_mode == 0) then call get_param(param_file, mdl, "ANISO_GRID_DIR", aniso_grid_dir, & - "The vector pointing in the direction of anistropy for horizontal viscosity. "//& + "The vector pointing in the direction of anisotropy for horizontal viscosity. "//& "n1,n2 are the i,j components relative to the grid.", & units="nondim", fail_if_missing=CS%anisotropic, do_not_log=.not.CS%anisotropic) elseif (aniso_mode == 1) then call get_param(param_file, mdl, "ANISO_GRID_DIR", aniso_grid_dir, & - "The vector pointing in the direction of anistropy for horizontal viscosity. "//& + "The vector pointing in the direction of anisotropy for horizontal viscosity. "//& "n1,n2 are the i,j components relative to the spherical coordinates.", & units="nondim", fail_if_missing=CS%anisotropic, do_not_log=.not.CS%anisotropic) else call get_param(param_file, mdl, "ANISO_GRID_DIR", aniso_grid_dir, & - "The vector pointing in the direction of anistropy for horizontal viscosity.", & + "The vector pointing in the direction of anisotropy for horizontal viscosity.", & units="nondim", fail_if_missing=.false., do_not_log=.true.) endif @@ -1924,25 +2553,54 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "If true, use a biharmonic Leith nonlinear eddy "//& "viscosity.", default=.false., do_not_log=.not.CS%biharmonic) if (.not.CS%biharmonic) CS%Leith_Ah = .false. + call get_param(param_file, mdl, "USE_LEITHY", CS%use_Leithy, & + "If true, use a biharmonic Leith nonlinear eddy "//& + "viscosity together with a harmonic backscatter.", & + default=.false.) call get_param(param_file, mdl, "BOUND_AH", CS%bound_Ah, & "If true, the biharmonic coefficient is locally limited "//& "to be stable.", default=.true., do_not_log=.not.CS%biharmonic) - call get_param(param_file, mdl, "BETTER_BOUND_AH", CS%better_bound_Ah, & - "If true, the biharmonic coefficient is locally limited "//& - "to be stable with a better bounding than just BOUND_AH.", & - default=CS%bound_Ah, do_not_log=.not.CS%biharmonic) if (.not.CS%biharmonic) CS%bound_Ah = .false. - if (.not.CS%biharmonic) CS%better_bound_Ah = .false. call get_param(param_file, mdl, "RE_AH", CS%Re_Ah, & "If nonzero, the biharmonic coefficient is scaled "//& "so that the biharmonic Reynolds number is equal to this.", & units="nondim", default=0.0, do_not_log=.not.CS%biharmonic) + call get_param(param_file, mdl, "BACKSCATTER_UNDERBOUND", CS%backscatter_underbound, & + "If true, the bounds on the biharmonic viscosity are allowed to "//& + "increase where the Laplacian viscosity is negative (due to backscatter "//& + "parameterizations) beyond the largest timestep-dependent stable values of "//& + "biharmonic viscosity when no Laplacian viscosity is applied. The default "//& + "is true for historical reasons, but this option probably should not be used "//& + "because it can contribute to numerical instabilities.", & + default=.false., do_not_log=.not.((CS%bound_Kh).and.(CS%bound_Ah))) + call get_param(param_file, mdl, "SMAG_BI_CONST",Smag_bi_const, & "The nondimensional biharmonic Smagorinsky constant, "//& "typically 0.015 - 0.06.", units="nondim", default=0.0, & fail_if_missing=CS%Smagorinsky_Ah, do_not_log=.not.CS%Smagorinsky_Ah) + call get_param(param_file, mdl, "USE_BETA_IN_LEITH", CS%use_beta_in_Leith, & + "If true, include the beta term in the Leith nonlinear eddy viscosity.", & + default=CS%Leith_Kh, do_not_log=.not.(CS%Leith_Kh .or. CS%Leith_Ah) ) + call get_param(param_file, mdl, "MODIFIED_LEITH", CS%modified_Leith, & + "If true, add a term to Leith viscosity which is "//& + "proportional to the gradient of divergence.", & + default=.false., do_not_log=.not.(CS%Leith_Kh .or. CS%Leith_Ah) ) + call get_param(param_file, mdl, "USE_QG_LEITH_VISC", CS%use_QG_Leith_visc, & + "If true, use QG Leith nonlinear eddy viscosity.", & + default=.false., do_not_log=.not.(CS%Leith_Kh .or. CS%Leith_Ah) ) +! if (CS%use_QG_Leith_visc) then +! call MOM_error(FATAL, "USE_QG_LEITH_VISC=True activates code that is a work-in-progress and "//& +! "should not be used until a number of bugs are fixed. Specifically it does not "//& +! "reproduce across PE count or layout, and may use arrays that have not been properly "//& +! "set or allocated. See github.com/mom-ocean/MOM6/issues/1590 for a discussion.") +! endif + if (CS%use_QG_Leith_visc .and. .not. (CS%Leith_Kh .or. CS%Leith_Ah) ) then + call MOM_error(FATAL, "MOM_hor_visc.F90, hor_visc_init: "//& + "LEITH_KH or LEITH_AH must be True when USE_QG_LEITH_VISC=True.") + endif + call get_param(param_file, mdl, "BOUND_CORIOLIS", bound_Cor_def, default=.false.) call get_param(param_file, mdl, "BOUND_CORIOLIS_BIHARM", CS%bound_Coriolis, & "If true use a viscosity that increases with the square "//& @@ -1953,19 +2611,19 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "value of BOUND_CORIOLIS (or false).", default=bound_Cor_def, & do_not_log=.not.CS%Smagorinsky_Ah) if (.not.CS%Smagorinsky_Ah) CS%bound_Coriolis = .false. - call get_param(param_file, mdl, "MAXVEL", maxvel, default=3.0e8) + call get_param(param_file, mdl, "MAXVEL", maxvel, & + units="m s-1", default=3.0e8, scale=US%m_s_to_L_T) call get_param(param_file, mdl, "BOUND_CORIOLIS_VEL", bound_Cor_vel, & "The velocity scale at which BOUND_CORIOLIS_BIHARM causes "//& "the biharmonic drag to have comparable magnitude to the "//& "Coriolis acceleration. The default is set by MAXVEL.", & - units="m s-1", default=maxvel, scale=US%m_s_to_L_T, & + units="m s-1", default=maxvel*US%L_T_to_m_s, scale=US%m_s_to_L_T, & do_not_log=.not.(CS%Smagorinsky_Ah .and. CS%bound_Coriolis)) - call get_param(param_file, mdl, "LEITH_BI_CONST", Leith_bi_const, & "The nondimensional biharmonic Leith constant, "//& "typical values are thus far undetermined.", units="nondim", default=0.0, & - fail_if_missing=CS%Leith_Ah, do_not_log=.not.CS%Leith_Ah) - + fail_if_missing=(CS%Leith_Ah .or. CS%use_Leithy), & + do_not_log=.not.(CS%Leith_Ah .or. CS%use_Leithy)) call get_param(param_file, mdl, "USE_LAND_MASK_FOR_HVISC", CS%use_land_mask, & "If true, use the land mask for the computation of thicknesses "//& "at velocity locations. This eliminates the dependence on arbitrary "//& @@ -1974,7 +2632,11 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "The nondimensional coefficient of the ratio of the "//& "viscosity bounds to the theoretical maximum for "//& "stability without considering other terms.", units="nondim", & - default=0.8, do_not_log=.not.(CS%better_bound_Ah .or. CS%better_bound_Kh)) + default=0.8, do_not_log=.not.(CS%bound_Ah .or. CS%bound_Kh)) + call get_param(param_file, mdl, "KILL_SWITCH_COEF", CS%KS_coef, & + "A nondimensional coefficient on the biharmonic viscosity that "// & + "sets the kill switch for backscatter. Default is 1.0.", units="nondim", & + default=1.0, do_not_log=.not.(CS%EY24_EBT_BS)) call get_param(param_file, mdl, "NOSLIP", CS%no_slip, & "If true, no slip boundary conditions are used; otherwise "//& "free slip boundary conditions are assumed. The "//& @@ -1985,30 +2647,58 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) call get_param(param_file, mdl, "USE_KH_BG_2D", CS%use_Kh_bg_2d, & "If true, read a file containing 2-d background harmonic "//& "viscosities. The final viscosity is the maximum of the other "//& - "terms and this background value.", default=.false.) ! ###do_not_log=.not.CS%Laplacian? + "terms and this background value.", default=.false., do_not_log=.not.CS%Laplacian) + if (.not.CS%Laplacian) CS%use_Kh_bg_2d = .false. call get_param(param_file, mdl, "KH_BG_2D_BUG", CS%Kh_bg_2d_bug, & "If true, retain an answer-changing horizontal indexing bug in setting "//& - "the corner-point viscosities when USE_KH_BG_2D=True. This is"//& + "the corner-point viscosities when USE_KH_BG_2D=True. This is "//& "not recommended.", default=.false., do_not_log=.not.CS%use_Kh_bg_2d) - + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. + call get_param(param_file, mdl, "FRICTWORK_BUG", CS%FrictWork_bug, & + "If true, retain an answer-changing bug in calculating the FrictWork, "//& + "which cancels the h in thickness flux and the h at velocity point. This is "//& + "not recommended.", default=.false.) + call get_param(param_file, mdl, "OBC_SPECIFIED_STRAIN_BUG", CS%OBC_strain_bug, & + "If true, recover a bug that specified shear strain option at open boundaries "//& + "cannot be applied.", default=.true.) call get_param(param_file, mdl, "USE_GME", CS%use_GME, & "If true, use the GM+E backscatter scheme in association \n"//& "with the Gent and McWilliams parameterization.", default=.false.) call get_param(param_file, mdl, "SPLIT", split, & "Use the split time stepping if true.", default=.true., do_not_log=.true.) + if (CS%use_Leithy) then + if (.not.(CS%biharmonic .and. CS%Laplacian)) then + call MOM_error(FATAL, "MOM_hor_visc.F90, hor_visc_init: "//& + "LAPLACIAN and BIHARMONIC must both be True when USE_LEITHY=True.") + endif + endif + call get_param(param_file, mdl, "LEITHY_CK", CS%c_K, & + "Fraction of biharmonic dissipation that gets backscattered, "//& + "in Leith+E.", units="nondim", default=1.0, do_not_log=.not.CS%use_Leithy) + call get_param(param_file, mdl, "SMOOTH_AH", CS%smooth_Ah, & + "If true, Ah and m_leithy are smoothed within Leith+E. This requires "//& + "lots of blocking communications, which can be expensive", & + default=.true., do_not_log=.not.CS%use_Leithy) + if (CS%use_GME .and. .not.split) call MOM_error(FATAL,"ERROR: Currently, USE_GME = True "// & "cannot be used with SPLIT=False.") - call get_param(param_file, mdl, "GME_H0", CS%GME_h0, & - "The strength of GME tapers quadratically to zero when the bathymetric "//& - "depth is shallower than GME_H0.", & - units="m", scale=US%m_to_Z, default=1000.0, do_not_log=.not.CS%use_GME) - call get_param(param_file, mdl, "GME_EFFICIENCY", CS%GME_efficiency, & - "The nondimensional prefactor multiplying the GME coefficient.", & - units="nondim", default=1.0, do_not_log=.not.CS%use_GME) - call get_param(param_file, mdl, "GME_LIMITER", CS%GME_limiter, & - "The absolute maximum value the GME coefficient is allowed to take.", & - units="m2 s-1", scale=US%m_to_L**2*US%T_to_s, default=1.0e7, & - do_not_log=.not.CS%use_GME) + + if (CS%use_GME) then + call get_param(param_file, mdl, "GME_NUM_SMOOTHINGS", CS%num_smooth_gme, & + "Number of smoothing passes for the GME fluxes.", & + default=1) + call get_param(param_file, mdl, "GME_H0", CS%GME_h0, & + "The strength of GME tapers quadratically to zero when the bathymetric "//& + "depth is shallower than GME_H0.", & + units="m", scale=GV%m_to_H, default=1000.0) + call get_param(param_file, mdl, "GME_EFFICIENCY", CS%GME_efficiency, & + "The nondimensional prefactor multiplying the GME coefficient.", & + units="nondim", default=1.0) + call get_param(param_file, mdl, "GME_LIMITER", CS%GME_limiter, & + "The absolute maximum value the GME coefficient is allowed to take.", & + units="m2 s-1", scale=US%m_to_L**2*US%T_to_s, default=1.0e7) + endif if (CS%Laplacian .or. CS%biharmonic) then call get_param(param_file, mdl, "DT", dt, & @@ -2016,6 +2706,11 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) fail_if_missing=.true.) Idt = 1.0 / dt endif + call get_param(param_file, mdl, "KILL_SWITCH_TIMESCALE", CS%KS_timescale, & + "A timescale for computing the CFL limit for viscosity "// & + "that determines when backscatter is shut off. Default is DT.", & + default= dt , units="s", scale=US%s_to_T, do_not_log=.not.(CS%EY24_EBT_BS)) + if (CS%no_slip .and. CS%biharmonic) & call MOM_error(FATAL,"ERROR: NOSLIP and BIHARMONIC cannot be defined "// & "at the same time in MOM.") @@ -2039,17 +2734,17 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) ALLOC_(CS%grid_sp_h2(isd:ied,jsd:jed)) ; CS%grid_sp_h2(:,:) = 0.0 ALLOC_(CS%Kh_bg_xx(isd:ied,jsd:jed)) ; CS%Kh_bg_xx(:,:) = 0.0 ALLOC_(CS%Kh_bg_xy(IsdB:IedB,JsdB:JedB)) ; CS%Kh_bg_xy(:,:) = 0.0 - if (CS%bound_Kh .or. CS%better_bound_Kh) then - ALLOC_(CS%Kh_Max_xx(Isd:Ied,Jsd:Jed)) ; CS%Kh_Max_xx(:,:) = 0.0 - ALLOC_(CS%Kh_Max_xy(IsdB:IedB,JsdB:JedB)) ; CS%Kh_Max_xy(:,:) = 0.0 + if (CS%bound_Kh .or. CS%EY24_EBT_BS) then + allocate(CS%Kh_Max_xx(Isd:Ied,Jsd:Jed), source=0.0) + allocate(CS%Kh_Max_xy(IsdB:IedB,JsdB:JedB), source=0.0) endif - if (CS%Smagorinsky_Kh) then - ALLOC_(CS%Laplac2_const_xx(isd:ied,jsd:jed)) ; CS%Laplac2_const_xx(:,:) = 0.0 - ALLOC_(CS%Laplac2_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%Laplac2_const_xy(:,:) = 0.0 + if (CS%Smagorinsky_Kh .or. CS%EY24_EBT_BS) then + allocate(CS%Laplac2_const_xx(isd:ied,jsd:jed), source=0.0) + allocate(CS%Laplac2_const_xy(IsdB:IedB,JsdB:JedB), source=0.0) endif if (CS%Leith_Kh) then - ALLOC_(CS%Laplac3_const_xx(isd:ied,jsd:jed)) ; CS%Laplac3_const_xx(:,:) = 0.0 - ALLOC_(CS%Laplac3_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%Laplac3_const_xy(:,:) = 0.0 + allocate(CS%Laplac3_const_xx(isd:ied,jsd:jed), source=0.0) + allocate(CS%Laplac3_const_xy(IsdB:IedB,JsdB:JedB), source=0.0) endif endif ALLOC_(CS%reduction_xx(isd:ied,jsd:jed)) ; CS%reduction_xx(:,:) = 0.0 @@ -2057,10 +2752,10 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) CS%dynamic_aniso = .false. if (CS%anisotropic) then - ALLOC_(CS%n1n2_h(isd:ied,jsd:jed)) ; CS%n1n2_h(:,:) = 0.0 - ALLOC_(CS%n1n1_m_n2n2_h(isd:ied,jsd:jed)) ; CS%n1n1_m_n2n2_h(:,:) = 0.0 - ALLOC_(CS%n1n2_q(IsdB:IedB,JsdB:JedB)) ; CS%n1n2_q(:,:) = 0.0 - ALLOC_(CS%n1n1_m_n2n2_q(IsdB:IedB,JsdB:JedB)) ; CS%n1n1_m_n2n2_q(:,:) = 0.0 + allocate(CS%n1n2_h(isd:ied,jsd:jed), source=0.0) + allocate(CS%n1n1_m_n2n2_h(isd:ied,jsd:jed), source=0.0) + allocate(CS%n1n2_q(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%n1n1_m_n2n2_q(IsdB:IedB,JsdB:JedB), source=0.0) select case (aniso_mode) case (0) call align_aniso_tensor_to_grid(CS, aniso_grid_dir(1), aniso_grid_dir(2)) @@ -2077,11 +2772,15 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) call get_param(param_file, mdl, "KH_BG_2D_FILENAME", filename, & 'The filename containing a 2d map of "Kh".', & default='KH_background_2d.nc', do_not_log=.not.CS%use_Kh_bg_2d) + call get_param(param_file, mdl, "KH_BG_2D_VARNAME", Kh_var, & + 'The name in the input file of the horizontal viscosity variable.', & + default='Kh', do_not_log=.not.CS%use_Kh_bg_2d) + if (CS%use_Kh_bg_2d) then call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) - ALLOC_(CS%Kh_bg_2d(isd:ied,jsd:jed)) ; CS%Kh_bg_2d(:,:) = 0.0 - call MOM_read_data(trim(inputdir)//trim(filename), 'Kh', CS%Kh_bg_2d, & + allocate(CS%Kh_bg_2d(isd:ied,jsd:jed), source=0.0) + call MOM_read_data(trim(inputdir)//trim(filename), Kh_var, CS%Kh_bg_2d, & G%domain, timelevel=1, scale=US%m_to_L**2*US%T_to_s) call pass_var(CS%Kh_bg_2d, G%domain) endif @@ -2093,32 +2792,57 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) ALLOC_(CS%Ah_bg_xx(isd:ied,jsd:jed)) ; CS%Ah_bg_xx(:,:) = 0.0 ALLOC_(CS%Ah_bg_xy(IsdB:IedB,JsdB:JedB)) ; CS%Ah_bg_xy(:,:) = 0.0 ALLOC_(CS%grid_sp_h3(isd:ied,jsd:jed)) ; CS%grid_sp_h3(:,:) = 0.0 - if (CS%bound_Ah .or. CS%better_bound_Ah) then - ALLOC_(CS%Ah_Max_xx(isd:ied,jsd:jed)) ; CS%Ah_Max_xx(:,:) = 0.0 - ALLOC_(CS%Ah_Max_xy(IsdB:IedB,JsdB:JedB)) ; CS%Ah_Max_xy(:,:) = 0.0 + if (CS%bound_Ah) then + allocate(CS%Ah_Max_xx(isd:ied,jsd:jed), source=0.0) + allocate(CS%Ah_Max_xy(IsdB:IedB,JsdB:JedB), source=0.0) + endif + if (CS%EY24_EBT_BS) then + allocate(CS%Ah_Max_xx_KS(isd:ied,jsd:jed), source=0.0) + allocate(CS%Ah_Max_xy_KS(IsdB:IedB,JsdB:JedB), source=0.0) endif if (CS%Smagorinsky_Ah) then - ALLOC_(CS%Biharm_const_xx(isd:ied,jsd:jed)) ; CS%Biharm_const_xx(:,:) = 0.0 - ALLOC_(CS%Biharm_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%Biharm_const_xy(:,:) = 0.0 + allocate(CS%Biharm_const_xx(isd:ied,jsd:jed), source=0.0) + allocate(CS%Biharm_const_xy(IsdB:IedB,JsdB:JedB), source=0.0) if (CS%bound_Coriolis) then - ALLOC_(CS%Biharm_const2_xx(isd:ied,jsd:jed)) ; CS%Biharm_const2_xx(:,:) = 0.0 - ALLOC_(CS%Biharm_const2_xy(IsdB:IedB,JsdB:JedB)) ; CS%Biharm_const2_xy(:,:) = 0.0 + allocate(CS%Biharm_const2_xx(isd:ied,jsd:jed), source=0.0) + allocate(CS%Biharm_const2_xy(IsdB:IedB,JsdB:JedB), source=0.0) endif endif - if (CS%Leith_Ah) then - ALLOC_(CS%biharm6_const_xx(isd:ied,jsd:jed)) ; CS%biharm6_const_xx(:,:) = 0.0 - ALLOC_(CS%biharm6_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%biharm6_const_xy(:,:) = 0.0 + if ((CS%Leith_Ah) .or. (CS%use_Leithy)) then + allocate(CS%biharm6_const_xx(isd:ied,jsd:jed), source=0.0) + allocate(CS%biharm6_const_xy(IsdB:IedB,JsdB:JedB), source=0.0) + endif + if (CS%use_Leithy) then + allocate(CS%m_const_leithy(isd:ied,jsd:jed), source=0.0) + allocate(CS%m_leithy_max(isd:ied,jsd:jed), source=0.0) endif if (CS%Re_Ah > 0.0) then - ALLOC_(CS%Re_Ah_const_xx(isd:ied,jsd:jed)); CS%Re_Ah_const_xx(:,:) = 0.0 - ALLOC_(CS%Re_Ah_const_xy(IsdB:IedB,JsdB:JedB)); CS%Re_Ah_const_xy(:,:) = 0.0 + allocate(CS%Re_Ah_const_xx(isd:ied,jsd:jed), source=0.0) + allocate(CS%Re_Ah_const_xy(IsdB:IedB,JsdB:JedB), source=0.0) endif endif do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 CS%dx2q(I,J) = G%dxBu(I,J)*G%dxBu(I,J) ; CS%dy2q(I,J) = G%dyBu(I,J)*G%dyBu(I,J) - CS%DX_dyBu(I,J) = G%dxBu(I,J)*G%IdyBu(I,J) ; CS%DY_dxBu(I,J) = G%dyBu(I,J)*G%IdxBu(I,J) enddo ; enddo - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + + if (((CS%Leith_Kh) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) .and. & + ((G%isc-G%isd < 3) .or. (G%isc-G%isd < 3))) call MOM_error(FATAL, & + "The minimum halo size is 3 when a Leith viscosity is being used.") + if (CS%use_Leithy) then + do J=js-3,Jeq+2 ; do I=is-3,Ieq+2 + CS%DX_dyBu(I,J) = G%dxBu(I,J)*G%IdyBu(I,J) ; CS%DY_dxBu(I,J) = G%dyBu(I,J)*G%IdxBu(I,J) + enddo ; enddo + elseif ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + CS%DX_dyBu(I,J) = G%dxBu(I,J)*G%IdyBu(I,J) ; CS%DY_dxBu(I,J) = G%dyBu(I,J)*G%IdxBu(I,J) + enddo ; enddo + else + do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + CS%DX_dyBu(I,J) = G%dxBu(I,J)*G%IdyBu(I,J) ; CS%DY_dxBu(I,J) = G%dyBu(I,J)*G%IdxBu(I,J) + enddo ; enddo + endif + + do j=js-2,Jeq+2 ; do i=is-2,Ieq+2 CS%dx2h(i,j) = G%dxT(i,j)*G%dxT(i,j) ; CS%dy2h(i,j) = G%dyT(i,j)*G%dyT(i,j) CS%DX_dyT(i,j) = G%dxT(i,j)*G%IdyT(i,j) ; CS%DY_dxT(i,j) = G%dyT(i,j)*G%IdxT(i,j) enddo ; enddo @@ -2159,7 +2883,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) ! Calculate and store the background viscosity at h-points min_grid_sp_h2 = huge(1.) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js-1,Jeq+1 ; do i=is-1,Ieq+1 ! Static factors in the Smagorinsky and Leith schemes grid_sp_h2 = (2.0*CS%dx2h(i,j)*CS%dy2h(i,j)) / (CS%dx2h(i,j) + CS%dy2h(i,j)) CS%grid_sp_h2(i,j) = grid_sp_h2 @@ -2175,11 +2899,6 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) slat_fn = abs( sin( deg2rad * G%geoLatT(i,j) ) ) ** Kh_pwr_of_sine CS%Kh_bg_xx(i,j) = MAX(Kh_sin_lat * slat_fn, CS%Kh_bg_xx(i,j)) endif - if (CS%bound_Kh .and. .not.CS%better_bound_Kh) then - ! Limit the background viscosity to be numerically stable - CS%Kh_Max_xx(i,j) = Kh_Limit * grid_sp_h2 - CS%Kh_bg_xx(i,j) = MIN(CS%Kh_bg_xx(i,j), CS%Kh_Max_xx(i,j)) - endif min_grid_sp_h2 = min(grid_sp_h2, min_grid_sp_h2) enddo ; enddo call min_across_PEs(min_grid_sp_h2) @@ -2210,31 +2929,26 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) slat_fn = abs( sin( deg2rad * G%geoLatBu(I,J) ) ) ** Kh_pwr_of_sine CS%Kh_bg_xy(I,J) = MAX(Kh_sin_lat * slat_fn, CS%Kh_bg_xy(I,J)) endif - if (CS%bound_Kh .and. .not.CS%better_bound_Kh) then - ! Limit the background viscosity to be numerically stable - CS%Kh_Max_xy(I,J) = Kh_Limit * grid_sp_q2 - CS%Kh_bg_xy(I,J) = MIN(CS%Kh_bg_xy(I,J), CS%Kh_Max_xy(I,J)) - endif enddo ; enddo endif if (CS%biharmonic) then - do j=js-1,Jeq+1 ; do I=Isq-1,Ieq+1 + do j=js-1,Jeq+1 ; do I=is-2,Ieq+1 CS%Idx2dyCu(I,j) = (G%IdxCu(I,j)*G%IdxCu(I,j)) * G%IdyCu(I,j) CS%Idxdy2u(I,j) = G%IdxCu(I,j) * (G%IdyCu(I,j)*G%IdyCu(I,j)) enddo ; enddo - do J=Jsq-1,Jeq+1 ; do i=is-1,Ieq+1 + do J=js-2,Jeq+1 ; do i=is-1,Ieq+1 CS%Idx2dyCv(i,J) = (G%IdxCv(i,J)*G%IdxCv(i,J)) * G%IdyCv(i,J) CS%Idxdy2v(i,J) = G%IdxCv(i,J) * (G%IdyCv(i,J)*G%IdyCv(i,J)) enddo ; enddo CS%Ah_bg_xy(:,:) = 0.0 - ! The 0.3 below was 0.4 in MOM1.10. The change in hq requires - ! this to be less than 1/3, rather than 1/2 as before. - if (CS%better_bound_Ah .or. CS%bound_Ah) Ah_Limit = 0.3 / (dt*64.0) + ! The 0.3 below was 0.4 in HIM 1.10. The change in hq requires + ! this to be less than 1/3, rather than 1/2 as before. + if (CS%bound_Ah) Ah_Limit = 0.3 / (dt*64.0) if (CS%Smagorinsky_Ah .and. CS%bound_Coriolis) & BoundCorConst = 1.0 / (5.0*(bound_Cor_vel*bound_Cor_vel)) min_grid_sp_h4 = huge(1.) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js-1,Jeq+1 ; do i=is-1,Ieq+1 grid_sp_h2 = (2.0*CS%dx2h(i,j)*CS%dy2h(i,j)) / (CS%dx2h(i,j)+CS%dy2h(i,j)) grid_sp_h3 = grid_sp_h2*sqrt(grid_sp_h2) CS%grid_sp_h3(i,j) = grid_sp_h3 @@ -2248,16 +2962,17 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) endif endif if (CS%Leith_Ah) then - CS%biharm6_const_xx(i,j) = Leith_bi_const * (grid_sp_h3 * grid_sp_h3) + CS%biharm6_const_xx(i,j) = Leith_bi_const * (grid_sp_h3 * grid_sp_h3) + endif + if (CS%use_Leithy) then + CS%biharm6_const_xx(i,j) = Leith_bi_const * max(G%dxT(i,j),G%dyT(i,j))**6 + CS%m_const_leithy(i,j) = 0.5 * sqrt(CS%c_K) * max(G%dxT(i,j),G%dyT(i,j)) + CS%m_leithy_max(i,j) = 4. / max(G%dxT(i,j),G%dyT(i,j))**2 endif CS%Ah_bg_xx(i,j) = MAX(Ah, Ah_vel_scale * grid_sp_h2 * sqrt(grid_sp_h2)) if (CS%Re_Ah > 0.0) CS%Re_Ah_const_xx(i,j) = grid_sp_h3 / CS%Re_Ah if (Ah_time_scale > 0.) CS%Ah_bg_xx(i,j) = & MAX(CS%Ah_bg_xx(i,j), (grid_sp_h2 * grid_sp_h2) / Ah_time_scale) - if (CS%bound_Ah .and. .not.CS%better_bound_Ah) then - CS%Ah_Max_xx(i,j) = Ah_Limit * (grid_sp_h2 * grid_sp_h2) - CS%Ah_bg_xx(i,j) = MIN(CS%Ah_bg_xx(i,j), CS%Ah_Max_xx(i,j)) - endif min_grid_sp_h4 = min(grid_sp_h2**2, min_grid_sp_h4) enddo ; enddo call min_across_PEs(min_grid_sp_h4) @@ -2272,22 +2987,18 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) (abs(G%CoriolisBu(I,J)) * BoundCorConst) endif endif - if (CS%Leith_Ah) then - CS%biharm6_const_xy(I,J) = Leith_bi_const * (grid_sp_q3 * grid_sp_q3) + if ((CS%Leith_Ah) .or. (CS%use_Leithy))then + CS%biharm6_const_xy(I,J) = Leith_bi_const * (grid_sp_q3 * grid_sp_q3) endif CS%Ah_bg_xy(I,J) = MAX(Ah, Ah_vel_scale * grid_sp_q2 * sqrt(grid_sp_q2)) if (CS%Re_Ah > 0.0) CS%Re_Ah_const_xy(i,j) = grid_sp_q3 / CS%Re_Ah if (Ah_time_scale > 0.) CS%Ah_bg_xy(i,j) = & - MAX(CS%Ah_bg_xy(i,j), (grid_sp_q2 * grid_sp_q2) / Ah_time_scale) - if (CS%bound_Ah .and. .not.CS%better_bound_Ah) then - CS%Ah_Max_xy(I,J) = Ah_Limit * (grid_sp_q2 * grid_sp_q2) - CS%Ah_bg_xy(I,J) = MIN(CS%Ah_bg_xy(I,J), CS%Ah_Max_xy(I,J)) - endif + MAX(CS%Ah_bg_xy(i,j), (grid_sp_q2 * grid_sp_q2) / Ah_time_scale) enddo ; enddo endif ! The Laplacian bounds should avoid overshoots when CS%bound_coef < 1. - if (CS%Laplacian .and. CS%better_bound_Kh) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + if (CS%Laplacian .and. CS%bound_Kh) then + do j=js-1,Jeq+1 ; do i=is-1,Ieq+1 denom = max( & (CS%dy2h(i,j) * CS%DY_dxT(i,j) * (G%IdyCu(I,j) + G%IdyCu(I-1,j)) * & max(G%IdyCu(I,j)*G%IareaCu(I,j), G%IdyCu(I-1,j)*G%IareaCu(I-1,j)) ), & @@ -2308,64 +3019,74 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) CS%Kh_Max_xy(I,J) = CS%bound_coef * 0.25 * Idt / denom enddo ; enddo if (CS%debug) then - call hchksum(CS%Kh_Max_xx, "Kh_Max_xx", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T) - call Bchksum(CS%Kh_Max_xy, "Kh_Max_xy", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T) + call hchksum(CS%Kh_Max_xx, "Kh_Max_xx", G%HI, haloshift=0, unscale=US%L_to_m**2*US%s_to_T) + call Bchksum(CS%Kh_Max_xy, "Kh_Max_xy", G%HI, haloshift=0, unscale=US%L_to_m**2*US%s_to_T) endif endif ! The biharmonic bounds should avoid overshoots when CS%bound_coef < 0.5, but ! empirically work for CS%bound_coef <~ 1.0 - if (CS%biharmonic .and. CS%better_bound_Ah) then - do j=js-1,Jeq+1 ; do I=Isq-1,Ieq+1 - u0u(I,j) = (CS%Idxdy2u(I,j)*(CS%dy2h(i+1,j)*CS%DY_dxT(i+1,j)*(G%IdyCu(I+1,j) + G%IdyCu(I,j)) + & - CS%dy2h(i,j) * CS%DY_dxT(i,j) * (G%IdyCu(I,j) + G%IdyCu(I-1,j)) ) + & - CS%Idx2dyCu(I,j)*(CS%dx2q(I,J) * CS%DX_dyBu(I,J) * (G%IdxCu(I,j+1) + G%IdxCu(I,j)) + & - CS%dx2q(I,J-1)*CS%DX_dyBu(I,J-1)*(G%IdxCu(I,j) + G%IdxCu(I,j-1)) ) ) - u0v(I,j) = (CS%Idxdy2u(I,j)*(CS%dy2h(i+1,j)*CS%DX_dyT(i+1,j)*(G%IdxCv(i+1,J) + G%IdxCv(i+1,J-1)) + & - CS%dy2h(i,j) * CS%DX_dyT(i,j) * (G%IdxCv(i,J) + G%IdxCv(i,J-1)) ) + & - CS%Idx2dyCu(I,j)*(CS%dx2q(I,J) * CS%DY_dxBu(I,J) * (G%IdyCv(i+1,J) + G%IdyCv(i,J)) + & - CS%dx2q(I,J-1)*CS%DY_dxBu(I,J-1)*(G%IdyCv(i+1,J-1) + G%IdyCv(i,J-1)) ) ) + if (CS%biharmonic .and. CS%bound_Ah) then + do j=js-1,Jeq+1 ; do I=is-2,Ieq+1 + u0u(I,j) = ((CS%Idxdy2u(I,j)*((CS%dy2h(i+1,j)*CS%DY_dxT(i+1,j)*(G%IdyCu(I+1,j) + G%IdyCu(I,j))) + & + (CS%dy2h(i,j) * CS%DY_dxT(i,j) * (G%IdyCu(I,j) + G%IdyCu(I-1,j))) )) + & + (CS%Idx2dyCu(I,j)*((CS%dx2q(I,J) * CS%DX_dyBu(I,J) * (G%IdxCu(I,j+1) + G%IdxCu(I,j))) + & + (CS%dx2q(I,J-1)*CS%DX_dyBu(I,J-1)*(G%IdxCu(I,j) + G%IdxCu(I,j-1))) )) ) + u0v(I,j) = ((CS%Idxdy2u(I,j)*((CS%dy2h(i+1,j)*CS%DX_dyT(i+1,j)*(G%IdxCv(i+1,J) + G%IdxCv(i+1,J-1))) + & + (CS%dy2h(i,j) * CS%DX_dyT(i,j) * (G%IdxCv(i,J) + G%IdxCv(i,J-1))) )) + & + (CS%Idx2dyCu(I,j)*((CS%dx2q(I,J) * CS%DY_dxBu(I,J) * (G%IdyCv(i+1,J) + G%IdyCv(i,J))) + & + (CS%dx2q(I,J-1)*CS%DY_dxBu(I,J-1)*(G%IdyCv(i+1,J-1) + G%IdyCv(i,J-1))) )) ) enddo ; enddo - do J=Jsq-1,Jeq+1 ; do i=is-1,Ieq+1 - v0u(i,J) = (CS%Idxdy2v(i,J)*(CS%dy2q(I,J) * CS%DX_dyBu(I,J) * (G%IdxCu(I,j+1) + G%IdxCu(I,j)) + & - CS%dy2q(I-1,J)*CS%DX_dyBu(I-1,J)*(G%IdxCu(I-1,j+1) + G%IdxCu(I-1,j)) ) + & - CS%Idx2dyCv(i,J)*(CS%dx2h(i,j+1)*CS%DY_dxT(i,j+1)*(G%IdyCu(I,j+1) + G%IdyCu(I-1,j+1)) + & - CS%dx2h(i,j) * CS%DY_dxT(i,j) * (G%IdyCu(I,j) + G%IdyCu(I-1,j)) ) ) - v0v(i,J) = (CS%Idxdy2v(i,J)*(CS%dy2q(I,J) * CS%DY_dxBu(I,J) * (G%IdyCv(i+1,J) + G%IdyCv(i,J)) + & - CS%dy2q(I-1,J)*CS%DY_dxBu(I-1,J)*(G%IdyCv(i,J) + G%IdyCv(i-1,J)) ) + & - CS%Idx2dyCv(i,J)*(CS%dx2h(i,j+1)*CS%DX_dyT(i,j+1)*(G%IdxCv(i,J+1) + G%IdxCv(i,J)) + & - CS%dx2h(i,j) * CS%DX_dyT(i,j) * (G%IdxCv(i,J) + G%IdxCv(i,J-1)) ) ) + do J=js-2,Jeq+1 ; do i=is-1,Ieq+1 + v0u(i,J) = ((CS%Idxdy2v(i,J)*((CS%dy2q(I,J) * CS%DX_dyBu(I,J) * (G%IdxCu(I,j+1) + G%IdxCu(I,j))) + & + (CS%dy2q(I-1,J)*CS%DX_dyBu(I-1,J)*(G%IdxCu(I-1,j+1) + G%IdxCu(I-1,j))) )) + & + (CS%Idx2dyCv(i,J)*((CS%dx2h(i,j+1)*CS%DY_dxT(i,j+1)*(G%IdyCu(I,j+1) + G%IdyCu(I-1,j+1))) + & + (CS%dx2h(i,j) * CS%DY_dxT(i,j) * (G%IdyCu(I,j) + G%IdyCu(I-1,j))) ) )) + v0v(i,J) = ((CS%Idxdy2v(i,J)*((CS%dy2q(I,J) * CS%DY_dxBu(I,J) * (G%IdyCv(i+1,J) + G%IdyCv(i,J))) + & + (CS%dy2q(I-1,J)*CS%DY_dxBu(I-1,J)*(G%IdyCv(i,J) + G%IdyCv(i-1,J))) )) + & + (CS%Idx2dyCv(i,J)*((CS%dx2h(i,j+1)*CS%DX_dyT(i,j+1)*(G%IdxCv(i,J+1) + G%IdxCv(i,J))) + & + (CS%dx2h(i,j) * CS%DX_dyT(i,j) * (G%IdxCv(i,J) + G%IdxCv(i,J-1))) )) ) enddo ; enddo - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js-1,Jeq+1 ; do i=is-1,Ieq+1 denom = max( & (CS%dy2h(i,j) * & - (CS%DY_dxT(i,j)*(G%IdyCu(I,j)*u0u(I,j) + G%IdyCu(I-1,j)*u0u(I-1,j)) + & - CS%DX_dyT(i,j)*(G%IdxCv(i,J)*v0u(i,J) + G%IdxCv(i,J-1)*v0u(i,J-1))) * & - max(G%IdyCu(I,j)*G%IareaCu(I,j), G%IdyCu(I-1,j)*G%IareaCu(I-1,j)) ), & + ((CS%DY_dxT(i,j)*((G%IdyCu(I,j)*u0u(I,j)) + (G%IdyCu(I-1,j)*u0u(I-1,j)))) + & + (CS%DX_dyT(i,j)*((G%IdxCv(i,J)*v0u(i,J)) + (G%IdxCv(i,J-1)*v0u(i,J-1))))) * & + max(G%IdyCu(I,j)*G%IareaCu(I,j), G%IdyCu(I-1,j)*G%IareaCu(I-1,j)) ), & (CS%dx2h(i,j) * & - (CS%DY_dxT(i,j)*(G%IdyCu(I,j)*u0v(I,j) + G%IdyCu(I-1,j)*u0v(I-1,j)) + & - CS%DX_dyT(i,j)*(G%IdxCv(i,J)*v0v(i,J) + G%IdxCv(i,J-1)*v0v(i,J-1))) * & + ((CS%DY_dxT(i,j)*((G%IdyCu(I,j)*u0v(I,j)) + (G%IdyCu(I-1,j)*u0v(I-1,j)))) + & + (CS%DX_dyT(i,j)*((G%IdxCv(i,J)*v0v(i,J)) + (G%IdxCv(i,J-1)*v0v(i,J-1))))) * & max(G%IdxCv(i,J)*G%IareaCv(i,J), G%IdxCv(i,J-1)*G%IareaCv(i,J-1)) ) ) CS%Ah_Max_xx(I,J) = 0.0 - if (denom > 0.0) & + if (denom > 0.0) then CS%Ah_Max_xx(I,J) = CS%bound_coef * 0.5 * Idt / denom + if (CS%EY24_EBT_BS) then + CS%Ah_Max_xx_KS(i,j) = CS%bound_coef * 0.5 / (CS%KS_timescale * denom) + endif + endif + enddo ; enddo do J=js-1,Jeq ; do I=is-1,Ieq denom = max( & (CS%dx2q(I,J) * & - (CS%DX_dyBu(I,J)*(u0u(I,j+1)*G%IdxCu(I,j+1) + u0u(I,j)*G%IdxCu(I,j)) + & - CS%DY_dxBu(I,J)*(v0u(i+1,J)*G%IdyCv(i+1,J) + v0u(i,J)*G%IdyCv(i,J))) * & - max(G%IdxCu(I,j)*G%IareaCu(I,j), G%IdxCu(I,j+1)*G%IareaCu(I,j+1)) ), & + ((CS%DX_dyBu(I,J)*((u0u(I,j+1)*G%IdxCu(I,j+1)) + (u0u(I,j)*G%IdxCu(I,j)))) + & + (CS%DY_dxBu(I,J)*((v0u(i+1,J)*G%IdyCv(i+1,J)) + (v0u(i,J)*G%IdyCv(i,J))))) * & + max(G%IdxCu(I,j)*G%IareaCu(I,j), G%IdxCu(I,j+1)*G%IareaCu(I,j+1)) ), & (CS%dy2q(I,J) * & - (CS%DX_dyBu(I,J)*(u0v(I,j+1)*G%IdxCu(I,j+1) + u0v(I,j)*G%IdxCu(I,j)) + & - CS%DY_dxBu(I,J)*(v0v(i+1,J)*G%IdyCv(i+1,J) + v0v(i,J)*G%IdyCv(i,J))) * & + ((CS%DX_dyBu(I,J)*((u0v(I,j+1)*G%IdxCu(I,j+1)) + (u0v(I,j)*G%IdxCu(I,j)))) + & + (CS%DY_dxBu(I,J)*((v0v(i+1,J)*G%IdyCv(i+1,J)) + (v0v(i,J)*G%IdyCv(i,J))))) * & max(G%IdyCv(i,J)*G%IareaCv(i,J), G%IdyCv(i+1,J)*G%IareaCv(i+1,J)) ) ) CS%Ah_Max_xy(I,J) = 0.0 - if (denom > 0.0) & + if (denom > 0.0) then CS%Ah_Max_xy(I,J) = CS%bound_coef * 0.5 * Idt / denom + if (CS%EY24_EBT_BS) then + CS%Ah_Max_xy_KS(i,j) = CS%bound_coef * 0.5 / (CS%KS_timescale * denom) + endif + endif + enddo ; enddo if (CS%debug) then - call hchksum(CS%Ah_Max_xx, "Ah_Max_xx", G%HI, haloshift=0, scale=US%L_to_m**4*US%s_to_T) - call Bchksum(CS%Ah_Max_xy, "Ah_Max_xy", G%HI, haloshift=0, scale=US%L_to_m**4*US%s_to_T) + call hchksum(CS%Ah_Max_xx, "Ah_Max_xx", G%HI, haloshift=0, unscale=US%L_to_m**4*US%s_to_T) + call Bchksum(CS%Ah_Max_xy, "Ah_Max_xy", G%HI, haloshift=0, unscale=US%L_to_m**4*US%s_to_T) endif endif ! Register fields for output from this module. @@ -2460,6 +3181,20 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) 'Biharmonic Horizontal Viscosity at q Points', 'm4 s-1', conversion=US%L_to_m**4*US%s_to_T) CS%id_grid_Re_Ah = register_diag_field('ocean_model', 'grid_Re_Ah', diag%axesTL, Time, & 'Grid Reynolds number for the Biharmonic horizontal viscosity at h points', 'nondim') + if (CS%EY24_EBT_BS) then + CS%id_visc_limit_h_flag = register_diag_field('ocean_model', 'visc_limit_h_flag', diag%axesTL, Time, & + 'Locations where the biharmonic viscosity reached the better_bound limiter at h points', 'nondim') + CS%id_visc_limit_q_flag = register_diag_field('ocean_model', 'visc_limit_q_flag', diag%axesBL, Time, & + 'Locations where the biharmonic viscosity reached the better_bound limiter at q points', 'nondim') + CS%id_visc_limit_h = register_diag_field('ocean_model', 'visc_limit_h', diag%axesTL, Time, & + 'Value of the biharmonic viscosity limiter at h points', 'nondim') + CS%id_visc_limit_q = register_diag_field('ocean_model', 'visc_limit_q', diag%axesBL, Time, & + 'Value of the biharmonic viscosity limiter at q points', 'nondim') + CS%id_visc_limit_h_frac = register_diag_field('ocean_model', 'visc_limit_h_frac', diag%axesTL, Time, & + 'Value of the biharmonic viscosity limiter at h points', 'nondim') + CS%id_visc_limit_q_frac = register_diag_field('ocean_model', 'visc_limit_q_frac', diag%axesBL, Time, & + 'Value of the biharmonic viscosity limiter at q points', 'nondim') + endif if (CS%id_grid_Re_Ah > 0) & ! Compute the smallest biharmonic viscosity capable of modifying the @@ -2491,16 +3226,37 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) CS%min_grid_Kh = spacing(1.) * min_grid_sp_h2 * Idt endif if (CS%use_GME) then - CS%id_GME_coeff_h = register_diag_field('ocean_model', 'GME_coeff_h', diag%axesTL, Time, & + CS%id_dudx_bt = register_diag_field('ocean_model', 'dudx_bt', diag%axesT1, Time, & + 'Zonal component of the barotropic shearing strain at h points', 's-1', & + conversion=US%s_to_T) + CS%id_dudy_bt = register_diag_field('ocean_model', 'dudy_bt', diag%axesB1, Time, & + 'Zonal component of the barotropic shearing strain at q points', 's-1', & + conversion=US%s_to_T) + CS%id_dvdy_bt = register_diag_field('ocean_model', 'dvdy_bt', diag%axesT1, Time, & + 'Meridional component of the barotropic shearing strain at h points', 's-1', & + conversion=US%s_to_T) + CS%id_dvdx_bt = register_diag_field('ocean_model', 'dvdx_bt', diag%axesB1, Time, & + 'Meridional component of the barotropic shearing strain at q points', 's-1', & + conversion=US%s_to_T) + CS%id_GME_coeff_h = register_diag_field('ocean_model', 'GME_coeff_h', diag%axesTL, Time, & 'GME coefficient at h Points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) - CS%id_GME_coeff_q = register_diag_field('ocean_model', 'GME_coeff_q', diag%axesBL, Time, & + CS%id_GME_coeff_q = register_diag_field('ocean_model', 'GME_coeff_q', diag%axesBL, Time, & 'GME coefficient at q Points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) - CS%id_FrictWork_GME = register_diag_field('ocean_model','FrictWork_GME',diag%axesTL,Time,& - 'Integral work done by lateral friction terms in GME (excluding diffusion of energy)', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + CS%id_FrictWork_GME = register_diag_field('ocean_model','FrictWork_GME',diag%axesTL,Time,& + 'Integral work done by lateral friction terms in GME (excluding diffusion of energy)', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) endif + + if (CS%EY24_EBT_BS) then + CS%id_BS_coeff_h = register_diag_field('ocean_model', 'BS_coeff_h', diag%axesTL, Time, & + 'Backscatter coefficient at h points', units='m2 s-1', conversion=US%L_to_m**2*US%s_to_T) + CS%id_BS_coeff_q = register_diag_field('ocean_model', 'BS_coeff_q', diag%axesBL, Time, & + 'Backscatter coefficient at q points', units='m2 s-1', conversion=US%L_to_m**2*US%s_to_T) + endif + CS%id_FrictWork = register_diag_field('ocean_model','FrictWork',diag%axesTL,Time,& - 'Integral work done by lateral friction terms', & + 'Integral work done by lateral friction terms. If GME is turned on, this '//& + 'includes the GME contribution.', & 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) CS%id_FrictWorkIntz = register_diag_field('ocean_model','FrictWorkIntz',diag%axesT1,Time, & 'Depth integrated work done by lateral friction', & @@ -2508,9 +3264,27 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) cmor_field_name='dispkexyfo', & cmor_long_name='Depth integrated ocean kinetic energy dissipation due to lateral friction',& cmor_standard_name='ocean_kinetic_energy_dissipation_per_unit_area_due_to_xy_friction') + CS%id_FrictWork_bh = register_diag_field('ocean_model','FrictWork_bh',diag%axesTL,Time,& + 'Integral work done by the biharmonic lateral friction terms.', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + CS%id_FrictWorkIntz_bh = register_diag_field('ocean_model','FrictWorkIntz_bh',diag%axesT1,Time,& + 'Depth integrated work done by the biharmonic lateral friction', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) end subroutine hor_visc_init +!> hor_visc_vel_stencil returns the horizontal viscosity input velocity stencil size +function hor_visc_vel_stencil(CS) result(stencil) + type(hor_visc_CS), intent(in) :: CS !< Control structure for horizontal viscosity + integer :: stencil !< The horizontal viscosity velocity stencil size with the current settings. + + stencil = 2 + + if ((CS%Leith_Kh) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) then + stencil = 3 + endif +end function hor_visc_vel_stencil + !> Calculates factors in the anisotropic orientation tensor to be align with the grid. !! With n1=1 and n2=0, this recovers the approach of Large et al, 2001. subroutine align_aniso_tensor_to_grid(CS, n1, n2) @@ -2518,86 +3292,200 @@ subroutine align_aniso_tensor_to_grid(CS, n1, n2) real, intent(in) :: n1 !< i-component of direction vector [nondim] real, intent(in) :: n2 !< j-component of direction vector [nondim] ! Local variables - real :: recip_n2_norm + real :: recip_n2_norm ! The inverse of the squared magnitude of n1 and n2 [nondim] ! For normalizing n=(n1,n2) in case arguments are not a unit vector - recip_n2_norm = n1**2 + n2**2 - if (recip_n2_norm > 0.) recip_n2_norm = 1./recip_n2_norm + recip_n2_norm = (n1**2) + (n2**2) + if (recip_n2_norm > 0.) recip_n2_norm = 1. / recip_n2_norm CS%n1n2_h(:,:) = 2. * ( n1 * n2 ) * recip_n2_norm CS%n1n2_q(:,:) = 2. * ( n1 * n2 ) * recip_n2_norm - CS%n1n1_m_n2n2_h(:,:) = ( n1 * n1 - n2 * n2 ) * recip_n2_norm - CS%n1n1_m_n2n2_q(:,:) = ( n1 * n1 - n2 * n2 ) * recip_n2_norm + CS%n1n1_m_n2n2_h(:,:) = ( (n1 * n1) - (n2 * n2) ) * recip_n2_norm + CS%n1n1_m_n2n2_q(:,:) = ( (n1 * n1) - (n2 * n2) ) * recip_n2_norm end subroutine align_aniso_tensor_to_grid !> Apply a 1-1-4-1-1 Laplacian filter one time on GME diffusive flux to reduce any !! horizontal two-grid-point noise -subroutine smooth_GME(G, GME_flux_h, GME_flux_q) +subroutine smooth_GME(CS, G, GME_flux_h, GME_flux_q) + type(hor_visc_CS), intent(in) :: CS !< Control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid real, dimension(SZI_(G),SZJ_(G)), optional, intent(inout) :: GME_flux_h!< GME diffusive flux - !! at h points + !! at h points [L2 T-2 ~> m2 s-2] real, dimension(SZIB_(G),SZJB_(G)), optional, intent(inout) :: GME_flux_q!< GME diffusive flux - !! at q points + !! at q points [L2 T-2 ~> m2 s-2] ! local variables - real, dimension(SZI_(G),SZJ_(G)) :: GME_flux_h_original - real, dimension(SZIB_(G),SZJB_(G)) :: GME_flux_q_original - real :: wc, ww, we, wn, ws ! averaging weights for smoothing - integer :: i, j, k, s - do s=1,1 - ! Update halos + real, dimension(SZI_(G),SZJ_(G)) :: GME_flux_h_original ! The previous value of GME_flux_h [L2 T-2 ~> m2 s-2] + real, dimension(SZIB_(G),SZJB_(G)) :: GME_flux_q_original ! The previous value of GME_flux_q [L2 T-2 ~> m2 s-2] + real :: wc, ww, we, wn, ws ! averaging weights for smoothing [nondim] + integer :: i, j, s, halosz + integer :: xh, xq ! The number of valid extra halo points for h and q points. + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + xh = 0 ; xq = 0 + + do s=1,CS%num_smooth_gme if (present(GME_flux_h)) then - !### Work on a wider halo to eliminate this blocking send! - call pass_var(GME_flux_h, G%Domain) + if (xh < 0) then + ! Update halos if needed, but avoid doing so more often than is needed. + halosz = min(G%isc-G%isd, G%jsc-G%jsd, 2+CS%num_smooth_gme-s) + call pass_var(GME_flux_h, G%Domain, halo=halosz) + xh = halosz - 2 + endif GME_flux_h_original(:,:) = GME_flux_h(:,:) ! apply smoothing on GME - do j = G%jsc, G%jec - do i = G%isc, G%iec - ! skip land points - if (G%mask2dT(i,j)==0.) cycle - ! compute weights - ww = 0.125 * G%mask2dT(i-1,j) - we = 0.125 * G%mask2dT(i+1,j) - ws = 0.125 * G%mask2dT(i,j-1) - wn = 0.125 * G%mask2dT(i,j+1) - wc = 1.0 - (ww+we+wn+ws) - !### Add parentheses to make this rotationally invariant. - GME_flux_h(i,j) = wc * GME_flux_h_original(i,j) & - + ww * GME_flux_h_original(i-1,j) & - + we * GME_flux_h_original(i+1,j) & - + ws * GME_flux_h_original(i,j-1) & - + wn * GME_flux_h_original(i,j+1) - enddo - enddo + do j=Jsq-xh,Jeq+1+xh ; do i=Isq-xh,Ieq+1+xh + ! skip land points + if (G%mask2dT(i,j)==0.) cycle + ! compute weights + ww = 0.125 * G%mask2dT(i-1,j) + we = 0.125 * G%mask2dT(i+1,j) + ws = 0.125 * G%mask2dT(i,j-1) + wn = 0.125 * G%mask2dT(i,j+1) + wc = 1.0 - ((ww+we)+(wn+ws)) + GME_flux_h(i,j) = wc * GME_flux_h_original(i,j) & + + ((ww * GME_flux_h_original(i-1,j) + we * GME_flux_h_original(i+1,j)) & + + (ws * GME_flux_h_original(i,j-1) + wn * GME_flux_h_original(i,j+1))) + enddo ; enddo + xh = xh - 1 endif - ! Update halos if (present(GME_flux_q)) then - !### Work on a wider halo to eliminate this blocking send! - call pass_var(GME_flux_q, G%Domain, position=CORNER, complete=.true.) + if (xq < 0) then + ! Update halos if needed, but avoid doing so more often than is needed. + halosz = min(G%isc-G%isd, G%jsc-G%jsd, 2+CS%num_smooth_gme-s) + call pass_var(GME_flux_q, G%Domain, position=CORNER, complete=.true., halo=halosz) + xq = halosz - 2 + endif GME_flux_q_original(:,:) = GME_flux_q(:,:) ! apply smoothing on GME - do J = G%JscB, G%JecB - do I = G%IscB, G%IecB - ! skip land points - if (G%mask2dBu(I,J)==0.) cycle - ! compute weights - ww = 0.125 * G%mask2dBu(I-1,J) - we = 0.125 * G%mask2dBu(I+1,J) - ws = 0.125 * G%mask2dBu(I,J-1) - wn = 0.125 * G%mask2dBu(I,J+1) - wc = 1.0 - (ww+we+wn+ws) - !### Add parentheses to make this rotationally invariant. - GME_flux_q(I,J) = wc * GME_flux_q_original(I,J) & - + ww * GME_flux_q_original(I-1,J) & - + we * GME_flux_q_original(I+1,J) & - + ws * GME_flux_q_original(I,J-1) & - + wn * GME_flux_q_original(I,J+1) - enddo - enddo + do J=js-1-xq,je+xq ; do I=is-1-xq,ie+xq + ! skip land points + if (G%mask2dBu(I,J)==0.) cycle + ! compute weights + ww = 0.125 * G%mask2dBu(I-1,J) + we = 0.125 * G%mask2dBu(I+1,J) + ws = 0.125 * G%mask2dBu(I,J-1) + wn = 0.125 * G%mask2dBu(I,J+1) + wc = 1.0 - ((ww+we)+(wn+ws)) + GME_flux_q(I,J) = wc * GME_flux_q_original(I,J) & + + ((ww * GME_flux_q_original(I-1,J) + we * GME_flux_q_original(I+1,J)) & + + (ws * GME_flux_q_original(I,J-1) + wn * GME_flux_q_original(I,J+1))) + enddo ; enddo + xq = xq - 1 endif enddo ! s-loop end subroutine smooth_GME +!> Apply a 9-point smoothing filter twice to a field staggered at a thickness point to reduce +!! horizontal two-grid-point noise. +!! Note that this subroutine does not conserve mass, so don't use it in situations where you +!! need conservation. Also note that it assumes that the input field has valid values in the +!! first two halo points upon entry. +subroutine smooth_x9_h(G, field_h, zero_land) + type(ocean_grid_type), intent(in) :: G !< Ocean grid + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: field_h !< h-point field to be smoothed [arbitrary] + logical, optional, intent(in) :: zero_land !< If present and false, return the average + !! of the surrounding ocean points when + !! smoothing, otherwise use a value of 0 for + !! land points and include them in the averages. + + ! Local variables + real :: fh_prev(SZI_(G),SZJ_(G)) ! The value of the h-point field at the previous iteration [arbitrary] + real :: Iwts ! The inverse of the sum of the weights [nondim] + logical :: zero_land_val ! The value of the zero_land optional argument or .true. if it is absent. + integer :: i, j, s, is, ie, js, je + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + zero_land_val = .true. ; if (present(zero_land)) zero_land_val = zero_land + + do s=1,0,-1 + fh_prev(:,:) = field_h(:,:) + ! apply smoothing on field_h using rotationally symmetric expressions. + do j=js-s,je+s ; do i=is-s,ie+s ; if (G%mask2dT(i,j) > 0.0) then + Iwts = 0.0625 + if (.not. zero_land_val) & + Iwts = 1.0 / ( (4.0*G%mask2dT(i,j) + & + ( 2.0*((G%mask2dT(i-1,j) + G%mask2dT(i+1,j)) + & + (G%mask2dT(i,j-1) + G%mask2dT(i,j+1))) + & + ((G%mask2dT(i-1,j-1) + G%mask2dT(i+1,j+1)) + & + (G%mask2dT(i-1,j+1) + G%mask2dT(i+1,j-1))) ) ) + 1.0e-16 ) + field_h(i,j) = Iwts * ( 4.0*G%mask2dT(i,j) * fh_prev(i,j) & + + (2.0*((G%mask2dT(i-1,j) * fh_prev(i-1,j) + G%mask2dT(i+1,j) * fh_prev(i+1,j)) + & + (G%mask2dT(i,j-1) * fh_prev(i,j-1) + G%mask2dT(i,j+1) * fh_prev(i,j+1))) & + + ((G%mask2dT(i-1,j-1) * fh_prev(i-1,j-1) + G%mask2dT(i+1,j+1) * fh_prev(i+1,j+1)) + & + (G%mask2dT(i-1,j+1) * fh_prev(i-1,j+1) + G%mask2dT(i+1,j-1) * fh_prev(i-1,j-1))) )) + endif ; enddo ; enddo + enddo + +end subroutine smooth_x9_h + +!> Apply a 9-point smoothing filter twice to a pair of velocity components to reduce +!! horizontal two-grid-point noise. +!! Note that this subroutine does not conserve angular momentum, so don't use it +!! in situations where you need conservation. Also note that it assumes that the +!! input fields have valid values in the first two halo points upon entry. +subroutine smooth_x9_uv(G, field_u, field_v, zero_land) + type(ocean_grid_type), intent(in) :: G !< Ocean grid + real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: field_u !< u-point field to be smoothed [arbitrary] + real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: field_v !< v-point field to be smoothed [arbitrary] + logical, optional, intent(in) :: zero_land !< If present and false, return the average + !! of the surrounding ocean points when + !! smoothing, otherwise use a value of 0 for + !! land points and include them in the averages. + + ! Local variables. + real :: fu_prev(SZIB_(G),SZJ_(G)) ! The value of the u-point field at the previous iteration [arbitrary] + real :: fv_prev(SZI_(G),SZJB_(G)) ! The value of the v-point field at the previous iteration [arbitrary] + real :: Iwts ! The inverse of the sum of the weights [nondim] + logical :: zero_land_val ! The value of the zero_land optional argument or .true. if it is absent. + integer :: i, j, s, is, ie, js, je, Isq, Ieq, Jsq, Jeq + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + zero_land_val = .true. ; if (present(zero_land)) zero_land_val = zero_land + + do s=1,0,-1 + fu_prev(:,:) = field_u(:,:) + ! apply smoothing on field_u using the original non-rotationally symmetric expressions. + do j=js-s,je+s ; do I=Isq-s,Ieq+s ; if (G%mask2dCu(I,j) > 0.0) then + Iwts = 0.0625 + if (.not. zero_land_val) & + Iwts = 1.0 / ( (4.0*G%mask2dCu(I,j) + & + ( 2.0*((G%mask2dCu(I-1,j) + G%mask2dCu(I+1,j)) + & + (G%mask2dCu(I,j-1) + G%mask2dCu(I,j+1))) + & + ((G%mask2dCu(I-1,j-1) + G%mask2dCu(I+1,j+1)) + & + (G%mask2dCu(I-1,j+1) + G%mask2dCu(I+1,j-1))) ) ) + 1.0e-16 ) + field_u(I,j) = Iwts * ( 4.0*G%mask2dCu(I,j) * fu_prev(I,j) & + + (2.0*((G%mask2dCu(I-1,j) * fu_prev(I-1,j) + G%mask2dCu(I+1,j) * fu_prev(I+1,j)) + & + (G%mask2dCu(I,j-1) * fu_prev(I,j-1) + G%mask2dCu(I,j+1) * fu_prev(I,j+1))) & + + ((G%mask2dCu(I-1,j-1) * fu_prev(I-1,j-1) + G%mask2dCu(I+1,j+1) * fu_prev(I+1,j+1)) + & + (G%mask2dCu(I-1,j+1) * fu_prev(I-1,j+1) + G%mask2dCu(I+1,j-1) * fu_prev(I-1,j-1))) )) + endif ; enddo ; enddo + + fv_prev(:,:) = field_v(:,:) + ! apply smoothing on field_v using the original non-rotationally symmetric expressions. + do J=Jsq-s,Jeq+s ; do i=is-s,ie+s ; if (G%mask2dCv(i,J) > 0.0) then + Iwts = 0.0625 + if (.not. zero_land_val) & + Iwts = 1.0 / ( (4.0*G%mask2dCv(i,J) + & + ( 2.0*((G%mask2dCv(i-1,J) + G%mask2dCv(i+1,J)) + & + (G%mask2dCv(i,J-1) + G%mask2dCv(i,J+1))) + & + ((G%mask2dCv(i-1,J-1) + G%mask2dCv(i+1,J+1)) + & + (G%mask2dCv(i-1,J+1) + G%mask2dCv(i+1,J-1))) ) ) + 1.0e-16 ) + field_v(i,J) = Iwts * ( 4.0*G%mask2dCv(i,J) * fv_prev(i,J) & + + (2.0*((G%mask2dCv(i-1,J) * fv_prev(i-1,J) + G%mask2dCv(i+1,J) * fv_prev(i+1,J)) + & + (G%mask2dCv(i,J-1) * fv_prev(i,J-1) + G%mask2dCv(i,J+1) * fv_prev(i,J+1))) & + + ((G%mask2dCv(i-1,J-1) * fv_prev(i-1,J-1) + G%mask2dCv(i+1,J+1) * fv_prev(i+1,J+1)) + & + (G%mask2dCv(i-1,J+1) * fv_prev(i-1,J+1) + G%mask2dCv(i+1,J-1) * fv_prev(i-1,J-1))) )) + endif ; enddo ; enddo + enddo + +end subroutine smooth_x9_uv + !> Deallocates any variables allocated in hor_visc_init. subroutine hor_visc_end(CS) - type(hor_visc_CS), intent(inout) :: CS !< Horizontal viscosity control struct + type(hor_visc_CS), intent(inout) :: CS !< Horizontal viscosity control structure if (CS%Laplacian .or. CS%biharmonic) then DEALLOC_(CS%dx2h) ; DEALLOC_(CS%dx2q) ; DEALLOC_(CS%dy2h) ; DEALLOC_(CS%dy2q) DEALLOC_(CS%dx_dyT) ; DEALLOC_(CS%dy_dxT) ; DEALLOC_(CS%dx_dyBu) ; DEALLOC_(CS%dy_dxBu) @@ -2606,62 +3494,68 @@ subroutine hor_visc_end(CS) if (CS%Laplacian) then DEALLOC_(CS%Kh_bg_xx) ; DEALLOC_(CS%Kh_bg_xy) DEALLOC_(CS%grid_sp_h2) - if (CS%bound_Kh) then - DEALLOC_(CS%Kh_Max_xx) ; DEALLOC_(CS%Kh_Max_xy) - endif - if (CS%Smagorinsky_Kh) then - DEALLOC_(CS%Laplac2_const_xx) ; DEALLOC_(CS%Laplac2_const_xy) - endif - if (CS%Leith_Kh) then - DEALLOC_(CS%Laplac3_const_xx) ; DEALLOC_(CS%Laplac3_const_xy) - endif + if (allocated(CS%Kh_bg_2d)) deallocate(CS%Kh_bg_2d) + + if (allocated(CS%Kh_Max_xx)) deallocate(CS%Kh_Max_xx) + if (allocated(CS%Kh_Max_xy)) deallocate(CS%Kh_Max_xy) + if (allocated(CS%Laplac2_const_xx)) deallocate(CS%Laplac2_const_xx) + if (allocated(CS%Laplac2_const_xy)) deallocate(CS%Laplac2_const_xy) + if (allocated(CS%Laplac3_const_xx)) deallocate(CS%Laplac3_const_xx) + if (allocated(CS%Laplac3_const_xy)) deallocate(CS%Laplac3_const_xy) endif if (CS%biharmonic) then DEALLOC_(CS%grid_sp_h3) DEALLOC_(CS%Idx2dyCu) ; DEALLOC_(CS%Idx2dyCv) DEALLOC_(CS%Idxdy2u) ; DEALLOC_(CS%Idxdy2v) DEALLOC_(CS%Ah_bg_xx) ; DEALLOC_(CS%Ah_bg_xy) - if (CS%bound_Ah) then - DEALLOC_(CS%Ah_Max_xx) ; DEALLOC_(CS%Ah_Max_xy) - endif - if (CS%Smagorinsky_Ah) then - DEALLOC_(CS%Biharm_const_xx) ; DEALLOC_(CS%Biharm_const_xy) - endif - if (CS%Leith_Ah) then - DEALLOC_(CS%Biharm6_const_xx) ; DEALLOC_(CS%Biharm6_const_xy) - endif - if (CS%Re_Ah > 0.0) then - DEALLOC_(CS%Re_Ah_const_xx) ; DEALLOC_(CS%Re_Ah_const_xy) - endif + + if (allocated(CS%Ah_Max_xx)) deallocate(CS%Ah_Max_xx) + if (allocated(CS%Ah_Max_xy)) deallocate(CS%Ah_Max_xy) + if (allocated(CS%Ah_Max_xx_KS)) deallocate(CS%Ah_Max_xx_KS) + if (allocated(CS%Ah_Max_xy_KS)) deallocate(CS%Ah_Max_xy_KS) + if (allocated(CS%Biharm_const_xx)) deallocate(CS%Biharm_const_xx) + if (allocated(CS%Biharm_const_xy)) deallocate(CS%Biharm_const_xy) + if (allocated(CS%Biharm_const2_xx)) deallocate(CS%Biharm_const2_xx) + if (allocated(CS%Biharm_const2_xy)) deallocate(CS%Biharm_const2_xy) + if (allocated(CS%Biharm6_const_xx)) deallocate(CS%Biharm6_const_xx) + if (allocated(CS%Biharm6_const_xy)) deallocate(CS%Biharm6_const_xy) + if (allocated(CS%m_const_leithy)) deallocate(CS%m_const_leithy) + if (allocated(CS%m_leithy_max)) deallocate(CS%m_leithy_max) + if (allocated(CS%Re_Ah_const_xx)) deallocate(CS%Re_Ah_const_xx) + if (allocated(CS%Re_Ah_const_xy)) deallocate(CS%Re_Ah_const_xy) endif - if (CS%anisotropic) then - DEALLOC_(CS%n1n2_h) - DEALLOC_(CS%n1n2_q) - DEALLOC_(CS%n1n1_m_n2n2_h) - DEALLOC_(CS%n1n1_m_n2n2_q) + + if (allocated(CS%n1n2_h)) deallocate(CS%n1n2_h) + if (allocated(CS%n1n2_q)) deallocate(CS%n1n2_q) + if (allocated(CS%n1n1_m_n2n2_h)) deallocate(CS%n1n1_m_n2n2_h) + if (allocated(CS%n1n1_m_n2n2_q)) deallocate(CS%n1n1_m_n2n2_q) + + if (CS%use_ZB2020) then + call ZB2020_end(CS%ZB2020) endif + end subroutine hor_visc_end !> \namespace mom_hor_visc !! -!! This module contains the subroutine horizontal_viscosity() that calculates the +!! \section section_horizontal_viscosity Horizontal viscosity in MOM +!! +!! This module contains the subroutine horizontal_viscosity that calculates the !! effects of horizontal viscosity, including parameterizations of the value of -!! the viscosity itself. horizontal_viscosity() calculates the acceleration due to +!! the viscosity itself. Subroutine horizontal_viscosity calculates the acceleration due to !! some combination of a biharmonic viscosity and a Laplacian viscosity. Either or !! both may use a coefficient that depends on the shear and strain of the flow. !! All metric terms are retained. The Laplacian is calculated as the divergence of -!! a stress tensor, using the form suggested by Smagorinsky (1993). The biharmonic +!! a stress tensor, using the form suggested by \cite Smagorinsky1993. The biharmonic !! is calculated by twice applying the divergence of the stress tensor that is !! used to calculate the Laplacian, but without the dependence on thickness in the !! first pass. This form permits a variable viscosity, and indicates no !! acceleration for either resting fluid or solid body rotation. !! -!! The form of the viscous accelerations is discussed extensively in Griffies and -!! Hallberg (2000), and the implementation here follows that discussion closely. -!! We use the notation of Smith and McWilliams (2003) with the exception that the +!! The form of the viscous accelerations is discussed extensively in \cite griffies2000, +!! and the implementation here follows that discussion closely. +!! We use the notation of \cite Smith2003 with the exception that the !! isotropic viscosity is \f$\kappa_h\f$. !! -!! \section section_horizontal_viscosity Horizontal viscosity in MOM -!! !! In general, the horizontal stress tensor can be written as !! \f[ !! {\bf \sigma} = @@ -2709,7 +3603,7 @@ end subroutine hor_visc_end !! \f} !! !! The viscosity \f$\kappa_h\f$ may either be a constant or variable. For example, -!! \f$\kappa_h\f$ may vary with the shear, as proposed by Smagorinsky (1993). +!! \f$\kappa_h\f$ may vary with the shear, as proposed by \cite Smagorinsky1993. !! !! The accelerations resulting form the divergence of the stress tensor are !! \f{eqnarray*}{ @@ -2807,8 +3701,8 @@ end subroutine hor_visc_end !! !! \subsection section_anisotropic_viscosity Anisotropic viscosity !! -!! Large et al., 2001, proposed enhancing viscosity in a particular direction and the -!! approach was generalized in Smith and McWilliams, 2003. We use the second form of their +!! \cite Large2001 proposed enhancing viscosity in a particular direction and the +!! approach was generalized in \cite Smith2003. We use the second form of their !! two coefficient anisotropic viscosity (section 4.3). We also replace their !! \f$A^\prime\f$ and $D$ such that \f$2A^\prime = 2 \kappa_h + D\f$ and !! \f$\kappa_a = D\f$ so that \f$\kappa_h\f$ can be considered the isotropic diff --git a/src/parameterizations/lateral/MOM_interface_filter.F90 b/src/parameterizations/lateral/MOM_interface_filter.F90 new file mode 100644 index 0000000000..645333991a --- /dev/null +++ b/src/parameterizations/lateral/MOM_interface_filter.F90 @@ -0,0 +1,499 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Interface height filtering module +module MOM_interface_filter + +use MOM_debugging, only : hchksum, uvchksum +use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl +use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, time_type +use MOM_domains, only : pass_var, CORNER, pass_vector +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : find_eta +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs, cont_diag_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +public interface_filter, interface_filter_init, interface_filter_end + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Control structure for interface height filtering +type, public :: interface_filter_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. + real :: max_smoothing_CFL !< Maximum value of the smoothing CFL for interface height filtering [nondim] + real :: filter_rate !< The rate at which grid-scale anomalies are damped away [T-1 ~> s-1] + integer :: filter_order !< The even power of the interface height smoothing. + !! At present valid values are 0, 2, or 4. + logical :: interface_filter !< If true, interfaces heights are diffused. + logical :: isotropic_filter !< If true, use the same filtering lengthscales in both directions, + !! otherwise use filtering lengthscales in each direction that scale + !! with the grid spacing in that direction. + logical :: debug !< write verbose checksums for debugging purposes + + type(diag_ctrl), pointer :: diag => NULL() !< structure used to regulate timing of diagnostics + + !>@{ + !! Diagnostic identifier + integer :: id_uh_sm = -1, id_vh_sm = -1 + integer :: id_L2_u = -1, id_L2_v = -1 + integer :: id_sfn_x = -1, id_sfn_y = -1 + !>@} +end type interface_filter_CS + +contains + +!> Apply a transport that leads to a smoothing of interface height, subject to limits that +!! ensure stability and positive definiteness of layer thicknesses. +!! It also updates the along-layer mass fluxes used in the tracer transport equations. +subroutine interface_filter(h, uhtr, vhtr, tv, dt, G, GV, US, CDp, CS) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uhtr !< Accumulated zonal mass flux + !! [L2 H ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vhtr !< Accumulated meridional mass flux + !! [L2 H ~> m3 or kg] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + real, intent(in) :: dt !< Time increment [T ~> s] + type(cont_diag_ptrs), intent(inout) :: CDp !< Diagnostics for the continuity equation + type(interface_filter_CS), intent(inout) :: CS !< Control structure for interface height + !! filtering + ! Local variables + real :: e(SZI_(G),SZJ_(G),SZK_(GV)+1) ! Heights of interfaces, relative to mean + ! sea level [Z ~> m], positive up. + real :: de_smooth(SZI_(G),SZJ_(G),SZK_(GV)+1) ! Change in the heights of interfaces after one pass + ! of Laplacian smoothing [Z ~> m], positive downward to avoid + ! having to change other signs in the call to interface_filter. + real :: uhD(SZIB_(G),SZJ_(G),SZK_(GV)) ! Smoothing u*h fluxes within a timestep [L2 H ~> m3 or kg] + real :: vhD(SZI_(G),SZJB_(G),SZK_(GV)) ! Smoothing v*h fluxes within a timestep [L2 H ~> m3 or kg] + + real, dimension(SZIB_(G),SZJ_(G)) :: & + Lsm2_u ! Interface height squared smoothing lengths per timestep at u-points [L2 ~> m2] + real, dimension(SZI_(G),SZJB_(G)) :: & + Lsm2_v ! Interface height squared smoothing lengths per timestep at v-points [L2 ~> m2] + + real :: diag_sfn_x(SZIB_(G),SZJ_(G),SZK_(GV)+1) ! Diagnostic of the x-face streamfunction + ! [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: diag_sfn_y(SZI_(G),SZJB_(G),SZK_(GV)+1) ! Diagnostic of the y-face streamfunction + ! [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: filter_strength ! The amount of filtering within a each iteration [nondim] + real :: Idt ! The inverse of the timestep [T-1 ~> s-1] + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + integer :: itt, filter_itts ! The number of iterations of the filter, set as 1/2 the power. + integer :: i, j, k, is, ie, js, je, nz, hs + + if (.not. CS%initialized) call MOM_error(FATAL, "MOM_interface_filter: "//& + "Module must be initialized before it is used.") + + if ((.not.CS%interface_filter) .or. (CS%filter_rate <= 0.0) .or. (CS%filter_order < 2)) return + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + h_neglect = GV%H_subroundoff + + filter_itts = CS%filter_order / 2 + Idt = 1.0 / dt + + if (filter_itts > min(G%isc-G%isd, G%jsc-G%jsd)) call MOM_error(FATAL, & + "interface_filter: The halos are not wide enough to accommodate the filter "//& + "order specified by INTERFACE_FILTER_ORDER.") + + ! Calculates interface heights, e, in [Z ~> m]. + call find_eta(h, tv, G, GV, US, e, halo_size=filter_itts) + + ! Set the smoothing length scales to apply at each iteration. + if (filter_itts == 1) then + filter_strength = min(CS%filter_rate*dt, CS%max_smoothing_CFL) + elseif (filter_itts == 2) then + filter_strength = min(sqrt(CS%filter_rate*dt), CS%max_smoothing_CFL) + else + filter_strength = min((CS%filter_rate*dt)**(1.0/filter_itts), CS%max_smoothing_CFL) + endif + hs = filter_itts-1 + if (CS%isotropic_filter) then + !$OMP parallel do default(shared) + do j=js-hs,je+hs ; do I=is-(hs+1),ie+hs + Lsm2_u(I,j) = (0.25*filter_strength) / ((G%IdxCu(I,j)**2) + (G%IdyCu(I,j)**2)) + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-(hs+1),je+hs ; do i=is-hs,ie+hs + Lsm2_v(i,J) = (0.25*filter_strength) / ((G%IdxCv(i,J)**2) + (G%IdyCv(i,J)**2)) + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=js-hs,je+hs ; do I=is-(hs+1),ie+hs + Lsm2_u(I,j) = (0.125*filter_strength) * (min(G%areaT(i,j), G%areaT(i+1,j)) * G%IdyCu(I,j))**2 + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-(hs+1),je+hs ; do i=is-hs,ie+hs + Lsm2_v(i,J) = (0.125*filter_strength) * (min(G%areaT(i,j), G%areaT(i,j+1)) * G%IdxCv(i,J))**2 + enddo ; enddo + endif + + if (CS%debug) then + call uvchksum("Kh_[uv]", Lsm2_u, Lsm2_v, G%HI, haloshift=hs, & + unscale=US%L_to_m**2, scalar_pair=.true.) + call hchksum(h, "interface_filter_1 h", G%HI, haloshift=hs+1, unscale=GV%H_to_m) + call hchksum(e, "interface_filter_1 e", G%HI, haloshift=hs+1, unscale=US%Z_to_m) + endif + + ! Calculate uhD, vhD from h, e, Lsm2_u, Lsm2_v + call filter_interface(h, e, Lsm2_u, Lsm2_v, uhD, vhD, tv, G, GV, US, halo_size=filter_itts-1) + + + do itt=2,filter_itts + hs = (filter_itts - itt) + 1 ! Set the halo size to work on. + !$OMP parallel do default(shared) + do j=js-hs,je+hs + do i=is-hs,ie+hs ; de_smooth(i,j,nz+1) = 0.0 ; enddo + + if (allocated(tv%SpV_avg)) then + ! This is the fully non-Boussinesq version. + do k=nz,1,-1 ; do i=is-hs,ie+hs + de_smooth(i,j,K) = de_smooth(i,j,K+1) + (GV%H_to_RZ * tv%SpV_avg(i,j,k)) * G%IareaT(i,j) * & + ((uhD(I,j,k) - uhD(I-1,j,k)) + (vhD(i,J,k) - vhD(i,J-1,k))) + enddo ; enddo + else + do k=nz,1,-1 ; do i=is-hs,ie+hs + de_smooth(i,j,K) = de_smooth(i,j,K+1) + GV%H_to_Z * G%IareaT(i,j) * & + ((uhD(I,j,k) - uhD(I-1,j,k)) + (vhD(i,J,k) - vhD(i,J-1,k))) + enddo ; enddo + endif + enddo + + ! Calculate uhD, vhD from h, de_smooth, Lsm2_u, Lsm2_v + call filter_interface(h, de_smooth, Lsm2_u, Lsm2_v, uhD, vhD, tv, G, GV, US, halo_size=filter_itts-itt) + enddo + + ! Offer diagnostic fields for averaging. This must occur before updating the layer thicknesses + ! so that the diagnostics can be remapped properly to other diagnostic vertical coordinates. + if (query_averaging_enabled(CS%diag)) then + if (CS%id_sfn_x > 0) then + diag_sfn_x(:,:,1) = 0.0 ; diag_sfn_x(:,:,nz+1) = 0.0 + do K=nz,2,-1 ; do j=js,je ; do I=is-1,ie + if (CS%id_sfn_x>0) diag_sfn_x(I,j,K) = diag_sfn_x(I,j,K+1) + uhD(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_sfn_x, diag_sfn_x, CS%diag) + endif + if (CS%id_sfn_y > 0) then + diag_sfn_y(:,:,1) = 0.0 ; diag_sfn_y(:,:,nz+1) = 0.0 + do K=nz,2,-1 ; do J=js-1,je ; do i=is,ie + diag_sfn_y(i,J,K) = diag_sfn_y(i,J,K+1) + vhD(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_sfn_y, diag_sfn_y, CS%diag) + endif + if (CS%id_uh_sm > 0) call post_data(CS%id_uh_sm, Idt*uhD(:,:,:), CS%diag) + if (CS%id_vh_sm > 0) call post_data(CS%id_vh_sm, Idt*vhD(:,:,:), CS%diag) + if (CS%id_L2_u > 0) call post_data(CS%id_L2_u, Lsm2_u, CS%diag) + if (CS%id_L2_v > 0) call post_data(CS%id_L2_v, Lsm2_v, CS%diag) + endif + + ! Update the layer thicknesses, and store the transports that will be needed for the tracers. + !$OMP parallel do default(shared) + do k=1,nz + do j=js,je ; do I=is-1,ie + uhtr(I,j,k) = uhtr(I,j,k) + uhD(I,j,k) + enddo ; enddo + do J=js-1,je ; do i=is,ie + vhtr(i,J,k) = vhtr(i,J,k) + vhD(i,J,k) + enddo ; enddo + do j=js,je ; do i=is,ie + h(i,j,k) = h(i,j,k) - G%IareaT(i,j) * & + ((uhD(I,j,k) - uhD(I-1,j,k)) + (vhD(i,J,k) - vhD(i,J-1,k))) + if (h(i,j,k) < GV%Angstrom_H) h(i,j,k) = GV%Angstrom_H + enddo ; enddo + + ! Store the transports associated with the smoothing if they are needed for diagnostics. + if (associated(CDp%uh_smooth)) then ; do j=js,je ; do I=is-1,ie + CDp%uh_smooth(I,j,k) = uhD(I,j,k)*Idt + enddo ; enddo ; endif + if (associated(CDp%vh_smooth)) then ; do J=js-1,je ; do i=is,ie + CDp%vh_smooth(i,J,k) = vhD(i,J,k)*Idt + enddo ; enddo ; endif + + enddo + + if (CS%debug) then + call uvchksum("interface_filter [uv]hD", uhD, vhD, & + G%HI, haloshift=0, unscale=GV%H_to_m*US%L_to_m**2) + call uvchksum("interface_filter [uv]htr", uhtr, vhtr, & + G%HI, haloshift=0, unscale=US%L_to_m**2*GV%H_to_m) + call hchksum(h, "interface_filter h", G%HI, haloshift=0, unscale=GV%H_to_m) + endif + +end subroutine interface_filter + +!> Calculates parameterized layer transports for use in the continuity equation. +!! Fluxes are limited to give positive definite thicknesses. +!! Called by interface_filter(). +subroutine filter_interface(h, e, Lsm2_u, Lsm2_v, uhD, vhD, tv, G, GV, US, halo_size) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface positions [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Lsm2_u !< Interface smoothing lengths squared + !! at u points [L2 ~> m2] + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Lsm2_v !< Interface smoothing lengths squared + !! at v points [L2 ~> m2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(out) :: uhD !< Zonal mass fluxes + !! [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: vhD !< Meridional mass fluxes + !! [H L2 ~> m3 or kg] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + integer, optional, intent(in) :: halo_size !< The size of the halo to work on, + !! 0 by default. + + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + h_avail ! The mass available for diffusion out of each face [H L2 ~> m3 or kg]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & + h_avail_rsum ! The running sum of h_avail above an interface [H L2 ~> m3 or kg]. + real :: uhtot(SZIB_(G),SZJ_(G)) ! The vertical sum of uhD [H L2 ~> m3 or kg]. + real :: vhtot(SZI_(G),SZJB_(G)) ! The vertical sum of vhD [H L2 ~> m3 or kg]. + real :: Slope ! The slope of density surfaces, calculated in a way that is always + ! between -1 and 1 after undoing dimensional scaling, [Z L-1 ~> nondim] + real :: Sfn_est ! A preliminary estimate (before limiting) of the overturning + ! streamfunction [H L2 ~> m3 or kg]. + real :: Sfn ! The overturning streamfunction [H L2 ~> m3 or kg]. + real :: Rho_avg ! The in situ density averaged to an interface [R ~> kg m-3] + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: hn_2 ! Half of h_neglect [H ~> m or kg m-2]. + integer :: i, j, k, is, ie, js, je, nz, hs + + hs = 0 ; if (present(halo_size)) hs = halo_size + is = G%isc-hs ; ie = G%iec+hs ; js = G%jsc-hs ; je = G%jec+hs ; nz = GV%ke + + h_neglect = GV%H_subroundoff ; hn_2 = 0.5*h_neglect + + ! Find the maximum and minimum permitted streamfunction. + !$OMP parallel do default(shared) + do j=js-1,je+1 + do i=is-1,ie+1 + h_avail_rsum(i,j,1) = 0.0 + h_avail(i,j,1) = max(0.25*G%areaT(i,j)*(h(i,j,1)-GV%Angstrom_H),0.0) + h_avail_rsum(i,j,2) = h_avail(i,j,1) + enddo + do k=2,nz ; do i=is-1,ie+1 + h_avail(i,j,k) = max(0.25*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) + h_avail_rsum(i,j,k+1) = h_avail_rsum(i,j,k) + h_avail(i,j,k) + enddo ; enddo + enddo + + !$OMP parallel do default(shared) private(Slope,Sfn_est,Sfn) + do j=js,je + do I=is-1,ie ; uhtot(I,j) = 0.0 ; enddo + do K=nz,2,-1 + do I=is-1,ie + Slope = (e(i,j,K)-e(i+1,j,K)) * G%IdxCu_OBCmask(I,j) + + if (allocated(tv%SpV_avg)) then + ! This is the fully non-Boussinesq version. + Rho_avg = ( ((h(i,j,k) + h(i,j,k-1)) + (h(i+1,j,k) + h(i+1,j,k-1))) + 4.0*hn_2 ) / & + ( ((h(i,j,k)+hn_2) * tv%SpV_avg(i,j,k) + (h(i,j,k-1)+hn_2) * tv%SpV_avg(i,j,k-1)) + & + ((h(i+1,j,k)+hn_2)*tv%SpV_avg(i+1,j,k) + (h(i+1,j,k-1)+hn_2)*tv%SpV_avg(i+1,j,k-1)) ) + Sfn_est = (Lsm2_u(I,j)*G%dy_Cu(I,j)) * (GV%RZ_to_H * Slope) * Rho_avg + else + Sfn_est = (Lsm2_u(I,j)*G%dy_Cu(I,j)) * (GV%Z_to_H * Slope) + endif + + ! Make sure that there is enough mass above to allow the streamfunction + ! to satisfy the boundary condition of 0 at the surface. + Sfn = min(max(Sfn_est, -h_avail_rsum(i,j,K)), h_avail_rsum(i+1,j,K)) + + ! The actual transport is limited by the mass available in the two + ! neighboring grid cells. + uhD(I,j,k) = max(min((Sfn - uhtot(I,j)), h_avail(i,j,k)), & + -h_avail(i+1,j,k)) + + ! sfn_x(I,j,K) = max(min(Sfn, uhtot(I,j)+h_avail(i,j,k)), & + ! uhtot(I,j)-h_avail(i+1,j,K)) + + uhtot(I,j) = uhtot(I,j) + uhD(I,j,k) + + enddo + enddo ! end of k-loop + + ! In layer 1, enforce the boundary conditions that Sfn(z=0) = 0.0 + do I=is-1,ie ; uhD(I,j,1) = -uhtot(I,j) ; enddo + enddo ! end of j-loop + + ! Calculate the meridional fluxes and gradients. + + !$OMP parallel do default(shared) private(Slope,Sfn_est,Sfn) + do J=js-1,je + do i=is,ie ; vhtot(i,J) = 0.0 ; enddo + do K=nz,2,-1 + do i=is,ie + Slope = (e(i,j,K)-e(i,j+1,K)) * G%IdyCv_OBCmask(i,J) + + if (allocated(tv%SpV_avg)) then + ! This is the fully non-Boussinesq version. + Rho_avg = ( ((h(i,j,k) + h(i,j,k-1)) + (h(i,j+1,k) + h(i,j+1,k-1))) + 4.0*hn_2 ) / & + ( ((h(i,j,k)+hn_2) * tv%SpV_avg(i,j,k) + (h(i,j,k-1)+hn_2) * tv%SpV_avg(i,j,k-1)) + & + ((h(i,j+1,k)+hn_2)*tv%SpV_avg(i,j+1,k) + (h(i,j+1,k-1)+hn_2)*tv%SpV_avg(i,j+1,k-1)) ) + Sfn_est = (Lsm2_v(i,J)*G%dx_Cv(i,J)) * (GV%RZ_to_H * Slope) * Rho_avg + else + Sfn_est = (Lsm2_v(i,J)*G%dx_Cv(i,J)) * (GV%Z_to_H * Slope) + endif + + ! Make sure that there is enough mass above to allow the streamfunction + ! to satisfy the boundary condition of 0 at the surface. + Sfn = min(max(Sfn_est, -h_avail_rsum(i,j,K)), h_avail_rsum(i,j+1,K)) + + ! The actual transport is limited by the mass available in the two neighboring grid cells. + vhD(i,J,k) = max(min((Sfn - vhtot(i,J)), h_avail(i,j,k)), -h_avail(i,j+1,k)) + + ! sfn_y(i,J,K) = max(min(Sfn, vhtot(i,J)+h_avail(i,j,k)), & + ! vhtot(i,J)-h_avail(i,j+1,k)) + + vhtot(i,J) = vhtot(i,J) + vhD(i,J,k) + + enddo + enddo ! end of k-loop + ! In layer 1, enforce the boundary conditions that Sfn(z=0) = 0.0 + do i=is,ie ; vhD(i,J,1) = -vhtot(i,J) ; enddo + enddo ! end of j-loop + +end subroutine filter_interface + +!> Initialize the interface height filtering module/structure +subroutine interface_filter_init(Time, G, GV, US, param_file, diag, CDp, CS) + type(time_type), intent(in) :: Time !< Current model time + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file handles + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure + type(cont_diag_ptrs), intent(inout) :: CDp !< Continuity equation diagnostics + type(interface_filter_CS), intent(inout) :: CS !< Control structure for interface height filtering + + ! Local variables + character(len=40) :: mdl = "MOM_interface_filter" ! This module's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" + real :: interface_filter_time ! The grid-scale interface height filtering timescale [T ~> s] + + CS%initialized = .true. + CS%diag => diag + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "INTERFACE_FILTER_TIME", interface_filter_time, & + "If positive, interface heights are subjected to a grid-scale "//& + "dependent biharmonic filter, using a rate based on this timescale.", & + default=0.0, units="s", scale=US%s_to_T) + CS%filter_rate = 0.0 + if (interface_filter_time > 0.0) CS%filter_rate = 1.0 / interface_filter_time + CS%interface_filter = (interface_filter_time > 0.0) + call get_param(param_file, mdl, "INTERFACE_FILTER_MAX_CFL", CS%max_smoothing_CFL, & + "The maximum value of the local CFL ratio that "//& + "is permitted for the interface height smoothing. 1.0 is the "//& + "marginally unstable value.", units="nondimensional", default=0.8) + if (CS%max_smoothing_CFL < 0.0) CS%max_smoothing_CFL = 0.0 + + call get_param(param_file, mdl, "INTERFACE_FILTER_ORDER", CS%filter_order, & + "The even power of the interface height smoothing. "//& + "At present valid values are 0, 2, 4 or 6.", default=4) + if (CS%filter_order == 0) then + CS%filter_rate = 0.0 + elseif ((CS%filter_order /= 2) .and. (CS%filter_order /= 4) .and. (CS%filter_order /= 6)) then + call MOM_error(FATAL, "Unsupported value of INTERFACE_FILTER_ORDER specified. "//& + "Only 0, 2, 4 or 6 are supported.") + endif + call get_param(param_file, mdl, "INTERFACE_FILTER_ISOTROPIC", CS%isotropic_filter, & + "If true, use the same filtering lengthscales in both directions; "//& + "otherwise use filtering lengthscales in each direction that scale "//& + "with the grid spacing in that direction.", default=.true.) + + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + + if (CS%filter_order > 0) then + CS%id_uh_sm = register_diag_field('ocean_model', 'uh_smooth', diag%axesCuL, Time, & + 'Interface Smoothing Zonal Thickness Flux', & + 'kg s-1', conversion=GV%H_to_kg_m2*US%L_to_m**2*US%s_to_T, & + y_cell_method='sum', v_extensive=.true.) + CS%id_vh_sm = register_diag_field('ocean_model', 'vh_smooth', diag%axesCvL, Time, & + 'Interface Smoothing Meridional Thickness Flux', & + 'kg s-1', conversion=GV%H_to_kg_m2*US%L_to_m**2*US%s_to_T, & + x_cell_method='sum', v_extensive=.true.) + + CS%id_L2_u = register_diag_field('ocean_model', 'Lsmooth2_u', diag%axesCu1, Time, & + 'Interface height smoothing length-scale squared at U-points', & + 'm2', conversion=US%L_to_m**2) + CS%id_L2_v = register_diag_field('ocean_model', 'Lsmooth2_u', diag%axesCv1, Time, & + 'Interface height smoothing length-scale squared at V-points', & + 'm2', conversion=US%L_to_m**2) + + CS%id_sfn_x = register_diag_field('ocean_model', 'Smooth_sfn_x', diag%axesCui, Time, & + 'Interface smoothing Zonal Overturning Streamfunction', & + 'm3 s-1', conversion=GV%H_to_m*US%L_to_m**2*US%s_to_T) + CS%id_sfn_y = register_diag_field('ocean_model', 'Smooth_sfn_y', diag%axesCvi, Time, & + 'Interface smoothing Meridional Overturning Streamfunction', & + 'm3 s-1', conversion=GV%H_to_m*US%L_to_m**2*US%s_to_T) + endif + +end subroutine interface_filter_init + +!> Deallocate the interface height filtering control structure +subroutine interface_filter_end(CS, CDp) + type(interface_filter_CS), intent(inout) :: CS !< Control structure for interface height filtering + type(cont_diag_ptrs), intent(inout) :: CDp !< Continuity diagnostic control structure + + ! NOTE: [uv]h_smooth are not yet used in diagnostics, but they are here for now for completeness. + if (associated(CDp%uh_smooth)) deallocate(CDp%uh_smooth) + if (associated(CDp%vh_smooth)) deallocate(CDp%vh_smooth) + +end subroutine interface_filter_end + +!> \namespace mom_interface_filter +!! +!! \section section_interface_filter Interface height filtering +!! +!! Interface height filtering is implemented via along-layer mass fluxes +!! \f[ +!! h^\dagger \leftarrow h^n - \Delta t \nabla \cdot ( \vec{uh}^* ) +!! \f] +!! where the mass fluxes are cast as the difference in vector streamfunction +!! +!! \f[ +!! \vec{uh}^* = \delta_k \vec{\psi} . +!! \f] +!! +!! The streamfunction is proportional to the slope in the difference between +!! unsmoothed interface heights and those smoothed with one (or more) passes of a Laplacian +!! filter, depending on the order of the filter, or to the slope for a Laplacian +!! filter +!! \f[ +!! \vec{\psi} = - \kappa_h {\nabla \eta - \eta_{smooth}} +!! \f] +!! +!! The result of the above expression is subsequently bounded by minimum and maximum values, including a +!! maximum smoothing rate for numerical stability (\f$ \kappa_{h} \f$ is calculated internally). +!! +!! \subsection section_filter_module_parameters Module mom_interface_filter parameters +!! +!! | Symbol | Module parameter | +!! | ------ | --------------- | +!! | - | APPLY_INTERFACE_FILTER | +!! | - | INTERFACE_FILTER_TIME | +!! | - | INTERFACE_FILTER_MAX_CFL | +!! | - | INTERFACE_FILTER_ORDER | +!! + +end module MOM_interface_filter diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index eb7d3a6340..0803a70841 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -1,47 +1,58 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Subroutines that use the ray-tracing equations to propagate the internal tide energy density. !! !! \author Benjamin Mater & Robert Hallberg, 2015 module MOM_internal_tides -! This file is part of MOM6. See LICENSE.md for the license. - +use MOM_checksums, only : hchksum use MOM_debugging, only : is_NaN use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_axis_init use MOM_diag_mediator, only : disable_averaging, enable_averages use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr use MOM_diag_mediator, only : axes_grp, define_axes_group -use MOM_domains, only : AGRID, To_South, To_West, To_All -use MOM_domains, only : create_group_pass, do_group_pass, pass_var +use MOM_domains, only : AGRID, To_South, To_West, To_All, CGRID_NE +use MOM_domains, only : create_group_pass, do_group_pass, pass_var, pass_vector use MOM_domains, only : group_pass_type, start_group_pass, complete_group_pass use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type +use MOM_forcing_type,only : forcing use MOM_grid, only : ocean_grid_type -use MOM_io, only : slasher, vardesc, MOM_read_data, file_exists +use MOM_int_tide_input, only: int_tide_input_CS, get_input_TKE, get_barotropic_tidal_vel +use MOM_io, only : slasher, MOM_read_data, file_exists, axis_info +use MOM_io, only : set_axis_info, get_axis_info, stdout use MOM_restart, only : register_restart_field, MOM_restart_CS, restart_init, save_restart -use MOM_spatial_means, only : global_area_mean +use MOM_restart, only : lock_check, restart_registry_lock +use MOM_spatial_means, only : global_area_integral +use MOM_string_functions, only: extract_real, uppercase use MOM_time_manager, only : time_type, time_type_to_real, operator(+), operator(/), operator(-) use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface, thermo_var_ptrs +use MOM_variables, only : surface, thermo_var_ptrs, vertvisc_type use MOM_verticalGrid, only : verticalGrid_type -use MOM_wave_structure, only: wave_structure_init, wave_structure, wave_structure_CS - -!use, intrinsic :: IEEE_ARITHMETIC +use MOM_wave_speed, only : wave_speeds, wave_speed_CS, wave_speed_init +use mpp_domains_mod, only : NORTH_FACE => NORTH, EAST_FACE => EAST implicit none ; private #include -public propagate_int_tide !, register_int_tide_restarts +public propagate_int_tide, register_int_tide_restarts public internal_tides_init, internal_tides_end -public get_lowmode_loss +public get_lowmode_loss, get_lowmode_diffusivity !> This control structure has parameters for the MOM_internal_tides module type, public :: int_tide_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. logical :: do_int_tides !< If true, use the internal tide code. integer :: nFreq = 0 !< The number of internal tide frequency bands integer :: nMode = 1 !< The number of internal tide vertical modes integer :: nAngle = 24 !< The number of internal tide angular orientations integer :: energized_angle = -1 !< If positive, only this angular band is energized for debugging purposes + real :: dt_itides !< The timestep for internal tides ray-tracing [T ~> s] + real :: uniform_test_cg !< Uniform group velocity of internal tide + !! for testing internal tides [L T-1 ~> m s-1] logical :: corner_adv !< If true, use a corner advection rather than PPM. logical :: upwind_1st !< If true, use a first-order upwind scheme. logical :: simple_2nd !< If true, use a simple second order (arithmetic mean) interpolation @@ -50,13 +61,27 @@ module MOM_internal_tides !! areas when estimating CFL numbers. Without aggress_adjust, !! the default is false; it is always true with aggress_adjust. logical :: use_PPMang !< If true, use PPM for advection of energy in angular space. - + logical :: update_Kd !< If true, the scheme will modify the diffusivities seen by the dynamics + logical :: apply_refraction !< If false, skip refraction (for debugging) + logical :: apply_propagation !< If False, do not propagate energy (for debugging) + logical :: turn_critical_lat !< If True, rays change direction at critical latitude instead + !! of being trapped + logical :: reflect_critical_lat !< If True, rays reflect at the critical latitude instead + !! of turning parallel to it + logical :: debug !< If true, use debugging prints + logical :: init_forcing_only !< if True, add TKE forcing only at first step (for debugging) + logical :: force_posit_En !< if True, remove subroundoff negative values (needs enhancement) + logical :: add_tke_forcing = .true. !< Whether to add forcing, used by init_forcing_only + + real, allocatable, dimension(:,:) :: fraction_tidal_input + !< how the energy from one tidal component is distributed + !! over the various vertical modes, 2d in frequency and mode [nondim] real, allocatable, dimension(:,:) :: refl_angle - !< local coastline/ridge/shelf angles read from file + !< local coastline/ridge/shelf angles read from file [rad] ! (could be in G control structure) - real :: nullangle = -999.9 !< placeholder value in cells with no reflection + real :: nullangle = -999.9 !< placeholder value in cells with no reflection [rad] real, allocatable, dimension(:,:) :: refl_pref - !< partial reflection coeff for each "coast cell" + !< partial reflection coeff for each "coast cell" [nondim] ! (could be in G control structure) logical, allocatable, dimension(:,:) :: refl_pref_logical !< true if reflecting cell with partial reflection @@ -65,40 +90,90 @@ module MOM_internal_tides !< identifies reflection cells where double reflection !! is possible (i.e. ridge cells) ! (could be in G control structure) + real, allocatable, dimension(:,:) :: trans + !< partial transmission coeff for each "coast cell" [nondim] + real, allocatable, dimension(:,:) :: residual + !< residual of reflection and transmission coeff for each "coast cell" [nondim] real, allocatable, dimension(:,:,:,:) :: cp !< horizontal phase speed [L T-1 ~> m s-1] real, allocatable, dimension(:,:,:,:,:) :: TKE_leak_loss - !< energy lost due to misc background processes [R Z3 T-3 ~> W m-2] + !< energy lost due to misc background processes [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:,:,:,:) :: TKE_quad_loss - !< energy lost due to quadratic bottom drag [R Z3 T-3 ~> W m-2] + !< energy lost due to quadratic bottom drag [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:,:,:,:) :: TKE_Froude_loss - !< energy lost due to wave breaking [R Z3 T-3 ~> W m-2] + !< energy lost due to wave breaking [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:) :: TKE_itidal_loss_fixed - !< Fixed part of the energy lost due to small-scale drag [R L-2 Z3 ~> kg m-2] here; - !! This will be multiplied by N and the squared near-bottom velocity to get - !! the energy losses in [R Z3 T-3 ~> W m-2] + !< Fixed part of the energy lost due to small-scale drag [H Z2 L-2 ~> kg m-2] here. + !! This will be multiplied by N and the squared near-bottom velocity (and by + !! the near-bottom density in non-Boussinesq mode) to get the energy losses + !! in [R Z4 H-1 L-2 ~> kg m-2 or m] real, allocatable, dimension(:,:,:,:,:) :: TKE_itidal_loss - !< energy lost due to small-scale wave drag [R Z3 T-3 ~> W m-2] - real, allocatable, dimension(:,:) :: tot_leak_loss !< Energy loss rates due to misc bakground processes, - !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + !< energy lost due to small-scale wave drag [H Z2 T-3 ~> m3 s-3 or W m-2] + real, allocatable, dimension(:,:,:,:,:) :: TKE_residual_loss + !< internal tide energy loss due to the residual at slopes [H Z2 T-3 ~> m3 s-3 or W m-2] + real, allocatable, dimension(:,:,:,:,:) :: TKE_slope_loss + !< internal tide energy loss due to the residual at slopes [H Z2 T-3 ~> m3 s-3 or W m-2] + real, allocatable, dimension(:,:) :: TKE_input_glo_dt + !< The integrated energy input to the internal waves [H Z2 L2 T-2 ~> m5 s-2 or J] + real, allocatable, dimension(:,:) :: TKE_leak_loss_glo_dt + !< Integrated energy lost due to misc background processes [H Z2 L2 T-2 ~> m5 s-2 or J] + real, allocatable, dimension(:,:) :: TKE_quad_loss_glo_dt + !< Integrated energy lost due to quadratic bottom drag [H Z2 L2 T-2 ~> m5 s-2 or J] + real, allocatable, dimension(:,:) :: TKE_Froude_loss_glo_dt + !< Integrated energy lost due to wave breaking [H Z2 L2 T-2 ~> m5 s-2 or J] + real, allocatable, dimension(:,:) :: TKE_itidal_loss_glo_dt + !< energy lost due to small-scale wave drag [H Z2 T-2 ~> m3 s-2 or J m-2] + real, allocatable, dimension(:,:) :: TKE_residual_loss_glo_dt + !< internal tide energy loss due to the residual at slopes [H Z2 L2 T-2 ~> m5 s-2 or J] + real, allocatable, dimension(:,:) :: error_mode + !< internal tide energy budget error for each mode [H Z2 L2 T-2 ~> m5 s-2 or J] + real, allocatable, dimension(:,:) :: tot_leak_loss !< Energy loss rates due to misc background processes, + !! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:) :: tot_quad_loss !< Energy loss rates due to quadratic bottom drag, - !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + !! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:) :: tot_itidal_loss !< Energy loss rates due to small-scale drag, - !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + !! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:) :: tot_Froude_loss !< Energy loss rates due to wave breaking, - !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + !! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or W m-2] + real, allocatable, dimension(:,:) :: tot_residual_loss !< Energy loss rates due to residual on slopes, + !! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable, dimension(:,:) :: tot_allprocesses_loss !< Energy loss rates due to all processes, - !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + !! summed over angle, frequency and mode [H Z2 T-3 ~> m3 s-3 or W m-2] + real, allocatable, dimension(:,:,:,:) :: w_struct !< Vertical structure of vertical velocity (normalized) + !! for each frequency and each mode [nondim] + real, allocatable, dimension(:,:,:,:) :: u_struct !< Vertical structure of horizontal velocity (normalized and + !! divided by layer thicknesses) for each frequency and each mode [Z-1 ~> m-1] + real, allocatable, dimension(:,:,:) :: u_struct_max !< Maximum of u_struct, + !! for each mode [Z-1 ~> m-1] + real, allocatable, dimension(:,:,:) :: u_struct_bot !< Bottom value of u_struct, + !! for each mode [Z-1 ~> m-1] + real, allocatable, dimension(:,:,:) :: int_w2 !< Vertical integral of w_struct squared, + !! for each mode [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: int_U2 !< Vertical integral of u_struct squared, + !! for each mode [H Z-2 ~> m-1 or kg m-4] + real, allocatable, dimension(:,:,:) :: int_N2w2 !< Depth-integrated Brunt Vaissalla freqency times + !! vertical profile squared, for each mode [H T-2 ~> m s-2 or kg m-2 s-2] real :: q_itides !< fraction of local dissipation [nondim] - real :: En_sum !< global sum of energy for use in debugging [R Z3 T-2 ~> J m-2] + real :: mixing_effic !< mixing efficiency [nondim] + real :: En_sum !< global sum of energy for use in debugging, in MKS units [m5 s-2 or J] + real :: En_underflow !< A minuscule amount of energy [H Z2 T-2 ~> m3 s-2 or J m-2] + integer :: En_restart_power !< A power factor of 2 by which to multiply the energy in restart [nondim] type(time_type), pointer :: Time => NULL() !< A pointer to the model's clock. + type(group_pass_type) :: pass_En !< Pass 5d array Energy as a group of 3d arrays character(len=200) :: inputdir !< directory to look for coastline angle file - real :: decay_rate !< A constant rate at which internal tide energy is - !! lost to the interior ocean internal wave field. + integer :: itides_adv_limiter !< The type of limiter to use for the energy advection scheme + real, allocatable, dimension(:,:,:,:) :: decay_rate_2d !< rate at which internal tide energy is + !! lost to the interior ocean internal wave field + !! as a function of longitude, latitude, frequency + !! and vertical mode [T-1 ~> s-1]. real :: cdrag !< The bottom drag coefficient [nondim]. real :: drag_min_depth !< The minimum total ocean thickness that will be used in the denominator !! of the quadratic drag terms for internal tides when - !! INTERNAL_TIDE_QUAD_DRAG is true [Z ~> m] + !! INTERNAL_TIDE_QUAD_DRAG is true [H ~> m or kg m-2] + real :: gamma_osborn !< Mixing efficiency from Osborn 1980 [nondim] + real :: Kd_min !< The minimum diapycnal diffusivity. [L2 T-1 ~> m2 s-1] + real :: max_TKE_to_Kd !< Maximum allowed value for TKE_to_kd [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: min_thick_layer_Kd !< minimum layer thickness allowed to use with TKE_to_kd [H ~> m or kg m-2] logical :: apply_background_drag !< If true, apply a drag due to background processes as a sink. logical :: apply_bottom_drag @@ -107,36 +182,81 @@ module MOM_internal_tides !< If true, apply scattering due to small-scale roughness as a sink. logical :: apply_Froude_drag !< If true, apply wave breaking as a sink. + real :: En_check_tol !< An energy density tolerance for flagging points with small negative + !! internal tide energy [H Z2 T-2 ~> m3 s-2 or J m-2] + logical :: apply_residual_drag + !< If true, apply sink from residual term of reflection/transmission. + logical :: use_2d_decay_rate + !< If true, use a spatially varying decay rate for each harmonic. real, allocatable :: En(:,:,:,:,:) !< The internal wave energy density as a function of (i,j,angle,frequency,mode) - !! integrated within an angular and frequency band [R Z3 T-2 ~> J m-2] - real, allocatable :: En_restart(:,:,:) - !< The internal wave energy density as a function of (i,j,angle); temporary for restart + !! integrated within an angular and frequency band [H Z2 T-2 ~> m3 s-2 or J m-2] + real, allocatable :: En_ini_glo(:,:) + !< The internal wave energy density as a function of (frequency,mode) spatially + !! integrated within an angular and frequency band [H Z2 L2 T-2 ~> m5 s-2 or J] + !! only at the start of the routine (for diags) + real, allocatable :: En_end_glo(:,:) + !< The internal wave energy density as a function of (frequency,mode) spatially + !! integrated within an angular and frequency band [H Z2 L2 T-2 ~> m5 s-2 or J] + !! only at the end of the routine (for diags) + real, allocatable :: En_restart_mode1(:,:,:,:) + !< The internal wave energy density as a function of (i,j,angle,freq) + !! for mode 1 [H Z2 T-2 ~> m3 s-2 or J m-2] + real, allocatable :: En_restart_mode2(:,:,:,:) + !< The internal wave energy density as a function of (i,j,angle,freq) + !! for mode 2 [H Z2 T-2 ~> m3 s-2 or J m-2] + real, allocatable :: En_restart_mode3(:,:,:,:) + !< The internal wave energy density as a function of (i,j,angle,freq) + !! for mode 3 [H Z2 T-2 ~> m3 s-2 or J m-2] + real, allocatable :: En_restart_mode4(:,:,:,:) + !< The internal wave energy density as a function of (i,j,angle,freq) + !! for mode 4 [H Z2 T-2 ~> m3 s-2 or J m-2] + real, allocatable :: En_restart_mode5(:,:,:,:) + !< The internal wave energy density as a function of (i,j,angle,freq) + !! for mode 5 [H Z2 T-2 ~> m3 s-2 or J m-2] + real, allocatable, dimension(:) :: frequency !< The frequency of each band [T-1 ~> s-1]. + real :: Int_tide_decay_scale !< vertical decay scale for St Laurent profile [Z ~> m] + real :: Int_tide_decay_scale_slope !< vertical decay scale for St Laurent profile on slopes [Z ~> m] + type(wave_speed_CS) :: wave_speed !< Wave speed control structure type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the !! timing of diagnostic output. - type(wave_structure_CS) :: wave_struct !< Wave structure control struct !>@{ Diag handles ! Diag handles relevant to all modes, frequencies, and angles - integer :: id_tot_En = -1, id_TKE_itidal_input = -1, id_itide_drag = -1 + integer :: id_cg1 = -1 ! diagnostic handle for mode-1 speed + integer, allocatable, dimension(:) :: id_cn ! diagnostic handle for all mode speeds + integer :: id_tot_En = -1 integer :: id_refl_pref = -1, id_refl_ang = -1, id_land_mask = -1 + integer :: id_trans = -1, id_residual = -1 integer :: id_dx_Cv = -1, id_dy_Cu = -1 ! Diag handles considering: sums over all modes, frequencies, and angles integer :: id_tot_leak_loss = -1, id_tot_quad_loss = -1, id_tot_itidal_loss = -1 - integer :: id_tot_Froude_loss = -1, id_tot_allprocesses_loss = -1 - ! Diag handles considering: all modes & freqs; summed over angles + integer :: id_tot_Froude_loss = -1, id_tot_residual_loss = -1, id_tot_allprocesses_loss = -1 + ! Diag handles considering: all modes & frequencies; summed over angles integer, allocatable, dimension(:,:) :: & id_En_mode, & id_itidal_loss_mode, & + id_leak_loss_mode, & + id_quad_loss_mode, & + id_Froude_loss_mode, & + id_residual_loss_mode, & id_allprocesses_loss_mode, & + id_itide_drag, & id_Ub_mode, & id_cp_mode - ! Diag handles considering: all modes, freqs, and angles + ! Diag handles considering: all modes, frequencies, and angles integer, allocatable, dimension(:,:) :: & id_En_ang_mode, & id_itidal_loss_ang_mode + integer, allocatable, dimension(:) :: & + id_TKE_itidal_input, & + id_Ustruct_mode, & + id_Wstruct_mode, & + id_int_w2_mode, & + id_int_U2_mode, & + id_int_N2w2_mode !>@} end type int_tide_CS @@ -148,12 +268,18 @@ module MOM_internal_tides !>@} end type loop_bounds_type +!>@{ Enumeration values for numerical schemes +integer, parameter :: LIMITER_ADV_MINMOD = 1 +integer, parameter :: LIMITER_ADV_POSITIVE = 2 +character*(20), parameter :: LIMITER_ADV_MINMOD_STRING = "MINMOD" +character*(20), parameter :: LIMITER_ADV_POSITIVE_STRING = "POSITIVE" +!>@} + contains !> Calls subroutines in this file that are needed to refract, propagate, !! and dissipate energy density of the internal tide. -subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & - G, GV, US, CS) +subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_CSp, CS) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -161,170 +287,411 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Pointer to thermodynamic variables !! (needed for wave structure). - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: TKE_itidal_input !< The energy input to the - !! internal waves [R Z3 T-3 ~> W m-2]. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: vel_btTide !< Barotropic velocity read - !! from file [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Nb !< Near-bottom buoyancy frequency [T-1 ~> s-1]. + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: Nb !< Near-bottom buoyancy frequency [T-1 ~> s-1]. + !! In some cases the input values are used, but in + !! others this is set along with the wave speeds. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Rho_bot !< Near-bottom density or the Boussinesq + !! reference density [R ~> kg m-3]. real, intent(in) :: dt !< Length of time over which to advance !! the internal tides [T ~> s]. - type(int_tide_CS), intent(inout) :: CS !< Internal tide control struct - real, dimension(SZI_(G),SZJ_(G),CS%nMode), & - intent(in) :: cn !< The internal wave speeds of each - !! mode [L T-1 ~> m s-1]. + type(int_tide_input_CS), intent(in) :: inttide_input_CSp !< Internal tide input control structure + type(int_tide_CS), intent(inout) :: CS !< Internal tide control structure + ! Local variables + real, dimension(SZI_(G),SZJ_(G),CS%nFreq) :: & + TKE_itidal_input, & !< The energy input to the internal waves [H Z2 T-3 ~> m3 s-3 or W m-2]. + vel_btTide !< Barotropic velocity read from file [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),2) :: & - test + test ! A test unit vector used to determine grid rotation in halos [nondim] + real, dimension(SZI_(G),SZJ_(G),CS%nMode) :: & + cn ! baroclinic internal gravity wave speeds for each mode [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),CS%nFreq,CS%nMode) :: & - tot_En_mode, & ! energy summed over angles only [R Z3 T-2 ~> J m-2] + tot_En_mode, & ! energy summed over angles only [H Z2 T-2 ~> m3 s-2 or J m-2] Ub, & ! near-bottom horizontal velocity of wave (modal) [L T-1 ~> m s-1] Umax ! Maximum horizontal velocity of wave (modal) [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJB_(G)) :: & - flux_heat_y, & - flux_prec_y + real, dimension(SZI_(G),SZJ_(G),CS%nFreq,CS%nMode) :: & + drag_scale ! bottom drag scale [T-1 ~> s-1] real, dimension(SZI_(G),SZJ_(G)) :: & - tot_En, & ! energy summed over angles, modes, frequencies [R Z3 T-2 ~> J m-2] - tot_leak_loss, tot_quad_loss, tot_itidal_loss, tot_Froude_loss, tot_allprocesses_loss, & - ! energy loss rates summed over angle, freq, and mode [R Z3 T-3 ~> W m-2] + tot_vel_btTide2, & ! [L2 T-2 ~> m2 s-2] + tot_En, & ! energy summed over angles, modes, frequencies [H Z2 T-2 ~> m3 s-2 or J m-2] + tot_leak_loss, tot_quad_loss, tot_itidal_loss, tot_Froude_loss, tot_residual_loss, tot_allprocesses_loss, & + ! energy loss rates summed over angle, freq, and mode [H Z2 T-3 ~> m3 s-3 or W m-2] htot, & ! The vertical sum of the layer thicknesses [H ~> m or kg m-2] - drag_scale, & ! bottom drag scale [T-1 ~> s-1] - itidal_loss_mode, allprocesses_loss_mode - ! energy loss rates for a given mode and frequency (summed over angles) [R Z3 T-3 ~> W m-2] - real :: frac_per_sector, f2, Kmag2 - real :: I_D_here ! The inverse of the local depth [Z-1 ~> m-1] - real :: I_rho0 ! The inverse fo the Boussinesq density [R-1 ~> m3 kg-1] - real :: freq2 ! The frequency squared [T-2 ~> s-2] - real :: c_phase ! The phase speed [L T-1 ~> m s-1] - real :: loss_rate ! An energy loss rate [T-1 ~> s-1] - real :: Fr2_max + itidal_loss_mode, & ! Energy lost due to small-scale wave drag, summed over angles [H Z2 T-3 ~> m3 s-3 or W m-2] + leak_loss_mode, & + quad_loss_mode, & + Froude_loss_mode, & + residual_loss_mode, & + allprocesses_loss_mode ! Total energy loss rates for a given mode and frequency (summed over + ! all angles) [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: frac_per_sector ! The inverse of the number of angular, modal and frequency bins [nondim] + real :: f2 ! The squared Coriolis parameter interpolated to a tracer point [T-2 ~> s-2] + real :: Kmag2 ! A squared horizontal wavenumber [L-2 ~> m-2] + real :: I_D_here ! The inverse of the local water column thickness [H-1 ~> m-1 or m2 kg-1] + real :: I_mass ! The inverse of the local water mass [R-1 Z-1 ~> m2 kg-1] + real :: I_dt ! The inverse of the timestep [T-1 ~> s-1] + real :: dt_sub ! The effective timestep use to subcycle the propagation [T ~> s] + real :: En_restart_factor ! A multiplicative factor of the form 2**En_restart_power [nondim] + real :: I_En_restart_factor ! The inverse of the restart mult factor [nondim] + real :: freq2 ! The frequency squared [T-2 ~> s-2] + real :: PE_term ! total potential energy of profile [R Z ~> kg m-2] + real :: KE_term ! total kinetic energy of profile [R Z ~> kg m-2] + real :: U_mag ! rescaled magnitude of horizontal profile [L Z T-1 ~> m2 s-1] + real :: W0 ! rescaled magnitude of vertical profile [Z T-1 ~> m s-1] + real :: c_phase ! The phase speed [L T-1 ~> m s-1] + ! real :: loss_rate ! An energy loss rate [T-1 ~> s-1] + real :: Fr2_max ! The column maximum internal wave Froude number squared [nondim] real :: cn_subRO ! A tiny wave speed to prevent division by zero [L T-1 ~> m s-1] - real :: En_new, En_check ! Energies for debugging [R Z3 T-2 ~> J m-2] - real :: En_initial, Delta_E_check ! Energies for debugging [R Z3 T-2 ~> J m-2] - real :: TKE_Froude_loss_check, TKE_Froude_loss_tot ! Energy losses for debugging [R Z3 T-3 ~> W m-2] + real :: en_subRO ! A tiny energy to prevent division by zero [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: En_a, En_b ! Energies for time stepping [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: En_sumtmp ! Energies for debugging [H Z2 L2 T-2 ~> m5 s-2 or J] + real :: HZ2_T2_to_J_m2 ! unit conversion factor for Energy from internal units + ! to mks [T2 kg H-1 Z-2 s-2 ~> kg m-3 or 1] + real :: J_m2_to_HZ2_T2 ! unit conversion factor for Energy from mks to internal + ! units [H Z2 s2 T-2 kg-1 ~> m3 kg-1 or 1] character(len=160) :: mesg ! The text of an error message - integer :: a, m, fr, i, j, k, is, ie, js, je, isd, ied, jsd, jed, nAngle, nzm + integer :: En_halo_ij_stencil ! The halo size needed for energy advection + integer :: a, m, fr, i, j, k, is, ie, js, je, isd, ied, jsd, jed, nAngle, nc integer :: id_g, jd_g ! global (decomp-invar) indices (for debugging) - type(group_pass_type), save :: pass_test, pass_En + integer :: subcycles ! number of subcycles for the propagation + type(group_pass_type), save :: pass_test type(time_type) :: time_end logical:: avg_enabled is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nAngle = CS%NAngle - I_rho0 = 1.0 / GV%Rho0 - cn_subRO = 1e-100*US%m_s_to_L_T ! The hard-coded value here might need to increase. - ! init local arrays - drag_scale(:,:) = 0. + HZ2_T2_to_J_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**2) + J_m2_to_HZ2_T2 = GV%kg_m2_to_H*(US%m_to_Z**2)*(US%T_to_s**2) + + cn_subRO = 1e-30*US%m_s_to_L_T + en_subRO = 1e-30*J_m2_to_HZ2_T2 + + I_dt = 1.0 / dt + En_restart_factor = 2**CS%En_restart_power + I_En_restart_factor = 1.0 / En_restart_factor + + if (CS%dt_itides <= 0.) then + subcycles = 1 + else + subcycles = CEILING(dt/CS%dt_itides - 0.0001) + endif + dt_sub = dt / subcycles + + ! initialize local arrays + TKE_itidal_input(:,:,:) = 0. + vel_btTide(:,:,:) = 0. + tot_vel_btTide2(:,:) = 0. + drag_scale(:,:,:,:) = 0. Ub(:,:,:,:) = 0. + Umax(:,:,:,:) = 0. + + cn(:,:,:) = 0. + + ! Rebuild energy density array from multiple restarts + do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,1) = CS%En_restart_mode1(i,j,a,fr) * I_En_restart_factor + enddo ; enddo ; enddo ; enddo + + if (CS%nMode >= 2) then + do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,2) = CS%En_restart_mode2(i,j,a,fr) * I_En_restart_factor + enddo ; enddo ; enddo ; enddo + endif + + if (CS%nMode >= 3) then + do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,3) = CS%En_restart_mode3(i,j,a,fr) * I_En_restart_factor + enddo ; enddo ; enddo ; enddo + endif + + if (CS%nMode >= 4) then + do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,4) = CS%En_restart_mode4(i,j,a,fr) * I_En_restart_factor + enddo ; enddo ; enddo ; enddo + endif + + if (CS%nMode >= 5) then + do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,5) = CS%En_restart_mode5(i,j,a,fr) * I_En_restart_factor + enddo ; enddo ; enddo ; enddo + endif + + if (CS%debug) then + ! save initial energy for online budget + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%En(:,:,a,fr,m), G, tmp_scale=HZ2_T2_to_J_m2) + enddo + CS%En_ini_glo(fr,m) = En_sumtmp + enddo ; enddo + endif + + ! Set properties related to the internal tides, such as the wave speeds, storing some + ! of them in the control structure for this module. + if (CS%uniform_test_cg > 0.0) then + do m=1,CS%nMode ; cn(:,:,m) = CS%uniform_test_cg ; enddo + else + call wave_speeds(h, tv, G, GV, US, CS%nMode, cn, CS%wave_speed, & + CS%w_struct, CS%u_struct, CS%u_struct_max, CS%u_struct_bot, & + Nb, CS%int_w2, CS%int_U2, CS%int_N2w2, halo_size=2) + ! The value of halo_size above would have to be larger if there were + ! not a halo update between the calls to propagate_x and propagate_y. + ! It can be 1 point smaller if teleport is not used. + endif + + call pass_var(cn,G%Domain) + + if (CS%debug) then + call hchksum(cn(:,:,1), "CN mode 1", G%HI, haloshift=0, unscale=US%L_to_m*US%s_to_T) + call hchksum(CS%w_struct(:,:,:,1), "Wstruct mode 1", G%HI, haloshift=0) + call hchksum(CS%u_struct(:,:,:,1), "Ustruct mode 1", G%HI, haloshift=0, unscale=US%m_to_Z) + call hchksum(CS%u_struct_bot(:,:,1), "Ustruct_bot mode 1", G%HI, haloshift=0, unscale=US%m_to_Z) + call hchksum(CS%u_struct_max(:,:,1), "Ustruct_max mode 1", G%HI, haloshift=0, unscale=US%m_to_Z) + call hchksum(CS%int_w2(:,:,1), "int_w2", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(CS%int_U2(:,:,1), "int_U2", G%HI, haloshift=0, unscale=GV%H_to_mks*US%m_to_Z**2) + call hchksum(CS%int_N2w2(:,:,1), "int_N2w2", G%HI, haloshift=0, unscale=GV%H_to_mks*US%s_to_T**2) + endif ! Set the wave speeds for the modes, using cg(n) ~ cg(1)/n.********************** ! This is wrong, of course, but it works reasonably in some cases. ! Uncomment if wave_speed is not used to calculate the true values (BDM). - !do m=1,CS%nMode ; do j=jsd,jed ; do i=isd,ied + !do m=1,CS%nMode ; do j=js-2,je+2 ; do i=is-2,ie+2 ! cn(i,j,m) = cn(i,j,1) / real(m) !enddo ; enddo ; enddo ! Add the forcing.*************************************************************** - if (CS%energized_angle <= 0) then - frac_per_sector = 1.0 / real(CS%nAngle * CS%nMode * CS%nFreq) - do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie - f2 = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & - (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) - if (CS%frequency(fr)**2 > f2) & - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt*frac_per_sector*(1.0-CS%q_itides) * & - TKE_itidal_input(i,j) - enddo ; enddo ; enddo ; enddo ; enddo - elseif (CS%energized_angle <= CS%nAngle) then - frac_per_sector = 1.0 / real(CS%nMode * CS%nFreq) - a = CS%energized_angle - do m=1,CS%nMode ; do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie - f2 = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & - (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) - if (CS%frequency(fr)**2 > f2) & - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt*frac_per_sector*(1.0-CS%q_itides) * & - TKE_itidal_input(i,j) - enddo ; enddo ; enddo ; enddo - else - call MOM_error(WARNING, "Internal tide energy is being put into a angular "//& - "band that does not exist.") + + if (CS%add_tke_forcing) then + + call get_input_TKE(G, TKE_itidal_input, CS%nFreq, inttide_input_CSp) + + if (CS%debug) then + call hchksum(TKE_itidal_input(:,:,1), "TKE_itidal_input", G%HI, haloshift=0, & + unscale=GV%H_to_mks*(US%Z_to_m**2)*(US%s_to_T)**3) + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides bf input", G%HI, haloshift=0, unscale=HZ2_T2_to_J_m2) + endif + + if (CS%energized_angle <= 0) then + frac_per_sector = 1.0 / real(CS%nAngle) + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie + f2 = 0.25*((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + & + (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) + if (CS%frequency(fr)**2 > f2) then + CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + (dt*frac_per_sector*(1.0-CS%q_itides) * & + CS%fraction_tidal_input(fr,m) * TKE_itidal_input(i,j,fr)) + else + ! zero out input TKE value to get correct diagnostics + TKE_itidal_input(i,j,fr) = 0. + endif + enddo ; enddo ; enddo ; enddo ; enddo + elseif (CS%energized_angle <= CS%nAngle) then + frac_per_sector = 1.0 + a = CS%energized_angle + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie + f2 = 0.25*((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + & + (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) + if (CS%frequency(fr)**2 > f2) then + CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + (dt*frac_per_sector*(1.0-CS%q_itides) * & + CS%fraction_tidal_input(fr,m) * TKE_itidal_input(i,j,fr)) + else + ! zero out input TKE value to get correct diagnostics + TKE_itidal_input(i,j,fr) = 0. + endif + enddo ; enddo ; enddo ; enddo + else + call MOM_error(WARNING, "Internal tide energy is being put into a angular "//& + "band that does not exist.") + endif + endif ! add tke forcing + + if (CS%init_forcing_only) CS%add_tke_forcing=.false. + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af input", G%HI, haloshift=0, unscale=HZ2_T2_to_J_m2) + ! save forcing for online budget + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(dt*frac_per_sector*(1.0-CS%q_itides)* & + CS%fraction_tidal_input(fr,m)*TKE_itidal_input(:,:,fr), & + G, tmp_scale=HZ2_T2_to_J_m2) + enddo + CS%TKE_input_glo_dt(fr,m) = En_sumtmp + enddo ; enddo endif ! Pass a test vector to check for grid rotation in the halo updates. - do j=jsd,jed ; do i=isd,ied ; test(i,j,1) = 1.0 ; test(i,j,2) = 0.0 ; enddo ; enddo - do m=1,CS%nMode ; do fr=1,CS%nFreq - call create_group_pass(pass_En, CS%En(:,:,:,fr,m), G%domain) - enddo ; enddo + do j=jsd,jed ; do i=isd,ied ; test(i,j,1) = 0.0 ; test(i,j,2) = 1.0 ; enddo ; enddo call create_group_pass(pass_test, test(:,:,1), test(:,:,2), G%domain, stagger=AGRID) call start_group_pass(pass_test, G%domain) - ! Apply half the refraction. - do m=1,CS%nMode ; do fr=1,CS%nFreq - call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, & - G, US, CS%nAngle, CS%use_PPMang) - enddo ; enddo - - ! Check for En<0 - for debugging, delete later - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - write(mesg,*) 'After first refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=',CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) - CS%En(i,j,a,fr,m) = 0.0 -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") - endif + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af halo", G%HI, haloshift=0, unscale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after forcing') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after forcing', CS%En_sum enddo ; enddo - enddo ; enddo ; enddo - - call do_group_pass(pass_En, G%domain) + endif call complete_group_pass(pass_test, G%domain) - ! Rotate points in the halos as necessary. - call correct_halo_rotation(CS%En, test, G, CS%nAngle) + ! TKE_slope_loss need to be accumulated but since it is + ! passed as inout and accumulated within propagate_x/propagate_y + ! it does not need temp array for accumulation + CS%TKE_slope_loss(:,:,:,:,:) = 0. - ! Propagate the waves. - do m=1,CS%NMode ; do fr=1,CS%Nfreq - call propagate(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), dt, & - G, US, CS, CS%NAngle) - enddo ; enddo + ! Start subcycling + do nc=1,subcycles - ! Check for En<0 - for debugging, delete later - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset - if (abs(CS%En(i,j,a,fr,m))>1.0) then ! only print if large - write(mesg,*) 'After propagation: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=', CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + ! Apply half the refraction. + if (CS%apply_refraction) then + do m=1,CS%nMode ; do fr=1,CS%nFreq + call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt_sub, & + G, US, CS%nAngle, CS%use_PPMang) + enddo ; enddo + endif + ! A this point, CS%En is only valid on the computational domain. + + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af refr", G%HI, haloshift=0, unscale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after 1/2 refraction') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after 1/2 refraction', CS%En_sum + enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After first refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=', HZ2_T2_to_J_m2*CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + ! Set the halo size to work on, using similar logic to that used in propagate. This may need + ! to be adjusted depending on the advection scheme and whether teleport is used. + if (CS%upwind_1st) then ; En_halo_ij_stencil = 2 + else ; En_halo_ij_stencil = 3 ; endif + + ! Rotate points in the halos as necessary. + call do_group_pass(CS%pass_En, G%domain) + call correct_halo_rotation(CS%En, test, G, CS%nAngle, halo=En_halo_ij_stencil) + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af halo R", G%HI, haloshift=0, unscale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after correct halo rotation') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after correct halo rotation', CS%En_sum + enddo ; enddo + endif + + ! Propagate the waves. + do m=1,CS%nMode ; do fr=1,CS%Nfreq + + if (CS%apply_propagation) then + call propagate(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), dt_sub, & + G, GV, US, CS, CS%NAngle, test(:,:,:), En_halo_ij_stencil, CS%TKE_slope_loss(:,:,:,fr,m)) endif - CS%En(i,j,a,fr,m) = 0.0 - endif enddo ; enddo - enddo ; enddo ; enddo - ! Apply the other half of the refraction. - do m=1,CS%NMode ; do fr=1,CS%Nfreq - call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, & - G, US, CS%NAngle, CS%use_PPMang) - enddo ; enddo + ! Rotate points in the halos as necessary. + call do_group_pass(CS%pass_En, G%domain) + call correct_halo_rotation(CS%En, test, G, CS%nAngle, halo=En_halo_ij_stencil) - ! Check for En<0 - for debugging, delete later - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - write(mesg,*) 'After second refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=',CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) - CS%En(i,j,a,fr,m) = 0.0 -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") - endif - enddo ; enddo - enddo ; enddo ; enddo + + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af prop", G%HI, haloshift=0, unscale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after propagate') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after propagate', CS%En_sum + enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset + if (abs(CS%En(i,j,a,fr,m))>CS%En_check_tol) then ! only print if large + write(mesg,*) 'After propagation: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=', HZ2_T2_to_J_m2*CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) + ! RD propagate produces very little negative energy (diff 2 large numbers), needs fix + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%apply_refraction) then + ! Apply the other half of the refraction. + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt_sub, & + G, US, CS%NAngle, CS%use_PPMang) + enddo ; enddo + ! A this point, CS%En is only valid on the computational domain. + endif + + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides af refr2", G%HI, haloshift=0, unscale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after 2/2 refraction') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after 2/2 refraction', CS%En_sum + enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After second refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=', HZ2_T2_to_J_m2*CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + call do_group_pass(CS%pass_En, G%domain) + call correct_halo_rotation(CS%En, test, G, CS%nAngle, halo=En_halo_ij_stencil) + + enddo ! end subcycling ! Apply various dissipation mechanisms. if (CS%apply_background_drag .or. CS%apply_bottom_drag & @@ -332,8 +699,8 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & .or. (CS%id_tot_En > 0)) then tot_En(:,:) = 0.0 tot_En_mode(:,:,:,:) = 0.0 - do m=1,CS%NMode ; do fr=1,CS%Nfreq - do j=jsd,jed ; do i=isd,ied ; do a=1,CS%nAngle + do m=1,CS%nMode ; do fr=1,CS%Nfreq + do j=js,je ; do i=is,ie ; do a=1,CS%nAngle tot_En(i,j) = tot_En(i,j) + CS%En(i,j,a,fr,m) tot_En_mode(i,j,fr,m) = tot_En_mode(i,j,fr,m) + CS%En(i,j,a,fr,m) enddo ; enddo ; enddo @@ -342,184 +709,385 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & ! Extract the energy for mixing due to misc. processes (background leakage)------ if (CS%apply_background_drag) then - do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied - ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale - ! to each En component (technically not correct; fix later) - CS%TKE_leak_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * CS%decay_rate ! loss rate [R Z3 T-3 ~> W m-2] - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt * CS%decay_rate) ! implicit update + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie + ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale + ! to each En component (technically not correct; fix later) + En_b = CS%En(i,j,a,fr,m) ! save previous value + En_a = CS%En(i,j,a,fr,m) / (1.0 + (dt * CS%decay_rate_2d(i,j,fr,m))) ! implicit update + CS%TKE_leak_loss(i,j,a,fr,m) = (En_b - En_a) * I_dt ! compute exact loss rate [H Z2 T-3 ~> m3 s-3 or W m-2] + CS%En(i,j,a,fr,m) = En_a ! update value enddo ; enddo ; enddo ; enddo ; enddo endif - ! Check for En<0 - for debugging, delete later - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - write(mesg,*) 'After leak loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=',CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) - CS%En(i,j,a,fr,m) = 0.0 -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") - endif + + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after leak", G%HI, haloshift=0, unscale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after background drag') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after background drag', CS%En_sum + call sum_En(G, GV, US, CS, CS%TKE_leak_loss(:,:,:,fr,m) * dt, 'prop_int_tide: loss after background drag') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: loss after background drag', CS%En_sum enddo ; enddo - enddo ; enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After leak loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=', HZ2_T2_to_J_m2*CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + ! save loss term for online budget + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%TKE_leak_loss(:,:,a,fr,m)*dt, G, & + tmp_scale=HZ2_T2_to_J_m2) + enddo + CS%TKE_leak_loss_glo_dt(fr,m) = En_sumtmp + enddo ; enddo + endif ! Extract the energy for mixing due to bottom drag------------------------------- if (CS%apply_bottom_drag) then do j=jsd,jed ; do i=isd,ied ; htot(i,j) = 0.0 ; enddo ; enddo + + call get_barotropic_tidal_vel(G, vel_btTide, CS%nFreq, inttide_input_CSp) + + do fr=1,CS%Nfreq ; do j=jsd,jed ; do i=isd,ied + tot_vel_btTide2(i,j) = tot_vel_btTide2(i,j) + (vel_btTide(i,j,fr)**2) + enddo ; enddo ; enddo + do k=1,GV%ke ; do j=jsd,jed ; do i=isd,ied htot(i,j) = htot(i,j) + h(i,j,k) enddo ; enddo ; enddo - do j=jsd,jed ; do i=isd,ied - I_D_here = 1.0 / (max(GV%H_to_Z*htot(i,j), CS%drag_min_depth)) - drag_scale(i,j) = CS%cdrag * sqrt(max(0.0, US%L_to_Z**2*vel_btTide(i,j)**2 + & - tot_En(i,j) * I_rho0 * I_D_here)) * I_D_here - enddo ; enddo - do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + if (GV%Boussinesq) then + ! This is mathematically equivalent to the form in the option below, but they differ at roundoff. + do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do j=jsd,jed ; do i=isd,ied + I_D_here = 1.0 / (max(htot(i,j), CS%drag_min_depth)) + drag_scale(i,j,fr,m) = CS%cdrag * sqrt(max(0.0, US%L_to_Z**2*tot_vel_btTide2(i,j) + & + (tot_En_mode(i,j,fr,m) * I_D_here))) * GV%Z_to_H*I_D_here + enddo ; enddo ; enddo ; enddo + else + do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do j=jsd,jed ; do i=isd,ied + I_D_here = 1.0 / (max(htot(i,j), CS%drag_min_depth)) + I_mass = GV%RZ_to_H * I_D_here + drag_scale(i,j,fr,m) = (CS%cdrag * (Rho_bot(i,j)*I_mass)) * & + sqrt(max(0.0, US%L_to_Z**2*tot_vel_btTide2(i,j) + & + (tot_En_mode(i,j,fr,m) * I_D_here))) + enddo ; enddo ; enddo ; enddo + endif + + if (CS%debug) call hchksum(drag_scale(:,:,1,1), "dragscale", G%HI, haloshift=0, unscale=US%s_to_T) + if (CS%debug) call hchksum(tot_vel_btTide2(:,:), "tot_vel_btTide2", G%HI, haloshift=0, unscale=US%L_T_to_m_s**2) + + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale ! to each En component (technically not correct; fix later) - CS%TKE_quad_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * drag_scale(i,j) ! loss rate - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt * drag_scale(i,j)) ! implicit update + En_b = CS%En(i,j,a,fr,m) + En_a = CS%En(i,j,a,fr,m) / (1.0 + (dt * drag_scale(i,j,fr,m))) ! implicit update + CS%TKE_quad_loss(i,j,a,fr,m) = (En_b - En_a) * I_dt + CS%En(i,j,a,fr,m) = En_a enddo ; enddo ; enddo ; enddo ; enddo endif - ! Check for En<0 - for debugging, delete later - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - write(mesg,*) 'After bottom loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=',CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) - CS%En(i,j,a,fr,m) = 0.0 -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") - !stop - endif + + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after quad", G%HI, haloshift=0, unscale=HZ2_T2_to_J_m2) + ! save loss term for online budget + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%TKE_quad_loss(:,:,a,fr,m)*dt, G, & + tmp_scale=HZ2_T2_to_J_m2) + enddo + CS%TKE_quad_loss_glo_dt(fr,m) = En_sumtmp enddo ; enddo - enddo ; enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After bottom loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=', HZ2_T2_to_J_m2*CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + endif ! Extract the energy for mixing due to scattering (wave-drag)-------------------- ! still need to allow a portion of the extracted energy to go to higher modes. ! First, find velocity profiles if (CS%apply_wave_drag .or. CS%apply_Froude_drag) then - do m=1,CS%NMode ; do fr=1,CS%Nfreq - ! Calculate modal structure for given mode and frequency - call wave_structure(h, tv, G, GV, US, cn(:,:,m), m, CS%frequency(fr), & - CS%wave_struct, tot_En_mode(:,:,fr,m), full_halos=.true.) - ! Pick out near-bottom and max horizontal baroclinic velocity values at each point - do j=jsd,jed ; do i=isd,ied + do m=1,CS%nMode ; do fr=1,CS%Nfreq + + ! compute near-bottom and max horizontal baroclinic velocity values at each point + do j=js,je ; do i=is,ie id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - nzm = CS%wave_struct%num_intfaces(i,j) - Ub(i,j,fr,m) = CS%wave_struct%Uavg_profile(i,j,nzm) - Umax(i,j,fr,m) = maxval(CS%wave_struct%Uavg_profile(i,j,1:nzm)) + + ! Calculate wavenumber magnitude + freq2 = CS%frequency(fr)**2 + + f2 = (0.25*(G%CoriolisBu(I,J) + G%CoriolisBu(max(I-1,1),max(J-1,1)) + & + G%CoriolisBu(I,max(J-1,1)) + G%CoriolisBu(max(I-1,1),J)))**2 + Kmag2 = (freq2 - f2) / ((cn(i,j,m)**2) + (cn_subRO**2)) + + + ! Back-calculate amplitude from energy equation + if ( (G%mask2dT(i,j) > 0.5) .and. (freq2*Kmag2 > 0.0)) then + ! Units here are [R Z ~> kg m-2] + KE_term = 0.25*GV%H_to_RZ*( (((freq2 + f2) / (freq2*Kmag2))*US%L_to_Z**2*CS%int_U2(i,j,m)) + & + CS%int_w2(i,j,m) ) + PE_term = 0.25*GV%H_to_RZ*( CS%int_N2w2(i,j,m) / freq2 ) + + if (KE_term + PE_term > 0.0) then + W0 = sqrt( GV%H_to_RZ * tot_En_mode(i,j,fr,m) / (KE_term + PE_term) ) + else + !call MOM_error(WARNING, "MOM internal tides: KE + PE <= 0.0; setting to W0 to 0.0") + W0 = 0.0 + endif + + U_mag = W0 * sqrt((freq2 + f2) / (2.0*freq2*Kmag2)) + ! scaled maximum tidal velocity + Umax(i,j,fr,m) = abs(U_mag * CS%u_struct_max(i,j,m)) + ! scaled bottom tidal velocity + Ub(i,j,fr,m) = abs(U_mag * CS%u_struct_bot(i,j,m)) + else + Umax(i,j,fr,m) = 0. + Ub(i,j,fr,m) = 0. + endif + enddo ; enddo ! i-loop, j-loop enddo ; enddo ! fr-loop, m-loop endif ! apply_wave or _Froude_drag (Ub or Umax needed) ! Finally, apply loss if (CS%apply_wave_drag) then ! Calculate loss rate and apply loss over the time step - call itidal_lowmode_loss(G, US, CS, Nb, Ub, CS%En, CS%TKE_itidal_loss_fixed, & - CS%TKE_itidal_loss, dt, full_halos=.false.) + call itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, CS%En, CS%TKE_itidal_loss_fixed, & + CS%TKE_itidal_loss, dt, halo_size=0) endif - ! Check for En<0 - for debugging, delete later - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging - write(mesg,*) 'After wave drag loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=',CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) - CS%En(i,j,a,fr,m) = 0.0 -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") - endif + + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after wave", G%HI, haloshift=0, unscale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: before Froude drag') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: before Froude drag', CS%En_sum enddo ; enddo - enddo ; enddo ; enddo + ! save loss term for online budget, may want to add a debug flag later + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%TKE_itidal_loss(:,:,a,fr,m)*dt, G, & + tmp_scale=HZ2_T2_to_J_m2) + enddo + CS%TKE_itidal_loss_glo_dt(fr,m) = En_sumtmp + enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + write(mesg,*) 'After wave drag loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=', HZ2_T2_to_J_m2*CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + endif ! Extract the energy for mixing due to wave breaking----------------------------- if (CS%apply_Froude_drag) then ! Pick out maximum baroclinic velocity values; calculate Fr=max(u)/cg - do m=1,CS%NMode ; do fr=1,CS%Nfreq + do m=1,CS%nMode ; do fr=1,CS%Nfreq freq2 = CS%frequency(fr)**2 - do j=jsd,jed ; do i=isd,ied + do j=js,je ; do i=is,ie id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging ! Calculate horizontal phase velocity magnitudes - f2 = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & - (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) - Kmag2 = (freq2 - f2) / (cn(i,j,m)**2 + cn_subRO**2) + f2 = 0.25*((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + & + (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))) + Kmag2 = (freq2 - f2) / ((cn(i,j,m)**2) + (cn_subRO**2)) c_phase = 0.0 + CS%TKE_Froude_loss(i,j,:,fr,m) = 0. ! init for all angles if (Kmag2 > 0.0) then c_phase = sqrt(freq2/Kmag2) - nzm = CS%wave_struct%num_intfaces(i,j) Fr2_max = (Umax(i,j,fr,m) / c_phase)**2 ! Dissipate energy if Fr>1; done here with an arbitrary time scale if (Fr2_max > 1.0) then - En_initial = sum(CS%En(i,j,:,fr,m)) ! for debugging ! Calculate effective decay rate [T-1 ~> s-1] if breaking occurs over a time step - loss_rate = (1.0 - Fr2_max) / (Fr2_max * dt) + !loss_rate = (1.0 - Fr2_max) / (Fr2_max * dt) do a=1,CS%nAngle ! Determine effective dissipation rate (Wm-2) - CS%TKE_Froude_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * abs(loss_rate) - ! Update energy - En_new = CS%En(i,j,a,fr,m)/Fr2_max ! for debugging - En_check = CS%En(i,j,a,fr,m) - CS%TKE_Froude_loss(i,j,a,fr,m)*dt ! for debugging - ! Re-scale (reduce) energy due to breaking - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m)/Fr2_max - ! Check (for debugging only) - if (abs(En_new - En_check) > 1e-10*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2) then - call MOM_error(WARNING, "MOM_internal_tides: something is wrong with Fr-breaking.", & - all_print=.true.) - write(mesg,*) "En_new=", En_new , "En_check=", En_check - call MOM_error(WARNING, "MOM_internal_tides: "//trim(mesg), all_print=.true.) - endif + !CS%TKE_Froude_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * abs(loss_rate) + En_b = CS%En(i,j,a,fr,m) + En_a = CS%En(i,j,a,fr,m)/Fr2_max + CS%TKE_Froude_loss(i,j,a,fr,m) = (En_b - En_a) * I_dt + CS%En(i,j,a,fr,m) = En_a enddo - ! Check (for debugging) - Delta_E_check = En_initial - sum(CS%En(i,j,:,fr,m)) - TKE_Froude_loss_check = abs(Delta_E_check)/dt - TKE_Froude_loss_tot = sum(CS%TKE_Froude_loss(i,j,:,fr,m)) - if (abs(TKE_Froude_loss_check - TKE_Froude_loss_tot) > 1e-10) then - call MOM_error(WARNING, "MOM_internal_tides: something is wrong with Fr energy update.", & - all_print=.true.) - write(mesg,*) "TKE_Froude_loss_check=", TKE_Froude_loss_check, & - "TKE_Froude_loss_tot=", TKE_Froude_loss_tot - call MOM_error(WARNING, "MOM_internal_tides: "//trim(mesg), all_print=.true.) - endif endif ! Fr2>1 endif ! Kmag2>0 CS%cp(i,j,fr,m) = c_phase enddo ; enddo enddo ; enddo endif - ! Check for En<0 - for debugging, delete later - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle - do j=js,je ; do i=is,ie - if (CS%En(i,j,a,fr,m)<0.0) then - id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset - write(mesg,*) 'After Froude loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=',CS%En(i,j,a,fr,m) - call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) - CS%En(i,j,a,fr,m) = 0.0 -! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") - !stop + + if (CS%force_posit_En) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=jsd,jed ; do i=isd,ied + if (CS%En(i,j,a,fr,m)<0.0) then + CS%En(i,j,a,fr,m) = 0.0 + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after froude", G%HI, haloshift=0, unscale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide: after Froude drag') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: after Froude drag', CS%En_sum + call sum_En(G, GV, US, CS, CS%TKE_Froude_loss(:,:,:,fr,m) * dt, 'prop_int_tide: loss after Froude drag') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'prop_int_tide: loss after Froude drag', CS%En_sum + enddo ; enddo + ! save loss term for online budget, may want to add a debug flag later + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%TKE_Froude_loss(:,:,a,fr,m)*dt, G, & + tmp_scale=HZ2_T2_to_J_m2) + enddo + CS%TKE_Froude_loss_glo_dt(fr,m) = En_sumtmp + enddo ; enddo + ! Check for En<0 - for debugging, delete later + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie + if (CS%En(i,j,a,fr,m)<0.0) then + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset + write(mesg,*) 'After Froude loss: En<0.0 at ig=', id_g, ', jg=', jd_g, & + 'En=', HZ2_T2_to_J_m2*CS%En(i,j,a,fr,m) + call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg), all_print=.true.) + !call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") + endif + enddo ; enddo + enddo ; enddo ; enddo + endif + + ! loss from residual of reflection/transmission coefficients + if (CS%apply_residual_drag) then + + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie + ! implicit form is rewritten to minimize number of divisions + !CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt * CS%TKE_residual_loss(i,j,a,fr,m) / & + ! (CS%En(i,j,a,fr,m) + en_subRO)) + ! only compute when partial reflection is present not to create noise elsewhere + if (CS%refl_pref_logical(i,j)) then + En_b = CS%En(i,j,a,fr,m) + En_a = (CS%En(i,j,a,fr,m) * (CS%En(i,j,a,fr,m) + en_subRO)) / & + ((CS%En(i,j,a,fr,m) + en_subRO) + (dt * CS%TKE_slope_loss(i,j,a,fr,m))) + CS%TKE_residual_loss(i,j,a,fr,m) = (En_b - En_a) * I_dt + CS%En(i,j,a,fr,m) = En_a endif + enddo ; enddo ; enddo ; enddo ; enddo + + else + ! zero out the residual loss term so it does not count towards diagnostics + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie + CS%TKE_residual_loss(i,j,a,fr,m) = 0. + enddo ; enddo ; enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(CS%En(:,:,:,1,1), "EnergyIntTides after slope", G%HI, haloshift=0, unscale=HZ2_T2_to_J_m2) + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide') enddo ; enddo - enddo ; enddo ; enddo + ! save loss term for online budget + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%TKE_residual_loss(:,:,a,fr,m)*dt, G, & + tmp_scale=HZ2_T2_to_J_m2) + enddo + CS%TKE_residual_loss_glo_dt(fr,m) = En_sumtmp + enddo ; enddo + endif - ! Check for energy conservation on computational domain.************************* - do m=1,CS%NMode ; do fr=1,CS%Nfreq - call sum_En(G,CS,CS%En(:,:,:,fr,m),'prop_int_tide') - enddo ; enddo + !---- energy budget ---- + if (CS%debug) then + ! save final energy for online budget + do m=1,CS%nMode ; do fr=1,CS%nFreq + En_sumtmp = 0. + do a=1,CS%nAngle + En_sumtmp = En_sumtmp + global_area_integral(CS%En(:,:,a,fr,m), G, tmp_scale=HZ2_T2_to_J_m2) + enddo + CS%En_end_glo(fr,m) = En_sumtmp + enddo ; enddo + + do m=1,CS%nMode ; do fr=1,CS%nFreq + CS%error_mode(fr,m) = CS%En_ini_glo(fr,m) + CS%TKE_input_glo_dt(fr,m) - CS%TKE_leak_loss_glo_dt(fr,m) - & + CS%TKE_quad_loss_glo_dt(fr,m) - CS%TKE_itidal_loss_glo_dt(fr,m) - & + CS%TKE_Froude_loss_glo_dt(fr,m) - CS%TKE_residual_loss_glo_dt(fr,m) - & + CS%En_end_glo(fr,m) + if (is_root_pe()) write(stdout,'(A,F18.10)') & + "error in Energy budget", US%L_to_m**2*HZ2_T2_to_J_m2*CS%error_mode(fr,m) + enddo ; enddo + endif ! Output diagnostics.************************************************************ avg_enabled = query_averaging_enabled(CS%diag, time_end=time_end) call enable_averages(dt, time_end, CS%diag) if (query_averaging_enabled(CS%diag)) then - ! Output two-dimensional diagnostistics + ! Output internal wave modal wave speeds + if (CS%id_cg1 > 0) call post_data(CS%id_cg1, cn(:,:,1),CS%diag) + do m=1,CS%nMode ; if (CS%id_cn(m) > 0) call post_data(CS%id_cn(m), cn(:,:,m), CS%diag) ; enddo + + ! Output two-dimensional diagnostics if (CS%id_tot_En > 0) call post_data(CS%id_tot_En, tot_En, CS%diag) - if (CS%id_itide_drag > 0) call post_data(CS%id_itide_drag, drag_scale, CS%diag) - if (CS%id_TKE_itidal_input > 0) call post_data(CS%id_TKE_itidal_input, & - TKE_itidal_input, CS%diag) + do fr=1,CS%nFreq + if (CS%id_TKE_itidal_input(fr) > 0) call post_data(CS%id_TKE_itidal_input(fr), & + TKE_itidal_input(:,:,fr), CS%diag) + enddo - ! Output 2-D energy density (summed over angles) for each freq and mode - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; if (CS%id_En_mode(fr,m) > 0) then + do m=1,CS%nMode ; do fr=1,CS%nFreq + if (CS%id_itide_drag(fr,m) > 0) call post_data(CS%id_itide_drag(fr,m), drag_scale(:,:,fr,m), CS%diag) + enddo ; enddo + + ! Output 2-D energy density (summed over angles) for each frequency and mode + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; if (CS%id_En_mode(fr,m) > 0) then tot_En(:,:) = 0.0 do a=1,CS%nAngle ; do j=js,je ; do i=is,ie tot_En(i,j) = tot_En(i,j) + CS%En(i,j,a,fr,m) @@ -527,8 +1095,37 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & call post_data(CS%id_En_mode(fr,m), tot_En, CS%diag) endif ; enddo ; enddo - ! Output 3-D (i,j,a) energy density for each freq and mode - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; if (CS%id_En_ang_mode(fr,m) > 0) then + ! split energy array into multiple restarts + do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En_restart_mode1(i,j,a,fr) = CS%En(i,j,a,fr,1) * En_restart_factor + enddo ; enddo ; enddo ; enddo + + if (CS%nMode >= 2) then + do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En_restart_mode2(i,j,a,fr) = CS%En(i,j,a,fr,2) * En_restart_factor + enddo ; enddo ; enddo ; enddo + endif + + if (CS%nMode >= 3) then + do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En_restart_mode3(i,j,a,fr) = CS%En(i,j,a,fr,3) * En_restart_factor + enddo ; enddo ; enddo ; enddo + endif + + if (CS%nMode >= 4) then + do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En_restart_mode4(i,j,a,fr) = CS%En(i,j,a,fr,4) * En_restart_factor + enddo ; enddo ; enddo ; enddo + endif + + if (CS%nMode >= 5) then + do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En_restart_mode5(i,j,a,fr) = CS%En(i,j,a,fr,5) * En_restart_factor + enddo ; enddo ; enddo ; enddo + endif + + ! Output 3-D (i,j,a) energy density for each frequency and mode + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; if (CS%id_En_ang_mode(fr,m) > 0) then call post_data(CS%id_En_ang_mode(fr,m), CS%En(:,:,:,fr,m) , CS%diag) endif ; enddo ; enddo @@ -537,21 +1134,25 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & tot_quad_loss(:,:) = 0.0 tot_itidal_loss(:,:) = 0.0 tot_Froude_loss(:,:) = 0.0 + tot_residual_loss(:,:) = 0.0 tot_allprocesses_loss(:,:) = 0.0 - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie tot_leak_loss(i,j) = tot_leak_loss(i,j) + CS%TKE_leak_loss(i,j,a,fr,m) tot_quad_loss(i,j) = tot_quad_loss(i,j) + CS%TKE_quad_loss(i,j,a,fr,m) tot_itidal_loss(i,j) = tot_itidal_loss(i,j) + CS%TKE_itidal_loss(i,j,a,fr,m) tot_Froude_loss(i,j) = tot_Froude_loss(i,j) + CS%TKE_Froude_loss(i,j,a,fr,m) + tot_residual_loss(i,j) = tot_residual_loss(i,j) + CS%TKE_residual_loss(i,j,a,fr,m) enddo ; enddo ; enddo ; enddo ; enddo do j=js,je ; do i=is,ie - tot_allprocesses_loss(i,j) = tot_leak_loss(i,j) + tot_quad_loss(i,j) + & - tot_itidal_loss(i,j) + tot_Froude_loss(i,j) + tot_allprocesses_loss(i,j) = ((((tot_leak_loss(i,j) + tot_quad_loss(i,j)) + & + tot_itidal_loss(i,j)) + tot_Froude_loss(i,j)) + & + tot_residual_loss(i,j)) enddo ; enddo CS%tot_leak_loss = tot_leak_loss CS%tot_quad_loss = tot_quad_loss CS%tot_itidal_loss = tot_itidal_loss CS%tot_Froude_loss = tot_Froude_loss + CS%tot_residual_loss = tot_residual_loss CS%tot_allprocesses_loss = tot_allprocesses_loss if (CS%id_tot_leak_loss > 0) then call post_data(CS%id_tot_leak_loss, tot_leak_loss, CS%diag) @@ -565,37 +1166,73 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & if (CS%id_tot_Froude_loss > 0) then call post_data(CS%id_tot_Froude_loss, tot_Froude_loss, CS%diag) endif + if (CS%id_tot_residual_loss > 0) then + call post_data(CS%id_tot_residual_loss, tot_residual_loss, CS%diag) + endif if (CS%id_tot_allprocesses_loss > 0) then call post_data(CS%id_tot_allprocesses_loss, tot_allprocesses_loss, CS%diag) endif - ! Output 2-D energy loss (summed over angles) for each freq and mode - do m=1,CS%NMode ; do fr=1,CS%Nfreq + ! Output 2-D energy loss (summed over angles) for each frequency and mode + do m=1,CS%nMode ; do fr=1,CS%Nfreq if (CS%id_itidal_loss_mode(fr,m) > 0 .or. CS%id_allprocesses_loss_mode(fr,m) > 0) then itidal_loss_mode(:,:) = 0.0 ! wave-drag processes (could do others as well) + leak_loss_mode(:,:) = 0.0 + quad_loss_mode(:,:) = 0.0 + Froude_loss_mode(:,:) = 0.0 + residual_loss_mode(:,:) = 0.0 allprocesses_loss_mode(:,:) = 0.0 ! all processes summed together do a=1,CS%nAngle ; do j=js,je ; do i=is,ie itidal_loss_mode(i,j) = itidal_loss_mode(i,j) + CS%TKE_itidal_loss(i,j,a,fr,m) + leak_loss_mode(i,j) = leak_loss_mode(i,j) + CS%TKE_leak_loss(i,j,a,fr,m) + quad_loss_mode(i,j) = quad_loss_mode(i,j) + CS%TKE_quad_loss(i,j,a,fr,m) + Froude_loss_mode(i,j) = Froude_loss_mode(i,j) + CS%TKE_Froude_loss(i,j,a,fr,m) + residual_loss_mode(i,j) = residual_loss_mode(i,j) + CS%TKE_residual_loss(i,j,a,fr,m) allprocesses_loss_mode(i,j) = allprocesses_loss_mode(i,j) + & - CS%TKE_leak_loss(i,j,a,fr,m) + CS%TKE_quad_loss(i,j,a,fr,m) + & - CS%TKE_itidal_loss(i,j,a,fr,m) + CS%TKE_Froude_loss(i,j,a,fr,m) + ((((CS%TKE_leak_loss(i,j,a,fr,m) + CS%TKE_quad_loss(i,j,a,fr,m)) + & + CS%TKE_itidal_loss(i,j,a,fr,m)) + CS%TKE_Froude_loss(i,j,a,fr,m)) + & + CS%TKE_residual_loss(i,j,a,fr,m)) enddo ; enddo ; enddo call post_data(CS%id_itidal_loss_mode(fr,m), itidal_loss_mode, CS%diag) + call post_data(CS%id_leak_loss_mode(fr,m), leak_loss_mode, CS%diag) + call post_data(CS%id_quad_loss_mode(fr,m), quad_loss_mode, CS%diag) + call post_data(CS%id_Froude_loss_mode(fr,m), Froude_loss_mode, CS%diag) + call post_data(CS%id_residual_loss_mode(fr,m), residual_loss_mode, CS%diag) call post_data(CS%id_allprocesses_loss_mode(fr,m), allprocesses_loss_mode, CS%diag) endif ; enddo ; enddo - ! Output 3-D (i,j,a) energy loss for each freq and mode - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; if (CS%id_itidal_loss_ang_mode(fr,m) > 0) then + ! Output 3-D (i,j,a) energy loss for each frequency and mode + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; if (CS%id_itidal_loss_ang_mode(fr,m) > 0) then call post_data(CS%id_itidal_loss_ang_mode(fr,m), CS%TKE_itidal_loss(:,:,:,fr,m) , CS%diag) endif ; enddo ; enddo - ! Output 2-D period-averaged horizontal near-bottom mode velocity for each freq and mode - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; if (CS%id_Ub_mode(fr,m) > 0) then + ! Output 2-D period-averaged horizontal near-bottom mode velocity for each frequency and mode + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; if (CS%id_Ub_mode(fr,m) > 0) then call post_data(CS%id_Ub_mode(fr,m), Ub(:,:,fr,m), CS%diag) endif ; enddo ; enddo - ! Output 2-D horizontal phase velocity for each freq and mode - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; if (CS%id_cp_mode(fr,m) > 0) then + do m=1,CS%nMode ; if (CS%id_Ustruct_mode(m) > 0) then + call post_data(CS%id_Ustruct_mode(m), CS%u_struct(:,:,:,m), CS%diag) + endif ; enddo + + do m=1,CS%nMode ; if (CS%id_Wstruct_mode(m) > 0) then + call post_data(CS%id_Wstruct_mode(m), CS%w_struct(:,:,:,m), CS%diag) + endif ; enddo + + do m=1,CS%nMode ; if (CS%id_int_w2_mode(m) > 0) then + call post_data(CS%id_int_w2_mode(m), CS%int_w2(:,:,m), CS%diag) + endif ; enddo + + do m=1,CS%nMode ; if (CS%id_int_U2_mode(m) > 0) then + call post_data(CS%id_int_U2_mode(m), CS%int_U2(:,:,m), CS%diag) + endif ; enddo + + do m=1,CS%nMode ; if (CS%id_int_N2w2_mode(m) > 0) then + call post_data(CS%id_int_N2w2_mode(m), CS%int_N2w2(:,:,m), CS%diag) + endif ; enddo + + ! Output 2-D horizontal phase velocity for each frequency and mode + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; if (CS%id_cp_mode(fr,m) > 0) then call post_data(CS%id_cp_mode(fr,m), CS%cp(:,:,fr,m), CS%diag) endif ; enddo ; enddo @@ -606,25 +1243,25 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & end subroutine propagate_int_tide !> Checks for energy conservation on computational domain -subroutine sum_En(G, CS, En, label) +subroutine sum_En(G, GV, US, CS, En, label) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(int_tide_CS), intent(inout) :: CS !< Internal tide control struct + type(verticalGrid_type),intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(int_tide_CS), intent(inout) :: CS !< Internal tide control structure real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle), & - intent(in) :: En !< The energy density of the internal tides [R Z3 T-2 ~> J m-2]. + intent(in) :: En !< The energy density of the internal tides [H Z2 T-2 ~> m3 s-2 or J m-2]. character(len=*), intent(in) :: label !< A label to use in error messages ! Local variables - real :: En_sum ! The total energy [R Z3 T-2 ~> J m-2] - real :: tmpForSumming - integer :: m,fr,a - ! real :: En_sum_diff, En_sum_pdiff + real :: En_sum ! The total energy in MKS units for potential output [m5 s-2 or J] + integer :: a + ! real :: En_sum_diff ! Change in energy from the expected value [m5 s-2 or J] + ! real :: En_sum_pdiff ! Percentage change in energy from the expected value [nondim] ! character(len=160) :: mesg ! The text of an error message - ! real :: days + ! real :: days ! The time in days for use in output messages [days] En_sum = 0.0 - tmpForSumming = 0.0 do a=1,CS%nAngle - tmpForSumming = global_area_mean(En(:,:,a),G)*G%areaT_global - En_sum = En_sum + tmpForSumming + En_sum = En_sum + global_area_integral(En(:,:,a), G, unscale=GV%H_to_mks*(US%Z_to_m**2)*(US%s_to_T)**2) enddo CS%En_sum = En_sum !En_sum_diff = En_sum - CS%En_sum @@ -647,45 +1284,63 @@ end subroutine sum_En !> Calculates the energy lost from the propagating internal tide due to !! scattering over small-scale roughness along the lines of Jayne & St. Laurent (2001). -subroutine itidal_lowmode_loss(G, US, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, dt, full_halos) +subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixed, TKE_loss, dt, halo_size) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(int_tide_CS), intent(in) :: CS !< Internal tide control struct + type(int_tide_CS), intent(in) :: CS !< Internal tide control structure real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(in) :: Nb !< Near-bottom stratification [T-1 ~> s-1]. + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(in) :: Rho_bot !< Near-bottom density [R ~> kg m-3]. real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%nFreq,CS%nMode), & intent(inout) :: Ub !< RMS (over one period) near-bottom horizontal !! mode velocity [L T-1 ~> m s-1]. real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(in) :: TKE_loss_fixed !< Fixed part of energy loss [R L-2 Z3 ~> kg m-2] - !! (rho*kappa*h^2). + intent(in) :: TKE_loss_fixed !< Fixed part of energy loss [R Z4 H-1 L-2 ~> kg m-2 or m] + !! (rho*kappa*h^2) or (kappa*h^2). real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle,CS%nFreq,CS%nMode), & - intent(inout) :: En !< Energy density of the internal waves [R Z3 T-2 ~> J m-2]. + intent(inout) :: En !< Energy density of the internal waves [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle,CS%nFreq,CS%nMode), & - intent(out) :: TKE_loss !< Energy loss rate [R Z3 T-3 ~> W m-2] + intent(out) :: TKE_loss !< Energy loss rate [H Z2 T-3 ~> m3 s-3 or W m-2] !! (q*rho*kappa*h^2*N*U^2). real, intent(in) :: dt !< Time increment [T ~> s]. - logical,optional, intent(in) :: full_halos !< If true, do the calculation over the - !! entirecomputational domain. + integer, optional, intent(in) :: halo_size !< The halo size over which to do the calculations ! Local variables - integer :: j,i,m,fr,a, is, ie, js, je - real :: En_tot ! energy for a given mode, frequency, and point summed over angles [R Z3 T-2 ~> J m-2] - real :: TKE_loss_tot ! dissipation for a given mode, frequency, and point summed over angles [R Z3 T-3 ~> W m-2] - real :: TKE_sum_check ! temporary for check summing - real :: frac_per_sector ! fraction of energy in each wedge + integer :: j, i, m, fr, a, is, ie, js, je, halo + real :: En_tot ! energy for a given mode, frequency + ! and point summed over angles [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: TKE_loss_tot ! dissipation for a given mode, frequency + ! and point summed over angles [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: frac_per_sector ! fraction of energy in each wedge [nondim] real :: q_itides ! fraction of energy actually lost to mixing (remainder, 1-q, is - ! assumed to stay in propagating mode for now - BDM) + ! assumed to stay in propagating mode for now - BDM) [nondim] real :: loss_rate ! approximate loss rate for implicit calc [T-1 ~> s-1] - real :: En_negl ! negilibly small number to prevent division by zero + real :: En_negl ! negligibly small number to prevent division by zero [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: En_a, En_b ! energy before and after timestep [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: I_dt ! The inverse of the timestep [T-1 ~> s-1] + real :: J_m2_to_HZ2_T2 ! unit conversion factor for Energy from mks to internal + ! units [H Z2 s2 T-2 kg-1 ~> m3 kg-1 or 1] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + J_m2_to_HZ2_T2 = GV%m_to_H*(US%m_to_Z**2)*(US%T_to_s**2) + + I_dt = 1.0 / dt q_itides = CS%q_itides - En_negl = 1e-30*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2 + En_negl = 1e-30*J_m2_to_HZ2_T2 - if (present(full_halos)) then ; if (full_halos) then - is = G%isd ; ie = G%ied ; js = G%jsd ; je = G%jed - endif ; endif + if (present(halo_size)) then + halo = halo_size + is = G%isc - halo ; ie = G%iec + halo ; js = G%jsc - halo ; je = G%jec + halo + endif + + if (CS%debug) then + call hchksum(TKE_loss_fixed, "TKE loss fixed", G%HI, haloshift=0, & + unscale=US%RZ_to_kg_m2*(US%Z_to_m**3)*GV%m_to_H*(US%m_to_L**2)) + call hchksum(Nb(:,:), "Nbottom", G%HI, haloshift=0, unscale=US%s_to_T) + call hchksum(Ub(:,:,1,1), "Ubottom", G%HI, haloshift=0, unscale=US%L_to_m*US%s_to_T) + endif do j=js,je ; do i=is,ie ; do m=1,CS%nMode ; do fr=1,CS%nFreq @@ -695,41 +1350,32 @@ subroutine itidal_lowmode_loss(G, US, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, En_tot = En_tot + En(i,j,a,fr,m) enddo - ! Calculate TKE loss rate; units of [R Z3 T-3 ~> W m-2] here. - TKE_loss_tot = q_itides * TKE_loss_fixed(i,j) * Nb(i,j) * Ub(i,j,fr,m)**2 + ! Calculate TKE loss rate; units of [H Z2 T-3 ~> m3 s-3 or W m-2] here. + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + TKE_loss_tot = q_itides * GV%RZ_to_H*GV%Z_to_H*TKE_loss_fixed(i,j)*Nb(i,j)*Ub(i,j,fr,m)**2 + else + TKE_loss_tot = q_itides * (GV%RZ_to_H*GV%RZ_to_H*Rho_bot(i,j))*TKE_loss_fixed(i,j)*Nb(i,j)*Ub(i,j,fr,m)**2 + endif ! Update energy remaining (this is a pseudo implicit calc) ! (E(t+1)-E(t))/dt = -TKE_loss(E(t+1)/E(t)), which goes to zero as E(t+1) goes to zero if (En_tot > 0.0) then do a=1,CS%nAngle frac_per_sector = En(i,j,a,fr,m)/En_tot - TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot ! Wm-2 + TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot ! [H Z2 T-3 ~> m3 s-3 or W m-2] loss_rate = TKE_loss(i,j,a,fr,m) / (En(i,j,a,fr,m) + En_negl) ! [T-1 ~> s-1] - En(i,j,a,fr,m) = En(i,j,a,fr,m) / (1.0 + dt*loss_rate) + En_b = En(i,j,a,fr,m) + En_a = En(i,j,a,fr,m) / (1.0 + (dt*loss_rate)) + TKE_loss(i,j,a,fr,m) = (En_b - En_a) * I_dt ! overwrite with exact value + En(i,j,a,fr,m) = En_a enddo else ! no loss if no energy - TKE_loss(i,j,:,fr,m) = 0.0 + do a=1,CS%nAngle + TKE_loss(i,j,a,fr,m) = 0.0 + enddo endif - ! Update energy remaining (this is the old explicit calc) - !if (En_tot > 0.0) then - ! do a=1,CS%nAngle - ! frac_per_sector = En(i,j,a,fr,m)/En_tot - ! TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot - ! if (TKE_loss(i,j,a,fr,m)*dt <= En(i,j,a,fr,m))then - ! En(i,j,a,fr,m) = En(i,j,a,fr,m) - TKE_loss(i,j,a,fr,m)*dt - ! else - ! call MOM_error(WARNING, "itidal_lowmode_loss: energy loss greater than avalable, "// & - ! " setting En to zero.", all_print=.true.) - ! En(i,j,a,fr,m) = 0.0 - ! endif - ! enddo - !else - ! ! no loss if no energy - ! TKE_loss(i,j,:,fr,m) = 0.0 - !endif - enddo ; enddo ; enddo ; enddo end subroutine itidal_lowmode_loss @@ -742,18 +1388,459 @@ subroutine get_lowmode_loss(i,j,G,CS,mechanism,TKE_loss_sum) integer, intent(in) :: i !< The i-index of the value to be reported. integer, intent(in) :: j !< The j-index of the value to be reported. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(int_tide_CS), intent(in) :: CS !< Internal tide control struct + type(int_tide_CS), intent(in) :: CS !< Internal tide control structure character(len=*), intent(in) :: mechanism !< The named mechanism of loss to return real, intent(out) :: TKE_loss_sum !< Total energy loss rate due to specified - !! mechanism [R Z3 T-3 ~> W m-2]. + !! mechanism [H Z2 T-3 ~> m3 s-3 or W m-2]. - if (mechanism == 'LeakDrag') TKE_loss_sum = CS%tot_leak_loss(i,j) ! not used for mixing yet - if (mechanism == 'QuadDrag') TKE_loss_sum = CS%tot_quad_loss(i,j) ! not used for mixing yet - if (mechanism == 'WaveDrag') TKE_loss_sum = CS%tot_itidal_loss(i,j) ! currently used for mixing - if (mechanism == 'Froude') TKE_loss_sum = CS%tot_Froude_loss(i,j) ! not used for mixing yet + if (mechanism == 'LeakDrag') TKE_loss_sum = CS%tot_leak_loss(i,j) + if (mechanism == 'QuadDrag') TKE_loss_sum = CS%tot_quad_loss(i,j) + if (mechanism == 'WaveDrag') TKE_loss_sum = CS%tot_itidal_loss(i,j) + if (mechanism == 'Froude') TKE_loss_sum = CS%tot_Froude_loss(i,j) + if (mechanism == 'SlopeDrag') TKE_loss_sum = CS%tot_residual_loss(i,j) end subroutine get_lowmode_loss + +!> Returns the values of diffusivity corresponding to various mechanisms +subroutine get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2_int, TKE_to_Kd, Kd_max, CS, & + Kd_leak, Kd_quad, Kd_itidal, Kd_Froude, Kd_slope, & + Kd_lay, Kd_int, profile_leak, profile_quad, profile_itidal, & + profile_Froude, profile_slope) + + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G)), intent(in) :: h_bot !< Bottom boundary layer thickness [H ~> m or kg m-2] + integer, dimension(SZI_(G)), intent(in) :: k_bot !< Bottom boundary layer top layer index + integer, intent(in) :: j !< The j-index to work on + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: N2_lay !< The squared buoyancy frequency of the + !! layers [T-2 ~> s-2]. + real, dimension(SZI_(G),SZK_(GV)+1), intent(in) :: N2_int !< The squared buoyancy frequency of the + !! interfaces [T-2 ~> s-2]. + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE + !! dissipated within a layer and the + !! diapycnal diffusivity within that layer, + !! usually (~Rho_0 / (G_Earth * dRho_lay)) + !! [T2 Z-1 ~> s2 m-1] + real, intent(in) :: Kd_max !< The maximum increment for diapycnal + !! diffusivity due to TKE-based processes + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + !! Set this to a negative value to have no limit. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + type(int_tide_cs), intent(in) :: CS !< The control structure for this module + + real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_leak !< Diffusivity due to background drag + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_quad !< Diffusivity due to bottom drag + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_itidal !< Diffusivity due to wave drag + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_Froude !< Diffusivity due to high Froude breaking + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_slope !< Diffusivity due to critical slopes + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZK_(GV)+1), intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G), SZK_(GV)), intent(out) :: profile_leak !< Normalized profile for background drag + !! [H-1 ~> m-1 or m2 kg-1] + real, dimension(SZI_(G), SZK_(GV)), intent(out) :: profile_quad !< Normalized profile for bottom drag + !! [H-1 ~> m-1 or m2 kg-1] + real, dimension(SZI_(G), SZK_(GV)), intent(out) :: profile_itidal !< Normalized profile for wave drag + !! [H-1 ~> m-1 or m2 kg-1] + real, dimension(SZI_(G), SZK_(GV)), intent(out) :: profile_Froude !< Normalized profile for Froude drag + !! [H-1 ~> m-1 or m2 kg-1] + real, dimension(SZI_(G), SZK_(GV)), intent(out) :: profile_slope !< Normalized profile for critical slopes + !! [H-1 ~> m-1 or m2 kg-1] + + ! local variables + real :: TKE_loss ! temp variable to pass value of internal tides TKE loss [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: renorm_N ! renormalization for N profile [H T-1 ~> m s-1 or kg m-2 s-1] + real :: renorm_N2 ! renormalization for N2 profile [H T-2 ~> m s-2 or kg m-2 s-2] + real :: tmp_StLau ! tmp var for renormalization for StLaurent profile [nondim] + real :: tmp_StLau_slope ! tmp var for renormalization for StLaurent profile [nondim] + real :: renorm_StLau ! renormalization for StLaurent profile [nondim] + real :: renorm_StLau_slope! renormalization for StLaurent profile [nondim] + real :: htot ! total depth of water column [H ~> m or kg m-2] + real :: htmp ! local value of thickness in layers [H ~> m or kg m-2] + real :: h_d ! expomential decay length scale [H ~> m or kg m-2] + real :: h_s ! expomential decay length scale on the slope [H ~> m or kg m-2] + real :: I_h_d ! inverse of expomential decay length scale [H-1 ~> m-1 or m2 kg-1] + real :: I_h_s ! inverse of expomential decay length scale on the slope [H-1 ~> m-1 or m2 kg-1] + real :: TKE_to_Kd_lim ! limited version of TKE_to_Kd [T2 Z-1 ~> s2 m-1] + + ! vertical profiles have units Z-1 for conversion to Kd to be dim correct (see eq 2 of St Laurent GRL 2002) + real, dimension(SZK_(GV)) :: profile_N ! vertical profile varying with N [H-1 ~> m-1 or m2 kg-1] + real, dimension(SZK_(GV)) :: profile_N2 ! vertical profile varying with N2 [H-1 ~> m-1 or m2 kg-1] + real, dimension(SZK_(GV)) :: profile_StLaurent ! vertical profile according to St Laurent 2002 + ! [H-1 ~> m-1 or m2 kg-1] + real, dimension(SZK_(GV)) :: profile_StLaurent_slope ! vertical profile according to St Laurent 2002 + ! [H-1 ~> m-1 or m2 kg-1] + real, dimension(SZK_(GV)) :: profile_BBL ! vertical profile Heavyside BBL [H-1 ~> m-1 or m2 kg-1] + real, dimension(SZK_(GV)) :: Kd_leak_lay ! Diffusivity due to background drag [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZK_(GV)) :: Kd_quad_lay ! Diffusivity due to bottom drag [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZK_(GV)) :: Kd_itidal_lay ! Diffusivity due to wave drag [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZK_(GV)) :: Kd_Froude_lay ! Diffusivity due to high Froude breaking [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZK_(GV)) :: Kd_slope_lay ! Diffusivity due to critical slopes [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + + real :: hmin ! A minimum allowable thickness [H ~> m or kg m-2] + real :: h_rmn ! Remaining thickness in k-loop [H ~> m or kg m-2] + real :: frac ! A fraction of thicknesses [nondim] + real :: I_h_bot ! inverse of Bottom boundary layer thickness [H-1 ~> m-1 or m2 kg-1] + + real :: verif_N, & ! profile verification [nondim] + verif_N2, & ! profile verification [nondim] + verif_bbl, & ! profile verification [nondim] + verif_stl1,& ! profile verification [nondim] + verif_stl2,& ! profile verification [nondim] + threshold_renorm_N2,& ! Maximum allowable error on N2 profile [H T-2 ~> m s-2 or kg m-2 s-2] + threshold_renorm_N, & ! Maximum allowable error on N profile [H T-1 ~> m s-1 or kg m-2 s-1] + threshold_verif ! Maximum allowable error on verification [nondim] + + logical :: non_Bous ! fully Non-Boussinesq + integer :: i, k, is, ie, nz + + is=G%isc ; ie=G%iec ; nz=GV%ke + + non_Bous = .not.(GV%Boussinesq .or. GV%semi_Boussinesq) + + h_d = CS%Int_tide_decay_scale + h_s = CS%Int_tide_decay_scale_slope + I_h_d = 1 / h_d + I_h_s = 1 / h_s + + hmin = 1.0e-6*GV%m_to_H + threshold_renorm_N2 = 1.0e-13 * GV%m_to_H * US%T_to_s**2 + threshold_renorm_N = 1.0e-13 * GV%m_to_H * US%T_to_s + threshold_verif = 1.0e-13 + + ! init output arrays + profile_leak(:,:) = 0.0 + profile_quad(:,:) = 0.0 + profile_slope(:,:) = 0.0 + profile_itidal(:,:) = 0.0 + profile_Froude(:,:) = 0.0 + + Kd_leak_lay(:) = 0.0 + Kd_quad_lay(:) = 0.0 + Kd_itidal_lay(:) = 0.0 + Kd_Froude_lay(:) = 0.0 + Kd_slope_lay(:) = 0.0 + + Kd_leak(:,:) = 0.0 + Kd_quad(:,:) = 0.0 + Kd_itidal(:,:) = 0.0 + Kd_Froude(:,:) = 0.0 + Kd_slope(:,:) = 0.0 + + do i=is,ie + + ! create vertical profiles for diffusivities in layers + renorm_N = 0.0 + renorm_N2 = 0.0 + renorm_StLau = 0.0 + renorm_StLau_slope = 0.0 + tmp_StLau = 0.0 + tmp_StLau_slope = 0.0 + htot = 0.0 + htmp = 0.0 + I_h_bot = 1.0 / h_bot(i) + + do k=1,nz + ! N-profile + if (N2_lay(i,k) < 0.) call MOM_error(WARNING, "negative buoyancy freq") + renorm_N = renorm_N + (sqrt(max(N2_lay(i,k), 0.)) * h(i,j,k)) + ! N2-profile + renorm_N2 = renorm_N2 + (max(N2_lay(i,k), 0.) * h(i,j,k)) + ! total depth + htot = htot + h(i,j,k) + enddo + + profile_N2(:) = 0.0 + profile_N(:) = 0.0 + profile_BBL(:) = 0.0 + profile_StLaurent(:) = 0.0 + profile_StLaurent_slope(:) = 0.0 + + ! BBL-profile + h_rmn = h_bot(i) + do k=nz,1,-1 + if (G%mask2dT(i,j) > 0.0) then + profile_BBL(k) = 0.0 + if (h(i,j,k) <= h_rmn) then + profile_BBL(k) = 1.0 * I_h_bot + h_rmn = h_rmn - h(i,j,k) + else + if (h_rmn > 0.0) then + frac = h_rmn / h(i,j,k) + profile_BBL(k) = frac * I_h_bot + h_rmn = h_rmn - frac*h(i,j,k) + endif + endif + endif + enddo + + do k=1,nz + if (G%mask2dT(i,j) > 0.0) then + ! N - profile + if (renorm_N > threshold_renorm_N) then + profile_N(k) = sqrt(max(N2_lay(i,k), 0.)) / renorm_N + else + profile_N(k) = 1 / htot + endif + + ! N2 - profile + if (renorm_N2 > threshold_renorm_N2) then + profile_N2(k) = max(N2_lay(i,k), 0.) / renorm_N2 + else + profile_N2(k) = 1 / htot + endif + + ! slope intensified (St Laurent GRL 2002) - profile + ! in paper, z is defined positive upwards, range 0 to -H + ! here depth positive downwards + ! profiles are almost normalized but differ from a few percent + ! so we add a second renormalization factor + + ! add first half of layer: get to the layer center + htmp = htmp + 0.5*h(i,j,k) + + profile_StLaurent(k) = exp(-I_h_d*(htot-htmp)) / & + (h_d*(1 - exp(-I_h_d*htot))) + + profile_StLaurent_slope(k) = exp(-I_h_s*(htot-htmp)) / & + (h_s*(1 - exp(-I_h_s*htot))) + + tmp_StLau = tmp_StLau + (profile_StLaurent(k) * h(i,j,k)) + tmp_StLau_slope = tmp_StLau_slope + (profile_StLaurent_slope(k) * h(i,j,k)) + + ! add second half of layer: get to the next interface + htmp = htmp + 0.5*h(i,j,k) + endif + enddo + + if (G%mask2dT(i,j) > 0.0) then + ! allow for difference less than verification threshold + renorm_StLau = 1.0 + renorm_StLau_slope = 1.0 + if (abs(tmp_StLau -1.0) > threshold_verif) renorm_StLau = 1.0 / tmp_StLau + if (abs(tmp_StLau_slope -1.0) > threshold_verif) renorm_StLau_slope = 1.0 / tmp_StLau_slope + + do k=1,nz + profile_StLaurent(k) = profile_StLaurent(k) * renorm_StLau + profile_StLaurent_slope(k) = profile_StLaurent_slope(k) * renorm_StLau_slope + enddo + endif + + ! verif integrals + if (CS%debug) then + if (G%mask2dT(i,j) > 0.0) then + verif_N = 0.0 + verif_N2 = 0.0 + verif_bbl = 0.0 + verif_stl1 = 0.0 + verif_stl2 = 0.0 + do k=1,nz + verif_N = verif_N + (profile_N(k) * h(i,j,k)) + verif_N2 = verif_N2 + (profile_N2(k) * h(i,j,k)) + verif_bbl = verif_bbl + (profile_BBL(k) * h(i,j,k)) + verif_stl1 = verif_stl1 + (profile_StLaurent(k) * h(i,j,k)) + verif_stl2 = verif_stl2 + (profile_StLaurent_slope(k) * h(i,j,k)) + enddo + + if (abs(verif_N -1.0) > threshold_verif) then + write(stdout,'(I0,", ",I0,F18.10)') i, j, verif_N + call MOM_error(FATAL, "mismatch integral for N profile") + endif + if (abs(verif_N2 -1.0) > threshold_verif) then + write(stdout,'(I0,", ",I0,F18.10)') i, j, verif_N2 + call MOM_error(FATAL, "mismatch integral for N2 profile") + endif + if (abs(verif_bbl -1.0) > threshold_verif) then + write(stdout,'(I0,", ",I0,F18.10)') i, j, verif_bbl + call MOM_error(FATAL, "mismatch integral for bbl profile") + endif + if (abs(verif_stl1 -1.0) > threshold_verif) then + write(stdout,'(I0,", ",I0,F18.10)') i, j, verif_stl1 + call MOM_error(FATAL, "mismatch integral for stl1 profile") + endif + if (abs(verif_stl2 -1.0) > threshold_verif) then + write(stdout,'(I0,", ",I0,F18.10)') i, j, verif_stl2 + call MOM_error(FATAL, "mismatch integral for stl2 profile") + endif + + endif + endif + + ! note on units: TKE_to_Kd = 1 / ((g/rho0) * drho) Z-1 T2 + ! mult by dz gives -1/N2 in T2 + + ! get TKE loss value and compute diffusivities in layers + if (CS%apply_background_drag) then + call get_lowmode_loss(i, j, G, CS, "LeakDrag", TKE_loss) + ! insert logic to switch between profiles here + ! if trim(CS%leak_profile) == "N2" then + profile_leak(i,:) = profile_N2(:) + ! elseif trim(CS%leak_profile) == "N" then + ! profile_leak(:) = profile_N(:) + ! something else + ! endif + Kd_leak_lay(:) = 0. + do k=1,nz + ! layer diffusivity for processus + if (h(i,j,k) >= CS%min_thick_layer_Kd) then + TKE_to_Kd_lim = min(TKE_to_Kd(i,k), CS%max_TKE_to_Kd) + Kd_leak_lay(k) = CS%mixing_effic * TKE_loss * TKE_to_Kd_lim * profile_leak(i,k) * h(i,j,k) + else + Kd_leak_lay(k) = 0. + endif + ! add to total Kd in layer + if (CS%update_Kd) Kd_lay(i,k) = Kd_lay(i,k) + min(Kd_leak_lay(k), Kd_max) + enddo + endif + + if (CS%apply_Froude_drag) then + call get_lowmode_loss(i, j, G, CS, "Froude", TKE_loss) + ! insert logic to switch between profiles here + ! if trim(CS%Froude_profile) == "N" then + profile_Froude(i,:) = profile_N(:) + ! elseif trim(CS%Froude_profile) == "N2" then + ! profile_Froude(:) = profile_N2(:) + ! something else + ! endif + do k=1,nz + ! layer diffusivity for processus + if (h(i,j,k) >= CS%min_thick_layer_Kd) then + TKE_to_Kd_lim = min(TKE_to_Kd(i,k), CS%max_TKE_to_Kd) + Kd_Froude_lay(k) = CS%mixing_effic * TKE_loss * TKE_to_Kd_lim * profile_Froude(i,k) * h(i,j,k) + else + Kd_Froude_lay(k) = 0. + endif + ! add to total Kd in layer + if (CS%update_Kd) Kd_lay(i,k) = Kd_lay(i,k) + min(Kd_Froude_lay(k), Kd_max) + enddo + endif + + if (CS%apply_wave_drag) then + call get_lowmode_loss(i, j, G, CS, "WaveDrag", TKE_loss) + ! insert logic to switch between profiles here + ! if trim(CS%wave_profile) == "StLaurent" then + profile_itidal(i,:) = profile_StLaurent(:) + ! elseif trim(CS%Froude_profile) == "N2" then + ! profile_itidal(:) = profile_N2(:) + ! something else + ! endif + do k=1,nz + ! layer diffusivity for processus + if (h(i,j,k) >= CS%min_thick_layer_Kd) then + TKE_to_Kd_lim = min(TKE_to_Kd(i,k), CS%max_TKE_to_Kd) + Kd_itidal_lay(k) = CS%mixing_effic * TKE_loss * TKE_to_Kd_lim * profile_itidal(i,k) * h(i,j,k) + else + Kd_itidal_lay(k) = 0. + endif + ! add to total Kd in layer + if (CS%update_Kd) Kd_lay(i,k) = Kd_lay(i,k) + min(Kd_itidal_lay(k), Kd_max) + enddo + endif + + if (CS%apply_residual_drag) then + call get_lowmode_loss(i, j, G, CS, "SlopeDrag", TKE_loss) + ! insert logic to switch between profiles here + ! if trim(CS%wave_profile) == "StLaurent" then + profile_slope(i,:) = profile_StLaurent_slope(:) + ! elseif trim(CS%Froude_profile) == "N2" then + ! profile_itidal(:) = profile_N2(:) + ! something else + ! endif + do k=1,nz + ! layer diffusivity for processus + if (h(i,j,k) >= CS%min_thick_layer_Kd) then + TKE_to_Kd_lim = min(TKE_to_Kd(i,k), CS%max_TKE_to_Kd) + Kd_slope_lay(k) = CS%mixing_effic * TKE_loss * TKE_to_Kd_lim * profile_slope(i,k) * h(i,j,k) + else + Kd_slope_lay(k) = 0. + endif + ! add to total Kd in layer + if (CS%update_Kd) Kd_lay(i,k) = Kd_lay(i,k) + min(Kd_slope_lay(k), Kd_max) + enddo + endif + + if (CS%apply_bottom_drag) then + call get_lowmode_loss(i, j, G, CS, "QuadDrag", TKE_loss) + ! insert logic to switch between profiles here + ! if trim(CS%bottom_profile) == "BBL" then + profile_quad(i,:) = profile_BBL(:) + ! elseif trim(CS%bottom_profile) == "N2" then + ! profile_quad(:) = profile_N2(:) + ! something else + ! endif + do k=1,nz + ! layer diffusivity for processus + if (h(i,j,k) >= CS%min_thick_layer_Kd) then + TKE_to_Kd_lim = min(TKE_to_Kd(i,k), CS%max_TKE_to_Kd) + Kd_quad_lay(k) = CS%mixing_effic * TKE_loss * TKE_to_Kd_lim * profile_quad(i,k) * h(i,j,k) + else + Kd_quad_lay(k) = 0. + endif + ! add to total Kd in layer + if (CS%update_Kd) Kd_lay(i,k) = Kd_lay(i,k) + min(Kd_quad_lay(k), Kd_max) + enddo + endif + + ! interpolate Kd_[] to interfaces and add to Kd_int + if (CS%apply_background_drag) then + do k=1,nz+1 + if (k>1) Kd_leak(i,K) = 0.5*Kd_leak_lay(k-1) + if (k1) Kd_itidal(i,K) = 0.5*Kd_itidal_lay(k-1) + if (k1) Kd_Froude(i,K) = 0.5*Kd_Froude_lay(k-1) + if (k1) Kd_slope(i,K) = 0.5*Kd_slope_lay(k-1) + if (k1) Kd_quad(i,K) = 0.5*Kd_quad_lay(k-1) + if (k Implements refraction on the internal waves at a single frequency. subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. @@ -762,7 +1849,7 @@ subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: En !< The internal gravity wave energy density as a !! function of space and angular resolution, - !! [R Z3 T-2 ~> J m-2]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(in) :: cn !< Baroclinic mode speed [L T-1 ~> m s-1]. real, intent(in) :: freq !< Wave frequency [T-1 ~> s-1]. @@ -773,47 +1860,52 @@ subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) ! Local variables integer, parameter :: stencil = 2 real, dimension(SZI_(G),1-stencil:NAngle+stencil) :: & - En2d + En2d ! The internal gravity wave energy density in zonal slices [H Z2 T-2 ~> m3 s-2 or J m-2] real, dimension(1-stencil:NAngle+stencil) :: & - cos_angle, sin_angle + cos_angle, sin_angle ! The cosine and sine of each angle [nondim] real, dimension(SZI_(G)) :: & - Dk_Dt_Kmag, Dl_Dt_Kmag + Dk_Dt_Kmag, Dl_Dt_Kmag ! Rates of angular refraction [T-1 ~> s-1] real, dimension(SZI_(G),0:nAngle) :: & - Flux_E + Flux_E ! The flux of energy between successive angular wedges + ! within a timestep [H Z2 T-2 ~> m3 s-2 or J m-2] real, dimension(SZI_(G),SZJ_(G),1-stencil:NAngle+stencil) :: & - CFL_ang - real, dimension(G%IsdB:G%IedB,G%jsd:G%jed) :: cn_u !< Internal wave group velocity at U-point - real, dimension(G%isd:G%ied,G%JsdB:G%JedB) :: cn_v !< Internal wave group velocity at V-point - real, dimension(G%isd:G%ied,G%jsd:G%jed) :: cnmask !< Local mask for group velocity + CFL_ang ! The CFL number of angular refraction [nondim] + real, dimension(G%IsdB:G%IedB,G%jsd:G%jed) :: cn_u !< Internal wave group velocity at U-point [L T-1 ~> m s-1] + real, dimension(G%isd:G%ied,G%JsdB:G%JedB) :: cn_v !< Internal wave group velocity at V-point [L T-1 ~> m s-1] + real, dimension(G%isd:G%ied,G%jsd:G%jed) :: cnmask !< Local mask for group velocity [nondim] real :: f2 ! The squared Coriolis parameter [T-2 ~> s-2]. real :: favg ! The average Coriolis parameter at a point [T-1 ~> s-1]. real :: df_dy, df_dx ! The x- and y- gradients of the Coriolis parameter [T-1 L-1 ~> s-1 m-1]. real :: dlnCn_dx ! The x-gradient of the wave speed divided by itself [L-1 ~> m-1]. real :: dlnCn_dy ! The y-gradient of the wave speed divided by itself [L-1 ~> m-1]. - real :: Angle_size, dt_Angle_size, angle - real :: Ifreq, Kmag2, I_Kmag + real :: Angle_size ! The size of each wedge of angles [rad] + real :: dt_Angle_size ! The time step divided by the angle size [T rad-1 ~> s rad-1] + real :: angle ! The central angle of each wedge [rad] + real :: Ifreq ! The inverse of the wave frequency [T ~> s] + real :: Kmag2 ! A squared horizontal wavenumber [L-2 ~> m-2] + real :: I_Kmag ! The inverse of the magnitude of the horizontal wavenumber [L ~> m] real :: cn_subRO ! A tiny wave speed to prevent division by zero [L T-1 ~> m s-1] integer :: is, ie, js, je, asd, aed, na integer :: i, j, a - real :: wgt1, wgt2 + real :: wgt1, wgt2 ! Weights in an average, both of which may be 0 [nondim] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; na = size(En,3) asd = 1-stencil ; aed = NAngle+stencil cnmask(:,:) = merge(0., 1., cn(:,:) == 0.) - do j=js,je ; do i=is-1,ie + do j=js,je ; do I=is-1,ie ! wgt = 0 if local cn == 0, wgt = 0.5 if both contiguous values != 0 ! and wgt = 1 if neighbour cn == 0 - wgt1 = cnmask(i,j) - 0.5 * cnmask(i,j) * cnmask(i+1,j) - wgt2 = cnmask(i+1,j) - 0.5 * cnmask(i,j) * cnmask(i+1,j) - cn_u(I,j) = wgt1*cn(i,j) + wgt2*cn(i+1,j) + wgt1 = cnmask(i,j) - (0.5 * cnmask(i,j) * cnmask(i+1,j)) + wgt2 = cnmask(i+1,j) - (0.5 * cnmask(i,j) * cnmask(i+1,j)) + cn_u(I,j) = (wgt1*cn(i,j)) + (wgt2*cn(i+1,j)) enddo ; enddo - do j=js-1,je ; do i=is,ie - wgt1 = cnmask(i,j) - 0.5 * cnmask(i,j) * cnmask(i,j+1) - wgt2 = cnmask(i,j+1) - 0.5 * cnmask(i,j) * cnmask(i,j+1) - cn_v(i,J) = wgt1*cn(i,j) + wgt2*cn(i,j+1) + do J=js-1,je ; do i=is,ie + wgt1 = cnmask(i,j) - (0.5 * cnmask(i,j) * cnmask(i,j+1)) + wgt2 = cnmask(i,j+1) - (0.5 * cnmask(i,j) * cnmask(i,j+1)) + cn_v(i,J) = (wgt1*cn(i,j)) + (wgt2*cn(i,j+1)) enddo ; enddo Ifreq = 1.0 / freq @@ -840,14 +1932,14 @@ subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) ! Do the refraction. do i=is,ie - f2 = 0.25* ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & - (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2)) + f2 = 0.25* ((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + & + (G%Coriolis2Bu(I,J-1) + G%Coriolis2Bu(I-1,J))) favg = 0.25*((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) + & (G%CoriolisBu(I,J-1) + G%CoriolisBu(I-1,J))) - df_dx = 0.5*((G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1)) - & - (G%CoriolisBu(I-1,J) + G%CoriolisBu(I-1,J-1))) * G%IdxT(i,j) - df_dy = 0.5*((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) - & - (G%CoriolisBu(I,J-1) + G%CoriolisBu(I-1,J-1))) * G%IdyT(i,j) + df_dx = 0.5*G%IdxT(i,j)*((G%CoriolisBu(I,J) - G%CoriolisBu(I-1,J-1)) + & + (G%CoriolisBu(I,J-1) - G%CoriolisBu(I-1,J))) + df_dy = 0.5*G%IdyT(i,j)*((G%CoriolisBu(I,J) - G%CoriolisBu(I-1,J-1)) + & + (G%CoriolisBu(I-1,J) - G%CoriolisBu(I,J-1))) dlnCn_dx = G%IdxT(i,j) * (cn_u(I,j) - cn_u(I-1,j)) / (0.5 * (cn_u(I,j) + cn_u(I-1,j)) + cn_subRO) dlnCn_dy = G%IdyT(i,j) * (cn_v(i,J) - cn_v(i,J-1)) / (0.5 * (cn_v(i,J) + cn_v(i,J-1)) + cn_subRO) @@ -865,10 +1957,10 @@ subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) ! Determine the energy fluxes in angular orientation space. do A=asd,aed ; do i=is,ie - CFL_ang(i,j,A) = (cos_angle(A) * Dl_Dt_Kmag(i) - sin_angle(A) * Dk_Dt_Kmag(i)) * dt_Angle_size + CFL_ang(i,j,A) = ((cos_angle(A) * Dl_Dt_Kmag(i)) - (sin_angle(A) * Dk_Dt_Kmag(i))) * dt_Angle_size if (abs(CFL_ang(i,j,A)) > 1.0) then call MOM_error(WARNING, "refract: CFL exceeds 1.", .true.) - if (CFL_ang(i,j,A) > 0.0) then ; CFL_ang(i,j,A) = 1.0 ; else ; CFL_ang(i,j,A) = -1.0 ; endif + if (CFL_ang(i,j,A) > 1.0) then ; CFL_ang(i,j,A) = 1.0 ; else ; CFL_ang(i,j,A) = -1.0 ; endif endif enddo ; enddo @@ -903,31 +1995,30 @@ end subroutine refract !! piecewise parabolic scheme. This needs to be called from within i and j spatial loops. subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) integer, intent(in) :: NAngle !< The number of wave orientations in the - !! discretized wave energy spectrum. + !! discretized wave energy spectrum [nondim] real, intent(in) :: dt !< Time increment [T ~> s]. integer, intent(in) :: halo_ang !< The halo size in angular space real, dimension(1-halo_ang:NAngle+halo_ang), & intent(in) :: En2d !< The internal gravity wave energy density as a - !! function of angular resolution [R Z3 T-2 ~> J m-2]. + !! function of angular resolution [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(1-halo_ang:NAngle+halo_ang), & - intent(in) :: CFL_ang !< The CFL number of the energy advection across angles + intent(in) :: CFL_ang !< The CFL number of the energy advection across angles [nondim] real, dimension(0:NAngle), intent(out) :: Flux_En !< The time integrated internal wave energy flux - !! across angles [R Z3 T-2 ~> J m-2]. + !! across angles [H Z2 T-2 ~> m3 s-2 or J m-2]. ! Local variables - real :: flux + real :: flux ! The internal wave energy flux across angles [H Z2 T-3 ~> m3 s-3 or W m-2]. real :: u_ang ! Angular propagation speed [Rad T-1 ~> Rad s-1] real :: Angle_size ! The size of each orientation wedge in radians [Rad] - real :: I_Angle_size ! The inverse of the the orientation wedges [Rad-1] + real :: I_Angle_size ! The inverse of the orientation wedges [Rad-1] real :: I_dt ! The inverse of the timestep [T-1 ~> s-1] - real :: aR, aL ! Left and right edge estimates of energy density [R Z3 T-2 rad-1 ~> J m-2 rad-1] - real :: dMx, dMn + real :: aR, aL ! Left and right edge estimates of energy density [H Z2 T-2 rad-1 ~> m3 s-2 rad-1 or J m-2 rad-1] real :: Ep, Ec, Em ! Mean angular energy density for three successive wedges in angular - ! orientation [R Z3 T-2 rad-1 ~> J m-2 rad-1] - real :: dA, curv_3 ! Difference and curvature of energy density [R Z3 T-2 rad-1 ~> J m-2 rad-1] + ! orientation [H Z2 T-2 rad-1 ~> m3 s-2 rad-1 or J m-2 rad-1] + real :: dA, curv_3 ! Difference and curvature of energy density [H Z2 T-2 rad-1 ~> m3 s-2 rad-1 or J m-2 rad-1] real, parameter :: oneSixth = 1.0/6.0 ! One sixth [nondim] integer :: a - I_dt = 1 / dt + I_dt = 1.0 / dt Angle_size = (8.0*atan(1.0)) / (real(NAngle)) I_Angle_size = 1 / Angle_size Flux_En(:) = 0 @@ -937,7 +2028,7 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) if (u_ang >= 0.0) then ! Implementation of PPM-H3 ! Convert wedge-integrated energy density into angular energy densities for three successive - ! wedges around the source wedge for this flux [R Z3 T-2 rad-1 ~> J m-2 rad-1]. + ! wedges around the source wedge for this flux [H Z2 T-2 rad-1 ~> m3 s-2 rad-1 or J m-2 rad-1]. Ep = En2d(a+1)*I_Angle_size Ec = En2d(a) *I_Angle_size Em = En2d(a-1)*I_Angle_size @@ -955,15 +2046,15 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) aR = 3.*Ec - 2.*aL ! Flatten the profile to move the extremum to the right edge endif curv_3 = (aR + aL) - 2.0*Ec ! Curvature - ! Calculate angular flux rate [R Z3 T-3 ~> W m-2] + ! Calculate angular flux rate [H Z2 T-3 ~> m3 s-3 or W m-2] flux = u_ang*( aR + CFL_ang(A) * ( 0.5*(aL - aR) + curv_3 * (CFL_ang(A) - 1.5) ) ) - ! Calculate amount of energy fluxed between wedges [R Z3 T-2 ~> J m-2] + ! Calculate amount of energy fluxed between wedges [H Z2 T-2 ~> m3 s-2 or J m-2] Flux_En(A) = dt * flux !Flux_En(A) = (dt * I_Angle_size) * flux else ! Implementation of PPM-H3 ! Convert wedge-integrated energy density into angular energy densities for three successive - ! wedges around the source wedge for this flux [R Z3 T-2 rad-1 ~> J m-2 rad-1]. + ! wedges around the source wedge for this flux [H Z2 T-2 rad-1 ~> m3 s-2 rad-1 or J m-2 rad-1]. Ep = En2d(a+2)*I_Angle_size Ec = En2d(a+1)*I_Angle_size Em = En2d(a) *I_Angle_size @@ -981,10 +2072,10 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) aR = 3.*Ec - 2.*aL ! Flatten the profile to move the extremum to the right edge endif curv_3 = (aR + aL) - 2.0*Ec ! Curvature - ! Calculate angular flux rate [R Z3 T-3 ~> W m-2] + ! Calculate angular flux rate [H Z2 T-3 ~> m3 s-3 or W m-2] ! Note that CFL_ang is negative here, so it looks odd compared with equivalent expressions. flux = u_ang*( aL - CFL_ang(A) * ( 0.5*(aR - aL) + curv_3 * (-CFL_ang(A) - 1.5) ) ) - ! Calculate amount of energy fluxed between wedges [R Z3 T-2 ~> J m-2] + ! Calculate amount of energy fluxed between wedges [H Z2 T-2 ~> m3 s-2 or J m-2] Flux_En(A) = dt * flux !Flux_En(A) = (dt * I_Angle_size) * flux endif @@ -992,41 +2083,50 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) end subroutine PPM_angular_advect !> Propagates internal waves at a single frequency. -subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle) +subroutine propagate(En, cn, freq, dt, G, GV, US, CS, NAngle, test, halo_size, residual_loss) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: En !< The internal gravity wave energy density as a !! function of space and angular resolution, - !! [R Z3 T-2 ~> J m-2]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(in) :: cn !< Baroclinic mode speed [L T-1 ~> m s-1]. real, intent(in) :: freq !< Wave frequency [T-1 ~> s-1]. real, intent(in) :: dt !< Time step [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(int_tide_CS), intent(in) :: CS !< Internal tide control struct - + real, dimension(G%isd:G%ied,G%jsd:G%jed,2), intent(in) :: test !< test rotation vector + type(int_tide_CS), intent(inout) :: CS !< Internal tide control structure + integer, intent(in) :: halo_size !< halo size for correct rotation + real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & + intent(inout) :: residual_loss !< internal tide energy loss due + !! to the residual at slopes [H Z2 T-3 ~> m3 s-3 or W m-2]. ! Local variables - real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB) :: & - speed ! The magnitude of the group velocity at the q points for corner adv [L T-1 ~> m s-1]. integer, parameter :: stencil = 2 real, dimension(SZIB_(G),SZJ_(G)) :: & speed_x ! The magnitude of the group velocity at the Cu points [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJB_(G)) :: & speed_y ! The magnitude of the group velocity at the Cv points [L T-1 ~> m s-1]. real, dimension(0:NAngle) :: & - cos_angle, sin_angle + cos_angle, sin_angle ! The cosine and sine of each angle [nondim] real, dimension(NAngle) :: & - Cgx_av, Cgy_av, dCgx, dCgy + Cgx_av, & ! The average projection of the wedge into the x-direction [nondim] + Cgy_av, & ! The average projection of the wedge into the y-direction [nondim] + dCgx, & ! The difference in x-projections between the edges of each angular band [nondim]. + dCgy ! The difference in y-projections between the edges of each angular band [nondim]. real :: f2 ! The squared Coriolis parameter [T-2 ~> s-2]. - real :: Angle_size, I_Angle_size, angle + real :: Angle_size ! The size of each wedge of angles [rad] + real :: I_Angle_size ! The inverse of the size of each wedge of angles [rad-1] + real :: angle ! The central angle of each wedge [rad] real :: Ifreq ! The inverse of the frequency [T ~> s] real :: freq2 ! The frequency squared [T-2 ~> s-2] type(loop_bounds_type) :: LB + logical :: x_first integer :: is, ie, js, je, asd, aed, na integer :: ish, ieh, jsh, jeh - integer :: i, j, a + integer :: i, j, a, fr, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; na = size(En,3) asd = 1-stencil ; aed = NAngle+stencil @@ -1048,369 +2148,144 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle) Angle_size = (8.0*atan(1.0)) / real(NAngle) I_Angle_size = 1.0 / Angle_size - if (CS%corner_adv) then - ! IMPLEMENT CORNER ADVECTION IN HORIZONTAL-------------------- - ! FIND AVERAGE GROUP VELOCITY (SPEED) AT CELL CORNERS - ! NOTE: THIS HAS NOT BE ADAPTED FOR REFLECTION YET (BDM)!! - ! Fix indexing here later - speed(:,:) = 0.0 - do J=jsh-1,jeh ; do I=ish-1,ieh - f2 = G%CoriolisBu(I,J)**2 - speed(I,J) = 0.25*(cn(i,j) + cn(i+1,j) + cn(i+1,j+1) + cn(i,j+1)) * & - sqrt(max(freq2 - f2, 0.0)) * Ifreq + x_first = .true. ! x_first = (MOD(G%first_direction,2) == 0) + + if (CS%debug) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: top of routine') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'propagate: top of routine', CS%En_sum enddo ; enddo - do a=1,na - ! Apply the propagation WITH CORNER ADVECTION/FINITE VOLUME APPROACH. - LB%jsh = js ; LB%jeh = je ; LB%ish = is ; LB%ieh = ie - call propagate_corner_spread(En(:,:,a), a, NAngle, speed, dt, G, CS, LB) - enddo ! a-loop - else - ! IMPLEMENT PPM ADVECTION IN HORIZONTAL----------------------- - ! These could be in the control structure, as they do not vary. - do A=0,na - ! These are the angles at the cell edges... - angle = (real(A) - 0.5) * Angle_size - cos_angle(A) = cos(angle) ; sin_angle(A) = sin(angle) - enddo + endif - do a=1,na - Cgx_av(a) = (sin_angle(A) - sin_angle(A-1)) * I_Angle_size - Cgy_av(a) = -(cos_angle(A) - cos_angle(A-1)) * I_Angle_size - dCgx(a) = sqrt(0.5 + 0.5*(sin_angle(A)*cos_angle(A) - & - sin_angle(A-1)*cos_angle(A-1)) * I_Angle_size - & - Cgx_av(a)**2) - dCgy(a) = sqrt(0.5 - 0.5*(sin_angle(A)*cos_angle(A) - & - sin_angle(A-1)*cos_angle(A-1)) * I_Angle_size - & - Cgy_av(a)**2) - enddo + ! IMPLEMENT PPM ADVECTION IN HORIZONTAL----------------------- + ! These could be in the control structure, as they do not vary. + do A=0,na + ! These are the angles at the cell edges... + angle = (real(A) - 0.5) * Angle_size + cos_angle(A) = cos(angle) ; sin_angle(A) = sin(angle) + enddo - do j=jsh,jeh ; do I=ish-1,ieh - f2 = 0.5 * (G%CoriolisBu(I,J)**2 + G%CoriolisBu(I,J-1)**2) - speed_x(I,j) = 0.5*(cn(i,j) + cn(i+1,j)) * G%mask2dCu(I,j) * & - sqrt(max(freq2 - f2, 0.0)) * Ifreq - enddo ; enddo - do J=jsh-1,jeh ; do i=ish,ieh - f2 = 0.5 * (G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J)**2) - speed_y(i,J) = 0.5*(cn(i,j) + cn(i,j+1)) * G%mask2dCv(i,J) * & - sqrt(max(freq2 - f2, 0.0)) * Ifreq - enddo ; enddo + do a=1,na + Cgx_av(a) = (sin_angle(A) - sin_angle(A-1)) * I_Angle_size + Cgy_av(a) = -(cos_angle(A) - cos_angle(A-1)) * I_Angle_size + dCgx(a) = sqrt(0.5 + 0.5*(sin_angle(A)*cos_angle(A) - & + sin_angle(A-1)*cos_angle(A-1)) * I_Angle_size - & + Cgx_av(a)**2) + dCgy(a) = sqrt(0.5 - 0.5*(sin_angle(A)*cos_angle(A) - & + sin_angle(A-1)*cos_angle(A-1)) * I_Angle_size - & + Cgy_av(a)**2) + enddo - ! Apply propagation in x-direction (reflection included) - LB%jsh = jsh ; LB%jeh = jeh ; LB%ish = ish ; LB%ieh = ieh - call propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, CS%nAngle, CS, LB) + speed_x(:,:) = 0. + do j=jsh,jeh ; do I=ish-1,ieh + f2 = 0.5 * (G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I,J-1)) + speed_x(I,j) = 0.5*(cn(i,j) + cn(i+1,j)) * G%mask2dCu(I,j) * & + sqrt(max(freq2 - f2, 0.0)) * Ifreq + enddo ; enddo - ! Check for energy conservation on computational domain (for debugging) - !call sum_En(G, CS, En, 'post-propagate_x') + speed_y(:,:) = 0. + do J=jsh-1,jeh ; do i=ish,ieh + f2 = 0.5 * (G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J)) + speed_y(i,J) = 0.5*(cn(i,j) + cn(i,j+1)) * G%mask2dCv(i,J) * & + sqrt(max(freq2 - f2, 0.0)) * Ifreq + enddo ; enddo - ! Update halos - call pass_var(En, G%domain) + call pass_var(speed_x, G%Domain, position=EAST_FACE) + call pass_var(speed_y, G%Domain, position=NORTH_FACE) - ! Apply propagation in y-direction (reflection included) - ! LB%jsh = js ; LB%jeh = je ; LB%ish = is ; LB%ieh = ie ! Use if no teleport - LB%jsh = jsh ; LB%jeh = jeh ; LB%ish = ish ; LB%ieh = ieh - call propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, CS%nAngle, CS, LB) + call pass_var(En, G%domain) - ! Check for energy conservation on computational domain (for debugging) - !call sum_En(G, CS, En, 'post-propagate_y') + ! Apply propagation in the first direction (reflection included) + LB%jsh = jsh ; LB%jeh = jeh ; LB%ish = ish ; LB%ieh = ieh + if (x_first) then + call propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, CS%nAngle, CS, LB, residual_loss, freq2) + else + call propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, CS%nAngle, CS, LB, residual_loss, freq2) endif -end subroutine propagate + ! fix underflows + do a=1,na ; do j=jsh,jeh ; do i=ish,ieh + if (abs(En(i,j,a)) < CS%En_underflow) En(i,j,a) = 0.0 + enddo ; enddo ; enddo -!> This subroutine does first-order corner advection. It was written with the hopes -!! of smoothing out the garden sprinkler effect, but is too numerically diffusive to -!! be of much use as of yet. It is not yet compatible with reflection schemes (BDM). -subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS, LB) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(inout) :: En !< The energy density integrated over an angular - !! band [R Z3 T-2 ~> J m-2]. - real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed), & - intent(in) :: speed !< The magnitude of the group velocity at the cell - !! corner points [L T-1 ~> m s-1]. - integer, intent(in) :: energized_wedge !< Index of current ray direction. - integer, intent(in) :: NAngle !< The number of wave orientations in the - !! discretized wave energy spectrum. - real, intent(in) :: dt !< Time increment [T ~> s]. - type(int_tide_CS), intent(in) :: CS !< Internal tide control struct - type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. - ! Local variables - integer :: i, j, k, ish, ieh, jsh, jeh, m - real :: TwoPi, Angle_size - real :: energized_angle ! angle through center of current wedge - real :: theta ! angle at edge of wedge - real :: Nsubrays ! number of sub-rays for averaging - ! count includes the two rays that bound the current wedge, - ! i.e. those at -dtheta/2 and +dtheta/2 from energized angle - real :: I_Nsubwedges ! inverse of number of sub-wedges - real :: cos_thetaDT, sin_thetaDT ! cos(theta)*dt, sin(theta)*dt - real :: xNE,xNW,xSW,xSE,yNE,yNW,ySW,ySE ! corner point coordinates of advected fluid parcel - real :: CFL_xNE,CFL_xNW,CFL_xSW,CFL_xSE,CFL_yNE,CFL_yNW,CFL_ySW,CFL_ySE,CFL_max - real :: xN,xS,xE,xW,yN,yS,yE,yW ! intersection point coordinates of parcel edges and grid - real :: xCrn,yCrn ! grid point contained within advected fluid parcel - real :: xg,yg ! grid point of interest - real :: slopeN,slopeW,slopeS,slopeE, bN,bW,bS,bE ! parameters defining parcel sides - real :: aNE,aN,aNW,aW,aSW,aS,aSE,aE,aC ! sub-areas of advected parcel - real :: a_total ! total area of advected parcel - real :: a1,a2,a3,a4 ! areas used in calculating polygon areas (sub-areas) of advected parcel - real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: x,y ! coordinates of cell corners - real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: Idx,Idy ! inverse of dx,dy at cell corners - real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: dx,dy ! dx,dy at cell corners - real, dimension(2) :: E_new ! Energy in cell after advection for subray [R Z3 T-2 ~> J m-2]; set size - ! here to define Nsubrays - this should be made an input option later! + if (CS%debug) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: after propagate_x') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'propagate: after propagate_x', CS%En_sum + enddo ; enddo + endif - ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh - TwoPi = (8.0*atan(1.0)) - Nsubrays = real(size(E_new)) - I_Nsubwedges = 1./(Nsubrays - 1) - - Angle_size = TwoPi / real(NAngle) - energized_angle = Angle_size * real(energized_wedge - 1) ! for a=1 aligned with x-axis - !energized_angle = Angle_size * real(energized_wedge - 1) + 2.0*Angle_size ! - !energized_angle = Angle_size * real(energized_wedge - 1) + 0.5*Angle_size ! - do J=jsh-1,jeh ; do I=ish-1,ieh - ! This will only work for a Cartesian grid for which G%geoLonBu is in the same units has dx. - ! This needs to be extensively revised to work for a general grid. - x(I,J) = G%US%m_to_L*G%geoLonBu(I,J) - y(I,J) = G%US%m_to_L*G%geoLatBu(I,J) - Idx(I,J) = G%IdxBu(I,J) ; dx(I,J) = G%dxBu(I,J) - Idy(I,J) = G%IdyBu(I,J) ; dy(I,J) = G%dyBu(I,J) - enddo ; enddo + ! Update halos + call pass_var(En, G%domain) + call correct_halo_rotation_2d(En, test, G, NAngle, halo=halo_size) - do j=jsh,jeh ; do i=ish,ieh - do m=1,int(Nsubrays) - theta = energized_angle - 0.5*Angle_size + real(m - 1)*Angle_size*I_Nsubwedges - if (theta < 0.0) then - theta = theta + TwoPi - elseif (theta > TwoPi) then - theta = theta - TwoPi - endif - cos_thetaDT = cos(theta)*dt - sin_thetaDT = sin(theta)*dt - - ! corner point coordinates of advected fluid parcel ---------- - xg = x(I,J); yg = y(I,J) - xNE = xg - speed(I,J)*cos_thetaDT - yNE = yg - speed(I,J)*sin_thetaDT - CFL_xNE = (xg-xNE)*Idx(I,J) - CFL_yNE = (yg-yNE)*Idy(I,J) - - xg = x(I-1,J); yg = y(I-1,J) - xNW = xg - speed(I-1,J)*cos_thetaDT - yNW = yg - speed(I-1,J)*sin_thetaDT - CFL_xNW = (xg-xNW)*Idx(I-1,J) - CFL_yNW = (yg-yNW)*Idy(I-1,J) - - xg = x(I-1,J-1); yg = y(I-1,J-1) - xSW = xg - speed(I-1,J-1)*cos_thetaDT - ySW = yg - speed(I-1,J-1)*sin_thetaDT - CFL_xSW = (xg-xSW)*Idx(I-1,J-1) - CFL_ySW = (yg-ySW)*Idy(I-1,J-1) - - xg = x(I,J-1); yg = y(I,J-1) - xSE = xg - speed(I,J-1)*cos_thetaDT - ySE = yg - speed(I,J-1)*sin_thetaDT - CFL_xSE = (xg-xSE)*Idx(I,J-1) - CFL_ySE = (yg-ySE)*Idy(I,J-1) - - CFL_max = max(abs(CFL_xNE),abs(CFL_xNW),abs(CFL_xSW), & - abs(CFL_xSE),abs(CFL_yNE),abs(CFL_yNW), & - abs(CFL_ySW),abs(CFL_ySE)) - if (CFL_max > 1.0) then - call MOM_error(WARNING, "propagate_corner_spread: CFL exceeds 1.", .true.) - endif + if (CS%debug) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: after halo update') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'propagate: after halo update', CS%En_sum + enddo ; enddo + endif + ! Apply propagation in the second direction (reflection included) + ! LB%jsh = js ; LB%jeh = je ; LB%ish = is ; LB%ieh = ie ! Use if no teleport + LB%jsh = jsh ; LB%jeh = jeh ; LB%ish = ish ; LB%ieh = ieh + if (x_first) then + call propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, CS%nAngle, CS, LB, residual_loss, freq2) + else + call propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, CS%nAngle, CS, LB, residual_loss, freq2) + endif + + ! fix underflows + do a=1,na ; do j=jsh,jeh ; do i=ish,ieh + if (abs(En(i,j,a)) < CS%En_underflow) En(i,j,a) = 0.0 + enddo ; enddo ; enddo - ! intersection point coordinates of parcel edges and cell edges --- - if (0.0 <= theta .and. theta < 0.25*TwoPi) then - xN = x(I-1,J-1) - yW = y(I-1,J-1) - elseif (0.25*TwoPi <= theta .and. theta < 0.5*TwoPi) then - xN = x(I,J-1) - yW = y(I,J-1) - elseif (0.5*TwoPi <= theta .and. theta < 0.75*TwoPi) then - xN = x(I,J) - yW = y(I,J) - elseif (0.75*TwoPi <= theta .and. theta <= 1.00*TwoPi) then - xN = x(I-1,J) - yW = y(I-1,J) - endif - xS = xN - yE = yW - - ! north intersection - slopeN = (yNE - yNW)/(xNE - xNW) - bN = -slopeN*xNE + yNE - yN = slopeN*xN + bN - ! west intersection - if (xNW == xSW) then - xW = xNW - else - slopeW = (yNW - ySW)/(xNW - xSW) - bW = -slopeW*xNW + yNW - xW = (yW - bW)/slopeW - endif - ! south intersection - slopeS = (ySW - ySE)/(xSW - xSE) - bS = -slopeS*xSW + ySW - yS = slopeS*xS + bS - ! east intersection - if (xNE == xSE) then - xE = xNE - else - slopeE = (ySE - yNE)/(xSE - xNE) - bE = -slopeE*xSE + ySE - xE = (yE - bE)/slopeE - endif + call pass_var(En, G%domain) + call correct_halo_rotation_2d(En, test, G, NAngle, halo=halo_size) - ! areas -------------------------------------------- - aNE = 0.0; aN = 0.0; aNW = 0.0; ! initialize areas - aW = 0.0; aSW = 0.0; aS = 0.0; ! initialize areas - aSE = 0.0; aE = 0.0; aC = 0.0; ! initialize areas - if (0.0 <= theta .and. theta < 0.25*TwoPi) then - xCrn = x(I-1,J-1); yCrn = y(I-1,J-1) - ! west area - a1 = (yN - yCrn)*(0.5*(xN + xCrn)) - a2 = (yCrn - yW)*(0.5*(xCrn + xW)) - a3 = (yW - yNW)*(0.5*(xW + xNW)) - a4 = (yNW - yN)*(0.5*(xNW + xN)) - aW = a1 + a2 + a3 + a4 - ! southwest area - a1 = (yCrn - yS)*(0.5*(xCrn + xS)) - a2 = (yS - ySW)*(0.5*(xS + xSW)) - a3 = (ySW - yW)*(0.5*(xSW + xW)) - a4 = (yW - yCrn)*(0.5*(xW + xCrn)) - aSW = a1 + a2 + a3 + a4 - ! south area - a1 = (yE - ySE)*(0.5*(xE + xSE)) - a2 = (ySE - yS)*(0.5*(xSE + xS)) - a3 = (yS - yCrn)*(0.5*(xS + xCrn)) - a4 = (yCrn - yE)*(0.5*(xCrn + xE)) - aS = a1 + a2 + a3 + a4 - ! area within cell - a1 = (yNE - yE)*(0.5*(xNE + xE)) - a2 = (yE - yCrn)*(0.5*(xE + xCrn)) - a3 = (yCrn - yN)*(0.5*(xCrn + xN)) - a4 = (yN - yNE)*(0.5*(xN + xNE)) - aC = a1 + a2 + a3 + a4 - elseif (0.25*TwoPi <= theta .and. theta < 0.5*TwoPi) then - xCrn = x(I,J-1); yCrn = y(I,J-1) - ! south area - a1 = (yCrn - yS)*(0.5*(xCrn + xS)) - a2 = (yS - ySW)*(0.5*(xS + xSW)) - a3 = (ySW - yW)*(0.5*(xSW + xW)) - a4 = (yW - yCrn)*(0.5*(xW + xCrn)) - aS = a1 + a2 + a3 + a4 - ! southeast area - a1 = (yE - ySE)*(0.5*(xE + xSE)) - a2 = (ySE - yS)*(0.5*(xSE + xS)) - a3 = (yS - yCrn)*(0.5*(xS + xCrn)) - a4 = (yCrn - yE)*(0.5*(xCrn + xE)) - aSE = a1 + a2 + a3 + a4 - ! east area - a1 = (yNE - yE)*(0.5*(xNE + xE)) - a2 = (yE - yCrn)*(0.5*(xE + xCrn)) - a3 = (yCrn - yN)*(0.5*(xCrn + xN)) - a4 = (yN - yNE)*(0.5*(xN + xNE)) - aE = a1 + a2 + a3 + a4 - ! area within cell - a1 = (yN - yCrn)*(0.5*(xN + xCrn)) - a2 = (yCrn - yW)*(0.5*(xCrn + xW)) - a3 = (yW - yNW)*(0.5*(xW + xNW)) - a4 = (yNW - yN)*(0.5*(xNW + xN)) - aC = a1 + a2 + a3 + a4 - elseif (0.5*TwoPi <= theta .and. theta < 0.75*TwoPi) then - xCrn = x(I,J); yCrn = y(I,J) - ! east area - a1 = (yE - ySE)*(0.5*(xE + xSE)) - a2 = (ySE - yS)*(0.5*(xSE + xS)) - a3 = (yS - yCrn)*(0.5*(xS + xCrn)) - a4 = (yCrn - yE)*(0.5*(xCrn + xE)) - aE = a1 + a2 + a3 + a4 - ! northeast area - a1 = (yNE - yE)*(0.5*(xNE + xE)) - a2 = (yE - yCrn)*(0.5*(xE + xCrn)) - a3 = (yCrn - yN)*(0.5*(xCrn + xN)) - a4 = (yN - yNE)*(0.5*(xN + xNE)) - aNE = a1 + a2 + a3 + a4 - ! north area - a1 = (yN - yCrn)*(0.5*(xN + xCrn)) - a2 = (yCrn - yW)*(0.5*(xCrn + xW)) - a3 = (yW - yNW)*(0.5*(xW + xNW)) - a4 = (yNW - yN)*(0.5*(xNW + xN)) - aN = a1 + a2 + a3 + a4 - ! area within cell - a1 = (yCrn - yS)*(0.5*(xCrn + xS)) - a2 = (yS - ySW)*(0.5*(xS + xSW)) - a3 = (ySW - yW)*(0.5*(xSW + xW)) - a4 = (yW - yCrn)*(0.5*(xW + xCrn)) - aC = a1 + a2 + a3 + a4 - elseif (0.75*TwoPi <= theta .and. theta <= 1.00*TwoPi) then - xCrn = x(I-1,J); yCrn = y(I-1,J) - ! north area - a1 = (yNE - yE)*(0.5*(xNE + xE)) - a2 = (yE - yCrn)*(0.5*(xE + xCrn)) - a3 = (yCrn - yN)*(0.5*(xCrn + xN)) - a4 = (yN - yNE)*(0.5*(xN + xNE)) - aN = a1 + a2 + a3 + a4 - ! northwest area - a1 = (yN - yCrn)*(0.5*(xN + xCrn)) - a2 = (yCrn - yW)*(0.5*(xCrn + xW)) - a3 = (yW - yNW)*(0.5*(xW + xNW)) - a4 = (yNW - yN)*(0.5*(xNW + xN)) - aNW = a1 + a2 + a3 + a4 - ! west area - a1 = (yCrn - yS)*(0.5*(xCrn + xS)) - a2 = (yS - ySW)*(0.5*(xS + xSW)) - a3 = (ySW - yW)*(0.5*(xSW + xW)) - a4 = (yW - yCrn)*(0.5*(xW + xCrn)) - aW = a1 + a2 + a3 + a4 - ! area within cell - a1 = (yE - ySE)*(0.5*(xE + xSE)) - a2 = (ySE - yS)*(0.5*(xSE + xS)) - a3 = (yS - yCrn)*(0.5*(xS + xCrn)) - a4 = (yCrn - yE)*(0.5*(xCrn + xE)) - aC = a1 + a2 + a3 + a4 - endif + if (CS%debug) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq + call sum_En(G, GV, US, CS, CS%En(:,:,:,fr,m), 'propagate: bottom of routine') + if (is_root_pe()) write(stdout,'(A,E18.10)') 'propagate: bottom of routine', CS%En_sum + enddo ; enddo + endif + +end subroutine propagate - ! energy weighting ---------------------------------------- - a_total = aNE + aN + aNW + aW + aSW + aS + aSE + aE + aC - E_new(m) = (aNE*En(i+1,j+1) + aN*En(i,j+1) + aNW*En(i-1,j+1) + & - aW*En(i-1,j) + aSW*En(i-1,j-1) + aS*En(i,j-1) + & - aSE*En(i+1,j-1) + aE*En(i+1,j) + aC*En(i,j)) / (dx(i,j)*dy(i,j)) - enddo ! m-loop - ! update energy in cell - En(i,j) = sum(E_new)/Nsubrays - enddo ; enddo -end subroutine propagate_corner_spread !> Propagates the internal wave energy in the logical x-direction. -subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB) +subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, residual_loss, freq2) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & intent(inout) :: En !< The energy density integrated over an angular - !! band [R Z3 T-2 ~> J m-2]. + !! band [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(G%IsdB:G%IedB,G%jsd:G%jed), & intent(in) :: speed_x !< The magnitude of the group velocity at the !! Cu points [L T-1 ~> m s-1]. - real, dimension(Nangle), intent(in) :: Cgx_av !< The average x-projection in each angular band. + real, dimension(Nangle), intent(in) :: Cgx_av !< The average x-projection in each angular band [nondim] real, dimension(Nangle), intent(in) :: dCgx !< The difference in x-projections between the - !! edges of each angular band. + !! edges of each angular band [nondim]. real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(int_tide_CS), intent(in) :: CS !< Internal tide control struct + type(int_tide_CS), intent(in) :: CS !< Internal tide control structure type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. + real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & + intent(inout) :: residual_loss !< internal tide energy loss due + !! to the residual at slopes [H Z2 T-3 ~> m3 s-3 or W m-2]. + real, intent(in) :: freq2 !< The square of internal tides frequency [T-2 ~> s-2]. + ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - EnL, EnR ! Left and right face energy densities [R Z3 T-2 ~> J m-2]. + EnL, EnR ! Left and right face energy densities [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZIB_(G),SZJ_(G)) :: & - flux_x ! The internal wave energy flux [R Z3 L2 T-3 ~> J s-1]. + flux_x ! The internal wave energy flux [H Z2 L2 T-3 ~> m5 s-3 or J s-1]. real, dimension(SZIB_(G)) :: & - cg_p, cg_m, flux1, flux2 - !real, dimension(SZI_(G),SZJB_(G),Nangle) :: En_m, En_p + cg_p, & ! The x-direction group velocity [L T-1 ~> m s-1] + flux1 ! A 1-d copy of the x-direction internal wave energy flux [H Z2 L2 T-3 ~> m5 s-3 or J s-1]. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle) :: & - Fdt_m, Fdt_p! Left and right energy fluxes [R Z3 L2 T-2 ~> J] - integer :: i, j, k, ish, ieh, jsh, jeh, a + Fdt_m, Fdt_p! Left and right energy fluxes [H Z2 L2 T-2 ~> m5 s-2 or J] + integer :: i, j, ish, ieh, jsh, jeh, a ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh do a=1,Nangle @@ -1420,7 +2295,8 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB) EnL(i,j) = En(i,j,a) ; EnR(i,j) = En(i,j,a) enddo ; enddo else - call PPM_reconstruction_x(En(:,:,a), EnL, EnR, G, LB, simple_2nd=CS%simple_2nd) + call PPM_reconstruction_x(En(:,:,a), EnL, EnR, G, LB, & + simple_2nd=CS%simple_2nd, adv_limiter=CS%itides_adv_limiter) endif do j=jsh,jeh @@ -1430,12 +2306,19 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB) enddo call zonal_flux_En(cg_p, En(:,j,a), EnL(:,j), EnR(:,j), flux1, & dt, G, US, j, ish, ieh, CS%vol_CFL) - do I=ish-1,ieh ; flux_x(I,j) = flux1(I); enddo + do I=ish-1,ieh ; flux_x(I,j) = flux1(I) ; enddo enddo do j=jsh,jeh ; do i=ish,ieh - Fdt_m(i,j,a) = dt*flux_x(I-1,j) ! left face influx [R Z3 L2 T-2 ~> J] - Fdt_p(i,j,a) = -dt*flux_x(I,j) ! right face influx [R Z3 L2 T-2 ~> J] + Fdt_m(i,j,a) = dt*flux_x(I-1,j) ! left face influx [H Z2 L2 T-2 ~> m5 s-2 or J] + Fdt_p(i,j,a) = -dt*flux_x(I,j) ! right face influx [H Z2 L2 T-2 ~> m5 s-2 or J] + + ! only compute residual loss on partial reflection cells, remove numerical noise elsewhere + if (CS%refl_pref_logical(i,j)) then + residual_loss(i,j,a) = residual_loss(i,j,a) + & + ((abs(flux_x(I-1,j)) * CS%residual(i,j) * G%IareaT(i,j)) + & + (abs(flux_x(I,j)) * CS%residual(i,j) * G%IareaT(i,j))) + endif enddo ; enddo enddo ! a-loop @@ -1447,45 +2330,52 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB) call reflect(Fdt_p, Nangle, CS, G, LB) !call teleport(Fdt_p, Nangle, CS, G, LB) - ! Update reflected energy [R Z3 T-2 ~> J m-2] + ! Update reflected energy [H Z2 T-2 ~> m3 s-2 or J m-2] do a=1,Nangle ; do j=jsh,jeh ; do i=ish,ieh - ! if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0) & ! for debugging - ! call MOM_error(FATAL, "propagate_x: OutFlux>Available") - En(i,j,a) = En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a)) + En(i,j,a) = En(i,j,a) + (G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) enddo ; enddo ; enddo + ! existing energy at turning latitude should reflect away + if (CS%turn_critical_lat ) then + call turning_latitude(En, NAngle, freq2, CS, G, LB) + endif + end subroutine propagate_x !> Propagates the internal wave energy in the logical y-direction. -subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB) +subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, residual_loss, freq2) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & intent(inout) :: En !< The energy density integrated over an angular - !! band [R Z3 T-2 ~> J m-2]. + !! band [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(G%isd:G%ied,G%JsdB:G%JedB), & intent(in) :: speed_y !< The magnitude of the group velocity at the !! Cv points [L T-1 ~> m s-1]. - real, dimension(Nangle), intent(in) :: Cgy_av !< The average y-projection in each angular band. + real, dimension(Nangle), intent(in) :: Cgy_av !< The average y-projection in each angular band [nondim] real, dimension(Nangle), intent(in) :: dCgy !< The difference in y-projections between the - !! edges of each angular band. + !! edges of each angular band [nondim] real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(int_tide_CS), intent(in) :: CS !< Internal tide control struct + type(int_tide_CS), intent(in) :: CS !< Internal tide control structure type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. + real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & + intent(inout) :: residual_loss !< internal tide energy loss due + !! to the residual at slopes [H Z2 T-3 ~> m3 s-3 or W m-2]. + real, intent(in) :: freq2 !< The square of internal tides frequency [T-2 ~> s-2]. + ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - EnL, EnR ! South and north face energy densities [R Z3 T-2 ~> J m-2]. + EnL, EnR ! South and north face energy densities [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZJB_(G)) :: & - flux_y ! The internal wave energy flux [R Z3 L2 T-3 ~> J s-1]. + flux_y ! The internal wave energy flux [H Z2 L2 T-3 ~> m5 s-3 or J s-1]. real, dimension(SZI_(G)) :: & - cg_p, cg_m, flux1, flux2 - !real, dimension(SZI_(G),SZJB_(G),Nangle) :: En_m, En_p + cg_p, & ! The y-direction group velocity [L T-1 ~> m s-1] + flux1 ! A 1-d copy of the y-direction internal wave energy flux [H Z2 L2 T-3 ~> m5 s-3 or J s-1]. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle) :: & - Fdt_m, Fdt_p! South and north energy fluxes [R Z3 L2 T-2 ~> J] - character(len=160) :: mesg ! The text of an error message - integer :: i, j, k, ish, ieh, jsh, jeh, a + Fdt_m, Fdt_p! South and north energy fluxes [H Z2 L2 T-2 ~> m5 s-2 or J] + integer :: i, j, ish, ieh, jsh, jeh, a ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh do a=1,Nangle @@ -1495,7 +2385,8 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB) EnL(i,j) = En(i,j,a) ; EnR(i,j) = En(i,j,a) enddo ; enddo else - call PPM_reconstruction_y(En(:,:,a), EnL, EnR, G, LB, simple_2nd=CS%simple_2nd) + call PPM_reconstruction_y(En(:,:,a), EnL, EnR, G, LB, & + simple_2nd=CS%simple_2nd, adv_limiter=CS%itides_adv_limiter) endif do J=jsh-1,jeh @@ -1505,18 +2396,19 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB) enddo call merid_flux_En(cg_p, En(:,:,a), EnL(:,:), EnR(:,:), flux1, & dt, G, US, J, ish, ieh, CS%vol_CFL) - do i=ish,ieh ; flux_y(i,J) = flux1(i); enddo + do i=ish,ieh ; flux_y(i,J) = flux1(i) ; enddo enddo do j=jsh,jeh ; do i=ish,ieh - Fdt_m(i,j,a) = dt*flux_y(i,J-1) ! south face influx [R Z3 L2 T-2 ~> J] - Fdt_p(i,j,a) = -dt*flux_y(i,J) ! north face influx [R Z3 L2 T-2 ~> J] - !if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0) then ! for debugging - ! call MOM_error(WARNING, "propagate_y: OutFlux>Available prior to reflection", .true.) - ! write(mesg,*) "flux_y_south=",flux_y(i,J-1),"flux_y_north=",flux_y(i,J),"En=",En(i,j,a), & - ! "cn_south=", speed_y(i,J-1) * (Cgy_av(a)), "cn_north=", speed_y(i,J) * (Cgy_av(a)) - ! call MOM_error(WARNING, mesg, .true.) - !endif + Fdt_m(i,j,a) = dt*flux_y(i,J-1) ! south face influx [H Z2 L2 T-2 ~> m5 s-2 or J] + Fdt_p(i,j,a) = -dt*flux_y(i,J) ! north face influx [H Z2 L2 T-2 ~> m5 s-2 or J] + + ! only compute residual loss on partial reflection cells, remove numerical noise elsewhere + if (CS%refl_pref_logical(i,j)) then + residual_loss(i,j,a) = residual_loss(i,j,a) + & + ((abs(flux_y(i,J-1)) * CS%residual(i,j) * G%IareaT(i,j)) + & + (abs(flux_y(i,J)) * CS%residual(i,j) * G%IareaT(i,j))) + endif enddo ; enddo enddo ! a-loop @@ -1528,13 +2420,16 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB) call reflect(Fdt_p, Nangle, CS, G, LB) !call teleport(Fdt_p, Nangle, CS, G, LB) - ! Update reflected energy [R Z3 T-2 ~> J m-2] + ! Update reflected energy [H Z2 T-2 ~> m3 s-2 or J m-2] do a=1,Nangle ; do j=jsh,jeh ; do i=ish,ieh - ! if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0) & ! for debugging - ! call MOM_error(FATAL, "propagate_y: OutFlux>Available", .true.) En(i,j,a) = En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a)) enddo ; enddo ; enddo + ! existing energy at turning latitude should reflect away + if (CS%turn_critical_lat ) then + call turning_latitude(En, NAngle, freq2, CS, G, LB) + endif + end subroutine propagate_y !> Evaluates the zonal mass or volume fluxes in a layer. @@ -1542,12 +2437,12 @@ subroutine zonal_flux_En(u, h, hL, hR, uh, dt, G, US, j, ish, ieh, vol_CFL) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. real, dimension(SZIB_(G)), intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G)), intent(in) :: h !< Energy density used to calculate the fluxes - !! [R Z3 T-2 ~> J m-2]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G)), intent(in) :: hL !< Left- Energy densities in the reconstruction - !! [R Z3 T-2 ~> J m-2]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G)), intent(in) :: hR !< Right- Energy densities in the reconstruction - !! [R Z3 T-2 ~> J m-2]. - real, dimension(SZIB_(G)), intent(inout) :: uh !< The zonal energy transport [R Z3 L2 T-3 ~> J s-1]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. + real, dimension(SZIB_(G)), intent(out) :: uh !< The zonal energy transport [H Z2 L2 T-3 ~> m5 s-3 or J s-1]. real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: j !< The j-index to work on. @@ -1557,7 +2452,7 @@ subroutine zonal_flux_En(u, h, hL, hR, uh, dt, G, US, j, ish, ieh, vol_CFL) !! the cell areas when estimating the CFL number. ! Local variables real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim]. - real :: curv_3 ! A measure of the energy density curvature over a grid length [R Z3 T-2 ~> J m-2] + real :: curv_3 ! A measure of the energy density curvature over a grid length [H Z2 T-2 ~> m3 s-2 or J m-2] integer :: i do I=ish-1,ieh @@ -1585,12 +2480,13 @@ subroutine merid_flux_En(v, h, hL, hR, vh, dt, G, US, J, ish, ieh, vol_CFL) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. real, dimension(SZI_(G)), intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h !< Energy density used to calculate the - !! fluxes [R Z3 T-2 ~> J m-2]. + !! fluxes [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: hL !< Left- Energy densities in the - !! reconstruction [R Z3 T-2 ~> J m-2]. + !! reconstruction [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: hR !< Right- Energy densities in the - !! reconstruction [R Z3 T-2 ~> J m-2]. - real, dimension(SZI_(G)), intent(inout) :: vh !< The meridional energy transport [R Z3 L2 T-3 ~> J s-1]. + !! reconstruction [H Z2 T-2 ~> m3 s-2 or J m-2]. + real, dimension(SZI_(G)), intent(out) :: vh !< The meridional energy transport + !! [H Z2 L2 T-3 ~> m5 s-3 or J s-1]. real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: J !< The j-index to work on. @@ -1601,20 +2497,20 @@ subroutine merid_flux_En(v, h, hL, hR, vh, dt, G, US, J, ish, ieh, vol_CFL) !! the CFL number. ! Local variables real :: CFL ! The CFL number based on the local velocity and grid spacing [nondim]. - real :: curv_3 ! A measure of the energy density curvature over a grid length [R Z3 T-2 ~> J m-2] + real :: curv_3 ! A measure of the energy density curvature over a grid length [H Z2 T-2 ~> m3 s-2 or J m-2] integer :: i do i=ish,ieh if (v(i) > 0.0) then if (vol_CFL) then ; CFL = (v(i) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j)) else ; CFL = v(i) * dt * G%IdyT(i,j) ; endif - curv_3 = hL(i,j) + hR(i,j) - 2.0*h(i,j) + curv_3 = (hL(i,j) + hR(i,j)) - 2.0*h(i,j) vh(i) = G%dx_Cv(i,J) * v(i) * ( hR(i,j) + CFL * & (0.5*(hL(i,j) - hR(i,j)) + curv_3*(CFL - 1.5)) ) elseif (v(i) < 0.0) then if (vol_CFL) then ; CFL = (-v(i) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j+1)) else ; CFL = -v(i) * dt * G%IdyT(i,j+1) ; endif - curv_3 = hL(i,j+1) + hR(i,j+1) - 2.0*h(i,j+1) + curv_3 = (hL(i,j+1) + hR(i,j+1)) - 2.0*h(i,j+1) vh(i) = G%dx_Cv(i,J) * v(i) * ( hL(i,j+1) + CFL * & (0.5*(hR(i,j+1)-hL(i,j+1)) + curv_3*(CFL - 1.5)) ) else @@ -1631,9 +2527,10 @@ subroutine reflect(En, NAngle, CS, G, LB) real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: En !< The internal gravity wave energy density as a !! function of space and angular resolution - !! [R Z3 T-2 ~> J m-2]. - type(int_tide_CS), intent(in) :: CS !< Internal tide control struct + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. + type(int_tide_CS), intent(in) :: CS !< Internal tide control structure type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. + ! Local variables real, dimension(G%isd:G%ied,G%jsd:G%jed) :: angle_c ! angle of boundary wrt equator [rad] @@ -1642,17 +2539,18 @@ subroutine reflect(En, NAngle, CS, G, LB) ! values should collocate with angle_c [nondim] logical, dimension(G%isd:G%ied,G%jsd:G%jed) :: ridge ! tags of cells with double reflection - real, dimension(1:Nangle) :: En_reflected ! Energy reflected [R Z3 T-2 ~> J m-2]. + real, dimension(1:Nangle) :: En_reflected ! Energy reflected [H Z2 T-2 ~> m3 s-2 or J m-2]. real :: TwoPi ! 2*pi = 6.2831853... [nondim] real :: Angle_size ! size of beam wedge [rad] - integer :: angle_wall ! angle of coast/ridge/shelf wrt equator [nondim] - integer :: angle_wall0 ! angle of coast/ridge/shelf wrt equator [nondim] - integer :: angle_r ! angle of reflected ray wrt equator [nondim] - integer :: angle_r0 ! angle of reflected ray wrt equator [nondim] - integer :: angle_to_wall ! angle relative to wall [nondim] + real :: I_Angle_size ! inverse of size of beam wedge [rad-1] + integer :: angle_wall ! angle-bin of coast/ridge/shelf wrt equator + integer :: angle_wall0 ! angle-bin of coast/ridge/shelf wrt equator + integer :: angle_r ! angle-bin of reflected ray wrt equator + integer :: angle_r0 ! angle-bin of reflected ray wrt equator + integer :: angle_to_wall ! angle-bin relative to wall integer :: a, a0 ! loop index for angles - integer :: i, j, i_global + integer :: i, j integer :: Nangle_d2 ! Nangle / 2 integer :: isc, iec, jsc, jec ! start and end local indices on PE ! (values exclude halos) @@ -1664,6 +2562,7 @@ subroutine reflect(En, NAngle, CS, G, LB) TwoPi = 8.0*atan(1.0) Angle_size = TwoPi / (real(NAngle)) + I_Angle_size = 1.0 / Angle_size Nangle_d2 = (Nangle / 2) ! init local arrays @@ -1685,24 +2584,24 @@ subroutine reflect(En, NAngle, CS, G, LB) ! i.e., if energy is in a reflecting cell if (angle_c(i,j) /= CS%nullangle) then ! refection angle is given in rad, convert to the discrete angle - angle_wall = nint(angle_c(i,j)/Angle_size) + 1 + angle_wall = nint(angle_c(i,j)*I_Angle_size) + 1 do a=1,NAngle ; if (En(i,j,a) > 0.0) then ! reindex to 0 -> Nangle-1 for trig a0 = a - 1 angle_wall0 = angle_wall - 1 ! compute relative angle from wall and use cyclic properties ! to ensure it is bounded by 0 -> Nangle-1 - angle_to_wall = mod(a0 - angle_wall0 + Nangle, Nangle) + angle_to_wall = mod((a0 - angle_wall0) + Nangle, Nangle) if (ridge(i,j)) then ! if ray is not incident but in ridge cell, use complementary angle - if ((Nangle_d2 .lt. angle_to_wall) .and. (angle_to_wall .lt. Nangle)) then - angle_wall0 = mod(angle_wall0 + Nangle_d2 + Nangle, Nangle) + if ((Nangle_d2 < angle_to_wall) .and. (angle_to_wall < Nangle)) then + angle_wall0 = mod(angle_wall0 + (Nangle_d2 + Nangle), Nangle) endif endif ! do reflection - if ((0 .lt. angle_to_wall) .and. (angle_to_wall .lt. Nangle_d2)) then + if ((0 < angle_to_wall) .and. (angle_to_wall < Nangle_d2)) then angle_r0 = mod(2*angle_wall0 - a0 + Nangle, Nangle) angle_r = angle_r0 + 1 !re-index to 1 -> Nangle if (a /= angle_r) then @@ -1721,13 +2620,152 @@ subroutine reflect(En, NAngle, CS, G, LB) ! Check to make sure no energy gets onto land (only run for debugging) ! do a=1,NAngle ; do j=jsc,jec ; do i=isc,iec ! if (En(i,j,a) > 0.001 .and. G%mask2dT(i,j) == 0) then - ! write (mesg,*) 'En=', En(i,j,a), 'a=', a, 'ig_g=',i+G%idg_offset, 'jg_g=',j+G%jdg_offset + ! write (mesg,*) 'En=', HZ2_T2_to_J_m2*En(i,j,a), 'a=', a, 'ig_g=',i+G%idg_offset, 'jg_g=',j+G%jdg_offset ! call MOM_error(FATAL, "reflect: Energy detected out of bounds: "//trim(mesg), .true.) ! endif ! enddo ; enddo ; enddo end subroutine reflect +subroutine turning_latitude(En, NAngle, freq2, CS, G, LB) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + integer, intent(in) :: NAngle !< The number of wave orientations in the + !! discretized wave energy spectrum. + real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & + intent(inout) :: En !< The internal gravity wave energy density as a + !! function of space and angular resolution + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. + type(int_tide_CS), intent(in) :: CS !< Internal tide control structure + type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. + real, intent(in) :: freq2 !< The square of the internal tide frequency [T-2 ~> s-2] + + ! Local variables + real, dimension(G%isd:G%ied,G%jsd:G%jed) :: angle_c + ! angle of boundary wrt equator [rad] + real, dimension(1:Nangle) :: En_reflected ! Energy reflected [H Z2 T-2 ~> m3 s-2 or J m-2]. + + real :: TwoPi ! 2*pi = 6.2831853... [nondim] + real :: Angle_size ! size of beam wedge [rad] + real :: I_Angle_size ! inverse of size of beam wedge [rad-1] + real :: f2 + + integer :: angle_wall ! angle-bin of coast/ridge/shelf wrt equator + integer :: angle_wall0 ! angle-bin of coast/ridge/shelf wrt equator + integer :: angle_r ! angle-bin of reflected ray wrt equator + integer :: angle_r0 ! angle-bin of reflected ray wrt equator + integer :: angle_to_wall ! angle-bin relative to wall + integer :: a, a0 ! loop index for angles + integer :: i, j + integer :: Nangle_d2 ! Nangle / 2 + integer :: Nangle_d4p1 ! Nangle / 4 + 1 + integer :: Nangle_3d4p1 ! 3*Nangle / 4 + 1 + integer :: isc, iec, jsc, jec ! start and end local indices on PE + ! (values exclude halos) + integer :: ish, ieh, jsh, jeh ! start and end local indices on data domain + ! leaving out outdated halo points (march in) + + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh + + TwoPi = 8.0*atan(1.0) + Angle_size = TwoPi / (real(NAngle)) + I_Angle_size = 1.0 / Angle_size + Nangle_d2 = (Nangle / 2) + Nangle_d4p1 = (Nangle / 4) + 1 + Nangle_3d4p1 = (3 * Nangle / 4) + 1 + + + ! init local arrays + angle_c(:,:) = CS%nullangle + angle_wall = 0 + angle_wall0 =0 + angle_r = 0 + angle_r0 = 0 + angle_to_wall = 0 + + do j=jsh,jeh ; do i=ish,ieh + ! init + angle_wall = 0 + angle_wall0 = 0 + angle_r = 0 + angle_r0 = 0 + angle_to_wall = 0 + + f2 = max(abs(G%Coriolis2Bu(I-1,J)), abs(G%Coriolis2Bu(I,J)), & + abs(G%Coriolis2Bu(I-1,J-1)), abs(G%Coriolis2Bu(I,J-1))) + + if (G%CoriolisBu(I,J) < 0. ) then + if (f2 - freq2 >= 0.) then + angle_c(i,j) = 0.5 * TwoPi + endif + else + if (f2 - freq2 >= 0.) then + angle_c(i,j) = 0. + endif + endif + enddo ; enddo + + En_reflected(:) = 0.0 + + do j=jsh,jeh ; do i=ish,ieh + ! init + angle_wall = 0 + angle_wall0 = 0 + angle_r = 0 + angle_r0 = 0 + angle_to_wall = 0 + + if (angle_c(i,j) /= CS%nullangle) then + ! refection angle is given in rad, convert to the discrete angle + angle_wall = nint(angle_c(i,j)*I_Angle_size) + 1 + do a=1,NAngle ; if (En(i,j,a) > 0.0) then + + if (.not. CS%reflect_critical_lat) then + + ! turn parallel to critical lat + if ((a > Nangle_d4p1) .and. (a < Nangle_3d4p1)) then + angle_r0 = Nangle_d2 + else + angle_r0 = 0 + endif + angle_r = angle_r0 + 1 !re-index to 1 -> Nangle + + if (a /= angle_r) then + En_reflected(angle_r) = En(i,j,a) + En(i,j,a) = 0. + endif + + else + + ! reindex to 0 -> Nangle-1 for trig + a0 = a - 1 + angle_wall0 = angle_wall - 1 + ! compute relative angle from wall and use cyclic properties + ! to ensure it is bounded by 0 -> Nangle-1 + angle_to_wall = mod((a0 - angle_wall0) + Nangle, Nangle) + + ! do reflection + if ((0 < angle_to_wall) .and. (angle_to_wall < Nangle_d2)) then + angle_r0 = mod(2*angle_wall0 - a0 + Nangle, Nangle) + angle_r = angle_r0 + 1 !re-index to 1 -> Nangle + + if (a /= angle_r) then + En_reflected(angle_r) = En(i,j,a) + En(i,j,a) = 0. + endif + endif + endif + endif ; enddo ! a-loop + + do a=1,NAngle + En(i,j,a) = En(i,j,a) + En_reflected(a) + En_reflected(a) = 0.0 ! reset values + enddo ! a-loop + endif + enddo ; enddo ! i- and j-loops + +end subroutine turning_latitude + !> Moves energy across lines of partial reflection to prevent !! reflection of energy that is supposed to get across. subroutine teleport(En, NAngle, CS, G, LB) @@ -1737,8 +2775,8 @@ subroutine teleport(En, NAngle, CS, G, LB) real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: En !< The internal gravity wave energy density as a !! function of space and angular resolution - !! [R Z3 T-2 ~> J m-2]. - type(int_tide_CS), intent(in) :: CS !< Internal tide control struct + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. + type(int_tide_CS), intent(in) :: CS !< Internal tide control structure type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. ! Local variables real, dimension(G%isd:G%ied,G%jsd:G%jed) :: angle_c @@ -1753,23 +2791,18 @@ subroutine teleport(En, NAngle, CS, G, LB) real :: TwoPi ! 2*pi = 6.2831853... [nondim] real :: Angle_size ! size of beam wedge [rad] real, dimension(1:NAngle) :: angle_i ! angle of incident ray wrt equator [rad] - real, dimension(1:NAngle) :: cos_angle, sin_angle - real :: En_tele ! energy to be "teleported" [R Z3 T-2 ~> J m-2] + real, dimension(1:NAngle) :: cos_angle ! Cosine of the beam angle relative to eastward [nondim] + real, dimension(1:NAngle) :: sin_angle ! Sine of the beam angle relative to eastward [nondim] + real :: En_tele ! energy to be "teleported" [H Z2 T-2 ~> m3 s-2 or J m-2] character(len=160) :: mesg ! The text of an error message integer :: i, j, a - !integer :: isd, ied, jsd, jed ! start and end local indices on data domain - ! ! (values include halos) - !integer :: isc, iec, jsc, jec ! start and end local indices on PE - ! ! (values exclude halos) integer :: ish, ieh, jsh, jeh ! start and end local indices on data domain ! leaving out outdated halo points (march in) - integer :: id_g, jd_g ! global (decomp-invar) indices + integer :: id_g, jd_g ! global (decomposition-invariant) indices integer :: jos, ios ! offsets - real :: cos_normal, sin_normal, angle_wall - ! cos/sin of cross-ridge normal, ridge angle + real :: cos_normal, sin_normal ! cos/sin of cross-ridge normal direction [nondim] + real :: angle_wall ! The coastline angle or the complementary angle [radians] - !isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - !isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh TwoPi = 8.0*atan(1.0) @@ -1831,36 +2864,37 @@ end subroutine teleport !> Rotates points in the halos where required to accommodate !! changes in grid orientation, such as at the tripolar fold. -subroutine correct_halo_rotation(En, test, G, NAngle) +subroutine correct_halo_rotation(En, test, G, NAngle, halo) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(:,:,:,:,:), intent(inout) :: En !< The internal gravity wave energy density as a !! function of space, angular orientation, frequency, - !! and vertical mode [R Z3 T-2 ~> J m-2]. + !! and vertical mode [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZJ_(G),2), & intent(in) :: test !< An x-unit vector that has been passed through !! the halo updates, to enable the rotation of the - !! wave energies in the halo region to be corrected. + !! wave energies in the halo region to be corrected [nondim]. integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. + integer, intent(in) :: halo !< The halo size over which to do the calculations ! Local variables - real, dimension(G%isd:G%ied,NAngle) :: En2d + real, dimension(G%isd:G%ied,NAngle) :: En2d ! A zonal row of the internal gravity wave energy density + ! in a frequency band and mode [H Z2 T-2 ~> m3 s-2 or J m-2]. integer, dimension(G%isd:G%ied) :: a_shift integer :: i_first, i_last, a_new - integer :: a, i, j, isd, ied, jsd, jed, m, fr + integer :: a, i, j, ish, ieh, jsh, jeh, m, fr character(len=160) :: mesg ! The text of an error message - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + ish = G%isc-halo ; ieh = G%iec+halo ; jsh = G%jsc-halo ; jeh = G%jec+halo - do j=jsd,jed - i_first = ied+1 ; i_last = isd-1 - do i=isd,ied + do j=jsh,jeh + i_first = ieh+1 ; i_last = ish-1 + do i=ish,ieh a_shift(i) = 0 - if (test(i,j,1) /= 1.0) then + if (test(i,j,2) < 0.5) then if (ii_last) i_last = i - - if (test(i,j,1) == -1.0) then ; a_shift(i) = nAngle/2 - elseif (test(i,j,2) == 1.0) then ; a_shift(i) = -nAngle/4 - elseif (test(i,j,2) == -1.0) then ; a_shift(i) = nAngle/4 + if (test(i,j,2) < -0.5) then ; a_shift(i) = 0.5*nAngle + elseif (test(i,j,1) > 0.5) then ; a_shift(i) = -0.25*nAngle + elseif (test(i,j,1) < -0.5) then ; a_shift(i) = 0.25*nAngle else write(mesg,'("Unrecognized rotation test vector ",2ES9.2," at ",F7.2," E, ",& &F7.2," N; i,j=",2i4)') & @@ -1887,22 +2921,92 @@ subroutine correct_halo_rotation(En, test, G, NAngle) enddo end subroutine correct_halo_rotation + +!> Rotates points in the halos where required to accommodate +!! changes in grid orientation, such as at the tripolar fold. +subroutine correct_halo_rotation_2d(En, test, G, NAngle, halo) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(:,:,:), intent(inout) :: En !< The internal gravity wave energy density as a + !! function of space, angular orientation, frequency, + !! and vertical mode [H Z2 T-2 ~> m3 s-2 or J m-2]. + real, dimension(SZI_(G),SZJ_(G),2), & + intent(in) :: test !< An x-unit vector that has been passed through + !! the halo updates, to enable the rotation of the + !! wave energies in the halo region to be corrected [nondim]. + integer, intent(in) :: NAngle !< The number of wave orientations in the + !! discretized wave energy spectrum. + integer, intent(in) :: halo !< The halo size over which to do the calculations + ! Local variables + real, dimension(G%isd:G%ied,NAngle) :: En2d ! A zonal row of the internal gravity wave energy density + ! in a frequency band and mode [H Z2 T-2 ~> m3 s-2 or J m-2]. + integer, dimension(G%isd:G%ied) :: a_shift + integer :: i_first, i_last, a_new + integer :: a, i, j, ish, ieh, jsh, jeh + integer :: id_g, jd_g + character(len=160) :: mesg ! The text of an error message + ish = G%isc-halo ; ieh = G%iec+halo ; jsh = G%jsc-halo ; jeh = G%jec+halo + + ! top rows + do j=jsh,jeh + !do j= G%jec+1,jeh + i_first = ieh+1 ; i_last = ish-1 ! init + do i=ish,ieh + id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging + + a_shift(i) = 0 + if (test(i,j,2) < 0.5) then + if (ii_last) i_last = i + if (test(i,j,2) < -0.5) then ; a_shift(i) = 0.5*nAngle + elseif (test(i,j,1) > 0.5) then ; a_shift(i) = -0.25*nAngle + elseif (test(i,j,1) < -0.5) then ; a_shift(i) = 0.25*nAngle + else + write(mesg,'("Unrecognized rotation test vector ",2ES9.2," at ",F7.2," E, ",& + &F7.2," N; i,j=",2i4)') & + test(i,j,1), test(i,j,2), G%GeoLonT(i,j), G%GeoLatT(i,j), i, j + call MOM_error(FATAL, mesg) + endif + endif + enddo + + if (i_first <= i_last) then + ! At least one point in this row needs to be rotated. + do a=1,nAngle ; do i=i_first,i_last ; if (a_shift(i) /= 0) then + a_new = a + a_shift(i) + if (a_new < 1) a_new = a_new + nAngle + if (a_new > nAngle) a_new = a_new - nAngle + En2d(i,a_new) = En(i,j,a) + endif ; enddo ; enddo + do a=1,nAngle ; do i=i_first,i_last ; if (a_shift(i) /= 0) then + En(i,j,a) = En2d(i,a) + endif ; enddo ; enddo + endif + enddo +end subroutine correct_halo_rotation_2d + + !> Calculates left/right edge values for PPM reconstruction in x-direction. -subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd) +subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd, adv_limiter) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D). - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_l !< Left edge value of reconstruction (2D). - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_r !< Right edge value of reconstruction (2D). + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_l !< Left edge value of reconstruction (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_r !< Right edge value of reconstruction (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] type(loop_bounds_type), intent(in) :: LB !< A structure with the active loop bounds. logical, intent(in) :: simple_2nd !< If true, use the arithmetic mean !! energy densities as default edge values !! for a simple 2nd order scheme. + integer, intent(in) :: adv_limiter !< The type of limiter used + ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slopes. - real, parameter :: oneSixth = 1./6. - real :: h_ip1, h_im1 - real :: dMx, dMn - logical :: use_CW84 + real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slope in energy density times the cell width + ! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, parameter :: oneSixth = 1./6. ! One sixth [nondim] + real :: h_ip1, h_im1 ! The energy densities at adjacent points [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: dMx, dMn ! The maximum and minimum of values of energy density at adjacent points + ! relative to the center point [H Z2 T-2 ~> m3 s-2 or J m-2] character(len=256) :: mesg ! The text of an error message integer :: i, j, isl, iel, jsl, jel, stencil @@ -1913,13 +3017,13 @@ subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd) if ((isl-stencil < G%isd) .or. (iel+stencil > G%ied)) then write(mesg,'("In MOM_internal_tides, PPM_reconstruction_x called with a ", & - & "x-halo that needs to be increased by ",i2,".")') & + & "x-halo that needs to be increased by ",I0,".")') & stencil + max(G%isd-isl,iel-G%ied) call MOM_error(FATAL,mesg) endif if ((jsl < G%jsd) .or. (jel > G%jed)) then write(mesg,'("In MOM_internal_tides, PPM_reconstruction_x called with a ", & - & "y-halo that needs to be increased by ",i2,".")') & + & "y-halo that needs to be increased by ",I0,".")') & max(G%jsd-jsl,jel-G%jed) call MOM_error(FATAL,mesg) endif @@ -1959,24 +3063,37 @@ subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd) enddo ; enddo endif - call PPM_limit_pos(h_in, h_l, h_r, 0.0, G, isl, iel, jsl, jel) + select case(adv_limiter) + case (LIMITER_ADV_POSITIVE) + call PPM_limit_pos(h_in, h_l, h_r, 0.0, G, isl, iel, jsl, jel) + case (LIMITER_ADV_MINMOD) + call minmod_limiter(h_in, h_l, h_r, G, isl, iel, jsl, jel) + end select + end subroutine PPM_reconstruction_x !> Calculates left/right edge valus for PPM reconstruction in y-direction. -subroutine PPM_reconstruction_y(h_in, h_l, h_r, G, LB, simple_2nd) +subroutine PPM_reconstruction_y(h_in, h_l, h_r, G, LB, simple_2nd, adv_limiter) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D). - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_l !< Left edge value of reconstruction (2D). - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_r !< Right edge value of reconstruction (2D). + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_l !< Left edge value of reconstruction (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_r !< Right edge value of reconstruction (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] type(loop_bounds_type), intent(in) :: LB !< A structure with the active loop bounds. logical, intent(in) :: simple_2nd !< If true, use the arithmetic mean !! energy densities as default edge values !! for a simple 2nd order scheme. + integer, intent(in) :: adv_limiter !< The type of limiter used + ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slopes. - real, parameter :: oneSixth = 1./6. - real :: h_jp1, h_jm1 - real :: dMx, dMn + real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slope in energy density times the cell width + ! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, parameter :: oneSixth = 1./6. ! One sixth [nondim] + real :: h_jp1, h_jm1 ! The energy densities at adjacent points [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: dMx, dMn ! The maximum and minimum of values of energy density at adjacent points + ! relative to the center point [H Z2 T-2 ~> m3 s-2 or J m-2] character(len=256) :: mesg ! The text of an error message integer :: i, j, isl, iel, jsl, jel, stencil @@ -1987,13 +3104,13 @@ subroutine PPM_reconstruction_y(h_in, h_l, h_r, G, LB, simple_2nd) if ((isl < G%isd) .or. (iel > G%ied)) then write(mesg,'("In MOM_internal_tides, PPM_reconstruction_y called with a ", & - & "x-halo that needs to be increased by ",i2,".")') & + & "x-halo that needs to be increased by ",I0,".")') & max(G%isd-isl,iel-G%ied) call MOM_error(FATAL,mesg) endif if ((jsl-stencil < G%jsd) .or. (jel+stencil > G%jed)) then write(mesg,'("In MOM_internal_tides, PPM_reconstruction_y called with a ", & - & "y-halo that needs to be increased by ",i2,".")') & + & "y-halo that needs to be increased by ",I0,".")') & stencil + max(G%jsd-jsl,jel-G%jed) call MOM_error(FATAL,mesg) endif @@ -2031,33 +3148,44 @@ subroutine PPM_reconstruction_y(h_in, h_l, h_r, G, LB, simple_2nd) enddo ; enddo endif - call PPM_limit_pos(h_in, h_l, h_r, 0.0, G, isl, iel, jsl, jel) + select case(adv_limiter) + case (LIMITER_ADV_POSITIVE) + call PPM_limit_pos(h_in, h_l, h_r, 0.0, G, isl, iel, jsl, jel) + case (LIMITER_ADV_MINMOD) + call minmod_limiter(h_in, h_l, h_r, G, isl, iel, jsl, jel) + end select + end subroutine PPM_reconstruction_y !> Limits the left/right edge values of the PPM reconstruction !! to give a reconstruction that is positive-definite. Here this is -!! reinterpreted as giving a constant thickness if the mean thickness is less +!! reinterpreted as giving a constant value if the mean value is less !! than h_min, with a minimum of h_min otherwise. subroutine PPM_limit_pos(h_in, h_L, h_R, h_min, G, iis, iie, jis, jie) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Thickness of layer (2D). - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_L !< Left edge value (2D). - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_R !< Right edge value (2D). - real, intent(in) :: h_min !< The minimum thickness that can be - !! obtained by a concave parabolic fit. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in each sector (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_L !< Left edge value of reconstruction + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_R !< Right edge value of reconstruction + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, intent(in) :: h_min !< The minimum value that can be + !! obtained by a concave parabolic fit + !! [H Z2 T-2 ~> m3 s-2 or J m-2] integer, intent(in) :: iis !< Start i-index for computations integer, intent(in) :: iie !< End i-index for computations integer, intent(in) :: jis !< Start j-index for computations integer, intent(in) :: jie !< End j-index for computations ! Local variables - real :: curv, dh, scale - character(len=256) :: mesg ! The text of an error message - integer :: i,j + real :: curv ! The cell-area normalized curvature [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: dh ! The difference between the edge values [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: scale ! A rescaling factor used to give a minimum cell value of at least h_min [nondim] + integer :: i, j do j=jis,jie ; do i=iis,iie ! This limiter prevents undershooting minima within the domain with ! values less than h_min. - curv = 3.0*(h_L(i,j) + h_R(i,j) - 2.0*h_in(i,j)) + curv = 3.0*((h_L(i,j) + h_R(i,j)) - 2.0*h_in(i,j)) if (curv > 0.0) then ! Only minima are limited. dh = h_R(i,j) - h_L(i,j) if (abs(dh) < curv) then ! The parabola's minimum is within the cell. @@ -2075,72 +3203,218 @@ subroutine PPM_limit_pos(h_in, h_L, h_R, h_min, G, iis, iie, jis, jie) enddo ; enddo end subroutine PPM_limit_pos -! subroutine register_int_tide_restarts(G, param_file, CS, restart_CS) -! type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure -! type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters -! type(int_tide_CS), intent(in) :: CS !< Internal tide control struct -! type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct +!> Limits the left/right edge values using the simple minmod limiter +!! written in a way that avoids branching in favor of intrinsics +subroutine minmod_limiter(h_in, h_L, h_R, G, iis, iie, jis, jie) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in each sector (2D) + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_L !< Left edge value of reconstruction + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_R !< Right edge value of reconstruction + !! [H Z2 T-2 ~> m3 s-2 or J m-2] + integer, intent(in) :: iis !< Start i-index for computations + integer, intent(in) :: iie !< End i-index for computations + integer, intent(in) :: jis !< Start j-index for computations + integer, intent(in) :: jie !< End j-index for computations + ! Local variables + real :: sign_h_L, sign_h_R, sign_h_in ! the signs of the edge and center values + real :: sign_h_L_in, sign_h_R_in ! products of signs, detect crossing the zero line + integer :: i, j + + do j=jis,jie ; do i=iis,iie + + sign_h_L = sign(1.0d0, h_L(i,j)) + sign_h_R = sign(1.0d0, h_R(i,j)) + sign_h_in = sign(1.0d0, h_in(i,j)) + + sign_h_L_in = sign_h_L * sign_h_in + sign_h_R_in = sign_h_R * sign_h_in + + ! if opposite signs, goes to zero else take the min of edge and centers values + h_L(i,j) = (0.5 * (sign_h_L_in + 1.0)) * (sign_h_L * min(abs(h_L(i,j)), abs(h_in(i,j)))) + h_R(i,j) = (0.5 * (sign_h_R_in + 1.0)) * (sign_h_R * min(abs(h_R(i,j)), abs(h_in(i,j)))) + + enddo ; enddo + +end subroutine minmod_limiter + +subroutine register_int_tide_restarts(G, GV, US, param_file, CS, restart_CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type),intent(in):: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(int_tide_CS), pointer :: CS !< Internal tide control structure + type(MOM_restart_CS), pointer :: restart_CS !< MOM restart control structure + + ! This subroutine is used to allocate and register any fields in this module + ! that should be written to or read from the restart file. + logical :: non_Bous ! If true, this run is fully non-Boussinesq + logical :: Boussinesq ! If true, this run is fully Boussinesq + logical :: semi_Boussinesq ! If true, this run is partially non-Boussinesq + integer :: num_freq, num_angle, num_mode + integer :: isd, ied, jsd, jed, i, j, a, fr, m + character(64) :: units + + type(axis_info) :: axes_inttides(2) + real, dimension(:), allocatable :: angles, freqs ! Lables for angles and frequencies [nondim] + real :: HZ2_T2_to_J_m2 ! unit conversion factor for Energy from internal to mks [H Z2 T-2 ~> m3 s-2 or J m-2] + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + HZ2_T2_to_J_m2 = GV%H_to_MKS*(US%Z_to_m**2)*(US%s_to_T**2) + + if (associated(CS)) then + call MOM_error(WARNING, "register_int_tide_restarts called "//& + "with an associated control structure.") + return + endif + + allocate(CS) + + ! write extra axes + call get_param(param_file, "MOM", "INTERNAL_TIDE_ANGLES", num_angle, default=24) + call get_param(param_file, "MOM", "INTERNAL_TIDE_FREQS", num_freq, default=1) + call get_param(param_file, "MOM", "INTERNAL_TIDE_MODES", num_mode, default=1) + + ! define restart units depemding on Boussinesq + call get_param(param_file, "MOM", "BOUSSINESQ", Boussinesq, & + "If true, make the Boussinesq approximation.", default=.true., do_not_log=.true.) + call get_param(param_file, "MOM", "SEMI_BOUSSINESQ", semi_Boussinesq, & + "If true, do non-Boussinesq pressure force calculations and use mass-based "//& + "thicknesses, but use RHO_0 to convert layer thicknesses into certain "//& + "height changes. This only applies if BOUSSINESQ is false.", & + default=.true., do_not_log=.true.) + non_Bous = .not.(Boussinesq .or. semi_Boussinesq) + + units = "J m-2" + if (Boussinesq) units = "m3 s-2" + + allocate (angles(num_angle)) + allocate (freqs(num_freq)) + + do a=1,num_angle ; angles(a) = a ; enddo + do fr=1,num_freq ; freqs(fr) = fr ; enddo + + call set_axis_info(axes_inttides(1), "angle", "", "angle direction", num_angle, angles, "N", 1) + call set_axis_info(axes_inttides(2), "freq", "", "wave frequency", num_freq, freqs, "N", 1) + + ! full energy array + allocate(CS%En(isd:ied, jsd:jed, num_angle, num_freq, num_mode), source=0.0) -! ! This subroutine is not currently in use!! + do m=1,num_mode ; do fr=1,num_freq + call create_group_pass(CS%pass_En, CS%En(:,:,:,fr,m), G%Domain) + enddo ; enddo + + ! restart strategy: support for 5d restart is not yet available so we split into + ! 4d restarts. Vertical modes >= 6 are dissipated locally and do not propagate + ! so we only allow for 5 vertical modes and each has its own variable + + ! allocate restart arrays + allocate(CS%En_restart_mode1(isd:ied, jsd:jed, num_angle, num_freq), source=0.0) + if (num_mode >= 2) allocate(CS%En_restart_mode2(isd:ied, jsd:jed, num_angle, num_freq), source=0.0) + if (num_mode >= 3) allocate(CS%En_restart_mode3(isd:ied, jsd:jed, num_angle, num_freq), source=0.0) + if (num_mode >= 4) allocate(CS%En_restart_mode4(isd:ied, jsd:jed, num_angle, num_freq), source=0.0) + if (num_mode >= 5) allocate(CS%En_restart_mode5(isd:ied, jsd:jed, num_angle, num_freq), source=0.0) + + ! register all 4d restarts and copy into full Energy array when restarting from previous state + call register_restart_field(CS%En_restart_mode1(:,:,:,:), "IW_energy_mode1", .false., restart_CS, & + longname="The internal wave energy density f(i,j,angle,freq) for mode 1", & + units=units, conversion=HZ2_T2_to_J_m2, z_grid='1', t_grid="s", & + extra_axes=axes_inttides) + + do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,1) = CS%En_restart_mode1(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + + if (num_mode >= 2) then + call register_restart_field(CS%En_restart_mode2(:,:,:,:), "IW_energy_mode2", .false., restart_CS, & + longname="The internal wave energy density f(i,j,angle,freq) for mode 2", & + units=units, conversion=HZ2_T2_to_J_m2, z_grid='1', t_grid="s", & + extra_axes=axes_inttides) + + do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,2) = CS%En_restart_mode2(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + + endif -! ! This subroutine is used to allocate and register any fields in this module -! ! that should be written to or read from the restart file. -! logical :: use_int_tides -! type(vardesc) :: vd -! integer :: num_freq, num_angle , num_mode, period_1 -! integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, a -! isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed -! IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + if (num_mode >= 3) then + call register_restart_field(CS%En_restart_mode3(:,:,:,:), "IW_energy_mode3", .false., restart_CS, & + longname="The internal wave energy density f(i,j,angle,freq) for mode 3", & + units=units, conversion=HZ2_T2_to_J_m2, z_grid='1', t_grid="s", & + extra_axes=axes_inttides) -! if (associated(CS)) then -! call MOM_error(WARNING, "register_int_tide_restarts called "//& -! "with an associated control structure.") -! return -! endif + do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,3) = CS%En_restart_mode3(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + + endif + + if (num_mode >= 4) then + call register_restart_field(CS%En_restart_mode4(:,:,:,:), "IW_energy_mode4", .false., restart_CS, & + longname="The internal wave energy density f(i,j,angle,freq) for mode 4", & + units=units, conversion=HZ2_T2_to_J_m2, z_grid='1', t_grid="s", & + extra_axes=axes_inttides) -! use_int_tides = .false. -! call read_param(param_file, "INTERNAL_TIDES", use_int_tides) -! if (.not.use_int_tides) return + do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,4) = CS%En_restart_mode4(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + + endif -! allocate(CS) + if (num_mode >= 5) then + call register_restart_field(CS%En_restart_mode5(:,:,:,:), "IW_energy_mode5", .false., restart_CS, & + longname="The internal wave energy density f(i,j,angle,freq) for mode 5", & + units=units, conversion=HZ2_T2_to_J_m2, z_grid='1', t_grid="s", & + extra_axes=axes_inttides) -! num_angle = 24 -! call read_param(param_file, "INTERNAL_TIDE_ANGLES", num_angle) -! allocate(CS%En_restart(isd:ied, jsd:jed, num_angle), source=0.0) + do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,5) = CS%En_restart_mode5(i,j,a,fr) + enddo ; enddo ; enddo ; enddo -! vd = vardesc("En_restart", & -! "The internal wave energy density as a function of (i,j,angle,frequency,mode)", & -! 'h','1','1',"J m-2") -! call register_restart_field(CS%En_restart, vd, .false., restart_CS) + endif -! end subroutine register_int_tide_restarts +end subroutine register_int_tide_restarts !> This subroutine initializes the internal tides module. subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) type(time_type), target, intent(in) :: Time !< The current model time. - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time !! parameters. type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate !! diagnostic output. - type(int_tide_CS), intent(inout) :: CS !< Internal tide control struct + type(int_tide_CS), pointer :: CS !< Internal tide control structure ! Local variables - real :: Angle_size ! size of wedges, rad - real, allocatable :: angles(:) ! orientations of wedge centers, rad + real :: Angle_size ! size of wedges [rad] + real, allocatable :: angles(:) ! orientations of wedge centers [rad] real, dimension(:,:), allocatable :: h2 ! topographic roughness scale squared [Z2 ~> m2] real :: kappa_itides ! characteristic topographic wave number [L-1 ~> m-1] real, dimension(:,:), allocatable :: ridge_temp ! array for temporary storage of flags - ! of cells with double-reflecting ridges + ! of cells with double-reflecting ridges [nondim] + real, dimension(:,:), allocatable :: tmp_decay ! a temp array to store decay rates [T-1 ~> s-1] + real :: decay_rate ! A constant rate at which internal tide energy is + ! lost to the interior ocean internal wave field [T-1 ~> s-1]. logical :: use_int_tides, use_temperature + logical :: om4_remap_via_sub_cells ! Use the OM4-era ramap_via_sub_cells for calculating the EBT structure + real :: IGW_c1_thresh ! A threshold first mode internal wave speed below which all higher + ! mode speeds are not calculated but simply assigned a speed of 0 [L T-1 ~> m s-1]. real :: kappa_h2_factor ! A roughness scaling factor [nondim] real :: RMS_roughness_frac ! The maximum RMS topographic roughness as a fraction of the ! nominal ocean depth, or a negative value for no limit [nondim] - real :: period_1 ! The period of the gravest modeled mode [T ~> s] + real :: period ! A tidal period read from namelist [T ~> s] + real :: HZ2_T2_to_J_m2 ! unit conversion factor for Energy from internal units + ! to mks [T2 kg H-1 Z-2 s-2 ~> kg m-3 or 1] + real :: HZ2_T3_to_W_m2 ! unit conversion factor for TKE from internal units + ! to mks [T3 kg H-1 Z-2 s-3 ~> kg m-3 or 1] + real :: J_m2_to_HZ2_T2 ! unit conversion factor for Energy from mks to internal + ! units [H Z2 s2 T-2 kg-1 ~> m3 kg-1 or 1] integer :: num_angle, num_freq, num_mode, m, fr - integer :: isd, ied, jsd, jed, a, id_ang, i, j + integer :: isd, ied, jsd, jed, a, id_ang, i, j, nz type(axes_grp) :: axes_ang ! This include declares and sets the variable "version". # include "version_variable.h" @@ -2149,12 +3423,23 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) character(len=40) :: var_name character(len=160) :: var_descript character(len=200) :: filename - character(len=200) :: refl_angle_file, land_mask_file - character(len=200) :: refl_pref_file, refl_dbl_file - character(len=200) :: dy_Cu_file, dx_Cv_file - character(len=200) :: h2_file + character(len=200) :: refl_angle_file + character(len=200) :: refl_pref_file, refl_dbl_file, trans_file + character(len=200) :: h2_file, decay_file + character(len=80) :: rough_var ! Input file variable names + character(len=80) :: tmpstr + + character(len=240), dimension(:), allocatable :: energy_fractions + character(len=240) :: periods isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + nz = GV%ke + + HZ2_T2_to_J_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**2) + HZ2_T3_to_W_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**3) + J_m2_to_HZ2_T2 = GV%kg_m2_to_H*(US%m_to_Z**2)*(US%T_to_s**2) + + CS%initialized = .true. use_int_tides = .false. call read_param(param_file, "INTERNAL_TIDES", use_int_tides) @@ -2164,8 +3449,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) use_temperature = .true. call read_param(param_file, "ENABLE_THERMODYNAMICS", use_temperature) if (.not.use_temperature) call MOM_error(FATAL, & - "register_int_tide_restarts: internal_tides only works with "//& - "ENABLE_THERMODYNAMICS defined.") + "internal_tides_init: internal_tides only works with ENABLE_THERMODYNAMICS defined.") ! Set number of frequencies, angles, and modes to consider num_freq = 1 ; num_angle = 24 ; num_mode = 1 @@ -2175,20 +3459,33 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) if (.not.((num_freq > 0) .and. (num_angle > 0) .and. (num_mode > 0))) return CS%nFreq = num_freq ; CS%nAngle = num_angle ; CS%nMode = num_mode - ! Allocate energy density array - allocate(CS%En(isd:ied, jsd:jed, num_angle, num_freq, num_mode), source=0.0) + allocate(energy_fractions(num_freq)) + allocate(CS%fraction_tidal_input(num_freq,num_mode)) + + call read_param(param_file, "ENERGY_FRACTION_PER_MODE", energy_fractions) + + do fr=1,num_freq ; do m=1,num_mode + CS%fraction_tidal_input(fr,m) = extract_real(energy_fractions(fr), " ,", m, 0.) + enddo ; enddo ! Allocate phase speed array allocate(CS%cp(isd:ied, jsd:jed, num_freq, num_mode), source=0.0) ! Allocate and populate frequency array (each a multiple of first for now) allocate(CS%frequency(num_freq)) - call get_param(param_file, mdl, "FIRST_MODE_PERIOD", period_1, & - "The period of the first mode for internal tides", default=44567., & - units="s", scale=US%s_to_T) + + + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + + ! The periods of the tidal constituents for internal tides raytracing + call read_param(param_file, "TIDAL_PERIODS", periods) do fr=1,num_freq - CS%frequency(fr) = (8.0*atan(1.0) * (real(fr)) / period_1) ! ADDED BDM + period = US%s_to_T*extract_real(periods, " ,", fr, 0.) + if (period == 0.) call MOM_error(FATAL, "MOM_internal_tides: invalid tidal period") + CS%frequency(fr) = 8.0*atan(1.0)/period enddo ! Read all relevant parameters and write them to the model log. @@ -2209,6 +3506,10 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "INTERNAL_TIDE_ANGLES", num_angle, & "The number of angular resolution bands for the internal "//& "tide calculations.", default=24) + call get_param(param_file, mdl, "DT_ITIDES", CS%dt_itides, & + "The timestep for internal tides ray-tracing scheme. "//& + "If set to -1 (default), it uses the same value as DT_THERM.", & + units="s", default=-1., scale=US%s_to_T) if (use_int_tides) then if ((num_freq <= 0) .and. (num_mode <= 0) .and. (num_angle <= 0)) then @@ -2229,24 +3530,58 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "Inconsistent number of frequencies.") if (CS%NAngle /= num_angle) call MOM_error(FATAL, "Internal_tides_init: "//& "Inconsistent number of angles.") - if (CS%NMode /= num_mode) call MOM_error(FATAL, "Internal_tides_init: "//& + if (CS%nMode /= num_mode) call MOM_error(FATAL, "Internal_tides_init: "//& "Inconsistent number of modes.") if (4*(num_angle/4) /= num_angle) call MOM_error(FATAL, & "Internal_tides_init: INTERNAL_TIDE_ANGLES must be a multiple of 4.") CS%diag => diag - call get_param(param_file, mdl, "INTERNAL_TIDE_DECAY_RATE", CS%decay_rate, & + call get_param(param_file, mdl, "INTERNAL_TIDES_UPDATE_KD", CS%update_Kd, & + "If true, internal tides ray tracing changes Kd for dynamics.", & + default=.false.) + call get_param(param_file, mdl, "INTERNAL_TIDES_REFRACTION", CS%apply_refraction, & + "If true, internal tides ray tracing does refraction.", & + default=.true.) + call get_param(param_file, mdl, "INTERNAL_TIDES_PROPAGATION", CS%apply_propagation, & + "If true, internal tides ray tracing does propagate.", & + default=.true.) + call get_param(param_file, mdl, "INTERNAL_TIDES_ONLY_INIT_FORCING", CS%init_forcing_only, & + "If true, internal tides ray tracing only applies forcing at first step (debugging).", & + default=.false.) + call get_param(param_file, mdl, "TURN_CRITICAL_LAT", CS%turn_critical_lat, & + "If true, internal tides rays turn at the critical latitude.", & + default=.true.) + call get_param(param_file, mdl, "REFLECT_CRITICAL_LAT", CS%reflect_critical_lat, & + "If true, internal tides rays reflect at the critical latitude. "//& + "If false, rays turn parallel to the critical latitude", & + default=.true.) + call get_param(param_file, mdl, "INTERNAL_TIDES_FORCE_POS_EN", CS%force_posit_En, & + "If true, force energy to be positive by removing subroundoff negative values.", & + default=.true.) + call get_param(param_file, mdl, "KD_MIN", CS%Kd_min, & + "The minimum diapycnal diffusivity.", & + units="m2 s-1", default=2e-6, scale=GV%m2_s_to_HZ_T) + call get_param(param_file, mdl, "MINTHICK_TKE_TO_KD", CS%min_thick_layer_Kd, & + "The minimum thickness allowed with TKE_to_Kd.", & + units="m", default=1e-6, scale=GV%m_to_H) + call get_param(param_file, mdl, "ITIDES_MIXING_EFFIC", CS%mixing_effic, & + "Mixing efficiency for internal tides raytracing", & + units="nondim", default=0.2) + call get_param(param_file, mdl, "MAX_TKE_TO_KD", CS%max_TKE_to_Kd, & + "Limiter for TKE_to_Kd.", & + units="s2 m-1", default=1e9, scale=US%Z_to_m*US%s_to_T**2) + call get_param(param_file, mdl, "INTERNAL_TIDE_DECAY_RATE", decay_rate, & "The rate at which internal tide energy is lost to the "//& "interior ocean internal wave field.", & units="s-1", default=0.0, scale=US%T_to_s) + call get_param(param_file, mdl, "USE_2D_INTERNAL_TIDE_DECAY_RATE", CS%use_2d_decay_rate, & + "If true, use a spatially varying decay rate for leakage loss in the "// & + "internal tide code.", default=.false.) call get_param(param_file, mdl, "INTERNAL_TIDE_VOLUME_BASED_CFL", CS%vol_CFL, & "If true, use the ratio of the open face lengths to the "//& "tracer cell areas when estimating CFL numbers in the "//& "internal tide code.", default=.false.) - call get_param(param_file, mdl, "INTERNAL_TIDE_CORNER_ADVECT", CS%corner_adv, & - "If true, internal tide ray-tracing advection uses a "//& - "corner-advection scheme rather than PPM.", default=.false.) call get_param(param_file, mdl, "INTERNAL_TIDE_SIMPLE_2ND_PPM", CS%simple_2nd, & "If true, CONTINUITY_PPM uses a simple 2nd order "//& "(arithmetic mean) interpolation of the edge values. "//& @@ -2260,6 +3595,24 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "1st-order upwind advection. This scheme is highly "//& "continuity solver. This scheme is highly "//& "diffusive but may be useful for debugging.", default=.false.) + call get_param(param_file, mdl, "INTERNAL_TIDE_ADV_LIMITER", tmpstr, & + "Choose the limiter scheme used for the internal tide advection scheme, "//& + "available schemes are: \n"//& + "\t POSITIVE - a positive definite scheme similar to the continuity solver. \n"//& + "\t MINMOD - the simplest limiter.", default=LIMITER_ADV_MINMOD_STRING) + + tmpstr = uppercase(tmpstr) + select case (tmpstr) + case (LIMITER_ADV_POSITIVE_STRING) + CS%itides_adv_limiter = LIMITER_ADV_POSITIVE + case (LIMITER_ADV_MINMOD_STRING) + CS%itides_adv_limiter = LIMITER_ADV_MINMOD + case default + call MOM_mesg('internal_tide_init: Advection limiter ="'//trim(tmpstr)//'"', 0) + call MOM_error(FATAL, "internal_tide_init: Unrecognized setting "// & + "#define INTERNAL_TIDE_ADV_LIMITER "//trim(tmpstr)//" found in input file.") + end select + call get_param(param_file, mdl, "INTERNAL_TIDE_BACKGROUND_DRAG", CS%apply_background_drag, & "If true, the internal tide ray-tracing advection uses a background drag "//& "term as a sink.", default=.false.) @@ -2269,18 +3622,46 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "INTERNAL_TIDE_WAVE_DRAG", CS%apply_wave_drag, & "If true, apply scattering due to small-scale roughness as a sink.", & default=.false.) + call get_param(param_file, mdl, "INTERNAL_TIDE_RESIDUAL_DRAG", CS%apply_residual_drag, & + "If true, apply drag due to critical slopes", & + default=.false.) call get_param(param_file, mdl, "INTERNAL_TIDE_DRAG_MIN_DEPTH", CS%drag_min_depth, & "The minimum total ocean thickness that will be used in the denominator "//& "of the quadratic drag terms for internal tides.", & - units="m", default=1.0, scale=US%m_to_Z, do_not_log=.not.CS%apply_bottom_drag) - CS%drag_min_depth = MAX(CS%drag_min_depth, GV%H_subroundoff * GV%H_to_Z) + units="m", default=1.0, scale=GV%m_to_H, do_not_log=.not.CS%apply_bottom_drag) + CS%drag_min_depth = MAX(CS%drag_min_depth, GV%H_subroundoff) call get_param(param_file, mdl, "INTERNAL_TIDE_FROUDE_DRAG", CS%apply_Froude_drag, & "If true, apply wave breaking as a sink.", & default=.false.) + call get_param(param_file, mdl, "EN_CHECK_TOLERANCE", CS%En_check_tol, & + "An energy density tolerance for flagging points with small negative "//& + "internal tide energy.", & + units="J m-2", default=1.0, scale=J_m2_to_HZ2_T2, & + do_not_log=.not.CS%apply_Froude_drag) + call get_param(param_file, mdl, "EN_UNDERFLOW", CS%En_underflow, & + "A small energy density below which Energy is set to zero.", & + units="J m-2", default=1.0e-100, scale=J_m2_to_HZ2_T2) + call get_param(param_file, mdl, "EN_RESTART_POWER", CS%En_restart_power, & + "A power factor to save larger values x 2**(power) in restart files.", & + units="nondim", default=0) call get_param(param_file, mdl, "CDRAG", CS%cdrag, & "CDRAG is the drag coefficient relating the magnitude of "//& - "the velocity field to the bottom stress.", units="nondim", & - default=0.003) + "the velocity field to the bottom stress.", & + units="nondim", default=0.003) + call get_param(param_file, mdl, "INTERNAL_WAVE_CG1_THRESH", IGW_c1_thresh, & + "A minimal value of the first mode internal wave speed below which all higher "//& + "mode speeds are not calculated but are simply reported as 0. This must be "//& + "non-negative for the wave_speeds routine to be used.", & + units="m s-1", default=0.01, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + do_not_log=.true., default=.true.) + call get_param(param_file, mdl, "INTWAVE_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for calculating EBT structure. "//& + "See REMAPPING_USE_OM4_SUBCELLS for details. "//& + "We recommend setting this option to false.", default=om4_remap_via_sub_cells) + call get_param(param_file, mdl, "UNIFORM_TEST_CG", CS%uniform_test_cg, & + "If positive, a uniform group velocity of internal tide for test case", & + default=-1., units="m s-1", scale=US%m_s_to_L_T) call get_param(param_file, mdl, "INTERNAL_TIDE_ENERGIZED_ANGLE", CS%energized_angle, & "If positive, only one angular band of the internal tides "//& "gets all of the energy. (This is for debugging.)", default=-1) @@ -2299,6 +3680,17 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "KAPPA_H2_FACTOR", kappa_h2_factor, & "A scaling factor for the roughness amplitude with "//& "INT_TIDE_DISSIPATION.", units="nondim", default=1.0) + call get_param(param_file, mdl, "GAMMA_OSBORN", CS%gamma_osborn, & + "The mixing efficiency for internan tides from Osborn 1980 ", & + units="nondim", default=0.2) + call get_param(param_file, mdl, "INT_TIDE_DECAY_SCALE", CS%Int_tide_decay_scale, & + "The decay scale away from the bottom for tidal TKE with "//& + "the new coding when INT_TIDE_DISSIPATION is used.", & + units="m", default=500.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "INT_TIDE_DECAY_SCALE_SLOPES", CS%Int_tide_decay_scale_slope, & + "The slope decay scale away from the bottom for tidal TKE with "//& + "the new coding when INT_TIDE_DISSIPATION is used.", & + units="m", default=100.0, scale=GV%m_to_H) ! Allocate various arrays needed for loss rates allocate(h2(isd:ied,jsd:jed), source=0.0) @@ -2307,10 +3699,55 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%TKE_quad_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode), source=0.0) allocate(CS%TKE_itidal_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode), source=0.0) allocate(CS%TKE_Froude_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode), source=0.0) + allocate(CS%TKE_residual_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode), source=0.0) + allocate(CS%TKE_slope_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode), source=0.0) allocate(CS%tot_leak_loss(isd:ied,jsd:jed), source=0.0) allocate(CS%tot_quad_loss(isd:ied,jsd:jed), source=0.0) allocate(CS%tot_itidal_loss(isd:ied,jsd:jed), source=0.0) allocate(CS%tot_Froude_loss(isd:ied,jsd:jed), source=0.0) + allocate(CS%tot_residual_loss(isd:ied,jsd:jed), source=0.0) + allocate(CS%u_struct_bot(isd:ied,jsd:jed,num_mode), source=0.0) + allocate(CS%u_struct_max(isd:ied,jsd:jed,num_mode), source=0.0) + allocate(CS%int_w2(isd:ied,jsd:jed,num_mode), source=0.0) + allocate(CS%int_U2(isd:ied,jsd:jed,num_mode), source=0.0) + allocate(CS%int_N2w2(isd:ied,jsd:jed,num_mode), source=0.0) + allocate(CS%w_struct(isd:ied,jsd:jed,1:nz+1,num_mode), source=0.0) + allocate(CS%u_struct(isd:ied,jsd:jed,1:nz,num_mode), source=0.0) + allocate(CS%error_mode(num_freq,num_mode), source=0.0) + allocate(CS%En_ini_glo(num_freq,num_mode), source=0.0) + allocate(CS%En_end_glo(num_freq,num_mode), source=0.0) + allocate(CS%TKE_leak_loss_glo_dt(num_freq,num_mode), source=0.0) + allocate(CS%TKE_quad_loss_glo_dt(num_freq,num_mode), source=0.0) + allocate(CS%TKE_Froude_loss_glo_dt(num_freq,num_mode), source=0.0) + allocate(CS%TKE_itidal_loss_glo_dt(num_freq,num_mode), source=0.0) + allocate(CS%TKE_residual_loss_glo_dt(num_freq,num_mode), source=0.0) + allocate(CS%TKE_input_glo_dt(num_freq,num_mode), source=0.0) + allocate(CS%decay_rate_2d(isd:ied,jsd:jed,num_freq,num_mode), source=0.0) + allocate(tmp_decay(isd:ied,jsd:jed), source=0.0) + + if (CS%use_2d_decay_rate) then + call get_param(param_file, mdl, "ITIDES_DECAY_FILE", decay_file, & + "The path to the file containing the decay rates "//& + "for internal tides with USE_2D_INTERNAL_TIDE_DECAY_RATE.", & + fail_if_missing=.true.) + do m=1,num_mode ; do fr=1,num_freq + ! read 2d field for each harmonic + filename = trim(CS%inputdir) // trim(decay_file) + write(var_name, '("decay_rate_freq",i1,"_mode",i1)') fr, m + call MOM_read_data(filename, var_name, tmp_decay, G%domain, scale=US%T_to_s) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + CS%decay_rate_2d(i,j,fr,m) = tmp_decay(i,j) + enddo ; enddo + enddo ; enddo + else + do m=1,num_mode ; do fr=1,num_freq ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + CS%decay_rate_2d(i,j,fr,m) = decay_rate + enddo ; enddo ; enddo ; enddo + endif + + do m=1,num_mode + call pass_var(CS%decay_rate_2d(:,:,:,m), G%domain) + enddo ! Compute the fixed part of the bottom drag loss from baroclinic modes call get_param(param_file, mdl, "H2_FILE", h2_file, & @@ -2319,21 +3756,25 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) fail_if_missing=.true.) filename = trim(CS%inputdir) // trim(h2_file) call log_param(param_file, mdl, "INPUTDIR/H2_FILE", filename) + call get_param(param_file, mdl, "ROUGHNESS_VARNAME", rough_var, & + "The name in the input file of the squared sub-grid-scale "//& + "topographic roughness amplitude variable.", default="h2") call get_param(param_file, mdl, "INTERNAL_TIDE_ROUGHNESS_FRAC", RMS_roughness_frac, & "The maximum RMS topographic roughness as a fraction of the nominal ocean depth, "//& "or a negative value for no limit.", units="nondim", default=0.1) - call MOM_read_data(filename, 'h2', h2, G%domain, scale=US%m_to_Z**2) + call MOM_read_data(filename, rough_var, h2, G%domain, scale=US%m_to_Z**2) do j=G%jsc,G%jec ; do i=G%isc,G%iec ! Restrict RMS topographic roughness to a fraction (10 percent by default) of the column depth. if (RMS_roughness_frac >= 0.0) then - h2(i,j) = max(min((RMS_roughness_frac*(G%bathyT(i,j)+G%Z_ref))**2, h2(i,j)), 0.0) + h2(i,j) = max(min((RMS_roughness_frac * max(G%meanSL(i,j) + G%bathyT(i,j), 0.0))**2, h2(i,j)), 0.0) else h2(i,j) = max(h2(i,j), 0.0) endif - ! Compute the fixed part; units are [R L-2 Z3 ~> kg m-2] here - ! will be multiplied by N and the squared near-bottom velocity to get into [R Z3 T-3 ~> W m-2] - CS%TKE_itidal_loss_fixed(i,j) = 0.5*kappa_h2_factor*GV%Rho0 * US%L_to_Z*kappa_itides * h2(i,j) + ! Compute the fixed part; units are [R Z4 H-1 L-2 ~> kg m-2 or m] here + ! will be multiplied by N and the squared near-bottom velocity (and by the + ! near-bottom density in non-Boussinesq mode) to get into [H Z2 T-3 ~> m3 s-3 or W m-2] + CS%TKE_itidal_loss_fixed(i,j) = 0.5*kappa_h2_factor* GV%H_to_RZ * US%L_to_Z*kappa_itides * h2(i,j) enddo ; enddo deallocate(h2) @@ -2352,11 +3793,11 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) if (trim(refl_angle_file) /= '' ) call MOM_error(FATAL, & "REFL_ANGLE_FILE: "//trim(filename)//" not found") endif - ! replace NANs with null value + ! replace NaNs with null value do j=G%jsc,G%jec ; do i=G%isc,G%iec if (is_NaN(CS%refl_angle(i,j))) CS%refl_angle(i,j) = CS%nullangle enddo ; enddo - call pass_var(CS%refl_angle,G%domain) + call pass_var(CS%refl_angle, G%domain) ! Read in prescribed partial reflection coefficients from file call get_param(param_file, mdl, "REFL_PREF_FILE", refl_pref_file, & @@ -2372,19 +3813,17 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "REFL_PREF_FILE: "//trim(filename)//" not found") endif !CS%refl_pref = CS%refl_pref*1 ! adjust partial reflection if desired - call pass_var(CS%refl_pref,G%domain) + call pass_var(CS%refl_pref, G%domain) ! Tag reflection cells with partial reflection (done here for speed) allocate(CS%refl_pref_logical(isd:ied,jsd:jed), source=.false.) - do j=jsd,jed - do i=isd,ied - ! flag cells with partial reflection - if (CS%refl_angle(i,j) /= CS%nullangle .and. & - CS%refl_pref(i,j) < 1.0 .and. CS%refl_pref(i,j) > 0.0) then - CS%refl_pref_logical(i,j) = .true. - endif - enddo - enddo + do j=jsd,jed ; do i=isd,ied + ! flag cells with partial reflection + if ((CS%refl_angle(i,j) /= CS%nullangle) .and. & + (CS%refl_pref(i,j) < 1.0) .and. (CS%refl_pref(i,j) > 0.0)) then + CS%refl_pref_logical(i,j) = .true. + endif + enddo ; enddo ! Read in double-reflective (ridge) tags from file call get_param(param_file, mdl, "REFL_DBL_FILE", refl_dbl_file, & @@ -2399,61 +3838,79 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) if (trim(refl_dbl_file) /= '' ) call MOM_error(FATAL, & "REFL_DBL_FILE: "//trim(filename)//" not found") endif - call pass_var(ridge_temp,G%domain) + call pass_var(ridge_temp, G%domain) allocate(CS%refl_dbl(isd:ied,jsd:jed), source=.false.) - do i=isd,ied ; do j=jsd,jed - if (ridge_temp(i,j) == 1) then; CS%refl_dbl(i,j) = .true. - else ; CS%refl_dbl(i,j) = .false. ; endif + do j=jsd,jed ; do i=isd,ied + CS%refl_dbl(i,j) = (ridge_temp(i,j) == 1) enddo ; enddo - ! Read in prescribed land mask from file (if overwriting -BDM). - ! This should be done in MOM_initialize_topography subroutine - ! defined in MOM_fixed_initialization.F90 (BDM) - !call get_param(param_file, mdl, "LAND_MASK_FILE", land_mask_file, & - ! "The path to the file containing the land mask.", & - ! fail_if_missing=.false.) - !filename = trim(CS%inputdir) // trim(land_mask_file) - !call log_param(param_file, mdl, "INPUTDIR/LAND_MASK_FILE", filename) - !G%mask2dCu(:,:) = 1 ; G%mask2dCv(:,:) = 1 ; G%mask2dT(:,:) = 1 - !call MOM_read_data(filename, 'land_mask', G%mask2dCu, G%domain) - !call MOM_read_data(filename, 'land_mask', G%mask2dCv, G%domain) - !call MOM_read_data(filename, 'land_mask', G%mask2dT, G%domain) - !call pass_vector(G%mask2dCu, G%mask2dCv, G%domain, To_All+Scalar_Pair, CGRID_NE) - !call pass_var(G%mask2dT,G%domain) - - ! Read in prescribed partial east face blockages from file (if overwriting -BDM) - !call get_param(param_file, mdl, "dy_Cu_FILE", dy_Cu_file, & - ! "The path to the file containing the east face blockages.", & - ! fail_if_missing=.false.) - !filename = trim(CS%inputdir) // trim(dy_Cu_file) - !call log_param(param_file, mdl, "INPUTDIR/dy_Cu_FILE", filename) - !G%dy_Cu(:,:) = 0.0 - !call MOM_read_data(filename, 'dy_Cu', G%dy_Cu, G%domain, scale=US%m_to_L) - - ! Read in prescribed partial north face blockages from file (if overwriting -BDM) - !call get_param(param_file, mdl, "dx_Cv_FILE", dx_Cv_file, & - ! "The path to the file containing the north face blockages.", & - ! fail_if_missing=.false.) - !filename = trim(CS%inputdir) // trim(dx_Cv_file) - !call log_param(param_file, mdl, "INPUTDIR/dx_Cv_FILE", filename) - !G%dx_Cv(:,:) = 0.0 - !call MOM_read_data(filename, 'dx_Cv', G%dx_Cv, G%domain, scale=US%m_to_L) - !call pass_vector(G%dy_Cu, G%dx_Cv, G%domain, To_All+Scalar_Pair, CGRID_NE) + ! Read in the transmission coefficient and infer the residual + call get_param(param_file, mdl, "TRANS_FILE", trans_file, & + "The path to the file containing the transmission coefficent for internal tides.", & + fail_if_missing=.false., default='') + filename = trim(CS%inputdir) // trim(trans_file) + allocate(CS%trans(isd:ied,jsd:jed), source=0.0) + if (file_exists(filename, G%domain)) then + call log_param(param_file, mdl, "INPUTDIR/TRANS_FILE", filename) + call MOM_read_data(filename, 'trans', CS%trans, G%domain) + else + if (trim(trans_file) /= '' ) call MOM_error(FATAL, & + "TRANS_FILE: "//trim(filename)//" not found") + endif + + call pass_var(CS%trans, G%domain) + + ! residual + allocate(CS%residual(isd:ied,jsd:jed), source=0.0) + if (CS%apply_residual_drag) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (CS%refl_pref_logical(i,j)) then + CS%residual(i,j) = 1. - (CS%refl_pref(i,j) - CS%trans(i,j)) + endif + enddo ; enddo + call pass_var(CS%residual, G%domain) + else + ! report residual of transmission/reflection onto reflection + ! this ensure energy budget is conserved + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (CS%refl_pref_logical(i,j)) then + CS%refl_pref(i,j) = 1. - CS%trans(i,j) + endif + enddo ; enddo + call pass_var(CS%refl_pref, G%domain) + endif + + CS%id_cg1 = register_diag_field('ocean_model', 'cn1', diag%axesT1, & + Time, 'First baroclinic mode (eigen) speed', 'm s-1', conversion=US%L_T_to_m_s) + allocate(CS%id_cn(CS%nMode), source=-1) + do m=1,CS%nMode + write(var_name, '("cn_mode",i1)') m + write(var_descript, '("Baroclinic (eigen) speed of mode ",i1)') m + CS%id_cn(m) = register_diag_field('ocean_model',var_name, diag%axesT1, & + Time, var_descript, 'm s-1', conversion=US%L_T_to_m_s) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + enddo ! Register maps of reflection parameters CS%id_refl_ang = register_diag_field('ocean_model', 'refl_angle', diag%axesT1, & Time, 'Local angle of coastline/ridge/shelf with respect to equator', 'rad') CS%id_refl_pref = register_diag_field('ocean_model', 'refl_pref', diag%axesT1, & Time, 'Partial reflection coefficients', '') + CS%id_trans = register_diag_field('ocean_model', 'trans', diag%axesT1, & + Time, 'Partial transmission coefficients', '') + CS%id_residual = register_diag_field('ocean_model', 'residual', diag%axesT1, & + Time, 'Residual of reflection and transmission coefficients', '') CS%id_dx_Cv = register_diag_field('ocean_model', 'dx_Cv', diag%axesT1, & Time, 'North face unblocked width', 'm', conversion=US%L_to_m) CS%id_dy_Cu = register_diag_field('ocean_model', 'dy_Cu', diag%axesT1, & Time, 'East face unblocked width', 'm', conversion=US%L_to_m) CS%id_land_mask = register_diag_field('ocean_model', 'land_mask', diag%axesT1, & - Time, 'Land mask', 'logical') ! used if overriding (BDM) - ! Output reflection parameters as diags here (not needed every timestep) + Time, 'Land mask', 'nondim') + ! Output reflection parameters as diagnostics here (not needed every timestep) if (CS%id_refl_ang > 0) call post_data(CS%id_refl_ang, CS%refl_angle, CS%diag) if (CS%id_refl_pref > 0) call post_data(CS%id_refl_pref, CS%refl_pref, CS%diag) + if (CS%id_trans > 0) call post_data(CS%id_trans, CS%trans, CS%diag) + if (CS%id_residual > 0) call post_data(CS%id_residual, CS%residual, CS%diag) if (CS%id_dx_Cv > 0) call post_data(CS%id_dx_Cv, G%dx_Cv, CS%diag) if (CS%id_dy_Cu > 0) call post_data(CS%id_dy_Cu, G%dy_Cu, CS%diag) if (CS%id_land_mask > 0) call post_data(CS%id_land_mask, G%mask2dT, CS%diag) @@ -2461,115 +3918,205 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! Register 2-D energy density (summed over angles, freq, modes) CS%id_tot_En = register_diag_field('ocean_model', 'ITide_tot_En', diag%axesT1, & Time, 'Internal tide total energy density', & - 'J m-2', conversion=US%RZ3_T3_to_W_m2*US%T_to_s) - ! Register 2-D drag scale used for quadratic bottom drag - CS%id_itide_drag = register_diag_field('ocean_model', 'ITide_drag', diag%axesT1, & - Time, 'Interior and bottom drag internal tide decay timescale', 's-1', conversion=US%s_to_T) - !Register 2-D energy input into internal tides - CS%id_TKE_itidal_input = register_diag_field('ocean_model', 'TKE_itidal_input', diag%axesT1, & - Time, 'Conversion from barotropic to baroclinic tide, '//& - 'a fraction of which goes into rays', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + 'J m-2', conversion=HZ2_T2_to_J_m2) + + allocate(CS%id_itide_drag(CS%nFreq, CS%nMode), source=-1) + allocate(CS%id_TKE_itidal_input(CS%nFreq), source=-1) + do fr=1,CS%nFreq + ! Register 2-D energy input into internal tides for each frequency + write(var_name, '("TKE_itidal_input_freq",i1)') fr + write(var_descript, '("a fraction of which goes into rays in frequency ",i1)') fr + + CS%id_TKE_itidal_input(fr) = register_diag_field('ocean_model', var_name, diag%axesT1, & + Time, 'Conversion from barotropic to baroclinic tide, '//& + var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) + enddo ! Register 2-D energy losses (summed over angles, freq, modes) CS%id_tot_leak_loss = register_diag_field('ocean_model', 'ITide_tot_leak_loss', diag%axesT1, & Time, 'Internal tide energy loss to background drag', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + 'W m-2', conversion=HZ2_T3_to_W_m2) CS%id_tot_quad_loss = register_diag_field('ocean_model', 'ITide_tot_quad_loss', diag%axesT1, & Time, 'Internal tide energy loss to bottom drag', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + 'W m-2', conversion=HZ2_T3_to_W_m2) CS%id_tot_itidal_loss = register_diag_field('ocean_model', 'ITide_tot_itidal_loss', diag%axesT1, & Time, 'Internal tide energy loss to wave drag', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + 'W m-2', conversion=HZ2_T3_to_W_m2) CS%id_tot_Froude_loss = register_diag_field('ocean_model', 'ITide_tot_Froude_loss', diag%axesT1, & Time, 'Internal tide energy loss to wave breaking', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + 'W m-2', conversion=HZ2_T3_to_W_m2) + CS%id_tot_residual_loss = register_diag_field('ocean_model', 'ITide_tot_residual_loss', diag%axesT1, & + Time, 'Internal tide energy loss to residual on slopes', & + 'W m-2', conversion=HZ2_T3_to_W_m2) CS%id_tot_allprocesses_loss = register_diag_field('ocean_model', 'ITide_tot_allprocesses_loss', diag%axesT1, & Time, 'Internal tide energy loss summed over all processes', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + 'W m-2', conversion=HZ2_T3_to_W_m2) allocate(CS%id_En_mode(CS%nFreq,CS%nMode), source=-1) allocate(CS%id_En_ang_mode(CS%nFreq,CS%nMode), source=-1) allocate(CS%id_itidal_loss_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_leak_loss_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_quad_loss_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_Froude_loss_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_residual_loss_mode(CS%nFreq,CS%nMode), source=-1) allocate(CS%id_allprocesses_loss_mode(CS%nFreq,CS%nMode), source=-1) allocate(CS%id_itidal_loss_ang_mode(CS%nFreq,CS%nMode), source=-1) allocate(CS%id_Ub_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_Ustruct_mode(CS%nMode), source=-1) + allocate(CS%id_Wstruct_mode(CS%nMode), source=-1) + allocate(CS%id_int_w2_mode(CS%nMode), source=-1) + allocate(CS%id_int_U2_mode(CS%nMode), source=-1) + allocate(CS%id_int_N2w2_mode(CS%nMode), source=-1) allocate(CS%id_cp_mode(CS%nFreq,CS%nMode), source=-1) allocate(angles(CS%NAngle), source=0.0) Angle_size = (8.0*atan(1.0)) / (real(num_angle)) do a=1,num_angle ; angles(a) = (real(a) - 1) * Angle_size ; enddo - id_ang = diag_axis_init("angle", angles, "Radians", "N", "Angular Orienation of Fluxes") + id_ang = diag_axis_init("angle", angles, "Radians", "N", "Angular Orientation of Fluxes") call define_axes_group(diag, (/ diag%axesT1%handles(1), diag%axesT1%handles(2), id_ang /), & axes_ang, is_h_point=.true.) do fr=1,CS%nFreq ; write(freq_name(fr), '("freq",i1)') fr ; enddo do m=1,CS%nMode ; do fr=1,CS%nFreq - ! Register 2-D energy density (summed over angles) for each freq and mode + ! Register 2-D energy density (summed over angles) for each frequency and mode write(var_name, '("Itide_En_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy density in frequency ",i1," mode ",i1)') fr, m CS%id_En_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'J m-2', conversion=US%RZ3_T3_to_W_m2*US%T_to_s) + diag%axesT1, Time, var_descript, 'J m-2', conversion=HZ2_T2_to_J_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) - ! Register 3-D (i,j,a) energy density for each freq and mode + ! Register 3-D (i,j,a) energy density for each frequency and mode write(var_name, '("Itide_En_ang_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide angular energy density in frequency ",i1," mode ",i1)') fr, m CS%id_En_ang_mode(fr,m) = register_diag_field('ocean_model', var_name, & - axes_ang, Time, var_descript, 'J m-2 band-1', conversion=US%RZ3_T3_to_W_m2*US%T_to_s) + axes_ang, Time, var_descript, 'J m-2 band-1', conversion=HZ2_T2_to_J_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) - ! Register 2-D energy loss (summed over angles) for each freq and mode + ! Register 2-D energy loss (summed over angles) for each frequency and mode ! wave-drag only write(var_name, '("Itide_wavedrag_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy loss due to wave-drag from frequency ",i1," mode ",i1)') fr, m CS%id_itidal_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + diag%axesT1, Time, var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + ! Leakage loss + write(var_name, '("Itide_leak_loss_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Internal tide energy loss due to leakage from frequency ",i1," mode ",i1)') fr, m + CS%id_leak_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + ! Quad loss + write(var_name, '("Itide_quad_loss_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Internal tide energy quad loss from frequency ",i1," mode ",i1)') fr, m + CS%id_quad_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + ! Froude loss + write(var_name, '("Itide_froude_loss_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Internal tide energy Froude loss from frequency ",i1," mode ",i1)') fr, m + CS%id_froude_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + ! residual losses + write(var_name, '("Itide_residual_loss_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Internal tide energy residual loss from frequency ",i1," mode ",i1)') fr, m + CS%id_residual_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! all loss processes write(var_name, '("Itide_allprocesses_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy loss due to all processes from frequency ",i1," mode ",i1)') fr, m CS%id_allprocesses_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & - diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + diag%axesT1, Time, var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) - ! Register 3-D (i,j,a) energy loss for each freq and mode + ! Register 3-D (i,j,a) energy loss for each frequency and mode ! wave-drag only write(var_name, '("Itide_wavedrag_loss_ang_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy loss due to wave-drag from frequency ",i1," mode ",i1)') fr, m CS%id_itidal_loss_ang_mode(fr,m) = register_diag_field('ocean_model', var_name, & - axes_ang, Time, var_descript, 'W m-2 band-1', conversion=US%RZ3_T3_to_W_m2) + axes_ang, Time, var_descript, 'W m-2 band-1', conversion=HZ2_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) - ! Register 2-D period-averaged near-bottom horizonal velocity for each freq and mode + ! Register 2-D period-averaged near-bottom horizontal velocity for each frequency and mode write(var_name, '("Itide_Ub_freq",i1,"_mode",i1)') fr, m - write(var_descript, '("Near-bottom horizonal velocity for frequency ",i1," mode ",i1)') fr, m + write(var_descript, '("Near-bottom horizontal velocity for frequency ",i1," mode ",i1)') fr, m CS%id_Ub_mode(fr,m) = register_diag_field('ocean_model', var_name, & diag%axesT1, Time, var_descript, 'm s-1', conversion=US%L_T_to_m_s) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) - ! Register 2-D horizonal phase velocity for each freq and mode + ! Register 2-D horizontal phase velocity for each frequency and mode write(var_name, '("Itide_cp_freq",i1,"_mode",i1)') fr, m - write(var_descript, '("Horizonal phase velocity for frequency ",i1," mode ",i1)') fr, m + write(var_descript, '("Horizontal phase velocity for frequency ",i1," mode ",i1)') fr, m CS%id_cp_mode(fr,m) = register_diag_field('ocean_model', var_name, & diag%axesT1, Time, var_descript, 'm s-1', conversion=US%L_T_to_m_s) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + ! Register 2-D drag scale used for quadratic bottom drag for each frequency and mode + write(var_name, '("ITide_drag_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Interior and bottom drag int tide decay timescale in frequency ",i1, " mode ",i1)') fr, m + + CS%id_itide_drag(fr,m) = register_diag_field('ocean_model', var_name, diag%axesT1, Time, & + 's-1', conversion=US%s_to_T) enddo ; enddo - ! Initialize wave_structure (not sure if this should be here - BDM) - call wave_structure_init(Time, G, GV, param_file, diag, CS%wave_struct) + + do m=1,CS%nMode + + ! Register 3-D internal tide horizontal velocity profile for each mode + write(var_name, '("Itide_Ustruct","_mode",i1)') m + write(var_descript, '("horizontal velocity profile for mode ",i1)') m + CS%id_Ustruct_mode(m) = register_diag_field('ocean_model', var_name, & + diag%axesTl, Time, var_descript, 'm-1', conversion=US%m_to_L) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + + ! Register 3-D internal tide vertical velocity profile for each mode + write(var_name, '("Itide_Wstruct","_mode",i1)') m + write(var_descript, '("vertical velocity profile for mode ",i1)') m + CS%id_Wstruct_mode(m) = register_diag_field('ocean_model', var_name, & + diag%axesTi, Time, var_descript, 'nondim') + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + + write(var_name, '("Itide_int_w2","_mode",i1)') m + write(var_descript, '("integral of w2 for mode ",i1)') m + CS%id_int_w2_mode(m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'm', conversion=GV%H_to_m) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + + write(var_name, '("Itide_int_U2","_mode",i1)') m + write(var_descript, '("integral of U2 for mode ",i1)') m + CS%id_int_U2_mode(m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'm-1', conversion=US%m_to_Z*GV%H_to_Z) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + + write(var_name, '("Itide_int_N2w2","_mode",i1)') m + write(var_descript, '("integral of N2w2 for mode ",i1)') m + CS%id_int_N2w2_mode(m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'm s-2', conversion=GV%H_to_m*US%s_to_T**2) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + + enddo + + ! Initialize the module that calculates the wave speeds. + 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 !> This subroutine deallocates the memory associated with the internal tides control structure subroutine internal_tides_end(CS) - type(int_tide_CS), intent(inout) :: CS !< Internal tide control struct + type(int_tide_CS), intent(inout) :: CS !< Internal tide control structure if (allocated(CS%En)) deallocate(CS%En) if (allocated(CS%frequency)) deallocate(CS%frequency) if (allocated(CS%id_En_mode)) deallocate(CS%id_En_mode) if (allocated(CS%id_Ub_mode)) deallocate(CS%id_Ub_mode) if (allocated(CS%id_cp_mode)) deallocate(CS%id_cp_mode) + if (allocated(CS%id_Ustruct_mode)) deallocate(CS%id_Ustruct_mode) + if (allocated(CS%id_Wstruct_mode)) deallocate(CS%id_Wstruct_mode) + if (allocated(CS%id_int_w2_mode)) deallocate(CS%id_int_w2_mode) + if (allocated(CS%id_int_U2_mode)) deallocate(CS%id_int_U2_mode) + if (allocated(CS%id_int_N2w2_mode)) deallocate(CS%id_int_N2w2_mode) + end subroutine internal_tides_end end module MOM_internal_tides diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index da8e936642..1f1b453877 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -1,16 +1,19 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Variable mixing coefficients module MOM_lateral_mixing_coeffs -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_debugging, only : hchksum, uvchksum use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, post_data use MOM_diag_mediator, only : diag_ctrl, time_type, query_averaging_enabled use MOM_domains, only : create_group_pass, do_group_pass use MOM_domains, only : group_pass_type, pass_var, pass_vector +use MOM_EOS, only : calculate_density_derivs, EOS_domain use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_interface_heights, only : find_eta +use MOM_interface_heights, only : find_eta, thickness_to_dz use MOM_isopycnal_slopes, only : calc_isoneutral_slopes use MOM_grid, only : ocean_grid_type use MOM_unit_scaling, only : unit_scale_type @@ -18,6 +21,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, OBC_NONE +use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S +use MOM_MEKE_types, only : MEKE_type implicit none ; private @@ -44,10 +49,20 @@ module MOM_lateral_mixing_coeffs !! speed and calculate the resolution function !! independently at each point. logical :: use_stored_slopes !< If true, stores isopycnal slopes in this structure. - logical :: Resoln_use_ebt !< If true, uses the equivalent barotropic wave speed instead - !! of first baroclinic wave for calculating the resolution fn. + logical :: Resoln_use_ebt !< If true, use the equivalent barotropic wave speed instead of the + !! first baroclinic wave speed for calculating the resolution function. logical :: khth_use_ebt_struct !< If true, uses the equivalent barotropic structure !! 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. @@ -57,13 +72,26 @@ module MOM_lateral_mixing_coeffs !! This parameter is set depending on other parameters. logical :: calculate_depth_fns !< If true, calculate all the depth factors. !! This parameter is set depending on other parameters. - logical :: calculate_Eady_growth_rate !< If true, calculate all the Eady growth rate. + logical :: calculate_Eady_growth_rate !< If true, calculate all the Eady growth rates. !! This parameter is set depending on other parameters. + logical :: use_stanley_iso !< If true, use Stanley parameterization in MOM_isopycnal_slopes logical :: use_simpler_Eady_growth_rate !< If true, use a simpler method to calculate the !! Eady growth rate that avoids division by layer thickness. !! This parameter is set depending on other parameters. + logical :: full_depth_Eady_growth_rate !< If true, calculate the Eady growth rate based on an + !! average that includes contributions from sea-level changes + !! in its denominator, rather than just the nominal depth of + !! the bathymetry. This only applies when using the model + !! interface heights as a proxy for isopycnal slopes. + logical :: OBC_friendly !< If true, use only interior data for thickness weighting and + !! to calculate stratification and other fields at open boundary + !! condition faces. + logical :: res_fn_OBC_bug !< If false, use only interior data for calculating the resolution + !! functions at open boundary condition faces and vertices. real :: cropping_distance !< Distance from surface or bottom to filter out outcropped or !! incropped interfaces for the Eady growth rate calc [Z ~> m] + real :: h_min_N2 !< The minimum vertical distance to use in the denominator of the + !! buoyancy frequency used in the slope calculation [H ~> m or kg m-2] real, allocatable :: SN_u(:,:) !< S*N at u-points [T-1 ~> s-1] real, allocatable :: SN_v(:,:) !< S*N at v-points [T-1 ~> s-1] @@ -100,43 +128,49 @@ module MOM_lateral_mixing_coeffs !! spacing squared at v [L2 T-2 ~> m2 s-2]. real, allocatable :: Rd_dx_h(:,:) !< Deformation radius over grid spacing [nondim] - real, allocatable :: slope_x(:,:,:) !< Zonal isopycnal slope [nondim] - real, allocatable :: slope_y(:,:,:) !< Meridional isopycnal slope [nondim] - real, allocatable :: ebt_struct(:,:,:) !< Vertical structure function to scale diffusivities with [nondim] - - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: & - Laplac3_const_u !< Laplacian metric-dependent constants [L3 ~> m3] - - real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: & - Laplac3_const_v !< Laplacian metric-dependent constants [L3 ~> m3] - - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: & - KH_u_QG !< QG Leith GM coefficient at u-points [L2 T-1 ~> m2 s-1] - - real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: & - KH_v_QG !< QG Leith GM coefficient at v-points [L2 T-1 ~> m2 s-1] + 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(:,:,:) !< 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 :: interpolated_sqg_struct !< If true, interpolate properties to velocity points and then + !! interpolate the buoyancy frequencies and layer thicknesses + !! back to tracer points when calculating the SQG vertical + !! structure. + logical :: BS_use_sqg_struct !< If true, use sqg_stuct for backscatter vertical structure. + + real, allocatable :: Laplac3_const_u(:,:) !< Laplacian metric-dependent constants at u-points [L3 ~> m3] + real, allocatable :: Laplac3_const_v(:,:) !< Laplacian metric-dependent constants at u-points [L3 ~> m3] + real, allocatable :: KH_u_QG(:,:,:) !< QG Leith GM coefficient at u-points [L2 T-1 ~> m2 s-1] + real, allocatable :: KH_v_QG(:,:,:) !< QG Leith GM coefficient at v-points [L2 T-1 ~> m2 s-1] ! Parameters logical :: use_Visbeck !< Use Visbeck formulation for thickness diffusivity integer :: VarMix_Ktop !< Top layer to start downward integrals - real :: Visbeck_L_scale !< Fixed length scale in Visbeck formula + real :: Visbeck_L_scale !< Fixed length scale in Visbeck formula [L ~> m], or if negative a scaling + !! factor [nondim] relating this length scale squared to the cell area real :: Eady_GR_D_scale !< Depth over which to average SN [Z ~> m] - real :: Res_coef_khth !< A non-dimensional number that determines the function + real :: Res_coef_khth !< A coefficient [nondim] that determines the function !! of resolution, used for thickness and tracer mixing, as: !! F = 1 / (1 + (Res_coef_khth*Ld/dx)^Res_fn_power) - real :: Res_coef_visc !< A non-dimensional number that determines the function + real :: Res_coef_visc !< A coefficient [nondim] that determines the function !! of resolution, used for lateral viscosity, as: !! F = 1 / (1 + (Res_coef_visc*Ld/dx)^Res_fn_power) real :: depth_scaled_khth_h0 !< The depth above which KHTH is linearly scaled away [Z ~> m] real :: depth_scaled_khth_exp !< The exponent used in the depth dependent scaling function for KHTH [nondim] - real :: kappa_smooth !< A diffusivity for smoothing T/S in vanished layers [Z2 T-1 ~> m2 s-1] + real :: kappa_smooth !< A diffusivity for smoothing T/S in vanished layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] integer :: Res_fn_power_khth !< The power of dx/Ld in the KhTh resolution function. Any !! positive integer power may be used, but even powers !! and especially 2 are coded to be more efficient. integer :: Res_fn_power_visc !< The power of dx/Ld in the Kh resolution function. Any !! positive integer power may be used, but even powers !! and especially 2 are coded to be more efficient. - real :: Visbeck_S_max !< Upper bound on slope used in Eady growth rate [nondim]. + real :: Visbeck_S_max !< Upper bound on slope used in Eady growth rate [Z L-1 ~> nondim]. ! Leith parameters logical :: use_QG_Leith_GM !< If true, uses the QG Leith viscosity as the GM coefficient @@ -149,6 +183,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. !>@} @@ -159,20 +195,21 @@ module MOM_lateral_mixing_coeffs end type VarMix_CS public VarMix_init, VarMix_end, calc_slope_functions, calc_resoln_function -public calc_QG_Leith_viscosity, calc_depth_function +public calc_QG_slopes, calc_QG_Leith_viscosity, calc_depth_function, calc_sqg_struct contains !> Calculates the non-dimensional depth functions. subroutine calc_depth_function(G, CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(VarMix_CS), intent(inout) :: CS !< Variable mixing control struct + type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure ! Local variables integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq integer :: i, j - real :: H0 ! local variable for reference depth - real :: expo ! exponent used in the depth dependent scaling + real :: H0 ! The depth above which KHTH is linearly scaled away [Z ~> m] + real :: h1, h2 ! Temporary total thicknesses [Z ~> m] + real :: expo ! exponent used in the depth dependent scaling [nondim] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -185,35 +222,44 @@ subroutine calc_depth_function(G, CS) if (.not. allocated(CS%Depth_fn_v)) call MOM_error(FATAL, & "calc_depth_function: %Depth_fn_v is not associated with Depth_scaled_KhTh.") + ! For efficiency, the reciprocal of H0 should be used instead. H0 = CS%depth_scaled_khth_h0 expo = CS%depth_scaled_khth_exp !$OMP do do j=js,je ; do I=is-1,Ieq - CS%Depth_fn_u(I,j) = (MIN(1.0, (0.5*(G%bathyT(i,j) + G%bathyT(i+1,j)) + G%Z_ref)/H0))**expo + h1 = max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) + h2 = max(G%meanSL(i+1,j) + G%bathyT(i+1,j), 0.0) + CS%Depth_fn_u(I,j) = (MIN(1.0, (0.5 * (h1 + h2)) / H0))**expo enddo ; enddo !$OMP do do J=js-1,Jeq ; do i=is,ie - CS%Depth_fn_v(i,J) = (MIN(1.0, (0.5*(G%bathyT(i,j) + G%bathyT(i,j+1)) + G%Z_ref)/H0))**expo + h1 = max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) + h2 = max(G%meanSL(i,j+1) + G%bathyT(i,j+1), 0.0) + CS%Depth_fn_v(i,J) = (MIN(1.0, (0.5 * (h1 + h2)) / H0))**expo enddo ; enddo 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, OBC, 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 struct + type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure + type(MEKE_type), intent(in) :: MEKE !< MEKE struct + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure + real, intent(in) :: dt !< Time increment [T ~> s] ! Local variables ! Depending on the power-function being used, dimensional rescaling may be limited, so some ! of the following variables have units that depend on that power. - real :: cg1_q ! The gravity wave speed interpolated to q points [L T-1 ~> m s-1] or [m s-1]. - real :: cg1_u ! The gravity wave speed interpolated to u points [L T-1 ~> m s-1] or [m s-1]. - real :: cg1_v ! The gravity wave speed interpolated to v points [L T-1 ~> m s-1] or [m s-1]. + real :: cg1_q(SZIB_(G),SZJB_(G)) ! The gravity wave speed interpolated to q points [L T-1 ~> m s-1] or [m s-1]. + real :: cg1_u(SZIB_(G),SZJ_(G)) ! The gravity wave speed interpolated to u points [L T-1 ~> m s-1] or [m s-1]. + real :: cg1_v(SZI_(G),SZJB_(G)) ! The gravity wave speed interpolated to v points [L T-1 ~> m s-1] or [m s-1]. real :: dx_term ! A term in the denominator [L2 T-2 ~> m2 s-2] or [m2 s-2] + logical :: apply_u_OBC, apply_v_OBC ! If true, OBCs will be used to set the wave speed at some points on this PE. integer :: power_2 integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: i, j, k @@ -226,7 +272,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) 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 @@ -246,6 +293,51 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) call create_group_pass(CS%pass_cg1, CS%cg1, G%Domain) call do_group_pass(CS%pass_cg1, G%Domain) endif + if (CS%BS_use_sqg_struct .or. CS%khth_use_sqg_struct .or. CS%khtr_use_sqg_struct & + .or. CS%kdgl90_use_sqg_struct .or. CS%id_sqg_struct>0) then + call calc_sqg_struct(h, tv, G, GV, US, CS, dt, MEKE, OBC) + call pass_var(CS%sqg_struct, G%Domain) + endif + + if (CS%BS_EBT_power>0.) then + do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%BS_struct(i,j,k) = CS%ebt_struct(i,j,k)**CS%BS_EBT_power + enddo ; enddo ; enddo + elseif (CS%BS_use_sqg_struct) then + do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%BS_struct(i,j,k) = CS%sqg_struct(i,j,k) + enddo ; enddo ; enddo + endif + + if (CS%khth_use_ebt_struct) then + do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%khth_struct(i,j,k) = CS%ebt_struct(i,j,k) + enddo ; enddo ; enddo + elseif (CS%khth_use_sqg_struct) then + do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%khth_struct(i,j,k) = CS%sqg_struct(i,j,k) + enddo ; enddo ; enddo + endif + + if (CS%khtr_use_ebt_struct) then + do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%khtr_struct(i,j,k) = CS%ebt_struct(i,j,k) + enddo ; enddo ; enddo + elseif (CS%khtr_use_sqg_struct) then + do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%khtr_struct(i,j,k) = CS%sqg_struct(i,j,k) + enddo ; enddo ; enddo + endif + + if (CS%kdgl90_use_ebt_struct) then + do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%kdgl90_struct(i,j,k) = CS%ebt_struct(i,j,k) + enddo ; enddo ; enddo + elseif (CS%kdgl90_use_sqg_struct) then + do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%kdgl90_struct(i,j,k) = CS%sqg_struct(i,j,k) + enddo ; enddo ; enddo + endif ! Calculate and store the ratio between deformation radius and grid-spacing ! at h-points [nondim]. @@ -289,13 +381,40 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) if (.not. allocated(CS%beta_dx2_v)) call MOM_error(FATAL, & "calc_resoln_function: %beta_dx2_v is not associated with Resoln_scaled_Kh.") + apply_u_OBC = .false. ; apply_v_OBC = .false. + if (associated(OBC) .and. (.not.CS%res_fn_OBC_bug)) then + apply_u_OBC = OBC%u_OBCs_on_PE + apply_v_OBC = OBC%v_OBCs_on_PE + endif + + !$OMP parallel default(shared) private(dx_term,power_2) + + if (apply_u_OBC .or. apply_v_OBC) then + !$OMP do + do J=js-1,Jeq ; do I=is-1,Ieq + if ((OBC%segnum_u(I,j) /= 0) .or. (OBC%segnum_u(I,j+1) /= 0) .or. & + (OBC%segnum_v(i,J) /= 0) .or. (OBC%segnum_u(i+1,J) /= 0)) then + ! This is an OBC node, so use the fact that G%mask2dT is zero behind OBCs. The nondimensional + ! constant 1e-20 in the denominator makes this a de facto implementation of Adcroft's reciprocal + ! rule with a value that works for either 64-bit or 32-bit real numbers. + cg1_q(I,J) = ((G%mask2dT(i,j) * CS%cg1(i,j) + G%mask2dT(i+1,j+1) * CS%cg1(i+1,j+1)) + & + (G%mask2dT(i+1,j) * CS%cg1(i+1,j) + G%mask2dT(i,j+1) * CS%cg1(i,j+1))) / & + ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + (G%mask2dT(i+1,j) + G%mask2dT(i,j+1)) + 1.0e-20) + else + cg1_q(I,J) = 0.25 * ((CS%cg1(i,j) + CS%cg1(i+1,j+1)) + (CS%cg1(i+1,j) + CS%cg1(i,j+1))) + endif + enddo ; enddo + else + !$OMP do + do J=js-1,Jeq ; do I=is-1,Ieq + cg1_q(I,J) = 0.25 * ((CS%cg1(i,j) + CS%cg1(i+1,j+1)) + (CS%cg1(i+1,j) + CS%cg1(i,j+1))) + enddo ; enddo + endif + ! Do this calculation on the extent used in MOM_hor_visc.F90, and ! MOM_tracer.F90 so that no halo update is needed. - -!$OMP parallel default(none) shared(is,ie,js,je,Ieq,Jeq,CS,US) & -!$OMP private(dx_term,cg1_q,power_2,cg1_u,cg1_v) if (CS%Res_fn_power_visc >= 100) then -!$OMP do + !$OMP do do j=js-1,je+1 ; do i=is-1,ie+1 dx_term = CS%f2_dx2_h(i,j) + CS%cg1(i,j)*CS%beta_dx2_h(i,j) if ((CS%Res_coef_visc * CS%cg1(i,j))**2 > dx_term) then @@ -304,146 +423,335 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) CS%Res_fn_h(i,j) = 1.0 endif enddo ; enddo -!$OMP do + !$OMP do do J=js-1,Jeq ; do I=is-1,Ieq - cg1_q = 0.25 * ((CS%cg1(i,j) + CS%cg1(i+1,j+1)) + (CS%cg1(i+1,j) + CS%cg1(i,j+1))) - dx_term = CS%f2_dx2_q(I,J) + cg1_q * CS%beta_dx2_q(I,J) - if ((CS%Res_coef_visc * cg1_q)**2 > dx_term) then + dx_term = CS%f2_dx2_q(I,J) + cg1_q(I,J) * CS%beta_dx2_q(I,J) + if ((CS%Res_coef_visc * cg1_q(I,J))**2 > dx_term) then CS%Res_fn_q(I,J) = 0.0 else CS%Res_fn_q(I,J) = 1.0 endif enddo ; enddo elseif (CS%Res_fn_power_visc == 2) then -!$OMP do + !$OMP do do j=js-1,je+1 ; do i=is-1,ie+1 dx_term = CS%f2_dx2_h(i,j) + CS%cg1(i,j)*CS%beta_dx2_h(i,j) CS%Res_fn_h(i,j) = dx_term / (dx_term + (CS%Res_coef_visc * CS%cg1(i,j))**2) enddo ; enddo -!$OMP do + !$OMP do do J=js-1,Jeq ; do I=is-1,Ieq - cg1_q = 0.25 * ((CS%cg1(i,j) + CS%cg1(i+1,j+1)) + (CS%cg1(i+1,j) + CS%cg1(i,j+1))) - dx_term = CS%f2_dx2_q(I,J) + cg1_q * CS%beta_dx2_q(I,J) - CS%Res_fn_q(I,J) = dx_term / (dx_term + (CS%Res_coef_visc * cg1_q)**2) + dx_term = CS%f2_dx2_q(I,J) + cg1_q(I,J) * CS%beta_dx2_q(I,J) + CS%Res_fn_q(I,J) = dx_term / (dx_term + (CS%Res_coef_visc * cg1_q(I,J))**2) enddo ; enddo elseif (mod(CS%Res_fn_power_visc, 2) == 0) then power_2 = CS%Res_fn_power_visc / 2 -!$OMP do + !$OMP do do j=js-1,je+1 ; do i=is-1,ie+1 dx_term = (US%L_T_to_m_s**2*(CS%f2_dx2_h(i,j) + CS%cg1(i,j)*CS%beta_dx2_h(i,j)))**power_2 CS%Res_fn_h(i,j) = dx_term / & (dx_term + (CS%Res_coef_visc * US%L_T_to_m_s*CS%cg1(i,j))**CS%Res_fn_power_visc) enddo ; enddo -!$OMP do + !$OMP do do J=js-1,Jeq ; do I=is-1,Ieq - cg1_q = 0.25 * ((CS%cg1(i,j) + CS%cg1(i+1,j+1)) + (CS%cg1(i+1,j) + CS%cg1(i,j+1))) - dx_term = (US%L_T_to_m_s**2*(CS%f2_dx2_q(I,J) + cg1_q * CS%beta_dx2_q(I,J)))**power_2 + dx_term = (US%L_T_to_m_s**2*(CS%f2_dx2_q(I,J) + cg1_q(I,J) * CS%beta_dx2_q(I,J)))**power_2 CS%Res_fn_q(I,J) = dx_term / & - (dx_term + (CS%Res_coef_visc * US%L_T_to_m_s*cg1_q)**CS%Res_fn_power_visc) + (dx_term + (CS%Res_coef_visc * US%L_T_to_m_s*cg1_q(I,J))**CS%Res_fn_power_visc) enddo ; enddo else -!$OMP do + !$OMP do do j=js-1,je+1 ; do i=is-1,ie+1 dx_term = (US%L_T_to_m_s*sqrt(CS%f2_dx2_h(i,j) + & CS%cg1(i,j)*CS%beta_dx2_h(i,j)))**CS%Res_fn_power_visc CS%Res_fn_h(i,j) = dx_term / & (dx_term + (CS%Res_coef_visc * US%L_T_to_m_s*CS%cg1(i,j))**CS%Res_fn_power_visc) enddo ; enddo -!$OMP do + !$OMP do do J=js-1,Jeq ; do I=is-1,Ieq - cg1_q = 0.25 * ((CS%cg1(i,j) + CS%cg1(i+1,j+1)) + (CS%cg1(i+1,j) + CS%cg1(i,j+1))) dx_term = (US%L_T_to_m_s*sqrt(CS%f2_dx2_q(I,J) + & - cg1_q * CS%beta_dx2_q(I,J)))**CS%Res_fn_power_visc + cg1_q(I,J) * CS%beta_dx2_q(I,J)))**CS%Res_fn_power_visc CS%Res_fn_q(I,J) = dx_term / & - (dx_term + (CS%Res_coef_visc * US%L_T_to_m_s*cg1_q)**CS%Res_fn_power_visc) + (dx_term + (CS%Res_coef_visc * US%L_T_to_m_s*cg1_q(I,J))**CS%Res_fn_power_visc) enddo ; enddo endif if (CS%interpolate_Res_fn) then - do j=js,je ; do I=is-1,Ieq - CS%Res_fn_u(I,j) = 0.5*(CS%Res_fn_h(i,j) + CS%Res_fn_h(i+1,j)) - enddo ; enddo - do J=js-1,Jeq ; do i=is,ie - CS%Res_fn_v(i,J) = 0.5*(CS%Res_fn_h(i,j) + CS%Res_fn_h(i,j+1)) - enddo ; enddo + if (apply_u_OBC) then + do j=js,je ; do I=is-1,Ieq + CS%Res_fn_u(I,j) = 0.5*(CS%Res_fn_h(i,j) + CS%Res_fn_h(i+1,j)) + if (OBC%segnum_u(I,j) > 0) CS%Res_fn_u(I,j) = CS%Res_fn_h(i,j) ! Eastern OBC + if (OBC%segnum_u(I,j) < 0) CS%Res_fn_u(I,j) = CS%Res_fn_h(i+1,j) ! Western OBC + enddo ; enddo + else + do j=js,je ; do I=is-1,Ieq + CS%Res_fn_u(I,j) = 0.5*(CS%Res_fn_h(i,j) + CS%Res_fn_h(i+1,j)) + enddo ; enddo + endif + + if (apply_v_OBC) then + do J=js-1,Jeq ; do i=is,ie + CS%Res_fn_v(i,J) = 0.5*(CS%Res_fn_h(i,j) + CS%Res_fn_h(i,j+1)) + if (OBC%segnum_v(i,J) > 0) CS%Res_fn_v(i,J) = CS%Res_fn_h(i,j) ! Northern OBC + if (OBC%segnum_v(i,J) < 0) CS%Res_fn_v(i,J) = CS%Res_fn_h(i,j+1) ! Southern OBC + enddo ; enddo + else + do J=js-1,Jeq ; do i=is,ie + CS%Res_fn_v(i,J) = 0.5*(CS%Res_fn_h(i,j) + CS%Res_fn_h(i,j+1)) + enddo ; enddo + endif + else ! .not.CS%interpolate_Res_fn + if (apply_u_OBC) then + !$OMP do + do j=js,je ; do I=is-1,Ieq + cg1_u(I,j) = 0.5 * (CS%cg1(i,j) + CS%cg1(i+1,j)) + if (OBC%segnum_u(I,j) > 0) cg1_u(I,j) = CS%cg1(i,j) ! Eastern OBC + if (OBC%segnum_u(I,j) < 0) cg1_u(I,j) = CS%cg1(i+1,j) ! Western OBC + enddo ; enddo + else + !$OMP do + do j=js,je ; do I=is-1,Ieq + cg1_u(I,j) = 0.5 * (CS%cg1(i,j) + CS%cg1(i+1,j)) + enddo ; enddo + endif + + if (apply_v_OBC) then + !$OMP do + do J=js-1,Jeq ; do i=is,ie + cg1_v(i,J) = 0.5 * (CS%cg1(i,j) + CS%cg1(i,j+1)) + if (OBC%segnum_v(i,J) > 0) cg1_v(i,J) = CS%cg1(i,j) ! Northern OBC + if (OBC%segnum_v(i,J) < 0) cg1_v(i,J) = CS%cg1(i,j+1) ! Southern OBC + enddo ; enddo + else + !$OMP do + do J=js-1,Jeq ; do i=is,ie + cg1_v(i,J) = 0.5 * (CS%cg1(i,j) + CS%cg1(i,j+1)) + enddo ; enddo + endif + if (CS%Res_fn_power_khth >= 100) then -!$OMP do + !$OMP do do j=js,je ; do I=is-1,Ieq - cg1_u = 0.5 * (CS%cg1(i,j) + CS%cg1(i+1,j)) - dx_term = CS%f2_dx2_u(I,j) + cg1_u * CS%beta_dx2_u(I,j) - if ((CS%Res_coef_khth * cg1_u)**2 > dx_term) then + dx_term = CS%f2_dx2_u(I,j) + cg1_u(I,j) * CS%beta_dx2_u(I,j) + if ((CS%Res_coef_khth * cg1_u(I,j))**2 > dx_term) then CS%Res_fn_u(I,j) = 0.0 else CS%Res_fn_u(I,j) = 1.0 endif enddo ; enddo -!$OMP do + !$OMP do do J=js-1,Jeq ; do i=is,ie - cg1_v = 0.5 * (CS%cg1(i,j) + CS%cg1(i,j+1)) - dx_term = CS%f2_dx2_v(i,J) + cg1_v * CS%beta_dx2_v(i,J) - if ((CS%Res_coef_khth * cg1_v)**2 > dx_term) then + dx_term = CS%f2_dx2_v(i,J) + cg1_v(i,J) * CS%beta_dx2_v(i,J) + if ((CS%Res_coef_khth * cg1_v(i,J))**2 > dx_term) then CS%Res_fn_v(i,J) = 0.0 else CS%Res_fn_v(i,J) = 1.0 endif enddo ; enddo elseif (CS%Res_fn_power_khth == 2) then -!$OMP do + !$OMP do do j=js,je ; do I=is-1,Ieq - cg1_u = 0.5 * (CS%cg1(i,j) + CS%cg1(i+1,j)) - dx_term = CS%f2_dx2_u(I,j) + cg1_u * CS%beta_dx2_u(I,j) - CS%Res_fn_u(I,j) = dx_term / (dx_term + (CS%Res_coef_khth * cg1_u)**2) + dx_term = CS%f2_dx2_u(I,j) + cg1_u(I,j) * CS%beta_dx2_u(I,j) + CS%Res_fn_u(I,j) = dx_term / (dx_term + (CS%Res_coef_khth * cg1_u(I,j))**2) enddo ; enddo -!$OMP do + !$OMP do do J=js-1,Jeq ; do i=is,ie - cg1_v = 0.5 * (CS%cg1(i,j) + CS%cg1(i,j+1)) - dx_term = CS%f2_dx2_v(i,J) + cg1_v * CS%beta_dx2_v(i,J) - CS%Res_fn_v(i,J) = dx_term / (dx_term + (CS%Res_coef_khth * cg1_v)**2) + dx_term = CS%f2_dx2_v(i,J) + cg1_v(i,J) * CS%beta_dx2_v(i,J) + CS%Res_fn_v(i,J) = dx_term / (dx_term + (CS%Res_coef_khth * cg1_v(i,J))**2) enddo ; enddo elseif (mod(CS%Res_fn_power_khth, 2) == 0) then power_2 = CS%Res_fn_power_khth / 2 -!$OMP do + !$OMP do do j=js,je ; do I=is-1,Ieq - cg1_u = 0.5 * (CS%cg1(i,j) + CS%cg1(i+1,j)) - dx_term = (US%L_T_to_m_s**2 * (CS%f2_dx2_u(I,j) + cg1_u * CS%beta_dx2_u(I,j)))**power_2 + dx_term = (US%L_T_to_m_s**2 * (CS%f2_dx2_u(I,j) + cg1_u(I,j) * CS%beta_dx2_u(I,j)))**power_2 CS%Res_fn_u(I,j) = dx_term / & - (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_u)**CS%Res_fn_power_khth) + (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_u(I,j))**CS%Res_fn_power_khth) enddo ; enddo -!$OMP do + !$OMP do do J=js-1,Jeq ; do i=is,ie - cg1_v = 0.5 * (CS%cg1(i,j) + CS%cg1(i,j+1)) - dx_term = (US%L_T_to_m_s**2 * (CS%f2_dx2_v(i,J) + cg1_v * CS%beta_dx2_v(i,J)))**power_2 + dx_term = (US%L_T_to_m_s**2 * (CS%f2_dx2_v(i,J) + cg1_v(i,J) * CS%beta_dx2_v(i,J)))**power_2 CS%Res_fn_v(i,J) = dx_term / & - (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_v)**CS%Res_fn_power_khth) + (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_v(i,J))**CS%Res_fn_power_khth) enddo ; enddo else -!$OMP do + !$OMP do do j=js,je ; do I=is-1,Ieq - cg1_u = 0.5 * (CS%cg1(i,j) + CS%cg1(i+1,j)) dx_term = (US%L_T_to_m_s*sqrt(CS%f2_dx2_u(I,j) + & - cg1_u * CS%beta_dx2_u(I,j)))**CS%Res_fn_power_khth + cg1_u(I,j) * CS%beta_dx2_u(I,j)))**CS%Res_fn_power_khth CS%Res_fn_u(I,j) = dx_term / & - (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_u)**CS%Res_fn_power_khth) + (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_u(I,j))**CS%Res_fn_power_khth) enddo ; enddo -!$OMP do + !$OMP do do J=js-1,Jeq ; do i=is,ie - cg1_v = 0.5 * (CS%cg1(i,j) + CS%cg1(i,j+1)) dx_term = (US%L_T_to_m_s*sqrt(CS%f2_dx2_v(i,J) + & - cg1_v * CS%beta_dx2_v(i,J)))**CS%Res_fn_power_khth + cg1_v(i,J) * CS%beta_dx2_v(i,J)))**CS%Res_fn_power_khth CS%Res_fn_v(i,J) = dx_term / & - (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_v)**CS%Res_fn_power_khth) + (dx_term + (CS%Res_coef_khth * US%L_T_to_m_s*cg1_v(i,J))**CS%Res_fn_power_khth) enddo ; enddo endif endif -!$OMP end parallel + !$OMP end parallel if (query_averaging_enabled(CS%diag)) then if (CS%id_Res_fn > 0) call post_data(CS%id_Res_fn, CS%Res_fn_h, CS%diag) + if (CS%id_BS_struct > 0) call post_data(CS%id_BS_struct, CS%BS_struct, CS%diag) + if (CS%id_khth_struct > 0) call post_data(CS%id_khth_struct, CS%khth_struct, CS%diag) + if (CS%id_khtr_struct > 0) call post_data(CS%id_khtr_struct, CS%khtr_struct, CS%diag) + if (CS%id_kdgl90_struct > 0) call post_data(CS%id_kdgl90_struct, CS%kdgl90_struct, CS%diag) + endif + + if (CS%debug) then + call hchksum(CS%cg1, "calc_resoln_fn cg1", G%HI, haloshift=1, unscale=US%L_T_to_m_s) + call uvchksum("Res_fn_[uv]", CS%Res_fn_u, CS%Res_fn_v, G%HI, haloshift=0, & + unscale=1.0, scalar_pair=.true.) endif end subroutine calc_resoln_function +!> Calculates and stores functions of SQG mode +subroutine calc_sqg_struct(h, tv, G, GV, US, CS, dt, MEKE, OBC) + 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 + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure + + ! 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 buoyancy frequency at u-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: N2_v ! Square of buoyancy frequency 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 [Z ~> 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 [L ~> m] + + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Geometric layer thicknesses in height units [Z ~> m] + real :: I_f_Le(SZI_(G),SZJ_(G)) ! The inverse of the absolute value of f times the Eddy + ! length scale [T L-1 ~> s m-1] + real :: p_i(SZI_(G),SZJ_(G)) ! Pressure at the interface [R L2 T-2 ~> Pa] + real :: T_i(SZI_(G)) ! Temperature at the interface [C ~> degC] + real :: S_i(SZI_(G)) ! Salinity at the interface [S ~> ppt] + real :: dRho_dS(SZI_(G)) ! Local change in density with salinity using the model EOS and + ! state interpolated to an interface [R C-1 ~> kg m-3 ppt-1] + real :: dRho_dT(SZI_(G)) ! Local change in density with salinity using the model EOS and + ! state interpolated [R C-1 ~> kg m-3 degC-1] + real :: H_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] + real :: GxSpV ! Gravitiational acceleration times the specific volume at an interface + ! [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] + real :: drdk ! Vertical density differences across an interface [R ~> kg m-3] + real :: dz_int ! Average of thicknesses around an interface in height units [Z ~> m] + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + 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.") + + if (CS%sqg_expo <= 0.) then + CS%sqg_struct(:,:,:) = 1. + else + if (allocated(MEKE%Le)) then + do j=js,je ; do i=is,ie + Le(i,j) = MEKE%Le(i,j) + enddo ; enddo + else + do j=js,je ; do i=is,ie + Le(i,j) = sqrt(G%areaT(i,j)) + enddo ; enddo + endif + + do j=js,je ; do i=is,ie + ! Setting the structure averaged over the top layer to 1 is consistent with it being well mixed. + CS%sqg_struct(i,j,1) = 1.0 + enddo ; enddo + + if (CS%interpolated_sqg_struct) then + do j=js,je ; do i=is,ie + 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 + call find_eta(h, tv, G, GV, US, e, halo_size=2) !### Could be halo_size=1? + 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, OBC=OBC, OBC_N2=CS%OBC_friendly) + 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 + else + do j=js,je ; do i=is,ie + I_f_Le(i,j) = 1.0 / & + (Le(i,j) * max(0.25*((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & + (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1)))), f_subround)) + enddo ; enddo + + call thickness_to_dz(h, tv, dz, G, GV, US) + + if (associated(tv%eqn_of_state)) then + EOSdom(:) = EOS_domain(G%HI) + H_to_pres = GV%H_to_RZ * GV%g_Earth + ! Set the pressure at the topmost interior interface. + p_i(:,:) = 0.0 + if (associated(tv%p_surf)) then + do j=js,je ; do i=is,ie ; p_i(i,j) = tv%p_surf(i,j) ; enddo ; enddo + endif + if (.not.allocated(tv%SpV_avg)) GxSpV = GV%g_Earth / GV%Rho0 + do K=2,nz ; do j=js,je + ! Find the derivatives of density with T and S at the interface. + do i=is,ie + p_i(i,j) = p_i(i,j) + H_to_pres * h(i,j,k-1) + T_i(i) = 0.5*(tv%T(i,j,k-1)+tv%T(i,j,k)) + S_i(i) = 0.5*(tv%S(i,j,k-1)+tv%S(i,j,k)) + enddo + call calculate_density_derivs(T_i, S_i, p_i(:,j), dRho_dT, dRho_dS, tv%eqn_of_state, EOSdom) + + do i=is,ie + if (allocated(tv%SpV_avg)) & ! GxSpV is in [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] + GxSpV = GV%g_Earth * 0.5 * (tv%SpV_avg(i,j,k) + tv%SpV_avg(i,j,k-1)) + + drdk = max(dRho_dT(i) * (tv%T(i,j,k)-tv%T(i,j,k-1)) + & + dRho_dS(i) * (tv%S(i,j,k)-tv%S(i,j,k-1)), 0.0) ! Density difference [R ~> kg m-3] + dz_int = 0.5*(dz(i,j,k-1) + dz(i,j,k)) ! Thickness around interface [Z ~> m] + CS%sqg_struct(i,j,k) = CS%sqg_struct(i,j,k-1) * & + exp(-CS%sqg_expo * (sqrt((GxSpV * drdk) * dz_int) * I_f_Le(i,j)) ) + ! To derive the expression above, note that + ! N2 = GxSpV * drdk / dzh(i,j,K) ! Square of positive buoyancy freq. [L2 Z-2 T-2 ~> s-2] + ! CS%sqg_struct(i,j,k) = CS%sqg_struct(i,j,k-1) * & + ! exp(-CS%sqg_expo * (dz_int(i,j,K) * sqrt(N2) * I_f_Le(i,j)) ) + enddo + enddo ; enddo + else ! (GV%Boussinesq .and. .not.use_EOS) then + do K=2,nz ; do j=js,je ; do i=is,ie + dz_int = 0.5*(dz(i,j,k-1) + dz(i,j,k)) ! Thickness around interface [Z ~> m] + CS%sqg_struct(i,j,k) = CS%sqg_struct(i,j,k-1) * & + exp(-CS%sqg_expo * (sqrt(GV%g_prime(K) * dz_int) * I_f_Le(i,j)) ) + enddo ; enddo ; enddo + endif + endif + 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%interpolated_sqg_struct .and. (CS%sqg_expo > 0.)) then + if (CS%id_N2_u > 0) call post_data(CS%id_N2_u, N2_u, CS%diag) + if (CS%id_N2_v > 0) call post_data(CS%id_N2_v, N2_v, CS%diag) + endif + 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) @@ -453,38 +761,35 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables real, intent(in) :: dt !< Time increment [T ~> s] - type(VarMix_CS), intent(inout) :: CS !< Variable mixing control struct - type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure + ! 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),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 buoyancy frequency at u-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: N2_v ! Square of buoyancy frequency at v-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: dzu ! Z-thickness at u-points [Z ~> m] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: dzv ! Z-thickness at v-points [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: dzSxN ! |Sx| N times dz at u-points [Z T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: dzSyN ! |Sy| N times dz at v-points [Z T-1 ~> m s-1] if (.not. CS%initialized) call MOM_error(FATAL, "MOM_lateral_mixing_coeffs.F90, calc_slope_functions: "//& "Module must be initialized before it is used.") if (CS%calculate_Eady_growth_rate) then + call find_eta(h, tv, G, GV, US, e, halo_size=2) if (CS%use_simpler_Eady_growth_rate) then - call find_eta(h, tv, G, GV, US, e, halo_size=2) - call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, & + 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, OBC=OBC) - call calc_Eady_growth_rate_2D(CS, G, GV, US, OBC, h, e, dzu, dzv, dzSxN, dzSyN, CS%SN_u, CS%SN_v) + dzSxN=dzSxN, dzSyN=dzSyN, halo=1, OBC=OBC, OBC_N2=CS%OBC_friendly) + call calc_Eady_growth_rate_2D(CS, G, GV, US, h, e, dzu, dzv, dzSxN, dzSyN, CS%SN_u, CS%SN_v) + elseif (CS%use_stored_slopes) then + 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, halo=1, OBC=OBC, & + OBC_N2=CS%OBC_friendly) + call calc_Visbeck_coeffs_old(h, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, US, CS, OBC) else - call find_eta(h, tv, G, GV, US, e, halo_size=2) - if (CS%use_stored_slopes) then - call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, & - CS%slope_x, CS%slope_y, N2_u=N2_u, N2_v=N2_v, halo=1, OBC=OBC) - call calc_Visbeck_coeffs_old(h, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, US, CS, OBC) - else - !call calc_isoneutral_slopes(G, GV, h, e, tv, dt*CS%kappa_smooth, CS%slope_x, CS%slope_y) - call calc_slope_functions_using_just_e(h, G, GV, US, CS, e, .true., OBC) - endif + call calc_slope_functions_using_just_e(h, G, GV, US, CS, e) endif endif @@ -510,62 +815,117 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C 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] - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: slope_x !< Zonal isoneutral slope + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: slope_x !< Zonal isoneutral slope [Z L-1 ~> nondim] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: N2_u !< Buoyancy (Brunt-Vaisala) frequency !! at u-points [L2 Z-2 T-2 ~> s-2] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: slope_y !< Meridional isoneutral slope + !! [Z L-1 ~> nondim] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: N2_v !< Buoyancy (Brunt-Vaisala) frequency !! at v-points [L2 Z-2 T-2 ~> s-2] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(VarMix_CS), intent(inout) :: CS !< Variable mixing control struct - type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. ! Local variables - real :: S2 ! Interface slope squared [nondim] - real :: N2 ! Positive buoyancy frequency or zero [T-2 ~> s-2] + real :: S2 ! Interface slope squared [Z2 L-2 ~> nondim] + real :: N2 ! Positive buoyancy frequency or zero [L2 Z-2 T-2 ~> s-2] real :: Hup, Hdn ! Thickness from above, below [H ~> m or kg m-2] - real :: H_geom ! The geometric mean of Hup*Hdn [H ~> m or kg m-2]. - integer :: is, ie, js, je, nz - integer :: i, j, k, kb_max - integer :: l_seg - real :: S2max, wNE, wSE, wSW, wNW - real :: H_u(SZIB_(G)), H_v(SZI_(G)) - real :: S2_u(SZIB_(G), SZJ_(G)) - real :: S2_v(SZI_(G), SZJB_(G)) - logical :: local_open_u_BC, local_open_v_BC + real :: H_geom ! The geometric mean of Hup and Hdn [H ~> m or kg m-2]. + real :: S2max ! An upper bound on the squared slopes [Z2 L-2 ~> nondim] + real :: wNE, wSE, wSW, wNW ! Weights of adjacent points [nondim] + real :: H_u(SZIB_(G)), H_v(SZI_(G)) ! Layer thicknesses at u- and v-points [H ~> m or kg m-2] + + ! Note that at some points in the code S2_u and S2_v hold the running depth + ! integrals of the squared slope [H ~> m or kg m-2] before the average is taken. + real :: S2_u(SZIB_(G),SZJ_(G)) ! At first the thickness-weighted depth integral of the squared + ! slope [H Z2 L-2 ~> m or kg m-2] and then the average of the + ! squared slope [Z2 L-2 ~> nondim] at u points. + real :: S2_v(SZI_(G),SZJB_(G)) ! At first the thickness-weighted depth integral of the squared + ! slope [H Z2 L-2 ~> m or kg m-2] and then the average of the + ! squared slope [Z2 L-2 ~> nondim] at v points. + integer :: OBC_dir_u(SZIB_(G),SZJ_(G)) ! An integer indicating where there are u OBCs: +1 for + ! eastern OBCs, -1 for western OBCs and 0 at points with no OBCs. + integer :: OBC_dir_v(SZI_(G),SZJB_(G)) ! An integer indicating where there are v OBCs: +1 for + ! northern OBCs, -1 for southern OBCs and 0 at points with no OBCs. + real :: h4_u(SZIB_(G),SZJ_(G),SZK_(GV)+1) ! The product of the 4 thicknesses surrounding a u-point + ! interface or the inward equivalent with OBCs [H4 ~> m4 or kg4 m-8] + real :: h4_v(SZI_(G),SZJB_(G),SZK_(GV)+1) ! The product of the 4 thicknesses surrounding a v-point + ! interface or the inward equivalent with OBCs [H4 ~> m4 or kg4 m-8] + integer :: i, j, k, is, ie, js, je, nz if (.not. CS%initialized) call MOM_error(FATAL, "calc_Visbeck_coeffs_old: "// & "Module must be initialized before it is used.") if (.not. CS%calculate_Eady_growth_rate) return - if (.not. allocated(CS%SN_u)) call MOM_error(FATAL, "calc_slope_function:"// & + if (.not. allocated(CS%SN_u)) call MOM_error(FATAL, "calc_slope_function: "// & "%SN_u is not associated with use_variable_mixing.") - if (.not. allocated(CS%SN_v)) call MOM_error(FATAL, "calc_slope_function:"// & + if (.not. allocated(CS%SN_v)) call MOM_error(FATAL, "calc_slope_function: "// & "%SN_v is not associated with use_variable_mixing.") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - local_open_u_BC = .false. - local_open_v_BC = .false. - if (associated(OBC)) then - local_open_u_BC = OBC%open_u_BCs_exist_globally - local_open_v_BC = OBC%open_v_BCs_exist_globally - endif - S2max = CS%Visbeck_S_max**2 - !$OMP parallel do default(shared) - do j=js-1,je+1 ; do i=is-1,ie+1 - CS%SN_u(i,j) = 0.0 - CS%SN_v(i,j) = 0.0 - enddo ; enddo + CS%SN_u(:,:) = 0.0 + CS%SN_v(:,:) = 0.0 + + ! These settings apply where there are not open boundary conditions. + OBC_dir_u(:,:) = 0 ; OBC_dir_v(:,:) = 0 + + if (associated(OBC) .and. CS%OBC_friendly) then + ! Store the direction of any OBC faces. + !$OMP parallel do default(shared) + do j=js-1,je+1 ; do I=is-1,ie ; if (OBC%segnum_u(I,j) /= 0) then + if (OBC%segnum_u(I,j) > 0) OBC_dir_u(I,j) = 1 ! OBC_DIRECTION_E + if (OBC%segnum_u(I,j) < 0) OBC_dir_u(I,j) = -1 ! OBC_DIRECTION_W + endif ; enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is-1,ie+1 ; if (OBC%segnum_v(i,J) /= 0) then + if (OBC%segnum_v(i,J) > 0) OBC_dir_v(i,J) = 1 ! OBC_DIRECTION_N + if (OBC%segnum_v(i,J) < 0) OBC_dir_v(i,J) = -1 ! OBC_DIRECTION_S + endif ; enddo ; enddo + + ! Use the masked product of the 4 (or 2) thicknesses around a velocity-point interface for weights. + !$OMP parallel do default(shared) + do K=2,nz + do j=js-1,je+1 ; do I=is-1,ie + if (OBC_dir_u(I,j) == 0) then + h4_u(I,j,K) = G%mask2dCu(I,j) * ( (h(i,j,k)*h(i+1,j,k)) * (h(i,j,k-1)*h(i+1,j,k-1)) ) + elseif (OBC_dir_u(I,j) == 1) then ! OBC_DIRECTION_E + h4_u(I,j,K) = G%mask2dCu(I,j) * ( (h(i,j,k)**2) * (h(i,j,k-1)**2) ) + elseif (OBC_dir_u(I,j) == -1) then ! OBC_DIRECTION_W + h4_u(I,j,K) = G%mask2dCu(I,j) * ( (h(i+1,j,k)**2) * (h(i+1,j,k-1)**2) ) + endif + enddo ; enddo + do J=js-1,je ; do i=is-1,ie+1 + if (OBC_dir_v(i,J) == 0) then + h4_v(i,J,K) = G%mask2dCv(i,J) * ( (h(i,j,k)*h(i,j+1,k)) * (h(i,j,k-1)*h(i,j+1,k-1)) ) + elseif (OBC_dir_v(i,J) == 1) then ! OBC_DIRECTION_N + h4_v(i,J,K) = G%mask2dCv(i,J) * ( (h(i,j,k)**2) * (h(i,j,k-1)**2) ) + elseif (OBC_dir_v(i,J) == -1) then ! OBC_DIRECTION_S + h4_v(i,J,K) = G%mask2dCv(i,J) * ( (h(i,j+1,k)**2) * (h(i,j+1,k-1)**2) ) + endif + enddo ; enddo + enddo + else ! The land mask is sufficient and there are no special considerations taken at OBC points. + ! Use the masked product of the 4 thicknesses around a velocity-point interface for weights. + !$OMP parallel do default(shared) + do K=2,nz + do j=js-1,je+1 ; do I=is-1,ie + h4_u(I,j,K) = G%mask2dCu(I,j) * ( (h(i,j,k)*h(i+1,j,k)) * (h(i,j,k-1)*h(i+1,j,k-1)) ) + enddo ; enddo + do J=js-1,je ; do i=is-1,ie+1 + h4_v(i,J,K) = G%mask2dCv(i,J) * ( (h(i,j,k)*h(i,j+1,k)) * (h(i,j,k-1)*h(i,j+1,k-1)) ) + enddo ; enddo + enddo + endif ! To set the length scale based on the deformation radius, use wave_speed to ! calculate the first-mode gravity wave speed and then blend the equatorial ! and midlatitude deformation radii, using calc_resoln_function as a template. !$OMP parallel do default(shared) private(S2,H_u,Hdn,Hup,H_geom,N2,wNE,wSE,wSW,wNW) - do j = js,je + do j=js,je do I=is-1,ie CS%SN_u(I,j) = 0. ; H_u(I) = 0. ; S2_u(I,j) = 0. enddo @@ -575,13 +935,20 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C H_geom = sqrt( Hdn * Hup ) !H_geom = H_geom * sqrt(N2) ! WKB-ish !H_geom = H_geom * N2 ! WKB-ish - wSE = G%mask2dCv(i+1,J-1) * ( (h(i+1,j,k)*h(i+1,j-1,k)) * (h(i+1,j,k-1)*h(i+1,j-1,k-1)) ) - wNW = G%mask2dCv(i ,J ) * ( (h(i ,j,k)*h(i ,j+1,k)) * (h(i ,j,k-1)*h(i ,j+1,k-1)) ) - wNE = G%mask2dCv(i+1,J ) * ( (h(i+1,j,k)*h(i+1,j+1,k)) * (h(i+1,j,k-1)*h(i+1,j+1,k-1)) ) - wSW = G%mask2dCv(i ,J-1) * ( (h(i ,j,k)*h(i ,j-1,k)) * (h(i ,j,k-1)*h(i ,j-1,k-1)) ) + wSE = h4_v(i+1,J-1,K) + wNW = h4_v(i,J,K) + wNE = h4_v(i+1,J,K) + wSW = h4_v(i,J-1,K) + if (OBC_dir_u(I,j) == 1) then ! OBC_DIRECTION_E + wSE = 0.0 ; wNE = 0.0 + H_geom = sqrt( h(i,j,k) * h(i,j,k-1) ) + elseif (OBC_dir_u(I,j) == -1) then ! OBC_DIRECTION_W + wSW = 0.0 ; wNW = 0.0 + H_geom = sqrt( h(i+1,j,k) * h(i+1,j,k-1) ) + endif S2 = slope_x(I,j,K)**2 + & - ((wNW*slope_y(i,J,K)**2 + wSE*slope_y(i+1,J-1,K)**2) + & - (wNE*slope_y(i+1,J,K)**2 + wSW*slope_y(i,J-1,K)**2) ) / & + (((wNW*slope_y(i,J,K)**2) + (wSE*slope_y(i+1,J-1,K)**2)) + & + ((wNE*slope_y(i+1,J,K)**2) + (wSW*slope_y(i,J-1,K)**2)) ) / & ( ((wSE+wNW) + (wNE+wSW)) + GV%H_subroundoff**4 ) if (S2max>0.) S2 = S2 * S2max / (S2 + S2max) ! Limit S2 @@ -592,25 +959,16 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C enddo ; enddo do I=is-1,ie if (H_u(I)>0.) then - CS%SN_u(I,j) = G%mask2dCu(I,j) * CS%SN_u(I,j) / H_u(I) - S2_u(I,j) = G%mask2dCu(I,j) * S2_u(I,j) / H_u(I) + CS%SN_u(I,j) = G%OBCmaskCu(I,j) * CS%SN_u(I,j) / H_u(I) + S2_u(I,j) = G%OBCmaskCu(I,j) * S2_u(I,j) / H_u(I) else CS%SN_u(I,j) = 0. endif - if (local_open_u_BC) then - l_seg = OBC%segnum_u(I,j) - - if (l_seg /= OBC_NONE) then - if (OBC%segment(l_seg)%open) then - CS%SN_u(i,J) = 0. - endif - endif - endif enddo enddo !$OMP parallel do default(shared) private(S2,H_v,Hdn,Hup,H_geom,N2,wNE,wSE,wSW,wNW) - do J = js-1,je + do J=js-1,je do i=is,ie CS%SN_v(i,J) = 0. ; H_v(i) = 0. ; S2_v(i,J) = 0. enddo @@ -620,13 +978,20 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C H_geom = sqrt( Hdn * Hup ) !H_geom = H_geom * sqrt(N2) ! WKB-ish !H_geom = H_geom * N2 ! WKB-ish - wSE = G%mask2dCu(I,j) * ( (h(i,j ,k)*h(i+1,j ,k)) * (h(i,j ,k-1)*h(i+1,j ,k-1)) ) - wNW = G%mask2dCu(I-1,j+1) * ( (h(i,j+1,k)*h(i-1,j+1,k)) * (h(i,j+1,k-1)*h(i-1,j+1,k-1)) ) - wNE = G%mask2dCu(I,j+1) * ( (h(i,j+1,k)*h(i+1,j+1,k)) * (h(i,j+1,k-1)*h(i+1,j+1,k-1)) ) - wSW = G%mask2dCu(I-1,j) * ( (h(i,j ,k)*h(i-1,j ,k)) * (h(i,j ,k-1)*h(i-1,j ,k-1)) ) + wSE = h4_u(I,j,K) + wNW = h4_u(I-1,j+1,K) + wNE = h4_u(I,j+1,K) + wSW = h4_u(I-1,j,K) + if (OBC_dir_v(i,J) == 1) then ! OBC_DIRECTION_N + wNW = 0.0 ; wNE = 0.0 + H_geom = sqrt( h(i,j,k) * h(i,j,k-1) ) + elseif (OBC_dir_v(i,J) == -1) then ! OBC_DIRECTION_S + wSW = 0.0 ; wSE = 0.0 + H_geom = sqrt( h(i,j+1,k) * h(i,j+1,k-1) ) + endif S2 = slope_y(i,J,K)**2 + & - ((wSE*slope_x(I,j,K)**2 + wNW*slope_x(I-1,j+1,K)**2) + & - (wNE*slope_x(I,j+1,K)**2 + wSW*slope_x(I-1,j,K)**2) ) / & + (((wSE*slope_x(I,j,K)**2) + (wNW*slope_x(I-1,j+1,K)**2)) + & + ((wNE*slope_x(I,j+1,K)**2) + (wSW*slope_x(I-1,j,K)**2)) ) / & ( ((wSE+wNW) + (wNE+wSW)) + GV%H_subroundoff**4 ) if (S2max>0.) S2 = S2 * S2max / (S2 + S2max) ! Limit S2 @@ -637,24 +1002,15 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C enddo ; enddo do i=is,ie if (H_v(i)>0.) then - CS%SN_v(i,J) = G%mask2dCv(i,J) * CS%SN_v(i,J) / H_v(i) - S2_v(i,J) = G%mask2dCv(i,J) * S2_v(i,J) / H_v(i) + CS%SN_v(i,J) = G%OBCmaskCv(i,J) * CS%SN_v(i,J) / H_v(i) + S2_v(i,J) = G%OBCmaskCv(i,J) * S2_v(i,J) / H_v(i) else CS%SN_v(i,J) = 0. endif - if (local_open_v_BC) then - l_seg = OBC%segnum_v(i,J) - - if (l_seg /= OBC_NONE) then - if (OBC%segment(OBC%segnum_v(i,J))%open) then - CS%SN_v(i,J) = 0. - endif - endif - endif enddo enddo -! Offer diagnostic fields for averaging. + ! Offer diagnostic fields for averaging. if (query_averaging_enabled(CS%diag)) then if (CS%id_S2_u > 0) call post_data(CS%id_S2_u, S2_u, CS%diag) if (CS%id_S2_v > 0) call post_data(CS%id_S2_v, S2_v, CS%diag) @@ -662,22 +1018,23 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C if (CS%debug) then call uvchksum("calc_Visbeck_coeffs_old slope_[xy]", slope_x, slope_y, G%HI, & - scale=US%Z_to_L, haloshift=1) + unscale=US%Z_to_L, haloshift=1) + ! call uvchksum("calc_Visbeck_coeffs_old S2_[uv]", S2_u, S2_v, G%HI, & + ! unscale=US%Z_to_L**2, scalar_pair=.true.) call uvchksum("calc_Visbeck_coeffs_old N2_u, N2_v", N2_u, N2_v, G%HI, & - scale=US%L_to_Z**2 * US%s_to_T**2, scalar_pair=.true.) + unscale=US%L_to_Z**2*US%s_to_T**2, scalar_pair=.true.) call uvchksum("calc_Visbeck_coeffs_old SN_[uv]", CS%SN_u, CS%SN_v, G%HI, & - scale=US%s_to_T, scalar_pair=.true.) + unscale=US%s_to_T, scalar_pair=.true.) endif end subroutine calc_Visbeck_coeffs_old !> Calculates the Eady growth rate (2D fields) for use in MEKE and the Visbeck schemes -subroutine calc_Eady_growth_rate_2D(CS, G, GV, US, OBC, h, e, dzu, dzv, dzSxN, dzSyN, SN_u, SN_v) +subroutine calc_Eady_growth_rate_2D(CS, G, GV, US, h, e, dzu, dzv, dzSxN, dzSyN, SN_u, SN_v) type(VarMix_CS), intent(inout) :: CS !< Variable mixing coefficients type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(ocean_OBC_type), pointer, intent(in) :: OBC !< Open boundaries control structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Interface height [Z ~> m] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface height [Z ~> m] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: dzu !< dz at u-points [Z ~> m] @@ -694,29 +1051,22 @@ subroutine calc_Eady_growth_rate_2D(CS, G, GV, US, OBC, h, e, dzu, dzv, dzSxN, d real :: sum_dz(SZI_(G)) ! Cumulative sum of z-thicknesses [Z ~> m] real :: vint_SN(SZIB_(G)) ! Cumulative integral of SN [Z T-1 ~> m s-1] real, dimension(SZIB_(G),SZJ_(G)) :: SN_cpy !< SN at u-points [T-1 ~> s-1] - real :: dz_neglect ! An incy wincy distance to avoid division by zero [Z ~> m] + real :: dz_neglect ! A negligibly small distance to avoid division by zero [Z ~> m] real :: r_crp_dist ! The inverse of the distance over which to scale the cropping [Z-1 ~> m-1] real :: dB, dT ! Elevation variables used when cropping [Z ~> m] - integer :: i, j, k, l_seg - logical :: local_open_u_BC, local_open_v_BC, crop + integer :: i, j, k + logical :: crop - dz_neglect = GV%H_subroundoff * GV%H_to_Z + dz_neglect = GV%dZ_subroundoff D_scale = CS%Eady_GR_D_scale if (D_scale<=0.) D_scale = 64.*GV%max_depth ! 0 means use full depth so choose something big r_crp_dist = 1. / max( dz_neglect, CS%cropping_distance ) crop = CS%cropping_distance>=0. ! Only filter out in-/out-cropped interface is parameter if non-negative - local_open_u_BC = .false. - local_open_v_BC = .false. - if (associated(OBC)) then - local_open_u_BC = OBC%open_u_BCs_exist_globally - local_open_v_BC = OBC%open_v_BCs_exist_globally - endif - if (CS%debug) then - call uvchksum("calc_Eady_growth_rate_2D dz[uv]", dzu, dzv, G%HI, scale=US%Z_to_m, scalar_pair=.true.) + call uvchksum("calc_Eady_growth_rate_2D dz[uv]", dzu, dzv, G%HI, unscale=US%Z_to_m, scalar_pair=.true.) call uvchksum("calc_Eady_growth_rate_2D dzS2N2[uv]", dzSxN, dzSyN, G%HI, & - scale=US%Z_to_m*US%s_to_T, scalar_pair=.true.) + unscale=US%Z_to_m*US%s_to_T, scalar_pair=.true.) endif !$OMP parallel do default(shared) @@ -725,8 +1075,8 @@ subroutine calc_Eady_growth_rate_2D(CS, G, GV, US, OBC, h, e, dzu, dzv, dzSxN, d CS%SN_v(i,j) = 0.0 enddo ; enddo - !$OMP parallel do default(shared) private(dnew,dz,weight,l_seg,vint_SN,sum_dz) - do j = G%jsc-1,G%jec+1 + !$OMP parallel do default(shared) private(dnew,dz,weight,vint_SN,sum_dz,dT,dB) + do j=G%jsc-1,G%jec+1 do I=G%isc-1,G%iec vint_SN(I) = 0. sum_dz(I) = dz_neglect @@ -763,23 +1113,13 @@ subroutine calc_Eady_growth_rate_2D(CS, G, GV, US, OBC, h, e, dzu, dzv, dzSxN, d enddo ; enddo endif do I=G%isc-1,G%iec - CS%SN_u(I,j) = G%mask2dCu(I,j) * ( vint_SN(I) / sum_dz(I) ) - SN_cpy(I,j) = G%mask2dCu(I,j) * ( vint_SN(I) / sum_dz(I) ) + CS%SN_u(I,j) = G%OBCmaskCu(I,j) * ( vint_SN(I) / sum_dz(I) ) + SN_cpy(I,j) = G%OBCmaskCu(I,j) * ( vint_SN(I) / sum_dz(I) ) enddo - if (local_open_u_BC) then - do I=G%isc-1,G%iec - l_seg = OBC%segnum_u(I,j) - if (l_seg /= OBC_NONE) then - if (OBC%segment(l_seg)%open) then - CS%SN_u(i,J) = 0. - endif - endif - enddo - endif enddo - !$OMP parallel do default(shared) private(dnew,dz,weight,l_seg) - do J = G%jsc-1,G%jec + !$OMP parallel do default(shared) private(dnew,dz,weight,vint_SN,sum_dz,dT,dB) + do J=G%jsc-1,G%jec do i=G%isc-1,G%iec+1 vint_SN(i) = 0. sum_dz(i) = dz_neglect @@ -816,93 +1156,97 @@ subroutine calc_Eady_growth_rate_2D(CS, G, GV, US, OBC, h, e, dzu, dzv, dzSxN, d enddo ; enddo endif do i=G%isc-1,G%iec+1 - CS%SN_v(i,J) = G%mask2dCv(i,J) * ( vint_SN(i) / sum_dz(i) ) + CS%SN_v(i,J) = G%OBCmaskCv(i,J) * ( vint_SN(i) / sum_dz(i) ) enddo - if (local_open_v_BC) then - do i=G%isc-1,G%iec+1 - l_seg = OBC%segnum_v(i,J) - if (l_seg /= OBC_NONE) then - if (OBC%segment(l_seg)%open) then - CS%SN_v(i,J) = 0. - endif - endif - enddo - endif enddo - do j = G%jsc,G%jec + do j=G%jsc,G%jec do I=G%isc-1,G%iec CS%SN_u(I,j) = sqrt( SN_cpy(I,j)**2 & - + 0.25*( (CS%SN_v(i,J)**2 + CS%SN_v(i+1,J-1)**2) & - + (CS%SN_v(i+1,J)**2 + CS%SN_v(i,J-1)**2) ) ) + + 0.25*( ((CS%SN_v(i,J)**2) + (CS%SN_v(i+1,J-1)**2)) & + + ((CS%SN_v(i+1,J)**2) + (CS%SN_v(i,J-1)**2)) ) ) enddo enddo - do J = G%jsc-1,G%jec + do J=G%jsc-1,G%jec do i=G%isc,G%iec CS%SN_v(i,J) = sqrt( CS%SN_v(i,J)**2 & - + 0.25*( (SN_cpy(I,j)**2 + SN_cpy(I-1,j+1)**2) & - + (SN_cpy(I,j+1)**2 + SN_cpy(I-1,j)**2) ) ) + + 0.25*( ((SN_cpy(I,j)**2) + (SN_cpy(I-1,j+1)**2)) & + + ((SN_cpy(I,j+1)**2) + (SN_cpy(I-1,j)**2)) ) ) enddo enddo if (CS%debug) then call uvchksum("calc_Eady_growth_rate_2D SN_[uv]", CS%SN_u, CS%SN_v, G%HI, & - scale=US%s_to_T, scalar_pair=.true.) + unscale=US%s_to_T, scalar_pair=.true.) endif end subroutine calc_Eady_growth_rate_2D !> The original calc_slope_function() that calculated slopes using !! interface positions only, not accounting for density variations. -subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slopes, OBC) +subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(VarMix_CS), intent(inout) :: CS !< Variable mixing control struct + type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface position [Z ~> m] - logical, intent(in) :: calculate_slopes !< If true, calculate slopes - !! internally otherwise use slopes stored in CS - type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + ! type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables ! Local variables - real :: E_x(SZIB_(G), SZJ_(G)) ! X-slope of interface at u points [nondim] (for diagnostics) - real :: E_y(SZI_(G), SZJB_(G)) ! Y-slope of interface at v points [nondim] (for diagnostics) + real :: E_x(SZIB_(G),SZJ_(G)) ! X-slope of interface at u points [Z L-1 ~> nondim] (for diagnostics) + real :: E_y(SZI_(G),SZJB_(G)) ! Y-slope of interface at v points [Z L-1 ~> nondim] (for diagnostics) + real :: dz_tot(SZI_(G),SZJ_(G)) ! The total thickness of the water columns [Z ~> m] + ! real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! The vertical distance across each layer [Z ~> m] real :: H_cutoff ! Local estimate of a minimum thickness for masking [H ~> m or kg m-2] + real :: dZ_cutoff ! A minimum water column depth for masking [H ~> m or kg m-2] + real :: h1, h2 ! Temporary total thicknesses [Z ~> m] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. - real :: S2 ! Interface slope squared [nondim] - real :: N2 ! Brunt-Vaisala frequency squared [T-2 ~> s-2] + real :: S2 ! Interface slope squared [Z2 L-2 ~> nondim] + real :: N2 ! Brunt-Vaisala frequency squared [L2 Z-2 T-2 ~> s-2] real :: Hup, Hdn ! Thickness from above, below [H ~> m or kg m-2] real :: H_geom ! The geometric mean of Hup*Hdn [H ~> m or kg m-2]. - real :: one_meter ! One meter in thickness units [H ~> m or kg m-2]. + real :: S2N2_u_local(SZIB_(G),SZJ_(G),SZK_(GV)) ! The depth integral of the slope times + ! the buoyancy frequency squared at u-points [Z T-2 ~> m s-2] + real :: S2N2_v_local(SZI_(G),SZJB_(G),SZK_(GV)) ! The depth integral of the slope times + ! the buoyancy frequency squared at v-points [Z T-2 ~> m s-2] + logical :: use_dztot ! If true, use the total water column thickness rather than the + ! bathymetric depth for certain calculations. integer :: is, ie, js, je, nz - integer :: i, j, k, kb_max - integer :: l_seg - real :: S2N2_u_local(SZIB_(G), SZJ_(G),SZK_(GV)) - real :: S2N2_v_local(SZI_(G), SZJB_(G),SZK_(GV)) - logical :: local_open_u_BC, local_open_v_BC + integer :: i, j, k if (.not. CS%initialized) call MOM_error(FATAL, "calc_slope_functions_using_just_e: "// & "Module must be initialized before it is used.") if (.not. CS%calculate_Eady_growth_rate) return - if (.not. allocated(CS%SN_u)) call MOM_error(FATAL, "calc_slope_function:"// & + if (.not. allocated(CS%SN_u)) call MOM_error(FATAL, "calc_slope_function: "// & "%SN_u is not associated with use_variable_mixing.") - if (.not. allocated(CS%SN_v)) call MOM_error(FATAL, "calc_slope_function:"// & + if (.not. allocated(CS%SN_v)) call MOM_error(FATAL, "calc_slope_function: "// & "%SN_v is not associated with use_variable_mixing.") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - local_open_u_BC = .false. - local_open_v_BC = .false. - if (associated(OBC)) then - local_open_u_BC = OBC%open_u_BCs_exist_globally - local_open_v_BC = OBC%open_v_BCs_exist_globally - endif - - one_meter = 1.0 * GV%m_to_H h_neglect = GV%H_subroundoff H_cutoff = real(2*nz) * (GV%Angstrom_H + h_neglect) + dZ_cutoff = real(2*nz) * (GV%Angstrom_Z + GV%dz_subroundoff) + + use_dztot = CS%full_depth_Eady_growth_rate ! .or. .not.(GV%Boussinesq or GV%semi_Boussinesq) + + if (use_dztot) then + !$OMP parallel do default(shared) + do j=js-1,je+1 ; do i=is-1,ie+1 + dz_tot(i,j) = e(i,j,1) - e(i,j,nz+1) + enddo ; enddo + ! The following mathematically equivalent expression is more expensive but is less + ! sensitive to roundoff for large Z_ref: + ! call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + ! do j=js-1,je+1 + ! do i=is-1,ie+1 ; dz_tot(i,j) = 0.0 ; enddo + ! do k=1,nz ; do i=is-1,ie+1 + ! dz_tot(i,j) = dz_tot(i,j) + dz(i,j,k) + ! enddo ; enddo + ! enddo + endif ! To set the length scale based on the deformation radius, use wave_speed to ! calculate the first-mode gravity wave speed and then blend the equatorial @@ -911,54 +1255,44 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop !$OMP parallel do default(shared) private(E_x,E_y,S2,Hdn,Hup,H_geom,N2) do k=nz,CS%VarMix_Ktop,-1 - if (calculate_slopes) then - ! Calculate the interface slopes E_x and E_y and u- and v- points respectively - do j=js-1,je+1 ; do I=is-1,ie - E_x(I,j) = US%Z_to_L*(e(i+1,j,K)-e(i,j,K))*G%IdxCu(I,j) - ! Mask slopes where interface intersects topography - if (min(h(I,j,k),h(I+1,j,k)) < H_cutoff) E_x(I,j) = 0. - enddo ; enddo - do J=js-1,je ; do i=is-1,ie+1 - E_y(i,J) = US%Z_to_L*(e(i,j+1,K)-e(i,j,K))*G%IdyCv(i,J) - ! Mask slopes where interface intersects topography - if (min(h(i,J,k),h(i,J+1,k)) < H_cutoff) E_y(I,j) = 0. - enddo ; enddo - else - do j=js-1,je+1 ; do I=is-1,ie - E_x(I,j) = CS%slope_x(I,j,k) - if (min(h(I,j,k),h(I+1,j,k)) < H_cutoff) E_x(I,j) = 0. - enddo ; enddo - do j=js-1,je ; do I=is-1,ie+1 - E_y(i,J) = CS%slope_y(i,J,k) - if (min(h(i,J,k),h(i,J+1,k)) < H_cutoff) E_y(I,j) = 0. - enddo ; enddo - endif + ! Calculate the interface slopes E_x and E_y and u- and v- points respectively + do j=js-1,je+1 ; do I=is-1,ie + E_x(I,j) = (e(i+1,j,K)-e(i,j,K))*G%IdxCu(I,j) + ! Mask slopes where interface intersects topography + if (min(h(i,j,k),h(i+1,j,k)) < H_cutoff) E_x(I,j) = 0. + enddo ; enddo + do J=js-1,je ; do i=is-1,ie+1 + E_y(i,J) = (e(i,j+1,K)-e(i,j,K))*G%IdyCv(i,J) + ! Mask slopes where interface intersects topography + if (min(h(i,j,k),h(i,j+1,k)) < H_cutoff) E_y(i,J) = 0. + enddo ; enddo ! Calculate N*S*h from this layer and add to the sum do j=js,je ; do I=is-1,ie S2 = ( E_x(I,j)**2 + 0.25*( & - (E_y(I,j)**2+E_y(I+1,j-1)**2)+(E_y(I+1,j)**2+E_y(I,j-1)**2) ) ) + ((E_y(i,J)**2) + (E_y(i+1,J-1)**2)) + ((E_y(i+1,J)**2) + (E_y(i,J-1)**2)) ) ) + if (min(h(i,j,k-1), h(i+1,j,k-1), h(i,j,k), h(i+1,j,k)) < H_cutoff) S2 = 0.0 + Hdn = 2.*h(i,j,k)*h(i,j,k-1) / (h(i,j,k) + h(i,j,k-1) + h_neglect) Hup = 2.*h(i+1,j,k)*h(i+1,j,k-1) / (h(i+1,j,k) + h(i+1,j,k-1) + h_neglect) H_geom = sqrt(Hdn*Hup) - N2 = GV%g_prime(k)*US%L_to_Z**2 / (GV%H_to_Z * max(Hdn,Hup,one_meter)) - if (min(h(i,j,k-1), h(i+1,j,k-1), h(i,j,k), h(i+1,j,k)) < H_cutoff) & - S2 = 0.0 - S2N2_u_local(I,j,k) = (H_geom * GV%H_to_Z) * S2 * N2 + ! N2 = GV%g_prime(k) / (GV%H_to_Z * max(Hdn, Hup, CS%h_min_N2)) + S2N2_u_local(I,j,k) = (H_geom * S2) * (GV%g_prime(k) / max(Hdn, Hup, CS%h_min_N2) ) enddo ; enddo do J=js-1,je ; do i=is,ie S2 = ( E_y(i,J)**2 + 0.25*( & - (E_x(i,J)**2+E_x(i-1,J+1)**2)+(E_x(i,J+1)**2+E_x(i-1,J)**2) ) ) + ((E_x(I,j)**2) + (E_x(I-1,j+1)**2)) + ((E_x(I,j+1)**2) + (E_x(I-1,j)**2)) ) ) + if (min(h(i,j,k-1), h(i,j+1,k-1), h(i,j,k), h(i,j+1,k)) < H_cutoff) S2 = 0.0 + Hdn = 2.*h(i,j,k)*h(i,j,k-1) / (h(i,j,k) + h(i,j,k-1) + h_neglect) Hup = 2.*h(i,j+1,k)*h(i,j+1,k-1) / (h(i,j+1,k) + h(i,j+1,k-1) + h_neglect) H_geom = sqrt(Hdn*Hup) - N2 = GV%g_prime(k)*US%L_to_Z**2 / (GV%H_to_Z * max(Hdn,Hup,one_meter)) - if (min(h(i,j,k-1), h(i,j+1,k-1), h(i,j,k), h(i,j+1,k)) < H_cutoff) & - S2 = 0.0 - S2N2_v_local(i,J,k) = (H_geom * GV%H_to_Z) * S2 * N2 + ! N2 = GV%g_prime(k) / (GV%H_to_Z * max(Hdn, Hup, CS%h_min_N2)) + S2N2_v_local(i,J,k) = (H_geom * S2) * (GV%g_prime(k) / (max(Hdn, Hup, CS%h_min_N2))) enddo ; enddo enddo ! k + !$OMP parallel do default(shared) do j=js,je do I=is-1,ie ; CS%SN_u(I,j) = 0.0 ; enddo @@ -966,26 +1300,23 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop CS%SN_u(I,j) = CS%SN_u(I,j) + S2N2_u_local(I,j,k) enddo ; enddo ! SN above contains S^2*N^2*H, convert to vertical average of S*N - do I=is-1,ie - !### Replace G%bathT+G%Z_ref here with (e(i,j,1) - e(i,j,nz+1)). - !SN_u(I,j) = sqrt( SN_u(I,j) / ( max(G%bathyT(i,j), G%bathyT(i+1,j)) + (G%Z_ref + GV%Angstrom_Z) ) ) - !The code below behaves better than the line above. Not sure why? AJA - if ( min(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref > H_cutoff*GV%H_to_Z ) then - CS%SN_u(I,j) = G%mask2dCu(I,j) * sqrt( CS%SN_u(I,j) / & - (max(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref) ) - else - CS%SN_u(I,j) = 0.0 - endif - if (local_open_u_BC) then - l_seg = OBC%segnum_u(I,j) - if (l_seg /= OBC_NONE) then - if (OBC%segment(l_seg)%open) then - CS%SN_u(I,j) = 0. - endif + if (use_dztot) then + do I=is-1,ie + CS%SN_u(I,j) = G%OBCmaskCu(I,j) * sqrt( CS%SN_u(I,j) / & + max(dz_tot(i,j), dz_tot(i+1,j), GV%dz_subroundoff) ) + enddo + else + do I=is-1,ie + h1 = max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) + h2 = max(G%meanSL(i+1,j) + G%bathyT(i+1,j), 0.0) + if ( min(h1, h2) > dZ_cutoff ) then + CS%SN_u(I,j) = G%OBCmaskCu(I,j) * sqrt( CS%SN_u(I,j) / max(h1, h2) ) + else + CS%SN_u(I,j) = 0.0 endif - endif - enddo + enddo + endif enddo !$OMP parallel do default(shared) do J=js-1,je @@ -993,56 +1324,84 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop do k=nz,CS%VarMix_Ktop,-1 ; do i=is,ie CS%SN_v(i,J) = CS%SN_v(i,J) + S2N2_v_local(i,J,k) enddo ; enddo - do i=is,ie - !### Replace G%bathT+G%Z_ref here with (e(i,j,1) - e(i,j,nz+1)). - !SN_v(i,J) = sqrt( SN_v(i,J) / ( max(G%bathyT(i,J), G%bathyT(i,J+1)) + (G%Z_ref + GV%Angstrom_Z) ) ) - !The code below behaves better than the line above. Not sure why? AJA - if ( min(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref > H_cutoff*GV%H_to_Z ) then - CS%SN_v(i,J) = G%mask2dCv(i,J) * sqrt( CS%SN_v(i,J) / & - (max(G%bathyT(i,j), G%bathyT(i,j+1)) + G%Z_ref) ) - else - CS%SN_v(i,J) = 0.0 - endif - if (local_open_v_BC) then - l_seg = OBC%segnum_v(i,J) - - if (l_seg /= OBC_NONE) then - if (OBC%segment(OBC%segnum_v(i,J))%open) then - CS%SN_v(i,J) = 0. - endif + if (use_dztot) then + do i=is,ie + CS%SN_v(i,J) = G%OBCmaskCv(i,J) * sqrt( CS%SN_v(i,J) / & + max(dz_tot(i,j), dz_tot(i,j+1), GV%dz_subroundoff) ) + enddo + else + do i=is,ie + ! There is a primordial horizontal indexing bug on the following line from the previous + ! versions of the code. This comment should be deleted by the end of 2024. + ! if ( min(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref > dZ_cutoff ) then + h1 = max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) + h2 = max(G%meanSL(i,j+1) + G%bathyT(i,j+1), 0.0) + if ( min(h1, h2) > dZ_cutoff ) then + CS%SN_v(i,J) = G%OBCmaskCv(i,J) * sqrt( CS%SN_v(i,J) / max(h1, h2) ) + else + CS%SN_v(i,J) = 0.0 endif - endif - enddo + enddo + endif enddo end subroutine calc_slope_functions_using_just_e + +!> Calculates and returns isopycnal slopes with wider halos for use in finding QG viscosity. +subroutine calc_QG_slopes(h, tv, dt, G, GV, US, slope_x, slope_y, CS, OBC) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + 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 + real, intent(in) :: dt !< Time increment [T ~> s] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: slope_x !< Isopycnal slope in i-dir [Z L-1 ~> nondim] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: slope_y !< Isopycnal slope in j-dir [Z L-1 ~> nondim] + type(VarMix_CS), intent(in) :: CS !< Variable mixing control structure + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: e ! The interface heights relative to mean sea level [Z ~> m] + + if (.not. CS%initialized) call MOM_error(FATAL, "MOM_lateral_mixing_coeffs.F90, calc_QG_slopes: "//& + "Module must be initialized before it is used.") + + call find_eta(h, tv, G, GV, US, e, halo_size=3) + call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, CS%use_stanley_iso, & + slope_x, slope_y, halo=2, OBC=OBC, OBC_N2=CS%OBC_friendly) + +end subroutine calc_QG_slopes + !> Calculates the Leith Laplacian and bi-harmonic viscosity coefficients -subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vort_xy_dx, vort_xy_dy) +subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, dz, k, div_xx_dx, div_xx_dy, slope_x, slope_y, & + vort_xy_dx, vort_xy_dy) type(VarMix_CS), intent(inout) :: CS !< Variable mixing coefficients - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] - integer, intent(in) :: k !< Layer for which to calculate vorticity magnitude - real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: div_xx_dx !< x-derivative of horizontal divergence + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: dz !< Layer vertical extents [Z ~> m] + integer, intent(in) :: k !< Layer for which to calculate vorticity magnitude + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: div_xx_dx !< x-derivative of horizontal divergence !! (d/dx(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1] - real, dimension(SZI_(G),SZJB_(G)), intent(in) :: div_xx_dy !< y-derivative of horizontal divergence + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: div_xx_dy !< y-derivative of horizontal divergence !! (d/dy(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: slope_x !< Isopycnal slope in i-dir [Z L-1 ~> nondim] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: slope_y !< Isopycnal slope in j-dir [Z L-1 ~> nondim] real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: vort_xy_dx !< x-derivative of vertical vorticity !! (d/dx(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: vort_xy_dy !< y-derivative of vertical vorticity !! (d/dy(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] ! Local variables real, dimension(SZI_(G),SZJB_(G)) :: & - dslopey_dz, & ! z-derivative of y-slope at v-points [Z-1 ~> m-1] + dslopey_dz, & ! z-derivative of y-slope at v-points [L-1 ~> m-1] h_at_v, & ! Thickness at v-points [H ~> m or kg m-2] beta_v, & ! Beta at v-points [T-1 L-1 ~> s-1 m-1] grad_vort_mag_v, & ! Magnitude of vorticity gradient at v-points [T-1 L-1 ~> s-1 m-1] grad_div_mag_v ! Magnitude of divergence gradient at v-points [T-1 L-1 ~> s-1 m-1] real, dimension(SZIB_(G),SZJ_(G)) :: & - dslopex_dz, & ! z-derivative of x-slope at u-points [Z-1 ~> m-1] + dslopex_dz, & ! z-derivative of x-slope at u-points [L-1 ~> m-1] h_at_u, & ! Thickness at u-points [H ~> m or kg m-2] beta_u, & ! Beta at u-points [T-1 L-1 ~> s-1 m-1] grad_vort_mag_u, & ! Magnitude of vorticity gradient at u-points [T-1 L-1 ~> s-1 m-1] @@ -1051,54 +1410,63 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo real :: h_at_slope_below ! The thickness below [H ~> m or kg m-2] real :: Ih ! The inverse of a combination of thicknesses [H-1 ~> m-1 or m2 kg-1] real :: f ! A copy of the Coriolis parameter [T-1 ~> s-1] - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq,nz - real :: inv_PI3 + real :: Z_to_H ! A local copy of depth to thickness conversion factors or the inverse of the + ! mass-weighted average specific volumes around an interface [H Z-1 ~> nondim or kg m-3] + real :: inv_PI3 ! The inverse of pi cubed [nondim] + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB nz = GV%ke - inv_PI3 = 1.0/((4.0*atan(1.0))**3) + inv_PI3 = 1.0 / ((4.0*atan(1.0))**3) + Z_to_H = GV%Z_to_H ! This will be replaced with a varying value in non-Boussinesq mode. if ((k > 1) .and. (k < nz)) then - do j=js-1,je+1 ; do I=is-2,Ieq+1 + do j=js-2,je+2 ; do I=is-2,ie+1 h_at_slope_above = 2. * ( h(i,j,k-1) * h(i+1,j,k-1) ) * ( h(i,j,k) * h(i+1,j,k) ) / & ( ( h(i,j,k-1) * h(i+1,j,k-1) ) * ( h(i,j,k) + h(i+1,j,k) ) & - + ( h(i,j,k) * h(i+1,j,k) ) * ( h(i,j,k-1) + h(i+1,j,k-1) ) + GV%H_subroundoff ) + + ( h(i,j,k) * h(i+1,j,k) ) * ( h(i,j,k-1) + h(i+1,j,k-1) ) + GV%H_subroundoff**3 ) h_at_slope_below = 2. * ( h(i,j,k) * h(i+1,j,k) ) * ( h(i,j,k+1) * h(i+1,j,k+1) ) / & ( ( h(i,j,k) * h(i+1,j,k) ) * ( h(i,j,k+1) + h(i+1,j,k+1) ) & - + ( h(i,j,k+1) * h(i+1,j,k+1) ) * ( h(i,j,k) + h(i+1,j,k) ) + GV%H_subroundoff ) - Ih = 1./ ( ( h_at_slope_above + h_at_slope_below + GV%H_subroundoff ) * GV%H_to_Z ) - dslopex_dz(I,j) = 2. * ( CS%slope_x(i,j,k) - CS%slope_x(i,j,k+1) ) * Ih + + ( h(i,j,k+1) * h(i+1,j,k+1) ) * ( h(i,j,k) + h(i+1,j,k) ) + GV%H_subroundoff**3 ) + Ih = 1./ ( h_at_slope_above + h_at_slope_below + GV%H_subroundoff ) + if (.not.GV%Boussinesq) & + Z_to_H = ( (h(i,j,k-1) + h(i+1,j,k-1)) + (h(i,j,k) + h(i+1,j,k)) ) / & + ( (dz(i,j,k-1) + dz(i+1,j,k-1)) + (dz(i,j,k) + dz(i+1,j,k)) + GV%dZ_subroundoff) + dslopex_dz(I,j) = 2. * ( slope_x(I,j,k) - slope_x(I,j,k+1) ) * (Z_to_H * Ih) h_at_u(I,j) = 2. * ( h_at_slope_above * h_at_slope_below ) * Ih enddo ; enddo - do J=js-2,Jeq+1 ; do i=is-1,ie+1 + do J=js-2,je+1 ; do i=is-2,ie+2 h_at_slope_above = 2. * ( h(i,j,k-1) * h(i,j+1,k-1) ) * ( h(i,j,k) * h(i,j+1,k) ) / & ( ( h(i,j,k-1) * h(i,j+1,k-1) ) * ( h(i,j,k) + h(i,j+1,k) ) & - + ( h(i,j,k) * h(i,j+1,k) ) * ( h(i,j,k-1) + h(i,j+1,k-1) ) + GV%H_subroundoff ) + + ( h(i,j,k) * h(i,j+1,k) ) * ( h(i,j,k-1) + h(i,j+1,k-1) ) + GV%H_subroundoff**3 ) h_at_slope_below = 2. * ( h(i,j,k) * h(i,j+1,k) ) * ( h(i,j,k+1) * h(i,j+1,k+1) ) / & ( ( h(i,j,k) * h(i,j+1,k) ) * ( h(i,j,k+1) + h(i,j+1,k+1) ) & - + ( h(i,j,k+1) * h(i,j+1,k+1) ) * ( h(i,j,k) + h(i,j+1,k) ) + GV%H_subroundoff ) - Ih = 1./ ( ( h_at_slope_above + h_at_slope_below + GV%H_subroundoff ) * GV%H_to_Z ) - dslopey_dz(i,J) = 2. * ( CS%slope_y(i,j,k) - CS%slope_y(i,j,k+1) ) * Ih + + ( h(i,j,k+1) * h(i,j+1,k+1) ) * ( h(i,j,k) + h(i,j+1,k) ) + GV%H_subroundoff**3 ) + Ih = 1./ ( h_at_slope_above + h_at_slope_below + GV%H_subroundoff ) + if (.not.GV%Boussinesq) & + Z_to_H = ( (h(i,j,k-1) + h(i,j+1,k-1)) + (h(i,j,k) + h(i,j+1,k)) ) / & + ( (dz(i,j,k-1) + dz(i,j+1,k-1)) + (dz(i,j,k) + dz(i,j+1,k)) + GV%dZ_subroundoff) + dslopey_dz(i,J) = 2. * ( slope_y(i,J,k) - slope_y(i,J,k+1) ) * (Z_to_H * Ih) h_at_v(i,J) = 2. * ( h_at_slope_above * h_at_slope_below ) * Ih enddo ; enddo - do J=js-1,je ; do i=is-1,Ieq+1 + do J=js-2,je+1 ; do i=is-1,ie+1 f = 0.5 * ( G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J) ) - vort_xy_dx(i,J) = vort_xy_dx(i,J) - f * US%L_to_Z * & - ( ( h_at_u(I,j) * dslopex_dz(I,j) + h_at_u(I-1,j+1) * dslopex_dz(I-1,j+1) ) & - + ( h_at_u(I-1,j) * dslopex_dz(I-1,j) + h_at_u(I,j+1) * dslopex_dz(I,j+1) ) ) / & + vort_xy_dx(i,J) = vort_xy_dx(i,J) - f * & + ( ( (h_at_u(I,j) * dslopex_dz(I,j)) + (h_at_u(I-1,j+1) * dslopex_dz(I-1,j+1)) ) & + + ( (h_at_u(I-1,j) * dslopex_dz(I-1,j)) + (h_at_u(I,j+1) * dslopex_dz(I,j+1)) ) ) / & ( ( h_at_u(I,j) + h_at_u(I-1,j+1) ) + ( h_at_u(I-1,j) + h_at_u(I,j+1) ) + GV%H_subroundoff) enddo ; enddo - do j=js-1,Jeq+1 ; do I=is-1,ie + do j=js-1,je+1 ; do I=is-2,ie+1 f = 0.5 * ( G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1) ) - vort_xy_dy(I,j) = vort_xy_dy(I,j) - f * US%L_to_Z * & - ( ( h_at_v(i,J) * dslopey_dz(i,J) + h_at_v(i+1,J-1) * dslopey_dz(i+1,J-1) ) & - + ( h_at_v(i,J-1) * dslopey_dz(i,J-1) + h_at_v(i+1,J) * dslopey_dz(i+1,J) ) ) / & + vort_xy_dy(I,j) = vort_xy_dy(I,j) - f * & + ( ( (h_at_v(i,J) * dslopey_dz(i,J)) + (h_at_v(i+1,J-1) * dslopey_dz(i+1,J-1)) ) & + + ( (h_at_v(i,J-1) * dslopey_dz(i,J-1)) + (h_at_v(i+1,J) * dslopey_dz(i+1,J)) ) ) / & ( ( h_at_v(i,J) + h_at_v(i+1,J-1) ) + ( h_at_v(i,J-1) + h_at_v(i+1,J) ) + GV%H_subroundoff) enddo ; enddo endif ! k > 1 @@ -1112,7 +1480,7 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo + (div_xx_dy(i+1,J) + div_xx_dy(i,J-1))))**2) if (CS%use_beta_in_QG_Leith) then beta_u(I,j) = sqrt((0.5*(G%dF_dx(i,j)+G%dF_dx(i+1,j))**2) + & - (0.5*(G%dF_dy(i,j)+G%dF_dy(i+1,j))**2)) + (0.5*(G%dF_dy(i,j)+G%dF_dy(i+1,j))**2)) CS%KH_u_QG(I,j,k) = MIN(grad_vort_mag_u(I,j) + grad_div_mag_u(I,j), 3.0*beta_u(I,j)) * & CS%Laplac3_const_u(I,j) * inv_PI3 else @@ -1128,7 +1496,7 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo + (div_xx_dx(I,j+1) + div_xx_dx(I-1,j))))**2) if (CS%use_beta_in_QG_Leith) then beta_v(i,J) = sqrt((0.5*(G%dF_dx(i,j)+G%dF_dx(i,j+1))**2) + & - (0.5*(G%dF_dy(i,j)+G%dF_dy(i,j+1))**2)) + (0.5*(G%dF_dy(i,j)+G%dF_dy(i,j+1))**2)) CS%KH_v_QG(i,J,k) = MIN(grad_vort_mag_v(i,J) + grad_div_mag_v(i,J), 3.0*beta_v(i,J)) * & CS%Laplac3_const_v(i,J) * inv_PI3 else @@ -1155,17 +1523,29 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) type(param_file_type), intent(in) :: param_file !< Parameter file handles type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(VarMix_CS), intent(inout) :: CS !< Variable mixing coefficients + ! Local variables - real :: KhTr_Slope_Cff, KhTh_Slope_Cff, oneOrTwo + real :: KhTr_Slope_Cff ! The nondimensional coefficient in the Visbeck formula + ! for the epipycnal tracer diffusivity [nondim] + real :: KhTh_Slope_Cff ! The nondimensional coefficient in the Visbeck formula + ! for the interface depth diffusivity [nondim] + real :: oneOrTwo ! A variable that may be 1 or 2, depending on which form + ! of the equatorial deformation radius us used [nondim] real :: N2_filter_depth ! A depth below which stratification is treated as monotonic when - ! calculating the first-mode wave speed [Z ~> m] - real :: KhTr_passivity_coeff + ! calculating the first-mode wave speed [H ~> m or kg m-2] + real :: KhTr_passivity_coeff ! Coefficient setting the ratio between along-isopycnal tracer + ! mixing and interface height mixing [nondim] real :: absurdly_small_freq ! A miniscule frequency that is used to avoid division by 0 [T-1 ~> s-1]. The ! default value is roughly (pi / (the age of the universe)). logical :: Gill_equatorial_Ld, use_FGNV_streamfn, use_MEKE, in_use - logical :: default_2018_answers, remap_answers_2018 - real :: MLE_front_length - real :: Leith_Lap_const ! The non-dimensional coefficient in the Leith viscosity + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + integer :: 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. + real :: MLE_front_length ! The frontal-length scale used to calculate the upscaling of + ! buoyancy gradients in boundary layer parameterizations [L ~> m] + real :: Leith_Lap_const ! The non-dimensional coefficient in the Leith viscosity [nondim] real :: grid_sp_u2, grid_sp_v2 ! Intermediate quantities for Leith metrics [L2 ~> m2] real :: grid_sp_u3, grid_sp_v3 ! Intermediate quantities for Leith metrics [L3 ~> m3] real :: wave_speed_min ! A floor in the first mode speed below which 0 is returned [L T-1 ~> m s-1] @@ -1174,9 +1554,19 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) ! scaled by the resolution function. logical :: better_speed_est ! If true, use a more robust estimate of the first ! mode wave speed as the starting point for iterations. -! This include declares and sets the variable "version". + real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale + ! temperature variance [nondim] + logical :: use_SQG ! This is true if the SQG structure will be used for any parameterizations. + logical :: om4_remap_via_sub_cells ! Use the OM4-era remap_via_sub_cells for calculating the EBT structure + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. + logical :: mixing_coefs_OBC_bug ! If false, use only interior data for thickness weighting in + ! lateral mixing coefficient calculations and to calculate stratification + ! and other fields at open boundary condition faces. + ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_lateral_mixing_coeffs" ! This module's name. + integer :: number_of_OBC_segments integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -1190,7 +1580,8 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) CS%calculate_cg1 = .false. CS%calculate_Rd_dx = .false. CS%calculate_res_fns = .false. - CS%use_simpler_Eady_growth_rate = .false. + CS%use_simpler_Eady_growth_rate = .false. + CS%full_depth_Eady_growth_rate = .false. CS%calculate_depth_fns = .false. ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") @@ -1208,7 +1599,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "when the first baroclinic deformation radius is well "//& "resolved.", default=.false.) call get_param(param_file, mdl, "DEPTH_SCALED_KHTH", CS%Depth_scaled_KhTh, & - "If true, KHTH is scaled away when the depth is shallower"//& + "If true, KHTH is scaled away when the depth is shallower "//& "than a reference depth: KHTH = MIN(1,H/H0)**N * KHTH, "//& "where H0 is a reference depth, controlled via DEPTH_SCALED_KHTH_H0, "//& "and the exponent (N) is controlled via DEPTH_SCALED_KHTH_EXP.",& @@ -1229,20 +1620,45 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) if (.not.use_MEKE) Resoln_scaled_MEKE_visc = .false. call get_param(param_file, mdl, "RESOLN_USE_EBT", CS%Resoln_use_ebt, & "If true, uses the equivalent barotropic wave speed instead "//& - "of first baroclinic wave for calculating the resolution fn.",& + "of first baroclinic wave for calculating the resolution function.",& + default=.false.) + call get_param(param_file, mdl, "BACKSCAT_EBT_POWER", CS%BS_EBT_power, & + "Power to raise EBT vertical structure to when backscatter "// & + "has vertical structure.", units="nondim", default=0.0) + call get_param(param_file, mdl, "BS_USE_SQG_STRUCT", CS%BS_use_sqg_struct, & + "If true, the SQG vertical structure is used for backscatter "//& + "on the condition that BS_EBT_power=0", & default=.false.) call get_param(param_file, mdl, "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) + "for the interface depth diffusivity", units="nondim", default=0.0) call get_param(param_file, mdl, "KHTR_SLOPE_CFF", KhTr_Slope_Cff, & "The nondimensional coefficient in the Visbeck formula "//& - "for the epipycnal tracer diffusivity", units="nondim", & - default=0.0) + "for the epipycnal tracer diffusivity", units="nondim", default=0.0) call get_param(param_file, mdl, "USE_STORED_SLOPES", CS%use_stored_slopes,& "If true, the isopycnal slopes are calculated once and "//& "stored for re-use. This uses more memory but avoids calling "//& @@ -1254,49 +1670,118 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) default=1.0e-17, units="s-1", scale=US%T_to_s) call get_param(param_file, mdl, "KHTH_USE_FGNV_STREAMFUNCTION", use_FGNV_streamfn, & default=.false., do_not_log=.true.) - CS%calculate_cg1 = CS%calculate_cg1 .or. use_FGNV_streamfn + CS%calculate_cg1 = CS%calculate_cg1 .or. use_FGNV_streamfn .or. CS%khth_use_ebt_struct & + .or. CS%kdgl90_use_ebt_struct .or. CS%BS_EBT_power>0. CS%calculate_Rd_dx = CS%calculate_Rd_dx .or. use_MEKE ! Indicate whether to calculate the Eady growth rate CS%calculate_Eady_growth_rate = use_MEKE .or. (KhTr_Slope_Cff>0.) .or. (KhTh_Slope_Cff>0.) call get_param(param_file, mdl, "KHTR_PASSIVITY_COEFF", KhTr_passivity_coeff, & - default=0., do_not_log=.true.) + units="nondim", default=0., do_not_log=.true.) CS%calculate_Rd_dx = CS%calculate_Rd_dx .or. (KhTr_passivity_coeff>0.) call get_param(param_file, mdl, "MLE_FRONT_LENGTH", MLE_front_length, & - default=0., do_not_log=.true.) + units="m", default=0.0, scale=US%m_to_L, do_not_log=.true.) CS%calculate_Rd_dx = CS%calculate_Rd_dx .or. (MLE_front_length>0.) call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false., do_not_log=.true.) - - if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct) then + call get_param(param_file, mdl, "USE_STANLEY_ISO", CS%use_stanley_iso, & + "If true, turn on Stanley SGS T variance parameterization "// & + "in isopycnal slope code.", default=.false.) + if (CS%use_stanley_iso) then + call get_param(param_file, mdl, "STANLEY_COEFF", Stanley_coeff, & + "Coefficient correlating the temperature gradient and SGS T variance.", & + units="nondim", default=-1.0, do_not_log=.true.) + if (Stanley_coeff < 0.0) call MOM_error(FATAL, & + "STANLEY_COEFF must be set >= 0 if USE_STANLEY_ISO is true.") + endif + call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", number_of_OBC_segments, & + default=0, do_not_log=.true.) + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. + call get_param(param_file, mdl, "MIXING_COEFS_OBC_BUG", mixing_coefs_OBC_bug, & + "If false, use only interior data for thickness weighting in lateral mixing "//& + "coefficient calculations and to calculate stratification and other fields at "//& + "open boundary condition faces.", & + default=enable_bugs, do_not_log=(number_of_OBC_segments<=0)) + CS%OBC_friendly = .not. MIXING_COEFS_OBC_BUG + call get_param(param_file, mdl, "RESOLN_FUNCTION_OBC_BUG", CS%res_fn_OBC_bug, & + "If false, use only interior data for calculating the resolution functions at "//& + "open boundary condition faces and vertices.", & + default=enable_bugs, do_not_log=(number_of_OBC_segments<=0)) + + if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct & + .or. CS%BS_EBT_power>0. .or. CS%khtr_use_ebt_struct) then in_use = .true. call get_param(param_file, mdl, "RESOLN_N2_FILTER_DEPTH", N2_filter_depth, & "The depth below which N2 is monotonized to avoid stratification "//& - "artifacts from altering the equivalent barotropic mode structure.",& - units="m", default=2000., scale=US%m_to_Z) + "artifacts from altering the equivalent barotropic mode structure. "//& + "This monotonzization is disabled if this parameter is negative.", & + units="m", default=-1.0, scale=GV%m_to_H) allocate(CS%ebt_struct(isd:ied,jsd:jed,GV%ke), source=0.0) endif + use_SQG = CS%BS_use_sqg_struct .or. CS%khth_use_sqg_struct .or. CS%khtr_use_sqg_struct .or. & + CS%kdgl90_use_sqg_struct + 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, do_not_log=.not.use_SQG) + call get_param(param_file, mdl, "INTERPOLATED_SQG_STRUCTURE", CS%interpolated_sqg_struct, & + "If true, interpolate properties to velocity points and then interpolate the "//& + "buoyancy frequencies and layer thicknesses back to tracer points when "//& + "calculating the SQG vertical structure.", & + default=.true., do_not_log=.not.use_SQG) + !### Consider changing the default for INTERPOLATED_SQG_STRUCTURE to false. + + if ((CS%BS_EBT_power>0.) .and. CS%BS_use_sqg_struct) call MOM_error(FATAL, & + "calc_resoln_function: BS_EBT_POWER>0. and BS_USE_SQG=True cannot be set together") + + if (CS%khth_use_ebt_struct .and. CS%khth_use_sqg_struct) call MOM_error(FATAL, & + "calc_resoln_function: Only one of KHTH_USE_EBT_STRUCT and KHTH_USE_SQG_STRUCT can be true") + + if (CS%khtr_use_ebt_struct .and. CS%khtr_use_sqg_struct) call MOM_error(FATAL, & + "calc_resoln_function: Only one of KHTR_USE_EBT_STRUCT and KHTR_USE_SQG_STRUCT can be true") + + if (CS%kdgl90_use_ebt_struct .and. CS%kdgl90_use_sqg_struct) call MOM_error(FATAL, & + "calc_resoln_function: Only one of KD_GL90_USE_EBT_STRUCT and KD_GL90_USE_SQG_STRUCT can be true") + + if (CS%BS_EBT_power>0. .or. CS%BS_use_sqg_struct) then + allocate(CS%BS_struct(isd:ied,jsd:jed,GV%ke), source=0.0) + endif + + if (CS%khth_use_ebt_struct .or. CS%khth_use_sqg_struct) then + allocate(CS%khth_struct(isd:ied, jsd:jed, gv%ke), source=0.0) + endif + + if (CS%khtr_use_ebt_struct .or. CS%khtr_use_sqg_struct) then + allocate(CS%khtr_struct(isd:ied, jsd:jed, gv%ke), source=0.0) + endif + + if (CS%kdgl90_use_ebt_struct .or. CS%kdgl90_use_sqg_struct) then + allocate(CS%kdgl90_struct(isd:ied, jsd:jed, gv%ke), source=0.0) + endif + if (CS%use_stored_slopes) then if (KhTr_Slope_Cff>0. .or. KhTh_Slope_Cff>0.) then call get_param(param_file, mdl, "VISBECK_MAX_SLOPE", CS%Visbeck_S_max, & "If non-zero, is an upper bound on slopes used in the "//& "Visbeck formula for diffusivity. This does not affect the "//& "isopycnal slope calculation used within thickness diffusion.", & - units="nondim", default=0.0) + units="nondim", default=0.0, scale=US%L_to_Z) else CS%Visbeck_S_max = 0. endif endif - if (CS%use_stored_slopes) then + if (CS%use_stored_slopes .or. (CS%interpolated_sqg_struct .and. (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) allocate(CS%slope_y(isd:ied,JsdB:JedB,GV%ke+1), source=0.0) call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_smooth, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & - units="m2 s-1", default=1.0e-6, scale=US%m_to_Z**2*US%T_to_s) + units="m2 s-1", default=1.0e-6, scale=GV%m2_s_to_HZ_T) endif if (CS%calculate_Eady_growth_rate) then @@ -1312,7 +1797,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "that avoids division by layer thickness. Recommended.", default=.false.) if (CS%use_simpler_Eady_growth_rate) then if (.not. CS%use_stored_slopes) call MOM_error(FATAL, & - "MOM_lateral_mixing_coeffs.F90, VarMix_init:"//& + "MOM_lateral_mixing_coeffs.F90, VarMix_init: "//& "When USE_SIMPLER_EADY_GROWTH_RATE=True, USE_STORED_SLOPES must also be True.") call get_param(param_file, mdl, "EADY_GROWTH_RATE_D_SCALE", CS%Eady_GR_D_scale, & "The depth from surface over which to average SN when calculating "//& @@ -1327,26 +1812,40 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "The layer number at which to start vertical integration "//& "of S*N for purposes of finding the Eady growth rate.", & units="nondim", default=2) + call get_param(param_file, mdl, "MIN_DZ_FOR_SLOPE_N2", CS%h_min_N2, & + "The minimum vertical distance to use in the denominator of the "//& + "bouyancy frequency used in the slope calculation.", & + units="m", default=1.0, scale=GV%m_to_H, do_not_log=CS%use_stored_slopes) + + call get_param(param_file, mdl, "FULL_DEPTH_EADY_GROWTH_RATE", CS%full_depth_Eady_growth_rate, & + "If true, calculate the Eady growth rate based on average slope times "//& + "stratification that includes contributions from sea-level changes "//& + "in its denominator, rather than just the nominal depth of the bathymetry. "//& + "This only applies when using the model interface heights as a proxy for "//& + "isopycnal slopes.", default=.not.(GV%Boussinesq.or.GV%semi_Boussinesq), & + do_not_log=CS%use_stored_slopes) endif endif if (KhTr_Slope_Cff>0. .or. KhTh_Slope_Cff>0.) then in_use = .true. call get_param(param_file, mdl, "VISBECK_L_SCALE", CS%Visbeck_L_scale, & - "The fixed length scale in the Visbeck formula.", units="m", & - default=0.0) + "The fixed length scale in the Visbeck formula, or if negative a nondimensional "//& + "scaling factor relating this length scale squared to the cell areas.", & + units="m or nondim", default=0.0, scale=US%m_to_L) allocate(CS%L2u(IsdB:IedB,jsd:jed), source=0.0) allocate(CS%L2v(isd:ied,JsdB:JedB), source=0.0) if (CS%Visbeck_L_scale<0) then + ! Undo the rescaling of CS%Visbeck_L_scale. do j=js,je ; do I=is-1,Ieq - CS%L2u(I,j) = CS%Visbeck_L_scale**2 * G%areaCu(I,j) + CS%L2u(I,j) = (US%L_to_m*CS%Visbeck_L_scale)**2 * G%areaCu(I,j) enddo ; enddo do J=js-1,Jeq ; do i=is,ie - CS%L2v(i,J) = CS%Visbeck_L_scale**2 * G%areaCv(i,J) + CS%L2v(i,J) = (US%L_to_m*CS%Visbeck_L_scale)**2 * G%areaCv(i,J) enddo ; enddo else - CS%L2u(:,:) = US%m_to_L**2*CS%Visbeck_L_scale**2 - CS%L2v(:,:) = US%m_to_L**2*CS%Visbeck_L_scale**2 + CS%L2u(:,:) = CS%Visbeck_L_scale**2 + CS%L2v(:,:) = CS%Visbeck_L_scale**2 endif CS%id_L2u = register_diag_field('ocean_model', 'L2u', diag%axesCu1, Time, & @@ -1357,7 +1856,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) @@ -1418,7 +1941,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "positive integer may be used, although even integers "//& "are more efficient to calculate. Setting this greater "//& "than 100 results in a step-function being used.", & - units="nondim", default=2) + default=2) call get_param(param_file, mdl, "VISC_RES_SCALE_COEF", CS%Res_coef_visc, & "A coefficient that determines how Kh is scaled away if "//& "RESOLN_SCALED_... is true, as "//& @@ -1431,7 +1954,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "are more efficient to calculate. Setting this greater "//& "than 100 results in a step-function being used. "//& "This function affects lateral viscosity, Kh, and not KhTh.", & - units="nondim", default=CS%Res_fn_power_khth) + default=CS%Res_fn_power_khth) call get_param(param_file, mdl, "INTERPOLATE_RES_FN", CS%interpolate_Res_fn, & "If true, interpolate the resolution function to the "//& "velocity points from the thickness points; otherwise "//& @@ -1439,10 +1962,10 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "function independently at each point.", default=.false.) if (CS%interpolate_Res_fn) then if (CS%Res_coef_visc /= CS%Res_coef_khth) call MOM_error(FATAL, & - "MOM_lateral_mixing_coeffs.F90, VarMix_init:"//& + "MOM_lateral_mixing_coeffs.F90, VarMix_init: "//& "When INTERPOLATE_RES_FN=True, VISC_RES_FN_POWER must equal KH_RES_SCALE_COEF.") if (CS%Res_fn_power_visc /= CS%Res_fn_power_khth) call MOM_error(FATAL, & - "MOM_lateral_mixing_coeffs.F90, VarMix_init:"//& + "MOM_lateral_mixing_coeffs.F90, VarMix_init: "//& "When INTERPOLATE_RES_FN=True, VISC_RES_FN_POWER must equal KH_RES_FN_POWER.") endif call get_param(param_file, mdl, "GILL_EQUATORIAL_LD", Gill_equatorial_Ld, & @@ -1456,35 +1979,35 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) endif do J=js-1,Jeq ; do I=is-1,Ieq - CS%f2_dx2_q(I,J) = (G%dxBu(I,J)**2 + G%dyBu(I,J)**2) * & - max(G%CoriolisBu(I,J)**2, absurdly_small_freq**2) - CS%beta_dx2_q(I,J) = oneOrTwo * ((G%dxBu(I,J))**2 + (G%dyBu(I,J))**2) * (sqrt(0.5 * & - ( (((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + & - ((G%CoriolisBu(I+1,J)-G%CoriolisBu(I,J)) * G%IdxCv(i+1,J))**2) + & - (((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + & - ((G%CoriolisBu(I,J+1)-G%CoriolisBu(I,J)) * G%IdyCu(I,j+1))**2) ) )) + CS%f2_dx2_q(I,J) = ((G%dxBu(I,J)**2) + (G%dyBu(I,J)**2)) * & + max(G%Coriolis2Bu(I,J), absurdly_small_freq**2) + CS%beta_dx2_q(I,J) = oneOrTwo * ((G%dxBu(I,J)**2) + (G%dyBu(I,J)**2)) * (sqrt(0.5 * & + ( ((((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2) + & + (((G%CoriolisBu(I+1,J)-G%CoriolisBu(I,J)) * G%IdxCv(i+1,J))**2)) + & + ((((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2) + & + (((G%CoriolisBu(I,J+1)-G%CoriolisBu(I,J)) * G%IdyCu(I,j+1))**2)) ) )) enddo ; enddo do j=js,je ; do I=is-1,Ieq - CS%f2_dx2_u(I,j) = (G%dxCu(I,j)**2 + G%dyCu(I,j)**2) * & - max(0.5* (G%CoriolisBu(I,J)**2+G%CoriolisBu(I,J-1)**2), absurdly_small_freq**2) - CS%beta_dx2_u(I,j) = oneOrTwo * ((G%dxCu(I,j))**2 + (G%dyCu(I,j))**2) * (sqrt( & - 0.25*( (((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2 + & - ((G%CoriolisBu(I+1,J)-G%CoriolisBu(I,J)) * G%IdxCv(i+1,J))**2) + & - (((G%CoriolisBu(I+1,J-1)-G%CoriolisBu(I,J-1)) * G%IdxCv(i+1,J-1))**2 + & - ((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2) ) + & - ((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 )) + CS%f2_dx2_u(I,j) = ((G%dxCu(I,j)**2) + (G%dyCu(I,j)**2)) * & + max(0.5* (G%Coriolis2Bu(I,J)+G%Coriolis2Bu(I,J-1)), absurdly_small_freq**2) + CS%beta_dx2_u(I,j) = oneOrTwo * ((G%dxCu(I,j)**2) + (G%dyCu(I,j)**2)) * (sqrt( & + ((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + & + 0.25*( ((((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2) + & + (((G%CoriolisBu(I+1,J)-G%CoriolisBu(I,J)) * G%IdxCv(i+1,J))**2)) + & + ((((G%CoriolisBu(I+1,J-1)-G%CoriolisBu(I,J-1)) * G%IdxCv(i+1,J-1))**2) + & + (((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2)) ) )) enddo ; enddo do J=js-1,Jeq ; do i=is,ie - CS%f2_dx2_v(i,J) = ((G%dxCv(i,J))**2 + (G%dyCv(i,J))**2) * & - max(0.5*(G%CoriolisBu(I,J)**2+G%CoriolisBu(I-1,J)**2), absurdly_small_freq**2) - CS%beta_dx2_v(i,J) = oneOrTwo * ((G%dxCv(i,J))**2 + (G%dyCv(i,J))**2) * (sqrt( & + CS%f2_dx2_v(i,J) = ((G%dxCv(i,J)**2) + (G%dyCv(i,J)**2)) * & + max(0.5*(G%Coriolis2Bu(I,J)+G%Coriolis2Bu(I-1,J)), absurdly_small_freq**2) + CS%beta_dx2_v(i,J) = oneOrTwo * ((G%dxCv(i,J)**2) + (G%dyCv(i,J)**2)) * (sqrt( & ((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + & - 0.25*( (((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + & - ((G%CoriolisBu(I-1,J+1)-G%CoriolisBu(I-1,J)) * G%IdyCu(I-1,j+1))**2) + & - (((G%CoriolisBu(I,J+1)-G%CoriolisBu(I,J)) * G%IdyCu(I,j+1))**2 + & - ((G%CoriolisBu(I-1,J)-G%CoriolisBu(I-1,J-1)) * G%IdyCu(I-1,j))**2) ) )) + 0.25*( ((((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2) + & + (((G%CoriolisBu(I-1,J+1)-G%CoriolisBu(I-1,J)) * G%IdyCu(I-1,j+1))**2)) + & + ((((G%CoriolisBu(I,J+1)-G%CoriolisBu(I,J)) * G%IdyCu(I,j+1))**2) + & + (((G%CoriolisBu(I-1,J)-G%CoriolisBu(I-1,J-1)) * G%IdyCu(I-1,j))**2)) ) )) enddo ; enddo endif @@ -1512,28 +2035,32 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%beta_dx2_h(isd:ied,jsd:jed), source=0.0) allocate(CS%f2_dx2_h(isd:ied,jsd:jed), source=0.0) do j=js-1,je+1 ; do i=is-1,ie+1 - CS%f2_dx2_h(i,j) = (G%dxT(i,j)**2 + G%dyT(i,j)**2) * & - max(0.25 * ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & - (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)), & + CS%f2_dx2_h(i,j) = ((G%dxT(i,j)**2) + (G%dyT(i,j)**2)) * & + max(0.25 * ((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + & + (G%Coriolis2Bu(I-1,J) + G%Coriolis2Bu(I,J-1))), & absurdly_small_freq**2) - CS%beta_dx2_h(i,j) = oneOrTwo * ((G%dxT(i,j))**2 + (G%dyT(i,j))**2) * (sqrt(0.5 * & - ( (((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2 + & - ((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2) + & - (((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2 + & - ((G%CoriolisBu(I-1,J)-G%CoriolisBu(I-1,J-1)) * G%IdyCu(I-1,j))**2) ) )) + CS%beta_dx2_h(i,j) = oneOrTwo * ((G%dxT(i,j)**2) + (G%dyT(i,j)**2)) * (sqrt(0.5 * & + ( ((((G%CoriolisBu(I,J)-G%CoriolisBu(I-1,J)) * G%IdxCv(i,J))**2) + & + (((G%CoriolisBu(I,J-1)-G%CoriolisBu(I-1,J-1)) * G%IdxCv(i,J-1))**2)) + & + ((((G%CoriolisBu(I,J)-G%CoriolisBu(I,J-1)) * G%IdyCu(I,j))**2) + & + (((G%CoriolisBu(I-1,J)-G%CoriolisBu(I-1,J-1)) * G%IdyCu(I-1,j))**2)) ) )) enddo ; enddo endif if (CS%calculate_cg1) then in_use = .true. allocate(CS%cg1(isd:ied,jsd:jed), source=0.0) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & + "The vintage of the expressions and order of arithmetic to use for remapping. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) + call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_TOL", wave_speed_tol, & "The fractional tolerance for finding the wave speeds.", & units="nondim", default=0.001) @@ -1544,10 +2071,16 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_BETTER_EST", better_speed_est, & "If true, use a more robust estimate of the first mode wave speed as the "//& "starting point for iterations.", default=.true.) - call wave_speed_init(CS%wave_speed, use_ebt_mode=CS%Resoln_use_ebt, & - mono_N2_depth=N2_filter_depth, remap_answers_2018=remap_answers_2018, & + 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, "EBT_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for calculating EBT structure. "//& + "See REMAPPING_USE_OM4_SUBCELLS for details. "//& + "We recommend setting this option to false.", default=om4_remap_via_sub_cells) + call wave_speed_init(CS%wave_speed, GV, use_ebt_mode=CS%Resoln_use_ebt, & + mono_N2_depth=N2_filter_depth, remap_answer_date=remap_answer_date, & better_speed_est=better_speed_est, min_speed=wave_speed_min, & - wave_speed_tol=wave_speed_tol) + om4_remap_via_sub_cells=om4_remap_via_sub_cells, wave_speed_tol=wave_speed_tol) endif ! Leith parameters @@ -1564,12 +2097,12 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "If true, include the beta term in the Leith nonlinear eddy viscosity.", & default=.true.) - ALLOC_(CS%Laplac3_const_u(IsdB:IedB,jsd:jed)) ; CS%Laplac3_const_u(:,:) = 0.0 - ALLOC_(CS%Laplac3_const_v(isd:ied,JsdB:JedB)) ; CS%Laplac3_const_v(:,:) = 0.0 - ALLOC_(CS%KH_u_QG(IsdB:IedB,jsd:jed,GV%ke)) ; CS%KH_u_QG(:,:,:) = 0.0 - ALLOC_(CS%KH_v_QG(isd:ied,JsdB:JedB,GV%ke)) ; CS%KH_v_QG(:,:,:) = 0.0 - ! register diagnostics + allocate(CS%Laplac3_const_u(IsdB:IedB,jsd:jed), source=0.0) + allocate(CS%Laplac3_const_v(isd:ied,JsdB:JedB), source=0.0) + allocate(CS%KH_u_QG(IsdB:IedB,jsd:jed,GV%ke), source=0.0) + allocate(CS%KH_v_QG(isd:ied,JsdB:JedB,GV%ke), source=0.0) + ! register diagnostics CS%id_KH_u_QG = register_diag_field('ocean_model', 'KH_u_QG', diag%axesCuL, Time, & 'Horizontal viscosity from Leith QG, at u-points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) CS%id_KH_v_QG = register_diag_field('ocean_model', 'KH_v_QG', diag%axesCvL, Time, & @@ -1589,7 +2122,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) enddo ; enddo if (.not. CS%use_stored_slopes) call MOM_error(FATAL, & - "MOM_lateral_mixing_coeffs.F90, VarMix_init:"//& + "MOM_lateral_mixing_coeffs.F90, VarMix_init: "//& "USE_STORED_SLOPES must be True when using QG Leith.") endif @@ -1601,56 +2134,47 @@ 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) & - deallocate(CS%ebt_struct) + if (allocated(CS%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 (allocated(CS%khth_struct)) deallocate(CS%khth_struct) + if (allocated(CS%khtr_struct)) deallocate(CS%khtr_struct) + if (allocated(CS%kdgl90_struct)) deallocate(CS%kdgl90_struct) - if (CS%use_stored_slopes) then - deallocate(CS%slope_x) - deallocate(CS%slope_y) - endif + if (allocated(CS%slope_x)) deallocate(CS%slope_x) + if (allocated(CS%slope_y)) deallocate(CS%slope_y) - if (CS%calculate_Eady_growth_rate) then - deallocate(CS%SN_u) - deallocate(CS%SN_v) - endif + if (allocated(CS%SN_u)) deallocate(CS%SN_u) + if (allocated(CS%SN_v)) deallocate(CS%SN_v) if (allocated(CS%L2u)) deallocate(CS%L2u) if (allocated(CS%L2v)) deallocate(CS%L2v) - if (CS%Resoln_scaling_used) then - deallocate(CS%Res_fn_h) - deallocate(CS%Res_fn_q) - deallocate(CS%Res_fn_u) - deallocate(CS%Res_fn_v) - deallocate(CS%beta_dx2_q) - deallocate(CS%beta_dx2_u) - deallocate(CS%beta_dx2_v) - deallocate(CS%f2_dx2_q) - deallocate(CS%f2_dx2_u) - deallocate(CS%f2_dx2_v) - endif + if (allocated(CS%Res_fn_h)) deallocate(CS%Res_fn_h) + if (allocated(CS%Res_fn_q)) deallocate(CS%Res_fn_q) + if (allocated(CS%Res_fn_u)) deallocate(CS%Res_fn_u) + if (allocated(CS%Res_fn_v)) deallocate(CS%Res_fn_v) + if (allocated(CS%beta_dx2_q)) deallocate(CS%beta_dx2_q) + if (allocated(CS%beta_dx2_u)) deallocate(CS%beta_dx2_u) + if (allocated(CS%beta_dx2_v)) deallocate(CS%beta_dx2_v) + if (allocated(CS%f2_dx2_q)) deallocate(CS%f2_dx2_q) + if (allocated(CS%f2_dx2_u)) deallocate(CS%f2_dx2_u) + if (allocated(CS%f2_dx2_v)) deallocate(CS%f2_dx2_v) - if (CS%Depth_scaled_KhTh) then - deallocate(CS%Depth_fn_u) - deallocate(CS%Depth_fn_v) - endif + if (allocated(CS%Depth_fn_u)) deallocate(CS%Depth_fn_u) + if (allocated(CS%Depth_fn_v)) deallocate(CS%Depth_fn_v) - if (CS%calculate_Rd_dx) then - deallocate(CS%Rd_dx_h) - deallocate(CS%beta_dx2_h) - deallocate(CS%f2_dx2_h) - endif + if (allocated(CS%Rd_dx_h)) deallocate(CS%Rd_dx_h) + if (allocated(CS%beta_dx2_h)) deallocate(CS%beta_dx2_h) + if (allocated(CS%f2_dx2_h)) deallocate(CS%f2_dx2_h) - if (CS%calculate_cg1) then - deallocate(CS%cg1) - endif + if (allocated(CS%cg1)) deallocate(CS%cg1) + + if (allocated(CS%Laplac3_const_u)) deallocate(CS%Laplac3_const_u) + if (allocated(CS%Laplac3_const_v)) deallocate(CS%Laplac3_const_v) + if (allocated(CS%KH_u_QG)) deallocate(CS%KH_u_QG) + if (allocated(CS%KH_v_QG)) deallocate(CS%KH_v_QG) - if (CS%Use_QG_Leith_GM) then - DEALLOC_(CS%Laplac3_const_u) - DEALLOC_(CS%Laplac3_const_v) - DEALLOC_(CS%KH_u_QG) - DEALLOC_(CS%KH_v_QG) - endif end subroutine VarMix_end !> \namespace mom_lateral_mixing_coeffs @@ -1674,14 +2198,14 @@ end subroutine VarMix_end !! \f] !! !! \todo Check this reference to Bob on/off paper. -!! The resolution function used in scaling diffusivities (Hallberg, 2010) is +!! The resolution function used in scaling diffusivities (\cite hallberg2013) is !! !! \f[ !! r(\Delta,L_d) = \frac{1}{1+(\alpha R)^p} !! \f] !! -!! The resolution function can be applied independently to thickness diffusion (module mom_thickness_diffuse), -!! tracer diffusion (mom_tracer_hordiff) lateral viscosity (mom_hor_visc). +!! The resolution function can be applied independently to thickness diffusion \(module mom_thickness_diffuse\), +!! tracer diffusion \(mom_tracer_hordiff\) lateral viscosity \(mom_hor_visc\). !! !! Robert Hallberg, 2013: Using a resolution function to regulate parameterizations of oceanic mesoscale eddy effects. !! Ocean Modelling, 71, pp 92-103. http://dx.doi.org/10.1016/j.ocemod.2013.08.007 @@ -1703,7 +2227,7 @@ end subroutine VarMix_end !! \section section_Vicbeck Visbeck diffusivity !! !! This module also calculates factors used in setting the thickness diffusivity similar to a Visbeck et al., 1997, -!! scheme. The factors are combined in mom_thickness_diffuse::thickness_diffuse() but calculated in this module. +!! scheme. The factors are combined in mom_thickness_diffuse::thickness_diffuse but calculated in this module. !! !! \f[ !! \kappa_h = \alpha_s L_s^2 S N @@ -1726,7 +2250,7 @@ end subroutine VarMix_end !! \section section_vertical_structure_khth Vertical structure function for KhTh !! !! The thickness diffusivity can be prescribed a vertical distribution with the shape of the equivalent barotropic -!! velocity mode. The structure function is stored in the control structure for thie module (varmix_cs) but is +!! velocity mode. The structure function is stored in the control structure for this module (varmix_cs) but is !! calculated using subroutines in mom_wave_speed. !! !! | Symbol | Module parameter | diff --git a/src/parameterizations/lateral/MOM_load_love_numbers.F90 b/src/parameterizations/lateral/MOM_load_love_numbers.F90 new file mode 100644 index 0000000000..8ca2951cc4 --- /dev/null +++ b/src/parameterizations/lateral/MOM_load_love_numbers.F90 @@ -0,0 +1,1492 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Load Love Numbers for degree range [0, 1440] +module MOM_load_love_numbers + +implicit none ; private + +public Love_Data + +integer, parameter :: lmax = 1440 !< Maximum degree of the stored Love numbers +real, dimension(4, lmax+1), parameter :: & + Love_Data = & + reshape((/ 0.0, 0.0000000000, 0.0000000000 , -1.0000000000 , & + 1.0, -1.2858777580,-8.9608179370e-1, -1.0000000000 , & + 2.0, -0.9907994900, 2.3286695000e-2, -3.0516104000e-1, & + 3.0, -1.0499631000, 6.9892136000e-2, -1.9585733000e-1, & + 4.0, -1.0526477000, 5.8670467000e-2, -1.3352284000e-1, & + 5.0, -1.0855918000, 4.6165153000e-2, -1.0456531000e-1, & + 6.0, -1.1431163000, 3.8586926000e-2, -9.0184841000e-2, & + 7.0, -1.2116273000, 3.4198827000e-2, -8.1906787000e-2, & + 8.0, -1.2831157000, 3.1474998000e-2, -7.6379141000e-2, & + 9.0, -1.3538554000, 2.9624407000e-2, -7.2250183000e-2, & + 10.0, -1.4223516000, 2.8273961000e-2, -6.8934145000e-2, & + 11.0, -1.4881117000, 2.7242278000e-2, -6.6147992000e-2, & + 12.0, -1.5510428000, 2.6431124000e-2, -6.3736253000e-2, & + 13.0, -1.6111895000, 2.5779507000e-2, -6.1602870000e-2, & + 14.0, -1.6686329000, 2.5245139000e-2, -5.9683159000e-2, & + 15.0, -1.7234569000, 2.4796803000e-2, -5.7931180000e-2, & + 16.0, -1.7757418000, 2.4410861000e-2, -5.6313294000e-2, & + 17.0, -1.8255646000, 2.4069336000e-2, -5.4804452000e-2, & + 18.0, -1.8730019000, 2.3758645000e-2, -5.3385807000e-2, & + 19.0, -1.9181321000, 2.3468646000e-2, -5.2043088000e-2, & + 20.0, -1.9610366000, 2.3191893000e-2, -5.0765423000e-2, & + 21.0, -2.0018000000, 2.2923032000e-2, -4.9544487000e-2, & + 22.0, -2.0405101000, 2.2658321000e-2, -4.8373866000e-2, & + 23.0, -2.0772571000, 2.2395242000e-2, -4.7248575000e-2, & + 24.0, -2.1121328000, 2.2132200000e-2, -4.6164708000e-2, & + 25.0, -2.1452296000, 2.1868280000e-2, -4.5119160000e-2, & + 26.0, -2.1766398000, 2.1603063000e-2, -4.4109431000e-2, & + 27.0, -2.2064546000, 2.1336479000e-2, -4.3133464000e-2, & + 28.0, -2.2347634000, 2.1068700000e-2, -4.2189540000e-2, & + 29.0, -2.2616531000, 2.0800053000e-2, -4.1276184000e-2, & + 30.0, -2.2872080000, 2.0530962000e-2, -4.0392105000e-2, & + 31.0, -2.3115088000, 2.0261897000e-2, -3.9536148000e-2, & + 32.0, -2.3346328000, 1.9993346000e-2, -3.8707260000e-2, & + 33.0, -2.3566536000, 1.9725790000e-2, -3.7904463000e-2, & + 34.0, -2.3776409000, 1.9459686000e-2, -3.7126837000e-2, & + 35.0, -2.3976605000, 1.9195459000e-2, -3.6373510000e-2, & + 36.0, -2.4167746000, 1.8933494000e-2, -3.5643644000e-2, & + 37.0, -2.4350414000, 1.8674136000e-2, -3.4936432000e-2, & + 38.0, -2.4525156000, 1.8417687000e-2, -3.4251094000e-2, & + 39.0, -2.4692484000, 1.8164407000e-2, -3.3586873000e-2, & + 40.0, -2.4852876000, 1.7914518000e-2, -3.2943035000e-2, & + 41.0, -2.5006779000, 1.7668203000e-2, -3.2318866000e-2, & + 42.0, -2.5154609000, 1.7425613000e-2, -3.1713675000e-2, & + 43.0, -2.5296755000, 1.7186866000e-2, -3.1126789000e-2, & + 44.0, -2.5433577000, 1.6952053000e-2, -3.0557557000e-2, & + 45.0, -2.5565412000, 1.6721240000e-2, -3.0005347000e-2, & + 46.0, -2.5692574000, 1.6494470000e-2, -2.9469547000e-2, & + 47.0, -2.5815353000, 1.6271769000e-2, -2.8949568000e-2, & + 48.0, -2.5934022000, 1.6053144000e-2, -2.8444838000e-2, & + 49.0, -2.6048833000, 1.5838586000e-2, -2.7954806000e-2, & + 50.0, -2.6160021000, 1.5628077000e-2, -2.7478940000e-2, & + 51.0, -2.6267805000, 1.5421585000e-2, -2.7016729000e-2, & + 52.0, -2.6372389000, 1.5219071000e-2, -2.6567679000e-2, & + 53.0, -2.6473964000, 1.5020486000e-2, -2.6131317000e-2, & + 54.0, -2.6572706000, 1.4825779000e-2, -2.5707185000e-2, & + 55.0, -2.6668781000, 1.4634888000e-2, -2.5294846000e-2, & + 56.0, -2.6762345000, 1.4447752000e-2, -2.4893877000e-2, & + 57.0, -2.6853540000, 1.4264303000e-2, -2.4503874000e-2, & + 58.0, -2.6942503000, 1.4084474000e-2, -2.4124449000e-2, & + 59.0, -2.7029358000, 1.3908192000e-2, -2.3755228000e-2, & + 60.0, -2.7114225000, 1.3735386000e-2, -2.3395852000e-2, & + 61.0, -2.7197214000, 1.3565983000e-2, -2.3045980000e-2, & + 62.0, -2.7278428000, 1.3399909000e-2, -2.2705280000e-2, & + 63.0, -2.7357965000, 1.3237092000e-2, -2.2373437000e-2, & + 64.0, -2.7435916000, 1.3077458000e-2, -2.2050147000e-2, & + 65.0, -2.7512366000, 1.2920935000e-2, -2.1735119000e-2, & + 66.0, -2.7587397000, 1.2767451000e-2, -2.1428073000e-2, & + 67.0, -2.7661083000, 1.2616936000e-2, -2.1128742000e-2, & + 68.0, -2.7733496000, 1.2469319000e-2, -2.0836869000e-2, & + 69.0, -2.7804703000, 1.2324532000e-2, -2.0552206000e-2, & + 70.0, -2.7874767000, 1.2182508000e-2, -2.0274516000e-2, & + 71.0, -2.7943748000, 1.2043181000e-2, -2.0003572000e-2, & + 72.0, -2.8011702000, 1.1906487000e-2, -1.9739156000e-2, & + 73.0, -2.8078682000, 1.1772362000e-2, -1.9481058000e-2, & + 74.0, -2.8144738000, 1.1640746000e-2, -1.9229076000e-2, & + 75.0, -2.8209918000, 1.1511578000e-2, -1.8983017000e-2, & + 76.0, -2.8274266000, 1.1384799000e-2, -1.8742695000e-2, & + 77.0, -2.8337824000, 1.1260352000e-2, -1.8507931000e-2, & + 78.0, -2.8400633000, 1.1138183000e-2, -1.8278553000e-2, & + 79.0, -2.8462730000, 1.1018236000e-2, -1.8054395000e-2, & + 80.0, -2.8524152000, 1.0900460000e-2, -1.7835300000e-2, & + 81.0, -2.8584932000, 1.0784802000e-2, -1.7621113000e-2, & + 82.0, -2.8645103000, 1.0671213000e-2, -1.7411688000e-2, & + 83.0, -2.8704696000, 1.0559645000e-2, -1.7206882000e-2, & + 84.0, -2.8763739000, 1.0450051000e-2, -1.7006560000e-2, & + 85.0, -2.8822260000, 1.0342384000e-2, -1.6810590000e-2, & + 86.0, -2.8880285000, 1.0236599000e-2, -1.6618845000e-2, & + 87.0, -2.8937839000, 1.0132655000e-2, -1.6431203000e-2, & + 88.0, -2.8994945000, 1.0030508000e-2, -1.6247547000e-2, & + 89.0, -2.9051627000, 9.9301169000e-3, -1.6067762000e-2, & + 90.0, -2.9107905000, 9.8314429000e-3, -1.5891741000e-2, & + 91.0, -2.9163799000, 9.7344467000e-3, -1.5719376000e-2, & + 92.0, -2.9219330000, 9.6390907000e-3, -1.5550567000e-2, & + 93.0, -2.9274514000, 9.5453383000e-3, -1.5385215000e-2, & + 94.0, -2.9329370000, 9.4531538000e-3, -1.5223225000e-2, & + 95.0, -2.9383913000, 9.3625026000e-3, -1.5064506000e-2, & + 96.0, -2.9438161000, 9.2733509000e-3, -1.4908968000e-2, & + 97.0, -2.9492127000, 9.1856660000e-3, -1.4756526000e-2, & + 98.0, -2.9545826000, 9.0994159000e-3, -1.4607099000e-2, & + 99.0, -2.9599272000, 9.0145695000e-3, -1.4460604000e-2, & + 100.0, -2.9652476000, 8.9310967000e-3, -1.4316967000e-2, & + 101.0, -2.9705453000, 8.8489681000e-3, -1.4176111000e-2, & + 102.0, -2.9758213000, 8.7681548000e-3, -1.4037965000e-2, & + 103.0, -2.9810767000, 8.6886292000e-3, -1.3902458000e-2, & + 104.0, -2.9863125000, 8.6103640000e-3, -1.3769523000e-2, & + 105.0, -2.9915299000, 8.5333328000e-3, -1.3639094000e-2, & + 106.0, -2.9967298000, 8.4575097000e-3, -1.3511108000e-2, & + 107.0, -3.0019129000, 8.3828699000e-3, -1.3385503000e-2, & + 108.0, -3.0070803000, 8.3093886000e-3, -1.3262220000e-2, & + 109.0, -3.0122328000, 8.2370423000e-3, -1.3141201000e-2, & + 110.0, -3.0173710000, 8.1658076000e-3, -1.3022390000e-2, & + 111.0, -3.0224958000, 8.0956619000e-3, -1.2905734000e-2, & + 112.0, -3.0276079000, 8.0265832000e-3, -1.2791179000e-2, & + 113.0, -3.0327080000, 7.9585500000e-3, -1.2678675000e-2, & + 114.0, -3.0377966000, 7.8915413000e-3, -1.2568172000e-2, & + 115.0, -3.0428744000, 7.8255367000e-3, -1.2459622000e-2, & + 116.0, -3.0479420000, 7.7605163000e-3, -1.2352979000e-2, & + 117.0, -3.0529999000, 7.6964606000e-3, -1.2248198000e-2, & + 118.0, -3.0580486000, 7.6333507000e-3, -1.2145235000e-2, & + 119.0, -3.0630887000, 7.5711680000e-3, -1.2044048000e-2, & + 120.0, -3.0681205000, 7.5098946000e-3, -1.1944594000e-2, & + 121.0, -3.0731446000, 7.4495128000e-3, -1.1846835000e-2, & + 122.0, -3.0781614000, 7.3900054000e-3, -1.1750732000e-2, & + 123.0, -3.0831713000, 7.3313557000e-3, -1.1656245000e-2, & + 124.0, -3.0881747000, 7.2735474000e-3, -1.1563340000e-2, & + 125.0, -3.0931718000, 7.2165644000e-3, -1.1471980000e-2, & + 126.0, -3.0981632000, 7.1603911000e-3, -1.1382130000e-2, & + 127.0, -3.1031490000, 7.1050124000e-3, -1.1293757000e-2, & + 128.0, -3.1081296000, 7.0504134000e-3, -1.1206828000e-2, & + 129.0, -3.1131054000, 6.9965795000e-3, -1.1121311000e-2, & + 130.0, -3.1180765000, 6.9434967000e-3, -1.1037175000e-2, & + 131.0, -3.1230433000, 6.8911509000e-3, -1.0954391000e-2, & + 132.0, -3.1280059000, 6.8395288000e-3, -1.0872928000e-2, & + 133.0, -3.1329647000, 6.7886171000e-3, -1.0792758000e-2, & + 134.0, -3.1379199000, 6.7384029000e-3, -1.0713853000e-2, & + 135.0, -3.1428716000, 6.6888735000e-3, -1.0636187000e-2, & + 136.0, -3.1478201000, 6.6400168000e-3, -1.0559733000e-2, & + 137.0, -3.1527656000, 6.5918206000e-3, -1.0484466000e-2, & + 138.0, -3.1577082000, 6.5442732000e-3, -1.0410360000e-2, & + 139.0, -3.1626481000, 6.4973631000e-3, -1.0337392000e-2, & + 140.0, -3.1675855000, 6.4510790000e-3, -1.0265537000e-2, & + 141.0, -3.1725205000, 6.4054099000e-3, -1.0194773000e-2, & + 142.0, -3.1774533000, 6.3603452000e-3, -1.0125078000e-2, & + 143.0, -3.1823840000, 6.3158742000e-3, -1.0056429000e-2, & + 144.0, -3.1873127000, 6.2719868000e-3, -9.9888045000e-3, & + 145.0, -3.1922396000, 6.2286729000e-3, -9.9221850000e-3, & + 146.0, -3.1971648000, 6.1859227000e-3, -9.8565496000e-3, & + 147.0, -3.2020883000, 6.1437265000e-3, -9.7918788000e-3, & + 148.0, -3.2070102000, 6.1020749000e-3, -9.7281532000e-3, & + 149.0, -3.2119308000, 6.0609589000e-3, -9.6653542000e-3, & + 150.0, -3.2168500000, 6.0203693000e-3, -9.6034635000e-3, & + 151.0, -3.2217679000, 5.9802974000e-3, -9.5424633000e-3, & + 152.0, -3.2266847000, 5.9407346000e-3, -9.4823362000e-3, & + 153.0, -3.2316003000, 5.9016724000e-3, -9.4230652000e-3, & + 154.0, -3.2365149000, 5.8631026000e-3, -9.3646338000e-3, & + 155.0, -3.2414284000, 5.8250172000e-3, -9.3070259000e-3, & + 156.0, -3.2463411000, 5.7874081000e-3, -9.2502257000e-3, & + 157.0, -3.2512529000, 5.7502678000e-3, -9.1942178000e-3, & + 158.0, -3.2561639000, 5.7135886000e-3, -9.1389873000e-3, & + 159.0, -3.2610741000, 5.6773630000e-3, -9.0845194000e-3, & + 160.0, -3.2659835000, 5.6415839000e-3, -9.0308000000e-3, & + 161.0, -3.2708923000, 5.6062442000e-3, -8.9778149000e-3, & + 162.0, -3.2758004000, 5.5713368000e-3, -8.9255506000e-3, & + 163.0, -3.2807079000, 5.5368550000e-3, -8.8739938000e-3, & + 164.0, -3.2856148000, 5.5027920000e-3, -8.8231314000e-3, & + 165.0, -3.2905211000, 5.4691413000e-3, -8.7729507000e-3, & + 166.0, -3.2954269000, 5.4358966000e-3, -8.7234394000e-3, & + 167.0, -3.3003322000, 5.4030515000e-3, -8.6745852000e-3, & + 168.0, -3.3052370000, 5.3705998000e-3, -8.6263763000e-3, & + 169.0, -3.3101414000, 5.3385356000e-3, -8.5788012000e-3, & + 170.0, -3.3150452000, 5.3068529000e-3, -8.5318484000e-3, & + 171.0, -3.3199486000, 5.2755459000e-3, -8.4855070000e-3, & + 172.0, -3.3248516000, 5.2446089000e-3, -8.4397661000e-3, & + 173.0, -3.3297541000, 5.2140364000e-3, -8.3946150000e-3, & + 174.0, -3.3346563000, 5.1838229000e-3, -8.3500435000e-3, & + 175.0, -3.3395580000, 5.1539630000e-3, -8.3060415000e-3, & + 176.0, -3.3444593000, 5.1244515000e-3, -8.2625990000e-3, & + 177.0, -3.3493602000, 5.0952833000e-3, -8.2197063000e-3, & + 178.0, -3.3542607000, 5.0664532000e-3, -8.1773539000e-3, & + 179.0, -3.3591609000, 5.0379563000e-3, -8.1355327000e-3, & + 180.0, -3.3640606000, 5.0097879000e-3, -8.0942335000e-3, & + 181.0, -3.3689599000, 4.9819430000e-3, -8.0534474000e-3, & + 182.0, -3.3738588000, 4.9544170000e-3, -8.0131658000e-3, & + 183.0, -3.3787572000, 4.9272053000e-3, -7.9733801000e-3, & + 184.0, -3.3836553000, 4.9003034000e-3, -7.9340821000e-3, & + 185.0, -3.3885529000, 4.8737069000e-3, -7.8952635000e-3, & + 186.0, -3.3934501000, 4.8474114000e-3, -7.8569164000e-3, & + 187.0, -3.3983469000, 4.8214127000e-3, -7.8190330000e-3, & + 188.0, -3.4032432000, 4.7957066000e-3, -7.7816057000e-3, & + 189.0, -3.4081390000, 4.7702889000e-3, -7.7446269000e-3, & + 190.0, -3.4130344000, 4.7451557000e-3, -7.7080893000e-3, & + 191.0, -3.4179292000, 4.7203030000e-3, -7.6719857000e-3, & + 192.0, -3.4228236000, 4.6957268000e-3, -7.6363091000e-3, & + 193.0, -3.4277174000, 4.6714235000e-3, -7.6010526000e-3, & + 194.0, -3.4326107000, 4.6473891000e-3, -7.5662095000e-3, & + 195.0, -3.4375035000, 4.6236200000e-3, -7.5317730000e-3, & + 196.0, -3.4423957000, 4.6001126000e-3, -7.4977367000e-3, & + 197.0, -3.4472873000, 4.5768634000e-3, -7.4640943000e-3, & + 198.0, -3.4521783000, 4.5538688000e-3, -7.4308395000e-3, & + 199.0, -3.4570687000, 4.5311254000e-3, -7.3979662000e-3, & + 200.0, -3.4619585000, 4.5086298000e-3, -7.3654685000e-3, & + 201.0, -3.4668476000, 4.4863788000e-3, -7.3333403000e-3, & + 202.0, -3.4717360000, 4.4643689000e-3, -7.3015761000e-3, & + 203.0, -3.4766237000, 4.4425971000e-3, -7.2701701000e-3, & + 204.0, -3.4815107000, 4.4210601000e-3, -7.2391168000e-3, & + 205.0, -3.4863970000, 4.3997550000e-3, -7.2084108000e-3, & + 206.0, -3.4912825000, 4.3786785000e-3, -7.1780467000e-3, & + 207.0, -3.4961672000, 4.3578278000e-3, -7.1480193000e-3, & + 208.0, -3.5010512000, 4.3371999000e-3, -7.1183236000e-3, & + 209.0, -3.5059343000, 4.3167918000e-3, -7.0889544000e-3, & + 210.0, -3.5108165000, 4.2966008000e-3, -7.0599068000e-3, & + 211.0, -3.5156979000, 4.2766239000e-3, -7.0311760000e-3, & + 212.0, -3.5205784000, 4.2568586000e-3, -7.0027573000e-3, & + 213.0, -3.5254580000, 4.2373019000e-3, -6.9746460000e-3, & + 214.0, -3.5303366000, 4.2179514000e-3, -6.9468375000e-3, & + 215.0, -3.5352143000, 4.1988043000e-3, -6.9193272000e-3, & + 216.0, -3.5400909000, 4.1798580000e-3, -6.8921109000e-3, & + 217.0, -3.5449666000, 4.1611101000e-3, -6.8651842000e-3, & + 218.0, -3.5498412000, 4.1425580000e-3, -6.8385428000e-3, & + 219.0, -3.5547147000, 4.1241992000e-3, -6.8121826000e-3, & + 220.0, -3.5595871000, 4.1060313000e-3, -6.7860995000e-3, & + 221.0, -3.5644584000, 4.0880520000e-3, -6.7602894000e-3, & + 222.0, -3.5693286000, 4.0702588000e-3, -6.7347484000e-3, & + 223.0, -3.5741976000, 4.0526495000e-3, -6.7094726000e-3, & + 224.0, -3.5790654000, 4.0352217000e-3, -6.6844583000e-3, & + 225.0, -3.5839320000, 4.0179733000e-3, -6.6597016000e-3, & + 226.0, -3.5887973000, 4.0009020000e-3, -6.6351989000e-3, & + 227.0, -3.5936613000, 3.9840057000e-3, -6.6109466000e-3, & + 228.0, -3.5985240000, 3.9672821000e-3, -6.5869411000e-3, & + 229.0, -3.6033854000, 3.9507293000e-3, -6.5631791000e-3, & + 230.0, -3.6082455000, 3.9343450000e-3, -6.5396569000e-3, & + 231.0, -3.6131041000, 3.9181273000e-3, -6.5163713000e-3, & + 232.0, -3.6179613000, 3.9020742000e-3, -6.4933190000e-3, & + 233.0, -3.6228171000, 3.8861836000e-3, -6.4704966000e-3, & + 234.0, -3.6276714000, 3.8704536000e-3, -6.4479012000e-3, & + 235.0, -3.6325242000, 3.8548822000e-3, -6.4255293000e-3, & + 236.0, -3.6373754000, 3.8394677000e-3, -6.4033781000e-3, & + 237.0, -3.6422252000, 3.8242080000e-3, -6.3814445000e-3, & + 238.0, -3.6470733000, 3.8091013000e-3, -6.3597254000e-3, & + 239.0, -3.6519198000, 3.7941458000e-3, -6.3382179000e-3, & + 240.0, -3.6567647000, 3.7793398000e-3, -6.3169193000e-3, & + 241.0, -3.6616079000, 3.7646814000e-3, -6.2958265000e-3, & + 242.0, -3.6664494000, 3.7501690000e-3, -6.2749370000e-3, & + 243.0, -3.6712891000, 3.7358007000e-3, -6.2542478000e-3, & + 244.0, -3.6761271000, 3.7215749000e-3, -6.2337563000e-3, & + 245.0, -3.6809634000, 3.7074899000e-3, -6.2134599000e-3, & + 246.0, -3.6857978000, 3.6935441000e-3, -6.1933559000e-3, & + 247.0, -3.6906303000, 3.6797359000e-3, -6.1734419000e-3, & + 248.0, -3.6954610000, 3.6660636000e-3, -6.1537152000e-3, & + 249.0, -3.7002898000, 3.6525257000e-3, -6.1341734000e-3, & + 250.0, -3.7051167000, 3.6391206000e-3, -6.1148140000e-3, & + 251.0, -3.7099416000, 3.6258468000e-3, -6.0956346000e-3, & + 252.0, -3.7147645000, 3.6127027000e-3, -6.0766330000e-3, & + 253.0, -3.7195854000, 3.5996869000e-3, -6.0578067000e-3, & + 254.0, -3.7244043000, 3.5867979000e-3, -6.0391534000e-3, & + 255.0, -3.7292211000, 3.5740342000e-3, -6.0206710000e-3, & + 256.0, -3.7340357000, 3.5613944000e-3, -6.0023572000e-3, & + 257.0, -3.7388483000, 3.5488772000e-3, -5.9842098000e-3, & + 258.0, -3.7436587000, 3.5364810000e-3, -5.9662266000e-3, & + 259.0, -3.7484669000, 3.5242045000e-3, -5.9484056000e-3, & + 260.0, -3.7532729000, 3.5120464000e-3, -5.9307447000e-3, & + 261.0, -3.7580766000, 3.5000053000e-3, -5.9132419000e-3, & + 262.0, -3.7628780000, 3.4880799000e-3, -5.8958950000e-3, & + 263.0, -3.7676772000, 3.4762689000e-3, -5.8787022000e-3, & + 264.0, -3.7724740000, 3.4645710000e-3, -5.8616614000e-3, & + 265.0, -3.7772685000, 3.4529849000e-3, -5.8447709000e-3, & + 266.0, -3.7820605000, 3.4415093000e-3, -5.8280285000e-3, & + 267.0, -3.7868501000, 3.4301431000e-3, -5.8114326000e-3, & + 268.0, -3.7916373000, 3.4188851000e-3, -5.7949812000e-3, & + 269.0, -3.7964220000, 3.4077339000e-3, -5.7786726000e-3, & + 270.0, -3.8012042000, 3.3966884000e-3, -5.7625050000e-3, & + 271.0, -3.8059839000, 3.3857475000e-3, -5.7464766000e-3, & + 272.0, -3.8107610000, 3.3749099000e-3, -5.7305857000e-3, & + 273.0, -3.8155355000, 3.3641746000e-3, -5.7148305000e-3, & + 274.0, -3.8203074000, 3.3535404000e-3, -5.6992095000e-3, & + 275.0, -3.8250766000, 3.3430061000e-3, -5.6837210000e-3, & + 276.0, -3.8298432000, 3.3325707000e-3, -5.6683633000e-3, & + 277.0, -3.8346070000, 3.3222331000e-3, -5.6531348000e-3, & + 278.0, -3.8393682000, 3.3119922000e-3, -5.6380340000e-3, & + 279.0, -3.8441265000, 3.3018470000e-3, -5.6230593000e-3, & + 280.0, -3.8488821000, 3.2917964000e-3, -5.6082092000e-3, & + 281.0, -3.8536348000, 3.2818393000e-3, -5.5934822000e-3, & + 282.0, -3.8583847000, 3.2719748000e-3, -5.5788767000e-3, & + 283.0, -3.8631317000, 3.2622018000e-3, -5.5643913000e-3, & + 284.0, -3.8678759000, 3.2525193000e-3, -5.5500246000e-3, & + 285.0, -3.8726170000, 3.2429264000e-3, -5.5357752000e-3, & + 286.0, -3.8773553000, 3.2334221000e-3, -5.5216416000e-3, & + 287.0, -3.8820905000, 3.2240054000e-3, -5.5076224000e-3, & + 288.0, -3.8868227000, 3.2146753000e-3, -5.4937164000e-3, & + 289.0, -3.8915519000, 3.2054310000e-3, -5.4799221000e-3, & + 290.0, -3.8962780000, 3.1962715000e-3, -5.4662383000e-3, & + 291.0, -3.9010010000, 3.1871958000e-3, -5.4526635000e-3, & + 292.0, -3.9057209000, 3.1782032000e-3, -5.4391967000e-3, & + 293.0, -3.9104377000, 3.1692926000e-3, -5.4258363000e-3, & + 294.0, -3.9151512000, 3.1604632000e-3, -5.4125813000e-3, & + 295.0, -3.9198616000, 3.1517142000e-3, -5.3994305000e-3, & + 296.0, -3.9245687000, 3.1430446000e-3, -5.3863824000e-3, & + 297.0, -3.9292725000, 3.1344537000e-3, -5.3734361000e-3, & + 298.0, -3.9339731000, 3.1259405000e-3, -5.3605902000e-3, & + 299.0, -3.9386704000, 3.1175043000e-3, -5.3478437000e-3, & + 300.0, -3.9433643000, 3.1091442000e-3, -5.3351954000e-3, & + 301.0, -3.9480548000, 3.1008594000e-3, -5.3226441000e-3, & + 302.0, -3.9527420000, 3.0926491000e-3, -5.3101888000e-3, & + 303.0, -3.9574257000, 3.0845126000e-3, -5.2978283000e-3, & + 304.0, -3.9621060000, 3.0764490000e-3, -5.2855615000e-3, & + 305.0, -3.9667828000, 3.0684575000e-3, -5.2733874000e-3, & + 306.0, -3.9714561000, 3.0605375000e-3, -5.2613050000e-3, & + 307.0, -3.9761259000, 3.0526881000e-3, -5.2493131000e-3, & + 308.0, -3.9807921000, 3.0449085000e-3, -5.2374107000e-3, & + 309.0, -3.9854548000, 3.0371982000e-3, -5.2255969000e-3, & + 310.0, -3.9901138000, 3.0295562000e-3, -5.2138707000e-3, & + 311.0, -3.9947693000, 3.0219820000e-3, -5.2022310000e-3, & + 312.0, -3.9994210000, 3.0144747000e-3, -5.1906768000e-3, & + 313.0, -4.0040691000, 3.0070337000e-3, -5.1792073000e-3, & + 314.0, -4.0087135000, 2.9996584000e-3, -5.1678215000e-3, & + 315.0, -4.0133542000, 2.9923479000e-3, -5.1565183000e-3, & + 316.0, -4.0179911000, 2.9851016000e-3, -5.1452970000e-3, & + 317.0, -4.0226242000, 2.9779189000e-3, -5.1341566000e-3, & + 318.0, -4.0272535000, 2.9707990000e-3, -5.1230962000e-3, & + 319.0, -4.0318790000, 2.9637414000e-3, -5.1121150000e-3, & + 320.0, -4.0365006000, 2.9567453000e-3, -5.1012119000e-3, & + 321.0, -4.0411184000, 2.9498101000e-3, -5.0903863000e-3, & + 322.0, -4.0457322000, 2.9429353000e-3, -5.0796372000e-3, & + 323.0, -4.0503421000, 2.9361201000e-3, -5.0689638000e-3, & + 324.0, -4.0549481000, 2.9293639000e-3, -5.0583652000e-3, & + 325.0, -4.0595501000, 2.9226662000e-3, -5.0478407000e-3, & + 326.0, -4.0641480000, 2.9160263000e-3, -5.0373894000e-3, & + 327.0, -4.0687420000, 2.9094435000e-3, -5.0270106000e-3, & + 328.0, -4.0733319000, 2.9029174000e-3, -5.0167034000e-3, & + 329.0, -4.0779177000, 2.8964474000e-3, -5.0064671000e-3, & + 330.0, -4.0824995000, 2.8900327000e-3, -4.9963009000e-3, & + 331.0, -4.0870771000, 2.8836730000e-3, -4.9862041000e-3, & + 332.0, -4.0916505000, 2.8773676000e-3, -4.9761758000e-3, & + 333.0, -4.0962198000, 2.8711159000e-3, -4.9662155000e-3, & + 334.0, -4.1007850000, 2.8649173000e-3, -4.9563223000e-3, & + 335.0, -4.1053459000, 2.8587715000e-3, -4.9464955000e-3, & + 336.0, -4.1099025000, 2.8526777000e-3, -4.9367344000e-3, & + 337.0, -4.1144549000, 2.8466354000e-3, -4.9270384000e-3, & + 338.0, -4.1190030000, 2.8406442000e-3, -4.9174066000e-3, & + 339.0, -4.1235469000, 2.8347035000e-3, -4.9078386000e-3, & + 340.0, -4.1280863000, 2.8288128000e-3, -4.8983335000e-3, & + 341.0, -4.1326215000, 2.8229715000e-3, -4.8888907000e-3, & + 342.0, -4.1371523000, 2.8171792000e-3, -4.8795095000e-3, & + 343.0, -4.1416786000, 2.8114353000e-3, -4.8701893000e-3, & + 344.0, -4.1462006000, 2.8057394000e-3, -4.8609295000e-3, & + 345.0, -4.1507181000, 2.8000909000e-3, -4.8517295000e-3, & + 346.0, -4.1552312000, 2.7944894000e-3, -4.8425885000e-3, & + 347.0, -4.1597397000, 2.7889344000e-3, -4.8335060000e-3, & + 348.0, -4.1642438000, 2.7834254000e-3, -4.8244814000e-3, & + 349.0, -4.1687434000, 2.7779620000e-3, -4.8155141000e-3, & + 350.0, -4.1732384000, 2.7725436000e-3, -4.8066034000e-3, & + 351.0, -4.1777288000, 2.7671698000e-3, -4.7977488000e-3, & + 352.0, -4.1822147000, 2.7618402000e-3, -4.7889498000e-3, & + 353.0, -4.1866959000, 2.7565543000e-3, -4.7802057000e-3, & + 354.0, -4.1911725000, 2.7513117000e-3, -4.7715160000e-3, & + 355.0, -4.1956445000, 2.7461118000e-3, -4.7628800000e-3, & + 356.0, -4.2001118000, 2.7409544000e-3, -4.7542974000e-3, & + 357.0, -4.2045744000, 2.7358388000e-3, -4.7457675000e-3, & + 358.0, -4.2090323000, 2.7307648000e-3, -4.7372897000e-3, & + 359.0, -4.2134854000, 2.7257319000e-3, -4.7288636000e-3, & + 360.0, -4.2179338000, 2.7207397000e-3, -4.7204886000e-3, & + 361.0, -4.2223775000, 2.7157877000e-3, -4.7121643000e-3, & + 362.0, -4.2268163000, 2.7108756000e-3, -4.7038900000e-3, & + 363.0, -4.2312503000, 2.7060029000e-3, -4.6956653000e-3, & + 364.0, -4.2356795000, 2.7011692000e-3, -4.6874897000e-3, & + 365.0, -4.2401039000, 2.6963742000e-3, -4.6793627000e-3, & + 366.0, -4.2445234000, 2.6916175000e-3, -4.6712838000e-3, & + 367.0, -4.2489380000, 2.6868986000e-3, -4.6632526000e-3, & + 368.0, -4.2533476000, 2.6822172000e-3, -4.6552684000e-3, & + 369.0, -4.2577524000, 2.6775728000e-3, -4.6473310000e-3, & + 370.0, -4.2621522000, 2.6729652000e-3, -4.6394397000e-3, & + 371.0, -4.2665470000, 2.6683940000e-3, -4.6315942000e-3, & + 372.0, -4.2709369000, 2.6638587000e-3, -4.6237940000e-3, & + 373.0, -4.2753218000, 2.6593590000e-3, -4.6160387000e-3, & + 374.0, -4.2797016000, 2.6548946000e-3, -4.6083277000e-3, & + 375.0, -4.2840764000, 2.6504651000e-3, -4.6006607000e-3, & + 376.0, -4.2884462000, 2.6460701000e-3, -4.5930373000e-3, & + 377.0, -4.2928108000, 2.6417093000e-3, -4.5854569000e-3, & + 378.0, -4.2971704000, 2.6373823000e-3, -4.5779192000e-3, & + 379.0, -4.3015249000, 2.6330888000e-3, -4.5704238000e-3, & + 380.0, -4.3058742000, 2.6288285000e-3, -4.5629702000e-3, & + 381.0, -4.3102184000, 2.6246011000e-3, -4.5555581000e-3, & + 382.0, -4.3145575000, 2.6204061000e-3, -4.5481870000e-3, & + 383.0, -4.3188914000, 2.6162432000e-3, -4.5408565000e-3, & + 384.0, -4.3232200000, 2.6121122000e-3, -4.5335663000e-3, & + 385.0, -4.3275435000, 2.6080128000e-3, -4.5263159000e-3, & + 386.0, -4.3318617000, 2.6039445000e-3, -4.5191050000e-3, & + 387.0, -4.3361747000, 2.5999071000e-3, -4.5119331000e-3, & + 388.0, -4.3404824000, 2.5959002000e-3, -4.5048000000e-3, & + 389.0, -4.3447848000, 2.5919236000e-3, -4.4977052000e-3, & + 390.0, -4.3490820000, 2.5879770000e-3, -4.4906484000e-3, & + 391.0, -4.3533738000, 2.5840600000e-3, -4.4836292000e-3, & + 392.0, -4.3576603000, 2.5801724000e-3, -4.4766472000e-3, & + 393.0, -4.3619414000, 2.5763138000e-3, -4.4697021000e-3, & + 394.0, -4.3662172000, 2.5724840000e-3, -4.4627935000e-3, & + 395.0, -4.3704876000, 2.5686827000e-3, -4.4559212000e-3, & + 396.0, -4.3747527000, 2.5649095000e-3, -4.4490846000e-3, & + 397.0, -4.3790123000, 2.5611642000e-3, -4.4422836000e-3, & + 398.0, -4.3832665000, 2.5574466000e-3, -4.4355178000e-3, & + 399.0, -4.3875152000, 2.5537563000e-3, -4.4287868000e-3, & + 400.0, -4.3917586000, 2.5500930000e-3, -4.4220903000e-3, & + 401.0, -4.3959964000, 2.5464565000e-3, -4.4154280000e-3, & + 402.0, -4.4002288000, 2.5428466000e-3, -4.4087995000e-3, & + 403.0, -4.4044556000, 2.5392629000e-3, -4.4022046000e-3, & + 404.0, -4.4086770000, 2.5357051000e-3, -4.3956430000e-3, & + 405.0, -4.4128928000, 2.5321731000e-3, -4.3891142000e-3, & + 406.0, -4.4171031000, 2.5286666000e-3, -4.3826181000e-3, & + 407.0, -4.4213078000, 2.5251852000e-3, -4.3761543000e-3, & + 408.0, -4.4255070000, 2.5217289000e-3, -4.3697225000e-3, & + 409.0, -4.4297006000, 2.5182972000e-3, -4.3633224000e-3, & + 410.0, -4.4338886000, 2.5148899000e-3, -4.3569537000e-3, & + 411.0, -4.4380709000, 2.5115069000e-3, -4.3506162000e-3, & + 412.0, -4.4422477000, 2.5081478000e-3, -4.3443095000e-3, & + 413.0, -4.4464188000, 2.5048125000e-3, -4.3380334000e-3, & + 414.0, -4.4505843000, 2.5015006000e-3, -4.3317876000e-3, & + 415.0, -4.4547441000, 2.4982119000e-3, -4.3255718000e-3, & + 416.0, -4.4588982000, 2.4949463000e-3, -4.3193857000e-3, & + 417.0, -4.4630466000, 2.4917034000e-3, -4.3132290000e-3, & + 418.0, -4.4671894000, 2.4884831000e-3, -4.3071016000e-3, & + 419.0, -4.4713264000, 2.4852851000e-3, -4.3010031000e-3, & + 420.0, -4.4754577000, 2.4821092000e-3, -4.2949332000e-3, & + 421.0, -4.4795832000, 2.4789551000e-3, -4.2888918000e-3, & + 422.0, -4.4837030000, 2.4758227000e-3, -4.2828785000e-3, & + 423.0, -4.4878171000, 2.4727118000e-3, -4.2768931000e-3, & + 424.0, -4.4919253000, 2.4696220000e-3, -4.2709353000e-3, & + 425.0, -4.4960278000, 2.4665532000e-3, -4.2650050000e-3, & + 426.0, -4.5001245000, 2.4635053000e-3, -4.2591017000e-3, & + 427.0, -4.5042153000, 2.4604778000e-3, -4.2532254000e-3, & + 428.0, -4.5083003000, 2.4574708000e-3, -4.2473758000e-3, & + 429.0, -4.5123795000, 2.4544839000e-3, -4.2415526000e-3, & + 430.0, -4.5164529000, 2.4515170000e-3, -4.2357555000e-3, & + 431.0, -4.5205204000, 2.4485699000e-3, -4.2299844000e-3, & + 432.0, -4.5245820000, 2.4456423000e-3, -4.2242391000e-3, & + 433.0, -4.5286377000, 2.4427340000e-3, -4.2185193000e-3, & + 434.0, -4.5326876000, 2.4398450000e-3, -4.2128247000e-3, & + 435.0, -4.5367315000, 2.4369749000e-3, -4.2071552000e-3, & + 436.0, -4.5407695000, 2.4341235000e-3, -4.2015105000e-3, & + 437.0, -4.5448016000, 2.4312908000e-3, -4.1958904000e-3, & + 438.0, -4.5488278000, 2.4284765000e-3, -4.1902947000e-3, & + 439.0, -4.5528480000, 2.4256804000e-3, -4.1847233000e-3, & + 440.0, -4.5568623000, 2.4229023000e-3, -4.1791757000e-3, & + 441.0, -4.5608706000, 2.4201420000e-3, -4.1736520000e-3, & + 442.0, -4.5648729000, 2.4173995000e-3, -4.1681518000e-3, & + 443.0, -4.5688693000, 2.4146744000e-3, -4.1626750000e-3, & + 444.0, -4.5728596000, 2.4119666000e-3, -4.1572213000e-3, & + 445.0, -4.5768440000, 2.4092760000e-3, -4.1517905000e-3, & + 446.0, -4.5808223000, 2.4066023000e-3, -4.1463825000e-3, & + 447.0, -4.5847946000, 2.4039454000e-3, -4.1409971000e-3, & + 448.0, -4.5887608000, 2.4013051000e-3, -4.1356340000e-3, & + 449.0, -4.5927211000, 2.3986813000e-3, -4.1302931000e-3, & + 450.0, -4.5966752000, 2.3960738000e-3, -4.1249742000e-3, & + 451.0, -4.6006234000, 2.3934824000e-3, -4.1196771000e-3, & + 452.0, -4.6045654000, 2.3909070000e-3, -4.1144015000e-3, & + 453.0, -4.6085014000, 2.3883473000e-3, -4.1091474000e-3, & + 454.0, -4.6124313000, 2.3858033000e-3, -4.1039146000e-3, & + 455.0, -4.6163550000, 2.3832748000e-3, -4.0987028000e-3, & + 456.0, -4.6202727000, 2.3807615000e-3, -4.0935118000e-3, & + 457.0, -4.6241843000, 2.3782635000e-3, -4.0883416000e-3, & + 458.0, -4.6280897000, 2.3757804000e-3, -4.0831919000e-3, & + 459.0, -4.6319890000, 2.3733122000e-3, -4.0780626000e-3, & + 460.0, -4.6358822000, 2.3708588000e-3, -4.0729534000e-3, & + 461.0, -4.6397692000, 2.3684198000e-3, -4.0678643000e-3, & + 462.0, -4.6436501000, 2.3659953000e-3, -4.0627950000e-3, & + 463.0, -4.6475249000, 2.3635851000e-3, -4.0577454000e-3, & + 464.0, -4.6513934000, 2.3611889000e-3, -4.0527153000e-3, & + 465.0, -4.6552558000, 2.3588068000e-3, -4.0477046000e-3, & + 466.0, -4.6591120000, 2.3564384000e-3, -4.0427131000e-3, & + 467.0, -4.6629620000, 2.3540838000e-3, -4.0377406000e-3, & + 468.0, -4.6668058000, 2.3517427000e-3, -4.0327870000e-3, & + 469.0, -4.6706434000, 2.3494150000e-3, -4.0278521000e-3, & + 470.0, -4.6744748000, 2.3471006000e-3, -4.0229358000e-3, & + 471.0, -4.6783000000, 2.3447994000e-3, -4.0180379000e-3, & + 472.0, -4.6821189000, 2.3425111000e-3, -4.0131582000e-3, & + 473.0, -4.6859316000, 2.3402357000e-3, -4.0082967000e-3, & + 474.0, -4.6897381000, 2.3379731000e-3, -4.0034532000e-3, & + 475.0, -4.6935383000, 2.3357231000e-3, -3.9986274000e-3, & + 476.0, -4.6973323000, 2.3334855000e-3, -3.9938194000e-3, & + 477.0, -4.7011201000, 2.3312604000e-3, -3.9890289000e-3, & + 478.0, -4.7049015000, 2.3290474000e-3, -3.9842557000e-3, & + 479.0, -4.7086767000, 2.3268466000e-3, -3.9794999000e-3, & + 480.0, -4.7124456000, 2.3246577000e-3, -3.9747611000e-3, & + 481.0, -4.7162083000, 2.3224807000e-3, -3.9700393000e-3, & + 482.0, -4.7199646000, 2.3203154000e-3, -3.9653344000e-3, & + 483.0, -4.7237147000, 2.3181618000e-3, -3.9606461000e-3, & + 484.0, -4.7274585000, 2.3160196000e-3, -3.9559744000e-3, & + 485.0, -4.7311959000, 2.3138889000e-3, -3.9513192000e-3, & + 486.0, -4.7349271000, 2.3117694000e-3, -3.9466802000e-3, & + 487.0, -4.7386519000, 2.3096610000e-3, -3.9420575000e-3, & + 488.0, -4.7423704000, 2.3075637000e-3, -3.9374508000e-3, & + 489.0, -4.7460826000, 2.3054773000e-3, -3.9328600000e-3, & + 490.0, -4.7497885000, 2.3034017000e-3, -3.9282850000e-3, & + 491.0, -4.7534880000, 2.3013368000e-3, -3.9237256000e-3, & + 492.0, -4.7571812000, 2.2992825000e-3, -3.9191818000e-3, & + 493.0, -4.7608681000, 2.2972386000e-3, -3.9146535000e-3, & + 494.0, -4.7645486000, 2.2952052000e-3, -3.9101404000e-3, & + 495.0, -4.7682227000, 2.2931820000e-3, -3.9056425000e-3, & + 496.0, -4.7718905000, 2.2911690000e-3, -3.9011597000e-3, & + 497.0, -4.7755520000, 2.2891660000e-3, -3.8966919000e-3, & + 498.0, -4.7792071000, 2.2871729000e-3, -3.8922389000e-3, & + 499.0, -4.7828558000, 2.2851898000e-3, -3.8878005000e-3, & + 500.0, -4.7864981000, 2.2832163000e-3, -3.8833768000e-3, & + 501.0, -4.7901341000, 2.2812525000e-3, -3.8789676000e-3, & + 502.0, -4.7937636000, 2.2792983000e-3, -3.8745728000e-3, & + 503.0, -4.7973868000, 2.2773535000e-3, -3.8701922000e-3, & + 504.0, -4.8010036000, 2.2754180000e-3, -3.8658258000e-3, & + 505.0, -4.8046141000, 2.2734918000e-3, -3.8614735000e-3, & + 506.0, -4.8082181000, 2.2715748000e-3, -3.8571351000e-3, & + 507.0, -4.8118157000, 2.2696668000e-3, -3.8528105000e-3, & + 508.0, -4.8154069000, 2.2677678000e-3, -3.8484997000e-3, & + 509.0, -4.8189918000, 2.2658777000e-3, -3.8442025000e-3, & + 510.0, -4.8225702000, 2.2639964000e-3, -3.8399188000e-3, & + 511.0, -4.8261422000, 2.2621237000e-3, -3.8356485000e-3, & + 512.0, -4.8297078000, 2.2602597000e-3, -3.8313916000e-3, & + 513.0, -4.8332670000, 2.2584041000e-3, -3.8271479000e-3, & + 514.0, -4.8368197000, 2.2565570000e-3, -3.8229173000e-3, & + 515.0, -4.8403661000, 2.2547183000e-3, -3.8186997000e-3, & + 516.0, -4.8439060000, 2.2528877000e-3, -3.8144951000e-3, & + 517.0, -4.8474395000, 2.2510654000e-3, -3.8103033000e-3, & + 518.0, -4.8509666000, 2.2492511000e-3, -3.8061243000e-3, & + 519.0, -4.8544872000, 2.2474448000e-3, -3.8019578000e-3, & + 520.0, -4.8580014000, 2.2456465000e-3, -3.7978040000e-3, & + 521.0, -4.8615092000, 2.2438560000e-3, -3.7936626000e-3, & + 522.0, -4.8650105000, 2.2420732000e-3, -3.7895335000e-3, & + 523.0, -4.8685054000, 2.2402981000e-3, -3.7854168000e-3, & + 524.0, -4.8719939000, 2.2385305000e-3, -3.7813122000e-3, & + 525.0, -4.8754759000, 2.2367705000e-3, -3.7772197000e-3, & + 526.0, -4.8789515000, 2.2350179000e-3, -3.7731392000e-3, & + 527.0, -4.8824206000, 2.2332727000e-3, -3.7690706000e-3, & + 528.0, -4.8858833000, 2.2315347000e-3, -3.7650139000e-3, & + 529.0, -4.8893395000, 2.2298040000e-3, -3.7609689000e-3, & + 530.0, -4.8927893000, 2.2280804000e-3, -3.7569356000e-3, & + 531.0, -4.8962327000, 2.2263638000e-3, -3.7529139000e-3, & + 532.0, -4.8996696000, 2.2246542000e-3, -3.7489037000e-3, & + 533.0, -4.9031000000, 2.2229515000e-3, -3.7449049000e-3, & + 534.0, -4.9065240000, 2.2212556000e-3, -3.7409174000e-3, & + 535.0, -4.9099415000, 2.2195665000e-3, -3.7369411000e-3, & + 536.0, -4.9133526000, 2.2178841000e-3, -3.7329761000e-3, & + 537.0, -4.9167573000, 2.2162082000e-3, -3.7290221000e-3, & + 538.0, -4.9201554000, 2.2145390000e-3, -3.7250792000e-3, & + 539.0, -4.9235472000, 2.2128762000e-3, -3.7211471000e-3, & + 540.0, -4.9269324000, 2.2112198000e-3, -3.7172260000e-3, & + 541.0, -4.9303112000, 2.2095698000e-3, -3.7133156000e-3, & + 542.0, -4.9336836000, 2.2079261000e-3, -3.7094160000e-3, & + 543.0, -4.9370495000, 2.2062885000e-3, -3.7055269000e-3, & + 544.0, -4.9404089000, 2.2046571000e-3, -3.7016485000e-3, & + 545.0, -4.9437619000, 2.2030318000e-3, -3.6977805000e-3, & + 546.0, -4.9471084000, 2.2014125000e-3, -3.6939229000e-3, & + 547.0, -4.9504485000, 2.1997991000e-3, -3.6900757000e-3, & + 548.0, -4.9537821000, 2.1981917000e-3, -3.6862387000e-3, & + 549.0, -4.9571092000, 2.1965901000e-3, -3.6824120000e-3, & + 550.0, -4.9604299000, 2.1949942000e-3, -3.6785954000e-3, & + 551.0, -4.9637442000, 2.1934040000e-3, -3.6747888000e-3, & + 552.0, -4.9670519000, 2.1918195000e-3, -3.6709922000e-3, & + 553.0, -4.9703533000, 2.1902406000e-3, -3.6672056000e-3, & + 554.0, -4.9736481000, 2.1886671000e-3, -3.6634288000e-3, & + 555.0, -4.9769366000, 2.1870992000e-3, -3.6596618000e-3, & + 556.0, -4.9802185000, 2.1855366000e-3, -3.6559045000e-3, & + 557.0, -4.9834940000, 2.1839795000e-3, -3.6521569000e-3, & + 558.0, -4.9867631000, 2.1824276000e-3, -3.6484189000e-3, & + 559.0, -4.9900257000, 2.1808809000e-3, -3.6446904000e-3, & + 560.0, -4.9932819000, 2.1793394000e-3, -3.6409714000e-3, & + 561.0, -4.9965316000, 2.1778031000e-3, -3.6372617000e-3, & + 562.0, -4.9997749000, 2.1762718000e-3, -3.6335615000e-3, & + 563.0, -5.0030117000, 2.1747455000e-3, -3.6298704000e-3, & + 564.0, -5.0062421000, 2.1732242000e-3, -3.6261887000e-3, & + 565.0, -5.0094660000, 2.1717078000e-3, -3.6225160000e-3, & + 566.0, -5.0126835000, 2.1701963000e-3, -3.6188525000e-3, & + 567.0, -5.0158946000, 2.1686895000e-3, -3.6151980000e-3, & + 568.0, -5.0190992000, 2.1671876000e-3, -3.6115525000e-3, & + 569.0, -5.0222974000, 2.1656903000e-3, -3.6079159000e-3, & + 570.0, -5.0254891000, 2.1641977000e-3, -3.6042882000e-3, & + 571.0, -5.0286744000, 2.1627096000e-3, -3.6006692000e-3, & + 572.0, -5.0318533000, 2.1612262000e-3, -3.5970590000e-3, & + 573.0, -5.0350258000, 2.1597472000e-3, -3.5934575000e-3, & + 574.0, -5.0381918000, 2.1582727000e-3, -3.5898647000e-3, & + 575.0, -5.0413514000, 2.1568026000e-3, -3.5862804000e-3, & + 576.0, -5.0445046000, 2.1553369000e-3, -3.5827047000e-3, & + 577.0, -5.0476514000, 2.1538755000e-3, -3.5791374000e-3, & + 578.0, -5.0507917000, 2.1524183000e-3, -3.5755785000e-3, & + 579.0, -5.0539256000, 2.1509654000e-3, -3.5720280000e-3, & + 580.0, -5.0570532000, 2.1495166000e-3, -3.5684858000e-3, & + 581.0, -5.0601743000, 2.1480720000e-3, -3.5649519000e-3, & + 582.0, -5.0632890000, 2.1466315000e-3, -3.5614262000e-3, & + 583.0, -5.0663973000, 2.1451950000e-3, -3.5579086000e-3, & + 584.0, -5.0694991000, 2.1437625000e-3, -3.5543992000e-3, & + 585.0, -5.0725946000, 2.1423339000e-3, -3.5508978000e-3, & + 586.0, -5.0756837000, 2.1409093000e-3, -3.5474044000e-3, & + 587.0, -5.0787664000, 2.1394885000e-3, -3.5439189000e-3, & + 588.0, -5.0818427000, 2.1380716000e-3, -3.5404414000e-3, & + 589.0, -5.0849126000, 2.1366585000e-3, -3.5369717000e-3, & + 590.0, -5.0879762000, 2.1352491000e-3, -3.5335099000e-3, & + 591.0, -5.0910333000, 2.1338434000e-3, -3.5300557000e-3, & + 592.0, -5.0940841000, 2.1324413000e-3, -3.5266094000e-3, & + 593.0, -5.0971285000, 2.1310429000e-3, -3.5231706000e-3, & + 594.0, -5.1001665000, 2.1296481000e-3, -3.5197395000e-3, & + 595.0, -5.1031982000, 2.1282569000e-3, -3.5163160000e-3, & + 596.0, -5.1062234000, 2.1268691000e-3, -3.5129000000e-3, & + 597.0, -5.1092424000, 2.1254848000e-3, -3.5094915000e-3, & + 598.0, -5.1122549000, 2.1241039000e-3, -3.5060904000e-3, & + 599.0, -5.1152611000, 2.1227265000e-3, -3.5026968000e-3, & + 600.0, -5.1182610000, 2.1213524000e-3, -3.4993105000e-3, & + 601.0, -5.1212545000, 2.1199816000e-3, -3.4959315000e-3, & + 602.0, -5.1242417000, 2.1186141000e-3, -3.4925597000e-3, & + 603.0, -5.1272225000, 2.1172498000e-3, -3.4891952000e-3, & + 604.0, -5.1301970000, 2.1158888000e-3, -3.4858379000e-3, & + 605.0, -5.1331651000, 2.1145309000e-3, -3.4824877000e-3, & + 606.0, -5.1361270000, 2.1131762000e-3, -3.4791445000e-3, & + 607.0, -5.1390825000, 2.1118246000e-3, -3.4758085000e-3, & + 608.0, -5.1420316000, 2.1104761000e-3, -3.4724795000e-3, & + 609.0, -5.1449745000, 2.1091306000e-3, -3.4691574000e-3, & + 610.0, -5.1479111000, 2.1077881000e-3, -3.4658423000e-3, & + 611.0, -5.1508413000, 2.1064486000e-3, -3.4625341000e-3, & + 612.0, -5.1537652000, 2.1051120000e-3, -3.4592327000e-3, & + 613.0, -5.1566829000, 2.1037784000e-3, -3.4559381000e-3, & + 614.0, -5.1595942000, 2.1024476000e-3, -3.4526504000e-3, & + 615.0, -5.1624993000, 2.1011196000e-3, -3.4493693000e-3, & + 616.0, -5.1653981000, 2.0997945000e-3, -3.4460950000e-3, & + 617.0, -5.1682905000, 2.0984722000e-3, -3.4428273000e-3, & + 618.0, -5.1711768000, 2.0971526000e-3, -3.4395663000e-3, & + 619.0, -5.1740567000, 2.0958358000e-3, -3.4363118000e-3, & + 620.0, -5.1769304000, 2.0945216000e-3, -3.4330639000e-3, & + 621.0, -5.1797978000, 2.0932101000e-3, -3.4298226000e-3, & + 622.0, -5.1826589000, 2.0919012000e-3, -3.4265877000e-3, & + 623.0, -5.1855138000, 2.0905950000e-3, -3.4233592000e-3, & + 624.0, -5.1883625000, 2.0892913000e-3, -3.4201372000e-3, & + 625.0, -5.1912049000, 2.0879902000e-3, -3.4169215000e-3, & + 626.0, -5.1940410000, 2.0866915000e-3, -3.4137122000e-3, & + 627.0, -5.1968710000, 2.0853954000e-3, -3.4105092000e-3, & + 628.0, -5.1996947000, 2.0841018000e-3, -3.4073124000e-3, & + 629.0, -5.2025121000, 2.0828105000e-3, -3.4041219000e-3, & + 630.0, -5.2053234000, 2.0815217000e-3, -3.4009376000e-3, & + 631.0, -5.2081285000, 2.0802353000e-3, -3.3977595000e-3, & + 632.0, -5.2109273000, 2.0789512000e-3, -3.3945875000e-3, & + 633.0, -5.2137199000, 2.0776695000e-3, -3.3914216000e-3, & + 634.0, -5.2165064000, 2.0763900000e-3, -3.3882618000e-3, & + 635.0, -5.2192866000, 2.0751129000e-3, -3.3851080000e-3, & + 636.0, -5.2220607000, 2.0738380000e-3, -3.3819602000e-3, & + 637.0, -5.2248286000, 2.0725653000e-3, -3.3788184000e-3, & + 638.0, -5.2275903000, 2.0712949000e-3, -3.3756826000e-3, & + 639.0, -5.2303458000, 2.0700266000e-3, -3.3725527000e-3, & + 640.0, -5.2330952000, 2.0687604000e-3, -3.3694286000e-3, & + 641.0, -5.2358384000, 2.0674964000e-3, -3.3663104000e-3, & + 642.0, -5.2385755000, 2.0662346000e-3, -3.3631981000e-3, & + 643.0, -5.2413064000, 2.0649747000e-3, -3.3600915000e-3, & + 644.0, -5.2440312000, 2.0637170000e-3, -3.3569907000e-3, & + 645.0, -5.2467498000, 2.0624613000e-3, -3.3538957000e-3, & + 646.0, -5.2494624000, 2.0612076000e-3, -3.3508063000e-3, & + 647.0, -5.2521688000, 2.0599559000e-3, -3.3477227000e-3, & + 648.0, -5.2548690000, 2.0587062000e-3, -3.3446446000e-3, & + 649.0, -5.2575632000, 2.0574585000e-3, -3.3415722000e-3, & + 650.0, -5.2602513000, 2.0562126000e-3, -3.3385054000e-3, & + 651.0, -5.2629332000, 2.0549687000e-3, -3.3354442000e-3, & + 652.0, -5.2656091000, 2.0537266000e-3, -3.3323885000e-3, & + 653.0, -5.2682789000, 2.0524865000e-3, -3.3293383000e-3, & + 654.0, -5.2709426000, 2.0512481000e-3, -3.3262936000e-3, & + 655.0, -5.2736002000, 2.0500116000e-3, -3.3232543000e-3, & + 656.0, -5.2762518000, 2.0487769000e-3, -3.3202205000e-3, & + 657.0, -5.2788973000, 2.0475440000e-3, -3.3171921000e-3, & + 658.0, -5.2815367000, 2.0463128000e-3, -3.3141691000e-3, & + 659.0, -5.2841701000, 2.0450834000e-3, -3.3111514000e-3, & + 660.0, -5.2867975000, 2.0438557000e-3, -3.3081390000e-3, & + 661.0, -5.2894188000, 2.0426297000e-3, -3.3051319000e-3, & + 662.0, -5.2920341000, 2.0414054000e-3, -3.3021302000e-3, & + 663.0, -5.2946433000, 2.0401828000e-3, -3.2991336000e-3, & + 664.0, -5.2972466000, 2.0389618000e-3, -3.2961423000e-3, & + 665.0, -5.2998438000, 2.0377425000e-3, -3.2931562000e-3, & + 666.0, -5.3024350000, 2.0365247000e-3, -3.2901753000e-3, & + 667.0, -5.3050203000, 2.0353086000e-3, -3.2871995000e-3, & + 668.0, -5.3075995000, 2.0340940000e-3, -3.2842288000e-3, & + 669.0, -5.3101728000, 2.0328810000e-3, -3.2812633000e-3, & + 670.0, -5.3127401000, 2.0316695000e-3, -3.2783028000e-3, & + 671.0, -5.3153014000, 2.0304596000e-3, -3.2753474000e-3, & + 672.0, -5.3178568000, 2.0292512000e-3, -3.2723970000e-3, & + 673.0, -5.3204062000, 2.0280443000e-3, -3.2694517000e-3, & + 674.0, -5.3229496000, 2.0268388000e-3, -3.2665113000e-3, & + 675.0, -5.3254871000, 2.0256348000e-3, -3.2635759000e-3, & + 676.0, -5.3280187000, 2.0244322000e-3, -3.2606454000e-3, & + 677.0, -5.3305444000, 2.0232311000e-3, -3.2577199000e-3, & + 678.0, -5.3330641000, 2.0220314000e-3, -3.2547992000e-3, & + 679.0, -5.3355779000, 2.0208331000e-3, -3.2518834000e-3, & + 680.0, -5.3380858000, 2.0196361000e-3, -3.2489725000e-3, & + 681.0, -5.3405878000, 2.0184406000e-3, -3.2460664000e-3, & + 682.0, -5.3430840000, 2.0172463000e-3, -3.2431652000e-3, & + 683.0, -5.3455742000, 2.0160534000e-3, -3.2402687000e-3, & + 684.0, -5.3480585000, 2.0148619000e-3, -3.2373770000e-3, & + 685.0, -5.3505370000, 2.0136716000e-3, -3.2344900000e-3, & + 686.0, -5.3530097000, 2.0124826000e-3, -3.2316078000e-3, & + 687.0, -5.3554764000, 2.0112949000e-3, -3.2287303000e-3, & + 688.0, -5.3579373000, 2.0101085000e-3, -3.2258574000e-3, & + 689.0, -5.3603924000, 2.0089233000e-3, -3.2229893000e-3, & + 690.0, -5.3628417000, 2.0077394000e-3, -3.2201258000e-3, & + 691.0, -5.3652851000, 2.0065567000e-3, -3.2172669000e-3, & + 692.0, -5.3677227000, 2.0053752000e-3, -3.2144126000e-3, & + 693.0, -5.3701545000, 2.0041948000e-3, -3.2115629000e-3, & + 694.0, -5.3725805000, 2.0030157000e-3, -3.2087178000e-3, & + 695.0, -5.3750006000, 2.0018377000e-3, -3.2058772000e-3, & + 696.0, -5.3774150000, 2.0006609000e-3, -3.2030412000e-3, & + 697.0, -5.3798237000, 1.9994853000e-3, -3.2002097000e-3, & + 698.0, -5.3822265000, 1.9983108000e-3, -3.1973826000e-3, & + 699.0, -5.3846236000, 1.9971373000e-3, -3.1945601000e-3, & + 700.0, -5.3870149000, 1.9959650000e-3, -3.1917420000e-3, & + 701.0, -5.3894005000, 1.9947938000e-3, -3.1889283000e-3, & + 702.0, -5.3917803000, 1.9936237000e-3, -3.1861191000e-3, & + 703.0, -5.3941544000, 1.9924547000e-3, -3.1833143000e-3, & + 704.0, -5.3965228000, 1.9912867000e-3, -3.1805139000e-3, & + 705.0, -5.3988854000, 1.9901198000e-3, -3.1777178000e-3, & + 706.0, -5.4012423000, 1.9889539000e-3, -3.1749261000e-3, & + 707.0, -5.4035936000, 1.9877890000e-3, -3.1721387000e-3, & + 708.0, -5.4059391000, 1.9866252000e-3, -3.1693556000e-3, & + 709.0, -5.4082790000, 1.9854623000e-3, -3.1665769000e-3, & + 710.0, -5.4106131000, 1.9843005000e-3, -3.1638024000e-3, & + 711.0, -5.4129416000, 1.9831396000e-3, -3.1610322000e-3, & + 712.0, -5.4152645000, 1.9819797000e-3, -3.1582662000e-3, & + 713.0, -5.4175816000, 1.9808208000e-3, -3.1555045000e-3, & + 714.0, -5.4198932000, 1.9796628000e-3, -3.1527469000e-3, & + 715.0, -5.4221991000, 1.9785058000e-3, -3.1499936000e-3, & + 716.0, -5.4244993000, 1.9773497000e-3, -3.1472445000e-3, & + 717.0, -5.4267939000, 1.9761945000e-3, -3.1444995000e-3, & + 718.0, -5.4290830000, 1.9750402000e-3, -3.1417587000e-3, & + 719.0, -5.4313664000, 1.9738869000e-3, -3.1390221000e-3, & + 720.0, -5.4336442000, 1.9727344000e-3, -3.1362895000e-3, & + 721.0, -5.4359164000, 1.9715828000e-3, -3.1335611000e-3, & + 722.0, -5.4381830000, 1.9704321000e-3, -3.1308367000e-3, & + 723.0, -5.4404441000, 1.9692823000e-3, -3.1281164000e-3, & + 724.0, -5.4426996000, 1.9681333000e-3, -3.1254002000e-3, & + 725.0, -5.4449495000, 1.9669852000e-3, -3.1226881000e-3, & + 726.0, -5.4471939000, 1.9658379000e-3, -3.1199799000e-3, & + 727.0, -5.4494328000, 1.9646915000e-3, -3.1172758000e-3, & + 728.0, -5.4516661000, 1.9635458000e-3, -3.1145757000e-3, & + 729.0, -5.4538938000, 1.9624010000e-3, -3.1118796000e-3, & + 730.0, -5.4561161000, 1.9612570000e-3, -3.1091874000e-3, & + 731.0, -5.4583329000, 1.9601138000e-3, -3.1064992000e-3, & + 732.0, -5.4605441000, 1.9589714000e-3, -3.1038149000e-3, & + 733.0, -5.4627499000, 1.9578298000e-3, -3.1011346000e-3, & + 734.0, -5.4649502000, 1.9566889000e-3, -3.0984582000e-3, & + 735.0, -5.4671450000, 1.9555488000e-3, -3.0957857000e-3, & + 736.0, -5.4693343000, 1.9544095000e-3, -3.0931171000e-3, & + 737.0, -5.4715182000, 1.9532709000e-3, -3.0904524000e-3, & + 738.0, -5.4736966000, 1.9521331000e-3, -3.0877915000e-3, & + 739.0, -5.4758696000, 1.9509960000e-3, -3.0851345000e-3, & + 740.0, -5.4780372000, 1.9498596000e-3, -3.0824813000e-3, & + 741.0, -5.4801993000, 1.9487240000e-3, -3.0798319000e-3, & + 742.0, -5.4823560000, 1.9475891000e-3, -3.0771864000e-3, & + 743.0, -5.4845073000, 1.9464549000e-3, -3.0745446000e-3, & + 744.0, -5.4866533000, 1.9453214000e-3, -3.0719066000e-3, & + 745.0, -5.4887938000, 1.9441885000e-3, -3.0692724000e-3, & + 746.0, -5.4909289000, 1.9430564000e-3, -3.0666420000e-3, & + 747.0, -5.4930587000, 1.9419250000e-3, -3.0640153000e-3, & + 748.0, -5.4951831000, 1.9407942000e-3, -3.0613923000e-3, & + 749.0, -5.4973021000, 1.9396641000e-3, -3.0587731000e-3, & + 750.0, -5.4994158000, 1.9385347000e-3, -3.0561575000e-3, & + 751.0, -5.5015242000, 1.9374059000e-3, -3.0535457000e-3, & + 752.0, -5.5036272000, 1.9362778000e-3, -3.0509375000e-3, & + 753.0, -5.5057250000, 1.9351503000e-3, -3.0483331000e-3, & + 754.0, -5.5078174000, 1.9340235000e-3, -3.0457322000e-3, & + 755.0, -5.5099044000, 1.9328973000e-3, -3.0431351000e-3, & + 756.0, -5.5119863000, 1.9317717000e-3, -3.0405415000e-3, & + 757.0, -5.5140628000, 1.9306468000e-3, -3.0379516000e-3, & + 758.0, -5.5161340000, 1.9295224000e-3, -3.0353653000e-3, & + 759.0, -5.5182000000, 1.9283987000e-3, -3.0327826000e-3, & + 760.0, -5.5202607000, 1.9272756000e-3, -3.0302035000e-3, & + 761.0, -5.5223161000, 1.9261531000e-3, -3.0276280000e-3, & + 762.0, -5.5243664000, 1.9250311000e-3, -3.0250561000e-3, & + 763.0, -5.5264113000, 1.9239098000e-3, -3.0224877000e-3, & + 764.0, -5.5284511000, 1.9227890000e-3, -3.0199228000e-3, & + 765.0, -5.5304856000, 1.9216689000e-3, -3.0173615000e-3, & + 766.0, -5.5325150000, 1.9205493000e-3, -3.0148038000e-3, & + 767.0, -5.5345391000, 1.9194303000e-3, -3.0122495000e-3, & + 768.0, -5.5365581000, 1.9183118000e-3, -3.0096987000e-3, & + 769.0, -5.5385718000, 1.9171939000e-3, -3.0071515000e-3, & + 770.0, -5.5405804000, 1.9160766000e-3, -3.0046077000e-3, & + 771.0, -5.5425839000, 1.9149598000e-3, -3.0020674000e-3, & + 772.0, -5.5445822000, 1.9138435000e-3, -2.9995305000e-3, & + 773.0, -5.5465753000, 1.9127278000e-3, -2.9969971000e-3, & + 774.0, -5.5485633000, 1.9116127000e-3, -2.9944671000e-3, & + 775.0, -5.5505462000, 1.9104981000e-3, -2.9919406000e-3, & + 776.0, -5.5525239000, 1.9093840000e-3, -2.9894175000e-3, & + 777.0, -5.5544966000, 1.9082704000e-3, -2.9868978000e-3, & + 778.0, -5.5564641000, 1.9071573000e-3, -2.9843815000e-3, & + 779.0, -5.5584266000, 1.9060448000e-3, -2.9818686000e-3, & + 780.0, -5.5603840000, 1.9049328000e-3, -2.9793591000e-3, & + 781.0, -5.5623363000, 1.9038213000e-3, -2.9768530000e-3, & + 782.0, -5.5642835000, 1.9027103000e-3, -2.9743502000e-3, & + 783.0, -5.5662257000, 1.9015998000e-3, -2.9718507000e-3, & + 784.0, -5.5681628000, 1.9004898000e-3, -2.9693547000e-3, & + 785.0, -5.5700949000, 1.8993803000e-3, -2.9668619000e-3, & + 786.0, -5.5720220000, 1.8982713000e-3, -2.9643725000e-3, & + 787.0, -5.5739440000, 1.8971627000e-3, -2.9618864000e-3, & + 788.0, -5.5758611000, 1.8960547000e-3, -2.9594036000e-3, & + 789.0, -5.5777731000, 1.8949471000e-3, -2.9569240000e-3, & + 790.0, -5.5796802000, 1.8938401000e-3, -2.9544478000e-3, & + 791.0, -5.5815822000, 1.8927334000e-3, -2.9519749000e-3, & + 792.0, -5.5834793000, 1.8916273000e-3, -2.9495052000e-3, & + 793.0, -5.5853715000, 1.8905216000e-3, -2.9470388000e-3, & + 794.0, -5.5872586000, 1.8894164000e-3, -2.9445756000e-3, & + 795.0, -5.5891409000, 1.8883117000e-3, -2.9421157000e-3, & + 796.0, -5.5910182000, 1.8872074000e-3, -2.9396591000e-3, & + 797.0, -5.5928905000, 1.8861036000e-3, -2.9372056000e-3, & + 798.0, -5.5947580000, 1.8850002000e-3, -2.9347554000e-3, & + 799.0, -5.5966205000, 1.8838973000e-3, -2.9323083000e-3, & + 800.0, -5.5984781000, 1.8827948000e-3, -2.9298645000e-3, & + 801.0, -5.6003309000, 1.8816928000e-3, -2.9274239000e-3, & + 802.0, -5.6021787000, 1.8805912000e-3, -2.9249864000e-3, & + 803.0, -5.6040217000, 1.8794901000e-3, -2.9225522000e-3, & + 804.0, -5.6058598000, 1.8783894000e-3, -2.9201211000e-3, & + 805.0, -5.6076931000, 1.8772891000e-3, -2.9176931000e-3, & + 806.0, -5.6095215000, 1.8761892000e-3, -2.9152683000e-3, & + 807.0, -5.6113451000, 1.8750898000e-3, -2.9128467000e-3, & + 808.0, -5.6131638000, 1.8739909000e-3, -2.9104282000e-3, & + 809.0, -5.6149777000, 1.8728923000e-3, -2.9080128000e-3, & + 810.0, -5.6167869000, 1.8717942000e-3, -2.9056005000e-3, & + 811.0, -5.6185912000, 1.8706965000e-3, -2.9031914000e-3, & + 812.0, -5.6203907000, 1.8695992000e-3, -2.9007853000e-3, & + 813.0, -5.6221855000, 1.8685023000e-3, -2.8983824000e-3, & + 814.0, -5.6239754000, 1.8674058000e-3, -2.8959825000e-3, & + 815.0, -5.6257606000, 1.8663098000e-3, -2.8935857000e-3, & + 816.0, -5.6275411000, 1.8652141000e-3, -2.8911920000e-3, & + 817.0, -5.6293168000, 1.8641189000e-3, -2.8888014000e-3, & + 818.0, -5.6310878000, 1.8630241000e-3, -2.8864138000e-3, & + 819.0, -5.6328540000, 1.8619297000e-3, -2.8840292000e-3, & + 820.0, -5.6346155000, 1.8608357000e-3, -2.8816477000e-3, & + 821.0, -5.6363723000, 1.8597420000e-3, -2.8792693000e-3, & + 822.0, -5.6381245000, 1.8586488000e-3, -2.8768939000e-3, & + 823.0, -5.6398719000, 1.8575560000e-3, -2.8745215000e-3, & + 824.0, -5.6416146000, 1.8564636000e-3, -2.8721521000e-3, & + 825.0, -5.6433527000, 1.8553716000e-3, -2.8697857000e-3, & + 826.0, -5.6450861000, 1.8542799000e-3, -2.8674223000e-3, & + 827.0, -5.6468149000, 1.8531887000e-3, -2.8650619000e-3, & + 828.0, -5.6485390000, 1.8520979000e-3, -2.8627045000e-3, & + 829.0, -5.6502584000, 1.8510074000e-3, -2.8603501000e-3, & + 830.0, -5.6519733000, 1.8499173000e-3, -2.8579986000e-3, & + 831.0, -5.6536835000, 1.8488276000e-3, -2.8556502000e-3, & + 832.0, -5.6553891000, 1.8477384000e-3, -2.8533046000e-3, & + 833.0, -5.6570901000, 1.8466494000e-3, -2.8509621000e-3, & + 834.0, -5.6587866000, 1.8455609000e-3, -2.8486224000e-3, & + 835.0, -5.6604784000, 1.8444728000e-3, -2.8462858000e-3, & + 836.0, -5.6621657000, 1.8433850000e-3, -2.8439520000e-3, & + 837.0, -5.6638484000, 1.8422976000e-3, -2.8416212000e-3, & + 838.0, -5.6655266000, 1.8412106000e-3, -2.8392933000e-3, & + 839.0, -5.6672002000, 1.8401239000e-3, -2.8369683000e-3, & + 840.0, -5.6688693000, 1.8390377000e-3, -2.8346462000e-3, & + 841.0, -5.6705338000, 1.8379518000e-3, -2.8323270000e-3, & + 842.0, -5.6721939000, 1.8368663000e-3, -2.8300107000e-3, & + 843.0, -5.6738494000, 1.8357811000e-3, -2.8276973000e-3, & + 844.0, -5.6755004000, 1.8346964000e-3, -2.8253867000e-3, & + 845.0, -5.6771470000, 1.8336120000e-3, -2.8230791000e-3, & + 846.0, -5.6787890000, 1.8325279000e-3, -2.8207743000e-3, & + 847.0, -5.6804266000, 1.8314443000e-3, -2.8184724000e-3, & + 848.0, -5.6820597000, 1.8303610000e-3, -2.8161733000e-3, & + 849.0, -5.6836884000, 1.8292781000e-3, -2.8138771000e-3, & + 850.0, -5.6853127000, 1.8281955000e-3, -2.8115837000e-3, & + 851.0, -5.6869325000, 1.8271133000e-3, -2.8092932000e-3, & + 852.0, -5.6885478000, 1.8260315000e-3, -2.8070055000e-3, & + 853.0, -5.6901588000, 1.8249501000e-3, -2.8047206000e-3, & + 854.0, -5.6917653000, 1.8238690000e-3, -2.8024385000e-3, & + 855.0, -5.6933675000, 1.8227882000e-3, -2.8001593000e-3, & + 856.0, -5.6949653000, 1.8217079000e-3, -2.7978829000e-3, & + 857.0, -5.6965586000, 1.8206279000e-3, -2.7956092000e-3, & + 858.0, -5.6981477000, 1.8195482000e-3, -2.7933384000e-3, & + 859.0, -5.6997323000, 1.8184690000e-3, -2.7910703000e-3, & + 860.0, -5.7013126000, 1.8173900000e-3, -2.7888051000e-3, & + 861.0, -5.7028886000, 1.8163115000e-3, -2.7865426000e-3, & + 862.0, -5.7044602000, 1.8152333000e-3, -2.7842829000e-3, & + 863.0, -5.7060275000, 1.8141555000e-3, -2.7820260000e-3, & + 864.0, -5.7075905000, 1.8130780000e-3, -2.7797718000e-3, & + 865.0, -5.7091492000, 1.8120009000e-3, -2.7775204000e-3, & + 866.0, -5.7107035000, 1.8109241000e-3, -2.7752717000e-3, & + 867.0, -5.7122536000, 1.8098477000e-3, -2.7730258000e-3, & + 868.0, -5.7137995000, 1.8087717000e-3, -2.7707826000e-3, & + 869.0, -5.7153410000, 1.8076960000e-3, -2.7685421000e-3, & + 870.0, -5.7168783000, 1.8066207000e-3, -2.7663044000e-3, & + 871.0, -5.7184113000, 1.8055458000e-3, -2.7640694000e-3, & + 872.0, -5.7199401000, 1.8044712000e-3, -2.7618372000e-3, & + 873.0, -5.7214646000, 1.8033969000e-3, -2.7596076000e-3, & + 874.0, -5.7229850000, 1.8023230000e-3, -2.7573808000e-3, & + 875.0, -5.7245011000, 1.8012495000e-3, -2.7551566000e-3, & + 876.0, -5.7260130000, 1.8001763000e-3, -2.7529352000e-3, & + 877.0, -5.7275207000, 1.7991035000e-3, -2.7507164000e-3, & + 878.0, -5.7290242000, 1.7980311000e-3, -2.7485003000e-3, & + 879.0, -5.7305236000, 1.7969590000e-3, -2.7462870000e-3, & + 880.0, -5.7320187000, 1.7958873000e-3, -2.7440763000e-3, & + 881.0, -5.7335097000, 1.7948159000e-3, -2.7418682000e-3, & + 882.0, -5.7349966000, 1.7937449000e-3, -2.7396629000e-3, & + 883.0, -5.7364793000, 1.7926742000e-3, -2.7374601000e-3, & + 884.0, -5.7379579000, 1.7916039000e-3, -2.7352601000e-3, & + 885.0, -5.7394323000, 1.7905340000e-3, -2.7330627000e-3, & + 886.0, -5.7409027000, 1.7894644000e-3, -2.7308680000e-3, & + 887.0, -5.7423689000, 1.7883951000e-3, -2.7286759000e-3, & + 888.0, -5.7438310000, 1.7873263000e-3, -2.7264864000e-3, & + 889.0, -5.7452891000, 1.7862578000e-3, -2.7242996000e-3, & + 890.0, -5.7467430000, 1.7851896000e-3, -2.7221154000e-3, & + 891.0, -5.7481929000, 1.7841218000e-3, -2.7199338000e-3, & + 892.0, -5.7496387000, 1.7830544000e-3, -2.7177548000e-3, & + 893.0, -5.7510805000, 1.7819873000e-3, -2.7155785000e-3, & + 894.0, -5.7525182000, 1.7809206000e-3, -2.7134047000e-3, & + 895.0, -5.7539519000, 1.7798543000e-3, -2.7112336000e-3, & + 896.0, -5.7553816000, 1.7787883000e-3, -2.7090651000e-3, & + 897.0, -5.7568072000, 1.7777227000e-3, -2.7068991000e-3, & + 898.0, -5.7582289000, 1.7766574000e-3, -2.7047358000e-3, & + 899.0, -5.7596465000, 1.7755925000e-3, -2.7025750000e-3, & + 900.0, -5.7610602000, 1.7745280000e-3, -2.7004169000e-3, & + 901.0, -5.7624698000, 1.7734638000e-3, -2.6982613000e-3, & + 902.0, -5.7638755000, 1.7724000000e-3, -2.6961082000e-3, & + 903.0, -5.7652772000, 1.7713365000e-3, -2.6939578000e-3, & + 904.0, -5.7666750000, 1.7702734000e-3, -2.6918099000e-3, & + 905.0, -5.7680688000, 1.7692107000e-3, -2.6896645000e-3, & + 906.0, -5.7694587000, 1.7681484000e-3, -2.6875218000e-3, & + 907.0, -5.7708447000, 1.7670864000e-3, -2.6853815000e-3, & + 908.0, -5.7722267000, 1.7660247000e-3, -2.6832438000e-3, & + 909.0, -5.7736048000, 1.7649635000e-3, -2.6811087000e-3, & + 910.0, -5.7749791000, 1.7639026000e-3, -2.6789761000e-3, & + 911.0, -5.7763494000, 1.7628421000e-3, -2.6768460000e-3, & + 912.0, -5.7777158000, 1.7617819000e-3, -2.6747185000e-3, & + 913.0, -5.7790784000, 1.7607221000e-3, -2.6725934000e-3, & + 914.0, -5.7804371000, 1.7596627000e-3, -2.6704709000e-3, & + 915.0, -5.7817919000, 1.7586037000e-3, -2.6683510000e-3, & + 916.0, -5.7831429000, 1.7575450000e-3, -2.6662335000e-3, & + 917.0, -5.7844901000, 1.7564867000e-3, -2.6641185000e-3, & + 918.0, -5.7858334000, 1.7554288000e-3, -2.6620060000e-3, & + 919.0, -5.7871729000, 1.7543712000e-3, -2.6598961000e-3, & + 920.0, -5.7885086000, 1.7533140000e-3, -2.6577886000e-3, & + 921.0, -5.7898405000, 1.7522572000e-3, -2.6556836000e-3, & + 922.0, -5.7911686000, 1.7512008000e-3, -2.6535811000e-3, & + 923.0, -5.7924928000, 1.7501447000e-3, -2.6514811000e-3, & + 924.0, -5.7938134000, 1.7490890000e-3, -2.6493836000e-3, & + 925.0, -5.7951301000, 1.7480337000e-3, -2.6472885000e-3, & + 926.0, -5.7964431000, 1.7469788000e-3, -2.6451960000e-3, & + 927.0, -5.7977523000, 1.7459242000e-3, -2.6431058000e-3, & + 928.0, -5.7990578000, 1.7448700000e-3, -2.6410182000e-3, & + 929.0, -5.8003595000, 1.7438162000e-3, -2.6389330000e-3, & + 930.0, -5.8016575000, 1.7427628000e-3, -2.6368502000e-3, & + 931.0, -5.8029518000, 1.7417098000e-3, -2.6347699000e-3, & + 932.0, -5.8042424000, 1.7406571000e-3, -2.6326921000e-3, & + 933.0, -5.8055293000, 1.7396049000e-3, -2.6306167000e-3, & + 934.0, -5.8068125000, 1.7385530000e-3, -2.6285437000e-3, & + 935.0, -5.8080920000, 1.7375015000e-3, -2.6264732000e-3, & + 936.0, -5.8093679000, 1.7364504000e-3, -2.6244051000e-3, & + 937.0, -5.8106400000, 1.7353996000e-3, -2.6223394000e-3, & + 938.0, -5.8119085000, 1.7343493000e-3, -2.6202762000e-3, & + 939.0, -5.8131734000, 1.7332993000e-3, -2.6182153000e-3, & + 940.0, -5.8144346000, 1.7322497000e-3, -2.6161569000e-3, & + 941.0, -5.8156922000, 1.7312006000e-3, -2.6141009000e-3, & + 942.0, -5.8169461000, 1.7301518000e-3, -2.6120473000e-3, & + 943.0, -5.8181965000, 1.7291034000e-3, -2.6099961000e-3, & + 944.0, -5.8194432000, 1.7280553000e-3, -2.6079473000e-3, & + 945.0, -5.8206864000, 1.7270077000e-3, -2.6059010000e-3, & + 946.0, -5.8219259000, 1.7259605000e-3, -2.6038570000e-3, & + 947.0, -5.8231619000, 1.7249137000e-3, -2.6018154000e-3, & + 948.0, -5.8243943000, 1.7238672000e-3, -2.5997761000e-3, & + 949.0, -5.8256231000, 1.7228212000e-3, -2.5977393000e-3, & + 950.0, -5.8268484000, 1.7217755000e-3, -2.5957048000e-3, & + 951.0, -5.8280701000, 1.7207303000e-3, -2.5936728000e-3, & + 952.0, -5.8292883000, 1.7196854000e-3, -2.5916430000e-3, & + 953.0, -5.8305029000, 1.7186410000e-3, -2.5896157000e-3, & + 954.0, -5.8317141000, 1.7175970000e-3, -2.5875907000e-3, & + 955.0, -5.8329217000, 1.7165533000e-3, -2.5855681000e-3, & + 956.0, -5.8341258000, 1.7155101000e-3, -2.5835478000e-3, & + 957.0, -5.8353264000, 1.7144672000e-3, -2.5815299000e-3, & + 958.0, -5.8365235000, 1.7134248000e-3, -2.5795144000e-3, & + 959.0, -5.8377172000, 1.7123828000e-3, -2.5775012000e-3, & + 960.0, -5.8389074000, 1.7113411000e-3, -2.5754903000e-3, & + 961.0, -5.8400941000, 1.7102999000e-3, -2.5734818000e-3, & + 962.0, -5.8412773000, 1.7092591000e-3, -2.5714756000e-3, & + 963.0, -5.8424571000, 1.7082187000e-3, -2.5694717000e-3, & + 964.0, -5.8436335000, 1.7071787000e-3, -2.5674702000e-3, & + 965.0, -5.8448065000, 1.7061391000e-3, -2.5654710000e-3, & + 966.0, -5.8459760000, 1.7051000000e-3, -2.5634741000e-3, & + 967.0, -5.8471421000, 1.7040612000e-3, -2.5614796000e-3, & + 968.0, -5.8483048000, 1.7030229000e-3, -2.5594873000e-3, & + 969.0, -5.8494641000, 1.7019850000e-3, -2.5574974000e-3, & + 970.0, -5.8506200000, 1.7009475000e-3, -2.5555098000e-3, & + 971.0, -5.8517725000, 1.6999104000e-3, -2.5535245000e-3, & + 972.0, -5.8529217000, 1.6988737000e-3, -2.5515415000e-3, & + 973.0, -5.8540675000, 1.6978374000e-3, -2.5495608000e-3, & + 974.0, -5.8552099000, 1.6968016000e-3, -2.5475824000e-3, & + 975.0, -5.8563490000, 1.6957662000e-3, -2.5456062000e-3, & + 976.0, -5.8574847000, 1.6947312000e-3, -2.5436324000e-3, & + 977.0, -5.8586172000, 1.6936966000e-3, -2.5416609000e-3, & + 978.0, -5.8597463000, 1.6926625000e-3, -2.5396916000e-3, & + 979.0, -5.8608720000, 1.6916288000e-3, -2.5377246000e-3, & + 980.0, -5.8619945000, 1.6905955000e-3, -2.5357599000e-3, & + 981.0, -5.8631137000, 1.6895626000e-3, -2.5337975000e-3, & + 982.0, -5.8642296000, 1.6885302000e-3, -2.5318373000e-3, & + 983.0, -5.8653422000, 1.6874982000e-3, -2.5298794000e-3, & + 984.0, -5.8664515000, 1.6864666000e-3, -2.5279238000e-3, & + 985.0, -5.8675576000, 1.6854355000e-3, -2.5259704000e-3, & + 986.0, -5.8686604000, 1.6844048000e-3, -2.5240193000e-3, & + 987.0, -5.8697599000, 1.6833745000e-3, -2.5220704000e-3, & + 988.0, -5.8708562000, 1.6823447000e-3, -2.5201238000e-3, & + 989.0, -5.8719493000, 1.6813153000e-3, -2.5181795000e-3, & + 990.0, -5.8730391000, 1.6802863000e-3, -2.5162374000e-3, & + 991.0, -5.8741258000, 1.6792578000e-3, -2.5142975000e-3, & + 992.0, -5.8752092000, 1.6782297000e-3, -2.5123598000e-3, & + 993.0, -5.8762894000, 1.6772020000e-3, -2.5104244000e-3, & + 994.0, -5.8773664000, 1.6761748000e-3, -2.5084913000e-3, & + 995.0, -5.8784403000, 1.6751480000e-3, -2.5065603000e-3, & + 996.0, -5.8795109000, 1.6741217000e-3, -2.5046316000e-3, & + 997.0, -5.8805784000, 1.6730958000e-3, -2.5027051000e-3, & + 998.0, -5.8816427000, 1.6720704000e-3, -2.5007809000e-3, & + 999.0, -5.8827039000, 1.6710454000e-3, -2.4988588000e-3, & + 1000.0, -5.8837619000, 1.6700209000e-3, -2.4969390000e-3, & + 1001.0, -5.8848168000, 1.6689968000e-3, -2.4950213000e-3, & + 1002.0, -5.8858686000, 1.6679732000e-3, -2.4931059000e-3, & + 1003.0, -5.8869172000, 1.6669500000e-3, -2.4911927000e-3, & + 1004.0, -5.8879627000, 1.6659272000e-3, -2.4892817000e-3, & + 1005.0, -5.8890051000, 1.6649049000e-3, -2.4873729000e-3, & + 1006.0, -5.8900444000, 1.6638831000e-3, -2.4854663000e-3, & + 1007.0, -5.8910807000, 1.6628617000e-3, -2.4835619000e-3, & + 1008.0, -5.8921138000, 1.6618408000e-3, -2.4816596000e-3, & + 1009.0, -5.8931439000, 1.6608204000e-3, -2.4797596000e-3, & + 1010.0, -5.8941708000, 1.6598004000e-3, -2.4778617000e-3, & + 1011.0, -5.8951948000, 1.6587808000e-3, -2.4759660000e-3, & + 1012.0, -5.8962156000, 1.6577617000e-3, -2.4740725000e-3, & + 1013.0, -5.8972335000, 1.6567431000e-3, -2.4721812000e-3, & + 1014.0, -5.8982483000, 1.6557250000e-3, -2.4702920000e-3, & + 1015.0, -5.8992600000, 1.6547073000e-3, -2.4684051000e-3, & + 1016.0, -5.9002688000, 1.6536901000e-3, -2.4665202000e-3, & + 1017.0, -5.9012745000, 1.6526733000e-3, -2.4646376000e-3, & + 1018.0, -5.9022772000, 1.6516570000e-3, -2.4627571000e-3, & + 1019.0, -5.9032769000, 1.6506412000e-3, -2.4608788000e-3, & + 1020.0, -5.9042737000, 1.6496258000e-3, -2.4590026000e-3, & + 1021.0, -5.9052674000, 1.6486109000e-3, -2.4571286000e-3, & + 1022.0, -5.9062582000, 1.6475965000e-3, -2.4552567000e-3, & + 1023.0, -5.9072460000, 1.6465826000e-3, -2.4533870000e-3, & + 1024.0, -5.9082308000, 1.6455691000e-3, -2.4515194000e-3, & + 1025.0, -5.9092127000, 1.6445561000e-3, -2.4496539000e-3, & + 1026.0, -5.9101917000, 1.6435436000e-3, -2.4477906000e-3, & + 1027.0, -5.9111677000, 1.6425316000e-3, -2.4459295000e-3, & + 1028.0, -5.9121408000, 1.6415200000e-3, -2.4440704000e-3, & + 1029.0, -5.9131109000, 1.6405089000e-3, -2.4422135000e-3, & + 1030.0, -5.9140782000, 1.6394983000e-3, -2.4403587000e-3, & + 1031.0, -5.9150425000, 1.6384882000e-3, -2.4385061000e-3, & + 1032.0, -5.9160039000, 1.6374786000e-3, -2.4366555000e-3, & + 1033.0, -5.9169625000, 1.6364694000e-3, -2.4348071000e-3, & + 1034.0, -5.9179181000, 1.6354607000e-3, -2.4329608000e-3, & + 1035.0, -5.9188709000, 1.6344526000e-3, -2.4311166000e-3, & + 1036.0, -5.9198208000, 1.6334449000e-3, -2.4292746000e-3, & + 1037.0, -5.9207678000, 1.6324377000e-3, -2.4274346000e-3, & + 1038.0, -5.9217120000, 1.6314309000e-3, -2.4255967000e-3, & + 1039.0, -5.9226533000, 1.6304247000e-3, -2.4237610000e-3, & + 1040.0, -5.9235918000, 1.6294190000e-3, -2.4219273000e-3, & + 1041.0, -5.9245275000, 1.6284137000e-3, -2.4200958000e-3, & + 1042.0, -5.9254603000, 1.6274090000e-3, -2.4182663000e-3, & + 1043.0, -5.9263904000, 1.6264047000e-3, -2.4164389000e-3, & + 1044.0, -5.9273176000, 1.6254009000e-3, -2.4146136000e-3, & + 1045.0, -5.9282420000, 1.6243977000e-3, -2.4127904000e-3, & + 1046.0, -5.9291636000, 1.6233949000e-3, -2.4109693000e-3, & + 1047.0, -5.9300824000, 1.6223926000e-3, -2.4091503000e-3, & + 1048.0, -5.9309984000, 1.6213909000e-3, -2.4073333000e-3, & + 1049.0, -5.9319117000, 1.6203896000e-3, -2.4055185000e-3, & + 1050.0, -5.9328222000, 1.6193888000e-3, -2.4037057000e-3, & + 1051.0, -5.9337299000, 1.6183886000e-3, -2.4018949000e-3, & + 1052.0, -5.9346349000, 1.6173888000e-3, -2.4000862000e-3, & + 1053.0, -5.9355371000, 1.6163895000e-3, -2.3982796000e-3, & + 1054.0, -5.9364366000, 1.6153908000e-3, -2.3964751000e-3, & + 1055.0, -5.9373334000, 1.6143925000e-3, -2.3946726000e-3, & + 1056.0, -5.9382274000, 1.6133948000e-3, -2.3928722000e-3, & + 1057.0, -5.9391187000, 1.6123976000e-3, -2.3910738000e-3, & + 1058.0, -5.9400074000, 1.6114009000e-3, -2.3892775000e-3, & + 1059.0, -5.9408933000, 1.6104046000e-3, -2.3874833000e-3, & + 1060.0, -5.9417765000, 1.6094089000e-3, -2.3856910000e-3, & + 1061.0, -5.9426570000, 1.6084138000e-3, -2.3839009000e-3, & + 1062.0, -5.9435349000, 1.6074191000e-3, -2.3821127000e-3, & + 1063.0, -5.9444100000, 1.6064249000e-3, -2.3803266000e-3, & + 1064.0, -5.9452825000, 1.6054313000e-3, -2.3785426000e-3, & + 1065.0, -5.9461524000, 1.6044382000e-3, -2.3767606000e-3, & + 1066.0, -5.9470196000, 1.6034456000e-3, -2.3749806000e-3, & + 1067.0, -5.9478841000, 1.6024535000e-3, -2.3732026000e-3, & + 1068.0, -5.9487460000, 1.6014619000e-3, -2.3714267000e-3, & + 1069.0, -5.9496053000, 1.6004709000e-3, -2.3696528000e-3, & + 1070.0, -5.9504619000, 1.5994804000e-3, -2.3678809000e-3, & + 1071.0, -5.9513160000, 1.5984904000e-3, -2.3661110000e-3, & + 1072.0, -5.9521674000, 1.5975009000e-3, -2.3643432000e-3, & + 1073.0, -5.9530162000, 1.5965120000e-3, -2.3625773000e-3, & + 1074.0, -5.9538624000, 1.5955236000e-3, -2.3608135000e-3, & + 1075.0, -5.9547061000, 1.5945357000e-3, -2.3590517000e-3, & + 1076.0, -5.9555471000, 1.5935483000e-3, -2.3572919000e-3, & + 1077.0, -5.9563856000, 1.5925615000e-3, -2.3555341000e-3, & + 1078.0, -5.9572215000, 1.5915752000e-3, -2.3537782000e-3, & + 1079.0, -5.9580548000, 1.5905894000e-3, -2.3520244000e-3, & + 1080.0, -5.9588856000, 1.5896041000e-3, -2.3502726000e-3, & + 1081.0, -5.9597138000, 1.5886194000e-3, -2.3485228000e-3, & + 1082.0, -5.9605395000, 1.5876353000e-3, -2.3467750000e-3, & + 1083.0, -5.9613627000, 1.5866516000e-3, -2.3450292000e-3, & + 1084.0, -5.9621833000, 1.5856685000e-3, -2.3432853000e-3, & + 1085.0, -5.9630014000, 1.5846860000e-3, -2.3415434000e-3, & + 1086.0, -5.9638170000, 1.5837039000e-3, -2.3398036000e-3, & + 1087.0, -5.9646301000, 1.5827224000e-3, -2.3380657000e-3, & + 1088.0, -5.9654407000, 1.5817415000e-3, -2.3363297000e-3, & + 1089.0, -5.9662488000, 1.5807611000e-3, -2.3345958000e-3, & + 1090.0, -5.9670544000, 1.5797812000e-3, -2.3328638000e-3, & + 1091.0, -5.9678575000, 1.5788019000e-3, -2.3311338000e-3, & + 1092.0, -5.9686582000, 1.5778231000e-3, -2.3294057000e-3, & + 1093.0, -5.9694563000, 1.5768449000e-3, -2.3276797000e-3, & + 1094.0, -5.9702521000, 1.5758672000e-3, -2.3259555000e-3, & + 1095.0, -5.9710453000, 1.5748901000e-3, -2.3242334000e-3, & + 1096.0, -5.9718361000, 1.5739135000e-3, -2.3225132000e-3, & + 1097.0, -5.9726245000, 1.5729374000e-3, -2.3207950000e-3, & + 1098.0, -5.9734105000, 1.5719619000e-3, -2.3190787000e-3, & + 1099.0, -5.9741940000, 1.5709870000e-3, -2.3173643000e-3, & + 1100.0, -5.9749751000, 1.5700126000e-3, -2.3156519000e-3, & + 1101.0, -5.9757538000, 1.5690387000e-3, -2.3139415000e-3, & + 1102.0, -5.9765300000, 1.5680654000e-3, -2.3122330000e-3, & + 1103.0, -5.9773039000, 1.5670927000e-3, -2.3105264000e-3, & + 1104.0, -5.9780754000, 1.5661205000e-3, -2.3088218000e-3, & + 1105.0, -5.9788445000, 1.5651489000e-3, -2.3071191000e-3, & + 1106.0, -5.9796112000, 1.5641778000e-3, -2.3054184000e-3, & + 1107.0, -5.9803755000, 1.5632073000e-3, -2.3037195000e-3, & + 1108.0, -5.9811375000, 1.5622374000e-3, -2.3020226000e-3, & + 1109.0, -5.9818971000, 1.5612680000e-3, -2.3003277000e-3, & + 1110.0, -5.9826543000, 1.5602991000e-3, -2.2986346000e-3, & + 1111.0, -5.9834092000, 1.5593309000e-3, -2.2969435000e-3, & + 1112.0, -5.9841618000, 1.5583632000e-3, -2.2952543000e-3, & + 1113.0, -5.9849120000, 1.5573960000e-3, -2.2935670000e-3, & + 1114.0, -5.9856599000, 1.5564294000e-3, -2.2918817000e-3, & + 1115.0, -5.9864054000, 1.5554634000e-3, -2.2901982000e-3, & + 1116.0, -5.9871487000, 1.5544979000e-3, -2.2885167000e-3, & + 1117.0, -5.9878896000, 1.5535331000e-3, -2.2868370000e-3, & + 1118.0, -5.9886282000, 1.5525687000e-3, -2.2851593000e-3, & + 1119.0, -5.9893646000, 1.5516050000e-3, -2.2834835000e-3, & + 1120.0, -5.9900986000, 1.5506418000e-3, -2.2818095000e-3, & + 1121.0, -5.9908304000, 1.5496792000e-3, -2.2801375000e-3, & + 1122.0, -5.9915599000, 1.5487171000e-3, -2.2784674000e-3, & + 1123.0, -5.9922871000, 1.5477557000e-3, -2.2767991000e-3, & + 1124.0, -5.9930120000, 1.5467948000e-3, -2.2751328000e-3, & + 1125.0, -5.9937347000, 1.5458344000e-3, -2.2734683000e-3, & + 1126.0, -5.9944551000, 1.5448747000e-3, -2.2718058000e-3, & + 1127.0, -5.9951733000, 1.5439155000e-3, -2.2701451000e-3, & + 1128.0, -5.9958892000, 1.5429569000e-3, -2.2684863000e-3, & + 1129.0, -5.9966029000, 1.5419989000e-3, -2.2668294000e-3, & + 1130.0, -5.9973144000, 1.5410414000e-3, -2.2651743000e-3, & + 1131.0, -5.9980236000, 1.5400845000e-3, -2.2635212000e-3, & + 1132.0, -5.9987307000, 1.5391282000e-3, -2.2618699000e-3, & + 1133.0, -5.9994355000, 1.5381725000e-3, -2.2602205000e-3, & + 1134.0, -6.0001381000, 1.5372174000e-3, -2.2585729000e-3, & + 1135.0, -6.0008385000, 1.5362628000e-3, -2.2569272000e-3, & + 1136.0, -6.0015367000, 1.5353089000e-3, -2.2552834000e-3, & + 1137.0, -6.0022328000, 1.5343555000e-3, -2.2536414000e-3, & + 1138.0, -6.0029266000, 1.5334027000e-3, -2.2520013000e-3, & + 1139.0, -6.0036183000, 1.5324504000e-3, -2.2503631000e-3, & + 1140.0, -6.0043078000, 1.5314988000e-3, -2.2487267000e-3, & + 1141.0, -6.0049952000, 1.5305477000e-3, -2.2470922000e-3, & + 1142.0, -6.0056804000, 1.5295973000e-3, -2.2454595000e-3, & + 1143.0, -6.0063635000, 1.5286474000e-3, -2.2438287000e-3, & + 1144.0, -6.0070444000, 1.5276981000e-3, -2.2421997000e-3, & + 1145.0, -6.0077231000, 1.5267494000e-3, -2.2405726000e-3, & + 1146.0, -6.0083998000, 1.5258013000e-3, -2.2389473000e-3, & + 1147.0, -6.0090743000, 1.5248538000e-3, -2.2373238000e-3, & + 1148.0, -6.0097467000, 1.5239068000e-3, -2.2357022000e-3, & + 1149.0, -6.0104170000, 1.5229605000e-3, -2.2340824000e-3, & + 1150.0, -6.0110851000, 1.5220147000e-3, -2.2324645000e-3, & + 1151.0, -6.0117512000, 1.5210696000e-3, -2.2308484000e-3, & + 1152.0, -6.0124152000, 1.5201250000e-3, -2.2292341000e-3, & + 1153.0, -6.0130771000, 1.5191811000e-3, -2.2276216000e-3, & + 1154.0, -6.0137369000, 1.5182377000e-3, -2.2260110000e-3, & + 1155.0, -6.0143946000, 1.5172949000e-3, -2.2244022000e-3, & + 1156.0, -6.0150502000, 1.5163527000e-3, -2.2227952000e-3, & + 1157.0, -6.0157038000, 1.5154112000e-3, -2.2211900000e-3, & + 1158.0, -6.0163553000, 1.5144702000e-3, -2.2195866000e-3, & + 1159.0, -6.0170048000, 1.5135298000e-3, -2.2179851000e-3, & + 1160.0, -6.0176522000, 1.5125900000e-3, -2.2163853000e-3, & + 1161.0, -6.0182976000, 1.5116508000e-3, -2.2147874000e-3, & + 1162.0, -6.0189409000, 1.5107122000e-3, -2.2131913000e-3, & + 1163.0, -6.0195822000, 1.5097742000e-3, -2.2115970000e-3, & + 1164.0, -6.0202215000, 1.5088369000e-3, -2.2100045000e-3, & + 1165.0, -6.0208588000, 1.5079001000e-3, -2.2084138000e-3, & + 1166.0, -6.0214940000, 1.5069639000e-3, -2.2068249000e-3, & + 1167.0, -6.0221273000, 1.5060283000e-3, -2.2052377000e-3, & + 1168.0, -6.0227585000, 1.5050934000e-3, -2.2036524000e-3, & + 1169.0, -6.0233877000, 1.5041590000e-3, -2.2020689000e-3, & + 1170.0, -6.0240150000, 1.5032253000e-3, -2.2004872000e-3, & + 1171.0, -6.0246402000, 1.5022921000e-3, -2.1989072000e-3, & + 1172.0, -6.0252635000, 1.5013596000e-3, -2.1973290000e-3, & + 1173.0, -6.0258848000, 1.5004276000e-3, -2.1957527000e-3, & + 1174.0, -6.0265042000, 1.4994963000e-3, -2.1941781000e-3, & + 1175.0, -6.0271215000, 1.4985656000e-3, -2.1926052000e-3, & + 1176.0, -6.0277369000, 1.4976355000e-3, -2.1910342000e-3, & + 1177.0, -6.0283504000, 1.4967060000e-3, -2.1894649000e-3, & + 1178.0, -6.0289619000, 1.4957771000e-3, -2.1878974000e-3, & + 1179.0, -6.0295715000, 1.4948489000e-3, -2.1863317000e-3, & + 1180.0, -6.0301791000, 1.4939212000e-3, -2.1847678000e-3, & + 1181.0, -6.0307848000, 1.4929942000e-3, -2.1832056000e-3, & + 1182.0, -6.0313886000, 1.4920677000e-3, -2.1816451000e-3, & + 1183.0, -6.0319905000, 1.4911419000e-3, -2.1800865000e-3, & + 1184.0, -6.0325904000, 1.4902167000e-3, -2.1785296000e-3, & + 1185.0, -6.0331885000, 1.4892921000e-3, -2.1769744000e-3, & + 1186.0, -6.0337846000, 1.4883682000e-3, -2.1754210000e-3, & + 1187.0, -6.0343789000, 1.4874448000e-3, -2.1738694000e-3, & + 1188.0, -6.0349712000, 1.4865221000e-3, -2.1723195000e-3, & + 1189.0, -6.0355617000, 1.4856000000e-3, -2.1707714000e-3, & + 1190.0, -6.0361503000, 1.4846785000e-3, -2.1692250000e-3, & + 1191.0, -6.0367370000, 1.4837576000e-3, -2.1676804000e-3, & + 1192.0, -6.0373218000, 1.4828373000e-3, -2.1661375000e-3, & + 1193.0, -6.0379048000, 1.4819177000e-3, -2.1645963000e-3, & + 1194.0, -6.0384859000, 1.4809986000e-3, -2.1630569000e-3, & + 1195.0, -6.0390651000, 1.4800802000e-3, -2.1615192000e-3, & + 1196.0, -6.0396426000, 1.4791625000e-3, -2.1599833000e-3, & + 1197.0, -6.0402181000, 1.4782453000e-3, -2.1584490000e-3, & + 1198.0, -6.0407919000, 1.4773288000e-3, -2.1569166000e-3, & + 1199.0, -6.0413638000, 1.4764129000e-3, -2.1553858000e-3, & + 1200.0, -6.0419338000, 1.4754976000e-3, -2.1538568000e-3, & + 1201.0, -6.0425021000, 1.4745829000e-3, -2.1523295000e-3, & + 1202.0, -6.0430685000, 1.4736689000e-3, -2.1508039000e-3, & + 1203.0, -6.0436331000, 1.4727555000e-3, -2.1492800000e-3, & + 1204.0, -6.0441959000, 1.4718427000e-3, -2.1477579000e-3, & + 1205.0, -6.0447570000, 1.4709305000e-3, -2.1462375000e-3, & + 1206.0, -6.0453162000, 1.4700190000e-3, -2.1447188000e-3, & + 1207.0, -6.0458736000, 1.4691081000e-3, -2.1432018000e-3, & + 1208.0, -6.0464292000, 1.4681978000e-3, -2.1416865000e-3, & + 1209.0, -6.0469831000, 1.4672882000e-3, -2.1401729000e-3, & + 1210.0, -6.0475352000, 1.4663791000e-3, -2.1386610000e-3, & + 1211.0, -6.0480855000, 1.4654707000e-3, -2.1371509000e-3, & + 1212.0, -6.0486341000, 1.4645630000e-3, -2.1356424000e-3, & + 1213.0, -6.0491809000, 1.4636558000e-3, -2.1341356000e-3, & + 1214.0, -6.0497259000, 1.4627493000e-3, -2.1326306000e-3, & + 1215.0, -6.0502692000, 1.4618435000e-3, -2.1311272000e-3, & + 1216.0, -6.0508107000, 1.4609382000e-3, -2.1296255000e-3, & + 1217.0, -6.0513505000, 1.4600336000e-3, -2.1281255000e-3, & + 1218.0, -6.0518886000, 1.4591297000e-3, -2.1266272000e-3, & + 1219.0, -6.0524250000, 1.4582263000e-3, -2.1251306000e-3, & + 1220.0, -6.0529596000, 1.4573236000e-3, -2.1236357000e-3, & + 1221.0, -6.0534925000, 1.4564215000e-3, -2.1221424000e-3, & + 1222.0, -6.0540237000, 1.4555201000e-3, -2.1206509000e-3, & + 1223.0, -6.0545531000, 1.4546193000e-3, -2.1191610000e-3, & + 1224.0, -6.0550809000, 1.4537191000e-3, -2.1176728000e-3, & + 1225.0, -6.0556070000, 1.4528196000e-3, -2.1161863000e-3, & + 1226.0, -6.0561314000, 1.4519207000e-3, -2.1147014000e-3, & + 1227.0, -6.0566541000, 1.4510224000e-3, -2.1132182000e-3, & + 1228.0, -6.0571751000, 1.4501248000e-3, -2.1117367000e-3, & + 1229.0, -6.0576944000, 1.4492278000e-3, -2.1102569000e-3, & + 1230.0, -6.0582120000, 1.4483315000e-3, -2.1087787000e-3, & + 1231.0, -6.0587280000, 1.4474358000e-3, -2.1073022000e-3, & + 1232.0, -6.0592424000, 1.4465407000e-3, -2.1058273000e-3, & + 1233.0, -6.0597550000, 1.4456463000e-3, -2.1043541000e-3, & + 1234.0, -6.0602660000, 1.4447525000e-3, -2.1028826000e-3, & + 1235.0, -6.0607754000, 1.4438593000e-3, -2.1014127000e-3, & + 1236.0, -6.0612831000, 1.4429668000e-3, -2.0999445000e-3, & + 1237.0, -6.0617892000, 1.4420750000e-3, -2.0984779000e-3, & + 1238.0, -6.0622936000, 1.4411837000e-3, -2.0970130000e-3, & + 1239.0, -6.0627964000, 1.4402931000e-3, -2.0955497000e-3, & + 1240.0, -6.0632976000, 1.4394032000e-3, -2.0940880000e-3, & + 1241.0, -6.0637972000, 1.4385139000e-3, -2.0926281000e-3, & + 1242.0, -6.0642951000, 1.4376252000e-3, -2.0911697000e-3, & + 1243.0, -6.0647914000, 1.4367372000e-3, -2.0897130000e-3, & + 1244.0, -6.0652862000, 1.4358498000e-3, -2.0882579000e-3, & + 1245.0, -6.0657793000, 1.4349631000e-3, -2.0868045000e-3, & + 1246.0, -6.0662708000, 1.4340770000e-3, -2.0853527000e-3, & + 1247.0, -6.0667608000, 1.4331916000e-3, -2.0839025000e-3, & + 1248.0, -6.0672491000, 1.4323068000e-3, -2.0824540000e-3, & + 1249.0, -6.0677359000, 1.4314226000e-3, -2.0810070000e-3, & + 1250.0, -6.0682211000, 1.4305391000e-3, -2.0795618000e-3, & + 1251.0, -6.0687047000, 1.4296562000e-3, -2.0781181000e-3, & + 1252.0, -6.0691867000, 1.4287740000e-3, -2.0766760000e-3, & + 1253.0, -6.0696672000, 1.4278925000e-3, -2.0752356000e-3, & + 1254.0, -6.0701462000, 1.4270115000e-3, -2.0737968000e-3, & + 1255.0, -6.0706235000, 1.4261312000e-3, -2.0723596000e-3, & + 1256.0, -6.0710993000, 1.4252516000e-3, -2.0709241000e-3, & + 1257.0, -6.0715736000, 1.4243726000e-3, -2.0694901000e-3, & + 1258.0, -6.0720464000, 1.4234943000e-3, -2.0680577000e-3, & + 1259.0, -6.0725175000, 1.4226166000e-3, -2.0666270000e-3, & + 1260.0, -6.0729872000, 1.4217396000e-3, -2.0651979000e-3, & + 1261.0, -6.0734554000, 1.4208632000e-3, -2.0637703000e-3, & + 1262.0, -6.0739220000, 1.4199874000e-3, -2.0623444000e-3, & + 1263.0, -6.0743871000, 1.4191123000e-3, -2.0609201000e-3, & + 1264.0, -6.0748507000, 1.4182379000e-3, -2.0594973000e-3, & + 1265.0, -6.0753127000, 1.4173641000e-3, -2.0580762000e-3, & + 1266.0, -6.0757733000, 1.4164910000e-3, -2.0566566000e-3, & + 1267.0, -6.0762324000, 1.4156185000e-3, -2.0552387000e-3, & + 1268.0, -6.0766899000, 1.4147466000e-3, -2.0538223000e-3, & + 1269.0, -6.0771460000, 1.4138754000e-3, -2.0524076000e-3, & + 1270.0, -6.0776006000, 1.4130049000e-3, -2.0509944000e-3, & + 1271.0, -6.0780537000, 1.4121350000e-3, -2.0495828000e-3, & + 1272.0, -6.0785054000, 1.4112658000e-3, -2.0481728000e-3, & + 1273.0, -6.0789555000, 1.4103972000e-3, -2.0467643000e-3, & + 1274.0, -6.0794042000, 1.4095293000e-3, -2.0453575000e-3, & + 1275.0, -6.0798515000, 1.4086620000e-3, -2.0439522000e-3, & + 1276.0, -6.0802972000, 1.4077954000e-3, -2.0425485000e-3, & + 1277.0, -6.0807415000, 1.4069294000e-3, -2.0411464000e-3, & + 1278.0, -6.0811844000, 1.4060641000e-3, -2.0397458000e-3, & + 1279.0, -6.0816258000, 1.4051994000e-3, -2.0383468000e-3, & + 1280.0, -6.0820658000, 1.4043354000e-3, -2.0369494000e-3, & + 1281.0, -6.0825043000, 1.4034720000e-3, -2.0355536000e-3, & + 1282.0, -6.0829414000, 1.4026093000e-3, -2.0341593000e-3, & + 1283.0, -6.0833771000, 1.4017473000e-3, -2.0327665000e-3, & + 1284.0, -6.0838114000, 1.4008859000e-3, -2.0313754000e-3, & + 1285.0, -6.0842442000, 1.4000251000e-3, -2.0299858000e-3, & + 1286.0, -6.0846756000, 1.3991650000e-3, -2.0285977000e-3, & + 1287.0, -6.0851056000, 1.3983056000e-3, -2.0272112000e-3, & + 1288.0, -6.0855342000, 1.3974468000e-3, -2.0258263000e-3, & + 1289.0, -6.0859614000, 1.3965887000e-3, -2.0244429000e-3, & + 1290.0, -6.0863871000, 1.3957312000e-3, -2.0230610000e-3, & + 1291.0, -6.0868115000, 1.3948744000e-3, -2.0216807000e-3, & + 1292.0, -6.0872345000, 1.3940183000e-3, -2.0203020000e-3, & + 1293.0, -6.0876561000, 1.3931628000e-3, -2.0189247000e-3, & + 1294.0, -6.0880764000, 1.3923079000e-3, -2.0175491000e-3, & + 1295.0, -6.0884952000, 1.3914537000e-3, -2.0161749000e-3, & + 1296.0, -6.0889127000, 1.3906002000e-3, -2.0148024000e-3, & + 1297.0, -6.0893288000, 1.3897473000e-3, -2.0134313000e-3, & + 1298.0, -6.0897435000, 1.3888951000e-3, -2.0120618000e-3, & + 1299.0, -6.0901569000, 1.3880436000e-3, -2.0106938000e-3, & + 1300.0, -6.0905689000, 1.3871927000e-3, -2.0093273000e-3, & + 1301.0, -6.0909796000, 1.3863424000e-3, -2.0079624000e-3, & + 1302.0, -6.0913889000, 1.3854928000e-3, -2.0065990000e-3, & + 1303.0, -6.0917969000, 1.3846439000e-3, -2.0052371000e-3, & + 1304.0, -6.0922035000, 1.3837956000e-3, -2.0038767000e-3, & + 1305.0, -6.0926088000, 1.3829480000e-3, -2.0025179000e-3, & + 1306.0, -6.0930127000, 1.3821011000e-3, -2.0011606000e-3, & + 1307.0, -6.0934154000, 1.3812548000e-3, -1.9998048000e-3, & + 1308.0, -6.0938167000, 1.3804091000e-3, -1.9984505000e-3, & + 1309.0, -6.0942166000, 1.3795642000e-3, -1.9970977000e-3, & + 1310.0, -6.0946153000, 1.3787199000e-3, -1.9957464000e-3, & + 1311.0, -6.0950127000, 1.3778762000e-3, -1.9943967000e-3, & + 1312.0, -6.0954087000, 1.3770332000e-3, -1.9930484000e-3, & + 1313.0, -6.0958034000, 1.3761909000e-3, -1.9917017000e-3, & + 1314.0, -6.0961969000, 1.3753492000e-3, -1.9903564000e-3, & + 1315.0, -6.0965890000, 1.3745082000e-3, -1.9890127000e-3, & + 1316.0, -6.0969798000, 1.3736678000e-3, -1.9876705000e-3, & + 1317.0, -6.0973694000, 1.3728281000e-3, -1.9863297000e-3, & + 1318.0, -6.0977577000, 1.3719890000e-3, -1.9849905000e-3, & + 1319.0, -6.0981446000, 1.3711507000e-3, -1.9836527000e-3, & + 1320.0, -6.0985303000, 1.3703129000e-3, -1.9823165000e-3, & + 1321.0, -6.0989148000, 1.3694759000e-3, -1.9809817000e-3, & + 1322.0, -6.0992979000, 1.3686395000e-3, -1.9796485000e-3, & + 1323.0, -6.0996798000, 1.3678037000e-3, -1.9783167000e-3, & + 1324.0, -6.1000605000, 1.3669686000e-3, -1.9769864000e-3, & + 1325.0, -6.1004399000, 1.3661342000e-3, -1.9756576000e-3, & + 1326.0, -6.1008180000, 1.3653005000e-3, -1.9743302000e-3, & + 1327.0, -6.1011948000, 1.3644674000e-3, -1.9730044000e-3, & + 1328.0, -6.1015705000, 1.3636349000e-3, -1.9716800000e-3, & + 1329.0, -6.1019449000, 1.3628031000e-3, -1.9703571000e-3, & + 1330.0, -6.1023180000, 1.3619720000e-3, -1.9690357000e-3, & + 1331.0, -6.1026899000, 1.3611416000e-3, -1.9677157000e-3, & + 1332.0, -6.1030606000, 1.3603118000e-3, -1.9663972000e-3, & + 1333.0, -6.1034300000, 1.3594826000e-3, -1.9650802000e-3, & + 1334.0, -6.1037983000, 1.3586541000e-3, -1.9637647000e-3, & + 1335.0, -6.1041653000, 1.3578263000e-3, -1.9624506000e-3, & + 1336.0, -6.1045311000, 1.3569992000e-3, -1.9611380000e-3, & + 1337.0, -6.1048956000, 1.3561727000e-3, -1.9598268000e-3, & + 1338.0, -6.1052590000, 1.3553468000e-3, -1.9585171000e-3, & + 1339.0, -6.1056212000, 1.3545217000e-3, -1.9572089000e-3, & + 1340.0, -6.1059821000, 1.3536972000e-3, -1.9559021000e-3, & + 1341.0, -6.1063419000, 1.3528733000e-3, -1.9545968000e-3, & + 1342.0, -6.1067005000, 1.3520501000e-3, -1.9532929000e-3, & + 1343.0, -6.1070578000, 1.3512276000e-3, -1.9519905000e-3, & + 1344.0, -6.1074140000, 1.3504057000e-3, -1.9506896000e-3, & + 1345.0, -6.1077690000, 1.3495845000e-3, -1.9493900000e-3, & + 1346.0, -6.1081229000, 1.3487640000e-3, -1.9480920000e-3, & + 1347.0, -6.1084755000, 1.3479441000e-3, -1.9467953000e-3, & + 1348.0, -6.1088270000, 1.3471249000e-3, -1.9455001000e-3, & + 1349.0, -6.1091773000, 1.3463063000e-3, -1.9442064000e-3, & + 1350.0, -6.1095265000, 1.3454884000e-3, -1.9429141000e-3, & + 1351.0, -6.1098744000, 1.3446712000e-3, -1.9416232000e-3, & + 1352.0, -6.1102213000, 1.3438546000e-3, -1.9403338000e-3, & + 1353.0, -6.1105669000, 1.3430387000e-3, -1.9390458000e-3, & + 1354.0, -6.1109115000, 1.3422234000e-3, -1.9377592000e-3, & + 1355.0, -6.1112548000, 1.3414088000e-3, -1.9364741000e-3, & + 1356.0, -6.1115971000, 1.3405949000e-3, -1.9351903000e-3, & + 1357.0, -6.1119382000, 1.3397816000e-3, -1.9339081000e-3, & + 1358.0, -6.1122781000, 1.3389690000e-3, -1.9326272000e-3, & + 1359.0, -6.1126170000, 1.3381571000e-3, -1.9313478000e-3, & + 1360.0, -6.1129546000, 1.3373458000e-3, -1.9300697000e-3, & + 1361.0, -6.1132912000, 1.3365352000e-3, -1.9287931000e-3, & + 1362.0, -6.1136267000, 1.3357252000e-3, -1.9275180000e-3, & + 1363.0, -6.1139610000, 1.3349159000e-3, -1.9262442000e-3, & + 1364.0, -6.1142942000, 1.3341073000e-3, -1.9249718000e-3, & + 1365.0, -6.1146263000, 1.3332993000e-3, -1.9237009000e-3, & + 1366.0, -6.1149573000, 1.3324920000e-3, -1.9224314000e-3, & + 1367.0, -6.1152872000, 1.3316853000e-3, -1.9211632000e-3, & + 1368.0, -6.1156160000, 1.3308793000e-3, -1.9198965000e-3, & + 1369.0, -6.1159437000, 1.3300740000e-3, -1.9186312000e-3, & + 1370.0, -6.1162702000, 1.3292693000e-3, -1.9173673000e-3, & + 1371.0, -6.1165957000, 1.3284653000e-3, -1.9161048000e-3, & + 1372.0, -6.1169202000, 1.3276619000e-3, -1.9148437000e-3, & + 1373.0, -6.1172435000, 1.3268592000e-3, -1.9135840000e-3, & + 1374.0, -6.1175657000, 1.3260572000e-3, -1.9123257000e-3, & + 1375.0, -6.1178869000, 1.3252558000e-3, -1.9110688000e-3, & + 1376.0, -6.1182070000, 1.3244551000e-3, -1.9098133000e-3, & + 1377.0, -6.1185260000, 1.3236551000e-3, -1.9085591000e-3, & + 1378.0, -6.1188440000, 1.3228557000e-3, -1.9073064000e-3, & + 1379.0, -6.1191609000, 1.3220569000e-3, -1.9060550000e-3, & + 1380.0, -6.1194767000, 1.3212589000e-3, -1.9048051000e-3, & + 1381.0, -6.1197915000, 1.3204614000e-3, -1.9035565000e-3, & + 1382.0, -6.1201052000, 1.3196647000e-3, -1.9023093000e-3, & + 1383.0, -6.1204179000, 1.3188686000e-3, -1.9010635000e-3, & + 1384.0, -6.1207295000, 1.3180732000e-3, -1.8998190000e-3, & + 1385.0, -6.1210401000, 1.3172784000e-3, -1.8985760000e-3, & + 1386.0, -6.1213496000, 1.3164843000e-3, -1.8973343000e-3, & + 1387.0, -6.1216581000, 1.3156908000e-3, -1.8960940000e-3, & + 1388.0, -6.1219656000, 1.3148980000e-3, -1.8948550000e-3, & + 1389.0, -6.1222720000, 1.3141059000e-3, -1.8936175000e-3, & + 1390.0, -6.1225774000, 1.3133144000e-3, -1.8923813000e-3, & + 1391.0, -6.1228818000, 1.3125236000e-3, -1.8911464000e-3, & + 1392.0, -6.1231851000, 1.3117334000e-3, -1.8899130000e-3, & + 1393.0, -6.1234875000, 1.3109439000e-3, -1.8886809000e-3, & + 1394.0, -6.1237888000, 1.3101551000e-3, -1.8874501000e-3, & + 1395.0, -6.1240891000, 1.3093669000e-3, -1.8862207000e-3, & + 1396.0, -6.1243884000, 1.3085794000e-3, -1.8849927000e-3, & + 1397.0, -6.1246867000, 1.3077925000e-3, -1.8837660000e-3, & + 1398.0, -6.1249840000, 1.3070063000e-3, -1.8825407000e-3, & + 1399.0, -6.1252803000, 1.3062208000e-3, -1.8813168000e-3, & + 1400.0, -6.1255756000, 1.3054359000e-3, -1.8800942000e-3, & + 1401.0, -6.1258699000, 1.3046517000e-3, -1.8788729000e-3, & + 1402.0, -6.1261632000, 1.3038681000e-3, -1.8776530000e-3, & + 1403.0, -6.1264555000, 1.3030852000e-3, -1.8764345000e-3, & + 1404.0, -6.1267469000, 1.3023029000e-3, -1.8752172000e-3, & + 1405.0, -6.1270372000, 1.3015213000e-3, -1.8740014000e-3, & + 1406.0, -6.1273266000, 1.3007404000e-3, -1.8727868000e-3, & + 1407.0, -6.1276150000, 1.2999601000e-3, -1.8715736000e-3, & + 1408.0, -6.1279024000, 1.2991804000e-3, -1.8703618000e-3, & + 1409.0, -6.1281889000, 1.2984015000e-3, -1.8691513000e-3, & + 1410.0, -6.1284744000, 1.2976231000e-3, -1.8679421000e-3, & + 1411.0, -6.1287590000, 1.2968455000e-3, -1.8667343000e-3, & + 1412.0, -6.1290425000, 1.2960685000e-3, -1.8655277000e-3, & + 1413.0, -6.1293252000, 1.2952921000e-3, -1.8643226000e-3, & + 1414.0, -6.1296068000, 1.2945164000e-3, -1.8631187000e-3, & + 1415.0, -6.1298876000, 1.2937414000e-3, -1.8619162000e-3, & + 1416.0, -6.1301673000, 1.2929670000e-3, -1.8607150000e-3, & + 1417.0, -6.1304462000, 1.2921933000e-3, -1.8595151000e-3, & + 1418.0, -6.1307241000, 1.2914202000e-3, -1.8583165000e-3, & + 1419.0, -6.1310010000, 1.2906478000e-3, -1.8571193000e-3, & + 1420.0, -6.1312770000, 1.2898761000e-3, -1.8559234000e-3, & + 1421.0, -6.1315521000, 1.2891050000e-3, -1.8547288000e-3, & + 1422.0, -6.1318263000, 1.2883345000e-3, -1.8535355000e-3, & + 1423.0, -6.1320995000, 1.2875647000e-3, -1.8523435000e-3, & + 1424.0, -6.1323718000, 1.2867956000e-3, -1.8511528000e-3, & + 1425.0, -6.1326432000, 1.2860271000e-3, -1.8499635000e-3, & + 1426.0, -6.1329136000, 1.2852592000e-3, -1.8487754000e-3, & + 1427.0, -6.1331832000, 1.2844921000e-3, -1.8475887000e-3, & + 1428.0, -6.1334518000, 1.2837255000e-3, -1.8464033000e-3, & + 1429.0, -6.1337196000, 1.2829597000e-3, -1.8452191000e-3, & + 1430.0, -6.1339864000, 1.2821945000e-3, -1.8440363000e-3, & + 1431.0, -6.1342523000, 1.2814299000e-3, -1.8428548000e-3, & + 1432.0, -6.1345173000, 1.2806660000e-3, -1.8416745000e-3, & + 1433.0, -6.1347815000, 1.2799027000e-3, -1.8404956000e-3, & + 1434.0, -6.1350447000, 1.2791401000e-3, -1.8393180000e-3, & + 1435.0, -6.1353070000, 1.2783782000e-3, -1.8381416000e-3, & + 1436.0, -6.1355685000, 1.2776168000e-3, -1.8369666000e-3, & + 1437.0, -6.1358290000, 1.2768562000e-3, -1.8357928000e-3, & + 1438.0, -6.1360887000, 1.2760962000e-3, -1.8346203000e-3, & + 1439.0, -6.1363475000, 1.2753368000e-3, -1.8334492000e-3, & + 1440.0, -6.1366054000, 1.2745781000e-3, -1.8322792000e-3 & + /), (/4, lmax+1/)) !< Load Love numbers + +!> \namespace mom_load_love_numbers +!! \section section_Love_numbers The Love numbers +!! +!! This module serves the sole purpose of storing load Love number. The Love numbers are used for the spherical harmonic +!! self-attraction and loading (SAL) calculation in MOM_self_attr_load module. This separate module ensures readability +!! of the SAL module. +!! +!! Variable Love_Data stores the Love numbers up to degree 1440. From left to right: degree, h, l, and k. Data in this +!! module is imported from SAL calculation in Model for Prediction Across Scales (MPAS)-Ocean developed by Los Alamos +!! National Laboratory and University of Michigan [\cite Barton2022 and \cite Brus2023]. The load Love numbers +!! are from \cite Wang2012-2, which are in the center of mass of total Earth system reference frame (CM). When used, +!! Love numbers with degree<2 should be converted to center of mass solid Earth reference frame (CF) +!! [\cite Blewitt2003], as in subroutine calc_love_scaling in MOM_tidal_forcing module. +!! +!! References: +!! +!! Barton, K.N., Pal, N., Brus, S.R., Petersen, M.R., Arbic, B.K., Engwirda, D., Roberts, A.F., Westerink, J.J., +!! Wirasaet, D. and Schindelegger, M., 2022. Global Barotropic Tide Modeling Using Inline Self‐Attraction and Loading in +!! MPAS‐Ocean. Journal of Advances in Modeling Earth Systems, 14(11), p.e2022MS003207. +!! https://doi.org/10.1029/2022MS003207 +!! +!! Blewitt, G., 2003. Self‐consistency in reference frames, geocenter definition, and surface loading of the solid +!! Earth. Journal of geophysical research: solid earth, 108(B2). +!! https://doi.org/10.1029/2002JB002082 +!! +!! Brus, S.R., Barton, K.N., Pal, N., Roberts, A.F., Engwirda, D., Petersen, M.R., Arbic, B.K., Wirasaet, D., +!! Westerink, J.J. and Schindelegger, M., 2023. Scalable self attraction and loading calculations for unstructured ocean +!! tide models. Ocean Modelling, p.102160. +!! https://doi.org/10.1016/j.ocemod.2023.102160 +!! +!! Wang, H., Xiang, L., Jia, L., Jiang, L., Wang, Z., Hu, B. and Gao, P., 2012. Load Love numbers and Green's functions +!! for elastic Earth models PREM, iasp91, ak135, and modified models with refined crustal structure from Crust 2.0. +!! Computers & Geosciences, 49, pp.190-199. +!! https://doi.org/10.1016/j.cageo.2012.06.022 +end module MOM_load_love_numbers diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 04982d7171..3f3c79db5a 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -1,25 +1,31 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> \brief Parameterization of mixed layer restratification by unresolved mixed-layer eddies. module MOM_mixed_layer_restrat -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_debugging, only : hchksum use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, time_type use MOM_diag_mediator, only : diag_update_remap_grids use MOM_domains, only : pass_var, To_West, To_South, Omit_Corners use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_forcing_type, only : mech_forcing +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_file_parser, only : openParameterBlock, closeParameterBlock +use MOM_forcing_type, only : mech_forcing, find_ustar use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type -use MOM_io, only : vardesc, var_desc +use MOM_interpolate, only : init_external_field, time_interp_external, time_interp_external_init +use MOM_interpolate, only : external_field +use MOM_intrinsic_functions, only : cuberoot +use MOM_io, only : slasher, MOM_read_data use MOM_lateral_mixing_coeffs, only : VarMix_CS use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, EOS_domain +use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units +use MOM_EOS, only : calculate_density, calculate_spec_vol, EOS_domain implicit none ; private @@ -28,6 +34,7 @@ module MOM_mixed_layer_restrat public mixedlayer_restrat public mixedlayer_restrat_init public mixedlayer_restrat_register_restarts +public mixedlayer_restrat_unit_tests ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -46,9 +53,13 @@ module MOM_mixed_layer_restrat !! upscaling of buoyancy gradients that is otherwise represented !! by the parameter FOX_KEMPER_ML_RESTRAT_COEF. If MLE_FRONT_LENGTH is !! non-zero, it is recommended to set FOX_KEMPER_ML_RESTRAT_COEF=1.0. + logical :: fl_from_file !< If true, read the MLE front-length scale from a netCDF file. logical :: MLE_use_PBL_MLD !< If true, use the MLD provided by the PBL parameterization. !! if false, MLE will calculate a MLD based on a density difference !! based on the parameter MLE_DENSITY_DIFF. + logical :: Bodner_detect_MLD !< If true, detect the MLD based on given density difference criterion + !! (MLE_DENSITY_DIFF) in the Bodner et al. parameterization. + real :: vonKar !< The von Karman constant as used for mixed layer viscosity [nondim] real :: MLE_MLD_decay_time !< Time-scale to use in a running-mean when MLD is retreating [T ~> s]. real :: MLE_MLD_decay_time2 !< Time-scale to use in a running-mean when filtered MLD is retreating [T ~> s]. real :: MLE_density_diff !< Density difference used in detecting mixed-layer depth [R ~> kg m-3]. @@ -57,13 +68,56 @@ module MOM_mixed_layer_restrat !! the mixed-layer [nondim]. real :: MLE_MLD_stretch !< A scaling coefficient for stretching/shrinking the MLD used in !! the MLE scheme [nondim]. This simply multiplies MLD wherever used. + + ! The following parameters are used in the Bodner et al., 2023, parameterization + logical :: use_Bodner = .false. !< If true, use the Bodner et al., 2023, parameterization. + real :: Cr !< Efficiency coefficient from Bodner et al., 2023 [nondim] + real :: mstar !< The m* value used to estimate the turbulent vertical momentum flux [nondim] + real :: nstar !< The n* value used to estimate the turbulent vertical momentum flux [nondim] + real :: min_wstar2 !< The minimum lower bound to apply to the vertical momentum flux, + !! w'u', in the Bodner et al., restratification parameterization + !! [Z2 T-2 ~> m2 s-2]. This avoids a division-by-zero in the limit when u* + !! and the buoyancy flux are zero. + real :: BLD_growing_Tfilt !< The time-scale for a running-mean filter applied to the boundary layer + !! depth (BLD) when the BLD is deeper than the running mean [T ~> s]. + !! A value of 0 instantaneously sets the running mean to the current value of BLD. + real :: BLD_decaying_Tfilt !< The time-scale for a running-mean filter applied to the boundary layer + !! depth (BLD) when the BLD is shallower than the running mean [T ~> s]. + !! A value of 0 instantaneously sets the running mean to the current value of BLD. + real :: MLD_decaying_Tfilt !< The time-scale for a running-mean filter applied to the time-filtered + !! MLD, when the latter is shallower than the running mean [T ~> s]. + !! A value of 0 instantaneously sets the running mean to the current value of MLD. + real :: MLD_growing_Tfilt !< The time-scale for a running-mean filter applied to the time-filtered + !! MLD, when the latter is deeper than the running mean [T ~> s]. + !! A value of 0 instantaneously sets the running mean to the current value of MLD. + integer :: answer_date !< The vintage of the order of arithmetic and expressions in the + !! mixed layer restrat calculations. Values below 20240201 recover + !! the answers from the end of 2023, while higher values use the new + !! cuberoot function in the Bodner code to avoid needing to undo + !! dimensional rescaling. + logical :: debug = .false. !< If true, calculate checksums of fields for debugging. + type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. + type(external_field) :: sbc_fl !< A handle used in time interpolation of + !! front-length scales read from a file. + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + logical :: use_Stanley_ML !< If true, use the Stanley parameterization of SGS T variance + real :: ustar_min !< A minimum value of ustar in thickness units to avoid numerical + !! problems [H T-1 ~> m s-1 or kg m-2 s-1] + real :: Kv_restrat !< A viscosity that sets a floor on the momentum mixing rate + !! during restratification, rescaled into thickness-based + !! units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1] + logical :: MLD_grid !< If true, read a spacially varying field for MLD_decaying_Tfilt + logical :: Cr_grid !< If true, read a spacially varying field for Cr real, dimension(:,:), allocatable :: & MLD_filtered, & !< Time-filtered MLD [H ~> m or kg m-2] - MLD_filtered_slow !< Slower time-filtered MLD [H ~> m or kg m-2] + MLD_filtered_slow, & !< Slower time-filtered MLD [H ~> m or kg m-2] + wpup_filtered, & !< Time-filtered vertical momentum flux [H L T-2 ~> m2 s-2 or kg m-1 s-2] + MLD_Tfilt_space, & !< Spatially varying time scale for MLD filter [T ~> s] + Cr_space !< Spatially varying Cr coefficient [nondim] !>@{ !! Diagnostic identifier @@ -72,11 +126,17 @@ module MOM_mixed_layer_restrat integer :: id_uhml = -1 integer :: id_vhml = -1 integer :: id_MLD = -1 + integer :: id_BLD = -1 integer :: id_Rml = -1 integer :: id_uDml = -1 integer :: id_vDml = -1 integer :: id_uml = -1 integer :: id_vml = -1 + integer :: id_wpup = -1 + integer :: id_ustar = -1 + integer :: id_bflux = -1 + integer :: id_lfbod = -1 + integer :: id_mle_fl = -1 !>@} end type mixedlayer_restrat_CS @@ -88,7 +148,7 @@ module MOM_mixed_layer_restrat !> Driver for the mixed-layer restratification parameterization. !! The code branches between two different implementations depending !! on whether the bulk-mixed layer or a general coordinate are in use. -subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt, MLD, VarMix, G, GV, US, CS) +subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt, MLD, h_MLD, bflux, VarMix, G, GV, US, CS) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -101,23 +161,34 @@ subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt, MLD, VarMix, G, GV, type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces real, intent(in) :: dt !< Time increment [T ~> s] real, dimension(:,:), pointer :: MLD !< Mixed layer depth provided by the - !! PBL scheme [Z ~> m] - type(VarMix_CS), intent(in) :: VarMix !< Variable mixing control struct + !! planetary boundary layer scheme [Z ~> m] + real, dimension(:,:), pointer :: h_MLD !< Mixed layer thickness provided + !! by the planetary boundary layer + !! scheme [H ~> m or kg m-2] + real, dimension(:,:), pointer :: bflux !< Surface buoyancy flux provided by the + !! PBL scheme [Z2 T-3 ~> m2 s-3] + type(VarMix_CS), intent(in) :: VarMix !< Variable mixing control structure type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure - if (.not. CS%initialized) call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & + + if (.not. CS%initialized) call MOM_error(FATAL, "mixedlayer_restrat: "// & "Module must be initialized before it is used.") if (GV%nkml>0) then + ! Original form, written for the isopycnal model with a bulk mixed layer call mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) + elseif (CS%use_Bodner) then + ! Implementation of Bodner et al., 2023 + call mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, dt, MLD, h_MLD, bflux) else - call mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD, VarMix, G, GV, US, CS) + ! Implementation of Fox-Kemper et al., 2008, to work in general coordinates + call mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, VarMix, G, GV, US, CS) endif end subroutine mixedlayer_restrat -!> Calculates a restratifying flow in the mixed layer. -subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, G, GV, US, CS) +!> Calculates a restratifying flow in the mixed layer, following the formulation used in OM4 +subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, VarMix, G, GV, US, CS) ! Arguments type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure @@ -130,131 +201,124 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables structure type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces real, intent(in) :: dt !< Time increment [T ~> s] - real, dimension(:,:), pointer :: MLD_in !< Mixed layer depth provided by the - !! PBL scheme [Z ~> m] (not H) - type(VarMix_CS), intent(in) :: VarMix !< Variable mixing control struct + real, dimension(:,:), pointer :: h_MLD !< Thickness of water within the + !! mixed layer depth provided by + !! the PBL scheme [H ~> m or kg m-2] + type(VarMix_CS), intent(in) :: VarMix !< Variable mixing control structure type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure + ! Local variables - real :: uhml(SZIB_(G),SZJ_(G),SZK_(GV)) ! zonal mixed layer transport [H L2 T-1 ~> m3 s-1 or kg s-1] - real :: vhml(SZI_(G),SZJB_(G),SZK_(GV)) ! merid mixed layer transport [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: uhml(SZIB_(G),SZJ_(G),SZK_(GV)) ! Restratifying zonal thickness transports [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vhml(SZI_(G),SZJB_(G),SZK_(GV)) ! Restratifying meridional thickness transports [H L2 T-1 ~> m3 s-1 or kg s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & h_avail ! The volume available for diffusion out of each face of each ! sublayer of the mixed layer, divided by dt [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G),SZJ_(G)) :: & + U_star_2d, & ! The wind friction velocity in thickness-based units, calculated using + ! the Boussinesq reference density or the time-evolving surface density + ! in non-Boussinesq mode [H T-1 ~> m s-1 or kg m-2 s-1] MLD_fast, & ! Mixed layer depth actually used in MLE restratification parameterization [H ~> m or kg m-2] htot_fast, & ! The sum of the thicknesses of layers in the mixed layer [H ~> m or kg m-2] - Rml_av_fast, & ! g_Rho0 times the average mixed layer density [L2 Z-1 T-2 ~> m s-2] - MLD_slow, & ! Mixed layer depth actually used in MLE restratification parameterization [H ~> m or kg m-2] + Rml_av_fast, & ! Negative g_Rho0 times the average mixed layer density or G_Earth + ! times the average specific volume [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2] + MLD_slow, & ! Mixed layer depth actually used in MLE restratification parameterization [H ~> m or kg m-2] + mle_fl_2d, & ! MLE frontal length-scale [L ~> m] htot_slow, & ! The sum of the thicknesses of layers in the mixed layer [H ~> m or kg m-2] - Rml_av_slow ! g_Rho0 times the average mixed layer density [L2 Z-1 T-2 ~> m s-2] - real :: g_Rho0 ! G_Earth/Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] + Rml_av_slow ! Negative g_Rho0 times the average mixed layer density or G_Earth + ! times the average specific volume [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2] + real :: g_Rho0 ! G_Earth/Rho0 times a thickness conversion factor + ! [L2 H-1 T-2 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2] real :: rho_ml(SZI_(G)) ! Potential density relative to the surface [R ~> kg m-3] + real :: rml_int_fast(SZI_(G)) ! The integral of density over the mixed layer depth [R H ~> kg m-2 or kg2 m-5] + real :: rml_int_slow(SZI_(G)) ! The integral of density over the mixed layer depth [R H ~> kg m-2 or kg2 m-5] + real :: SpV_ml(SZI_(G)) ! Specific volume evaluated at the surface pressure [R-1 ~> m3 kg-1] + real :: SpV_int_fast(SZI_(G)) ! Specific volume integrated through the mixed layer [H R-1 ~> m4 kg-1 or m] + real :: SpV_int_slow(SZI_(G)) ! Specific volume integrated through the mixed layer [H R-1 ~> m4 kg-1 or m] real :: p0(SZI_(G)) ! A pressure of 0 [R L2 T-2 ~> Pa] - real :: h_vel ! htot interpolated onto velocity points [Z ~> m] (not H). + real :: h_vel ! htot interpolated onto velocity points [H ~> m or kg m-2] real :: absf ! absolute value of f, interpolated to velocity points [T-1 ~> s-1] - real :: u_star ! surface friction velocity, interpolated to velocity points [Z T-1 ~> m s-1]. + real :: u_star ! surface friction velocity, interpolated to velocity points and recast into + ! thickness-based units [H T-1 ~> m s-1 or kg m-2 s-1]. real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer [T-1 ~> s-1] real :: timescale ! mixing growth timescale [T ~> s] + real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. real :: h_neglect ! tiny thickness usually lost in roundoff so can be neglected [H ~> m or kg m-2] - real :: dz_neglect ! A tiny thickness that is usually lost in roundoff so can be neglected [Z ~> m] real :: I4dt ! 1/(4 dt) [T-1 ~> s-1] - real :: Ihtot,Ihtot_slow! Inverses of the total mixed layer thickness [H-1 ~> m-1 or m2 kg-1] + real :: Ihtot, Ihtot_slow ! Inverses of the total mixed layer thickness [H-1 ~> m-1 or m2 kg-1] real :: a(SZK_(GV)) ! A non-dimensional value relating the overall flux ! magnitudes (uDml & vDml) to the realized flux in a - ! layer. The vertical sum of a() through the pieces of + ! layer [nondim]. The vertical sum of a() through the pieces of ! the mixed layer must be 0. - real :: b(SZK_(GV)) ! As for a(k) but for the slow-filtered MLD - real :: uDml(SZIB_(G)) ! The zonal and meridional volume fluxes in the upper - real :: vDml(SZI_(G)) ! half of the mixed layer [H L2 T-1 ~> m3 s-1 or kg s-1]. - real :: uDml_slow(SZIB_(G)) ! The zonal and meridional volume fluxes in the upper - real :: vDml_slow(SZI_(G)) ! half of the mixed layer [H L2 T-1 ~> m3 s-1 or kg s-1]. - real :: utimescale_diag(SZIB_(G),SZJ_(G)) ! restratification timescales in the zonal and - real :: vtimescale_diag(SZI_(G),SZJB_(G)) ! meridional directions [T ~> s], stored in 2-D arrays - ! for diagnostic purposes. - real :: uDml_diag(SZIB_(G),SZJ_(G)), vDml_diag(SZI_(G),SZJB_(G)) - real, dimension(SZI_(G)) :: rhoSurf, deltaRhoAtKm1, deltaRhoAtK ! Densities [R ~> kg m-3] - real, dimension(SZI_(G)) :: dK, dKm1 ! Depths of layer centers [H ~> m or kg m-2]. - real, dimension(SZI_(G)) :: pRef_MLD ! A reference pressure for calculating the mixed layer - ! densities [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G)) :: rhoAtK, rho1, d1, pRef_N2 ! Used for N2 + real :: b(SZK_(GV)) ! As for a(k) but for the slow-filtered MLD [nondim] + real :: uDml(SZIB_(G)) ! Zonal volume fluxes in the upper half of the mixed layer [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vDml(SZI_(G)) ! Meridional volume fluxes in the upper half of the mixed layer [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: uDml_slow(SZIB_(G)) ! Zonal volume fluxes in the upper half of the boundary layer to + ! restratify the time-filtered boundary layer depth [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vDml_slow(SZI_(G)) ! Meridional volume fluxes in the upper half of the boundary layer to + ! restratify the time-filtered boundary layer depth [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: utimescale_diag(SZIB_(G),SZJ_(G)) ! Zonal restratification timescale [T ~> s], stored for diagnostics. + real :: vtimescale_diag(SZI_(G),SZJB_(G)) ! Meridional restratification timescale [T ~> s], stored for diagnostics. + real :: uDml_diag(SZIB_(G),SZJ_(G)) ! A 2D copy of uDml for diagnostics [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vDml_diag(SZI_(G),SZJB_(G)) ! A 2D copy of vDml for diagnostics [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G)) :: covTS, & ! SGS TS covariance in Stanley param; currently 0 [C S ~> degC ppt] + varS ! SGS S variance in Stanley param; currently 0 [S2 ~> ppt2] real :: aFac, bFac ! Nondimensional ratios [nondim] - real :: ddRho ! A density difference [R ~> kg m-3] - real :: hAtVel, zpa, zpb, dh, res_scaling_fac - real :: I_LFront ! The inverse of the frontal length scale [L-1 ~> m-1] + real :: hAtVel ! Thickness at the velocity points [H ~> m or kg m-2] + real :: zpa ! Fractional position within the mixed layer of the interface above a layer [nondim] + real :: zpb ! Fractional position within the mixed layer of the interface below a layer [nondim] + real :: dh ! Portion of the layer thickness that is in the mixed layer [H ~> m or kg m-2] + real :: res_scaling_fac ! The resolution-dependent scaling factor [nondim] + real :: lfront ! Frontal length scale at velocity points [L ~> m] + real :: I_LFront ! The inverse of the frontal length scale [L-1 ~> m-1] + real :: vonKar_x_pi2 ! A scaling constant that is approximately the von Karman constant times + ! pi squared [nondim] + character(len=128) :: mesg logical :: line_is_empty, keep_going, res_upscale integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - real :: PSI, PSI1, z, BOTTOP, XP, DD ! For the following statement functions - ! Stream function as a function of non-dimensional position within mixed-layer (F77 statement function) - !PSI1(z) = max(0., (1. - (2.*z+1.)**2 ) ) - PSI1(z) = max(0., (1. - (2.*z+1.)**2 ) * (1. + (5./21.)*(2.*z+1.)**2) ) - BOTTOP(z) = 0.5*(1.-SIGN(1.,z+0.5)) ! =0 for z>-0.5, =1 for z<-0.5 - XP(z) = max(0., min(1., (-z-0.5)*2./(1.+2.*CS%MLE_tail_dh) ) ) - DD(z) = (1.-3.*(XP(z)**2)+2.*(XP(z)**3))**(1.+2.*CS%MLE_tail_dh) - PSI(z) = max( PSI1(z), DD(z)*BOTTOP(z) ) ! Combines original PSI1 with tail - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - if (.not.associated(tv%eqn_of_state)) call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & + h_min = 0.5*GV%Angstrom_H ! This should be GV%Angstrom_H, but that value would change answers. + covTS(:) = 0.0 !!Functionality not implemented yet; in future, should be passed in tv + varS(:) = 0.0 + mle_fl_2d(:,:) = 0.0 + vonKar_x_pi2 = CS%vonKar * 9.8696 + + if (.not.associated(tv%eqn_of_state)) call MOM_error(FATAL, "mixedlayer_restrat_OM4: "// & "An equation of state must be used with this module.") if (.not. allocated(VarMix%Rd_dx_h) .and. CS%front_length > 0.) & - call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & + call MOM_error(FATAL, "mixedlayer_restrat_OM4: "// & "The resolution argument, Rd/dx, was not associated.") + if (CS%use_Stanley_ML .and. .not.GV%Boussinesq) call MOM_error(FATAL, & + "MOM_mixedlayer_restrat: The Stanley parameterization is not "//& + "available without the Boussinesq approximation.") + + ! Extract the friction velocity from the forcing type. + call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1, H_T_units=.true.) if (CS%MLE_density_diff > 0.) then ! We need to calculate a mixed layer depth, MLD. - !! TODO: use derivatives and mid-MLD pressure. Currently this is sigma-0. -AJA - pRef_MLD(:) = 0. - EOSdom(:) = EOS_domain(G%HI, halo=1) - do j = js-1, je+1 - dK(:) = 0.5 * h(:,j,1) ! Depth of center of surface layer - call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, tv%eqn_of_state, EOSdom) - deltaRhoAtK(:) = 0. - MLD_fast(:,j) = 0. - do k = 2, nz - dKm1(:) = dK(:) ! Depth of center of layer K-1 - dK(:) = dK(:) + 0.5 * ( h(:,j,k) + h(:,j,k-1) ) ! Depth of center of layer K - ! Mixed-layer depth, using sigma-0 (surface reference pressure) - deltaRhoAtKm1(:) = deltaRhoAtK(:) ! Store value from previous iteration of K - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, tv%eqn_of_state, EOSdom) - do i = is-1,ie+1 - deltaRhoAtK(i) = deltaRhoAtK(i) - rhoSurf(i) ! Density difference between layer K and surface - enddo - do i = is-1, ie+1 - ddRho = deltaRhoAtK(i) - deltaRhoAtKm1(i) - if ((MLD_fast(i,j)==0.) .and. (ddRho>0.) .and. & - (deltaRhoAtKm1(i)=CS%MLE_density_diff)) then - aFac = ( CS%MLE_density_diff - deltaRhoAtKm1(i) ) / ddRho - MLD_fast(i,j) = dK(i) * aFac + dKm1(i) * (1. - aFac) - endif - enddo ! i-loop - enddo ! k-loop - do i = is-1, ie+1 - MLD_fast(i,j) = CS%MLE_MLD_stretch * MLD_fast(i,j) - if ((MLD_fast(i,j)==0.) .and. (deltaRhoAtK(i)0.) then if (CS%debug) then - call hchksum(CS%MLD_filtered, 'mixed_layer_restrat: MLD_filtered', G%HI, haloshift=1, scale=GV%H_to_m) - call hchksum(MLD_in, 'mixed_layer_restrat: MLD in', G%HI, haloshift=1, scale=US%Z_to_m) + call hchksum(CS%MLD_filtered, 'mixed_layer_restrat: MLD_filtered', G%HI, haloshift=1, unscale=GV%H_to_mks) + call hchksum(h_MLD, 'mixed_layer_restrat: MLD in', G%HI, haloshift=1, unscale=GV%H_to_mks) endif aFac = CS%MLE_MLD_decay_time / ( dt + CS%MLE_MLD_decay_time ) bFac = dt / ( dt + CS%MLE_MLD_decay_time ) - do j = js-1, je+1 ; do i = is-1, ie+1 + do j=js-1,je+1 ; do i=is-1,ie+1 ! Expression bFac*MLD_fast(i,j) + aFac*CS%MLD_filtered(i,j) is the time-filtered ! (running mean) of MLD. The max() allows the "running mean" to be reset ! instantly to a deeper MLD. @@ -266,12 +330,13 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var ! Apply slower time filter (to remove seasonal cycle) on already filtered MLD_fast if (CS%MLE_MLD_decay_time2>0.) then if (CS%debug) then - call hchksum(CS%MLD_filtered_slow,'mixed_layer_restrat: MLD_filtered_slow',G%HI,haloshift=1,scale=GV%H_to_m) - call hchksum(MLD_fast,'mixed_layer_restrat: MLD fast',G%HI,haloshift=1,scale=GV%H_to_m) + call hchksum(CS%MLD_filtered_slow, 'mixed_layer_restrat: MLD_filtered_slow', G%HI, & + haloshift=1, unscale=GV%H_to_mks) + call hchksum(MLD_fast, 'mixed_layer_restrat: MLD fast', G%HI, haloshift=1, unscale=GV%H_to_mks) endif aFac = CS%MLE_MLD_decay_time2 / ( dt + CS%MLE_MLD_decay_time2 ) bFac = dt / ( dt + CS%MLE_MLD_decay_time2 ) - do j = js-1, je+1 ; do i = is-1, ie+1 + do j=js-1,je+1 ; do i=is-1,ie+1 ! Expression bFac*MLD_fast(i,j) + aFac*CS%MLD_filtered(i,j) is the time-filtered ! (running mean) of MLD. The max() allows the "running mean" to be reset ! instantly to a deeper MLD. @@ -279,7 +344,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var MLD_slow(i,j) = CS%MLD_filtered_slow(i,j) enddo ; enddo else - do j = js-1, je+1 ; do i = is-1, ie+1 + do j=js-1,je+1 ; do i=is-1,ie+1 MLD_slow(i,j) = MLD_fast(i,j) enddo ; enddo endif @@ -287,71 +352,132 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var uDml(:) = 0.0 ; vDml(:) = 0.0 uDml_slow(:) = 0.0 ; vDml_slow(:) = 0.0 I4dt = 0.25 / dt - g_Rho0 = GV%g_Earth / GV%Rho0 + g_Rho0 = GV%H_to_Z * GV%g_Earth / GV%Rho0 h_neglect = GV%H_subroundoff - dz_neglect = GV%H_subroundoff*GV%H_to_Z if (CS%front_length>0.) then res_upscale = .true. - I_LFront = 1. / CS%front_length + do j=js-1,je+1 ; do i=is-1,ie+1 + mle_fl_2d(i,j) = CS%front_length + enddo ; enddo + elseif (CS%front_length == 0. .and. CS%fl_from_file) then + res_upscale = .true. + call time_interp_external(CS%sbc_fl, CS%Time, mle_fl_2d, turns=G%HI%turns, scale=US%m_to_L) + call pass_var(mle_fl_2d, G%domain, halo=1) + do j=js,je ; do i=is,ie + if ((G%mask2dT(i,j) > 0.0) .and. (mle_fl_2d(i,j) < 0.0)) then + write(mesg,'(" Time_interp negative MLE frontal-length scale of ",(1pe12.4)," at i,j = ",& + & I0,", ",I0," lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') & + mle_fl_2d(i,j), i, j, G%geoLonT(i,j), G%geoLatT(i,j) + call MOM_error(FATAL, "MOM_mixed_layer_restrat mixedlayer_restrat_OM4: "//trim(mesg)) + endif + enddo ; enddo else res_upscale = .false. endif p0(:) = 0.0 EOSdom(:) = EOS_domain(G%HI, halo=1) -!$OMP parallel default(none) shared(is,ie,js,je,G,GV,US,htot_fast,Rml_av_fast,tv,p0,h,h_avail,& -!$OMP h_neglect,g_Rho0,I4dt,CS,uhml,uhtr,dt,vhml,vhtr,EOSdom, & -!$OMP utimescale_diag,vtimescale_diag,forces,dz_neglect, & -!$OMP htot_slow,MLD_slow,Rml_av_slow,VarMix,I_LFront, & -!$OMP res_upscale, nz,MLD_fast,uDml_diag,vDml_diag) & -!$OMP private(rho_ml,h_vel,u_star,absf,mom_mixrate,timescale, & -!$OMP line_is_empty, keep_going,res_scaling_fac, & -!$OMP a,IhTot,b,Ihtot_slow,zpb,hAtVel,zpa,dh) & -!$OMP firstprivate(uDml,vDml,uDml_slow,vDml_slow) -!$OMP do - do j=js-1,je+1 - do i=is-1,ie+1 - htot_fast(i,j) = 0.0 ; Rml_av_fast(i,j) = 0.0 - htot_slow(i,j) = 0.0 ; Rml_av_slow(i,j) = 0.0 - enddo - keep_going = .true. - do k=1,nz + !$OMP parallel default(shared) private(rho_ml,h_vel,u_star,absf,mom_mixrate,timescale, & + !$OMP SpV_ml,SpV_int_fast,SpV_int_slow,Rml_int_fast,Rml_int_slow, & + !$OMP line_is_empty,keep_going,res_scaling_fac, & + !$OMP a,IhTot,b,Ihtot_slow,zpb,hAtVel,zpa,dh,lfront,I_LFront) & + !$OMP firstprivate(uDml,vDml,uDml_slow,vDml_slow) + + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + !$OMP do + do j=js-1,je+1 do i=is-1,ie+1 - h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) + htot_fast(i,j) = 0.0 ; Rml_int_fast(i) = 0.0 + htot_slow(i,j) = 0.0 ; Rml_int_slow(i) = 0.0 enddo - if (keep_going) then - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, rho_ml(:), tv%eqn_of_state, EOSdom) - line_is_empty = .true. + keep_going = .true. + do k=1,nz do i=is-1,ie+1 - if (htot_fast(i,j) < MLD_fast(i,j)) then - dh = min( h(i,j,k), MLD_fast(i,j)-htot_fast(i,j) ) - Rml_av_fast(i,j) = Rml_av_fast(i,j) + dh*rho_ml(i) - htot_fast(i,j) = htot_fast(i,j) + dh - line_is_empty = .false. - endif - if (htot_slow(i,j) < MLD_slow(i,j)) then - dh = min( h(i,j,k), MLD_slow(i,j)-htot_slow(i,j) ) - Rml_av_slow(i,j) = Rml_av_slow(i,j) + dh*rho_ml(i) - htot_slow(i,j) = htot_slow(i,j) + dh - line_is_empty = .false. - endif + h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) enddo - if (line_is_empty) keep_going=.false. - endif + if (keep_going) then + if (CS%use_Stanley_ML) then + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, tv%varT(:,j,k), covTS, varS, & + rho_ml(:), tv%eqn_of_state, EOSdom) + else + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, rho_ml(:), tv%eqn_of_state, EOSdom) + endif + line_is_empty = .true. + do i=is-1,ie+1 + if (htot_fast(i,j) < MLD_fast(i,j)) then + dh = min( h(i,j,k), MLD_fast(i,j)-htot_fast(i,j) ) + Rml_int_fast(i) = Rml_int_fast(i) + dh*rho_ml(i) + htot_fast(i,j) = htot_fast(i,j) + dh + line_is_empty = .false. + endif + if (htot_slow(i,j) < MLD_slow(i,j)) then + dh = min( h(i,j,k), MLD_slow(i,j)-htot_slow(i,j) ) + Rml_int_slow(i) = Rml_int_slow(i) + dh*rho_ml(i) + htot_slow(i,j) = htot_slow(i,j) + dh + line_is_empty = .false. + endif + enddo + if (line_is_empty) keep_going=.false. + endif + enddo + + do i=is-1,ie+1 + Rml_av_fast(i,j) = -(g_Rho0*Rml_int_fast(i)) / (htot_fast(i,j) + h_neglect) + Rml_av_slow(i,j) = -(g_Rho0*Rml_int_slow(i)) / (htot_slow(i,j) + h_neglect) + enddo enddo + else ! This is only used in non-Boussinesq mode. + !$OMP do + do j=js-1,je+1 + do i=is-1,ie+1 + htot_fast(i,j) = 0.0 ; SpV_int_fast(i) = 0.0 + htot_slow(i,j) = 0.0 ; SpV_int_slow(i) = 0.0 + enddo + keep_going = .true. + do k=1,nz + do i=is-1,ie+1 + h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) + enddo + if (keep_going) then + ! if (CS%use_Stanley_ML) then ! This is not implemented yet in the EoS code. + ! call calculate_spec_vol(tv%T(:,j,k), tv%S(:,j,k), p0, tv%varT(:,j,k), covTS, varS, & + ! rho_ml(:), tv%eqn_of_state, EOSdom) + ! else + call calculate_spec_vol(tv%T(:,j,k), tv%S(:,j,k), p0, SpV_ml, tv%eqn_of_state, EOSdom) + ! endif + line_is_empty = .true. + do i=is-1,ie+1 + if (htot_fast(i,j) < MLD_fast(i,j)) then + dh = min( h(i,j,k), MLD_fast(i,j)-htot_fast(i,j) ) + SpV_int_fast(i) = SpV_int_fast(i) + dh*SpV_ml(i) + htot_fast(i,j) = htot_fast(i,j) + dh + line_is_empty = .false. + endif + if (htot_slow(i,j) < MLD_slow(i,j)) then + dh = min( h(i,j,k), MLD_slow(i,j)-htot_slow(i,j) ) + SpV_int_slow(i) = SpV_int_slow(i) + dh*SpV_ml(i) + htot_slow(i,j) = htot_slow(i,j) + dh + line_is_empty = .false. + endif + enddo + if (line_is_empty) keep_going=.false. + endif + enddo - do i=is-1,ie+1 - Rml_av_fast(i,j) = -(g_Rho0*Rml_av_fast(i,j)) / (htot_fast(i,j) + h_neglect) - Rml_av_slow(i,j) = -(g_Rho0*Rml_av_slow(i,j)) / (htot_slow(i,j) + h_neglect) + ! Convert the vertically integrated specific volume into a positive variable with units of density. + do i=is-1,ie+1 + Rml_av_fast(i,j) = (GV%H_to_RZ*GV%g_Earth * SpV_int_fast(i)) / (htot_fast(i,j) + h_neglect) + Rml_av_slow(i,j) = (GV%H_to_RZ*GV%g_Earth * SpV_int_slow(i)) / (htot_slow(i,j) + h_neglect) + enddo enddo - enddo + endif if (CS%debug) then - call hchksum(h,'mixed_layer_restrat: h', G%HI, haloshift=1, scale=GV%H_to_m) - call hchksum(forces%ustar,'mixed_layer_restrat: u*', G%HI, haloshift=1, scale=US%Z_to_m*US%s_to_T) - call hchksum(MLD_fast,'mixed_layer_restrat: MLD', G%HI, haloshift=1, scale=GV%H_to_m) - call hchksum(Rml_av_fast,'mixed_layer_restrat: rml', G%HI, haloshift=1, & - scale=US%m_to_Z*US%L_T_to_m_s**2) + call hchksum(h, 'mixed_layer_restrat: h', G%HI, haloshift=1, unscale=GV%H_to_mks) + call hchksum(U_star_2d, 'mixed_layer_restrat: u*', G%HI, haloshift=1, unscale=GV%H_to_m*US%s_to_T) + call hchksum(MLD_fast, 'mixed_layer_restrat: MLD', G%HI, haloshift=1, unscale=GV%H_to_mks) + call hchksum(Rml_av_fast, 'mixed_layer_restrat: rml', G%HI, haloshift=1, & + unscale=GV%m_to_H*US%L_T_to_m_s**2) endif ! TO DO: @@ -359,35 +485,50 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var ! 2. Add exponential tail to stream-function? ! U - Component -!$OMP do + !$OMP do do j=js,je ; do I=is-1,ie - u_star = 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j)) + u_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i+1,j))) + absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) + ! Compute I_LFront = 1 / (frontal length scale) [L-1 ~> m-1] + lfront = 0.5 * (mle_fl_2d(i,j) + mle_fl_2d(i+1,j)) + ! Adcroft reciprocal + I_LFront = 0.0 ; if (lfront /= 0.0) I_LFront = 1.0/lfront ! If needed, res_scaling_fac = min( ds, L_d ) / l_f if (res_upscale) res_scaling_fac = & - ( sqrt( 0.5 * ( G%dxCu(I,j)**2 + G%dyCu(I,j)**2 ) ) * I_LFront ) & + ( sqrt( 0.5 * ( (G%dxCu(I,j)**2) + (G%dyCu(I,j)**2) ) ) * I_LFront ) & * min( 1., 0.5*( VarMix%Rd_dx_h(i,j) + VarMix%Rd_dx_h(i+1,j) ) ) - ! peak ML visc: u_star * 0.41 * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) + ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) ! momentum mixing rate: pi^2*visc/h_ml^2 - ! 0.41 is the von Karmen constant, 9.8696 = pi^2. - h_vel = 0.5*((htot_fast(i,j) + htot_fast(i+1,j)) + h_neglect) * GV%H_to_Z - mom_mixrate = (0.41*9.8696)*u_star**2 / & - (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + h_vel = 0.5*((htot_fast(i,j) + htot_fast(i+1,j)) + h_neglect) + + ! NOTE: growth_time changes answers on some systems, see below. + ! timescale = growth_time(u_star, h_vel, absf, h_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + + mom_mixrate = vonKar_x_pi2*u_star**2 / & + (absf*h_vel**2 + 4.0*(h_vel+h_neglect)*u_star) timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) timescale = timescale * CS%ml_restrat_coef + if (res_upscale) timescale = timescale * res_scaling_fac - uDml(I) = timescale * G%mask2dCu(I,j)*G%dyCu(I,j)*G%IdxCu(I,j) * & - (Rml_av_fast(i+1,j)-Rml_av_fast(i,j)) * (h_vel**2 * GV%Z_to_H) + uDml(I) = timescale * G%dyCu(I,j)*G%IdxCu_OBCmask(I,j) * & + (Rml_av_fast(i+1,j)-Rml_av_fast(i,j)) * (h_vel**2) + ! As above but using the slow filtered MLD - h_vel = 0.5*((htot_slow(i,j) + htot_slow(i+1,j)) + h_neglect) * GV%H_to_Z - mom_mixrate = (0.41*9.8696)*u_star**2 / & - (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + h_vel = 0.5*((htot_slow(i,j) + htot_slow(i+1,j)) + h_neglect) + + ! NOTE: growth_time changes answers on some systems, see below. + ! timescale = growth_time(u_star, h_vel, absf, h_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef2) + + mom_mixrate = vonKar_x_pi2*u_star**2 / & + (absf*h_vel**2 + 4.0*(h_vel+h_neglect)*u_star) timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) timescale = timescale * CS%ml_restrat_coef2 + if (res_upscale) timescale = timescale * res_scaling_fac - uDml_slow(I) = timescale * G%mask2dCu(I,j)*G%dyCu(I,j)*G%IdxCu(I,j) * & - (Rml_av_slow(i+1,j)-Rml_av_slow(i,j)) * (h_vel**2 * GV%Z_to_H) + uDml_slow(I) = timescale * G%dyCu(I,j)*G%IdxCu_OBCmask(I,j) * & + (Rml_av_slow(i+1,j)-Rml_av_slow(i,j)) * (h_vel**2) if (uDml(I) + uDml_slow(I) == 0.) then do k=1,nz ; uhml(I,j,k) = 0.0 ; enddo @@ -399,9 +540,9 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var ! The sum of a(k) through the mixed layers must be 0. do k=1,nz hAtVel = 0.5*(h(i,j,k) + h(i+1,j,k)) - a(k) = PSI(zpa) ! Psi(z/MLD) for upper interface - zpa = zpa - (hAtVel * IhTot) ! z/H for lower interface - a(k) = a(k) - PSI(zpa) ! Transport profile + a(k) = mu(zpa, CS%MLE_tail_dh) ! mu(z/MLD) for upper interface + zpa = zpa - (hAtVel * IhTot) ! z/H for lower interface + a(k) = a(k) - mu(zpa, CS%MLE_tail_dh) ! Transport profile ! Limit magnitude (uDml) if it would violate CFL if (a(k)*uDml(I) > 0.0) then if (a(k)*uDml(I) > h_avail(i,j,k)) uDml(I) = h_avail(i,j,k) / a(k) @@ -412,9 +553,9 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var do k=1,nz ! Transport for slow-filtered MLD hAtVel = 0.5*(h(i,j,k) + h(i+1,j,k)) - b(k) = PSI(zpb) ! Psi(z/MLD) for upper interface - zpb = zpb - (hAtVel * IhTot_slow) ! z/H for lower interface - b(k) = b(k) - PSI(zpb) ! Transport profile + b(k) = mu(zpb, CS%MLE_tail_dh) ! mu(z/MLD) for upper interface + zpb = zpb - (hAtVel * IhTot_slow) ! z/H for lower interface + b(k) = b(k) - mu(zpb, CS%MLE_tail_dh) ! Transport profile ! Limit magnitude (uDml_slow) if it would violate CFL when added to uDml if (b(k)*uDml_slow(I) > 0.0) then if (b(k)*uDml_slow(I) > h_avail(i,j,k) - a(k)*uDml(I)) & @@ -435,35 +576,49 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var enddo ; enddo ! V- component -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie - u_star = 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1)) + u_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i,j+1))) + ! Compute I_LFront = 1 / (frontal length scale) [L-1 ~> m-1] + lfront = 0.5 * (mle_fl_2d(i,j) + mle_fl_2d(i,j+1)) + ! Adcroft reciprocal + I_LFront = 0.0 ; if (lfront /= 0.0) I_LFront = 1.0/lfront absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) ! If needed, res_scaling_fac = min( ds, L_d ) / l_f if (res_upscale) res_scaling_fac = & - ( sqrt( 0.5 * ( (G%dxCv(i,J))**2 + (G%dyCv(i,J))**2 ) ) * I_LFront ) & + ( sqrt( 0.5 * ( (G%dxCv(i,J)**2) + (G%dyCv(i,J)**2) ) ) * I_LFront ) & * min( 1., 0.5*( VarMix%Rd_dx_h(i,j) + VarMix%Rd_dx_h(i,j+1) ) ) - ! peak ML visc: u_star * 0.41 * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) + ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) ! momentum mixing rate: pi^2*visc/h_ml^2 - ! 0.41 is the von Karmen constant, 9.8696 = pi^2. - h_vel = 0.5*((htot_fast(i,j) + htot_fast(i,j+1)) + h_neglect) * GV%H_to_Z - mom_mixrate = (0.41*9.8696)*u_star**2 / & - (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + h_vel = 0.5*((htot_fast(i,j) + htot_fast(i,j+1)) + h_neglect) + + ! NOTE: growth_time changes answers on some systems, see below. + ! timescale = growth_time(u_star, h_vel, absf, h_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + + mom_mixrate = vonKar_x_pi2*u_star**2 / & + (absf*h_vel**2 + 4.0*(h_vel+h_neglect)*u_star) timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) timescale = timescale * CS%ml_restrat_coef + if (res_upscale) timescale = timescale * res_scaling_fac - vDml(i) = timescale * G%mask2dCv(i,J)*G%dxCv(i,J)*G%IdyCv(i,J) * & - (Rml_av_fast(i,j+1)-Rml_av_fast(i,j)) * (h_vel**2 * GV%Z_to_H) + vDml(i) = timescale * G%dxCv(i,J)*G%IdyCv_OBCmask(i,J) * & + (Rml_av_fast(i,j+1)-Rml_av_fast(i,j)) * (h_vel**2) + ! As above but using the slow filtered MLD - h_vel = 0.5*((htot_slow(i,j) + htot_slow(i,j+1)) + h_neglect) * GV%H_to_Z - mom_mixrate = (0.41*9.8696)*u_star**2 / & - (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + h_vel = 0.5*((htot_slow(i,j) + htot_slow(i,j+1)) + h_neglect) + + ! NOTE: growth_time changes answers on some systems, see below. + ! timescale = growth_time(u_star, h_vel, absf, h_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef2) + + mom_mixrate = vonKar_x_pi2*u_star**2 / & + (absf*h_vel**2 + 4.0*(h_vel+h_neglect)*u_star) timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) timescale = timescale * CS%ml_restrat_coef2 + if (res_upscale) timescale = timescale * res_scaling_fac - vDml_slow(i) = timescale * G%mask2dCv(i,J)*G%dxCv(i,J)*G%IdyCv(i,J) * & - (Rml_av_slow(i,j+1)-Rml_av_slow(i,j)) * (h_vel**2 * GV%Z_to_H) + vDml_slow(i) = timescale * G%dxCv(i,J)*G%IdyCv_OBCmask(i,J) * & + (Rml_av_slow(i,j+1)-Rml_av_slow(i,j)) * (h_vel**2) if (vDml(i) + vDml_slow(i) == 0.) then do k=1,nz ; vhml(i,J,k) = 0.0 ; enddo @@ -475,9 +630,9 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var ! The sum of a(k) through the mixed layers must be 0. do k=1,nz hAtVel = 0.5*(h(i,j,k) + h(i,j+1,k)) - a(k) = PSI( zpa ) ! Psi(z/MLD) for upper interface - zpa = zpa - (hAtVel * IhTot) ! z/H for lower interface - a(k) = a(k) - PSI( zpa ) ! Transport profile + a(k) = mu(zpa, CS%MLE_tail_dh) ! mu(z/MLD) for upper interface + zpa = zpa - (hAtVel * IhTot) ! z/H for lower interface + a(k) = a(k) - mu(zpa, CS%MLE_tail_dh) ! Transport profile ! Limit magnitude (vDml) if it would violate CFL if (a(k)*vDml(i) > 0.0) then if (a(k)*vDml(i) > h_avail(i,j,k)) vDml(i) = h_avail(i,j,k) / a(k) @@ -488,9 +643,9 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var do k=1,nz ! Transport for slow-filtered MLD hAtVel = 0.5*(h(i,j,k) + h(i,j+1,k)) - b(k) = PSI(zpb) ! Psi(z/MLD) for upper interface - zpb = zpb - (hAtVel * IhTot_slow) ! z/H for lower interface - b(k) = b(k) - PSI(zpb) ! Transport profile + b(k) = mu(zpb, CS%MLE_tail_dh) ! mu(z/MLD) for upper interface + zpb = zpb - (hAtVel * IhTot_slow) ! z/H for lower interface + b(k) = b(k) - mu(zpb, CS%MLE_tail_dh) ! Transport profile ! Limit magnitude (vDml_slow) if it would violate CFL when added to vDml if (b(k)*vDml_slow(i) > 0.0) then if (b(k)*vDml_slow(i) > h_avail(i,j,k) - a(k)*vDml(i)) & @@ -510,12 +665,13 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var vDml_diag(i,J) = vDml(i) enddo ; enddo -!$OMP do + !$OMP do do j=js,je ; do k=1,nz ; do i=is,ie h(i,j,k) = h(i,j,k) - dt*G%IareaT(i,j) * & ((uhml(I,j,k) - uhml(I-1,j,k)) + (vhml(i,J,k) - vhml(i,J-1,k))) + if (h(i,j,k) < h_min) h(i,j,k) = h_min enddo ; enddo ; enddo -!$OMP end parallel + !$OMP end parallel ! Whenever thickness changes let the diag manager know, target grids ! for vertical remapping may need to be regenerated. @@ -530,22 +686,24 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var if (CS%id_vrestrat_time > 0) call post_data(CS%id_vrestrat_time, vtimescale_diag, CS%diag) if (CS%id_uhml > 0) call post_data(CS%id_uhml, uhml, CS%diag) if (CS%id_vhml > 0) call post_data(CS%id_vhml, vhml, CS%diag) - if (CS%id_MLD > 0) call post_data(CS%id_MLD, MLD_fast, CS%diag) + if (CS%id_BLD > 0) call post_data(CS%id_BLD, MLD_fast, CS%diag) + if (CS%id_MLD > 0) call post_data(CS%id_MLD, MLD_slow, CS%diag) if (CS%id_Rml > 0) call post_data(CS%id_Rml, Rml_av_fast, CS%diag) if (CS%id_uDml > 0) call post_data(CS%id_uDml, uDml_diag, CS%diag) if (CS%id_vDml > 0) call post_data(CS%id_vDml, vDml_diag, CS%diag) + if (CS%id_mle_fl > 0) call post_data(CS%id_mle_fl, mle_fl_2d, CS%diag) if (CS%id_uml > 0) then - do J=js,je ; do i=is-1,ie + do j=js,je ; do I=is-1,ie h_vel = 0.5*((htot_fast(i,j) + htot_fast(i+1,j)) + h_neglect) - uDml_diag(I,j) = uDml_diag(I,j) / (0.01*h_vel) * G%IdyCu(I,j) * (PSI(0.)-PSI(-.01)) + uDml_diag(I,j) = uDml_diag(I,j) / (0.01*h_vel) * G%IdyCu(I,j) * (mu(0.,0.)-mu(-.01,0.)) enddo ; enddo call post_data(CS%id_uml, uDml_diag, CS%diag) endif if (CS%id_vml > 0) then do J=js-1,je ; do i=is,ie h_vel = 0.5*((htot_fast(i,j) + htot_fast(i,j+1)) + h_neglect) - vDml_diag(i,J) = vDml_diag(i,J) / (0.01*h_vel) * G%IdxCv(i,J) * (PSI(0.)-PSI(-.01)) + vDml_diag(i,J) = vDml_diag(i,J) / (0.01*h_vel) * G%IdxCv(i,J) * (mu(0.,0.)-mu(-.01,0.)) enddo ; enddo call post_data(CS%id_vml, vDml_diag, CS%diag) endif @@ -555,8 +713,513 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var ! This needs to happen after the H update and before the next post_data. call diag_update_remap_grids(CS%diag) -end subroutine mixedlayer_restrat_general +end subroutine mixedlayer_restrat_OM4 + +!> Stream function shape as a function of non-dimensional position within mixed-layer [nondim] +real function mu(sigma, dh) + real, intent(in) :: sigma !< Fractional position within mixed layer [nondim] + !! z=0 is surface, z=-1 is the bottom of the mixed layer + real, intent(in) :: dh !< Non-dimensional distance over which to extend stream + !! function to smooth transport at base [nondim] + ! Local variables + real :: xp !< A linear function from mid-point of the mixed-layer + !! to the extended mixed-layer bottom [nondim] + real :: bottop !< A mask, 0 in upper half of mixed layer, 1 otherwise [nondim] + real :: dd !< A cubic(-ish) profile in lower half of extended mixed + !! layer to smooth out the parameterized transport [nondim] + + ! Lower order shape (not used), see eq 10 from FK08b. + ! Apparently used in CM2G, see eq 14 of FK11. + !mu = max(0., (1. - (2.*sigma + 1.)**2)) + + ! Second order, in Rossby number, shape. See eq 21 from FK08a, eq 9 from FK08b, eq 5 FK11 + mu = max(0., (1. - (2.*sigma + 1.)**2) * (1. + (5./21.)*(2.*sigma + 1.)**2)) + + ! -0.5 < sigma : xp(sigma)=0 (upper half of mixed layer) + ! -1.0+dh < sigma < -0.5 : xp(sigma)=linear (lower half +dh of mixed layer) + ! sigma < -1.0+dh : xp(sigma)=1 (below mixed layer + dh) + xp = max(0., min(1., (-sigma - 0.5)*2. / (1. + 2.*dh))) + + ! -0.5 < sigma : dd(sigma)=1 (upper half of mixed layer) + ! -1.0+dh < sigma < -0.5 : dd(sigma)=cubic (lower half +dh of mixed layer) + ! sigma < -1.0+dh : dd(sigma)=0 (below mixed layer + dh) + dd = (max(1. - xp**2 * (3. - 2.*xp), 0.))**(1. + 2.*dh) + + ! -0.5 < sigma : bottop(sigma)=0 (upper half of mixed layer) + ! sigma < -0.5 : bottop(sigma)=1 (below upper half) + bottop = 0.5*(1. - sign(1., sigma + 0.5)) ! =0 for sigma>-0.5, =1 for sigma<-0.5 + + mu = max(mu, dd*bottop) ! Combines original psi1 with tail +end function mu + +!> Calculates a restratifying flow in the mixed layer, following the formulation +!! used in Bodner et al., 2023 (B22) +subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, dt, BLD, h_MLD, bflux) + ! Arguments + type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uhtr !< Accumulated zonal mass flux + !! [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vhtr !< Accumulated meridional mass flux + !! [H L2 ~> m3 or kg] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables structure + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, intent(in) :: dt !< Time increment [T ~> s] + real, dimension(:,:), pointer :: BLD !< Active boundary layer depth provided by the + !! PBL scheme [Z ~> m] (not H) + real, dimension(:,:), pointer :: h_MLD !< Thickness of water within the + !! active boundary layer depth provided by + !! the PBL scheme [H ~> m or kg m-2] + real, dimension(:,:), pointer :: bflux !< Surface buoyancy flux provided by the + !! PBL scheme [Z2 T-3 ~> m2 s-3] + ! Local variables + real :: uhml(SZIB_(G),SZJ_(G),SZK_(GV)) ! zonal mixed layer transport [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vhml(SZI_(G),SZJB_(G),SZK_(GV)) ! merid mixed layer transport [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vol_dt_avail(SZI_(G),SZJ_(G),SZK_(GV)) ! The volume available for exchange out of each face of + ! each layer, divided by dt [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJ_(G)) :: & + little_h, & ! "Little h" representing active mixing layer depth [H ~> m or kg m-2] + big_H, & ! "Big H" representing the mixed layer depth [H ~> m or kg m-2] + mld, & ! The mixed layer depth returned by detect_mld [H ~> m or kg m-2] + htot, & ! The sum of the thicknesses of layers in the mixed layer [H ~> m or kg m-2] + buoy_av, & ! g_Rho0 times the average mixed layer density or G_Earth + ! times the average specific volume [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2] + wpup ! Turbulent vertical momentum [L H T-2 ~> m2 s-2 or kg m-1 s-2] + real :: uDml_diag(SZIB_(G),SZJ_(G)) ! A 2D copy of uDml for diagnostics [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vDml_diag(SZI_(G),SZJB_(G)) ! A 2D copy of vDml for diagnostics [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: lf_bodner_diag(SZI_(G),SZJ_(G)) ! Front width as in Bodner et al., 2023 (B22), eq 24 [L ~> m] + real :: U_star_2d(SZI_(G),SZJ_(G)) ! The wind friction velocity, calculated using the Boussinesq + ! reference density or the time-evolving surface density in non-Boussinesq + ! mode [Z T-1 ~> m s-1] + real :: covTS(SZI_(G)) ! SGS TS covariance in Stanley param; currently 0 [C S ~> degC ppt] + real :: varS(SZI_(G)) ! SGS S variance in Stanley param; currently 0 [S2 ~> ppt2] + real :: dmu(SZK_(GV)) ! Change in mu(z) across layer k [nondim] + real :: Rml_int(SZI_(G)) ! Potential density integrated through the mixed layer [R H ~> kg m-2 or kg2 m-5] + real :: SpV_ml(SZI_(G)) ! Specific volume evaluated at the surface pressure [R-1 ~> m3 kg-1] + real :: SpV_int(SZI_(G)) ! Specific volume integrated through the mixed layer [H R-1 ~> m4 kg-1 or m] + real :: rho_ml(SZI_(G)) ! Potential density relative to the surface [R ~> kg m-3] + real :: p0(SZI_(G)) ! A pressure of 0 [R L2 T-2 ~> Pa] + real :: g_Rho0 ! G_Earth/Rho0 times a thickness conversion factor + ! [L2 H-1 T-2 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2] + real :: h_vel ! htot interpolated onto velocity points [H ~> m or kg m-2] + real :: w_star3 ! Cube of turbulent convective velocity [Z3 T-3 ~> m3 s-3] + real :: u_star3 ! Cube of surface friction velocity [Z3 T-3 ~> m3 s-3] + real :: r_wpup ! reciprocal of vertical momentum flux [T2 L-1 H-1 ~> s2 m-2 or m s2 kg-1] + real :: absf ! absolute value of f, interpolated to velocity points [T-1 ~> s-1] + real :: f_h ! Coriolis parameter at h-points [T-1 ~> s-1] + real :: f2_h ! Coriolis parameter at h-points squared [T-2 ~> s-2] + real :: absurdly_small_freq2 ! Frequency squared used to avoid division by 0 [T-2 ~> s-2] + real :: grid_dsd ! combination of grid scales [L2 ~> m2] + real :: h_sml ! "Little h", the active mixing depth with diurnal cycle removed [H ~> m or kg m-2] + real :: h_big ! "Big H", the mixed layer depth based on a time filtered "little h" [H ~> m or kg m-2] + real :: grd_b ! The vertically average gradient of buoyancy [L H-1 T-2 ~> s-2 or m3 kg-1 s-2] + real :: psi_mag ! Magnitude of stream function [L2 H T-1 ~> m3 s-1 or kg s-1] + real :: h_neglect ! tiny thickness usually lost in roundoff so can be neglected [H ~> m or kg m-2] + real :: I4dt ! 1/(4 dt) [T-1 ~> s-1] + real :: Ihtot ! Inverses of the total mixed layer thickness [H-1 ~> m-1 or m2 kg-1] + real :: hAtVel ! Thickness at the velocity points [H ~> m or kg m-2] + real :: sigint ! Fractional position within the mixed layer of the interface above a layer [nondim] + real :: muzb ! mu(z) at bottom of the layer [nondim] + real :: muza ! mu(z) at top of the layer [nondim] + real :: dh ! Portion of the layer thickness that is in the mixed layer [H ~> m or kg m-2] + real :: Z3_T3_to_m3_s3 ! Conversion factors to undo scaling and permit terms to be raised to a + ! fractional power [T3 m3 Z-3 s-3 ~> 1] + real :: m2_s2_to_Z2_T2 ! Conversion factors to restore scaling after a term is raised to a + ! fractional power [Z2 s2 T-2 m-2 ~> 1] + real, parameter :: two_thirds = 2./3. ! [nondim] + logical :: line_is_empty, keep_going + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + I4dt = 0.25 / dt + g_Rho0 = GV%H_to_Z * GV%g_Earth / GV%Rho0 + h_neglect = GV%H_subroundoff + + covTS(:) = 0.0 ! Might be in tv% in the future. Not implemented for the time being. + varS(:) = 0.0 ! Ditto. + + ! This value is roughly (pi / (the age of the universe) )^2. + absurdly_small_freq2 = 1e-34*US%T_to_s**2 + + if (.not.associated(tv%eqn_of_state)) call MOM_error(FATAL, "mixedlayer_restrat_Bodner: "// & + "An equation of state must be used with this module.") + if (CS%MLE_use_PBL_MLD) then + if (CS%MLE_density_diff > 0.) call MOM_error(FATAL, "mixedlayer_restrat_Bodner: "// & + "MLE_density_diff is +ve and should not be in mixedlayer_restrat_Bodner.") + if (.not.associated(bflux)) call MOM_error(FATAL, "mixedlayer_restrat_Bodner: "// & + "Surface buoyancy flux was not associated.") + else + if (.not.CS%Bodner_detect_MLD) call MOM_error(FATAL, "mixedlayer_restrat_Bodner: "// & + "To use the Bodner et al., 2023, MLE parameterization, either MLE_USE_PBL_MLD or "// & + "Bodner_detect_MLD must be True.") + endif + + if (associated(bflux)) & + call pass_var(bflux, G%domain, halo=1) + + ! Extract the friction velocity from the forcing type. + call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1) + + if (CS%debug) then + call hchksum(h,'mixed_Bodner: h', G%HI, haloshift=1, unscale=GV%H_to_mks) + call hchksum(BLD, 'mle_Bodner: BLD', G%HI, haloshift=1, unscale=US%Z_to_m) + call hchksum(h_MLD, 'mle_Bodner: h_MLD', G%HI, haloshift=1, unscale=GV%H_to_mks) + if (associated(bflux)) & + call hchksum(bflux, 'mle_Bodner: bflux', G%HI, haloshift=1, unscale=US%Z_to_m**2*US%s_to_T**3) + call hchksum(U_star_2d, 'mle_Bodner: u*', G%HI, haloshift=1, unscale=US%Z_to_m*US%s_to_T) + call hchksum(CS%MLD_filtered, 'mle_Bodner: MLD_filtered 1', & + G%HI, haloshift=1, unscale=GV%H_to_mks) + call hchksum(CS%MLD_filtered_slow,'mle_Bodner: MLD_filtered_slow 1', & + G%HI, haloshift=1, unscale=GV%H_to_mks) + endif + + ! Apply time filter to h_MLD (to remove diurnal cycle) to obtain "little h". + ! "little h" is representative of the active mixing layer depth, used in B22 formula (eq 27). + do j=js-1,je+1 ; do i=is-1,ie+1 + little_h(i,j) = rmean2ts(h_MLD(i,j), CS%MLD_filtered(i,j), & + CS%BLD_growing_Tfilt, CS%BLD_decaying_Tfilt, dt) + CS%MLD_filtered(i,j) = little_h(i,j) + enddo ; enddo + + ! Calculate "big H", representative of the mixed layer depth, used in B22 formula (eq 27). + if (CS%MLD_grid) then + do j=js-1,je+1 ; do i=is-1,ie+1 + big_H(i,j) = rmean2ts(little_h(i,j), CS%MLD_filtered_slow(i,j), & + CS%MLD_growing_Tfilt, CS%MLD_Tfilt_space(i,j), dt) + enddo ; enddo + elseif (CS%Bodner_detect_MLD) then + call detect_mld(h, tv, MLD, G, GV, CS) + do j=js-1,je+1 ; do i=is-1,ie+1 + big_H(i,j) = rmean2ts(MLD(i,j), CS%MLD_filtered_slow(i,j), & + CS%MLD_growing_Tfilt, CS%MLD_decaying_Tfilt, dt) + enddo ; enddo + else + do j=js-1,je+1 ; do i=is-1,ie+1 + big_H(i,j) = rmean2ts(little_h(i,j), CS%MLD_filtered_slow(i,j), & + CS%MLD_growing_Tfilt, CS%MLD_decaying_Tfilt, dt) + enddo ; enddo + endif + do j=js-1,je+1 ; do i=is-1,ie+1 + CS%MLD_filtered_slow(i,j) = big_H(i,j) + enddo ; enddo + + ! Estimate w'u' at h-points, with a floor to avoid division by zero later. + if (allocated(tv%SpV_avg) .and. .not.(GV%Boussinesq .or. GV%semi_Boussinesq)) then + do j=js-1,je+1 ; do i=is-1,ie+1 + ! This expression differs by a factor of 1. / (Rho_0 * SpV_avg) compared with the other + ! expressions below, and it is invariant to the value of Rho_0 in non-Boussinesq mode. + wpup(i,j) = max((cuberoot( CS%mstar * U_star_2d(i,j)**3 + & + CS%nstar * max(0., -bflux(i,j)) * BLD(i,j) ))**2, CS%min_wstar2) & + * (US%Z_to_L * GV%RZ_to_H / tv%SpV_avg(i,j,1)) + ! The final line above converts from [Z2 T-2 ~> m2 s-2] to [L H T-2 ~> m2 s-2 or Pa]. + ! Some rescaling factors and the division by specific volume compensating for other + ! factors that are in find_ustar_mech, and others effectively converting the wind + ! stresses from [R L Z T-2 ~> Pa] to [L H T-2 ~> m2 s-2 or Pa]. The rescaling factors + ! and density being applied to the buoyancy flux are not so neatly explained because + ! fractional powers cancel out or combine with terms in the definitions of BLD and + ! bflux (such as SpV_avg**-2/3 combining with other terms in bflux to give the thermal + ! expansion coefficient) and because the specific volume does vary within the mixed layer. + enddo ; enddo + elseif (CS%answer_date < 20240201) then + Z3_T3_to_m3_s3 = (US%Z_to_m * US%s_to_T)**3 + m2_s2_to_Z2_T2 = (US%m_to_Z * US%T_to_s)**2 + do j=js-1,je+1 ; do i=is-1,ie+1 + w_star3 = max(0., -bflux(i,j)) * BLD(i,j) ! In [Z3 T-3 ~> m3 s-3] + u_star3 = U_star_2d(i,j)**3 ! In [Z3 T-3 ~> m3 s-3] + wpup(i,j) = max(m2_s2_to_Z2_T2 * (Z3_T3_to_m3_s3 * ( CS%mstar * u_star3 + CS%nstar * w_star3 ) )**two_thirds, & + CS%min_wstar2) * US%Z_to_L * GV%Z_to_H ! In [L H T-2 ~> m2 s-2 or kg m-1 s-2] + enddo ; enddo + else + do j=js-1,je+1 ; do i=is-1,ie+1 + w_star3 = max(0., -bflux(i,j)) * BLD(i,j) ! In [Z3 T-3 ~> m3 s-3] + wpup(i,j) = max( (cuberoot(CS%mstar * U_star_2d(i,j)**3 + CS%nstar * w_star3))**2, CS%min_wstar2 ) & + * US%Z_to_L * GV%Z_to_H ! In [L H T-2 ~> m2 s-2 or kg m-1 s-2] + enddo ; enddo + endif + + ! We filter w'u' with the same time scales used for "little h" + do j=js-1,je+1 ; do i=is-1,ie+1 + wpup(i,j) = rmean2ts(wpup(i,j), CS%wpup_filtered(i,j), & + CS%BLD_growing_Tfilt, CS%BLD_decaying_Tfilt, dt) + CS%wpup_filtered(i,j) = wpup(i,j) + enddo ; enddo + + if (CS%id_lfbod > 0) then + do j=js-1,je+1 ; do i=is-1,ie+1 + ! Calculate front length used in B22 formula (eq 24). + w_star3 = max(0., -bflux(i,j)) * BLD(i,j) + u_star3 = U_star_2d(i,j)**3 + + ! Include an absurdly_small_freq2 to prevent division by zero. + f_h = 0.25 * ((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) & + + (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J-1))) + f2_h = max(f_h**2, absurdly_small_freq2) + + lf_bodner_diag(i,j) = & + 0.25 * cuberoot(CS%mstar * u_star3 + CS%nstar * w_star3)**2 & + / (f2_h * max(little_h(i,j), GV%Angstrom_H)) + enddo ; enddo + + ! Rescale from [Z2 H-1 ~> m or m4 kg-1] to [L ~> m] + if (allocated(tv%SpV_avg) .and. .not.(GV%Boussinesq .or. GV%semi_Boussinesq)) then + do j=js-1,je+1 ; do i=is-1,ie+1 + lf_bodner_diag(i,j) = lf_bodner_diag(i,j) & + * (US%Z_to_L * GV%RZ_to_H / tv%SpV_avg(i,j,1)) + enddo ; enddo + else + do j=js-1,je+1 ; do i=is-1,ie+1 + lf_bodner_diag(i,j) = lf_bodner_diag(i,j) * US%Z_to_L * GV%Z_to_H + enddo ; enddo + endif + endif + + if (CS%debug) then + call hchksum(little_h,'mle_Bodner: little_h', G%HI, haloshift=1, unscale=GV%H_to_mks) + call hchksum(big_H,'mle_Bodner: big_H', G%HI, haloshift=1, unscale=GV%H_to_mks) + call hchksum(CS%MLD_filtered,'mle_Bodner: MLD_filtered 2', & + G%HI, haloshift=1, unscale=GV%H_to_mks) + call hchksum(CS%MLD_filtered_slow,'mle_Bodner: MLD_filtered_slow 2', & + G%HI, haloshift=1, unscale=GV%H_to_mks) + call hchksum(wpup,'mle_Bodner: wpup', G%HI, haloshift=1, unscale=US%L_to_m*GV%H_to_mks*US%s_to_T**2) + endif + + ! Calculate the average density in the "mixed layer". + ! Notice we use p=0 (sigma_0) since horizontal differences of vertical averages of + ! in-situ density would contain the MLD gradient (through the pressure dependence). + p0(:) = 0.0 + EOSdom(:) = EOS_domain(G%HI, halo=1) + !$OMP parallel & + !$OMP default(shared) & + !$OMP private(i, j, k, keep_going, line_is_empty, dh, & + !$OMP grid_dsd, absf, h_sml, h_big, grd_b, r_wpup, psi_mag, IhTot, & + !$OMP sigint, muzb, muza, hAtVel, Rml_int, SpV_int) + + !$OMP do + do j=js-1,je+1 + rho_ml(:) = 0.0 ; SpV_ml(:) = 0.0 + do i=is-1,ie+1 + htot(i,j) = 0.0 ; Rml_int(i) = 0.0 ; SpV_int(i) = 0.0 + enddo + keep_going = .true. + do k=1,nz + do i=is-1,ie+1 + vol_dt_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) + enddo + if (keep_going) then + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + if (CS%use_Stanley_ML) then + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, tv%varT(:,j,k), covTS, varS, & + rho_ml, tv%eqn_of_state, EOSdom) + else + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, rho_ml, tv%eqn_of_state, EOSdom) + endif + else + call calculate_spec_vol(tv%T(:,j,k), tv%S(:,j,k), p0, SpV_ml, tv%eqn_of_state, EOSdom) + endif + line_is_empty = .true. + do i=is-1,ie+1 + if (htot(i,j) < big_H(i,j)) then + dh = min( h(i,j,k), big_H(i,j) - htot(i,j) ) + Rml_int(i) = Rml_int(i) + dh*rho_ml(i) ! Rml_int has units of [R H ~> kg m-2] + SpV_int(i) = SpV_int(i) + dh*SpV_ml(i) ! SpV_int has units of [H R-1 ~> m4 kg-1 or m] + htot(i,j) = htot(i,j) + dh + line_is_empty = .false. + endif + enddo + if (line_is_empty) keep_going=.false. + endif + enddo + + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do i=is-1,ie+1 + ! Buoy_av has units (L2 H-1 T-2 R-1) * (R H) * H-1 = [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2] + buoy_av(i,j) = -( g_Rho0 * Rml_int(i) ) / (htot(i,j) + h_neglect) + enddo + else + do i=is-1,ie+1 + ! Buoy_av has units (R L2 H-1 T-2) * (R-1 H) * H-1 = [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2] + buoy_av(i,j) = (GV%H_to_RZ*GV%g_Earth * SpV_int(i)) / (htot(i,j) + h_neglect) + enddo + endif + enddo + + if (CS%debug) then + call hchksum(htot,'mle_Bodner: htot', G%HI, haloshift=1, unscale=GV%H_to_mks) + call hchksum(vol_dt_avail,'mle_Bodner: vol_dt_avail', G%HI, haloshift=1, & + unscale=US%L_to_m**2*GV%H_to_mks*US%s_to_T) + call hchksum(buoy_av,'mle_Bodner: buoy_av', G%HI, haloshift=1, unscale=GV%m_to_H*US%L_T_to_m_s**2) + endif + + ! U - Component + !$OMP do + do j=js,je ; do I=is-1,ie + if (G%OBCmaskCu(I,j) > 0.) then + grid_dsd = sqrt(0.5*( G%dxCu(I,j)**2 + G%dyCu(I,j)**2 )) * G%dyCu(I,j) ! [L2 ~> m2] + absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) ! [T-1 ~> s-1] + h_sml = 0.5*( little_h(i,j) + little_h(i+1,j) ) ! [H ~> m or kg m-2] + h_big = 0.5*( big_H(i,j) + big_H(i+1,j) ) ! [H ~> m or kg m-2] + grd_b = ( buoy_av(i+1,j) - buoy_av(i,j) ) * G%IdxCu(I,j) ! [L H-1 T-2 ~> s-2 or m3 kg-1 s-2] + r_wpup = 2. / ( wpup(i,j) + wpup(i+1,j) ) ! [T2 L-1 H-1 ~> s2 m-2 or m s2 kg-1] + psi_mag = ( ( ( (0.5*(CS%Cr_space(i,j) + CS%Cr_space(i+1,j))) * grid_dsd ) & ! [L2 H T-1 ~> m3 s-1 or kg s-1] + * ( absf * h_sml ) ) * ( ( h_big**2 ) * grd_b ) ) * r_wpup + else ! There is no flux on land and no gradient at open boundary points. + psi_mag = 0.0 + endif + + IhTot = 2.0 / ((htot(i,j) + htot(i+1,j)) + h_neglect) ! [H-1 ~> m-1 or m2 kg-1] + sigint = 0.0 + muzb = 0.0 ! This will be the first value of muza = mu(z=0) + do k=1,nz + muza = muzb ! mu(z/MLD) for upper interface [nondim] + hAtVel = 0.5*(h(i,j,k) + h(i+1,j,k)) ! Thickness at velocity point [H ~> m or kg m-2] + sigint = sigint - (hAtVel * IhTot) ! z/H for lower interface [nondim] + muzb = mu(sigint, CS%MLE_tail_dh) ! mu(z/MLD) for lower interface [nondim] + dmu(k) = muza - muzb ! Change in mu(z) across layer [nondim] + ! dmu(k)*psi_mag is the transport in this layer [L2 H T-1 ~> m3 s-1] + ! Limit magnitude (psi_mag) if it would violate CFL + if (dmu(k)*psi_mag > 0.0) then + if (dmu(k)*psi_mag > vol_dt_avail(i,j,k)) psi_mag = vol_dt_avail(i,j,k) / dmu(k) + elseif (dmu(k)*psi_mag < 0.0) then + if (-dmu(k)*psi_mag > vol_dt_avail(i+1,j,k)) psi_mag = -vol_dt_avail(i+1,j,k) / dmu(k) + endif + enddo ! These loops cannot be fused because psi_mag applies to the whole column + do k=1,nz + uhml(I,j,k) = dmu(k) * psi_mag ! [L2 H T-1 ~> m3 s-1 or kg s-1] + uhtr(I,j,k) = uhtr(I,j,k) + uhml(I,j,k) * dt ! [L2 H ~> m3 or kg] + enddo + + uDml_diag(I,j) = psi_mag + enddo ; enddo + + ! V- component + !$OMP do + do J=js-1,je ; do i=is,ie + if (G%OBCmaskCv(i,J) > 0.) then + grid_dsd = sqrt(0.5*( G%dxCv(i,J)**2 + G%dyCv(i,J)**2 )) * G%dxCv(i,J) ! [L2 ~> m2] + absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) ! [T-1 ~> s-1] + h_sml = 0.5*( little_h(i,j) + little_h(i,j+1) ) ! [H ~> m or kg m-2] + h_big = 0.5*( big_H(i,j) + big_H(i,j+1) ) ! [H ~> m or kg m-2] + grd_b = ( buoy_av(i,j+1) - buoy_av(i,j) ) * G%IdyCv(I,j) ! [L H-1 T-2 ~> s-2 or m3 kg-1 s-2] + r_wpup = 2. / ( wpup(i,j) + wpup(i,j+1) ) ! [T2 L-1 H-1 ~> s2 m-2 or m s2 kg-1] + psi_mag = ( ( ( (0.5*(CS%Cr_space(i,j) + CS%Cr_space(i,j+1))) * grid_dsd ) & ! [L2 H T-1 ~> m3 s-1 or kg s-1] + * ( absf * h_sml ) ) * ( ( h_big**2 ) * grd_b ) ) * r_wpup + else ! There is no flux on land and no gradient at open boundary points. + psi_mag = 0.0 + endif + + IhTot = 2.0 / ((htot(i,j) + htot(i,j+1)) + h_neglect) ! [H-1 ~> m-1 or m2 kg-1] + sigint = 0.0 + muzb = 0.0 ! This will be the first value of muza = mu(z=0) + do k=1,nz + muza = muzb ! mu(z/MLD) for upper interface [nondim] + hAtVel = 0.5*(h(i,j,k) + h(i,j+1,k)) ! Thickness at velocity point [H ~> m or kg m-2] + sigint = sigint - (hAtVel * IhTot) ! z/H for lower interface [nondim] + muzb = mu(sigint, CS%MLE_tail_dh) ! mu(z/MLD) for lower interface [nondim] + dmu(k) = muza - muzb ! Change in mu(z) across layer [nondim] + ! dmu(k)*psi_mag is the transport in this layer [L2 H T-1 ~> m3 s-1 or kg s-1] + ! Limit magnitude (psi_mag) if it would violate CFL + if (dmu(k)*psi_mag > 0.0) then + if (dmu(k)*psi_mag > vol_dt_avail(i,j,k)) psi_mag = vol_dt_avail(i,j,k) / dmu(k) + elseif (dmu(k)*psi_mag < 0.0) then + if (-dmu(k)*psi_mag > vol_dt_avail(i,j+1,k)) psi_mag = -vol_dt_avail(i,j+1,k) / dmu(k) + endif + enddo ! These loops cannot be fused because psi_mag applies to the whole column + do k=1,nz + vhml(i,J,k) = dmu(k) * psi_mag ! [L2 H T-1 ~> m3 s-1 or kg s-1] + vhtr(i,J,k) = vhtr(i,J,k) + vhml(i,J,k) * dt ! [L2 H ~> m3 or kg] + enddo + + vDml_diag(i,J) = psi_mag + enddo ; enddo + + !$OMP do + do j=js,je ; do k=1,nz ; do i=is,ie + h(i,j,k) = h(i,j,k) - dt*G%IareaT(i,j) * & + ((uhml(I,j,k) - uhml(I-1,j,k)) + (vhml(i,J,k) - vhml(i,J-1,k))) + enddo ; enddo ; enddo + !$OMP end parallel + + if (CS%id_uhml > 0 .or. CS%id_vhml > 0) & + ! Remapped uhml and vhml require east/north halo updates of h + call pass_var(h, G%domain, To_West+To_South+Omit_Corners, halo=1) + ! Whenever thickness changes let the diag manager know, target grids + ! for vertical remapping may need to be regenerated. + call diag_update_remap_grids(CS%diag) + + ! Offer diagnostic fields for averaging. + if (query_averaging_enabled(CS%diag)) then + if (CS%id_ustar > 0) call post_data(CS%id_ustar, U_star_2d, CS%diag) + if (CS%id_bflux > 0) call post_data(CS%id_bflux, bflux, CS%diag) + if (CS%id_wpup > 0) call post_data(CS%id_wpup, wpup, CS%diag) + if (CS%id_Rml > 0) call post_data(CS%id_Rml, buoy_av, CS%diag) + if (CS%id_BLD > 0) call post_data(CS%id_BLD, little_h, CS%diag) + if (CS%id_MLD > 0) call post_data(CS%id_MLD, big_H, CS%diag) + if (CS%id_uhml > 0) call post_data(CS%id_uhml, uhml, CS%diag) + if (CS%id_vhml > 0) call post_data(CS%id_vhml, vhml, CS%diag) + if (CS%id_uDml > 0) call post_data(CS%id_uDml, uDml_diag, CS%diag) + if (CS%id_vDml > 0) call post_data(CS%id_vDml, vDml_diag, CS%diag) + if (CS%id_lfbod > 0) call post_data(CS%id_lfbod, lf_bodner_diag, CS%diag) + if (CS%id_uml > 0) then + do j=js,je ; do I=is-1,ie + h_vel = 0.5*((htot(i,j) + htot(i+1,j)) + h_neglect) + uDml_diag(I,j) = uDml_diag(I,j) / (0.01*h_vel) * G%IdyCu(I,j) * (mu(0.,0.)-mu(-.01,0.)) + enddo ; enddo + call post_data(CS%id_uml, uDml_diag, CS%diag) + endif + if (CS%id_vml > 0) then + do J=js-1,je ; do i=is,ie + h_vel = 0.5*((htot(i,j) + htot(i,j+1)) + h_neglect) + vDml_diag(i,J) = vDml_diag(i,J) / (0.01*h_vel) * G%IdxCv(i,J) * (mu(0.,0.)-mu(-.01,0.)) + enddo ; enddo + call post_data(CS%id_vml, vDml_diag, CS%diag) + endif + endif + +end subroutine mixedlayer_restrat_Bodner + +!> Two time-scale running mean in the same arbitrary units as "signal" and "filtered" +!! +!! If signal > filtered, returns running-mean with time scale "tau_growing". +!! If signal <= filtered, returns running-mean with time scale "tau_decaying". +!! +!! The running mean of \f$ s \f$ with time scale "of \f$ \tau \f$ is: +!! \f[ +!! \bar{s} <- ( \Delta t * s + \tau * \bar{s} ) / ( \Delta t + \tau ) +!! \f] +!! +!! Note that if \f$ tau=0 \f$, then the running mean equals the signal. Thus, +!! rmean2ts with tau_growing=0 recovers the "resetting running mean" used in OM4. +real elemental function rmean2ts(signal, filtered, tau_growing, tau_decaying, dt) + ! Arguments + real, intent(in) :: signal ! Unfiltered signal in arbitrary units [A] + real, intent(in) :: filtered ! Current value of running mean in the same arbitrary units [A] + real, intent(in) :: tau_growing ! Time scale for growing signal [T ~> s] + real, intent(in) :: tau_decaying ! Time scale for decaying signal [T ~> s] + real, intent(in) :: dt ! Time step [T ~> s] + ! Local variables + real :: afac, bfac ! Non-dimensional fractional weights [nondim] + real :: rt ! Reciprocal time scale [T-1 ~> s-1] + + if (signal>=filtered) then + rt = 1.0 / ( dt + tau_growing ) + aFac = tau_growing * rt + bFac = 1. - aFac + else + rt = 1.0 / ( dt + tau_decaying ) + aFac = tau_decaying * rt + bFac = 1. - aFac + endif + + rmean2ts = aFac * filtered + bFac * signal + +end function rmean2ts !> Calculates a restratifying flow assuming a 2-layer bulk mixed layer. subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) @@ -572,41 +1235,51 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces real, intent(in) :: dt !< Time increment [T ~> s] type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure + ! Local variables - real :: uhml(SZIB_(G),SZJ_(G),SZK_(GV)) ! zonal mixed layer transport [H L2 T-1 ~> m3 s-1 or kg s-1] - real :: vhml(SZI_(G),SZJB_(G),SZK_(GV)) ! merid mixed layer transport [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: uhml(SZIB_(G),SZJ_(G),SZK_(GV)) ! Restratifying zonal thickness transports [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vhml(SZI_(G),SZJB_(G),SZK_(GV)) ! Restratifying meridional thickness transports [H L2 T-1 ~> m3 s-1 or kg s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & h_avail ! The volume available for diffusion out of each face of each ! sublayer of the mixed layer, divided by dt [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G),SZJ_(G)) :: & + U_star_2d, & ! The wind friction velocity in thickness-based units, calculated using + ! the Boussinesq reference density or the time-evolving surface density + ! in non-Boussinesq mode [H T-1 ~> m s-1 or kg m-2 s-1] htot, & ! The sum of the thicknesses of layers in the mixed layer [H ~> m or kg m-2] - Rml_av ! g_Rho0 times the average mixed layer density [L2 Z-1 T-2 ~> m s-2] - real :: g_Rho0 ! G_Earth/Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] - real :: Rho0(SZI_(G)) ! Potential density relative to the surface [R ~> kg m-3] + Rml_av ! g_Rho0 times the average mixed layer density or negative G_Earth + ! times the average specific volume [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2] + real :: g_Rho0 ! G_Earth/Rho0 times a thickness conversion factor + ! [L2 H-1 T-2 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2] + real :: Rho_ml(SZI_(G)) ! Potential density relative to the surface [R ~> kg m-3] + real :: rho_int(SZI_(G)) ! The integral of density over the mixed layer depth [R H ~> kg m-2 or kg2 m-5] + real :: SpV_ml(SZI_(G)) ! Specific volume evaluated at the surface pressure [R-1 ~> m3 kg-1] + real :: SpV_int(SZI_(G)) ! Specific volume integrated through the surface layer [H R-1 ~> m4 kg-1 or m] real :: p0(SZI_(G)) ! A pressure of 0 [R L2 T-2 ~> Pa] - real :: h_vel ! htot interpolated onto velocity points [Z ~> m]. (The units are not H.) + real :: h_vel ! htot interpolated onto velocity points [H ~> m or kg m-2] real :: absf ! absolute value of f, interpolated to velocity points [T-1 ~> s-1] - real :: u_star ! surface friction velocity, interpolated to velocity points [Z T-1 ~> m s-1]. + real :: u_star ! surface friction velocity, interpolated to velocity points and recast into + ! thickness-based units [H T-1 ~> m s-1 or kg m-2 s-1]. + real :: vonKar_x_pi2 ! A scaling constant that is approximately the von Karman constant times + ! pi squared [nondim] real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer [T-1 ~> s-1] real :: timescale ! mixing growth timescale [T ~> s] + real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. real :: h_neglect ! tiny thickness usually lost in roundoff and can be neglected [H ~> m or kg m-2] - real :: dz_neglect ! tiny thickness that usually lost in roundoff and can be neglected [Z ~> m] real :: I4dt ! 1/(4 dt) [T-1 ~> s-1] real :: I2htot ! Twice the total mixed layer thickness at velocity points [H ~> m or kg m-2] real :: z_topx2 ! depth of the top of a layer at velocity points [H ~> m or kg m-2] real :: hx2 ! layer thickness at velocity points [H ~> m or kg m-2] - real :: a(SZK_(GV)) ! A non-dimensional value relating the overall flux - ! magnitudes (uDml & vDml) to the realized flux in a - ! layer. The vertical sum of a() through the pieces of - ! the mixed layer must be 0. - real :: uDml(SZIB_(G)) ! The zonal and meridional volume fluxes in the upper - real :: vDml(SZI_(G)) ! half of the mixed layer [H L2 T-1 ~> m3 s-1 or kg s-1]. - real :: utimescale_diag(SZIB_(G),SZJ_(G)) ! The restratification timescales - real :: vtimescale_diag(SZI_(G),SZJB_(G)) ! in the zonal and meridional - ! directions [T ~> s], stored in 2-D - ! arrays for diagnostic purposes. - real :: uDml_diag(SZIB_(G),SZJ_(G)), vDml_diag(SZI_(G),SZJB_(G)) + real :: a(SZK_(GV)) ! A non-dimensional value relating the overall flux magnitudes (uDml & vDml) + ! to the realized flux in a layer [nondim]. The vertical sum of a() + ! through the pieces of the mixed layer must be 0. + real :: uDml(SZIB_(G)) ! Zonal volume fluxes in the upper half of the mixed layer [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vDml(SZI_(G)) ! Meridional volume fluxes in the upper half of the mixed layer [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: utimescale_diag(SZIB_(G),SZJ_(G)) ! Zonal restratification timescale [T ~> s], stored for diagnostics. + real :: vtimescale_diag(SZI_(G),SZJB_(G)) ! Meridional restratification timescale [T ~> s], stored for diagnostics. + real :: uDml_diag(SZIB_(G),SZJ_(G)) ! A 2D copy of uDml for diagnostics [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vDml_diag(SZI_(G),SZJB_(G)) ! A 2D copy of vDml for diagnostics [H L2 T-1 ~> m3 s-1 or kg s-1] logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state @@ -614,74 +1287,105 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nkml = GV%nkml - if (.not. CS%initialized) call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & + if (.not. CS%initialized) call MOM_error(FATAL, "mixedlayer_restrat_BML: "// & "Module must be initialized before it is used.") if ((nkml<2) .or. (CS%ml_restrat_coef<=0.0)) return + + h_min = 0.5*GV%Angstrom_H ! This should be GV%Angstrom_H, but that value would change answers. uDml(:) = 0.0 ; vDml(:) = 0.0 I4dt = 0.25 / dt - g_Rho0 = GV%g_Earth / GV%Rho0 + g_Rho0 = GV%H_to_Z * GV%g_Earth / GV%Rho0 + vonKar_x_pi2 = CS%vonKar * 9.8696 use_EOS = associated(tv%eqn_of_state) h_neglect = GV%H_subroundoff - dz_neglect = GV%H_subroundoff*GV%H_to_Z - if (.not.use_EOS) call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & + if (.not.use_EOS) call MOM_error(FATAL, "mixedlayer_restrat_BML: "// & "An equation of state must be used with this module.") + if (CS%use_Stanley_ML) call MOM_error(FATAL, "mixedlayer_restrat_BML: "// & + "The Stanley parameterization is not available with the BML.") + + ! Extract the friction velocity from the forcing type. + call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1, H_T_units=.true.) + ! Fix this later for nkml >= 3. p0(:) = 0.0 EOSdom(:) = EOS_domain(G%HI, halo=1) -!$OMP parallel default(none) shared(is,ie,js,je,G,GV,US,htot,Rml_av,tv,p0,h,h_avail,EOSdom, & -!$OMP h_neglect,g_Rho0,I4dt,CS,uhml,uhtr,dt,vhml,vhtr, & -!$OMP utimescale_diag,vtimescale_diag,forces,dz_neglect, & -!$OMP uDml_diag,vDml_diag,nkml) & -!$OMP private(Rho0,h_vel,u_star,absf,mom_mixrate,timescale, & -!$OMP I2htot,z_topx2,hx2,a) & -!$OMP firstprivate(uDml,vDml) -!$OMP do - do j=js-1,je+1 - do i=is-1,ie+1 - htot(i,j) = 0.0 ; Rml_av(i,j) = 0.0 - enddo - do k=1,nkml - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, Rho0(:), tv%eqn_of_state, EOSdom) + !$OMP parallel default(shared) private(Rho_ml,rho_int,h_vel,u_star,absf,mom_mixrate,timescale, & + !$OMP SpV_ml,SpV_int,I2htot,z_topx2,hx2,a) & + !$OMP firstprivate(uDml,vDml) + + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + !$OMP do + do j=js-1,je+1 do i=is-1,ie+1 - Rml_av(i,j) = Rml_av(i,j) + h(i,j,k)*Rho0(i) - htot(i,j) = htot(i,j) + h(i,j,k) - h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) + htot(i,j) = 0.0 ; rho_int(i) = 0.0 + enddo + do k=1,nkml + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, Rho_ml(:), tv%eqn_of_state, EOSdom) + do i=is-1,ie+1 + rho_int(i) = rho_int(i) + h(i,j,k)*Rho_ml(i) + htot(i,j) = htot(i,j) + h(i,j,k) + h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) + enddo + enddo + + do i=is-1,ie+1 + Rml_av(i,j) = (g_Rho0*rho_int(i)) / (htot(i,j) + h_neglect) enddo enddo + else ! This is only used in non-Boussinesq mode. + !$OMP do + do j=js-1,je+1 + do i=is-1,ie+1 + htot(i,j) = 0.0 ; SpV_int(i) = 0.0 + enddo + do k=1,nkml + call calculate_spec_vol(tv%T(:,j,k), tv%S(:,j,k), p0, SpV_ml, tv%eqn_of_state, EOSdom) + do i=is-1,ie+1 + SpV_int(i) = SpV_int(i) + h(i,j,k)*SpV_ml(i) ! [H R-1 ~> m4 kg-1 or m] + htot(i,j) = htot(i,j) + h(i,j,k) + h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) + enddo + enddo - do i=is-1,ie+1 - Rml_av(i,j) = (g_Rho0*Rml_av(i,j)) / (htot(i,j) + h_neglect) + ! Convert the vertically integrated specific volume into a negative variable with units of density. + do i=is-1,ie+1 + Rml_av(i,j) = (-GV%H_to_RZ*GV%g_Earth * SpV_int(i)) / (htot(i,j) + h_neglect) + enddo enddo - enddo + endif ! TO DO: ! 1. Mixing extends below the mixing layer to the mixed layer. Find it! ! 2. Add exponential tail to stream-function? ! U - Component -!$OMP do + !$OMP do do j=js,je ; do I=is-1,ie - h_vel = 0.5*(htot(i,j) + htot(i+1,j)) * GV%H_to_Z + h_vel = 0.5*(htot(i,j) + htot(i+1,j)) + + u_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i+1,j))) - u_star = 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j)) absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) - ! peak ML visc: u_star * 0.41 * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) + + ! NOTE: growth_time changes answers on some systems, see below. + ! timescale = growth_time(u_star, h_vel, absf, h_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + + ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) ! momentum mixing rate: pi^2*visc/h_ml^2 - ! 0.41 is the von Karmen constant, 9.8696 = pi^2. - mom_mixrate = (0.41*9.8696)*u_star**2 / & - (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + mom_mixrate = vonKar_x_pi2*u_star**2 / & + (absf*h_vel**2 + 4.0*(h_vel+h_neglect)*u_star) timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) timescale = timescale * CS%ml_restrat_coef ! timescale = timescale*(2?)*(L_def/L_MLI) * min(EKE/MKE,1.0 + (G%dyCv(i,j)/L_def)**2) - uDml(I) = timescale * G%mask2dCu(I,j)*G%dyCu(I,j)*G%IdxCu(I,j) * & - (Rml_av(i+1,j)-Rml_av(i,j)) * (h_vel**2 * GV%Z_to_H) + uDml(I) = timescale * G%dyCu(I,j)*G%IdxCu_OBCmask(I,j) * & + (Rml_av(i+1,j)-Rml_av(i,j)) * (h_vel**2) if (uDml(I) == 0) then do k=1,nkml ; uhml(I,j,k) = 0.0 ; enddo @@ -711,24 +1415,28 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) enddo ; enddo ! V- component -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie - h_vel = 0.5*(htot(i,j) + htot(i,j+1)) * GV%H_to_Z + h_vel = 0.5*(htot(i,j) + htot(i,j+1)) + + u_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i,j+1))) - u_star = 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1)) absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) - ! peak ML visc: u_star * 0.41 * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) + + ! NOTE: growth_time changes answers on some systems, see below. + ! timescale = growth_time(u_star, h_vel, absf, h_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + + ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) ! momentum mixing rate: pi^2*visc/h_ml^2 - ! 0.41 is the von Karmen constant, 9.8696 = pi^2. - mom_mixrate = (0.41*9.8696)*u_star**2 / & - (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + mom_mixrate = vonKar_x_pi2*u_star**2 / & + (absf*h_vel**2 + 4.0*(h_vel+h_neglect)*u_star) timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) timescale = timescale * CS%ml_restrat_coef ! timescale = timescale*(2?)*(L_def/L_MLI) * min(EKE/MKE,1.0 + (G%dyCv(i,j)/L_def)**2) - vDml(i) = timescale * G%mask2dCv(i,J)*G%dxCv(i,J)*G%IdyCv(i,J) * & - (Rml_av(i,j+1)-Rml_av(i,j)) * (h_vel**2 * GV%Z_to_H) + vDml(i) = timescale * G%dxCv(i,J)*G%IdyCv_OBCmask(i,J) * & + (Rml_av(i,j+1)-Rml_av(i,j)) * (h_vel**2) if (vDml(i) == 0) then do k=1,nkml ; vhml(i,J,k) = 0.0 ; enddo else @@ -756,12 +1464,13 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) vDml_diag(i,J) = vDml(i) enddo ; enddo -!$OMP do + !$OMP do do j=js,je ; do k=1,nkml ; do i=is,ie h(i,j,k) = h(i,j,k) - dt*G%IareaT(i,j) * & ((uhml(I,j,k) - uhml(I-1,j,k)) + (vhml(i,J,k) - vhml(i,J-1,k))) + if (h(i,j,k) < h_min) h(i,j,k) = h_min enddo ; enddo ; enddo -!$OMP end parallel + !$OMP end parallel ! Whenever thickness changes let the diag manager know, target grids ! for vertical remapping may need to be regenerated. @@ -792,25 +1501,146 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) end subroutine mixedlayer_restrat_BML +!> Detects the mixed layer depth using a density difference criterion (MLE_DENSITY_DIFF) +subroutine detect_mld(h, tv, MLD_fast, G, GV, CS) + type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: MLD_fast !< detected mixed layer depth [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables structure + + ! Local variables + real, dimension(SZI_(G)) :: pRef_MLD ! A reference pressure for calculating the mixed layer + ! densities [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G)) :: rhoSurf, deltaRhoAtKm1, deltaRhoAtK ! Densities and density differences [R ~> kg m-3] + real, dimension(SZI_(G)) :: dK, dKm1 ! Depths of layer centers [H ~> m or kg m-2]. + real :: ddRho ! A density difference [R ~> kg m-3] + real :: aFac ! A nondimensional ratio [nondim] + real :: covTS(SZI_(G)) ! SGS TS covariance in Stanley param; currently 0 [C S ~> degC ppt] + real :: varS(SZI_(G)) ! SGS S variance in Stanley param; currently 0 [S2 ~> ppt2] + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + covTS(:) = 0.0 ! Might be in tv% in the future. Not implemented for the time being. + varS(:) = 0.0 ! Ditto. + + !! TODO: use derivatives and mid-MLD pressure. Currently this is sigma-0. -AJA + pRef_MLD(:) = 0. + EOSdom(:) = EOS_domain(G%HI, halo=1) + do j=js-1,je+1 + dK(:) = 0.5 * h(:,j,1) ! Depth of center of surface layer + if (CS%use_Stanley_ML) then + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, tv%varT(:,j,1), covTS, varS, & + rhoSurf, tv%eqn_of_state, EOSdom) + else + call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, tv%eqn_of_state, EOSdom) + endif + deltaRhoAtK(:) = 0. + MLD_fast(:,j) = 0. + do k=2,nz + dKm1(:) = dK(:) ! Depth of center of layer K-1 + dK(:) = dK(:) + 0.5 * ( h(:,j,k) + h(:,j,k-1) ) ! Depth of center of layer K + ! Mixed-layer depth, using sigma-0 (surface reference pressure) + deltaRhoAtKm1(:) = deltaRhoAtK(:) ! Store value from previous iteration of K + if (CS%use_Stanley_ML) then + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, tv%varT(:,j,k), covTS, varS, & + deltaRhoAtK, tv%eqn_of_state, EOSdom) + else + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, tv%eqn_of_state, EOSdom) + endif + do i=is-1,ie+1 + deltaRhoAtK(i) = deltaRhoAtK(i) - rhoSurf(i) ! Density difference between layer K and surface + enddo + do i=is-1,ie+1 + ddRho = deltaRhoAtK(i) - deltaRhoAtKm1(i) + if ((MLD_fast(i,j)==0.) .and. (ddRho>0.) .and. & + (deltaRhoAtKm1(i)=CS%MLE_density_diff)) then + aFac = ( CS%MLE_density_diff - deltaRhoAtKm1(i) ) / ddRho + MLD_fast(i,j) = dK(i) * aFac + dKm1(i) * (1. - aFac) + endif + enddo ! i-loop + enddo ! k-loop + do i=is-1,ie+1 + MLD_fast(i,j) = CS%MLE_MLD_stretch * MLD_fast(i,j) + if ((MLD_fast(i,j)==0.) .and. (deltaRhoAtK(i) Return the growth timescale for the submesoscale mixed layer eddies in [T ~> s] +real function growth_time(u_star, hBL, absf, h_neg, vonKar, Kv_rest, restrat_coef) + real, intent(in) :: u_star !< Surface friction velocity in thickness-based units [H T-1 ~> m s-1 or kg m-2 s-1] + real, intent(in) :: hBL !< Boundary layer thickness including at least a negligible + !! value to keep it positive definite [H ~> m or kg m-2] + real, intent(in) :: absf !< Absolute value of the Coriolis parameter [T-1 ~> s-1] + real, intent(in) :: h_neg !< A tiny thickness that is usually lost in roundoff so can be + !! neglected [H ~> m or kg m-2] + real, intent(in) :: Kv_rest !< The background laminar vertical viscosity used for restratification, + !! rescaled into thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1] + real, intent(in) :: vonKar !< The von Karman constant, used to scale the turbulent limits + !! on the restratification timescales [nondim] + real, intent(in) :: restrat_coef !< An overall scaling factor for the restratification timescale [nondim] + + ! Local variables + real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer [T-1 ~> s-1] + real :: Kv_eff ! An effective overall viscosity in thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1] + real :: pi2 ! A scaling constant that is approximately pi^2 [nondim] + + ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) + Kv_water + ! momentum mixing rate: pi^2*visc/h_ml^2 + pi2 = 9.8696 ! Approximately pi^2. This is more accurate than the overall uncertainty of the + ! scheme, with a value that is chosen to reproduce previous answers. + if (Kv_rest <= 0.0) then + ! This case reproduces the previous answers, but the extra h_neg is otherwise unnecessary. + mom_mixrate = (pi2*vonKar)*u_star**2 / (absf*hBL**2 + 4.0*(hBL + h_neg)*u_star) + growth_time = restrat_coef * (0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2)) + else + ! Set the mixing rate to the sum of a turbulent mixing rate and a laminar viscous rate. + ! mom_mixrate = pi2*vonKar*u_star**2 / (absf*hBL**2 + 4.0*hBL*u_star) + pi2*Kv_rest / hBL**2 + if (absf*hBL <= 4.0e-16*u_star) then + Kv_eff = pi2 * (Kv_rest + 0.25*vonKar*hBL*u_star) + else + Kv_eff = pi2 * (Kv_rest + vonKar*u_star**2*hBL / (absf*hBL + 4.0*u_star)) + endif + growth_time = (restrat_coef*0.0625) * ((hBL**2*(hBL**2*absf + 2.0*Kv_eff)) / ((hBL**2*absf)**2 + Kv_eff**2)) + endif + +end function growth_time !> Initialize the mixed layer restratification module logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, restart_CS) - type(time_type), intent(in) :: Time !< Current model time + type(time_type), target, intent(in) :: Time !< Current model time type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file to parse type(diag_ctrl), target, intent(inout) :: diag !< Regulate diagnostics type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure - type(MOM_restart_CS), intent(in) :: restart_CS !< MOM restart control struct + type(MOM_restart_CS), intent(in) :: restart_CS !< MOM restart control structure ! Local variables - real :: H_rescale ! A rescaling factor for thicknesses from the representation in - ! a restart file to the internal representation in this run. - real :: flux_to_kg_per_s ! A unit conversion factor for fluxes. + real :: flux_to_kg_per_s ! A unit conversion factor for fluxes. [kg T s-1 H-1 L-2 ~> kg m-3 or 1] + real :: omega ! The Earth's rotation rate [T-1 ~> s-1]. + real :: ustar_min_dflt ! The default value for RESTRAT_USTAR_MIN [Z T-1 ~> m s-1] + real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale + ! temperature variance [nondim] + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags ! This include declares and sets the variable "version". + character(len=200) :: inputdir ! The directory where NetCDF input files + character(len=240) :: mle_fl_filename ! A file from which chl_a concentrations are to be read. + character(len=128) :: mle_fl_file ! Data containing MLE front-length scale. Used + ! when reading from file. + character(len=32) :: fl_varname ! Name of front-length scale variable in mle_fl_file. + # include "version_variable.h" - integer :: i, j + character(len=200) :: filename, varname ! Read all relevant parameters and write them to the model log. call get_param(param_file, mdl, "MIXEDLAYER_RESTRAT", mixedlayer_restrat_init, & @@ -824,6 +1654,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, if (.not. mixedlayer_restrat_init) return CS%initialized = .true. + CS%Time => Time ! Nonsense values to cause problems when these parameters are not used CS%MLE_MLD_decay_time = -9.e9*US%s_to_T @@ -831,9 +1662,128 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, CS%MLE_tail_dh = -9.e9 CS%MLE_use_PBL_MLD = .false. CS%MLE_MLD_stretch = -9.e9 + CS%use_Stanley_ML = .false. + CS%use_Bodner = .false. + CS%fl_from_file = .false. + CS%MLD_grid = .false. + CS%Cr_grid = .false. call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false., do_not_log=.true.) - call get_param(param_file, mdl, "FOX_KEMPER_ML_RESTRAT_COEF", CS%ml_restrat_coef, & + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231, do_not_log=.true.) + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + call openParameterBlock(param_file,'MLE') ! Prepend MLE% to all parameters + if (GV%nkml==0) then + call get_param(param_file, mdl, "USE_BODNER23", CS%use_Bodner, & + "If true, use the Bodner et al., 2023, formulation of the re-stratifying "//& + "mixed-layer restratification parameterization. This only works in ALE mode.", & + default=.false.) + endif + if (CS%use_Bodner) then + call get_param(param_file, mdl, "CR", CS%Cr, & + "The efficiency coefficient in eq 27 of Bodner et al., 2023.", & + units="nondim", default=0.0) + call get_param(param_file, mdl, "BODNER_NSTAR", CS%Nstar, & + "The n* value used to estimate the turbulent vertical momentum flux "//& + "in Bodner et al., 2023, eq. 18. This is independent of the value used in "//& + "the PBL scheme but should be set to be the same for consistency.", & + units="nondim", default=0.066) + call get_param(param_file, mdl, "BODNER_MSTAR", CS%Mstar, & + "The m* value used to estimate the turbulent vertical momentum flux "//& + "in Bodner et al., 2023, eq. 18. This is independent of the value used in "//& + "the PBL scheme but should be set to be the same for consistency.", & + units="nondim", default=0.5) + call get_param(param_file, mdl, "BLD_GROWING_TFILTER", CS%BLD_growing_Tfilt, & + "The time-scale for a running-mean filter applied to the boundary layer "//& + "depth (BLD) when the BLD is deeper than the running mean. A value of 0 "//& + "instantaneously sets the running mean to the current value of BLD.", & + units="s", default=0., scale=US%s_to_T) + call get_param(param_file, mdl, "BLD_DECAYING_TFILTER", CS%BLD_decaying_Tfilt, & + "The time-scale for a running-mean filter applied to the boundary layer "//& + "depth (BLD) when the BLD is shallower than the running mean. A value of 0 "//& + "instantaneously sets the running mean to the current value of BLD.", & + units="s", default=0., scale=US%s_to_T) + call get_param(param_file, mdl, "MLD_GROWING_TFILTER", CS%MLD_growing_Tfilt, & + "The time-scale for a running-mean filter applied to the time-filtered "//& + "BLD, when the latter is deeper than the running mean. A value of 0 "//& + "instantaneously sets the running mean to the current value filtered BLD.", & + units="s", default=0., scale=US%s_to_T) + call get_param(param_file, mdl, "MLD_DECAYING_TFILTER", CS%MLD_decaying_Tfilt, & + "The time-scale for a running-mean filter applied to the time-filtered "//& + "BLD, when the latter is shallower than the running mean. A value of 0 "//& + "instantaneously sets the running mean to the current value filtered BLD.", & + units="s", default=0., scale=US%s_to_T) + call get_param(param_file, mdl, "ML_RESTRAT_ANSWER_DATE", CS%answer_date, & + "The vintage of the order of arithmetic and expressions in the mixed layer "//& + "restrat calculations. Values below 20240201 recover the answers from the end "//& + "of 2023, while higher values use the new cuberoot function in the Bodner code "//& + "to avoid needing to undo dimensional rescaling.", & + default=default_answer_date, & + do_not_log=.not.(CS%use_Bodner.and.(GV%Boussinesq.or.GV%semi_Boussinesq))) + call get_param(param_file, mdl, "MIN_WSTAR2", CS%min_wstar2, & + "The minimum lower bound to apply to the vertical momentum flux, w'u', "//& + "in the Bodner et al., restratification parameterization. This avoids "//& + "a division-by-zero in the limit when u* and the buoyancy flux are zero. "//& + "The default is less than the molecular viscosity of water times the Coriolis "//& + "parameter a micron away from the equator.", & + units="m2 s-2", default=1.0e-24, scale=US%m_to_Z**2*US%T_to_s**2) + call get_param(param_file, mdl, "TAIL_DH", CS%MLE_tail_dh, & + "Fraction by which to extend the mixed-layer restratification "//& + "depth used for a smoother stream function at the base of "//& + "the mixed-layer.", units="nondim", default=0.0) + call get_param(param_file, mdl, "USE_STANLEY_TVAR", CS%use_Stanley_ML, & + "If true, turn on Stanley SGS T variance parameterization "// & + "in ML restrat code.", default=.false.) + call get_param(param_file, mdl, "USE_CR_GRID", CS%Cr_grid, & + "If true, read in a spatially varying Cr field.", default=.false.) + call get_param(param_file, mdl, "USE_MLD_GRID", CS%MLD_grid, & + "If true, read in a spatially varying MLD_decaying_Tfilt field.", default=.false.) + if (CS%MLD_grid) then + call get_param(param_file, mdl, "MLD_TFILT_FILE", filename, & + "The path to the file containing the MLD_decaying_Tfilt fields.", & + default="") + call get_param(param_file, mdl, "MLD_TFILT_VAR", varname, & + "The variable name for MLD_decaying_Tfilt field.", & + default="MLD_tfilt") + filename = trim(inputdir) // "/" // trim(filename) + allocate(CS%MLD_Tfilt_space(G%isd:G%ied,G%jsd:G%jed), source=0.0) + call MOM_read_data(filename, varname, CS%MLD_Tfilt_space, G%domain, scale=US%s_to_T) + call pass_var(CS%MLD_Tfilt_space, G%domain) + endif + allocate(CS%Cr_space(G%isd:G%ied,G%jsd:G%jed), source=CS%Cr) + if (CS%Cr_grid) then + call get_param(param_file, mdl, "CR_FILE", filename, & + "The path to the file containing the Cr fields.", & + default="") + call get_param(param_file, mdl, "CR_VAR", varname, & + "The variable name for Cr field.", & + default="Cr") + filename = trim(inputdir) // "/" // trim(filename) + call MOM_read_data(filename, varname, CS%Cr_space, G%domain) + call pass_var(CS%Cr_space, G%domain) + endif + call closeParameterBlock(param_file) ! The remaining parameters do not have MLE% prepended + call get_param(param_file, mdl, "MLE_USE_PBL_MLD", CS%MLE_use_PBL_MLD, & + "If true, the MLE parameterization will use the mixed-layer "//& + "depth provided by the active PBL parameterization. If false, "//& + "MLE will estimate a MLD based on a density difference with the "//& + "surface using the parameter MLE_DENSITY_DIFF, unless "//& + "BODNER_DETECT_MLD is true.", default=.false.) + call get_param(param_file, mdl, "BODNER_DETECT_MLD", CS%Bodner_detect_MLD, & + "If true, the Bodner parameterization will use the mixed-layer depth "//& + "detected via the density difference criterion MLE_DENSITY_DIFF.", default=.false.) + if (.not.(CS%MLE_use_PBL_MLD.or.CS%Bodner_detect_MLD)) call MOM_error(FATAL, "mixedlayer_restrat_init: "// & + "To use MLE%USE_BODNER23=True then MLE_USE_PBL_MLD or BODNER_DETECT_MLD must be true.") + if (CS%MLE_use_PBL_MLD.and.CS%Bodner_detect_MLD) call MOM_error(FATAL, "mixedlayer_restrat_init: "// & + "MLE_USE_PBL_MLD and BODNER_DETECT_MLD cannot both be true.") + else + call closeParameterBlock(param_file) ! The remaining parameters do not have MLE% prepended + endif + + if (.not.CS%use_Bodner) then + ! This coefficient is used in both layered and ALE versions of Fox-Kemper but not Bodner + call get_param(param_file, mdl, "FOX_KEMPER_ML_RESTRAT_COEF", CS%ml_restrat_coef, & "A nondimensional coefficient that is proportional to "//& "the ratio of the deformation radius to the dominant "//& "lengthscale of the submesoscale mixed layer "//& @@ -841,48 +1791,109 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, "mesoscale eddy kinetic energy to the large-scale "//& "geostrophic kinetic energy or 1 plus the square of the "//& "grid spacing over the deformation radius, as detailed "//& - "by Fox-Kemper et al. (2010)", units="nondim", default=0.0) - ! We use GV%nkml to distinguish between the old and new implementation of MLE. - ! The old implementation only works for the layer model with nkml>0. - if (GV%nkml==0) then - call get_param(param_file, mdl, "FOX_KEMPER_ML_RESTRAT_COEF2", CS%ml_restrat_coef2, & + "by Fox-Kemper et al. (2011)", units="nondim", default=0.0) + ! These parameters are only used in the OM4-era version of Fox-Kemper + call get_param(param_file, mdl, "USE_STANLEY_ML", CS%use_Stanley_ML, & + "If true, turn on Stanley SGS T variance parameterization "// & + "in ML restrat code.", default=.false.) + if (CS%use_Stanley_ML) then + call get_param(param_file, mdl, "STANLEY_COEFF", Stanley_coeff, & + "Coefficient correlating the temperature gradient and SGS T variance.", & + units="nondim", default=-1.0, do_not_log=.true.) + if (Stanley_coeff < 0.0) call MOM_error(FATAL, & + "STANLEY_COEFF must be set >= 0 if USE_STANLEY_ML is true.") + endif + call get_param(param_file, mdl, 'VON_KARMAN_CONST', CS%vonKar, & + 'The value the von Karman constant as used for mixed layer viscosity.', & + units='nondim', default=0.41) + ! We use GV%nkml to distinguish between the old and new implementation of MLE. + ! The old implementation only works for the layer model with nkml>0. + if (GV%nkml==0) then + call get_param(param_file, mdl, "FOX_KEMPER_ML_RESTRAT_COEF2", CS%ml_restrat_coef2, & "As for FOX_KEMPER_ML_RESTRAT_COEF but used in a second application "//& "of the MLE restratification parameterization.", units="nondim", default=0.0) - call get_param(param_file, mdl, "MLE_FRONT_LENGTH", CS%front_length, & + call get_param(param_file, mdl, "MLE_FRONT_LENGTH", CS%front_length, & "If non-zero, is the frontal-length scale used to calculate the "//& "upscaling of buoyancy gradients that is otherwise represented "//& "by the parameter FOX_KEMPER_ML_RESTRAT_COEF. If MLE_FRONT_LENGTH is "//& "non-zero, it is recommended to set FOX_KEMPER_ML_RESTRAT_COEF=1.0.",& units="m", default=0.0, scale=US%m_to_L) - call get_param(param_file, mdl, "MLE_USE_PBL_MLD", CS%MLE_use_PBL_MLD, & + call get_param(param_file, mdl, "MLE_FRONT_LENGTH_FROM_FILE", CS%fl_from_file, & + "If true, the MLE front-length scale is read from a file.", default=.false.) + if (CS%fl_from_file) then + call time_interp_external_init() + + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + call get_param(param_file, mdl, "MLE_FL_FILE", mle_fl_file, & + "MLE_FL_FILE is the file containing MLE front-length scale. "//& + "It is used when MLE_FRONT_LENGTH_FROM_FILE is true.", fail_if_missing=.true.) + mle_fl_filename = trim(slasher(inputdir))//trim(mle_fl_file) + call log_param(param_file, mdl, "INPUTDIR/MLE_FL_FILE", mle_fl_filename) + call get_param(param_file, mdl, "FL_VARNAME", fl_varname, & + "Name of MLE front-length scale variable in MLE_FL_FILE.", default='mle_fl') + if (modulo(G%Domain%turns, 4) /= 0) then + CS%sbc_fl = init_external_field(mle_fl_filename, trim(fl_varname), MOM_domain=G%Domain%domain_in) + else + CS%sbc_fl = init_external_field(mle_fl_filename, trim(fl_varname), MOM_domain=G%Domain) + endif + endif + if (CS%fl_from_file .and. CS%front_length>0.0) call MOM_error(FATAL, "mixedlayer_restrat_init: "// & + "MLE_FRONT_LENGTH_FROM_FILE cannot be true when MLE_FRONT_LENGTH > 0.0. "// & + "If you want to use MLE_FRONT_LENGTH, set MLE_FRONT_LENGTH_FROM_FILE to false. " // & + "If you want to use MLE_FRONT_LENGTH_FROM_FILE, set MLE_FRONT_LENGTH to 0.0.") + call get_param(param_file, mdl, "MLE_USE_PBL_MLD", CS%MLE_use_PBL_MLD, & "If true, the MLE parameterization will use the mixed-layer "//& "depth provided by the active PBL parameterization. If false, "//& "MLE will estimate a MLD based on a density difference with the "//& "surface using the parameter MLE_DENSITY_DIFF.", default=.false.) - call get_param(param_file, mdl, "MLE_MLD_DECAY_TIME", CS%MLE_MLD_decay_time, & + call get_param(param_file, mdl, "MLE_MLD_DECAY_TIME", CS%MLE_MLD_decay_time, & "The time-scale for a running-mean filter applied to the mixed-layer "//& "depth used in the MLE restratification parameterization. When "//& "the MLD deepens below the current running-mean the running-mean "//& "is instantaneously set to the current MLD.", units="s", default=0., scale=US%s_to_T) - call get_param(param_file, mdl, "MLE_MLD_DECAY_TIME2", CS%MLE_MLD_decay_time2, & + call get_param(param_file, mdl, "MLE_MLD_DECAY_TIME2", CS%MLE_MLD_decay_time2, & "The time-scale for a running-mean filter applied to the filtered "//& "mixed-layer depth used in a second MLE restratification parameterization. "//& "When the MLD deepens below the current running-mean the running-mean "//& "is instantaneously set to the current MLD.", units="s", default=0., scale=US%s_to_T) - if (.not. CS%MLE_use_PBL_MLD) then - call get_param(param_file, mdl, "MLE_DENSITY_DIFF", CS%MLE_density_diff, & + if (.not. CS%MLE_use_PBL_MLD) then + call get_param(param_file, mdl, "MLE_DENSITY_DIFF", CS%MLE_density_diff, & "Density difference used to detect the mixed-layer "//& "depth used for the mixed-layer eddy parameterization "//& - "by Fox-Kemper et al. (2010)", units="kg/m3", default=0.03, scale=US%kg_m3_to_R) - endif - call get_param(param_file, mdl, "MLE_TAIL_DH", CS%MLE_tail_dh, & + "by Fox-Kemper et al. (2011)", units="kg/m3", default=0.03, scale=US%kg_m3_to_R) + endif + call get_param(param_file, mdl, "MLE_TAIL_DH", CS%MLE_tail_dh, & "Fraction by which to extend the mixed-layer restratification "//& "depth used for a smoother stream function at the base of "//& "the mixed-layer.", units="nondim", default=0.0) - call get_param(param_file, mdl, "MLE_MLD_STRETCH", CS%MLE_MLD_stretch, & + call get_param(param_file, mdl, "MLE_MLD_STRETCH", CS%MLE_MLD_stretch, & "A scaling coefficient for stretching/shrinking the MLD "//& "used in the MLE scheme. This simply multiplies MLD wherever used.",& units="nondim", default=1.0) + endif + call get_param(param_file, mdl, "KV_RESTRAT", CS%Kv_restrat, & + "A small viscosity that sets a floor on the momentum mixing rate during "//& + "restratification. If this is positive, it will prevent some possible "//& + "divisions by zero even if ustar, RESTRAT_USTAR_MIN, and f are all 0.", & + units="m2 s-1", default=0.0, scale=GV%m2_s_to_HZ_T*(US%Z_to_m*GV%m_to_H)) + call get_param(param_file, mdl, "OMEGA", omega, & + "The rotation rate of the earth.", & + units="s-1", default=7.2921e-5, scale=US%T_to_s) + ustar_min_dflt = 2.0e-4 * omega * (GV%Angstrom_Z + GV%dZ_subroundoff) + call get_param(param_file, mdl, "RESTRAT_USTAR_MIN", CS%ustar_min, & + "The minimum value of ustar that will be used by the mixed layer "//& + "restratification module. This can be tiny, but if this is greater than 0, "//& + "it will prevent divisions by zero when f and KV_RESTRAT are zero.", & + units="m s-1", default=US%Z_to_m*US%s_to_T*ustar_min_dflt, scale=GV%m_to_H*US%T_to_s) + elseif (CS%Bodner_detect_MLD) then + call get_param(param_file, mdl, "MLE_DENSITY_DIFF", CS%MLE_density_diff, & + "Density difference used to detect the mixed-layer "//& + "depth used for the mixed-layer eddy parameterization "//& + "by Fox-Kemper et al. (2010)", units="kg/m3", default=0.03, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "MLE_MLD_STRETCH", CS%MLE_MLD_stretch, & + "A scaling coefficient for stretching/shrinking the MLD "//& + "used in the MLE scheme. This simply multiplies MLD wherever used.",& + units="nondim", default=1.0) endif CS%diag => diag @@ -902,9 +1913,12 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, CS%id_MLD = register_diag_field('ocean_model', 'MLD_restrat', diag%axesT1, Time, & 'Mixed Layer Depth as used in the mixed-layer restratification parameterization', & 'm', conversion=GV%H_to_m) + CS%id_BLD = register_diag_field('ocean_model', 'BLD_restrat', diag%axesT1, Time, & + 'Boundary Layer Depth as used in the mixed-layer restratification parameterization', & + 'm', conversion=GV%H_to_m) CS%id_Rml = register_diag_field('ocean_model', 'ML_buoy_restrat', diag%axesT1, Time, & 'Mixed Layer Buoyancy as used in the mixed-layer restratification parameterization', & - 'm s2', conversion=US%m_to_Z*(US%L_T_to_m_s**2)) + 'm s-2', conversion=GV%m_to_H*(US%L_T_to_m_s**2)) CS%id_uDml = register_diag_field('ocean_model', 'udml_restrat', diag%axesCu1, Time, & 'Transport stream function amplitude for zonal restratification of mixed layer', & 'm3 s-1', conversion=GV%H_to_m*(US%L_to_m**2)*US%s_to_T) @@ -917,42 +1931,45 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, CS%id_vml = register_diag_field('ocean_model', 'vml_restrat', diag%axesCv1, Time, & 'Surface meridional velocity component of mixed layer restratification', & 'm s-1', conversion=US%L_T_to_m_s) - - ! Rescale variables from restart files if the internal dimensional scalings have changed. - if (CS%MLE_MLD_decay_time>0. .or. CS%MLE_MLD_decay_time2>0.) then - if (query_initialized(CS%MLD_filtered, "MLD_MLE_filtered", restart_CS) .and. & - (GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= GV%m_to_H)) then - H_rescale = GV%m_to_H / GV%m_to_H_restart - do j=G%jsc,G%jec ; do i=G%isc,G%iec - CS%MLD_filtered(i,j) = H_rescale * CS%MLD_filtered(i,j) - enddo ; enddo - endif - endif - if (CS%MLE_MLD_decay_time2>0.) then - if (query_initialized(CS%MLD_filtered_slow, "MLD_MLE_filtered_slow", restart_CS) .and. & - (GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= GV%m_to_H)) then - H_rescale = GV%m_to_H / GV%m_to_H_restart - do j=G%jsc,G%jec ; do i=G%isc,G%iec - CS%MLD_filtered_slow(i,j) = H_rescale * CS%MLD_filtered_slow(i,j) - enddo ; enddo - endif + if (CS%use_Bodner) then + CS%id_wpup = register_diag_field('ocean_model', 'MLE_wpup', diag%axesT1, Time, & + 'Vertical turbulent momentum flux in Bodner mixed layer restratification parameterization', & + 'm2 s-2', conversion=US%L_to_m*GV%H_to_m*US%s_to_T**2) + CS%id_ustar = register_diag_field('ocean_model', 'MLE_ustar', diag%axesT1, Time, & + 'Surface turbulent friction velocity, u*, in Bodner mixed layer restratification parameterization', & + 'm s-1', conversion=(US%Z_to_m*US%s_to_T)) + CS%id_bflux = register_diag_field('ocean_model', 'MLE_bflux', diag%axesT1, Time, & + 'Surface buoyancy flux, B0, in Bodner mixed layer restratification parameterization', & + 'm2 s-3', conversion=(US%Z_to_m**2*US%s_to_T**3)) + CS%id_lfbod = register_diag_field('ocean_model', 'lf_bodner', diag%axesT1, Time, & + 'Front length in Bodner mixed layer restratificiation parameterization', & + 'm', conversion=US%L_to_m) + else + CS%id_mle_fl = register_diag_field('ocean_model', 'mle_fl', diag%axesT1, Time, & + 'Frontal length scale used in the mixed layer restratificiation parameterization', & + 'm', conversion=US%L_to_m) endif ! If MLD_filtered is being used, we need to update halo regions after a restart if (allocated(CS%MLD_filtered)) call pass_var(CS%MLD_filtered, G%domain) + if (allocated(CS%MLD_filtered_slow)) call pass_var(CS%MLD_filtered_slow, G%domain) + if (allocated(CS%wpup_filtered)) call pass_var(CS%wpup_filtered, G%domain) end function mixedlayer_restrat_init !> Allocate and register fields in the mixed layer restratification structure for restarts -subroutine mixedlayer_restrat_register_restarts(HI, param_file, CS, restart_CS) +subroutine mixedlayer_restrat_register_restarts(HI, GV, US, param_file, CS, restart_CS) ! Arguments type(hor_index_type), intent(in) :: HI !< Horizontal index structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file to parse type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure - type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure + ! Local variables - type(vardesc) :: vd - logical :: mixedlayer_restrat_init + character(len=64) :: mom_flux_units + logical :: mixedlayer_restrat_init, use_Bodner ! Check to see if this module will be used call get_param(param_file, mdl, "MIXEDLAYER_RESTRAT", mixedlayer_restrat_init, & @@ -960,53 +1977,139 @@ subroutine mixedlayer_restrat_register_restarts(HI, param_file, CS, restart_CS) if (.not. mixedlayer_restrat_init) return call get_param(param_file, mdl, "MLE_MLD_DECAY_TIME", CS%MLE_MLD_decay_time, & - default=0., do_not_log=.true.) + units="s", default=0., scale=US%s_to_T, do_not_log=.true.) call get_param(param_file, mdl, "MLE_MLD_DECAY_TIME2", CS%MLE_MLD_decay_time2, & - default=0., do_not_log=.true.) - if (CS%MLE_MLD_decay_time>0. .or. CS%MLE_MLD_decay_time2>0.) then + units="s", default=0., scale=US%s_to_T, do_not_log=.true.) + call openParameterBlock(param_file, 'MLE', do_not_log=.true.) + call get_param(param_file, mdl, "USE_BODNER23", use_Bodner, & + default=.false., do_not_log=.true.) + call closeParameterBlock(param_file) + if (CS%MLE_MLD_decay_time>0. .or. CS%MLE_MLD_decay_time2>0. .or. use_Bodner) then ! CS%MLD_filtered is used to keep a running mean of the PBL's actively mixed MLD. allocate(CS%MLD_filtered(HI%isd:HI%ied,HI%jsd:HI%jed), source=0.) - vd = var_desc("MLD_MLE_filtered","m","Time-filtered MLD for use in MLE", & - hor_grid='h', z_grid='1') - call register_restart_field(CS%MLD_filtered, vd, .false., restart_CS) + call register_restart_field(CS%MLD_filtered, "MLD_MLE_filtered", .false., restart_CS, & + longname="Time-filtered MLD for use in MLE", & + units=get_thickness_units(GV), conversion=GV%H_to_MKS) endif - if (CS%MLE_MLD_decay_time2>0.) then + if (CS%MLE_MLD_decay_time2>0. .or. use_Bodner) then ! CS%MLD_filtered_slow is used to keep a running mean of the PBL's seasonal or winter MLD. allocate(CS%MLD_filtered_slow(HI%isd:HI%ied,HI%jsd:HI%jed), source=0.) - vd = var_desc("MLD_MLE_filtered_slow","m","c Slower time-filtered MLD for use in MLE", & - hor_grid='h', z_grid='1') - call register_restart_field(CS%MLD_filtered_slow, vd, .false., restart_CS) + call register_restart_field(CS%MLD_filtered_slow, "MLD_MLE_filtered_slow", .false., restart_CS, & + longname="Slower time-filtered MLD for use in MLE", & + units=get_thickness_units(GV), conversion=GV%H_to_MKS) + endif + if (use_Bodner) then + ! CS%MLD_filtered_slow is used to keep a running mean of the PBL's seasonal or winter MLD. + mom_flux_units = "m2 s-2" ; if (.not.GV%Boussinesq) mom_flux_units = "kg m-1 s-2" + allocate(CS%wpup_filtered(HI%isd:HI%ied,HI%jsd:HI%jed), source=0.) + call register_restart_field(CS%wpup_filtered, "MLE_Bflux", .false., restart_CS, & + longname="Time-filtered vertical turbulent momentum flux for use in MLE", & + units=mom_flux_units, conversion=US%L_to_m*GV%H_to_mks*US%s_to_T**2 ) endif end subroutine mixedlayer_restrat_register_restarts +!> Returns true if a unit test of functions in MOM_mixedlayer_restrat fail. +!! Returns false otherwise. +logical function mixedlayer_restrat_unit_tests(verbose) + logical, intent(in) :: verbose !< If true, write results to stdout + + ! Local variables + logical :: this_test + + print *,'===== mixedlayer_restrat: mixedlayer_restrat_unit_tests ==================' + + ! Tests of the shape function mu(z) + this_test = & + test_answer(verbose, mu(3.,0.), 0., 'mu(3)=0') + this_test = this_test .or. & + test_answer(verbose, mu(0.,0.), 0., 'mu(0)=0') + this_test = this_test .or. & + test_answer(verbose, mu(-0.25,0.), 0.7946428571428572, 'mu(-0.25)=0.7946...', tol=epsilon(1.)) + this_test = this_test .or. & + test_answer(verbose, mu(-0.5,0.), 1., 'mu(-0.5)=1') + this_test = this_test .or. & + test_answer(verbose, mu(-0.75,0.), 0.7946428571428572, 'mu(-0.75)=0.7946...', tol=epsilon(1.)) + this_test = this_test .or. & + test_answer(verbose, mu(-1.,0.), 0., 'mu(-1)=0') + this_test = this_test .or. & + test_answer(verbose, mu(-3.,0.), 0., 'mu(-3)=0') + this_test = this_test .or. & + test_answer(verbose, mu(-0.5,0.5), 1., 'mu(-0.5,0.5)=1') + this_test = this_test .or. & + test_answer(verbose, mu(-1.,0.5), 0.25, 'mu(-1,0.5)=0.25') + this_test = this_test .or. & + test_answer(verbose, mu(-1.5,0.5), 0., 'mu(-1.5,0.5)=0') + if (.not. this_test) print '(a)',' Passed tests of mu(z)' + mixedlayer_restrat_unit_tests = this_test + + ! Tests of the two time-scale running mean function + this_test = & + test_answer(verbose, rmean2ts(3.,2.,0.,0.,3.), 3., 'rmean2ts(3,2,0,0,3)=3') + this_test = this_test .or. & + test_answer(verbose, rmean2ts(1.,2.,0.,0.,3.), 1., 'rmean2ts(1,2,0,0,3)=1') + this_test = this_test .or. & + test_answer(verbose, rmean2ts(4.,0.,3.,0.,1.), 1., 'rmean2ts(4,0,3,0,1)=1') + this_test = this_test .or. & + test_answer(verbose, rmean2ts(0.,4.,0.,3.,1.), 3., 'rmean2ts(0,4,0,3,1)=3') + if (.not. this_test) print '(a)',' Passed tests of rmean2ts(s,f,g,d,dt)' + mixedlayer_restrat_unit_tests = mixedlayer_restrat_unit_tests .or. this_test + +end function mixedlayer_restrat_unit_tests + +!> Returns true if any cell of u and u_true are not identical. Returns false otherwise. +logical function test_answer(verbose, u, u_true, label, tol) + logical, intent(in) :: verbose !< If true, write results to stdout + real, intent(in) :: u !< Values to test in arbitrary units [A] + real, intent(in) :: u_true !< Values to test against (correct answer) [A] + character(len=*), intent(in) :: label !< Message + real, optional, intent(in) :: tol !< The tolerance for differences between u and u_true [A] + ! Local variables + real :: tolerance ! The tolerance for differences between u and u_true [A] + + tolerance = 0.0 ; if (present(tol)) tolerance = tol + test_answer = .false. + + if (abs(u - u_true) > tolerance) test_answer = .true. + if (test_answer .or. verbose) then + if (test_answer) then + print '(3(a,1pe24.16),1x,a,1x,a)','computed =',u,' correct =',u_true, & + ' err=',u-u_true,' < wrong',label + else + print '(2(a,1pe24.16),1x,a)','computed =',u,' correct =',u_true,label + endif + endif + +end function test_answer + !> \namespace mom_mixed_layer_restrat !! !! \section section_mle Mixed-layer eddy parameterization module !! -!! The subroutines in this file implement a parameterization of unresolved viscous -!! mixed layer restratification of the mixed layer as described in Fox-Kemper et -!! al., 2008, and whose impacts are described in Fox-Kemper et al., 2011. +!! The subroutines in this module implement a parameterization of unresolved viscous +!! mixed layer restratification of the mixed layer as described in \cite fox-kemper2008, +!! and whose impacts are described in \cite fox-kemper2011. !! This is derived in part from the older parameterization that is described in -!! Hallberg (Aha Hulikoa, 2003), which this new parameterization surpasses, which -!! in turn is based on the sub-inertial mixed layer theory of Young (JPO, 1994). +!! \cite Hallberg2003, which this new parameterization surpasses, which +!! in turn is based on the sub-inertial mixed layer theory of \cite Young1994. !! There is no net horizontal volume transport due to this parameterization, and -!! no direct effect below the mixed layer. +!! no direct effect below the mixed layer. A revised version of the parameterization by +!! \cite Bodner2023 is also available as an option. !! !! This parameterization sets the restratification timescale to agree with !! high-resolution studies of mixed layer restratification. !! -!! The run-time parameter FOX_KEMPER_ML_RESTRAT_COEF is a non-dimensional number of +!! The run-time parameter FOX_KEMPER_ML_RESTRAT_COEF is a non-dimensional number of !! order a few tens, proportional to the ratio of the deformation radius or the -!! grid scale (whichever is smaller to the dominant horizontal length-scale of the +!! grid scale (whichever is smaller) to the dominant horizontal length-scale of the !! sub-meso-scale mixed layer instabilities. !! !! \subsection section_mle_nutshell "Sub-meso" in a nutshell !! !! The parameterization is colloquially referred to as "sub-meso". !! -!! The original Fox-Kemper et al., (2008b) paper proposed a quasi-Stokes -!! advection described by the stream function (eq. 5 of Fox-Kemper et al., 2011): +!! The original \cite fox-kemper2008-2 paper proposed a quasi-Stokes +!! advection described by the stream function (eq. 5 of \cite fox-kemper2011): !! \f[ !! {\bf \Psi}_o = C_e \frac{ H^2 \nabla \bar{b} \times \hat{\bf z} }{ |f| } \mu(z) !! \f] @@ -1020,7 +2123,7 @@ end subroutine mixedlayer_restrat_register_restarts !! \f$ \nabla \bar{b} \f$ is a depth mean buoyancy gradient averaged over the mixed layer. !! !! For use in coarse-resolution models, an upscaling of the buoyancy gradients and adaption for the equator -!! leads to the following parameterization (eq. 6 of Fox-Kemper et al., 2011): +!! leads to the following parameterization (eq. 6 of \cite fox-kemper2011): !! \f[ !! {\bf \Psi} = C_e \Gamma_\Delta \frac{\Delta s}{l_f} \frac{ H^2 \nabla \bar{b} \times \hat{\bf z} } !! { \sqrt{ f^2 + \tau^{-2}} } \mu(z) @@ -1030,16 +2133,23 @@ end subroutine mixedlayer_restrat_register_restarts !! \f$ \tau \f$ is a time-scale for mixing momentum across the mixed layer. !! \f$ l_f \f$ is thought to be of order hundreds of meters. !! -!! The upscaling factor \f$ \frac{\Delta s}{l_f} \f$ can be a global constant, model parameter FOX_KEMPER_ML_RESTRAT, -!! so that in practice the parameterization is: +!! The upscaling factor \f$ \frac{\Delta s}{l_f} \f$ can be a global constant, model parameter +!! FOX_KEMPER_ML_RESTRAT, so that in practice the parameterization is: !! \f[ !! {\bf \Psi} = C_e \Gamma_\Delta \frac{ H^2 \nabla \bar{b} \times \hat{\bf z} }{ \sqrt{ f^2 + \tau^{-2}} } \mu(z) !! \f] !! with non-unity \f$ \Gamma_\Delta \f$. !! !! \f$ C_e \f$ is hard-coded as 0.0625. \f$ \tau \f$ is calculated from the surface friction velocity \f$ u^* \f$. +!! !! \todo Explain expression for momentum mixing time-scale. !! +!! | Symbol | Module parameter | +!! | ---------------------------- | --------------------- | +!! | \f$ \Gamma_\Delta \f$ | FOX_KEMPER_ML_RESTRAT | +!! | \f$ l_f \f$ | MLE_FRONT_LENGTH | +!! | \f$ \Delta \rho \f$ | MLE_DENSITY_DIFF | +!! !! \subsection section_mle_filtering Time-filtering of mixed-layer depth !! !! Using the instantaneous mixed-layer depth is inconsistent with the finite life-time of @@ -1051,6 +2161,10 @@ end subroutine mixedlayer_restrat_register_restarts !! but to decay with time-scale \f$ \tau_h \f$. !! \f$ \bar{H} \f$ is substituted for \f$ H \f$ in the above equations. !! +!! | Symbol | Module parameter | +!! | ---------------------------- | --------------------- | +!! | \f$ \tau_h \f$ | MLE_MLD_DECAY_TIME | +!! !! \subsection section_mle_mld Defining the mixed-layer-depth !! !! If the parameter MLE_USE_PBL_MLD=True then the mixed-layer depth is defined/diagnosed by the @@ -1060,6 +2174,59 @@ end subroutine mixedlayer_restrat_register_restarts !! as the depth of a given density difference, \f$ \Delta \rho \f$, with the surface where the !! density difference is the parameter MLE_DENSITY_DIFF. !! +!! \subsection The Bodner (2023) modification +!! +!! To use this variant of the parameterization, set MLE\%USE_BODNER23=True which then changes the +!! available parameters. +!! MLE_USE_PBL_MLD must be True to use the B23 modification. +!! +!! \cite Bodner2023, (B23) use an expression for the frontal width which changes the scaling from \f$ H^2 \f$ +!! to \f$ h H^2 \f$: +!! \f[ +!! {\bf \Psi} = C_r \frac{\Delta s |f| \bar{h} \bar{H}^2 \nabla \bar{b} \times \hat{\bf z} } +!! { \left( m_*u_*^3 + n_* w_*^3 \right)^{2/3} } \mu(z) +!! \f] +!! (see eq. 27 of B23). +!! Here, the \f$h\f$ is the activate boundary layer depth, and \f$H\f$ is the mixed layer depth. +!! The denominator is an approximation of the vertical turbulent momentum flux \f$\overline{w'u'}\f$ (see +!! eq. 18 of B23) calculated from the surface friction velocity \f$u_*\f$, and from the surface buoyancy flux, +!! \f$B\f$, using the relation \f$ w_*^3 \sim -B h \f$. +!! An advantage of this form of "sub-meso" is the denominator is well behaved at the equator but we apply a +!! lower bound of \f$w_{min}^2\f$ to avoid division by zero under zero forcing. +!! As for the original Fox-Kemper parameterization, \f$\nabla \bar{b}\f$ is the buoyancy gradient averaged +!! over the mixed-layer. +!! +!! The instantaneous boundary layer depth, \f$h\f$, is time filtered primarily to remove the diurnal cycle: +!! \f[ +!! \bar{h} \leftarrow \max \left( +!! \min \left( h, \frac{ \Delta t h + \tau_{h+} \bar{h} }{ \Delta t + \tau_{h+} } \right), +!! \frac{ \Delta t h + \tau_{h-} \bar{h} }{ \Delta t + \tau_{h-} } \right) +!! \f] +!! Setting \f$ \tau_{h+}=0 \f$ means that when \f$ h>\bar{h} \f$ then \f$\bar{h}\leftarrow h\f$, i.e. the +!! effective (filtered) depth, \f$\bar{h}\f$, is instantly deepened. When \f$h<\bar{h}\f$ then the effective +!! depth shoals with time-scale \f$\tau_{h-}\f$. +!! +!! A second filter is applied to \f$\bar{h}\f$ to yield and effective "mixed layer depth", \f$\bar{H}\f$, +!! defined as the deepest the boundary layer over some time-scale \f$\tau_{H-}\f$: +!! \f[ +!! \bar{H} \leftarrow \max \left( +!! \min \left( \bar{h}, \frac{ \Delta t \bar{h} + \tau_{H+} \bar{H} }{ \Delta t + \tau_{H+} } \right), +!! \frac{ \Delta t \bar{h} + \tau_{h-} \bar{H} }{ \Delta t + \tau_{H-} } \right) +!! \f] +!! Again, setting \f$ \tau_{H+}=0 \f$ allows the effective mixed layer to instantly deepend to \f$ \bar{h} \f$. +!! +!! | Symbol | Module parameter | +!! | ---------------------------- | ------------------------- | +!! | \f$ C_r \f$ | MLE\%CR | +!! | \f$ n_* \f$ | MLE\%BODNER_NSTAR | +!! | \f$ m_* \f$ | MLE\%BODNER_MSTAR | +!! | \f$ w_* \f$ | MLE\%BODNER_MSTAR | +!! | \f$ w_{min}^2 \f$ | MLE\%MIN_WSTAR2 | +!! | \f$ \tau_{h+} \f$ | MLE\%BLD_GROWING_TFILTER | +!! | \f$ \tau_{h-} \f$ | MLE\%BLD_DECAYING_TFILTER | +!! | \f$ \tau_{H+} \f$ | MLE\%MLD_GROWING_TFILTER | +!! | \f$ \tau_{H-} \f$ | MLE\%MLD_DECAYING_TFILTER | +!! !! \subsection section_mle_ref References !! !! Fox-Kemper, B., Ferrari, R. and Hallberg, R., 2008: @@ -1077,11 +2244,9 @@ end subroutine mixedlayer_restrat_register_restarts !! in global ocean climate simulations. Ocean Modell., 39(1), p61-78. !! https://doi.org/10.1016/j.ocemod.2010.09.002 !! -!! | Symbol | Module parameter | -!! | ---------------------------- | --------------------- | -!! | \f$ \Gamma_\Delta \f$ | FOX_KEMPER_ML_RESTRAT | -!! | \f$ l_f \f$ | MLE_FRONT_LENGTH | -!! | \f$ \tau_h \f$ | MLE_MLD_DECAY_TIME | -!! | \f$ \Delta \rho \f$ | MLE_DENSITY_DIFF | +!! A.S. Bodner, B. Fox-Kemper, L. Johnson, L. P. Van Roekel, J. C. McWilliams, P. P. Sullivan, P. S. Hall, +!! and J. Dong, 2023: Modifying the Mixed Layer Eddy Parameterization to Include Frontogenesis Arrest by +!! Boundary Layer Turbulence. J. Phys. Oceanogr., 53(1), p323-339. +!! https://doi.org/10.1175/JPO-D-21-0297.1 end module MOM_mixed_layer_restrat diff --git a/src/parameterizations/lateral/MOM_self_attr_load.F90 b/src/parameterizations/lateral/MOM_self_attr_load.F90 new file mode 100644 index 0000000000..7f6e35008c --- /dev/null +++ b/src/parameterizations/lateral/MOM_self_attr_load.F90 @@ -0,0 +1,400 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +module MOM_self_attr_load + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_MODULE +use MOM_domains, only : pass_var +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : find_col_mass +use MOM_io, only : MOM_infra_file, MOM_field, vardesc, slasher +use MOM_io, only : create_MOM_file, MOM_read_data, MOM_write_field, var_desc +use MOM_load_love_numbers, only : Love_Data +use MOM_restart, only : is_new_run, MOM_restart_CS +use MOM_spherical_harmonics, only : spherical_harmonics_init, spherical_harmonics_end +use MOM_spherical_harmonics, only : spherical_harmonics_forward, spherical_harmonics_inverse +use MOM_spherical_harmonics, only : sht_CS, order2index, calc_lmax +use MOM_string_functions, only : lowercase +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +public calc_SAL, scalar_SAL_sensitivity, SAL_init, SAL_end + +#include + +!> The control structure for the MOM_self_attr_load module +type, public :: SAL_CS ; private + logical :: use_sal_scalar = .false. + !< If true, use the scalar approximation to calculate SAL. + logical :: use_sal_sht = .false. + !< If true, use online spherical harmonics to calculate SAL + logical :: use_tidal_sal_prev = .false. + !< If true, read the tidal SAL from the previous iteration of the tides to + !! facilitate convergence. + logical :: use_bpa = .false. + !< If true, use bottom pressure anomaly instead of SSH to calculate SAL. + real :: eta_prop + !< The partial derivative of eta_sal with the local value of eta [nondim]. + real :: linear_scaling + !< Dimensional coefficients for scalar SAL [nondim] or [Z T2 L-2 R-1 ~> m Pa-1] + type(sht_CS), allocatable :: sht + !< Spherical harmonic transforms (SHT) control structure + integer :: sal_sht_Nd + !< Maximum degree for spherical harmonic transforms [nondim] + real, allocatable :: pbot_ref(:,:) + !< Reference bottom pressure [R L2 T-2 ~> Pa] + real, allocatable :: Love_scaling(:) + !< Dimensional coefficients for harmonic SAL, which are functions of Love numbers + !! [nondim] or [Z T2 L-2 R-1 ~> m Pa-1], depending on the value of use_ppa. + real, allocatable :: Snm_Re(:), & !< Real SHT coefficient for SHT SAL [Z ~> m] + Snm_Im(:) !< Imaginary SHT coefficient for SHT SAL [Z ~> m] +end type SAL_CS + +integer :: id_clock_SAL !< CPU clock for self-attraction and loading + +contains + +!> This subroutine calculates seawater self-attraction and loading based on either sea surface height (SSH) or bottom +!! pressure anomaly. Note that the SAL calculation applies to all motions across the spectrum. Tidal-specific methods +!! that assume periodicity, i.e. iterative and read-in SAL, are stored in MOM_tidal_forcing module. +!! The input field can be either SSH [Z ~> m] or total bottom pressure [R L2 T-2 ~> Pa]. If total bottom pressure is +!! used, bottom pressure anomaly is first calculated by subtracting a reference bottom pressure from an input file. +!! The output field is expressed as geopotential height anomaly, and therefore has the unit of [Z ~> m]. +subroutine calc_SAL(eta, eta_sal, G, CS, tmp_scale) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta !< The sea surface height anomaly from + !! a time-mean geoid or total bottom pressure [Z ~> m] or [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_sal !< The geopotential height anomaly from + !! self-attraction and loading [Z ~> m]. + type(SAL_CS), intent(inout) :: CS !< The control structure returned by a previous call to SAL_init. + real, optional, intent(in) :: tmp_scale !< A rescaling factor to temporarily convert eta + !! to MKS units in reproducing sumes [m Z-1 ~> 1] + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: bpa ! SSH or bottom pressure anomaly [Z ~> m] or [R L2 T-2 ~> Pa] + integer :: n, m, l + integer :: Isq, Ieq, Jsq, Jeq + integer :: i, j + + call cpu_clock_begin(id_clock_SAL) + + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + if (CS%use_bpa) then ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + bpa(i,j) = eta(i,j) - CS%pbot_ref(i,j) + enddo ; enddo ; else ; do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + bpa(i,j) = eta(i,j) + enddo ; enddo ; endif + + ! use the scalar approximation and/or iterative tidal SAL + if (CS%use_sal_scalar .or. CS%use_tidal_sal_prev) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta_sal(i,j) = CS%linear_scaling * bpa(i,j) + enddo ; enddo + + ! use the spherical harmonics method + elseif (CS%use_sal_sht) then + call spherical_harmonics_forward(G, CS%sht, bpa, CS%Snm_Re, CS%Snm_Im, CS%sal_sht_Nd, tmp_scale=tmp_scale) + + ! Multiply scaling factors to each mode + do m = 0,CS%sal_sht_Nd + l = order2index(m, CS%sal_sht_Nd) + do n = m,CS%sal_sht_Nd + CS%Snm_Re(l+n-m) = CS%Snm_Re(l+n-m) * CS%Love_scaling(l+n-m) + CS%Snm_Im(l+n-m) = CS%Snm_Im(l+n-m) * CS%Love_scaling(l+n-m) + enddo + enddo + + call spherical_harmonics_inverse(G, CS%sht, CS%Snm_Re, CS%Snm_Im, eta_sal, CS%sal_sht_Nd) + ! Halo was not calculated in spherical harmonic transforms. + call pass_var(eta_sal, G%domain) + + else + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta_sal(i,j) = 0.0 + enddo ; enddo + endif + + call cpu_clock_end(id_clock_SAL) +end subroutine calc_SAL + +!> This subroutine returns eta_prop member of SAL_CS type, which is the non-dimensional partial +!! derivative of the local geopotential height with the input sea surface height due to the scalar +!! approximation of self-attraction and loading. +subroutine scalar_SAL_sensitivity(CS, deta_sal_deta) + type(SAL_CS), intent(in) :: CS !< The control structure returned by a previous call to SAL_init. + real, intent(out) :: deta_sal_deta !< The partial derivative of eta_sal with + !! the local value of eta [nondim]. + deta_sal_deta = CS%eta_prop +end subroutine scalar_SAL_sensitivity + +!> This subroutine calculates coefficients of the spherical harmonic modes for self-attraction and loading. +!! The algorithm is based on the SAL implementation in MPAS-ocean, which was modified by Kristin Barton from +!! routine written by K. Quinn (March 2010) and modified by M. Schindelegger (May 2017). +subroutine calc_love_scaling(rhoW, rhoE, grav, CS) + real, intent(in) :: rhoW !< The average density of sea water [R ~> kg m-3] + real, intent(in) :: rhoE !< The average density of Earth [R ~> kg m-3] + real, intent(in) :: grav !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] + type(SAL_CS), intent(inout) :: CS !< The control structure returned by a previous call to SAL_init. + + ! Local variables + real :: coef_rhoE ! A scaling coefficient of solid Earth density. coef_rhoE = rhoW / rhoE with USE_BPA=False + ! and coef_rhoE = 1.0 / (rhoE * grav) with USE_BPA=True. [nondim] or [Z T2 L-2 R-1 ~> m Pa-1] + real, dimension(:), allocatable :: HDat, LDat, KDat ! Love numbers converted in CF reference frames [nondim] + real :: H1, L1, K1 ! Temporary variables to store degree 1 Love numbers [nondim] + integer :: n_tot ! Size of the stored Love numbers [nondim] + integer :: nlm ! Maximum spherical harmonics degree [nondim] + integer :: n, m, l + + n_tot = size(Love_Data, dim=2) + nlm = CS%sal_sht_Nd + + if (nlm+1 > n_tot) call MOM_error(FATAL, "MOM_tidal_forcing " // & + "calc_love_scaling: maximum spherical harmonics degree is larger than " // & + "the size of the stored Love numbers in MOM_load_love_number.") + + allocate(HDat(nlm+1), LDat(nlm+1), KDat(nlm+1)) + HDat(:) = Love_Data(2,1:nlm+1) ; LDat(:) = Love_Data(3,1:nlm+1) ; KDat(:) = Love_Data(4,1:nlm+1) + + ! Convert reference frames from CM to CF + if (nlm > 0) then + H1 = HDat(2) ; L1 = LDat(2) ; K1 = KDat(2) + HDat(2) = ( 2.0 / 3.0) * (H1 - L1) + LDat(2) = (-1.0 / 3.0) * (H1 - L1) + KDat(2) = (-1.0 / 3.0) * H1 - (2.0 / 3.0) * L1 - 1.0 + endif + + if (CS%use_bpa) then + coef_rhoE = 1.0 / (rhoE * grav) ! [Z T2 L-2 R-1 ~> m Pa-1] + else + coef_rhoE = rhoW / rhoE ! [nondim] + endif + + do m=0,nlm ; do n=m,nlm + l = order2index(m, nlm) + ! Love_scaling has the same as coef_rhoE. + CS%Love_scaling(l+n-m) = (3.0 / real(2*n+1)) * coef_rhoE * (1.0 + KDat(n+1) - HDat(n+1)) + enddo ; enddo +end subroutine calc_love_scaling + +!> This subroutine initializes the self-attraction and loading control structure. +subroutine SAL_init(h, tv, G, GV, US, param_file, CS, restart_CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. + type(SAL_CS), intent(inout) :: CS !< Self-attraction and loading control structure + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(MOM_restart_CS), optional, intent(in) :: restart_CS !< MOM restart control structure + ! Local variables +# include "version_variable.h" + character(len=40) :: mdl = "MOM_self_attr_load" ! This module's name. + integer :: lmax ! Total modes of the real spherical harmonics [nondim] + real :: rhoE ! The average density of Earth [R ~> kg m-3]. + character(len=20) :: bpa_config ! String for reference bottom pressure config option + real :: tmp(G%isd:G%ied, G%jsd:G%jed) ! Temporary field storing mass returned by find_col_mass + ! [R Z ~> kg m-2] + logical :: restart_sim ! If true, this is a restart run + character(len=200) :: filename, ref_pbot_file, inputdir ! Strings for file/path + character(len=200) :: ref_pbot_varname ! Variable name in file + type(MOM_infra_file) :: IO_handle ! used to write ref_pbot file + type(vardesc) :: vars(1) ! used to write ref_pbot file + type(MOM_field) :: fields(1) ! used to write ref_pbot file + logical :: calculate_sal, tides, use_tidal_sal_file + integer :: default_answer_date, tides_answer_date ! Recover old answers with tides + real :: sal_scalar_value ! Scaling SAL factors [nondim] + integer :: isd, ied, jsd, jed + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + + call get_param(param_file, '', "TIDES", tides, default=.false., do_not_log=.True.) + call get_param(param_file, '', "CALCULATE_SAL", calculate_sal, default=tides, do_not_log=.True.) + if (.not. calculate_sal) return + + call get_param(param_file, mdl, "SAL_USE_BPA", CS%use_bpa, & + "If true, use bottom pressure anomaly to calculate self-attraction and "// & + "loading (SAL). Otherwise sea surface height anomaly is used, which is "// & + "only accurate for uniform density fluid.", default=.False.) + if (CS%use_bpa) then + allocate(CS%pbot_ref(isd:ied, jsd:jed), source=0.0) + call get_param(param_file, mdl, "SAL_REF_PBOT_CONFIG", bpa_config, default="file", & + do_not_log=.True.) + restart_sim = .False. ; if (present(restart_CS)) restart_sim = (.not. is_new_run(restart_CS)) + if (restart_sim .and. (trim(lowercase(bpa_config))/='file')) then + call MOM_error(WARNING, "SAL_init: 'file' is not used by SAL_PBOT_REF_CONFIG for a restart "//& + "run, SAL_PBOT_REF_CONFIG is reset to 'file'.") + bpa_config = 'file' + endif + call get_param(param_file, mdl, "SAL_REF_PBOT_CONFIG", bpa_config, & + "A string that determines how the reference bottom pressure for SAL "//& + "is specified:\n"//& + "\t init - calculated by thickness, temperature and salinity from \n"//& + "\t initialization and assuming surface pressure is zero.\n"//& + "\t This option can only be used by new simulations.\n"//& + "\t file - read from the file specified by REF_PBOT_FILE.", & + default="file", do_not_read=.True.) + call get_param(param_file, '', "INPUTDIR", inputdir, default=".", do_not_log=.True.) + call get_param(param_file, mdl, "REF_PBOT_FILE", ref_pbot_file, & + "Reference bottom pressure file used by self-attraction and loading (SAL).", & + default="pbot.nc") + call get_param(param_file, mdl, "REF_PBOT_VARNAME", ref_pbot_varname, & + "The name of the variable in REF_PBOT_FILE with reference bottom "//& + "pressure. The variable should have the unit of Pa.", default="pbot") + filename = trim(slasher(inputdir))//trim(ref_pbot_file) + call log_param(param_file, mdl, "INPUTDIR/REF_PBOT_FILE", filename) + select case (trim(lowercase(bpa_config))) + case ("file") + call MOM_read_data(filename, trim(ref_pbot_varname), CS%pbot_ref, G%Domain,& + scale=US%Pa_to_RL2_T2) + case ("init") + call find_col_mass(h, tv, G, GV, US, tmp, CS%pbot_ref) + ! Write reference bottom pressure file + vars(1) = var_desc(trim(ref_pbot_varname), units="Pa", & + longname="Reference bottom pressure", & + hor_grid='h', z_grid='1', t_grid='1') + call create_MOM_file(IO_handle, trim(filename), vars, 1, fields, G=G) + call MOM_write_field(IO_handle, fields(1), G%Domain, CS%pbot_ref, unscale=US%RL2_T2_to_Pa) + call IO_handle%close() + case default + call MOM_error(FATAL, "SAL_init: Unsupported SAL_PBOT_REF_CONFIG option "//trim(bpa_config)) + end select + call pass_var(CS%pbot_ref, G%Domain) + endif + + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231, do_not_log=.True.) ! used to check SAL_USE_BPA + call get_param(param_file, '', "TIDES_ANSWER_DATE", tides_answer_date, & + default=default_answer_date, do_not_log=.True.) ! used to check SAL_USE_BPA + if (tides_answer_date<=20250131 .and. CS%use_bpa) & + call MOM_error(FATAL, trim(mdl) // ", SAL_init: SAL_USE_BPA needs to be false to recover "//& + "tide answers before 20250131.") + call get_param(param_file, '', "TIDAL_SAL_FROM_FILE", use_tidal_sal_file, default=.false., & + do_not_log=.True.) ! used to set default of SAL_SCALAR_APPROX + call get_param(param_file, mdl, "SAL_SCALAR_APPROX", CS%use_sal_scalar, & + "If true, use the scalar approximation to calculate self-attraction and "//& + "loading.", default=tides .and. (.not. use_tidal_sal_file)) + if (CS%use_sal_scalar .and. CS%use_bpa) & + call MOM_error(WARNING, trim(mdl) // ", SAL_init: Using bottom pressure anomaly for scalar "//& + "approximation SAL is unsubstantiated.") + call get_param(param_file, mdl, "SAL_SCALAR_VALUE", sal_scalar_value, "The constant of "//& + "proportionality between self-attraction and loading (SAL) geopotential "//& + "anomaly and barotropic geopotential anomaly. This is only used if "//& + "SAL_SCALAR_APPROX is true or USE_PREVIOUS_TIDES is true.", default=0.0, & + units="m m-1", do_not_log=.not.(CS%use_sal_scalar .or. CS%use_tidal_sal_prev), & + old_name='TIDE_SAL_SCALAR_VALUE') + call get_param(param_file, '', "USE_PREVIOUS_TIDES", CS%use_tidal_sal_prev, & + default=.false., do_not_log=.True.) + call get_param(param_file, mdl, "SAL_HARMONICS", CS%use_sal_sht, & + "If true, use the online spherical harmonics method to calculate "//& + "self-attraction and loading.", default=.false.) + call get_param(param_file, mdl, "SAL_HARMONICS_DEGREE", CS%sal_sht_Nd, & + "The maximum degree of the spherical harmonics transformation used for "// & + "calculating the self-attraction and loading term.", & + default=0, do_not_log=(.not. CS%use_sal_sht)) + call get_param(param_file, mdl, "RHO_SOLID_EARTH", rhoE, & + "The mean solid earth density. This is used for calculating the "// & + "self-attraction and loading term.", units="kg m-3", & + default=5517.0, scale=US%kg_m3_to_R, do_not_log=(.not. CS%use_sal_sht)) + + ! Set scaling coefficients for scalar approximation + if (CS%use_sal_scalar .or. CS%use_tidal_sal_prev) then + if (CS%use_sal_scalar .and. CS%use_tidal_sal_prev) then + CS%eta_prop = 2.0 * sal_scalar_value + else + CS%eta_prop = sal_scalar_value + endif + if (CS%use_bpa) then + CS%linear_scaling = CS%eta_prop / (GV%Rho0 * GV%g_Earth) + else + CS%linear_scaling = CS%eta_prop + endif + else + CS%eta_prop = 0.0 ; CS%linear_scaling = 0.0 + endif + + ! Set scaling coefficients for spherical harmonics + if (CS%use_sal_sht) then + lmax = calc_lmax(CS%sal_sht_Nd) + allocate(CS%Snm_Re(lmax), source=0.0) + allocate(CS%Snm_Im(lmax), source=0.0) + + allocate(CS%Love_scaling(lmax), source=0.0) + call calc_love_scaling(GV%Rho0, rhoE, GV%g_Earth, CS) + + allocate(CS%sht) + call spherical_harmonics_init(G, param_file, CS%sht) + endif + + id_clock_SAL = cpu_clock_id('(Ocean SAL)', grain=CLOCK_MODULE) + +end subroutine SAL_init + +!> This subroutine deallocates memory associated with the SAL module. +subroutine SAL_end(CS) + type(SAL_CS), intent(inout) :: CS !< The control structure returned by a previous call + !! to SAL_init; it is deallocated here. + + if (allocated(CS%pbot_ref)) deallocate(CS%pbot_ref) + + if (CS%use_sal_sht) then + if (allocated(CS%Love_scaling)) deallocate(CS%Love_scaling) + if (allocated(CS%Snm_Re)) deallocate(CS%Snm_Re) + if (allocated(CS%Snm_Im)) deallocate(CS%Snm_Im) + call spherical_harmonics_end(CS%sht) + deallocate(CS%sht) + endif +end subroutine SAL_end + +!> \namespace self_attr_load +!! +!! \section section_SAL Self attraction and loading +!! +!! This module contains methods to calculate self-attraction and loading (SAL) as a function of sea surface height or +!! bottom pressure anomaly. SAL is primarily used for fast evolving processes like tides or storm surges, but the +!! effect applies to all motions. +!! +!! If SAL_SCALAR_APPROX is true, a scalar approximation is applied (\cite Accad1978) and the SAL is simply +!! a fraction (set by SAL_SCALAR_VALUE, usually around 10% for global tides) of local SSH. For tides, the +!! scalar approximation can also be used to iterate the SAL to convergence [see USE_PREVIOUS_TIDES in +!! MOM_tidal_forcing, \cite Arbic2004]. +!! +!! If SAL_HARMONICS is true, a more accurate online spherical harmonic transforms are used to calculate +!! SAL. Subroutines in module MOM_spherical_harmonics are called and the degree of spherical harmonic transforms is set +!! by SAL_HARMONICS_DEGREE. The algorithm is based on SAL calculation in Model for Prediction Across +!! Scales (MPAS)-Ocean developed by Los Alamos National Laboratory and University of Michigan +!! [\cite Barton2022 and \cite Brus2023]. +!! +!! References: +!! +!! Accad, Y. and Pekeris, C.L., 1978. Solution of the tidal equations for the M2 and S2 tides in the world oceans from a +!! knowledge of the tidal potential alone. Philosophical Transactions of the Royal Society of London. Series A, +!! Mathematical and Physical Sciences, 290(1368), pp.235-266. +!! https://doi.org/10.1098/rsta.1978.0083 +!! +!! Arbic, B.K., Garner, S.T., Hallberg, R.W. and Simmons, H.L., 2004. The accuracy of surface elevations in forward +!! global barotropic and baroclinic tide models. Deep Sea Research Part II: Topical Studies in Oceanography, 51(25-26), +!! pp.3069-3101. +!! https://doi.org/10.1016/j.dsr2.2004.09.014 +!! +!! Barton, K.N., Pal, N., Brus, S.R., Petersen, M.R., Arbic, B.K., Engwirda, D., Roberts, A.F., Westerink, J.J., +!! Wirasaet, D. and Schindelegger, M., 2022. Global Barotropic Tide Modeling Using Inline Self‐Attraction and Loading in +!! MPAS‐Ocean. Journal of Advances in Modeling Earth Systems, 14(11), p.e2022MS003207. +!! https://doi.org/10.1029/2022MS003207 +!! +!! Brus, S.R., Barton, K.N., Pal, N., Roberts, A.F., Engwirda, D., Petersen, M.R., Arbic, B.K., Wirasaet, D., +!! Westerink, J.J. and Schindelegger, M., 2023. Scalable self attraction and loading calculations for unstructured ocean +!! tide models. Ocean Modelling, p.102160. +!! https://doi.org/10.1016/j.ocemod.2023.102160 +end module MOM_self_attr_load diff --git a/src/parameterizations/lateral/MOM_spherical_harmonics.F90 b/src/parameterizations/lateral/MOM_spherical_harmonics.F90 new file mode 100644 index 0000000000..d948583a42 --- /dev/null +++ b/src/parameterizations/lateral/MOM_spherical_harmonics.F90 @@ -0,0 +1,397 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Laplace's spherical harmonic transforms (SHT) +module MOM_spherical_harmonics +use MOM_coms_infra, only : sum_across_PEs +use MOM_coms, only : reproducing_sum +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, & + CLOCK_MODULE, CLOCK_ROUTINE, CLOCK_LOOP +use MOM_error_handler, only : MOM_error, FATAL +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type + +implicit none ; private + +public spherical_harmonics_init, spherical_harmonics_end, order2index, calc_lmax +public spherical_harmonics_forward, spherical_harmonics_inverse + +#include + +!> Control structure for spherical harmonic transforms +type, public :: sht_CS ; private + logical :: initialized = .False. !< True if this control structure has been initialized. + integer :: ndegree !< Maximum degree of the spherical harmonics [nondim]. + integer :: lmax !< Number of associated Legendre polynomials of nonnegative m + !! [lmax=(ndegree+1)*(ndegree+2)/2] [nondim]. + real, allocatable :: cos_clatT(:,:) !< Precomputed cosine of colatitude at the t-cells [nondim]. + real, allocatable :: Pmm(:,:,:) !< Precomputed associated Legendre polynomials (m=n) at the t-cells [nondim]. + real, allocatable :: cos_lonT(:,:,:), & !< Precomputed cosine factors at the t-cells [nondim]. + sin_lonT(:,:,:) !< Precomputed sine factors at the t-cells [nondim]. + real, allocatable :: cos_lonT_wtd(:,:,:), & !< Precomputed area-weighted cosine factors at the t-cells [nondim] + sin_lonT_wtd(:,:,:) !< Precomputed area-weighted sine factors at the t-cells [nondim] + real, allocatable :: a_recur(:,:), & !< Precomputed recurrence coefficients a [nondim]. + b_recur(:,:) !< Precomputed recurrence coefficients b [nondim]. + logical :: reprod_sum !< True if use reproducible global sums +end type sht_CS + +integer :: id_clock_sht=-1 !< CPU clock for SHT [MODULE] +integer :: id_clock_sht_forward=-1 !< CPU clock for forward transforms [ROUTINE] +integer :: id_clock_sht_inverse=-1 !< CPU clock for inverse transforms [ROUTINE] +integer :: id_clock_sht_global_sum=-1 !< CPU clock for global summation in forward transforms [LOOP] + +contains + +!> Calculates forward spherical harmonics transforms +subroutine spherical_harmonics_forward(G, CS, var, Snm_Re, Snm_Im, Nd, tmp_scale) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(sht_CS), intent(inout) :: CS !< Control structure for SHT + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: var !< Input 2-D variable in arbitrary mks units [a] + !! or in arbitrary rescaled units [A ~> a] if + !! tmp_scale is present + real, intent(out) :: Snm_Re(:) !< SHT coefficients for the real modes (cosine) in + !! the same arbitrary units as var [a] or [A ~> a] + real, intent(out) :: Snm_Im(:) !< SHT coefficients for the imaginary modes (sine) in + !! the same arbitrary units as var [a] or [A ~> a] + integer, optional, intent(in) :: Nd !< Maximum degree of the spherical harmonics + !! overriding ndegree in the CS [nondim] + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor to convert + !! var to MKS units during the reproducing + !! sums [a A-1 ~> 1] + ! local variables + integer :: Nmax ! Local copy of the maximum degree of the spherical harmonics + integer :: Ltot ! Local copy of the number of spherical harmonics + real, dimension(SZI_(G),SZJ_(G)) :: & + pmn, & ! Current associated Legendre polynomials of degree n and order m [nondim] + pmnm1, & ! Associated Legendre polynomials of degree n-1 and order m [nondim] + pmnm2 ! Associated Legendre polynomials of degree n-2 and order m [nondim] + real, allocatable, dimension(:,:,:) :: & + Snm_Re_raw, & ! Array of un-summed real spherical harmonics transform coefficients for + ! reproducing sums in the same arbitrary units as var, [a] or [A ~> a] + Snm_Im_raw ! Array of un-summed imaginary spherical harmonics transform coefficients for + ! reproducing sums in the same arbitrary units as var, [a] or [A ~> a] + real :: sum_tot ! The total of all components output by the reproducing sum in the same + ! arbitrary units as var, [a] or [A ~> a] + integer :: i, j, k + integer :: is, ie, js, je, isd, ied, jsd, jed + integer :: m, n, l + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_spherical_harmonics " // & + "spherical_harmonics_forward: Module must be initialized before it is used.") + + if (id_clock_sht>0) call cpu_clock_begin(id_clock_sht) + if (id_clock_sht_forward>0) call cpu_clock_begin(id_clock_sht_forward) + + Nmax = CS%ndegree ; if (present(Nd)) Nmax = Nd + Ltot = calc_lmax(Nmax) + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + do j=jsd,jed ; do i=isd,ied + pmn(i,j) = 0.0 ; pmnm1(i,j) = 0.0 ; pmnm2(i,j) = 0.0 + enddo ; enddo + + do l=1,Ltot ; Snm_Re(l) = 0.0 ; Snm_Im(l) = 0.0 ; enddo + + if (CS%reprod_sum) then + allocate(Snm_Re_raw(is:ie, js:je, Ltot), source=0.0) + allocate(Snm_Im_raw(is:ie, js:je, Ltot), source=0.0) + do m=0,Nmax + l = order2index(m, Nmax) + + do j=js,je ; do i=is,ie + Snm_Re_raw(i,j,l) = var(i,j) * CS%Pmm(i,j,m+1) * CS%cos_lonT_wtd(i,j,m+1) + Snm_Im_raw(i,j,l) = var(i,j) * CS%Pmm(i,j,m+1) * CS%sin_lonT_wtd(i,j,m+1) + pmnm2(i,j) = 0.0 + pmnm1(i,j) = CS%Pmm(i,j,m+1) + enddo ; enddo + + do n = m+1, Nmax ; do j=js,je ; do i=is,ie + pmn(i,j) = & + CS%a_recur(n+1,m+1) * CS%cos_clatT(i,j) * pmnm1(i,j) - CS%b_recur(n+1,m+1) * pmnm2(i,j) + Snm_Re_raw(i,j,l+n-m) = var(i,j) * pmn(i,j) * CS%cos_lonT_wtd(i,j,m+1) + Snm_Im_raw(i,j,l+n-m) = var(i,j) * pmn(i,j) * CS%sin_lonT_wtd(i,j,m+1) + pmnm2(i,j) = pmnm1(i,j) + pmnm1(i,j) = pmn(i,j) + enddo ; enddo ; enddo + enddo + else + do m=0,Nmax + l = order2index(m, Nmax) + + do j=js,je ; do i=is,ie + Snm_Re(l) = Snm_Re(l) + var(i,j) * CS%Pmm(i,j,m+1) * CS%cos_lonT_wtd(i,j,m+1) + Snm_Im(l) = Snm_Im(l) + var(i,j) * CS%Pmm(i,j,m+1) * CS%sin_lonT_wtd(i,j,m+1) + pmnm2(i,j) = 0.0 + pmnm1(i,j) = CS%Pmm(i,j,m+1) + enddo ; enddo + + do n=m+1, Nmax ; do j=js,je ; do i=is,ie + pmn(i,j) = & + CS%a_recur(n+1,m+1) * CS%cos_clatT(i,j) * pmnm1(i,j) - CS%b_recur(n+1,m+1) * pmnm2(i,j) + Snm_Re(l+n-m) = Snm_Re(l+n-m) + var(i,j) * pmn(i,j) * CS%cos_lonT_wtd(i,j,m+1) + Snm_Im(l+n-m) = Snm_Im(l+n-m) + var(i,j) * pmn(i,j) * CS%sin_lonT_wtd(i,j,m+1) + pmnm2(i,j) = pmnm1(i,j) + pmnm1(i,j) = pmn(i,j) + enddo ; enddo ; enddo + enddo + endif + + if (id_clock_sht_global_sum>0) call cpu_clock_begin(id_clock_sht_global_sum) + + if (CS%reprod_sum) then + sum_tot = reproducing_sum(Snm_Re_raw(:,:,1:Ltot), sums=Snm_Re(1:Ltot), unscale=tmp_scale) + sum_tot = reproducing_sum(Snm_Im_raw(:,:,1:Ltot), sums=Snm_Im(1:Ltot), unscale=tmp_scale) + deallocate(Snm_Re_raw, Snm_Im_raw) + else + call sum_across_PEs(Snm_Re, Ltot) + call sum_across_PEs(Snm_Im, Ltot) + endif + + if (id_clock_sht_global_sum>0) call cpu_clock_end(id_clock_sht_global_sum) + if (id_clock_sht_forward>0) call cpu_clock_end(id_clock_sht_forward) + if (id_clock_sht>0) call cpu_clock_end(id_clock_sht) +end subroutine spherical_harmonics_forward + +!> Calculates inverse spherical harmonics transforms +subroutine spherical_harmonics_inverse(G, CS, Snm_Re, Snm_Im, var, Nd) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(sht_CS), intent(in) :: CS !< Control structure for SHT + real, intent(in) :: Snm_Re(:) !< SHT coefficients for the real modes (cosine) + !! in arbitrary units [a] or [A ~> a] + real, intent(in) :: Snm_Im(:) !< SHT coefficients for the imaginary modes (sine) in + !! the same arbitrary units as Snm_Re [a] or [A ~> a] + real, dimension(SZI_(G),SZJ_(G)), & + intent(out) :: var !< Output 2-D variable in the same arbitrary units + !! as Snm_Re and Snm_Im [a] or [A ~> a] + integer, optional, intent(in) :: Nd !< Maximum degree of the spherical harmonics + !! overriding ndegree in the CS [nondim] + ! local variables + integer :: Nmax ! Local copy of the maximum degree of the spherical harmonics [nondim] + real :: mFac ! A constant multiplier. mFac = 1 (if m==0) or 2 (if m>0) [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: & + pmn, & ! Current associated Legendre polynomials of degree n and order m [nondim] + pmnm1, & ! Associated Legendre polynomials of degree n-1 and order m [nondim] + pmnm2 ! Associated Legendre polynomials of degree n-2 and order m [nondim] + integer :: i, j, k + integer :: is, ie, js, je, isd, ied, jsd, jed + integer :: m, n, l + + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_spherical_harmonics " // & + "spherical_harmonics_inverse: Module must be initialized before it is used.") + + if (id_clock_sht>0) call cpu_clock_begin(id_clock_sht) + if (id_clock_sht_inverse>0) call cpu_clock_begin(id_clock_sht_inverse) + + Nmax = CS%ndegree ; if (present(Nd)) Nmax = Nd + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + do j=jsd,jed ; do i=isd,ied + pmn(i,j) = 0.0 ; pmnm1(i,j) = 0.0 ; pmnm2(i,j) = 0.0 + var(i,j) = 0.0 + enddo ; enddo + + do m=0,Nmax + mFac = sign(1.0, m-0.5)*0.5 + 1.5 + l = order2index(m, Nmax) + + do j=js,je ; do i=is,ie + var(i,j) = var(i,j) & + + mFac * CS%Pmm(i,j,m+1) * ( Snm_Re(l) * CS%cos_lonT(i,j,m+1) & + + Snm_Im(l) * CS%sin_lonT(i,j,m+1)) + pmnm2(i,j) = 0.0 + pmnm1(i,j) = CS%Pmm(i,j,m+1) + enddo ; enddo + + do n=m+1,Nmax ; do j=js,je ; do i=is,ie + pmn(i,j) = & + CS%a_recur(n+1,m+1) * CS%cos_clatT(i,j) * pmnm1(i,j) - CS%b_recur(n+1,m+1) * pmnm2(i,j) + var(i,j) = var(i,j) & + + mFac * pmn(i,j) * ( Snm_Re(l+n-m) * CS%cos_lonT(i,j,m+1) & + + Snm_Im(l+n-m) * CS%sin_lonT(i,j,m+1)) + pmnm2(i,j) = pmnm1(i,j) + pmnm1(i,j) = pmn(i,j) + enddo ; enddo ; enddo + enddo + + if (id_clock_sht_inverse>0) call cpu_clock_end(id_clock_sht_inverse) + if (id_clock_sht>0) call cpu_clock_end(id_clock_sht) +end subroutine spherical_harmonics_inverse + +!> Calculate precomputed coefficients +subroutine spherical_harmonics_init(G, param_file, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(param_file_type), intent(in) :: param_file !< A structure indicating + type(sht_CS), intent(inout) :: CS !< Control structure for spherical harmonic transforms + + ! local variables + real, parameter :: PI = 4.0*atan(1.0) ! 3.1415926... calculated as 4*atan(1) [nondim] + real, parameter :: RADIAN = PI / 180.0 ! Degree to Radian constant [radian degree-1] + real, dimension(SZI_(G),SZJ_(G)) :: sin_clatT ! sine of colatitude at the t-cells [nondim]. + real :: Pmm_coef ! = sqrt{ 1.0/(4.0*PI) * prod[(2k+1)/2k)] } [nondim]. + integer :: is, ie, js, je + integer :: i, j, k + integer :: m, n + integer :: Nd_SAL ! Maximum degree for SAL + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MOM_spherical_harmonics" ! This module's name. + + if (CS%initialized) return + CS%initialized = .True. + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "SAL_HARMONICS_DEGREE", Nd_SAL, "", default=0, do_not_log=.true.) + CS%ndegree = Nd_SAL + CS%lmax = calc_lmax(CS%ndegree) + call get_param(param_file, mdl, "SHT_REPRODUCING_SUM", CS%reprod_sum, & + "If true, use reproducing sums (invariant to PE layout) in inverse transform "// & + "of spherical harmonics. Otherwise use a simple sum of floating point numbers. ", & + default=.False.) + + ! Calculate recurrence relationship coefficients + allocate(CS%a_recur(CS%ndegree+1, CS%ndegree+1), source=0.0) + allocate(CS%b_recur(CS%ndegree+1, CS%ndegree+1), source=0.0) + do m=0,CS%ndegree ; do n=m+1,CS%ndegree + ! These expressione will give NaNs with 32-bit integers for n > 23170, but this is trapped elsewhere. + CS%a_recur(n+1,m+1) = sqrt(real((2*n-1) * (2*n+1)) / real((n-m) * (n+m))) + CS%b_recur(n+1,m+1) = sqrt((real(2*n+1) * real((n+m-1) * (n-m-1))) / (real((n-m) * (n+m)) * real(2*n-3))) + enddo ; enddo + + ! Calculate complex exponential factors + allocate(CS%cos_lonT_wtd(is:ie, js:je, CS%ndegree+1), source=0.0) + allocate(CS%sin_lonT_wtd(is:ie, js:je, CS%ndegree+1), source=0.0) + allocate(CS%cos_lonT(is:ie, js:je, CS%ndegree+1), source=0.0) + allocate(CS%sin_lonT(is:ie, js:je, CS%ndegree+1), source=0.0) + do m=0,CS%ndegree + do j=js,je ; do i=is,ie + CS%cos_lonT(i,j,m+1) = cos(real(m) * (G%geolonT(i,j)*RADIAN)) + CS%sin_lonT(i,j,m+1) = sin(real(m) * (G%geolonT(i,j)*RADIAN)) + CS%cos_lonT_wtd(i,j,m+1) = CS%cos_lonT(i,j,m+1) * G%areaT(i,j) / G%Rad_Earth_L**2 + CS%sin_lonT_wtd(i,j,m+1) = CS%sin_lonT(i,j,m+1) * G%areaT(i,j) / G%Rad_Earth_L**2 + enddo ; enddo + enddo + + ! Calculate sine and cosine of colatitude + allocate(CS%cos_clatT(is:ie, js:je), source=0.0) + do j=js,je ; do i=is,ie + CS%cos_clatT(i,j) = cos(0.5*PI - G%geolatT(i,j)*RADIAN) + sin_clatT(i,j) = sin(0.5*PI - G%geolatT(i,j)*RADIAN) + enddo ; enddo + + ! Calculate the diagonal elements of the associated Legendre polynomials (n=m) + allocate(CS%Pmm(is:ie,js:je,m+1), source=0.0) + do m=0,CS%ndegree + Pmm_coef = 1.0/(4.0*PI) + do k=1,m ; Pmm_coef = Pmm_coef * (real(2*k+1) / real(2*k)) ; enddo + Pmm_coef = sqrt(Pmm_coef) + do j=js,je ; do i=is,ie + CS%Pmm(i,j,m+1) = Pmm_coef * (sin_clatT(i,j)**m) + enddo ; enddo + enddo + + id_clock_sht = cpu_clock_id('(Ocean spherical harmonics)', grain=CLOCK_MODULE) + id_clock_sht_forward = cpu_clock_id('(Ocean SHT forward)', grain=CLOCK_ROUTINE) + id_clock_sht_inverse = cpu_clock_id('(Ocean SHT inverse)', grain=CLOCK_ROUTINE) + id_clock_sht_global_sum = cpu_clock_id('(Ocean SHT global sum)', grain=CLOCK_LOOP) + +end subroutine spherical_harmonics_init + +!> Deallocate any variables allocated in spherical_harmonics_init +subroutine spherical_harmonics_end(CS) + type(sht_CS), intent(inout) :: CS !< Control structure for spherical harmonic transforms + + deallocate(CS%cos_clatT) + deallocate(CS%Pmm) + deallocate(CS%cos_lonT_wtd, CS%sin_lonT_wtd, CS%cos_lonT, CS%sin_lonT) + deallocate(CS%a_recur, CS%b_recur) +end subroutine spherical_harmonics_end + +!> Calculates the number of real elements (cosine) of spherical harmonics given maximum degree Nd. +function calc_lmax(Nd) result(lmax) + integer :: lmax !< Number of real spherical harmonic modes [nondim] + integer, intent(in) :: Nd !< Maximum degree [nondim] + + lmax = (Nd+2) * (Nd+1) / 2 +end function calc_lmax + +!> Calculates the one-dimensional index number at (n=0, m=m), given order m and maximum degree Nd. +!! It is sequenced with degree (n) changing first and order (m) changing second. +function order2index(m, Nd) result(l) + integer :: l !< One-dimensional index number [nondim] + integer, intent(in) :: m !< Current order number [nondim] + integer, intent(in) :: Nd !< Maximum degree [nondim] + + l = ((Nd+1) + (Nd+1-(m-1)))*m/2 + 1 +end function order2index + +!> \namespace mom_spherical_harmonics +!! +!! \section section_spherical_harmonics Spherical harmonics +!! +!! This module contains the subroutines to calculate spherical harmonic transforms (SHT), namely, forward transform +!! of a two-dimensional field into a given number of spherical harmonic modes and its inverse transform. This module +!! is primarily used to but not limited to calculate self-attraction and loading (SAL) term, which is mostly relevant to +!! high frequency motions such as tides. Should other needs arise in the future, this API can be easily modified. +!! Currently, the transforms are for t-cell fields only. +!! +!! This module is stemmed from SAL calculation in Model for Prediction Across Scales (MPAS)-Ocean developed by Los +!! Alamos National Laboratory and University of Michigan [\cite Barton2022 and \cite Brus2023]. The algorithm +!! for forward and inverse transforms loosely follows \cite Schaeffer2013. +!! +!! In forward transform, a two-dimensional physical field can be projected into a series of spherical harmonics. The +!! spherical harmonic coefficient of degree n and order m for a field \f$f(\theta, \phi)\f$ is calculated as follows: +!! \f[ +!! f^m_n = \int^{2\pi}_{0}\int^{\pi}_{0}f(\theta,\phi)Y^m_n(\theta,\phi)\sin\theta d\theta d\phi +!! \f] +!! and +!! \f[ +!! Y^m_n(\theta,\phi) = P^m_n(\cos\theta)\exp(im\phi) +!! \f] +!! where \f$P^m_n(\cos \theta)\f$ is the normalized associated Legendre polynomial of degree n and order m. \f$\phi\f$ +!! is the longitude and \f$\theta\f$ is the colatitude. +!! Or, written in the discretized form: +!! \f[ +!! f^m_n = \sum^{Nj}_{0}\sum^{Ni}_{0}f(i,j)Y^m_n(i,j)A(i,j)/r_e^2 +!! \f] +!! where \f$A\f$ is the area of the cell and \f$r_e\f$ is the radius of the Earth. +!! +!! In inverse transform, the first N degree spherical harmonic coefficients are used to reconstruct a two-dimensional +!! physical field: +!! \f[ +!! f(\theta,\phi) = \sum^N_{n=0}\sum^{n}_{m=-n}f^m_nY^m_n(\theta,\phi) +!! \f] +!! +!! The exponential coefficients are pre-computed and stored in the memory. The associated Legendre polynomials are +!! computed "on-the-fly", using the recurrence relationships to avoid large memory usage and take the advantage of +!! array vectorization. +!! +!! The maximum degree of the spherical harmonics is a runtime parameter and the maximum used by all SHT applications. +!! At the moment, it is only decided by SAL_HARMONICS_DEGREE. +!! +!! The forward transforms involve a global summation. Runtime flag SHT_REPRODUCING_SUM controls +!! whether this is done in a bit-wise reproducing way or not. +!! +!! References: +!! +!! Barton, K.N., Pal, N., Brus, S.R., Petersen, M.R., Arbic, B.K., Engwirda, D., Roberts, A.F., Westerink, J.J., +!! Wirasaet, D. and Schindelegger, M., 2022. Global Barotropic Tide Modeling Using Inline Self‐Attraction and Loading in +!! MPAS‐Ocean. Journal of Advances in Modeling Earth Systems, 14(11), p.e2022MS003207. +!! https://doi.org/10.1029/2022MS003207 +!! +!! Brus, S.R., Barton, K.N., Pal, N., Roberts, A.F., Engwirda, D., Petersen, M.R., Arbic, B.K., Wirasaet, D., +!! Westerink, J.J. and Schindelegger, M., 2023. Scalable self attraction and loading calculations for unstructured ocean +!! tide models. Ocean Modelling, p.102160. +!! https://doi.org/10.1016/j.ocemod.2023.102160 +!! +!! Schaeffer, N., 2013. Efficient spherical harmonic transforms aimed at pseudospectral numerical simulations. +!! Geochemistry, Geophysics, Geosystems, 14(3), pp.751-758. +!! https://doi.org/10.1002/ggge.20071 +end module MOM_spherical_harmonics diff --git a/src/parameterizations/lateral/MOM_streaming_filter.F90 b/src/parameterizations/lateral/MOM_streaming_filter.F90 new file mode 100644 index 0000000000..701d0848a0 --- /dev/null +++ b/src/parameterizations/lateral/MOM_streaming_filter.F90 @@ -0,0 +1,213 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Streaming band-pass filter for detecting the instantaneous tidal signals in the simulation + +module MOM_streaming_filter + +use MOM_error_handler, only : MOM_mesg, MOM_error, NOTE, FATAL +use MOM_file_parser, only : get_param, param_file_type +use MOM_hor_index, only : hor_index_type +use MOM_io, only : axis_info, set_axis_info +use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS +use MOM_tidal_forcing, only : tidal_frequency +use MOM_time_manager, only : time_type, time_to_real +use MOM_unit_scaling, only : unit_scale_type + +implicit none ; private + +public Filt_register, Filt_init, Filt_accum + +#include + +!> Control structure for the MOM_streaming_filter module +type, public :: Filter_CS ; private + integer :: nf !< Number of filters to be used in the simulation + !>@{ Lower and upper bounds of input data + integer :: is, ie, js, je + !>@} + character(len=8) :: key !< Identifier of the variable to be filtered + character(len=2), allocatable, dimension(:) :: filter_names !< Names of filters + real, allocatable, dimension(:) :: filter_omega !< Target frequencies of filters [rad T-1 ~> rad s-1] + real, allocatable, dimension(:) :: filter_alpha !< Bandwidth parameters of filters [nondim] + real, allocatable, dimension(:,:,:) :: s1, & !< A dummy variable for solving the system of ODEs [A] + u1 !< Filtered data, representing the narrow-band signal + !< oscillating around the target frequency [A] + real :: old_time = -1.0 !< The time of the previous accumulating step [T ~> s] +end type Filter_CS + +contains + +!> This subroutine registers the filter variables given the number of filters and the grid +subroutine Filt_register(nf, key, grid, HI, CS, restart_CS) + integer, intent(in) :: nf !< Number of filters to be used in the simulation + character(len=*), intent(in) :: key !< Identifier of the variable to be filtered + character(len=*), intent(in) :: grid !< Horizontal grid location: "h", "u", or "v" + type(hor_index_type), intent(in) :: HI !< Horizontal index type structure + type(Filter_CS), intent(out) :: CS !< Control structure of MOM_streaming_filter + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure + + ! Local variables + type(axis_info) :: filter_axis(1) + real, dimension(:), allocatable :: n_filters !< Labels of filters [nondim] + integer :: c + + CS%nf = nf + CS%key = key + + select case (trim(grid)) + case ('h') + CS%is = HI%isd ; CS%ie = HI%ied ; CS%js = HI%jsd ; CS%je = HI%jed + case ('u') + CS%is = HI%IsdB ; CS%ie = HI%IedB ; CS%js = HI%jsd ; CS%je = HI%jed + case ('v') + CS%is = HI%isd ; CS%ie = HI%ied ; CS%js = HI%JsdB ; CS%je = HI%JedB + case default + call MOM_error(FATAL, "MOM_streaming_filter: horizontal grid not supported") + end select + + allocate(CS%s1(CS%is:CS%ie, CS%js:CS%je, nf), source=0.0) + allocate(CS%u1(CS%is:CS%ie, CS%js:CS%je, nf), source=0.0) + + ! Register restarts for s1 and u1 + allocate(n_filters(nf)) + + do c=1,nf ; n_filters(c) = c ; enddo + + call set_axis_info(filter_axis(1), "n_filters", "", "number of filters", nf, n_filters, "N", 1) + + call register_restart_field(CS%s1(:,:,:), "Filter_"//trim(key)//"_s1", .false., restart_CS, & + longname="Dummy variable for streaming band-pass filter", & + hor_grid=trim(grid), z_grid="1", t_grid="s", extra_axes=filter_axis) + call register_restart_field(CS%u1(:,:,:), "Filter_"//trim(key)//"_u1", .false., restart_CS, & + longname="Output of streaming band-pass filter", & + hor_grid=trim(grid), z_grid="1", t_grid="s", extra_axes=filter_axis) + +end subroutine Filt_register + +!> This subroutine initializes the filters +subroutine Filt_init(param_file, US, CS, restart_CS) + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(Filter_CS), intent(inout) :: CS !< Control structure of MOM_streaming_filter + type(MOM_restart_CS), intent(in) :: restart_CS !< MOM restart control structure + + ! Local variables + character(len=40) :: mdl = "MOM_streaming_filter" !< This module's name + character(len=50) :: filter_name_str !< List of filters to be registered + character(len=200) :: mesg + integer :: c + + call get_param(param_file, mdl, "FILTER_NAMES", filter_name_str, & + "Names of streaming band-pass filters to be used in the simulation.", & + fail_if_missing=.true.) + allocate(CS%filter_names(CS%nf)) + allocate(CS%filter_omega(CS%nf)) + allocate(CS%filter_alpha(CS%nf)) + read(filter_name_str, *) CS%filter_names + + do c=1,CS%nf + ! If filter_name_str consists of tidal constituents, use tidal frequencies. + call get_param(param_file, mdl, "FILTER_"//trim(CS%filter_names(c))//"_OMEGA", & + CS%filter_omega(c), "Target frequency of the "//trim(CS%filter_names(c))//& + " filter. This is used if USE_FILTER is true and "//trim(CS%filter_names(c))//& + " is in FILTER_NAMES.", units="rad s-1", scale=US%T_to_s, default=0.0) + call get_param(param_file, mdl, "FILTER_"//trim(CS%filter_names(c))//"_ALPHA", & + CS%filter_alpha(c), "Bandwidth parameter of the "//trim(CS%filter_names(c))//& + " filter. Must be positive.", units="nondim", fail_if_missing=.true.) + + if (CS%filter_omega(c)<=0.0) CS%filter_omega(c) = tidal_frequency(trim(CS%filter_names(c))) + if (CS%filter_alpha(c)<=0.0) call MOM_error(FATAL, "MOM_streaming_filter: bandwidth <= 0") + + write(mesg,*) "MOM_streaming_filter: ", trim(CS%filter_names(c)), & + " filter registered, target frequency = ", CS%filter_omega(c), & + ", bandwidth = ", CS%filter_alpha(c) + call MOM_error(NOTE, trim(mesg)) + enddo + + if (query_initialized(CS%s1, "Filter_"//trim(CS%key)//"_s1", restart_CS)) then + write(mesg,*) "MOM_streaming_filter: Dummy variable for filter ", trim(CS%key), & + " found in restart files." + else + write(mesg,*) "MOM_streaming_filter: Dummy variable for filter ", trim(CS%key), & + " not found in restart files. The filter will spin up from zeros." + endif + call MOM_error(NOTE, trim(mesg)) + + if (query_initialized(CS%u1, "Filter_"//trim(CS%key)//"_u1", restart_CS)) then + write(mesg,*) "MOM_streaming_filter: Output of filter ", trim(CS%key), & + " found in restart files." + else + write(mesg,*) "MOM_streaming_filter: Output of filter ", trim(CS%key), & + " not found in restart files. The filter will spin up from zeros." + endif + call MOM_error(NOTE, trim(mesg)) + +end subroutine Filt_init + +!> This subroutine timesteps the filter equations. Here, u is the broadband input signal from the model, +!! and u1 is the filtered, narrowband output signal, obtained from the solution of the filter equations. +subroutine Filt_accum(u, u1, Time, US, CS) + real, dimension(:,:,:), pointer, intent(out) :: u1 !< Output of the filter [A] + type(time_type), intent(in) :: Time !< The current model time + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(Filter_CS), target, intent(inout) :: CS !< Control structure of MOM_streaming_filter + real, dimension(CS%is:CS%ie,CS%js:CS%je), intent(in) :: u !< Input into the filter [A] + + ! Local variables + real :: now, & !< The current model time [T ~> s] + dt, & !< Time step size for the filter equations [T ~> s] + c1, c2 !< Coefficients for the filter equations [nondim] + integer :: i, j, k + + now = time_to_real(Time, scale=US%s_to_T) + + ! Initialize CS%old_time at the first time step + if (CS%old_time<0.0) CS%old_time = now + + ! Timestep the filter equations only if we are in a new time step + if (CS%old_time CS%u1 + +end subroutine Filt_accum + +!> \namespace mom_streaming_filter +!! +!! By Chengzhu Xu (chengzhu.xu@oregonstate.edu) and Edward D. Zaron +!! +!! The algorithm detects the instantaneous, narrowband tidal signals (u1) from the broadband +!! model output (u) by solving a set of coupled ODEs (the filter equations) at each time step. +!! In the filter equations, u1 is approximately the part of the signal that oscillates at the +!! filter's target frequency, and s1 is approximately the imaginary complement in time of u1. +!! +!! Major revision on Dec 9, 2024: The filters are no longer hard-coded. Instead, multiple filters +!! with tidal frequencies or arbitrary frequencies as their target frequencies can be turned on. +!! The filter names are specified in MOM_input and must consist of two letters/numbers. If the +!! name of a filter is the same as the name of a tidal constituent, then the corresponding tidal +!! frequency will be used as its target frequency. Otherwise, the user must specify the target +!! frequency. In either case, the target frequency is specified by "FILTER_${FILTER_NAME}_OMEGA". +!! +!! The restarting capability has also been implemented. Because the filtering is a point-wise +!! operation, all variables are considered as fields, even if they are velocity components. +!! +!! Xu, C., & Zaron, E. D. (2024). Detecting instantaneous tidal signals in ocean models utilizing +!! streaming band-pass filters. Journal of Advances in Modeling Earth Systems, 16, e2024MS004319. +!! https://doi.org/10.1029/2024MS004319 + +end module MOM_streaming_filter + diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 8303d30621..3c60f2a83a 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -1,7 +1,9 @@ -!> Thickness diffusion (or Gent McWilliams) -module MOM_thickness_diffuse +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 -! This file is part of MOM6. See LICENSE.md for the license. +!> Isopycnal height diffusion (or Gent McWilliams diffusion) +module MOM_thickness_diffuse use MOM_debugging, only : hchksum, uvchksum use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl @@ -13,10 +15,12 @@ module MOM_thickness_diffuse use MOM_EOS, only : calculate_density_second_derivs use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_interface_heights, only : find_eta +use MOM_io, only : MOM_read_data, slasher +use MOM_interface_heights, only : find_eta, thickness_to_dz use MOM_isopycnal_slopes, only : vert_fill_TS use MOM_lateral_mixing_coeffs, only : VarMix_CS use MOM_MEKE_types, only : MEKE_type +use MOM_stochastics, only : stochastic_CS use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, cont_diag_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -25,7 +29,6 @@ module MOM_thickness_diffuse #include public thickness_diffuse, thickness_diffuse_init, thickness_diffuse_end -! public vert_fill_TS public thickness_diffuse_get_KH ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional @@ -33,18 +36,24 @@ module MOM_thickness_diffuse ! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units ! vary with the Boussinesq approximation, the Boussinesq variant is given first. -!> Control structure for thickness diffusion +!> Control structure for thickness_diffuse type, public :: thickness_diffuse_CS ; private logical :: initialized = .false. !< True if this control structure has been initialized. - real :: Khth !< Background interface depth diffusivity [L2 T-1 ~> m2 s-1] + real :: Khth !< Background isopycnal depth diffusivity [L2 T-1 ~> m2 s-1] real :: Khth_Slope_Cff !< Slope dependence coefficient of Khth [nondim] - real :: max_Khth_CFL !< Maximum value of the diffusive CFL for thickness diffusion + real :: max_Khth_CFL !< Maximum value of the diffusive CFL for isopycnal height diffusion [nondim] real :: Khth_Min !< Minimum value of Khth [L2 T-1 ~> m2 s-1] real :: Khth_Max !< Maximum value of Khth [L2 T-1 ~> m2 s-1], or 0 for no max - real :: slope_max !< Slopes steeper than slope_max are limited in some way [Z L-1 ~> nondim]. - real :: kappa_smooth !< Vertical diffusivity used to interpolate more - !! sensible values of T & S into thin layers [Z2 T-1 ~> m2 s-1]. + real :: Kh_eta_bg !< Background isopycnal height diffusivity [L2 T-1 ~> m2 s-1] + real :: Kh_eta_vel !< Velocity scale that is multiplied by the grid spacing to give + !! the isopycnal height diffusivity [L T-1 ~> m s-1] + real :: slope_max !< Slopes steeper than slope_max are limited in some way [Z L-1 ~> nondim] + real :: kappa_smooth !< Vertical diffusivity used to interpolate more sensible values + !! of T & S into thin layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] logical :: thickness_diffuse !< If true, interfaces heights are diffused. + logical :: full_depth_khth_min !< If true, KHTH_MIN is enforced throughout the whole water column. + !! Otherwise, KHTH_MIN is only enforced at the surface. This parameter + !! is only available when KHTH_USE_EBT_STRUCT=True and KHTH_MIN>0. logical :: use_FGNV_streamfn !< If true, use the streamfunction formulation of !! Ferrari et al., 2010, which effectively emphasizes !! graver vertical modes by smoothing in the vertical. @@ -52,8 +61,9 @@ module MOM_thickness_diffuse !! Ferrari et al., 2010, streamfunction formulation [nondim]. real :: FGNV_c_min !< A minimum wave speed used in the Ferrari et al., 2010, !! streamfunction formulation [L T-1 ~> m s-1]. - real :: N2_floor !< A floor for Brunt-Vasaila frequency in the Ferrari et al., 2010, - !! streamfunction formulation [T-2 ~> s-2]. + real :: N2_floor !< A floor for squared buoyancy frequency in the Ferrari et al., 2010, + !! streamfunction formulation divided by aspect ratio rescaling factors + !! [L2 Z-2 T-2 ~> s-2]. logical :: detangle_interfaces !< If true, add 3-d structured interface height !! diffusivities to horizontally smooth jagged layers. real :: detangle_time !< If detangle_interfaces is true, this is the @@ -67,28 +77,46 @@ module MOM_thickness_diffuse logical :: MEKE_GEOMETRIC !< If true, uses the GM coefficient formulation from the GEOMETRIC !! framework (Marshall et al., 2012) real :: MEKE_GEOMETRIC_alpha!< The nondimensional coefficient governing the efficiency of - !! the GEOMETRIC thickness difussion [nondim] + !! the GEOMETRIC isopycnal height diffusion [nondim] real :: MEKE_GEOMETRIC_epsilon !< Minimum Eady growth rate for the GEOMETRIC thickness !! diffusivity [T-1 ~> s-1]. - logical :: MEKE_GEOM_answers_2018 !< If true, use expressions in the MEKE_GEOMETRIC calculation - !! that recover the answers from the original implementation. - !! Otherwise, use expressions that satisfy rotational symmetry. - logical :: Use_KH_in_MEKE !< If true, uses the thickness diffusivity calculated here to diffuse MEKE. + integer :: MEKE_GEOM_answer_date !< The vintage of the expressions in the MEKE_GEOMETRIC + !! calculation. Values below 20190101 recover the answers from the + !! original implementation, while higher values use expressions that + !! satisfy rotational symmetry. + logical :: Use_KH_in_MEKE !< If true, uses the isopycnal height diffusivity calculated here to diffuse MEKE. + real :: MEKE_min_depth_diff !< The minimum total depth over which to average the diffusivity + !! used for MEKE [H ~> m or kg m-2]. When the total depth is less + !! than this, the diffusivity is scaled away. logical :: GM_src_alt !< If true, use the GM energy conversion form S^2*N^2*kappa rather - !! than the streamfunction for the GM source term. + !! than the streamfunction for the GM source term for MEKE. + integer :: MEKE_src_answer_date !< The vintage of the expressions in the GM energy conversion + !! calculation when MEKE_GM_SRC_ALT is true. Values below 20240601 + !! recover the answers from the original implementation, while higher + !! values use expressions that satisfy rotational symmetry. + logical :: MEKE_src_slope_bug !< If true, use a bug that limits the positive values, but not the + !! negative values, of the slopes used when MEKE_GM_SRC_ALT is true. + !! When this is true, it breaks rotational symmetry. logical :: use_GM_work_bug !< If true, use the incorrect sign for the !! top-level work tendency on the top layer. real :: Stanley_det_coeff !< The coefficient correlating SGS temperature variance with the mean !! temperature gradient in the deterministic part of the Stanley parameterization. - !! Negative values disable the scheme." [nondim] + !! Negative values disable the scheme. [nondim] + logical :: read_khth !< If true, read a file containing the spatially varying horizontal + !! isopycnal height diffusivity + logical :: use_stanley_gm !< If true, also use the Stanley parameterization in MOM_thickness_diffuse type(diag_ctrl), pointer :: diag => NULL() !< structure used to regulate timing of diagnostics - real, allocatable :: GMwork(:,:) !< Work by thickness diffusivity [R Z L2 T-3 ~> W m-2] + real, allocatable :: GMwork(:,:) !< Work by isopycnal height diffusion [R Z L2 T-3 ~> W m-2] real, allocatable :: diagSlopeX(:,:,:) !< Diagnostic: zonal neutral slope [Z L-1 ~> nondim] real, allocatable :: diagSlopeY(:,:,:) !< Diagnostic: zonal neutral slope [Z L-1 ~> nondim] - real, allocatable :: KH_u_GME(:,:,:) !< interface height diffusivities in u-columns [L2 T-1 ~> m2 s-1] - real, allocatable :: KH_v_GME(:,:,:) !< interface height diffusivities in v-columns [L2 T-1 ~> m2 s-1] + real, allocatable :: Kh_eta_u(:,:) !< Isopycnal height diffusivities at u points [L2 T-1 ~> m2 s-1] + real, allocatable :: Kh_eta_v(:,:) !< Isopycnal height diffusivities in v points [L2 T-1 ~> m2 s-1] + + real, allocatable :: KH_u_GME(:,:,:) !< Isopycnal height diffusivities in u-columns [L2 T-1 ~> m2 s-1] + real, allocatable :: KH_v_GME(:,:,:) !< Isopycnal height diffusivities in v-columns [L2 T-1 ~> m2 s-1] + real, allocatable :: khth2d(:,:) !< 2D isopycnal height diffusivity at h-points [L2 T-1 ~> m2 s-1] !>@{ !! Diagnostic identifier @@ -102,10 +130,10 @@ module MOM_thickness_diffuse contains -!> Calculates thickness diffusion coefficients and applies thickness diffusion to layer -!! thicknesses, h. Diffusivities are limited to ensure stability. +!> Calculates isopycnal height diffusion coefficients and applies isopycnal height diffusion +!! by modifying to the layer thicknesses, h. Diffusivities are limited to ensure stability. !! Also returns along-layer mass fluxes used in the continuity equation. -subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp, CS) +subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp, CS, STOCH) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -119,53 +147,56 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp type(MEKE_type), intent(inout) :: MEKE !< MEKE fields type(VarMix_CS), target, intent(in) :: VarMix !< Variable mixing coefficients type(cont_diag_ptrs), intent(inout) :: CDp !< Diagnostics for the continuity equation - type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness diffusion + type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness_diffuse + type(stochastic_CS), intent(inout) :: STOCH !< Stochastic control structure ! Local variables - real :: e(SZI_(G), SZJ_(G),SZK_(GV)+1) ! heights of interfaces, relative to mean + real :: e(SZI_(G),SZJ_(G),SZK_(GV)+1) ! heights of interfaces, relative to mean ! sea level [Z ~> m], positive up. - real :: uhD(SZIB_(G), SZJ_(G),SZK_(GV)) ! Diffusive u*h fluxes [L2 H T-1 ~> m3 s-1 or kg s-1] - real :: vhD(SZI_(G), SZJB_(G),SZK_(GV)) ! Diffusive v*h fluxes [L2 H T-1 ~> m3 s-1 or kg s-1] + real :: uhD(SZIB_(G),SZJ_(G),SZK_(GV)) ! Diffusive u*h fluxes [L2 H T-1 ~> m3 s-1 or kg s-1] + real :: vhD(SZI_(G),SZJB_(G),SZK_(GV)) ! Diffusive v*h fluxes [L2 H T-1 ~> m3 s-1 or kg s-1] - real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: & - KH_u, & ! interface height diffusivities in u-columns [L2 T-1 ~> m2 s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & + KH_u, & ! Isopycnal height diffusivities in u-columns [L2 T-1 ~> m2 s-1] int_slope_u ! A nondimensional ratio from 0 to 1 that gives the relative ! weighting of the interface slopes to that calculated also ! using density gradients at u points. The physically correct ! slopes occur at 0, while 1 is used for numerical closures [nondim]. - real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: & - KH_v, & ! interface height diffusivities in v-columns [L2 T-1 ~> m2 s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & + KH_v, & ! Isopycnal height diffusivities in v-columns [L2 T-1 ~> m2 s-1] int_slope_v ! A nondimensional ratio from 0 to 1 that gives the relative ! weighting of the interface slopes to that calculated also ! using density gradients at v points. The physically correct ! slopes occur at 0, while 1 is used for numerical closures [nondim]. - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & KH_t ! diagnosed diffusivity at tracer points [L2 T-1 ~> m2 s-1] - real, dimension(SZIB_(G), SZJ_(G)) :: & - KH_u_CFL ! The maximum stable interface height diffusivity at u grid points [L2 T-1 ~> m2 s-1] - real, dimension(SZI_(G), SZJB_(G)) :: & - KH_v_CFL ! The maximum stable interface height diffusivity at v grid points [L2 T-1 ~> m2 s-1] - real, dimension(SZI_(G), SZJ_(G)) :: & + real, dimension(SZIB_(G),SZJ_(G)) :: & + KH_u_CFL ! The maximum stable isopycnal height diffusivity at u grid points [L2 T-1 ~> m2 s-1] + real, dimension(SZI_(G),SZJB_(G)) :: & + KH_v_CFL ! The maximum stable isopycnal height diffusivity at v grid points [L2 T-1 ~> m2 s-1] + real, dimension(SZI_(G),SZJ_(G)) :: & htot ! The sum of the total layer thicknesses [H ~> m or kg m-2] - real :: Khth_Loc_u(SZIB_(G), SZJ_(G)) - real :: Khth_Loc_v(SZI_(G), SZJB_(G)) - real :: Khth_Loc(SZIB_(G), SZJB_(G)) ! locally calculated thickness diffusivity [L2 T-1 ~> m2 s-1] + real :: Khth_Loc_u(SZIB_(G),SZJ_(G)) ! The isopycnal height diffusivity at u points [L2 T-1 ~> m2 s-1] + real :: Khth_Loc_v(SZI_(G),SZJB_(G)) ! The isopycnal height diffusivity at v points [L2 T-1 ~> m2 s-1] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real, dimension(:,:), pointer :: cg1 => null() !< Wave speed [L T-1 ~> m s-1] - logical :: use_VarMix, Resoln_scaled, Depth_scaled, use_stored_slopes, khth_use_ebt_struct, use_Visbeck + real :: hu(SZI_(G),SZJ_(G)) ! A thickness-based mask at u points, used for diagnostics [nondim] + real :: hv(SZI_(G),SZJ_(G)) ! A thickness-based mask at v points, used for diagnostics [nondim] + real :: KH_u_lay(SZI_(G),SZJ_(G)) ! Diagnostic of isopycnal height diffusivities at u-points averaged + ! 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_vert_struct, use_Visbeck logical :: use_QG_Leith integer :: i, j, k, is, ie, js, je, nz - real :: hu(SZI_(G), SZJ_(G)) ! u-thickness [H ~> m or kg m-2] - real :: hv(SZI_(G), SZJ_(G)) ! v-thickness [H ~> m or kg m-2] - real :: KH_u_lay(SZI_(G), SZJ_(G)) ! layer ave thickness diffusivities [L2 T-1 ~> m2 s-1] - real :: KH_v_lay(SZI_(G), SZJ_(G)) ! layer ave thickness diffusivities [L2 T-1 ~> m2 s-1] if (.not. CS%initialized) call MOM_error(FATAL, "MOM_thickness_diffuse: "//& "Module must be initialized before it is used.") if ((.not.CS%thickness_diffuse) & - .or. .not. (CS%Khth > 0.0 .or. VarMix%use_variable_mixing)) return + .or. .not. (CS%Khth > 0.0 .or. CS%read_khth & + .or. VarMix%use_variable_mixing)) return is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke h_neglect = GV%H_subroundoff @@ -175,7 +206,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 @@ -183,7 +214,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 @@ -192,34 +223,37 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif -!$OMP parallel do default(none) shared(is,ie,js,je,KH_u_CFL,dt,G,CS) + !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie KH_u_CFL(I,j) = (0.25*CS%max_Khth_CFL) / & - (dt * (G%IdxCu(I,j)*G%IdxCu(I,j) + G%IdyCu(I,j)*G%IdyCu(I,j))) + (dt * ((G%IdxCu(I,j)*G%IdxCu(I,j)) + (G%IdyCu(I,j)*G%IdyCu(I,j)))) enddo ; enddo -!$OMP parallel do default(none) shared(is,ie,js,je,KH_v_CFL,dt,G,CS) - do j=js-1,je ; do I=is,ie + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie KH_v_CFL(i,J) = (0.25*CS%max_Khth_CFL) / & - (dt * (G%IdxCv(i,J)*G%IdxCv(i,J) + G%IdyCv(i,J)*G%IdyCv(i,J))) + (dt * ((G%IdxCv(i,J)*G%IdxCv(i,J)) + (G%IdyCv(i,J)*G%IdyCv(i,J)))) enddo ; enddo ! Calculates interface heights, e, in [Z ~> m]. call find_eta(h, tv, G, GV, US, e, halo_size=1) ! Set the diffusivities. -!$OMP parallel default(none) shared(is,ie,js,je,Khth_Loc_u,CS,use_VarMix,VarMix, & -!$OMP MEKE,Resoln_scaled,KH_u,G,use_QG_Leith,use_Visbeck,& -!$OMP KH_u_CFL,nz,Khth_Loc,KH_v,KH_v_CFL,int_slope_u, & -!$OMP int_slope_v,khth_use_ebt_struct, Depth_scaled, & -!$OMP Khth_loc_v) -!$OMP do - do j=js,je ; do I=is-1,ie - Khth_loc_u(I,j) = CS%Khth - enddo ; enddo + !$OMP parallel default(shared) + if (.not. CS%read_khth) then + !$OMP do + do j=js,je ; do I=is-1,ie + Khth_loc_u(I,j) = CS%Khth + enddo ; enddo + else ! use 2d KHTH that was read in from file + !$OMP do + do j=js,je ; do I=is-1,ie + Khth_loc_u(I,j) = 0.5 * (CS%khth2d(i,j) + CS%khth2d(i+1,j)) + enddo ; enddo + endif if (use_VarMix) then if (use_Visbeck) then -!$OMP do + !$OMP do do j=js,je ; do I=is-1,ie Khth_loc_u(I,j) = Khth_loc_u(I,j) + & CS%KHTH_Slope_Cff*VarMix%L2u(I,j) * VarMix%SN_u(I,j) @@ -229,9 +263,9 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (allocated(MEKE%Kh)) then if (CS%MEKE_GEOMETRIC) then -!$OMP do + !$OMP do do j=js,je ; do I=is-1,ie - Khth_loc_u(I,j) = Khth_loc_u(I,j) + G%mask2dCu(I,j) * CS%MEKE_GEOMETRIC_alpha * & + Khth_loc_u(I,j) = Khth_loc_u(I,j) + G%OBCmaskCu(I,j) * CS%MEKE_GEOMETRIC_alpha * & 0.5*(MEKE%MEKE(i,j)+MEKE%MEKE(i+1,j)) / & (VarMix%SN_u(I,j) + CS%MEKE_GEOMETRIC_epsilon) enddo ; enddo @@ -243,42 +277,50 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif if (Resoln_scaled) then -!$OMP do + !$OMP do do j=js,je ; do I=is-1,ie Khth_loc_u(I,j) = Khth_loc_u(I,j) * VarMix%Res_fn_u(I,j) enddo ; enddo endif if (Depth_scaled) then -!$OMP do + !$OMP do do j=js,je ; do I=is-1,ie Khth_loc_u(I,j) = Khth_loc_u(I,j) * VarMix%Depth_fn_u(I,j) enddo ; enddo endif if (CS%Khth_Max > 0) then -!$OMP do + !$OMP do do j=js,je ; do I=is-1,ie Khth_loc_u(I,j) = max(CS%Khth_Min, min(Khth_loc_u(I,j), CS%Khth_Max)) enddo ; enddo else -!$OMP do + !$OMP do do j=js,je ; do I=is-1,ie Khth_loc_u(I,j) = max(CS%Khth_Min, Khth_loc_u(I,j)) enddo ; enddo endif -!$OMP do + !$OMP do do j=js,je ; do I=is-1,ie KH_u(I,j,1) = min(KH_u_CFL(I,j), Khth_loc_u(I,j)) enddo ; enddo - if (khth_use_ebt_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) ) - enddo ; enddo ; enddo + if (khth_use_vert_struct) then + if (CS%full_depth_khth_min) 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%khth_struct(i,j,k-1) + VarMix%khth_struct(i+1,j,k-1) ) + KH_u(I,j,K) = max(KH_u(I,j,K), CS%Khth_Min) + enddo ; enddo ; enddo + else + !$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%khth_struct(i,j,k-1) + VarMix%khth_struct(i+1,j,k-1) ) + enddo ; enddo ; enddo + endif else -!$OMP do + !$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) enddo ; enddo ; enddo @@ -286,7 +328,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (use_VarMix) then if (use_QG_Leith) then -!$OMP do + !$OMP do do k=1,nz ; do j=js,je ; do I=is-1,ie KH_u(I,j,k) = VarMix%KH_u_QG(I,j,k) enddo ; enddo ; enddo @@ -294,20 +336,27 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif if (CS%use_GME_thickness_diffuse) then -!$OMP do + !$OMP do do k=1,nz+1 ; do j=js,je ; do I=is-1,ie CS%KH_u_GME(I,j,k) = KH_u(I,j,k) enddo ; enddo ; enddo endif -!$OMP do - do J=js-1,je ; do i=is,ie - Khth_loc_v(i,J) = CS%Khth - enddo ; enddo + if (.not. CS%read_khth) then + !$OMP do + do J=js-1,je ; do i=is,ie + Khth_loc_v(i,J) = CS%Khth + enddo ; enddo + else ! read KHTH from file + !$OMP do + do J=js-1,je ; do i=is,ie + Khth_loc_v(i,J) = 0.5 * (CS%khth2d(i,j) + CS%khth2d(i,j+1)) + enddo ; enddo + endif if (use_VarMix) then if (use_Visbeck) then -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie Khth_loc_v(i,J) = Khth_loc_v(i,J) + CS%KHTH_Slope_Cff*VarMix%L2v(i,J)*VarMix%SN_v(i,J) enddo ; enddo @@ -315,9 +364,9 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif if (allocated(MEKE%Kh)) then if (CS%MEKE_GEOMETRIC) then -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie - Khth_loc_v(i,J) = Khth_loc_v(i,J) + G%mask2dCv(i,J) * CS%MEKE_GEOMETRIC_alpha * & + Khth_loc_v(i,J) = Khth_loc_v(i,J) + G%OBCmaskCv(i,J) * CS%MEKE_GEOMETRIC_alpha * & 0.5*(MEKE%MEKE(i,j)+MEKE%MEKE(i,j+1)) / & (VarMix%SN_v(i,J) + CS%MEKE_GEOMETRIC_epsilon) enddo ; enddo @@ -329,45 +378,53 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif if (Resoln_scaled) then -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie Khth_loc_v(i,J) = Khth_loc_v(i,J) * VarMix%Res_fn_v(i,J) enddo ; enddo endif if (Depth_scaled) then -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie Khth_loc_v(i,J) = Khth_loc_v(i,J) * VarMix%Depth_fn_v(i,J) enddo ; enddo endif if (CS%Khth_Max > 0) then -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie Khth_loc_v(i,J) = max(CS%Khth_Min, min(Khth_loc_v(i,J), CS%Khth_Max)) enddo ; enddo else -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie Khth_loc_v(i,J) = max(CS%Khth_Min, Khth_loc_v(i,J)) enddo ; enddo endif if (CS%max_Khth_CFL > 0.0) then -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie KH_v(i,J,1) = min(KH_v_CFL(i,J), Khth_loc_v(i,J)) enddo ; enddo endif - if (khth_use_ebt_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) ) - enddo ; enddo ; enddo + if (khth_use_vert_struct) then + if (CS%full_depth_khth_min) 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%khth_struct(i,j,k-1) + VarMix%khth_struct(i,j+1,k-1) ) + KH_v(i,J,K) = max(KH_v(i,J,K), CS%Khth_Min) + enddo ; enddo ; enddo + else + !$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%khth_struct(i,j,k-1) + VarMix%khth_struct(i,j+1,k-1) ) + enddo ; enddo ; enddo + endif else -!$OMP do + !$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) enddo ; enddo ; enddo @@ -375,7 +432,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (use_VarMix) then if (use_QG_Leith) then -!$OMP do + !$OMP do do k=1,nz ; do J=js-1,je ; do i=is,ie KH_v(i,J,k) = VarMix%KH_v_QG(i,J,k) enddo ; enddo ; enddo @@ -383,7 +440,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif if (CS%use_GME_thickness_diffuse) then -!$OMP do + !$OMP do do k=1,nz+1 ; do J=js-1,je ; do i=is,ie CS%KH_v_GME(i,J,k) = KH_v(i,J,k) enddo ; enddo ; enddo @@ -391,9 +448,9 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (allocated(MEKE%Kh)) then if (CS%MEKE_GEOMETRIC) then - if (CS%MEKE_GEOM_answers_2018) then + if (CS%MEKE_GEOM_answer_date < 20190101) then !$OMP do - do j=js,je ; do I=is,ie + do j=js,je ; do i=is,ie ! This does not give bitwise rotational symmetry. MEKE%Kh(i,j) = CS%MEKE_GEOMETRIC_alpha * MEKE%MEKE(i,j) / & (0.25*(VarMix%SN_u(I,j)+VarMix%SN_u(I-1,j) + & @@ -402,7 +459,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp enddo ; enddo else !$OMP do - do j=js,je ; do I=is,ie + do j=js,je ; do i=is,ie ! With the additional parentheses this gives bitwise rotational symmetry. MEKE%Kh(i,j) = CS%MEKE_GEOMETRIC_alpha * MEKE%MEKE(i,j) / & (0.25*((VarMix%SN_u(I,j)+VarMix%SN_u(I-1,j)) + & @@ -413,46 +470,66 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif endif - -!$OMP do + !$OMP do do K=1,nz+1 ; do j=js,je ; do I=is-1,ie ; int_slope_u(I,j,K) = 0.0 ; enddo ; enddo ; enddo -!$OMP do + !$OMP do do K=1,nz+1 ; do J=js-1,je ; do i=is,ie ; int_slope_v(i,J,K) = 0.0 ; enddo ; enddo ; enddo -!$OMP end parallel + !$OMP end parallel if (CS%detangle_interfaces) then call add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV, US, & CS, int_slope_u, int_slope_v) endif + if ((CS%Kh_eta_bg > 0.0) .or. (CS%Kh_eta_vel > 0.0)) then + call add_interface_Kh(G, GV, US, CS, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, int_slope_u, int_slope_v) + endif + if (CS%debug) then call uvchksum("Kh_[uv]", Kh_u, Kh_v, G%HI, haloshift=0, & - scale=(US%L_to_m**2)*US%s_to_T, scalar_pair=.true.) + unscale=(US%L_to_m**2)*US%s_to_T, scalar_pair=.true.) + call uvchksum("Kh_[uv]_CFL", Kh_u_CFL, Kh_v_CFL, G%HI, haloshift=0, & + unscale=(US%L_to_m**2)*US%s_to_T, scalar_pair=.true.) + if (Resoln_scaled) then + call uvchksum("Res_fn_[uv]", VarMix%Res_fn_u, VarMix%Res_fn_v, G%HI, haloshift=0, & + unscale=1.0, scalar_pair=.true.) + endif call uvchksum("int_slope_[uv]", int_slope_u, int_slope_v, G%HI, haloshift=0) - call hchksum(h, "thickness_diffuse_1 h", G%HI, haloshift=1, scale=GV%H_to_m) - call hchksum(e, "thickness_diffuse_1 e", G%HI, haloshift=1, scale=US%Z_to_m) + call hchksum(h, "thickness_diffuse_1 h", G%HI, haloshift=1, unscale=GV%H_to_m) + call hchksum(e, "thickness_diffuse_1 e", G%HI, haloshift=1, unscale=US%Z_to_m) if (use_stored_slopes) then call uvchksum("VarMix%slope_[xy]", VarMix%slope_x, VarMix%slope_y, & - G%HI, haloshift=0, scale=US%Z_to_L) + G%HI, haloshift=0, unscale=US%Z_to_L) endif if (associated(tv%eqn_of_state)) then - call hchksum(tv%T, "thickness_diffuse T", G%HI, haloshift=1) - call hchksum(tv%S, "thickness_diffuse S", G%HI, haloshift=1) + call hchksum(tv%T, "thickness_diffuse T", G%HI, haloshift=1, unscale=US%C_to_degC) + call hchksum(tv%S, "thickness_diffuse S", G%HI, haloshift=1, unscale=US%S_to_ppt) endif endif ! Calculate uhD, vhD from h, e, KH_u, KH_v, tv%T/S - if (use_stored_slopes) then - call thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, CS, & - int_slope_u, int_slope_v, VarMix%slope_x, VarMix%slope_y) + if (STOCH%skeb_use_gm) then + if (use_stored_slopes) then + call thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, CS, & + int_slope_u, int_slope_v, VarMix%slope_x, VarMix%slope_y, & + STOCH=STOCH, VarMix=VarMix) + else + call thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, CS, & + int_slope_u, int_slope_v, STOCH=STOCH, VarMix=VarMix) + endif else - call thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, CS, & - int_slope_u, int_slope_v) + if (use_stored_slopes) then + call thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, CS, & + int_slope_u, int_slope_v, VarMix%slope_x, VarMix%slope_y) + else + call thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, CS, & + int_slope_u, int_slope_v) + endif endif if (VarMix%use_variable_mixing) then if (allocated(MEKE%Rd_dx_h) .and. allocated(VarMix%Rd_dx_h)) then -!$OMP parallel do default(none) shared(is,ie,js,je,MEKE,VarMix) + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie MEKE%Rd_dx_h(i,j) = VarMix%Rd_dx_h(i,j) enddo ; enddo @@ -469,11 +546,10 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (CS%id_KH_u1 > 0) call post_data(CS%id_KH_u1, KH_u(:,:,1), CS%diag) if (CS%id_KH_v1 > 0) call post_data(CS%id_KH_v1, KH_v(:,:,1), CS%diag) - ! Diagnose diffusivity at T-cell point. Do simple average, rather than - ! thickness-weighted average, in order that KH_t is depth-independent - ! in the case where KH_u and KH_v are depth independent. Otherwise, - ! if use thickness weighted average, the variations of thickness with - ! depth will place a spurious depth dependence to the diagnosed KH_t. + ! Diagnose diffusivity at T-cell point. Do a simple average, rather than a + ! thickness-weighted average, so that KH_t is depth-independent when KH_u and KH_v + ! are depth independent. If a thickness-weighted average were used, the variations + ! of thickness could give a spurious depth dependence to the diagnosed KH_t. if (CS%id_KH_t > 0 .or. CS%id_KH_t1 > 0 .or. CS%Use_KH_in_MEKE) then do k=1,nz ! thicknesses across u and v faces, converted to 0/1 mask @@ -494,8 +570,8 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp enddo ; enddo ! diagnose diffusivity at T-points do j=js,je ; do i=is,ie - Kh_t(i,j,k) = ((hu(I-1,j)*KH_u_lay(i-1,j) + hu(I,j)*KH_u_lay(I,j)) + & - (hv(i,J-1)*KH_v_lay(i,J-1) + hv(i,J)*KH_v_lay(i,J))) / & + Kh_t(i,j,k) = (((hu(I-1,j)*KH_u_lay(i-1,j)) + (hu(I,j)*KH_u_lay(I,j))) + & + ((hv(i,J-1)*KH_v_lay(i,J-1)) + (hv(i,J)*KH_v_lay(i,J)))) / & ((hu(I-1,j)+hu(I,j)) + (hv(i,J-1)+hv(i,J)) + 1.0e-20) ! Use this denominator instead if hu and hv are actual thicknesses rather than a 0/1 mask: ! ((hu(I-1,j)+hu(I,j)) + (hv(i,J-1)+hv(i,J)) + h_neglect) @@ -513,7 +589,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp enddo do j=js,je ; do i=is,ie - MEKE%Kh_diff(i,j) = MEKE%Kh_diff(i,j) / MAX(1.0*GV%m_to_H, htot(i,j)) + MEKE%Kh_diff(i,j) = MEKE%Kh_diff(i,j) / MAX(CS%MEKE_min_depth_diff, htot(i,j)) enddo ; enddo endif @@ -523,7 +599,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif - !$OMP parallel do default(none) shared(is,ie,js,je,nz,uhtr,uhD,dt,vhtr,CDp,vhD,h,G,GV) + !$OMP parallel do default(shared) do k=1,nz do j=js,je ; do I=is-1,ie uhtr(I,j,k) = uhtr(I,j,k) + uhD(I,j,k) * dt @@ -547,10 +623,10 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (CS%debug) then call uvchksum("thickness_diffuse [uv]hD", uhD, vhD, & - G%HI, haloshift=0, scale=GV%H_to_m*US%L_to_m**2*US%s_to_T) + G%HI, haloshift=0, unscale=GV%H_to_m*US%L_to_m**2*US%s_to_T) call uvchksum("thickness_diffuse [uv]htr", uhtr, vhtr, & - G%HI, haloshift=0, scale=US%L_to_m**2*GV%H_to_m) - call hchksum(h, "thickness_diffuse h", G%HI, haloshift=0, scale=GV%H_to_m) + G%HI, haloshift=0, unscale=US%L_to_m**2*GV%H_to_m) + call hchksum(h, "thickness_diffuse h", G%HI, haloshift=0, unscale=GV%H_to_m) endif end subroutine thickness_diffuse @@ -559,15 +635,15 @@ end subroutine thickness_diffuse !! Fluxes are limited to give positive definite thicknesses. !! Called by thickness_diffuse(). subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, & - CS, int_slope_u, int_slope_v, slope_x, slope_y) + CS, int_slope_u, int_slope_v, slope_x, slope_y, STOCH, VarMix) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface positions [Z ~> m] - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: Kh_u !< Thickness diffusivity on interfaces + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: Kh_u !< Isopycnal height diffusivity !! at u points [L2 T-1 ~> m2 s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: Kh_v !< Thickness diffusivity on interfaces + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: Kh_v !< Isopycnal height diffusivity !! at v points [L2 T-1 ~> m2 s-1] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(out) :: uhD !< Zonal mass fluxes @@ -576,8 +652,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV !! [H L2 T-1 ~> m3 s-1 or kg s-1] real, dimension(:,:), pointer :: cg1 !< Wave speed [L T-1 ~> m s-1] real, intent(in) :: dt !< Time increment [T ~> s] - type(MEKE_type), intent(inout) :: MEKE !< MEKE fields - type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness diffusion + type(MEKE_type), intent(inout) :: MEKE !< MEKE fields + type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness_diffuse real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: int_slope_u !< Ratio that determine how much of !! the isopycnal slopes are taken directly from !! the interface slopes without consideration of @@ -588,133 +664,173 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV !! density gradients [nondim]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), optional, intent(in) :: slope_x !< Isopyc. slope at u [Z L-1 ~> nondim] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), optional, intent(in) :: slope_y !< Isopyc. slope at v [Z L-1 ~> nondim] + type(stochastic_CS), optional, intent(inout) :: STOCH !< Stochastic control structure + type(VarMix_CS), target, optional, intent(in) :: VarMix !< Variable mixing coefficents + ! Local variables - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: & - T, & ! The temperature (or density) [degC], with the values in + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + T, & ! The temperature [C ~> degC], with the values in ! in massless layers filled vertically by diffusion. - S, & ! The filled salinity [ppt], with the values in + S, & ! The filled salinity [S ~> ppt], with the values in ! in massless layers filled vertically by diffusion. h_avail, & ! The mass available for diffusion out of each face, divided ! by dt [H L2 T-1 ~> m3 s-1 or kg s-1]. h_frac ! The fraction of the mass in the column above the bottom ! interface of a layer that is within a layer [nondim]. 0 m s-2], - ! used for calculating PE release - real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: & - Slope_x_PE, & ! 3D array of neutral slopes at u-points, set equal to Slope (below, nondim) - hN2_x_PE ! thickness in m times Brunt-Vaisala freqeuncy at u-points [L2 Z-1 T-2 ~> m s-2], - ! used for calculating PE release - real, dimension(SZI_(G), SZJ_(G),SZK_(GV)+1) :: & + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Height change across layers [Z ~> m] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & + Slope_y_PE, & ! 3D array of neutral slopes at v-points, set equal to Slope (below) [Z L-1 ~> nondim] + hN2_y_PE ! Harmonic mean of thicknesses around the interfaces times the buoyancy frequency + ! at v-points with unit conversion factors [H L2 Z-2 T-2 ~> m s-2 or kg m-2 s-2], + ! used for calculating the potential energy release + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & + Slope_x_PE, & ! 3D array of neutral slopes at u-points, set equal to Slope (below) [Z L-1 ~> nondim] + hN2_x_PE ! Harmonic mean of thicknesses around the interfaces times the buoyancy frequency + ! at u-points with unit conversion factors [H L2 Z-2 T-2 ~> m s-2 or kg m-2 s-2], + ! used for calculating the potential energy release + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & pres, & ! The pressure at an interface [R L2 T-2 ~> Pa]. h_avail_rsum ! The running sum of h_avail above an interface [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIB_(G)) :: & - drho_dT_u, & ! The derivative of density with temperature at u points [R degC-1 ~> kg m-3 degC-1] - drho_dS_u, & ! The derivative of density with salinity at u points [R ppt-1 ~> kg m-3 ppt-1]. - drho_dT_dT_u ! The second derivative of density with temperature at u points [R degC-2 ~> kg m-3 degC-2] - real, dimension(SZIB_(G)) :: scrap ! An array to pass to calculate_density_second_derivs() that will be ingored. + drho_dT_u, & ! The derivative of density with temperature at u points [R C-1 ~> kg m-3 degC-1] + drho_dS_u ! The derivative of density with salinity at u points [R S-1 ~> kg m-3 ppt-1]. + real, dimension(SZIB_(G)) :: scrap ! An array to pass to calculate_density_second_derivs() + ! with various units that will be ignored [various] real, dimension(SZI_(G)) :: & - drho_dT_v, & ! The derivative of density with temperature at v points [R degC-1 ~> kg m-3 degC-1] - drho_dS_v, & ! The derivative of density with salinity at v points [R ppt-1 ~> kg m-3 ppt-1]. - drho_dT_dT_v ! The second derivative of density with temperature at v points [R degC-2 ~> kg m-3 degC-2] - real :: uhtot(SZIB_(G), SZJ_(G)) ! The vertical sum of uhD [H L2 T-1 ~> m3 s-1 or kg s-1]. - real :: vhtot(SZI_(G), SZJB_(G)) ! The vertical sum of vhD [H L2 T-1 ~> m3 s-1 or kg s-1]. + drho_dT_v, & ! The derivative of density with temperature at v points [R C-1 ~> kg m-3 degC-1] + drho_dS_v, & ! The derivative of density with salinity at v points [R S-1 ~> kg m-3 ppt-1]. + drho_dT_dT_h, & ! The second derivative of density with temperature at h points [R C-2 ~> kg m-3 degC-2] + drho_dT_dT_hr ! The second derivative of density with temperature at h (+1) points [R C-2 ~> kg m-3 degC-2] + real :: uhtot(SZIB_(G),SZJ_(G)) ! The vertical sum of uhD [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: vhtot(SZI_(G),SZJB_(G)) ! The vertical sum of vhD [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIB_(G)) :: & - T_u, & ! Temperature on the interface at the u-point [degC]. - S_u, & ! Salinity on the interface at the u-point [ppt]. + T_u, & ! Temperature on the interface at the u-point [C ~> degC]. + S_u, & ! Salinity on the interface at the u-point [S ~> ppt]. pres_u ! Pressure on the interface at the u-point [R L2 T-2 ~> Pa]. real, dimension(SZI_(G)) :: & - T_v, & ! Temperature on the interface at the v-point [degC]. - S_v, & ! Salinity on the interface at the v-point [ppt]. - pres_v ! Pressure on the interface at the v-point [R L2 T-2 ~> Pa]. - real :: Work_u(SZIB_(G), SZJ_(G)) ! The work being done by the thickness - real :: Work_v(SZI_(G), SZJB_(G)) ! diffusion integrated over a cell [R Z L4 T-3 ~> W ] + T_v, & ! Temperature on the interface at the v-point [C ~> degC]. + S_v, & ! Salinity on the interface at the v-point [S ~> ppt]. + pres_v, & ! Pressure on the interface at the v-point [R L2 T-2 ~> Pa]. + T_h, & ! Temperature on the interface at the h-point [C ~> degC]. + S_h, & ! Salinity on the interface at the h-point [S ~> ppt]. + pres_h, & ! Pressure on the interface at the h-point [R L2 T-2 ~> Pa]. + T_hr, & ! Temperature on the interface at the h (+1) point [C ~> degC]. + S_hr, & ! Salinity on the interface at the h (+1) point [S ~> ppt]. + pres_hr ! Pressure on the interface at the h (+1) point [R L2 T-2 ~> Pa]. + real :: Work_u(SZIB_(G),SZJ_(G)) ! The work done by the isopycnal height diffusion + ! integrated over u-point water columns [R Z L4 T-3 ~> W] + real :: Work_v(SZI_(G),SZJB_(G)) ! The work done by the isopycnal height diffusion + ! integrated over v-point water columns [R Z L4 T-3 ~> W] real :: Work_h ! The work averaged over an h-cell [R Z L2 T-3 ~> W m-2]. - real :: PE_release_h ! The amount of potential energy released by GM averaged over an h-cell [L4 Z-1 T-3 ~> m3 s-3] - ! The calculation is equal to h * S^2 * N^2 * kappa_GM. + real :: PE_release_h ! The amount of potential energy released by GM averaged over an h-cell + ! [R Z L2 T-3 ~> W m-2]. The calculation equals rho0 * h * S^2 * N^2 * kappa_GM. real :: I4dt ! 1 / 4 dt [T-1 ~> s-1]. - real :: drdiA, drdiB ! Along layer zonal- and meridional- potential density - real :: drdjA, drdjB ! gradients in the layers above (A) and below(B) the - ! interface times the grid spacing [R ~> kg m-3]. + real :: drdiA, drdiB ! Along layer zonal potential density gradients in the layers above (A) + ! and below (B) the interface times the grid spacing [R ~> kg m-3]. + real :: drdjA, drdjB ! Along layer meridional potential density gradients in the layers above (A) + ! and below (B) the interface times the grid spacing [R ~> kg m-3]. real :: drdkL, drdkR ! Vertical density differences across an interface [R ~> kg m-3]. real :: drdi_u(SZIB_(G),SZK_(GV)) ! Copy of drdi at u-points [R ~> kg m-3]. - real :: drdj_v(SZI_(G), SZK_(GV)) ! Copy of drdj at v-points [R ~> kg m-3]. + real :: drdj_v(SZI_(G),SZK_(GV)) ! Copy of drdj at v-points [R ~> kg m-3]. real :: drdkDe_u(SZIB_(G),SZK_(GV)+1) ! Lateral difference of product of drdk and e at u-points ! [Z R ~> kg m-2]. real :: drdkDe_v(SZI_(G),SZK_(GV)+1) ! Lateral difference of product of drdk and e at v-points ! [Z R ~> kg m-2]. real :: hg2A, hg2B, hg2L, hg2R ! Squares of geometric mean thicknesses [H2 ~> m2 or kg2 m-4]. real :: haA, haB, haL, haR ! Arithmetic mean thicknesses [H ~> m or kg m-2]. - real :: dzaL, dzaR ! Temporary thicknesses [Z ~> m]. - real :: wtA, wtB, wtL, wtR ! Unscaled weights, with various units. + real :: dzg2A, dzg2B ! Squares of geometric mean vertical layer extents [Z2 ~> m2]. + real :: dzaA, dzaB ! Arithmetic mean vertical layer extents [Z ~> m]. + real :: dzaL, dzaR ! Temporary vertical layer extents [Z ~> m] + real :: wtA, wtB ! Unnormalized weights of the slopes above and below [H3 ~> m3 or kg3 m-6] + real :: wtL, wtR ! Unnormalized weights of the slopes to the left and right [H3 Z ~> m4 or kg3 m-5] real :: drdx, drdy ! Zonal and meridional density gradients [R L-1 ~> kg m-4]. real :: drdz ! Vertical density gradient [R Z-1 ~> kg m-4]. - real :: h_harm ! Harmonic mean layer thickness [H ~> m or kg m-2]. - real :: c2_h_u(SZIB_(G),SZK_(GV)+1) ! Wave speed squared divided by h at u-points [L2 Z-1 T-2 ~> m s-2]. - real :: c2_h_v(SZI_(G),SZK_(GV)+1) ! Wave speed squared divided by h at v-points [L2 Z-1 T-2 ~> m s-2]. - real :: hN2_u(SZIB_(G),SZK_(GV)+1) ! Thickness in m times N2 at interfaces above u-points [L2 Z-1 T-2 ~> m s-2]. - real :: hN2_v(SZI_(G),SZK_(GV)+1) ! Thickness in m times N2 at interfaces above v-points [L2 Z-1 T-2 ~> m s-2]. + real :: dz_harm ! Harmonic mean layer vertical extent [Z ~> m]. + real :: c2_dz_u(SZIB_(G),SZK_(GV)+1) ! Wave speed squared divided by dz at u-points [L2 Z-1 T-2 ~> m s-2] + real :: c2_dz_v(SZI_(G),SZK_(GV)+1) ! Wave speed squared divided by dz at v-points [L2 Z-1 T-2 ~> m s-2] + real :: dzN2_u(SZIB_(G),SZK_(GV)+1) ! Vertical extent times N2 at interfaces above u-points times + ! rescaling factors from vertical to horizontal distances [L2 Z-1 T-2 ~> m s-2] + real :: dzN2_v(SZI_(G),SZK_(GV)+1) ! Vertical extent times N2 at interfaces above v-points times + ! rescaling factors from vertical to horizontal distances [L2 Z-1 T-2 ~> m s-2] real :: Sfn_est ! A preliminary estimate (before limiting) of the overturning - ! streamfunction [Z L2 T-1 ~> m3 s-1]. - real :: Sfn_unlim_u(SZIB_(G),SZK_(GV)+1) ! Streamfunction for u-points [Z L2 T-1 ~> m3 s-1]. - real :: Sfn_unlim_v(SZI_(G),SZK_(GV)+1) ! Streamfunction for v-points [Z L2 T-1 ~> m3 s-1]. - real :: slope2_Ratio_u(SZIB_(G),SZK_(GV)+1) ! The ratio of the slope squared to slope_max squared. - real :: slope2_Ratio_v(SZI_(G),SZK_(GV)+1) ! The ratio of the slope squared to slope_max squared. + ! streamfunction [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: Sfn_unlim_u(SZIB_(G),SZK_(GV)+1) ! Volume streamfunction for u-points [Z L2 T-1 ~> m3 s-1] + real :: Sfn_unlim_v(SZI_(G),SZK_(GV)+1) ! Volume streamfunction for v-points [Z L2 T-1 ~> m3 s-1] + real :: slope2_Ratio_u(SZIB_(G),SZK_(GV)+1) ! The ratio of the slope squared to slope_max squared [nondim] + real :: slope2_Ratio_v(SZI_(G),SZK_(GV)+1) ! The ratio of the slope squared to slope_max squared [nondim] real :: Sfn_in_h ! The overturning streamfunction [H L2 T-1 ~> m3 s-1 or kg s-1] (note that ! the units are different from other Sfn vars). - real :: Sfn_safe ! The streamfunction that goes linearly back to 0 at the surface. This is a - ! good thing to use when the slope is so large as to be meaningless [Z L2 T-1 ~> m3 s-1]. - real :: Slope ! The slope of density surfaces, calculated in a way - ! that is always between -1 and 1, nondimensional. + real :: Sfn_safe ! The streamfunction that goes linearly back to 0 at the surface + ! [H L2 T-1 ~> m3 s-1 or kg s-1]. This is a good value to use when the + ! slope is so large as to be meaningless, usually due to weak stratification. + real :: Slope ! The slope of density surfaces, calculated in a way that is always + ! between -1 and 1 after undoing dimensional scaling, [Z L-1 ~> nondim] real :: mag_grad2 ! The squared magnitude of the 3-d density gradient [R2 L-2 ~> kg2 m-8]. real :: I_slope_max2 ! The inverse of slope_max squared [L2 Z-2 ~> nondim]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: hn_2 ! Half of h_neglect [H ~> m or kg m-2]. real :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4]. real :: dz_neglect ! A thickness [Z ~> m], that is so small it is usually lost ! in roundoff and can be neglected [Z ~> m]. + real :: dz_neglect2 ! dz_neglect^2 [Z2 ~> m2] real :: G_scale ! The gravitational acceleration times a unit conversion ! factor [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. - logical :: use_EOS ! If true, density is calculated from T & S using an - ! equation of state. + logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. logical :: find_work ! If true, find the change in energy due to the fluxes. integer :: nk_linear ! The number of layers over which the streamfunction goes to 0. real :: G_rho0 ! g/Rho0 [L2 R-1 Z-1 T-2 ~> m4 kg-1 s-2]. + real :: Rho_avg ! The in situ density averaged to an interface [R ~> kg m-3] real :: N2_floor ! A floor for N2 to avoid degeneracy in the elliptic solver - ! times unit conversion factors [T-2 L2 Z-2 ~> s-2] - real :: Tl(5) ! copy and T in local stencil [degC] - real :: mn_T ! mean of T in local stencil [degC] - real :: mn_T2 ! mean of T**2 in local stencil [degC] - real :: hl(5) ! Copy of local stencil of H [H ~> m] - real :: r_sm_H ! Reciprocal of sum of H in local stencil [H-1 ~> m-1] - real, dimension(SZI_(G), SZJ_(G),SZK_(GV)) :: Tsgs2 ! Sub-grid temperature variance [degC2] - - real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: diag_sfn_x, diag_sfn_unlim_x ! Diagnostics - real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: diag_sfn_y, diag_sfn_unlim_y ! Diagnostics + ! times unit conversion factors [L2 Z-2 T-2 ~> s-2] + real :: N2_unlim ! An unlimited estimate of the buoyancy frequency + ! times unit conversion factors [L2 Z-2 T-2 ~> s-2] + real :: Z_to_H ! A conversion factor from heights to thicknesses, perhaps based on + ! a spatially variable local density [H Z-1 ~> nondim or kg m-3] + real :: diag_sfn_x(SZIB_(G),SZJ_(G),SZK_(GV)+1) ! Diagnostic of the x-face streamfunction + ! [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: diag_sfn_unlim_x(SZIB_(G),SZJ_(G),SZK_(GV)+1) ! Diagnostic of the x-face streamfunction before + ! applying limiters [Z L2 T-1 ~> m3 s-1] + real :: diag_sfn_y(SZI_(G),SZJB_(G),SZK_(GV)+1) ! Diagnostic of the y-face streamfunction + ! [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: diag_sfn_unlim_y(SZI_(G),SZJB_(G),SZK_(GV)+1) ! Diagnostic of the y-face streamfunction before + ! applying limiters [Z L2 T-1 ~> m3 s-1] + ! applying limiters [H L2 T-1 ~> m3 s-1 or kg s-1] + real, allocatable :: skeb_gm_work(:,:) ! Temp array to hold GM work for SKEB + real, allocatable :: skeb_ebt_norm2(:,:) ! Used to normalize EBT for SKEB + logical :: present_slope_x, present_slope_y, calc_derivatives - integer, dimension(2) :: EOSdom_u ! The shifted i-computational domain to use for equation of + integer, dimension(2) :: EOSdom_u ! The shifted I-computational domain to use for equation of ! state calculations at u-points. - integer, dimension(2) :: EOSdom_v ! The shifted I-computational domain to use for equation of + integer, dimension(2) :: EOSdom_v ! The shifted i-computational domain to use for equation of ! state calculations at v-points. - logical :: use_Stanley + integer, dimension(2) :: EOSdom_h1 ! The shifted i-computational domain to use for equation of + ! state calculations at h points with 1 extra halo point + logical :: use_stanley, skeb_use_gm integer :: is, ie, js, je, nz, IsdB, halo integer :: i, j, k is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke ; IsdB = G%IsdB I4dt = 0.25 / dt I_slope_max2 = 1.0 / (CS%slope_max**2) - G_scale = GV%g_Earth * GV%H_to_Z - h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect**2 - dz_neglect = GV%H_subroundoff*GV%H_to_Z - G_rho0 = GV%g_Earth / GV%Rho0 - N2_floor = CS%N2_floor*US%Z_to_L**2 + h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect**2 ; hn_2 = 0.5*h_neglect + dz_neglect = GV%dZ_subroundoff ; dz_neglect2 = dz_neglect**2 + if (GV%Boussinesq) G_rho0 = GV%g_Earth / GV%Rho0 + N2_floor = CS%N2_floor use_EOS = associated(tv%eqn_of_state) present_slope_x = PRESENT(slope_x) present_slope_y = PRESENT(slope_y) - use_Stanley = CS%Stanley_det_coeff >= 0. + + use_stanley = CS%use_stanley_gm + + skeb_use_gm = .false. + if (present(STOCH)) skeb_use_gm = STOCH%skeb_use_gm + if (skeb_use_gm) then + allocate(skeb_gm_work(is:ie,js:je), source=0.) + allocate(skeb_ebt_norm2(is:ie,js:je), source=0.) + endif nk_linear = max(GV%nkml, 1) @@ -725,22 +841,22 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV find_work = allocated(MEKE%GM_src) find_work = (allocated(CS%GMwork) .or. find_work) + find_work = (skeb_use_gm .or. find_work) if (use_EOS) then halo = 1 ! Default halo to fill is 1 - if (use_Stanley) halo = 2 ! Need wider valid halo for gradients of T - call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, halo, larger_h_denom=.true.) + call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, US, halo, larger_h_denom=.true.) endif + ! Rescale the thicknesses, perhaps using the specific volume. + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + if (CS%use_FGNV_streamfn .and. .not. associated(cg1)) call MOM_error(FATAL, & "cg1 must be associated when using FGNV streamfunction.") -!$OMP parallel default(none) shared(is,ie,js,je,h_avail_rsum,pres,h_avail,I4dt, use_Stanley, & -!$OMP CS,G,GV,tv,h,h_frac,nz,uhtot,Work_u,vhtot,Work_v,Tsgs2,T, & -!$OMP diag_sfn_x, diag_sfn_y, diag_sfn_unlim_x, diag_sfn_unlim_y ) & -!$OMP private(hl,r_sm_H,Tl,mn_T,mn_T2) + !$OMP parallel default(shared) ! Find the maximum and minimum permitted streamfunction. -!$OMP do + !$OMP do do j=js-1,je+1 ; do i=is-1,ie+1 h_avail_rsum(i,j,1) = 0.0 pres(i,j,1) = 0.0 @@ -751,42 +867,6 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV h_frac(i,j,1) = 1.0 pres(i,j,2) = pres(i,j,1) + (GV%g_Earth*GV%H_to_RZ) * h(i,j,1) enddo ; enddo - if (use_Stanley) then -!$OMP do - do k=1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 - !! SGS variance in i-direction [degC2] - !dTdi2 = ( ( G%mask2dCu(I ,j) * G%IdxCu(I ,j) * ( T(i+1,j,k) - T(i,j,k) ) & - ! + G%mask2dCu(I-1,j) * G%IdxCu(I-1,j) * ( T(i,j,k) - T(i-1,j,k) ) & - ! ) * G%dxT(i,j) * 0.5 )**2 - !! SGS variance in j-direction [degC2] - !dTdj2 = ( ( G%mask2dCv(i,J ) * G%IdyCv(i,J ) * ( T(i,j+1,k) - T(i,j,k) ) & - ! + G%mask2dCv(i,J-1) * G%IdyCv(i,J-1) * ( T(i,j,k) - T(i,j-1,k) ) & - ! ) * G%dyT(i,j) * 0.5 )**2 - !Tsgs2(i,j,k) = CS%Stanley_det_coeff * 0.5 * ( dTdi2 + dTdj2 ) - ! This block does a thickness weighted variance calculation and helps control for - ! extreme gradients along layers which are vanished against topography. It is - ! still a poor approximation in the interior when coordinates are strongly tilted. - hl(1) = h(i,j,k) * G%mask2dT(i,j) - hl(2) = h(i-1,j,k) * G%mask2dCu(I-1,j) - hl(3) = h(i+1,j,k) * G%mask2dCu(I,j) - hl(4) = h(i,j-1,k) * G%mask2dCv(i,J-1) - hl(5) = h(i,j+1,k) * G%mask2dCv(i,J) - r_sm_H = 1. / ( ( hl(1) + ( ( hl(2) + hl(3) ) + ( hl(4) + hl(5) ) ) ) + GV%H_subroundoff ) - ! Mean of T - Tl(1) = T(i,j,k) ; Tl(2) = T(i-1,j,k) ; Tl(3) = T(i+1,j,k) - Tl(4) = T(i,j-1,k) ; Tl(5) = T(i,j+1,k) - mn_T = ( hl(1)*Tl(1) + ( ( hl(2)*Tl(2) + hl(3)*Tl(3) ) + ( hl(4)*Tl(4) + hl(5)*Tl(5) ) ) ) * r_sm_H - ! Adjust T vectors to have zero mean - Tl(:) = Tl(:) - mn_T ; mn_T = 0. - ! Variance of T - mn_T2 = ( hl(1)*Tl(1)*Tl(1) + ( ( hl(2)*Tl(2)*Tl(2) + hl(3)*Tl(3)*Tl(3) ) & - + ( hl(4)*Tl(4)*Tl(4) + hl(5)*Tl(5)*Tl(5) ) ) ) * r_sm_H - ! Variance should be positive but round-off can violate this. Calculating - ! variance directly would fix this but requires more operations. - Tsgs2(i,j,k) = CS%Stanley_det_coeff * max(0., mn_T2) - enddo ; enddo ; enddo - endif -!$OMP do do j=js-1,je+1 do k=2,nz ; do i=is-1,ie+1 h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) @@ -796,36 +876,41 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV pres(i,j,K+1) = pres(i,j,K) + (GV%g_Earth*GV%H_to_RZ) * h(i,j,k) enddo ; enddo enddo -!$OMP do + !$OMP do do j=js,je ; do I=is-1,ie uhtot(I,j) = 0.0 ; Work_u(I,j) = 0.0 - diag_sfn_x(I,j,1) = 0.0 ; diag_sfn_unlim_x(I,j,1) = 0.0 - diag_sfn_x(I,j,nz+1) = 0.0 ; diag_sfn_unlim_x(I,j,nz+1) = 0.0 enddo ; enddo -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie vhtot(i,J) = 0.0 ; Work_v(i,J) = 0.0 - diag_sfn_y(i,J,1) = 0.0 ; diag_sfn_unlim_y(i,J,1) = 0.0 - diag_sfn_y(i,J,nz+1) = 0.0 ; diag_sfn_unlim_y(i,J,nz+1) = 0.0 enddo ; enddo -!$OMP end parallel - - EOSdom_u(1) = (is-1) - (G%IsdB-1) ; EOSdom_u(2) = ie - (G%IsdB-1) -!$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S, & -!$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect,I_slope_max2, & -!$OMP h_neglect2,int_slope_u,KH_u,uhtot,h_frac,h_avail_rsum, & -!$OMP uhD,h_avail,G_scale,Work_u,CS,slope_x,cg1,diag_sfn_x, & -!$OMP diag_sfn_unlim_x,N2_floor,EOSdom_u,use_stanley, Tsgs2, & -!$OMP present_slope_x,G_rho0,Slope_x_PE,hN2_x_PE) & -!$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & -!$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & -!$OMP drho_dT_dT_u,scrap, & -!$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & -!$OMP drdx,mag_grad2,Slope,slope2_Ratio_u,hN2_u, & -!$OMP Sfn_unlim_u,drdi_u,drdkDe_u,h_harm,c2_h_u, & -!$OMP Sfn_safe,Sfn_est,Sfn_in_h,calc_derivatives) + !$OMP end parallel + + if (CS%id_sfn_x > 0) then ; diag_sfn_x(:,:,1) = 0.0 ; diag_sfn_x(:,:,nz+1) = 0.0 ; endif + if (CS%id_sfn_y > 0) then ; diag_sfn_y(:,:,1) = 0.0 ; diag_sfn_y(:,:,nz+1) = 0.0 ; endif + if (CS%id_sfn_unlim_x > 0) then ; diag_sfn_unlim_x(:,:,1) = 0.0 ; diag_sfn_unlim_x(:,:,nz+1) = 0.0 ; endif + if (CS%id_sfn_unlim_y > 0) then ; diag_sfn_unlim_y(:,:,1) = 0.0 ; diag_sfn_unlim_y(:,:,nz+1) = 0.0 ; endif + + EOSdom_u(1) = (is-1) - (G%IsdB-1) ; EOSdom_u(2) = ie - (G%IsdB-1) + EOSdom_v(:) = EOS_domain(G%HI) + EOSdom_h1(:) = EOS_domain(G%HI, halo=1) + + !$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S, & + !$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz,dz_neglect,dz_neglect2, & + !$OMP h_neglect2,hn_2,I_slope_max2,int_slope_u,KH_u,uhtot, & + !$OMP h_frac,h_avail_rsum,uhD,h_avail,Work_u,CS,slope_x,cg1, & + !$OMP diag_sfn_x,diag_sfn_unlim_x,N2_floor,EOSdom_u,EOSdom_h1, & + !$OMP use_stanley,present_slope_x,G_rho0,Slope_x_PE,hN2_x_PE) & + !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u,G_scale, & + !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & + !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h,N2_unlim, & + !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & + !$OMP dzg2A,dzg2B,dzaA,dzaB,dz_harm,Z_to_H, & + !$OMP drdx,mag_grad2,Slope,slope2_Ratio_u,dzN2_u, & + !$OMP Sfn_unlim_u,Rho_avg,drdi_u,drdkDe_u,c2_dz_u, & + !$OMP Sfn_safe,Sfn_est,Sfn_in_h,calc_derivatives) do j=js,je - do I=is-1,ie ; hN2_u(I,1) = 0. ; hN2_u(I,nz+1) = 0. ; enddo + do I=is-1,ie ; dzN2_u(I,1) = 0. ; dzN2_u(I,nz+1) = 0. ; enddo do K=nz,2,-1 if (find_work .and. .not.(use_EOS)) then drdiA = 0.0 ; drdiB = 0.0 @@ -833,7 +918,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV endif calc_derivatives = use_EOS .and. (k >= nk_linear) .and. & - (find_work .or. .not. present_slope_x .or. CS%use_FGNV_streamfn .or. use_Stanley) + (find_work .or. .not. present_slope_x .or. CS%use_FGNV_streamfn .or. use_stanley) ! Calculate the zonal fluxes and gradients. if (calc_derivatives) then @@ -845,12 +930,18 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, drho_dS_u, & tv%eqn_of_state, EOSdom_u) endif - if (use_Stanley) then + if (use_stanley) then + do i=is-1,ie+1 + pres_h(i) = pres(i,j,K) + T_h(i) = 0.5*(T(i,j,k) + T(i,j,k-1)) + S_h(i) = 0.5*(S(i,j,k) + S(i,j,k-1)) + enddo + ! The second line below would correspond to arguments ! drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & - call calculate_density_second_derivs(T_u, S_u, pres_u, & - scrap, scrap, drho_dT_dT_u, scrap, scrap, & - (is-IsdB+1)-1, ie-is+2, tv%eqn_of_state) + call calculate_density_second_derivs(T_h, S_h, pres_h, & + scrap, scrap, drho_dT_dT_h, scrap, scrap, & + tv%eqn_of_state, EOSdom_h1) endif do I=is-1,ie @@ -866,15 +957,17 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV drho_dS_u(I) * (S(i,j,k)-S(i,j,k-1))) drdkR = (drho_dT_u(I) * (T(i+1,j,k)-T(i+1,j,k-1)) + & drho_dS_u(I) * (S(i+1,j,k)-S(i+1,j,k-1))) - drdkDe_u(I,K) = drdkR * e(i+1,j,K) - drdkL * e(i,j,K) + drdkDe_u(I,K) = (drdkR * e(i+1,j,K)) - (drdkL * e(i,j,K)) elseif (find_work) then ! This is used in pure stacked SW mode - drdkDe_u(I,K) = drdkR * e(i+1,j,K) - drdkL * e(i,j,K) + drdkDe_u(I,K) = (drdkR * e(i+1,j,K)) - (drdkL * e(i,j,K)) endif - if (use_Stanley) then + if (use_stanley) then ! Correction to the horizontal density gradient due to nonlinearity in ! the EOS rectifying SGS temperature anomalies - drdiA = drdiA + drho_dT_dT_u(I) * 0.5 * ( Tsgs2(i+1,j,k-1)-Tsgs2(i,j,k-1) ) - drdiB = drdiB + drho_dT_dT_u(I) * 0.5 * ( Tsgs2(i+1,j,k)-Tsgs2(i,j,k) ) + drdiA = drdiA + 0.5 * ((drho_dT_dT_h(i+1) * tv%varT(i+1,j,k-1)) - & + (drho_dT_dT_h(i) * tv%varT(i,j,k-1)) ) + drdiB = drdiB + 0.5 * ((drho_dT_dT_h(i+1) * tv%varT(i+1,j,k)) - & + (drho_dT_dT_h(i) * tv%varT(i,j,k)) ) endif if (find_work) drdi_u(I,k) = drdiB @@ -887,15 +980,18 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV haR = 0.5*(h(i+1,j,k-1) + h(i+1,j,k)) + h_neglect if (GV%Boussinesq) then dzaL = haL * GV%H_to_Z ; dzaR = haR * GV%H_to_Z - else + elseif (GV%semi_Boussinesq) then dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect dzaR = 0.5*(e(i+1,j,K-1) - e(i+1,j,K+1)) + dz_neglect + else + dzaL = 0.5*(dz(i,j,k-1) + dz(i,j,k)) + dz_neglect + dzaR = 0.5*(dz(i+1,j,k-1) + dz(i+1,j,k)) + dz_neglect endif ! Use the harmonic mean thicknesses to weight the horizontal gradients. ! These unnormalized weights have been rearranged to minimize divisions. wtL = hg2L*(haR*dzaR) ; wtR = hg2R*(haL*dzaL) - drdz = (wtL * drdkL + wtR * drdkR) / (dzaL*wtL + dzaR*wtR) + drdz = ((wtL * drdkL) + (wtR * drdkR)) / ((dzaL*wtL) + (dzaR*wtR)) ! The expression for drdz above is mathematically equivalent to: ! drdz = ((hg2L/haL) * drdkL/dzaL + (hg2R/haR) * drdkR/dzaR) / & ! ((hg2L/haL) + (hg2R/haR)) @@ -904,10 +1000,23 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV haA = 0.5*(h(i,j,k-1) + h(i+1,j,k-1)) + h_neglect haB = 0.5*(h(i,j,k) + h(i+1,j,k)) + h_neglect - ! hN2_u is used with the FGNV streamfunction formulation - hN2_u(I,K) = (0.5 * GV%H_to_Z * ( hg2A / haA + hg2B / haB )) * & - max(drdz*G_rho0, N2_floor) + if (GV%Boussinesq) then + N2_unlim = drdz*G_rho0 + else + N2_unlim = (GV%g_Earth*GV%RZ_to_H) * & + (((wtL * drdkL) + (wtR * drdkR)) / ((haL*wtL) + (haR*wtR))) + endif + + dzg2A = dz(i,j,k-1)*dz(i+1,j,k-1) + dz_neglect2 + dzg2B = dz(i,j,k)*dz(i+1,j,k) + dz_neglect2 + dzaA = 0.5*(dz(i,j,k-1) + dz(i+1,j,k-1)) + dz_neglect + dzaB = 0.5*(dz(i,j,k) + dz(i+1,j,k)) + dz_neglect + ! dzN2_u is used with the FGNV streamfunction formulation + dzN2_u(I,K) = (0.5 * ( dzg2A / dzaA + dzg2B / dzaB )) * max(N2_unlim, N2_floor) + if (find_work .and. CS%GM_src_alt) & + hN2_x_PE(I,j,k) = (0.5 * ( hg2A / haA + hg2B / haB )) * max(N2_unlim, N2_floor) endif + if (present_slope_x) then Slope = slope_x(I,j,k) slope2_Ratio_u(I,K) = Slope**2 * I_slope_max2 @@ -937,12 +1046,17 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV int_slope_u(I,j,K) * ((e(i+1,j,K)-e(i,j,K)) * G%IdxCu(I,j)) slope2_Ratio_u(I,K) = (1.0 - int_slope_u(I,j,K)) * slope2_Ratio_u(I,K) - Slope_x_PE(I,j,k) = MIN(Slope,CS%slope_max) - hN2_x_PE(I,j,k) = hN2_u(I,K) + if (CS%MEKE_src_slope_bug) then + Slope_x_PE(I,j,k) = MIN(Slope, CS%slope_max) + else + Slope_x_PE(I,j,k) = Slope + if (Slope > CS%slope_max) Slope_x_PE(I,j,k) = CS%slope_max + if (Slope < -CS%slope_max) Slope_x_PE(I,j,k) = -CS%slope_max + endif if (CS%id_slope_x > 0) CS%diagSlopeX(I,j,k) = Slope - ! Estimate the streamfunction at each interface [Z L2 T-1 ~> m3 s-1]. - Sfn_unlim_u(I,K) = -((KH_u(I,j,K)*G%dy_Cu(I,j))*Slope) + ! Estimate the streamfunction at each interface [H L2 T-1 ~> m3 s-1 or kg s-1]. + Sfn_unlim_u(I,K) = -(KH_u(I,j,K)*G%dy_Cu(I,j))*Slope ! Avoid moving dense water upslope from below the level of ! the bottom on the receiving side. @@ -968,14 +1082,14 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (present_slope_x) then Slope = slope_x(I,j,k) else - Slope = ((e(i,j,K)-e(i+1,j,K))*G%IdxCu(I,j)) * G%mask2dCu(I,j) + Slope = (e(i+1,j,K)-e(i,j,K)) * G%IdxCu_OBCmask(I,j) endif if (CS%id_slope_x > 0) CS%diagSlopeX(I,j,k) = Slope - Sfn_unlim_u(I,K) = ((KH_u(I,j,K)*G%dy_Cu(I,j))*Slope) - hN2_u(I,K) = GV%g_prime(K) + Sfn_unlim_u(I,K) = -(KH_u(I,j,K)*G%dy_Cu(I,j))*Slope + dzN2_u(I,K) = GV%g_prime(K) endif ! if (use_EOS) else ! if (k > nk_linear) - hN2_u(I,K) = N2_floor * dz_neglect + dzN2_u(I,K) = N2_floor * dz_neglect Sfn_unlim_u(I,K) = 0. endif ! if (k > nk_linear) if (CS%id_sfn_unlim_x>0) diag_sfn_unlim_x(I,j,K) = Sfn_unlim_u(I,K) @@ -983,20 +1097,19 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV enddo ! k-loop if (CS%use_FGNV_streamfn) then - do k=1,nz ; do I=is-1,ie ; if (G%mask2dCu(I,j)>0.) then - h_harm = max( h_neglect, & - 2. * h(i,j,k) * h(i+1,j,k) / ( ( h(i,j,k) + h(i+1,j,k) ) + h_neglect ) ) - c2_h_u(I,k) = CS%FGNV_scale * & - ( 0.5*( cg1(i,j) + cg1(i+1,j) ) )**2 / (GV%H_to_Z*h_harm) + do k=1,nz ; do I=is-1,ie ; if (G%OBCmaskCu(I,j)>0.) then + dz_harm = max( dz_neglect, & + 2. * dz(i,j,k) * dz(i+1,j,k) / ( ( dz(i,j,k) + dz(i+1,j,k) ) + dz_neglect ) ) + c2_dz_u(I,k) = CS%FGNV_scale * ( 0.5*( cg1(i,j) + cg1(i+1,j) ) )**2 / dz_harm endif ; enddo ; enddo ! Solve an elliptic equation for the streamfunction following Ferrari et al., 2010. do I=is-1,ie - if (G%mask2dCu(I,j)>0.) then + if (G%OBCmaskCu(I,j)>0.) then do K=2,nz Sfn_unlim_u(I,K) = (1. + CS%FGNV_scale) * Sfn_unlim_u(I,K) enddo - call streamfn_solver(nz, c2_h_u(I,:), hN2_u(I,:), Sfn_unlim_u(I,:)) + call streamfn_solver(nz, c2_dz_u(I,:), dzN2_u(I,:), Sfn_unlim_u(I,:)) else do K=2,nz Sfn_unlim_u(I,K) = 0. @@ -1007,25 +1120,36 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV do K=nz,2,-1 do I=is-1,ie + + if (allocated(tv%SpV_avg) .and. (find_work .or. (k > nk_linear)) ) then + Rho_avg = ( ((h(i,j,k) + h(i,j,k-1)) + (h(i+1,j,k) + h(i+1,j,k-1))) + 4.0*hn_2 ) / & + ( (((h(i,j,k)+hn_2) * tv%SpV_avg(i,j,k)) + ((h(i,j,k-1)+hn_2) * tv%SpV_avg(i,j,k-1))) + & + (((h(i+1,j,k)+hn_2)*tv%SpV_avg(i+1,j,k)) + ((h(i+1,j,k-1)+hn_2)*tv%SpV_avg(i+1,j,k-1))) ) + ! Use an average density to convert the volume streamfunction estimate into a mass streamfunction. + Z_to_H = GV%RZ_to_H*Rho_avg + else + Z_to_H = GV%Z_to_H + endif + if (k > nk_linear) then if (use_EOS) then if (uhtot(I,j) <= 0.0) then ! The transport that must balance the transport below is positive. - Sfn_safe = uhtot(I,j) * (1.0 - h_frac(i,j,k)) * GV%H_to_Z + Sfn_safe = uhtot(I,j) * (1.0 - h_frac(i,j,k)) else ! (uhtot(I,j) > 0.0) - Sfn_safe = uhtot(I,j) * (1.0 - h_frac(i+1,j,k)) * GV%H_to_Z + Sfn_safe = uhtot(I,j) * (1.0 - h_frac(i+1,j,k)) endif - ! The actual streamfunction at each interface. - Sfn_est = (Sfn_unlim_u(I,K) + slope2_Ratio_u(I,K)*Sfn_safe) / (1.0 + slope2_Ratio_u(I,K)) - else ! With .not.use_EOS, the layers are constant density. - Sfn_est = Sfn_unlim_u(I,K) + ! Determine the actual streamfunction at each interface. + Sfn_est = (Z_to_H*Sfn_unlim_u(I,K) + slope2_Ratio_u(I,K)*Sfn_safe) / (1.0 + slope2_Ratio_u(I,K)) + else ! When use_EOS is false, the layers are constant density. + Sfn_est = Z_to_H*Sfn_unlim_u(I,K) endif ! Make sure that there is enough mass above to allow the streamfunction ! to satisfy the boundary condition of 0 at the surface. - Sfn_in_H = min(max(Sfn_est * GV%Z_to_H, -h_avail_rsum(i,j,K)), h_avail_rsum(i+1,j,K)) + Sfn_in_H = min(max(Sfn_est, -h_avail_rsum(i,j,K)), h_avail_rsum(i+1,j,K)) ! The actual transport is limited by the mass available in the two ! neighboring grid cells. @@ -1056,6 +1180,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! else ! sfn_slope_x(I,j,K) = sfn_slope_x(I,j,K+1) * (1.0 - h_frac(i+1,j,k)) ! endif + endif uhtot(I,j) = uhtot(I,j) + uhD(I,j,k) @@ -1064,9 +1189,15 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! This is the energy tendency based on the original profiles, and does ! not include any nonlinear terms due to a finite time step (which would ! involve interactions between the fluxes through the different faces. - ! A second order centered estimate is used for the density transfered + ! A second order centered estimate is used for the density transferred ! between water columns. + if (allocated(tv%SpV_avg)) then + G_scale = GV%H_to_RZ * GV%g_Earth / Rho_avg + else + G_scale = GV%g_Earth * GV%H_to_Z + endif + Work_u(I,j) = Work_u(I,j) + G_scale * & ( uhtot(I,j) * drdkDe_u(I,K) - & (uhD(I,j,k) * drdi_u(I,k)) * 0.25 * & @@ -1077,21 +1208,22 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV enddo ! end of k-loop enddo ! end of j-loop - ! Calculate the meridional fluxes and gradients. - EOSdom_v(:) = EOS_domain(G%HI) -!$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S, & -!$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect,I_slope_max2, & -!$OMP h_neglect2,int_slope_v,KH_v,vhtot,h_frac,h_avail_rsum, & -!$OMP vhD,h_avail,G_scale,Work_v,CS,slope_y,cg1,diag_sfn_y, & -!$OMP diag_sfn_unlim_y,N2_floor,EOSdom_v,use_stanley,Tsgs2, & -!$OMP present_slope_y,G_rho0,Slope_y_PE,hN2_y_PE) & -!$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & -!$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & -!$OMP drho_dT_dT_v,scrap, & -!$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & -!$OMP drdy,mag_grad2,Slope,slope2_Ratio_v,hN2_v, & -!$OMP Sfn_unlim_v,drdj_v,drdkDe_v,h_harm,c2_h_v, & -!$OMP Sfn_safe,Sfn_est,Sfn_in_h,calc_derivatives) + ! Calculate the meridional fluxes and gradients. + + !$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S,dz, & + !$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect,dz_neglect2, & + !$OMP h_neglect2,int_slope_v,KH_v,vhtot,h_frac,h_avail_rsum, & + !$OMP I_slope_max2,vhD,h_avail,Work_v,CS,slope_y,cg1,hn_2,& + !$OMP diag_sfn_y,diag_sfn_unlim_y,N2_floor,EOSdom_v,use_stanley,& + !$OMP present_slope_y,G_rho0,Slope_y_PE,hN2_y_PE) & + !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v,S_h,S_hr, & + !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA,G_scale, & + !$OMP drho_dT_dT_h,drho_dT_dT_hr,scrap,pres_h,T_h,T_hr, & + !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz,pres_hr, & + !$OMP dzg2A,dzg2B,dzaA,dzaB,dz_harm,Z_to_H, & + !$OMP drdy,mag_grad2,Slope,slope2_Ratio_v,dzN2_v,N2_unlim, & + !$OMP Sfn_unlim_v,Rho_avg,drdj_v,drdkDe_v,c2_dz_v, & + !$OMP Sfn_safe,Sfn_est,Sfn_in_h,calc_derivatives) do J=js-1,je do K=nz,2,-1 if (find_work .and. .not.(use_EOS)) then @@ -1100,7 +1232,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV endif calc_derivatives = use_EOS .and. (k >= nk_linear) .and. & - (find_work .or. .not. present_slope_y .or. CS%use_FGNV_streamfn .or. use_Stanley) + (find_work .or. .not. present_slope_y .or. CS%use_FGNV_streamfn .or. use_stanley) if (calc_derivatives) then do i=is,ie @@ -1111,12 +1243,25 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, & tv%eqn_of_state, EOSdom_v) endif - if (use_Stanley) then + if (use_stanley) then + do i=is,ie + pres_h(i) = pres(i,j,K) + T_h(i) = 0.5*(T(i,j,k) + T(i,j,k-1)) + S_h(i) = 0.5*(S(i,j,k) + S(i,j,k-1)) + + pres_hr(i) = pres(i,j+1,K) + T_hr(i) = 0.5*(T(i,j+1,k) + T(i,j+1,k-1)) + S_hr(i) = 0.5*(S(i,j+1,k) + S(i,j+1,k-1)) + enddo + ! The second line below would correspond to arguments ! drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & - call calculate_density_second_derivs(T_v, S_v, pres_v, & - scrap, scrap, drho_dT_dT_v, scrap, scrap, & - is, ie-is+1, tv%eqn_of_state) + call calculate_density_second_derivs(T_h, S_h, pres_h, & + scrap, scrap, drho_dT_dT_h, scrap, scrap, & + tv%eqn_of_state, EOSdom_v) + call calculate_density_second_derivs(T_hr, S_hr, pres_hr, & + scrap, scrap, drho_dT_dT_hr, scrap, scrap, & + tv%eqn_of_state, EOSdom_v) endif do i=is,ie if (calc_derivatives) then @@ -1131,15 +1276,17 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV drho_dS_v(i) * (S(i,j,k)-S(i,j,k-1))) drdkR = (drho_dT_v(i) * (T(i,j+1,k)-T(i,j+1,k-1)) + & drho_dS_v(i) * (S(i,j+1,k)-S(i,j+1,k-1))) - drdkDe_v(i,K) = drdkR * e(i,j+1,K) - drdkL * e(i,j,K) + drdkDe_v(i,K) = (drdkR * e(i,j+1,K)) - (drdkL * e(i,j,K)) elseif (find_work) then ! This is used in pure stacked SW mode - drdkDe_v(i,K) = drdkR * e(i,j+1,K) - drdkL * e(i,j,K) + drdkDe_v(i,K) = (drdkR * e(i,j+1,K)) - (drdkL * e(i,j,K)) endif - if (use_Stanley) then + if (use_stanley) then ! Correction to the horizontal density gradient due to nonlinearity in ! the EOS rectifying SGS temperature anomalies - drdjA = drdjA + drho_dT_dT_v(I) * 0.5 * ( Tsgs2(i,j+1,k-1)-Tsgs2(i,j,k-1) ) - drdjB = drdjB + drho_dT_dT_v(I) * 0.5 * ( Tsgs2(i,j+1,k)-Tsgs2(i,j,k) ) + drdjA = drdjA + 0.5 * ((drho_dT_dT_hr(i) * tv%varT(i,j+1,k-1)) - & + (drho_dT_dT_h(i) * tv%varT(i,j,k-1)) ) + drdjB = drdjB + 0.5 * ((drho_dT_dT_hr(i) * tv%varT(i,j+1,k)) - & + (drho_dT_dT_h(i) * tv%varT(i,j,k)) ) endif if (find_work) drdj_v(i,k) = drdjB @@ -1151,17 +1298,21 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV hg2R = h(i,j+1,k-1)*h(i,j+1,k) + h_neglect2 haL = 0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect haR = 0.5*(h(i,j+1,k-1) + h(i,j+1,k)) + h_neglect + if (GV%Boussinesq) then dzaL = haL * GV%H_to_Z ; dzaR = haR * GV%H_to_Z - else + elseif (GV%semi_Boussinesq) then dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect dzaR = 0.5*(e(i,j+1,K-1) - e(i,j+1,K+1)) + dz_neglect + else + dzaL = 0.5*(dz(i,j,k-1) + dz(i,j,k)) + dz_neglect + dzaR = 0.5*(dz(i,j+1,k-1) + dz(i,j+1,k)) + dz_neglect endif ! Use the harmonic mean thicknesses to weight the horizontal gradients. ! These unnormalized weights have been rearranged to minimize divisions. wtL = hg2L*(haR*dzaR) ; wtR = hg2R*(haL*dzaL) - drdz = (wtL * drdkL + wtR * drdkR) / (dzaL*wtL + dzaR*wtR) + drdz = ((wtL * drdkL) + (wtR * drdkR)) / ((dzaL*wtL) + (dzaR*wtR)) ! The expression for drdz above is mathematically equivalent to: ! drdz = ((hg2L/haL) * drdkL/dzaL + (hg2R/haR) * drdkR/dzaR) / & ! ((hg2L/haL) + (hg2R/haR)) @@ -1170,9 +1321,22 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV haA = 0.5*(h(i,j,k-1) + h(i,j+1,k-1)) + h_neglect haB = 0.5*(h(i,j,k) + h(i,j+1,k)) + h_neglect - ! hN2_v is used with the FGNV streamfunction formulation - hN2_v(i,K) = (0.5 * GV%H_to_Z * ( hg2A / haA + hg2B / haB )) * & - max(drdz*G_rho0, N2_floor) + if (GV%Boussinesq) then + N2_unlim = drdz*G_rho0 + else + N2_unlim = (GV%g_Earth*GV%RZ_to_H) * & + (((wtL * drdkL) + (wtR * drdkR)) / ((haL*wtL) + (haR*wtR))) + endif + + dzg2A = dz(i,j,k-1)*dz(i,j+1,k-1) + dz_neglect2 + dzg2B = dz(i,j,k)*dz(i,j+1,k) + dz_neglect2 + dzaA = 0.5*(dz(i,j,k-1) + dz(i,j+1,k-1)) + dz_neglect + dzaB = 0.5*(dz(i,j,k) + dz(i,j+1,k)) + dz_neglect + + ! dzN2_v is used with the FGNV streamfunction formulation + dzN2_v(i,K) = (0.5*( dzg2A / dzaA + dzg2B / dzaB )) * max(N2_unlim, N2_floor) + if (find_work .and. CS%GM_src_alt) & + hN2_y_PE(i,J,k) = (0.5*( hg2A / haA + hg2B / haB )) * max(N2_unlim, N2_floor) endif if (present_slope_y) then Slope = slope_y(i,J,k) @@ -1203,11 +1367,15 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV int_slope_v(i,J,K) * ((e(i,j+1,K)-e(i,j,K)) * G%IdyCv(i,J)) slope2_Ratio_v(i,K) = (1.0 - int_slope_v(i,J,K)) * slope2_Ratio_v(i,K) - Slope_y_PE(i,J,k) = MIN(Slope,CS%slope_max) - hN2_y_PE(i,J,k) = hN2_v(i,K) + if (CS%MEKE_src_slope_bug) then + Slope_y_PE(i,J,k) = MIN(Slope, CS%slope_max) + else + Slope_y_PE(i,J,k) = Slope + if (Slope > CS%slope_max) Slope_y_PE(i,J,k) = CS%slope_max + if (Slope < -CS%slope_max) Slope_y_PE(i,J,k) = -CS%slope_max + endif if (CS%id_slope_y > 0) CS%diagSlopeY(I,j,k) = Slope - ! Estimate the streamfunction at each interface [Z L2 T-1 ~> m3 s-1]. Sfn_unlim_v(i,K) = -((KH_v(i,J,K)*G%dx_Cv(i,J))*Slope) ! Avoid moving dense water upslope from below the level of @@ -1234,14 +1402,14 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (present_slope_y) then Slope = slope_y(i,J,k) else - Slope = ((e(i,j,K)-e(i,j+1,K))*G%IdyCv(i,J)) * G%mask2dCv(i,J) + Slope = (e(i,j+1,K)-e(i,j,K)) * G%IdyCv_OBCmask(i,J) endif if (CS%id_slope_y > 0) CS%diagSlopeY(I,j,k) = Slope - Sfn_unlim_v(i,K) = ((KH_v(i,J,K)*G%dx_Cv(i,J))*Slope) - hN2_v(i,K) = GV%g_prime(K) + Sfn_unlim_v(i,K) = -((KH_v(i,J,K)*G%dx_Cv(i,J))*Slope) + dzN2_v(i,K) = GV%g_prime(K) endif ! if (use_EOS) else ! if (k > nk_linear) - hN2_v(i,K) = N2_floor * dz_neglect + dzN2_v(i,K) = N2_floor * dz_neglect Sfn_unlim_v(i,K) = 0. endif ! if (k > nk_linear) if (CS%id_sfn_unlim_y>0) diag_sfn_unlim_y(i,J,K) = Sfn_unlim_v(i,K) @@ -1249,20 +1417,19 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV enddo ! k-loop if (CS%use_FGNV_streamfn) then - do k=1,nz ; do i=is,ie ; if (G%mask2dCv(i,J)>0.) then - h_harm = max( h_neglect, & - 2. * h(i,j,k) * h(i,j+1,k) / ( ( h(i,j,k) + h(i,j+1,k) ) + h_neglect ) ) - c2_h_v(i,k) = CS%FGNV_scale * & - ( 0.5*( cg1(i,j) + cg1(i,j+1) ) )**2 / (GV%H_to_Z*h_harm) + do k=1,nz ; do i=is,ie ; if (G%OBCmaskCv(i,J)>0.) then + dz_harm = max( dz_neglect, & + 2. * dz(i,j,k) * dz(i,j+1,k) / ( ( dz(i,j,k) + dz(i,j+1,k) ) + dz_neglect ) ) + c2_dz_v(i,k) = CS%FGNV_scale * ( 0.5*( cg1(i,j) + cg1(i,j+1) ) )**2 / dz_harm endif ; enddo ; enddo ! Solve an elliptic equation for the streamfunction following Ferrari et al., 2010. do i=is,ie - if (G%mask2dCv(i,J)>0.) then + if (G%OBCmaskCv(i,J)>0.) then do K=2,nz Sfn_unlim_v(i,K) = (1. + CS%FGNV_scale) * Sfn_unlim_v(i,K) enddo - call streamfn_solver(nz, c2_h_v(i,:), hN2_v(i,:), Sfn_unlim_v(i,:)) + call streamfn_solver(nz, c2_dz_v(i,:), dzN2_v(i,:), Sfn_unlim_v(i,:)) else do K=2,nz Sfn_unlim_v(i,K) = 0. @@ -1273,25 +1440,35 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV do K=nz,2,-1 do i=is,ie + if (allocated(tv%SpV_avg) .and. (find_work .or. (k > nk_linear)) ) then + Rho_avg = ( ((h(i,j,k) + h(i,j,k-1)) + (h(i,j+1,k) + h(i,j+1,k-1))) + 4.0*hn_2 ) / & + ( (((h(i,j,k)+hn_2) * tv%SpV_avg(i,j,k)) + ((h(i,j,k-1)+hn_2) * tv%SpV_avg(i,j,k-1))) + & + (((h(i,j+1,k)+hn_2)*tv%SpV_avg(i,j+1,k)) + ((h(i,j+1,k-1)+hn_2)*tv%SpV_avg(i,j+1,k-1))) ) + ! Use an average density to convert the volume streamfunction estimate into a mass streamfunction. + Z_to_H = GV%RZ_to_H*Rho_avg + else + Z_to_H = GV%Z_to_H + endif + if (k > nk_linear) then if (use_EOS) then if (vhtot(i,J) <= 0.0) then ! The transport that must balance the transport below is positive. - Sfn_safe = vhtot(i,J) * (1.0 - h_frac(i,j,k)) * GV%H_to_Z + Sfn_safe = vhtot(i,J) * (1.0 - h_frac(i,j,k)) else ! (vhtot(I,j) > 0.0) - Sfn_safe = vhtot(i,J) * (1.0 - h_frac(i,j+1,k)) * GV%H_to_Z + Sfn_safe = vhtot(i,J) * (1.0 - h_frac(i,j+1,k)) endif - ! The actual streamfunction at each interface. - Sfn_est = (Sfn_unlim_v(i,K) + slope2_Ratio_v(i,K)*Sfn_safe) / (1.0 + slope2_Ratio_v(i,K)) - else ! With .not.use_EOS, the layers are constant density. - Sfn_est = Sfn_unlim_v(i,K) + ! Find the actual streamfunction at each interface. + Sfn_est = (Z_to_H*Sfn_unlim_v(i,K) + slope2_Ratio_v(i,K)*Sfn_safe) / (1.0 + slope2_Ratio_v(i,K)) + else ! When use_EOS is false, the layers are constant density. + Sfn_est = Z_to_H*Sfn_unlim_v(i,K) endif ! Make sure that there is enough mass above to allow the streamfunction ! to satisfy the boundary condition of 0 at the surface. - Sfn_in_H = min(max(Sfn_est * GV%Z_to_H, -h_avail_rsum(i,j,K)), h_avail_rsum(i,j+1,K)) + Sfn_in_H = min(max(Sfn_est, -h_avail_rsum(i,j,K)), h_avail_rsum(i,j+1,K)) ! The actual transport is limited by the mass available in the two ! neighboring grid cells. @@ -1329,9 +1506,15 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! This is the energy tendency based on the original profiles, and does ! not include any nonlinear terms due to a finite time step (which would ! involve interactions between the fluxes through the different faces. - ! A second order centered estimate is used for the density transfered + ! A second order centered estimate is used for the density transferred ! between water columns. + if (allocated(tv%SpV_avg)) then + G_scale = GV%H_to_RZ * GV%g_Earth / Rho_avg + else + G_scale = GV%g_Earth * GV%H_to_Z + endif + Work_v(i,J) = Work_v(i,J) + G_scale * & ( vhtot(i,J) * drdkDe_v(i,K) - & (vhD(i,J,k) * drdj_v(i,k)) * 0.25 * & @@ -1348,7 +1531,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV do J=js-1,je ; do i=is,ie ; vhD(i,J,1) = -vhtot(i,J) ; enddo ; enddo else EOSdom_u(1) = (is-1) - (G%IsdB-1) ; EOSdom_u(2) = ie - (G%IsdB-1) - !$OMP parallel do default(shared) private(pres_u,T_u,S_u,drho_dT_u,drho_dS_u,drdiB) + !$OMP parallel do default(shared) private(pres_u,T_u,S_u,drho_dT_u,drho_dS_u,drdiB,G_scale) do j=js,je if (use_EOS) then do I=is-1,ie @@ -1362,9 +1545,15 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV do I=is-1,ie uhD(I,j,1) = -uhtot(I,j) + G_scale = GV%g_Earth * GV%H_to_Z if (use_EOS) then drdiB = drho_dT_u(I) * (T(i+1,j,1)-T(i,j,1)) + & drho_dS_u(I) * (S(i+1,j,1)-S(i,j,1)) + if (allocated(tv%SpV_avg)) then + G_scale = GV%H_to_RZ * GV%g_Earth * & + ( ( ((h(i,j,1)+hn_2) * tv%SpV_avg(i,j,1)) + ((h(i+1,j,1)+hn_2) * tv%SpV_avg(i+1,j,1)) ) / & + ( (h(i,j,1) + h(i+1,j,1)) + 2.0*hn_2 ) ) + endif endif if (CS%use_GM_work_bug) then Work_u(I,j) = Work_u(I,j) + G_scale * & @@ -1379,7 +1568,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV enddo EOSdom_v(:) = EOS_domain(G%HI) - !$OMP parallel do default(shared) private(pres_v,T_v,S_v,drho_dT_v,drho_dS_v,drdjB) + !$OMP parallel do default(shared) private(pres_v,T_v,S_v,drho_dT_v,drho_dS_v,drdjB,G_scale) do J=js-1,je if (use_EOS) then do i=is,ie @@ -1393,9 +1582,15 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV do i=is,ie vhD(i,J,1) = -vhtot(i,J) + G_scale = GV%g_Earth * GV%H_to_Z if (use_EOS) then drdjB = drho_dT_v(i) * (T(i,j+1,1)-T(i,j,1)) + & drho_dS_v(i) * (S(i,j+1,1)-S(i,j,1)) + if (allocated(tv%SpV_avg)) then + G_scale = GV%H_to_RZ * GV%g_Earth * & + ( ( ((h(i,j,1)+hn_2) * tv%SpV_avg(i,j,1)) + ((h(i,j+1,1)+hn_2) * tv%SpV_avg(i,j+1,1)) ) / & + ( (h(i,j,1) + h(i,j+1,1)) + 2.0*hn_2 ) ) + endif endif Work_v(i,J) = Work_v(i,J) - G_scale * & ( (vhD(i,J,1) * drdjB) * 0.25 * & @@ -1405,23 +1600,61 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV endif if (find_work) then ; do j=js,je ; do i=is,ie - ! Note that the units of Work_v and Work_u are W, while Work_h is W m-2. + ! Note that the units of Work_v and Work_u are [R Z L4 T-3 ~> W], while Work_h is in [R Z L2 T-3 ~> W m-2]. Work_h = 0.5 * G%IareaT(i,j) * & ((Work_u(I-1,j) + Work_u(I,j)) + (Work_v(i,J-1) + Work_v(i,J))) if (allocated(CS%GMwork)) CS%GMwork(i,j) = Work_h if (.not. CS%GM_src_alt) then ; if (allocated(MEKE%GM_src)) then MEKE%GM_src(i,j) = MEKE%GM_src(i,j) + Work_h endif ; endif + if (skeb_use_gm) then + skeb_gm_work(i,j) = STOCH%skeb_gm_coef * Work_h + skeb_ebt_norm2(i,j) = 0.0 + do k=1,nz + skeb_ebt_norm2(i,j) = skeb_ebt_norm2(i,j) + h(i,j,k) * VarMix%ebt_struct(i,j,k)**2 + enddo + skeb_ebt_norm2(i,j) = GV%H_to_RZ * (skeb_ebt_norm2(i,j) + h_neglect) + endif enddo ; enddo ; endif - if (find_work .and. CS%GM_src_alt) then ; if (allocated(MEKE%GM_src)) then - do j=js,je ; do i=is,ie ; do k=nz,1,-1 - PE_release_h = -0.25*(KH_u(I,j,k)*(Slope_x_PE(I,j,k)**2) * hN2_x_PE(I,j,k) + & - Kh_u(I-1,j,k)*(Slope_x_PE(I-1,j,k)**2) * hN2_x_PE(I-1,j,k) + & - Kh_v(i,J,k)*(Slope_y_PE(i,J,k)**2) * hN2_y_PE(i,J,k) + & - Kh_v(i,J-1,k)*(Slope_y_PE(i,J-1,k)**2) * hN2_y_PE(i,J-1,k)) - MEKE%GM_src(i,j) = MEKE%GM_src(i,j) + US%L_to_Z**2 * GV%Rho0 * PE_release_h + if (skeb_use_gm) then + ! This block spreads the GM work down through the column using the ebt vertical structure, squared. + ! Note the sign convention. + do k=1,nz ; do j=js,je ; do i=is,ie + STOCH%skeb_diss(i,j,k) = STOCH%skeb_diss(i,j,k) - skeb_gm_work(i,j) * & + VarMix%ebt_struct(i,j,k)**2 / skeb_ebt_norm2(i,j) enddo ; enddo ; enddo + endif + + if (find_work .and. CS%GM_src_alt) then ; if (allocated(MEKE%GM_src)) then + if (CS%MEKE_src_answer_date >= 20240601) then + do j=js,je ; do i=is,ie ; do k=nz,1,-1 + PE_release_h = -0.25 * GV%H_to_RZ * & + ( ((KH_u(I,j,k)*(Slope_x_PE(I,j,k)**2) * hN2_x_PE(I,j,k)) + & + (Kh_u(I-1,j,k)*(Slope_x_PE(I-1,j,k)**2) * hN2_x_PE(I-1,j,k))) + & + ((Kh_v(i,J,k)*(Slope_y_PE(i,J,k)**2) * hN2_y_PE(i,J,k)) + & + (Kh_v(i,J-1,k)*(Slope_y_PE(i,J-1,k)**2) * hN2_y_PE(i,J-1,k))) ) + MEKE%GM_src(i,j) = MEKE%GM_src(i,j) + PE_release_h + enddo ; enddo ; enddo + else + do j=js,je ; do i=is,ie ; do k=nz,1,-1 + PE_release_h = -0.25 * GV%H_to_RZ * & + ((KH_u(I,j,k)*(Slope_x_PE(I,j,k)**2) * hN2_x_PE(I,j,k)) + & + (Kh_u(I-1,j,k)*(Slope_x_PE(I-1,j,k)**2) * hN2_x_PE(I-1,j,k)) + & + (Kh_v(i,J,k)*(Slope_y_PE(i,J,k)**2) * hN2_y_PE(i,J,k)) + & + (Kh_v(i,J-1,k)*(Slope_y_PE(i,J-1,k)**2) * hN2_y_PE(i,J-1,k))) + MEKE%GM_src(i,j) = MEKE%GM_src(i,j) + PE_release_h + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(MEKE%GM_src, 'MEKE%GM_src', G%HI, unscale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + call uvchksum("KH_[uv]", Kh_u, Kh_v, G%HI, unscale=US%L_to_m**2*US%s_to_T, & + scalar_pair=.true.) + call uvchksum("Slope_[xy]_PE", Slope_x_PE, Slope_y_PE, G%HI, unscale=US%Z_to_L) + call uvchksum("hN2_[xy]_PE", hN2_x_PE, hN2_y_PE, G%HI, unscale=GV%H_to_mks*US%L_to_Z**2*US%s_to_T**2, & + scalar_pair=.true.) + endif endif ; endif if (CS%id_slope_x > 0) call post_data(CS%id_slope_x, CS%diagSlopeX, CS%diag) @@ -1436,16 +1669,20 @@ end subroutine thickness_diffuse_full !> Tridiagonal solver for streamfunction at interfaces subroutine streamfn_solver(nk, c2_h, hN2, sfn) integer, intent(in) :: nk !< Number of layers - real, dimension(nk), intent(in) :: c2_h !< Wave speed squared over thickness in layers [L2 Z-1 T-2 ~> m s-2] - real, dimension(nk+1), intent(in) :: hN2 !< Thickness times N2 at interfaces [L2 Z-1 T-2 ~> m s-2] - real, dimension(nk+1), intent(inout) :: sfn !< Streamfunction [Z L2 T-1 ~> m3 s-1] or arbitrary units + real, dimension(nk), intent(in) :: c2_h !< Wave speed squared over thickness in layers, rescaled to + !! [H L2 Z-2 T-2 ~> m s-2 or kg m-2 s-2] + real, dimension(nk+1), intent(in) :: hN2 !< Thickness times N2 at interfaces times rescaling factors + !! [H L2 Z-2 T-2 ~> m s-2 or kg m-2 s-2] + real, dimension(nk+1), intent(inout) :: sfn !< Streamfunction [H L2 T-1 ~> m3 s-1 or kg s-1] or arbitrary units !! On entry, equals diffusivity times slope. !! On exit, equals the streamfunction. ! Local variables + real :: c1(nk) ! The dependence of the final streamfunction on the values below [nondim] + real :: d1 ! The complement of c1(k) (i.e., 1 - c1(k)) [nondim] + real :: b_denom ! A term in the denominator of beta [H L2 Z-2 T-2 ~> m s-2 or kg m-2 s-2] + real :: beta ! The normalization for the pivot [Z2 T2 H-1 L-2 ~> s2 m-1 or m2 s2 kg-1] integer :: k - real :: b_denom, beta, d1, c1(nk) - sfn(1) = 0. b_denom = hN2(2) + c2_h(1) beta = 1.0 / ( b_denom + c2_h(2) ) @@ -1466,7 +1703,49 @@ subroutine streamfn_solver(nk, c2_h, hN2, sfn) end subroutine streamfn_solver -!> Modifies thickness diffusivities to untangle layer structures +!> Add a diffusivity that acts on the isopycnal heights, regardless of the densities +subroutine add_interface_Kh(G, GV, US, CS, Kh_u, Kh_v, Kh_u_CFL, Kh_v_CFL, int_slope_u, int_slope_v) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thickness_diffuse_CS), intent(in) :: CS !< Control structure for thickness_diffuse + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kh_u !< Isopycnal height diffusivity + !! at u points [L2 T-1 ~> m2 s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: Kh_v !< Isopycnal height diffusivity + !! at v points [L2 T-1 ~> m2 s-1] + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Kh_u_CFL !< Maximum stable isopycnal height + !! diffusivity at u points [L2 T-1 ~> m2 s-1] + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Kh_v_CFL !< Maximum stable isopycnal height + !! diffusivity at v points [L2 T-1 ~> m2 s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: int_slope_u !< Ratio that determine how much of + !! the isopycnal slopes are taken directly from + !! the interface slopes without consideration + !! of density gradients [nondim]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: int_slope_v !< Ratio that determine how much of + !! the isopycnal slopes are taken directly from + !! the interface slopes without consideration + !! of density gradients [nondim]. + + ! Local variables + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + do k=1,nz+1 ; do j=js,je ; do I=is-1,ie ; if (CS%Kh_eta_u(I,j) > 0.0) then + int_slope_u(I,j,K) = (int_slope_u(I,j,K)*Kh_u(I,j,K) + CS%Kh_eta_u(I,j)) / & + (Kh_u(I,j,K) + CS%Kh_eta_u(I,j)) + Kh_u(I,j,K) = min(Kh_u(I,j,K) + CS%Kh_eta_u(I,j), Kh_u_CFL(I,j)) + endif ; enddo ; enddo ; enddo + + do k=1,nz+1 ; do J=js-1,je ; do i=is,ie ; if (CS%Kh_eta_v(i,J) > 0.0) then + int_slope_v(i,J,K) = (int_slope_v(i,J,K)*Kh_v(i,J,K) + CS%Kh_eta_v(i,J)) / & + (Kh_v(i,J,K) + CS%Kh_eta_v(i,J)) + Kh_v(i,J,K) = min(Kh_v(i,J,K) + CS%Kh_eta_v(i,J), Kh_v_CFL(i,J)) + endif ; enddo ; enddo ; enddo + +end subroutine add_interface_Kh + +!> Modifies isopycnal height diffusivities to untangle layer structures subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV, US, CS, & int_slope_u, int_slope_v) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure @@ -1474,34 +1753,34 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV 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] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface positions [Z ~> m] - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kh_u !< Thickness diffusivity on interfaces + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kh_u !< Isopycnal height diffusivity !! at u points [L2 T-1 ~> m2 s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: Kh_v !< Thickness diffusivity on interfaces - !! at v points [L2 T-1 ~> m2 s-1] - real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Kh_u_CFL !< Maximum stable thickness diffusivity - !! at u points [L2 T-1 ~> m2 s-1] - real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Kh_v_CFL !< Maximum stable thickness diffusivity + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: Kh_v !< Isopycnal height diffusivity !! at v points [L2 T-1 ~> m2 s-1] + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Kh_u_CFL !< Maximum stable isopycnal height + !! diffusivity at u points [L2 T-1 ~> m2 s-1] + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Kh_v_CFL !< Maximum stable isopycnal height + !! diffusivity at v points [L2 T-1 ~> m2 s-1] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure real, intent(in) :: dt !< Time increment [T ~> s] - type(thickness_diffuse_CS), intent(in) :: CS !< Control structure for thickness diffusion + type(thickness_diffuse_CS), intent(in) :: CS !< Control structure for thickness_diffuse real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: int_slope_u !< Ratio that determine how much of !! the isopycnal slopes are taken directly from !! the interface slopes without consideration - !! of density gradients. + !! of density gradients [nondim]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: int_slope_v !< Ratio that determine how much of !! the isopycnal slopes are taken directly from !! the interface slopes without consideration - !! of density gradients. + !! of density gradients [nondim]. ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & de_top ! The distances between the top of a layer and the top of the ! region where the detangling is applied [H ~> m or kg m-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & - Kh_lay_u ! The tentative interface height diffusivity for each layer at + Kh_lay_u ! The tentative isopycnal height diffusivity for each layer at ! u points [L2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & - Kh_lay_v ! The tentative interface height diffusivity for each layer at + Kh_lay_v ! The tentative isopycnal height diffusivity for each layer at ! v points [L2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G)) :: & de_bot ! The distances from the bottom of the region where the @@ -1510,7 +1789,7 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV ! with the thinner modified near the boundaries to mask out ! thickness variations due to topography, etc. real :: jag_Rat ! The nondimensional jaggedness ratio for a layer, going - ! from 0 (smooth) to 1 (jagged). This is the difference + ! from 0 (smooth) to 1 (jagged) [nondim]. This is the difference ! between the arithmetic and harmonic mean thicknesses ! normalized by the arithmetic mean thickness. real :: Kh_scale ! A ratio by which Kh_u_CFL is scaled for maximally jagged @@ -1527,20 +1806,22 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV ! and the ratio of the face length to the adjacent cell ! areas for comparability with the diffusivities [L Z T-1 ~> m2 s-1]. real :: adH ! The absolute value of dH [L Z T-1 ~> m2 s-1]. - real :: sign ! 1 or -1, with the same sign as the layer thickness gradient. + real :: sign ! 1 or -1, with the same sign as the layer thickness gradient [nondim]. real :: sl_K ! The sign-corrected slope of the interface above [Z L-1 ~> nondim]. real :: sl_Kp1 ! The sign-corrected slope of the interface below [Z L-1 ~> nondim]. real :: I_sl_K ! The (limited) inverse of sl_K [L Z-1 ~> nondim]. real :: I_sl_Kp1 ! The (limited) inverse of sl_Kp1 [L Z-1 ~> nondim]. real :: I_4t ! A quarter of a flux scaling factor divided by ! the damping timescale [T-1 ~> s-1]. - real :: Fn_R ! A function of Rsl, such that Rsl < Fn_R < 1. - real :: denom, I_denom ! A denominator and its inverse, various units. + real :: Fn_R ! A function of Rsl, such that Rsl < Fn_R < 1 [nondim] + real :: Idx_eff ! The effective inverse x-grid spacing at a u-point [L-1 ~> m-1] + real :: Idy_eff ! The effective inverse y-grid spacing at a v-point [L-1 ~> m-1] + real :: slope_sq ! The sum of the squared slopes above and below a layer [Z2 L-2 ~> nondim] real :: Kh_max ! A local ceiling on the diffusivity [L2 T-1 ~> m2 s-1]. - real :: wt1, wt2 ! Nondimensional weights. + real :: wt1, wt2 ! Nondimensional weights [nondim]. ! Variables used only in testing code. - ! real, dimension(SZK_(GV)) :: uh_here - ! real, dimension(SZK_(GV)+1) :: Sfn + ! real, dimension(SZK_(GV)) :: uh_here ! The transport in a layer [Z L2 T-1 ~> m3 s-1] + ! real, dimension(SZK_(GV)+1) :: Sfn ! The streamfunction at an interface [Z L T-1 ~> m2 s-1] real :: dKh ! An increment in the diffusivity [L2 T-1 ~> m2 s-1]. real, dimension(SZIB_(G),SZK_(GV)+1) :: & @@ -1567,7 +1848,7 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV Kh_max_p , & ! See above [nondim]. Kh0_max_p ! See above [L2 T-1 ~> m2 s-1]. real, dimension(SZIB_(G)) :: & - Kh_max_max ! The maximum diffusivity permitted in a column [L2 T-1 ~> m2 s-1].. + Kh_max_max ! The maximum diffusivity permitted in a column [L2 T-1 ~> m2 s-1] logical, dimension(SZIB_(G)) :: & do_i ! If true, work on a column. integer :: i, j, k, n, ish, jsh, is, ie, js, je, nz, k_top @@ -1601,7 +1882,7 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV de_bot(i,j) = de_bot(i,j) + h(i,j,k+1) enddo ; enddo - do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.0) then + do j=js,je ; do I=is-1,ie ; if (G%OBCmaskCu(I,j) > 0.0) then if (h(i,j,k) > h(i+1,j,k)) then h2 = h(i,j,k) h1 = max( h(i+1,j,k), h2 - min(de_bot(i+1,j), de_top(i+1,j,k)) ) @@ -1613,7 +1894,7 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV KH_lay_u(I,j,k) = (Kh_scale * KH_u_CFL(I,j)) * jag_Rat**2 endif ; enddo ; enddo - do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then + do J=js-1,je ; do i=is,ie ; if (G%OBCmaskCv(i,J) > 0.0) then if (h(i,j,k) > h(i,j+1,k)) then h2 = h(i,j,k) h1 = max( h(i,j+1,k), h2 - min(de_bot(i,j+1), de_top(i,j+1,k)) ) @@ -1639,7 +1920,7 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV ! First, populate the diffusivities if (n==1) then ! This is a u-column. do i=ish,ie - do_i(I) = (G%mask2dCu(I,j) > 0.0) + do_i(I) = (G%OBCmaskCu(I,j) > 0.0) Kh_Max_max(I) = KH_u_CFL(I,j) enddo do K=1,nz+1 ; do i=ish,ie @@ -1649,7 +1930,7 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV enddo ; enddo else ! This is a v-column. do i=ish,ie - do_i(i) = (G%mask2dCv(i,J) > 0.0) ; Kh_Max_max(I) = KH_v_CFL(i,J) + do_i(i) = (G%OBCmaskCv(i,J) > 0.0) ; Kh_Max_max(I) = KH_v_CFL(i,J) enddo do K=1,nz+1 ; do i=ish,ie Kh_bg(I,K) = KH_v(I,j,K) ; Kh(I,K) = Kh_bg(I,K) @@ -1662,49 +1943,49 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV do k=k_top,nz ; do i=ish,ie ; if (do_i(i)) then if (n==1) then ! This is a u-column. dH = 0.0 - denom = ((G%IareaT(i+1,j) + G%IareaT(i,j)) * G%dy_Cu(I,j)) + Idx_eff = ((G%IareaT(i+1,j) + G%IareaT(i,j)) * G%dy_Cu(I,j)) ! This expression uses differences in e in place of h for better ! consistency with the slopes. - if (denom > 0.0) & + if (Idx_eff > 0.0) & dH = I_4t * ((e(i+1,j,K) - e(i+1,j,K+1)) - & - (e(i,j,K) - e(i,j,K+1))) / denom - ! dH = I_4t * (h(i+1,j,k) - h(i,j,k)) / denom + (e(i,j,K) - e(i,j,K+1))) / Idx_eff + ! dH = I_4t * (h(i+1,j,k) - h(i,j,k)) / Idx_eff adH = abs(dH) sign = 1.0 ; if (dH < 0) sign = -1.0 sl_K = sign * (e(i+1,j,K)-e(i,j,K)) * G%IdxCu(I,j) sl_Kp1 = sign * (e(i+1,j,K+1)-e(i,j,K+1)) * G%IdxCu(I,j) - ! Add the incremental diffusivites to the surrounding interfaces. + ! Add the incremental diffusivities to the surrounding interfaces. ! Adding more to the more steeply sloping layers (as below) makes ! the diffusivities more than twice as effective. - denom = (sl_K**2 + sl_Kp1**2) + slope_sq = (sl_K**2 + sl_Kp1**2) wt1 = 0.5 ; wt2 = 0.5 - if (denom > 0.0) then - wt1 = sl_K**2 / denom ; wt2 = sl_Kp1**2 / denom + if (slope_sq > 0.0) then + wt1 = sl_K**2 / slope_sq ; wt2 = sl_Kp1**2 / slope_sq endif Kh_detangle(I,K) = Kh_detangle(I,K) + wt1*KH_lay_u(I,j,k) Kh_detangle(I,K+1) = Kh_detangle(I,K+1) + wt2*KH_lay_u(I,j,k) else ! This is a v-column. dH = 0.0 - denom = ((G%IareaT(i,j+1) + G%IareaT(i,j)) * G%dx_Cv(I,j)) - if (denom > 0.0) & + Idy_eff = ((G%IareaT(i,j+1) + G%IareaT(i,j)) * G%dx_Cv(I,j)) + if (Idy_eff > 0.0) & dH = I_4t * ((e(i,j+1,K) - e(i,j+1,K+1)) - & - (e(i,j,K) - e(i,j,K+1))) / denom - ! dH = I_4t * (h(i,j+1,k) - h(i,j,k)) / denom + (e(i,j,K) - e(i,j,K+1))) / Idy_eff + ! dH = I_4t * (h(i,j+1,k) - h(i,j,k)) / Idy_eff adH = abs(dH) sign = 1.0 ; if (dH < 0) sign = -1.0 sl_K = sign * (e(i,j+1,K)-e(i,j,K)) * G%IdyCv(i,J) sl_Kp1 = sign * (e(i,j+1,K+1)-e(i,j,K+1)) * G%IdyCv(i,J) - ! Add the incremental diffusviites to the surrounding interfaces. + ! Add the incremental diffusivities to the surrounding interfaces. ! Adding more to the more steeply sloping layers (as below) makes ! the diffusivities more than twice as effective. - denom = (sl_K**2 + sl_Kp1**2) + slope_sq = (sl_K**2 + sl_Kp1**2) wt1 = 0.5 ; wt2 = 0.5 - if (denom > 0.0) then - wt1 = sl_K**2 / denom ; wt2 = sl_Kp1**2 / denom + if (slope_sq > 0.0) then + wt1 = sl_K**2 / slope_sq ; wt2 = sl_Kp1**2 / slope_sq endif Kh_detangle(I,K) = Kh_detangle(I,K) + wt1*KH_lay_v(i,J,k) Kh_detangle(I,K+1) = Kh_detangle(I,K+1) + wt2*KH_lay_v(i,J,k) @@ -1784,7 +2065,7 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV ! Kh(I,K) <= Kh_max_m(I,K)*Kh(I,K-1) + Kh0_max_m(I,K) ! Kh(I,K) <= Kh_max_p(I,K)*Kh(I,K+1) + Kh0_max_p(I,K) - ! Increase the diffusivies to satisfy the min constraints. + ! Increase the diffusivities to satisfy the min constraints. ! All non-zero min constraints on one diffusivity are max constraints on another. do K=k_top+1,nz ; do i=ish,ie ; if (do_i(i)) then Kh(I,K) = max(Kh_bg(I,K), Kh_detangle(I,K), & @@ -1881,7 +2162,7 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV end subroutine add_detangling_Kh -!> Initialize the thickness diffusion module/structure +!> Initialize the isopycnal height diffusion module and its control structure subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) type(time_type), intent(in) :: Time !< Current model time type(ocean_grid_type), intent(in) :: G !< Ocean grid structure @@ -1890,16 +2171,27 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) type(param_file_type), intent(in) :: param_file !< Parameter file handles type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(cont_diag_ptrs), intent(inout) :: CDp !< Continuity equation diagnostics - type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness diffusion + type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness_diffuse -! This include declares and sets the variable "version". -#include "version_variable.h" + ! Local variables character(len=40) :: mdl = "MOM_thickness_diffuse" ! This module's name. + character(len=200) :: khth_file, inputdir, khth_varname + ! This include declares and sets the variable "version". +# include "version_variable.h" + real :: grid_sp ! The local grid spacing [L ~> m] real :: omega ! The Earth's rotation rate [T-1 ~> s-1] - real :: strat_floor ! A floor for Brunt-Vasaila frequency in the Ferrari et al. 2010, + real :: strat_floor ! A floor for buoyancy frequency in the Ferrari et al. 2010, ! streamfunction formulation, expressed as a fraction of planetary - ! rotation [nondim]. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. + ! rotation divided by an aspect ratio rescaling factor [L Z-1 ~> nondim] + real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale + ! temperature variance [nondim] + logical :: khth_use_ebt_struct ! If true, uses the equivalent barotropic structure + ! as the vertical structure of thickness diffusivity. + ! Used to determine if FULL_DEPTH_KHTH_MIN should be + ! available. + logical :: use_meke = .false. ! If true, use the MEKE formulation for the thickness diffusivity. + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + integer :: i, j CS%initialized = .true. CS%diag => diag @@ -1912,13 +2204,49 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) call get_param(param_file, mdl, "KHTH", CS%Khth, & "The background horizontal thickness diffusivity.", & default=0.0, units="m2 s-1", scale=US%m_to_L**2*US%T_to_s) + call get_param(param_file, mdl, "READ_KHTH", CS%read_khth, & + "If true, read a file (given by KHTH_FILE) containing the "//& + "spatially varying horizontal isopycnal height diffusivity.", & + default=.false.) + if (CS%read_khth) then + if (CS%Khth > 0) then + call MOM_error(FATAL, "thickness_diffuse_init: KHTH > 0 is not "// & + "compatible with READ_KHTH = TRUE. ") + endif + call get_param(param_file, mdl, "INPUTDIR", inputdir, & + "The directory in which all input files are found.", & + default=".", do_not_log=.true.) + inputdir = slasher(inputdir) + call get_param(param_file, mdl, "KHTH_FILE", khth_file, & + "The file containing the spatially varying horizontal "//& + "isopycnal height diffusivity.", default="khth.nc") + call get_param(param_file, mdl, "KHTH_VARIABLE", khth_varname, & + "The name of the isopycnal height diffusivity variable to read "//& + "from KHTH_FILE.", & + default="khth") + khth_file = trim(inputdir) // trim(khth_file) + + allocate(CS%khth2d(G%isd:G%ied, G%jsd:G%jed), source=0.0) + call MOM_read_data(khth_file, khth_varname, CS%khth2d(:,:), G%domain, scale=US%m_to_L**2*US%T_to_s) + call pass_var(CS%khth2d, G%domain) + endif call get_param(param_file, mdl, "KHTH_SLOPE_CFF", CS%KHTH_Slope_Cff, & - "The nondimensional coefficient in the Visbeck formula "//& - "for the interface depth diffusivity", units="nondim", & - default=0.0) + "The nondimensional coefficient in the Visbeck formula for "//& + "the interface depth diffusivity", units="nondim", default=0.0) call get_param(param_file, mdl, "KHTH_MIN", CS%KHTH_Min, & "The minimum horizontal thickness diffusivity.", & default=0.0, units="m2 s-1", scale=US%m_to_L**2*US%T_to_s) + call get_param(param_file, mdl, "KHTH_USE_EBT_STRUCT", khth_use_ebt_struct, & + "If true, uses the equivalent barotropic structure "//& + "as the vertical structure of thickness diffusivity.",& + default=.false., do_not_log=.true.) + if (khth_use_ebt_struct .and. CS%KHTH_Min>0.0) then + call get_param(param_file, mdl, "FULL_DEPTH_KHTH_MIN", CS%full_depth_khth_min, & + "If true, KHTH_MIN is enforced throughout the whole water column. "//& + "Otherwise, KHTH_MIN is only enforced at the surface. This parameter "//& + "is only available when KHTH_USE_EBT_STRUCT=True and KHTH_MIN>0.", & + default=.false.) + endif call get_param(param_file, mdl, "KHTH_MAX", CS%KHTH_Max, & "The maximum horizontal thickness diffusivity.", & default=0.0, units="m2 s-1", scale=US%m_to_L**2*US%T_to_s) @@ -1927,11 +2255,32 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) "is permitted for the thickness diffusivity. 1.0 is the "//& "marginally unstable value in a pure layered model, but "//& "much smaller numbers (e.g. 0.1) seem to work better for "//& - "ALE-based models.", units = "nondimensional", default=0.8) + "ALE-based models.", units="nondimensional", default=0.8) -! call get_param(param_file, mdl, "USE_QG_LEITH_GM", CS%QG_Leith_GM, & -! "If true, use the QG Leith viscosity as the GM coefficient.", & -! default=.false.) + call get_param(param_file, mdl, "KH_ETA_CONST", CS%Kh_eta_bg, & + "The background horizontal diffusivity of the interface heights (without "//& + "considering the layer density structure). If diffusive CFL limits are "//& + "encountered, the diffusivities of the isopycnals and the interfaces heights "//& + "are scaled back proportionately.", & + default=0.0, units="m2 s-1", scale=US%m_to_L**2*US%T_to_s) + call get_param(param_file, mdl, "KH_ETA_VEL_SCALE", CS%Kh_eta_vel, & + "A velocity scale that is multiplied by the grid spacing to give a contribution "//& + "to the horizontal diffusivity of the interface heights (without considering "//& + "the layer density structure).", & + default=0.0, units="m s-1", scale=US%m_to_L*US%T_to_s) + + if ((CS%Kh_eta_bg > 0.0) .or. (CS%Kh_eta_vel > 0.0)) then + allocate(CS%Kh_eta_u(G%IsdB:G%IedB, G%jsd:G%jed), source=0.) + allocate(CS%Kh_eta_v(G%isd:G%ied, G%JsdB:G%JedB), source=0.) + do j=G%jsc,G%jec ; do I=G%isc-1,G%iec + grid_sp = sqrt((2.0*G%dxCu(I,j)**2 * G%dyCu(I,j)**2) / ((G%dxCu(I,j)**2) + (G%dyCu(I,j)**2))) + CS%Kh_eta_u(I,j) = G%OBCmaskCu(I,j) * MAX(0.0, CS%Kh_eta_bg + CS%Kh_eta_vel * grid_sp) + enddo ; enddo + do J=G%jsc-1,G%jec ; do i=G%isc,G%iec + grid_sp = sqrt((2.0*G%dxCv(i,J)**2 * G%dyCv(i,J)**2) / ((G%dxCv(i,J)**2) + (G%dyCv(i,J)**2))) + CS%Kh_eta_v(i,J) = G%OBCmaskCv(i,J) * MAX(0.0, CS%Kh_eta_bg + CS%Kh_eta_vel * grid_sp) + enddo ; enddo + endif if (CS%max_Khth_CFL < 0.0) CS%max_Khth_CFL = 0.0 call get_param(param_file, mdl, "DETANGLE_INTERFACES", CS%detangle_interfaces, & @@ -1950,7 +2299,7 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_smooth, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & - units="m2 s-1", default=1.0e-6, scale=US%m_to_Z**2*US%T_to_s) + units="m2 s-1", default=1.0e-6, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "KHTH_USE_FGNV_STREAMFUNCTION", CS%use_FGNV_streamfn, & "If true, use the streamfunction formulation of "//& "Ferrari et al., 2010, which effectively emphasizes "//& @@ -1968,11 +2317,17 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) "A floor for Brunt-Vasaila frequency in the Ferrari et al., 2010, "//& "streamfunction formulation, expressed as a fraction of planetary "//& "rotation, OMEGA. This should be tiny but non-zero to avoid degeneracy.", & - default=1.e-15, units="nondim", do_not_log=.not.CS%use_FGNV_streamfn) - call get_param(param_file, mdl, "STANLEY_PRM_DET_COEFF", CS%Stanley_det_coeff, & - "The coefficient correlating SGS temperature variance with the mean "//& - "temperature gradient in the deterministic part of the Stanley parameterization. "//& - "Negative values disable the scheme.", units="nondim", default=-1.0) + default=1.e-15, units="nondim", scale=US%Z_to_L, do_not_log=.not.CS%use_FGNV_streamfn) + call get_param(param_file, mdl, "USE_STANLEY_GM", CS%use_stanley_gm, & + "If true, turn on Stanley SGS T variance parameterization "// & + "in GM code.", default=.false.) + if (CS%use_stanley_gm) then + call get_param(param_file, mdl, "STANLEY_COEFF", Stanley_coeff, & + "Coefficient correlating the temperature gradient and SGS T variance.", & + units="nondim", default=-1.0, do_not_log=.true.) + if (Stanley_coeff < 0.0) call MOM_error(FATAL, & + "STANLEY_COEFF must be set >= 0 if USE_STANLEY_GM is true.") + endif call get_param(param_file, mdl, "OMEGA", omega, & "The rotation rate of the earth.", & default=7.2921e-5, units="s-1", scale=US%T_to_s, do_not_log=.not.CS%use_FGNV_streamfn) @@ -1982,9 +2337,25 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231, do_not_log=.true.) + call get_param(param_file, mdl, "MEKE_GM_SRC_ALT", CS%GM_src_alt, & "If true, use the GM energy conversion form S^2*N^2*kappa rather "//& "than the streamfunction for the GM source term.", default=.false.) + call get_param(param_file, mdl, "MEKE_GM_SRC_ANSWER_DATE", CS%MEKE_src_answer_date, & + "The vintage of the expressions in the GM energy conversion calculation when "//& + "MEKE_GM_SRC_ALT is true. Values below 20240601 recover the answers from the "//& + "original implementation, while higher values use expressions that satisfy "//& + "rotational symmetry.", & + default=default_answer_date, do_not_log=.not.CS%GM_src_alt) + call get_param(param_file, mdl, "MEKE_GM_SRC_ALT_SLOPE_BUG", CS%MEKE_src_slope_bug, & + "If true, use a bug that limits the positive values, but not the negative values, "//& + "of the slopes used when MEKE_GM_SRC_ALT is true. When this is true, it breaks "//& + "all of the symmetry rules that MOM6 is supposed to obey.", & + default=.false., do_not_log=.not.CS%GM_src_alt) + call get_param(param_file, mdl, "MEKE_GEOMETRIC", CS%MEKE_GEOMETRIC, & "If true, uses the GM coefficient formulation from the GEOMETRIC "//& "framework (Marshall et al., 2012).", default=.false.) @@ -1996,18 +2367,24 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) "The nondimensional coefficient governing the efficiency of the GEOMETRIC "//& "thickness diffusion.", units="nondim", default=0.05) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) - call get_param(param_file, mdl, "MEKE_GEOMETRIC_2018_ANSWERS", CS%MEKE_GEOM_answers_2018, & - "If true, use expressions in the MEKE_GEOMETRIC calculation that recover the "//& - "answers from the original implementation. Otherwise, use expressions that "//& - "satisfy rotational symmetry.", default=default_2018_answers) + call get_param(param_file, mdl, "MEKE_GEOMETRIC_ANSWER_DATE", CS%MEKE_GEOM_answer_date, & + "The vintage of the expressions in the MEKE_GEOMETRIC calculation. "//& + "Values below 20190101 recover the answers from the original implementation, "//& + "while higher values use expressions that satisfy rotational symmetry.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%MEKE_GEOM_answer_date = max(CS%MEKE_GEOM_answer_date, 20230701) endif - call get_param(param_file, mdl, "USE_KH_IN_MEKE", CS%Use_KH_in_MEKE, & - "If true, uses the thickness diffusivity calculated here to diffuse MEKE.", & - default=.false.) + call get_param(param_file, mdl, "USE_MEKE", use_meke, default=.false., do_not_log=.true.) + if (use_meke) then + call get_param(param_file, mdl, "USE_KH_IN_MEKE", CS%Use_KH_in_MEKE, & + "If true, uses the thickness diffusivity calculated here to diffuse MEKE.", & + default=.false.) + call get_param(param_file, mdl, "MEKE_MIN_DEPTH_DIFF", CS%MEKE_min_depth_diff, & + "The minimum total depth over which to average the diffusivity used for MEKE. "//& + "When the total depth is less than this, the diffusivity is scaled away.", & + units="m", default=1.0, scale=GV%m_to_H, do_not_log=.not.CS%Use_KH_in_MEKE) + endif call get_param(param_file, mdl, "USE_GME", CS%use_GME_thickness_diffuse, & "If true, use the GM+E backscatter scheme in association "//& @@ -2090,14 +2467,14 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) end subroutine thickness_diffuse_init -!> Copies ubtav and vbtav from private type into arrays +!> Copies KH_u_GME and KH_v_GME from private type into arrays provided as arguments subroutine thickness_diffuse_get_KH(CS, KH_u_GME, KH_v_GME, G, GV) type(thickness_diffuse_CS), intent(in) :: CS !< Control structure for this module type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: KH_u_GME !< interface height + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: KH_u_GME !< Isopycnal height !! diffusivities at u-faces [L2 T-1 ~> m2 s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: KH_v_GME !< interface height + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: KH_v_GME !< Isopycnal height !! diffusivities at v-faces [L2 T-1 ~> m2 s-1] ! Local variables integer :: i,j,k @@ -2112,9 +2489,9 @@ subroutine thickness_diffuse_get_KH(CS, KH_u_GME, KH_v_GME, G, GV) end subroutine thickness_diffuse_get_KH -!> Deallocate the thickness diffusion control structure +!> Deallocate the thickness_diffus3 control structure subroutine thickness_diffuse_end(CS, CDp) - type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness diffusion + type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness_diffuse type(cont_diag_ptrs), intent(inout) :: CDp !< Continuity diagnostic control structure if (CS%id_slope_x > 0) deallocate(CS%diagSlopeX) @@ -2130,13 +2507,15 @@ subroutine thickness_diffuse_end(CS, CDp) deallocate(CS%KH_u_GME) deallocate(CS%KH_v_GME) endif + + if (allocated(CS%khth2d)) deallocate(CS%khth2d) end subroutine thickness_diffuse_end !> \namespace mom_thickness_diffuse !! -!! \section section_gm Thickness diffusion (aka Gent-McWilliams) +!! \section section_gm Isopycnal height diffusion (aka Gent-McWilliams) !! -!! Thickness diffusion is implemented via along-layer mass fluxes +!! Isopycnal height diffusion is implemented via along-layer mass fluxes !! \f[ !! h^\dagger \leftarrow h^n - \Delta t \nabla \cdot ( \vec{uh}^* ) !! \f] @@ -2146,37 +2525,38 @@ end subroutine thickness_diffuse_end !! \vec{uh}^* = \delta_k \vec{\psi} . !! \f] !! -!! The GM implementation of thickness diffusion made the streamfunction proportional to the potential density slope +!! The GM implementation of isopycnal height diffusion made the streamfunction proportional +!! to the potential density slope !! \f[ !! \vec{\psi} = - \kappa_h \frac{\nabla_z \rho}{\partial_z \rho} -!! = \frac{g\kappa_h}{\rho_o} \frac{\nabla \rho}{N^2} = \kappa_h \frac{M^2}{N^2} +!! = \frac{g\kappa_h}{\rho_o} \frac{\nabla \rho}{N^2} = -\kappa_h \frac{M^2}{N^2} !! \f] !! but for robustness the scheme is implemented as !! \f[ -!! \vec{\psi} = \kappa_h \frac{M^2}{\sqrt{N^4 + M^4}} +!! \vec{\psi} = -\kappa_h \frac{M^2}{\sqrt{N^4 + M^4}} !! \f] -!! since the quantity \f$\frac{M^2}{\sqrt{N^2 + M^2}}\f$ is bounded between $-1$ and $1$ and does not change sign +!! since the quantity \f$\frac{M^2}{\sqrt{N^4 + M^4}}\f$ is bounded between $-1$ and $1$ and does not change sign !! if \f$N^2<0\f$. !! -!! Optionally, the method of Ferrari et al, 2010, can be used to obtain the streamfunction which solves the +!! Optionally, the method of \cite ferrari2010, can be used to obtain the streamfunction which solves the !! vertically elliptic equation: !! \f[ -!! \gamma_F \partial_z c^2 \partial_z \psi - N_*^2 \psi = ( 1 + \gamma_F ) \kappa_h N_*^2 \frac{M^2}{\sqrt{N^4+M^4}} +!! \gamma_F \partial_z c^2 \partial_z \psi - N_*^2 \psi = -( 1 + \gamma_F ) \kappa_h N_*^2 \frac{M^2}{\sqrt{N^4+M^4}} !! \f] !! which recovers the previous streamfunction relation in the limit that \f$ c \rightarrow 0 \f$. !! Here, \f$c=\max(c_{min},c_g)\f$ is the maximum of either \f$c_{min}\f$ and either the first baroclinic mode !! wave-speed or the equivalent barotropic mode wave-speed. -!! \f$N_*^2 = \max(N^2,0)\f$ is a non-negative form of the square of the Brunt-Vaisala frequency. +!! \f$N_*^2 = \max(N^2,0)\f$ is a non-negative form of the square of the buoyancy frequency. !! The parameter \f$\gamma_F\f$ is used to reduce the vertical smoothing length scale. !! \f[ !! \kappa_h = \left( \kappa_o + \alpha_{s} L_{s}^2 < S N > + \alpha_{M} \kappa_{M} \right) r(\Delta x,L_d) !! \f] -!! where \f$ S \f$ is the isoneutral slope magnitude, \f$ N \f$ is the square root of Brunt-Vaisala frequency, +!! where \f$ S \f$ is the isoneutral slope magnitude, \f$ N \f$ is the buoyancy frequency, !! \f$\kappa_{M}\f$ is the diffusivity calculated by the MEKE parameterization (mom_meke module) and !! \f$ r(\Delta x,L_d) \f$ is a function of the local resolution (ratio of grid-spacing, \f$\Delta x\f$, !! to deformation radius, \f$L_d\f$). The length \f$L_s\f$ is provided by the mom_lateral_mixing_coeffs module !! (enabled with USE_VARIABLE_MIXING=True and the term \f$\f$ is the vertical average slope -!! times the Brunt-Vaisala frequency prescribed by Visbeck et al., 1996. +!! times the buoyancy frequency prescribed by \cite visbeck1996. !! !! The result of the above expression is subsequently bounded by minimum and maximum values, including an upper !! diffusivity consistent with numerical stability (\f$ \kappa_{cfl} \f$ is calculated internally). @@ -2220,7 +2600,7 @@ end subroutine thickness_diffuse_end !! A boundary-value problem for the parameterized mesoscale eddy transport. !! Ocean Modelling, 32, 143-156. http://doi.org/10.1016/j.ocemod.2010.01.004 !! -!! Viscbeck, M., J.C. Marshall, H. Jones, 1996: +!! Visbeck, M., J.C. Marshall, H. Jones, 1996: !! Dynamics of isolated convective regions in the ocean. J. Phys. Oceangr., 26, 1721-1734. !! http://dx.doi.org/10.1175/1520-0485(1996)026%3C1721:DOICRI%3E2.0.CO;2 diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index cc4517a473..473a1eaf63 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -1,22 +1,24 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Tidal contributions to geopotential module MOM_tidal_forcing -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, & - CLOCK_MODULE + CLOCK_MODULE, CLOCK_ROUTINE use MOM_domains, only : pass_var use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_io, only : field_exists, file_exists, MOM_read_data -use MOM_time_manager, only : set_date, time_type, time_type_to_real, operator(-) +use MOM_time_manager, only : set_date, time_type, time_minus_signed use MOM_unit_scaling, only : unit_scale_type implicit none ; private public calc_tidal_forcing, tidal_forcing_init, tidal_forcing_end -public tidal_forcing_sensitivity +public calc_tidal_forcing_legacy ! MOM_open_boundary uses the following to set tides on the boundary. public astro_longitudes_init, eq_phase, nodal_fu, tidal_frequency @@ -26,32 +28,29 @@ module MOM_tidal_forcing !! constituents that could be used. !> Simple type to store astronomical longitudes used to calculate tidal phases. type, public :: astro_longitudes - real :: & - s, & !< Mean longitude of moon [rad] - h, & !< Mean longitude of sun [rad] - p, & !< Mean longitude of lunar perigee [rad] - N !< Longitude of ascending node [rad] + real :: s !< Mean longitude of moon [rad] + real :: h !< Mean longitude of sun [rad] + real :: p !< Mean longitude of lunar perigee [rad] + real :: N !< Longitude of ascending node [rad] end type astro_longitudes !> The control structure for the MOM_tidal_forcing module type, public :: tidal_forcing_CS ; private - logical :: use_sal_scalar !< If true, use the scalar approximation when - !! calculating self-attraction and loading. - logical :: tidal_sal_from_file !< If true, Read the tidal self-attraction + logical :: use_tidal_sal_file !< If true, Read the tidal self-attraction !! and loading from input files, specified !! by TIDAL_INPUT_FILE. - logical :: use_prev_tides !< If true, use the SAL from the previous + logical :: use_tidal_sal_prev !< If true, use the SAL from the previous !! iteration of the tides to facilitate convergence. logical :: use_eq_phase !< If true, tidal forcing is phase-shifted to match !! equilibrium tide. Set to false if providing tidal phases !! that have already been shifted by the !! astronomical/equilibrium argument. - real :: sal_scalar !< The constant of proportionality between sea surface - !! height (really it should be bottom pressure) anomalies - !! and bottom geopotential anomalies [nondim]. + real :: sal_scalar = 0.0 !< The constant of proportionality between self-attraction and + !! loading (SAL) geopotential anomaly and total geopotential geopotential + !! anomalies. This is only used if USE_PREVIOUS_TIDES is true. [nondim]. integer :: nc !< The number of tidal constituents in use. real, dimension(MAX_CONSTITUENTS) :: & - freq, & !< The frequency of a tidal constituent [T-1 ~> s-1]. + freq, & !< The frequency of a tidal constituent [rad T-1 ~> rad s-1]. phase0, & !< The phase of a tidal constituent at time 0 [rad]. amp, & !< The amplitude of a tidal constituent at time 0 [Z ~> m]. love_no !< The Love number of a tidal constituent at time 0 [nondim]. @@ -62,14 +61,18 @@ module MOM_tidal_forcing type(astro_longitudes) :: tidal_longitudes !< Astronomical longitudes used to calculate !! tidal phases at t = 0. real, allocatable :: & - sin_struct(:,:,:), & !< The sine and cosine based structures that can - cos_struct(:,:,:), & !< be associated with the astronomical forcing [nondim]. - cosphasesal(:,:,:), & !< The cosine and sine of the phase of the - sinphasesal(:,:,:), & !< self-attraction and loading amphidromes. + sin_struct(:,:,:), & !< The sine based structures that can be associated with + !! the astronomical forcing [nondim]. + cos_struct(:,:,:), & !< The cosine based structures that can be associated with + !! the astronomical forcing [nondim]. + cosphasesal(:,:,:), & !< The cosine of the phase of the self-attraction and loading amphidromes [nondim]. + sinphasesal(:,:,:), & !< The sine of the phase of the self-attraction and loading amphidromes [nondim]. ampsal(:,:,:), & !< The amplitude of the SAL [Z ~> m]. - cosphase_prev(:,:,:), & !< The cosine and sine of the phase of the - sinphase_prev(:,:,:), & !< amphidromes in the previous tidal solutions. - amp_prev(:,:,:) !< The amplitude of the previous tidal solution [Z ~> m]. + cosphase_prev(:,:,:), & !< The cosine of the phase of the amphidromes in the previous tidal solutions [nondim]. + sinphase_prev(:,:,:), & !< The sine of the phase of the amphidromes in the previous tidal solutions [nondim]. + amp_prev(:,:,:), & !< The amplitude of the previous tidal solution [Z ~> m]. + tide_fn(:), & !< Amplitude modulation of tides by nodal cycle [nondim]. + tide_un(:) !< Phase modulation of tides by nodal cycle [rad]. end type tidal_forcing_CS integer :: id_clock_tides !< CPU clock for tides @@ -84,15 +87,18 @@ module MOM_tidal_forcing !! (their Equation I.71), which are based on Schureman, 1958. !! For simplicity, the time associated with time_ref should !! be at midnight. These formulas also only make sense if -!! the calendar is gregorian. +!! the calendar is Gregorian. subroutine astro_longitudes_init(time_ref, longitudes) type(time_type), intent(in) :: time_ref !> Time to calculate longitudes for. type(astro_longitudes), intent(out) :: longitudes !> Lunar and solar longitudes at time_ref. + + ! Local variables real :: D !> Time since the reference date [days] real :: T !> Time in Julian centuries [centuries] real, parameter :: PI = 4.0 * atan(1.0) !> 3.14159... [nondim] - ! Find date at time_ref in days since 1900-01-01 - D = time_type_to_real(time_ref - set_date(1900, 1, 1)) / (24.0 * 3600.0) + + ! Find date at time_ref in days since midnight at the start of 1900-01-01 + D = time_minus_signed(time_ref, set_date(1900, 1, 1, 0, 0, 0)) / (24.0 * 3600.0) ! Time since 1900-01-01 in Julian centuries ! Kowalik and Luick use 36526, but Schureman uses 36525 which I think is correct. T = D / 36525.0 @@ -114,7 +120,7 @@ end subroutine astro_longitudes_init function eq_phase(constit, longitudes) character (len=2), intent(in) :: constit !> Name of constituent (e.g., M2). type(astro_longitudes), intent(in) :: longitudes !> Mean longitudes calculated using astro_longitudes_init - real, parameter :: PI = 4.0 * atan(1.0) !> 3.14159... + real, parameter :: PI = 4.0 * atan(1.0) !> 3.14159... [nondim] real :: eq_phase !> The equilibrium phase argument for the constituent [rad]. select case (constit) @@ -147,7 +153,7 @@ end function eq_phase !! Values used here are from previous versions of MOM. function tidal_frequency(constit) character (len=2), intent(in) :: constit !> Constituent to look up - real :: tidal_frequency !> Angular frequency [s-1] + real :: tidal_frequency !> Angular frequency [rad s-1] select case (constit) case ("M2") @@ -234,31 +240,35 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. - type(tidal_forcing_CS), intent(inout) :: CS !< Tidal forcing control struct + type(tidal_forcing_CS), intent(inout) :: CS !< Tidal forcing control structure ! Local variables real, dimension(SZI_(G), SZJ_(G)) :: & - phase, & ! The phase of some tidal constituent. - lat_rad, lon_rad ! Latitudes and longitudes of h-points in radians. - real :: deg_to_rad - real, dimension(MAX_CONSTITUENTS) :: freq_def ! Default frequency for each tidal constituent [s-1] + phase, & ! The phase of some tidal constituent [radians]. + lat_rad, lon_rad ! Latitudes and longitudes of h-points [radians]. + real :: deg_to_rad ! A conversion factor from degrees to radians [radian degree-1] + real, dimension(MAX_CONSTITUENTS) :: freq_def ! Default frequency for each tidal constituent [rad s-1] real, dimension(MAX_CONSTITUENTS) :: phase0_def ! Default reference phase for each tidal constituent [rad] real, dimension(MAX_CONSTITUENTS) :: amp_def ! Default amplitude for each tidal constituent [m] real, dimension(MAX_CONSTITUENTS) :: love_def ! Default love number for each constituent [nondim] integer, dimension(3) :: tide_ref_date !< Reference date (t = 0) for tidal forcing. - logical :: use_const ! True if a constituent is being used. + integer, dimension(3) :: nodal_ref_date !< Reference date for calculating nodal modulation for tidal forcing. logical :: use_M2, use_S2, use_N2, use_K2, use_K1, use_O1, use_P1, use_Q1 logical :: use_MF, use_MM logical :: tides ! True if a tidal forcing is to be used. - logical :: FAIL_IF_MISSING = .true. + logical :: add_nodal_terms = .false. !< If true, insert terms for the 18.6 year modulation when + !! calculating tidal forcing. + type(time_type) :: nodal_time !< Model time to calculate nodal modulation for. + type(astro_longitudes) :: nodal_longitudes !< Solar and lunar longitudes for tidal forcing ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_tidal_forcing" ! This module's name. character(len=128) :: mesg character(len=200) :: tidal_input_files(4*MAX_CONSTITUENTS) integer :: i, j, c, is, ie, js, je, isd, ied, jsd, jed, nc + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - isd = G%isd ; ied = G%ied ; jsd = G%jsd; jed = G%jed + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") @@ -341,60 +351,55 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) return endif - call get_param(param_file, mdl, "TIDAL_SAL_FROM_FILE", CS%tidal_sal_from_file, & + call get_param(param_file, mdl, "TIDAL_SAL_FROM_FILE", CS%use_tidal_sal_file, & "If true, read the tidal self-attraction and loading "//& "from input files, specified by TIDAL_INPUT_FILE. "//& "This is only used if TIDES is true.", default=.false.) - call get_param(param_file, mdl, "USE_PREVIOUS_TIDES", CS%use_prev_tides, & + call get_param(param_file, mdl, "USE_PREVIOUS_TIDES", CS%use_tidal_sal_prev, & "If true, use the SAL from the previous iteration of the "//& "tides to facilitate convergent iteration. "//& "This is only used if TIDES is true.", default=.false.) - call get_param(param_file, mdl, "TIDE_USE_SAL_SCALAR", CS%use_sal_scalar, & - "If true and TIDES is true, use the scalar approximation "//& - "when calculating self-attraction and loading.", & - default=.not.CS%tidal_sal_from_file) - ! If it is being used, sal_scalar MUST be specified in param_file. - if (CS%use_sal_scalar .or. CS%use_prev_tides) & - call get_param(param_file, mdl, "TIDE_SAL_SCALAR_VALUE", CS%sal_scalar, & - "The constant of proportionality between sea surface "//& - "height (really it should be bottom pressure) anomalies "//& - "and bottom geopotential anomalies. This is only used if "//& - "TIDES and TIDE_USE_SAL_SCALAR are true.", units="m m-1", & - fail_if_missing=.true.) + if (CS%use_tidal_sal_prev) & + call get_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar, "The constant of "//& + "proportionality between self-attraction and loading (SAL) geopotential "//& + "anomaly and barotropic geopotential anomalies. This is only used if "//& + "SAL_SCALAR_APPROX is true or USE_PREVIOUS_TIDES is true.", default=0.0, & + units="m m-1", do_not_log=(.not.CS%use_tidal_sal_prev), & + old_name='TIDE_SAL_SCALAR_VALUE') if (nc > MAX_CONSTITUENTS) then - write(mesg,'("Increase MAX_CONSTITUENTS in MOM_tidal_forcing.F90 to at least",I3, & - &"to accommodate all the registered tidal constituents.")') nc + write(mesg,'("Increase MAX_CONSTITUENTS in MOM_tidal_forcing.F90 to at least ",I0, & + &" to accommodate all the registered tidal constituents.")') nc call MOM_error(FATAL, "MOM_tidal_forcing"//mesg) endif do c=1,4*MAX_CONSTITUENTS ; tidal_input_files(c) = "" ; enddo - if (CS%tidal_sal_from_file .or. CS%use_prev_tides) then + if (CS%use_tidal_sal_file .or. CS%use_tidal_sal_prev) then call get_param(param_file, mdl, "TIDAL_INPUT_FILE", tidal_input_files, & "A list of input files for tidal information.", & - default = "", fail_if_missing=.true.) + default="", fail_if_missing=.true.) endif call get_param(param_file, mdl, "TIDE_REF_DATE", tide_ref_date, & "Year,month,day to use as reference date for tidal forcing. "//& "If not specified, defaults to 0.", & - default=0) + old_name="OBC_TIDE_REF_DATE", defaults=(/0, 0, 0/)) call get_param(param_file, mdl, "TIDE_USE_EQ_PHASE", CS%use_eq_phase, & "Correct phases by calculating equilibrium phase arguments for TIDE_REF_DATE. ", & - default=.false., fail_if_missing=.false.) + old_name="OBC_TIDE_ADD_EQ_PHASE", default=.false., fail_if_missing=.false.) if (sum(tide_ref_date) == 0) then ! tide_ref_date defaults to 0. - CS%time_ref = set_date(1, 1, 1) + CS%time_ref = set_date(1, 1, 1, 0, 0, 0) else - if(.not. CS%use_eq_phase) then + if (.not. CS%use_eq_phase) then ! Using a reference date but not using phase relative to equilibrium. ! This makes sense as long as either phases are overridden, or ! correctly simulating tidal phases is not desired. call MOM_mesg('Tidal phases will *not* be corrected with equilibrium arguments.') endif - CS%time_ref = set_date(tide_ref_date(1), tide_ref_date(2), tide_ref_date(3)) + CS%time_ref = set_date(tide_ref_date(1), tide_ref_date(2), tide_ref_date(3), 0, 0, 0) endif ! Initialize reference time for tides and find relevant lunar and solar @@ -474,7 +479,8 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) "Frequency of the "//trim(CS%const_name(c))//" tidal constituent. "//& "This is only used if TIDES and TIDE_"//trim(CS%const_name(c))// & " are true, or if OBC_TIDE_N_CONSTITUENTS > 0 and "//trim(CS%const_name(c))// & - " is in OBC_TIDE_CONSTITUENTS.", units="s-1", default=freq_def(c), scale=US%T_to_s) + " is in OBC_TIDE_CONSTITUENTS.", units="rad s-1", default=freq_def(c), & + scale=US%T_to_s) call get_param(param_file, mdl, "TIDE_"//trim(CS%const_name(c))//"_AMP", CS%amp(c), & "Amplitude of the "//trim(CS%const_name(c))//" tidal constituent. "//& "This is only used if TIDES and TIDE_"//trim(CS%const_name(c))// & @@ -485,7 +491,7 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) " are true.", units="radians", default=phase0_def(c)) enddo - if (CS%tidal_sal_from_file) then + if (CS%use_tidal_sal_file) then allocate(CS%cosphasesal(isd:ied,jsd:jed,nc)) allocate(CS%sinphasesal(isd:ied,jsd:jed,nc)) allocate(CS%ampsal(isd:ied,jsd:jed,nc)) @@ -503,7 +509,7 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) enddo endif - if (CS%USE_PREV_TIDES) then + if (CS%use_tidal_sal_prev) then allocate(CS%cosphase_prev(isd:ied,jsd:jed,nc)) allocate(CS%sinphase_prev(isd:ied,jsd:jed,nc)) allocate(CS%amp_prev(isd:ied,jsd:jed,nc)) @@ -521,6 +527,43 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) enddo endif + call get_param(param_file, mdl, "TIDE_ADD_NODAL", add_nodal_terms, & + "If true, include 18.6 year nodal modulation in the astronomical tidal forcing.", & + old_name="OBC_TIDE_ADD_NODAL", default=.false.) + call get_param(param_file, mdl, "TIDE_NODAL_REF_DATE", nodal_ref_date, & + "Fixed reference date to use for nodal modulation of astronomical tidal forcing.", & + old_name="OBC_TIDE_REF_DATE", fail_if_missing=.false., defaults=(/0, 0, 0/)) + + ! If the nodal correction is based on a different time, initialize that. + ! Otherwise, it can use N from the time reference. + if (add_nodal_terms) then + if (sum(nodal_ref_date) /= 0) then + ! A reference date was provided for the nodal correction + nodal_time = set_date(nodal_ref_date(1), nodal_ref_date(2), nodal_ref_date(3)) + call astro_longitudes_init(nodal_time, nodal_longitudes) + elseif (CS%use_eq_phase) then + ! Astronomical longitudes were already calculated for use in equilibrium phases, + ! so use nodal longitude from that. + nodal_longitudes = CS%tidal_longitudes + else + ! Tidal reference time is a required parameter, so calculate the longitudes from that. + call astro_longitudes_init(CS%time_ref, nodal_longitudes) + endif + endif + + allocate(CS%tide_fn(nc)) + allocate(CS%tide_un(nc)) + + do c=1,nc + ! Find nodal corrections if needed + if (add_nodal_terms) then + call nodal_fu(trim(CS%const_name(c)), nodal_longitudes%N, CS%tide_fn(c), CS%tide_un(c)) + else + CS%tide_fn(c) = 1.0 + CS%tide_un(c) = 0.0 + endif + enddo + id_clock_tides = cpu_clock_id('(Ocean tides)', grain=CLOCK_MODULE) end subroutine tidal_forcing_init @@ -531,8 +574,9 @@ subroutine find_in_files(filenames, varname, array, G, scale) character(len=*), dimension(:), intent(in) :: filenames !< The names of the files to search for the named variable character(len=*), intent(in) :: varname !< The name of the variable to read type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: array !< The array to fill with the data - real, optional, intent(in) :: scale !< A factor by which to rescale the array. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: array !< The array to fill with the data [arbitrary] + real, optional, intent(in) :: scale !< A factor by which to rescale the array to translate it + !! into its desired units [arbitrary] ! Local variables integer :: nf @@ -557,102 +601,153 @@ subroutine find_in_files(filenames, varname, array, G, scale) end subroutine find_in_files -!> This subroutine calculates returns the partial derivative of the local -!! geopotential height with the input sea surface height due to self-attraction -!! and loading. -subroutine tidal_forcing_sensitivity(G, CS, deta_tidal_deta) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(tidal_forcing_CS), intent(in) :: CS !< The control structure returned by a previous call to tidal_forcing_init. - real, intent(out) :: deta_tidal_deta !< The partial derivative of eta_tidal with - !! the local value of eta [nondim]. - - if (CS%USE_SAL_SCALAR .and. CS%USE_PREV_TIDES) then - deta_tidal_deta = 2.0*CS%SAL_SCALAR - elseif (CS%USE_SAL_SCALAR .or. CS%USE_PREV_TIDES) then - deta_tidal_deta = CS%SAL_SCALAR - else - deta_tidal_deta = 0.0 - endif -end subroutine tidal_forcing_sensitivity - !> This subroutine calculates the geopotential anomalies that drive the tides, -!! including self-attraction and loading. Optionally, it also returns the -!! partial derivative of the local geopotential height with the input sea surface -!! height. For now, eta and eta_tidal are both geopotential heights in depth -!! units, but probably the input for eta should really be replaced with the -!! column mass anomalies. -subroutine calc_tidal_forcing(Time, eta, eta_tidal, G, US, CS) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(time_type), intent(in) :: Time !< The time for the caluculation. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta !< The sea surface height anomaly from - !! a time-mean geoid [Z ~> m]. - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_tidal !< The tidal forcing geopotential height - !! anomalies [Z ~> m]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(tidal_forcing_CS), intent(in) :: CS !< The control structure returned by a - !! previous call to tidal_forcing_init. +!! including tidal self-attraction and loading from previous solutions. +subroutine calc_tidal_forcing(Time, e_tide_eq, e_tide_sal, G, US, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(time_type), intent(in) :: Time !< The time for the caluculation. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: e_tide_eq !< The geopotential height anomalies + !! due to the equilibrium tides [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: e_tide_sal !< The geopotential height anomalies + !! due to the tidal SAL [Z ~> m]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(tidal_forcing_CS), intent(in) :: CS !< The control structure returned by a + !! previous call to tidal_forcing_init. ! Local variables real :: now ! The relative time compared with the tidal reference [T ~> s] real :: amp_cosomegat, amp_sinomegat ! The tidal amplitudes times the components of phase [Z ~> m] real :: cosomegat, sinomegat ! The components of the phase [nondim] - real :: eta_prop ! The nondimenional constant of proportionality beteen eta and eta_tidal [nondim] integer :: i, j, c, m, is, ie, js, je, Isq, Ieq, Jsq, Jeq is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB call cpu_clock_begin(id_clock_tides) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_tide_eq(i,j) = 0.0 + e_tide_sal(i,j) = 0.0 + enddo ; enddo + if (CS%nc == 0) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 ; eta_tidal(i,j) = 0.0 ; enddo ; enddo return endif - now = US%s_to_T * time_type_to_real(Time - cs%time_ref) + now = time_minus_signed(Time, cs%time_ref, scale=US%s_to_T) - if (CS%USE_SAL_SCALAR .and. CS%USE_PREV_TIDES) then - eta_prop = 2.0*CS%SAL_SCALAR - elseif (CS%USE_SAL_SCALAR .or. CS%USE_PREV_TIDES) then - eta_prop = CS%SAL_SCALAR - else - eta_prop = 0.0 + do c=1,CS%nc + m = CS%struct(c) + amp_cosomegat = CS%amp(c)*CS%love_no(c)*CS%tide_fn(c) * cos(CS%freq(c)*now + (CS%phase0(c) + CS%tide_un(c))) + amp_sinomegat = CS%amp(c)*CS%love_no(c)*CS%tide_fn(c) * sin(CS%freq(c)*now + (CS%phase0(c) + CS%tide_un(c))) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_tide_eq(i,j) = e_tide_eq(i,j) + (amp_cosomegat*CS%cos_struct(i,j,m) + & + amp_sinomegat*CS%sin_struct(i,j,m)) + enddo ; enddo + enddo + + if (CS%use_tidal_sal_file) then ; do c=1,CS%nc + cosomegat = CS%tide_fn(c) * cos(CS%freq(c)*now + (CS%phase0(c) + CS%tide_un(c))) + sinomegat = CS%tide_fn(c) * sin(CS%freq(c)*now + (CS%phase0(c) + CS%tide_un(c))) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_tide_sal(i,j) = e_tide_sal(i,j) + CS%ampsal(i,j,c) * & + (cosomegat*CS%cosphasesal(i,j,c) + sinomegat*CS%sinphasesal(i,j,c)) + enddo ; enddo + enddo ; endif + + if (CS%use_tidal_sal_prev) then ; do c=1,CS%nc + cosomegat = CS%tide_fn(c) * cos(CS%freq(c)*now + (CS%phase0(c) + CS%tide_un(c))) + sinomegat = CS%tide_fn(c) * sin(CS%freq(c)*now + (CS%phase0(c) + CS%tide_un(c))) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_tide_sal(i,j) = e_tide_sal(i,j) - CS%sal_scalar * CS%amp_prev(i,j,c) * & + (cosomegat*CS%cosphase_prev(i,j,c) + sinomegat*CS%sinphase_prev(i,j,c)) + enddo ; enddo + enddo ; endif + + call cpu_clock_end(id_clock_tides) + +end subroutine calc_tidal_forcing + +!> This subroutine functions the same as calc_tidal_forcing but outputs a field that combines +!! previously calculated self-attraction and loading (SAL) and tidal forcings, so that old answers +!! can be preserved bitwise before SAL is separated out as an individual module. +subroutine calc_tidal_forcing_legacy(Time, e_sal, e_sal_tide, e_tide_eq, e_tide_sal, G, US, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(time_type), intent(in) :: Time !< The time for the caluculation. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: e_sal !< The self-attraction and loading fields + !! calculated previously used to + !! initialized e_sal_tide [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: e_sal_tide !< The total geopotential height anomalies + !! due to both SAL and tidal forcings [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: e_tide_eq !< The geopotential height anomalies + !! due to the equilibrium tides [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: e_tide_sal !< The geopotential height anomalies + !! due to the tidal SAL [Z ~> m]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(tidal_forcing_CS), intent(in) :: CS !< The control structure returned by a + !! previous call to tidal_forcing_init. + + ! Local variables + real :: now ! The relative time compared with the tidal reference [T ~> s] + real :: amp_cosomegat, amp_sinomegat ! The tidal amplitudes times the components of phase [Z ~> m] + real :: cosomegat, sinomegat ! The components of the phase [nondim] + real :: amp_cossin ! A temporary field that adds cosines and sines [nondim] + integer :: i, j, c, m, is, ie, js, je, Isq, Ieq, Jsq, Jeq + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + call cpu_clock_begin(id_clock_tides) + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_sal_tide(i,j) = 0.0 + e_tide_eq(i,j) = 0.0 + e_tide_sal(i,j) = 0.0 + enddo ; enddo + + if (CS%nc == 0) then + return endif + now = time_minus_signed(Time, cs%time_ref, scale=US%s_to_T) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta_tidal(i,j) = eta_prop*eta(i,j) + e_sal_tide(i,j) = e_sal(i,j) enddo ; enddo do c=1,CS%nc m = CS%struct(c) - amp_cosomegat = CS%amp(c)*CS%love_no(c) * cos(CS%freq(c)*now + CS%phase0(c)) - amp_sinomegat = CS%amp(c)*CS%love_no(c) * sin(CS%freq(c)*now + CS%phase0(c)) + amp_cosomegat = CS%amp(c)*CS%love_no(c)*CS%tide_fn(c) * cos(CS%freq(c)*now + (CS%phase0(c) + CS%tide_un(c))) + amp_sinomegat = CS%amp(c)*CS%love_no(c)*CS%tide_fn(c) * sin(CS%freq(c)*now + (CS%phase0(c) + CS%tide_un(c))) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta_tidal(i,j) = eta_tidal(i,j) + (amp_cosomegat*CS%cos_struct(i,j,m) + & - amp_sinomegat*CS%sin_struct(i,j,m)) + amp_cossin = (amp_cosomegat*CS%cos_struct(i,j,m) + amp_sinomegat*CS%sin_struct(i,j,m)) + e_sal_tide(i,j) = e_sal_tide(i,j) + amp_cossin + e_tide_eq(i,j) = e_tide_eq(i,j) + amp_cossin enddo ; enddo enddo - if (CS%tidal_sal_from_file) then ; do c=1,CS%nc - cosomegat = cos(CS%freq(c)*now) - sinomegat = sin(CS%freq(c)*now) + if (CS%use_tidal_sal_file) then ; do c=1,CS%nc + cosomegat = CS%tide_fn(c) * cos(CS%freq(c)*now + (CS%phase0(c) + CS%tide_un(c))) + sinomegat = CS%tide_fn(c) * sin(CS%freq(c)*now + (CS%phase0(c) + CS%tide_un(c))) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta_tidal(i,j) = eta_tidal(i,j) + CS%ampsal(i,j,c) * & - (cosomegat*CS%cosphasesal(i,j,c) + sinomegat*CS%sinphasesal(i,j,c)) + amp_cossin = CS%ampsal(i,j,c) & + * (cosomegat*CS%cosphasesal(i,j,c) + sinomegat*CS%sinphasesal(i,j,c)) + e_sal_tide(i,j) = e_sal_tide(i,j) + amp_cossin + e_tide_sal(i,j) = e_tide_sal(i,j) + amp_cossin enddo ; enddo enddo ; endif - if (CS%USE_PREV_TIDES) then ; do c=1,CS%nc - cosomegat = cos(CS%freq(c)*now) - sinomegat = sin(CS%freq(c)*now) + if (CS%use_tidal_sal_prev) then ; do c=1,CS%nc + cosomegat = CS%tide_fn(c) * cos(CS%freq(c)*now + (CS%phase0(c) + CS%tide_un(c))) + sinomegat = CS%tide_fn(c) * sin(CS%freq(c)*now + (CS%phase0(c) + CS%tide_un(c))) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta_tidal(i,j) = eta_tidal(i,j) - CS%SAL_SCALAR*CS%amp_prev(i,j,c) * & - (cosomegat*CS%cosphase_prev(i,j,c) + sinomegat*CS%sinphase_prev(i,j,c)) + amp_cossin = -CS%sal_scalar * CS%amp_prev(i,j,c) & + * (cosomegat*CS%cosphase_prev(i,j,c) + sinomegat*CS%sinphase_prev(i,j,c)) + e_sal_tide(i,j) = e_sal_tide(i,j) + amp_cossin + e_tide_sal(i,j) = e_tide_sal(i,j) + amp_cossin enddo ; enddo enddo ; endif - call cpu_clock_end(id_clock_tides) -end subroutine calc_tidal_forcing +end subroutine calc_tidal_forcing_legacy !> This subroutine deallocates memory associated with the tidal forcing module. subroutine tidal_forcing_end(CS) @@ -673,6 +768,8 @@ end subroutine tidal_forcing_end !> \namespace tidal_forcing !! +!! \section section_tides Tidal forcing +!! !! Code by Robert Hallberg, August 2005, based on C-code by Harper !! Simmons, February, 2003, in turn based on code by Brian Arbic. !! @@ -689,15 +786,16 @@ end subroutine tidal_forcing_end !! can be changed at run time by setting variables like TIDE_M2_FREQ, !! TIDE_M2_AMP and TIDE_M2_PHASE_T0 (for M2). !! -!! In addition, the approach to calculating self-attraction and -!! loading is set at run time. The default is to use the scalar -!! approximation, with a coefficient TIDE_SAL_SCALAR_VALUE that must -!! be set in the run-time file (for global runs, 0.094 is typical). -!! Alternately, TIDAL_SAL_FROM_FILE can be set to read the SAL from -!! a file containing the results of a previous simulation. To iterate -!! the SAL to convergence, USE_PREVIOUS_TIDES may be useful (for -!! details, see Arbic et al., 2004, DSR II). With TIDAL_SAL_FROM_FILE -!! or USE_PREVIOUS_TIDES,a list of input files must be provided to -!! describe each constituent's properties from a previous solution. - +!! In addition, approaches to calculate self-attraction and loading +!! due to tides (harmonics of astronomical forcing frequencies) +!! are provided. TIDAL_SAL_FROM_FILE can be set to read the phase and +!! amplitude of the tidal SAL. USE_PREVIOUS_TIDES may be useful in +!! combination with the scalar approximation to iterate the SAL to +!! convergence (for details, see \cite Arbic2004). With +!! TIDAL_SAL_FROM_FILE or USE_PREVIOUS_TIDES, a list of input +!! files must be provided to describe each constituent's properties from +!! a previous solution. The online SAL calculations that are functions +!! of SSH (rather should be bottom pressure anmoaly), either a scalar +!! approximation or with spherical harmonic transforms, are located in +!! MOM_self_attr_load. end module MOM_tidal_forcing diff --git a/src/parameterizations/lateral/MOM_wave_drag.F90 b/src/parameterizations/lateral/MOM_wave_drag.F90 new file mode 100644 index 0000000000..eb3062769d --- /dev/null +++ b/src/parameterizations/lateral/MOM_wave_drag.F90 @@ -0,0 +1,184 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Frequency-dependent linear wave drag + +module MOM_wave_drag + +use MOM_domains, only : pass_vector, To_All, Scalar_Pair +use MOM_error_handler, only : MOM_error, NOTE +use MOM_file_parser, only : get_param, log_param, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_io, only : MOM_read_data, slasher, EAST_FACE, NORTH_FACE +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +public wave_drag_init, wave_drag_calc + +#include + +!> Control structure for the MOM_wave_drag module +type, public :: wave_drag_CS ; private + integer :: nf !< Number of filters to be used in the simulation + real, allocatable, dimension(:,:,:) :: coef_u !< frequency-dependent drag coefficients [H T-1 ~> m s-1] + real, allocatable, dimension(:,:,:) :: coef_v !< frequency-dependent drag coefficients [H T-1 ~> m s-1] + real, allocatable, dimension(:,:,:) :: coef_uv !< frequency-dependent drag coefficients [H T-1 ~> m s-1] + real, allocatable, dimension(:,:,:) :: coef_vu !< frequency-dependent drag coefficients [H T-1 ~> m s-1] + logical :: tensor_drag !< If true, include the off-diagonal components of the + !! wave drag tensor for computing the wave drag +end type wave_drag_CS + +contains + +!> This subroutine reads drag coefficients from file. +subroutine wave_drag_init(param_file, wave_drag_file, G, GV, US, CS) + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + character(len=*), intent(in) :: wave_drag_file !< The file from which to read drag coefficients + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(wave_drag_CS), intent(out) :: CS !< Control structure of MOM_wave_drag + + ! Local variables + character(len=40) :: mdl = "MOM_wave_drag" !< This module's name + character(len=50) :: filter_name_str !< List of drag coefficients to be used + character(len=2), allocatable, dimension(:) :: filter_names !< Names of drag coefficients + character(len=80) :: var_names(4) !< Names of variables in wave_drag_file + character(len=200) :: mesg + real :: var_scale !< Scaling factors of drag coefficients [nondim] + integer :: c + + ! The number and names of drag coefficients should match those of the streaming filters. + call get_param(param_file, mdl, "N_FILTERS", CS%nf, & + "Number of streaming band-pass filters to be used in the simulation.", & + default=0, do_not_log=.true.) + call get_param(param_file, mdl, "FILTER_NAMES", filter_name_str, & + "Names of streaming band-pass filters to be used in the simulation.", & + do_not_log=.true.) + + allocate(CS%coef_u(G%IsdB:G%IedB,G%jsd:G%jed,CS%nf)) ; CS%coef_u(:,:,:) = 0.0 + allocate(CS%coef_v(G%isd:G%ied,G%JsdB:G%JedB,CS%nf)) ; CS%coef_v(:,:,:) = 0.0 + allocate(CS%coef_uv(G%IsdB:G%IedB,G%jsd:G%jed,CS%nf)) ; CS%coef_uv(:,:,:) = 0.0 + allocate(CS%coef_vu(G%isd:G%ied,G%JsdB:G%JedB,CS%nf)) ; CS%coef_vu(:,:,:) = 0.0 + allocate(filter_names(CS%nf)) ; read(filter_name_str, *) filter_names + + CS%tensor_drag = .false. + + if (len_trim(wave_drag_file) > 0) then + do c=1,CS%nf + call get_param(param_file, mdl, "BT_"//trim(filter_names(c))//"_DRAG_U", & + var_names(1), "The name of the variable in BT_WAVE_DRAG_FILE "//& + "for the drag coefficient of the "//trim(filter_names(c))//& + " frequency at u points.", default="") + call get_param(param_file, mdl, "BT_"//trim(filter_names(c))//"_DRAG_V", & + var_names(2), "The name of the variable in BT_WAVE_DRAG_FILE "//& + "for the drag coefficient of the "//trim(filter_names(c))//& + " frequency at v points.", default="") + call get_param(param_file, mdl, "BT_"//trim(filter_names(c))//"_DRAG_UV", & + var_names(3), "The name of the variable in BT_WAVE_DRAG_FILE "//& + "for the drag coefficient of the "//trim(filter_names(c))//& + " frequency at u points, corresponding to the off-diagonal "//& + "component of the wave drag tensor.", default="") + call get_param(param_file, mdl, "BT_"//trim(filter_names(c))//"_DRAG_VU", & + var_names(4), "The name of the variable in BT_WAVE_DRAG_FILE "//& + "for the drag coefficient of the "//trim(filter_names(c))//& + " frequency at v points, corresponding to the off-diagonal "//& + "component of the wave drag tensor.", default="") + call get_param(param_file, mdl, "BT_"//trim(filter_names(c))//"_DRAG_SCALE", & + var_scale, "A scaling factor for the drag coefficient of the "//& + trim(filter_names(c))//" frequency.", default=1.0, units="nondim") + + if (len_trim(var_names(1))>0 .and. len_trim(var_names(2))>0 .and. var_scale>0.0) then + call MOM_read_data(wave_drag_file, trim(var_names(1)), CS%coef_u(:,:,c), G%Domain, & + position=EAST_FACE, scale=var_scale*GV%m_to_H*US%T_to_s) + call MOM_read_data(wave_drag_file, trim(var_names(2)), CS%coef_v(:,:,c), G%Domain, & + position=NORTH_FACE, scale=var_scale*GV%m_to_H*US%T_to_s) + call pass_vector(CS%coef_u(:,:,c), CS%coef_v(:,:,c), G%domain, & + direction=To_All+SCALAR_PAIR) + + if (len_trim(var_names(3))>0 .and. len_trim(var_names(4))>0) then + CS%tensor_drag = .true. + + call MOM_read_data(wave_drag_file, trim(var_names(3)), CS%coef_uv(:,:,c), G%Domain, & + position=EAST_FACE, scale=var_scale*GV%m_to_H*US%T_to_s) + call MOM_read_data(wave_drag_file, trim(var_names(4)), CS%coef_vu(:,:,c), G%Domain, & + position=NORTH_FACE, scale=var_scale*GV%m_to_H*US%T_to_s) + call pass_vector(CS%coef_uv(:,:,c), CS%coef_vu(:,:,c), G%domain, & + direction=To_All+SCALAR_PAIR) + endif + + write(mesg, *) "MOM_wave_drag: ", trim(filter_names(c)), & + " coefficients read from file, scaling factor = ", var_scale + call MOM_error(NOTE, trim(mesg)) + endif ! (len_trim(var_names(1))+len_trim(var_names(2))>0 .and. var_scale>0.0) + enddo ! k=1,CS%nf + endif ! (len_trim(wave_drag_file) > 0) + +end subroutine wave_drag_init + +!> This subroutine calculates the sum of the products of the tidal velocities and the scaled +!! frequency-dependent drag for each tidal constituent specified in MOM_input. +subroutine wave_drag_calc(u, v, drag_u, drag_v, G, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(wave_drag_CS), intent(in) :: CS !< Control structure of MOM_wave_drag + real, dimension(:,:,:), pointer, intent(in) :: u !< Zonal velocity from the output of + !! streaming band-pass filters [L T-1 ~> m s-1] + real, dimension(:,:,:), pointer, intent(in) :: v !< Meridional velocity from the output of + !! streaming band-pass filters [L T-1 ~> m s-1] + real, dimension(G%IsdB:G%IedB,G%jsd:G%jed), intent(out) :: drag_u !< Sum of products of filtered velocities + !! and scaled frequency-dependent drag [L2 T-2 ~> m2 s-2] + real, dimension(G%isd:G%ied,G%JsdB:G%JedB), intent(out) :: drag_v !< Sum of products of filtered velocities + !! and scaled frequency-dependent drag [L2 T-2 ~> m2 s-2] + + ! Local variables + integer :: is, ie, js, je, i, j, c + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + drag_u(:,:) = 0.0 ; drag_v(:,:) = 0.0 + + if (CS%tensor_drag) then + call pass_vector(u(:,:,1:CS%nf), v(:,:,1:CS%nf), G%domain, direction=To_All+SCALAR_PAIR) + !$OMP do + do j=js,je ; do I=is-1,ie ; do c=1,CS%nf ; if (G%mask2dCu(I,j) * CS%coef_u(I,j,c) > 0.0) then + drag_u(I,j) = drag_u(I,j) + (u(I,j,c) * CS%coef_u(I,j,c) + & + 0.25 * ((v(i+1,J,c) + v(i,J-1,c)) + (v(i,J,c) + v(i+1,J-1,c))) * CS%coef_uv(I,j,c)) + endif ; enddo ; enddo ; enddo + !$OMP do + do J=js-1,je ; do i=is,ie ; do c=1,CS%nf ; if (G%mask2dCv(i,J) * CS%coef_v(i,J,c) > 0.0) then + drag_v(i,J) = drag_v(i,J) + (v(i,J,c) * CS%coef_v(i,J,c) + & + 0.25 * ((u(I-1,j,c) + u(I,j+1,c)) + (u(I,j,c) + u(I-1,j+1,c))) * CS%coef_vu(i,J,c)) + endif ; enddo ; enddo ; enddo + else ! (.not.CS%tensor_drag) + !$OMP do + do j=js,je ; do I=is-1,ie ; do c=1,CS%nf ; if (G%mask2dCu(I,j) * CS%coef_u(I,j,c) > 0.0) then + drag_u(I,j) = drag_u(I,j) + u(I,j,c) * CS%coef_u(I,j,c) + endif ; enddo ; enddo ; enddo + !$OMP do + do J=js-1,je ; do i=is,ie ; do c=1,CS%nf ; if (G%mask2dCv(i,J) * CS%coef_v(i,J,c) > 0.0) then + drag_v(i,J) = drag_v(i,J) + v(i,J,c) * CS%coef_v(i,J,c) + endif ; enddo ; enddo ; enddo + endif ! (CS%tensor_drag) + +end subroutine wave_drag_calc + +!> \namespace mom_wave_drag +!! +!! By Chengzhu Xu (chengzhu.xu@oregonstate.edu) and Edward D. Zaron +!! +!! This module calculates the net effects of the frequency-dependent internal wave drag applied to +!! the tidal velocities, and returns the sum of products of frequency-dependent drag coefficients +!! and tidal velocities for each constituent to the MOM_barotropic module for further calculations. +!! It relies on the use of MOM_streaming_filter for determining the tidal velocities. Furthermore, +!! the number of drag coefficients cannot exceed that of the streaming filters, and the names of +!! drag coefficients should match those of the streaming filters. The frequency-dependent drag +!! coefficients are read from the same file for the linear drag coefficients in MOM_barotropic. +!! +!! Reference: Xu, C., & Zaron, E. D. (2025). Parameterization of frequency-dependent internal wave drag. +!! Journal of Advances in Modeling Earth Systems, 17, e2025MS005126. https://doi.org/10.1029/2025MS005126 + +end module MOM_wave_drag + diff --git a/src/parameterizations/stochastic/MOM_stochastics.F90 b/src/parameterizations/stochastic/MOM_stochastics.F90 index 21a22a222e..20144839b8 100644 --- a/src/parameterizations/stochastic/MOM_stochastics.F90 +++ b/src/parameterizations/stochastic/MOM_stochastics.F90 @@ -1,128 +1,252 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Top-level module for the MOM6 ocean model in coupled mode. module MOM_stochastics -! This file is part of MOM6. See LICENSE.md for the license. - ! This is the top level module for the MOM6 ocean model. It contains routines ! for initialization, update, and writing restart of stochastic physics. This ! particular version wraps all of the calls for MOM6 in the calls that had ! been used for MOM4. ! -use MOM_diag_mediator, only : register_diag_field, diag_ctrl, time_type +use MOM_debugging, only : hchksum, uvchksum, qchksum +use MOM_diag_mediator, only : register_diag_field, diag_ctrl, time_type, post_data +use MOM_diag_mediator, only : register_static_field, enable_averages, disable_averaging use MOM_grid, only : ocean_grid_type +use MOM_variables, only : thermo_var_ptrs +use MOM_domains, only : pass_var, pass_vector, CORNER, SCALAR_PAIR use MOM_verticalGrid, only : verticalGrid_type -use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave use MOM_file_parser, only : get_param, log_version, close_param_file, param_file_type use mpp_domains_mod, only : domain2d, mpp_get_layout, mpp_get_global_domain use mpp_domains_mod, only : mpp_define_domains, mpp_get_compute_domain, mpp_get_data_domain -use MOM_domains, only : root_PE,num_PEs +use MOM_domains, only : root_PE, num_PEs use MOM_coms, only : Get_PElist +use MOM_EOS, only : calculate_density, EOS_domain use stochastic_physics, only : init_stochastic_physics_ocn, run_stochastic_physics_ocn #include implicit none ; private -public stochastics_init, update_stochastics +public stochastics_init, update_stochastics, apply_skeb !> This control structure holds parameters for the MOM_stochastics module type, public:: stochastic_CS logical :: do_sppt !< If true, stochastically perturb the diabatic + logical :: do_skeb !< If true, stochastically perturb the horizontal velocity + logical :: skeb_use_gm !< If true, adds GM work to the amplitude of SKEBS + logical :: skeb_use_frict !< If true, adds viscous dissipation rate to the amplitude of SKEBS logical :: pert_epbl !< If true, then randomly perturb the KE dissipation and genration terms - integer :: id_sppt_wts = -1 !< Diagnostic id for SPPT - integer :: id_epbl1_wts=-1 !< Diagnostic id for epbl generation perturbation - integer :: id_epbl2_wts=-1 !< Diagnostic id for epbl dissipation perturbation + integer :: id_sppt_wts = -1 !< Diagnostic id for SPPT + integer :: id_skeb_wts = -1 !< Diagnostic id for SKEB + integer :: id_skebu = -1 !< Diagnostic id for SKEB + integer :: id_skebv = -1 !< Diagnostic id for SKEB + integer :: id_diss = -1 !< Diagnostic id for SKEB + integer :: skeb_npass = -1 !< number of passes of the 9-point smoother for the dissipation estimate + integer :: id_psi = -1 !< Diagnostic id for SPPT + integer :: id_epbl1_wts = -1 !< Diagnostic id for epbl generation perturbation + integer :: id_epbl2_wts = -1 !< Diagnostic id for epbl dissipation perturbation + integer :: id_skeb_taperu = -1 !< Diagnostic id for u taper of SKEB velocity increment + integer :: id_skeb_taperv = -1 !< Diagnostic id for v taper of SKEB velocity increment + real :: skeb_gm_coef !< If skeb_use_gm is true, then skeb_gm_coef * GM_work is added to the + !! dissipation rate used to set the amplitude of SKEBS [nondim] + real :: skeb_frict_coef !< If skeb_use_frict is true, then skeb_gm_coef * GM_work is added to the + !! dissipation rate used to set the amplitude of SKEBS [nondim] + real, allocatable :: skeb_diss(:,:,:) !< Dissipation rate used to set amplitude of SKEBS [L2 T-3 ~> m2 s-3] + !! Index into this at h points. ! stochastic patterns real, allocatable :: sppt_wts(:,:) !< Random pattern for ocean SPPT - !! tendencies with a number between 0 and 2 - real, allocatable :: epbl1_wts(:,:) !< Random pattern for K.E. generation - real, allocatable :: epbl2_wts(:,:) !< Random pattern for K.E. dissipation - type(diag_ctrl), pointer :: diag !< structure used to regulate timing of diagnostic output + !! tendencies with a number between 0 and 2 [nondim] + real, allocatable :: skeb_wts(:,:) !< Random pattern for ocean SKEB [nondim] + real, allocatable :: epbl1_wts(:,:) !< Random pattern for K.E. generation [nondim] + real, allocatable :: epbl2_wts(:,:) !< Random pattern for K.E. dissipation [nondim] type(time_type), pointer :: Time !< Pointer to model time (needed for sponges) + type(diag_ctrl), pointer :: diag=>NULL() !< A structure that is used to regulate the + + ! Taper array to smoothly zero out the SKEBS velocity increment near land + real, allocatable :: taperCu(:,:) !< Taper applied to u component of stochastic + !! velocity increment range [0,1], [nondim] + real, allocatable :: taperCv(:,:) !< Taper applied to v component of stochastic + !! velocity increment range [0,1], [nondim] + end type stochastic_CS contains !! This subroutine initializes the stochastics physics control structure. subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) - real, intent(in) :: dt !< time step [T ~> s] - type(ocean_grid_type), intent(in) :: grid !< horizontal grid information - type(verticalGrid_type), intent(in) :: GV !< vertical grid structure - type(stochastic_CS), pointer, intent(inout):: CS !< stochastic control structure + real, intent(in) :: dt !< time step [T ~> s] + type(ocean_grid_type), intent(in) :: grid !< horizontal grid information + type(verticalGrid_type), intent(in) :: GV !< vertical grid structure + type(stochastic_CS), pointer, intent(inout) :: CS !< stochastic control structure type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(inout) :: diag !< structure to regulate diagnostic output - type(time_type), target :: Time !< model time + type(diag_ctrl), target, intent(inout) :: diag !< structure to regulate diagnostic output + type(time_type), target :: Time !< model time + ! Local variables - integer,allocatable :: pelist(:) ! list of pes for this instance of the ocean + integer, allocatable :: pelist(:) ! list of pes for this instance of the ocean integer :: mom_comm ! list of pes for this instance of the ocean integer :: num_procs ! number of processors to pass to stochastic physics integer :: iret ! return code from stochastic physics - integer :: me ! my pe integer :: pe_zero ! root pe - integer :: nx ! number of x-points including halo - integer :: ny ! number of x-points including halo + integer :: nxT, nxB ! number of x-points including halo + integer :: nyT, nyB ! number of y-points including halo + integer :: i, j, k ! loop indices + real :: tmp(grid%isdB:grid%iedB,grid%jsdB:grid%jedB) ! Used to construct tapers + integer :: taper_width ! Width (in cells) of the taper that brings the stochastic velocity + ! increments to 0 at the boundary. -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "ocean_stochastics_init" ! This module's name. - call callTree_enter("ocean_model_stochastic_init(), MOM_stochastics.F90") + call callTree_enter("stochastic_init(), MOM_stochastics.F90") if (associated(CS)) then call MOM_error(WARNING, "MOM_stochastics_init called with an "// & "associated control structure.") return else ; allocate(CS) ; endif - CS%diag => diag CS%Time => Time + CS%diag => diag ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") -! get number of processors and PE list for stocasthci physics initialization + ! get number of processors and PE list for stochastic physics initialization call get_param(param_file, mdl, "DO_SPPT", CS%do_sppt, & "If true, then stochastically perturb the thermodynamic "//& - "tendemcies of T,S, amd h. Amplitude and correlations are "//& + "tendencies of T,S, and h. Amplitude and correlations are "//& "controlled by the nam_stoch namelist in the UFS model only.", & default=.false.) + call get_param(param_file, mdl, "DO_SKEB", CS%do_skeb, & + "If true, then stochastically perturb the currents "//& + "using the stochastic kinetic energy backscatter scheme.",& + default=.false.) + call get_param(param_file, mdl, "SKEB_NPASS", CS%skeb_npass, & + "number of passes of a 9-point smoother of the "//& + "dissipation estimate.", default=3, do_not_log=.not.CS%do_skeb) + call get_param(param_file, mdl, "SKEB_TAPER_WIDTH", taper_width, & + "number of cells over which the stochastic velocity increment "//& + "is tapered to zero.", default=4, do_not_log=.not.CS%do_skeb) + call get_param(param_file, mdl, "SKEB_USE_GM", CS%skeb_use_gm, & + "If true, adds GM work rate to the SKEBS amplitude.", & + default=.false., do_not_log=.not.CS%do_skeb) + if ((.not. CS%do_skeb) .and. (CS%skeb_use_gm)) call MOM_error(FATAL, "If SKEB_USE_GM is True "//& + "then DO_SKEB must also be True.") + call get_param(param_file, mdl, "SKEB_GM_COEF", CS%skeb_gm_coef, & + "Fraction of GM work that is added to backscatter rate.", & + units="nondim", default=0.0, do_not_log=.not.CS%skeb_use_gm) + call get_param(param_file, mdl, "SKEB_USE_FRICT", CS%skeb_use_frict, & + "If true, adds horizontal friction dissipation rate "//& + "to the SKEBS amplitude.", default=.false., do_not_log=.not.CS%do_skeb) + if ((.not. CS%do_skeb) .and. (CS%skeb_use_frict)) call MOM_error(FATAL, "If SKEB_USE_FRICT is "//& + "True then DO_SKEB must also be True.") + call get_param(param_file, mdl, "SKEB_FRICT_COEF", CS%skeb_frict_coef, & + "Fraction of horizontal friction work that is added to backscatter rate.", & + units="nondim", default=0.0, do_not_log=.not.CS%skeb_use_frict) call get_param(param_file, mdl, "PERT_EPBL", CS%pert_epbl, & "If true, then stochastically perturb the kinetic energy "//& "production and dissipation terms. Amplitude and correlations are "//& "controlled by the nam_stoch namelist in the UFS model only.", & default=.false.) - if (CS%do_sppt .OR. CS%pert_epbl) then - num_procs=num_PEs() - allocate(pelist(num_procs)) - call Get_PElist(pelist,commID = mom_comm) - pe_zero=root_PE() - nx = grid%ied - grid%isd + 1 - ny = grid%jed - grid%jsd + 1 - call init_stochastic_physics_ocn(dt,grid%geoLonT,grid%geoLatT,nx,ny,GV%ke, & - CS%pert_epbl,CS%do_sppt,pe_zero,mom_comm,iret) - if (iret/=0) then - call MOM_error(FATAL, "call to init_stochastic_physics_ocn failed") - return - endif - - if (CS%do_sppt) allocate(CS%sppt_wts(grid%isd:grid%ied,grid%jsd:grid%jed)) - if (CS%pert_epbl) then - allocate(CS%epbl1_wts(grid%isd:grid%ied,grid%jsd:grid%jed)) - allocate(CS%epbl2_wts(grid%isd:grid%ied,grid%jsd:grid%jed)) - endif + + if (CS%do_sppt .OR. CS%pert_epbl .OR. CS%do_skeb) then + num_procs = num_PEs() + allocate(pelist(num_procs)) + call Get_PElist(pelist,commID = mom_comm) + pe_zero = root_PE() + nxT = grid%ied - grid%isd + 1 + nyT = grid%jed - grid%jsd + 1 + nxB = grid%iedB - grid%isdB + 1 + nyB = grid%jedB - grid%jsdB + 1 + call init_stochastic_physics_ocn(dt, grid%geoLonT, grid%geoLatT, nxT, nyT, GV%ke, & + grid%geoLonBu, grid%geoLatBu, nxB, nyB, & + CS%pert_epbl, CS%do_sppt, CS%do_skeb, pe_zero, mom_comm, iret) + if (iret/=0) then + call MOM_error(FATAL, "call to init_stochastic_physics_ocn failed") + return + endif + + if (CS%do_sppt) allocate(CS%sppt_wts(grid%isd:grid%ied,grid%jsd:grid%jed)) + if (CS%do_skeb) allocate(CS%skeb_wts(grid%isdB:grid%iedB,grid%jsdB:grid%jedB)) + if (CS%do_skeb) allocate(CS%skeb_diss(grid%isd:grid%ied,grid%jsd:grid%jed,GV%ke), source=0.) + if (CS%pert_epbl) then + allocate(CS%epbl1_wts(grid%isd:grid%ied,grid%jsd:grid%jed)) + allocate(CS%epbl2_wts(grid%isd:grid%ied,grid%jsd:grid%jed)) + endif endif + CS%id_sppt_wts = register_diag_field('ocean_model', 'sppt_pattern', CS%diag%axesT1, Time, & 'random pattern for sppt', 'None') + CS%id_skeb_wts = register_diag_field('ocean_model', 'skeb_pattern', CS%diag%axesB1, Time, & + 'random pattern for skeb', 'None') CS%id_epbl1_wts = register_diag_field('ocean_model', 'epbl1_wts', CS%diag%axesT1, Time, & 'random pattern for KE generation', 'None') CS%id_epbl2_wts = register_diag_field('ocean_model', 'epbl2_wts', CS%diag%axesT1, Time, & 'random pattern for KE dissipation', 'None') + CS%id_skebu = register_diag_field('ocean_model', 'skebu', CS%diag%axesCuL, Time, & + 'zonal current perts', 'None') + CS%id_skebv = register_diag_field('ocean_model', 'skebv', CS%diag%axesCvL, Time, & + 'zonal current perts', 'None') + CS%id_diss = register_diag_field('ocean_model', 'skeb_amp', CS%diag%axesTL, Time, & + 'SKEB amplitude', 'm s-1') + CS%id_psi = register_diag_field('ocean_model', 'psi', CS%diag%axesBL, Time, & + 'stream function', 'None') + CS%id_skeb_taperu = register_static_field('ocean_model', 'skeb_taper_u', CS%diag%axesCu1, & + 'SKEB taper u', 'None', interp_method='none') + CS%id_skeb_taperv = register_static_field('ocean_model', 'skeb_taper_v', CS%diag%axesCv1, & + 'SKEB taper v', 'None', interp_method='none') - if (is_root_pe()) & - write(*,'(/12x,a/)') '=== COMPLETED MOM STOCHASTIC INITIALIZATION =====' + ! Initialize the "taper" fields. These fields multiply the components of the stochastic + ! velocity increment in such a way as to smoothly taper them to zero at land boundaries. + if ((CS%do_skeb) .or. (CS%id_skeb_taperu > 0) .or. (CS%id_skeb_taperv > 0)) then + allocate(CS%taperCu(grid%IsdB:grid%IedB,grid%jsd:grid%jed)) + allocate(CS%taperCv(grid%isd:grid%ied,grid%JsdB:grid%JedB)) + ! Initialize taper from land mask + do j=grid%jsd,grid%jed ; do I=grid%isdB,grid%iedB + CS%taperCu(I,j) = grid%mask2dCu(I,j) + enddo ; enddo + do J=grid%jsdB,grid%jedB ; do i=grid%isd,grid%ied + CS%taperCv(i,J) = grid%mask2dCv(i,J) + enddo ; enddo + ! Extend taper land + do k=1,(taper_width / 2) + do j=grid%jsc-1,grid%jec+1 ; do I=grid%iscB-1,grid%iecB+1 + tmp(I,j) = minval(CS%taperCu(I-1:I+1,j-1:j+1)) + enddo ; enddo + do j=grid%jsc,grid%jec ; do I=grid%iscB,grid%iecB + CS%taperCu(I,j) = minval(tmp(I-1:I+1,j-1:j+1)) + enddo ; enddo + do J=grid%jscB-1,grid%jecB+1 ; do i=grid%isc-1,grid%iec+1 + tmp(i,J) = minval(CS%taperCv(i-1:i+1,J-1:J+1)) + enddo ; enddo + do J=grid%jscB,grid%jecB ; do i=grid%isc,grid%iec + CS%taperCv(i,J) = minval(tmp(i-1:i+1,J-1:J+1)) + enddo ; enddo + ! Update halo + call pass_vector(CS%taperCu, CS%taperCv, grid%Domain, SCALAR_PAIR) + enddo + ! Smooth tapers. Each call smooths twice. + do k=1,(taper_width - (taper_width/2)) + call smooth_x9_uv(grid, CS%taperCu, CS%taperCv, zero_land=.true.) + call pass_vector(CS%taperCu, CS%taperCv, grid%Domain, SCALAR_PAIR) + enddo + endif + + !call uvchksum("SKEB taper [uv]", CS%taperCu, CS%taperCv, grid%HI) + + if (CS%id_skeb_taperu > 0) call post_data(CS%id_skeb_taperu, CS%taperCu, CS%diag, .true.) + if (CS%id_skeb_taperv > 0) call post_data(CS%id_skeb_taperv, CS%taperCv, CS%diag, .true.) + + if (CS%do_sppt .OR. CS%pert_epbl .OR. CS%do_skeb) & + call MOM_mesg(' === COMPLETED MOM STOCHASTIC INITIALIZATION =====') + + call callTree_leave("stochastic_init(), MOM_stochastics.F90") - call callTree_leave("ocean_model_init(") - return end subroutine stochastics_init !> update_ocean_model uses the forcing in Ice_ocean_boundary to advance the @@ -135,10 +259,196 @@ subroutine update_stochastics(CS) call callTree_enter("update_stochastics(), MOM_stochastics.F90") ! update stochastic physics patterns before running next time-step - call run_stochastic_physics_ocn(CS%sppt_wts,CS%epbl1_wts,CS%epbl2_wts) + call run_stochastic_physics_ocn(CS%sppt_wts,CS%skeb_wts,CS%epbl1_wts,CS%epbl2_wts) + + call callTree_leave("update_stochastics(), MOM_stochastics.F90") - return end subroutine update_stochastics +subroutine apply_skeb(grid,GV,CS,uc,vc,thickness,tv,dt,Time_end) + + type(ocean_grid_type), intent(in) :: grid !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid + type(stochastic_CS), intent(inout) :: CS !< stochastic control structure + + real, dimension(SZIB_(grid),SZJ_(grid),SZK_(GV)), intent(inout) :: uc !< zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(grid),SZJB_(grid),SZK_(GV)), intent(inout) :: vc !< meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(grid),SZJ_(grid),SZK_(GV)), intent(in) :: thickness !< thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< points to thermodynamic fields + real, intent(in) :: dt !< time increment [T ~> s] + type(time_type), intent(in) :: Time_end !< Time at the end of the interval +! locals + + real, dimension(SZIB_(grid),SZJB_(grid),SZK_(GV)) :: psi !< Streamfunction for stochastic velocity increments + !! [L2 T-1 ~> m2 s-1] + real, dimension(SZIB_(grid),SZJ_(grid) ,SZK_(GV)) :: ustar !< Stochastic u velocity increment [L T-1 ~> m s-1] + real, dimension(SZI_(grid) ,SZJB_(grid),SZK_(GV)) :: vstar !< Stochastic v velocity increment [L T-1 ~> m s-1] + real, dimension(SZI_(grid),SZJ_(grid)) :: diss_tmp !< Temporary array used in smoothing skeb_diss + !! [L2 T-3 ~> m2 s-2] + real, dimension(3,3) :: local_weights !< 3x3 stencil weights used in smoothing skeb_diss + !! [L2 ~> m2] + + real :: shr,ten,tot,kh + integer :: i,j,k,iter + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + + call callTree_enter("apply_skeb(), MOM_stochastics.F90") + + if ((.not. CS%skeb_use_gm) .and. (.not. CS%skeb_use_frict)) then + ! fill in halos with zeros + do k=1,GV%ke + do j=grid%jsd,grid%jed ; do i=grid%isd,grid%ied + CS%skeb_diss(i,j,k) = 0.0 + enddo ; enddo + enddo + + !kh needs to be scaled + + kh=1!(120*111)**2 + do k=1,GV%ke + do j=grid%jsc,grid%jec ; do i=grid%isc,grid%iec + ! Shear + shr = (vc(i,J,k)-vc(i-1,J,k))*grid%mask2dCv(i,J)*grid%mask2dCv(i-1,J)*grid%IdxCv(i,J)+& + (uc(I,j,k)-uc(I,j-1,k))*grid%mask2dCu(I,j)*grid%mask2dCu(I,j-1)*grid%IdyCu(I,j) + ! Tension + ten = (vc(i,J,k)-vc(i-1,J,k))*grid%mask2dCv(i,J)*grid%mask2dCv(i-1,J)*grid%IdyCv(i,J)+& + (uc(I,j,k)-uc(I,j-1,k))*grid%mask2dCu(I,j)*grid%mask2dCu(I,j-1)*grid%IdxCu(I,j) + + tot = sqrt( shr**2 + ten**2 ) * grid%mask2dT(i,j) + CS%skeb_diss(i,j,k) = tot**3 * kh * grid%areaT(i,j)!!**2 + enddo ; enddo + enddo + endif ! Sets CS%skeb_diss without GM or FrictWork + + ! smooth dissipation skeb_npass times + do iter=1,CS%skeb_npass + if (mod(iter,2) == 1) call pass_var(CS%skeb_diss, grid%domain) + do k=1,GV%ke + do j=grid%jsc-1,grid%jec+1 ; do i=grid%isc-1,grid%iec+1 + ! This does not preserve rotational symmetry + local_weights = grid%mask2dT(i-1:i+1,j-1:j+1)*grid%areaT(i-1:i+1,j-1:j+1) + diss_tmp(i,j) = sum(local_weights*CS%skeb_diss(i-1:i+1,j-1:j+1,k)) / & + (sum(local_weights) + 1.E-16) + enddo ; enddo + do j=grid%jsc-1,grid%jec+1 ; do i=grid%isc-1,grid%iec+1 + if (grid%mask2dT(i,j)==0.) cycle + CS%skeb_diss(i,j,k) = diss_tmp(i,j) + enddo ; enddo + enddo + enddo + call pass_var(CS%skeb_diss, grid%domain) + + ! call hchksum(CS%skeb_diss, "SKEB DISS", grid%HI, haloshift=2) + ! call qchksum(CS%skeb_wts, "SKEB WTS", grid%HI, haloshift=1) + + do k=1,GV%ke + do J=grid%jscB-1,grid%jecB ; do I=grid%iscB-1,grid%iecB + psi(I,J,k) = sqrt(0.25 * dt * max((CS%skeb_diss(i ,j ,k) + CS%skeb_diss(i+1,j+1,k)) + & + (CS%skeb_diss(i ,j+1,k) + CS%skeb_diss(i+1,j ,k)), 0.) ) & + * CS%skeb_wts(I,J) + enddo ; enddo + enddo + !call qchksum(psi,"SKEB PSI", grid%HI, haloshift=1) + !call pass_var(psi, grid%domain, position=CORNER) + do k=1,GV%ke + do j=grid%jsc,grid%jec ; do I=grid%iscB,grid%iecB + ustar(I,j,k) = - (psi(I,J,k) - psi(I,J-1,k)) * CS%taperCu(I,j) * grid%IdyCu(I,j) + uc(I,j,k) = uc(I,j,k) + ustar(I,j,k) + enddo ; enddo + do J=grid%jscB,grid%jecB ; do i=grid%isc,grid%iec + vstar(i,J,k) = (psi(I,J,k) - psi(I-1,J,k)) * CS%taperCv(i,J) * grid%IdxCv(i,J) + vc(i,J,k) = vc(i,J,k) + vstar(i,J,k) + enddo ; enddo + enddo + + !call uvchksum("SKEB increment [uv]", ustar, vstar, grid%HI) + + call enable_averages(dt, Time_end, CS%diag) + if (CS%id_diss > 0) then + call post_data(CS%id_diss, sqrt(dt * max(CS%skeb_diss(:,:,:), 0.)), CS%diag) + endif + if (CS%id_skeb_wts > 0) then + call post_data(CS%id_skeb_wts, CS%skeb_wts, CS%diag) + endif + if (CS%id_skebu > 0) then + call post_data(CS%id_skebu, ustar(:,:,:), CS%diag) + endif + if (CS%id_skebv > 0) then + call post_data(CS%id_skebv, vstar(:,:,:), CS%diag) + endif + if (CS%id_psi > 0) then + call post_data(CS%id_psi, psi(:,:,:), CS%diag) + endif + call disable_averaging(CS%diag) + CS%skeb_diss(:,:,:) = 0.0 ! Must zero before next time step. + + call callTree_leave("apply_skeb(), MOM_stochastics.F90") + +end subroutine apply_skeb + +!> Apply a 9-point smoothing filter twice to a pair of velocity components to reduce +!! horizontal two-grid-point noise. +!! Note that this subroutine does not conserve angular momentum, so don't use it +!! in situations where you need conservation. Also note that it assumes that the +!! input fields have valid values in the first two halo points upon entry. +subroutine smooth_x9_uv(G, field_u, field_v, zero_land) + type(ocean_grid_type), intent(in) :: G !< Ocean grid + real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: field_u !< u-point field to be smoothed[arbitrary] + real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: field_v !< v-point field to be smoothed [arbitrary] + logical, optional, intent(in) :: zero_land !< If present and false, return the average + !! of the surrounding ocean points when + !! smoothing, otherwise use a value of 0 for + !! land points and include them in the averages. + + ! Local variables. + real :: fu_prev(SZIB_(G),SZJ_(G)) ! The value of the u-point field at the previous iteration [arbitrary] + real :: fv_prev(SZI_(G),SZJB_(G)) ! The value of the v-point field at the previous iteration [arbitrary] + real :: Iwts ! The inverse of the sum of the weights [nondim] + logical :: zero_land_val ! The value of the zero_land optional argument or .true. if it is absent. + integer :: i, j, s, is, ie, js, je, Isq, Ieq, Jsq, Jeq + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + zero_land_val = .true. ; if (present(zero_land)) zero_land_val = zero_land + + do s=1,0,-1 + fu_prev(:,:) = field_u(:,:) + ! apply smoothing on field_u using rotationally symmetric expressions. + do j=js-s,je+s ; do I=Isq-s,Ieq+s ; if (G%mask2dCu(I,j) > 0.0) then + Iwts = 0.0625 + if (.not. zero_land_val) & + Iwts = 1.0 / ( (4.0*G%mask2dCu(I,j) + & + ( 2.0*((G%mask2dCu(I-1,j) + G%mask2dCu(I+1,j)) + & + (G%mask2dCu(I,j-1) + G%mask2dCu(I,j+1))) + & + ((G%mask2dCu(I-1,j-1) + G%mask2dCu(I+1,j+1)) + & + (G%mask2dCu(I-1,j+1) + G%mask2dCu(I+1,j-1))) ) ) + 1.0e-16 ) + field_u(I,j) = Iwts * ( 4.0*G%mask2dCu(I,j) * fu_prev(I,j) & + + (2.0*((G%mask2dCu(I-1,j) * fu_prev(I-1,j) + G%mask2dCu(I+1,j) * fu_prev(I+1,j)) + & + (G%mask2dCu(I,j-1) * fu_prev(I,j-1) + G%mask2dCu(I,j+1) * fu_prev(I,j+1))) & + + ((G%mask2dCu(I-1,j-1) * fu_prev(I-1,j-1) + G%mask2dCu(I+1,j+1) * fu_prev(I+1,j+1)) + & + (G%mask2dCu(I-1,j+1) * fu_prev(I-1,j+1) + G%mask2dCu(I+1,j-1) * fu_prev(I-1,j-1))) )) + endif ; enddo ; enddo + + fv_prev(:,:) = field_v(:,:) + ! apply smoothing on field_v using rotationally symmetric expressions. + do J=Jsq-s,Jeq+s ; do i=is-s,ie+s ; if (G%mask2dCv(i,J) > 0.0) then + Iwts = 0.0625 + if (.not. zero_land_val) & + Iwts = 1.0 / ( (4.0*G%mask2dCv(i,J) + & + ( 2.0*((G%mask2dCv(i-1,J) + G%mask2dCv(i+1,J)) + & + (G%mask2dCv(i,J-1) + G%mask2dCv(i,J+1))) + & + ((G%mask2dCv(i-1,J-1) + G%mask2dCv(i+1,J+1)) + & + (G%mask2dCv(i-1,J+1) + G%mask2dCv(i+1,J-1))) ) ) + 1.0e-16 ) + field_v(i,J) = Iwts * ( 4.0*G%mask2dCv(i,J) * fv_prev(i,J) & + + (2.0*((G%mask2dCv(i-1,J) * fv_prev(i-1,J) + G%mask2dCv(i+1,J) * fv_prev(i+1,J)) + & + (G%mask2dCv(i,J-1) * fv_prev(i,J-1) + G%mask2dCv(i,J+1) * fv_prev(i,J+1))) & + + ((G%mask2dCv(i-1,J-1) * fv_prev(i-1,J-1) + G%mask2dCv(i+1,J+1) * fv_prev(i+1,J+1)) + & + (G%mask2dCv(i-1,J+1) * fv_prev(i-1,J+1) + G%mask2dCv(i+1,J-1) * fv_prev(i-1,J-1))) )) + endif ; enddo ; enddo + enddo + +end subroutine smooth_x9_uv + end module MOM_stochastics diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 472ee21e36..0d3a148458 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -1,3 +1,7 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> This module contains the routines used to apply sponge layers when using !! the ALE mode. !! @@ -11,21 +15,24 @@ module MOM_ALE_sponge -! This file is part of MOM6. See LICENSE.md for the license. use MOM_array_transform, only: rotate_array use MOM_coms, only : sum_across_PEs use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field use MOM_diag_mediator, only : diag_ctrl -use MOM_domains, only : pass_var +use MOM_domains, only : pass_var, To_ALL, Omit_Corners use MOM_error_handler, only : MOM_error, FATAL, NOTE, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_horizontal_regridding, only : horiz_interp_and_extrap_tracer -use MOM_interpolate, only : init_external_field, get_external_field_info, time_interp_external_init +use MOM_interpolate, only : init_external_field, time_interp_external_init +use MOM_interpolate, only : get_external_field_info +use MOM_interpolate, only : external_field +use MOM_io, only : axis_info use MOM_remapping, only : remapping_cs, remapping_core_h, initialize_remapping use MOM_spatial_means, only : global_i_mean use MOM_time_manager, only : time_type use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -65,21 +72,26 @@ module MOM_ALE_sponge ! vary with the Boussinesq approximation, the Boussinesq variant is given first. !> A structure for creating arrays of pointers to 3D arrays with extra gridding information -type :: p3d - integer :: id !< id for FMS external time interpolator +type :: p3d ; private + !integer :: id !< id for FMS external time interpolator integer :: nz_data !< The number of vertical levels in the input field. integer :: num_tlevs !< The number of time records contained in the file - real, dimension(:,:,:), pointer :: p => NULL() !< pointer to the data. - real, dimension(:,:,:), pointer :: h => NULL() !< pointer to the data grid. + real, dimension(:,:,:), pointer :: p => NULL() !< pointer to the data [various] + real, dimension(:,:,:), pointer :: dz => NULL() !< pointer to the data grid spacing [Z ~> m] end type p3d !> A structure for creating arrays of pointers to 2D arrays with extra gridding information -type :: p2d - integer :: id !< id for FMS external time interpolator +type :: p2d ; private + type(external_field) :: field !< Time interpolator field handle integer :: nz_data !< The number of vertical levels in the input field integer :: num_tlevs !< The number of time records contained in the file - real, dimension(:,:), pointer :: p => NULL() !< pointer the data. - real, dimension(:,:), pointer :: h => NULL() !< pointer the data grid. + real :: scale = 1.0 !< A multiplicative factor by which to rescale input data [various] + real, dimension(:,:), pointer :: p => NULL() !< pointer to the data [various] + real, dimension(:,:), pointer :: dz => NULL() !< pointer to the data grid spacing [Z ~> m] + character(len=:), allocatable :: name !< The name of the input field + character(len=:), allocatable :: long_name !< The long name of the input field + character(len=:), allocatable :: unit !< The unit of the input field + type(axis_info), allocatable :: axes_data(:) !< Axis types for the input field end type p2d !> ALE sponge control structure @@ -109,30 +121,33 @@ module MOM_ALE_sponge type(p2d) :: Ref_val_v !< The values to which the v-velocities are damped. type(p3d) :: var_u !< Pointer to the u velocities that are being damped. type(p3d) :: var_v !< Pointer to the v velocities that are being damped. - type(p2d) :: Ref_h !< Grid on which reference data is provided (older code). - type(p2d) :: Ref_hu !< u-point grid on which reference data is provided (older code). - type(p2d) :: Ref_hv !< v-point grid on which reference data is provided (older code). + type(p2d) :: Ref_dz !< Grid on which reference data is provided (older code). + type(p2d) :: Ref_dzu !< u-point grid on which reference data is provided (older code). + type(p2d) :: Ref_dzv !< v-point grid on which reference data is provided (older code). type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. type(remapping_cs) :: remap_cs !< Remapping parameters and work arrays - logical :: remap_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. - logical :: hor_regrid_answers_2018 !< If true, use the order of arithmetic for horizontal regridding - !! that recovers the answers from the end of 2018. Otherwise, use - !! rotationally symmetric forms of the same expressions. + integer :: 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. + integer :: hor_regrid_answer_date !< The vintage of the order of arithmetic and expressions to use + !! for horizontal regridding. Values below 20190101 recover the + !! answers from 2018, while higher values use expressions that have + !! been rearranged for rotational invariance. logical :: time_varying_sponges !< True if using newer sponge code - logical :: spongeDataOngrid !< True if the sponge data are on the model horizontal grid - - logical :: reentrant_x !< grid is reentrant in the x direction - logical :: tripolar_N !< grid is folded at its north edge + logical :: spongeDataOngrid !< True if the sponge data are on the model horizontal grid + real :: varying_input_dz_mask !< An input file thickness below which the target values with time-varying + !! sponges are replaced by the value above [Z ~> m]. + !! It is not clear why this needs to be greater than 0. !>@{ Diagnostic IDs - integer, dimension(2) :: id_sp_tendency !< Diagnostic ids for temperature and salinity - !! tendency due to sponges + integer, dimension(MAX_FIELDS_) :: id_sp_tendency = reshape([-1], [MAX_FIELDS_], [-1]) !< Diagnostic ids for tracer + !! tendencies due to sponges. + !! Init all to -1. integer :: id_sp_u_tendency !< Diagnostic id for zonal momentum tendency due to !! Rayleigh damping integer :: id_sp_v_tendency !< Diagnostic id for meridional momentum tendency due to @@ -143,12 +158,12 @@ module MOM_ALE_sponge !> This subroutine determines the number of points which are within sponges in this computational !! domain. Only points that have positive values of Iresttime and which mask2dT indicates are ocean -!! points are included in the sponges. It also stores the target interface heights. This +!! points are included in the sponges. It also stores the target interface heights. subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, nz_data, & - Iresttime_u_in, Iresttime_v_in) + Iresttime_u_in, Iresttime_v_in, data_h_is_Z) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure integer, intent(in) :: nz_data !< The total number of sponge input layers. real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: Iresttime !< The inverse of the restoring time [T-1 ~> s-1]. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file @@ -156,23 +171,32 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module (in/out). real, dimension(SZI_(G),SZJ_(G),nz_data), intent(inout) :: data_h !< The thicknesses of the sponge - !! input layers [H ~> m or kg m-2]. - real, dimension(SZIB_(G),SZJ_(G)), intent(in), optional :: Iresttime_u_in !< The inverse of the restoring + !! input layers, in [H ~> m or kg m-2] or [Z ~> m] + !! depending on data_h_is_Z. + real, dimension(SZIB_(G),SZJ_(G)), optional, intent(in) :: Iresttime_u_in !< The inverse of the restoring !! time at U-points [T-1 ~> s-1]. - real, dimension(SZI_(G),SZJB_(G)), intent(in), optional :: Iresttime_v_in !< The inverse of the restoring - ! time at v-points [T-1 ~> s-1]. - + real, dimension(SZI_(G),SZJB_(G)), optional, intent(in) :: Iresttime_v_in !< The inverse of the restoring + !! time at v-points [T-1 ~> s-1]. + logical, optional, intent(in) :: data_h_is_Z !< If present and true data_h is already in + !! depth units. Omitting this is the same as setting + !! it to false. -! This include declares and sets the variable "version". -#include "version_variable.h" + ! Local variables character(len=40) :: mdl = "MOM_sponge" ! This module's name. - logical :: use_sponge 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, dimension(SZI_(G),SZJ_(G),nz_data) :: data_dz !< The vertical extent of the sponge + !! input layers [Z ~> m]. + real :: data_h_to_Z_scale ! A scaling factor to convert data_h into the right units, often [Z H-1 ~> 1 or m3 kg-1] + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=64) :: remapScheme + logical :: use_sponge logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries - logical :: default_2018_answers + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v - character(len=10) :: remapScheme + if (associated(CS)) then call MOM_error(WARNING, "initialize_ALE_sponge_fixed called with an associated "// & "control structure.") @@ -195,40 +219,54 @@ 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, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", CS%remap_answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) - call get_param(param_file, mdl, "HOR_REGRID_2018_ANSWERS", CS%hor_regrid_answers_2018, & - "If true, use the order of arithmetic for horizontal regridding that recovers "//& - "the answers from the end of 2018. Otherwise, use rotationally symmetric "//& - "forms of the same expressions.", default=default_2018_answers) - call get_param(param_file, mdl, "REENTRANT_X", CS%reentrant_x, & - "If true, the domain is zonally reentrant.", default=.true.) - call get_param(param_file, mdl, "TRIPOLAR_N", CS%tripolar_N, & - "Use tripolar connectivity at the northern edge of the "//& - "domain. With TRIPOLAR_N, NIGLOBAL must be even.", default=.false.) + 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) + call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%remap_answer_date, & + "The vintage of the expressions and order of arithmetic to use for remapping. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%remap_answer_date = max(CS%remap_answer_date, 20230701) + 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, "SPONGE_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for ALE sponge. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=om4_remap_via_sub_cells) + + call get_param(param_file, mdl, "HOR_REGRID_ANSWER_DATE", CS%hor_regrid_answer_date, & + "The vintage of the order of arithmetic for horizontal regridding. "//& + "Dates before 20190101 give the same answers as the code did in late 2018, "//& + "while later versions add parentheses for rotational symmetry. "//& + "Dates after 20230101 use reproducing sums for global averages.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%hor_regrid_answer_date = max(CS%hor_regrid_answer_date, 20230701) CS%time_varying_sponges = .false. CS%nz = GV%ke + data_h_to_Z_scale = GV%H_to_Z ; if (present(data_h_is_Z)) data_h_to_Z_scale = 1.0 + + do k=1,nz_data ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + data_dz(i,j,k) = data_h_to_Z_scale * data_h(i,j,k) + enddo ; enddo ; enddo ! number of columns to be restored CS%num_col = 0 ; CS%fldno = 0 do j=G%jsc,G%jec ; do i=G%isc,G%iec - if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) & + if ((Iresttime(i,j) > 0.0) .and. (G%mask2dT(i,j) > 0.0)) & CS%num_col = CS%num_col + 1 enddo ; enddo @@ -239,17 +277,17 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, ! pass indices, restoring time to the CS structure col = 1 do j=G%jsc,G%jec ; do i=G%isc,G%iec - if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) then + if ((Iresttime(i,j) > 0.0) .and. (G%mask2dT(i,j) > 0.0)) then CS%col_i(col) = i ; CS%col_j(col) = j CS%Iresttime_col(col) = Iresttime(i,j) - col = col +1 + col = col + 1 endif enddo ; enddo ! same for total number of arbitrary layers and correspondent data CS%nz_data = nz_data - allocate(CS%Ref_h%p(CS%nz_data,CS%num_col)) + allocate(CS%Ref_dz%p(CS%nz_data,CS%num_col), source=0.0) do col=1,CS%num_col ; do K=1,CS%nz_data - CS%Ref_h%p(K,col) = data_h(CS%col_i(col),CS%col_j(col),K) + CS%Ref_dz%p(K,col) = data_dz(CS%col_i(col),CS%col_j(col),K) enddo ; enddo endif @@ -258,7 +296,8 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, ! Call the constructor for remapping control structure call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation, & - answers_2018=CS%remap_answers_2018) + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & + answer_date=CS%remap_answer_date) call log_param(param_file, mdl, "!Total sponge columns at h points", total_sponge_cols, & "The total number of columns where sponges are applied at h points.", like_default=.true.) @@ -267,21 +306,21 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, allocate(Iresttime_u(G%isdB:G%iedB,G%jsd:G%jed), source=0.0) allocate(Iresttime_v(G%isd:G%ied,G%jsdB:G%jedB), source=0.0) - call pass_var(Iresttime,G%Domain) - call pass_var(data_h,G%Domain) + call pass_var(Iresttime, G%Domain, To_All+Omit_Corners, halo=1) + call pass_var(data_dz, G%Domain, To_All+Omit_Corners, halo=1) ! u points - CS%num_col_u = 0 ; + CS%num_col_u = 0 if (present(Iresttime_u_in)) then - Iresttime_u(:,:) = Iresttime_u_in(:,:) + Iresttime_u(:,:) = Iresttime_u_in(:,:) else do j=G%jsc,G%jec ; do I=G%iscB,G%iecB Iresttime_u(I,j) = 0.5 * (Iresttime(i,j) + Iresttime(i+1,j)) enddo ; enddo endif do j=G%jsc,G%jec ; do I=G%iscB,G%iecB - if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) & - CS%num_col_u = CS%num_col_u + 1 + if ((Iresttime_u(I,j) > 0.0) .and. (G%mask2dCu(I,j) > 0.0)) & + CS%num_col_u = CS%num_col_u + 1 enddo ; enddo if (CS%num_col_u > 0) then @@ -293,7 +332,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, ! Store the column indices and restoring rates in the CS structure col = 1 do j=G%jsc,G%jec ; do I=G%iscB,G%iecB - if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) then + if ((Iresttime_u(I,j) > 0.0) .and. (G%mask2dCu(I,j) > 0.0)) then CS%col_i_u(col) = I ; CS%col_j_u(col) = j CS%Iresttime_col_u(col) = Iresttime_u(I,j) col = col + 1 @@ -301,11 +340,11 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, enddo ; enddo ! same for total number of arbitrary layers and correspondent data - allocate(CS%Ref_hu%p(CS%nz_data,CS%num_col_u)) + allocate(CS%Ref_dzu%p(CS%nz_data,CS%num_col_u), source=0.0) do col=1,CS%num_col_u I = CS%col_i_u(col) ; j = CS%col_j_u(col) do k=1,CS%nz_data - CS%Ref_hu%p(k,col) = 0.5 * (data_h(i,j,k) + data_h(i+1,j,k)) + CS%Ref_dzu%p(k,col) = 0.5 * (data_dz(i,j,k) + data_dz(i+1,j,k)) enddo enddo endif @@ -315,16 +354,16 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, "The total number of columns where sponges are applied at u points.", like_default=.true.) ! v points - CS%num_col_v = 0 ; + CS%num_col_v = 0 if (present(Iresttime_v_in)) then Iresttime_v(:,:) = Iresttime_v_in(:,:) else - do J=G%jscB,G%jecB; do i=G%isc,G%iec + do J=G%jscB,G%jecB ; do i=G%isc,G%iec Iresttime_v(i,J) = 0.5 * (Iresttime(i,j) + Iresttime(i,j+1)) enddo ; enddo endif - do J=G%jscB,G%jecB; do i=G%isc,G%iec - if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) & + do J=G%jscB,G%jecB ; do i=G%isc,G%iec + if ((Iresttime_v(i,J) > 0.0) .and. (G%mask2dCv(i,J) > 0.0)) & CS%num_col_v = CS%num_col_v + 1 enddo ; enddo @@ -337,7 +376,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, ! pass indices, restoring time to the CS structure col = 1 do J=G%jscB,G%jecB ; do i=G%isc,G%iec - if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) then + if ((Iresttime_v(i,J) > 0.0) .and. (G%mask2dCv(i,J) > 0.0)) then CS%col_i_v(col) = i ; CS%col_j_v(col) = j CS%Iresttime_col_v(col) = Iresttime_v(i,j) col = col + 1 @@ -345,11 +384,11 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, enddo ; enddo ! same for total number of arbitrary layers and correspondent data - allocate(CS%Ref_hv%p(CS%nz_data,CS%num_col_v)) + allocate(CS%Ref_dzv%p(CS%nz_data,CS%num_col_v), source=0.0) do col=1,CS%num_col_v i = CS%col_i_v(col) ; J = CS%col_j_v(col) do k=1,CS%nz_data - CS%Ref_hv%p(k,col) = 0.5 * (data_h(i,j,k) + data_h(i,j+1,k)) + CS%Ref_dzv%p(k,col) = 0.5 * (data_dz(i,j,k) + data_dz(i,j+1,k)) enddo enddo endif @@ -371,15 +410,22 @@ function get_ALE_sponge_nz_data(CS) end function get_ALE_sponge_nz_data !> Return the thicknesses used for the data with a fixed ALE sponge -subroutine get_ALE_sponge_thicknesses(G, data_h, sponge_mask, CS) +subroutine get_ALE_sponge_thicknesses(G, GV, data_h, sponge_mask, CS, data_h_in_Z) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, allocatable, dimension(:,:,:), & - intent(inout) :: data_h !< The thicknesses of the sponge input layers [H ~> m or kg m-2]. + intent(inout) :: data_h !< The thicknesses of the sponge input layers expressed + !! as vertical extents [Z ~> m] or in thickness units + !! [H ~> m or kg m-2], depending on the value of data_h_in_Z. logical, dimension(SZI_(G),SZJ_(G)), & intent(out) :: sponge_mask !< A logical mask that is true where !! sponges are being applied. type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for the ALE_sponge module. + logical, optional, intent(in) :: data_h_in_Z !< If present and true data_h is returned in + !! depth units. Omitting this is the same as setting + !! it to false. + real :: Z_to_data_h_units ! A scaling factor to return data_h in the right units, often [H Z-1 ~> 1 or kg m-3] integer :: c, i, j, k if (allocated(data_h)) call MOM_error(FATAL, & @@ -395,11 +441,13 @@ subroutine get_ALE_sponge_thicknesses(G, data_h, sponge_mask, CS) allocate(data_h(G%isd:G%ied,G%jsd:G%jed,CS%nz_data), source=-1.0) sponge_mask(:,:) = .false. + Z_to_data_h_units = GV%Z_to_H ; if (present(data_h_in_Z)) Z_to_data_h_units = 1.0 + do c=1,CS%num_col i = CS%col_i(c) ; j = CS%col_j(c) sponge_mask(i,j) = .true. do k=1,CS%nz_data - data_h(i,j,k) = CS%Ref_h%p(k,c) + data_h(i,j,k) = Z_to_data_h_units*CS%Ref_dz%p(k,c) enddo enddo @@ -408,10 +456,11 @@ end subroutine get_ALE_sponge_thicknesses !> This subroutine determines the number of points which are to be restored in the computational !! domain. Only points that have positive values of Iresttime and which mask2dT indicates are ocean !! points are included in the sponges. -subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Iresttime_u_in, Iresttime_v_in) +subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, US, param_file, CS, Iresttime_u_in, Iresttime_v_in) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: Iresttime !< The inverse of the restoring time [T-1 ~> s-1]. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to parse !! for model parameter values. @@ -422,17 +471,19 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest real, dimension(SZI_(G),SZJB_(G)), intent(in), optional :: Iresttime_v_in !< The inverse of the restoring time !! for v [T-1 ~> s-1]. -! This include declares and sets the variable "version". -#include "version_variable.h" + ! Local variables character(len=40) :: mdl = "MOM_sponge" ! This module's name. - logical :: use_sponge real, allocatable, dimension(:,:) :: Iresttime_u !< inverse of the restoring time at u points [T-1 ~> s-1] real, allocatable, dimension(:,:) :: Iresttime_v !< inverse of the restoring time at v points [T-1 ~> s-1] + real :: dz_neglect, dz_neglect_edge ! Negligible layer extents [Z ~> m] + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=64) :: remapScheme + logical :: use_sponge logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries - logical :: default_2018_answers - logical :: spongeDataOngrid = .false. - integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v - character(len=10) :: remapScheme + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm + integer :: i, j, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v if (associated(CS)) then call MOM_error(WARNING, "initialize_ALE_sponge_varying called with an associated "// & @@ -451,37 +502,46 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest "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, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", CS%remap_answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) - call get_param(param_file, mdl, "HOR_REGRID_2018_ANSWERS", CS%hor_regrid_answers_2018, & - "If true, use the order of arithmetic for horizontal regridding that recovers "//& - "the answers from the end of 2018 and retain a bug in the 3-dimensional mask "//& - "returned in certain cases. Otherwise, use rotationally symmetric "//& - "forms of the same expressions and initialize the mask properly.", & - default=default_2018_answers) + 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.", & + units="m", default=0.001, scale=US%m_to_Z) + + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%remap_answer_date, & + "The vintage of the expressions and order of arithmetic to use for remapping. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "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, "REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + do_not_log=.true., default=.true.) + call get_param(param_file, mdl, "SPONGE_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for ALE sponge. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=om4_remap_via_sub_cells) + call get_param(param_file, mdl, "HOR_REGRID_ANSWER_DATE", CS%hor_regrid_answer_date, & + "The vintage of the order of arithmetic for horizontal regridding. "//& + "Dates before 20190101 give the same answers as the code did in late 2018, "//& + "while later versions add parentheses for rotational symmetry. "//& + "Dates after 20230101 use reproducing sums for global averages.", & + default=default_answer_date) call get_param(param_file, mdl, "SPONGE_DATA_ONGRID", CS%spongeDataOngrid, & "When defined, the incoming sponge data are "//& "assumed to be on the model grid " , & default=.false.) - call get_param(param_file, mdl, "REENTRANT_X", CS%reentrant_x, & - "If true, the domain is zonally reentrant.", default=.true.) - call get_param(param_file, mdl, "TRIPOLAR_N", CS%tripolar_N, & - "Use tripolar connectivity at the northern edge of the "//& - "domain. With TRIPOLAR_N, NIGLOBAL must be even.", default=.false.) CS%time_varying_sponges = .true. CS%nz = GV%ke @@ -489,7 +549,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest ! number of columns to be restored CS%num_col = 0 ; CS%fldno = 0 do j=G%jsc,G%jec ; do i=G%isc,G%iec - if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) & + if ((Iresttime(i,j) > 0.0) .and. (G%mask2dT(i,j) > 0.0)) & CS%num_col = CS%num_col + 1 enddo ; enddo if (CS%num_col > 0) then @@ -499,7 +559,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest ! pass indices, restoring time to the CS structure col = 1 do j=G%jsc,G%jec ; do i=G%isc,G%iec - if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) then + if ((Iresttime(i,j) > 0.0) .and. (G%mask2dT(i,j) > 0.0)) then CS%col_i(col) = i ; CS%col_j(col) = j CS%Iresttime_col(col) = Iresttime(i,j) col = col + 1 @@ -510,15 +570,26 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest 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, & - answers_2018=CS%remap_answers_2018) + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & + answer_date=CS%remap_answer_date, & + h_neglect=dz_neglect, h_neglect_edge=dz_neglect_edge) call log_param(param_file, mdl, "!Total sponge columns at h points", total_sponge_cols, & "The total number of columns where sponges are applied at h points.", like_default=.true.) if (CS%sponge_uv) then allocate(Iresttime_u(G%isdB:G%iedB,G%jsd:G%jed), source=0.0) allocate(Iresttime_v(G%isd:G%ied,G%jsdB:G%jedB), source=0.0) - call pass_var(Iresttime,G%Domain) + call pass_var(Iresttime, G%Domain, To_All+Omit_Corners, halo=1) ! u points if (present(Iresttime_u_in)) then Iresttime_u(:,:) = Iresttime_u_in(:,:) @@ -527,9 +598,9 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest Iresttime_u(I,j) = 0.5 * (Iresttime(i,j) + Iresttime(i+1,j)) enddo ; enddo endif - CS%num_col_u = 0 ; - do j=G%jsc,G%jec; do I=G%iscB,G%iecB - if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) & + CS%num_col_u = 0 + do j=G%jsc,G%jec ; do I=G%iscB,G%iecB + if ((Iresttime_u(I,j) > 0.0) .and. (G%mask2dCu(I,j) > 0.0)) & CS%num_col_u = CS%num_col_u + 1 enddo ; enddo if (CS%num_col_u > 0) then @@ -539,7 +610,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest ! pass indices, restoring time to the CS structure col = 1 do j=G%jsc,G%jec ; do I=G%iscB,G%iecB - if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) then + if ((Iresttime_u(I,j) > 0.0) .and. (G%mask2dCu(I,j) > 0.0)) then CS%col_i_u(col) = i ; CS%col_j_u(col) = j CS%Iresttime_col_u(col) = Iresttime_u(i,j) col = col + 1 @@ -555,13 +626,13 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest if (present(Iresttime_v_in)) then Iresttime_v(:,:) = Iresttime_v_in(:,:) else - do J=G%jscB,G%jecB; do i=G%isc,G%iec + do J=G%jscB,G%jecB ; do i=G%isc,G%iec Iresttime_v(i,J) = 0.5 * (Iresttime(i,j) + Iresttime(i,j+1)) enddo ; enddo endif - CS%num_col_v = 0 ; - do J=G%jscB,G%jecB; do i=G%isc,G%iec - if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) & + CS%num_col_v = 0 + do J=G%jscB,G%jecB ; do i=G%isc,G%iec + if ((Iresttime_v(i,J) > 0.0) .and. (G%mask2dCv(i,J) > 0.0)) & CS%num_col_v = CS%num_col_v + 1 enddo ; enddo if (CS%num_col_v > 0) then @@ -571,7 +642,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest ! pass indices, restoring time to the CS structure col = 1 do J=G%jscB,G%jecB ; do i=G%isc,G%iec - if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) then + if ((Iresttime_v(i,J) > 0.0) .and. (G%mask2dCv(i,J) > 0.0)) then CS%col_i_v(col) = i ; CS%col_j_v(col) = j CS%Iresttime_col_v(col) = Iresttime_v(i,j) col = col + 1 @@ -595,15 +666,25 @@ subroutine init_ALE_sponge_diags(Time, G, diag, CS, US) !! output. type(ALE_sponge_CS), intent(inout) :: CS !< ALE sponge control structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + ! Local Variables + character(len=:), allocatable :: tend_unit ! The units for a sponge tendency diagnostic. + real :: tend_conv ! The conversion factor use for the sponge tendency [A T-1 ~> a s-1] + integer :: m CS%diag => diag - CS%id_sp_tendency(1) = -1 - CS%id_sp_tendency(1) = register_diag_field('ocean_model', 'sp_tendency_temp', diag%axesTL, Time, & - 'Time tendency due to temperature restoring', 'degC s-1', conversion=US%s_to_T) - CS%id_sp_tendency(2) = -1 - CS%id_sp_tendency(2) = register_diag_field('ocean_model', 'sp_tendency_salt', diag%axesTL, Time, & - 'Time tendency due to salinity restoring', 'g kg-1 s-1', conversion=US%s_to_T) + do m=1,CS%fldno + if ((trim(CS%Ref_val(m)%unit) == 'none') .or. (len_trim(CS%Ref_val(m)%unit) == 0)) then + tend_unit = "s-1" + else + tend_unit = trim(CS%Ref_val(m)%unit)//" s-1" + endif + tend_conv = US%s_to_T ; if (CS%Ref_val(m)%scale /= 0.0) tend_conv = US%s_to_T / CS%Ref_val(m)%scale + CS%id_sp_tendency(m) = register_diag_field('ocean_model', 'sp_tendency_'//CS%Ref_val(m)%name, & + diag%axesTL, Time, long_name='Time tendency due to restoring '//CS%Ref_val(m)%long_name, & + units=tend_unit, conversion=tend_conv) + enddo + CS%id_sp_u_tendency = -1 CS%id_sp_u_tendency = register_diag_field('ocean_model', 'sp_tendency_u', diag%axesCuL, Time, & 'Zonal acceleration due to sponges', 'm s-2', conversion=US%L_T2_to_m_s2) @@ -615,24 +696,42 @@ end subroutine init_ALE_sponge_diags !> This subroutine stores the reference profile at h points for the variable !! whose address is given by f_ptr. -subroutine set_up_ALE_sponge_field_fixed(sp_val, G, GV, f_ptr, CS) +subroutine set_up_ALE_sponge_field_fixed(sp_val, G, GV, f_ptr, CS, & + sp_name, sp_long_name, sp_unit, scale) type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(ALE_sponge_CS), pointer :: CS !< ALE sponge control structure (in/out). real, dimension(SZI_(G),SZJ_(G),CS%nz_data), & intent(in) :: sp_val !< Field to be used in the sponge, it can have an - !! arbitrary number of layers. + !! arbitrary number of layers [various] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - target, intent(in) :: f_ptr !< Pointer to the field to be damped - - integer :: j, k, col + target, intent(in) :: f_ptr !< Pointer to the field to be damped [various] + character(len=*), intent(in) :: sp_name !< The name of the tracer field + character(len=*), optional, & + intent(in) :: sp_long_name !< The long name of the tracer field + !! if not given, use the sp_name + character(len=*), optional, & + intent(in) :: sp_unit !< The unit of the tracer field + !! if not given, use the none + real, optional, intent(in) :: scale !< A factor by which to rescale the input data, including any + !! contributions due to dimensional rescaling [various ~> 1]. + !! The default is 1. + + real :: scale_fac ! A factor by which to scale sp_val before storing it [various ~> 1] + integer :: k, col character(len=256) :: mesg ! String for error messages + character(len=256) :: long_name ! The long name of the tracer field + character(len=256) :: unit ! The unit of the tracer field if (.not.associated(CS)) return + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + long_name = sp_name ; if (present(sp_long_name)) long_name = sp_long_name + unit = 'none' ; if (present(sp_unit)) unit = sp_unit + CS%fldno = CS%fldno + 1 if (CS%fldno > MAX_FIELDS_) then - write(mesg,'("Increase MAX_FIELDS_ to at least ",I3," in MOM_memory.h or decrease & + write(mesg,'("Increase MAX_FIELDS_ to at least ",I0," in MOM_memory.h or decrease & &the number of fields to be damped in the call to & &initialize_ALE_sponge." )') CS%fldno call MOM_error(FATAL,"set_up_ALE_sponge_field: "//mesg) @@ -640,10 +739,14 @@ subroutine set_up_ALE_sponge_field_fixed(sp_val, G, GV, f_ptr, CS) ! stores the reference profile CS%Ref_val(CS%fldno)%nz_data = CS%nz_data + CS%Ref_val(CS%fldno)%name = sp_name + CS%Ref_val(CS%fldno)%long_name = long_name + CS%Ref_val(CS%fldno)%unit = unit + CS%Ref_val(CS%fldno)%scale = scale_fac allocate(CS%Ref_val(CS%fldno)%p(CS%nz_data,CS%num_col), source=0.0) do col=1,CS%num_col do k=1,CS%nz_data - CS%Ref_val(CS%fldno)%p(k,col) = sp_val(CS%col_i(col),CS%col_j(col),k) + CS%Ref_val(CS%fldno)%p(k,col) = scale_fac*sp_val(CS%col_i(col),CS%col_j(col),k) enddo enddo @@ -653,7 +756,8 @@ end subroutine set_up_ALE_sponge_field_fixed !> This subroutine stores the reference profile at h points for the variable !! whose address is given by filename and fieldname. -subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, f_ptr, CS) +subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, f_ptr, CS, & + sp_name, sp_long_name, sp_unit, scale) character(len=*), intent(in) :: filename !< The name of the file with the !! time varying field data character(len=*), intent(in) :: fieldname !< The name of the field in the file @@ -663,57 +767,67 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - target, intent(in) :: f_ptr !< Pointer to the field to be damped (in). + target, intent(in) :: f_ptr !< Pointer to the field to be damped (in) [various]. type(ALE_sponge_CS), pointer :: CS !< Sponge control structure (in/out). + character(len=*), intent(in) :: sp_name !< The name of the tracer field + character(len=*), optional, & + intent(in) :: sp_long_name !< The long name of the tracer field + !! if not given, use the sp_name + character(len=*), optional, & + intent(in) :: sp_unit !< The unit of the tracer field + !! if not given, use 'none' + real, optional, intent(in) :: scale !< A factor by which to rescale the input data, including any + !! contributions due to dimensional rescaling [various ~> 1]. ! Local variables - real, allocatable, dimension(:,:,:) :: sp_val !< Field to be used in the sponge - real, allocatable, dimension(:,:,:) :: mask_z !< Field mask for the sponge data - real, allocatable, dimension(:), target :: z_in, z_edges_in ! Heights [Z ~> m]. - real :: missing_value - integer :: j, k, col - integer :: isd,ied,jsd,jed - integer :: nPoints + integer :: isd, ied, jsd, jed integer, dimension(4) :: fld_sz integer :: nz_data !< the number of vertical levels in this input field character(len=256) :: mesg ! String for error messages + character(len=256) :: long_name ! The long name of the tracer field + character(len=256) :: unit ! The unit of the tracer field + long_name = sp_name ; if (present(sp_long_name)) long_name = sp_long_name + unit = 'none' ; if (present(sp_unit)) unit = sp_unit + ! Local variables for ALE remapping - real :: zTopOfCell, zBottomOfCell ! Heights [Z ~> m]. - type(remapping_CS) :: remapCS ! Remapping parameters and work arrays if (.not.associated(CS)) return ! initialize time interpolator module call time_interp_external_init() - isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed CS%fldno = CS%fldno + 1 if (CS%fldno > MAX_FIELDS_) then - write(mesg, '("Increase MAX_FIELDS_ to at least ",I3," in MOM_memory.h or decrease "//& - "the number of fields to be damped in the call to initialize_ALE_sponge." )') CS%fldno + write(mesg, '("Increase MAX_FIELDS_ to at least ",I0," in MOM_memory.h or decrease "//& + &"the number of fields to be damped in the call to initialize_ALE_sponge." )') CS%fldno call MOM_error(FATAL,"set_up_ALE_sponge_field: "//mesg) endif ! get a unique time interp id for this field. If sponge data is on-grid, then setup ! to only read on the computational domain if (CS%spongeDataOngrid) then - CS%Ref_val(CS%fldno)%id = init_external_field(filename, fieldname, MOM_domain=G%Domain) + CS%Ref_val(CS%fldno)%field = init_external_field(filename, fieldname, MOM_domain=G%Domain) else - CS%Ref_val(CS%fldno)%id = init_external_field(filename, fieldname) + CS%Ref_val(CS%fldno)%field = init_external_field(filename, fieldname) endif + CS%Ref_val(CS%fldno)%name = sp_name + CS%Ref_val(CS%fldno)%long_name = long_name + CS%Ref_val(CS%fldno)%unit = unit fld_sz(1:4) = -1 - call get_external_field_info(CS%Ref_val(CS%fldno)%id, size=fld_sz) + call get_external_field_info(CS%Ref_val(CS%fldno)%field, size=fld_sz, axes=CS%Ref_val(CS%fldno)%axes_data) nz_data = fld_sz(3) CS%Ref_val(CS%fldno)%nz_data = nz_data !< individual sponge fields may reside on a different vertical grid CS%Ref_val(CS%fldno)%num_tlevs = fld_sz(4) + CS%Ref_val(CS%fldno)%scale = 1.0 ; if (present(scale)) CS%Ref_val(CS%fldno)%scale = scale ! initializes the target profile array for this field ! for all columns which will be masked allocate(CS%Ref_val(CS%fldno)%p(nz_data,CS%num_col), source=0.0) - allocate(CS%Ref_val(CS%fldno)%h(nz_data,CS%num_col), source=0.0) + allocate(CS%Ref_val(CS%fldno)%dz(nz_data,CS%num_col), source=0.0) CS%var(CS%fldno)%p => f_ptr end subroutine set_up_ALE_sponge_field_varying !> This subroutine stores the reference profile at u and v points for the variable !! whose address is given by u_ptr and v_ptr. -subroutine set_up_ALE_sponge_vel_field_fixed(u_val, v_val, G, GV, u_ptr, v_ptr, CS) +subroutine set_up_ALE_sponge_vel_field_fixed(u_val, v_val, G, GV, u_ptr, v_ptr, CS, scale) type(ocean_grid_type), intent(in) :: G !< Grid structure (in). type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(ALE_sponge_CS), pointer :: CS !< Sponge structure (in/out). @@ -727,24 +841,29 @@ subroutine set_up_ALE_sponge_vel_field_fixed(u_val, v_val, G, GV, u_ptr, v_ptr, !! have fewer layers than the model itself, but not more. real, target, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u_ptr !< u-field to be damped [L T-1 ~> m s-1] real, target, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v_ptr !< v-field to be damped [L T-1 ~> m s-1] + real, optional, intent(in) :: scale !< A factor by which to rescale the input data, including any + !! contributions due to dimensional rescaling [various ~> 1]. + !! The default is 1. - integer :: j, k, col, fld_sz(4) - character(len=256) :: mesg ! String for error messages + real :: scale_fac ! A dimensional rescaling factor [various ~> 1] + integer :: k, col if (.not.associated(CS)) return + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + ! stores the reference profile allocate(CS%Ref_val_u%p(CS%nz_data,CS%num_col_u), source=0.0) do col=1,CS%num_col_u do k=1,CS%nz_data - CS%Ref_val_u%p(k,col) = u_val(CS%col_i_u(col),CS%col_j_u(col),k) + CS%Ref_val_u%p(k,col) = scale_fac*u_val(CS%col_i_u(col),CS%col_j_u(col),k) enddo enddo CS%var_u%p => u_ptr allocate(CS%Ref_val_v%p(CS%nz_data,CS%num_col_v), source=0.0) do col=1,CS%num_col_v do k=1,CS%nz_data - CS%Ref_val_v%p(k,col) = v_val(CS%col_i_v(col),CS%col_j_v(col),k) + CS%Ref_val_v%p(k,col) = scale_fac*v_val(CS%col_i_v(col),CS%col_j_v(col),k) enddo enddo CS%var_v%p => v_ptr @@ -754,7 +873,7 @@ end subroutine set_up_ALE_sponge_vel_field_fixed !> This subroutine stores the reference profile at u and v points for the variable !! whose address is given by u_ptr and v_ptr. subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename_v, fieldname_v, & - Time, G, GV, US, CS, u_ptr, v_ptr) + Time, G, GV, US, CS, u_ptr, v_ptr, scale) character(len=*), intent(in) :: filename_u !< File name for u field character(len=*), intent(in) :: fieldname_u !< Name of u variable in file character(len=*), intent(in) :: filename_v !< File name for v field @@ -766,100 +885,102 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename type(ALE_sponge_CS), pointer :: CS !< Sponge structure (in/out). real, target, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u_ptr !< u-field to be damped [L T-1 ~> m s-1] real, target, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v_ptr !< v-field to be damped [L T-1 ~> m s-1] + real, optional, intent(in) :: scale !< A factor by which to rescale the input data, including any + !! contributions due to dimensional rescaling, often in + !! [L s T-1 m-1 ~> 1]. For varying velocities the + !! default is the same as using US%m_s_to_L_T. ! Local variables - real, allocatable, dimension(:,:,:) :: u_val !< U field to be used in the sponge [L T-1 ~> m s-1]. - real, allocatable, dimension(:,:,:) :: v_val !< V field to be used in the sponge [L T-1 ~> m s-1]. - - real, allocatable, dimension(:), target :: z_in, z_edges_in - real :: missing_value logical :: override - - integer :: j, k, col integer :: isd, ied, jsd, jed integer :: isdB, iedB, jsdB, jedB integer, dimension(4) :: fld_sz - character(len=256) :: mesg ! String for error messages - integer :: tmp if (.not.associated(CS)) return override =.true. - isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed - isdB = G%isdB; iedB = G%iedB; jsdB = G%jsdB; jedB = G%jedB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + isdB = G%isdB ; iedB = G%iedB ; jsdB = G%jsdB ; jedB = G%jedB ! get a unique id for this field which will allow us to return an array ! containing time-interpolated values from an external file corresponding ! to the current model date. if (CS%spongeDataOngrid) then - CS%Ref_val_u%id = init_external_field(filename_u, fieldname_u, domain=G%Domain%mpp_domain) + CS%Ref_val_u%field = init_external_field(filename_u, fieldname_u, domain=G%Domain%mpp_domain) else - CS%Ref_val_u%id = init_external_field(filename_u, fieldname_u) + CS%Ref_val_u%field = init_external_field(filename_u, fieldname_u) endif - fld_sz(1:4)=-1 - call get_external_field_info(CS%Ref_val_u%id, size=fld_sz) + fld_sz(1:4) = -1 + call get_external_field_info(CS%Ref_val_u%field, size=fld_sz, axes=CS%Ref_val_u%axes_data) CS%Ref_val_u%nz_data = fld_sz(3) CS%Ref_val_u%num_tlevs = fld_sz(4) + CS%Ref_val_u%scale = US%m_s_to_L_T ; if (present(scale)) CS%Ref_val_u%scale = scale if (CS%spongeDataOngrid) then - CS%Ref_val_v%id = init_external_field(filename_v, fieldname_v, domain=G%Domain%mpp_domain) + CS%Ref_val_v%field = init_external_field(filename_v, fieldname_v, domain=G%Domain%mpp_domain) else - CS%Ref_val_v%id = init_external_field(filename_v, fieldname_v) + CS%Ref_val_v%field = init_external_field(filename_v, fieldname_v) endif - fld_sz(1:4)=-1 - call get_external_field_info(CS%Ref_val_v%id, size=fld_sz) + fld_sz(1:4) = -1 + call get_external_field_info(CS%Ref_val_v%field, size=fld_sz, axes=CS%Ref_val_v%axes_data) CS%Ref_val_v%nz_data = fld_sz(3) CS%Ref_val_v%num_tlevs = fld_sz(4) + CS%Ref_val_v%scale = US%m_s_to_L_T ; if (present(scale)) CS%Ref_val_v%scale = scale ! stores the reference profile allocate(CS%Ref_val_u%p(fld_sz(3),CS%num_col_u), source=0.0) - allocate(CS%Ref_val_u%h(fld_sz(3),CS%num_col_u), source=0.0) + allocate(CS%Ref_val_u%dz(fld_sz(3),CS%num_col_u), source=0.0) CS%var_u%p => u_ptr allocate(CS%Ref_val_v%p(fld_sz(3),CS%num_col_v), source=0.0) - allocate(CS%Ref_val_v%h(fld_sz(3),CS%num_col_v), source=0.0) + allocate(CS%Ref_val_v%dz(fld_sz(3),CS%num_col_v), source=0.0) CS%var_v%p => v_ptr end subroutine set_up_ALE_sponge_vel_field_varying !> This subroutine applies damping to the layers thicknesses, temp, salt and a variety of tracers !! for every column where there is damping. -subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) +subroutine apply_ALE_sponge(h, tv, dt, G, GV, US, CS, Time) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure (in). type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] (in) + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables real, intent(in) :: dt !< The amount of time covered by this call [T ~> s]. type(ALE_sponge_CS), pointer :: CS !< A pointer to the control structure for this module !! that is set by a previous call to initialize_ALE_sponge (in). type(time_type), intent(in) :: Time !< The current model date + ! Local variables real :: damp ! The timestep times the local damping coefficient [nondim]. real :: I1pdamp ! I1pdamp is 1/(1 + damp). [nondim]. - real :: m_to_Z ! A unit conversion factor from m to Z. - real, allocatable, dimension(:) :: tmp_val2 ! data values on the original grid - real, dimension(SZK_(GV)) :: tmp_val1 ! data values remapped to model grid - real, dimension(SZK_(GV)) :: h_col ! A column of thicknesses at h, u or v points [H ~> m or kg m-2] - real, allocatable, dimension(:,:,:) :: sp_val ! A temporary array for fields - real, allocatable, dimension(:,:,:) :: mask_z ! A temporary array for field mask at h pts - real, allocatable, dimension(:,:,:) :: mask_u ! A temporary array for field mask at u pts - real, allocatable, dimension(:,:,:) :: mask_v ! A temporary array for field mask at v pts - real, allocatable, dimension(:,:,:) :: tmp !< A temporary array for thermodynamic sponge tendency diagnostics, + real, allocatable, dimension(:) :: tmp_val2 ! data values on the original grid [various] + real, dimension(SZK_(GV)) :: tmp_val1 ! data values remapped to model grid [various] + real, dimension(SZK_(GV)) :: dz_col ! A column of thicknesses at h, u or v points [Z ~> m] + real, allocatable, dimension(:,:,:) :: sp_val ! A temporary array for fields [various] + real, allocatable, dimension(:,:,:) :: mask_z ! A temporary array for field mask at h pts [nondim] + real, allocatable, dimension(:,:,:) :: mask_u ! A temporary array for field mask at u pts [nondim] + real, allocatable, dimension(:,:,:) :: mask_v ! A temporary array for field mask at v pts [nondim] + real, allocatable, dimension(:,:,:) :: tmp !< A temporary array for thermodynamic sponge tendency + !! diagnostics [various] then in [various T-1 ~> various s-1] real, allocatable, dimension(:,:,:) :: tmp_u !< A temporary array for u sponge acceleration diagnostics + !! first in [L T-1 ~> m s-1] then in [L T-2 ~> m s-2] real, allocatable, dimension(:,:,:) :: tmp_v !< A temporary array for v sponge acceleration diagnostics - real, dimension(:), allocatable :: hsrc ! Source thicknesses [Z ~> m]. + !! first in [L T-1 ~> m s-1] then in [L T-2 ~> m s-2] + real, dimension(:), allocatable :: dz_src ! Source thicknesses [Z ~> m]. + real :: dz_model(SZI_(G),SZJ_(G),SZK_(GV)) ! Vertical distance across model layers [Z ~> m] + ! Local variables for ALE remapping - real, dimension(:), allocatable :: tmpT1d - integer :: c, m, nkmb, i, j, k, is, ie, js, je, nz, nz_data - integer :: col, total_sponge_cols + real, dimension(:), allocatable :: tmpT1d ! A temporary variable for ALE remapping [various] + integer :: c, m, i, j, k, is, ie, js, je, nz, nz_data real, allocatable, dimension(:), target :: z_in ! The depths (positive downward) in the input file [Z ~> m] real, allocatable, dimension(:), target :: z_edges_in ! The depths (positive downward) of the ! edges in the input file [Z ~> m] - real :: missing_value - real :: Idt ! The inverse of the timestep [T-1 ~> s-1] - real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] + real :: missing_value ! The missing value in the input data field [various] + real :: Idt ! The inverse of the timestep [T-1 ~> s-1] real :: zTopOfCell, zBottomOfCell ! Interface heights (positive upward) in the input dataset [Z ~> m]. - real :: sp_val_u ! Interpolation of sp_val to u-points - real :: sp_val_v ! Interpolation of sp_val to v-points + 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] integer :: nPoints is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -867,28 +988,21 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) Idt = 1.0/dt - if (.not.CS%remap_answers_2018) then - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - elseif (GV%Boussinesq) then - h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 - else - h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 - endif - if (CS%time_varying_sponges) then do m=1,CS%fldno nz_data = CS%Ref_val(m)%nz_data - call horiz_interp_and_extrap_tracer(CS%Ref_val(m)%id, Time, 1.0, G, sp_val, mask_z, z_in, & - z_edges_in, missing_value, CS%reentrant_x, CS%tripolar_N, .false., & - spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z, & - answers_2018=CS%hor_regrid_answers_2018) - allocate( hsrc(nz_data) ) + call horiz_interp_and_extrap_tracer(CS%Ref_val(m)%field, Time, G, sp_val, & + mask_z, z_in, z_edges_in, missing_value, & + scale=CS%Ref_val(m)%scale, spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z, & + answer_date=CS%hor_regrid_answer_date, axes=CS%Ref_val(m)%axes_data) + allocate( dz_src(nz_data) ) allocate( tmpT1d(nz_data) ) do c=1,CS%num_col + ! Set i and j to the structured indices of column c. i = CS%col_i(c) ; j = CS%col_j(c) CS%Ref_val(m)%p(1:nz_data,c) = sp_val(i,j,1:nz_data) ! Build the source grid - zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0; hsrc(:) = 0.0; tmpT1d(:) = -99.9 + zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0 ; dz_src(:) = 0.0 ; tmpT1d(:) = -99.9 do k=1,nz_data if (mask_z(CS%col_i(c),CS%col_j(c),k) == 1.0) then zBottomOfCell = -min( z_edges_in(k+1) - G%Z_ref, G%bathyT(CS%col_i(c),CS%col_j(c)) ) @@ -899,26 +1013,26 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) else ! This next block should only ever be reached over land tmpT1d(k) = -99.9 endif - hsrc(k) = zTopOfCell - zBottomOfCell - if (hsrc(k)>0.) nPoints = nPoints + 1 + dz_src(k) = zTopOfCell - zBottomOfCell + if (dz_src(k) > 0.) nPoints = nPoints + 1 zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k enddo ! In case data is deeper than model - hsrc(nz_data) = hsrc(nz_data) + ( zTopOfCell + G%bathyT(CS%col_i(c),CS%col_j(c)) ) - CS%Ref_val(m)%h(1:nz_data,c) = GV%Z_to_H*hsrc(1:nz_data) + dz_src(nz_data) = dz_src(nz_data) + ( zTopOfCell + G%bathyT(CS%col_i(c),CS%col_j(c)) ) + CS%Ref_val(m)%dz(1:nz_data,c) = dz_src(1:nz_data) CS%Ref_val(m)%p(1:nz_data,c) = tmpT1d(1:nz_data) do k=2,nz_data - if (CS%Ref_val(m)%h(k,c) <= 0.001*GV%m_to_H) & + if (CS%Ref_val(m)%dz(k,c) <= CS%varying_input_dz_mask) & ! some confusion here about why the masks are not correct returning from horiz_interp ! reverting to using a minimum thickness criteria CS%Ref_val(m)%p(k,c) = CS%Ref_val(m)%p(k-1,c) enddo enddo - deallocate(sp_val, mask_z, hsrc, tmpT1d) + deallocate(sp_val, mask_z, dz_src, tmpT1d) enddo endif - tmp_val1(:)=0.0;h_col(:)=0.0 + tmp_val1(:) = 0.0 ; dz_col(:) = 0.0 do m=1,CS%fldno nz_data = CS%Ref_val(m)%nz_data allocate(tmp_val2(CS%Ref_val(m)%nz_data)) @@ -926,22 +1040,26 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) allocate(tmp(G%isd:G%ied,G%jsd:G%jed,nz), source=0.0) endif do c=1,CS%num_col - ! c is an index for the next 3 lines but a multiplier for the rest of the loop - ! Therefore we use c as per C code and increment the index where necessary. + ! Set i and j to the structured indices of column c. i = CS%col_i(c) ; j = CS%col_j(c) damp = dt * CS%Iresttime_col(c) I1pdamp = 1.0 / (1.0 + damp) tmp_val2(1:nz_data) = CS%Ref_val(m)%p(1:nz_data,c) - do k=1,nz - h_col(k)=h(i,j,k) - enddo + if ((.not.GV%Boussinesq) .and. allocated(tv%SpV_avg)) then + do k=1,nz + dz_col(k) = GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + enddo + else + do k=1,nz + dz_col(k) = GV%H_to_Z * h(i,j,k) + enddo + endif if (CS%time_varying_sponges) then - - call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val(m)%h(1:nz_data,c), tmp_val2, & - CS%nz, h_col, tmp_val1, h_neglect, h_neglect_edge) + 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) else - call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_h%p(1:nz_data,c), tmp_val2, & - CS%nz, h_col, tmp_val1, h_neglect, h_neglect_edge) + 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) endif !Backward Euler method if (CS%id_sp_tendency(m) > 0) tmp(i,j,1:nz) = CS%var(m)%p(i,j,1:nz) @@ -962,26 +1080,25 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) if (CS%time_varying_sponges) then nz_data = CS%Ref_val_u%nz_data ! Interpolate from the external horizontal grid and in time - call horiz_interp_and_extrap_tracer(CS%Ref_val_u%id, Time, 1.0, G, sp_val, mask_z, z_in, & - z_edges_in, missing_value, CS%reentrant_x, CS%tripolar_N, .false., & - spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z,& - answers_2018=CS%hor_regrid_answers_2018) + call horiz_interp_and_extrap_tracer(CS%Ref_val_u%field, Time, G, sp_val, & + mask_z, z_in, z_edges_in, missing_value, & + scale=CS%Ref_val_u%scale, spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z, & + answer_date=CS%hor_regrid_answer_date, axes=CS%Ref_val_u%axes_data) ! Initialize mask_z halos to zero before pass_var, in case of no update mask_z(G%isc-1, G%jsc:G%jec, :) = 0. mask_z(G%iec+1, G%jsc:G%jec, :) = 0. - call pass_var(sp_val, G%Domain) - call pass_var(mask_z, G%Domain) + call pass_var(sp_val, G%Domain, To_All+Omit_Corners, halo=1) + call pass_var(mask_z, G%Domain, To_All+Omit_Corners, halo=1) allocate(mask_u(G%isdB:G%iedB,G%jsd:G%jed,1:nz_data)) - do j=G%jsc,G%jec; do I=G%iscB,G%iecB + do j=G%jsc,G%jec ; do I=G%iscB,G%iecB mask_u(I,j,1:nz_data) = min(mask_z(i,j,1:nz_data),mask_z(i+1,j,1:nz_data)) enddo ; enddo - allocate( hsrc(nz_data) ) + allocate( dz_src(nz_data) ) do c=1,CS%num_col_u - ! c is an index for the next 3 lines but a multiplier for the rest of the loop - ! Therefore we use c as per C code and increment the index where necessary. + ! Set i and j to the structured indices of column c. i = CS%col_i_u(c) ; j = CS%col_j_u(c) if (mask_u(i,j,1) == 1.0) then do k=1,nz_data @@ -992,7 +1109,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) CS%Ref_val_u%p(1:nz_data,c) = 0.0 endif ! Build the source grid - zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0; hsrc(:) = 0.0 + zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0 ; dz_src(:) = 0.0 do k=1,nz_data if (mask_u(i,j,k) == 1.0) then zBottomOfCell = -min( z_edges_in(k+1) - G%Z_ref, G%bathyT(i,j) ) @@ -1000,36 +1117,35 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) zBottomOfCell = -G%bathyT(i,j) else ! This next block should only ever be reached over land endif - hsrc(k) = zTopOfCell - zBottomOfCell - if (hsrc(k)>0.) nPoints = nPoints + 1 + dz_src(k) = zTopOfCell - zBottomOfCell + if (dz_src(k) > 0.) nPoints = nPoints + 1 zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k enddo ! In case data is deeper than model - hsrc(nz_data) = hsrc(nz_data) + ( zTopOfCell + G%bathyT(i,j) ) - CS%Ref_val_u%h(1:nz_data,c) = GV%Z_to_H*hsrc(1:nz_data) + dz_src(nz_data) = dz_src(nz_data) + ( zTopOfCell + G%bathyT(i,j) ) + CS%Ref_val_u%dz(1:nz_data,c) = dz_src(1:nz_data) enddo - deallocate(sp_val, mask_u, mask_z, hsrc) + deallocate(sp_val, mask_u, mask_z, dz_src) nz_data = CS%Ref_val_v%nz_data ! Interpolate from the external horizontal grid and in time - call horiz_interp_and_extrap_tracer(CS%Ref_val_v%id, Time, 1.0, G, sp_val, mask_z, z_in, & - z_edges_in, missing_value, CS%reentrant_x, CS%tripolar_N, .false., & - spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z,& - answers_2018=CS%hor_regrid_answers_2018) + call horiz_interp_and_extrap_tracer(CS%Ref_val_v%field, Time, G, sp_val, & + mask_z, z_in, z_edges_in, missing_value, & + scale=CS%Ref_val_v%scale, spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z,& + answer_date=CS%hor_regrid_answer_date, axes=CS%Ref_val_v%axes_data) ! Initialize mask_z halos to zero before pass_var, in case of no update mask_z(G%isc:G%iec, G%jsc-1, :) = 0. mask_z(G%isc:G%iec, G%jec+1, :) = 0. - call pass_var(sp_val, G%Domain) - call pass_var(mask_z, G%Domain) + call pass_var(sp_val, G%Domain, To_All+Omit_Corners, halo=1) + call pass_var(mask_z, G%Domain, To_All+Omit_Corners, halo=1) allocate(mask_v(G%isd:G%ied,G%jsdB:G%jedB,1:nz_data)) - do J=G%jscB,G%jecB; do i=G%isc,G%iec + do J=G%jscB,G%jecB ; do i=G%isc,G%iec mask_v(i,J,1:nz_data) = min(mask_z(i,j,1:nz_data),mask_z(i,j+1,1:nz_data)) enddo ; enddo - !call pass_var(mask_z,G%Domain) - allocate( hsrc(nz_data) ) + + allocate( dz_src(nz_data) ) do c=1,CS%num_col_v - ! c is an index for the next 3 lines but a multiplier for the rest of the loop - ! Therefore we use c as per C code and increment the index where necessary. + ! Set i and j to the structured indices of column c. i = CS%col_i_v(c) ; j = CS%col_j_v(c) if (mask_v(i,j,1) == 1.0) then do k=1,nz_data @@ -1040,7 +1156,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) CS%Ref_val_v%p(1:nz_data,c) = 0.0 endif ! Build the source grid - zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0; hsrc(:) = 0.0 + zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0 ; dz_src(:) = 0.0 do k=1,nz_data if (mask_v(i,j,k) == 1.0) then zBottomOfCell = -min( z_edges_in(k+1) - G%Z_ref, G%bathyT(i,j) ) @@ -1048,18 +1164,31 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) zBottomOfCell = -G%bathyT(i,j) else ! This next block should only ever be reached over land endif - hsrc(k) = zTopOfCell - zBottomOfCell - if (hsrc(k)>0.) nPoints = nPoints + 1 + dz_src(k) = zTopOfCell - zBottomOfCell + if (dz_src(k) > 0.) nPoints = nPoints + 1 zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k enddo ! In case data is deeper than model - hsrc(nz_data) = hsrc(nz_data) + ( zTopOfCell + G%bathyT(i,j) ) - CS%Ref_val_v%h(1:nz_data,c) = GV%Z_to_H*hsrc(1:nz_data) + dz_src(nz_data) = dz_src(nz_data) + ( zTopOfCell + G%bathyT(i,j) ) + CS%Ref_val_v%dz(1:nz_data,c) = dz_src(1:nz_data) enddo - deallocate(sp_val, mask_v, mask_z, hsrc) + deallocate(sp_val, mask_v, mask_z, dz_src) + endif + + ! Because we can not be certain whether there are velocity points at the processor + ! boundaries, and the thicknesses might not have been updated there, we need to + ! calculate the tracer point layer vertical extents and then do a halo update. + if ((.not.GV%Boussinesq) .and. allocated(tv%SpV_avg)) then + do k=1,nz ; do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + dz_model(i,j,k) = GV%H_to_RZ * (h(i,j,k)*tv%SpV_avg(i,j,k)) + enddo ; enddo ; enddo + else + do k=1,nz ; do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + dz_model(i,j,k) = GV%H_to_Z * h(i,j,k) + enddo ; enddo ; enddo endif + call pass_var(dz_model, G%Domain, To_All+Omit_Corners, halo=1) - call pass_var(h,G%Domain) nz_data = CS%Ref_val_u%nz_data allocate(tmp_val2(nz_data)) if (CS%id_sp_u_tendency > 0) then @@ -1072,14 +1201,14 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) I1pdamp = 1.0 / (1.0 + damp) tmp_val2(1:nz_data) = CS%Ref_val_u%p(1:nz_data,c) do k=1,nz - h_col(k) = 0.5 * (h(i,j,k) + h(i+1,j,k)) + dz_col(k) = 0.5 * (dz_model(i,j,k) + dz_model(i+1,j,k)) enddo if (CS%time_varying_sponges) then - call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val_u%h(1:nz_data,c), tmp_val2, & - CS%nz, h_col, tmp_val1, h_neglect, h_neglect_edge) + 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) else - call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_hu%p(1:nz_data,c), tmp_val2, & - CS%nz, h_col, tmp_val1, h_neglect, h_neglect_edge) + 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) 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 @@ -1105,14 +1234,14 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) if (CS%time_varying_sponges) nz_data = CS%Ref_val_v%nz_data tmp_val2(1:nz_data) = CS%Ref_val_v%p(1:nz_data,c) do k=1,nz - h_col(k) = 0.5 * (h(i,j,k) + h(i,j+1,k)) + dz_col(k) = 0.5 * (dz_model(i,j,k) + dz_model(i,j+1,k)) enddo if (CS%time_varying_sponges) then - call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val_v%h(1:nz_data,c), tmp_val2, & - CS%nz, h_col, tmp_val1, h_neglect, h_neglect_edge) + 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) else - call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_hv%p(1:nz_data,c), tmp_val2, & - CS%nz, h_col, tmp_val1, h_neglect, h_neglect_edge) + 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) 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 @@ -1129,7 +1258,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) end subroutine apply_ALE_sponge !> Rotate the ALE sponge fields from the input to the model index map. -subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, turns, param_file) +subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, US, turns, param_file) type(ALE_sponge_CS), intent(in) :: sponge_in !< The control structure for this module with the !! original grid rotation type(ocean_grid_type), intent(in) :: G_in !< The ocean's grid structure with the original rotation. @@ -1137,6 +1266,7 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, turns, param_file) !! the new grid rotation type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure with the new rotation. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: turns !< The number of 90-degree turns between grids type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. @@ -1147,10 +1277,13 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, turns, param_file) ! 3. Call initialize_ALE_sponge using new grid and rotated Iresttime(:,:) ! All the index adjustment should follow from the Iresttime rotation - real, dimension(:,:), allocatable :: Iresttime_in, Iresttime - real, dimension(:,:,:), allocatable :: data_h_in, data_h - real, dimension(:,:,:), allocatable :: sp_val_in, sp_val - real, dimension(:,:,:), pointer :: sp_ptr => NULL() + real, dimension(:,:), allocatable :: Iresttime_in ! Restoring rate on the input sponges [T-1 ~> s-1] + real, dimension(:,:), allocatable :: Iresttime ! Restoring rate on the output sponges [T-1 ~> s-1] + real, dimension(:,:,:), allocatable :: data_dz_in ! Grid for the input sponges [Z ~> m] + real, dimension(:,:,:), allocatable :: data_dz ! Grid for the output sponges [Z ~> m] + real, dimension(:,:,:), allocatable :: sp_val_in ! Target data for the input sponges [various] + real, dimension(:,:,:), allocatable :: sp_val ! Target data for the output sponges [various] + real, dimension(:,:,:), pointer :: sp_ptr => NULL() ! Target data for the input sponges [various] integer :: c, c_i, c_j integer :: k, nz_data integer :: n @@ -1164,45 +1297,47 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, turns, param_file) if (fixed_sponge) then nz_data = sponge_in%nz_data - allocate(data_h_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed, nz_data), source=0.0) - allocate(data_h(G%isd:G%ied, G%jsd:G%jed, nz_data)) + allocate(data_dz_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed, nz_data), source=0.0) + allocate(data_dz(G%isd:G%ied, G%jsd:G%jed, nz_data)) endif - ! Re-populate the 2D Iresttime and data_h arrays on the original grid + ! Re-populate the 2D Iresttime and data_dz arrays on the original grid do c=1,sponge_in%num_col c_i = sponge_in%col_i(c) c_j = sponge_in%col_j(c) Iresttime_in(c_i, c_j) = sponge_in%Iresttime_col(c) if (fixed_sponge) then do k = 1, nz_data - data_h(c_i, c_j, k) = sponge_in%Ref_h%p(k,c) + data_dz_in(c_i, c_j, k) = sponge_in%Ref_dz%p(k,c) enddo endif enddo call rotate_array(Iresttime_in, turns, Iresttime) if (fixed_sponge) then - call rotate_array(data_h_in, turns, data_h) + call rotate_array(data_dz_in, turns, data_dz) call initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, sponge, & - data_h, nz_data) + data_dz, nz_data, data_h_is_Z=.true.) else - call initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, sponge) + call initialize_ALE_sponge_varying(Iresttime, G, GV, US, param_file, sponge) endif deallocate(Iresttime_in) deallocate(Iresttime) if (fixed_sponge) then - deallocate(data_h_in) - deallocate(data_h) + deallocate(data_dz_in) + deallocate(data_dz) endif ! Second part: Provide rotated fields for which relaxation is applied - sponge%fldno = sponge_in%fldno - if (fixed_sponge) then allocate(sp_val_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed, nz_data)) allocate(sp_val(G%isd:G%ied, G%jsd:G%jed, nz_data)) + ! For a fixed sponge, sponge%fldno is incremented from 0 in the calls to set_up_ALE_sponge_field. + sponge%fldno = 0 + else + sponge%fldno = sponge_in%fldno endif do n=1,sponge_in%fldno @@ -1221,21 +1356,23 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, turns, param_file) call rotate_array(sp_val_in, turns, sp_val) ! NOTE: This points sp_val with the unrotated field. See note below. - call set_up_ALE_sponge_field(sp_val, G, GV, sp_ptr, sponge) + call set_up_ALE_sponge_field(sp_val, G, GV, sp_ptr, sponge, & + sponge_in%Ref_val(n)%name, sp_long_name=sponge_in%Ref_val(n)%long_name, & + sp_unit=sponge_in%Ref_val(n)%unit) deallocate(sp_val_in) else ! We don't want to repeat FMS init in set_up_ALE_sponge_field_varying() ! (time_interp_external_init, init_external_field, etc), so we manually ! do a portion of this function below. - sponge%Ref_val(n)%id = sponge_in%Ref_val(n)%id + sponge%Ref_val(n)%field = sponge_in%Ref_val(n)%field sponge%Ref_val(n)%num_tlevs = sponge_in%Ref_val(n)%num_tlevs nz_data = sponge_in%Ref_val(n)%nz_data sponge%Ref_val(n)%nz_data = nz_data allocate(sponge%Ref_val(n)%p(nz_data, sponge_in%num_col), source=0.0) - allocate(sponge%Ref_val(n)%h(nz_data, sponge_in%num_col), source=0.0) + allocate(sponge%Ref_val(n)%dz(nz_data, sponge_in%num_col), source=0.0) ! TODO: There is currently no way to associate a generic field pointer to ! its rotated equivalent without introducing a new data structure which @@ -1253,8 +1390,7 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, turns, param_file) ! TODO: var_u and var_v sponge damping is not yet supported. if (associated(sponge_in%var_u%p) .or. associated(sponge_in%var_v%p)) & - call MOM_error(FATAL, "Rotation of ALE sponge velocities is not yet " & - // "implemented.") + call MOM_error(FATAL, "Rotation of ALE sponge velocities is not yet implemented.") ! Transfer any existing diag_CS reference pointer sponge%diag => sponge_in%diag @@ -1270,11 +1406,11 @@ end subroutine rotate_ALE_sponge subroutine update_ALE_sponge_field(sponge, p_old, G, GV, p_new) type(ALE_sponge_CS), intent(inout) :: sponge !< ALE sponge control struct real, dimension(:,:,:), & - target, intent(in) :: p_old !< The previous array of target values + target, intent(in) :: p_old !< The previous array of target values [various] type(ocean_grid_type), intent(in) :: G !< The updated ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - target, intent(in) :: p_new !< The new array of target values + target, intent(in) :: p_new !< The new array of target values [various] integer :: n diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 2ff0a21196..5e6c05dd42 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Provides the K-Profile Parameterization (KPP) of Large et al., 1994, via CVMix. module MOM_CVMix_KPP -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_coms, only : max_across_PEs use MOM_debugging, only : hchksum, is_NaN use MOM_diag_mediator, only : time_type, diag_ctrl, safe_alloc_ptr, post_data @@ -12,6 +14,8 @@ module MOM_CVMix_KPP use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_file_parser, only : openParameterBlock, closeParameterBlock use MOM_grid, only : ocean_grid_type, isPointInCell +use MOM_interface_heights, only : thickness_to_dz +use MOM_restart, only : MOM_restart_CS, register_restart_field use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -19,6 +23,7 @@ module MOM_CVMix_KPP use MOM_domains, only : pass_var use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE +use MOM_tracer_types, only : tracer_type use CVMix_kpp, only : CVMix_init_kpp, CVMix_put_kpp, CVMix_get_kpp_real use CVMix_kpp, only : CVMix_coeffs_kpp @@ -28,17 +33,20 @@ module MOM_CVMix_KPP use CVMix_kpp, only : CVMix_kpp_compute_unresolved_shear use CVMix_kpp, only : CVMix_kpp_params_type use CVMix_kpp, only : CVMix_kpp_compute_kOBL_depth +use CVMix_kpp, only : CVMix_kpp_compute_StokesXi implicit none ; private #include "MOM_memory.h" +public :: register_KPP_restarts public :: KPP_init public :: KPP_compute_BLD public :: KPP_calculate public :: KPP_end public :: KPP_NonLocalTransport_temp public :: KPP_NonLocalTransport_saln +public :: KPP_NonLocalTransport public :: KPP_get_BLD ! Enumerated constants @@ -71,28 +79,30 @@ module MOM_CVMix_KPP type, public :: KPP_CS ; private ! Parameters - real :: Ri_crit !< Critical bulk Richardson number (defines OBL depth) - real :: vonKarman !< von Karman constant (dimensionless) - real :: cs !< Parameter for computing velocity scale function (dimensionless) - real :: cs2 !< Parameter for multiplying by non-local term + real :: Ri_crit !< Critical bulk Richardson number (defines OBL depth) [nondim] + real :: vonKarman !< von Karman constant (dimensionless) [nondim] + real :: cs !< Parameter for computing velocity scale function (dimensionless) [nondim] + real :: cs2 !< Parameter for multiplying by non-local term [nondim] ! This is active for NLT_SHAPE_CUBIC_LMD only logical :: enhance_diffusion !< If True, add enhanced diffusivity at base of boundary layer. - character(len=10) :: interpType !< Type of interpolation to compute bulk Richardson number - character(len=10) :: interpType2 !< Type of interpolation to compute diff and visc at OBL_depth + character(len=32) :: interpType !< Type of interpolation to compute bulk Richardson number + character(len=32) :: interpType2 !< Type of interpolation to compute diff and visc at OBL_depth + logical :: StokesMOST !< If True, use Stokes similarity package logical :: computeEkman !< If True, compute Ekman depth limit for OBLdepth logical :: computeMoninObukhov !< If True, compute Monin-Obukhov limit for OBLdepth logical :: passiveMode !< If True, makes KPP passive meaning it does NOT alter the diffusivity real :: deepOBLoffset !< If non-zero, is a distance from the bottom that the OBL can not - !! penetrate through [m] - real :: minOBLdepth !< If non-zero, is a minimum depth for the OBL [m] + !! penetrate through [Z ~> m] + real :: minOBLdepth !< If non-zero, is a minimum depth for the OBL [Z ~> m] real :: surf_layer_ext !< Fraction of OBL depth considered in the surface layer [nondim] - real :: minVtsqr !< Min for the squared unresolved velocity used in Rib CVMix calculation [m2 s-2] + real :: minVtsqr !< Min for the squared unresolved velocity used in Rib CVMix + !! calculation [L2 T-2 ~> m2 s-2] logical :: fixedOBLdepth !< If True, will fix the OBL depth at fixedOBLdepth_value - real :: fixedOBLdepth_value !< value for the fixed OBL depth when fixedOBLdepth==True. + real :: fixedOBLdepth_value !< value for the fixed OBL depth when fixedOBLdepth==True [Z ~> m] logical :: debug !< If True, calculate checksums and write debugging information character(len=30) :: MatchTechnique !< Method used in CVMix for setting diffusivity and NLT profile functions integer :: NLT_shape !< MOM6 over-ride of CVMix NLT shape function - logical :: applyNonLocalTrans !< If True, apply non-local transport to heat and scalars + logical :: applyNonLocalTrans !< If True, apply non-local transport to all tracers integer :: n_smooth !< Number of times smoothing operator is applied on OBLdepth. logical :: deepen_only !< If true, apply OBLdepth smoothing at a cell only if the OBLdepth gets deeper. logical :: KPPzeroDiffusivity !< If True, will set diffusivity and viscosity from KPP to zero @@ -101,21 +111,25 @@ module MOM_CVMix_KPP !! If False, will replace initial diffusivity wherever KPP diffusivity !! is non-zero. real :: min_thickness !< A minimum thickness used to avoid division by small numbers - !! in the vicinity of vanished layers. - ! smg: obsolete below - logical :: correctSurfLayerAvg !< If true, applies a correction to the averaging of surface layer properties - real :: surfLayerDepth !< A guess at the depth of the surface layer (which should 0.1 of OBLdepth) [m] - ! smg: obsolete above + !! in the vicinity of vanished layers [Z ~> m] integer :: SW_METHOD !< Sets method for using shortwave radiation in surface buoyancy flux logical :: LT_K_Enhancement !< Flags if enhancing mixing coefficients due to LT integer :: LT_K_Shape !< Integer for constant or shape function enhancement integer :: LT_K_Method !< Integer for mixing coefficients LT method - real :: KPP_K_ENH_FAC !< Factor to multiply by K if Method is CONSTANT + real :: KPP_CVt2 !< Parameter for Stokes MOST convection entrainment [nondim] + real :: KPP_K_ENH_FAC !< Factor to multiply by K if Method is CONSTANT [nondim] logical :: LT_Vt2_Enhancement !< Flags if enhancing Vt2 due to LT integer :: LT_VT2_METHOD !< Integer for Vt2 LT method - real :: KPP_VT2_ENH_FAC !< Factor to multiply by VT2 if Method is CONSTANT + real :: KPP_VT2_ENH_FAC !< Factor to multiply by VT2 if Method is CONSTANT [nondim] + real :: MLD_guess_min !< The minimum estimate of the mixed layer depth used to + !! calculate the Langmuir number for Langmuir turbulence + !! enhancement with KPP [Z ~> m] logical :: STOKES_MIXING !< Flag if model is mixing down Stokes gradient - !! This is relavent for which current to use in RiB + !! This is relevant for which current to use in RiB + integer :: answer_date !< The vintage of the order of arithmetic in the CVMix KPP + !! calculations. Values below 20240501 recover the answers + !! from early in 2024, while higher values use expressions + !! that have been refactored for rotational symmetry. !> CVMix parameters type(CVMix_kpp_params_type), pointer :: KPP_params => NULL() @@ -127,7 +141,6 @@ module MOM_CVMix_KPP integer :: id_Ws = -1, id_Vt2 = -1 integer :: id_BulkUz2 = -1, id_BulkDrho = -1 integer :: id_uStar = -1, id_buoyFlux = -1 - integer :: id_QminusSW = -1, id_netS = -1 integer :: id_sigma = -1, id_Kv_KPP = -1 integer :: id_Kt_KPP = -1, id_Ks_KPP = -1 integer :: id_Tsurf = -1, id_Ssurf = -1 @@ -135,39 +148,40 @@ module MOM_CVMix_KPP integer :: id_Kd_in = -1 integer :: id_NLTt = -1 integer :: id_NLTs = -1 - integer :: id_NLT_dSdt = -1 - integer :: id_NLT_dTdt = -1 - integer :: id_NLT_temp_budget = -1 - integer :: id_NLT_saln_budget = -1 integer :: id_EnhK = -1, id_EnhVt2 = -1 integer :: id_EnhW = -1 integer :: id_La_SL = -1 integer :: id_OBLdepth_original = -1 + integer :: id_StokesXI = -1 + integer :: id_Lam2 = -1 !>@} ! Diagnostics arrays - real, allocatable, dimension(:,:) :: OBLdepth !< Depth (positive) of OBL [m] - real, allocatable, dimension(:,:) :: OBLdepth_original !< Depth (positive) of OBL [m] without smoothing - real, allocatable, dimension(:,:) :: kOBL !< Level (+fraction) of OBL extent - real, allocatable, dimension(:,:) :: OBLdepthprev !< previous Depth (positive) of OBL [m] - real, allocatable, dimension(:,:) :: La_SL !< Langmuir number used in KPP + real, pointer, dimension(:,:) :: OBLdepth !< Depth (positive) of ocean boundary layer (OBL) [Z ~> m] + real, allocatable, dimension(:,:) :: OBLdepth_original !< Depth (positive) of OBL without smoothing [Z ~> m] + real, allocatable, dimension(:,:) :: StokesParXI !< Stokes similarity parameter [nondim] + real, allocatable, dimension(:,:) :: Lam2 !< La^(-2) = Ustk0/u* [nondim] + real, allocatable, dimension(:,:) :: kOBL !< Level (+fraction) of OBL extent [nondim] + real, allocatable, dimension(:,:) :: OBLdepthprev !< previous Depth (positive) of OBL [Z ~> m] + real, allocatable, dimension(:,:) :: La_SL !< Langmuir number used in KPP [nondim] real, allocatable, dimension(:,:,:) :: dRho !< Bulk difference in density [R ~> kg m-3] - real, allocatable, dimension(:,:,:) :: Uz2 !< Square of bulk difference in resolved velocity [m2 s-2] - real, allocatable, dimension(:,:,:) :: BulkRi !< Bulk Richardson number for each layer (dimensionless) - real, allocatable, dimension(:,:,:) :: sigma !< Sigma coordinate (dimensionless) - real, allocatable, dimension(:,:,:) :: Ws !< Turbulent velocity scale for scalars [m s-1] - real, allocatable, dimension(:,:,:) :: N !< Brunt-Vaisala frequency [s-1] - real, allocatable, dimension(:,:,:) :: N2 !< Squared Brunt-Vaisala frequency [s-2] - real, allocatable, dimension(:,:,:) :: Vt2 !< Unresolved squared turbulence velocity for bulk Ri [m2 s-2] - real, allocatable, dimension(:,:,:) :: Kt_KPP !< Temp diffusivity from KPP [m2 s-1] - real, allocatable, dimension(:,:,:) :: Ks_KPP !< Scalar diffusivity from KPP [m2 s-1] - real, allocatable, dimension(:,:,:) :: Kv_KPP !< Viscosity due to KPP [m2 s-1] - real, allocatable, dimension(:,:) :: Tsurf !< Temperature of surface layer [degC] - real, allocatable, dimension(:,:) :: Ssurf !< Salinity of surface layer [ppt] - real, allocatable, dimension(:,:) :: Usurf !< i-velocity of surface layer [m s-1] - real, allocatable, dimension(:,:) :: Vsurf !< j-velocity of surface layer [m s-1] - real, allocatable, dimension(:,:,:) :: EnhK !< Enhancement for mixing coefficient - real, allocatable, dimension(:,:,:) :: EnhVt2 !< Enhancement for Vt2 + real, allocatable, dimension(:,:,:) :: Uz2 !< Square of bulk difference in resolved velocity [L2 T-2 ~> m2 s-2] + real, allocatable, dimension(:,:,:) :: BulkRi !< Bulk Richardson number for each layer [nondim] + real, allocatable, dimension(:,:,:) :: sigma !< Sigma coordinate (dimensionless) [nondim] + real, allocatable, dimension(:,:,:) :: Ws !< Turbulent velocity scale for scalars [Z T-1 ~> m s-1] + real, allocatable, dimension(:,:,:) :: N !< Brunt-Vaisala frequency [T-1 ~> s-1] + real, allocatable, dimension(:,:,:) :: N2 !< Squared Brunt-Vaisala frequency [T-2 ~> s-2] + real, allocatable, dimension(:,:,:) :: Vt2 !< Unresolved squared turbulence velocity for + !! bulk Ri [Z2 T-2 ~> m2 s-2] + real, allocatable, dimension(:,:,:) :: Kt_KPP !< Temp diffusivity from KPP [Z2 T-1 ~> m2 s-1] + real, allocatable, dimension(:,:,:) :: Ks_KPP !< Scalar diffusivity from KPP [Z2 T-1 ~> m2 s-1] + real, allocatable, dimension(:,:,:) :: Kv_KPP !< Viscosity due to KPP [Z2 T-1 ~> m2 s-1] + real, allocatable, dimension(:,:) :: Tsurf !< Temperature of surface layer [C ~> degC] + real, allocatable, dimension(:,:) :: Ssurf !< Salinity of surface layer [S ~> ppt] + real, allocatable, dimension(:,:) :: Usurf !< i-velocity of surface layer [L T-1 ~> m s-1] + real, allocatable, dimension(:,:) :: Vsurf !< j-velocity of surface layer [L T-1 ~> m s-1] + real, allocatable, dimension(:,:,:) :: EnhK !< Enhancement for mixing coefficient [nondim] + real, allocatable, dimension(:,:,:) :: EnhVt2 !< Enhancement for Vt2 [nondim] end type KPP_CS @@ -179,6 +193,33 @@ module MOM_CVMix_KPP contains +!> Routine to register restarts, pass-through to children modules +subroutine register_KPP_restarts(G, param_file, restart_CSp, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(MOM_restart_CS), pointer :: restart_CSp !< MOM restart control structure + type(KPP_CS), pointer :: CS !< module control structure + + character(len=40) :: mdl = 'MOM_CVMix_KPP' !< name of this module + logical :: use_kpp, fpmix + + if (associated(CS)) call MOM_error(FATAL, 'MOM_CVMix_KPP, register_KPP_restarts: '// & + 'Control structure has already been initialized') + call get_param(param_file, mdl, "USE_KPP", use_kpp, default=.false., do_not_log=.true.) + ! Forego remainder of initialization if not using this scheme + if (.not. use_kpp) return + allocate(CS) + + allocate(CS%OBLdepth(SZI_(G),SZJ_(G)), source=0.0) + + ! FPMIX is needed to decide if boundary layer depth should be added to restart file + call get_param(param_file, '', "FPMIX", fpmix, & + "If true, add non-local momentum flux increments and diffuse down the Eulerian gradient.", & + default=.false., do_not_log=.true.) + if (fpmix) call register_restart_field(CS%OBLdepth, 'KPP_OBLdepth', .false., restart_CSp) + +end subroutine register_KPP_restarts + !> Initialize the CVMix KPP module and set up diagnostics !! Returns True if KPP is to be used, False otherwise. logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) @@ -197,15 +238,13 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) # include "version_variable.h" character(len=40) :: mdl = 'MOM_CVMix_KPP' !< name of this module character(len=20) :: string !< local temporary string - character(len=20) :: langmuir_mixing_opt = 'NONE' !< langmuir mixing opt to be passed to CVMix, e.g., LWF16 - character(len=20) :: langmuir_entrainment_opt = 'NONE' !< langmuir entrainment opt to be passed to CVMix, e.g., LWF16 - character(len=20) :: wave_method + character(len=20) :: langmuir_mixing_opt = 'NONE' !< Langmuir mixing option to be passed to CVMix, e.g., LWF16 + character(len=20) :: langmuir_entrainment_opt = 'NONE' !< Langmuir entrainment option to be + !! passed to CVMix, e.g., LWF16 + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. logical :: CS_IS_ONE=.false. !< Logical for setting Cs based on Non-local logical :: lnoDGat1=.false. !< True => G'(1) = 0 (shape function) !! False => compute G'(1) as in LMD94 - if (associated(CS)) call MOM_error(FATAL, 'MOM_CVMix_KPP, KPP_init: '// & - 'Control structure has already been initialized') - ! Read parameters call get_param(paramFile, mdl, "USE_KPP", KPP_init, default=.false., do_not_log=.true.) call log_version(paramFile, mdl, version, 'This is the MOM wrapper to CVMix:KPP\n' // & @@ -216,7 +255,10 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) default=.false.) ! Forego remainder of initialization if not using this scheme if (.not. KPP_init) return - allocate(CS) + + call get_param(paramFile, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231, do_not_log=.true.) call openParameterBlock(paramFile,'KPP') call get_param(paramFile, mdl, 'PASSIVE', CS%passiveMode, & @@ -227,13 +269,12 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) if (present(passive)) passive=CS%passiveMode ! This is passed back to the caller so ! the caller knows to not use KPP output call get_param(paramFile, mdl, 'APPLY_NONLOCAL_TRANSPORT', CS%applyNonLocalTrans, & - 'If True, applies the non-local transport to heat and scalars. '// & + 'If True, applies the non-local transport to all tracers. '// & 'If False, calculates the non-local transport and tendencies but '//& 'purely for diagnostic purposes.', & default=.not. CS%passiveMode) call get_param(paramFile, mdl, 'N_SMOOTH', CS%n_smooth, & - 'The number of times the 1-1-4-1-1 Laplacian filter is applied on '// & - 'OBL depth.', & + 'The number of times the 1-1-4-1-1 Laplacian filter is applied on OBL depth.', & default=0) if (CS%n_smooth > G%domain%nihalo) then call MOM_error(FATAL,'KPP smoothing number (N_SMOOTH) cannot be greater than NIHALO.') @@ -265,6 +306,9 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) 'Type of interpolation to compute diff and visc at OBL_depth.\n'// & 'Allowed types are: linear, quadratic, cubic or LMD94.', & default='LMD94') + call get_param(paramFile, mdl, 'STOKES_MOST', CS%StokesMOST, & + 'If True, use Stokes Similarity package.', & + default=.False.) call get_param(paramFile, mdl, 'COMPUTE_EKMAN', CS%computeEkman, & 'If True, limit OBL depth to be no deeper than Ekman depth.', & default=.False.) @@ -281,7 +325,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) call get_param(paramFile, mdl, 'DEEP_OBL_OFFSET', CS%deepOBLoffset, & 'If non-zero, the distance above the bottom to which the OBL is clipped '// & 'if it would otherwise reach the bottom. The smaller of this and 0.1D is used.', & - units='m',default=0.) + units='m', default=0., scale=US%m_to_Z) call get_param(paramFile, mdl, 'FIXED_OBLDEPTH', CS%fixedOBLdepth, & 'If True, fix the OBL depth to FIXED_OBLDEPTH_VALUE '// & 'rather than using the OBL depth from CVMix. '// & @@ -291,32 +335,18 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) 'Value for the fixed OBL depth when fixedOBLdepth==True. '// & 'This parameter is for just for testing purposes. '// & 'It will over-ride the OBLdepth computed from CVMix.', & - units='m',default=30.0) + units='m', default=30.0, scale=US%m_to_Z) call get_param(paramFile, mdl, 'SURF_LAYER_EXTENT', CS%surf_layer_ext, & 'Fraction of OBL depth considered in the surface layer.', & - units='nondim',default=0.10) + units='nondim', default=0.10) call get_param(paramFile, mdl, 'MINIMUM_OBL_DEPTH', CS%minOBLdepth, & 'If non-zero, a minimum depth to use for KPP OBL depth. Independent of '// & 'this parameter, the OBL depth is always at least as deep as the first layer.', & - units='m',default=0.) + units='m', default=0., scale=US%m_to_Z) call get_param(paramFile, mdl, 'MINIMUM_VT2', CS%minVtsqr, & 'Min of the unresolved velocity Vt2 used in Rib CVMix calculation.\n'// & 'Scaling: MINIMUM_VT2 = const1*d*N*ws, with d=1m, N=1e-5/s, ws=1e-6 m/s.', & - units='m2/s2',default=1e-10) - -! smg: for removal below - call get_param(paramFile, mdl, 'CORRECT_SURFACE_LAYER_AVERAGE', CS%correctSurfLayerAvg, & - 'If true, applies a correction step to the averaging of surface layer '// & - 'properties. This option is obsolete.', default=.False.) - if (CS%correctSurfLayerAvg) & - call MOM_error(FATAL,'Correct surface layer average disabled in code. To recover \n'// & - ' feature will require code intervention.') - call get_param(paramFile, mdl, 'FIRST_GUESS_SURFACE_LAYER_DEPTH', CS%surfLayerDepth, & - 'The first guess at the depth of the surface layer used for averaging '// & - 'the surface layer properties. If =0, the top model level properties '// & - 'will be used for the surface layer. If CORRECT_SURFACE_LAYER_AVERAGE=True, a '// & - 'subsequent correction is applied. This parameter is obsolete', units='m', default=0.) -! smg: for removal above + units='m2/s2', default=1e-10, scale=US%m_s_to_L_T**2) call get_param(paramFile, mdl, 'NLT_SHAPE', string, & 'MOM6 method to set nonlocal transport profile. '// & @@ -386,16 +416,16 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) call get_param(paramFile, mdl, 'CVMix_ZERO_H_WORK_AROUND', CS%min_thickness, & 'A minimum thickness used to avoid division by small numbers in the vicinity '// & 'of vanished layers. This is independent of MIN_THICKNESS used in other parts of MOM.', & - units='m', default=0.) + units='m', default=0., scale=US%m_to_Z) !/BGR: New options for including Langmuir effects !/ 1. Options related to enhancing the mixing coefficient call get_param(paramFile, mdl, "USE_KPP_LT_K", CS%LT_K_Enhancement, & - 'Flag for Langmuir turbulence enhancement of turbulent'//& - 'mixing coefficient.', units="", Default=.false.) + 'Flag for Langmuir turbulence enhancement of turbulent '//& + 'mixing coefficient.', Default=.false.) call get_param(paramFile, mdl, "STOKES_MIXING", CS%Stokes_Mixing, & - 'Flag for Langmuir turbulence enhancement of turbulent'//& - 'mixing coefficient.', units="", Default=.false.) + 'Flag for Langmuir turbulence enhancement of turbulent '//& + 'mixing coefficient.', Default=.false.) if (CS%LT_K_Enhancement) then call get_param(paramFile, mdl, 'KPP_LT_K_SHAPE', string, & 'Vertical dependence of LT enhancement of mixing. '// & @@ -434,15 +464,15 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) "Unrecognized KPP_LT_K_METHOD option: "//trim(string)) end select if (CS%LT_K_METHOD==LT_K_MODE_CONSTANT) then - call get_param(paramFile, mdl, "KPP_K_ENH_FAC",CS%KPP_K_ENH_FAC , & - 'Constant value to enhance mixing coefficient in KPP.', & - default=1.0) + call get_param(paramFile, mdl, "KPP_K_ENH_FAC", CS%KPP_K_ENH_FAC, & + 'Constant value to enhance mixing coefficient in KPP.', & + units="nondim", default=1.0) endif endif !/ 2. Options related to enhancing the unresolved Vt2/entrainment in Rib call get_param(paramFile, mdl, "USE_KPP_LT_VT2", CS%LT_Vt2_Enhancement, & - 'Flag for Langmuir turbulence enhancement of Vt2'//& - 'in Bulk Richardson Number.', units="", Default=.false.) + 'Flag for Langmuir turbulence enhancement of Vt2 '//& + 'in Bulk Richardson Number.', Default=.false.) if (CS%LT_Vt2_Enhancement) then call get_param(paramFile, mdl, "KPP_LT_VT2_METHOD",string , & 'Method to enhance Vt2 in KPP. '// & @@ -474,24 +504,43 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) "Unrecognized KPP_LT_VT2_METHOD option: "//trim(string)) end select if (CS%LT_VT2_METHOD==LT_VT2_MODE_CONSTANT) then - call get_param(paramFile, mdl, "KPP_VT2_ENH_FAC",CS%KPP_VT2_ENH_FAC , & + call get_param(paramFile, mdl, "KPP_VT2_ENH_FAC", CS%KPP_VT2_ENH_FAC, & 'Constant value to enhance VT2 in KPP.', & - default=1.0) + units="nondim", default=1.0) endif endif + if (CS%LT_K_ENHANCEMENT .or. CS%LT_VT2_ENHANCEMENT) then + call get_param(paramFile, mdl, "KPP_LT_MLD_GUESS_MIN", CS%MLD_guess_min, & + "The minimum estimate of the mixed layer depth used to calculate "//& + "the Langmuir number for Langmuir turbulence enhancement with KPP.", & + units="m", default=1.0, scale=US%m_to_Z) + endif + + call get_param(paramFile, mdl, "KPP_CVt2", CS%KPP_CVt2, & + 'Parameter for Stokes MOST convection entrainment', & + units="nondim", default=1.6) + + call get_param(paramFile, mdl, "ANSWER_DATE", CS%answer_date, & + "The vintage of the order of arithmetic in the CVMix KPP calculations. Values "//& + "below 20240501 recover the answers from early in 2024, while higher values "//& + "use expressions that have been refactored for rotational symmetry.", & + default=default_answer_date) + call closeParameterBlock(paramFile) call get_param(paramFile, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) call CVMix_init_kpp( Ri_crit=CS%Ri_crit, & - minOBLdepth=CS%minOBLdepth, & - minVtsqr=CS%minVtsqr, & + minOBLdepth=US%Z_to_m*CS%minOBLdepth, & + minVtsqr=US%L_T_to_m_s**2*CS%minVtsqr, & vonKarman=CS%vonKarman, & surf_layer_ext=CS%surf_layer_ext, & + CVt2=CS%KPP_CVt2, & interp_type=CS%interpType, & interp_type2=CS%interpType2, & lEkman=CS%computeEkman, & + lStokesMOST=CS%StokesMOST, & lMonOb=CS%computeMoninObukhov, & MatchTechnique=CS%MatchTechnique, & lenhanced_diff=CS%enhance_diffusion,& @@ -504,7 +553,8 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) ! Register diagnostics CS%diag => diag CS%id_OBLdepth = register_diag_field('ocean_model', 'KPP_OBLdepth', diag%axesT1, Time, & - 'Thickness of the surface Ocean Boundary Layer calculated by [CVMix] KPP', 'meter', & + 'Thickness of the surface Ocean Boundary Layer calculated by [CVMix] KPP', & + 'meter', conversion=US%Z_to_m, & cmor_field_name='oml', cmor_long_name='ocean_mixed_layer_thickness_defined_by_mixing_scheme', & cmor_units='m', cmor_standard_name='Ocean Mixed Layer Thickness Defined by Mixing Scheme') ! CMOR names are placeholders; must be modified by time period @@ -512,67 +562,68 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) ! omldamax. if (CS%n_smooth > 0) then CS%id_OBLdepth_original = register_diag_field('ocean_model', 'KPP_OBLdepth_original', diag%axesT1, Time, & - 'Thickness of the surface Ocean Boundary Layer without smoothing calculated by [CVMix] KPP', 'meter', & + 'Thickness of the surface Ocean Boundary Layer without smoothing calculated by [CVMix] KPP', & + 'meter', conversion=US%Z_to_m, & cmor_field_name='oml', cmor_long_name='ocean_mixed_layer_thickness_defined_by_mixing_scheme', & cmor_units='m', cmor_standard_name='Ocean Mixed Layer Thickness Defined by Mixing Scheme') endif + if ( CS%StokesMOST ) then + CS%id_StokesXI = register_diag_field('ocean_model', 'StokesXI', diag%axesT1, Time, & + 'Stokes Similarity Parameter', 'nondim') + CS%id_Lam2 = register_diag_field('ocean_model', 'Lam2', diag%axesT1, Time, & + 'Ustk0_ustar', 'nondim') + endif CS%id_BulkDrho = register_diag_field('ocean_model', 'KPP_BulkDrho', diag%axesTL, Time, & 'Bulk difference in density used in Bulk Richardson number, as used by [CVMix] KPP', & 'kg/m3', conversion=US%R_to_kg_m3) CS%id_BulkUz2 = register_diag_field('ocean_model', 'KPP_BulkUz2', diag%axesTL, Time, & - 'Square of bulk difference in resolved velocity used in Bulk Richardson number via [CVMix] KPP', 'm2/s2') + 'Square of bulk difference in resolved velocity used in Bulk Richardson number via [CVMix] KPP', & + 'm2/s2', conversion=US%L_T_to_m_s**2) CS%id_BulkRi = register_diag_field('ocean_model', 'KPP_BulkRi', diag%axesTL, Time, & 'Bulk Richardson number used to find the OBL depth used by [CVMix] KPP', 'nondim') CS%id_Sigma = register_diag_field('ocean_model', 'KPP_sigma', diag%axesTi, Time, & 'Sigma coordinate used by [CVMix] KPP', 'nondim') CS%id_Ws = register_diag_field('ocean_model', 'KPP_Ws', diag%axesTL, Time, & - 'Turbulent vertical velocity scale for scalars used by [CVMix] KPP', 'm/s') + 'Turbulent vertical velocity scale for scalars used by [CVMix] KPP', & + 'm/s', conversion=US%Z_to_m*US%s_to_T) CS%id_N = register_diag_field('ocean_model', 'KPP_N', diag%axesTi, Time, & - '(Adjusted) Brunt-Vaisala frequency used by [CVMix] KPP', '1/s') + '(Adjusted) Brunt-Vaisala frequency used by [CVMix] KPP', '1/s', conversion=US%s_to_T) CS%id_N2 = register_diag_field('ocean_model', 'KPP_N2', diag%axesTi, Time, & - 'Square of Brunt-Vaisala frequency used by [CVMix] KPP', '1/s2') + 'Square of Brunt-Vaisala frequency used by [CVMix] KPP', '1/s2', conversion=US%s_to_T**2) CS%id_Vt2 = register_diag_field('ocean_model', 'KPP_Vt2', diag%axesTL, Time, & - 'Unresolved shear turbulence used by [CVMix] KPP', 'm2/s2') + 'Unresolved shear turbulence used by [CVMix] KPP', 'm2/s2', conversion=US%Z_to_m**2*US%s_to_T**2) CS%id_uStar = register_diag_field('ocean_model', 'KPP_uStar', diag%axesT1, Time, & 'Friction velocity, u*, as used by [CVMix] KPP', 'm/s', conversion=US%Z_to_m*US%s_to_T) CS%id_buoyFlux = register_diag_field('ocean_model', 'KPP_buoyFlux', diag%axesTi, Time, & - 'Surface (and penetrating) buoyancy flux, as used by [CVMix] KPP', 'm2/s3', conversion=US%L_to_m**2*US%s_to_T**3) - CS%id_QminusSW = register_diag_field('ocean_model', 'KPP_QminusSW', diag%axesT1, Time, & - 'Net temperature flux ignoring short-wave, as used by [CVMix] KPP', 'K m/s', conversion=GV%H_to_m*US%s_to_T) - CS%id_netS = register_diag_field('ocean_model', 'KPP_netSalt', diag%axesT1, Time, & - 'Effective net surface salt flux, as used by [CVMix] KPP', 'ppt m/s', conversion=GV%H_to_m*US%s_to_T) + 'Surface (and penetrating) buoyancy flux, as used by [CVMix] KPP', & + 'm2/s3', conversion=US%L_to_m**2*US%s_to_T**3) CS%id_Kt_KPP = register_diag_field('ocean_model', 'KPP_Kheat', diag%axesTi, Time, & - 'Heat diffusivity due to KPP, as calculated by [CVMix] KPP', 'm2/s') + 'Heat diffusivity due to KPP, as calculated by [CVMix] KPP', & + 'm2/s', conversion=US%Z2_T_to_m2_s) CS%id_Kd_in = register_diag_field('ocean_model', 'KPP_Kd_in', diag%axesTi, Time, & - 'Diffusivity passed to KPP', 'm2/s', conversion=US%Z2_T_to_m2_s) + 'Diffusivity passed to KPP', 'm2/s', conversion=GV%HZ_T_to_m2_s) CS%id_Ks_KPP = register_diag_field('ocean_model', 'KPP_Ksalt', diag%axesTi, Time, & - 'Salt diffusivity due to KPP, as calculated by [CVMix] KPP', 'm2/s') + 'Salt diffusivity due to KPP, as calculated by [CVMix] KPP', & + 'm2/s', conversion=US%Z2_T_to_m2_s) CS%id_Kv_KPP = register_diag_field('ocean_model', 'KPP_Kv', diag%axesTi, Time, & - 'Vertical viscosity due to KPP, as calculated by [CVMix] KPP', 'm2/s') + 'Vertical viscosity due to KPP, as calculated by [CVMix] KPP', & + 'm2/s', conversion=US%Z2_T_to_m2_s) CS%id_NLTt = register_diag_field('ocean_model', 'KPP_NLtransport_heat', diag%axesTi, Time, & 'Non-local transport (Cs*G(sigma)) for heat, as calculated by [CVMix] KPP', 'nondim') CS%id_NLTs = register_diag_field('ocean_model', 'KPP_NLtransport_salt', diag%axesTi, Time, & 'Non-local tranpsort (Cs*G(sigma)) for scalars, as calculated by [CVMix] KPP', 'nondim') - CS%id_NLT_dTdt = register_diag_field('ocean_model', 'KPP_NLT_dTdt', diag%axesTL, Time, & - 'Temperature tendency due to non-local transport of heat, as calculated by [CVMix] KPP', & - 'K/s', conversion=US%s_to_T) - CS%id_NLT_dSdt = register_diag_field('ocean_model', 'KPP_NLT_dSdt', diag%axesTL, Time, & - 'Salinity tendency due to non-local transport of salt, as calculated by [CVMix] KPP', & - 'ppt/s', conversion=US%s_to_T) - CS%id_NLT_temp_budget = register_diag_field('ocean_model', 'KPP_NLT_temp_budget', diag%axesTL, Time, & - 'Heat content change due to non-local transport, as calculated by [CVMix] KPP', & - 'W/m^2', conversion=US%QRZ_T_to_W_m2) - CS%id_NLT_saln_budget = register_diag_field('ocean_model', 'KPP_NLT_saln_budget', diag%axesTL, Time, & - 'Salt content change due to non-local transport, as calculated by [CVMix] KPP', & - 'kg/(sec*m^2)', conversion=US%RZ_T_to_kg_m2s) CS%id_Tsurf = register_diag_field('ocean_model', 'KPP_Tsurf', diag%axesT1, Time, & - 'Temperature of surface layer (10% of OBL depth) as passed to [CVMix] KPP', 'C') + 'Temperature of surface layer (10% of OBL depth) as passed to [CVMix] KPP', & + 'C', conversion=US%C_to_degC) CS%id_Ssurf = register_diag_field('ocean_model', 'KPP_Ssurf', diag%axesT1, Time, & - 'Salinity of surface layer (10% of OBL depth) as passed to [CVMix] KPP', 'ppt') + 'Salinity of surface layer (10% of OBL depth) as passed to [CVMix] KPP', & + 'ppt', conversion=US%S_to_ppt) CS%id_Usurf = register_diag_field('ocean_model', 'KPP_Usurf', diag%axesCu1, Time, & - 'i-component flow of surface layer (10% of OBL depth) as passed to [CVMix] KPP', 'm/s') + 'i-component flow of surface layer (10% of OBL depth) as passed to [CVMix] KPP', & + 'm/s', conversion=US%L_T_to_m_s) CS%id_Vsurf = register_diag_field('ocean_model', 'KPP_Vsurf', diag%axesCv1, Time, & - 'j-component flow of surface layer (10% of OBL depth) as passed to [CVMix] KPP', 'm/s') + 'j-component flow of surface layer (10% of OBL depth) as passed to [CVMix] KPP', & + 'm/s', conversion=US%L_T_to_m_s) CS%id_EnhK = register_diag_field('ocean_model', 'EnhK', diag%axesTI, Time, & 'Langmuir number enhancement to K as used by [CVMix] KPP','nondim') CS%id_EnhVt2 = register_diag_field('ocean_model', 'EnhVt2', diag%axesTL, Time, & @@ -581,7 +632,8 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) 'Surface-layer Langmuir number computed in [CVMix] KPP','nondim') allocate( CS%N( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=0. ) - allocate( CS%OBLdepth( SZI_(G), SZJ_(G) ), source=0. ) + allocate( CS%StokesParXI( SZI_(G), SZJ_(G) ), source=0. ) + allocate( CS%Lam2 ( SZI_(G), SZJ_(G) ), source=0. ) allocate( CS%kOBL( SZI_(G), SZJ_(G) ), source=0. ) allocate( CS%La_SL( SZI_(G), SZJ_(G) ), source=0. ) allocate( CS%Vt2( SZI_(G), SZJ_(G), SZK_(GV) ), source=0. ) @@ -610,7 +662,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) end function KPP_init !> KPP vertical diffusivity/viscosity and non-local tracer transport -subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & +subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & nonLocalTransHeat, nonLocalTransScalar, Waves, lamult) ! Arguments @@ -618,49 +670,55 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & type(ocean_grid_type), intent(in) :: G !< Ocean grid type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer/level thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: uStar !< Surface friction velocity [Z T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: buoyFlux !< Surface buoyancy flux [L2 T-3 ~> m2 s-3] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kt !< (in) Vertical diffusivity of heat w/o KPP !! (out) Vertical diffusivity including KPP - !! [Z2 T-1 ~> m2 s-1] + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Ks !< (in) Vertical diffusivity of salt w/o KPP !! (out) Vertical diffusivity including KPP - !! [Z2 T-1 ~> m2 s-1] + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kv !< (in) Vertical viscosity w/o KPP !! (out) Vertical viscosity including KPP - !! [Z2 T-1 ~> m2 s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: nonLocalTransHeat !< Temp non-local transport [m s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: nonLocalTransScalar !< scalar non-local trans. [m s-1] + !! [H Z T-1 ~> m2 s-1 or Pa s] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: nonLocalTransHeat !< Temp non-local transport [nondim] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: nonLocalTransScalar !< scalar non-local trans. [nondim] type(wave_parameters_CS), pointer :: Waves !< Wave CS for Langmuir turbulence - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: lamult !< Langmuir enhancement multiplier - -! Local variables - integer :: i, j, k ! Loop indices - real, dimension( GV%ke ) :: cellHeight ! Cell center heights referenced to surface [m] (negative in ocean) - real, dimension( GV%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [m] (negative in ocean) - real, dimension( GV%ke+1, 2) :: Kdiffusivity ! Vertical diffusivity at interfaces [m2 s-1] - real, dimension( GV%ke+1 ) :: Kviscosity ! Vertical viscosity at interfaces [m2 s-1] - real, dimension( GV%ke+1, 2) :: nonLocalTrans ! Non-local transport for heat/salt at interfaces [nondim] - - real :: surfFricVel, surfBuoyFlux - real :: sigma, sigmaRatio + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: lamult !< Langmuir enhancement multiplier [nondim] + + ! Local variables + integer :: i, j, k ! Loop indices + real, dimension(SZI_(G),SZK_(GV)) :: dz ! Height change across layers [Z ~> m] + real, dimension( GV%ke ) :: cellHeight ! Cell center heights referenced to surface [Z ~> m] (negative in ocean) + real, dimension( GV%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [Z ~> m] (negative in ocean) + real, dimension( GV%ke ) :: z_cell ! Cell center heights referenced to surface [m] (negative in ocean) + real, dimension( GV%ke+1 ) :: z_inter ! Cell interface heights referenced to surface [m] (negative in ocean) + real, dimension( GV%ke+1, 2) :: Kdiffusivity ! Vertical diffusivity at interfaces in MKS units [m2 s-1] + real, dimension( GV%ke+1 ) :: Kviscosity ! Vertical viscosity at interfaces in MKS units [m2 s-1] + real, dimension( GV%ke+1, 2) :: nonLocalTrans ! Non-local transport for heat/salt at interfaces [nondim] + + real :: surfFricVel ! Surface friction velocity in MKS units [m s-1] + real :: surfBuoyFlux ! Surface buoyancy flux in MKS units [m2 s-3] + real :: sigma ! Fractional vertical position within the boundary layer [nondim] + real :: sigmaRatio ! A cubic function of sigma [nondim] real :: buoy_scale ! A unit conversion factor for buoyancy fluxes [m2 T3 L-2 s-3 ~> 1] - real :: dh ! The local thickness used for calculating interface positions [m] - real :: hcorr ! A cumulative correction arising from inflation of vanished layers [m] + real :: dh ! The local thickness used for calculating interface positions [Z ~> m] + real :: hcorr ! A cumulative correction arising from inflation of vanished layers [Z ~> m] ! For Langmuir Calculations - real :: LangEnhK ! Langmuir enhancement for mixing coefficient + real :: LangEnhK ! Langmuir enhancement for mixing coefficient [nondim] if (CS%Stokes_Mixing .and. .not.associated(Waves)) call MOM_error(FATAL, & "KPP_calculate: The Waves control structure must be associated if STOKES_MIXING is True.") if (CS%debug) then - call hchksum(h, "KPP in: h",G%HI,haloshift=0, scale=GV%H_to_m) - call hchksum(uStar, "KPP in: uStar",G%HI,haloshift=0, scale=US%Z_to_m*US%s_to_T) - call hchksum(buoyFlux, "KPP in: buoyFlux",G%HI,haloshift=0, scale=US%L_to_m**2*US%s_to_T**3) - call hchksum(Kt, "KPP in: Kt",G%HI,haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Ks, "KPP in: Ks",G%HI,haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(h, "KPP in: h", G%HI, haloshift=0, unscale=GV%H_to_m) + call hchksum(uStar, "KPP in: uStar", G%HI, haloshift=0, unscale=US%Z_to_m*US%s_to_T) + call hchksum(buoyFlux, "KPP in: buoyFlux", G%HI, haloshift=0, unscale=US%L_to_m**2*US%s_to_T**3) + call hchksum(Kt, "KPP in: Kt", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Ks, "KPP in: Ks", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif nonLocalTrans(:,:) = 0.0 @@ -671,17 +729,18 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & buoy_scale = US%L_to_m**2*US%s_to_T**3 !$OMP parallel do default(none) firstprivate(nonLocalTrans) & - !$OMP private(surfFricVel, iFaceHeight, hcorr, dh, cellHeight, & + !$OMP private(surfFricVel, iFaceHeight, hcorr, dh, dz, cellHeight, & !$OMP surfBuoyFlux, Kdiffusivity, Kviscosity, LangEnhK, sigma, & - !$OMP sigmaRatio) & - !$OMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, Kt, & + !$OMP sigmaRatio, z_inter, z_cell) & + !$OMP shared(G, GV, CS, US, tv, uStar, h, buoy_scale, buoyFlux, Kt, & !$OMP Ks, Kv, nonLocalTransHeat, nonLocalTransScalar, Waves, lamult) ! loop over horizontal points on processor do j = G%jsc, G%jec - do i = G%isc, G%iec - ! skip calling KPP for land points - if (G%mask2dT(i,j)==0.) cycle + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + + do i = G%isc, G%iec ; if (G%mask2dT(i,j) > 0.0) then ! things independent of position within the column surfFricVel = US%Z_to_m*US%s_to_T * uStar(i,j) @@ -691,7 +750,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & do k=1,GV%ke ! cell center and cell bottom in meters (negative values in the ocean) - dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment + dh = dz(i,k) ! Nominal thickness to use for increment dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness @@ -701,7 +760,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & enddo ! k-loop finishes surfBuoyFlux = buoy_scale*buoyFlux(i,j,1) ! This is only used in kpp_compute_OBL_depth to limit - ! h to Monin-Obukov (default is false, ie. not used) + ! h to Monin-Obukhov (default is false, ie. not used) ! Call CVMix/KPP to obtain OBL diffusivities, viscosities and non-local transports @@ -723,9 +782,9 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & Kdiffusivity(:,:) = 0. ! Diffusivities for heat and salt [m2 s-1] Kviscosity(:) = 0. ! Viscosity [m2 s-1] else - Kdiffusivity(:,1) = US%Z2_T_to_m2_s * Kt(i,j,:) - Kdiffusivity(:,2) = US%Z2_T_to_m2_s * Ks(i,j,:) - Kviscosity(:) = US%Z2_T_to_m2_s * Kv(i,j,:) + Kdiffusivity(:,1) = GV%HZ_T_to_m2_s * Kt(i,j,:) + Kdiffusivity(:,2) = GV%HZ_T_to_m2_s * Ks(i,j,:) + Kviscosity(:) = GV%HZ_T_to_m2_s * Kv(i,j,:) endif IF (CS%LT_K_ENHANCEMENT) then @@ -770,15 +829,23 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & enddo endif + ! Convert columns to MKS units for passing to CVMix + do k = 1, GV%ke + z_cell(k) = US%Z_to_m*cellHeight(k) + enddo + do K = 1, GV%ke+1 + z_inter(K) = US%Z_to_m*iFaceHeight(K) + enddo + call CVMix_coeffs_kpp(Kviscosity(:), & ! (inout) Total viscosity [m2 s-1] Kdiffusivity(:,1), & ! (inout) Total heat diffusivity [m2 s-1] Kdiffusivity(:,2), & ! (inout) Total salt diffusivity [m2 s-1] - iFaceHeight, & ! (in) Height of interfaces [m] - cellHeight, & ! (in) Height of level centers [m] + z_inter(:), & ! (in) Height of interfaces [m] + z_cell(:), & ! (in) Height of level centers [m] Kviscosity(:), & ! (in) Original viscosity [m2 s-1] Kdiffusivity(:,1), & ! (in) Original heat diffusivity [m2 s-1] Kdiffusivity(:,2), & ! (in) Original salt diffusivity [m2 s-1] - CS%OBLdepth(i,j), & ! (in) OBL depth [m] + US%Z_to_m*CS%OBLdepth(i,j), & ! (in) OBL depth [m] CS%kOBL(i,j), & ! (in) level (+fraction) of OBL extent nonLocalTrans(:,1),& ! (out) Non-local heat transport [nondim] nonLocalTrans(:,2),& ! (out) Non-local salt transport [nondim] @@ -787,14 +854,31 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & GV%ke, & ! (in) Number of levels to compute coeffs for GV%ke, & ! (in) Number of levels in array shape Langmuir_EFactor=LangEnhK,& ! Langmuir enhancement multiplier + StokesXi = CS%StokesParXI(i,j), & ! Stokes forcing parameter CVMix_kpp_params_user=CS%KPP_params ) ! safety check, Kviscosity and Kdiffusivity must be >= 0 do k=1, GV%ke+1 if (Kviscosity(k) < 0. .or. Kdiffusivity(k,1) < 0.) then + write(*,'(a,3i3)') 'interface, i, j, k = ',j, j, k + write(*,'(a,2f12.5)') 'lon,lat=', G%geoLonT(i,j), G%geoLatT(i,j) + write(*,'(a,es12.4)') 'depth, z_inter(k) =',z_inter(k) + write(*,'(a,es12.4)') 'Kviscosity(k) =',Kviscosity(k) + write(*,'(a,es12.4)') 'Kdiffusivity(k,1) =',Kdiffusivity(k,1) + write(*,'(a,es12.4)') 'Kdiffusivity(k,2) =',Kdiffusivity(k,2) + write(*,'(a,es12.4)') 'OBLdepth =',US%Z_to_m*CS%OBLdepth(i,j) + write(*,'(a,f8.4)') 'kOBL =',CS%kOBL(i,j) + write(*,'(a,es12.4)') 'u* =',surfFricVel + write(*,'(a,es12.4)') 'bottom, z_inter(GV%ke+1) =',z_inter(GV%ke+1) + write(*,'(a,es12.4)') 'CS%La_SL(i,j) =',CS%La_SL(i,j) + write(*,'(a,es12.4)') 'LangEnhK =',LangEnhK + if (present(lamult)) write(*,'(a,es12.4)') 'lamult(i,j) =',lamult(i,j) + write(*,*) 'Kviscosity(:) =',Kviscosity(:) + write(*,*) 'Kdiffusivity(:,1) =',Kdiffusivity(:,1) + call MOM_error(FATAL,"KPP_calculate, after CVMix_coeffs_kpp: "// & "Negative vertical viscosity or diffusivity has been detected. " // & - "This is likely related to the choice of MATCH_TECHNIQUE and INTERP_TYPE2." //& + "This is likely related to the choice of MATCH_TECHNIQUE and INTERP_TYPE2. " //& "You might consider using the default options for these parameters." ) endif enddo @@ -839,8 +923,8 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & ! we apply nonLocalTrans in subroutines ! KPP_NonLocalTransport_temp and KPP_NonLocalTransport_saln - nonLocalTransHeat(i,j,:) = nonLocalTrans(:,1) ! temp - nonLocalTransScalar(i,j,:) = nonLocalTrans(:,2) ! saln + nonLocalTransHeat(i,j,:) = nonLocalTrans(:,1) ! temperature + nonLocalTransScalar(i,j,:) = nonLocalTrans(:,2) ! salinity ! set the KPP diffusivity and viscosity to zero for testing purposes if (CS%KPPzeroDiffusivity) then @@ -851,29 +935,29 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & ! Copy 1d data into 3d diagnostic arrays !/ grabbing obldepth_0d for next time step. - CS%OBLdepthprev(i,j)=CS%OBLdepth(i,j) + CS%OBLdepthprev(i,j) = CS%OBLdepth(i,j) if (CS%id_sigma > 0) then CS%sigma(i,j,:) = 0. - if (CS%OBLdepth(i,j)>0.) CS%sigma(i,j,:) = -iFaceHeight/CS%OBLdepth(i,j) + if (CS%OBLdepth(i,j)>0.) CS%sigma(i,j,:) = -iFaceHeight(:)/CS%OBLdepth(i,j) endif - if (CS%id_Kt_KPP > 0) CS%Kt_KPP(i,j,:) = Kdiffusivity(:,1) - if (CS%id_Ks_KPP > 0) CS%Ks_KPP(i,j,:) = Kdiffusivity(:,2) - if (CS%id_Kv_KPP > 0) CS%Kv_KPP(i,j,:) = Kviscosity(:) + if (CS%id_Kt_KPP > 0) CS%Kt_KPP(i,j,:) = US%m2_s_to_Z2_T * Kdiffusivity(:,1) + if (CS%id_Ks_KPP > 0) CS%Ks_KPP(i,j,:) = US%m2_s_to_Z2_T * Kdiffusivity(:,2) + if (CS%id_Kv_KPP > 0) CS%Kv_KPP(i,j,:) = US%m2_s_to_Z2_T * Kviscosity(:) ! Update output of routine if (.not. CS%passiveMode) then if (CS%KPPisAdditive) then do k=1, GV%ke+1 - Kt(i,j,k) = Kt(i,j,k) + US%m2_s_to_Z2_T * Kdiffusivity(k,1) - Ks(i,j,k) = Ks(i,j,k) + US%m2_s_to_Z2_T * Kdiffusivity(k,2) - Kv(i,j,k) = Kv(i,j,k) + US%m2_s_to_Z2_T * Kviscosity(k) + Kt(i,j,k) = Kt(i,j,k) + GV%m2_s_to_HZ_T * Kdiffusivity(k,1) + Ks(i,j,k) = Ks(i,j,k) + GV%m2_s_to_HZ_T * Kdiffusivity(k,2) + Kv(i,j,k) = Kv(i,j,k) + GV%m2_s_to_HZ_T * Kviscosity(k) if (CS%Stokes_Mixing) Waves%KvS(i,j,k) = Kv(i,j,k) enddo else ! KPP replaces prior diffusivity when former is non-zero do k=1, GV%ke+1 - if (Kdiffusivity(k,1) /= 0.) Kt(i,j,k) = US%m2_s_to_Z2_T * Kdiffusivity(k,1) - if (Kdiffusivity(k,2) /= 0.) Ks(i,j,k) = US%m2_s_to_Z2_T * Kdiffusivity(k,2) - if (Kviscosity(k) /= 0.) Kv(i,j,k) = US%m2_s_to_Z2_T * Kviscosity(k) + if (Kdiffusivity(k,1) /= 0.) Kt(i,j,k) = GV%m2_s_to_HZ_T * Kdiffusivity(k,1) + if (Kdiffusivity(k,2) /= 0.) Ks(i,j,k) = GV%m2_s_to_HZ_T * Kdiffusivity(k,2) + if (Kviscosity(k) /= 0.) Kv(i,j,k) = GV%m2_s_to_HZ_T * Kviscosity(k) if (CS%Stokes_Mixing) Waves%KvS(i,j,k) = Kv(i,j,k) enddo endif @@ -881,14 +965,14 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & ! end of the horizontal do-loops over the vertical columns - enddo ! i + endif ; enddo ! i enddo ! j call cpu_clock_end(id_clock_KPP_calc) if (CS%debug) then - call hchksum(Kt, "KPP out: Kt", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Ks, "KPP out: Ks", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kt, "KPP out: Kt", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Ks, "KPP out: Ks", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif ! send diagnostics to post_data @@ -916,106 +1000,143 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl type(ocean_grid_type), intent(inout) :: G !< Ocean grid type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer/level thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: Temp !< potential/cons temp [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: Salt !< Salinity [ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: Temp !< potential/cons temp [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: Salt !< Salinity [S ~> ppt] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Velocity i-component [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Velocity j-component [L T-1 ~> m s-1] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: uStar !< Surface friction velocity [Z T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: buoyFlux !< Surface buoyancy flux [L2 T-3 ~> m2 s-3] type(wave_parameters_CS), pointer :: Waves !< Wave CS for Langmuir turbulence - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: lamult!< Langmuir enhancement factor + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: lamult !< Langmuir enhancement factor [nondim] ! Local variables - integer :: i, j, k, km1 ! Loop indices - real, dimension( GV%ke ) :: cellHeight ! Cell center heights referenced to surface [m] (negative in ocean) - real, dimension( GV%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [m] (negative in ocean) - real, dimension( GV%ke+1 ) :: N2_1d ! Brunt-Vaisala frequency squared, at interfaces [s-2] - real, dimension( GV%ke ) :: Ws_1d ! Profile of vertical velocity scale for scalars [m s-1] - real, dimension( GV%ke ) :: deltaRho ! delta Rho in numerator of Bulk Ri number [R ~> kg m-3] - real, dimension( GV%ke ) :: deltaU2 ! square of delta U (shear) in denominator of Bulk Ri [m2 s-2] - real, dimension( GV%ke ) :: surfBuoyFlux2 - real, dimension( GV%ke ) :: BulkRi_1d ! Bulk Richardson number for each layer [nondim] - - ! for EOS calculation + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Height change across layers [Z ~> m] + ! Variables for passing to CVMix routines, often in MKS units + real, dimension( GV%ke ) :: Ws_1d ! Profile of vertical velocity scale for scalars in MKS units [m s-1] + real, dimension( GV%ke ) :: deltaRho ! delta Rho in numerator of Bulk Ri number [R ~> kg m-3] + real, dimension( GV%ke ) :: deltaBuoy ! Change in Buoyancy based on deltaRho [m s-2] + real, dimension( GV%ke ) :: deltaU2 ! square of delta U (shear) in denominator of Bulk Ri [m2 s-2] + real, dimension( GV%ke ) :: surfBuoyFlux2 ! Surface buoyancy flux in MKS units [m2 s-3] + real, dimension( GV%ke ) :: BulkRi_1d ! Bulk Richardson number for each layer [nondim] + real, dimension( GV%ke ) :: Vt2_1d ! Unresolved squared turbulence velocity for bulk Ri [m2 s-2] + real, dimension( GV%ke ) :: z_cell ! Cell center heights referenced to surface [m] (negative in ocean) + real, dimension( GV%ke ) :: OBL_depth ! Cell center depths referenced to surface [m] (positive in ocean) + real, dimension( GV%ke+1 ) :: z_inter ! Cell interface heights referenced to surface [m] (negative in ocean) + real, dimension( GV%ke+1 ) :: N_col ! A column of buoyancy frequencies at interfaces in MKS units [s-1] + real :: surfFricVel ! Surface friction velocity in MKS units [m s-1] + real :: surfBuoyFlux ! Surface buoyancy flux in MKS units [m2 s-3] + real :: Coriolis ! Coriolis parameter at tracer points in MKS units [s-1] + real :: KPP_OBL_depth ! Boundary layer depth calculated by CVMix_kpp_compute_OBL_depth in MKS units [m] + + ! Variables for EOS calculations real, dimension( 3*GV%ke ) :: rho_1D ! A column of densities [R ~> kg m-3] real, dimension( 3*GV%ke ) :: pres_1D ! A column of pressures [R L2 T-2 ~> Pa] - real, dimension( 3*GV%ke ) :: Temp_1D ! A column of temperatures [degC] - real, dimension( 3*GV%ke ) :: Salt_1D ! A column of salinities [ppt] - - real :: surfFricVel, surfBuoyFlux, Coriolis - real :: GoRho ! Gravitational acceleration divided by density in MKS units [m R-1 s-2 ~> m4 kg-1 s-2] - real :: pRef ! The interface pressure [R L2 T-2 ~> Pa] - real :: rho1, rhoK, Uk, Vk, sigma, sigmaRatio - - real :: zBottomMinusOffset ! Height of bottom plus a little bit [m] - real :: SLdepth_0d ! Surface layer depth = surf_layer_ext*OBLdepth. - real :: hTot ! Running sum of thickness used in the surface layer average [m] - real :: buoy_scale ! A unit conversion factor for buoyancy fluxes [m2 T3 L-2 s-3 ~> 1] - real :: delH ! Thickness of a layer [m] - real :: surfHtemp, surfTemp ! Integral and average of temp over the surface layer - real :: surfHsalt, surfSalt ! Integral and average of saln over the surface layer - real :: surfHu, surfU ! Integral and average of u over the surface layer - real :: surfHv, surfV ! Integral and average of v over the surface layer - real :: dh ! The local thickness used for calculating interface positions [m] - real :: hcorr ! A cumulative correction arising from inflation of vanished layers [m] - integer :: kk, ksfc, ktmp + real, dimension( 3*GV%ke ) :: Temp_1D ! A column of temperatures [C ~> degC] + real, dimension( 3*GV%ke ) :: Salt_1D ! A column of salinities [S ~> ppt] + + real, dimension( GV%ke ) :: cellHeight ! Cell center heights referenced to surface [Z ~> m] (negative in ocean) + real, dimension( GV%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [Z ~> m] (negative in ocean) + real, dimension( GV%ke+1 ) :: N2_1d ! Brunt-Vaisala frequency squared, at interfaces [T-2 ~> s-2] + real :: zBottomMinusOffset ! Height of bottom plus a little bit [Z ~> m] + real :: GoRho ! Gravitational acceleration in MKS units divided by density [m s-2 R-1 ~> m4 kg-1 s-2] + real :: GoRho_Z_L2 ! Gravitational acceleration, perhaps divided by density, times aspect ratio + ! rescaling [H T-2 R-1 ~> m4 kg-1 s-2 or m s-2] + real :: pRef ! The interface pressure [R L2 T-2 ~> Pa] + real :: Uk, Vk ! Layer velocities relative to their averages in the surface layer [L T-1 ~> m s-1] + real :: SLdepth_0d ! Surface layer depth = surf_layer_ext*OBLdepth [Z ~> m] + real :: hTot ! Running sum of thickness used in the surface layer average [Z ~> m] + real :: I_hTot ! The inverse of hTot [Z-1 ~> m-1] + real :: buoy_scale ! A unit conversion factor for buoyancy fluxes [m2 T3 L-2 s-3 ~> 1] + real :: delH ! Thickness of a layer [Z ~> m] + real :: surfTemp ! Average of temperature over the surface layer [C ~> degC] + real :: surfHtemp ! Integral of temperature over the surface layer [Z C ~> m degC] + real :: surfSalt ! Average of salinity over the surface layer [S ~> ppt] + real :: surfHsalt ! Integral of salinity over the surface layer [Z S ~> m ppt] + real :: surfHu, surfHv ! Integral of u and v over the surface layer [Z L T-1 ~> m2 s-1] + real :: surfU, surfV ! Average of u and v over the surface layer [Z T-1 ~> m s-1] + real :: dh ! The local thickness used for calculating interface positions [Z ~> m] + real :: hcorr ! A cumulative correction arising from inflation of vanished layers [Z ~> m] ! For Langmuir Calculations - real :: LangEnhVt2 ! Langmuir enhancement for unresolved shear - real, dimension(GV%ke) :: U_H, V_H - real :: MLD_GUESS, LA - real :: surfHuS, surfHvS, surfUs, surfVs, wavedir, currentdir - real :: VarUp, VarDn, M, VarLo, VarAvg - real :: H10pct, H20pct,CMNFACT, USx20pct, USy20pct, enhvt2 - integer :: B - real :: WST + real :: Vt_layer ! non-dimensional extent contribution to unresolved shear + real :: LangEnhVt2 ! Langmuir enhancement for unresolved shear [nondim] + real, dimension(GV%ke) :: U_H, V_H ! Velocities at tracer points [L T-1 ~> m s-1] + real :: MLD_guess ! A guess at the mixed layer depth for calculating the Langmuir number [Z ~> m] + real :: LA ! The local Langmuir number [nondim] + real :: surfHuS, surfHvS ! Stokes drift velocities integrated over the boundary layer [Z L T-1 ~> m2 s-1] + real :: surfUs, surfVs ! Stokes drift velocities averaged over the boundary layer [Z T-1 ~> m s-1] + + integer :: i, j, k, km1, kk, ksfc, ktmp ! Loop indices + + real, dimension(GV%ke) :: uE_H, vE_H ! Eulerian velocities h-points, centers [L T-1 ~> m s-1] + real, dimension(GV%ke) :: uS_H, vS_H ! Stokes drift components h-points, centers [L T-1 ~> m s-1] + real, dimension(GV%ke) :: uSbar_H, vSbar_H ! Cell Average Stokes drift h-points [L T-1 ~> m s-1] + real, dimension(GV%ke+1) :: uS_Hi, vS_Hi ! Stokes Drift components at interfaces [L T-1 ~> m s-1] + real :: uS_SLD , vS_SLD, uS_SLC , vS_SLC, uSbar_SLD, vSbar_SLD ! Stokes at/to to Surface Layer Extent + ! [L T-1 ~> m s-1] + real :: StokesXI ! Stokes similarity parameter [nondim] + real, dimension( GV%ke ) :: StokesXI_1d , StokesVt_1d ! Parameters of TKE production ratio [nondim] + integer :: kbl ! index of cell containing boundary layer depth if (CS%Stokes_Mixing .and. .not.associated(Waves)) call MOM_error(FATAL, & "KPP_compute_BLD: The Waves control structure must be associated if STOKES_MIXING is True.") if (CS%debug) then - call hchksum(Salt, "KPP in: S",G%HI,haloshift=0) - call hchksum(Temp, "KPP in: T",G%HI,haloshift=0) - call hchksum(u, "KPP in: u",G%HI,haloshift=0,scale=US%L_T_to_m_s) - call hchksum(v, "KPP in: v",G%HI,haloshift=0,scale=US%L_T_to_m_s) + call hchksum(Salt, "KPP in: S", G%HI, haloshift=0, unscale=US%S_to_ppt) + call hchksum(Temp, "KPP in: T", G%HI, haloshift=0, unscale=US%C_to_degC) + call hchksum(u, "KPP in: u", G%HI, haloshift=0, unscale=US%L_T_to_m_s) + call hchksum(v, "KPP in: v", G%HI, haloshift=0, unscale=US%L_T_to_m_s) endif call cpu_clock_begin(id_clock_KPP_compute_BLD) ! some constants - GoRho = US%L_T_to_m_s**2*US%m_to_Z * GV%g_Earth / GV%Rho0 + GoRho = US%Z_to_m*US%s_to_T**2 * (GV%g_Earth_Z_T2 / GV%Rho0) + if (GV%Boussinesq) then + GoRho_Z_L2 = GV%Z_to_H * GV%g_Earth_Z_T2 / GV%Rho0 + else + GoRho_Z_L2 = GV%g_Earth_Z_T2 * GV%RZ_to_H + endif buoy_scale = US%L_to_m**2*US%s_to_T**3 + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, G, GV, US) + ! loop over horizontal points on processor !$OMP parallel do default(none) private(surfFricVel, iFaceHeight, hcorr, dh, cellHeight, & - !$OMP surfBuoyFlux, U_H, V_H, Coriolis, pRef, SLdepth_0d, & + !$OMP surfBuoyFlux, U_H, V_H, Coriolis, pRef, SLdepth_0d, vt2_1d, & !$OMP ksfc, surfHtemp, surfHsalt, surfHu, surfHv, surfHuS, & - !$OMP surfHvS, hTot, delH, surftemp, surfsalt, surfu, surfv, & - !$OMP surfUs, surfVs, Uk, Vk, deltaU2, km1, kk, pres_1D, & - !$OMP Temp_1D, salt_1D, surfBuoyFlux2, MLD_GUESS, LA, rho_1D, & - !$OMP deltarho, N2_1d, ws_1d, LangEnhVT2, enhvt2, wst, & - !$OMP BulkRi_1d, zBottomMinusOffset) & - !$OMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, & - !$OMP Temp, Salt, waves, tv, GoRho, u, v, lamult) + !$OMP surfHvS, hTot, I_hTot, delH, surftemp, surfsalt, surfu, surfv, & + !$OMP surfUs, surfVs, Uk, Vk, deltaU2, km1, kk, pres_1D, N_col, & + !$OMP Temp_1D, salt_1D, surfBuoyFlux2, MLD_guess, LA, rho_1D, & + !$OMP deltarho, deltaBuoy, N2_1d, ws_1d, LangEnhVT2,KPP_OBL_depth, z_cell, & + !$OMP z_inter, OBL_depth, BulkRi_1d, zBottomMinusOffset, uE_H, vE_H, & + !$OMP uS_H, vS_H, uSbar_H, vSbar_H , uS_Hi, vS_Hi, & + !$OMP uS_SLD, vS_SLD, uS_SLC, vS_SLC, uSbar_SLD, vSbar_SLD, & + !$OMP StokesXI, StokesXI_1d, StokesVt_1d, kbl) & + !$OMP shared(G, GV, CS, US, uStar, h, dz, buoy_scale, buoyFlux, & + !$OMP Temp, Salt, waves, tv, GoRho, GoRho_Z_L2, u, v, lamult, Vt_layer) do j = G%jsc, G%jec - do i = G%isc, G%iec - - ! skip calling KPP for land points - if (G%mask2dT(i,j)==0.) cycle + do i = G%isc, G%iec ; if (G%mask2dT(i,j) > 0.0) then do k=1,GV%ke - U_H(k) = 0.5 * US%L_T_to_m_s*(u(i,j,k)+u(i-1,j,k)) - V_H(k) = 0.5 * US%L_T_to_m_s*(v(i,j,k)+v(i,j-1,k)) + U_H(k) = 0.5 * (u(I,j,k)+u(I-1,j,k)) + V_H(k) = 0.5 * (v(i,J,k)+v(i,J-1,k)) enddo - + if (CS%StokesMOST) then + do k=1,GV%ke + uE_H(k) = 0.5 * (u(I,j,k)+u(I-1,j,k)-Waves%US_x(I,j,k)-Waves%US_x(I-1,j,k)) + vE_H(k) = 0.5 * (v(i,J,k)+v(i,J-1,k)-Waves%US_y(i,J,k)-Waves%US_y(i,J-1,k)) + enddo + endif ! things independent of position within the column Coriolis = 0.25*US%s_to_T*( (G%CoriolisBu(i,j) + G%CoriolisBu(i-1,j-1)) + & (G%CoriolisBu(i-1,j) + G%CoriolisBu(i,j-1)) ) surfFricVel = US%Z_to_m*US%s_to_T * uStar(i,j) - ! Bullk Richardson number computed for each cell in a column, + ! Bulk Richardson number computed for each cell in a column, ! assuming OBLdepth = grid cell depth. After Rib(k) is ! known for the column, then CVMix interpolates to find ! the actual OBLdepth. This approach avoids need to iterate @@ -1024,10 +1145,13 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl iFaceHeight(1) = 0.0 ! BBL is all relative to the surface pRef = 0. ; if (associated(tv%p_surf)) pRef = tv%p_surf(i,j) hcorr = 0. - do k=1,GV%ke + if (CS%StokesMOST) call Compute_StokesDrift( i, j, h(i,j,1) , iFaceHeight(1), & + uS_Hi(1), vS_Hi(1), uS_H(1), vS_H(1), uSbar_H(1), vSbar_H(1), Waves) + + do k=1,GV%ke ! cell center and cell bottom in meters (negative values in the ocean) - dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment + dh = dz(i,j,k) ! Nominal thickness to use for increment dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness @@ -1044,58 +1168,112 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl endif enddo - ! average temp, saln, u, v over surface layer - ! use C-grid average to get u,v on T-points. - surfHtemp=0.0 - surfHsalt=0.0 - surfHu =0.0 - surfHv =0.0 - surfHuS =0.0 - surfHvS =0.0 - hTot =0.0 - do ktmp = 1,ksfc - - ! SLdepth_0d can be between cell interfaces - delH = min( max(0.0, SLdepth_0d - hTot), h(i,j,ktmp)*GV%H_to_m ) - - ! surface layer thickness - hTot = hTot + delH - - ! surface averaged fields - surfHtemp = surfHtemp + Temp(i,j,ktmp) * delH - surfHsalt = surfHsalt + Salt(i,j,ktmp) * delH - surfHu = surfHu + 0.5*US%L_T_to_m_s*(u(i,j,ktmp)+u(i-1,j,ktmp)) * delH - surfHv = surfHv + 0.5*US%L_T_to_m_s*(v(i,j,ktmp)+v(i,j-1,ktmp)) * delH + if (CS%StokesMOST) then + ! if k=1, want buoyFlux(i,j,1) - buoyFlux(i,j,2), otherwise + ! subtract average of buoyFlux(i,j,k) and buoyFlux(i,j,k+1) + surfBuoyFlux = buoy_scale * & + (buoyFlux(i,j,1) - 0.5*(buoyFlux(i,j,max(2,k))+buoyFlux(i,j,k+1)) ) + surfBuoyFlux2(k) = surfBuoyFlux + call Compute_StokesDrift(i,j, iFaceHeight(k),iFaceHeight(k+1), & + uS_Hi(k+1), vS_Hi(k+1), uS_H(k), vS_H(k), uSbar_H(k), vSbar_H(k), Waves) + call Compute_StokesDrift(i,j, iFaceHeight(ksfc) , -SLdepth_0d, & + uS_SLD , vS_SLD, uS_SLC , vS_SLC, uSbar_SLD, vSbar_SLD, Waves) + call cvmix_kpp_compute_StokesXi( iFaceHeight,CellHeight,ksfc ,SLdepth_0d,surfBuoyFlux, & + surfFricVel,waves%omega_w2x(i,j), uE_H, vE_H, uS_Hi, vS_Hi, uSbar_H, vSbar_H, uS_SLD,& + vS_SLD, uSbar_SLD, vSbar_SLD, StokesXI, CVMix_kpp_params_user=CS%KPP_params ) + StokesXI_1d(k) = StokesXI + StokesVt_1d(k) = 0.0 ! StokesXI + + ! average temperature, salinity, u and v over surface layer starting at ksfc + delH = SLdepth_0d + iFaceHeight(ksfc) + surfHtemp = Temp(i,j,ksfc) * delH + surfHsalt = Salt(i,j,ksfc) * delH + surfHu = (uE_H(ksfc) + uSbar_SLD) * delH + surfHv = (vE_H(ksfc) + vSbar_SLD) * delH + hTot = delH + do ktmp = 1,ksfc-1 ! if ksfc >=2 + delH = h(i,j,ktmp)*GV%H_to_Z + hTot = hTot + delH + surfHtemp = surfHtemp + Temp(i,j,ktmp) * delH + surfHsalt = surfHsalt + Salt(i,j,ktmp) * delH + surfHu = surfHu + (uE_H(ktmp) + uSbar_H(ktmp)) * delH + surfHv = surfHv + (vE_H(ktmp) + vSbar_H(ktmp)) * delH + enddo + I_hTot = 1./hTot + surfTemp = surfHtemp * I_hTot + surfSalt = surfHsalt * I_hTot + surfU = surfHu * I_hTot + surfV = surfHv * I_hTot + + Uk = uE_H(k) + uS_H(k) - surfU + Vk = vE_H(k) + vS_H(k) - surfV + + else !not StokesMOST + StokesXI_1d(k) = 0.0 + ! average temperature, salinity, u and v over surface layer + ! use C-grid average to get u and v on T-points. + surfHtemp = 0.0 + surfHsalt = 0.0 + surfHu = 0.0 + surfHv = 0.0 + surfHuS = 0.0 + surfHvS = 0.0 + hTot = 0.0 + do ktmp = 1,ksfc + + ! SLdepth_0d can be between cell interfaces + delH = min( max(0.0, SLdepth_0d - hTot), dz(i,j,ktmp) ) + + ! surface layer thickness + hTot = hTot + delH + + ! surface averaged fields + surfHtemp = surfHtemp + Temp(i,j,ktmp) * delH + surfHsalt = surfHsalt + Salt(i,j,ktmp) * delH + surfHu = surfHu + 0.5*(u(i,j,ktmp)+u(i-1,j,ktmp)) * delH + surfHv = surfHv + 0.5*(v(i,j,ktmp)+v(i,j-1,ktmp)) * delH + if (CS%Stokes_Mixing) then + surfHus = surfHus + 0.5*(Waves%US_x(i,j,ktmp)+Waves%US_x(i-1,j,ktmp)) * delH + surfHvs = surfHvs + 0.5*(Waves%US_y(i,j,ktmp)+Waves%US_y(i,j-1,ktmp)) * delH + endif + + enddo + !I_hTot = 1./hTot + !surfTemp = surfHtemp * I_hTot + !surfSalt = surfHsalt * I_hTot + !surfU = surfHu * I_hTot + !surfV = surfHv * I_hTot + !surfUs = surfHus * I_hTot + !surfVs = surfHvs * I_hTot + + surfTemp = surfHtemp / hTot + surfSalt = surfHsalt / hTot + surfU = surfHu / hTot + surfV = surfHv / hTot + surfUs = surfHus / hTot + surfVs = surfHvs / hTot + ! vertical shear between present layer and surface layer averaged surfU and surfV. + ! C-grid average to get Uk and Vk on T-points. + Uk = 0.5*(u(i,j,k)+u(i-1,j,k)) - surfU + Vk = 0.5*(v(i,j,k)+v(i,j-1,k)) - surfV + if (CS%Stokes_Mixing) then - surfHus = surfHus + 0.5*US%L_T_to_m_s*(Waves%US_x(i,j,ktmp)+Waves%US_x(i-1,j,ktmp)) * delH - surfHvs = surfHvs + 0.5*US%L_T_to_m_s*(Waves%US_y(i,j,ktmp)+Waves%US_y(i,j-1,ktmp)) * delH + ! If momentum is mixed down the Stokes drift gradient, then + ! the Stokes drift must be included in the bulk Richardson number + ! calculation. + Uk = Uk + (0.5*(Waves%Us_x(i,j,k)+Waves%US_x(i-1,j,k)) - surfUs ) + Vk = Vk + (0.5*(Waves%Us_y(i,j,k)+Waves%Us_y(i,j-1,k)) - surfVs ) endif - enddo - surfTemp = surfHtemp / hTot - surfSalt = surfHsalt / hTot - surfU = surfHu / hTot - surfV = surfHv / hTot - surfUs = surfHus / hTot - surfVs = surfHvs / hTot - - ! vertical shear between present layer and - ! surface layer averaged surfU,surfV. - ! C-grid average to get Uk and Vk on T-points. - Uk = 0.5*US%L_T_to_m_s*(u(i,j,k)+u(i-1,j,k)) - surfU - Vk = 0.5*US%L_T_to_m_s*(v(i,j,k)+v(i,j-1,k)) - surfV - - if (CS%Stokes_Mixing) then - ! If momentum is mixed down the Stokes drift gradient, then - ! the Stokes drift must be included in the bulk Richardson number - ! calculation. - Uk = Uk + (0.5*US%L_T_to_m_s*(Waves%Us_x(i,j,k)+Waves%US_x(i-1,j,k)) - surfUs ) - Vk = Vk + (0.5*US%L_T_to_m_s*(Waves%Us_y(i,j,k)+Waves%Us_y(i,j-1,k)) - surfVs ) - endif + ! this difference accounts for penetrating SW + surfBuoyFlux = buoy_scale * (buoyFlux(i,j,1) - buoyFlux(i,j,k+1)) + surfBuoyFlux2(k) = surfBuoyFlux - deltaU2(k) = Uk**2 + Vk**2 + endif ! StokesMOST - ! pressure, temp, and saln for EOS + deltaU2(k) = US%L_T_to_m_s**2 * ((Uk**2) + (Vk**2)) + + ! pressure, temperature, and salinity for calling the equation of state ! kk+1 = surface fields ! kk+2 = k fields ! kk+3 = km1 fields @@ -1115,16 +1293,13 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl ! iterate pRef for next pass through k-loop. pRef = pRef + (GV%g_Earth * GV%H_to_RZ) * h(i,j,k) - ! this difference accounts for penetrating SW - surfBuoyFlux2(k) = buoy_scale * (buoyFlux(i,j,1) - buoyFlux(i,j,k+1)) - enddo ! k-loop finishes - if (CS%LT_K_ENHANCEMENT .or. CS%LT_VT2_ENHANCEMENT) then - MLD_GUESS = max( 1.*US%m_to_Z, abs(US%m_to_Z*CS%OBLdepthprev(i,j) ) ) + if ( (CS%LT_K_ENHANCEMENT .or. CS%LT_VT2_ENHANCEMENT) .and. .not. present(lamult)) then + MLD_guess = max( CS%MLD_guess_min, abs(CS%OBLdepthprev(i,j) ) ) call get_Langmuir_Number(LA, G, GV, US, MLD_guess, uStar(i,j), i, j, & - H=H(i,j,:), U_H=U_H, V_H=V_H, WAVES=WAVES) - CS%La_SL(i,j)=LA + dz=dz(i,j,:), U_H=U_H, V_H=V_H, WAVES=WAVES) + CS%La_SL(i,j) = LA endif @@ -1138,24 +1313,42 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl km1 = max(1, k-1) kk = 3*(k-1) deltaRho(k) = rho_1D(kk+2) - rho_1D(kk+1) - N2_1d(k) = (GoRho * (rho_1D(kk+2) - rho_1D(kk+3)) ) / & - ((0.5*(h(i,j,km1) + h(i,j,k))+GV%H_subroundoff)*GV%H_to_m) + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + deltaBuoy(k) = GoRho*(rho_1D(kk+2) - rho_1D(kk+1)) + else + deltaBuoy(k) = (US%Z_to_m*US%s_to_T**2) * GV%g_Earth_Z_T2 * & + ( (rho_1D(kk+2) - rho_1D(kk+1)) / (0.5 * (rho_1D(kk+2) + rho_1D(kk+1))) ) + endif + N2_1d(k) = (GoRho_Z_L2 * (rho_1D(kk+2) - rho_1D(kk+3)) ) / & + ((0.5*(h(i,j,km1) + h(i,j,k))+GV%H_subroundoff)) CS%N(i,j,k) = sqrt( max( N2_1d(k), 0.) ) enddo N2_1d(GV%ke+1 ) = 0.0 CS%N(i,j,GV%ke+1 ) = 0.0 - ! turbulent velocity scales w_s and w_m computed at the cell centers. - ! Note that if sigma > CS%surf_layer_ext, then CVMix_kpp_compute_turbulent_scales - ! computes w_s and w_m velocity scale at sigma=CS%surf_layer_ext. So we only pass - ! sigma=CS%surf_layer_ext for this calculation. - call CVMix_kpp_compute_turbulent_scales( & - CS%surf_layer_ext, & ! (in) Normalized surface layer depth; sigma = CS%surf_layer_ext - -cellHeight, & ! (in) Assume here that OBL depth [m] = -cellHeight(k) - surfBuoyFlux2, & ! (in) Buoyancy flux at surface [m2 s-3] - surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] - w_s=Ws_1d, & ! (out) Turbulent velocity scale profile [m s-1] - CVMix_kpp_params_user=CS%KPP_params ) + ! Convert columns to MKS units for passing to CVMix + do k = 1, GV%ke + OBL_depth(k) = -US%Z_to_m * cellHeight(k) + z_cell(k) = US%Z_to_m*cellHeight(k) + enddo + do K = 1, GV%ke+1 + N_col(K) = US%s_to_T*CS%N(i,j,K) + z_inter(K) = US%Z_to_m*iFaceHeight(K) + enddo + + ! CVMix_kpp_compute_turbulent_scales_1d_OBL computes w_s velocity scale at cell centers for + ! CVmix_kpp_compute_bulk_Richardson call to CVmix_kpp_compute_unresolved_shear + ! at sigma=Vt_layer (CS%surf_layer_ext or 1.0) for this calculation. + ! StokesVt_1d controls Stokes enhancement (= 0 for none) + Vt_layer = 1.0 ! CS%surf_layer_ext + call CVMix_kpp_compute_turbulent_scales( & ! 1d_OBL + Vt_layer, & ! (in) Boundary layer extent contributing to unresolved shear + OBL_depth, & ! (in) OBL depth [m] + surfBuoyFlux2, & ! (in) Buoyancy flux at surface [m2 s-3] + surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] + xi=StokesVt_1d, & ! (in) Stokes similarity parameter-->1/CHI(xi) enhance of Vt + w_s=Ws_1d, & ! (out) Turbulent velocity scale profile [m s-1] + CVMix_kpp_params_user=CS%KPP_params ) ! Determine the enhancement factor for unresolved shear IF (CS%LT_VT2_ENHANCEMENT) then @@ -1182,79 +1375,119 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl ! Calculate Bulk Richardson number from eq (21) of LMD94 BulkRi_1d = CVmix_kpp_compute_bulk_Richardson( & - zt_cntr = cellHeight(1:GV%ke), & ! Depth of cell center [m] - delta_buoy_cntr=GoRho*deltaRho, & ! Bulk buoyancy difference, Br-B(z) [m s-2] + zt_cntr=z_cell, & ! Depth of cell center [m] + delta_buoy_cntr=deltaBuoy, & ! Bulk buoyancy difference, Br-B(z) [m s-2] delta_Vsqr_cntr=deltaU2, & ! Square of resolved velocity difference [m2 s-2] ws_cntr=Ws_1d, & ! Turbulent velocity scale profile [m s-1] - N_iface=CS%N(i,j,:), & ! Buoyancy frequency [s-1] + N_iface=N_col, & ! Buoyancy frequency [s-1] EFactor=LangEnhVT2, & ! Langmuir enhancement factor [nondim] - LaSL = CS%La_SL(i,j), & ! surface layer averaged Langmuir number [nondim] - bfsfc = surfBuoyFlux, & ! surface buoyancy flux [m2 s-3] - uStar = uStar(i,j), & ! surface friction velocity [m s-1] + LaSL=CS%La_SL(i,j), & ! surface layer averaged Langmuir number [nondim] + bfsfc=surfBuoyFlux2, & ! surface buoyancy flux [m2 s-3] + uStar=surfFricVel, & ! surface friction velocity [m s-1] CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters +! ! A hack to avoid KPP reaching the bottom. It was needed during development +! ! because KPP was unable to handle vanishingly small layers near the bottom. +! if (CS%deepOBLoffset>0.) then +! zBottomMinusOffset = iFaceHeight(GV%ke+1) + min(CS%deepOBLoffset, -0.1*iFaceHeight(GV%ke+1)) +! CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -zBottomMinusOffset ) +! endif + zBottomMinusOffset = iFaceHeight(GV%ke+1) + min(CS%deepOBLoffset,-0.1*iFaceHeight(GV%ke+1)) call CVMix_kpp_compute_OBL_depth( & - BulkRi_1d, & ! (in) Bulk Richardson number - iFaceHeight, & ! (in) Height of interfaces [m] - CS%OBLdepth(i,j), & ! (out) OBL depth [m] - CS%kOBL(i,j), & ! (out) level (+fraction) of OBL extent - zt_cntr=cellHeight, & ! (in) Height of cell centers [m] - surf_fric=surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] - surf_buoy=surfBuoyFlux, & ! (in) Buoyancy flux at surface [m2 s-3] - Coriolis=Coriolis, & ! (in) Coriolis parameter [s-1] - CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters + BulkRi_1d, & ! (in) Bulk Richardson number + z_inter, & ! (in) Height of interfaces [m] + KPP_OBL_depth, & ! (out) OBL depth [m] + CS%kOBL(i,j), & ! (out) level (+fraction) of OBL extent + zt_cntr=z_cell, & ! (in) Height of cell centers [m] + surf_fric=surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] + surf_buoy=surfBuoyFlux2, & ! (in) Buoyancy flux at surface [m2 s-3] + Coriolis=Coriolis, & ! (in) Coriolis parameter [s-1] + Xi = StokesXI_1d, & ! (in) Stokes similarity parameter Lmob limit (1-Xi) + zBottom = zBottomMinusOffset, & ! (in) Numerical limit on OBLdepth + CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters + CS%OBLdepth(i,j) = US%m_to_Z * KPP_OBL_depth + + if (CS%StokesMOST) then + kbl = int(CS%kOBL(i,j)) + SLdepth_0d = CS%surf_layer_ext*CS%OBLdepth(i,j) + surfBuoyFlux = surfBuoyFlux2(kbl) + ! find ksfc for cell where "surface layer" sits + ksfc = kbl + do ktmp = 1, kbl + if (-1.0*iFaceHeight(ktmp+1) >= SLdepth_0d) then + ksfc = ktmp + exit + endif + enddo + + call Compute_StokesDrift(i,j, iFaceHeight(ksfc) , -SLdepth_0d, & + uS_SLD , vS_SLD, uS_SLC , vS_SLC, uSbar_SLD, vSbar_SLD, Waves) + call cvmix_kpp_compute_StokesXi( iFaceHeight,CellHeight,ksfc ,SLdepth_0d, & + surfBuoyFlux, surfFricVel,waves%omega_w2x(i,j), uE_H, vE_H, uS_Hi, & + vS_Hi, uSbar_H, vSbar_H, uS_SLD, vS_SLD, uSbar_SLD, vSbar_SLD, & + StokesXI, CVMix_kpp_params_user=CS%KPP_params ) + CS%StokesParXI(i,j) = StokesXI + CS%Lam2(i,j) = sqrt(US_Hi(1)**2+VS_Hi(1)**2) / MAX(surfFricVel,0.0002) + + else !.not Stokes_MOST + CS%StokesParXI(i,j) = 10.0 + CS%Lam2(i,j) = sqrt(US_Hi(1)**2+VS_Hi(1)**2) / MAX(surfFricVel,0.0002) ! A hack to avoid KPP reaching the bottom. It was needed during development ! because KPP was unable to handle vanishingly small layers near the bottom. if (CS%deepOBLoffset>0.) then - zBottomMinusOffset = iFaceHeight(GV%ke+1) + min(CS%deepOBLoffset,-0.1*iFaceHeight(GV%ke+1)) + zBottomMinusOffset = iFaceHeight(GV%ke+1) + min(CS%deepOBLoffset, -0.1*iFaceHeight(GV%ke+1)) CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -zBottomMinusOffset ) endif ! apply some constraints on OBLdepth - if(CS%fixedOBLdepth) CS%OBLdepth(i,j) = CS%fixedOBLdepth_value + if (CS%fixedOBLdepth) CS%OBLdepth(i,j) = CS%fixedOBLdepth_value CS%OBLdepth(i,j) = max( CS%OBLdepth(i,j), -iFaceHeight(2) ) ! no shallower than top layer CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -iFaceHeight(GV%ke+1) ) ! no deeper than bottom CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) + endif !Stokes_MOST + ! compute unresolved squared velocity for diagnostics if (CS%id_Vt2 > 0) then - CS%Vt2(i,j,:) = CVmix_kpp_compute_unresolved_shear( & - cellHeight(1:GV%ke), & ! Depth of cell center [m] - ws_cntr=Ws_1d, & ! Turbulent velocity scale profile, at centers [m s-1] - N_iface=CS%N(i,j,:), & ! Buoyancy frequency at interface [s-1] + Vt2_1d(:) = CVmix_kpp_compute_unresolved_shear( & + z_cell, & ! Depth of cell center [m] + ws_cntr=Ws_1d, & ! Turbulent velocity scale profile, at centers [m s-1] + N_iface=N_col, & ! Buoyancy frequency at interface [s-1] EFactor=LangEnhVT2, & ! Langmuir enhancement factor [nondim] LaSL=CS%La_SL(i,j), & ! surface layer averaged Langmuir number [nondim] - bfsfc=surfBuoyFlux, & ! surface buoyancy flux [m2 s-3] - uStar=uStar(i,j), & ! surface friction velocity [m s-1] + bfsfc=surfBuoyFlux2, & ! surface buoyancy flux [m2 s-3] + uStar=surfFricVel, & ! surface friction velocity [m s-1] CVmix_kpp_params_user=CS%KPP_params ) ! KPP parameters + CS%Vt2(i,j,:) = US%m_to_Z**2*US%T_to_s**2 * Vt2_1d(:) endif ! recompute wscale for diagnostics, now that we in fact know boundary layer depth !BGR consider if LTEnhancement is wanted for diagnostics if (CS%id_Ws > 0) then - call CVMix_kpp_compute_turbulent_scales( & - -CellHeight/CS%OBLdepth(i,j), & ! (in) Normalized boundary layer coordinate - CS%OBLdepth(i,j), & ! (in) OBL depth [m] + call CVMix_kpp_compute_turbulent_scales( & + -cellHeight(:)/CS%OBLdepth(i,j), & ! (in) Normalized boundary layer coordinate [nondim] + US%Z_to_m*CS%OBLdepth(i,j), & ! (in) OBL depth [m] surfBuoyFlux, & ! (in) Buoyancy flux at surface [m2 s-3] surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] + xi=StokesXI, & ! (in) Stokes similarity parameter-->1/CHI(xi) enhance w_s=Ws_1d, & ! (out) Turbulent velocity scale profile [m s-1] CVMix_kpp_params_user=CS%KPP_params) ! KPP parameters - CS%Ws(i,j,:) = Ws_1d(:) + CS%Ws(i,j,:) = US%m_to_Z*US%T_to_s*Ws_1d(:) endif ! Diagnostics if (CS%id_N2 > 0) CS%N2(i,j,:) = N2_1d(:) if (CS%id_BulkDrho > 0) CS%dRho(i,j,:) = deltaRho(:) if (CS%id_BulkRi > 0) CS%BulkRi(i,j,:) = BulkRi_1d(:) - if (CS%id_BulkUz2 > 0) CS%Uz2(i,j,:) = deltaU2(:) + if (CS%id_BulkUz2 > 0) CS%Uz2(i,j,:) = US%m_s_to_L_T**2 * deltaU2(:) if (CS%id_Tsurf > 0) CS%Tsurf(i,j) = surfTemp if (CS%id_Ssurf > 0) CS%Ssurf(i,j) = surfSalt if (CS%id_Usurf > 0) CS%Usurf(i,j) = surfU - if (CS%id_Vsurf > 0) CS%Vsurf(i,j) = surfv + if (CS%id_Vsurf > 0) CS%Vsurf(i,j) = surfV - enddo + endif ; enddo enddo call cpu_clock_end(id_clock_KPP_compute_BLD) @@ -1274,64 +1507,80 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl if (CS%id_La_SL > 0) call post_data(CS%id_La_SL, CS%La_SL, CS%diag) if (CS%id_Vt2 > 0) call post_data(CS%id_Vt2, CS%Vt2, CS%diag) + if (CS%StokesMOST) then + if (CS%id_StokesXI > 0) call post_data(CS%id_StokesXI, CS%StokesParXI, CS%diag) + if (CS%id_Lam2 > 0) call post_data(CS%id_Lam2 , CS%Lam2 , CS%diag) + endif + ! BLD smoothing: - if (CS%n_smooth > 0) call KPP_smooth_BLD(CS,G,GV,h) + if (CS%n_smooth > 0) call KPP_smooth_BLD(CS, G, GV, US, dz) end subroutine KPP_compute_BLD !> Apply a 1-1-4-1-1 Laplacian filter one time on BLD to reduce any horizontal two-grid-point noise -subroutine KPP_smooth_BLD(CS,G,GV,h) +subroutine KPP_smooth_BLD(CS, G, GV, US, dz) ! Arguments type(KPP_CS), pointer :: CS !< Control structure type(ocean_grid_type), intent(inout) :: G !< Ocean grid type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer/level thicknesses [H ~> m or kg m-2] - - ! local - real, dimension(SZI_(G),SZJ_(G)) :: OBLdepth_prev ! OBLdepth before s.th smoothing iteration [m] - real, dimension( GV%ke ) :: cellHeight ! Cell center heights referenced to surface [m] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: dz !< Layer thicknesses [Z ~> m] + + ! local variables + real, dimension(SZI_(G),SZJ_(G)) :: OBLdepth_prev ! OBLdepth before s.th smoothing iteration [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)) :: total_depth ! The total depth of the water column, adjusted + ! for the minimum layer thickness [Z ~> m] + real, dimension( GV%ke ) :: cellHeight ! Cell center heights referenced to surface [Z ~> m] ! (negative in the ocean) - real, dimension( GV%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [m] + real, dimension( GV%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [Z ~> m] ! (negative in the ocean) real :: wc, ww, we, wn, ws ! averaging weights for smoothing [nondim] - real :: dh ! The local thickness used for calculating interface positions [m] - real :: hcorr ! A cumulative correction arising from inflation of vanished layers [m] - integer :: i, j, k, s + real :: dh ! The local thickness used for calculating interface positions [Z ~> m] + real :: h_cor(SZI_(G)) ! A cumulative correction arising from inflation of vanished layers [Z ~> m] + real :: hcorr ! A cumulative correction arising from inflation of vanished layers [Z ~> m] + integer :: i, j, k, s, halo call cpu_clock_begin(id_clock_KPP_smoothing) - ! Update halos + ! Find the total water column thickness first, as it is reused for each smoothing pass. + total_depth(:,:) = 0.0 + + !$OMP parallel do default(shared) private(dh, h_cor) + do j = G%jsc, G%jec + h_cor(:) = 0. + do k=1,GV%ke + do i=G%isc,G%iec ; if (G%mask2dT(i,j) > 0.0) then + ! This code replicates the interface height calculations below. It could be simpler, as shown below. + dh = dz(i,j,k) ! Nominal thickness to use for increment + dh = dh + h_cor(i) ! Take away the accumulated error (could temporarily make dh<0) + h_cor(i) = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 + dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness + total_depth(i,j) = total_depth(i,j) + dh + endif ; enddo + enddo + enddo + ! A much simpler (but answer changing) version of the total_depth calculation would be + ! do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + ! total_depth(i,j) = total_depth(i,j) + dz(i,j,k) + ! enddo ; enddo ; enddo + + ! Update halos once, then march inward for each iteration + if (CS%n_smooth > 1) call pass_var(total_depth, G%Domain, halo=CS%n_smooth, complete=.false.) call pass_var(CS%OBLdepth, G%Domain, halo=CS%n_smooth) - if (CS%id_OBLdepth_original > 0) CS%OBLdepth_original = CS%OBLdepth + if (CS%id_OBLdepth_original > 0) CS%OBLdepth_original(:,:) = CS%OBLdepth(:,:) do s=1,CS%n_smooth - OBLdepth_prev = CS%OBLdepth + OBLdepth_prev(:,:) = CS%OBLdepth(:,:) + halo = CS%n_smooth - s ! apply smoothing on OBL depth - !$OMP parallel do default(none) shared(G, GV, CS, h, OBLdepth_prev) & - !$OMP private(wc, ww, we, wn, ws, dh, hcorr, cellHeight, iFaceHeight) - do j = G%jsc, G%jec - do i = G%isc, G%iec - - ! skip land points - if (G%mask2dT(i,j)==0.) cycle - - iFaceHeight(1) = 0.0 ! BBL is all relative to the surface - hcorr = 0. - do k=1,GV%ke - - ! cell center and cell bottom in meters (negative values in the ocean) - dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment - dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) - hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 - dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness - cellHeight(k) = iFaceHeight(k) - 0.5 * dh - iFaceHeight(k+1) = iFaceHeight(k) - dh - enddo - + !$OMP parallel do default(none) shared(G, GV, CS, OBLdepth_prev, total_depth, halo) & + !$OMP private(wc, ww, we, wn, ws) + do j = G%jsc-halo, G%jec+halo + do i = G%isc-halo, G%iec+halo ; if (G%mask2dT(i,j) > 0.0) then ! compute weights ww = 0.125 * G%mask2dT(i-1,j) we = 0.125 * G%mask2dT(i+1,j) @@ -1339,29 +1588,53 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) wn = 0.125 * G%mask2dT(i,j+1) wc = 1.0 - (ww+we+wn+ws) - CS%OBLdepth(i,j) = wc * OBLdepth_prev(i,j) & - + ww * OBLdepth_prev(i-1,j) & - + we * OBLdepth_prev(i+1,j) & - + ws * OBLdepth_prev(i,j-1) & - + wn * OBLdepth_prev(i,j+1) + if (CS%answer_date < 20240501) then + CS%OBLdepth(i,j) = wc * OBLdepth_prev(i,j) & + + ww * OBLdepth_prev(i-1,j) & + + we * OBLdepth_prev(i+1,j) & + + ws * OBLdepth_prev(i,j-1) & + + wn * OBLdepth_prev(i,j+1) + else + CS%OBLdepth(i,j) = wc * OBLdepth_prev(i,j) & + + ((ww * OBLdepth_prev(i-1,j) + we * OBLdepth_prev(i+1,j)) & + + (ws * OBLdepth_prev(i,j-1) + wn * OBLdepth_prev(i,j+1))) + endif ! Apply OBLdepth smoothing at a cell only if the OBLdepth gets deeper via smoothing. if (CS%deepen_only) CS%OBLdepth(i,j) = max(CS%OBLdepth(i,j), OBLdepth_prev(i,j)) ! prevent OBL depths deeper than the bathymetric depth - CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -iFaceHeight(GV%ke+1) ) ! no deeper than bottom - CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) - enddo + CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), total_depth(i,j) ) ! no deeper than bottom + endif ; enddo enddo enddo ! s-loop + ! Determine the fractional index of the bottom of the boundary layer. + !$OMP parallel do default(none) shared(G, GV, CS, dz) & + !$OMP private(dh, hcorr, cellHeight, iFaceHeight) + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (G%mask2dT(i,j) > 0.0) then + + iFaceHeight(1) = 0.0 ! BBL is all relative to the surface + hcorr = 0. + do k=1,GV%ke + ! cell center and cell bottom in meters (negative values in the ocean) + dh = dz(i,j,k) ! Nominal thickness to use for increment + dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) + hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 + dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness + cellHeight(k) = iFaceHeight(k) - 0.5 * dh + iFaceHeight(k+1) = iFaceHeight(k) - dh + enddo + + CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) + endif ; enddo ; enddo + call cpu_clock_end(id_clock_KPP_smoothing) end subroutine KPP_smooth_BLD - !> Copies KPP surface boundary layer depth into BLD, in units of [Z ~> m] unless other units are specified. subroutine KPP_get_BLD(CS, BLD, G, US, m_to_BLD_units) type(KPP_CS), pointer :: CS !< Control structure for @@ -1370,12 +1643,12 @@ subroutine KPP_get_BLD(CS, BLD, G, US, m_to_BLD_units) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: BLD !< Boundary layer depth [Z ~> m] or other units real, optional, intent(in) :: m_to_BLD_units !< A conversion factor from meters - !! to the desired units for BLD + !! to the desired units for BLD [various] ! Local variables - real :: scale ! A dimensional rescaling factor + real :: scale ! A dimensional rescaling factor in [nondim] or other units. integer :: i,j - scale = US%m_to_Z ; if (present(m_to_BLD_units)) scale = m_to_BLD_units + scale = 1.0 ; if (present(m_to_BLD_units)) scale = US%Z_to_m*m_to_BLD_units !$OMP parallel do default(none) shared(BLD, CS, G, scale) do j = G%jsc, G%jec ; do i = G%isc, G%iec @@ -1384,131 +1657,156 @@ subroutine KPP_get_BLD(CS, BLD, G, US, m_to_BLD_units) end subroutine KPP_get_BLD -!> Apply KPP non-local transport of surface fluxes for temperature. -subroutine KPP_NonLocalTransport_temp(CS, G, GV, h, nonLocalTrans, surfFlux, & - dt, scalar, C_p) +!> Apply KPP non-local transport of surface fluxes for a given tracer +subroutine KPP_NonLocalTransport(CS, G, GV, h, nonLocalTrans, surfFlux, & + dt, diag, tr_ptr, scalar, flux_scale) + type(KPP_CS), intent(in) :: CS !< Control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer/level thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: nonLocalTrans !< Non-local transport [nondim] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: surfFlux !< Surface flux of scalar + !! [conc H T-1 ~> conc m s-1 or conc kg m-2 s-1] + real, intent(in) :: dt !< Time-step [T ~> s] + type(diag_ctrl), target, intent(in) :: diag !< Diagnostics + type(tracer_type), pointer, intent(in) :: tr_ptr !< tracer_type has diagnostic ids on it + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: scalar !< Scalar (scalar units [conc]) + real, optional, intent(in) :: flux_scale !< Scale factor to get surfFlux + !! into proper units [various] + + integer :: i, j, k + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dtracer ! Rate of tracer change [conc T-1 ~> conc s-1] + real, dimension(SZI_(G),SZJ_(G)) :: surfFlux_loc ! An optionally rescaled surface flux of the scalar + ! in [conc H T-1 ~> conc m s-1 or conc kg m-2 s-1] or other units + + ! term used to scale + if (present(flux_scale)) then + do j = G%jsc, G%jec ; do i = G%isc, G%iec + surfFlux_loc(i,j) = surfFlux(i,j) * flux_scale + enddo ; enddo + else + surfFlux_loc(:,:) = surfFlux(:,:) + endif + + ! Post surface flux diagnostic + if (tr_ptr%id_net_surfflux > 0) call post_data(tr_ptr%id_net_surfflux, surfFlux_loc(:,:), diag) + + ! Only continue if we are applying the nonlocal tendency + ! or the nonlocal tendency diagnostic has been requested + if ((tr_ptr%id_NLT_tendency > 0) .or. (CS%applyNonLocalTrans)) then + + !$OMP parallel do default(none) shared(dtracer, nonLocalTrans, h, G, GV, surfFlux_loc) + do k = 1, GV%ke ; do j = G%jsc, G%jec ; do i = G%isc, G%iec + dtracer(i,j,k) = ( nonLocalTrans(i,j,k) - nonLocalTrans(i,j,k+1) ) / & + ( h(i,j,k) + GV%H_subroundoff ) * surfFlux_loc(i,j) + enddo ; enddo ; enddo + + ! Update tracer due to non-local redistribution of surface flux + if (CS%applyNonLocalTrans) then + !$OMP parallel do default(none) shared(G, GV, dt, scalar, dtracer) + do k = 1, GV%ke ; do j = G%jsc, G%jec ; do i = G%isc, G%iec + scalar(i,j,k) = scalar(i,j,k) + dt * dtracer(i,j,k) + enddo ; enddo ; enddo + endif + if (tr_ptr%id_NLT_tendency > 0) call post_data(tr_ptr%id_NLT_tendency, dtracer, diag) + + endif + + + if (tr_ptr%id_NLT_budget > 0) then + !$OMP parallel do default(none) shared(G, GV, dtracer, nonLocalTrans, surfFlux_loc) + do k = 1, GV%ke ; do j = G%jsc, G%jec ; do i = G%isc, G%iec + ! Here dtracer has units of [Q R Z T-1 ~> W m-2]. + dtracer(i,j,k) = (nonLocalTrans(i,j,k) - nonLocalTrans(i,j,k+1)) * surfFlux_loc(i,j) + enddo ; enddo ; enddo + call post_data(tr_ptr%id_NLT_budget, dtracer(:,:,:), diag) + endif +end subroutine KPP_NonLocalTransport + + +!> Apply KPP non-local transport of surface fluxes for temperature. +subroutine KPP_NonLocalTransport_temp(CS, G, GV, h, nonLocalTrans, surfFlux, dt, tr_ptr, scalar, C_p) type(KPP_CS), intent(in) :: CS !< Control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer/level thickness [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: nonLocalTrans !< Non-local transport [nondim] real, dimension(SZI_(G),SZJ_(G)), intent(in) :: surfFlux !< Surface flux of temperature - !! [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] + !! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] real, intent(in) :: dt !< Time-step [T ~> s] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: scalar !< temperature [degC] + type(tracer_type), pointer, intent(in) :: tr_ptr !< tracer_type has diagnostic ids on it + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: scalar !< temperature [C ~> degC] real, intent(in) :: C_p !< Seawater specific heat capacity - !! [Q degC-1 ~> J kg-1 degC-1] + !! [Q C-1 ~> J kg-1 degC-1] - integer :: i, j, k - real, dimension( SZI_(G), SZJ_(G),SZK_(GV) ) :: dtracer ! Rate of tracer change [degC T-1 ~> degC s-1] - - - dtracer(:,:,:) = 0.0 - !$OMP parallel do default(none) shared(dtracer, nonLocalTrans, h, G, GV, surfFlux) - do k = 1, GV%ke - do j = G%jsc, G%jec - do i = G%isc, G%iec - dtracer(i,j,k) = ( nonLocalTrans(i,j,k) - nonLocalTrans(i,j,k+1) ) / & - ( h(i,j,k) + GV%H_subroundoff ) * surfFlux(i,j) - enddo - enddo - enddo - - ! Update tracer due to non-local redistribution of surface flux - if (CS%applyNonLocalTrans) then - !$OMP parallel do default(none) shared(dt, scalar, dtracer, G, GV) - do k = 1, GV%ke - do j = G%jsc, G%jec - do i = G%isc, G%iec - scalar(i,j,k) = scalar(i,j,k) + dt * dtracer(i,j,k) - enddo - enddo - enddo - endif - - ! Diagnostics - if (CS%id_QminusSW > 0) call post_data(CS%id_QminusSW, surfFlux, CS%diag) - if (CS%id_NLT_dTdt > 0) call post_data(CS%id_NLT_dTdt, dtracer, CS%diag) - if (CS%id_NLT_temp_budget > 0) then - dtracer(:,:,:) = 0.0 - !$OMP parallel do default(none) shared(dtracer, nonLocalTrans, surfFlux, C_p, G, GV) - do k = 1, GV%ke - do j = G%jsc, G%jec - do i = G%isc, G%iec - ! Here dtracer has units of [Q R Z T-1 ~> W m-2]. - dtracer(i,j,k) = (nonLocalTrans(i,j,k) - nonLocalTrans(i,j,k+1)) * & - surfFlux(i,j) * C_p * GV%H_to_RZ - enddo - enddo - enddo - call post_data(CS%id_NLT_temp_budget, dtracer, CS%diag) - endif + call KPP_NonLocalTransport(CS, G, GV, h, nonLocalTrans, surfFlux, dt, CS%diag, & + tr_ptr, scalar) end subroutine KPP_NonLocalTransport_temp !> Apply KPP non-local transport of surface fluxes for salinity. -!> This routine is a useful prototype for other material tracers. -subroutine KPP_NonLocalTransport_saln(CS, G, GV, h, nonLocalTrans, surfFlux, dt, scalar) - - type(KPP_CS), intent(in) :: CS !< Control structure - type(ocean_grid_type), intent(in) :: G !< Ocean grid - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer/level thickness [H ~> m or kg m-2] +subroutine KPP_NonLocalTransport_saln(CS, G, GV, h, nonLocalTrans, surfFlux, dt, tr_ptr, scalar) + type(KPP_CS), intent(in) :: CS !< Control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer/level thickness [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: nonLocalTrans !< Non-local transport [nondim] - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: surfFlux !< Surface flux of salt - !! [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] - real, intent(in) :: dt !< Time-step [T ~> s] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: scalar !< Salinity [ppt] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: surfFlux !< Surface flux of salt + !! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + real, intent(in) :: dt !< Time-step [T ~> s] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: scalar !< Salinity [S ~> ppt] + type(tracer_type), pointer, intent(in) :: tr_ptr !< tracer_type has diagnostic ids on it - integer :: i, j, k - real, dimension( SZI_(G), SZJ_(G),SZK_(GV) ) :: dtracer ! Rate of tracer change [ppt T-1 ~> ppt s-1] + call KPP_NonLocalTransport(CS, G, GV, h, nonLocalTrans, surfFlux, dt, CS%diag, & + tr_ptr, scalar) +end subroutine KPP_NonLocalTransport_saln - dtracer(:,:,:) = 0.0 - !$OMP parallel do default(none) shared(dtracer, nonLocalTrans, h, G, GV, surfFlux) - do k = 1, GV%ke - do j = G%jsc, G%jec - do i = G%isc, G%iec - dtracer(i,j,k) = ( nonLocalTrans(i,j,k) - nonLocalTrans(i,j,k+1) ) / & - ( h(i,j,k) + GV%H_subroundoff ) * surfFlux(i,j) - enddo - enddo +!> Compute Stokes Drift components at zbot < ztop <= 0 and at k=0.5*(ztop+zbot) and +!! average components from ztop to zbot <= 0 +subroutine Compute_StokesDrift(i ,j, ztop, zbot, uS_i, vS_i, uS_k, vS_k, uSbar, vSbar, waves) + + type(wave_parameters_CS), pointer :: waves !< Wave CS for Langmuir turbulence + real, intent(in) :: ztop !< cell top + real, intent(in) :: zbot !< cell bottom + real, intent(inout) :: uS_i !< Stokes u velocity at zbot interface + real, intent(inout) :: vS_i !< Stokes v velocity at zbot interface + real, intent(inout) :: uS_k !< Stokes u velocity at zk center + real, intent(inout) :: vS_k !< Stokes v at zk =0.5(ztop+zbot) + real, intent(inout) :: uSbar !< mean Stokes u (ztop to zbot) + real, intent(inout) :: vSbar !< mean Stokes v (ztop to zbot) + integer, intent(in) :: i !< Meridional index of H-point + integer, intent(in) :: j !< Zonal index of H-point + + ! local variables + integer :: b !< wavenumber band index + real :: fexp !< an exponential function + real :: WaveNum !< Wavenumber + + uS_i = 0.0 + vS_i = 0.0 + uS_k = 0.0 + vS_k = 0.0 + uSbar = 0.0 + vSbar = 0.0 + do b = 1, waves%NumBands + WaveNum = waves%WaveNum_Cen(b) + fexp = exp(2. * WaveNum * zbot) + uS_i = uS_i + waves%Ustk_Hb(i,j,b) * fexp + vS_i = vS_i + waves%Vstk_Hb(i,j,b) * fexp + fexp = exp( WaveNum * (ztop + zbot) ) + uS_k = uS_k+ waves%Ustk_Hb(i,j,b) * fexp + vS_k = vS_k+ waves%Vstk_Hb(i,j,b) * fexp + fexp = exp(2. * WaveNum * ztop) - exp(2. * WaveNum * zbot) + uSbar = uSbar + 0.5 * waves%Ustk_Hb(i,j,b) * fexp / WaveNum + vSbar = vSbar + 0.5 * waves%Vstk_Hb(i,j,b) * fexp / WaveNum enddo + uSbar = uSbar / (ztop-zbot) + vSbar = vSbar / (ztop-zbot) - ! Update tracer due to non-local redistribution of surface flux - if (CS%applyNonLocalTrans) then - !$OMP parallel do default(none) shared(G, GV, dt, scalar, dtracer) - do k = 1, GV%ke - do j = G%jsc, G%jec - do i = G%isc, G%iec - scalar(i,j,k) = scalar(i,j,k) + dt * dtracer(i,j,k) - enddo - enddo - enddo - endif - - ! Diagnostics - if (CS%id_netS > 0) call post_data(CS%id_netS, surfFlux, CS%diag) - if (CS%id_NLT_dSdt > 0) call post_data(CS%id_NLT_dSdt, dtracer, CS%diag) - if (CS%id_NLT_saln_budget > 0) then - dtracer(:,:,:) = 0.0 - !$OMP parallel do default(none) shared(G, GV, dtracer, nonLocalTrans, surfFlux) - do k = 1, GV%ke - do j = G%jsc, G%jec - do i = G%isc, G%iec - ! Here dtracer has units of [ppt R Z T-1 ~> ppt kg m-2 s-1] - dtracer(i,j,k) = (nonLocalTrans(i,j,k) - nonLocalTrans(i,j,k+1)) * & - surfFlux(i,j) * GV%H_to_RZ - enddo - enddo - enddo - call post_data(CS%id_NLT_saln_budget, dtracer, CS%diag) - endif - -end subroutine KPP_NonLocalTransport_saln - +end subroutine Compute_StokesDrift !> Clear pointers, deallocate memory subroutine KPP_end(CS) diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index 6b44fce15e..4a3cb49824 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Interface to CVMix convection scheme. module MOM_CVMix_conv -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_debugging, only : hchksum use MOM_diag_mediator, only : diag_ctrl, time_type, register_diag_field use MOM_diag_mediator, only : post_data @@ -11,6 +13,7 @@ module MOM_CVMix_conv use MOM_file_parser, only : openParameterBlock, closeParameterBlock use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -27,14 +30,14 @@ module MOM_CVMix_conv type, public :: CVMix_conv_cs ; private ! Parameters - real :: kd_conv_const !< diffusivity constant used in convective regime [m2 s-1] - real :: kv_conv_const !< viscosity constant used in convective regime [m2 s-1] + real :: kd_conv_const !< diffusivity constant used in convective regime [Z2 T-1 ~> m2 s-1] + real :: kv_conv_const !< viscosity constant used in convective regime [Z2 T-1 ~> m2 s-1] real :: bv_sqr_conv !< Threshold for squared buoyancy frequency - !! needed to trigger Brunt-Vaisala parameterization [s-2] - real :: min_thickness !< Minimum thickness allowed [m] + !! needed to trigger Brunt-Vaisala parameterization [T-2 ~> s-2] + real :: min_thickness !< Minimum thickness allowed [Z ~> m] logical :: debug !< If true, turn on debugging - ! Daignostic handles and pointers + ! Diagnostic handles and pointers type(diag_ctrl), pointer :: diag => NULL() !< Pointer to diagnostics control structure !>@{ Diagnostics handles integer :: id_N2 = -1, id_kd_conv = -1, id_kv_conv = -1 @@ -55,13 +58,13 @@ logical function CVMix_conv_init(Time, G, GV, US, param_file, diag, CS) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Run-time parameter file handle type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure. - type(CVMix_conv_cs), intent(inout) :: CS !< CVMix convetction control struct + type(CVMix_conv_cs), intent(inout) :: CS !< CVMix convection control structure - real :: prandtl_conv !< Turbulent Prandtl number used in convective instabilities. + real :: prandtl_conv !< Turbulent Prandtl number used in convective instabilities [nondim] logical :: useEPBL !< If True, use the ePBL boundary layer scheme. -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" ! Read parameters call get_param(param_file, mdl, "USE_CVMix_CONVECTION", CVMix_conv_init, default=.false., do_not_log=.true.) @@ -84,13 +87,14 @@ logical function CVMix_conv_init(Time, G, GV, US, param_file, diag, CS) ! be aplied in the boundary layer if (useEPBL) then call MOM_error(WARNING, 'MOM_CVMix_conv_init: '// & - 'CVMix convection may not be properly applied when ENERGETICS_SFC_PBL = True'//& + 'CVMix convection may not be properly applied when ENERGETICS_SFC_PBL = True '//& 'as convective mixing might occur in the boundary layer.') endif call get_param(param_file, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) - call get_param(param_file, mdl, 'MIN_THICKNESS', CS%min_thickness, default=0.001, do_not_log=.True.) + call get_param(param_file, mdl, 'MIN_THICKNESS', CS%min_thickness, & + units="m", scale=US%m_to_Z, default=0.001, do_not_log=.True.) call openParameterBlock(param_file,'CVMix_CONVECTION') @@ -101,13 +105,13 @@ logical function CVMix_conv_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, 'KD_CONV', CS%kd_conv_const, & "Diffusivity used in convective regime. Corresponding viscosity "//& - "(KV_CONV) will be set to KD_CONV * PRANDTL_TURB.", & - units='m2/s', default=1.00) + "(KV_CONV) will be set to KD_CONV * PRANDTL_CONV.", & + units='m2/s', default=1.00, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, 'BV_SQR_CONV', CS%bv_sqr_conv, & "Threshold for squared buoyancy frequency needed to trigger "//& "Brunt-Vaisala parameterization.", & - units='1/s^2', default=0.0) + units='1/s^2', default=0.0, scale=US%T_to_s**2) call closeParameterBlock(param_file) @@ -123,10 +127,10 @@ logical function CVMix_conv_init(Time, G, GV, US, param_file, diag, CS) CS%id_kv_conv = register_diag_field('ocean_model', 'kv_conv', diag%axesTi, Time, & 'Additional viscosity added by MOM_CVMix_conv module', 'm2/s', conversion=US%Z2_T_to_m2_s) - call CVMix_init_conv(convect_diff=CS%kd_conv_const, & - convect_visc=CS%kv_conv_const, & + call CVMix_init_conv(convect_diff=US%Z2_T_to_m2_s*CS%kd_conv_const, & + convect_visc=US%Z2_T_to_m2_s*CS%kv_conv_const, & lBruntVaisala=.true., & - BVsqr_convect=CS%bv_sqr_conv) + BVsqr_convect=US%s_to_T**2*CS%bv_sqr_conv) end function CVMix_conv_init @@ -139,45 +143,50 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) 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 !< Thermodynamics structure. - type(CVMix_conv_cs), intent(in) :: CS !< CVMix convection control struct + type(CVMix_conv_cs), intent(in) :: CS !< CVMix convection control structure real, dimension(SZI_(G),SZJ_(G)), intent(in) :: hbl !< Depth of ocean boundary layer [Z ~> m] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & - intent(inout) :: Kd !< Diapycnal diffusivity at each interface that - !! will be incremented here [Z2 T-1 ~> m2 s-1]. + intent(inout) :: Kd !< Diapycnal diffusivity at each interface + !! that will be incremented here + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & - intent(inout) :: KV !< Viscosity at each interface that will be - !! incremented here [Z2 T-1 ~> m2 s-1]. + intent(inout) :: Kv !< Viscosity at each interface that will be + !! incremented here [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & optional, intent(inout) :: Kd_aux !< A second diapycnal diffusivity at each !! interface that will also be incremented - !! here [Z2 T-1 ~> m2 s-1]. + !! here [H Z T-1 ~> m2 s-1 or kg m-1 s-1] ! local variables - real, dimension(SZK_(GV)) :: rho_lwr !< Adiabatic Water Density, this is a dummy + real, dimension(SZK_(GV)) :: rho_lwr !< Adiabatic Water Density [kg m-3], this is a dummy !! variable since here convection is always !! computed based on Brunt Vaisala. - real, dimension(SZK_(GV)) :: rho_1d !< water density in a column, this is also + real, dimension(SZK_(GV)) :: rho_1d !< water density in a column [kg m-3], this is also !! a dummy variable, same reason as above. real, dimension(SZK_(GV)+1) :: N2 !< Squared buoyancy frequency [s-2] real, dimension(SZK_(GV)+1) :: kv_col !< Viscosities at interfaces in the column [m2 s-1] real, dimension(SZK_(GV)+1) :: kd_col !< Diffusivities at interfaces in the column [m2 s-1] - real, dimension(SZK_(GV)+1) :: iFaceHeight !< Height of interfaces [m] - real, dimension(SZK_(GV)) :: cellHeight !< Height of cell centers [m] + real, dimension(SZK_(GV)+1) :: iFaceHeight !< Height of interfaces [Z ~> m] + real, dimension(SZK_(GV)) :: cellHeight !< Height of cell centers [Z ~> m] + real, dimension(SZI_(G),SZK_(GV)) :: dz ! Height change across layers [Z ~> m] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & kd_conv, & !< Diffusivity added by convection for diagnostics [Z2 T-1 ~> m2 s-1] kv_conv, & !< Viscosity added by convection for diagnostics [Z2 T-1 ~> m2 s-1] N2_3d !< Squared buoyancy frequency for diagnostics [T-2 ~> s-2] - integer :: kOBL !< level of OBL extent - real :: g_o_rho0 ! Gravitational acceleration divided by density times unit convserion factors - ! [Z s-2 R-1 ~> m4 s-2 kg-1] + integer :: kOBL !< level of ocean boundary layer extent + real :: g_o_rho0 ! Gravitational acceleration, perhaps divided by density, times unit conversion factors + ! [H s-2 R-1 ~> m4 s-2 kg-1 or m s-2] real :: pref ! Interface pressures [R L2 T-2 ~> Pa] real :: rhok, rhokm1 ! In situ densities of the layers above and below at the interface pressure [R ~> kg m-3] - real :: hbl_KPP ! The depth of the ocean boundary as used by KPP [m] - real :: dz ! A thickness [Z ~> m] - real :: dh, hcorr ! Two thicknesses [m] + real :: dh_int ! The distance between layer centers [H ~> m or kg m-2] + real :: dh, hcorr ! Limited thicknesses and a cumulative correction [Z ~> m] integer :: i, j, k - g_o_rho0 = US%L_to_Z**2*US%s_to_T**2 * GV%g_Earth / GV%Rho0 + if (GV%Boussinesq) then + g_o_rho0 = (US%s_to_T**2*GV%Z_to_H) * GV%g_Earth_Z_T2 / GV%Rho0 + else + g_o_rho0 = (US%s_to_T**2*GV%RZ_to_H) * GV%g_Earth_Z_T2 + endif ! initialize dummy variables rho_lwr(:) = 0.0 ; rho_1d(:) = 0.0 @@ -190,6 +199,10 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) if (CS%id_kd_conv > 0) Kd_conv(:,:,:) = 0.0 do j = G%jsc, G%jec + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + do i = G%isc, G%iec ! skip calling at land points @@ -204,8 +217,8 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) call calculate_density(tv%t(i,j,k), tv%s(i,j,k), pRef, rhok, tv%eqn_of_state) call calculate_density(tv%t(i,j,k-1), tv%s(i,j,k-1), pRef, rhokm1, tv%eqn_of_state) - dz = ((0.5*(h(i,j,k-1) + h(i,j,k))+GV%H_subroundoff)*GV%H_to_Z) - N2(K) = g_o_rho0 * (rhok - rhokm1) / dz ! Can be negative + dh_int = 0.5*(h(i,j,k-1) + h(i,j,k)) + GV%H_subroundoff + N2(K) = g_o_rho0 * (rhok - rhokm1) / dh_int ! Can be negative enddo @@ -213,17 +226,16 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) hcorr = 0.0 ! compute heights at cell center and interfaces do k=1,GV%ke - dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment, in the units used by CVMix. + dh = dz(i,k) ! Nominal thickness to use for increment, in the units of heights dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 - dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness + dh = max(dh, CS%min_thickness) ! Limited increment dh>=min_thickness cellHeight(k) = iFaceHeight(k) - 0.5 * dh iFaceHeight(k+1) = iFaceHeight(k) - dh enddo ! gets index of the level and interface above hbl - hbl_KPP = US%Z_to_m*hbl(i,j) ! Convert to the units used by CVMix. - kOBL = CVMix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight, hbl_KPP) + kOBL = CVMix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight, hbl(i,j)) kv_col(:) = 0.0 ; kd_col(:) = 0.0 call CVMix_coeffs_conv(Mdiff_out=kv_col(:), & @@ -237,18 +249,18 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) ! Increment the diffusivity outside of the boundary layer. do K=max(1,kOBL+1),GV%ke+1 - Kd(i,j,K) = Kd(i,j,K) + US%m2_s_to_Z2_T * kd_col(K) + Kd(i,j,K) = Kd(i,j,K) + GV%m2_s_to_HZ_T * kd_col(K) enddo if (present(Kd_aux)) then ! Increment the other diffusivity outside of the boundary layer. do K=max(1,kOBL+1),GV%ke+1 - Kd_aux(i,j,K) = Kd_aux(i,j,K) + US%m2_s_to_Z2_T * kd_col(K) + Kd_aux(i,j,K) = Kd_aux(i,j,K) + GV%m2_s_to_HZ_T * kd_col(K) enddo endif ! Increment the viscosity outside of the boundary layer. do K=max(1,kOBL+1),GV%ke+1 - Kv(i,j,K) = Kv(i,j,K) + US%m2_s_to_Z2_T * kv_col(K) + Kv(i,j,K) = Kv(i,j,K) + GV%m2_s_to_HZ_T * kv_col(K) enddo ! Store 3-d arrays for diagnostics. @@ -271,13 +283,13 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) enddo if (CS%debug) then - ! if (CS%id_N2 > 0) call hchksum(N2_3d, "MOM_CVMix_conv: N2",G%HI,haloshift=0) + ! if (CS%id_N2 > 0) call hchksum(N2_3d, "MOM_CVMix_conv: N2", G%HI, haloshift=0, unscale=US%s_to_T**2) ! if (CS%id_kd_conv > 0) & - ! call hchksum(Kd_conv, "MOM_CVMix_conv: Kd_conv", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + ! call hchksum(Kd_conv, "MOM_CVMix_conv: Kd_conv", G%HI, haloshift=0, unscale=US%Z2_T_to_m2_s) ! if (CS%id_kv_conv > 0) & - ! call hchksum(Kv_conv, "MOM_CVMix_conv: Kv_conv", G%HI, haloshift=0, scale=US%m2_s_to_Z2_T) - call hchksum(Kd, "MOM_CVMix_conv: Kd", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kv, "MOM_CVMix_conv: Kv", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + ! call hchksum(Kv_conv, "MOM_CVMix_conv: Kv_conv", G%HI, haloshift=0, unscale=US%Z2_T_to_m2_s) + call hchksum(Kd, "MOM_CVMix_conv: Kd", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Kv, "MOM_CVMix_conv: Kv", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif ! send diagnostics to post_data @@ -293,7 +305,7 @@ end subroutine calculate_CVMix_conv logical function CVMix_conv_is_used(param_file) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters call get_param(param_file, mdl, "USE_CVMix_CONVECTION", CVMix_conv_is_used, & - default=.false., do_not_log = .true.) + default=.false., do_not_log=.true.) end function CVMix_conv_is_used diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 index f1ac4c926a..0c3ecaee3f 100644 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Interface to CVMix double diffusion scheme. module MOM_CVMix_ddiff -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_diag_mediator, only : diag_ctrl, time_type, register_diag_field use MOM_diag_mediator, only : post_data use MOM_EOS, only : calculate_density_derivs @@ -28,14 +30,14 @@ module MOM_CVMix_ddiff ! Parameters real :: strat_param_max !< maximum value for the stratification parameter [nondim] real :: kappa_ddiff_s !< leading coefficient in formula for salt-fingering regime - !! for salinity diffusion [m2 s-1] + !! for salinity diffusion [Z2 T-1 ~> m2 s-1] real :: ddiff_exp1 !< interior exponent in salt-fingering regime formula [nondim] real :: ddiff_exp2 !< exterior exponent in salt-fingering regime formula [nondim] - real :: mol_diff !< molecular diffusivity [m2 s-1] + real :: mol_diff !< molecular diffusivity [Z2 T-1 ~> m2 s-1] real :: kappa_ddiff_param1 !< exterior coefficient in diffusive convection regime [nondim] real :: kappa_ddiff_param2 !< middle coefficient in diffusive convection regime [nondim] real :: kappa_ddiff_param3 !< interior coefficient in diffusive convection regime [nondim] - real :: min_thickness !< Minimum thickness allowed [m] + real :: min_thickness !< Minimum thickness allowed [H ~> m or kg m-2] character(len=4) :: diff_conv_type !< type of diffusive convection to use. Options are Marmorino & !! Caldwell 1976 ("MC76"; default) and Kelley 1988, 1990 ("K90") logical :: debug !< If true, turn on debugging @@ -57,8 +59,8 @@ logical function CVMix_ddiff_init(Time, G, GV, US, param_file, diag, CS) type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure. type(CVMix_ddiff_cs), pointer :: CS !< This module's control structure. -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" if (associated(CS)) then call MOM_error(WARNING, "CVMix_ddiff_init called with an associated "// & @@ -82,7 +84,8 @@ logical function CVMix_ddiff_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) - call get_param(param_file, mdl, 'MIN_THICKNESS', CS%min_thickness, default=0.001, do_not_log=.True.) + call get_param(param_file, mdl, 'MIN_THICKNESS', CS%min_thickness, & + units="m", scale=GV%m_to_H, default=0.001, do_not_log=.True.) call openParameterBlock(param_file,'CVMIX_DDIFF') @@ -91,8 +94,8 @@ logical function CVMix_ddiff_init(Time, G, GV, US, param_file, diag, CS) units="nondim", default=2.55) call get_param(param_file, mdl, "KAPPA_DDIFF_S", CS%kappa_ddiff_s, & - "Leading coefficient in formula for salt-fingering regime "//& - "for salinity diffusion.", units="m2 s-1", default=1.0e-4) + "Leading coefficient in formula for salt-fingering regime for salinity diffusion.", & + units="m2 s-1", default=1.0e-4, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "DDIFF_EXP1", CS%ddiff_exp1, & "Interior exponent in salt-fingering regime formula.", & @@ -116,7 +119,7 @@ logical function CVMix_ddiff_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "MOL_DIFF", CS%mol_diff, & "Molecular diffusivity used in CVMix double diffusion.", & - units="m2 s-1", default=1.5e-6) + units="m2 s-1", default=1.5e-6, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "DIFF_CONV_TYPE", CS%diff_conv_type, & "type of diffusive convection to use. Options are Marmorino \n" //& @@ -126,10 +129,10 @@ logical function CVMix_ddiff_init(Time, G, GV, US, param_file, diag, CS) call closeParameterBlock(param_file) call cvmix_init_ddiff(strat_param_max=CS%strat_param_max, & - kappa_ddiff_s=CS%kappa_ddiff_s, & + kappa_ddiff_s=US%Z2_T_to_m2_s*CS%kappa_ddiff_s, & ddiff_exp1=CS%ddiff_exp1, & ddiff_exp2=CS%ddiff_exp2, & - mol_diff=CS%mol_diff, & + mol_diff=US%Z2_T_to_m2_s*CS%mol_diff, & kappa_ddiff_param1=CS%kappa_ddiff_param1, & kappa_ddiff_param2=CS%kappa_ddiff_param2, & kappa_ddiff_param3=CS%kappa_ddiff_param3, & @@ -149,9 +152,11 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) integer, intent(in) :: j !< Meridional grid index to work on. ! Kd_T and Kd_S are intent inout because only one j-row is set here, but they are essentially outputs. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kd_T !< Interface double diffusion diapycnal - !! diffusivity for temp [Z2 T-1 ~> m2 s-1]. + !! diffusivity for temperature + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kd_S !< Interface double diffusion diapycnal - !! diffusivity for salt [Z2 T-1 ~> m2 s-1]. + !! diffusivity for salinity + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] type(CVMix_ddiff_cs), pointer :: CS !< The control structure returned !! by a previous call to CVMix_ddiff_init. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & @@ -159,36 +164,35 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) ! Local variables real, dimension(SZK_(GV)) :: & - cellHeight, & !< Height of cell centers [m] - dRho_dT, & !< partial derivatives of density wrt temp [R degC-1 ~> kg m-3 degC-1] - dRho_dS, & !< partial derivatives of density wrt saln [R ppt-1 ~> kg m-3 ppt-1] + cellHeight, & !< Height of cell centers relative to the sea surface [H ~> m or kg m-2] + dRho_dT, & !< partial derivatives of density with temperature [R C-1 ~> kg m-3 degC-1] + dRho_dS, & !< partial derivatives of density with salinity [R S-1 ~> kg m-3 ppt-1] pres_int, & !< pressure at each interface [R L2 T-2 ~> Pa] - temp_int, & !< temp and at interfaces [degC] - salt_int, & !< salt at at interfaces [ppt] + temp_int, & !< temp and at interfaces [C ~> degC] + salt_int, & !< salt at at interfaces [S ~> ppt] alpha_dT, & !< alpha*dT across interfaces [kg m-3] beta_dS, & !< beta*dS across interfaces [kg m-3] - dT, & !< temp. difference between adjacent layers [degC] - dS !< salt difference between adjacent layers [ppt] + dT, & !< temperature difference between adjacent layers [C ~> degC] + dS !< salinity difference between adjacent layers [S ~> ppt] real, dimension(SZK_(GV)+1) :: & Kd1_T, & !< Diapycanal diffusivity of temperature [m2 s-1]. Kd1_S !< Diapycanal diffusivity of salinity [m2 s-1]. - real, dimension(SZK_(GV)+1) :: iFaceHeight !< Height of interfaces [m] - integer :: kOBL !< level of OBL extent - real :: dh, hcorr + real, dimension(SZK_(GV)+1) :: iFaceHeight !< Height of interfaces relative to the sea surface [H ~> m or kg m-2] + real :: dh, hcorr ! Limited thicknesses and a cumulative correction [H ~> m or kg m-2] integer :: i, k ! initialize dummy variables - pres_int(:) = 0.0; temp_int(:) = 0.0; salt_int(:) = 0.0 - alpha_dT(:) = 0.0; beta_dS(:) = 0.0; dRho_dT(:) = 0.0 - dRho_dS(:) = 0.0; dT(:) = 0.0; dS(:) = 0.0 + pres_int(:) = 0.0 ; temp_int(:) = 0.0 ; salt_int(:) = 0.0 + alpha_dT(:) = 0.0 ; beta_dS(:) = 0.0 ; dRho_dT(:) = 0.0 + dRho_dS(:) = 0.0 ; dT(:) = 0.0 ; dS(:) = 0.0 ! GMM, I am leaving some code commented below. We need to pass BLD to - ! this soubroutine to avoid adding diffusivity above that. This needs + ! this subroutine to avoid adding diffusivity above that. This needs ! to be done once we re-structure the order of the calls. !if (.not. associated(hbl)) then - ! allocate(hbl(SZI_(G), SZJ_(G))); + ! allocate(hbl(SZI_(G), SZJ_(G))) ! hbl(:,:) = 0.0 !endif @@ -199,7 +203,7 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) pres_int(1) = 0. ; if (associated(tv%p_surf)) pres_int(1) = tv%p_surf(i,j) ! we don't have SST and SSS, so let's use values at top-most layer - temp_int(1) = tv%T(i,j,1); salt_int(1) = tv%S(i,j,1) + temp_int(1) = tv%T(i,j,1) ; salt_int(1) = tv%S(i,j,1) do K=2,GV%ke ! pressure at interface pres_int(K) = pres_int(K-1) + (GV%g_Earth * GV%H_to_RZ) * h(i,j,k-1) @@ -235,7 +239,7 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) hcorr = 0.0 ! compute heights at cell center and interfaces do k=1,GV%ke - dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment + dh = h(i,j,k) ! Nominal thickness to use for increment, in height units dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness @@ -243,8 +247,8 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) iFaceHeight(k+1) = iFaceHeight(k) - dh enddo - ! gets index of the level and interface above hbl - !kOBL = CVmix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight,hbl(i,j)) + ! gets index of the level and interface above hbl in [H ~> m or kg m-2] + !kOBL = CVmix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight, hbl(i,j)) Kd1_T(:) = 0.0 ; Kd1_S(:) = 0.0 call CVMix_coeffs_ddiff(Tdiff_out=Kd1_T(:), & @@ -254,8 +258,8 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) nlev=GV%ke, & max_nlev=GV%ke) do K=1,GV%ke+1 - Kd_T(i,j,K) = US%m2_s_to_Z2_T * Kd1_T(K) - Kd_S(i,j,K) = US%m2_s_to_Z2_T * Kd1_S(K) + Kd_T(i,j,K) = GV%m2_s_to_HZ_T * Kd1_T(K) + Kd_S(i,j,K) = GV%m2_s_to_HZ_T * Kd1_S(K) enddo ! Do not apply mixing due to convection within the boundary layer @@ -274,11 +278,11 @@ end subroutine compute_ddiff_coeffs logical function CVMix_ddiff_is_used(param_file) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters call get_param(param_file, mdl, "USE_CVMIX_DDIFF", CVMix_ddiff_is_used, & - default=.false., do_not_log = .true.) + default=.false., do_not_log=.true.) end function CVMix_ddiff_is_used -!> Clear pointers and dealocate memory +!> Clear pointers and deallocate memory ! NOTE: Placeholder destructor subroutine CVMix_ddiff_end(CS) type(CVMix_ddiff_cs), pointer :: CS !< Control structure for this module that diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index eed99ceb3f..ac69b06125 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Interface to CVMix interior shear schemes module MOM_CVMix_shear -! This file is part of MOM6. See LICENSE.md for the license. - !> \author Brandon Reichl use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr @@ -10,6 +12,7 @@ module MOM_CVMix_shear use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -28,25 +31,25 @@ module MOM_CVMix_shear ! vary with the Boussinesq approximation, the Boussinesq variant is given first. !> Control structure including parameters for CVMix interior shear schemes. -type, public :: CVMix_shear_cs ! TODO: private +type, public :: CVMix_shear_cs ; private logical :: use_LMD94 !< Flags to use the LMD94 scheme logical :: use_PP81 !< Flags to use Pacanowski and Philander (JPO 1981) - logical :: smooth_ri !< If true, smooth Ri using a 1-2-1 filter - real :: Ri_zero !< LMD94 critical Richardson number - real :: Nu_zero !< LMD94 maximum interior diffusivity - real :: KPP_exp !< Exponent of unitless factor of diff. - !! for KPP internal shear mixing scheme. + integer :: n_smooth_ri !< Number of times to smooth Ri using a 1-2-1 filter + real :: Ri_zero !< LMD94 critical Richardson number [nondim] + real :: Nu_zero !< LMD94 maximum interior diffusivity [Z2 T-1 ~> m2 s-1] + real :: KPP_exp !< Exponent of unitless factor of diffusivities + !! for KPP internal shear mixing scheme [nondim] real, allocatable, dimension(:,:,:) :: N2 !< Squared Brunt-Vaisala frequency [T-2 ~> s-2] real, allocatable, dimension(:,:,:) :: S2 !< Squared shear frequency [T-2 ~> s-2] - real, allocatable, dimension(:,:,:) :: ri_grad !< Gradient Richardson number - real, allocatable, dimension(:,:,:) :: ri_grad_smooth !< Gradient Richardson number - !! after smoothing + real, allocatable, dimension(:,:,:) :: ri_grad !< Gradient Richardson number [nondim] + real, allocatable, dimension(:,:,:) :: ri_grad_orig !< Gradient Richardson number + !! after smoothing [nondim] character(10) :: Mix_Scheme !< Mixing scheme name (string) type(diag_ctrl), pointer :: diag => NULL() !< Pointer to the diagnostics control structure !>@{ Diagnostic handles integer :: id_N2 = -1, id_S2 = -1, id_ri_grad = -1, id_kv = -1, id_kd = -1 - integer :: id_ri_grad_smooth = -1 + integer :: id_ri_grad_orig = -1 !>@} end type CVMix_shear_cs @@ -66,35 +69,41 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) 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 !< Thermodynamics structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(out) :: kd !< The vertical diffusivity at each interface - !! (not layer!) [Z2 T-1 ~> m2 s-1]. + !! (not layer!) [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(out) :: kv !< The vertical viscosity at each interface - !! (not layer!) [Z2 T-1 ~> m2 s-1]. + !! (not layer!) [H Z T-1 ~> m2 s-1 or Pa s] type(CVMix_shear_cs), pointer :: CS !< The control structure returned by a previous !! call to CVMix_shear_init. ! Local variables - integer :: i, j, k, kk, km1 + integer :: i, j, k, kk, km1, s real :: GoRho ! Gravitational acceleration divided by density [Z T-2 R-1 ~> m4 s-2 kg-1] real :: pref ! Interface pressures [R L2 T-2 ~> Pa] real :: DU, DV ! Velocity differences [L T-1 ~> m s-1] - real :: DZ ! Grid spacing around an interface [Z ~> m] + real :: dz_int ! Grid spacing around an interface [Z ~> m] real :: N2 ! Buoyancy frequency at an interface [T-2 ~> s-2] real :: S2 ! Shear squared at an interface [T-2 ~> s-2] real :: dummy ! A dummy variable [nondim] real :: dRho ! Buoyancy differences [Z T-2 ~> m s-2] + real, dimension(SZI_(G),SZK_(GV)) :: dz ! Height change across layers [Z ~> m] real, dimension(2*(GV%ke)) :: pres_1d ! A column of interface pressures [R L2 T-2 ~> Pa] - real, dimension(2*(GV%ke)) :: temp_1d ! A column of temperatures [degC] - real, dimension(2*(GV%ke)) :: salt_1d ! A column of salinities [ppt] + real, dimension(2*(GV%ke)) :: temp_1d ! A column of temperatures [C ~> degC] + real, dimension(2*(GV%ke)) :: salt_1d ! A column of salinities [S ~> ppt] real, dimension(2*(GV%ke)) :: rho_1d ! A column of densities at interface pressures [R ~> kg m-3] - real, dimension(GV%ke+1) :: Ri_Grad !< Gradient Richardson number [nondim] + real, dimension(GV%ke+1) :: Ri_Grad !< Gradient Richardson number [nondim] + real, dimension(GV%ke+1) :: Ri_Grad_prev !< Gradient Richardson number before s.th smoothing iteration [nondim] real, dimension(GV%ke+1) :: Kvisc !< Vertical viscosity at interfaces [m2 s-1] real, dimension(GV%ke+1) :: Kdiff !< Diapycnal diffusivity at interfaces [m2 s-1] real :: epsln !< Threshold to identify vanished layers [H ~> m or kg m-2] ! some constants - GoRho = US%L_to_Z**2 * GV%g_Earth / GV%Rho0 + GoRho = GV%g_Earth_Z_T2 / GV%Rho0 epsln = 1.e-10 * GV%m_to_H do j = G%jsc, G%jec + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + do i = G%isc, G%iec ! skip calling for land points @@ -131,13 +140,17 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) kk = 2*(k-1) DU = u_h(i,j,k) - u_h(i,j,km1) DV = v_h(i,j,k) - v_h(i,j,km1) - DRHO = GoRho * (rho_1D(kk+1) - rho_1D(kk+2)) - DZ = (0.5*(h(i,j,km1) + h(i,j,k))+GV%H_subroundoff)*GV%H_to_Z - N2 = DRHO / DZ - S2 = US%L_to_Z**2*(DU*DU+DV*DV)/(DZ*DZ) + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + dRho = GoRho * (rho_1D(kk+1) - rho_1D(kk+2)) + else + dRho = GV%g_Earth_Z_T2 * (rho_1D(kk+1) - rho_1D(kk+2)) / (0.5*(rho_1D(kk+1) + rho_1D(kk+2))) + endif + dz_int = 0.5*(dz(i,km1) + dz(i,k)) + GV%dZ_subroundoff + N2 = DRHO / dz_int + S2 = US%L_to_Z**2*((DU*DU) + (DV*DV)) / (dz_int*dz_int) Ri_Grad(k) = max(0., N2) / max(S2, 1.e-10*US%T_to_s**2) - ! fill 3d arrays, if user asks for diagsnostics + ! fill 3d arrays, if user asks for diagnostics if (CS%id_N2 > 0) CS%N2(i,j,k) = N2 if (CS%id_S2 > 0) CS%S2(i,j,k) = S2 @@ -145,9 +158,10 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) Ri_grad(GV%ke+1) = Ri_grad(GV%ke) - if (CS%id_ri_grad > 0) CS%ri_grad(i,j,:) = Ri_Grad(:) + if (CS%n_smooth_ri > 0) then + + if (CS%id_ri_grad_orig > 0) CS%ri_grad_orig(i,j,:) = Ri_Grad(:) - if (CS%smooth_ri) then ! 1) fill Ri_grad in vanished layers with adjacent value do k = 2, GV%ke if (h(i,j,k) <= epsln) Ri_grad(k) = Ri_grad(k-1) @@ -155,20 +169,27 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) Ri_grad(GV%ke+1) = Ri_grad(GV%ke) - ! 2) vertically smooth Ri with 1-2-1 filter - dummy = 0.25 * Ri_grad(2) - Ri_grad(GV%ke+1) = Ri_grad(GV%ke) - do k = 3, GV%ke - Ri_Grad(k) = dummy + 0.5 * Ri_Grad(k) + 0.25 * Ri_grad(k+1) - dummy = 0.25 * Ri_grad(k) + do s=1,CS%n_smooth_ri + + Ri_Grad_prev(:) = Ri_Grad(:) + + ! 2) vertically smooth Ri with 1-2-1 filter + dummy = 0.25 * Ri_grad_prev(2) + do k = 3, GV%ke + Ri_Grad(k) = dummy + 0.5 * Ri_Grad_prev(k) + 0.25 * Ri_grad_prev(k+1) + dummy = 0.25 * Ri_grad(k) + enddo enddo - if (CS%id_ri_grad_smooth > 0) CS%ri_grad_smooth(i,j,:) = Ri_Grad(:) + Ri_grad(GV%ke+1) = Ri_grad(GV%ke) + endif + if (CS%id_ri_grad > 0) CS%ri_grad(i,j,:) = Ri_Grad(:) + do K=1,GV%ke+1 - Kvisc(K) = US%Z2_T_to_m2_s * kv(i,j,K) - Kdiff(K) = US%Z2_T_to_m2_s * kd(i,j,K) + Kvisc(K) = GV%HZ_T_to_m2_s * kv(i,j,K) + Kdiff(K) = GV%HZ_T_to_m2_s * kd(i,j,K) enddo ! Call to CVMix wrapper for computing interior mixing coefficients. @@ -178,8 +199,8 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) nlev=GV%ke, & max_nlev=GV%ke) do K=1,GV%ke+1 - kv(i,j,K) = US%m2_s_to_Z2_T * Kvisc(K) - kd(i,j,K) = US%m2_s_to_Z2_T * Kdiff(K) + kv(i,j,K) = GV%m2_s_to_HZ_T * Kvisc(K) + kd(i,j,K) = GV%m2_s_to_HZ_T * Kdiff(K) enddo enddo enddo @@ -190,7 +211,7 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) if (CS%id_N2 > 0) call post_data(CS%id_N2, CS%N2, CS%diag) if (CS%id_S2 > 0) call post_data(CS%id_S2, CS%S2, CS%diag) if (CS%id_ri_grad > 0) call post_data(CS%id_ri_grad, CS%ri_grad, CS%diag) - if (CS%id_ri_grad_smooth > 0) call post_data(CS%id_ri_grad_smooth ,CS%ri_grad_smooth, CS%diag) + if (CS%id_ri_grad_orig > 0) call post_data(CS%id_ri_grad_orig ,CS%ri_grad_orig, CS%diag) end subroutine calculate_CVMix_shear @@ -245,8 +266,8 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) ! Otherwise, warn user and kill job. if ((NumberTrue) > 1) then call MOM_error(FATAL, 'MOM_CVMix_shear_init: '// & - 'Multiple shear driven internal mixing schemes selected,'//& - ' please disable all but one scheme to proceed.') + 'Multiple shear driven internal mixing schemes selected, '//& + 'please disable all but one scheme to proceed.') endif CVMix_shear_init = use_PP81 .or. use_LMD94 @@ -264,22 +285,22 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "NU_ZERO", CS%Nu_Zero, & "Leading coefficient in KPP shear mixing.", & - units="nondim", default=5.e-3) + units="m2 s-1", default=5.e-3, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "RI_ZERO", CS%Ri_Zero, & "Critical Richardson for KPP shear mixing, "// & "NOTE this the internal mixing and this is "// & - "not for setting the boundary layer depth." & - ,units="nondim", default=0.8) + "not for setting the boundary layer depth.", & + units="nondim", default=0.8) call get_param(param_file, mdl, "KPP_EXP", CS%KPP_exp, & "Exponent of unitless factor of diffusivities, "// & - "for KPP internal shear mixing scheme." & - ,units="nondim", default=3.0) - call get_param(param_file, mdl, "SMOOTH_RI", CS%smooth_ri, & - "If true, vertically smooth the Richardson "// & - "number by applying a 1-2-1 filter once.", & - default = .false.) + "for KPP internal shear mixing scheme.", & + units="nondim", default=3.0) + call get_param(param_file, mdl, "N_SMOOTH_RI", CS%n_smooth_ri, & + "If > 0, vertically smooth the Richardson "// & + "number by applying a 1-2-1 filter N_SMOOTH_RI times.", & + default=0) call cvmix_init_shear(mix_scheme=CS%Mix_Scheme, & - KPP_nu_zero=CS%Nu_Zero, & + KPP_nu_zero=US%Z2_T_to_m2_s*CS%Nu_Zero, & KPP_Ri_zero=CS%Ri_zero, & KPP_exp=CS%KPP_exp) @@ -304,21 +325,24 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) allocate( CS%ri_grad( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=1.e8 ) endif - CS%id_ri_grad_smooth = register_diag_field('ocean_model', 'ri_grad_shear_smooth', & - diag%axesTi, Time, & - 'Smoothed gradient Richarson number used by MOM_CVMix_shear module','nondim') - if (CS%id_ri_grad_smooth > 0) then !Initialize w/ large Richardson value - allocate( CS%ri_grad_smooth( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=1.e8 ) + if (CS%n_smooth_ri > 0) then + CS%id_ri_grad_orig = register_diag_field('ocean_model', 'ri_grad_shear_orig', & + diag%axesTi, Time, & + 'Original gradient Richarson number, before smoothing was applied. This is '//& + 'part of the MOM_CVMix_shear module and only available when N_SMOOTH_RI > 0','nondim') + endif + if (CS%id_ri_grad_orig > 0 .or. CS%n_smooth_ri > 0) then !Initialize w/ large Richardson value + allocate( CS%ri_grad_orig( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=1.e8 ) endif CS%id_kd = register_diag_field('ocean_model', 'kd_shear_CVMix', diag%axesTi, Time, & - 'Vertical diffusivity added by MOM_CVMix_shear module', 'm2/s', conversion=US%Z2_T_to_m2_s) + 'Vertical diffusivity added by MOM_CVMix_shear module', 'm2/s', conversion=GV%HZ_T_to_m2_s) CS%id_kv = register_diag_field('ocean_model', 'kv_shear_CVMix', diag%axesTi, Time, & - 'Vertical viscosity added by MOM_CVMix_shear module', 'm2/s', conversion=US%Z2_T_to_m2_s) + 'Vertical viscosity added by MOM_CVMix_shear module', 'm2/s', conversion=GV%HZ_T_to_m2_s) end function CVMix_shear_init -!> Reads the parameters "LMD94" and "PP81" and returns state. +!> Reads the parameters "USE_LMD94" and "USE_PP81" and returns true if either is true. !! This function allows other modules to know whether this parameterization will !! be used without needing to duplicate the log entry. logical function CVMix_shear_is_used(param_file) @@ -326,13 +350,13 @@ logical function CVMix_shear_is_used(param_file) ! Local variables logical :: LMD94, PP81 call get_param(param_file, mdl, "USE_LMD94", LMD94, & - default=.false., do_not_log = .true.) - call get_param(param_file, mdl, "Use_PP81", PP81, & - default=.false., do_not_log = .true.) + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "USE_PP81", PP81, & + default=.false., do_not_log=.true.) CVMix_shear_is_used = (LMD94 .or. PP81) end function CVMix_shear_is_used -!> Clear pointers and dealocate memory +!> Clear pointers and deallocate memory subroutine CVMix_shear_end(CS) type(CVMix_shear_cs), intent(inout) :: CS !< Control structure for this module that !! will be deallocated in this subroutine diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index c3ee727573..5b41cef038 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -1,19 +1,21 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Interface to background mixing schemes, including the Bryan and Lewis (1979) !! which is applied via CVMix. module MOM_bkgnd_mixing -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_debugging, only : hchksum use MOM_diag_mediator, only : diag_ctrl, time_type, register_diag_field use MOM_diag_mediator, only : post_data -use MOM_EOS, only : calculate_density, calculate_density_derivs use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE -use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_file_parser, only : openParameterBlock, closeParameterBlock use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type @@ -38,35 +40,39 @@ module MOM_bkgnd_mixing ! Parameters real :: Bryan_Lewis_c1 !< The vertical diffusivity values for Bryan-Lewis profile - !! at |z|=D [m2 s-1] + !! at |z|=D [Z2 T-1 ~> m2 s-1] real :: Bryan_Lewis_c2 !< The amplitude of variation in diffusivity for the - !! Bryan-Lewis diffusivity profile [m2 s-1] + !! Bryan-Lewis diffusivity profile [Z2 T-1 ~> m2 s-1] real :: Bryan_Lewis_c3 !< The inverse length scale for transition region in the - !! Bryan-Lewis diffusivity profile [m-1] + !! Bryan-Lewis diffusivity profile [Z-1 ~> m-1] real :: Bryan_Lewis_c4 !< The depth where diffusivity is Bryan_Lewis_bl1 in the - !! Bryan-Lewis profile [m] + !! Bryan-Lewis profile [Z ~> m] real :: bckgrnd_vdc1 !< Background diffusivity (Ledwell) when - !! horiz_varying_background=.true. [Z2 T-1 ~> m2 s-1] + !! horiz_varying_background=.true. [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: bckgrnd_vdc_eq !< Equatorial diffusivity (Gregg) when - !! horiz_varying_background=.true. [Z2 T-1 ~> m2 s-1] + !! horiz_varying_background=.true. [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: bckgrnd_vdc_psim !< Max. PSI induced diffusivity (MacKinnon) when - !! horiz_varying_background=.true. [Z2 T-1 ~> m2 s-1] + !! horiz_varying_background=.true. [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: bckgrnd_vdc_Banda !< Banda Sea diffusivity (Gordon) when - !! horiz_varying_background=.true. [Z2 T-1 ~> m2 s-1] - real :: Kd_min !< minimum diapycnal diffusivity [Z2 T-1 ~> m2 s-1] - real :: Kd !< interior diapycnal diffusivity [Z2 T-1 ~> m2 s-1] + !! horiz_varying_background=.true. [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Kd_min !< minimum diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Kd !< interior diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: omega !< The Earth's rotation rate [T-1 ~> s-1]. real :: N0_2Omega !< ratio of the typical Buoyancy frequency to !! twice the Earth's rotation period, used with the - !! Henyey scaling from the mixing + !! Henyey scaling from the mixing [nondim] + real :: Henyey_max_lat !< A latitude poleward of which the Henyey profile + !! is returned to the minimum diffusivity [degrees_N] real :: prandtl_bkgnd !< Turbulent Prandtl number used to convert - !! vertical background diffusivity into viscosity + !! vertical background diffusivity into viscosity [nondim] real :: Kd_tanh_lat_scale !< A nondimensional scaling for the range of - !! diffusivities with Kd_tanh_lat_fn. Valid values + !! diffusivities with Kd_tanh_lat_fn [nondim]. Valid values !! are in the range of -2 to 2; 0.4 reproduces CM2M. - real :: Kdml !< mixed layer diapycnal diffusivity [Z2 T-1 ~> m2 s-1] - !! when bulkmixedlayer==.false. - real :: Hmix !< mixed layer thickness [Z ~> m] when bulkmixedlayer==.false. + real :: Kd_tot_ml !< The mixed layer diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + !! when no other physically based mixed layer turbulence + !! parameterization is being used. + real :: Hmix !< mixed layer thickness [H ~> m or kg m-2] when no physically based + !! ocean surface boundary layer parameterization is used. logical :: Kd_tanh_lat_fn !< If true, use the tanh dependence of Kd_sfc on !! latitude, like GFDL CM2.1/CM2M. There is no !! physical justification for this form, and it can @@ -79,24 +85,8 @@ module MOM_bkgnd_mixing !! Henyey et al, JGR (1986) latitudinal scaling for the background diapycnal diffusivity, !! which gives a marked decrease in the diffusivity near the equator. The simplification !! here is to assume that the in-situ stratification is the same as the reference stratificaiton. - logical :: Henyey_IGW_background_new !< same as Henyey_IGW_background - !! but incorporate the effect of stratification on TKE dissipation, - !! e = f/f_0 * acosh(N/f) / acosh(N_0/f_0) * e_0 - !! where e is the TKE dissipation, and N_0 and f_0 - !! are the reference buoyancy frequency and inertial frequencies respectively. - !! e_0 is the reference dissipation at (N_0,f_0). In the previous version, N=N_0. - !! Additionally, the squared inverse relationship between diapycnal diffusivities - !! and stratification is included: - !! - !! kd = e/N^2 - !! - !! where kd is the diapycnal diffusivity. This approach assumes that work done - !! against gravity is uniformly distributed throughout the column. Whereas, kd=kd_0*e, - !! as in the original version, concentrates buoyancy work in regions of strong stratification. - logical :: bulkmixedlayer !< If true, a refined bulk mixed layer scheme is used - logical :: Kd_via_Kdml_bug !< If true and KDML /= KD and a number of other higher precedence - !! options are not used, the background diffusivity is set incorrectly using a - !! bug that was introduced in March, 2018. + logical :: physical_OBL_scheme !< If true, a physically-based scheme is used to determine mixing in the + !! ocean's surface boundary layer, such as ePBL, KPP, or a refined bulk mixed layer scheme. logical :: debug !< If true, turn on debugging in this module ! Diagnostic handles and pointers type(diag_ctrl), pointer :: diag => NULL() !< A structure that regulates diagnostic output @@ -110,7 +100,7 @@ module MOM_bkgnd_mixing contains !> Initialize the background mixing routine. -subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) +subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS, physical_OBL_scheme) type(time_type), intent(in) :: Time !< The current time. type(ocean_grid_type), intent(in) :: G !< Grid structure. @@ -118,15 +108,22 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Run-time parameter file handle type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure. - type(bkgnd_mixing_cs), pointer :: CS !< This module's control structure. + type(bkgnd_mixing_cs), pointer :: CS !< This module's control structure. + logical, intent(in) :: physical_OBL_scheme !< If true, a physically based + !! parameterization (like KPP or ePBL or a bulk mixed + !! layer) is used outside of set_diffusivity to + !! specify the mixing that occurs in the ocean's + !! surface boundary layer. ! Local variables - real :: Kv ! The interior vertical viscosity [Z2 T-1 ~> m2 s-1] - read to set Prandtl + real :: Kv ! The interior vertical viscosity [H Z T-1 ~> m2 s-1 or Pa s] - read to set Prandtl ! number unless it is provided as a parameter - real :: prandtl_bkgnd_comp ! Kv/CS%Kd. Gets compared with user-specified prandtl_bkgnd. + real :: Kd_z ! The background diapycnal diffusivity in [Z2 T-1 ~> m2 s-1] for use + ! in setting the default for other diffusivities. + real :: prandtl_bkgnd_comp ! Kv/CS%Kd [nondim]. Gets compared with user-specified prandtl_bkgnd. -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" if (associated(CS)) then call MOM_error(WARNING, "bkgnd_mixing_init called with an associated "// & @@ -139,41 +136,61 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) call log_version(param_file, mdl, version, & "Adding static vertical background mixing coefficients") - call get_param(param_file, mdl, "KD", CS%Kd, & + call get_param(param_file, mdl, "KD", Kd_z, & "The background diapycnal diffusivity of density in the "//& "interior. Zero or the molecular value, ~1e-7 m2 s-1, "//& "may be used.", default=0.0, units="m2 s-1", scale=US%m2_s_to_Z2_T) + CS%Kd = (GV%m2_s_to_HZ_T*US%Z2_T_to_m2_s) * Kd_z call get_param(param_file, mdl, "KV", Kv, & "The background kinematic viscosity in the interior. "//& "The molecular value, ~1e-6 m2 s-1, may be used.", & - units="m2 s-1", scale=US%m2_s_to_Z2_T, fail_if_missing=.true.) + units="m2 s-1", scale=GV%m2_s_to_HZ_T, fail_if_missing=.true.) call get_param(param_file, mdl, "KD_MIN", CS%Kd_min, & "The minimum diapycnal diffusivity.", & - units="m2 s-1", default=0.01*CS%Kd*US%Z2_T_to_m2_s, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=0.01*Kd_z*US%Z2_T_to_m2_s, scale=GV%m2_s_to_HZ_T) ! The following is needed to set one of the choices of vertical background mixing - ! BULKMIXEDLAYER is not always defined (e.g., CM2G63L), so the following line by passes - ! the need to include BULKMIXEDLAYER in MOM_input - CS%bulkmixedlayer = (GV%nkml > 0) - if (CS%bulkmixedlayer) then + CS%physical_OBL_scheme = physical_OBL_scheme + if (CS%physical_OBL_scheme) then ! Check that Kdml is not set when using bulk mixed layer - call get_param(param_file, mdl, "KDML", CS%Kdml, default=-1.) - if (CS%Kdml>0.) call MOM_error(FATAL, & - "bkgnd_mixing_init: KDML cannot be set when using bulk mixed layer.") - CS%Kdml = CS%Kd ! This is not used with a bulk mixed layer, but also cannot be a NaN. + call get_param(param_file, mdl, "KDML", CS%Kd_tot_ml, & + units="m2 s-1", default=-1., scale=GV%m2_s_to_HZ_T, do_not_log=.true.) + if (CS%Kd_tot_ml>0.) call MOM_error(FATAL, & + "bkgnd_mixing_init: KDML is a depricated parameter that should not be used.") + call get_param(param_file, mdl, "KD_ML_TOT", CS%Kd_tot_ml, & + units="m2 s-1", default=-1.0, scale=GV%m2_s_to_HZ_T, do_not_log=.true.) + if (CS%Kd_tot_ml>0.) call MOM_error(FATAL, & + "bkgnd_mixing_init: KD_ML_TOT cannot be set when using a physically based ocean "//& + "boundary layer mixing parameterization.") + CS%Kd_tot_ml = CS%Kd ! This is not used with a bulk mixed layer, but also cannot be a NaN. else - call get_param(param_file, mdl, "KDML", CS%Kdml, & + call get_param(param_file, mdl, "KD_ML_TOT", CS%Kd_tot_ml, & + "The total diapcynal diffusivity in the surface mixed layer when there is "//& + "not a physically based parameterization of mixing in the mixed layer, such "//& + "as bulk mixed layer or KPP or ePBL.", & + units="m2 s-1", default=Kd_z*US%Z2_T_to_m2_s, scale=GV%m2_s_to_HZ_T, do_not_log=.true.) + if (abs(CS%Kd_tot_ml - CS%Kd) <= 1.0e-15*abs(CS%Kd)) then + call get_param(param_file, mdl, "KDML", CS%Kd_tot_ml, & "If BULKMIXEDLAYER is false, KDML is the elevated "//& "diapycnal diffusivity in the topmost HMIX of fluid. "//& "KDML is only used if BULKMIXEDLAYER is false.", & - units="m2 s-1", default=CS%Kd*US%Z2_T_to_m2_s, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=Kd_z*US%Z2_T_to_m2_s, scale=GV%m2_s_to_HZ_T, do_not_log=.true.) + if (abs(CS%Kd_tot_ml - CS%Kd) > 1.0e-15*abs(CS%Kd)) & + call MOM_error(WARNING, "KDML is a depricated parameter. Use KD_ML_TOT instead.") + endif + call log_param(param_file, mdl, "KD_ML_TOT", CS%Kd_tot_ml, & + "The total diapcynal diffusivity in the surface mixed layer when there is "//& + "not a physically based parameterization of mixing in the mixed layer, such "//& + "as bulk mixed layer or KPP or ePBL.", & + units="m2 s-1", default=Kd_z*US%Z2_T_to_m2_s, unscale=GV%HZ_T_to_m2_s) + call get_param(param_file, mdl, "HMIX_FIXED", CS%Hmix, & "The prescribed depth over which the near-surface "//& "viscosity and diffusivity are elevated when the bulk "//& - "mixed layer is not used.", units="m", scale=US%m_to_Z, fail_if_missing=.true.) + "mixed layer is not used.", units="m", scale=GV%m_to_H, fail_if_missing=.true.) endif call get_param(param_file, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) @@ -190,19 +207,19 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "BRYAN_LEWIS_C1", CS%Bryan_Lewis_c1, & "The vertical diffusivity values for Bryan-Lewis profile at |z|=D.", & - units="m2 s-1", fail_if_missing=.true.) + units="m2 s-1", scale=US%m2_s_to_Z2_T, fail_if_missing=.true.) call get_param(param_file, mdl, "BRYAN_LEWIS_C2", CS%Bryan_Lewis_c2, & "The amplitude of variation in diffusivity for the Bryan-Lewis profile", & - units="m2 s-1", fail_if_missing=.true.) + units="m2 s-1", scale=US%m2_s_to_Z2_T, fail_if_missing=.true.) call get_param(param_file, mdl, "BRYAN_LEWIS_C3", CS%Bryan_Lewis_c3, & "The inverse length scale for transition region in the Bryan-Lewis profile", & - units="m-1", fail_if_missing=.true.) + units="m-1", scale=US%Z_to_m, fail_if_missing=.true.) call get_param(param_file, mdl, "BRYAN_LEWIS_C4", CS%Bryan_Lewis_c4, & "The depth where diffusivity is BRYAN_LEWIS_C1 in the Bryan-Lewis profile",& - units="m", fail_if_missing=.true.) + units="m", scale=US%m_to_Z, fail_if_missing=.true.) endif ! CS%Bryan_Lewis_diffusivity @@ -216,19 +233,19 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "BCKGRND_VDC1", CS%bckgrnd_vdc1, & "Background diffusivity (Ledwell) when HORIZ_VARYING_BACKGROUND=True", & - units="m2 s-1",default = 0.16e-04, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=0.16e-04, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "BCKGRND_VDC_EQ", CS%bckgrnd_vdc_eq, & "Equatorial diffusivity (Gregg) when HORIZ_VARYING_BACKGROUND=True", & - units="m2 s-1",default = 0.01e-04, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=0.01e-04, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "BCKGRND_VDC_PSIM", CS%bckgrnd_vdc_psim, & "Max. PSI induced diffusivity (MacKinnon) when HORIZ_VARYING_BACKGROUND=True", & - units="m2 s-1",default = 0.13e-4, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=0.13e-4, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "BCKGRND_VDC_BAN", CS%bckgrnd_vdc_Banda, & "Banda Sea diffusivity (Gordon) when HORIZ_VARYING_BACKGROUND=True", & - units="m2 s-1",default = 1.0e-4, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=1.0e-4, scale=GV%m2_s_to_HZ_T) endif call get_param(param_file, mdl, "PRANDTL_BKGND", CS%prandtl_bkgnd, & @@ -252,13 +269,6 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) "Harrison & Hallberg, JPO 2008.", default=.false.) if (CS%Henyey_IGW_background) call check_bkgnd_scheme(CS, "HENYEY_IGW_BACKGROUND") - - call get_param(param_file, mdl, "HENYEY_IGW_BACKGROUND_NEW", CS%Henyey_IGW_background_new, & - "If true, use a better latitude-dependent scaling for the "//& - "background diffusivity, as described in "//& - "Harrison & Hallberg, JPO 2008.", default=.false.) - if (CS%Henyey_IGW_background_new) call check_bkgnd_scheme(CS, "HENYEY_IGW_BACKGROUND_NEW") - if (CS%Kd>0.0 .and. (trim(CS%bkgnd_scheme_str)=="BRYAN_LEWIS_DIFFUSIVITY" .or.& trim(CS%bkgnd_scheme_str)=="HORIZ_VARYING_BACKGROUND" )) then call MOM_error(WARNING, "bkgnd_mixing_init: a nonzero constant background "//& @@ -271,8 +281,12 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) "the Earth's rotation period, used with the Henyey "//& "scaling from the mixing.", units="nondim", default=20.0) call get_param(param_file, mdl, "OMEGA", CS%omega, & - "The rotation rate of the earth.", units="s-1", & - default=7.2921e-5, scale=US%T_to_s) + "The rotation rate of the earth.", & + units="s-1", default=7.2921e-5, scale=US%T_to_s) + call get_param(param_file, mdl, "HENYEY_MAX_LAT", CS%Henyey_max_lat, & + "A latitude poleward of which the Henyey profile "//& + "is returned to the minimum diffusivity", & + units="degN", default=95.0) endif call get_param(param_file, mdl, "KD_TANH_LAT_FN", CS%Kd_tanh_lat_fn, & @@ -290,16 +304,6 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS) if (CS%Henyey_IGW_background .and. CS%Kd_tanh_lat_fn) call MOM_error(FATAL, & "MOM_bkgnd_mixing: KD_TANH_LAT_FN can not be used with HENYEY_IGW_BACKGROUND.") - CS%Kd_via_Kdml_bug = .false. - if ((CS%Kd /= CS%Kdml) .and. .not.(CS%Kd_tanh_lat_fn .or. CS%bulkmixedlayer .or. & - CS%Henyey_IGW_background .or. CS%Henyey_IGW_background_new .or. & - CS%horiz_varying_background .or. CS%Bryan_Lewis_diffusivity)) then - call get_param(param_file, mdl, "KD_BACKGROUND_VIA_KDML_BUG", CS%Kd_via_Kdml_bug, & - "If true and KDML /= KD and several other conditions apply, the background "//& - "diffusivity is set incorrectly using a bug that was introduced in March, 2018.", & - default=.true.) ! The default should be changed to false and this parameter obsoleted. - endif - ! call closeParameterBlock(param_file) end subroutine bkgnd_mixing_init @@ -313,12 +317,12 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. real, dimension(SZI_(G),SZK_(GV)), intent(in) :: N2_lay !< squared buoyancy frequency associated !! with layers [T-2 ~> s-2] - real, dimension(SZI_(G),SZK_(GV)), intent(out) :: Kd_lay !< The background diapycnal diffusivity - !! of each layer [Z2 T-1 ~> m2 s-1]. - real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_int !< The background diapycnal diffusivity - !! of each interface [Z2 T-1 ~> m2 s-1]. + real, dimension(SZI_(G),SZK_(GV)), intent(out) :: Kd_lay !< The background diapycnal diffusivity of each + !! layer [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_int !< The background diapycnal diffusivity of each + !! interface [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kv_bkgnd !< The background vertical viscosity at - !! each interface [Z2 T-1 ~> m2 s-1] + !! each interface [H Z T-1 ~> m2 s-1 or Pa s] integer, intent(in) :: j !< Meridional grid index type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(bkgnd_mixing_cs), pointer :: CS !< The control structure returned by @@ -328,19 +332,17 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, real, dimension(SZK_(GV)+1) :: depth_int !< Distance from surface of the interfaces [m] real, dimension(SZK_(GV)+1) :: Kd_col !< Diffusivities at the interfaces [m2 s-1] real, dimension(SZK_(GV)+1) :: Kv_col !< Viscosities at the interfaces [m2 s-1] - real, dimension(SZI_(G)) :: Kd_sfc !< Surface value of the diffusivity [Z2 T-1 ~> m2 s-1] - real, dimension(SZI_(G)) :: depth !< Distance from surface of an interface [Z ~> m] - real :: depth_c !< depth of the center of a layer [Z ~> m] - real :: I_Hmix !< inverse of fixed mixed layer thickness [Z-1 ~> m-1] - real :: I_2Omega !< 1/(2 Omega) [T ~> s] - real :: N_2Omega ! The ratio of the stratification to the Earth's rotation rate [nondim] - real :: N02_N2 ! The ratio a reference stratification to the actual stratification [nondim] - real :: I_x30 !< 2/acos(2) = 1/(sin(30 deg) * acosh(1/sin(30 deg))) - real :: deg_to_rad !< factor converting degrees to radians, pi/180. + real, dimension(SZI_(G)) :: Kd_sfc !< Surface value of the diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G)) :: depth !< Distance from surface of an interface [H ~> m or kg m-2] + real, dimension(SZI_(G),SZK_(GV)) :: dz !< Height change across layers [Z ~> m] + real :: depth_c !< depth of the center of a layer [H ~> m or kg m-2] + real :: I_Hmix !< inverse of fixed mixed layer thickness [H-1 ~> m-1 or m2 kg-1] + real :: I_x30 !< 2/acos(2) = 1/(sin(30 deg) * acosh(1/sin(30 deg))) [nondim] + real :: deg_to_rad !< factor converting degrees to radians [radians degree-1], pi/180. real :: abs_sinlat !< absolute value of sine of latitude [nondim] real :: min_sinlat ! The minimum value of the sine of latitude [nondim] - real :: bckgrnd_vdc_psin !< PSI diffusivity in northern hemisphere [Z2 T-1 ~> m2 s-1] - real :: bckgrnd_vdc_psis !< PSI diffusivity in southern hemisphere [Z2 T-1 ~> m2 s-1] + real :: bckgrnd_vdc_psin !< PSI diffusivity in northern hemisphere [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: bckgrnd_vdc_psis !< PSI diffusivity in southern hemisphere [H Z T-1 ~> m2 s-1 or kg m-1 s-1] integer :: i, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -356,18 +358,20 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, ! Set up the background diffusivity. if (CS%Bryan_Lewis_diffusivity) then + call thickness_to_dz(h, tv, dz, j, G, GV) + do i=is,ie depth_int(1) = 0.0 do k=2,nz+1 - depth_int(k) = depth_int(k-1) + GV%H_to_m*h(i,j,k-1) + depth_int(k) = depth_int(k-1) + US%Z_to_m*dz(i,k-1) enddo call CVMix_init_bkgnd(max_nlev=nz, & zw = depth_int(:), & !< interface depths relative to the surface in m, must be positive. - bl1 = CS%Bryan_Lewis_c1, & - bl2 = CS%Bryan_Lewis_c2, & - bl3 = CS%Bryan_Lewis_c3, & - bl4 = CS%Bryan_Lewis_c4, & + bl1 = US%Z2_T_to_m2_s*CS%Bryan_Lewis_c1, & + bl2 = US%Z2_T_to_m2_s*CS%Bryan_Lewis_c2, & + bl3 = US%m_to_Z*CS%Bryan_Lewis_c3, & + bl4 = US%Z_to_m*CS%Bryan_Lewis_c4, & prandtl = CS%prandtl_bkgnd) Kd_col(:) = 0.0 ; Kv_col(:) = 0.0 ! Is this line necessary? @@ -375,11 +379,11 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, ! Update Kd and Kv. do K=1,nz+1 - Kv_bkgnd(i,K) = US%m2_s_to_Z2_T*Kv_col(K) - Kd_int(i,K) = US%m2_s_to_Z2_T*Kd_col(K) + Kv_bkgnd(i,K) = GV%m2_s_to_HZ_T * Kv_col(K) + Kd_int(i,K) = GV%m2_s_to_HZ_T*Kd_col(K) enddo do k=1,nz - Kd_lay(i,k) = Kd_lay(i,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_col(K) + Kd_col(K+1)) + Kd_lay(i,k) = Kd_lay(i,k) + 0.5 * GV%m2_s_to_HZ_T * (Kd_col(K) + Kd_col(K+1)) enddo enddo ! i loop @@ -429,31 +433,13 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, Kd_lay(i,k) = Kd_int(i,1) enddo ; enddo - elseif (CS%Henyey_IGW_background_new) then - I_x30 = 2.0 / invcosh(CS%N0_2Omega*2.0) ! This is evaluated at 30 deg. - I_2Omega = 0.5 / CS%omega - do k=1,nz ; do i=is,ie - abs_sinlat = max(min_sinlat, abs(sin(G%geoLatT(i,j)*deg_to_rad))) - N_2Omega = max(abs_sinlat, sqrt(N2_lay(i,k))*I_2Omega) - N02_N2 = (CS%N0_2Omega/N_2Omega)**2 - Kd_lay(i,k) = max(CS%Kd_min, CS%Kd * & - ((abs_sinlat * invcosh(N_2Omega/abs_sinlat)) * I_x30)*N02_N2) - enddo ; enddo - ! Update Kd_int and Kv_bkgnd, based on Kd_lay. These might be just used for diagnostic purposes. - do i=is,ie - Kd_int(i,1) = 0.0; Kv_bkgnd(i,1) = 0.0 - Kd_int(i,nz+1) = 0.0; Kv_bkgnd(i,nz+1) = 0.0 - enddo - do K=2,nz ; do i=is,ie - Kd_int(i,K) = 0.5*(Kd_lay(i,k-1) + Kd_lay(i,k)) - Kv_bkgnd(i,K) = Kd_int(i,K) * CS%prandtl_bkgnd - enddo ; enddo else ! Set a potentially spatially varying surface value of diffusivity. if (CS%Henyey_IGW_background) then I_x30 = 2.0 / invcosh(CS%N0_2Omega*2.0) ! This is evaluated at 30 deg. do i=is,ie abs_sinlat = abs(sin(G%geoLatT(i,j)*deg_to_rad)) + if (abs(G%geoLatT(i,j))>CS%Henyey_max_lat) abs_sinlat = min_sinlat Kd_sfc(i) = max(CS%Kd_min, CS%Kd * & ((abs_sinlat * invcosh(CS%N0_2Omega / max(min_sinlat, abs_sinlat))) * I_x30) ) enddo @@ -471,31 +457,21 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, enddo endif - ! Now set background diffusivies based on these surface values, possibly with vertical structure. - if ((.not.CS%bulkmixedlayer) .and. (CS%Kd /= CS%Kdml)) then + ! Now set background diffusivities based on these surface values, possibly with vertical structure. + if ((.not.CS%physical_OBL_scheme) .and. (CS%Kd /= CS%Kd_tot_ml)) then ! This is a crude way to put in a diffusive boundary layer without an explicit boundary ! layer turbulence scheme. It should not be used for any realistic ocean models. - I_Hmix = 1.0 / (CS%Hmix + GV%H_subroundoff*GV%H_to_Z) + I_Hmix = 1.0 / (CS%Hmix + GV%H_subroundoff) do i=is,ie ; depth(i) = 0.0 ; enddo do k=1,nz ; do i=is,ie - depth_c = depth(i) + 0.5*GV%H_to_Z*h(i,j,k) - if (CS%Kd_via_Kdml_bug) then - ! These two lines should update Kd_lay, not Kd_int. They were correctly working on the - ! same variables until MOM6 commit 7a818716 (PR#750), which was added on March 26, 2018. - if (depth_c <= CS%Hmix) then ; Kd_int(i,K) = CS%Kdml - elseif (depth_c >= 2.0*CS%Hmix) then ; Kd_int(i,K) = Kd_sfc(i) - else - Kd_lay(i,k) = ((Kd_sfc(i) - CS%Kdml) * I_Hmix) * depth_c + (2.0*CS%Kdml - Kd_sfc(i)) - endif + depth_c = depth(i) + 0.5*h(i,j,k) + if (depth_c <= CS%Hmix) then ; Kd_lay(i,k) = CS%Kd_tot_ml + elseif (depth_c >= 2.0*CS%Hmix) then ; Kd_lay(i,k) = Kd_sfc(i) else - if (depth_c <= CS%Hmix) then ; Kd_lay(i,k) = CS%Kdml - elseif (depth_c >= 2.0*CS%Hmix) then ; Kd_lay(i,k) = Kd_sfc(i) - else - Kd_lay(i,k) = ((Kd_sfc(i) - CS%Kdml) * I_Hmix) * depth_c + (2.0*CS%Kdml - Kd_sfc(i)) - endif + Kd_lay(i,k) = ((Kd_sfc(i) - CS%Kd_tot_ml) * I_Hmix) * depth_c + (2.0*CS%Kd_tot_ml - Kd_sfc(i)) endif - depth(i) = depth(i) + GV%H_to_Z*h(i,j,k) + depth(i) = depth(i) + h(i,j,k) enddo ; enddo else ! There is no vertical structure to the background diffusivity. @@ -506,8 +482,8 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, ! Update Kd_int and Kv_bkgnd, based on Kd_lay. These might be just used for diagnostic purposes. do i=is,ie - Kd_int(i,1) = 0.0; Kv_bkgnd(i,1) = 0.0 - Kd_int(i,nz+1) = 0.0; Kv_bkgnd(i,nz+1) = 0.0 + Kd_int(i,1) = 0.0 ; Kv_bkgnd(i,1) = 0.0 + Kd_int(i,nz+1) = 0.0 ; Kv_bkgnd(i,nz+1) = 0.0 enddo do K=2,nz ; do i=is,ie Kd_int(i,K) = 0.5*(Kd_lay(i,k-1) + Kd_lay(i,k)) @@ -523,7 +499,7 @@ end subroutine calculate_bkgnd_mixing logical function CVMix_bkgnd_is_used(param_file) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters call get_param(param_file, mdl, "USE_CVMix_BACKGROUND", CVMix_bkgnd_is_used, & - default=.false., do_not_log = .true.) + default=.false., do_not_log=.true.) end function CVMix_bkgnd_is_used @@ -543,7 +519,7 @@ subroutine check_bkgnd_scheme(CS, str) end subroutine -!> Clear pointers and dealocate memory +!> Clear pointers and deallocate memory subroutine bkgnd_mixing_end(CS) type(bkgnd_mixing_cs), pointer :: CS !< Control structure for this module that !! will be deallocated in this subroutine diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index dd160c300c..16fbc24b1f 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -1,21 +1,25 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Build mixed layer parameterization module MOM_bulk_mixed_layer -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc use MOM_diag_mediator, only : time_type, diag_ctrl, diag_update_remap_grids use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain +use MOM_EOS, only : average_specific_vol, calculate_density_derivs +use MOM_EOS, only : calculate_spec_vol, calculate_specific_vol_derivs use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : extractFluxes1d, forcing +use MOM_forcing_type, only : extractFluxes1d, forcing, find_ustar use MOM_grid, only : ocean_grid_type use MOM_opacity, only : absorbRemainingSW, optics_type, extract_optics_slice use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain implicit none ; private @@ -35,7 +39,7 @@ module MOM_bulk_mixed_layer integer :: nkbl !< The number of buffer layers. integer :: nsw !< The number of bands of penetrating shortwave radiation. real :: mstar !< The ratio of the friction velocity cubed to the - !! TKE input to the mixed layer, nondimensional. + !! TKE input to the mixed layer [nondim]. real :: nstar !< The fraction of the TKE input to the mixed layer !! available to drive entrainment [nondim]. real :: nstar2 !< The fraction of potential energy released by @@ -43,13 +47,20 @@ module MOM_bulk_mixed_layer logical :: absorb_all_SW !< If true, all shortwave radiation is absorbed by the !! ocean, instead of passing through to the bottom mud. real :: TKE_decay !< The ratio of the natural Ekman depth to the TKE - !! decay scale, nondimensional. - real :: bulk_Ri_ML !< The efficiency with which mean kinetic energy - !! released by mechanically forced entrainment of - !! the mixed layer is converted to TKE [nondim]. - real :: bulk_Ri_convective !< The efficiency with which convectively - !! released mean kinetic energy becomes TKE [nondim]. + !! decay scale [nondim]. + real :: bulk_Ri_ML !< The efficiency with which mean kinetic energy released by + !! mechanically forced entrainment of the mixed layer is + !! converted to TKE, times conversion factors between the + !! natural units of mean kinetic energy and TKE [Z2 L-2 ~> nondim] + real :: bulk_Ri_convective !< The efficiency with which convectively released mean kinetic + !! energy becomes TKE, times conversion factors between the natural + !! units of mean kinetic energy and TKE [Z2 L-2 ~> nondim] + real :: vonKar !< The von Karman constant as used for mixed layer viscosity [nondim] real :: Hmix_min !< The minimum mixed layer thickness [H ~> m or kg m-2]. + real :: mech_TKE_floor !< A tiny floor on the amount of turbulent kinetic energy that is + !! used when the mixed layer does not yet contain HMIX_MIN fluid + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. The default is so small that its actual + !! value is irrelevant, but it is detectably greater than 0. real :: H_limit_fluxes !< When the total ocean depth is less than this !! value [H ~> m or kg m-2], scale away all surface forcing to !! avoid boiling the ocean. @@ -57,7 +68,7 @@ module MOM_bulk_mixed_layer !! If the value is small enough, this should not affect the solution. real :: omega !< The Earth's rotation rate [T-1 ~> s-1]. real :: dT_dS_wt !< When forced to extrapolate T & S to match the - !! layer densities, this factor (in degC / ppt) is + !! layer densities, this factor [C S-1 ~> degC ppt-1] is !! combined with the derivatives of density with T & S !! to determines what direction is orthogonal to !! density contours. It should be a typical value of @@ -83,13 +94,15 @@ module MOM_bulk_mixed_layer integer :: ML_presort_nz_conv_adj !< If ML_resort is true, do convective !! adjustment on this many layers (starting from the !! top) before sorting the remaining layers. - real :: omega_frac !< When setting the decay scale for turbulence, use - !! this fraction of the absolute rotation rate blended - !! with the local value of f, as sqrt((1-of)*f^2 + of*4*omega^2). + real :: omega_frac !< When setting the decay scale for turbulence, use this fraction + !! of the absolute rotation rate blended with the local value of f, + !! as sqrt((1-of)*f^2 + of*4*omega^2) [nondim]. logical :: correct_absorption !< If true, the depth at which penetrating !! shortwave radiation is absorbed is corrected by !! moving some of the heating upward in the water !! column. The default is false. + logical :: nonBous_energetics !< If true, use non-Boussinesq expressions for the energetic + !! calculations used in the bulk mixed layer calculations. logical :: Resolve_Ekman !< If true, the nkml layers in the mixed layer are !! chosen to optimally represent the impact of the !! Ekman transport on the mixed layer TKE budget. @@ -97,16 +110,15 @@ module MOM_bulk_mixed_layer logical :: TKE_diagnostics = .false. !< If true, calculate extensive diagnostics of the TKE budget logical :: do_rivermix = .false. !< Provide additional TKE to mix river runoff !! at the river mouths to rivermix_depth - real :: rivermix_depth = 0.0 !< The depth of mixing if do_rivermix is true [Z ~> m]. + real :: rivermix_depth = 0.0 !< The depth of mixing if do_rivermix is true [H ~> m or kg m-2]. logical :: limit_det !< If true, limit the extent of buffer layer !! detrainment to be consistent with neighbors. real :: lim_det_dH_sfc !< The fractional limit in the change between grid !! points of the surface region (mixed & buffer !! layer) thickness [nondim]. 0.5 by default. real :: lim_det_dH_bathy !< The fraction of the total depth by which the - !! thickness of the surface region (mixed & buffer - !! layer) is allowed to change between grid points. - !! Nondimensional, 0.2 by default. + !! thickness of the surface region (mixed & buffer layers) is allowed + !! to change between grid points [nondim]. 0.2 by default. logical :: use_river_heat_content !< If true, use the fluxes%runoff_Hflx field !! to set the heat carried by runoff, instead of !! using SST for temperature of liq_runoff @@ -117,25 +129,25 @@ module MOM_bulk_mixed_layer type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the !! timing of diagnostic output. real :: Allowed_T_chg !< The amount by which temperature is allowed - !! to exceed previous values during detrainment, K. + !! to exceed previous values during detrainment [C ~> degC] real :: Allowed_S_chg !< The amount by which salinity is allowed - !! to exceed previous values during detrainment, ppt. + !! to exceed previous values during detrainment [S ~> ppt] - ! These are terms in the mixed layer TKE budget, all in [Z L2 T-3 ~> m3 s-3] except as noted. + ! These are terms in the mixed layer TKE budget, all in [H Z2 T-3 ~> m3 s-3 or W m-2] except as noted. real, allocatable, dimension(:,:) :: & ML_depth, & !< The mixed layer depth [H ~> m or kg m-2]. - diag_TKE_wind, & !< The wind source of TKE. - diag_TKE_RiBulk, & !< The resolved KE source of TKE. - diag_TKE_conv, & !< The convective source of TKE. - diag_TKE_pen_SW, & !< The TKE sink required to mix penetrating shortwave heating. - diag_TKE_mech_decay, & !< The decay of mechanical TKE. - diag_TKE_conv_decay, & !< The decay of convective TKE. - diag_TKE_mixing, & !< The work done by TKE to deepen the mixed layer. - diag_TKE_conv_s2, & !< The convective source of TKE due to to mixing in sigma2. + diag_TKE_wind, & !< The wind source of TKE [H Z2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_RiBulk, & !< The resolved KE source of TKE [H Z2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_conv, & !< The convective source of TKE [H Z2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_pen_SW, & !< The TKE sink required to mix penetrating shortwave heating [H Z2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_mech_decay, & !< The decay of mechanical TKE [H Z2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_conv_decay, & !< The decay of convective TKE [H Z2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_mixing, & !< The work done by TKE to deepen the mixed layer [H Z2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_conv_s2, & !< The convective source of TKE due to to mixing in sigma2 [H Z2 T-3 ~> m3 s-3 or W m-2]. diag_PE_detrain, & !< The spurious source of potential energy due to mixed layer - !! detrainment [R Z L2 T-3 ~> W m-2]. + !! detrainment [R Z3 T-3 ~> W m-2]. diag_PE_detrain2 !< The spurious source of potential energy due to mixed layer only - !! detrainment [R Z L2 T-3 ~> W m-2]. + !! detrainment [R Z3 T-3 ~> W m-2]. type(group_pass_type) :: pass_h_sum_hmbl_prev !< For group halo pass !>@{ Diagnostic IDs @@ -156,7 +168,7 @@ module MOM_bulk_mixed_layer !> This subroutine partially steps the bulk mixed layer model. !! See \ref BML for more details. subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, CS, & - optics, Hml, aggregate_FW_forcing, dt_diag, last_call) + optics, BLD, H_ml, aggregate_FW_forcing, dt_diag, last_call) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -170,10 +182,10 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C !! [L T-1 ~> m s-1]. type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any !! available thermodynamic fields. Absent - !! fields have NULL ptrs. + !! fields have NULL pointers. type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any !! possible forcing fields. Unused fields - !! have NULL ptrs. + !! have NULL pointers. real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: ea !< The amount of fluid moved downward into a @@ -183,18 +195,21 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C intent(inout) :: eb !< The amount of fluid moved upward into a !! layer; this should be increased due to !! mixed layer entrainment [H ~> m or kg m-2]. - type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control struct + type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control structure type(optics_type), pointer :: optics !< The structure that can be queried for the !! inverse of the vertical absorption decay !! scale for penetrating shortwave radiation. - real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), & + intent(inout) :: BLD !< Active mixed layer depth [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), & + intent(inout) :: H_ml !< Active mixed layer thickness [H ~> m or kg m-2]. logical, intent(in) :: aggregate_FW_forcing !< If true, the net incoming and !! outgoing surface freshwater fluxes are !! combined before being applied, instead of !! being applied separately. real, optional, intent(in) :: dt_diag !< The diagnostic time step, !! which may be less than dt if there are - !! two callse to mixedlayer [T ~> s]. + !! two calls to mixedlayer [T ~> s]. logical, optional, intent(in) :: last_call !< if true, this is the last call !! to mixedlayer in the current time step, so !! diagnostics will be written. The default is @@ -212,9 +227,10 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! will be used to hold the new mixed layer properties. real, dimension(SZI_(G),SZK0_(GV)) :: & h, & ! The layer thickness [H ~> m or kg m-2]. - T, & ! The layer temperatures [degC]. - S, & ! The layer salinities [ppt]. + T, & ! The layer temperatures [C ~> degC]. + S, & ! The layer salinities [S ~> ppt]. R0, & ! The potential density referenced to the surface [R ~> kg m-3]. + SpV0, & ! The specific volume referenced to the surface [R-1 ~> m3 kg-1]. Rcv ! The coordinate variable potential density [R ~> kg m-3]. real, dimension(SZI_(G),SZK_(GV)) :: & u, & ! The zonal velocity [L T-1 ~> m s-1]. @@ -230,81 +246,97 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C integer, dimension(SZI_(G),SZK_(GV)) :: & ksort ! The sorted k-index that each original layer goes to. real, dimension(SZI_(G),SZJ_(G)) :: & - h_miss ! The summed absolute mismatch [Z ~> m]. + h_miss ! The summed absolute mismatch [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)) :: & + U_star_2d, &! The wind friction velocity, calculated using the Boussinesq reference density or + ! the time-evolving surface density in non-Boussinesq mode [Z T-1 ~> m s-1] + U_star_H_2d ! The wind friction velocity in thickness-based units, calculated + ! using the Boussinesq reference density or the time-evolving + ! surface density in non-Boussinesq mode [H T-1 ~> m s-1 or kg m-2 s-1] real, dimension(SZI_(G)) :: & TKE, & ! The turbulent kinetic energy available for mixing over a - ! time step [Z L2 T-2 ~> m3 s-2]. + ! time step [H Z2 T-2 ~> m3 s-2 or J m-2]. Conv_En, & ! The turbulent kinetic energy source due to mixing down to - ! the depth of free convection [Z L2 T-2 ~> m3 s-2]. + ! the depth of free convection [H Z2 T-2 ~> m3 s-2 or J m-2]. htot, & ! The total depth of the layers being considered for ! entrainment [H ~> m or kg m-2]. R0_tot, & ! The integrated potential density referenced to the surface ! of the layers which are fully entrained [H R ~> kg m-2 or kg2 m-5]. + SpV0_tot, & ! The integrated specific volume referenced to the surface + ! of the layers which are fully entrained [H R-1 ~> m4 kg-1 or m]. Rcv_tot, & ! The integrated coordinate value potential density of the ! layers that are fully entrained [H R ~> kg m-2 or kg2 m-5]. Ttot, & ! The integrated temperature of layers which are fully - ! entrained [degC H ~> degC m or degC kg m-2]. + ! entrained [C H ~> degC m or degC kg m-2]. Stot, & ! The integrated salt of layers which are fully entrained - ! [H ppt ~> m ppt or ppt kg m-2]. - uhtot, & ! The depth integrated zonal and meridional velocities in the - vhtot, & ! mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + ! [H S ~> m ppt or ppt kg m-2]. + uhtot, & ! The depth integrated zonal velocity in the mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1] + vhtot, & ! The depth integrated meridional velocity in the mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1] - netMassInOut, & ! The net mass flux (if non-Boussinsq) or volume flux (if + netMassInOut, & ! The net mass flux (if non-Boussinesq) or volume flux (if ! Boussinesq - i.e. the fresh water flux (P+R-E)) into the ! ocean over a time step [H ~> m or kg m-2]. NetMassOut, & ! The mass flux (if non-Boussinesq) or volume flux (if Boussinesq) ! over a time step from evaporating fresh water [H ~> m or kg m-2] - Net_heat, & ! The net heating at the surface over a time step [degC H ~> degC m or degC kg m-2]. + Net_heat, & ! The net heating at the surface over a time step [C H ~> degC m or degC kg m-2] ! Any penetrating shortwave radiation is not included in Net_heat. - Net_salt, & ! The surface salt flux into the ocean over a time step, ppt H. + Net_salt, & ! The surface salt flux into the ocean over a time step [S H ~> ppt m or ppt kg m-2] Idecay_len_TKE, & ! The inverse of a turbulence decay length scale [H-1 ~> m-1 or m2 kg-1]. p_ref, & ! Reference pressure for the potential density governing mixed ! layer dynamics, almost always 0 (or 1e5) [R L2 T-2 ~> Pa]. p_ref_cv, & ! Reference pressure for the potential density which defines ! the coordinate variable, set to P_Ref [R L2 T-2 ~> Pa]. dR0_dT, & ! Partial derivative of the mixed layer potential density with - ! temperature [R degC-1 ~> kg m-3 degC-1]. + ! temperature [R C-1 ~> kg m-3 degC-1]. + dSpV0_dT, & ! Partial derivative of the mixed layer specific volume with + ! temperature [R-1 C-1 ~> m3 kg-1 degC-1]. dRcv_dT, & ! Partial derivative of the coordinate variable potential - ! density in the mixed layer with temperature [R degC-1 ~> kg m-3 degC-1]. + ! density in the mixed layer with temperature [R C-1 ~> kg m-3 degC-1]. dR0_dS, & ! Partial derivative of the mixed layer potential density with - ! salinity [R ppt-1 ~> kg m-3 ppt-1]. + ! salinity [R S-1 ~> kg m-3 ppt-1]. + dSpV0_dS, & ! Partial derivative of the mixed layer specific volume with + ! salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. dRcv_dS, & ! Partial derivative of the coordinate variable potential - ! density in the mixed layer with salinity [R ppt-1 ~> kg m-3 ppt-1]. + ! density in the mixed layer with salinity [R S-1 ~> kg m-3 ppt-1]. + p_sfc, & ! The sea surface pressure [R L2 T-2 ~> Pa] + dp_ml, & ! The pressure change across the mixed layer [R L2 T-2 ~> Pa] + SpV_ml, & ! The specific volume averaged across the mixed layer [R-1 ~> m3 kg-1] TKE_river ! The source of turbulent kinetic energy available for mixing - ! at rivermouths [Z L2 T-3 ~> m3 s-3]. + ! at rivermouths [H Z2 T-3 ~> m3 s-3 or W m-2]. real, dimension(max(CS%nsw,1),SZI_(G)) :: & Pen_SW_bnd ! The penetrating fraction of the shortwave heating integrated - ! over a time step in each band [degC H ~> degC m or degC kg m-2]. + ! over a time step in each band [C H ~> degC m or degC kg m-2]. real, dimension(max(CS%nsw,1),SZI_(G),SZK_(GV)) :: & - opacity_band ! The opacity in each band [H-1 ~> m-1 or m2 kg-1]. The indicies are band, i, k. + opacity_band ! The opacity in each band [H-1 ~> m-1 or m2 kg-1]. The indices are band, i, k. real :: cMKE(2,SZI_(G)) ! Coefficients of HpE and HpE^2 used in calculating the ! denominator of MKE_rate; the two elements have differing ! units of [H-1 ~> m-1 or m2 kg-1] and [H-2 ~> m-2 or m4 kg-2]. real :: Irho0 ! 1.0 / rho_0 [R-1 ~> m3 kg-1] - real :: Inkml, Inkmlm1! 1.0 / REAL(nkml) and 1.0 / REAL(nkml-1) + real :: Inkml, Inkmlm1! 1.0 / REAL(nkml) and 1.0 / REAL(nkml-1) [nondim] real :: Ih ! The inverse of a thickness [H-1 ~> m-1 or m2 kg-1]. real :: Idt_diag ! The inverse of the timestep used for diagnostics [T-1 ~> s-1]. - real :: RmixConst - + real :: RmixConst ! A combination of constants used in the river mixing energy + ! calculation [H Z T-2 R-2 ~> m8 s-2 kg-2 or m5 s-2 kg-1] or + ! [H Z T-2 ~> m2 s-2 or kg m-1 s-2] real, dimension(SZI_(G)) :: & dKE_FC, & ! The change in mean kinetic energy due to free convection - ! [Z L2 T-2 ~> m3 s-2]. + ! [H Z2 T-2 ~> m3 s-2 or J m-2]. h_CA ! The depth to which convective adjustment has gone [H ~> m or kg m-2]. real, dimension(SZI_(G),SZK_(GV)) :: & dKE_CA, & ! The change in mean kinetic energy due to convective - ! adjustment [Z L2 T-2 ~> m3 s-2]. + ! adjustment [H Z2 T-2 ~> m3 s-2 or J m-2]. cTKE ! The turbulent kinetic energy source due to convective - ! adjustment [Z L2 T-2 ~> m3 s-2]. + ! adjustment [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZJ_(G)) :: & Hsfc_max, & ! The thickness of the surface region (mixed and buffer layers) - ! after entrainment but before any buffer layer detrainment [Z ~> m]. + ! after entrainment but before any buffer layer detrainment [H ~> m or kg m-2]. Hsfc_used, & ! The thickness of the surface region after buffer layer - ! detrainment [Z ~> m]. + ! detrainment [H ~> m or kg m-2]. Hsfc_min, & ! The minimum thickness of the surface region based on the ! new mixed layer depth and the previous thickness of the - ! neighboring water columns [Z ~> m]. + ! neighboring water columns [H ~> m or kg m-2]. h_sum, & ! The total thickness of the water column [H ~> m or kg m-2]. hmbl_prev ! The previous thickness of the mixed and buffer layers [H ~> m or kg m-2]. real, dimension(SZI_(G)) :: & @@ -312,16 +344,16 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! layers before detrainment in to the interior [H ~> m or kg m-2]. max_BL_det ! If non-negative, the maximum amount of entrainment from ! the buffer layers that will be allowed this time step [H ~> m or kg m-2]. - real :: dHsfc, dHD ! Local copies of nondimensional parameters. + real :: dHsfc, dHD ! Local copies of nondimensional parameters [nondim] real :: H_nbr ! A minimum thickness based on neighboring thicknesses [H ~> m or kg m-2]. - real :: absf_x_H ! The absolute value of f times the mixed layer thickness [Z T-1 ~> m s-1]. - real :: kU_star ! Ustar times the Von Karmen constant [Z T-1 ~> m s-1]. - real :: dt__diag ! A recaled copy of dt_diag (if present) or dt [T ~> s]. + real :: absf_x_H ! The absolute value of f times the mixed layer thickness [H T-1 ~> m s-1 or kg m-2 s-1]. + real :: kU_star ! Ustar times the Von Karman constant [H T-1 ~> m s-1 or kg m-2 s-1]. + real :: dt__diag ! A rescaled copy of dt_diag (if present) or dt [T ~> s]. logical :: write_diags ! If true, write out diagnostics with this step. logical :: reset_diags ! If true, zero out the accumulated diagnostics. integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state - integer :: i, j, k, is, ie, js, je, nz, nkmb, n + integer :: i, j, k, is, ie, js, je, nz, nkmb integer :: nsw ! The number of bands of penetrating shortwave radiation. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -333,16 +365,16 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C if (.not. associated(tv%eqn_of_state)) call MOM_error(FATAL, & "MOM_mixed_layer: Temperature, salinity and an equation of state "//& "must now be used.") - if (.NOT. associated(fluxes%ustar)) call MOM_error(FATAL, & - "MOM_mixed_layer: No surface TKE fluxes (ustar) defined in mixedlayer!") + if (.not. (associated(fluxes%ustar) .or. associated(fluxes%tau_mag))) call MOM_error(FATAL, & + "MOM_mixed_layer: No surface TKE fluxes (ustar or tau_mag) defined in mixedlayer!") nkmb = CS%nkml+CS%nkbl Inkml = 1.0 / REAL(CS%nkml) if (CS%nkml > 1) Inkmlm1 = 1.0 / REAL(CS%nkml-1) - Irho0 = 1.0 / (GV%Rho0) + Irho0 = 1.0 / GV%Rho0 dt__diag = dt ; if (present(dt_diag)) dt__diag = dt_diag - Idt_diag = 1.0 / (dt__diag) + Idt_diag = 1.0 / dt__diag write_diags = .true. ; if (present(last_call)) write_diags = last_call p_ref(:) = 0.0 ; p_ref_cv(:) = tv%P_Ref @@ -408,11 +440,16 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C max_BL_det(:) = -1 EOSdom(:) = EOS_domain(G%HI) + ! Extract the friction velocity from the forcing type. + call find_ustar(fluxes, tv, U_star_2d, G, GV, US) + if (CS%Resolve_Ekman .and. (CS%nkml>1)) & + call find_ustar(fluxes, tv, U_star_H_2d, G, GV, US, H_T_units=.true.) + !$OMP parallel default(shared) firstprivate(dKE_CA,cTKE,h_CA,max_BL_det,p_ref,p_ref_cv) & - !$OMP private(h,u,v,h_orig,eps,T,S,opacity_band,d_ea,d_eb,R0,Rcv,ksort, & - !$OMP dR0_dT,dR0_dS,dRcv_dT,dRcv_dS,htot,Ttot,Stot,TKE,Conv_en, & + !$OMP private(h,u,v,h_orig,eps,T,S,opacity_band,d_ea,d_eb,R0,SpV0,Rcv,ksort, & + !$OMP dR0_dT,dR0_dS,dRcv_dT,dRcv_dS,dSpV0_dT,dSpV0_dS,htot,Ttot,Stot,TKE,Conv_en, & !$OMP RmixConst,TKE_river,Pen_SW_bnd,netMassInOut,NetMassOut, & - !$OMP Net_heat,Net_salt,uhtot,vhtot,R0_tot,Rcv_tot,dKE_FC, & + !$OMP Net_heat,Net_salt,uhtot,vhtot,R0_tot,Rcv_tot,SpV0_tot,dKE_FC, & !$OMP Idecay_len_TKE,cMKE,Hsfc,dHsfc,dHD,H_nbr,kU_Star, & !$OMP absf_x_H,ebml,eaml) !$OMP do @@ -424,7 +461,14 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C eps(i,k) = 0.0 ; if (k > nkmb) eps(i,k) = GV%Angstrom_H T(i,k) = tv%T(i,j,k) ; S(i,k) = tv%S(i,j,k) enddo ; enddo - if (nsw>0) call extract_optics_slice(optics, j, G, GV, opacity=opacity_band, opacity_scale=GV%H_to_m) + if (nsw>0) then + if (GV%Boussinesq .or. (.not.allocated(tv%SpV_avg))) then + call extract_optics_slice(optics, j, G, GV, opacity=opacity_band, opacity_scale=GV%H_to_Z) + else + call extract_optics_slice(optics, j, G, GV, opacity=opacity_band, opacity_scale=GV%H_to_RZ, & + SpV_avg=tv%SpV_avg) + endif + endif do k=1,nz ; do i=is,ie d_ea(i,k) = 0.0 ; d_eb(i,k) = 0.0 @@ -439,26 +483,35 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C do k=1,CS%nkml ; do i=is,ie p_ref(i) = p_ref(i) + 0.5*(GV%H_to_RZ*GV%g_Earth)*h(i,k) enddo ; enddo - call calculate_density_derivs(T(:,1), S(:,1), p_ref, dR0_dT, dR0_dS, tv%eqn_of_state, EOSdom) + if (CS%nonBous_energetics) then + call calculate_specific_vol_derivs(T(:,1), S(:,1), p_ref, dSpV0_dT, dSpV0_dS, tv%eqn_of_state, EOSdom) + do k=1,nz + call calculate_spec_vol(T(:,k), S(:,k), p_ref, SpV0(:,k), tv%eqn_of_state, EOSdom) + enddo + else + call calculate_density_derivs(T(:,1), S(:,1), p_ref, dR0_dT, dR0_dS, tv%eqn_of_state, EOSdom) + do k=1,nz + call calculate_density(T(:,k), S(:,k), p_ref, R0(:,k), tv%eqn_of_state, EOSdom) + enddo + endif call calculate_density_derivs(T(:,1), S(:,1), p_ref_cv, dRcv_dT, dRcv_dS, tv%eqn_of_state, EOSdom) do k=1,nz - call calculate_density(T(:,k), S(:,k), p_ref, R0(:,k), tv%eqn_of_state, EOSdom) call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), tv%eqn_of_state, EOSdom) enddo if (CS%ML_resort) then if (CS%ML_presort_nz_conv_adj > 0) & - call convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, dKE_CA, cTKE, j, G, GV, & + call convective_adjustment(h, u, v, R0, SpV0, Rcv, T, S, eps, d_eb, dKE_CA, cTKE, j, G, GV, & US, CS, CS%ML_presort_nz_conv_adj) - call sort_ML(h, R0, eps, G, GV, CS, ksort) + call sort_ML(h, R0, SpV0, eps, G, GV, CS, ksort) else do k=1,nz ; do i=is,ie ; ksort(i,k) = k ; enddo ; enddo ! Undergo instantaneous entrainment into the buffer layers and mixed layers ! to remove hydrostatic instabilities. Any water that is lighter than ! currently in the mixed or buffer layer is entrained. - call convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, dKE_CA, cTKE, j, G, GV, US, CS) + call convective_adjustment(h, u, v, R0, SpV0, Rcv, T, S, eps, d_eb, dKE_CA, cTKE, j, G, GV, US, CS) do i=is,ie ; h_CA(i) = h(i,1) ; enddo endif @@ -468,18 +521,28 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! Here we add an additional source of TKE to the mixed layer where river ! is present to simulate unresolved estuaries. The TKE input is diagnosed ! as follows: - ! TKE_river[Z L2 T-3 ~> m3 s-3] = 0.5*rivermix_depth * g * Irho0**2 * drho_ds * + ! TKE_river[H Z2 T-3 ~> m3 s-3] = 0.5*rivermix_depth * g * Irho0**2 * drho_ds * ! River*(Samb - Sriver) = CS%mstar*U_star^3 ! where River is in units of [R Z T-1 ~> kg m-2 s-1]. ! Samb = Ambient salinity at the mouth of the estuary ! rivermix_depth = The prescribed depth over which to mix river inflow ! drho_ds = The gradient of density wrt salt at the ambient surface salinity. ! Sriver = 0 (i.e. rivers are assumed to be pure freshwater) - RmixConst = 0.5*CS%rivermix_depth * GV%g_Earth * Irho0**2 - do i=is,ie - TKE_river(i) = max(0.0, RmixConst*dR0_dS(i)* & - (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * S(i,1)) - enddo + if (CS%nonBous_energetics) then + RmixConst = -0.5*CS%rivermix_depth * GV%g_Earth_Z_T2 + do i=is,ie + TKE_river(i) = max(0.0, RmixConst * dSpV0_dS(i) * & + ((fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) + & + (fluxes%lrunoff_glc(i,j) + fluxes%frunoff_glc(i,j))) * S(i,1)) + enddo + else + RmixConst = 0.5*CS%rivermix_depth * GV%g_Earth_Z_T2 * Irho0**2 + do i=is,ie + TKE_river(i) = max(0.0, RmixConst*dR0_dS(i)* & + ((fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) + & + (fluxes%lrunoff_glc(i,j) + fluxes%frunoff_glc(i,j))) * S(i,1)) + enddo + endif else do i=is,ie ; TKE_river(i) = 0.0 ; enddo endif @@ -488,8 +551,8 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! We aggregate the thermodynamic forcing for a time step into the following: ! netMassInOut = water [H ~> m or kg m-2] added/removed via surface fluxes ! netMassOut = water [H ~> m or kg m-2] removed via evaporating surface fluxes - ! net_heat = heat via surface fluxes [degC H ~> degC m or degC kg m-2] - ! net_salt = salt via surface fluxes [ppt H ~> ppt m or gSalt m-2] + ! net_heat = heat via surface fluxes [C H ~> degC m or degC kg m-2] + ! net_salt = salt via surface fluxes [S H ~> ppt m or gSalt m-2] ! Pen_SW_bnd = components to penetrative shortwave radiation call extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & CS%H_limit_fluxes, CS%use_river_heat_content, CS%use_calving_heat_content, & @@ -497,27 +560,27 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C tv, aggregate_FW_forcing) ! This subroutine causes the mixed layer to entrain to depth of free convection. - call mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, R0_tot, Rcv_tot, & - u, v, T, S, R0, Rcv, eps, dR0_dT, dRcv_dT, dR0_dS, dRcv_dS, & + call mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, R0_tot, SpV0_tot, Rcv_tot, & + u, v, T, S, R0, SpV0, Rcv, eps, dR0_dT, dSpV0_dT, dRcv_dT, dR0_dS, dSpV0_dS, dRcv_dS, & netMassInOut, netMassOut, Net_heat, Net_salt, & nsw, Pen_SW_bnd, opacity_band, Conv_En, dKE_FC, & j, ksort, G, GV, US, CS, tv, fluxes, dt, aggregate_FW_forcing) ! Now the mixed layer undergoes mechanically forced entrainment. ! The mixed layer may entrain down to the Monin-Obukhov depth if the - ! surface is becoming lighter, and is effecti1336vely detraining. + ! surface is becoming lighter, and is effectively detraining. ! First the TKE at the depth of free convection that is available ! to drive mixing is calculated. - call find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, & - TKE, TKE_river, Idecay_len_TKE, cMKE, dt, Idt_diag, & + call find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_FC, dKE_CA, & + TKE, TKE_river, Idecay_len_TKE, cMKE, tv, dt, Idt_diag, & j, ksort, G, GV, US, CS) ! Here the mechanically driven entrainment occurs. call mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & - R0_tot, Rcv_tot, u, v, T, S, R0, Rcv, eps, dR0_dT, dRcv_dT, & - cMKE, Idt_diag, nsw, Pen_SW_bnd, opacity_band, TKE, & - Idecay_len_TKE, j, ksort, G, GV, US, CS) + R0_tot, SpV0_tot, Rcv_tot, u, v, T, S, R0, SpV0, Rcv, eps, & + dR0_dT, dSpV0_dT, dRcv_dT, cMKE, Idt_diag, nsw, Pen_SW_bnd, & + opacity_band, TKE, Idecay_len_TKE, j, ksort, G, GV, US, CS) call absorbRemainingSW(G, GV, US, h(:,1:), opacity_band, nsw, optics, j, dt, & CS%H_limit_fluxes, CS%correct_absorption, CS%absorb_all_SW, & @@ -530,20 +593,49 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! Calculate the homogeneous mixed layer properties and store them in layer 0. do i=is,ie ; if (htot(i) > 0.0) then Ih = 1.0 / htot(i) - R0(i,0) = R0_tot(i) * Ih ; Rcv(i,0) = Rcv_tot(i) * Ih + if (CS%nonBous_energetics) then + SpV0(i,0) = SpV0_tot(i) * Ih + else + R0(i,0) = R0_tot(i) * Ih + endif + Rcv(i,0) = Rcv_tot(i) * Ih T(i,0) = Ttot(i) * Ih ; S(i,0) = Stot(i) * Ih h(i,0) = htot(i) else ! This may not ever be needed? - T(i,0) = T(i,1) ; S(i,0) = S(i,1) ; R0(i,0) = R0(i,1) ; Rcv(i,0) = Rcv(i,1) + T(i,0) = T(i,1) ; S(i,0) = S(i,1) ; Rcv(i,0) = Rcv(i,1) + if (CS%nonBous_energetics) then + SpV0(i,0) = SpV0(i,1) + else + R0(i,0) = R0(i,1) + endif h(i,0) = htot(i) endif ; enddo if (write_diags .and. allocated(CS%ML_depth)) then ; do i=is,ie - CS%ML_depth(i,j) = h(i,0) * GV%H_to_m ! Rescale the diagnostic. - enddo ; endif - if (associated(Hml)) then ; do i=is,ie - Hml(i,j) = G%mask2dT(i,j) * (h(i,0) * GV%H_to_Z) ! Rescale the diagnostic for output. + CS%ML_depth(i,j) = h(i,0) ! Store the diagnostic. enddo ; endif + ! Return the mixed layer depth in [Z ~> m]. + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do i=is,ie + BLD(i,j) = G%mask2dT(i,j) * GV%H_to_Z*h(i,0) + enddo + else + do i=is,ie ; dp_ml(i) = GV%g_Earth * GV%H_to_RZ * h(i,0) ; enddo + if (associated(tv%p_surf)) then + do i=is,ie ; p_sfc(i) = tv%p_surf(i,j) ; enddo + else + do i=is,ie ; p_sfc(i) = 0.0 ; enddo + endif + call average_specific_vol(T(:,0), S(:,0), p_sfc, dp_ml, SpV_ml, tv%eqn_of_state) + do i=is,ie + BLD(i,j) = G%mask2dT(i,j) * GV%H_to_RZ * SpV_ml(i) * h(i,0) + enddo + endif + ! Return the mixed layer thickness in [H ~> m or kg m-2]. + do i=is,ie + H_ml(i,j) = G%mask2dT(i,j) * h(i,0) + enddo + ! At this point, return water to the original layers, but constrained to ! still be sorted. After this point, all the water that is in massive ! interior layers will be denser than water remaining in the mixed- and @@ -555,8 +647,8 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! these unused layers (but not currently in the code). if (CS%ML_resort) then - call resort_ML(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), Rcv(:,0:), GV%Rlay(:), eps, & - d_ea, d_eb, ksort, G, GV, CS, dR0_dT, dR0_dS, dRcv_dT, dRcv_dS) + call resort_ML(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), SpV0(:,0:), Rcv(:,0:), GV%Rlay(:), eps, & + d_ea, d_eb, ksort, G, GV, CS, dR0_dT, dR0_dS, dSpV0_dT, dSpV0_dS, dRcv_dT, dRcv_dS) endif if (CS%limit_det .or. (CS%id_Hsfc_max > 0) .or. (CS%id_Hsfc_min > 0)) then @@ -573,37 +665,37 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C hmbl_prev(i,j-1) - dHD*min(h_sum(i,j),h_sum(i,j-1)), & hmbl_prev(i,j+1) - dHD*min(h_sum(i,j),h_sum(i,j+1))) ) - Hsfc_min(i,j) = GV%H_to_Z * max(h(i,0), min(Hsfc(i), H_nbr)) + Hsfc_min(i,j) = max(h(i,0), min(Hsfc(i), H_nbr)) if (CS%limit_det) max_BL_det(i) = max(0.0, Hsfc(i)-H_nbr) enddo endif if (CS%id_Hsfc_max > 0) then ; do i=is,ie - Hsfc_max(i,j) = GV%H_to_Z * Hsfc(i) + Hsfc_max(i,j) = Hsfc(i) enddo ; endif endif -! Move water left in the former mixed layer into the buffer layer and -! from the buffer layer into the interior. These steps might best be -! treated in conjuction. + ! Move water left in the former mixed layer into the buffer layer and + ! from the buffer layer into the interior. These steps might best be + ! treated in conjunction. if (CS%nkbl == 1) then - call mixedlayer_detrain_1(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), Rcv(:,0:), & + call mixedlayer_detrain_1(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), SpV0(:,0:), Rcv(:,0:), & GV%Rlay(:), dt, dt__diag, d_ea, d_eb, j, G, GV, US, CS, & dRcv_dT, dRcv_dS, max_BL_det) elseif (CS%nkbl == 2) then - call mixedlayer_detrain_2(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), Rcv(:,0:), & + call mixedlayer_detrain_2(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), SpV0(:,0:), Rcv(:,0:), & GV%Rlay(:), dt, dt__diag, d_ea, j, G, GV, US, CS, & - dR0_dT, dR0_dS, dRcv_dT, dRcv_dS, max_BL_det) + dR0_dT, dR0_dS, dSpV0_dT, dSpV0_dS, dRcv_dT, dRcv_dS, max_BL_det) else ! CS%nkbl not = 1 or 2 ! This code only works with 1 or 2 buffer layers. call MOM_error(FATAL, "MOM_mixed_layer: CS%nkbl must be 1 or 2 for now.") endif if (CS%id_Hsfc_used > 0) then - do i=is,ie ; Hsfc_used(i,j) = GV%H_to_Z * h(i,0) ; enddo + do i=is,ie ; Hsfc_used(i,j) = h(i,0) ; enddo do k=CS%nkml+1,nkmb ; do i=is,ie - Hsfc_used(i,j) = Hsfc_used(i,j) + GV%H_to_Z * h(i,k) + Hsfc_used(i,j) = Hsfc_used(i,j) + h(i,k) enddo ; enddo endif @@ -618,14 +710,21 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! as the third piece will then optimally describe mixed layer ! restratification. For nkml>=4 the whole strategy should be revisited. do i=is,ie - kU_star = 0.41*fluxes%ustar(i,j) ! Maybe could be replaced with u*+w*? - if (associated(fluxes%ustar_shelf) .and. & - associated(fluxes%frac_shelf_h)) then - if (fluxes%frac_shelf_h(i,j) > 0.0) & - kU_star = (1.0 - fluxes%frac_shelf_h(i,j)) * kU_star + & - fluxes%frac_shelf_h(i,j) * (0.41*fluxes%ustar_shelf(i,j)) + ! Perhaps in the following, u* could be replaced with u*+w*? + kU_star = CS%vonKar * U_star_H_2d(i,j) + if (associated(fluxes%ustar_shelf) .and. associated(fluxes%frac_shelf_h)) then + if (fluxes%frac_shelf_h(i,j) > 0.0) then + if (allocated(tv%SpV_avg)) then + kU_star = (1.0 - fluxes%frac_shelf_h(i,j)) * kU_star + & + fluxes%frac_shelf_h(i,j) * ((CS%vonKar*fluxes%ustar_shelf(i,j)) / & + (GV%H_to_RZ * tv%SpV_avg(i,j,1))) + else + kU_star = (1.0 - fluxes%frac_shelf_h(i,j)) * kU_star + & + fluxes%frac_shelf_h(i,j) * (CS%vonKar*GV%Z_to_H*fluxes%ustar_shelf(i,j)) + endif + endif endif - absf_x_H = 0.25 * GV%H_to_Z * h(i,0) * & + absf_x_H = 0.25 * h(i,0) * & ((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I-1,J)))) ! If the mixed layer vertical viscosity specification is changed in @@ -676,7 +775,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! Copy the interior thicknesses and other fields back to the 3-d arrays. do k=CS%nkml+1,nz ; do i=is,ie - h_3d(i,j,k) = h(i,k); tv%T(i,j,k) = T(i,k) ; tv%S(i,j,k) = S(i,k) + h_3d(i,j,k) = h(i,k) ; tv%T(i,j,k) = T(i,k) ; tv%S(i,j,k) = S(i,k) enddo ; enddo do k=1,nz ; do i=is,ie @@ -686,15 +785,15 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C if (CS%id_h_mismatch > 0) then do i=is,ie - h_miss(i,j) = GV%H_to_Z * abs(h_3d(i,j,1) - (h_orig(i,1) + & + h_miss(i,j) = abs(h_3d(i,j,1) - (h_orig(i,1) + & (eaml(i,1) + (ebml(i,1) - eaml(i,1+1))))) enddo do k=2,nz-1 ; do i=is,ie - h_miss(i,j) = h_miss(i,j) + GV%H_to_Z * abs(h_3d(i,j,k) - (h_orig(i,k) + & + h_miss(i,j) = h_miss(i,j) + abs(h_3d(i,j,k) - (h_orig(i,k) + & ((eaml(i,k) - ebml(i,k-1)) + (ebml(i,k) - eaml(i,k+1))))) enddo ; enddo do i=is,ie - h_miss(i,j) = h_miss(i,j) + GV%H_to_Z * abs(h_3d(i,j,nz) - (h_orig(i,nz) + & + h_miss(i,j) = h_miss(i,j) + abs(h_3d(i,j,nz) - (h_orig(i,nz) + & ((eaml(i,nz) - ebml(i,nz-1)) + ebml(i,nz)))) enddo endif @@ -746,7 +845,7 @@ end subroutine bulkmixedlayer !> This subroutine does instantaneous convective entrainment into the buffer !! layers and mixed layers to remove hydrostatic instabilities. Any water that !! is lighter than currently in the mixed- or buffer- layer is entrained. -subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & +subroutine convective_adjustment(h, u, v, R0, SpV0, Rcv, T, S, eps, d_eb, & dKE_CA, cTKE, j, G, GV, US, CS, nz_conv) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -758,10 +857,12 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & !! points [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: R0 !< Potential density referenced to !! surface pressure [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg-1]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: Rcv !< The coordinate defining potential !! density [R ~> kg m-3]. - real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: T !< Layer temperatures [degC]. - real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Layer salinities [ppt]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: T !< Layer temperatures [C ~> degC]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Layer salinities [S ~> ppt]. real, dimension(SZI_(G),SZK_(GV)), intent(in) :: eps !< The negligibly small amount of water !! that will be left in each layer [H ~> m or kg m-2]. real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: d_eb !< The downward increase across a layer @@ -770,43 +871,44 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & !! a layer. real, dimension(SZI_(G),SZK_(GV)), intent(out) :: dKE_CA !< The vertically integrated change in !! kinetic energy due to convective - !! adjustment [Z L2 T-2 ~> m3 s-2]. + !! adjustment [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZK_(GV)), intent(out) :: cTKE !< The buoyant turbulent kinetic energy !! source due to convective adjustment - !! [Z L2 T-2 ~> m3 s-2]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. integer, intent(in) :: j !< The j-index to work on. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(bulkmixedlayer_CS), intent(in) :: CS !< Bulk mixed layer control struct + type(bulkmixedlayer_CS), intent(in) :: CS !< Bulk mixed layer control structure integer, optional, intent(in) :: nz_conv !< If present, the number of layers !! over which to do convective adjustment !! (perhaps CS%nkml). ! Local variables real, dimension(SZI_(G)) :: & - htot, & ! The total depth of the layers being considered for - ! entrainment [H ~> m or kg m-2]. R0_tot, & ! The integrated potential density referenced to the surface ! of the layers which are fully entrained [H R ~> kg m-2 or kg2 m-5]. + SpV0_tot, & ! The integrated specific volume referenced to the surface + ! of the layers which are fully entrained [H R-1 ~> m4 kg-1 or m]. Rcv_tot, & ! The integrated coordinate value potential density of the ! layers that are fully entrained [H R ~> kg m-2 or kg2 m-5]. Ttot, & ! The integrated temperature of layers which are fully - ! entrained [degC H ~> degC m or degC kg m-2]. + ! entrained [C H ~> degC m or degC kg m-2]. Stot, & ! The integrated salt of layers which are fully entrained - ! [H ppt ~> m ppt or ppt kg m-2]. - uhtot, & ! The depth integrated zonal and meridional velocities in - vhtot, & ! the mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + ! [H S ~> m ppt or ppt kg m-2]. + uhtot, & ! The depth integrated zonal velocities in the mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1] + vhtot, & ! The depth integrated meridional velocities in the mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1] KE_orig, & ! The total mean kinetic energy per unit area in the mixed layer before ! convection, [H L2 T-2 ~> m3 s-2 or kg s-2]. h_orig_k1 ! The depth of layer k1 before convective adjustment [H ~> m or kg m-2]. real :: h_ent ! The thickness from a layer that is entrained [H ~> m or kg m-2]. real :: Ih ! The inverse of a thickness [H-1 ~> m-1 or m2 kg-1]. - real :: g_H2_2Rho0 ! Half the gravitational acceleration times the square of + real :: g_H_2Rho0 ! Half the gravitational acceleration times ! the conversion from H to Z divided by the mean density, - ! in [L2 Z T-3 H-2 R-1 ~> m4 s-3 kg-1 or m10 s-3 kg-3]. + ! in [Z2 T-2 H-1 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]. + logical :: unstable integer :: is, ie, nz, i, k, k1, nzc, nkmb is = G%isc ; ie = G%iec ; nz = GV%ke - g_H2_2Rho0 = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * GV%Rho0) + g_H_2Rho0 = (GV%g_Earth_Z_T2 * GV%H_to_Z) / (2.0 * GV%Rho0) nzc = nz ; if (present(nz_conv)) nzc = nz_conv nkmb = CS%nkml+CS%nkbl @@ -816,9 +918,13 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & do k1=min(nzc-1,nkmb),1,-1 do i=is,ie h_orig_k1(i) = h(i,k1) - KE_orig(i) = 0.5*h(i,k1)*(u(i,k1)**2 + v(i,k1)**2) + KE_orig(i) = 0.5*h(i,k1)*((u(i,k1)**2) + (v(i,k1)**2)) uhtot(i) = h(i,k1)*u(i,k1) ; vhtot(i) = h(i,k1)*v(i,k1) - R0_tot(i) = R0(i,k1) * h(i,k1) + if (CS%nonBous_energetics) then + SpV0_tot(i) = SpV0(i,k1) * h(i,k1) + else + R0_tot(i) = R0(i,k1) * h(i,k1) + endif cTKE(i,k1) = 0.0 ; dKE_CA(i,k1) = 0.0 Rcv_tot(i) = Rcv(i,k1) * h(i,k1) @@ -826,17 +932,30 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & enddo do k=k1+1,nzc do i=is,ie - if ((h(i,k) > eps(i,k)) .and. (R0_tot(i) > h(i,k1)*R0(i,k))) then + if (CS%nonBous_energetics) then + unstable = (SpV0_tot(i) < h(i,k1)*SpV0(i,k)) + else + unstable = (R0_tot(i) > h(i,k1)*R0(i,k)) + endif + if ((h(i,k) > eps(i,k)) .and. unstable) then h_ent = h(i,k)-eps(i,k) - cTKE(i,k1) = cTKE(i,k1) + h_ent * g_H2_2Rho0 * & - (R0_tot(i) - h(i,k1)*R0(i,k)) * CS%nstar2 + if (CS%nonBous_energetics) then + ! This and the other energy calculations assume that specific volume is + ! conserved during mixing, which ignores certain thermobaric contributions. + cTKE(i,k1) = cTKE(i,k1) + 0.5 * h_ent * (GV%g_Earth_Z_T2 * GV%H_to_RZ) * & + (h(i,k1)*SpV0(i,k) - SpV0_tot(i)) * CS%nstar2 + SpV0_tot(i) = SpV0_tot(i) + h_ent * SpV0(i,k) + else + cTKE(i,k1) = cTKE(i,k1) + h_ent * g_H_2Rho0 * & + (R0_tot(i) - h(i,k1)*R0(i,k)) * CS%nstar2 + R0_tot(i) = R0_tot(i) + h_ent * R0(i,k) + endif if (k < nkmb) then cTKE(i,k1) = cTKE(i,k1) + cTKE(i,k) dKE_CA(i,k1) = dKE_CA(i,k1) + dKE_CA(i,k) endif - R0_tot(i) = R0_tot(i) + h_ent * R0(i,k) KE_orig(i) = KE_orig(i) + 0.5*h_ent* & - (u(i,k)*u(i,k) + v(i,k)*v(i,k)) + ((u(i,k)*u(i,k)) + (v(i,k)*v(i,k))) uhtot(i) = uhtot(i) + h_ent*u(i,k) vhtot(i) = vhtot(i) + h_ent*v(i,k) @@ -854,10 +973,14 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & ! layer in question, if it has entrained. do i=is,ie ; if (h(i,k1) > h_orig_k1(i)) then Ih = 1.0 / h(i,k1) - R0(i,k1) = R0_tot(i) * Ih + if (CS%nonBous_energetics) then + SpV0(i,k1) = SpV0_tot(i) * Ih + else + R0(i,k1) = R0_tot(i) * Ih + endif u(i,k1) = uhtot(i) * Ih ; v(i,k1) = vhtot(i) * Ih - dKE_CA(i,k1) = dKE_CA(i,k1) + GV%H_to_Z * (CS%bulk_Ri_convective * & - (KE_orig(i) - 0.5*h(i,k1)*(u(i,k1)**2 + v(i,k1)**2))) + dKE_CA(i,k1) = dKE_CA(i,k1) + CS%bulk_Ri_convective * & + (KE_orig(i) - 0.5*h(i,k1)*((u(i,k1)**2) + (v(i,k1)**2))) Rcv(i,k1) = Rcv_tot(i) * Ih T(i,k1) = Ttot(i) * Ih ; S(i,k1) = Stot(i) * Ih endif ; enddo @@ -865,7 +988,11 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & ! If lower mixed or buffer layers are massless, give them the properties of the ! layer above. do k=2,min(nzc,nkmb) ; do i=is,ie ; if (h(i,k) == 0.0) then - R0(i,k) = R0(i,k-1) + if (CS%nonBous_energetics) then + SpV0(i,k) = SpV0(i,k-1) + else + R0(i,k) = R0(i,k-1) + endif Rcv(i,k) = Rcv(i,k-1) ; T(i,k) = T(i,k-1) ; S(i,k) = S(i,k-1) endif ; enddo ; enddo @@ -875,8 +1002,8 @@ end subroutine convective_adjustment !! convection. The depth of free convection is the shallowest depth at which the !! fluid is denser than the average of the fluid above. subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & - R0_tot, Rcv_tot, u, v, T, S, R0, Rcv, eps, & - dR0_dT, dRcv_dT, dR0_dS, dRcv_dS, & + R0_tot, SpV0_tot, Rcv_tot, u, v, T, S, R0, SpV0, Rcv, eps, & + dR0_dT, dSpV0_dT, dRcv_dT, dR0_dS, dSpV0_dS, dRcv_dS, & netMassInOut, netMassOut, Net_heat, Net_salt, & nsw, Pen_SW_bnd, opacity_band, Conv_En, & dKE_FC, j, ksort, G, GV, US, CS, tv, fluxes, dt, & @@ -892,15 +1019,17 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & !! Positive values go with mass gain by a layer. real, dimension(SZI_(G)), intent(out) :: htot !< The accumulated mixed layer thickness [H ~> m or kg m-2]. real, dimension(SZI_(G)), intent(out) :: Ttot !< The depth integrated mixed layer temperature - !! [degC H ~> degC m or degC kg m-2]. + !! [C H ~> degC m or degC kg m-2]. real, dimension(SZI_(G)), intent(out) :: Stot !< The depth integrated mixed layer salinity - !! [ppt H ~> ppt m or ppt kg m-2]. + !! [S H ~> ppt m or ppt kg m-2]. real, dimension(SZI_(G)), intent(out) :: uhtot !< The depth integrated mixed layer zonal !! velocity [H L T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZI_(G)), intent(out) :: vhtot !< The integrated mixed layer meridional !! velocity [H L T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZI_(G)), intent(out) :: R0_tot !< The integrated mixed layer potential density referenced !! to 0 pressure [H R ~> kg m-2 or kg2 m-5]. + real, dimension(SZI_(G)), intent(out) :: SpV0_tot !< The integrated mixed layer specific volume referenced + !! to 0 pressure [H R-1 ~> m4 kg-1 or m]. real, dimension(SZI_(G)), intent(out) :: Rcv_tot !< The integrated mixed layer coordinate !! variable potential density [H R ~> kg m-2 or kg2 m-5]. real, dimension(SZI_(G),SZK_(GV)), & @@ -908,12 +1037,15 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: v !< Zonal velocities interpolated to h points [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZK0_(GV)), & - intent(in) :: T !< Layer temperatures [degC]. + intent(in) :: T !< Layer temperatures [C ~> degC]. real, dimension(SZI_(G),SZK0_(GV)), & - intent(in) :: S !< Layer salinities [ppt]. + intent(in) :: S !< Layer salinities [S ~> ppt]. real, dimension(SZI_(G),SZK0_(GV)), & intent(in) :: R0 !< Potential density referenced to !! surface pressure [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), & + intent(in) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg-1]. real, dimension(SZI_(G),SZK0_(GV)), & intent(in) :: Rcv !< The coordinate defining potential !! density [R ~> kg m-3]. @@ -921,45 +1053,49 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & intent(in) :: eps !< The negligibly small amount of water !! that will be left in each layer [H ~> m or kg m-2]. real, dimension(SZI_(G)), intent(in) :: dR0_dT !< The partial derivative of R0 with respect to - !! temperature [R degC-1 ~> kg m-3 degC-1]. + !! temperature [R C-1 ~> kg m-3 degC-1]. + real, dimension(SZI_(G)), intent(in) :: dSpV0_dT !< The partial derivative of SpV0 with respect to + !! temperature [R-1 C-1 ~> m3 kg-1 degC-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of Rcv with respect to - !! temperature [R degC-1 ~> kg m-3 degC-1]. + !! temperature [R C-1 ~> kg m-3 degC-1]. real, dimension(SZI_(G)), intent(in) :: dR0_dS !< The partial derivative of R0 with respect to - !! salinity [R ppt-1 ~> kg m-3 ppt-1]. + !! salinity [R S-1 ~> kg m-3 ppt-1]. + real, dimension(SZI_(G)), intent(in) :: dSpV0_dS !< The partial derivative of SpV0 with respect to + !! salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dS !< The partial derivative of Rcv with respect to - !! salinity [R ppt-1 ~> kg m-3 ppt-1]. + !! salinity [R S-1 ~> kg m-3 ppt-1]. real, dimension(SZI_(G)), intent(in) :: netMassInOut !< The net mass flux (if non-Boussinesq) !! or volume flux (if Boussinesq) into the ocean !! within a time step [H ~> m or kg m-2]. (I.e. P+R-E.) real, dimension(SZI_(G)), intent(in) :: netMassOut !< The mass or volume flux out of the ocean !! within a time step [H ~> m or kg m-2]. real, dimension(SZI_(G)), intent(in) :: Net_heat !< The net heating at the surface over a time - !! step [degC H ~> degC m or degC kg m-2]. Any penetrating + !! step [C H ~> degC m or degC kg m-2]. Any penetrating !! shortwave radiation is not included in Net_heat. real, dimension(SZI_(G)), intent(in) :: Net_salt !< The net surface salt flux into the ocean - !! over a time step [ppt H ~> ppt m or ppt kg m-2]. + !! over a time step [S H ~> ppt m or ppt kg m-2]. integer, intent(in) :: nsw !< The number of bands of penetrating !! shortwave radiation. real, dimension(max(nsw,1),SZI_(G)), intent(inout) :: Pen_SW_bnd !< The penetrating shortwave !! heating at the sea surface in each penetrating - !! band [degC H ~> degC m or degC kg m-2]. + !! band [C H ~> degC m or degC kg m-2]. real, dimension(max(nsw,1),SZI_(G),SZK_(GV)), intent(in) :: opacity_band !< The opacity in each band of !! penetrating shortwave radiation [H-1 ~> m-1 or m2 kg-1]. real, dimension(SZI_(G)), intent(out) :: Conv_En !< The buoyant turbulent kinetic energy source - !! due to free convection [Z L2 T-2 ~> m3 s-2]. + !! due to free convection [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G)), intent(out) :: dKE_FC !< The vertically integrated change in kinetic - !! energy due to free convection [Z L2 T-2 ~> m3 s-2]. + !! energy due to free convection [H Z2 T-2 ~> m3 s-2 or J m-2]. integer, intent(in) :: j !< The j-index to work on. integer, dimension(SZI_(G),SZK_(GV)), & intent(in) :: ksort !< The density-sorted k-indices. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(bulkmixedlayer_CS), intent(in) :: CS !< Bulk mixed layer control struct + type(bulkmixedlayer_CS), intent(in) :: CS !< Bulk mixed layer control structure type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any !! available thermodynamic fields. Absent - !! fields have NULL ptrs. + !! fields have NULL pointers. type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any !! possible forcing fields. Unused fields - !! have NULL ptrs. + !! have NULL pointers. real, intent(in) :: dt !< Time increment [T ~> s]. logical, intent(in) :: aggregate_FW_forcing !< If true, the net incoming and !! outgoing surface freshwater fluxes are @@ -977,39 +1113,38 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & real :: SW_trans ! The fraction of shortwave radiation ! that is not absorbed in a layer [nondim]. real :: Pen_absorbed ! The amount of penetrative shortwave radiation - ! that is absorbed in a layer [degC H ~> degC m or degC kg m-2]. + ! that is absorbed in a layer [C H ~> degC m or degC kg m-2]. real :: h_avail ! The thickness in a layer available for ! entrainment [H ~> m or kg m-2]. real :: h_ent ! The thickness from a layer that is entrained [H ~> m or kg m-2]. - real :: T_precip ! The temperature of the precipitation [degC]. - real :: C1_3, C1_6 ! 1/3 and 1/6. - real :: En_fn, Frac, x1 ! Nondimensional temporary variables. - real :: dr, dr0 ! Temporary variables [R H ~> kg m-2 or kg2 m-5]. + real :: T_precip ! The temperature of the precipitation [C ~> degC]. + real :: C1_3, C1_6 ! 1/3 and 1/6 [nondim] + real :: En_fn, Frac, x1 ! Nondimensional temporary variables [nondim]. + real :: dr, dr0 ! Temporary variables [R H ~> kg m-2 or kg2 m-5] or [H R-1 ~> m4 kg-1 or m]. real :: dr_ent, dr_comp ! Temporary variables [R H ~> kg m-2 or kg2 m-5]. real :: dr_dh ! The partial derivative of dr_ent with h_ent [R ~> kg m-3]. - real :: h_min, h_max ! The minimum, maximum, and previous estimates for - real :: h_prev ! h_ent [H ~> m or kg m-2]. + real :: h_min, h_max ! The minimum and maximum estimates for h_ent [H ~> m or kg m-2] + real :: h_prev ! The previous estimate for h_ent [H ~> m or kg m-2] real :: h_evap ! The thickness that is evaporated [H ~> m or kg m-2]. real :: dh_Newt ! The Newton's method estimate of the change in ! h_ent between iterations [H ~> m or kg m-2]. - real :: g_H2_2Rho0 ! Half the gravitational acceleration times the square of + real :: g_H_2Rho0 ! Half the gravitational acceleration times ! the conversion from H to Z divided by the mean density, - ! [L2 Z T-3 H-2 R-1 ~> m4 s-3 kg-1 or m10 s-3 kg-3]. + ! [Z2 T-2 H-1 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]. real :: Angstrom ! The minimum layer thickness [H ~> m or kg m-2]. real :: opacity ! The opacity converted to inverse thickness units [H-1 ~> m-1 or m2 kg-1] real :: sum_Pen_En ! The potential energy change due to penetrating ! shortwave radiation, integrated over a layer ! [H R ~> kg m-2 or kg2 m-5]. real :: Idt ! 1.0/dt [T-1 ~> s-1] - real :: netHeatOut ! accumulated heat content of mass leaving ocean integer :: is, ie, nz, i, k, ks, itt, n real, dimension(max(nsw,1)) :: & - C2, & ! Temporary variable R H-1 ~> kg m-4 or m-1]. + C2, & ! Temporary variable [R H-1 ~> kg m-4 or m-1]. r_SW_top ! Temporary variables [H R ~> kg m-2 or kg2 m-5]. Angstrom = GV%Angstrom_H C1_3 = 1.0/3.0 ; C1_6 = 1.0/6.0 - g_H2_2Rho0 = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * GV%Rho0) + g_H_2Rho0 = (GV%g_Earth_Z_T2 * GV%H_to_Z) / (2.0 * GV%Rho0) Idt = 1.0 / dt is = G%isc ; ie = G%iec ; nz = GV%ke @@ -1053,10 +1188,17 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & Stot(i) = h_ent*S(i,k) + Net_salt(i) uhtot(i) = u(i,1)*netMassIn(i) + u(i,k)*h_ent vhtot(i) = v(i,1)*netMassIn(i) + v(i,k)*h_ent - R0_tot(i) = (h_ent*R0(i,k) + netMassIn(i)*R0(i,1)) + & + if (CS%nonBous_energetics) then + SpV0_tot(i) = (h_ent*SpV0(i,k) + netMassIn(i)*SpV0(i,1)) + & +! dSpV0_dT(i)*netMassIn(i)*(T_precip - T(i,1)) + & + (dSpV0_dT(i)*(Net_heat(i) + Pen_absorbed) - & + dSpV0_dS(i) * (netMassIn(i) * S(i,1) - Net_salt(i))) + else + R0_tot(i) = (h_ent*R0(i,k) + netMassIn(i)*R0(i,1)) + & ! dR0_dT(i)*netMassIn(i)*(T_precip - T(i,1)) + & (dR0_dT(i)*(Net_heat(i) + Pen_absorbed) - & dR0_dS(i) * (netMassIn(i) * S(i,1) - Net_salt(i))) + endif Rcv_tot(i) = (h_ent*Rcv(i,k) + netMassIn(i)*Rcv(i,1)) + & ! dRcv_dT(i)*netMassIn(i)*(T_precip - T(i,1)) + & (dRcv_dT(i)*(Net_heat(i) + Pen_absorbed) - & @@ -1064,11 +1206,12 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & Conv_En(i) = 0.0 ; dKE_FC(i) = 0.0 if (associated(fluxes%heat_content_massin)) & fluxes%heat_content_massin(i,j) = fluxes%heat_content_massin(i,j) + & - T_precip * netMassIn(i) * GV%H_to_RZ * fluxes%C_p * Idt + T_precip * netMassIn(i) * GV%H_to_RZ * tv%C_p * Idt if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & T_precip * netMassIn(i) * GV%H_to_RZ else ! This is a massless column, but zero out the summed variables anyway for safety. - htot(i) = 0.0 ; Ttot(i) = 0.0 ; Stot(i) = 0.0 ; R0_tot(i) = 0.0 ; Rcv_tot = 0.0 + htot(i) = 0.0 ; Ttot(i) = 0.0 ; Stot(i) = 0.0 ; Rcv_tot = 0.0 + R0_tot(i) = 0.0 ; SpV0_tot(i) = 0.0 uhtot(i) = 0.0 ; vhtot(i) = 0.0 ; Conv_En(i) = 0.0 ; dKE_FC(i) = 0.0 endif ; enddo @@ -1086,7 +1229,11 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & h(i,k) = h(i,k) - h_ent d_eb(i,k) = d_eb(i,k) - h_ent - R0_tot(i) = R0_tot(i) + h_ent*R0(i,k) + if (CS%nonBous_energetics) then + SpV0_tot(i) = SpV0_tot(i) + h_ent*SpV0(i,k) + else + R0_tot(i) = R0_tot(i) + h_ent*R0(i,k) + endif uhtot(i) = uhtot(i) + h_ent*u(i,k) vhtot(i) = vhtot(i) + h_ent*v(i,k) @@ -1110,17 +1257,21 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & endif Stot(i) = Stot(i) + h_evap*S(i,k) - R0_tot(i) = R0_tot(i) + dR0_dS(i)*h_evap*S(i,k) + if (CS%nonBous_energetics) then + SpV0_tot(i) = SpV0_tot(i) + dSpV0_dS(i)*h_evap*S(i,k) + else + R0_tot(i) = R0_tot(i) + dR0_dS(i)*h_evap*S(i,k) + endif Rcv_tot(i) = Rcv_tot(i) + dRcv_dS(i)*h_evap*S(i,k) d_eb(i,k) = d_eb(i,k) - h_evap ! smg: when resolve the A=B code, we will set - ! heat_content_massout = heat_content_massout - T(i,k)*h_evap*GV%H_to_RZ*fluxes%C_p*Idt + ! heat_content_massout = heat_content_massout - T(i,k)*h_evap*GV%H_to_RZ*tv%C_p*Idt ! by uncommenting the lines here. ! we will also then completely remove TempXpme from the model. if (associated(fluxes%heat_content_massout)) & fluxes%heat_content_massout(i,j) = fluxes%heat_content_massout(i,j) - & - T(i,k)*h_evap*GV%H_to_RZ * fluxes%C_p * Idt + T(i,k)*h_evap*GV%H_to_RZ * tv%C_p * Idt if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) - & T(i,k)*h_evap*GV%H_to_RZ @@ -1129,14 +1280,25 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & ! The following section calculates how much fluid will be entrained. h_avail = h(i,k) - eps(i,k) if (h_avail > 0.0) then - dr = R0_tot(i) - htot(i)*R0(i,k) h_ent = 0.0 - dr0 = dr - do n=1,nsw ; if (Pen_SW_bnd(n,i) > 0.0) then - dr0 = dr0 - (dR0_dT(i)*Pen_SW_bnd(n,i)) * & - opacity_band(n,i,k)*htot(i) - endif ; enddo + if (CS%nonBous_energetics) then + dr = htot(i)*SpV0(i,k) - SpV0_tot(i) + + dr0 = dr + do n=1,nsw ; if (Pen_SW_bnd(n,i) > 0.0) then + dr0 = dr0 + (dSpV0_dT(i)*Pen_SW_bnd(n,i)) * & + opacity_band(n,i,k)*htot(i) + endif ; enddo + else + dr = R0_tot(i) - htot(i)*R0(i,k) + + dr0 = dr + do n=1,nsw ; if (Pen_SW_bnd(n,i) > 0.0) then + dr0 = dr0 - (dR0_dT(i)*Pen_SW_bnd(n,i)) * & + opacity_band(n,i,k)*htot(i) + endif ; enddo + endif ! Some entrainment will occur from this layer. if (dr0 > 0.0) then @@ -1146,8 +1308,13 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & ! density averaged over the mixed layer and that layer. opacity = opacity_band(n,i,k) SW_trans = exp(-h_avail*opacity) - dr_comp = dr_comp + (dR0_dT(i)*Pen_SW_bnd(n,i)) * & - ((1.0 - SW_trans) - opacity*(htot(i)+h_avail)*SW_trans) + if (CS%nonBous_energetics) then + dr_comp = dr_comp - (dSpV0_dT(i)*Pen_SW_bnd(n,i)) * & + ((1.0 - SW_trans) - opacity*(htot(i)+h_avail)*SW_trans) + else + dr_comp = dr_comp + (dR0_dT(i)*Pen_SW_bnd(n,i)) * & + ((1.0 - SW_trans) - opacity*(htot(i)+h_avail)*SW_trans) + endif endif ; enddo if (dr_comp >= 0.0) then ! The entire layer is entrained. @@ -1164,7 +1331,11 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & h_min = 0.0 ; h_max = h_avail do n=1,nsw - r_SW_top(n) = dR0_dT(i) * Pen_SW_bnd(n,i) + if (CS%nonBous_energetics) then + r_SW_top(n) = -dSpV0_dT(i) * Pen_SW_bnd(n,i) + else + r_SW_top(n) = dR0_dT(i) * Pen_SW_bnd(n,i) + endif C2(n) = r_SW_top(n) * opacity_band(n,i,k)**2 enddo do itt=1,10 @@ -1211,27 +1382,40 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & En_fn = ((opacity*htot(i) + 2.0) * & ((1.0-SW_trans) / x1) - 1.0 + SW_trans) endif - sum_Pen_En = sum_Pen_En - (dR0_dT(i)*Pen_SW_bnd(n,i)) * En_fn + if (CS%nonBous_energetics) then + sum_Pen_En = sum_Pen_En + (dSpV0_dT(i)*Pen_SW_bnd(n,i)) * En_fn + else + sum_Pen_En = sum_Pen_En - (dR0_dT(i)*Pen_SW_bnd(n,i)) * En_fn + endif Pen_absorbed = Pen_absorbed + Pen_SW_bnd(n,i) * (1.0 - SW_trans) Pen_SW_bnd(n,i) = Pen_SW_bnd(n,i) * SW_trans endif ; enddo - Conv_En(i) = Conv_En(i) + g_H2_2Rho0 * h_ent * & - ( (R0_tot(i) - R0(i,k)*htot(i)) + sum_Pen_En ) + if (CS%nonBous_energetics) then + ! This and the other energy calculations assume that specific volume is + ! conserved during mixing, which ignores certain thermobaric contributions. + Conv_En(i) = Conv_En(i) + 0.5 * (GV%g_Earth_Z_T2 * GV%H_to_RZ) * h_ent * & + ( (SpV0(i,k)*htot(i) - SpV0_tot(i)) + sum_Pen_En ) + SpV0_tot(i) = SpV0_tot(i) + (h_ent * SpV0(i,k) + Pen_absorbed*dSpV0_dT(i)) + else + Conv_En(i) = Conv_En(i) + g_H_2Rho0 * h_ent * & + ( (R0_tot(i) - R0(i,k)*htot(i)) + sum_Pen_En ) + R0_tot(i) = R0_tot(i) + (h_ent * R0(i,k) + Pen_absorbed*dR0_dT(i)) + endif - R0_tot(i) = R0_tot(i) + (h_ent * R0(i,k) + Pen_absorbed*dR0_dT(i)) Stot(i) = Stot(i) + h_ent * S(i,k) Ttot(i) = Ttot(i) + (h_ent * T(i,k) + Pen_absorbed) Rcv_tot(i) = Rcv_tot(i) + (h_ent * Rcv(i,k) + Pen_absorbed*dRcv_dT(i)) endif ! dr0 > 0.0 - if (h_ent > 0.0) then - if (htot(i) > 0.0) & + + if ((h_ent > 0.0) .and. (htot(i) > 0.0)) & dKE_FC(i) = dKE_FC(i) + CS%bulk_Ri_convective * 0.5 * & - ((GV%H_to_Z*h_ent) / (htot(i)*(h_ent+htot(i)))) * & - ((uhtot(i)-u(i,k)*htot(i))**2 + (vhtot(i)-v(i,k)*htot(i))**2) + ((h_ent) / (htot(i)*(h_ent+htot(i)))) * & + (((uhtot(i)-u(i,k)*htot(i))**2) + ((vhtot(i)-v(i,k)*htot(i))**2)) + if (h_ent > 0.0) then htot(i) = htot(i) + h_ent h(i,k) = h(i,k) - h_ent d_eb(i,k) = d_eb(i,k) - h_ent @@ -1242,7 +1426,6 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & endif endif - endif ! h_avail>0 endif ; enddo ! i loop enddo ! k loop @@ -1251,8 +1434,8 @@ end subroutine mixedlayer_convection !> This subroutine determines the TKE available at the depth of free !! convection to drive mechanical entrainment. -subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, & - TKE, TKE_river, Idecay_len_TKE, cMKE, dt, Idt_diag, & +subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_FC, dKE_CA, & + TKE, TKE_river, Idecay_len_TKE, cMKE, tv, dt, Idt_diag, & j, ksort, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -1263,60 +1446,68 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, !! adjustment [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to any !! possible forcing fields. Unused fields - !! have NULL ptrs. + !! have NULL pointers. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: U_star_2d !< The wind friction velocity, calculated + !! using the Boussinesq reference density or + !! the time-evolving surface density in + !! non-Boussinesq mode [Z T-1 ~> m s-1] real, dimension(SZI_(G)), intent(inout) :: Conv_En !< The buoyant turbulent kinetic energy source - !! due to free convection [Z L2 T-2 ~> m3 s-2]. + !! due to free convection [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G)), intent(in) :: dKE_FC !< The vertically integrated change in !! kinetic energy due to free convection - !! [Z L2 T-2 ~> m3 s-2]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: cTKE !< The buoyant turbulent kinetic energy !! source due to convective adjustment - !! [Z L2 T-2 ~> m3 s-2]. + !! [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: dKE_CA !< The vertically integrated change in !! kinetic energy due to convective - !! adjustment [Z L2 T-2 ~> m3 s-2]. + !! adjustment [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G)), intent(out) :: TKE !< The turbulent kinetic energy available for - !! mixing over a time step [Z L2 T-2 ~> m3 s-2]. + !! mixing over a time step [H Z2 T-2 ~> m3 s-2 or J m-2] real, dimension(SZI_(G)), intent(out) :: Idecay_len_TKE !< The inverse of the vertical decay !! scale for TKE [H-1 ~> m-1 or m2 kg-1]. real, dimension(SZI_(G)), intent(in) :: TKE_river !< The source of turbulent kinetic energy !! available for driving mixing at river mouths - !! [Z L2 T-3 ~> m3 s-3]. + !! [H Z2 T-3 ~> m3 s-3 or W m-2]. real, dimension(2,SZI_(G)), intent(out) :: cMKE !< Coefficients of HpE and HpE^2 in !! calculating the denominator of MKE_rate, !! [H-1 ~> m-1 or m2 kg-1] and [H-2 ~> m-2 or m4 kg-2]. + type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any + !! available thermodynamic fields. real, intent(in) :: dt !< The time step [T ~> s]. real, intent(in) :: Idt_diag !< The inverse of the accumulated diagnostic !! time interval [T-1 ~> s-1]. integer, intent(in) :: j !< The j-index to work on. integer, dimension(SZI_(G),SZK_(GV)), & - intent(in) :: ksort !< The density-sorted k-indicies. - type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control struct + intent(in) :: ksort !< The density-sorted k-indices. + type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control structure ! This subroutine determines the TKE available at the depth of free ! convection to drive mechanical entrainment. ! Local variables - real :: dKE_conv ! The change in mean kinetic energy due to all convection [Z L2 T-2 ~> m3 s-2]. + real :: dKE_conv ! The change in mean kinetic energy due to all convection [H Z2 T-2 ~> m3 s-2 or J m-2]. real :: nstar_FC ! The effective efficiency with which the energy released by ! free convection is converted to TKE, often ~0.2 [nondim]. real :: nstar_CA ! The effective efficiency with which the energy released by ! convective adjustment is converted to TKE, often ~0.2 [nondim]. real :: TKE_CA ! The potential energy released by convective adjustment if - ! that release is positive [Z L2 T-2 ~> m3 s-2]. + ! that release is positive [H Z2 T-2 ~> m3 s-2 or J m-2]. real :: MKE_rate_CA ! MKE_rate for convective adjustment [nondim], 0 to 1. real :: MKE_rate_FC ! MKE_rate for free convection [nondim], 0 to 1. - real :: totEn_Z ! The total potential energy released by convection, [Z3 T-2 ~> m3 s-2]. + real :: totEn_Z ! The total potential energy released by convection, [H Z2 T-2 ~> m3 s-2 or J m-2]. real :: Ih ! The inverse of a thickness [H-1 ~> m-1 or m2 kg-1]. real :: exp_kh ! The nondimensional decay of TKE across a layer [nondim]. real :: absf ! The absolute value of f averaged to thickness points [T-1 ~> s-1]. real :: U_star ! The friction velocity [Z T-1 ~> m s-1]. - real :: absf_Ustar ! The absolute value of f divided by U_star [Z-1 ~> m-1]. - real :: wind_TKE_src ! The surface wind source of TKE [Z L2 T-3 ~> m3 s-3]. + real :: absf_Ustar ! The absolute value of f divided by U_star converted to thickness units [H-1 ~> m-1 or m2 kg-1] + real :: wind_TKE_src ! The surface wind source of TKE [H Z2 T-3 ~> m3 s-3 or W m-2]. real :: diag_wt ! The ratio of the current timestep to the diagnostic ! timestep (which may include 2 calls) [nondim]. + real :: H_to_Z ! The thickness to depth conversion factor, which in non-Boussinesq mode is + ! based on the layer-averaged specific volume [Z H-1 ~> nondim or m3 kg-1] integer :: is, ie, nz, i is = G%isc ; ie = G%iec ; nz = GV%ke @@ -1324,7 +1515,14 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, if (CS%omega_frac >= 1.0) absf = 2.0*CS%omega do i=is,ie - U_star = fluxes%ustar(i,j) + U_star = U_star_2d(i,j) + + if (GV%Boussinesq .or. (.not.allocated(tv%SpV_avg))) then + H_to_Z = GV%H_to_Z + else + H_to_Z = GV%H_to_RZ * tv%SpV_avg(i,j,1) + endif + if (associated(fluxes%ustar_shelf) .and. associated(fluxes%frac_shelf_h)) then if (fluxes%frac_shelf_h(i,j) > 0.0) & U_star = (1.0 - fluxes%frac_shelf_h(i,j)) * U_star + & @@ -1332,14 +1530,15 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, endif if (U_star < CS%ustar_min) U_star = CS%ustar_min + if (CS%omega_frac < 1.0) then absf = 0.25*((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I-1,J)))) if (CS%omega_frac > 0.0) & absf = sqrt(CS%omega_frac*4.0*CS%omega**2 + (1.0-CS%omega_frac)*absf**2) endif - absf_Ustar = absf / U_star - Idecay_len_TKE(i) = (absf_Ustar * CS%TKE_decay) * GV%H_to_Z + absf_Ustar = H_to_Z * absf / U_star + Idecay_len_TKE(i) = absf_Ustar * CS%TKE_decay ! The first number in the denominator could be anywhere up to 16. The ! value of 3 was chosen to minimize the time-step dependence of the amount @@ -1347,12 +1546,12 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, ! the equatorial areas. Although it is not cast as a parameter, it should ! be considered an empirical parameter, and it might depend strongly on the ! number of sublayers in the mixed layer and their locations. -! The 0.41 is VonKarman's constant. This equation assumes that small & large -! scales contribute to mixed layer deepening at similar rates, even though -! small scales are dissipated more rapidly (implying they are less efficient). -! Ih = 1.0/(16.0*0.41*U_star*dt) - Ih = GV%H_to_Z/(3.0*0.41*U_star*dt) - cMKE(1,i) = 4.0 * Ih ; cMKE(2,i) = (absf_Ustar*GV%H_to_Z) * Ih +! This equation assumes that small & large scales contribute to mixed layer +! deepening at similar rates, even though small scales are dissipated more +! rapidly (implying they are less efficient). +! Ih = H_to_Z / (16.0*CS%vonKar*U_star*dt) + Ih = H_to_Z / (3.0*CS%vonKar*U_star*dt) + cMKE(1,i) = 4.0 * Ih ; cMKE(2,i) = absf_Ustar * Ih if (Idecay_len_TKE(i) > 0.0) then exp_kh = exp(-htot(i)*Idecay_len_TKE(i)) @@ -1366,11 +1565,11 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, if (Conv_En(i) < 0.0) Conv_En(i) = 0.0 if (cTKE(i,1) > 0.0) then ; TKE_CA = cTKE(i,1) ; else ; TKE_CA = 0.0 ; endif if ((htot(i) >= h_CA(i)) .or. (TKE_CA == 0.0)) then - totEn_Z = US%L_to_Z**2 * (Conv_En(i) + TKE_CA) + totEn_Z = (Conv_En(i) + TKE_CA) if (totEn_Z > 0.0) then nstar_FC = CS%nstar * totEn_Z / (totEn_Z + 0.2 * & - sqrt(0.5 * dt * (absf*(htot(i)*GV%H_to_Z))**3 * totEn_Z)) + sqrt(0.5 * dt * (H_to_Z**2*(absf*htot(i))**3) * totEn_Z)) else nstar_FC = CS%nstar endif @@ -1378,17 +1577,17 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, else ! This reconstructs the Buoyancy flux within the topmost htot of water. if (Conv_En(i) > 0.0) then - totEn_Z = US%L_to_Z**2 * (Conv_En(i) + TKE_CA * (htot(i) / h_CA(i)) ) + totEn_Z = (Conv_En(i) + TKE_CA * (htot(i) / h_CA(i)) ) nstar_FC = CS%nstar * totEn_Z / (totEn_Z + 0.2 * & - sqrt(0.5 * dt * (absf*(htot(i)*GV%H_to_Z))**3 * totEn_Z)) + sqrt(0.5 * dt * (H_to_Z**2*(absf*htot(i))**3) * totEn_Z)) else nstar_FC = CS%nstar endif - totEn_Z = US%L_to_Z**2 * (Conv_En(i) + TKE_CA) + totEn_Z = (Conv_En(i) + TKE_CA) if (TKE_CA > 0.0) then nstar_CA = CS%nstar * totEn_Z / (totEn_Z + 0.2 * & - sqrt(0.5 * dt * (absf*(h_CA(i)*GV%H_to_Z))**3 * totEn_Z)) + sqrt(0.5 * dt * (H_to_Z**2*(absf*h_CA(i))**3) * totEn_Z)) else nstar_CA = CS%nstar endif @@ -1410,15 +1609,25 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, dKE_conv = dKE_CA(i,1) * MKE_rate_CA + dKE_FC(i) * MKE_rate_FC ! At this point, it is assumed that cTKE is positive and stored in TKE_CA! ! Note: Removed factor of 2 in u*^3 terms. - TKE(i) = (dt*CS%mstar)*((US%Z_to_L**2*(U_star*U_Star*U_Star))*exp_kh) + & - (exp_kh * dKE_conv + nstar_FC*Conv_En(i) + nstar_CA * TKE_CA) + if (GV%Boussinesq .or. GV%semi_Boussinesq .or. .not.(associated(fluxes%tau_mag))) then + TKE(i) = (dt*CS%mstar)*((GV%Z_to_H*(U_star*U_Star*U_Star))*exp_kh) + & + (exp_kh * dKE_conv + nstar_FC*Conv_En(i) + nstar_CA * TKE_CA) + else + ! Note that GV%Z_to_H*U_star**3 = GV%RZ_to_H * fluxes%tau_mag(i,j) * U_star + TKE(i) = (dt*CS%mstar) * ((GV%RZ_to_H * fluxes%tau_mag(i,j) * U_star)*exp_kh) + & + (exp_kh * dKE_conv + nstar_FC*Conv_En(i) + nstar_CA * TKE_CA) + endif if (CS%do_rivermix) then ! Add additional TKE at river mouths TKE(i) = TKE(i) + TKE_river(i)*dt*exp_kh endif if (CS%TKE_diagnostics) then - wind_TKE_src = CS%mstar*(US%Z_to_L**2*U_star*U_Star*U_Star) * diag_wt + if (GV%Boussinesq .or. GV%semi_Boussinesq .or. .not.(associated(fluxes%tau_mag))) then + wind_TKE_src = CS%mstar*(GV%Z_to_H*U_star*U_Star*U_Star) * diag_wt + else + wind_TKE_src = CS%mstar*(GV%RZ_to_H * fluxes%tau_mag(i,j) * U_star) * diag_wt + endif CS%diag_TKE_wind(i,j) = CS%diag_TKE_wind(i,j) + & ( wind_TKE_src + TKE_river(i) * diag_wt ) CS%diag_TKE_RiBulk(i,j) = CS%diag_TKE_RiBulk(i,j) + dKE_conv*Idt_diag @@ -1437,8 +1646,8 @@ end subroutine find_starting_TKE !> This subroutine calculates mechanically driven entrainment. subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & - R0_tot, Rcv_tot, u, v, T, S, R0, Rcv, eps, & - dR0_dT, dRcv_dT, cMKE, Idt_diag, nsw, & + R0_tot, SpV0_tot, Rcv_tot, u, v, T, S, R0, SpV0, Rcv, eps, & + dR0_dT, dSpV0_dT, dRcv_dT, cMKE, Idt_diag, nsw, & Pen_SW_bnd, opacity_band, TKE, & Idecay_len_TKE, j, ksort, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. @@ -1450,17 +1659,19 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & intent(inout) :: d_eb !< The downward increase across a layer in the !! layer in the entrainment from below [H ~> m or kg m-2]. !! Positive values go with mass gain by a layer. - real, dimension(SZI_(G)), intent(inout) :: htot !< The accumlated mixed layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(inout) :: htot !< The accumulated mixed layer thickness [H ~> m or kg m-2]. real, dimension(SZI_(G)), intent(inout) :: Ttot !< The depth integrated mixed layer temperature - !! [degC H ~> degC m or degC kg m-2]. + !! [C H ~> degC m or degC kg m-2]. real, dimension(SZI_(G)), intent(inout) :: Stot !< The depth integrated mixed layer salinity - !! [ppt H ~> ppt m or ppt kg m-2]. + !! [S H ~> ppt m or ppt kg m-2]. real, dimension(SZI_(G)), intent(inout) :: uhtot !< The depth integrated mixed layer zonal !! velocity [H L T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZI_(G)), intent(inout) :: vhtot !< The integrated mixed layer meridional !! velocity [H L T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZI_(G)), intent(inout) :: R0_tot !< The integrated mixed layer potential density !! referenced to 0 pressure [H R ~> kg m-2 or kg2 m-5]. + real, dimension(SZI_(G)), intent(inout) :: SpV0_tot !< The integrated mixed layer specific volume referenced + !! to 0 pressure [H R-1 ~> m4 kg-1 or m]. real, dimension(SZI_(G)), intent(inout) :: Rcv_tot !< The integrated mixed layer coordinate variable !! potential density [H R ~> kg m-2 or kg2 m-5]. real, dimension(SZI_(G),SZK_(GV)), & @@ -1468,12 +1679,15 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: v !< Zonal velocities interpolated to h points [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZK0_(GV)), & - intent(in) :: T !< Layer temperatures [degC]. + intent(in) :: T !< Layer temperatures [C ~> degC]. real, dimension(SZI_(G),SZK0_(GV)), & - intent(in) :: S !< Layer salinities [ppt]. + intent(in) :: S !< Layer salinities [S ~> ppt]. real, dimension(SZI_(G),SZK0_(GV)), & intent(in) :: R0 !< Potential density referenced to !! surface pressure [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), & + intent(in) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg-1]. real, dimension(SZI_(G),SZK0_(GV)), & intent(in) :: Rcv !< The coordinate defining potential !! density [R ~> kg m-3]. @@ -1481,9 +1695,11 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & intent(in) :: eps !< The negligibly small amount of water !! that will be left in each layer [H ~> m or kg m-2]. real, dimension(SZI_(G)), intent(in) :: dR0_dT !< The partial derivative of R0 with respect to - !! temperature [R degC-1 ~> kg m-3 degC-1]. + !! temperature [R C-1 ~> kg m-3 degC-1]. + real, dimension(SZI_(G)), intent(in) :: dSpV0_dT !< The partial derivative of SpV0 with respect to + !! temperature [R-1 C-1 ~> m3 kg-1 degC-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of Rcv with respect to - !! temperature [R degC-1 ~> kg m-3 degC-1]. + !! temperature [R C-1 ~> kg m-3 degC-1]. real, dimension(2,SZI_(G)), intent(in) :: cMKE !< Coefficients of HpE and HpE^2 used in calculating the !! denominator of MKE_rate; the two elements have differing !! units of [H-1 ~> m-1 or m2 kg-1] and [H-2 ~> m-2 or m4 kg-2]. @@ -1493,25 +1709,25 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & !! shortwave radiation. real, dimension(max(nsw,1),SZI_(G)), intent(inout) :: Pen_SW_bnd !< The penetrating shortwave !! heating at the sea surface in each penetrating - !! band [degC H ~> degC m or degC kg m-2]. + !! band [C H ~> degC m or degC kg m-2]. real, dimension(max(nsw,1),SZI_(G),SZK_(GV)), intent(in) :: opacity_band !< The opacity in each band of !! penetrating shortwave radiation [H-1 ~> m-1 or m2 kg-1]. real, dimension(SZI_(G)), intent(inout) :: TKE !< The turbulent kinetic energy !! available for mixing over a time - !! step [Z L2 T-2 ~> m3 s-2]. + !! step [H Z2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G)), intent(inout) :: Idecay_len_TKE !< The vertical TKE decay rate [H-1 ~> m-1 or m2 kg-1]. integer, intent(in) :: j !< The j-index to work on. integer, dimension(SZI_(G),SZK_(GV)), & - intent(in) :: ksort !< The density-sorted k-indicies. - type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control struct + intent(in) :: ksort !< The density-sorted k-indices. + type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control structure ! This subroutine calculates mechanically driven entrainment. ! Local variables real :: SW_trans ! The fraction of shortwave radiation that is not - ! absorbed in a layer, nondimensional. + ! absorbed in a layer [nondim]. real :: Pen_absorbed ! The amount of penetrative shortwave radiation - ! that is absorbed in a layer [degC H ~> degC m or degC kg m-2]. + ! that is absorbed in a layer [C H ~> degC m or degC kg m-2]. real :: h_avail ! The thickness in a layer available for entrainment [H ~> m or kg m-2]. real :: h_ent ! The thickness from a layer that is entrained [H ~> m or kg m-2]. real :: h_min, h_max ! Limits on the solution for h_ent [H ~> m or kg m-2]. @@ -1519,45 +1735,45 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & ! h_ent between iterations [H ~> m or kg m-2]. real :: MKE_rate ! The fraction of the energy in resolved shears ! within the mixed layer that will be eliminated - ! within a timestep, nondim, 0 to 1. + ! within a timestep [nondim], 0 to 1. real :: HpE ! The current thickness plus entrainment [H ~> m or kg m-2]. real :: g_H_2Rho0 ! Half the gravitational acceleration times the ! conversion from H to m divided by the mean density, - ! in [L2 T-2 H-1 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]. + ! in [Z2 T-2 H-1 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]. real :: TKE_full_ent ! The TKE remaining if a layer is fully entrained - ! [Z L2 T-2 ~> m3 s-2]. + ! [H Z2 T-2 ~> m3 s-2 or J m-2]. real :: dRL ! Work required to mix water from the next layer - ! across the mixed layer [L2 T-2 ~> m2 s-2]. + ! across the mixed layer [Z2 T-2 ~> m2 s-2]. real :: Pen_En_Contrib ! Penetrating SW contributions to the changes in - ! TKE, divided by layer thickness in m [L2 T-2 ~> m2 s-2]. - real :: Cpen1 ! A temporary variable [L2 T-2 ~> m2 s-2]. + ! TKE, divided by layer thickness in m [Z2 T-2 ~> m2 s-2]. + real :: Cpen1 ! A temporary variable [Z2 T-2 ~> m2 s-2]. real :: dMKE ! A temporary variable related to the release of mean - ! kinetic energy [H Z L2 T-2 ~> m4 s-2 or kg m s-2] - real :: TKE_ent ! The TKE that remains if h_ent were entrained [Z L2 T-2 ~> m3 s-2]. + ! kinetic energy [H2 Z2 T-2 ~> m4 s-2 or kg2 m-2 s-2] + real :: TKE_ent ! The TKE that remains if h_ent were entrained [H Z2 T-2 ~> m3 s-2 or J m-2] real :: TKE_ent1 ! The TKE that would remain, without considering the - ! release of mean kinetic energy [Z L2 T-2 ~> m3 s-2]. - real :: dTKE_dh ! The partial derivative of TKE with h_ent [Z L2 T-2 H-1 ~> m2 s-2 or m5 s-2 kg-1]. + ! release of mean kinetic energy [H Z2 T-2 ~> m3 s-2 or J m-2] + real :: dTKE_dh ! The partial derivative of TKE with h_ent [Z2 T-2 ~> m2 s-2] real :: Pen_dTKE_dh_Contrib ! The penetrating shortwave contribution to - ! dTKE_dh [L2 T-2 ~> m2 s-2]. + ! dTKE_dh [Z2 T-2 ~> m2 s-2]. real :: EF4_val ! The result of EF4() (see later) [H-1 ~> m-1 or m2 kg-1]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: dEF4_dh ! The partial derivative of EF4 with h [H-2 ~> m-2 or m4 kg-2]. - real :: Pen_En1 ! A nondimensional temporary variable. - real :: kh, exp_kh ! Nondimensional temporary variables related to the - real :: f1_kh ! fractional decay of TKE across a layer. - real :: x1, e_x1 ! Nondimensional temporary variables related to - real :: f1_x1, f2_x1 ! the relative decay of TKE and SW radiation across - real :: f3_x1 ! a layer, and exponential-related functions of x1. + real :: Pen_En1 ! A nondimensional temporary variable [nondim]. + real :: kh, exp_kh, f1_kh ! Nondimensional temporary variables related to the + ! fractional decay of TKE across a layer [nondim]. + real :: x1, e_x1 ! Nondimensional temporary variables related to the relative decay + ! of TKE and SW radiation across a layer [nondim] + real :: f1_x1, f2_x1, f3_x1 ! Exponential-related functions of x1 [nondim]. real :: E_HxHpE ! Entrainment divided by the product of the new and old ! thicknesses [H-1 ~> m-1 or m2 kg-1]. real :: Hmix_min ! The minimum mixed layer depth [H ~> m or kg m-2]. - real :: opacity - real :: C1_3, C1_6, C1_24 ! 1/3, 1/6, and 1/24. + real :: opacity ! The opacity of a layer in a band of shortwave radiation [H-1 ~> m-1 or m2 kg-1] + real :: C1_3, C1_6, C1_24 ! 1/3, 1/6, and 1/24. [nondim] integer :: is, ie, nz, i, k, ks, itt, n C1_3 = 1.0/3.0 ; C1_6 = 1.0/6.0 ; C1_24 = 1.0/24.0 - g_H_2Rho0 = (GV%g_Earth * GV%H_to_Z) / (2.0 * GV%Rho0) + g_H_2Rho0 = (GV%g_Earth_Z_T2 * GV%H_to_Z) / (2.0 * GV%Rho0) Hmix_min = CS%Hmix_min h_neglect = GV%H_subroundoff is = G%isc ; ie = G%iec ; nz = GV%ke @@ -1569,9 +1785,13 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & h_avail = h(i,k) - eps(i,k) if ((h_avail > 0.) .and. ((TKE(i) > 0.) .or. (htot(i) < Hmix_min))) then - dRL = g_H_2Rho0 * (R0(i,k)*htot(i) - R0_tot(i) ) - dMKE = (GV%H_to_Z * CS%bulk_Ri_ML) * 0.5 * & - ((uhtot(i)-u(i,k)*htot(i))**2 + (vhtot(i)-v(i,k)*htot(i))**2) + if (CS%nonBous_energetics) then + dRL = 0.5 * (GV%g_Earth_Z_T2 * GV%H_to_RZ) * (SpV0_tot(i) - SpV0(i,k)*htot(i)) + else + dRL = g_H_2Rho0 * (R0(i,k)*htot(i) - R0_tot(i) ) + endif + dMKE = CS%bulk_Ri_ML * 0.5 * & + (((uhtot(i)-u(i,k)*htot(i))**2) + ((vhtot(i)-v(i,k)*htot(i))**2)) ! Find the TKE that would remain if the entire layer were entrained. kh = Idecay_len_TKE(i)*h_avail ; exp_kh = exp(-kh) @@ -1609,14 +1829,19 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & Pen_En1 = exp_kh * ((1.0+opacity*htot(i))*f1_x1 + & opacity*h_avail*f2_x1) endif - Pen_En_Contrib = Pen_En_Contrib + & - (g_H_2Rho0*dR0_dT(i)*Pen_SW_bnd(n,i)) * (Pen_En1 - f1_kh) + if (CS%nonBous_energetics) then + Pen_En_Contrib = Pen_En_Contrib - & + (0.5 * (GV%g_Earth_Z_T2 * GV%H_to_RZ) * dSpV0_dT(i)*Pen_SW_bnd(n,i)) * (Pen_En1 - f1_kh) + else + Pen_En_Contrib = Pen_En_Contrib + & + (g_H_2Rho0*dR0_dT(i)*Pen_SW_bnd(n,i)) * (Pen_En1 - f1_kh) + endif endif ; enddo HpE = htot(i)+h_avail MKE_rate = 1.0/(1.0 + (cMKE(1,i)*HpE + cMKE(2,i)*HpE**2)) EF4_val = EF4(htot(i)+h_neglect,h_avail,Idecay_len_TKE(i)) - TKE_full_ent = (exp_kh*TKE(i) - (h_avail*GV%H_to_Z)*(dRL*f1_kh + Pen_En_Contrib)) + & + TKE_full_ent = (exp_kh*TKE(i) - h_avail*(dRL*f1_kh + Pen_En_Contrib)) + & MKE_rate*dMKE*EF4_val if ((TKE_full_ent >= 0.0) .or. (h_avail+htot(i) <= Hmix_min)) then ! The layer will be fully entrained. @@ -1625,19 +1850,18 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & if (CS%TKE_diagnostics) then E_HxHpE = h_ent / ((htot(i)+h_neglect)*(htot(i)+h_ent+h_neglect)) CS%diag_TKE_mech_decay(i,j) = CS%diag_TKE_mech_decay(i,j) + & - Idt_diag * ((exp_kh-1.0)* TKE(i) + (h_ent*GV%H_to_Z)*dRL*(1.0-f1_kh) + & + Idt_diag * ((exp_kh-1.0)* TKE(i) + h_ent*dRL*(1.0-f1_kh) + & MKE_rate*dMKE*(EF4_val-E_HxHpE)) - CS%diag_TKE_mixing(i,j) = CS%diag_TKE_mixing(i,j) - & - Idt_diag*(GV%H_to_Z*h_ent)*dRL + CS%diag_TKE_mixing(i,j) = CS%diag_TKE_mixing(i,j) - Idt_diag*h_ent*dRL CS%diag_TKE_pen_SW(i,j) = CS%diag_TKE_pen_SW(i,j) - & - Idt_diag*(GV%H_to_Z*h_ent)*Pen_En_Contrib + Idt_diag*h_ent*Pen_En_Contrib CS%diag_TKE_RiBulk(i,j) = CS%diag_TKE_RiBulk(i,j) + & Idt_diag*MKE_rate*dMKE*E_HxHpE endif TKE(i) = TKE_full_ent - !### The minimum TKE value in this line may be problematically small. - if (TKE(i) <= 0.0) TKE(i) = 1.0e-150*US%m_to_Z*US%m_s_to_L_T**2 + + if (TKE(i) <= 0.0) TKE(i) = CS%mech_TKE_floor else ! The layer is only partially entrained. The amount that will be ! entrained is determined iteratively. No further layers will be @@ -1690,21 +1914,25 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & Pen_En1 = exp_kh * ((1.0+opacity*htot(i))*f1_x1 + & opacity*h_ent*f2_x1) endif - Cpen1 = g_H_2Rho0*dR0_dT(i)*Pen_SW_bnd(n,i) + if (CS%nonBous_energetics) then + Cpen1 = -0.5 * (GV%g_Earth_Z_T2 * GV%H_to_RZ) * dSpV0_dT(i) * Pen_SW_bnd(n,i) + else + Cpen1 = g_H_2Rho0 * dR0_dT(i) * Pen_SW_bnd(n,i) + endif Pen_En_Contrib = Pen_En_Contrib + Cpen1*(Pen_En1 - f1_kh) Pen_dTKE_dh_Contrib = Pen_dTKE_dh_Contrib + & Cpen1*((1.0-SW_trans) - opacity*(htot(i) + h_ent)*SW_trans) endif ; enddo ! (Pen_SW_bnd(n,i) > 0.0) - TKE_ent1 = exp_kh* TKE(i) - (h_ent*GV%H_to_Z)*(dRL*f1_kh + Pen_En_Contrib) + TKE_ent1 = exp_kh* TKE(i) - h_ent*(dRL*f1_kh + Pen_En_Contrib) EF4_val = EF4(htot(i)+h_neglect,h_ent,Idecay_len_TKE(i),dEF4_dh) HpE = htot(i)+h_ent MKE_rate = 1.0/(1.0 + (cMKE(1,i)*HpE + cMKE(2,i)*HpE**2)) TKE_ent = TKE_ent1 + dMKE*EF4_val*MKE_rate ! TKE_ent is the TKE that would remain if h_ent were entrained. - dTKE_dh = ((-Idecay_len_TKE(i)*TKE_ent1 - dRL*GV%H_to_Z) + & - Pen_dTKE_dh_Contrib*GV%H_to_Z) + dMKE * MKE_rate* & + dTKE_dh = ((-Idecay_len_TKE(i)*TKE_ent1 - dRL) + & + Pen_dTKE_dh_Contrib) + dMKE * MKE_rate* & (dEF4_dh - EF4_val*MKE_rate*(cMKE(1,i)+2.0*cMKE(2,i)*HpE)) ! dh_Newt = -TKE_ent / dTKE_dh ! Bisect if the Newton's method prediction is outside of the bounded range. @@ -1738,14 +1966,11 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & E_HxHpE = h_ent / ((htot(i)+h_neglect)*(HpE+h_neglect)) CS%diag_TKE_mech_decay(i,j) = CS%diag_TKE_mech_decay(i,j) + & - Idt_diag * ((exp_kh-1.0)* TKE(i) + (h_ent*GV%H_to_Z)*dRL*(1.0-f1_kh) + & + Idt_diag * ((exp_kh-1.0)* TKE(i) + h_ent*dRL*(1.0-f1_kh) + & dMKE*MKE_rate*(EF4_val-E_HxHpE)) - CS%diag_TKE_mixing(i,j) = CS%diag_TKE_mixing(i,j) - & - Idt_diag*(h_ent*GV%H_to_Z)*dRL - CS%diag_TKE_pen_SW(i,j) = CS%diag_TKE_pen_SW(i,j) - & - Idt_diag*(h_ent*GV%H_to_Z)*Pen_En_Contrib - CS%diag_TKE_RiBulk(i,j) = CS%diag_TKE_RiBulk(i,j) + & - Idt_diag*dMKE*MKE_rate*E_HxHpE + CS%diag_TKE_mixing(i,j) = CS%diag_TKE_mixing(i,j) - Idt_diag*h_ent*dRL + CS%diag_TKE_pen_SW(i,j) = CS%diag_TKE_pen_SW(i,j) - Idt_diag*h_ent*Pen_En_Contrib + CS%diag_TKE_RiBulk(i,j) = CS%diag_TKE_RiBulk(i,j) + Idt_diag*dMKE*MKE_rate*E_HxHpE endif TKE(i) = 0.0 @@ -1759,7 +1984,11 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & endif ; enddo htot(i) = htot(i) + h_ent - R0_tot(i) = R0_tot(i) + (h_ent * R0(i,k) + Pen_absorbed*dR0_dT(i)) + if (CS%nonBous_energetics) then + SpV0_tot(i) = SpV0_tot(i) + (h_ent * SpV0(i,k) + Pen_absorbed*dSpV0_dT(i)) + else + R0_tot(i) = R0_tot(i) + (h_ent * R0(i,k) + Pen_absorbed*dR0_dT(i)) + endif h(i,k) = h(i,k) - h_ent d_eb(i,k) = d_eb(i,k) - h_ent @@ -1769,7 +1998,7 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & uhtot(i) = uhtot(i) + u(i,k)*h_ent vhtot(i) = vhtot(i) + v(i,k)*h_ent - endif ! h_avail > 0.0 .AND TKE(i) > 0.0 + endif ! h_avail > 0.0 .and. TKE(i) > 0.0 endif ; enddo ! i loop enddo ! k loop @@ -1778,20 +2007,23 @@ end subroutine mechanical_entrainment !> This subroutine generates an array of indices that are sorted by layer !! density. -subroutine sort_ML(h, R0, eps, G, GV, CS, ksort) +subroutine sort_ML(h, R0, SpV0, eps, G, GV, CS, ksort) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZK0_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. real, dimension(SZI_(G),SZK0_(GV)), intent(in) :: R0 !< The potential density used to sort !! the layers [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), intent(in) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg-1] real, dimension(SZI_(G),SZK_(GV)), intent(in) :: eps !< The (small) thickness that must !! remain in each layer [H ~> m or kg m-2]. - type(bulkmixedlayer_CS), intent(in) :: CS !< Bulk mixed layer control struct + type(bulkmixedlayer_CS), intent(in) :: CS !< Bulk mixed layer control structure integer, dimension(SZI_(G),SZK_(GV)), intent(out) :: ksort !< The k-index to use in the sort. ! Local variables - real :: R0sort(SZI_(G),SZK_(GV)) - integer :: nsort(SZI_(G)) + real :: R0sort(SZI_(G),SZK_(GV)) ! The sorted potential density [R ~> kg m-3] + real :: SpV0sort(SZI_(G),SZK_(GV)) ! The sorted specific volume [R-1 ~> m3 kg-1] + integer :: nsort(SZI_(G)) ! The number of layers left to sort logical :: done_sorting(SZI_(G)) integer :: i, k, ks, is, ie, nz, nkmb @@ -1809,36 +2041,55 @@ subroutine sort_ML(h, R0, eps, G, GV, CS, ksort) do k=1,nz ; do i=is,ie ; ksort(i,k) = -1 ; enddo ; enddo do i=is,ie ; nsort(i) = 0 ; done_sorting(i) = .false. ; enddo - do k=1,nz ; do i=is,ie ; if (h(i,k) > eps(i,k)) then - if (done_sorting(i)) then ; ks = nsort(i) ; else - do ks=nsort(i),1,-1 - if (R0(i,k) >= R0sort(i,ks)) exit - R0sort(i,ks+1) = R0sort(i,ks) ; ksort(i,ks+1) = ksort(i,ks) - enddo - if ((k > nkmb) .and. (ks == nsort(i))) done_sorting(i) = .true. - endif - ksort(i,ks+1) = k - R0sort(i,ks+1) = R0(i,k) - nsort(i) = nsort(i) + 1 - endif ; enddo ; enddo + if (CS%nonBous_energetics) then + do k=1,nz ; do i=is,ie ; if (h(i,k) > eps(i,k)) then + if (done_sorting(i)) then ; ks = nsort(i) ; else + do ks=nsort(i),1,-1 + if (SpV0(i,k) <= SpV0sort(i,ks)) exit + SpV0sort(i,ks+1) = SpV0sort(i,ks) ; ksort(i,ks+1) = ksort(i,ks) + enddo + if ((k > nkmb) .and. (ks == nsort(i))) done_sorting(i) = .true. + endif + + ksort(i,ks+1) = k + SpV0sort(i,ks+1) = SpV0(i,k) + nsort(i) = nsort(i) + 1 + endif ; enddo ; enddo + else + do k=1,nz ; do i=is,ie ; if (h(i,k) > eps(i,k)) then + if (done_sorting(i)) then ; ks = nsort(i) ; else + do ks=nsort(i),1,-1 + if (R0(i,k) >= R0sort(i,ks)) exit + R0sort(i,ks+1) = R0sort(i,ks) ; ksort(i,ks+1) = ksort(i,ks) + enddo + if ((k > nkmb) .and. (ks == nsort(i))) done_sorting(i) = .true. + endif + + ksort(i,ks+1) = k + R0sort(i,ks+1) = R0(i,k) + nsort(i) = nsort(i) + 1 + endif ; enddo ; enddo + endif end subroutine sort_ML !> This subroutine actually moves properties between layers to achieve a !! resorted state, with all of the resorted water either moved into the correct !! interior layers or in the top nkmb layers. -subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS, & - dR0_dT, dR0_dS, dRcv_dT, dRcv_dS) +subroutine resort_ML(h, T, S, R0, SpV0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS, & + dR0_dT, dR0_dS, dSpV0_dT, dSpV0_dS, dRcv_dT, dRcv_dS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid !! structure. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2]. !! Layer 0 is the new mixed layer. - real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: T !< Layer temperatures [degC]. - real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Layer salinities [ppt]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: T !< Layer temperatures [C ~> degC]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Layer salinities [S ~> ppt]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: R0 !< Potential density referenced to !! surface pressure [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg-1] real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: Rcv !< The coordinate defining !! potential density [R ~> kg m-3]. real, dimension(SZK_(GV)), intent(in) :: RcvTgt !< The target value of Rcv for each @@ -1854,24 +2105,28 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS !! layer in the entrainment from !! below [H ~> m or kg m-2]. Positive values go !! with mass gain by a layer. - integer, dimension(SZI_(G),SZK_(GV)), intent(in) :: ksort !< The density-sorted k-indicies. - type(bulkmixedlayer_CS), intent(in) :: CS !< Bulk mixed layer control struct + integer, dimension(SZI_(G),SZK_(GV)), intent(in) :: ksort !< The density-sorted k-indices. + type(bulkmixedlayer_CS), intent(in) :: CS !< Bulk mixed layer control structure real, dimension(SZI_(G)), intent(in) :: dR0_dT !< The partial derivative of !! potential density referenced !! to the surface with potential - !! temperature [R degC-1 ~> kg m-3 degC-1]. + !! temperature [R C-1 ~> kg m-3 degC-1]. real, dimension(SZI_(G)), intent(in) :: dR0_dS !< The partial derivative of - !! cpotential density referenced + !! potential density referenced !! to the surface with salinity, - !! [R ppt-1 ~> kg m-3 ppt-1]. + !! [R S-1 ~> kg m-3 ppt-1]. + real, dimension(SZI_(G)), intent(in) :: dSpV0_dT !< The partial derivative of SpV0 with respect + !! to temperature [R-1 C-1 ~> m3 kg-1 degC-1] + real, dimension(SZI_(G)), intent(in) :: dSpV0_dS !< The partial derivative of SpV0 with respect + !! to salinity [R-1 S-1 ~> m3 kg-1 ppt-1] real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of !! coordinate defining potential !! density with potential - !! temperature [R degC-1 ~> kg m-3 degC-1]. + !! temperature [R C-1 ~> kg m-3 degC-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dS !< The partial derivative of !! coordinate defining potential !! density with salinity, - !! [R ppt-1 ~> kg m-3 ppt-1]. + !! [R S-1 ~> kg m-3 ppt-1]. ! If there are no massive light layers above the deepest of the mixed- and ! buffer layers, do nothing (except perhaps to reshuffle these layers). @@ -1882,21 +2137,41 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS ! and the coordinate density (sigma-2)) between the newly forming mixed layer ! and a residual buffer- or mixed layer, and the number of massive layers above ! the deepest massive buffer or mixed layer is greater than nkbl, then split -! those buffer layers into peices that match the target density of the two +! those buffer layers into pieces that match the target density of the two ! nearest interior layers. ! Otherwise, if there are more than nkbl+1 remaining massive layers ! Local variables - real :: h_move, h_tgt_old, I_hnew - real :: dT_dS_wt2, dT_dR, dS_dR, I_denom - real :: Rcv_int - real :: T_up, S_up, R0_up, I_hup, h_to_up - real :: T_dn, S_dn, R0_dn, I_hdn, h_to_dn - real :: wt_dn - real :: dR1, dR2 - real :: dPE, hmin, min_dPE, min_hmin - real, dimension(SZK_(GV)) :: & - h_tmp, R0_tmp, T_tmp, S_tmp, Rcv_tmp + real :: h_move ! The thickness of water being moved between layers [H ~> m or kg m-2] + real :: h_tgt_old ! The previous thickness of the recipient layer [H ~> m or kg m-2] + real :: I_hnew ! The inverse of a new layer thickness [H-1 ~> m-1 or m2 kg-1] + real :: dT_dS_wt2 ! The square of the relative weighting of temperature and salinity changes + ! when extrapolating to match a target density [C2 S-2 ~> degC2 ppt-2] + real :: dT_dR ! The ratio of temperature changes to density changes when + ! extrapolating [C R-1 ~> degC m3 kg-1] + real :: dS_dR ! The ratio of salinity changes to density changes when + ! extrapolating [S R-1 ~> ppt m3 kg-1] + real :: I_denom ! A work variable with units of [S2 R-2 ~> ppt2 m6 kg-2]. + real :: Rcv_int ! The target coordinate density of an interior layer [R ~> kg m-3] + real :: T_up, T_dn ! Temperatures projected to match the target densities of two layers [C ~> degC] + real :: S_up, S_dn ! Salinities projected to match the target densities of two layers [S ~> ppt] + real :: R0_up, R0_dn ! Potential densities projected to match the target coordinate + ! densities of two layers [R ~> kg m-3] + real :: SpV0_up, SpV0_dn ! Specific volumes projected to be consistent with the target coordinate + ! densities of two layers [R-1 ~> m3 kg-1] + real :: I_hup, I_hdn ! Inverse of the new thicknesses of the two layers [H-1 ~> m-1 or m2 kg-1] + real :: h_to_up, h_to_dn ! Thickness transferred to two layers [H ~> m or kg m-2] + real :: wt_dn ! Fraction of the thickness transferred to the deeper layer [nondim] + real :: dR1, dR2 ! Density difference with the target densities of two layers [R ~> kg m-3] + real :: dPE, min_dPE ! Values proportional to the potential energy change due to the merging of a + ! pair of layers [R H2 ~> kg m-1 or kg3 m-7] or [R-1 H2 ~> m5 kg-1 or kg m-1] + real :: hmin, min_hmin ! The thickness of the thinnest layer [H ~> m or kg m-2] + real :: h_tmp(SZK_(GV)) ! A copy of the original layer thicknesses [H ~> m or kg m-2] + real :: R0_tmp(SZK_(GV)) ! A copy of the original layer potential densities [R ~> kg m-3] + real :: SpV0_tmp(SZK_(GV)) ! A copy of the original layer specific volumes [R ~> kg m-3] + real :: T_tmp(SZK_(GV)) ! A copy of the original layer temperatures [C ~> degC] + real :: S_tmp(SZK_(GV)) ! A copy of the original layer salinities [S ~> ppt] + real :: Rcv_tmp(SZK_(GV)) ! A copy of the original layer coordinate densities [R ~> kg m-3] integer :: ks_min logical :: sorted, leave_in_layer integer :: ks_deep(SZI_(G)), k_count(SZI_(G)), ks2_reverse(SZI_(G), SZK_(GV)) @@ -1995,13 +2270,19 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS T_dn = T(i,k) + dT_dR * dR2 S_dn = S(i,k) + dS_dR * dR2 - R0_up = R0(i,k) + (dT_dR*dR0_dT(i) + dS_dR*dR0_dS(i)) * dR1 - R0_dn = R0(i,k) + (dT_dR*dR0_dT(i) + dS_dR*dR0_dS(i)) * dR2 + if (CS%nonBous_energetics) then + SpV0_up = SpV0(i,k) + (dT_dR*dSpV0_dT(i) + dS_dR*dSpV0_dS(i)) * dR1 + SpV0_dn = SpV0(i,k) + (dT_dR*dSpV0_dT(i) + dS_dR*dSpV0_dS(i)) * dR2 - ! Make sure the new properties are acceptable. - if ((R0_up > R0(i,0)) .or. (R0_dn > R0(i,0))) & - ! Avoid creating obviously unstable profiles. - exit + ! Make sure the new properties are acceptable, and avoid creating obviously unstable profiles. + if ((SpV0_up < SpV0(i,0)) .or. (SpV0_dn < SpV0(i,0))) exit + else + R0_up = R0(i,k) + (dT_dR*dR0_dT(i) + dS_dR*dR0_dS(i)) * dR1 + R0_dn = R0(i,k) + (dT_dR*dR0_dT(i) + dS_dR*dR0_dS(i)) * dR2 + + ! Make sure the new properties are acceptable, and avoid creating obviously unstable profiles. + if ((R0_up > R0(i,0)) .or. (R0_dn > R0(i,0))) exit + endif wt_dn = (Rcv(i,k) - RcvTgt(k2-1)) / (RcvTgt(k2) - RcvTgt(k2-1)) h_to_up = (h(i,k)-eps(i,k)) * (1.0 - wt_dn) @@ -2009,8 +2290,13 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS I_hup = 1.0 / (h(i,k2-1) + h_to_up) I_hdn = 1.0 / (h(i,k2) + h_to_dn) - R0(i,k2-1) = (R0(i,k2)*h(i,k2-1) + R0_up*h_to_up) * I_hup - R0(i,k2) = (R0(i,k2)*h(i,k2) + R0_dn*h_to_dn) * I_hdn + if (CS%nonBous_energetics) then + SpV0(i,k2-1) = (SpV0(i,k2)*h(i,k2-1) + SpV0_up*h_to_up) * I_hup + SpV0(i,k2) = (SpV0(i,k2)*h(i,k2) + SpV0_dn*h_to_dn) * I_hdn + else + R0(i,k2-1) = (R0(i,k2)*h(i,k2-1) + R0_up*h_to_up) * I_hup + R0(i,k2) = (R0(i,k2)*h(i,k2) + R0_dn*h_to_dn) * I_hdn + endif T(i,k2-1) = (T(i,k2)*h(i,k2-1) + T_up*h_to_up) * I_hup T(i,k2) = (T(i,k2)*h(i,k2) + T_dn*h_to_dn) * I_hdn @@ -2054,7 +2340,11 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS ks_min = -1 ; min_dPE = 1.0 ; min_hmin = 0.0 do ks=1,nks-1 k1 = ks2(ks) ; k2 = ks2(ks+1) - dPE = max(0.0, (R0(i,k2)-R0(i,k1)) * h(i,k1) * h(i,k2)) + if (CS%nonBous_energetics) then + dPE = max(0.0, (SpV0(i,k1) - SpV0(i,k2)) * (h(i,k1) * h(i,k2))) + else + dPE = max(0.0, (R0(i,k2) - R0(i,k1)) * h(i,k1) * h(i,k2)) + endif hmin = min(h(i,k1)-eps(i,k1), h(i,k2)-eps(i,k2)) if ((ks_min < 0) .or. (dPE < min_dPE) .or. & ((dPE <= 0.0) .and. (hmin < min_hmin))) then @@ -2072,7 +2362,11 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS h(i,k_src) = eps(i,k_src) h(i,k_tgt) = h(i,k_tgt) + h_move I_hnew = 1.0 / (h(i,k_tgt)) - R0(i,k_tgt) = (R0(i,k_tgt)*h_tgt_old + R0(i,k_src)*h_move) * I_hnew + if (CS%nonBous_energetics) then + SpV0(i,k_tgt) = (SpV0(i,k_tgt)*h_tgt_old + SpV0(i,k_src)*h_move) * I_hnew + else + R0(i,k_tgt) = (R0(i,k_tgt)*h_tgt_old + R0(i,k_src)*h_move) * I_hnew + endif T(i,k_tgt) = (T(i,k_tgt)*h_tgt_old + T(i,k_src)*h_move) * I_hnew S(i,k_tgt) = (S(i,k_tgt)*h_tgt_old + S(i,k_src)*h_move) * I_hnew @@ -2098,7 +2392,12 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS ! Save all the properties of the nkmb layers that might be replaced. do k=1,nkmb - h_tmp(k) = h(i,k) ; R0_tmp(k) = R0(i,k) + h_tmp(k) = h(i,k) + if (CS%nonBous_energetics) then + SpV0_tmp(k) = SpV0(i,k) + else + R0_tmp(k) = R0(i,k) + endif T_tmp(k) = T(i,k) ; S_tmp(k) = S(i,k) ; Rcv_tmp(k) = Rcv(i,k) h(i,k) = 0.0 @@ -2116,7 +2415,11 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS h_move = h(i,k_src)-eps(i,k_src) h(i,k_src) = eps(i,k_src) h(i,k_tgt) = h_move - R0(i,k_tgt) = R0(i,k_src) + if (CS%nonBous_energetics) then + SpV0(i,k_tgt) = SpV0(i,k_src) + else + R0(i,k_tgt) = R0(i,k_src) + endif T(i,k_tgt) = T(i,k_src) ; S(i,k_tgt) = S(i,k_src) Rcv(i,k_tgt) = Rcv(i,k_src) @@ -2125,7 +2428,11 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS d_eb(i,k_tgt) = d_eb(i,k_tgt) + h_move else h(i,k_tgt) = h_tmp(k_src) - R0(i,k_tgt) = R0_tmp(k_src) + if (CS%nonBous_energetics) then + SpV0(i,k_tgt) = SpV0_tmp(k_src) + else + R0(i,k_tgt) = R0_tmp(k_src) + endif T(i,k_tgt) = T_tmp(k_src) ; S(i,k_tgt) = S_tmp(k_src) Rcv(i,k_tgt) = Rcv_tmp(k_src) @@ -2148,16 +2455,18 @@ end subroutine resort_ML !> This subroutine moves any water left in the former mixed layers into the !! two buffer layers and may also move buffer layer water into the interior !! isopycnal layers. -subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, G, GV, US, CS, & - dR0_dT, dR0_dS, dRcv_dT, dRcv_dS, max_BL_det) +subroutine mixedlayer_detrain_2(h, T, S, R0, Spv0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, G, GV, US, CS, & + dR0_dT, dR0_dS, dSpV0_dT, dSpV0_dS, dRcv_dT, dRcv_dS, max_BL_det) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2]. !! Layer 0 is the new mixed layer. - real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: T !< Potential temperature [degC]. - real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Salinity [ppt]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: T !< Potential temperature [C ~> degC]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Salinity [S ~> ppt]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: R0 !< Potential density referenced to !! surface pressure [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg-1] real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: Rcv !< The coordinate defining potential !! density [R ~> kg m-3]. real, dimension(SZK_(GV)), intent(in) :: RcvTgt !< The target value of Rcv for each @@ -2170,22 +2479,28 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, !! goes with layer thickness increases. integer, intent(in) :: j !< The meridional row to work on. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control struct + type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control structure real, dimension(SZI_(G)), intent(in) :: dR0_dT !< The partial derivative of !! potential density referenced to the !! surface with potential temperature, - !! [R degC-1 ~> kg m-3 degC-1]. + !! [R C-1 ~> kg m-3 degC-1]. real, dimension(SZI_(G)), intent(in) :: dR0_dS !< The partial derivative of - !! cpotential density referenced to the + !! potential density referenced to the !! surface with salinity - !! [R ppt-1 ~> kg m-3 ppt-1]. + !! [R S-1 ~> kg m-3 ppt-1]. + real, dimension(SZI_(G)), intent(in) :: dSpV0_dT !< The partial derivative of specific + !! volume with respect to temeprature + !! [R-1 C-1 ~> m3 kg-1 degC-1] + real, dimension(SZI_(G)), intent(in) :: dSpV0_dS !< The partial derivative of specific + !! volume with respect to salinity + !! [R-1 S-1 ~> m3 kg-1 ppt-1] real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of !! coordinate defining potential density !! with potential temperature, - !! [R degC-1 ~> kg m-3 degC-1]. + !! [R C-1 ~> kg m-3 degC-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dS !< The partial derivative of !! coordinate defining potential density - !! with salinity [R ppt-1 ~> kg m-3 ppt-1]. + !! with salinity [R S-1 ~> kg m-3 ppt-1]. real, dimension(SZI_(G)), intent(in) :: max_BL_det !< If non-negative, the maximum !! detrainment permitted from the buffer !! layers [H ~> m or kg m-2]. @@ -2199,12 +2514,14 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, ! layers [H ~> m or kg m-2]. real :: R0_to_bl ! The depth integrated amount of R0 that is detrained to the ! buffer layer [H R ~> kg m-2 or kg2 m-5] + real :: SpV0_to_bl ! The depth integrated amount of SpV0 that is detrained to the + ! buffer layer [H R-1 ~> m4 kg-1 or m] real :: Rcv_to_bl ! The depth integrated amount of Rcv that is detrained to the ! buffer layer [H R ~> kg m-2 or kg2 m-5] real :: T_to_bl ! The depth integrated amount of T that is detrained to the - ! buffer layer [degC H ~> degC m or degC kg m-2] + ! buffer layer [C H ~> degC m or degC kg m-2] real :: S_to_bl ! The depth integrated amount of S that is detrained to the - ! buffer layer [ppt H ~> ppt m or ppt kg m-2] + ! buffer layer [S H ~> ppt m or ppt kg m-2] real :: h_min_bl ! The minimum buffer layer thickness [H ~> m or kg m-2]. real :: h1, h2 ! Scalar variables holding the values of @@ -2217,43 +2534,59 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, real :: stays_min, stays_max ! The minimum and maximum permitted values of ! stays [H ~> m or kg m-2]. + logical :: intermediate ! True if the water in layer kb1 is intermediate in density + ! between the water in kb2 and the water being detrained. logical :: mergeable_bl ! If true, it is an option to combine the two ! buffer layers and create water that matches ! the target density of an interior layer. + logical :: better_to_merge ! True if it is energetically favorable to merge layers real :: stays_merge ! If the two buffer layers can be combined ! stays_merge is the thickness of the upper ! layer that remains [H ~> m or kg m-2]. real :: stays_min_merge ! The minimum allowed value of stays_merge [H ~> m or kg m-2]. real :: dR0_2dz, dRcv_2dz ! Half the vertical gradients of R0 and Rcv [R H-1 ~> kg m-4 or m-1] -! real :: dT_2dz, dS_2dz ! Half the vertical gradients of T and S, in degC H-1, and ppt H-1. + real :: dSpV0_2dz ! Half the vertical gradients of SpV0 and Rcv [R-1 H-1 ~> m2 kg-1 or m5 kg-2] +! real :: dT_2dz ! Half the vertical gradient of T [C H-1 ~> degC m-1 or degC m2 kg-1] +! real :: dS_2dz ! Half the vertical gradient of S [S H-1 ~> ppt m-1 or ppt m2 kg-1] real :: scale_slope ! A nondimensional number < 1 used to scale down ! the slope within the upper buffer layer when - ! water MUST be detrained to the lower layer. + ! water MUST be detrained to the lower layer [nondim]. - real :: dPE_extrap ! The potential energy change due to dispersive + real :: dPE_extrap_rhoG ! The potential energy change due to dispersive ! advection or mixing layers, divided by ! rho_0*g [H2 ~> m2 or kg2 m-4]. + real :: dPE_extrapolate ! The potential energy change due to dispersive advection or + ! mixing layers [R Z3 T-2 ~> J m-2]. real :: dPE_det, dPE_merge ! The energy required to mix the detrained water ! into the buffer layer or the merge the two - ! buffer layers [R H2 L2 Z-1 T-2 ~> J m-2 or J kg2 m-8]. + ! buffer layers [R H2 Z T-2 ~> J m-2 or J kg2 m-8]. + real :: dPE_det_nB, dPE_merge_nB ! The energy required to mix the detrained water + ! into the buffer layer or the merge the two + ! buffer layers [R Z3 T-2 ~> J m-2]. real :: h_from_ml ! The amount of additional water that must be ! drawn from the mixed layer [H ~> m or kg m-2]. real :: h_det_h2 ! The amount of detrained water and mixed layer ! water that will go directly into the lower ! buffer layer [H ~> m or kg m-2]. - real :: h_det_to_h2, h_ml_to_h2 ! All of the variables hA_to_hB are the thickness fluxes - real :: h_det_to_h1, h_ml_to_h1 ! from one layer to another [H ~> m or kg m-2], - real :: h1_to_h2, h1_to_k0 ! with h_det the detrained water, h_ml - real :: h2_to_k1, h2_to_k1_rem ! the actively mixed layer, h1 and h2 the upper - ! and lower buffer layers, and k0 and k1 the - ! interior layers that are just lighter and - ! just denser than the lower buffer layer. - - real :: R0_det, T_det, S_det ! Detrained values of R0 [R ~> kg m-3], T [degC], and S [ppt]. - real :: Rcv_stays, R0_stays ! Values of Rcv and R0 that stay in a layer. - real :: T_stays, S_stays ! Values of T and S that stay in a layer. + + real :: h_det_to_h2, h_ml_to_h2 ! The fluxes of detrained and mixed layer water to + ! the lower buffer layer [H ~> m or kg m-2]. + real :: h_det_to_h1, h_ml_to_h1 ! The fluxes of detrained and mixed layer water to + ! the upper buffer layer [H ~> m or kg m-2]. + real :: h1_to_h2, h1_to_k0 ! The fluxes of upper buffer layer water to the lower buffer layer + ! and to an interior layer that is just denser than the lower + ! buffer layer [H ~> m or kg m-2]. + real :: h2_to_k1, h2_to_k1_rem ! Fluxes of lower buffer layer water to the interior layer that + ! is just denser than the lower buffer layer [H ~> m or kg m-2]. + + real :: R0_det ! Detrained value of potential density referenced to the surface [R ~> kg m-3] + real :: SpV0_det ! Detrained value of specific volume referenced to the surface [R-1 ~> m3 kg-1] + real :: T_det, S_det ! Detrained values of temperature [C ~> degC] and salinity [S ~> ppt] + real :: Rcv_stays, R0_stays ! Values of Rcv and R0 that stay in a layer [R ~> kg m-3] + real :: SpV0_stays ! Values of SpV0 that stay in a layer [R-1 ~> m3 kg-1] + real :: T_stays, S_stays ! Values of T and S that stay in a layer, [C ~> degC] and S [S ~> ppt] real :: dSpice_det, dSpice_stays! The spiciness difference between an original ! buffer layer and the water that moves into ! an interior layer or that stays in that @@ -2263,21 +2596,26 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, ! moves into an interior layer [R ~> kg m-3]. real :: dSpice_2dz ! The vertical gradient of spiciness used for ! advection [R H-1 ~> kg m-4 or m-1]. - + real :: dSpiceSpV_stays ! The specific volume based spiciness difference between an original + ! buffer layer and the water that stays in that layer [R-1 ~> m3 kg-1] + real :: dSpiceSpV_lim ! A limit on the specific volume based spiciness difference + ! between the lower buffer layer and the water that + ! moves into an interior layer [R-1 ~> m3 kg-1] real :: dPE_ratio ! Multiplier of dPE_det at which merging is ! permitted - here (detrainment_per_day/dt)*30 - ! days? + ! days? [nondim] real :: num_events ! The number of detrainment events over which - ! to prefer merging the buffer layers. + ! to prefer merging the buffer layers [nondim]. real :: dPE_time_ratio ! Larger of 1 and the detrainment timescale over dt [nondim]. real :: dT_dS_gauge, dS_dT_gauge ! The relative scales of temperature and ! salinity changes in defining spiciness, in - ! [degC ppt-1] and [ppt degC-1]. - real :: I_denom ! A work variable with units of [ppt2 R-2 ~> ppt2 m6 kg-2]. + ! [C S-1 ~> degC ppt-1] and [S C-1 ~> ppt degC-1]. + real :: I_denom ! A work variable with units of [S2 R-2 ~> ppt2 m6 kg-2] or [R2 S2 ~> ppt2 kg2 m-6]. - real :: g_2 ! 1/2 g_Earth [L2 Z-1 T-2 ~> m s-2]. - real :: Rho0xG ! Rho0 times G_Earth [R L2 Z-1 T-2 ~> kg m-2 s-2]. + real :: g_2 ! 1/2 g_Earth [Z T-2 ~> m s-2]. + real :: Rho0xG ! Rho0 times G_Earth [R Z T-2 ~> kg m-2 s-2]. real :: I2Rho0 ! 1 / (2 Rho0) [R-1 ~> m3 kg-1]. + real :: Idt_diag ! The inverse of the timestep used for diagnostics [T-1 ~> s-1]. real :: Idt_H2 ! The square of the conversion from thickness to Z ! divided by the time step [Z2 H-2 T-1 ~> s-1 or m6 kg-2 s-1]. logical :: stable_Rcv ! If true, the buffer layers are stable with @@ -2285,36 +2623,40 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. - real :: s1en ! A work variable [R Z L2 T-3 ~> W m-2] + real :: s1en ! A work variable [R Z3 T-3 ~> W m-2] real :: s1, s2, bh0 ! Work variables [H ~> m or kg m-2]. real :: s3sq ! A work variable [H2 ~> m2 or kg2 m-4]. real :: I_ya, b1 ! Nondimensional work variables [nondim] - real :: Ih, Ihdet, Ih1f, Ih2f ! Assorted inverse thickness work variables, - real :: Ihk0, Ihk1, Ih12 ! all in [H-1 ~> m-1 or m2 kg-1]. - real :: dR1, dR2, dR2b, dRk1 ! Assorted density difference work variables, - real :: dR0, dR21, dRcv ! all in [R ~> kg m-3]. + real :: Ih, Ihdet, Ih1f, Ih2f ! Assorted inverse thickness work variables [H-1 ~> m-1 or m2 kg-1] + real :: Ihk0, Ihk1, Ih12 ! Assorted inverse thickness work variables [H-1 ~> m-1 or m2 kg-1] + real :: dR1, dR2, dR2b, dRk1 ! Assorted density difference work variables [R ~> kg m-3] + real :: dR0, dR21, dRcv ! Assorted density difference work variables [R ~> kg m-3] + real :: dSpV0, dSpVk1 ! Assorted specific volume difference work variables [R-1 ~> m3 kg-1] real :: dRcv_stays, dRcv_det, dRcv_lim ! Assorted densities [R ~> kg m-3] - real :: Angstrom ! The minumum layer thickness [H ~> m or kg m-2]. - - real :: h2_to_k1_lim, T_new, S_new, T_max, T_min, S_max, S_min - character(len=200) :: mesg + real :: Angstrom ! The minimum layer thickness [H ~> m or kg m-2]. + real :: h2_to_k1_lim ! A limit on the thickness that can be detrained to layer k1 [H ~> m or kg m-2] + real :: T_new, T_max, T_min ! Temperature of the detrained water and limits on it [C ~> degC] + real :: S_new, S_max, S_min ! Salinity of the detrained water and limits on it [S ~> ppt] + logical :: stable integer :: i, k, k0, k1, is, ie, nz, kb1, kb2, nkmb + is = G%isc ; ie = G%iec ; nz = GV%ke - kb1 = CS%nkml+1; kb2 = CS%nkml+2 + kb1 = CS%nkml+1 ; kb2 = CS%nkml+2 nkmb = CS%nkml+CS%nkbl h_neglect = GV%H_subroundoff - g_2 = 0.5 * GV%g_Earth - Rho0xG = GV%Rho0 * GV%g_Earth + g_2 = 0.5 * GV%g_Earth_Z_T2 + Rho0xG = GV%Rho0 * GV%g_Earth_Z_T2 + Idt_diag = 1.0 / dt_diag Idt_H2 = GV%H_to_Z**2 / dt_diag - I2Rho0 = 0.5 / (GV%Rho0) + I2Rho0 = 0.5 / GV%Rho0 Angstrom = GV%Angstrom_H ! This is hard coding of arbitrary and dimensional numbers. dT_dS_gauge = CS%dT_dS_wt ; dS_dT_gauge = 1.0 / dT_dS_gauge num_events = 10.0 - if (CS%nkbl /= 2) call MOM_error(FATAL, "MOM_mixed_layer"// & + if (CS%nkbl /= 2) call MOM_error(FATAL, "MOM_mixed_layer: "// & "CS%nkbl must be 2 in mixedlayer_detrain_2.") if (dt < CS%BL_detrain_time) then ; dPE_time_ratio = CS%BL_detrain_time / (dt) @@ -2327,12 +2669,16 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, ! As coded this has the k and i loop orders switched, but k is CS%nkml is ! often just 1 or 2, so this seems like it should not be a problem, especially ! since it means that a number of variables can now be scalars, not arrays. - h_to_bl = 0.0 ; R0_to_bl = 0.0 + h_to_bl = 0.0 ; R0_to_bl = 0.0 ; SpV0_to_bl = 0.0 Rcv_to_bl = 0.0 ; T_to_bl = 0.0 ; S_to_bl = 0.0 do k=1,CS%nkml ; if (h(i,k) > 0.0) then h_to_bl = h_to_bl + h(i,k) - R0_to_bl = R0_to_bl + R0(i,k)*h(i,k) + if (CS%nonBous_energetics) then + SpV0_to_bl = SpV0_to_bl + SpV0(i,k)*h(i,k) + else + R0_to_bl = R0_to_bl + R0(i,k)*h(i,k) + endif Rcv_to_bl = Rcv_to_bl + Rcv(i,k)*h(i,k) T_to_bl = T_to_bl + T(i,k)*h(i,k) @@ -2341,8 +2687,14 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, d_ea(i,k) = d_ea(i,k) - h(i,k) h(i,k) = 0.0 endif ; enddo - if (h_to_bl > 0.0) then ; R0_det = R0_to_bl / h_to_bl - else ; R0_det = R0(i,0) ; endif + + if (CS%nonBous_energetics) then + if (h_to_bl > 0.0) then ; SpV0_det = SpV0_to_bl / h_to_bl + else ; SpV0_det = SpV0(i,0) ; endif + else + if (h_to_bl > 0.0) then ; R0_det = R0_to_bl / h_to_bl + else ; R0_det = R0(i,0) ; endif + endif ! This code does both downward detrainment from both the mixed layer and the ! buffer layers. @@ -2355,7 +2707,7 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, ! (3) The lower buffer layer density extrapolated to its base with a ! linear fit between the two layers must exceed the density of the ! next denser interior layer. - ! (4) The average extroplated coordinate density that is moved into the + ! (4) The average extrapolated coordinate density that is moved into the ! isopycnal interior matches the target value for that layer. ! (5) The potential energy change is calculated and might be used later ! to allow the upper buffer layer to mix more into the lower buffer @@ -2367,8 +2719,11 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, h_min_bl = MIN(CS%Hbuffer_min, CS%Hbuffer_rel_min*h(i,0)) stable_Rcv = .true. - if (((R0(i,kb2)-R0(i,kb1)) * (Rcv(i,kb2)-Rcv(i,kb1)) <= 0.0)) & - stable_Rcv = .false. + if (CS%nonBous_energetics) then + if (((SpV0(i,kb1)-SpV0(i,kb2)) * (Rcv(i,kb2)-Rcv(i,kb1)) <= 0.0)) stable_Rcv = .false. + else + if (((R0(i,kb2)-R0(i,kb1)) * (Rcv(i,kb2)-Rcv(i,kb1)) <= 0.0)) stable_Rcv = .false. + endif h1 = h(i,kb1) ; h2 = h(i,kb2) @@ -2383,26 +2738,36 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, ! are not meaningful, but may later be used to determine the properties of ! waters moving into the lower buffer layer. So the properties of the ! lower buffer layer are set to be between those of the upper buffer layer - ! and the next denser interior layer, measured by R0. This probably does + ! and the next denser interior layer, measured by R0 or SpV0. This probably does ! not happen very often, so I am not too worried about the inefficiency of ! the following loop. do k1=kb2+1,nz ; if (h(i,k1) > 2.0*Angstrom) exit ; enddo - R0(i,kb2) = R0(i,kb1) + Rcv(i,kb2) = Rcv(i,kb1) ; T(i,kb2) = T(i,kb1) ; S(i,kb2) = S(i,kb1) - Rcv(i,kb2)=Rcv(i,kb1) ; T(i,kb2)=T(i,kb1) ; S(i,kb2)=S(i,kb1) + if (CS%nonBous_energetics) then + SpV0(i,kb2) = SpV0(i,kb1) + if (k1 <= nz) then ; if (SpV0(i,k1) <= SpV0(i,kb1)) then + SpV0(i,kb2) = 0.5*(SpV0(i,kb1)+SpV0(i,k1)) + Rcv(i,kb2) = 0.5*(Rcv(i,kb1)+Rcv(i,k1)) + T(i,kb2) = 0.5*(T(i,kb1)+T(i,k1)) + S(i,kb2) = 0.5*(S(i,kb1)+S(i,k1)) + endif ; endif + else + R0(i,kb2) = R0(i,kb1) - if (k1 <= nz) then ; if (R0(i,k1) >= R0(i,kb1)) then - R0(i,kb2) = 0.5*(R0(i,kb1)+R0(i,k1)) + if (k1 <= nz) then ; if (R0(i,k1) >= R0(i,kb1)) then + R0(i,kb2) = 0.5*(R0(i,kb1)+R0(i,k1)) - Rcv(i,kb2) = 0.5*(Rcv(i,kb1)+Rcv(i,k1)) - T(i,kb2) = 0.5*(T(i,kb1)+T(i,k1)) - S(i,kb2) = 0.5*(S(i,kb1)+S(i,k1)) - endif ; endif + Rcv(i,kb2) = 0.5*(Rcv(i,kb1)+Rcv(i,k1)) + T(i,kb2) = 0.5*(T(i,kb1)+T(i,k1)) + S(i,kb2) = 0.5*(S(i,kb1)+S(i,k1)) + endif ; endif + endif endif ! (h2 = 0 && h1 > 0) - dPE_extrap = 0.0 ; dPE_merge = 0.0 + dPE_extrap_rhoG = 0.0 ; dPE_extrapolate = 0.0 ; dPE_merge = 0.0 ; dPE_merge_nB = 0.0 mergeable_bl = .false. if ((h1 > 0.0) .and. (h2 > 0.0) .and. (h_to_bl > 0.0) .and. & (stable_Rcv)) then @@ -2419,12 +2784,23 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, ! into the lower one, each with an energy change that equals that required ! to mix the detrained water with the upper buffer layer. h1_avail = h1 - MAX(0.0,h_min_bl-h_to_bl) - if ((k1<=nz) .and. (h2 > h_min_bl) .and. (h1_avail > 0.0) .and. & - (R0(i,kb1) < R0(i,kb2)) .and. (h_to_bl*R0(i,kb1) > R0_to_bl)) then - dRk1 = (RcvTgt(k1) - Rcv(i,kb2)) * (R0(i,kb2) - R0(i,kb1)) / & - (Rcv(i,kb2) - Rcv(i,kb1)) - b1 = dRk1 / (R0(i,kb2) - R0(i,kb1)) + if (CS%nonBous_energetics) then + intermediate = (SpV0(i,kb1) > SpV0(i,kb2)) .and. (h_to_bl*SpV0(i,kb1) < SpV0_to_bl) + else + intermediate = (R0(i,kb1) < R0(i,kb2)) .and. (h_to_bl*R0(i,kb1) > R0_to_bl) + endif + + if ((k1<=nz) .and. (h2 > h_min_bl) .and. (h1_avail > 0.0) .and. intermediate) then + if (CS%nonBous_energetics) then + dSpVk1 = (RcvTgt(k1) - Rcv(i,kb2)) * (SpV0(i,kb2) - SpV0(i,kb1)) / & + (Rcv(i,kb2) - Rcv(i,kb1)) + b1 = (RcvTgt(k1) - Rcv(i,kb2)) / (Rcv(i,kb2) - Rcv(i,kb1)) + else + dRk1 = (RcvTgt(k1) - Rcv(i,kb2)) * (R0(i,kb2) - R0(i,kb1)) / & + (Rcv(i,kb2) - Rcv(i,kb1)) + b1 = dRk1 / (R0(i,kb2) - R0(i,kb1)) ! b1 = RcvTgt(k1) - Rcv(i,kb2)) / (Rcv(i,kb2) - Rcv(i,kb1)) + endif ! Apply several limits to the detrainment. ! Entrain less than the mass in h2, and keep the base of the buffer @@ -2434,8 +2810,14 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, ! buffer layers with upwind advection from the layer above. if (h2_to_k1*(h1_avail + b1*(h1_avail + h2)) > h2*h1_avail) & h2_to_k1 = (h2*h1_avail) / (h1_avail + b1*(h1_avail + h2)) - if (h2_to_k1*(dRk1 * h2) > (h_to_bl*R0(i,kb1) - R0_to_bl) * h1) & - h2_to_k1 = (h_to_bl*R0(i,kb1) - R0_to_bl) * h1 / (dRk1 * h2) + + if (CS%nonBous_energetics) then + if (h2_to_k1*(dSpVk1 * h2) < (h_to_bl*SpV0(i,kb1) - SpV0_to_bl) * h1) & + h2_to_k1 = (h_to_bl*SpV0(i,kb1) - SpV0_to_bl) * h1 / (dSpVk1 * h2) + else + if (h2_to_k1*(dRk1 * h2) > (h_to_bl*R0(i,kb1) - R0_to_bl) * h1) & + h2_to_k1 = (h_to_bl*R0(i,kb1) - R0_to_bl) * h1 / (dRk1 * h2) + endif if ((k1==kb2+1) .and. (CS%BL_extrap_lim > 0.)) then ! Simply do not detrain very light water into the lightest isopycnal @@ -2477,9 +2859,15 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, (dT_dS_gauge * dRcv_dT(i) * dRcv + dRcv_dS(i) * dSpice_det) S_det = S(i,kb2) + I_denom * & (dRcv_dS(i) * dRcv - dT_dS_gauge * dRcv_dT(i) * dSpice_det) - ! The detrained values of R0 are based on changes in T and S. - R0_det = R0(i,kb2) + (T_det-T(i,kb2)) * dR0_dT(i) + & - (S_det-S(i,kb2)) * dR0_dS(i) + + ! The detrained values of R0 or SpV0 are based on changes in T and S. + if (CS%nonBous_energetics) then + SpV0_det = SpV0(i,kb2) + (T_det-T(i,kb2)) * dSpV0_dT(i) + & + (S_det-S(i,kb2)) * dSpV0_dS(i) + else + R0_det = R0(i,kb2) + (T_det-T(i,kb2)) * dR0_dT(i) + & + (S_det-S(i,kb2)) * dR0_dS(i) + endif if (CS%BL_extrap_lim >= 0.) then ! Only do this detrainment if the new layer's temperature and salinity @@ -2521,10 +2909,14 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, h1_to_h2*S(i,kb1)) * Ih2f S(i,k1) = ((h(i,k1)+h_neglect)*S(i,k1) + h2_to_k1*S_det) * Ihk1 - ! Changes in R0 are based on changes in T and S. - R0(i,kb2) = ((h(i,kb2)*R0(i,kb2) - h2_to_k1*R0_det) + & - h1_to_h2*R0(i,kb1)) * Ih2f - R0(i,k1) = ((h(i,k1)+h_neglect)*R0(i,k1) + h2_to_k1*R0_det) * Ihk1 + ! Changes in R0 or SpV0 are based on changes in T and S. + if (CS%nonBous_energetics) then + SpV0(i,kb2) = ((h(i,kb2)*SpV0(i,kb2) - h2_to_k1*SpV0_det) + h1_to_h2*SpV0(i,kb1)) * Ih2f + SpV0(i,k1) = ((h(i,k1)+h_neglect)*SpV0(i,k1) + h2_to_k1*SpV0_det) * Ihk1 + else + R0(i,kb2) = ((h(i,kb2)*R0(i,kb2) - h2_to_k1*R0_det) + h1_to_h2*R0(i,kb1)) * Ih2f + R0(i,k1) = ((h(i,k1)+h_neglect)*R0(i,k1) + h2_to_k1*R0_det) * Ihk1 + endif h(i,kb1) = h(i,kb1) - h1_to_h2 ; h1 = h(i,kb1) h(i,kb2) = (h(i,kb2) - h2_to_k1) + h1_to_h2 ; h2 = h(i,kb2) @@ -2545,8 +2937,13 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, k0 = k1-1 dR1 = RcvTgt(k0)-Rcv(i,kb1) ; dR2 = Rcv(i,kb2)-RcvTgt(k0) - if ((k0>kb2) .and. (dR1 > 0.0) .and. (h1 > h_min_bl) .and. & - (h2*dR2 < h1*dR1) .and. (R0(i,kb2) > R0(i,kb1))) then + if (CS%nonBous_energetics) then + stable = (SpV0(i,kb2) < SpV0(i,kb1)) + else + stable = (R0(i,kb2) > R0(i,kb1)) + endif + + if ((k0>kb2) .and. (dR1 > 0.0) .and. (h1 > h_min_bl) .and. (h2*dR2 < h1*dR1) .and. stable) then ! An interior isopycnal layer (k0) is intermediate in density between ! the two buffer layers, and there can be detrainment. The entire ! lower buffer layer is combined with a portion of the upper buffer @@ -2555,12 +2952,20 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, ((dR1+dR2)*h1 + dR1*(h1+h2) + & sqrt((dR2*h1-dR1*h2)**2 + 4*(h1+h2)*h2*(dR1+dR2)*dR2)) - stays_min_merge = MAX(h_min_bl, 2.0*h_min_bl - h_to_bl, & - h1 - (h1+h2)*(R0(i,kb1) - R0_det) / (R0(i,kb2) - R0(i,kb1))) - if ((stays_merge > stays_min_merge) .and. & - (stays_merge + h2_to_k1_rem >= h1 + h2)) then - mergeable_bl = .true. - dPE_merge = g_2*(R0(i,kb2)-R0(i,kb1))*(h1-stays_merge)*(h2-stays_merge) + if (CS%nonBous_energetics) then + stays_min_merge = MAX(h_min_bl, 2.0*h_min_bl - h_to_bl, & + h1 - (h1+h2)*(SpV0(i,kb1) - SpV0_det) / (SpV0(i,kb2) - SpV0(i,kb1))) + if ((stays_merge > stays_min_merge) .and. (stays_merge + h2_to_k1_rem >= h1 + h2)) then + mergeable_bl = .true. + dPE_merge_nB = g_2*GV%H_to_RZ**2*(SpV0(i,kb1)-SpV0(i,kb2)) * ((h1-stays_merge)*(h2-stays_merge)) + endif + else + stays_min_merge = MAX(h_min_bl, 2.0*h_min_bl - h_to_bl, & + h1 - (h1+h2)*(R0(i,kb1) - R0_det) / (R0(i,kb2) - R0(i,kb1))) + if ((stays_merge > stays_min_merge) .and. (stays_merge + h2_to_k1_rem >= h1 + h2)) then + mergeable_bl = .true. + dPE_merge = g_2*(R0(i,kb2)-R0(i,kb1)) * (h1-stays_merge)*(h2-stays_merge) + endif endif endif @@ -2601,9 +3006,14 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, (dT_dS_gauge * dRcv_dT(i) * dRcv + dRcv_dS(i) * dSpice_det) S_det = S(i,kb2) + I_denom * & (dRcv_dS(i) * dRcv - dT_dS_gauge * dRcv_dT(i) * dSpice_det) - ! The detrained values of R0 are based on changes in T and S. - R0_det = R0(i,kb2) + (T_det-T(i,kb2)) * dR0_dT(i) + & - (S_det-S(i,kb2)) * dR0_dS(i) + ! The detrained values of R0 or SpV0 are based on changes in T and S. + if (CS%nonBous_energetics) then + SpV0_det = SpV0(i,kb2) + (T_det-T(i,kb2)) * dSpV0_dT(i) + & + (S_det-S(i,kb2)) * dSpV0_dS(i) + else + R0_det = R0(i,kb2) + (T_det-T(i,kb2)) * dR0_dT(i) + & + (S_det-S(i,kb2)) * dR0_dS(i) + endif ! Now that the properties of the detrained water are known, ! potentially limit the amount of water that is detrained to @@ -2669,9 +3079,14 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, S(i,kb2) = (h2*S(i,kb2) - h2_to_k1*S_det) * Ih2f S(i,k1) = ((h(i,k1)+h_neglect)*S(i,k1) + h2_to_k1*S_det) * Ihk1 - ! Changes in R0 are based on changes in T and S. - R0(i,kb2) = (h2*R0(i,kb2) - h2_to_k1*R0_det) * Ih2f - R0(i,k1) = ((h(i,k1)+h_neglect)*R0(i,k1) + h2_to_k1*R0_det) * Ihk1 + ! Changes in R0 or SpV0 are based on changes in T and S. + if (CS%nonBous_energetics) then + SpV0(i,kb2) = (h2*SpV0(i,kb2) - h2_to_k1*SpV0_det) * Ih2f + SpV0(i,k1) = ((h(i,k1)+h_neglect)*SpV0(i,k1) + h2_to_k1*SpV0_det) * Ihk1 + else + R0(i,kb2) = (h2*R0(i,kb2) - h2_to_k1*R0_det) * Ih2f + R0(i,k1) = ((h(i,k1)+h_neglect)*R0(i,k1) + h2_to_k1*R0_det) * Ihk1 + endif else ! h2==h2_to_k1 can happen if dR2b = 0 exactly, but this is very ! unlikely. In this case the entirety of layer kb2 is detrained. @@ -2681,13 +3096,22 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, Rcv(i,k1) = (h(i,k1)*Rcv(i,k1) + h2*Rcv(i,kb2)) * Ihk1 T(i,k1) = (h(i,k1)*T(i,k1) + h2*T(i,kb2)) * Ihk1 S(i,k1) = (h(i,k1)*S(i,k1) + h2*S(i,kb2)) * Ihk1 - R0(i,k1) = (h(i,k1)*R0(i,k1) + h2*R0(i,kb2)) * Ihk1 + if (CS%nonBous_energetics) then + SpV0(i,k1) = (h(i,k1)*SpV0(i,k1) + h2*SpV0(i,kb2)) * Ihk1 + else + R0(i,k1) = (h(i,k1)*R0(i,k1) + h2*R0(i,kb2)) * Ihk1 + endif endif h(i,k1) = h(i,k1) + h2_to_k1 h(i,kb2) = h(i,kb2) - h2_to_k1 ; h2 = h(i,kb2) - ! dPE_extrap should be positive here. - dPE_extrap = I2Rho0*(R0_det-R0(i,kb2))*h2_to_k1*h2 + ! dPE_extrap_rhoG should be positive here. + if (CS%nonBous_energetics) then + dPE_extrap_rhoG = 0.5*(SpV0(i,kb2)-SpV0_det) * (h2_to_k1*h2) / SpV0(i,k1) + dPE_extrapolate = 0.5*GV%g_Earth_Z_T2*GV%H_to_RZ**2*(SpV0(i,kb2)-SpV0_det) * (h2_to_k1*h2) + else + dPE_extrap_rhoG = I2Rho0*(R0_det-R0(i,kb2))*h2_to_k1*h2 + endif d_ea(i,kb2) = d_ea(i,kb2) - h2_to_k1 d_ea(i,k1) = d_ea(i,k1) + h2_to_k1 @@ -2714,9 +3138,15 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, Ihdet = 0.0 ; if (h_to_bl > 0.0) Ihdet = 1.0 / h_to_bl Ih1f = 1.0 / (h_det_to_h1 + h_ml_to_h1) - R0(i,kb2) = ((h2*R0(i,kb2) + h1*R0(i,kb1)) + & - (h_det_to_h2*R0_to_bl*Ihdet + h_ml_to_h2*R0(i,0))) * Ih - R0(i,kb1) = (h_det_to_h1*R0_to_bl*Ihdet + h_ml_to_h1*R0(i,0)) * Ih1f + if (CS%nonBous_energetics) then + SpV0(i,kb2) = ((h2*SpV0(i,kb2) + h1*SpV0(i,kb1)) + & + (h_det_to_h2*SpV0_to_bl*Ihdet + h_ml_to_h2*SpV0(i,0))) * Ih + SpV0(i,kb1) = (h_det_to_h1*SpV0_to_bl*Ihdet + h_ml_to_h1*SpV0(i,0)) * Ih1f + else + R0(i,kb2) = ((h2*R0(i,kb2) + h1*R0(i,kb1)) + & + (h_det_to_h2*R0_to_bl*Ihdet + h_ml_to_h2*R0(i,0))) * Ih + R0(i,kb1) = (h_det_to_h1*R0_to_bl*Ihdet + h_ml_to_h1*R0(i,0)) * Ih1f + endif Rcv(i,kb2) = ((h2*Rcv(i,kb2) + h1*Rcv(i,kb1)) + & (h_det_to_h2*Rcv_to_bl*Ihdet + h_ml_to_h2*Rcv(i,0))) * Ih @@ -2740,18 +3170,30 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, if (allocated(CS%diag_PE_detrain) .or. allocated(CS%diag_PE_detrain2)) then - R0_det = R0_to_bl*Ihdet - s1en = g_2 * Idt_H2 * ( ((R0(i,kb2)-R0(i,kb1))*h1*h2 + & - h_det_to_h2*( (R0(i,kb1)-R0_det)*h1 + (R0(i,kb2)-R0_det)*h2 ) + & - h_ml_to_h2*( (R0(i,kb2)-R0(i,0))*h2 + (R0(i,kb1)-R0(i,0))*h1 + & - (R0_det-R0(i,0))*h_det_to_h2 ) + & - h_det_to_h1*h_ml_to_h1*(R0_det-R0(i,0))) - 2.0*GV%Rho0*dPE_extrap ) + if (CS%nonBous_energetics) then + SpV0_det = SpV0_to_bl*Ihdet + s1en = Idt_diag * ( -GV%H_to_RZ**2 * g_2 * ((SpV0(i,kb2)-SpV0(i,kb1))*h1*h2 + & + h_det_to_h2*( (SpV0(i,kb1)-SpV0_det)*h1 + (SpV0(i,kb2)-SpV0_det)*h2 ) + & + h_ml_to_h2*( (SpV0(i,kb2)-SpV0(i,0))*h2 + (SpV0(i,kb1)-SpV0(i,0))*h1 + & + (SpV0_det-SpV0(i,0))*h_det_to_h2 ) + & + h_det_to_h1*h_ml_to_h1*(SpV0_det-SpV0(i,0))) - dPE_extrapolate ) + + if (allocated(CS%diag_PE_detrain2)) & + CS%diag_PE_detrain2(i,j) = CS%diag_PE_detrain2(i,j) + s1en + Idt_diag*dPE_extrapolate + else + R0_det = R0_to_bl*Ihdet + s1en = g_2 * Idt_H2 * ( ((R0(i,kb2)-R0(i,kb1))*h1*h2 + & + h_det_to_h2*( (R0(i,kb1)-R0_det)*h1 + (R0(i,kb2)-R0_det)*h2 ) + & + h_ml_to_h2*( (R0(i,kb2)-R0(i,0))*h2 + (R0(i,kb1)-R0(i,0))*h1 + & + (R0_det-R0(i,0))*h_det_to_h2 ) + & + h_det_to_h1*h_ml_to_h1*(R0_det-R0(i,0))) - 2.0*GV%Rho0*dPE_extrap_rhoG ) + + if (allocated(CS%diag_PE_detrain2)) & + CS%diag_PE_detrain2(i,j) = CS%diag_PE_detrain2(i,j) + s1en + Idt_H2*Rho0xG*dPE_extrap_rhoG + endif if (allocated(CS%diag_PE_detrain)) & CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + s1en - - if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & - CS%diag_PE_detrain2(i,j) + s1en + Idt_H2*Rho0xG*dPE_extrap endif elseif ((h_to_bl > 0.0) .or. (h1 < h_min_bl) .or. (h2 < h_min_bl)) then @@ -2763,8 +3205,18 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, if (h_from_ml > 0.0) then ! Some water needs to be moved from the mixed layer so that the upper ! (and perhaps lower) buffer layers exceed their minimum thicknesses. - dPE_extrap = dPE_extrap - I2Rho0*h_from_ml*(R0_to_bl - R0(i,0)*h_to_bl) - R0_to_bl = R0_to_bl + h_from_ml*R0(i,0) + if (CS%nonBous_energetics) then + ! The choice of which specific volume to use in the denominator could be revisited. + ! dPE_extrap_rhoG = dPE_extrap_rhoG + 0.5*h_from_ml*(SpV0_to_bl - SpV0(i,0)*h_to_bl) / SpV0(i,0) + dPE_extrap_rhoG = dPE_extrap_rhoG + 0.5*h_from_ml*(SpV0_to_bl - SpV0(i,0)*h_to_bl) * & + ( (h_to_bl + h_from_ml) / (SpV0_to_bl + h_from_ml*SpV0(i,0)) ) + dPE_extrapolate = dPE_extrapolate + 0.5*GV%g_Earth_Z_T2*GV%H_to_RZ**2 * & + h_from_ml*(SpV0_to_bl - SpV0(i,0)*h_to_bl) + SpV0_to_bl = SpV0_to_bl + h_from_ml*SpV0(i,0) + else + dPE_extrap_rhoG = dPE_extrap_rhoG - I2Rho0*h_from_ml*(R0_to_bl - R0(i,0)*h_to_bl) + R0_to_bl = R0_to_bl + h_from_ml*R0(i,0) + endif Rcv_to_bl = Rcv_to_bl + h_from_ml*Rcv(i,0) T_to_bl = T_to_bl + h_from_ml*T(i,0) S_to_bl = S_to_bl + h_from_ml*S(i,0) @@ -2776,8 +3228,13 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, ! The absolute value should be unnecessary and 1e9 is just a large number. b1 = 1.0e9 - if (R0(i,kb2) - R0(i,kb1) > 1.0e-9*abs(R0(i,kb1) - R0_det)) & - b1 = abs(R0(i,kb1) - R0_det) / (R0(i,kb2) - R0(i,kb1)) + if (CS%nonBous_energetics) then + if (SpV0(i,kb1) - SpV0(i,kb2) > 1.0e-9*abs(SpV0_det - SpV0(i,kb1))) & + b1 = abs(SpV0_det - SpV0(i,kb1)) / (SpV0(i,kb1) - SpV0(i,kb2)) + else + if (R0(i,kb2) - R0(i,kb1) > 1.0e-9*abs(R0(i,kb1) - R0_det)) & + b1 = abs(R0(i,kb1) - R0_det) / (R0(i,kb2) - R0(i,kb1)) + endif stays_min = MAX((1.0-b1)*h1 - b1*h2, 0.0, h_min_bl - h_to_bl) stays_max = h1 - MAX(h_min_bl-h2,0.0) @@ -2797,9 +3254,9 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, if (s2 < 0.0) then ! The energy released by detrainment from the lower buffer layer can be ! used to mix water from the upper buffer layer into the lower one. - s3sq = I_ya*MAX(bh0*h1-dPE_extrap, 0.0) + s3sq = I_ya*MAX(bh0*h1-dPE_extrap_rhoG, 0.0) else - s3sq = I_ya*(bh0*h1-MIN(dPE_extrap,0.0)) + s3sq = I_ya*(bh0*h1-MIN(dPE_extrap_rhoG,0.0)) endif if (s3sq == 0.0) then @@ -2837,10 +3294,17 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, endif endif - dPE_det = g_2*((R0(i,kb1)*h_to_bl - R0_to_bl)*stays + & - (R0(i,kb2)-R0(i,kb1)) * (h1-stays) * & - (h2 - scale_slope*stays*((h1+h2)+h_to_bl)/(h1+h2)) ) - & - Rho0xG*dPE_extrap + if (CS%nonBous_energetics) then + dPE_det_nB = -g_2*GV%H_to_RZ**2*((SpV0(i,kb1)*h_to_bl - SpV0_to_bl)*stays + & + (SpV0(i,kb2)-SpV0(i,kb1)) * (h1-stays) * & + (h2 - scale_slope*stays*((h1+h2)+h_to_bl)/(h1+h2)) ) - & + dPE_extrapolate + else + dPE_det = g_2*((R0(i,kb1)*h_to_bl - R0_to_bl)*stays + & + (R0(i,kb2)-R0(i,kb1)) * (h1-stays) * & + (h2 - scale_slope*stays*((h1+h2)+h_to_bl)/(h1+h2)) ) - & + Rho0xG*dPE_extrap_rhoG + endif if (dPE_time_ratio*h_to_bl > h_to_bl+h(i,0)) then dPE_ratio = (h_to_bl+h(i,0)) / h_to_bl @@ -2848,7 +3312,13 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, dPE_ratio = dPE_time_ratio endif - if ((mergeable_bl) .and. (num_events*dPE_ratio*dPE_det > dPE_merge)) then + if (CS%nonBous_energetics) then + better_to_merge = (num_events*dPE_ratio*dPE_det_nB > dPE_merge_nB) + else + better_to_merge = (num_events*dPE_ratio*dPE_det > dPE_merge) + endif + + if (mergeable_bl .and. better_to_merge) then ! It is energetically preferable to merge the two buffer layers, detrain ! them into interior layer (k0), move the remaining upper buffer layer ! water into the lower buffer layer, and detrain undiluted into the @@ -2858,7 +3328,7 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, h1_to_h2 = stays_merge - stays Ihk0 = 1.0 / ((h1_to_k0 + h2) + h(i,k0)) - Ih1f = 1.0 / (h_to_bl + stays); Ih2f = 1.0 / h1_to_h2 + Ih1f = 1.0 / (h_to_bl + stays) ; Ih2f = 1.0 / h1_to_h2 Ih12 = 1.0 / (h1 + h2) dRcv_2dz = (Rcv(i,kb1) - Rcv(i,kb2)) * Ih12 @@ -2875,8 +3345,14 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, I_denom = 1.0 / (dRcv_dS(i)**2 + (dT_dS_gauge*dRcv_dT(i))**2) dSpice_2dz = (dS_dT_gauge*dRcv_dS(i)*(T(i,kb1)-T(i,kb2)) - & dT_dS_gauge*dRcv_dT(i)*(S(i,kb1)-S(i,kb2))) * Ih12 - dSpice_lim = (dS_dT_gauge*dR0_dS(i)*(T_to_bl-T(i,kb1)*h_to_bl) - & - dT_dS_gauge*dR0_dT(i)*(S_to_bl-S(i,kb1)*h_to_bl)) / h_to_bl + if (CS%nonBous_energetics) then + ! Use the specific volume differences to limit the coordinate density change. + dSpice_lim = -Rcv(i,kb1) * (dS_dT_gauge*dSpV0_dS(i)*(T_to_bl-T(i,kb1)*h_to_bl) - & + dT_dS_gauge*dSpV0_dT(i)*(S_to_bl-S(i,kb1)*h_to_bl)) / (SpV0(i,kb1) * h_to_bl) + else + dSpice_lim = (dS_dT_gauge*dR0_dS(i)*(T_to_bl-T(i,kb1)*h_to_bl) - & + dT_dS_gauge*dR0_dT(i)*(S_to_bl-S(i,kb1)*h_to_bl)) / h_to_bl + endif if (dSpice_lim * dSpice_2dz <= 0.0) dSpice_2dz = 0.0 if (stays > 0.0) then @@ -2889,15 +3365,20 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, (dT_dS_gauge * dRcv_dT(i) * dRcv_stays + dRcv_dS(i) * dSpice_stays) S_stays = S(i,kb1) + I_denom * & (dRcv_dS(i) * dRcv_stays - dT_dS_gauge * dRcv_dT(i) * dSpice_stays) - ! The values of R0 are based on changes in T and S. - R0_stays = R0(i,kb1) + (T_stays-T(i,kb1)) * dR0_dT(i) + & - (S_stays-S(i,kb1)) * dR0_dS(i) + ! The values of R0 or SpV0 are based on changes in T and S. + if (CS%nonBous_energetics) then + SpV0_stays = SpV0(i,kb1) + (T_stays-T(i,kb1)) * dSpV0_dT(i) + & + (S_stays-S(i,kb1)) * dSpV0_dS(i) + else + R0_stays = R0(i,kb1) + (T_stays-T(i,kb1)) * dR0_dT(i) + & + (S_stays-S(i,kb1)) * dR0_dS(i) + endif else ! Limit the spiciness of the water that moves into the lower buffer layer. if (abs(dSpice_lim) < abs(dSpice_2dz*h1_to_k0)) & dSpice_2dz = dSpice_lim/h1_to_k0 ! These will be multiplied by 0 later. - T_stays = 0.0 ; S_stays = 0.0 ; R0_stays = 0.0 + T_stays = 0.0 ; S_stays = 0.0 ; R0_stays = 0.0 ; SpV0_stays = 0.0 endif dSpice_det = - dSpice_2dz*(stays + h1_to_h2) @@ -2905,9 +3386,14 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, (dT_dS_gauge * dRcv_dT(i) * dRcv_det + dRcv_dS(i) * dSpice_det) S_det = S(i,kb1) + I_denom * & (dRcv_dS(i) * dRcv_det - dT_dS_gauge * dRcv_dT(i) * dSpice_det) - ! The values of R0 are based on changes in T and S. - R0_det = R0(i,kb1) + (T_det-T(i,kb1)) * dR0_dT(i) + & - (S_det-S(i,kb1)) * dR0_dS(i) + ! The values of R0 or SpV0 are based on changes in T and S. + if (CS%nonBous_energetics) then + SpV0_det = SpV0(i,kb1) + (T_det-T(i,kb1)) * dSpV0_dT(i) + & + (S_det-S(i,kb1)) * dSpV0_dS(i) + else + R0_det = R0(i,kb1) + (T_det-T(i,kb1)) * dR0_dT(i) + & + (S_det-S(i,kb1)) * dR0_dS(i) + endif T(i,k0) = ((h1_to_k0*T_det + h2*T(i,kb2)) + h(i,k0)*T(i,k0)) * Ihk0 T(i,kb2) = (h1*T(i,kb1) - stays*T_stays - h1_to_k0*T_det) * Ih2f @@ -2917,29 +3403,40 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, S(i,kb2) = (h1*S(i,kb1) - stays*S_stays - h1_to_k0*S_det) * Ih2f S(i,kb1) = (S_to_bl + stays*S_stays) * Ih1f - R0(i,k0) = ((h1_to_k0*R0_det + h2*R0(i,kb2)) + h(i,k0)*R0(i,k0)) * Ihk0 - R0(i,kb2) = (h1*R0(i,kb1) - stays*R0_stays - h1_to_k0*R0_det) * Ih2f - R0(i,kb1) = (R0_to_bl + stays*R0_stays) * Ih1f + if (CS%nonBous_energetics) then + SpV0(i,k0) = ((h1_to_k0*SpV0_det + h2*SpV0(i,kb2)) + h(i,k0)*SpV0(i,k0)) * Ihk0 + SpV0(i,kb2) = (h1*SpV0(i,kb1) - stays*SpV0_stays - h1_to_k0*SpV0_det) * Ih2f + SpV0(i,kb1) = (SpV0_to_bl + stays*SpV0_stays) * Ih1f + else + R0(i,k0) = ((h1_to_k0*R0_det + h2*R0(i,kb2)) + h(i,k0)*R0(i,k0)) * Ihk0 + R0(i,kb2) = (h1*R0(i,kb1) - stays*R0_stays - h1_to_k0*R0_det) * Ih2f + R0(i,kb1) = (R0_to_bl + stays*R0_stays) * Ih1f + endif ! ! The following is 2nd-order upwind advection without limiters. ! dT_2dz = (T(i,kb1) - T(i,kb2)) * Ih12 ! T(i,k0) = (h1_to_k0*(T(i,kb1) - dT_2dz*(stays+h1_to_h2)) + & ! h2*T(i,kb2) + h(i,k0)*T(i,k0)) * Ihk0 ! T(i,kb2) = T(i,kb1) + dT_2dz*(h1_to_k0-stays) -! T(i,kb1) = (T_to_bl + stays*(T(i,kb1) + & -! dT_2dz*(h1_to_k0 + h1_to_h2))) * Ih1f +! T(i,kb1) = (T_to_bl + stays*(T(i,kb1) + dT_2dz*(h1_to_k0 + h1_to_h2))) * Ih1f ! dS_2dz = (S(i,kb1) - S(i,kb2)) * Ih12 ! S(i,k0) = (h1_to_k0*(S(i,kb1) - dS_2dz*(stays+h1_to_h2)) + & ! h2*S(i,kb2) + h(i,k0)*S(i,k0)) * Ihk0 ! S(i,kb2) = S(i,kb1) + dS_2dz*(h1_to_k0-stays) -! S(i,kb1) = (S_to_bl + stays*(S(i,kb1) + & -! dS_2dz*(h1_to_k0 + h1_to_h2))) * Ih1f -! dR0_2dz = (R0(i,kb1) - R0(i,kb2)) * Ih12 -! R0(i,k0) = (h1_to_k0*(R0(i,kb1) - dR0_2dz*(stays+h1_to_h2)) + & -! h2*R0(i,kb2) + h(i,k0)*R0(i,k0)) * Ihk0 -! R0(i,kb2) = R0(i,kb1) + dR0_2dz*(h1_to_k0-stays) -! R0(i,kb1) = (R0_to_bl + stays*(R0(i,kb1) + & -! dR0_2dz*(h1_to_k0 + h1_to_h2))) * Ih1f +! S(i,kb1) = (S_to_bl + stays*(S(i,kb1) + dS_2dz*(h1_to_k0 + h1_to_h2))) * Ih1f +! if (CS%nonBous_energetics) then +! dSpV0_2dz = (SpV0(i,kb1) - SpV0(i,kb2)) * Ih12 +! SpV0(i,k0) = (h1_to_k0*(SpV0(i,kb1) - dSpV0_2dz*(stays+h1_to_h2)) + & +! h2*SpV0(i,kb2) + h(i,k0)*SpV0(i,k0)) * Ihk0 +! SpV0(i,kb2) = SpV0(i,kb1) + dSpV0_2dz*(h1_to_k0-stays) +! SpV0(i,kb1) = (SpV0_to_bl + stays*(SpV0(i,kb1) + dSpV0_2dz*(h1_to_k0 + h1_to_h2))) * Ih1f +! else +! dR0_2dz = (R0(i,kb1) - R0(i,kb2)) * Ih12 +! R0(i,k0) = (h1_to_k0*(R0(i,kb1) - dR0_2dz*(stays+h1_to_h2)) + & +! h2*R0(i,kb2) + h(i,k0)*R0(i,k0)) * Ihk0 +! R0(i,kb2) = R0(i,kb1) + dR0_2dz*(h1_to_k0-stays) +! R0(i,kb1) = (R0_to_bl + stays*(R0(i,kb1) + dR0_2dz*(h1_to_k0 + h1_to_h2))) * Ih1f +! endif d_ea(i,kb1) = (d_ea(i,kb1) + h_to_bl) + (stays - h1) d_ea(i,kb2) = d_ea(i,kb2) + (h1_to_h2 - h2) @@ -2948,10 +3445,17 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, h(i,kb1) = stays + h_to_bl h(i,kb2) = h1_to_h2 h(i,k0) = h(i,k0) + (h1_to_k0 + h2) - if (allocated(CS%diag_PE_detrain)) & - CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + Idt_H2*dPE_merge - if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & - CS%diag_PE_detrain2(i,j) + Idt_H2*(dPE_det + Rho0xG*dPE_extrap) + if (CS%nonBous_energetics) then + if (allocated(CS%diag_PE_detrain)) & + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + Idt_diag*dPE_merge_nB + if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & + CS%diag_PE_detrain2(i,j) + Idt_diag*(dPE_det_nB + dPE_extrapolate) + else + if (allocated(CS%diag_PE_detrain)) & + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + Idt_H2*dPE_merge + if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & + CS%diag_PE_detrain2(i,j) + Idt_H2*(dPE_det + Rho0xG*dPE_extrap_rhoG) + endif else ! Not mergeable_bl. ! There is no further detrainment from the buffer layers, and the ! upper buffer layer water is distributed optimally between the @@ -2959,37 +3463,64 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, h1_to_h2 = h1 - stays Ih1f = 1.0 / (h_to_bl + stays) ; Ih2f = 1.0 / (h2 + h1_to_h2) Ih = 1.0 / (h1 + h2) - dR0_2dz = (R0(i,kb1) - R0(i,kb2)) * Ih - R0(i,kb2) = (h2*R0(i,kb2) + h1_to_h2*(R0(i,kb1) - & - scale_slope*dR0_2dz*stays)) * Ih2f - R0(i,kb1) = (R0_to_bl + stays*(R0(i,kb1) + & - scale_slope*dR0_2dz*h1_to_h2)) * Ih1f - - ! Use 2nd order upwind advection of spiciness, limited by the value - ! in the detrained water to determine the detrained temperature and - ! salinity. - dR0 = scale_slope*dR0_2dz*h1_to_h2 - dSpice_stays = (dS_dT_gauge*dR0_dS(i)*(T(i,kb1)-T(i,kb2)) - & - dT_dS_gauge*dR0_dT(i)*(S(i,kb1)-S(i,kb2))) * & - scale_slope*h1_to_h2 * Ih - if (h_to_bl > 0.0) then - dSpice_lim = (dS_dT_gauge*dR0_dS(i)*(T_to_bl-T(i,kb1)*h_to_bl) - & - dT_dS_gauge*dR0_dT(i)*(S_to_bl-S(i,kb1)*h_to_bl)) /& - h_to_bl + if (CS%nonBous_energetics) then + dSpV0_2dz = (SpV0(i,kb1) - SpV0(i,kb2)) * Ih + SpV0(i,kb2) = (h2*SpV0(i,kb2) + h1_to_h2*(SpV0(i,kb1) - scale_slope*dSpV0_2dz*stays)) * Ih2f + SpV0(i,kb1) = (SpV0_to_bl + stays*(SpV0(i,kb1) + scale_slope*dSpV0_2dz*h1_to_h2)) * Ih1f else - dSpice_lim = dS_dT_gauge*dR0_dS(i)*(T(i,0)-T(i,kb1)) - & - dT_dS_gauge*dR0_dT(i)*(S(i,0)-S(i,kb1)) + dR0_2dz = (R0(i,kb1) - R0(i,kb2)) * Ih + R0(i,kb2) = (h2*R0(i,kb2) + h1_to_h2*(R0(i,kb1) - scale_slope*dR0_2dz*stays)) * Ih2f + R0(i,kb1) = (R0_to_bl + stays*(R0(i,kb1) + scale_slope*dR0_2dz*h1_to_h2)) * Ih1f endif - if (dSpice_stays*dSpice_lim <= 0.0) then - dSpice_stays = 0.0 - elseif (abs(dSpice_stays) > abs(dSpice_lim)) then - dSpice_stays = dSpice_lim + + ! Use 2nd order upwind advection of spiciness, limited by the value in the + ! detrained water to determine the detrained temperature and salinity. + if (CS%nonBous_energetics) then + dSpV0 = scale_slope*dSpV0_2dz*h1_to_h2 + dSpiceSpV_stays = (dS_dT_gauge*dSpV0_dS(i)*(T(i,kb1)-T(i,kb2)) - & + dT_dS_gauge*dSpV0_dT(i)*(S(i,kb1)-S(i,kb2))) * & + scale_slope*h1_to_h2 * Ih + if (h_to_bl > 0.0) then + dSpiceSpV_lim = (dS_dT_gauge*dSpV0_dS(i)*(T_to_bl-T(i,kb1)*h_to_bl) - & + dT_dS_gauge*dSpV0_dT(i)*(S_to_bl-S(i,kb1)*h_to_bl)) / h_to_bl + else + dSpiceSpV_lim = dS_dT_gauge*dSpV0_dS(i)*(T(i,0)-T(i,kb1)) - & + dT_dS_gauge*dSpV0_dT(i)*(S(i,0)-S(i,kb1)) + endif + if (dSpiceSpV_stays*dSpiceSpV_lim <= 0.0) then + dSpiceSpV_stays = 0.0 + elseif (abs(dSpiceSpV_stays) > abs(dSpiceSpV_lim)) then + dSpiceSpV_stays = dSpiceSpV_lim + endif + I_denom = 1.0 / (dSpV0_dS(i)**2 + (dT_dS_gauge*dSpV0_dT(i))**2) + T_stays = T(i,kb1) + dT_dS_gauge * I_denom * & + (dT_dS_gauge * dSpV0_dT(i) * dSpV0 + dSpV0_dS(i) * dSpiceSpV_stays) + S_stays = S(i,kb1) + I_denom * & + (dSpV0_dS(i) * dSpV0 - dT_dS_gauge * dSpV0_dT(i) * dSpiceSpV_stays) + else + dR0 = scale_slope*dR0_2dz*h1_to_h2 + dSpice_stays = (dS_dT_gauge*dR0_dS(i)*(T(i,kb1)-T(i,kb2)) - & + dT_dS_gauge*dR0_dT(i)*(S(i,kb1)-S(i,kb2))) * & + scale_slope*h1_to_h2 * Ih + if (h_to_bl > 0.0) then + dSpice_lim = (dS_dT_gauge*dR0_dS(i)*(T_to_bl-T(i,kb1)*h_to_bl) - & + dT_dS_gauge*dR0_dT(i)*(S_to_bl-S(i,kb1)*h_to_bl)) / h_to_bl + else + dSpice_lim = dS_dT_gauge*dR0_dS(i)*(T(i,0)-T(i,kb1)) - & + dT_dS_gauge*dR0_dT(i)*(S(i,0)-S(i,kb1)) + endif + if (dSpice_stays*dSpice_lim <= 0.0) then + dSpice_stays = 0.0 + elseif (abs(dSpice_stays) > abs(dSpice_lim)) then + dSpice_stays = dSpice_lim + endif + I_denom = 1.0 / (dR0_dS(i)**2 + (dT_dS_gauge*dR0_dT(i))**2) + T_stays = T(i,kb1) + dT_dS_gauge * I_denom * & + (dT_dS_gauge * dR0_dT(i) * dR0 + dR0_dS(i) * dSpice_stays) + S_stays = S(i,kb1) + I_denom * & + (dR0_dS(i) * dR0 - dT_dS_gauge * dR0_dT(i) * dSpice_stays) endif - I_denom = 1.0 / (dR0_dS(i)**2 + (dT_dS_gauge*dR0_dT(i))**2) - T_stays = T(i,kb1) + dT_dS_gauge * I_denom * & - (dT_dS_gauge * dR0_dT(i) * dR0 + dR0_dS(i) * dSpice_stays) - S_stays = S(i,kb1) + I_denom * & - (dR0_dS(i) * dR0 - dT_dS_gauge * dR0_dT(i) * dSpice_stays) + ! The detrained values of Rcv are based on changes in T and S. Rcv_stays = Rcv(i,kb1) + (T_stays-T(i,kb1)) * dRcv_dT(i) + & (S_stays-S(i,kb1)) * dRcv_dS(i) @@ -3024,10 +3555,19 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, h(i,kb1) = stays + h_to_bl h(i,kb2) = h(i,kb2) + h1_to_h2 - if (allocated(CS%diag_PE_detrain)) & - CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + Idt_H2*dPE_det - if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & - CS%diag_PE_detrain2(i,j) + Idt_H2*(dPE_det + Rho0xG*dPE_extrap) + if (CS%nonBous_energetics) then + if (allocated(CS%diag_PE_detrain)) & + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + Idt_diag*dPE_det_nB + if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & + CS%diag_PE_detrain2(i,j) + Idt_diag*(dPE_det_nB + dPE_extrapolate) + else + ! Recasting dPE_det into the same units as dPE_det_nB changes these diagnostics slightly + ! in some cases for reasons that are not understood. + if (allocated(CS%diag_PE_detrain)) & + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + Idt_H2*dPE_det + if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & + CS%diag_PE_detrain2(i,j) + Idt_H2*(dPE_det + Rho0xG*dPE_extrap_rhoG) + endif endif endif ! End of detrainment... @@ -3038,16 +3578,18 @@ end subroutine mixedlayer_detrain_2 !> This subroutine moves any water left in the former mixed layers into the !! single buffer layers and may also move buffer layer water into the interior !! isopycnal layers. -subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_eb, & +subroutine mixedlayer_detrain_1(h, T, S, R0, SpV0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_eb, & j, G, GV, US, CS, dRcv_dT, dRcv_dS, max_BL_det) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2]. !! Layer 0 is the new mixed layer. - real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: T !< Potential temperature [degC]. - real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Salinity [ppt]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: T !< Potential temperature [C ~> degC]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Salinity [S ~> ppt]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: R0 !< Potential density referenced to !! surface pressure [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg-1] real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: Rcv !< The coordinate defining potential !! density [R ~> kg m-3]. real, dimension(SZK_(GV)), intent(in) :: RcvTgt !< The target value of Rcv for each @@ -3065,14 +3607,14 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e !! a layer. integer, intent(in) :: j !< The meridional row to work on. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control struct + type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control structure real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of !! coordinate defining potential density !! with potential temperature - !! [R degC-1 ~> kg m-3 degC-1]. + !! [R C-1 ~> kg m-3 degC-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dS !< The partial derivative of !! coordinate defining potential density - !! with salinity [R ppt-1 ~> kg m-3 ppt-1]. + !! with salinity [R S-1 ~> kg m-3 ppt-1]. real, dimension(SZI_(G)), intent(in) :: max_BL_det !< If non-negative, the maximum !! detrainment permitted from the buffer !! layers [H ~> m or kg m-2]. @@ -3084,45 +3626,81 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e real :: max_det_rem(SZI_(G)) ! Remaining permitted detrainment [H ~> m or kg m-2]. real :: detrain(SZI_(G)) ! The thickness of fluid to detrain ! from the mixed layer [H ~> m or kg m-2]. - real :: dT_dR, dS_dR, dRml, dR0_dRcv, dT_dS_wt2 - real :: I_denom ! A work variable [ppt2 R-2 ~> ppt2 m6 kg-2]. - real :: Sdown, Tdown + real :: dT_dS_wt2 ! The square of the relative weighting of temperature and salinity changes + ! when extraploating to match a target density [C2 S-2 ~> degC2 ppt-2] + real :: dT_dR ! The ratio of temperature changes to density changes when + ! extrapolating [C R-1 ~> degC m3 kg-1] + real :: dS_dR ! The ratio of salinity changes to density changes when + ! extrapolating [S R-1 ~> ppt m3 kg-1] + real :: dRml ! The density range within the extent of the mixed layers [R ~> kg m-3] + real :: dR0_dRcv ! The relative changes in the potential density and the coordinate density [nondim] + real :: dSpV0_dRcv ! The relative changes in the specific volume and the coordinate density [R-2 ~> m6 kg-2] + real :: I_denom ! A work variable [S2 R-2 ~> ppt2 m6 kg-2]. + real :: Sdown ! The salinity of the detrained water [S ~> ppt] + real :: Tdown ! The temperature of the detrained water [C ~> degC] real :: dt_Time ! The timestep divided by the detrainment timescale [nondim]. - real :: g_H2_2Rho0dt ! Half the gravitational acceleration times the square of the + real :: g_H_2Rho0dt ! Half the gravitational acceleration times the ! conversion from H to m divided by the mean density times the time - ! step [L2 Z T-3 H-2 R-1 ~> m4 s-3 kg-1 or m10 s-3 kg-3]. + ! step [Z2 T-3 H-1 R-1 ~> m4 s-3 kg-1 or m7 s-3 kg-2]. real :: g_H2_2dt ! Half the gravitational acceleration times the square of the ! conversion from H to Z divided by the diagnostic time step - ! [L2 Z H-2 T-3 ~> m s-3 or m7 kg-2 s-3]. - + ! [Z3 H-2 T-3 ~> m s-3 or m7 kg-2 s-3]. + real :: nB_g_H_2dt ! Half the gravitational acceleration times the conversion from + ! H to RZ divided by the diagnostic time step + ! [R Z2 H-1 T-3 ~> kg m-2 s-3 or m s-3]. + real :: nB_gRZ_H2_2dt ! Half the gravitational acceleration times the conversion from + ! H to RZ squared divided by the diagnostic time step + ! [R2 Z3 H-2 T-3 ~> kg2 m-5 s-3 or m s-3] + real :: x1 ! A temporary work variable [various] logical :: splittable_BL(SZI_(G)), orthogonal_extrap - real :: x1 - + logical :: must_unmix integer :: i, is, ie, k, k1, nkmb, nz + is = G%isc ; ie = G%iec ; nz = GV%ke nkmb = CS%nkml+CS%nkbl if (CS%nkbl /= 1) call MOM_error(FATAL,"MOM_mixed_layer: "// & "CS%nkbl must be 1 in mixedlayer_detrain_1.") dt_Time = dt / CS%BL_detrain_time - g_H2_2Rho0dt = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * GV%Rho0 * dt_diag) - g_H2_2dt = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * dt_diag) + + if (CS%nonBous_energetics) then + nB_g_H_2dt = (GV%g_Earth_Z_T2 * GV%H_to_RZ) / (2.0 * dt_diag) + nB_gRZ_H2_2dt = GV%H_to_RZ * nB_g_H_2dt + else + g_H2_2dt = (GV%g_Earth_Z_T2 * GV%H_to_Z**2) / (2.0 * dt_diag) + g_H_2Rho0dt = g_H2_2dt * GV%RZ_to_H + endif ! Move detrained water into the buffer layer. do k=1,CS%nkml do i=is,ie ; if (h(i,k) > 0.0) then Ih = 1.0 / (h(i,nkmb) + h(i,k)) - if (CS%TKE_diagnostics) & - CS%diag_TKE_conv_s2(i,j) = CS%diag_TKE_conv_s2(i,j) + & - g_H2_2Rho0dt * h(i,k) * h(i,nkmb) * (R0(i,nkmb) - R0(i,k)) - if (allocated(CS%diag_PE_detrain)) & - CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + & - g_H2_2dt * h(i,k) * h(i,nkmb) * (R0(i,nkmb) - R0(i,k)) - if (allocated(CS%diag_PE_detrain2)) & - CS%diag_PE_detrain2(i,j) = CS%diag_PE_detrain2(i,j) + & - g_H2_2dt * h(i,k) * h(i,nkmb) * (R0(i,nkmb) - R0(i,k)) - - R0(i,nkmb) = (R0(i,nkmb)*h(i,nkmb) + R0(i,k)*h(i,k)) * Ih + + if (CS%nonBous_energetics) then + if (CS%TKE_diagnostics) & + CS%diag_TKE_conv_s2(i,j) = CS%diag_TKE_conv_s2(i,j) - & + nB_g_H_2dt * (h(i,k) * h(i,nkmb)) * (SpV0(i,nkmb) - SpV0(i,k)) + if (allocated(CS%diag_PE_detrain)) & + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) - & + nB_gRZ_H2_2dt * (h(i,k) * h(i,nkmb)) * (SpV0(i,nkmb) - SpV0(i,k)) + if (allocated(CS%diag_PE_detrain2)) & + CS%diag_PE_detrain2(i,j) = CS%diag_PE_detrain2(i,j) - & + nB_gRZ_H2_2dt * (h(i,k) * h(i,nkmb)) * (SpV0(i,nkmb) - SpV0(i,k)) + + SpV0(i,nkmb) = (SpV0(i,nkmb)*h(i,nkmb) + SpV0(i,k)*h(i,k)) * Ih + else + if (CS%TKE_diagnostics) & + CS%diag_TKE_conv_s2(i,j) = CS%diag_TKE_conv_s2(i,j) + & + g_H_2Rho0dt * h(i,k) * h(i,nkmb) * (R0(i,nkmb) - R0(i,k)) + if (allocated(CS%diag_PE_detrain)) & + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + & + g_H2_2dt * h(i,k) * h(i,nkmb) * (R0(i,nkmb) - R0(i,k)) + if (allocated(CS%diag_PE_detrain2)) & + CS%diag_PE_detrain2(i,j) = CS%diag_PE_detrain2(i,j) + & + g_H2_2dt * h(i,k) * h(i,nkmb) * (R0(i,nkmb) - R0(i,k)) + + R0(i,nkmb) = (R0(i,nkmb)*h(i,nkmb) + R0(i,k)*h(i,k)) * Ih + endif Rcv(i,nkmb) = (Rcv(i,nkmb)*h(i,nkmb) + Rcv(i,k)*h(i,k)) * Ih T(i,nkmb) = (T(i,nkmb)*h(i,nkmb) + T(i,k)*h(i,k)) * Ih S(i,nkmb) = (S(i,nkmb)*h(i,nkmb) + S(i,k)*h(i,k)) * Ih @@ -3152,12 +3730,24 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e ! the released buoyancy. With multiple buffer layers, much more ! graceful options are available. do i=is,ie ; if (h(i,nkmb) > 0.0) then - if ((R0(i,0) & - (R0(i,nkmb)-R0(i,nz))*h(i,nkmb)) then - detrain(i) = (R0(i,nkmb)-R0(i,nz))*h(i,nkmb) / (R0(i,nkmb)-R0(i,0)) + if (CS%nonBous_energetics) then + must_unmix = (SpV0(i,0) > SpV0(i,nz)) .and. (SpV0(i,nz) > SpV0(i,nkmb)) + else + must_unmix = (R0(i,0) < R0(i,nz)) .and. (R0(i,nz) < R0(i,nkmb)) + endif + if (must_unmix) then + if (CS%nonBous_energetics) then + if ((SpV0(i,0)-SpV0(i,nz))*h(i,0) > (SpV0(i,nz)-SpV0(i,nkmb))*h(i,nkmb)) then + detrain(i) = (SpV0(i,nz)-SpV0(i,nkmb))*h(i,nkmb) / (SpV0(i,0)-SpV0(i,nkmb)) + else + detrain(i) = (SpV0(i,0)-SpV0(i,nz))*h(i,0) / (SpV0(i,0)-SpV0(i,nkmb)) + endif else - detrain(i) = (R0(i,nz)-R0(i,0))*h(i,0) / (R0(i,nkmb)-R0(i,0)) + if ((R0(i,nz)-R0(i,0))*h(i,0) > (R0(i,nkmb)-R0(i,nz))*h(i,nkmb)) then + detrain(i) = (R0(i,nkmb)-R0(i,nz))*h(i,nkmb) / (R0(i,nkmb)-R0(i,0)) + else + detrain(i) = (R0(i,nz)-R0(i,0))*h(i,0) / (R0(i,nkmb)-R0(i,0)) + endif endif d_eb(i,CS%nkml) = d_eb(i,CS%nkml) + detrain(i) @@ -3165,12 +3755,22 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e d_eb(i,nkmb) = d_eb(i,nkmb) - detrain(i) d_ea(i,nkmb) = d_ea(i,nkmb) + detrain(i) - if (allocated(CS%diag_PE_detrain)) CS%diag_PE_detrain(i,j) = & - CS%diag_PE_detrain(i,j) + g_H2_2dt * detrain(i)* & - (h(i,0) + h(i,nkmb)) * (R0(i,nkmb) - R0(i,0)) - x1 = R0(i,0) - R0(i,0) = R0(i,0) - detrain(i)*(R0(i,0)-R0(i,nkmb)) / h(i,0) - R0(i,nkmb) = R0(i,nkmb) - detrain(i)*(R0(i,nkmb)-x1) / h(i,nkmb) + if (CS%nonBous_energetics) then + if (allocated(CS%diag_PE_detrain)) CS%diag_PE_detrain(i,j) = & + CS%diag_PE_detrain(i,j) - nB_gRZ_H2_2dt * detrain(i)* & + (h(i,0) + h(i,nkmb)) * (SpV0(i,nkmb) - SpV0(i,0)) + x1 = SpV0(i,0) + SpV0(i,0) = SpV0(i,0) - detrain(i)*(SpV0(i,0)-SpV0(i,nkmb)) / h(i,0) + SpV0(i,nkmb) = SpV0(i,nkmb) - detrain(i)*(SpV0(i,nkmb)-x1) / h(i,nkmb) + else + if (allocated(CS%diag_PE_detrain)) CS%diag_PE_detrain(i,j) = & + CS%diag_PE_detrain(i,j) + g_H2_2dt * detrain(i)* & + (h(i,0) + h(i,nkmb)) * (R0(i,nkmb) - R0(i,0)) + x1 = R0(i,0) + R0(i,0) = R0(i,0) - detrain(i)*(R0(i,0)-R0(i,nkmb)) / h(i,0) + R0(i,nkmb) = R0(i,nkmb) - detrain(i)*(R0(i,nkmb)-x1) / h(i,nkmb) + endif + x1 = Rcv(i,0) Rcv(i,0) = Rcv(i,0) - detrain(i)*(Rcv(i,0)-Rcv(i,nkmb)) / h(i,0) Rcv(i,nkmb) = Rcv(i,nkmb) - detrain(i)*(Rcv(i,nkmb)-x1) / h(i,nkmb) @@ -3197,7 +3797,7 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e do k=nz-1,nkmb+1,-1 ; do i=is,ie if (splittable_BL(i)) then - if (RcvTgt(k)<=Rcv(i,nkmb)) then + if (RcvTgt(k) <= Rcv(i,nkmb)) then ! Estimate dR/drho, dTheta/dR, and dS/dR, where R is the coordinate variable ! and rho is in-situ (or surface) potential density. ! There is no "right" way to do this, so this keeps things reasonable, if @@ -3218,9 +3818,13 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e else ; orthogonal_extrap = .true. ; endif endif - if ((R0(i,0) >= R0(i,k1)) .or. (Rcv(i,0) >= Rcv(i,nkmb))) cycle - ! In this case there is an inversion of in-situ density relative to - ! the coordinate variable. Do not detrain from the buffer layer. + ! Check for the case when there is an inversion of in-situ density relative to + ! the coordinate variable. Do not detrain from the buffer layer in this case. + if (CS%nonBous_energetics) then + if ((SpV0(i,0) <= SpV0(i,k1)) .or. (Rcv(i,0) >= Rcv(i,nkmb))) cycle + else + if ((R0(i,0) >= R0(i,k1)) .or. (Rcv(i,0) >= Rcv(i,nkmb))) cycle + endif if (orthogonal_extrap) then ! 36 here is a typical oceanic value of (dR/dS) / (dR/dT) - it says @@ -3233,20 +3837,33 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e dT_dR = (T(i,0) - T(i,k1)) / (Rcv(i,0) - Rcv(i,k1)) dS_dR = (S(i,0) - S(i,k1)) / (Rcv(i,0) - Rcv(i,k1)) endif - dRml = dt_Time * (R0(i,nkmb) - R0(i,0)) * & - (Rcv(i,0) - Rcv(i,k1)) / (R0(i,0) - R0(i,k1)) - ! Once again, there is an apparent density inversion in Rcv. - if (dRml < 0.0) cycle - dR0_dRcv = (R0(i,0) - R0(i,k1)) / (Rcv(i,0) - Rcv(i,k1)) + + if (CS%nonBous_energetics) then + dRml = dt_Time * (SpV0(i,0) - SpV0(i,nkmb)) * & + (Rcv(i,0) - Rcv(i,k1)) / (SpV0(i,k1) - SpV0(i,0)) + if (dRml < 0.0) cycle ! Once again, there is an apparent density inversion in Rcv. + dSpV0_dRcv = (SpV0(i,0) - SpV0(i,k1)) / (Rcv(i,0) - Rcv(i,k1)) + else + dRml = dt_Time * (R0(i,nkmb) - R0(i,0)) * & + (Rcv(i,0) - Rcv(i,k1)) / (R0(i,0) - R0(i,k1)) + if (dRml < 0.0) cycle ! Once again, there is an apparent density inversion in Rcv. + dR0_dRcv = (R0(i,0) - R0(i,k1)) / (Rcv(i,0) - Rcv(i,k1)) + endif if ((Rcv(i,nkmb) - dRml < RcvTgt(k)) .and. (max_det_rem(i) > h(i,nkmb))) then ! In this case, the buffer layer is split into two isopycnal layers. - detrain(i) = h(i,nkmb)*(Rcv(i,nkmb) - RcvTgt(k)) / & - (RcvTgt(k+1) - RcvTgt(k)) + detrain(i) = h(i,nkmb) * (Rcv(i,nkmb) - RcvTgt(k)) / & + (RcvTgt(k+1) - RcvTgt(k)) - if (allocated(CS%diag_PE_detrain)) CS%diag_PE_detrain(i,j) = & - CS%diag_PE_detrain(i,j) - g_H2_2dt * detrain(i) * & - (h(i,nkmb)-detrain(i)) * (RcvTgt(k+1) - RcvTgt(k)) * dR0_dRcv + if (allocated(CS%diag_PE_detrain)) then + if (CS%nonBous_energetics) then + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + nB_gRZ_H2_2dt * detrain(i) * & + (h(i,nkmb)-detrain(i)) * (RcvTgt(k+1) - RcvTgt(k)) * dSpV0_dRcv + else + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) - g_H2_2dt * detrain(i) * & + (h(i,nkmb)-detrain(i)) * (RcvTgt(k+1) - RcvTgt(k)) * dR0_dRcv + endif + endif Tdown = detrain(i) * (T(i,nkmb) + dT_dR*(RcvTgt(k+1)-Rcv(i,nkmb))) T(i,k) = (h(i,k) * T(i,k) + & @@ -3293,11 +3910,17 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e h(i,k+1) = h(i,k+1) + detrain(i) h(i,nkmb) = h(i,nkmb) - detrain(i) - if (allocated(CS%diag_PE_detrain)) CS%diag_PE_detrain(i,j) = & - CS%diag_PE_detrain(i,j) - g_H2_2dt * detrain(i) * dR0_dRcv * & - (h(i,nkmb)-detrain(i)) * (RcvTgt(k+1) - Rcv(i,nkmb) + dRml) + if (allocated(CS%diag_PE_detrain)) then + if (CS%nonBous_energetics) then + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + nB_gRZ_H2_2dt * detrain(i) * dSpV0_dRcv * & + (h(i,nkmb)-detrain(i)) * (RcvTgt(k+1) - Rcv(i,nkmb) + dRml) + else + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) - g_H2_2dt * detrain(i) * dR0_dRcv * & + (h(i,nkmb)-detrain(i)) * (RcvTgt(k+1) - Rcv(i,nkmb) + dRml) + endif + endif endif - endif ! RcvTgt(k)<=Rcv(i,nkmb) + endif ! (RcvTgt(k) <= Rcv(i,nkmb)) endif ! splittable_BL enddo ; enddo ! i & k loops @@ -3332,13 +3955,14 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) !! parameters. type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic !! output. - type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control struct + type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control structure -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_mixed_layer" ! This module's name. - real :: BL_detrain_time_dflt ! The default value for BUFFER_LAY_DETRAIN_TIME [s] - real :: omega_frac_dflt, ustar_min_dflt, Hmix_min_m + real :: omega_frac_dflt ! The default value for ML_OMEGA_FRAC [nondim] + real :: ustar_min_dflt ! The default value for BML_USTAR_MIN [Z T-1 ~> m s-1] + real :: Hmix_min_z ! HMIX_MIN in units of vertical extent [Z ~> m], used to set other defaults integer :: isd, ied, jsd, jed logical :: use_temperature, use_omega isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -3371,8 +3995,8 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "BULK_RI_ML", CS%bulk_Ri_ML, & "The efficiency with which mean kinetic energy released "//& "by mechanically forced entrainment of the mixed layer "//& - "is converted to turbulent kinetic energy.", units="nondim",& - fail_if_missing=.true.) + "is converted to turbulent kinetic energy.", & + units="nondim", fail_if_missing=.true., scale=US%L_to_Z**2) call get_param(param_file, mdl, "ABSORB_ALL_SW", CS%absorb_all_sw, & "If true, all shortwave radiation is absorbed by the "//& "ocean, instead of passing through to the bottom mud.", & @@ -3384,41 +4008,50 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "NSTAR2", CS%nstar2, & "The portion of any potential energy released by "//& "convective adjustment that is available to drive "//& - "entrainment at the base of mixed layer. By default "//& - "NSTAR2=NSTAR.", units="nondim", default=CS%nstar) + "entrainment at the base of mixed layer. By default NSTAR2=NSTAR.", & + units="nondim", default=CS%nstar) call get_param(param_file, mdl, "BULK_RI_CONVECTIVE", CS%bulk_Ri_convective, & "The efficiency with which convectively released mean "//& "kinetic energy is converted to turbulent kinetic "//& "energy. By default BULK_RI_CONVECTIVE=BULK_RI_ML.", & - units="nondim", default=CS%bulk_Ri_ML) - call get_param(param_file, mdl, "HMIX_MIN", CS%Hmix_min, & + units="nondim", default=US%Z_to_L**2*CS%bulk_Ri_ML, scale=US%L_to_Z**2) + call get_param(param_file, mdl, 'VON_KARMAN_CONST', CS%vonKar, & + 'The value the von Karman constant as used for mixed layer viscosity.', & + units='nondim', default=0.41) + call get_param(param_file, mdl, "HMIX_MIN", Hmix_min_Z, & "The minimum mixed layer depth if the mixed layer depth "//& - "is determined dynamically.", units="m", default=0.0, scale=GV%m_to_H, & - unscaled=Hmix_min_m) + "is determined dynamically.", units="m", default=0.0, scale=US%m_to_Z) + CS%Hmix_min = GV%m_to_H * (US%Z_to_m * Hmix_min_Z) + call get_param(param_file, mdl, "MECH_TKE_FLOOR", CS%mech_TKE_floor, & + "A tiny floor on the amount of turbulent kinetic energy that is used when "//& + "the mixed layer does not yet contain HMIX_MIN fluid. The default is so "//& + "small that its actual value is irrelevant, so long as it is greater than 0.", & + units="m3 s-2", default=1.0e-150, scale=GV%m_to_H*US%m_s_to_L_T**2*US%L_to_Z**2, & + do_not_log=(Hmix_min_Z<=0.0)) call get_param(param_file, mdl, "LIMIT_BUFFER_DETRAIN", CS%limit_det, & "If true, limit the detrainment from the buffer layers "//& "to not be too different from the neighbors.", default=.false.) call get_param(param_file, mdl, "ALLOWED_DETRAIN_TEMP_CHG", CS%Allowed_T_chg, & - "The amount by which temperature is allowed to exceed "//& - "previous values during detrainment.", units="K", default=0.5) + "The amount by which temperature is allowed to exceed previous values "//& + "during detrainment.", units="K", default=0.5, scale=US%degC_to_C) call get_param(param_file, mdl, "ALLOWED_DETRAIN_SALT_CHG", CS%Allowed_S_chg, & - "The amount by which salinity is allowed to exceed "//& - "previous values during detrainment.", units="PSU", default=0.1) + "The amount by which salinity is allowed to exceed previous values "//& + "during detrainment.", units="ppt", default=0.1, scale=US%ppt_to_S) call get_param(param_file, mdl, "ML_DT_DS_WEIGHT", CS%dT_dS_wt, & "When forced to extrapolate T & S to match the layer "//& "densities, this factor (in deg C / PSU) is combined "//& "with the derivatives of density with T & S to determine "//& "what direction is orthogonal to density contours. It "//& - "should be a typical value of (dR/dS) / (dR/dT) in "//& - "oceanic profiles.", units="degC PSU-1", default=6.0) + "should be a typical value of (dR/dS) / (dR/dT) in oceanic profiles.", & + units="degC ppt-1", default=6.0, scale=US%degC_to_C*US%S_to_ppt) call get_param(param_file, mdl, "BUFFER_LAYER_EXTRAP_LIMIT", CS%BL_extrap_lim, & "A limit on the density range over which extrapolation "//& "can occur when detraining from the buffer layers, "//& "relative to the density range within the mixed and "//& "buffer layers, when the detrainment is going into the "//& "lightest interior layer, nondimensional, or a negative "//& - "value not to apply this limit.", units="nondim", default = -1.0) + "value not to apply this limit.", units="nondim", default=-1.0) call get_param(param_file, mdl, "BUFFER_LAYER_HMIN_THICK", CS%Hbuffer_min, & "The minimum buffer layer thickness when the mixed layer is very thick.", & units="m", default=5.0, scale=GV%m_to_H) @@ -3426,10 +4059,15 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) "The minimum buffer layer thickness relative to the combined mixed "//& "land buffer ayer thicknesses when they are thin.", & units="nondim", default=0.1/CS%nkbl) - BL_detrain_time_dflt = 4.0*3600.0 ; if (CS%nkbl==1) BL_detrain_time_dflt = 86400.0*30.0 - call get_param(param_file, mdl, "BUFFER_LAY_DETRAIN_TIME", CS%BL_detrain_time, & + if (CS%nkbl==1) then + call get_param(param_file, mdl, "BUFFER_LAY_DETRAIN_TIME", CS%BL_detrain_time, & + "A timescale that characterizes buffer layer detrainment events.", & + units="s", default=86400.0*30.0, scale=US%s_to_T) + else + call get_param(param_file, mdl, "BUFFER_LAY_DETRAIN_TIME", CS%BL_detrain_time, & "A timescale that characterizes buffer layer detrainment events.", & - units="s", default=BL_detrain_time_dflt, scale=US%s_to_T) + units="s", default=4.0*3600.0, scale=US%s_to_T) + endif call get_param(param_file, mdl, "BUFFER_SPLIT_RHO_TOL", CS%BL_split_rho_tol, & "The fractional tolerance for matching layer target densities when splitting "//& "layers to deal with massive interior layers that are lighter than one of the "//& @@ -3438,7 +4076,7 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "DEPTH_LIMIT_FLUXES", CS%H_limit_fluxes, & "The surface fluxes are scaled away when the total ocean "//& "depth is less than DEPTH_LIMIT_FLUXES.", & - units="m", default=0.1*Hmix_min_m, scale=GV%m_to_H) + units="m", default=0.1*US%Z_to_m*Hmix_min_z, scale=GV%m_to_H) call get_param(param_file, mdl, "OMEGA", CS%omega, & "The rotation rate of the earth.", & default=7.2921e-5, units="s-1", scale=US%T_to_s) @@ -3465,14 +4103,19 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) "layers before sorting when ML_RESORT is true.", & units="nondim", default=0, fail_if_missing=.true.) ! Fail added by AJA. ! This gives a minimum decay scale that is typically much less than Angstrom. - ustar_min_dflt = 2e-4*US%s_to_T*CS%omega*(GV%Angstrom_m + GV%H_to_m*GV%H_subroundoff) + ustar_min_dflt = 2e-4*CS%omega*(GV%Angstrom_Z + GV%dZ_subroundoff) call get_param(param_file, mdl, "BML_USTAR_MIN", CS%ustar_min, & "The minimum value of ustar that should be used by the "//& "bulk mixed layer model in setting vertical TKE decay "//& - "scales. This must be greater than 0.", units="m s-1", & - default=ustar_min_dflt, scale=US%m_to_Z*US%T_to_s) + "scales. This must be greater than 0.", & + units="m s-1", default=US%Z_to_m*US%s_to_T*ustar_min_dflt, scale=US%m_to_Z*US%T_to_s) if (CS%ustar_min<=0.0) call MOM_error(FATAL, "BML_USTAR_MIN must be positive.") + call get_param(param_file, mdl, "BML_NONBOUSINESQ", CS%nonBous_energetics, & + "If true, use non-Boussinesq expressions for the energetic calculations "//& + "used in the bulk mixed layer calculations.", & + default=.not.(GV%Boussinesq.or.GV%semi_Boussinesq)) + call get_param(param_file, mdl, "RESOLVE_EKMAN", CS%Resolve_Ekman, & "If true, the NKML>1 layers in the mixed layer are "//& "chosen to optimally represent the impact of the Ekman "//& @@ -3491,7 +4134,7 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) if (CS%do_rivermix) & call get_param(param_file, mdl, "RIVERMIX_DEPTH", CS%rivermix_depth, & "The depth to which rivers are mixed if DO_RIVERMIX is "//& - "defined.", units="m", default=0.0, scale=US%m_to_Z) + "defined.", units="m", default=0.0, scale=GV%m_to_H) call get_param(param_file, mdl, "USE_RIVER_HEAT_CONTENT", CS%use_river_heat_content, & "If true, use the fluxes%runoff_Hflx field to set the "//& "heat carried by runoff, instead of using SST*CP*liq_runoff.", & @@ -3505,45 +4148,45 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) "during mixedlayer convection.", default=.false.) CS%id_ML_depth = register_diag_field('ocean_model', 'h_ML', diag%axesT1, & - Time, 'Surface mixed layer depth', 'm') + Time, 'Surface mixed layer depth', 'm', conversion=GV%H_to_m) CS%id_TKE_wind = register_diag_field('ocean_model', 'TKE_wind', diag%axesT1, & Time, 'Wind-stirring source of mixed layer TKE', & - 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'm3 s-3', conversion=GV%H_to_m*(US%Z_to_m**2)*(US%s_to_T**3)) CS%id_TKE_RiBulk = register_diag_field('ocean_model', 'TKE_RiBulk', diag%axesT1, & Time, 'Mean kinetic energy source of mixed layer TKE', & - 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'm3 s-3', conversion=GV%H_to_m*(US%Z_to_m**2)*(US%s_to_T**3)) CS%id_TKE_conv = register_diag_field('ocean_model', 'TKE_conv', diag%axesT1, & Time, 'Convective source of mixed layer TKE', & - 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'm3 s-3', conversion=GV%H_to_m*(US%Z_to_m**2)*(US%s_to_T**3)) CS%id_TKE_pen_SW = register_diag_field('ocean_model', 'TKE_pen_SW', diag%axesT1, & Time, 'TKE consumed by mixing penetrative shortwave radation through the mixed layer', & - 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'm3 s-3', conversion=GV%H_to_m*(US%Z_to_m**2)*(US%s_to_T**3)) CS%id_TKE_mixing = register_diag_field('ocean_model', 'TKE_mixing', diag%axesT1, & Time, 'TKE consumed by mixing that deepens the mixed layer', & - 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'm3 s-3', conversion=GV%H_to_m*(US%Z_to_m**2)*(US%s_to_T**3)) CS%id_TKE_mech_decay = register_diag_field('ocean_model', 'TKE_mech_decay', diag%axesT1, & Time, 'Mechanical energy decay sink of mixed layer TKE', & - 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'm3 s-3', conversion=GV%H_to_m*(US%Z_to_m**2)*(US%s_to_T**3)) CS%id_TKE_conv_decay = register_diag_field('ocean_model', 'TKE_conv_decay', diag%axesT1, & Time, 'Convective energy decay sink of mixed layer TKE', & - 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'm3 s-3', conversion=GV%H_to_m*(US%Z_to_m**2)*(US%s_to_T**3)) CS%id_TKE_conv_s2 = register_diag_field('ocean_model', 'TKE_conv_s2', diag%axesT1, & Time, 'Spurious source of mixed layer TKE from sigma2', & - 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'm3 s-3', conversion=GV%H_to_m*(US%Z_to_m**2)*(US%s_to_T**3)) CS%id_PE_detrain = register_diag_field('ocean_model', 'PE_detrain', diag%axesT1, & Time, 'Spurious source of potential energy from mixed layer detrainment', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_PE_detrain2 = register_diag_field('ocean_model', 'PE_detrain2', diag%axesT1, & Time, 'Spurious source of potential energy from mixed layer only detrainment', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_h_mismatch = register_diag_field('ocean_model', 'h_miss_ML', diag%axesT1, & - Time, 'Summed absolute mismatch in entrainment terms', 'm', conversion=US%Z_to_m) + Time, 'Summed absolute mismatch in entrainment terms', 'm', conversion=GV%H_to_m) CS%id_Hsfc_used = register_diag_field('ocean_model', 'Hs_used', diag%axesT1, & - Time, 'Surface region thickness that is used', 'm', conversion=US%Z_to_m) + Time, 'Surface region thickness that is used', 'm', conversion=GV%H_to_m) CS%id_Hsfc_max = register_diag_field('ocean_model', 'Hs_max', diag%axesT1, & - Time, 'Maximum surface region thickness', 'm', conversion=US%Z_to_m) + Time, 'Maximum surface region thickness', 'm', conversion=GV%H_to_m) CS%id_Hsfc_min = register_diag_field('ocean_model', 'Hs_min', diag%axesT1, & - Time, 'Minimum surface region thickness', 'm', conversion=US%Z_to_m) + Time, 'Minimum surface region thickness', 'm', conversion=GV%H_to_m) !CS%lim_det_dH_sfc = 0.5 ; CS%lim_det_dH_bathy = 0.2 ! Technically these should not get used if limit_det is false? if (CS%limit_det .or. (CS%id_Hsfc_min > 0)) then call get_param(param_file, mdl, "LIMIT_BUFFER_DET_DH_SFC", CS%lim_det_dH_sfc, & @@ -3600,7 +4243,7 @@ function EF4(Ht, En, I_L, dR_de) real :: EF4 !< The integral [H-1 ~> m-1 or m2 kg-1]. ! Local variables - real :: exp_LHpE ! A nondimensional exponential decay. + real :: exp_LHpE ! A nondimensional exponential decay [nondim]. real :: I_HpE ! An inverse thickness plus entrainment [H-1 ~> m-1 or m2 kg-1]. real :: Res ! The result of the integral above [H-1 ~> m-1 or m2 kg-1]. @@ -3619,8 +4262,8 @@ end function EF4 !! !! This file contains the subroutine (bulkmixedlayer) that !! implements a Kraus-Turner-like bulk mixed layer, based on the work -!! of various people, as described in the review paper by \cite Niiler1977, -!! with particular attention to the form proposed by \cite Oberhuber1993, +!! of various people, as described in the review paper by \cite niiler1977, +!! with particular attention to the form proposed by \cite Oberhuber1993a, !! with an extension to a refined bulk mixed layer as described in !! Hallberg (\cite muller2003). The physical processes portrayed in !! this subroutine include convective adjustment and mixed layer entrainment diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index c421b3a0f7..bcde4feb34 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -1,9 +1,11 @@ -!> Provides functions for some diabatic processes such as fraxil, brine rejection, +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Provides functions for some diabatic processes such as frazil, brine rejection, !! tendency due to surface flux divergence. module MOM_diabatic_aux -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr @@ -15,7 +17,9 @@ module MOM_diabatic_aux use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing, extractFluxes1d, forcing_SinglePointPrint use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz use MOM_interpolate, only : init_external_field, time_interp_external, time_interp_external_init +use MOM_interpolate, only : external_field use MOM_io, only : slasher use MOM_opacity, only : set_opacity, opacity_CS, extract_optics_slice, extract_optics_fields use MOM_opacity, only : optics_type, optics_nbands, absorbRemainingSW, sumSWoverBands @@ -30,8 +34,7 @@ module MOM_diabatic_aux public diabatic_aux_init, diabatic_aux_end public make_frazil, adjust_salt, differential_diffuse_T_S, triDiagTS, triDiagTS_Eulerian -public find_uv_at_h, diagnoseMLDbyDensityDifference, applyBoundaryFluxesInOut, set_pen_shortwave -public diagnoseMLDbyEnergy +public find_uv_at_h, applyBoundaryFluxesInOut, set_pen_shortwave ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -43,6 +46,8 @@ module MOM_diabatic_aux logical :: do_rivermix = .false. !< Provide additional TKE to mix river runoff at the !! river mouths to a depth of "rivermix_depth" real :: rivermix_depth = 0.0 !< The depth to which rivers are mixed if do_rivermix = T [Z ~> m]. + real :: dSalt_frac_max !< An upper limit on the fraction of the salt in a layer that can be + !! lost to the net surface salt fluxes within a timestep [nondim] logical :: reclaim_frazil !< If true, try to use any frazil heat deficit to !! to cool the topmost layer down to the freezing !! point. The default is true. @@ -62,9 +67,14 @@ module MOM_diabatic_aux !! is added with a temperature of the local SST. logical :: var_pen_sw !< If true, use one of the CHL_A schemes to determine the !! e-folding depth of incoming shortwave radiation. - integer :: sbc_chl !< An integer handle used in time interpolation of + type(external_field) :: sbc_chl !< A handle used in time interpolation of !! chlorophyll read from a file. - logical :: chl_from_file !< If true, chl_a is read from a file. + logical :: chl_from_file !< If true, chl_a is read from a file. + logical :: do_brine_plume !< If true, insert salt flux below the surface according to + !! a parameterization by \cite Nguyen2009. + integer :: brine_plume_n !< The exponent in the brine plume parameterization. + real :: plume_strength !< Fraction of the available brine to take to the bottom of the mixed + !! layer [nondim]. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(diag_ctrl), pointer :: diag !< Structure used to regulate timing of diagnostic output @@ -106,22 +116,21 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< Structure containing pointers to any available !! thermodynamic fields. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diabatic_aux_CS), intent(in) :: CS !< The control structure returned by a previous !! call to diabatic_aux_init. real, dimension(SZI_(G),SZJ_(G)), & optional, intent(in) :: p_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa]. integer, optional, intent(in) :: halo !< Halo width over which to calculate frazil - ! Local variables real, dimension(SZI_(G)) :: & fraz_col, & ! The accumulated heat requirement due to frazil [Q R Z ~> J m-2]. - T_freeze, & ! The freezing potential temperature at the current salinity [degC]. + T_freeze, & ! The freezing potential temperature at the current salinity [C ~> degC]. ps ! Surface pressure [R L2 T-2 ~> Pa] real, dimension(SZI_(G),SZK_(GV)) :: & pressure ! The pressure at the middle of each layer [R L2 T-2 ~> Pa]. real :: H_to_RL2_T2 ! A conversion factor from thicknesses in H to pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] - real :: hc ! A layer's heat capacity [Q R Z degC-1 ~> J m-2 degC-1]. + real :: hc ! A layer's heat capacity [Q R Z C-1 ~> J m-2 degC-1]. logical :: T_fr_set ! True if the freezing point has been calculated for a ! row of points. integer :: i, j, k, is, ie, js, je, nz @@ -153,8 +162,7 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) pressure(i,1) = ps(i) + (0.5*H_to_RL2_T2)*h(i,j,1) enddo do k=2,nz ; do i=is,ie - pressure(i,k) = pressure(i,k-1) + & - (0.5*H_to_RL2_T2) * (h(i,j,k) + h(i,j,k-1)) + pressure(i,k) = pressure(i,k-1) + (0.5*H_to_RL2_T2) * (h(i,j,k) + h(i,j,k-1)) enddo ; enddo endif @@ -162,8 +170,8 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) T_fr_set = .false. do i=is,ie ; if (tv%frazil(i,j) > 0.0) then if (.not.T_fr_set) then - call calculate_TFreeze(tv%S(i:,j,1), pressure(i:,1), T_freeze(i:), & - 1, ie-i+1, tv%eqn_of_state, pres_scale=US%RL2_T2_to_Pa) + call calculate_TFreeze(tv%S(i:ie,j,1), pressure(i:ie,1), T_freeze(i:ie), & + tv%eqn_of_state) T_fr_set = .true. endif @@ -188,8 +196,8 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) if ((G%mask2dT(i,j) > 0.0) .and. & ((tv%T(i,j,k) < 0.0) .or. (fraz_col(i) > 0.0))) then if (.not.T_fr_set) then - call calculate_TFreeze(tv%S(i:,j,k), pressure(i:,k), T_freeze(i:), & - 1, ie-i+1, tv%eqn_of_state, pres_scale=US%RL2_T2_to_Pa) + call calculate_TFreeze(tv%S(i:ie,j,k), pressure(i:ie,k), T_freeze(i:ie), & + tv%eqn_of_state) T_fr_set = .true. endif @@ -216,58 +224,70 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) tv%frazil(i,j) = tv%frazil(i,j) + fraz_col(i) enddo enddo + + tv%frazil_was_reset = .false. + call cpu_clock_end(id_clock_frazil) end subroutine make_frazil -!> This subroutine applies double diffusion to T & S, assuming no diapycal mass -!! fluxes, using a simple triadiagonal solver. -subroutine differential_diffuse_T_S(h, T, S, Kd_T, Kd_S, dt, G, GV) +!> This subroutine applies double diffusion to T & S, assuming no diapycnal mass +!! fluxes, using a simple tridiagonal solver. +subroutine differential_diffuse_T_S(h, T, S, Kd_T, Kd_S, tv, dt, G, GV) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: T !< Potential temperature [degC]. + intent(inout) :: T !< Potential temperature [C ~> degC]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: S !< Salinity [PSU] or [gSalt/kg], generically [ppt]. + intent(inout) :: S !< Salinity [PSU] or [gSalt/kg], generically [S ~> ppt]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & - intent(inout) :: Kd_T !< The extra diffusivity of temperature due to + intent(in) :: Kd_T !< The extra diffusivity of temperature due to !! double diffusion relative to the diffusivity of - !! diffusivity of density [Z2 T-1 ~> m2 s-1]. + !! density [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(in) :: Kd_S !< The extra diffusivity of salinity due to !! double diffusion relative to the diffusivity of - !! diffusivity of density [Z2 T-1 ~> m2 s-1]. + !! density [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any + !! available thermodynamic fields. real, intent(in) :: dt !< Time increment [T ~> s]. ! local variables real, dimension(SZI_(G)) :: & - b1_T, b1_S, & ! Variables used by the tridiagonal solvers of T & S [H ~> m or kg m-2]. - d1_T, d1_S ! Variables used by the tridiagonal solvers [nondim]. + b1_T, b1_S, & ! Variables used by the tridiagonal solvers of T & S [H ~> m or kg m-2]. + d1_T, d1_S ! Variables used by the tridiagonal solvers [nondim]. real, dimension(SZI_(G),SZK_(GV)) :: & - c1_T, c1_S ! Variables used by the tridiagonal solvers [H ~> m or kg m-2]. + dz, & ! Height change across layers [Z ~> m] + c1_T, c1_S ! Variables used by the tridiagonal solvers [H ~> m or kg m-2]. real, dimension(SZI_(G),SZK_(GV)+1) :: & - mix_T, mix_S ! Mixing distances in both directions across each interface [H ~> m or kg m-2]. - real :: h_tr ! h_tr is h at tracer points with a tiny thickness - ! added to ensure positive definiteness [H ~> m or kg m-2]. - real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected [H ~> m or kg m-2]. - real :: I_h_int ! The inverse of the thickness associated with an - ! interface [H-1 ~> m-1 or m2 kg-1]. - real :: b_denom_T ! The first term in the denominators for the expressions - real :: b_denom_S ! for b1_T and b1_S, both [H ~> m or kg m-2]. + mix_T, mix_S ! Mixing distances in both directions across each interface [H ~> m or kg m-2]. + real :: h_tr ! h_tr is h at tracer points with a tiny thickness + ! added to ensure positive definiteness [H ~> m or kg m-2]. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. + real :: I_dz_int ! The inverse of the height scale associated with an interface [Z-1 ~> m-1]. + real :: b_denom_T ! The first term in the denominator for the expression for b1_T [H ~> m or kg m-2]. + real :: b_denom_S ! The first term in the denominator for the expression for b1_S [H ~> m or kg m-2]. integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke h_neglect = GV%H_subroundoff + dz_neglect = GV%dZ_subroundoff !$OMP parallel do default(private) shared(is,ie,js,je,h,h_neglect,dt,Kd_T,Kd_S,G,GV,T,S,nz) do j=js,je + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + do i=is,ie - I_h_int = 1.0 / (0.5 * (h(i,j,1) + h(i,j,2)) + h_neglect) - mix_T(i,2) = ((dt * Kd_T(i,j,2)) * GV%Z_to_H**2) * I_h_int - mix_S(i,2) = ((dt * Kd_S(i,j,2)) * GV%Z_to_H**2) * I_h_int + I_dz_int = 1.0 / (0.5 * (dz(i,1) + dz(i,2)) + dz_neglect) + mix_T(i,2) = (dt * Kd_T(i,j,2)) * I_dz_int + mix_S(i,2) = (dt * Kd_S(i,j,2)) * I_dz_int h_tr = h(i,j,1) + h_neglect b1_T(i) = 1.0 / (h_tr + mix_T(i,2)) @@ -279,9 +299,9 @@ subroutine differential_diffuse_T_S(h, T, S, Kd_T, Kd_S, dt, G, GV) enddo do k=2,nz-1 ; do i=is,ie ! Calculate the mixing across the interface below this layer. - I_h_int = 1.0 / (0.5 * (h(i,j,k) + h(i,j,k+1)) + h_neglect) - mix_T(i,K+1) = ((dt * Kd_T(i,j,K+1)) * GV%Z_to_H**2) * I_h_int - mix_S(i,K+1) = ((dt * Kd_S(i,j,K+1)) * GV%Z_to_H**2) * I_h_int + I_dz_int = 1.0 / (0.5 * (dz(i,k) + dz(i,k+1)) + dz_neglect) + mix_T(i,K+1) = ((dt * Kd_T(i,j,K+1))) * I_dz_int + mix_S(i,K+1) = ((dt * Kd_S(i,j,K+1))) * I_dz_int c1_T(i,k) = mix_T(i,K) * b1_T(i) c1_S(i,k) = mix_S(i,K) * b1_S(i) @@ -329,8 +349,8 @@ subroutine adjust_salt(h, tv, G, GV, CS) !! call to diabatic_aux_init. ! local variables - real :: salt_add_col(SZI_(G),SZJ_(G)) !< The accumulated salt requirement [ppt R Z ~> gSalt m-2] - real :: S_min !< The minimum salinity [ppt]. + real :: salt_add_col(SZI_(G),SZJ_(G)) !< The accumulated salt requirement [S R Z ~> gSalt m-2] + real :: S_min !< The minimum salinity [S ~> ppt]. real :: mc !< A layer's mass [R Z ~> kg m-2]. integer :: i, j, k, is, ie, js, je, nz @@ -386,8 +406,8 @@ subroutine triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, T, S) !! above within this time step [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: eb !< The amount of fluid entrained from the layer !! below within this time step [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: T !< Layer potential temperatures [degC]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: S !< Layer salinities [ppt]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: T !< Layer potential temperatures [C ~> degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: S !< Layer salinities [S ~> ppt]. ! Local variables real :: b1(SZIB_(G)) ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. @@ -434,8 +454,8 @@ subroutine triDiagTS_Eulerian(G, GV, is, ie, js, je, hold, ent, T, S) !! [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: ent !< The amount of fluid mixed across an interface !! within this time step [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: T !< Layer potential temperatures [degC]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: S !< Layer salinities [ppt]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: T !< Layer potential temperatures [C ~> degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: S !< Layer salinities [S ~> ppt]. ! Local variables real :: b1(SZIB_(G)) ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. @@ -498,17 +518,18 @@ subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb, zero_mix) !! v_h as though ea and eb were being supplied with !! uniformly zero values. - ! local variables + ! Local variables real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: b1(SZI_(G)) ! A thickness used in the tridiagonal solver [H ~> m or kg m-2] real :: c1(SZI_(G),SZK_(GV)) ! A variable used in the tridiagonal solver [nondim] real :: d1(SZI_(G)) ! The complement of c1 [nondim] - real :: a_n(SZI_(G)), a_s(SZI_(G)) ! Fractional weights of the neighboring - real :: a_e(SZI_(G)), a_w(SZI_(G)) ! velocity points, ~1/2 in the open - ! ocean, nondimensional. - real :: sum_area, Idenom + ! Fractional weights of the neighboring velocity points, ~1/2 in the open ocean. + real :: a_n(SZI_(G)), a_s(SZI_(G)) ! Fractional weights of the neighboring velocity points [nondim] + real :: a_e(SZI_(G)), a_w(SZI_(G)) ! Fractional weights of the neighboring velocity points [nondim] + real :: sum_area ! A sum of adjacent areas [L2 ~> m2] + real :: Idenom ! The inverse of the denominator in a weighted average [L-2 ~> m-2] logical :: mix_vertically, zero_mixing integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -527,7 +548,13 @@ subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb, zero_mix) do j=js,je do i=is,ie sum_area = G%areaCu(I-1,j) + G%areaCu(I,j) - if (sum_area>0.0) then + if (sum_area > 0.0) then + ! If this were a simple area weighted average, this would just be I_denom = 1.0 / sum_area. + ! The other factor of sqrt(0.5*sum_area*G%IareaT(i,j)) is 1 for open ocean points on a + ! Cartesian grid. This construct predates the initial commit of the MOM6 code, and was + ! present in the GOLD code before February, 2010. I do not recall why this was added, and + ! the GOLD CVS server that contained the relevant history and logs appears to have been + ! decommissioned. Idenom = sqrt(0.5*G%IareaT(i,j) / sum_area) a_w(i) = G%areaCu(I-1,j) * Idenom a_e(i) = G%areaCu(I,j) * Idenom @@ -536,7 +563,7 @@ subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb, zero_mix) endif sum_area = G%areaCv(i,J-1) + G%areaCv(i,J) - if (sum_area>0.0) then + if (sum_area > 0.0) then Idenom = sqrt(0.5*G%IareaT(i,j) / sum_area) a_s(i) = G%areaCv(i,J-1) * Idenom a_n(i) = G%areaCv(i,J) * Idenom @@ -550,17 +577,17 @@ subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb, zero_mix) b_denom_1 = h(i,j,1) + h_neglect b1(i) = 1.0 / (b_denom_1 + eb(i,j,1)) d1(i) = b_denom_1 * b1(i) - u_h(i,j,1) = (h(i,j,1)*b1(i)) * (a_e(i)*u(I,j,1) + a_w(i)*u(I-1,j,1)) - v_h(i,j,1) = (h(i,j,1)*b1(i)) * (a_n(i)*v(i,J,1) + a_s(i)*v(i,J-1,1)) + u_h(i,j,1) = (h(i,j,1)*b1(i)) * ((a_e(i)*u(I,j,1)) + (a_w(i)*u(I-1,j,1))) + v_h(i,j,1) = (h(i,j,1)*b1(i)) * ((a_n(i)*v(i,J,1)) + (a_s(i)*v(i,J-1,1))) enddo do k=2,nz ; do i=is,ie c1(i,k) = eb(i,j,k-1) * b1(i) b_denom_1 = h(i,j,k) + d1(i)*ea(i,j,k) + h_neglect b1(i) = 1.0 / (b_denom_1 + eb(i,j,k)) d1(i) = b_denom_1 * b1(i) - u_h(i,j,k) = (h(i,j,k) * (a_e(i)*u(I,j,k) + a_w(i)*u(I-1,j,k)) + & + u_h(i,j,k) = (h(i,j,k) * ((a_e(i)*u(I,j,k)) + (a_w(i)*u(I-1,j,k))) + & ea(i,j,k)*u_h(i,j,k-1))*b1(i) - v_h(i,j,k) = (h(i,j,k) * (a_n(i)*v(i,J,k) + a_s(i)*v(i,J-1,k)) + & + v_h(i,j,k) = (h(i,j,k) * ((a_n(i)*v(i,J,k)) + (a_s(i)*v(i,J-1,k))) + & ea(i,j,k)*v_h(i,j,k-1))*b1(i) enddo ; enddo do k=nz-1,1,-1 ; do i=is,ie @@ -570,18 +597,18 @@ subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb, zero_mix) elseif (zero_mixing) then do i=is,ie b1(i) = 1.0 / (h(i,j,1) + h_neglect) - u_h(i,j,1) = (h(i,j,1)*b1(i)) * (a_e(i)*u(I,j,1) + a_w(i)*u(I-1,j,1)) - v_h(i,j,1) = (h(i,j,1)*b1(i)) * (a_n(i)*v(i,J,1) + a_s(i)*v(i,J-1,1)) + u_h(i,j,1) = (h(i,j,1)*b1(i)) * ((a_e(i)*u(I,j,1)) + (a_w(i)*u(I-1,j,1))) + v_h(i,j,1) = (h(i,j,1)*b1(i)) * ((a_n(i)*v(i,J,1)) + (a_s(i)*v(i,J-1,1))) enddo do k=2,nz ; do i=is,ie b1(i) = 1.0 / (h(i,j,k) + h_neglect) - u_h(i,j,k) = (h(i,j,k) * (a_e(i)*u(I,j,k) + a_w(i)*u(I-1,j,k))) * b1(i) - v_h(i,j,k) = (h(i,j,k) * (a_n(i)*v(i,J,k) + a_s(i)*v(i,J-1,k))) * b1(i) + u_h(i,j,k) = (h(i,j,k) * ((a_e(i)*u(I,j,k)) + (a_w(i)*u(I-1,j,k)))) * b1(i) + v_h(i,j,k) = (h(i,j,k) * ((a_n(i)*v(i,J,k)) + (a_s(i)*v(i,J-1,k)))) * b1(i) enddo ; enddo else do k=1,nz ; do i=is,ie - u_h(i,j,k) = a_e(i)*u(I,j,k) + a_w(i)*u(I-1,j,k) - v_h(i,j,k) = a_n(i)*v(i,J,k) + a_s(i)*v(i,J-1,k) + u_h(i,j,k) = (a_e(i)*u(I,j,k)) + (a_w(i)*u(I-1,j,k)) + v_h(i,j,k) = (a_n(i)*v(i,J,k)) + (a_s(i)*v(i,J-1,k)) enddo ; enddo endif enddo @@ -589,12 +616,15 @@ subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb, zero_mix) call cpu_clock_end(id_clock_uv_at_h) end subroutine find_uv_at_h - +!> Estimate the optical properties of the water column and determine the penetrating shortwave +!! radiation by band, extracting the relevant information from the fluxes type and storing it +!! in the optics type for later application. This routine is effectively a wrapper for +!! set_opacity with added error handling and diagnostics. subroutine set_pen_shortwave(optics, fluxes, G, GV, US, CS, opacity, tracer_flow_CSp) type(optics_type), pointer :: optics !< An optics structure that has will contain !! information about shortwave fluxes and absorption. type(forcing), intent(inout) :: fluxes !< points to forcing fields - !! unused fields have NULL ptrs + !! unused fields have NULL pointers type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -604,10 +634,10 @@ subroutine set_pen_shortwave(optics, fluxes, G, GV, US, CS, opacity, tracer_flow !! organizing the tracer modules. ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: chl_2d !< Vertically uniform chlorophyll-A concentractions [mg m-3] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: chl_3d !< The chlorophyll-A concentractions of each layer [mg m-3] + real, dimension(SZI_(G),SZJ_(G)) :: chl_2d !< Vertically uniform chlorophyll-A concentrations [mg m-3] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: chl_3d !< The chlorophyll-A concentrations of each layer [mg m-3] character(len=128) :: mesg - integer :: i, j, k, is, ie, js, je + integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec if (.not.associated(optics)) return @@ -616,11 +646,11 @@ subroutine set_pen_shortwave(optics, fluxes, G, GV, US, CS, opacity, tracer_flow if (CS%chl_from_file) then ! Only the 2-d surface chlorophyll can be read in from a file. The ! same value is assumed for all layers. - call time_interp_external(CS%sbc_chl, CS%Time, chl_2d) + call time_interp_external(CS%sbc_chl, CS%Time, chl_2d, turns=G%HI%turns) do j=js,je ; do i=is,ie - if ((G%mask2dT(i,j) > 0.5) .and. (chl_2d(i,j) < 0.0)) then + if ((G%mask2dT(i,j) > 0.0) .and. (chl_2d(i,j) < 0.0)) then write(mesg,'(" Time_interp negative chl of ",(1pe12.4)," at i,j = ",& - & 2(i3), "lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') & + & I0,", ",I0," lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') & chl_2d(i,j), i, j, G%geoLonT(i,j), G%geoLatT(i,j) call MOM_error(FATAL, "MOM_diabatic_aux set_pen_shortwave: "//trim(mesg)) endif @@ -648,350 +678,13 @@ subroutine set_pen_shortwave(optics, fluxes, G, GV, US, CS, opacity, tracer_flow end subroutine set_pen_shortwave - -!> Diagnose a mixed layer depth (MLD) determined by a given density difference with the surface. -!> This routine is appropriate in MOM_diabatic_driver due to its position within the time stepping. -subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, diagPtr, & - id_N2subML, id_MLDsq, dz_subML) - type(ocean_grid_type), intent(in) :: G !< Grid type - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - integer, intent(in) :: id_MLD !< Handle (ID) of MLD diagnostic - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any - !! available thermodynamic fields. - real, intent(in) :: densityDiff !< Density difference to determine MLD [R ~> kg m-3] - type(diag_ctrl), pointer :: diagPtr !< Diagnostics structure - integer, optional, intent(in) :: id_N2subML !< Optional handle (ID) of subML stratification - integer, optional, intent(in) :: id_MLDsq !< Optional handle (ID) of squared MLD - real, optional, intent(in) :: dz_subML !< The distance over which to calculate N2subML - !! or 50 m if missing [Z ~> m] - - ! Local variables - real, dimension(SZI_(G)) :: deltaRhoAtKm1, deltaRhoAtK ! Density differences [R ~> kg m-3]. - real, dimension(SZI_(G)) :: pRef_MLD, pRef_N2 ! Reference pressures [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G)) :: H_subML, dH_N2 ! Summed thicknesses used in N2 calculation [H ~> m]. - real, dimension(SZI_(G)) :: T_subML, T_deeper ! Temperatures used in the N2 calculation [degC]. - real, dimension(SZI_(G)) :: S_subML, S_deeper ! Salinities used in the N2 calculation [ppt]. - real, dimension(SZI_(G)) :: rho_subML, rho_deeper ! Densities used in the N2 calculation [R ~> kg m-3]. - real, dimension(SZI_(G)) :: dK, dKm1 ! Depths [Z ~> m]. - real, dimension(SZI_(G)) :: rhoSurf ! Density used in finding the mixedlayer depth [R ~> kg m-3]. - real, dimension(SZI_(G), SZJ_(G)) :: MLD ! Diagnosed mixed layer depth [Z ~> m]. - real, dimension(SZI_(G), SZJ_(G)) :: subMLN2 ! Diagnosed stratification below ML [T-2 ~> s-2]. - real, dimension(SZI_(G), SZJ_(G)) :: MLD2 ! Diagnosed MLD^2 [Z2 ~> m2]. - logical, dimension(SZI_(G)) :: N2_region_set ! If true, all necessary values for calculating N2 - ! have been stored already. - real :: gE_Rho0 ! The gravitational acceleration divided by a mean density [Z T-2 R-1 ~> m4 s-2 kg-1]. - real :: dH_subML ! Depth below ML over which to diagnose stratification [H ~> m]. - real :: aFac ! A nondimensional factor [nondim] - real :: ddRho ! A density difference [R ~> kg m-3] - integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state - integer :: i, j, is, ie, js, je, k, nz, id_N2, id_SQ - - id_N2 = -1 ; if (PRESENT(id_N2subML)) id_N2 = id_N2subML - - id_SQ = -1 ; if (PRESENT(id_MLDsq)) id_SQ = id_MLDsq - - gE_rho0 = US%L_to_Z**2*GV%g_Earth / (GV%Rho0) - dH_subML = 50.*GV%m_to_H ; if (present(dz_subML)) dH_subML = GV%Z_to_H*dz_subML - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - - pRef_MLD(:) = 0.0 - EOSdom(:) = EOS_domain(G%HI) - do j=js,je - do i=is,ie ; dK(i) = 0.5 * h(i,j,1) * GV%H_to_Z ; enddo ! Depth of center of surface layer - call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, tv%eqn_of_state, EOSdom) - do i=is,ie - deltaRhoAtK(i) = 0. - MLD(i,j) = 0. - if (id_N2>0) then - subMLN2(i,j) = 0.0 - H_subML(i) = h(i,j,1) ; dH_N2(i) = 0.0 - T_subML(i) = 0.0 ; S_subML(i) = 0.0 ; T_deeper(i) = 0.0 ; S_deeper(i) = 0.0 - N2_region_set(i) = (G%mask2dT(i,j)<0.5) ! Only need to work on ocean points. - endif - enddo - do k=2,nz - do i=is,ie - dKm1(i) = dK(i) ! Depth of center of layer K-1 - dK(i) = dK(i) + 0.5 * ( h(i,j,k) + h(i,j,k-1) ) * GV%H_to_Z ! Depth of center of layer K - enddo - - ! Prepare to calculate stratification, N2, immediately below the mixed layer by finding - ! the cells that extend over at least dz_subML. - if (id_N2>0) then - do i=is,ie - if (MLD(i,j)==0.0) then ! Still in the mixed layer. - H_subML(i) = H_subML(i) + h(i,j,k) - elseif (.not.N2_region_set(i)) then ! This block is below the mixed layer, but N2 has not been found yet. - if (dH_N2(i)==0.0) then ! Record the temperature, salinity, pressure, immediately below the ML - T_subML(i) = tv%T(i,j,k) ; S_subML(i) = tv%S(i,j,k) - H_subML(i) = H_subML(i) + 0.5 * h(i,j,k) ! Start midway through this layer. - dH_N2(i) = 0.5 * h(i,j,k) - elseif (dH_N2(i) + h(i,j,k) < dH_subML) then - dH_N2(i) = dH_N2(i) + h(i,j,k) - else ! This layer includes the base of the region where N2 is calculated. - T_deeper(i) = tv%T(i,j,k) ; S_deeper(i) = tv%S(i,j,k) - dH_N2(i) = dH_N2(i) + 0.5 * h(i,j,k) - N2_region_set(i) = .true. - endif - endif - enddo ! i-loop - endif ! id_N2>0 - - ! Mixed-layer depth, using sigma-0 (surface reference pressure) - do i=is,ie ; deltaRhoAtKm1(i) = deltaRhoAtK(i) ; enddo ! Store value from previous iteration of K - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, tv%eqn_of_state, EOSdom) - do i = is, ie - deltaRhoAtK(i) = deltaRhoAtK(i) - rhoSurf(i) ! Density difference between layer K and surface - ddRho = deltaRhoAtK(i) - deltaRhoAtKm1(i) - if ((MLD(i,j)==0.) .and. (ddRho>0.) .and. & - (deltaRhoAtKm1(i)=densityDiff)) then - aFac = ( densityDiff - deltaRhoAtKm1(i) ) / ddRho - MLD(i,j) = dK(i) * aFac + dKm1(i) * (1. - aFac) - endif - if (id_SQ > 0) MLD2(i,j) = MLD(i,j)**2 - enddo ! i-loop - enddo ! k-loop - do i=is,ie - if ((MLD(i,j)==0.) .and. (deltaRhoAtK(i)0) then ! Now actually calculate stratification, N2, below the mixed layer. - do i=is,ie ; pRef_N2(i) = (GV%g_Earth * GV%H_to_RZ) * (H_subML(i) + 0.5*dH_N2(i)) ; enddo - ! if ((.not.N2_region_set(i)) .and. (dH_N2(i) > 0.5*dH_subML)) then - ! ! Use whatever stratification we can, measured over whatever distance is available? - ! T_deeper(i) = tv%T(i,j,nz) ; S_deeper(i) = tv%S(i,j,nz) - ! N2_region_set(i) = .true. - ! endif - call calculate_density(T_subML, S_subML, pRef_N2, rho_subML, tv%eqn_of_state, EOSdom) - call calculate_density(T_deeper, S_deeper, pRef_N2, rho_deeper, tv%eqn_of_state, EOSdom) - do i=is,ie ; if ((G%mask2dT(i,j)>0.5) .and. N2_region_set(i)) then - subMLN2(i,j) = gE_rho0 * (rho_deeper(i) - rho_subML(i)) / (GV%H_to_z * dH_N2(i)) - endif ; enddo - endif - enddo ! j-loop - - if (id_MLD > 0) call post_data(id_MLD, MLD, diagPtr) - if (id_N2 > 0) call post_data(id_N2, subMLN2, diagPtr) - if (id_SQ > 0) call post_data(id_SQ, MLD2, diagPtr) - -end subroutine diagnoseMLDbyDensityDifference - -!> Diagnose a mixed layer depth (MLD) determined by the depth a given energy value would mix. -!> This routine is appropriate in MOM_diabatic_driver due to its position within the time stepping. -subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) - ! Author: Brandon Reichl - ! Date: October 2, 2020 - ! // - ! *Note that gravity is assumed constant everywhere and divided out of all calculations. - ! - ! This code has been written to step through the columns layer by layer, summing the PE - ! change inferred by mixing the layer with all layers above. When the change exceeds a - ! threshold (determined by input array Mixing_Energy), the code needs to solve for how far - ! into this layer the threshold PE change occurs (assuming constant density layers). - ! This is expressed here via solving the function F(X) = 0 where: - ! F(X) = 0.5 * ( Ca*X^3/(D1+X) + Cb*X^2/(D1+X) + Cc*X/(D1+X) + Dc/(D1+X) - ! + Ca2*X^2 + Cb2*X + Cc2) - ! where all coefficients are determined by the previous mixed layer depth, the - ! density of the previous mixed layer, the present layer thickness, and the present - ! layer density. This equation is worked out by computing the total PE assuming constant - ! density in the mixed layer as well as in the remaining part of the present layer that is - ! not mixed. - ! To solve for X in this equation a Newton's method iteration is employed, which - ! converges extremely quickly (usually 1 guess) since this equation turns out being rather - ! lienar for PE change with increasing X. - ! Input parameters: - integer, dimension(3), intent(in) :: id_MLD !< Energy output diag IDs - type(ocean_grid_type), intent(in) :: G !< Grid type - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(3), intent(in) :: Mixing_Energy !< Energy values for up to 3 MLDs - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any - !! available thermodynamic fields. - type(diag_ctrl), pointer :: diagPtr !< Diagnostics structure - - ! Local variables - real, dimension(SZI_(G), SZJ_(G),3) :: MLD ! Diagnosed mixed layer depth [Z ~> m]. - real, dimension(SZK_(GV)) :: Z_L, Z_U, dZ, Rho_c, pRef_MLD - real, dimension(3) :: PE_threshold - - real :: ig, E_g - real :: PE_Threshold_fraction, PE, PE_Mixed, PE_Mixed_TST - real :: RhoDZ_ML, H_ML, RhoDZ_ML_TST, H_ML_TST - real :: Rho_ML - - real :: R1, D1, R2, D2 - real :: Ca, Cb,D ,Cc, Cd, Ca2, Cb2, C, Cc2 - real :: Gx, Gpx, Hx, iHx, Hpx, Ix, Ipx, Fgx, Fpx, X, X2 - - integer :: IT, iM - integer :: i, j, is, ie, js, je, k, nz - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - - pRef_MLD(:) = 0.0 - mld(:,:,:) = 0.0 - PE_Threshold_fraction = 1.e-4 !Fixed threshold of 0.01%, could be runtime. - - do iM=1,3 - PE_threshold(iM) = Mixing_Energy(iM)/GV%g_earth - enddo - - do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.0) then - - call calculate_density(tv%T(i,j,:), tv%S(i,j,:), pRef_MLD, rho_c, 1, nz, & - tv%eqn_of_state, scale=US%kg_m3_to_R) - - do k=1,nz - DZ(k) = h(i,j,k) * GV%H_to_Z - enddo - Z_U(1) = 0.0 - Z_L(1) = -DZ(1) - do k=2,nz - Z_U(k) = Z_L(k-1) - Z_L(k) = Z_L(k-1)-DZ(k) - enddo - - do iM=1,3 - - ! Initialize these for each column-wise calculation - PE = 0.0 - RhoDZ_ML = 0.0 - H_ML = 0.0 - RhoDZ_ML_TST = 0.0 - H_ML_TST = 0.0 - PE_Mixed = 0.0 - - do k=1,nz - - ! This is the unmixed PE cumulative sum from top down - PE = PE + 0.5 * rho_c(k) * (Z_U(k)**2 - Z_L(k)**2) - - ! This is the depth and integral of density - H_ML_TST = H_ML + DZ(k) - RhoDZ_ML_TST = RhoDZ_ML + rho_c(k) * DZ(k) - - ! The average density assuming all layers including this were mixed - Rho_ML = RhoDZ_ML_TST/H_ML_TST - - ! The PE assuming all layers including this were mixed - ! Note that 0. could be replaced with "Surface", which doesn't have to be 0 - ! but 0 is a good reference value. - PE_Mixed_TST = 0.5 * Rho_ML * (0.**2 - (0. - H_ML_TST)**2) - - ! Check if we supplied enough energy to mix to this layer - if (PE_Mixed_TST - PE <= PE_threshold(iM)) then - H_ML = H_ML_TST - RhoDZ_ML = RhoDZ_ML_TST - - else ! If not, we need to solve where the energy ran out - ! This will be done with a Newton's method iteration: - - R1 = RhoDZ_ML / H_ML ! The density of the mixed layer (not including this layer) - D1 = H_ML ! The thickness of the mixed layer (not including this layer) - R2 = rho_c(k) ! The density of this layer - D2 = DZ(k) ! The thickness of this layer - - ! This block could be used to calculate the function coefficients if - ! we don't reference all values to a surface designated as z=0 - ! S = Surface - ! Ca = -(R2) - ! Cb = -( (R1*D1) + R2*(2.*D1-2.*S) ) - ! D = D1**2. - 2.*D1*S - ! Cc = -( R1*D1*(2.*D1-2.*S) + R2*D ) - ! Cd = -(R1*D1*D) - ! Ca2 = R2 - ! Cb2 = R2*(2*D1-2*S) - ! C = S**2 + D2**2 + D1**2 - 2*D1*S - 2.*D2*S +2.*D1*D2 - ! Cc2 = R2*(D+S**2-C) - ! - ! If the surface is S = 0, it simplifies to: - Ca = -R2 - Cb = -(R1 * D1 + R2 * (2. * D1)) - D = D1**2 - Cc = -(R1 * D1 * (2. * D1) + (R2 * D)) - Cd = -R1 * (D1 * D) - Ca2 = R2 - Cb2 = R2 * (2. * D1) - C = D2**2 + D1**2 + 2. * (D1 * D2) - Cc2 = R2 * (D - C) - - ! First guess for an iteration using Newton's method - X = DZ(k) * 0.5 - - IT=0 - do while(IT<10)!We can iterate up to 10 times - ! We are trying to solve the function: - ! F(x) = G(x)/H(x)+I(x) - ! for where F(x) = PE+PE_threshold, or equivalently for where - ! F(x) = G(x)/H(x)+I(x) - (PE+PE_threshold) = 0 - ! We also need the derivative of this function for the Newton's method iteration - ! F'(x) = (G'(x)H(x)-G(x)H'(x))/H(x)^2 + I'(x) - ! G and its derivative - Gx = 0.5 * (Ca * (X*X*X) + Cb * X**2 + Cc * X + Cd) - Gpx = 0.5 * (3. * (Ca * X**2) + 2. * (Cb * X) + Cc) - ! H, its inverse, and its derivative - Hx = D1 + X - iHx = 1. / Hx - Hpx = 1. - ! I and its derivative - Ix = 0.5 * (Ca2 * X**2 + Cb2 * X + Cc2) - Ipx = 0.5 * (2. * Ca2 * X + Cb2) - - ! The Function and its derivative: - PE_Mixed = Gx * iHx + Ix - Fgx = PE_Mixed - (PE + PE_threshold(iM)) - Fpx = (Gpx * Hx - Hpx * Gx) * iHx**2 + Ipx - - ! Check if our solution is within the threshold bounds, if not update - ! using Newton's method. This appears to converge almost always in - ! one step because the function is very close to linear in most applications. - if (abs(Fgx) > PE_Threshold(iM) * PE_Threshold_fraction) then - X2 = X - Fgx / Fpx - IT = IT + 1 - if (X2 < 0. .or. X2 > DZ(k)) then - ! The iteration seems to be robust, but we need to do something *if* - ! things go wrong... How should we treat failed iteration? - ! Present solution: Stop trying to compute and just say we can't mix this layer. - X=0 - exit - else - X = X2 - endif - else - exit! Quit the iteration - endif - enddo - H_ML = H_ML + X - exit! Quit looping through the column - endif - enddo - MLD(i,j,iM) = H_ML - enddo - else - MLD(i,j,:) = 0.0 - endif - enddo ; enddo - - if (id_MLD(1) > 0) call post_data(id_MLD(1), MLD(:,:,1), diagPtr) - if (id_MLD(2) > 0) call post_data(id_MLD(2), MLD(:,:,2), diagPtr) - if (id_MLD(3) > 0) call post_data(id_MLD(3), MLD(:,:,3), diagPtr) - -end subroutine diagnoseMLDbyEnergy - !> Update the thickness, temperature, and salinity due to thermodynamic !! boundary forcing (contained in fluxes type) applied to h, tv%T and tv%S, !! and calculate the TKE implications of this heating. subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, tv, & aggregate_FW_forcing, evap_CFL_limit, & minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, & - SkinBuoyFlux ) + SkinBuoyFlux, MLD_h) type(diabatic_aux_CS), pointer :: CS !< Control structure for diabatic_aux type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -1015,23 +708,33 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !! forcing through each layer [R Z3 T-2 ~> J m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(out) :: dSV_dT !< Partial derivative of specific volume with - !! potential temperature [R-1 degC-1 ~> m3 kg-1 degC-1]. + !! potential temperature [R-1 C-1 ~> m3 kg-1 degC-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(out) :: dSV_dS !< Partial derivative of specific volume with - !! salinity [R-1 ppt-1 ~> m3 kg-1 ppt-1]. + !! salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. real, dimension(SZI_(G),SZJ_(G)), & optional, intent(out) :: SkinBuoyFlux !< Buoyancy flux at surface [Z2 T-3 ~> m2 s-3]. + real, dimension(:,:), & + optional, pointer :: MLD_h !< Mixed layer thickness for brine plumes [H ~> m or kg m-2] ! Local variables integer, parameter :: maxGroundings = 5 integer :: numberOfGroundings, iGround(maxGroundings), jGround(maxGroundings) - real :: H_limit_fluxes - real :: IforcingDepthScale + real :: H_limit_fluxes ! Surface fluxes are scaled down fluxes when the total depth of the ocean + ! drops below this value [H ~> m or kg m-2] + real :: IforcingDepthScale ! The inverse of the layer thickness below which mass losses are + ! shifted to the next deeper layer [H ~> m or kg m-2] real :: Idt ! The inverse of the timestep [T-1 ~> s-1] - real :: dThickness, dTemp, dSalt - real :: fractionOfForcing, hOld, Ithickness + real :: dThickness ! The change in layer thickness [H ~> m or kg m-2] + real :: dTemp ! The integrated change in layer temperature [C H ~> degC m or degC kg m-2] + real :: dSalt ! The integrated change in layer salinity [S H ~> ppt m or ppt kg m-2] + real :: fractionOfForcing ! THe fraction of the remaining forcing applied to a layer [nondim] + real :: hOld ! The original thickness of a layer [H ~> m or kg m-2] + real :: Ithickness ! The inverse of the new layer thickness [H-1 ~> m-1 or m2 kg-1] real :: RivermixConst ! A constant used in implementing river mixing [R Z2 T-1 ~> Pa s]. - + real :: EnthalpyConst ! A constant used to control the enthalpy calculation [nondim] + ! By default EnthalpyConst = 1.0. If fluxes%heat_content_evap + ! is associated enthalpy is provided via coupler and EnthalpyConst = 0.0. real, dimension(SZI_(G)) :: & d_pres, & ! pressure change across a layer [R L2 T-2 ~> Pa] p_lay, & ! average pressure in a layer [R L2 T-2 ~> Pa] @@ -1040,64 +743,99 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t netMassIn, & ! mass entering ocean surface [H ~> m or kg m-2] over a time step netMassOut, & ! mass leaving ocean surface [H ~> m or kg m-2] over a time step netHeat, & ! heat via surface fluxes excluding Pen_SW_bnd and netMassOut - ! [degC H ~> degC m or degC kg m-2] + ! [C H ~> degC m or degC kg m-2] netSalt, & ! surface salt flux ( g(salt)/m2 for non-Bouss and ppt*H for Bouss ) - ! [ppt H ~> ppt m or ppt kg m-2] + ! [S H ~> ppt m or ppt kg m-2] nonpenSW, & ! non-downwelling SW, which is absorbed at ocean surface - ! [degC H ~> degC m or degC kg m-2] + ! [C H ~> degC m or degC kg m-2] SurfPressure, & ! Surface pressure (approximated as 0.0) [R L2 T-2 ~> Pa] - dRhodT, & ! change in density per change in temperature [R degC-1 ~> kg m-3 degC-1] - dRhodS, & ! change in density per change in salinity [R ppt-1 ~> kg m-3 ppt-1] - netheat_rate, & ! netheat but for dt=1 [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] + dRhodT, & ! change in density per change in temperature [R C-1 ~> kg m-3 degC-1] + dRhodS, & ! change in density per change in salinity [R S-1 ~> kg m-3 ppt-1] + dSpV_dT, & ! Partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSpV_dS, & ! Partial derivative of specific volume with to salinity [R-1 S-1 ~> m3 kg-1 ppt-1] + netheat_rate, & ! netheat but for dt=1 [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] netsalt_rate, & ! netsalt but for dt=1 (e.g. returns a rate) - ! [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] - netMassInOut_rate! netmassinout but for dt=1 [H T-1 ~> m s-1 or kg m-2 s-1] + ! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + netMassInOut_rate, & ! netmassinout but for dt=1 [H T-1 ~> m s-1 or kg m-2 s-1] + mixing_depth, & ! The mixing depth for brine plumes [H ~> m or kg m-2] + total_h ! Total thickness of the water column [H ~> m or kg m-2] real, dimension(SZI_(G), SZK_(GV)) :: & h2d, & ! A 2-d copy of the thicknesses [H ~> m or kg m-2] - T2d, & ! A 2-d copy of the layer temperatures [degC] + ! dz, & ! Layer thicknesses in depth units [Z ~> m] + T2d, & ! A 2-d copy of the layer temperatures [C ~> degC] pen_TKE_2d, & ! The TKE required to homogenize the heating by shortwave radiation within ! a layer [R Z3 T-2 ~> J m-2] - dSV_dT_2d ! The partial derivative of specific volume with temperature [R-1 degC-1 ~> m3 kg-1 degC-1] + dSV_dT_2d ! The partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] real, dimension(SZI_(G)) :: & netPen_rate ! The surface penetrative shortwave heating rate summed over all bands - ! [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] + ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] real, dimension(max(nsw,1),SZI_(G)) :: & Pen_SW_bnd, & ! The penetrative shortwave heating integrated over a timestep by band - ! [degC H ~> degC m or degC kg m-2] + ! [C H ~> degC m or degC kg m-2] Pen_SW_bnd_rate ! The penetrative shortwave heating rate by band - ! [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] + ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] real, dimension(max(nsw,1),SZI_(G),SZK_(GV)) :: & opacityBand ! The opacity (inverse of the exponential absorption length) of each frequency - ! band of shortwave radation in each layer [H-1 ~> m-1 or m2 kg-1] + ! band of shortwave radiation in each layer [H-1 ~> m-1 or m2 kg-1] real, dimension(maxGroundings) :: hGrounding ! Thickness added by each grounding event [H ~> m or kg m-2] - real :: Temp_in, Salin_in + real :: Temp_in ! The initial temperature of a layer [C ~> degC] + real :: Salin_in ! The initial salinity of a layer [S ~> ppt] real :: g_Hconv2 ! A conversion factor for use in the TKE calculation ! in units of [Z3 R2 T-2 H-2 ~> kg2 m-5 s-2 or m s-2]. real :: GoRho ! g_Earth times a unit conversion factor divided by density ! [Z T-2 R-1 ~> m4 s-2 kg-1] - logical :: calculate_energetics - logical :: calculate_buoyancy + real :: g_conv ! The gravitational acceleration times the conversion factors from non-Boussinesq + ! thickness units to mass per units area [R Z2 H-1 T-2 ~> kg m-2 s-2 or m s-2] + logical :: calculate_energetics ! If true, calculate the energy required to mix the newly added + ! water over the topmost grid cell, assuming that the fluxes of heat and salt + ! and rejected brine are initially applied in vanishingly thin layers at the + ! top of the layer before being mixed throughout the layer. + logical :: calculate_buoyancy ! If true, calculate the surface buoyancy flux. + real :: dK(SZI_(G)) ! Depth of the layer center in thickness units [H ~> m or kg m-2] + real :: A_brine(SZI_(G)) ! Constant [H-(n+1) ~> m-(n+1) or m(2n+2) kg-(n+1)]. + real :: fraction_left_brine ! Fraction of the brine that has not been applied yet [nondim] + real :: plume_fraction ! Fraction of the brine that is applied to a layer [nondim] + real :: plume_flux ! Brine flux to move downwards [S H ~> ppt m or ppt kg m-2] integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state - integer :: i, j, is, ie, js, je, k, nz, n, nb + integer :: i, j, is, ie, js, je, k, nz, nb character(len=45) :: mesg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Idt = 1.0 / dt + plume_flux = 0.0 calculate_energetics = (present(cTKE) .and. present(dSV_dT) .and. present(dSV_dS)) calculate_buoyancy = present(SkinBuoyFlux) if (calculate_buoyancy) SkinBuoyFlux(:,:) = 0.0 if (present(cTKE)) cTKE(:,:,:) = 0.0 - g_Hconv2 = (US%L_to_Z**2*GV%g_Earth * GV%H_to_RZ) * GV%H_to_RZ + g_Hconv2 = (GV%g_Earth_Z_T2 * GV%H_to_RZ) * GV%H_to_RZ EOSdom(:) = EOS_domain(G%HI) ! Only apply forcing if fluxes%sw is associated. if (.not.associated(fluxes%sw) .and. .not.calculate_energetics) return + EnthalpyConst = 1.0 + if (associated(fluxes%heat_content_evap)) EnthalpyConst = 0.0 + if (calculate_buoyancy) then SurfPressure(:) = 0.0 - GoRho = US%L_to_Z**2*GV%g_Earth / GV%Rho0 + GoRho = GV%g_Earth_Z_T2 / GV%Rho0 + endif + + if (CS%do_brine_plume .and. .not.present(MLD_h)) then + call MOM_error(FATAL, "MOM_diabatic_aux.F90, applyBoundaryFluxesInOut(): "//& + "Brine plume parameterization requires a mixed-layer depth argument,\n"//& + "currently coming from the energetic PBL scheme.") + endif + if (CS%do_brine_plume .and. .not.associated(MLD_h)) then + call MOM_error(FATAL, "MOM_diabatic_aux.F90, applyBoundaryFluxesInOut(): "//& + "Brine plume parameterization requires an associated mixed-layer depth.") + endif + if (CS%do_brine_plume .and. .not. associated(fluxes%salt_left_behind)) then + call MOM_error(FATAL, "MOM_diabatic_aux.F90, applyBoundaryFluxesInOut(): "//& + "Brine plume parameterization requires DO_BRINE_PLUME\n"//& + "to be turned on in SIS2 as well as MOM6.") endif ! H_limit_fluxes is used by extractFluxes1d to scale down fluxes if the total @@ -1105,7 +843,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! To accommodate vanishing upper layers, we need to allow for an instantaneous ! distribution of forcing over some finite vertical extent. The bulk mixed layer ! code handles this issue properly. - H_limit_fluxes = max(GV%Angstrom_H, 1.E-30*GV%m_to_H) + H_limit_fluxes = max(GV%Angstrom_H, GV%H_subroundoff) ! diagnostic to see if need to create mass to avoid grounding if (CS%id_createdH>0) CS%createdH(:,:) = 0. @@ -1115,17 +853,20 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !$OMP H_limit_fluxes,numberOfGroundings,iGround,jGround,& !$OMP nonPenSW,hGrounding,CS,Idt,aggregate_FW_forcing, & !$OMP minimum_forcing_depth,evap_CFL_limit,dt,EOSdom, & - !$OMP calculate_buoyancy,netPen_rate,SkinBuoyFlux,GoRho, & - !$OMP calculate_energetics,dSV_dT,dSV_dS,cTKE,g_Hconv2) & + !$OMP calculate_buoyancy,netPen_rate,SkinBuoyFlux,GoRho,& + !$OMP calculate_energetics,dSV_dT,dSV_dS,cTKE,g_Hconv2, & + !$OMP EnthalpyConst,MLD_h) & !$OMP private(opacityBand,h2d,T2d,netMassInOut,netMassOut, & !$OMP netHeat,netSalt,Pen_SW_bnd,fractionOfForcing, & - !$OMP IforcingDepthScale, & + !$OMP IforcingDepthScale,g_conv,dSpV_dT,dSpV_dS, & !$OMP dThickness,dTemp,dSalt,hOld,Ithickness, & !$OMP netMassIn,pres,d_pres,p_lay,dSV_dT_2d, & !$OMP netmassinout_rate,netheat_rate,netsalt_rate, & !$OMP drhodt,drhods,pen_sw_bnd_rate, & - !$OMP pen_TKE_2d,Temp_in,Salin_in,RivermixConst) & - !$OMP firstprivate(SurfPressure) + !$OMP pen_TKE_2d,Temp_in,Salin_in,RivermixConst, & + !$OMP mixing_depth,A_brine,fraction_left_brine, & + !$OMP plume_fraction,dK,total_h) & + !$OMP firstprivate(SurfPressure,plume_flux) do j=js,je ! Work in vertical slices for efficiency @@ -1160,7 +901,14 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! Nothing more is done on this j-slice if there is no buoyancy forcing. if (.not.associated(fluxes%sw)) cycle - if (nsw>0) call extract_optics_slice(optics, j, G, GV, opacity=opacityBand, opacity_scale=(1.0/GV%m_to_H)) + if (nsw>0) then + if (GV%Boussinesq .or. (.not.allocated(tv%SpV_avg))) then + call extract_optics_slice(optics, j, G, GV, opacity=opacityBand, opacity_scale=GV%H_to_Z) + else + call extract_optics_slice(optics, j, G, GV, opacity=opacityBand, opacity_scale=GV%H_to_RZ, & + SpV_avg=tv%SpV_avg) + endif + endif ! The surface forcing is contained in the fluxes type. ! We aggregate the thermodynamic forcing for a time step into the following: @@ -1169,12 +917,12 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! note that lprec generally has sea ice melt/form included. ! netMassOut = net mass leaving ocean surface [H ~> m or kg m-2] over a time step. ! netMassOut < 0 means mass leaves ocean. - ! netHeat = heat via surface fluxes [degC H ~> degC m or degC kg m-2], excluding the part + ! netHeat = heat via surface fluxes [C H ~> degC m or degC kg m-2], excluding the part ! contained in Pen_SW_bnd; and excluding heat_content of netMassOut < 0. - ! netSalt = surface salt fluxes [ppt H ~> ppt m or gSalt m-2] + ! netSalt = surface salt fluxes [S H ~> ppt m or gSalt m-2] ! Pen_SW_bnd = components to penetrative shortwave radiation split according to bands. ! This field provides that portion of SW from atmosphere that in fact - ! enters to the ocean and participates in pentrative SW heating. + ! enters to the ocean and participates in penetrative SW heating. ! nonpenSW = non-downwelling SW flux, which is absorbed in ocean surface ! (in tandem w/ LW,SENS,LAT); saved only for diagnostic purposes. @@ -1202,7 +950,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! For all these reasons we compute additional values of <_rate> which are preserved ! for the buoyancy flux calculation and reproduce the old answers. ! In the future this needs more detailed investigation to make sure everything is - ! consistent and correct. These details shouldnt significantly effect climate, + ! consistent and correct. These details should not significantly effect climate, ! but do change answers. !----------------------------------------------------------------------------------------- if (calculate_buoyancy) then @@ -1227,7 +975,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t else netMassIn(i) = netMassInOut(i) - netMassOut(i) endif - if (G%mask2dT(i,j)>0.0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%netMassOut(i,j) = netMassOut(i) fluxes%netMassIn(i,j) = netMassIn(i) else @@ -1241,8 +989,19 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! ocean (and corresponding outward heat content), and ignoring penetrative SW. ! B/ update mass, salt, temp from mass leaving ocean. ! C/ update temp due to penetrative SW + if (CS%do_brine_plume) then + ! Find the plume mixing depth. + do i=is,ie ; total_h(i) = 0.0 ; enddo + do k=1,nz ; do i=is,ie ; total_h(i) = total_h(i) + h(i,j,k) ; enddo ; enddo + do i=is,ie + mixing_depth(i) = min( max(MLD_h(i,j) - minimum_forcing_depth, minimum_forcing_depth), & + max(total_h(i), GV%angstrom_h) ) + GV%H_subroundoff + A_brine(i) = (CS%brine_plume_n + 1) / (mixing_depth(i) ** (CS%brine_plume_n + 1)) + enddo + endif + do i=is,ie - if (G%mask2dT(i,j)>0.) then + if (G%mask2dT(i,j) > 0.) then ! A/ Update mass, temp, and salinity due to incoming mass flux. do k=1,1 @@ -1258,17 +1017,19 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! This line accounts for the temperature of the mass exchange Temp_in = T2d(i,k) Salin_in = 0.0 - dTemp = dTemp + dThickness*Temp_in + dTemp = dTemp + dThickness*Temp_in*EnthalpyConst ! Diagnostics of heat content associated with mass fluxes - if (associated(fluxes%heat_content_massin)) & - fluxes%heat_content_massin(i,j) = fluxes%heat_content_massin(i,j) + & - T2d(i,k) * max(0.,dThickness) * GV%H_to_RZ * fluxes%C_p * Idt - if (associated(fluxes%heat_content_massout)) & - fluxes%heat_content_massout(i,j) = fluxes%heat_content_massout(i,j) + & - T2d(i,k) * min(0.,dThickness) * GV%H_to_RZ * fluxes%C_p * Idt - if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & - T2d(i,k) * dThickness * GV%H_to_RZ + if (.not. associated(fluxes%heat_content_evap)) then + if (associated(fluxes%heat_content_massin)) & + fluxes%heat_content_massin(i,j) = fluxes%heat_content_massin(i,j) + & + T2d(i,k) * max(0.,dThickness) * GV%H_to_RZ * tv%C_p * Idt + if (associated(fluxes%heat_content_massout)) & + fluxes%heat_content_massout(i,j) = fluxes%heat_content_massout(i,j) + & + T2d(i,k) * min(0.,dThickness) * GV%H_to_RZ * tv%C_p * Idt + if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & + T2d(i,k) * dThickness * GV%H_to_RZ + endif ! Determine the energetics of river mixing before updating the state. if (calculate_energetics .and. associated(fluxes%lrunoff) .and. CS%do_rivermix) then @@ -1280,15 +1041,18 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! where River is in units of [Z T-1 ~> m s-1]. ! Samb = Ambient salinity at the mouth of the estuary ! rivermix_depth = The prescribed depth over which to mix river inflow - ! drho_ds = The gradient of density wrt salt at the ambient surface salinity. + ! drho_ds = The derivative of density with salt at the ambient surface salinity. ! Sriver = 0 (i.e. rivers are assumed to be pure freshwater) if (GV%Boussinesq) then - RivermixConst = -0.5*(CS%rivermix_depth*dt) * ( US%L_to_Z**2*GV%g_Earth ) * GV%Rho0 + RivermixConst = -0.5*(CS%rivermix_depth*dt) * GV%g_Earth_Z_T2 * GV%Rho0 + elseif (allocated(tv%SpV_avg)) then + RivermixConst = -0.5*(CS%rivermix_depth*dt) * GV%g_Earth_Z_T2 / tv%SpV_avg(i,j,1) else - RivermixConst = -0.5*(CS%rivermix_depth*dt) * GV%Rho0 * ( US%L_to_Z**2*GV%g_Earth ) + RivermixConst = -0.5*(CS%rivermix_depth*dt) * GV%Rho0 * GV%g_Earth_Z_T2 endif cTKE(i,j,k) = cTKE(i,j,k) + max(0.0, RivermixConst*dSV_dS(i,j,1) * & - (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * tv%S(i,j,1)) + ((fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) + & + (fluxes%lrunoff_glc(i,j) + fluxes%frunoff_glc(i,j))) * tv%S(i,j,1)) endif ! Update state @@ -1311,8 +1075,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t enddo ! k=1,1 ! B/ Update mass, salt, temp from mass leaving ocean and other fluxes of heat and salt. + fraction_left_brine = 1.0 do k=1,nz - ! Place forcing into this layer if this layer has nontrivial thickness. ! For layers thin relative to 1/IforcingDepthScale, then distribute ! forcing into deeper layers. @@ -1327,12 +1091,37 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t fractionOfForcing = -evap_CFL_limit*h2d(i,k)/netMassOut(i) endif + if (CS%do_brine_plume .and. associated(fluxes%salt_left_behind)) then + if (fluxes%salt_left_behind(i,j) > 0 .and. fraction_left_brine > 0.0) then + ! Place forcing into this layer by depth for brine plume parameterization. + if (k == 1) then + dK(i) = 0.5 * h(i,j,k) ! Depth of center of layer K + plume_flux = - (1000.0*US%ppt_to_S * (CS%plume_strength * fluxes%salt_left_behind(i,j))) * GV%RZ_to_H + plume_fraction = 1.0 + else + dK(i) = dK(i) + 0.5 * ( h(i,j,k) + h(i,j,k-1) ) ! Depth of center of layer K + plume_flux = 0.0 + endif + if (dK(i) <= mixing_depth(i) .and. fraction_left_brine > 0.0) then + plume_fraction = min(fraction_left_brine, (A_brine(i) * dK(i)**CS%brine_plume_n) * h(i,j,k)) + else + IforcingDepthScale = 1. / max(GV%H_subroundoff, minimum_forcing_depth - netMassOut(i) ) + ! plume_fraction = fraction_left_brine, unless h2d is less than IforcingDepthScale. + plume_fraction = min(fraction_left_brine, h2d(i,k)*IforcingDepthScale) + endif + fraction_left_brine = fraction_left_brine - plume_fraction + plume_flux = plume_flux + plume_fraction * (1000.0*US%ppt_to_S * (CS%plume_strength * & + fluxes%salt_left_behind(i,j))) * GV%RZ_to_H + else + plume_flux = 0.0 + endif + endif + ! Change in state due to forcing dThickness = max( fractionOfForcing*netMassOut(i), -h2d(i,k) ) dTemp = fractionOfForcing*netHeat(i) - ! ### The 0.9999 here should become a run-time parameter? - dSalt = max( fractionOfForcing*netSalt(i), -0.9999*h2d(i,k)*tv%S(i,j,k)) + dSalt = max( fractionOfForcing*netSalt(i), -CS%dSalt_frac_max * h2d(i,k) * tv%S(i,j,k)) ! Update the forcing by the part to be consumed within the present k-layer. ! If fractionOfForcing = 1, then new netMassOut vanishes. @@ -1341,17 +1130,19 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t netSalt(i) = netSalt(i) - dSalt ! This line accounts for the temperature of the mass exchange - dTemp = dTemp + dThickness*T2d(i,k) + dTemp = dTemp + dThickness*T2d(i,k)*EnthalpyConst ! Diagnostics of heat content associated with mass fluxes - if (associated(fluxes%heat_content_massin)) & - fluxes%heat_content_massin(i,j) = fluxes%heat_content_massin(i,j) + & - T2d(i,k) * max(0.,dThickness) * GV%H_to_RZ * fluxes%C_p * Idt - if (associated(fluxes%heat_content_massout)) & - fluxes%heat_content_massout(i,j) = fluxes%heat_content_massout(i,j) + & - T2d(i,k) * min(0.,dThickness) * GV%H_to_RZ * fluxes%C_p * Idt - if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & - T2d(i,k) * dThickness * GV%H_to_RZ + if (.not. associated(fluxes%heat_content_evap)) then + if (associated(fluxes%heat_content_massin)) & + fluxes%heat_content_massin(i,j) = fluxes%heat_content_massin(i,j) + & + T2d(i,k) * max(0.,dThickness) * GV%H_to_RZ * tv%C_p * Idt + if (associated(fluxes%heat_content_massout)) & + fluxes%heat_content_massout(i,j) = fluxes%heat_content_massout(i,j) + & + T2d(i,k) * min(0.,dThickness) * GV%H_to_RZ * tv%C_p * Idt + if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & + T2d(i,k) * dThickness * GV%H_to_RZ + endif ! Update state by the appropriate increment. hOld = h2d(i,k) ! Keep original thickness in hand @@ -1370,29 +1161,31 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t endif Ithickness = 1.0/h2d(i,k) ! Inverse of new thickness T2d(i,k) = (hOld*T2d(i,k) + dTemp)*Ithickness - tv%S(i,j,k) = (hOld*tv%S(i,j,k) + dSalt)*Ithickness + tv%S(i,j,k) = (hOld*tv%S(i,j,k) + dSalt + plume_flux)*Ithickness elseif (h2d(i,k) < 0.0) then ! h2d==0 is a special limit that needs no extra handling call forcing_SinglePointPrint(fluxes,G,i,j,'applyBoundaryFluxesInOut (h<0)') write(0,*) 'applyBoundaryFluxesInOut(): lon,lat=',G%geoLonT(i,j),G%geoLatT(i,j) - write(0,*) 'applyBoundaryFluxesInOut(): netT,netS,netH=',netHeat(i),netSalt(i),netMassInOut(i) - write(0,*) 'applyBoundaryFluxesInOut(): dT,dS,dH=',dTemp,dSalt,dThickness + write(0,*) 'applyBoundaryFluxesInOut(): netT,netS,netH=', & + US%C_to_degC*netHeat(i), US%S_to_ppt*netSalt(i), netMassInOut(i) + write(0,*) 'applyBoundaryFluxesInOut(): dT,dS,dH=', & + US%C_to_degC*dTemp, US%S_to_ppt*dSalt, dThickness write(0,*) 'applyBoundaryFluxesInOut(): h(n),h(n+1),k=',hOld,h2d(i,k),k - call MOM_error(FATAL, "MOM_diabatic_driver.F90, applyBoundaryFluxesInOut(): "//& + call MOM_error(FATAL, "MOM_diabatic_aux.F90, applyBoundaryFluxesInOut(): "//& "Complete mass loss in column!") endif enddo ! k ! Check if trying to apply fluxes over land points - elseif ((abs(netHeat(i))+abs(netSalt(i))+abs(netMassIn(i))+abs(netMassOut(i)))>0.) then + elseif ((abs(netHeat(i)) + abs(netSalt(i)) + abs(netMassIn(i)) + abs(netMassOut(i))) > 0.) then if (.not. CS%ignore_fluxes_over_land) then call forcing_SinglePointPrint(fluxes,G,i,j,'applyBoundaryFluxesInOut (land)') write(0,*) 'applyBoundaryFluxesInOut(): lon,lat=',G%geoLonT(i,j),G%geoLatT(i,j) write(0,*) 'applyBoundaryFluxesInOut(): netHeat,netSalt,netMassIn,netMassOut=',& - netHeat(i),netSalt(i),netMassIn(i),netMassOut(i) + US%C_to_degC*netHeat(i), US%S_to_ppt*netSalt(i), netMassIn(i), netMassOut(i) - call MOM_error(FATAL, "MOM_diabatic_driver.F90, applyBoundaryFluxesInOut(): "//& + call MOM_error(FATAL, "MOM_diabatic_aux.F90, applyBoundaryFluxesInOut(): "//& "Mass loss over land?") endif @@ -1455,6 +1248,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! convergence of SW into a layer do k=1,nz ; do i=is,ie + ! Note that the units of penSW_diag change here, from [C ~> degC] to [Q R Z T-1 ~> W m-2]. CS%penSW_diag(i,j,k) = (T2d(i,k)-CS%penSW_diag(i,j,k))*h(i,j,k) * Idt * tv%C_p * GV%H_to_RZ enddo ; enddo @@ -1485,31 +1279,45 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! 1) Answers will change due to round-off ! 2) Be sure to save their values BEFORE fluxes are used. if (Calculate_Buoyancy) then - drhodt(:) = 0.0 - drhods(:) = 0.0 netPen_rate(:) = 0.0 ! Sum over bands and attenuate as a function of depth. ! netPen_rate is the netSW as a function of depth, but only the surface value is used here, ! in which case the values of dt, h, optics and H_limit_fluxes are irrelevant. Consider ! writing a shorter and simpler variant to handle this very limited case. - ! call sumSWoverBands(G, GV, US, h2d(:,:), optics_nbands(optics), optics, j, dt, & + ! Find the vertical distances across layers. + ! call thickness_to_dz(h, tv, dz, j, G, GV) + ! call sumSWoverBands(G, GV, US, h2d, dz, optics_nbands(optics), optics, j, dt, & ! H_limit_fluxes, .true., pen_SW_bnd_rate, netPen) do i=is,ie ; do nb=1,nsw ; netPen_rate(i) = netPen_rate(i) + pen_SW_bnd_rate(nb,i) ; enddo ; enddo - ! Density derivatives - if (associated(tv%p_surf)) then ; do i=is,ie ; SurfPressure(i) = tv%p_surf(i,j) ; enddo ; endif - call calculate_density_derivs(T2d(:,1), tv%S(:,j,1), SurfPressure, dRhodT, dRhodS, & - tv%eqn_of_state, EOSdom) ! 1. Adjust netSalt to reflect dilution effect of FW flux ! 2. Add in the SW heating for purposes of calculating the net ! surface buoyancy flux affecting the top layer. ! 3. Convert to a buoyancy flux, excluding penetrating SW heating ! BGR-Jul 5, 2017: The contribution of SW heating here needs investigated for ePBL. - do i=is,ie - SkinBuoyFlux(i,j) = - GoRho * GV%H_to_Z * & - (dRhodS(i) * (netSalt_rate(i) - tv%S(i,j,1)*netMassInOut_rate(i)) + & - dRhodT(i) * ( netHeat_rate(i) + netPen_rate(i)) ) ! [Z2 T-3 ~> m2 s-3] - enddo + if (associated(tv%p_surf)) then ; do i=is,ie ; SurfPressure(i) = tv%p_surf(i,j) ; enddo ; endif + + if ((.not.GV%Boussinesq) .and. (.not.GV%semi_Boussinesq)) then + g_conv = GV%g_Earth_Z_T2 * GV%H_to_RZ + + ! Specific volume derivatives + call calculate_specific_vol_derivs(T2d(:,1), tv%S(:,j,1), SurfPressure, dSpV_dT, dSpV_dS, & + tv%eqn_of_state, EOS_domain(G%HI)) + do i=is,ie + SkinBuoyFlux(i,j) = g_conv * & + (dSpV_dS(i) * ( netSalt_rate(i) - tv%S(i,j,1)*netMassInOut_rate(i)) + & + dSpV_dT(i) * ( netHeat_rate(i) + netPen_rate(i)) ) ! [Z2 T-3 ~> m2 s-3] + enddo + else + ! Density derivatives + call calculate_density_derivs(T2d(:,1), tv%S(:,j,1), SurfPressure, dRhodT, dRhodS, & + tv%eqn_of_state, EOSdom) + do i=is,ie + SkinBuoyFlux(i,j) = - GoRho * GV%H_to_Z * & + (dRhodS(i) * ( netSalt_rate(i) - tv%S(i,j,1)*netMassInOut_rate(i)) + & + dRhodT(i) * ( netHeat_rate(i) + netPen_rate(i)) ) ! [Z2 T-3 ~> m2 s-3] + enddo + endif endif enddo ! j-loop finish @@ -1521,18 +1329,18 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t if (CS%id_nonpenSW_diag > 0) call post_data(CS%id_nonpenSW_diag , CS%nonpenSW_diag , CS%diag) ! The following check will be ignored if ignore_fluxes_over_land = true - if (numberOfGroundings>0 .and. .not. CS%ignore_fluxes_over_land) then + if ((numberOfGroundings > 0) .and. .not.CS%ignore_fluxes_over_land) then do i = 1, min(numberOfGroundings, maxGroundings) call forcing_SinglePointPrint(fluxes,G,iGround(i),jGround(i),'applyBoundaryFluxesInOut (grounding)') write(mesg(1:45),'(3es15.3)') G%geoLonT( iGround(i), jGround(i) ), & G%geoLatT( iGround(i), jGround(i)), hGrounding(i)*GV%H_to_m - call MOM_error(WARNING, "MOM_diabatic_driver.F90, applyBoundaryFluxesInOut(): "//& + call MOM_error(WARNING, "MOM_diabatic_aux.F90, applyBoundaryFluxesInOut(): "//& "Mass created. x,y,dh= "//trim(mesg), all_print=.true.) enddo if (numberOfGroundings - maxGroundings > 0) then - write(mesg, '(i4)') numberOfGroundings - maxGroundings - call MOM_error(WARNING, "MOM_diabatic_driver:F90, applyBoundaryFluxesInOut(): "//& + write(mesg, '(I0)') numberOfGroundings - maxGroundings + call MOM_error(WARNING, "MOM_diabatic_aux:F90, applyBoundaryFluxesInOut(): "//& trim(mesg) // " groundings remaining") endif endif @@ -1555,17 +1363,16 @@ subroutine diabatic_aux_init(Time, G, GV, US, param_file, diag, CS, useALEalgori !! boundary layer scheme to determine the diffusivity !! in the surface boundary layer. -! This "include" declares and sets the variable "version". -#include "version_variable.h" + ! This "include" declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_diabatic_aux" ! This module's name. - character(len=48) :: thickness_units character(len=200) :: inputdir ! The directory where NetCDF input files character(len=240) :: chl_filename ! A file from which chl_a concentrations are to be read. character(len=128) :: chl_file ! Data containing chl_a concentrations. Used ! when var_pen_sw is defined and reading from file. character(len=32) :: chl_varname ! Name of chl_a variable in chl_file. logical :: use_temperature ! True if thermodynamics are enabled. - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz, nbands + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -1585,28 +1392,31 @@ subroutine diabatic_aux_init(Time, G, GV, US, param_file, diag, CS, useALEalgori "The following parameters are used for auxiliary diabatic processes.") call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", use_temperature, & - "If true, temperature and salinity are used as state "//& - "variables.", default=.true.) + "If true, temperature and salinity are used as state variables.", default=.true.) call get_param(param_file, mdl, "RECLAIM_FRAZIL", CS%reclaim_frazil, & "If true, try to use any frazil heat deficit to cool any "//& "overlying layers down to the freezing point, thereby "//& "avoiding the creation of thin ice when the SST is above "//& - "the freezing point.", default=.true.) - call get_param(param_file, mdl, "PRESSURE_DEPENDENT_FRAZIL", & - CS%pressure_dependent_frazil, & + "the freezing point.", default=.true., do_not_log=.not.use_temperature) + call get_param(param_file, mdl, "SALT_EXTRACTION_LIMIT", CS%dSalt_frac_max, & + "An upper limit on the fraction of the salt in a layer that can be lost to the "//& + "net surface salt fluxes within a timestep.", & + units="nondim", default=0.9999, do_not_log=.not.use_temperature) + CS%dSalt_frac_max = max(min(CS%dSalt_frac_max, 1.0), 0.0) + call get_param(param_file, mdl, "PRESSURE_DEPENDENT_FRAZIL", CS%pressure_dependent_frazil, & "If true, use a pressure dependent freezing temperature "//& "when making frazil. The default is false, which will be "//& "faster but is inappropriate with ice-shelf cavities.", & - default=.false.) + default=.false., do_not_log=.not.use_temperature) if (use_ePBL) then call get_param(param_file, mdl, "IGNORE_FLUXES_OVER_LAND", CS%ignore_fluxes_over_land,& - "If true, the model does not check if fluxes are being applied "//& - "over land points. This is needed when the ocean is coupled "//& - "with ice shelves and sea ice, since the sea ice mask needs to "//& - "be different than the ocean mask to avoid sea ice formation "//& - "under ice shelves. This flag only works when use_ePBL = True.", default=.false.) + "If true, the model does not check if fluxes are being applied "//& + "over land points. This is needed when the ocean is coupled "//& + "with ice shelves and sea ice, since the sea ice mask needs to "//& + "be different than the ocean mask to avoid sea ice formation "//& + "under ice shelves. This flag only works when use_ePBL = True.", default=.false.) call get_param(param_file, mdl, "DO_RIVERMIX", CS%do_rivermix, & "If true, apply additional mixing wherever there is "//& "runoff, so that it is mixed down to RIVERMIX_DEPTH "//& @@ -1623,16 +1433,26 @@ subroutine diabatic_aux_init(Time, G, GV, US, param_file, diag, CS, useALEalgori call get_param(param_file, mdl, "USE_RIVER_HEAT_CONTENT", CS%use_river_heat_content, & "If true, use the fluxes%runoff_Hflx field to set the "//& "heat carried by runoff, instead of using SST*CP*liq_runoff.", & - default=.false.) + default=.false., do_not_log=.not.use_temperature) call get_param(param_file, mdl, "USE_CALVING_HEAT_CONTENT", CS%use_calving_heat_content, & "If true, use the fluxes%calving_Hflx field to set the "//& "heat carried by runoff, instead of using SST*CP*froz_runoff.", & - default=.false.) + default=.false., do_not_log=.not.use_temperature) else CS%use_river_heat_content = .false. CS%use_calving_heat_content = .false. endif + call get_param(param_file, mdl, "DO_BRINE_PLUME", CS%do_brine_plume, & + "If true, use a brine plume parameterization from "//& + "Nguyen et al., 2009.", default=.false.) + call get_param(param_file, mdl, "BRINE_PLUME_EXPONENT", CS%brine_plume_n, & + "If using the brine plume parameterization, set the integer exponent.", & + default=5, do_not_log=.not.CS%do_brine_plume) + call get_param(param_file, mdl, "BRINE_PLUME_FRACTION", CS%plume_strength, & + "Fraction of the available brine to mix down using the brine plume parameterization.", & + units="nondim", default=1.0, do_not_log=.not.CS%do_brine_plume) + if (useALEalgorithm) then CS%id_createdH = register_diag_field('ocean_model',"created_H",diag%axesT1, & Time, "The volume flux added to stop the ocean from drying out and becoming negative in depth", & @@ -1689,7 +1509,11 @@ subroutine diabatic_aux_init(Time, G, GV, US, param_file, diag, CS, useALEalgori call log_param(param_file, mdl, "INPUTDIR/CHL_FILE", chl_filename) call get_param(param_file, mdl, "CHL_VARNAME", chl_varname, & "Name of CHL_A variable in CHL_FILE.", default='CHL_A') - CS%sbc_chl = init_external_field(chl_filename, trim(chl_varname), MOM_domain=G%Domain) + if (modulo(G%Domain%turns, 4) /= 0) then + CS%sbc_chl = init_external_field(chl_filename, trim(chl_varname), MOM_domain=G%Domain%domain_in) + else + CS%sbc_chl = init_external_field(chl_filename, trim(chl_varname), MOM_domain=G%Domain) + endif endif CS%id_chl = register_diag_field('ocean_model', 'Chl_opac', diag%axesT1, Time, & @@ -1721,32 +1545,37 @@ end subroutine diabatic_aux_end !> \namespace mom_diabatic_aux !! -!! This module contains the subroutines that, along with the -!! subroutines that it calls, implements diapycnal mass and momentum -!! fluxes and a bulk mixed layer. The diapycnal diffusion can be -!! used without the bulk mixed layer. +!! This module contains subroutines that apply various diabatic processes. Usually these +!! subroutines are called from the MOM_diabatic module. All of these routines use appropriate +!! limiters or logic to work properly with arbitrary layer thicknesses (including massless layers) +!! and an arbitrarily large timestep. !! -!! diabatic first determines the (diffusive) diapycnal mass fluxes -!! based on the convergence of the buoyancy fluxes within each layer. -!! The dual-stream entrainment scheme of MacDougall and Dewar (JPO, -!! 1997) is used for combined diapycnal advection and diffusion, -!! calculated implicitly and potentially with the Richardson number -!! dependent mixing, as described by Hallberg (MWR, 2000). Diapycnal -!! advection is fundamentally the residual of diapycnal diffusion, -!! so the fully implicit upwind differencing scheme that is used is -!! entirely appropriate. The downward buoyancy flux in each layer -!! is determined from an implicit calculation based on the previously -!! calculated flux of the layer above and an estimated flux in the -!! layer below. This flux is subject to the following conditions: -!! (1) the flux in the top and bottom layers are set by the boundary -!! conditions, and (2) no layer may be driven below an Angstrom thick- -!! ness. If there is a bulk mixed layer, the buffer layer is treat- -!! ed as a fixed density layer with vanishingly small diffusivity. +!! The subroutine make_frazil facilitates the formation of frazil ice when the ocean water +!! drops below the in situ freezing point by heating the water to the freezing point and +!! accumulating the required heat for exchange with the sea-ice module. !! -!! diabatic takes 5 arguments: the two velocities (u and v), the -!! thicknesses (h), a structure containing the forcing fields, and -!! the length of time over which to act (dt). The velocities and -!! thickness are taken as inputs and modified within the subroutine. -!! There is no limit on the time step. - +!! The subroutine adjust_salt adds salt as necessary to keep the salinity above a +!! specified minimum value, and keeps track of the cumulative additions. If the minimum +!! salinity is the natural value of 0, this routine should never do anything. +!! +!! The subroutine differential_diffuse_T_S solves a pair of tridiagonal equations for +!! the diffusion of temperatures and salinities with differing diffusivities. +!! +!! The subroutine triDiagTS solves a tridiagonal equations for the evolution of temperatures +!! and salinities due to net entrainment by layers and a diffusion with the same diffusivity. +!! +!! The subroutine triDiagTS_Eulerian solves a tridiagonal equations for the evolution of +!! temperatures and salinities due to diffusion with the same diffusivity, but no net entrainment. +!! +!! The subroutine find_uv_at_h interpolates velocities to thickness points, optionally also +!! using tridiagonal equations to solve for the impacts of net entrainment or mixing of +!! momentum between layers. +!! +!! The subroutine set_pen_shortwave determines the optical properties of the water column and +!! the net shortwave fluxes, and stores them in the optics type, working via calls to set_opacity. +!! +!! The subroutine applyBoundaryFluxesInOut updates the layer thicknesses, temperatures and +!! salinities due to the application of the surface forcing. It may also calculate the implied +!! turbulent kinetic energy requirements for this forcing to be mixed over the model's finite +!! vertical resolution in the surface layers. end module MOM_diabatic_aux diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 336be5669a..b065762808 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> This routine drives the diabatic/dianeutral physics for MOM module MOM_diabatic_driver -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_bulk_mixed_layer, only : bulkmixedlayer, bulkmixedlayer_init, bulkmixedlayer_CS use MOM_debugging, only : hchksum use MOM_checksum_packages, only : MOM_state_chksum, MOM_state_stats @@ -12,8 +14,8 @@ module MOM_diabatic_driver use MOM_CVMix_ddiff, only : CVMix_ddiff_is_used use MOM_diabatic_aux, only : diabatic_aux_init, diabatic_aux_end, diabatic_aux_CS use MOM_diabatic_aux, only : make_frazil, adjust_salt, differential_diffuse_T_S, triDiagTS -use MOM_diabatic_aux, only : triDiagTS_Eulerian, find_uv_at_h, diagnoseMLDbyDensityDifference -use MOM_diabatic_aux, only : applyBoundaryFluxesInOut, diagnoseMLDbyEnergy, set_pen_shortwave +use MOM_diabatic_aux, only : triDiagTS_Eulerian, find_uv_at_h +use MOM_diabatic_aux, only : applyBoundaryFluxesInOut, set_pen_shortwave use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : post_product_sum_u, post_product_sum_v use MOM_diag_mediator, only : diag_ctrl, time_type, diag_update_remap_grids @@ -21,6 +23,9 @@ module MOM_diabatic_driver use MOM_diag_mediator, only : diag_grid_storage, diag_grid_storage_init, diag_grid_storage_end use MOM_diag_mediator, only : diag_copy_diag_to_storage, diag_copy_storage_to_diag use MOM_diag_mediator, only : diag_save_grids, diag_restore_grids +use MOM_diagnose_mld, only : diagnoseMLDbyDensityDifference, diagnoseMLDbyEnergy +use MOM_diagnose_kdwork, only : vbf_CS, KdWork_init, KdWork_end, KdWork_diagnostics +use MOM_diagnose_kdwork, only : Allocate_VBF_CS, Deallocate_VBF_CS use MOM_diapyc_energy_req, only : diapyc_energy_req_init, diapyc_energy_req_end use MOM_diapyc_energy_req, only : diapyc_energy_req_calc, diapyc_energy_req_test, diapyc_energy_req_CS use MOM_CVMix_conv, only : CVMix_conv_init, CVMix_conv_cs @@ -32,29 +37,32 @@ module MOM_diabatic_driver use MOM_energetic_PBL, only : energetic_PBL_get_MLD use MOM_entrain_diffusive, only : entrainment_diffusive, entrain_diffusive_init use MOM_entrain_diffusive, only : entrain_diffusive_CS -use MOM_EOS, only : calculate_density, calculate_TFreeze, EOS_domain +use MOM_EOS, only : calculate_density, calculate_density_derivs, calculate_TFreeze +use MOM_EOS, only : calculate_specific_vol_derivs, EOS_domain use MOM_error_handler, only : MOM_error, FATAL, WARNING, callTree_showQuery,MOM_mesg use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : get_param, log_version, param_file_type, read_param -use MOM_forcing_type, only : forcing, MOM_forcing_chksum +use MOM_forcing_type, only : forcing, MOM_forcing_chksum, find_ustar use MOM_forcing_type, only : calculateBuoyancyFlux2d, forcing_SinglePointPrint use MOM_geothermal, only : geothermal_entraining, geothermal_in_place use MOM_geothermal, only : geothermal_init, geothermal_end, geothermal_CS use MOM_grid, only : ocean_grid_type use MOM_int_tide_input, only : set_int_tide_input, int_tide_input_init use MOM_int_tide_input, only : int_tide_input_end, int_tide_input_CS, int_tide_input_type -use MOM_interface_heights, only : find_eta -use MOM_internal_tides, only : propagate_int_tide +use MOM_interface_heights, only : find_eta, calc_derived_thermo, thickness_to_dz +use MOM_interface_heights, only : convert_MLD_to_ML_thickness +use MOM_internal_tides, only : propagate_int_tide, register_int_tide_restarts use MOM_internal_tides, only : internal_tides_init, internal_tides_end, int_tide_CS use MOM_kappa_shear, only : kappa_shear_is_used use MOM_CVMix_KPP, only : KPP_CS, KPP_init, KPP_compute_BLD, KPP_calculate -use MOM_CVMix_KPP, only : KPP_end, KPP_get_BLD +use MOM_CVMix_KPP, only : KPP_end, KPP_get_BLD, register_KPP_restarts use MOM_CVMix_KPP, only : KPP_NonLocalTransport_temp, KPP_NonLocalTransport_saln use MOM_oda_incupd, only : apply_oda_incupd, oda_incupd_CS use MOM_opacity, only : opacity_init, opacity_end, opacity_CS use MOM_opacity, only : absorbRemainingSW, optics_type, optics_nbands use MOM_open_boundary, only : ocean_OBC_type use MOM_regularize_layers, only : regularize_layers, regularize_layers_init, regularize_layers_CS +use MOM_restart, only : MOM_restart_CS use MOM_set_diffusivity, only : set_diffusivity, set_BBL_TKE use MOM_set_diffusivity, only : set_diffusivity_init, set_diffusivity_end use MOM_set_diffusivity, only : set_diffusivity_CS @@ -67,7 +75,6 @@ module MOM_diabatic_driver use MOM_variables, only : thermo_var_ptrs, vertvisc_type, accel_diag_ptrs use MOM_variables, only : cont_diag_ptrs, MOM_thermovar_chksum, p3d use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units -use MOM_wave_speed, only : wave_speeds use MOM_wave_interface, only : wave_parameters_CS use MOM_stochastics, only : stochastic_CS @@ -81,7 +88,7 @@ module MOM_diabatic_driver public extract_diabatic_member public adiabatic public adiabatic_driver_init -! public legacy_diabatic +public register_diabatic_restarts ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -123,10 +130,7 @@ module MOM_diabatic_driver !! other diffusivities. Otherwise, the larger of kappa- !! shear and ePBL diffusivities are used. real :: ePBL_Prandtl !< The Prandtl number used by ePBL to convert vertical - !! diffusivities into viscosities. - integer :: nMode = 1 !< Number of baroclinic modes to consider - real :: uniform_test_cg !< Uniform group velocity of internal tide - !! for testing internal tides [L T-1 ~> m s-1] + !! diffusivities into viscosities [nondim]. logical :: useALEalgorithm !< If true, use the ALE algorithm rather than layered !! isopycnal/stacked shallow water mode. This logical !! passed by argument to diabatic_driver_init. @@ -134,7 +138,7 @@ module MOM_diabatic_driver !! FW fluxes are applied separately or combined before !! being applied. real :: ML_mix_first !< The nondimensional fraction of the mixed layer - !! algorithm that is applied before diffusive mixing. + !! algorithm that is applied before diffusive mixing [nondim]. !! The default is 0, while 0.5 gives Strang splitting !! and 1 is a sensible value too. Note that if there !! are convective instabilities in the initial state, @@ -150,17 +154,20 @@ module MOM_diabatic_driver !! diffusivity of Kd_min_tr (see below) were operating. real :: Kd_BBL_tr !< A bottom boundary layer tracer diffusivity that !! will allow for explicitly specified bottom fluxes - !! [Z2 T-1 ~> m2 s-1]. The entrainment at the bottom is at - !! least sqrt(Kd_BBL_tr*dt) over the same distance. + !! [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1]. The entrainment at the + !! bottom is at least sqrt(Kd_BBL_tr*dt) over the same distance. real :: Kd_min_tr !< A minimal diffusivity that should always be !! applied to tracers, especially in massless layers - !! near the bottom [Z2 T-1 ~> m2 s-1]. + !! near the bottom [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: minimum_forcing_depth !< The smallest depth over which heat and freshwater !! fluxes are applied [H ~> m or kg m-2]. real :: evap_CFL_limit = 0.8 !< The largest fraction of a layer that can be !! evaporated in one time-step [nondim]. integer :: halo_TS_diff = 0 !< The temperature, salinity and thickness halo size that !! must be valid for the diffusivity calculations. + integer :: halo_diabatic = 0 !< The temperature, salinity, specific volume and thickness + !! halo size that must be valid for the diabatic calculations, + !! including vertical mixing and internal tide propagation. logical :: useKPP = .false. !< use CVMix/KPP diffusivities and non-local transport logical :: KPPisPassive !< If true, KPP is in passive mode, not changing answers. logical :: debug !< If true, write verbose checksums for debugging purposes. @@ -172,20 +179,28 @@ module MOM_diabatic_driver real :: MLDdensityDifference !< Density difference used to determine MLD_user [R ~> kg m-3] real :: dz_subML_N2 !< The distance over which to calculate a diagnostic of the !! average stratification at the base of the mixed layer [Z ~> m]. - real :: MLD_EN_VALS(3) !< Energy values for energy mixed layer diagnostics + real :: MLD_En_vals(3) !< Energy values for energy mixed layer diagnostics [R Z3 T-2 ~> J m-2] + real :: BMLD_En_vals(3) !< Energy values for energy bottom mixed layer diagnostics [R Z3 T-2 ~> J m-2] + logical :: use_OM4_MLD_En_iter !< If true, uses an older iteration in the energetics MLD calculation to bitwise + !! reproduce OM4 era models + real :: ref_h_mld = 0.0 !< The depth of the "surface" density used in a difference mixed based + !! MLD calculation [Z ~> m]. + logical :: Use_KdWork_diag = .false. !< Logical flag to indicate if any Kd_work diagnostics are on. + logical :: Use_N2_diag = .false. !< Logical flag to indicate if any N2 diagnostics are on. !>@{ Diagnostic IDs - integer :: id_cg1 = -1 ! diag handle for mode-1 speed - integer, allocatable, dimension(:) :: id_cn ! diag handle for all mode speeds integer :: id_ea = -1, id_eb = -1 ! used by layer diabatic integer :: id_ea_t = -1, id_eb_t = -1, id_ea_s = -1, id_eb_s = -1 integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_int = -1, id_Kd_ePBL = -1 integer :: id_Tdif = -1, id_Sdif = -1, id_Tadv = -1, id_Sadv = -1 + integer :: id_N2_dd = -1, id_N2_salt_dd = -1, id_N2_temp_dd ! These are handles to diagnostics related to the mixed layer properties. integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 + integer :: id_MLD_003_zr = -1, id_MLD_003_rr = -1 integer :: id_MLD_EN1 = -1, id_MLD_EN2 = -1, id_MLD_EN3 = -1, id_subMLN2 = -1 + integer :: id_BMLD_EN1 = -1, id_BMLD_EN2 = -1, id_BMLD_EN3 = -1 - ! These are handles to diatgnostics that are only available in non-ALE layered mode. + ! These are handles to diagnostics that are only available in non-ALE layered mode. integer :: id_wd = -1 integer :: id_dudt_dia = -1, id_dvdt_dia = -1 integer :: id_hf_dudt_dia_2d = -1, id_hf_dvdt_dia_2d = -1 @@ -232,27 +247,20 @@ module MOM_diabatic_driver type(KPP_CS), pointer :: KPP_CSp => NULL() !< Control structure for a child module type(diapyc_energy_req_CS), pointer :: diapyc_en_rec_CSp => NULL() !< Control structure for a child module type(oda_incupd_CS), pointer :: oda_incupd_CSp => NULL() !< Control structure for a child module - type(bulkmixedlayer_CS) :: bulkmixedlayer !< Bulk mixed layer control struct - type(CVMix_conv_CS) :: CVMix_conv !< CVMix convection control struct - type(energetic_PBL_CS) :: energetic_PBL !< Energetic PBL control struct - type(entrain_diffusive_CS) :: entrain_diffusive !< Diffusive entrainment control struct - type(geothermal_CS) :: geothermal !< Geothermal control struct - type(int_tide_CS) :: int_tide !< Internal tide control struct - type(opacity_CS) :: opacity !< Opacity control struct - type(regularize_layers_CS) :: regularize_layers !< Regularize layer control struct + type(int_tide_CS), pointer :: int_tide_CSp => NULL() !< Control structure for a child module + type(vbf_CS), pointer :: VBF => NULL() !< Control structure for a child module + + + type(bulkmixedlayer_CS) :: bulkmixedlayer !< Bulk mixed layer control structure + type(CVMix_conv_CS) :: CVMix_conv !< CVMix convection control structure + type(energetic_PBL_CS) :: ePBL !< Energetic PBL control structure + type(entrain_diffusive_CS) :: entrain_diffusive !< Diffusive entrainment control structure + type(geothermal_CS) :: geothermal !< Geothermal control structure + type(opacity_CS) :: opacity !< Opacity control structure + type(regularize_layers_CS) :: regularize_layers !< Regularize layer control structure type(group_pass_type) :: pass_hold_eb_ea !< For group halo pass - type(group_pass_type) :: pass_Kv !< For group halo pass - type(diag_grid_storage) :: diag_grids_prev!< Stores diagnostic grids at some previous point in the algorithm - ! Data arrays for communicating between components - !### Why are these arrays in this control structure, and not local variables in the various routines? - real, allocatable, dimension(:,:,:) :: KPP_NLTheat !< KPP non-local transport for heat [nondim] - real, allocatable, dimension(:,:,:) :: KPP_NLTscalar !< KPP non-local transport for scalars [nondim] - real, allocatable, dimension(:,:,:) :: KPP_buoy_flux !< KPP forcing buoyancy flux [L2 T-3 ~> m2 s-3] - real, allocatable, dimension(:,:) :: KPP_temp_flux !< KPP effective temperature flux - !! [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] - real, allocatable, dimension(:,:) :: KPP_salt_flux !< KPP effective salt flux - !! [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + type(diag_grid_storage) :: diag_grids_prev !< Stores diagnostic grids at some previous point in the algorithm type(time_type), pointer :: Time !< Pointer to model time (needed for sponges) end type diabatic_CS @@ -268,7 +276,7 @@ module MOM_diabatic_driver !> This subroutine imposes the diapycnal mass fluxes and the !! accompanying diapycnal advection of momentum and tracers. -subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & +subroutine diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, stoch_CS, OBC, Waves) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -277,7 +285,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs - real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: BLD !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields !! unused fields have NULL ptrs type(vertvisc_type), intent(inout) :: visc !< Structure with vertical viscosities, @@ -296,34 +304,19 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & - eta ! Interface heights before diapycnal mixing [m]. - real, dimension(SZI_(G),SZJ_(G),CS%nMode) :: & - cn_IGW ! baroclinic internal gravity wave speeds [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: temp_diag ! Previous temperature for diagnostics [degC] - integer :: i, j, k, m, is, ie, js, je, nz + eta ! Interface heights before diapycnal mixing [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: temp_diag ! Previous temperature for diagnostics [C ~> degC] + real, dimension(SZI_(G)) :: T_freeze, & ! The freezing potential temperature at the current salinity [C ~> degC]. + ps ! Surface pressure [R L2 T-2 ~> Pa] + real, dimension(SZI_(G),SZK_(GV)) :: & + pressure ! The pressure at the middle of each layer [R L2 T-2 ~> Pa]. + real :: H_to_RL2_T2 ! A conversion factor from thicknesses in H to pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] + integer :: i, j, k, is, ie, js, je, nz logical :: showCallTree ! If true, show the call tree - real, allocatable, dimension(:,:,:) :: h_in ! thickness before thermodynamics - real, allocatable, dimension(:,:,:) :: t_in ! temperature before thermodynamics - real, allocatable, dimension(:,:,:) :: s_in ! salinity before thermodynamics - real :: t_tend,s_tend,h_tend ! holder for tendencey needed for SPPT - real :: t_pert,s_pert,h_pert ! holder for perturbations needed for SPPT - - if (G%ke == 1) return - - ! save copy of the date for SPPT if active - if (stoch_CS%do_sppt) then - allocate(h_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) - allocate(t_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) - allocate(s_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) - h_in(:,:,:)=h(:,:,:) - t_in(:,:,:)=tv%T(:,:,:) - s_in(:,:,:)=tv%S(:,:,:) - - if (stoch_CS%id_sppt_wts > 0) then - call post_data(stoch_CS%id_sppt_wts, stoch_CS%sppt_wts, CS%diag) - endif - endif + real, allocatable, dimension(:,:,:) :: h_in ! thickness before thermodynamics [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: t_in ! temperature before thermodynamics [C ~> degC] + real, allocatable, dimension(:,:,:) :: s_in ! salinity before thermodynamics [S ~> ppt] if (GV%ke == 1) return @@ -342,7 +335,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & showCallTree = callTree_showQuery() - ! Offer diagnostics of various state varables at the start of diabatic + ! Offer diagnostics of various state variables at the start of diabatic ! these are mostly for debugging purposes. if (CS%id_u_predia > 0) call post_data(CS%id_u_predia, u, CS%diag) if (CS%id_v_predia > 0) call post_data(CS%id_v_predia, v, CS%diag) @@ -350,10 +343,17 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%id_T_predia > 0) call post_data(CS%id_T_predia, tv%T, CS%diag) if (CS%id_S_predia > 0) call post_data(CS%id_S_predia, tv%S, CS%diag) if (CS%id_e_predia > 0) then - call find_eta(h, tv, G, GV, US, eta, eta_to_m=1.0, dZref=G%Z_ref) + call find_eta(h, tv, G, GV, US, eta, dZref=G%Z_ref) call post_data(CS%id_e_predia, eta, CS%diag) endif + ! Save a copy of the initial state if stochastic perturbations are active. + if (stoch_CS%do_sppt) then + allocate(h_in(G%isd:G%ied, G%jsd:G%jed, GV%ke)) ; h_in(:,:,:) = h(:,:,:) + allocate(t_in(G%isd:G%ied, G%jsd:G%jed, GV%ke)) ; t_in(:,:,:) = tv%T(:,:,:) + allocate(s_in(G%isd:G%ied, G%jsd:G%jed, GV%ke)) ; s_in(:,:,:) = tv%S(:,:,:) + endif + if (CS%debug) then call MOM_state_chksum("Start of diabatic ", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("Start of diabatic", fluxes, G, US, haloshift=0) @@ -364,7 +364,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & call diapyc_energy_req_test(h, dt, tv, G, GV, US, CS%diapyc_en_rec_CSp) call cpu_clock_begin(id_clock_set_diffusivity) - call set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS%set_diff_CSp, OBC=OBC) + call set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS%set_diff_CSp, OBC=OBC) call cpu_clock_end(id_clock_set_diffusivity) ! Frazil formation keeps the temperature above the freezing point. @@ -372,7 +372,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! the end of the diabatic processes. if (associated(tv%T) .AND. associated(tv%frazil)) then ! For frazil diagnostic, the first call covers the first half of the time step - call enable_averages(0.5*dt, Time_end - real_to_time(0.5*US%T_to_s*dt), CS%diag) + call enable_averages(0.5*dt, Time_end - real_to_time(0.5*dt, unscale=US%T_to_s), CS%diag) if (CS%frazil_tendency_diag) then do k=1,nz ; do j=js,je ; do i=is,ie temp_diag(i,j,k) = tv%T(i,j,k) @@ -398,31 +398,31 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! This block provides an interface for the unresolved low-mode internal tide module. call set_int_tide_input(u, v, h, tv, fluxes, CS%int_tide_input, dt, G, GV, US, & CS%int_tide_input_CSp) - cn_IGW(:,:,:) = 0.0 - if (CS%uniform_test_cg > 0.0) then - do m=1,CS%nMode ; cn_IGW(:,:,m) = CS%uniform_test_cg ; enddo - else - call wave_speeds(h, tv, G, GV, US, CS%nMode, cn_IGW, full_halos=.true.) - endif - call propagate_int_tide(h, tv, cn_IGW, CS%int_tide_input%TKE_itidal_input, CS%int_tide_input%tideamp, & - CS%int_tide_input%Nb, dt, G, GV, US, CS%int_tide) + call propagate_int_tide(h, tv, CS%int_tide_input%Nb, CS%int_tide_input%Rho_bot, dt, & + G, GV, US, CS%int_tide_input_CSp, CS%int_tide_CSp) + if (showCallTree) call callTree_waypoint("done with propagate_int_tide (diabatic)") endif ! end CS%use_int_tides if (CS%useALEalgorithm .and. CS%use_legacy_diabatic) then - call diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + call diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, stoch_CS, Waves) elseif (CS%useALEalgorithm) then - call diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + call diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, stoch_CS, Waves) else - call layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + call layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, Waves) endif - call cpu_clock_begin(id_clock_pass) + if (associated(visc%sfc_buoy_flx)) & + call pass_var(visc%sfc_buoy_flx, G%domain, halo=1, complete=.not.associated(visc%MLD)) + if (associated(visc%h_ML)) & + call pass_var(visc%h_ML, G%Domain, halo=1, complete=.not.associated(visc%MLD)) + if (associated(visc%MLD)) & + call pass_var(visc%MLD, G%Domain, halo=1, complete=.true.) if (associated(visc%Kv_shear)) & call pass_var(visc%Kv_shear, G%Domain, To_All+Omit_Corners, halo=1) call cpu_clock_end(id_clock_pass) @@ -456,65 +456,80 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & endif ! endif for frazil + if (stoch_CS%do_sppt) then + ! perturb diabatic tendencies. + ! These stochastic perturbations do not conserve heat, salt or mass. + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = max(h_in(i,j,k) + (h(i,j,k)-h_in(i,j,k)) * stoch_CS%sppt_wts(i,j), GV%Angstrom_H) + tv%S(i,j,k) = max(s_in(i,j,k) + (tv%S(i,j,k)-s_in(i,j,k)) * stoch_CS%sppt_wts(i,j), 0.0) + enddo ; enddo ; enddo + ! now that we have updated thickness and salinity, calculate freeing point + H_to_RL2_T2 = GV%H_to_RZ * GV%g_Earth + do j=js,je + ps(:) = 0.0 + if (associated(fluxes%p_surf)) then + do i=is,ie + ps(i) = fluxes%p_surf(i,j) + enddo + endif + + do i=is,ie + pressure(i,1) = ps(i) + (0.5*H_to_RL2_T2)*h(i,j,1) + enddo + do k=2,nz ; do i=is,ie + pressure(i,k) = pressure(i,k-1) + & + (0.5*H_to_RL2_T2) * (h(i,j,k) + h(i,j,k-1)) + enddo ; enddo + do k=1,nz + call calculate_TFreeze(tv%S(is:ie,j,k), pressure(is:ie,k), T_freeze(is:ie), & + tv%eqn_of_state) + do i=is,ie + tv%T(i,j,k) = max(t_in(i,j,k) + (tv%T(i,j,k)-t_in(i,j,k)) * stoch_CS%sppt_wts(i,j), T_freeze(i)) + enddo + enddo + enddo + + deallocate(h_in, t_in, s_in) + endif ! Diagnose mixed layer depths. call enable_averages(dt, Time_end, CS%diag) if (CS%id_MLD_003 > 0 .or. CS%id_subMLN2 > 0 .or. CS%id_mlotstsq > 0) then call diagnoseMLDbyDensityDifference(CS%id_MLD_003, h, tv, 0.03*US%kg_m3_to_R, G, GV, US, CS%diag, & + CS%ref_h_mld, CS%id_MLD_003_zr, CS%id_MLD_003_rr, & id_N2subML=CS%id_subMLN2, id_MLDsq=CS%id_mlotstsq, dz_subML=CS%dz_subML_N2) endif if (CS%id_MLD_0125 > 0) then - call diagnoseMLDbyDensityDifference(CS%id_MLD_0125, h, tv, 0.125*US%kg_m3_to_R, G, GV, US, CS%diag) + call diagnoseMLDbyDensityDifference(CS%id_MLD_0125, h, tv, 0.125*US%kg_m3_to_R, G, GV, US, CS%diag, & + ref_H_MLD=0.0, id_ref_z=-1, id_ref_rho=-1) endif if (CS%id_MLD_user > 0) then - call diagnoseMLDbyDensityDifference(CS%id_MLD_user, h, tv, CS%MLDdensityDifference, G, GV, US, CS%diag) + call diagnoseMLDbyDensityDifference(CS%id_MLD_user, h, tv, CS%MLDdensityDifference, G, GV, US, CS%diag, & + ref_H_MLD=0.0, id_ref_z=-1, id_ref_rho=-1) endif if ((CS%id_MLD_EN1 > 0) .or. (CS%id_MLD_EN2 > 0) .or. (CS%id_MLD_EN3 > 0)) then - call diagnoseMLDbyEnergy((/CS%id_MLD_EN1, CS%id_MLD_EN2, CS%id_MLD_EN3/),& - h, tv, G, GV, US, CS%MLD_EN_VALS, CS%diag) + ! Surface Mixed Layer diagnostic + call diagnoseMLDbyEnergy((/CS%id_MLD_EN1, CS%id_MLD_EN2, CS%id_MLD_EN3/), h, tv, G, GV, US, CS%MLD_En_vals, & + (/1,nz/), CS%diag, OM4_iteration=CS%use_OM4_MLD_En_iter) endif - if (CS%use_int_tides) then - if (CS%id_cg1 > 0) call post_data(CS%id_cg1, cn_IGW(:,:,1),CS%diag) - do m=1,CS%nMode ; if (CS%id_cn(m) > 0) call post_data(CS%id_cn(m), cn_IGW(:,:,m), CS%diag) ; enddo + if ((CS%id_BMLD_EN1 > 0) .or. (CS%id_BMLD_EN2 > 0) .or. (CS%id_BMLD_EN3 > 0)) then + ! Bottom Mixed Layer diagnostic + call diagnoseMLDbyEnergy((/CS%id_BMLD_EN1, CS%id_BMLD_EN2, CS%id_BMLD_EN3/), h, tv, G, GV, US, CS%BMLD_En_vals, & + (/nz,1/), CS%diag, OM4_iteration=.false.) endif + if (stoch_CS%do_sppt .and. stoch_CS%id_sppt_wts > 0) & + call post_data(stoch_CS%id_sppt_wts, stoch_CS%sppt_wts, CS%diag) + call disable_averaging(CS%diag) if (CS%debugConservation) call MOM_state_stats('leaving diabatic', u, v, h, tv%T, tv%S, G, GV, US) - if (stoch_CS%do_sppt) then - ! perturb diabatic tendecies - do k=1,nz - do j=js,je - do i=is,ie - h_tend = (h(i,j,k)-h_in(i,j,k))*stoch_CS%sppt_wts(i,j) - t_tend = (tv%T(i,j,k)-t_in(i,j,k))*stoch_CS%sppt_wts(i,j) - s_tend = (tv%S(i,j,k)-s_in(i,j,k))*stoch_CS%sppt_wts(i,j) - h_pert=h_tend+h_in(i,j,k) - t_pert=t_tend+t_in(i,j,k) - s_pert=s_tend+s_in(i,j,k) - if (h_pert > GV%Angstrom_H) then - h(i,j,k) = h_pert - else - h(i,j,k) = GV%Angstrom_H - endif - tv%T(i,j,k) = t_pert - if (s_pert > 0.0) then - tv%S(i,j,k) = s_pert - endif - enddo - enddo - enddo - deallocate(h_in) - deallocate(t_in) - deallocate(s_in) - endif - end subroutine diabatic !> Applies diabatic forcing and diapycnal mixing of temperature, salinity and other tracers for use !! with an ALE algorithm. This version uses an older set of algorithms compared with diabatic_ALE. -subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & +subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, stoch_CS, Waves) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -524,7 +539,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs - real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: BLD !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields !! unused fields have NULL ptrs type(vertvisc_type), intent(inout) :: visc !< Structure with vertical viscosities, @@ -542,32 +557,51 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & h_orig, & ! Initial layer thicknesses [H ~> m or kg m-2] - dSV_dT, & ! The partial derivative of specific volume with temperature [R-1 degC-1 ~> m3 kg-1 degC-1] - dSV_dS, & ! The partial derivative of specific volume with salinity [R-1 ppt-1 ~> m3 kg-1 ppt-1]. + dz, & ! The vertical distance between interfaces around a layer [Z ~> m] + dSV_dT, & ! The partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSV_dS, & ! The partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. cTKE, & ! convective TKE requirements for each layer [R Z3 T-2 ~> J m-2]. u_h, & ! Zonal velocities interpolated to thickness points [L T-1 ~> m s-1] v_h, & ! Meridional velocities interpolated to thickness points [L T-1 ~> m s-1] - temp_diag, & ! Diagnostic array of previous temperatures [degC] - saln_diag ! Diagnostic array of previous salinity [ppt] + temp_diag, & ! Diagnostic array of previous temperatures [C ~> degC] + saln_diag ! Diagnostic array of previous salinity [S ~> ppt] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & ent_s, & ! The diffusive coupling across interfaces within one time step for ! salinity and passive tracers [H ~> m or kg m-2] ent_t, & ! The diffusive coupling across interfaces within one time step for ! temperature [H ~> m or kg m-2] - Kd_int, & ! diapycnal diffusivity of interfaces [Z2 T-1 ~> m2 s-1] - Kd_heat, & ! diapycnal diffusivity of heat [Z2 T-1 ~> m2 s-1] - Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [Z2 T-1 ~> m2 s-1] + Kd_int, & ! diapycnal diffusivity of interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_heat, & ! diapycnal diffusivity of heat [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_extra_T , & ! The extra diffusivity of temperature due to double diffusion relative to - ! Kd_int [Z2 T-1 ~> m2 s-1]. + ! Kd_int [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_extra_S , & ! The extra diffusivity of salinity due to double diffusion relative to - ! Kd_int [Z2 T-1 ~> m2 s-1]. - Kd_ePBL, & ! test array of diapycnal diffusivities at interfaces [Z2 T-1 ~> m2 s-1] - Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] - Sdif_flx ! diffusive diapycnal salt flux across interfaces [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + ! Kd_int [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_ePBL, & ! test array of diapycnal diffusivities at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + KPP_NLTheat, & ! KPP non-local transport for heat [nondim] + KPP_NLTscalar, & ! KPP non-local transport for scalars [nondim] + KPP_buoy_flux, & ! KPP forcing buoyancy flux [L2 T-3 ~> m2 s-3] + Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + N2_salt, & !< Salinity contribution to squared buoyancy frequency at interfaces [T-2 ~> s-2] + N2_temp !< Temperature contribution to squared buoyancy frequency at interfaces [T-2 ~> s-2] real, dimension(SZI_(G),SZJ_(G)) :: & - SkinBuoyFlux ! 2d surface buoyancy flux [Z2 T-3 ~> m2 s-3], used by ePBL + U_star, & ! The friction velocity [Z T-1 ~> m s-1]. + KPP_temp_flux, & ! KPP effective temperature flux [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + KPP_salt_flux, & ! KPP effective salt flux [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + SkinBuoyFlux, & ! 2d surface buoyancy flux [Z2 T-3 ~> m2 s-3], used by ePBL + BBL_BuoyFlux ! 2d bottom buoyancy flux [Z2 T-3 ~> m2 s-3], used by ePBL + + real, dimension(SZI_(G)) :: & + p_i ,& ! Pressure at the interface [R L2 T-2 ~> Pa] + T_i, & ! Temperature at the interface [C ~> degC] + S_i, & ! Salinity at the interface [S ~> ppt] + drhodS, & ! Local change in density w.r.t. salinity using model EOS & state [R C-1 ~> kg m-3 ppt-1] + drhodT, & ! Local change in density w.r.t. temperature using model EOS & state [R C-1 ~> kg m-3 degC-1] + dSpV_dT, & ! Partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSpV_dS ! Partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1] logical, dimension(SZI_(G)) :: & in_boundary ! True if there are no massive layers below, where massive is defined as @@ -576,28 +610,39 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2] - real :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4] + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m] + real :: dz_neglect2 ! dz_neglect^2 [Z2 ~> m2] real :: add_ent ! Entrainment that needs to be added when mixing tracers [H ~> m or kg m-2] - real :: I_hval ! The inverse of the thicknesses averaged to interfaces [H-1 ~> m-1 or m2 kg-1] - real :: h_tr ! h_tr is h at tracer points with a tiny thickness - ! added to ensure positive definiteness [H ~> m or kg m-2] + real :: I_dzval ! The inverse of the thicknesses averaged to interfaces [Z-1 ~> m-1] + real :: I_h ! The inverse of the thicknesses averaged to interfaces [H-1 ~> m-1 or m2 kg-1] real :: Tr_ea_BBL ! The diffusive tracer thickness in the BBL that is ! coupled to the bottom within a timestep [H ~> m or kg m-2] - real :: Kd_add_here ! An added diffusivity [Z2 T-1 ~> m2 s-1]. + real :: Kd_add_here ! An added diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real :: htot(SZIB_(G)) ! The summed thickness from the bottom [H ~> m or kg m-2]. real :: Ent_int ! The diffusive entrainment rate at an interface [H ~> m or kg m-2] real :: Idt ! The inverse time step [T-1 ~> s-1] + real :: g_Rho0 ! G_Earth/Rho0 [H T-2 R-1 ~> m4 s-2 kg-1 or m s-2] + real :: H_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] + real :: alt_H_to_pres! A conversion factor from thicknesses to pressure w/ alternative scaling [R Z T-2 ~> Pa m-1] + logical :: nonBous ! True if not using the Boussinesq approximation - integer :: dir_flag ! An integer encoding the directions in which to do halo updates. - logical :: showCallTree ! If true, show the call tree - integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, m + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state - integer :: ig, jg ! global indices for testing testing itide point source (BDM) + logical :: showCallTree ! If true, show the call tree + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect*h_neglect + dz_neglect = GV%dZ_subroundoff ; dz_neglect2 = dz_neglect*dz_neglect + h_neglect = GV%H_subroundoff + + nonBous = .not.(GV%Boussinesq .or. GV%semi_Boussinesq) + g_Rho0 = GV%g_Earth_Z_T2 / GV%H_to_RZ + H_to_pres = GV%H_to_RZ * GV%g_Earth + alt_H_to_pres = H_to_pres * US%L_to_Z**2 * GV%Z_to_H + Kd_heat(:,:,:) = 0.0 ; Kd_salt(:,:,:) = 0.0 showCallTree = callTree_showQuery() @@ -606,9 +651,11 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! For all other diabatic subroutines, the averaging window should be the entire diabatic timestep call enable_averages(dt, Time_end, CS%diag) + if (CS%Use_KdWork_diag) call Allocate_VBF_CS(G, GV, CS%VBF) + if (CS%use_geothermal) then call cpu_clock_begin(id_clock_geothermal) - call geothermal_in_place(h, tv, dt, G, GV, US, CS%geothermal, halo=CS%halo_TS_diff) + call geothermal_in_place(h, tv, dt, G, GV, US, CS%geothermal, BBL_BuoyFlux, halo=CS%halo_TS_diff) call cpu_clock_end(id_clock_geothermal) if (showCallTree) call callTree_waypoint("geothermal (diabatic)") if (CS%debugConservation) call MOM_state_stats('geothermal', u, v, h, tv%T, tv%S, G, GV, US) @@ -642,10 +689,10 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call MOM_state_chksum("before set_diffusivity", u, v, h, G, GV, US, haloshift=CS%halo_TS_diff) if (CS%double_diffuse) then call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, visc, dt, Kd_int, G, GV, US, & - CS%set_diff_CSp, Kd_extra_T=Kd_extra_T, Kd_extra_S=Kd_extra_S) + CS%set_diff_CSp, CS%VBF, Kd_extra_T=Kd_extra_T, Kd_extra_S=Kd_extra_S) else call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, visc, dt, Kd_int, G, GV, US, & - CS%set_diff_CSp) + CS%set_diff_CSp, CS%VBF) endif call cpu_clock_end(id_clock_set_diffusivity) if (showCallTree) call callTree_waypoint("done with set_diffusivity (diabatic)") @@ -655,7 +702,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call MOM_state_chksum("after set_diffusivity ", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after set_diffusivity ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after set_diffusivity ", tv, G, US) - call hchksum(Kd_Int, "after set_diffusivity Kd_Int", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_Int, "after set_diffusivity Kd_Int", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif ! Set diffusivities for heat and salt separately @@ -676,42 +723,52 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim endif if (CS%debug) then - call hchksum(Kd_heat, "after set_diffusivity Kd_heat", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kd_salt, "after set_diffusivity Kd_salt", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_heat, "after set_diffusivity Kd_heat", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Kd_salt, "after set_diffusivity Kd_salt", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif call cpu_clock_begin(id_clock_kpp) ! total vertical viscosity in the interior is represented via visc%Kv_shear + ! NOTE: The following do not require initialization, but their checksums do + ! require initialization, and past versions were initialized to zero. + KPP_NLTheat(:,:,:) = 0. + KPP_NLTscalar(:,:,:) = 0. + KPP_buoy_flux(:,:,:) = 0. + KPP_temp_flux(:,:) = 0. + KPP_salt_flux(:,:) = 0. + ! KPP needs the surface buoyancy flux but does not update state variables. ! We could make this call higher up to avoid a repeat unpacking of the surface fluxes. - ! Sets: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux - ! NOTE: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux are returned as rates (i.e. stuff per second) + ! Sets: KPP_buoy_flux, KPP_temp_flux, KPP_salt_flux + ! NOTE: KPP_buoy_flux, KPP_temp_flux, KPP_salt_flux are returned as rates (i.e. stuff per second) ! unlike other instances where the fluxes are integrated in time over a time-step. call calculateBuoyancyFlux2d(G, GV, US, fluxes, CS%optics, h, tv%T, tv%S, tv, & - CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux) - ! The KPP scheme calculates boundary layer diffusivities and non-local transport. + KPP_buoy_flux, KPP_temp_flux, KPP_salt_flux) + ! Determine the friction velocity, perhaps using the evovling surface density. + call find_ustar(fluxes, tv, U_star, G, GV, US) + + ! The KPP scheme calculates boundary layer diffusivities and non-local transport. if ( associated(fluxes%lamult) ) then call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & - fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) + U_star, KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & - Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, KPP_buoy_flux, Kd_heat, & + Kd_salt, visc%Kv_shear, KPP_NLTheat, KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) else call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & - fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) + U_star, KPP_buoy_flux, Waves=Waves) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & - Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, KPP_buoy_flux, Kd_heat, & + Kd_salt, visc%Kv_shear, KPP_NLTheat, KPP_NLTscalar, Waves=Waves) endif - if (associated(Hml)) then - call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G, US) - call pass_var(Hml, G%domain, halo=1) - ! If visc%MLD exists, copy KPP's BLD into it - if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) - endif + call KPP_get_BLD(CS%KPP_CSp, BLD(:,:), G, US) + ! If visc%MLD or visc%h_ML exist, copy KPP's BLD into them with appropriate conversions. + if (associated(visc%h_ML)) call convert_MLD_to_ML_thickness(BLD, h, visc%h_ML, tv, G, GV) + if (associated(visc%MLD)) visc%MLD(:,:) = BLD(:,:) + if (associated(visc%sfc_buoy_flx)) visc%sfc_buoy_flx(:,:) = KPP_buoy_flux(:,:,1) if (.not.CS%KPPisPassive) then !$OMP parallel do default(shared) @@ -732,19 +789,21 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call MOM_state_chksum("after KPP", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after KPP", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after KPP", tv, G, US) - call hchksum(Kd_heat, "after KPP Kd_heat", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kd_salt, "after KPP Kd_salt", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(CS%KPP_temp_flux, "before KPP_applyNLT netHeat", G%HI, haloshift=0, scale=GV%H_to_m*US%s_to_T) - call hchksum(CS%KPP_salt_flux, "before KPP_applyNLT netSalt", G%HI, haloshift=0, scale=GV%H_to_m*US%s_to_T) - call hchksum(CS%KPP_NLTheat, "before KPP_applyNLT NLTheat", G%HI, haloshift=0) - call hchksum(CS%KPP_NLTscalar, "before KPP_applyNLT NLTscalar", G%HI, haloshift=0) + call hchksum(Kd_heat, "after KPP Kd_heat", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Kd_salt, "after KPP Kd_salt", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(KPP_temp_flux, "before KPP_applyNLT netHeat", G%HI, haloshift=0, & + unscale=US%C_to_degC*GV%H_to_m*US%s_to_T) + call hchksum(KPP_salt_flux, "before KPP_applyNLT netSalt", G%HI, haloshift=0, & + unscale=US%S_to_ppt*GV%H_to_m*US%s_to_T) + call hchksum(KPP_NLTheat, "before KPP_applyNLT NLTheat", G%HI, haloshift=0) + call hchksum(KPP_NLTscalar, "before KPP_applyNLT NLTscalar", G%HI, haloshift=0) endif ! Apply non-local transport of heat and salt ! Changes: tv%T, tv%S - call KPP_NonLocalTransport_temp(CS%KPP_CSp, G, GV, h, CS%KPP_NLTheat, CS%KPP_temp_flux, & - dt, tv%T, tv%C_p) - call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, CS%KPP_NLTscalar, CS%KPP_salt_flux, & - dt, tv%S) + call KPP_NonLocalTransport_temp(CS%KPP_CSp, G, GV, h, KPP_NLTheat, KPP_temp_flux, & + dt, tv%tr_T, tv%T, tv%C_p) + call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, KPP_NLTscalar, KPP_salt_flux, & + dt, tv%tr_S, tv%S) call cpu_clock_end(id_clock_kpp) if (showCallTree) call callTree_waypoint("done with KPP_applyNonLocalTransport (diabatic)") if (CS%debugConservation) call MOM_state_stats('KPP_applyNonLocalTransport', u, v, h, tv%T, tv%S, G, GV, US) @@ -761,7 +820,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim if (CS%double_diffuse .and. associated(tv%T)) then call cpu_clock_begin(id_clock_differential_diff) - call differential_diffuse_T_S(h, tv%T, tv%S, Kd_extra_T, Kd_extra_S, dt, G, GV) + call differential_diffuse_T_S(h, tv%T, tv%S, Kd_extra_T, Kd_extra_S, tv, dt, G, GV) call cpu_clock_end(id_clock_differential_diff) if (showCallTree) call callTree_waypoint("done with differential_diffuse_T_S (diabatic)") @@ -782,18 +841,21 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! Calculate vertical mixing due to convection (computed via CVMix) if (CS%use_CVMix_conv) then ! Increment vertical diffusion and viscosity due to convection - call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv, Hml, Kd_int, visc%Kv_slow) + call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv, BLD, Kd_int, visc%Kv_shear) endif + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, G, GV, US) + ! This block sets ent_t and ent_s from h and Kd_int. do j=js,je ; do i=is,ie ent_s(i,j,1) = 0.0 ; ent_s(i,j,nz+1) = 0.0 ent_t(i,j,1) = 0.0 ; ent_t(i,j,nz+1) = 0.0 enddo ; enddo - !$OMP parallel do default(shared) private(I_hval) + !$OMP parallel do default(shared) private(I_dzval) do K=2,nz ; do j=js,je ; do i=is,ie - I_hval = 1.0 / (h_neglect + 0.5*(h(i,j,k-1) + h(i,j,k))) - ent_s(i,j,K) = (GV%Z_to_H**2) * dt * I_hval * Kd_int(i,j,K) + I_dzval = 1.0 / (dz_neglect + 0.5*(dz(i,j,k-1) + dz(i,j,k))) + ent_s(i,j,K) = dt * I_dzval * Kd_int(i,j,K) ent_t(i,j,K) = ent_s(i,j,K) enddo ; enddo ; enddo if (showCallTree) call callTree_waypoint("done setting ent_s and ent_t from Kd_int (diabatic)") @@ -802,7 +864,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call MOM_forcing_chksum("after calc_entrain ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after calc_entrain ", tv, G, US) call MOM_state_chksum("after calc_entrain ", u, v, h, G, GV, US, haloshift=0) - call hchksum(ent_s, "after calc_entrain ent_s", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(ent_s, "after calc_entrain ent_s", G%HI, haloshift=0, unscale=GV%H_to_MKS) endif ! Save fields before boundary forcing is applied for tendency diagnostics @@ -824,31 +886,37 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim skinbuoyflux(:,:) = 0.0 call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & - optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, CS%evap_CFL_limit, & - CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux) + optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, CS%evap_CFL_limit, & + CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux, MLD_h=visc%h_ML) if (CS%debug) then - call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, scale=GV%H_to_m) - call hchksum(ent_s, "after applyBoundaryFluxes ent_s", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, unscale=GV%H_to_mks) + call hchksum(ent_s, "after applyBoundaryFluxes ent_s", G%HI, haloshift=0, unscale=GV%H_to_mks) call hchksum(cTKE, "after applyBoundaryFluxes cTKE", G%HI, haloshift=0, & - scale=US%RZ3_T3_to_W_m2*US%T_to_s) - call hchksum(dSV_dT, "after applyBoundaryFluxes dSV_dT", G%HI, haloshift=0, scale=US%kg_m3_to_R) - call hchksum(dSV_dS, "after applyBoundaryFluxes dSV_dS", G%HI, haloshift=0, scale=US%kg_m3_to_R) + unscale=US%RZ3_T3_to_W_m2*US%T_to_s) + call hchksum(dSV_dT, "after applyBoundaryFluxes dSV_dT", G%HI, haloshift=0, & + unscale=US%kg_m3_to_R*US%degC_to_C) + call hchksum(dSV_dS, "after applyBoundaryFluxes dSV_dS", G%HI, haloshift=0, & + unscale=US%kg_m3_to_R*US%ppt_to_S) + call hchksum(h, "after applyBoundaryFluxes h", G%HI, haloshift=0, unscale=GV%H_to_mks) + call hchksum(tv%T, "after applyBoundaryFluxes tv%T", G%HI, haloshift=0, unscale=US%C_to_degC) + call hchksum(tv%S, "after applyBoundaryFluxes tv%S", G%HI, haloshift=0, unscale=US%S_to_ppt) + call hchksum(SkinBuoyFlux, "after applyBdryFlux SkinBuoyFlux", G%HI, haloshift=0, & + unscale=US%Z_to_m**2*US%s_to_T**3) endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) - call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & - CS%energetic_PBL, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) + call energetic_PBL(h, u_h, v_h, tv, fluxes, visc, dt, Kd_ePBL, G, GV, US, & + CS%ePBL, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, BBL_BuoyFlux, waves=waves) - if (associated(Hml)) then - call energetic_PBL_get_MLD(CS%energetic_PBL, Hml(:,:), G, US) - call pass_var(Hml, G%domain, halo=1) - ! If visc%MLD exists, copy ePBL's MLD into it - if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) - elseif (associated(visc%MLD)) then - call energetic_PBL_get_MLD(CS%energetic_PBL, visc%MLD, G, US) - call pass_var(visc%MLD, G%domain, halo=1) - endif + call energetic_PBL_get_MLD(CS%ePBL, BLD(:,:), G, US) + ! If visc%MLD or visc%h_ML exist, copy ePBL's BLD into them with appropriate conversions. + if (associated(visc%h_ML)) call convert_MLD_to_ML_thickness(BLD, h, visc%h_ML, tv, G, GV) + if (associated(visc%MLD)) visc%MLD(:,:) = BLD(:,:) + if (associated(visc%sfc_buoy_flx)) visc%sfc_buoy_flx(:,:) = SkinBuoyFlux(:,:) + + ! Find the vertical distances across layers, which may have been modified by the net surface flux + call thickness_to_dz(h, tv, dz, G, GV, US) ! Augment the diffusivities and viscosity due to those diagnosed in energetic_PBL. do K=2,nz ; do j=js,je ; do i=is,ie @@ -860,7 +928,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim visc%Kv_shear(i,j,K) = max(visc%Kv_shear(i,j,K), CS%ePBL_Prandtl*Kd_ePBL(i,j,K)) endif - Ent_int = Kd_add_here * (GV%Z_to_H**2 * dt) / (0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect) + Ent_int = Kd_add_here * dt / (0.5*(dz(i,j,k-1) + dz(i,j,k)) + dz_neglect) ent_s(i,j,K) = ent_s(i,j,K) + Ent_int Kd_int(i,j,K) = Kd_int(i,j,K) + Kd_add_here @@ -871,15 +939,18 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim enddo ; enddo ; enddo if (CS%debug) then - call hchksum(ent_t, "after ePBL ent_t", G%HI, haloshift=0, scale=GV%H_to_m) - call hchksum(ent_s, "after ePBL ent_s", G%HI, haloshift=0, scale=GV%H_to_m) - call hchksum(Kd_ePBL, "after ePBL Kd_ePBL", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(ent_t, "after ePBL ent_t", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(ent_s, "after ePBL ent_s", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(Kd_ePBL, "after ePBL Kd_ePBL", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif else call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, & - CS%evap_CFL_limit, CS%minimum_forcing_depth) + CS%evap_CFL_limit, CS%minimum_forcing_depth, MLD_h=visc%h_ML) + + ! Find the vertical distances across layers, which may have been modified by the net surface flux + call thickness_to_dz(h, tv, dz, G, GV, US) endif ! endif for CS%use_energetic_PBL @@ -913,8 +984,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim if (associated(tv%T)) then if (CS%debug) then - call hchksum(ent_t, "before triDiagTS ent_t ", G%HI, haloshift=0, scale=GV%H_to_m) - call hchksum(ent_s, "before triDiagTS ent_s ", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(ent_t, "before triDiagTS ent_t ", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(ent_s, "before triDiagTS ent_s ", G%HI, haloshift=0, unscale=GV%H_to_MKS) endif call cpu_clock_begin(id_clock_tridiag) @@ -968,6 +1039,12 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! target grids for vertical remapping may need to be regenerated. call diag_update_remap_grids(CS%diag) + ! Set diffusivities for VBF diagnostics if enabled + if (CS%use_energetic_PBL .and. associated(CS%VBF%Kd_ePBL)) CS%VBF%Kd_ePBL(:,:,:) = Kd_ePBL(:,:,:) + if (associated(CS%VBF%Kd_salt)) CS%VBF%Kd_temp(:,:,:) = Kd_heat(:,:,:) + if (associated(CS%VBF%Kd_temp)) CS%VBF%Kd_salt(:,:,:) = Kd_salt(:,:,:) + + ! Diagnose the diapycnal diffusivities and other related quantities. if (CS%id_Kd_int > 0) call post_data(CS%id_Kd_int, Kd_int, CS%diag) if (CS%id_Kd_heat > 0) call post_data(CS%id_Kd_heat, Kd_heat, CS%diag) @@ -1002,11 +1079,73 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim if (CS%id_Sdif > 0) call post_data(CS%id_Sdif, Sdif_flx, CS%diag) endif + if (CS%Use_KdWork_diag .or. CS%Use_N2_diag) then + N2_salt(:,:,:) = 0.0 + N2_temp(:,:,:) = 0.0 + !Compute N2 and don't mask negatives here + EOSdom(:) = EOS_domain(G%HI) + if (nonBous) then + !$OMP parallel do default(shared) + do j=js,je + if (associated(tv%p_surf)) then + do i=is,ie ; p_i(i) = tv%p_surf(i,j) ; enddo + else + do i=is,ie ; p_i(i) = 0.0 ; enddo + endif + do K=2,nz + do i=is,ie + p_i(i) = p_i(i) + H_to_pres * h(i,j,k-1) + enddo + T_i = 0.5*(tv%T(:,j,k-1)+tv%T(:,j,k)) + S_i = 0.5*(tv%S(:,j,k-1)+tv%S(:,j,k)) + call calculate_specific_vol_derivs(T_i, S_i, p_i, dSpV_dT, dSpV_dS, tv%eqn_of_state, EOSdom) + do i=is,ie + I_dzval = 1.0 / (dz_neglect + 0.5*(dz(i,j,k-1) + dz(i,j,k))) + N2_salt(i,j,K) = (tv%S(i,j,k-1) - tv%S(i,j,k)) * (dSpv_dS(i) * (alt_H_to_pres * I_dzval)) + N2_temp(i,j,K) = (tv%T(i,j,k-1) - tv%T(i,j,k)) * (dSpV_dT(i) * (alt_H_to_pres * I_dzval)) + enddo + enddo + enddo + else + !$OMP parallel do default(shared) + do j=js,je + if (associated(tv%p_surf)) then + do i=is,ie ; p_i(i) = tv%p_surf(i,j) ; enddo + else + do i=is,ie ; p_i(i) = 0.0 ; enddo + endif + do K=2,nz + do i=is,ie + p_i(i) = p_i(i) + H_to_pres* h(i,j,k-1) + enddo + T_i = 0.5*(tv%T(:,j,k-1)+tv%T(:,j,k)) + S_i = 0.5*(tv%S(:,j,k-1)+tv%S(:,j,k)) + call calculate_density_derivs(T_i, S_i, p_i, dRhodT, dRhodS, tv%eqn_of_state, EOSdom) + do i=is,ie + I_h = 1.0 / (h_neglect + 0.5*(h(i,j,k-1) + h(i,j,k))) + N2_salt(i,j,K) = -(tv%S(i,j,k-1) - tv%S(i,j,k)) * (dRhodS(i) * (g_rho0 * I_h)) + N2_temp(i,j,K) = -(tv%T(i,j,k-1) - tv%T(i,j,k)) * (dRhodT(i) * (g_rho0 * I_h)) + enddo + enddo + enddo + endif + if (CS%id_N2_dd>0) call post_data(CS%id_N2_dd, N2_salt(:,:,:)+N2_temp(:,:,:), CS%diag) + if (CS%id_N2_salt_dd>0) call post_data(CS%id_N2_salt_dd, N2_salt, CS%diag) + if (CS%id_N2_temp_dd>0) call post_data(CS%id_N2_temp_dd, N2_temp, CS%diag) + + if (CS%Use_KdWork_diag) then + call KdWork_diagnostics(G,GV,US,CS%diag,CS%VBF,N2_salt,N2_temp,dz) + endif + + call deallocate_VBF_CS(CS%VBF) + + endif + ! mixing of passive tracers from massless boundary layers to interior call cpu_clock_begin(id_clock_tracers) if (CS%mix_boundary_tracer_ALE) then - Tr_ea_BBL = GV%Z_to_H * sqrt(dt*CS%Kd_BBL_tr) + Tr_ea_BBL = sqrt(dt * CS%Kd_BBL_tr) !$OMP parallel do default(shared) private(htot,in_boundary,add_ent) do j=js,je @@ -1025,8 +1164,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! in the calculation of the fluxes in the first place. Kd_min_tr ! should be much less than the values that have been set in Kd_int, ! perhaps a molecular diffusivity. - add_ent = ((dt * CS%Kd_min_tr) * GV%Z_to_H**2) * & - ((h(i,j,k-1)+h(i,j,k)+h_neglect) / (h(i,j,k-1)*h(i,j,k)+h_neglect2)) - & + add_ent = ((dt * CS%Kd_min_tr)) * & + ((dz(i,j,k-1)+dz(i,j,k)+dz_neglect) / (dz(i,j,k-1)*dz(i,j,k)+dz_neglect2)) - & 0.5*(ent_s(i,j,K) + ent_s(i,j,K)) if (htot(i) < Tr_ea_BBL) then add_ent = max(0.0, add_ent, (Tr_ea_BBL - htot(i)) - ent_s(i,j,K)) @@ -1038,8 +1177,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim endif if (CS%double_diffuse) then ; if (Kd_extra_S(i,j,k) > 0.0) then - add_ent = ((dt * Kd_extra_S(i,j,k)) * GV%Z_to_H**2) / & - (0.5 * (h(i,j,k-1) + h(i,j,k)) + h_neglect) + add_ent = (dt * Kd_extra_S(i,j,k)) / & + (0.5 * (dz(i,j,k-1) + dz(i,j,k)) + dz_neglect) ent_s(i,j,K) = ent_s(i,j,K) + add_ent endif ; endif enddo ; enddo @@ -1049,8 +1188,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim !$OMP parallel do default(shared) private(add_ent) do k=nz,2,-1 ; do j=js,je ; do i=is,ie if (Kd_extra_S(i,j,k) > 0.0) then - add_ent = ((dt * Kd_extra_S(i,j,k)) * GV%Z_to_H**2) / & - (0.5 * (h(i,j,k-1) + h(i,j,k)) + h_neglect) + add_ent = (dt * Kd_extra_S(i,j,k)) / & + (0.5 * (dz(i,j,k-1) + dz(i,j,k)) + dz_neglect) else add_ent = 0.0 endif @@ -1059,17 +1198,19 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim endif ! (CS%mix_boundary_tracers) ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied - call call_tracer_column_fns(h_orig, h, ent_s(:,:,1:nz), ent_s(:,:,2:nz+1), fluxes, Hml, dt, & + call call_tracer_column_fns(h_orig, h, ent_s(:,:,1:nz), ent_s(:,:,2:nz+1), fluxes, BLD, dt, & G, GV, US, tv, CS%optics, CS%tracer_flow_CSp, CS%debug, & - evap_CFL_limit = CS%evap_CFL_limit, & - minimum_forcing_depth=CS%minimum_forcing_depth) + KPP_CSp=CS%KPP_CSp, & + nonLocalTrans=KPP_NLTscalar, & + evap_CFL_limit=CS%evap_CFL_limit, & + minimum_forcing_depth=CS%minimum_forcing_depth, h_BL=visc%h_ML) call cpu_clock_end(id_clock_tracers) ! Apply ALE sponge if (CS%use_sponge .and. associated(CS%ALE_sponge_CSp)) then call cpu_clock_begin(id_clock_sponge) - call apply_ALE_sponge(h, dt, G, GV, US, CS%ALE_sponge_CSp, CS%Time) + call apply_ALE_sponge(h, tv, dt, G, GV, US, CS%ALE_sponge_CSp, CS%Time) call cpu_clock_end(id_clock_sponge) if (CS%debug) then call MOM_state_chksum("apply_sponge ", u, v, h, G, GV, US, haloshift=0) @@ -1100,7 +1241,7 @@ end subroutine diabatic_ALE_legacy !> This subroutine imposes the diapycnal mass fluxes and the !! accompanying diapycnal advection of momentum and tracers. -subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & +subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, stoch_CS, Waves) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -1110,7 +1251,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs - real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: BLD !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields !! unused fields have NULL ptrs type(vertvisc_type), intent(inout) :: visc !< Structure with vertical viscosities, @@ -1128,13 +1269,14 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & h_orig, & ! Initial layer thicknesses [H ~> m or kg m-2] - dSV_dT, & ! The partial derivative of specific volume with temperature [R-1 degC-1 ~> m3 kg-1 degC-1] - dSV_dS, & ! The partial derivative of specific volume with salinity [R-1 ppt-1 ~> m3 kg-1 ppt-1]. + dz, & ! The vertical distance between interfaces around a layer [Z ~> m] + dSV_dT, & ! The partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSV_dS, & ! The partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. cTKE, & ! convective TKE requirements for each layer [R Z3 T-2 ~> J m-2]. u_h, & ! Zonal velocities interpolated to thickness points [L T-1 ~> m s-1] v_h, & ! Meridional velocities interpolated to thickness points [L T-1 ~> m s-1] - temp_diag, & ! Diagnostic array of previous temperatures [degC] - saln_diag ! Diagnostic array of previous salinity [ppt] + temp_diag, & ! Diagnostic array of previous temperatures [C ~> degC] + saln_diag ! Diagnostic array of previous salinity [S ~> ppt] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & ent_s, & ! The diffusive coupling across interfaces within one time step for @@ -1142,44 +1284,76 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ent_t, & ! The diffusive coupling across interfaces within one time step for ! temperature [H ~> m or kg m-2] Kd_heat, & ! diapycnal diffusivity of heat or the smaller of the diapycnal diffusivities of - ! heat and salt [Z2 T-1 ~> m2 s-1] - Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [Z2 T-1 ~> m2 s-1] + ! heat and salt [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_extra_T , & ! The extra diffusivity of temperature due to double diffusion relative to - ! Kd_int returned from set_diffusivity [Z2 T-1 ~> m2 s-1]. + ! Kd_int returned from set_diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_extra_S , & ! The extra diffusivity of salinity due to double diffusion relative to - ! Kd_int returned from set_diffusivity [Z2 T-1 ~> m2 s-1]. - Kd_ePBL, & ! boundary layer or convective diapycnal diffusivities at interfaces [Z2 T-1 ~> m2 s-1] - Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] - Sdif_flx ! diffusive diapycnal salt flux across interfaces [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + ! Kd_int returned from set_diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_ePBL, & ! boundary layer or convective diapycnal diffusivities at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + KPP_NLTheat, & ! KPP non-local transport for heat [nondim] + KPP_NLTscalar, & ! KPP non-local transport for scalars [nondim] + KPP_buoy_flux, & ! KPP forcing buoyancy flux [L2 T-3 ~> m2 s-3] + Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + N2_salt, & !< Salinity contribution to squared buoyancy frequency at interfaces [T-2 ~> s-2] + N2_temp !< Temperature contribution to squared buoyancy frequency at interfaces [T-2 ~> s-2] real, dimension(SZI_(G),SZJ_(G)) :: & - SkinBuoyFlux ! 2d surface buoyancy flux [Z2 T-3 ~> m2 s-3], used by ePBL + U_star, & ! The friction velocity [Z T-1 ~> m s-1]. + KPP_temp_flux, & ! KPP effective temperature flux [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + KPP_salt_flux, & ! KPP effective salt flux [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + SkinBuoyFlux, & ! 2d surface buoyancy flux [Z2 T-3 ~> m2 s-3], used by ePBL + BBL_BuoyFlux ! 2d bottom buoyancy flux [Z2 T-3 ~> m2 s-3], used by ePBL logical, dimension(SZI_(G)) :: & in_boundary ! True if there are no massive layers below, where massive is defined as ! sufficiently thick that the no-flux boundary conditions have not restricted ! the entrainment - usually sqrt(Kd*dt). + real, dimension(SZI_(G)) :: & + p_i ,& ! Pressure at the interface [R L2 T-2 ~> Pa] + T_i, & ! Temperature at the interface [C ~> degC] + S_i, & ! Salinity at the interface [S ~> ppt] + drhodS, & ! Local change in density w.r.t. salinity using model EOS & state [R C-1 ~> kg m-3 ppt-1] + drhodT, & ! Local change in density w.r.t. temperature using model EOS & state [R C-1 ~> kg m-3 degC-1] + dSpV_dT, & ! Partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSpV_dS ! Partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1] + real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2] - real :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4] + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m] + real :: dz_neglect2 ! dz_neglect^2 [Z2 ~> m2] real :: add_ent ! Entrainment that needs to be added when mixing tracers [H ~> m or kg m-2] - real :: I_hval ! The inverse of the thicknesses averaged to interfaces [H-1 ~> m-1 or m2 kg-1] - real :: h_tr ! h_tr is h at tracer points with a tiny thickness - ! added to ensure positive definiteness [H ~> m or kg m-2] + real :: I_dzval ! The inverse of the thicknesses averaged to interfaces [Z-1 ~> m-1] + real :: I_h ! The inverse of the thicknesses averaged to interfaces [H-1 ~> m-1 or m2 kg-1] real :: Tr_ea_BBL ! The diffusive tracer thickness in the BBL that is ! coupled to the bottom within a timestep [H ~> m or kg m-2] real :: htot(SZIB_(G)) ! The summed thickness from the bottom [H ~> m or kg m-2]. - real :: Kd_add_here ! An added diffusivity [Z2 T-1 ~> m2 s-1]. - real :: Idt ! The inverse time step [T-1 ~> s-1] + real :: Kd_add_here ! An added diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real :: Idt ! The inverse time step [T-1 ~> s-1] + real :: g_Rho0 ! G_Earth/Rho0 [H T-2 R-1 ~> m4 s-2 kg-1 or m s-2] + real :: H_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] + real :: alt_H_to_pres! A conversion factor from thicknesses to pressure w/ alternative scaling [R Z T-2 ~> Pa m-1] + logical :: nonBous ! True if not using the Boussinesq approximation + + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state - integer :: dir_flag ! An integer encoding the directions in which to do halo updates. logical :: showCallTree ! If true, show the call tree - integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, m + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, Isq, Ieq, Jsq, Jeq, nz 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 Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect*h_neglect + dz_neglect = GV%dZ_subroundoff ; dz_neglect2 = dz_neglect*dz_neglect + h_neglect = GV%H_subroundoff + + nonBous = .not.(GV%Boussinesq .or. GV%semi_Boussinesq) + g_Rho0 = GV%g_Earth_Z_T2 / GV%H_to_RZ + H_to_pres = GV%H_to_RZ * GV%g_Earth + alt_H_to_pres = H_to_pres * US%L_to_Z**2 * GV%Z_to_H + Kd_heat(:,:,:) = 0.0 ; Kd_salt(:,:,:) = 0.0 ent_s(:,:,:) = 0.0 ; ent_t(:,:,:) = 0.0 @@ -1192,9 +1366,11 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! For all other diabatic subroutines, the averaging window should be the entire diabatic timestep call enable_averages(dt, Time_end, CS%diag) + if (CS%Use_KdWork_diag) call Allocate_VBF_CS(G, GV, CS%VBF) + if (CS%use_geothermal) then call cpu_clock_begin(id_clock_geothermal) - call geothermal_in_place(h, tv, dt, G, GV, US, CS%geothermal, halo=CS%halo_TS_diff) + call geothermal_in_place(h, tv, dt, G, GV, US, CS%geothermal, BBL_buoyflux, halo=CS%halo_TS_diff) call cpu_clock_end(id_clock_geothermal) if (showCallTree) call callTree_waypoint("geothermal (diabatic)") if (CS%debugConservation) call MOM_state_stats('geothermal', u, v, h, tv%T, tv%S, G, GV, US) @@ -1228,10 +1404,10 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call MOM_state_chksum("before set_diffusivity", u, v, h, G, GV, US, haloshift=CS%halo_TS_diff) if (CS%double_diffuse) then call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, visc, dt, Kd_heat, G, GV, US, & - CS%set_diff_CSp, Kd_extra_T=Kd_extra_T, Kd_extra_S=Kd_extra_S) + CS%set_diff_CSp, CS%VBF, Kd_extra_T=Kd_extra_T, Kd_extra_S=Kd_extra_S) else call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, visc, dt, Kd_heat, G, GV, US, & - CS%set_diff_CSp) + CS%set_diff_CSp, CS%VBF) endif call cpu_clock_end(id_clock_set_diffusivity) if (showCallTree) call callTree_waypoint("done with set_diffusivity (diabatic)") @@ -1240,12 +1416,9 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call MOM_state_chksum("after set_diffusivity ", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after set_diffusivity ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after set_diffusivity ", tv, G, US) - call hchksum(Kd_heat, "after set_diffusivity Kd_heat", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_heat, "after set_diffusivity Kd_heat", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif - ! Store the diagnosed typical diffusivity at interfaces. - if (CS%id_Kd_int > 0) call post_data(CS%id_Kd_int, Kd_heat, CS%diag) - ! Set diffusivities for heat and salt separately, and possibly change the meaning of Kd_heat. if (CS%double_diffuse) then ! Add contributions from double diffusion @@ -1262,8 +1435,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, endif if (CS%debug) then - call hchksum(Kd_heat, "after double diffuse Kd_heat", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kd_salt, "after double diffuse Kd_salt", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_heat, "after double diffuse Kd_heat", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Kd_salt, "after double diffuse Kd_salt", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif if (CS%useKPP) then @@ -1273,54 +1446,66 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, visc%Kv_shear(i,j,k) = visc%Kv_shear(i,j,k) + visc%Kv_slow(i,j,k) enddo ; enddo ; enddo + ! NOTE: The following do not require initialization, but their checksums do + ! require initialization, and past versions were initialized to zero. + KPP_NLTheat(:,:,:) = 0. + KPP_NLTscalar(:,:,:) = 0. + KPP_buoy_flux(:,:,:) = 0. + KPP_temp_flux(:,:) = 0. + KPP_salt_flux(:,:) = 0. + ! KPP needs the surface buoyancy flux but does not update state variables. ! We could make this call higher up to avoid a repeat unpacking of the surface fluxes. - ! Sets: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux - ! NOTE: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux are returned as rates (i.e. stuff per second) + ! Sets: KPP_buoy_flux, KPP_temp_flux, KPP_salt_flux + ! NOTE: KPP_buoy_flux, KPP_temp_flux, KPP_salt_flux are returned as rates (i.e. stuff per second) ! unlike other instances where the fluxes are integrated in time over a time-step. call calculateBuoyancyFlux2d(G, GV, US, fluxes, CS%optics, h, tv%T, tv%S, tv, & - CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux) + KPP_buoy_flux, KPP_temp_flux, KPP_salt_flux) + + ! Determine the friction velocity, perhaps using the evovling surface density. + call find_ustar(fluxes, tv, U_star, G, GV, US) ! The KPP scheme calculates boundary layer diffusivities and non-local transport. if ( associated(fluxes%lamult) ) then call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & - fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) + U_star, KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & - Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, KPP_buoy_flux, Kd_heat, & + Kd_salt, visc%Kv_shear, KPP_NLTheat, KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) else call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & - fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) + U_star, KPP_buoy_flux, Waves=Waves) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & - Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, KPP_buoy_flux, Kd_heat, & + Kd_salt, visc%Kv_shear, KPP_NLTheat, KPP_NLTscalar, Waves=Waves) endif - if (associated(Hml)) then - call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G, US) - call pass_var(Hml, G%domain, halo=1) - ! If visc%MLD exists, copy KPP's BLD into it - if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) - endif + call KPP_get_BLD(CS%KPP_CSp, BLD(:,:), G, US) + ! If visc%MLD or visc%h_ML exist, copy KPP's BLD into them with appropriate conversions. + if (associated(visc%h_ML)) call convert_MLD_to_ML_thickness(BLD, h, visc%h_ML, tv, G, GV) + if (associated(visc%MLD)) visc%MLD(:,:) = BLD(:,:) + if (associated(visc%sfc_buoy_flx)) visc%sfc_buoy_flx(:,:) = KPP_buoy_flux(:,:,1) if (showCallTree) call callTree_waypoint("done with KPP_calculate (diabatic)") if (CS%debug) then call MOM_state_chksum("after KPP", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after KPP", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after KPP", tv, G, US) - call hchksum(Kd_heat, "after KPP Kd_heat", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kd_salt, "after KPP Kd_salt", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(CS%KPP_temp_flux, "before KPP_applyNLT netHeat", G%HI, haloshift=0, scale=GV%H_to_m*US%s_to_T) - call hchksum(CS%KPP_salt_flux, "before KPP_applyNLT netSalt", G%HI, haloshift=0, scale=GV%H_to_m*US%s_to_T) - call hchksum(CS%KPP_NLTheat, "before KPP_applyNLT NLTheat", G%HI, haloshift=0) - call hchksum(CS%KPP_NLTscalar, "before KPP_applyNLT NLTscalar", G%HI, haloshift=0) + call hchksum(Kd_heat, "after KPP Kd_heat", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Kd_salt, "after KPP Kd_salt", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(KPP_temp_flux, "before KPP_applyNLT netHeat", G%HI, haloshift=0, & + unscale=US%C_to_degC*GV%H_to_m*US%s_to_T) + call hchksum(KPP_salt_flux, "before KPP_applyNLT netSalt", G%HI, haloshift=0, & + unscale=US%S_to_ppt*GV%H_to_m*US%s_to_T) + call hchksum(KPP_NLTheat, "before KPP_applyNLT NLTheat", G%HI, haloshift=0) + call hchksum(KPP_NLTscalar, "before KPP_applyNLT NLTscalar", G%HI, haloshift=0) endif ! Apply non-local transport of heat and salt ! Changes: tv%T, tv%S - call KPP_NonLocalTransport_temp(CS%KPP_CSp, G, GV, h, CS%KPP_NLTheat, CS%KPP_temp_flux, & - dt, tv%T, tv%C_p) - call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, CS%KPP_NLTscalar, CS%KPP_salt_flux, & - dt, tv%S) + call KPP_NonLocalTransport_temp(CS%KPP_CSp, G, GV, h, KPP_NLTheat, KPP_temp_flux, & + dt, tv%tr_T, tv%T, tv%C_p) + call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, KPP_NLTscalar, KPP_salt_flux, & + dt, tv%tr_S, tv%S) call cpu_clock_end(id_clock_kpp) if (showCallTree) call callTree_waypoint("done with KPP_applyNonLocalTransport (diabatic)") if (CS%debugConservation) call MOM_state_stats('KPP_applyNonLocalTransport', u, v, h, tv%T, tv%S, G, GV, US) @@ -1335,11 +1520,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! Calculate vertical mixing due to convection (computed via CVMix) if (CS%use_CVMix_conv) then ! Increment vertical diffusion and viscosity due to convection - if (CS%useKPP) then - call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv, Hml, Kd_heat, visc%Kv_shear, Kd_aux=Kd_salt) - else - call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv, Hml, Kd_heat, visc%Kv_slow, Kd_aux=Kd_salt) - endif + call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv, BLD, Kd_heat, visc%Kv_shear, Kd_aux=Kd_salt) endif ! Save fields before boundary forcing is applied for tendency diagnostics @@ -1362,30 +1543,28 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, skinbuoyflux(:,:) = 0.0 call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, CS%evap_CFL_limit, & - CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux) + CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux, MLD_h=visc%h_ML) if (CS%debug) then - call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, scale=GV%H_to_m) - call hchksum(ent_s, "after applyBoundaryFluxes ent_s", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(ent_s, "after applyBoundaryFluxes ent_s", G%HI, haloshift=0, unscale=GV%H_to_MKS) call hchksum(cTKE, "after applyBoundaryFluxes cTKE", G%HI, haloshift=0, & - scale=US%RZ3_T3_to_W_m2*US%T_to_s) - call hchksum(dSV_dT, "after applyBoundaryFluxes dSV_dT", G%HI, haloshift=0, scale=US%kg_m3_to_R) - call hchksum(dSV_dS, "after applyBoundaryFluxes dSV_dS", G%HI, haloshift=0, scale=US%kg_m3_to_R) + unscale=US%RZ3_T3_to_W_m2*US%T_to_s) + call hchksum(dSV_dT, "after applyBoundaryFluxes dSV_dT", G%HI, haloshift=0, & + unscale=US%kg_m3_to_R*US%degC_to_C) + call hchksum(dSV_dS, "after applyBoundaryFluxes dSV_dS", G%HI, haloshift=0, & + unscale=US%kg_m3_to_R*US%ppt_to_S) endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) - call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & - CS%energetic_PBL, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) + call energetic_PBL(h, u_h, v_h, tv, fluxes, visc, dt, Kd_ePBL, G, GV, US, & + CS%ePBL, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, BBL_BuoyFlux, waves=waves) - if (associated(Hml)) then - call energetic_PBL_get_MLD(CS%energetic_PBL, Hml(:,:), G, US) - call pass_var(Hml, G%domain, halo=1) - ! If visc%MLD exists, copy ePBL's MLD into it - if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) - elseif (associated(visc%MLD)) then - call energetic_PBL_get_MLD(CS%energetic_PBL, visc%MLD, G, US) - call pass_var(visc%MLD, G%domain, halo=1) - endif + call energetic_PBL_get_MLD(CS%ePBL, BLD(:,:), G, US) + ! If visc%MLD or visc%h_ML exist, copy ePBL's BLD into them with appropriate conversions. + if (associated(visc%h_ML)) call convert_MLD_to_ML_thickness(BLD, h, visc%h_ML, tv, G, GV) + if (associated(visc%MLD)) visc%MLD(:,:) = BLD(:,:) + if (associated(visc%sfc_buoy_flx)) visc%sfc_buoy_flx(:,:) = SkinBuoyFlux(:,:) ! Augment the diffusivities and viscosity due to those diagnosed in energetic_PBL. do K=2,nz ; do j=js,je ; do i=is,ie @@ -1402,15 +1581,15 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, enddo ; enddo ; enddo if (CS%debug) then - call hchksum(ent_t, "after ePBL ent_t", G%HI, haloshift=0, scale=GV%H_to_m) - call hchksum(ent_s, "after ePBL ent_s", G%HI, haloshift=0, scale=GV%H_to_m) - call hchksum(Kd_ePBL, "after ePBL Kd_ePBL", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(ent_t, "after ePBL ent_t", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(ent_s, "after ePBL ent_s", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(Kd_ePBL, "after ePBL Kd_ePBL", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif else call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, & - CS%evap_CFL_limit, CS%minimum_forcing_depth) + CS%evap_CFL_limit, CS%minimum_forcing_depth, MLD_h=visc%h_ML) endif ! endif for CS%use_energetic_PBL @@ -1439,8 +1618,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, if (associated(tv%T)) then if (CS%debug) then - call hchksum(ent_t, "before triDiagTS ent_t ", G%HI, haloshift=0, scale=GV%H_to_m) - call hchksum(ent_s, "before triDiagTS ent_s ", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(ent_t, "before triDiagTS ent_t ", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(ent_s, "before triDiagTS ent_s ", G%HI, haloshift=0, unscale=GV%H_to_MKS) endif call cpu_clock_begin(id_clock_tridiag) @@ -1460,17 +1639,20 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, enddo ; enddo ; enddo endif + ! Find the vertical distances across layers, which may have been modified by the net surface flux + call thickness_to_dz(h, tv, dz, G, GV, US) + ! set ent_t=dt*Kd_heat/h_int and est_s=dt*Kd_salt/h_int on interfaces for use in the tridiagonal solver. do j=js,je ; do i=is,ie ent_t(i,j,1) = 0. ; ent_t(i,j,nz+1) = 0. ent_s(i,j,1) = 0. ; ent_s(i,j,nz+1) = 0. enddo ; enddo - !$OMP parallel do default(shared) private(I_hval) + !$OMP parallel do default(shared) private(I_dzval) do K=2,nz ; do j=js,je ; do i=is,ie - I_hval = 1.0 / (h_neglect + 0.5*(h(i,j,k-1) + h(i,j,k))) - ent_t(i,j,K) = (GV%Z_to_H**2) * dt * I_hval * Kd_heat(i,j,k) - ent_s(i,j,K) = (GV%Z_to_H**2) * dt * I_hval * Kd_salt(i,j,k) + I_dzval = 1.0 / (dz_neglect + 0.5*(dz(i,j,k-1) + dz(i,j,k))) + ent_t(i,j,K) = dt * I_dzval * Kd_heat(i,j,k) + ent_s(i,j,K) = dt * I_dzval * Kd_salt(i,j,k) enddo ; enddo ; enddo if (showCallTree) call callTree_waypoint("done setting ent_t and ent_t from Kd_heat and " //& "Kd_salt (diabatic_ALE)") @@ -1500,15 +1682,29 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! target grids for vertical remapping may need to be regenerated. call diag_update_remap_grids(CS%diag) + ! Set diffusivities for VBF diagnostics if enabled + if (CS%use_energetic_PBL .and. associated(CS%VBF%Kd_ePBL)) CS%VBF%Kd_ePBL(:,:,:) = Kd_ePBL(:,:,:) + if (associated(CS%VBF%Kd_salt)) CS%VBF%Kd_temp(:,:,:) = Kd_heat(:,:,:) + if (associated(CS%VBF%Kd_temp)) CS%VBF%Kd_salt(:,:,:) = Kd_salt(:,:,:) + ! Diagnose the diapycnal diffusivities and other related quantities. - if (CS%id_Kd_heat > 0) call post_data(CS%id_Kd_heat, Kd_heat, CS%diag) - if (CS%id_Kd_salt > 0) call post_data(CS%id_Kd_salt, Kd_salt, CS%diag) - if (CS%id_Kd_ePBL > 0) call post_data(CS%id_Kd_ePBL, Kd_ePBL, CS%diag) + if (CS%id_Kd_heat > 0) call post_data(CS%id_Kd_heat, Kd_heat, CS%diag) + if (CS%id_Kd_salt > 0) call post_data(CS%id_Kd_salt, Kd_salt, CS%diag) + if (CS%id_Kd_ePBL > 0) call post_data(CS%id_Kd_ePBL, Kd_ePBL, CS%diag) + if (CS%id_Kd_int > 0) then + if (CS%double_diffuse .or. CS%useKPP) then + ! Using this as a work array might cause confusion. + do K=1,nz ; do j=js,je ; do i=is,ie + Kd_heat(i,j,k) = min(Kd_heat(i,j,k), Kd_salt(i,j,k)) + enddo ; enddo ; enddo + endif + call post_data(CS%id_Kd_int, Kd_heat, CS%diag) + endif - if (CS%id_ea_t > 0) call post_data(CS%id_ea_t, ent_t(:,:,1:nz), CS%diag) - if (CS%id_eb_t > 0) call post_data(CS%id_eb_t, ent_t(:,:,2:nz+1), CS%diag) - if (CS%id_ea_s > 0) call post_data(CS%id_ea_s, ent_s(:,:,1:nz), CS%diag) - if (CS%id_eb_s > 0) call post_data(CS%id_eb_s, ent_s(:,:,2:nz+1), CS%diag) + if (CS%id_ea_t > 0) call post_data(CS%id_ea_t, ent_t(:,:,1:nz), CS%diag) + if (CS%id_eb_t > 0) call post_data(CS%id_eb_t, ent_t(:,:,2:nz+1), CS%diag) + if (CS%id_ea_s > 0) call post_data(CS%id_ea_s, ent_s(:,:,1:nz), CS%diag) + if (CS%id_eb_s > 0) call post_data(CS%id_eb_s, ent_s(:,:,2:nz+1), CS%diag) Idt = 1.0 / dt if (CS%id_Tdif > 0) then @@ -1532,11 +1728,73 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, if (CS%id_Sdif > 0) call post_data(CS%id_Sdif, Sdif_flx, CS%diag) endif + if (CS%Use_KdWork_diag .or. CS%Use_N2_diag) then + N2_salt(:,:,:) = 0.0 + N2_temp(:,:,:) = 0.0 + !Compute N2 and don't mask negatives here + EOSdom(:) = EOS_domain(G%HI) + if (nonBous) then + !$OMP parallel do default(shared) + do j=js,je + if (associated(tv%p_surf)) then + do i=is,ie ; p_i(i) = tv%p_surf(i,j) ; enddo + else + do i=is,ie ; p_i(i) = 0.0 ; enddo + endif + do K=2,nz + do i=is,ie + p_i(i) = p_i(i) + H_to_pres * h(i,j,k-1) + enddo + T_i = 0.5*(tv%T(:,j,k-1)+tv%T(:,j,k)) + S_i = 0.5*(tv%S(:,j,k-1)+tv%S(:,j,k)) + call calculate_specific_vol_derivs(T_i, S_i, p_i, dSpV_dT, dSpV_dS, tv%eqn_of_state, EOSdom) + do i=is,ie + I_dzval = 1.0 / (dz_neglect + 0.5*(dz(i,j,k-1) + dz(i,j,k))) + N2_salt(i,j,K) = (tv%S(i,j,k-1) - tv%S(i,j,k)) * (dSpv_dS(i) * (alt_H_to_pres * I_dzval)) + N2_temp(i,j,K) = (tv%T(i,j,k-1) - tv%T(i,j,k)) * (dSpV_dT(i) * (alt_H_to_pres * I_dzval)) + enddo + enddo + enddo + else + !$OMP parallel do default(shared) + do j=js,je + if (associated(tv%p_surf)) then + do i=is,ie ; p_i(i) = tv%p_surf(i,j) ; enddo + else + do i=is,ie ; p_i(i) = 0.0 ; enddo + endif + do K=2,nz + do i=is,ie + p_i(i) = p_i(i) + H_to_pres* h(i,j,k-1) + enddo + T_i = 0.5*(tv%T(:,j,k-1)+tv%T(:,j,k)) + S_i = 0.5*(tv%S(:,j,k-1)+tv%S(:,j,k)) + call calculate_density_derivs(T_i, S_i, p_i, dRhodT, dRhodS, tv%eqn_of_state, EOSdom) + do i=is,ie + I_h = 1.0 / (h_neglect + 0.5*(h(i,j,k-1) + h(i,j,k))) + N2_salt(i,j,K) = -(tv%S(i,j,k-1) - tv%S(i,j,k)) * (dRhodS(i) * (g_rho0 * I_h)) + N2_temp(i,j,K) = -(tv%T(i,j,k-1) - tv%T(i,j,k)) * (dRhodT(i) * (g_rho0 * I_h)) + enddo + enddo + enddo + endif + if (CS%id_N2_dd>0) call post_data(CS%id_N2_dd, N2_salt(:,:,:)+N2_temp(:,:,:), CS%diag) + if (CS%id_N2_salt_dd>0) call post_data(CS%id_N2_salt_dd, N2_salt, CS%diag) + if (CS%id_N2_temp_dd>0) call post_data(CS%id_N2_temp_dd, N2_temp, CS%diag) + + if (CS%Use_KdWork_diag) then + call KdWork_diagnostics(G,GV,US,CS%diag,CS%VBF,N2_salt,N2_temp,dz) + endif + + call deallocate_VBF_CS(CS%VBF) + + endif + ! mixing of passive tracers from massless boundary layers to interior call cpu_clock_begin(id_clock_tracers) if (CS%mix_boundary_tracer_ALE) then - Tr_ea_BBL = GV%Z_to_H * sqrt(dt*CS%Kd_BBL_tr) + Tr_ea_BBL = sqrt(dt * CS%Kd_BBL_tr) !$OMP parallel do default(shared) private(htot,in_boundary,add_ent) do j=js,je do i=is,ie @@ -1550,8 +1808,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! bottom, add some mixing of tracers between these layers. This flux is based on the ! harmonic mean of the two thicknesses, following what is done in layered mode. Kd_min_tr ! should be much less than the values in Kd_salt, perhaps a molecular diffusivity. - add_ent = ((dt * CS%Kd_min_tr) * GV%Z_to_H**2) * & - ((h(i,j,k-1)+h(i,j,k) + h_neglect) / (h(i,j,k-1)*h(i,j,k) + h_neglect2)) - & + add_ent = (dt * CS%Kd_min_tr) * & + ((dz(i,j,k-1)+dz(i,j,k) + dz_neglect) / (dz(i,j,k-1)*dz(i,j,k) + dz_neglect2)) - & ent_s(i,j,K) if (htot(i) < Tr_ea_BBL) then add_ent = max(0.0, add_ent, (Tr_ea_BBL - htot(i)) - ent_s(i,j,K)) @@ -1566,17 +1824,19 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, endif ! (CS%mix_boundary_tracer_ALE) ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied - call call_tracer_column_fns(h_orig, h, ent_s(:,:,1:nz), ent_s(:,:,2:nz+1), fluxes, Hml, dt, & + call call_tracer_column_fns(h_orig, h, ent_s(:,:,1:nz), ent_s(:,:,2:nz+1), fluxes, BLD, dt, & G, GV, US, tv, CS%optics, CS%tracer_flow_CSp, CS%debug, & + KPP_CSp=CS%KPP_CSp, & + nonLocalTrans=KPP_NLTscalar, & evap_CFL_limit=CS%evap_CFL_limit, & - minimum_forcing_depth=CS%minimum_forcing_depth) + minimum_forcing_depth=CS%minimum_forcing_depth, h_BL=visc%h_ML) call cpu_clock_end(id_clock_tracers) ! Apply ALE sponge if (CS%use_sponge .and. associated(CS%ALE_sponge_CSp)) then call cpu_clock_begin(id_clock_sponge) - call apply_ALE_sponge(h, dt, G, GV, US, CS%ALE_sponge_CSp, CS%Time) + call apply_ALE_sponge(h, tv, dt, G, GV, US, CS%ALE_sponge_CSp, CS%Time) call cpu_clock_end(id_clock_sponge) if (CS%debug) then call MOM_state_chksum("apply_sponge ", u, v, h, G, GV, US, haloshift=0) @@ -1611,7 +1871,7 @@ end subroutine diabatic_ALE !> Imposes the diapycnal mass fluxes and the accompanying diapycnal advection of momentum and tracers !! using the original MOM6 algorithms. -subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & +subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, Waves) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -1621,7 +1881,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs - real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: BLD !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields !! unused fields have NULL ptrs type(vertvisc_type), intent(inout) :: visc !< Structure with vertical viscosities, @@ -1640,41 +1900,46 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! one time step [H ~> m or kg m-2] eb, & ! amount of fluid entrained from the layer below within ! one time step [H ~> m or kg m-2] - Kd_lay, & ! diapycnal diffusivity of layers [Z2 T-1 ~> m2 s-1] + Kd_lay, & ! diapycnal diffusivity of layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] h_orig, & ! initial layer thicknesses [H ~> m or kg m-2] + dz, & ! The vertical distance between interfaces around a layer [Z ~> m] hold, & ! layer thickness before diapycnal entrainment, and later the initial ! layer thicknesses (if a mixed layer is used) [H ~> m or kg m-2] - dSV_dT, & ! The partial derivative of specific volume with temperature [R-1 degC-1 ~> m3 kg-1 degC-1] - dSV_dS, & ! The partial derivative of specific volume with salinity [R-1 ppt-1 ~> m3 kg-1 ppt-1]. + dz_old, & ! The initial vertical distance between interfaces around a layer + ! or the distance before entrainment [Z ~> m] u_h, & ! Zonal velocities at thickness points after entrainment [L T-1 ~> m s-1] v_h, & ! Meridional velocities at thickness points after entrainment [L T-1 ~> m s-1] - temp_diag, & ! Diagnostic array of previous temperatures [degC] - saln_diag ! Diagnostic array of previous salinity [ppt] + temp_diag, & ! Diagnostic array of previous temperatures [C ~> degC] + saln_diag ! Diagnostic array of previous salinity [S ~> ppt] real, dimension(SZI_(G),SZJ_(G)) :: & - Rcv_ml, & ! Coordinate density of mixed layer [R ~> kg m-3], used for applying sponges - SkinBuoyFlux ! 2d surface buoyancy flux [Z2 T-3 ~> m2 s-3], used by ePBL + h_MLD, & ! Active mixed layer thickness [H ~> m or kg m-2]. + U_star, & ! The friction velocity [Z T-1 ~> m s-1]. + KPP_temp_flux, & ! KPP effective temperature flux [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + KPP_salt_flux, & ! KPP effective salt flux [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + Rcv_ml ! Coordinate density of mixed layer [R ~> kg m-3], used for applying sponges real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: & ! These are targets so that the space can be shared with eaml & ebml. - eatr, & ! The equivalent of ea and eb for tracers, which differ from ea and - ebtr ! eb in that they tend to homogenize tracers in massless layers - ! near the boundaries [H ~> m or kg m-2] (for Bous or non-Bouss) + eatr, & ! The equivalent of ea for tracers, which differs from ea in that it tends to + ! homogenize tracers in massless layers near the boundaries [H ~> m or kg m-2] + ebtr ! The equivalent of eb for tracers, which differs from eb in that it tends to + ! homogenize tracers in massless layers near the boundaries [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & - Kd_int, & ! diapycnal diffusivity of interfaces [Z2 T-1 ~> m2 s-1] - Kd_heat, & ! diapycnal diffusivity of heat [Z2 T-1 ~> m2 s-1] - Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [Z2 T-1 ~> m2 s-1] + Kd_int, & ! diapycnal diffusivity of interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_heat, & ! diapycnal diffusivity of heat [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_extra_T , & ! The extra diffusivity of temperature due to double diffusion relative to - ! Kd_int [Z2 T-1 ~> m2 s-1]. + ! Kd_int [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_extra_S , & ! The extra diffusivity of salinity due to double diffusion relative to - ! Kd_int [Z2 T-1 ~> m2 s-1]. - Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] - Tadv_flx, & ! advective diapycnal heat flux across interfaces [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] - Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] - Sadv_flx ! advective diapycnal salt flux across interfaces [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] - - real, allocatable, dimension(:,:) :: & - hf_dudt_dia_2d, hf_dvdt_dia_2d ! Depth sum of diapycnal mixing accelaration * fract. thickness [L T-2 ~> m s-2]. + ! Kd_int [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + KPP_NLTheat, & ! KPP non-local transport for heat [nondim] + KPP_NLTscalar, & ! KPP non-local transport for scalars [nondim] + KPP_buoy_flux, & ! KPP forcing buoyancy flux [L2 T-3 ~> m2 s-3] + Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + Tadv_flx, & ! advective diapycnal heat flux across interfaces [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + Sadv_flx ! advective diapycnal salt flux across interfaces [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] ! The following 3 variables are only used with a bulk mixed layer. real, pointer, dimension(:,:,:) :: & @@ -1696,7 +1961,9 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2] - real :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4] + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m] + real :: dz_neglect2 ! dz_neglect^2 [Z2 ~> m2] real :: net_ent ! The net of ea-eb at an interface [H ~> m or kg m-2] real :: add_ent ! Entrainment that needs to be added when mixing tracers [H ~> m or kg m-2] real :: eaval ! eaval is 2*ea at velocity grid points [H ~> m or kg m-2] @@ -1718,15 +1985,15 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e integer :: dir_flag ! An integer encoding the directions in which to do halo updates. logical :: showCallTree ! If true, show the call tree integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state - integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb, m, halo + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb, halo is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB nkmb = GV%nk_rho_varies - h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect*h_neglect + h_neglect = GV%H_subroundoff + dz_neglect = GV%dZ_subroundoff ; dz_neglect2 = dz_neglect*dz_neglect Kd_heat(:,:,:) = 0.0 ; Kd_salt(:,:,:) = 0.0 - showCallTree = callTree_showQuery() if (showCallTree) call callTree_enter("layered_diabatic(), MOM_diabatic_driver.F90") @@ -1780,11 +2047,14 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! Changes: h, tv%T, tv%S, eaml and ebml (G is also inout???) call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt*CS%ML_mix_first, & eaml, ebml, G, GV, US, CS%bulkmixedlayer, CS%optics, & - Hml, CS%aggregate_FW_forcing, dt, last_call=.false.) + BLD, h_MLD, CS%aggregate_FW_forcing, dt, last_call=.false.) + else ! Changes: h, tv%T, tv%S, eaml and ebml (G is also inout???) call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt, eaml, ebml, & G, GV, US, CS%bulkmixedlayer, CS%optics, & - Hml, CS%aggregate_FW_forcing, dt, last_call=.true.) + BLD, h_MLD, CS%aggregate_FW_forcing, dt, last_call=.true.) + if (associated(visc%h_ML)) visc%h_ML(:,:) = h_MLD(:,:) + if (associated(visc%MLD)) visc%MLD(:,:) = BLD(:,:) endif ! Keep salinity from falling below a small but positive threshold. @@ -1811,8 +2081,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e if ((CS%ML_mix_first > 0.0) .or. CS%use_geothermal) then call find_uv_at_h(u, v, h_orig, u_h, v_h, G, GV, US, eaml, ebml) if (CS%debug) then - call hchksum(eaml, "after find_uv_at_h eaml", G%HI, scale=GV%H_to_m) - call hchksum(ebml, "after find_uv_at_h ebml", G%HI, scale=GV%H_to_m) + call hchksum(eaml, "after find_uv_at_h eaml", G%HI, unscale=GV%H_to_MKS) + call hchksum(ebml, "after find_uv_at_h ebml", G%HI, unscale=GV%H_to_MKS) endif else call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) @@ -1825,17 +2095,23 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! Also changes: visc%Kd_shear and visc%Kv_shear if ((CS%halo_TS_diff > 0) .and. (CS%ML_mix_first > 0.0)) then if (associated(tv%T)) call pass_var(tv%T, G%Domain, halo=CS%halo_TS_diff, complete=.false.) - if (associated(tv%T)) call pass_var(tv%S, G%Domain, halo=CS%halo_TS_diff, complete=.false.) + if (associated(tv%S)) call pass_var(tv%S, G%Domain, halo=CS%halo_TS_diff, complete=.false.) call pass_var(h, G%domain, halo=CS%halo_TS_diff, complete=.true.) endif + + ! Update derived thermodynamic quantities. + if ((CS%ML_mix_first > 0.0) .and. allocated(tv%SpV_avg)) then + call calc_derived_thermo(tv, h, G, GV, US, halo=CS%halo_TS_diff) + endif + if (CS%debug) & call MOM_state_chksum("before set_diffusivity", u, v, h, G, GV, US, haloshift=CS%halo_TS_diff) if (CS%double_diffuse) then call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, visc, dt, Kd_int, G, GV, US, & - CS%set_diff_CSp, Kd_lay=Kd_lay, Kd_extra_T=Kd_extra_T, Kd_extra_S=Kd_extra_S) + CS%set_diff_CSp, CS%VBF, Kd_lay=Kd_lay, Kd_extra_T=Kd_extra_T, Kd_extra_S=Kd_extra_S) else call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, visc, dt, Kd_int, G, GV, US, & - CS%set_diff_CSp, Kd_lay=Kd_lay) + CS%set_diff_CSp, CS%VBF, Kd_lay=Kd_lay) endif call cpu_clock_end(id_clock_set_diffusivity) if (showCallTree) call callTree_waypoint("done with set_diffusivity (diabatic)") @@ -1844,20 +2120,29 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call MOM_state_chksum("after set_diffusivity ", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after set_diffusivity ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after set_diffusivity ", tv, G, US) - call hchksum(Kd_lay, "after set_diffusivity Kd_lay", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kd_Int, "after set_diffusivity Kd_Int", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_lay, "after set_diffusivity Kd_lay", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Kd_Int, "after set_diffusivity Kd_Int", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif if (CS%useKPP) then call cpu_clock_begin(id_clock_kpp) + + ! NOTE: The following do not require initialization, but their checksums do + ! require initialization, and past versions were initialized to zero. + KPP_NLTheat(:,:,:) = 0. + KPP_NLTscalar(:,:,:) = 0. + KPP_buoy_flux(:,:,:) = 0. + KPP_temp_flux(:,:) = 0. + KPP_salt_flux(:,:) = 0. + ! KPP needs the surface buoyancy flux but does not update state variables. ! We could make this call higher up to avoid a repeat unpacking of the surface fluxes. - ! Sets: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux - ! NOTE: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux are returned as rates (i.e. stuff per second) + ! Sets: KPP_buoy_flux, KPP_temp_flux, KPP_salt_flux + ! NOTE: KPP_buoy_flux, KPP_temp_flux, KPP_salt_flux are returned as rates (i.e. stuff per second) ! unlike other instances where the fluxes are integrated in time over a time-step. call calculateBuoyancyFlux2d(G, GV, US, fluxes, CS%optics, h, tv%T, tv%S, tv, & - CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux) + KPP_buoy_flux, KPP_temp_flux, KPP_salt_flux) ! The KPP scheme calculates boundary layer diffusivities and non-local transport. ! Set diffusivities for heat and salt separately @@ -1877,26 +2162,28 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e enddo ; enddo ; enddo endif + ! Determine the friction velocity, perhaps using the evovling surface density. + call find_ustar(fluxes, tv, U_star, G, GV, US) + if ( associated(fluxes%lamult) ) then call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & - fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) + U_star, KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & - Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, KPP_buoy_flux, Kd_heat, & + Kd_salt, visc%Kv_shear, KPP_NLTheat, KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) else call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & - fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) + U_star, KPP_buoy_flux, Waves=Waves) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & - Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, KPP_buoy_flux, Kd_heat, & + Kd_salt, visc%Kv_shear, KPP_NLTheat, KPP_NLTscalar, Waves=Waves) endif - if (associated(Hml)) then - call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G, US) - call pass_var(Hml, G%domain, halo=1) - ! If visc%MLD exists, copy KPP's BLD into it - if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) - endif + call KPP_get_BLD(CS%KPP_CSp, BLD(:,:), G, US) + ! If visc%MLD or visc%h_ML exist, copy KPP's BLD into them with appropriate conversions. + if (associated(visc%h_ML)) call convert_MLD_to_ML_thickness(BLD, h, visc%h_ML, tv, G, GV) + if (associated(visc%MLD)) visc%MLD(:,:) = BLD(:,:) + if (associated(visc%sfc_buoy_flx)) visc%sfc_buoy_flx(:,:) = KPP_buoy_flux(:,:,1) if (.not. CS%KPPisPassive) then !$OMP parallel do default(shared) @@ -1918,31 +2205,32 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call MOM_state_chksum("after KPP", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after KPP", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after KPP", tv, G, US) - call hchksum(Kd_lay, "after KPP Kd_lay", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kd_Int, "after KPP Kd_Int", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_lay, "after KPP Kd_lay", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Kd_Int, "after KPP Kd_Int", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif - endif ! endif for KPP ! Add vertical diff./visc. due to convection (computed via CVMix) if (CS%use_CVMix_conv) then - call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv, Hml, Kd_int, visc%Kv_slow) + call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv, BLD, Kd_int, visc%Kv_shear) endif if (CS%useKPP) then call cpu_clock_begin(id_clock_kpp) if (CS%debug) then - call hchksum(CS%KPP_temp_flux, "before KPP_applyNLT netHeat", G%HI, haloshift=0, scale=GV%H_to_m*US%s_to_T) - call hchksum(CS%KPP_salt_flux, "before KPP_applyNLT netSalt", G%HI, haloshift=0, scale=GV%H_to_m*US%s_to_T) - call hchksum(CS%KPP_NLTheat, "before KPP_applyNLT NLTheat", G%HI, haloshift=0) - call hchksum(CS%KPP_NLTscalar, "before KPP_applyNLT NLTscalar", G%HI, haloshift=0) + call hchksum(KPP_temp_flux, "before KPP_applyNLT netHeat", G%HI, haloshift=0, & + unscale=US%C_to_degC*GV%H_to_m*US%s_to_T) + call hchksum(KPP_salt_flux, "before KPP_applyNLT netSalt", G%HI, haloshift=0, & + unscale=US%S_to_ppt*GV%H_to_m*US%s_to_T) + call hchksum(KPP_NLTheat, "before KPP_applyNLT NLTheat", G%HI, haloshift=0) + call hchksum(KPP_NLTscalar, "before KPP_applyNLT NLTscalar", G%HI, haloshift=0) endif ! Apply non-local transport of heat and salt ! Changes: tv%T, tv%S - call KPP_NonLocalTransport_temp(CS%KPP_CSp, G, GV, h, CS%KPP_NLTheat, CS%KPP_temp_flux, & - dt, tv%T, tv%C_p) - call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, CS%KPP_NLTscalar, CS%KPP_salt_flux, & - dt, tv%S) + call KPP_NonLocalTransport_temp(CS%KPP_CSp, G, GV, h, KPP_NLTheat, KPP_temp_flux, & + dt, tv%tr_T, tv%T, tv%C_p) + call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, KPP_NLTscalar, KPP_salt_flux, & + dt, tv%tr_S, tv%S) call cpu_clock_end(id_clock_kpp) if (showCallTree) call callTree_waypoint("done with KPP_applyNonLocalTransport (diabatic)") if (CS%debugConservation) call MOM_state_stats('KPP_applyNonLocalTransport', u, v, h, tv%T, tv%S, G, GV, US) @@ -1959,7 +2247,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e if (CS%double_diffuse .and. associated(tv%T)) then call cpu_clock_begin(id_clock_differential_diff) - call differential_diffuse_T_S(h, tv%T, tv%S, Kd_extra_T, Kd_extra_S, dt, G, GV) + call differential_diffuse_T_S(h, tv%T, tv%S, Kd_extra_T, Kd_extra_S, tv, dt, G, GV) call cpu_clock_end(id_clock_differential_diff) if (showCallTree) call callTree_waypoint("done with differential_diffuse_T_S (diabatic)") if (CS%debugConservation) call MOM_state_stats('differential_diffuse_T_S', u, v, h, tv%T, tv%S, G, GV, US) @@ -1990,8 +2278,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call MOM_forcing_chksum("after calc_entrain ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after calc_entrain ", tv, G, US) call MOM_state_chksum("after calc_entrain ", u, v, h, G, GV, US, haloshift=0) - call hchksum(ea, "after calc_entrain ea", G%HI, haloshift=0, scale=GV%H_to_m) - call hchksum(eb, "after calc_entrain eb", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(ea, "after calc_entrain ea", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(eb, "after calc_entrain eb", G%HI, haloshift=0, unscale=GV%H_to_MKS) endif ! Save fields before boundary forcing is applied for tendency diagnostics @@ -2146,8 +2434,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e eb(i,j,k) = eb(i,j,k) + ebml(i,j,k) enddo ; enddo ; enddo if (CS%debug) then - call hchksum(ea, "after ea = ea + eaml", G%HI, haloshift=0, scale=GV%H_to_m) - call hchksum(eb, "after eb = eb + ebml", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(ea, "after ea = ea + eaml", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(eb, "after eb = eb + ebml", G%HI, haloshift=0, unscale=GV%H_to_MKS) endif endif @@ -2168,7 +2456,9 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! Changes: h, tv%T, tv%S, ea and eb (G is also inout???) call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt_mix, ea, eb, & G, GV, US, CS%bulkmixedlayer, CS%optics, & - Hml, CS%aggregate_FW_forcing, dt, last_call=.true.) + BLD, h_MLD, CS%aggregate_FW_forcing, dt, last_call=.true.) + if (associated(visc%h_ML)) visc%h_ML(:,:) = h_MLD(:,:) + if (associated(visc%MLD)) visc%MLD(:,:) = BLD(:,:) ! Keep salinity from falling below a small but positive threshold. ! This constraint is needed for SIS1 ice model, which can extract @@ -2190,8 +2480,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e if (associated(tv%T)) then if (CS%debug) then - call hchksum(ea, "before triDiagTS ea ", G%HI, haloshift=0, scale=GV%H_to_m) - call hchksum(eb, "before triDiagTS eb ", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(ea, "before triDiagTS ea ", G%HI, haloshift=0, unscale=GV%H_to_MKS) + call hchksum(eb, "before triDiagTS eb ", G%HI, haloshift=0, unscale=GV%H_to_MKS) endif call cpu_clock_begin(id_clock_tridiag) @@ -2220,7 +2510,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e endif ! diagnose temperature, salinity, heat, and salt tendencies - ! Note: hold here refers to the thicknesses from before the dual-entraintment when using + ! Note: hold here refers to the thicknesses from before the dual-entrainment when using ! the bulk mixed layer scheme, so tendencies should be posted on hold. if (CS%diabatic_diff_tendency_diag) then call diagnose_diabatic_diff_tendency(tv, hold, temp_diag, saln_diag, dt, G, GV, US, CS) @@ -2238,8 +2528,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e if (CS%debug) then call MOM_state_chksum("after mixed layer ", u, v, h, G, GV, US, haloshift=0) call MOM_thermovar_chksum("after mixed layer ", tv, G, US) - call hchksum(ea, "after mixed layer ea", G%HI, scale=GV%H_to_m) - call hchksum(eb, "after mixed layer eb", G%HI, scale=GV%H_to_m) + call hchksum(ea, "after mixed layer ea", G%HI, unscale=GV%H_to_MKS) + call hchksum(eb, "after mixed layer eb", G%HI, unscale=GV%H_to_MKS) endif call cpu_clock_begin(id_clock_remap) @@ -2286,8 +2576,15 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! mixing of passive tracers from massless boundary layers to interior call cpu_clock_begin(id_clock_tracers) + + ! Find the vertical distances across layers. + if (CS%mix_boundary_tracers .or. CS%double_diffuse) & + call thickness_to_dz(h, tv, dz, G, GV, US) + if (CS%double_diffuse) & + call thickness_to_dz(hold, tv, dz_old, G, GV, US) + if (CS%mix_boundary_tracers) then - Tr_ea_BBL = GV%Z_to_H * sqrt(dt*CS%Kd_BBL_tr) + Tr_ea_BBL = sqrt(dt * CS%Kd_BBL_tr) !$OMP parallel do default(shared) private(htot,in_boundary,add_ent) do j=js,je do i=is,ie @@ -2306,9 +2603,9 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! in the calculation of the fluxes in the first place. Kd_min_tr ! should be much less than the values that have been set in Kd_lay, ! perhaps a molecular diffusivity. - add_ent = ((dt * CS%Kd_min_tr) * GV%Z_to_H**2) * & - ((h(i,j,k-1)+h(i,j,k)+h_neglect) / & - (h(i,j,k-1)*h(i,j,k)+h_neglect2)) - & + add_ent = (dt * CS%Kd_min_tr) * & + ((dz(i,j,k-1) + dz(i,j,k) + dz_neglect) / & + (dz(i,j,k-1)*dz(i,j,k) + dz_neglect2)) - & 0.5*(ea(i,j,k) + eb(i,j,k-1)) if (htot(i) < Tr_ea_BBL) then add_ent = max(0.0, add_ent, & @@ -2323,9 +2620,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ebtr(i,j,k-1) = eb(i,j,k-1) ; eatr(i,j,k) = ea(i,j,k) endif if (CS%double_diffuse) then ; if (Kd_extra_S(i,j,K) > 0.0) then - add_ent = ((dt * Kd_extra_S(i,j,K)) * GV%Z_to_H**2) / & - (0.25 * ((h(i,j,k-1) + h(i,j,k)) + (hold(i,j,k-1) + hold(i,j,k))) + & - h_neglect) + add_ent = (dt * Kd_extra_S(i,j,K)) / & + (0.25 * ((dz(i,j,k-1) + dz(i,j,k)) + (dz_old(i,j,k-1) + dz_old(i,j,k))) + dz_neglect) ebtr(i,j,k-1) = ebtr(i,j,k-1) + add_ent eatr(i,j,k) = eatr(i,j,k) + add_ent endif ; endif @@ -2334,8 +2630,9 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e enddo - call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, Hml, dt, G, GV, US, tv, & - CS%optics, CS%tracer_flow_CSp, CS%debug) + call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, BLD, dt, G, GV, US, tv, & + CS%optics, CS%tracer_flow_CSp, CS%debug, & + KPP_CSp=CS%KPP_CSp, nonLocalTrans=KPP_NLTscalar, h_BL=visc%h_ML) elseif (CS%double_diffuse) then ! extra diffusivity for passive tracers @@ -2345,9 +2642,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e !$OMP parallel do default(shared) private(add_ent) do k=nz,2,-1 ; do j=js,je ; do i=is,ie if (Kd_extra_S(i,j,K) > 0.0) then - add_ent = ((dt * Kd_extra_S(i,j,K)) * GV%Z_to_H**2) / & - (0.25 * ((h(i,j,k-1) + h(i,j,k)) + (hold(i,j,k-1) + hold(i,j,k))) + & - h_neglect) + add_ent = (dt * Kd_extra_S(i,j,K)) / & + (0.25 * ((dz(i,j,k-1) + dz(i,j,k)) + (dz_old(i,j,k-1) + dz_old(i,j,k))) + dz_neglect) else add_ent = 0.0 endif @@ -2355,12 +2651,14 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e eatr(i,j,k) = ea(i,j,k) + add_ent enddo ; enddo ; enddo - call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, Hml, dt, G, GV, US, tv, & - CS%optics, CS%tracer_flow_CSp, CS%debug) + call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, BLD, dt, G, GV, US, tv, & + CS%optics, CS%tracer_flow_CSp, CS%debug, & + KPP_CSp=CS%KPP_CSp, nonLocalTrans=KPP_NLTscalar, h_BL=visc%h_ML) else - call call_tracer_column_fns(hold, h, ea, eb, fluxes, Hml, dt, G, GV, US, tv, & - CS%optics, CS%tracer_flow_CSp, CS%debug) + call call_tracer_column_fns(hold, h, ea, eb, fluxes, BLD, dt, G, GV, US, tv, & + CS%optics, CS%tracer_flow_CSp, CS%debug, & + KPP_CSp=CS%KPP_CSp, nonLocalTrans=KPP_NLTscalar, h_BL=visc%h_ML) endif ! (CS%mix_boundary_tracers) @@ -2378,9 +2676,9 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call calculate_density(tv%T(:,j,1), tv%S(:,j,1), p_ref_cv, Rcv_ml(:,j), & tv%eqn_of_state, EOSdom) enddo - call apply_sponge(h, dt, G, GV, US, ea, eb, CS%sponge_CSp, Rcv_ml) + call apply_sponge(h, tv, dt, G, GV, US, ea, eb, CS%sponge_CSp, Rcv_ml) else - call apply_sponge(h, dt, G, GV, US, ea, eb, CS%sponge_CSp) + call apply_sponge(h, tv, dt, G, GV, US, ea, eb, CS%sponge_CSp) endif call cpu_clock_end(id_clock_sponge) if (CS%debug) then @@ -2421,8 +2719,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! mixed layer turbulence is applied elsewhere. if (CS%use_bulkmixedlayer) then if (CS%debug) then - call hchksum(ea, "before net flux rearrangement ea", G%HI, scale=GV%H_to_m) - call hchksum(eb, "before net flux rearrangement eb", G%HI, scale=GV%H_to_m) + call hchksum(ea, "before net flux rearrangement ea", G%HI, unscale=GV%H_to_MKS) + call hchksum(eb, "before net flux rearrangement eb", G%HI, unscale=GV%H_to_MKS) endif !$OMP parallel do default(shared) private(net_ent) do j=js,je @@ -2433,8 +2731,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e enddo ; enddo enddo if (CS%debug) then - call hchksum(ea, "after net flux rearrangement ea", G%HI, scale=GV%H_to_m) - call hchksum(eb, "after net flux rearrangement eb", G%HI, scale=GV%H_to_m) + call hchksum(ea, "after net flux rearrangement ea", G%HI, unscale=GV%H_to_MKS) + call hchksum(eb, "after net flux rearrangement eb", G%HI, unscale=GV%H_to_MKS) endif endif @@ -2465,9 +2763,9 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! or enters the ocean with the surface velocity. if (CS%debug) then call MOM_state_chksum("before u/v tridiag ", u, v, h, G, GV, US, haloshift=0) - call hchksum(ea, "before u/v tridiag ea", G%HI, scale=GV%H_to_m) - call hchksum(eb, "before u/v tridiag eb", G%HI, scale=GV%H_to_m) - call hchksum(hold, "before u/v tridiag hold", G%HI, scale=GV%H_to_m) + call hchksum(ea, "before u/v tridiag ea", G%HI, unscale=GV%H_to_MKS) + call hchksum(eb, "before u/v tridiag eb", G%HI, unscale=GV%H_to_MKS) + call hchksum(hold, "before u/v tridiag hold", G%HI, unscale=GV%H_to_MKS) endif call cpu_clock_begin(id_clock_tridiag) @@ -2569,7 +2867,7 @@ end subroutine layered_diabatic !> Returns pointers or values of members within the diabatic_CS type. For extensibility, !! each returned argument is an optional argument subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, evap_CFL_limit, minimum_forcing_depth, & - KPP_CSp, energetic_PBL_CSp, diabatic_aux_CSp, diabatic_halo) + KPP_CSp, energetic_PBL_CSp, diabatic_aux_CSp, diabatic_halo, use_KPP) type(diabatic_CS), target, intent(in) :: CS !< module control structure ! All output arguments are optional type(opacity_CS), optional, pointer :: opacity_CSp !< A pointer to be set to the opacity control structure @@ -2584,18 +2882,20 @@ subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, evap_CFL_limit, !! control structure integer, optional, intent( out) :: diabatic_halo !< The halo size where the diabatic algorithms !! assume thermodynamics properties are valid. + logical, optional, intent( out) :: use_KPP !< If true, diabatic is using KPP vertical mixing ! Pointers to control structures if (present(opacity_CSp)) opacity_CSp => CS%opacity if (present(optics_CSp)) optics_CSp => CS%optics if (present(KPP_CSp)) KPP_CSp => CS%KPP_CSp - if (present(energetic_PBL_CSp)) energetic_PBL_CSp => CS%energetic_PBL + if (present(energetic_PBL_CSp) .and. CS%use_energetic_PBL) energetic_PBL_CSp => CS%ePBL + if (present(diabatic_aux_CSp)) diabatic_aux_CSp => CS%diabatic_aux_CSp ! Constants within diabatic_CS if (present(evap_CFL_limit)) evap_CFL_limit = CS%evap_CFL_limit if (present(minimum_forcing_depth)) minimum_forcing_depth = CS%minimum_forcing_depth - if (present(diabatic_halo)) diabatic_halo = CS%halo_TS_diff - + if (present(diabatic_halo)) diabatic_halo = CS%halo_diabatic + if (present(use_KPP)) use_KPP = CS%use_KPP end subroutine extract_diabatic_member !> Routine called for adiabatic physics @@ -2610,7 +2910,7 @@ subroutine adiabatic(h, tv, fluxes, dt, G, GV, US, CS) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diabatic_CS), pointer :: CS !< module control structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: zeros ! An array of zeros. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: zeros ! An array of zeros with units of [H ~> m or kg m-2] zeros(:,:,:) = 0.0 @@ -2628,19 +2928,19 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(thermo_var_ptrs), intent(in) :: tv !< points to updated thermodynamic fields real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< thickness [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: temp_old !< temperature prior to diabatic physics - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: saln_old !< salinity prior to diabatic physics [ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: temp_old !< temperature prior to diabatic + !! physics [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: saln_old !< salinity prior to diabatic physics [S ~> ppt] real, intent(in) :: dt !< time step [T ~> s] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diabatic_CS), pointer :: CS !< module control structure ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: work_3d - real, dimension(SZI_(G),SZJ_(G)) :: work_2d + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: work_3d ! A 3-d work array for diagnostics [various] + real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array for diagnostics [various] real :: Idt ! The inverse of the timestep [T-1 ~> s-1] - real :: ppt2mks = 0.001 ! Conversion factor from g/kg to kg/kg. integer :: i, j, k, is, ie, js, je, nz - logical :: do_saln_tend ! Calculate salinity-based tendency diagnosics + logical :: do_saln_tend ! Calculate salinity-based tendency diagnostics is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Idt = 0.0 ; if (dt > 0.0) Idt = 1. / dt @@ -2689,7 +2989,7 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, ! salt tendency if (CS%id_diabatic_diff_salt_tend > 0 .or. CS%id_diabatic_diff_salt_tend_2d > 0) then do k=1,nz ; do j=js,je ; do i=is,ie - work_3d(i,j,k) = h(i,j,k)*GV%H_to_RZ * ppt2mks * work_3d(i,j,k) + work_3d(i,j,k) = h(i,j,k) * work_3d(i,j,k) enddo ; enddo ; enddo if (CS%id_diabatic_diff_salt_tend > 0) then call post_data(CS%id_diabatic_diff_salt_tend, work_3d, CS%diag, alt_h=h) @@ -2719,9 +3019,9 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< thickness after boundary flux application [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: temp_old !< temperature prior to boundary flux application [degC] + intent(in) :: temp_old !< temperature prior to boundary flux application [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: saln_old !< salinity prior to boundary flux application [ppt] + intent(in) :: saln_old !< salinity prior to boundary flux application [S ~> ppt] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h_old !< thickness prior to boundary flux application [H ~> m or kg m-2] real, intent(in) :: dt !< time step [T ~> s] @@ -2729,10 +3029,9 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, type(diabatic_CS), pointer :: CS !< module control structure ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: work_3d - real, dimension(SZI_(G),SZJ_(G)) :: work_2d + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: work_3d ! A 3-d work array for diagnostics [various] + real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array for diagnostics [various] real :: Idt ! The inverse of the timestep [T-1 ~> s-1] - real :: ppt2mks = 0.001 ! Conversion factor from g/kg to kg/kg. integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -2784,7 +3083,7 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, ! salt tendency if (CS%id_boundary_forcing_salt_tend > 0 .or. CS%id_boundary_forcing_salt_tend_2d > 0) then do k=1,nz ; do j=js,je ; do i=is,ie - work_3d(i,j,k) = GV%H_to_RZ * ppt2mks * Idt * (h(i,j,k) * tv%S(i,j,k) - h_old(i,j,k) * saln_old(i,j,k)) + work_3d(i,j,k) = Idt * (h(i,j,k) * tv%S(i,j,k) - h_old(i,j,k) * saln_old(i,j,k)) enddo ; enddo ; enddo if (CS%id_boundary_forcing_salt_tend > 0) then call post_data(CS%id_boundary_forcing_salt_tend, work_3d, CS%diag, alt_h=h_old) @@ -2810,13 +3109,13 @@ subroutine diagnose_frazil_tendency(tv, h, temp_old, dt, G, GV, US, CS) type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(thermo_var_ptrs), intent(in) :: tv !< points to updated thermodynamic fields real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< thickness [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: temp_old !< temperature prior to frazil formation [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: temp_old !< temperature prior to frazil formation [C ~> degC] real, intent(in) :: dt !< time step [T ~> s] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diabatic_CS), pointer :: CS !< module control structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: work_3d - real, dimension(SZI_(G),SZJ_(G)) :: work_2d + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: work_3d ! A 3-d work array for diagnostics [various] + real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array for diagnostics [various] real :: Idt ! The inverse of the timestep [T-1 ~> s-1] integer :: i, j, k, is, ie, js, je, nz @@ -2913,7 +3212,7 @@ end subroutine adiabatic_driver_init !> This routine initializes the diabatic driver module. subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, diag, & ADp, CDp, CS, tracer_flow_CSp, sponge_CSp, & - ALE_sponge_CSp, oda_incupd_CSp) + ALE_sponge_CSp, oda_incupd_CSp, int_tide_CSp) type(time_type), target :: Time !< model time type(ocean_grid_type), intent(inout) :: G !< model grid structure type(verticalGrid_type), intent(in) :: GV !< model vertical grid structure @@ -2929,11 +3228,12 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di !! tracer flow control module type(sponge_CS), pointer :: sponge_CSp !< pointer to the sponge module control structure type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< pointer to the ALE sponge module control structure - type(oda_incupd_CS), pointer :: oda_incupd_CSp !< pointer to the oda incupd module control structure + type(oda_incupd_CS), pointer :: oda_incupd_CSp !< pointer to the ocean data assimilation incremental + !! update module control structure + type(int_tide_CS), pointer :: int_tide_CSp !< pointer to the internal tide structure ! Local variables - real :: Kd ! A diffusivity used in the default for other tracer diffusivities, in MKS units [m2 s-1] - integer :: num_mode + real :: Kd ! A diffusivity used in the default for other tracer diffusivities [Z2 T-1 ~> m2 s-1] logical :: use_temperature character(len=20) :: EN1, EN2, EN3 @@ -2941,20 +3241,11 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di # include "version_variable.h" character(len=40) :: mdl = "MOM_diabatic_driver" ! This module's name. character(len=48) :: thickness_units - character(len=40) :: var_name - character(len=160) :: var_descript - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz, nbands, m + logical :: physical_OBL_scheme + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz, nbands isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - if (associated(CS)) then - call MOM_error(WARNING, "diabatic_driver_init called with an "// & - "associated control structure.") - return - else - allocate(CS) - endif - CS%initialized = .true. CS%diag => diag @@ -2964,6 +3255,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di if (associated(sponge_CSp)) CS%sponge_CSp => sponge_CSp if (associated(ALE_sponge_CSp)) CS%ALE_sponge_CSp => ALE_sponge_CSp if (associated(oda_incupd_CSp)) CS%oda_incupd_CSp => oda_incupd_CSp + if (associated(int_tide_CSp)) CS%int_tide_CSp => int_tide_CSp CS%useALEalgorithm = useALEalgorithm CS%use_bulkmixedlayer = (GV%nkml > 0) @@ -3025,18 +3317,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di call get_param(param_file, mdl, "INTERNAL_TIDES", CS%use_int_tides, & "If true, use the code that advances a separate set of "//& "equations for the internal tide energy density.", default=.false.) - CS%nMode = 1 - if (CS%use_int_tides) then - call get_param(param_file, mdl, "INTERNAL_TIDE_MODES", CS%nMode, & - "The number of distinct internal tide modes "//& - "that will be calculated.", default=1, do_not_log=.true.) - call get_param(param_file, mdl, "UNIFORM_TEST_CG", CS%uniform_test_cg, & - "If positive, a uniform group velocity of internal tide for test case", & - default=-1., units="m s-1", scale=US%m_s_to_L_T) - endif - call get_param(param_file, mdl, "MASSLESS_MATCH_TARGETS", & - CS%massless_match_targets, & + call get_param(param_file, mdl, "MASSLESS_MATCH_TARGETS", CS%massless_match_targets, & "If true, the temperature and salinity of massless layers "//& "are kept consistent with their target densities. "//& "Otherwise the properties of massless layers evolve "//& @@ -3069,16 +3351,19 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di "KD_MIN_TR were operating.", default=.false., do_not_log=.not.CS%useALEalgorithm) if (CS%mix_boundary_tracers .or. CS%mix_boundary_tracer_ALE) then - call get_param(param_file, mdl, "KD", Kd, default=0.0) + call get_param(param_file, mdl, "KD", Kd, units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "KD_MIN_TR", CS%Kd_min_tr, & "A minimal diffusivity that should always be applied to "//& "tracers, especially in massless layers near the bottom. "//& - "The default is 0.1*KD.", units="m2 s-1", default=0.1*Kd, scale=US%m2_s_to_Z2_T) + "The default is 0.1*KD.", & + units="m2 s-1", default=0.1*Kd*US%Z2_T_to_m2_s, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "KD_BBL_TR", CS%Kd_BBL_tr, & "A bottom boundary layer tracer diffusivity that will "//& "allow for explicitly specified bottom fluxes. The "//& "entrainment at the bottom is at least sqrt(Kd_BBL_tr*dt) "//& - "over the same distance.", units="m2 s-1", default=0., scale=US%m2_s_to_Z2_T) + "over the same distance.", & + units="m2 s-1", default=0., scale=GV%m2_s_to_HZ_T*(US%Z_to_m*GV%m_to_H)) + ! The scaling factor here is usually equivalent to GV%m2_s_to_HZ_T*GV%Z_to_H. endif call get_param(param_file, mdl, "TRACER_TRIDIAG", CS%tracer_tridiag, & @@ -3143,38 +3428,37 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di call safe_alloc_ptr(ADp%dv_dt_dia,isd,ied,JsdB,JedB,nz) endif - if (CS%use_int_tides) then - CS%id_cg1 = register_diag_field('ocean_model', 'cn1', diag%axesT1, & - Time, 'First baroclinic mode (eigen) speed', 'm s-1', conversion=US%L_T_to_m_s) - allocate(CS%id_cn(CS%nMode), source=-1) - do m=1,CS%nMode - write(var_name, '("cn_mode",i1)') m - write(var_descript, '("Baroclinic (eigen) speed of mode ",i1)') m - CS%id_cn(m) = register_diag_field('ocean_model',var_name, diag%axesT1, & - Time, var_descript, 'm s-1', conversion=US%L_T_to_m_s) - call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) - enddo - endif - if (use_temperature) then CS%id_Tdif = register_diag_field('ocean_model',"Tflx_dia_diff", diag%axesTi, & Time, "Diffusive diapycnal temperature flux across interfaces", & - "degC m s-1", conversion=GV%H_to_m*US%s_to_T) + units="degC m s-1", conversion=US%C_to_degC*GV%H_to_m*US%s_to_T) if (.not.CS%useALEalgorithm) then CS%id_Tadv = register_diag_field('ocean_model',"Tflx_dia_adv", diag%axesTi, & Time, "Advective diapycnal temperature flux across interfaces", & - "degC m s-1", conversion=GV%H_to_m*US%s_to_T) + units="degC m s-1", conversion=US%C_to_degC*GV%H_to_m*US%s_to_T) endif CS%id_Sdif = register_diag_field('ocean_model',"Sflx_dia_diff", diag%axesTi, & Time, "Diffusive diapycnal salnity flux across interfaces", & - "psu m s-1", conversion=GV%H_to_m*US%s_to_T) + units="psu m s-1", conversion=US%S_to_ppt*GV%H_to_m*US%s_to_T) if (.not.CS%useALEalgorithm) then CS%id_Sadv = register_diag_field('ocean_model',"Sflx_dia_adv", diag%axesTi, & Time, "Advective diapycnal salnity flux across interfaces", & - "psu m s-1", conversion=GV%H_to_m*US%s_to_T) + units="psu m s-1", conversion=US%S_to_ppt*GV%H_to_m*US%s_to_T) endif + + CS%id_N2_dd = register_diag_field('ocean_model',"N2_diabatic", diag%axesTi, & + Time, "Squared buoyancy frequency diagnosed after diffusion applied in thermodynamic timestep.", & + "s-2", conversion=US%s_to_T**2) + CS%id_N2_temp_dd = register_diag_field('ocean_model',"N2_temp_diabatic", diag%axesTi, & + Time, "Squared buoyancy frequency due to temperature stratification diagnosed after diffusion applied "//& + "in thermodynamic timestep.", "s-2", conversion=US%s_to_T**2) + CS%id_N2_salt_dd = register_diag_field('ocean_model',"N2_salt_diabatic", diag%axesTi, & + Time, "Squared buoyancy frequency due to salinity stratification diagnosed after diffusion applied "//& + "in thermodynamic timestep.", "s-2", conversion=US%s_to_T**2) + if (CS%id_N2_dd>0 .or. CS%id_N2_temp_dd>0 .or. CS%id_N2_salt_dd>0) CS%Use_N2_diag = .true. + CS%id_MLD_003 = register_diag_field('ocean_model', 'MLD_003', diag%axesT1, Time, & - 'Mixed layer depth (delta rho = 0.03)', 'm', conversion=US%Z_to_m, & + 'Mixed layer depth (delta rho = 0.03)', units='m', conversion=US%Z_to_m, & cmor_field_name='mlotst', cmor_long_name='Ocean Mixed Layer Thickness Defined by Sigma T', & cmor_standard_name='ocean_mixed_layer_thickness_defined_by_sigma_t') CS%id_mlotstsq = register_diag_field('ocean_model', 'mlotstsq', diag%axesT1, Time, & @@ -3183,32 +3467,66 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di units='m2', conversion=US%Z_to_m**2) CS%id_MLD_0125 = register_diag_field('ocean_model', 'MLD_0125', diag%axesT1, Time, & 'Mixed layer depth (delta rho = 0.125)', 'm', conversion=US%Z_to_m) - call get_param(param_file, mdl, "MLD_EN_VALS", CS%MLD_EN_VALS, & + call get_param(param_file, mdl, "MLD_EN_VALS", CS%MLD_En_vals, & "The energy values used to compute MLDs. If not set (or all set to 0.), the "//& - "default will overwrite to 25., 2500., 250000.",units='J/m2', default=0., & - scale=US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2) - if ((CS%MLD_EN_VALS(1)==0.).and.(CS%MLD_EN_VALS(2)==0.).and.(CS%MLD_EN_VALS(3)==0.)) then - CS%MLD_EN_VALS = (/25.*US%kg_m3_to_R*US%m_to_Z*US%m_to_L**2*US%T_to_s**2,& - 2500.*US%kg_m3_to_R*US%m_to_Z*US%m_to_L**2*US%T_to_s**2,& - 250000.*US%kg_m3_to_R*US%m_to_Z*US%m_to_L**2*US%T_to_s**2/) - endif - write(EN1,'(F10.2)') CS%MLD_EN_VALS(1)*US%R_to_kg_m3*US%Z_to_m*US%L_to_m**2*US%s_to_T**2 - write(EN2,'(F10.2)') CS%MLD_EN_VALS(2)*US%R_to_kg_m3*US%Z_to_m*US%L_to_m**2*US%s_to_T**2 - write(EN3,'(F10.2)') CS%MLD_EN_VALS(3)*US%R_to_kg_m3*US%Z_to_m*US%L_to_m**2*US%s_to_T**2 + "default will overwrite to 25., 2500., 250000.", units='J/m2', & + defaults=(/25., 2500., 250000./), scale=US%W_m2_to_RZ3_T3*US%s_to_T) + write(EN1,'(F10.2)') CS%MLD_En_vals(1)*US%RZ3_T3_to_W_m2*US%T_to_s + write(EN2,'(F10.2)') CS%MLD_En_vals(2)*US%RZ3_T3_to_W_m2*US%T_to_s + write(EN3,'(F10.2)') CS%MLD_En_vals(3)*US%RZ3_T3_to_W_m2*US%T_to_s CS%id_MLD_EN1 = register_diag_field('ocean_model', 'MLD_EN1', diag%axesT1, Time, & 'Mixed layer depth for energy value set to '//trim(EN1)//' J/m2 (Energy set by 1st MLD_EN_VALS)', & - 'm', conversion=US%Z_to_m) + units='m', conversion=US%Z_to_m) CS%id_MLD_EN2 = register_diag_field('ocean_model', 'MLD_EN2', diag%axesT1, Time, & 'Mixed layer depth for energy value set to '//trim(EN2)//' J/m2 (Energy set by 2nd MLD_EN_VALS)', & - 'm', conversion=US%Z_to_m) + units='m', conversion=US%Z_to_m) CS%id_MLD_EN3 = register_diag_field('ocean_model', 'MLD_EN3', diag%axesT1, Time, & 'Mixed layer depth for energy value set to '//trim(EN3)//' J/m2 (Energy set by 3rd MLD_EN_VALS)', & - 'm', conversion=US%Z_to_m) + units='m', conversion=US%Z_to_m) + call get_param(param_file, mdl, "BMLD_EN_VALS", CS%BMLD_En_vals, & + "The energy values used to compute Bottom MLDs. If not set (or all set to 0.), the "//& + "default will overwrite to 25., 2500., 250000.", units='J/m2', & + defaults=(/25., 2500., 250000./), scale=US%W_m2_to_RZ3_T3*US%s_to_T) + write(EN1,'(F10.2)') CS%BMLD_En_vals(1)*US%RZ3_T3_to_W_m2*US%T_to_s + write(EN2,'(F10.2)') CS%BMLD_En_vals(2)*US%RZ3_T3_to_W_m2*US%T_to_s + write(EN3,'(F10.2)') CS%BMLD_En_vals(3)*US%RZ3_T3_to_W_m2*US%T_to_s + CS%id_BMLD_EN1 = register_diag_field('ocean_model', 'BMLD_EN1', diag%axesT1, Time, & + 'Bottom mixed layer depth for energy value set to '//trim(EN1)//' J/m2 (Energy set by 1st MLD_EN_VALS)', & + units='m', conversion=US%Z_to_m) + CS%id_BMLD_EN2 = register_diag_field('ocean_model', 'BMLD_EN2', diag%axesT1, Time, & + 'Bottom mixed layer depth for energy value set to '//trim(EN2)//' J/m2 (Energy set by 2nd MLD_EN_VALS)', & + units='m', conversion=US%Z_to_m) + CS%id_BMLD_EN3 = register_diag_field('ocean_model', 'BMLD_EN3', diag%axesT1, Time, & + 'Bottom mixed layer depth for energy value set to '//trim(EN3)//' J/m2 (Energy set by 3rd MLD_EN_VALS)', & + units='m', conversion=US%Z_to_m) + if ((CS%id_MLD_EN1>0).or. (CS%id_MLD_EN2>0).or. (CS%id_MLD_EN3>0).or. & + (CS%id_BMLD_EN1>0).or.(CS%id_BMLD_EN2>0).or.(CS%id_BMLD_EN3>0)) then + call get_param(param_file, mdl, "USE_OM4_MLD_EN_ITER", CS%use_OM4_MLD_En_iter, & + "If true, uses an older set of iteration coefficients in computing the PE based "//& + "surface MLD to reproduce OM4 era models. False uses an updated (general) method.",& + default=.true.) + endif CS%id_subMLN2 = register_diag_field('ocean_model', 'subML_N2', diag%axesT1, Time, & - 'Squared buoyancy frequency below mixed layer', 's-2', conversion=US%s_to_T**2) + 'Squared buoyancy frequency below mixed layer', units='s-2', conversion=US%s_to_T**2) CS%id_MLD_user = register_diag_field('ocean_model', 'MLD_user', diag%axesT1, Time, & - 'Mixed layer depth (used defined)', 'm', conversion=US%Z_to_m) + 'Mixed layer depth (used defined)', units='m', conversion=US%Z_to_m) + if (CS%id_MLD_003 > 0) then + call get_param(param_file, mdl, "HREF_FOR_MLD", CS%ref_h_mld, & + "Reference depth used to calculate the potential density used to find the mixed layer depth "//& + "based on a delta rho = 0.03 kg/m3.", units='m', default=0.0, scale=US%m_to_Z) + CS%id_MLD_003_zr = register_diag_field('ocean_model', 'MLD_003_refZ', diag%axesT1, Time, & + 'Depth of reference density for MLD (delta rho = 0.03)', units='m', conversion=US%Z_to_m) + CS%id_MLD_003_rr = register_diag_field('ocean_model', 'MLD_003_refRho', diag%axesT1, Time, & + 'Reference density for MLD (delta rho = 0.03)', units='kg/m3', conversion=US%R_to_kg_m3) + endif endif + + call KdWork_init(Time, G,GV,US,diag,CS%VBF,CS%Use_KdWork_diag) + if (CS%Use_KdWork_diag.and.(.not.useALEalgorithm)) & + call MOM_error(WARNING,"The KdWork diagnostics are not fully implemented for use in layer mode.") + if (CS%Use_KdWork_diag.and.(CS%use_legacy_diabatic)) & + call MOM_error(WARNING,"The KdWork diagnostics are only approximate with the legacy diabatic driver.") + call get_param(param_file, mdl, "DIAG_MLD_DENSITY_DIFF", CS%MLDdensityDifference, & "The density difference used to determine a diagnostic mixed "//& "layer depth, MLD_user, following the definition of Levitus 1982. "//& @@ -3229,28 +3547,28 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 'Layer Thickness before diabatic forcing', & trim(thickness_units), conversion=GV%H_to_MKS, v_extensive=.true.) CS%id_e_predia = register_diag_field('ocean_model', 'e_predia', diag%axesTi, Time, & - 'Interface Heights before diabatic forcing', 'm') + 'Interface Heights before diabatic forcing', 'm', conversion=US%Z_to_m) if (use_temperature) then CS%id_T_predia = register_diag_field('ocean_model', 'temp_predia', diag%axesTL, Time, & - 'Potential Temperature', 'degC') + 'Potential Temperature', 'degC', conversion=US%C_to_degC) CS%id_S_predia = register_diag_field('ocean_model', 'salt_predia', diag%axesTL, Time, & - 'Salinity', 'PSU') + 'Salinity', 'PSU', conversion=US%S_to_ppt) endif CS%id_Kd_int = register_diag_field('ocean_model', 'Kd_interface', diag%axesTi, Time, & - 'Total diapycnal diffusivity at interfaces', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Total diapycnal diffusivity at interfaces', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) if (CS%use_energetic_PBL) then - CS%id_Kd_ePBL = register_diag_field('ocean_model', 'Kd_ePBL', diag%axesTi, Time, & - 'ePBL diapycnal diffusivity at interfaces', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + CS%id_Kd_ePBL = register_diag_field('ocean_model', 'Kd_ePBL', diag%axesTi, Time, & + 'ePBL diapycnal diffusivity at interfaces', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) endif CS%id_Kd_heat = register_diag_field('ocean_model', 'Kd_heat', diag%axesTi, Time, & - 'Total diapycnal diffusivity for heat at interfaces', 'm2 s-1', conversion=US%Z2_T_to_m2_s, & + 'Total diapycnal diffusivity for heat at interfaces', 'm2 s-1', conversion=GV%HZ_T_to_m2_s, & cmor_field_name='difvho', & cmor_standard_name='ocean_vertical_heat_diffusivity', & cmor_long_name='Ocean vertical heat diffusivity') CS%id_Kd_salt = register_diag_field('ocean_model', 'Kd_salt', diag%axesTi, Time, & - 'Total diapycnal diffusivity for salt at interfaces', 'm2 s-1', conversion=US%Z2_T_to_m2_s, & + 'Total diapycnal diffusivity for salt at interfaces', 'm2 s-1', conversion=GV%HZ_T_to_m2_s, & cmor_field_name='difvso', & cmor_standard_name='ocean_vertical_salt_diffusivity', & cmor_long_name='Ocean vertical salt diffusivity') @@ -3258,32 +3576,25 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! CS%useKPP is set to True if KPP-scheme is to be used, False otherwise. ! KPP_init() allocated CS%KPP_Csp and also sets CS%KPPisPassive CS%useKPP = KPP_init(param_file, G, GV, US, diag, Time, CS%KPP_CSp, passive=CS%KPPisPassive) - if (CS%useKPP) then - allocate(CS%KPP_NLTheat(isd:ied,jsd:jed,nz+1), source=0.0) - allocate(CS%KPP_NLTscalar(isd:ied,jsd:jed,nz+1), source=0.0) - allocate(CS%KPP_buoy_flux(isd:ied,jsd:jed,nz+1), source=0.0) - allocate(CS%KPP_temp_flux(isd:ied,jsd:jed), source=0.0) - allocate(CS%KPP_salt_flux(isd:ied,jsd:jed), source=0.0) - endif - - ! diagnostics for tendencies of temp and saln due to diabatic processes + ! Diagnostics for tendencies of temperature and salinity due to diabatic processes, ! available only for ALE algorithm. - ! diagnostics for tendencies of temp and heat due to frazil + ! Diagnostics for tendencies of temperature and heat due to frazil CS%id_diabatic_diff_h = register_diag_field('ocean_model', 'diabatic_diff_h', diag%axesTL, Time, & - long_name='Cell thickness used during diabatic diffusion', & - units='m', conversion=GV%H_to_m, v_extensive=.true.) + 'Cell thickness used during diabatic diffusion', & + thickness_units, conversion=GV%H_to_MKS, v_extensive=.true.) + if (CS%useALEalgorithm) then CS%id_diabatic_diff_temp_tend = register_diag_field('ocean_model', & 'diabatic_diff_temp_tendency', diag%axesTL, Time, & - 'Diabatic diffusion temperature tendency', 'degC s-1', conversion=US%s_to_T) + 'Diabatic diffusion temperature tendency', 'degC s-1', conversion=US%C_to_degC*US%s_to_T) if (CS%id_diabatic_diff_temp_tend > 0) then CS%diabatic_diff_tendency_diag = .true. endif CS%id_diabatic_diff_saln_tend = register_diag_field('ocean_model',& 'diabatic_diff_saln_tendency', diag%axesTL, Time, & - 'Diabatic diffusion salinity tendency', 'psu s-1', conversion=US%s_to_T) + 'Diabatic diffusion salinity tendency', 'psu s-1', conversion=US%S_to_ppt*US%s_to_T) if (CS%id_diabatic_diff_saln_tend > 0) then CS%diabatic_diff_tendency_diag = .true. endif @@ -3304,7 +3615,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_diabatic_diff_salt_tend = register_diag_field('ocean_model', & 'diabatic_salt_tendency', diag%axesTL, Time, & 'Diabatic diffusion of salt tendency', & - 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, cmor_field_name='osaltdiff', & + 'kg m-2 s-1', conversion=US%S_to_ppt*0.001*GV%H_to_RZ*US%RZ_T_to_kg_m2s, & + cmor_field_name='osaltdiff', & cmor_standard_name='tendency_of_sea_water_salinity_expressed_as_salt_content_'// & 'due_to_parameterized_dianeutral_mixing', & cmor_long_name='Tendency of sea water salinity expressed as salt content '// & @@ -3331,7 +3643,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_diabatic_diff_salt_tend_2d = register_diag_field('ocean_model', & 'diabatic_salt_tendency_2d', diag%axesT1, Time, & 'Depth integrated diabatic diffusion salt tendency', & - 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, cmor_field_name='osaltdiff_2d', & + 'kg m-2 s-1', conversion=US%S_to_ppt*0.001*GV%H_to_RZ*US%RZ_T_to_kg_m2s, & + cmor_field_name='osaltdiff_2d', & cmor_standard_name='tendency_of_sea_water_salinity_expressed_as_salt_content_'// & 'due_to_parameterized_dianeutral_mixing_depth_integrated', & cmor_long_name='Tendency of sea water salinity expressed as salt content '// & @@ -3340,30 +3653,30 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%diabatic_diff_tendency_diag = .true. endif - ! diagnostics for tendencies of thickness temp and saln due to boundary forcing + ! Diagnostics for tendencies of thickness temperature and salinity due to boundary forcing, ! available only for ALE algorithm. - ! diagnostics for tendencies of temp and heat due to frazil + ! Diagnostics for tendencies of temperature and heat due to frazil CS%id_boundary_forcing_h = register_diag_field('ocean_model', 'boundary_forcing_h', diag%axesTL, Time, & - long_name='Cell thickness after applying boundary forcing', & - units='m', conversion=GV%H_to_m, v_extensive=.true.) + 'Cell thickness after applying boundary forcing', & + thickness_units, conversion=GV%H_to_MKS, v_extensive=.true.) CS%id_boundary_forcing_h_tendency = register_diag_field('ocean_model', & 'boundary_forcing_h_tendency', diag%axesTL, Time, & 'Cell thickness tendency due to boundary forcing', & - 'm s-1', conversion=GV%H_to_m*US%s_to_T, v_extensive=.true.) + trim(thickness_units)//" s-1", conversion=GV%H_to_MKS*US%s_to_T, v_extensive=.true.) if (CS%id_boundary_forcing_h_tendency > 0) then CS%boundary_forcing_tendency_diag = .true. endif CS%id_boundary_forcing_temp_tend = register_diag_field('ocean_model',& 'boundary_forcing_temp_tendency', diag%axesTL, Time, & - 'Boundary forcing temperature tendency', 'degC s-1', conversion=US%s_to_T) + 'Boundary forcing temperature tendency', 'degC s-1', conversion=US%C_to_degC*US%s_to_T) if (CS%id_boundary_forcing_temp_tend > 0) then CS%boundary_forcing_tendency_diag = .true. endif CS%id_boundary_forcing_saln_tend = register_diag_field('ocean_model',& 'boundary_forcing_saln_tendency', diag%axesTL, Time, & - 'Boundary forcing saln tendency', 'psu s-1', conversion=US%s_to_T) + 'Boundary forcing saln tendency', 'psu s-1', conversion=US%S_to_ppt*US%s_to_T) if (CS%id_boundary_forcing_saln_tend > 0) then CS%boundary_forcing_tendency_diag = .true. endif @@ -3371,14 +3684,15 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_boundary_forcing_heat_tend = register_diag_field('ocean_model',& 'boundary_forcing_heat_tendency', diag%axesTL, Time, & 'Boundary forcing heat tendency', & - 'W m-2', conversion=US%QRZ_T_to_W_m2, v_extensive = .true.) + 'W m-2', conversion=US%QRZ_T_to_W_m2, v_extensive=.true.) if (CS%id_boundary_forcing_heat_tend > 0) then CS%boundary_forcing_tendency_diag = .true. endif CS%id_boundary_forcing_salt_tend = register_diag_field('ocean_model',& 'boundary_forcing_salt_tendency', diag%axesTL, Time, & - 'Boundary forcing salt tendency', 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + 'Boundary forcing salt tendency', & + 'kg m-2 s-1', conversion=US%S_to_ppt*0.001*GV%H_to_RZ*US%RZ_T_to_kg_m2s, & v_extensive = .true.) if (CS%id_boundary_forcing_salt_tend > 0) then CS%boundary_forcing_tendency_diag = .true. @@ -3397,7 +3711,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_boundary_forcing_salt_tend_2d = register_diag_field('ocean_model',& 'boundary_forcing_salt_tendency_2d', diag%axesT1, Time, & 'Depth integrated boundary forcing of ocean salt', & - 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) + 'kg m-2 s-1', conversion=US%S_to_ppt*0.001*GV%H_to_RZ*US%RZ_T_to_kg_m2s) if (CS%id_boundary_forcing_salt_tend_2d > 0) then CS%boundary_forcing_tendency_diag = .true. endif @@ -3406,12 +3720,12 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! diagnostics for tendencies of temp and heat due to frazil CS%id_frazil_h = register_diag_field('ocean_model', 'frazil_h', diag%axesTL, Time, & long_name='Cell Thickness', standard_name='cell_thickness', & - units='m', conversion=GV%H_to_m, v_extensive=.true.) + units=thickness_units, conversion=GV%H_to_MKS, v_extensive=.true.) ! diagnostic for tendency of temp due to frazil CS%id_frazil_temp_tend = register_diag_field('ocean_model',& 'frazil_temp_tendency', diag%axesTL, Time, & - 'Temperature tendency due to frazil formation', 'degC s-1', conversion=US%s_to_T) + 'Temperature tendency due to frazil formation', 'degC s-1', conversion=US%C_to_degC*US%s_to_T) if (CS%id_frazil_temp_tend > 0) then CS%frazil_tendency_diag = .true. endif @@ -3425,7 +3739,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%frazil_tendency_diag = .true. endif - ! if all is working propertly, this diagnostic should equal to hfsifrazil + ! If all is working properly, this diagnostic should equal to hfsifrazil. CS%id_frazil_heat_tend_2d = register_diag_field('ocean_model',& 'frazil_heat_tendency_2d', diag%axesT1, Time, & 'Depth integrated heat tendency due to frazil formation', & @@ -3448,12 +3762,19 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di if (CS%use_int_tides) then call int_tide_input_init(Time, G, GV, US, param_file, diag, CS%int_tide_input_CSp, & CS%int_tide_input) - call internal_tides_init(Time, G, GV, US, param_file, diag, CS%int_tide) + call internal_tides_init(Time, G, GV, US, param_file, diag, int_tide_CSp) endif + !if (associated(int_tide_CSp)) CS%int_tide_CSp => int_tide_CSp + + physical_OBL_scheme = (CS%use_bulkmixedlayer .or. CS%use_KPP .or. CS%use_energetic_PBL) ! initialize module for setting diffusivities - call set_diffusivity_init(Time, G, GV, US, param_file, diag, CS%set_diff_CSp, CS%int_tide, & - halo_TS=CS%halo_TS_diff, double_diffuse=CS%double_diffuse) + call set_diffusivity_init(Time, G, GV, US, param_file, diag, CS%set_diff_CSp, CS%int_tide_CSp, & + halo_TS=CS%halo_TS_diff, double_diffuse=CS%double_diffuse, & + physical_OBL_scheme=physical_OBL_scheme) + + CS%halo_diabatic = CS%halo_TS_diff + if (CS%use_int_tides) CS%halo_diabatic = max(CS%halo_TS_diff, 2) if (CS%useKPP .and. (CS%double_diffuse .and. .not.CS%use_CVMix_ddiff)) & call MOM_error(FATAL, 'diabatic_driver_init: DOUBLE_DIFFUSION (old method) does not work '//& @@ -3486,7 +3807,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di if (CS%use_bulkmixedlayer) & call bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS%bulkmixedlayer) if (CS%use_energetic_PBL) & - call energetic_PBL_init(Time, G, GV, US, param_file, diag, CS%energetic_PBL) + call energetic_PBL_init(Time, G, GV, US, param_file, diag, CS%ePBL) call regularize_layers_init(Time, G, GV, param_file, diag, CS%regularize_layers) @@ -3507,11 +3828,46 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di end subroutine diabatic_driver_init +!> Routine to register restarts, pass-through to children modules +subroutine register_diabatic_restarts(G, GV, US, param_file, int_tide_CSp, restart_CSp, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(int_tide_CS), pointer :: int_tide_CSp !< Internal tide control structure + type(MOM_restart_CS), pointer :: restart_CSp !< MOM restart control structure + type(diabatic_CS), pointer :: CS !< module control structure + + logical :: use_int_tides + + if (associated(CS)) then + call MOM_error(WARNING, "diabatic_driver_init called with an "// & + "associated control structure.") + return + else + allocate(CS) + endif + + use_int_tides=.false. + + call read_param(param_file, "INTERNAL_TIDES", use_int_tides) + + if (use_int_tides) then + call register_int_tide_restarts(G, GV, US, param_file, int_tide_CSp, restart_CSp) + endif + + call register_KPP_restarts(G, param_file, restart_CSp, CS%KPP_CSp) + +end subroutine register_diabatic_restarts !> Routine to close the diabatic driver module subroutine diabatic_driver_end(CS) type(diabatic_CS), intent(inout) :: CS !< module control structure + if (associated(CS%VBF)) then + call KdWork_end(CS%VBF) + endif + if (associated(CS%optics)) then call opacity_end(CS%opacity, CS%optics) deallocate(CS%optics) @@ -3521,7 +3877,7 @@ subroutine diabatic_driver_end(CS) call diapyc_energy_req_end(CS%diapyc_en_rec_CSp) if (CS%use_energetic_PBL) & - call energetic_PBL_end(CS%energetic_PBL) + call energetic_PBL_end(CS%ePBL) call diabatic_aux_end(CS%diabatic_aux_CSp) @@ -3532,14 +3888,8 @@ subroutine diabatic_driver_end(CS) if (CS%use_geothermal) & call geothermal_end(CS%geothermal) - if (CS%useKPP) then - deallocate( CS%KPP_buoy_flux ) - deallocate( CS%KPP_temp_flux ) - deallocate( CS%KPP_salt_flux ) - deallocate( CS%KPP_NLTheat ) - deallocate( CS%KPP_NLTscalar ) + if (CS%useKPP) & call KPP_end(CS%KPP_CSp) - endif ! GMM, the following is commented out because arrays in ! CS%diag_grids_prev are neither pointers or allocatables @@ -3577,8 +3927,8 @@ end subroutine diabatic_driver_end !! calculated flux of the layer above and an estimated flux in the !! layer below. This flux is subject to the following conditions: !! (1) the flux in the top and bottom layers are set by the boundary -!! conditions, and (2) no layer may be driven below an Angstrom thick- -!! ness. If there is a bulk mixed layer, the buffer layer is treated +!! conditions, and (2) no layer may be driven below a minimal thickness. +!! If there is a bulk mixed layer, the buffer layer is treated !! as a fixed density layer with vanishingly small diffusivity. !! !! diabatic takes 5 arguments: the two velocities (u and v), the diff --git a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 index 379275196e..a7d4bd71d8 100644 --- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 +++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -1,18 +1,21 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Calculates the energy requirements of mixing. module MOM_diapyc_energy_req -! This file is part of MOM6. See LICENSE.md for the license. - !! \author By Robert Hallberg, May 2015 use MOM_diag_mediator, only : diag_ctrl, Time_type, post_data, register_diag_field +use MOM_EOS, only : calculate_specific_vol_derivs, calculate_density use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_grid, only : ocean_grid_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_specific_vol_derivs, calculate_density +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -27,8 +30,9 @@ module MOM_diapyc_energy_req type, public :: diapyc_energy_req_CS ; private logical :: initialized = .false. !< A variable that is here because empty !! structures are not permitted by some compilers. - real :: test_Kh_scaling !< A scaling factor for the diapycnal diffusivity. - real :: ColHt_scaling !< A scaling factor for the column height change correction term. + real :: test_Kh_scaling !< A scaling factor for the diapycnal diffusivity [nondim] + real :: ColHt_scaling !< A scaling factor for the column height change correction term [nondim] + real :: VonKar !< The von Karman coefficient as used in this module [nondim] logical :: use_test_Kh_profile !< If true, use the internal test diffusivity profile in place of !! any that might be passed in as an argument. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to @@ -58,19 +62,26 @@ subroutine diapyc_energy_req_test(h_3d, dt, tv, G, GV, US, CS, Kd_int) real, intent(in) :: dt !< The amount of time covered by this call [T ~> s]. type(diapyc_energy_req_CS), pointer :: CS !< This module's control structure. real, dimension(G%isd:G%ied,G%jsd:G%jed,GV%ke+1), & - optional, intent(in) :: Kd_int !< Interface diffusivities [Z2 T-1 ~> m2 s-1]. + optional, intent(in) :: Kd_int !< Interface diffusivities [H Z T-1 ~> m2 s-1 or kg m-1 s-1] ! Local variables real, dimension(GV%ke) :: & - T0, S0, & ! T0 & S0 are columns of initial temperatures and salinities [degC] and g/kg. - h_col ! h_col is a column of thicknesses h at tracer points [H ~> m or kg m-2]. + T0, S0, & ! T0 & S0 are columns of initial temperatures and salinities [C ~> degC] and [S ~> ppt]. + h_col, & ! h_col is a column of thicknesses h at tracer points [H ~> m or kg m-2]. + dz_col ! dz_col is a column of vertical distances across layers at tracer points [Z ~> m] + real, dimension( G%isd:G%ied,GV%ke) :: & + dz_2d ! A 2-d slice of the vertical distance across layers [Z ~> m] real, dimension(GV%ke+1) :: & - Kd, & ! A column of diapycnal diffusivities at interfaces [Z2 T-1 ~> m2 s-1]. + Kd, & ! A column of diapycnal diffusivities at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. h_top, h_bot ! Distances from the top or bottom [H ~> m or kg m-2]. - real :: ustar, absf, htot + real :: dz_h_int ! The ratio of the vertical distances across the layers surrounding an interface + ! over the layer thicknesses [H Z-1 ~> nondim or kg m-3] + real :: ustar ! The local friction velocity [Z T-1 ~> m s-1] + real :: absf ! The absolute value of the Coriolis parameter [T-1 ~> s-1] + real :: htot ! The sum of the thicknesses [H ~> m or kg m-2]. real :: energy_Kd ! The energy used by diapycnal mixing [R Z L2 T-3 ~> W m-2]. - real :: tmp1 ! A temporary array. - integer :: i, j, k, is, ie, js, je, nz, itt + real :: tmp1 ! A temporary array [H2 ~> m2 or kg2 m-4] + integer :: i, j, k, is, ie, js, je, nz logical :: may_print is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -81,36 +92,56 @@ subroutine diapyc_energy_req_test(h_3d, dt, tv, G, GV, US, CS, Kd_int) "Module must be initialized before it is used.") !$OMP do - do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then - if (present(Kd_int) .and. .not.CS%use_test_Kh_profile) then - do k=1,nz+1 ; Kd(K) = CS%test_Kh_scaling*Kd_int(i,j,K) ; enddo - else - htot = 0.0 ; h_top(1) = 0.0 + do j=js,je + call thickness_to_dz(h_3d, tv, dz_2d, j, G, GV) + + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + do k=1,nz T0(k) = tv%T(i,j,k) ; S0(k) = tv%S(i,j,k) h_col(k) = h_3d(i,j,k) - h_top(K+1) = h_top(K) + h_col(k) - enddo - htot = h_top(nz+1) - h_bot(nz+1) = 0.0 - do k=nz,1,-1 - h_bot(K) = h_bot(K+1) + h_col(k) + dz_col(k) = dz_2d(i,k) enddo - ustar = 0.01*US%m_to_Z*US%T_to_s ! Change this to being an input parameter? - absf = 0.25*((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & - (abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J)))) - Kd(1) = 0.0 ; Kd(nz+1) = 0.0 - do K=2,nz - tmp1 = h_top(K) * h_bot(K) * GV%H_to_Z - Kd(K) = CS%test_Kh_scaling * & - ustar * 0.41 * (tmp1*ustar) / (absf*tmp1 + htot*ustar) - enddo - endif - may_print = is_root_PE() .and. (i==ie) .and. (j==je) - call diapyc_energy_req_calc(h_col, T0, S0, Kd, energy_Kd, dt, tv, G, GV, US, & - may_print=may_print, CS=CS) - endif ; enddo ; enddo + if (present(Kd_int) .and. .not.CS%use_test_Kh_profile) then + do k=1,nz+1 ; Kd(K) = CS%test_Kh_scaling*Kd_int(i,j,K) ; enddo + else + htot = 0.0 ; h_top(1) = 0.0 + do k=1,nz + h_top(K+1) = h_top(K) + h_col(k) + enddo + htot = h_top(nz+1) + + h_bot(nz+1) = 0.0 + do k=nz,1,-1 + h_bot(K) = h_bot(K+1) + h_col(k) + enddo + + ustar = 0.01*US%m_to_Z*US%T_to_s ! Change this to being an input parameter? + absf = 0.25*((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & + (abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J)))) + Kd(1) = 0.0 ; Kd(nz+1) = 0.0 + if (GV%Boussinesq) then + do K=2,nz + tmp1 = h_top(K) * h_bot(K) + Kd(K) = CS%test_Kh_scaling * & + ustar * CS%VonKar * (tmp1*ustar) / (absf*GV%H_to_Z*tmp1 + htot*ustar) + enddo + else + do K=2,nz + tmp1 = h_top(K) * h_bot(K) + dz_h_int = (dz_2d(j,k-1) + dz_2d(j,k) + GV%dz_subroundoff) / & + (h_3d(i,j,k-1) + h_3d(i,j,k) + GV%H_subroundoff) + Kd(K) = CS%test_Kh_scaling * & + ustar * CS%VonKar * (tmp1*ustar) / (dz_h_int*absf*tmp1 + htot*ustar) + enddo + endif + endif + may_print = is_root_PE() .and. (i==ie) .and. (j==je) + call diapyc_energy_req_calc(h_col, dz_col, T0, S0, Kd, energy_Kd, dt, tv, G, GV, US, & + may_print=may_print, CS=CS) + endif ; enddo + enddo end subroutine diapyc_energy_req_test @@ -120,17 +151,19 @@ end subroutine diapyc_energy_req_test !! 4 different ways, all of which should be equivalent, but reports only one. !! The various estimates are taken because they will later be used as templates !! for other bits of code -subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & +subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv, & G, GV, US, may_print, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(GV%ke), intent(in) :: h_in !< Layer thickness before entrainment, - !! [H ~> m or kg m-2]. - real, dimension(GV%ke), intent(in) :: T_in !< The layer temperatures [degC]. - real, dimension(GV%ke), intent(in) :: S_in !< The layer salinities [ppt]. + !! [H ~> m or kg m-2] + real, dimension(GV%ke), intent(in) :: dz_in !< Vertical distance across layers before + !! entrainment [Z ~> m] + real, dimension(GV%ke), intent(in) :: T_in !< The layer temperatures [C ~> degC]. + real, dimension(GV%ke), intent(in) :: S_in !< The layer salinities [S ~> ppt]. real, dimension(GV%ke+1), intent(in) :: Kd !< The interfaces diapycnal diffusivities - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real, intent(in) :: dt !< The amount of time covered by this call [T ~> s]. real, intent(out) :: energy_Kd !< The column-integrated rate of energy !! consumption by diapycnal diffusion [R Z L2 T-3 ~> W m-2]. @@ -151,42 +184,50 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & real, dimension(GV%ke) :: & p_lay, & ! Average pressure of a layer [R L2 T-2 ~> Pa]. - dSV_dT, & ! Partial derivative of specific volume with temperature [R-1 degC-1 ~> m3 kg-1 degC-1]. - dSV_dS, & ! Partial derivative of specific volume with salinity [R-1 ppt-1 ~> m3 kg-1 ppt-1]. - T0, S0, & ! Initial temperatures and salinities [degC] and [ppt]. - Te, Se, & ! Running incomplete estimates of the new temperatures and salinities [degC] and [ppt]. - Te_a, Se_a, & ! Running incomplete estimates of the new temperatures and salinities [degC] and [ppt]. - Te_b, Se_b, & ! Running incomplete estimates of the new temperatures and salinities [degC] and [ppt]. - Tf, Sf, & ! New final values of the temperatures and salinities [degC] and [ppt]. - dTe, dSe, & ! Running (1-way) estimates of temperature and salinity change [degC] and [ppt]. - dTe_a, dSe_a, & ! Running (1-way) estimates of temperature and salinity change [degC] and [ppt]. - dTe_b, dSe_b, & ! Running (1-way) estimates of temperature and salinity change [degC] and [ppt]. + dSV_dT, & ! Partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1]. + dSV_dS, & ! Partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. + T0, S0, & ! Initial temperatures and salinities [C ~> degC] and [S ~> ppt]. + Tf, Sf, & ! New final values of the temperatures and salinities [C ~> degC] and [S ~> ppt]. Th_a, & ! An effective temperature times a thickness in the layer above, including implicit - ! mixing effects with other yet higher layers [degC H ~> degC m or degC kg m-2]. + ! mixing effects with other yet higher layers [C H ~> degC m or degC kg m-2]. Sh_a, & ! An effective salinity times a thickness in the layer above, including implicit - ! mixing effects with other yet higher layers [ppt H ~> ppt m or ppt kg m-2]. + ! mixing effects with other yet higher layers [S H ~> ppt m or ppt kg m-2]. Th_b, & ! An effective temperature times a thickness in the layer below, including implicit - ! mixing effects with other yet lower layers [degC H ~> degC m or degC kg m-2]. + ! mixing effects with other yet lower layers [C H ~> degC m or degC kg m-2]. Sh_b, & ! An effective salinity times a thickness in the layer below, including implicit - ! mixing effects with other yet lower layers [ppt H ~> ppt m or ppt kg m-2]. - dT_to_dPE, & ! Partial derivative of column potential energy with the temperature and salinity - dS_to_dPE, & ! changes within a layer [R Z L2 T-2 degC-1 ~> J m-2 degC-1] and [R Z L2 T-2 ppt-1 ~> J m-2 ppt-1]. - dT_to_dColHt, & ! Partial derivatives of the total column height with the temperature - dS_to_dColHt, & ! and salinity changes within a layer [Z degC-1 ~> m degC-1] and [Z ppt-1 ~> m ppt-1]. - dT_to_dColHt_a, & ! Partial derivatives of the total column height with the temperature - dS_to_dColHt_a, & ! and salinity changes within a layer, including the implicit effects - ! of mixing with layers higher in the water colun [Z degC-1 ~> m degC-1] and [Z ppt-1 ~> m ppt-1]. - dT_to_dColHt_b, & ! Partial derivatives of the total column height with the temperature - dS_to_dColHt_b, & ! and salinity changes within a layer, including the implicit effects - ! of mixing with layers lower in the water colun [Z degC-1 ~> m degC-1] and [Z ppt-1 ~> m ppt-1]. - dT_to_dPE_a, & ! Partial derivatives of column potential energy with the temperature - dS_to_dPE_a, & ! and salinity changes within a layer, including the implicit effects - ! of mixing with layers higher in the water column, in - ! units of [R Z L2 T-2 degC-1 ~> J m-2 degC-1] and [R Z L2 T-2 ppt-1 ~> J m-2 ppt-1]. - dT_to_dPE_b, & ! Partial derivatives of column potential energy with the temperature - dS_to_dPE_b, & ! and salinity changes within a layer, including the implicit effects - ! of mixing with layers lower in the water column, in - ! units of [R Z L2 T-2 degC-1 ~> J m-2 degC-1] and [R Z L2 T-2 ppt-1 ~> J m-2 ppt-1]. + ! mixing effects with other yet lower layers [S H ~> ppt m or ppt kg m-2]. + dT_to_dPE, & ! Partial derivative of column potential energy with the temperature changes within + ! a layer [R Z L2 T-2 C-1 ~> J m-2 degC-1] + dS_to_dPE, & ! Partial derivative of column potential energy with the salinity changes within + ! a layer [R Z L2 T-2 S-1 ~> J m-2 ppt-1] + dT_to_dColHt, & ! Partial derivative of the total column height with the temperature + ! changes within a layer [Z C-1 ~> m degC-1] + dS_to_dColHt, & ! Partial derivative of the total column height with the + ! salinity changes within a layer [Z S-1 ~> m ppt-1]. + dT_to_dColHt_a, & ! Partial derivative of the total column height with the temperature changes + ! within a layer, including the implicit effects of mixing with layers higher + ! in the water column [Z C-1 ~> m degC-1]. + dS_to_dColHt_a, & ! Partial derivative of the total column height with the salinity changes + ! within a layer, including the implicit effects of mixing with layers higher + ! of mixing with layers higher in the water column [Z S-1 ~> m ppt-1]. + dT_to_dColHt_b, & ! Partial derivative of the total column height with the temperature changes + ! within a layer, including the implicit effects of mixing with layers lower + ! in the water column [Z C-1 ~> m degC-1]. + dS_to_dColHt_b, & ! Partial derivative of the total column height with the salinity changes + ! within a layer, including the implicit effects of mixing with layers lower + ! in the water column [Z S-1 ~> m ppt-1]. + dT_to_dPE_a, & ! Partial derivative of column potential energy with the temperature changes + ! within a layer, including the implicit effects of mixing with layers higher + ! in the water column, in units of [R Z L2 T-2 C-1 ~> J m-2 degC-1]. + dS_to_dPE_a, & ! Partial derivative of column potential energy with the salinity changes + ! within a layer, including the implicit effects of mixing with layers higher + ! in the water column, in units of [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. + dT_to_dPE_b, & ! Partial derivative of column potential energy with the temperature changes + ! within a layer, including the implicit effects of mixing with layers lower + ! in the water column, in units of [R Z L2 T-2 C-1 ~> J m-2 degC-1]. + dS_to_dPE_b, & ! Partial derivative of column potential energy with the salinity changes + ! within a layer, including the implicit effects of mixing with layers lower + ! in the water column, in units of [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. hp_a, & ! An effective pivot thickness of the layer including the effects ! of coupling with layers above [H ~> m or kg m-2]. This is the first term ! in the denominator of b1 in a downward-oriented tridiagonal solver. @@ -195,8 +236,18 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & ! in the denominator of b1 in an upward-oriented tridiagonal solver. c1_a, & ! c1_a is used by a downward-oriented tridiagonal solver [nondim]. c1_b, & ! c1_b is used by an upward-oriented tridiagonal solver [nondim]. - h_tr ! h_tr is h at tracer points with a h_neglect added to + h_tr, & ! h_tr is h at tracer points with a h_neglect added to ! ensure positive definiteness [H ~> m or kg m-2]. + dz_tr ! dz_tr is dz at tracer points with dz_neglect added to + ! ensure positive definiteness [Z ~> m] + ! Note that the following arrays have extra (ficticious) layers above or below the + ! water column for code convenience + real, dimension(0:GV%ke+1) :: & + Te, Se ! Running incomplete estimates of the new temperatures and salinities [C ~> degC] and [S ~> ppt] + real, dimension(0:GV%ke) :: & + Te_a, Se_a ! Running incomplete estimates of the new temperatures and salinities [C ~> degC] and [S ~> ppt] + real, dimension(GV%ke+1) :: & + Te_b, Se_b ! Running incomplete estimates of the new temperatures and salinities [C ~> degC] and [S ~> ppt] real, dimension(GV%ke+1) :: & pres, & ! Interface pressures [R L2 T-2 ~> Pa]. pres_Z, & ! The hydrostatic interface pressure, which is used to relate @@ -218,52 +269,48 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & ! accumulating the diffusivities [R Z L2 T-2 ~> J m-2]. ColHt_cor_k ! The correction to the potential energy change due to ! changes in the net column height [R Z L2 T-2 ~> J m-2]. - real :: & - b1 ! b1 is used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. - real :: & - I_b1 ! The inverse of b1 [H ~> m or kg m-2]. + real :: b1 ! b1 is used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. real :: Kd0 ! The value of Kddt_h that has already been applied [H ~> m or kg m-2]. real :: dKd ! The change in the value of Kddt_h [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. - real :: dTe_term ! A diffusivity-independent term related to the temperature - ! change in the layer below the interface [degC H ~> degC m or degC kg m-2]. - real :: dSe_term ! A diffusivity-independent term related to the salinity - ! change in the layer below the interface [ppt H ~> ppt m or ppt kg m-2]. real :: Kddt_h_guess ! A guess of the final value of Kddt_h [H ~> m or kg m-2]. real :: dMass ! The mass per unit area within a layer [R Z ~> kg m-2]. real :: dPres ! The hydrostatic pressure change across a layer [R L2 T-2 ~> Pa]. - real :: dMKE_max ! The maximum amount of mean kinetic energy that could be - ! converted to turbulent kinetic energy if the velocity in - ! the layer below an interface were homogenized with all of - ! the water above the interface [R Z L2 T-2 ~> J m-2 = kg s-2]. real :: rho_here ! The in-situ density [R ~> kg m-3]. real :: PE_change ! The change in column potential energy from applying Kddt_h at the ! present interface [R L2 Z T-2 ~> J m-2]. real :: ColHt_cor ! The correction to PE_chg that is made due to a net ! change in the column height [R L2 Z T-2 ~> J m-2]. real :: htot ! A running sum of thicknesses [H ~> m or kg m-2]. - real :: dTe_t2, dT_km1_t2, dT_k_t2 ! Temporary arrays describing temperature changes [degC]. - real :: dSe_t2, dS_km1_t2, dS_k_t2 ! Temporary arrays describing salinity changes [ppt]. + real :: dztot ! A running sum of vertical distances across layers [Z ~> m] logical :: do_print ! The following are a bunch of diagnostic arrays for debugging purposes. real, dimension(GV%ke) :: & - Ta, Sa, Tb, Sb + Ta, Tb, & ! Copies of temperature profiles for debugging [C ~> degC] + Sa, Sb ! Copies of salinity profiles for debugging [S ~> ppt] real, dimension(GV%ke+1) :: & - dPEa_dKd, dPEa_dKd_est, dPEa_dKd_err, dPEa_dKd_trunc, dPEa_dKd_err_norm, & - dPEb_dKd, dPEb_dKd_est, dPEb_dKd_err, dPEb_dKd_trunc, dPEb_dKd_err_norm - real :: PE_chg_tot1A, PE_chg_tot2A, T_chg_totA - real :: PE_chg_tot1B, PE_chg_tot2B, T_chg_totB - real :: PE_chg_tot1C, PE_chg_tot2C, T_chg_totC - real :: PE_chg_tot1D, PE_chg_tot2D, T_chg_totD - real, dimension(GV%ke+1) :: dPEchg_dKd - real :: PE_chg(6) - real, dimension(6) :: dT_k_itt, dS_k_itt, dT_km1_itt, dS_km1_itt - - integer :: k, nz, itt, max_itt, k_cent + dPEa_dKd, dPEa_dKd_est, & ! Estimates of the partial derivative of the column potential energy + ! change with Kddt_h [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. + dPEb_dKd, dPEb_dKd_est, & ! Estimates of the partial derivative of the column potential energy + ! change with Kddt_h [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. + dPEa_dKd_err, dPEb_dKd_err, & ! Differences in estimates of the partial derivative of the column + ! potential energy change with Kddt_h [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. + dPEa_dKd_err_norm, dPEb_dKd_err_norm, & ! Normalized changes in sensitivities [nondim] + dPEa_dKd_trunc, dPEb_dKd_trunc ! Estimates of the truncation error in estimates of the partial + ! derivative of the column potential energy change with + ! Kddt_h [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. + real :: PE_chg_tot1A, PE_chg_tot2A ! Changes in column potential energy [R Z L2 T-2 ~> J m-2] + real :: PE_chg_tot1B, PE_chg_tot2B ! Changes in column potential energy [R Z L2 T-2 ~> J m-2] + real :: PE_chg_tot1C, PE_chg_tot2C ! Changes in column potential energy [R Z L2 T-2 ~> J m-2] + real :: PE_chg_tot1D, PE_chg_tot2D ! Changes in column potential energy [R Z L2 T-2 ~> J m-2] + real :: T_chg_totA, T_chg_totB ! Vertically integrated temperature changes [C H ~> degC m or degC kg m-2] + real :: T_chg_totC, T_chg_totD ! Vertically integrated temperature changes [C H ~> degC m or degC kg m-2] + real :: PE_chg(6) ! The potential energy change within the first few iterations [R Z L2 T-2 ~> J m-2] + + integer :: k, nz, itt, k_cent logical :: surface_BL, bottom_BL, central, halves, debug - logical :: old_PE_calc nz = GV%ke h_neglect = GV%H_subroundoff @@ -279,11 +326,13 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & dPEb_dKd(:) = 0.0 ; dPEb_dKd_est(:) = 0.0 ; dPEb_dKd_err(:) = 0.0 dPEb_dKd_err_norm(:) = 0.0 ; dPEb_dKd_trunc(:) = 0.0 - htot = 0.0 ; pres(1) = 0.0 ; pres_Z(1) = 0.0 ; Z_int(1) = 0.0 + htot = 0.0 ; dztot = 0.0 ; pres(1) = 0.0 ; pres_Z(1) = 0.0 ; Z_int(1) = 0.0 do k=1,nz T0(k) = T_in(k) ; S0(k) = S_in(k) h_tr(k) = h_in(k) + dz_tr(k) = dz_in(k) htot = htot + h_tr(k) + dztot = dztot + dz_tr(k) pres(K+1) = pres(K) + (GV%g_Earth * GV%H_to_RZ) * h_tr(k) pres_Z(K+1) = pres(K+1) p_lay(k) = 0.5*(pres(K) + pres(K+1)) @@ -291,15 +340,23 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & enddo do k=1,nz h_tr(k) = max(h_tr(k), 1e-15*htot) + dz_tr(k) = max(dz_tr(k), 1e-15*dztot) enddo ! Introduce a diffusive flux variable, Kddt_h(K) = ea(k) = eb(k-1) Kddt_h(1) = 0.0 ; Kddt_h(nz+1) = 0.0 do K=2,nz - Kddt_h(K) = min((GV%Z_to_H**2*dt)*Kd(k) / (0.5*(h_tr(k-1) + h_tr(k))), 1e3*htot) + Kddt_h(K) = min(dt * Kd(k) / (0.5*(dz_tr(k-1) + dz_tr(k))), 1e3*dztot) enddo + ! Zero out the temperature and salinity estimates in the extra (ficticious) layers. + ! The actual values set here are irrelevant (so long as they are not NaNs) because they + ! are always multiplied by a zero value of Kddt_h reflecting the no-flux boundary condition. + Te(0) = 0.0 ; Se(0) = 0.0 ; Te(nz+1) = 0.0 ; Se(nz+1) = 0.0 + Te_a(0) = 0.0 ; Se_a(0) = 0.0 + Te_b(nz+1) = 0.0 ; Se_b(nz+1) = 0.0 + ! Solve the tridiagonal equations for new temperatures. call calculate_specific_vol_derivs(T0, S0, p_lay, dSV_dT, dSV_dS, tv%eqn_of_state) @@ -316,10 +373,8 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & ! PE_chg_k(1) = 0.0 ; PE_chg_k(nz+1) = 0.0 ! PEchg(:) = 0.0 PE_chg_k(:,:) = 0.0 ; ColHt_cor_k(:,:) = 0.0 - dPEchg_dKd(:) = 0.0 if (surface_BL) then ! This version is appropriate for a surface boundary layer. - old_PE_calc = .false. ! Set up values appropriate for no diffusivity. do k=1,nz @@ -335,71 +390,32 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & ! on how much energy is available. ! Precalculate some temporary expressions that are independent of Kddt_h_guess. - if (old_PE_calc) then - if (K==2) then - dT_km1_t2 = (T0(k)-T0(k-1)) - dS_km1_t2 = (S0(k)-S0(k-1)) - dTe_t2 = 0.0 ; dSe_t2 = 0.0 - else - dTe_t2 = Kddt_h(K-1) * ((T0(k-2) - T0(k-1)) + dTe(k-2)) - dSe_t2 = Kddt_h(K-1) * ((S0(k-2) - S0(k-1)) + dSe(k-2)) - dT_km1_t2 = (T0(k)-T0(k-1)) - & - (Kddt_h(K-1) / hp_a(k-1)) * ((T0(k-2) - T0(k-1)) + dTe(k-2)) - dS_km1_t2 = (S0(k)-S0(k-1)) - & - (Kddt_h(K-1) / hp_a(k-1)) * ((S0(k-2) - S0(k-1)) + dSe(k-2)) - endif - dTe_term = dTe_t2 + hp_a(k-1) * (T0(k-1)-T0(k)) - dSe_term = dSe_t2 + hp_a(k-1) * (S0(k-1)-S0(k)) - else - if (K<=2) then - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) - else - Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te(k-2) - Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se(k-2) - endif - Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) - endif + Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te(k-2) + Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se(k-2) + Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) ! Find the energy change due to a guess at the strength of diffusion at interface K. Kddt_h_guess = Kddt_h(K) - if (old_PE_calc) then - call find_PE_chg_orig(Kddt_h_guess, h_tr(k), hp_a(k-1), & - dTe_term, dSe_term, dT_km1_t2, dS_km1_t2, & - dT_to_dPE(k), dS_to_dPE(k), dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), & - pres_Z(K), dT_to_dColHt(k), dS_to_dColHt(k), & - dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - PE_chg_k(k,1), dPEa_dKd(k)) - else - call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & - Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & - dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_chg_k(K,1), dPEc_dKd=dPEa_dKd(K), & - ColHt_cor=ColHt_cor_k(K,1)) - endif + call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt_b(k), dS_to_dColHt_b(k), & + PE_chg=PE_chg_k(K,1), dPEc_dKd=dPEa_dKd(K), & + PE_ColHt_cor=ColHt_cor_k(K,1)) if (debug) then do itt=1,5 Kddt_h_guess = (1.0+0.01*(itt-3))*Kddt_h(K) - if (old_PE_calc) then - call find_PE_chg_orig(Kddt_h_guess, h_tr(k), hp_a(k-1), & - dTe_term, dSe_term, dT_km1_t2, dS_km1_t2, & - dT_to_dPE(k), dS_to_dPE(k), dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), & - pres_Z(K), dT_to_dColHt(k), dS_to_dColHt(k), & - dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - PE_chg=PE_chg(itt)) - else - call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & - Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & - dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_chg(itt)) - endif + call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt_b(k), dS_to_dColHt_b(k), & + PE_chg=PE_chg(itt)) enddo ! Compare with a 4th-order finite difference estimate. dPEa_dKd_est(k) = (4.0*(PE_chg(4)-Pe_chg(2))/(0.02*Kddt_h(K)) - & @@ -416,17 +432,8 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & b1 = 1.0 / (hp_a(k-1) + Kddt_h(K)) c1_a(K) = Kddt_h(K) * b1 - if (k==2) then - Te(1) = b1*(h_tr(1)*T0(1)) - Se(1) = b1*(h_tr(1)*S0(1)) - else - Te(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te(k-2)) - Se(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se(k-2)) - endif - if (old_PE_calc) then - dTe(k-1) = b1 * ( Kddt_h(K)*(T0(k)-T0(k-1)) + dTe_t2 ) - dSe(k-1) = b1 * ( Kddt_h(K)*(S0(k)-S0(k-1)) + dSe_t2 ) - endif + Te(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te(k-2)) + Se(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se(k-2)) hp_a(k) = h_tr(k) + (hp_a(k-1) * b1) * Kddt_h(K) dT_to_dPE_a(k) = dT_to_dPE(k) + c1_a(K)*dT_to_dPE_a(k-1) @@ -439,10 +446,6 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & b1 = 1.0 / (hp_a(nz)) Tf(nz) = b1 * (h_tr(nz) * T0(nz) + Kddt_h(nz) * Te(nz-1)) Sf(nz) = b1 * (h_tr(nz) * S0(nz) + Kddt_h(nz) * Se(nz-1)) - if (old_PE_calc) then - dTe(nz) = b1 * Kddt_h(nz) * ((T0(nz-1)-T0(nz)) + dTe(nz-1)) - dSe(nz) = b1 * Kddt_h(nz) * ((S0(nz-1)-S0(nz)) + dSe(nz-1)) - endif do k=nz-1,1,-1 Tf(k) = Te(k) + c1_a(K+1)*Tf(k+1) @@ -465,7 +468,6 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & endif if (bottom_BL) then ! This version is appropriate for a bottom boundary layer. - old_PE_calc = .false. ! Set up values appropriate for no diffusivity. do k=1,nz @@ -481,71 +483,32 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & ! on how much energy is available. ! Precalculate some temporary expressions that are independent of Kddt_h_guess. - if (old_PE_calc) then - if (K==nz) then - dT_k_t2 = (T0(k-1)-T0(k)) - dS_k_t2 = (S0(k-1)-S0(k)) - dTe_t2 = 0.0 ; dSe_t2 = 0.0 - else - dTe_t2 = Kddt_h(K+1) * ((T0(k+1) - T0(k)) + dTe(k+1)) - dSe_t2 = Kddt_h(K+1) * ((S0(k+1) - S0(k)) + dSe(k+1)) - dT_k_t2 = (T0(k-1)-T0(k)) - & - (Kddt_h(k+1)/ hp_b(k)) * ((T0(k+1) - T0(k)) + dTe(k+1)) - dS_k_t2 = (S0(k-1)-S0(k)) - & - (Kddt_h(k+1)/ hp_b(k)) * ((S0(k+1) - S0(k)) + dSe(k+1)) - endif - dTe_term = dTe_t2 + hp_b(k) * (T0(k)-T0(k-1)) - dSe_term = dSe_t2 + hp_b(k) * (S0(k)-S0(k-1)) - else - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) - if (K>=nz) then - Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) - else - Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te(k+1) - Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(k+1) * Se(k+1) - endif - endif + Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te(k+1) + Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(K+1) * Se(k+1) ! Find the energy change due to a guess at the strength of diffusion at interface K. Kddt_h_guess = Kddt_h(K) - if (old_PE_calc) then - call find_PE_chg_orig(Kddt_h_guess, h_tr(k-1), hp_b(k), & - dTe_term, dSe_term, dT_k_t2, dS_k_t2, & - dT_to_dPE(k-1), dS_to_dPE(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres_Z(K), dT_to_dColHt(k-1), dS_to_dColHt(k-1), & - dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_chg_k(K,2), dPEc_dKd=dPEb_dKd(K)) - else - call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & - Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & - dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_chg_k(K,2), dPEc_dKd=dPEb_dKd(K), & - ColHt_cor=ColHt_cor_k(K,2)) - endif + call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt_b(k), dS_to_dColHt_b(k), & + PE_chg=PE_chg_k(K,2), dPEc_dKd=dPEb_dKd(K), & + PE_ColHt_cor=ColHt_cor_k(K,2)) if (debug) then ! Compare with a 4th-order finite difference estimate. do itt=1,5 Kddt_h_guess = (1.0+0.01*(itt-3))*Kddt_h(K) - if (old_PE_calc) then - call find_PE_chg_orig(Kddt_h_guess, h_tr(k-1), hp_b(k), & - dTe_term, dSe_term, dT_k_t2, dS_k_t2, & - dT_to_dPE(k-1), dS_to_dPE(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres_Z(K), dT_to_dColHt(k-1), dS_to_dColHt(k-1), & + call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & PE_chg=PE_chg(itt)) - else - call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & - Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & - dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_chg(itt)) - endif enddo dPEb_dKd_est(k) = (4.0*(PE_chg(4)-Pe_chg(2))/(0.02*Kddt_h(K)) - & @@ -562,17 +525,9 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & b1 = 1.0 / (hp_b(k) + Kddt_h(K)) c1_b(K) = Kddt_h(K) * b1 - if (k==nz) then - Te(nz) = b1* (h_tr(nz)*T0(nz)) - Se(nz) = b1* (h_tr(nz)*S0(nz)) - else - Te(k) = b1 * (h_tr(k) * T0(k) + Kddt_h(K+1) * Te(k+1)) - Se(k) = b1 * (h_tr(k) * S0(k) + Kddt_h(k+1) * Se(k+1)) - endif - if (old_PE_calc) then - dTe(k) = b1 * ( Kddt_h(K)*(T0(k-1)-T0(k)) + dTe_t2 ) - dSe(k) = b1 * ( Kddt_h(K)*(S0(k-1)-S0(k)) + dSe_t2 ) - endif + + Te(k) = b1 * (h_tr(k) * T0(k) + Kddt_h(K+1) * Te(k+1)) + Se(k) = b1 * (h_tr(k) * S0(k) + Kddt_h(K+1) * Se(k+1)) hp_b(k-1) = h_tr(k-1) + (hp_b(k) * b1) * Kddt_h(K) dT_to_dPE_b(k-1) = dT_to_dPE(k-1) + c1_b(K)*dT_to_dPE_b(k) @@ -585,10 +540,6 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & b1 = 1.0 / (hp_b(1)) Tf(1) = b1 * (h_tr(1) * T0(1) + Kddt_h(2) * Te(2)) Sf(1) = b1 * (h_tr(1) * S0(1) + Kddt_h(2) * Se(2)) - if (old_PE_calc) then - dTe(1) = b1 * Kddt_h(2) * ((T0(2)-T0(1)) + dTe(2)) - dSe(1) = b1 * Kddt_h(2) * ((S0(2)-S0(1)) + dSe(2)) - endif do k=2,nz Tf(k) = Te(k) + c1_b(K)*Tf(k-1) @@ -626,12 +577,9 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & do K=2,nz ! Loop over interior interfaces. ! First calculate some terms that are independent of the change in Kddt_h(K). Kd0 = 0.0 ! This might need to be changed - it is the already applied value of Kddt_h(K). - if (K<=2) then - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) - else - Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) - Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) - endif + + Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) + Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) Kddt_h_a(K) = 0.0 ; if (K < K_cent) Kddt_h_a(K) = Kddt_h(K) @@ -642,19 +590,15 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_change, ColHt_cor=ColHt_cor) + PE_chg=PE_change, PE_ColHt_cor=ColHt_cor) PE_chg_k(K,3) = PE_change ColHt_cor_k(K,3) = ColHt_cor b1 = 1.0 / (hp_a(k-1) + Kddt_h_a(K)) c1_a(K) = Kddt_h_a(K) * b1 - if (k==2) then - Te_a(1) = b1*(h_tr(1)*T0(1)) - Se_a(1) = b1*(h_tr(1)*S0(1)) - else - Te_a(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kddt_h_a(K-1) * Te_a(k-2)) - Se_a(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kddt_h_a(K-1) * Se_a(k-2)) - endif + + Te_a(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kddt_h_a(K-1) * Te_a(k-2)) + Se_a(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kddt_h_a(K-1) * Se_a(k-2)) hp_a(k) = h_tr(k) + (hp_a(k-1) * b1) * Kddt_h_a(K) dT_to_dPE_a(k) = dT_to_dPE(k) + c1_a(K)*dT_to_dPE_a(k-1) @@ -668,18 +612,13 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & do K=nz,2,-1 ! Loop over interior interfaces. ! First calculate some terms that are independent of the change in Kddt_h(K). Kd0 = 0.0 ! This might need to be changed - it is the already applied value of Kddt_h(K). -! if (K<=2) then - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) -! else -! Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) -! Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) -! endif - if (K>=nz) then - Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) - else - Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te_b(k+1) - Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(k+1) * Se_b(k+1) - endif + + Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) +! Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) +! Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) + + Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te_b(k+1) + Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(K+1) * Se_b(k+1) Kddt_h_b(K) = 0.0 ; if (K > K_cent) Kddt_h_b(K) = Kddt_h(K) dKd = Kddt_h_b(K) @@ -689,19 +628,15 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_change, ColHt_cor=ColHt_cor) + PE_chg=PE_change, PE_ColHt_cor=ColHt_cor) PE_chg_k(K,3) = PE_chg_k(K,3) + PE_change ColHt_cor_k(K,3) = ColHt_cor_k(K,3) + ColHt_cor b1 = 1.0 / (hp_b(k) + Kddt_h_b(K)) c1_b(K) = Kddt_h_b(K) * b1 - if (k==nz) then - Te_b(k) = b1 * (h_tr(k)*T0(k)) - Se_b(k) = b1 * (h_tr(k)*S0(k)) - else - Te_b(k) = b1 * (h_tr(k) * T0(k) + Kddt_h_b(K+1) * Te_b(k+1)) - Se_b(k) = b1 * (h_tr(k) * S0(k) + Kddt_h_b(k+1) * Se_b(k+1)) - endif + + Te_b(k) = b1 * (h_tr(k) * T0(k) + Kddt_h_b(K+1) * Te_b(k+1)) + Se_b(k) = b1 * (h_tr(k) * S0(k) + Kddt_h_b(K+1) * Se_b(k+1)) hp_b(k-1) = h_tr(k-1) + (hp_b(k) * b1) * Kddt_h_b(K) dT_to_dPE_b(k-1) = dT_to_dPE(k-1) + c1_b(K)*dT_to_dPE_b(k) @@ -716,18 +651,11 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & ! First calculate some terms that are independent of the change in Kddt_h(K). Kd0 = 0.0 ! This might need to be changed - it is the already applied value of Kddt_h(K). - if (K<=2) then - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) - else - Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) - Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) - endif - if (K>=nz) then - Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) - else - Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te_b(k+1) - Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(k+1) * Se_b(k+1) - endif + + Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) + Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) + Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te_b(k+1) + Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(K+1) * Se_b(k+1) dKd = Kddt_h(K) @@ -736,7 +664,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_change, ColHt_cor=ColHt_cor) + PE_chg=PE_change, PE_ColHt_cor=ColHt_cor) PE_chg_k(K,3) = PE_chg_k(K,3) + PE_change ColHt_cor_k(K,3) = ColHt_cor_k(K,3) + ColHt_cor @@ -802,16 +730,12 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & enddo ! Calculate the dependencies on layers above. - Kddt_h_a(1) = 0.0 do K=2,nz ! Loop over interior interfaces. ! First calculate some terms that are independent of the change in Kddt_h(K). Kd0 = Kd_so_far(K) - if (K<=2) then - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) - else - Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2) - Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2) - endif + + Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2) + Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2) Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) dKd = 0.5 * Kddt_h(K) - Kd_so_far(K) @@ -821,7 +745,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_change, ColHt_cor=ColHt_cor) + PE_chg=PE_change, PE_ColHt_cor=ColHt_cor) PE_chg_k(K,4) = PE_change ColHt_cor_k(K,4) = ColHt_cor @@ -830,13 +754,9 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & b1 = 1.0 / (hp_a(k-1) + Kd_so_far(K)) c1_a(K) = Kd_so_far(K) * b1 - if (k==2) then - Te(1) = b1*(h_tr(1)*T0(1)) - Se(1) = b1*(h_tr(1)*S0(1)) - else - Te(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2)) - Se(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2)) - endif + + Te(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2)) + Se(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2)) hp_a(k) = h_tr(k) + (hp_a(k-1) * b1) * Kd_so_far(K) dT_to_dPE_a(k) = dT_to_dPE(k) + c1_a(K)*dT_to_dPE_a(k-1) @@ -849,18 +769,11 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & do K=nz,2,-1 ! Loop over interior interfaces. ! First calculate some terms that are independent of the change in Kddt_h(K). Kd0 = Kd_so_far(K) - if (K<=2) then - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) - else - Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2) - Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2) - endif - if (K>=nz) then - Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) - else - Th_b(k) = h_tr(k) * T0(k) + Kd_so_far(K+1) * Te(k+1) - Sh_b(k) = h_tr(k) * S0(k) + Kd_so_far(k+1) * Se(k+1) - endif + + Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2) + Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2) + Th_b(k) = h_tr(k) * T0(k) + Kd_so_far(K+1) * Te(k+1) + Sh_b(k) = h_tr(k) * S0(k) + Kd_so_far(k+1) * Se(k+1) dKd = Kddt_h(K) - Kd_so_far(K) @@ -869,7 +782,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_change, ColHt_cor=ColHt_cor) + PE_chg=PE_change, PE_ColHt_cor=ColHt_cor) PE_chg_k(K,4) = PE_chg_k(K,4) + PE_change ColHt_cor_k(K,4) = ColHt_cor_k(K,4) + ColHt_cor @@ -879,13 +792,9 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & b1 = 1.0 / (hp_b(k) + Kd_so_far(K)) c1_b(K) = Kd_so_far(K) * b1 - if (k==nz) then - Te(k) = b1 * (h_tr(k)*T0(k)) - Se(k) = b1 * (h_tr(k)*S0(k)) - else - Te(k) = b1 * (h_tr(k) * T0(k) + Kd_so_far(K+1) * Te(k+1)) - Se(k) = b1 * (h_tr(k) * S0(k) + Kd_so_far(k+1) * Se(k+1)) - endif + + Te(k) = b1 * (h_tr(k) * T0(k) + Kd_so_far(K+1) * Te(k+1)) + Se(k) = b1 * (h_tr(k) * S0(k) + Kd_so_far(k+1) * Se(k+1)) hp_b(k-1) = h_tr(k-1) + (hp_b(k) * b1) * Kd_so_far(K) dT_to_dPE_b(k-1) = dT_to_dPE(k-1) + c1_b(K)*dT_to_dPE_b(k) @@ -944,7 +853,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & do K=2,nz call calculate_density(0.5*(T0(k-1) + T0(k)), 0.5*(S0(k-1) + S0(k)), & pres(K), rho_here, tv%eqn_of_state) - N2(K) = ((US%L_to_Z**2*GV%g_Earth) * rho_here / (0.5*GV%H_to_Z*(h_tr(k-1) + h_tr(k)))) * & + N2(K) = (GV%g_Earth_Z_T2 * rho_here / (0.5*(dz_tr(k-1) + dz_tr(k)))) * & ( 0.5*(dSV_dT(k-1) + dSV_dT(k)) * (T0(k-1) - T0(k)) + & 0.5*(dSV_dS(k-1) + dSV_dS(k)) * (S0(k-1) - S0(k)) ) enddo @@ -955,7 +864,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & do K=2,nz call calculate_density(0.5*(Tf(k-1) + Tf(k)), 0.5*(Sf(k-1) + Sf(k)), & pres(K), rho_here, tv%eqn_of_state) - N2(K) = ((US%L_to_Z**2*GV%g_Earth) * rho_here / (0.5*GV%H_to_Z*(h_tr(k-1) + h_tr(k)))) * & + N2(K) = (GV%g_Earth_Z_T2 * rho_here / (0.5*(dz_tr(k-1) + dz_tr(k)))) * & ( 0.5*(dSV_dT(k-1) + dSV_dT(k)) * (Tf(k-1) - Tf(k)) + & 0.5*(dSV_dS(k-1) + dSV_dS(k)) * (Sf(k-1) - Sf(k)) ) enddo @@ -966,11 +875,11 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & end subroutine diapyc_energy_req_calc !> This subroutine calculates the change in potential energy and or derivatives -!! for several changes in an interfaces's diapycnal diffusivity times a timestep. +!! for several changes in an interface's diapycnal diffusivity times a timestep. subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & dT_to_dPE_a, dS_to_dPE_a, dT_to_dPE_b, dS_to_dPE_b, & pres_Z, dT_to_dColHt_a, dS_to_dColHt_a, dT_to_dColHt_b, dS_to_dColHt_b, & - PE_chg, dPEc_dKd, dPE_max, dPEc_dKd_0, ColHt_cor) + PE_chg, dPEc_dKd, dPE_max, dPEc_dKd_0, PE_ColHt_cor) real, intent(in) :: Kddt_h0 !< The previously used diffusivity at an interface times !! the time step and divided by the average of the !! thicknesses around the interface [H ~> m or kg m-2]. @@ -987,79 +896,81 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & !! Kddt_h for the interface above [H ~> m or kg m-2]. real, intent(in) :: Th_a !< An effective temperature times a thickness in the layer !! above, including implicit mixing effects with other - !! yet higher layers [degC H ~> degC m or degC kg m-2]. + !! yet higher layers [C H ~> degC m or degC kg m-2]. real, intent(in) :: Sh_a !< An effective salinity times a thickness in the layer !! above, including implicit mixing effects with other - !! yet higher layers [ppt H ~> ppt m or ppt kg m-2]. + !! yet higher layers [S H ~> ppt m or ppt kg m-2]. real, intent(in) :: Th_b !< An effective temperature times a thickness in the layer !! below, including implicit mixing effects with other - !! yet lower layers [degC H ~> degC m or degC kg m-2]. + !! yet lower layers [C H ~> degC m or degC kg m-2]. real, intent(in) :: Sh_b !< An effective salinity times a thickness in the layer !! below, including implicit mixing effects with other - !! yet lower layers [ppt H ~> ppt m or ppt kg m-2]. + !! yet lower layers [S H ~> ppt m or ppt kg m-2]. real, intent(in) :: dT_to_dPE_a !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating - !! a layer's temperature change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers above [R Z L2 T-2 degC-1 ~> J m-2 degC-1]. + !! a layer's temperature change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! temperatures of all the layers above [R Z L2 T-2 C-1 ~> J m-2 degC-1]. real, intent(in) :: dS_to_dPE_a !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating - !! a layer's salinity change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers above [R Z L2 T-2 ppt-1 ~> J m-2 ppt-1]. + !! a layer's salinity change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! salinities of all the layers above [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. real, intent(in) :: dT_to_dPE_b !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating - !! a layer's temperature change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers below [R Z L2 T-2 degC-1 ~> J m-2 degC-1]. + !! a layer's temperature change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! temperatures of all the layers below [R Z L2 T-2 C-1 ~> J m-2 degC-1]. real, intent(in) :: dS_to_dPE_b !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating - !! a layer's salinity change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers below [R Z L2 T-2 ppt-1 ~> J m-2 ppt-1]. - real, intent(in) :: pres_Z !< The hydrostatic interface pressure, which is used to relate + !! a layer's salinity change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! salinities of all the layers below [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. + real, intent(in) :: pres_Z !< The hydrostatic interface pressure, which relates !! the changes in column thickness to the energy that is radiated !! as gravity waves and unavailable to drive mixing [R L2 T-2 ~> J m-3]. real, intent(in) :: dT_to_dColHt_a !< A factor (mass_lay*dSColHtc_vol/dT) relating !! a layer's temperature change to the change in column !! height, including all implicit diffusive changes - !! in the temperatures of all the layers above [Z degC-1 ~> m degC-1]. + !! in the temperatures of all the layers above [Z C-1 ~> m degC-1]. real, intent(in) :: dS_to_dColHt_a !< A factor (mass_lay*dSColHtc_vol/dS) relating !! a layer's salinity change to the change in column !! height, including all implicit diffusive changes - !! in the salinities of all the layers above [Z ppt-1 ~> m ppt-1]. + !! in the salinities of all the layers above [Z S-1 ~> m ppt-1]. real, intent(in) :: dT_to_dColHt_b !< A factor (mass_lay*dSColHtc_vol/dT) relating !! a layer's temperature change to the change in column !! height, including all implicit diffusive changes - !! in the temperatures of all the layers below [Z degC-1 ~> m degC-1]. + !! in the temperatures of all the layers below [Z C-1 ~> m degC-1]. real, intent(in) :: dS_to_dColHt_b !< A factor (mass_lay*dSColHtc_vol/dS) relating !! a layer's salinity change to the change in column !! height, including all implicit diffusive changes - !! in the salinities of all the layers below [Z ppt-1 ~> m ppt-1]. + !! in the salinities of all the layers below [Z S-1 ~> m ppt-1]. - real, optional, intent(out) :: PE_chg !< The change in column potential energy from applying - !! Kddt_h at the present interface [R Z L2 T-2 ~> J m-2]. + real, intent(out) :: PE_chg !< The change in column potential energy from applying + !! Kddt_h at the present interface [R Z L2 T-2 ~> J m-2]. real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h, !! [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. real, optional, intent(out) :: dPE_max !< The maximum change in column potential energy that could - !! be realizedd by applying a huge value of Kddt_h at the + !! be realized by applying a huge value of Kddt_h at the !! present interface [R Z L2 T-2 ~> J m-2]. real, optional, intent(out) :: dPEc_dKd_0 !< The partial derivative of PE_chg with Kddt_h in the !! limit where Kddt_h = 0 [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. - real, optional, intent(out) :: ColHt_cor !< The correction to PE_chg that is made due to a net + real, optional, intent(out) :: PE_ColHt_cor !< The correction to PE_chg that is made due to a net !! change in the column height [R Z L2 T-2 ~> J m-2]. + ! Local variables real :: hps ! The sum of the two effective pivot thicknesses [H ~> m or kg m-2]. real :: bdt1 ! A product of the two pivot thicknesses plus a diffusive term [H2 ~> m2 or kg2 m-4]. - real :: dT_c ! The core term in the expressions for the temperature changes [degC H2 ~> degC m2 or degC kg2 m-4]. - real :: dS_c ! The core term in the expressions for the salinity changes [psu H2 ~> psu m2 or psu kg2 m-4]. + real :: dT_c ! The core term in the expressions for the temperature changes [C H2 ~> degC m2 or degC kg2 m-4]. + real :: dS_c ! The core term in the expressions for the salinity changes [S H2 ~> ppt m2 or ppt kg2 m-4]. real :: PEc_core ! The diffusivity-independent core term in the expressions - ! for the potential energy changes [R L2 T-2 ~> J m-3]. + ! for the potential energy changes [H3 R Z L2 T-2 ~> J m or J kg3 m-8]. real :: ColHt_core ! The diffusivity-independent core term in the expressions - ! for the column height changes [R L2 T-2 ~> J m-3]. + ! for the column height changes [H3 Z ~> m4 or kg3 m-5]. real :: ColHt_chg ! The change in the column height [Z ~> m]. - real :: y1 ! A local temporary term, in [H-3] or [H-4] in various contexts. + real :: y1_3 ! A local temporary term in [H-3 ~> m-3 or m6 kg-3]. + real :: y1_4 ! A local temporary term in [H-4 ~> m-4 or m8 kg-4]. ! The expression for the change in potential energy used here is derived ! from the expression for the final estimates of the changes in temperature ! and salinities, and then extensively manipulated to get it into its most - ! succint form. The derivation is not necessarily obvious, but it demonstrably + ! succinct form. The derivation is not necessarily obvious, but it demonstrably ! works by comparison with separate calculations of the energy changes after ! the tridiagonal solver for the final changes in temperature and salinity are ! applied. @@ -1073,204 +984,42 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & ColHt_core = hp_b * (dT_to_dColHt_a * dT_c + dS_to_dColHt_a * dS_c) - & hp_a * (dT_to_dColHt_b * dT_c + dS_to_dColHt_b * dS_c) - if (present(PE_chg)) then - ! Find the change in column potential energy due to the change in the - ! diffusivity at this interface by dKddt_h. - y1 = dKddt_h / (bdt1 * (bdt1 + dKddt_h * hps)) - PE_chg = PEc_core * y1 - ColHt_chg = ColHt_core * y1 - if (ColHt_chg < 0.0) PE_chg = PE_chg - pres_Z * ColHt_chg - if (present(ColHt_cor)) ColHt_cor = -pres_Z * min(ColHt_chg, 0.0) - elseif (present(ColHt_cor)) then - y1 = dKddt_h / (bdt1 * (bdt1 + dKddt_h * hps)) - ColHt_cor = -pres_Z * min(ColHt_core * y1, 0.0) - endif + ! Find the change in column potential energy due to the change in the + ! diffusivity at this interface by dKddt_h. + y1_3 = dKddt_h / (bdt1 * (bdt1 + dKddt_h * hps)) + PE_chg = PEc_core * y1_3 + ColHt_chg = ColHt_core * y1_3 + if (ColHt_chg < 0.0) PE_chg = PE_chg - pres_Z * ColHt_chg + + if (present(PE_ColHt_cor)) PE_ColHt_cor = -pres_Z * min(ColHt_chg, 0.0) if (present(dPEc_dKd)) then ! Find the derivative of the potential energy change with dKddt_h. - y1 = 1.0 / (bdt1 + dKddt_h * hps)**2 - dPEc_dKd = PEc_core * y1 - ColHt_chg = ColHt_core * y1 + y1_4 = 1.0 / (bdt1 + dKddt_h * hps)**2 + dPEc_dKd = PEc_core * y1_4 + ColHt_chg = ColHt_core * y1_4 if (ColHt_chg < 0.0) dPEc_dKd = dPEc_dKd - pres_Z * ColHt_chg endif if (present(dPE_max)) then ! This expression is the limit of PE_chg for infinite dKddt_h. - y1 = 1.0 / (bdt1 * hps) - dPE_max = PEc_core * y1 - ColHt_chg = ColHt_core * y1 + y1_3 = 1.0 / (bdt1 * hps) + dPE_max = PEc_core * y1_3 + ColHt_chg = ColHt_core * y1_3 if (ColHt_chg < 0.0) dPE_max = dPE_max - pres_Z * ColHt_chg endif if (present(dPEc_dKd_0)) then ! This expression is the limit of dPEc_dKd for dKddt_h = 0. - y1 = 1.0 / bdt1**2 - dPEc_dKd_0 = PEc_core * y1 - ColHt_chg = ColHt_core * y1 + y1_4 = 1.0 / bdt1**2 + dPEc_dKd_0 = PEc_core * y1_4 + ColHt_chg = ColHt_core * y1_4 if (ColHt_chg < 0.0) dPEc_dKd_0 = dPEc_dKd_0 - pres_Z * ColHt_chg endif end subroutine find_PE_chg -!> This subroutine calculates the change in potential energy and or derivatives -!! for several changes in an interfaces's diapycnal diffusivity times a timestep -!! using the original form used in the first version of ePBL. -subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & - dT_km1_t2, dS_km1_t2, dT_to_dPE_k, dS_to_dPE_k, & - dT_to_dPEa, dS_to_dPEa, pres_Z, dT_to_dColHt_k, & - dS_to_dColHt_k, dT_to_dColHta, dS_to_dColHta, & - PE_chg, dPEc_dKd, dPE_max, dPEc_dKd_0) - real, intent(in) :: Kddt_h !< The diffusivity at an interface times the time step and - !! divided by the average of the thicknesses around the - !! interface [H ~> m or kg m-2]. - real, intent(in) :: h_k !< The thickness of the layer below the interface [H ~> m or kg m-2]. - real, intent(in) :: b_den_1 !< The first term in the denominator of the pivot - !! for the tridiagonal solver, given by h_k plus a term that - !! is a fraction (determined from the tridiagonal solver) of - !! Kddt_h for the interface above [H ~> m or kg m-2]. - real, intent(in) :: dTe_term !< A diffusivity-independent term related to the temperature change - !! in the layer below the interface [degC H ~> degC m or degC kg m-2]. - real, intent(in) :: dSe_term !< A diffusivity-independent term related to the salinity change - !! in the layer below the interface [ppt H ~> ppt m or ppt kg m-2]. - real, intent(in) :: dT_km1_t2 !< A diffusivity-independent term related to the - !! temperature change in the layer above the interface [degC]. - real, intent(in) :: dS_km1_t2 !< A diffusivity-independent term related to the - !! salinity change in the layer above the interface [ppt]. - real, intent(in) :: pres_Z !< The hydrostatic interface pressure, which is used to relate - !! the changes in column thickness to the energy that is radiated - !! as gravity waves and unavailable to drive mixing [R L2 T-2 ~> J m-3]. - real, intent(in) :: dT_to_dPE_k !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating - !! a layer's temperature change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers below [R Z L2 T-2 degC-1 ~> J m-2 degC-1]. - real, intent(in) :: dS_to_dPE_k !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating - !! a layer's salinity change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers below [R Z L2 T-2 ppt-1 ~> J m-2 ppt-1]. - real, intent(in) :: dT_to_dPEa !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating - !! a layer's temperature change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers above [R Z L2 T-2 degC-1 ~> J m-2 degC-1]. - real, intent(in) :: dS_to_dPEa !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating - !! a layer's salinity change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers above [R Z L2 T-2 ppt-1 ~> J m-2 ppt-1]. - real, intent(in) :: dT_to_dColHt_k !< A factor (mass_lay*dSColHtc_vol/dT) relating - !! a layer's temperature change to the change in column - !! height, including all implicit diffusive changes - !! in the temperatures of all the layers below [Z degC-1 ~> m degC-1]. - real, intent(in) :: dS_to_dColHt_k !< A factor (mass_lay*dSColHtc_vol/dS) relating - !! a layer's salinity change to the change in column - !! height, including all implicit diffusive changes - !! in the salinities of all the layers below [Z ppt-1 ~> m ppt-1]. - real, intent(in) :: dT_to_dColHta !< A factor (mass_lay*dSColHtc_vol/dT) relating - !! a layer's temperature change to the change in column - !! height, including all implicit diffusive changes - !! in the temperatures of all the layers above [Z degC-1 ~> m degC-1]. - real, intent(in) :: dS_to_dColHta !< A factor (mass_lay*dSColHtc_vol/dS) relating - !! a layer's salinity change to the change in column - !! height, including all implicit diffusive changes - !! in the salinities of all the layers above [Z ppt-1 ~> m ppt-1]. - - real, optional, intent(out) :: PE_chg !< The change in column potential energy from applying - !! Kddt_h at the present interface [R Z L2 T-2 ~> J m-2]. - real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h, - !! [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. - real, optional, intent(out) :: dPE_max !< The maximum change in column potential energy that could - !! be realized by applying a huge value of Kddt_h at the - !! present interface [R Z L2 T-2 ~> J m-2]. - real, optional, intent(out) :: dPEc_dKd_0 !< The partial derivative of PE_chg with Kddt_h in the - !! limit where Kddt_h = 0 [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. - -! This subroutine determines the total potential energy change due to mixing -! at an interface, including all of the implicit effects of the prescribed -! mixing at interfaces above. Everything here is derived by careful manipulation -! of the robust tridiagonal solvers used for tracers by MOM6. The results are -! positive for mixing in a stably stratified environment. -! The comments describing these arguments are for a downward mixing pass, but -! this routine can also be used for an upward pass with the sense of direction -! reversed. - - real :: b1 ! b1 is used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. - real :: b1Kd ! Temporary array [nondim] - real :: ColHt_chg ! The change in column thickness [Z ~> m]. - real :: dColHt_max ! The change in column thickness for infinite diffusivity [Z ~> m]. - real :: dColHt_dKd ! The partial derivative of column thickness with Kddt_h [Z H-1 ~> nondim or m3 kg-1] - real :: dT_k, dT_km1 ! Temperature changes in layers k and k-1 [degC] - real :: dS_k, dS_km1 ! Salinity changes in layers k and k-1 [ppt] - real :: I_Kr_denom ! Temporary array [H-2 ~> m-2 or m4 kg-2] - real :: dKr_dKd ! Temporary array [H-2 ~> m-2 or m4 kg-2] - real :: ddT_k_dKd, ddT_km1_dKd ! Temporary arrays indicating the temperature changes - ! per unit change in Kddt_h [degC H-1 ~> degC m-1 or degC m2 kg-1] - real :: ddS_k_dKd, ddS_km1_dKd ! Temporary arrays indicating the salinity changes - ! per unit change in Kddt_h [ppt H-1 ~> ppt m-1 or ppt m2 kg-1] - - b1 = 1.0 / (b_den_1 + Kddt_h) - b1Kd = Kddt_h*b1 - - ! Start with the temperature change in layer k-1 due to the diffusivity at - ! interface K without considering the effects of changes in layer k. - - ! Calculate the change in PE due to the diffusion at interface K - ! if Kddt_h(K+1) = 0. - I_Kr_denom = 1.0 / (h_k*b_den_1 + (b_den_1 + h_k)*Kddt_h) - - dT_k = (Kddt_h*I_Kr_denom) * dTe_term - dS_k = (Kddt_h*I_Kr_denom) * dSe_term - - if (present(PE_chg)) then - ! Find the change in energy due to diffusion with strength Kddt_h at this interface. - ! Increment the temperature changes in layer k-1 due the changes in layer k. - dT_km1 = b1Kd * ( dT_k + dT_km1_t2 ) - dS_km1 = b1Kd * ( dS_k + dS_km1_t2 ) - - PE_chg = (dT_to_dPE_k * dT_k + dT_to_dPEa * dT_km1) + & - (dS_to_dPE_k * dS_k + dS_to_dPEa * dS_km1) - ColHt_chg = (dT_to_dColHt_k * dT_k + dT_to_dColHta * dT_km1) + & - (dS_to_dColHt_k * dS_k + dS_to_dColHta * dS_km1) - if (ColHt_chg < 0.0) PE_chg = PE_chg - pres_Z * ColHt_chg - endif - - if (present(dPEc_dKd)) then - ! Find the derivatives of the temperature and salinity changes with Kddt_h. - dKr_dKd = (h_k*b_den_1) * I_Kr_denom**2 - - ddT_k_dKd = dKr_dKd * dTe_term - ddS_k_dKd = dKr_dKd * dSe_term - ddT_km1_dKd = (b1**2 * b_den_1) * ( dT_k + dT_km1_t2 ) + b1Kd * ddT_k_dKd - ddS_km1_dKd = (b1**2 * b_den_1) * ( dS_k + dS_km1_t2 ) + b1Kd * ddS_k_dKd - - ! Calculate the partial derivative of Pe_chg with Kddt_h. - dPEc_dKd = (dT_to_dPE_k * ddT_k_dKd + dT_to_dPEa * ddT_km1_dKd) + & - (dS_to_dPE_k * ddS_k_dKd + dS_to_dPEa * ddS_km1_dKd) - dColHt_dKd = (dT_to_dColHt_k * ddT_k_dKd + dT_to_dColHta * ddT_km1_dKd) + & - (dS_to_dColHt_k * ddS_k_dKd + dS_to_dColHta * ddS_km1_dKd) - if (dColHt_dKd < 0.0) dPEc_dKd = dPEc_dKd - pres_Z * dColHt_dKd - endif - - if (present(dPE_max)) then - ! This expression is the limit of PE_chg for infinite Kddt_h. - dPE_max = (dT_to_dPEa * dT_km1_t2 + dS_to_dPEa * dS_km1_t2) + & - ((dT_to_dPE_k + dT_to_dPEa) * dTe_term + & - (dS_to_dPE_k + dS_to_dPEa) * dSe_term) / (b_den_1 + h_k) - dColHt_max = (dT_to_dColHta * dT_km1_t2 + dS_to_dColHta * dS_km1_t2) + & - ((dT_to_dColHt_k + dT_to_dColHta) * dTe_term + & - (dS_to_dColHt_k + dS_to_dColHta) * dSe_term) / (b_den_1 + h_k) - if (dColHt_max < 0.0) dPE_max = dPE_max - pres_Z*dColHt_max - endif - - if (present(dPEc_dKd_0)) then - ! This expression is the limit of dPEc_dKd for Kddt_h = 0. - dPEc_dKd_0 = (dT_to_dPEa * dT_km1_t2 + dS_to_dPEa * dS_km1_t2) / (b_den_1) + & - (dT_to_dPE_k * dTe_term + dS_to_dPE_k * dSe_term) / (h_k*b_den_1) - dColHt_dKd = (dT_to_dColHta * dT_km1_t2 + dS_to_dColHta * dS_km1_t2) / (b_den_1) + & - (dT_to_dColHt_k * dTe_term + dS_to_dColHt_k * dSe_term) / (h_k*b_den_1) - if (dColHt_dKd < 0.0) dPEc_dKd_0 = dPEc_dKd_0 - pres_Z*dColHt_dKd - endif - -end subroutine find_PE_chg_orig - !> Initialize parameters and allocate memory associated with the diapycnal energy requirement module. subroutine diapyc_energy_req_init(Time, G, GV, US, param_file, diag, CS) type(time_type), intent(in) :: Time !< model time @@ -1281,11 +1030,9 @@ subroutine diapyc_energy_req_init(Time, G, GV, US, param_file, diag, CS) type(diag_ctrl), target, intent(inout) :: diag !< structure to regulate diagnostic output type(diapyc_energy_req_CS), pointer :: CS !< module control structure - integer, save :: init_calls = 0 ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_diapyc_energy_req" ! This module's name. - character(len=256) :: mesg ! Message for error messages. if (.not.associated(CS)) then ; allocate(CS) else ; return ; endif @@ -1301,10 +1048,12 @@ subroutine diapyc_energy_req_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "ENERGY_REQ_COL_HT_SCALING", CS%ColHt_scaling, & "A scaling factor for the column height change correction "//& "used in testing the energy requirements.", default=1.0, units="nondim") - call get_param(param_file, mdl, "ENERGY_REQ_USE_TEST_PROFILE", & - CS%use_test_Kh_profile, & + call get_param(param_file, mdl, "ENERGY_REQ_USE_TEST_PROFILE", CS%use_test_Kh_profile, & "If true, use the internal test diffusivity profile in "//& "place of any that might be passed in as an argument.", default=.false.) + call get_param(param_file, mdl, 'VON_KARMAN_CONST', CS%vonKar, & + 'The value the von Karman constant as used for mixed layer viscosity.', & + units='nondim', default=0.41) CS%id_ERt = register_diag_field('ocean_model', 'EnReqTest_ERt', diag%axesZi, Time, & "Diffusivity Energy Requirements, top-down", & @@ -1339,13 +1088,13 @@ subroutine diapyc_energy_req_init(Time, G, GV, US, param_file, diag, CS) "Column Height Correction to Energy Requirements, halves", & "J m-2", conversion=US%RZ_to_kg_m2*US%L_T_to_m_s**2) CS%id_T0 = register_diag_field('ocean_model', 'EnReqTest_T0', diag%axesZL, Time, & - "Temperature before mixing", "deg C") + "Temperature before mixing", "deg C", conversion=US%C_to_degC) CS%id_Tf = register_diag_field('ocean_model', 'EnReqTest_Tf', diag%axesZL, Time, & - "Temperature after mixing", "deg C") + "Temperature after mixing", "deg C", conversion=US%C_to_degC) CS%id_S0 = register_diag_field('ocean_model', 'EnReqTest_S0', diag%axesZL, Time, & - "Salinity before mixing", "g kg-1") + "Salinity before mixing", "g kg-1", conversion=US%S_to_ppt) CS%id_Sf = register_diag_field('ocean_model', 'EnReqTest_Sf', diag%axesZL, Time, & - "Salinity after mixing", "g kg-1") + "Salinity after mixing", "g kg-1", conversion=US%S_to_ppt) CS%id_N2_0 = register_diag_field('ocean_model', 'EnReqTest_N2_0', diag%axesZi, Time, & "Squared buoyancy frequency before mixing", "second-2", conversion=US%s_to_T**2) CS%id_N2_f = register_diag_field('ocean_model', 'EnReqTest_N2_f', diag%axesZi, Time, & diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index d88d5e551d..6930007bd1 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -1,23 +1,29 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Energetically consistent planetary boundary layer parameterization module MOM_energetic_PBL -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE -use MOM_coms, only : EFP_type, real_to_EFP, EFP_to_real, operator(+), assignment(=), EFP_sum_across_PEs -use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc -use MOM_diag_mediator, only : time_type, diag_ctrl -use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type -use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : forcing -use MOM_grid, only : ocean_grid_type +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_coms, only : EFP_type, real_to_EFP, EFP_to_real, operator(+), assignment(=), EFP_sum_across_PEs +use MOM_debugging, only : hchksum +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc +use MOM_diag_mediator, only : post_data_3d_by_column, post_data_3d_final +use MOM_diag_mediator, only : time_type, diag_ctrl +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_intrinsic_functions, only : cuberoot use MOM_string_functions, only : uppercase -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type -use MOM_wave_interface, only: wave_parameters_CS, Get_Langmuir_Number -use MOM_stochastics, only : stochastic_CS +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs, vertvisc_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_wave_interface, only : wave_parameters_CS, Get_Langmuir_Number +use MOM_stochastics, only : stochastic_CS implicit none ; private @@ -36,8 +42,7 @@ module MOM_energetic_PBL logical :: initialized = .false. !< True if this control structure has been initialized. !/ Constants - real :: VonKar = 0.41 !< The von Karman coefficient. This should be a runtime parameter, - !! but because it is set to 0.4 at runtime in KPP it might change answers. + real :: VonKar !< The von Karman coefficient as used in the ePBL module [nondim] real :: omega !< The Earth's rotation rate [T-1 ~> s-1]. real :: omega_frac !< When setting the decay scale for turbulence, use this fraction of !! the absolute rotation rate blended with the local value of f, as @@ -58,22 +63,29 @@ module MOM_energetic_PBL !! self-consistent mixed layer depth. Otherwise use the false position !! after a maximum and minimum bound have been evaluated and the !! returned value from the previous guess or bisection before this. + logical :: MLD_iter_bug !< If true use buggy logic that gives the wrong bounds for the next + !! iteration when successive guesses increase by exactly EPBL_MLD_TOLERANCE. integer :: max_MLD_its !< The maximum number of iterations that can be used to find a !! self-consistent mixed layer depth with Use_MLD_iteration. - real :: MixLenExponent !< Exponent in the mixing length shape-function. + real :: MixLenExponent !< Exponent in the mixing length shape-function [nondim]. !! 1 is law-of-the-wall at top and bottom, !! 2 is more KPP like. real :: MKE_to_TKE_effic !< The efficiency with which mean kinetic energy released by !! mechanically forced entrainment of the mixed layer is converted to - !! TKE [nondim]. + !! TKE, times conversion factors between the natural units of mean + !! kinetic energy and those used for TKE [Z2 L-2 ~> nondim]. + logical :: direct_calc !< If true and there is no conversion from mean kinetic energy to ePBL + !! turbulent kinetic energy, use a direct calculation of the + !! diffusivity that is supported by a given energy input instead of the + !! more general but slower iterative solver. real :: ustar_min !< A minimum value of ustar to avoid numerical problems [Z T-1 ~> m s-1]. !! If the value is small enough, this should not affect the solution. real :: Ekman_scale_coef !< A nondimensional scaling factor controlling the inhibition of the - !! diffusive length scale by rotation. Making this larger decreases + !! diffusive length scale by rotation [nondim]. Making this larger decreases !! the diffusivity in the planetary boundary layer. real :: transLay_scale !< A scale for the mixing length in the transition layer !! at the edge of the boundary layer as a fraction of the - !! boundary layer thickness. The default is 0, but a + !! boundary layer thickness [nondim]. The default is 0, but a !! value of 0.1 might be better justified by observations. real :: MLD_tol !< A tolerance for determining the boundary layer thickness when !! Use_MLD_iteration is true [Z ~> m]. @@ -91,15 +103,14 @@ module MOM_energetic_PBL !! Making this larger increases the diffusivity. real :: vstar_surf_fac !< If (wT_scheme == wT_from_RH18) this is the proportionality coefficient between !! ustar and the surface mechanical contribution to vstar [nondim] - real :: vstar_scale_fac !< An overall nondimensional scaling factor for vstar times a unit - !! conversion factor [Z s T-1 m-1 ~> nondim]. Making this larger increases - !! the diffusivity. + real :: vstar_scale_fac !< An overall nondimensional scaling factor for vstar [nondim]. Making + !! this larger increases the diffusivity. !mstar related options integer :: mstar_scheme !< An encoded integer to determine which formula is used to set mstar - logical :: MSTAR_FLATCAP=.true. !< Set false to use asymptotic mstar cap. - real :: mstar_cap !< Since MSTAR is restoring undissipated energy to mixing, - !! there must be a cap on how large it can be. This + integer :: BBL_mstar_scheme !< An encoded integer to determine which formula is used to set mstar + real :: mstar_cap !< Since mstar is restoring undissipated energy to mixing, + !! there must be a cap on how large it can be [nondim]. This !! is definitely a function of latitude (Ekman limit), !! but will be taken as constant for now. @@ -107,109 +118,177 @@ module MOM_energetic_PBL real :: TKE_decay !< The ratio of the natural Ekman depth to the TKE decay scale [nondim]. !/ mstar_scheme == 0 - real :: fixed_mstar !< Mstar is the ratio of the friction velocity cubed to the TKE available to - !! drive entrainment, nondimensional. This quantity is the vertically + real :: fixed_mstar !< mstar is the ratio of the friction velocity cubed to the TKE available to + !! drive entrainment [nondim]. This quantity is the vertically !! integrated shear production minus the vertically integrated !! dissipation of TKE produced by shear. This value is used if the option !! for using a fixed mstar is used. + real :: BBL_fixed_mstar !< Similar to fixed_mstar, but for the bottom boundary layer !/ mstar_scheme == 2 - real :: C_EK = 0.17 !< MSTAR Coefficient in rotation limit for mstar_scheme=OM4 - real :: MSTAR_COEF = 0.3 !< MSTAR coefficient in rotation/stabilizing balance for mstar_scheme=OM4 + real :: C_Ek = 0.17 !< mstar Coefficient in rotation limit for EPBL_MSTAR_SCHEME=OM4 [nondim] + real :: mstar_coef = 0.3 !< mstar coefficient in rotation/stabilizing balance for EPBL_MSTAR_SCHEME=OM4 [nondim] !/ mstar_scheme == 3 - real :: RH18_mstar_cN1 !< MSTAR_N coefficient 1 (outter-most coefficient for fit). + real :: RH18_mstar_cN1 !< mstar_N coefficient 1 (outer-most coefficient for fit) [nondim]. !! Value of 0.275 in RH18. Increasing this !! coefficient increases mechanical mixing for all values of Hf/ust, !! but is most effective at low values (weakly developed OSBLs). - real :: RH18_mstar_cN2 !< MSTAR_N coefficient 2 (coefficient outside of exponential decay). - !! Value of 8.0 in RH18. Increasing this coefficient increases MSTAR + real :: RH18_mstar_cN2 !< mstar_N coefficient 2 (coefficient outside of exponential decay) [nondim]. + !! Value of 8.0 in RH18. Increasing this coefficient increases mstar !! for all values of HF/ust, with a consistent affect across !! a wide range of Hf/ust. - real :: RH18_mstar_cN3 !< MSTAR_N coefficient 3 (exponential decay coefficient). Value of + real :: RH18_mstar_cN3 !< mstar_N coefficient 3 (exponential decay coefficient) [nondim]. Value of !! -5.0 in RH18. Increasing this increases how quickly the value - !! of MSTAR decreases as Hf/ust increases. - real :: RH18_mstar_cS1 !< MSTAR_S coefficient for RH18 in stabilizing limit. + !! of mstar decreases as Hf/ust increases. + real :: RH18_mstar_cS1 !< mstar_S coefficient for RH18 in stabilizing limit [nondim]. !! Value of 0.2 in RH18. - real :: RH18_mstar_cS2 !< MSTAR_S exponent for RH18 in stabilizing limit. + real :: RH18_mstar_cS2 !< mstar_S exponent for RH18 in stabilizing limit [nondim]. !! Value of 0.4 in RH18. !/ Coefficient for shear/convective turbulence interaction - real :: mstar_convect_coef !< Factor to reduce mstar when statically unstable. + real :: mstar_convect_coef !< Factor to reduce mstar when statically unstable [nondim]. !/ Langmuir turbulence related parameters logical :: Use_LT = .false. !< Flag for using LT in Energy calculation - integer :: LT_ENHANCE_FORM !< Integer for Enhancement functional form (various options) - real :: LT_ENHANCE_COEF !< Coefficient in fit for Langmuir Enhancment - real :: LT_ENHANCE_EXP !< Exponent in fit for Langmuir Enhancement - real :: LaC_MLDoEK !< Coefficient for Langmuir number modification based on the ratio of - !! the mixed layer depth over the Ekman depth. - real :: LaC_MLDoOB_stab !< Coefficient for Langmuir number modification based on the ratio of - !! the mixed layer depth over the Obukov depth with stablizing forcing. - real :: LaC_EKoOB_stab !< Coefficient for Langmuir number modification based on the ratio of - !! the Ekman depth over the Obukov depth with stablizing forcing. - real :: LaC_MLDoOB_un !< Coefficient for Langmuir number modification based on the ratio of - !! the mixed layer depth over the Obukov depth with destablizing forcing. - real :: LaC_EKoOB_un !< Coefficient for Langmuir number modification based on the ratio of - !! the Ekman depth over the Obukov depth with destablizing forcing. - real :: Max_Enhance_M = 5. !< The maximum allowed LT enhancement to the mixing. + integer :: LT_enhance_form !< Integer for Enhancement functional form (various options) + real :: LT_enhance_coef !< Coefficient in fit for Langmuir Enhancement [nondim] + real :: LT_enhance_exp !< Exponent in fit for Langmuir Enhancement [nondim] + real :: LaC_MLD_Ek !< Coefficient for Langmuir number modification based on the ratio of + !! the mixed layer depth over the Ekman depth [nondim]. + real :: LaC_MLD_Ob_stab !< Coefficient for Langmuir number modification based on the ratio of + !! the mixed layer depth over the Obukhov depth with stabilizing forcing [nondim]. + real :: LaC_Ek_Ob_stab !< Coefficient for Langmuir number modification based on the ratio of + !! the Ekman depth over the Obukhov depth with stabilizing forcing [nondim]. + real :: LaC_MLD_Ob_un !< Coefficient for Langmuir number modification based on the ratio of + !! the mixed layer depth over the Obukhov depth with destabilizing forcing [nondim]. + real :: LaC_Ek_Ob_un !< Coefficient for Langmuir number modification based on the ratio of + !! the Ekman depth over the Obukhov depth with destabilizing forcing [nondim]. + real :: Max_Enhance_M = 5. !< The maximum allowed LT enhancement to the mixing [nondim]. + + !/ Machine learned equation discovery model paramters + logical :: eqdisc !< Uses machine learned shape function + logical :: eqdisc_v0 !< Uses machine learned velocity scale + logical :: eqdisc_v0h !< Uses machine learned velocity scale that uses boundary layer depth as input + real :: v0_lower_cap !< Lower cap to prevent v0 from attaining anomlously low values [Z T-1 ~> m s-1] + real :: v0_upper_cap !< Upper cap to prevent v0 from attaining anomlously high values [Z T-1 ~> m s-1] + real :: f_lower !< Lower cap of |f| i.e. absolute of Coriolis parameter [T-1 ~> s-1] + !! Used only in get_eqdisc_v0 subroutine. Default is 0.1deg Lat + real :: bflux_lower_cap !< Lower cap for capping blfux [Z2 T-3 ~> m2 s-3] + real :: bflux_upper_cap !< Upper cap for capping blfux [Z2 T-3 ~> m2 s-3] + real :: sigma_max_lower_cap !< Lower cap to prevent sigma_max from attaining low values [nondim] + real :: sigma_max_upper_cap !< Upper cap to prevent sigma_max from attaining high values [nondim] + real :: Eh_upper_cap !< Upper cap to prevent Eh = hf/(u__*) from attaining high values [nondim] + real :: Lh_cap !< Cap to prevent Lh = h/Monin_Obukhov_depth from attaining beyond extreme values [nondim] + real, allocatable, dimension(:) :: shape_function !< shape function used in machine learned diffusivity [nondim] + !/ Coefficients used for Machine learned diffusivity + real :: ML_c(18) !< Array of non-dimensional constants used in machine learned (ML) diffusivity [nondim] + real :: shape_function_epsilon !< An small value of shape_function below the boundary layer depth [nondim] + + !/ Bottom boundary layer mixing related options + real :: ePBL_BBL_effic !< The efficiency of bottom boundary layer mixing via ePBL driven by + !! the bottom drag dissipation of mean kinetic energy, times + !! conversion factors between the natural units of mean kinetic energy + !! and those used for TKE [Z2 L-2 ~> nondim]. + real :: ePBL_tidal_effic !< The efficiency of bottom boundary layer mixing via ePBL driven by + !! the bottom drag dissipation of tides, times conversion factors + !! between the natural units of mean kinetic energy and those used for + !! TKE [Z2 L-2 ~> nondim]. + logical :: Use_BBLD_iteration !< If true, use the proximity to the top of the actively turbulent + !! bottom boundary layer to constrain the mixing lengths. + real :: TKE_decay_BBL !< The ratio of the natural Ekman depth to the TKE decay scale for + !! bottom boundary layer mixing [nondim] + real :: min_BBL_mix_len !< The minimum mixing length scale that will be used by ePBL in the bottom + !! boundary layer mixing [Z ~> m]. The default (0) does not set a minimum. + real :: MixLenExponent_BBL !< Exponent in the bottom boundary layer mixing length shape-function [nondim]. + !! 1 is law-of-the-wall at top and bottom, + !! 2 is more KPP like. + real :: BBLD_tol !< The tolerance for the iteratively determined bottom boundary layer depth [Z ~> m]. + !! This is only used with USE_MLD_ITERATION. + integer :: max_BBLD_its !< The maximum number of iterations that can be used to find a self-consistent + !! bottom boundary layer depth. + integer :: wT_scheme_BBL !< An enumerated value indicating the method for finding the bottom boundary + !! layer turbulent velocity scale. There are currently two options: + !! wT_mwT_from_cRoot_TKE is the original (TKE_remaining)^1/3 + !! wT_from_RH18 is the version described by Reichl and Hallberg, 2018 + real :: vstar_scale_fac_BBL !< An overall nondimensional scaling factor for wT in the bottom boundary layer [nondim]. + !! Making this larger increases the bottom boundary layer diffusivity.", & + real :: vstar_surf_fac_BBL !< If (wT_scheme_BBL == wT_from_RH18) this is the proportionality coefficient between + !! ustar and the bottom boundayer layer mechanical contribution to vstar [nondim] + real :: Ekman_scale_coef_BBL !< A nondimensional scaling factor controlling the inhibition of the + !! diffusive length scale by rotation in the bottom boundary layer [nondim]. + !! Making this larger decreases the bottom boundary layer diffusivity. + logical :: decay_adjusted_BBL_TKE !< If true, include an adjustment factor in the bottom boundary layer + !! energetics that accounts for an exponential decay of TKE from a + !! near-bottom source and an assumed piecewise linear linear profile + !! of the buoyancy flux response to a change in a diffusivity. + logical :: BBL_effic_bug !< If true, overestimate the efficiency of the non-tidal ePBL bottom boundary + !! layer diffusivity by a factor of 1/sqrt(CDRAG), which is often a factor of + !! about 18.3. + logical :: ePBL_BBL_use_mstar !< If true, use an mstar*ustar^3 paramaterization to get the TKE available + !! to drive mixing in the bottom boundary layer version of ePBL. Otherwise, + !! use the meanflow energy loss to bottom drag scaled by a constant efficiency. + + !/ Options for documenting differences from parameter choices + integer :: options_diff !< If positive, this is a coded integer indicating a pair of + !! settings whose differences are diagnosed in a passive diagnostic mode + !! via extra calls to ePBL_column. If this is 0 or negative no extra + !! calls occur. !/ Others type(time_type), pointer :: Time=>NULL() !< A pointer to the ocean model's clock. logical :: TKE_diagnostics = .false. !< If true, diagnostics of the TKE budget are being calculated. - logical :: answers_2018 !< If true, use the order of arithmetic and expressions that recover the - !! answers from the end of 2018. Otherwise, use updated and more robust - !! forms of the same expressions. + integer :: answer_date !< The vintage of the order of arithmetic and expressions in the ePBL + !! 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. Values below 20240101 use A**(1./3.) to + !! estimate the cube root of A in several expressions, while higher + !! values use the integer root function cuberoot(A) and therefore + !! can work with scaled variables. logical :: orig_PE_calc !< If true, the ePBL code uses the original form of the !! potential energy change code. Otherwise, it uses a newer version !! that can work with successive increments to the diffusivity in !! upward or downward passes. + logical :: debug !< If true, write verbose checksums for debugging purposes. type(diag_ctrl), pointer :: diag=>NULL() !< A structure that is used to regulate the !! timing of diagnostic output. real, allocatable, dimension(:,:) :: & - ML_depth !< The mixed layer depth determined by active mixing in ePBL [Z ~> m]. - ! These are terms in the mixed layer TKE budget, all in [R Z3 T-3 ~> W m-2 = kg s-3]. + ML_depth !< The mixed layer depth determined by active mixing in ePBL, which may + !! be used for the first guess in the next time step [H ~> m or kg m-2] real, allocatable, dimension(:,:) :: & - diag_TKE_wind, & !< The wind source of TKE [R Z3 T-3 ~> W m-2]. - diag_TKE_MKE, & !< The resolved KE source of TKE [R Z3 T-3 ~> W m-2]. - diag_TKE_conv, & !< The convective source of TKE [R Z3 T-3 ~> W m-2]. - diag_TKE_forcing, & !< The TKE sink required to mix surface penetrating shortwave heating - !! [R Z3 T-3 ~> W m-2]. - diag_TKE_mech_decay, & !< The decay of mechanical TKE [R Z3 T-3 ~> W m-2]. - diag_TKE_conv_decay, & !< The decay of convective TKE [R Z3 T-3 ~> W m-2]. - diag_TKE_mixing, & !< The work done by TKE to deepen the mixed layer [R Z3 T-3 ~> W m-2]. - ! These additional diagnostics are also 2d. - MSTAR_MIX, & !< Mstar used in EPBL [nondim] - MSTAR_LT, & !< Mstar due to Langmuir turbulence [nondim] - LA, & !< Langmuir number [nondim] - LA_MOD !< Modified Langmuir number [nondim] + BBL_depth !< The bottom boundary layer depth determined by active mixing in ePBL [H ~> m or kg m-2] type(EFP_type), dimension(2) :: sum_its !< The total number of iterations and columns worked on + type(EFP_type), dimension(2) :: sum_its_BBL !< The total number of iterations and columns worked on - real, allocatable, dimension(:,:,:) :: & - Velocity_Scale, & !< The velocity scale used in getting Kd [Z T-1 ~> m s-1] - Mixing_Length !< The length scale used in getting Kd [Z ~> m] !>@{ Diagnostic IDs + integer :: id_Kd_ePBL_col_by_col = -1 integer :: id_ML_depth = -1, id_hML_depth = -1, id_TKE_wind = -1, id_TKE_mixing = -1 + integer :: id_ustar_ePBL = -1, id_bflx_ePBL = -1 integer :: id_TKE_MKE = -1, id_TKE_conv = -1, id_TKE_forcing = -1 integer :: id_TKE_mech_decay = -1, id_TKE_conv_decay = -1 integer :: id_Mixing_Length = -1, id_Velocity_Scale = -1 - integer :: id_MSTAR_mix = -1, id_LA_mod = -1, id_LA = -1, id_MSTAR_LT = -1 + integer :: id_Kd_BBL = -1, id_BBL_Mix_Length = -1, id_BBL_Vel_Scale = -1 + integer :: id_TKE_BBL = -1, id_TKE_BBL_mixing = -1, id_TKE_BBL_decay = -1 + integer :: id_ustar_BBL = -1, id_bflx_BBL = -1, id_BBL_decay_scale = -1, id_BBL_depth = -1 + integer :: id_mstar_sfc = -1, id_mstar_BBL = -1, id_LA_mod = -1, id_LA = -1, id_mstar_LT = -1 + ! The next options are used when passively diagnosing sensitivities from parameter choices + integer :: id_opt_diff_Kd_ePBL = -1, id_opt_maxdiff_Kd_ePBL = -1, id_opt_diff_hML_depth = -1 !>@} end type energetic_PBL_CS -!>@{ Enumeration values for mstar_Scheme -integer, parameter :: Use_Fixed_MStar = 0 !< The value of mstar_scheme to use a constant mstar -integer, parameter :: MStar_from_Ekman = 2 !< The value of mstar_scheme to base mstar on the ratio +!>@{ Enumeration values for mstar_scheme +integer, parameter :: Use_Fixed_mstar = 0 !< The value of mstar_scheme to use a constant mstar +integer, parameter :: mstar_from_Ekman = 2 !< The value of mstar_scheme to base mstar on the ratio !! of the Ekman layer depth to the Obukhov depth -integer, parameter :: MStar_from_RH18 = 3 !< The value of mstar_scheme to base mstar of of RH18 -integer, parameter :: No_Langmuir = 0 !< The value of LT_ENHANCE_FORM not use Langmuir turbolence. -integer, parameter :: Langmuir_rescale = 2 !< The value of LT_ENHANCE_FORM to use a multiplicative +integer, parameter :: mstar_from_RH18 = 3 !< The value of mstar_scheme to base mstar of of RH18 +integer, parameter :: No_Langmuir = 0 !< The value of LT_enhance_form not use Langmuir turbulence. +integer, parameter :: Langmuir_rescale = 2 !< The value of LT_enhance_form to use a multiplicative !! rescaling of mstar to account for Langmuir turbulence. -integer, parameter :: Langmuir_add = 3 !< The value of LT_ENHANCE_FORM to add a contribution to - !! mstar from Langmuir turblence to other contributions. +integer, parameter :: Langmuir_add = 3 !< The value of LT_enhance_form to add a contribution to + !! mstar from Langmuir turbulence to other contributions. integer, parameter :: wT_from_cRoot_TKE = 0 !< Use a constant times the cube root of remaining TKE !! to calculate the turbulent velocity. integer, parameter :: wT_from_RH18 = 1 !< Use a scheme based on a combination of w* and v* as @@ -229,13 +308,17 @@ module MOM_energetic_PBL !> A type for conveniently passing around ePBL diagnostics for a column. type, public :: ePBL_column_diags ; private !>@{ Local column copies of energy change diagnostics, all in [R Z3 T-3 ~> W m-2]. - real :: dTKE_conv, dTKE_forcing, dTKE_wind, dTKE_mixing - real :: dTKE_MKE, dTKE_mech_decay, dTKE_conv_decay + real :: dTKE_conv, dTKE_forcing, dTKE_wind, dTKE_mixing ! Local column diagnostics [R Z3 T-3 ~> W m-2] + real :: dTKE_MKE, dTKE_mech_decay, dTKE_conv_decay ! Local column diagnostics [R Z3 T-3 ~> W m-2] + real :: dTKE_BBL, dTKE_BBL_decay, dTKE_BBL_mixing ! Local column diagnostics [R Z3 T-3 ~> W m-2] !>@} real :: LA !< The value of the Langmuir number [nondim] real :: LAmod !< The modified Langmuir number by convection [nondim] real :: mstar !< The value of mstar used in ePBL [nondim] + real :: mstar_BBL !< The value of mstar used in ePBL BBL [nondim] real :: mstar_LT !< The portion of mstar due to Langmuir turbulence [nondim] + integer :: OBL_its !< The number of iterations used to find a self-consistent surface boundary layer depth + integer :: BBL_its !< The number of iterations used to find a self-consistent bottom boundary layer depth end type ePBL_column_diags contains @@ -244,8 +327,8 @@ module MOM_energetic_PBL !! mixed layer model. It assumes that heating, cooling and freshwater fluxes !! have already been applied. All calculations are done implicitly, and there !! is no stability limit on the time step. -subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS, & - stoch_CS, dSV_dT, dSV_dS, TKE_forced, buoy_flux, Waves ) +subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, visc, dt, Kd_int, G, GV, US, CS, & + stoch_CS, dSV_dT, dSV_dS, TKE_forced, buoy_flux, BBL_buoy_flux, Waves ) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -260,10 +343,10 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: dSV_dT !< The partial derivative of in-situ specific !! volume with potential temperature - !! [R-1 degC-1 ~> m3 kg-1 degC-1]. + !! [R-1 C-1 ~> m3 kg-1 degC-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: dSV_dS !< The partial derivative of in-situ specific - !! volume with salinity [R-1 ppt-1 ~> m3 kg-1 ppt-1]. + !! volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: TKE_forced !< The forcing requirements to homogenize the !! forcing that has been applied to each layer @@ -274,15 +357,19 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any !! possible forcing fields. Unused fields have !! NULL ptrs. + type(vertvisc_type), intent(in) :: visc !< Structure with vertical viscosities, + !! BBL properties and related fields real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(out) :: Kd_int !< The diagnosed diffusivities at interfaces - !! [Z2 T-1 ~> m2 s-1]. - type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control struct + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control structure real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: buoy_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3]. + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: BBL_buoy_flux !< The bottom buoyancy flux [Z2 T-3 ~> m2 s-3]. type(wave_parameters_CS), pointer :: Waves !< Waves control structure for Langmuir turbulence - type(stochastic_CS), pointer :: stoch_CS !< The control structure returned by a previous + type(stochastic_CS), pointer :: stoch_CS !< The control structure returned by a previous ! This subroutine determines the diffusivities from the integrated energetics ! mixed layer model. It assumes that heating, cooling and freshwater fluxes @@ -298,7 +385,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! mixing. ! ! The key parameters for the mixed layer are found in the control structure. -! To use the classic constant mstar mixied layers choose MSTAR_SCHEME=CONSTANT. +! To use the classic constant mstar mixed layers choose EPBL_MSTAR_SCHEME=CONSTANT. ! The key parameters then include mstar, nstar, TKE_decay, and conv_decay. ! For the Oberhuber (1993) mixed layer,the values of these are: ! mstar = 1.25, nstar = 1, TKE_decay = 2.5, conv_decay = 0.5 @@ -309,39 +396,116 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! Local variables real, dimension(SZI_(G),SZK_(GV)) :: & h_2d, & ! A 2-d slice of the layer thickness [H ~> m or kg m-2]. - T_2d, & ! A 2-d slice of the layer temperatures [degC]. - S_2d, & ! A 2-d slice of the layer salinities [ppt]. + dz_2d, & ! A 2-d slice of the vertical distance across layers [Z ~> m]. + T_2d, & ! A 2-d slice of the layer temperatures [C ~> degC]. + S_2d, & ! A 2-d slice of the layer salinities [S ~> ppt]. TKE_forced_2d, & ! A 2-d slice of TKE_forced [R Z3 T-2 ~> J m-2]. - dSV_dT_2d, & ! A 2-d slice of dSV_dT [R-1 degC-1 ~> m3 kg-1 degC-1]. - dSV_dS_2d, & ! A 2-d slice of dSV_dS [R-1 ppt-1 ~> m3 kg-1 ppt-1]. + dSV_dT_2d, & ! A 2-d slice of dSV_dT [R-1 C-1 ~> m3 kg-1 degC-1]. + dSV_dS_2d, & ! A 2-d slice of dSV_dS [R-1 S-1 ~> m3 kg-1 ppt-1]. u_2d, & ! A 2-d slice of the zonal velocity [L T-1 ~> m s-1]. v_2d ! A 2-d slice of the meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZK_(GV)+1) :: & - Kd_2d ! A 2-d version of the diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. + Kd_2d ! A 2-d version of the diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZK_(GV)) :: & h, & ! The layer thickness [H ~> m or kg m-2]. - T0, & ! The initial layer temperatures [degC]. - S0, & ! The initial layer salinities [ppt]. - dSV_dT_1d, & ! The partial derivatives of specific volume with temperature [R-1 degC-1 ~> m3 kg-1 degC-1]. - dSV_dS_1d, & ! The partial derivatives of specific volume with salinity [R-1 ppt-1 ~> m3 kg-1 ppt-1]. + dz, & ! The vertical distance across layers [Z ~> m]. + T0, & ! The initial layer temperatures [C ~> degC]. + S0, & ! The initial layer salinities [S ~> ppt]. + dSV_dT_1d, & ! The partial derivatives of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1]. + dSV_dS_1d, & ! The partial derivatives of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. TKE_forcing, & ! Forcing of the TKE in the layer coming from TKE_forced [R Z3 T-2 ~> J m-2]. u, & ! The zonal velocity [L T-1 ~> m s-1]. v ! The meridional velocity [L T-1 ~> m s-1]. real, dimension(SZK_(GV)+1) :: & - Kd, & ! The diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. - mixvel, & ! A turbulent mixing veloxity [Z T-1 ~> m s-1]. - mixlen ! A turbulent mixing length [Z ~> m]. + Kd, & ! The diapycnal diffusivity due to ePBL [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + mixvel, & ! A turbulent mixing velocity [Z T-1 ~> m s-1]. + mixlen, & ! A turbulent mixing length [Z ~> m]. + mixvel_BBL, & ! A bottom boundary layer turbulent mixing velocity [Z T-1 ~> m s-1]. + mixlen_BBL, & ! A bottom boundary layer turbulent mixing length [Z ~> m]. + Kd_BBL, & ! The bottom boundary layer diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + SpV_dt, & ! Specific volume interpolated to interfaces divided by dt or 1.0 / (dt * Rho0), + ! in [R-1 T-1 ~> m3 kg-1 s-1], used to convert local TKE into a turbulence velocity cubed. + SpV_dt_cf ! Specific volume interpolated to interfaces divided by dt or 1.0 / (dt * Rho0) + ! times conversion factors for answer dates before 20240101 in + ! [m3 Z-3 R-1 T2 s-3 ~> m3 kg-1 s-1] or without the conversion factors for + ! answer dates of 20240101 and later in [R-1 T-1 ~> m3 kg-1 s-1], used to + ! convert local TKE into a turbulence velocity cubed. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: absf ! The absolute value of f [T-1 ~> s-1]. real :: U_star ! The surface friction velocity [Z T-1 ~> m s-1]. real :: U_Star_Mean ! The surface friction without gustiness [Z T-1 ~> m s-1]. + real :: mech_TKE ! The mechanically generated turbulent kinetic energy available for mixing over a + ! timestep before the application of the efficiency in mstar [R Z3 T-2 ~> J m-2] + real :: u_star_BBL ! The bottom boundary layer friction velocity [H T-1 ~> m s-1 or kg m-2 s-1]. + real :: u_star_BBL_z_t ! The bottom boundary layer friction velocity converted to Z T-1 [Z T-1 ~> m s-1]. + real :: BBL_TKE ! The mechanically generated turbulent kinetic energy available for bottom + ! boundary layer mixing within a timestep [R Z3 T-2 ~> J m-2] + real :: I_rho ! The inverse of the Boussinesq reference density [R-1 ~> m3 kg-1] + real :: I_dt ! The Adcroft reciprocal of the timestep [T-1 ~> s-1] + real :: I_rho0dt ! The inverse of the Boussinesq reference density times the time + ! step [R-1 T-1 ~> m3 kg-1 s-1] real :: B_Flux ! The surface buoyancy flux [Z2 T-3 ~> m2 s-3] - real :: MLD_io ! The mixed layer depth found by ePBL_column [Z ~> m]. + real :: MLD_io ! The mixed layer depth found by ePBL_column [Z ~> m] + real :: BBLD_io ! The bottom boundary layer thickness found by ePBL_BBL_column [Z ~> m] + real :: MLD_in ! The first guess at the mixed layer depth [Z ~> m] + real :: BBLD_in ! The first guess at the bottom boundary layer thickness [Z ~> m] type(ePBL_column_diags) :: eCD ! A container for passing around diagnostics. + ! The following variables are used for diagnostics + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & + diag_Velocity_Scale, & ! The velocity scale used in getting Kd [Z T-1 ~> m s-1] + diag_Mixing_Length, & ! The length scale used in getting Kd [Z ~> m] + Kd_BBL_3d, & ! The bottom boundary layer diffusivities [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + BBL_Vel_Scale, & ! The velocity scale used in getting the BBL part of Kd [Z T-1 ~> m s-1] + BBL_Mix_Length ! The length scale used in getting the BBL part of Kd [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)) :: & + ! The next 7 diagnostics are terms in the mixed layer TKE budget, all in [R Z3 T-3 ~> W m-2]. + diag_TKE_wind, & ! The wind source of TKE [R Z3 T-3 ~> W m-2] + diag_TKE_MKE, & ! The resolved KE source of TKE [R Z3 T-3 ~> W m-2] + diag_TKE_conv, & ! The convective source of TKE [R Z3 T-3 ~> W m-2] + diag_TKE_forcing, & ! The TKE sink required to mix surface penetrating shortwave heating [R Z3 T-3 ~> W m-2] + diag_TKE_mech_decay, & ! The decay of mechanical TKE [R Z3 T-3 ~> W m-2] + diag_TKE_conv_decay, & ! The decay of convective TKE [R Z3 T-3 ~> W m-2] + diag_TKE_mixing, & ! The work done by TKE to deepen the mixed layer [R Z3 T-3 ~> W m-2] + diag_TKE_BBL, & ! The source of TKE to the bottom boundary layer [R Z3 T-3 ~> W m-2]. + diag_TKE_BBL_mixing, & ! The work done by TKE to thicken the bottom boundary layer [R Z3 T-3 ~> W m-2]. + diag_TKE_BBL_decay, & ! The work lost to decy of mechanical TKE in the bottom boundary + ! layer [R Z3 T-3 ~> W m-2]. + diag_ustar_BBL, & ! The bottom boundary layer friction velocity [H T-1 ~> m s-1 or kg m-2 s-1] + diag_BBL_decay_scale, & ! The bottom boundary layer TKE decay length scale [H ~> m] + diag_mstar_sfc, & ! mstar used in EPBL [nondim] + diag_mstar_BBL, & ! mstar used in EPBL BBL [nondim] + diag_mstar_LT, & ! mstar due to Langmuir turbulence [nondim] + diag_LA, & ! Langmuir number [nondim] + diag_LA_mod, & ! Modified Langmuir number [nondim] + diag_ustar ! The surface boundary layer friction velocity [Z T-1 ~> m s-1] + + ! The following variables are only used for diagnosing sensitivities to ePBL settings + real, dimension(SZK_(GV)+1) :: & + Kd_1, Kd_2 ! Diapycnal diffusivities found with different ePBL options [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: diff_Kd(SZI_(G),SZJ_(G),SZK_(GV)+1) ! The change in diapycnal diffusivities found with different + ! ePBL options [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: max_abs_diff_Kd(SZI_(G),SZJ_(G)) ! The column maximum magnitude of the change in diapycnal + ! diffusivities found with different ePBL options [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: diff_hML_depth(SZI_(G),SZJ_(G)) ! The change in diagnosed active mixing layer depth with + ! different ePBL options [Z ~> m] + real :: BLD_1, BLD_2 ! Surface or bottom boundary layer depths found with different ePBL_column options [Z ~> m] + real :: SpV_scale1 ! A factor that accounts for the varying scaling of SpV_dt with answer date + ! [nondim] or [T3 m3 Z-3 s-3 ~> 1] + real :: SpV_scale2 ! A factor that accounts for the varying scaling of SpV_dt with answer date + ! [nondim] or [Z3 s3 T-3 m-3 ~> 1] + real :: SpV_dt_tmp(SZK_(GV)+1) ! Specific volume interpolated to interfaces divided by dt or 1.0 / (dt * Rho0) + ! times conversion factors for answer dates before 20240101 in + ! [m3 Z-3 R-1 T2 s-3 ~> m3 kg-1 s-1] or without the conversion factors for + ! answer dates of 20240101 and later in [R-1 T-1 ~> m3 kg-1 s-1], used to + ! convert local TKE into a turbulence velocity cubed. + type(ePBL_column_diags) :: eCD_tmp ! A container for not passing around diagnostics. + type(energetic_PBL_CS) :: CS_tmp1, CS_tmp2 ! Copies of the energetic PBL control structure that + ! can be modified to test for sensitivities + logical :: BBL_mixing ! If true, there is bottom boundary layer mixing. integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -351,30 +515,80 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS if (.not. associated(tv%eqn_of_state)) call MOM_error(FATAL, & "energetic_PBL: Temperature, salinity and an equation of state "//& "must now be used.") - if (.NOT. associated(fluxes%ustar)) call MOM_error(FATAL, & - "energetic_PBL: No surface TKE fluxes (ustar) defined in fluxes type!") + if (.not.(associated(fluxes%ustar) .or. associated(fluxes%tau_mag))) call MOM_error(FATAL, & + "energetic_PBL: No surface friction velocity (ustar or tau_mag) defined in fluxes type.") + if ((.not.GV%Boussinesq) .and. (.not.associated(fluxes%tau_mag))) call MOM_error(FATAL, & + "energetic_PBL: No surface wind stress magnitude defined in fluxes type in non-Boussinesq mode.") if (CS%use_LT .and. .not.associated(Waves)) call MOM_error(FATAL, & "energetic_PBL: The Waves control structure must be associated if CS%use_LT "//& "(i.e., USE_LA_LI2016 or EPBL_LT) is True.") h_neglect = GV%H_subroundoff + I_rho = GV%H_to_Z * GV%RZ_to_H ! == 1.0 / GV%Rho0 ! This is not used when fully non-Boussinesq. + I_dt = 0.0 ; if (dt > 0.0) I_dt = 1.0 / dt + I_rho0dt = 1.0 / (GV%Rho0 * dt) ! This is not used when fully non-Boussinesq. + BBL_mixing = ((CS%ePBL_BBL_effic > 0.0) .or. (CS%ePBL_tidal_effic > 0.0) .or. CS%ePBL_BBL_use_mstar) ! Zero out diagnostics before accumulation. if (CS%TKE_diagnostics) then -!!OMP parallel do default(none) shared(is,ie,js,je,CS) + !!OMP parallel do default(shared) do j=js,je ; do i=is,ie - CS%diag_TKE_wind(i,j) = 0.0 ; CS%diag_TKE_MKE(i,j) = 0.0 - CS%diag_TKE_conv(i,j) = 0.0 ; CS%diag_TKE_forcing(i,j) = 0.0 - CS%diag_TKE_mixing(i,j) = 0.0 ; CS%diag_TKE_mech_decay(i,j) = 0.0 - CS%diag_TKE_conv_decay(i,j) = 0.0 !; CS%diag_TKE_unbalanced(i,j) = 0.0 + diag_TKE_wind(i,j) = 0.0 ; diag_TKE_MKE(i,j) = 0.0 + diag_TKE_conv(i,j) = 0.0 ; diag_TKE_forcing(i,j) = 0.0 + diag_TKE_mixing(i,j) = 0.0 ; diag_TKE_mech_decay(i,j) = 0.0 + diag_TKE_conv_decay(i,j) = 0.0 !; diag_TKE_unbalanced(i,j) = 0.0 enddo ; enddo + if (BBL_mixing) then + !!OMP parallel do default(shared) + do j=js,je ; do i=is,ie + diag_TKE_BBL(i,j) = 0.0 ; diag_TKE_BBL_mixing(i,j) = 0.0 + diag_TKE_BBL_decay(i,j) = 0.0 + enddo ; enddo + endif + endif + if (CS%debug .or. (CS%id_Mixing_Length>0)) diag_Mixing_Length(:,:,:) = 0.0 + if (CS%debug .or. (CS%id_Velocity_Scale>0)) diag_Velocity_Scale(:,:,:) = 0.0 + if (BBL_mixing) then + if (CS%debug .or. (CS%id_BBL_Mix_Length>0)) BBL_Mix_Length(:,:,:) = 0.0 + if (CS%debug .or. (CS%id_BBL_Vel_Scale>0)) BBL_Vel_Scale(:,:,:) = 0.0 + if (CS%id_Kd_BBL > 0) Kd_BBL_3d(:,:,:) = 0.0 + if (CS%id_ustar_BBL > 0) diag_ustar_BBL(:,:) = 0.0 + if (CS%id_BBL_decay_scale > 0) diag_BBL_decay_scale(:,:) = 0.0 endif - ! if (CS%id_Mixing_Length>0) CS%Mixing_Length(:,:,:) = 0.0 - ! if (CS%id_Velocity_Scale>0) CS%Velocity_Scale(:,:,:) = 0.0 -!!OMP parallel do default(private) shared(js,je,nz,is,ie,h_3d,u_3d,v_3d,tv,dt, & -!!OMP CS,G,GV,US,fluxes,TKE_forced,dSV_dT,dSV_dS,Kd_int) + ! CS_tmp is used to test sensitivity to parameter setting changes. + if (CS%options_diff > 0) then + CS_tmp1 = CS ; CS_tmp2 = CS + SpV_scale1 = 1.0 ; SpV_scale2 = 1.0 + + if (CS%options_diff == 1) then + CS_tmp1%orig_PE_calc = .true. ; CS_tmp2%orig_PE_calc = .false. + elseif (CS%options_diff == 2) then + CS_tmp1%answer_date = 20181231 ; CS_tmp2%answer_date = 20240101 + elseif (CS%options_diff == 3) then + CS_tmp1%direct_calc = .true. ; CS_tmp2%direct_calc = .false. + CS_tmp1%MKE_to_TKE_effic = 0.0 ; CS_tmp2%MKE_to_TKE_effic = 0.0 + CS_tmp1%orig_PE_calc = .false. ; CS_tmp2%orig_PE_calc = .false. + elseif (CS%options_diff == 4) then + CS_tmp1%direct_calc = .true. ; CS_tmp2%direct_calc = .false. + CS_tmp1%MKE_to_TKE_effic = 0.0 ; CS_tmp2%MKE_to_TKE_effic = 0.0 + CS_tmp1%ePBL_BBL_effic = 0.2 ; CS_tmp2%ePBL_BBL_effic = 0.2 + elseif (CS%options_diff == 5) then + CS_tmp1%decay_adjusted_BBL_TKE = .true. ; CS_tmp2%decay_adjusted_BBL_TKE = .false. + CS_tmp1%MKE_to_TKE_effic = 0.0 ; CS_tmp2%MKE_to_TKE_effic = 0.0 + CS_tmp1%ePBL_BBL_effic = 0.2 ; CS_tmp2%ePBL_BBL_effic = 0.2 + endif + ! This logic is needed because the scaling of SpV_dt changes with answer date. + if (CS_tmp1%answer_date < 20240101) SpV_scale1 = US%m_to_Z**3 * US%T_to_s**3 + if (CS_tmp2%answer_date < 20240101) SpV_scale2 = US%m_to_Z**3 * US%T_to_s**3 + if (CS%id_opt_diff_Kd_ePBL > 0) diff_Kd(:,:,:) = 0.0 + if (CS%id_opt_maxdiff_Kd_ePBL > 0) max_abs_diff_Kd(:,:) = 0.0 + if (CS%id_opt_diff_hML_depth > 0) diff_hML_depth(:,:) = 0.0 + endif + + !!OMP parallel do default(private) shared(js,je,nz,is,ie,h_3d,u_3d,v_3d,tv,dt,I_dt,BBL_mixing, & + !!OMP CS,G,GV,US,fluxes,TKE_forced,dSV_dT,dSV_dS,Kd_int) do j=js,je ! Copy the thicknesses and other fields to 2-d arrays. do k=1,nz ; do i=is,ie @@ -383,6 +597,21 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS TKE_forced_2d(i,k) = TKE_forced(i,j,k) dSV_dT_2d(i,k) = dSV_dT(i,j,k) ; dSV_dS_2d(i,k) = dSV_dS(i,j,k) enddo ; enddo + call thickness_to_dz(h_3d, tv, dz_2d, j, G, GV) + + ! Set the inverse density used to translating local TKE into a turbulence velocity + SpV_dt(:) = 0.0 + if ((dt > 0.0) .and. GV%Boussinesq .or. .not.allocated(tv%SpV_avg)) then + if (CS%answer_date < 20240101) then + do K=1,nz+1 + SpV_dt(K) = 1.0 / (dt*GV%Rho0) + enddo + else + do K=1,nz+1 + SpV_dt(K) = I_rho0dt + enddo + endif + endif ! Determine the initial mech_TKE and conv_PErel, including the energy required ! to mix surface heating through the topmost cell, the energy released by mixing @@ -390,19 +619,42 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! homogenizing the shortwave heating within that cell. This sets the energy ! and ustar and wstar available to drive mixing at the first interior ! interface. - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then ! Copy the thicknesses and other fields to 1-d arrays. do k=1,nz - h(k) = h_2d(i,k) + GV%H_subroundoff ; u(k) = u_2d(i,k) ; v(k) = v_2d(i,k) + h(k) = h_2d(i,k) + GV%H_subroundoff ; dz(k) = dz_2d(i,k) + GV%dZ_subroundoff + u(k) = u_2d(i,k) ; v(k) = v_2d(i,k) T0(k) = T_2d(i,k) ; S0(k) = S_2d(i,k) ; TKE_forcing(k) = TKE_forced_2d(i,k) dSV_dT_1d(k) = dSV_dT_2d(i,k) ; dSV_dS_1d(k) = dSV_dS_2d(i,k) enddo do K=1,nz+1 ; Kd(K) = 0.0 ; enddo ! Make local copies of surface forcing and process them. - u_star = fluxes%ustar(i,j) - u_star_Mean = fluxes%ustar_gustless(i,j) + if (associated(fluxes%ustar) .and. (GV%Boussinesq .or. .not.associated(fluxes%tau_mag))) then + u_star = fluxes%ustar(i,j) + u_star_Mean = fluxes%ustar_gustless(i,j) + mech_TKE = dt * GV%Rho0 * u_star**3 + elseif (allocated(tv%SpV_avg)) then + u_star = sqrt(fluxes%tau_mag(i,j) * tv%SpV_avg(i,j,1)) + u_star_Mean = sqrt(fluxes%tau_mag_gustless(i,j) * tv%SpV_avg(i,j,1)) + mech_TKE = dt * u_star * fluxes%tau_mag(i,j) + else + u_star = sqrt(fluxes%tau_mag(i,j) * I_rho) + u_star_Mean = sqrt(fluxes%tau_mag_gustless(i,j) * I_rho) + mech_TKE = dt * GV%Rho0 * u_star**3 + ! The line above is equivalent to: mech_TKE = dt * u_star * fluxes%tau_mag(i,j) + endif + diag_ustar(i,j) = u_star + + if (allocated(tv%SpV_avg) .and. .not.GV%Boussinesq) then + SpV_dt(1) = tv%SpV_avg(i,j,1) * I_dt + do K=2,nz + SpV_dt(K) = 0.5*(tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i,j,k)) * I_dt + enddo + SpV_dt(nz+1) = tv%SpV_avg(i,j,nz) * I_dt + endif + B_flux = buoy_flux(i,j) if (associated(fluxes%ustar_shelf) .and. associated(fluxes%frac_shelf_h)) then if (fluxes%frac_shelf_h(i,j) > 0.0) & @@ -421,101 +673,253 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! Perhaps provide a first guess for MLD based on a stored previous value. MLD_io = -1.0 - if (CS%MLD_iteration_guess .and. (CS%ML_Depth(i,j) > 0.0)) MLD_io = CS%ML_Depth(i,j) + if (CS%MLD_iteration_guess .and. (CS%ML_depth(i,j) > 0.0)) MLD_io = CS%ML_depth(i,j) + BBLD_io = 0.0 + + ! Store the initial guesses at the boundary layer depths for testing sensitivities. + MLD_in = MLD_io + if (CS%answer_date < 20240101) then + do K=1,nz+1 ; SpV_dt_cf(K) = (US%Z_to_m**3*US%s_to_T**3) * SpV_dt(K) ; enddo + else + do K=1,nz+1 ; SpV_dt_cf(K) = SpV_dt(K) ; enddo + endif if (stoch_CS%pert_epbl) then ! stochastics are active - call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & - u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & + call ePBL_column(h, dz, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, SpV_dt_cf, TKE_forcing, B_flux, absf, & + u_star, u_star_mean, mech_TKE, dt, MLD_io, Kd, mixvel, mixlen, GV, & US, CS, eCD, Waves, G, i, j, & - epbl1_wt=stoch_CS%epbl1_wts(i,j),epbl2_wt=stoch_CS%epbl2_wts(i,j)) + TKE_gen_stoch=stoch_CS%epbl1_wts(i,j), TKE_diss_stoch=stoch_CS%epbl2_wts(i,j)) else - call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & - u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & + call ePBL_column(h, dz, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, SpV_dt_cf, TKE_forcing, B_flux, absf, & + u_star, u_star_mean, mech_TKE, dt, MLD_io, Kd, mixvel, mixlen, GV, & US, CS, eCD, Waves, G, i, j) endif + if (CS%id_Kd_ePBL_col_by_col > 0) & + call post_data_3d_by_column(CS%id_Kd_ePBL_col_by_col, Kd, CS%diag, i, j) + + ! Add the diffusivity due to bottom boundary layer mixing, if there is energy to drive this mixing. + if (BBL_mixing) then + if (CS%MLD_iteration_guess .and. (CS%BBL_depth(i,j) > 0.0)) BBLD_io = CS%BBL_depth(i,j) + BBLD_in = BBLD_io + u_star_BBL = max(visc%ustar_BBL(i,j), CS%ustar_min*GV%Z_to_H) ! units are H T-1 + if (GV%Boussinesq) then + u_star_BBL_z_t = u_star_BBL*GV%H_to_Z + else + u_star_BBL_z_t = u_star_BBL*GV%H_to_RZ*tv%SpV_avg(i,j,1) + endif + + if (CS%ePBL_BBL_use_mstar) then + BBL_TKE = dt * ((u_star_BBL*GV%H_to_RZ) * u_star_BBL_z_t**2) + else + if (CS%BBL_effic_bug) then + BBL_TKE = CS%ePBL_BBL_effic * GV%H_to_RZ * dt * visc%BBL_meanKE_loss_sqrtCd(i,j) + else + BBL_TKE = CS%ePBL_BBL_effic * GV%H_to_RZ * dt * visc%BBL_meanKE_loss(i,j) + endif + ! Add in tidal dissipation energy at the bottom, noting that fluxes%BBL_tidal_dis is + ! in [R Z L2 T-3 ~> W m-2], unlike visc%BBL_meanKE_loss. + if ((CS%ePBL_tidal_effic > 0.0) .and. associated(fluxes%BBL_tidal_dis)) & + BBL_TKE = BBL_TKE + CS%ePBL_tidal_effic * dt * fluxes%BBL_tidal_dis(i,j) + endif + + call ePBL_BBL_column(h, dz, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, SpV_dt, absf, dt, Kd, BBL_TKE, & + u_star_BBL, u_star_BBL_z_t, BBL_buoy_flux(i,j), Kd_BBL, BBLD_io, mixvel_BBL, mixlen_BBL, & + GV, US, CS, eCD) + + do K=1,nz+1 ; Kd(K) = Kd(K) + Kd_BBL(K) ; enddo + if (CS%id_Kd_BBL > 0) then ; do K=1,nz+1 + Kd_BBL_3d(i,j,K) = Kd_BBL(K) + enddo ; endif + if (CS%id_ustar_BBL > 0) diag_ustar_BBL(i,j) = u_star_BBL + if ((CS%id_BBL_decay_scale > 0) .and. (CS%TKE_decay * absf > 0)) & + diag_BBL_decay_scale(i,j) = u_star_BBL / (CS%TKE_decay * absf) + endif ! Copy the diffusivities to a 2-d array. do K=1,nz+1 Kd_2d(i,K) = Kd(K) enddo CS%ML_depth(i,j) = MLD_io + CS%BBL_depth(i,j) = BBLD_io if (CS%TKE_diagnostics) then - CS%diag_TKE_MKE(i,j) = CS%diag_TKE_MKE(i,j) + eCD%dTKE_MKE - CS%diag_TKE_conv(i,j) = CS%diag_TKE_conv(i,j) + eCD%dTKE_conv - CS%diag_TKE_forcing(i,j) = CS%diag_TKE_forcing(i,j) + eCD%dTKE_forcing - CS%diag_TKE_wind(i,j) = CS%diag_TKE_wind(i,j) + eCD%dTKE_wind - CS%diag_TKE_mixing(i,j) = CS%diag_TKE_mixing(i,j) + eCD%dTKE_mixing - CS%diag_TKE_mech_decay(i,j) = CS%diag_TKE_mech_decay(i,j) + eCD%dTKE_mech_decay - CS%diag_TKE_conv_decay(i,j) = CS%diag_TKE_conv_decay(i,j) + eCD%dTKE_conv_decay - ! CS%diag_TKE_unbalanced(i,j) = CS%diag_TKE_unbalanced(i,j) + eCD%dTKE_unbalanced + diag_TKE_MKE(i,j) = diag_TKE_MKE(i,j) + eCD%dTKE_MKE + diag_TKE_conv(i,j) = diag_TKE_conv(i,j) + eCD%dTKE_conv + diag_TKE_forcing(i,j) = diag_TKE_forcing(i,j) + eCD%dTKE_forcing + diag_TKE_wind(i,j) = diag_TKE_wind(i,j) + eCD%dTKE_wind + diag_TKE_mixing(i,j) = diag_TKE_mixing(i,j) + eCD%dTKE_mixing + diag_TKE_mech_decay(i,j) = diag_TKE_mech_decay(i,j) + eCD%dTKE_mech_decay + diag_TKE_conv_decay(i,j) = diag_TKE_conv_decay(i,j) + eCD%dTKE_conv_decay + ! diag_TKE_unbalanced(i,j) = diag_TKE_unbalanced(i,j) + eCD%dTKE_unbalanced endif - ! Write to 3-D for outputing Mixing length and velocity scale. - if (CS%id_Mixing_Length>0) then ; do k=1,nz - CS%Mixing_Length(i,j,k) = mixlen(k) + ! Write mixing length and velocity scale to 3-D arrays for diagnostic output + if (CS%debug .or. (CS%id_Mixing_Length > 0)) then ; do K=1,nz+1 + diag_Mixing_Length(i,j,K) = mixlen(K) enddo ; endif - if (CS%id_Velocity_Scale>0) then ; do k=1,nz - CS%Velocity_Scale(i,j,k) = mixvel(k) + if (CS%debug .or. (CS%id_Velocity_Scale > 0)) then ; do K=1,nz+1 + diag_Velocity_Scale(i,j,K) = mixvel(K) enddo ; endif - if (allocated(CS%mstar_mix)) CS%mstar_mix(i,j) = eCD%mstar - if (allocated(CS%mstar_lt)) CS%mstar_lt(i,j) = eCD%mstar_LT - if (allocated(CS%La)) CS%La(i,j) = eCD%LA - if (allocated(CS%La_mod)) CS%La_mod(i,j) = eCD%LAmod + if (BBL_mixing) then + if (CS%debug .or. (CS%id_BBL_Mix_Length>0)) then ; do k=1,nz + BBL_Mix_Length(i,j,k) = mixlen_BBL(k) + enddo ; endif + if (CS%debug .or. (CS%id_BBL_Vel_Scale>0)) then ; do k=1,nz + BBL_Vel_Scale(i,j,k) = mixvel_BBL(k) + enddo ; endif + if (CS%id_TKE_BBL>0) & + diag_TKE_BBL(i,j) = diag_TKE_BBL(i,j) + BBL_TKE + endif + if (CS%id_mstar_sfc > 0) diag_mstar_sfc(i,j) = eCD%mstar + if (CS%id_mstar_bbl > 0) diag_mstar_BBL(i,j) = eCD%mstar_BBL + if (CS%id_mstar_LT > 0) diag_mstar_lt(i,j) = eCD%mstar_LT + if (CS%id_LA > 0) diag_LA(i,j) = eCD%LA + if (CS%id_LA_mod > 0) diag_LA_mod(i,j) = eCD%LAmod + if (report_avg_its) then + CS%sum_its(1) = CS%sum_its(1) + real_to_EFP(real(eCD%OBL_its)) + CS%sum_its(2) = CS%sum_its(2) + real_to_EFP(1.0) + if (BBL_mixing) then + CS%sum_its_BBL(1) = CS%sum_its_BBL(1) + real_to_EFP(real(eCD%BBL_its)) + CS%sum_its_BBL(2) = CS%sum_its_BBL(2) + real_to_EFP(1.0) + endif + endif + + if (CS%options_diff > 0) then + ! Call ePBL_column of ePBL_BBL_column with different parameter settings to diagnose sensitivities. + ! These do not change the model state, and are only used for diagnostic purposes. + if (CS%options_diff < 4) then + BLD_1 = MLD_in ; BLD_2 = MLD_in + do K=1,nz+1 ; SpV_dt_tmp(K) = SpV_scale1 * SpV_dt(K) ; enddo + call ePBL_column(h, dz, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, SpV_dt_tmp, TKE_forcing, & + B_flux, absf, u_star, u_star_mean, mech_TKE, dt, BLD_1, Kd_1, & + mixvel, mixlen, GV, US, CS_tmp1, eCD_tmp, Waves, G, i, j) + do K=1,nz+1 ; SpV_dt_tmp(K) = SpV_scale2 * SpV_dt(K) ; enddo + call ePBL_column(h, dz, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, SpV_dt_tmp, TKE_forcing, & + B_flux, absf, u_star, u_star_mean, mech_TKE, dt, BLD_2, Kd_2, & + mixvel, mixlen, GV, US, CS_tmp2, eCD_tmp, Waves, G, i, j) + else + BLD_1 = BBLD_in ; BLD_2 = BBLD_in + BBL_TKE = CS%ePBL_BBL_effic * GV%H_to_RZ * dt * visc%BBL_meanKE_loss(i,j) + if ((CS%ePBL_tidal_effic > 0.0) .and. associated(fluxes%BBL_tidal_dis)) & + BBL_TKE = BBL_TKE + CS%ePBL_tidal_effic * dt * fluxes%BBL_tidal_dis(i,j) + u_star_BBL = max(visc%ustar_BBL(i,j), CS%ustar_min*GV%Z_to_H) + u_star_BBL_z_t = u_star_bbl*GV%H_to_Z + call ePBL_BBL_column(h, dz, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, SpV_dt, absf, dt, Kd, BBL_TKE, & + u_star_BBL, u_star_BBL_z_t, BBL_buoy_flux(i,j), Kd_1, BLD_1, mixvel_BBL, mixlen_BBL, & + GV, US, CS_tmp1, eCD_tmp) + call ePBL_BBL_column(h, dz, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, SpV_dt, absf, dt, Kd, BBL_TKE, & + u_star_BBL, u_star_BBL_z_t, BBL_buoy_flux(i,j), Kd_2, BLD_2, mixvel_BBL, mixlen_BBL, & + GV, US, CS_tmp2, eCD_tmp) + endif + + if (CS%id_opt_diff_Kd_ePBL > 0) then + do K=1,nz+1 ; diff_Kd(i,j,K) = Kd_1(K) - Kd_2(K) ; enddo + endif + if (CS%id_opt_maxdiff_Kd_ePBL > 0) then + max_abs_diff_Kd(i,j) = 0.0 + do K=1,nz+1 ; max_abs_diff_Kd(i,j) = max(max_abs_diff_Kd(i,j), abs(Kd_1(K) - Kd_2(K))) ; enddo + endif + if (CS%id_opt_diff_hML_depth > 0) diff_hML_depth(i,j) = BLD_1 - BLD_2 + endif + else ! End of the ocean-point part of the i-loop ! For masked points, Kd_int must still be set (to 0) because it has intent out. do K=1,nz+1 ; Kd_2d(i,K) = 0. ; enddo CS%ML_depth(i,j) = 0.0 - endif ; enddo ! Close of i-loop - Note unusual loop order! + CS%BBL_depth(i,j) = 0.0 + endif ; enddo ! Close of i-loop - Note the unusual loop order, with k-loops inside i-loops. do K=1,nz+1 ; do i=is,ie ; Kd_int(i,j,K) = Kd_2d(i,K) ; enddo ; enddo enddo ! j-loop + if (CS%id_Kd_ePBL_col_by_col > 0) call post_data_3d_final(CS%id_Kd_ePBL_col_by_col, CS%diag) + + if (CS%debug .and. BBL_mixing) then + call hchksum(visc%BBL_meanKE_loss, "ePBL visc%BBL_meanKE_loss", G%HI, & + unscale=GV%H_to_MKS*US%L_T_to_m_s**2*US%s_to_T) + call hchksum(visc%ustar_BBL, "ePBL visc%ustar_BBL", G%HI, unscale=GV%H_to_MKS*US%s_to_T) + call hchksum(Kd_int, "End of ePBL Kd_int", G%HI, unscale=GV%H_to_MKS*US%Z_to_m*US%s_to_T) + call hchksum(diag_Velocity_Scale, "ePBL Velocity_Scale", G%HI, unscale=US%Z_to_m*US%s_to_T) + call hchksum(diag_Mixing_Length, "ePBL Mixing_Length", G%HI, unscale=US%Z_to_m) + call hchksum(BBL_Vel_Scale, "ePBL BBL_Vel_Scale", G%HI, unscale=US%Z_to_m*US%s_to_T) + call hchksum(BBL_Mix_Length, "ePBL BBL_Mix_Length", G%HI, unscale=US%Z_to_m) + endif if (CS%id_ML_depth > 0) call post_data(CS%id_ML_depth, CS%ML_depth, CS%diag) + if (CS%id_ustar_ePBL > 0) call post_data(CS%id_ustar_ePBL, diag_ustar, CS%diag) + if (CS%id_bflx_ePBL > 0) call post_data(CS%id_bflx_ePBL, buoy_flux, CS%diag) if (CS%id_hML_depth > 0) call post_data(CS%id_hML_depth, CS%ML_depth, CS%diag) - if (CS%id_TKE_wind > 0) call post_data(CS%id_TKE_wind, CS%diag_TKE_wind, CS%diag) - if (CS%id_TKE_MKE > 0) call post_data(CS%id_TKE_MKE, CS%diag_TKE_MKE, CS%diag) - if (CS%id_TKE_conv > 0) call post_data(CS%id_TKE_conv, CS%diag_TKE_conv, CS%diag) - if (CS%id_TKE_forcing > 0) call post_data(CS%id_TKE_forcing, CS%diag_TKE_forcing, CS%diag) - if (CS%id_TKE_mixing > 0) call post_data(CS%id_TKE_mixing, CS%diag_TKE_mixing, CS%diag) + if (CS%id_TKE_wind > 0) call post_data(CS%id_TKE_wind, diag_TKE_wind, CS%diag) + if (CS%id_TKE_MKE > 0) call post_data(CS%id_TKE_MKE, diag_TKE_MKE, CS%diag) + if (CS%id_TKE_conv > 0) call post_data(CS%id_TKE_conv, diag_TKE_conv, CS%diag) + if (CS%id_TKE_forcing > 0) call post_data(CS%id_TKE_forcing, diag_TKE_forcing, CS%diag) + if (CS%id_TKE_mixing > 0) call post_data(CS%id_TKE_mixing, diag_TKE_mixing, CS%diag) if (CS%id_TKE_mech_decay > 0) & - call post_data(CS%id_TKE_mech_decay, CS%diag_TKE_mech_decay, CS%diag) + call post_data(CS%id_TKE_mech_decay, diag_TKE_mech_decay, CS%diag) if (CS%id_TKE_conv_decay > 0) & - call post_data(CS%id_TKE_conv_decay, CS%diag_TKE_conv_decay, CS%diag) - if (CS%id_Mixing_Length > 0) call post_data(CS%id_Mixing_Length, CS%Mixing_Length, CS%diag) - if (CS%id_Velocity_Scale >0) call post_data(CS%id_Velocity_Scale, CS%Velocity_Scale, CS%diag) - if (CS%id_MSTAR_MIX > 0) call post_data(CS%id_MSTAR_MIX, CS%MSTAR_MIX, CS%diag) - if (CS%id_LA > 0) call post_data(CS%id_LA, CS%LA, CS%diag) - if (CS%id_LA_MOD > 0) call post_data(CS%id_LA_MOD, CS%LA_MOD, CS%diag) - if (CS%id_MSTAR_LT > 0) call post_data(CS%id_MSTAR_LT, CS%MSTAR_LT, CS%diag) - if (stoch_CS%pert_epbl) then + call post_data(CS%id_TKE_conv_decay, diag_TKE_conv_decay, CS%diag) + if (CS%id_Mixing_Length > 0) call post_data(CS%id_Mixing_Length, diag_Mixing_Length, CS%diag) + if (CS%id_Velocity_Scale >0) call post_data(CS%id_Velocity_Scale, diag_Velocity_Scale, CS%diag) + if (CS%id_mstar_sfc > 0) call post_data(CS%id_mstar_sfc, diag_mstar_sfc, CS%diag) + if (BBL_mixing) then + if (CS%id_Kd_BBL > 0) call post_data(CS%id_Kd_BBL, Kd_BBL_3d, CS%diag) + if (CS%id_BBL_Mix_Length > 0) call post_data(CS%id_BBL_Mix_Length, BBL_Mix_Length, CS%diag) + if (CS%id_BBL_Vel_Scale > 0) call post_data(CS%id_BBL_Vel_Scale, BBL_Vel_Scale, CS%diag) + if (CS%id_ustar_BBL > 0) call post_data(CS%id_ustar_BBL, diag_ustar_BBL, CS%diag) + if (CS%id_BBL_decay_scale > 0) call post_data(CS%id_BBL_decay_scale, diag_BBL_decay_scale, CS%diag) + if (CS%id_TKE_BBL > 0) call post_data(CS%id_TKE_BBL, diag_TKE_BBL, CS%diag) + if (CS%id_TKE_BBL_mixing > 0) call post_data(CS%id_TKE_BBL_mixing, diag_TKE_BBL_mixing, CS%diag) + if (CS%id_TKE_BBL_decay > 0) call post_data(CS%id_TKE_BBL_decay, diag_TKE_BBL_decay, CS%diag) + if (CS%id_BBL_depth > 0) call post_data(CS%id_BBL_depth, CS%BBL_depth, CS%diag) + if (CS%id_mstar_BBL > 0) call post_data(CS%id_mstar_BBL, diag_mstar_BBL, CS%diag) + endif + if (CS%id_LA > 0) call post_data(CS%id_LA, diag_LA, CS%diag) + if (CS%id_LA_mod > 0) call post_data(CS%id_LA_mod, diag_LA_mod, CS%diag) + if (CS%id_mstar_LT > 0) call post_data(CS%id_mstar_LT, diag_mstar_LT, CS%diag) + if (stoch_CS%pert_epbl) then if (stoch_CS%id_epbl1_wts > 0) call post_data(stoch_CS%id_epbl1_wts, stoch_CS%epbl1_wts, CS%diag) if (stoch_CS%id_epbl2_wts > 0) call post_data(stoch_CS%id_epbl2_wts, stoch_CS%epbl2_wts, CS%diag) endif + + if (CS%options_diff > 0) then + ! These diagnostics are only for determining sensitivities to different ePBL settings. + if (CS%id_opt_diff_Kd_ePBL > 0) call post_data(CS%id_opt_diff_Kd_ePBL, diff_Kd, CS%diag) + if (CS%id_opt_maxdiff_Kd_ePBL > 0) call post_data(CS%id_opt_maxdiff_Kd_ePBL, max_abs_diff_Kd, CS%diag) + if (CS%id_opt_diff_hML_depth > 0) call post_data(CS%id_opt_diff_hML_depth, diff_hML_depth, CS%diag) + endif + end subroutine energetic_PBL !> This subroutine determines the diffusivities from the integrated energetics !! mixed layer model for a single column of water. -subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, absf, & - u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, US, CS, eCD, & - Waves, G, i, j, epbl1_wt, epbl2_wt) +subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, TKE_forcing, B_flux, absf, & + u_star, u_star_mean, mech_TKE_in, dt, MLD_io, Kd, mixvel, mixlen, GV, US, CS, eCD, & + Waves, G, i, j, TKE_gen_stoch, TKE_diss_stoch) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZK_(GV)), intent(in) :: dz !< The vertical distance across layers [Z ~> m]. real, dimension(SZK_(GV)), intent(in) :: u !< Zonal velocities interpolated to h points !! [L T-1 ~> m s-1]. real, dimension(SZK_(GV)), intent(in) :: v !< Zonal velocities interpolated to h points !! [L T-1 ~> m s-1]. - real, dimension(SZK_(GV)), intent(in) :: T0 !< The initial layer temperatures [degC]. - real, dimension(SZK_(GV)), intent(in) :: S0 !< The initial layer salinities [ppt]. + real, dimension(SZK_(GV)), intent(in) :: T0 !< The initial layer temperatures [C ~> degC]. + real, dimension(SZK_(GV)), intent(in) :: S0 !< The initial layer salinities [S ~> ppt]. real, dimension(SZK_(GV)), intent(in) :: dSV_dT !< The partial derivative of in-situ specific !! volume with potential temperature - !! [R-1 degC-1 ~> m3 kg-1 degC-1]. + !! [R-1 C-1 ~> m3 kg-1 degC-1]. real, dimension(SZK_(GV)), intent(in) :: dSV_dS !< The partial derivative of in-situ specific - !! volume with salinity [R-1 ppt-1 ~> m3 kg-1 ppt-1]. + !! volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. + real, dimension(SZK_(GV)+1), intent(in) :: SpV_dt !< Specific volume interpolated to interfaces + !! divided by dt or 1.0 / (dt * Rho0), times conversion + !! factors for answer dates before 20240101 in + !! [m3 Z-3 R-1 T2 s-3 ~> m3 kg-1 s-1] or without + !! the conversion factors for answer dates of + !! 20240101 and later in [R-1 T-1 ~> m3 kg-1 s-1], + !! used to convert local TKE into a turbulence + !! velocity cubed. real, dimension(SZK_(GV)), intent(in) :: TKE_forcing !< The forcing requirements to homogenize the !! forcing that has been applied to each layer !! [R Z3 T-2 ~> J m-2]. @@ -524,25 +928,29 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs real, intent(in) :: u_star !< The surface friction velocity [Z T-1 ~> m s-1]. real, intent(in) :: u_star_mean !< The surface friction velocity without any !! contribution from unresolved gustiness [Z T-1 ~> m s-1]. + real, intent(in) :: mech_TKE_in !< The mechanically generated turbulent + !! kinetic energy available for mixing over a time + !! step before the application of the efficiency + !! in mstar. [R Z3 T-2 ~> J m-2]. real, intent(inout) :: MLD_io !< A first guess at the mixed layer depth on input, and - !! the calculated mixed layer depth on output [Z ~> m]. + !! the calculated mixed layer depth on output [Z ~> m] real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZK_(GV)+1), & intent(out) :: Kd !< The diagnosed diffusivities at interfaces - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZK_(GV)+1), & intent(out) :: mixvel !< The mixing velocity scale used in Kd !! [Z T-1 ~> m s-1]. real, dimension(SZK_(GV)+1), & intent(out) :: mixlen !< The mixing length scale used in Kd [Z ~> m]. - type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control struct + type(energetic_PBL_CS), intent(in) :: CS !< Energetic PBL control structure type(ePBL_column_diags), intent(inout) :: eCD !< A container for passing around diagnostics. type(wave_parameters_CS), pointer :: Waves !< Waves control structure for Langmuir turbulence - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - real, optional, intent(in) :: epbl1_wt !< random number to perturb KE generation - real, optional, intent(in) :: epbl2_wt !< random number to perturb KE dissipation + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. integer, intent(in) :: i !< The i-index to work on (used for Waves) - integer, intent(in) :: j !< The i-index to work on (used for Waves) + integer, intent(in) :: j !< The j-index to work on (used for Waves) + real, optional, intent(in) :: TKE_gen_stoch !< random factor used to perturb TKE generation [nondim] + real, optional, intent(in) :: TKE_diss_stoch !< random factor used to perturb TKE dissipation [nondim] ! This subroutine determines the diffusivities in a single column from the integrated energetics ! planetary boundary layer (ePBL) model. It assumes that heating, cooling and freshwater fluxes @@ -568,60 +976,66 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs real :: conv_PErel ! The potential energy that has been convectively released ! during this timestep [R Z3 T-2 ~> J m-2]. A portion nstar_FC ! of conv_PErel is available to drive mixing. - real :: htot ! The total depth of the layers above an interface [H ~> m or kg m-2]. - real :: uhtot ! The depth integrated zonal and meridional velocities in the - real :: vhtot ! layers above [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + real :: htot ! The total thickness of the layers above an interface [H ~> m or kg m-2]. + real :: dztot ! The total depth of the layers above an interface [Z ~> m]. + real :: uhtot ! The depth integrated zonal velocities in the layers above [H L T-1 ~> m2 s-1 or kg m-1 s-1] + real :: vhtot ! The depth integrated meridional velocities in the layers above [H L T-1 ~> m2 s-1 or kg m-1 s-1] real :: Idecay_len_TKE ! The inverse of a turbulence decay length scale [H-1 ~> m-1 or m2 kg-1]. - real :: h_sum ! The total thickness of the water column [H ~> m or kg m-2]. + real :: dz_sum ! The total thickness of the water column [Z ~> m]. real, dimension(SZK_(GV)) :: & dT_to_dColHt, & ! Partial derivative of the total column height with the temperature changes - ! within a layer [Z degC-1 ~> m degC-1]. + ! within a layer [Z C-1 ~> m degC-1]. dS_to_dColHt, & ! Partial derivative of the total column height with the salinity changes - ! within a layer [Z ppt-1 ~> m ppt-1]. + ! within a layer [Z S-1 ~> m ppt-1]. dT_to_dPE, & ! Partial derivatives of column potential energy with the temperature - ! changes within a layer, in [R Z3 T-2 degC-1 ~> J m-2 degC-1]. + ! changes within a layer, in [R Z3 T-2 C-1 ~> J m-2 degC-1]. dS_to_dPE, & ! Partial derivatives of column potential energy with the salinity changes - ! within a layer, in [R Z3 T-2 ppt-1 ~> J m-2 ppt-1]. + ! within a layer, in [R Z3 T-2 S-1 ~> J m-2 ppt-1]. dT_to_dColHt_a, & ! Partial derivative of the total column height with the temperature changes ! within a layer, including the implicit effects of mixing with layers higher - ! in the water column [Z degC-1 ~> m degC-1]. + ! in the water column [Z C-1 ~> m degC-1]. dS_to_dColHt_a, & ! Partial derivative of the total column height with the salinity changes ! within a layer, including the implicit effects of mixing with layers higher - ! in the water column [Z ppt-1 ~> m ppt-1]. + ! in the water column [Z S-1 ~> m ppt-1]. dT_to_dPE_a, & ! Partial derivatives of column potential energy with the temperature changes ! within a layer, including the implicit effects of mixing with layers higher - ! in the water column [R Z3 T-2 degC-1 ~> J m-2 degC-1]. + ! in the water column [R Z3 T-2 C-1 ~> J m-2 degC-1]. dS_to_dPE_a, & ! Partial derivative of column potential energy with the salinity changes ! within a layer, including the implicit effects of mixing with layers higher - ! in the water column [R Z3 T-2 ppt-1 ~> J m-2 ppt-1]. + ! in the water column [R Z3 T-2 S-1 ~> J m-2 ppt-1]. c1, & ! c1 is used by the tridiagonal solver [nondim]. - Te, & ! Estimated final values of T in the column [degC]. - Se, & ! Estimated final values of S in the column [ppt]. - dTe, & ! Running (1-way) estimates of temperature change [degC]. - dSe, & ! Running (1-way) estimates of salinity change [ppt]. + Te, & ! Estimated final values of T in the column [C ~> degC]. + Se, & ! Estimated final values of S in the column [S ~> ppt]. + dTe, & ! Running (1-way) estimates of temperature change [C ~> degC]. + dSe, & ! Running (1-way) estimates of salinity change [S ~> ppt]. + hp_a, & ! An effective pivot thickness of the layer including the effects + ! of coupling with layers above [H ~> m or kg m-2]. This is the first term + ! in the denominator of b1 in a downward-oriented tridiagonal solver. Th_a, & ! An effective temperature times a thickness in the layer above, including implicit - ! mixing effects with other yet higher layers [degC H ~> degC m or degC kg m-2]. + ! mixing effects with other yet higher layers [C H ~> degC m or degC kg m-2]. Sh_a, & ! An effective salinity times a thickness in the layer above, including implicit - ! mixing effects with other yet higher layers [ppt H ~> ppt m or ppt kg m-2]. + ! mixing effects with other yet higher layers [S H ~> ppt m or ppt kg m-2]. Th_b, & ! An effective temperature times a thickness in the layer below, including implicit - ! mixing effects with other yet lower layers [degC H ~> degC m or degC kg m-2]. + ! mixing effects with other yet lower layers [C H ~> degC m or degC kg m-2]. Sh_b ! An effective salinity times a thickness in the layer below, including implicit - ! mixing effects with other yet lower layers [ppt H ~> ppt m or ppt kg m-2]. + ! mixing effects with other yet lower layers [S H ~> ppt m or ppt kg m-2]. real, dimension(SZK_(GV)+1) :: & MixLen_shape, & ! A nondimensional shape factor for the mixing length that - ! gives it an appropriate assymptotic value at the bottom of - ! the boundary layer. - Kddt_h ! The diapycnal diffusivity times a timestep divided by the - ! average thicknesses around a layer [H ~> m or kg m-2]. + ! gives it an appropriate asymptotic value at the bottom of + ! the boundary layer [nondim]. + h_dz_int, & ! The ratio of the layer thicknesses over the vertical distances + ! across the layers surrounding an interface [H Z-1 ~> nondim or kg m-3] + Kddt_h ! The total diapycnal diffusivity at an interface times a timestep divided by the + ! average thicknesses around an interface [H ~> m or kg m-2]. real :: b1 ! b1 is inverse of the pivot used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. - real :: hp_a ! An effective pivot thickness of the layer including the effects - ! of coupling with layers above [H ~> m or kg m-2]. This is the first term - ! in the denominator of b1 in a downward-oriented tridiagonal solver. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. real :: dMass ! The mass per unit area within a layer [Z R ~> kg m-2]. - real :: dPres ! The hydrostatic pressure change across a layer [R Z2 T-2 ~> Pa = J m-3]. + real :: dPres ! The hydrostatic pressure change across a layer [R Z2 T-2 ~> Pa] or + ! equivalently [R Z2 T-2 ~> J m-3]. real :: dMKE_max ! The maximum amount of mean kinetic energy that could be ! converted to turbulent kinetic energy if the velocity in ! the layer below an interface were homogenized with all of @@ -630,50 +1044,47 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs ! of a layer and the thickness of the water above, used in ! the MKE conversion equation [H-1 ~> m-1 or m2 kg-1]. - real :: dt_h ! The timestep divided by the averages of the thicknesses around - ! a layer, times a thickness conversion factor [H T Z-2 ~> s m-1 or kg s m-4]. - real :: h_bot ! The distance from the bottom [H ~> m or kg m-2]. - real :: h_rsum ! The running sum of h from the top [Z ~> m]. - real :: I_hs ! The inverse of h_sum [H-1 ~> m-1 or m2 kg-1]. + real :: dt_h ! The timestep divided by the averages of the vertical distances around + ! a layer [T Z-1 ~> s m-1]. + real :: dz_bot ! The distance from the bottom [Z ~> m]. + real :: dz_rsum ! The running sum of dz from the top [Z ~> m]. + real :: I_dzsum ! The inverse of dz_sum [Z-1 ~> m-1]. real :: I_MLD ! The inverse of the current value of MLD [Z-1 ~> m-1]. - real :: h_tt ! The distance from the surface or up to the next interface + real :: dz_tt ! The distance from the surface or up to the next interface ! that did not exhibit turbulent mixing from this scheme plus - ! a surface mixing roughness length given by h_tt_min [H ~> m or kg m-2]. - real :: h_tt_min ! A surface roughness length [H ~> m or kg m-2]. + ! a surface mixing roughness length given by dz_tt_min [Z ~> m]. + real :: dz_tt_min ! A surface roughness length [Z ~> m]. - real :: C1_3 ! = 1/3. - real :: I_dtrho ! 1.0 / (dt * Rho0) times conversion factors in [m3 Z-3 R-1 T2 s-3 ~> m3 kg-1 s-1]. - ! This is used convert TKE back into ustar^3. + real :: C1_3 ! = 1/3 [nondim] real :: vstar ! An in-situ turbulent velocity [Z T-1 ~> m s-1]. real :: mstar_total ! The value of mstar used in ePBL [nondim] real :: mstar_LT ! An addition to mstar due to Langmuir turbulence [nondim] (output for diagnostic) - real :: MLD_output ! The mixed layer depth output from this routine [Z ~> m]. + real :: MLD_output ! The mixed layer depth output from this routine [Z ~> m] real :: LA ! The value of the Langmuir number [nondim] real :: LAmod ! The modified Langmuir number by convection [nondim] - real :: hbs_here ! The local minimum of hb_hs and MixLen_shape, times a - ! conversion factor from H to Z [Z H-1 ~> nondim or m3 kg-1]. + real :: hbs_here ! The local minimum of hb_hs and MixLen_shape [nondim] real :: nstar_FC ! The fraction of conv_PErel that can be converted to mixing [nondim]. real :: TKE_reduc ! The fraction by which TKE and other energy fields are ! reduced to support mixing [nondim]. between 0 and 1. real :: tot_TKE ! The total TKE available to support mixing at interface K [R Z3 T-2 ~> J m-2]. real :: TKE_here ! The total TKE at this point in the algorithm [R Z3 T-2 ~> J m-2]. real :: dT_km1_t2 ! A diffusivity-independent term related to the temperature - ! change in the layer above the interface [degC]. + ! change in the layer above the interface [C ~> degC]. real :: dS_km1_t2 ! A diffusivity-independent term related to the salinity - ! change in the layer above the interface [ppt]. + ! change in the layer above the interface [S ~> ppt]. real :: dTe_term ! A diffusivity-independent term related to the temperature - ! change in the layer below the interface [degC H ~> degC m or degC kg m-2]. + ! change in the layer below the interface [C H ~> degC m or degC kg m-2]. real :: dSe_term ! A diffusivity-independent term related to the salinity - ! change in the layer above the interface [ppt H ~> ppt m or ppt kg m-2]. - real :: dTe_t2 ! A part of dTe_term [degC H ~> degC m or degC kg m-2]. - real :: dSe_t2 ! A part of dSe_term [ppt H ~> ppt m or ppt kg m-2]. + ! change in the layer above the interface [S H ~> ppt m or ppt kg m-2]. + real :: dTe_t2 ! A part of dTe_term [C H ~> degC m or degC kg m-2]. + real :: dSe_t2 ! A part of dSe_term [S H ~> ppt m or ppt kg m-2]. real :: dPE_conv ! The convective change in column potential energy [R Z3 T-2 ~> J m-2]. real :: MKE_src ! The mean kinetic energy source of TKE due to Kddt_h(K) [R Z3 T-2 ~> J m-2]. real :: dMKE_src_dK ! The partial derivative of MKE_src with Kddt_h(K) [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. - real :: Kd_guess0 ! A first guess of the diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. + real :: Kd_guess0 ! A first guess of the diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real :: PE_chg_g0 ! The potential energy change when Kd is Kd_guess0 [R Z3 T-2 ~> J m-2] - real :: Kddt_h_g0 ! The first guess diapycnal diffusivity times a timestep divided - ! by the average thicknesses around a layer [H ~> m or kg m-2]. + real :: Kddt_h_g0 ! The first guess of the change in diapycnal diffusivity times a timestep + ! divided by the average thicknesses around an interface [H ~> m or kg m-2]. real :: PE_chg_max ! The maximum PE change for very large values of Kddt_h(K) [R Z3 T-2 ~> J m-2]. real :: dPEc_dKd_Kd0 ! The partial derivative of PE change with Kddt_h(K) ! for very small values of Kddt_h(K) [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. @@ -691,7 +1102,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs real :: dKddt_h_Newt ! The change between guesses at Kddt_h(K) with Newton's method [H ~> m or kg m-2]. real :: Kddt_h_newt ! The Newton's method next guess for Kddt_h(K) [H ~> m or kg m-2]. real :: exp_kh ! The nondimensional decay of TKE across a layer [nondim]. - real :: vstar_unit_scale ! A unit converion factor for turbulent velocities [Z T-1 s m-1 ~> 1] + real :: vstar_unit_scale ! A unit conversion factor for turbulent velocities [Z T-1 s m-1 ~> 1] logical :: use_Newt ! Use Newton's method for the next guess at Kddt_h(K). logical :: convectively_stable ! If true the water column is convectively stable at this interface. logical :: sfc_connected ! If true the ocean is actively turbulent from the present @@ -699,15 +1110,15 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs logical :: sfc_disconnect ! If true, any turbulence has become disconnected ! from the surface. -! The following are only used for diagnostics. + ! The following is only used for diagnostics. real :: I_dtdiag ! = 1.0 / dt [T-1 ~> s-1]. !---------------------------------------------------------------------- !/BGR added Aug24,2016 for adding iteration to get boundary layer depth ! - needed to compute new mixing length. - real :: MLD_guess, MLD_found ! Mixing Layer depth guessed/found for iteration [Z ~> m]. - real :: min_MLD ! Iteration bounds [Z ~> m], which are adjusted at each step - real :: max_MLD ! - These are initialized based on surface/bottom + real :: MLD_guess, MLD_found ! Mixing Layer depth guessed/found for iteration [Z ~> m] + real :: min_MLD, max_MLD ! Iteration bounds on MLD [Z ~> m], which are adjusted at each step + ! - These are initialized based on surface/bottom ! 1. The iteration guesses a value (possibly from prev step or neighbor). ! 2. The iteration checks if value is converged, too shallow, or too deep. ! 3. Based on result adjusts the Max/Min and searches through the water column. @@ -721,38 +1132,57 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs ! can improve this. real :: dMLD_min ! The change in diagnosed mixed layer depth when the guess is min_MLD [Z ~> m] real :: dMLD_max ! The change in diagnosed mixed layer depth when the guess is max_MLD [Z ~> m] - logical :: FIRST_OBL ! Flag for computing "found" Mixing layer depth - logical :: OBL_converged ! Flag for convergence of MLD integer :: OBL_it ! Iteration counter - real :: Surface_Scale ! Surface decay scale for vstar + real :: TKE_used ! The TKE used to support mixing at an interface [R Z3 T-2 ~> J m-2]. + ! real :: Kd_add ! The additional diffusivity at an interface [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: frac_in_BL ! The fraction of the energy required to support dKd_max that is suppiled by + ! max_PE_chg, used here to determine a fractional layer contribution to the + ! boundary layer thickness [nondim] + real :: Surface_Scale ! Surface decay scale for vstar [nondim] logical :: calc_Te ! If true calculate the expected final temperature and salinity values. + logical :: no_MKE_conversion ! If true, there is no conversion from MKE to TKE, so a simpler solver can be used. logical :: debug ! This is used as a hard-coded value for debugging. + logical :: convectively_unstable ! If true, there is convective instability at an interface. ! The following arrays are used only for debugging purposes. - real :: dPE_debug, mixing_debug, taux2, tauy2 - real, dimension(20) :: TKE_left_itt, PE_chg_itt, Kddt_h_itt, dPEa_dKd_itt, MKE_src_itt - real, dimension(SZK_(GV)) :: mech_TKE_k, conv_PErel_k, nstar_k - real, dimension(SZK_(GV)) :: dT_expect !< Expected temperature changes [degC] - real, dimension(SZK_(GV)) :: dS_expect !< Expected salinity changes [ppt] + real :: dPE_debug ! An estimate of the potential energy change [R Z3 T-2 ~> J m-2] + real :: mixing_debug ! An estimate of the rate of change of potential energy due to mixing [R Z3 T-3 ~> W m-2] + real, dimension(20) :: TKE_left_itt ! The value of TKE_left after each iteration [R Z3 T-2 ~> J m-2] + real, dimension(20) :: PE_chg_itt ! The value of PE_chg after each iteration [R Z3 T-2 ~> J m-2] + real, dimension(20) :: Kddt_h_itt ! The value of Kddt_h_guess after each iteration [H ~> m or kg m-2] + real, dimension(20) :: dPEa_dKd_itt ! The value of dPEc_dKd after each iteration [R Z3 T-2 H-1 ~> J m-3 or J kg-1] + real, dimension(20) :: MKE_src_itt ! The value of MKE_src after each iteration [R Z3 T-2 ~> J m-2] + real, dimension(SZK_(GV)) :: mech_TKE_k ! The mechanically generated turbulent kinetic energy + ! available for mixing over a time step for each layer [R Z3 T-2 ~> J m-2]. + real, dimension(SZK_(GV)) :: conv_PErel_k ! The potential energy that has been convectively released + ! during this timestep for each layer [R Z3 T-2 ~> J m-2]. + real, dimension(SZK_(GV)) :: nstar_k ! The fraction of conv_PErel that can be converted to mixing + ! for each layer [nondim]. + real, dimension(SZK_(GV)) :: dT_expect ! Expected temperature changes [C ~> degC] + real, dimension(SZK_(GV)) :: dS_expect ! Expected salinity changes [S ~> ppt] integer, dimension(SZK_(GV)) :: num_itts integer :: k, nz, itt, max_itt + ! variables for ML based diffusivity + real :: v0_ML_turb_vel_scale ! turbulence vel scale from ML in diffusivity [Z T-1 ~> m s-1] + nz = GV%ke debug = .false. ! Change this hard-coded value for debugging. calc_Te = (debug .or. (.not.CS%orig_PE_calc)) + no_MKE_conversion = ((CS%direct_calc) .and. (CS%MKE_to_TKE_effic == 0.0)) h_neglect = GV%H_subroundoff + dz_neglect = GV%dZ_subroundoff C1_3 = 1.0 / 3.0 I_dtdiag = 1.0 / dt max_itt = 20 - h_tt_min = 0.0 - I_dtrho = 0.0 ; if (dt*GV%Rho0 > 0.0) I_dtrho = (US%Z_to_m**3*US%s_to_T**3) / (dt*GV%Rho0) - vstar_unit_scale = US%m_to_Z * US%T_to_s + dz_tt_min = 0.0 + if (CS%answer_date < 20240101) vstar_unit_scale = US%m_to_Z * US%T_to_s MLD_guess = MLD_io @@ -768,7 +1198,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs pres_Z(1) = 0.0 do k=1,nz dMass = GV%H_to_RZ * h(k) - dPres = US%L_to_Z**2 * GV%g_Earth * dMass + dPres = GV%g_Earth_Z_T2 * dMass dT_to_dPE(k) = (dMass * (pres_Z(K) + 0.5*dPres)) * dSV_dT(k) dS_to_dPE(k) = (dMass * (pres_Z(K) + 0.5*dPres)) * dSV_dS(k) dT_to_dColHt(k) = dMass * dSV_dT(k) @@ -777,21 +1207,21 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs pres_Z(K+1) = pres_Z(K) + dPres enddo - ! Determine the total thickness (h_sum) and the fractional distance from the bottom (hb_hs). - h_sum = H_neglect ; do k=1,nz ; h_sum = h_sum + h(k) ; enddo - I_hs = 0.0 ; if (h_sum > 0.0) I_hs = 1.0 / h_sum - h_bot = 0.0 + ! Determine the total thickness (dz_sum) and the fractional distance from the bottom (hb_hs). + dz_sum = dz_neglect ; do k=1,nz ; dz_sum = dz_sum + dz(k) ; enddo + I_dzsum = 0.0 ; if (dz_sum > 0.0) I_dzsum = 1.0 / dz_sum + dz_bot = 0.0 hb_hs(nz+1) = 0.0 do k=nz,1,-1 - h_bot = h_bot + h(k) - hb_hs(K) = h_bot * I_hs + dz_bot = dz_bot + dz(k) + hb_hs(K) = dz_bot * I_dzsum enddo - MLD_output = h(1)*GV%H_to_Z + MLD_output = dz(1) !/The following lines are for the iteration over MLD ! max_MLD will initialized as ocean bottom depth - max_MLD = 0.0 ; do k=1,nz ; max_MLD = max_MLD + h(k)*GV%H_to_Z ; enddo + max_MLD = 0.0 ; do k=1,nz ; max_MLD = max_MLD + dz(k) ; enddo ! min_MLD will be initialized to 0. min_MLD = 0.0 ! Set values of the wrong signs to indicate that these changes are not based on valid estimates @@ -800,573 +1230,1483 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs ! If no first guess is provided for MLD, try the middle of the water column if (MLD_guess <= min_MLD) MLD_guess = 0.5 * (min_MLD + max_MLD) + if (GV%Boussinesq) then + do K=1,nz+1 ; h_dz_int(K) = GV%Z_to_H ; enddo + else + h_dz_int(1) = (h(1) + h_neglect) / (dz(1) + dz_neglect) + do K=2,nz + h_dz_int(K) = (h(k-1) + h(k) + h_neglect) / (dz(k-1) + dz(k) + dz_neglect) + enddo + h_dz_int(nz+1) = (h(nz) + h_neglect) / (dz(nz) + dz_neglect) + endif + ! Iterate to determine a converged EPBL depth. - OBL_converged = .false. do OBL_it=1,CS%Max_MLD_Its - if (.not. OBL_converged) then - ! If not using MLD_Iteration flag loop to only execute once. - if (.not.CS%Use_MLD_iteration) OBL_converged = .true. + if (debug) then ; mech_TKE_k(:) = 0.0 ; conv_PErel_k(:) = 0.0 ; endif - if (debug) then ; mech_TKE_k(:) = 0.0 ; conv_PErel_k(:) = 0.0 ; endif + ! Reset ML_depth + MLD_output = dz(1) + sfc_connected = .true. - ! Reset ML_depth - MLD_output = h(1)*GV%H_to_Z - sfc_connected = .true. + !/ Here we get mstar, which is the ratio of convective TKE driven mixing to UStar**3 + if (CS%Use_LT) then + call get_Langmuir_Number(LA, G, GV, US, abs(MLD_guess), u_star_mean, i, j, dz, Waves, & + U_H=u, V_H=v) + call find_mstar(CS, US, B_flux, u_star, MLD_guess, absf, .false., & + mstar_total, Langmuir_Number=La, Convect_Langmuir_Number=LAmod,& + mstar_LT=mstar_LT) + else + call find_mstar(CS, US, B_flux, u_star, MLD_guess, absf, .false., mstar_total) + endif + + !/ Apply mstar to get mech_TKE + if ((CS%answer_date < 20190101) .and. (CS%mstar_scheme==Use_Fixed_mstar)) then + mech_TKE = (dt*mstar_total*GV%Rho0) * u_star**3 + else + mech_TKE = mstar_total * mech_TKE_in + ! mech_TKE = mstar_total * (dt*GV%Rho0* u_star**3) + endif + ! stochastically perturb mech_TKE in the UFS + if (present(TKE_gen_stoch)) mech_TKE = mech_TKE*TKE_gen_stoch - !/ Here we get MStar, which is the ratio of convective TKE driven mixing to UStar**3 - if (CS%Use_LT) then - call get_Langmuir_Number(LA, G, GV, US, abs(MLD_guess), u_star_mean, i, j, h, Waves, & - U_H=u, V_H=v) - call find_mstar(CS, US, B_flux, u_star, u_star_Mean, MLD_Guess, absf, & - MStar_total, Langmuir_Number=La, Convect_Langmuir_Number=LAmod,& - mstar_LT=mstar_LT) + if (CS%TKE_diagnostics) then + eCD%dTKE_conv = 0.0 ; eCD%dTKE_mixing = 0.0 + eCD%dTKE_MKE = 0.0 ; eCD%dTKE_mech_decay = 0.0 ; eCD%dTKE_conv_decay = 0.0 + + eCD%dTKE_wind = mech_TKE * I_dtdiag + if (TKE_forcing(1) <= 0.0) then + eCD%dTKE_forcing = max(-mech_TKE, TKE_forcing(1)) * I_dtdiag + ! eCD%dTKE_unbalanced = min(0.0, TKE_forcing(1) + mech_TKE) * I_dtdiag else - call find_mstar(CS, US, B_flux, u_star, u_star_mean, MLD_guess, absf, mstar_total) + eCD%dTKE_forcing = CS%nstar*TKE_forcing(1) * I_dtdiag + ! eCD%dTKE_unbalanced = 0.0 endif + endif + + if (TKE_forcing(1) <= 0.0) then + mech_TKE = mech_TKE + TKE_forcing(1) + if (mech_TKE < 0.0) mech_TKE = 0.0 + conv_PErel = 0.0 + else + conv_PErel = TKE_forcing(1) + endif - !/ Apply MStar to get mech_TKE - if ((CS%answers_2018) .and. (CS%mstar_scheme==Use_Fixed_MStar)) then - mech_TKE = (dt*MSTAR_total*GV%Rho0) * u_star**3 + + ! Store in 1D arrays for output. + do K=1,nz+1 ; mixvel(K) = 0.0 ; mixlen(K) = 0.0 ; enddo + + ! Determine the mixing shape function MixLen_shape. + if ((.not.CS%Use_MLD_iteration) .or. & + (CS%transLay_scale >= 1.0) .or. (CS%transLay_scale < 0.0) ) then + do K=1,nz+1 + MixLen_shape(K) = 1.0 + enddo + elseif (MLD_guess <= 0.0) then + if (CS%transLay_scale > 0.0) then ; do K=1,nz+1 + MixLen_shape(K) = CS%transLay_scale + enddo ; else ; do K=1,nz+1 + MixLen_shape(K) = 1.0 + enddo ; endif + else + ! Reduce the mixing length based on MLD, with a quadratic + ! expression that follows KPP. + I_MLD = 1.0 / MLD_guess + dz_rsum = 0.0 + MixLen_shape(1) = 1.0 + if (CS%eqdisc) then ! update Kd as per Machine Learning equation discovery + call kappa_eqdisc(MixLen_shape, CS, GV, h, absf, B_flux, u_star, MLD_guess) else - mech_TKE = MSTAR_total * (dt*GV%Rho0* u_star**3) + do K=2,nz+1 + dz_rsum = dz_rsum + dz(k-1) + if (CS%MixLenExponent==2.0) then + MixLen_shape(K) = CS%transLay_scale + (1.0 - CS%transLay_scale) * & + (max(0.0, (MLD_guess - dz_rsum)*I_MLD) )**2 ! CS%MixLenExponent + else + MixLen_shape(K) = CS%transLay_scale + (1.0 - CS%transLay_scale) * & + (max(0.0, (MLD_guess - dz_rsum)*I_MLD) )**CS%MixLenExponent + endif + enddo endif - ! stochastically pertrub mech_TKE in the UFS - if (present(epbl1_wt)) mech_TKE=mech_TKE*epbl1_wt + endif - if (CS%TKE_diagnostics) then - eCD%dTKE_conv = 0.0 ; eCD%dTKE_mixing = 0.0 - eCD%dTKE_MKE = 0.0 ; eCD%dTKE_mech_decay = 0.0 ; eCD%dTKE_conv_decay = 0.0 + v0_ML_turb_vel_scale = 0.0 ! a variable that gets passed on to get_eqdisc_v0 & get_eqdisc_v0h + if (CS%eqdisc_v0) then + call get_eqdisc_v0(CS,absf,B_flux,u_star,v0_ML_turb_vel_scale) + elseif (CS%eqdisc_v0h) then + call get_eqdisc_v0h(CS,B_flux,u_star,MLD_guess,v0_ML_turb_vel_scale) + endif + + Kd(1) = 0.0 ; Kddt_h(1) = 0.0 + hp_a(1) = h(1) + dT_to_dPE_a(1) = dT_to_dPE(1) ; dT_to_dColHt_a(1) = dT_to_dColHt(1) + dS_to_dPE_a(1) = dS_to_dPE(1) ; dS_to_dColHt_a(1) = dS_to_dColHt(1) + + htot = h(1) ; dztot = dz(1) ; uhtot = u(1)*h(1) ; vhtot = v(1)*h(1) + + if (debug) then + mech_TKE_k(1) = mech_TKE ; conv_PErel_k(1) = conv_PErel + nstar_k(:) = 0.0 ; nstar_k(1) = CS%nstar ; num_itts(:) = -1 + endif - eCD%dTKE_wind = mech_TKE * I_dtdiag - if (TKE_forcing(1) <= 0.0) then - eCD%dTKE_forcing = max(-mech_TKE, TKE_forcing(1)) * I_dtdiag - ! eCD%dTKE_unbalanced = min(0.0, TKE_forcing(1) + mech_TKE) * I_dtdiag + do K=2,nz + ! Apply dissipation to the TKE, here applied as an exponential decay + ! due to 3-d turbulent energy being lost to inefficient rotational modes. + + ! There should be several different "flavors" of TKE that decay at + ! different rates. The following form is often used for mechanical + ! stirring from the surface, perhaps due to breaking surface gravity + ! waves and wind-driven turbulence. + if (GV%Boussinesq) then + Idecay_len_TKE = (CS%TKE_decay * absf / u_star) * GV%H_to_Z + else + Idecay_len_TKE = (CS%TKE_decay * absf) / (h_dz_int(K) * u_star) + endif + exp_kh = 1.0 + if (Idecay_len_TKE > 0.0) exp_kh = exp(-h(k-1)*Idecay_len_TKE) + if (CS%TKE_diagnostics) & + eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag + if (present(TKE_diss_stoch)) then ! perturb the TKE destruction + mech_TKE = mech_TKE * (1.0 + (exp_kh-1.0) * TKE_diss_stoch) + else + mech_TKE = mech_TKE * exp_kh + endif + + ! Accumulate any convectively released potential energy to contribute + ! to wstar and to drive penetrating convection. + if (TKE_forcing(k) > 0.0) then + conv_PErel = conv_PErel + TKE_forcing(k) + if (CS%TKE_diagnostics) & + eCD%dTKE_forcing = eCD%dTKE_forcing + CS%nstar*TKE_forcing(k) * I_dtdiag + endif + + if (debug) then + mech_TKE_k(K) = mech_TKE ; conv_PErel_k(K) = conv_PErel + endif + + ! Determine the total energy + nstar_FC = CS%nstar + if (CS%nstar * conv_PErel > 0.0) then + ! Here nstar is a function of the natural Rossby number 0.2/(1+0.2/Ro), based + ! on a curve fit from the data of Wang (GRL, 2003). + ! Note: Ro = 1.0 / sqrt(0.5 * dt * Rho0 * (absf*dztot)**3 / conv_PErel) + if (GV%Boussinesq) then + nstar_FC = CS%nstar * conv_PErel / (conv_PErel + 0.2 * & + sqrt(0.5 * dt * GV%Rho0 * (absf*dztot)**3 * conv_PErel)) else - eCD%dTKE_forcing = CS%nstar*TKE_forcing(1) * I_dtdiag - ! eCD%dTKE_unbalanced = 0.0 + nstar_FC = CS%nstar * conv_PErel / (conv_PErel + 0.2 * & + sqrt(0.5 * dt * GV%H_to_RZ * (absf**3 * (dztot**2 * htot)) * conv_PErel)) endif endif - if (TKE_forcing(1) <= 0.0) then - mech_TKE = mech_TKE + TKE_forcing(1) - if (mech_TKE < 0.0) mech_TKE = 0.0 - conv_PErel = 0.0 + if (debug) nstar_k(K) = nstar_FC + + tot_TKE = mech_TKE + nstar_FC * conv_PErel + + ! For each interior interface, first discard the TKE to account for + ! mixing of shortwave radiation through the next denser cell. + if (TKE_forcing(k) < 0.0) then + if (TKE_forcing(k) + tot_TKE < 0.0) then + ! The shortwave requirements deplete all the energy in this layer. + if (CS%TKE_diagnostics) then + eCD%dTKE_mixing = eCD%dTKE_mixing + tot_TKE * I_dtdiag + eCD%dTKE_forcing = eCD%dTKE_forcing - tot_TKE * I_dtdiag + ! eCD%dTKE_unbalanced = eCD%dTKE_unbalanced + (TKE_forcing(k) + tot_TKE) * I_dtdiag + eCD%dTKE_conv_decay = eCD%dTKE_conv_decay + (CS%nstar-nstar_FC) * conv_PErel * I_dtdiag + endif + tot_TKE = 0.0 ; mech_TKE = 0.0 ; conv_PErel = 0.0 + else + ! Reduce the mechanical and convective TKE proportionately. + TKE_reduc = (tot_TKE + TKE_forcing(k)) / tot_TKE + if (CS%TKE_diagnostics) then + eCD%dTKE_mixing = eCD%dTKE_mixing - TKE_forcing(k) * I_dtdiag + eCD%dTKE_forcing = eCD%dTKE_forcing + TKE_forcing(k) * I_dtdiag + eCD%dTKE_conv_decay = eCD%dTKE_conv_decay + & + (1.0-TKE_reduc)*(CS%nstar-nstar_FC) * conv_PErel * I_dtdiag + endif + tot_TKE = TKE_reduc*tot_TKE ! = tot_TKE + TKE_forcing(k) + mech_TKE = TKE_reduc*mech_TKE + conv_PErel = TKE_reduc*conv_PErel + endif + endif + + ! Precalculate some temporary expressions that are independent of Kddt_h(K). + if (CS%orig_PE_calc) then + if (K==2) then + dTe_t2 = 0.0 ; dSe_t2 = 0.0 + else + dTe_t2 = Kddt_h(K-1) * ((T0(k-2) - T0(k-1)) + dTe(k-2)) + dSe_t2 = Kddt_h(K-1) * ((S0(k-2) - S0(k-1)) + dSe(k-2)) + endif + endif + dt_h = dt / max(0.5*(dz(k-1)+dz(k)), 1e-15*dz_sum) + + ! This tests whether the layers above and below this interface are in + ! a convectively stable configuration, without considering any effects of + ! mixing at higher interfaces. It is an approximation to the more + ! complete test dPEc_dKd_Kd0 >= 0.0, that would include the effects of + ! mixing across interface K-1. The dT_to_dColHt here are effectively + ! mass-weighted estimates of dSV_dT. + Convectively_stable = ( 0.0 <= & + ( (dT_to_dColHt(k) + dT_to_dColHt(k-1) ) * (T0(k-1)-T0(k)) + & + (dS_to_dColHt(k) + dS_to_dColHt(k-1) ) * (S0(k-1)-S0(k)) ) ) + + if ((mech_TKE + conv_PErel) <= 0.0 .and. Convectively_stable) then + ! Energy is already exhausted, so set Kd = 0 and cycle or exit? + tot_TKE = 0.0 ; mech_TKE = 0.0 ; conv_PErel = 0.0 + Kd(K) = 0.0 ; Kddt_h(K) = 0.0 + sfc_disconnect = .true. + ! if (.not.debug) exit + + ! The estimated properties for layer k-1 can be calculated, using + ! greatly simplified expressions when Kddt_h = 0. This enables the + ! tridiagonal solver for the whole column to be completed for debugging + ! purposes, and also allows for something akin to convective adjustment + ! in unstable interior regions? + b1 = 1.0 / hp_a(k-1) + c1(K) = 0.0 + if (CS%orig_PE_calc) then + dTe(k-1) = b1 * ( dTe_t2 ) + dSe(k-1) = b1 * ( dSe_t2 ) + endif + + hp_a(k) = h(k) + dT_to_dPE_a(k) = dT_to_dPE(k) + dS_to_dPE_a(k) = dS_to_dPE(k) + dT_to_dColHt_a(k) = dT_to_dColHt(k) + dS_to_dColHt_a(k) = dS_to_dColHt(k) + + else ! tot_TKE > 0.0 or this is a potentially convectively unstable profile. + sfc_disconnect = .false. + + ! Precalculate some more temporary expressions that are independent of + ! Kddt_h(K). + if (CS%orig_PE_calc) then + if (K==2) then + dT_km1_t2 = (T0(k)-T0(k-1)) + dS_km1_t2 = (S0(k)-S0(k-1)) + else + dT_km1_t2 = (T0(k)-T0(k-1)) - & + (Kddt_h(K-1) / hp_a(k-1)) * ((T0(k-2) - T0(k-1)) + dTe(k-2)) + dS_km1_t2 = (S0(k)-S0(k-1)) - & + (Kddt_h(K-1) / hp_a(k-1)) * ((S0(k-2) - S0(k-1)) + dSe(k-2)) + endif + dTe_term = dTe_t2 + hp_a(k-1) * (T0(k-1)-T0(k)) + dSe_term = dSe_t2 + hp_a(k-1) * (S0(k-1)-S0(k)) + else + if (K<=2) then + Th_a(k-1) = h(k-1) * T0(k-1) ; Sh_a(k-1) = h(k-1) * S0(k-1) + else + Th_a(k-1) = h(k-1) * T0(k-1) + Kddt_h(K-1) * Te(k-2) + Sh_a(k-1) = h(k-1) * S0(k-1) + Kddt_h(K-1) * Se(k-2) + endif + Th_b(k) = h(k) * T0(k) ; Sh_b(k) = h(k) * S0(k) + endif + + ! Using Pr=1 and the diffusivity at the bottom interface (once it is + ! known), determine how much resolved mean kinetic energy (MKE) will be + ! extracted within a timestep and add a fraction CS%MKE_to_TKE_effic of + ! this to the mTKE budget available for mixing in the next layer. + + if ((CS%MKE_to_TKE_effic > 0.0) .and. (htot*h(k) > 0.0)) then + ! This is the energy that would be available from homogenizing the + ! velocities between layer k and the layers above. + dMKE_max = (GV%H_to_RZ * CS%MKE_to_TKE_effic) * 0.5 * & + (h(k) / ((htot + h(k))*htot)) * & + (((uhtot-u(k)*htot)**2) + ((vhtot-v(k)*htot)**2)) + ! A fraction (1-exp(Kddt_h*MKE2_Hharm)) of this energy would be + ! extracted by mixing with a finite viscosity. + MKE2_Hharm = (htot + h(k) + 2.0*h_neglect) / & + ((htot+h_neglect) * (h(k)+h_neglect)) + else + dMKE_max = 0.0 + MKE2_Hharm = 0.0 + endif + + ! At this point, Kddt_h(K) will be unknown because its value may depend + ! on how much energy is available. mech_TKE might be negative due to + ! contributions from TKE_forced. + dz_tt = dztot + dz_tt_min + TKE_here = mech_TKE + CS%wstar_ustar_coef*conv_PErel + if (TKE_here > 0.0) then + if (CS%answer_date < 20240101) then + if (CS%wT_scheme==wT_from_cRoot_TKE) then + vstar = CS%vstar_scale_fac * vstar_unit_scale * (SpV_dt(K)*TKE_here)**C1_3 + elseif (CS%wT_scheme==wT_from_RH18) then + Surface_Scale = max(0.05, 1.0 - dztot / MLD_guess) + vstar = CS%vstar_scale_fac * Surface_Scale * (CS%vstar_surf_fac*u_star + & + vstar_unit_scale * (CS%wstar_ustar_coef*conv_PErel*SpV_dt(K))**C1_3) + endif + else + if (CS%wT_scheme==wT_from_cRoot_TKE) then + vstar = CS%vstar_scale_fac * cuberoot(SpV_dt(K)*TKE_here) + elseif (CS%wT_scheme==wT_from_RH18) then + Surface_Scale = max(0.05, 1.0 - dztot / MLD_guess) + vstar = (CS%vstar_scale_fac * Surface_Scale) * ( CS%vstar_surf_fac*u_star + & + cuberoot((CS%wstar_ustar_coef*conv_PErel) * SpV_dt(K)) ) + endif + endif + hbs_here = min(hb_hs(K), MixLen_shape(K)) + mixlen(K) = max(CS%min_mix_len, ((dz_tt*hbs_here)*vstar) / & + ((CS%Ekman_scale_coef * absf) * (dz_tt*hbs_here) + vstar)) + !Note setting Kd_guess0 to vstar * CS%vonKar * mixlen(K) here will + ! change the answers. Therefore, skipping that. + if (.not.CS%Use_MLD_iteration) then + Kd_guess0 = (h_dz_int(K)*vstar) * CS%vonKar * ((dz_tt*hbs_here)*vstar) / & + ((CS%Ekman_scale_coef * absf) * (dz_tt*hbs_here) + vstar) + elseif (CS%eqdisc) then ! ML-eqdisc line1/2 + Kd_guess0 = MixLen_shape(K) * v0_ML_turb_vel_scale * MLD_guess ! ML-eqdisc + else + Kd_guess0 = (h_dz_int(K)*vstar) * CS%vonKar * mixlen(K) + endif + else + vstar = 0.0 ; Kd_guess0 = 0.0 + endif + mixvel(K) = vstar ! Track vstar + Kddt_h_g0 = Kd_guess0 * dt_h + + if (no_MKE_conversion) then + ! Without conversion from MKE to TKE, the updated diffusivity can be determined directly. + ! Replace h(k) with hp_b(k) = h(k), and dT_to_dPE with dT_to_dPE_b, etc., for a 2-direction solver. + call find_Kd_from_PE_chg(0.0, Kd_guess0, dt_h, tot_TKE, hp_a(k-1), h(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE(k), dS_to_dPE(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt(k), dS_to_dColHt(k), Kd_add=Kd(K), PE_chg=TKE_used, & + dPE_max=PE_chg_max, frac_dKd_max_PE=frac_in_BL) + convectively_unstable = (PE_chg_max < 0.0) + PE_chg_g0 = TKE_used ! This is only used in the convectively unstable limit. + MKE_src = 0.0 + elseif (CS%orig_PE_calc) then + call find_PE_chg_orig(Kddt_h_g0, h(k), hp_a(k-1), dTe_term, dSe_term, & + dT_km1_t2, dS_km1_t2, dT_to_dPE(k), dS_to_dPE(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), & + pres_Z(K), dT_to_dColHt(k), dS_to_dColHt(k), & + dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + PE_chg=PE_chg_g0, dPE_max=PE_chg_max, dPEc_dKd_0=dPEc_dKd_Kd0 ) + convectively_unstable = (PE_chg_g0 < 0.0) .or. ((vstar == 0.0) .and. (dPEc_dKd_Kd0 < 0.0)) + MKE_src = dMKE_max*(1.0 - exp(-Kddt_h_g0 * MKE2_Hharm)) + else + call find_PE_chg(0.0, Kddt_h_g0, hp_a(k-1), h(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE(k), dS_to_dPE(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt(k), dS_to_dColHt(k), & + PE_chg=PE_chg_g0, dPE_max=PE_chg_max, dPEc_dKd_0=dPEc_dKd_Kd0 ) + convectively_unstable = (PE_chg_g0 < 0.0) .or. ((vstar == 0.0) .and. (dPEc_dKd_Kd0 < 0.0)) + MKE_src = dMKE_max*(1.0 - exp(-Kddt_h_g0 * MKE2_Hharm)) + endif + + ! This block checks out different cases to determine Kd at the present interface. + if (convectively_unstable) then + ! This column is convectively unstable. + if (PE_chg_max <= 0.0) then + ! Does MKE_src need to be included in the calculation of vstar here? + TKE_here = mech_TKE + CS%wstar_ustar_coef*(conv_PErel-PE_chg_max) + if (TKE_here > 0.0) then + if (CS%answer_date < 20240101) then + if (CS%wT_scheme==wT_from_cRoot_TKE) then + vstar = CS%vstar_scale_fac * vstar_unit_scale * (SpV_dt(K)*TKE_here)**C1_3 + elseif (CS%wT_scheme==wT_from_RH18) then + Surface_Scale = max(0.05, 1. - dztot / MLD_guess) + vstar = CS%vstar_scale_fac * Surface_Scale * (CS%vstar_surf_fac*u_star + & + vstar_unit_scale * (CS%wstar_ustar_coef*conv_PErel*SpV_dt(K))**C1_3) + endif + else + if (CS%wT_scheme==wT_from_cRoot_TKE) then + vstar = CS%vstar_scale_fac * cuberoot(SpV_dt(K)*TKE_here) + elseif (CS%wT_scheme==wT_from_RH18) then + Surface_Scale = max(0.05, 1. - dztot / MLD_guess) + vstar = (CS%vstar_scale_fac * Surface_Scale) * ( CS%vstar_surf_fac*u_star + & + cuberoot((CS%wstar_ustar_coef*conv_PErel) * SpV_dt(K)) ) + endif + endif + hbs_here = min(hb_hs(K), MixLen_shape(K)) + mixlen(K) = max(CS%min_mix_len, ((dz_tt*hbs_here)*vstar) / & + ((CS%Ekman_scale_coef * absf) * (dz_tt*hbs_here) + vstar)) + if (.not.CS%Use_MLD_iteration) then + ! Note again (as prev) that using mixlen here + ! instead of redoing the computation will change answers... + Kd(K) = (h_dz_int(K)*vstar) * CS%vonKar * ((dz_tt*hbs_here)*vstar) / & + ((CS%Ekman_scale_coef * absf) * (dz_tt*hbs_here) + vstar) + elseif (CS%eqdisc) then ! ML-eqdisc line2/2 + Kd(K) = MixLen_shape(K) * v0_ML_turb_vel_scale * MLD_guess ! ML-eqdisc + else + Kd(K) = (h_dz_int(K)*vstar) * CS%vonKar * mixlen(K) + endif + else + vstar = 0.0 ; Kd(K) = 0.0 + endif + mixvel(K) = vstar + + if (CS%orig_PE_calc) then + call find_PE_chg_orig(Kd(K)*dt_h, h(k), hp_a(k-1), dTe_term, dSe_term, & + dT_km1_t2, dS_km1_t2, dT_to_dPE(k), dS_to_dPE(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), & + pres_Z(K), dT_to_dColHt(k), dS_to_dColHt(k), & + dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + PE_chg=dPE_conv) + else + call find_PE_chg(0.0, Kd(K)*dt_h, hp_a(k-1), h(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE(k), dS_to_dPE(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt(k), dS_to_dColHt(k), & + PE_chg=dPE_conv) + endif + ! Should this be iterated to convergence for Kd? + if (dPE_conv > 0.0) then + Kd(K) = Kd_guess0 ; dPE_conv = PE_chg_g0 + else + MKE_src = dMKE_max*(1.0 - exp(-(Kd(K)*dt_h) * MKE2_Hharm)) + endif + else + ! The energy change does not vary monotonically with Kddt_h. Find the maximum? + Kd(K) = Kd_guess0 ; dPE_conv = PE_chg_g0 + endif + + conv_PErel = conv_PErel - dPE_conv + mech_TKE = mech_TKE + MKE_src + if (CS%TKE_diagnostics) then + eCD%dTKE_conv = eCD%dTKE_conv - CS%nstar*dPE_conv * I_dtdiag + eCD%dTKE_MKE = eCD%dTKE_MKE + MKE_src * I_dtdiag + endif + if (sfc_connected) then + MLD_output = MLD_output + dz(k) + endif + + Kddt_h(K) = Kd(K) * dt_h + + elseif (no_MKE_conversion) then ! (PE_chg_max >= 0.0) and use the diffusivity from find_Kd_from_PE_chg. + ! Kd(K) and TKE_used were already set by find_Kd_from_PE_chg. + + ! frac_in_BL = min((TKE_used / PE_chg_g0), 1.0) + if (sfc_connected) MLD_output = MLD_output + frac_in_BL*dz(k) + if (frac_in_BL < 1.0) sfc_disconnect = .true. + + ! Reduce the mechanical and convective TKE proportionately. + TKE_reduc = 0.0 ! tot_TKE could be 0 if Convectively_stable is false. + if ((tot_TKE > 0.0) .and. (tot_TKE > TKE_used)) TKE_reduc = (tot_TKE - TKE_used) / tot_TKE + + ! All TKE should have been consumed. + if (CS%TKE_diagnostics) then + eCD%dTKE_mixing = eCD%dTKE_mixing - TKE_used * I_dtdiag + eCD%dTKE_conv_decay = eCD%dTKE_conv_decay + & + (1.0-TKE_reduc)*(CS%nstar-nstar_FC) * conv_PErel * I_dtdiag + endif + + tot_TKE = tot_TKE - TKE_used + mech_TKE = TKE_reduc*mech_TKE + conv_PErel = TKE_reduc*conv_PErel + + Kddt_h(K) = Kd(K) * dt_h + + elseif (tot_TKE + (MKE_src - PE_chg_g0) >= 0.0) then + ! This column is convectively stable and there is energy to support the suggested + ! mixing. Keep that estimate. + Kd(K) = Kd_guess0 + Kddt_h(K) = Kddt_h_g0 + + ! Reduce the mechanical and convective TKE proportionately. + tot_TKE = tot_TKE + MKE_src + TKE_reduc = 0.0 ! tot_TKE could be 0 if Convectively_stable is false. + if (tot_TKE > 0.0) TKE_reduc = (tot_TKE - PE_chg_g0) / tot_TKE + if (CS%TKE_diagnostics) then + eCD%dTKE_mixing = eCD%dTKE_mixing - PE_chg_g0 * I_dtdiag + eCD%dTKE_MKE = eCD%dTKE_MKE + MKE_src * I_dtdiag + eCD%dTKE_conv_decay = eCD%dTKE_conv_decay + & + (1.0-TKE_reduc)*(CS%nstar-nstar_FC) * conv_PErel * I_dtdiag + endif + tot_TKE = TKE_reduc*tot_TKE + mech_TKE = TKE_reduc*(mech_TKE + MKE_src) + conv_PErel = TKE_reduc*conv_PErel + if (sfc_connected) then + MLD_output = MLD_output + dz(k) + endif + + elseif (tot_TKE == 0.0) then + ! This can arise if nstar_FC = 0, but it is not common. + Kd(K) = 0.0 ; Kddt_h(K) = 0.0 + tot_TKE = 0.0 ; conv_PErel = 0.0 ; mech_TKE = 0.0 + sfc_disconnect = .true. + else + ! There is not enough energy to support the mixing, so reduce the + ! diffusivity to what can be supported. + Kddt_h_max = Kddt_h_g0 ; Kddt_h_min = 0.0 + TKE_left_max = tot_TKE + (MKE_src - PE_chg_g0) + TKE_left_min = tot_TKE + + ! As a starting guess, take the minimum of a false position estimate + ! and a Newton's method estimate starting from Kddt_h = 0.0. + Kddt_h_guess = tot_TKE * Kddt_h_max / max( PE_chg_g0 - MKE_src, & + Kddt_h_max * (dPEc_dKd_Kd0 - dMKE_max * MKE2_Hharm) ) + ! The above expression is mathematically the same as the following + ! except it is not susceptible to division by zero when + ! dPEc_dKd_Kd0 = dMKE_max = 0 . + ! Kddt_h_guess = tot_TKE * min( Kddt_h_max / (PE_chg_g0 - MKE_src), & + ! 1.0 / (dPEc_dKd_Kd0 - dMKE_max * MKE2_Hharm) ) + if (debug) then + TKE_left_itt(:) = 0.0 ; dPEa_dKd_itt(:) = 0.0 ; PE_chg_itt(:) = 0.0 + MKE_src_itt(:) = 0.0 ; Kddt_h_itt(:) = 0.0 + endif + do itt=1,max_itt + if (CS%orig_PE_calc) then + call find_PE_chg_orig(Kddt_h_guess, h(k), hp_a(k-1), dTe_term, dSe_term, & + dT_km1_t2, dS_km1_t2, dT_to_dPE(k), dS_to_dPE(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), & + pres_Z(K), dT_to_dColHt(k), dS_to_dColHt(k), & + dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + PE_chg=PE_chg, dPEc_dKd=dPEc_dKd ) + else + call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), h(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE(k), dS_to_dPE(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt(k), dS_to_dColHt(k), & + PE_chg=PE_chg, dPEc_dKd=dPEc_dKd) + endif + MKE_src = dMKE_max * (1.0 - exp(-MKE2_Hharm * Kddt_h_guess)) + dMKE_src_dK = dMKE_max * MKE2_Hharm * exp(-MKE2_Hharm * Kddt_h_guess) + + TKE_left = tot_TKE + (MKE_src - PE_chg) + if (debug .and. itt<=20) then + Kddt_h_itt(itt) = Kddt_h_guess ; MKE_src_itt(itt) = MKE_src + PE_chg_itt(itt) = PE_chg ; dPEa_dKd_itt(itt) = dPEc_dKd + TKE_left_itt(itt) = TKE_left + endif + ! Store the new bounding values, bearing in mind that min and max + ! here refer to Kddt_h and dTKE_left/dKddt_h < 0: + if (TKE_left >= 0.0) then + Kddt_h_min = Kddt_h_guess ; TKE_left_min = TKE_left + else + Kddt_h_max = Kddt_h_guess ; TKE_left_max = TKE_left + endif + + ! Try to use Newton's method, but if it would go outside the bracketed + ! values use the false-position method instead. + use_Newt = .true. + if (dPEc_dKd - dMKE_src_dK <= 0.0) then + use_Newt = .false. + else + dKddt_h_Newt = TKE_left / (dPEc_dKd - dMKE_src_dK) + Kddt_h_Newt = Kddt_h_guess + dKddt_h_Newt + if ((Kddt_h_Newt > Kddt_h_max) .or. (Kddt_h_Newt < Kddt_h_min)) & + use_Newt = .false. + endif + + if (use_Newt) then + Kddt_h_next = Kddt_h_guess + dKddt_h_Newt + dKddt_h = dKddt_h_Newt + else + Kddt_h_next = (TKE_left_max * Kddt_h_min - Kddt_h_max * TKE_left_min) / & + (TKE_left_max - TKE_left_min) + dKddt_h = Kddt_h_next - Kddt_h_guess + endif + + if ((abs(dKddt_h) < 1e-9*Kddt_h_guess) .or. (itt==max_itt)) then + ! Use the old value so that the energy calculation does not need to be repeated. + if (debug) num_itts(K) = itt + exit + else + Kddt_h_guess = Kddt_h_next + endif + enddo ! Inner iteration loop on itt. + Kd(K) = Kddt_h_guess / dt_h ; Kddt_h(K) = Kd(K) * dt_h + + ! All TKE should have been consumed. + if (CS%TKE_diagnostics) then + eCD%dTKE_mixing = eCD%dTKE_mixing - (tot_TKE + MKE_src) * I_dtdiag + eCD%dTKE_MKE = eCD%dTKE_MKE + MKE_src * I_dtdiag + eCD%dTKE_conv_decay = eCD%dTKE_conv_decay + & + (CS%nstar-nstar_FC) * conv_PErel * I_dtdiag + endif + + if (sfc_connected) MLD_output = MLD_output + (PE_chg / (PE_chg_g0)) * dz(k) + + tot_TKE = 0.0 ; mech_TKE = 0.0 ; conv_PErel = 0.0 + sfc_disconnect = .true. + endif ! End of convective or forced mixing cases to determine Kd. + + Kddt_h(K) = Kd(K) * dt_h + ! At this point, the final value of Kddt_h(K) is known, so the + ! estimated properties for layer k-1 can be calculated. + b1 = 1.0 / (hp_a(k-1) + Kddt_h(K)) + c1(K) = Kddt_h(K) * b1 + if (CS%orig_PE_calc) then + dTe(k-1) = b1 * ( Kddt_h(K)*(T0(k)-T0(k-1)) + dTe_t2 ) + dSe(k-1) = b1 * ( Kddt_h(K)*(S0(k)-S0(k-1)) + dSe_t2 ) + endif + + hp_a(k) = h(k) + (hp_a(k-1) * b1) * Kddt_h(K) + dT_to_dPE_a(k) = dT_to_dPE(k) + c1(K)*dT_to_dPE_a(k-1) + dS_to_dPE_a(k) = dS_to_dPE(k) + c1(K)*dS_to_dPE_a(k-1) + dT_to_dColHt_a(k) = dT_to_dColHt(k) + c1(K)*dT_to_dColHt_a(k-1) + dS_to_dColHt_a(k) = dS_to_dColHt(k) + c1(K)*dS_to_dColHt_a(k-1) + + endif ! tot_TKT > 0.0 branch. Kddt_h(K) has been set. + + ! Store integrated velocities and thicknesses for MKE conversion calculations. + if (sfc_disconnect) then + ! There is no turbulence at this interface, so zero out the running sums. + uhtot = u(k)*h(k) + vhtot = v(k)*h(k) + htot = h(k) + dztot = dz(k) + sfc_connected = .false. else - conv_PErel = TKE_forcing(1) + uhtot = uhtot + u(k)*h(k) + vhtot = vhtot + v(k)*h(k) + htot = htot + h(k) + dztot = dztot + dz(k) + endif + + if (calc_Te) then + if (K==2) then + Te(1) = b1*(h(1)*T0(1)) + Se(1) = b1*(h(1)*S0(1)) + else + Te(k-1) = b1 * (h(k-1) * T0(k-1) + Kddt_h(K-1) * Te(k-2)) + Se(k-1) = b1 * (h(k-1) * S0(k-1) + Kddt_h(K-1) * Se(k-2)) + endif + endif + enddo + Kd(nz+1) = 0.0 + + if (debug) then + ! Complete the tridiagonal solve for Te. + b1 = 1.0 / hp_a(nz) + Te(nz) = b1 * (h(nz) * T0(nz) + Kddt_h(nz) * Te(nz-1)) + Se(nz) = b1 * (h(nz) * S0(nz) + Kddt_h(nz) * Se(nz-1)) + dT_expect(nz) = Te(nz) - T0(nz) ; dS_expect(nz) = Se(nz) - S0(nz) + do k=nz-1,1,-1 + Te(k) = Te(k) + c1(K+1)*Te(k+1) + Se(k) = Se(k) + c1(K+1)*Se(k+1) + dT_expect(k) = Te(k) - T0(k) ; dS_expect(k) = Se(k) - S0(k) + enddo + endif + + if (debug) then + dPE_debug = 0.0 + do k=1,nz + dPE_debug = dPE_debug + (dT_to_dPE(k) * (Te(k) - T0(k)) + & + dS_to_dPE(k) * (Se(k) - S0(k))) + enddo + mixing_debug = dPE_debug * I_dtdiag + endif + + if (OBL_it >= CS%Max_MLD_Its) exit + + ! The following lines are used for the iteration. Note the iteration has been altered + ! to use the value predicted by the TKE threshold (ML_depth). This is because the mstar + ! is now dependent on the ML, and therefore the ML needs to be estimated more precisely + ! than the grid spacing. + + ! New method uses ML_depth as computed in ePBL routine + MLD_found = MLD_output + + ! Find out whether to do another iteration and the new bounds on it. + if (CS%MLD_iter_bug) then + ! There is a bug in the logic here if (MLD_found - MLD_guess == CS%MLD_tol). + if (MLD_found - MLD_guess > CS%MLD_tol) then + min_MLD = MLD_guess ; dMLD_min = MLD_found - MLD_guess + elseif (abs(MLD_found - MLD_guess) < CS%MLD_tol) then + exit ! Break the MLD convergence loop + else ! We know this guess was too deep + max_MLD = MLD_guess ; dMLD_max = MLD_found - MLD_guess ! < -CS%MLD_tol + endif + else + if (abs(MLD_found - MLD_guess) < CS%MLD_tol) then + exit ! Break the MLD convergence loop + elseif (MLD_found > MLD_guess) then ! This guess was too shallow + min_MLD = MLD_guess ; dMLD_min = MLD_found - MLD_guess + else ! We know this guess was too deep + max_MLD = MLD_guess ; dMLD_max = MLD_found - MLD_guess ! < -CS%MLD_tol + endif + endif + + if (OBL_it < CS%Max_MLD_Its) then + if (CS%MLD_bisection) then + ! For the next pass, guess the average of the minimum and maximum values. + MLD_guess = 0.5*(min_MLD + max_MLD) + else ! Try using the false position method or the returned value instead of simple bisection. + ! Taking the occasional step with MLD_output empirically helps to converge faster. + if ((dMLD_min > 0.0) .and. (dMLD_max < 0.0) .and. (OBL_it > 2) .and. (mod(OBL_it-1,4) > 0)) then + ! Both bounds have valid change estimates and are probably in the range of possible outputs. + MLD_guess = (dMLD_min*max_MLD - dMLD_max*min_MLD) / (dMLD_min - dMLD_max) + elseif ((MLD_found > min_MLD) .and. (MLD_found < max_MLD)) then + ! The output MLD_found is an interesting guess, as it is likely to bracket the true solution + ! along with the previous value of MLD_guess and to be close to the solution. + MLD_guess = MLD_found + else ! Bisect if the other guesses would be out-of-bounds. This does not happen much. + MLD_guess = 0.5*(min_MLD + max_MLD) + endif endif + endif + + enddo ! Iteration loop for converged boundary layer thickness. + + eCD%OBL_its = min(OBL_it, CS%Max_MLD_Its) + if (CS%Use_LT) then + eCD%LA = LA ; eCD%LAmod = LAmod ; eCD%mstar = mstar_total ; eCD%mstar_LT = mstar_LT + else + eCD%LA = 0.0 ; eCD%LAmod = 0.0 ; eCD%mstar = mstar_total ; eCD%mstar_LT = 0.0 + endif + MLD_io = MLD_output + +end subroutine ePBL_column + + +!> This subroutine determines the diffusivities from a bottom boundary layer version of +!! the integrated energetics mixed layer model for a single column of water. +subroutine ePBL_BBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, absf, & + dt, Kd, BBL_TKE_in, u_star_BBL, u_star_BBL_z_t, b_flux_BBL, Kd_BBL, BBLD_io, mixvel_BBL, & + mixlen_BBL, GV, US, CS, eCD) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZK_(GV)), intent(in) :: dz !< The vertical distance across layers [Z ~> m]. + real, dimension(SZK_(GV)), intent(in) :: u !< Zonal velocities interpolated to h points + !! [L T-1 ~> m s-1]. + real, dimension(SZK_(GV)), intent(in) :: v !< Zonal velocities interpolated to h points + !! [L T-1 ~> m s-1]. + real, dimension(SZK_(GV)), intent(in) :: T0 !< The initial layer temperatures [C ~> degC]. + real, dimension(SZK_(GV)), intent(in) :: S0 !< The initial layer salinities [S ~> ppt]. + + real, dimension(SZK_(GV)), intent(in) :: dSV_dT !< The partial derivative of in-situ specific + !! volume with potential temperature + !! [R-1 C-1 ~> m3 kg-1 degC-1]. + real, dimension(SZK_(GV)), intent(in) :: dSV_dS !< The partial derivative of in-situ specific + !! volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. + real, dimension(SZK_(GV)+1), intent(in) :: SpV_dt !< Specific volume interpolated to interfaces + !! divided by dt (if non-Boussinesq) or + !! 1.0 / (dt * Rho0), in [R-1 T-1 ~> m3 kg-1 s-1], + !! used to convert local TKE into a turbulence + !! velocity cubed. + real, intent(in) :: absf !< The absolute value of the Coriolis parameter [T-1 ~> s-1]. + real, intent(in) :: dt !< Time increment [T ~> s]. + real, dimension(SZK_(GV)+1), & + intent(in) :: Kd !< The diffusivities at interfaces due to previously + !! applied mixing processes [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, intent(in) :: BBL_TKE_in !< The mechanically generated turbulent + !! kinetic energy available for bottom boundary + !! layer mixing within a time step [R Z3 T-2 ~> J m-2]. + real, intent(in) :: u_star_BBL !< The bottom boundary layer friction velocity + !! in thickness flux units [H T-1 ~> m s-1 or kg m-2 s-1] + real, intent(in) :: u_star_BBL_z_t !< The bottom boundary layer friction velocity + !! converted to length flux units [Z T-1 ~> m s-1] + real, intent(in) :: b_flux_BBL !< The bottom boundary layer buoyancy flux + real, dimension(SZK_(GV)+1), & + intent(out) :: Kd_BBL !< The bottom boundary layer contribution to diffusivities + !! at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, intent(inout) :: BBLD_io !< A first guess at the bottom boundary layer depth on input, and + !! the calculated bottom boundary layer depth on output [Z ~> m] + real, dimension(SZK_(GV)+1), & + intent(out) :: mixvel_BBL !< The profile of boundary layer turbulent mixing + !! velocities [Z T-1 ~> m s-1] + real, dimension(SZK_(GV)+1), & + intent(out) :: mixlen_BBL !< The profile of bottom boundary layer turbulent + !! mixing lengths [Z ~> m] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(energetic_PBL_CS), intent(in) :: CS !< Energetic PBL control structure + type(ePBL_column_diags), intent(inout) :: eCD !< A container for passing around diagnostics. + +! This subroutine determines the contributions from diffusivities in a single column from a +! bottom-boundary layer adaptation of the integrated energetics planetary boundary layer (ePBL) +! model. It accounts for the possibility that the surface boundary diffusivities have already +! been determined. All calculations are done implicitly, and there is no stability limit on the +! time step. Only mechanical mixing in the bottom boundary layer is considered. (Geothermal heat +! fluxes are addressed elsewhere in the MOM6 code, and convection throughout the water column is +! handled by the surface version of ePBL.) There is no conversion of released mean kinetic energy +! into bottom boundary layer turbulent kinetic energy (at least for now), apart from the explicit +! energy that is supplied as an argument to this routine. + + ! Local variables + real, dimension(SZK_(GV)+1) :: & + pres_Z, & ! Interface pressures with a rescaling factor to convert interface height + ! movements into changes in column potential energy [R Z2 T-2 ~> kg m-1 s-2]. + dztop_dztot ! The distance from the surface divided by the thickness of the + ! water column [nondim]. + real :: mech_BBL_TKE ! The mechanically generated turbulent kinetic energy available for + ! bottom boundary layer mixing within a time step [R Z3 T-2 ~> J m-2]. + real :: TKE_eff_avail ! The turbulent kinetic energy that is effectively available to drive mixing + ! after any effects of exponentially decay have been taken into account + ! [R Z3 T-2 ~> J m-2] + real :: TKE_eff_used ! The amount of TKE_eff_avail that has been used to drive mixing [R Z3 T-2 ~> J m-2] + real :: htot ! The total thickness of the layers above an interface [H ~> m or kg m-2]. + real :: dztot ! The total depth of the layers above an interface [Z ~> m]. + real :: uhtot ! The depth integrated zonal velocities in the layers above [H L T-1 ~> m2 s-1 or kg m-1 s-1] + real :: vhtot ! The depth integrated meridional velocities in the layers above [H L T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Idecay_len_TKE ! The inverse of a turbulence decay length scale [H-1 ~> m-1 or m2 kg-1]. + real :: dz_sum ! The total thickness of the water column [Z ~> m]. + + real, dimension(SZK_(GV)) :: & + dT_to_dColHt, & ! Partial derivative of the total column height with the temperature changes + ! within a layer [Z C-1 ~> m degC-1]. + dS_to_dColHt, & ! Partial derivative of the total column height with the salinity changes + ! within a layer [Z S-1 ~> m ppt-1]. + dT_to_dPE, & ! Partial derivatives of column potential energy with the temperature + ! changes within a layer, in [R Z3 T-2 C-1 ~> J m-2 degC-1]. + dS_to_dPE, & ! Partial derivatives of column potential energy with the salinity changes + ! within a layer, in [R Z3 T-2 S-1 ~> J m-2 ppt-1]. + dT_to_dColHt_a, & ! Partial derivative of the total column height with the temperature changes + ! within a layer, including the implicit effects of mixing with layers higher + ! in the water column [Z C-1 ~> m degC-1]. + dS_to_dColHt_a, & ! Partial derivative of the total column height with the salinity changes + ! within a layer, including the implicit effects of mixing with layers higher + ! in the water column [Z S-1 ~> m ppt-1]. + dT_to_dPE_a, & ! Partial derivatives of column potential energy with the temperature changes + ! within a layer, including the implicit effects of mixing with layers higher + ! in the water column [R Z3 T-2 C-1 ~> J m-2 degC-1]. + dS_to_dPE_a, & ! Partial derivative of column potential energy with the salinity changes + ! within a layer, including the implicit effects of mixing with layers higher + ! in the water column [R Z3 T-2 S-1 ~> J m-2 ppt-1]. + dT_to_dColHt_b, & ! Partial derivative of the total column height with the temperature changes + ! within a layer, including the implicit effects of mixing with layers deeper + ! in the water column [Z C-1 ~> m degC-1]. + dS_to_dColHt_b, & ! Partial derivative of the total column height with the salinity changes + ! within a layer, including the implicit effects of mixing with layers deeper + ! in the water column [Z S-1 ~> m ppt-1]. + dT_to_dPE_b, & ! Partial derivatives of column potential energy with the temperature changes + ! within a layer, including the implicit effects of mixing with layers deeper + ! in the water column [R Z3 T-2 C-1 ~> J m-2 degC-1]. + dS_to_dPE_b, & ! Partial derivative of column potential energy with the salinity changes + ! within a layer, including the implicit effects of mixing with layers deeper + ! in the water column [R Z3 T-2 S-1 ~> J m-2 ppt-1]. + c1, & ! c1 is used by the tridiagonal solver [nondim]. + Te, & ! Estimated final values of T in the column [C ~> degC]. + Se, & ! Estimated final values of S in the column [S ~> ppt]. + hp_a, & ! An effective pivot thickness of the layer including the effects + ! of coupling with layers above [H ~> m or kg m-2]. This is the first term + ! in the denominator of b1 in a downward-oriented tridiagonal solver. + hp_b, & ! An effective pivot thickness of the layer including the effects + ! of coupling with layers below [H ~> m or kg m-2]. This is the first term + ! in the denominator of b1 in an upward-oriented tridiagonal solver. + Th_a, & ! An effective temperature times a thickness in the layer above, including implicit + ! mixing effects with other yet higher layers [C H ~> degC m or degC kg m-2]. + Sh_a, & ! An effective salinity times a thickness in the layer above, including implicit + ! mixing effects with other yet higher layers [S H ~> ppt m or ppt kg m-2]. + Th_b, & ! An effective temperature times a thickness in the layer below, including implicit + ! mixing effects with other yet lower layers [C H ~> degC m or degC kg m-2]. + Sh_b ! An effective salinity times a thickness in the layer below, including implicit + ! mixing effects with other yet lower layers [S H ~> ppt m or ppt kg m-2]. + real, dimension(SZK_(GV)+1) :: & + MixLen_shape, & ! A nondimensional shape factor for the mixing length that + ! gives it an appropriate asymptotic value at the bottom of + ! the boundary layer [nondim]. + h_dz_int, & ! The ratio of the layer thicknesses over the vertical distances + ! across the layers surrounding an interface [H Z-1 ~> nondim or kg m-3] + Kddt_h ! The total diapycnal diffusivity at an interface times a timestep divided by the + ! average thicknesses around an interface [H ~> m or kg m-2]. + real :: b1 ! b1 is inverse of the pivot used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. + real :: dMass ! The mass per unit area within a layer [Z R ~> kg m-2]. + real :: dPres ! The hydrostatic pressure change across a layer [R Z2 T-2 ~> Pa] or + ! equivalently [R Z2 T-2 ~> J m-3]. + real :: dt_h ! The timestep divided by the averages of the vertical distances around + ! a layer [T Z-1 ~> s m-1]. + real :: dz_top ! The distance from the surface [Z ~> m]. + real :: dz_rsum ! The distance from the seafloor [Z ~> m]. + real :: I_dzsum ! The inverse of dz_sum [Z-1 ~> m-1]. + real :: I_BBLD ! The inverse of the current value of BBLD [Z-1 ~> m-1]. + real :: dz_tt ! The distance from the surface or up to the next interface + ! that did not exhibit turbulent mixing from this scheme plus + ! a surface mixing roughness length given by dz_tt_min [Z ~> m]. + real :: dz_tt_min ! A surface roughness length [Z ~> m]. + real :: C1_3 ! = 1/3 [nondim] + real :: vstar ! An in-situ turbulent velocity [Z T-1 ~> m s-1]. + real :: BBLD_output ! The bottom boundary layer depth output from this routine [Z ~> m] + real :: hbs_here ! The local minimum of dztop_dztot and MixLen_shape [nondim] + real :: TKE_used ! The TKE used to support mixing at an interface [R Z3 T-2 ~> J m-2]. + real :: Kd_guess0 ! A first guess of the diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real :: PE_chg_g0 ! The potential energy change when Kd is Kd_guess0 [R Z3 T-2 ~> J m-2] + real :: Kddt_h_g0 ! The first guess of the change in diapycnal diffusivity times a timestep + ! divided by the average thicknesses around an interface [H ~> m or kg m-2]. + real :: Kddt_h_prev ! The diapycnal diffusivity before modification times a timestep divided + ! by the average thicknesses around an interface [H ~> m or kg m-2]. + real :: dPEc_dKd_Kd0 ! The partial derivative of PE change with Kddt_h(K) + ! for very small values of Kddt_h(K) [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. + real :: PE_chg ! The change in potential energy due to mixing at an + ! interface [R Z3 T-2 ~> J m-2], positive for the column increasing + ! in potential energy (i.e., consuming TKE). + real :: TKE_left ! The amount of turbulent kinetic energy left for the most + ! recent guess at Kddt_h(K) [R Z3 T-2 ~> J m-2]. + real :: dPEc_dKd ! The partial derivative of PE_chg with Kddt_h(K) [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. + real :: TKE_left_min, TKE_left_max ! Maximum and minimum values of TKE_left [R Z3 T-2 ~> J m-2]. + real :: Kddt_h_max, Kddt_h_min ! Maximum and minimum values of Kddt_h(K) [H ~> m or kg m-2]. + real :: Kddt_h_guess ! A guess at the value of Kddt_h(K) [H ~> m or kg m-2]. + real :: Kddt_h_next ! The next guess at the value of Kddt_h(K) [H ~> m or kg m-2]. + real :: dKddt_h ! The change between guesses at Kddt_h(K) [H ~> m or kg m-2]. + real :: dKddt_h_Newt ! The change between guesses at Kddt_h(K) with Newton's method [H ~> m or kg m-2]. + real :: Kddt_h_newt ! The Newton's method next guess for Kddt_h(K) [H ~> m or kg m-2]. + real :: exp_kh ! The nondimensional decay of TKE across a layer [nondim]. + real :: frac_in_BL ! The fraction of the energy required to support dKd_max that is suppiled by + ! max_PE_chg, used here to determine a fractional layer contribution to the + ! boundary layer thickness [nondim] + real :: TKE_rescale ! The effective fractional increase in energy available to + ! mixing at this interface once its exponential decay is accounted for [nondim] + logical :: use_Newt ! Use Newton's method for the next guess at Kddt_h(K). + logical :: convectively_stable ! If true the water column is convectively stable at this interface. + logical :: bot_connected ! If true the ocean is actively turbulent from the present + ! interface all the way down to the seafloor. + logical :: bot_disconnect ! If true, any turbulence has become disconnected + ! from the bottom. + + ! The following is only used for diagnostics. + real :: I_dtdiag ! = 1.0 / dt [T-1 ~> s-1]. + + real :: BBLD_guess, BBLD_found ! Bottom boundary layer depth guessed/found for iteration [Z ~> m] + real :: min_BBLD, max_BBLD ! Iteration bounds on BBLD [Z ~> m], which are adjusted at each step + real :: dBBLD_min ! The change in diagnosed mixed layer depth when the guess is min_BLD [Z ~> m] + real :: dBBLD_max ! The change in diagnosed mixed layer depth when the guess is max_BLD [Z ~> m] + integer :: BBL_it ! Iteration counter + + real :: Surface_Scale ! Surface decay scale for vstar [nondim] + logical :: debug ! This is used as a hard-coded value for debugging. + logical :: no_MKE_conversion ! If true, there is conversion of MKE to TKE in this routine. + real :: mstar_BBL !< the value of mstar for the bottom boundary layer [nondim] + + ! The following arrays are used only for debugging purposes. + real :: dPE_debug ! An estimate of the potential energy change [R Z3 T-2 ~> J m-2] + real :: mixing_debug ! An estimate of the rate of change of potential energy due to mixing [R Z3 T-3 ~> W m-2] + real, dimension(20) :: TKE_left_itt ! The value of TKE_left after each iteration [R Z3 T-2 ~> J m-2] + real, dimension(20) :: PE_chg_itt ! The value of PE_chg after each iteration [R Z3 T-2 ~> J m-2] + real, dimension(20) :: Kddt_h_itt ! The value of Kddt_h_guess after each iteration [H ~> m or kg m-2] + real, dimension(20) :: dPEa_dKd_itt ! The value of dPEc_dKd after each iteration [R Z3 T-2 H-1 ~> J m-3 or J kg-1] +! real, dimension(20) :: MKE_src_itt ! The value of MKE_src after each iteration [R Z3 T-2 ~> J m-2] + real, dimension(SZK_(GV)) :: dT_expect !< Expected temperature changes [C ~> degC] + real, dimension(SZK_(GV)) :: dS_expect !< Expected salinity changes [S ~> ppt] + real, dimension(SZK_(GV)) :: mech_BBL_TKE_k ! The mechanically generated turbulent kinetic energy + ! available for bottom boundary mixing over a time step for each layer [R Z3 T-2 ~> J m-2]. + integer, dimension(SZK_(GV)) :: num_itts + + integer :: k, nz, itt, max_itt + + nz = GV%ke + + debug = .false. ! Change this hard-coded value for debugging. + no_MKE_conversion = ((CS%direct_calc) ) ! .and. (CS%MKE_to_TKE_effic == 0.0)) + + ! Add bottom boundary layer mixing if there is energy to support it. + if (((CS%ePBL_BBL_effic <= 0.0) .and. (CS%ePBL_tidal_effic <= 0.0) .and. (.not.CS%ePBL_BBL_use_mstar)) & + .or. (BBL_TKE_in <= 0.0)) then + ! There is no added bottom boundary layer mixing. + BBLD_io = 0.0 + Kd_BBL(:) = 0.0 + mixvel_BBL(:) = 0.0 ; mixlen_BBL(:) = 0.0 + eCD%BBL_its = 0 + if (CS%TKE_diagnostics) then + eCD%dTKE_BBL_mixing = 0.0 ; eCD%dTKE_BBL_decay = 0.0 ; eCD%dTKE_BBL = 0.0 + ! eCD%dTKE_BBL_MKE = 0.0 + endif + return + else + ! There will be added bottom boundary layer mixing. + + h_neglect = GV%H_subroundoff + dz_neglect = GV%dZ_subroundoff + + C1_3 = 1.0 / 3.0 + I_dtdiag = 1.0 / dt + max_itt = 20 + dz_tt_min = 0.0 + + ! The next two blocks of code could be shared with ePBL_column. + + ! Set up fields relating a layer's temperature and salinity changes to potential energy changes. + pres_Z(1) = 0.0 + do k=1,nz + dMass = GV%H_to_RZ * h(k) + dPres = GV%g_Earth_Z_T2 * dMass + dT_to_dPE(k) = (dMass * (pres_Z(K) + 0.5*dPres)) * dSV_dT(k) + dS_to_dPE(k) = (dMass * (pres_Z(K) + 0.5*dPres)) * dSV_dS(k) + dT_to_dColHt(k) = dMass * dSV_dT(k) + dS_to_dColHt(k) = dMass * dSV_dS(k) + + pres_Z(K+1) = pres_Z(K) + dPres + enddo + + if (GV%Boussinesq) then + do K=1,nz+1 ; h_dz_int(K) = GV%Z_to_H ; enddo + else + h_dz_int(1) = (h(1) + h_neglect) / (dz(1) + dz_neglect) + do K=2,nz + h_dz_int(K) = (h(k-1) + h(k) + h_neglect) / (dz(k-1) + dz(k) + dz_neglect) + enddo + h_dz_int(nz+1) = (h(nz) + h_neglect) / (dz(nz) + dz_neglect) + endif + ! The two previous blocks of code could be shared with ePBL_column. + + ! Determine the total thickness (dz_sum) and the fractional distance from the top (dztop_dztot). + dz_sum = 0.0 ; do k=1,nz ; dz_sum = dz_sum + dz(k) ; enddo + I_dzsum = 0.0 ; if (dz_sum > 0.0) I_dzsum = 1.0 / dz_sum + dz_top = 0.0 + dztop_dztot(nz+1) = 0.0 + do k=1,nz + dz_top = dz_top + dz(k) + dztop_dztot(K) = dz_top * I_dzsum + enddo + + ! Set terms from a tridiagonal solver based on the previously determined diffusivities. + Kddt_h(1) = 0.0 + hp_a(1) = h(1) + dT_to_dPE_a(1) = dT_to_dPE(1) ; dT_to_dColHt_a(1) = dT_to_dColHt(1) + dS_to_dPE_a(1) = dS_to_dPE(1) ; dS_to_dColHt_a(1) = dS_to_dColHt(1) + do K=2,nz + dt_h = dt / max(0.5*(dz(k-1)+dz(k)), 1e-15*dz_sum) + Kddt_h(K) = Kd(K) * dt_h + b1 = 1.0 / (hp_a(k-1) + Kddt_h(K)) + c1(K) = Kddt_h(K) * b1 + hp_a(k) = h(k) + (hp_a(k-1) * b1) * Kddt_h(K) + dT_to_dPE_a(k) = dT_to_dPE(k) + c1(K)*dT_to_dPE_a(k-1) + dS_to_dPE_a(k) = dS_to_dPE(k) + c1(K)*dS_to_dPE_a(k-1) + dT_to_dColHt_a(k) = dT_to_dColHt(k) + c1(K)*dT_to_dColHt_a(k-1) + dS_to_dColHt_a(k) = dS_to_dColHt(k) + c1(K)*dS_to_dColHt_a(k-1) + if (K<=2) then + Te(k-1) = b1*(h(k-1)*T0(k-1)) ; Se(k-1) = b1*(h(k-1)*S0(k-1)) + Th_a(k-1) = h(k-1) * T0(k-1) ; Sh_a(k-1) = h(k-1) * S0(k-1) + else + Te(k-1) = b1 * (h(k-1) * T0(k-1) + Kddt_h(K-1) * Te(k-2)) + Se(k-1) = b1 * (h(k-1) * S0(k-1) + Kddt_h(K-1) * Se(k-2)) + Th_a(k-1) = h(k-1) * T0(k-1) + Kddt_h(K-1) * Te(k-2) + Sh_a(k-1) = h(k-1) * S0(k-1) + Kddt_h(K-1) * Se(k-2) + endif + enddo + Kddt_h(nz+1) = 0.0 + if (debug) then + ! Complete the tridiagonal solve for Te and Se, which may be useful for debugging. + b1 = 1.0 / hp_a(nz) + Te(nz) = b1 * (h(nz) * T0(nz) + Kddt_h(nz) * Te(nz-1)) + Se(nz) = b1 * (h(nz) * S0(nz) + Kddt_h(nz) * Se(nz-1)) + do k=nz-1,1,-1 + Te(k) = Te(k) + c1(K+1)*Te(k+1) + Se(k) = Se(k) + c1(K+1)*Se(k+1) + enddo + endif + + BBLD_guess = BBLD_io + + !/The following lines are for the iteration over BBLD + ! max_BBLD will initialized as ocean bottom depth + max_BBLD = 0.0 ; do k=1,nz ; max_BBLD = max_BBLD + dz(k) ; enddo + ! min_BBLD will be initialized to 0. + min_BBLD = 0.0 + ! Set values of the wrong signs to indicate that these changes are not based on valid estimates + dBBLD_min = -1.0*US%m_to_Z ; dBBLD_max = 1.0*US%m_to_Z + + ! If no first guess is provided for BBLD, try the middle of the water column + if (BBLD_guess <= min_BBLD) BBLD_guess = 0.5 * (min_BBLD + max_BBLD) + + ! Iterate to determine a converged EPBL bottom boundary layer depth. + do BBL_it=1,CS%max_BBLD_its + + if (debug) then ; mech_BBL_TKE_k(:) = 0.0 ; endif + + ! Reset BBL_depth + BBLD_output = dz(nz) + bot_connected = .true. + + if (CS%ePBL_BBL_use_mstar) then + call find_mstar(CS, US, B_flux_BBL, u_star_BBL_z_t, BBLD_guess, absf, .true., mstar_BBL) + eCD%mstar_BBL = mstar_BBL + mech_BBL_TKE = mstar_BBL * BBL_TKE_in + else + mech_BBL_TKE = BBL_TKE_in + eCD%mstar_BBL = 0.0 + endif + if (CS%TKE_diagnostics) then + ! eCD%dTKE_BBL_MKE = 0.0 + eCD%dTKE_BBL_mixing = 0.0 + eCD%dTKE_BBL_decay = 0.0 + eCD%dTKE_BBL = mech_BBL_TKE * I_dtdiag + endif ! Store in 1D arrays for output. - do K=1,nz+1 ; mixvel(K) = 0.0 ; mixlen(K) = 0.0 ; enddo + do K=1,nz+1 ; mixvel_BBL(K) = 0.0 ; mixlen_BBL(K) = 0.0 ; enddo ! Determine the mixing shape function MixLen_shape. - if ((.not.CS%Use_MLD_iteration) .or. & + if ((.not.CS%Use_BBLD_iteration) .or. & (CS%transLay_scale >= 1.0) .or. (CS%transLay_scale < 0.0) ) then do K=1,nz+1 MixLen_shape(K) = 1.0 enddo - elseif (MLD_guess <= 0.0) then + elseif (BBLD_guess <= 0.0) then if (CS%transLay_scale > 0.0) then ; do K=1,nz+1 MixLen_shape(K) = CS%transLay_scale enddo ; else ; do K=1,nz+1 MixLen_shape(K) = 1.0 enddo ; endif else - ! Reduce the mixing length based on MLD, with a quadratic + ! Reduce the mixing length based on BBLD, with a quadratic ! expression that follows KPP. - I_MLD = 1.0 / MLD_guess - h_rsum = 0.0 - MixLen_shape(1) = 1.0 - do K=2,nz+1 - h_rsum = h_rsum + h(k-1)*GV%H_to_Z - if (CS%MixLenExponent==2.0) then + I_BBLD = 1.0 / BBLD_guess + dz_rsum = 0.0 + MixLen_shape(nz+1) = 1.0 + if (CS%MixLenExponent_BBL==2.0) then + do K=nz,1,-1 + dz_rsum = dz_rsum + dz(k) MixLen_shape(K) = CS%transLay_scale + (1.0 - CS%transLay_scale) * & - (max(0.0, (MLD_guess - h_rsum)*I_MLD) )**2 ! CS%MixLenExponent - else + (max(0.0, (BBLD_guess - dz_rsum)*I_BBLD) )**2 + enddo + elseif (CS%MixLenExponent_BBL==1.0) then + do K=nz,1,-1 + dz_rsum = dz_rsum + dz(k) MixLen_shape(K) = CS%transLay_scale + (1.0 - CS%transLay_scale) * & - (max(0.0, (MLD_guess - h_rsum)*I_MLD) )**CS%MixLenExponent - endif - enddo + (max(0.0, (BBLD_guess - dz_rsum)*I_BBLD) ) + enddo + else ! (CS%MixLenExponent_BBL /= 2.0 or 1.0) then + do K=nz,1,-1 + dz_rsum = dz_rsum + dz(k) + MixLen_shape(K) = CS%transLay_scale + (1.0 - CS%transLay_scale) * & + (max(0.0, (BBLD_guess - dz_rsum)*I_BBLD) )**CS%MixLenExponent_BBL + enddo + endif endif - Kd(1) = 0.0 ; Kddt_h(1) = 0.0 - hp_a = h(1) - dT_to_dPE_a(1) = dT_to_dPE(1) ; dT_to_dColHt_a(1) = dT_to_dColHt(1) - dS_to_dPE_a(1) = dS_to_dPE(1) ; dS_to_dColHt_a(1) = dS_to_dColHt(1) + Kd_BBL(nz+1) = 0.0 ; Kddt_h(nz+1) = 0.0 + hp_b(nz) = h(nz) + dT_to_dPE_b(nz) = dT_to_dPE(nz) ; dT_to_dColHt_b(nz) = dT_to_dColHt(nz) + dS_to_dPE_b(nz) = dS_to_dPE(nz) ; dS_to_dColHt_b(nz) = dS_to_dColHt(nz) - htot = h(1) ; uhtot = u(1)*h(1) ; vhtot = v(1)*h(1) + htot = h(nz) ; dztot = dz(nz) ; uhtot = u(nz)*h(nz) ; vhtot = v(nz)*h(nz) if (debug) then - mech_TKE_k(1) = mech_TKE ; conv_PErel_k(1) = conv_PErel - nstar_k(:) = 0.0 ; nstar_k(1) = CS%nstar ; num_itts(:) = -1 + mech_BBL_TKE_k(nz) = mech_BBL_TKE + num_itts(:) = -1 endif - do K=2,nz - ! Apply dissipation to the TKE, here applied as an exponential decay + Idecay_len_TKE = (CS%TKE_decay_BBL * absf) / u_star_BBL + do K=nz,2,-1 + ! Apply dissipation to the TKE, here applied as an exponential decay ! due to 3-d turbulent energy being lost to inefficient rotational modes. - - ! There should be several different "flavors" of TKE that decay at - ! different rates. The following form is often used for mechanical - ! stirring from the surface, perhaps due to breaking surface gravity - ! waves and wind-driven turbulence. - Idecay_len_TKE = (CS%TKE_decay * absf / u_star) * GV%H_to_Z + ! The following form is often used for mechanical stirring from the surface. + ! There could be several different "flavors" of TKE that decay at different rates. exp_kh = 1.0 - if (Idecay_len_TKE > 0.0) exp_kh = exp(-h(k-1)*Idecay_len_TKE) + if (Idecay_len_TKE > 0.0) exp_kh = exp(-h(k)*Idecay_len_TKE) if (CS%TKE_diagnostics) & - eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag - if (present(epbl2_wt)) then ! perturb the TKE destruction - mech_TKE = mech_TKE * (1+(exp_kh-1) * epbl2_wt) - else - mech_TKE = mech_TKE * exp_kh - endif - !if ( i .eq. 10 .and. j .eq. 10 .and. k .eq. nz) print*,'mech TKE', mech_TKE - - ! Accumulate any convectively released potential energy to contribute - ! to wstar and to drive penetrating convection. - if (TKE_forcing(k) > 0.0) then - conv_PErel = conv_PErel + TKE_forcing(k) - if (CS%TKE_diagnostics) & - eCD%dTKE_forcing = eCD%dTKE_forcing + CS%nstar*TKE_forcing(k) * I_dtdiag - endif - - if (debug) then - mech_TKE_k(K) = mech_TKE ; conv_PErel_k(K) = conv_PErel - endif - - ! Determine the total energy - nstar_FC = CS%nstar - if (CS%nstar * conv_PErel > 0.0) then - ! Here nstar is a function of the natural Rossby number 0.2/(1+0.2/Ro), based - ! on a curve fit from the data of Wang (GRL, 2003). - ! Note: Ro = 1.0 / sqrt(0.5 * dt * Rho0 * (absf*htot)**3 / conv_PErel) - nstar_FC = CS%nstar * conv_PErel / (conv_PErel + 0.2 * & - sqrt(0.5 * dt * GV%Rho0 * (absf*(htot*GV%H_to_Z))**3 * conv_PErel)) - endif - - if (debug) nstar_k(K) = nstar_FC - - tot_TKE = mech_TKE + nstar_FC * conv_PErel - - ! For each interior interface, first discard the TKE to account for - ! mixing of shortwave radiation through the next denser cell. - if (TKE_forcing(k) < 0.0) then - if (TKE_forcing(k) + tot_TKE < 0.0) then - ! The shortwave requirements deplete all the energy in this layer. - if (CS%TKE_diagnostics) then - eCD%dTKE_mixing = eCD%dTKE_mixing + tot_TKE * I_dtdiag - eCD%dTKE_forcing = eCD%dTKE_forcing - tot_TKE * I_dtdiag - ! eCD%dTKE_unbalanced = eCD%dTKE_unbalanced + (TKE_forcing(k) + tot_TKE) * I_dtdiag - eCD%dTKE_conv_decay = eCD%dTKE_conv_decay + (CS%nstar-nstar_FC) * conv_PErel * I_dtdiag - endif - tot_TKE = 0.0 ; mech_TKE = 0.0 ; conv_PErel = 0.0 - else - ! Reduce the mechanical and convective TKE proportionately. - TKE_reduc = (tot_TKE + TKE_forcing(k)) / tot_TKE - if (CS%TKE_diagnostics) then - eCD%dTKE_mixing = eCD%dTKE_mixing - TKE_forcing(k) * I_dtdiag - eCD%dTKE_forcing = eCD%dTKE_forcing + TKE_forcing(k) * I_dtdiag - eCD%dTKE_conv_decay = eCD%dTKE_conv_decay + & - (1.0-TKE_reduc)*(CS%nstar-nstar_FC) * conv_PErel * I_dtdiag - endif - tot_TKE = TKE_reduc*tot_TKE ! = tot_TKE + TKE_forcing(k) - mech_TKE = TKE_reduc*mech_TKE - conv_PErel = TKE_reduc*conv_PErel - endif + eCD%dTKE_BBL_decay = eCD%dTKE_BBL_decay + (exp_kh-1.0) * mech_BBL_TKE * I_dtdiag + mech_BBL_TKE = mech_BBL_TKE * exp_kh + + if (debug) then + mech_BBL_TKE_k(K) = mech_BBL_TKE endif ! Precalculate some temporary expressions that are independent of Kddt_h(K). - if (CS%orig_PE_calc) then - if (K==2) then - dTe_t2 = 0.0 ; dSe_t2 = 0.0 - else - dTe_t2 = Kddt_h(K-1) * ((T0(k-2) - T0(k-1)) + dTe(k-2)) - dSe_t2 = Kddt_h(K-1) * ((S0(k-2) - S0(k-1)) + dSe(k-2)) - endif - endif - dt_h = (GV%Z_to_H**2*dt) / max(0.5*(h(k-1)+h(k)), 1e-15*h_sum) + dt_h = dt / max(0.5*(dz(k-1)+dz(k)), 1e-15*dz_sum) ! This tests whether the layers above and below this interface are in ! a convectively stable configuration, without considering any effects of ! mixing at higher interfaces. It is an approximation to the more ! complete test dPEc_dKd_Kd0 >= 0.0, that would include the effects of - ! mixing across interface K-1. The dT_to_dColHt here are effectively - ! mass-weigted estimates of dSV_dT. + ! mixing across interface K+1. The dT_to_dColHt here are effectively + ! mass-weighted estimates of dSV_dT. Convectively_stable = ( 0.0 <= & ( (dT_to_dColHt(k) + dT_to_dColHt(k-1) ) * (T0(k-1)-T0(k)) + & (dS_to_dColHt(k) + dS_to_dColHt(k-1) ) * (S0(k-1)-S0(k)) ) ) - if ((mech_TKE + conv_PErel) <= 0.0 .and. Convectively_stable) then - ! Energy is already exhausted, so set Kd = 0 and cycle or exit? - tot_TKE = 0.0 ; mech_TKE = 0.0 ; conv_PErel = 0.0 - Kd(K) = 0.0 ; Kddt_h(K) = 0.0 - sfc_disconnect = .true. + if ((mech_BBL_TKE <= 0.0) .and. Convectively_stable) then + ! Energy is already exhausted, so set Kd_BBL = 0 and cycle or exit? + mech_BBL_TKE = 0.0 + Kd_BBL(K) = 0.0 ; Kddt_h(K) = Kd(K) * dt_h + bot_disconnect = .true. ! if (.not.debug) exit - ! The estimated properties for layer k-1 can be calculated, using - ! greatly simplified expressions when Kddt_h = 0. This enables the - ! tridiagonal solver for the whole column to be completed for debugging - ! purposes, and also allows for something akin to convective adjustment - ! in unstable interior regions? - b1 = 1.0 / hp_a - c1(K) = 0.0 - if (CS%orig_PE_calc) then - dTe(k-1) = b1 * ( dTe_t2 ) - dSe(k-1) = b1 * ( dSe_t2 ) - endif + else ! mech_BBL_TKE > 0.0 or this is a potentially convectively unstable profile. + bot_disconnect = .false. - hp_a = h(k) - dT_to_dPE_a(k) = dT_to_dPE(k) - dS_to_dPE_a(k) = dS_to_dPE(k) - dT_to_dColHt_a(k) = dT_to_dColHt(k) - dS_to_dColHt_a(k) = dS_to_dColHt(k) - - else ! tot_TKE > 0.0 or this is a potentially convectively unstable profile. - sfc_disconnect = .false. - - ! Precalculate some more temporary expressions that are independent of - ! Kddt_h(K). - if (CS%orig_PE_calc) then - if (K==2) then - dT_km1_t2 = (T0(k)-T0(k-1)) - dS_km1_t2 = (S0(k)-S0(k-1)) - else - dT_km1_t2 = (T0(k)-T0(k-1)) - & - (Kddt_h(K-1) / hp_a) * ((T0(k-2) - T0(k-1)) + dTe(k-2)) - dS_km1_t2 = (S0(k)-S0(k-1)) - & - (Kddt_h(K-1) / hp_a) * ((S0(k-2) - S0(k-1)) + dSe(k-2)) - endif - dTe_term = dTe_t2 + hp_a * (T0(k-1)-T0(k)) - dSe_term = dSe_t2 + hp_a * (S0(k-1)-S0(k)) - else - if (K<=2) then - Th_a(k-1) = h(k-1) * T0(k-1) ; Sh_a(k-1) = h(k-1) * S0(k-1) - else - Th_a(k-1) = h(k-1) * T0(k-1) + Kddt_h(K-1) * Te(k-2) - Sh_a(k-1) = h(k-1) * S0(k-1) + Kddt_h(K-1) * Se(k-2) - endif + ! Precalculate some more temporary expressions that are independent of Kddt_h(K). + if (K>=nz) then Th_b(k) = h(k) * T0(k) ; Sh_b(k) = h(k) * S0(k) + else + Th_b(k) = h(k) * T0(k) + Kddt_h(K+1) * Te(k+1) + Sh_b(k) = h(k) * S0(k) + Kddt_h(K+1) * Se(k+1) endif - ! Using Pr=1 and the diffusivity at the bottom interface (once it is + ! Using Pr=1 and the diffusivity at the upper interface (once it is ! known), determine how much resolved mean kinetic energy (MKE) will be ! extracted within a timestep and add a fraction CS%MKE_to_TKE_effic of ! this to the mTKE budget available for mixing in the next layer. - - if ((CS%MKE_to_TKE_effic > 0.0) .and. (htot*h(k) > 0.0)) then - ! This is the energy that would be available from homogenizing the - ! velocities between layer k and the layers above. - dMKE_max = (US%L_to_Z**2*GV%H_to_RZ * CS%MKE_to_TKE_effic) * 0.5 * & - (h(k) / ((htot + h(k))*htot)) * & - ((uhtot-u(k)*htot)**2 + (vhtot-v(k)*htot)**2) - ! A fraction (1-exp(Kddt_h*MKE2_Hharm)) of this energy would be - ! extracted by mixing with a finite viscosity. - MKE2_Hharm = (htot + h(k) + 2.0*h_neglect) / & - ((htot+h_neglect) * (h(k)+h_neglect)) - else - dMKE_max = 0.0 - MKE2_Hharm = 0.0 - endif + ! This is not enabled yet for BBL mixing. + ! if ((CS%MKE_to_TKE_effic > 0.0) .and. (htot*h(k-1) > 0.0)) then + ! ! This is the energy that would be available from homogenizing the + ! ! velocities between layer k-1 and the layers below. + ! dMKE_max = (GV%H_to_RZ * CS%MKE_to_TKE_effic) * 0.5 * & + ! (h(k-1) / ((htot + h(k-1))*htot)) * & + ! ((uhtot-u(k-1)*htot)**2 + (vhtot-v(k-1)*htot)**2) + ! ! A fraction (1-exp(Kddt_h*MKE2_Hharm)) of this energy would be + ! ! extracted by mixing with a finite viscosity. + ! MKE2_Hharm = (htot + h(k-1) + 2.0*h_neglect) / & + ! ((htot+h_neglect) * (h(k-1)+h_neglect)) + ! else + ! dMKE_max = 0.0 + ! MKE2_Hharm = 0.0 + ! endif ! At this point, Kddt_h(K) will be unknown because its value may depend - ! on how much energy is available. mech_TKE might be negative due to - ! contributions from TKE_forced. - h_tt = htot + h_tt_min - TKE_here = mech_TKE + CS%wstar_ustar_coef*conv_PErel - if (TKE_here > 0.0) then - if (CS%wT_scheme==wT_from_cRoot_TKE) then - vstar = CS%vstar_scale_fac * vstar_unit_scale * (I_dtrho*TKE_here)**C1_3 - elseif (CS%wT_scheme==wT_from_RH18) then - Surface_Scale = max(0.05, 1.0 - htot/MLD_guess) - vstar = CS%vstar_scale_fac * Surface_Scale * (CS%vstar_surf_fac*u_star + & - vstar_unit_scale * (CS%wstar_ustar_coef*conv_PErel*I_dtrho)**C1_3) - endif - hbs_here = GV%H_to_Z * min(hb_hs(K), MixLen_shape(K)) - mixlen(K) = MAX(CS%min_mix_len, ((h_tt*hbs_here)*vstar) / & - ((CS%Ekman_scale_coef * absf) * (h_tt*hbs_here) + vstar)) - !Note setting Kd_guess0 to vstar * CS%vonKar * mixlen(K) here will - ! change the answers. Therefore, skipping that. - if (.not.CS%Use_MLD_iteration) then - Kd_guess0 = vstar * CS%vonKar * ((h_tt*hbs_here)*vstar) / & - ((CS%Ekman_scale_coef * absf) * (h_tt*hbs_here) + vstar) - else - Kd_guess0 = vstar * CS%vonKar * mixlen(K) + ! on how much energy is available. + dz_tt = dztot + dz_tt_min + if (mech_BBL_TKE > 0.0) then + if (CS%wT_scheme_BBL==wT_from_cRoot_TKE) then + vstar = CS%vstar_scale_fac_BBL * cuberoot(SpV_dt(K)*mech_BBL_TKE) + elseif (CS%wT_scheme_BBL==wT_from_RH18) then + Surface_Scale = max(0.05, 1.0 - dztot / BBLD_guess) + vstar = (CS%vstar_scale_fac_BBL * Surface_Scale) * ( CS%vstar_surf_fac_BBL*u_star_BBL/h_dz_int(K) ) endif + hbs_here = min(dztop_dztot(K), MixLen_shape(K)) + mixlen_BBL(K) = max(CS%min_BBL_mix_len, ((dz_tt*hbs_here)*vstar) / & + ((CS%Ekman_scale_coef_BBL * absf) * (dz_tt*hbs_here) + vstar)) + Kd_guess0 = (h_dz_int(K)*vstar) * CS%vonKar * mixlen_BBL(K) else vstar = 0.0 ; Kd_guess0 = 0.0 endif - mixvel(K) = vstar ! Track vstar - Kddt_h_g0 = Kd_guess0 * dt_h - - if (CS%orig_PE_calc) then - call find_PE_chg_orig(Kddt_h_g0, h(k), hp_a, dTe_term, dSe_term, & - dT_km1_t2, dS_km1_t2, dT_to_dPE(k), dS_to_dPE(k), & - dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), & - pres_Z(K), dT_to_dColHt(k), dS_to_dColHt(k), & - dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - PE_chg=PE_chg_g0, dPE_max=PE_chg_max, dPEc_dKd_0=dPEc_dKd_Kd0 ) - else - call find_PE_chg(0.0, Kddt_h_g0, hp_a, h(k), & - Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & - dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE(k), dS_to_dPE(k), & - pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - dT_to_dColHt(k), dS_to_dColHt(k), & - PE_chg=PE_chg_g0, dPE_max=PE_chg_max, dPEc_dKd_0=dPEc_dKd_Kd0 ) + mixvel_BBL(K) = vstar ! Track vstar + + TKE_rescale = 1.0 + if (CS%decay_adjusted_BBL_TKE) then + ! Add a scaling factor that accounts for the exponential decay of TKE from a + ! near-bottom source and the assumption that an increase in the diffusivity at an + ! interface causes a linearly increasing buoyancy flux going from 0 at the bottom + ! to a peak at the interface, and then going back to 0 atop the layer above. + TKE_rescale = exp_decay_TKE_adjust(htot, h(k-1), Idecay_len_TKE) endif - MKE_src = dMKE_max*(1.0 - exp(-Kddt_h_g0 * MKE2_Hharm)) - - ! This block checks out different cases to determine Kd at the present interface. - if ((PE_chg_g0 < 0.0) .or. ((vstar == 0.0) .and. (dPEc_dKd_Kd0 < 0.0))) then - ! This column is convectively unstable. - if (PE_chg_max <= 0.0) then - ! Does MKE_src need to be included in the calculation of vstar here? - TKE_here = mech_TKE + CS%wstar_ustar_coef*(conv_PErel-PE_chg_max) - if (TKE_here > 0.0) then - if (CS%wT_scheme==wT_from_cRoot_TKE) then - vstar = CS%vstar_scale_fac * vstar_unit_scale * (I_dtrho*TKE_here)**C1_3 - elseif (CS%wT_scheme==wT_from_RH18) then - Surface_Scale = max(0.05, 1. - htot/MLD_guess) - vstar = CS%vstar_scale_fac * Surface_Scale * (CS%vstar_surf_fac*u_star + & - vstar_unit_scale * (CS%wstar_ustar_coef*conv_PErel*I_dtrho)**C1_3) - endif - hbs_here = GV%H_to_Z * min(hb_hs(K), MixLen_shape(K)) - mixlen(K) = max(CS%min_mix_len, ((h_tt*hbs_here)*vstar) / & - ((CS%Ekman_scale_coef * absf) * (h_tt*hbs_here) + vstar)) - if (.not.CS%Use_MLD_iteration) then - ! Note again (as prev) that using mixlen here - ! instead of redoing the computation will change answers... - Kd(K) = vstar * CS%vonKar * ((h_tt*hbs_here)*vstar) / & - ((CS%Ekman_scale_coef * absf) * (h_tt*hbs_here) + vstar) - else - Kd(K) = vstar * CS%vonKar * mixlen(K) - endif - else - vstar = 0.0 ; Kd(K) = 0.0 - endif - mixvel(K) = vstar - - if (CS%orig_PE_calc) then - call find_PE_chg_orig(Kd(K)*dt_h, h(k), hp_a, dTe_term, dSe_term, & - dT_km1_t2, dS_km1_t2, dT_to_dPE(k), dS_to_dPE(k), & - dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), & - pres_Z(K), dT_to_dColHt(k), dS_to_dColHt(k), & - dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - PE_chg=dPE_conv) + TKE_eff_avail = TKE_rescale*mech_BBL_TKE + + if (no_MKE_conversion) then + ! Without conversion from MKE to TKE, the updated diffusivity can be determined directly. + call find_Kd_from_PE_chg(Kd(K), Kd_guess0, dt_h, TKE_eff_avail, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt_b(k), dS_to_dColHt_b(k), Kd_add=Kd_BBL(K), PE_chg=TKE_eff_used, & + frac_dKd_max_PE=frac_in_BL) + + ! Do not add energy if the column is convectively unstable. This was handled previously + ! for mixing from the surface. + if (TKE_eff_used < 0.0) TKE_eff_used = 0.0 + + ! Convert back to the TKE that has actually been used. + if (CS%decay_adjusted_BBL_TKE) then + if (TKE_rescale == 0.0) then ! This probably never occurs, even at roundoff. + TKE_used = mech_BBL_TKE ! All the energy was dissipated before it could mix. else - call find_PE_chg(0.0, Kd(K)*dt_h, hp_a, h(k), & - Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & - dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE(k), dS_to_dPE(k), & - pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - dT_to_dColHt(k), dS_to_dColHt(k), & - PE_chg=dPE_conv) - endif - ! Should this be iterated to convergence for Kd? - if (dPE_conv > 0.0) then - Kd(K) = Kd_guess0 ; dPE_conv = PE_chg_g0 - else - MKE_src = dMKE_max*(1.0 - exp(-(Kd(K)*dt_h) * MKE2_Hharm)) + TKE_used = TKE_eff_used / TKE_rescale endif else - ! The energy change does not vary monotonically with Kddt_h. Find the maximum? - Kd(K) = Kd_guess0 ; dPE_conv = PE_chg_g0 + TKE_used = TKE_eff_used endif - conv_PErel = conv_PErel - dPE_conv - mech_TKE = mech_TKE + MKE_src - if (CS%TKE_diagnostics) then - eCD%dTKE_conv = eCD%dTKE_conv - CS%nstar*dPE_conv * I_dtdiag - eCD%dTKE_MKE = eCD%dTKE_MKE + MKE_src * I_dtdiag - endif - if (sfc_connected) then - MLD_output = MLD_output + GV%H_to_Z * h(k) - endif + if (bot_connected) BBLD_output = BBLD_output + frac_in_BL*dz(k-1) + if (frac_in_BL < 1.0) bot_disconnect = .true. - Kddt_h(K) = Kd(K) * dt_h - elseif (tot_TKE + (MKE_src - PE_chg_g0) >= 0.0) then - ! This column is convctively stable and there is energy to support the suggested - ! mixing. Keep that estimate. - Kd(K) = Kd_guess0 - Kddt_h(K) = Kddt_h_g0 - - ! Reduce the mechanical and convective TKE proportionately. - tot_TKE = tot_TKE + MKE_src - TKE_reduc = 0.0 ! tot_TKE could be 0 if Convectively_stable is false. - if (tot_TKE > 0.0) TKE_reduc = (tot_TKE - PE_chg_g0) / tot_TKE if (CS%TKE_diagnostics) then - eCD%dTKE_mixing = eCD%dTKE_mixing - PE_chg_g0 * I_dtdiag - eCD%dTKE_MKE = eCD%dTKE_MKE + MKE_src * I_dtdiag - eCD%dTKE_conv_decay = eCD%dTKE_conv_decay + & - (1.0-TKE_reduc)*(CS%nstar-nstar_FC) * conv_PErel * I_dtdiag - endif - tot_TKE = TKE_reduc*tot_TKE - mech_TKE = TKE_reduc*(mech_TKE + MKE_src) - conv_PErel = TKE_reduc*conv_PErel - if (sfc_connected) then - MLD_output = MLD_output + GV%H_to_Z * h(k) + eCD%dTKE_BBL_mixing = eCD%dTKE_BBL_mixing - TKE_eff_used * I_dtdiag + eCD%dTKE_BBL_decay = eCD%dTKE_BBL_decay - (TKE_used-TKE_eff_used) * I_dtdiag endif - elseif (tot_TKE == 0.0) then - ! This can arise if nstar_FC = 0, but it is not common. - Kd(K) = 0.0 ; Kddt_h(K) = 0.0 - tot_TKE = 0.0 ; conv_PErel = 0.0 ; mech_TKE = 0.0 - sfc_disconnect = .true. + mech_BBL_TKE = mech_BBL_TKE - TKE_used + + Kddt_h(K) = (Kd(K) + Kd_BBL(K)) * dt_h + else - ! There is not enough energy to support the mixing, so reduce the - ! diffusivity to what can be supported. - Kddt_h_max = Kddt_h_g0 ; Kddt_h_min = 0.0 - TKE_left_max = tot_TKE + (MKE_src - PE_chg_g0) - TKE_left_min = tot_TKE - - ! As a starting guess, take the minimum of a false position estimate - ! and a Newton's method estimate starting from Kddt_h = 0.0. - Kddt_h_guess = tot_TKE * Kddt_h_max / max( PE_chg_g0 - MKE_src, & - Kddt_h_max * (dPEc_dKd_Kd0 - dMKE_max * MKE2_Hharm) ) - ! The above expression is mathematically the same as the following - ! except it is not susceptible to division by zero when - ! dPEc_dKd_Kd0 = dMKE_max = 0 . - ! Kddt_h_guess = tot_TKE * min( Kddt_h_max / (PE_chg_g0 - MKE_src), & - ! 1.0 / (dPEc_dKd_Kd0 - dMKE_max * MKE2_Hharm) ) - if (debug) then - TKE_left_itt(:) = 0.0 ; dPEa_dKd_itt(:) = 0.0 ; PE_chg_itt(:) = 0.0 - MKE_src_itt(:) = 0.0 ; Kddt_h_itt(:) = 0.0 - endif - do itt=1,max_itt - if (CS%orig_PE_calc) then - call find_PE_chg_orig(Kddt_h_guess, h(k), hp_a, dTe_term, dSe_term, & - dT_km1_t2, dS_km1_t2, dT_to_dPE(k), dS_to_dPE(k), & - dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), & - pres_Z(K), dT_to_dColHt(k), dS_to_dColHt(k), & - dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - PE_chg=PE_chg, dPEc_dKd=dPEc_dKd ) - else - call find_PE_chg(0.0, Kddt_h_guess, hp_a, h(k), & - Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & - dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE(k), dS_to_dPE(k), & - pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - dT_to_dColHt(k), dS_to_dColHt(k), & - PE_chg=dPE_conv, dPEc_dKd=dPEc_dKd) - endif - MKE_src = dMKE_max * (1.0 - exp(-MKE2_Hharm * Kddt_h_guess)) - dMKE_src_dK = dMKE_max * MKE2_Hharm * exp(-MKE2_Hharm * Kddt_h_guess) - - TKE_left = tot_TKE + (MKE_src - PE_chg) - if (debug .and. itt<=20) then - Kddt_h_itt(itt) = Kddt_h_guess ; MKE_src_itt(itt) = MKE_src - PE_chg_itt(itt) = PE_chg ; dPEa_dKd_itt(itt) = dPEc_dKd - TKE_left_itt(itt) = TKE_left - endif - ! Store the new bounding values, bearing in mind that min and max - ! here refer to Kddt_h and dTKE_left/dKddt_h < 0: - if (TKE_left >= 0.0) then - Kddt_h_min = Kddt_h_guess ; TKE_left_min = TKE_left - else - Kddt_h_max = Kddt_h_guess ; TKE_left_max = TKE_left + Kddt_h_prev = Kd(K) * dt_h + Kddt_h_g0 = Kd_guess0 * dt_h + ! Find the change in PE with the guess at the added bottom boundary layer mixing. + call find_PE_chg(Kddt_h_prev, Kddt_h_g0, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt_b(k), dS_to_dColHt_b(k), & + PE_chg=PE_chg_g0, dPEc_dKd_0=dPEc_dKd_Kd0 ) + + ! MKE_src = 0.0 ! Enable later?: = dMKE_max*(1.0 - exp(-Kddt_h_g0 * MKE2_Hharm)) + + ! Do not add energy if the column is convectively unstable. This was handled previously + ! for mixing from the surface. + if (PE_chg_g0 < 0.0) PE_chg_g0 = 0.0 + + ! This block checks out different cases to determine Kd at the present interface. + ! if (mech_BBL_TKE*TKE_rescale + (MKE_src - PE_chg_g0) >= 0.0) then + if (TKE_eff_avail - PE_chg_g0 >= 0.0) then + ! This column is convectively stable and there is energy to support the suggested + ! mixing, or it is convectively unstable. Keep this first estimate of Kd. + Kd_BBL(K) = Kd_guess0 + Kddt_h(K) = Kddt_h_prev + Kddt_h_g0 + + TKE_used = PE_chg_g0 / TKE_rescale + + if (CS%TKE_diagnostics) then + eCD%dTKE_BBL_mixing = eCD%dTKE_BBL_mixing - PE_chg_g0 * I_dtdiag +! eCD%dTKE_MKE = eCD%dTKE_MKE + MKE_src * I_dtdiag + eCD%dTKE_BBL_decay = eCD%dTKE_BBL_decay - (TKE_used - PE_chg_g0) * I_dtdiag endif - ! Try to use Newton's method, but if it would go outside the bracketed - ! values use the false-position method instead. - use_Newt = .true. - if (dPEc_dKd - dMKE_src_dK <= 0.0) then - use_Newt = .false. - else - dKddt_h_Newt = TKE_left / (dPEc_dKd - dMKE_src_dK) - Kddt_h_Newt = Kddt_h_guess + dKddt_h_Newt - if ((Kddt_h_Newt > Kddt_h_max) .or. (Kddt_h_Newt < Kddt_h_min)) & - use_Newt = .false. + ! mech_BBL_TKE = mech_BBL_TKE + MKE_src - TKE_used + mech_BBL_TKE = mech_BBL_TKE - TKE_used + if (bot_connected) then + BBLD_output = BBLD_output + dz(k-1) endif - if (use_Newt) then - Kddt_h_next = Kddt_h_guess + dKddt_h_Newt - dKddt_h = dKddt_h_Newt - else - Kddt_h_next = (TKE_left_max * Kddt_h_min - Kddt_h_max * TKE_left_min) / & - (TKE_left_max - TKE_left_min) - dKddt_h = Kddt_h_next - Kddt_h_guess + elseif (TKE_eff_avail == 0.0) then + ! This can arise if there is no energy input to drive mixing or if there + ! is such strong decay that the mech_BBL_TKE becomes 0 via an underflow. + Kd_BBL(K) = 0.0 ; Kddt_h(K) = Kddt_h_prev + if (CS%TKE_diagnostics) then + eCD%dTKE_BBL_decay = eCD%dTKE_BBL_decay - mech_BBL_TKE * I_dtdiag endif - - if ((abs(dKddt_h) < 1e-9*Kddt_h_guess) .or. (itt==max_itt)) then - ! Use the old value so that the energy calculation does not need to be repeated. - if (debug) num_itts(K) = itt - exit - else - Kddt_h_guess = Kddt_h_next + mech_BBL_TKE = 0.0 + bot_disconnect = .true. + else + ! There is not enough energy to support the mixing, so reduce the + ! diffusivity to what can be supported. + Kddt_h_max = Kddt_h_g0 ; Kddt_h_min = 0.0 + ! TKE_left_max = TKE_eff_avail + (MKE_src - PE_chg_g0) + TKE_left_max = TKE_eff_avail - PE_chg_g0 + TKE_left_min = TKE_eff_avail + + ! As a starting guess, take the minimum of a false position estimate + ! and a Newton's method estimate starting from dKddt_h = 0.0 + ! Enable conversion from MKE to TKE in the bottom boundary layer later? + ! Kddt_h_guess = TKE_eff_avail * Kddt_h_max / max( PE_chg_g0 - MKE_src, & + ! Kddt_h_max * (dPEc_dKd_Kd0 - dMKE_max * MKE2_Hharm) ) + Kddt_h_guess = TKE_eff_avail * Kddt_h_max / max( PE_chg_g0, Kddt_h_max * dPEc_dKd_Kd0 ) + ! The above expression is mathematically the same as the following + ! except it is not susceptible to division by zero when + ! dPEc_dKd_Kd0 = dMKE_max = 0 . + ! Kddt_h_guess = TKE_eff_avail * min( Kddt_h_max / (PE_chg_g0 - MKE_src), & + ! 1.0 / (dPEc_dKd_Kd0 - dMKE_max * MKE2_Hharm) ) + if (debug) then + TKE_left_itt(:) = 0.0 ; dPEa_dKd_itt(:) = 0.0 ; PE_chg_itt(:) = 0.0 + Kddt_h_itt(:) = 0.0 ! ; MKE_src_itt(:) = 0.0 endif - enddo ! Inner iteration loop on itt. - Kd(K) = Kddt_h_guess / dt_h ; Kddt_h(K) = Kd(K) * dt_h + do itt=1,max_itt + call find_PE_chg(Kddt_h_prev, Kddt_h_guess, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt_b(k), dS_to_dColHt_b(k), & + PE_chg=PE_chg, dPEc_dKd=dPEc_dKd) + ! Enable conversion from MKE to TKE in the bottom boundary layer later? + ! MKE_src = dMKE_max * (1.0 - exp(-MKE2_Hharm * Kddt_h_guess)) + ! dMKE_src_dK = dMKE_max * MKE2_Hharm * exp(-MKE2_Hharm * Kddt_h_guess) + + ! TKE_left = TKE_eff_avail + (MKE_src - PE_chg) + TKE_left = TKE_eff_avail - PE_chg + if (debug .and. itt<=20) then + Kddt_h_itt(itt) = Kddt_h_guess ! ; MKE_src_itt(itt) = MKE_src + PE_chg_itt(itt) = PE_chg ; dPEa_dKd_itt(itt) = dPEc_dKd + TKE_left_itt(itt) = TKE_left + endif + ! Store the new bounding values, bearing in mind that min and max + ! here refer to Kddt_h and dTKE_left/dKddt_h < 0: + if (TKE_left >= 0.0) then + Kddt_h_min = Kddt_h_guess ; TKE_left_min = TKE_left + else + Kddt_h_max = Kddt_h_guess ; TKE_left_max = TKE_left + endif - ! All TKE should have been consumed. - if (CS%TKE_diagnostics) then - eCD%dTKE_mixing = eCD%dTKE_mixing - (tot_TKE + MKE_src) * I_dtdiag - eCD%dTKE_MKE = eCD%dTKE_MKE + MKE_src * I_dtdiag - eCD%dTKE_conv_decay = eCD%dTKE_conv_decay + & - (CS%nstar-nstar_FC) * conv_PErel * I_dtdiag - endif + ! Try to use Newton's method, but if it would go outside the bracketed + ! values use the false-position method instead. + use_Newt = .true. + ! if (dPEc_dKd - dMKE_src_dK <= 0.0) then + if (dPEc_dKd <= 0.0) then + use_Newt = .false. + else + ! dKddt_h_Newt = TKE_left / (dPEc_dKd - dMKE_src_dK) + dKddt_h_Newt = TKE_left / dPEc_dKd + Kddt_h_Newt = Kddt_h_guess + dKddt_h_Newt + if ((Kddt_h_Newt > Kddt_h_max) .or. (Kddt_h_Newt < Kddt_h_min)) & + use_Newt = .false. + endif - if (sfc_connected) MLD_output = MLD_output + & - (PE_chg / (PE_chg_g0)) * GV%H_to_Z * h(k) + if (use_Newt) then + Kddt_h_next = Kddt_h_guess + dKddt_h_Newt + dKddt_h = dKddt_h_Newt + else + Kddt_h_next = (TKE_left_max * Kddt_h_min - Kddt_h_max * TKE_left_min) / & + (TKE_left_max - TKE_left_min) + dKddt_h = Kddt_h_next - Kddt_h_guess + endif - tot_TKE = 0.0 ; mech_TKE = 0.0 ; conv_PErel = 0.0 - sfc_disconnect = .true. - endif ! End of convective or forced mixing cases to determine Kd. + if ((abs(dKddt_h) < 1e-9*Kddt_h_guess) .or. (itt==max_itt)) then + ! Use the old value so that the energy calculation does not need to be repeated. + if (debug) num_itts(K) = itt + exit + else + Kddt_h_guess = Kddt_h_next + endif + enddo ! Inner iteration loop on itt. + Kd_BBL(K) = Kddt_h_guess / dt_h + Kddt_h(K) = (Kd(K) + Kd_BBL(K)) * dt_h + + ! All TKE should have been consumed. + if (CS%TKE_diagnostics) then + ! eCD%dTKE_BBL_mixing = eCD%dTKE_BBL_mixing - (TKE_eff_avail + MKE_src) * I_dtdiag + ! eCD%dTKE_BBL_MKE = eCD%dTKE_BBL_MKE + MKE_src * I_dtdiag + eCD%dTKE_BBL_mixing = eCD%dTKE_BBL_mixing - TKE_eff_avail * I_dtdiag + eCD%dTKE_BBL_decay = eCD%dTKE_BBL_decay - (mech_BBL_TKE-TKE_eff_avail) * I_dtdiag + endif - Kddt_h(K) = Kd(K) * dt_h - ! At this point, the final value of Kddt_h(K) is known, so the - ! estimated properties for layer k-1 can be calculated. - b1 = 1.0 / (hp_a + Kddt_h(K)) - c1(K) = Kddt_h(K) * b1 - if (CS%orig_PE_calc) then - dTe(k-1) = b1 * ( Kddt_h(K)*(T0(k)-T0(k-1)) + dTe_t2 ) - dSe(k-1) = b1 * ( Kddt_h(K)*(S0(k)-S0(k-1)) + dSe_t2 ) - endif + if (bot_connected) BBLD_output = BBLD_output + (PE_chg / PE_chg_g0) * dz(k-1) - hp_a = h(k) + (hp_a * b1) * Kddt_h(K) - dT_to_dPE_a(k) = dT_to_dPE(k) + c1(K)*dT_to_dPE_a(k-1) - dS_to_dPE_a(k) = dS_to_dPE(k) + c1(K)*dS_to_dPE_a(k-1) - dT_to_dColHt_a(k) = dT_to_dColHt(k) + c1(K)*dT_to_dColHt_a(k-1) - dS_to_dColHt_a(k) = dS_to_dColHt(k) + c1(K)*dS_to_dColHt_a(k-1) + mech_BBL_TKE = 0.0 + bot_disconnect = .true. + endif ! End of convective or forced mixing cases to determine Kd. + endif + Kddt_h(K) = (Kd(K) + Kd_BBL(K)) * dt_h endif ! tot_TKT > 0.0 branch. Kddt_h(K) has been set. + ! At this point, the final value of Kddt_h(K) is known, so the + ! estimated properties for layer k can be calculated. + b1 = 1.0 / (hp_b(k) + Kddt_h(K)) + c1(K) = Kddt_h(K) * b1 + + hp_b(k-1) = h(k-1) + (hp_b(k) * b1) * Kddt_h(K) + dT_to_dPE_b(k-1) = dT_to_dPE(k-1) + c1(K)*dT_to_dPE_b(k) + dS_to_dPE_b(k-1) = dS_to_dPE(k-1) + c1(K)*dS_to_dPE_b(k) + dT_to_dColHt_b(k-1) = dT_to_dColHt(k-1) + c1(K)*dT_to_dColHt_b(k) + dS_to_dColHt_b(k-1) = dS_to_dColHt(k-1) + c1(K)*dS_to_dColHt_b(k) + ! Store integrated velocities and thicknesses for MKE conversion calculations. - if (sfc_disconnect) then - ! There is no turbulence at this interface, so zero out the running sums. - uhtot = u(k)*h(k) - vhtot = v(k)*h(k) - htot = h(k) - sfc_connected = .false. + if (bot_disconnect) then + ! There is no turbulence at this interface, so restart the running sums. + uhtot = u(k-1)*h(k-1) + vhtot = v(k-1)*h(k-1) + htot = h(k-1) + dztot = dz(k-1) + bot_connected = .false. else - uhtot = uhtot + u(k)*h(k) - vhtot = vhtot + v(k)*h(k) - htot = htot + h(k) + uhtot = uhtot + u(k-1)*h(k-1) + vhtot = vhtot + v(k-1)*h(k-1) + htot = htot + h(k-1) + dztot = dztot + dz(k-1) endif - if (calc_Te) then - if (k==2) then - Te(1) = b1*(h(1)*T0(1)) - Se(1) = b1*(h(1)*S0(1)) - else - Te(k-1) = b1 * (h(k-1) * T0(k-1) + Kddt_h(K-1) * Te(k-2)) - Se(k-1) = b1 * (h(k-1) * S0(k-1) + Kddt_h(K-1) * Se(k-2)) - endif + if (K==nz) then + Te(k) = b1*(h(k)*T0(k)) + Se(k) = b1*(h(k)*S0(k)) + else + Te(k) = b1 * (h(k) * T0(k) + Kddt_h(K+1) * Te(k+1)) + Se(k) = b1 * (h(k) * S0(k) + Kddt_h(K+1) * Se(k+1)) endif enddo - Kd(nz+1) = 0.0 + Kd_BBL(1) = 0.0 if (debug) then - ! Complete the tridiagonal solve for Te. - b1 = 1.0 / hp_a - Te(nz) = b1 * (h(nz) * T0(nz) + Kddt_h(nz) * Te(nz-1)) - Se(nz) = b1 * (h(nz) * S0(nz) + Kddt_h(nz) * Se(nz-1)) - dT_expect(nz) = Te(nz) - T0(nz) ; dS_expect(nz) = Se(nz) - S0(nz) - do k=nz-1,1,-1 - Te(k) = Te(k) + c1(K+1)*Te(k+1) - Se(k) = Se(k) + c1(K+1)*Se(k+1) + ! Complete the tridiagonal solve for Te with a downward pass. + b1 = 1.0 / hp_b(1) + Te(1) = b1 * (h(1) * T0(1) + Kddt_h(2) * Te(2)) + Se(1) = b1 * (h(1) * S0(1) + Kddt_h(2) * Se(2)) + dT_expect(1) = Te(1) - T0(1) ; dS_expect(1) = Se(1) - S0(1) + do k=2,nz + Te(k) = Te(k) + c1(K)*Te(k-1) + Se(k) = Se(k) + c1(K)*Se(k-1) dT_expect(k) = Te(k) - T0(k) ; dS_expect(k) = Se(k) - S0(k) enddo - endif - if (debug) then dPE_debug = 0.0 do k=1,nz dPE_debug = dPE_debug + (dT_to_dPE(k) * (Te(k) - T0(k)) + & @@ -1374,70 +2714,373 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs enddo mixing_debug = dPE_debug * I_dtdiag endif - k = nz ! This is here to allow a breakpoint to be set. - !/BGR - ! The following lines are used for the iteration - ! note the iteration has been altered to use the value predicted by - ! the TKE threshold (ML_DEPTH). This is because the MSTAR - ! is now dependent on the ML, and therefore the ML needs to be estimated - ! more precisely than the grid spacing. - - !New method uses ML_DEPTH as computed in ePBL routine - MLD_found = MLD_output - if (MLD_found - MLD_guess > CS%MLD_tol) then - min_MLD = MLD_guess ; dMLD_min = MLD_found - MLD_guess - elseif (abs(MLD_found - MLD_guess) < CS%MLD_tol) then - OBL_converged = .true. ! Break convergence loop + + ! Skip the rest of the contents of the do loop if there are no more BBL depth iterations. + if (BBL_it >= CS%max_BBLD_its) exit + + ! The following lines are used for the iteration to determine the boundary layer depth. + ! Note that the iteration uses the value predicted by the TKE threshold (BBL_DEPTH), + ! because the mixing length shape is dependent on the BBL depth, and therefore the BBL depth + ! should be estimated more precisely than the grid spacing. + + ! New method uses BBL_DEPTH as computed in ePBL routine + BBLD_found = BBLD_output + if (abs(BBLD_found - BBLD_guess) < CS%BBLD_tol) then + exit ! Break the BBL depth convergence loop + elseif (BBLD_found > BBLD_guess) then + min_BBLD = BBLD_guess ; dBBLD_min = BBLD_found - BBLD_guess else ! We know this guess was too deep - max_MLD = MLD_guess ; dMLD_max = MLD_found - MLD_guess ! < -CS%MLD_tol + max_BBLD = BBLD_guess ; dBBLD_max = BBLD_found - BBLD_guess ! <= -CS%BBLD_tol endif - if (.not.OBL_converged) then ; if (CS%MLD_bisection) then - ! For the next pass, guess the average of the minimum and maximum values. - MLD_guess = 0.5*(min_MLD + max_MLD) - else ! Try using the false position method or the returned value instead of simple bisection. - ! Taking the occasional step with MLD_output empirically helps to converge faster. - if ((dMLD_min > 0.0) .and. (dMLD_max < 0.0) .and. (OBL_it > 2) .and. (mod(OBL_it-1,4)>0)) then - ! Both bounds have valid change estimates and are probably in the range of possible outputs. - MLD_Guess = (dMLD_min*max_MLD - dMLD_max*min_MLD) / (dMLD_min - dMLD_max) - elseif ((MLD_found > min_MLD) .and. (MLD_found < max_MLD)) then - ! The output MLD_found is an interesting guess, as it likely to bracket the true solution - ! along with the previous value of MLD_guess and to be close to the solution. - MLD_guess = MLD_found - else ! Bisect if the other guesses would be out-of-bounds. This does not happen much. - MLD_guess = 0.5*(min_MLD + max_MLD) - endif - endif ; endif - endif - if ((OBL_converged) .or. (OBL_it==CS%Max_MLD_Its)) then - if (report_avg_its) then - CS%sum_its(1) = CS%sum_its(1) + real_to_EFP(real(OBL_it)) - CS%sum_its(2) = CS%sum_its(2) + real_to_EFP(1.0) + ! Try using the false position method or the returned value instead of simple bisection. + ! Taking the occasional step with BBLD_output empirically helps to converge faster. + if ((dBBLD_min > 0.0) .and. (dBBLD_max < 0.0) .and. (BBL_it > 2) .and. (mod(BBL_it-1,4) > 0)) then + ! Both bounds have valid change estimates and are probably in the range of possible outputs. + BBLD_guess = (dBBLD_min*max_BBLD - dBBLD_max*min_BBLD) / (dBBLD_min - dBBLD_max) + elseif ((BBLD_found > min_BBLD) .and. (BBLD_found < max_BBLD)) then + ! The output BBLD_found is an interesting guess, as it is likely to bracket the true solution + ! along with the previous value of BBLD_guess and to be close to the solution. + BBLD_guess = BBLD_found + else ! Bisect if the other guesses would be out-of-bounds. This does not happen much. + BBLD_guess = 0.5*(min_BBLD + max_BBLD) endif - exit + + enddo ! Iteration loop for converged boundary layer thickness. + + eCD%BBL_its = min(BBL_it, CS%max_BBLD_its) + BBLD_io = BBLD_output + endif + +end subroutine ePBL_BBL_column + +!> Gives shape function that sets the vertical structure of OSBL diffusivity +!! as described in Sane et al. 2025 +subroutine kappa_eqdisc(shape_func, CS, GV, dz, absf, B_flux, u_star, MLD_guess) + + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(energetic_PBL_CS), intent(in) :: CS !< Energetic PBL control struct + real, dimension(SZK_(GV)+1), intent(inout) :: shape_func !< shape function, [nondim] + real, intent(in) :: absf !< The absolute value of f [T-1 ~> s-1] + real, intent(in) :: u_star !< The surface friction velocity [Z T-1 ~> m s-1] + real, intent(in) :: B_Flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3] + real, dimension(SZK_(GV)), intent(in) :: dz !< The vertical distance across layers [Z ~> m] + real, intent(in) :: MLD_guess !< Mixing Layer depth guessed/found for iteration [Z ~> m]. + real, dimension(SZK_(GV)+1) :: hz !< depth variable, only used in this routine [H ~> m] + + ! local variables for this subroutine + integer :: nz + integer :: K, n ! integers for looping + real :: Lh ! ((B_flux * h))/(u_star^3), boundary layer depth by M-O depth, [nondim] + real :: Eh ! ((h f)/u_star ), boundary layer depth by Ekman depth, [nondim] + real :: sm ! sigma_max: location of maximum of shape function in sigma coordinate [nondim] + real :: hbl ! Boundary layer depth, same as MLD_guess [Z ~> m] + real :: F ! function, used in asymptotic model for sm, Equation 7 in Sane et al. 2024 [nondim] + real :: F_Eh ! F multiplied by Eh [nondim] + real :: u_star_I ! inverse of u_star [Z-1 T ~> m-1 s] + + ! variables used for optimizing computations: + real :: sm_h ! sigma_max multiplied by boundary layer depth [Z ~> m] + real :: sm_h_I ! inverse of sm_h [Z-1 ~> m-1] + real :: hz_n ! z depth to avoid calling hz multiple times [Z ~> m] + real :: z_minus_sm_h ! depth z minus \sigma_m * MLD_Guess [Z ~> m] + real :: z_minus_sm_h2 ! (depth z minus \sigma_m * MLD_Guess)^2 [Z2 ~> m2] + real :: z_minus_sm_h3 ! (depth z minus \sigma_m * MLD_Guess)^3 [Z3 ~> m3] + real :: h_minus_smh_I ! inverse of (MLD_Guess - \sigma_m * MLD_Guess) [Z-1 ~> m-1] + real :: h_minus_smh_I2 ! inverse of (MLD_Guess - \sigma_m * MLD_Guess) ^ 2 [Z-2 ~> m-2] + real :: h_minus_smh_I3 ! inverse of (MLD_Guess - \sigma_m * MLD_Guess) ^ 3 [Z-3 ~> m-3] + real :: z_sm_h_I ! depth divided by (\sigma_m * MLD_Guess) [nondim] + real :: coef_c2 ! = 2.98 * h_minus_smh_I2 ! [Z-2 ~> m-2] + real :: coef_c3 ! = 2.98 * h_minus_smh_I2 ! [Z-3 ~> m-3] + + nz = SZK_(GV)+1 + hz(1) = 0.0 + do K=2,nz + hz(K) = hz(K-1) + dz(K-1) + enddo + hbl = MLD_Guess ! hbl is boundary layer depth. + + u_star_I = 1.0/u_star + Lh = (-B_flux * hbl) * ((u_star_I * u_star_I) * u_star_I) ! Boundary layer depth divided by Monin-Obukhov depth + Eh = (hbl * absf) * u_star_I ! Boundary layer depth divided by Ekman depth + + ! B_flux given negative sign to follow convention used in Sane et al. 2023 + ! Lh < 0 --> surface stabilizing i.e. heating, and Lh > 0 --> surface destabilizing i.e. cooling + ! This capping does not matter because these equations have asymptotes. Not sensitive beyond the caps. + Eh = min(Eh, CS%Eh_upper_cap) ! capping p1 to less than 2.0. It is always >0.0. + Lh = min(max(Lh, -CS%Lh_cap), CS%Lh_cap) ! capping Lh between -8 and 8 + + ! Empirical model to predict sm: + ! F is Equation (6) in Sane et al. 2025, and needs to be computed before sigma_m: + ! \mathcal{F} = \frac{1}{c_3 + c_4 \cdot e^{-\left( \text{sgn}(B) \cdot {c_5} \cdot {{L_h}^3} \right)}} + c_6 + ! Equation (5) in Sane et al. 2025: + ! \sigma_{m} = \frac{1}{c_1 + \frac{c_2}{\mathcal{F} \cdot E_h}} + ! Note: Lh over here is ((Bh)/ustar^3), whereas in Sane et al. 2025, L_h = (((Bh)^{1/3})/(ustar)) + + F = (1.0/ ( CS%ML_c(3) + CS%ML_c(4) * exp(-CS%ML_c(5) * Lh) ) ) + CS%ML_c(6) + F_Eh = F * Eh + sm = F_Eh / (CS%ML_c(1)*F_Eh +CS%ML_c(2)) + sm = min(max(sm, CS%sigma_max_lower_cap), CS%sigma_max_upper_cap) ! makes sure 0.1 hbl) then + shape_func(n) = CS%shape_function_epsilon ! set an arbitrary low constant value below hbl, default 0.01 endif - enddo ! Iteration loop for converged boundary layer thickness. - if (CS%Use_LT) then - eCD%LA = LA ; eCD%LAmod = LAmod ; eCD%mstar = mstar_total ; eCD%mstar_LT = mstar_LT + enddo +end subroutine kappa_eqdisc + +!> Gives velocity scale (v_0) using equations that approximate neural network of Sane et al. 2023 +subroutine get_eqdisc_v0(CS, absf, B_flux, u_star, v0_dummy) + type(energetic_PBL_CS), intent(in) :: CS !< Energetic PBL control struct + real, intent(in) :: B_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3] + real, intent(in) :: u_star !< The surface friction velocity [Z T-1 ~> m s-1] + real, intent(in) :: absf !< The absolute value of f [T-1 ~> s-1]. + real, intent(inout) :: v0_dummy !< velocity scale v0, local variable [Z T-1 ~> m s-1] + + ! local variables for this subroutine + real :: bflux_c ! capped bflux [Z2 T-3 ~> m2 s-3] + real :: absf_c ! capped absf [T-1 ~> s-1] + real :: root_b_f ! square root of (abs(B_flux) * Coriolis) [Z T-2 ~> m s-2] + real :: f_u2 ! Coriolis X ustar^2 [Z2 T-3 ~> m2 s-3] + real :: den ! denominator, units iof buuyancy flux [Z2 T-3 ~> m2 s-3] + real :: root_B_by_Omega ! sqrt( B / Omega ) [Z T-1 ~> m s-1] + real :: f_prime ! Coriolis divided by Earth's rotation [nondim] + real :: omega_I ! Inverse of the Earth's rotation rate, 1 divided by omega [T ~> s] + + if (B_flux <= CS%bflux_lower_cap) then + bflux_c = CS%bflux_lower_cap + elseif (B_flux >= CS%bflux_upper_cap) then + bflux_c = CS%bflux_upper_cap else - eCD%LA = 0.0 ; eCD%LAmod = 0.0 ; eCD%mstar = mstar_total ; eCD%mstar_LT = 0.0 + bflux_c = B_flux endif - MLD_io = MLD_output + if (absf <= CS%f_lower) then ! + absf_c = CS%f_lower ! 0.1 deg Latitude, cap avoids zero coriolis, solution insensitive below 0.1 deg. + else + absf_c = absf + endif -end subroutine ePBL_column + f_u2 = absf_c * (u_star * u_star) ! pre-computing + + ! setting v0_dummy here: + ! \lambda = (1/ustar) \sqrt(bflux_c/absf_c) + + if (bflux_c >= 0.0) then ! surface heating and neutral conditions + ! Equation 7 in Sane et al. 2025: + ! \frac{v_0}{u_*} = \frac{c_{7}}{\lambda + c_{8} + \frac{c_{9}^2}{\lambda + c_{9}} } + + root_b_f = sqrt( bflux_c * absf_c) + den = bflux_c + (CS%ML_c(8) + CS%ML_c(9)) * u_star * root_b_f + & + (CS%ML_c(8) * CS%ML_c(9) + CS%ML_c(9)**2) * f_u2 + v0_dummy = ( ( CS%ML_c(7)*( (u_star * root_b_f) + (CS%ML_c(9)*f_u2) ) ) * u_star) / den + + else ! surface cooling + ! Equation 8 in Sane et al. 2025: + ! \frac{v_0}{u_*}=\frac{c_{10} \cdot \lambda \cdot \sqrt{f'} }{1 + + ! \frac{(c_{11} e^{(-c_{12} \cdot f')} + c_{13}) }{\lambda ^2} } + c_{14} + + omega_I = 1.0 / CS%omega + f_prime = absf_c * omega_I ! Coriolis divided by Earth's rotation + root_B_by_Omega = sqrt( -bflux_c * omega_I ) + den = ( -bflux_c + CS%ML_c(11) * f_u2 * exp(-f_prime * CS%ML_c(12) ) ) + CS%ML_c(13)*f_u2 + v0_dummy = ( CS%ML_c(10) * (-bflux_c * root_B_by_Omega) / den ) + ( CS%ML_c(14) * u_star ) + + endif + + v0_dummy = min( max(v0_dummy, CS%v0_lower_cap), CS%v0_upper_cap ) + ! upper cap kept for safety, but has never hit this cap. + + ! v0_lower_cap has been set to 0.0001 as data below that values does not exist in the training + ! solution was tested for lower cap of 0.00001 and was found to be insensitive. + ! sensitivity arises when lower cap is 0.0. That is when diffusivity attains extremely low values and + ! they go near molecular diffusivity. Boundary layers might become "sub-grid" i.e. < 1 metre + ! some cause issues such as anomlous surface warming. + ! this needs further investigation, our choices are motivated by practicallity for now. +end subroutine get_eqdisc_v0 + +!> Gives velocity scale (v_0^h) using equations that with using boundary layer depth as one of its inputs +!! These equations are different than those set in get_eqdisc_v0 subroutine +subroutine get_eqdisc_v0h(CS, B_flux, u_star, MLD_guess, v0_dummy) + type(energetic_PBL_CS), intent(in) :: CS !< Energetic PBL control struct + real, intent(in) :: B_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3] + real, intent(in) :: u_star !< The surface friction velocity [Z T-1 ~> m s-1] + real, intent(in) :: MLD_guess !< boundary layer depth guessed/found for iteration [Z ~> m] + + real, intent(inout) :: v0_dummy !< velocity scale v0, local variable [Z T-1 ~> m s-1] + + ! local variables for this subroutine + real :: bflux_c ! capped bflux [Z2 T-3 ~> m2 s-3] + real :: B_h, den ! Surface buoyancy flux multiplied by boundary layer depth, den is a denominator [Z3 T-3 ~> m3 s-3] + real :: B_h_power1by3 ! cuberoot of (Surface buoyancy flux multiplied by boundary layer depth) [Z T-1 ~> m s-1] + real :: u_star_2 ! u_star squared, [Z2 T-2 ~> m2 s-2] + real :: u_star_3 ! u_star cubed, [Z3 T-3 ~> m3 s-3] + + u_star_2 = u_star * u_star ! pre-multiplying to get ustar ^ 2 + u_star_3 = u_star_2 * u_star ! ustar ^ 3.0 + + if (B_flux <= CS%bflux_lower_cap) then + bflux_c = CS%bflux_lower_cap + elseif (B_flux >= CS%bflux_upper_cap) then + bflux_c = CS%bflux_upper_cap + else + bflux_c = B_flux + endif + + B_h = abs(bflux_c) * MLD_guess + B_h_power1by3 = cuberoot(B_h) + + ! setting v0_dummy here: + + if (bflux_c >= 0.0) then ! surface heating and neutral conditions + ! Equation 9 in Sane et al. 2025: + ! \frac{v_0^h}{u_*} = \frac{C_{14}}{ c_{15} L_h^3 + c_{16} L_h^2 + 1 } + + den = ( CS%ML_c(15) * B_h + CS%ML_c(16)* u_star*(B_h_power1by3*B_h_power1by3)) & + + (u_star*u_star_2) + v0_dummy = ( CS%ML_c(14) * (u_star_2 * u_star_2)) / den + + else + ! Equation 10 in Sane et al. 2025: + ! \frac{v_0^h}{u_*} = \frac{L_h}{c_{17} + \frac{c_{18}}{L_h ^2}} + c_{14} + den = CS%ML_c(17) * (B_h_power1by3*B_h_power1by3) + CS%ML_c(18) * u_star_2 + v0_dummy = (B_h / den ) + CS%ML_c(14) * u_star + endif + + v0_dummy = min( max(v0_dummy, CS%v0_lower_cap), CS%v0_upper_cap ) + ! upper cap kept for safety, but has never hit this cap. + + ! v0_lower_cap has been set to 0.0001 as data below that values does not exist in the training + ! solution was tested for lower cap of 0.00001 and was found to be insensitive. + ! sensitivity arises when lower cap is 0.0. That is when diffusivity attains extremely low values and + ! they go near molecular diffusivity. Boundary layers might become "sub-grid" i.e. < 1 metre + ! some cause issues such as anomlous surface warming. + ! this needs further investigation, our choices are motivated by practicallity for now. +end subroutine get_eqdisc_v0h + +!> Determine a scaling factor that accounts for the exponential decay of turbulent kinetic energy +!! from a boundary source and the assumption that an increase in the diffusivity at an interface +!! causes a linearly increasing buoyancy flux going from 0 at the bottom to a peak at the interface, +!! and then going back to 0 atop the layer above. Where this factor increases the available mixing +!! TKE, it is only compensating for the fact that the TKE has already been reduced by the same +!! exponential decay rate. ha and hb must be non-negative, and this function generally increases +!! with hb and decreases with ha. +!! +!! Exp_decay_TKE_adjust is coded to have a lower bound of 1e-30 on the return value. For large +!! values of ha*Idecay, the return value is about 0.5*ka*(ha+hb)*Idecay**2 * exp(-ha*Idecay), but +!! return values of less than 1e-30 are deliberately reset to 1e-30. For relatively large values +!! of hb*Idecay, the return value increases linearly with hb. When Idecay ~= 0, the return value +!! is close to 1. +function exp_decay_TKE_adjust(hb, ha, Idecay) result(TKE_to_PE_scale) + real, intent(in) :: hb !< The thickness over which the buoyancy flux varies on the + !! near-boundary side of an interface (e.g., a well-mixed bottom + !! boundary layer thickness) [H ~> m or kg m-2] + real, intent(in) :: ha !< The thickness of the layer on the opposite side of an interface from + !! the boundary [H ~> m or kg m-2] + real, intent(in) :: Idecay !< The inverse of a turbulence decay length scale [H-1 ~> m-1 or m2 kg-1] + real :: TKE_to_PE_scale !< The effective fractional change in energy available to + !! drive mixing at this interface once the exponential decay of TKE + !! is accounted for [nondim]. TKE_to_PE_scale is always positive. + + real :: khb ! The thickness on the boundary side times the TKE decay rate [nondim] + real :: kha ! The thickness away from from the boundary times the TKE decay rate [nondim] + real, parameter :: C1_3 = 1.0/3.0 ! A rational constant [nondim] + + khb = abs(hb*Idecay) + kha = abs(ha*Idecay) + + ! For large enough kha that exp(kha) > 1.0e17*kha: + ! TKE_to_PE_scale = (0.5 * (khb + kha) * kha) * exp(-kha) > (0.5 * kha**2) * exp(-kha) + ! To keep TKE_to_PE_scale > -1e30 and avoid overflow in the exp(), keep kha < kha_max_30, where: + ! kha_max_30 = ln(0.5*1e30) + 2.0 * ln(kha_max_30) ~= 68.3844 + 2.0 * ln(68.3844+8.6895)) + ! If kha_max = 77.0739, (0.5 * kha_max**2) * exp(-kha_max) = 1.0e-30. + + if (kha > 77.0739) then + TKE_to_PE_scale = 1.0e-30 + elseif ((kha > 2.2e-4) .and. (khb > 2.2e-4)) then + ! This is the usual case, derived from integrals of z exp(z) over the layers above and below. + ! TKE_to_PE_scale = (0.5 * (khb + kha)) / & + ! ((exp(-khb) - (1.0 - khb)) / khb + (exp(kha) - (1.0 + kha)) / kha) + TKE_to_PE_scale = (0.5 * (khb + kha) * (kha * khb)) / & + (kha * (exp(-khb) - (1.0 - khb)) + khb * (exp(kha) - (1.0 + kha))) + elseif (khb > 2.2e-4) then + ! For small values of kha, approximate (exp(kha) - (1.0 + hha)) by the first two + ! terms of its Taylor series: 0.5*kha**2 + C1_6*kha**3 + ... + kha**n/n! + ... + ! which is more accurate when kha**4/24. < 1e-16 or kha < ~ 2.21e-4. + TKE_to_PE_scale = (0.5 * (khb + kha) * khb) / & + ((exp(-khb) - (1.0 - khb)) + 0.5*(khb * kha) * (1.0 + C1_3*kha)) + elseif (kha > 2.2e-4) then + ! Use a Taylor series expansion for small values of khb + TKE_to_PE_scale = (0.5 * (khb + kha) * kha) / & + (0.5 * (kha * khb) * (1.0 - C1_3*Khb) + (exp(kha) - (1.0 + kha))) + else ! (kha < 2.2e-4) .and. (khb < 2.2e-4) - use Taylor series approximations for both + TKE_to_PE_scale = 1.0 / (1.0 + C1_3*(kha - khb)) + endif + + if (TKE_to_PE_scale < 1.0e-30) TKE_to_PE_scale = 1.0e-30 + + ! For kha >> 1: + ! TKE_to_PE_scale = (0.5 * (khb + kha) * kha) * exp(-kha) + + ! For khb >> 1: + ! TKE_to_PE_scale = (0.5 * (khb + kha) * (kha * khb)) / & + ! (khb * exp(kha) - (kha + khb))) + ! For khb >> 1 and khb >> kha: + ! TKE_to_PE_scale = (0.5 * (kha * khb)) / (exp(kha) - 1.0)) + +end function exp_decay_TKE_adjust !> This subroutine calculates the change in potential energy and or derivatives -!! for several changes in an interfaces's diapycnal diffusivity times a timestep. +!! for several changes in an interface's diapycnal diffusivity times a timestep. subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & dT_to_dPE_a, dS_to_dPE_a, dT_to_dPE_b, dS_to_dPE_b, & pres_Z, dT_to_dColHt_a, dS_to_dColHt_a, dT_to_dColHt_b, dS_to_dColHt_b, & PE_chg, dPEc_dKd, dPE_max, dPEc_dKd_0, PE_ColHt_cor) real, intent(in) :: Kddt_h0 !< The previously used diffusivity at an interface times - !! the time step and divided by the average of the + !! the time step and divided by the average of the !! thicknesses around the interface [H ~> m or kg m-2]. real, intent(in) :: dKddt_h !< The trial change in the diffusivity at an interface times - !! the time step and divided by the average of the + !! the time step and divided by the average of the !! thicknesses around the interface [H ~> m or kg m-2]. real, intent(in) :: hp_a !< The effective pivot thickness of the layer above the !! interface, given by h_k plus a term that @@ -1446,72 +3089,72 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & real, intent(in) :: hp_b !< The effective pivot thickness of the layer below the !! interface, given by h_k plus a term that !! is a fraction (determined from the tridiagonal solver) of - !! Kddt_h for the interface above [H ~> m or kg m-2]. + !! Kddt_h for the interface below [H ~> m or kg m-2]. real, intent(in) :: Th_a !< An effective temperature times a thickness in the layer !! above, including implicit mixing effects with other - !! yet higher layers [degC H ~> degC m or degC kg m-2]. + !! yet higher layers [C H ~> degC m or degC kg m-2]. real, intent(in) :: Sh_a !< An effective salinity times a thickness in the layer !! above, including implicit mixing effects with other - !! yet higher layers [degC H ~> degC m or degC kg m-2]. + !! yet higher layers [S H ~> ppt m or ppt kg m-2]. real, intent(in) :: Th_b !< An effective temperature times a thickness in the layer - !! below, including implicit mixfing effects with other - !! yet lower layers [degC H ~> degC m or degC kg m-2]. + !! below, including implicit mixing effects with other + !! yet lower layers [C H ~> degC m or degC kg m-2]. real, intent(in) :: Sh_b !< An effective salinity times a thickness in the layer !! below, including implicit mixing effects with other - !! yet lower layers [degC H ~> degC m or degC kg m-2]. + !! yet lower layers [S H ~> ppt m or ppt kg m-2]. real, intent(in) :: dT_to_dPE_a !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating !! a layer's temperature change to the change in column potential !! energy, including all implicit diffusive changes in the - !! temperatures of all the layers above [R Z3 T-2 degC-1 ~> J m-2 degC-1]. + !! temperatures of all the layers above [R Z3 T-2 C-1 ~> J m-2 degC-1]. real, intent(in) :: dS_to_dPE_a !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating !! a layer's salinity change to the change in column potential !! energy, including all implicit diffusive changes in the - !! salinities of all the layers above [R Z3 T-2 ppt-1 ~> J m-2 ppt-1]. + !! salinities of all the layers above [R Z3 T-2 S-1 ~> J m-2 ppt-1]. real, intent(in) :: dT_to_dPE_b !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating !! a layer's temperature change to the change in column potential !! energy, including all implicit diffusive changes in the - !! temperatures of all the layers below [R Z3 T-2 degC-1 ~> J m-2 degC-1]. + !! temperatures of all the layers below [R Z3 T-2 C-1 ~> J m-2 degC-1]. real, intent(in) :: dS_to_dPE_b !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating !! a layer's salinity change to the change in column potential !! energy, including all implicit diffusive changes in the - !! salinities of all the layers below [R Z3 T-2 ppt-1 ~> J m-2 ppt-1]. + !! salinities of all the layers below [R Z3 T-2 S-1 ~> J m-2 ppt-1]. real, intent(in) :: pres_Z !< The rescaled hydrostatic interface pressure, which relates !! the changes in column thickness to the energy that is radiated !! as gravity waves and unavailable to drive mixing [R Z2 T-2 ~> J m-3]. real, intent(in) :: dT_to_dColHt_a !< A factor (mass_lay*dSColHtc_vol/dT) relating !! a layer's temperature change to the change in column !! height, including all implicit diffusive changes - !! in the temperatures of all the layers above [Z degC-1 ~> m degC-1]. + !! in the temperatures of all the layers above [Z C-1 ~> m degC-1]. real, intent(in) :: dS_to_dColHt_a !< A factor (mass_lay*dSColHtc_vol/dS) relating !! a layer's salinity change to the change in column !! height, including all implicit diffusive changes - !! in the salinities of all the layers above [Z ppt-1 ~> m ppt-1]. + !! in the salinities of all the layers above [Z S-1 ~> m ppt-1]. real, intent(in) :: dT_to_dColHt_b !< A factor (mass_lay*dSColHtc_vol/dT) relating !! a layer's temperature change to the change in column !! height, including all implicit diffusive changes - !! in the temperatures of all the layers below [Z degC-1 ~> m degC-1]. + !! in the temperatures of all the layers below [Z C-1 ~> m degC-1]. real, intent(in) :: dS_to_dColHt_b !< A factor (mass_lay*dSColHtc_vol/dS) relating !! a layer's salinity change to the change in column !! height, including all implicit diffusive changes - !! in the salinities of all the layers below [Z ppt-1 ~> m ppt-1]. + !! in the salinities of all the layers below [Z S-1 ~> m ppt-1]. real, intent(out) :: PE_chg !< The change in column potential energy from applying - !! Kddt_h at the present interface [R Z3 T-2 ~> J m-2]. - real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h + !! dKddt_h at the present interface [R Z3 T-2 ~> J m-2]. + real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with dKddt_h !! [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. real, optional, intent(out) :: dPE_max !< The maximum change in column potential energy that could - !! be realizedd by applying a huge value of Kddt_h at the + !! be realized by applying a huge value of dKddt_h at the !! present interface [R Z3 T-2 ~> J m-2]. - real, optional, intent(out) :: dPEc_dKd_0 !< The partial derivative of PE_chg with Kddt_h in the - !! limit where Kddt_h = 0 [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. + real, optional, intent(out) :: dPEc_dKd_0 !< The partial derivative of PE_chg with dKddt_h in the + !! limit where dKddt_h = 0 [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. real, optional, intent(out) :: PE_ColHt_cor !< The correction to PE_chg that is made due to a net !! change in the column height [R Z3 T-2 ~> J m-2]. ! Local variables real :: hps ! The sum of the two effective pivot thicknesses [H ~> m or kg m-2]. real :: bdt1 ! A product of the two pivot thicknesses plus a diffusive term [H2 ~> m2 or kg2 m-4]. - real :: dT_c ! The core term in the expressions for the temperature changes [degC H2 ~> degC m2 or degC kg2 m-4]. - real :: dS_c ! The core term in the expressions for the salinity changes [ppt H2 ~> ppt m2 or ppt kg2 m-4]. + real :: dT_c ! The core term in the expressions for the temperature changes [C H2 ~> degC m2 or degC kg2 m-4]. + real :: dS_c ! The core term in the expressions for the salinity changes [S H2 ~> ppt m2 or ppt kg2 m-4]. real :: PEc_core ! The diffusivity-independent core term in the expressions ! for the potential energy changes [R Z2 T-2 ~> J m-3]. real :: ColHt_core ! The diffusivity-independent core term in the expressions @@ -1523,7 +3166,7 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & ! The expression for the change in potential energy used here is derived ! from the expression for the final estimates of the changes in temperature ! and salinities, and then extensively manipulated to get it into its most - ! succint form. The derivation is not necessarily obvious, but it demonstrably + ! succinct form. The derivation is not necessarily obvious, but it demonstrably ! works by comparison with separate calculations of the energy changes after ! the tridiagonal solver for the final changes in temperature and salinity are ! applied. @@ -1572,8 +3215,155 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & end subroutine find_PE_chg + +!> This subroutine directly calculates the an increment in the diapycnal diffusivity based on the +!! change in potential energy within a timestep, subject to bounds on the possible change in +!! diffusivity, returning both the added diffusivity and the realized potential energy change, and +!! optionally also the maximum change in potential energy that would be realized for an infinitely +!! large diffusivity. +subroutine find_Kd_from_PE_chg(Kd_prev, dKd_max, dt_h, max_PE_chg, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & + dT_to_dPE_a, dS_to_dPE_a, dT_to_dPE_b, dS_to_dPE_b, pres_Z, & + dT_to_dColHt_a, dS_to_dColHt_a, dT_to_dColHt_b, dS_to_dColHt_b, & + Kd_add, PE_chg, dPE_max, frac_dKd_max_PE) + real, intent(in) :: Kd_prev !< The previously used diffusivity at an interface + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, intent(in) :: dKd_max !< The maximum change in the diffusivity at an interface + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, intent(in) :: dt_h !< The time step and divided by the average of the + !! thicknesses around the interface [T Z-1 ~> s m-1]. + real, intent(in) :: max_PE_chg !< The maximum change in the column potential energy due to + !! additional mixing at an interface [R Z3 T-2 ~> J m-2]. + + real, intent(in) :: hp_a !< The effective pivot thickness of the layer above the + !! interface, given by h_k plus a term that + !! is a fraction (determined from the tridiagonal solver) of + !! Kddt_h for the interface above [H ~> m or kg m-2]. + real, intent(in) :: hp_b !< The effective pivot thickness of the layer below the + !! interface, given by h_k plus a term that + !! is a fraction (determined from the tridiagonal solver) of + !! Kddt_h for the interface below [H ~> m or kg m-2]. + real, intent(in) :: Th_a !< An effective temperature times a thickness in the layer + !! above, including implicit mixing effects with other + !! yet higher layers [C H ~> degC m or degC kg m-2]. + real, intent(in) :: Sh_a !< An effective salinity times a thickness in the layer + !! above, including implicit mixing effects with other + !! yet higher layers [S H ~> ppt m or ppt kg m-2]. + real, intent(in) :: Th_b !< An effective temperature times a thickness in the layer + !! below, including implicit mixing effects with other + !! yet lower layers [C H ~> degC m or degC kg m-2]. + real, intent(in) :: Sh_b !< An effective salinity times a thickness in the layer + !! below, including implicit mixing effects with other + !! yet lower layers [S H ~> ppt m or ppt kg m-2]. + real, intent(in) :: dT_to_dPE_a !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating + !! a layer's temperature change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! temperatures of all the layers above [R Z3 T-2 C-1 ~> J m-2 degC-1]. + real, intent(in) :: dS_to_dPE_a !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating + !! a layer's salinity change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! salinities of all the layers above [R Z3 T-2 S-1 ~> J m-2 ppt-1]. + real, intent(in) :: dT_to_dPE_b !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating + !! a layer's temperature change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! temperatures of all the layers below [R Z3 T-2 C-1 ~> J m-2 degC-1]. + real, intent(in) :: dS_to_dPE_b !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating + !! a layer's salinity change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! salinities of all the layers below [R Z3 T-2 S-1 ~> J m-2 ppt-1]. + real, intent(in) :: pres_Z !< The rescaled hydrostatic interface pressure, which relates + !! the changes in column thickness to the energy that is radiated + !! as gravity waves and unavailable to drive mixing [R Z2 T-2 ~> J m-3]. + real, intent(in) :: dT_to_dColHt_a !< A factor (mass_lay*dSColHtc_vol/dT) relating + !! a layer's temperature change to the change in column + !! height, including all implicit diffusive changes + !! in the temperatures of all the layers above [Z C-1 ~> m degC-1]. + real, intent(in) :: dS_to_dColHt_a !< A factor (mass_lay*dSColHtc_vol/dS) relating + !! a layer's salinity change to the change in column + !! height, including all implicit diffusive changes + !! in the salinities of all the layers above [Z S-1 ~> m ppt-1]. + real, intent(in) :: dT_to_dColHt_b !< A factor (mass_lay*dSColHtc_vol/dT) relating + !! a layer's temperature change to the change in column + !! height, including all implicit diffusive changes + !! in the temperatures of all the layers below [Z C-1 ~> m degC-1]. + real, intent(in) :: dS_to_dColHt_b !< A factor (mass_lay*dSColHtc_vol/dS) relating + !! a layer's salinity change to the change in column + !! height, including all implicit diffusive changes + !! in the salinities of all the layers below [Z S-1 ~> m ppt-1]. + real, intent(out) :: Kd_add !< The additional diffusivity at an interface + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, intent(out) :: PE_chg !< The realized change in the column potential energy due to + !! additional mixing at an interface [R Z3 T-2 ~> J m-2]. + real, optional, & + intent(out) :: dPE_max !< The maximum change in column potential energy that could + !! be realized by applying a huge value of dKddt_h at the + !! present interface [R Z3 T-2 ~> J m-2]. + real, optional, & + intent(out) :: frac_dKd_max_PE !< The fraction of the energy required to support dKd_max + !! that is supplied by max_PE_chg [nondim] + + ! Local variables + real :: Kddt_h0 ! The previously used diffusivity at an interface times the time step + ! and divided by the average of the thicknesses around the + ! interface [H ~> m or kg m-2]. + real :: dKddt_h ! The upper bound on the change in the diffusivity at an interface times + ! the time step and divided by the average of the thicknesses around + ! the interface [H ~> m or kg m-2]. + real :: hps ! The sum of the two effective pivot thicknesses [H ~> m or kg m-2]. + real :: bdt1 ! A product of the two pivot thicknesses plus a diffusive term [H2 ~> m2 or kg2 m-4]. + real :: dT_c ! The core term in the expressions for the temperature changes [C H2 ~> degC m2 or degC kg2 m-4]. + real :: dS_c ! The core term in the expressions for the salinity changes [S H2 ~> ppt m2 or ppt kg2 m-4]. + real :: PEc_core ! The diffusivity-independent core term in the expressions + ! for the potential energy changes [R Z2 T-2 ~> J m-3]. + real :: ColHt_core ! The diffusivity-independent core term in the expressions + ! for the column height changes [H Z ~> m2 or kg m-1]. + + ! The expression for the change in potential energy used here is derived from the expression + ! for the final estimates of the changes in temperature and salinities, which is then + ! extensively manipulated to get it into its most succinct form. It is the same as the + ! expression that appears in find_PE_chg. + + Kddt_h0 = Kd_prev * dt_h + hps = hp_a + hp_b + bdt1 = hp_a * hp_b + Kddt_h0 * hps + dT_c = hp_a * Th_b - hp_b * Th_a + dS_c = hp_a * Sh_b - hp_b * Sh_a + PEc_core = hp_b * (dT_to_dPE_a * dT_c + dS_to_dPE_a * dS_c) - & + hp_a * (dT_to_dPE_b * dT_c + dS_to_dPE_b * dS_c) + ColHt_core = hp_b * (dT_to_dColHt_a * dT_c + dS_to_dColHt_a * dS_c) - & + hp_a * (dT_to_dColHt_b * dT_c + dS_to_dColHt_b * dS_c) + if (ColHt_core < 0.0) PEc_core = PEc_core - pres_Z * ColHt_core + + ! Find the change in column potential energy due to the change in the + ! diffusivity at this interface by dKd_max, and use this to dermine which limit applies. + dKddt_h = dKd_max * dt_h + if ( (PEc_core * dKddt_h <= max_PE_chg * (bdt1 * (bdt1 + dKddt_h * hps))) .or. (PEc_core <= 0.0) ) then + ! There is more than enough energy available to support the maximum permitted diffusivity. + Kd_add = dKd_max + PE_chg = PEc_core * dKddt_h / (bdt1 * (bdt1 + dKddt_h * hps)) + if (present(frac_dKd_max_PE)) frac_dKd_max_PE = 1.0 + else + ! Mixing is constrained by the available energy, so solve the following for Kd_add: + ! max_PE_chg = PEc_core * Kd_add * dt_h / (bdt1 * (bdt1 + Kd_add * dt_h * hps)) + ! It has been verified that the two branches are continuous. + Kd_add = (bdt1**2 * max_PE_chg) / (dt_h * (PEc_core - bdt1 * hps * max_PE_chg)) + PE_chg = max_PE_chg + if (present(frac_dKd_max_PE)) & + frac_dKd_max_PE = (PE_chg * (bdt1 * (bdt1 + dKddt_h * hps))) / (PEc_core * dKddt_h) + endif + + ! Note that the derivative of PE_chg with dKddt_h is monotonic: + ! dPE_chg_dKd = PEc_core * ( (bdt1 * (bdt1 + dKddt_h * hps)) - bdtl * hps * dKddt_h ) / & + ! (bdt1 * (bdt1 + dKddt_h * hps))**2 + ! dPE_chg_dKd = PEc_core / (bdt1 + dKddt_h * hps)**2 + + ! This expression is the limit of PE_chg for infinite dKddt_h. + if (present(dPE_max)) dPE_max = PEc_core / (bdt1 * hps) + +end subroutine find_Kd_from_PE_chg + + !> This subroutine calculates the change in potential energy and or derivatives -!! for several changes in an interfaces's diapycnal diffusivity times a timestep +!! for several changes in an interface's diapycnal diffusivity times a timestep !! using the original form used in the first version of ePBL. subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & dT_km1_t2, dS_km1_t2, dT_to_dPE_k, dS_to_dPE_k, & @@ -1589,55 +3379,55 @@ subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & !! is a fraction (determined from the tridiagonal solver) of !! Kddt_h for the interface above [H ~> m or kg m-2]. real, intent(in) :: dTe_term !< A diffusivity-independent term related to the temperature change - !! in the layer below the interface [degC H ~> degC m or degC kg m-2]. + !! in the layer below the interface [C H ~> degC m or degC kg m-2]. real, intent(in) :: dSe_term !< A diffusivity-independent term related to the salinity change - !! in the layer below the interface [ppt H ~> ppt m or ppt kg m-2]. + !! in the layer below the interface [S H ~> ppt m or ppt kg m-2]. real, intent(in) :: dT_km1_t2 !< A diffusivity-independent term related to the - !! temperature change in the layer above the interface [degC]. + !! temperature change in the layer above the interface [C ~> degC]. real, intent(in) :: dS_km1_t2 !< A diffusivity-independent term related to the - !! salinity change in the layer above the interface [ppt]. + !! salinity change in the layer above the interface [S ~> ppt]. real, intent(in) :: pres_Z !< The rescaled hydrostatic interface pressure, which relates !! the changes in column thickness to the energy that is radiated !! as gravity waves and unavailable to drive mixing [R Z2 T-2 ~> J m-3]. real, intent(in) :: dT_to_dPE_k !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating !! a layer's temperature change to the change in column potential !! energy, including all implicit diffusive changes in the - !! temperatures of all the layers below [R Z3 T-2 degC-1 ~> J m-2 degC-1]. + !! temperatures of all the layers below [R Z3 T-2 C-1 ~> J m-2 degC-1]. real, intent(in) :: dS_to_dPE_k !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating !! a layer's salinity change to the change in column potential !! energy, including all implicit diffusive changes in the - !! in the salinities of all the layers below [R Z3 T-2 ppt-1 ~> J m-2 ppt-1]. + !! in the salinities of all the layers below [R Z3 T-2 S-1 ~> J m-2 ppt-1]. real, intent(in) :: dT_to_dPEa !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating !! a layer's temperature change to the change in column potential !! energy, including all implicit diffusive changes in the - !! temperatures of all the layers above [R Z3 T-2 degC-1 ~> J m-2 degC-1]. + !! temperatures of all the layers above [R Z3 T-2 C-1 ~> J m-2 degC-1]. real, intent(in) :: dS_to_dPEa !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating !! a layer's salinity change to the change in column potential !! energy, including all implicit diffusive changes in the - !! salinities of all the layers above [R Z3 T-2 ppt-1 ~> J m-2 ppt-1]. + !! salinities of all the layers above [R Z3 T-2 S-1 ~> J m-2 ppt-1]. real, intent(in) :: dT_to_dColHt_k !< A factor (mass_lay*dSColHtc_vol/dT) relating !! a layer's temperature change to the change in column !! height, including all implicit diffusive changes in the - !! temperatures of all the layers below [Z degC-1 ~> m degC-1]. + !! temperatures of all the layers below [Z C-1 ~> m degC-1]. real, intent(in) :: dS_to_dColHt_k !< A factor (mass_lay*dSColHtc_vol/dS) relating !! a layer's salinity change to the change in column !! height, including all implicit diffusive changes - !! in the salinities of all the layers below [Z ppt-1 ~> m ppt-1]. + !! in the salinities of all the layers below [Z S-1 ~> m ppt-1]. real, intent(in) :: dT_to_dColHta !< A factor (mass_lay*dSColHtc_vol/dT) relating !! a layer's temperature change to the change in column !! height, including all implicit diffusive changes - !! in the temperatures of all the layers above [Z degC-1 ~> m degC-1]. + !! in the temperatures of all the layers above [Z C-1 ~> m degC-1]. real, intent(in) :: dS_to_dColHta !< A factor (mass_lay*dSColHtc_vol/dS) relating !! a layer's salinity change to the change in column !! height, including all implicit diffusive changes - !! in the salinities of all the layers above [Z ppt-1 ~> m ppt-1]. + !! in the salinities of all the layers above [Z S-1 ~> m ppt-1]. real, intent(out) :: PE_chg !< The change in column potential energy from applying !! Kddt_h at the present interface [R Z3 T-2 ~> J m-2]. real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h !! [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. real, optional, intent(out) :: dPE_max !< The maximum change in column potential energy that could - !! be realizedd by applying a huge value of Kddt_h at the + !! be realized by applying a huge value of Kddt_h at the !! present interface [R Z3 T-2 ~> J m-2]. real, optional, intent(out) :: dPEc_dKd_0 !< The partial derivative of PE_chg with Kddt_h in the !! limit where Kddt_h = 0 [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. @@ -1657,14 +3447,14 @@ subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & real :: ColHt_chg ! The change in column thickness [Z ~> m]. real :: dColHt_max ! The change in column thickness for infinite diffusivity [Z ~> m]. real :: dColHt_dKd ! The partial derivative of column thickness with Kddt_h [Z H-1 ~> nondim or m3 kg-1] - real :: dT_k, dT_km1 ! Temperature changes in layers k and k-1 [degC] - real :: dS_k, dS_km1 ! Salinity changes in layers k and k-1 [ppt] + real :: dT_k, dT_km1 ! Temperature changes in layers k and k-1 [C ~> degC] + real :: dS_k, dS_km1 ! Salinity changes in layers k and k-1 [S ~> ppt] real :: I_Kr_denom ! Temporary array [H-2 ~> m-2 or m4 kg-2] real :: dKr_dKd ! Temporary array [H-2 ~> m-2 or m4 kg-2] real :: ddT_k_dKd, ddT_km1_dKd ! Temporary arrays indicating the temperature changes - ! per unit change in Kddt_h [degC H-1 ~> degC m-1 or degC m2 kg-1] + ! per unit change in Kddt_h [C H-1 ~> degC m-1 or degC m2 kg-1] real :: ddS_k_dKd, ddS_km1_dKd ! Temporary arrays indicating the salinity changes - ! per unit change in Kddt_h [ppt H-1 ~> ppt m-1 or ppt m2 kg-1] + ! per unit change in Kddt_h [S H-1 ~> ppt m-1 or ppt m2 kg-1] b1 = 1.0 / (b_den_1 + Kddt_h) b1Kd = Kddt_h*b1 @@ -1728,111 +3518,121 @@ subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & end subroutine find_PE_chg_orig -!> This subroutine finds the Mstar value for ePBL -subroutine find_mstar(CS, US, Buoyancy_Flux, UStar, UStar_Mean,& - BLD, Abs_Coriolis, MStar, Langmuir_Number,& - MStar_LT, Convect_Langmuir_Number) +!> This subroutine finds the mstar value for ePBL +subroutine find_mstar(CS, US, Buoyancy_Flux, UStar, & + BLD, Abs_Coriolis, Is_BBL, mstar, & + Langmuir_Number, mstar_LT, Convect_Langmuir_Number) type(energetic_PBL_CS), intent(in) :: CS !< Energetic PBL control structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, intent(in) :: UStar !< ustar w/ gustiness [Z T-1 ~> m s-1] - real, intent(in) :: UStar_Mean !< ustar w/o gustiness [Z T-1 ~> m s-1] - real, intent(in) :: Abs_Coriolis !< abolute value of the Coriolis parameter [T-1 ~> s-1] + real, intent(in) :: UStar !< ustar including gustiness [Z T-1 ~> m s-1] + real, intent(in) :: Abs_Coriolis !< absolute value of the Coriolis parameter [T-1 ~> s-1] real, intent(in) :: Buoyancy_Flux !< Buoyancy flux [Z2 T-3 ~> m2 s-3] real, intent(in) :: BLD !< boundary layer depth [Z ~> m] - real, intent(out) :: Mstar !< Ouput mstar (Mixing/ustar**3) [nondim] + logical, intent(in) :: Is_BBL !< Logcal flag to indicate if bottom boundary layer mode + real, intent(out) :: mstar !< Output mstar (Mixing/ustar**3) [nondim] real, optional, intent(in) :: Langmuir_Number !< Langmuir number [nondim] - real, optional, intent(out) :: MStar_LT !< Mstar increase due to Langmuir turbulence [nondim] + real, optional, intent(out) :: mstar_LT !< mstar increase due to Langmuir turbulence [nondim] real, optional, intent(out) :: Convect_Langmuir_number !< Langmuir number including buoyancy flux [nondim] !/ Variables used in computing mstar real :: MSN_term ! Temporary terms [nondim] real :: MSCR_term1, MSCR_term2 ! Temporary terms [Z3 T-3 ~> m3 s-3] - real :: MStar_Conv_Red ! Adjustment made to mstar due to convection reducing mechanical mixing [nondim] - real :: MStar_S, MStar_N ! Mstar in (S)tabilizing/(N)ot-stabilizing buoyancy flux [nondim] + real :: mstar_Conv_Red ! Adjustment made to mstar due to convection reducing mechanical mixing [nondim] + real :: mstar_S, mstar_N ! mstar in (S)tabilizing/(N)ot-stabilizing buoyancy flux [nondim] + integer :: mstar_scheme ! Toggles between surface and bottom boundary layer mstar scheme from control structure !/ Integer options for how to find mstar !/ - if (CS%mstar_scheme == Use_Fixed_MStar) then - MStar = CS%Fixed_MStar + if (Is_BBL) then + mstar_scheme = CS%BBL_mstar_scheme + else + mstar_scheme = CS%mstar_scheme + endif + + if (mstar_scheme == Use_Fixed_mstar) then + if (Is_BBL) then + mstar = CS%BBL_Fixed_mstar + else + mstar = CS%Fixed_mstar + endif !/ 1. Get mstar - elseif (CS%mstar_scheme == MStar_from_Ekman) then + elseif (mstar_scheme == mstar_from_Ekman) then - if (CS%answers_2018) then + if (CS%answer_date < 20190101) then ! The limit for the balance of rotation and stabilizing is f(L_Ekman,L_Obukhov) - MStar_S = CS%MStar_coef*sqrt(max(0.0,Buoyancy_Flux) / UStar**2 / & + mstar_S = CS%mstar_coef*sqrt(max(0.0,Buoyancy_Flux) / UStar**2 / & (Abs_Coriolis + 1.e-10*US%T_to_s) ) ! The limit for rotation (Ekman length) limited mixing - MStar_N = CS%C_Ek * log( max( 1., UStar / (Abs_Coriolis + 1.e-10*US%T_to_s) / BLD ) ) + mstar_N = CS%C_Ek * log( max( 1., UStar / (Abs_Coriolis + 1.e-10*US%T_to_s) / BLD ) ) else ! The limit for the balance of rotation and stabilizing is f(L_Ekman,L_Obukhov) - MStar_S = CS%MSTAR_COEF*sqrt(max(0.0, Buoyancy_Flux) / (UStar**2 * max(Abs_Coriolis, 1.e-20*US%T_to_s))) + mstar_S = CS%mstar_coef*sqrt(max(0.0, Buoyancy_Flux) / (UStar**2 * max(Abs_Coriolis, 1.e-20*US%T_to_s))) ! The limit for rotation (Ekman length) limited mixing - MStar_N = 0.0 - if (UStar > Abs_Coriolis * BLD) Mstar_N = CS%C_EK * log(UStar / (Abs_Coriolis * BLD)) + mstar_N = 0.0 + if (UStar > Abs_Coriolis * BLD) mstar_N = CS%C_Ek * log(UStar / (Abs_Coriolis * BLD)) endif ! Here 1.25 is about .5/von Karman, which gives the Obukhov limit. - MStar = max(MStar_S, min(1.25, MStar_N)) - if (CS%MStar_Cap > 0.0) MStar = min( CS%MStar_Cap,MStar ) - elseif ( CS%mstar_scheme == MStar_from_RH18 ) then - if (CS%answers_2018) then - MStar_N = CS%RH18_MStar_cn1 * ( 1.0 - 1.0 / ( 1. + CS%RH18_MStar_cn2 * & + mstar = max(mstar_S, min(1.25, mstar_N)) + if (CS%mstar_Cap > 0.0) mstar = min( CS%mstar_Cap,mstar ) + elseif ( mstar_scheme == mstar_from_RH18 ) then + if (CS%answer_date < 20190101) then + mstar_N = CS%RH18_mstar_cn1 * ( 1.0 - 1.0 / ( 1. + CS%RH18_mstar_cn2 * & exp( CS%RH18_mstar_CN3 * BLD * Abs_Coriolis / UStar) ) ) else - MSN_term = CS%RH18_MStar_cn2 * exp( CS%RH18_mstar_CN3 * BLD * Abs_Coriolis / UStar) - MStar_N = (CS%RH18_MStar_cn1 * MSN_term) / ( 1. + MSN_term) + MSN_term = CS%RH18_mstar_cn2 * exp( CS%RH18_mstar_CN3 * BLD * Abs_Coriolis / UStar) + mstar_N = (CS%RH18_mstar_cn1 * MSN_term) / ( 1. + MSN_term) endif - MStar_S = CS%RH18_MStar_CS1 * ( max(0.0, Buoyancy_Flux)**2 * BLD / & + mstar_S = CS%RH18_mstar_CS1 * ( max(0.0, Buoyancy_Flux)**2 * BLD / & ( UStar**5 * max(Abs_Coriolis,1.e-20*US%T_to_s) ) )**CS%RH18_mstar_cs2 - MStar = MStar_N + MStar_S + mstar = mstar_N + mstar_S endif !/ 2. Adjust mstar to account for convective turbulence - if (CS%answers_2018) then - MStar_Conv_Red = 1. - CS%MStar_Convect_coef * (-min(0.0,Buoyancy_Flux) + 1.e-10*US%T_to_s**3*US%m_to_Z**2) / & + if (CS%answer_date < 20190101) then + mstar_Conv_Red = 1. - CS%mstar_Convect_coef * (-min(0.0,Buoyancy_Flux) + 1.e-10*US%T_to_s**3*US%m_to_Z**2) / & ( (-min(0.0,Buoyancy_Flux) + 1.e-10*US%T_to_s**3*US%m_to_Z**2) + & - 2.0 *MStar * UStar**3 / BLD ) + 2.0 *mstar * UStar**3 / BLD ) else MSCR_term1 = -BLD * min(0.0, Buoyancy_Flux) - MSCR_term2 = 2.0*MStar * UStar**3 + MSCR_term2 = 2.0*mstar * UStar**3 if ( abs(MSCR_term2) > 0.0) then - MStar_Conv_Red = ((1.-CS%mstar_convect_coef) * MSCR_term1 + MSCR_term2) / (MSCR_term1 + MSCR_term2) + mstar_Conv_Red = ((1.-CS%mstar_convect_coef) * MSCR_term1 + MSCR_term2) / (MSCR_term1 + MSCR_term2) else - MStar_Conv_Red = 1.-CS%mstar_convect_coef + mstar_Conv_Red = 1.-CS%mstar_convect_coef endif endif !/3. Combine various mstar terms to get final value - MStar = MStar * MStar_Conv_Red + mstar = mstar * mstar_Conv_Red - if (present(Langmuir_Number)) then - !### In this call, ustar was previously ustar_mean. Is this change deliberate, Brandon? -RWH - call mstar_Langmuir(CS, US, Abs_Coriolis, Buoyancy_Flux, UStar, BLD, Langmuir_Number, MStar, & - MStar_LT, Convect_Langmuir_Number) + if ((.not.Is_BBL) .and. (present(Langmuir_Number))) then + call mstar_Langmuir(CS, US, Abs_Coriolis, Buoyancy_Flux, UStar, BLD, Langmuir_Number, mstar, & + mstar_LT, Convect_Langmuir_Number) endif -end subroutine Find_Mstar +end subroutine Find_mstar -!> This subroutine modifies the Mstar value if the Langmuir number is present -subroutine Mstar_Langmuir(CS, US, Abs_Coriolis, Buoyancy_Flux, UStar, BLD, Langmuir_Number, & - Mstar, MStar_LT, Convect_Langmuir_Number) +!> This subroutine modifies the mstar value if the Langmuir number is present +subroutine mstar_Langmuir(CS, US, Abs_Coriolis, Buoyancy_Flux, UStar, BLD, Langmuir_Number, & + mstar, mstar_LT, Convect_Langmuir_Number) type(energetic_PBL_CS), intent(in) :: CS !< Energetic PBL control structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(in) :: Abs_Coriolis !< Absolute value of the Coriolis parameter [T-1 ~> s-1] real, intent(in) :: Buoyancy_Flux !< Buoyancy flux [Z2 T-3 ~> m2 s-3] real, intent(in) :: UStar !< Surface friction velocity with? gustiness [Z T-1 ~> m s-1] real, intent(in) :: BLD !< boundary layer depth [Z ~> m] - real, intent(inout) :: Mstar !< Input/output mstar (Mixing/ustar**3) [nondim] + real, intent(inout) :: mstar !< Input/output mstar (Mixing/ustar**3) [nondim] real, intent(in) :: Langmuir_Number !< Langmuir number [nondim] - real, intent(out) :: MStar_LT !< Mstar increase due to Langmuir turbulence [nondim] + real, intent(out) :: mstar_LT !< mstar increase due to Langmuir turbulence [nondim] real, intent(out) :: Convect_Langmuir_number !< Langmuir number including buoyancy flux [nondim] !/ - real, parameter :: Max_ratio = 1.0e16 ! The maximum value of a nondimensional ratio. - real :: enhance_mstar ! A multiplicative scaling of mstar due to Langmuir turbulence. - real :: mstar_LT_add ! A value that is added to mstar due to Langmuir turbulence. + real, parameter :: Max_ratio = 1.0e16 ! The maximum value of a nondimensional ratio [nondim]. + real :: enhance_mstar ! A multiplicative scaling of mstar due to Langmuir turbulence [nondim]. + real :: mstar_LT_add ! A value that is added to mstar due to Langmuir turbulence [nondim]. real :: iL_Ekman ! Inverse of Ekman length scale [Z-1 ~> m-1]. real :: iL_Obukhov ! Inverse of Obukhov length scale [Z-1 ~> m-1]. real :: I_ustar ! The Adcroft reciprocal of ustar [T Z-1 ~> s m-1] @@ -1840,17 +3640,21 @@ subroutine Mstar_Langmuir(CS, US, Abs_Coriolis, Buoyancy_Flux, UStar, BLD, Langm real :: MLD_Ekman ! The ratio of the mixed layer depth to the Ekman layer depth [nondim]. real :: Ekman_Obukhov ! The Ekman layer thickness divided by the Obukhov depth [nondim]. real :: MLD_Obukhov ! The mixed layer depth divided by the Obukhov depth [nondim]. - real :: MLD_Obukhov_stab ! Ratios of length scales where MLD is boundary layer depth [nondim]. - real :: Ekman_Obukhov_stab ! > - real :: MLD_Obukhov_un ! Ratios of length scales where MLD is boundary layer depth - real :: Ekman_Obukhov_un ! > + real :: MLD_Obukhov_stab ! The mixed layer depth divided by the Obukhov depth under stable + ! conditions or 0 under unstable conditions [nondim]. + real :: Ekman_Obukhov_stab ! The Ekman layer thickness divided by the Obukhov depth under stable + ! conditions or 0 under unstable conditions [nondim]. + real :: MLD_Obukhov_un ! The mixed layer depth divided by the Obukhov depth under unstable + ! conditions or 0 under stable conditions [nondim]. + real :: Ekman_Obukhov_un ! The Ekman layer thickness divided by the Obukhov depth under unstable + ! conditions or 0 under stable conditions [nondim]. ! Set default values for no Langmuir effects. enhance_mstar = 1.0 ; mstar_LT_add = 0.0 - if (CS%LT_Enhance_Form /= No_Langmuir) then + if (CS%LT_enhance_form /= No_Langmuir) then ! a. Get parameters for modified LA - if (CS%answers_2018) then + if (CS%answer_date < 20190101) then iL_Ekman = Abs_Coriolis / Ustar iL_Obukhov = Buoyancy_Flux*CS%vonkar / Ustar**3 Ekman_Obukhov_stab = abs(max(0., iL_Obukhov / (iL_Ekman + 1.e-10*US%Z_to_m))) @@ -1882,42 +3686,43 @@ subroutine Mstar_Langmuir(CS, US, Abs_Coriolis, Buoyancy_Flux, UStar, BLD, Langm ! Assumes linear factors based on length scale ratios to adjust LA ! Note when these coefficients are set to 0 recovers simple LA. Convect_Langmuir_Number = Langmuir_Number * & - ( (1.0 + max(-0.5, CS%LaC_MLDoEK * MLD_Ekman)) + & - ((CS%LaC_EKoOB_stab * Ekman_Obukhov_stab + CS%LaC_EKoOB_un * Ekman_Obukhov_un) + & - (CS%LaC_MLDoOB_stab * MLD_Obukhov_stab + CS%LaC_MLDoOB_un * MLD_Obukhov_un)) ) + ( (1.0 + max(-0.5, CS%LaC_MLD_Ek * MLD_Ekman)) + & + ((CS%LaC_Ek_Ob_stab * Ekman_Obukhov_stab + CS%LaC_Ek_Ob_un * Ekman_Obukhov_un) + & + (CS%LaC_MLD_Ob_stab * MLD_Obukhov_stab + CS%LaC_MLD_Ob_un * MLD_Obukhov_un)) ) - if (CS%LT_Enhance_Form == Langmuir_rescale) then + if (CS%LT_enhance_form == Langmuir_rescale) then ! Enhancement is multiplied (added mst_lt set to 0) Enhance_mstar = min(CS%Max_Enhance_M, & - (1. + CS%LT_ENHANCE_COEF * Convect_Langmuir_Number**CS%LT_ENHANCE_EXP) ) - elseif (CS%LT_ENHANCE_Form == Langmuir_add) then + (1. + CS%LT_enhance_coef * Convect_Langmuir_Number**CS%LT_enhance_exp) ) + elseif (CS%LT_enhance_form == Langmuir_add) then ! or Enhancement is additive (multiplied enhance_m set to 1) - mstar_LT_add = CS%LT_ENHANCE_COEF * Convect_Langmuir_Number**CS%LT_ENHANCE_EXP + mstar_LT_add = CS%LT_enhance_coef * Convect_Langmuir_Number**CS%LT_enhance_exp endif endif mstar_LT = (enhance_mstar - 1.0)*mstar + mstar_LT_add ! Diagnose the full increase in mstar. mstar = mstar*enhance_mstar + mstar_LT_add -end subroutine Mstar_Langmuir +end subroutine mstar_Langmuir !> Copies the ePBL active mixed layer depth into MLD, in units of [Z ~> m] unless other units are specified. subroutine energetic_PBL_get_MLD(CS, MLD, G, US, m_to_MLD_units) - type(energetic_PBL_CS), intent(in) :: CS !< Energetic PBL control struct + type(energetic_PBL_CS), intent(in) :: CS !< Energetic PBL control structure type(ocean_grid_type), intent(in) :: G !< Grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: MLD !< Depth of ePBL active mixing layer [Z ~> m] or other units + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: MLD !< Depth of ePBL active mixing layer [Z ~> m] + !! or other units real, optional, intent(in) :: m_to_MLD_units !< A conversion factor from meters - !! to the desired units for MLD + !! to the desired units for MLD, sometimes [Z m-1 ~> 1] ! Local variables - real :: scale ! A dimensional rescaling factor - integer :: i,j + real :: scale ! A dimensional rescaling factor, often [nondim] or [m Z-1 ~> 1] + integer :: i, j scale = 1.0 ; if (present(m_to_MLD_units)) scale = US%Z_to_m * m_to_MLD_units do j=G%jsc,G%jec ; do i=G%isc,G%iec - MLD(i,j) = scale*CS%ML_Depth(i,j) + MLD(i,j) = scale*CS%ML_depth(i,j) enddo ; enddo end subroutine energetic_PBL_get_MLD @@ -1931,18 +3736,25 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic output - type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control struct + type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control structure ! Local variables ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_energetic_PBL" ! This module's name. - character(len=20) :: tmpstr - real :: omega_frac_dflt + character(len=20) :: tmpstr ! A string that is parsed for parameter settings + character(len=20) :: mstar_scheme ! A string that is parsed for mstar parameter settings + character(len=20) :: vel_scale_str ! A string that is parsed for velocity scale parameter settings + character(len=120) :: diff_text ! A clause describing parameter setting that differ. + real :: omega_frac_dflt ! The default for omega_frac [nondim] integer :: isd, ied, jsd, jed integer :: mstar_mode, LT_enhance, wT_mode - logical :: default_2018_answers - logical :: use_temperature, use_omega + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. + logical :: use_omega + logical :: no_BBL ! If true, EPBL_BBL_EFFIC < 0 and EPBL_BBL_TIDAL_EFFIC < 0, so + ! bottom boundary layer mixing is not enabled. logical :: use_la_windsea isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -1955,16 +3767,19 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) !/1. General ePBL settings + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) call get_param(param_file, mdl, "OMEGA", CS%omega, & - "The rotation rate of the earth.", units="s-1", & - default=7.2921e-5, scale=US%T_to_S) + "The rotation rate of the earth.", & + units="s-1", default=7.2921e-5, scale=US%T_to_S) call get_param(param_file, mdl, "ML_USE_OMEGA", use_omega, & "If true, use the absolute rotation rate instead of the "//& "vertical component of rotation when setting the decay "//& "scale for turbulence.", default=.false., do_not_log=.true.) omega_frac_dflt = 0.0 if (use_omega) then - call MOM_error(WARNING, "ML_USE_OMEGA is depricated; use ML_OMEGA_FRAC=1.0 instead.") + call MOM_error(WARNING, "ML_USE_OMEGA is deprecated; use ML_OMEGA_FRAC=1.0 instead.") omega_frac_dflt = 1.0 endif call get_param(param_file, mdl, "ML_OMEGA_FRAC", CS%omega_frac, & @@ -1976,122 +3791,163 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) "A nondimensional scaling factor controlling the inhibition "//& "of the diffusive length scale by rotation. Making this larger "//& "decreases the PBL diffusivity.", units="nondim", default=1.0) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) - call get_param(param_file, mdl, "EPBL_2018_ANSWERS", CS%answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) - + call get_param(param_file, mdl, 'VON_KARMAN_CONST', CS%vonKar, & + 'The value the von Karman constant as used for mixed layer viscosity.', & + units='nondim', default=0.41) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "EPBL_ANSWER_DATE", CS%answer_date, & + "The vintage of the order of arithmetic and expressions in the energetic "//& + "PBL 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. Values below 20240101 use A**(1./3.) to estimate the cube "//& + "root of A in several expressions, while higher values use the integer root "//& + "function cuberoot(A) and therefore can work with scaled variables.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) call get_param(param_file, mdl, "EPBL_ORIGINAL_PE_CALC", CS%orig_PE_calc, & - "If true, the ePBL code uses the original form of the "//& - "potential energy change code. Otherwise, the newer "//& - "version that can work with successive increments to the "//& - "diffusivity in upward or downward passes is used.", default=.true.) + "If true, the ePBL code uses the original form of the potential energy change "//& + "code. Otherwise, the newer version that can work with successive increments "//& + "to the diffusivity in upward or downward passes is used.", & + default=.true.) ! Change the default to .false.? call get_param(param_file, mdl, "MKE_TO_TKE_EFFIC", CS%MKE_to_TKE_effic, & "The efficiency with which mean kinetic energy released "//& "by mechanically forced entrainment of the mixed layer "//& - "is converted to turbulent kinetic energy.", units="nondim", & - default=0.0) + "is converted to turbulent kinetic energy.", & + units="nondim", default=0.0, scale=US%L_to_Z**2) call get_param(param_file, mdl, "TKE_DECAY", CS%TKE_decay, & - "TKE_DECAY relates the vertical rate of decay of the "//& - "TKE available for mechanical entrainment to the natural "//& - "Ekman depth.", units="nondim", default=2.5) + "TKE_DECAY relates the vertical rate of decay of the TKE available "//& + "for mechanical entrainment to the natural Ekman depth.", & + units="nondim", default=2.5) + call get_param(param_file, mdl, "DIRECT_EPBL_MIXING_CALC", CS%direct_calc, & + "If true and there is no conversion from mean kinetic energy to ePBL turbulent "//& + "kinetic energy, use a direct calculation of the diffusivity that is supported "//& + "by a given energy input instead of the more general but slower iterative solver.", & + default=.false., do_not_log=(CS%MKE_to_TKE_effic>0.0)) -!/2. Options related to setting MSTAR - call get_param(param_file, mdl, "EPBL_MSTAR_SCHEME", tmpstr, & +!/2. Options related to setting mstar + + call get_param(param_file, mdl, "EPBL_MSTAR_SCHEME", mstar_scheme, & "EPBL_MSTAR_SCHEME selects the method for setting mstar. Valid values are: \n"//& "\t CONSTANT - Use a fixed mstar given by MSTAR \n"//& - "\t OM4 - Use L_Ekman/L_Obukhov in the sabilizing limit, as in OM4 \n"//& + "\t OM4 - Use L_Ekman/L_Obukhov in the stabilizing limit, as in OM4 \n"//& "\t REICHL_H18 - Use the scheme documented in Reichl & Hallberg, 2018.", & default=CONSTANT_STRING, do_not_log=.true.) call get_param(param_file, mdl, "MSTAR_MODE", mstar_mode, default=-1) if (mstar_mode == 0) then - tmpstr = CONSTANT_STRING + mstar_scheme = CONSTANT_STRING call MOM_error(WARNING, "Use EPBL_MSTAR_SCHEME = CONSTANT instead of the archaic MSTAR_MODE = 0.") elseif (mstar_mode == 1) then call MOM_error(FATAL, "You are using a legacy mstar mode in ePBL that has been phased out. "//& "If you need to use this setting please report this error. Also use "//& "EPBL_MSTAR_SCHEME to specify the scheme for mstar.") elseif (mstar_mode == 2) then - tmpstr = OM4_STRING + mstar_scheme = OM4_STRING call MOM_error(WARNING, "Use EPBL_MSTAR_SCHEME = OM4 instead of the archaic MSTAR_MODE = 2.") elseif (mstar_mode == 3) then - tmpstr = RH18_STRING + mstar_scheme = RH18_STRING call MOM_error(WARNING, "Use EPBL_MSTAR_SCHEME = REICHL_H18 instead of the archaic MSTAR_MODE = 3.") elseif (mstar_mode > 3) then call MOM_error(FATAL, "An unrecognized value of the obsolete parameter MSTAR_MODE was specified.") endif - call log_param(param_file, mdl, "EPBL_MSTAR_SCHEME", tmpstr, & + call log_param(param_file, mdl, "EPBL_MSTAR_SCHEME", mstar_scheme, & "EPBL_MSTAR_SCHEME selects the method for setting mstar. Valid values are: \n"//& "\t CONSTANT - Use a fixed mstar given by MSTAR \n"//& "\t OM4 - Use L_Ekman/L_Obukhov in the stabilizing limit, as in OM4 \n"//& "\t REICHL_H18 - Use the scheme documented in Reichl & Hallberg, 2018.", & default=CONSTANT_STRING) - tmpstr = uppercase(tmpstr) - select case (tmpstr) + mstar_scheme = uppercase(mstar_scheme) + select case (mstar_scheme) case (CONSTANT_STRING) - CS%mstar_Scheme = Use_Fixed_MStar + CS%mstar_scheme = Use_Fixed_mstar case (OM4_STRING) - CS%mstar_Scheme = MStar_from_Ekman + CS%mstar_scheme = mstar_from_Ekman case (RH18_STRING) - CS%mstar_Scheme = MStar_from_RH18 + CS%mstar_scheme = mstar_from_RH18 case default - call MOM_mesg('energetic_PBL_init: EPBL_MSTAR_SCHEME ="'//trim(tmpstr)//'"', 0) + call MOM_mesg('energetic_PBL_init: EPBL_MSTAR_SCHEME ="'//trim(mstar_scheme)//'"', 0) call MOM_error(FATAL, "energetic_PBL_init: Unrecognized setting "// & - "EPBL_MSTAR_SCHEME = "//trim(tmpstr)//" found in input file.") + "EPBL_MSTAR_SCHEME = "//trim(mstar_scheme)//" found in input file.") end select - call get_param(param_file, mdl, "MSTAR", CS%fixed_mstar, & "The ratio of the friction velocity cubed to the TKE input to the "//& - "mixed layer. This option is used if EPBL_MSTAR_SCHEME = CONSTANT.", & - units="nondim", default=1.2, do_not_log=(CS%mstar_scheme/=Use_Fixed_MStar)) + "surface boundary layer. This option is used if EPBL_MSTAR_SCHEME = CONSTANT.", & + units="nondim", default=1.2, do_not_log=(CS%mstar_scheme/=Use_Fixed_mstar)) + call get_param(param_file, mdl, "MSTAR_CAP", CS%mstar_cap, & "If this value is positive, it sets the maximum value of mstar "//& - "allowed in ePBL. (This is not used if EPBL_MSTAR_SCHEME = CONSTANT).", & - units="nondim", default=-1.0, do_not_log=(CS%mstar_scheme==Use_Fixed_MStar)) - ! mstar_scheme==MStar_from_Ekman options - call get_param(param_file, mdl, "MSTAR2_COEF1", CS%MSTAR_COEF, & + "allowed in ePBL. (This is not used if EPBL_mstar_scheme = CONSTANT).", & + units="nondim", default=-1.0, do_not_log=(CS%mstar_scheme==Use_Fixed_mstar)) + ! mstar_scheme==mstar_from_Ekman options + call get_param(param_file, mdl, "MSTAR2_COEF1", CS%mstar_coef, & "Coefficient in computing mstar when rotation and stabilizing "//& - "effects are both important (used if EPBL_MSTAR_SCHEME = OM4).", & - units="nondim", default=0.3, do_not_log=(CS%mstar_scheme/=MStar_from_Ekman)) - call get_param(param_file, mdl, "MSTAR2_COEF2", CS%C_EK, & + "effects are both important (used if EPBL_mstar_scheme = OM4).", & + units="nondim", default=0.3, do_not_log=(CS%mstar_scheme/=mstar_from_Ekman)) + call get_param(param_file, mdl, "MSTAR2_COEF2", CS%C_Ek, & "Coefficient in computing mstar when only rotation limits "// & "the total mixing (used if EPBL_MSTAR_SCHEME = OM4)", & - units="nondim", default=0.085, do_not_log=(CS%mstar_scheme/=MStar_from_Ekman)) - ! mstar_scheme==MStar_from_RH18 options + units="nondim", default=0.085, do_not_log=(CS%mstar_scheme/=mstar_from_Ekman)) + ! mstar_scheme==mstar_from_RH18 options call get_param(param_file, mdl, "RH18_MSTAR_CN1", CS%RH18_mstar_cn1,& - "MSTAR_N coefficient 1 (outter-most coefficient for fit). "//& + "MSTAR_N coefficient 1 (outer-most coefficient for fit). "//& "The value of 0.275 is given in RH18. Increasing this "//& - "coefficient increases MSTAR for all values of Hf/ust, but more "//& + "coefficient increases mstar for all values of Hf/ust, but more "//& "effectively at low values (weakly developed OSBLs).", & - units="nondim", default=0.275, do_not_log=(CS%mstar_scheme/=MStar_from_RH18)) + units="nondim", default=0.275, do_not_log=(CS%mstar_scheme/=mstar_from_RH18)) call get_param(param_file, mdl, "RH18_MSTAR_CN2", CS%RH18_mstar_cn2,& "MSTAR_N coefficient 2 (coefficient outside of exponential decay). "//& "The value of 8.0 is given in RH18. Increasing this coefficient "//& - "increases MSTAR for all values of HF/ust, with a much more even "//& + "increases mstar for all values of HF/ust, with a much more even "//& "effect across a wide range of Hf/ust than CN1.", & - units="nondim", default=8.0, do_not_log=(CS%mstar_scheme/=MStar_from_RH18)) + units="nondim", default=8.0, do_not_log=(CS%mstar_scheme/=mstar_from_RH18)) call get_param(param_file, mdl, "RH18_MSTAR_CN3", CS%RH18_mstar_CN3,& "MSTAR_N coefficient 3 (exponential decay coefficient). "//& "The value of -5.0 is given in RH18. Increasing this increases how "//& - "quickly the value of MSTAR decreases as Hf/ust increases.", & - units="nondim", default=-5.0, do_not_log=(CS%mstar_scheme/=MStar_from_RH18)) + "quickly the value of mstar decreases as Hf/ust increases.", & + units="nondim", default=-5.0, do_not_log=(CS%mstar_scheme/=mstar_from_RH18)) call get_param(param_file, mdl, "RH18_MSTAR_CS1", CS%RH18_mstar_cs1,& "MSTAR_S coefficient for RH18 in stabilizing limit. "//& "The value of 0.2 is given in RH18 and increasing it increases "//& - "MSTAR in the presence of a stabilizing surface buoyancy flux.", & - units="nondim", default=0.2, do_not_log=(CS%mstar_scheme/=MStar_from_RH18)) + "mstar in the presence of a stabilizing surface buoyancy flux.", & + units="nondim", default=0.2, do_not_log=(CS%mstar_scheme/=mstar_from_RH18)) call get_param(param_file, mdl, "RH18_MSTAR_CS2", CS%RH18_mstar_cs2,& "MSTAR_S exponent for RH18 in stabilizing limit. "//& - "The value of 0.4 is given in RH18 and increasing it increases MSTAR "//& + "The value of 0.4 is given in RH18 and increasing it increases mstar "//& "exponentially in the presence of a stabilizing surface buoyancy flux.", & - Units="nondim", default=0.4, do_not_log=(CS%mstar_scheme/=MStar_from_RH18)) - + Units="nondim", default=0.4, do_not_log=(CS%mstar_scheme/=mstar_from_RH18)) +!/ BBL mstar related options + call get_param(param_file, mdl, "EPBL_BBL_USE_MSTAR", CS%ePBL_BBL_use_mstar, & + "A logical to use mstar in the calculation of TKE in the ePBL BBL scheme", & + units="nondim", default=.false.) + if (CS%ePBL_BBL_use_mstar) then + call get_param(param_file, mdl, "EPBL_BBL_MSTAR_SCHEME", tmpstr, & + "EPBL_BBL_MSTAR_SCHEME selects the method for setting mstar in the BBL. Valid values are: \n"//& + "\t CONSTANT - Use a fixed mstar given by MSTAR_BBL \n"//& + "\t OM4 - Use L_Ekman/L_Obukhov in the stabilizing limit, as in OM4 \n"//& + "\t REICHL_H18 - Use the scheme documented in Reichl & Hallberg, 2018.", & + default=mstar_scheme) + tmpstr = uppercase(tmpstr) + select case (tmpstr) + case (CONSTANT_STRING) + CS%BBL_mstar_scheme = Use_Fixed_mstar + case (OM4_STRING) + CS%BBL_mstar_scheme = mstar_from_Ekman + case (RH18_STRING) + CS%BBL_mstar_scheme = mstar_from_RH18 + case default + call MOM_mesg('energetic_PBL_init: EPBL_BBL_MSTAR_SCHEME ="'//trim(tmpstr)//'"', 0) + call MOM_error(FATAL, "energetic_PBL_init: Unrecognized setting "// & + "EPBL_BBL_MSTAR_SCHEME = "//trim(tmpstr)//" found in input file.") + end select + call get_param(param_file, mdl, "MSTAR_BBL", CS%BBL_fixed_mstar, & + "The ratio of the friction velocity cubed to the TKE input to the "//& + "bottom boundary layer. This option is used if EPBL_BBL_MSTAR_SCHEME = CONSTANT.", & + units="nondim", default=1.2, do_not_log=(CS%BBL_mstar_scheme/=Use_Fixed_mstar)) + endif !/ Convective turbulence related options call get_param(param_file, mdl, "NSTAR", CS%nstar, & @@ -2132,10 +3988,16 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) "mixed layer depth. Otherwise use the false position after a maximum and minimum "//& "bound have been evaluated and the returned value or bisection before this.", & default=.false., do_not_log=.not.CS%Use_MLD_iteration) + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. + call get_param(param_file, mdl, "EPBL_MLD_ITER_BUG", CS%MLD_iter_bug, & + "If true, use buggy logic that gives the wrong bounds for the next iteration "//& + "when successive guesses increase by exactly EPBL_MLD_TOLERANCE.", & + default=enable_bugs, do_not_log=.not.CS%Use_MLD_iteration) call get_param(param_file, mdl, "EPBL_MLD_MAX_ITS", CS%max_MLD_its, & "The maximum number of iterations that can be used to find a self-consistent "//& "mixed layer depth. If EPBL_MLD_BISECTION is true, the maximum number "//& - "iteractions needed is set by Depth/2^MAX_ITS < EPBL_MLD_TOLERANCE.", & + "of iterations needed is set by Depth/2^MAX_ITS < EPBL_MLD_TOLERANCE.", & default=20, do_not_log=.not.CS%Use_MLD_iteration) if (.not.CS%Use_MLD_iteration) CS%Max_MLD_Its = 1 call get_param(param_file, mdl, "EPBL_MIN_MIX_LEN", CS%min_mix_len, & @@ -2150,7 +4012,7 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) units="nondim", default=2.0) !/ Turbulent velocity scale in mixing coefficient - call get_param(param_file, mdl, "EPBL_VEL_SCALE_SCHEME", tmpstr, & + call get_param(param_file, mdl, "EPBL_VEL_SCALE_SCHEME", vel_scale_str, & "Selects the method for translating TKE into turbulent velocities. "//& "Valid values are: \n"//& "\t CUBE_ROOT_TKE - A constant times the cube root of remaining TKE. \n"//& @@ -2159,31 +4021,31 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) default=ROOT_TKE_STRING, do_not_log=.true.) call get_param(param_file, mdl, "EPBL_VEL_SCALE_MODE", wT_mode, default=-1) if (wT_mode == 0) then - tmpstr = ROOT_TKE_STRING + vel_scale_str = ROOT_TKE_STRING call MOM_error(WARNING, "Use EPBL_VEL_SCALE_SCHEME = CUBE_ROOT_TKE instead of the archaic EPBL_VEL_SCALE_MODE = 0.") elseif (wT_mode == 1) then - tmpstr = RH18_STRING + vel_scale_str = RH18_STRING call MOM_error(WARNING, "Use EPBL_VEL_SCALE_SCHEME = REICHL_H18 instead of the archaic EPBL_VEL_SCALE_MODE = 1.") elseif (wT_mode >= 2) then call MOM_error(FATAL, "An unrecognized value of the obsolete parameter EPBL_VEL_SCALE_MODE was specified.") endif - call log_param(param_file, mdl, "EPBL_VEL_SCALE_SCHEME", tmpstr, & + call log_param(param_file, mdl, "EPBL_VEL_SCALE_SCHEME", vel_scale_str, & "Selects the method for translating TKE into turbulent velocities. "//& "Valid values are: \n"//& "\t CUBE_ROOT_TKE - A constant times the cube root of remaining TKE. \n"//& "\t REICHL_H18 - Use the scheme based on a combination of w* and v* as \n"//& "\t documented in Reichl & Hallberg, 2018.", & default=ROOT_TKE_STRING) - tmpstr = uppercase(tmpstr) - select case (tmpstr) + vel_scale_str = uppercase(vel_scale_str) + select case (vel_scale_str) case (ROOT_TKE_STRING) CS%wT_scheme = wT_from_cRoot_TKE case (RH18_STRING) CS%wT_scheme = wT_from_RH18 case default - call MOM_mesg('energetic_PBL_init: EPBL_VEL_SCALE_SCHEME ="'//trim(tmpstr)//'"', 0) + call MOM_mesg('energetic_PBL_init: EPBL_VEL_SCALE_SCHEME ="'//trim(vel_scale_str)//'"', 0) call MOM_error(FATAL, "energetic_PBL_init: Unrecognized setting "// & - "EPBL_VEL_SCALE_SCHEME = "//trim(tmpstr)//" found in input file.") + "EPBL_VEL_SCALE_SCHEME = "//trim(vel_scale_str)//" found in input file.") end select call get_param(param_file, mdl, "WSTAR_USTAR_COEF", CS%wstar_ustar_coef, & @@ -2199,17 +4061,96 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) "The proportionality times ustar to set vstar at the surface.", & units="nondim", default=1.2) + !/ Bottom boundary layer mixing related options + call get_param(param_file, mdl, "EPBL_BBL_EFFIC", CS%ePBL_BBL_effic, & + "The efficiency of bottom boundary layer mixing via ePBL. Setting this to a "//& + "value that is greater than 0 to enable bottom boundary layer mixing from EPBL.", & + units="nondim", default=0.0, scale=US%L_to_Z**2) + call get_param(param_file, mdl, "EPBL_BBL_TIDAL_EFFIC", CS%ePBL_tidal_effic, & + "The efficiency of bottom boundary layer mixing via ePBL driven by the "//& + "bottom drag dissipation of tides, as provided in fluxes%BBL_tidal_dis.", & + units="nondim", default=0.0, scale=US%L_to_Z**2) !### Change the default to follow EPBL_BBL_EFFIC? + no_BBL = ((CS%ePBL_BBL_effic <= 0.0) .and. (CS%ePBL_tidal_effic <= 0.0)) + + call get_param(param_file, mdl, "USE_BBLD_ITERATION", CS%Use_BBLD_iteration, & + "A logical that specifies whether or not to use the distance to the top of the "//& + "actively turbulent bottom boundary layer to help set the EPBL length scale.", & + default=.true., do_not_log=no_BBL) + call get_param(param_file, mdl, "TKE_DECAY_BBL", CS%TKE_decay_BBL, & + "TKE_DECAY_BBL relates the vertical rate of decay of the TKE available for "//& + "mechanical entrainment in the bottom boundary layer to the natural Ekman depth.", & + units="nondim", default=CS%TKE_decay, do_not_log=no_BBL) + call get_param(param_file, mdl, "MIX_LEN_EXPONENT_BBL", CS%MixLenExponent_BBL, & + "The exponent applied to the ratio of the distance to the top of the BBL "//& + "and the total BBL depth which determines the shape of the mixing length. "//& + "This is only used if USE_MLD_ITERATION is True.", & + units="nondim", default=2.0, do_not_log=(no_BBL.or.(.not.CS%Use_BBLD_iteration))) + call get_param(param_file, mdl, "EPBL_MIN_BBL_MIX_LEN", CS%min_BBL_mix_len, & + "The minimum mixing length scale that will be used by ePBL for bottom boundary "//& + "layer mixing. Choosing (0) does not set a minimum.", & + units="meter", default=CS%min_mix_len, scale=US%m_to_Z, do_not_log=no_BBL) + call get_param(param_file, mdl, "EPBL_BBLD_TOLERANCE", CS%BBLD_tol, & + "The tolerance for the iteratively determined bottom boundary layer depth. "//& + "This is only used with USE_MLD_ITERATION.", & + units="meter", default=US%Z_to_m*CS%MLD_tol, scale=US%m_to_Z, & + do_not_log=(no_BBL.or.(.not.CS%Use_MLD_iteration))) + call get_param(param_file, mdl, "EPBL_BBLD_MAX_ITS", CS%max_BBLD_its, & + "The maximum number of iterations that can be used to find a self-consistent "//& + "bottom boundary layer depth.", & + default=CS%max_MLD_its, do_not_log=(no_BBL.or.(.not.CS%Use_MLD_iteration))) + if (.not.CS%Use_MLD_iteration) CS%max_BBLD_its = 1 + + call get_param(param_file, mdl, "EPBL_BBL_VEL_SCALE_SCHEME", tmpstr, & + "Selects the method for translating bottom boundary layer TKE into turbulent velocities. "//& + "Valid values are: \n"//& + "\t CUBE_ROOT_TKE - A constant times the cube root of remaining BBL TKE. \n"//& + "\t REICHL_H18 - Use the scheme based on a combination of w* and v* as \n"//& + "\t documented in Reichl & Hallberg, 2018.", & + default=vel_scale_str, do_not_log=no_BBL) + select case (tmpstr) + case (ROOT_TKE_STRING) + CS%wT_scheme_BBL = wT_from_cRoot_TKE + case (RH18_STRING) + CS%wT_scheme_BBL = wT_from_RH18 + case default + call MOM_mesg('energetic_PBL_init: EPBL_BBL_VEL_SCALE_SCHEME ="'//trim(tmpstr)//'"', 0) + call MOM_error(FATAL, "energetic_PBL_init: Unrecognized setting "// & + "EPBL_BBL_VEL_SCALE_SCHEME = "//trim(tmpstr)//" found in input file.") + end select + call get_param(param_file, mdl, "EPBL_BBL_VEL_SCALE_FACTOR", CS%vstar_scale_fac_BBL, & + "An overall nondimensional scaling factor for wT in the bottom boundary layer. "//& + "Making this larger increases the bottom boundary layer diffusivity.", & + units="nondim", default=CS%vstar_scale_fac, do_not_log=no_BBL) + call get_param(param_file, mdl, "VSTAR_BBL_SURF_FAC", CS%vstar_surf_fac_BBL,& + "The proportionality times ustar to set vstar in the bottom boundary layer.", & + units="nondim", default=CS%vstar_surf_fac, do_not_log=(no_BBL.or.(CS%wT_scheme_BBL/=wT_from_RH18))) + call get_param(param_file, mdl, "EKMAN_SCALE_COEF_BBL", CS%Ekman_scale_coef_BBL, & + "A nondimensional scaling factor controlling the inhibition of the diffusive "//& + "length scale by rotation in the bottom boundary layer. Making this larger "//& + "decreases the bottom boundary layer diffusivity.", & + units="nondim", default=CS%Ekman_scale_coef, do_not_log=no_BBL) + call get_param(param_file, mdl, "EPBL_BBL_EFFIC_BUG", CS%BBL_effic_bug, & + "If true, overestimate the efficiency of the non-tidal ePBL bottom boundary "//& + "layer diffusivity by a factor of 1/sqrt(CDRAG), which is often a factor of "//& + "about 18.3.", default=.false., do_not_log=(CS%ePBL_BBL_effic<=0.0)) + + call get_param(param_file, mdl, "DECAY_ADJUSTED_BBL_TKE", CS%decay_adjusted_BBL_TKE, & + "If true, include an adjustment factor in the bottom boundary layer energetics "//& + "that accounts for an exponential decay of TKE from a near-bottom source and "//& + "an assumed piecewise linear profile of the buoyancy flux response to a change "//& + "in a diffusivity.", & + default=.false., do_not_log=no_BBL) + !/ Options related to Langmuir turbulence call get_param(param_file, mdl, "USE_LA_LI2016", use_LA_Windsea, & "A logical to use the Li et al. 2016 (submitted) formula to "//& - "determine the Langmuir number.", units="nondim", default=.false.) + "determine the Langmuir number.", default=.false.) ! Note this can be activated in other ways, but this preserves the old method. if (use_LA_windsea) then CS%use_LT = .true. else call get_param(param_file, mdl, "EPBL_LT", CS%use_LT, & - "A logical to use a LT parameterization.", & - units="nondim", default=.false.) + "A logical to use a LT parameterization.", default=.false.) endif if (CS%use_LT) then call get_param(param_file, mdl, "EPBL_LANGMUIR_SCHEME", tmpstr, & @@ -2217,23 +4158,23 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) "Valid values are: \n"//& "\t NONE - Do not do any extra mixing due to Langmuir turbulence \n"//& "\t RESCALE - Use a multiplicative rescaling of mstar to account for Langmuir turbulence \n"//& - "\t ADDITIVE - Add a Langmuir turblence contribution to mstar to other contributions", & + "\t ADDITIVE - Add a Langmuir turbulence contribution to mstar to other contributions", & default=NONE_STRING, do_not_log=.true.) call get_param(param_file, mdl, "LT_ENHANCE", LT_enhance, default=-1) - if (LT_ENHANCE == 0) then + if (LT_enhance == 0) then tmpstr = NONE_STRING call MOM_error(WARNING, "Use EPBL_LANGMUIR_SCHEME = NONE instead of the archaic LT_ENHANCE = 0.") - elseif (LT_ENHANCE == 1) then + elseif (LT_enhance == 1) then call MOM_error(FATAL, "You are using a legacy LT_ENHANCE mode in ePBL that has been phased out. "//& "If you need to use this setting please report this error. Also use "//& "EPBL_LANGMUIR_SCHEME to specify the scheme for mstar.") - elseif (LT_ENHANCE == 2) then + elseif (LT_enhance == 2) then tmpstr = RESCALED_STRING call MOM_error(WARNING, "Use EPBL_LANGMUIR_SCHEME = RESCALE instead of the archaic LT_ENHANCE = 2.") - elseif (LT_ENHANCE == 3) then + elseif (LT_enhance == 3) then tmpstr = ADDITIVE_STRING call MOM_error(WARNING, "Use EPBL_LANGMUIR_SCHEME = ADDITIVE instead of the archaic LT_ENHANCE = 3.") - elseif (LT_ENHANCE > 3) then + elseif (LT_enhance > 3) then call MOM_error(FATAL, "An unrecognized value of the obsolete parameter LT_ENHANCE was specified.") endif call log_param(param_file, mdl, "EPBL_LANGMUIR_SCHEME", tmpstr, & @@ -2241,7 +4182,7 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) "Valid values are: \n"//& "\t NONE - Do not do any extra mixing due to Langmuir turbulence \n"//& "\t RESCALE - Use a multiplicative rescaling of mstar to account for Langmuir turbulence \n"//& - "\t ADDITIVE - Add a Langmuir turblence contribution to mstar to other contributions", & + "\t ADDITIVE - Add a Langmuir turbulence contribution to mstar to other contributions", & default=NONE_STRING) tmpstr = uppercase(tmpstr) select case (tmpstr) @@ -2257,143 +4198,263 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) "EPBL_LANGMUIR_SCHEME = "//trim(tmpstr)//" found in input file.") end select - call get_param(param_file, mdl, "LT_ENHANCE_COEF", CS%LT_ENHANCE_COEF, & + call get_param(param_file, mdl, "LT_ENHANCE_COEF", CS%LT_enhance_coef, & "Coefficient for Langmuir enhancement of mstar", & units="nondim", default=0.447, do_not_log=(CS%LT_enhance_form==No_Langmuir)) - call get_param(param_file, mdl, "LT_ENHANCE_EXP", CS%LT_ENHANCE_EXP, & - "Exponent for Langmuir enhancementt of mstar", & + call get_param(param_file, mdl, "LT_ENHANCE_EXP", CS%LT_enhance_exp, & + "Exponent for Langmuir enhancement of mstar", & units="nondim", default=-1.33, do_not_log=(CS%LT_enhance_form==No_Langmuir)) - call get_param(param_file, mdl, "LT_MOD_LAC1", CS%LaC_MLDoEK, & + call get_param(param_file, mdl, "LT_MOD_LAC1", CS%LaC_MLD_Ek, & "Coefficient for modification of Langmuir number due to "//& "MLD approaching Ekman depth.", & units="nondim", default=-0.87, do_not_log=(CS%LT_enhance_form==No_Langmuir)) - call get_param(param_file, mdl, "LT_MOD_LAC2", CS%LaC_MLDoOB_stab, & + call get_param(param_file, mdl, "LT_MOD_LAC2", CS%LaC_MLD_Ob_stab, & "Coefficient for modification of Langmuir number due to "//& "MLD approaching stable Obukhov depth.", & units="nondim", default=0.0, do_not_log=(CS%LT_enhance_form==No_Langmuir)) - call get_param(param_file, mdl, "LT_MOD_LAC3", CS%LaC_MLDoOB_un, & + call get_param(param_file, mdl, "LT_MOD_LAC3", CS%LaC_MLD_Ob_un, & "Coefficient for modification of Langmuir number due to "//& "MLD approaching unstable Obukhov depth.", & units="nondim", default=0.0, do_not_log=(CS%LT_enhance_form==No_Langmuir)) - call get_param(param_file, mdl, "LT_MOD_LAC4", CS%Lac_EKoOB_stab, & + call get_param(param_file, mdl, "LT_MOD_LAC4", CS%Lac_Ek_Ob_stab, & "Coefficient for modification of Langmuir number due to "//& "ratio of Ekman to stable Obukhov depth.", & units="nondim", default=0.95, do_not_log=(CS%LT_enhance_form==No_Langmuir)) - call get_param(param_file, mdl, "LT_MOD_LAC5", CS%Lac_EKoOB_un, & + call get_param(param_file, mdl, "LT_MOD_LAC5", CS%Lac_Ek_Ob_un, & "Coefficient for modification of Langmuir number due to "//& "ratio of Ekman to unstable Obukhov depth.", & units="nondim", default=0.95, do_not_log=(CS%LT_enhance_form==No_Langmuir)) endif + !/Options related to Machine Learning Equation Discovery + ! Logial flags for using shape function from equation discovery - machine learning + ! EPBL_EQD_DIFFUSIVITY : EPBL + Equation Discovery Diffusivity parameters + + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_SHAPE", CS%eqdisc, & + "Logical flag for activating ML equation for shape function "// & + "that uses forcing to change its structure.", & + units="nondim", default=.false.) + + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_VELOCITY", CS%eqdisc_v0, & + "Logical flag for activating ML equation discovery for velocity scale", & + units="nondim", default=.false.) + + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_VELOCITY_H", CS%eqdisc_v0h, & + "Logical flag for activating ML equation discovery for velocity scale with h as input", & + units="nondim", default=.false.) + + + ! sets a lower cap for abs_f (Coriolis parameter) required in equation for v_0. + ! Small value, solution not sensitive below 1 deg Latitute + ! Default value of 2.5384E-07 corresponds to 0.1 deg. + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_CORIOLIS_LOWER_CAP", CS%f_lower, & + "value of lower limit cap for v0, default is for 0.1 deg, insensitive below 1deg", & + units="s-1", default=2.5384E-07, scale=US%T_to_S, & + do_not_log=.not.CS%eqdisc_v0) + + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_V0_LOWER_CAP", CS%v0_lower_cap, & + "value of lower limit cap for Coriolis in v0", & + units="m s-1", default=0.0001, scale=US%m_to_Z*US%T_to_s, & + do_not_log=.not.(CS%eqdisc_v0.or.CS%eqdisc_v0h)) + + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_V0_UPPER_CAP", CS%v0_upper_cap, & + "value of upper limit cap for Coriolis in v0", & + units="m s-1", default=0.1, scale=US%m_to_Z*US%T_to_s, & + do_not_log=.not.(CS%eqdisc_v0.or.CS%eqdisc_v0h)) + + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_BFLUX_LOWER_CAP", CS%bflux_lower_cap, & + "value of lower limit cap for Bflux used in setting in v0", & + units="m2 s-3", default=-7.0E-07, scale=(US%m_to_L**2)*(US%T_to_s**3), & + do_not_log=.not.(CS%eqdisc_v0.or.CS%eqdisc_v0h)) + + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_BFLUX_UPPER_CAP", CS%bflux_upper_cap, & + "value of upper limit cap for Bflux used in setting in v0", & + units="m2 s-3", default=7.0E-07, scale=(US%m_to_L**2)*(US%T_to_s**3), & + do_not_log=.not.(CS%eqdisc_v0.or.CS%eqdisc_v0h)) + + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_SIGMA_MAX_LOWER_CAP", CS%sigma_max_lower_cap, & + "value of lower limit cap for sigma coordinate of maximum for diffusivity", & + units="nondim", default=0.1, do_not_log=.not.CS%eqdisc) + + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_SIGMA_MAX_UPPER_CAP", CS%sigma_max_upper_cap, & + "value of upper limit cap for sigma coordinate of maximum for diffusivity", & + units="nondim", default=0.7, do_not_log=.not.CS%eqdisc) + + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_EH_UPPER_CAP", CS%Eh_upper_cap, & + "value of upper limit cap for boundary layer depth by Ekman depth hf/u", & + units="nondim", default=2.0, do_not_log=.not.CS%eqdisc) + + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_LH_CAP", CS%Lh_cap, & + "value of upper limit cap for boundary layer depth by Monin-Obukhov depth hB/u^3", & + units="nondim", default=8.0, do_not_log=.not.CS%eqdisc) + + ! The coefficients used for machine learned diffusivity + ! c1 to c6 used for sigma_m, + ! 7 to 9 v_0 surface heating, 10 to 14 v_0 surface cooling (ML velocity scale without h as input) + ! 14, 15, & 16 for v_0h surface heating, 17, 18, & 14 for v_0h surface cooling (ML velocity scale with h as input) + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_COEFFS", CS%ML_c, & + "Coefficient used for ML diffusivity 1 to 18 ", units="nondim", & + defaults=(/1.7908 , 0.6904, 0.0712, 0.4380, 2.6821, 1.5845, 0.1550, 1.1120, 0.8616, 0.0984, & + 45.0, 2.8570, 3.290, 0.0785, 0.650, 0.0944, 6.0277, 15.7292 /), & + do_not_log=.not.(CS%eqdisc .or. CS%eqdisc_v0 .or. CS%eqdisc_v0h)) + + call get_param(param_file, mdl, "EPBL_EQD_DIFFUSIVITY_SHAPE_FUNCTION_EPSILON", CS%shape_function_epsilon, & + "Constant value of OSBL shape function below the boundary layer", & + units="nondim", default=0.01, do_not_log=.not.CS%eqdisc) + + !/ options end for Machine Learning Equation Discovery + + !/ Options for documenting differences from parameter choices + call get_param(param_file, mdl, "EPBL_OPTIONS_DIFF", CS%options_diff, & + "If positive, this is a coded integer indicating a pair of settings whose "//& + "differences are diagnosed in a passive diagnostic mode via extra calls to "//& + "ePBL_column. If this is 0 or negative no extra calls occur.", & + default=0) + if (CS%options_diff > 0) then + if (CS%options_diff == 1) then + diff_text = "EPBL_ORIGINAL_PE_CALC settings" + elseif (CS%options_diff == 2) then + diff_text = "EPBL_ANSWER_DATE settings" + elseif (CS%options_diff == 3) then + diff_text = "DIRECT_EPBL_MIXING_CALC settings" + elseif (CS%options_diff == 4) then + diff_text = "BBL DIRECT_EPBL_MIXING_CALC settings" + elseif (CS%options_diff == 5) then + diff_text = "BBL DECAY_ADJUSTED_BBL_TKE settings" + else + diff_text = "unchanged settings" + endif + endif !/ Logging parameters ! This gives a minimum decay scale that is typically much less than Angstrom. - CS%ustar_min = 2e-4*CS%omega*(GV%Angstrom_Z + GV%H_to_Z*GV%H_subroundoff) - call log_param(param_file, mdl, "!EPBL_USTAR_MIN", CS%ustar_min*US%Z_to_m*US%s_to_T, & + CS%ustar_min = 2e-4*CS%omega*(GV%Angstrom_Z + GV%dZ_subroundoff) + call log_param(param_file, mdl, "!EPBL_USTAR_MIN", CS%ustar_min, & "The (tiny) minimum friction velocity used within the "//& - "ePBL code, derived from OMEGA and ANGSTROM.", units="m s-1", & + "ePBL code, derived from OMEGA and ANGSTROM.", & + units="m s-1", unscale=US%Z_to_m*US%s_to_T, & like_default=.true.) !/ Checking output flags + CS%id_Kd_ePBL_col_by_col = register_diag_field('ocean_model', 'Kd_ePBL_col_by_col', diag%axesTi, Time, & + 'ePBL diapycnal diffusivity at interfaces posted column by column', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) CS%id_ML_depth = register_diag_field('ocean_model', 'ePBL_h_ML', diag%axesT1, & - Time, 'Surface boundary layer depth', 'm', conversion=US%Z_to_m, & + Time, 'Surface boundary layer depth', units='m', conversion=US%Z_to_m, & cmor_long_name='Ocean Mixed Layer Thickness Defined by Mixing Scheme') ! This is an alias for the same variable as ePBL_h_ML CS%id_hML_depth = register_diag_field('ocean_model', 'h_ML', diag%axesT1, & - Time, 'Surface mixed layer depth based on active turbulence', 'm', conversion=US%Z_to_m) + Time, 'Surface mixed layer depth based on active turbulence', units='m', conversion=US%Z_to_m) + CS%id_ustar_ePBL = register_diag_field('ocean_model', 'ePBL_ustar', diag%axesT1, & + Time, 'Surface friction in ePBL', units='m s-1', conversion=US%Z_to_m*US%s_to_T) + CS%id_bflx_ePBL = register_diag_field('ocean_model', 'ePBL_bflx', diag%axesT1, & + Time, 'Surface buoyancy flux in ePBL', units='m2 s-3', conversion=US%Z_to_m**2*US%s_to_T**3) CS%id_TKE_wind = register_diag_field('ocean_model', 'ePBL_TKE_wind', diag%axesT1, & - Time, 'Wind-stirring source of mixed layer TKE', 'W m-2', conversion=US%RZ3_T3_to_W_m2) + Time, 'Wind-stirring source of mixed layer TKE', units='W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_TKE_MKE = register_diag_field('ocean_model', 'ePBL_TKE_MKE', diag%axesT1, & - Time, 'Mean kinetic energy source of mixed layer TKE', 'W m-2', conversion=US%RZ3_T3_to_W_m2) + Time, 'Mean kinetic energy source of mixed layer TKE', units='W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_TKE_conv = register_diag_field('ocean_model', 'ePBL_TKE_conv', diag%axesT1, & - Time, 'Convective source of mixed layer TKE', 'W m-2', conversion=US%RZ3_T3_to_W_m2) + Time, 'Convective source of mixed layer TKE', units='W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_TKE_forcing = register_diag_field('ocean_model', 'ePBL_TKE_forcing', diag%axesT1, & Time, 'TKE consumed by mixing surface forcing or penetrative shortwave radation '//& - 'through model layers', 'W m-2', conversion=US%RZ3_T3_to_W_m2) + 'through model layers', units='W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_TKE_mixing = register_diag_field('ocean_model', 'ePBL_TKE_mixing', diag%axesT1, & - Time, 'TKE consumed by mixing that deepens the mixed layer', 'W m-2', conversion=US%RZ3_T3_to_W_m2) + Time, 'TKE consumed by mixing that deepens the mixed layer', units='W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_TKE_mech_decay = register_diag_field('ocean_model', 'ePBL_TKE_mech_decay', diag%axesT1, & - Time, 'Mechanical energy decay sink of mixed layer TKE', 'W m-2', conversion=US%RZ3_T3_to_W_m2) + Time, 'Mechanical energy decay sink of mixed layer TKE', units='W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_TKE_conv_decay = register_diag_field('ocean_model', 'ePBL_TKE_conv_decay', diag%axesT1, & - Time, 'Convective energy decay sink of mixed layer TKE', 'W m-2', conversion=US%RZ3_T3_to_W_m2) + Time, 'Convective energy decay sink of mixed layer TKE', units='W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_Mixing_Length = register_diag_field('ocean_model', 'Mixing_Length', diag%axesTi, & - Time, 'Mixing Length that is used', 'm', conversion=US%Z_to_m) + Time, 'Mixing Length that is used', units='m', conversion=US%Z_to_m) CS%id_Velocity_Scale = register_diag_field('ocean_model', 'Velocity_Scale', diag%axesTi, & - Time, 'Velocity Scale that is used.', 'm s-1', conversion=US%Z_to_m*US%s_to_T) - CS%id_MSTAR_mix = register_diag_field('ocean_model', 'MSTAR', diag%axesT1, & + Time, 'Velocity Scale that is used.', units='m s-1', conversion=US%Z_to_m*US%s_to_T) + CS%id_mstar_sfc = register_diag_field('ocean_model', 'MSTAR', diag%axesT1, & Time, 'Total mstar that is used.', 'nondim') + if ((CS%ePBL_BBL_effic > 0.0) .or. (CS%ePBL_tidal_effic > 0.0) .or. CS%ePBL_BBL_use_mstar) then + CS%id_Kd_BBL = register_diag_field('ocean_model', 'Kd_ePBL_BBL', diag%axesTi, & + Time, 'ePBL bottom boundary layer diffusivity', units='m2 s-1', conversion=GV%HZ_T_to_m2_s) + CS%id_BBL_Mix_Length = register_diag_field('ocean_model', 'BBL_Mixing_Length', diag%axesTi, & + Time, 'ePBL bottom boundary layer mixing length', units='m', conversion=US%Z_to_m) + CS%id_BBL_Vel_Scale = register_diag_field('ocean_model', 'BBL_Velocity_Scale', diag%axesTi, & + Time, 'ePBL bottom boundary layer velocity scale', units='m s-1', conversion=US%Z_to_m*US%s_to_T) + CS%id_BBL_depth = register_diag_field('ocean_model', 'h_BBL', diag%axesT1, & + Time, 'Bottom boundary layer depth based on active turbulence', units='m', conversion=US%Z_to_m) + CS%id_ustar_BBL = register_diag_field('ocean_model', 'ePBL_ustar_BBL', diag%axesT1, & + Time, 'The bottom boundary layer friction velocity', units='m s-1', conversion=GV%H_to_m*US%s_to_T) + CS%id_BBL_decay_scale = register_diag_field('ocean_model', 'BBL_decay_scale', diag%axesT1, & + Time, 'The bottom boundary layer TKE decay lengthscale', units='m', conversion=GV%H_to_m) + CS%id_TKE_BBL = register_diag_field('ocean_model', 'ePBL_BBL_TKE', diag%axesT1, & + Time, 'The source of TKE for the bottom boundary layer', units='W m-2', conversion=US%RZ3_T3_to_W_m2) + CS%id_TKE_BBL_mixing = register_diag_field('ocean_model', 'ePBL_BBL_TKE_mixing', diag%axesT1, & + Time, 'TKE consumed by mixing that thickens the bottom boundary layer', & + units='W m-2', conversion=US%RZ3_T3_to_W_m2) + CS%id_TKE_BBL_decay = register_diag_field('ocean_model', 'ePBL_BBL_TKE_decay', diag%axesT1, & + Time, 'Energy decay sink of mixed layer TKE in the bottom boundary layer', & + units='W m-2', conversion=US%RZ3_T3_to_W_m2) + CS%id_mstar_BBL = register_diag_field('ocean_model', 'MSTAR_BBL', diag%axesT1, & + Time, 'Total BBL mstar that is used.', 'nondim') + endif if (CS%use_LT) then CS%id_LA = register_diag_field('ocean_model', 'LA', diag%axesT1, & Time, 'Langmuir number.', 'nondim') CS%id_LA_mod = register_diag_field('ocean_model', 'LA_MOD', diag%axesT1, & Time, 'Modified Langmuir number.', 'nondim') - CS%id_MSTAR_LT = register_diag_field('ocean_model', 'MSTAR_LT', diag%axesT1, & + CS%id_mstar_LT = register_diag_field('ocean_model', 'MSTAR_LT', diag%axesT1, & Time, 'Increase in mstar due to Langmuir Turbulence.', 'nondim') endif - call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", use_temperature, & - "If true, temperature and salinity are used as state "//& - "variables.", default=.true.) + if (CS%options_diff > 0) then + CS%id_opt_diff_Kd_ePBL = register_diag_field('ocean_model', 'ePBL_opt_diff_Kd_ePBL', diag%axesTi, & + Time, 'Change in ePBL diapycnal diffusivity at interfaces due to '//trim(diff_text), & + units='m2 s-1', conversion=GV%HZ_T_to_m2_s) + CS%id_opt_maxdiff_Kd_ePBL = register_diag_field('ocean_model', 'ePBL_opt_maxdiff_Kd_ePBL', diag%axesT1, & + Time, 'Column maximum change in ePBL diapycnal diffusivity at interfaces due to '//trim(diff_text), & + units='m2 s-1', conversion=GV%HZ_T_to_m2_s) + CS%id_opt_diff_hML_depth = register_diag_field('ocean_model', 'ePBL_opt_diff_h_ML', diag%axesT1, Time, & + 'Change in surface or bottom boundary layer depth based on active turbulence due to '//trim(diff_text), & + units='m', conversion=US%Z_to_m) + endif if (report_avg_its) then CS%sum_its(1) = real_to_EFP(0.0) ; CS%sum_its(2) = real_to_EFP(0.0) + CS%sum_its_BBL(1) = real_to_EFP(0.0) ; CS%sum_its_BBL(2) = real_to_EFP(0.0) endif - if (max(CS%id_TKE_wind, CS%id_TKE_MKE, CS%id_TKE_conv, & - CS%id_TKE_mixing, CS%id_TKE_mech_decay, CS%id_TKE_forcing, & - CS%id_TKE_conv_decay) > 0) then - call safe_alloc_alloc(CS%diag_TKE_wind, isd, ied, jsd, jed) - call safe_alloc_alloc(CS%diag_TKE_MKE, isd, ied, jsd, jed) - call safe_alloc_alloc(CS%diag_TKE_conv, isd, ied, jsd, jed) - call safe_alloc_alloc(CS%diag_TKE_forcing, isd, ied, jsd, jed) - call safe_alloc_alloc(CS%diag_TKE_mixing, isd, ied, jsd, jed) - call safe_alloc_alloc(CS%diag_TKE_mech_decay, isd, ied, jsd, jed) - call safe_alloc_alloc(CS%diag_TKE_conv_decay, isd, ied, jsd, jed) - - CS%TKE_diagnostics = .true. + CS%TKE_diagnostics = (max(CS%id_TKE_wind, CS%id_TKE_MKE, CS%id_TKE_conv, & + CS%id_TKE_mixing, CS%id_TKE_mech_decay, CS%id_TKE_forcing, & + CS%id_TKE_conv_decay) > 0) + if ((CS%ePBL_BBL_effic > 0.0) .or. (CS%ePBL_tidal_effic > 0.0) .or. CS%ePBL_BBL_use_mstar) then + CS%TKE_diagnostics = CS%TKE_diagnostics .or. & + (max(CS%id_TKE_BBL, CS%id_TKE_BBL_mixing, CS%id_TKE_BBL_decay) > 0) endif - if (CS%id_Velocity_Scale>0) call safe_alloc_alloc(CS%Velocity_Scale, isd, ied, jsd, jed, GV%ke+1) - if (CS%id_Mixing_Length>0) call safe_alloc_alloc(CS%Mixing_Length, isd, ied, jsd, jed, GV%ke+1) call safe_alloc_alloc(CS%ML_depth, isd, ied, jsd, jed) - if (max(CS%id_mstar_mix, CS%id_LA, CS%id_LA_mod, CS%id_MSTAR_LT ) >0) then - call safe_alloc_alloc(CS%Mstar_mix, isd, ied, jsd, jed) - call safe_alloc_alloc(CS%LA, isd, ied, jsd, jed) - call safe_alloc_alloc(CS%LA_MOD, isd, ied, jsd, jed) - call safe_alloc_alloc(CS%MSTAR_LT, isd, ied, jsd, jed) - endif + call safe_alloc_alloc(CS%BBL_depth, isd, ied, jsd, jed) end subroutine energetic_PBL_init !> Clean up and deallocate memory associated with the energetic_PBL module. subroutine energetic_PBL_end(CS) - type(energetic_PBL_CS), intent(inout) :: CS !< Energetic_PBL control struct + type(energetic_PBL_CS), intent(inout) :: CS !< Energetic_PBL control structure character(len=256) :: mesg - real :: avg_its + real :: avg_its ! The averaged number of iterations used by ePBL [nondim] if (allocated(CS%ML_depth)) deallocate(CS%ML_depth) - if (allocated(CS%LA)) deallocate(CS%LA) - if (allocated(CS%LA_MOD)) deallocate(CS%LA_MOD) - if (allocated(CS%MSTAR_MIX)) deallocate(CS%MSTAR_MIX) - if (allocated(CS%MSTAR_LT)) deallocate(CS%MSTAR_LT) - if (allocated(CS%diag_TKE_wind)) deallocate(CS%diag_TKE_wind) - if (allocated(CS%diag_TKE_MKE)) deallocate(CS%diag_TKE_MKE) - if (allocated(CS%diag_TKE_conv)) deallocate(CS%diag_TKE_conv) - if (allocated(CS%diag_TKE_forcing)) deallocate(CS%diag_TKE_forcing) - if (allocated(CS%diag_TKE_mixing)) deallocate(CS%diag_TKE_mixing) - if (allocated(CS%diag_TKE_mech_decay)) deallocate(CS%diag_TKE_mech_decay) - if (allocated(CS%diag_TKE_conv_decay)) deallocate(CS%diag_TKE_conv_decay) - if (allocated(CS%Mixing_Length)) deallocate(CS%Mixing_Length) - if (allocated(CS%Velocity_Scale)) deallocate(CS%Velocity_Scale) + if (allocated(CS%BBL_depth)) deallocate(CS%BBL_depth) if (report_avg_its) then call EFP_sum_across_PEs(CS%sum_its, 2) - avg_its = EFP_to_real(CS%sum_its(1)) / EFP_to_real(CS%sum_its(2)) write (mesg,*) "Average ePBL iterations = ", avg_its call MOM_mesg(mesg) + + if ((CS%ePBL_BBL_effic > 0.0) .or. (CS%ePBL_tidal_effic > 0.0) .or. CS%ePBL_BBL_use_mstar) then + call EFP_sum_across_PEs(CS%sum_its_BBL, 2) + avg_its = EFP_to_real(CS%sum_its_BBL(1)) / EFP_to_real(CS%sum_its_BBL(2)) + write (mesg,*) "Average ePBL BBL iterations = ", avg_its + call MOM_mesg(mesg) + endif endif end subroutine energetic_PBL_end diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index fdc38ebf1e..4f5ae31f0c 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -1,18 +1,21 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Diapycnal mixing and advection in isopycnal mode module MOM_entrain_diffusive -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_EOS, only : calculate_density, calculate_density_derivs +use MOM_EOS, only : calculate_specific_vol_derivs, EOS_domain use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_forcing_type, only : forcing -use MOM_grid, only : ocean_grid_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -34,6 +37,9 @@ module MOM_entrain_diffusive !! calculate the diapycnal entrainment. real :: Tolerance_Ent !< The tolerance with which to solve for entrainment values !! [H ~> m or kg m-2]. + real :: max_Ent !< A large ceiling on the maximum permitted amount of entrainment + !! across each interface between the mixed and buffer layers within + !! a timestep [H ~> m or kg m-2]. real :: Rho_sig_off !< The offset between potential density and a sigma value [R ~> kg m-3] type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. @@ -70,15 +76,14 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & intent(out) :: eb !< The amount of fluid entrained from the layer !! below within this time step [H ~> m or kg m-2]. integer, dimension(SZI_(G),SZJ_(G)), & - optional, intent(inout) :: kb_out !< The index of the lightest layer denser than + intent(inout) :: kb_out !< The index of the lightest layer denser than !! the buffer layer. - ! At least one of the two following arguments must be present. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - optional, intent(in) :: Kd_Lay !< The diapycnal diffusivity of layers - !! [Z2 T-1 ~> m2 s-1]. + intent(in) :: Kd_Lay !< The diapycnal diffusivity of layers + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & - optional, intent(in) :: Kd_int !< The diapycnal diffusivity of interfaces - !! [Z2 T-1 ~> m2 s-1]. + intent(in) :: Kd_int !< The diapycnal diffusivity of interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. ! This subroutine calculates ea and eb, the rates at which a layer entrains ! from the layers above and below. The entrainment rates are proportional to @@ -109,11 +114,12 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & real, allocatable, dimension(:,:,:) :: & Kd_eff, & ! The effective diffusivity that actually applies to each ! layer after the effects of boundary conditions are - ! considered [Z2 T-1 ~> m2 s-1]. + ! considered [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. diff_work ! The work actually done by diffusion across each ! interface [R Z3 T-3 ~> W m-2]. Sum vertically for the total work. - real :: hm, fm, fr, fk ! Work variables with units of H, H, H, and H2. + real :: hm, fm, fr ! Work variables with units of [H ~> m or kg m-2]. + real :: fk ! A Work variable with units of [H2 ~> m2 or kg2 m-4] real :: b1(SZI_(G)) ! A variable used by the tridiagonal solver [H ~> m or kg m-2] real :: c1(SZI_(G),SZK_(GV)) ! A variable used by the tridiagonal solver [nondim] @@ -140,9 +146,11 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & zeros, & ! An array of all zeros. (Usually used with [H ~> m or kg m-2].) max_eakb, & ! The maximum value of eakb that might be realized [H ~> m or kg m-2]. min_eakb, & ! The minimum value of eakb that might be realized [H ~> m or kg m-2]. - err_max_eakb0, & ! The value of error returned by determine_Ea_kb - err_min_eakb0, & ! when eakb = min_eakb and max_eakb and ea_kbp1 = 0. - err_eakb0, & ! A value of error returned by determine_Ea_kb. + err_max_eakb0, & ! The value of error returned by determine_Ea_kb when eakb = max_eakb + ! and ea_kbp1 = 0 [H2 ~> m2 or kg2 m-4]. + err_min_eakb0, & ! The value of error returned by determine_Ea_kb when eakb = min_eakb + ! and ea_kbp1 = 0 [H2 ~> m2 or kg2 m-4]. + err_eakb0, & ! A value of error returned by determine_Ea_kb [H2 ~> m2 or kg2 m-4]. F_kb, & ! The value of F in layer kb, or equivalently the entrainment ! from below by layer kb [H ~> m or kg m-2]. dFdfm_kb, & ! The partial derivative of F with fm [nondim]. See dFdfm. @@ -168,16 +176,20 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & grats ! 2*(2 + ds_k+1 / ds_k + ds_k / ds_k+1) = ! 4*ds_Lay*(1/ds_k + 1/ds_k+1). [nondim] - real :: dRHo ! The change in locally referenced potential density between - ! the layers above and below an interface [R ~> kg m-3]. + real :: dRho ! The change in locally referenced potential density between + ! the layers above and below an interface [R ~> kg m-3] + real :: dSpV ! The change in locally referenced specific volume between + ! the layers above and below an interface [R-1 ~> m3 kg-1] real :: g_2dt ! 0.5 * G_Earth / dt, times unit conversion factors - ! [Z3 H-2 T-3 ~> m s-3 or m7 kg-2 s-3]. + ! [Z3 H-2 T-3 or R2 Z3 H-2 T-3 ~> m s-3]. real, dimension(SZI_(G)) :: & pressure, & ! The pressure at an interface [R L2 T-2 ~> Pa]. T_eos, S_eos, & ! The potential temperature and salinity at which to - ! evaluate dRho_dT and dRho_dS [degC] and [ppt]. - dRho_dT, dRho_dS ! The partial derivatives of potential density with temperature and - ! salinity, [R degC-1 ~> kg m-3 degC-1] and [R ppt-1 ~> kg m-3 ppt-1]. + ! evaluate dRho_dT and dRho_dS [C ~> degC] and [S ~> ppt]. + dRho_dT, & ! The partial derivative of potential density with temperature [R C-1 ~> kg m-3 degC-1] + dRho_dS, & ! The partial derivative of potential density with salinity [R S-1 ~> kg m-3 ppt-1] + dSpV_dT, & ! The partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSpV_dS ! The partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1] real :: tolerance ! The tolerance within which E must be converged [H ~> m or kg m-2]. real :: Angstrom ! The minimum layer thickness [H ~> m or kg m-2]. @@ -187,13 +199,13 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & ! entrain from the layer above [H ~> m or kg m-2]. real :: Kd_here ! The effective diapycnal diffusivity times the timestep [H2 ~> m2 or kg2 m-4]. real :: h_avail ! The thickness that is available for entrainment [H ~> m or kg m-2]. - real :: dS_kb_eff ! The value of dS_kb after limiting is taken into account. + real :: dS_kb_eff ! The value of dS_kb after limiting is taken into account [R ~> kg m-3]. real :: Rho_cor ! The depth-integrated potential density anomaly that ! needs to be corrected for [H R ~> kg m-2 or kg2 m-5]. real :: ea_cor ! The corrective adjustment to eakb [H ~> m or kg m-2]. real :: h1 ! The layer thickness after entrainment through the ! interface below is taken into account [H ~> m or kg m-2]. - real :: Idt ! The inverse of the time step [T-1 ~> s-1]. + real :: Idt ! The inverse of the time step [Z H-1 T-1 ~> s-1 or m3 kg-1 s-1]. logical :: do_any logical :: do_entrain_eakb ! True if buffer layer is entrained @@ -211,9 +223,6 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & if (.not. CS%initialized) call MOM_error(FATAL, & "MOM_entrain_diffusive: Module must be initialized before it is used.") - if (.not.(present(Kd_Lay) .or. present(Kd_int))) call MOM_error(FATAL, & - "MOM_entrain_diffusive: Either Kd_Lay or Kd_int must be present in call.") - if ((.not.CS%bulkmixedlayer .and. .not.associated(fluxes%buoy)) .and. & (associated(fluxes%lprec) .or. associated(fluxes%evap) .or. & associated(fluxes%sens) .or. associated(fluxes%sw))) then @@ -248,53 +257,50 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & endif EOSdom(:) = EOS_domain(G%HI) - !$OMP parallel do default(none) shared(is,ie,js,je,nz,Kd_Lay,G,GV,US,dt,CS,h,tv, & - !$OMP kmb,Angstrom,fluxes,K2,h_neglect,tolerance, & - !$OMP ea,eb,Kd_int,Kd_eff,EOSdom,diff_work,g_2dt, kb_out) & - !$OMP firstprivate(kb,ds_dsp1,dsp1_ds,pres,kb_min) & - !$OMP private(dtKd,dtKd_int,do_i,Ent_bl,dtKd_kb,h_bl, & - !$OMP I2p2dsp1_ds,grats,htot,max_eakb,I_dSkbp1, & - !$OMP zeros,maxF_kb,maxF,ea_kbp1,eakb,Sref, & - !$OMP maxF_correct,do_any,do_entrain_eakb, & - !$OMP err_min_eakb0,err_max_eakb0,eakb_maxF, & - !$OMP min_eakb,err_eakb0,F,minF,hm,fk,F_kb_maxent,& - !$OMP F_kb,is1,ie1,kb_min_act,dFdfm_kb,b1,dFdfm, & - !$OMP Fprev,fm,fr,c1,reiterate,eb_kmb,did_i, & - !$OMP h_avail,h_guess,dS_kb,Rcv,F_cor,dS_kb_eff, & - !$OMP Rho_cor,ea_cor,h1,Idt,Kd_here,pressure, & - !$OMP T_eos,S_eos,dRho_dT,dRho_dS,dRho,dS_anom_lim) + !$OMP parallel do default(private) shared(is,ie,js,je,nz,Kd_Lay,G,GV,US,dt,CS,h,tv, & + !$OMP kmb,Angstrom,fluxes,K2,h_neglect,tolerance, & + !$OMP ea,eb,Kd_int,Kd_eff,EOSdom,diff_work,g_2dt, kb_out) & + !$OMP firstprivate(kb,ds_dsp1,dsp1_ds,pres,kb_min) do j=js,je do i=is,ie ; kb(i) = 1 ; enddo - if (present(Kd_Lay)) then + if (allocated(tv%SpV_avg)) then do k=1,nz ; do i=is,ie - dtKd(i,k) = GV%Z_to_H**2 * (dt * Kd_lay(i,j,k)) + dtKd(i,k) = GV%RZ_to_H * (dt * Kd_lay(i,j,k)) / tv%SpV_avg(i,j,k) enddo ; enddo - if (present(Kd_int)) then - do K=1,nz+1 ; do i=is,ie - dtKd_int(i,K) = GV%Z_to_H**2 * (dt * Kd_int(i,j,K)) - enddo ; enddo - else - do K=2,nz ; do i=is,ie - dtKd_int(i,K) = GV%Z_to_H**2 * (0.5 * dt * (Kd_lay(i,j,k-1) + Kd_lay(i,j,k))) - enddo ; enddo - endif - else ! Kd_int must be present, or there already would have been an error. + do i=is,ie + dtKd_int(i,1) = GV%RZ_to_H * (dt * Kd_int(i,j,1)) / tv%SpV_avg(i,j,1) + dtKd_int(i,nz+1) = GV%RZ_to_H * (dt * Kd_int(i,j,nz+1)) / tv%SpV_avg(i,j,nz) + enddo + ! Use the mass-weighted average specific volume to translate thicknesses to verti distances. + do K=2,nz ; do i=is,ie + dtKd_int(i,K) = GV%RZ_to_H * (dt * Kd_int(i,j,K)) * & + ( (h(i,j,k-1) + h(i,j,k) + 2.0*h_neglect) / & + ((h(i,j,k-1)+h_neglect) * tv%SpV_avg(i,j,k-1) + & + (h(i,j,k)+h_neglect) * tv%SpV_avg(i,j,k)) ) + enddo ; enddo + else do k=1,nz ; do i=is,ie - dtKd(i,k) = GV%Z_to_H**2 * (0.5 * dt * (Kd_int(i,j,K)+Kd_int(i,j,K+1))) + dtKd(i,k) = GV%Z_to_H * (dt * Kd_lay(i,j,k)) enddo ; enddo - dO K=1,nz+1 ; do i=is,ie - dtKd_int(i,K) = GV%Z_to_H**2 * (dt * Kd_int(i,j,K)) + do K=1,nz+1 ; do i=is,ie + dtKd_int(i,K) = GV%Z_to_H * (dt * Kd_int(i,j,K)) enddo ; enddo endif - do i=is,ie ; do_i(i) = (G%mask2dT(i,j) > 0.5) ; enddo + do i=is,ie ; do_i(i) = (G%mask2dT(i,j) > 0.0) ; enddo do i=is,ie ; ds_dsp1(i,nz) = 0.0 ; enddo do i=is,ie ; dsp1_ds(i,nz) = 0.0 ; enddo - do k=2,nz-1 ; do i=is,ie - ds_dsp1(i,k) = GV%g_prime(k) / GV%g_prime(k+1) - enddo ; enddo + if (GV%Boussinesq .or. GV%Semi_Boussinesq) then + do k=2,nz-1 ; do i=is,ie + ds_dsp1(i,k) = GV%g_prime(k) / GV%g_prime(k+1) + enddo ; enddo + else ! Use a mathematically equivalent form that avoids any dependency on RHO_0. + do k=2,nz-1 ; do i=is,ie + ds_dsp1(i,k) = (GV%Rlay(k) - GV%Rlay(k-1)) / (GV%Rlay(k+1) - GV%Rlay(k)) + enddo ; enddo + endif if (CS%bulkmixedlayer) then ! This subroutine determines the averaged entrainment across each @@ -387,9 +393,16 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & maxF(i,1) = 0.0 htot(i) = h(i,j,1) - Angstrom enddo - if (associated(fluxes%buoy)) then ; do i=is,ie - maxF(i,1) = GV%Z_to_H * (dt*fluxes%buoy(i,j)) / GV%g_prime(2) - enddo ; endif + if (associated(fluxes%buoy) .and. GV%Boussinesq) then + do i=is,ie + maxF(i,1) = GV%Z_to_H * (dt*fluxes%buoy(i,j)) / GV%g_prime(2) + enddo + elseif (associated(fluxes%buoy)) then + do i=is,ie + maxF(i,1) = (GV%RZ_to_H * 0.5*(GV%Rlay(1) + GV%Rlay(2)) * (dt*fluxes%buoy(i,j))) / & + GV%g_prime(2) + enddo + endif endif ! The following code calculates the maximum flux, maxF, for the interior @@ -752,7 +765,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & ea(i,j,k) = ea(i,j,k) + ea_cor eb(i,j,k) = eb(i,j,k) - (dS_kb(i) * I_dSkbp1(i)) * ea_cor elseif (k < kb(i)) then - ! Repetative, unless ea(kb) has been corrected. + ! Repetitive, unless ea(kb) has been corrected. ea(i,j,k) = ea(i,j,k+1) endif enddo @@ -761,7 +774,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & ea(i,j,k) = ea(i,j,k+1) enddo ; enddo - ! Repetative, unless ea(kb) has been corrected. + ! Repetitive, unless ea(kb) has been corrected. k=kmb do i=is,ie ! Do not adjust eb through the base of the buffer layers, but it @@ -813,7 +826,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & endif ! associated(tv%eqn_of_state)) if (CS%id_Kd > 0) then - Idt = GV%H_to_Z**2 / dt + Idt = (GV%H_to_m*US%m_to_Z) / dt do k=2,nz-1 ; do i=is,ie if (k 0) then - g_2dt = 0.5 * GV%H_to_Z**2*US%L_to_Z**2 * (GV%g_Earth / dt) + if (GV%Boussinesq .or. .not.associated(tv%eqn_of_state)) then + g_2dt = 0.5 * GV%H_to_Z**2 * (GV%g_Earth_Z_T2 / dt) + else + g_2dt = 0.5 * GV%H_to_RZ**2 * (GV%g_Earth_Z_T2 / dt) + endif do i=is,ie ; diff_work(i,j,1) = 0.0 ; diff_work(i,j,nz+1) = 0.0 ; enddo if (associated(tv%eqn_of_state)) then if (associated(fluxes%p_surf)) then @@ -848,23 +865,44 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & S_eos(i) = 0.5*(tv%S(i,j,k-1) + tv%S(i,j,k)) endif enddo - call calculate_density_derivs(T_eos, S_eos, pressure, dRho_dT, dRho_dS, & - tv%eqn_of_state, EOSdom) - do i=is,ie - if ((k>kmb) .and. (kkmb) .and. (kkmb) .and. (k m or kg m-2]. real, dimension(SZI_(G),SZK_(GV)), intent(in) :: Ent_bl !< The average entrainment upward and @@ -1050,7 +1086,6 @@ subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, US, CS, j, Ent_bl, real, dimension(SZI_(G), SZK_(GV)) :: & S_est ! An estimate of the coordinate potential density - 1000 after ! entrainment for each layer [R ~> kg m-3]. - real :: max_ent ! The maximum possible entrainment [H ~> m or kg m-2]. real :: dh ! An available thickness [H ~> m or kg m-2]. real :: Kd_x_dt ! The diffusion that remains after thin layers are ! entrained [H2 ~> m2 or kg2 m-4]. @@ -1060,8 +1095,6 @@ subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, US, CS, j, Ent_bl, integer :: i, k, is, ie, nz is = G%isc ; ie = G%iec ; nz = GV%ke -! max_ent = 1.0e14*GV%Angstrom_H ! This is set to avoid roundoff problems. - max_ent = 1.0e4*GV%m_to_H h_neglect = GV%H_subroundoff do i=is,ie ; pres(i) = tv%P_Ref ; enddo @@ -1081,8 +1114,7 @@ subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, US, CS, j, Ent_bl, do k=2,kmb ; do i=is,ie if (do_i(i)) then - Ent_bl(i,K) = min(2.0 * dtKd_int(i,K) / (h(i,j,k-1) + h(i,j,k) + h_neglect), & - max_ent) + Ent_bl(i,K) = min(2.0 * dtKd_int(i,K) / (h(i,j,k-1) + h(i,j,k) + h_neglect), CS%max_Ent) else ; Ent_bl(i,K) = 0.0 ; endif enddo ; enddo @@ -1232,13 +1264,14 @@ subroutine determine_dSkb(h_bl, Sref, Ent_bl, E_kb, is, ie, kmb, G, GV, limit, & ! Local variables real, dimension(SZI_(G),SZK_(GV)) :: & - b1, c1, & ! b1 and c1 are variables used by the tridiagonal solver. - S, dS_dE, & ! The coordinate density [R ~> kg m-3] and its derivative with E. - ea, dea_dE, & ! The entrainment from above and its derivative with E. - eb, deb_dE ! The entrainment from below and its derivative with E. - real :: deriv_dSkb(SZI_(G)) - real :: d1(SZI_(G)) ! d1 = 1.0-c1 is also used by the tridiagonal solver. - real :: src ! A source term for dS_dR. + b1, c1, & ! b1 [H-1 ~> m-1 or m2 kg-1] and c1 [nondim] are variables used by the tridiagonal solver. + S, dS_dE, & ! The coordinate density [R ~> kg m-3] and its derivative with E [R H-1 ~> kg m-4 or m-1]. + ea, dea_dE, & ! The entrainment from above [H ~> m or kg m-2] and its derivative with E [nondim]. + eb, deb_dE ! The entrainment from below [H ~> m or kg m-2] and its derivative with E [nondim]. + real :: deriv_dSkb(SZI_(G)) ! The limited derivative of the new density difference across the base of + ! the buffer layers with the new density of the bottommost buffer layer [nondim] + real :: d1(SZI_(G)) ! d1 = 1.0-c1 is also used by the tridiagonal solver [nondim]. + real :: src ! A source term for dS_dR [R ~> kg m-3]. real :: h1 ! The thickness in excess of the minimum that will remain ! after exchange with the layer below [H ~> m or kg m-2]. logical, dimension(SZI_(G)) :: do_i @@ -1247,13 +1280,15 @@ subroutine determine_dSkb(h_bl, Sref, Ent_bl, E_kb, is, ie, kmb, G, GV, limit, & real :: h_tr ! h_tr is h at tracer points with a tiny thickness ! added to ensure positive definiteness [H ~> m or kg m-2]. real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. - real :: rat - real :: dS_kbp1, IdS_kbp1 - real :: deriv_dSLay - real :: Inv_term ! [nondim] + real :: rat ! A ratio of density differences [nondim] + real :: dS_kbp1 ! The density difference between the top two interior layers [R ~> kg m-3]. + real :: IdS_kbp1 ! The inverse of dS_kbp1 [R-1 ~> m3 kg-1] + real :: deriv_dSLay ! The derivative of the projected density difference across the topmost interior + ! layer with the density difference across the interface above it [nondim] + real :: Inv_term ! The inverse of a nondimensional expression [nondim] real :: f1, df1_drat ! Temporary variables [nondim]. real :: z, dz_drat, f2, df2_dz, expz ! Temporary variables [nondim]. - real :: eps_dSLay, eps_dSkb ! Small nondimensional constants. + real :: eps_dSLay, eps_dSkb ! Small nondimensional constants [nondim]. integer :: i, k if (present(ddSlay_dE) .and. .not.present(dSlay)) call MOM_error(FATAL, & @@ -1447,16 +1482,21 @@ subroutine F_kb_to_ea_kb(h_bl, Sref, Ent_bl, I_dSkbp1, F_kb, kmb, i, & real, optional, intent(in) :: tol_in !< A tolerance for the iterative determination !! of the entrainment [H ~> m or kg m-2]. - real :: max_ea, min_ea - real :: err, err_min, err_max - real :: derr_dea - real :: val, tolerance, tol1 - real :: ea_prev - real :: dS_kbp1 - logical :: bisect_next, Newton - real, dimension(SZI_(G)) :: dS_kb - real, dimension(SZI_(G)) :: maxF, ent_maxF, zeros - real, dimension(SZI_(G)) :: ddSkb_dE + real :: max_ea, min_ea ! Bounds on the estimated entraiment [H ~> m or kg m-2] + real :: err, err_min, err_max ! Errors in the mass flux balance [H R ~> kg m-2 or kg2 m-5] + real :: derr_dea ! The change in error with the change in ea [R ~> kg m-3] + real :: val ! An estimate mass flux [H R ~> kg m-2 or kg2 m-5] + real :: tolerance, tol1 ! Tolerances for the determination of the entrainment [H ~> m or kg m-2] + real :: ea_prev ! A previous estimate of ea_kb [H ~> m or kg m-2] + real :: dS_kbp1 ! The density difference between two interior layers [R ~> kg m-3] + real :: dS_kb(SZI_(G)) ! The limited potential density difference across the interface + ! between the bottommost buffer layer and the topmost interior layer [R ~> kg m-3] + real :: maxF(SZI_(G)) ! The maximum value of F (the density flux divided by density + ! differences) found in the range min_ent < ent < max_ent [H ~> m or kg m-2]. + real :: ent_maxF(SZI_(G)) ! The value of entrainment that gives maxF [H ~> m or kg m-2] + real :: zeros(SZI_(G)) ! An array of zero entrainments [H ~> m or kg m-2] + real :: ddSkb_dE(SZI_(G)) ! The partial derivative of dS_kb with ea_kb [R H-1 ~> kg m-4 or m-1] + logical :: bisect_next, Newton ! These indicate what method the next iteration should use integer :: it integer, parameter :: MAXIT = 30 @@ -1589,13 +1629,15 @@ subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & !! The input value is the first guess. real, dimension(SZI_(G)), optional, intent(out) :: error !< The error (locally defined in this !! routine) associated with the returned - !! solution. + !! solution [H2 ~> m2 or kg2 m-4] real, dimension(SZI_(G)), optional, intent(in) :: err_min_eakb0 !< The errors (locally defined) !! associated with min_eakb when ea_kbp1 = 0, - !! returned from a previous call to this fn. + !! returned from a previous call to this + !! subroutine [H2 ~> m2 or kg2 m-4]. real, dimension(SZI_(G)), optional, intent(in) :: err_max_eakb0 !< The errors (locally defined) !! associated with min_eakb when ea_kbp1 = 0, - !! returned from a previous call to this fn. + !! returned from a previous call to this + !! subroutine [H2 ~> m2 or kg2 m-4]. real, dimension(SZI_(G)), optional, intent(out) :: F_kb !< The entrainment from below by the !! uppermost interior layer !! corresponding to the returned @@ -1719,7 +1761,7 @@ subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & Ent(i) = Ent(i) - err(i) / derror_dE(i) elseif (false_position(i) .and. & (error_maxE(i) - error_minE(i) < 0.9*large_err)) then - ! Use the false postion method if there are decent error estimates. + ! Use the false position method if there are decent error estimates. Ent(i) = E_min(i) + (E_max(i)-E_min(i)) * & (-error_minE(i)/(error_maxE(i) - error_minE(i))) false_position(i) = .false. @@ -1802,9 +1844,9 @@ subroutine find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_ent_in, max_ent_in, & !! limited value at ent=max_ent_in in this !! array [H ~> m or kg m-2]. real, dimension(SZI_(G)), & - optional, intent(in) :: F_thresh !< If F_thresh is present, return the first - !! value found that has F > F_thresh, or - !! the maximum. + optional, intent(in) :: F_thresh !< If F_thresh is present, return the first value + !! found that has F > F_thresh [H ~> m or kg m-2], or + !! the maximum root if it is absent. ! Maximize F = ent*ds_kb*I_dSkbp1 in the range min_ent < ent < max_ent. ! ds_kb may itself be limited to positive values in determine_dSkb, which gives @@ -1813,17 +1855,21 @@ subroutine find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_ent_in, max_ent_in, & ! negative) value. It is faster to find the true maximum by first finding the ! unlimited maximum and comparing it to the limited value at max_ent_in. real, dimension(SZI_(G)) :: & - ent, & - minent, maxent, ent_best, & - F_max_ent_in, & - F_maxent, F_minent, F, F_best, & - dF_dent, dF_dE_max, dF_dE_min, dF_dE_best, & - dS_kb, dS_kb_lim, ddSkb_dE, dS_anom_lim, & - chg_prev, chg_pre_prev - real :: dF_dE_mean, maxslope, minslope - real :: tolerance - real :: ratio_select_end - real :: rat, max_chg, min_chg, chg1, chg2, chg + ent, & ! The updated estimate of the entrainment [H ~> m or kg m-2] + minent, maxent, ent_best, & ! Various previous estimates of the entrainment [H ~> m or kg m-2] + F_max_ent_in, & ! The value of F that gives the input maximum value of ent [H ~> m or kg m-2] + F_maxent, F_minent, F, F_best, & ! Various estimates of F [H ~> m or kg m-2] + dF_dent, dF_dE_max, dF_dE_min, dF_dE_best, & ! Various derivatives of F with ent [nondim] + dS_kb, & ! The density difference across the interface between the bottommost + ! buffer layer and the topmost interior layer [R ~> kg m-3] + dS_kb_lim, dS_anom_lim, & ! Various limits on dS_kb [R ~> kg m-3] + ddSkb_dE, & ! The partial derivative of dS_kb with ent [R H-1 ~> kg m-4 or m-1]. + chg_prev, chg_pre_prev ! Changes in estimates of the entrainment from previous iterations [H ~> m or kg m-2] + real :: dF_dE_mean, maxslope, minslope ! Various derivatives of F with ent [nondim] + real :: tolerance ! The tolerance within which ent must be converged [H ~> m or kg m-2] + real :: ratio_select_end, rat ! Fractional changes in the value of ent to use for the next iteration + ! relative to its bounded range [nondim] + real :: max_chg, min_chg, chg1, chg2, chg ! Changes in entrainment estimates [H ~> m or kg m-2] logical, dimension(SZI_(G)) :: do_i, last_it, need_bracket, may_use_best logical :: doany, OK1, OK2, bisect, new_min_bound integer :: i, it, is1, ie1 @@ -1876,14 +1922,14 @@ subroutine find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_ent_in, max_ent_in, & maxslope = MAX(dF_dE_mean, dF_dE_min(i), dF_dE_max(i)) minslope = MIN(dF_dE_mean, dF_dE_min(i), dF_dE_max(i)) if (F_minent(i) >= F_maxent(i)) then - if (dF_dE_min(i) > 0.0) then ; rat = 0.02 ! A small step should bracket the soln. + if (dF_dE_min(i) > 0.0) then ; rat = 0.02 ! A small step should bracket the solution. elseif (maxslope < ratio_select_end*minslope) then ! The maximum of F is at minent. F_best(i) = F_minent(i) ; ent_best(i) = minent(i) ; rat = 0.0 do_i(i) = .false. else ; rat = 0.382 ; endif ! Use the golden ratio else - if (dF_dE_max(i) < 0.0) then ; rat = 0.98 ! A small step should bracket the soln. + if (dF_dE_max(i) < 0.0) then ; rat = 0.98 ! A small step should bracket the solution. elseif (minslope > ratio_select_end*maxslope) then ! The maximum of F is at maxent. F_best(i) = F_maxent(i) ; ent_best(i) = maxent(i) ; rat = 1.0 @@ -1979,7 +2025,7 @@ subroutine find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_ent_in, max_ent_in, & new_min_bound = .true. ! We have a new minimum bound. elseif ((F(i) <= F_maxent(i)) .and. (F(i) > F_minent(i))) then new_min_bound = .false. ! We have a new maximum bound. - else ! This case would bracket a minimum. Wierd. + else ! This case would bracket a minimum. Weird. ! Unless the derivative indicates that there is a maximum near the ! lower bound, try keeping the end with the larger value of F ! in a tie keep the minimum as the answer here will be compared @@ -2068,14 +2114,14 @@ subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS, just_re !! parameters. type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic !! output. - type(entrain_diffusive_CS), intent(inout) :: CS !< Entrainment diffusion control struct + type(entrain_diffusive_CS), intent(inout) :: CS !< Entrainment diffusion control structure logical, intent(in) :: just_read_params !< If true, this call will only read !! and log parameters without registering !! any diagnostics ! Local variables - real :: dt ! The dynamics timestep, used here in the default for TOLERANCE_ENT, in MKS units [s] - real :: Kd ! A diffusivity used in the default for TOLERANCE_ENT, in MKS units [m2 s-1] + real :: dt ! The dynamics timestep, used here in the default for TOLERANCE_ENT [T ~> s] + real :: Kd ! A diffusivity used in the default for TOLERANCE_ENT [Z2 T-1 ~> m2 s-1] ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_entrain_diffusive" ! This module's name. @@ -2090,21 +2136,25 @@ subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS, just_re call get_param(param_file, mdl, "MAX_ENT_IT", CS%max_ent_it, & "The maximum number of iterations that may be used to "//& "calculate the interior diapycnal entrainment.", default=5, do_not_log=just_read_params) - ! In this module, KD is only used to set the default for TOLERANCE_ENT. [m2 s-1] - call get_param(param_file, mdl, "KD", Kd, default=0.0) + ! In this module, KD is only used to set the default for TOLERANCE_ENT. [Z2 T-1 ~> m2 s-1] + call get_param(param_file, mdl, "KD", Kd, units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "DT", dt, & - "The (baroclinic) dynamics time step.", units = "s", & - fail_if_missing=.true., do_not_log=just_read_params) + "The (baroclinic) dynamics time step.", & + units="s", scale=US%s_to_T, fail_if_missing=.true., do_not_log=just_read_params) call get_param(param_file, mdl, "TOLERANCE_ENT", CS%Tolerance_Ent, & "The tolerance with which to solve for entrainment values.", & - units="m", default=MAX(100.0*GV%Angstrom_m,1.0e-4*sqrt(dt*Kd)), scale=GV%m_to_H, & + units="m", default=US%Z_to_m*MAX(100.0*GV%Angstrom_Z,1.0e-4*sqrt(dt*Kd)), scale=GV%m_to_H, & do_not_log=just_read_params) + call get_param(param_file, mdl, "ENTRAIN_DIFFUSIVE_MAX_ENT", CS%max_Ent, & + "A large ceiling on the maximum permitted amount of entrainment across each "//& + "interface between the mixed and buffer layers within a timestep.", & + units="m", default=1.0e4, scale=GV%m_to_H, do_not_log=.not.CS%bulkmixedlayer) CS%Rho_sig_off = 1000.0*US%kg_m3_to_R if (.not.just_read_params) then CS%id_Kd = register_diag_field('ocean_model', 'Kd_effective', diag%axesTL, Time, & - 'Diapycnal diffusivity as applied', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Diapycnal diffusivity as applied', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) CS%id_diff_work = register_diag_field('ocean_model', 'diff_work', diag%axesTi, Time, & 'Work actually done by diapycnal diffusion across each interface', & 'W m-2', conversion=US%RZ3_T3_to_W_m2) @@ -2119,10 +2169,10 @@ end subroutine entrain_diffusive_init !! mixing and advection in isopycnal layers. The main subroutine, !! calculate_entrainment, returns the entrainment by each layer !! across the interfaces above and below it. These are calculated -!! subject to the constraints that no layers can be driven to neg- -!! ative thickness and that the each layer maintains its target -!! density, using the scheme described in Hallberg (MWR 2000). There -!! may or may not be a bulk mixed layer above the isopycnal layers. +!! subject to the constraints that no layers can be driven to negative +!! thickness and that the each layer maintains its target density, +!! using the scheme described in Hallberg (MWR 2000). There may or +!! may not be a bulk mixed layer above the isopycnal layers. !! The solution is iterated until the change in the entrainment !! between successive iterations is less than some small tolerance. !! @@ -2134,9 +2184,9 @@ end subroutine entrain_diffusive_init !! diffusion, so the fully implicit upwind differencing scheme that !! is used is entirely appropriate. The downward buoyancy flux in !! each layer is determined from an implicit calculation based on -!! the previously calculated flux of the layer above and an estim- -!! ated flux in the layer below. This flux is subject to the foll- -!! owing conditions: (1) the flux in the top and bottom layers are +!! the previously calculated flux of the layer above and an estimated +!! flux in the layer below. This flux is subject to the following +!! conditions: (1) the flux in the top and bottom layers are !! set by the boundary conditions, and (2) no layer may be driven !! below an Angstrom thickness. If there is a bulk mixed layer, the !! mixed and buffer layers are treated as Eulerian layers, whose diff --git a/src/parameterizations/vertical/MOM_full_convection.F90 b/src/parameterizations/vertical/MOM_full_convection.F90 index 8ddd256ac7..bcf715a204 100644 --- a/src/parameterizations/vertical/MOM_full_convection.F90 +++ b/src/parameterizations/vertical/MOM_full_convection.F90 @@ -1,13 +1,16 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Does full convective adjustment of unstable regions via a strong diffusivity. module MOM_full_convection -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_grid, only : ocean_grid_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density_derivs, EOS_domain +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density_derivs, EOS_domain implicit none ; private @@ -21,43 +24,44 @@ module MOM_full_convection subroutine full_convection(G, GV, US, h, tv, T_adj, S_adj, p_surf, Kddt_smooth, halo) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: T_adj !< Adjusted potential temperature [degC]. + intent(out) :: T_adj !< Adjusted potential temperature [C ~> degC]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: S_adj !< Adjusted salinity [ppt]. + intent(out) :: S_adj !< Adjusted salinity [S ~> ppt]. real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] (or NULL). - real, intent(in) :: Kddt_smooth !< A smoothing vertical - !! diffusivity times a timestep [H2 ~> m2 or kg2 m-4]. + real, intent(in) :: Kddt_smooth !< A smoothing vertical diffusivity + !! times a timestep [H Z ~> m2 or kg m-1]. integer, intent(in) :: halo !< Halo width over which to compute ! Local variables real, dimension(SZI_(G),SZK_(GV)+1) :: & - dRho_dT, & ! The derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] - dRho_dS ! The derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. - real :: h_neglect, h0 ! A thickness that is so small it is usually lost + dRho_dT, & ! The derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + dRho_dS ! The derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. + real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] + real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. ! logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. real, dimension(SZI_(G),SZK0_(G)) :: & Te_a, & ! A partially updated temperature estimate including the influence from - ! mixing with layers above rescaled by a factor of d_a [degC]. + ! mixing with layers above rescaled by a factor of d_a [C ~> degC]. ! This array is discretized on tracer cells, but contains an extra ! layer at the top for algorithmic convenience. Se_a ! A partially updated salinity estimate including the influence from - ! mixing with layers above rescaled by a factor of d_a [ppt]. + ! mixing with layers above rescaled by a factor of d_a [S ~> ppt]. ! This array is discretized on tracer cells, but contains an extra ! layer at the top for algorithmic convenience. real, dimension(SZI_(G),SZK_(GV)+1) :: & Te_b, & ! A partially updated temperature estimate including the influence from - ! mixing with layers below rescaled by a factor of d_b [degC]. + ! mixing with layers below rescaled by a factor of d_b [C ~> degC]. ! This array is discretized on tracer cells, but contains an extra ! layer at the bottom for algorithmic convenience. Se_b ! A partially updated salinity estimate including the influence from - ! mixing with layers below rescaled by a factor of d_b [ppt]. + ! mixing with layers below rescaled by a factor of d_b [S ~> ppt]. ! This array is discretized on tracer cells, but contains an extra ! layer at the bottom for algorithmic convenience. real, dimension(SZI_(G),SZK_(GV)+1) :: & @@ -90,15 +94,17 @@ subroutine full_convection(G, GV, US, h, tv, T_adj, S_adj, p_surf, Kddt_smooth, if (.not.associated(tv%eqn_of_state)) return h_neglect = GV%H_subroundoff - mix_len = (1.0e20 * nz) * (G%max_depth * GV%Z_to_H) - h0 = 1.0e-16*sqrt(Kddt_smooth) + h_neglect + mix_len = (1.0e20 * nz) * (G%max_depth * US%Z_to_m * GV%m_to_H) do j=js,je mix(:,:) = 0.0 ; d_b(:,:) = 1.0 ! These would be Te_b(:,:) = tv%T(:,j,:), etc., but the values are not used Te_b(:,:) = 0.0 ; Se_b(:,:) = 0.0 - call smoothed_dRdT_dRdS(h, tv, Kddt_smooth, dRho_dT, dRho_dS, G, GV, US, j, p_surf, halo) + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV, halo_size=halo) + + call smoothed_dRdT_dRdS(h, dz, tv, Kddt_smooth, dRho_dT, dRho_dS, G, GV, US, j, p_surf, halo) do i=is,ie do_i(i) = (G%mask2dT(i,j) > 0.0) @@ -270,22 +276,22 @@ end subroutine full_convection !! above and below, including partial calculations from a tridiagonal solver. function is_unstable(dRho_dT, dRho_dS, h_a, h_b, mix_A, mix_B, T_a, T_b, S_a, S_b, & Te_aa, Te_bb, Se_aa, Se_bb, d_A, d_B) - real, intent(in) :: dRho_dT !< The derivative of in situ density with temperature [R degC-1 ~> kg m-3 degC-1] - real, intent(in) :: dRho_dS !< The derivative of in situ density with salinity [R ppt-1 ~> kg m-3 ppt-1] + real, intent(in) :: dRho_dT !< The derivative of in situ density with temperature [R C-1 ~> kg m-3 degC-1] + real, intent(in) :: dRho_dS !< The derivative of in situ density with salinity [R S-1 ~> kg m-3 ppt-1] real, intent(in) :: h_a !< The thickness of the layer above [H ~> m or kg m-2] real, intent(in) :: h_b !< The thickness of the layer below [H ~> m or kg m-2] real, intent(in) :: mix_A !< The time integrated mixing rate of the interface above [H ~> m or kg m-2] real, intent(in) :: mix_B !< The time integrated mixing rate of the interface below [H ~> m or kg m-2] - real, intent(in) :: T_a !< The initial temperature of the layer above [degC] - real, intent(in) :: T_b !< The initial temperature of the layer below [degC] - real, intent(in) :: S_a !< The initial salinity of the layer below [ppt] - real, intent(in) :: S_b !< The initial salinity of the layer below [ppt] - real, intent(in) :: Te_aa !< The estimated temperature two layers above rescaled by d_A [degC] - real, intent(in) :: Te_bb !< The estimated temperature two layers below rescaled by d_B [degC] - real, intent(in) :: Se_aa !< The estimated salinity two layers above rescaled by d_A [ppt] - real, intent(in) :: Se_bb !< The estimated salinity two layers below rescaled by d_B [ppt] - real, intent(in) :: d_A !< The rescaling dependency across the interface above, nondim. - real, intent(in) :: d_B !< The rescaling dependency across the interface below, nondim. + real, intent(in) :: T_a !< The initial temperature of the layer above [C ~> degC] + real, intent(in) :: T_b !< The initial temperature of the layer below [C ~> degC] + real, intent(in) :: S_a !< The initial salinity of the layer below [S ~> ppt] + real, intent(in) :: S_b !< The initial salinity of the layer below [S ~> ppt] + real, intent(in) :: Te_aa !< The estimated temperature two layers above rescaled by d_A [C ~> degC] + real, intent(in) :: Te_bb !< The estimated temperature two layers below rescaled by d_B [C ~> degC] + real, intent(in) :: Se_aa !< The estimated salinity two layers above rescaled by d_A [S ~> ppt] + real, intent(in) :: Se_bb !< The estimated salinity two layers below rescaled by d_B [S ~> ppt] + real, intent(in) :: d_A !< The rescaling dependency across the interface above [nondim] + real, intent(in) :: d_B !< The rescaling dependency across the interface below [nondim] logical :: is_unstable !< The return value, true if the profile is statically unstable !! around the interface in question. @@ -306,20 +312,22 @@ end function is_unstable !> Returns the partial derivatives of locally referenced potential density with !! temperature and salinity after the properties have been smoothed with a small !! constant diffusivity. -subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, halo) +subroutine smoothed_dRdT_dRdS(h, dz, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, halo) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: dz !< Height change across layers [Z ~> m] type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables - real, intent(in) :: Kddt !< A diffusivity times a time increment [H2 ~> m2 or kg2 m-4]. + real, intent(in) :: Kddt !< A diffusivity times a time increment [H Z ~> m2 or kg m-1]. real, dimension(SZI_(G),SZK_(GV)+1), & intent(out) :: dR_dT !< Derivative of locally referenced - !! potential density with temperature [R degC-1 ~> kg m-3 degC-1] + !! potential density with temperature [R C-1 ~> kg m-3 degC-1] real, dimension(SZI_(G),SZK_(GV)+1), & intent(out) :: dR_dS !< Derivative of locally referenced - !! potential density with salinity [R ppt-1 ~> kg m-3 ppt-1] + !! potential density with salinity [R S-1 ~> kg m-3 ppt-1] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: j !< The j-point to work on. real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa]. @@ -331,13 +339,14 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h real :: b1(SZI_(G)) ! A tridiagonal solver variable [H-1 ~> m-1 or m2 kg-1] real :: d1(SZI_(G)) ! A tridiagonal solver variable [nondim] real :: c1(SZI_(G),SZK_(GV)) ! A tridiagonal solver variable [nondim] - real :: T_f(SZI_(G),SZK_(GV)) ! Filtered temperatures [degC] - real :: S_f(SZI_(G),SZK_(GV)) ! Filtered salinities [ppt] + real :: T_f(SZI_(G),SZK_(GV)) ! Filtered temperatures [C ~> degC] + real :: S_f(SZI_(G),SZK_(GV)) ! Filtered salinities [S ~> ppt] real :: pres(SZI_(G)) ! Interface pressures [R L2 T-2 ~> Pa]. - real :: T_EOS(SZI_(G)) ! Filtered and vertically averaged temperatures [degC] - real :: S_EOS(SZI_(G)) ! Filtered and vertically averaged salinities [ppt] - real :: kap_dt_x2 ! The product of 2*kappa*dt [H2 ~> m2 or kg2 m-4]. - real :: h_neglect, h0 ! Negligible thicknesses to allow for zero thicknesses, + real :: T_EOS(SZI_(G)) ! Filtered and vertically averaged temperatures [C ~> degC] + real :: S_EOS(SZI_(G)) ! Filtered and vertically averaged salinities [S ~> ppt] + real :: kap_dt_x2 ! The product of 2*kappa*dt [H Z ~> m2 or kg m-1]. + real :: dz_neglect, h0 ! A negligible vertical distances [Z ~> m] + real :: h_neglect ! A negligible thickness to allow for zero thicknesses ! [H ~> m or kg m-2]. real :: h_tr ! The thickness at tracer points, plus h_neglect [H ~> m or kg m-2]. integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state @@ -347,6 +356,7 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h nz = GV%ke h_neglect = GV%H_subroundoff + dz_neglect = GV%dz_subroundoff kap_dt_x2 = 2.0*Kddt if (Kddt <= 0.0) then @@ -354,9 +364,9 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h T_f(i,k) = tv%T(i,j,k) ; S_f(i,k) = tv%S(i,j,k) enddo ; enddo else - h0 = 1.0e-16*sqrt(Kddt) + h_neglect + h0 = 1.0e-16*sqrt(GV%H_to_m*US%m_to_Z*Kddt) + dz_neglect do i=is,ie - mix(i,2) = kap_dt_x2 / ((h(i,j,1)+h(i,j,2)) + h0) + mix(i,2) = kap_dt_x2 / ((dz(i,1)+dz(i,2)) + h0) h_tr = h(i,j,1) + h_neglect b1(i) = 1.0 / (h_tr + mix(i,2)) @@ -365,7 +375,7 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h S_f(i,1) = (b1(i)*h_tr)*tv%S(i,j,1) enddo do k=2,nz-1 ; do i=is,ie - mix(i,K+1) = kap_dt_x2 / ((h(i,j,k)+h(i,j,k+1)) + h0) + mix(i,K+1) = kap_dt_x2 / ((dz(i,k)+dz(i,k+1)) + h0) c1(i,k) = mix(i,K) * b1(i) h_tr = h(i,j,k) + h_neglect diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index 9884eec7a2..93c429198d 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Implemented geothermal heating at the ocean bottom. module MOM_geothermal -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc use MOM_diag_mediator, only : register_static_field, time_type, diag_ctrl use MOM_domains, only : pass_var @@ -13,7 +15,8 @@ module MOM_geothermal use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units -use MOM_EOS, only : calculate_density, calculate_density_derivs +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain +use MOM_EOS, only : calculate_specific_vol_derivs implicit none ; private @@ -26,7 +29,7 @@ module MOM_geothermal logical :: initialized = .false. !< True if this control structure has been initialized. real :: dRcv_dT_inplace !< The value of dRcv_dT above which (dRcv_dT is negative) the !! water is heated in place instead of moving upward between - !! layers in non-ALE layered mode [R degC-1 ~> kg m-3 degC-1] + !! layers in non-ALE layered mode [R C-1 ~> kg m-3 degC-1] real, allocatable, dimension(:,:) :: geo_heat !< The geothermal heat flux [Q R Z T-1 ~> W m-2] real :: geothermal_thick !< The thickness over which geothermal heating is !! applied [H ~> m or kg m-2] @@ -39,7 +42,7 @@ module MOM_geothermal integer :: id_internal_heat_heat_tendency = -1 !< ID for diagnostic of heat tendency integer :: id_internal_heat_temp_tendency = -1 !< ID for diagnostic of temperature tendency integer :: id_internal_heat_h_tendency = -1 !< ID for diagnostic of thickness tendency - + integer :: id_geothermal_buoyancy_flux = -1 !< ID for diagnostic of bottom buoyancy flux end type geothermal_CS contains @@ -72,47 +75,47 @@ subroutine geothermal_entraining(h, tv, dt, ea, eb, G, GV, US, CS, halo) integer, optional, intent(in) :: halo !< Halo width over which to work ! Local variables real, dimension(SZI_(G)) :: & - heat_rem, & ! remaining heat [H degC ~> m degC or kg degC m-2] + heat_rem, & ! remaining heat [H C ~> m degC or kg degC m-2] h_geo_rem, & ! remaining thickness to apply geothermal heating [H ~> m or kg m-2] Rcv_BL, & ! coordinate density in the deepest variable density layer [R ~> kg m-3] p_ref ! coordinate densities reference pressure [R L2 T-2 ~> Pa] real, dimension(2) :: & - T2, S2, & ! temp and saln in the present and target layers [degC] and [ppt] - dRcv_dT_, & ! partial derivative of coordinate density wrt temp [R degC-1 ~> kg m-3 degC-1] - dRcv_dS_ ! partial derivative of coordinate density wrt saln [R ppt-1 ~> kg m-3 ppt-1] + T2, S2, & ! temp and saln in the present and target layers [C ~> degC] and [S ~> ppt] + dRcv_dT_, & ! partial derivative of coordinate density wrt temp [R C-1 ~> kg m-3 degC-1] + dRcv_dS_ ! partial derivative of coordinate density wrt saln [R S-1 ~> kg m-3 ppt-1] real :: Angstrom, H_neglect ! small thicknesses [H ~> m or kg m-2] real :: Rcv ! coordinate density of present layer [R ~> kg m-3] real :: Rcv_tgt ! coordinate density of target layer [R ~> kg m-3] real :: dRcv ! difference between Rcv and Rcv_tgt [R ~> kg m-3] real :: dRcv_dT ! partial derivative of coordinate density wrt temp - ! in the present layer [R degC-1 ~> kg m-3 degC-1]; usually negative + ! in the present layer [R C-1 ~> kg m-3 degC-1]; usually negative real :: h_heated ! thickness that is being heated [H ~> m or kg m-2] - real :: heat_avail ! heating available for the present layer [degC H ~> degC m or degC kg m-2] + real :: heat_avail ! heating available for the present layer [C H ~> degC m or degC kg m-2] real :: heat_in_place ! heating to warm present layer w/o movement between layers - ! [degC H ~> degC m or degC kg m-2] + ! [C H ~> degC m or degC kg m-2] real :: heat_trans ! heating available to move water from present layer to target - ! layer [degC H ~> degC m or degC kg m-2] + ! layer [C H ~> degC m or degC kg m-2] real :: heating ! heating used to move water from present layer to target layer - ! [degC H ~> degC m or degC kg m-2] + ! [C H ~> degC m or degC kg m-2] ! 0 <= heating <= heat_trans real :: h_transfer ! thickness moved between layers [H ~> m or kg m-2] real :: wt_in_place ! relative weighting that goes from 0 to 1 [nondim] real :: I_h ! inverse thickness [H-1 ~> m-1 or m2 kg-1] - real :: dTemp ! temperature increase in a layer [degC] + real :: dTemp ! temperature increase in a layer [C ~> degC] real :: Irho_cp ! inverse of heat capacity per unit layer volume - ! [degC H Q-1 R-1 Z-1 ~> degC m3 J-1 or degC kg J-1] + ! [C H Q-1 R-1 Z-1 ~> degC m3 J-1 or degC kg J-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & - T_old, & ! Temperature of each layer before any heat is added, for diagnostics [degC] + T_old, & ! Temperature of each layer before any heat is added, for diagnostics [C ~> degC] h_old, & ! Thickness of each layer before any heat is added, for diagnostics [H ~> m or kg m-2] - work_3d ! Scratch variable used to calculate changes due to geothermal + work_3d ! Scratch variable used to calculate changes due to geothermal [various] real :: Idt ! inverse of the timestep [T-1 ~> s-1] logical :: do_i(SZI_(G)) logical :: compute_h_old, compute_T_old - integer :: i, j, k, is, ie, js, je, nz, k2, i2 + integer :: i, j, k, is, ie, js, je, nz, k2 integer :: isj, iej, num_left, nkmb, k_tgt is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -360,7 +363,7 @@ end subroutine geothermal_entraining !> Applies geothermal heating to the bottommost layers that occur within GEOTHERMAL_THICKNESS of !! the bottom, by simply heating the water in place. Any heat that can not be applied to the ocean !! is returned (WHERE)? -subroutine geothermal_in_place(h, tv, dt, G, GV, US, CS, halo) +subroutine geothermal_in_place(h, tv, dt, G, GV, US, CS, BFlx_geothermal, halo) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] @@ -369,26 +372,39 @@ subroutine geothermal_in_place(h, tv, dt, G, GV, US, CS, halo) real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(geothermal_CS), intent(in) :: CS !< Geothermal heating control struct + real, dimension(SZI_(G), SZJ_(G)), intent(out) :: BFlx_geothermal !< Geothermal buoyancy flux + !! in [Z2 T-3 ~> m2 s-3] integer, optional, intent(in) :: halo !< Halo width over which to work + ! Local variables real, dimension(SZI_(G)) :: & - heat_rem, & ! remaining heat [H degC ~> m degC or kg degC m-2] - h_geo_rem ! remaining thickness to apply geothermal heating [H ~> m or kg m-2] + heat_rem, & ! remaining heat [H C ~> m degC or kg degC m-2] + h_geo_rem, & ! remaining thickness to apply geothermal heating [H ~> m or kg m-2] + bottom_pressure, & ! Hydrostatic pressure in bottom layer [R L2 T-2 ~> Pa] + dRhodT, & ! Partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + dRhodS, & ! Partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] + dSpVdT, & ! Partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSpVdS ! Partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1] real :: Angstrom, H_neglect ! small thicknesses [H ~> m or kg m-2] - real :: heat_here ! heating applied to the present layer [degC H ~> degC m or degC kg m-2] - real :: dTemp ! temperature increase in a layer [degC] + real :: heat_here ! heating applied to the present layer [C H ~> degC m or degC kg m-2] + real :: dTemp ! temperature increase in a layer [C ~> degC] real :: Irho_cp ! inverse of heat capacity per unit layer volume - ! [degC H Q-1 R-1 Z-1 ~> degC m3 J-1 or degC kg J-1] + ! [C H Q-1 R-1 Z-1 ~> degC m3 J-1 or degC kg J-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & - dTdt_diag ! Diagnostic of temperature tendency [degC T-1 ~> degC s-1] which might be + dTdt_diag ! Diagnostic of temperature tendency [C T-1 ~> degC s-1] which might be ! converted into a layer-integrated heat tendency [Q R Z T-1 ~> W m-2] real :: Idt ! inverse of the timestep [T-1 ~> s-1] + real :: H_to_Pres ! A conversion factor from thicknesses to pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] + real :: I_Cp ! 1.0 / C_p [C Q-1 ~> kg degC J-1] + real :: I_Rho0Squared ! 1.0 / rho_0^2 (Boussinesq only) [R-2 ~> m6 kg-2] logical :: do_any ! True if there is more to be done on the current j-row. logical :: calc_diags ! True if diagnostic tendencies are needed. - integer :: i, j, k, is, ie, js, je, nz, i2, isj, iej + logical :: nonBous ! If true, do not make the Boussinesq approximation. + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, j, k, is, ie, js, je, nz, isj, iej is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (present(halo)) then @@ -399,25 +415,56 @@ subroutine geothermal_in_place(h, tv, dt, G, GV, US, CS, halo) "Module must be initialized before it is used.") if (.not.CS%apply_geothermal) return + nonBous = .not.(GV%Boussinesq .or. GV%semi_Boussinesq) Irho_cp = 1.0 / (GV%H_to_RZ * tv%C_p) Angstrom = GV%Angstrom_H H_neglect = GV%H_subroundoff Idt = 1.0 / dt + H_to_pres = GV%H_to_RZ * GV%g_Earth + I_Cp = 1. /tv%C_p + if (.not.nonBous) I_Rho0squared = 1. / (GV%Rho0**2) + EOSdom(:) = EOS_domain(G%HI) if (.not.associated(tv%T)) call MOM_error(FATAL, "MOM geothermal_in_place: "//& "Geothermal heating can only be applied if T & S are state variables.") -! do i=is,ie ; do j=js,je +! do j=js,je ; do i=is,ie ! resid(i,j) = tv%internal_heat(i,j) ! enddo ; enddo ! Conditionals for tracking diagnostic depdendencies calc_diags = (CS%id_internal_heat_heat_tendency > 0) .or. (CS%id_internal_heat_temp_tendency > 0) + BFlx_geothermal(:,:) = 0.0 if (calc_diags) dTdt_diag(:,:,:) = 0.0 !$OMP parallel do default(shared) private(heat_rem,do_any,h_geo_rem,isj,iej,heat_here,dTemp) do j=js,je + bottom_pressure(:) = 0.0 + do k=1,nz ; do i=is,ie + bottom_pressure(i) = bottom_pressure(i) + H_to_pres * h(i,j,k) + enddo ; enddo + if (nonBous) then + dSpVdT(:) = 0.0 + dSpVdS(:) = 0.0 + call calculate_specific_vol_derivs(tv%T(:,j,nz), tv%S(:,j,nz), bottom_pressure, dSpVdT, dSpVdS, & + tv%eqn_of_state, EOSdom) + do i=is,ie + BFlx_geothermal(i,j) = ( (GV%g_Earth_Z_T2 * dSpVdT(i)) * (CS%geo_heat(i,j)*I_Cp) ) * G%mask2dT(i,j) + enddo + else + dRhodT(:) = 0.0 + dRhodS(:) = 0.0 + call calculate_density_derivs(tv%T(:,j,nz), tv%S(:,j,nz), bottom_pressure, dRhodT, dRhodS, & + tv%eqn_of_state, EOSdom) + do i=is,ie + BFlx_geothermal(i,j) = - ( (GV%g_Earth_Z_T2*I_Rho0squared) * ((I_Cp*dRhodT(i))*CS%geo_heat(i,j)) ) & + * G%mask2dT(i,j) + enddo + endif + + + ! Only work on columns that are being heated, and heat the near-bottom water. ! If there is not enough mass in the ocean, pass some of the heat up @@ -475,12 +522,14 @@ subroutine geothermal_in_place(h, tv, dt, G, GV, US, CS, halo) if (CS%id_internal_heat_heat_tendency > 0) then do k=1,nz ; do j=js,je ; do i=is,ie ! Dangerously reuse dTdt_diag for a related variable with different units, going from - ! units of [degC T-1 ~> degC s-1] to units of [Q R Z T-1 ~> W m-2] + ! units of [C T-1 ~> degC s-1] to units of [Q R Z T-1 ~> W m-2] dTdt_diag(i,j,k) = (GV%H_to_RZ*tv%C_p) * (h(i,j,k) * dTdt_diag(i,j,k)) enddo ; enddo ; enddo call post_data(CS%id_internal_heat_heat_tendency, dTdt_diag, CS%diag, alt_h=h) endif - + if (CS%id_geothermal_buoyancy_flux > 0) then + call post_data(CS%id_geothermal_buoyancy_flux, BFlx_geothermal, CS%diag) + endif ! do j=js,je ; do i=is,ie ! resid(i,j) = tv%internal_heat(i,j) - resid(i,j) - GV%H_to_RZ * & ! (G%mask2dT(i,j) * (CS%geo_heat(i,j) * (dt*Irho_cp))) @@ -537,7 +586,7 @@ subroutine geothermal_init(Time, G, GV, US, param_file, diag, CS, useALEalgorith "The value of drho_dT above which geothermal heating "//& "simply heats water in place instead of moving it between "//& "isopycnal layers. This must be negative.", & - units="kg m-3 K-1", scale=US%kg_m3_to_R, default=-0.01, & + units="kg m-3 K-1", scale=US%kg_m3_to_R*US%C_to_degC, default=-0.01, & do_not_log=((GV%nk_rho_varies<=0).or.(GV%nk_rho_varies>=GV%ke)) ) if (CS%dRcv_dT_inplace >= 0.0) call MOM_error(FATAL, "geothermal_init: "//& "GEOTHERMAL_DRHO_DT_INPLACE must be negative.") @@ -572,18 +621,22 @@ subroutine geothermal_init(Time, G, GV, US, param_file, diag, CS, useALEalgorith x_cell_method='mean', y_cell_method='mean', area_cell_method='mean') if (id > 0) call post_data(id, CS%geo_heat, diag, .true.) + CS%id_geothermal_buoyancy_flux = register_diag_field('ocean_model', & + 'geo_bflx', diag%axesT1, Time, 'Geothermal buoyancy flux into ocean', & + 'm2 s-3', conversion=US%Z_to_m**2*US%s_to_T**3) + ! Diagnostic for tendencies due to internal heat (in 3d) - CS%id_internal_heat_heat_tendency=register_diag_field('ocean_model', & + CS%id_internal_heat_heat_tendency = register_diag_field('ocean_model', & 'internal_heat_heat_tendency', diag%axesTL, Time, & 'Heat tendency (in 3D) due to internal (geothermal) sources', & 'W m-2', conversion=US%QRZ_T_to_W_m2, v_extensive=.true.) - CS%id_internal_heat_temp_tendency=register_diag_field('ocean_model', & + CS%id_internal_heat_temp_tendency = register_diag_field('ocean_model', & 'internal_heat_temp_tendency', diag%axesTL, Time, & 'Temperature tendency (in 3D) due to internal (geothermal) sources', & - 'degC s-1', conversion=US%s_to_T, v_extensive=.true.) + 'degC s-1', conversion=US%C_to_degC*US%s_to_T, v_extensive=.true.) if (.not.useALEalgorithm) then ! Do not offer this diagnostic if heating will be in place. - CS%id_internal_heat_h_tendency=register_diag_field('ocean_model', & + CS%id_internal_heat_h_tendency = register_diag_field('ocean_model', & 'internal_heat_h_tendency', diag%axesTL, Time, & 'Thickness tendency (in 3D) due to internal (geothermal) sources', & trim(thickness_units)//' s-1', conversion=GV%H_to_MKS*US%s_to_T, v_extensive=.true.) diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 300cdcbe1e..f8ed9f111c 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Calculates energy input to the internal tides module MOM_int_tide_input -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE use MOM_diag_mediator, only : diag_ctrl, query_averaging_enabled @@ -11,21 +13,25 @@ module MOM_int_tide_input use MOM_debugging, only : hchksum use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_file_parser, only : read_param use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type use MOM_io, only : slasher, vardesc, MOM_read_data +use MOM_interface_heights, only : thickness_to_dz, find_rho_bottom use MOM_isopycnal_slopes, only : vert_fill_TS +use MOM_string_functions, only : extractWord use MOM_time_manager, only : time_type, set_time, operator(+), operator(<=) use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type, p3d use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain +use MOM_EOS, only : calculate_density_derivs, EOS_domain implicit none ; private #include public set_int_tide_input, int_tide_input_init, int_tide_input_end +public get_input_TKE, get_barotropic_tidal_vel ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -38,40 +44,45 @@ module MOM_int_tide_input logical :: debug !< If true, write verbose checksums for debugging. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. - real :: TKE_itide_max !< Maximum Internal tide conversion - !! available to mix above the BBL [R Z3 T-3 ~> W m-2] + real :: TKE_itide_maxi !< Maximum Internal tide conversion + !! available to mix above the BBL [H Z2 T-3 ~> m3 s-3 or W m-2] real :: kappa_fill !< Vertical diffusivity used to interpolate sensible values - !! of T & S into thin layers [Z2 T-1 ~> m2 s-1]. + !! of T & S into thin layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + + real, allocatable, dimension(:,:,:) :: TKE_itidal_coef + !< The time-invariant field that enters the TKE_itidal input calculation noting that the + !! stratification and perhaps density are time-varying [R Z4 H-1 T-2 ~> J m-2 or J m kg-1]. + real, allocatable, dimension(:,:,:) :: & + TKE_itidal_input, & !< The internal tide TKE input at the bottom of the ocean [H Z2 T-3 ~> m3 s-3 or W m-2]. + tideamp !< The amplitude of the tidal velocities [L T-1 ~> m s-1]. - real, allocatable, dimension(:,:) :: TKE_itidal_coef - !< The time-invariant field that enters the TKE_itidal input calculation [R Z3 T-2 ~> J m-2]. character(len=200) :: inputdir !< The directory for input files. logical :: int_tide_source_test !< If true, apply an arbitrary generation site - !! for internal tide testing (BDM) + !! for internal tide testing type(time_type) :: time_max_source !< A time for use in testing internal tides real :: int_tide_source_x !< X Location of generation site - !! for internal tide for testing (BDM) - !! for internal tide for testing (BDM) + !! for internal tide for testing [degrees_E] or [km] real :: int_tide_source_y !< Y Location of generation site - !! for internal tide for testing (BDM) + !! for internal tide for testing [degrees_N] or [km] integer :: int_tide_source_i !< I Location of generation site integer :: int_tide_source_j !< J Location of generation site logical :: int_tide_use_glob_ij !< Use global indices for generation site + integer :: nFreq = 0 !< The number of internal tide frequency bands !>@{ Diagnostic IDs - integer :: id_TKE_itidal_itide = -1, id_Nb = -1, id_N2_bot = -1 + integer, allocatable, dimension(:) :: id_TKE_itidal_itide + integer :: id_Nb = -1, id_N2_bot = -1 !>@} end type int_tide_input_CS !> This type is used to exchange fields related to the internal tides. type, public :: int_tide_input_type real, allocatable, dimension(:,:) :: & - TKE_itidal_input, & !< The internal tide TKE input at the bottom of the ocean [R Z3 T-3 ~> W m-2]. h2, & !< The squared topographic roughness height [Z2 ~> m2]. - tideamp, & !< The amplitude of the tidal velocities [Z T-1 ~> m s-1]. - Nb !< The bottom stratification [T-1 ~> s-1]. + Nb, & !< The bottom stratification [T-1 ~> s-1]. + Rho_bot !< The bottom density or the Boussinesq reference density [R ~> kg m-3]. end type int_tide_input_type contains @@ -91,20 +102,33 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) !! to the internal tide sources. real, intent(in) :: dt !< The time increment [T ~> s]. type(int_tide_input_CS), pointer :: CS !< This module's control structure. + ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & N2_bot ! The bottom squared buoyancy frequency [T-2 ~> s-2]. + real, dimension(SZI_(G),SZJ_(G)) :: & + Rho_bot, & ! The average near-bottom density or the Boussinesq reference density [R ~> kg m-3]. + h_bot ! Bottom boundary layer thickness [H ~> m or kg m-2]. + integer, dimension(SZI_(G),SZJ_(G)) :: k_bot ! Bottom boundary layer top layer index. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & - T_f, S_f ! The temperature and salinity in [degC] and [ppt] with the values in + T_f, S_f ! The temperature and salinity in [C ~> degC] and [S ~> ppt] with the values in ! the massless layers filled vertically by diffusion. logical :: use_EOS ! If true, density is calculated from T & S using an ! equation of state. logical :: avg_enabled ! for testing internal tides (BDM) type(time_type) :: time_end !< For use in testing internal tides (BDM) + real :: HZ2_T3_to_W_m2 ! unit conversion factor for TKE from internal units + ! to mks [T3 kg H-1 Z-2 s-3 ~> kg m-3 or 1] + real :: W_m2_to_HZ2_T3 ! unit conversion factor for TKE from mks to internal + ! units [H Z2 s3 T-3 kg-1 ~> m3 kg-1 or 1] - integer :: i, j, k, is, ie, js, je, nz, isd, ied, jsd, jed + integer :: i, j, is, ie, js, je, nz, isd, ied, jsd, jed integer :: i_global, j_global + integer :: fr + + HZ2_T3_to_W_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**3) + W_m2_to_HZ2_T3 = GV%kg_m2_to_H*(US%m_to_Z**2)*(US%T_to_s**3) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -119,51 +143,65 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) ! Smooth the properties through massless layers. if (use_EOS) then - call vert_fill_TS(h, tv%T, tv%S, CS%kappa_fill*dt, T_f, S_f, G, GV, larger_h_denom=.true.) + call vert_fill_TS(h, tv%T, tv%S, CS%kappa_fill*dt, T_f, S_f, G, GV, US, larger_h_denom=.true.) endif - call find_N2_bottom(h, tv, T_f, S_f, itide%h2, fluxes, G, GV, US, N2_bot) + call find_N2_bottom(G, GV, US, tv, fluxes, h, T_f, S_f, itide%h2, N2_bot, Rho_bot, h_bot, k_bot) avg_enabled = query_averaging_enabled(CS%diag, time_end=time_end) - !$OMP parallel do default(shared) - do j=js,je ; do i=is,ie - itide%Nb(i,j) = G%mask2dT(i,j) * sqrt(N2_bot(i,j)) - itide%TKE_itidal_input(i,j) = min(CS%TKE_itidal_coef(i,j)*itide%Nb(i,j), CS%TKE_itide_max) - enddo ; enddo + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + !$OMP parallel do default(shared) + do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie + itide%Nb(i,j) = G%mask2dT(i,j) * sqrt(N2_bot(i,j)) + CS%TKE_itidal_input(i,j,fr) = min(GV%RZ_to_H*GV%Z_to_H*CS%TKE_itidal_coef(i,j,fr)*itide%Nb(i,j), & + CS%TKE_itide_maxi) + enddo ; enddo ; enddo + else + !$OMP parallel do default(shared) + do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie + itide%Nb(i,j) = G%mask2dT(i,j) * sqrt(N2_bot(i,j)) + itide%Rho_bot(i,j) = G%mask2dT(i,j) * Rho_bot(i,j) + CS%TKE_itidal_input(i,j,fr) = min((GV%RZ_to_H*GV%RZ_to_H*Rho_bot(i,j))*CS%TKE_itidal_coef(i,j,fr)*itide%Nb(i,j), & + CS%TKE_itide_maxi) + enddo ; enddo ; enddo + endif if (CS%int_tide_source_test) then - itide%TKE_itidal_input(:,:) = 0.0 + CS%TKE_itidal_input(:,:,:) = 0.0 if (time_end <= CS%time_max_source) then if (CS%int_tide_use_glob_ij) then - do j=js,je ; do i=is,ie + do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie i_global = i + G%idg_offset j_global = j + G%jdg_offset if ((i_global == CS%int_tide_source_i) .and. (j_global == CS%int_tide_source_j)) then - itide%TKE_itidal_input(i,j) = 1.0*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3 + CS%TKE_itidal_input(i,j,fr) = 1.0*W_m2_to_HZ2_T3 endif - enddo ; enddo + enddo ; enddo ; enddo else - do j=js,je ; do i=is,ie + do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie ! Input an arbitrary energy point source.id_ if (((G%geoLonCu(I-1,j)-CS%int_tide_source_x) * (G%geoLonBu(I,j)-CS%int_tide_source_x) <= 0.0) .and. & ((G%geoLatCv(i,J-1)-CS%int_tide_source_y) * (G%geoLatCv(i,j)-CS%int_tide_source_y) <= 0.0)) then - itide%TKE_itidal_input(i,j) = 1.0*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3 + CS%TKE_itidal_input(i,j,fr) = 1.0*W_m2_to_HZ2_T3 endif - enddo ; enddo + enddo ; enddo ; enddo endif endif endif if (CS%debug) then - call hchksum(N2_bot,"N2_bot",G%HI,haloshift=0, scale=US%s_to_T**2) - call hchksum(itide%TKE_itidal_input,"TKE_itidal_input",G%HI,haloshift=0, & - scale=US%RZ3_T3_to_W_m2) + call hchksum(N2_bot, "N2_bot", G%HI, haloshift=0, unscale=US%s_to_T**2) + call hchksum(CS%TKE_itidal_input,"TKE_itidal_input", G%HI, haloshift=0, & + unscale=HZ2_T3_to_W_m2) endif call enable_averages(dt, time_end, CS%diag) - if (CS%id_TKE_itidal_itide > 0) call post_data(CS%id_TKE_itidal_itide, itide%TKE_itidal_input, CS%diag) + do fr=1,CS%nFreq + if (CS%id_TKE_itidal_itide(fr) > 0) call post_data(CS%id_TKE_itidal_itide(fr), & + CS%TKE_itidal_input(isd:ied,jsd:jed,fr), CS%diag) + enddo if (CS%id_Nb > 0) call post_data(CS%id_Nb, itide%Nb, CS%diag) if (CS%id_N2_bot > 0 ) call post_data(CS%id_N2_bot, N2_bot, CS%diag) @@ -172,71 +210,80 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) end subroutine set_int_tide_input !> Estimates the near-bottom buoyancy frequency (N^2). -subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) +subroutine find_N2_bottom(G, GV, US, tv, fluxes, h, T_f, S_f, h2, N2_bot, Rho_bot, h_bot, k_bot) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to the !! thermodynamic fields + type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: T_f !< Temperature after vertical filtering to - !! smooth out the values in thin layers [degC]. + !! smooth out the values in thin layers [C ~> degC]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: S_f !< Salinity after vertical filtering to - !! smooth out the values in thin layers [ppt]. + !! smooth out the values in thin layers [S ~> ppt]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h2 !< Bottom topographic roughness [Z2 ~> m2]. - type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes - type(int_tide_input_CS), pointer :: CS !< This module's control structure. - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: N2_bot !< The squared buoyancy freqency at the + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: N2_bot !< The squared buoyancy frequency at the !! ocean bottom [T-2 ~> s-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: Rho_bot !< The average density near the ocean + !! bottom [R ~> kg m-3] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_bot !< Bottom boundary layer thickness [H ~> m or kg m-2] + integer, dimension(SZI_(G),SZJ_(G)), intent(out) :: k_bot !< Bottom boundary layer top layer index + ! Local variables real, dimension(SZI_(G),SZK_(GV)+1) :: & + pres, & ! The pressure at each interface [R L2 T-2 ~> Pa]. dRho_int ! The unfiltered density differences across interfaces [R ~> kg m-3]. + real, dimension(SZI_(G),SZK_(GV)) :: dz ! Layer thicknesses in depth units [Z ~> m] real, dimension(SZI_(G)) :: & - pres, & ! The pressure at each interface [R L2 T-2 ~> Pa]. - Temp_int, & ! The temperature at each interface [degC]. - Salin_int, & ! The salinity at each interface [ppt]. + Temp_int, & ! The temperature at each interface [C ~> degC] + Salin_int, & ! The salinity at each interface [S ~> ppt] drho_bot, & ! The density difference at the bottom of a layer [R ~> kg m-3] h_amp, & ! The amplitude of topographic roughness [Z ~> m]. - hb, & ! The depth below a layer [Z ~> m]. - z_from_bot, & ! The height of a layer center above the bottom [Z ~> m]. - dRho_dT, & ! The partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] - dRho_dS ! The partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. - - real :: dz_int ! The thickness associated with an interface [Z ~> m]. - real :: G_Rho0 ! The gravitation acceleration divided by the Boussinesq - ! density [Z T-2 R-1 ~> m4 s-2 kg-1]. + hb, & ! The thickness of the water column below the midpoint of a layer [H ~> m or kg m-2] + z_from_bot, & ! The distance of a layer center from the bottom [Z ~> m] + dRho_dT, & ! The partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + dRho_dS ! The partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. + + real :: dz_int ! The vertical extent of water associated with an interface [Z ~> m] + real :: G_Rho0 ! The gravitational acceleration, sometimes divided by the Boussinesq + ! density [H T-2 R-1 ~> m4 s-2 kg-1 or m s-2]. logical :: do_i(SZI_(G)), do_any integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - G_Rho0 = (US%L_to_Z**2*GV%g_Earth) / GV%Rho0 + G_Rho0 = GV%g_Earth_Z_T2 / GV%H_to_RZ EOSdom(:) = EOS_domain(G%HI) ! Find the (limited) density jump across each interface. do i=is,ie dRho_int(i,1) = 0.0 ; dRho_int(i,nz+1) = 0.0 enddo -!$OMP parallel do default(none) shared(is,ie,js,je,nz,tv,fluxes,G,GV,US,h,T_f,S_f, & -!$OMP h2,N2_bot,G_Rho0,EOSdom) & -!$OMP private(pres,Temp_Int,Salin_Int,dRho_dT,dRho_dS, & -!$OMP hb,dRho_bot,z_from_bot,do_i,h_amp, & -!$OMP do_any,dz_int) & -!$OMP firstprivate(dRho_int) + + !$OMP parallel do default(none) shared(is,ie,js,je,nz,tv,fluxes,G,GV,US,h,T_f,S_f, & + !$OMP h2,N2_bot,Rho_bot,h_bot,k_bot,G_Rho0,EOSdom) & + !$OMP private(pres,Temp_Int,Salin_Int,dRho_dT,dRho_dS, & + !$OMP dz,hb,dRho_bot,z_from_bot,do_i,h_amp,do_any,dz_int) & + !$OMP firstprivate(dRho_int) do j=js,je + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + if (associated(tv%eqn_of_state)) then if (associated(fluxes%p_surf)) then - do i=is,ie ; pres(i) = fluxes%p_surf(i,j) ; enddo + do i=is,ie ; pres(i,1) = fluxes%p_surf(i,j) ; enddo else - do i=is,ie ; pres(i) = 0.0 ; enddo + do i=is,ie ; pres(i,1) = 0.0 ; enddo endif do K=2,nz do i=is,ie - pres(i) = pres(i) + (GV%g_Earth*GV%H_to_RZ)*h(i,j,k-1) + pres(i,K) = pres(i,K-1) + (GV%g_Earth*GV%H_to_RZ)*h(i,j,k-1) Temp_Int(i) = 0.5 * (T_f(i,j,k) + T_f(i,j,k-1)) Salin_Int(i) = 0.5 * (S_f(i,j,k) + S_f(i,j,k-1)) enddo - call calculate_density_derivs(Temp_int, Salin_int, pres, dRho_dT(:), dRho_dS(:), & + call calculate_density_derivs(Temp_int, Salin_int, pres(:,K), dRho_dT(:), dRho_dS(:), & tv%eqn_of_state, EOSdom) do i=is,ie dRho_int(i,K) = max(dRho_dT(i)*(T_f(i,j,k) - T_f(i,j,k-1)) + & @@ -252,24 +299,24 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) ! Find the bottom boundary layer stratification. do i=is,ie hb(i) = 0.0 ; dRho_bot(i) = 0.0 - z_from_bot(i) = 0.5*GV%H_to_Z*h(i,j,nz) - do_i(i) = (G%mask2dT(i,j) > 0.5) + z_from_bot(i) = 0.5*dz(i,nz) + do_i(i) = (G%mask2dT(i,j) > 0.0) h_amp(i) = sqrt(h2(i,j)) enddo do k=nz,2,-1 do_any = .false. do i=is,ie ; if (do_i(i)) then - dz_int = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j,k-1)) + dz_int = 0.5*(dz(i,k) + dz(i,k-1)) z_from_bot(i) = z_from_bot(i) + dz_int ! middle of the layer above - hb(i) = hb(i) + dz_int + hb(i) = hb(i) + 0.5*(h(i,j,k) + h(i,j,k-1)) dRho_bot(i) = dRho_bot(i) + dRho_int(i,K) if (z_from_bot(i) > h_amp(i)) then if (k>2) then ! Always include at least one full layer. - hb(i) = hb(i) + 0.5*GV%H_to_Z*(h(i,j,k-1) + h(i,j,k-2)) + hb(i) = hb(i) + 0.5*(h(i,j,k-1) + h(i,j,k-2)) dRho_bot(i) = dRho_bot(i) + dRho_int(i,K-1) endif do_i(i) = .false. @@ -285,10 +332,52 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) N2_bot(i,j) = (G_Rho0 * dRho_bot(i)) / hb(i) else ; N2_bot(i,j) = 0.0 ; endif enddo + + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do i=is,ie + rho_bot(i,j) = GV%Rho0 + enddo + else + ! Average the density over the envelope of the topography. + call find_rho_bottom(G, GV, US, tv, h, dz, pres, h_amp, j, Rho_bot(:,j), h_bot(:,j), k_bot(:,j)) + endif enddo end subroutine find_N2_bottom +!> Returns TKE_itidal_input +subroutine get_input_TKE(G, TKE_itidal_input, nFreq, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). + integer, intent(in) :: nFreq !< number of frequencies + real, dimension(SZI_(G),SZJ_(G),nFreq), & + intent(out) :: TKE_itidal_input !< The energy input to the internal waves + !! [H Z2 T-3 ~> m3 s-3 or W m-2]. + type(int_tide_input_CS), target :: CS !< A pointer that is set to point to the control + !! structure for the internal tide input module. + integer :: i,j,fr + + do fr=1,nFreq ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + TKE_itidal_input(i,j,fr) = CS%TKE_itidal_input(i,j,fr) + enddo ; enddo ; enddo + +end subroutine get_input_TKE + +!> Returns barotropic tidal velocities +subroutine get_barotropic_tidal_vel(G, vel_btTide, nFreq, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). + integer, intent(in) :: nFreq !< number of frequencies + real, dimension(SZI_(G),SZJ_(G),nFreq), & + intent(out) :: vel_btTide !< Barotropic velocity read from file [L T-1 ~> m s-1]. + type(int_tide_input_CS), target :: CS !< A pointer that is set to point to the control + !! structure for the internal tide input module. + integer :: i,j,fr + + do fr=1,nFreq ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + vel_btTide(i,j,fr) = CS%tideamp(i,j,fr) + enddo ; enddo ; enddo + +end subroutine get_barotropic_tidal_vel + !> Initializes the data related to the internal tide input module subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) type(time_type), intent(in) :: Time !< The current model time @@ -301,13 +390,15 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) type(int_tide_input_type), pointer :: itide !< A structure containing fields related !! to the internal tide sources. ! Local variables - type(vardesc) :: vd logical :: read_tideamp ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_int_tide_input" ! This module's name. - character(len=20) :: tmpstr - character(len=200) :: filename, tideamp_file, h2_file + character(len=200) :: filename, tideamp_file, h2_file ! Input file names or paths + character(len=80) :: tideamp_var, rough_var ! Input file variable names + character(len=80) :: var_name + character(len=200) :: var_descript + character(len=200) :: tidefile_varnames real :: mask_itidal ! A multiplicative land mask, 0 or 1 [nondim] real :: max_frac_rough ! The fraction relating the maximum topographic roughness @@ -317,9 +408,14 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) real :: kappa_h2_factor ! factor for the product of wavenumber * rms sgs height [nondim]. real :: kappa_itides ! topographic wavenumber and non-dimensional scaling [L-1 ~> m-1] real :: min_zbot_itides ! Minimum ocean depth for internal tide conversion [Z ~> m]. + real :: HZ2_T3_to_W_m2 ! unit conversion factor for TKE from internal units + ! to mks [T3 kg H-1 Z-2 s-3 ~> kg m-3 or 1] + real :: W_m2_to_HZ2_T3 ! unit conversion factor for TKE from mks to internal + ! units [H Z2 s3 T-3 kg-1 ~> m3 kg-1 or 1] integer :: tlen_days !< Time interval from start for adding wave source !! for testing internal tides (BDM) integer :: i, j, is, ie, js, je, isd, ied, jsd, jed + integer :: num_freq, fr if (associated(CS)) then call MOM_error(WARNING, "int_tide_input_init called with an associated "// & @@ -341,6 +437,9 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) CS%diag => diag + HZ2_T3_to_W_m2 = GV%H_to_kg_m2*(US%Z_to_m**2)*(US%s_to_T**3) + W_m2_to_HZ2_T3 = GV%kg_m2_to_H*(US%m_to_Z**2)*(US%T_to_s**3) + ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") @@ -355,17 +454,21 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_fill, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & - units="m2 s-1", default=1.0e-6, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=1.0e-6, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "UTIDE", utide, & "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & units="m s-1", default=0.0, scale=US%m_s_to_L_T) + call read_param(param_file, "INTERNAL_TIDE_FREQS", num_freq) + CS%nFreq= num_freq + allocate(itide%Nb(isd:ied,jsd:jed), source=0.0) + allocate(itide%Rho_bot(isd:ied,jsd:jed), source=0.0) allocate(itide%h2(isd:ied,jsd:jed), source=0.0) - allocate(itide%TKE_itidal_input(isd:ied,jsd:jed), source=0.0) - allocate(itide%tideamp(isd:ied,jsd:jed), source=utide) - allocate(CS%TKE_itidal_coef(isd:ied,jsd:jed), source=0.0) + allocate(CS%TKE_itidal_input(isd:ied,jsd:jed,num_freq), source=0.0) + allocate(CS%tideamp(isd:ied,jsd:jed,num_freq), source=utide) + allocate(CS%TKE_itidal_coef(isd:ied,jsd:jed, num_freq), source=0.0) call get_param(param_file, mdl, "KAPPA_ITIDES", kappa_itides, & "A topographic wavenumber used with INT_TIDE_DISSIPATION. "//& @@ -375,10 +478,10 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) call get_param(param_file, mdl, "KAPPA_H2_FACTOR", kappa_h2_factor, & "A scaling factor for the roughness amplitude with "//& "INT_TIDE_DISSIPATION.", units="nondim", default=1.0) - call get_param(param_file, mdl, "TKE_ITIDE_MAX", CS%TKE_itide_max, & + call get_param(param_file, mdl, "TKE_ITIDE_MAX", CS%TKE_itide_maxi, & "The maximum internal tide energy source available to mix "//& "above the bottom boundary layer with INT_TIDE_DISSIPATION.", & - units="W m-2", default=1.0e3, scale=US%W_m2_to_RZ3_T3) + units="W m-2", default=1.0e3, scale=W_m2_to_HZ2_T3) call get_param(param_file, mdl, "READ_TIDEAMP", read_tideamp, & "If true, read a file (given by TIDEAMP_FILE) containing "//& @@ -389,7 +492,13 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) "tidal amplitudes with INT_TIDE_DISSIPATION.", default="tideamp.nc") filename = trim(CS%inputdir) // trim(tideamp_file) call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) - call MOM_read_data(filename, 'tideamp', itide%tideamp, G%domain, scale=US%m_s_to_L_T) + + call read_param(param_file, "INTTIDE_AMP_VARNAMES", tidefile_varnames) + do fr=1,num_freq + tideamp_var = extractWord(tidefile_varnames,fr) + call MOM_read_data(filename, tideamp_var, CS%tideamp(:,:,fr), G%domain, scale=US%m_s_to_L_T) + enddo + endif call get_param(param_file, mdl, "H2_FILE", h2_file, & @@ -398,7 +507,10 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) fail_if_missing=.true.) filename = trim(CS%inputdir) // trim(h2_file) call log_param(param_file, mdl, "INPUTDIR/H2_FILE", filename) - call MOM_read_data(filename, 'h2', itide%h2, G%domain, scale=US%m_to_Z**2) + call get_param(param_file, mdl, "ROUGHNESS_VARNAME", rough_var, & + "The name in the input file of the squared sub-grid-scale "//& + "topographic roughness amplitude variable.", default="h2") + call MOM_read_data(filename, rough_var, itide%h2, G%domain, scale=US%m_to_Z**2) call get_param(param_file, mdl, "FRACTIONAL_ROUGHNESS_MAX", max_frac_rough, & "The maximum topographic roughness amplitude as a fraction of the mean depth, "//& @@ -411,13 +523,13 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) default=.false.) if (CS%int_tide_source_test)then call get_param(param_file, mdl, "INTERNAL_TIDE_USE_GLOB_IJ", CS%int_tide_use_glob_ij, & - "Use global IJ for interal tide generation source test", default=.false.) + "Use global IJ for internal tide generation source test", default=.false.) call get_param(param_file, mdl, "INTERNAL_TIDE_SOURCE_X", CS%int_tide_source_x, & - "X Location of generation site for internal tide", default=1., & - do_not_log=CS%int_tide_use_glob_ij) + "X Location of generation site for internal tide", & + units=G%x_ax_unit_short, default=1.0, do_not_log=CS%int_tide_use_glob_ij) call get_param(param_file, mdl, "INTERNAL_TIDE_SOURCE_Y", CS%int_tide_source_y, & - "Y Location of generation site for internal tide", default=1., & - do_not_log=CS%int_tide_use_glob_ij) + "Y Location of generation site for internal tide", & + units=G%y_ax_unit_short, default=1.0, do_not_log=CS%int_tide_use_glob_ij) call get_param(param_file, mdl, "INTERNAL_TIDE_SOURCE_I", CS%int_tide_source_i, & "I Location of generation site for internal tide", default=0, & do_not_log=.not.CS%int_tide_use_glob_ij) @@ -439,25 +551,31 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) endif endif - do j=js,je ; do i=is,ie + do fr=1,num_freq ; do j=js,je ; do i=is,ie mask_itidal = 1.0 - if (G%bathyT(i,j) + G%Z_ref < min_zbot_itides) mask_itidal = 0.0 + if (G%meanSL(i,j) + G%bathyT(i,j) < min_zbot_itides) mask_itidal = 0.0 - itide%tideamp(i,j) = itide%tideamp(i,j) * mask_itidal * G%mask2dT(i,j) + CS%tideamp(i,j,fr) = CS%tideamp(i,j,fr) * mask_itidal * G%mask2dT(i,j) ! Restrict rms topo to a fraction (often 10 percent) of the column depth. if (max_frac_rough >= 0.0) & - itide%h2(i,j) = min((max_frac_rough*(G%bathyT(i,j)+G%Z_ref))**2, itide%h2(i,j)) + itide%h2(i,j) = min((max_frac_rough * max(G%meanSL(i,j) + G%bathyT(i,j), 0.0))**2, itide%h2(i,j)) - ! Compute the fixed part of internal tidal forcing; units are [R Z3 T-2 ~> J m-2] here. - CS%TKE_itidal_coef(i,j) = 0.5*US%L_to_Z*kappa_h2_factor*GV%Rho0*& - kappa_itides * itide%h2(i,j) * itide%tideamp(i,j)**2 - enddo ; enddo + ! Compute the fixed part of internal tidal forcing; units are [R Z4 H-1 T-2 ~> J m-2 or J m kg-1] here. + CS%TKE_itidal_coef(i,j,fr) = 0.5*US%L_to_Z*kappa_h2_factor * GV%H_to_RZ * & + kappa_itides * itide%h2(i,j) * CS%tideamp(i,j,fr)**2 + enddo ; enddo ; enddo - CS%id_TKE_itidal_itide = register_diag_field('ocean_model','TKE_itidal_itide',diag%axesT1,Time, & - 'Internal Tide Driven Turbulent Kinetic Energy', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + allocate( CS%id_TKE_itidal_itide(num_freq), source=-1) + + do fr=1,num_freq + write(var_name, '("TKE_itidal_itide_freq",i1)') fr + write(var_descript, '("Internal Tide Driven Turbulent Kinetic Energy in frequency ",i1)') fr + + CS%id_TKE_itidal_itide(fr) = register_diag_field('ocean_model',var_name,diag%axesT1,Time, & + var_descript, 'W m-2', conversion=HZ2_T3_to_W_m2) + enddo CS%id_Nb = register_diag_field('ocean_model','Nb_itide',diag%axesT1,Time, & 'Bottom Buoyancy Frequency', 's-1', conversion=US%s_to_T) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index a44a7aee95..0dbd34c88c 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -1,20 +1,24 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Shear-dependent mixing following Jackson et al. 2008. module MOM_kappa_shear -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end -use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE -use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr -use MOM_diag_mediator, only : diag_ctrl, time_type -use MOM_debugging, only : hchksum, Bchksum -use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_grid, only : ocean_grid_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density_derivs +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr +use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_debugging, only : hchksum, Bchksum +use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density_derivs +use MOM_EOS, only : calculate_density, calculate_specific_vol_derivs implicit none ; private @@ -52,9 +56,17 @@ module MOM_kappa_shear real :: lambda2_N_S !< The square of the ratio of the coefficients of !! the buoyancy and shear scales in the diffusivity !! equation, 0 to eliminate the shear scale [nondim]. + real :: lz_rescale !< A coefficient to rescale the distance to the nearest + !! solid boundary. This adjustment is to account for + !! regions where 3 dimensional turbulence prevents the + !! growth of shear instabilities [nondim]. real :: TKE_bg !< The background level of TKE [Z2 T-2 ~> m2 s-2]. - real :: kappa_0 !< The background diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. - real :: kappa_trunc !< Diffusivities smaller than this are rounded to 0 [Z2 T-1 ~> m2 s-1]. + real :: kappa_0 !< The background diapycnal diffusivity [H Z T-1 ~> m2 s-1 or Pa s] + real :: kappa_seed !< A moderately large seed value of diapycnal diffusivity that + !! is used as a starting turbulent diffusivity in the iterations + !! to finding an energetically constrained solution for the + !! shear-driven diffusivity [H Z T-1 ~> m2 s-1 or Pa s] + real :: kappa_trunc !< Diffusivities smaller than this are rounded to 0 [H Z T-1 ~> m2 s-1 or Pa s] real :: kappa_tol_err !< The fractional error in kappa that is tolerated [nondim]. real :: Prandtl_turb !< Prandtl number used to convert Kd_shear into viscosity [nondim]. integer :: nkml !< The number of layers in the mixed layer, as @@ -67,7 +79,7 @@ module MOM_kappa_shear !! to estimate the time-averaged diffusivity. logical :: dKdQ_iteration_bug !< If true. use an older, dimensionally inconsistent estimate of !! the derivative of diffusivity with energy in the Newton's method - !! iteration. The bug causes undercorrections when dz > 1m. + !! iteration. The bug causes under-corrections when dz > 1m. logical :: KS_at_vertex !< If true, do the calculations of the shear-driven mixing !! at the cell vertices (i.e., the vorticity points). logical :: eliminate_massless !< If true, massless layers are merged with neighboring @@ -80,6 +92,10 @@ module MOM_kappa_shear !! greater than 1. The lower limit for the permitted fractional !! decrease is (1 - 0.5/kappa_src_max_chg). These limits could !! perhaps be made dynamic with an improved iterative solver. + real :: VS_GeoMean_Kdmin !< A minimum diffusivity for computing the horizontal averages + !! when using the geometric mean with VERTEX_SHEAR=True. The model + !! is sensitive to this value, which is a drawback of using the + !! geometric average as currently implemented. logical :: psurf_bug !< If true, do a simple average of the cell surface pressures to get a !! surface pressure at the corner if VERTEX_SHEAR=True. Otherwise mask !! out any land points in the average. @@ -87,6 +103,15 @@ module MOM_kappa_shear !! time average TKE when there is mass in all layers. Otherwise always !! report the time-averaged TKE, as is currently done when there !! are some massless layers. + logical :: VS_viscosity_bug !< If true, use a bug in the calculation of the viscosity that sets + !! it to zero for all vertices that are on a coastline. + logical :: vertex_shear_OBC_bug !< If false, use extra masking when interpolating thicknesses to velocity + !! points for setting up the shear velocities at vertices to avoid using + !! external thicknesses at open boundaries. When OBCs are not in use, + !! this parameter does not change answers, but true is more efficient. + logical :: VS_GeometricMean !< If true use geometric averaging for Kd from vertices to tracer points + logical :: VS_ThicknessMean !< If true use thickness weighting when averaging Kd from vertices to + !! tracer points logical :: restrictive_tolerance_check !< If false, uses the less restrictive tolerance check to !! determine if a timestep is acceptable for the KS_it outer iteration !! loop, as the code was originally written. True uses the more @@ -97,7 +122,8 @@ module MOM_kappa_shear type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. !>@{ Diagnostic IDs - integer :: id_Kd_shear = -1, id_TKE = -1, id_ILd2 = -1, id_dz_Int = -1 + integer :: id_Kd_shear = -1, id_TKE = -1, id_Kd_vertex = -1, & + id_S2_init = -1, id_N2_init = -1, id_S2_mean = -1, id_N2_mean = -1 !>@} end type Kappa_shear_CS @@ -123,15 +149,15 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] (or NULL). real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(inout) :: kappa_io !< The diapycnal diffusivity at each interface - !! (not layer!) [Z2 T-1 ~> m2 s-1]. Initially this is the - !! value from the previous timestep, which may + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. Initially this + !! is the value from the previous timestep, which may !! accelerate the iteration toward convergence. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(out) :: tke_io !< The turbulent kinetic energy per unit mass at !! each interface (not layer!) [Z2 T-2 ~> m2 s-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(inout) :: kv_io !< The vertical viscosity at each interface - !! (not layer!) [Z2 T-1 ~> m2 s-1]. This discards any + !! (not layer!) [H Z T-1 ~> m2 s-1 or Pa s]. This discards any !! previous value (i.e. it is intent out) and !! simply sets Kv = Prandtl * Kd_shear real, intent(in) :: dt !< Time increment [T ~> s]. @@ -139,31 +165,44 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & !! call to kappa_shear_init. ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & + diag_N2_init, & ! Diagnostic of N2 as provided to this routine [T-2 ~> s-2] + diag_S2_init, & ! Diagnostic of S2 as provided to this routine [T-2 ~> s-2] + diag_N2_mean, & ! Diagnostic of N2 averaged over the timestep applied [T-2 ~> s-2] + diag_S2_mean ! Diagnostic of S2 averaged over the timestep applied [T-2 ~> s-2] real, dimension(SZI_(G),SZK_(GV)) :: & - h_2d, & ! A 2-D version of h, but converted to [Z ~> m]. + h_2d, & ! A 2-D version of h [H ~> m or kg m-2]. + dz_2d, & ! Vertical distance between interface heights [Z ~> m]. u_2d, v_2d, & ! 2-D versions of u_in and v_in, converted to [L T-1 ~> m s-1]. - T_2d, S_2d, rho_2d ! 2-D versions of T [degC], S [ppt], and rho [R ~> kg m-3]. + T_2d, S_2d, rho_2d ! 2-D versions of T [C ~> degC], S [S ~> ppt], and rho [R ~> kg m-3]. real, dimension(SZI_(G),SZK_(GV)+1) :: & - kappa_2d, & ! 2-D version of kappa_io [Z2 T-1 ~> m2 s-1]. + kappa_2d, & ! 2-D version of kappa_io [H Z T-1 ~> m2 s-1 or Pa s] tke_2d ! 2-D version tke_io [Z2 T-2 ~> m2 s-2]. real, dimension(SZK_(GV)) :: & - Idz, & ! The inverse of the distance between TKE points [Z-1 ~> m-1]. - dz, & ! The layer thickness [Z ~> m]. - u0xdz, & ! The initial zonal velocity times dz [Z L T-1 ~> m2 s-1]. - v0xdz, & ! The initial meridional velocity times dz [Z L T-1 ~> m2 s-1]. - T0xdz, & ! The initial temperature times dz [degC Z ~> degC m]. - S0xdz ! The initial salinity times dz [ppt Z ~> ppt m]. + Idz, & ! The inverse of the thickness of the merged layers [H-1 ~> m2 kg-1]. + h_lay, & ! The layer thickness [H ~> m or kg m-2] + dz_lay, & ! The geometric layer thickness in height units [Z ~> m] + u0xdz, & ! The initial zonal velocity times dz [H L T-1 ~> m2 s-1 or kg m-1 s-1] + v0xdz, & ! The initial meridional velocity times dz [H L T-1 ~> m2 s-1 or kg m-1 s-1] + T0xdz, & ! The initial temperature times thickness [C H ~> degC m or degC kg m-2] or if + ! temperature is not a state variable, the density times thickness [R H ~> kg m-2 or kg2 m-5] + S0xdz ! The initial salinity times dz [S H ~> ppt m or ppt kg m-2]. real, dimension(SZK_(GV)+1) :: & - kappa, & ! The shear-driven diapycnal diffusivity at an interface [Z2 T-1 ~> m2 s-1]. + kappa, & ! The shear-driven diapycnal diffusivity at an interface [H Z T-1 ~> m2 s-1 or Pa s] tke, & ! The Turbulent Kinetic Energy per unit mass at an interface [Z2 T-2 ~> m2 s-2]. - kappa_avg, & ! The time-weighted average of kappa [Z2 T-1 ~> m2 s-1]. - tke_avg ! The time-weighted average of TKE [Z2 T-2 ~> m2 s-2]. - real :: f2 ! The squared Coriolis parameter of each column [T-2 ~> s-2]. + kappa_avg, & ! The time-weighted average of kappa [H Z T-1 ~> m2 s-1 or Pa s] + tke_avg, & ! The time-weighted average of TKE [Z2 T-2 ~> m2 s-2]. + N2_init, & ! N2 as provided to this routine [T-2 ~> s-2]. + S2_init, & ! S2 as provided to this routine [T-2 ~> s-2]. + N2_mean, & ! The time-weighted average of N2 [T-2 ~> s-2]. + S2_mean ! The time-weighted average of S2 [T-2 ~> s-2]. + + real :: f2 ! The squared Coriolis parameter of each column [T-2 ~> s-2]. real :: surface_pres ! The top surface pressure [R L2 T-2 ~> Pa]. - real :: dz_in_lay ! The running sum of the thickness in a layer [Z ~> m]. - real :: k0dt ! The background diffusivity times the timestep [Z2 ~> m2]. - real :: dz_massless ! A layer thickness that is considered massless [Z ~> m]. + real :: dz_in_lay ! The running sum of the thickness in a layer [H ~> m or kg m-2] + real :: k0dt ! The background diffusivity times the timestep [H Z ~> m2 or kg m-1] + real :: dz_massless ! A layer thickness that is considered massless [H ~> m or kg m-2] logical :: use_temperature ! If true, temperature and salinity have been ! allocated and are being used as state variables. @@ -174,18 +213,28 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & ! interpolating back to the original index space [nondim]. integer :: is, ie, js, je, i, j, k, nz, nzc - is = G%isc ; ie = G%iec; js = G%jsc ; je = G%jec ; nz = GV%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke use_temperature = associated(tv%T) k0dt = dt*CS%kappa_0 - dz_massless = 0.1*sqrt(k0dt) + dz_massless = 0.1*sqrt((US%Z_to_m*GV%m_to_H)*k0dt) + + if ((CS%id_N2_init>0) .or. CS%debug) diag_N2_init(:,:,:) = 0.0 + if ((CS%id_S2_init>0) .or. CS%debug) diag_S2_init(:,:,:) = 0.0 + if (CS%id_N2_mean>0) diag_N2_mean(:,:,:) = 0.0 + if (CS%id_S2_mean>0) diag_S2_mean(:,:,:) = 0.0 !$OMP parallel do default(private) shared(js,je,is,ie,nz,h,u_in,v_in,use_temperature,tv,G,GV,US, & - !$OMP CS,kappa_io,dz_massless,k0dt,p_surf,dt,tke_io,kv_io) + !$OMP CS,kappa_io,dz_massless,k0dt,p_surf,dt,tke_io,kv_io, & + !$OMP diag_N2_init,diag_S2_init,diag_N2_mean,diag_S2_mean) do j=js,je + + ! Convert layer thicknesses into geometric thickness in height units. + call thickness_to_dz(h, tv, dz_2d, j, G, GV) + do k=1,nz ; do i=is,ie - h_2d(i,k) = h(i,j,k)*GV%H_to_Z + h_2d(i,k) = h(i,j,k) u_2d(i,k) = u_in(i,j,k) ; v_2d(i,k) = v_in(i,j,k) enddo ; enddo if (use_temperature) then ; do k=1,nz ; do i=is,ie @@ -197,28 +246,30 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & !--------------------------------------- ! Work on each column. !--------------------------------------- - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then ! call cpu_clock_begin(id_clock_setup) + ! Store a transposed version of the initial arrays. ! Any elimination of massless layers would occur here. if (CS%eliminate_massless) then nzc = 1 do k=1,nz ! Zero out the thicknesses of all layers, even if they are unused. - dz(k) = 0.0 ; u0xdz(k) = 0.0 ; v0xdz(k) = 0.0 + h_lay(k) = 0.0 ; dz_lay(k) = 0.0 ; u0xdz(k) = 0.0 ; v0xdz(k) = 0.0 T0xdz(k) = 0.0 ; S0xdz(k) = 0.0 ! Add a new layer if this one has mass. -! if ((dz(nzc) > 0.0) .and. (h_2d(i,k) > dz_massless)) nzc = nzc+1 - if ((k>CS%nkml) .and. (dz(nzc) > 0.0) .and. & +! if ((h_lay(nzc) > 0.0) .and. (h_2d(i,k) > dz_massless)) nzc = nzc+1 + if ((k>CS%nkml) .and. (h_lay(nzc) > 0.0) .and. & (h_2d(i,k) > dz_massless)) nzc = nzc+1 ! Only merge clusters of massless layers. -! if ((dz(nzc) > dz_massless) .or. & -! ((dz(nzc) > 0.0) .and. (h_2d(i,k) > dz_massless))) nzc = nzc+1 +! if ((h_lay(nzc) > dz_massless) .or. & +! ((h_lay(nzc) > 0.0) .and. (h_2d(i,k) > dz_massless))) nzc = nzc+1 kc(k) = nzc - dz(nzc) = dz(nzc) + h_2d(i,k) + h_lay(nzc) = h_lay(nzc) + h_2d(i,k) + dz_lay(nzc) = dz_lay(nzc) + dz_2d(i,k) u0xdz(nzc) = u0xdz(nzc) + u_2d(i,k)*h_2d(i,k) v0xdz(nzc) = v0xdz(nzc) + v_2d(i,k)*h_2d(i,k) if (use_temperature) then @@ -232,7 +283,7 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & kc(nz+1) = nzc+1 ! Set up Idz as the inverse of layer thicknesses. - do k=1,nzc ; Idz(k) = 1.0 / dz(k) ; enddo + do k=1,nzc ; Idz(k) = 1.0 / h_lay(k) ; enddo ! Now determine kf, the fractional weight of interface kc when ! interpolating between interfaces kc and kc+1. @@ -247,34 +298,36 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & kf(nz+1) = 0.0 else do k=1,nz - dz(k) = h_2d(i,k) - u0xdz(k) = u_2d(i,k)*dz(k) ; v0xdz(k) = v_2d(i,k)*dz(k) + h_lay(k) = h_2d(i,k) + dz_lay(k) = dz_2d(i,k) + u0xdz(k) = u_2d(i,k)*h_lay(k) ; v0xdz(k) = v_2d(i,k)*h_lay(k) enddo if (use_temperature) then do k=1,nz - T0xdz(k) = T_2d(i,k)*dz(k) ; S0xdz(k) = S_2d(i,k)*dz(k) + T0xdz(k) = T_2d(i,k)*h_lay(k) ; S0xdz(k) = S_2d(i,k)*h_lay(k) enddo else do k=1,nz - T0xdz(k) = rho_2d(i,k)*dz(k) ; S0xdz(k) = rho_2d(i,k)*dz(k) + T0xdz(k) = rho_2d(i,k)*h_lay(k) ; S0xdz(k) = rho_2d(i,k)*h_lay(k) enddo endif nzc = nz do k=1,nzc+1 ; kc(k) = k ; kf(k) = 0.0 ; enddo endif - f2 = 0.25 * ((G%CoriolisBu(I,j)**2 + G%CoriolisBu(I-1,J-1)**2) + & - (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2)) + f2 = 0.25 * ((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + & + (G%Coriolis2Bu(I,J-1) + G%Coriolis2Bu(I-1,J))) surface_pres = 0.0 ; if (associated(p_surf)) surface_pres = p_surf(i,j) ! ---------------------------------------------------- I_Ld2_1d, dz_Int_1d ! Set the initial guess for kappa, here defined at interfaces. ! ---------------------------------------------------- - do K=1,nzc+1 ; kappa(K) = US%m2_s_to_Z2_T*1.0 ; enddo + do K=1,nzc+1 ; kappa(K) = CS%kappa_seed ; enddo call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & - dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & - tke_avg, tv, CS, GV, US) + h_lay, dz_lay, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & + tke_avg, N2_init, S2_init, N2_mean, S2_mean, & + tv, CS, GV, US) ! call cpu_clock_begin(id_clock_setup) ! Extrapolate from the vertically reduced grid back to the original layers. @@ -287,16 +340,43 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & tke_2d(i,K) = tke_avg(K) endif enddo + if (CS%id_N2_mean>0) then ; do K=1,nz+1 + diag_N2_mean(i,j,K) = N2_mean(K) + enddo ; endif + if (CS%id_S2_mean>0) then ; do K=1,nz+1 + diag_S2_mean(i,j,K) = S2_mean(K) + enddo ; endif + if ((CS%id_N2_init>0) .or. CS%debug) then ; do K=1,nz+1 + diag_N2_init(i,j,K) = N2_init(K) + enddo ; endif + if ((CS%id_S2_init>0) .or. CS%debug) then ; do K=1,nz+1 + diag_S2_init(i,j,K) = S2_init(K) + enddo ; endif else do K=1,nz+1 if (kf(K) == 0.0) then kappa_2d(i,K) = kappa_avg(kc(K)) tke_2d(i,K) = tke_avg(kc(K)) else - kappa_2d(i,K) = (1.0-kf(K)) * kappa_avg(kc(K)) + & - kf(K) * kappa_avg(kc(K)+1) - tke_2d(i,K) = (1.0-kf(K)) * tke_avg(kc(K)) + & - kf(K) * tke_avg(kc(K)+1) + kappa_2d(i,K) = (1.0-kf(K)) * kappa_avg(kc(K)) + kf(K) * kappa_avg(kc(K)+1) + tke_2d(i,K) = (1.0-kf(K)) * tke_avg(kc(K)) + kf(K) * tke_avg(kc(K)+1) + endif + enddo + do K=1,nz+1 + if (kf(K) == 0.0) then + if (CS%id_N2_mean>0) diag_N2_mean(i,j,K) = N2_mean(kc(K)) + if (CS%id_S2_mean>0) diag_S2_mean(i,j,K) = S2_mean(kc(K)) + if ((CS%id_N2_init>0) .or. CS%debug) diag_N2_init(i,j,K) = N2_init(kc(K)) + if ((CS%id_S2_init>0) .or. CS%debug) diag_S2_init(i,j,K) = S2_init(kc(K)) + else + if (CS%id_N2_mean>0) & + diag_N2_mean(i,j,K) = (1.0-kf(K)) * N2_mean(kc(K)) + kf(K) * N2_mean(kc(K)+1) + if (CS%id_S2_mean>0) & + diag_S2_mean(i,j,K) = (1.0-kf(K)) * S2_mean(kc(K)) + kf(K) * S2_mean(kc(K)+1) + if ((CS%id_N2_init>0) .or. CS%debug) & + diag_N2_init(i,j,K) = (1.0-kf(K)) * N2_init(kc(K)) + kf(K) * N2_init(kc(K)+1) + if ((CS%id_S2_init>0) .or. CS%debug) & + diag_S2_init(i,j,K) = (1.0-kf(K)) * S2_init(kc(K)) + kf(K) * S2_init(kc(K)+1) endif enddo endif @@ -311,17 +391,24 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & kappa_io(i,j,K) = G%mask2dT(i,j) * kappa_2d(i,K) tke_io(i,j,K) = G%mask2dT(i,j) * tke_2d(i,K) kv_io(i,j,K) = ( G%mask2dT(i,j) * kappa_2d(i,K) ) * CS%Prandtl_turb + enddo ; enddo enddo ! end of j-loop if (CS%debug) then - call hchksum(kappa_io, "kappa", G%HI, scale=US%Z2_T_to_m2_s) - call hchksum(tke_io, "tke", G%HI, scale=US%Z_to_m**2*US%s_to_T**2) + call hchksum(diag_N2_init, "kappa_shear N2_init", G%HI, unscale=US%s_to_T**2) + call hchksum(diag_S2_init, "kappa_shear S2_init", G%HI, unscale=US%s_to_T**2) + call hchksum(kappa_io, "kappa", G%HI, unscale=GV%HZ_T_to_m2_s) + call hchksum(tke_io, "tke", G%HI, unscale=US%Z_to_m**2*US%s_to_T**2) endif if (CS%id_Kd_shear > 0) call post_data(CS%id_Kd_shear, kappa_io, CS%diag) if (CS%id_TKE > 0) call post_data(CS%id_TKE, tke_io, CS%diag) + if (CS%id_N2_init > 0) call post_data(CS%id_N2_init, diag_N2_init, CS%diag) + if (CS%id_S2_init > 0) call post_data(CS%id_S2_init, diag_S2_init, CS%diag) + if (CS%id_N2_mean > 0) call post_data(CS%id_N2_mean, diag_N2_mean, CS%diag) + if (CS%id_S2_mean > 0) call post_data(CS%id_S2_mean, diag_S2_mean, CS%diag) end subroutine Calculate_kappa_shear @@ -339,9 +426,9 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: T_in !< Layer potential temperatures [degC] + intent(in) :: T_in !< Layer potential temperatures [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: S_in !< Layer salinities in ppt. + intent(in) :: S_in !< Layer salinities [S ~> ppt] type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any !! available thermodynamic fields. Absent fields !! have NULL ptrs. @@ -349,103 +436,172 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ !! (or NULL). real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(out) :: kappa_io !< The diapycnal diffusivity at each interface - !! (not layer!) [Z2 T-1 ~> m2 s-1]. + !! (not layer!) [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)+1), & intent(out) :: tke_io !< The turbulent kinetic energy per unit mass at !! each interface (not layer!) [Z2 T-2 ~> m2 s-2]. real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)+1), & - intent(inout) :: kv_io !< The vertical viscosity at each interface [Z2 T-1 ~> m2 s-1]. + intent(inout) :: kv_io !< The vertical viscosity at each interface + !! [H Z T-1 ~> m2 s-1 or Pa s]. !! The previous value is used to initialize kappa - !! in the vertex columes as Kappa = Kv/Prandtl - !! to accelerate the iteration toward covergence. + !! in the vertex columns as Kappa = Kv/Prandtl + !! to accelerate the iteration toward convergence. real, intent(in) :: dt !< Time increment [T ~> s]. type(Kappa_shear_CS), pointer :: CS !< The control structure returned by a previous !! call to kappa_shear_init. ! Local variables + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)+1) :: & + diag_N2_init, & ! Diagnostic of N2 as provided to this routine [T-2 ~> s-2] + diag_S2_init, & ! Diagnostic of S2 as provided to this routine [T-2 ~> s-2] + diag_N2_mean, & ! Diagnostic of N2 averaged over the timestep applied [T-2 ~> s-2] + diag_S2_mean ! Diagnostic of S2 averaged over the timestep applied [T-2 ~> s-2] + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + dz_3d ! Vertical distance between interface heights [Z ~> m]. + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)+1) :: & + kappa_vertex ! Diffusivity at interfaces and vertices [H Z T-1 ~> m2 s-1 or Pa s] + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)) :: & + h_vert ! Thicknesses interpolated to vertices [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & + h_at_u ! A mask-weighted thickness interpolated to u-points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & + h_at_v ! A mask-weighted thickness interpolated to v-points [H ~> m or kg m-2] real, dimension(SZIB_(G),SZK_(GV)) :: & - h_2d, & ! A 2-D version of h, but converted to [Z ~> m]. + h_2d, & ! A 2-D version of h interpolated to vertices [H ~> m or kg m-2]. + dz_2d, & ! Vertical distance between interface heights [Z ~> m]. u_2d, v_2d, & ! 2-D versions of u_in and v_in, converted to [L T-1 ~> m s-1]. - T_2d, S_2d, rho_2d ! 2-D versions of T [degC], S [ppt], and rho [R ~> kg m-3]. - real, dimension(SZIB_(G),SZK_(GV)+1,2) :: & - kappa_2d ! Quasi 2-D versions of kappa_io [Z2 T-1 ~> m2 s-1]. + T_2d, S_2d, rho_2d ! 2-D versions of T [C ~> degC], S [S ~> ppt], and rho [R ~> kg m-3]. + real, dimension(SZIB_(G),SZK_(GV)+1) :: & + kappa_2d ! 2-D slice of kappa_vert [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZIB_(G),SZK_(GV)+1) :: & tke_2d ! 2-D version tke_io [Z2 T-2 ~> m2 s-2]. real, dimension(SZK_(GV)) :: & - Idz, & ! The inverse of the distance between TKE points [Z-1 ~> m-1]. - dz, & ! The layer thickness [Z ~> m]. - u0xdz, & ! The initial zonal velocity times dz [L Z T-1 ~> m2 s-1]. - v0xdz, & ! The initial meridional velocity times dz [L Z T-1 ~> m2 s-1]. - T0xdz, & ! The initial temperature times dz [degC Z ~> degC m]. - S0xdz ! The initial salinity times dz [ppt Z ~> ppt m]. + Idz, & ! The inverse of the thickness of the merged layers [H-1 ~> m2 kg-1]. + h_lay, & ! The layer thickness [H ~> m or kg m-2] + dz_lay, & ! The geometric layer thickness in height units [Z ~> m] + u0xdz, & ! The initial zonal velocity times dz [L H T-1 ~> m2 s-1 or kg m-1 s-1]. + v0xdz, & ! The initial meridional velocity times dz [H L T-1 ~> m2 s-1 or kg m-1 s-1] + T0xdz, & ! The initial temperature times dz [C H ~> degC m or degC kg m-2] + S0xdz ! The initial salinity times dz [S H ~> ppt m or ppt kg m-2] real, dimension(SZK_(GV)+1) :: & - kappa, & ! The shear-driven diapycnal diffusivity at an interface [Z2 T-1 ~> m2 s-1]. + kappa, & ! The shear-driven diapycnal diffusivity at an interface [H Z T-1 ~> m2 s-1 or Pa s] tke, & ! The Turbulent Kinetic Energy per unit mass at an interface [Z2 T-2 ~> m2 s-2]. - kappa_avg, & ! The time-weighted average of kappa [Z2 T-1 ~> m2 s-1]. - tke_avg ! The time-weighted average of TKE [Z2 T-2 ~> m2 s-2]. + kappa_avg, & ! The time-weighted average of kappa [H Z T-1 ~> m2 s-1 or Pa s] + tke_avg, & ! The time-weighted average of TKE [Z2 T-2 ~> m2 s-2]. + N2_init, & ! N2 as provided to this routine [T-2 ~> s-2]. + S2_init, & ! S2 as provided to this routine [T-2 ~> s-2]. + N2_mean, & ! The time-weighted average of N2 [T-2 ~> s-2]. + S2_mean ! The time-weighted average of S2 [T-2 ~> s-2]. + real :: f2 ! The squared Coriolis parameter of each column [T-2 ~> s-2]. real :: surface_pres ! The top surface pressure [R L2 T-2 ~> Pa]. - real :: dz_in_lay ! The running sum of the thickness in a layer [Z ~> m]. - real :: k0dt ! The background diffusivity times the timestep [Z2 ~> m2]. - real :: dz_massless ! A layer thickness that is considered massless [Z ~> m]. - real :: I_hwt ! The inverse of the masked thickness weights [H-1 ~> m-1 or m2 kg-1]. + real :: dz_in_lay ! The running sum of the thickness in a layer [H ~> m or kg m-2] + real :: k0dt ! The background diffusivity times the timestep [H Z ~> m2 or kg m-1] + real :: dz_massless ! A layer thickness that is considered massless [H ~> m or kg m-2] + real :: I_hwt ! The inverse of the sum of the adjacent masked thickness weights [H-1 ~> m-1 or m2 kg-1] + real :: I_htot ! The inverse of the sum of the thicknesses at adjacent vertices [H-1 ~> m-1 or m2 kg-1] real :: I_Prandtl ! The inverse of the turbulent Prandtl number [nondim]. logical :: use_temperature ! If true, temperature and salinity have been ! allocated and are being used as state variables. - logical :: do_i ! If true, work on this column. integer, dimension(SZK_(GV)+1) :: kc ! The index map between the original ! interfaces and the interfaces with massless layers ! merged into nearby massive layers. real, dimension(SZK_(GV)+1) :: kf ! The fractional weight of interface kc+1 for ! interpolating back to the original index space [nondim]. - integer :: IsB, IeB, JsB, JeB, i, j, k, nz, nzc, J2, J2m1 + real :: h_SW, h_SE, h_NW, h_NE ! Thicknesses at adjacent vertices [H ~> m or kg m-2] + real :: mks_to_HZ_T ! A factor used to restore dimensional scaling after the geometric mean + ! diffusivity is taken using thickness weighted powers [H Z s m-2 T-1 ~> 1] + ! or [H Z m s kg-1 T-1 ~> 1] + real :: H_tiny ! A sub-roundoff thickness to use in the denominator when calculating + ! thickness-weighted averages [H ~> m or kg m-2] + integer :: IsB, IeB, JsB, JeB, i, j, k, nz, nzc ! Diagnostics that should be deleted? isB = G%isc-1 ; ieB = G%iecB ; jsB = G%jsc-1 ; jeB = G%jecB ; nz = GV%ke + if ((CS%id_N2_init>0) .or. CS%debug) diag_N2_init(:,:,:) = 0.0 + if ((CS%id_S2_init>0) .or. CS%debug) diag_S2_init(:,:,:) = 0.0 + if (CS%id_N2_mean>0) diag_N2_mean(:,:,:) = 0.0 + if (CS%id_S2_mean>0) diag_S2_mean(:,:,:) = 0.0 + kappa_vertex(:,:,:) = 0.0 + use_temperature = associated(tv%T) k0dt = dt*CS%kappa_0 - dz_massless = 0.1*sqrt(k0dt) + dz_massless = 0.1*sqrt((US%Z_to_m*GV%m_to_H)*k0dt) I_Prandtl = 0.0 ; if (CS%Prandtl_turb > 0.0) I_Prandtl = 1.0 / CS%Prandtl_turb + H_tiny = 0.5 * GV%H_subroundoff + + ! Convert layer thicknesses into geometric thickness in height units. + call thickness_to_dz(h, tv, dz_3d, G, GV, US, halo_size=1) - !$OMP parallel do default(private) shared(jsB,jeB,isB,ieB,nz,h,u_in,v_in,use_temperature,tv,G,GV, & - !$OMP US,CS,kappa_io,dz_massless,k0dt,p_surf,dt,tke_io,kv_io,I_Prandtl) + if (CS%vertex_shear_OBC_bug) then + !$OMP parallel do default(shared) + do k=1,nz + do j=JsB,JeB+1 ; do I=IsB,IeB + h_at_u(I,j,k) = G%mask2dCu(I,j) * (h(i,j,k) + h(i+1,j,k)) * 0.5 + enddo ; enddo + do J=JsB,JeB ; do i=IsB,IeB+1 + h_at_v(i,J,k) = G%mask2dCv(i,J) * (h(i,j,k) + h(i,j+1,k)) * 0.5 + enddo ; enddo + enddo + else + ! Because G%mask2dCu(I,j) is zero if either G%mask2dT(i,j) or G%mask2dT(i+1,j) except at OBC + ! faces, the following form give equivalent answers to those above unless OBCs are in use, + ! although the former is clearly less complicated and costly. + !$OMP parallel do default(shared) + do k=1,nz + do j=JsB,JeB+1 ; do I=IsB,IeB + h_at_u(I,j,k) = G%mask2dCu(I,j) * (G%mask2dT(i,j) * h(i,j,k) + G%mask2dT(i+1,j) * h(i+1,j,k)) / & + (G%mask2dT(i,j) + G%mask2dT(i+1,j) + 1.0e-36) + enddo ; enddo + do J=JsB,JeB ; do i=IsB,IeB+1 + h_at_v(i,J,k) = G%mask2dCv(i,J) * (G%mask2dT(i,j) * h(i,j,k) + G%mask2dT(i,j+1) * h(i,j+1,k)) / & + (G%mask2dT(i,j) + G%mask2dT(i,j+1) + 1.0e-36) + enddo ; enddo + enddo + endif + + + !$OMP parallel do default(private) shared(jsB,jeB,isB,ieB,nz,h,u_in,v_in,use_temperature,tv,G,GV,US,CS,kappa_io, & + !$OMP dz_massless,k0dt,p_surf,dt,tke_io,kv_io,kappa_vertex,h_vert,I_Prandtl, & + !$OMP diag_N2_init,diag_S2_init,diag_N2_mean,diag_S2_mean) do J=JsB,JeB - J2 = mod(J,2)+1 ; J2m1 = 3-J2 ! = mod(J-1,2)+1 ! Interpolate the various quantities to the corners, using masks. do k=1,nz ; do I=IsB,IeB - u_2d(I,k) = (u_in(I,j,k) * (G%mask2dCu(I,j) * (h(i,j,k) + h(i+1,j,k))) + & - u_in(I,j+1,k) * (G%mask2dCu(I,j+1) * (h(i,j+1,k) + h(i+1,j+1,k))) ) / & - ((G%mask2dCu(I,j) * (h(i,j,k) + h(i+1,j,k)) + & - G%mask2dCu(I,j+1) * (h(i,j+1,k) + h(i+1,j+1,k))) + GV%H_subroundoff) - v_2d(I,k) = (v_in(i,J,k) * (G%mask2dCv(i,J) * (h(i,j,k) + h(i,j+1,k))) + & - v_in(i+1,J,k) * (G%mask2dCv(i+1,J) * (h(i+1,j,k) + h(i+1,j+1,k))) ) / & - ((G%mask2dCv(i,J) * (h(i,j,k) + h(i,j+1,k)) + & - G%mask2dCv(i+1,J) * (h(i+1,j,k) + h(i+1,j+1,k))) + GV%H_subroundoff) + u_2d(I,k) = ( (u_in(I,j,k) * h_at_u(I,j,k)) + (u_in(I,j+1,k) * h_at_u(I,j+1,k)) ) / & + ( (h_at_u(I,j,k) + h_at_u(I,j+1,k)) + H_tiny ) + v_2d(I,k) = ( (v_in(i,J,k) * h_at_v(i,J,k)) + (v_in(i+1,J,k) * h_at_v(i+1,J,k)) ) / & + ( (h_at_v(i,J,k) + h_at_v(i+1,J,k)) + H_tiny ) + I_hwt = 1.0 / (((G%mask2dT(i,j) * h(i,j,k) + G%mask2dT(i+1,j+1) * h(i+1,j+1,k)) + & (G%mask2dT(i+1,j) * h(i+1,j,k) + G%mask2dT(i,j+1) * h(i,j+1,k))) + & GV%H_subroundoff) if (use_temperature) then - T_2d(I,k) = ( ((G%mask2dT(i,j) * h(i,j,k)) * T_in(i,j,k) + & - (G%mask2dT(i+1,j+1) * h(i+1,j+1,k)) * T_in(i+1,j+1,k)) + & - ((G%mask2dT(i+1,j) * h(i+1,j,k)) * T_in(i+1,j,k) + & - (G%mask2dT(i,j+1) * h(i,j+1,k)) * T_in(i,j+1,k)) ) * I_hwt - S_2d(I,k) = ( ((G%mask2dT(i,j) * h(i,j,k)) * S_in(i,j,k) + & - (G%mask2dT(i+1,j+1) * h(i+1,j+1,k)) * S_in(i+1,j+1,k)) + & - ((G%mask2dT(i+1,j) * h(i+1,j,k)) * S_in(i+1,j,k) + & - (G%mask2dT(i,j+1) * h(i,j+1,k)) * S_in(i,j+1,k)) ) * I_hwt + T_2d(I,k) = ( (G%mask2dT(i,j) * (h(i,j,k) * T_in(i,j,k)) + & + G%mask2dT(i+1,j+1) * (h(i+1,j+1,k) * T_in(i+1,j+1,k))) + & + (G%mask2dT(i+1,j) * (h(i+1,j,k) * T_in(i+1,j,k)) + & + G%mask2dT(i,j+1) * (h(i,j+1,k) * T_in(i,j+1,k))) ) * I_hwt + S_2d(I,k) = ( (G%mask2dT(i,j) * (h(i,j,k) * S_in(i,j,k)) + & + G%mask2dT(i+1,j+1) * (h(i+1,j+1,k) * S_in(i+1,j+1,k))) + & + (G%mask2dT(i+1,j) * (h(i+1,j,k) * S_in(i+1,j,k)) + & + G%mask2dT(i,j+1) * (h(i,j+1,k) * S_in(i,j+1,k))) ) * I_hwt endif - h_2d(I,k) = GV%H_to_Z * ((G%mask2dT(i,j) * h(i,j,k) + G%mask2dT(i+1,j+1) * h(i+1,j+1,k)) + & - (G%mask2dT(i+1,j) * h(i+1,j,k) + G%mask2dT(i,j+1) * h(i,j+1,k)) ) / & - ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + & - (G%mask2dT(i+1,j) + G%mask2dT(i,j+1)) + 1.0e-36 ) -! h_2d(I,k) = 0.25*((h(i,j,k) + h(i+1,j+1,k)) + (h(i+1,j,k) + h(i,j+1,k)))*GV%H_to_Z -! h_2d(I,k) = ((h(i,j,k)**2 + h(i+1,j+1,k)**2) + & -! (h(i+1,j,k)**2 + h(i,j+1,k)**2))*GV%H_to_Z * I_hwt + h_2d(I,k) = ((G%mask2dT(i,j) * h(i,j,k) + G%mask2dT(i+1,j+1) * h(i+1,j+1,k)) + & + (G%mask2dT(i+1,j) * h(i+1,j,k) + G%mask2dT(i,j+1) * h(i,j+1,k)) ) / & + ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + & + (G%mask2dT(i+1,j) + G%mask2dT(i,j+1)) + 1.0e-36 ) + dz_2d(I,k) = ((G%mask2dT(i,j) * dz_3d(i,j,k) + G%mask2dT(i+1,j+1) * dz_3d(i+1,j+1,k)) + & + (G%mask2dT(i+1,j) * dz_3d(i+1,j,k) + G%mask2dT(i,j+1) * dz_3d(i,j+1,k)) ) / & + ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + & + (G%mask2dT(i+1,j) + G%mask2dT(i,j+1)) + 1.0e-36 ) +! h_2d(I,k) = 0.25*((h(i,j,k) + h(i+1,j+1,k)) + (h(i+1,j,k) + h(i,j+1,k))) +! h_2d(I,k) = (((h(i,j,k)**2) + (h(i+1,j+1,k)**2)) + & +! ((h(i+1,j,k)**2) + (h(i,j+1,k)**2))) * I_hwt enddo ; enddo if (.not.use_temperature) then ; do k=1,nz ; do I=IsB,IeB rho_2d(I,k) = GV%Rlay(k) @@ -463,20 +619,21 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ nzc = 1 do k=1,nz ! Zero out the thicknesses of all layers, even if they are unused. - dz(k) = 0.0 ; u0xdz(k) = 0.0 ; v0xdz(k) = 0.0 + h_lay(k) = 0.0 ; dz_lay(k) = 0.0 ; u0xdz(k) = 0.0 ; v0xdz(k) = 0.0 T0xdz(k) = 0.0 ; S0xdz(k) = 0.0 ! Add a new layer if this one has mass. -! if ((dz(nzc) > 0.0) .and. (h_2d(I,k) > dz_massless)) nzc = nzc+1 - if ((k>CS%nkml) .and. (dz(nzc) > 0.0) .and. & +! if ((h_lay(nzc) > 0.0) .and. (h_2d(I,k) > dz_massless)) nzc = nzc+1 + if ((k>CS%nkml) .and. (h_lay(nzc) > 0.0) .and. & (h_2d(I,k) > dz_massless)) nzc = nzc+1 ! Only merge clusters of massless layers. -! if ((dz(nzc) > dz_massless) .or. & -! ((dz(nzc) > 0.0) .and. (h_2d(I,k) > dz_massless))) nzc = nzc+1 +! if ((h_lay(nzc) > dz_massless) .or. & +! ((h_lay(nzc) > 0.0) .and. (h_2d(I,k) > dz_massless))) nzc = nzc+1 kc(k) = nzc - dz(nzc) = dz(nzc) + h_2d(I,k) + h_lay(nzc) = h_lay(nzc) + h_2d(I,k) + dz_lay(nzc) = dz_lay(nzc) + dz_2d(I,k) u0xdz(nzc) = u0xdz(nzc) + u_2d(I,k)*h_2d(I,k) v0xdz(nzc) = v0xdz(nzc) + v_2d(I,k)*h_2d(I,k) if (use_temperature) then @@ -490,7 +647,7 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ kc(nz+1) = nzc+1 ! Set up Idz as the inverse of layer thicknesses. - do k=1,nzc ; Idz(k) = 1.0 / dz(k) ; enddo + do k=1,nzc ; Idz(k) = 1.0 / h_lay(k) ; enddo ! Now determine kf, the fractional weight of interface kc when ! interpolating between interfaces kc and kc+1. @@ -505,22 +662,24 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ kf(nz+1) = 0.0 else do k=1,nz - dz(k) = h_2d(I,k) - u0xdz(k) = u_2d(I,k)*dz(k) ; v0xdz(k) = v_2d(I,k)*dz(k) + h_lay(k) = h_2d(I,k) + dz_lay(k) = dz_2d(I,k) + u0xdz(k) = u_2d(I,k)*h_lay(k) ; v0xdz(k) = v_2d(I,k)*h_lay(k) enddo if (use_temperature) then do k=1,nz - T0xdz(k) = T_2d(I,k)*dz(k) ; S0xdz(k) = S_2d(I,k)*dz(k) + T0xdz(k) = T_2d(I,k)*h_lay(k) ; S0xdz(k) = S_2d(I,k)*h_lay(k) enddo else do k=1,nz - T0xdz(k) = rho_2d(I,k)*dz(k) ; S0xdz(k) = rho_2d(I,k)*dz(k) + T0xdz(k) = rho_2d(I,k)*h_lay(k) ; S0xdz(k) = rho_2d(I,k)*h_lay(k) enddo endif nzc = nz do k=1,nzc+1 ; kc(k) = k ; kf(k) = 0.0 ; enddo endif - f2 = G%CoriolisBu(I,J)**2 + + f2 = G%Coriolis2Bu(I,J) surface_pres = 0.0 if (associated(p_surf)) then if (CS%psurf_bug) then @@ -538,70 +697,178 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ ! ---------------------------------------------------- ! Set the initial guess for kappa, here defined at interfaces. ! ---------------------------------------------------- - do K=1,nzc+1 ; kappa(K) = US%m2_s_to_Z2_T*1.0 ; enddo + do K=1,nzc+1 ; kappa(K) = CS%kappa_seed ; enddo call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & - dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & - tke_avg, tv, CS, GV, US) + h_lay, dz_lay, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & + tke_avg, N2_init, S2_init, N2_mean, S2_mean, tv, CS, GV, US) ! call cpu_clock_begin(Id_clock_setup) ! Extrapolate from the vertically reduced grid back to the original layers. if (nz == nzc) then do K=1,nz+1 - kappa_2d(I,K,J2) = kappa_avg(K) + kappa_2d(I,K) = kappa_avg(K) if (CS%all_layer_TKE_bug) then - tke_2d(i,K) = tke(K) + tke_2d(I,K) = tke(K) else - tke_2d(i,K) = tke_avg(K) + tke_2d(I,K) = tke_avg(K) endif enddo + if (CS%id_N2_mean>0) then ; do K=1,nz+1 + diag_N2_mean(I,J,K) = N2_mean(K) + enddo ; endif + if (CS%id_S2_mean>0) then ; do K=1,nz+1 + diag_S2_mean(I,J,K) = S2_mean(K) + enddo ; endif + if ((CS%id_N2_init>0) .or. CS%debug) then ; do K=1,nz+1 + diag_N2_init(I,J,K) = N2_init(K) + enddo ; endif + if ((CS%id_S2_init>0) .or. CS%debug) then ; do K=1,nz+1 + diag_S2_init(I,J,K) = S2_init(K) + enddo ; endif else do K=1,nz+1 if (kf(K) == 0.0) then - kappa_2d(I,K,J2) = kappa_avg(kc(K)) + kappa_2d(I,K) = kappa_avg(kc(K)) tke_2d(I,K) = tke_avg(kc(K)) else - kappa_2d(I,K,J2) = (1.0-kf(K)) * kappa_avg(kc(K)) + kf(K) * kappa_avg(kc(K)+1) + kappa_2d(I,K) = (1.0-kf(K)) * kappa_avg(kc(K)) + kf(K) * kappa_avg(kc(K)+1) tke_2d(I,K) = (1.0-kf(K)) * tke_avg(kc(K)) + kf(K) * tke_avg(kc(K)+1) endif enddo + do K=1,nz+1 + if (kf(K) == 0.0) then + if (CS%id_N2_mean>0) diag_N2_mean(I,J,K) = N2_mean(kc(K)) + if (CS%id_S2_mean>0) diag_S2_mean(I,J,K) = S2_mean(kc(K)) + if ((CS%id_N2_init>0) .or. CS%debug) diag_N2_init(I,J,K) = N2_init(kc(K)) + if ((CS%id_S2_init>0) .or. CS%debug) diag_S2_init(I,J,K) = S2_init(kc(K)) + else + if (CS%id_N2_mean>0) & + diag_N2_mean(I,J,K) = (1.0-kf(K)) * N2_mean(kc(K)) + kf(K) * N2_mean(kc(K)+1) + if (CS%id_S2_mean>0) & + diag_S2_mean(I,J,K) = (1.0-kf(K)) * S2_mean(kc(K)) + kf(K) * S2_mean(kc(K)+1) + if ((CS%id_N2_init>0) .or. CS%debug) & + diag_N2_init(I,J,K) = (1.0-kf(K)) * N2_init(kc(K)) + kf(K) * N2_init(kc(K)+1) + if ((CS%id_S2_init>0) .or. CS%debug) & + diag_S2_init(I,J,K) = (1.0-kf(K)) * S2_init(kc(K)) + kf(K) * S2_init(kc(K)+1) + endif + enddo endif ! call cpu_clock_end(Id_clock_setup) else ! Land points, still inside the i-loop. do K=1,nz+1 - kappa_2d(I,K,J2) = 0.0 ; tke_2d(I,K) = 0.0 + kappa_2d(I,K) = 0.0 ; tke_2d(I,K) = 0.0 enddo endif ; enddo ! i-loop - do K=1,nz+1 ; do I=IsB,IeB - tke_io(I,J,K) = G%mask2dBu(I,J) * tke_2d(I,K) - kv_io(I,J,K) = ( G%mask2dBu(I,J) * kappa_2d(I,K,J2) ) * CS%Prandtl_turb - enddo ; enddo - if (J>=G%jsc) then ; do K=1,nz+1 ; do i=G%isc,G%iec - ! Set the diffusivities in tracer columns from the values at vertices. - kappa_io(i,j,K) = G%mask2dT(i,j) * 0.25 * & - ((kappa_2d(I-1,K,J2m1) + kappa_2d(I,K,J2)) + & - (kappa_2d(I-1,K,J2) + kappa_2d(I,K,J2m1))) - enddo ; enddo ; endif - + ! Store the 2-d slices back in the 3-d arrays for restarts or interpolation back to tracer points. + if (CS%VS_ThicknessMean) then + do K=1,nz+1 ; do I=IsB,IeB + h_vert(I,J,k) = h_2d(I,k) + enddo ; enddo + endif + if (CS%VS_viscosity_bug) then + do K=1,nz+1 ; do I=IsB,IeB + kappa_vertex(I,J,K) = kappa_2d(I,K) + tke_io(I,J,K) = G%mask2dBu(I,J) * tke_2d(I,K) + kv_io(I,J,K) = ( G%mask2dBu(I,J) * kappa_vertex(I,J,K) ) * CS%Prandtl_turb + enddo ; enddo + else + do K=1,nz+1 ; do I=IsB,IeB + kappa_vertex(I,J,K) = kappa_2d(I,K) + tke_io(I,J,K) = tke_2d(I,K) + kv_io(I,J,K) = kappa_vertex(I,J,K) * CS%Prandtl_turb + enddo ; enddo + endif enddo ! end of J-loop + ! Set the diffusivities in tracer columns from the values at vertices. + + !$OMP parallel do default(private) shared(G,kappa_io) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + ! The turbulent length scales (and hence turbulent diffusivity) should always go to 0 at the top and bottom. + kappa_io(i,j,1) = 0.0 + kappa_io(i,j,nz+1) = 0.0 + enddo ; enddo + if (CS%VS_ThicknessMean .and. CS%VS_GeometricMean) then + ! This conversion factor is required to allow for arbitrary fractional powers of the diffusivities. + mks_to_HZ_T = 1.0 / GV%HZ_T_to_MKS + !$OMP parallel do default(private) shared(nz,G,GV,CS,kappa_io,kappa_vertex,h_vert) + do K=2,nz ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + h_SW = 0.5 * (h_vert(I-1,J-1,k) + h_vert(I-1,J-1,k-1)) + h_NE = 0.5 * (h_vert(I,J,k) + h_vert(I,J,k-1)) + h_NW = 0.5 * (h_vert(I-1,J,k) + h_vert(I-1,J,k-1)) + h_SE = 0.5 * (h_vert(I,J-1,k) + h_vert(I,J-1,k-1)) + if ((h_SW + h_NE) + (h_NW + h_SE) > 0.0) then + ! The geometric mean is zero if any component is zero, hence the need to use a floor + ! on the value of kappa_trunc in regions on boundaries of shear zones. + I_htot = 1.0 / ((h_SW + h_NE) + (h_NW + h_SE)) + kappa_io(i,j,K) = G%mask2dT(i,j) * mks_to_HZ_T * & + ( ((GV%HZ_T_to_MKS * max(kappa_vertex(I-1,J-1,K), CS%VS_GeoMean_Kdmin))**(h_SW*I_htot) * & + (GV%HZ_T_to_MKS * max(kappa_vertex(I,J,K), CS%VS_GeoMean_Kdmin))**(h_NE*I_htot)) * & + ((GV%HZ_T_to_MKS * max(kappa_vertex(I-1,J,K), CS%VS_GeoMean_Kdmin))**(h_NW*I_htot) * & + (GV%HZ_T_to_MKS * max(kappa_vertex(I,J-1,K), CS%VS_GeoMean_Kdmin))**(h_SE*I_htot)) ) + else + ! If all points have zero thickness, the thickness-weighted geometric mean is undefined, so use + ! the non-thickness weighted geometric mean instead. + kappa_io(i,j,K) = G%mask2dT(i,j) * sqrt(sqrt( & + (max(kappa_vertex(I-1,J-1,K),CS%VS_GeoMean_Kdmin) * max(kappa_vertex(I,J,K),CS%VS_GeoMean_Kdmin)) * & + (max(kappa_vertex(I-1,J,K),CS%VS_GeoMean_Kdmin) * max(kappa_vertex(I,J-1,K),CS%VS_GeoMean_Kdmin)) )) + endif + enddo ; enddo ; enddo + elseif (CS%VS_ThicknessMean) then ! Use thickness-weighted arithmetic mean diffusivities. + !$OMP parallel do default(private) shared(nz,G,GV,CS,kappa_io,kappa_vertex,h_vert) + do K=2,nz ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + h_SW = 0.5 * (h_vert(I-1,J-1,k) + h_vert(I-1,J-1,k-1)) + h_NE = 0.5 * (h_vert(I,J,k) + h_vert(I,J,k-1)) + h_NW = 0.5 * (h_vert(I-1,J,k) + h_vert(I-1,J,k-1)) + h_SE = 0.5 * (h_vert(I,J-1,k) + h_vert(I,J-1,k-1)) + ! The following expression is a thickness weighted arithmetic mean at tracer points: + I_htot = 1.0 / (((h_SW + h_NE) + (h_NW + h_SE)) + GV%H_subroundoff) + kappa_io(i,j,K) = G%mask2dT(i,j) * & + (((kappa_vertex(I-1,J-1,K)*h_SW) + (kappa_vertex(I,J,K)*h_NE)) + & + ((kappa_vertex(I-1,J,K)*h_NW) + (kappa_vertex(I,J-1,K)*h_SE))) * I_htot + enddo ; enddo ; enddo + elseif (CS%VS_GeometricMean) then ! The geometic mean diffusivities are not thickness weighted. + !$OMP parallel do default(private) shared(nz,G,CS,kappa_io,kappa_vertex) + do K=2,nz ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + kappa_io(i,j,K) = G%mask2dT(i,j) * sqrt(sqrt( & + (max(kappa_vertex(I-1,J-1,K),CS%VS_GeoMean_Kdmin) * max(kappa_vertex(I,J,K),CS%VS_GeoMean_Kdmin)) * & + (max(kappa_vertex(I-1,J,K),CS%VS_GeoMean_Kdmin) * max(kappa_vertex(I,J-1,K),CS%VS_GeoMean_Kdmin)) )) + enddo ; enddo ; enddo + else ! Use a non-thickness weighted arithmetic mean. + !$OMP parallel do default(private) shared(nz,G,CS,kappa_io,kappa_vertex) + do K=2,nz ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + kappa_io(i,j,K) = G%mask2dT(i,j) * 0.25 * & + ((kappa_vertex(I-1,J-1,K) + kappa_vertex(I,J,K)) +& + (kappa_vertex(I-1,J,K) + kappa_vertex(I,J-1,K))) + enddo ; enddo ; enddo + endif + if (CS%debug) then - call hchksum(kappa_io, "kappa", G%HI, scale=US%Z2_T_to_m2_s) - call Bchksum(tke_io, "tke", G%HI, scale=US%Z_to_m**2*US%s_to_T**2) + call Bchksum(diag_N2_init, "shear_vertex N2_init", G%HI, unscale=US%s_to_T**2) + call Bchksum(diag_S2_init, "shear_vertex S2_init", G%HI, unscale=US%s_to_T**2) + call hchksum(kappa_io, "kappa", G%HI, unscale=GV%HZ_T_to_m2_s) + call Bchksum(tke_io, "tke", G%HI, unscale=US%Z_to_m**2*US%s_to_T**2) endif if (CS%id_Kd_shear > 0) call post_data(CS%id_Kd_shear, kappa_io, CS%diag) if (CS%id_TKE > 0) call post_data(CS%id_TKE, tke_io, CS%diag) + if (CS%id_Kd_vertex > 0) call post_data(CS%id_Kd_vertex, kappa_vertex, CS%diag) + if (CS%id_N2_init > 0) call post_data(CS%id_N2_init, diag_N2_init, CS%diag) + if (CS%id_S2_init > 0) call post_data(CS%id_S2_init, diag_S2_init, CS%diag) + if (CS%id_N2_mean > 0) call post_data(CS%id_N2_mean, diag_N2_mean, CS%diag) + if (CS%id_S2_mean > 0) call post_data(CS%id_S2_mean, diag_S2_mean, CS%diag) end subroutine Calc_kappa_shear_vertex !> This subroutine calculates shear-driven diffusivity and TKE in a single column -subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & - u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, tke_avg, tv, CS, GV, US) +subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, hlay, dz_lay, & + u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, tke_avg, N2_init, S2_init, & + N2_mean, S2_mean, tv, CS, GV, US ) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZK_(GV)+1), & - intent(inout) :: kappa !< The time-weighted average of kappa [Z2 T-1 ~> m2 s-1]. + intent(inout) :: kappa !< The time-weighted average of kappa [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZK_(GV)+1), & intent(out) :: tke !< The Turbulent Kinetic Energy per unit mass at !! an interface [Z2 T-2 ~> m2 s-2]. @@ -609,19 +876,30 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & real, intent(in) :: f2 !< The square of the Coriolis parameter [T-2 ~> s-2]. real, intent(in) :: surface_pres !< The surface pressure [R L2 T-2 ~> Pa]. real, dimension(SZK_(GV)), & - intent(in) :: dz !< The layer thickness [Z ~> m]. + intent(in) :: hlay !< The layer thickness [H ~> m or kg m-2] real, dimension(SZK_(GV)), & - intent(in) :: u0xdz !< The initial zonal velocity times dz [Z L T-1 ~> m2 s-1]. + intent(in) :: dz_lay !< The geometric layer thickness in height units [Z ~> m] real, dimension(SZK_(GV)), & - intent(in) :: v0xdz !< The initial meridional velocity times dz [Z L T-1 ~> m2 s-1]. + intent(in) :: u0xdz !< The initial zonal velocity times hlay [H L T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZK_(GV)), & - intent(in) :: T0xdz !< The initial temperature times dz [degC Z ~> degC m]. + intent(in) :: v0xdz !< The initial meridional velocity times the + !! layer thickness [H L T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZK_(GV)), & - intent(in) :: S0xdz !< The initial salinity times dz [ppt Z ~> ppt m]. + intent(in) :: T0xdz !< The initial temperature times hlay [C H ~> degC m or degC kg m-2] + real, dimension(SZK_(GV)), & + intent(in) :: S0xdz !< The initial salinity times hlay [S H ~> ppt m or ppt kg m-2] real, dimension(SZK_(GV)+1), & - intent(out) :: kappa_avg !< The time-weighted average of kappa [Z2 T-1 ~> m2 s-1]. + intent(out) :: kappa_avg !< The time-weighted average of kappa [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZK_(GV)+1), & intent(out) :: tke_avg !< The time-weighted average of TKE [Z2 T-2 ~> m2 s-2]. + real, dimension(SZK_(GV)+1), & + intent(out) :: N2_mean !< The time-weighted average of N2 [Z2 T-2 ~> m2 s-2]. + real, dimension(SZK_(GV)+1), & + intent(out) :: S2_mean !< The time-weighted average of S2 [Z2 T-2 ~> m2 s-2]. + real, dimension(SZK_(GV)+1), & + intent(out) :: N2_init !< The initial value of N2 [Z2 T-2 ~> m2 s-2]. + real, dimension(SZK_(GV)+1), & + intent(out) :: S2_init !< The initial value of S2 [Z2 T-2 ~> m2 s-2]. real, intent(in) :: dt !< Time increment [T ~> s]. type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any !! available thermodynamic fields. Absent fields @@ -635,54 +913,63 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & u, & ! The zonal velocity after a timestep of mixing [L T-1 ~> m s-1]. v, & ! The meridional velocity after a timestep of mixing [L T-1 ~> m s-1]. Idz, & ! The inverse of the distance between TKE points [Z-1 ~> m-1]. - T, & ! The potential temperature after a timestep of mixing [degC]. - Sal, & ! The salinity after a timestep of mixing [ppt]. + T, & ! The potential temperature after a timestep of mixing [C ~> degC]. + Sal, & ! The salinity after a timestep of mixing [S ~> ppt]. u_test, v_test, & ! Temporary velocities [L T-1 ~> m s-1]. - T_test, S_test ! Temporary temperatures [degC] and salinities [ppt]. + T_test, S_test ! Temporary temperatures [C ~> degC] and salinities [S ~> ppt]. real, dimension(nzc+1) :: & N2, & ! The squared buoyancy frequency at an interface [T-2 ~> s-2]. - dz_Int, & ! The extent of a finite-volume space surrounding an interface, - ! as used in calculating kappa and TKE [Z ~> m]. + h_Int, & ! The extent of a finite-volume space surrounding an interface, + ! as used in calculating kappa and TKE [H ~> m or kg m-2] + dz_Int, & ! The vertical distance with the space surrounding an interface, + ! as used in calculating kappa and TKE [Z ~> m] + dz_h_Int, & ! The ratio of the vertical distances to the thickness around an + ! interface [Z H-1 ~> nondim or m3 kg-1]. In non-Boussinesq mode + ! this is the specific volume, otherwise it is a scaling factor. I_dz_int, & ! The inverse of the distance between velocity & density points ! above and below an interface [Z-1 ~> m-1]. This is used to - ! calculate N2, shear, and fluxes, and it might differ from - ! 1/dz_Int, as they have different uses. + ! calculate N2, shear and fluxes. S2, & ! The squared shear at an interface [T-2 ~> s-2]. a1, & ! a1 is the coupling between adjacent interfaces in the TKE, - ! velocity, and density equations [Z s-1 ~> m s-1] or [Z ~> m] - c1, & ! c1 is used in the tridiagonal (and similar) solvers. - k_src, & ! The shear-dependent source term in the kappa equation [T-1 ~> s-1]. - kappa_src, & ! The shear-dependent source term in the kappa equation [T-1 ~> s-1]. - kappa_out, & ! The kappa that results from the kappa equation [Z2 T-1 ~> m2 s-1]. - kappa_mid, & ! The average of the initial and predictor estimates of kappa [Z2 T-1 ~> m2 s-1]. + ! velocity, and density equations [H ~> m or kg m-2] + c1, & ! c1 is used in the tridiagonal (and similar) solvers [nondim]. + k_src, & ! The shear-dependent source term in the kappa equation [T-1 ~> s-1] + kappa_src, & ! The shear-dependent source term in the kappa equation [T-1 ~> s-1] + kappa_out, & ! The kappa that results from the kappa equation [H Z T-1 ~> m2 s-1 or Pa s] + kappa_mid, & ! The average of the initial and predictor estimates of kappa [H Z T-1 ~> m2 s-1 or Pa s] tke_pred, & ! The value of TKE from a predictor step [Z2 T-2 ~> m2 s-2]. - kappa_pred, & ! The value of kappa from a predictor step [Z2 T-1 ~> m2 s-1]. + kappa_pred, & ! The value of kappa from a predictor step [H Z T-1 ~> m2 s-1 or Pa s] pressure, & ! The pressure at an interface [R L2 T-2 ~> Pa]. - T_int, & ! The temperature interpolated to an interface [degC]. - Sal_int, & ! The salinity interpolated to an interface [ppt]. - dbuoy_dT, & ! The partial derivatives of buoyancy with changes in temperature - dbuoy_dS, & ! and salinity, [Z T-2 degC-1 ~> m s-2 degC-1] and [Z T-2 ppt-1 ~> m s-2 ppt-1]. + T_int, & ! The temperature interpolated to an interface [C ~> degC]. + Sal_int, & ! The salinity interpolated to an interface [S ~> ppt]. + dbuoy_dT, & ! The partial derivative of buoyancy with changes in temperature [Z T-2 C-1 ~> m s-2 degC-1] + dbuoy_dS, & ! The partial derivative of buoyancy with changes in salinity [Z T-2 S-1 ~> m s-2 ppt-1] + dSpV_dT, & ! The partial derivative of specific volume with changes in temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSpV_dS, & ! The partial derivative of specific volume with changes in salinity [R-1 S-1 ~> m3 kg-1 ppt-1] + rho_int, & ! The in situ density interpolated to an interface [R ~> kg m-3] I_L2_bdry, & ! The inverse of the square of twice the harmonic mean - ! distance to the top and bottom boundaries [Z-2 ~> m-2]. - K_Q, & ! Diffusivity divided by TKE [T ~> s]. - K_Q_tmp, & ! A temporary copy of diffusivity divided by TKE [T ~> s]. - local_src_avg, & ! The time-integral of the local source [nondim]. + ! distance to the top and bottom boundaries [H-1 Z-1 ~> m-2 or m kg-1]. + K_Q, & ! Diffusivity divided by TKE [H T Z-1 ~> s or kg s m-3] + K_Q_tmp, & ! A temporary copy of diffusivity divided by TKE [H T Z-1 ~> s or kg s m-3] + local_src_avg, & ! The time-integral of the local source [nondim] tol_min, & ! Minimum tolerated ksrc for the corrector step [T-1 ~> s-1]. tol_max, & ! Maximum tolerated ksrc for the corrector step [T-1 ~> s-1]. tol_chg, & ! The tolerated kappa change integrated over a timestep [nondim]. dist_from_top, & ! The distance from the top surface [Z ~> m]. + h_from_top, & ! The total thickness above an interface [H ~> m or kg m-2] local_src ! The sum of all sources of kappa, including kappa_src and - ! sources from the elliptic term [T-1 ~> s-1]. + ! sources from the elliptic term [T-1 ~> s-1] real :: dist_from_bot ! The distance from the bottom surface [Z ~> m]. - real :: b1 ! The inverse of the pivot in the tridiagonal equations. - real :: bd1 ! A term in the denominator of b1. - real :: d1 ! 1 - c1 in the tridiagonal equations. - real :: gR0 ! A conversion factor from Z to pressure, given by Rho_0 times g - ! [R L2 T-2 Z-1 ~> kg m-2 s-2]. + real :: h_from_bot ! The total thickness below and interface [H ~> m or kg m-2] + real :: b1 ! The inverse of the pivot in the tridiagonal equations [H-1 ~> m-1 or m2 kg-1]. + real :: bd1 ! A term in the denominator of b1 [H ~> m or kg m-2]. + real :: d1 ! 1 - c1 in the tridiagonal equations [nondim] + real :: gR0 ! A conversion factor from H to pressure, Rho_0 times g in Boussinesq + ! mode, or just g when non-Boussinesq [R L2 T-2 H-1 ~> kg m-2 s-2 or m s-2]. real :: g_R0 ! g_R0 is a rescaled version of g/Rho [Z R-1 T-2 ~> m4 kg-1 s-2]. - real :: Norm ! A factor that normalizes two weights to 1 [Z-2 ~> m-2]. + real :: Norm ! A factor that normalizes two weights to 1 [H-2 ~> m-2 or m4 kg-2]. real :: tol_dksrc ! Tolerance for the change in the kappa source within an iteration ! relative to the local source [nondim]. This must be greater than 1. real :: tol2 ! The tolerance for the change in the kappa source within an iteration @@ -698,15 +985,16 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! gives acceptably small changes in k_src [T ~> s]. real :: Idtt ! Idtt = 1 / dt_test [T-1 ~> s-1]. real :: dt_inc ! An increment to dt_test that is being tested [T ~> s]. - - real :: k0dt ! The background diffusivity times the timestep [Z2 ~> m2]. + real :: wt_a ! The fraction of a layer thickness identified with the interface + ! above a layer [nondim] + real :: wt_b ! The fraction of a layer thickness identified with the interface + ! below a layer [nondim] + real :: k0dt ! The background diffusivity times the timestep [H Z ~> m2 or kg m-1]. + real :: I_lz_rescale_sqr ! The inverse of a rescaling factor for L2_bdry (Lz) squared [nondim]. logical :: valid_dt ! If true, all levels so far exhibit acceptably small changes in k_src. logical :: use_temperature ! If true, temperature and salinity have been ! allocated and are being used as state variables. integer :: ks_kappa, ke_kappa ! The k-range with nonzero kappas. - integer :: dt_halvings ! The number of times that the time-step is halved - ! in seeking an acceptable timestep. If none is - ! found, dt_rem*0.5^dt_halvings is used. integer :: dt_refinements ! The number of 2-fold refinements that will be used ! to estimate the maximum permitted time step. I.e., ! the resolution is 1/2^dt_refinements. @@ -717,10 +1005,12 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! N2_debug, & ! A version of N2 for debugging [T-2 ~> s-2] Ri_crit = CS%Rino_crit - gR0 = GV%Rho0 * GV%g_Earth - g_R0 = (US%L_to_Z**2 * GV%g_Earth) / (GV%Rho0) + gR0 = GV%H_to_RZ * GV%g_Earth + g_R0 = GV%g_Earth_Z_T2 / GV%Rho0 k0dt = dt*CS%kappa_0 + I_lz_rescale_sqr = 1.0 ; if (CS%lz_rescale > 0) I_lz_rescale_sqr = 1/(CS%lz_rescale*CS%lz_rescale) + tol_dksrc = CS%kappa_src_max_chg if (tol_dksrc == 10.0) then ! This is equivalent to the expression below, but avoids changes at roundoff for the default value. @@ -734,27 +1024,40 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! Set up Idz as the inverse of layer thicknesses. - do k=1,nzc ; Idz(k) = 1.0 / dz(k) ; enddo + do k=1,nzc ; Idz(k) = 1.0 / dz_lay(k) ; enddo ! Set up I_dz_int as the inverse of the distance between ! adjacent layer centers. - I_dz_int(1) = 2.0 / dz(1) - dist_from_top(1) = 0.0 + I_dz_int(1) = 2.0 / dz_lay(1) + dist_from_top(1) = 0.0 ; h_from_top(1) = 0.0 do K=2,nzc - I_dz_int(K) = 2.0 / (dz(k-1) + dz(k)) - dist_from_top(K) = dist_from_top(K-1) + dz(k-1) + I_dz_int(K) = 2.0 / (dz_lay(k-1) + dz_lay(k)) + dist_from_top(K) = dist_from_top(K-1) + dz_lay(k-1) + h_from_top(K) = h_from_top(K-1) + hlay(k-1) + enddo + I_dz_int(nzc+1) = 2.0 / dz_lay(nzc) + + ! Find the inverse of the squared distances from the boundaries. + dist_from_bot = 0.0 ; h_from_bot = 0.0 + do K=nzc,2,-1 + dist_from_bot = dist_from_bot + dz_lay(k) + h_from_bot = h_from_bot + hlay(k) + ! Find the inverse of the squared distances from the boundaries, + I_L2_bdry(K) = ((dist_from_top(K) + dist_from_bot) * (h_from_top(K) + h_from_bot)) / & + ((dist_from_top(K) * dist_from_bot) * (h_from_top(K) * h_from_bot)) + ! reduce the distance by a factor of "lz_rescale" + I_L2_bdry(K) = I_lz_rescale_sqr*I_L2_bdry(K) enddo - I_dz_int(nzc+1) = 2.0 / dz(nzc) ! Determine the velocities and thicknesses after eliminating massless ! layers and applying a time-step of background diffusion. if (nzc > 1) then a1(2) = k0dt*I_dz_int(2) - b1 = 1.0 / (dz(1) + a1(2)) + b1 = 1.0 / (hlay(1) + a1(2)) u(1) = b1 * u0xdz(1) ; v(1) = b1 * v0xdz(1) T(1) = b1 * T0xdz(1) ; Sal(1) = b1 * S0xdz(1) - c1(2) = a1(2) * b1 ; d1 = dz(1) * b1 ! = 1 - c1 + c1(2) = a1(2) * b1 ; d1 = hlay(1) * b1 ! = 1 - c1 do k=2,nzc-1 - bd1 = dz(k) + d1*a1(k) + bd1 = hlay(k) + d1*a1(k) a1(k+1) = k0dt*I_dz_int(k+1) b1 = 1.0 / (bd1 + a1(k+1)) u(k) = b1 * (u0xdz(k) + a1(k)*u(k-1)) @@ -766,11 +1069,11 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! rho or T and S have insulating boundary conditions, u & v use no-slip ! bottom boundary conditions (if kappa0 > 0). ! For no-slip bottom boundary conditions - b1 = 1.0 / ((dz(nzc) + d1*a1(nzc)) + k0dt*I_dz_int(nzc+1)) + b1 = 1.0 / ((hlay(nzc) + d1*a1(nzc)) + k0dt*I_dz_int(nzc+1)) u(nzc) = b1 * (u0xdz(nzc) + a1(nzc)*u(nzc-1)) v(nzc) = b1 * (v0xdz(nzc) + a1(nzc)*v(nzc-1)) ! For insulating boundary conditions - b1 = 1.0 / (dz(nzc) + d1*a1(nzc)) + b1 = 1.0 / (hlay(nzc) + d1*a1(nzc)) T(nzc) = b1 * (T0xdz(nzc) + a1(nzc)*T(nzc-1)) Sal(nzc) = b1 * (S0xdz(nzc) + a1(nzc)*Sal(nzc-1)) do k=nzc-1,1,-1 @@ -779,9 +1082,9 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & enddo else ! This is correct, but probably unnecessary. - b1 = 1.0 / (dz(1) + k0dt*I_dz_int(2)) + b1 = 1.0 / (hlay(1) + k0dt*I_dz_int(2)) u(1) = b1 * u0xdz(1) ; v(1) = b1 * v0xdz(1) - b1 = 1.0 / dz(1) + b1 = 1.0 / hlay(1) T(1) = b1 * T0xdz(1) ; Sal(1) = b1 * S0xdz(1) endif @@ -791,33 +1094,66 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! layers have thin cells, and the total thickness adds up properly. ! The top- and bottom- interfaces have zero thickness, consistent with ! adding additional zero thickness layers. - dz_Int(1) = 0.0 ; dz_Int(2) = dz(1) + h_Int(1) = 0.0 ; h_Int(2) = hlay(1) + dz_Int(1) = 0.0 ; dz_Int(2) = dz_lay(1) do K=2,nzc-1 - Norm = 1.0 / (dz(k)*(dz(k-1)+dz(k+1)) + 2.0*dz(k-1)*dz(k+1)) - dz_Int(K) = dz_Int(K) + dz(k) * ( ((dz(k)+dz(k+1)) * dz(k-1)) * Norm) - dz_Int(K+1) = dz(k) * ( ((dz(k-1)+dz(k)) * dz(k+1)) * Norm) + Norm = 1.0 / (hlay(k)*(hlay(k-1)+hlay(k+1)) + 2.0*hlay(k-1)*hlay(k+1)) + wt_a = ((hlay(k)+hlay(k+1)) * hlay(k-1)) * Norm + wt_b = ((hlay(k-1)+hlay(k)) * hlay(k+1)) * Norm + h_Int(K) = h_Int(K) + hlay(k) * wt_a + h_Int(K+1) = hlay(k) * wt_b + dz_Int(K) = dz_Int(K) + dz_lay(k) * wt_a + dz_Int(K+1) = dz_lay(k) * wt_b enddo - dz_Int(nzc) = dz_Int(nzc) + dz(nzc) ; dz_Int(nzc+1) = 0.0 + h_Int(nzc) = h_Int(nzc) + hlay(nzc) ; h_Int(nzc+1) = 0.0 + dz_Int(nzc) = dz_Int(nzc) + dz_lay(nzc) ; dz_Int(nzc+1) = 0.0 - dist_from_bot = 0.0 - do K=nzc,2,-1 - dist_from_bot = dist_from_bot + dz(k) - I_L2_bdry(K) = (dist_from_top(K) + dist_from_bot)**2 / & - (dist_from_top(K) * dist_from_bot)**2 - enddo + if (GV%Boussinesq) then + do K=1,nzc+1 ; dz_h_Int(K) = GV%H_to_Z ; enddo + else + ! Find an effective average specific volume around an interface. + dz_h_Int(1:nzc+1) = 0.0 + if (hlay(1) > 0.0) dz_h_Int(1) = dz_lay(1) / hlay(1) + do K=2,nzc+1 + if (h_Int(K) > 0.0) then + dz_h_Int(K) = dz_Int(K) / h_Int(K) + else + dz_h_Int(K) = dz_h_Int(K-1) + endif + enddo + endif ! Calculate thermodynamic coefficients and an initial estimate of N2. if (use_temperature) then pressure(1) = surface_pres do K=2,nzc - pressure(K) = pressure(K-1) + gR0*dz(k-1) + pressure(K) = pressure(K-1) + gR0*hlay(k-1) T_int(K) = 0.5*(T(k-1) + T(k)) Sal_int(K) = 0.5*(Sal(k-1) + Sal(k)) enddo - call calculate_density_derivs(T_int, Sal_int, pressure, dbuoy_dT, dbuoy_dS, & - tv%eqn_of_state, (/2,nzc/), scale=-g_R0 ) - else + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + call calculate_density_derivs(T_int, Sal_int, pressure, dbuoy_dT, dbuoy_dS, & + tv%eqn_of_state, (/2,nzc/), scale=-g_R0 ) + else + ! These should perhaps be combined into a single call to calculate the thermal expansion + ! and haline contraction coefficients? + call calculate_specific_vol_derivs(T_int, Sal_int, pressure, dSpV_dT, dSpV_dS, & + tv%eqn_of_state, (/2,nzc/) ) + call calculate_density(T_int, Sal_int, pressure, rho_int, tv%eqn_of_state, (/2,nzc/) ) + do K=2,nzc + dbuoy_dT(K) = GV%g_Earth_Z_T2 * (rho_int(K) * dSpV_dT(K)) + dbuoy_dS(K) = GV%g_Earth_Z_T2 * (rho_int(K) * dSpV_dS(K)) + enddo + endif + elseif (GV%Boussinesq .or. GV%semi_Boussinesq) then do K=1,nzc+1 ; dbuoy_dT(K) = -g_R0 ; dbuoy_dS(K) = 0.0 ; enddo + else + do K=1,nzc+1 ; dbuoy_dS(K) = 0.0 ; enddo + dbuoy_dT(1) = -GV%g_Earth_Z_T2 / GV%Rlay(1) + do K=2,nzc + dbuoy_dT(K) = -GV%g_Earth_Z_T2 / (0.5*(GV%Rlay(k-1) + GV%Rlay(k))) + enddo + dbuoy_dT(nzc+1) = -GV%g_Earth_Z_T2 / GV%Rlay(nzc) endif ! N2_debug(1) = 0.0 ; N2_debug(nzc+1) = 0.0 @@ -828,19 +1164,25 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! enddo ! This call just calculates N2 and S2. - call calculate_projected_state(kappa, u, v, T, Sal, 0.0, nzc, dz, I_dz_int, dbuoy_dT, dbuoy_dS, & + call calculate_projected_state(kappa, u, v, T, Sal, 0.0, nzc, hlay, I_dz_int, dbuoy_dT, dbuoy_dS, & CS%vel_underflow, u, v, T, Sal, N2, S2, GV, US) + do K=1,nzc+1 + N2_init(K) = N2(K) + S2_init(K) = S2(K) + enddo + + ! ---------------------------------------------------- ! Iterate ! ---------------------------------------------------- dt_rem = dt do K=1,nzc+1 K_Q(K) = 0.0 - kappa_avg(K) = 0.0 ; tke_avg(K) = 0.0 + kappa_avg(K) = 0.0 ; tke_avg(K) = 0.0 ; N2_mean(K) = 0.0 ; S2_mean(K) = 0.0 local_src_avg(K) = 0.0 ! Use the grid spacings to scale errors in the source. - if ( dz_Int(K) > 0.0 ) & - local_src_avg(K) = 0.1 * k0dt * I_dz_int(K) / dz_Int(K) + if ( h_Int(K) > 0.0 ) & + local_src_avg(K) = 0.1 * k0dt * I_dz_int(K) / h_Int(K) enddo ! call cpu_clock_end(id_clock_setup) @@ -853,7 +1195,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! ---------------------------------------------------- ! call cpu_clock_begin(id_clock_KQ) - call find_kappa_tke(N2, S2, kappa, Idz, dz_Int, I_L2_bdry, f2, & + call find_kappa_tke(N2, S2, kappa, Idz, h_Int, dz_Int, dz_h_Int, I_L2_bdry, f2, & nzc, CS, GV, US, K_Q, tke, kappa_out, kappa_src, local_src) ! call cpu_clock_end(id_clock_KQ) @@ -891,7 +1233,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! timestep is found long before the minimum is reached, so the ! value of max_KS_it may be unimportant, especially if it is large ! enough. - call calculate_projected_state(kappa_out, u, v, T, Sal, 0.5*dt_test, nzc, dz, I_dz_int, & + call calculate_projected_state(kappa_out, u, v, T, Sal, 0.5*dt_test, nzc, hlay, I_dz_int, & dbuoy_dT, dbuoy_dS, CS%vel_underflow, u_test, v_test, & T_test, S_test, N2, S2, GV, US, ks_int=ks_kappa, ke_int=ke_kappa) valid_dt = .true. @@ -924,7 +1266,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & if ((dt_test < dt_rem) .and. valid_dt) then dt_inc = 0.5*dt_test do itt_dt=1,dt_refinements - call calculate_projected_state(kappa_out, u, v, T, Sal, 0.5*(dt_test+dt_inc), nzc, dz, & + call calculate_projected_state(kappa_out, u, v, T, Sal, 0.5*(dt_test+dt_inc), nzc, hlay, & I_dz_int, dbuoy_dT, dbuoy_dS, CS%vel_underflow, u_test, v_test, T_test, S_test, & N2, S2, GV, US, ks_int=ks_kappa, ke_int=ke_kappa) valid_dt = .true. @@ -973,14 +1315,14 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! call cpu_clock_end(id_clock_avg) else ! call cpu_clock_begin(id_clock_project) - call calculate_projected_state(kappa_out, u, v, T, Sal, dt_now, nzc, dz, I_dz_int, & + call calculate_projected_state(kappa_out, u, v, T, Sal, dt_now, nzc, hlay, I_dz_int, & dbuoy_dT, dbuoy_dS, CS%vel_underflow, u_test, v_test, & T_test, S_test, N2, S2, GV, US, ks_int=ks_kappa, ke_int=ke_kappa) ! call cpu_clock_end(id_clock_project) ! call cpu_clock_begin(id_clock_KQ) do K=1,nzc+1 ; K_Q_tmp(K) = K_Q(K) ; enddo - call find_kappa_tke(N2, S2, kappa_out, Idz, dz_Int, I_L2_bdry, f2, & + call find_kappa_tke(N2, S2, kappa_out, Idz, h_Int, dz_Int, dz_h_Int, I_L2_bdry, f2, & nzc, CS, GV, US, K_Q_tmp, tke_pred, kappa_pred) ! call cpu_clock_end(id_clock_KQ) @@ -992,13 +1334,13 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & enddo ! call cpu_clock_begin(id_clock_project) - call calculate_projected_state(kappa_mid, u, v, T, Sal, dt_now, nzc, dz, I_dz_int, & + call calculate_projected_state(kappa_mid, u, v, T, Sal, dt_now, nzc, hlay, I_dz_int, & dbuoy_dT, dbuoy_dS, CS%vel_underflow, u_test, v_test, & T_test, S_test, N2, S2, GV, US, ks_int=ks_kappa, ke_int=ke_kappa) ! call cpu_clock_end(id_clock_project) ! call cpu_clock_begin(id_clock_KQ) - call find_kappa_tke(N2, S2, kappa_out, Idz, dz_Int, I_L2_bdry, f2, & + call find_kappa_tke(N2, S2, kappa_out, Idz, h_Int, dz_Int, dz_h_Int, I_L2_bdry, f2, & nzc, CS, GV, US, K_Q, tke_pred, kappa_pred) ! call cpu_clock_end(id_clock_KQ) @@ -1008,15 +1350,18 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & kappa_mid(K) = 0.5*(kappa_out(K) + kappa_pred(K)) kappa_avg(K) = kappa_avg(K) + kappa_mid(K)*dt_wt tke_avg(K) = tke_avg(K) + dt_wt*0.5*(tke_pred(K) + tke(K)) + N2_mean(K) = N2_mean(K) + dt_wt*N2(K) + S2_mean(K) = S2_mean(K) + dt_wt*S2(K) kappa(K) = kappa_pred(K) ! First guess for the next iteration. enddo + ! call cpu_clock_end(id_clock_avg) endif if (dt_rem > 0.0) then ! Update the values of u, v, T, Sal, N2, and S2 for the next iteration. ! call cpu_clock_begin(id_clock_project) - call calculate_projected_state(kappa_mid, u, v, T, Sal, dt_now, nzc, dz, I_dz_int, & + call calculate_projected_state(kappa_mid, u, v, T, Sal, dt_now, nzc, hlay, I_dz_int, & dbuoy_dT, dbuoy_dS, CS%vel_underflow, u, v, T, Sal, N2, S2, & GV, US) ! call cpu_clock_end(id_clock_project) @@ -1036,25 +1381,25 @@ subroutine calculate_projected_state(kappa, u0, v0, T0, S0, dt, nz, dz, I_dz_int integer, intent(in) :: nz !< The number of layers (after eliminating massless !! layers?). real, dimension(nz+1), intent(in) :: kappa !< The diapycnal diffusivity at interfaces, - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or Pa s]. real, dimension(nz), intent(in) :: u0 !< The initial zonal velocity [L T-1 ~> m s-1]. real, dimension(nz), intent(in) :: v0 !< The initial meridional velocity [L T-1 ~> m s-1]. - real, dimension(nz), intent(in) :: T0 !< The initial temperature [degC]. - real, dimension(nz), intent(in) :: S0 !< The initial salinity [ppt]. + real, dimension(nz), intent(in) :: T0 !< The initial temperature [C ~> degC]. + real, dimension(nz), intent(in) :: S0 !< The initial salinity [S ~> ppt]. real, intent(in) :: dt !< The time step [T ~> s]. - real, dimension(nz), intent(in) :: dz !< The grid spacing of layers [Z ~> m]. - real, dimension(nz+1), intent(in) :: I_dz_int !< The inverse of the layer's thicknesses - !! [Z-1 ~> m-1]. + real, dimension(nz), intent(in) :: dz !< The layer thicknesses [H ~> m or kg m-2] + real, dimension(nz+1), intent(in) :: I_dz_int !< The inverse of the distance between successive + !! layer centers [Z-1 ~> m-1]. real, dimension(nz+1), intent(in) :: dbuoy_dT !< The partial derivative of buoyancy with - !! temperature [Z T-2 degC-1 ~> m s-2 degC-1]. + !! temperature [Z T-2 C-1 ~> m s-2 degC-1]. real, dimension(nz+1), intent(in) :: dbuoy_dS !< The partial derivative of buoyancy with - !! salinity [Z T-2 ppt-1 ~> m s-2 ppt-1]. + !! salinity [Z T-2 S-1 ~> m s-2 ppt-1]. real, intent(in) :: vel_under !< Any velocities that are smaller in magnitude !! than this value are set to 0 [L T-1 ~> m s-1]. real, dimension(nz), intent(inout) :: u !< The zonal velocity after dt [L T-1 ~> m s-1]. real, dimension(nz), intent(inout) :: v !< The meridional velocity after dt [L T-1 ~> m s-1]. - real, dimension(nz), intent(inout) :: T !< The temperature after dt [degC]. - real, dimension(nz), intent(inout) :: Sal !< The salinity after dt [ppt]. + real, dimension(nz), intent(inout) :: T !< The temperature after dt [C ~> degC]. + real, dimension(nz), intent(inout) :: Sal !< The salinity after dt [S ~> ppt]. real, dimension(nz+1), intent(inout) :: N2 !< The buoyancy frequency squared at interfaces [T-2 ~> s-2]. real, dimension(nz+1), intent(inout) :: S2 !< The squared shear at interfaces [T-2 ~> s-2]. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -1064,10 +1409,11 @@ subroutine calculate_projected_state(kappa, u0, v0, T0, S0, dt, nz, dz, I_dz_int !! diffusivity. ! Local variables - real, dimension(nz+1) :: c1 - real :: L2_to_Z2 ! A conversion factor from horizontal length units to vertical depth - ! units squared [Z2 s2 T-2 m-2 ~> 1]. - real :: a_a, a_b, b1, d1, bd1, b1nz_0 + real, dimension(nz+1) :: c1 ! A tridiagonal variable [nondim] + real :: a_a, a_b ! Tridiagonal coupling coefficients [H ~> m or kg m-2] + real :: b1, b1nz_0 ! Tridiagonal variables [H-1 ~> m-1 or m2 kg-1] + real :: bd1 ! A term in the denominator of b1 [H ~> m or kg m-2] + real :: d1 ! A tridiagonal variable [nondim] integer :: k, ks, ke ks = 1 ; ke = nz @@ -1135,16 +1481,14 @@ subroutine calculate_projected_state(kappa, u0, v0, T0, S0, dt, nz, dz, I_dz_int endif ! Store the squared shear at interfaces - ! L2_to_Z2 = US%m_to_Z**2 * US%T_to_s**2 - L2_to_Z2 = US%L_to_Z**2 S2(1) = 0.0 ; S2(nz+1) = 0.0 if (ks > 1) & - S2(ks) = ((u(ks)-u0(ks-1))**2 + (v(ks)-v0(ks-1))**2) * (L2_to_Z2*I_dz_int(ks)**2) + S2(ks) = (((u(ks)-u0(ks-1))**2) + ((v(ks)-v0(ks-1))**2)) * (US%L_to_Z*I_dz_int(ks))**2 do K=ks+1,ke - S2(K) = ((u(k)-u(k-1))**2 + (v(k)-v(k-1))**2) * (L2_to_Z2*I_dz_int(K)**2) + S2(K) = (((u(k)-u(k-1))**2) + ((v(k)-v(k-1))**2)) * (US%L_to_Z*I_dz_int(K))**2 enddo if (ke This subroutine calculates new, consistent estimates of TKE and kappa. -subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & +subroutine find_kappa_tke(N2, S2, kappa_in, Idz, h_Int, dz_Int, dz_h_Int, I_L2_bdry, f2, & nz, CS, GV, US, K_Q, tke, kappa, kappa_src, local_src) integer, intent(in) :: nz !< The number of layers to work on. real, dimension(nz+1), intent(in) :: N2 !< The buoyancy frequency squared at interfaces [T-2 ~> s-2]. real, dimension(nz+1), intent(in) :: S2 !< The squared shear at interfaces [T-2 ~> s-2]. real, dimension(nz+1), intent(in) :: kappa_in !< The initial guess at the diffusivity - !! [Z2 T-1 ~> m2 s-1]. - real, dimension(nz+1), intent(in) :: dz_Int !< The thicknesses associated with interfaces - !! [Z-1 ~> m-1]. + !! [H Z T-1 ~> m2 s-1 or Pa s] + real, dimension(nz+1), intent(in) :: h_Int !< The thicknesses associated with interfaces + !! [H ~> m or kg m-2] + real, dimension(nz+1), intent(in) :: dz_Int !< The vertical distances around interfaces [Z ~> m] + real, dimension(nz+1), intent(in) :: dz_h_Int !< The ratio of the vertical distances to the + !! thickness around an interface [Z H-1 ~> nondim or m3 kg-1]. + !! In non-Boussinesq mode this is the specific volume. real, dimension(nz+1), intent(in) :: I_L2_bdry !< The inverse of the squared distance to - !! boundaries [Z-2 ~> m-2]. + !! boundaries [H-1 Z-1 ~> m-2 or m kg-1]. real, dimension(nz), intent(in) :: Idz !< The inverse grid spacing of layers [Z-1 ~> m-1]. real, intent(in) :: f2 !< The squared Coriolis parameter [T-2 ~> s-2]. type(Kappa_shear_CS), pointer :: CS !< A pointer to this module's control structure. @@ -1180,82 +1528,85 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(nz+1), intent(inout) :: K_Q !< The shear-driven diapycnal diffusivity divided by !! the turbulent kinetic energy per unit mass at - !! interfaces [T ~> s]. + !! interfaces [H T Z-1 ~> s or kg s m-3]. real, dimension(nz+1), intent(out) :: tke !< The turbulent kinetic energy per unit mass at !! interfaces [Z2 T-2 ~> m2 s-2]. - real, dimension(nz+1), intent(out) :: kappa !< The diapycnal diffusivity at interfaces - !! [Z2 T-1 ~> m2 s-1]. + real, dimension(nz+1), intent(out) :: kappa !< The diapycnal diffusivity at interfaces + !! [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(nz+1), optional, & - intent(out) :: kappa_src !< The source term for kappa [T-1 ~> s-1]. + intent(out) :: kappa_src !< The source term for kappa [T-1 ~> s-1] real, dimension(nz+1), optional, & - intent(out) :: local_src !< The sum of all local sources for kappa, - !! [T-1 ~> s-1]. + intent(out) :: local_src !< The sum of all local sources for kappa + !! [T-1 ~> s-1] ! This subroutine calculates new, consistent estimates of TKE and kappa. ! Local variables real, dimension(nz) :: & - aQ, & ! aQ is the coupling between adjacent interfaces in the TKE equations [Z T-1 ~> m s-1]. + aQ, & ! aQ is the coupling between adjacent interfaces in the TKE equations [H T-1 ~> m s-1 or kg m-2 s-1] dQdz ! Half the partial derivative of TKE with depth [Z T-2 ~> m s-2]. real, dimension(nz+1) :: & - dK, & ! The change in kappa [Z2 T-1 ~> m2 s-1]. + dK, & ! The change in kappa [H Z T-1 ~> m2 s-1 or Pa s]. dQ, & ! The change in TKE [Z2 T-2 ~> m2 s-2]. cQ, cK, & ! cQ and cK are the upward influences in the tridiagonal and ! hexadiagonal solvers for the TKE and kappa equations [nondim]. - I_Ld2, & ! 1/Ld^2, where Ld is the effective decay length scale for kappa [Z-2 ~> m-2]. + I_Ld2, & ! 1/Ld^2, where Ld is the effective decay length scale for kappa [H-1 Z-1 ~> m-2 or m kg-1] TKE_decay, & ! The local TKE decay rate [T-1 ~> s-1]. k_src, & ! The source term in the kappa equation [T-1 ~> s-1]. - dQmdK, & ! With Newton's method the change in dQ(k-1) due to dK(k) [T ~> s]. - dKdQ, & ! With Newton's method the change in dK(k) due to dQ(k) [T-1 ~> s-1]. + dQmdK, & ! With Newton's method the change in dQ(k-1) due to dK(k) [Z T H-1 ~> s or m3 s kg-1] + dKdQ, & ! With Newton's method the change in dK(k) due to dQ(k) [H Z-1 T-1 ~> s-1 or kg m-3 s-1] e1 ! The fractional change in a layer TKE due to a change in the - ! TKE of the layer above when all the kappas below are 0. + ! TKE of the layer above when all the kappas below are 0 [nondim]. ! e1 is nondimensional, and 0 < e1 < 1. - real :: tke_src ! The net source of TKE due to mixing against the shear - ! and stratification [Z2 T-3 ~> m2 s-3]. (For convenience, - ! a term involving the non-dissipation of q0 is also - ! included here.) - real :: bQ ! The inverse of the pivot in the tridiagonal equations [T Z-1 ~> s m-1]. + real :: tke_src ! The net source of TKE due to mixing against the shear and stratification + ! [Z2 T-3 ~> m2 s-3] or [H Z T-3 ~> m2 s-3 or kg m-1 s-3]. + ! (For convenience, a term involving the non-dissipation of q0 is also included here.) + real :: bQ ! The inverse of the pivot in the tridiagonal equations [T H-1 ~> s m-1 or m2 s kg-1] real :: bK ! The inverse of the pivot in the tridiagonal equations [Z-1 ~> m-1]. - real :: bQd1 ! A term in the denominator of bQ [Z T-1 ~> m s-1]. + real :: bQd1 ! A term in the denominator of bQ [H T-1 ~> m s-1 or kg m-2 s-1] real :: bKd1 ! A term in the denominator of bK [Z ~> m]. - real :: cQcomp, cKcomp ! 1 - cQ or 1 - cK in the tridiagonal equations. + real :: cQcomp, cKcomp ! 1 - cQ or 1 - cK in the tridiagonal equations [nondim]. real :: c_s2 ! The coefficient for the decay of TKE due to - ! shear (i.e. proportional to |S|*tke), nondimensional. + ! shear (i.e. proportional to |S|*tke) [nondim]. real :: c_n2 ! The coefficient for the decay of TKE due to ! stratification (i.e. proportional to N*tke) [nondim]. real :: Ri_crit ! The critical shear Richardson number for shear- - ! driven mixing. The theoretical value is 0.25. + ! driven mixing [nondim]. The theoretical value is 0.25. real :: q0 ! The background level of TKE [Z2 T-2 ~> m2 s-2]. real :: Ilambda2 ! 1.0 / CS%lambda**2 [nondim] real :: TKE_min ! The minimum value of shear-driven TKE that can be ! solved for [Z2 T-2 ~> m2 s-2]. - real :: kappa0 ! The background diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. - real :: kappa_trunc ! Diffusivities smaller than this are rounded to 0 [Z2 T-1 ~> m2 s-1]. + real :: kappa0 ! The background diapycnal diffusivity [H Z T-1 ~> m2 s-1 or Pa s] + real :: kappa_trunc ! Diffusivities smaller than this are rounded to 0 [H Z T-1 ~> m2 s-1 or Pa s] - real :: eden1, eden2, I_eden, ome ! Variables used in calculating e1. - real :: diffusive_src ! The diffusive source in the kappa equation [Z T-1 ~> m s-1]. + real :: eden1, eden2 ! Variables used in calculating e1 [H Z-2 ~> m-1 or kg m-4] + real :: I_eden ! The inverse of the denominator in e1 [Z2 H-1 ~> m or m4 kg-1] + real :: ome ! Variables used in calculating e1 [nondim] + real :: diffusive_src ! The diffusive source in the kappa equation [H T-1 ~> m s-1 or kg m-2 s-1] real :: chg_by_k0 ! The value of k_src that leads to an increase of - ! kappa_0 if only the diffusive term is a sink [T-1 ~> s-1]. + ! kappa_0 if only the diffusive term is a sink [T-1 ~> s-1] + real :: h_dz_here ! The ratio of the thicknesses to the vertical distances around an interface + ! [H Z-1 ~> nondim or kg m-3]. In non-Boussinesq mode this is the density. - real :: kappa_mean ! A mean value of kappa [Z2 T-1 ~> m2 s-1]. + real :: kappa_mean ! A mean value of kappa [H Z T-1 ~> m2 s-1 or Pa s] real :: Newton_test ! The value of relative error that will cause the next - ! iteration to use Newton's method. + ! iteration to use Newton's method [nondim]. ! Temporary variables used in the Newton's method iterations. - real :: decay_term_k ! The decay term in the diffusivity equation - real :: decay_term_Q ! The decay term in the TKE equation - proportional to [T-1 ~> s-1] + real :: decay_term_k ! The decay term in the diffusivity equation [Z-1 ~> m-1] + real :: decay_term_Q ! The decay term in the TKE equation - proportional to [H Z-1 T-1 ~> s-1 or kg m-3 s-1] real :: I_Q ! The inverse of TKE [T2 Z-2 ~> s2 m-2] - real :: kap_src - real :: v1 ! A temporary variable proportional to [T-1 ~> s-1] - real :: v2 - real :: tol_err ! The tolerance for max_err that determines when to - ! stop iterating. - real :: Newton_err ! The tolerance for max_err that determines when to - ! start using Newton's method. Empirically, an initial - ! value of about 0.2 seems to be most efficient. - real, parameter :: roundoff = 1.0e-16 ! A negligible fractional change in TKE. - ! This could be larger but performance gains are small. + real :: kap_src ! A source term in the kappa equation [H T-1 ~> m s-1 or kg m-2 s-1] + real :: v1 ! A temporary variable proportional to [H Z-1 T-1 ~> s-1 or kg m-3 s-1] + real :: v2 ! A temporary variable in [Z T-2 ~> m s-2] + real :: tol_err ! The tolerance for max_err that determines when to + ! stop iterating [nondim]. + real :: Newton_err ! The tolerance for max_err that determines when to + ! start using Newton's method [nondim]. Empirically, an initial + ! value of about 0.2 seems to be most efficient. + real, parameter :: roundoff = 1.0e-16 ! A negligible fractional change in TKE [nondim]. + ! This could be larger but performance gains are small. logical :: tke_noflux_bottom_BC = .false. ! Specify the boundary conditions - logical :: tke_noflux_top_BC = .false. ! that are applied to the TKE eqns. + logical :: tke_noflux_top_BC = .false. ! that are applied to the TKE equations. logical :: do_Newton ! If .true., use Newton's method for the next iteration. logical :: abort_Newton ! If .true., an Newton's method has encountered a 0 ! pivot, and should not have been used. @@ -1269,10 +1620,11 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! These variables are used only for debugging. logical, parameter :: debug_soln = .false. - real :: K_err_lin, Q_err_lin, TKE_src_norm + real :: K_err_lin ! The imbalance in the K equation [H T-1 ~> m s-1 or kg m-2 s-1] + real :: Q_err_lin ! The imbalance in the Q equation [H Z T-3 ~> m2 s-3 or kg m-1 s-3] real, dimension(nz+1) :: & - I_Ld2_debug, & ! A separate version of I_Ld2 for debugging [Z-2 ~> m-2]. - kappa_prev, & ! The value of kappa at the start of the current iteration [Z2 T-1 ~> m2 s-1]. + I_Ld2_debug, & ! A separate version of I_Ld2 for debugging [H-1 Z-1 ~> m-2 or m kg-1]. + kappa_prev, & ! The value of kappa at the start of the current iteration [H Z T-1 ~> m2 s-1 or Pa s] TKE_prev ! The value of TKE at the start of the current iteration [Z2 T-2 ~> m2 s-2]. c_N2 = CS%C_N**2 ; c_S2 = CS%C_S**2 @@ -1330,14 +1682,14 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! k-1, the final changes in TKE are related by dQ(K+1) = e1(K+1)*dQ(K). eden2 = kappa0 * Idz(nz) if (tke_noflux_bottom_BC) then - eden1 = dz_Int(nz+1)*TKE_decay(nz+1) + eden1 = h_Int(nz+1)*TKE_decay(nz+1) I_eden = 1.0 / (eden2 + eden1) e1(nz+1) = eden2 * I_eden ; ome = eden1 * I_eden else e1(nz+1) = 0.0 ; ome = 1.0 endif do k=nz,2,-1 - eden1 = dz_Int(K)*TKE_decay(K) + ome * eden2 + eden1 = h_Int(K)*TKE_decay(K) + ome * eden2 eden2 = kappa0 * Idz(k-1) I_eden = 1.0 / (eden2 + eden1) e1(K) = eden2 * I_eden ; ome = eden1 * I_eden ! = 1-e1 @@ -1367,20 +1719,20 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & enddo dQ(1) = -TKE(1) if (tke_noflux_top_BC) then - tke_src = kappa0*S2(1) + q0 * TKE_decay(1) ! Uses that kappa(1) = 0 - bQd1 = dz_Int(1) * TKE_decay(1) + tke_src = dz_h_Int(1)*kappa0*S2(1) + q0 * TKE_decay(1) ! Uses that kappa(1) = 0 + bQd1 = h_Int(1) * TKE_decay(1) bQ = 1.0 / (bQd1 + aQ(1)) - tke(1) = bQ * (dz_Int(1)*tke_src) + tke(1) = bQ * (h_Int(1)*tke_src) cQ(2) = aQ(1) * bQ ; cQcomp = bQd1 * bQ ! = 1 - cQ else tke(1) = q0 ; cQ(2) = 0.0 ; cQcomp = 1.0 endif do K=2,ke_tke-1 dQ(K) = -TKE(K) - tke_src = (kappa(K) + kappa0)*S2(K) + q0*TKE_decay(K) - bQd1 = dz_Int(K)*(TKE_decay(K) + N2(K)*K_Q(K)) + cQcomp*aQ(k-1) + tke_src = dz_h_Int(K)*(kappa(K) + kappa0)*S2(K) + q0*TKE_decay(K) + bQd1 = h_Int(K)*(TKE_decay(K) + dz_h_Int(K)*N2(K)*K_Q(K)) + cQcomp*aQ(k-1) bQ = 1.0 / (bQd1 + aQ(k)) - tke(K) = bQ * (dz_Int(K)*tke_src + aQ(k-1)*tke(K-1)) + tke(K) = bQ * (h_Int(K)*tke_src + aQ(k-1)*tke(K-1)) cQ(K+1) = aQ(k) * bQ ; cQcomp = bQd1 * bQ ! = 1 - cQ enddo if ((ke_tke == nz+1) .and. .not.(tke_noflux_bottom_BC)) then @@ -1388,18 +1740,18 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & dQ(nz+1) = 0.0 else k = ke_tke - tke_src = kappa0*S2(K) + q0*TKE_decay(K) ! Uses that kappa(ke_tke) = 0 + tke_src = dz_h_Int(K)*kappa0*S2(K) + q0*TKE_decay(K) ! Uses that kappa(ke_tke) = 0 if (K == nz+1) then dQ(K) = -TKE(K) - bQ = 1.0 / (dz_Int(K)*TKE_decay(K) + cQcomp*aQ(k-1)) - tke(K) = max(TKE_min, bQ * (dz_Int(K)*tke_src + aQ(k-1)*tke(K-1))) + bQ = 1.0 / (h_Int(K)*TKE_decay(K) + cQcomp*aQ(k-1)) + tke(K) = max(TKE_min, bQ * (h_Int(K)*tke_src + aQ(k-1)*tke(K-1))) dQ(K) = tke(K) + dQ(K) else - bQ = 1.0 / ((dz_Int(K)*TKE_decay(K) + cQcomp*aQ(k-1)) + aQ(k)) + bQ = 1.0 / ((h_Int(K)*TKE_decay(K) + cQcomp*aQ(k-1)) + aQ(k)) cQ(K+1) = aQ(k) * bQ ! Account for all changes deeper in the water column. dQ(K) = -TKE(K) - tke(K) = max((bQ * (dz_Int(K)*tke_src + aQ(k-1)*tke(K-1)) + & + tke(K) = max((bQ * (h_Int(K)*tke_src + aQ(k-1)*tke(K-1)) + & cQ(K+1)*(tke(K+1) - e1(K+1)*tke(K))) / (1.0 - cQ(K+1)*e1(K+1)), TKE_min) dQ(K) = tke(K) + dQ(K) @@ -1429,17 +1781,17 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & dK(1) = 0.0 ! kappa takes boundary values of 0. cK(2) = 0.0 ; cKcomp = 1.0 - if (itt == 1) then ; dO K=2,nz - I_Ld2(K) = (N2(K)*Ilambda2 + f2) / tke(K) + I_L2_bdry(K) + if (itt == 1) then ; do K=2,nz + I_Ld2(K) = dz_h_Int(K)*(N2(K)*Ilambda2 + f2) / tke(K) + I_L2_bdry(K) enddo ; endif do K=2,nz dK(K) = -kappa(K) if (itt>1) & - I_Ld2(K) = (N2(K)*Ilambda2 + f2) / tke(K) + I_L2_bdry(K) - bKd1 = dz_Int(K)*I_Ld2(K) + cKcomp*Idz(k-1) + I_Ld2(K) = dz_h_Int(K)*(N2(K)*Ilambda2 + f2) / tke(K) + I_L2_bdry(K) + bKd1 = h_Int(K)*I_Ld2(K) + cKcomp*Idz(k-1) bK = 1.0 / (bKd1 + Idz(k)) - kappa(K) = bK * (Idz(k-1)*kappa(K-1) + dz_Int(K) * K_src(K)) + kappa(K) = bK * (Idz(k-1)*kappa(K-1) + h_Int(K) * K_src(K)) cK(K+1) = Idz(k) * bK ; cKcomp = bKd1 * bK ! = 1 - cK(K+1) ! Neglect values that are smaller than kappa_trunc. @@ -1479,12 +1831,12 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & aQ(1) = (0.5*(kappa(1)+kappa(2))+kappa0) * Idz(1) dQdz(1) = 0.5*(TKE(1) - TKE(2))*Idz(1) if (tke_noflux_top_BC) then - tke_src = dz_Int(1) * (kappa0*S2(1) - (TKE(1) - q0)*TKE_decay(1)) - & + tke_src = h_Int(1) * (kappa0*dz_h_Int(1)*S2(1) - (TKE(1) - q0)*TKE_decay(1)) - & aQ(1) * (TKE(1) - TKE(2)) - bQ = 1.0 / (aQ(1) + dz_Int(1)*TKE_decay(1)) + bQ = 1.0 / (aQ(1) + h_Int(1)*TKE_decay(1)) cQ(2) = aQ(1) * bQ - cQcomp = (dz_Int(1)*TKE_decay(1)) * bQ ! = 1 - cQ(2) + cQcomp = (h_Int(1)*TKE_decay(1)) * bQ ! = 1 - cQ(2) dQmdK(2) = -dQdz(1) * bQ dQ(1) = bQ * tke_src else @@ -1492,14 +1844,14 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & endif do K=2,nz I_Q = 1.0 / TKE(K) - I_Ld2(K) = (N2(K)*Ilambda2 + f2) * I_Q + I_L2_bdry(K) + I_Ld2(K) = (N2(K)*Ilambda2 + f2) * dz_h_Int(K)*I_Q + I_L2_bdry(K) - kap_src = dz_Int(K) * (K_src(K) - I_Ld2(K)*kappa(K)) + & + kap_src = h_Int(K) * (K_src(K) - I_Ld2(K)*kappa(K)) + & Idz(k-1)*(kappa(K-1)-kappa(K)) - Idz(k)*(kappa(K)-kappa(K+1)) ! Ensure that the pivot is always positive, and that 0 <= cK <= 1. ! Otherwise do not use Newton's method. - decay_term_k = -Idz(k-1)*dQmdK(K)*dKdQ(K-1) + dz_Int(K)*I_Ld2(K) + decay_term_k = -Idz(k-1)*dQmdK(K)*dKdQ(K-1) + h_Int(K)*I_Ld2(K) if (decay_term_k < 0.0) then ; abort_Newton = .true. ; exit ; endif bK = 1.0 / (Idz(k) + Idz(k-1)*cKcomp + decay_term_k) @@ -1525,8 +1877,8 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! Solve for dQ(K)... aQ(k) = (0.5*(kappa(K)+kappa(K+1))+kappa0) * Idz(k) dQdz(k) = 0.5*(TKE(K) - TKE(K+1))*Idz(k) - tke_src = dz_Int(K) * (((kappa(K) + kappa0)*S2(K) - kappa(k)*N2(K)) - & - (TKE(k) - q0)*TKE_decay(k)) - & + tke_src = h_Int(K) * ((dz_h_Int(K) * ((kappa(K) + kappa0)*S2(K) - kappa(k)*N2(K))) - & + (TKE(k) - q0)*TKE_decay(k)) - & (aQ(k) * (TKE(K) - TKE(K+1)) - aQ(k-1) * (TKE(K-1) - TKE(K))) v1 = aQ(k-1) + dQdz(k-1)*dKdQ(K-1) v2 = (v1*dQmdK(K) + dQdz(k-1)*cK(K)) + & @@ -1534,7 +1886,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! Ensure that the pivot is always positive, and that 0 <= cQ <= 1. ! Otherwise do not use Newton's method. - decay_term_Q = dz_Int(K)*TKE_decay(K) - dQdz(k-1)*dKdQ(K-1)*cQ(K) - v2*dKdQ(K) + decay_term_Q = h_Int(K)*TKE_decay(K) - dQdz(k-1)*dKdQ(K-1)*cQ(K) - v2*dKdQ(K) if (decay_term_Q < 0.0) then ; abort_Newton = .true. ; exit ; endif bQ = 1.0 / (aQ(k) + (cQcomp*aQ(k-1) + decay_term_Q)) @@ -1557,11 +1909,11 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & dK(nz+1) = 0.0 ; dKdQ(nz+1) = 0.0 if (tke_noflux_bottom_BC) then K = nz+1 - tke_src = dz_Int(K) * (kappa0*S2(K) - (TKE(K) - q0)*TKE_decay(K)) + & + tke_src = h_Int(K) * (kappa0*dz_h_Int(K)*S2(K) - (TKE(K) - q0)*TKE_decay(K)) + & aQ(k-1) * (TKE(K-1) - TKE(K)) v1 = aQ(k-1) + dQdz(k-1)*dKdQ(K-1) - decay_term_Q = max(0.0, dz_Int(K)*TKE_decay(K) - dQdz(k-1)*dKdQ(K-1)*cQ(K)) + decay_term_Q = max(0.0, h_Int(K)*TKE_decay(K) - dQdz(k-1)*dKdQ(K-1)*cQ(K)) if (decay_term_Q < 0.0) then abort_Newton = .true. else @@ -1581,9 +1933,9 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & if (debug_soln .and. (K < nz+1)) then ! Ignore this source? aQ(k) = (0.5*(kappa(K)+kappa(K+1))+kappa0) * Idz(k) - ! tke_src_norm = (dz_Int(K) * (kappa0*S2(K) - (TKE(K)-q0)*TKE_decay(K)) - & + ! tke_src_norm = ((kappa0*dz_Int(K)*S2(K) - h_Int(K)*(TKE(K)-q0)*TKE_decay(K)) - & ! (aQ(k) * (TKE(K) - TKE(K+1)) - aQ(k-1) * (TKE(K-1) - TKE(K))) ) / & - ! (aQ(k) + (aQ(k-1) + dz_Int(K)*TKE_decay(K))) + ! (aQ(k) + (aQ(k-1) + h_Int(K)*TKE_decay(K))) endif dK(K) = 0.0 ! Ensure that TKE+dQ will not drop below 0.5*TKE. @@ -1622,23 +1974,24 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! The unit conversions here have not been carefully tested. if (debug_soln) then ; do K=2,nz ! In these equations, K_err_lin and Q_err_lin should be at round-off levels - ! compared with the dominant terms, perhaps, dz_Int*I_Ld2*kappa and - ! dz_Int*TKE_decay*TKE. The exception is where, either 1) the decay term has been + ! compared with the dominant terms, perhaps, h_Int*I_Ld2*kappa and + ! h_Int*TKE_decay*TKE. The exception is where, either 1) the decay term has been ! been increased to ensure a positive pivot, or 2) negative TKEs have been ! truncated, or 3) small or negative kappas have been rounded toward 0. I_Q = 1.0 / TKE(K) - I_Ld2_debug(K) = (N2(K)*Ilambda2 + f2) * I_Q + I_L2_bdry(K) + I_Ld2_debug(K) = (N2(K)*Ilambda2 + f2) * dz_h_Int(K)*I_Q + I_L2_bdry(K) - kap_src = dz_Int(K) * (K_src(K) - I_Ld2(K)*kappa_prev(K)) + & + kap_src = h_Int(K) * (k_src(K) - I_Ld2(K)*kappa_prev(K)) + & (Idz(k-1)*(kappa_prev(k-1)-kappa_prev(k)) - & Idz(k)*(kappa_prev(k)-kappa_prev(k+1))) K_err_lin = -Idz(k-1)*(dK(K-1)-dK(K)) + Idz(k)*(dK(K)-dK(K+1)) + & - dz_Int(K)*I_Ld2_debug(K)*dK(K) - kap_src - & + h_Int(K)*I_Ld2_debug(K)*dK(K) - kap_src - & dz_Int(K)*(N2(K)*Ilambda2 + f2)*I_Q**2*kappa_prev(K) * dQ(K) - tke_src = dz_Int(K) * ((kappa_prev(K) + kappa0)*S2(K) - & - kappa_prev(K)*N2(K) - (TKE_prev(K) - q0)*TKE_decay(K)) - & - (aQ(k) * (TKE_prev(K) - TKE_prev(K+1)) - aQ(k-1) * (TKE_prev(K-1) - TKE_prev(K))) + h_dz_here = 0.0 ; if (abs(dz_h_Int(K)) > 0.0) h_dz_here = 1.0 / dz_h_Int(K) + tke_src = h_Int(K) * ((kappa_prev(K) + kappa0)*S2(K) - & + kappa_prev(K)*N2(K) - (TKE_prev(K) - q0)*h_dz_here*TKE_decay(K)) - & + (aQ(k) * (TKE_prev(K) - TKE_prev(K+1)) - aQ(k-1) * (TKE_prev(K-1) - TKE_prev(K))) Q_err_lin = tke_src + (aQ(k-1) * (dQ(K-1)-dQ(K)) - aQ(k) * (dQ(k)-dQ(k+1))) - & 0.5*(TKE_prev(K)-TKE_prev(K+1))*Idz(k) * (dK(K) + dK(K+1)) - & 0.5*(TKE_prev(K)-TKE_prev(K-1))*Idz(k-1)* (dK(K-1) + dK(K)) + & @@ -1698,11 +2051,11 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & local_src(1) = 0.0 ; local_src(nz+1) = 0.0 do K=2,nz diffusive_src = Idz(k-1)*(kappa(K-1)-kappa(K)) + Idz(k)*(kappa(K+1)-kappa(K)) - chg_by_k0 = kappa0 * ((Idz(k-1)+Idz(k)) / dz_Int(K) + I_Ld2(K)) + chg_by_k0 = kappa0 * ((Idz(k-1)+Idz(k)) / h_Int(K) + I_Ld2(K)) if (diffusive_src <= 0.0) then local_src(K) = K_src(K) + chg_by_k0 else - local_src(K) = (K_src(K) + chg_by_k0) + diffusive_src / dz_Int(K) + local_src(K) = (K_src(K) + chg_by_k0) + diffusive_src / h_Int(K) endif enddo endif @@ -1730,15 +2083,18 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) logical :: kappa_shear_init !< True if module is to be used, False otherwise ! Local variables + real :: KD_normal ! The KD of the main model, read here only as a parameter + ! for setting the default of KD_SMOOTH [Z2 T-1 ~> m2 s-1] + real :: kappa_0_default ! The default value for KD_KAPPA_SHEAR_0 [Z2 T-1 ~> m2 s-1] logical :: merge_mixedlayer + integer :: number_of_OBC_segments logical :: debug_shear + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. logical :: just_read ! If true, this module is not used, so only read the parameters. ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_kappa_shear" ! This module's name. - real :: kappa_0_unscaled ! The value of kappa_0 in MKS units [m2 s-1] - real :: KD_normal ! The KD of the main model, read here only as a parameter - ! for setting the default of KD_SMOOTH in MKS units [m2 s-1] if (associated(CS)) then call MOM_error(WARNING, "kappa_shear_init called with an associated "// & @@ -1769,6 +2125,37 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) "If true, do the calculations of the shear-driven mixing "//& "at the cell vertices (i.e., the vorticity points).", & default=.false., do_not_log=just_read) + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. + call get_param(param_file, mdl, "VERTEX_SHEAR_VISCOSITY_BUG", CS%VS_viscosity_bug, & + "If true, use a bug in vertex shear that zeros out viscosities at "//& + "vertices on coastlines.", & + default=enable_bugs, do_not_log=just_read.or.(.not.CS%KS_at_vertex)) + call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", number_of_OBC_segments, & + default=0, do_not_log=.true.) + call get_param(param_file, mdl, "VERTEX_SHEAR_OBC_BUG", CS%vertex_shear_OBC_bug, & + "If false, use extra masking when interpolating thicknesses to velocity "//& + "points for setting up the shear velocities at vertices to avoid using "//& + "external thicknesses at open boundaries. When OBCs are not in use, "//& + "this parameter does not change answers, but true is more efficient.", & + default=enable_bugs, & + do_not_log=just_read.or.(.not.CS%KS_at_vertex).or.(number_of_OBC_segments<=0)) + ! Use OBC settings to set the default for VERTEX_SHEAR_OBC_BUG? + call get_param(param_file, mdl, "VERTEX_SHEAR_GEOMETRIC_MEAN", CS%VS_GeometricMean, & + "If true, use a geometric mean for moving diffusivity from "//& + "vertices to tracer points. False uses algebraic mean.", & + default=.false., do_not_log=just_read.or.(.not.CS%KS_at_vertex)) + call get_param(param_file, mdl, "VERTEX_SHEAR_THICKNESS_MEAN", CS%VS_ThicknessMean, & + "If true, apply thickness weighting to horizontal averagings of diffusivity "//& + "to tracer points in the kappa shear solver.", & + default=.false.) + if (CS%VS_GeometricMean) then + call get_param(param_file, mdl, "VERTEX_SHEAR_GEOMETRIC_MEAN_KDMIN", & + CS%VS_GeoMean_Kdmin, "If using the geometric mean in vertex shear, "//& + "use this minimum value for Kd. This is an ad-hoc parameter, the "//& + "diffusivities on the edge of shear regions are sensitive to the choice.",& + units="m2 s-1", default=0.0, scale=GV%m2_s_to_HZ_T, do_not_log=just_read) + endif call get_param(param_file, mdl, "RINO_CRIT", CS%RiNo_crit, & "The critical Richardson number for shear mixing.", & units="nondim", default=0.25, do_not_log=just_read) @@ -1780,17 +2167,25 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) "The maximum number of iterations that may be used to "//& "estimate the Richardson number driven mixing.", & units="nondim", default=50, do_not_log=just_read) - call get_param(param_file, mdl, "KD", KD_normal, default=0.0, do_not_log=.true.) + call get_param(param_file, mdl, "KD", KD_normal, & + units="m2 s-1", scale=US%m2_s_to_Z2_T, default=0.0, do_not_log=.true.) + kappa_0_default = max(Kd_normal, 1.0e-7*US%m2_s_to_Z2_T) call get_param(param_file, mdl, "KD_KAPPA_SHEAR_0", CS%kappa_0, & "The background diffusivity that is used to smooth the "//& "density and shear profiles before solving for the "//& "diffusivities. The default is the greater of KD and 1e-7 m2 s-1.", & - units="m2 s-1", default=max(KD_normal, 1.0e-7), scale=US%m2_s_to_Z2_T, & - unscaled=kappa_0_unscaled, do_not_log=just_read) + units="m2 s-1", default=kappa_0_default*US%Z2_T_to_m2_s, scale=GV%m2_s_to_HZ_T, & + do_not_log=just_read) + call get_param(param_file, mdl, "KD_SEED_KAPPA_SHEAR", CS%kappa_seed, & + "A moderately large seed value of diapycnal diffusivity that is used as a "//& + "starting turbulent diffusivity in the iterations to find an energetically "//& + "constrained solution for the shear-driven diffusivity.", & + units="m2 s-1", default=1.0, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "KD_TRUNC_KAPPA_SHEAR", CS%kappa_trunc, & "The value of shear-driven diffusivity that is considered negligible "//& "and is rounded down to 0. The default is 1% of KD_KAPPA_SHEAR_0.", & - units="m2 s-1", default=0.01*kappa_0_unscaled, scale=US%m2_s_to_Z2_T, do_not_log=just_read) + units="m2 s-1", default=0.01*CS%kappa_0*GV%HZ_T_to_m2_s, scale=GV%m2_s_to_HZ_T, & + do_not_log=just_read) call get_param(param_file, mdl, "FRI_CURVATURE", CS%FRi_curvature, & "The nondimensional curvature of the function of the "//& "Richardson number in the kappa source term in the "//& @@ -1816,6 +2211,11 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) "Set this to 0 (the default) to eliminate the shear scale. "//& "This is only used if USE_JACKSON_PARAM is true.", & units="nondim", default=0.0, do_not_log=just_read) + call get_param(param_file, mdl, "LZ_RESCALE", CS%lz_rescale, & + "A coefficient to rescale the distance to the nearest solid boundary. "//& + "This adjustment is to account for regions where 3 dimensional turbulence "//& + "prevents the growth of shear instabilities [nondim].", & + units="nondim", default=1.0) call get_param(param_file, mdl, "KAPPA_SHEAR_TOL_ERR", CS%kappa_tol_err, & "The fractional error in kappa that is tolerated. "//& "Iteration stops when changes between subsequent "//& @@ -1835,11 +2235,11 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) default=.true., do_not_log=just_read) call get_param(param_file, mdl, "MAX_KAPPA_SHEAR_IT", CS%max_KS_it, & "The maximum number of iterations that may be used to "//& - "estimate the time-averaged diffusivity.", units="nondim", & + "estimate the time-averaged diffusivity.", & default=13, do_not_log=just_read) call get_param(param_file, mdl, "PRANDTL_TURB", CS%Prandtl_turb, & "The turbulent Prandtl number applied to shear instability.", & - units="nondim", default=1.0, do_not_log=.true.) + units="nondim", default=1.0, do_not_log=just_read) call get_param(param_file, mdl, "VEL_UNDERFLOW", CS%vel_underflow, & "A negligibly small velocity magnitude below which velocity components are set "//& "to 0. A reasonable value might be 1e-30 m/s, which is less than an "//& @@ -1862,7 +2262,7 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "KAPPA_SHEAR_VERTEX_PSURF_BUG", CS%psurf_bug, & "If true, do a simple average of the cell surface pressures to get a pressure "//& "at the corner if VERTEX_SHEAR=True. Otherwise mask out any land points in "//& - "the average.", default=.true., do_not_log=(just_read .or. (.not.CS%KS_at_vertex))) + "the average.", default=.false., do_not_log=(just_read .or. (.not.CS%KS_at_vertex))) call get_param(param_file, mdl, "KAPPA_SHEAR_ITER_BUG", CS%dKdQ_iteration_bug, & "If true, use an older, dimensionally inconsistent estimate of the "//& @@ -1896,9 +2296,38 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) CS%diag => diag CS%id_Kd_shear = register_diag_field('ocean_model','Kd_shear', diag%axesTi, Time, & - 'Shear-driven Diapycnal Diffusivity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) - CS%id_TKE = register_diag_field('ocean_model','TKE_shear', diag%axesTi, Time, & - 'Shear-driven Turbulent Kinetic Energy', 'm2 s-2', conversion=US%Z_to_m**2*US%s_to_T**2) + 'Shear-driven Diapycnal Diffusivity at horizontal tracer points', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) + if (CS%KS_at_vertex) then + CS%id_TKE = register_diag_field('ocean_model','TKE_shear', diag%axesBi, Time, & + 'Shear-driven Turbulent Kinetic Energy at horizontal vertices', 'm2 s-2', conversion=US%Z_to_m**2*US%s_to_T**2) + CS%id_Kd_vertex = register_diag_field('ocean_model','Kd_shear_vertex', diag%axesBi, Time, & + 'Shear-driven Diapycnal Diffusivity at horizontal vertices', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) + CS%id_S2_init = register_diag_field('ocean_model','S2_shear_in', diag%axesBi, Time, & + 'Interface shear squared at horizontal vertices, as input to kappa-shear', 's-2', conversion=US%s_to_T**2) + CS%id_N2_init = register_diag_field('ocean_model','N2_shear_in', diag%axesBi, Time, & + 'Interface stratification at horizontal vertices, as input to kappa-shear', 's-2', conversion=US%s_to_T**2) + CS%id_S2_mean = register_diag_field('ocean_model','S2_shear_mean', diag%axesBi, Time, & + 'Interface shear squared at horizontal vertices, averaged over timestep in kappa-shear', & + 's-2', conversion=US%s_to_T**2) + CS%id_N2_mean = register_diag_field('ocean_model','N2_shear_mean', diag%axesBi, Time, & + 'Interface stratification at horizontal vertices, averaged over timestep in kappa-shear', & + 's-2', conversion=US%s_to_T**2) + else + CS%id_TKE = register_diag_field('ocean_model','TKE_shear', diag%axesTi, Time, & + 'Shear-driven Turbulent Kinetic Energy at horizontal tracer points', & + 'm2 s-2', conversion=US%Z_to_m**2*US%s_to_T**2) + CS%id_S2_init = register_diag_field('ocean_model','S2_shear_in', diag%axesTi, Time, & + 'Interface shear squared at horizontal tracer points, as input to kappa-shear', 's-2', conversion=US%s_to_T**2) + CS%id_N2_init = register_diag_field('ocean_model','N2_shear_in', diag%axesTi, Time, & + 'Interface stratification at horizontal tracer points, as input to kappa-shear', & + 's-2', conversion=US%s_to_T**2) + CS%id_S2_mean = register_diag_field('ocean_model','S2_shear_mean', diag%axesTi, Time, & + 'Interface shear squared at horizontal tracer points, averaged over timestep in kappa-shear', & + 's-2', conversion=US%s_to_T**2) + CS%id_N2_mean = register_diag_field('ocean_model','N2_shear_mean', diag%axesTi, Time, & + 'Interface stratification at horizontal tracer points, averaged ove timestep in kappa-shear', & + 's-2', conversion=US%s_to_T**2) + endif end function kappa_shear_init @@ -1954,7 +2383,7 @@ end function kappa_shear_at_vertex !! TKE with shear and stratification fixed, then marches the density !! and velocities forward with an adaptive (and aggressive) time step !! in a predictor-corrector-corrector emulation of a trapezoidal -!! scheme. Run-time-settable parameters determine the tolerence to +!! scheme. Run-time-settable parameters determine the tolerance to !! which the kappa and TKE equations are solved and the minimum time !! step that can be taken. diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index 02d49d024d..02c9958e6e 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Routines used to calculate the opacity of the ocean. module MOM_opacity -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_diag_mediator, only : time_type, diag_ctrl, safe_alloc_ptr, post_data use MOM_diag_mediator, only : query_averaging_enabled, register_diag_field use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING @@ -17,7 +19,7 @@ module MOM_opacity #include -public set_opacity, opacity_init, opacity_end, opacity_manizza, opacity_morel +public set_opacity, opacity_init, opacity_end public extract_optics_slice, extract_optics_fields, optics_nbands public absorbRemainingSW, sumSWoverBands @@ -25,7 +27,7 @@ module MOM_opacity type, public :: optics_type integer :: nbands !< The number of penetrating bands of SW radiation - real, allocatable :: opacity_band(:,:,:,:) !< SW optical depth per unit thickness [m-1] + real, allocatable :: opacity_band(:,:,:,:) !< SW optical depth per unit thickness [Z-1 ~> m-1] !! The number of radiation bands is most rapidly varying (first) index. real, allocatable :: sw_pen_band(:,:,:) !< shortwave radiation [Q R Z T-1 ~> W m-2] @@ -38,16 +40,29 @@ module MOM_opacity !< The maximum wavelength in each band of penetrating shortwave radiation [nm] real :: PenSW_flux_absorb !< A heat flux that is small enough to be completely absorbed in the next - !! sufficiently thick layer [H degC T-1 ~> degC m s-1 or degC kg m-2 s-1]. + !! sufficiently thick layer [C H T-1 ~> degC m s-1 or degC kg m-2 s-1]. real :: PenSW_absorb_Invlen !< The inverse of the thickness that is used to absorb the remaining - !! shortwave heat flux when it drops below PEN_SW_FLUX_ABSORB [H ~> m or kg m-2]. - logical :: answers_2018 !< If true, use the order of arithmetic and expressions that recover the - !! answers from the end of 2018. Otherwise, use updated and more robust - !! forms of the same expressions. + !! shortwave heat flux when it drops below PEN_SW_FLUX_ABSORB [H ~> m or kg m-2]. + + !! Lookup tables for Ohlmann solar penetration scheme + !! These would naturally exist as private module variables but that is prohibited in MOM6 + real :: dlog10chl !< Chl increment within lookup table [log10 of Chl in mg m-3] + real :: chl_min !< Lower bound of Chl in lookup table [mg m-3] + real :: log10chl_min !< Lower bound of Chl in lookup table [log10 of Chl in mg m-3] + real :: log10chl_max !< Upper bound of Chl in lookup table [log10 of Chl in mg m-3] + real, allocatable, dimension(:) :: a1_lut,& !< Coefficient for band 1 [nondim] + & a2_lut,& !< Coefficient for band 2 [nondim] + & b1_lut,& !< Exponential decay scale for band 1 [Z-1 ~> m-1] + & b2_lut !< Exponential decay scale for band 2 [Z-1 ~> m-1] + + integer :: answer_date !< The vintage of the order of arithmetic and expressions in the optics + !! 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. end type optics_type -!> The control structure with paramters for the MOM_opacity module +!> The control structure with parameters for the MOM_opacity module type, public :: opacity_CS ; private logical :: var_pen_sw !< If true, use one of the CHL_A schemes (specified by OPACITY_SCHEME) to !! determine the e-folding depth of incoming shortwave radiation. @@ -55,18 +70,32 @@ module MOM_opacity !! water properties into the opacity (i.e., the e-folding depth) and !! (perhaps) the number of bands of penetrating shortwave radiation to use. real :: pen_sw_scale !< The vertical absorption e-folding depth of the - !! penetrating shortwave radiation [m]. + !! penetrating shortwave radiation [Z ~> m]. real :: pen_sw_scale_2nd !< The vertical absorption e-folding depth of the - !! (2nd) penetrating shortwave radiation [m]. - real :: SW_1ST_EXP_RATIO !< Ratio for 1st exp decay in Two Exp decay opacity + !! (2nd) penetrating shortwave radiation [Z ~> m]. + real :: SW_1ST_EXP_RATIO !< Ratio for 1st exp decay in Two Exp decay opacity [nondim] real :: pen_sw_frac !< The fraction of shortwave radiation that is - !! penetrating with a constant e-folding approach. + !! penetrating with a constant e-folding approach [nondim] real :: blue_frac !< The fraction of the penetrating shortwave !! radiation that is in the blue band [nondim]. - real :: opacity_land_value !< The value to use for opacity over land [m-1]. + real :: opacity_land_value !< The value to use for opacity over land [Z-1 ~> m-1]. !! The default is 10 m-1 - a value for muddy water. + real, allocatable, dimension(:,:) & + :: opacity_coef !< Groups of coefficients, in [Z-1 ~> m-1] or [Z ~> m] depending on the + !! scheme, in expressions for opacity, with the second index being the + !! wavelength band. For example, when OPACITY_SCHEME = MANIZZA_05, + !! these are coef_1 and coef_2 in the + !! expression opacity = coef_1 + coef_2 * chl**pow. + real, allocatable, dimension(:) & + :: sw_pen_frac_coef !< Coefficients in the expression for the penetrating shortwave + !! fracetion [nondim] + real, allocatable, dimension(:) & + :: chl_power !< Powers of chlorophyll [nondim] for each band for expressions for + !! opacity of the form opacity = coef_1 + coef_2 * chl**pow. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. + integer :: chl_dep_bands !< The number of bands that depend on the Chlorophyll concentrations. + logical :: warning_issued !< A flag that is used to avoid repetitive warnings. !>@{ Diagnostic IDs integer :: id_sw_pen = -1, id_sw_vis_pen = -1 @@ -75,17 +104,16 @@ module MOM_opacity end type opacity_CS !>@{ Coded integers to specify the opacity scheme -integer, parameter :: NO_SCHEME = 0, MANIZZA_05 = 1, MOREL_88 = 2, SINGLE_EXP = 3, DOUBLE_EXP = 4 +integer, parameter :: NO_SCHEME = 0, MANIZZA_05 = 1, MOREL_88 = 2, SINGLE_EXP = 3, DOUBLE_EXP = 4,& + & OHLMANN_03 = 5 !>@} character*(10), parameter :: MANIZZA_05_STRING = "MANIZZA_05" !< String to specify the opacity scheme character*(10), parameter :: MOREL_88_STRING = "MOREL_88" !< String to specify the opacity scheme +character*(10), parameter :: OHLMANN_03_STRING = "OHLMANN_03" !< String to specify the opacity scheme character*(10), parameter :: SINGLE_EXP_STRING = "SINGLE_EXP" !< String to specify the opacity scheme character*(10), parameter :: DOUBLE_EXP_STRING = "DOUBLE_EXP" !< String to specify the opacity scheme -real, parameter :: op_diag_len = 1e-10 !< Lengthscale L used to remap opacity - !! from op to 1/L * tanh(op * L) - contains !> This sets the opacity of sea water based based on one of several different schemes. @@ -103,24 +131,24 @@ subroutine set_opacity(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir, sw_ type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(opacity_CS) :: CS !< The control structure earlier set up by opacity_init. real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(in) :: chl_2d !< Vertically uniform chlorophyll-A concentractions [mg m-3] + optional, intent(in) :: chl_2d !< Vertically uniform chlorophyll-A concentrations [mg m-3] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - optional, intent(in) :: chl_3d !< The chlorophyll-A concentractions of each layer [mg m-3] + optional, intent(in) :: chl_3d !< The chlorophyll-A concentrations of each layer [mg m-3] ! Local variables integer :: i, j, k, n, is, ie, js, je, nz - real :: inv_sw_pen_scale ! The inverse of the e-folding scale [m-1]. + real :: inv_sw_pen_scale ! The inverse of the e-folding scale [Z-1 ~> m-1]. real :: Inv_nbands ! The inverse of the number of bands of penetrating - ! shortwave radiation. - logical :: call_for_surface ! if horizontal slice is the surface layer - real :: tmp(SZI_(G),SZJ_(G),SZK_(GV)) ! A 3-d temporary array. - real :: chl(SZI_(G),SZJ_(G),SZK_(GV)) ! The concentration of chlorophyll-A [mg m-3]. + ! shortwave radiation [nondim] + real :: tmp(SZI_(G),SZJ_(G),SZK_(GV)) ! A 3-d temporary array for diagnosing opacity [Z-1 ~> m-1] real :: Pen_SW_tot(SZI_(G),SZJ_(G)) ! The penetrating shortwave radiation ! summed across all bands [Q R Z T-1 ~> W m-2]. + real :: op_diag_len ! A tiny lengthscale [Z ~> m] used to remap diagnostics of opacity + ! from op to 1/op_diag_len * tanh(op * op_diag_len) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (present(chl_2d) .or. present(chl_3d)) then - ! The optical properties are based on cholophyll concentrations. + ! The optical properties are based on chlorophyll concentrations. call opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir, sw_nir_dif, & G, GV, US, CS, chl_2d, chl_3d) else ! Use sw e-folding scale set by MOM_input @@ -128,14 +156,14 @@ subroutine set_opacity(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir, sw_ else ; Inv_nbands = 1.0 / real(optics%nbands) ; endif ! Make sure there is no division by 0. - inv_sw_pen_scale = 1.0 / max(CS%pen_sw_scale, 0.1*GV%Angstrom_m, & - GV%H_to_m*GV%H_subroundoff) + inv_sw_pen_scale = 1.0 / max(CS%pen_sw_scale, 0.1*GV%Angstrom_Z, & + GV%dZ_subroundoff) if ( CS%Opacity_scheme == DOUBLE_EXP ) then !$OMP parallel do default(shared) do k=1,nz ; do j=js,je ; do i=is,ie optics%opacity_band(1,i,j,k) = inv_sw_pen_scale optics%opacity_band(2,i,j,k) = 1.0 / max(CS%pen_sw_scale_2nd, & - 0.1*GV%Angstrom_m,GV%H_to_m*GV%H_subroundoff) + 0.1*GV%Angstrom_Z, GV%dZ_subroundoff) enddo ; enddo ; enddo if (.not.associated(sw_total) .or. (CS%pen_SW_scale <= 0.0)) then !$OMP parallel do default(shared) @@ -199,11 +227,12 @@ subroutine set_opacity(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir, sw_ call post_data(CS%id_sw_vis_pen, Pen_SW_tot, CS%diag) endif do n=1,optics%nbands ; if (CS%id_opacity(n) > 0) then + op_diag_len = 1.0e-10*US%m_to_Z ! A minimal extinction depth to constrain the range of opacity [Z ~> m] !$OMP parallel do default(shared) do k=1,nz ; do j=js,je ; do i=is,ie ! Remap opacity (op) to 1/L * tanh(op * L) where L is one Angstrom. ! This gives a nearly identical value when op << 1/L but allows one to - ! store the values when opacity is divergent (i.e. opaque). + ! record the values even at reduced precision when opacity is huge (i.e. opaque). tmp(i,j,k) = tanh(op_diag_len * optics%opacity_band(n,i,j,k)) / op_diag_len enddo ; enddo ; enddo call post_data(CS%id_opacity(n), tmp, CS%diag) @@ -213,12 +242,12 @@ subroutine set_opacity(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir, sw_ end subroutine set_opacity -!> This sets the "blue" band opacity based on chloophyll A concencentrations +!> This sets the "blue" band opacity based on chlorophyll A concentrations !! The red portion is lumped into the net heating at the surface. subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir, sw_nir_dif, & G, GV, US, CS, chl_2d, chl_3d) type(optics_type), intent(inout) :: optics !< An optics structure that has values - !! set based on the opacities. + !! set based on the opacities. real, dimension(:,:), pointer :: sw_total !< Total shortwave flux into the ocean [Q R Z T-1 ~> W m-2] real, dimension(:,:), pointer :: sw_vis_dir !< Visible, direct shortwave into the ocean [Q R Z T-1 ~> W m-2] real, dimension(:,:), pointer :: sw_vis_dif !< Visible, diffuse shortwave into the ocean [Q R Z T-1 ~> W m-2] @@ -229,25 +258,24 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(opacity_CS) :: CS !< The control structure. real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(in) :: chl_2d !< Vertically uniform chlorophyll-A concentractions [mg m-3] + optional, intent(in) :: chl_2d !< Vertically uniform chlorophyll-A concentrations [mg m-3] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - optional, intent(in) :: chl_3d !< A 3-d field of chlorophyll-A concentractions [mg m-3] + optional, intent(in) :: chl_3d !< A 3-d field of chlorophyll-A concentrations [mg m-3] real :: chl_data(SZI_(G),SZJ_(G)) ! The chlorophyll A concentrations in a layer [mg m-3]. real :: Inv_nbands ! The inverse of the number of bands of penetrating - ! shortwave radiation. + ! shortwave radiation [nondim] real :: Inv_nbands_nir ! The inverse of the number of bands of penetrating - ! near-infrafed radiation. + ! near-infrared radiation [nondim] real :: SW_pen_tot ! The sum across the bands of the penetrating ! shortwave radiation [Q R Z T-1 ~> W m-2]. real :: SW_vis_tot ! The sum across the visible bands of shortwave ! radiation [Q R Z T-1 ~> W m-2]. real :: SW_nir_tot ! The sum across the near infrared bands of shortwave ! radiation [Q R Z T-1 ~> W m-2]. - type(time_type) :: day character(len=128) :: mesg integer :: i, j, k, n, is, ie, js, je, nz, nbands - logical :: multiband_vis_input, multiband_nir_input + logical :: multiband_vis_input, multiband_nir_input, total_sw_input is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -255,11 +283,21 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir ! use the "blue" band in the parameterizations to determine the e-folding ! depth of the incoming shortwave attenuation. The red portion is lumped ! into the net heating at the surface. +! Adding Ohlmann scheme. Needs sw_total and chl as inputs. Produces 2 penetrating bands. +! This implementation follows that in CESM-POP using a lookup table in log10(chl) space. +! The table is initialized in subroutine init_ohlmann and the coefficients are recovered +! with routines lookup_ohlmann_swpen and lookup_ohlmann_opacity. +! Note that this form treats the IR solar input implicitly: the sum of partitioning +! coefficients < 1.0. The remainder is non-penetrating and is deposited in first layer +! irrespective of thickness. The Ohlmann (2003) paper states that the scheme is not valid +! for vertcal grids with first layer thickness < 2.0 meters. +! +! Ohlmann, J.C. Ocean radiant heating in climate models. J. Climate, 16, 1337-1351, 2003. ! ! Morel, A., Optical modeling of the upper ocean in relation to its biogenous -! matter content (case-i waters).,J. Geo. Res., {93}, 10,749--10,768, 1988. +! matter content (case-i waters)., J. Geo. Res., {93}, 10,749--10,768, 1988. ! -! Manizza, M., C.~L. Quere, A.~Watson, and E.~T. Buitenhuis, Bio-optical +! Manizza, M., C. L. Quere, A. Watson, and E. T. Buitenhuis, Bio-optical ! feedbacks among phytoplankton, upper ocean physics and sea-ice in a ! global model, Geophys. Res. Let., , L05,603, 2005. @@ -271,18 +309,27 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir if (nbands <= 2) then ; Inv_nbands_nir = 0.0 else ; Inv_nbands_nir = 1.0 / real(nbands - 2.0) ; endif - multiband_vis_input = (associated(sw_vis_dir) .and. & - associated(sw_vis_dif)) - multiband_nir_input = (associated(sw_nir_dir) .and. & - associated(sw_nir_dif)) + if (.not.(associated(sw_total) .or. (associated(sw_vis_dir) .and. associated(sw_vis_dif) .and. & + associated(sw_nir_dir) .and. associated(sw_nir_dif)) )) then + if (.not.CS%warning_issued) then + call MOM_error(WARNING, & + "opacity_from_chl called without any shortwave flux arrays allocated.\n"//& + "Consider setting PEN_SW_NBANDS = 0 if no shortwave fluxes are being used.") + endif + CS%warning_issued = .true. + endif + + multiband_vis_input = (associated(sw_vis_dir) .and. associated(sw_vis_dif)) + multiband_nir_input = (associated(sw_nir_dir) .and. associated(sw_nir_dif)) + total_sw_input = associated(sw_total) chl_data(:,:) = 0.0 if (present(chl_3d)) then do j=js,je ; do i=is,ie ; chl_data(i,j) = chl_3d(i,j,1) ; enddo ; enddo do k=1,nz ; do j=js,je ; do i=is,ie - if ((G%mask2dT(i,j) > 0.5) .and. (chl_3d(i,j,k) < 0.0)) then + if ((G%mask2dT(i,j) > 0.0) .and. (chl_3d(i,j,k) < 0.0)) then write(mesg,'(" Negative chl_3d of ",(1pe12.4)," found at i,j,k = ", & - & 3(1x,i3), " lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') & + & 3(1x,I0), " lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') & chl_3d(i,j,k), i, j, k, G%geoLonT(i,j), G%geoLatT(i,j) call MOM_error(FATAL, "MOM_opacity opacity_from_chl: "//trim(mesg)) endif @@ -290,15 +337,15 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir elseif (present(chl_2d)) then do j=js,je ; do i=is,ie ; chl_data(i,j) = chl_2d(i,j) ; enddo ; enddo do j=js,je ; do i=is,ie - if ((G%mask2dT(i,j) > 0.5) .and. (chl_2d(i,j) < 0.0)) then + if ((G%mask2dT(i,j) > 0.0) .and. (chl_2d(i,j) < 0.0)) then write(mesg,'(" Negative chl_2d of ",(1pe12.4)," at i,j = ", & - & 2(i3), "lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') & + & I0,", ",I0," lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') & chl_data(i,j), i, j, G%geoLonT(i,j), G%geoLatT(i,j) call MOM_error(FATAL, "MOM_opacity opacity_from_chl: "//trim(mesg)) endif enddo ; enddo else - call MOM_error(FATAL, "Either chl_2d or chl_3d must be preesnt in a call to opacity_form_chl.") + call MOM_error(FATAL, "Either chl_2d or chl_3d must be present in a call to opacity_form_chl.") endif select case (CS%opacity_scheme) @@ -306,15 +353,16 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir !$OMP parallel do default(shared) private(SW_vis_tot,SW_nir_tot) do j=js,je ; do i=is,ie SW_vis_tot = 0.0 ; SW_nir_tot = 0.0 - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then if (multiband_vis_input) then SW_vis_tot = sw_vis_dir(i,j) + sw_vis_dif(i,j) - else ! Follow Manizza 05 in assuming that 42% of SW is visible. + elseif (total_sw_input) then + ! Follow Manizza 05 in assuming that 42% of SW is visible. SW_vis_tot = 0.42 * sw_total(i,j) endif if (multiband_nir_input) then SW_nir_tot = sw_nir_dir(i,j) + sw_nir_dif(i,j) - else + elseif (total_sw_input) then SW_nir_tot = sw_total(i,j) - SW_vis_tot endif endif @@ -333,15 +381,40 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir !$OMP parallel do default(shared) private(SW_pen_tot) do j=js,je ; do i=is,ie SW_pen_tot = 0.0 - if (G%mask2dT(i,j) > 0.5) then ; if (multiband_vis_input) then - SW_pen_tot = SW_pen_frac_morel(chl_data(i,j)) * (sw_vis_dir(i,j) + sw_vis_dif(i,j)) - else - SW_pen_tot = SW_pen_frac_morel(chl_data(i,j)) * 0.5*sw_total(i,j) - endif ; endif + if (G%mask2dT(i,j) > 0.0) then + if (multiband_vis_input) then + SW_pen_tot = SW_pen_frac_morel(chl_data(i,j), CS) * (sw_vis_dir(i,j) + sw_vis_dif(i,j)) + elseif (total_sw_input) then + SW_pen_tot = SW_pen_frac_morel(chl_data(i,j), CS) * 0.5*sw_total(i,j) + endif + endif do n=1,nbands optics%sw_pen_band(n,i,j) = Inv_nbands*sw_pen_tot enddo + enddo ; enddo + case (OHLMANN_03) + ! want exactly two penetrating bands. If not, throw an error. + if ( nbands /= 2 ) then + call MOM_error(FATAL, "opacity_from_chl: CS%opacity_scheme requires nbands==2.") + endif + !$OMP parallel do default(shared) private(SW_vis_tot) + do j=js,je ; do i=is,ie + SW_vis_tot = 0.0 ! Ohlmann does not classify as vis/nir. Using vis to add up total + if (G%mask2dT(i,j) < 0.5) then + optics%sw_pen_band(1:2,i,j) = 0. ! Make sure there is a valid value for land points + else + if (multiband_vis_input ) then ! If multiband_vis_input is true then so is multiband_nir_input + SW_vis_tot = ((sw_vis_dir(i,j) + sw_vis_dif(i,j)) + sw_nir_dir(i,j)) + sw_nir_dif(i,j) + elseif (total_sw_input) then + SW_vis_tot = sw_total(i,j) + else + call MOM_error(FATAL, "No shortwave input was provided.") + endif + + ! Bands 1-2 (Ohlmann factors A with coefficients for Table 1a) + optics%sw_pen_band(1:2,i,j) = lookup_ohlmann_swpen(chl_data(i,j),optics)*SW_vis_tot + endif enddo ; enddo case default call MOM_error(FATAL, "opacity_from_chl: CS%opacity_scheme is not valid.") @@ -349,6 +422,13 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir !$OMP parallel do default(shared) firstprivate(chl_data) do k=1,nz + !! FOB + !!! I don't think this is what we want to do with Ohlmann. + !!! The surface CHL is used in developing the parameterization. + !!! Only the surface CHL is used above in setting optics%sw_pen_band for all schemes. + !!! Seems inconsistent to use depth dependent CHL in opacity calculation. + !!! Nevertheless, leaving as is for now. + !! FOB if (present(chl_3d)) then do j=js,je ; do i=is,ie ; chl_data(i,j) = chl_3d(i,j,k) ; enddo ; enddo endif @@ -361,118 +441,130 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir optics%opacity_band(n,i,j,k) = CS%opacity_land_value enddo else - ! Band 1 is Manizza blue. - optics%opacity_band(1,i,j,k) = 0.0232 + 0.074*chl_data(i,j)**0.674 - if (nbands >= 2) & ! Band 2 is Manizza red. - optics%opacity_band(2,i,j,k) = 0.225 + 0.037*chl_data(i,j)**0.629 - ! All remaining bands are NIR, for lack of something better to do. - do n=3,nbands ; optics%opacity_band(n,i,j,k) = 2.86 ; enddo + do n=1,CS%chl_dep_bands + optics%opacity_band(n,i,j,k) = CS%opacity_coef(1,n) + & + CS%opacity_coef(2,n) * chl_data(i,j)**CS%chl_power(n) + enddo + do n=CS%chl_dep_bands+1,optics%nbands ! These bands do not depend on the chlorophyll. + ! Any nonzero values that were in opacity_coef(2,n) have been added to opacity_coef(1,n). + optics%opacity_band(n,i,j,k) = CS%opacity_coef(1,n) + enddo endif enddo ; enddo case (MOREL_88) do j=js,je ; do i=is,ie optics%opacity_band(1,i,j,k) = CS%opacity_land_value - if (G%mask2dT(i,j) > 0.5) & - optics%opacity_band(1,i,j,k) = opacity_morel(chl_data(i,j)) + if (G%mask2dT(i,j) > 0.0) & + optics%opacity_band(1,i,j,k) = opacity_morel(chl_data(i,j), CS) do n=2,optics%nbands optics%opacity_band(n,i,j,k) = optics%opacity_band(1,i,j,k) enddo enddo ; enddo - + case (OHLMANN_03) + !! not testing for 2 bands since we did it above + do j=js,je ; do i=is,ie + if (G%mask2dT(i,j) <= 0.5) then + optics%opacity_band(1:2,i,j,k) = CS%opacity_land_value + else + ! Bands 1-2 (Ohlmann factors B with coefficients for Table 1a + optics%opacity_band(1:2,i,j,k) = lookup_ohlmann_opacity(chl_data(i,j),optics) * US%Z_to_m + endif + enddo ; enddo case default call MOM_error(FATAL, "opacity_from_chl: CS%opacity_scheme is not valid.") end select enddo - end subroutine opacity_from_chl !> This sets the blue-wavelength opacity according to the scheme proposed by !! Morel and Antoine (1994). -function opacity_morel(chl_data) - real, intent(in) :: chl_data !< The chlorophyll-A concentration in mg m-3. - real :: opacity_morel !< The returned opacity [m-1] +function opacity_morel(chl_data, CS) + real, intent(in) :: chl_data !< The chlorophyll-A concentration in [mg m-3] + type(opacity_CS) :: CS !< Opacity control structure + real :: opacity_morel !< The returned opacity [Z-1 ~> m-1] - ! The following are coefficients for the optical model taken from Morel and - ! Antoine (1994). These coeficients represent a non uniform distribution of - ! chlorophyll-a through the water column. Other approaches may be more - ! appropriate when using an interactive ecosystem model that predicts - ! three-dimensional chl-a values. - real, dimension(6), parameter :: & - Z2_coef = (/7.925, -6.644, 3.662, -1.815, -0.218, 0.502/) - real :: Chl, Chl2 ! The log10 of chl_data (in mg m-3), and Chl^2. + real :: Chl, Chl2 ! The log10 of chl_data (in mg m-3), and Chl^2 [nondim] Chl = log10(min(max(chl_data,0.02),60.0)) ; Chl2 = Chl*Chl - opacity_morel = 1.0 / ( (Z2_coef(1) + Z2_coef(2)*Chl) + Chl2 * & - ((Z2_coef(3) + Chl*Z2_coef(4)) + Chl2*(Z2_coef(5) + Chl*Z2_coef(6))) ) -end function + ! All frequency bands currently use the same opacities. + opacity_morel = 1.0 / ( (CS%opacity_coef(1,1) + CS%opacity_coef(2,1)*Chl) + Chl2 * & + ((CS%opacity_coef(3,1) + Chl*CS%opacity_coef(4,1)) + & + Chl2*(CS%opacity_coef(5,1) + Chl*CS%opacity_coef(6,1))) ) +end function opacity_morel !> This sets the penetrating shortwave fraction according to the scheme proposed by !! Morel and Antoine (1994). -function SW_pen_frac_morel(chl_data) - real, intent(in) :: chl_data !< The chlorophyll-A concentration in mg m-3. +function SW_pen_frac_morel(chl_data, CS) + real, intent(in) :: chl_data !< The chlorophyll-A concentration [mg m-3] + type(opacity_CS) :: CS !< Opacity control structure real :: SW_pen_frac_morel !< The returned penetrating shortwave fraction [nondim] ! The following are coefficients for the optical model taken from Morel and - ! Antoine (1994). These coeficients represent a non uniform distribution of + ! Antoine (1994). These coefficients represent a non uniform distribution of ! chlorophyll-a through the water column. Other approaches may be more ! appropriate when using an interactive ecosystem model that predicts ! three-dimensional chl-a values. - real :: Chl, Chl2 ! The log10 of chl_data in mg m-3, and Chl^2. - real, dimension(6), parameter :: & - V1_coef = (/0.321, 0.008, 0.132, 0.038, -0.017, -0.007/) + real :: Chl, Chl2 ! The log10 of chl_data in mg m-3, and Chl^2 [nondim] Chl = log10(min(max(chl_data,0.02),60.0)) ; Chl2 = Chl*Chl - SW_pen_frac_morel = 1.0 - ( (V1_coef(1) + V1_coef(2)*Chl) + Chl2 * & - ((V1_coef(3) + Chl*V1_coef(4)) + Chl2*(V1_coef(5) + Chl*V1_coef(6))) ) + SW_pen_frac_morel = 1.0 - ( (CS%SW_pen_frac_coef(1) + CS%SW_pen_frac_coef(2)*Chl) + Chl2 * & + ((CS%SW_pen_frac_coef(3) + Chl*CS%SW_pen_frac_coef(4)) + & + Chl2*(CS%SW_pen_frac_coef(5) + Chl*CS%SW_pen_frac_coef(6))) ) end function SW_pen_frac_morel -!> This sets the blue-wavelength opacity according to the scheme proposed by -!! Manizza, M. et al, 2005. -function opacity_manizza(chl_data) - real, intent(in) :: chl_data !< The chlorophyll-A concentration in mg m-3. - real :: opacity_manizza !< The returned opacity [m-1] -! This sets the blue-wavelength opacity according to the scheme proposed by Manizza, M. et al, 2005. - - opacity_manizza = 0.0232 + 0.074*chl_data**0.674 -end function - !> This subroutine returns a 2-d slice at constant j of fields from an optics_type, with the potential !! for rescaling these fields. -subroutine extract_optics_slice(optics, j, G, GV, opacity, opacity_scale, penSW_top, penSW_scale) +subroutine extract_optics_slice(optics, j, G, GV, opacity, opacity_scale, penSW_top, penSW_scale, SpV_avg) type(optics_type), intent(in) :: optics !< An optics structure that has values of opacities !! and shortwave fluxes. integer, intent(in) :: j !< j-index to extract type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(max(optics%nbands,1),SZI_(G),SZK_(GV)), & - optional, intent(out) :: opacity !< The opacity in each band, i-point, and layer - real, optional, intent(in) :: opacity_scale !< A factor by which to rescale the opacity. + optional, intent(out) :: opacity !< The opacity in each band, i-point, and layer [Z-1 ~> m-1], + !! but with units that can be altered by opacity_scale + !! and the presence of SpV_avg to change this to other + !! units like [H-1 ~> m-1 or m2 kg-1] + real, optional, intent(in) :: opacity_scale !< A factor by which to rescale the opacity [nondim] or + !! [Z H-1 ~> 1 or m3 kg-1] real, dimension(max(optics%nbands,1),SZI_(G)), & optional, intent(out) :: penSW_top !< The shortwave radiation [Q R Z T-1 ~> W m-2] !! at the surface in each of the nbands bands !! that penetrates beyond the surface skin layer. - real, optional, intent(in) :: penSW_scale !< A factor by which to rescale the shortwave flux. + real, optional, intent(in) :: penSW_scale !< A factor by which to rescale the shortwave flux [nondim] + !! or other units. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: SpV_avg !< The layer-averaged specific volume [R-1 ~> m3 kg-1] + !! that is used along with opacity_scale in non-Boussinesq + !! cases to change the opacity from distance based units to + !! mass-based units ! Local variables - real :: scale_opacity, scale_penSW ! Rescaling factors + real :: scale_opacity ! A rescaling factor for opacity [nondim], or the same units as opacity_scale. + real :: scale_penSW ! A rescaling factor for the penetrating shortwave radiation [nondim] or the + ! same units as penSW_scale integer :: i, is, ie, k, nz, n is = G%isc ; ie = G%iec ; nz = GV%ke scale_opacity = 1.0 ; if (present(opacity_scale)) scale_opacity = opacity_scale scale_penSW = 1.0 ; if (present(penSW_scale)) scale_penSW = penSW_scale - if (present(opacity)) then ; do k=1,nz ; do i=is,ie - do n=1,optics%nbands - opacity(n,i,k) = scale_opacity * optics%opacity_band(n,i,j,k) - enddo - enddo ; enddo ; endif + if (present(opacity)) then + if (present(SpV_avg)) then + do k=1,nz ; do i=is,ie ; do n=1,optics%nbands + opacity(n,i,k) = (scale_opacity * SpV_avg(i,j,k)) * optics%opacity_band(n,i,j,k) + enddo ; enddo ; enddo + else + do k=1,nz ; do i=is,ie ; do n=1,optics%nbands + opacity(n,i,k) = scale_opacity * optics%opacity_band(n,i,j,k) + enddo ; enddo ; enddo + endif + endif - if (present(penSW_top)) then ; do k=1,nz ; do i=is,ie - do n=1,optics%nbands - penSW_top(n,i) = scale_penSW * optics%sw_pen_band(n,i,j) - enddo + if (present(penSW_top)) then ; do i=is,ie ; do n=1,optics%nbands + penSW_top(n,i) = scale_penSW * optics%sw_pen_band(n,i,j) enddo ; enddo ; endif end subroutine extract_optics_slice @@ -489,14 +581,18 @@ end subroutine extract_optics_fields !> Return the number of bands of penetrating shortwave radiation. function optics_nbands(optics) - type(optics_type), intent(in) :: optics !< An optics structure that has values of opacities + type(optics_type), pointer :: optics !< An optics structure that has values of opacities !! and shortwave fluxes. integer :: optics_nbands !< The number of penetrating bands of SW radiation - optics_nbands = optics%nbands + if (associated(optics)) then + optics_nbands = optics%nbands + else + optics_nbands = 0 + endif end function optics_nbands -!> Apply shortwave heating below the boundary layer (when running with the bulk mixed layer inhereted +!> Apply shortwave heating below the boundary layer (when running with the bulk mixed layer inherited !! from GOLD) or throughout the water column. !! !! In addition, it causes all of the remaining SW radiation to be absorbed, provided that the total @@ -515,7 +611,7 @@ subroutine absorbRemainingSW(G, GV, US, h, opacity_band, nsw, optics, j, dt, H_l real, dimension(SZI_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. real, dimension(max(1,nsw),SZI_(G),SZK_(GV)), intent(in) :: opacity_band !< Opacity in each band of penetrating !! shortwave radiation [H-1 ~> m-1 or m2 kg-1]. - !! The indicies are band, i, k. + !! The indices are band, i, k. type(optics_type), intent(in) :: optics !< An optics structure that has values of !! opacities and shortwave fluxes. integer, intent(in) :: j !< j-index to work on. @@ -539,28 +635,28 @@ subroutine absorbRemainingSW(G, GV, US, h, opacity_band, nsw, optics, j, dt, H_l !! shortwave that should be absorbed by !! each layer. real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: T !< Layer potential/conservative - !! temperatures [degC] + !! temperatures [C ~> degC] real, dimension(max(1,nsw),SZI_(G)), intent(inout) :: Pen_SW_bnd !< Penetrating shortwave heating in !! each band that hits the bottom and will !! will be redistributed through the water - !! column [degC H ~> degC m or degC kg m-2], + !! column [C H ~> degC m or degC kg m-2], !! size nsw x SZI_(G). real, dimension(SZI_(G),SZK_(GV)), optional, intent(in) :: eps !< Small thickness that must remain in !! each layer, and which will not be !! subject to heating [H ~> m or kg m-2] - integer, dimension(SZI_(G),SZK_(GV)), optional, intent(in) :: ksort !< Density-sorted k-indicies. + integer, dimension(SZI_(G),SZK_(GV)), optional, intent(in) :: ksort !< Density-sorted k-indices. real, dimension(SZI_(G)), optional, intent(in) :: htot !< Total mixed layer thickness [H ~> m or kg m-2]. real, dimension(SZI_(G)), optional, intent(inout) :: Ttot !< Depth integrated mixed layer - !! temperature [degC H ~> degC m or degC kg m-2] + !! temperature [C H ~> degC m or degC kg m-2] real, dimension(SZI_(G),SZK_(GV)), optional, intent(in) :: dSV_dT !< The partial derivative of specific volume - !! with temperature [R-1 degC-1 ~> m3 kg-1 degC-1] + !! with temperature [R-1 C-1 ~> m3 kg-1 degC-1] real, dimension(SZI_(G),SZK_(GV)), optional, intent(inout) :: TKE !< The TKE sink from mixing the heating !! throughout a layer [R Z3 T-2 ~> J m-2]. ! Local variables real, dimension(SZI_(G),SZK_(GV)) :: & T_chg_above ! A temperature change that will be applied to all the thick - ! layers above a given layer [degC]. This is only nonzero if + ! layers above a given layer [C ~> degC]. This is only nonzero if ! adjustAbsorptionProfile is true, in which case the net ! change in the temperature of a layer is the sum of the ! direct heating of that layer plus T_chg_above from all of @@ -570,14 +666,14 @@ subroutine absorbRemainingSW(G, GV, US, h, opacity_band, nsw, optics, j, dt, H_l h_heat, & ! The thickness of the water column that will be heated by ! any remaining shortwave radiation [H ~> m or kg m-2]. T_chg, & ! The temperature change of thick layers due to the remaining - ! shortwave radiation and contributions from T_chg_above [degC]. + ! shortwave radiation and contributions from T_chg_above [C ~> degC]. Pen_SW_rem ! The sum across all wavelength bands of the penetrating shortwave ! heating that hits the bottom and will be redistributed through - ! the water column [degC H ~> degC m or degC kg m-2] + ! the water column [C H ~> degC m or degC kg m-2] real :: SW_trans ! fraction of shortwave radiation that is not ! absorbed in a layer [nondim] real :: unabsorbed ! fraction of the shortwave radiation that - ! is not absorbed because the layers are too thin + ! is not absorbed because the layers are too thin [nondim] real :: Ih_limit ! inverse of the total depth at which the ! surface fluxes start to be limited [H-1 ~> m-1 or m2 kg-1] real :: h_min_heat ! minimum thickness layer that should get heated [H ~> m or kg m-2] @@ -585,13 +681,13 @@ subroutine absorbRemainingSW(G, GV, US, h, opacity_band, nsw, optics, j, dt, H_l real :: exp_OD ! exp(-opt_depth) [nondim] real :: heat_bnd ! heating due to absorption in the current ! layer by the current band, including any piece that - ! is moved upward [degC H ~> degC m or degC kg m-2] + ! is moved upward [C H ~> degC m or degC kg m-2] real :: SWa ! fraction of the absorbed shortwave that is ! moved to layers above with adjustAbsorptionProfile [nondim] - real :: coSWa_frac ! The fraction of SWa that is actually moved upward. + real :: coSWa_frac ! The fraction of SWa that is actually moved upward [nondim] real :: min_SW_heat ! A minimum remaining shortwave heating within a timestep that will be simply ! absorbed in the next layer for computational efficiency, instead of - ! continuing to penetrate [degC H ~> degC m or degC kg m-2]. + ! continuing to penetrate [C H ~> degC m or degC kg m-2]. real :: I_Habs ! The inverse of the absorption length for a minimal flux [H-1 ~> m-1 or m2 kg-1] real :: epsilon ! A small thickness that must remain in each ! layer, and which will not be subject to heating [H ~> m or kg m-2] @@ -601,10 +697,12 @@ subroutine absorbRemainingSW(G, GV, US, h, opacity_band, nsw, optics, j, dt, H_l ! was not entirely absorbed. logical :: TKE_calc ! If true, calculate the implications to the ! TKE budget of the shortwave heating. - real :: C1_6, C1_60 + real :: C1_6, C1_60 ! Rational fractions [nondim] integer :: is, ie, nz, i, k, ks, n - SW_Remains = .false. + if (nsw < 1) return + + SW_Remains = .false. min_SW_heat = optics%PenSW_flux_absorb * dt I_Habs = optics%PenSW_absorb_Invlen @@ -614,10 +712,10 @@ subroutine absorbRemainingSW(G, GV, US, h, opacity_band, nsw, optics, j, dt, H_l TKE_calc = (present(TKE) .and. present(dSV_dT)) - if (optics%answers_2018) then - g_Hconv2 = (US%L_to_Z**2*GV%g_Earth * GV%H_to_RZ) * GV%H_to_RZ + if (optics%answer_date < 20190101) then + g_Hconv2 = (GV%g_Earth_Z_T2 * GV%H_to_RZ) * GV%H_to_RZ else - g_Hconv2 = US%L_to_Z**2*GV%g_Earth * GV%H_to_RZ**2 + g_Hconv2 = GV%g_Earth_Z_T2 * GV%H_to_RZ**2 endif h_heat(:) = 0.0 @@ -644,7 +742,7 @@ subroutine absorbRemainingSW(G, GV, US, h, opacity_band, nsw, optics, j, dt, H_l ! Heating at a very small rate can be absorbed by a sufficiently thick layer or several ! thin layers without further penetration. - if (optics%answers_2018) then + if (optics%answer_date < 20190101) then if (nsw*Pen_SW_bnd(n,i)*SW_trans < min_SW_heat*min(1.0, I_Habs*h(i,k)) ) SW_trans = 0.0 elseif ((nsw*Pen_SW_bnd(n,i)*SW_trans < min_SW_heat) .and. (h(i,k) > h_min_heat)) then if (nsw*Pen_SW_bnd(n,i) <= min_SW_heat * (I_Habs*(h(i,k) - h_min_heat))) then @@ -774,13 +872,15 @@ end subroutine absorbRemainingSW !> This subroutine calculates the total shortwave heat flux integrated over !! bands as a function of depth. This routine is only called for computing !! buoyancy fluxes for use in KPP. This routine does not update the state. -subroutine sumSWoverBands(G, GV, US, h, nsw, optics, j, dt, & +subroutine sumSWoverBands(G, GV, US, h, dz, nsw, optics, j, dt, & H_limit_fluxes, absorbAllSW, iPen_SW_bnd, netPen) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: dz !< Layer vertical extent [Z ~> m]. integer, intent(in) :: nsw !< The number of bands of penetrating shortwave !! radiation, perhaps from optics_nbands(optics), type(optics_type), intent(in) :: optics !< An optics structure that has values @@ -794,30 +894,30 @@ subroutine sumSWoverBands(G, GV, US, h, nsw, optics, j, dt, & !! radiation is absorbed in the ocean water column. real, dimension(max(nsw,1),SZI_(G)), intent(in) :: iPen_SW_bnd !< The incident penetrating shortwave !! in each band at the sea surface; size nsw x SZI_(G) - !! [degC H ~> degC m or degC kg m-2]. + !! [C H ~> degC m or degC kg m-2]. real, dimension(SZI_(G),SZK_(GV)+1), & intent(inout) :: netPen !< Net penetrating shortwave heat flux at each !! interface, summed across all bands - !! [degC H ~> degC m or degC kg m-2]. + !! [C H ~> degC m or degC kg m-2]. ! Local variables real :: h_heat(SZI_(G)) ! thickness of the water column that receives ! remaining shortwave radiation [H ~> m or kg m-2]. real :: Pen_SW_rem(SZI_(G)) ! sum across all wavelength bands of the ! penetrating shortwave heating that hits the bottom ! and will be redistributed through the water column - ! [degC H ~> degC m or degC kg m-2] + ! [C H ~> degC m or degC kg m-2] real, dimension(max(nsw,1),SZI_(G)) :: Pen_SW_bnd ! The remaining penetrating shortwave radiation - ! in each band, initially iPen_SW_bnd [degC H ~> degC m or degC kg m-2] + ! in each band, initially iPen_SW_bnd [C H ~> degC m or degC kg m-2] real :: SW_trans ! fraction of shortwave radiation not ! absorbed in a layer [nondim] real :: unabsorbed ! fraction of the shortwave radiation - ! not absorbed because the layers are too thin. + ! not absorbed because the layers are too thin [nondim]. real :: Ih_limit ! inverse of the total depth at which the ! surface fluxes start to be limited [H-1 ~> m-1 or m2 kg-1] real :: min_SW_heat ! A minimum remaining shortwave heating within a timestep that will be simply ! absorbed in the next layer for computational efficiency, instead of - ! continuing to penetrate [degC H ~> degC m or degC kg m-2]. + ! continuing to penetrate [C H ~> degC m or degC kg m-2]. real :: I_Habs ! The inverse of the absorption length for a minimal flux [H-1 ~> m-1 or m2 kg-1] real :: h_min_heat ! minimum thickness layer that should get heated [H ~> m or kg m-2] real :: opt_depth ! optical depth of a layer [nondim] @@ -825,15 +925,19 @@ subroutine sumSWoverBands(G, GV, US, h, nsw, optics, j, dt, & logical :: SW_Remains ! If true, some column has shortwave radiation that ! was not entirely absorbed. - integer :: is, ie, nz, i, k, ks, n + integer :: is, ie, nz, i, k, n SW_Remains = .false. - min_SW_heat = optics%PenSW_flux_absorb*dt ! Default of 2.5e-11*US%T_to_s*GV%m_to_H I_Habs = 1e3*GV%H_to_m ! optics%PenSW_absorb_Invlen h_min_heat = 2.0*GV%Angstrom_H + GV%H_subroundoff is = G%isc ; ie = G%iec ; nz = GV%ke + if (nsw < 1) then + netPen(:,:) = 0.0 + return + endif + pen_SW_bnd(:,:) = iPen_SW_bnd(:,:) do i=is,ie ; h_heat(i) = 0.0 ; enddo do i=is,ie @@ -845,6 +949,7 @@ subroutine sumSWoverBands(G, GV, US, h, nsw, optics, j, dt, & ! Apply penetrating SW radiation to remaining parts of layers. ! Excessively thin layers are not heated to avoid runaway temps. + min_SW_heat = optics%PenSW_flux_absorb*dt ! Default of 2.5e-11*US%T_to_s*GV%m_to_H do k=1,nz do i=is,ie @@ -853,13 +958,13 @@ subroutine sumSWoverBands(G, GV, US, h, nsw, optics, j, dt, & if (h(i,k) > 0.0) then do n=1,nsw ; if (Pen_SW_bnd(n,i) > 0.0) then ! SW_trans is the SW that is transmitted THROUGH the layer - opt_depth = h(i,k)*GV%H_to_m * optics%opacity_band(n,i,j,k) + opt_depth = dz(i,k) * optics%opacity_band(n,i,j,k) exp_OD = exp(-opt_depth) SW_trans = exp_OD ! Heating at a very small rate can be absorbed by a sufficiently thick layer or several ! thin layers without further penetration. - if (optics%answers_2018) then + if (optics%answer_date < 20190101) then if (nsw*Pen_SW_bnd(n,i)*SW_trans < min_SW_heat*min(1.0, I_Habs*h(i,k)) ) SW_trans = 0.0 elseif ((nsw*Pen_SW_bnd(n,i)*SW_trans < min_SW_heat) .and. (h(i,k) > h_min_heat)) then if (nsw*Pen_SW_bnd(n,i) <= min_SW_heat * (I_Habs*(h(i,k) - h_min_heat))) then @@ -912,7 +1017,7 @@ end subroutine sumSWoverBands -!> This routine initalizes the opacity module, including an optics_type. +!> This routine initializes the opacity module, including an optics_type. subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) type(time_type), target, intent(in) :: Time !< The current model time. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. @@ -922,7 +1027,7 @@ subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) !! parameters. type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic !! output. - type(opacity_CS) :: CS !< Opacity control struct + type(opacity_CS) :: CS !< Opacity control structure type(optics_type) :: optics !< An optics structure that has parameters !! set and arrays allocated here. ! Local variables @@ -933,11 +1038,26 @@ subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) character(len=40) :: scheme_string ! This include declares and sets the variable "version". # include "version_variable.h" + real :: opacity_coefs(6) ! Pairs of opacity coefficients [Z-1 ~> m-1] for blue, red and + ! near-infrared radiation with parameterizations following the + ! functional form from Manizza et al., GRL 2005, namely in the form + ! opacity = coef_1 + coef_2 * chl**pow for each band. + real :: opacity_powers(3) ! Powers of chlorophyll [nondim] for blue, red and near-infrared + ! radiation bands, in expressions for opacity of the form + ! opacity = coef_1 + coef_2 * chl**pow. + real :: extinction_coefs(6) ! Extinction length coefficients [Z ~> m] for penetrating shortwave + ! radiation in the form proposed by Morel and Antoine (1994), namely + ! opacity = 1 / (sum(n=1:6, Coef(n) * log10(Chl)**(n-1))) + real :: sw_pen_frac_coefs(6) ! Coefficients for the shortwave radiation fraction [nondim] in a + ! fifth order polynomial fit as a funciton of log10(Chlorophyll). real :: PenSW_absorb_minthick ! A thickness that is used to absorb the remaining shortwave heat ! flux when that flux drops below PEN_SW_FLUX_ABSORB [H ~> m or kg m-2] - real :: PenSW_minthick_dflt ! The default for PenSW_absorb_minthick [m] - logical :: default_2018_answers - logical :: use_scheme + real :: PenSW_minthick_dflt ! The default for PenSW_absorb_minthick [m] + real :: I_NIR_bands ! The inverse of the number of near-infrared bands being used [nondim] + real, allocatable :: band_wavelengths(:) ! The bounding wavelengths for the penetrating shortwave + ! radiation bands [nm] + real, allocatable :: band_wavelen_default(:) ! The defaults for band_wavelengths [nm] + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags integer :: isd, ied, jsd, jed, nz, n isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke @@ -959,7 +1079,8 @@ subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) "concentrations are translated into opacities. Currently "//& "valid options include:\n"//& " \t\t MANIZZA_05 - Use Manizza et al., GRL, 2005. \n"//& - " \t\t MOREL_88 - Use Morel, JGR, 1988.", & + " \t\t MOREL_88 - Use Morel, JGR, 1988. \n"//& + " \t\t OHLMANN_03 - Use Ohlmann, J Clim, 2003. (only use if dz(1)>2.0m)", & default=MANIZZA_05_STRING) if (len_trim(tmpstr) > 0) then tmpstr = uppercase(tmpstr) @@ -968,6 +1089,8 @@ subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) CS%opacity_scheme = MANIZZA_05 ; scheme_string = MANIZZA_05_STRING case (MOREL_88_STRING) CS%opacity_scheme = MOREL_88 ; scheme_string = MOREL_88_STRING + case (OHLMANN_03_STRING) + CS%opacity_scheme = OHLMANN_03 ; scheme_string = OHLMANN_03_STRING case default call MOM_error(FATAL, "opacity_init: #DEFINE OPACITY_SCHEME "//& trim(tmpstr) // "in input file is invalid.") @@ -1002,19 +1125,18 @@ subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) call MOM_mesg('opacity_init: opacity scheme set to "'//trim(tmpstr)//'".', 5) endif call get_param(param_file, mdl, "PEN_SW_SCALE", CS%pen_sw_scale, & - "The vertical absorption e-folding depth of the "//& - "penetrating shortwave radiation.", units="m", default=0.0) + "The vertical absorption e-folding depth of the penetrating shortwave radiation.", & + units="m", default=0.0, scale=US%m_to_Z) !BGR/ Added for opacity_scheme==double_exp read in 2nd exp-decay and fraction if (CS%Opacity_scheme == DOUBLE_EXP ) then call get_param(param_file, mdl, "PEN_SW_SCALE_2ND", CS%pen_sw_scale_2nd, & "The (2nd) vertical absorption e-folding depth of the "//& - "penetrating shortwave radiation "//& - "(use if SW_EXP_MODE==double.)",& - units="m", default=0.0) + "penetrating shortwave radiation (use if SW_EXP_MODE==double.)", & + units="m", default=0.0, scale=US%m_to_Z) call get_param(param_file, mdl, "SW_1ST_EXP_RATIO", CS%sw_1st_exp_ratio, & "The fraction of 1st vertical absorption e-folding depth "//& "penetrating shortwave radiation if SW_EXP_MODE==double.",& - units="m", default=0.0) + units="nondim", default=0.0) elseif (CS%OPACITY_SCHEME == Single_Exp) then !/Else disable 2nd_exp scheme CS%pen_sw_scale_2nd = 0.0 @@ -1034,57 +1156,142 @@ subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) elseif (CS%Opacity_scheme == SINGLE_EXP ) then if (optics%nbands /= 1) call MOM_error(FATAL, & "set_opacity: \Cannot use a single_exp opacity scheme with nbands!=1.") + elseif (CS%Opacity_scheme == OHLMANN_03 ) then + if (optics%nbands /= 2) call MOM_error(FATAL, & + "set_opacity: \OHLMANN_03 scheme requires nbands==2") endif - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) - call get_param(param_file, mdl, "OPTICS_2018_ANSWERS", optics%answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated expressions for "//& - "handling the absorption of small remaining shortwave fluxes.", & - default=default_2018_answers) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "OPTICS_ANSWER_DATE", optics%answer_date, & + "The vintage of the order of arithmetic and expressions in the optics 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) optics%answer_date = max(optics%answer_date, 20230701) call get_param(param_file, mdl, "PEN_SW_FLUX_ABSORB", optics%PenSW_flux_absorb, & "A minimum remaining shortwave heating rate that will be simply absorbed in "//& "the next sufficiently thick layers for computational efficiency, instead of "//& "continuing to penetrate. The default, 2.5e-11 degC m s-1, is about 1e-4 W m-2 "//& "or 0.08 degC m century-1, but 0 is also a valid value.", & - default=2.5e-11, units="degC m s-1", scale=GV%m_to_H*US%T_to_s) + default=2.5e-11, units="degC m s-1", scale=US%degC_to_C*GV%m_to_H*US%T_to_s) - if (optics%answers_2018) then ; PenSW_minthick_dflt = 0.001 ; else ; PenSW_minthick_dflt = 1.0 ; endif + if (optics%answer_date < 20190101) then ; PenSW_minthick_dflt = 0.001 ; else ; PenSW_minthick_dflt = 1.0 ; endif call get_param(param_file, mdl, "PEN_SW_ABSORB_MINTHICK", PenSW_absorb_minthick, & "A thickness that is used to absorb the remaining penetrating shortwave heat "//& "flux when it drops below PEN_SW_FLUX_ABSORB.", & default=PenSW_minthick_dflt, units="m", scale=GV%m_to_H) optics%PenSW_absorb_Invlen = 1.0 / (PenSW_absorb_minthick + GV%H_subroundoff) + ! The defaults for the following coefficients are taken from Manizza et al., GRL, 2005. + call get_param(param_file, mdl, "OPACITY_VALUES_MANIZZA", opacity_coefs, & + "Pairs of opacity coefficients for blue, red and near-infrared radiation with "//& + "parameterizations following the functional form from Manizza et al., GRL 2005, "//& + "namely in the form opacity = coef_1 + coef_2 * chl**pow for each band. Although "//& + "coefficients are set for 3 bands, more or less bands may actually be used, with "//& + "extra bands following the same properties as band 3.", & + units="m-1", scale=US%Z_to_m, defaults=(/0.0232, 0.074, 0.225, 0.037, 2.86, 0.0/), & + do_not_log=(CS%opacity_scheme/=MANIZZA_05)) + call get_param(param_file, mdl, "CHOROPHYLL_POWER_MANIZZA", opacity_powers, & + "Powers of chlorophyll for blue, red and near-infrared radiation bands in "//& + "expressions for opacity of the form opacity = coef_1 + coef_2 * chl**pow.", & + units="nondim", defaults=(/0.674, 0.629, 0.0/), & + do_not_log=(CS%opacity_scheme/=MANIZZA_05)) + + ! The defaults for the following coefficients are taken from Morel and Antoine (1994). + call get_param(param_file, mdl, "OPACITY_VALUES_MOREL", extinction_coefs, & + "Shortwave extinction length coefficients for shortwave radiation in the form "//& + "proposed by Morel (1988), opacity = 1 / (sum(Coef(n) * log10(Chl)**(n-1))).", & + units="m", scale=US%m_to_Z, defaults=(/7.925, -6.644, 3.662, -1.815, -0.218, 0.502/), & + do_not_log=(CS%opacity_scheme/=MOREL_88)) + call get_param(param_file, mdl, "SW_PEN_FRAC_COEFS_MOREL", sw_pen_frac_coefs, & + "Coefficients for the shortwave radiation fraction in a fifth order polynomial "//& + "fit as a function of log10(Chlorophyll).", & + units="nondim", defaults=(/0.321, 0.008, 0.132, 0.038, -0.017, -0.007/), & + do_not_log=(CS%opacity_scheme/=MOREL_88)) + if (.not.allocated(optics%min_wavelength_band)) & allocate(optics%min_wavelength_band(optics%nbands)) if (.not.allocated(optics%max_wavelength_band)) & allocate(optics%max_wavelength_band(optics%nbands)) + ! Set the wavelengths of the opacity bands + allocate(band_wavelengths(optics%nbands+1), source=0.0) + allocate(band_wavelen_default(optics%nbands+1), source=0.0) if (CS%opacity_scheme == MANIZZA_05) then - optics%min_wavelength_band(1) =0 - optics%max_wavelength_band(1) =550 - if (optics%nbands >= 2) then - optics%min_wavelength_band(2)=550 - optics%max_wavelength_band(2)=700 - endif - if (optics%nbands > 2) then + if (optics%nbands >= 1) band_wavelen_default(2) = 550.0 + if (optics%nbands >= 2) band_wavelen_default(3) = 700.0 + if (optics%nbands >= 3) then + I_NIR_bands = 1.0 / real(optics%nbands - 2) do n=3,optics%nbands - optics%min_wavelength_band(n) =700 - optics%max_wavelength_band(n) =2800 + band_wavelen_default(n+1) = 2800. - (optics%nbands-n)*2100.0*I_NIR_bands enddo endif endif + call get_param(param_file, mdl, "OPACITY_BAND_WAVELENGTHS", band_wavelengths, & + "The bounding wavelengths for the various bands of shortwave radiation, with "//& + "defaults that depend on the setting for OPACITY_SCHEME.", & + units="nm", defaults=band_wavelen_default, do_not_log=(optics%nbands<2)) + do n=1,optics%nbands + optics%min_wavelength_band(n) = band_wavelengths(n) + optics%max_wavelength_band(n) = band_wavelengths(n+1) + enddo + deallocate(band_wavelengths, band_wavelen_default) + + ! Set opacity scheme dependent parameters. + + if (CS%opacity_scheme == MANIZZA_05) then + allocate(CS%opacity_coef(2,optics%nbands)) + allocate(CS%chl_power(optics%nbands)) + do n=1,min(3,optics%nbands) + CS%opacity_coef(1,n) = opacity_coefs(2*n-1) ; CS%opacity_coef(2,n) = opacity_coefs(2*n) + CS%chl_power(n) = opacity_powers(n) + enddo + ! All remaining bands use the same properties as NIR, for lack of something better to do. + do n=4,optics%nbands + CS%opacity_coef(1,n) = CS%opacity_coef(1,n-1) ; CS%opacity_coef(2,n) = CS%opacity_coef(2,n-1) + CS%chl_power(n) = CS%chl_power(n-1) + enddo + ! Determine the last band that is dependent on chlorophyll. + CS%chl_dep_bands = optics%nbands + do n=optics%nbands,1,-1 + if (CS%chl_power(n) /= 0.0) exit + CS%chl_dep_bands = n - 1 + enddo + do n=CS%chl_dep_bands+1,optics%nbands + if (CS%opacity_coef(2,n) /= 0.0) then + call MOM_error(WARNING, "set_opacity: A non-zero value of the chlorophyll dependence in "//& + "OPACITY_VALUES_MANIZZA was set for a band with zero power in its chlorophyll dependence "//& + "as set by CHOROPHYLL_POWER_MANIZZA.") + CS%opacity_coef(1,n) = CS%opacity_coef(1,n) + CS%opacity_coef(2,n) + CS%opacity_coef(2,n) = 0.0 + endif + enddo + + elseif (CS%opacity_scheme == MOREL_88) then + ! The Morel opacity scheme represents a non uniform distribution of chlorophyll-a through the + ! water column. Other approaches may be more appropriate when using an interactive ecosystem + ! model that predicts three-dimensional chl-a values. + allocate(CS%opacity_coef(6, optics%nbands)) + allocate(CS%sw_pen_frac_coef(6)) + + ! As presently implemented, all frequency bands use the same opacities. + do n=1,optics%nbands + CS%opacity_coef(1:6,n) = extinction_coefs(1:6) + enddo + CS%sw_pen_frac_coef(:) = sw_pen_frac_coefs(:) + endif call get_param(param_file, mdl, "OPACITY_LAND_VALUE", CS%opacity_land_value, & "The value to use for opacity over land. The default is "//& - "10 m-1 - a value for muddy water.", units="m-1", default=10.0) + "10 m-1 - a value for muddy water.", units="m-1", default=10.0, scale=US%Z_to_m) + + CS%warning_issued = .false. if (.not.allocated(optics%opacity_band)) & - allocate(optics%opacity_band(optics%nbands,isd:ied,jsd:jed,nz)) + allocate(optics%opacity_band(optics%nbands,isd:ied,jsd:jed,nz), source=0.0) if (.not.allocated(optics%sw_pen_band)) & allocate(optics%sw_pen_band(optics%nbands,isd:ied,jsd:jed)) allocate(CS%id_opacity(optics%nbands), source=-1) @@ -1094,23 +1301,203 @@ subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) CS%id_sw_vis_pen = register_diag_field('ocean_model', 'SW_vis_pen', diag%axesT1, Time, & 'Visible penetrating shortwave radiation flux into ocean', 'W m-2', conversion=US%QRZ_T_to_W_m2) do n=1,optics%nbands - write(bandnum,'(i3)') n - shortname = 'opac_'//trim(adjustl(bandnum)) - longname = 'Opacity for shortwave radiation in band '//trim(adjustl(bandnum)) & - // ', saved as L^-1 tanh(Opacity * L) for L = 10^-10 m' + write(bandnum,'(I0)') n + shortname = 'opac_'//trim(bandnum) + longname = 'Opacity for shortwave radiation in band '//trim(bandnum)// & + ', saved as L^-1 tanh(Opacity * L) for L = 10^-10 m' CS%id_opacity(n) = register_diag_field('ocean_model', shortname, diag%axesTL, Time, & - longname, 'm-1') + longname, 'm-1', conversion=US%m_to_Z) enddo + if (CS%opacity_scheme == OHLMANN_03) then + ! Set up the lookup table + call init_ohlmann_table(optics) + endif + end subroutine opacity_init +!> Initialize the lookup table for Ohlmann solar penetration scheme. +!! Step size in Chl is a constant in log-space to make lookups easy. +!! Step size is fine enough that nearest neighbor lookup is sufficiently +!! accurate. +subroutine init_ohlmann_table(optics) + + implicit none + + type(optics_type), intent(inout) :: optics + + ! Local variables + + !! These are the data from Ohlmann (2003) Table 1a with additional + !! values provided by C. Ohlmann and implemented in CESM-POP by B. Briegleb + integer, parameter :: nval_tab1a = 31 + real, parameter, dimension(nval_tab1a) :: & + chl_tab1a = (/ & + .001, .005, .01, .02, & + .03, .05, .10, .15, & + .20, .25, .30, .35, & + .40, .45, .50, .60, & + .70, .80, .90, 1.00, & + 1.50, 2.00, 2.50, 3.00, & + 4.00, 5.00, 6.00, 7.00, & + 8.00, 9.00, 10.00 /) + + real, parameter, dimension(nval_tab1a) :: & + a1_tab1a = (/ & + 0.4421, 0.4451, 0.4488, 0.4563, & + 0.4622, 0.4715, 0.4877, 0.4993, & + 0.5084, 0.5159, 0.5223, 0.5278, & + 0.5326, 0.5369, 0.5408, 0.5474, & + 0.5529, 0.5576, 0.5615, 0.5649, & + 0.5757, 0.5802, 0.5808, 0.5788, & + 0.56965, 0.55638, 0.54091, 0.52442, & + 0.50766, 0.49110, 0.47505 /) + + real, parameter, dimension(nval_tab1a) :: & + a2_tab1a = (/ & + 0.2981, 0.2963, 0.2940, 0.2894, & + 0.2858, 0.2800, 0.2703, 0.2628, & + 0.2571, 0.2523, 0.2481, 0.2444, & + 0.2411, 0.2382, 0.2356, 0.2309, & + 0.2269, 0.2235, 0.2206, 0.2181, & + 0.2106, 0.2089, 0.2113, 0.2167, & + 0.23357, 0.25504, 0.27829, 0.30274, & + 0.32698, 0.35056, 0.37303 /) + + real, parameter, dimension(nval_tab1a) :: & + b1_tab1a = (/ & + 0.0287, 0.0301, 0.0319, 0.0355, & + 0.0384, 0.0434, 0.0532, 0.0612, & + 0.0681, 0.0743, 0.0800, 0.0853, & + 0.0902, 0.0949, 0.0993, 0.1077, & + 0.1154, 0.1227, 0.1294, 0.1359, & + 0.1640, 0.1876, 0.2082, 0.2264, & + 0.25808, 0.28498, 0.30844, 0.32932, & + 0.34817, 0.36540, 0.38132 /) + + real, parameter, dimension(nval_tab1a) :: & + b2_tab1a = (/ & + 0.3192, 0.3243, 0.3306, 0.3433, & + 0.3537, 0.3705, 0.4031, 0.4262, & + 0.4456, 0.4621, 0.4763, 0.4889, & + 0.4999, 0.5100, 0.5191, 0.5347, & + 0.5477, 0.5588, 0.5682, 0.5764, & + 0.6042, 0.6206, 0.6324, 0.6425, & + 0.66172, 0.68144, 0.70086, 0.72144, & + 0.74178, 0.76190, 0.78155 /) + + !! Make the table big enough so step size is smaller + !! in log-space that any increment in Table 1a + integer, parameter :: nval_lut=401 + real :: chl, log10chl_lut, w1, w2 + integer :: n,m,mm1,err + + allocate(optics%a1_lut(nval_lut),optics%b1_lut(nval_lut),& + & optics%a2_lut(nval_lut),optics%b2_lut(nval_lut),& + & stat=err) + if ( err /= 0 ) then + call MOM_error(FATAL,"init_ohlmann: Cannot allocate lookup table") + endif + + optics%chl_min = chl_tab1a(1) + optics%log10chl_min = log10(chl_tab1a(1)) + optics%log10chl_max = log10(chl_tab1a(nval_tab1a)) + optics%dlog10chl = (optics%log10chl_max - optics%log10chl_min)/(nval_lut-1) + + ! step through the lookup table + m = 2 + do n=1,nval_lut + log10chl_lut = optics%log10chl_min + (n-1)*optics%dlog10chl + chl = 10.0**log10chl_lut + chl = max(chl_tab1a(1),min(chl,chl_tab1a(nval_tab1a))) + + ! find interval in Table 1a (m-1,m] + do while (chl > chl_tab1a(m)) + m = m + 1 + enddo + mm1 = m-1 + + ! interpolation weights + w2 = (chl - chl_tab1a(mm1))/(chl_tab1a(m) - chl_tab1a(mm1)) + w1 = 1. - w2 + + ! fill in the tables + optics%a1_lut(n) = w1*a1_tab1a(mm1) + w2*a1_tab1a(m) + optics%a2_lut(n) = w1*a2_tab1a(mm1) + w2*a2_tab1a(m) + optics%b1_lut(n) = w1*b1_tab1a(mm1) + w2*b1_tab1a(m) + optics%b2_lut(n) = w1*b2_tab1a(mm1) + w2*b2_tab1a(m) + enddo + + return +end subroutine init_ohlmann_table + +!> Get the partion of total solar into bands from Ohlmann lookup table +function lookup_ohlmann_swpen(chl,optics) result(A) + + implicit none + + real, intent(in) :: chl + type(optics_type), intent(in) :: optics + real, dimension(2) :: A + + ! Local variables + + real :: log10chl + integer :: n + + ! Make sure we are in the table + if (chl > optics%chl_min) then + log10chl = min(log10(chl),optics%log10chl_max) + else + log10chl = optics%log10chl_min + endif + ! Do a nearest neighbor lookup + n = nint( (log10chl - optics%log10chl_min)/optics%dlog10chl ) + 1 + + A(1) = optics%a1_lut(n) + A(2) = optics%a2_lut(n) + +end function lookup_ohlmann_swpen + +!> Get the opacity (decay scale) from Ohlmann lookup table +function lookup_ohlmann_opacity(chl,optics) result(B) + + implicit none + real, intent(in) :: chl + type(optics_type), intent(in) :: optics + real, dimension(2) :: B + + ! Local variables + real :: log10chl + integer :: n + + ! Make sure we are in the table + if (chl > optics%chl_min) then + log10chl = min(log10(chl),optics%log10chl_max) + else + log10chl = optics%log10chl_min + endif + ! Do a nearest neighbor lookup + n = nint( (log10chl - optics%log10chl_min)/optics%dlog10chl ) + 1 + + B(1) = optics%b1_lut(n) + B(2) = optics%b2_lut(n) + + return +end function lookup_ohlmann_opacity subroutine opacity_end(CS, optics) - type(opacity_CS) :: CS !< Opacity control struct + type(opacity_CS) :: CS !< Opacity control structure type(optics_type) :: optics !< An optics type structure that should be deallocated. if (allocated(CS%id_opacity)) & deallocate(CS%id_opacity) + if (allocated(CS%opacity_coef)) & + deallocate(CS%opacity_coef) + if (allocated(CS%sw_pen_frac_coef)) & + deallocate(CS%sw_pen_frac_coef) + if (allocated(CS%chl_power)) & + deallocate(CS%chl_power) if (allocated(optics%sw_pen_band)) & deallocate(optics%sw_pen_band) if (allocated(optics%opacity_band)) & @@ -1118,14 +1505,18 @@ subroutine opacity_end(CS, optics) if (allocated(optics%max_wavelength_band)) & deallocate(optics%max_wavelength_band) if (allocated(optics%min_wavelength_band)) & - deallocate(optics%min_wavelength_band) + deallocate(optics%min_wavelength_band) + if (allocated(optics%a1_lut)) deallocate(optics%a1_lut) + if (allocated(optics%a2_lut)) deallocate(optics%a2_lut) + if (allocated(optics%b1_lut)) deallocate(optics%b1_lut) + if (allocated(optics%b2_lut)) deallocate(optics%b2_lut) end subroutine opacity_end !> \namespace mom_opacity !! !! opacity_from_chl: !! In this routine, the Morel (modified) or Manizza (modified) -!! schemes use the "blue" band in the paramterizations to determine +!! schemes use the "blue" band in the parameterizations to determine !! the e-folding depth of the incoming shortwave attenuation. The red !! portion is lumped into the net heating at the surface. !! @@ -1138,4 +1529,7 @@ end subroutine opacity_end !! and sea-ice in a global model, Geophys. Res. Let., 32, L05603, !! doi:10.1029/2004GL020778. +!! Ohlmann, J.C., 2003: Ocean radiant heating in climate models. +!! J. Climate, 16, 1337-1351, 2003. + end module MOM_opacity diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index 1f141ffd0f..a8dd0cb1e6 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Provides regularization of layers in isopycnal mode module MOM_regularize_layers -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : time_type, diag_ctrl @@ -13,7 +15,7 @@ module MOM_regularize_layers use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain +use MOM_EOS, only : calculate_density, EOS_domain implicit none ; private @@ -34,6 +36,10 @@ module MOM_regularize_layers real :: density_match_tol !< A relative tolerance for how well the densities must match !! with the target densities during detrainment when regularizing !! the near-surface layers [nondim] + real :: sufficient_adjustment !< The fraction of the target entrainment of mass to the mixed + !! and buffer layers that is enough for one timestep when regularizing + !! the near-surface layers [nondim]. No more mass will be sought from + !! deeper layers in the interior after this fraction is exceeded. real :: h_def_tol1 !< The value of the relative thickness deficit at !! which to start modifying the structure, 0.5 by !! default (or a thickness ratio of 5.83) [nondim]. @@ -50,9 +56,10 @@ module MOM_regularize_layers type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. - logical :: answers_2018 !< If true, use the order of arithmetic and expressions that recover the - !! answers from the end of 2018. Otherwise, use updated and more robust - !! forms of the same expressions. + integer :: answer_date !< The vintage of the order of arithmetic and expressions in this module's + !! calculations. Values below 20190101 recover the answers from the + !! end of 2018, while higher values use updated and more robust forms + !! of the same expressions. logical :: debug !< If true, do more thorough checks for debugging purposes. integer :: id_def_rat = -1 !< A diagnostic ID @@ -74,7 +81,7 @@ subroutine regularize_layers(h, tv, dt, ea, eb, G, GV, US, CS) intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]. type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any !! available thermodynamic fields. Absent fields - !! have NULL ptrs. + !! have NULL pointers. real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: ea !< The amount of fluid moved downward into a @@ -85,12 +92,7 @@ subroutine regularize_layers(h, tv, dt, ea, eb, G, GV, US, CS) !! this should be increased due to mixed layer !! entrainment [H ~> m or kg m-2]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(regularize_layers_CS), intent(in) :: CS !< Regularize layer control struct - - ! Local variables - integer :: i, j, k, is, ie, js, je, nz - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + type(regularize_layers_CS), intent(in) :: CS !< Regularize layer control structure if (.not. CS%initialized) call MOM_error(FATAL, "MOM_regularize_layers: "//& "Module must be initialized before it is used.") @@ -111,7 +113,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]. type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any !! available thermodynamic fields. Absent fields - !! have NULL ptrs. + !! have NULL pointers. real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: ea !< The amount of fluid moved downward into a @@ -122,7 +124,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) !! this should be increased due to mixed layer !! entrainment [H ~> m or kg m-2]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(regularize_layers_CS), intent(in) :: CS !< Regularize layer control struct + type(regularize_layers_CS), intent(in) :: CS !< Regularize layer control structure ! Local variables real, dimension(SZIB_(G),SZJ_(G)) :: & @@ -138,12 +140,12 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) e_filt, e_2d ! The interface depths [H ~> m or kg m-2], positive upward. real, dimension(SZI_(G),SZK_(GV)) :: & h_2d, & ! A 2-d version of h [H ~> m or kg m-2]. - T_2d, & ! A 2-d version of tv%T [degC]. - S_2d, & ! A 2-d version of tv%S [ppt]. + T_2d, & ! A 2-d version of tv%T [C ~> degC]. + S_2d, & ! A 2-d version of tv%S [S ~> ppt]. Rcv, & ! A 2-d version of the coordinate density [R ~> kg m-3]. h_2d_init, & ! The initial value of h_2d [H ~> m or kg m-2]. - T_2d_init, & ! THe initial value of T_2d [degC]. - S_2d_init, & ! The initial value of S_2d [ppt]. + T_2d_init, & ! The initial value of T_2d [C ~> degC]. + S_2d_init, & ! The initial value of S_2d [S ~> ppt]. d_eb, & ! The downward increase across a layer in the entrainment from ! below [H ~> m or kg m-2]. The sign convention is that positive values of ! d_eb correspond to a gain in mass by a layer by upward motion. @@ -153,38 +155,41 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) real, dimension(SZI_(G)) :: & p_ref_cv, & ! Reference pressure for the potential density which defines ! the coordinate variable, set to P_Ref [R L2 T-2 ~> Pa]. - Rcv_tol, & ! A tolerence, relative to the target density differences + Rcv_tol, & ! A tolerance, relative to the target density differences ! between layers, for detraining into the interior [nondim]. - h_add_tgt, h_add_tot, & - h_tot1, Th_tot1, Sh_tot1, & - h_tot3, Th_tot3, Sh_tot3, & - h_tot2, Th_tot2, Sh_tot2 + h_add_tgt, & ! The target for the thickness to add to the mixed layers [H ~> m or kg m-2] + h_add_tot, & ! The net thickness added to the mixed layers [H ~> m or kg m-2] + h_tot1, h_tot2, h_tot3, & ! Debugging diagnostics of total thicknesses [H ~> m or kg m-2] + Th_tot1, Th_tot2, Th_tot3, & ! Debugging diagnostics of integrated temperatures [C H ~> degC m or degC kg m-2] + Sh_tot1, Sh_tot2, Sh_tot3 ! Debugging diagnostics of integrated salinities [S H ~> ppt m or ppt kg m-2] real, dimension(SZK_(GV)) :: & h_prev_1d ! The previous thicknesses [H ~> m or kg m-2]. real :: I_dtol ! The inverse of the tolerance changes [nondim]. real :: I_dtol34 ! The inverse of the tolerance changes [nondim]. - real :: h1, h2 ! Temporary thicknesses [H ~> m or kg m-2]. real :: e_e, e_w, e_n, e_s ! Temporary interface heights [H ~> m or kg m-2]. - real :: wt ! The weight of the filted interfaces in setting the targets [nondim]. + real :: wt ! The weight of the filtered interfaces in setting the targets [nondim]. real :: scale ! A scaling factor [nondim]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real, dimension(SZK_(GV)+1) :: & - int_flux, int_Tflux, int_Sflux, int_Rflux - real :: h_add - real :: h_det_tot - real :: max_def_rat - real :: Rcv_min_det ! The lightest (min) and densest (max) coordinate density - real :: Rcv_max_det ! that can detrain into a layer [R ~> kg m-3]. - - real :: int_top, int_bot - real :: h_predicted - real :: h_prev - real :: h_deficit + int_flux, & ! Mass flux across the interfaces [H ~> m or kg m-2] + int_Tflux, & ! Temperature flux across the interfaces [C H ~> degC m or degC kg m-2] + int_Sflux ! Salinity flux across the interfaces [S H ~> ppt m or ppt kg m-2] + real :: h_add ! The thickness to add to the layers above an interface [H ~> m or kg m-2] + real :: h_det_tot ! The total thickness detrained by the mixed layers [H ~> m or kg m-2] + real :: max_def_rat ! The maximum value of the ratio of the thickness deficit to the minimum depth [nondim] + real :: Rcv_min_det ! The lightest coordinate density that can detrain into a layer [R ~> kg m-3] + real :: Rcv_max_det ! The densest coordinate density that can detrain into a layer [R ~> kg m-3] + + real :: int_top, int_bot ! The interface depths above and below a layer [H ~> m or kg m-2], positive upward. + real :: h_predicted ! An updated thickness [H ~> m or kg m-2] + real :: h_prev ! The previous thickness [H ~> m or kg m-2] + real :: h_deficit ! The difference between the layer thickness and the value estimated from the + ! filtered interface depths [H ~> m or kg m-2] logical :: cols_left, ent_any, more_ent_i(SZI_(G)), ent_i(SZI_(G)) logical :: det_any, det_i(SZI_(G)) - logical :: do_j(SZJ_(G)), do_i(SZI_(G)), find_i(SZI_(G)) + logical :: do_j(SZJ_(G)), do_i(SZI_(G)) logical :: debug = .false. logical :: fatal_error character(len=256) :: mesg ! Message for error messages. @@ -234,8 +239,6 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) !$OMP eb,nkml,EOSdom) do j=js,je ; if (do_j(j)) then -! call calculate_density_derivs(T(:,1), S(:,1), p_ref_cv, dRcv_dT, dRcv_dS, tv%eqn_of_state, EOSdom) - do k=1,nz ; do i=is,ie ; d_ea(i,k) = 0.0 ; d_eb(i,k) = 0.0 ; enddo ; enddo kmax_d_ea = 0 @@ -309,7 +312,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) else h_add = e_2d(i,nkmb+1) - e_filt(i,nkmb+1) h_2d(i,k) = h_2d(i,k) - h_add - if (CS%answers_2018) then + if (CS%answer_date < 20190101) then e_2d(i,nkmb+1) = e_2d(i,nkmb+1) - h_add else e_2d(i,nkmb+1) = e_filt(i,nkmb+1) @@ -324,7 +327,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) S_2d(i,nkmb) = (h_prev*S_2d(i,nkmb) + h_add*S_2d(i,k)) / h_2d(i,nkmb) if ((e_2d(i,nkmb+1) <= e_filt(i,nkmb+1)) .or. & - (h_add_tot(i) > 0.6*h_add_tgt(i))) then !### 0.6 is adjustable?. + (h_add_tot(i) > CS%sufficient_adjustment*h_add_tgt(i))) then more_ent_i(i) = .false. else cols_left = .true. @@ -474,7 +477,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) k1 = 1 ; k2 = 1 int_top = 0.0 do k=1,nkmb+1 - int_flux(k) = 0.0 ; int_Rflux(k) = 0.0 + int_flux(k) = 0.0 int_Tflux(k) = 0.0 ; int_Sflux(k) = 0.0 enddo do k=1,2*nkmb @@ -571,21 +574,21 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) if (abs(h_tot1(i) - h_tot2(i)) > 1e-12*h_tot1(i)) then write(mesg,'(ES11.4," became ",ES11.4," diff ",ES11.4)') & h_tot1(i), h_tot2(i), (h_tot1(i) - h_tot2(i)) - call MOM_error(WARNING, "regularize_surface: Mass non-conservation."//& + call MOM_error(WARNING, "regularize_surface: Mass non-conservation. "//& trim(mesg), .true.) fatal_error = .true. endif - if (abs(Th_tot1(i) - Th_tot2(i)) > 1e-12*(Th_tot1(i)+10.0*h_tot1(i))) then + if (abs(Th_tot1(i) - Th_tot2(i)) > 1e-12*abs(Th_tot1(i) + 10.0*US%degC_to_C*h_tot1(i))) then write(mesg,'(ES11.4," became ",ES11.4," diff ",ES11.4," int diff ",ES11.4)') & Th_tot1(i), Th_tot2(i), (Th_tot1(i) - Th_tot2(i)), (Th_tot1(i) - Th_tot3(i)) - call MOM_error(WARNING, "regularize_surface: Heat non-conservation."//& + call MOM_error(WARNING, "regularize_surface: Heat non-conservation. "//& trim(mesg), .true.) fatal_error = .true. endif - if (abs(Sh_tot1(i) - Sh_tot2(i)) > 1e-12*(Sh_tot1(i)+10.0*h_tot1(i))) then + if (abs(Sh_tot1(i) - Sh_tot2(i)) > 1e-12*abs(Sh_tot1(i) + 10.0*US%ppt_to_S*h_tot1(i))) then write(mesg,'(ES11.4," became ",ES11.4," diff ",ES11.4," int diff ",ES11.4)') & Sh_tot1(i), Sh_tot2(i), (Sh_tot1(i) - Sh_tot2(i)), (Sh_tot1(i) - Sh_tot3(i)) - call MOM_error(WARNING, "regularize_surface: Salinity non-conservation."//& + call MOM_error(WARNING, "regularize_surface: Salinity non-conservation. "//& trim(mesg), .true.) fatal_error = .true. endif @@ -605,7 +608,7 @@ end subroutine regularize_surface !> This subroutine determines the amount by which the harmonic mean !! thickness at velocity points differ from the arithmetic means, relative to -!! the the arithmetic means, after eliminating thickness variations that are +!! the arithmetic means, after eliminating thickness variations that are !! solely due to topography and aggregating all interior layers into one. subroutine find_deficit_ratios(e, def_rat_u, def_rat_v, G, GV, CS, h) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. @@ -618,7 +621,7 @@ subroutine find_deficit_ratios(e, def_rat_u, def_rat_v, G, GV, CS, h) real, dimension(SZI_(G),SZJB_(G)), & intent(out) :: def_rat_v !< The thickness deficit ratio at v points, !! [nondim]. - type(regularize_layers_CS), intent(in) :: CS !< Regularize layer control struct + type(regularize_layers_CS), intent(in) :: CS !< Regularize layer control structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. @@ -713,12 +716,11 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) !! run-time parameters. type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate !! diagnostic output. - type(regularize_layers_CS), intent(inout) :: CS !< Regularize layer control struct + type(regularize_layers_CS), intent(inout) :: CS !< Regularize layer control structure -#include "version_variable.h" +# include "version_variable.h" character(len=40) :: mdl = "MOM_regularize_layers" ! This module's name. - logical :: use_temperature - logical :: default_2018_answers + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags logical :: just_read integer :: isd, ied, jsd, jed isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -748,13 +750,21 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) "densities during detrainment when regularizing the near-surface layers. The "//& "default of 0.6 gives 20% overlaps in density", & units="nondim", default=0.6, do_not_log=just_read) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false., do_not_log=just_read) - call get_param(param_file, mdl, "REGULARIZE_LAYERS_2018_ANSWERS", CS%answers_2018, & - "If true, use the order of arithmetic and expressions that recover the answers "//& - "from the end of 2018. Otherwise, use updated and more robust forms of the "//& - "same expressions.", default=default_2018_answers, do_not_log=just_read) + call get_param(param_file, mdl, "REG_SFC_SUFFICIENT_ADJ", CS%sufficient_adjustment, & + "The fraction of the target entrainment of mass to the mixed and buffer layers "//& + "that is enough for one timestep when regularizing the near-surface layers. "//& + "No more mass will be sought from deeper layers in the interior after this "//& + "fraction is exceeded.", units="nondim", default=0.6, do_not_log=just_read) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231, do_not_log=just_read) + call get_param(param_file, mdl, "REGULARIZE_LAYERS_ANSWER_DATE", CS%answer_date, & + "The vintage of the order of arithmetic and expressions in the regularize "//& + "layers 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) endif call get_param(param_file, mdl, "HMIX_MIN", CS%Hmix_min, & diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 061fe776e1..971e5f6226 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Calculate vertical diffusivity from all mixing processes module MOM_set_diffusivity -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_bkgnd_mixing, only : calculate_bkgnd_mixing, bkgnd_mixing_init, bkgnd_mixing_cs use MOM_bkgnd_mixing, only : bkgnd_mixing_end use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end @@ -13,6 +15,7 @@ module MOM_set_diffusivity use MOM_CVMix_shear, only : CVMix_shear_end use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_diag_mediator, only : post_data, register_diag_field +use MOM_diagnose_kdwork, only : vbf_CS use MOM_debugging, only : hchksum, uvchksum, Bchksum, hchksum_pair use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE @@ -22,7 +25,8 @@ module MOM_set_diffusivity use MOM_forcing_type, only : forcing, optics_type use MOM_full_convection, only : full_convection use MOM_grid, only : ocean_grid_type -use MOM_internal_tides, only : int_tide_CS, get_lowmode_loss +use MOM_interface_heights, only : thickness_to_dz, find_rho_bottom +use MOM_internal_tides, only : int_tide_CS, get_lowmode_loss, get_lowmode_diffusivity use MOM_intrinsic_functions, only : invcosh use MOM_io, only : slasher, MOM_read_data use MOM_isopycnal_slopes, only : vert_fill_TS @@ -69,24 +73,33 @@ module MOM_set_diffusivity !! drag law c_drag*|u|*u. logical :: BBL_mixing_as_max !< If true, take the maximum of the diffusivity !! from the BBL mixing and the other diffusivities. - !! Otherwise, diffusivities from the BBL_mixing is - !! added. + !! Otherwise, diffusivities from the BBL_mixing is added. logical :: use_LOTW_BBL_diffusivity !< If true, use simpler/less precise, BBL diffusivity. logical :: LOTW_BBL_use_omega !< If true, use simpler/less precise, BBL diffusivity. - real :: BBL_effic !< efficiency with which the energy extracted - !! by bottom drag drives BBL diffusion [nondim] + real :: Von_Karm !< The von Karman constant as used in the BBL diffusivity calculation + !! [nondim]. See (http://en.wikipedia.org/wiki/Von_Karman_constant) + real :: BBL_effic !< Efficiency with which the energy extracted + !! by bottom drag drives BBL diffusion in the original BBL scheme, times + !! conversion factors between the natural units of mean kinetic energy + !! and those those used for TKE [Z2 L-2 ~> nondim]. + real :: ePBL_BBL_effic !< efficiency with which the energy extracted + !! by bottom drag drives BBL diffusion in the ePBL BBL scheme [nondim] + logical :: ePBL_BBL_mstar !< logical if the bottom boundary layer uses an mstar x ustar^3 formulation + !! needed here to know whether or not to populate the bottom ustar real :: cdrag !< quadratic drag coefficient [nondim] - real :: IMax_decay !< inverse of a maximum decay scale for - !! bottom-drag driven turbulence [Z-1 ~> m-1]. - real :: Kv !< The interior vertical viscosity [Z2 T-1 ~> m2 s-1]. - real :: Kd !< interior diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. - real :: Kd_min !< minimum diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. - real :: Kd_max !< maximum increment for diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. + real :: dz_BBL_avg_min !< A minimal distance over which to average to determine the average + !! bottom boundary layer density [Z ~> m] + real :: IMax_decay !< Inverse of a maximum decay scale for + !! bottom-drag driven turbulence [H-1 ~> m-1 or m2 kg-1]. + real :: Kv !< The interior vertical viscosity [H Z T-1 ~> m2 s-1 or Pa s] + real :: Kd !< interior diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Kd_min !< minimum diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Kd_max !< maximum increment for diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] !! Set to a negative value to have no limit. real :: Kd_add !< uniform diffusivity added everywhere without - !! filtering or scaling [Z2 T-1 ~> m2 s-1]. + !! filtering or scaling [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: Kd_smooth !< Vertical diffusivity used to interpolate more - !! sensible values of T & S into thin layers [Z2 T-1 ~> m2 s-1]. + !! sensible values of T & S into thin layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] type(diag_ctrl), pointer :: diag => NULL() !< structure to regulate diagnostic output timing logical :: limit_dissipation !< If enabled, dissipation is limited to be larger @@ -95,7 +108,7 @@ module MOM_set_diffusivity real :: dissip_N0 !< Coefficient a in minimum dissipation = a+b*N [R Z2 T-3 ~> W m-3] real :: dissip_N1 !< Coefficient b in minimum dissipation = a+b*N [R Z2 T-2 ~> J m-3] real :: dissip_N2 !< Coefficient c in minimum dissipation = c*N2 [R Z2 T-1 ~> J s m-3] - real :: dissip_Kd_min !< Minimum Kd [Z2 T-1 ~> m2 s-1], with dissipation Rho0*Kd_min*N^2 + real :: dissip_Kd_min !< Minimum Kd [H Z T-1 ~> m2 s-1 or kg m-1 s-1], with dissipation Rho0*Kd_min*N^2 real :: omega !< Earth's rotation frequency [T-1 ~> s-1] logical :: ML_radiation !< allow a fraction of TKE available from wind work @@ -111,12 +124,11 @@ module MOM_set_diffusivity !! The diapycnal diffusivity is KD(k) = E/(N2(k)+OMEGA2), !! where N2 is the squared buoyancy frequency [T-2 ~> s-2] and OMEGA2 !! is the rotation rate of the earth squared. - real :: ML_rad_kd_max !< Maximum diapycnal diffusivity due to turbulence - !! radiated from the base of the mixed layer [Z2 T-1 ~> m2 s-1]. - real :: ML_rad_efold_coeff !< non-dim coefficient to scale penetration depth - real :: ML_rad_coeff !< coefficient, which scales MSTAR*USTAR^3 to - !! obtain energy available for mixing below - !! mixed layer base [nondim] + real :: ML_rad_kd_max !< Maximum diapycnal diffusivity due to turbulence radiated from + !! the base of the mixed layer [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real :: ML_rad_efold_coeff !< Coefficient to scale penetration depth [nondim] + real :: ML_rad_coeff !< Coefficient which scales MSTAR*USTAR^3 to obtain energy + !! available for mixing below mixed layer base [nondim] logical :: ML_rad_bug !< If true use code with a bug that reduces the energy available !! in the transition layer by a factor of the inverse of the energy !! deposition lenthscale (in m). @@ -133,7 +145,7 @@ module MOM_set_diffusivity !! of the vertical component of rotation when !! setting the decay scale for mixed layer turbulence. real :: ML_omega_frac !< When setting the decay scale for turbulence, use - !! this fraction of the absolute rotation rate blended + !! this fraction [nondim] of the absolute rotation rate blended !! with the local value of f, as f^2 ~= (1-of)*f^2 + of*4*omega^2. logical :: user_change_diff !< If true, call user-defined code to change diffusivity. logical :: useKappaShear !< If true, use the kappa_shear module to find the @@ -145,15 +157,28 @@ module MOM_set_diffusivity logical :: double_diffusion !< If true, enable double-diffusive mixing using an old method. logical :: use_CVMix_ddiff !< If true, enable double-diffusive mixing via CVMix. logical :: use_tidal_mixing !< If true, activate tidal mixing diffusivity. + logical :: use_int_tides !< If true, use internal tides ray tracing logical :: simple_TKE_to_Kd !< If true, uses a simple estimate of Kd/TKE that !! does not rely on a layer-formulation. - real :: Max_Rrho_salt_fingers !< max density ratio for salt fingering - real :: Max_salt_diff_salt_fingers !< max salt diffusivity for salt fingers [Z2 T-1 ~> m2 s-1] - real :: Kv_molecular !< molecular visc for double diff convect [Z2 T-1 ~> m2 s-1] - - logical :: answers_2018 !< If true, use the order of arithmetic and expressions that recover the - !! answers from the end of 2018. Otherwise, use updated and more robust - !! forms of the same expressions. + real :: Max_Rrho_salt_fingers !< max density ratio for salt fingering [nondim] + real :: Max_salt_diff_salt_fingers !< max salt diffusivity for salt fingers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Kv_molecular !< Molecular viscosity for double diffusive convection [H Z T-1 ~> m2 s-1 or Pa s] + + integer :: answer_date !< The vintage of the order of arithmetic and expressions in this module's + !! calculations. Values below 20190101 recover the answers from the + !! end of 2018, while higher values use updated and more robust forms + !! of the same expressions. Values above 20240630 use more accurate + !! expressions for cases where USE_LOTW_BBL_DIFFUSIVITY is true. Values + !! above 20250301 use less confusing expressions to set the bottom-drag + !! generated diffusivity when USE_LOTW_BBL_DIFFUSIVITY is false. + integer :: LOTW_BBL_answer_date !< The vintage of the order of arithmetic and expressions + !! in the LOTW_BBL calculations. Values below 20240630 recover the + !! original answers, while higher values use more accurate expressions. + !! This only applies when USE_LOTW_BBL_DIFFUSIVITY is true. + integer :: drag_diff_answer_date !< The vintage of the order of arithmetic in the drag diffusivity + !! calculations. Values above 20250301 use less confusing expressions + !! to set the bottom-drag generated diffusivity when + !! USE_LOTW_BBL_DIFFUSIVITY is false. character(len=200) :: inputdir !< The directory in which input files are found type(user_change_diff_CS), pointer :: user_change_diff_CSp => NULL() !< Control structure for a child module @@ -167,8 +192,12 @@ module MOM_set_diffusivity !>@{ Diagnostic IDs integer :: id_maxTKE = -1, id_TKE_to_Kd = -1, id_Kd_user = -1 integer :: id_Kd_layer = -1, id_Kd_BBL = -1, id_N2 = -1 - integer :: id_Kd_Work = -1, id_KT_extra = -1, id_KS_extra = -1, id_R_rho = -1 - integer :: id_Kd_bkgnd = -1, id_Kv_bkgnd = -1 + integer :: id_Kd_Work = -1, id_KT_extra = -1, id_KS_extra = -1, id_R_rho = -1 + integer :: id_Kd_bkgnd = -1, id_Kv_bkgnd = -1, id_Kd_leak = -1 + integer :: id_Kd_quad = -1, id_Kd_itidal = -1, id_Kd_Froude = -1, id_Kd_slope = -1 + integer :: id_prof_leak = -1, id_prof_quad = -1, id_prof_itidal= -1 + integer :: id_prof_Froude= -1, id_prof_slope = -1, id_bbl_thick = -1, id_kbbl = -1 + integer :: id_Kd_Work_added = -1 !>@} end type set_diffusivity_CS @@ -176,20 +205,33 @@ module MOM_set_diffusivity !> This structure has memory for used in calculating diagnostics of diffusivity type diffusivity_diags real, pointer, dimension(:,:,:) :: & - N2_3d => NULL(), & !< squared buoyancy frequency at interfaces [T-2 ~> s-2] - Kd_user => NULL(), & !< user-added diffusivity at interfaces [Z2 T-1 ~> m2 s-1] - Kd_BBL => NULL(), & !< BBL diffusivity at interfaces [Z2 T-1 ~> m2 s-1] - Kd_work => NULL(), & !< layer integrated work by diapycnal mixing [R Z3 T-3 ~> W m-2] - maxTKE => NULL(), & !< energy required to entrain to h_max [Z3 T-3 ~> m3 s-3] - Kd_bkgnd => NULL(), & !< Background diffusivity at interfaces [Z2 T-1 ~> m2 s-1] - Kv_bkgnd => NULL(), & !< Viscosity from ackground diffusivity at interfaces [Z2 T-1 ~> m2 s-1] - KT_extra => NULL(), & !< double diffusion diffusivity for temp [Z2 T-1 ~> m2 s-1]. - KS_extra => NULL(), & !< double diffusion diffusivity for saln [Z2 T-1 ~> m2 s-1]. - drho_rat => NULL() !< The density difference ratio used in double diffusion [nondim]. + N2_3d => NULL(), & !< squared buoyancy frequency at interfaces [T-2 ~> s-2] + Kd_user => NULL(), & !< user-added diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_BBL => NULL(), & !< BBL diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_Work => NULL(), & !< layer integrated work by diapycnal mixing [R Z3 T-3 ~> W m-2] + Kd_Work_added => NULL(), & !< layer integrated work by added mixing [R Z3 T-3 ~> W m-2] + maxTKE => NULL(), & !< energy required to entrain to h_max [H Z2 T-3 ~> m3 s-3 or W m-2] + Kd_bkgnd => NULL(), & !< Background diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kv_bkgnd => NULL(), & !< Viscosity from background diffusivity at interfaces [H Z T-1 ~> m2 s-1 or Pa s] + KT_extra => NULL(), & !< Double diffusion diffusivity for temperature [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + KS_extra => NULL(), & !< Double diffusion diffusivity for salinity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + drho_rat => NULL(), & !< The density difference ratio used in double diffusion [nondim]. + Kd_leak => NULL(), & !< internal tides leakage diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_quad => NULL(), & !< internal tides bottom drag diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_itidal => NULL(), & !< internal tides wave drag diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_Froude => NULL(), & !< internal tides high Froude diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_slope => NULL(), & !< internal tides critical slopes diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + prof_leak => NULL(), & !< vertical profile for leakage [H-1 ~> m-1 or m2 kg-1] + prof_quad => NULL(), & !< vertical profile for bottom drag [H-1 ~> m-1 or m2 kg-1] + prof_itidal => NULL(), & !< vertical profile for wave drag [H-1 ~> m-1 or m2 kg-1] + prof_Froude => NULL(), & !< vertical profile for Froude drag [H-1 ~> m-1 or m2 kg-1] + prof_slope => NULL() !< vertical profile for critical slopes [H-1 ~> m-1 or m2 kg-1] + real, pointer, dimension(:,:) :: bbl_thick => NULL(), & !< bottom boundary layer thickness [H ~> m or kg m-2] + kbbl => NULL() !< top of bottom boundary layer + real, pointer, dimension(:,:,:) :: TKE_to_Kd => NULL() !< conversion rate (~1.0 / (G_Earth + dRho_lay)) between TKE - !! dissipated within a layer and Kd in that layer - !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] + !! dissipated within a layer and Kd in that layer [T2 Z-1 ~> s2 m-1] end type diffusivity_diags @@ -200,7 +242,7 @@ module MOM_set_diffusivity contains subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_int, & - G, GV, US, CS, Kd_lay, Kd_extra_T, Kd_extra_S) + G, GV, US, CS, VBF, Kd_lay, Kd_extra_T, Kd_extra_S) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -223,44 +265,63 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i !! boundary layer properties and related fields. real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & - intent(out) :: Kd_int !< Diapycnal diffusivity at each interface [Z2 T-1 ~> m2 s-1]. + intent(out) :: Kd_int !< Diapycnal diffusivity at each interface + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. type(set_diffusivity_CS), pointer :: CS !< Module control structure. + type(vbf_CS), pointer :: VBF !< A diagnostic control structure for vertical buoyancy fluxes real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - optional, intent(out) :: Kd_lay !< Diapycnal diffusivity of each layer [Z2 T-1 ~> m2 s-1]. + optional, intent(out) :: Kd_lay !< Diapycnal diffusivity of each layer + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & optional, intent(out) :: Kd_extra_T !< The extra diffusivity at interfaces of - !! temperature due to double diffusion relative to - !! the diffusivity of density [Z2 T-1 ~> m2 s-1]. + !! temperature due to double diffusion relative + !! to the diffusivity of density + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & optional, intent(out) :: Kd_extra_S !< The extra diffusivity at interfaces of - !! salinity due to double diffusion relative to - !! the diffusivity of density [Z2 T-1 ~> m2 s-1]. + !! salinity due to double diffusion relative + !! to the diffusivity of density + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] ! local variables - real, dimension(SZI_(G)) :: & - N2_bot ! bottom squared buoyancy frequency [T-2 ~> s-2] + real :: N2_bot(SZI_(G)) ! Bottom squared buoyancy frequency [T-2 ~> s-2] + real :: rho_bot(SZI_(G)) ! In situ near-bottom density [T-2 ~> s-2] + real :: h_bot(SZI_(G)) ! Bottom boundary layer thickness [H ~> m or kg m-2] + integer :: k_bot(SZI_(G)) ! Bottom boundary layer thickness top layer index type(diffusivity_diags) :: dd ! structure with arrays of available diags + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & - T_f, S_f ! Temperature and salinity [degC] and [ppt] with properties in massless layers + T_f, S_f ! Temperature and salinity [C ~> degC] and [S ~> ppt] with properties in massless layers ! filled vertically by diffusion or the properties after full convective adjustment. real, dimension(SZI_(G),SZK_(GV)) :: & N2_lay, & !< Squared buoyancy frequency associated with layers [T-2 ~> s-2] - Kd_lay_2d, & !< The layer diffusivities [Z2 T-1 ~> m2 s-1] - maxTKE, & !< Energy required to entrain to h_max [Z3 T-3 ~> m3 s-3] + Kd_lay_2d, & !< The layer diffusivities [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + dz, & !< Height change across layers [Z ~> m] + maxTKE, & !< Energy required to entrain to h_max [H Z2 T-3 ~> m3 s-3 or W m-2] + prof_leak_2d, & !< vertical profile for leakage [Z-1 ~> m-1] + prof_quad_2d, & !< vertical profile for bottom drag [Z-1 ~> m-1] + prof_itidal_2d, & !< vertical profile for wave drag [Z-1 ~> m-1] + prof_Froude_2d, & !< vertical profile for Froude drag [Z-1 ~> m-1] + prof_slope_2d, & !< vertical profile for critical slopes [Z-1 ~> m-1] TKE_to_Kd !< Conversion rate (~1.0 / (G_Earth + dRho_lay)) between - !< TKE dissipated within a layer and Kd in that layer - !< [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] + !< TKE dissipated within a layer and Kd in that layer [T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(GV)+1) :: & N2_int, & !< squared buoyancy frequency associated at interfaces [T-2 ~> s-2] - Kd_int_2d, & !< The interface diffusivities [Z2 T-1 ~> m2 s-1] - Kv_bkgnd, & !< The background diffusion related interface viscosities [Z2 T-1 ~> m2 s-1] + Kd_int_2d, & !< The interface diffusivities [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kv_bkgnd, & !< The background diffusion related interface viscosities [H Z T-1 ~> m2 s-1 or Pa s] + Kd_leak_2d, & !< internal tides leakage diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_quad_2d, & !< internal tides bottom drag diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_itidal_2d, & !< internal tides wave drag diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_Froude_2d, & !< internal tides high Froude diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_slope_2d, & !< internal tides critical slopes diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] dRho_int, & !< Locally referenced potential density difference across interfaces [R ~> kg m-3] - KT_extra, & !< Double difusion diffusivity of temperature [Z2 T-1 ~> m2 s-1] - KS_extra !< Double difusion diffusivity of salinity [Z2 T-1 ~> m2 s-1] + KT_extra, & !< Double diffusion diffusivity of temperature [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + KS_extra !< Double diffusion diffusivity of salinity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: dissip ! local variable for dissipation calculations [Z2 R T-3 ~> W m-3] real :: Omega2 ! squared absolute rotation rate [T-2 ~> s-2] @@ -273,7 +334,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i integer :: i, j, k, is, ie, js, je, nz, isd, ied, jsd, jed - real :: kappa_dt_fill ! diffusivity times a timestep used to fill massless layers [Z2 ~> m2] + real :: kappa_dt_fill ! diffusivity times a timestep used to fill massless layers [H Z ~> m2 or kg m-1] 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 @@ -286,9 +347,9 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (.not.CS%initialized) call MOM_error(FATAL,"set_diffusivity: "//& "Module must be initialized before it is used.") - if (CS%answers_2018) then + if (CS%answer_date < 20190101) then ! These hard-coded dimensional parameters are being replaced. - kappa_dt_fill = US%m_to_Z**2 * 1.e-3 * 7200. + kappa_dt_fill = 1.e-3*GV%m2_s_to_HZ_T * 7200.*US%s_to_T else kappa_dt_fill = CS%Kd_smooth * dt endif @@ -302,6 +363,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i "when USE_CVMIX_DDIFF or DOUBLE_DIFFUSION are true.") TKE_to_Kd_used = (CS%use_tidal_mixing .or. CS%ML_radiation .or. & + CS%use_int_tides .or. & (CS%bottomdraglaw .and. .not.CS%use_LOTW_BBL_diffusivity)) ! Set Kd_lay, Kd_int and Kv_slow to constant values, mostly to fill the halos. @@ -315,7 +377,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (CS%id_N2 > 0) allocate(dd%N2_3d(isd:ied,jsd:jed,nz+1), source=0.0) if (CS%id_Kd_user > 0) allocate(dd%Kd_user(isd:ied,jsd:jed,nz+1), source=0.0) - if (CS%id_Kd_work > 0) allocate(dd%Kd_work(isd:ied,jsd:jed,nz), source=0.0) + if (CS%id_Kd_Work > 0) allocate(dd%Kd_Work(isd:ied,jsd:jed,nz), source=0.0) + if (CS%id_Kd_Work_added > 0) allocate(dd%Kd_Work_added(isd:ied,jsd:jed,nz), source=0.0) if (CS%id_maxTKE > 0) allocate(dd%maxTKE(isd:ied,jsd:jed,nz), source=0.0) if (CS%id_TKE_to_Kd > 0) allocate(dd%TKE_to_Kd(isd:ied,jsd:jed,nz), source=0.0) if ((CS%double_diffusion) .and. (CS%id_KT_extra > 0)) & @@ -323,50 +386,68 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if ((CS%double_diffusion) .and. (CS%id_KS_extra > 0)) & allocate(dd%KS_extra(isd:ied,jsd:jed,nz+1), source=0.0) if (CS%id_R_rho > 0) allocate(dd%drho_rat(isd:ied,jsd:jed,nz+1), source=0.0) - if (CS%id_Kd_BBL > 0) allocate(dd%Kd_BBL(isd:ied,jsd:jed,nz+1), source=0.0) + if (CS%id_Kd_BBL > 0 .or. associated(VBF%Kd_BBL)) & + allocate(dd%Kd_BBL(isd:ied,jsd:jed,nz+1), source=0.0) if (CS%id_Kd_bkgnd > 0) allocate(dd%Kd_bkgnd(isd:ied,jsd:jed,nz+1), source=0.) if (CS%id_Kv_bkgnd > 0) allocate(dd%Kv_bkgnd(isd:ied,jsd:jed,nz+1), source=0.) + if (CS%id_kbbl > 0) allocate(dd%kbbl(isd:ied,jsd:jed), source=0.) + if (CS%id_bbl_thick > 0) allocate(dd%bbl_thick(isd:ied,jsd:jed), source=0.) + if (CS%id_Kd_leak > 0) allocate(dd%Kd_leak(isd:ied,jsd:jed,nz+1), source=0.) + if (CS%id_Kd_quad > 0) allocate(dd%Kd_quad(isd:ied,jsd:jed,nz+1), source=0.) + if (CS%id_Kd_itidal > 0) allocate(dd%Kd_itidal(isd:ied,jsd:jed,nz+1), source=0.) + if (CS%id_Kd_Froude > 0) allocate(dd%Kd_Froude(isd:ied,jsd:jed,nz+1), source=0.) + if (CS%id_Kd_slope > 0) allocate(dd%Kd_slope(isd:ied,jsd:jed,nz+1), source=0.) + + if (CS%id_prof_leak > 0) allocate(dd%prof_leak(isd:ied,jsd:jed,nz), source=0.) + if (CS%id_prof_quad > 0) allocate(dd%prof_quad(isd:ied,jsd:jed,nz), source=0.) + if (CS%id_prof_itidal > 0) allocate(dd%prof_itidal(isd:ied,jsd:jed,nz), source=0.) + if (CS%id_prof_Froude > 0) allocate(dd%prof_Froude(isd:ied,jsd:jed,nz), source=0.) + if (CS%id_prof_slope > 0) allocate(dd%prof_slope(isd:ied,jsd:jed,nz), source=0.) + ! set up arrays for tidal mixing diagnostics if (CS%use_tidal_mixing) & call setup_tidal_diagnostics(G, GV, CS%tidal_mixing) if (CS%useKappaShear) then if (CS%debug) then - call hchksum_pair("before calc_KS [uv]_h", u_h, v_h, G%HI, scale=US%L_T_to_m_s) + call hchksum_pair("before calc_KS [uv]_h", u_h, v_h, G%HI, unscale=US%L_T_to_m_s) endif call cpu_clock_begin(id_clock_kappaShear) if (CS%Vertex_shear) then call full_convection(G, GV, US, h, tv, T_f, S_f, fluxes%p_surf, & - (GV%Z_to_H**2)*kappa_dt_fill, halo=1) + kappa_dt_fill, halo=1) call calc_kappa_shear_vertex(u, v, h, T_f, S_f, tv, fluxes%p_surf, visc%Kd_shear, & visc%TKE_turb, visc%Kv_shear_Bu, dt, G, GV, US, CS%kappaShear_CSp) if (associated(visc%Kv_shear)) visc%Kv_shear(:,:,:) = 0.0 ! needed for other parameterizations if (CS%debug) then - call hchksum(visc%Kd_shear, "after calc_KS_vert visc%Kd_shear", G%HI, scale=US%Z2_T_to_m2_s) - call Bchksum(visc%Kv_shear_Bu, "after calc_KS_vert visc%Kv_shear_Bu", G%HI, scale=US%Z2_T_to_m2_s) - call Bchksum(visc%TKE_turb, "after calc_KS_vert visc%TKE_turb", G%HI, scale=US%Z_to_m**2*US%s_to_T**2) + call hchksum(visc%Kd_shear, "after calc_KS_vert visc%Kd_shear", G%HI, unscale=GV%HZ_T_to_m2_s) + call Bchksum(visc%Kv_shear_Bu, "after calc_KS_vert visc%Kv_shear_Bu", G%HI, unscale=GV%HZ_T_to_m2_s) + call Bchksum(visc%TKE_turb, "after calc_KS_vert visc%TKE_turb", G%HI, unscale=US%Z_to_m**2*US%s_to_T**2) endif else ! Changes: visc%Kd_shear ; Sets: visc%Kv_shear and visc%TKE_turb call calculate_kappa_shear(u_h, v_h, h, tv, fluxes%p_surf, visc%Kd_shear, visc%TKE_turb, & visc%Kv_shear, dt, G, GV, US, CS%kappaShear_CSp) if (CS%debug) then - call hchksum(visc%Kd_shear, "after calc_KS visc%Kd_shear", G%HI, scale=US%Z2_T_to_m2_s) - call hchksum(visc%Kv_shear, "after calc_KS visc%Kv_shear", G%HI, scale=US%Z2_T_to_m2_s) - call hchksum(visc%TKE_turb, "after calc_KS visc%TKE_turb", G%HI, scale=US%Z_to_m**2*US%s_to_T**2) + call hchksum(visc%Kd_shear, "after calc_KS visc%Kd_shear", G%HI, unscale=GV%HZ_T_to_m2_s) + call hchksum(visc%Kv_shear, "after calc_KS visc%Kv_shear", G%HI, unscale=GV%HZ_T_to_m2_s) + call hchksum(visc%TKE_turb, "after calc_KS visc%TKE_turb", G%HI, unscale=US%Z_to_m**2*US%s_to_T**2) endif endif call cpu_clock_end(id_clock_kappaShear) if (showCallTree) call callTree_waypoint("done with calculate_kappa_shear (set_diffusivity)") + if (associated(VBF%Kd_KS)) then ; do K=1,nz+1 ; do i=is,ie ; do j=js,je + VBF%Kd_KS(i,j,K) = visc%Kd_shear(i,j,K) + enddo ; enddo ; enddo ; endif elseif (CS%use_CVMix_shear) then !NOTE{BGR}: this needs to be cleaned up. It works in 1D case, but has not been tested outside. call calculate_CVMix_shear(u_h, v_h, h, tv, visc%Kd_shear, visc%Kv_shear, G, GV, US, CS%CVMix_shear_CSp) if (CS%debug) then - call hchksum(visc%Kd_shear, "after CVMix_shear visc%Kd_shear", G%HI, scale=US%Z2_T_to_m2_s) - call hchksum(visc%Kv_shear, "after CVMix_shear visc%Kv_shear", G%HI, scale=US%Z2_T_to_m2_s) + call hchksum(visc%Kd_shear, "after CVMix_shear visc%Kd_shear", G%HI, unscale=GV%HZ_T_to_m2_s) + call hchksum(visc%Kv_shear, "after CVMix_shear visc%Kv_shear", G%HI, unscale=GV%HZ_T_to_m2_s) endif elseif (associated(visc%Kv_shear)) then visc%Kv_shear(:,:,:) = 0.0 ! needed if calculate_kappa_shear is not enabled @@ -375,15 +456,15 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i ! Smooth the properties through massless layers. if (use_EOS) then if (CS%debug) then - call hchksum(tv%T, "before vert_fill_TS tv%T",G%HI) - call hchksum(tv%S, "before vert_fill_TS tv%S",G%HI) - call hchksum(h, "before vert_fill_TS h",G%HI, scale=GV%H_to_m) + call hchksum(tv%T, "before vert_fill_TS tv%T", G%HI, unscale=US%C_to_degC) + call hchksum(tv%S, "before vert_fill_TS tv%S", G%HI, unscale=US%S_to_ppt) + call hchksum(h, "before vert_fill_TS h",G%HI, unscale=GV%H_to_m) endif - call vert_fill_TS(h, tv%T, tv%S, kappa_dt_fill, T_f, S_f, G, GV, larger_h_denom=.true.) + call vert_fill_TS(h, tv%T, tv%S, kappa_dt_fill, T_f, S_f, G, GV, US, larger_h_denom=.true.) if (CS%debug) then - call hchksum(tv%T, "after vert_fill_TS tv%T",G%HI) - call hchksum(tv%S, "after vert_fill_TS tv%S",G%HI) - call hchksum(h, "after vert_fill_TS h",G%HI, scale=GV%H_to_m) + call hchksum(tv%T, "after vert_fill_TS tv%T", G%HI, unscale=US%C_to_degC) + call hchksum(tv%S, "after vert_fill_TS tv%S", G%HI, unscale=US%S_to_ppt) + call hchksum(h, "after vert_fill_TS h",G%HI, unscale=GV%H_to_m) endif endif @@ -391,13 +472,13 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i ! be an appropriate place to add a depth-dependent parameterization or another explicit ! parameterization of Kd. - !$OMP parallel do default(shared) private(dRho_int,N2_lay,Kd_lay_2d,Kd_int_2d,Kv_bkgnd,N2_int,& - !$OMP N2_bot,KT_extra,KS_extra,TKE_to_Kd,maxTKE,dissip,kb)& + !$OMP parallel do default(shared) private(dRho_int,N2_lay,Kd_lay_2d,Kd_int_2d,Kv_bkgnd,N2_int,dz, & + !$OMP N2_bot,rho_bot,h_bot,k_bot,KT_extra,KS_extra,TKE_to_Kd,maxTKE,dissip,kb) & !$OMP if(.not. CS%use_CVMix_ddiff) do j=js,je ! Set up variables related to the stratification. - call find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, N2_lay, N2_int, N2_bot) + call find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, N2_lay, N2_int, N2_bot, rho_bot, h_bot, k_bot) if (associated(dd%N2_3d)) then do K=1,nz+1 ; do i=is,ie ; dd%N2_3d(i,j,K) = N2_int(i,K) ; enddo ; enddo @@ -415,6 +496,9 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (CS%id_Kd_bkgnd > 0) then ; do K=1,nz+1 ; do i=is,ie dd%Kd_bkgnd(i,j,K) = Kd_int_2d(i,K) enddo ; enddo ; endif + if (associated(VBF%Kd_bkgnd)) then ; do K=1,nz+1 ; do i=is,ie + VBF%Kd_bkgnd(i,j,K) = Kd_int_2d(i,K) + enddo ; enddo ; endif ! Double-diffusion (old method) if (CS%double_diffusion) then @@ -425,12 +509,12 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (KS_extra(i,K) > KT_extra(i,K)) then ! salt fingering Kd_lay_2d(i,k-1) = Kd_lay_2d(i,k-1) + 0.5 * KT_extra(i,K) Kd_lay_2d(i,k) = Kd_lay_2d(i,k) + 0.5 * KT_extra(i,K) - Kd_extra_S(i,j,K) = (KS_extra(i,K) - KT_extra(i,K)) + Kd_extra_S(i,j,K) = KS_extra(i,K) - KT_extra(i,K) Kd_extra_T(i,j,K) = 0.0 elseif (KT_extra(i,K) > 0.0) then ! double-diffusive convection Kd_lay_2d(i,k-1) = Kd_lay_2d(i,k-1) + 0.5 * KS_extra(i,K) Kd_lay_2d(i,k) = Kd_lay_2d(i,k) + 0.5 * KS_extra(i,K) - Kd_extra_T(i,j,K) = (KT_extra(i,K) - KS_extra(i,K)) + Kd_extra_T(i,j,K) = KT_extra(i,K) - KS_extra(i,K) Kd_extra_S(i,j,K) = 0.0 else ! There is no double diffusion at this interface. Kd_extra_T(i,j,K) = 0.0 @@ -444,6 +528,13 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (associated(dd%KS_extra)) then ; do K=1,nz+1 ; do i=is,ie dd%KS_extra(i,j,K) = KS_extra(i,K) enddo ; enddo ; endif + + if (associated(VBF%Kd_ddiff_T)) then ; do K=1,nz+1 ; do i=is,ie + VBF%Kd_ddiff_T(i,j,K) = KT_extra(i,K) + enddo ; enddo ; endif + if (associated(VBF%Kd_ddiff_S)) then ; do K=1,nz+1 ; do i=is,ie + VBF%Kd_ddiff_S(i,j,K) = KS_extra(i,K) + enddo ; enddo ; endif endif ! Apply double diffusion via CVMix @@ -456,6 +547,12 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i else call compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_extra_T, Kd_extra_S, CS%CVMix_ddiff_csp) endif + if (associated(VBF%Kd_ddiff_T)) then ; do K=1,nz+1 ; do i=is,ie + VBF%Kd_ddiff_T(i,j,K) = KT_extra(i,K) + enddo ; enddo ; endif + if (associated(VBF%Kd_ddiff_S)) then ; do K=1,nz+1 ; do i=is,ie + VBF%Kd_ddiff_S(i,j,K) = KS_extra(i,K) + enddo ; enddo ; endif call cpu_clock_end(id_clock_CVMix_ddiff) endif @@ -491,26 +588,95 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i enddo ; enddo endif + if (CS%ML_radiation .or. CS%use_tidal_mixing .or. associated(dd%Kd_Work)) then + call thickness_to_dz(h, tv, dz, j, G, GV) + endif + ! Add the ML_Rad diffusivity. - if (CS%ML_radiation) & - call add_MLrad_diffusivity(h, fluxes, j, Kd_int_2d, G, GV, US, CS, TKE_to_Kd, Kd_lay_2d) + if (CS%ML_radiation) then + call add_MLrad_diffusivity(dz, fluxes, tv, j, Kd_int_2d, G, GV, US, CS, TKE_to_Kd, Kd_lay_2d) + endif ! Add the Nikurashin and / or tidal bottom-driven mixing if (CS%use_tidal_mixing) & - call calculate_tidal_mixing(h, j, N2_bot, N2_lay, N2_int, TKE_to_Kd, & + call calculate_tidal_mixing(dz, j, N2_bot, rho_bot, N2_lay, N2_int, TKE_to_Kd, & maxTKE, G, GV, US, CS%tidal_mixing, & - CS%Kd_max, visc%Kv_slow, Kd_lay_2d, Kd_int_2d) + CS%Kd_max, visc%Kv_slow, Kd_lay_2d, Kd_int_2d, VBF) + + ! Add diffusivity from internal tides ray tracing + if (CS%use_int_tides) then + + call get_lowmode_diffusivity(G, GV, h, tv, US, h_bot, k_bot, j, N2_lay, N2_int, TKE_to_Kd, CS%Kd_max, & + CS%int_tide_CSp, Kd_leak_2d, Kd_quad_2d, Kd_itidal_2d, Kd_Froude_2d, Kd_slope_2d, & + Kd_lay_2d, Kd_int_2d, prof_leak_2d, prof_quad_2d, prof_itidal_2d, prof_froude_2d, & + prof_slope_2d) + + if (CS%id_kbbl > 0) then ; do i=is,ie + dd%kbbl(i,j) = k_bot(i) + enddo ; endif + if (CS%id_bbl_thick > 0) then ; do i=is,ie + dd%bbl_thick(i,j) = h_bot(i) + enddo ; endif + if (CS%id_Kd_leak > 0) then ; do K=1,nz+1 ; do i=is,ie + dd%Kd_leak(i,j,K) = Kd_leak_2d(i,K) + enddo ; enddo ; endif + if (CS%id_Kd_quad > 0) then ; do K=1,nz+1 ; do i=is,ie + dd%Kd_quad(i,j,K) = Kd_quad_2d(i,K) + enddo ; enddo ; endif + if (CS%id_Kd_itidal > 0) then ; do K=1,nz+1 ; do i=is,ie + dd%Kd_itidal(i,j,K) = Kd_itidal_2d(i,K) + enddo ; enddo ; endif + if (CS%id_Kd_Froude > 0) then ; do K=1,nz+1 ; do i=is,ie + dd%Kd_Froude(i,j,K) = Kd_Froude_2d(i,K) + enddo ; enddo ; endif + if (CS%id_Kd_slope > 0) then ; do K=1,nz+1 ; do i=is,ie + dd%Kd_slope(i,j,K) = Kd_slope_2d(i,K) + enddo ; enddo ; endif + if (associated (VBF%Kd_leak)) then ; do K=1,nz+1 ; do i=is,ie + VBF%Kd_leak(i,j,K) = min(Kd_leak_2d(i,K), CS%Kd_max) + enddo ; enddo ; endif + if (associated (VBF%Kd_quad)) then ; do K=1,nz+1 ; do i=is,ie + VBF%Kd_quad(i,j,K) = min(Kd_quad_2d(i,K), CS%Kd_max) + enddo ; enddo ; endif + if (associated (VBF%Kd_itidal)) then ; do K=1,nz+1 ; do i=is,ie + VBF%Kd_itidal(i,j,K) = min(Kd_itidal_2d(i,K), CS%Kd_max) + enddo ; enddo ; endif + if (associated (VBF%Kd_Froude)) then ; do K=1,nz+1 ; do i=is,ie + VBF%Kd_Froude(i,j,K) = min(Kd_Froude_2d(i,K), CS%Kd_max) + enddo ; enddo ; endif + if (associated (VBF%Kd_slope)) then ; do K=1,nz+1 ; do i=is,ie + VBF%Kd_slope(i,j,K) = min(Kd_slope_2d(i,K), CS%Kd_max) + enddo ; enddo ; endif + if (CS%id_prof_leak > 0) then ; do k=1,nz ; do i=is,ie + dd%prof_leak(i,j,k) = prof_leak_2d(i,k) + enddo ; enddo ; endif + if (CS%id_prof_quad > 0) then ; do k=1,nz ; do i=is,ie + dd%prof_quad(i,j,k) = prof_quad_2d(i,k) + enddo ; enddo ; endif + if (CS%id_prof_itidal > 0) then ; do k=1,nz ; do i=is,ie + dd%prof_itidal(i,j,k) = prof_itidal_2d(i,k) + enddo ; enddo ; endif + if (CS%id_prof_Froude > 0) then ; do k=1,nz ; do i=is,ie + dd%prof_Froude(i,j,k) = prof_Froude_2d(i,k) + enddo ; enddo ; endif + if (CS%id_prof_slope > 0) then ; do k=1,nz ; do i=is,ie + dd%prof_slope(i,j,k) = prof_slope_2d(i,k) + enddo ; enddo ; endif + endif ! This adds the diffusion sustained by the energy extracted from the flow by the bottom drag. - if (CS%bottomdraglaw .and. (CS%BBL_effic>0.0)) then + if (CS%bottomdraglaw .and. (CS%BBL_effic > 0.0)) then if (CS%use_LOTW_BBL_diffusivity) then - call add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int_2d, G, GV, US, CS, & - dd%Kd_BBL, Kd_lay_2d) + call add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Rho_bot, Kd_int_2d, & + G, GV, US, CS, dd%Kd_BBL, Kd_lay_2d) else call add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & - maxTKE, kb, G, GV, US, CS, Kd_lay_2d, Kd_int_2d, dd%Kd_BBL) + maxTKE, kb, rho_bot, G, GV, US, CS, Kd_lay_2d, Kd_int_2d, dd%Kd_BBL) endif + if (associated(VBF%Kd_BBL)) then ; do K=1,nz+1 ; do i=is,ie + VBF%Kd_BBL(i,j,K) = dd%Kd_BBL(i,j,K) + enddo ; enddo ; endif endif if (CS%limit_dissipation) then @@ -524,14 +690,17 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i CS%dissip_N0 + CS%dissip_N1 * sqrt(N2_int(i,K)), & ! Floor aka Gargett CS%dissip_N2 * N2_int(i,K)) ! Floor of Kd_min*rho0/F_Ri Kd_int_2d(i,K) = max(Kd_int_2d(i,K) , & ! Apply floor to Kd - dissip * (CS%FluxRi_max / (GV%Rho0 * (N2_int(i,K) + Omega2)))) + dissip * (CS%FluxRi_max / (GV%H_to_RZ * (N2_int(i,K) + Omega2)))) enddo ; enddo endif ! Optionally add a uniform diffusivity at the interfaces. - if (CS%Kd_add > 0.0) then ; do K=1,nz+1 ; do i=is,ie - Kd_int_2d(i,K) = Kd_int_2d(i,K) + CS%Kd_add - enddo ; enddo ; endif + if (CS%Kd_add > 0.0) then + do K=1,nz+1 ; do i=is,ie + Kd_int_2d(i,K) = Kd_int_2d(i,K) + CS%Kd_add + enddo ; enddo + VBF%Kd_add = CS%Kd_add + endif ! Copy the 2-d slices into the 3-d array that is exported. do K=1,nz+1 ; do i=is,ie @@ -549,14 +718,13 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i CS%dissip_N0 + CS%dissip_N1 * sqrt(N2_lay(i,k)), & ! Floor aka Gargett CS%dissip_N2 * N2_lay(i,k)) ! Floor of Kd_min*rho0/F_Ri Kd_lay_2d(i,k) = max(Kd_lay_2d(i,k) , & ! Apply floor to Kd - dissip * (CS%FluxRi_max / (GV%Rho0 * (N2_lay(i,k) + Omega2)))) + dissip * (CS%FluxRi_max / (GV%H_to_RZ * (N2_lay(i,k) + Omega2)))) enddo ; enddo endif - if (associated(dd%Kd_work)) then + if (associated(dd%Kd_Work)) then do k=1,nz ; do i=is,ie - dd%Kd_Work(i,j,k) = GV%Rho0 * Kd_lay_2d(i,k) * N2_lay(i,k) * & - GV%H_to_Z*h(i,j,k) ! Watt m-2 s = kg s-3 + dd%Kd_Work(i,j,k) = GV%H_to_RZ * Kd_lay_2d(i,k) * N2_lay(i,k) * dz(i,k) ! Watt m-2 = kg s-3 enddo ; enddo endif @@ -567,6 +735,12 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i enddo ; enddo endif + if (associated(dd%Kd_Work_added)) then + do k=1,nz ; do i=is,ie + dd%Kd_Work_added(i,j,k) = GV%H_to_RZ * CS%Kd_add * N2_lay(i,k) * dz(i,k) ! Watt m-2 = kg s-3 + enddo ; enddo + endif + ! Copy the 2-d slices into the 3-d array that is exported; this was done above for Kd_int. if (present(Kd_lay)) then ; do k=1,nz ; do i=is,ie Kd_lay(i,j,k) = Kd_lay_2d(i,k) @@ -579,33 +753,48 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i endif if (CS%debug) then - if (present(Kd_lay)) call hchksum(Kd_lay, "Kd_lay", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + if (present(Kd_lay)) call hchksum(Kd_lay, "Kd_lay", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) - if (CS%useKappaShear) call hchksum(visc%Kd_shear, "Turbulent Kd", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + if (CS%useKappaShear) call hchksum(visc%Kd_shear, "Turbulent Kd", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) if (CS%use_CVMix_ddiff) then - call hchksum(Kd_extra_T, "MOM_set_diffusivity: Kd_extra_T", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kd_extra_S, "MOM_set_diffusivity: Kd_extra_S", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_extra_T, "MOM_set_diffusivity: Kd_extra_T", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + call hchksum(Kd_extra_S, "MOM_set_diffusivity: Kd_extra_S", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) endif - if (associated(visc%kv_bbl_u) .and. associated(visc%kv_bbl_v)) then + if (allocated(visc%kv_bbl_u) .and. allocated(visc%kv_bbl_v)) then call uvchksum("BBL Kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, G%HI, & - haloshift=0, symmetric=.true., scale=US%Z2_T_to_m2_s, & + haloshift=0, symmetric=.true., unscale=GV%HZ_T_to_m2_s, & scalar_pair=.true.) endif - if (associated(visc%bbl_thick_u) .and. associated(visc%bbl_thick_v)) then + if (allocated(visc%bbl_thick_u) .and. allocated(visc%bbl_thick_v)) then call uvchksum("BBL bbl_thick_[uv]", visc%bbl_thick_u, visc%bbl_thick_v, & - G%HI, haloshift=0, symmetric=.true., scale=US%Z_to_m, & + G%HI, haloshift=0, symmetric=.true., unscale=US%Z_to_m, & scalar_pair=.true.) endif - if (associated(visc%Ray_u) .and. associated(visc%Ray_v)) then - call uvchksum("Ray_[uv]", visc%Ray_u, visc%Ray_v, G%HI, 0, symmetric=.true., scale=US%Z_to_m*US%s_to_T) + if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) then + call uvchksum("Ray_[uv]", visc%Ray_u, visc%Ray_v, G%HI, 0, & + symmetric=.true., unscale=GV%H_to_m*US%s_to_T, scalar_pair=.true.) endif endif + if (CS%debug) then + if (CS%id_prof_leak > 0) call hchksum(dd%prof_leak, "leakage_profile", G%HI, haloshift=0, unscale=GV%m_to_H) + if (CS%id_prof_slope > 0) call hchksum(dd%prof_slope, "slope_profile", G%HI, haloshift=0, unscale=GV%m_to_H) + if (CS%id_prof_Froude > 0) call hchksum(dd%prof_Froude, "Froude_profile", G%HI, haloshift=0, unscale=GV%m_to_H) + if (CS%id_prof_quad > 0) call hchksum(dd%prof_quad, "quad_profile", G%HI, haloshift=0, unscale=GV%m_to_H) + if (CS%id_prof_itidal > 0) call hchksum(dd%prof_itidal, "itidal_profile", G%HI, haloshift=0, unscale=GV%m_to_H) + if (CS%id_TKE_to_Kd > 0) call hchksum(dd%TKE_to_Kd, "TKE_to_Kd", G%HI, haloshift=0, unscale=US%m_to_Z*US%T_to_s**2) + if (CS%id_Kd_leak > 0) call hchksum(dd%Kd_leak, "Kd_leak", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + if (CS%id_Kd_quad > 0) call hchksum(dd%Kd_quad, "Kd_quad", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + if (CS%id_Kd_itidal > 0) call hchksum(dd%Kd_itidal, "Kd_itidal", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + if (CS%id_Kd_Froude > 0) call hchksum(dd%Kd_Froude, "Kd_Froude", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + if (CS%id_Kd_slope > 0) call hchksum(dd%Kd_slope, "Kd_slope", G%HI, haloshift=0, unscale=GV%HZ_T_to_m2_s) + endif + ! post diagnostics if (present(Kd_lay) .and. (CS%id_Kd_layer > 0)) call post_data(CS%id_Kd_layer, Kd_lay, CS%diag) @@ -613,16 +802,31 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (CS%id_Kd_bkgnd > 0) call post_data(CS%id_Kd_bkgnd, dd%Kd_bkgnd, CS%diag) if (CS%id_Kv_bkgnd > 0) call post_data(CS%id_Kv_bkgnd, dd%Kv_bkgnd, CS%diag) + if (CS%id_kbbl > 0) call post_data(CS%id_kbbl, dd%kbbl, CS%diag) + if (CS%id_bbl_thick > 0) call post_data(CS%id_bbl_thick, dd%bbl_thick, CS%diag) + if (CS%id_Kd_leak > 0) call post_data(CS%id_Kd_leak, dd%Kd_leak, CS%diag) + if (CS%id_Kd_slope > 0) call post_data(CS%id_Kd_slope, dd%Kd_slope, CS%diag) + if (CS%id_Kd_Froude > 0) call post_data(CS%id_Kd_Froude, dd%Kd_Froude, CS%diag) + if (CS%id_Kd_quad > 0) call post_data(CS%id_Kd_quad, dd%Kd_quad, CS%diag) + if (CS%id_Kd_itidal > 0) call post_data(CS%id_Kd_itidal, dd%Kd_itidal, CS%diag) + + if (CS%id_prof_leak > 0) call post_data(CS%id_prof_leak, dd%prof_leak, CS%diag) + if (CS%id_prof_slope > 0) call post_data(CS%id_prof_slope, dd%prof_slope, CS%diag) + if (CS%id_prof_Froude > 0) call post_data(CS%id_prof_Froude, dd%prof_Froude, CS%diag) + if (CS%id_prof_quad > 0) call post_data(CS%id_prof_quad, dd%prof_quad, CS%diag) + if (CS%id_prof_itidal > 0) call post_data(CS%id_prof_itidal, dd%prof_itidal, CS%diag) + ! tidal mixing if (CS%use_tidal_mixing) & call post_tidal_diagnostics(G, GV, h, CS%tidal_mixing) - if (CS%id_N2 > 0) call post_data(CS%id_N2, dd%N2_3d, CS%diag) - if (CS%id_Kd_Work > 0) call post_data(CS%id_Kd_Work, dd%Kd_Work, CS%diag) - if (CS%id_maxTKE > 0) call post_data(CS%id_maxTKE, dd%maxTKE, CS%diag) - if (CS%id_TKE_to_Kd > 0) call post_data(CS%id_TKE_to_Kd, dd%TKE_to_Kd, CS%diag) + if (CS%id_N2 > 0) call post_data(CS%id_N2, dd%N2_3d, CS%diag) + if (CS%id_Kd_Work > 0) call post_data(CS%id_Kd_Work, dd%Kd_Work, CS%diag) + if (CS%id_Kd_Work_added > 0) call post_data(CS%id_Kd_Work_added, dd%Kd_Work_added, CS%diag) + if (CS%id_maxTKE > 0) call post_data(CS%id_maxTKE, dd%maxTKE, CS%diag) + if (CS%id_TKE_to_Kd > 0) call post_data(CS%id_TKE_to_Kd, dd%TKE_to_Kd, CS%diag) - if (CS%id_Kd_user > 0) call post_data(CS%id_Kd_user, dd%Kd_user, CS%diag) + if (CS%id_Kd_user > 0) call post_data(CS%id_Kd_user, dd%Kd_user, CS%diag) ! double diffusive mixing if (CS%double_diffusion) then @@ -636,7 +840,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (CS%id_Kd_BBL > 0) call post_data(CS%id_Kd_BBL, dd%Kd_BBL, CS%diag) if (associated(dd%N2_3d)) deallocate(dd%N2_3d) - if (associated(dd%Kd_work)) deallocate(dd%Kd_work) + if (associated(dd%Kd_Work)) deallocate(dd%Kd_Work) + if (associated(dd%Kd_Work_added)) deallocate(dd%Kd_Work_added) if (associated(dd%Kd_user)) deallocate(dd%Kd_user) if (associated(dd%maxTKE)) deallocate(dd%maxTKE) if (associated(dd%TKE_to_Kd)) deallocate(dd%TKE_to_Kd) @@ -647,6 +852,17 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (associated(dd%Kd_bkgnd)) deallocate(dd%Kd_bkgnd) if (associated(dd%Kv_bkgnd)) deallocate(dd%Kv_bkgnd) + if (associated(dd%Kd_leak)) deallocate(dd%Kd_leak) + if (associated(dd%Kd_quad)) deallocate(dd%Kd_quad) + if (associated(dd%Kd_itidal)) deallocate(dd%Kd_itidal) + if (associated(dd%Kd_Froude)) deallocate(dd%Kd_Froude) + if (associated(dd%Kd_slope)) deallocate(dd%Kd_slope) + if (associated(dd%prof_leak)) deallocate(dd%prof_leak) + if (associated(dd%prof_quad)) deallocate(dd%prof_quad) + if (associated(dd%prof_itidal)) deallocate(dd%prof_itidal) + if (associated(dd%prof_Froude)) deallocate(dd%prof_Froude) + if (associated(dd%prof_slope)) deallocate(dd%prof_slope) + if (showCallTree) call callTree_leave("set_diffusivity()") end subroutine set_diffusivity @@ -670,11 +886,11 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure real, dimension(SZI_(G),SZK_(GV)), intent(out) :: TKE_to_Kd !< The conversion rate between the !! TKE dissipated within a layer and the - !! diapycnal diffusivity witin that layer, + !! diapycnal diffusivity within that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) - !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] - real, dimension(SZI_(G),SZK_(GV)), intent(out) :: maxTKE !< The energy required to for a layer to entrain - !! to its maximum realizable thickness [Z3 T-3 ~> m3 s-3] + !! [T2 Z-1 ~> s2 m-1] + real, dimension(SZI_(G),SZK_(GV)), intent(out) :: maxTKE !< The energy required to for a layer to entrain to its + !! maximum realizable thickness [H Z2 T-3 ~> m3 s-3 or W m-2] integer, dimension(SZI_(G)), intent(out) :: kb !< Index of lightest layer denser than the buffer !! layer, or -1 without a bulk mixed layer. ! Local variables @@ -686,28 +902,30 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & ! across an interface times the difference across the ! interface above it [nondim] rho_0, & ! Layer potential densities relative to surface pressure [R ~> kg m-3] + dz, & ! Height change across layers [Z ~> m] maxEnt ! maxEnt is the maximum value of entrainment from below (with ! compensating entrainment from above to keep the layer ! density from changing) that will not deplete all of the - ! layers above or below a layer within a timestep [Z ~> m]. + ! layers above or below a layer within a timestep [H ~> m or kg m-2]. real, dimension(SZI_(G)) :: & htot, & ! total thickness above or below a layer, or the - ! integrated thickness in the BBL [Z ~> m]. - mFkb, & ! total thickness in the mixed and buffer layers times ds_dsp1 [Z ~> m]. + ! integrated thickness in the BBL [H ~> m or kg m-2]. + mFkb, & ! total thickness in the mixed and buffer layers times ds_dsp1 [H ~> m or kg m-2] p_ref, & ! array of tv%P_Ref pressures [R L2 T-2 ~> Pa] Rcv_kmb, & ! coordinate density in the lowest buffer layer [R ~> kg m-3] p_0 ! An array of 0 pressures [R L2 T-2 ~> Pa] - real :: dh_max ! maximum amount of entrainment a layer could - ! undergo before entraining all fluid in the layers - ! above or below [Z ~> m]. + real :: dh_max ! maximum amount of entrainment a layer could undergo before + ! entraining all fluid in the layers above or below [H ~> m or kg m-2] real :: dRho_lay ! density change across a layer [R ~> kg m-3] real :: Omega2 ! rotation rate squared [T-2 ~> s-2] - real :: G_Rho0 ! gravitation accel divided by Bouss ref density [Z T-2 R-1 ~> m4 s-2 kg-1] - real :: G_IRho0 ! Alternate calculation of G_Rho0 for reproducibility [Z T-2 R-1 ~> m4 s-2 kg-1] - real :: I_Rho0 ! inverse of Boussinesq reference density [R-1 ~> m3 kg-1] + real :: grav ! Gravitational acceleration [Z T-2 ~> m s-2] + real :: G_Rho0 ! Gravitational acceleration divided by Boussinesq reference density + ! [Z R-1 T-2 ~> m4 s-2 kg-1] + real :: G_IRho0 ! Alternate calculation of G_Rho0 with thickness rescaling factors + ! [Z2 T-2 R-1 H-1 ~> m4 s-2 kg-1 or m7 kg-2 s-2] real :: I_dt ! 1/dt [T-1 ~> s-1] - real :: H_neglect ! negligibly small thickness [H ~> m or kg m-2] + real :: dz_neglect ! A negligibly small height change [Z ~> m] real :: hN2pO2 ! h (N^2 + Omega^2), in [Z T-2 ~> m s-2]. logical :: do_i(SZI_(G)) @@ -717,25 +935,28 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & I_dt = 1.0 / dt Omega2 = CS%omega**2 - H_neglect = GV%H_subroundoff - G_Rho0 = (US%L_to_Z**2 * GV%g_Earth) / (GV%Rho0) - if (CS%answers_2018) then - I_Rho0 = 1.0 / (GV%Rho0) - G_IRho0 = (US%L_to_Z**2 * GV%g_Earth) * I_Rho0 + dz_neglect = GV%dZ_subroundoff + grav = GV%g_Earth_Z_T2 + G_Rho0 = grav / GV%Rho0 + if (CS%answer_date < 20190101) then + G_IRho0 = grav * GV%H_to_Z**2 * GV%RZ_to_H else - G_IRho0 = G_Rho0 + G_IRho0 = GV%H_to_Z*G_Rho0 endif + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + ! Simple but coordinate-independent estimate of Kd/TKE if (CS%simple_TKE_to_Kd) then do k=1,nz ; do i=is,ie - hN2pO2 = (GV%H_to_Z * h(i,j,k)) * (N2_lay(i,k) + Omega2) ! Units of Z T-2. - if (hN2pO2>0.) then - TKE_to_Kd(i,k) = 1.0 / hN2pO2 ! Units of T2 Z-1. - else; TKE_to_Kd(i,k) = 0.; endif + hN2pO2 = dz(i,k) * (N2_lay(i,k) + Omega2) ! Units of Z T-2. + if (hN2pO2 > 0.) then + TKE_to_Kd(i,k) = 1.0 / hN2pO2 ! Units of T2 H-1. + else ; TKE_to_Kd(i,k) = 0. ; endif ! The maximum TKE conversion we allow is really a statement ! about the upper diffusivity we allow. Kd_max must be set. - maxTKE(i,k) = hN2pO2 * CS%Kd_max ! Units of Z3 T-3. + maxTKE(i,k) = hN2pO2 * CS%Kd_max ! Units of H Z2 T-3. enddo ; enddo kb(is:ie) = -1 ! kb should not be used by any code in non-layered mode -AJA return @@ -783,44 +1004,43 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & if (CS%bulkmixedlayer) then kmb = GV%nk_rho_varies do i=is,ie - htot(i) = GV%H_to_Z*h(i,j,kmb) + htot(i) = h(i,j,kmb) mFkb(i) = 0.0 - if (kb(i) < nz) & - mFkb(i) = ds_dsp1(i,kb(i)) * (GV%H_to_Z*(h(i,j,kmb) - GV%Angstrom_H)) + if (kb(i) < nz) mFkb(i) = ds_dsp1(i,kb(i)) * (h(i,j,kmb) - GV%Angstrom_H) enddo do k=1,kmb-1 ; do i=is,ie - htot(i) = htot(i) + GV%H_to_Z*h(i,j,k) - mFkb(i) = mFkb(i) + ds_dsp1(i,k+1)*(GV%H_to_Z*(h(i,j,k) - GV%Angstrom_H)) + htot(i) = htot(i) + h(i,j,k) + mFkb(i) = mFkb(i) + ds_dsp1(i,k+1)*(h(i,j,k) - GV%Angstrom_H) enddo ; enddo else do i=is,i - maxEnt(i,1) = 0.0 ; htot(i) = GV%H_to_Z*(h(i,j,1) - GV%Angstrom_H) + maxEnt(i,1) = 0.0 ; htot(i) = h(i,j,1) - GV%Angstrom_H enddo endif do k=kb_min,nz-1 ; do i=is,ie if (k == kb(i)) then maxEnt(i,kb(i)) = mFkb(i) elseif (k > kb(i)) then - if (CS%answers_2018) then + if (CS%answer_date < 20190101) then maxEnt(i,k) = (1.0/dsp1_ds(i,k))*(maxEnt(i,k-1) + htot(i)) else maxEnt(i,k) = ds_dsp1(i,k)*(maxEnt(i,k-1) + htot(i)) endif - htot(i) = htot(i) + GV%H_to_Z*(h(i,j,k) - GV%Angstrom_H) + htot(i) = htot(i) + (h(i,j,k) - GV%Angstrom_H) endif enddo ; enddo do i=is,ie - htot(i) = GV%H_to_Z*(h(i,j,nz) - GV%Angstrom_H) ; maxEnt(i,nz) = 0.0 - do_i(i) = (G%mask2dT(i,j) > 0.5) + htot(i) = h(i,j,nz) - GV%Angstrom_H ; maxEnt(i,nz) = 0.0 + do_i(i) = (G%mask2dT(i,j) > 0.0) enddo do k=nz-1,kb_min,-1 i_rem = 0 do i=is,ie ; if (do_i(i)) then if (k Calculate Brunt-Vaisala frequency, N^2. subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & - N2_lay, N2_int, N2_bot) + N2_lay, N2_int, N2_bot, Rho_bot, h_bot, k_bot) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -877,10 +1103,10 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & !! thermodynamic fields. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: T_f !< layer temperature with the values in massless layers - !! filled vertically by diffusion [degC]. + !! filled vertically by diffusion [C ~> degC]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: S_f !< Layer salinities with values in massless - !! layers filled vertically by diffusion [ppt]. + !! layers filled vertically by diffusion [S ~> ppt]. type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes integer, intent(in) :: j !< j-index of row to work on type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure @@ -892,33 +1118,38 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & real, dimension(SZI_(G),SZK_(GV)), & intent(out) :: N2_lay !< The squared buoyancy frequency of the layers [T-2 ~> s-2]. real, dimension(SZI_(G)), intent(out) :: N2_bot !< The near-bottom squared buoyancy frequency [T-2 ~> s-2]. + real, dimension(SZI_(G)), intent(out) :: Rho_bot !< Near-bottom density [R ~> kg m-3]. + real, dimension(SZI_(G)), optional, intent(out) :: h_bot !< Bottom boundary layer thickness [H ~> m or kg m-2]. + integer, dimension(SZI_(G)), optional, intent(out) :: k_bot !< Bottom boundary layer top layer index. + ! Local variables real, dimension(SZI_(G),SZK_(GV)+1) :: & + pres, & ! pressure at each interface [R L2 T-2 ~> Pa] dRho_int_unfilt, & ! unfiltered density differences across interfaces [R ~> kg m-3] - dRho_dT, & ! partial derivative of density wrt temp [R degC-1 ~> kg m-3 degC-1] - dRho_dS ! partial derivative of density wrt saln [R ppt-1 ~> kg m-3 ppt-1] - + dRho_dT, & ! partial derivative of density wrt temp [R C-1 ~> kg m-3 degC-1] + dRho_dS ! partial derivative of density wrt saln [R S-1 ~> kg m-3 ppt-1] + real, dimension(SZI_(G),SZK_(GV)) :: & + dz ! Height change across layers [Z ~> m] real, dimension(SZI_(G)) :: & - pres, & ! pressure at each interface [R L2 T-2 ~> Pa] - Temp_int, & ! temperature at each interface [degC] - Salin_int, & ! salinity at each interface [ppt] + Temp_int, & ! temperature at each interface [C ~> degC] + Salin_int, & ! salinity at each interface [S ~> ppt] drho_bot, & ! A density difference [R ~> kg m-3] h_amp, & ! The topographic roughness amplitude [Z ~> m]. - hb, & ! The thickness of the bottom layer [Z ~> m]. - z_from_bot ! The hieght above the bottom [Z ~> m]. + dz_BBL_avg, & ! The distance over which to average to find the near-bottom density [Z ~> m] + hb, & ! The thickness of the bottom layer [H ~> m or kg m-2] + z_from_bot ! The height above the bottom [Z ~> m] - real :: Rml_base ! density of the deepest variable density layer - real :: dz_int ! thickness associated with an interface [Z ~> m]. - real :: G_Rho0 ! gravitation acceleration divided by Bouss reference density - ! times some unit conversion factors [Z T-2 R-1 ~> m4 s-2 kg-1]. - real :: H_neglect ! negligibly small thickness, in the same units as h. + real :: dz_int ! Vertical distance associated with an interface [Z ~> m] + real :: G_Rho0 ! Gravitational acceleration, perhaps divided by Boussinesq reference density, + ! times some unit conversion factors [H T-2 R-1 ~> m4 s-2 kg-1 or m s-2]. + real :: H_neglect ! A negligibly small thickness [H ~> m or kg m-2] logical :: do_i(SZI_(G)), do_any 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 - G_Rho0 = (US%L_to_Z**2 * GV%g_Earth) / (GV%Rho0) + G_Rho0 = GV%g_Earth_Z_T2 / GV%H_to_RZ H_neglect = GV%H_subroundoff ! Find the (limited) density jump across each interface. @@ -928,24 +1159,24 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & enddo if (associated(tv%eqn_of_state)) then if (associated(fluxes%p_surf)) then - do i=is,ie ; pres(i) = fluxes%p_surf(i,j) ; enddo + do i=is,ie ; pres(i,1) = fluxes%p_surf(i,j) ; enddo else - do i=is,ie ; pres(i) = 0.0 ; enddo + do i=is,ie ; pres(i,1) = 0.0 ; enddo endif EOSdom(:) = EOS_domain(G%HI) do K=2,nz do i=is,ie - pres(i) = pres(i) + (GV%g_Earth*GV%H_to_RZ)*h(i,j,k-1) + pres(i,K) = pres(i,K-1) + (GV%g_Earth*GV%H_to_RZ)*h(i,j,k-1) Temp_Int(i) = 0.5 * (T_f(i,j,k) + T_f(i,j,k-1)) Salin_Int(i) = 0.5 * (S_f(i,j,k) + S_f(i,j,k-1)) enddo - call calculate_density_derivs(Temp_int, Salin_int, pres, dRho_dT(:,K), dRho_dS(:,K), & + call calculate_density_derivs(Temp_int, Salin_int, pres(:,K), dRho_dT(:,K), dRho_dS(:,K), & tv%eqn_of_state, EOSdom) do i=is,ie dRho_int(i,K) = max(dRho_dT(i,K)*(T_f(i,j,k) - T_f(i,j,k-1)) + & dRho_dS(i,K)*(S_f(i,j,k) - S_f(i,j,k-1)), 0.0) dRho_int_unfilt(i,K) = max(dRho_dT(i,K)*(tv%T(i,j,k) - tv%T(i,j,k-1)) + & - dRho_dS(i,K)*(tv%S(i,j,k) - tv%S(i,j,k-1)), 0.0) + dRho_dS(i,K)*(tv%S(i,j,k) - tv%S(i,j,k-1)), 0.0) enddo enddo else @@ -954,38 +1185,41 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & enddo ; enddo endif + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + ! Set the buoyancy frequencies. do k=1,nz ; do i=is,ie N2_lay(i,k) = G_Rho0 * 0.5*(dRho_int(i,K) + dRho_int(i,K+1)) / & - (GV%H_to_Z*(h(i,j,k) + H_neglect)) + (h(i,j,k) + H_neglect) enddo ; enddo do i=is,ie ; N2_int(i,1) = 0.0 ; N2_int(i,nz+1) = 0.0 ; enddo do K=2,nz ; do i=is,ie N2_int(i,K) = G_Rho0 * dRho_int(i,K) / & - (0.5*GV%H_to_Z*(h(i,j,k-1) + h(i,j,k) + H_neglect)) + (0.5*(h(i,j,k-1) + h(i,j,k) + H_neglect)) enddo ; enddo ! Find the bottom boundary layer stratification, and use this in the deepest layers. do i=is,ie hb(i) = 0.0 ; dRho_bot(i) = 0.0 ; h_amp(i) = 0.0 - z_from_bot(i) = 0.5*GV%H_to_Z*h(i,j,nz) - do_i(i) = (G%mask2dT(i,j) > 0.5) + z_from_bot(i) = 0.5*dz(i,nz) + do_i(i) = (G%mask2dT(i,j) > 0.0) enddo if (CS%use_tidal_mixing) call tidal_mixing_h_amp(h_amp, G, j, CS%tidal_mixing) do k=nz,2,-1 do_any = .false. do i=is,ie ; if (do_i(i)) then - dz_int = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j,k-1)) + dz_int = 0.5*(dz(i,k) + dz(i,k-1)) z_from_bot(i) = z_from_bot(i) + dz_int ! middle of the layer above - hb(i) = hb(i) + dz_int + hb(i) = hb(i) + 0.5*(h(i,j,k) + h(i,j,k-1)) drho_bot(i) = drho_bot(i) + dRho_int(i,K) if (z_from_bot(i) > h_amp(i)) then if (k>2) then ! Always include at least one full layer. - hb(i) = hb(i) + 0.5*GV%H_to_Z*(h(i,j,k-1) + h(i,j,k-2)) + hb(i) = hb(i) + 0.5*(h(i,j,k-1) + h(i,j,k-2)) drho_bot(i) = drho_bot(i) + dRho_int(i,K-1) endif do_i(i) = .false. @@ -1000,14 +1234,14 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & if (hb(i) > 0.0) then N2_bot(i) = (G_Rho0 * drho_bot(i)) / hb(i) else ; N2_bot(i) = 0.0 ; endif - z_from_bot(i) = 0.5*GV%H_to_Z*h(i,j,nz) - do_i(i) = (G%mask2dT(i,j) > 0.5) + z_from_bot(i) = 0.5*dz(i,nz) + do_i(i) = (G%mask2dT(i,j) > 0.0) enddo do k=nz,2,-1 do_any = .false. do i=is,ie ; if (do_i(i)) then - dz_int = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j,k-1)) + dz_int = 0.5*(dz(i,k) + dz(i,k-1)) z_from_bot(i) = z_from_bot(i) + dz_int ! middle of the layer above N2_int(i,K) = N2_bot(i) @@ -1029,11 +1263,15 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & enddo ; enddo endif + ! Average over the larger of the envelope of the topography or a minimal distance. + do i=is,ie ; dz_BBL_avg(i) = max(h_amp(i), CS%dz_BBL_avg_min) ; enddo + call find_rho_bottom(G, GV, US, tv, h, dz, pres, dz_BBL_avg, j, Rho_bot, h_bot, k_bot) + end subroutine find_N2 !> This subroutine sets the additional diffusivities of temperature and !! salinity due to double diffusion, using the same functional form as is -!! used in MOM4.1, and taken from an NCAR technical note (REF?) that updates +!! used in MOM4.1, and taken from the appendix of Danabasoglu et al. (2006), which updates !! what was in Large et al. (1994). All the coefficients here should probably !! be made run-time variables rather than hard-coded constants. !! @@ -1048,35 +1286,33 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: T_f !< layer temperatures with the values in massless layers - !! filled vertically by diffusion [degC]. + !! filled vertically by diffusion [C ~> degC]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: S_f !< Layer salinities with values in massless - !! layers filled vertically by diffusion [ppt]. + !! layers filled vertically by diffusion [S ~> ppt]. integer, intent(in) :: j !< Meridional index upon which to work. type(set_diffusivity_CS), pointer :: CS !< Module control structure. real, dimension(SZI_(G),SZK_(GV)+1), & intent(out) :: Kd_T_dd !< Interface double diffusion diapycnal - !! diffusivity for temp [Z2 T-1 ~> m2 s-1]. + !! diffusivity for temp [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZK_(GV)+1), & intent(out) :: Kd_S_dd !< Interface double diffusion diapycnal - !! diffusivity for saln [Z2 T-1 ~> m2 s-1]. + !! diffusivity for saln [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G)) :: & - dRho_dT, & ! partial derivatives of density wrt temp [R degC-1 ~> kg m-3 degC-1] - dRho_dS, & ! partial derivatives of density wrt saln [R ppt-1 ~> kg m-3 ppt-1] + dRho_dT, & ! partial derivatives of density with respect to temperature [R C-1 ~> kg m-3 degC-1] + dRho_dS, & ! partial derivatives of density with respect to salinity [R S-1 ~> kg m-3 ppt-1] pres, & ! pressure at each interface [R L2 T-2 ~> Pa] - Temp_int, & ! temperature at interfaces [degC] - Salin_int ! Salinity at interfaces [ppt] + Temp_int, & ! temperature at interfaces [C ~> degC] + Salin_int ! Salinity at interfaces [S ~> ppt] real :: alpha_dT ! density difference between layers due to temp diffs [R ~> kg m-3] real :: beta_dS ! density difference between layers due to saln diffs [R ~> kg m-3] real :: Rrho ! vertical density ratio [nondim] real :: diff_dd ! factor for double-diffusion [nondim] - real :: Kd_dd ! The dominant double diffusive diffusivity [Z2 T-1 ~> m2 s-1] - real :: prandtl ! flux ratio for diffusive convection regime - - real, parameter :: Rrho0 = 1.9 ! limit for double-diffusive density ratio [nondim] + 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] integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, k, is, ie, nz @@ -1103,8 +1339,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 @@ -1125,8 +1361,8 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) end subroutine double_diffusion !> This routine adds diffusion sustained by flow energy extracted by bottom drag. -subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & - maxTKE, kb, G, GV, US, CS, Kd_lay, Kd_int, Kd_BBL) +subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, & + kb, rho_bot, G, GV, US, CS, Kd_lay, Kd_int, Kd_BBL) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -1143,20 +1379,23 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & !! boundary layer properties and related fields integer, intent(in) :: j !< j-index of row to work on real, dimension(SZI_(G),SZK_(GV)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE - !! TKE dissipated within a layer and the - !! diapycnal diffusivity witin that layer, + !! TKE dissipated within a layer and the + !! diapycnal diffusivity within that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) - !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] - real, dimension(SZI_(G),SZK_(GV)), intent(in) :: maxTKE !< The energy required to for a layer to entrain - !! to its maximum-realizable thickness [Z3 T-3 ~> m3 s-3] + !! [T2 Z-1 ~> s2 m-1] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: maxTKE !< The energy required to for a layer to entrain to its + !! maximum-realizable thickness [H Z2 T-3 ~> m3 s-3 or W m-2] integer, dimension(SZI_(G)), intent(in) :: kb !< Index of lightest layer denser than the buffer !! layer, or -1 without a bulk mixed layer + real, dimension(SZI_(G)), intent(in) :: rho_bot !< In situ density averaged over a near-bottom + !! region [R ~> kg m-3] type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers, - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZK_(GV)+1), intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces, - !! [Z2 T-1 ~> m2 s-1]. - real, dimension(:,:,:), pointer :: Kd_BBL !< Interface BBL diffusivity [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(:,:,:), pointer :: Kd_BBL !< Interface BBL diffusivity + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] ! This routine adds diffusion sustained by flow energy extracted by bottom drag. @@ -1164,25 +1403,25 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & Rint ! coordinate density of an interface [R ~> kg m-3] real, dimension(SZI_(G)) :: & htot, & ! total thickness above or below a layer, or the - ! integrated thickness in the BBL [Z ~> m]. - rho_htot, & ! running integral with depth of density [R Z ~> kg m-2] + ! integrated thickness in the BBL [H ~> m or kg m-2]. + rho_htot, & ! running integral with depth of density [R H ~> kg m-2 or kg2 m-5] gh_sum_top, & ! BBL value of g'h that can be supported by - ! the local ustar, times R0_g [R Z ~> kg m-2] + ! the local ustar, times R0_g [R H ~> kg m-2 or kg2 m-5] Rho_top, & ! density at top of the BBL [R ~> kg m-3] TKE, & ! turbulent kinetic energy available to drive - ! bottom-boundary layer mixing in a layer [Z3 T-3 ~> m3 s-3] - I2decay ! inverse of twice the TKE decay scale [Z-1 ~> m-1]. + ! bottom-boundary layer mixing in a layer [H Z2 T-3 ~> m3 s-3 or W m-2] + I2decay ! inverse of twice the TKE decay scale [H-1 ~> m-1 or m2 kg-1]. - real :: TKE_to_layer ! TKE used to drive mixing in a layer [Z3 T-3 ~> m3 s-3] - real :: TKE_Ray ! TKE from layer Rayleigh drag used to drive mixing in layer [Z3 T-3 ~> m3 s-3] - real :: TKE_here ! TKE that goes into mixing in this layer [Z3 T-3 ~> m3 s-3] + real :: TKE_to_layer ! TKE used to drive mixing in a layer [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_Ray ! TKE from layer Rayleigh drag used to drive mixing in layer [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_here ! TKE that goes into mixing in this layer [H Z2 T-3 ~> m3 s-3 or W m-2] real :: dRl, dRbot ! temporaries holding density differences [R ~> kg m-3] real :: cdrag_sqrt ! square root of the drag coefficient [nondim] - real :: ustar_h ! value of ustar at a thickness point [Z T-1 ~> m s-1]. + real :: ustar_h ! Ustar at a thickness point rescaled into thickness + ! flux units [H T-1 ~> m s-1 or kg m-2 s-1]. real :: absf ! average absolute Coriolis parameter around a thickness point [T-1 ~> s-1] - real :: R0_g ! Rho0 / G_Earth [R T2 Z-1 ~> kg s2 m-4] - real :: I_rho0 ! 1 / RHO0 [R-1 ~> m3 kg-1] - real :: delta_Kd ! increment to Kd from the bottom boundary layer mixing [Z2 T-1 ~> m2 s-1]. + real :: R0_g ! Rho0 / G_Earth [R T2 H-1 ~> kg s2 m-4 or s2 m-1] + real :: delta_Kd ! increment to Kd from the bottom boundary layer mixing [H Z T-1 ~> m2 s-1 or kg m-1 s-1] logical :: Rayleigh_drag ! Set to true if Rayleigh drag velocities ! defined in visc, on the assumption that this ! extracted energy also drives diapycnal mixing. @@ -1195,14 +1434,13 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & do_diag_Kd_BBL = associated(Kd_BBL) - if (.not.(CS%bottomdraglaw .and. (CS%BBL_effic>0.0))) return + if (.not.(CS%bottomdraglaw .and. (CS%BBL_effic > 0.0))) return cdrag_sqrt = sqrt(CS%cdrag) TKE_Ray = 0.0 ; Rayleigh_drag = .false. - if (associated(visc%Ray_u) .and. associated(visc%Ray_v)) Rayleigh_drag = .true. + if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) Rayleigh_drag = .true. - I_Rho0 = 1.0 / (GV%Rho0) - R0_g = GV%Rho0 / (US%L_to_Z**2 * GV%g_Earth) + R0_g = GV%H_to_RZ / GV%g_Earth_Z_T2 do K=2,nz ; Rint(K) = 0.5*(GV%Rlay(k-1)+GV%Rlay(k)) ; enddo @@ -1213,8 +1451,13 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & ! to be relatively small and is discarded. do i=is,ie ustar_h = visc%ustar_BBL(i,j) - if (associated(fluxes%ustar_tidal)) & - ustar_h = ustar_h + fluxes%ustar_tidal(i,j) + if (associated(fluxes%ustar_tidal)) then + if (allocated(tv%SpV_avg)) then + ustar_h = ustar_h + GV%RZ_to_H*rho_bot(i) * fluxes%ustar_tidal(i,j) + else + ustar_h = ustar_h + GV%Z_to_H * fluxes%ustar_tidal(i,j) + endif + endif absf = 0.25 * ((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1)))) if ((ustar_h > 0.0) .and. (absf > 0.5*CS%IMax_decay*ustar_h)) then @@ -1224,12 +1467,15 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & ! If ustar_h = 0, this is land so this value doesn't matter. I2decay(i) = 0.5*CS%IMax_decay endif - TKE(i) = ((CS%BBL_effic * cdrag_sqrt) * exp(-I2decay(i)*(GV%H_to_Z*h(i,j,nz))) ) * & - visc%TKE_BBL(i,j) + if (CS%drag_diff_answer_date <= 20250301) then + TKE(i) = ((CS%BBL_effic * cdrag_sqrt) * exp(-I2decay(i)*h(i,j,nz)) ) * visc%BBL_meanKE_loss_sqrtCd(i,j) + else + TKE(i) = (CS%BBL_effic * exp(-I2decay(i)*h(i,j,nz)) ) * visc%BBL_meanKE_loss(i,j) + endif - if (associated(fluxes%TKE_tidal)) & - TKE(i) = TKE(i) + fluxes%TKE_tidal(i,j) * I_Rho0 * & - (CS%BBL_effic * exp(-I2decay(i)*(GV%H_to_Z*h(i,j,nz)))) + if (associated(fluxes%BBL_tidal_dis)) & + TKE(i) = TKE(i) + fluxes%BBL_tidal_dis(i,j) * GV%RZ_to_H * & + (CS%BBL_effic * exp(-I2decay(i)*h(i,j,nz))) ! Distribute the work over a BBL of depth 20^2 ustar^2 / g' following ! Killworth & Edwards (1999) and Zilitikevich & Mironov (1996). @@ -1238,17 +1484,17 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & gh_sum_top(i) = R0_g * 400.0 * ustar_h**2 - do_i(i) = (G%mask2dT(i,j) > 0.5) - htot(i) = GV%H_to_Z*h(i,j,nz) - rho_htot(i) = GV%Rlay(nz)*(GV%H_to_Z*h(i,j,nz)) + do_i(i) = (G%mask2dT(i,j) > 0.0) + htot(i) = h(i,j,nz) + rho_htot(i) = GV%Rlay(nz)*(h(i,j,nz)) Rho_top(i) = GV%Rlay(1) if (CS%bulkmixedlayer .and. do_i(i)) Rho_top(i) = GV%Rlay(kb(i)-1) enddo do k=nz-1,2,-1 ; domore = .false. do i=is,ie ; if (do_i(i)) then - htot(i) = htot(i) + GV%H_to_Z*h(i,j,k) - rho_htot(i) = rho_htot(i) + GV%Rlay(k)*(GV%H_to_Z*h(i,j,k)) + htot(i) = htot(i) + h(i,j,k) + rho_htot(i) = rho_htot(i) + GV%Rlay(k)*(h(i,j,k)) if (htot(i)*GV%Rlay(k-1) <= (rho_htot(i) - gh_sum_top(i))) then ! The top of the mixing is in the interface atop the current layer. Rho_top(i) = (rho_htot(i) - gh_sum_top(i)) / htot(i) @@ -1259,7 +1505,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & if (.not.domore) exit enddo ! k-loop - do i=is,ie ; do_i(i) = (G%mask2dT(i,j) > 0.5) ; enddo + do i=is,ie ; do_i(i) = (G%mask2dT(i,j) > 0.0) ; enddo do k=nz-1,kb_min,-1 i_rem = 0 do i=is,ie ; if (do_i(i)) then @@ -1267,12 +1513,11 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & i_rem = i_rem + 1 ! Count the i-rows that are still being worked on. ! Apply vertical decay of the turbulent energy. This energy is ! simply lost. - TKE(i) = TKE(i) * exp(-I2decay(i) * (GV%H_to_Z*(h(i,j,k) + h(i,j,k+1)))) + TKE(i) = TKE(i) * exp(-I2decay(i) * (h(i,j,k) + h(i,j,k+1))) -! if (maxEnt(i,k) <= 0.0) cycle if (maxTKE(i,k) <= 0.0) cycle - ! This is an analytic integral where diffusity is a quadratic function of + ! This is an analytic integral where diffusivity is a quadratic function of ! rho that goes asymptotically to 0 at Rho_top (vaguely following KPP?). if (TKE(i) > 0.0) then if (Rint(K) <= Rho_top(i)) then @@ -1285,11 +1530,11 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & else ; TKE_to_layer = 0.0 ; endif ! TKE_Ray has been initialized to 0 above. - if (Rayleigh_drag) TKE_Ray = 0.5*CS%BBL_effic * US%L_to_Z**2 * G%IareaT(i,j) * & - ((G%areaCu(I-1,j) * visc%Ray_u(I-1,j,k) * u(I-1,j,k)**2 + & - G%areaCu(I,j) * visc%Ray_u(I,j,k) * u(I,j,k)**2) + & - (G%areaCv(i,J-1) * visc%Ray_v(i,J-1,k) * v(i,J-1,k)**2 + & - G%areaCv(i,J) * visc%Ray_v(i,J,k) * v(i,J,k)**2)) + if (Rayleigh_drag) TKE_Ray = 0.5*CS%BBL_effic * G%IareaT(i,j) * & + (((G%areaCu(I-1,j) * visc%Ray_u(I-1,j,k) * u(I-1,j,k)**2) + & + (G%areaCu(I,j) * visc%Ray_u(I,j,k) * u(I,j,k)**2)) + & + ((G%areaCv(i,J-1) * visc%Ray_v(i,J-1,k) * v(i,J-1,k)**2) + & + (G%areaCv(i,J) * visc%Ray_v(i,J,k) * v(i,J,k)**2))) if (TKE_to_layer + TKE_Ray > 0.0) then if (CS%BBL_mixing_as_max) then @@ -1304,7 +1549,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & delta_Kd = CS%Kd_max Kd_lay(i,k) = Kd_lay(i,k) + delta_Kd else - Kd_lay(i,k) = (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) + Kd_lay(i,k) = (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) endif Kd_int(i,K) = Kd_int(i,K) + 0.5 * delta_Kd Kd_int(i,K+1) = Kd_int(i,K+1) + 0.5 * delta_Kd @@ -1358,7 +1603,7 @@ end subroutine add_drag_diffusivity !> Calculates a BBL diffusivity use a Prandtl number 1 diffusivity with a law of the !! wall turbulent viscosity, up to a BBL height where the energy used for mixing has !! consumed the mechanical TKE input. -subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int, & +subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Rho_bot, Kd_int, & G, GV, US, CS, Kd_BBL, Kd_lay) type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure @@ -1377,39 +1622,45 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int integer, intent(in) :: j !< j-index of row to work on real, dimension(SZI_(G),SZK_(GV)+1), & intent(in) :: N2_int !< Square of Brunt-Vaisala at interfaces [T-2 ~> s-2] + real, dimension(SZI_(G)), intent(in) :: rho_bot !< In situ density averaged over a near-bottom + !! region [R ~> kg m-3] real, dimension(SZI_(G),SZK_(GV)+1), & - intent(inout) :: Kd_int !< Interface net diffusivity [Z2 T-1 ~> m2 s-1] + intent(inout) :: Kd_int !< Interface net diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure - real, dimension(:,:,:), pointer :: Kd_BBL !< Interface BBL diffusivity [Z2 T-1 ~> m2 s-1] + real, dimension(:,:,:), pointer :: Kd_BBL !< Interface BBL diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZK_(GV)), & - optional, intent(inout) :: Kd_lay !< Layer net diffusivity [Z2 T-1 ~> m2 s-1] + optional, intent(inout) :: Kd_lay !< Layer net diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] ! Local variables - real :: TKE_column ! net TKE input into the column [Z3 T-3 ~> m3 s-3] - real :: TKE_remaining ! remaining TKE available for mixing in this layer and above [Z3 T-3 ~> m3 s-3] - real :: TKE_consumed ! TKE used for mixing in this layer [Z3 T-3 ~> m3 s-3] - real :: TKE_Kd_wall ! TKE associated with unlimited law of the wall mixing [Z3 T-3 ~> m3 s-3] + real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] + real :: dz_above(SZK_(GV)+1) ! Distance from each interface to the surface [Z ~> m] + real :: TKE_column ! net TKE input into the column [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: BBL_meanKE_dis ! Sum of tidal and mean kinetic energy dissipation in the bottom boundary layer, which + ! can act as a source of TKE [H L2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_remaining ! remaining TKE available for mixing in this layer and above [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_consumed ! TKE used for mixing in this layer [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_Kd_wall ! TKE associated with unlimited law of the wall mixing [H Z2 T-3 ~> m3 s-3 or W m-2] real :: cdrag_sqrt ! square root of the drag coefficient [nondim] - real :: ustar ! value of ustar at a thickness point [Z T-1 ~> m s-1]. - real :: ustar2 ! square of ustar, for convenience [Z2 T-2 ~> m2 s-2] + real :: ustar ! value of ustar at a thickness point [H T-1 ~> m s-1 or kg m-2 s-1]. + real :: ustar2 ! The square of ustar [H2 T-2 ~> m2 s-2 or kg2 m-4 s-2] real :: absf ! average absolute value of Coriolis parameter around a thickness point [T-1 ~> s-1] - real :: dh, dhm1 ! thickness of layers k and k-1, respecitvely [Z ~> m]. - real :: z_bot ! distance to interface k from bottom [Z ~> m]. - real :: D_minus_z ! distance to interface k from surface [Z ~> m]. - real :: total_thickness ! total thickness of water column [Z ~> m]. - real :: Idecay ! inverse of decay scale used for "Joule heating" loss of TKE with height [Z-1 ~> m-1]. - real :: Kd_wall ! Law of the wall diffusivity [Z2 T-1 ~> m2 s-1]. - real :: Kd_lower ! diffusivity for lower interface [Z2 T-1 ~> m2 s-1] - real :: ustar_D ! u* x D [Z2 T-1 ~> m2 s-1]. - real :: I_Rho0 ! 1 / rho0 [R-1 ~> m3 kg-1] + real :: dz_int ! Distance between the center of the layers around an interface [Z ~> m] + real :: z_bot ! Distance to interface K from bottom [Z ~> m] + real :: h_bot ! Total thickness between interface K and the bottom [H ~> m or kg m-2] + real :: D_minus_z ! Distance between interface k and the surface [Z ~> m] + real :: total_depth ! Total distance between the seafloor and the sea surface [Z ~> m] + real :: Idecay ! Inverse of decay scale used for "Joule heating" loss of TKE with + ! height [H-1 ~> m-1 or m2 kg-1]. + real :: Kd_wall ! Law of the wall diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Kd_lower ! diffusivity for lower interface [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: ustar_D ! The extent of the water column times u* [H Z T-1 ~> m2 s-1 or Pa s]. real :: N2_min ! Minimum value of N2 to use in calculation of TKE_Kd_wall [T-2 ~> s-2] logical :: Rayleigh_drag ! Set to true if there are Rayleigh drag velocities defined in visc, on ! the assumption that this extracted energy also drives diapycnal mixing. - integer :: i, k, km1 - real, parameter :: von_karm = 0.41 ! Von Karman constant (http://en.wikipedia.org/wiki/Von_Karman_constant) + integer :: i, k logical :: do_diag_Kd_BBL - if (.not.(CS%bottomdraglaw .and. (CS%BBL_effic>0.0))) return + if (.not.(CS%bottomdraglaw .and. (CS%BBL_effic > 0.0))) return do_diag_Kd_BBL = associated(Kd_BBL) N2_min = 0. @@ -1417,79 +1668,98 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int ! Determine whether to add Rayleigh drag contribution to TKE Rayleigh_drag = .false. - if (associated(visc%Ray_u) .and. associated(visc%Ray_v)) Rayleigh_drag = .true. - I_Rho0 = 1.0 / (GV%Rho0) + if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) Rayleigh_drag = .true. cdrag_sqrt = sqrt(CS%cdrag) + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + do i=G%isc,G%iec ! Developed in single-column mode ! Column-wise parameters. absf = 0.25 * ((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1)))) ! Non-zero on equator! - ! u* at the bottom [Z T-1 ~> m s-1]. + ! u* at the bottom [H T-1 ~> m s-1 or kg m-2 s-1]. ustar = visc%ustar_BBL(i,j) ustar2 = ustar**2 - ! In add_drag_diffusivity(), fluxes%ustar_tidal is added in. This might be double counting - ! since ustar_BBL should already include all contributions to u*? -AJA - !### Examine the question of whether there is double counting of fluxes%ustar_tidal. - if (associated(fluxes%ustar_tidal)) ustar = ustar + fluxes%ustar_tidal(i,j) + ! In add_drag_diffusivity(), fluxes%ustar_tidal is also added in. There is no + ! double-counting because the logic surrounding the calls to add_drag_diffusivity() + ! and add_LOTW_BBL_diffusivity() only calls one of the two routines. + if (associated(fluxes%ustar_tidal)) then + if (allocated(tv%SpV_avg)) then + ustar = ustar + GV%RZ_to_H*rho_bot(i) * fluxes%ustar_tidal(i,j) + else + ustar = ustar + GV%Z_to_H * fluxes%ustar_tidal(i,j) + endif + endif ! The maximum decay scale should be something of order 200 m. We use the smaller of u*/f and ! (IMax_decay)^-1 as the decay scale. If ustar = 0, this is land so this value doesn't matter. Idecay = CS%IMax_decay if ((ustar > 0.0) .and. (absf > CS%IMax_decay * ustar)) Idecay = absf / ustar - ! Energy input at the bottom [Z3 T-3 ~> m3 s-3]. - ! (Note that visc%TKE_BBL is in [Z3 T-3 ~> m3 s-3], set in set_BBL_TKE().) - ! I am still unsure about sqrt(cdrag) in this expressions - AJA - TKE_column = cdrag_sqrt * visc%TKE_BBL(i,j) - ! Add in tidal dissipation energy at the bottom [Z3 T-3 ~> m3 s-3]. - ! Note that TKE_tidal is in [R Z3 T-3 ~> W m-2]. - if (associated(fluxes%TKE_tidal)) & - TKE_column = TKE_column + fluxes%TKE_tidal(i,j) * I_Rho0 - TKE_column = CS%BBL_effic * TKE_column ! Only use a fraction of the mechanical dissipation for mixing. + ! Energy input at the bottom [H Z2 T-3 ~> m3 s-3 or W m-2]. + ! (Note that visc%BBL_meanKE_loss is in [H L2 T-3 ~> m3 s-3 or W m-2], set in set_BBL_TKE().) + BBL_meanKE_dis = visc%BBL_meanKE_loss(i,j) + ! Add in tidal dissipation energy at the bottom [H Z2 T-3 ~> m3 s-3 or W m-2]. + ! Note that BBL_tidal_dis is in [R Z L2 T-3 ~> W m-2]. + if (associated(fluxes%BBL_tidal_dis)) & + BBL_meanKE_dis = BBL_meanKE_dis + fluxes%BBL_tidal_dis(i,j) * GV%RZ_to_H + TKE_column = CS%BBL_effic * BBL_meanKE_dis ! Only use a fraction of the mechanical dissipation for mixing. TKE_remaining = TKE_column - total_thickness = ( sum(h(i,j,:)) + GV%H_subroundoff )* GV%H_to_Z ! Total column thickness [Z ~> m]. - ustar_D = ustar * total_thickness + if (CS%LOTW_BBL_answer_date > 20240630) then + dz_above(1) = GV%dz_subroundoff ! This could perhaps be 0 instead. + do K=2,GV%ke+1 + dz_above(K) = dz_above(K-1) + dz(i,k-1) + enddo + total_depth = dz_above(GV%ke+1) + else + total_depth = ( sum(dz(i,:)) + GV%dz_subroundoff ) ! Total column thickness [Z ~> m]. + endif + ustar_D = ustar * total_depth + h_bot = 0. z_bot = 0. Kd_lower = 0. ! Diffusivity on bottom boundary. ! Work upwards from the bottom, accumulating work used until it exceeds the available TKE input ! at the bottom. - do k=GV%ke,2,-1 - dh = GV%H_to_Z * h(i,j,k) ! Thickness of this level [Z ~> m]. - km1 = max(k-1, 1) - dhm1 = GV%H_to_Z * h(i,j,km1) ! Thickness of level above [Z ~> m]. + do K=GV%ke,2,-1 + dz_int = 0.5 * (dz(i,k-1) + dz(i,k)) ! Add in additional energy input from bottom-drag against slopes (sides) if (Rayleigh_drag) TKE_remaining = TKE_remaining + & - 0.5*CS%BBL_effic * US%L_to_Z**2 * G%IareaT(i,j) * & - ((G%areaCu(I-1,j) * visc%Ray_u(I-1,j,k) * u(I-1,j,k)**2 + & - G%areaCu(I,j) * visc%Ray_u(I,j,k) * u(I,j,k)**2) + & - (G%areaCv(i,J-1) * visc%Ray_v(i,J-1,k) * v(i,J-1,k)**2 + & - G%areaCv(i,J) * visc%Ray_v(i,J,k) * v(i,J,k)**2)) + 0.5*CS%BBL_effic * G%IareaT(i,j) * & + (((G%areaCu(I-1,j) * visc%Ray_u(I-1,j,k) * u(I-1,j,k)**2) + & + (G%areaCu(I,j) * visc%Ray_u(I,j,k) * u(I,j,k)**2)) + & + ((G%areaCv(i,J-1) * visc%Ray_v(i,J-1,k) * v(i,J-1,k)**2) + & + (G%areaCv(i,J) * visc%Ray_v(i,J,k) * v(i,J,k)**2))) ! Exponentially decay TKE across the thickness of the layer. ! This is energy loss in addition to work done as mixing, apparently to Joule heating. - TKE_remaining = exp(-Idecay*dh) * TKE_remaining + TKE_remaining = exp(-Idecay*h(i,j,k)) * TKE_remaining - z_bot = z_bot + h(i,j,k)*GV%H_to_Z ! Distance between upper interface of layer and the bottom [Z ~> m]. - D_minus_z = max(total_thickness - z_bot, 0.) ! Thickness above layer [Z ~> m]. + z_bot = z_bot + dz(i,k) ! Distance between upper interface of layer and the bottom [Z ~> m]. + h_bot = h_bot + h(i,j,k) ! Thickness between upper interface of layer and the bottom [H ~> m or kg m-2]. + if (CS%LOTW_BBL_answer_date > 20240630) then + D_minus_z = dz_above(K) + else + D_minus_z = max(total_depth - z_bot, 0.) ! Distance from the interface to the surface [Z ~> m]. + endif - ! Diffusivity using law of the wall, limited by rotation, at height z [Z2 T-1 ~> m2 s-1]. + ! Diffusivity using law of the wall, limited by rotation, at height z [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. ! This calculation is at the upper interface of the layer - if ( ustar_D + absf * ( z_bot * D_minus_z ) == 0.) then + if ( ustar_D + absf * ( h_bot * D_minus_z ) == 0.) then Kd_wall = 0. else - Kd_wall = ((von_karm * ustar2) * (z_bot * D_minus_z)) & - / (ustar_D + absf * (z_bot * D_minus_z)) + Kd_wall = ((CS%von_karm * ustar2) * (z_bot * D_minus_z)) & + / (ustar_D + absf * (h_bot * D_minus_z)) endif - ! TKE associated with Kd_wall [Z3 T-3 ~> m3 s-3]. - ! This calculation if for the volume spanning the interface. - TKE_Kd_wall = Kd_wall * 0.5 * (dh + dhm1) * max(N2_int(i,k), N2_min) + ! TKE associated with Kd_wall [H Z2 T-3 ~> m3 s-3 or W m-2]. + ! This calculation is for the volume spanning the interface. + TKE_Kd_wall = Kd_wall * dz_int * max(N2_int(i,K), N2_min) ! Now bound Kd such that the associated TKE is no greater than available TKE for mixing. if (TKE_Kd_wall > 0.) then @@ -1519,43 +1789,48 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int end subroutine add_LOTW_BBL_diffusivity !> This routine adds effects of mixed layer radiation to the layer diffusivities. -subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, Kd_lay) +subroutine add_MLrad_diffusivity(dz, fluxes, tv, j, Kd_int, G, GV, US, CS, TKE_to_Kd, Kd_lay) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: dz !< Height change across layers [Z ~> m] type(forcing), intent(in) :: fluxes !< Surface fluxes structure + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + !! thermodynamic fields. integer, intent(in) :: j !< The j-index to work on real, dimension(SZI_(G),SZK_(GV)+1), intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure real, dimension(SZI_(G),SZK_(GV)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE !! TKE dissipated within a layer and the !! diapycnal diffusivity witin that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) - !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] + !! [T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(GV)), & - optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers [Z2 T-1 ~> m2 s-1]. + optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. ! This routine adds effects of mixed layer radiation to the layer diffusivities. - real, dimension(SZI_(G)) :: h_ml ! Mixed layer thickness [Z ~> m]. - real, dimension(SZI_(G)) :: TKE_ml_flux ! Mixed layer TKE flux [Z3 T-3 ~> m3 s-3] - real, dimension(SZI_(G)) :: I_decay ! A decay rate [Z-1 ~> m-1]. - real, dimension(SZI_(G)) :: Kd_mlr_ml ! Diffusivities associated with mixed layer radiation [Z2 T-1 ~> m2 s-1]. + real, dimension(SZI_(G)) :: h_ml ! Mixed layer thickness [Z ~> m] + real, dimension(SZI_(G)) :: TKE_ml_flux ! Mixed layer TKE flux [H Z2 T-3 ~> m3 s-3 or W m-2] + real, dimension(SZI_(G)) :: I_decay ! A decay rate [Z-1 ~> m-1]. + real, dimension(SZI_(G)) :: Kd_mlr_ml ! Diffusivities associated with mixed layer radiation + ! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: f_sq ! The square of the local Coriolis parameter or a related variable [T-2 ~> s-2]. - real :: h_ml_sq ! The square of the mixed layer thickness [Z2 ~> m2]. + real :: h_ml_sq ! The square of the mixed layer thickness [Z2 ~> m2] + real :: u_star_H ! ustar converted to thickness based units [H T-1 ~> m s-1 or kg m-2 s-1] real :: ustar_sq ! ustar squared [Z2 T-2 ~> m2 s-2] - real :: Kd_mlr ! A diffusivity associated with mixed layer turbulence radiation [Z2 T-1 ~> m2 s-1]. - real :: C1_6 ! 1/6 + real :: Kd_mlr ! A diffusivity associated with mixed layer turbulence radiation + ! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: I_rho ! The inverse of the Boussinesq reference density [R-1 ~> m3 kg-1] + real :: C1_6 ! 1/6 [nondim] real :: Omega2 ! rotation rate squared [T-2 ~> s-2]. real :: z1 ! layer thickness times I_decay [nondim] - real :: dzL ! thickness converted to heights [Z ~> m]. - real :: I_decay_len2_TKE ! squared inverse decay lengthscale for - ! TKE, as used in the mixed layer code [Z-2 ~> m-2]. - real :: h_neglect ! negligibly small thickness [Z ~> m]. + real :: I_decay_len2_TKE ! Squared inverse decay lengthscale for TKE from the bulk mixed + ! layer code [Z-2 ~> m-2] + real :: dz_neglect ! A negligibly small height change [Z ~> m] logical :: do_any, do_i(SZI_(G)) integer :: i, k, is, ie, nz, kml @@ -1564,38 +1839,49 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, Omega2 = CS%omega**2 C1_6 = 1.0 / 6.0 kml = GV%nkml - h_neglect = GV%H_subroundoff*GV%H_to_Z + dz_neglect = GV%dz_subroundoff + I_rho = GV%H_to_Z * GV%RZ_to_H ! == 1.0 / GV%Rho0 ! This is not used when fully non-Boussinesq. if (.not.CS%ML_radiation) return - do i=is,ie ; h_ml(i) = 0.0 ; do_i(i) = (G%mask2dT(i,j) > 0.5) ; enddo - do k=1,kml ; do i=is,ie ; h_ml(i) = h_ml(i) + GV%H_to_Z*h(i,j,k) ; enddo ; enddo + do i=is,ie ; h_ml(i) = 0.0 ; do_i(i) = (G%mask2dT(i,j) > 0.0) ; enddo + do k=1,kml ; do i=is,ie ; h_ml(i) = h_ml(i) + dz(i,k) ; enddo ; enddo do i=is,ie ; if (do_i(i)) then if (CS%ML_omega_frac >= 1.0) then f_sq = 4.0 * Omega2 else - f_sq = 0.25 * ((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & - (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2)) + f_sq = 0.25 * ((G%Coriolis2Bu(I,J) + G%Coriolis2Bu(I-1,J-1)) + & + (G%Coriolis2Bu(I,J-1) + G%Coriolis2Bu(I-1,J))) if (CS%ML_omega_frac > 0.0) & f_sq = CS%ML_omega_frac * 4.0 * Omega2 + (1.0 - CS%ML_omega_frac) * f_sq endif - ustar_sq = max(fluxes%ustar(i,j), CS%ustar_min)**2 - - TKE_ml_flux(i) = (CS%mstar * CS%ML_rad_coeff) * (ustar_sq * (fluxes%ustar(i,j))) + ! Determine the energy flux out of the mixed layer and its vertical decay scale. + if (associated(fluxes%ustar) .and. (GV%Boussinesq .or. .not.associated(fluxes%tau_mag))) then + ustar_sq = max(fluxes%ustar(i,j), CS%ustar_min)**2 + u_star_H = GV%Z_to_H * fluxes%ustar(i,j) + elseif (allocated(tv%SpV_avg)) then + ustar_sq = max(fluxes%tau_mag(i,j) * tv%SpV_avg(i,j,1), CS%ustar_min**2) + u_star_H = GV%RZ_to_H * sqrt(fluxes%tau_mag(i,j) / tv%SpV_avg(i,j,1)) + else ! This semi-Boussinesq form is mathematically equivalent to the Boussinesq version above. + ! Differs at roundoff: ustar_sq = max(fluxes%tau_mag(i,j) * I_rho, CS%ustar_min**2) + ustar_sq = max((sqrt(fluxes%tau_mag(i,j) * I_rho))**2, CS%ustar_min**2) + u_star_H = GV%RZ_to_H * sqrt(fluxes%tau_mag(i,j) * GV%Rho0) + endif + TKE_ml_flux(i) = (CS%mstar * CS%ML_rad_coeff) * (ustar_sq * u_star_H) I_decay_len2_TKE = CS%TKE_decay**2 * (f_sq / ustar_sq) if (CS%ML_rad_TKE_decay) & TKE_ml_flux(i) = TKE_ml_flux(i) * exp(-h_ml(i) * sqrt(I_decay_len2_TKE)) ! Calculate the inverse decay scale - h_ml_sq = (CS%ML_rad_efold_coeff * (h_ml(i)+h_neglect))**2 + h_ml_sq = (CS%ML_rad_efold_coeff * (h_ml(i)+dz_neglect))**2 I_decay(i) = sqrt((I_decay_len2_TKE * h_ml_sq + 1.0) / h_ml_sq) ! Average the dissipation layer kml+1, using ! a more accurate Taylor series approximations for very thin layers. - z1 = (GV%H_to_Z*h(i,j,kml+1)) * I_decay(i) + z1 = dz(i,kml+1) * I_decay(i) if (z1 > 1e-5) then Kd_mlr = TKE_ml_flux(i) * TKE_to_Kd(i,kml+1) * (1.0 - exp(-z1)) else @@ -1620,16 +1906,16 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, do k=kml+2,nz-1 do_any = .false. do i=is,ie ; if (do_i(i)) then - dzL = GV%H_to_Z*h(i,j,k) ; z1 = dzL*I_decay(i) + z1 = dz(i,k)*I_decay(i) if (CS%ML_Rad_bug) then - ! These expresssions are dimensionally inconsistent. -RWH + ! These expressions are dimensionally inconsistent. -RWH ! This is supposed to be the integrated energy deposited in the layer, ! not the average over the layer as in these expressions. if (z1 > 1e-5) then - Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of Z2 T-1 - US%m_to_Z * ((1.0 - exp(-z1)) / dzL) ! Units of m-1 + Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of H Z T-1 + US%m_to_Z * ((1.0 - exp(-z1)) / dz(i,k)) ! Units of m-1 else - Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of Z2 T-1 + Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of H Z T-1 US%m_to_Z * (I_decay(i) * (1.0 - z1 * (0.5 - C1_6*z1))) ! Units of m-1 endif else @@ -1658,7 +1944,7 @@ end subroutine add_MLrad_diffusivity !> This subroutine calculates several properties related to bottom !! boundary layer turbulence. -subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) +subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -1668,8 +1954,9 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Structure with pointers to thermodynamic fields type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes - type(vertvisc_type), intent(in) :: visc !< Structure containing vertical viscosities, bottom + type(vertvisc_type), intent(inout) :: visc !< Structure containing vertical viscosities, bottom !! boundary layer properties and related fields. type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. @@ -1678,22 +1965,23 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) ! boundary layer turbulence. real, dimension(SZI_(G)) :: & - htot ! total thickness above or below a layer, or the - ! integrated thickness in the BBL [Z ~> m]. + htot ! Running sum of the depth in the BBL [Z ~> m]. real, dimension(SZIB_(G)) :: & uhtot, & ! running integral of u in the BBL [Z L T-1 ~> m2 s-1] - ustar, & ! bottom boundary layer turbulence speed [Z T-1 ~> m s-1]. + ustar, & ! bottom boundary layer piston velocity [H T-1 ~> m s-1 or kg m-2 s-1]. u2_bbl ! square of the mean zonal velocity in the BBL [L2 T-2 ~> m2 s-2] real :: vhtot(SZI_(G)) ! running integral of v in the BBL [Z L T-1 ~> m2 s-1] real, dimension(SZI_(G),SZJB_(G)) :: & - vstar, & ! ustar at at v-points [Z T-1 ~> m s-1]. + vstar, & ! ustar at at v-points [H T-1 ~> m s-1 or kg m-2 s-1]. v2_bbl ! square of average meridional velocity in BBL [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + dz ! The vertical distance between interfaces around a layer [Z ~> m] - real :: cdrag_sqrt ! square root of the drag coefficient [nondim] - real :: hvel ! thickness at velocity points [Z ~> m]. + real :: cdrag_sqrt ! Square root of the drag coefficient [nondim] + real :: hvel ! thickness at velocity points [Z ~> m] logical :: domore, do_i(SZI_(G)) integer :: i, j, k, is, ie, js, je, nz @@ -1716,51 +2004,60 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) if (.not.CS%initialized) call MOM_error(FATAL,"set_BBL_TKE: "//& "Module must be initialized before it is used.") - if (.not.CS%bottomdraglaw .or. (CS%BBL_effic<=0.0)) then - if (associated(visc%ustar_BBL)) then + if (.not.CS%bottomdraglaw .or. (CS%BBL_effic<=0.0 .and. CS%ePBL_BBL_effic<=0.0 .and. & + (.not.CS%ePBL_BBL_mstar))) then + if (allocated(visc%ustar_BBL)) then do j=js,je ; do i=is,ie ; visc%ustar_BBL(i,j) = 0.0 ; enddo ; enddo endif - if (associated(visc%TKE_BBL)) then - do j=js,je ; do i=is,ie ; visc%TKE_BBL(i,j) = 0.0 ; enddo ; enddo + if (allocated(visc%BBL_meanKE_loss)) then + do j=js,je ; do i=is,ie ; visc%BBL_meanKE_loss(i,j) = 0.0 ; enddo ; enddo + endif + if (allocated(visc%BBL_meanKE_loss_sqrtCd)) then + do j=js,je ; do i=is,ie ; visc%BBL_meanKE_loss_sqrtCd(i,j) = 0.0 ; enddo ; enddo endif return endif cdrag_sqrt = sqrt(CS%cdrag) + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + !$OMP parallel default(shared) private(do_i,vhtot,htot,domore,hvel,uhtot,ustar,u2_bbl) !$OMP do do J=js-1,je - ! Determine ustar and the square magnitude of the velocity in the - ! bottom boundary layer. Together these give the TKE source and - ! vertical decay scale. - do i=is,ie ; if ((G%mask2dCv(i,J) > 0.5) .and. (cdrag_sqrt*visc%bbl_thick_v(i,J) > 0.0)) then - do_i(i) = .true. ; vhtot(i) = 0.0 ; htot(i) = 0.0 - vstar(i,J) = visc%Kv_bbl_v(i,J) / (cdrag_sqrt*visc%bbl_thick_v(i,J)) - else - do_i(i) = .false. ; vstar(i,J) = 0.0 ; htot(i) = 0.0 - endif ; enddo + ! Determine ustar and the square magnitude of the velocity in the bottom boundary layer. + ! Together these give the TKE source and vertical decay scale. + do i=is,ie + do_i(i) = .false. ; vstar(i,J) = 0.0 ; vhtot(i) = 0.0 ; htot(i) = 0.0 + enddo + if (allocated(visc%Kv_bbl_v)) then + do i=is,ie ; if ((G%mask2dCv(i,J) > 0.0) .and. (cdrag_sqrt*visc%bbl_thick_v(i,J) > 0.0)) then + do_i(i) = .true. + vstar(i,J) = visc%Kv_bbl_v(i,J) / (cdrag_sqrt*visc%bbl_thick_v(i,J)) + endif ; enddo + endif + !### What about terms from visc%Ray? + do k=nz,1,-1 domore = .false. do i=is,ie ; if (do_i(i)) then ! Determine if grid point is an OBC has_obc = .false. if (local_open_v_BC) then - l_seg = OBC%segnum_v(i,J) - if (l_seg /= OBC_NONE) then - has_obc = OBC%segment(l_seg)%open - endif + l_seg = abs(OBC%segnum_v(i,J)) + if (l_seg /= 0) has_obc = OBC%segment(l_seg)%open endif ! Compute h based on OBC state if (has_obc) then - if (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then - hvel = GV%H_to_Z*h(i,j,k) + if (OBC%segnum_v(i,J) > 0) then ! OBC_DIRECTION_N + hvel = dz(i,j,k) else - hvel = GV%H_to_Z*h(i,j+1,k) + hvel = dz(i,j+1,k) endif else - hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j+1,k)) + hvel = 0.5*(dz(i,j,k) + dz(i,j+1,k)) endif if ((htot(i) + hvel) >= visc%bbl_thick_v(i,J)) then @@ -1775,40 +2072,42 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) endif ; enddo if (.not.domore) exit enddo - do i=is,ie ; if ((G%mask2dCv(i,J) > 0.5) .and. (htot(i) > 0.0)) then - v2_bbl(i,J) = (vhtot(i)*vhtot(i))/(htot(i)*htot(i)) + do i=is,ie ; if ((G%mask2dCv(i,J) > 0.0) .and. (htot(i) > 0.0)) then + v2_bbl(i,J) = (vhtot(i)*vhtot(i)) / (htot(i)*htot(i)) else v2_bbl(i,J) = 0.0 endif ; enddo enddo !$OMP do do j=js,je - do I=is-1,ie ; if ((G%mask2dCu(I,j) > 0.5) .and. (cdrag_sqrt*visc%bbl_thick_u(I,j) > 0.0)) then - do_i(I) = .true. ; uhtot(I) = 0.0 ; htot(I) = 0.0 - ustar(I) = visc%Kv_bbl_u(I,j) / (cdrag_sqrt*visc%bbl_thick_u(I,j)) - else - do_i(I) = .false. ; ustar(I) = 0.0 ; htot(I) = 0.0 - endif ; enddo + do I=is-1,ie + do_i(I) = .false. ; ustar(I) = 0.0 ; uhtot(I) = 0.0 ; htot(I) = 0.0 + enddo + if (allocated(visc%bbl_thick_u)) then + do I=is-1,ie ; if ((G%mask2dCu(I,j) > 0.0) .and. (cdrag_sqrt*visc%bbl_thick_u(I,j) > 0.0)) then + do_i(I) = .true. + ustar(I) = visc%Kv_bbl_u(I,j) / (cdrag_sqrt*visc%bbl_thick_u(I,j)) + endif ; enddo + endif + do k=nz,1,-1 ; domore = .false. do I=is-1,ie ; if (do_i(I)) then ! Determine if grid point is an OBC has_obc = .false. if (local_open_u_BC) then - l_seg = OBC%segnum_u(I,j) - if (l_seg /= OBC_NONE) then - has_obc = OBC%segment(l_seg)%open - endif + l_seg = abs(OBC%segnum_u(I,j)) + if (l_seg /= 0) has_obc = OBC%segment(l_seg)%open endif ! Compute h based on OBC state if (has_obc) then - if (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then - hvel = GV%H_to_Z*h(i,j,k) + if (OBC%segnum_u(I,j) > 0) then ! OBC_DIRECTION_E + hvel = dz(i,j,k) else ! OBC_DIRECTION_W - hvel = GV%H_to_Z*h(i+1,j,k) + hvel = dz(i+1,j,k) endif else - hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i+1,j,k)) + hvel = 0.5*(dz(i,j,k) + dz(i+1,j,k)) endif if ((htot(I) + hvel) >= visc%bbl_thick_u(I,j)) then @@ -1823,23 +2122,29 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) endif ; enddo if (.not.domore) exit enddo - do I=is-1,ie ; if ((G%mask2dCu(I,j) > 0.5) .and. (htot(i) > 0.0)) then - u2_bbl(I) = (uhtot(I)*uhtot(I))/(htot(I)*htot(I)) + do I=is-1,ie ; if ((G%mask2dCu(I,j) > 0.0) .and. (htot(i) > 0.0)) then + u2_bbl(I) = (uhtot(I)*uhtot(I)) / (htot(I)*htot(I)) else u2_bbl(I) = 0.0 endif ; enddo do i=is,ie visc%ustar_BBL(i,j) = sqrt(0.5*G%IareaT(i,j) * & - ((G%areaCu(I-1,j)*(ustar(I-1)*ustar(I-1)) + & - G%areaCu(I,j)*(ustar(I)*ustar(I))) + & - (G%areaCv(i,J-1)*(vstar(i,J-1)*vstar(i,J-1)) + & - G%areaCv(i,J)*(vstar(i,J)*vstar(i,J))) ) ) - visc%TKE_BBL(i,j) = US%L_to_Z**2 * & - (((G%areaCu(I-1,j)*(ustar(I-1)*u2_bbl(I-1)) + & - G%areaCu(I,j) * (ustar(I)*u2_bbl(I))) + & - (G%areaCv(i,J-1)*(vstar(i,J-1)*v2_bbl(i,J-1)) + & - G%areaCv(i,J) * (vstar(i,J)*v2_bbl(i,J))) )*G%IareaT(i,j)) + (((G%areaCu(I-1,j)*(ustar(I-1)*ustar(I-1))) + & + (G%areaCu(I,j)*(ustar(I)*ustar(I)))) + & + ((G%areaCv(i,J-1)*(vstar(i,J-1)*vstar(i,J-1))) + & + (G%areaCv(i,J)*(vstar(i,J)*vstar(i,J)))) ) ) + visc%BBL_meanKE_loss(i,j) = cdrag_sqrt * & + ((((G%areaCu(I-1,j)*(ustar(I-1)*u2_bbl(I-1))) + & + (G%areaCu(I,j) * (ustar(I)*u2_bbl(I)))) + & + ((G%areaCv(i,J-1)*(vstar(i,J-1)*v2_bbl(i,J-1))) + & + (G%areaCv(i,J) * (vstar(i,J)*v2_bbl(i,J)))) )*G%IareaT(i,j)) + ! The following line could be omitted if SET_DIFF_ANSWER_DATE > 20250301 and EPBL_BBL_EFFIC_BUG is false. + visc%BBL_meanKE_loss_sqrtCd(i,j) = & + ((((G%areaCu(I-1,j)*(ustar(I-1)*u2_bbl(I-1))) + & + (G%areaCu(I,j) * (ustar(I)*u2_bbl(I)))) + & + ((G%areaCv(i,J-1)*(vstar(i,J-1)*v2_bbl(i,J-1))) + & + (G%areaCv(i,J) * (vstar(i,J)*v2_bbl(i,J)))) )*G%IareaT(i,j)) enddo enddo !$OMP end parallel @@ -1870,11 +2175,12 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) ! Local variables real :: g_R0 ! g_R0 is a rescaled version of g/Rho [L2 Z-1 R-1 T-2 ~> m4 kg-1 s-2] - real :: eps, tmp ! nondimensional temporary variables - real :: a(SZK_(GV)), a_0(SZK_(GV)) ! nondimensional temporary variables + real :: eps, tmp ! nondimensional temporary variables [nondim] + real :: a(SZK_(GV)), a_0(SZK_(GV)) ! nondimensional temporary variables [nondim] real :: p_ref(SZI_(G)) ! an array of tv%P_Ref pressures [R L2 T-2 ~> Pa] real :: Rcv(SZI_(G),SZK_(GV)) ! coordinate density in the mixed and buffer layers [R ~> kg m-3] - real :: I_Drho ! temporary variable [R-1 ~> m3 kg-1] + real :: I_Drho ! The inverse of the coordinate density difference between + ! layers [R-1 ~> m3 kg-1] integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, k, k3, is, ie, nz, kmb @@ -1882,9 +2188,15 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) do k=2,nz-1 if (GV%g_prime(k+1) /= 0.0) then - do i=is,ie - ds_dsp1(i,k) = GV%g_prime(k) / GV%g_prime(k+1) - enddo + if (GV%Boussinesq .or. GV%Semi_Boussinesq) then + do i=is,ie + ds_dsp1(i,k) = GV%g_prime(k) / GV%g_prime(k+1) + enddo + else ! Use a mathematically equivalent form that avoids any dependency on RHO_0. + do i=is,ie + ds_dsp1(i,k) = (GV%Rlay(k) - GV%Rlay(k-1)) / (GV%Rlay(k+1) - GV%Rlay(k)) + enddo + endif else do i=is,ie ds_dsp1(i,k) = 1. @@ -1907,7 +2219,11 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) ! interfaces above and below the buffer layer and the next denser layer. k = kb(i) - I_Drho = g_R0 / GV%g_prime(k+1) + if (GV%Boussinesq .or. GV%Semi_Boussinesq) then + I_Drho = g_R0 / GV%g_prime(k+1) + else + I_Drho = 1.0 / (GV%Rlay(k+1) - GV%Rlay(k)) + endif ! The indexing convention for a is appropriate for the interfaces. do k3=1,kmb a(k3+1) = (GV%Rlay(k) - Rcv(i,k3)) * I_Drho @@ -1939,7 +2255,7 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) do k3=2,kmb ! ds_dsp1(i,k3) = MAX(a(k3),1e-5) - ! Deliberately treat convective instabilies of the upper mixed + ! Deliberately treat convective instabilities of the upper mixed ! and buffer layers with respect to the deepest buffer layer as ! though they don't exist. They will be eliminated by the upcoming ! call to the mixedlayer code anyway. @@ -1953,7 +2269,7 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) end subroutine set_density_ratios subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_CSp, halo_TS, & - double_diffuse) + double_diffuse, physical_OBL_scheme) type(time_type), intent(in) :: Time !< The current model time type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -1963,19 +2279,27 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ type(diag_ctrl), target, intent(inout) :: diag !< A structure used to regulate diagnostic output. type(set_diffusivity_CS), pointer :: CS !< pointer set to point to the module control !! structure. - type(int_tide_CS), intent(in), target :: int_tide_CSp !< Internal tide control struct - integer, optional, intent(out) :: halo_TS !< The halo size of tracer points that must be + type(int_tide_CS), pointer :: int_tide_CSp !< Internal tide control structure + integer, intent(out) :: halo_TS !< The halo size of tracer points that must be !! valid for the calculations in set_diffusivity. logical, intent(out) :: double_diffuse !< This indicates whether some version !! of double diffusion is being used. + logical, intent(in) :: physical_OBL_scheme !< If true, a physically based + !! parameterization (like KPP or ePBL or a bulk mixed + !! layer) is used outside of set_diffusivity to + !! specify the mixing that occurs in the ocean's + !! surface boundary layer. ! Local variables - real :: decay_length + real :: decay_length ! The maximum decay scale for the BBL diffusion [H ~> m or kg m-2] logical :: ML_use_omega - logical :: default_2018_answers + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_set_diffusivity" ! This module's name. + real :: vonKar ! The von Karman constant as used for mixed layer viscosity [nondim] + real :: Kd_z ! The background diapycnal diffusivity in [Z2 T-1 ~> m2 s-1] for use + ! in setting the default for other diffusivities. real :: omega_frac_dflt ! The default value for the fraction of the absolute rotation rate ! that is used in place of the absolute value of the local Coriolis ! parameter in the denominator of some expressions [nondim] @@ -1984,7 +2308,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ logical :: use_regridding ! If true, use the ALE algorithm rather than layered ! isopycnal or stacked shallow water mode. logical :: TKE_to_Kd_used ! If true, TKE_to_Kd and maxTKE need to be calculated. - integer :: i, j, is, ie, js, je + integer :: is, ie, js, je integer :: isd, ied, jsd, jed if (associated(CS)) then @@ -2020,13 +2344,17 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "OMEGA", CS%omega, & "The rotation rate of the earth.", units="s-1", default=7.2921e-5, scale=US%T_to_s) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) - call get_param(param_file, mdl, "SET_DIFF_2018_ANSWERS", CS%answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "SET_DIFF_ANSWER_DATE", CS%answer_date, & + "The vintage of the order of arithmetic and expressions in the set diffusivity "//& + "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. "//& + "Values above 20250301 also use less confusing expressions to set the bottom-drag "//& + "generated diffusivity when USE_LOTW_BBL_DIFFUSIVITY is false.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) ! CS%use_tidal_mixing is set to True if an internal tidal dissipation scheme is to be used. CS%use_tidal_mixing = tidal_mixing_init(Time, G, GV, US, param_file, & @@ -2040,7 +2368,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "length scale.", default=.false.) if (CS%ML_radiation) then ! This give a minimum decay scale that is typically much less than Angstrom. - CS%ustar_min = 2e-4 * CS%omega * (GV%Angstrom_Z + GV%H_subroundoff*GV%H_to_Z) + CS%ustar_min = 2e-4 * CS%omega * (GV%Angstrom_Z + GV%dZ_subroundoff) call get_param(param_file, mdl, "ML_RAD_EFOLD_COEFF", CS%ML_rad_efold_coeff, & "A coefficient that is used to scale the penetration "//& @@ -2054,7 +2382,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "The maximum diapycnal diffusivity due to turbulence "//& "radiated from the base of the mixed layer. "//& "This is only used if ML_RADIATION is true.", & - units="m2 s-1", default=1.0e-3, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=1.0e-3, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "ML_RAD_COEFF", CS%ML_rad_coeff, & "The coefficient which scales MSTAR*USTAR^3 to obtain "//& "the energy available for mixing below the base of the "//& @@ -2091,20 +2419,24 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "law of the form c_drag*|u|*u. The velocity magnitude "//& "may be an assumed value or it may be based on the actual "//& "velocity in the bottommost HBBL, depending on LINEAR_DRAG.", default=.true.) - if (CS%bottomdraglaw) then + if (CS%bottomdraglaw) then call get_param(param_file, mdl, "CDRAG", CS%cdrag, & "The drag coefficient relating the magnitude of the "//& "velocity field to the bottom stress. CDRAG is only used "//& "if BOTTOMDRAGLAW is true.", units="nondim", default=0.003) call get_param(param_file, mdl, "BBL_EFFIC", CS%BBL_effic, & - "The efficiency with which the energy extracted by "//& - "bottom drag drives BBL diffusion. This is only "//& - "used if BOTTOMDRAGLAW is true.", units="nondim", default=0.20) + "The efficiency with which the energy extracted by bottom drag drives BBL "//& + "diffusion. This is only used if BOTTOMDRAGLAW is true.", & + units="nondim", default=0.20, scale=US%L_to_Z**2) + call get_param(param_file, mdl, "EPBL_BBL_EFFIC", CS%ePBL_BBL_effic, & + units="nondim", default=0.0, do_not_log=.true.) + call get_param(param_file, mdl, "EPBL_BBL_USE_MSTAR", CS%ePBL_BBL_mstar, & + default=.false., do_not_log=.true.) call get_param(param_file, mdl, "BBL_MIXING_MAX_DECAY", decay_length, & "The maximum decay scale for the BBL diffusion, or 0 to allow the mixing "//& "to penetrate as far as stratification and rotation permit. The default "//& "for now is 200 m. This is only used if BOTTOMDRAGLAW is true.", & - units="m", default=200.0, scale=US%m_to_Z) + units="m", default=200.0, scale=GV%m_to_H) CS%IMax_decay = 0.0 if (decay_length > 0.0) CS%IMax_decay = 1.0/decay_length @@ -2121,12 +2453,34 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "LOTW_BBL_USE_OMEGA", CS%LOTW_BBL_use_omega, & "If true, use the maximum of Omega and N for the TKE to diffusion "//& "calculation. Otherwise, N is N.", default=.true.) + call get_param(param_file, mdl, 'VON_KARMAN_CONST', vonKar, & + 'The value the von Karman constant as used for mixed layer viscosity.', & + units='nondim', default=0.41) + call get_param(param_file, mdl, 'VON_KARMAN_BBL', CS%von_Karm, & + 'The value the von Karman constant as used in calculating the BBL diffusivity.', & + units='nondim', default=vonKar) endif else CS%use_LOTW_BBL_diffusivity = .false. ! This parameterization depends on a u* from viscous BBL endif + call get_param(param_file, mdl, "LOTW_BBL_ANSWER_DATE", CS%LOTW_BBL_answer_date, & + "The vintage of the order of arithmetic and expressions in the LOTW_BBL "//& + "calculations. Values below 20240630 recover the original answers, while "//& + "higher values use more accurate expressions. This only applies when "//& + "USE_LOTW_BBL_DIFFUSIVITY is true.", & + default=default_answer_date, do_not_log=.not.CS%use_LOTW_BBL_diffusivity) + call get_param(param_file, mdl, "DRAG_DIFFUSIVITY_ANSWER_DATE", CS%drag_diff_answer_date, & + "The vintage of the order of arithmetic in the drag diffusivity calculations. "//& + "Values above 20250301 use less confusing expressions to set the bottom-drag "//& + "generated diffusivity when USE_LOTW_BBL_DIFFUSIVITY is false. ", & + default=CS%answer_date, do_not_log=CS%use_LOTW_BBL_diffusivity.or.(CS%BBL_effic<=0.0)) + CS%id_Kd_BBL = register_diag_field('ocean_model', 'Kd_BBL', diag%axesTi, Time, & - 'Bottom Boundary Layer Diffusivity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Bottom Boundary Layer Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) + + call get_param(param_file, mdl, "DZ_BBL_AVG_MIN", CS%dz_BBL_avg_min, & + "A minimal distance over which to average to determine the average bottom "//& + "boundary layer density.", units="m", default=0.0, scale=US%m_to_Z) TKE_to_Kd_used = (CS%use_tidal_mixing .or. CS%ML_radiation .or. & (CS%bottomdraglaw .and. .not.CS%use_LOTW_BBL_diffusivity)) @@ -2137,25 +2491,30 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "for an isopycnal layer-formulation.", & default=.false., do_not_log=.not.TKE_to_Kd_used) - ! set params related to the background mixing - call bkgnd_mixing_init(Time, G, GV, US, param_file, CS%diag, CS%bkgnd_mixing_csp) + call get_param(param_file, mdl, "INTERNAL_TIDES", CS%use_int_tides, & + "If true, use the code that advances a separate set of "//& + "equations for the internal tide energy density.", default=.false.) + + ! set parameters related to the background mixing + call bkgnd_mixing_init(Time, G, GV, US, param_file, CS%diag, CS%bkgnd_mixing_csp, physical_OBL_scheme) call get_param(param_file, mdl, "KV", CS%Kv, & "The background kinematic viscosity in the interior. "//& "The molecular value, ~1e-6 m2 s-1, may be used.", & - units="m2 s-1", scale=US%m2_s_to_Z2_T, fail_if_missing=.true.) + units="m2 s-1", scale=GV%m2_s_to_HZ_T, fail_if_missing=.true.) - call get_param(param_file, mdl, "KD", CS%Kd, & + call get_param(param_file, mdl, "KD", Kd_z, & "The background diapycnal diffusivity of density in the "//& "interior. Zero or the molecular value, ~1e-7 m2 s-1, "//& "may be used.", default=0.0, units="m2 s-1", scale=US%m2_s_to_Z2_T) + CS%Kd = (GV%m2_s_to_HZ_T*US%Z2_T_to_m2_s) * Kd_z call get_param(param_file, mdl, "KD_MIN", CS%Kd_min, & "The minimum diapycnal diffusivity.", & - units="m2 s-1", default=0.01*CS%Kd*US%Z2_T_to_m2_s, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=0.01*Kd_z*US%Z2_T_to_m2_s, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "KD_MAX", CS%Kd_max, & "The maximum permitted increment for the diapycnal "//& "diffusivity from TKE-based parameterizations, or a negative "//& - "value for no limit.", units="m2 s-1", default=-1.0, scale=US%m2_s_to_Z2_T) + "value for no limit.", units="m2 s-1", default=-1.0, scale=GV%m2_s_to_HZ_T) if (CS%simple_TKE_to_Kd) then if (CS%Kd_max<=0.) call MOM_error(FATAL, & "set_diffusivity_init: To use SIMPLE_TKE_TO_KD, KD_MAX must be set to >0.") @@ -2168,14 +2527,14 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "KD_ADD", CS%Kd_add, & "A uniform diapycnal diffusivity that is added "//& "everywhere without any filtering or scaling.", & - units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=0.0, scale=GV%m2_s_to_HZ_T) if (CS%use_LOTW_BBL_diffusivity .and. CS%Kd_max<=0.) call MOM_error(FATAL, & "set_diffusivity_init: KD_MAX must be set (positive) when "// & "USE_LOTW_BBL_DIFFUSIVITY=True.") call get_param(param_file, mdl, "KD_SMOOTH", CS%Kd_smooth, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & - units="m2 s-1", default=1.0e-6, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=1.0e-6, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & @@ -2200,29 +2559,58 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ units="J m-3", default=0.0, scale=US%W_m2_to_RZ3_T3*US%Z_to_m*US%s_to_T) call get_param(param_file, mdl, "DISSIPATION_KD_MIN", CS%dissip_Kd_min, & "The minimum vertical diffusivity applied as a floor.", & - units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=0.0, scale=GV%m2_s_to_HZ_T) CS%limit_dissipation = (CS%dissip_min>0.) .or. (CS%dissip_N1>0.) .or. & (CS%dissip_N0>0.) .or. (CS%dissip_Kd_min>0.) CS%dissip_N2 = 0.0 if (CS%FluxRi_max > 0.0) & - CS%dissip_N2 = CS%dissip_Kd_min * GV%Rho0 / CS%FluxRi_max + CS%dissip_N2 = CS%dissip_Kd_min * GV%H_to_RZ / CS%FluxRi_max CS%id_Kd_bkgnd = register_diag_field('ocean_model', 'Kd_bkgnd', diag%axesTi, Time, & - 'Background diffusivity added by MOM_bkgnd_mixing module', 'm2/s', conversion=US%Z2_T_to_m2_s) + 'Background diffusivity added by MOM_bkgnd_mixing module', 'm2/s', conversion=GV%HZ_T_to_m2_s) CS%id_Kv_bkgnd = register_diag_field('ocean_model', 'Kv_bkgnd', diag%axesTi, Time, & - 'Background viscosity added by MOM_bkgnd_mixing module', 'm2/s', conversion=US%Z2_T_to_m2_s) + 'Background viscosity added by MOM_bkgnd_mixing module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + + if (CS%use_int_tides) then + CS%id_kbbl = register_diag_field('ocean_model', 'kbbl', diag%axesT1, Time, & + 'BBL index at h points', 'nondim') + CS%id_bbl_thick = register_diag_field('ocean_model', 'bbl_thick', diag%axesT1, Time, & + 'BBL thickness at h points', 'm', conversion=US%Z_to_m) + CS%id_Kd_leak = register_diag_field('ocean_model', 'Kd_leak', diag%axesTi, Time, & + 'internal tides leakage viscosity added by MOM_internal tides module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + CS%id_Kd_Froude = register_diag_field('ocean_model', 'Kd_Froude', diag%axesTi, Time, & + 'internal tides Froude viscosity added by MOM_internal tides module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + CS%id_Kd_itidal = register_diag_field('ocean_model', 'Kd_itidal', diag%axesTi, Time, & + 'internal tides wave drag viscosity added by MOM_internal tides module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + CS%id_Kd_quad = register_diag_field('ocean_model', 'Kd_quad', diag%axesTi, Time, & + 'internal tides bottom viscosity added by MOM_internal tides module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + CS%id_Kd_slope = register_diag_field('ocean_model', 'Kd_slope', diag%axesTi, Time, & + 'internal tides slope viscosity added by MOM_internal tides module', 'm2/s', conversion=GV%HZ_T_to_m2_s) + CS%id_prof_leak = register_diag_field('ocean_model', 'prof_leak', diag%axesTl, Time, & + 'internal tides leakage profile added by MOM_internal tides module', 'm-1', conversion=GV%m_to_H) + CS%id_prof_Froude = register_diag_field('ocean_model', 'prof_Froude', diag%axesTl, Time, & + 'internal tides Froude profile added by MOM_internal tides module', 'm-1', conversion=GV%m_to_H) + CS%id_prof_itidal = register_diag_field('ocean_model', 'prof_itidal', diag%axesTl, Time, & + 'internal tides wave drag profile added by MOM_internal tides module', 'm-1', conversion=GV%m_to_H) + CS%id_prof_quad = register_diag_field('ocean_model', 'prof_quad', diag%axesTl, Time, & + 'internal tides bottom profile added by MOM_internal tides module', 'm-1', conversion=GV%m_to_H) + CS%id_prof_slope = register_diag_field('ocean_model', 'prof_slope', diag%axesTl, Time, & + 'internal tides slope profile added by MOM_internal tides module', 'm-1', conversion=GV%m_to_H) + endif CS%id_Kd_layer = register_diag_field('ocean_model', 'Kd_layer', diag%axesTL, Time, & - 'Diapycnal diffusivity of layers (as set)', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Diapycnal diffusivity of layers (as set)', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) if (CS%use_tidal_mixing) then CS%id_Kd_Work = register_diag_field('ocean_model', 'Kd_Work', diag%axesTL, Time, & 'Work done by Diapycnal Mixing', 'W m-2', conversion=US%RZ3_T3_to_W_m2) + CS%id_Kd_Work_added = register_diag_field('ocean_model', 'Kd_Work_added', diag%axesTL, Time, & + 'Work done by additional mixing Kd_add', 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_maxTKE = register_diag_field('ocean_model', 'maxTKE', diag%axesTL, Time, & - 'Maximum layer TKE', 'm3 s-3', conversion=(US%Z_to_m**3*US%s_to_T**3)) + 'Maximum layer TKE', 'm3 s-3', conversion=(GV%H_to_m*US%Z_to_m**2*US%s_to_T**3)) CS%id_TKE_to_Kd = register_diag_field('ocean_model', 'TKE_to_Kd', diag%axesTL, Time, & - 'Convert TKE to Kd', 's2 m', conversion=US%Z2_T_to_m2_s*(US%m_to_Z**3*US%T_to_s**3)) + 'Convert TKE to Kd', 's2 m', conversion=GV%HZ_T_to_m2_s*(GV%m_to_H*US%m_to_Z**2*US%T_to_s**3)) CS%id_N2 = register_diag_field('ocean_model', 'N2', diag%axesTi, Time, & 'Buoyancy frequency squared', 's-2', conversion=US%s_to_T**2, cmor_field_name='obvfsq', & cmor_long_name='Square of seawater buoyancy frequency', & @@ -2231,23 +2619,23 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ if (CS%user_change_diff) & CS%id_Kd_user = register_diag_field('ocean_model', 'Kd_user', diag%axesTi, Time, & - 'User-specified Extra Diffusivity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'User-specified Extra Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) call get_param(param_file, mdl, "DOUBLE_DIFFUSION", CS%double_diffusion, & - "If true, increase diffusivites for temperature or salinity based on the "//& + "If true, increase diffusivities for temperature or salinity based on the "//& "double-diffusive parameterization described in Large et al. (1994).", & default=.false.) 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=US%m2_s_to_Z2_T) + default=1.e-4, units="m2 s-1", scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "KV_MOLECULAR", CS%Kv_molecular, & "Molecular viscosity for calculation of fluxes under double-diffusive "//& - "convection.", default=1.5e-6, units="m2 s-1", scale=US%m2_s_to_Z2_T) + "convection.", default=1.5e-6, units="m2 s-1", scale=GV%m2_s_to_HZ_T) ! The default molecular viscosity follows the CCSM4.0 and MOM4p1 defaults. endif ! old double-diffusion @@ -2279,15 +2667,15 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ if (CS%double_diffusion .and. CS%use_CVMix_ddiff) then call MOM_error(FATAL, 'set_diffusivity_init: '// & - 'Multiple double-diffusion options selected (DOUBLE_DIFFUSION and'//& + 'Multiple double-diffusion options selected (DOUBLE_DIFFUSION and '//& 'USE_CVMIX_DDIFF), please disable all but one option to proceed.') endif if (CS%double_diffusion .or. CS%use_CVMix_ddiff) then CS%id_KT_extra = register_diag_field('ocean_model', 'KT_extra', diag%axesTi, Time, & - 'Double-diffusive diffusivity for temperature', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Double-diffusive diffusivity for temperature', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) CS%id_KS_extra = register_diag_field('ocean_model', 'KS_extra', diag%axesTi, Time, & - 'Double-diffusive diffusivity for salinity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Double-diffusive diffusivity for salinity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) endif if (CS%use_CVMix_ddiff) then CS%id_R_rho = register_diag_field('ocean_model', 'R_rho', diag%axesTi, Time, & @@ -2301,7 +2689,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ end subroutine set_diffusivity_init -!> Clear pointers and dealocate memory +!> Clear pointers and deallocate memory subroutine set_diffusivity_end(CS) type(set_diffusivity_CS), intent(inout) :: CS !< Control structure for this module diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index f7d4b0cc0d..671d265a0e 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1,40 +1,47 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Calculates various values related to the bottom boundary layer, such as the viscosity and !! thickness of the BBL (set_viscous_BBL). module MOM_set_visc -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_debugging, only : uvchksum, hchksum -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_ALE, only : ALE_CS, ALE_remap_velocities, ALE_remap_interface_vals, ALE_remap_vertex_vals +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_cvmix_conv, only : cvmix_conv_is_used +use MOM_CVMix_ddiff, only : CVMix_ddiff_is_used +use MOM_cvmix_shear, only : cvmix_shear_is_used +use MOM_debugging, only : uvchksum, hchksum use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl, time_type -use MOM_domains, only : pass_var, CORNER +use MOM_domains, only : pass_var, CORNER +use MOM_EOS, only : calculate_density, calculate_density_derivs, calculate_specific_vol_derivs use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : forcing, mech_forcing -use MOM_grid, only : ocean_grid_type -use MOM_hor_index, only : hor_index_type -use MOM_io, only : slasher, MOM_read_data -use MOM_kappa_shear, only : kappa_shear_is_used, kappa_shear_at_vertex -use MOM_cvmix_shear, only : cvmix_shear_is_used -use MOM_cvmix_conv, only : cvmix_conv_is_used -use MOM_CVMix_ddiff, only : CVMix_ddiff_is_used -use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS -use MOM_restart, only : register_restart_field_as_obsolete -use MOM_safe_alloc, only : safe_alloc_ptr, safe_alloc_alloc -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs, vertvisc_type, porous_barrier_ptrs -use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs -use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_DIRECTION_E +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_file_parser, only : openParameterBlock, closeParameterBlock +use MOM_forcing_type, only : forcing, mech_forcing, find_ustar +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_intrinsic_functions, only : cuberoot +use MOM_io, only : slasher, MOM_read_data, vardesc, var_desc +use MOM_kappa_shear, only : kappa_shear_is_used, kappa_shear_at_vertex +use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_type, OBC_NONE, OBC_DIRECTION_E use MOM_open_boundary, only : OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S -use MOM_open_boundary, only : OBC_segment_type +use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS +use MOM_restart, only : register_restart_field_as_obsolete, register_restart_pair +use MOM_safe_alloc, only : safe_alloc_ptr, safe_alloc_alloc +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs, vertvisc_type, porous_barrier_type +use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units + implicit none ; private #include public set_viscous_BBL, set_viscous_ML, set_visc_init, set_visc_end -public set_visc_register_restarts +public set_visc_register_restarts, set_u_at_v, set_v_at_u +public remap_vertvisc_aux_vars ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -46,52 +53,75 @@ module MOM_set_visc logical :: initialized = .false. !< True if this control structure has been initialized. real :: Hbbl !< The static bottom boundary layer thickness [H ~> m or kg m-2]. !! Runtime parameter `HBBL`. - real :: cdrag !< The quadratic drag coefficient. + real :: dz_bbl !< The static bottom boundary layer thickness in height units [Z ~> m]. + !! Runtime parameter `HBBL`. + real :: cdrag !< The quadratic drag coefficient [nondim]. !! Runtime parameter `CDRAG`. real :: c_Smag !< The Laplacian Smagorinsky coefficient for - !! calculating the drag in channels. + !! calculating the drag in channels [nondim]. real :: drag_bg_vel !< An assumed unresolved background velocity for !! calculating the bottom drag [L T-1 ~> m s-1]. !! Runtime parameter `DRAG_BG_VEL`. - real :: BBL_thick_min !< The minimum bottom boundary layer thickness [H ~> m or kg m-2]. + !! Should not be used if BBL_USE_TIDAL_BG is True. + real :: BBL_thick_min !< The minimum bottom boundary layer thickness [Z ~> m]. !! This might be Kv / (cdrag * drag_bg_vel) to give !! Kv as the minimum near-bottom viscosity. real :: Htbl_shelf !< A nominal thickness of the surface boundary layer for use !! in calculating the near-surface velocity [H ~> m or kg m-2]. - real :: Htbl_shelf_min !< The minimum surface boundary layer thickness [H ~> m or kg m-2]. - real :: KV_BBL_min !< The minimum viscosity in the bottom boundary layer [Z2 T-1 ~> m2 s-1]. - real :: KV_TBL_min !< The minimum viscosity in the top boundary layer [Z2 T-1 ~> m2 s-1]. + real :: Htbl_shelf_min !< The minimum surface boundary layer thickness [Z ~> m]. + real :: KV_BBL_min !< The minimum viscosity in the bottom boundary layer [H Z T-1 ~> m2 s-1 or Pa s] + real :: KV_TBL_min !< The minimum viscosity in the top boundary layer [H Z T-1 ~> m2 s-1 or Pa s] logical :: bottomdraglaw !< If true, the bottom stress is calculated with a !! drag law c_drag*|u|*u. The velocity magnitude !! may be an assumed value or it may be based on the !! actual velocity in the bottommost `HBBL`, depending !! on whether linear_drag is true. !! Runtime parameter `BOTTOMDRAGLAW`. + logical :: bottomdragmap !< If true, apply the spatially varying drag coefficient (cdrag_2d) + !! instead of the spatially uniform drag coefficient (cdrag). + logical :: body_force_drag !< If true, the bottom stress is imposed as an explicit body force + !! applied over a fixed distance from the bottom, rather than as an + !! implicit calculation based on an enhanced near-bottom viscosity. logical :: BBL_use_EOS !< If true, use the equation of state in determining !! the properties of the bottom boundary layer. logical :: linear_drag !< If true, the drag law is cdrag*`DRAG_BG_VEL`*u. !! Runtime parameter `LINEAR_DRAG`. - logical :: Channel_drag !< If true, the drag is exerted directly on each - !! layer according to what fraction of the bottom - !! they overlie. + logical :: Channel_drag !< If true, the drag is exerted directly on each layer + !! according to what fraction of the bottom they overlie. + real :: Chan_drag_max_vol !< The maximum bottom boundary layer volume within which the + !! channel drag is applied, normalized by the full cell area, + !! or a negative value to apply no maximum [Z ~> m]. + real :: channel_break_depth !< When CHANNEL_DRAG is true, the bathymetric depth interpolated + !! to the vorticity point is a combination of the harmonic mean of the + !! adjacent velocity point depths below this depth [Z ~> m] and the + !! arithmetic mean of the adjacent depths above it, to roughly mimic a + !! continental shelf break profile. The internal version of this depth + !! uses the same offset (G%Z_ref) as the bathymetry. logical :: correct_BBL_bounds !< If true, uses the correct bounds on the BBL thickness and !! viscosity so that the bottom layer feels the intended drag. logical :: RiNo_mix !< If true, use Richardson number dependent mixing. logical :: dynamic_viscous_ML !< If true, use a bulk Richardson number criterion to !! determine the mixed layer thickness for viscosity. real :: bulk_Ri_ML !< The bulk mixed layer used to determine the - !! thickness of the viscous mixed layer. Nondim. + !! thickness of the viscous mixed layer [nondim] real :: omega !< The Earth's rotation rate [T-1 ~> s-1]. real :: ustar_min !< A minimum value of ustar to avoid numerical - !! problems [Z T-1 ~> m s-1]. If the value is small enough, - !! this should not affect the solution. + !! problems [H T-1 ~> m s-1 or kg m-2 s-1]. If the value is + !! small enough, this should not affect the solution. real :: TKE_decay !< The ratio of the natural Ekman depth to the TKE - !! decay scale, nondimensional. - real :: omega_frac !< When setting the decay scale for turbulence, use - !! this fraction of the absolute rotation rate blended - !! with the local value of f, as sqrt((1-of)*f^2 + of*4*omega^2). - logical :: answers_2018 !< If true, use the order of arithmetic and expressions that recover the - !! answers from the end of 2018. Otherwise, use updated and more robust + !! decay scale [nondim] + real :: omega_frac !< When setting the decay scale for turbulence, use this + !! fraction of the absolute rotation rate blended with the local + !! value of f, as sqrt((1-of)*f^2 + of*4*omega^2) [nondim] + real :: tideampfac2 !< A factor to multiply by tideamp to convert to a mean ustar, + !! accounts for conversion of amplitude to mean magnitude over + !! a time average much longer than the tidal periods and for + !! non-commuting conversion of mean tideamp to mean ustar**3 [nondim] + logical :: concave_trigonometric_L !< If true, use trigonometric expressions to determine the + !! fractional open interface lengths for concave topography. + integer :: answer_date !< The vintage of the order of arithmetic and expressions in the set + !! 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. logical :: debug !< If true, write verbose checksums for debugging purposes. logical :: BBL_use_tidal_bg !< If true, use a tidal background amplitude for the bottom velocity @@ -101,7 +131,9 @@ module MOM_set_visc type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. ! Allocatable data arrays - real, allocatable, dimension(:,:) :: tideamp !< RMS tidal amplitude at h points [Z T-1 ~> m s-1] + real, allocatable, dimension(:,:) :: cdrag_u !< The spatially varying quadratic drag coefficient [nondim] + real, allocatable, dimension(:,:) :: cdrag_v !< The spatially varying quadratic drag coefficient [nondim] + real, allocatable, dimension(:,:) :: tideamp !< RMS tidal amplitude at h points [L T-1 ~> m s-1] ! Diagnostic arrays real, allocatable, dimension(:,:) :: bbl_u !< BBL mean U current [L T-1 ~> m s-1] real, allocatable, dimension(:,:) :: bbl_v !< BBL mean V current [L T-1 ~> m s-1] @@ -128,27 +160,32 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any !! available thermodynamic fields. Absent fields - !! have NULL ptrs.. + !! have NULL pointers. type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical viscosities and !! related fields. type(set_visc_CS), intent(inout) :: CS !< The control structure returned by a previous !! call to set_visc_init. - type(porous_barrier_ptrs),intent(in) :: pbv !< porous barrier fractional cell metrics + type(porous_barrier_type),intent(in) :: pbv !< porous barrier fractional cell metrics ! Local variables real, dimension(SZIB_(G)) :: & - ustar, & ! The bottom friction velocity [Z T-1 ~> m s-1]. + ustar, & ! The bottom friction velocity [H T-1 ~> m s-1 or kg m-2 s-1]. T_EOS, & ! The temperature used to calculate the partial derivatives - ! of density with T and S [degC]. + ! of density with T and S [C ~> degC]. S_EOS, & ! The salinity used to calculate the partial derivatives - ! of density with T and S [ppt]. + ! of density with T and S [S ~> ppt]. dR_dT, & ! Partial derivative of the density in the bottom boundary - ! layer with temperature [R degC-1 ~> kg m-3 degC-1]. + ! layer with temperature [R C-1 ~> kg m-3 degC-1]. dR_dS, & ! Partial derivative of the density in the bottom boundary - ! layer with salinity [R ppt-1 ~> kg m-3 ppt-1]. - press ! The pressure at which dR_dT and dR_dS are evaluated [R L2 T-2 ~> Pa]. + ! layer with salinity [R S-1 ~> kg m-3 ppt-1]. + press, & ! The pressure at which dR_dT and dR_dS are evaluated [R L2 T-2 ~> Pa]. + umag_avg, & ! The average magnitude of velocities in the bottom boundary layer [L T-1 ~> m s-1]. + h_bbl_drag, & ! The thickness over which to apply drag as a body force [H ~> m or kg m-2]. + dz_bbl_drag ! The vertical height over which to apply drag as a body force [Z ~> m]. real :: htot ! Sum of the layer thicknesses up to some point [H ~> m or kg m-2]. + real :: dztot ! Distance from the bottom up to some point [Z ~> m]. real :: htot_vel ! Sum of the layer thicknesses up to some point [H ~> m or kg m-2]. + real :: dztot_vel ! Distance from the bottom up to some point [Z ~> m]. real :: Rhtot ! Running sum of thicknesses times the layer potential ! densities [H R ~> kg m-2 or kg2 m-5]. @@ -166,125 +203,141 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! direction [H ~> m or kg m-2]. h_vel, & ! Arithmetic mean of the layer thicknesses adjacent to a ! velocity point [H ~> m or kg m-2]. + dz_at_vel, & ! Vertical extent of a layer, using an upwind-biased + ! second order accurate estimate based on the previous velocity + ! direction [Z ~> m]. + dz_vel, & ! Arithmetic mean of the difference in across the layers adjacent + ! to a velocity point [Z ~> m]. T_vel, & ! Arithmetic mean of the layer temperatures adjacent to a - ! velocity point [degC]. + ! velocity point [C ~> degC]. S_vel, & ! Arithmetic mean of the layer salinities adjacent to a - ! velocity point [ppt]. + ! velocity point [S ~> ppt]. + SpV_vel, & ! Arithmetic mean of the layer averaged specific volumes adjacent to a + ! velocity point [R-1 ~> m3 kg-1]. Rml_vel ! Arithmetic mean of the layer coordinate densities adjacent ! to a velocity point [R ~> kg m-3]. + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Height change across layers [Z ~> m] real :: h_vel_pos ! The arithmetic mean thickness at a velocity point ! plus H_neglect to avoid 0 values [H ~> m or kg m-2]. real :: ustarsq ! 400 times the square of ustar, times ! Rho0 divided by G_Earth and the conversion ! from m to thickness units [H R ~> kg m-2 or kg2 m-5]. - real :: cdrag_sqrt_Z ! Square root of the drag coefficient, times a unit conversion - ! factor from lateral lengths to vertical depths [Z L-1 ~> nondim]. + real :: cdrag ! The drag coefficient [nondim]. real :: cdrag_sqrt ! Square root of the drag coefficient [nondim]. + real :: cdrag_sqrt_H ! Square root of the drag coefficient, times a unit conversion factor + ! from lateral lengths to layer thicknesses [H L-1 ~> nondim or kg m-3]. + real :: cdrag_sqrt_H_RL ! Square root of the drag coefficient, times a unit conversion factor from + ! density times lateral lengths to layer thicknesses [H L-1 R-1 ~> m3 kg-1 or nondim] + real :: cdrag_L_to_H ! The drag coefficient times conversion factors from lateral + ! distance to thickness units [H L-1 ~> nondim or kg m-3] + real :: cdrag_RL_to_H ! The drag coefficient times conversion factors from density times lateral + ! distance to thickness units [H L-1 R-1 ~> m3 kg-1 or nondim] + real :: cdrag_conv ! The drag coefficient times a combination of static conversion factors and in + ! situ density or Boussinesq reference density [H L-1 ~> nondim or kg m-3] real :: oldfn ! The integrated energy required to ! entrain up to the bottom of the layer, ! divided by G_Earth [H R ~> kg m-2 or kg2 m-5]. real :: Dfn ! The increment in oldfn for entraining ! the layer [H R ~> kg m-2 or kg2 m-5]. + real :: frac_used ! The fraction of the present layer that contributes to Dh and Ddz [nondim] real :: Dh ! The increment in layer thickness from ! the present layer [H ~> m or kg m-2]. - real :: bbl_thick ! The thickness of the bottom boundary layer [H ~> m or kg m-2]. - real :: bbl_thick_Z ! The thickness of the bottom boundary layer [Z ~> m]. - real :: kv_bbl ! The bottom boundary layer viscosity [Z2 T-1 ~> m2 s-1]. + real :: Ddz ! The increment in height change from the present layer [Z ~> m]. + real :: bbl_thick ! The thickness of the bottom boundary layer [Z ~> m]. + real :: BBL_thick_max ! A huge upper bound on the boundary layer thickness [Z ~> m]. + real :: kv_bbl ! The bottom boundary layer viscosity [H Z T-1 ~> m2 s-1 or Pa s] real :: C2f ! C2f = 2*f at velocity points [T-1 ~> s-1]. - - real :: U_bg_sq ! The square of an assumed background - ! velocity, for calculating the mean - ! magnitude near the bottom for use in the - ! quadratic bottom drag [L2 T-2 ~> m2 s-2]. + real :: u2_bg(SZIB_(G)) ! The square of an assumed background velocity, for calculating the mean + ! magnitude near the bottom for use in the quadratic bottom drag [L2 T-2 ~> m2 s-2]. real :: hwtot ! Sum of the thicknesses used to calculate ! the near-bottom velocity magnitude [H ~> m or kg m-2]. - real :: hutot ! Running sum of thicknesses times the - ! velocity magnitudes [H L T-1 ~> m2 s-1 or kg m-1 s-1]. - real :: Thtot ! Running sum of thickness times temperature [degC H ~> degC m or degC kg m-2]. - real :: Shtot ! Running sum of thickness times salinity [ppt H ~> ppt m or ppt kg m-2]. + real :: I_hwtot ! The Adcroft reciprocal of hwtot [H-1 ~> m-1 or m2 kg-1]. + real :: dzwtot ! The vertical extent of the region used to calculate + ! the near-bottom velocity magnitude [Z ~> m]. + real :: hutot ! Running sum of thicknesses times the velocity + ! magnitudes [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + real :: Thtot ! Running sum of thickness times temperature [C H ~> degC m or degC kg m-2]. + real :: Shtot ! Running sum of thickness times salinity [S H ~> ppt m or ppt kg m-2]. + real :: SpV_htot ! Running sum of thickness times specific volume [H R-1 ~> m4 kg-1 or m] real :: hweight ! The thickness of a layer that is within Hbbl ! of the bottom [H ~> m or kg m-2]. + real :: dzweight ! The counterpart of hweight in height units [Z ~> m]. real :: v_at_u, u_at_v ! v at a u point or vice versa [L T-1 ~> m s-1]. real :: Rho0x400_G ! 400*Rho0/G_Earth, times unit conversion factors - ! [R T2 H Z-2 ~> kg s2 m-4 or kg2 s2 m-7]. + ! [R T2 H-1 ~> kg s2 m-4 or s2 m-1]. ! The 400 is a constant proposed by Killworth and Edwards, 1999. real, dimension(SZI_(G),SZJ_(G),max(GV%nk_rho_varies,1)) :: & Rml ! The mixed layer coordinate density [R ~> kg m-3]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density [R L2 T-2 ~> Pa] (usually set to 2e7 Pa = 2000 dbar). - real :: D_vel ! The bottom depth at a velocity point [H ~> m or kg m-2]. - real :: Dp, Dm ! The depths at the edges of a velocity cell [H ~> m or kg m-2]. - real :: a ! a is the curvature of the bottom depth across a - ! cell, times the cell width squared [H ~> m or kg m-2]. - real :: a_3, a_12 ! a/3 and a/12 [H ~> m or kg m-2]. - real :: C24_a ! 24/a [H-1 ~> m-1 or m2 kg-1]. + real :: D_vel ! The bottom depth relative to the shelfbreak depth at a velocity point [Z ~> m]. + real :: Dp, Dm ! The bottom depths at the edges of a velocity cell relative to the + ! shelfbreak depth [Z ~> m]. + real :: D_vel_p, D_vel_m ! The bottom depths in adjacent velocity points relative to the + ! shelfbreak depth [Z ~> m]. + real :: crv ! crv is the curvature of the bottom depth across a + ! cell, times the cell width squared [Z ~> m]. real :: slope ! The absolute value of the bottom depth slope across - ! a cell times the cell width [H ~> m or kg m-2]. - real :: apb_4a, ax2_3apb ! Various nondimensional ratios of a and slope. - real :: a2x48_apb3, Iapb, Ibma_2 ! Combinations of a and slope [H-1 ~> m-1 or m2 kg-1]. - ! All of the following "volumes" have units of thickness because they are normalized - ! by the full horizontal area of a velocity cell. - real :: Vol_open ! The cell volume above which it is open [H ~> m or kg m-2]. - real :: Vol_direct ! With less than Vol_direct [H ~> m or kg m-2], there is a direct - ! solution of a cubic equation for L. - real :: Vol_2_reg ! The cell volume above which there are two separate - ! open areas that must be integrated [H ~> m or kg m-2]. - real :: vol ! The volume below the interface whose normalized - ! width is being sought [H ~> m or kg m-2]. - real :: vol_below ! The volume below the interface below the one that - ! is currently under consideration [H ~> m or kg m-2]. - real :: Vol_err ! The error in the volume with the latest estimate of - ! L, or the error for the interface below [H ~> m or kg m-2]. - real :: Vol_quit ! The volume error below which to quit iterating [H ~> m or kg m-2]. - real :: Vol_tol ! A volume error tolerance [H ~> m or kg m-2]. + ! a cell times the cell width [Z ~> m]. + real :: Vol_bbl_chan ! The volume of the bottom boundary layer as used in the channel + ! drag parameterization, normalized by the full horizontal area + ! of the velocity cell [Z ~> m]. + real :: vol_below(SZK_(GV)+1) ! The volume below each interface, normalized by the full + ! horizontal area of a velocity cell [Z ~> m]. real :: L(SZK_(GV)+1) ! The fraction of the full cell width that is open at ! the depth of each interface [nondim]. - real :: L_direct ! The value of L above volume Vol_direct [nondim]. - real :: L_max, L_min ! Upper and lower bounds on the correct value for L [nondim]. - real :: Vol_err_max ! The volume errors for the upper and lower bounds on - real :: Vol_err_min ! the correct value for L [H ~> m or kg m-2]. - real :: Vol_0 ! A deeper volume with known width L0 [H ~> m or kg m-2]. - real :: L0 ! The value of L above volume Vol_0 [nondim]. - real :: dVol ! vol - Vol_0 [H ~> m or kg m-2]. - real :: dV_dL2 ! The partial derivative of volume with L squared - ! evaluated at L=L0 [H ~> m or kg m-2]. + ! The next 9 variables are only used for debugging. + real :: L_trig(SZK_(GV)+1) ! The fraction of the full cell width that is open at + ! the depth of each interface from trigonometric expressions [nondim]. + real :: vol_err_trig(SZK_(GV)+1) ! The error in the volume below based on L_trig [Z ~> m] + real :: vol_err_iter(SZK_(GV)+1) ! The error in the volume below based on L_iter [Z ~> m] + real :: norm_err_trig(SZK_(GV)+1) ! vol_err_trig normalized by vol_below [nondim] + real :: norm_err_iter(SZK_(GV)+1) ! vol_err_iter normalized by vol_below [nondim] + real :: dL_trig_itt(SZK_(GV)+1) ! The difference between estimates of the fraction of the full cell + ! width that is open at the depth of each interface [nondim]. + real :: max_dL_trig_itt ! The largest difference between L and L_trig, for debugging [nondim] + real :: max_norm_err_trig ! The largest magnitude value of norm_err_trig in a column [nondim] + real :: max_norm_err_iter ! The largest magnitude value of norm_err_iter in a column [nondim] + real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. real :: ustH ! ustar converted to units of H T-1 [H T-1 ~> m s-1 or kg m-2 s-1]. real :: root ! A temporary variable [H T-1 ~> m s-1 or kg m-2 s-1]. real :: Cell_width ! The transverse width of the velocity cell [L ~> m]. - real :: Rayleigh ! A nondimensional value that is multiplied by the layer's - ! velocity magnitude to give the Rayleigh drag velocity, times - ! a lateral to vertical distance conversion factor [Z L-1 ~> nondim]. + real :: Rayleigh ! A factor that is multiplied by the layer's velocity magnitude + ! to give the Rayleigh drag velocity, times a lateral distance to + ! thickness conversion factor [H L-1 ~> nondim or kg m-3]. real :: gam ! The ratio of the change in the open interface width ! to the open interface width atop a cell [nondim]. real :: BBL_frac ! The fraction of a layer's drag that goes into the ! viscous bottom boundary layer [nondim]. real :: BBL_visc_frac ! The fraction of all the drag that is expressed as ! a viscous bottom boundary layer [nondim]. - real, parameter :: C1_3 = 1.0/3.0, C1_6 = 1.0/6.0, C1_12 = 1.0/12.0 - real :: C2pi_3 ! An irrational constant, 2/3 pi. - real :: tmp ! A temporary variable. - real :: tmp_val_m1_to_p1 - real :: curv_tol ! Numerator of curvature cubed, used to estimate - ! accuracy of a single L(:) Newton iteration - logical :: use_L0, do_one_L_iter ! Control flags for L(:) Newton iteration + real :: h_bbl_fr ! The fraction of the bottom boundary layer in a layer [nondim]. + real :: h_sum ! The sum of the thicknesses of the layers below the one being + ! worked on [H ~> m or kg m-2]. + real :: tideampfac2_x_0p5 ! tideampfac2 multiplied by the c-grid averaging factor of 0.5 + real, parameter :: C1_3 = 1.0/3.0, C1_6 = 1.0/6.0, C1_12 = 1.0/12.0 ! Rational constants [nondim] + real :: tmp ! A temporary variable, sometimes in [Z ~> m] logical :: use_BBL_EOS, do_i(SZIB_(G)) integer, dimension(2) :: EOSdom ! The computational domain for the equation of state integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, m, n, K2, nkmb, nkml - integer :: itt, maxitt=20 + integer :: is_OBC, ie_OBC, js_OBC, je_OBC type(ocean_OBC_type), pointer :: OBC => NULL() is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%isc-1 ; Ieq = G%IecB ; Jsq = G%jsc-1 ; Jeq = G%JecB nkmb = GV%nk_rho_varies ; nkml = GV%nkml h_neglect = GV%H_subroundoff - Rho0x400_G = 400.0*(GV%Rho0 / (US%L_to_Z**2 * GV%g_Earth)) * GV%Z_to_H - Vol_quit = 0.9*GV%Angstrom_H + h_neglect - C2pi_3 = 8.0*atan(1.0)/3.0 + dz_neglect = GV%dZ_subroundoff + + Rho0x400_G = 400.0*(GV%H_to_RZ / GV%g_Earth_Z_T2) + tideampfac2_x_0p5 = CS%tideampfac2*0.5 if (.not.CS%initialized) call MOM_error(FATAL,"MOM_set_viscosity(BBL): "//& "Module must be initialized before it is used.") @@ -292,22 +345,38 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (.not.CS%bottomdraglaw) return if (CS%debug) then - call uvchksum("Start set_viscous_BBL [uv]", u, v, G%HI, haloshift=1, scale=US%L_T_to_m_s) - call hchksum(h,"Start set_viscous_BBL h", G%HI, haloshift=1, scale=GV%H_to_m) - if (associated(tv%T)) call hchksum(tv%T, "Start set_viscous_BBL T", G%HI, haloshift=1) - if (associated(tv%S)) call hchksum(tv%S, "Start set_viscous_BBL S", G%HI, haloshift=1) + call uvchksum("Start set_viscous_BBL [uv]", u, v, G%HI, haloshift=1, unscale=US%L_T_to_m_s) + call hchksum(h,"Start set_viscous_BBL h", G%HI, haloshift=1, unscale=GV%H_to_m) + if (associated(tv%T)) call hchksum(tv%T, "Start set_viscous_BBL T", G%HI, haloshift=1, unscale=US%C_to_degC) + if (associated(tv%S)) call hchksum(tv%S, "Start set_viscous_BBL S", G%HI, haloshift=1, unscale=US%S_to_ppt) + if (allocated(tv%SpV_avg)) & + call hchksum(tv%SpV_avg, "Start set_viscous_BBL SpV_avg", G%HI, haloshift=1, unscale=US%kg_m3_to_R) + if (allocated(tv%SpV_avg)) call hchksum(tv%SpV_avg, "Cornerless SpV_avg", G%HI, & + haloshift=1, omit_corners=.true., unscale=US%kg_m3_to_R) + if (associated(tv%T)) call hchksum(tv%T, "Cornerless T", G%HI, haloshift=1, & + omit_corners=.true., unscale=US%C_to_degC) + if (associated(tv%S)) call hchksum(tv%S, "Cornerless S", G%HI, haloshift=1, & + omit_corners=.true., unscale=US%S_to_ppt) endif use_BBL_EOS = associated(tv%eqn_of_state) .and. CS%BBL_use_EOS OBC => CS%OBC - U_bg_sq = CS%drag_bg_vel * CS%drag_bg_vel - cdrag_sqrt = sqrt(CS%cdrag) - cdrag_sqrt_Z = US%L_to_Z * sqrt(CS%cdrag) + if (.not.CS%bottomdragmap) then + cdrag_sqrt = sqrt(CS%cdrag) + cdrag_sqrt_H = cdrag_sqrt * US%L_to_m * GV%m_to_H + cdrag_sqrt_H_RL = cdrag_sqrt * US%L_to_Z * GV%RZ_to_H + cdrag_L_to_H = CS%cdrag * US%L_to_m * GV%m_to_H + cdrag_RL_to_H = CS%cdrag * US%L_to_Z * GV%RZ_to_H + endif + BBL_thick_max = G%Rad_Earth_L * US%L_to_Z K2 = max(nkmb+1, 2) + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + ! With a linear drag law, the friction velocity is already known. -! if (CS%linear_drag) ustar(:) = cdrag_sqrt_Z*CS%drag_bg_vel +! if (CS%linear_drag) ustar(:) = cdrag_sqrt_H*CS%drag_bg_vel if ((nkml>0) .and. .not.use_BBL_EOS) then EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) @@ -321,32 +390,52 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) !$OMP parallel do default(shared) do J=js-1,je ; do i=is-1,ie+1 - D_v(i,J) = 0.5*(G%bathyT(i,j) + G%bathyT(i,j+1)) + G%Z_ref + D_v(i,J) = 0.5*(G%bathyT(i,j) + G%bathyT(i,j+1)) mask_v(i,J) = G%mask2dCv(i,J) enddo ; enddo !$OMP parallel do default(shared) do j=js-1,je+1 ; do I=is-1,ie - D_u(I,j) = 0.5*(G%bathyT(i,j) + G%bathyT(i+1,j)) + G%Z_ref + D_u(I,j) = 0.5*(G%bathyT(i,j) + G%bathyT(i+1,j)) mask_u(I,j) = G%mask2dCu(I,j) enddo ; enddo - if (associated(OBC)) then ; do n=1,OBC%number_of_segments - if (.not. OBC%segment(n)%on_pe) cycle + if (associated(OBC) .and. CS%Channel_drag) then ! Use a one-sided projection of bottom depths at OBC points. - I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB - if (OBC%segment(n)%is_N_or_S .and. (J >= js-1) .and. (J <= je)) then - do i = max(is-1,OBC%segment(n)%HI%isd), min(ie+1,OBC%segment(n)%HI%ied) - if (OBC%segment(n)%direction == OBC_DIRECTION_N) D_v(i,J) = G%bathyT(i,j) + G%Z_ref - if (OBC%segment(n)%direction == OBC_DIRECTION_S) D_v(i,J) = G%bathyT(i,j+1) + G%Z_ref - enddo - elseif (OBC%segment(n)%is_E_or_W .and. (I >= is-1) .and. (I <= ie)) then - do j = max(js-1,OBC%segment(n)%HI%jsd), min(je+1,OBC%segment(n)%HI%jed) - if (OBC%segment(n)%direction == OBC_DIRECTION_E) D_u(I,j) = G%bathyT(i,j) + G%Z_ref - if (OBC%segment(n)%direction == OBC_DIRECTION_W) D_u(I,j) = G%bathyT(i+1,j) + G%Z_ref - enddo + if (OBC%v_N_OBCs_on_PE) then + Js_OBC = max(js-1, OBC%Js_v_N_obc) ; Je_OBC = min(je, OBC%Je_v_N_obc) + is_OBC = max(is-1, OBC%is_v_N_obc) ; ie_OBC = min(ie+1, OBC%ie_v_N_obc) + !$OMP parallel do default(shared) + do J=Js_OBC,Je_OBC ; do i=is_OBC,ie_OBC + if (OBC%segnum_v(i,J) > 0) D_v(i,J) = G%bathyT(i,j) ! OBC_DIRECTION_N + enddo ; enddo endif - enddo ; endif - if (associated(OBC)) then ; do n=1,OBC%number_of_segments + if (OBC%v_S_OBCs_on_PE) then + Js_OBC = max(js-1, OBC%Js_v_S_obc) ; Je_OBC = min(je, OBC%Je_v_S_obc) + is_OBC = max(is-1, OBC%is_v_S_obc) ; ie_OBC = min(ie+1, OBC%ie_v_S_obc) + !$OMP parallel do default(shared) + do J=Js_OBC,Je_OBC ; do i=is_OBC,ie_OBC + if (OBC%segnum_v(i,J) < 0) D_v(i,J) = G%bathyT(i,j+1) ! OBC_DIRECTION_S + enddo ; enddo + endif + if (OBC%u_E_OBCs_on_PE) then + js_OBC = max(js-1, OBC%js_u_E_obc) ; je_OBC = min(je+1, OBC%je_u_E_obc) + Is_OBC = max(is-1, OBC%Is_u_E_obc) ; Ie_OBC = min(ie, OBC%Ie_u_E_obc) + !$OMP parallel do default(shared) + do j=js_OBC,je_OBC ; do I=Is_OBC,Ie_OBC + if (OBC%segnum_u(I,j) > 0) D_u(I,j) = G%bathyT(i,j) ! OBC_DIRECTION_E + enddo ; enddo + endif + if (OBC%u_W_OBCs_on_PE) then + js_OBC = max(js-1, OBC%js_u_W_obc) ; je_OBC = min(je+1, OBC%je_u_W_obc) + Is_OBC = max(is-1, OBC%Is_u_W_obc) ; Ie_OBC = min(ie, OBC%Ie_u_W_obc) + !$OMP parallel do default(shared) + do j=js_OBC,je_OBC ; do I=Is_OBC,Ie_OBC + if (OBC%segnum_u(I,j) < 0) D_u(I,j) = G%bathyT(i+1,j) ! OBC_DIRECTION_W + enddo ; enddo + endif + endif + + if (associated(OBC) .and. CS%Channel_drag) then ; do n=1,OBC%number_of_segments ! Now project bottom depths across cell-corner points in the OBCs. The two ! projections have to occur in sequence and can not be combined easily. if (.not. OBC%segment(n)%on_pe) cycle @@ -373,11 +462,15 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (.not.use_BBL_EOS) Rml_vel(:,:) = 0.0 - !$OMP parallel do default(private) shared(u,v,h,tv,visc,G,GV,US,CS,Rml,nz,nkmb, & - !$OMP nkml,Isq,Ieq,Jsq,Jeq,h_neglect,Rho0x400_G,C2pi_3, & - !$OMP U_bg_sq,cdrag_sqrt_Z,cdrag_sqrt,K2,use_BBL_EOS, & - !$OMP OBC,maxitt,D_u,D_v,mask_u,mask_v, pbv) & - !$OMP firstprivate(Vol_quit) + ! Resetting Ray_[uv] is required by body force drag. + if (allocated(visc%Ray_u)) visc%Ray_u(:,:,:) = 0.0 + if (allocated(visc%Ray_v)) visc%Ray_v(:,:,:) = 0.0 + + !$OMP parallel do default(private) shared(u,v,h,dz,tv,visc,G,GV,US,CS,Rml,nz,nkmb,nkml,K2, & + !$OMP Isq,Ieq,Jsq,Jeq,h_neglect,dz_neglect,Rho0x400_G, & + !$OMP cdrag_sqrt,cdrag_sqrt_H,cdrag_sqrt_H_RL, & + !$OMP cdrag_L_to_H,cdrag_RL_to_H,use_BBL_EOS,BBL_thick_max, & + !$OMP OBC,D_u,D_v,mask_u,mask_v,pbv) do j=Jsq,Jeq ; do m=1,2 if (m==1) then @@ -385,15 +478,13 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (j 0) do_i(i) = .true. + do_i(i) = (G%mask2dCu(I,j) > 0.0) enddo else ! m=2 refers to v-points is = G%isc ; ie = G%iec do i=is,ie - do_i(i) = .false. - if (G%mask2dCv(i,J) > 0) do_i(i) = .true. + do_i(i) = (G%mask2dCv(i,J) > 0.0) enddo endif @@ -402,16 +493,20 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (m==1) then ! u-points do k=1,nz ; do I=is,ie if (do_i(I)) then - if (u(I,j,k) *(h(i+1,j,k) - h(i,j,k)) >= 0) then + if (u(I,j,k) * (h(i+1,j,k) - h(i,j,k)) >= 0) then ! If the flow is from thin to thick then bias towards the thinner thickness h_at_vel(I,k) = 2.0*h(i,j,k)*h(i+1,j,k) / & (h(i,j,k) + h(i+1,j,k) + h_neglect) + dz_at_vel(I,k) = 2.0*dz(i,j,k)*dz(i+1,j,k) / & + (dz(i,j,k) + dz(i+1,j,k) + dz_neglect) else ! If the flow is from thick to thin then use the simple average thickness h_at_vel(I,k) = 0.5 * (h(i,j,k) + h(i+1,j,k)) + dz_at_vel(I,k) = 0.5 * (dz(i,j,k) + dz(i+1,j,k)) endif endif h_vel(I,k) = 0.5 * (h(i,j,k) + h(i+1,j,k)) + dz_vel(I,k) = 0.5 * (dz(i,j,k) + dz(i+1,j,k)) enddo ; enddo if (use_BBL_EOS) then ; do k=1,nz ; do I=is,ie ! Perhaps these should be thickness weighted. @@ -420,6 +515,9 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) enddo ; enddo ; else ; do k=1,nkmb ; do I=is,ie Rml_vel(I,k) = 0.5 * (Rml(i,j,k) + Rml(i+1,j,k)) enddo ; enddo ; endif + if (allocated(tv%SpV_avg)) then ; do k=1,nz ; do I=is,ie + SpV_vel(I,k) = 0.5 * (tv%SpV_avg(i,j,k) + tv%SpV_avg(i+1,j,k)) + enddo ; enddo ; endif else ! v-points do k=1,nz ; do i=is,ie if (do_i(i)) then @@ -427,28 +525,37 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! If the flow is from thin to thick then bias towards the thinner thickness h_at_vel(i,k) = 2.0*h(i,j,k)*h(i,j+1,k) / & (h(i,j,k) + h(i,j+1,k) + h_neglect) + dz_at_vel(i,k) = 2.0*dz(i,j,k)*dz(i,j+1,k) / & + (dz(i,j,k) + dz(i,j+1,k) + dz_neglect) else ! If the flow is from thick to thin then use the simple average thickness h_at_vel(i,k) = 0.5 * (h(i,j,k) + h(i,j+1,k)) + dz_at_vel(i,k) = 0.5 * (dz(i,j,k) + dz(i,j+1,k)) endif endif h_vel(i,k) = 0.5 * (h(i,j,k) + h(i,j+1,k)) + dz_vel(i,k) = 0.5 * (dz(i,j,k) + dz(i,j+1,k)) enddo ; enddo if (use_BBL_EOS) then ; do k=1,nz ; do i=is,ie + ! Perhaps these should be thickness weighted. T_vel(i,k) = 0.5 * (tv%T(i,j,k) + tv%T(i,j+1,k)) S_vel(i,k) = 0.5 * (tv%S(i,j,k) + tv%S(i,j+1,k)) enddo ; enddo ; else ; do k=1,nkmb ; do i=is,ie Rml_vel(i,k) = 0.5 * (Rml(i,j,k) + Rml(i,j+1,k)) enddo ; enddo ; endif + if (allocated(tv%SpV_avg)) then ; do k=1,nz ; do i=is,ie + SpV_vel(i,k) = 0.5 * (tv%SpV_avg(i,j,k) + tv%SpV_avg(i,j+1,k)) + enddo ; enddo ; endif endif if (associated(OBC)) then ; if (OBC%number_of_segments > 0) then ! Apply a zero gradient projection of thickness across OBC points. if (m==1) then - do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= 0)) then + if (OBC%segnum_u(I,j) > 0) then ! OBC_DIRECTION_E do k=1,nz h_at_vel(I,k) = h(i,j,k) ; h_vel(I,k) = h(i,j,k) + dz_at_vel(I,k) = dz(i,j,k) ; dz_vel(I,k) = dz(i,j,k) enddo if (use_BBL_EOS) then do k=1,nz @@ -459,9 +566,13 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) Rml_vel(I,k) = Rml(i,j,k) enddo endif - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + if (allocated(tv%SpV_avg)) then ; do k=1,nz + SpV_vel(I,k) = tv%SpV_avg(i,j,k) + enddo ; endif + elseif (OBC%segnum_u(I,j) < 0) then ! OBC_DIRECTION_W do k=1,nz h_at_vel(I,k) = h(i+1,j,k) ; h_vel(I,k) = h(i+1,j,k) + dz_at_vel(I,k) = dz(i+1,j,k) ; dz_vel(I,k) = dz(i+1,j,k) enddo if (use_BBL_EOS) then do k=1,nz @@ -472,13 +583,17 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) Rml_vel(I,k) = Rml(i+1,j,k) enddo endif + if (allocated(tv%SpV_avg)) then ; do k=1,nz + SpV_vel(I,k) = tv%SpV_avg(i+1,j,k) + enddo ; endif endif endif ; enddo else - do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= 0)) then + if (OBC%segnum_v(i,J) > 0) then ! OBC_DIRECTION_N do k=1,nz h_at_vel(i,k) = h(i,j,k) ; h_vel(i,k) = h(i,j,k) + dz_at_vel(i,k) = dz(i,j,k) ; dz_vel(i,k) = dz(i,j,k) enddo if (use_BBL_EOS) then do k=1,nz @@ -489,9 +604,13 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) Rml_vel(i,k) = Rml(i,j,k) enddo endif - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + if (allocated(tv%SpV_avg)) then ; do k=1,nz + SpV_vel(i,k) = tv%SpV_avg(i,j,k) + enddo ; endif + elseif (OBC%segnum_v(i,J) < 0) then ! OBC_DIRECTION_S do k=1,nz h_at_vel(i,k) = h(i,j+1,k) ; h_vel(i,k) = h(i,j+1,k) + dz_at_vel(i,k) = dz(i,j+1,k) ; dz_vel(i,k) = dz(i,j+1,k) enddo if (use_BBL_EOS) then do k=1,nz @@ -502,59 +621,96 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) Rml_vel(i,k) = Rml(i,j+1,k) enddo endif + if (allocated(tv%SpV_avg)) then ; do k=1,nz + SpV_vel(i,k) = tv%SpV_avg(i,j+1,k) + enddo ; endif endif endif ; enddo endif endif ; endif - if (use_BBL_EOS .or. .not.CS%linear_drag) then + ! Set the "back ground" friction velocity scale to either the tidal amplitude or place-holder constant + if (CS%BBL_use_tidal_bg) then + do i=is,ie ; if (do_i(i)) then ; if (m==1) then + u2_bg(I) = tideampfac2_x_0p5 * ( G%mask2dT(i,j)*(CS%tideamp(i,j)*CS%tideamp(i,j))+ & + G%mask2dT(i+1,j)*(CS%tideamp(i+1,j)*CS%tideamp(i+1,j)) ) + else + u2_bg(i) = tideampfac2_x_0p5 * ( G%mask2dT(i,j)*(CS%tideamp(i,j)*CS%tideamp(i,j))+ & + G%mask2dT(i,j+1)*(CS%tideamp(i,j+1)*CS%tideamp(i,j+1)) ) + endif ; endif ; enddo + else + do i=is,ie ; if (do_i(i)) then + u2_bg(i) = CS%drag_bg_vel * CS%drag_bg_vel + endif ; enddo + endif + + if (use_BBL_EOS .or. CS%body_force_drag .or. .not.CS%linear_drag) then ! Calculate the mean velocity magnitude over the bottommost CS%Hbbl of ! the water column for determining the quadratic bottom drag. ! Used in ustar(i) do i=is,ie ; if (do_i(i)) then htot_vel = 0.0 ; hwtot = 0.0 ; hutot = 0.0 - Thtot = 0.0 ; Shtot = 0.0 + dztot_vel = 0.0 ; dzwtot = 0.0 + Thtot = 0.0 ; Shtot = 0.0 ; SpV_htot = 0.0 + + if (CS%bottomdragmap) then + if (m==1) then + cdrag_sqrt = sqrt(CS%cdrag_u(i,j)) + else + cdrag_sqrt = sqrt(CS%cdrag_v(i,j)) + endif + cdrag_sqrt_H = cdrag_sqrt * US%L_to_m * GV%m_to_H + cdrag_sqrt_H_RL = cdrag_sqrt * US%L_to_Z * GV%RZ_to_H + endif + do k=nz,1,-1 if (htot_vel>=CS%Hbbl) exit ! terminate the k loop hweight = MIN(CS%Hbbl - htot_vel, h_at_vel(i,k)) if (hweight < 1.5*GV%Angstrom_H + h_neglect) cycle + dzweight = MIN(CS%dz_bbl - dztot_vel, dz_at_vel(i,k)) - htot_vel = htot_vel + h_at_vel(i,k) + htot_vel = htot_vel + h_at_vel(i,k) hwtot = hwtot + hweight + dztot_vel = dztot_vel + dz_at_vel(i,k) + dzwtot = dzwtot + dzweight if ((.not.CS%linear_drag) .and. (hweight >= 0.0)) then ; if (m==1) then v_at_u = set_v_at_u(v, h, G, GV, i, j, k, mask_v, OBC) - if (CS%BBL_use_tidal_bg) then - U_bg_sq = 0.5*( G%mask2dT(i,j)*(CS%tideamp(i,j)*CS%tideamp(i,j))+ & - G%mask2dT(i+1,j)*(CS%tideamp(i+1,j)*CS%tideamp(i+1,j)) ) - endif - hutot = hutot + hweight * sqrt(u(I,j,k)*u(I,j,k) + & - v_at_u*v_at_u + U_bg_sq) + hutot = hutot + hweight * sqrt(u(I,j,k)*u(I,j,k) + v_at_u*v_at_u + u2_bg(I)) else u_at_v = set_u_at_v(u, h, G, GV, i, j, k, mask_u, OBC) - if (CS%BBL_use_tidal_bg) then - U_bg_sq = 0.5*( G%mask2dT(i,j)*(CS%tideamp(i,j)*CS%tideamp(i,j))+ & - G%mask2dT(i,j+1)*(CS%tideamp(i,j+1)*CS%tideamp(i,j+1)) ) - endif - hutot = hutot + hweight * sqrt(v(i,J,k)*v(i,J,k) + & - u_at_v*u_at_v + U_bg_sq) + hutot = hutot + hweight * sqrt(v(i,J,k)*v(i,J,k) + u_at_v*u_at_v + u2_bg(i)) endif ; endif if (use_BBL_EOS .and. (hweight >= 0.0)) then Thtot = Thtot + hweight * T_vel(i,k) Shtot = Shtot + hweight * S_vel(i,k) endif + if (allocated(tv%SpV_avg) .and. (hweight >= 0.0)) then + SpV_htot = SpV_htot + hweight * SpV_vel(i,k) + endif enddo ! end of k loop + ! Find the Adcroft reciprocal of the total thickness weights + I_hwtot = 0.0 ; if (hwtot > 0.0) I_hwtot = 1.0 / hwtot + ! Set u* based on u*^2 = Cdrag u_bbl^2 - if (.not.CS%linear_drag .and. (hwtot > 0.0)) then - ustar(i) = cdrag_sqrt_Z*hutot/hwtot - else - ustar(i) = cdrag_sqrt_Z*CS%drag_bg_vel + if ((hwtot <= 0.0) .or. (CS%linear_drag .and. .not.allocated(tv%SpV_avg))) then + ustar(i) = cdrag_sqrt_H * CS%drag_bg_vel + elseif (CS%linear_drag .and. allocated(tv%SpV_avg)) then + ustar(i) = cdrag_sqrt_H_RL * CS%drag_bg_vel * (hwtot / SpV_htot) + elseif (allocated(tv%SpV_avg)) then ! (.not.CS%linear_drag) + ustar(i) = cdrag_sqrt_H_RL * hutot / SpV_htot + else ! (.not.CS%linear_drag .and. .not.allocated(tv%SpV_avg)) + ustar(i) = cdrag_sqrt_H * hutot / hwtot endif + umag_avg(i) = hutot * I_hwtot + h_bbl_drag(i) = hwtot + dz_bbl_drag(i) = dzwtot + if (use_BBL_EOS) then ; if (hwtot > 0.0) then T_EOS(i) = Thtot/hwtot ; S_EOS(i) = Shtot/hwtot else @@ -570,7 +726,17 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) endif ; enddo else - do i=is,ie ; ustar(i) = cdrag_sqrt_Z*CS%drag_bg_vel ; enddo + do i=is,ie + if (CS%bottomdragmap) then + if (m==1) then + cdrag_sqrt = sqrt(CS%cdrag_u(i,j)) + else + cdrag_sqrt = sqrt(CS%cdrag_v(i,j)) + endif + cdrag_sqrt_H = cdrag_sqrt * US%L_to_m * GV%m_to_H + endif + ustar(i) = cdrag_sqrt_H * CS%drag_bg_vel + enddo endif ! Not linear_drag if (use_BBL_EOS) then @@ -599,6 +765,17 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! The 400.0 in this expression is the square of a Ci introduced in KW99, eq. 2.22. ustarsq = Rho0x400_G * ustar(i)**2 ! Note not in units of u*^2 but [H R ~> kg m-2 or kg2 m-5] htot = 0.0 + dztot = 0.0 + + if (CS%bottomdragmap) then + if (m==1) then + cdrag = CS%cdrag_u(i,j) + else + cdrag = CS%cdrag_v(i,j) + endif + cdrag_L_to_H = cdrag * US%L_to_m * GV%m_to_H + cdrag_RL_to_H = cdrag * US%L_to_Z * GV%RZ_to_H + endif ! Calculate the thickness of a stratification limited BBL ignoring rotation: ! h_N = Ci u* / N (limit of KW99 eq. 2.20 for |f|->0) @@ -627,20 +804,26 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if ((oldfn + Dfn) <= ustarsq) then ! Use whole layer Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) else ! Use only part of the layer - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used endif ! Increment total BBL thickness and cumulative T and S htot = htot + Dh + dztot = dztot + Ddz Thtot = Thtot + T_vel(i,k)*Dh ; Shtot = Shtot + S_vel(i,k)*Dh enddo if ((oldfn < ustarsq) .and. h_at_vel(i,1) > 0.0) then ! Layer 1 might be part of the BBL. if (dR_dT(i) * (Thtot - T_vel(i,1)*htot) + & - dR_dS(i) * (Shtot - S_vel(i,1)*htot) < ustarsq) & + dR_dS(i) * (Shtot - S_vel(i,1)*htot) < ustarsq) then htot = htot + h_at_vel(i,1) + dztot = dztot + dz_at_vel(i,1) + endif endif ! Examination of layer 1. else ! Use Rlay and/or the coordinate density as density variables. Rhtot = 0.0 @@ -652,11 +835,15 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) cycle elseif ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) else - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used endif htot = htot + Dh + dztot = dztot + Ddz Rhtot = Rhtot + GV%Rlay(k)*Dh enddo if (nkml>0) then @@ -668,16 +855,26 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) cycle elseif ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) else - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used endif htot = htot + Dh + dztot = dztot + Ddz Rhtot = Rhtot + Rml_vel(i,k)*Dh enddo - if (Rhtot - Rml_vel(i,1)*htot < ustarsq) htot = htot + h_at_vel(i,1) + if (Rhtot - Rml_vel(i,1)*htot < ustarsq) then + htot = htot + h_at_vel(i,1) + dztot = dztot + dz_at_vel(i,1) + endif else - if (Rhtot - GV%Rlay(1)*htot < ustarsq) htot = htot + h_at_vel(i,1) + if (Rhtot - GV%Rlay(1)*htot < ustarsq) then + htot = htot + h_at_vel(i,1) + dztot = dztot + dz_at_vel(i,1) + endif endif endif ! use_BBL_EOS @@ -696,236 +893,157 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! xp = 1/2 + sqrt( 1/4 + (2 f h_N/u*)^2 ) ! To avoid dividing by zero if u*=0 then ! xp u* = 1/2 u* + sqrt( 1/4 u*^2 + (2 f h_N)^2 ) - if (CS%cdrag * U_bg_sq <= 0.0) then + if (CS%cdrag * u2_bg(i) <= 0.0) then ! This avoids NaNs and overflows, and could be used in all cases, ! but is not bitwise identical to the current code. - ustH = ustar(i)*GV%Z_to_H ; root = sqrt(0.25*ustH**2 + (htot*C2f)**2) - if (htot*ustH <= (CS%BBL_thick_min+h_neglect) * (0.5*ustH + root)) then + ustH = ustar(i) ; root = sqrt(0.25*ustH**2 + (htot*C2f)**2) + if (dztot*ustH <= (CS%BBL_thick_min+dz_neglect) * (0.5*ustH + root)) then bbl_thick = CS%BBL_thick_min else ! The following expression reads ! h_bbl = h_N u* / ( 1/2 u* + sqrt( 1/4 u*^2 + ( 2 f h_N )^2 ) ) ! which is h_bbl = h_N u*/(xp u*) as described above. - bbl_thick = (htot * ustH) / (0.5*ustH + root) + bbl_thick = (dztot * ustH) / (0.5*ustH + root) endif else ! The following expression reads ! h_bbl = h_N / ( 1/2 + sqrt( 1/4 + ( 2 f h_N / u* )^2 ) ) ! which is h_bbl = h_N/xp as described above. - bbl_thick = htot / (0.5 + sqrt(0.25 + htot*htot*C2f*C2f/ & - ((ustar(i)*ustar(i)) * (GV%Z_to_H**2)) ) ) + bbl_thick = dztot / (0.5 + sqrt(0.25 + htot*htot*C2f*C2f / (ustar(i)*ustar(i)) ) ) if (bbl_thick < CS%BBL_thick_min) bbl_thick = CS%BBL_thick_min endif + ! Store the normalized bottom boundary layer volume. + if (CS%Channel_drag) Vol_bbl_chan = bbl_thick + ! If there is Richardson number dependent mixing, that determines ! the vertical extent of the bottom boundary layer, and there is no ! need to set that scale here. In fact, viscously reducing the ! shears over an excessively large region reduces the efficacy of ! the Richardson number dependent mixing. - ! In other words, if using RiNo_mix then CS%Hbbl acts as an upper bound on + ! In other words, if using RiNo_mix then CS%dz_bbl acts as an upper bound on ! bbl_thick. - if ((bbl_thick > 0.5*CS%Hbbl) .and. (CS%RiNo_mix)) bbl_thick = 0.5*CS%Hbbl + if ((bbl_thick > 0.5*CS%dz_bbl) .and. (CS%RiNo_mix)) bbl_thick = 0.5*CS%dz_bbl + + ! If drag is a body force, bbl_thick is HBBL + if (CS%body_force_drag) bbl_thick = dz_bbl_drag(i) if (CS%Channel_drag) then - ! The drag within the bottommost bbl_thick is applied as a part of - ! an enhanced bottom viscosity, while above this the drag is applied - ! directly to the layers in question as a Rayleigh drag term. - !### The harmonic mean edge depths here are not invariant to offsets! + vol_below(nz+1) = 0.0 + do K=nz,1,-1 + vol_below(K) = vol_below(K+1) + dz_vel(i,k) + enddo + + ! Find the bathymetry at adjacent points relative to the shelf break. For now this + ! shelf break depth is set with a global constant, but it could vary in space. if (m==1) then - D_vel = D_u(I,j) - tmp = G%mask2dCu(I,j+1) * D_u(I,j+1) - Dp = 2.0 * D_vel * tmp / (D_vel + tmp) - tmp = G%mask2dCu(I,j-1) * D_u(I,j-1) - Dm = 2.0 * D_vel * tmp / (D_vel + tmp) + D_vel = D_u(I,j) - CS%channel_break_depth + D_vel_p = G%mask2dCu(I,j+1) * (D_u(I,j+1) - CS%channel_break_depth) + D_vel_m = G%mask2dCu(I,j-1) * (D_u(I,j-1) - CS%channel_break_depth) else - D_vel = D_v(i,J) - tmp = G%mask2dCv(i+1,J) * D_v(i+1,J) - Dp = 2.0 * D_vel * tmp / (D_vel + tmp) - tmp = G%mask2dCv(i-1,J) * D_v(i-1,J) - Dm = 2.0 * D_vel * tmp / (D_vel + tmp) + D_vel = D_v(i,J) - CS%channel_break_depth + D_vel_p = G%mask2dCv(i+1,J) * (D_v(i+1,J) - CS%channel_break_depth) + D_vel_m = G%mask2dCv(i-1,J) * (D_v(i-1,J) - CS%channel_break_depth) + endif + ! This profile uses a harmonic mean bottom depth below some reference value to + ! roughly mimic the topographic shape at and beneath a continental shelf break. + ! Above this a simple arithmetic mean is used. + if ((D_vel > 0.0) .and. (D_vel_p > 0.0)) then + Dp = 2.0 * D_vel * D_vel_p / (D_vel + D_vel_p) + else ! This is above the shelf-break, noting that D is positive downward. + Dp = 0.5 * (min(D_vel, 0.0) + min(D_vel_p, 0.0)) + endif + if ((D_vel > 0.0) .and. (D_vel_m > 0.0)) then + Dm = 2.0 * D_vel * D_vel_m / (D_vel + D_vel_m) + else ! This is above the shelf-break, noting that D is positive downward. + Dm = 0.5 * (min(D_vel, 0.0) + min(D_vel_m, 0.0)) endif if (Dm > Dp) then ; tmp = Dp ; Dp = Dm ; Dm = tmp ; endif - - ! Convert the D's to the units of thickness. - Dp = GV%Z_to_H*Dp ; Dm = GV%Z_to_H*Dm ; D_vel = GV%Z_to_H*D_vel - - a_3 = (Dp + Dm - 2.0*D_vel) ; a = 3.0*a_3 ; a_12 = 0.25*a_3 + crv = 3.0*(Dp + Dm - 2.0*D_vel) slope = Dp - Dm + ! If the curvature is small enough, there is no reason not to assume ! a uniformly sloping or flat bottom. - if (abs(a) < 1e-2*(slope + CS%BBL_thick_min)) a = 0.0 - ! Each cell extends from x=-1/2 to 1/2, and has a topography - ! given by D(x) = a*x^2 + b*x + D - a/12. - - ! Calculate the volume above which the entire cell is open and the - ! other volumes at which the equation that is solved for L changes. - if (a > 0.0) then - if (slope >= a) then - Vol_open = D_vel - Dm ; Vol_2_reg = Vol_open + if (abs(crv) < 1e-2*(slope + CS%BBL_thick_min)) crv = 0.0 + + ! Determine the normalized open length (L) at each interface. + if (crv == 0.0) then + call find_L_open_uniform_slope(vol_below, Dp, Dm, L, GV) + elseif (crv > 0.0) then + if (CS%concave_trigonometric_L) then + call find_L_open_concave_trigonometric(vol_below, D_vel, Dp, Dm, L, GV) else - tmp = slope/a - Vol_open = 0.25*slope*tmp + C1_12*a - Vol_2_reg = 0.5*tmp**2 * (a - C1_3*slope) - endif - ! Define some combinations of a & b for later use. - C24_a = 24.0/a ; Iapb = 1.0/(a+slope) - apb_4a = (slope+a)/(4.0*a) ; a2x48_apb3 = (48.0*(a*a))*(Iapb**3) - ax2_3apb = 2.0*C1_3*a*Iapb - elseif (a == 0.0) then - Vol_open = 0.5*slope - if (slope > 0) Iapb = 1.0/slope - else ! a < 0.0 - Vol_open = D_vel - Dm - if (slope >= -a) then - Iapb = 1.0e30 ; if (slope+a /= 0.0) Iapb = 1.0/(a+slope) - Vol_direct = 0.0 ; L_direct = 0.0 ; C24_a = 0.0 - else - C24_a = 24.0/a ; Iapb = 1.0/(a+slope) - L_direct = 1.0 + slope/a ! L_direct < 1 because a < 0 - Vol_direct = -C1_6*a*L_direct**3 - endif - Ibma_2 = 2.0 / (slope - a) - endif - - L(nz+1) = 0.0 ; vol = 0.0 ; Vol_err = 0.0 ; BBL_visc_frac = 0.0 - ! Determine the normalized open length at each interface. - do K=nz,1,-1 - vol_below = vol - - vol = vol + h_vel(i,k) - h_vel_pos = h_vel(i,k) + h_neglect - - if (vol >= Vol_open) then ; L(K) = 1.0 - elseif (a == 0) then ! The bottom has no curvature. - L(K) = sqrt(2.0*vol*Iapb) - elseif (a > 0) then - ! There may be a minimum depth, and there are - ! analytic expressions for L for all cases. - if (vol < Vol_2_reg) then - ! In this case, there is a contiguous open region and - ! vol = 0.5*L^2*(slope + a/3*(3-4L)). - if (a2x48_apb3*vol < 1e-8) then ! Could be 1e-7? - ! There is a very good approximation here for massless layers. - L0 = sqrt(2.0*vol*Iapb) ; L(K) = L0*(1.0 + ax2_3apb*L0) - else - L(K) = apb_4a * (1.0 - & - 2.0 * cos(C1_3*acos(a2x48_apb3*vol - 1.0) - C2pi_3)) - endif - ! To check the answers. - ! Vol_err = 0.5*(L(K)*L(K))*(slope + a_3*(3.0-4.0*L(K))) - vol - else ! There are two separate open regions. - ! vol = slope^2/4a + a/12 - (a/12)*(1-L)^2*(1+2L) - ! At the deepest volume, L = slope/a, at the top L = 1. - !L(K) = 0.5 - cos(C1_3*acos(1.0 - C24_a*(Vol_open - vol)) - C2pi_3) - tmp_val_m1_to_p1 = 1.0 - C24_a*(Vol_open - vol) - tmp_val_m1_to_p1 = max(-1., min(1., tmp_val_m1_to_p1)) - L(K) = 0.5 - cos(C1_3*acos(tmp_val_m1_to_p1) - C2pi_3) - ! To check the answers. - ! Vol_err = Vol_open - a_12*(1.0+2.0*L(K)) * (1.0-L(K))**2 - vol + call find_L_open_concave_iterative(vol_below, D_vel, Dp, Dm, L, GV) + if (CS%debug) then + ! The tests in this block reveal that the iterative and trigonometric solutions are + ! mathematically equivalent, but in some cases the iterative solution is consistent + ! at roundoff, but that the trigonmetric solutions have errors that can be several + ! orders of magnitude larger in some cases. + call find_L_open_concave_trigonometric(vol_below, D_vel, Dp, Dm, L_trig, GV) + call test_L_open_concave(vol_below, D_vel, Dp, Dm, L_trig, vol_err_trig, GV) + call test_L_open_concave(vol_below, D_vel, Dp, Dm, L, vol_err_iter, GV) + max_dL_trig_itt = 0.0 ; max_norm_err_trig = 0.0 ; max_norm_err_iter = 0.0 + norm_err_trig(:) = 0.0 ; norm_err_iter(:) = 0.0 + do K=1,nz+1 + dL_trig_itt(K) = L_trig(K) - L(K) + if (abs(dL_trig_itt(K)) > abs(max_dL_trig_itt)) max_dL_trig_itt = dL_trig_itt(K) + norm_err_trig(K) = vol_err_trig(K) / (vol_below(K) + dz_neglect) + norm_err_iter(K) = vol_err_iter(K) / (vol_below(K) + dz_neglect) + if (abs(norm_err_trig(K)) > abs(max_norm_err_trig)) max_norm_err_trig = norm_err_trig(K) + if (abs(norm_err_iter(K)) > abs(max_norm_err_iter)) max_norm_err_iter = norm_err_iter(K) + enddo + if (abs(max_dL_trig_itt) > 1.0e-13) & + K = nz+1 ! This is here only to use as a break point for a debugger. + if (abs(max_norm_err_trig) > 1.0e-13) & + K = nz+1 ! This is here only to use as a break point for a debugger. + if (abs(max_norm_err_iter) > 1.0e-13) & + K = nz+1 ! This is here only to use as a break point for a debugger. endif - else ! a < 0. - if (vol <= Vol_direct) then - ! Both edges of the cell are bounded by walls. - L(K) = (-0.25*C24_a*vol)**C1_3 - else - ! x_R is at 1/2 but x_L is in the interior & L is found by solving - ! vol = 0.5*L^2*(slope + a/3*(3-4L)) - - ! Vol_err = 0.5*(L(K+1)*L(K+1))*(slope + a_3*(3.0-4.0*L(K+1))) - vol_below - ! Change to ... - ! if (min(Vol_below + Vol_err, vol) <= Vol_direct) then ? - if (vol_below + Vol_err <= Vol_direct) then - L0 = L_direct ; Vol_0 = Vol_direct - else - L0 = L(K+1) ; Vol_0 = Vol_below + Vol_err - ! Change to Vol_0 = min(Vol_below + Vol_err, vol) ? - endif - - ! Try a relatively simple solution that usually works well - ! for massless layers. - dV_dL2 = 0.5*(slope+a) - a*L0 ; dVol = (vol-Vol_0) - ! dV_dL2 = 0.5*(slope+a) - a*L0 ; dVol = max(vol-Vol_0, 0.0) - - use_L0 = .false. - do_one_L_iter = .false. - if (CS%answers_2018) then - curv_tol = GV%Angstrom_H*dV_dL2**2 & - * (0.25 * dV_dL2 * GV%Angstrom_H - a * L0 * dVol) - do_one_L_iter = (a * a * dVol**3) < curv_tol - else - ! The following code is more robust when GV%Angstrom_H=0, but - ! it changes answers. - use_L0 = (dVol <= 0.) - - Vol_tol = max(0.5 * GV%Angstrom_H + GV%H_subroundoff, 1e-14 * vol) - Vol_quit = max(0.9 * GV%Angstrom_H + GV%H_subroundoff, 1e-14 * vol) + endif + else ! crv < 0.0 + call find_L_open_convex(vol_below, D_vel, Dp, Dm, L, GV, US, CS) + endif ! end of crv<0 cases. - curv_tol = Vol_tol * dV_dL2**2 & - * (dV_dL2 * Vol_tol - 2.0 * a * L0 * dVol) - do_one_L_iter = (a * a * dVol**3) < curv_tol - endif + ! Determine the Rayleigh drag contributions. - if (use_L0) then - L(K) = L0 - Vol_err = 0.5*(L(K)*L(K))*(slope + a_3*(3.0-4.0*L(K))) - vol - elseif (do_one_L_iter) then - ! One iteration of Newton's method should give an estimate - ! that is accurate to within Vol_tol. - L(K) = sqrt(L0*L0 + dVol / dV_dL2) - Vol_err = 0.5*(L(K)*L(K))*(slope + a_3*(3.0-4.0*L(K))) - vol - else - if (dV_dL2*(1.0-L0*L0) < dVol + & - dV_dL2 * (Vol_open - Vol)*Ibma_2) then - L_max = sqrt(1.0 - (Vol_open - Vol)*Ibma_2) - else - L_max = sqrt(L0*L0 + dVol / dV_dL2) - endif - L_min = sqrt(L0*L0 + dVol / (0.5*(slope+a) - a*L_max)) + ! The drag within the bottommost Vol_bbl_chan is applied as a part of an enhanced bottom + ! viscosity, while above this the drag is applied directly to the layers in question as a + ! Rayleigh drag term. - Vol_err_min = 0.5*(L_min**2)*(slope + a_3*(3.0-4.0*L_min)) - vol - Vol_err_max = 0.5*(L_max**2)*(slope + a_3*(3.0-4.0*L_max)) - vol - ! if ((abs(Vol_err_min) <= Vol_quit) .or. (Vol_err_min >= Vol_err_max)) then - if (abs(Vol_err_min) <= Vol_quit) then - L(K) = L_min ; Vol_err = Vol_err_min - else - L(K) = sqrt((L_min**2*Vol_err_max - L_max**2*Vol_err_min) / & - (Vol_err_max - Vol_err_min)) - do itt=1,maxitt - Vol_err = 0.5*(L(K)*L(K))*(slope + a_3*(3.0-4.0*L(K))) - vol - if (abs(Vol_err) <= Vol_quit) exit - ! Take a Newton's method iteration. This equation has proven - ! robust enough not to need bracketing. - L(K) = L(K) - Vol_err / (L(K)* (slope + a - 2.0*a*L(K))) - ! This would be a Newton's method iteration for L^2: - ! L(K) = sqrt(L(K)*L(K) - Vol_err / (0.5*(slope+a) - a*L(K))) - enddo - endif ! end of iterative solver - endif ! end of 1-boundary alternatives. - endif ! end of a<0 cases. - endif + ! Restrict the volume over which the channel drag is applied from the previously determined value. + if (CS%Chan_drag_max_vol >= 0.0) Vol_bbl_chan = min(Vol_bbl_chan, CS%Chan_drag_max_vol) + BBL_visc_frac = 0.0 + do K=nz,1,-1 !modify L(K) for porous barrier parameterization if (m==1) then ; L(K) = L(K)*pbv%por_layer_widthU(I,j,K) - else ; L(K) = L(K)*pbv%por_layer_widthV(i,J,K); endif + else ; L(K) = L(K)*pbv%por_layer_widthV(i,J,K) ; endif ! Determine the drag contributing to the bottom boundary layer - ! and the Raleigh drag that acts on each layer. + ! and the Rayleigh drag that acts on each layer. if (L(K) > L(K+1)) then - if (vol_below < bbl_thick) then - BBL_frac = (1.0-vol_below/bbl_thick)**2 + if (vol_below(K+1) < Vol_bbl_chan) then + BBL_frac = (1.0-vol_below(K+1)/Vol_bbl_chan)**2 BBL_visc_frac = BBL_visc_frac + BBL_frac*(L(K) - L(K+1)) else BBL_frac = 0.0 endif + if (allocated(tv%SpV_avg)) then + cdrag_conv = cdrag_RL_to_H / SpV_vel(i,k) + else + cdrag_conv = cdrag_L_to_H + endif + + h_vel_pos = h_vel(i,k) + h_neglect if (m==1) then ; Cell_width = G%dy_Cu(I,j)*pbv%por_face_areaU(I,j,k) else ; Cell_width = G%dx_Cv(i,J)*pbv%por_face_areaV(i,J,k) ; endif gam = 1.0 - L(K+1)/L(K) - Rayleigh = US%L_to_Z * CS%cdrag * (L(K)-L(K+1)) * (1.0-BBL_frac) * & + Rayleigh = cdrag_conv * (L(K)-L(K+1)) * (1.0-BBL_frac) * & (12.0*CS%c_Smag*h_vel_pos) / (12.0*CS%c_Smag*h_vel_pos + & - US%L_to_Z*GV%Z_to_H * CS%cdrag * gam*(1.0-gam)*(1.0-1.5*gam) * L(K)**2 * Cell_width) + cdrag_conv * gam*(1.0-gam)*(1.0-1.5*gam) * L(K)**2 * Cell_width) else ! This layer feels no drag. Rayleigh = 0.0 endif @@ -933,36 +1051,33 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (m==1) then if (Rayleigh > 0.0) then v_at_u = set_v_at_u(v, h, G, GV, i, j, k, mask_v, OBC) - visc%Ray_u(I,j,k) = Rayleigh*sqrt(u(I,j,k)*u(I,j,k) + & - v_at_u*v_at_u + U_bg_sq) + visc%Ray_u(I,j,k) = Rayleigh * sqrt(u(I,j,k)*u(I,j,k) + v_at_u*v_at_u + u2_bg(I)) else ; visc%Ray_u(I,j,k) = 0.0 ; endif else if (Rayleigh > 0.0) then u_at_v = set_u_at_v(u, h, G, GV, i, j, k, mask_u, OBC) - visc%Ray_v(i,J,k) = Rayleigh*sqrt(v(i,J,k)*v(i,J,k) + & - u_at_v*u_at_v + U_bg_sq) + visc%Ray_v(i,J,k) = Rayleigh * sqrt(v(i,J,k)*v(i,J,k) + u_at_v*u_at_v + u2_bg(i)) else ; visc%Ray_v(i,J,k) = 0.0 ; endif endif - enddo ! k loop to determine L(K). + enddo ! k loop to determine visc%Ray_[uv]. ! Set the near-bottom viscosity to a value which will give ! the correct stress when the shear occurs over bbl_thick. ! See next block for explanation. - bbl_thick_Z = bbl_thick * GV%H_to_Z if (CS%correct_BBL_bounds .and. & - cdrag_sqrt*ustar(i)*bbl_thick_Z*BBL_visc_frac <= CS%Kv_BBL_min) then + cdrag_sqrt*ustar(i)*bbl_thick*BBL_visc_frac <= CS%Kv_BBL_min) then ! If the bottom stress implies less viscosity than Kv_BBL_min then ! set kv_bbl to the bound and recompute bbl_thick to be consistent ! but with a ridiculously large upper bound on thickness (for Cd u*=0) kv_bbl = CS%Kv_BBL_min - if (cdrag_sqrt*ustar(i)*BBL_visc_frac*G%Rad_Earth_L*US%L_to_Z > kv_bbl) then - bbl_thick_Z = kv_bbl / ( cdrag_sqrt*ustar(i)*BBL_visc_frac ) + if ((cdrag_sqrt*ustar(i))*BBL_visc_frac*BBL_thick_max > kv_bbl) then + bbl_thick = kv_bbl / ( (cdrag_sqrt*ustar(i)) * BBL_visc_frac ) else - bbl_thick_Z = G%Rad_Earth_L * US%L_to_Z + bbl_thick = BBL_thick_max endif else - kv_bbl = cdrag_sqrt*ustar(i)*bbl_thick_Z*BBL_visc_frac + kv_bbl = (cdrag_sqrt*ustar(i)) * bbl_thick*BBL_visc_frac endif else ! Not Channel_drag. @@ -974,36 +1089,59 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! - u_bbl is embedded in u* since u*^2 = Cdrag u_bbl^2 ! - The average shear in the BBL is du/dz = 2 * u_bbl / h_bbl ! (which assumes a linear profile, hence the "2") - ! - bbl_thick was bounded to <= 0.5 * CS%Hbbl + ! - bbl_thick was bounded to <= 0.5 * CS%dz_bbl ! - The viscous stress kv_bbl du/dz should balance tau_b ! Cdrag u_bbl^2 = kv_bbl du/dz ! = 2 kv_bbl u_bbl ! so ! kv_bbl = 0.5 h_bbl Cdrag u_bbl ! = 0.5 h_bbl sqrt(Cdrag) u* - bbl_thick_Z = bbl_thick * GV%H_to_Z if (CS%correct_BBL_bounds .and. & - cdrag_sqrt*ustar(i)*bbl_thick_Z <= CS%Kv_BBL_min) then + cdrag_sqrt*ustar(i)*bbl_thick <= CS%Kv_BBL_min) then ! If the bottom stress implies less viscosity than Kv_BBL_min then ! set kv_bbl to the bound and recompute bbl_thick to be consistent ! but with a ridiculously large upper bound on thickness (for Cd u*=0) kv_bbl = CS%Kv_BBL_min - if (cdrag_sqrt*ustar(i)*G%Rad_Earth_L*US%L_to_Z > kv_bbl) then - bbl_thick_Z = kv_bbl / ( cdrag_sqrt*ustar(i) ) + if ((cdrag_sqrt*ustar(i))*BBL_thick_max > kv_bbl) then + bbl_thick = kv_bbl / ( cdrag_sqrt*ustar(i) ) else - bbl_thick_Z = G%Rad_Earth_L * US%L_to_Z + bbl_thick = BBL_thick_max endif else - kv_bbl = cdrag_sqrt*ustar(i)*bbl_thick_Z + kv_bbl = (cdrag_sqrt*ustar(i)) * bbl_thick endif endif + + if (CS%body_force_drag) then ; if (h_bbl_drag(i) > 0.0) then + ! Increment the Rayleigh drag as a way introduce the bottom drag as a body force. + h_sum = 0.0 + I_hwtot = 1.0 / h_bbl_drag(i) + do k=nz,1,-1 + h_bbl_fr = min(h_bbl_drag(i) - h_sum, h_at_vel(i,k)) * I_hwtot + if (allocated(tv%SpV_avg)) then + cdrag_conv = cdrag_RL_to_H / SpV_vel(i,k) + else + cdrag_conv = cdrag_L_to_H + endif + if (m==1) then + visc%Ray_u(I,j,k) = visc%Ray_u(I,j,k) + (cdrag_conv * umag_avg(I)) * h_bbl_fr + else + visc%Ray_v(i,J,k) = visc%Ray_v(i,J,k) + (cdrag_conv * umag_avg(i)) * h_bbl_fr + endif + h_sum = h_sum + h_at_vel(i,k) + if (h_sum >= h_bbl_drag(i)) exit ! The top of this layer is above the drag zone. + enddo + ! Do not enhance the near-bottom viscosity in this case. + Kv_bbl = CS%Kv_BBL_min + endif ; endif + kv_bbl = max(CS%Kv_BBL_min, kv_bbl) if (m==1) then - visc%Kv_bbl_u(I,j) = kv_bbl - visc%bbl_thick_u(I,j) = bbl_thick_Z + visc%bbl_thick_u(I,j) = bbl_thick + if (allocated(visc%Kv_bbl_u)) visc%Kv_bbl_u(I,j) = kv_bbl else - visc%Kv_bbl_v(i,J) = kv_bbl - visc%bbl_thick_v(i,J) = bbl_thick_Z + visc%bbl_thick_v(i,J) = bbl_thick + if (allocated(visc%Kv_bbl_v)) visc%Kv_bbl_v(i,J) = kv_bbl endif endif ; enddo ! end of i loop enddo ; enddo ! end of m & j loops @@ -1027,18 +1165,720 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) call post_data(CS%id_Ray_v, visc%Ray_v, CS%diag) if (CS%debug) then - if (associated(visc%Ray_u) .and. associated(visc%Ray_v)) & - call uvchksum("Ray [uv]", visc%Ray_u, visc%Ray_v, G%HI, haloshift=0, scale=US%Z_to_m*US%s_to_T) - if (associated(visc%kv_bbl_u) .and. associated(visc%kv_bbl_v)) & + if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) & + call uvchksum("Ray [uv]", visc%Ray_u, visc%Ray_v, G%HI, haloshift=0, & + unscale=GV%H_to_m*US%s_to_T, scalar_pair=.true.) + if (allocated(visc%kv_bbl_u) .and. allocated(visc%kv_bbl_v)) & call uvchksum("kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, G%HI, & - haloshift=0, scale=US%Z2_T_to_m2_s, scalar_pair=.true.) - if (associated(visc%bbl_thick_u) .and. associated(visc%bbl_thick_v)) & + haloshift=0, unscale=GV%HZ_T_to_m2_s, scalar_pair=.true.) + if (allocated(visc%bbl_thick_u) .and. allocated(visc%bbl_thick_v)) & call uvchksum("bbl_thick_[uv]", visc%bbl_thick_u, visc%bbl_thick_v, & - G%HI, haloshift=0, scale=US%Z_to_m, scalar_pair=.true.) + G%HI, haloshift=0, unscale=US%Z_to_m, scalar_pair=.true.) endif end subroutine set_viscous_BBL +!> Determine the normalized open length of each interface, given the edge depths and normalized +!! volumes below each interface. +subroutine find_L_open_uniform_slope(vol_below, Dp, Dm, L, GV) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZK_(GV)+1), intent(in) :: vol_below !< The volume below each interface, normalized by + !! the full horizontal area of a velocity cell [Z ~> m] + real, intent(in) :: Dp !< The larger of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, intent(in) :: Dm !< The smaller of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, dimension(SZK_(GV)+1), intent(out) :: L !< The fraction of the full cell width that is open at + !! the depth of each interface [nondim] + + ! Local variables + real :: slope ! The absolute value of the bottom depth slope across a cell times the cell width [Z ~> m]. + real :: I_slope ! The inverse of the normalized slope [Z-1 ~> m-1] + real :: Vol_open ! The cell volume above which it is open [Z ~> m]. + integer :: K, nz + + nz = GV%ke + + slope = abs(Dp - Dm) + if (slope == 0.0) then + L(1:nz) = 1.0 ; L(nz+1) = 0.0 + else + Vol_open = 0.5*slope + I_slope = 1.0 / slope + + L(nz+1) = 0.0 + do K=nz,1,-1 + if (vol_below(K) >= Vol_open) then ; L(K) = 1.0 + else + ! With a uniformly sloping bottom, the calculation of L(K) is the solution of a simple quadratic equation. + L(K) = sqrt(2.0*vol_below(K)*I_slope) + endif + enddo + endif + +end subroutine find_L_open_uniform_slope + +!> Determine the normalized open length of each interface for concave bathymetry (from the ocean perspective) +!! using trigonometric expressions. In this case there can be two separate open regions. +subroutine find_L_open_concave_trigonometric(vol_below, D_vel, Dp, Dm, L, GV) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZK_(GV)+1), intent(in) :: vol_below !< The volume below each interface, normalized by + !! the full horizontal area of a velocity cell [Z ~> m] + real, intent(in) :: D_vel !< The average bottom depth at a velocity point [Z ~> m] + real, intent(in) :: Dp !< The larger of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, intent(in) :: Dm !< The smaller of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, dimension(SZK_(GV)+1), intent(out) :: L !< The fraction of the full cell width that is open at + !! the depth of each interface [nondim] + + ! Local variables + real :: crv ! crv is the curvature of the bottom depth across a + ! cell, times the cell width squared [Z ~> m]. + real :: crv_3 ! crv/3 [Z ~> m]. + real :: slope ! The absolute value of the bottom depth slope across + ! a cell times the cell width [Z ~> m]. + ! The following "volumes" have units of vertical heights because they are normalized + ! by the full horizontal area of a velocity cell. + real :: Vol_open ! The cell volume above which the face is fully is open [Z ~> m]. + real :: Vol_2_reg ! The cell volume above which there are two separate + ! open areas that must be integrated [Z ~> m]. + real :: C24_crv ! 24/crv [Z-1 ~> m-1]. + real :: apb_4a, ax2_3apb ! Various nondimensional ratios of crv and slope [nondim]. + real :: a2x48_apb3, Iapb ! Combinations of crv (a) and slope (b) [Z-1 ~> m-1] + real :: L0 ! A linear estimate of L appropriate for tiny volumes [nondim]. + real :: slope_crv ! The slope divided by the curvature [nondim] + real :: tmp_val_m1_to_p1 ! A temporary variable [nondim] + real, parameter :: C1_3 = 1.0/3.0, C1_12 = 1.0/12.0 ! Rational constants [nondim] + real, parameter :: C2pi_3 = 8.0*atan(1.0)/3.0 ! An irrational constant, 2/3 pi. [nondim] + integer :: K, nz + + nz = GV%ke + + ! Each cell extends from x=-1/2 to 1/2, and has a topography + ! given by D(x) = crv*x^2 + slope*x + D_vel - crv/12. + !crv_3 = (Dp + Dm - 2.0*D_vel) ; crv = 3.0*crv_3 + crv_3 = (Dp + Dm - (2.0*D_vel)) ; crv = 3.0*crv_3 + slope = Dp - Dm + + ! Calculate the volume above which the entire cell is open and the volume at which the + ! equation that is solved for L changes because there are two separate open regions. + if (slope >= crv) then + Vol_open = D_vel - Dm ; Vol_2_reg = Vol_open + else + slope_crv = slope / crv + Vol_open = 0.25*slope*slope_crv + C1_12*crv + Vol_2_reg = 0.5*slope_crv**2 * (crv - C1_3*slope) + endif + ! Define some combinations of crv & slope for later use. + C24_crv = 24.0/crv ; Iapb = 1.0/(crv+slope) + apb_4a = (slope+crv)/(4.0*crv) ; a2x48_apb3 = (48.0*(crv*crv))*(Iapb**3) + ax2_3apb = 2.0*C1_3*crv*Iapb + + L(nz+1) = 0.0 + ! Determine the normalized open length (L) at each interface. + do K=nz,1,-1 + if (vol_below(K) >= Vol_open) then ! The whole cell is open. + L(K) = 1.0 + elseif (vol_below(K) < Vol_2_reg) then + ! In this case, there is a contiguous open region and + ! vol_below(K) = 0.5*L^2*(slope + crv/3*(3-4L)). + if (a2x48_apb3*vol_below(K) < 1e-8) then ! Could be 1e-7? + ! There is a very good approximation here for massless layers. + !L0 = sqrt(2.0*vol_below(K)*Iapb) ; L(K) = L0*(1.0 + ax2_3apb*L0) + L0 = sqrt(2.0*vol_below(K)*Iapb) ; L(K) = L0*(1.0 + (ax2_3apb*L0)) + else + !L(K) = apb_4a * (1.0 - & + ! 2.0 * cos(C1_3*acos(a2x48_apb3*vol_below(K) - 1.0) - C2pi_3)) + L(K) = apb_4a * (1.0 - & + 2.0 * cos(C1_3*acos((a2x48_apb3*vol_below(K)) - 1.0) - C2pi_3)) + endif + ! To check the answers. + ! Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol_below(K) + else ! There are two separate open regions. + ! vol_below(K) = slope^2/4crv + crv/12 - (crv/12)*(1-L)^2*(1+2L) + ! At the deepest volume, L = slope/crv, at the top L = 1. + ! L(K) = 0.5 - cos(C1_3*acos(1.0 - C24_crv*(Vol_open - vol_below(K))) - C2pi_3) + tmp_val_m1_to_p1 = 1.0 - C24_crv*(Vol_open - vol_below(K)) + tmp_val_m1_to_p1 = max(-1., min(1., tmp_val_m1_to_p1)) + L(K) = 0.5 - cos(C1_3*acos(tmp_val_m1_to_p1) - C2pi_3) + ! To check the answers. + ! Vol_err = Vol_open - 0.25*crv_3*(1.0+2.0*L(K)) * (1.0-L(K))**2 - vol_below(K) + endif + enddo ! k loop to determine L(K) in the concave case + +end subroutine find_L_open_concave_trigonometric + + + +!> Determine the normalized open length of each interface for concave bathymetry (from the ocean perspective) using +!! iterative methods to solve the relevant cubic equations. In this case there can be two separate open regions. +subroutine find_L_open_concave_iterative(vol_below, D_vel, Dp, Dm, L, GV) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZK_(GV)+1), intent(in) :: vol_below !< The volume below each interface, normalized by + !! the full horizontal area of a velocity cell [Z ~> m] + real, intent(in) :: D_vel !< The average bottom depth at a velocity point [Z ~> m] + real, intent(in) :: Dp !< The larger of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, intent(in) :: Dm !< The smaller of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, dimension(SZK_(GV)+1), intent(out) :: L !< The fraction of the full cell width that is open at + !! the depth of each interface [nondim] + + ! Local variables + real :: crv ! crv is the curvature of the bottom depth across a + ! cell, times the cell width squared [Z ~> m]. + real :: crv_3 ! crv/3 [Z ~> m]. + real :: slope ! The absolute value of the bottom depth slope across + ! a cell times the cell width [Z ~> m]. + + ! The following "volumes" have units of vertical heights because they are normalized + ! by the full horizontal area of a velocity cell. + real :: Vol_open ! The cell volume above which the face is fully is open [Z ~> m]. + real :: Vol_2_reg ! The cell volume above which there are two separate + ! open areas that must be integrated [Z ~> m]. + real :: L_2_reg ! The value of L when vol_below is Vol_2_reg [nondim] + real :: vol_inflect_1 ! The volume at which there is an inflection point in the expression + ! relating L to vol_err when there is a single open region [Z ~> m] + real :: vol_inflect_2 ! The volume at which there is an inflection point in the expression + ! relating L to vol_err when there are two open regions [Z ~> m] + + real :: L_inflect_1 ! The value of L that sits at an inflection point in the expression + ! relating L to vol_err when there is a single open region [nondim] + real :: L_inflect_2 ! The value of L that sits at an inflection point in the expression + ! relating L to vol_err when there is are two open regions [nondim] + real :: L_max, L_min ! Maximum and minimum bounds on the solution for L for an interface [nondim] + real :: vol_err ! The difference between the volume below an interface for a given value + ! of L and the target value [Z ~> m] + real :: dVol_dL ! The partial derivative of the volume below with L [Z ~> m] + real :: vol_err_max ! The value of vol_err when L is L_max [Z ~> m] + + ! The following combinations of slope and crv are reused across layers, and hence are pre-calculated + ! for efficiency. All are non-negative. + real :: Icrvpslope ! The inverse of the sum of crv and slope [Z-1 ~> m-1] + real :: slope_crv ! The slope divided by the curvature [nondim] + ! These are only used if the slope exceeds or matches the curvature. + real :: smc ! The slope minus the curvature [Z ~> m] + real :: C3c_m_s ! 3 times the curvature minus the slope [Z ~> m] + real :: I_3c_m_s ! The inverse of 3 times the curvature minus the slope [Z-1 ~> m-1] + ! These are only used if the curvature exceeds the slope. + real :: C4_crv ! The inverse of a quarter of the curvature [Z-1 ~> m-1] + real :: sxcms_c ! The slope times the difference between the curvature and slope + ! divided by the curvature [Z ~> m] + real :: slope2_4crv ! A quarter of the slope squared divided by the curvature [Z ~> m] + real :: I_3s_m_c ! The inverse of 3 times the slope minus the curvature [Z-1 ~> m-1] + real :: C3s_m_c ! 3 times the slope minus the curvature [Z ~> m] + + real, parameter :: C1_3 = 1.0 / 3.0, C1_12 = 1.0 / 12.0 ! Rational constants [nondim] + integer :: K, nz, itt + integer, parameter :: max_itt = 10 + + nz = GV%ke + + ! Each cell extends from x=-1/2 to 1/2, and has a topography + ! given by D(x) = crv*x^2 + slope*x + D_vel - crv/12. + + crv_3 = (Dp + Dm - 2.0*D_vel) ; crv = 3.0*crv_3 + slope = Dp - Dm + + ! Calculate the volume above which the entire cell is open and the volume at which the + ! equation that is solved for L changes because there are two separate open regions. + if (slope >= crv) then + Vol_open = D_vel - Dm ; Vol_2_reg = Vol_open + L_2_reg = 1.0 + if (crv + slope >= 4.0*crv) then + L_inflect_1 = 1.0 ; Vol_inflect_1 = Vol_open + else + slope_crv = slope / crv + L_inflect_1 = 0.25 + 0.25*slope_crv + vol_inflect_1 = 0.25*C1_12 * ((slope_crv + 1.0)**2 * (slope + crv)) + endif + ! Precalculate some combinations of crv & slope for later use. + smc = slope - crv + C3c_m_s = 3.0*crv - slope + if (C3c_m_s > 2.0*smc) I_3c_m_s = 1.0 / C3c_m_s + else + slope_crv = slope / crv + Vol_open = 0.25*slope*slope_crv + C1_12*crv + Vol_2_reg = 0.5*slope_crv**2 * (crv - C1_3*slope) + L_2_reg = slope_crv + + ! The inflection point is useful to know because below the inflection point + ! Newton's method converges monotonically from above and conversely above it. + ! These are the inflection point values of L and vol_below with a single open segment. + vol_inflect_1 = 0.25*C1_12 * ((slope_crv + 1.0)**2 * (slope + crv)) + L_inflect_1 = 0.25 + 0.25*slope_crv + ! These are the inflection point values of L and vol_below when there are two open segments. + ! Vol_inflect_2 = Vol_open - 0.125 * crv_3, which is equivalent to: + vol_inflect_2 = 0.25*slope*slope_crv + 0.125*crv_3 + L_inflect_2 = 0.5 + ! Precalculate some combinations of crv & slope for later use. + C4_crv = 4.0 / crv + slope2_4crv = 0.25 * slope * slope_crv + sxcms_c = slope_crv*(crv - slope) + C3s_m_c = 3.0*slope - crv + if (C3s_m_c > 2.0*sxcms_c) I_3s_m_c = 1.0 / C3s_m_c + endif + ! Define some combinations of crv & slope for later use. + Icrvpslope = 1.0 / (crv+slope) + + L(nz+1) = 0.0 + ! Determine the normalized open length (L) at each interface. + do K=nz,1,-1 + if (vol_below(K) >= Vol_open) then ! The whole cell is open. + L(K) = 1.0 + elseif (vol_below(K) < Vol_2_reg) then + ! In this case, there is a single contiguous open region from x=1/2-L to 1/2. + ! Changing the horizontal variable in the expression from D(x) to D(L) gives: + ! x(L) = 1/2 - L + ! D(L) = crv*(0.5 - L)^2 + slope*(0.5 - L) + D_vel - crv/12 + ! D(L) = crv*L^2 - crv*L + crv/4 + slope*(1/2 - L) + D_vel - crv/12 + ! D(L) = crv*L^2 - (slope+crv)*L + slope/2 + D_vel + crv/6 + ! D(0) = slope/2 + D_vel + crv/6 = (Dp - Dm)/2 + D_vel + (Dp + Dm - 2*D_vel)/2 = Dp + ! D(1) = crv - slope - crv + slope/2 + Dvel + crv/6 = D_vel - slope/2 + crv/6 = Dm + ! + ! vol_below = integral(y = 0 to L) D(y) dy - L * D(L) + ! = crv/3*L^3 - (slope+crv)/2*L^2 + (slope/2 + D_vel + crv/6)*L - + ! (crv*L^2 - (slope+crv)*L + slope/2 + D_vel + crv/6) * L + ! = -2/3 * crv * L^3 + 1/2 * (slope+crv) * L^2 + ! vol_below(K) = 0.5*L(K)**2*(slope + crv_3*(3-4*L(K))) + ! L(K) is between L(K+1) and slope_crv. + L_max = min(L_2_reg, 1.0) + if (vol_below(K) <= vol_inflect_1) L_max = min(L_max, L_inflect_1) + + L_min = L(K+1) + if (vol_below(K) >= vol_inflect_1) L_min = max(L_min, L_inflect_1) + + ! Ignoring the cubic term gives an under-estimate but is very accurate for near bottom + ! layers, so use this as a potential floor. + if (2.0*vol_below(K)*Icrvpslope > L_min**2) L_min = sqrt(2.0*vol_below(K)*Icrvpslope) + + ! Start with L_min in most cases. + L(k) = L_min + + if (vol_below(K) <= vol_inflect_1) then + ! Starting with L_min below L_inflect_1, only the first overshooting iteration of Newton's + ! method needs bounding. + L(k) = L_min + vol_err = 0.5*L(K)**2 * (slope + crv*(1.0 - 4.0*C1_3*L(K))) - vol_below(K) + ! If vol_err is 0 or positive (perhaps due to roundoff in L(K+1)), L_min is already the best solution. + if (vol_err < 0.0) then + dVol_dL = L(K) * (slope + crv*(1.0 - 2.0*L(k))) + if (L(K)*dVol_dL > vol_err + L_max*dVol_dL) then + L(K) = L_max + else + L(K) = L(K) - (vol_err / dVol_dL) + endif + + ! Subsequent iterations of Newton's method do not need bounds. + do itt=1,max_itt + vol_err = 0.5*L(K)**2 * (slope + crv*(1.0 - 4.0*C1_3*L(K))) - vol_below(K) + dVol_dL = L(K) * (slope + crv*(1.0 - 2.0*L(k))) + if (abs(vol_err) < max(1.0e-15*L(K), 1.0e-25)*dVol_dL) exit + L(K) = L(K) - (vol_err / dVol_dL) + enddo + endif + else ! (vol_below(K) > vol_inflect_1) + ! Iteration from below converges monotonically, but we need to deal with the case where we are + ! close to the peak of the topography and Newton's method mimics the convergence of bisection. + + ! Evaluate the error when L(K) = L_min as a possible first guess. + L(k) = L_min + vol_err = 0.5*L(K)**2 * (slope + crv*(1.0 - 4.0*C1_3*L(K))) - vol_below(K) + ! If vol_err is 0 or positive (perhaps due to roundoff in L(K+1)), L_min is already the best solution. + if (vol_err < 0.0) then + + ! These two upper estimates deal with the possibility that this point may be near + ! the upper extrema, where the error term might be approximately parabolic and + ! Newton's method would converge slowly like simple bisection. + if (slope < crv) then + ! if ((L_2_reg - L_min)*(3.0*slope - crv) > 2.0*slope_crv*(crv-slope)) then + if ((L_2_reg - L_min)*C3s_m_c > 2.0*sxcms_c) then + ! There is a decent upper estimate of L from the approximate quadratic equation found + ! by examining the error expressions at L ~= L_2_reg and ignoring the cubic term. + L_max = (slope_crv*(2.0*slope) - sqrt(sxcms_c**2 + & + 2.0*C3s_m_c*(Vol_2_reg - vol_below(K))) ) * I_3s_m_c + ! The line above is equivalent to: + ! L_max = (slope_crv*(2.0*slope) - sqrt(slope_crv**2*(crv-slope)**2 + & + ! 2.0*(3.0*slope - crv)*(Vol_2_reg - vol_below(K))) ) / & + ! (3.0*slope - crv) + else + L_max = slope_crv + endif + else ! (slope >= crv) + if ((1.0 - L_min)*C3c_m_s > 2.0*smc) then + ! There is a decent upper estimate of L from the approximate quadratic equation found + ! by examining the error expressions at L ~= 1 and ignoring the cubic term. + L_max = ( 2.0*crv - sqrt(smc**2 + 2.0*C3c_m_s * (Vol_open - vol_below(K))) ) * I_3c_m_s + ! The line above is equivalent to: + ! L_max = ( 2.0*crv - sqrt((slope - crv)**2 + 2.0*(3.0*crv - slope) * (Vol_open - vol_below(K))) ) / & + ! (3.0*crv - slope) + else + L_max = 1.0 + endif + endif + Vol_err_max = 0.5*L_max**2 * (slope + crv*(1.0 - 4.0*C1_3*L_max)) - vol_below(K) + ! if (Vol_err_max < 0.0) call MOM_error(FATAL, & + ! "Vol_err_max should never be negative in find_L_open_concave_iterative.") + if ((Vol_err_max < abs(Vol_err)) .and. (L_max < 1.0)) then + ! Start with 1 bounded Newton's method step from L_max + dVol_dL = L_max * (slope + crv*(1.0 - 2.0*L_max)) + L(K) = max(L_min, L_max - (vol_err_max / dVol_dL) ) + ! else ! Could use the fact that Vol_err is known to take an iteration? + endif + + ! Subsequent iterations of Newton's method do not need bounds. + do itt=1,max_itt + vol_err = 0.5*L(K)**2 * (slope + crv*(1.0 - 4.0*C1_3*L(K))) - vol_below(K) + dVol_dL = L(K) * (slope + crv*(1.0 - 2.0*L(k))) + if (abs(vol_err) < max(1.0e-15*L(K), 1.0e-25)*dVol_dL) exit + L(K) = L(K) - (vol_err / dVol_dL) + enddo + endif + + endif + + ! To check the answers. + ! Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol_below(K) + else ! There are two separate open regions. + ! vol_below(K) = slope^2/(4*crv) + crv/12 - (crv/12)*(1-L)^2*(1+2L) + ! At the deepest volume, L = slope/crv, at the top L = 1. + + ! To check the answers. + ! Vol_err = Vol_open - 0.25*crv_3*(1.0+2.0*L(K)) * (1.0-L(K))**2 - vol_below(K) + ! or equivalently: + ! Vol_err = Vol_open - 0.25*crv_3*(3.0-2.0*(1.0-L(K))) * (1.0-L(K))**2 - vol_below(K) + ! ! Note that: Vol_open = 0.25*slope*slope_crv + C1_12*crv + ! Vol_err = 0.25*slope*slope_crv + 0.25*crv_3*( 1.0 - (1.0 + 2.0*L(K)) * (1.0-L(K))**2 ) - vol_below(K) + ! Vol_err = 0.25*crv_3*L(K)**2*( 3.0 - 2.0*L(K) ) + 0.25*slope*slope_crv - vol_below(K) + + ! Derivation of the L_max limit below: + ! Vol_open - vol_below(K) = 0.25*crv_3*(3.0-2.0*(1.0-L(K))) * (1.0-L(K))**2 + ! (3.0-2.0*(1.0-L(K))) * (1.0-L(K))**2 = (Vol_open - vol_below(K)) / (0.25*crv_3) + ! When 1-L(K) << 1: + ! 3.0 * (1.0-L_max)**2 = (Vol_open - vol_below(K)) / (0.25*crv_3) + ! (1.0-L_max)**2 = (Vol_open - vol_below(K)) / (0.25*crv) + + ! Derivation of the L_min limit below: + ! Vol_err = 0.25*crv_3*L(K)**2*( 3.0 - 2.0*L(K) ) + 0.25*slope*slope_crv - vol_below(K) + ! crv*L(K)**2*( 1.0 - 2.0*C1_3*L(K) ) = 4.0*vol_below(K) - slope*slope_crv + ! When L(K) << 1: + ! crv*L_min**2 = 4.0*vol_below(K) - slope*slope_crv + ! L_min = sqrt((4.0*vol_below(K) - slope*slope_crv)/crv) + ! Noting that L(K) >= slope_crv, when L(K)-slope_crv << 1: + ! (crv + 2.0*C1_3*slope)*L_min**2 = 4.0*vol_below(K) - slope*slope_crv + ! L_min = sqrt((4.0*vol_below(K) - slope*slope_crv)/(crv + 2.0*C1_3*slope)) + + if (vol_below(K) <= Vol_inflect_2) then + ! Newton's Method would converge monotonically from above, but overshoot from below. + L_min = max(L(K+1), L_2_reg) ! L_2_reg = slope_crv + ! This under-estimate of L(K) is accurate for L ~= slope_crv: + if ((4.0*vol_below(K) - slope*slope_crv) > (crv + 2.0*C1_3*slope)*L_min**2) & + L_min = max(L_min, sqrt((4.0*vol_below(K) - slope*slope_crv) / (crv + 2.0*C1_3*slope))) + L_max = 0.5 ! = L_inflect_2 + + ! Starting with L_min below L_inflect_2, only the first overshooting iteration of Newton's + ! method needs bounding. + L(k) = L_min + Vol_err = crv_3*L(K)**2*( 0.75 - 0.5*L(K) ) + (slope2_4crv - vol_below(K)) + + ! If vol_err is 0 or positive (perhaps due to roundoff in L(K+1)), L_min is already the best solution. + if (vol_err < 0.0) then + dVol_dL = 0.5*crv * (L(K) * (1.0 - L(K))) + if (L(K)*dVol_dL >= vol_err + L_max*dVol_dL) then + L(K) = L_max + else + L(K) = L(K) - (vol_err / dVol_dL) + endif + ! Subsequent iterations of Newton's method do not need bounds. + do itt=1,max_itt + Vol_err = crv_3 * (L(K)**2 * (0.75 - 0.5*L(K))) + (slope2_4crv - vol_below(K)) + dVol_dL = 0.5*crv * (L(K)*(1.0 - L(K))) + if (abs(vol_err) < max(1.0e-15*L(K), 1.0e-25)*dVol_dL) exit + L(K) = L(K) - (vol_err / dVol_dL) + enddo + endif + else ! (vol_below(K) > Vol_inflect_2) + ! Newton's Method would converge monotonically from below, but overshoots from above, and + ! we may need to deal with the case where we are close to the peak of the topography. + L_min = max(L(K+1), 0.5) + L(k) = L_min + + Vol_err = crv_3 * (L(K)**2 * ( 0.75 - 0.5*L(K))) + (slope2_4crv - vol_below(K)) + ! If vol_err is 0 or positive (perhaps due to roundoff in L(K+1)), L(k) is already the best solution. + if (Vol_err < 0.0) then + ! This over-estimate of L(K) is accurate for L ~= 1: + L_max = 1.0 - sqrt( (Vol_open - vol_below(K)) * C4_crv ) + Vol_err_max = crv_3 * (L_max**2 * ( 0.75 - 0.5*L_max)) + (slope2_4crv - vol_below(K)) + ! if (Vol_err_max < 0.0) call MOM_error(FATAL, & + ! "Vol_err_max should never be negative in find_L_open_concave_iterative.") + if ((Vol_err_max < abs(Vol_err)) .and. (L_max < 1.0)) then + ! Start with 1 bounded Newton's method step from L_max + dVol_dL = 0.5*crv * (L_max * (1.0 - L_max)) + L(K) = max(L_min, L_max - (vol_err_max / dVol_dL) ) + ! else ! Could use the fact that Vol_err is known to take an iteration? + endif + + ! Subsequent iterations of Newton's method do not need bounds. + do itt=1,max_itt + Vol_err = crv_3 * (L(K)**2 * ( 0.75 - 0.5*L(K))) + (slope2_4crv - vol_below(K)) + dVol_dL = 0.5*crv * (L(K) * (1.0 - L(K))) + if (abs(vol_err) < max(1.0e-15*L(K), 1.0e-25)*dVol_dL) exit + L(K) = L(K) - (vol_err / dVol_dL) + enddo + endif + endif + + endif + enddo ! k loop to determine L(K) in the concave case + +end subroutine find_L_open_concave_iterative + + + +!> Test the validity the normalized open lengths of each interface for concave bathymetry (from the ocean perspective) +!! by evaluating and returing the relevant cubic equations. +subroutine test_L_open_concave(vol_below, D_vel, Dp, Dm, L, vol_err, GV) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZK_(GV)+1), intent(in) :: vol_below !< The volume below each interface, normalized by + !! the full horizontal area of a velocity cell [Z ~> m] + real, intent(in) :: D_vel !< The average bottom depth at a velocity point [Z ~> m] + real, intent(in) :: Dp !< The larger of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, intent(in) :: Dm !< The smaller of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, dimension(SZK_(GV)+1), intent(in) :: L !< The fraction of the full cell width that is open at + !! the depth of each interface [nondim] + real, dimension(SZK_(GV)+1), intent(out) :: vol_err !< The difference between vol_below and the + !! value obtained from using L in the cubic equation [Z ~> m] + + ! Local variables + real :: crv ! crv is the curvature of the bottom depth across a + ! cell, times the cell width squared [Z ~> m]. + real :: crv_3 ! crv/3 [Z ~> m]. + real :: slope ! The absolute value of the bottom depth slope across + ! a cell times the cell width [Z ~> m]. + + ! The following "volumes" have units of vertical heights because they are normalized + ! by the full horizontal area of a velocity cell. + real :: Vol_open ! The cell volume above which the face is fully is open [Z ~> m]. + real :: Vol_2_reg ! The cell volume above which there are two separate + ! open areas that must be integrated [Z ~> m]. + real :: L_2_reg ! The value of L when vol_below is Vol_2_reg [nondim] + + ! The following combinations of slope and crv are reused across layers, and hence are pre-calculated + ! for efficiency. All are non-negative. + real :: slope_crv ! The slope divided by the curvature [nondim] + ! These are only used if the curvature exceeds the slope. + real :: slope2_4crv ! A quarter of the slope squared divided by the curvature [Z ~> m] + + real, parameter :: C1_3 = 1.0 / 3.0, C1_12 = 1.0 / 12.0 ! Rational constants [nondim] + integer :: K, nz + + nz = GV%ke + + ! Each cell extends from x=-1/2 to 1/2, and has a topography + ! given by D(x) = crv*x^2 + slope*x + D_vel - crv/12. + + crv_3 = (Dp + Dm - 2.0*D_vel) ; crv = 3.0*crv_3 + slope = Dp - Dm + + ! Calculate the volume above which the entire cell is open and the volume at which the + ! equation that is solved for L changes because there are two separate open regions. + if (slope >= crv) then + Vol_open = D_vel - Dm ; Vol_2_reg = Vol_open + L_2_reg = 1.0 + if (crv + slope >= 4.0*crv) then + slope_crv = 1.0 + else + slope_crv = slope / crv + endif + else + slope_crv = slope / crv + Vol_open = 0.25*slope*slope_crv + C1_12*crv + Vol_2_reg = 0.5*slope_crv**2 * (crv - C1_3*slope) + L_2_reg = slope_crv + endif + slope2_4crv = 0.25 * slope * slope_crv + + ! Determine the volume error based on the normalized open length (L) at each interface. + Vol_err(nz+1) = 0.0 + do K=nz,1,-1 + if (L(K) >= 1.0) then + Vol_err(K) = max(Vol_open - vol_below(K), 0.0) + elseif (L(K) <= L_2_reg) then + vol_err(K) = 0.5*L(K)**2 * (slope + crv*(1.0 - 4.0*C1_3*L(K))) - vol_below(K) + else ! There are two separate open regions. + Vol_err(K) = crv_3 * (L(K)**2 * ( 0.75 - 0.5*L(K))) + (slope2_4crv - vol_below(K)) + endif + enddo ! k loop to determine L(K) in the concave case + +end subroutine test_L_open_concave + + +!> Determine the normalized open length of each interface for convex bathymetry (from the ocean +!! perspective) using Newton's method iterations. In this case there is a single open region +!! with the minimum depth at one edge of the cell. +subroutine find_L_open_convex(vol_below, D_vel, Dp, Dm, L, GV, US, CS) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZK_(GV)+1), intent(in) :: vol_below !< The volume below each interface, normalized by + !! the full horizontal area of a velocity cell [Z ~> m] + real, intent(in) :: D_vel !< The average bottom depth at a velocity point [Z ~> m] + real, intent(in) :: Dp !< The larger of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, intent(in) :: Dm !< The smaller of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, dimension(SZK_(GV)+1), intent(out) :: L !< The fraction of the full cell width that is open at + !! the depth of each interface [nondim] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(set_visc_CS), intent(in) :: CS !< The control structure returned by a previous + !! call to set_visc_init. + + ! Local variables + real :: crv ! crv is the curvature of the bottom depth across a + ! cell, times the cell width squared [Z ~> m]. + real :: crv_3 ! crv/3 [Z ~> m]. + real :: slope ! The absolute value of the bottom depth slope across + ! a cell times the cell width [Z ~> m]. + ! All of the following "volumes" have units of vertical heights because they are normalized + ! by the full horizontal area of a velocity cell. + real :: Vol_err ! The error in the volume with the latest estimate of + ! L, or the error for the interface below [Z ~> m]. + real :: Vol_quit ! The volume error below which to quit iterating [Z ~> m]. + real :: Vol_tol ! A volume error tolerance [Z ~> m]. + real :: Vol_open ! The cell volume above which the face is fully open [Z ~> m]. + real :: Vol_direct ! With less than Vol_direct [Z ~> m], there is a direct + ! solution of a cubic equation for L. + real :: Vol_err_max ! The volume error for the upper bound on the correct value for L [Z ~> m] + real :: Vol_err_min ! The volume error for the lower bound on the correct value for L [Z ~> m] + real :: Vol_0 ! A deeper volume with known width L0 [Z ~> m]. + real :: dVol ! vol - Vol_0 [Z ~> m]. + real :: dV_dL2 ! The partial derivative of volume with L squared + ! evaluated at L=L0 [Z ~> m]. + real :: L_direct ! The value of L above volume Vol_direct [nondim]. + real :: L_max, L_min ! Upper and lower bounds on the correct value for L [nondim]. + real :: L0 ! The value of L above volume Vol_0 [nondim]. + real :: Iapb, Ibma_2 ! Combinations of crv (a) and slope (b) [Z-1 ~> m-1] + real :: C24_crv ! 24/crv [Z-1 ~> m-1]. + real :: curv_tol ! Numerator of curvature cubed, used to estimate + ! accuracy of a single L(:) Newton iteration [Z5 ~> m5] + real, parameter :: C1_3 = 1.0/3.0, C1_6 = 1.0/6.0 ! Rational constants [nondim] + logical :: use_L0, do_one_L_iter ! Control flags for L(:) Newton iteration + integer :: K, nz, itt, maxitt=20 + + nz = GV%ke + + ! Each cell extends from x=-1/2 to 1/2, and has a topography + ! given by D(x) = crv*x^2 + slope*x + D_vel - crv/12. + crv_3 = (Dp + Dm - 2.0*D_vel) ; crv = 3.0*crv_3 + slope = Dp - Dm + + ! Calculate the volume above which the entire cell is open and the volume at which the + ! equation that is solved for L changes because there is a direct solution. + Vol_open = D_vel - Dm + if (slope >= -crv) then + Iapb = 1.0e30*US%Z_to_m ; if (slope+crv /= 0.0) Iapb = 1.0/(crv+slope) + Vol_direct = 0.0 ; L_direct = 0.0 ; C24_crv = 0.0 + else + C24_crv = 24.0/crv ; Iapb = 1.0/(crv+slope) + L_direct = 1.0 + slope/crv ! L_direct < 1 because crv < 0 + Vol_direct = -C1_6*crv*L_direct**3 + endif + Ibma_2 = 2.0 / (slope - crv) + + if (CS%answer_date < 20190101) Vol_quit = (0.9*GV%Angstrom_Z + GV%dZ_subroundoff) + + L(nz+1) = 0.0 ; Vol_err = 0.0 + ! Determine the normalized open length (L) at each interface. + do K=nz,1,-1 + if (vol_below(K) >= Vol_open) then + L(K) = 1.0 + elseif (vol_below(K) <= Vol_direct) then + ! Both edges of the cell are bounded by walls. + ! if (CS%answer_date < 20240101)) then + L(K) = (-0.25*C24_crv*vol_below(K))**C1_3 + ! else + ! L(K) = cuberoot(-0.25*C24_crv*vol_below(K)) + ! endif + else + ! x_R is at 1/2 but x_L is in the interior & L is found by iteratively solving + ! vol_below(K) = 0.5*L^2*(slope + crv/3*(3-4L)) + + ! Vol_err = 0.5*(L(K+1)*L(K+1))*(slope + crv_3*(3.0-4.0*L(K+1))) - vol_below(K+1) + ! Change to ... + ! if (min(vol_below(K+1) + Vol_err, vol_below(K)) <= Vol_direct) then ? + if (vol_below(K+1) + Vol_err <= Vol_direct) then + L0 = L_direct ; Vol_0 = Vol_direct + else + L0 = L(K+1) ; Vol_0 = vol_below(K+1) + Vol_err + ! Change to Vol_0 = min(vol_below(K+1) + Vol_err, vol_below(K)) ? + endif + + ! Try a relatively simple solution that usually works well + ! for massless layers. + dV_dL2 = 0.5*(slope+crv) - crv*L0 ; dVol = (vol_below(K)-Vol_0) + ! dV_dL2 = 0.5*(slope+crv) - crv*L0 ; dVol = max(vol_below(K)-Vol_0, 0.0) + + use_L0 = .false. + do_one_L_iter = .false. + if (CS%answer_date < 20190101) then + curv_tol = GV%Angstrom_Z*dV_dL2**2 & + * (0.25 * dV_dL2 * GV%Angstrom_Z - crv * L0 * dVol) + do_one_L_iter = (crv * crv * dVol**3) < curv_tol + else + ! The following code is more robust when GV%Angstrom_H=0, but + ! it changes answers. + use_L0 = (dVol <= 0.) + + Vol_tol = max(0.5 * GV%Angstrom_Z + GV%dZ_subroundoff, 1e-14 * vol_below(K)) + Vol_quit = max(0.9 * GV%Angstrom_Z + GV%dZ_subroundoff, 1e-14 * vol_below(K)) + + curv_tol = Vol_tol * dV_dL2**2 & + * (dV_dL2 * Vol_tol - 2.0 * crv * L0 * dVol) + do_one_L_iter = (crv * crv * dVol**3) < curv_tol + endif + + if (use_L0) then + L(K) = L0 + Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol_below(K) + elseif (do_one_L_iter) then + ! One iteration of Newton's method should give an estimate + ! that is accurate to within Vol_tol. + L(K) = sqrt(L0*L0 + dVol / dV_dL2) + Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol_below(K) + else + if (dV_dL2*(1.0-L0*L0) < dVol + & + dV_dL2 * (Vol_open - vol_below(K))*Ibma_2) then + L_max = sqrt(1.0 - (Vol_open - vol_below(K))*Ibma_2) + else + L_max = sqrt(L0*L0 + dVol / dV_dL2) + endif + L_min = sqrt(L0*L0 + dVol / (0.5*(slope+crv) - crv*L_max)) + + Vol_err_min = 0.5*(L_min**2)*(slope + crv_3*(3.0-4.0*L_min)) - vol_below(K) + Vol_err_max = 0.5*(L_max**2)*(slope + crv_3*(3.0-4.0*L_max)) - vol_below(K) + ! if ((abs(Vol_err_min) <= Vol_quit) .or. (Vol_err_min >= Vol_err_max)) then + if (abs(Vol_err_min) <= Vol_quit) then + L(K) = L_min ; Vol_err = Vol_err_min + else + L(K) = sqrt((L_min**2*Vol_err_max - L_max**2*Vol_err_min) / & + (Vol_err_max - Vol_err_min)) + do itt=1,maxitt + Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol_below(K) + if (abs(Vol_err) <= Vol_quit) exit + ! Take a Newton's method iteration. This equation has proven + ! robust enough not to need bracketing. + L(K) = L(K) - Vol_err / (L(K)* (slope + crv - 2.0*crv*L(K))) + ! This would be a Newton's method iteration for L^2: + ! L(K) = sqrt(L(K)*L(K) - Vol_err / (0.5*(slope+crv) - crv*L(K))) + enddo + endif ! end of iterative solver + endif ! end of 1-boundary alternatives. + endif ! end of 0, 1- and 2- boundary cases. + enddo ! k loop to determine L(K) in the convex case + +end subroutine find_L_open_convex + !> This subroutine finds a thickness-weighted value of v at the u-points. function set_v_at_u(v, h, G, GV, i, j, k, mask2dCv, OBC) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure @@ -1051,7 +1891,7 @@ function set_v_at_u(v, h, G, GV, i, j, k, mask2dCv, OBC) integer, intent(in) :: j !< The j-index of the u-location to work on. integer, intent(in) :: k !< The k-index of the u-location to work on. real, dimension(SZI_(G),SZJB_(G)),& - intent(in) :: mask2dCv !< A multiplicative mask of the v-points + intent(in) :: mask2dCv !< A multiplicative mask of the v-points [nondim] type(ocean_OBC_type), pointer :: OBC !< A pointer to an open boundary condition structure real :: set_v_at_u !< The return value of v at u points points in the !! same units as u, i.e. [L T-1 ~> m s-1] or other units. @@ -1066,11 +1906,11 @@ function set_v_at_u(v, h, G, GV, i, j, k, mask2dCv, OBC) enddo ; enddo if (associated(OBC)) then ; if (OBC%number_of_segments > 0) then - do j0 = -1,0 ; do i0 = 0,1 ; if ((OBC%segnum_v(i+i0,J+j0) /= OBC_NONE)) then + do j0 = -1,0 ; do i0 = 0,1 ; if (OBC%segnum_v(i+i0,J+j0) /= 0) then i1 = i+i0 ; J1 = J+j0 - if (OBC%segment(OBC%segnum_v(i1,j1))%direction == OBC_DIRECTION_N) then + if (OBC%segnum_v(i1,j1) > 0) then ! OBC_DIRECTION_N hwt(i0,j0) = 2.0 * h(i1,j1,k) * mask2dCv(i1,J1) - elseif (OBC%segment(OBC%segnum_v(i1,J1))%direction == OBC_DIRECTION_S) then + elseif (OBC%segnum_v(i1,J1) < 0) then ! OBC_DIRECTION_S hwt(i0,j0) = 2.0 * h(i1,J1+1,k) * mask2dCv(i1,J1) endif endif ; enddo ; enddo @@ -1079,8 +1919,8 @@ function set_v_at_u(v, h, G, GV, i, j, k, mask2dCv, OBC) hwt_tot = (hwt(0,-1) + hwt(1,0)) + (hwt(1,-1) + hwt(0,0)) set_v_at_u = 0.0 if (hwt_tot > 0.0) set_v_at_u = & - ((hwt(0,0) * v(i,J,k) + hwt(1,-1) * v(i+1,J-1,k)) + & - (hwt(1,0) * v(i+1,J,k) + hwt(0,-1) * v(i,J-1,k))) / hwt_tot + (((hwt(0,0) * v(i,J,k)) + (hwt(1,-1) * v(i+1,J-1,k))) + & + ((hwt(1,0) * v(i+1,J,k)) + (hwt(0,-1) * v(i,J-1,k)))) / hwt_tot end function set_v_at_u @@ -1096,7 +1936,7 @@ function set_u_at_v(u, h, G, GV, i, j, k, mask2dCu, OBC) integer, intent(in) :: j !< The j-index of the u-location to work on. integer, intent(in) :: k !< The k-index of the u-location to work on. real, dimension(SZIB_(G),SZJ_(G)), & - intent(in) :: mask2dCu !< A multiplicative mask of the u-points + intent(in) :: mask2dCu !< A multiplicative mask of the u-points [nondim] type(ocean_OBC_type), pointer :: OBC !< A pointer to an open boundary condition structure real :: set_u_at_v !< The return value of u at v points in the !! same units as u, i.e. [L T-1 ~> m s-1] or other units. @@ -1111,11 +1951,11 @@ function set_u_at_v(u, h, G, GV, i, j, k, mask2dCu, OBC) enddo ; enddo if (associated(OBC)) then ; if (OBC%number_of_segments > 0) then - do j0 = 0,1 ; do i0 = -1,0 ; if ((OBC%segnum_u(I+i0,j+j0) /= OBC_NONE)) then + do j0 = 0,1 ; do i0 = -1,0 ; if ((OBC%segnum_u(I+i0,j+j0) /= 0)) then I1 = I+i0 ; j1 = j+j0 - if (OBC%segment(OBC%segnum_u(I1,j1))%direction == OBC_DIRECTION_E) then + if (OBC%segnum_u(I1,j1) > 0) then ! OBC_DIRECTION_E hwt(i0,j0) = 2.0 * h(I1,j1,k) * mask2dCu(I1,j1) - elseif (OBC%segment(OBC%segnum_u(I1,j1))%direction == OBC_DIRECTION_W) then + elseif (OBC%segnum_u(I1,j1) < 0) then ! OBC_DIRECTION_W hwt(i0,j0) = 2.0 * h(I1+1,j1,k) * mask2dCu(I1,j1) endif endif ; enddo ; enddo @@ -1124,8 +1964,8 @@ function set_u_at_v(u, h, G, GV, i, j, k, mask2dCu, OBC) hwt_tot = (hwt(-1,0) + hwt(0,1)) + (hwt(0,0) + hwt(-1,1)) set_u_at_v = 0.0 if (hwt_tot > 0.0) set_u_at_v = & - ((hwt(0,0) * u(I,j,k) + hwt(-1,1) * u(I-1,j+1,k)) + & - (hwt(-1,0) * u(I-1,j,k) + hwt(0,1) * u(I,j+1,k))) / hwt_tot + (((hwt(0,0) * u(I,j,k)) + (hwt(-1,1) * u(I-1,j+1,k))) + & + ((hwt(-1,0) * u(I-1,j,k)) + (hwt(0,1) * u(I,j+1,k)))) / hwt_tot end function set_u_at_v @@ -1146,7 +1986,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available !! thermodynamic fields. Absent fields have - !! NULL ptrs. + !! NULL pointers. type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical viscosities and !! related fields. @@ -1156,65 +1996,80 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) ! Local variables real, dimension(SZIB_(G)) :: & - htot, & ! The total depth of the layers being that are within the + htot, & ! The total thickness of the layers that are within the ! surface mixed layer [H ~> m or kg m-2]. + dztot, & ! The distance from the surface to the bottom of the layers that are + ! within the surface mixed layer [Z ~> m] Thtot, & ! The integrated temperature of layers that are within the - ! surface mixed layer [H degC ~> m degC or kg degC m-2]. + ! surface mixed layer [H C ~> m degC or kg degC m-2]. Shtot, & ! The integrated salt of layers that are within the - ! surface mixed layer [H ppt ~> m ppt or kg ppt m-2]. + ! surface mixed layer [H S ~> m ppt or kg ppt m-2]. + SpV_htot, & ! Running sum of thickness times specific volume [H R-1 ~> m4 kg-1 or m] Rhtot, & ! The integrated density of layers that are within the surface mixed layer ! [H R ~> kg m-2 or kg2 m-5]. Rhtot is only used if no ! equation of state is used. - uhtot, & ! The depth integrated zonal and meridional velocities within - vhtot, & ! the surface mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + uhtot, & ! The depth integrated zonal velocity within the surface + ! mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + vhtot, & ! The depth integrated meridional velocity within the surface + ! mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1]. Idecay_len_TKE, & ! The inverse of a turbulence decay length scale [H-1 ~> m-1 or m2 kg-1]. dR_dT, & ! Partial derivative of the density at the base of layer nkml - ! (roughly the base of the mixed layer) with temperature [R degC-1 ~> kg m-3 degC-1]. + ! (roughly the base of the mixed layer) with temperature [R C-1 ~> kg m-3 degC-1]. dR_dS, & ! Partial derivative of the density at the base of layer nkml - ! (roughly the base of the mixed layer) with salinity [R ppt-1 ~> kg m-3 ppt-1]. - ustar, & ! The surface friction velocity under ice shelves [Z T-1 ~> m s-1]. + ! (roughly the base of the mixed layer) with salinity [R S-1 ~> kg m-3 ppt-1]. + dSpV_dT, & ! Partial derivative of the specific volume at the base of layer nkml + ! (roughly the base of the mixed layer) with temperature [R-1 C-1 ~> m3 kg-1 degC-1]. + dSpV_dS, & ! Partial derivative of the specific volume at the base of layer nkml + ! (roughly the base of the mixed layer) with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. + ustar, & ! The surface friction velocity under ice shelves [H T-1 ~> m s-1 or kg m-2 s-1]. press, & ! The pressure at which dR_dT and dR_dS are evaluated [R L2 T-2 ~> Pa]. - T_EOS, & ! The potential temperature at which dR_dT and dR_dS are evaluated [degC] - S_EOS ! The salinity at which dR_dT and dR_dS are evaluated [ppt]. + T_EOS, & ! The potential temperature at which dR_dT and dR_dS are evaluated [C ~> degC] + S_EOS ! The salinity at which dR_dT and dR_dS are evaluated [S ~> ppt]. + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Height change across layers [Z ~> m] real, dimension(SZIB_(G),SZJ_(G)) :: & mask_u ! A mask that disables any contributions from u points that ! are land or past open boundary conditions [nondim], 0 or 1. real, dimension(SZI_(G),SZJB_(G)) :: & mask_v ! A mask that disables any contributions from v points that ! are land or past open boundary conditions [nondim], 0 or 1. + real :: U_star_2d(SZI_(G),SZJ_(G)) ! The wind friction velocity in thickness-based units, + ! calculated using the Boussinesq reference density or the time-evolving + ! surface density in non-Boussinesq mode [H T-1 ~> m s-1 or kg m-2 s-1] real :: h_at_vel(SZIB_(G),SZK_(GV))! Layer thickness at velocity points, ! using an upwind-biased second order accurate estimate based ! on the previous velocity direction [H ~> m or kg m-2]. + real :: dz_at_vel(SZIB_(G),SZK_(GV)) ! Vertical extent of a layer at velocity points, + ! using an upwind-biased second order accurate estimate based + ! on the previous velocity direction [Z ~> m]. integer :: k_massive(SZIB_(G)) ! The k-index of the deepest layer yet found ! that has more than h_tiny thickness and will be in the ! viscous mixed layer. real :: Uh2 ! The squared magnitude of the difference between the velocity ! integrated through the mixed layer and the velocity of the - ! interior layer layer times the depth of the the mixed layer - ! [H2 Z2 T-2 ~> m4 s-2 or kg2 m-2 s-2]. + ! interior layer layer times the depth of the mixed layer + ! [H2 L2 T-2 ~> m4 s-2 or kg2 m-2 s-2]. real :: htot_vel ! Sum of the layer thicknesses up to some point [H ~> m or kg m-2]. real :: hwtot ! Sum of the thicknesses used to calculate ! the near-bottom velocity magnitude [H ~> m or kg m-2]. - real :: hutot ! Running sum of thicknesses times the - ! velocity magnitudes [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + real :: hutot ! Running sum of thicknesses times the velocity + ! magnitudes [H L T-1 ~> m2 s-1 or kg m-1 s-1]. real :: hweight ! The thickness of a layer that is within Hbbl ! of the bottom [H ~> m or kg m-2]. - real :: tbl_thick_Z ! The thickness of the top boundary layer [Z ~> m]. + real :: tbl_thick ! The thickness of the top boundary layer [Z ~> m]. real :: hlay ! The layer thickness at velocity points [H ~> m or kg m-2]. real :: I_2hlay ! 1 / 2*hlay [H-1 ~> m-1 or m2 kg-1]. - real :: T_lay ! The layer temperature at velocity points [degC]. - real :: S_lay ! The layer salinity at velocity points [ppt]. + real :: T_lay ! The layer temperature at velocity points [C ~> degC]. + real :: S_lay ! The layer salinity at velocity points [S ~> ppt]. real :: Rlay ! The layer potential density at velocity points [R ~> kg m-3]. real :: Rlb ! The potential density of the layer below [R ~> kg m-3]. - real :: v_at_u ! The meridonal velocity at a zonal velocity point [L T-1 ~> m s-1]. - real :: u_at_v ! The zonal velocity at a meridonal velocity point [L T-1 ~> m s-1]. + real :: v_at_u ! The meridional velocity at a zonal velocity point [L T-1 ~> m s-1]. + real :: u_at_v ! The zonal velocity at a meridional velocity point [L T-1 ~> m s-1]. real :: gHprime ! The mixed-layer internal gravity wave speed squared, based ! on the mixed layer thickness and density difference across ! the base of the mixed layer [L2 T-2 ~> m2 s-2]. real :: RiBulk ! The bulk Richardson number below which water is in the - ! viscous mixed layer, including reduction for turbulent - ! decay. Nondimensional. + ! viscous mixed layer, including reduction for turbulent decay [nondim] real :: dt_Rho0 ! The time step divided by the conversion from the layer ! thickness to layer mass [T H Z-1 R-1 ~> s m3 kg-1 or s]. real :: g_H_Rho0 ! The gravitational acceleration times the conversion from H to m divided @@ -1222,31 +2077,38 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) real :: ustarsq ! 400 times the square of ustar, times ! Rho0 divided by G_Earth and the conversion ! from m to thickness units [H R ~> kg m-2 or kg2 m-5]. - real :: cdrag_sqrt_Z ! Square root of the drag coefficient, times a unit conversion - ! factor from lateral lengths to vertical depths [Z L-1 ~> nondim] real :: cdrag_sqrt ! Square root of the drag coefficient [nondim]. + real :: cdrag_sqrt_H ! Square root of the drag coefficient, times a unit conversion + ! factor from lateral lengths to layer thicknesses [H L-1 ~> nondim or kg m-3]. + real :: cdrag_sqrt_H_RL ! Square root of the drag coefficient, times a unit conversion factor from + ! density times lateral lengths to layer thicknesses [H L-1 R-1 ~> m3 kg-1 or nondim] real :: oldfn ! The integrated energy required to ! entrain up to the bottom of the layer, ! divided by G_Earth [H R ~> kg m-2 or kg2 m-5]. real :: Dfn ! The increment in oldfn for entraining ! the layer [H R ~> kg m-2 or kg2 m-5]. - real :: Dh ! The increment in layer thickness from - ! the present layer [H ~> m or kg m-2]. - real :: U_bg_sq ! The square of an assumed background velocity, for - ! calculating the mean magnitude near the top for use in - ! the quadratic surface drag [L2 T-2 ~> m2 s-2]. + real :: frac_used ! The fraction of the present layer that contributes to Dh and Ddz [nondim] + real :: Dh ! The increment in layer thickness from the present layer [H ~> m or kg m-2]. + real :: Ddz ! The increment in height change from the present layer [Z ~> m]. + real :: u2_bg(SZIB_(G)) ! The square of an assumed background velocity, for + ! calculating the mean magnitude near the top for use in + ! the quadratic surface drag [L2 T-2 ~> m2 s-2]. real :: h_tiny ! A very small thickness [H ~> m or kg m-2]. Layers that are less than ! h_tiny can not be the deepest in the viscous mixed layer. real :: absf ! The absolute value of f averaged to velocity points [T-1 ~> s-1]. - real :: U_star ! The friction velocity at velocity points [Z T-1 ~> m s-1]. + real :: U_star ! The friction velocity at velocity points [H T-1 ~> m s-1 or kg m-2 s-1]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. real :: Rho0x400_G ! 400*Rho0/G_Earth, times unit conversion factors - ! [R T2 H Z-2 ~> kg s2 m-4 or kg2 s2 m-7]. + ! [R T2 H-1 ~> kg s2 m-4 or s2 m-1]. ! The 400 is a constant proposed by Killworth and Edwards, 1999. real :: ustar1 ! ustar [H T-1 ~> m s-1 or kg m-2 s-1] real :: h2f2 ! (h*2*f)^2 [H2 T-2 ~> m2 s-2 or kg2 m-4 s-2] logical :: use_EOS, do_any, do_any_shelf, do_i(SZIB_(G)) + logical :: nonBous_ML ! If true, use the non-Boussinesq form of some energy and + ! stratification calculations. integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, K2, nkmb, nkml, n type(ocean_OBC_type), pointer :: OBC => NULL() @@ -1260,35 +2122,48 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) if (.not.(CS%dynamic_viscous_ML .or. associated(forces%frac_shelf_u) .or. & associated(forces%frac_shelf_v)) ) return - Rho0x400_G = 400.0*(GV%Rho0/(US%L_to_Z**2 * GV%g_Earth)) * GV%Z_to_H - U_bg_sq = CS%drag_bg_vel * CS%drag_bg_vel + Rho0x400_G = 400.0*(GV%H_to_RZ / GV%g_Earth_Z_T2) cdrag_sqrt = sqrt(CS%cdrag) - cdrag_sqrt_Z = US%L_to_Z * sqrt(CS%cdrag) + cdrag_sqrt_H = cdrag_sqrt * US%L_to_m * GV%m_to_H + cdrag_sqrt_H_RL = cdrag_sqrt * US%L_to_Z * GV%RZ_to_H OBC => CS%OBC use_EOS = associated(tv%eqn_of_state) + nonBous_ML = allocated(tv%SpV_avg) dt_Rho0 = dt / GV%H_to_RZ h_neglect = GV%H_subroundoff h_tiny = 2.0*GV%Angstrom_H + h_neglect + dz_neglect = GV%dZ_subroundoff g_H_Rho0 = (GV%g_Earth*GV%H_to_Z) / (GV%Rho0) if (associated(forces%frac_shelf_u) .neqv. associated(forces%frac_shelf_v)) & call MOM_error(FATAL, "set_viscous_ML: one of forces%frac_shelf_u and "//& "forces%frac_shelf_v is associated, but the other is not.") + ! Extract the friction velocity from the forcing type. + call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1, H_T_units=.true.) + if (associated(forces%frac_shelf_u)) then ! This configuration has ice shelves, and the appropriate variables need to be ! allocated. If the arrays have already been allocated, these calls do nothing. - call safe_alloc_ptr(visc%tauy_shelf, G%isd, G%ied, G%JsdB, G%JedB) - call safe_alloc_ptr(visc%tbl_thick_shelf_u, G%IsdB, G%IedB, G%jsd, G%jed) - call safe_alloc_ptr(visc%tbl_thick_shelf_v, G%isd, G%ied, G%JsdB, G%JedB) - call safe_alloc_ptr(visc%kv_tbl_shelf_u, G%IsdB, G%IedB, G%jsd, G%jed) - call safe_alloc_ptr(visc%kv_tbl_shelf_v, G%isd, G%ied, G%JsdB, G%JedB) - call safe_alloc_ptr(visc%taux_shelf, G%IsdB, G%IedB, G%jsd, G%jed) - call safe_alloc_ptr(visc%tauy_shelf, G%isd, G%ied, G%JsdB, G%JedB) + if (.not.allocated(visc%taux_shelf)) & + allocate(visc%taux_shelf(G%IsdB:G%IedB, G%jsd:G%jed), source=0.0) + if (.not.allocated(visc%tauy_shelf)) & + allocate(visc%tauy_shelf(G%isd:G%ied, G%JsdB:G%JedB), source=0.0) + if (.not.allocated(visc%tbl_thick_shelf_u)) & + allocate(visc%tbl_thick_shelf_u(G%IsdB:G%IedB, G%jsd:G%jed), source=0.0) + if (.not.allocated(visc%tbl_thick_shelf_v)) & + allocate(visc%tbl_thick_shelf_v(G%isd:G%ied, G%JsdB:G%JedB), source=0.0) + if (.not.allocated(visc%kv_tbl_shelf_u)) & + allocate(visc%kv_tbl_shelf_u(G%IsdB:G%IedB, G%jsd:G%jed), source=0.0) + if (.not.allocated(visc%kv_tbl_shelf_v)) & + allocate(visc%kv_tbl_shelf_v(G%isd:G%ied, G%JsdB:G%JedB), source=0.0) ! With a linear drag law under shelves, the friction velocity is already known. -! if (CS%linear_drag) ustar(:) = cdrag_sqrt_Z*CS%drag_bg_vel +! if (CS%linear_drag) ustar(:) = cdrag_sqrt_H*CS%drag_bg_vel + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) endif !$OMP parallel do default(shared) @@ -1301,8 +2176,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) enddo ; enddo if (associated(OBC)) then ; do n=1,OBC%number_of_segments - ! Now project bottom depths across cell-corner points in the OBCs. The two - ! projections have to occur in sequence and can not be combined easily. + ! Project bottom depths across cell-corner points in the OBCs. if (.not. OBC%segment(n)%on_pe) cycle ! Use a one-sided projection of bottom depths at OBC points. I = OBC%segment(n)%HI%IsdB ; J = OBC%segment(n)%HI%JsdB @@ -1311,7 +2185,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) if (OBC%segment(n)%direction == OBC_DIRECTION_N) mask_u(I,j+1) = 0.0 if (OBC%segment(n)%direction == OBC_DIRECTION_S) mask_u(I,j) = 0.0 enddo - elseif (OBC%segment(n)%is_E_or_W .and. (I >= is-1) .and. (I <= je)) then + elseif (OBC%segment(n)%is_E_or_W .and. (I >= is-1) .and. (I <= ie)) then do J = max(js-1,OBC%segment(n)%HI%JsdB), min(je,OBC%segment(n)%HI%JedB) if (OBC%segment(n)%direction == OBC_DIRECTION_E) mask_v(i+1,J) = 0.0 if (OBC%segment(n)%direction == OBC_DIRECTION_W) mask_v(i,J) = 0.0 @@ -1319,9 +2193,10 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) endif enddo ; endif - !$OMP parallel do default(private) shared(u,v,h,tv,forces,visc,dt,G,GV,US,CS,use_EOS,dt_Rho0, & - !$OMP h_neglect,h_tiny,g_H_Rho0,js,je,OBC,Isq,Ieq,nz, & - !$OMP U_bg_sq,mask_v,cdrag_sqrt,cdrag_sqrt_Z,Rho0x400_G,nkml) + !$OMP parallel do default(private) shared(u,v,h,dz,tv,forces,visc,dt,G,GV,US,CS,use_EOS,dt_Rho0, & + !$OMP nonBous_ML,h_neglect,dz_neglect,h_tiny,g_H_Rho0, & + !$OMP js,je,OBC,Isq,Ieq,nz,nkml,U_star_2d,mask_v, & + !$OMP cdrag_sqrt,cdrag_sqrt_H,cdrag_sqrt_H_RL,Rho0x400_G) do j=js,je ! u-point loop if (CS%dynamic_viscous_ML) then do_any = .false. @@ -1342,8 +2217,8 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) if (CS%omega_frac > 0.0) & absf = sqrt(CS%omega_frac*4.0*CS%omega**2 + (1.0-CS%omega_frac)*absf**2) endif - U_star = max(CS%ustar_min, 0.5 * (forces%ustar(i,j) + forces%ustar(i+1,j))) - Idecay_len_TKE(I) = ((absf / U_star) * CS%TKE_decay) * GV%H_to_Z + U_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i+1,j))) + Idecay_len_TKE(I) = (absf / U_star) * CS%TKE_decay endif enddo @@ -1357,11 +2232,15 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) if (associated(tv%p_surf)) press(I) = press(I) + 0.5*(tv%p_surf(i,j)+tv%p_surf(i+1,j)) k2 = max(1,nkml) I_2hlay = 1.0 / (h(i,j,k2) + h(i+1,j,k2) + h_neglect) - T_EOS(I) = (h(i,j,k2)*tv%T(i,j,k2) + h(i+1,j,k2)*tv%T(i+1,j,k2)) * I_2hlay - S_EOS(I) = (h(i,j,k2)*tv%S(i,j,k2) + h(i+1,j,k2)*tv%S(i+1,j,k2)) * I_2hlay + T_EOS(I) = ((h(i,j,k2)*tv%T(i,j,k2)) + (h(i+1,j,k2)*tv%T(i+1,j,k2))) * I_2hlay + S_EOS(I) = ((h(i,j,k2)*tv%S(i,j,k2)) + (h(i+1,j,k2)*tv%S(i+1,j,k2))) * I_2hlay enddo call calculate_density_derivs(T_EOS, S_EOS, press, dR_dT, dR_dS, tv%eqn_of_state, & (/Isq-G%IsdB+1,Ieq-G%IsdB+1/) ) + if (nonBous_ML) then + call calculate_specific_vol_derivs(T_EOS, S_EOS, press, dSpV_dT, dSpV_dS, tv%eqn_of_state, & + (/Isq-G%IsdB+1,Ieq-G%IsdB+1/) ) + endif endif do I=Isq,Ieq ; if (do_i(I)) then @@ -1369,15 +2248,20 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) hlay = 0.5*(h(i,j,k) + h(i+1,j,k)) if (hlay > h_tiny) then ! Only consider non-vanished layers. I_2hlay = 1.0 / (h(i,j,k) + h(i+1,j,k)) - v_at_u = 0.5 * (h(i,j,k) * (v(i,J,k) + v(i,J-1,k)) + & - h(i+1,j,k) * (v(i+1,J,k) + v(i+1,J-1,k))) * I_2hlay - Uh2 = ((uhtot(I) - htot(I)*u(I,j,k))**2 + (vhtot(I) - htot(I)*v_at_u)**2) + v_at_u = 0.5 * ((h(i,j,k) * (v(i,J,k) + v(i,J-1,k))) + & + (h(i+1,j,k) * (v(i+1,J,k) + v(i+1,J-1,k)))) * I_2hlay + Uh2 = (uhtot(I) - htot(I)*u(I,j,k))**2 + (vhtot(I) - htot(I)*v_at_u)**2 if (use_EOS) then - T_lay = (h(i,j,k)*tv%T(i,j,k) + h(i+1,j,k)*tv%T(i+1,j,k)) * I_2hlay - S_lay = (h(i,j,k)*tv%S(i,j,k) + h(i+1,j,k)*tv%S(i+1,j,k)) * I_2hlay - gHprime = g_H_Rho0 * (dR_dT(I) * (T_lay*htot(I) - Thtot(I)) + & - dR_dS(I) * (S_lay*htot(I) - Shtot(I))) + T_lay = ((h(i,j,k)*tv%T(i,j,k)) + (h(i+1,j,k)*tv%T(i+1,j,k))) * I_2hlay + S_lay = ((h(i,j,k)*tv%S(i,j,k)) + (h(i+1,j,k)*tv%S(i+1,j,k))) * I_2hlay + if (nonBous_ML) then + gHprime = (GV%g_Earth * GV%H_to_RZ) * (dSpV_dT(I) * (Thtot(I) - T_lay*htot(I)) + & + dSpV_dS(I) * (Shtot(I) - S_lay*htot(I))) + else + gHprime = g_H_Rho0 * (dR_dT(I) * (T_lay*htot(I) - Thtot(I)) + & + dR_dS(I) * (S_lay*htot(I) - Shtot(I))) + endif else gHprime = g_H_Rho0 * (GV%Rlay(k)*htot(I) - Rhtot(I)) endif @@ -1405,11 +2289,11 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) do I=Isq,Ieq ; if (do_i(I)) then htot(I) = htot(I) + 0.5 * (h(i,j,k) + h(i+1,j,k)) uhtot(I) = uhtot(I) + 0.5 * (h(i,j,k) + h(i+1,j,k)) * u(I,j,k) - vhtot(I) = vhtot(I) + 0.25 * (h(i,j,k) * (v(i,J,k) + v(i,J-1,k)) + & - h(i+1,j,k) * (v(i+1,J,k) + v(i+1,J-1,k))) + vhtot(I) = vhtot(I) + 0.25 * ((h(i,j,k) * (v(i,J,k) + v(i,J-1,k))) + & + (h(i+1,j,k) * (v(i+1,J,k) + v(i+1,J-1,k)))) if (use_EOS) then - Thtot(I) = Thtot(I) + 0.5 * (h(i,j,k)*tv%T(i,j,k) + h(i+1,j,k)*tv%T(i+1,j,k)) - Shtot(I) = Shtot(I) + 0.5 * (h(i,j,k)*tv%S(i,j,k) + h(i+1,j,k)*tv%S(i+1,j,k)) + Thtot(I) = Thtot(I) + 0.5 * ((h(i,j,k)*tv%T(i,j,k)) + (h(i+1,j,k)*tv%T(i+1,j,k))) + Shtot(I) = Shtot(I) + 0.5 * ((h(i,j,k)*tv%S(i,j,k)) + (h(i+1,j,k)*tv%S(i+1,j,k))) else Rhtot(i) = Rhtot(i) + 0.5 * (h(i,j,k) + h(i+1,j,k)) * GV%Rlay(k) endif @@ -1435,19 +2319,24 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) if (do_any_shelf) then do k=1,nz ; do I=Isq,Ieq ; if (do_i(I)) then - if (u(I,j,k) *(h(i+1,j,k) - h(i,j,k)) >= 0) then + if (u(I,j,k) * (h(i+1,j,k) - h(i,j,k)) >= 0) then h_at_vel(i,k) = 2.0*h(i,j,k)*h(i+1,j,k) / & (h(i,j,k) + h(i+1,j,k) + h_neglect) + dz_at_vel(i,k) = 2.0*dz(i,j,k)*dz(i+1,j,k) / & + (dz(i,j,k) + dz(i+1,j,k) + dz_neglect) else h_at_vel(i,k) = 0.5 * (h(i,j,k) + h(i+1,j,k)) + dz_at_vel(i,k) = 0.5 * (dz(i,j,k) + dz(i+1,j,k)) endif else - h_at_vel(I,k) = 0.0 ; ustar(I) = 0.0 + h_at_vel(I,k) = 0.0 + dz_at_vel(I,k) = 0.0 + ustar(I) = 0.0 endif ; enddo ; enddo do I=Isq,Ieq ; if (do_i(I)) then htot_vel = 0.0 ; hwtot = 0.0 ; hutot = 0.0 - Thtot(I) = 0.0 ; Shtot(I) = 0.0 + Thtot(I) = 0.0 ; Shtot(I) = 0.0 ; SpV_htot(I) = 0.0 if (use_EOS .or. .not.CS%linear_drag) then ; do k=1,nz if (htot_vel>=CS%Htbl_shelf) exit ! terminate the k loop hweight = MIN(CS%Htbl_shelf - htot_vel, h_at_vel(i,k)) @@ -1458,19 +2347,32 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) if (.not.CS%linear_drag) then v_at_u = set_v_at_u(v, h, G, GV, i, j, k, mask_v, OBC) - hutot = hutot + hweight * sqrt(u(I,j,k)**2 + & - v_at_u**2 + U_bg_sq) + ! Set the "back ground" friction velocity scale to either the tidal amplitude or place-holder constant + if (CS%BBL_use_tidal_bg) then + u2_bg(I) = 0.5*( G%mask2dT(i,j)*(CS%tideamp(i,j)*CS%tideamp(i,j))+ & + G%mask2dT(i+1,j)*(CS%tideamp(i+1,j)*CS%tideamp(i+1,j)) ) + else + u2_bg(I) = CS%drag_bg_vel * CS%drag_bg_vel + endif + hutot = hutot + hweight * sqrt(u(I,j,k)**2 + v_at_u**2 + u2_bg(I)) endif if (use_EOS) then Thtot(I) = Thtot(I) + hweight * 0.5 * (tv%T(i,j,k) + tv%T(i+1,j,k)) Shtot(I) = Shtot(I) + hweight * 0.5 * (tv%S(i,j,k) + tv%S(i+1,j,k)) endif + if (allocated(tv%SpV_avg)) then + SpV_htot(I) = SpV_htot(I) + hweight * 0.5 * (tv%SpV_avg(i,j,k) + tv%SpV_avg(i+1,j,k)) + endif enddo ; endif - if ((.not.CS%linear_drag) .and. (hwtot > 0.0)) then - ustar(I) = cdrag_sqrt_Z * hutot/hwtot - else - ustar(I) = cdrag_sqrt_Z * CS%drag_bg_vel + if ((hwtot <= 0.0) .or. (CS%linear_drag .and. .not.allocated(tv%SpV_avg))) then + ustar(I) = cdrag_sqrt_H * CS%drag_bg_vel + elseif (CS%linear_drag .and. allocated(tv%SpV_avg)) then + ustar(I) = cdrag_sqrt_H_RL * CS%drag_bg_vel * (hwtot / SpV_htot(I)) + elseif (allocated(tv%SpV_avg)) then ! (.not.CS%linear_drag) + ustar(I) = cdrag_sqrt_H_RL * hutot / SpV_htot(I) + else ! (.not.CS%linear_drag .and. .not.allocated(tv%SpV_avg)) + ustar(I) = cdrag_sqrt_H * hutot / hwtot endif if (use_EOS) then ; if (hwtot > 0.0) then @@ -1478,6 +2380,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) else T_EOS(I) = 0.0 ; S_EOS(I) = 0.0 endif ; endif + ! if (allocated(tv%SpV_avg)) SpV_av(I) = SpVhtot(I) / hwtot endif ; enddo ! I-loop if (use_EOS) then @@ -1489,9 +2392,9 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) ! The 400.0 in this expression is the square of a constant proposed ! by Killworth and Edwards, 1999, in equation (2.20). ustarsq = Rho0x400_G * ustar(i)**2 - htot(i) = 0.0 + htot(i) = 0.0 ; dztot(i) = 0.0 if (use_EOS) then - Thtot(i) = 0.0 ; Shtot(i) = 0.0 + Thtot(i) = 0.0 ; Shtot(i) = 0.0 ; oldfn = 0.0 do k=1,nz-1 if (h_at_vel(i,k) <= 0.0) cycle T_Lay = 0.5 * (tv%T(i,j,k) + tv%T(i+1,j,k)) @@ -1504,19 +2407,25 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) (h_at_vel(i,k)+htot(i)) if ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) else - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used endif htot(i) = htot(i) + Dh + dztot(i) = dztot(i) + Ddz Thtot(i) = Thtot(i) + T_Lay*Dh ; Shtot(i) = Shtot(i) + S_Lay*Dh enddo if ((oldfn < ustarsq) .and. (h_at_vel(i,nz) > 0.0)) then T_Lay = 0.5*(tv%T(i,j,nz) + tv%T(i+1,j,nz)) S_Lay = 0.5*(tv%S(i,j,nz) + tv%S(i+1,j,nz)) if (dR_dT(i)*(T_Lay*htot(i) - Thtot(i)) + & - dR_dS(i)*(S_Lay*htot(i) - Shtot(i)) < ustarsq) & + dR_dS(i)*(S_Lay*htot(i) - Shtot(i)) < ustarsq) then htot(i) = htot(i) + h_at_vel(i,nz) + dztot(i) = dztot(i) + dz_at_vel(i,nz) + endif endif ! Examination of layer nz. else ! Use Rlay as the density variable. Rhtot = 0.0 @@ -1529,35 +2438,42 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) Dfn = (Rlb - Rlay)*(h_at_vel(i,k)+htot(i)) if ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) else - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used endif htot(i) = htot(i) + Dh + dztot(i) = dztot(i) + Ddz Rhtot(i) = Rhtot(i) + Rlay*Dh enddo - if (GV%Rlay(nz)*htot(i) - Rhtot(i) < ustarsq) & + if (GV%Rlay(nz)*htot(i) - Rhtot(i) < ustarsq) then htot(i) = htot(i) + h_at_vel(i,nz) + dztot(i) = dztot(i) + dz_at_vel(i,nz) + endif endif ! use_EOS - !visc%tbl_thick_shelf_u(I,j) = GV%H_to_Z * max(CS%Htbl_shelf_min, & - ! htot(I) / (0.5 + sqrt(0.25 + & - ! (htot(i)*(G%CoriolisBu(I,J-1)+G%CoriolisBu(I,J)))**2 / & - ! (ustar(i)*GV%Z_to_H)**2 )) ) - ustar1 = ustar(i)*GV%Z_to_H + ! visc%tbl_thick_shelf_u(I,j) = max(CS%Htbl_shelf_min, & + ! dztot(I) / (0.5 + sqrt(0.25 + & + ! ((htot(i)*(G%CoriolisBu(I,J-1)+G%CoriolisBu(I,J)))**2) / & + ! (ustar(i)**2) )) ) + ustar1 = ustar(i) h2f2 = (htot(i)*(G%CoriolisBu(I,J-1)+G%CoriolisBu(I,J)) + h_neglect*CS%omega)**2 - tbl_thick_Z = GV%H_to_Z * max(CS%Htbl_shelf_min, & - ( htot(I)*ustar1 ) / ( 0.5*ustar1 + sqrt((0.5*ustar1)**2 + h2f2 ) ) ) - visc%tbl_thick_shelf_u(I,j) = tbl_thick_Z - visc%Kv_tbl_shelf_u(I,j) = max(CS%Kv_TBL_min, cdrag_sqrt*ustar(i)*tbl_thick_Z) + tbl_thick = max(CS%Htbl_shelf_min, & + ( dztot(I)*ustar(i) ) / ( 0.5*ustar1 + sqrt((0.5*ustar1)**2 + h2f2 ) ) ) + visc%tbl_thick_shelf_u(I,j) = tbl_thick + visc%Kv_tbl_shelf_u(I,j) = max(CS%Kv_TBL_min, cdrag_sqrt*ustar1*tbl_thick) endif ; enddo ! I-loop endif ! do_any_shelf enddo ! j-loop at u-points - !$OMP parallel do default(private) shared(u,v,h,tv,forces,visc,dt,G,GV,US,CS,use_EOS,dt_Rho0, & - !$OMP h_neglect,h_tiny,g_H_Rho0,is,ie,OBC,Jsq,Jeq,nz, & - !$OMP U_bg_sq,cdrag_sqrt,cdrag_sqrt_Z,Rho0x400_G,nkml,mask_u) + !$OMP parallel do default(private) shared(u,v,h,dz,tv,forces,visc,dt,G,GV,US,CS,use_EOS,dt_Rho0, & + !$OMP nonBous_ML,h_neglect,dz_neglect,h_tiny,g_H_Rho0, & + !$OMP is,ie,OBC,Jsq,Jeq,nz,nkml,U_star_2d,mask_u, & + !$OMP cdrag_sqrt,cdrag_sqrt_H,cdrag_sqrt_H_RL,Rho0x400_G) do J=Jsq,Jeq ! v-point loop if (CS%dynamic_viscous_ML) then do_any = .false. @@ -1573,14 +2489,14 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) uhtot(i) = 0.25 * dt_Rho0 * ((forces%taux(I,j) + forces%taux(I-1,j+1)) + & (forces%taux(I-1,j) + forces%taux(I,j+1))) - if (CS%omega_frac >= 1.0) then ; absf = 2.0*CS%omega ; else - absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) - if (CS%omega_frac > 0.0) & - absf = sqrt(CS%omega_frac*4.0*CS%omega**2 + (1.0-CS%omega_frac)*absf**2) - endif + if (CS%omega_frac >= 1.0) then ; absf = 2.0*CS%omega ; else + absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) + if (CS%omega_frac > 0.0) & + absf = sqrt(CS%omega_frac*4.0*CS%omega**2 + (1.0-CS%omega_frac)*absf**2) + endif - U_star = max(CS%ustar_min, 0.5 * (forces%ustar(i,j) + forces%ustar(i,j+1))) - Idecay_len_TKE(i) = ((absf / U_star) * CS%TKE_decay) * GV%H_to_Z + U_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i,j+1))) + Idecay_len_TKE(i) = (absf / U_star) * CS%TKE_decay endif enddo @@ -1595,11 +2511,15 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) if (associated(tv%p_surf)) press(i) = press(i) + 0.5*(tv%p_surf(i,j)+tv%p_surf(i,j+1)) k2 = max(1,nkml) I_2hlay = 1.0 / (h(i,j,k2) + h(i,j+1,k2) + h_neglect) - T_EOS(i) = (h(i,j,k2)*tv%T(i,j,k2) + h(i,j+1,k2)*tv%T(i,j+1,k2)) * I_2hlay - S_EOS(i) = (h(i,j,k2)*tv%S(i,j,k2) + h(i,j+1,k2)*tv%S(i,j+1,k2)) * I_2hlay + T_EOS(i) = ((h(i,j,k2)*tv%T(i,j,k2)) + (h(i,j+1,k2)*tv%T(i,j+1,k2))) * I_2hlay + S_EOS(i) = ((h(i,j,k2)*tv%S(i,j,k2)) + (h(i,j+1,k2)*tv%S(i,j+1,k2))) * I_2hlay enddo call calculate_density_derivs(T_EOS, S_EOS, press, dR_dT, dR_dS, & tv%eqn_of_state, (/is-G%IsdB+1,ie-G%IsdB+1/) ) + if (nonBous_ML) then + call calculate_specific_vol_derivs(T_EOS, S_EOS, press, dSpV_dT, dSpV_dS, tv%eqn_of_state, & + (/is-G%IsdB+1,ie-G%IsdB+1/) ) + endif endif do i=is,ie ; if (do_i(i)) then @@ -1607,15 +2527,20 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) hlay = 0.5*(h(i,j,k) + h(i,j+1,k)) if (hlay > h_tiny) then ! Only consider non-vanished layers. I_2hlay = 1.0 / (h(i,j,k) + h(i,j+1,k)) - u_at_v = 0.5 * (h(i,j,k) * (u(I-1,j,k) + u(I,j,k)) + & - h(i,j+1,k) * (u(I-1,j+1,k) + u(I,j+1,k))) * I_2hlay - Uh2 = ((uhtot(I) - htot(I)*u_at_v)**2 + (vhtot(I) - htot(I)*v(i,J,k))**2) + u_at_v = 0.5 * ((h(i,j,k) * (u(I-1,j,k) + u(I,j,k))) + & + (h(i,j+1,k) * (u(I-1,j+1,k) + u(I,j+1,k)))) * I_2hlay + Uh2 = (vhtot(i) - htot(i)*v(i,J,k))**2 + (uhtot(i) - htot(i)*u_at_v)**2 if (use_EOS) then - T_lay = (h(i,j,k)*tv%T(i,j,k) + h(i,j+1,k)*tv%T(i,j+1,k)) * I_2hlay - S_lay = (h(i,j,k)*tv%S(i,j,k) + h(i,j+1,k)*tv%S(i,j+1,k)) * I_2hlay - gHprime = g_H_Rho0 * (dR_dT(i) * (T_lay*htot(i) - Thtot(i)) + & - dR_dS(i) * (S_lay*htot(i) - Shtot(i))) + T_lay = ((h(i,j,k)*tv%T(i,j,k)) + (h(i,j+1,k)*tv%T(i,j+1,k))) * I_2hlay + S_lay = ((h(i,j,k)*tv%S(i,j,k)) + (h(i,j+1,k)*tv%S(i,j+1,k))) * I_2hlay + if (nonBous_ML) then + gHprime = (GV%g_Earth * GV%H_to_RZ) * (dSpV_dT(i) * (Thtot(i) - T_lay*htot(i)) + & + dSpV_dS(i) * (Shtot(i) - S_lay*htot(i))) + else + gHprime = g_H_Rho0 * (dR_dT(i) * (T_lay*htot(i) - Thtot(i)) + & + dR_dS(i) * (S_lay*htot(i) - Shtot(i))) + endif else gHprime = g_H_Rho0 * (GV%Rlay(k)*htot(i) - Rhtot(i)) endif @@ -1643,11 +2568,11 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) do i=is,ie ; if (do_i(i)) then htot(i) = htot(i) + 0.5 * (h(i,J,k) + h(i,j+1,k)) vhtot(i) = vhtot(i) + 0.5 * (h(i,j,k) + h(i,j+1,k)) * v(i,J,k) - uhtot(i) = uhtot(i) + 0.25 * (h(i,j,k) * (u(I-1,j,k) + u(I,j,k)) + & - h(i,j+1,k) * (u(I-1,j+1,k) + u(I,j+1,k))) + uhtot(i) = uhtot(i) + 0.25 * ((h(i,j,k) * (u(I-1,j,k) + u(I,j,k))) + & + (h(i,j+1,k) * (u(I-1,j+1,k) + u(I,j+1,k)))) if (use_EOS) then - Thtot(i) = Thtot(i) + 0.5 * (h(i,j,k)*tv%T(i,j,k) + h(i,j+1,k)*tv%T(i,j+1,k)) - Shtot(i) = Shtot(i) + 0.5 * (h(i,j,k)*tv%S(i,j,k) + h(i,j+1,k)*tv%S(i,j+1,k)) + Thtot(i) = Thtot(i) + 0.5 * ((h(i,j,k)*tv%T(i,j,k)) + (h(i,j+1,k)*tv%T(i,j+1,k))) + Shtot(i) = Shtot(i) + 0.5 * ((h(i,j,k)*tv%S(i,j,k)) + (h(i,j+1,k)*tv%S(i,j+1,k))) else Rhtot(i) = Rhtot(i) + 0.5 * (h(i,j,k) + h(i,j+1,k)) * GV%Rlay(k) endif @@ -1676,16 +2601,21 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) if (v(i,J,k) * (h(i,j+1,k) - h(i,j,k)) >= 0) then h_at_vel(i,k) = 2.0*h(i,j,k)*h(i,j+1,k) / & (h(i,j,k) + h(i,j+1,k) + h_neglect) + dz_at_vel(i,k) = 2.0*dz(i,j,k)*dz(i,j+1,k) / & + (dz(i,j,k) + dz(i,j+1,k) + dz_neglect) else h_at_vel(i,k) = 0.5 * (h(i,j,k) + h(i,j+1,k)) + dz_at_vel(i,k) = 0.5 * (dz(i,j,k) + dz(i,j+1,k)) endif else - h_at_vel(I,k) = 0.0 ; ustar(i) = 0.0 + h_at_vel(I,k) = 0.0 + dz_at_vel(I,k) = 0.0 + ustar(i) = 0.0 endif ; enddo ; enddo do i=is,ie ; if (do_i(i)) then htot_vel = 0.0 ; hwtot = 0.0 ; hutot = 0.0 - Thtot(i) = 0.0 ; Shtot(i) = 0.0 + Thtot(i) = 0.0 ; Shtot(i) = 0.0 ; SpV_htot(i) = 0.0 if (use_EOS .or. .not.CS%linear_drag) then ; do k=1,nz if (htot_vel>=CS%Htbl_shelf) exit ! terminate the k loop hweight = MIN(CS%Htbl_shelf - htot_vel, h_at_vel(i,k)) @@ -1696,20 +2626,33 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) if (.not.CS%linear_drag) then u_at_v = set_u_at_v(u, h, G, GV, i, J, k, mask_u, OBC) - hutot = hutot + hweight * sqrt(v(i,J,k)**2 + & - u_at_v**2 + U_bg_sq) + ! Set the "back ground" friction velocity scale to either the tidal amplitude or place-holder constant + if (CS%BBL_use_tidal_bg) then + u2_bg(i) = 0.5*( G%mask2dT(i,j)*(CS%tideamp(i,j)*CS%tideamp(i,j))+ & + G%mask2dT(i,j+1)*(CS%tideamp(i,j+1)*CS%tideamp(i,j+1)) ) + else + u2_bg(i) = CS%drag_bg_vel * CS%drag_bg_vel + endif + hutot = hutot + hweight * sqrt(v(i,J,k)**2 + u_at_v**2 + u2_bg(i)) endif if (use_EOS) then Thtot(i) = Thtot(i) + hweight * 0.5 * (tv%T(i,j,k) + tv%T(i,j+1,k)) Shtot(i) = Shtot(i) + hweight * 0.5 * (tv%S(i,j,k) + tv%S(i,j+1,k)) endif + if (allocated(tv%SpV_avg)) then + SpV_htot(i) = SpV_htot(i) + hweight * 0.5 * (tv%SpV_avg(i,j,k) + tv%SpV_avg(i,j+1,k)) + endif enddo ; endif - if (.not.CS%linear_drag) then ; if (hwtot > 0.0) then - ustar(i) = cdrag_sqrt_Z * hutot/hwtot - else - ustar(i) = cdrag_sqrt_Z * CS%drag_bg_vel - endif ; endif + if ((hwtot <= 0.0) .or. (CS%linear_drag .and. .not.allocated(tv%SpV_avg))) then + ustar(i) = cdrag_sqrt_H * CS%drag_bg_vel + elseif (CS%linear_drag .and. allocated(tv%SpV_avg)) then + ustar(i) = cdrag_sqrt_H_RL * CS%drag_bg_vel * (hwtot / SpV_htot(i)) + elseif (allocated(tv%SpV_avg)) then ! (.not.CS%linear_drag) + ustar(i) = cdrag_sqrt_H_RL * hutot / SpV_htot(i) + else ! (.not.CS%linear_drag .and. .not.allocated(tv%SpV_avg)) + ustar(i) = cdrag_sqrt_H * hutot / hwtot + endif if (use_EOS) then ; if (hwtot > 0.0) then T_EOS(i) = Thtot(i)/hwtot ; S_EOS(i) = Shtot(i)/hwtot @@ -1728,8 +2671,9 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) ! by Killworth and Edwards, 1999, in equation (2.20). ustarsq = Rho0x400_G * ustar(i)**2 htot(i) = 0.0 + dztot(i) = 0.0 if (use_EOS) then - Thtot(i) = 0.0 ; Shtot(i) = 0.0 + Thtot(i) = 0.0 ; Shtot(i) = 0.0 ; oldfn = 0.0 do k=1,nz-1 if (h_at_vel(i,k) <= 0.0) cycle T_Lay = 0.5 * (tv%T(i,j,k) + tv%T(i,j+1,k)) @@ -1742,19 +2686,25 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) (h_at_vel(i,k)+htot(i)) if ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) else - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used endif htot(i) = htot(i) + Dh + dztot(i) = dztot(i) + Ddz Thtot(i) = Thtot(i) + T_Lay*Dh ; Shtot(i) = Shtot(i) + S_Lay*Dh enddo if ((oldfn < ustarsq) .and. (h_at_vel(i,nz) > 0.0)) then T_Lay = 0.5*(tv%T(i,j,nz) + tv%T(i,j+1,nz)) S_Lay = 0.5*(tv%S(i,j,nz) + tv%S(i,j+1,nz)) if (dR_dT(i)*(T_Lay*htot(i) - Thtot(i)) + & - dR_dS(i)*(S_Lay*htot(i) - Shtot(i)) < ustarsq) & + dR_dS(i)*(S_Lay*htot(i) - Shtot(i)) < ustarsq) then htot(i) = htot(i) + h_at_vel(i,nz) + dztot(i) = dztot(i) + dz_at_vel(i,nz) + endif endif ! Examination of layer nz. else ! Use Rlay as the density variable. Rhtot = 0.0 @@ -1767,27 +2717,33 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) Dfn = (Rlb - Rlay)*(h_at_vel(i,k)+htot(i)) if ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) else - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used endif htot(i) = htot(i) + Dh + dztot(i) = dztot(i) + Ddz Rhtot = Rhtot + Rlay*Dh enddo - if (GV%Rlay(nz)*htot(i) - Rhtot(i) < ustarsq) & + if (GV%Rlay(nz)*htot(i) - Rhtot(i) < ustarsq) then htot(i) = htot(i) + h_at_vel(i,nz) + dztot(i) = dztot(i) + dz_at_vel(i,nz) + endif endif ! use_EOS - !visc%tbl_thick_shelf_v(i,J) = GV%H_to_Z * max(CS%Htbl_shelf_min, & - ! htot(i) / (0.5 + sqrt(0.25 + & + ! visc%tbl_thick_shelf_v(i,J) = max(CS%Htbl_shelf_min, & + ! dztot(i) / (0.5 + sqrt(0.25 + & ! (htot(i)*(G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)))**2 / & - ! (ustar(i)*GV%Z_to_H)**2 )) ) - ustar1 = ustar(i)*GV%Z_to_H + ! (ustar(i))**2 )) ) + ustar1 = ustar(i) h2f2 = (htot(i)*(G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)) + h_neglect*CS%omega)**2 - tbl_thick_Z = GV%H_to_Z * max(CS%Htbl_shelf_min, & - ( htot(i)*ustar1 ) / ( 0.5*ustar1 + sqrt((0.5*ustar1)**2 + h2f2 ) ) ) - visc%tbl_thick_shelf_v(i,J) = tbl_thick_Z - visc%Kv_tbl_shelf_v(i,J) = max(CS%Kv_TBL_min, cdrag_sqrt*ustar(i)*tbl_thick_Z) + tbl_thick = max(CS%Htbl_shelf_min, & + ( dztot(i)*ustar(i) ) / ( 0.5*ustar1 + sqrt((0.5*ustar1)**2 + h2f2 ) ) ) + visc%tbl_thick_shelf_v(i,J) = tbl_thick + visc%Kv_tbl_shelf_v(i,J) = max(CS%Kv_TBL_min, cdrag_sqrt*ustar1*tbl_thick) endif ; enddo ! i-loop endif ! do_any_shelf @@ -1795,34 +2751,38 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) enddo ! J-loop at v-points if (CS%debug) then - if (associated(visc%nkml_visc_u) .and. associated(visc%nkml_visc_v)) & + if (allocated(visc%nkml_visc_u) .and. allocated(visc%nkml_visc_v)) & call uvchksum("nkml_visc_[uv]", visc%nkml_visc_u, visc%nkml_visc_v, & G%HI, haloshift=0, scalar_pair=.true.) endif - if (CS%id_nkml_visc_u > 0) & - call post_data(CS%id_nkml_visc_u, visc%nkml_visc_u, CS%diag) - if (CS%id_nkml_visc_v > 0) & - call post_data(CS%id_nkml_visc_v, visc%nkml_visc_v, CS%diag) + if (CS%id_nkml_visc_u > 0) call post_data(CS%id_nkml_visc_u, visc%nkml_visc_u, CS%diag) + if (CS%id_nkml_visc_v > 0) call post_data(CS%id_nkml_visc_v, visc%nkml_visc_v, CS%diag) end subroutine set_viscous_ML !> Register any fields associated with the vertvisc_type. -subroutine set_visc_register_restarts(HI, GV, param_file, visc, restart_CS) +subroutine set_visc_register_restarts(HI, G, GV, US, param_file, visc, restart_CS, use_ice_shelf) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time !! parameters. type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical !! viscosities and related fields. !! Allocated here. - type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure + logical, intent(in) :: use_ice_shelf !< if true, register tau_shelf restarts ! Local variables logical :: use_kappa_shear, KS_at_vertex - logical :: adiabatic, useKPP, useEPBL - logical :: use_CVMix_shear, MLE_use_PBL_MLD, use_CVMix_conv + logical :: adiabatic, useKPP, useEPBL, use_ideal_age + logical :: do_brine_plume, use_hor_bnd_diff, use_neutral_diffusion, use_fpmix + logical :: use_CVMix_shear, MLE_use_PBL_MLD, MLE_use_Bodner, use_CVMix_conv integer :: isd, ied, jsd, jed, nz - real :: hfreeze !< If hfreeze > 0 [m], melt potential will be computed. + real :: hfreeze !< If hfreeze > 0 [Z ~> m], melt potential will be computed. + character(len=16) :: Kv_units, Kd_units character(len=40) :: mdl = "MOM_set_visc" ! This module's name. + type(vardesc) :: u_desc, v_desc isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke call get_param(param_file, mdl, "ADIABATIC", adiabatic, default=.false., & @@ -1846,23 +2806,31 @@ subroutine set_visc_register_restarts(HI, GV, param_file, visc, restart_CS) "in the surface boundary layer.", default=.false., do_not_log=.true.) endif + if (GV%Boussinesq) then + Kv_units = "m2 s-1" ; Kd_units = "m2 s-1" + else + Kv_units = "Pa s" ; Kd_units = "kg m-1 s-1" + endif + if (use_kappa_shear .or. useKPP .or. useEPBL .or. use_CVMix_shear .or. use_CVMix_conv) then call safe_alloc_ptr(visc%Kd_shear, isd, ied, jsd, jed, nz+1) call register_restart_field(visc%Kd_shear, "Kd_shear", .false., restart_CS, & - "Shear-driven turbulent diffusivity at interfaces", "m2 s-1", z_grid='i') + "Shear-driven turbulent diffusivity at interfaces", & + units=Kd_units, conversion=GV%HZ_T_to_MKS, z_grid='i') endif if (useKPP .or. useEPBL .or. use_CVMix_shear .or. use_CVMix_conv .or. & (use_kappa_shear .and. .not.KS_at_vertex )) then call safe_alloc_ptr(visc%Kv_shear, isd, ied, jsd, jed, nz+1) call register_restart_field(visc%Kv_shear, "Kv_shear", .false., restart_CS, & - "Shear-driven turbulent viscosity at interfaces", "m2 s-1", z_grid='i') + "Shear-driven turbulent viscosity at interfaces", & + units=Kv_units, conversion=GV%HZ_T_to_MKS, z_grid='i') endif if (use_kappa_shear .and. KS_at_vertex) then call safe_alloc_ptr(visc%TKE_turb, HI%IsdB, HI%IedB, HI%JsdB, HI%JedB, nz+1) call safe_alloc_ptr(visc%Kv_shear_Bu, HI%IsdB, HI%IedB, HI%JsdB, HI%JedB, nz+1) call register_restart_field(visc%Kv_shear_Bu, "Kv_shear_Bu", .false., restart_CS, & - "Shear-driven turbulent viscosity at vertex interfaces", "m2 s-1", & - hor_grid="Bu", z_grid='i') + "Shear-driven turbulent viscosity at vertex interfaces", & + units=Kv_units, conversion=GV%HZ_T_to_MKS, hor_grid="Bu", z_grid='i') elseif (use_kappa_shear) then call safe_alloc_ptr(visc%TKE_turb, isd, ied, jsd, jed, nz+1) endif @@ -1872,26 +2840,102 @@ subroutine set_visc_register_restarts(HI, GV, param_file, visc, restart_CS) call safe_alloc_ptr(visc%Kv_slow, isd, ied, jsd, jed, nz+1) endif - ! visc%MLD is used to communicate the state of the (e)PBL or KPP to the rest of the model + ! visc%MLD and visc%h_ML are used to communicate the state of the (e)PBL or KPP to the rest of the model call get_param(param_file, mdl, "MLE_USE_PBL_MLD", MLE_use_PBL_MLD, & default=.false., do_not_log=.true.) - ! visc%MLD needs to be allocated when melt potential is computed (HFREEZE>0) + ! visc%h_ML needs to be allocated when melt potential is computed (HFREEZE>0) or one of + ! several other parameterizations are in use. call get_param(param_file, mdl, "HFREEZE", hfreeze, & - default=-1.0, do_not_log=.true.) + units="m", default=-1.0, scale=US%m_to_Z, do_not_log=.true.) + call get_param(param_file, mdl, "DO_BRINE_PLUME", do_brine_plume, & + "If true, use a brine plume parameterization from Nguyen et al., 2009.", & + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "USE_HORIZONTAL_BOUNDARY_DIFFUSION", use_hor_bnd_diff, & + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "USE_NEUTRAL_DIFFUSION", use_neutral_diffusion, & + default=.false., do_not_log=.true.) + if (use_neutral_diffusion) & + call get_param(param_file, mdl, "NDIFF_INTERIOR_ONLY", use_neutral_diffusion, & + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "FPMIX", use_fpmix, & + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "USE_IDEAL_AGE_TRACER", use_ideal_age, & + default=.false., do_not_log=.true.) + call openParameterBlock(param_file, 'MLE', do_not_log=.true.) + call get_param(param_file, mdl, "USE_BODNER23", MLE_use_Bodner, & + default=.false., do_not_log=.true.) + call closeParameterBlock(param_file) - if (MLE_use_PBL_MLD) then + if (MLE_use_PBL_MLD .or. MLE_use_Bodner) then call safe_alloc_ptr(visc%MLD, isd, ied, jsd, jed) + endif + if ((hfreeze >= 0.0) .or. MLE_use_PBL_MLD .or. do_brine_plume .or. use_fpmix .or. & + use_neutral_diffusion .or. use_hor_bnd_diff .or. use_ideal_age) then + call safe_alloc_ptr(visc%h_ML, isd, ied, jsd, jed) + endif + + if (MLE_use_PBL_MLD) then call register_restart_field(visc%MLD, "MLD", .false., restart_CS, & - "Instantaneous active mixing layer depth", "m") + "Instantaneous active mixing layer depth", units="m", conversion=US%Z_to_m) + endif + if (MLE_use_PBL_MLD .or. do_brine_plume .or. use_fpmix .or. & + use_neutral_diffusion .or. use_hor_bnd_diff) then + call register_restart_field(visc%h_ML, "h_ML", .false., restart_CS, & + "Instantaneous active mixing layer thickness", & + units=get_thickness_units(GV), conversion=GV%H_to_mks) endif - if (hfreeze >= 0.0 .and. .not.MLE_use_PBL_MLD) then - call safe_alloc_ptr(visc%MLD, isd, ied, jsd, jed) + ! visc%sfc_buoy_flx is used to communicate the state of the (e)PBL or KPP to the rest of the model + if (MLE_use_PBL_MLD .or. MLE_use_Bodner) then + call safe_alloc_ptr(visc%sfc_buoy_flx, isd, ied, jsd, jed) + call register_restart_field(visc%sfc_buoy_flx, "SFC_BFLX", .false., restart_CS, & + "Instantaneous surface buoyancy flux", "m2 s-3", & + conversion=US%Z_to_m**2*US%s_to_T**3) endif + if (use_ice_shelf) then + if (.not.allocated(visc%taux_shelf)) & + allocate(visc%taux_shelf(G%IsdB:G%IedB, G%jsd:G%jed), source=0.0) + if (.not.allocated(visc%tauy_shelf)) & + allocate(visc%tauy_shelf(G%isd:G%ied, G%JsdB:G%JedB), source=0.0) + u_desc = var_desc("u_taux_shelf", "Pa", "the zonal stress on the ocean under ice shelves", & + hor_grid='Cu',z_grid='1') + v_desc = var_desc("v_tauy_shelf", "Pa", "the meridional stress on the ocean under ice shelves", & + hor_grid='Cv',z_grid='1') + call register_restart_pair(visc%taux_shelf, visc%tauy_shelf, u_desc, v_desc, & + .false., restart_CS, conversion=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) + endif end subroutine set_visc_register_restarts +!> This subroutine does remapping for the auxiliary restart variables in a vertvisc_type +!! that are used across timesteps +subroutine remap_vertvisc_aux_vars(G, GV, visc, h_old, h_new, ALE_CSp, OBC) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical + !! viscosities and related fields. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old !< Thickness of source grid [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new !< Thickness of destination grid [H ~> m or kg m-2] + type(ALE_CS), pointer :: ALE_CSp !< ALE control structure to use when remapping + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + + if (associated(visc%Kd_shear)) then + call ALE_remap_interface_vals(ALE_CSp, G, GV, h_old, h_new, visc%Kd_shear) + endif + + if (associated(visc%Kv_shear)) then + call ALE_remap_interface_vals(ALE_CSp, G, GV, h_old, h_new, visc%Kv_shear) + endif + + if (associated(visc%Kv_shear_Bu)) then + call ALE_remap_vertex_vals(ALE_CSp, G, GV, h_old, h_new, visc%Kv_shear_Bu) + endif + +end subroutine remap_vertvisc_aux_vars + !> Initializes the MOM_set_visc control structure subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS, OBC) type(time_type), target, intent(in) :: Time !< The current model time. @@ -1903,38 +2947,41 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic !! output. type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical viscosities and - !! related fields. Allocated here. - type(set_visc_CS), intent(inout) :: CS !< Vertical viscosity control struct - type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct + !! related fields. + type(set_visc_CS), intent(inout) :: CS !< Vertical viscosity control structure + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure type(ocean_OBC_type), pointer :: OBC !< A pointer to an open boundary condition structure ! Local variables real :: Csmag_chan_dflt ! The default value for SMAG_CONST_CHANNEL [nondim] real :: smag_const1 ! The default value for the Smagorinsky Laplacian coefficient [nondim] - real :: TKE_decay_dflt ! The default value of a coeficient scaling the vertical decay + real :: TKE_decay_dflt ! The default value of a coefficient scaling the vertical decay ! rate of TKE [nondim] real :: bulk_Ri_ML_dflt ! The default bulk Richardson number for a bulk mixed layer [nondim] - real :: Kv_background ! The background kinematic viscosity in the interior [m2 s-1] + real :: Kv_background ! The background kinematic viscosity in the interior [Z2 T-1 ~> m2 s-1] real :: omega_frac_dflt ! The default value for the fraction of the absolute rotation rate that ! is used in place of the absolute value of the local Coriolis ! parameter in the denominator of some expressions [nondim] - real :: Z_rescale ! A rescaling factor for heights from the representation in - ! a restart file to the internal representation in this run. - real :: I_T_rescale ! A rescaling factor for time from the internal representation in this run - ! to the representation in a restart file. - real :: Z2_T_rescale ! A rescaling factor for vertical diffusivities and viscosities from the - ! representation in a restart file to the internal representation in this run. - integer :: i, j, k, is, ie, js, je, n + real :: Chan_max_thick_dflt ! The default value for CHANNEL_DRAG_MAX_THICK [Z ~> m] + real :: tideamp_factor ! A factor to multiply by tideamp when converting to mean tidal magnitude [nondim] + real :: shelfbreak_depth ! When CHANNEL_DRAG is true, the bathymetric depth interpolated + ! to the vorticity point is a combination of the harmonic mean of the + ! adjacent velocity point depths below this depth [Z ~> m] and the + ! arithmetic mean of the adjacent depths above it, to roughly mimic a + ! continental shelf break profile. + real, allocatable, dimension(:,:) :: cdrag_h !< The spatially varying quadratic drag coefficient [nondim] + + integer :: i, j, is, ie, js, je integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz - logical :: default_2018_answers - logical :: use_kappa_shear, adiabatic, use_omega, MLE_use_PBL_MLD + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: adiabatic, use_omega, MLE_use_PBL_MLD logical :: use_KPP logical :: use_regridding ! If true, use the ALE algorithm rather than layered ! isopycnal or stacked shallow water mode. logical :: use_temperature ! If true, temperature and salinity are used as state variables. logical :: use_EOS ! If true, density calculated from T & S using an equation of state. - character(len=200) :: filename, tideamp_file - type(OBC_segment_type), pointer :: segment => NULL() ! pointer to OBC segment type + character(len=200) :: filename, cdrag_file, tideamp_file ! Input file names or paths + character(len=80) :: cdrag_var, tideamp_var ! Input file variable names ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_set_visc" ! This module's name. @@ -1953,23 +3000,41 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS CS%RiNo_mix = .false. call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, default=".") CS%inputdir = slasher(CS%inputdir) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) - call get_param(param_file, mdl, "SET_VISC_2018_ANSWERS", CS%answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "SET_VISC_ANSWER_DATE", CS%answer_date, & + "The vintage of the order of arithmetic and expressions in the set 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) call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & "If true, the bottom stress is calculated with a drag "//& "law of the form c_drag*|u|*u. The velocity magnitude "//& "may be an assumed value or it may be based on the "//& "actual velocity in the bottommost HBBL, depending on "//& "LINEAR_DRAG.", default=.true.) + call get_param(param_file, mdl, "DRAG_AS_BODY_FORCE", CS%body_force_drag, & + "If true, the bottom stress is imposed as an explicit body force "//& + "applied over a fixed distance from the bottom, rather than as an "//& + "implicit calculation based on an enhanced near-bottom viscosity. "//& + "The thickness of the bottom boundary layer is HBBL.", & + default=.false., do_not_log=.not.CS%bottomdraglaw) call get_param(param_file, mdl, "CHANNEL_DRAG", CS%Channel_drag, & "If true, the bottom drag is exerted directly on each "//& - "layer proportional to the fraction of the bottom it "//& - "overlies.", default=.false.) + "layer proportional to the fraction of the bottom it overlies.", & + default=.false.) + call get_param(param_file, mdl, "CHANNEL_DRAG_SHELFBREAK_DEPTH", shelfbreak_depth, & + "When CHANNEL_DRAG is true, the bathymetric depth interpolated to the "//& + "vorticity point is a combination of the harmonic mean of the adjacent "//& + "velocity point depths below this depth and the arithmetic mean of the "//& + "depths above it, to roughly mimic a continental shelf break profile. "//& + "Setting this to exceed MAXIMUM_DEPTH leads to linear interpolation of "//& + "the topography between velocity points.", & + default=0.0, units="m", scale=US%m_to_Z, do_not_log=.not.CS%Channel_drag) + CS%channel_break_depth = shelfbreak_depth - G%Z_ref + call get_param(param_file, mdl, "LINEAR_DRAG", CS%linear_drag, & "If LINEAR_DRAG and BOTTOMDRAGLAW are defined the drag "//& "law is cdrag*DRAG_BG_VEL*u.", default=.false.) @@ -1977,19 +3042,15 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS do_not_log=.true.) if (adiabatic) then call log_param(param_file, mdl, "ADIABATIC",adiabatic, & - "There are no diapycnal mass fluxes if ADIABATIC is "//& - "true. This assumes that KD = KDML = 0.0 and that "//& - "there is no buoyancy forcing, but makes the model "//& - "faster by eliminating subroutine calls.", default=.false.) + "There are no diapycnal mass fluxes if ADIABATIC is true. "//& + "This assumes that KD = 0.0 and that there is no buoyancy forcing, "//& + "but makes the model faster by eliminating subroutine calls.", default=.false.) endif if (.not.adiabatic) then CS%RiNo_mix = kappa_shear_is_used(param_file) endif - call get_param(param_file, mdl, "PRANDTL_TURB", visc%Prandtl_turb, & - "The turbulent Prandtl number applied to shear "//& - "instability.", units="nondim", default=1.0) call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) call get_param(param_file, mdl, "DYNAMIC_VISCOUS_ML", CS%dynamic_viscous_ML, & @@ -1997,28 +3058,26 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS "determine the mixed layer thickness for viscosity.", & default=.false.) if (CS%dynamic_viscous_ML) then - call get_param(param_file, mdl, "BULK_RI_ML", bulk_Ri_ML_dflt, default=0.0) + call get_param(param_file, mdl, "BULK_RI_ML", bulk_Ri_ML_dflt, units="nondim", default=0.0) call get_param(param_file, mdl, "BULK_RI_ML_VISC", CS%bulk_Ri_ML, & - "The efficiency with which mean kinetic energy released "//& - "by mechanically forced entrainment of the mixed layer "//& - "is converted to turbulent kinetic energy. By default, "//& - "BULK_RI_ML_VISC = BULK_RI_ML or 0.", units="nondim", & - default=bulk_Ri_ML_dflt) - call get_param(param_file, mdl, "TKE_DECAY", TKE_decay_dflt, default=0.0) + "The efficiency with which mean kinetic energy released by mechanically "//& + "forced entrainment of the mixed layer is converted to turbulent "//& + "kinetic energy. By default, BULK_RI_ML_VISC = BULK_RI_ML or 0.", & + units="nondim", default=bulk_Ri_ML_dflt) + call get_param(param_file, mdl, "TKE_DECAY", TKE_decay_dflt, units="nondim", default=0.0) call get_param(param_file, mdl, "TKE_DECAY_VISC", CS%TKE_decay, & "TKE_DECAY_VISC relates the vertical rate of decay of "//& "the TKE available for mechanical entrainment to the "//& "natural Ekman depth for use in calculating the dynamic "//& - "mixed layer viscosity. By default, "//& - "TKE_DECAY_VISC = TKE_DECAY or 0.", units="nondim", & - default=TKE_decay_dflt) + "mixed layer viscosity. By default, TKE_DECAY_VISC = TKE_DECAY or 0.", & + units="nondim", default=TKE_decay_dflt) call get_param(param_file, mdl, "ML_USE_OMEGA", use_omega, & "If true, use the absolute rotation rate instead of the "//& "vertical component of rotation when setting the decay "//& - "scale for turbulence.", default=.false., do_not_log=.true.) + "scale for turbulence.", default=.false., do_not_log=.true.) omega_frac_dflt = 0.0 if (use_omega) then - call MOM_error(WARNING, "ML_USE_OMEGA is depricated; use ML_OMEGA_FRAC=1.0 instead.") + call MOM_error(WARNING, "ML_USE_OMEGA is deprecated; use ML_OMEGA_FRAC=1.0 instead.") omega_frac_dflt = 1.0 endif call get_param(param_file, mdl, "ML_OMEGA_FRAC", CS%omega_frac, & @@ -2027,28 +3086,37 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS "local value of f, as sqrt((1-of)*f^2 + of*4*omega^2).", & units="nondim", default=omega_frac_dflt) call get_param(param_file, mdl, "OMEGA", CS%omega, & - "The rotation rate of the earth.", units="s-1", & - default=7.2921e-5, scale=US%T_to_s) + "The rotation rate of the earth.", & + units="s-1", default=7.2921e-5, scale=US%T_to_s) ! This give a minimum decay scale that is typically much less than Angstrom. - CS%ustar_min = 2e-4*CS%omega*(GV%Angstrom_Z + GV%H_to_Z*GV%H_subroundoff) + CS%ustar_min = 2e-4*CS%omega*(GV%Angstrom_H + GV%H_subroundoff) else call get_param(param_file, mdl, "OMEGA", CS%omega, & - "The rotation rate of the earth.", units="s-1", & - default=7.2921e-5, scale=US%T_to_s) + "The rotation rate of the earth.", & + units="s-1", default=7.2921e-5, scale=US%T_to_s) endif - call get_param(param_file, mdl, "HBBL", CS%Hbbl, & - "The thickness of a bottom boundary layer with a "//& - "viscosity of KVBBL if BOTTOMDRAGLAW is not defined, or "//& - "the thickness over which near-bottom velocities are "//& - "averaged for the drag law if BOTTOMDRAGLAW is defined "//& - "but LINEAR_DRAG is not.", units="m", fail_if_missing=.true.) ! Rescaled later + call get_param(param_file, mdl, "HBBL", CS%dz_bbl, & + "The thickness of a bottom boundary layer with a viscosity increased by "//& + "KV_EXTRA_BBL if BOTTOMDRAGLAW is not defined, or the thickness over which "//& + "near-bottom velocities are averaged for the drag law if BOTTOMDRAGLAW is "//& + "defined but LINEAR_DRAG is not.", & + units="m", scale=US%m_to_Z, fail_if_missing=.true.) ! Rescaled later if (CS%bottomdraglaw) then call get_param(param_file, mdl, "CDRAG", CS%cdrag, & "CDRAG is the drag coefficient relating the magnitude of "//& "the velocity field to the bottom stress. CDRAG is only "//& - "used if BOTTOMDRAGLAW is defined.", units="nondim", & - default=0.003) + "used if BOTTOMDRAGLAW is defined.", units="nondim", default=0.003) + call get_param(param_file, mdl, "CDRAG_MAP", CS%bottomdragmap, & + "If true, apply a spatially varying scaling factor to CDRAG, "//& + "specified by CDRAG_VAR in CDRAG_FILE.", default=.false.) + call get_param(param_file, mdl, "CDRAG_FILE", cdrag_file, & + "The name of the file with the spatially varying bottom drag "//& + "scaling factor.", default="", do_not_log=.not.CS%bottomdragmap) + call get_param(param_file, mdl, "CDRAG_VAR", cdrag_var, & + "The name of the variable in CDRAG_FILE with the spatially "//& + "varying bottom drag scaling factor at h points.", & + default="", do_not_log=.not.CS%bottomdragmap) call get_param(param_file, mdl, "BBL_USE_TIDAL_BG", CS%BBL_use_tidal_bg, & "Flag to use the tidal RMS amplitude in place of constant "//& "background velocity for computing u* in the BBL. "//& @@ -2058,6 +3126,25 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS call get_param(param_file, mdl, "TIDEAMP_FILE", tideamp_file, & "The path to the file containing the spatially varying "//& "tidal amplitudes with INT_TIDE_DISSIPATION.", default="tideamp.nc") + call get_param(param_file, mdl, "TIDEAMP_VARNAME", tideamp_var, & + "The name of the tidal amplitude variable in the input file.", & + default="tideamp") + ! This value is here only to detect whether it is inadvertently used. CS%drag_bg_vel should + ! not be used if CS%BBL_use_tidal_bg is True. For this reason, we do not apply dimensions, + ! nor dimensional testing in this mode. If we ever detect a dimensional sensitivity to + ! this parameter, in this mode, then it means it is being used inappropriately. + CS%drag_bg_vel = 1.e30 + call get_param(param_file, mdl, "TIDEAMP_FACTOR", tideamp_factor, & + "A parameter to multiply by tideamp when converting to ustar. "//& + "It accounts for converting the amplitude to a mean magintude (approx 1/sqrt(2)) "//& + "and possibly also for non-commuting averaging operators when converting to ustar**3. "//& + "It is ignored if negative and uncapped so it can be greater than 1 if desired.",& + units="nondim", default=-1.0) + if (tideamp_factor < 0.0) then + CS%tideampfac2 = 1.0 + else + CS%tideampfac2 = tideamp_factor*tideamp_factor + endif else call get_param(param_file, mdl, "DRAG_BG_VEL", CS%drag_bg_vel, & "DRAG_BG_VEL is either the assumed bottom velocity (with "//& @@ -2084,24 +3171,22 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS "The minimum bottom boundary layer thickness that can be "//& "used with BOTTOMDRAGLAW. This might be "//& "Kv/(cdrag*drag_bg_vel) to give Kv as the minimum "//& - "near-bottom viscosity.", units="m", default=0.0) ! Rescaled later + "near-bottom viscosity.", units="m", default=0.0, scale=US%m_to_Z) call get_param(param_file, mdl, "HTBL_SHELF_MIN", CS%Htbl_shelf_min, & "The minimum top boundary layer thickness that can be "//& "used with BOTTOMDRAGLAW. This might be "//& "Kv/(cdrag*drag_bg_vel) to give Kv as the minimum "//& - "near-top viscosity.", units="m", default=CS%BBL_thick_min, scale=GV%m_to_H) + "near-top viscosity.", units="m", default=US%Z_to_m*CS%BBL_thick_min, scale=US%m_to_Z) call get_param(param_file, mdl, "HTBL_SHELF", CS%Htbl_shelf, & "The thickness over which near-surface velocities are "//& "averaged for the drag law under an ice shelf. By "//& - "default this is the same as HBBL", units="m", default=CS%Hbbl, scale=GV%m_to_H) - ! These unit conversions are out outside the get_param calls because the are also defaults. - CS%Hbbl = CS%Hbbl * GV%m_to_H ! Rescale - CS%BBL_thick_min = CS%BBL_thick_min * GV%m_to_H ! Rescale + "default this is the same as HBBL", & + units="m", default=US%Z_to_m*CS%dz_bbl, scale=GV%m_to_H) call get_param(param_file, mdl, "KV", Kv_background, & "The background kinematic viscosity in the interior. "//& "The molecular value, ~1e-6 m2 s-1, may be used.", & - units="m2 s-1", fail_if_missing=.true.) + units="m2 s-1", scale=US%m2_s_to_Z2_T, fail_if_missing=.true.) call get_param(param_file, mdl, "USE_KPP", use_KPP, & "If true, turns on the [CVMix] KPP scheme of Large et al., 1994, "//& @@ -2110,17 +3195,17 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS call get_param(param_file, mdl, "KV_BBL_MIN", CS%KV_BBL_min, & "The minimum viscosities in the bottom boundary layer.", & - units="m2 s-1", default=Kv_background, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=US%Z2_T_to_m2_s*Kv_background, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "KV_TBL_MIN", CS%KV_TBL_min, & "The minimum viscosities in the top boundary layer.", & - units="m2 s-1", default=Kv_background, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=US%Z2_T_to_m2_s*Kv_background, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "CORRECT_BBL_BOUNDS", CS%correct_BBL_bounds, & "If true, uses the correct bounds on the BBL thickness and "//& "viscosity so that the bottom layer feels the intended drag.", & default=.false.) if (CS%Channel_drag) then - call get_param(param_file, mdl, "SMAG_LAP_CONST", smag_const1, default=-1.0) + call get_param(param_file, mdl, "SMAG_LAP_CONST", smag_const1, units="nondim", default=-1.0) cSmag_chan_dflt = 0.15 if (smag_const1 >= 0.0) cSmag_chan_dflt = smag_const1 @@ -2131,30 +3216,49 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS "default is to use the same value as SMAG_LAP_CONST if "//& "it is defined, or 0.15 if it is not. The value used is "//& "also 0.15 if the specified value is negative.", & - units="nondim", default=cSmag_chan_dflt) + units="nondim", default=cSmag_chan_dflt, do_not_log=.not.CS%Channel_drag) if (CS%c_Smag < 0.0) CS%c_Smag = 0.15 + + call get_param(param_file, mdl, "TRIG_CHANNEL_DRAG_WIDTHS", CS%concave_trigonometric_L, & + "If true, use trigonometric expressions to determine the fractional open "//& + "interface lengths for concave topography.", & + default=.true., do_not_log=.not.CS%Channel_drag) endif + Chan_max_thick_dflt = -1.0*US%m_to_Z + if (CS%RiNo_mix) Chan_max_thick_dflt = 0.5*CS%dz_bbl + if (CS%body_force_drag) Chan_max_thick_dflt = CS%dz_bbl + call get_param(param_file, mdl, "CHANNEL_DRAG_MAX_BBL_THICK", CS%Chan_drag_max_vol, & + "The maximum bottom boundary layer thickness over which the channel drag is "//& + "exerted, or a negative value for no fixed limit, instead basing the BBL "//& + "thickness on the bottom stress, rotation and stratification. The default is "//& + "proportional to HBBL if USE_JACKSON_PARAM or DRAG_AS_BODY_FORCE is true.", & + units="m", default=US%Z_to_m*Chan_max_thick_dflt, scale=US%m_to_Z, & + do_not_log=.not.CS%Channel_drag) + call get_param(param_file, mdl, "MLE_USE_PBL_MLD", MLE_use_PBL_MLD, & default=.false., do_not_log=.true.) + CS%Hbbl = CS%dz_bbl * (US%Z_to_m * GV%m_to_H) ! Rescaled for use in expressions in thickness units. + if (CS%RiNo_mix .and. kappa_shear_at_vertex(param_file)) then - ! This is necessary for reproduciblity across restarts in non-symmetric mode. + ! This is necessary for reproducibility across restarts in non-symmetric mode. call pass_var(visc%Kv_shear_Bu, G%Domain, position=CORNER, complete=.true.) endif if (CS%bottomdraglaw) then allocate(visc%bbl_thick_u(IsdB:IedB,jsd:jed), source=0.0) - allocate(visc%kv_bbl_u(IsdB:IedB,jsd:jed), source=0.0) allocate(visc%bbl_thick_v(isd:ied,JsdB:JedB), source=0.0) + allocate(visc%kv_bbl_u(IsdB:IedB,jsd:jed), source=0.0) allocate(visc%kv_bbl_v(isd:ied,JsdB:JedB), source=0.0) allocate(visc%ustar_bbl(isd:ied,jsd:jed), source=0.0) - allocate(visc%TKE_bbl(isd:ied,jsd:jed), source=0.0) + allocate(visc%BBL_meanKE_loss(isd:ied,jsd:jed), source=0.0) + allocate(visc%BBL_meanKE_loss_sqrtCd(isd:ied,jsd:jed), source=0.0) CS%id_bbl_thick_u = register_diag_field('ocean_model', 'bbl_thick_u', & diag%axesCu1, Time, 'BBL thickness at u points', 'm', conversion=US%Z_to_m) CS%id_kv_bbl_u = register_diag_field('ocean_model', 'kv_bbl_u', diag%axesCu1, & - Time, 'BBL viscosity at u points', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + Time, 'BBL viscosity at u points', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) CS%id_bbl_u = register_diag_field('ocean_model', 'bbl_u', diag%axesCu1, & Time, 'BBL mean u current', 'm s-1', conversion=US%L_T_to_m_s) if (CS%id_bbl_u>0) then @@ -2163,27 +3267,48 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS CS%id_bbl_thick_v = register_diag_field('ocean_model', 'bbl_thick_v', & diag%axesCv1, Time, 'BBL thickness at v points', 'm', conversion=US%Z_to_m) CS%id_kv_bbl_v = register_diag_field('ocean_model', 'kv_bbl_v', diag%axesCv1, & - Time, 'BBL viscosity at v points', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + Time, 'BBL viscosity at v points', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) CS%id_bbl_v = register_diag_field('ocean_model', 'bbl_v', diag%axesCv1, & Time, 'BBL mean v current', 'm s-1', conversion=US%L_T_to_m_s) if (CS%id_bbl_v>0) then allocate(CS%bbl_v(isd:ied,JsdB:JedB), source=0.0) endif + if (CS%bottomdragmap) then + if (len_trim(cdrag_file)==0 .or. len_trim(cdrag_var)==0) then + call MOM_error(FATAL,"CDRAG_FILE and CDRAG_VAR are required when using CDRAG_MAP.") + endif + allocate(cdrag_h(isd:ied,jsd:jed), source=0.0) + allocate(CS%cdrag_u(IsdB:IedB,jsd:jed), source=0.0) + allocate(CS%cdrag_v(isd:ied,JsdB:JedB), source=0.0) + filename = trim(CS%inputdir) // trim(cdrag_file) + call log_param(param_file, mdl, "INPUTDIR/CDRAG_FILE", filename) + call MOM_read_data(filename, cdrag_var, cdrag_h, G%domain, scale=CS%cdrag) + call pass_var(cdrag_h, G%domain) + do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0) then + CS%cdrag_u(I,j) = (G%mask2dT(i,j) * cdrag_h(i,j) + G%mask2dT(i+1,j) * cdrag_h(i+1,j)) / & + (G%mask2dT(i,j) + G%mask2dT(i+1,j)) + endif ; enddo ; enddo + do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0) then + CS%cdrag_v(i,J) = (G%mask2dT(i,j) * cdrag_h(i,j) + G%mask2dT(i,j+1) * cdrag_h(i,j+1)) / & + (G%mask2dT(i,j) + G%mask2dT(i,j+1)) + endif ; enddo ; enddo + deallocate(cdrag_h) + endif if (CS%BBL_use_tidal_bg) then allocate(CS%tideamp(isd:ied,jsd:jed), source=0.0) filename = trim(CS%inputdir) // trim(tideamp_file) call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) - call MOM_read_data(filename, 'tideamp', CS%tideamp, G%domain, scale=US%m_to_Z*US%T_to_s) + call MOM_read_data(filename, tideamp_var, CS%tideamp, G%domain, scale=US%m_s_to_L_T) call pass_var(CS%tideamp,G%domain) endif endif - if (CS%Channel_drag) then + if (CS%Channel_drag .or. CS%body_force_drag) then allocate(visc%Ray_u(IsdB:IedB,jsd:jed,nz), source=0.0) allocate(visc%Ray_v(isd:ied,JsdB:JedB,nz), source=0.0) CS%id_Ray_u = register_diag_field('ocean_model', 'Rayleigh_u', diag%axesCuL, & - Time, 'Rayleigh drag velocity at u points', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + Time, 'Rayleigh drag velocity at u points', 'm s-1', conversion=GV%H_to_m*US%s_to_T) CS%id_Ray_v = register_diag_field('ocean_model', 'Rayleigh_v', diag%axesCvL, & - Time, 'Rayleigh drag velocity at v points', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + Time, 'Rayleigh drag velocity at v points', 'm s-1', conversion=GV%H_to_m*US%s_to_T) endif @@ -2191,52 +3316,14 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS allocate(visc%nkml_visc_u(IsdB:IedB,jsd:jed), source=0.0) allocate(visc%nkml_visc_v(isd:ied,JsdB:JedB), source=0.0) CS%id_nkml_visc_u = register_diag_field('ocean_model', 'nkml_visc_u', & - diag%axesCu1, Time, 'Number of layers in viscous mixed layer at u points', 'm') + diag%axesCu1, Time, 'Number of layers in viscous mixed layer at u points', 'nondim') CS%id_nkml_visc_v = register_diag_field('ocean_model', 'nkml_visc_v', & - diag%axesCv1, Time, 'Number of layers in viscous mixed layer at v points', 'm') + diag%axesCv1, Time, 'Number of layers in viscous mixed layer at v points', 'nondim') endif call register_restart_field_as_obsolete('Kd_turb','Kd_shear', restart_CS) call register_restart_field_as_obsolete('Kv_turb','Kv_shear', restart_CS) - ! Account for possible changes in dimensional scaling for variables that have been - ! read from a restart file. - Z_rescale = 1.0 - if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= US%m_to_Z)) & - Z_rescale = US%m_to_Z / US%m_to_Z_restart - I_T_rescale = 1.0 - if ((US%s_to_T_restart /= 0.0) .and. (US%s_to_T_restart /= US%s_to_T)) & - I_T_rescale = US%s_to_T_restart / US%s_to_T - Z2_T_rescale = Z_rescale**2*I_T_rescale - - if (Z2_T_rescale /= 1.0) then - if (associated(visc%Kd_shear)) then ; if (query_initialized(visc%Kd_shear, "Kd_shear", restart_CS)) then - do k=1,nz+1 ; do j=js,je ; do i=is,ie - visc%Kd_shear(i,j,k) = Z2_T_rescale * visc%Kd_shear(i,j,k) - enddo ; enddo ; enddo - endif ; endif - - if (associated(visc%Kv_shear)) then ; if (query_initialized(visc%Kv_shear, "Kv_shear", restart_CS)) then - do k=1,nz+1 ; do j=js,je ; do i=is,ie - visc%Kv_shear(i,j,k) = Z2_T_rescale * visc%Kv_shear(i,j,k) - enddo ; enddo ; enddo - endif ; endif - - if (associated(visc%Kv_shear_Bu)) then ; if (query_initialized(visc%Kv_shear_Bu, "Kv_shear_Bu", restart_CS)) then - do k=1,nz+1 ; do J=js-1,je ; do I=is-1,ie - visc%Kv_shear_Bu(I,J,k) = Z2_T_rescale * visc%Kv_shear_Bu(I,J,k) - enddo ; enddo ; enddo - endif ; endif - endif - - if (MLE_use_PBL_MLD .and. (Z_rescale /= 1.0)) then - if (associated(visc%MLD)) then ; if (query_initialized(visc%MLD, "MLD", restart_CS)) then - do j=js,je ; do i=is,ie - visc%MLD(i,j) = Z_rescale * visc%MLD(i,j) - enddo ; enddo - endif ; endif - endif - end subroutine set_visc_init !> This subroutine dellocates any memory in the set_visc control structure. @@ -2245,31 +3332,31 @@ subroutine set_visc_end(visc, CS) !! related fields. Elements are deallocated here. type(set_visc_CS), intent(inout) :: CS !< The control structure returned by a previous !! call to set_visc_init. - if (CS%bottomdraglaw) then - deallocate(visc%bbl_thick_u) ; deallocate(visc%bbl_thick_v) - deallocate(visc%kv_bbl_u) ; deallocate(visc%kv_bbl_v) - if (allocated(CS%bbl_u)) deallocate(CS%bbl_u) - if (allocated(CS%bbl_v)) deallocate(CS%bbl_v) - endif - if (CS%Channel_drag) then - deallocate(visc%Ray_u) ; deallocate(visc%Ray_v) - endif - if (CS%dynamic_viscous_ML) then - deallocate(visc%nkml_visc_u) ; deallocate(visc%nkml_visc_v) - endif + + if (allocated(visc%bbl_thick_u)) deallocate(visc%bbl_thick_u) + if (allocated(visc%bbl_thick_v)) deallocate(visc%bbl_thick_v) + if (allocated(visc%kv_bbl_u)) deallocate(visc%kv_bbl_u) + if (allocated(visc%kv_bbl_v)) deallocate(visc%kv_bbl_v) + if (allocated(CS%bbl_u)) deallocate(CS%bbl_u) + if (allocated(CS%bbl_v)) deallocate(CS%bbl_v) + if (allocated(visc%Ray_u)) deallocate(visc%Ray_u) + if (allocated(visc%Ray_v)) deallocate(visc%Ray_v) + if (allocated(visc%nkml_visc_u)) deallocate(visc%nkml_visc_u) + if (allocated(visc%nkml_visc_v)) deallocate(visc%nkml_visc_v) if (associated(visc%Kd_shear)) deallocate(visc%Kd_shear) if (associated(visc%Kv_slow)) deallocate(visc%Kv_slow) if (associated(visc%TKE_turb)) deallocate(visc%TKE_turb) if (associated(visc%Kv_shear)) deallocate(visc%Kv_shear) if (associated(visc%Kv_shear_Bu)) deallocate(visc%Kv_shear_Bu) - if (associated(visc%ustar_bbl)) deallocate(visc%ustar_bbl) - if (associated(visc%TKE_bbl)) deallocate(visc%TKE_bbl) - if (associated(visc%taux_shelf)) deallocate(visc%taux_shelf) - if (associated(visc%tauy_shelf)) deallocate(visc%tauy_shelf) - if (associated(visc%tbl_thick_shelf_u)) deallocate(visc%tbl_thick_shelf_u) - if (associated(visc%tbl_thick_shelf_v)) deallocate(visc%tbl_thick_shelf_v) - if (associated(visc%kv_tbl_shelf_u)) deallocate(visc%kv_tbl_shelf_u) - if (associated(visc%kv_tbl_shelf_v)) deallocate(visc%kv_tbl_shelf_v) + if (allocated(visc%ustar_bbl)) deallocate(visc%ustar_bbl) + if (allocated(visc%BBL_meanKE_loss)) deallocate(visc%BBL_meanKE_loss) + if (allocated(visc%BBL_meanKE_loss_sqrtCd)) deallocate(visc%BBL_meanKE_loss_sqrtCd) + if (allocated(visc%taux_shelf)) deallocate(visc%taux_shelf) + if (allocated(visc%tauy_shelf)) deallocate(visc%tauy_shelf) + if (allocated(visc%tbl_thick_shelf_u)) deallocate(visc%tbl_thick_shelf_u) + if (allocated(visc%tbl_thick_shelf_v)) deallocate(visc%tbl_thick_shelf_v) + if (allocated(visc%kv_tbl_shelf_u)) deallocate(visc%kv_tbl_shelf_u) + if (allocated(visc%kv_tbl_shelf_v)) deallocate(visc%kv_tbl_shelf_v) end subroutine set_visc_end !> \namespace mom_set_visc diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90 index d0d64079c3..f91eeac4f2 100644 --- a/src/parameterizations/vertical/MOM_sponge.F90 +++ b/src/parameterizations/vertical/MOM_sponge.F90 @@ -1,18 +1,21 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Implements sponge regions in isopycnal mode module MOM_sponge -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_coms, only : sum_across_PEs +use MOM_coms, only : sum_across_PEs use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field use MOM_diag_mediator, only : diag_ctrl use MOM_error_handler, only : MOM_error, FATAL, NOTE, WARNING, is_root_pe -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_grid, only : ocean_grid_type +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type use MOM_spatial_means, only : global_i_mean -use MOM_time_manager, only : time_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_verticalGrid, only : verticalGrid_type +use MOM_time_manager, only : time_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type ! Planned extension: Support for time varying sponge targets. @@ -30,11 +33,11 @@ module MOM_sponge !> A structure for creating arrays of pointers to 3D arrays type, public :: p3d - real, dimension(:,:,:), pointer :: p => NULL() !< A pointer to a 3D array + real, dimension(:,:,:), pointer :: p => NULL() !< A pointer to a 3D array [various] end type p3d !> A structure for creating arrays of pointers to 2D arrays type, public :: p2d - real, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2D array + real, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2D array [various] end type p2d !> This control structure holds memory and parameters for the MOM_sponge module @@ -131,7 +134,7 @@ subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, GV, & CS%num_col = 0 ; CS%fldno = 0 do j=G%jsc,G%jec ; do i=G%isc,G%iec - if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) & + if ((Iresttime(i,j) > 0.0) .and. (G%mask2dT(i,j) > 0.0)) & CS%num_col = CS%num_col + 1 enddo ; enddo @@ -143,7 +146,7 @@ subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, GV, & col = 1 do j=G%jsc,G%jec ; do i=G%isc,G%iec - if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) then + if ((Iresttime(i,j) > 0.0) .and. (G%mask2dT(i,j) > 0.0)) then CS%col_i(col) = i ; CS%col_j(col) = j CS%Iresttime_col(col) = Iresttime(i,j) col = col +1 @@ -203,15 +206,15 @@ subroutine set_up_sponge_field(sp_val, f_ptr, G, GV, nlay, CS, sp_val_i_mean) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: sp_val !< The reference profiles of the quantity being registered. + intent(in) :: sp_val !< The reference profiles of the quantity being registered [various] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - target, intent(in) :: f_ptr !< a pointer to the field which will be damped + target, intent(in) :: f_ptr !< a pointer to the field which will be damped [various] integer, intent(in) :: nlay !< the number of layers in this quantity type(sponge_CS), pointer :: CS !< A pointer to the control structure for this module that !! is set by a previous call to initialize_sponge. real, dimension(SZJ_(G),SZK_(GV)),& optional, intent(in) :: sp_val_i_mean !< The i-mean reference value for - !! this field with i-mean sponges. + !! this field with i-mean sponges [various] integer :: j, k, col character(len=256) :: mesg ! String for error messages @@ -221,7 +224,7 @@ subroutine set_up_sponge_field(sp_val, f_ptr, G, GV, nlay, CS, sp_val_i_mean) CS%fldno = CS%fldno + 1 if (CS%fldno > MAX_FIELDS_) then - write(mesg,'("Increase MAX_FIELDS_ to at least ",I3," in MOM_memory.h or decrease & + write(mesg,'("Increase MAX_FIELDS_ to at least ",I0," in MOM_memory.h or decrease & &the number of fields to be damped in the call to & &initialize_sponge." )') CS%fldno call MOM_error(FATAL,"set_up_sponge_field: "//mesg) @@ -240,8 +243,8 @@ subroutine set_up_sponge_field(sp_val, f_ptr, G, GV, nlay, CS, sp_val_i_mean) CS%var(CS%fldno)%p => f_ptr if (nlay/=CS%nz) then - write(mesg,'("Danger: Sponge reference fields require nz (",I3,") layers.& - & A field with ",I3," layers was passed to set_up_sponge_field.")') & + write(mesg,'("Danger: Sponge reference fields require nz (",I0,") layers.& + & A field with ",I0," layers was passed to set_up_sponge_field.")') & CS%nz, nlay if (is_root_pe()) call MOM_error(WARNING, "set_up_sponge_field: "//mesg) endif @@ -273,7 +276,6 @@ subroutine set_up_sponge_ML_density(sp_val, G, CS, sp_val_i_mean) !! layer density [R ~> kg m-3], for use if Iresttime_i_mean > 0. integer :: j, col - character(len=256) :: mesg ! String for error messages if (.not.associated(CS)) return @@ -302,12 +304,14 @@ end subroutine set_up_sponge_ML_density !> This subroutine applies damping to the layers thicknesses, mixed layer buoyancy, and a variety of !! tracers for every column where there is damping. -subroutine apply_sponge(h, dt, G, GV, US, ea, eb, CS, Rcv_ml) +subroutine apply_sponge(h, tv, dt, G, GV, US, ea, eb, CS, Rcv_ml) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables real, intent(in) :: dt !< The amount of time covered by this call [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: ea !< An array to which the amount of fluid entrained @@ -332,11 +336,11 @@ subroutine apply_sponge(h, dt, G, GV, US, ea, eb, CS, Rcv_ml) eta_anom, & ! Anomalies in the interface height, relative to the i-mean ! target value [Z ~> m]. fld_anom ! Anomalies in a tracer concentration, relative to the - ! i-mean target value. + ! i-mean target value [various] real, dimension(SZJ_(G), SZK_(GV)+1) :: & eta_mean_anom ! The i-mean interface height anomalies [Z ~> m]. real, allocatable, dimension(:,:,:) :: & - fld_mean_anom ! THe i-mean tracer concentration anomalies. + fld_mean_anom ! The i-mean tracer concentration anomalies [various] real, dimension(SZI_(G), SZK_(GV)+1) :: & h_above, & ! The total thickness above an interface [H ~> m or kg m-2]. h_below ! The total thickness below an interface [H ~> m or kg m-2]. @@ -345,10 +349,14 @@ subroutine apply_sponge(h, dt, G, GV, US, ea, eb, CS, Rcv_ml) ! give 0 at the surface [nondim]. real :: e(SZK_(GV)+1) ! The interface heights [Z ~> m], usually negative. + real :: dz_to_h(SZK_(GV)+1) ! Factors used to convert interface height movement + ! to thickness fluxes [H Z-1 ~> nondim or kg m-3] real :: e0 ! The height of the free surface [Z ~> m]. real :: e_str ! A nondimensional amount by which the reference ! profile must be stretched for the free surfaces ! heights in the two profiles to agree [nondim]. + real :: w_mean ! The vertical displacement of water moving upward through an + ! interface within 1 timestep [Z ~> m]. real :: w ! The thickness of water moving upward through an ! interface within 1 timestep [H ~> m or kg m-2]. real :: wm ! wm is w if w is negative and 0 otherwise [H ~> m or kg m-2]. @@ -382,9 +390,15 @@ subroutine apply_sponge(h, dt, G, GV, US, ea, eb, CS, Rcv_ml) "work properly with i-mean sponges and a bulk mixed layer.") do j=js,je ; do i=is,ie ; e_D(i,j,nz+1) = -G%bathyT(i,j) ; enddo ; enddo - do k=nz,1,-1 ; do j=js,je ; do i=is,ie - e_D(i,j,K) = e_D(i,j,K+1) + h(i,j,k)*GV%H_to_Z - enddo ; enddo ; enddo + if ((.not.GV%Boussinesq) .and. allocated(tv%SpV_avg)) then + do k=nz,1,-1 ; do j=js,je ; do i=is,ie + e_D(i,j,K) = e_D(i,j,K+1) + GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + enddo ; enddo ; enddo + else + do k=nz,1,-1 ; do j=js,je ; do i=is,ie + e_D(i,j,K) = e_D(i,j,K+1) + h(i,j,k)*GV%H_to_Z + enddo ; enddo ; enddo + endif do j=js,je do i=is,ie dilate(i) = (G%bathyT(i,j) + G%Z_ref) / (e_D(i,j,1) + G%bathyT(i,j)) @@ -422,20 +436,39 @@ subroutine apply_sponge(h, dt, G, GV, US, ea, eb, CS, Rcv_ml) do K=2,nz+1 ; do i=is,ie h_above(i,K) = h_above(i,K-1) + max(h(i,j,k-1)-GV%Angstrom_H, 0.0) enddo ; enddo - do K=2,nz - ! w is positive for an upward (lightward) flux of mass, resulting - ! in the downward movement of an interface. - w = damp_1pdamp * eta_mean_anom(j,K) * GV%Z_to_H - do i=is,ie + + ! In both blocks below, w is positive for an upward (lightward) flux of mass, + ! resulting in the downward movement of an interface. + if ((.not.GV%Boussinesq) .and. allocated(tv%SpV_avg)) then + do K=2,nz + w_mean = damp_1pdamp * eta_mean_anom(j,K) + do i=is,ie + w = w_mean * 2.0*GV%RZ_to_H / (tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i,j,k)) + if (w > 0.0) then + w_int(i,j,K) = min(w, h_below(i,K)) + eb(i,j,k-1) = eb(i,j,k-1) + w_int(i,j,K) + else + w_int(i,j,K) = max(w, -h_above(i,K)) + ea(i,j,k) = ea(i,j,k) - w_int(i,j,K) + endif + enddo + enddo + else + do K=2,nz + w = damp_1pdamp * eta_mean_anom(j,K) * GV%Z_to_H if (w > 0.0) then - w_int(i,j,K) = min(w, h_below(i,K)) - eb(i,j,k-1) = eb(i,j,k-1) + w_int(i,j,K) + do i=is,ie + w_int(i,j,K) = min(w, h_below(i,K)) + eb(i,j,k-1) = eb(i,j,k-1) + w_int(i,j,K) + enddo else - w_int(i,j,K) = max(w, -h_above(i,K)) - ea(i,j,k) = ea(i,j,k) - w_int(i,j,K) + do i=is,ie + w_int(i,j,K) = max(w, -h_above(i,K)) + ea(i,j,k) = ea(i,j,k) - w_int(i,j,K) + enddo endif enddo - enddo + endif do k=1,nz ; do i=is,ie ea_k = max(0.0, -w_int(i,j,K)) eb_k = max(0.0, w_int(i,j,K+1)) @@ -460,9 +493,20 @@ subroutine apply_sponge(h, dt, G, GV, US, ea, eb, CS, Rcv_ml) damp = dt * CS%Iresttime_col(c) e(1) = 0.0 ; e0 = 0.0 - do K=1,nz - e(K+1) = e(K) - h(i,j,k)*GV%H_to_Z - enddo + if ((.not.GV%Boussinesq) .and. allocated(tv%SpV_avg)) then + do K=1,nz + e(K+1) = e(K) - GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + enddo + dz_to_h(1) = GV%RZ_to_H / tv%SpV_avg(i,j,1) + do K=2,nz + dz_to_h(K) = 2.0*GV%RZ_to_H / (tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i,j,k)) + enddo + else + do K=1,nz + e(K+1) = e(K) - h(i,j,k)*GV%H_to_Z + dz_to_h(K) = GV%Z_to_H + enddo + endif e_str = e(nz+1) / CS%Ref_eta(nz+1,c) if ( CS%bulkmixedlayer ) then @@ -476,10 +520,10 @@ subroutine apply_sponge(h, dt, G, GV, US, ea, eb, CS, Rcv_ml) enddo enddo - wpb = 0.0; wb = 0.0 + wpb = 0.0 ; wb = 0.0 do k=nz,nkmb+1,-1 if (GV%Rlay(k) > Rcv_ml(i,j)) then - w = MIN((((e(K)-e0) - e_str*CS%Ref_eta(K,c)) * damp)*GV%Z_to_H, & + w = MIN((((e(K)-e0) - e_str*CS%Ref_eta(K,c)) * damp)*dz_to_h(K), & ((wb + h(i,j,k)) - GV%Angstrom_H)) wm = 0.5*(w-ABS(w)) do m=1,CS%fldno @@ -535,7 +579,7 @@ subroutine apply_sponge(h, dt, G, GV, US, ea, eb, CS, Rcv_ml) wpb = 0.0 wb = 0.0 do k=nz,1,-1 - w = MIN((((e(K)-e0) - e_str*CS%Ref_eta(K,c)) * damp)*GV%Z_to_H, & + w = MIN((((e(K)-e0) - e_str*CS%Ref_eta(K,c)) * damp)*dz_to_h(K), & ((wb + h(i,j,k)) - GV%Angstrom_H)) wm = 0.5*(w - ABS(w)) do m=1,CS%fldno diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index c8166c47b8..21c1c07c7c 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -1,17 +1,20 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Interface to vertical tidal mixing schemes including CVMix tidal mixing. module MOM_tidal_mixing -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_diag_mediator, only : diag_ctrl, time_type, register_diag_field use MOM_diag_mediator, only : safe_alloc_ptr, post_data +use MOM_diagnose_Kdwork, only : vbf_CS use MOM_debugging, only : hchksum -use MOM_EOS, only : calculate_density use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE use MOM_file_parser, only : openParameterBlock, closeParameterBlock use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_io, only : slasher, MOM_read_data, field_size +use MOM_io, only : read_netCDF_data use MOM_internal_tides, only : int_tide_CS, get_lowmode_loss use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h use MOM_string_functions, only : uppercase, lowercase @@ -43,27 +46,29 @@ module MOM_tidal_mixing !> Containers for tidal mixing diagnostics type, public :: tidal_mixing_diags ; private - real, allocatable :: Kd_itidal(:,:,:) !< internal tide diffusivity at interfaces [Z2 T-1 ~> m2 s-1]. - real, allocatable :: Fl_itidal(:,:,:) !< vertical flux of tidal turbulent dissipation [Z3 T-3 ~> m3 s-3] - real, allocatable :: Kd_Niku(:,:,:) !< lee-wave diffusivity at interfaces [Z2 T-1 ~> m2 s-1]. + real, allocatable :: Kd_itidal(:,:,:) !< internal tide diffusivity at interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, allocatable :: Fl_itidal(:,:,:) !< vertical flux of tidal turbulent dissipation + !! [H Z2 T-3 ~> m3 s-3 or W m-2] + real, allocatable :: Kd_Niku(:,:,:) !< lee-wave diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, allocatable :: Kd_Niku_work(:,:,:) !< layer integrated work by lee-wave driven mixing [R Z3 T-3 ~> W m-2] real, allocatable :: Kd_Itidal_Work(:,:,:) !< layer integrated work by int tide driven mixing [R Z3 T-3 ~> W m-2] real, allocatable :: Kd_Lowmode_Work(:,:,:) !< layer integrated work by low mode driven mixing [R Z3 T-3 ~> W m-2] - real, allocatable :: N2_int(:,:,:) !< Bouyancy frequency squared at interfaces [T-2 ~> s-2] - real, allocatable :: vert_dep_3d(:,:,:) !< The 3-d mixing energy deposition [W m-3] - real, allocatable :: Schmittner_coeff_3d(:,:,:) !< The coefficient in the Schmittner et al mixing scheme, in UNITS? + real, allocatable :: N2_int(:,:,:) !< Buoyancy frequency squared at interfaces [T-2 ~> s-2] + real, allocatable :: vert_dep_3d(:,:,:) !< The 3-d mixing energy deposition vertical fraction [nondim]? + real, allocatable :: Schmittner_coeff_3d(:,:,:) !< The coefficient in the Schmittner et al mixing scheme [nondim] real, allocatable :: tidal_qe_md(:,:,:) !< Input tidal energy dissipated locally, - !! interpolated to model vertical coordinate [W m-3?] + !! interpolated to model vertical coordinate [R Z3 T-3 ~> W m-2] real, allocatable :: Kd_lowmode(:,:,:) !< internal tide diffusivity at interfaces - !! due to propagating low modes [Z2 T-1 ~> m2 s-1]. + !! due to propagating low modes [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, allocatable :: Fl_lowmode(:,:,:) !< vertical flux of tidal turbulent - !! dissipation due to propagating low modes [Z3 T-3 ~> m3 s-3] + !! dissipation due to propagating low modes [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable :: TKE_itidal_used(:,:) !< internal tide TKE input at ocean bottom [R Z3 T-3 ~> W m-2] real, allocatable :: N2_bot(:,:) !< bottom squared buoyancy frequency [T-2 ~> s-2] real, allocatable :: N2_meanz(:,:) !< vertically averaged buoyancy frequency [T-2 ~> s-2] - real, allocatable :: Polzin_decay_scale_scaled(:,:) !< vertical scale of decay for tidal dissipation [Z ~> m] - real, allocatable :: Polzin_decay_scale(:,:) !< vertical decay scale for tidal diss with Polzin [Z ~> m] - real, allocatable :: Simmons_coeff_2d(:,:) !< The Simmons et al mixing coefficient + real, allocatable :: Polzin_decay_scale_scaled(:,:) !< Vertical scale of decay for tidal dissipation [Z ~> m] + real, allocatable :: Polzin_decay_scale(:,:) !< Vertical decay scale for tidal dissipation with Polzin [Z ~> m] + real, allocatable :: Simmons_coeff_2d(:,:) !< The Simmons et al mixing coefficient [nondim] end type !> Control structure with parameters for the tidal mixing module. @@ -86,7 +91,7 @@ module MOM_tidal_mixing !! for dissipation of the lee waves. Schemes that are !! currently encoded are St Laurent et al (2002) and !! Polzin (2009). - real :: Int_tide_decay_scale !< decay scale for internal wave TKE [Z ~> m]. + real :: Int_tide_decay_scale !< decay scale for internal wave TKE [Z ~> m] real :: Mu_itides !< efficiency for conversion of dissipation !! to potential energy [nondim] @@ -117,54 +122,58 @@ module MOM_tidal_mixing !! profile in Polzin formulation should not exceed !! Polzin_decay_scale_max_factor * depth of the ocean [nondim]. real :: Polzin_min_decay_scale !< minimum decay scale of the tidal dissipation - !! profile in Polzin formulation [Z ~> m]. + !! profile in Polzin formulation [Z ~> m] real :: TKE_itide_max !< maximum internal tide conversion [R Z3 T-3 ~> W m-2] !! available to mix above the BBL real :: utide !< constant tidal amplitude [Z T-1 ~> m s-1] if READ_TIDEAMP is false. real :: kappa_itides !< topographic wavenumber and non-dimensional scaling [Z-1 ~> m-1]. - real :: kappa_h2_factor !< factor for the product of wavenumber * rms sgs height + real :: kappa_h2_factor !< factor for the product of wavenumber * rms sgs height [nondim] character(len=200) :: inputdir !< The directory in which to find input files logical :: use_CVMix_tidal = .false. !< true if CVMix is to be used for determining !! diffusivity due to tidal mixing - real :: min_thickness !< Minimum thickness allowed [m] + real :: min_thickness !< Minimum thickness allowed [Z ~> m] ! CVMix-specific parameters integer :: CVMix_tidal_scheme = -1 !< 1 for Simmons, 2 for Schmittner type(CVMix_tidal_params_type) :: CVMix_tidal_params !< A CVMix-specific type with parameters for tidal mixing type(CVMix_global_params_type) :: CVMix_glb_params !< CVMix-specific for Prandtl number only - real :: tidal_max_coef !< CVMix-specific maximum allowable tidal diffusivity. [m^2/s] + real :: tidal_max_coef !< CVMix-specific maximum allowable tidal + !! diffusivity. [Z2 T-1 ~> m2 s-1] real :: tidal_diss_lim_tc !< CVMix-specific dissipation limit depth for !! tidal-energy-constituent data [Z ~> m]. type(remapping_CS) :: remap_CS !< The control structure for remapping - logical :: remap_answers_2018 = .true. !< If true, use the order of arithmetic and expressions that - !! recover the remapping answers from 2018. If false, use more - !! robust forms of the same remapping expressions. + integer :: 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. + integer :: tidal_answer_date !< The vintage of the order of arithmetic and expressions in the tidal + !! mixing 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. type(int_tide_CS), pointer :: int_tide_CSp=> NULL() !< Control structure for a child module ! Data containers real, allocatable :: TKE_Niku(:,:) !< Lee wave driven Turbulent Kinetic Energy input !! [R Z3 T-3 ~> W m-2] - real, allocatable :: TKE_itidal(:,:) !< The internal Turbulent Kinetic Energy input divided - !! by the bottom stratfication [R Z3 T-2 ~> J m-2]. + real, allocatable :: TKE_itidal(:,:) !< The internal Turbulent Kinetic Energy input divided by + !! the bottom stratification and in non-Boussinesq mode by + !! the near-bottom density [R Z4 H-1 T-2 ~> J m-2 or J m kg-1] real, allocatable :: Nb(:,:) !< The near bottom buoyancy frequency [T-1 ~> s-1]. - real, allocatable :: mask_itidal(:,:) !< A mask of where internal tide energy is input + real, allocatable :: mask_itidal(:,:) !< A mask of where internal tide energy is input [nondim] real, allocatable :: h2(:,:) !< Squared bottom depth variance [Z2 ~> m2]. real, allocatable :: tideamp(:,:) !< RMS tidal amplitude [Z T-1 ~> m s-1] real, allocatable :: h_src(:) !< tidal constituent input layer thickness [m] real, allocatable :: tidal_qe_2d(:,:) !< Tidal energy input times the local dissipation !! fraction, q*E(x,y), with the CVMix implementation - !! of Jayne et al tidal mixing [W m-2]. + !! of Jayne et al tidal mixing [R Z3 T-3 ~> W m-2]. !! TODO: make this E(x,y) only - real, allocatable :: tidal_qe_3d_in(:,:,:) !< q*E(x,y,z) with the Schmittner parameterization [W m-3?] + real, allocatable :: tidal_qe_3d_in(:,:,:) !< q*E(x,y,z) with the Schmittner parameterization [R Z3 T-3 ~> W m-2] - logical :: answers_2018 !< If true, use the order of arithmetic and expressions that recover the - !! answers from the end of 2018. Otherwise, use updated and more robust - !! forms of the same expressions. ! Diagnostics type(diag_ctrl), pointer :: diag => NULL() !< structure to regulate diagnostic output timing @@ -215,7 +224,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Run-time parameter file handle - type(int_tide_CS),target, intent(in) :: int_tide_CSp !< A pointer to the internal tides control structure + type(int_tide_CS), pointer :: int_tide_CSp !< A pointer to the internal tides control structure type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure. type(tidal_mixing_cs), intent(inout) :: CS !< This module's control structure. @@ -223,13 +232,18 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di logical :: use_CVMix_tidal logical :: int_tide_dissipation logical :: read_tideamp - logical :: default_2018_answers + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. character(len=20) :: tmpstr, int_tide_profile_str character(len=20) :: CVMix_tidal_scheme_str, tidal_energy_type - character(len=200) :: filename, h2_file, Niku_TKE_input_file - character(len=200) :: tidal_energy_file, tideamp_file - real :: utide, hamp, prandtl_tidal, max_frac_rough - real :: Niku_scale ! local variable for scaling the Nikurashin TKE flux data + character(len=200) :: filename, h2_file, Niku_TKE_input_file ! Input file names + character(len=200) :: tideamp_file ! Input file names or paths + character(len=80) :: tideamp_var, rough_var, TKE_input_var ! Input file variable names + real :: hamp ! The magnitude of the sub-gridscale bottom depth variance [Z ~> m] + real :: utide ! The RMS tidal amplitude [Z T-1 ~> m s-1] + real :: max_frac_rough ! A limit on the depth variance as a fraction of the total depth [nondim] + real :: prandtl_tidal ! Prandtl number used by CVMix tidal mixing schemes to convert vertical + ! diffusivities into viscosities [nondim] + real :: Niku_scale ! local variable for scaling the Nikurashin TKE flux data [nondim] integer :: i, j, is, ie, js, je integer :: isd, ied, jsd, jed @@ -265,24 +279,30 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di CS%debug = CS%debug.and.is_root_pe() CS%diag => diag - CS%int_tide_CSp => int_tide_CSp + if (associated(int_tide_CSp)) CS%int_tide_CSp => int_tide_CSp CS%use_CVmix_tidal = use_CVmix_tidal CS%int_tide_dissipation = int_tide_dissipation call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, default=".",do_not_log=.true.) CS%inputdir = slasher(CS%inputdir) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) - call get_param(param_file, mdl, "TIDAL_MIXING_2018_ANSWERS", CS%answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", CS%remap_answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "TIDAL_MIXING_ANSWER_DATE", CS%tidal_answer_date, & + "The vintage of the order of arithmetic and expressions in the tidal mixing "//& + "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%tidal_answer_date = max(CS%tidal_answer_date, 20230701) + + call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%remap_answer_date, & + "The vintage of the expressions and order of arithmetic to use for remapping. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%remap_answer_date = max(CS%remap_answer_date, 20230701) if (CS%int_tide_dissipation) then @@ -308,7 +328,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di endif ! CS%use_CVMix_tidal ! Read in vertical profile of tidal energy dissipation - if ( CS%CVMix_tidal_scheme.eq.SCHMITTNER .or. .not. CS%use_CVMix_tidal) then + if ( CS%CVMix_tidal_scheme == SCHMITTNER .or. .not. CS%use_CVMix_tidal) then call get_param(param_file, mdl, "INT_TIDE_PROFILE", int_tide_profile_str, & "INT_TIDE_PROFILE selects the vertical profile of energy "//& "dissipation with INT_TIDE_DISSIPATION. Valid values are:\n"//& @@ -407,8 +427,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di call get_param(param_file, mdl, "INT_TIDE_DECAY_SCALE", CS%Int_tide_decay_scale, & "The decay scale away from the bottom for tidal TKE with "//& "the new coding when INT_TIDE_DISSIPATION is used.", & - !units="m", default=0.0) - units="m", default=500.0, scale=US%m_to_Z) ! TODO: confirm this new default + units="m", default=500.0, scale=US%m_to_Z) call get_param(param_file, mdl, "MU_ITIDES", CS%Mu_itides, & "A dimensionless turbulent mixing efficiency used with "//& "INT_TIDE_DISSIPATION, often 0.2.", units="nondim", default=0.2) @@ -461,7 +480,13 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di "tidal amplitudes with INT_TIDE_DISSIPATION.", default="tideamp.nc") filename = trim(CS%inputdir) // trim(tideamp_file) call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) - call MOM_read_data(filename, 'tideamp', CS%tideamp, G%domain, scale=US%m_to_Z*US%T_to_s) + call get_param(param_file, mdl, "TIDEAMP_VARNAME", tideamp_var, & + "The name of the tidal amplitude variable in the input file.", & + default="tideamp") + ! NOTE: There are certain cases where FMS is unable to read this file, so + ! we use read_netCDF_data in place of MOM_read_data. + call read_netCDF_data(filename, tideamp_var, CS%tideamp, G%domain, & + rescale=US%m_to_Z*US%T_to_s) endif call get_param(param_file, mdl, "H2_FILE", h2_file, & @@ -470,7 +495,13 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di fail_if_missing=(.not.CS%use_CVMix_tidal)) filename = trim(CS%inputdir) // trim(h2_file) call log_param(param_file, mdl, "INPUTDIR/H2_FILE", filename) - call MOM_read_data(filename, 'h2', CS%h2, G%domain, scale=US%m_to_Z**2) + call get_param(param_file, mdl, "ROUGHNESS_VARNAME", rough_var, & + "The name in the input file of the squared sub-grid-scale "//& + "topographic roughness amplitude variable.", default="h2") + ! NOTE: There are certain cases where FMS is unable to read this file, so + ! we use read_netCDF_data in place of MOM_read_data. + call read_netCDF_data(filename, rough_var, CS%h2, G%domain, & + rescale=US%m_to_Z**2) call get_param(param_file, mdl, "FRACTIONAL_ROUGHNESS_MAX", max_frac_rough, & "The maximum topographic roughness amplitude as a fraction of the mean depth, "//& @@ -478,22 +509,22 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di units="nondim", default=0.1) do j=js,je ; do i=is,ie - if (G%bathyT(i,j)+G%Z_ref < CS%min_zbot_itides) CS%mask_itidal(i,j) = 0.0 + if (max(G%meanSL(i,j) + G%bathyT(i,j), 0.0) < CS%min_zbot_itides) CS%mask_itidal(i,j) = 0.0 CS%tideamp(i,j) = CS%tideamp(i,j) * CS%mask_itidal(i,j) * G%mask2dT(i,j) ! Restrict rms topo to a fraction (often 10 percent) of the column depth. - if (CS%answers_2018 .and. (max_frac_rough >= 0.0)) then - hamp = min(max_frac_rough*(G%bathyT(i,j)+G%Z_ref), sqrt(CS%h2(i,j))) + if ((CS%tidal_answer_date < 20190101) .and. (max_frac_rough >= 0.0)) then + hamp = min(max_frac_rough * max(G%meanSL(i,j) + G%bathyT(i,j), 0.0), sqrt(CS%h2(i,j))) CS%h2(i,j) = hamp*hamp else if (max_frac_rough >= 0.0) & - CS%h2(i,j) = min((max_frac_rough*(G%bathyT(i,j)+G%Z_ref))**2, CS%h2(i,j)) + CS%h2(i,j) = min((max_frac_rough * max(G%meanSL(i,j) + G%bathyT(i,j), 0.0))**2, CS%h2(i,j)) endif utide = CS%tideamp(i,j) ! Compute the fixed part of internal tidal forcing. - ! The units here are [R Z3 T-2 ~> J m-2 = kg s-2] here. - CS%TKE_itidal(i,j) = 0.5 * CS%kappa_h2_factor * GV%Rho0 * & + ! The units here are [R Z4 H-1 T-2 ~> J m-2 or m3 s-2] here. (Note that J m-2 = kg s-2.) + CS%TKE_itidal(i,j) = 0.5 * CS%kappa_h2_factor * GV%H_to_RZ * & CS%kappa_itides * CS%h2(i,j) * utide*utide enddo ; enddo @@ -501,30 +532,31 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di if (CS%Lee_wave_dissipation) then - call get_param(param_file, mdl, "NIKURASHIN_TKE_INPUT_FILE",Niku_TKE_input_file, & + call get_param(param_file, mdl, "NIKURASHIN_TKE_INPUT_FILE", Niku_TKE_input_file, & "The path to the file containing the TKE input from lee "//& "wave driven mixing. Used with LEE_WAVE_DISSIPATION.", & fail_if_missing=.true.) - call get_param(param_file, mdl, "NIKURASHIN_SCALE",Niku_scale, & + call get_param(param_file, mdl, "NIKURASHIN_SCALE", Niku_scale, & "A non-dimensional factor by which to scale the lee-wave "//& "driven TKE input. Used with LEE_WAVE_DISSIPATION.", & units="nondim", default=1.0) filename = trim(CS%inputdir) // trim(Niku_TKE_input_file) - call log_param(param_file, mdl, "INPUTDIR/NIKURASHIN_TKE_INPUT_FILE", & - filename) + call log_param(param_file, mdl, "INPUTDIR/NIKURASHIN_TKE_INPUT_FILE", filename) + call get_param(param_file, mdl, "TKE_INPUT_VAR", TKE_input_var, & + "The name in the input file of the turbulent kinetic energy input variable.", & + default="TKE_input") allocate(CS%TKE_Niku(is:ie,js:je), source=0.) - call MOM_read_data(filename, 'TKE_input', CS%TKE_Niku, G%domain, timelevel=1, & ! ??? timelevel -aja + + call MOM_read_data(filename, TKE_input_var, CS%TKE_Niku, G%domain, timelevel=1, & ! ??? timelevel -aja scale=Niku_scale*US%W_m2_to_RZ3_T3) call get_param(param_file, mdl, "GAMMA_NIKURASHIN",CS%Gamma_lee, & "The fraction of the lee wave energy that is dissipated "//& - "locally with LEE_WAVE_DISSIPATION.", units="nondim", & - default=0.3333) + "locally with LEE_WAVE_DISSIPATION.", units="nondim", default=0.3333) call get_param(param_file, mdl, "DECAY_SCALE_FACTOR_LEE",CS%Decay_scale_factor_lee, & - "Scaling for the vertical decay scaleof the local "//& - "dissipation of lee waves dissipation.", units="nondim", & - default=1.0) + "Scaling for the vertical decay scale of the local "//& + "dissipation of lee wave dissipation.", units="nondim", default=1.0) else CS%Decay_scale_factor_lee = -9.e99 ! This should never be used if CS%Lee_wave_dissipation = False endif @@ -536,25 +568,19 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di !call openParameterBlock(param_file,'CVMix_TIDAL') call get_param(param_file, mdl, "TIDAL_MAX_COEF", CS%tidal_max_coef, & "largest acceptable value for tidal diffusivity", & - units="m^2/s", default=50e-4) ! the default is 50e-4 in CVMix, 100e-4 in POP. + units="m^2/s", default=50e-4, scale=US%m2_s_to_Z2_T) ! the default is 50e-4 in CVMix, 100e-4 in POP. call get_param(param_file, mdl, "TIDAL_DISS_LIM_TC", CS%tidal_diss_lim_tc, & "Min allowable depth for dissipation for tidal-energy-constituent data. "//& "No dissipation contribution is applied above TIDAL_DISS_LIM_TC.", & units="m", default=0.0, scale=US%m_to_Z) - call get_param(param_file, mdl, "TIDAL_ENERGY_FILE",tidal_energy_file, & - "The path to the file containing tidal energy "//& - "dissipation. Used with CVMix tidal mixing schemes.", & - fail_if_missing=.true.) - call get_param(param_file, mdl, 'MIN_THICKNESS', CS%min_thickness, default=0.001, & - do_not_log=.True.) + call get_param(param_file, mdl, 'MIN_THICKNESS', CS%min_thickness, & + units="m", default=0.001, scale=US%m_to_Z, do_not_log=.True.) call get_param(param_file, mdl, "PRANDTL_TIDAL", prandtl_tidal, & "Prandtl number used by CVMix tidal mixing schemes "//& "to convert vertical diffusivities into viscosities.", & - units="nondim", default=1.0, & - do_not_log=.true.) - call CVMix_put(CS%CVMix_glb_params,'Prandtl',prandtl_tidal) + units="nondim", default=1.0, do_not_log=.true.) + call CVMix_put(CS%CVMix_glb_params, 'Prandtl', prandtl_tidal) - tidal_energy_file = trim(CS%inputdir) // trim(tidal_energy_file) call get_param(param_file, mdl, "TIDAL_ENERGY_TYPE",tidal_energy_type, & "The type of input tidal energy flux dataset. Valid values are"//& "\t Jayne\n"//& @@ -562,8 +588,8 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di fail_if_missing=.true.) ! Check whether tidal energy input format and CVMix tidal mixing scheme are consistent if ( .not. ( & - (uppercase(tidal_energy_type(1:4)).eq.'JAYN' .and. CS%CVMix_tidal_scheme.eq.SIMMONS).or. & - (uppercase(tidal_energy_type(1:4)).eq.'ER03' .and. CS%CVMix_tidal_scheme.eq.SCHMITTNER) ) )then + (uppercase(tidal_energy_type(1:4)) == 'JAYN' .and. CS%CVMix_tidal_scheme == SIMMONS).or. & + (uppercase(tidal_energy_type(1:4)) == 'ER03' .and. CS%CVMix_tidal_scheme == SCHMITTNER) ) )then call MOM_error(FATAL, "tidal_mixing_init: Tidal energy file type ("//& trim(tidal_energy_type)//") is incompatible with CVMix tidal "//& " mixing scheme: "//trim(CVMix_tidal_scheme_str) ) @@ -575,11 +601,11 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di mix_scheme = CVMix_tidal_scheme_str, & efficiency = CS%Mu_itides, & vertical_decay_scale = CS%int_tide_decay_scale*US%Z_to_m, & - max_coefficient = CS%tidal_max_coef, & + max_coefficient = CS%tidal_max_coef*US%Z2_T_to_m2_s, & 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, tidal_energy_file, CS) + call read_tidal_energy(G, GV, US, tidal_energy_type, param_file, CS) !call closeParameterBlock(param_file) @@ -591,21 +617,24 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di CS%Lowmode_itidal_dissipation) then CS%id_Kd_itidal = register_diag_field('ocean_model','Kd_itides',diag%axesTi,Time, & - 'Internal Tide Driven Diffusivity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Internal Tide Driven Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) if (CS%use_CVMix_tidal) then CS%id_N2_int = register_diag_field('ocean_model','N2_int',diag%axesTi,Time, & 'Bouyancy frequency squared, at interfaces', 's-2', conversion=US%s_to_T**2) !> TODO: add units - CS%id_Simmons_coeff = register_diag_field('ocean_model','Simmons_coeff',diag%axesT1,Time, & - 'time-invariant portion of the tidal mixing coefficient using the Simmons', '') - CS%id_Schmittner_coeff = register_diag_field('ocean_model','Schmittner_coeff',diag%axesTL,Time, & - 'time-invariant portion of the tidal mixing coefficient using the Schmittner', '') - CS%id_tidal_qe_md = register_diag_field('ocean_model','tidal_qe_md',diag%axesTL,Time, & - 'input tidal energy dissipated locally interpolated to model vertical coordinates', '') + if (CS%CVMix_tidal_scheme .eq. SIMMONS) then + CS%id_Simmons_coeff = register_diag_field('ocean_model','Simmons_coeff',diag%axesT1,Time, & + 'time-invariant portion of the tidal mixing coefficient using the Simmons', '') + else if (CS%CVMix_tidal_scheme .eq. SCHMITTNER) then + CS%id_Schmittner_coeff = register_diag_field('ocean_model','Schmittner_coeff',diag%axesTL,Time, & + 'time-invariant portion of the tidal mixing coefficient using the Schmittner', '') + CS%id_tidal_qe_md = register_diag_field('ocean_model','tidal_qe_md',diag%axesTL,Time, & + 'input tidal energy dissipated locally interpolated to model vertical coordinates', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2) + endif CS%id_vert_dep = register_diag_field('ocean_model','vert_dep',diag%axesTi,Time, & 'vertical deposition function needed for Simmons et al tidal mixing', '') - else CS%id_TKE_itidal = register_diag_field('ocean_model','TKE_itidal',diag%axesT1,Time, & 'Internal Tide Driven Turbulent Kinetic Energy', & @@ -615,24 +644,24 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di CS%id_Kd_lowmode = register_diag_field('ocean_model','Kd_lowmode',diag%axesTi,Time, & 'Internal Tide Driven Diffusivity (from propagating low modes)', & - 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'm2 s-1', conversion=GV%HZ_T_to_m2_s) CS%id_Fl_itidal = register_diag_field('ocean_model','Fl_itides',diag%axesTi,Time, & 'Vertical flux of tidal turbulent dissipation', & - 'm3 s-3', conversion=(US%Z_to_m**3*US%s_to_T**3)) + 'm3 s-3', conversion=(GV%H_to_m*US%Z_to_m**2*US%s_to_T**3)) CS%id_Fl_lowmode = register_diag_field('ocean_model','Fl_lowmode',diag%axesTi,Time, & 'Vertical flux of tidal turbulent dissipation (from propagating low modes)', & - 'm3 s-3', conversion=(US%Z_to_m**3*US%s_to_T**3)) + 'm3 s-3', conversion=(GV%H_to_m*US%Z_to_m**2*US%s_to_T**3)) - CS%id_Polzin_decay_scale = register_diag_field('ocean_model','Polzin_decay_scale',diag%axesT1,Time, & + CS%id_Polzin_decay_scale = register_diag_field('ocean_model','Polzin_decay_scale', diag%axesT1, Time, & 'Vertical decay scale for the tidal turbulent dissipation with Polzin scheme', & - 'm', conversion=US%Z_to_m) + units='m', conversion=US%Z_to_m) CS%id_Polzin_decay_scale_scaled = register_diag_field('ocean_model', & 'Polzin_decay_scale_scaled', diag%axesT1, Time, & 'Vertical decay scale for the tidal turbulent dissipation with Polzin scheme, '// & - 'scaled by N2_bot/N2_meanz', 'm', conversion=US%Z_to_m) + 'scaled by N2_bot/N2_meanz', units='m', conversion=US%Z_to_m) CS%id_N2_bot = register_diag_field('ocean_model','N2_b',diag%axesT1,Time, & 'Bottom Buoyancy frequency squared', 's-2', conversion=US%s_to_T**2) @@ -657,7 +686,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di 'Lee wave Driven Turbulent Kinetic Energy', & 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_Kd_Niku = register_diag_field('ocean_model','Kd_Nikurashin',diag%axesTi,Time, & - 'Lee Wave Driven Diffusivity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Lee Wave Driven Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) endif endif ! S%use_CVMix_tidal endif @@ -668,16 +697,16 @@ end function tidal_mixing_init !> Depending on whether or not CVMix is active, calls the associated subroutine to compute internal !! tidal dissipation and to add the effect of internal-tide-driven mixing to the layer or interface !! diffusivities. -subroutine calculate_tidal_mixing(h, j, N2_bot, N2_lay, N2_int, TKE_to_Kd, max_TKE, & - G, GV, US, CS, Kd_max, Kv, Kd_lay, Kd_int) +subroutine calculate_tidal_mixing(dz, j, N2_bot, Rho_bot, N2_lay, N2_int, TKE_to_Kd, max_TKE, & + G, GV, US, CS, Kd_max, Kv, Kd_lay, Kd_int, VBF) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: dz !< The vertical distance across layers [Z ~> m] integer, intent(in) :: j !< The j-index to work on real, dimension(SZI_(G)), intent(in) :: N2_bot !< The near-bottom squared buoyancy !! frequency [T-2 ~> s-2]. + real, dimension(SZI_(G)), intent(in) :: Rho_bot !< The near-bottom in situ density [R ~> kg m-3] real, dimension(SZI_(G),SZK_(GV)), intent(in) :: N2_lay !< The squared buoyancy frequency of the !! layers [T-2 ~> s-2]. real, dimension(SZI_(G),SZK_(GV)+1), intent(in) :: N2_int !< The squared buoyancy frequency at the @@ -686,28 +715,31 @@ subroutine calculate_tidal_mixing(h, j, N2_bot, N2_lay, N2_int, TKE_to_Kd, max_T !! dissipated within a layer and the !! diapycnal diffusivity within that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) - !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] - real, dimension(SZI_(G),SZK_(GV)), intent(in) :: max_TKE !< The energy required to for a layer to entrain - !! to its maximum realizable thickness [Z3 T-3 ~> m3 s-3] + !! [T2 Z-1 ~> s2 m-1] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: max_TKE !< The energy required for a layer to + !! entrain to its maximum realizable + !! thickness [H Z2 T-3 ~> m3 s-3 or W m-2] type(tidal_mixing_cs), intent(inout) :: CS !< The control structure for this module real, intent(in) :: Kd_max !< The maximum increment for diapycnal !! diffusivity due to TKE-based processes, - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] !! Set this to a negative value to have no limit. real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface - !! (not layer!) [Z2 T-1 ~> m2 s-1]. + !! (not layer!) [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZI_(G),SZK_(GV)), & - optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers [Z2 T-1 ~> m2 s-1]. + optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZK_(GV)+1), & - optional, intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces, - !! [Z2 T-1 ~> m2 s-1]. + optional, intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + type(vbf_CS), pointer :: VBF !< A diagnostic structure for vertical buoyancy fluxes if (CS%Int_tide_dissipation .or. CS%Lee_wave_dissipation .or. CS%Lowmode_itidal_dissipation) then if (CS%use_CVMix_tidal) then - call calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int) + call calculate_CVMix_tidal(dz, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int) else - call add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & - G, GV, US, CS, Kd_max, Kd_lay, Kd_int) + call add_int_tide_diffusivity(dz, j, N2_bot, Rho_bot, N2_lay, TKE_to_Kd, max_TKE, & + G, GV, US, CS, Kd_max, Kd_lay, Kd_int, VBF) endif endif end subroutine calculate_tidal_mixing @@ -715,38 +747,46 @@ end subroutine calculate_tidal_mixing !> Calls the CVMix routines to compute tidal dissipation and to add the effect of internal-tide-driven !! mixing to the interface diffusivities. -subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int) +subroutine calculate_CVMix_tidal(dz, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int) type(ocean_grid_type), intent(in) :: G !< Grid structure. type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(tidal_mixing_cs), intent(inout) :: CS !< This module's control structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: dz !< The vertical distance across layers [Z ~> m] integer, intent(in) :: j !< The j-index to work on real, dimension(SZI_(G),SZK_(GV)+1), intent(in) :: N2_int !< The squared buoyancy !! frequency at the interfaces [T-2 ~> s-2]. real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface - !! (not layer!) [Z2 T-1 ~> m2 s-1]. + !! (not layer!) [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZI_(G),SZK_(GV)), & - optional, intent(inout) :: Kd_lay!< The diapycnal diffusivity in the layers [Z2 T-1 ~> m2 s-1]. + optional, intent(inout) :: Kd_lay!< The diapycnal diffusivity in the layers + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZI_(G),SZK_(GV)+1), & - optional, intent(inout) :: Kd_int!< The diapycnal diffusivity at interfaces [Z2 T-1 ~> m2 s-1]. + optional, intent(inout) :: Kd_int!< The diapycnal diffusivity at interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. ! Local variables real, dimension(SZK_(GV)+1) :: Kd_tidal ! tidal diffusivity [m2 s-1] real, dimension(SZK_(GV)+1) :: Kv_tidal ! tidal viscosity [m2 s-1] - real, dimension(SZK_(GV)+1) :: vert_dep ! vertical deposition + real, dimension(SZK_(GV)+1) :: vert_dep ! vertical deposition [nondim] real, dimension(SZK_(GV)+1) :: iFaceHeight ! Height of interfaces [m] - real, dimension(SZK_(GV)+1) :: SchmittnerSocn + real, dimension(SZK_(GV)+1) :: SchmittnerSocn ! A larger value of the Schmittner coefficint to + ! use in the Southern Ocean [nondim]. If this is smaller + ! than Schmittner_coeff, that standard value is used. real, dimension(SZK_(GV)) :: cellHeight ! Height of cell centers [m] real, dimension(SZK_(GV)) :: tidal_qe_md ! Tidal dissipation energy interpolated from 3d input - ! to model coordinates + ! to model coordinates [R Z3 T-3 ~> W m-2] real, dimension(SZK_(GV)+1) :: N2_int_i ! De-scaled interface buoyancy frequency [s-2] - real, dimension(SZK_(GV)) :: Schmittner_coeff + real, dimension(SZK_(GV)) :: Schmittner_coeff ! A coefficient in the Schmittner et al (2014) mixing + ! parameterization [nondim] real, dimension(SZK_(GV)) :: h_m ! Cell thickness [m] - real, allocatable, dimension(:,:) :: exp_hab_zetar + real, allocatable, dimension(:,:) :: exp_hab_zetar ! A badly documented array that appears to be + ! related to the distribution of tidal mixing energy, with unusual array + ! extents that are not explained, that is set and used by the CVMix + ! tidal mixing schemes, perhaps in [m3 kg-1]? + real :: dh, hcorr ! Limited thicknesses and a cumulative correction [Z ~> m] + real :: Simmons_coeff ! A coefficient in the Simmons et al (2004) mixing parameterization [nondim] integer :: i, k, is, ie - real :: dh, hcorr, Simmons_coeff real, parameter :: rho_fw = 1000.0 ! fresh water density [kg m-3] ! TODO: when coupled, get this from CESM (SHR_CONST_RHOFW) @@ -760,18 +800,18 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int iFaceHeight = 0.0 ! BBL is all relative to the surface hcorr = 0.0 + ! Compute cell center depth and cell bottom in meters (negative values in the ocean) do k=1,GV%ke - ! cell center and cell bottom in meters (negative values in the ocean) - dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment, rescaled to m for use by CVMix. + dh = dz(i,k) ! Nominal thickness to use for increment, in the units of heights dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 - dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness - cellHeight(k) = iFaceHeight(k) - 0.5 * dh - iFaceHeight(k+1) = iFaceHeight(k) - dh + dh = max(dh, CS%min_thickness) ! Limited increment dh>=min_thickness + cellHeight(k) = iFaceHeight(k) - 0.5 * US%Z_to_m*dh + iFaceHeight(k+1) = iFaceHeight(k) - US%Z_to_m*dh enddo call CVMix_compute_Simmons_invariant( nlev = GV%ke, & - energy_flux = CS%tidal_qe_2d(i,j), & + energy_flux = US%RZ3_T3_to_W_m2*CS%tidal_qe_2d(i,j), & rho = rho_fw, & SimmonsCoeff = Simmons_coeff, & VertDep = vert_dep, & @@ -804,24 +844,24 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int ! Update diffusivity if (present(Kd_lay)) then do k=1,GV%ke - Kd_lay(i,k) = Kd_lay(i,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_tidal(k) + Kd_tidal(k+1)) + Kd_lay(i,k) = Kd_lay(i,k) + 0.5 * GV%m2_s_to_HZ_T * (Kd_tidal(k) + Kd_tidal(k+1)) enddo endif if (present(Kd_int)) then do K=1,GV%ke+1 - Kd_int(i,K) = Kd_int(i,K) + (US%m2_s_to_Z2_T * Kd_tidal(K)) + Kd_int(i,K) = Kd_int(i,K) + GV%m2_s_to_HZ_T * Kd_tidal(K) enddo endif ! Update viscosity with the proper unit conversion. if (associated(Kv)) then do K=1,GV%ke+1 - Kv(i,j,K) = Kv(i,j,K) + US%m2_s_to_Z2_T * Kv_tidal(K) ! Rescale from m2 s-1 to Z2 T-1. + Kv(i,j,K) = Kv(i,j,K) + GV%m2_s_to_HZ_T * Kv_tidal(K) ! Rescale from m2 s-1 to H Z T-1. enddo endif ! diagnostics if (allocated(CS%dd%Kd_itidal)) then - CS%dd%Kd_itidal(i,j,:) = US%m2_s_to_Z2_T*Kd_tidal(:) + CS%dd%Kd_itidal(i,j,:) = GV%m2_s_to_HZ_T * Kd_tidal(:) endif if (allocated(CS%dd%N2_int)) then CS%dd%N2_int(i,j,:) = N2_int(i,:) @@ -846,16 +886,17 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int if (G%mask2dT(i,j)<1) cycle - iFaceHeight = 0.0 ! BBL is all relative to the surface + iFaceHeight(:) = 0.0 ! BBL is all relative to the surface hcorr = 0.0 + ! Compute heights at cell center and interfaces, and rescale layer thicknesses do k=1,GV%ke - h_m(k) = h(i,j,k)*GV%H_to_m ! Rescale thicknesses to m for use by CVmix. - ! cell center and cell bottom in meters (negative values in the ocean) - dh = h_m(k) + hcorr ! Nominal thickness less the accumulated error (could temporarily make dh<0) + h_m(k) = dz(i,k)*US%Z_to_m ! Rescale thicknesses to m for use by CVmix. + dh = dz(i,k) ! Nominal thickness to use for increment, in the units of heights + dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 - dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness - cellHeight(k) = iFaceHeight(k) - 0.5 * dh - iFaceHeight(k+1) = iFaceHeight(k) - dh + dh = max(dh, CS%min_thickness) ! Limited increment dh>=min_thickness + cellHeight(k) = iFaceHeight(k) - 0.5 * US%Z_to_m*dh + iFaceHeight(k+1) = iFaceHeight(k) - US%Z_to_m*dh enddo SchmittnerSocn = 0.0 ! TODO: compute this @@ -873,14 +914,14 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int ! CVMix API to prevent this redundancy. ! remap from input z coordinate to model coordinate: - tidal_qe_md = 0.0 + 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) ! 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. call CVMix_compute_SchmittnerCoeff( nlev = GV%ke, & - energy_flux = tidal_qe_md(:), & + energy_flux = US%RZ3_T3_to_W_m2*tidal_qe_md(:), & SchmittnerCoeff = Schmittner_coeff, & exp_hab_zetar = exp_hab_zetar, & CVmix_tidal_params_user = CS%CVMix_tidal_params) @@ -904,25 +945,25 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int ! Update diffusivity if (present(Kd_lay)) then do k=1,GV%ke - Kd_lay(i,k) = Kd_lay(i,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_tidal(k) + Kd_tidal(k+1)) + Kd_lay(i,k) = Kd_lay(i,k) + 0.5 * GV%m2_s_to_HZ_T * (Kd_tidal(k) + Kd_tidal(k+1)) enddo endif if (present(Kd_int)) then do K=1,GV%ke+1 - Kd_int(i,K) = Kd_int(i,K) + (US%m2_s_to_Z2_T * Kd_tidal(K)) + Kd_int(i,K) = Kd_int(i,K) + (GV%m2_s_to_HZ_T * Kd_tidal(K)) enddo endif ! Update viscosity if (associated(Kv)) then do K=1,GV%ke+1 - Kv(i,j,K) = Kv(i,j,K) + US%m2_s_to_Z2_T * Kv_tidal(K) ! Rescale from m2 s-1 to Z2 T-1. + Kv(i,j,K) = Kv(i,j,K) + GV%m2_s_to_HZ_T * Kv_tidal(K) ! Rescale from m2 s-1 to H Z T-1. enddo endif ! diagnostics if (allocated(CS%dd%Kd_itidal)) then - CS%dd%Kd_itidal(i,j,:) = US%m2_s_to_Z2_T*Kd_tidal(:) + CS%dd%Kd_itidal(i,j,:) = GV%m2_s_to_HZ_T*Kd_tidal(:) endif if (allocated(CS%dd%N2_int)) then CS%dd%N2_int(i,j,:) = N2_int(i,:) @@ -954,93 +995,90 @@ end subroutine calculate_CVMix_tidal !! low modes (rays) of the internal tide ("lowmode"), and (3) local dissipation of internal lee waves. !! Will eventually need to add diffusivity due to other wave-breaking processes (e.g. Bottom friction, !! Froude-number-depending breaking, PSI, etc.). -subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & - G, GV, US, CS, Kd_max, Kd_lay, Kd_int) +subroutine add_int_tide_diffusivity(dz, j, N2_bot, Rho_bot, N2_lay, TKE_to_Kd, max_TKE, & + G, GV, US, CS, Kd_max, Kd_lay, Kd_int, VBF) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: dz !< The vertical distance across layers [Z ~> m] integer, intent(in) :: j !< The j-index to work on real, dimension(SZI_(G)), intent(in) :: N2_bot !< The near-bottom squared buoyancy frequency !! frequency [T-2 ~> s-2]. + real, dimension(SZI_(G)), intent(in) :: Rho_bot !< The near-bottom in situ density [R ~> kg m-3] real, dimension(SZI_(G),SZK_(GV)), intent(in) :: N2_lay !< The squared buoyancy frequency of the !! layers [T-2 ~> s-2]. real, dimension(SZI_(G),SZK_(GV)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE !! dissipated within a layer and the !! diapycnal diffusivity within that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) - !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] - real, dimension(SZI_(G),SZK_(GV)), intent(in) :: max_TKE !< The energy required to for a layer to entrain - !! to its maximum realizable thickness [Z3 T-3 ~> m3 s-3] + !! [T2 Z-1 ~> s2 m-1] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: max_TKE !< The energy required for a layer + !! to entrain to its maximum realizable + !! thickness [H Z2 T-3 ~> m3 s-3 or W m-2] type(tidal_mixing_cs), intent(inout) :: CS !< The control structure for this module real, intent(in) :: Kd_max !< The maximum increment for diapycnal !! diffusivity due to TKE-based processes - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. !! Set this to a negative value to have no limit. real, dimension(SZI_(G),SZK_(GV)), & - optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers [Z2 T-1 ~> m2 s-1] + optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZI_(G),SZK_(GV)+1), & optional, intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. + type(vbf_CS), pointer :: VBF !< A diagnostics structure for vertical buoyancy fluxes ! local real, dimension(SZI_(G)) :: & - htot, & ! total thickness above or below a layer, or the - ! integrated thickness in the BBL [Z ~> m]. - htot_WKB, & ! WKB scaled distance from top to bottom [Z ~> m]. - TKE_itidal_bot, & ! internal tide TKE at ocean bottom [Z3 T-3 ~> m3 s-3] - TKE_Niku_bot, & ! lee-wave TKE at ocean bottom [Z3 T-3 ~> m3 s-3] - TKE_lowmode_bot, & ! internal tide TKE at ocean bottom lost from all remote low modes [Z3 T-3 ~> m3 s-3] (BDM) + dztot, & ! Vertical distance between the top and bottom of the ocean [Z ~> m] + dztot_WKB, & ! WKB scaled distance from top to bottom [Z ~> m] + TKE_itidal_bot, & ! internal tide TKE at ocean bottom [H Z2 T-3 ~> m3 s-3 or W m-2] + TKE_Niku_bot, & ! lee-wave TKE at ocean bottom [H Z2 T-3 ~> m3 s-3 or W m-2] + TKE_lowmode_bot, & ! internal tide TKE at ocean bottom lost from all remote low modes [H Z2 T-3 ~> m3 s-3 or W m-2] Inv_int, & ! inverse of TKE decay for int tide over the depth of the ocean [nondim] Inv_int_lee, & ! inverse of TKE decay for lee waves over the depth of the ocean [nondim] - Inv_int_low, & ! inverse of TKE decay for low modes over the depth of the ocean [nondim] (BDM) - z0_Polzin, & ! TKE decay scale in Polzin formulation [Z ~> m]. + Inv_int_low, & ! inverse of TKE decay for low modes over the depth of the ocean [nondim] + z0_Polzin, & ! TKE decay scale in Polzin formulation [Z ~> m] z0_Polzin_scaled, & ! TKE decay scale in Polzin formulation [Z ~> m]. ! multiplied by N2_bot/N2_meanz to be coherent with the WKB scaled z ! z*=int(N2/N2_bot) * N2_bot/N2_meanz = int(N2/N2_meanz) ! z0_Polzin_scaled = z0_Polzin * N2_bot/N2_meanz N2_meanz, & ! vertically averaged squared buoyancy frequency [T-2 ~> s-2] for WKB scaling - TKE_itidal_rem, & ! remaining internal tide TKE (from barotropic source) [Z3 T-3 ~> m3 s-3] - TKE_Niku_rem, & ! remaining lee-wave TKE [Z3 T-3 ~> m3 s-3] - TKE_lowmode_rem, & ! remaining internal tide TKE (from propagating low mode source) [Z3 T-3 ~> m3 s-3] (BDM) + TKE_itidal_rem, & ! remaining internal tide TKE (from barotropic source) [H Z2 T-3 ~> m3 s-3 or W m-2] + TKE_Niku_rem, & ! remaining lee-wave TKE [H Z2 T-3 ~> m3 s-3 or W m-2] + TKE_lowmode_rem, & ! remaining internal tide TKE (from propagating low mode source) [H Z2 T-3 ~> m3 s-3 or W m-2] TKE_frac_top, & ! fraction of bottom TKE that should appear at top of a layer [nondim] TKE_frac_top_lee, & ! fraction of bottom TKE that should appear at top of a layer [nondim] TKE_frac_top_lowmode, & - ! fraction of bottom TKE that should appear at top of a layer [nondim] (BDM) - z_from_bot, & ! distance from bottom [Z ~> m]. - z_from_bot_WKB ! WKB scaled distance from bottom [Z ~> m]. - - real :: I_rho0 ! Inverse of the Boussinesq reference density, i.e. 1 / RHO0 [R-1 ~> m3 kg-1] - real :: Kd_add ! diffusivity to add in a layer [Z2 T-1 ~> m2 s-1]. - real :: TKE_itide_lay ! internal tide TKE imparted to a layer (from barotropic) [Z3 T-3 ~> m3 s-3] - real :: TKE_Niku_lay ! lee-wave TKE imparted to a layer [Z3 T-3 ~> m3 s-3] - real :: TKE_lowmode_lay ! internal tide TKE imparted to a layer (from low mode) [Z3 T-3 ~> m3 s-3] (BDM) + ! fraction of bottom TKE that should appear at top of a layer [nondim] + z_from_bot, & ! distance from bottom [Z ~> m] + z_from_bot_WKB ! WKB scaled distance from bottom [Z ~> m] + + real :: Kd_add ! Diffusivity to add in a layer [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: TKE_itide_lay ! internal tide TKE imparted to a layer (from barotropic) [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_Niku_lay ! lee-wave TKE imparted to a layer [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_lowmode_lay ! internal tide TKE imparted to a layer (from low mode) [H Z2 T-3 ~> m3 s-3 or W m-2] real :: frac_used ! fraction of TKE that can be used in a layer [nondim] - real :: Izeta ! inverse of TKE decay scale [Z-1 ~> m-1]. - real :: Izeta_lee ! inverse of TKE decay scale for lee waves [Z-1 ~> m-1]. - real :: z0Ps_num ! The numerator of the unlimited z0_Polzin_scaled [Z T-3 ~> m s-3]. + real :: Izeta ! inverse of TKE decay scale [Z-1 ~> m-1] + real :: Izeta_lee ! inverse of TKE decay scale for lee waves [Z-1 ~> m-1] + real :: z0Ps_num ! The numerator of the unlimited z0_Polzin_scaled [Z T-3 ~> m s-3] real :: z0Ps_denom ! The denominator of the unlimited z0_Polzin_scaled [T-3 ~> s-3]. - real :: z0_psl ! temporary variable [Z ~> m]. - real :: TKE_lowmode_tot ! TKE from all low modes [R Z3 T-3 ~> W m-2] (BDM) + real :: z0_psl ! temporary variable [Z ~> m] + real :: TKE_lowmode_tot ! TKE from all low modes [R Z3 T-3 ~> W m-2] logical :: use_Polzin, use_Simmons - character(len=160) :: mesg ! The text of an error message integer :: i, k, is, ie, nz - integer :: a, fr, m is = G%isc ; ie = G%iec ; nz = GV%ke if (.not.(CS%Int_tide_dissipation .or. CS%Lee_wave_dissipation)) return - do i=is,ie ; htot(i) = 0.0 ; Inv_int(i) = 0.0 ; Inv_int_lee(i) = 0.0 ; Inv_int_low(i) = 0.0 ;enddo + do i=is,ie ; dztot(i) = 0.0 ; Inv_int(i) = 0.0 ; Inv_int_lee(i) = 0.0 ; Inv_int_low(i) = 0.0 ; enddo do k=1,nz ; do i=is,ie - htot(i) = htot(i) + GV%H_to_Z*h(i,j,k) + dztot(i) = dztot(i) + dz(i,k) enddo ; enddo - I_Rho0 = 1.0 / (GV%Rho0) - use_Polzin = ((CS%Int_tide_dissipation .and. (CS%int_tide_profile == POLZIN_09)) .or. & (CS%lee_wave_dissipation .and. (CS%lee_wave_profile == POLZIN_09)) .or. & (CS%Lowmode_itidal_dissipation .and. (CS%int_tide_profile == POLZIN_09))) @@ -1051,29 +1089,28 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & ! Calculate parameters for vertical structure of dissipation ! Simmons: if ( use_Simmons ) then - Izeta = 1.0 / max(CS%Int_tide_decay_scale, GV%H_subroundoff*GV%H_to_Z) - Izeta_lee = 1.0 / max(CS%Int_tide_decay_scale*CS%Decay_scale_factor_lee, & - GV%H_subroundoff*GV%H_to_Z) + Izeta = 1.0 / max(CS%Int_tide_decay_scale, GV%dz_subroundoff) + Izeta_lee = 1.0 / max(CS%Int_tide_decay_scale*CS%Decay_scale_factor_lee, GV%dz_subroundoff) do i=is,ie CS%Nb(i,j) = sqrt(N2_bot(i)) if (allocated(CS%dd%N2_bot)) & CS%dd%N2_bot(i,j) = N2_bot(i) if ( CS%Int_tide_dissipation ) then - if (Izeta*htot(i) > 1.0e-14) then ! L'Hospital's version of Adcroft's reciprocal rule. - Inv_int(i) = 1.0 / (1.0 - exp(-Izeta*htot(i))) + if (Izeta*dztot(i) > 1.0e-14) then ! L'Hospital's version of Adcroft's reciprocal rule. + Inv_int(i) = 1.0 / (1.0 - exp(-Izeta*dztot(i))) endif endif if ( CS%Lee_wave_dissipation ) then - if (Izeta_lee*htot(i) > 1.0e-14) then ! L'Hospital's version of Adcroft's reciprocal rule. - Inv_int_lee(i) = 1.0 / (1.0 - exp(-Izeta_lee*htot(i))) + if (Izeta_lee*dztot(i) > 1.0e-14) then ! L'Hospital's version of Adcroft's reciprocal rule. + Inv_int_lee(i) = 1.0 / (1.0 - exp(-Izeta_lee*dztot(i))) endif endif if ( CS%Lowmode_itidal_dissipation) then - if (Izeta*htot(i) > 1.0e-14) then ! L'Hospital's version of Adcroft's reciprocal rule. - Inv_int_low(i) = 1.0 / (1.0 - exp(-Izeta*htot(i))) + if (Izeta*dztot(i) > 1.0e-14) then ! L'Hospital's version of Adcroft's reciprocal rule. + Inv_int_low(i) = 1.0 / (1.0 - exp(-Izeta*dztot(i))) endif endif - z_from_bot(i) = GV%H_to_Z*h(i,j,nz) + z_from_bot(i) = dz(i,nz) enddo endif ! Simmons @@ -1082,109 +1119,109 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & ! WKB scaling of the vertical coordinate do i=is,ie ; N2_meanz(i) = 0.0 ; enddo do k=1,nz ; do i=is,ie - N2_meanz(i) = N2_meanz(i) + N2_lay(i,k) * GV%H_to_Z * h(i,j,k) + N2_meanz(i) = N2_meanz(i) + N2_lay(i,k) * dz(i,k) enddo ; enddo do i=is,ie - N2_meanz(i) = N2_meanz(i) / (htot(i) + GV%H_subroundoff*GV%H_to_Z) + N2_meanz(i) = N2_meanz(i) / (dztot(i) + GV%dz_subroundoff) if (allocated(CS%dd%N2_meanz)) & CS%dd%N2_meanz(i,j) = N2_meanz(i) enddo ! WKB scaled z*(z=H) z* at the surface using the modified Polzin WKB scaling - do i=is,ie ; htot_WKB(i) = htot(i) ; enddo -! do i=is,ie ; htot_WKB(i) = 0.0 ; enddo + do i=is,ie ; dztot_WKB(i) = dztot(i) ; enddo +! do i=is,ie ; dztot_WKB(i) = 0.0 ; enddo ! do k=1,nz ; do i=is,ie -! htot_WKB(i) = htot_WKB(i) + GV%H_to_Z*h(i,j,k) * N2_lay(i,k) / N2_meanz(i) +! dztot_WKB(i) = dztot_WKB(i) + dz(i,k) * N2_lay(i,k) / N2_meanz(i) ! enddo ; enddo - ! htot_WKB(i) = htot(i) ! Nearly equivalent and simpler + ! dztot_WKB(i) = dztot(i) ! Nearly equivalent and simpler do i=is,ie CS%Nb(i,j) = sqrt(N2_bot(i)) - if (CS%answers_2018) then + if (CS%tidal_answer_date < 20190101) then if ((CS%tideamp(i,j) > 0.0) .and. & (CS%kappa_itides**2 * CS%h2(i,j) * CS%Nb(i,j)**3 > 1.0e-14*US%T_to_s**3) ) then - z0_polzin(i) = CS%Polzin_decay_scale_factor * CS%Nu_Polzin * & + z0_Polzin(i) = CS%Polzin_decay_scale_factor * CS%Nu_Polzin * & CS%Nbotref_Polzin**2 * CS%tideamp(i,j) / & ( CS%kappa_itides**2 * CS%h2(i,j) * CS%Nb(i,j)**3 ) - if (z0_polzin(i) < CS%Polzin_min_decay_scale) & - z0_polzin(i) = CS%Polzin_min_decay_scale + if (z0_Polzin(i) < CS%Polzin_min_decay_scale) & + z0_Polzin(i) = CS%Polzin_min_decay_scale if (N2_meanz(i) > 1.0e-14*US%T_to_s**2 ) then - z0_polzin_scaled(i) = z0_polzin(i)*CS%Nb(i,j)**2 / N2_meanz(i) + z0_Polzin_scaled(i) = z0_Polzin(i)*CS%Nb(i,j)**2 / N2_meanz(i) else - z0_polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * htot(i) + z0_Polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * dztot(i) endif - if (z0_polzin_scaled(i) > (CS%Polzin_decay_scale_max_factor * htot(i)) ) & - z0_polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * htot(i) + if (z0_Polzin_scaled(i) > (CS%Polzin_decay_scale_max_factor * dztot(i)) ) & + z0_Polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * dztot(i) else - z0_polzin(i) = CS%Polzin_decay_scale_max_factor * htot(i) - z0_polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * htot(i) + z0_Polzin(i) = CS%Polzin_decay_scale_max_factor * dztot(i) + z0_Polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * dztot(i) endif else z0Ps_num = (CS%Polzin_decay_scale_factor * CS%Nu_Polzin * CS%Nbotref_Polzin**2) * CS%tideamp(i,j) z0Ps_denom = ( CS%kappa_itides**2 * CS%h2(i,j) * CS%Nb(i,j) * N2_meanz(i) ) if ((CS%tideamp(i,j) > 0.0) .and. & - (z0Ps_num < z0Ps_denom * CS%Polzin_decay_scale_max_factor * htot(i))) then - z0_polzin_scaled(i) = z0Ps_num / z0Ps_denom + (z0Ps_num < z0Ps_denom * CS%Polzin_decay_scale_max_factor * dztot(i))) then + z0_Polzin_scaled(i) = z0Ps_num / z0Ps_denom - if (abs(N2_meanz(i) * z0_polzin_scaled(i)) < & - CS%Nb(i,j)**2 * (CS%Polzin_decay_scale_max_factor * htot(i))) then - z0_polzin(i) = z0_polzin_scaled(i) * (N2_meanz(i) / CS%Nb(i,j)**2) + if (abs(N2_meanz(i) * z0_Polzin_scaled(i)) < & + CS%Nb(i,j)**2 * (CS%Polzin_decay_scale_max_factor * dztot(i))) then + z0_Polzin(i) = z0_Polzin_scaled(i) * (N2_meanz(i) / CS%Nb(i,j)**2) else - z0_polzin(i) = CS%Polzin_decay_scale_max_factor * htot(i) + z0_Polzin(i) = CS%Polzin_decay_scale_max_factor * dztot(i) endif else - z0_polzin(i) = CS%Polzin_decay_scale_max_factor * htot(i) - z0_polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * htot(i) + z0_Polzin(i) = CS%Polzin_decay_scale_max_factor * dztot(i) + z0_Polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * dztot(i) endif endif if (allocated(CS%dd%Polzin_decay_scale)) & - CS%dd%Polzin_decay_scale(i,j) = z0_polzin(i) + CS%dd%Polzin_decay_scale(i,j) = z0_Polzin(i) if (allocated(CS%dd%Polzin_decay_scale_scaled)) & - CS%dd%Polzin_decay_scale_scaled(i,j) = z0_polzin_scaled(i) + CS%dd%Polzin_decay_scale_scaled(i,j) = z0_Polzin_scaled(i) if (allocated(CS%dd%N2_bot)) & CS%dd%N2_bot(i,j) = CS%Nb(i,j)*CS%Nb(i,j) - if (CS%answers_2018) then + if (CS%tidal_answer_date < 20190101) then ! These expressions use dimensional constants to avoid NaN values. if ( CS%Int_tide_dissipation .and. (CS%int_tide_profile == POLZIN_09) ) then - if (htot_WKB(i) > 1.0e-14*US%m_to_Z) & - Inv_int(i) = ( z0_polzin_scaled(i) / htot_WKB(i) ) + 1.0 + if (dztot_WKB(i) > 1.0e-14*US%m_to_Z) & + Inv_int(i) = ( z0_Polzin_scaled(i) / dztot_WKB(i) ) + 1.0 endif if ( CS%lee_wave_dissipation .and. (CS%lee_wave_profile == POLZIN_09) ) then - if (htot_WKB(i) > 1.0e-14*US%m_to_Z) & - Inv_int_lee(i) = ( z0_polzin_scaled(i)*CS%Decay_scale_factor_lee / htot_WKB(i) ) + 1.0 + if (dztot_WKB(i) > 1.0e-14*US%m_to_Z) & + Inv_int_lee(i) = ( z0_Polzin_scaled(i)*CS%Decay_scale_factor_lee / dztot_WKB(i) ) + 1.0 endif if ( CS%Lowmode_itidal_dissipation .and. (CS%int_tide_profile == POLZIN_09) ) then - if (htot_WKB(i) > 1.0e-14*US%m_to_Z) & - Inv_int_low(i) = ( z0_polzin_scaled(i) / htot_WKB(i) ) + 1.0 + if (dztot_WKB(i) > 1.0e-14*US%m_to_Z) & + Inv_int_low(i) = ( z0_Polzin_scaled(i) / dztot_WKB(i) ) + 1.0 endif else ! These expressions give values of Inv_int < 10^14 using a variant of Adcroft's reciprocal rule. Inv_int(i) = 0.0 ; Inv_int_lee(i) = 0.0 ; Inv_int_low(i) = 0.0 if ( CS%Int_tide_dissipation .and. (CS%int_tide_profile == POLZIN_09) ) then - if (z0_polzin_scaled(i) < 1.0e14 * htot_WKB(i)) & - Inv_int(i) = ( z0_polzin_scaled(i) / htot_WKB(i) ) + 1.0 + if (z0_Polzin_scaled(i) < 1.0e14 * dztot_WKB(i)) & + Inv_int(i) = ( z0_Polzin_scaled(i) / dztot_WKB(i) ) + 1.0 endif if ( CS%lee_wave_dissipation .and. (CS%lee_wave_profile == POLZIN_09) ) then - if (z0_polzin_scaled(i) < 1.0e14 * htot_WKB(i)) & - Inv_int_lee(i) = ( z0_polzin_scaled(i)*CS%Decay_scale_factor_lee / htot_WKB(i) ) + 1.0 + if (z0_Polzin_scaled(i) < 1.0e14 * dztot_WKB(i)) & + Inv_int_lee(i) = ( z0_Polzin_scaled(i)*CS%Decay_scale_factor_lee / dztot_WKB(i) ) + 1.0 endif if ( CS%Lowmode_itidal_dissipation .and. (CS%int_tide_profile == POLZIN_09) ) then - if (z0_polzin_scaled(i) < 1.0e14 * htot_WKB(i)) & - Inv_int_low(i) = ( z0_polzin_scaled(i) / htot_WKB(i) ) + 1.0 + if (z0_Polzin_scaled(i) < 1.0e14 * dztot_WKB(i)) & + Inv_int_low(i) = ( z0_Polzin_scaled(i) / dztot_WKB(i) ) + 1.0 endif endif - z_from_bot(i) = GV%H_to_Z*h(i,j,nz) + z_from_bot(i) = dz(i,nz) ! Use the new formulation for WKB scaling. N2 is referenced to its vertical mean. - if (CS%answers_2018) then + if (CS%tidal_answer_date < 20190101) then if (N2_meanz(i) > 1.0e-14*US%T_to_s**2 ) then - z_from_bot_WKB(i) = GV%H_to_Z*h(i,j,nz) * N2_lay(i,nz) / N2_meanz(i) + z_from_bot_WKB(i) = dz(i,nz) * N2_lay(i,nz) / N2_meanz(i) else ; z_from_bot_WKB(i) = 0 ; endif else - if (GV%H_to_Z*h(i,j,nz) * N2_lay(i,nz) < N2_meanz(i) * (1.0e14 * htot_WKB(i))) then - z_from_bot_WKB(i) = GV%H_to_Z*h(i,j,nz) * N2_lay(i,nz) / N2_meanz(i) + if (dz(i,nz) * N2_lay(i,nz) < N2_meanz(i) * (1.0e14 * dztot_WKB(i))) then + z_from_bot_WKB(i) = dz(i,nz) * N2_lay(i,nz) / N2_meanz(i) else ; z_from_bot_WKB(i) = 0 ; endif endif enddo @@ -1194,14 +1231,19 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & ! Both Polzin and Simmons: do i=is,ie ! Dissipation of locally trapped internal tide (non-propagating high modes) - TKE_itidal_bot(i) = min(CS%TKE_itidal(i,j)*CS%Nb(i,j), CS%TKE_itide_max) + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + TKE_itidal_bot(i) = min(GV%Z_to_H*CS%TKE_itidal(i,j)*CS%Nb(i,j), CS%TKE_itide_max) + else + TKE_itidal_bot(i) = min(GV%RZ_to_H*Rho_bot(i) * (CS%TKE_itidal(i,j)*CS%Nb(i,j)), & + CS%TKE_itide_max) + endif if (allocated(CS%dd%TKE_itidal_used)) & CS%dd%TKE_itidal_used(i,j) = TKE_itidal_bot(i) - TKE_itidal_bot(i) = (I_rho0 * CS%Mu_itides * CS%Gamma_itides) * TKE_itidal_bot(i) + TKE_itidal_bot(i) = (GV%RZ_to_H * CS%Mu_itides * CS%Gamma_itides) * TKE_itidal_bot(i) ! Dissipation of locally trapped lee waves TKE_Niku_bot(i) = 0.0 if (CS%Lee_wave_dissipation) then - TKE_Niku_bot(i) = (I_rho0 * CS%Mu_itides * CS%Gamma_lee) * CS%TKE_Niku(i,j) + TKE_Niku_bot(i) = (GV%RZ_to_H * CS%Mu_itides * CS%Gamma_lee) * CS%TKE_Niku(i,j) endif ! Dissipation of propagating internal tide (baroclinic low modes; rays) (BDM) TKE_lowmode_tot = 0.0 @@ -1209,7 +1251,7 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & if (CS%Lowmode_itidal_dissipation) then ! get loss rate due to wave drag on low modes (already multiplied by q) call get_lowmode_loss(i,j,G,CS%int_tide_CSp,"WaveDrag",TKE_lowmode_tot) - TKE_lowmode_bot(i) = CS%Mu_itides * I_rho0 * TKE_lowmode_tot + TKE_lowmode_bot(i) = CS%Mu_itides * GV%RZ_to_H * TKE_lowmode_tot endif ! Vertical energy flux at bottom TKE_itidal_rem(i) = Inv_int(i) * TKE_itidal_bot(i) @@ -1225,7 +1267,7 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & if ( use_Simmons ) then do k=nz-1,2,-1 ; do i=is,ie if (max_TKE(i,k) <= 0.0) cycle - z_from_bot(i) = z_from_bot(i) + GV%H_to_Z*h(i,j,k) + z_from_bot(i) = z_from_bot(i) + dz(i,k) ! Fraction of bottom flux predicted to reach top of this layer TKE_frac_top(i) = Inv_int(i) * exp(-Izeta * z_from_bot(i)) @@ -1239,7 +1281,7 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & TKE_lowmode_lay = TKE_lowmode_rem(i) - TKE_lowmode_bot(i)* TKE_frac_top_lowmode(i) ! Actual power expended may be less than predicted if stratification is weak; adjust - if (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay > (max_TKE(i,k))) then + if (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay > max_TKE(i,k)) then frac_used = (max_TKE(i,k)) / (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) TKE_itide_lay = frac_used * TKE_itide_lay TKE_Niku_lay = frac_used * TKE_Niku_lay @@ -1265,41 +1307,60 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & endif ! diagnostics - if (allocated(CS%dd%Kd_itidal)) then + if (allocated(CS%dd%Kd_itidal).or.(associated(VBF%Kd_itides))) then ! If at layers, CS%dd%Kd_itidal is just TKE_to_Kd(i,k) * TKE_itide_lay ! The following sets the interface diagnostics. Kd_add = TKE_to_Kd(i,k) * TKE_itide_lay if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) - if (k>1) CS%dd%Kd_itidal(i,j,K) = CS%dd%Kd_itidal(i,j,K) + 0.5*Kd_add - if (k1) CS%dd%Kd_itidal(i,j,K) = CS%dd%Kd_itidal(i,j,K) + 0.5*Kd_add + if (k1) VBF%Kd_itides(i,j,K) = VBF%Kd_itides(i,j,K) + 0.5*Kd_add + if (k= 0.0) Kd_add = min(Kd_add, Kd_max) - if (k>1) CS%dd%Kd_Niku(i,j,K) = CS%dd%Kd_Niku(i,j,K) + 0.5*Kd_add - if (k1) CS%dd%Kd_Niku(i,j,K) = CS%dd%Kd_Niku(i,j,K) + 0.5*Kd_add + if (k1) VBF%Kd_Niku(i,j,K) = VBF%Kd_Niku(i,j,K) + 0.5*Kd_add + if (k= 0.0) Kd_add = min(Kd_add, Kd_max) - if (k>1) CS%dd%Kd_lowmode(i,j,K) = CS%dd%Kd_lowmode(i,j,K) + 0.5*Kd_add - if (k1) CS%dd%Kd_lowmode(i,j,K) = CS%dd%Kd_lowmode(i,j,K) + 0.5*Kd_add + if (k1) VBF%Kd_lowmode(i,j,K) = VBF%Kd_lowmode(i,j,K) + 0.5*Kd_add + if (k 1.0e-14*US%T_to_s**2 ) then - z_from_bot_WKB(i) = z_from_bot_WKB(i) & - + GV%H_to_Z * h(i,j,k) * N2_lay(i,k) / N2_meanz(i) + z_from_bot_WKB(i) = z_from_bot_WKB(i) + dz(i,k) * N2_lay(i,k) / N2_meanz(i) else ; z_from_bot_WKB(i) = 0 ; endif else - if (GV%H_to_Z*h(i,j,k) * N2_lay(i,k) < (1.0e14 * htot_WKB(i)) * N2_meanz(i)) then - z_from_bot_WKB(i) = z_from_bot_WKB(i) + & - GV%H_to_Z*h(i,j,k) * N2_lay(i,k) / N2_meanz(i) + if (dz(i,k) * N2_lay(i,k) < (1.0e14 * dztot_WKB(i)) * N2_meanz(i)) then + z_from_bot_WKB(i) = z_from_bot_WKB(i) + dz(i,k) * N2_lay(i,k) / N2_meanz(i) endif endif ! Fraction of bottom flux predicted to reach top of this layer - TKE_frac_top(i) = ( Inv_int(i) * z0_polzin_scaled(i) ) / & - ( z0_polzin_scaled(i) + z_from_bot_WKB(i) ) - z0_psl = z0_polzin_scaled(i)*CS%Decay_scale_factor_lee + TKE_frac_top(i) = ( Inv_int(i) * z0_Polzin_scaled(i) ) / & + ( z0_Polzin_scaled(i) + z_from_bot_WKB(i) ) + z0_psl = z0_Polzin_scaled(i)*CS%Decay_scale_factor_lee TKE_frac_top_lee(i) = (Inv_int_lee(i) * z0_psl) / (z0_psl + z_from_bot_WKB(i)) - TKE_frac_top_lowmode(i) = ( Inv_int_low(i) * z0_polzin_scaled(i) ) / & - ( z0_polzin_scaled(i) + z_from_bot_WKB(i) ) + TKE_frac_top_lowmode(i) = ( Inv_int_low(i) * z0_Polzin_scaled(i) ) / & + ( z0_Polzin_scaled(i) + z_from_bot_WKB(i) ) ! Actual influx at bottom of layer minus predicted outflux at top of layer to give ! predicted power expended @@ -1337,8 +1396,8 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & TKE_lowmode_lay = TKE_lowmode_rem(i) - TKE_lowmode_bot(i)*TKE_frac_top_lowmode(i) ! Actual power expended may be less than predicted if stratification is weak; adjust - if (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay > (max_TKE(i,k))) then - frac_used = (max_TKE(i,k)) / (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) + if (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay > max_TKE(i,k)) then + frac_used = max_TKE(i,k) / (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) TKE_itide_lay = frac_used * TKE_itide_lay TKE_Niku_lay = frac_used * TKE_Niku_lay TKE_lowmode_lay = frac_used * TKE_lowmode_lay @@ -1363,39 +1422,58 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & endif ! diagnostics - if (allocated(CS%dd%Kd_itidal)) then + if (allocated(CS%dd%Kd_itidal).or.(associated(VBF%Kd_itides))) then ! If at layers, this is just CS%dd%Kd_itidal(i,j,K) = TKE_to_Kd(i,k) * TKE_itide_lay ! The following sets the interface diagnostics. Kd_add = TKE_to_Kd(i,k) * TKE_itide_lay if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) - if (k>1) CS%dd%Kd_itidal(i,j,K) = CS%dd%Kd_itidal(i,j,K) + 0.5*Kd_add - if (k1) CS%dd%Kd_itidal(i,j,K) = CS%dd%Kd_itidal(i,j,K) + 0.5*Kd_add + if (k1) VBF%Kd_itides(i,j,K) = VBF%Kd_itides(i,j,K) + 0.5*Kd_add + if (k= 0.0) Kd_add = min(Kd_add, Kd_max) - if (k>1) CS%dd%Kd_Niku(i,j,K) = CS%dd%Kd_Niku(i,j,K) + 0.5*Kd_add - if (k1) CS%dd%Kd_Niku(i,j,K) = CS%dd%Kd_Niku(i,j,K) + 0.5*Kd_add + if (k1) VBF%Kd_Niku(i,j,K) = VBF%Kd_Niku(i,j,K) + 0.5*Kd_add + if (k= 0.0) Kd_add = min(Kd_add, Kd_max) - if (k>1) CS%dd%Kd_lowmode(i,j,K) = CS%dd%Kd_lowmode(i,j,K) + 0.5*Kd_add - if (k1) CS%dd%Kd_lowmode(i,j,K) = CS%dd%Kd_lowmode(i,j,K) + 0.5*Kd_add + if (k1) VBF%Kd_lowmode(i,j,K) = VBF%Kd_lowmode(i,j,K) + 0.5*Kd_add + if (k 0) .or. (CS%id_Kd_Itidal_work > 0)) & allocate(CS%dd%Kd_itidal(isd:ied,jsd:jed,nz+1), source=0.0) @@ -1434,7 +1512,7 @@ subroutine setup_tidal_diagnostics(G, GV, CS) ! additional diags for CVMix if (CS%id_N2_int > 0) allocate(CS%dd%N2_int(isd:ied,jsd:jed,nz+1), source=0.0) if (CS%id_Simmons_coeff > 0) then - if (CS%CVMix_tidal_scheme .ne. SIMMONS) then + if (CS%CVMix_tidal_scheme /= SIMMONS) then call MOM_error(FATAL, "setup_tidal_diagnostics: Simmons_coeff diagnostics is available "//& "only when CVMix_tidal_scheme is Simmons") endif @@ -1442,14 +1520,14 @@ subroutine setup_tidal_diagnostics(G, GV, CS) endif if (CS%id_vert_dep > 0) allocate(CS%dd%vert_dep_3d(isd:ied,jsd:jed,nz+1), source=0.0) if (CS%id_Schmittner_coeff > 0) then - if (CS%CVMix_tidal_scheme .ne. SCHMITTNER) then + if (CS%CVMix_tidal_scheme /= SCHMITTNER) then call MOM_error(FATAL, "setup_tidal_diagnostics: Schmittner_coeff diagnostics is available "//& "only when CVMix_tidal_scheme is Schmittner.") endif allocate(CS%dd%Schmittner_coeff_3d(isd:ied,jsd:jed,nz), source=0.0) endif if (CS%id_tidal_qe_md > 0) then - if (CS%CVMix_tidal_scheme .ne. SCHMITTNER) then + if (CS%CVMix_tidal_scheme /= SCHMITTNER) then call MOM_error(FATAL, "setup_tidal_diagnostics: tidal_qe_md diagnostics is available "//& "only when CVMix_tidal_scheme is Schmittner.") endif @@ -1536,29 +1614,43 @@ 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, tidal_energy_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 - character(len=200), intent(in) :: tidal_energy_file !< The file from which to read tidalinputs + type(param_file_type), intent(in) :: param_file !< Run-time parameter file handle type(tidal_mixing_cs), intent(inout) :: CS !< The control structure for this module - ! local + + ! local variables + character(len=200) :: tidal_energy_file ! Input file names or paths + character(len=200) :: tidal_input_var ! Input file variable name + character(len=40) :: mdl = "MOM_tidal_mixing" !< This module's name. integer :: i, j, isd, ied, jsd, jed - real, allocatable, dimension(:,:) :: tidal_energy_flux_2d ! input tidal energy flux at T-grid points [W m-2] + real, allocatable, dimension(:,:) :: & + tidal_energy_flux_2d ! Input tidal energy flux at T-grid points [R Z3 T-3 ~> W m-2] isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + call get_param(param_file, mdl, "TIDAL_ENERGY_FILE", tidal_energy_file, & + "The path to the file containing tidal energy dissipation. "//& + "Used with CVMix tidal mixing schemes.", fail_if_missing=.true.) + tidal_energy_file = trim(CS%inputdir) // trim(tidal_energy_file) + select case (uppercase(tidal_energy_type(1:4))) case ('JAYN') ! Jayne 2009 if (.not. allocated(CS%tidal_qe_2d)) allocate(CS%tidal_qe_2d(isd:ied,jsd:jed)) allocate(tidal_energy_flux_2d(isd:ied,jsd:jed)) - call MOM_read_data(tidal_energy_file,'wave_dissipation',tidal_energy_flux_2d, G%domain) + call get_param(param_file, mdl, "TIDAL_DISSIPATION_VAR", tidal_input_var, & + "The name in the input file of the tidal energy source for mixing.", & + default="wave_dissipation") + call MOM_read_data(tidal_energy_file, tidal_input_var, tidal_energy_flux_2d, G%domain, scale=US%W_m2_to_RZ3_T3) do j=G%jsc,G%jec ; do i=G%isc,G%iec CS%tidal_qe_2d(i,j) = CS%Gamma_itides * tidal_energy_flux_2d(i,j) enddo ; enddo deallocate(tidal_energy_flux_2d) case ('ER03') ! Egbert & Ray 2003 - call read_tidal_constituents(G, US, tidal_energy_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 @@ -1566,25 +1658,27 @@ subroutine read_tidal_energy(G, US, tidal_energy_type, tidal_energy_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, 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 type(tidal_mixing_cs), intent(inout) :: CS !< The control structure for this module ! local variables - real, parameter :: C1_3 = 1.0/3.0 + real, parameter :: C1_3 = 1.0/3.0 ! A rational constant [nondim] real, dimension(SZI_(G),SZJ_(G)) :: & - tidal_qk1, & ! qk1 coefficient used in Schmittner & Egbert - tidal_qo1 ! qo1 coefficient used in Schmittner & Egbert + tidal_qk1, & ! qk1 coefficient used in Schmittner & Egbert [nondim] + tidal_qo1 ! qo1 coefficient used in Schmittner & Egbert [nondim] real, allocatable, dimension(:) :: & z_t, & ! depth from surface to midpoint of input layer [Z ~> m] z_w ! depth from surface to top of input layer [Z ~> m] real, allocatable, dimension(:,:,:) :: & - tc_m2, & ! input lunar semidiurnal tidal energy flux [W m-2] - tc_s2, & ! input solar semidiurnal tidal energy flux [W m-2] - tc_k1, & ! input lunar diurnal tidal energy flux [W m-2] - tc_o1 ! input lunar diurnal tidal energy flux [W m-2] + tc_m2, & ! input lunar semidiurnal tidal energy flux [R Z3 T-3 ~> W m-2] + tc_s2, & ! input solar semidiurnal tidal energy flux [R Z3 T-3 ~> W m-2] + tc_k1, & ! input lunar diurnal tidal energy flux [R Z3 T-3 ~> W m-2] + tc_o1 ! input lunar diurnal tidal energy flux [R Z3 T-3 ~> W m-2] integer, dimension(4) :: nz_in integer :: k, is, ie, js, je, isd, ied, jsd, jed, i, j @@ -1606,13 +1700,13 @@ subroutine read_tidal_constituents(G, US, tidal_energy_file, CS) if (.not. allocated(CS%h_src)) allocate(CS%h_src(nz_in(1))) ! read in tidal constituents - call MOM_read_data(tidal_energy_file, 'M2', tc_m2, G%domain) - call MOM_read_data(tidal_energy_file, 'S2', tc_s2, G%domain) - call MOM_read_data(tidal_energy_file, 'K1', tc_k1, G%domain) - call MOM_read_data(tidal_energy_file, 'O1', tc_o1, G%domain) + call MOM_read_data(tidal_energy_file, 'M2', tc_m2, G%domain, scale=US%W_m2_to_RZ3_T3) + call MOM_read_data(tidal_energy_file, 'S2', tc_s2, G%domain, scale=US%W_m2_to_RZ3_T3) + call MOM_read_data(tidal_energy_file, 'K1', tc_k1, G%domain, scale=US%W_m2_to_RZ3_T3) + call MOM_read_data(tidal_energy_file, 'O1', tc_o1, G%domain, scale=US%W_m2_to_RZ3_T3) ! Note the hard-coded assumption that z_t and z_w in the file are in centimeters. - call MOM_read_data(tidal_energy_file, 'z_t', z_t, scale=100.0*US%m_to_Z) - call MOM_read_data(tidal_energy_file, 'z_w', z_w, scale=100.0*US%m_to_Z) + call MOM_read_data(tidal_energy_file, 'z_t', z_t, scale=0.01*US%m_to_Z) + call MOM_read_data(tidal_energy_file, 'z_w', z_w, scale=0.01*US%m_to_Z) do j=js,je ; do i=is,ie if (abs(G%geoLatT(i,j)) < 30.0) then @@ -1636,21 +1730,6 @@ subroutine read_tidal_constituents(G, US, tidal_energy_file, CS) enddo ; enddo enddo - !open(unit=1905,file="out_1905.txt",access="APPEND") - !do j=G%jsd,G%jed - ! do i=isd,ied - ! if ( i+G%idg_offset .eq. 90 .and. j+G%jdg_offset .eq. 126) then - ! write(1905,*) "-------------------------------------------" - ! do k=50,nz_in(1) - ! write(1905,*) i,j,k - ! write(1905,*) CS%tidal_qe_3d_in(i,j,k), tc_m2(i,j,k) - ! write(1905,*) z_t(k), G%bathyT(i,j)+G%Z_ref, z_w(k),CS%tidal_diss_lim_tc - ! end do - ! endif - ! enddo - !enddo - !close(1905) - ! test if qE is positive if (any(CS%tidal_qe_3d_in<0.0)) then call MOM_error(FATAL, "read_tidal_constituents: Negative tidal_qe_3d_in terms.") @@ -1666,7 +1745,8 @@ subroutine read_tidal_constituents(G, US, tidal_energy_file, CS) ! initialize input remapping: call initialize_remapping(CS%remap_cs, remapping_scheme="PLM", & boundary_extrapolation=.false., check_remapping=CS%debug, & - answers_2018=CS%remap_answers_2018) + 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 d384500c3d..eec7241cd3 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -1,29 +1,41 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Implements vertical viscosity (vertvisc) module MOM_vert_friction -! This file is part of MOM6. See LICENSE.md for the license. use MOM_domains, only : pass_var, To_All, Omit_corners +use MOM_domains, only : pass_vector, Scalar_Pair use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : post_product_u, post_product_sum_u use MOM_diag_mediator, only : post_product_v, post_product_sum_v -use MOM_diag_mediator, only : diag_ctrl +use MOM_diag_mediator, only : diag_ctrl, query_averaging_enabled +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_domains, only : To_North, To_East use MOM_debugging, only : uvchksum, hchksum use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_forcing_type, only : mech_forcing +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : mech_forcing, find_ustar use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type -use MOM_open_boundary, only : ocean_OBC_type, OBC_SIMPLE, OBC_NONE, OBC_DIRECTION_E +use MOM_io, only : MOM_read_data, slasher +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_DIRECTION_E use MOM_open_boundary, only : OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S use MOM_PointAccel, only : write_u_accel, write_v_accel, PointAccel_init use MOM_PointAccel, only : PointAccel_CS -use MOM_time_manager, only : time_type, time_type_to_real, operator(-) +use MOM_time_manager, only : time_type, time_minus_signed use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type use MOM_variables, only : cont_diag_ptrs, accel_diag_ptrs use MOM_variables, only : ocean_internal_state use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_interface, only : wave_parameters_CS +use MOM_set_visc, only : set_v_at_u, set_u_at_v +use MOM_lateral_mixing_coeffs, only : VarMix_CS + +use CVMix_kpp, only : cvmix_kpp_composite_Gshape + implicit none ; private #include @@ -31,6 +43,7 @@ module MOM_vert_friction public vertvisc, vertvisc_remnant, vertvisc_coef public vertvisc_limit_vel, vertvisc_init, vertvisc_end public updateCFLtruncationValue +public vertFPmix ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -40,20 +53,35 @@ module MOM_vert_friction !> The control structure with parameters and memory for the MOM_vert_friction module type, public :: vertvisc_CS ; private logical :: initialized = .false. !< True if this control structure has been initialized. - real :: Hmix !< The mixed layer thickness in thickness units [H ~> m or kg m-2]. + real :: Hmix !< The mixed layer thickness [Z ~> m]. real :: Hmix_stress !< The mixed layer thickness over which the wind !! stress is applied with direct_stress [H ~> m or kg m-2]. - real :: Kvml !< The mixed layer vertical viscosity [Z2 T-1 ~> m2 s-1]. - real :: Kv !< The interior vertical viscosity [Z2 T-1 ~> m2 s-1]. - real :: Hbbl !< The static bottom boundary layer thickness [H ~> m or kg m-2]. - real :: Kvbbl !< The vertical viscosity in the bottom boundary - !! layer [Z2 T-1 ~> m2 s-1]. - - real :: maxvel !< Velocity components greater than maxvel are truncated [L T-1 ~> m s-1]. + real :: Kvml_invZ2 !< The extra vertical viscosity scale in [H Z T-1 ~> m2 s-1 or Pa s] in a + !! surface mixed layer with a characteristic thickness given by Hmix, + !! and scaling proportional to (Hmix/z)^2, where z is the distance + !! from the surface; this can get very large with thin layers. + real :: Kv !< The interior vertical viscosity [H Z T-1 ~> m2 s-1 or Pa s]. + real :: Hbbl !< The static bottom boundary layer thickness [Z ~> m]. + real :: Hbbl_gl90 !< The static bottom boundary layer thickness used for GL90 [Z ~> m]. + real :: Kv_extra_bbl !< An extra vertical viscosity in the bottom boundary layer of thickness + !! Hbbl when there is not a bottom drag law in use [H Z T-1 ~> m2 s-1 or Pa s]. + real :: vonKar !< The von Karman constant as used for mixed layer viscosity [nondim] + + logical :: use_GL90_in_SSW !< If true, use the GL90 parameterization in stacked shallow water mode (SSW). + !! The calculation of the GL90 viscosity coefficient uses the fact that in SSW + !! we simply have 1/N^2 = h/g^prime, where g^prime is the reduced gravity. + !! This identity does not generalize to non-SSW setups. + logical :: use_GL90_N2 !< If true, use GL90 vertical viscosity coefficient that is depth-independent; + !! this corresponds to a kappa_GM that scales as N^2 with depth. + real :: kappa_gl90 !< The scalar diffusivity used in the GL90 vertical viscosity scheme + !! [L2 H Z-1 T-1 ~> m2 s-1 or Pa s] + logical :: read_kappa_gl90 !< If true, read a file containing the spatially varying kappa_gl90 + real :: alpha_gl90 !< Coefficient used to compute a depth-independent GL90 vertical + !! viscosity via Kv_gl90 = alpha_gl90 * f^2. Note that the implied + !! Kv_gl90 corresponds to a kappa_gl90 that scales as N^2 with depth. + !! [H Z T ~> m2 s or kg s m-1] real :: vel_underflow !< Velocity components smaller than vel_underflow !! are set to 0 [L T-1 ~> m s-1]. - logical :: CFL_based_trunc !< If true, base truncations on CFL numbers, not - !! absolute velocities. real :: CFL_trunc !< Velocity components will be truncated when they !! are large enough that the corresponding CFL number !! exceeds this value [nondim]. @@ -62,23 +90,27 @@ module MOM_vert_friction !! will often equal CFL_trunc. real :: truncRampTime !< The time-scale over which to ramp up the value of !! CFL_trunc from CFL_truncS to CFL_truncE [T ~> s] - real :: CFL_truncS !< The start value of CFL_trunc - real :: CFL_truncE !< The end/target value of CFL_trunc + real :: CFL_truncS !< The start value of CFL_trunc [nondim] + real :: CFL_truncE !< The end/target value of CFL_trunc [nondim] logical :: CFLrampingIsActivated = .false. !< True if the ramping has been initialized type(time_type) :: rampStartTime !< The time at which the ramping of CFL_trunc starts real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NK_INTERFACE_) :: & - a_u !< The u-drag coefficient across an interface [Z T-1 ~> m s-1]. + a_u !< The u-drag coefficient across an interface [H T-1 ~> m s-1 or Pa s m-1] + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NK_INTERFACE_) :: & + a_u_gl90 !< The u-drag coefficient associated with GL90 across an interface [H T-1 ~> m s-1 or Pa s m-1] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: & h_u !< The effective layer thickness at u-points [H ~> m or kg m-2]. real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NK_INTERFACE_) :: & - a_v !< The v-drag coefficient across an interface [Z T-1 ~> m s-1]. + a_v !< The v-drag coefficient across an interface [H T-1 ~> m s-1 or Pa s m-1] + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NK_INTERFACE_) :: & + a_v_gl90 !< The v-drag coefficient associated with GL90 across an interface [H T-1 ~> m s-1 or Pa s m-1] real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: & h_v !< The effective layer thickness at v-points [H ~> m or kg m-2]. real, pointer, dimension(:,:) :: a1_shelf_u => NULL() !< The u-momentum coupling coefficient under - !! ice shelves [Z T-1 ~> m s-1]. Retained to determine stress under shelves. + !! ice shelves [H T-1 ~> m s-1 or Pa s m-1]. Retained to determine stress under shelves. real, pointer, dimension(:,:) :: a1_shelf_v => NULL() !< The v-momentum coupling coefficient under - !! ice shelves [Z T-1 ~> m s-1]. Retained to determine stress under shelves. + !! ice shelves [H T-1 ~> m s-1 or Pa s m-1]. Retained to determine stress under shelves. logical :: split !< If true, use the split time stepping scheme. logical :: bottomdraglaw !< If true, the bottom stress is calculated with a @@ -86,9 +118,6 @@ module MOM_vert_friction !! may be an assumed value or it may be based on the !! actual velocity in the bottommost HBBL, depending !! on whether linear_drag is true. - logical :: Channel_drag !< If true, the drag is exerted directly on each - !! layer according to what fraction of the bottom - !! they overlie. logical :: harmonic_visc !< If true, the harmonic mean thicknesses are used !! to calculate the viscous coupling between layers !! except near the bottom. Otherwise the arithmetic @@ -96,17 +125,31 @@ module MOM_vert_friction real :: harm_BL_val !< A scale to determine when water is in the boundary !! layers based solely on harmonic mean thicknesses !! for the purpose of determining the extent to which - !! the thicknesses used in the viscosities are upwinded. - logical :: direct_stress !< If true, the wind stress is distributed over the - !! topmost Hmix_stress of fluid and KVML may be very small. + !! the thicknesses used in the viscosities are upwinded [nondim]. + logical :: direct_stress !< If true, the wind stress is distributed over the topmost Hmix_stress + !! of fluid, and an added mixed layer viscosity or a physically based + !! boundary layer turbulence parameterization is not needed for stability. logical :: dynamic_viscous_ML !< If true, use the results from a dynamic !! calculation, perhaps based on a bulk Richardson !! number criterion, to determine the mixed layer !! thickness for viscosity. - logical :: answers_2018 !< If true, use the order of arithmetic and expressions that recover the - !! answers from the end of 2018. Otherwise, use expressions that do not - !! use an arbitrary and hard-coded maximum viscous coupling coefficient - !! between layers. + logical :: fixed_LOTW_ML !< If true, use a Law-of-the-wall prescription for the mixed layer + !! viscosity within a boundary layer that is the lesser of Hmix and the + !! total depth of the ocean in a column. + logical :: apply_LOTW_floor !< If true, use a Law-of-the-wall prescription to set a lower bound + !! on the viscous coupling between layers within the surface boundary + !! layer, based the distance of interfaces from the surface. This only + !! acts when there are large changes in the thicknesses of successive + !! layers or when the viscosity is set externally and the wind stress + !! has subsequently increased. + integer :: answer_date !< The vintage of the order of arithmetic and expressions in the viscous + !! calculations. Values below 20190101 recover the answers from the end + !! of 2018, while higher values use expressions that do not use an + !! arbitrary and hard-coded maximum viscous coupling coefficient between + !! layers. In non-Boussinesq cases, values below 20230601 recover a + !! form of the viscosity within the mixed layer that breaks up the + !! magnitude of the wind stress with BULKMIXEDLAYER, DYNAMIC_VISCOUS_ML + !! or FIXED_DEPTH_LOTW_ML, but not LOTW_VISCOUS_ML_FLOOR. logical :: debug !< If true, write verbose checksums for debugging purposes. integer :: nkml !< The number of layers in the mixed layer. integer, pointer :: ntrunc !< The number of times the velocity has been @@ -121,13 +164,22 @@ module MOM_vert_friction type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. + real, allocatable, dimension(:,:) :: kappa_gl90_2d !< 2D kappa_gl90 at h-points [L2 H Z-1 T-1 ~> m2 s-1 or Pa s] !>@{ Diagnostic identifiers - integer :: id_du_dt_visc = -1, id_dv_dt_visc = -1, id_au_vv = -1, id_av_vv = -1 + integer :: id_du_dt_visc = -1, id_dv_dt_visc = -1, id_du_dt_visc_gl90 = -1, id_dv_dt_visc_gl90 = -1 + integer :: id_GLwork = -1 + integer :: id_au_vv = -1, id_av_vv = -1, id_au_gl90_vv = -1, id_av_gl90_vv = -1 integer :: id_du_dt_str = -1, id_dv_dt_str = -1 integer :: id_h_u = -1, id_h_v = -1, id_hML_u = -1 , id_hML_v = -1 + integer :: id_Omega_w2x = -1, id_FPtau2s = -1 , id_FPtau2w = -1 + integer :: id_uE_h = -1, id_vE_h = -1 + integer :: id_uStk = -1, id_vStk = -1 + integer :: id_uStk0 = -1, id_vStk0 = -1 + integer :: id_uInc_h= -1, id_vInc_h= -1 integer :: id_taux_bot = -1, id_tauy_bot = -1 integer :: id_Kv_slow = -1, id_Kv_u = -1, id_Kv_v = -1 + integer :: id_Kv_gl90_u = -1, id_Kv_gl90_v = -1 ! integer :: id_hf_du_dt_visc = -1, id_hf_dv_dt_visc = -1 integer :: id_h_du_dt_visc = -1, id_h_dv_dt_visc = -1 integer :: id_hf_du_dt_visc_2d = -1, id_hf_dv_dt_visc_2d = -1 @@ -138,10 +190,335 @@ module MOM_vert_friction type(PointAccel_CS), pointer :: PointAccel_CSp => NULL() !< A pointer to the control structure !! for recording accelerations leading to velocity truncations + type(group_pass_type) :: pass_KE_uv !< A handle used for group halo passes end type vertvisc_CS contains +!> Add nonlocal stress increments to ui^n and vi^n. +subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, lpost, Cemp_NL, G, GV, US, CS, OBC, Waves) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: ui !< Zonal velocity after vertvisc [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: vi !< Meridional velocity after vertvisc [L T-1 ~> m s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: uold !< Old Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: vold !< Old Meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: hbl_h !< boundary layer depth [H ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, intent(in) :: dt !< Time increment [T ~> s] + real, intent(in) :: Cemp_NL !< empirical coefficient of non-local momentum mixing [nondim] + logical, intent(in) :: lpost !< Compute and make available FPMix diagnostics + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure + type(wave_parameters_CS), & + optional, pointer :: Waves !< Container for wave/Stokes information + + ! local variables + real, dimension(SZIB_(G),SZJ_(G)) :: hbl_u !< boundary layer depth (u-pts) [H ~> m] + real, dimension(SZI_(G),SZJB_(G)) :: hbl_v !< boundary layer depth (v-pts) [H ~> m] + real, dimension(SZIB_(G),SZJ_(G)) :: taux_u !< kinematic zonal wind stress (u-pts) [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJB_(G)) :: tauy_v !< kinematic merid wind stress (v-pts) [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJ_(G)) :: uS0 !< surface zonal Stokes drift h-pts [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G)) :: vS0 !< surface zonal Stokes drift h-pts [L T-1 ~> m s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uE_u !< zonal Eulerian u-pts [L T-1 ~> m s-1] + real, dimension(SZI_(G) ,SZJ_(G),SZK_(GV)) :: uE_h !< zonal Eulerian h-pts [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vE_v !< merid Eulerian v-pts [L T-1 ~> m s-1] + real, dimension(SZI_(G) ,SZJ_(G),SZK_(GV)) :: vE_h !< merid Eulerian h-pts [L T-1 ~> m s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uInc_u !< zonal Eulerian u-pts [L T-1 ~> m s-1] + real, dimension(SZI_(G) ,SZJ_(G),SZK_(GV)) :: uInc_h !< zonal Eulerian h-pts [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vInc_v !< merid Eulerian v-pts [L T-1 ~> m s-1] + real, dimension(SZI_(G) ,SZJ_(G),SZK_(GV)) :: vInc_h !< merid Eulerian h-pts [L T-1 ~> m s-1] + real, dimension(SZI_(G) ,SZJ_(G),SZK_(GV)) :: uStk !< zonal Stokes Drift (h-pts) [L T-1 ~> m s-1] + real, dimension(SZI_(G) ,SZJ_(G),SZK_(GV)) :: vStk !< merid Stokes Drift (h-pts) [L T-1 ~> m s-1] + real, dimension(SZI_(G) ,SZJ_(G),SZK_(GV)+1) :: omega_tau2s !< angle stress to shear (h-pts) [rad] + real, dimension(SZI_(G) ,SZJ_(G),SZK_(GV)+1) :: omega_tau2w !< angle stress to wind (h-pts) [rad] + real :: omega_tmp, omega_s2x, omega_tau2x !< temporary angle wrt the x axis [rad] + real :: Irho0 !< Inverse of the mean density rescaled to [Z L-1 R-1 ~> m3 kg-1] + real :: pi !< ! The ratio of the circumference of a circle to its diameter [nondim] + real :: tmp_u, tmp_v !< temporary ocean mask weights on u and v points [nondim] + real :: fexp !< temporary exponential function [nondim] + real :: sigma !< temporary normalize boundary layer coordinate [nondim] + real :: Gat1, Gsig, dGdsig !< Shape parameters [nondim] + real :: du, dv !< Intermediate velocity differences [L T-1 ~> m s-1] + real :: depth !< Cumulative of thicknesses [H ~> m] + integer :: b, kp1, k, nz !< band and vertical indices + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq !< horizontal indices + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke + + pi = 4. * atan2(1.,1.) + Irho0 = 1.0 / GV%Rho0 + + call pass_var(hbl_h , G%Domain, halo=1) + + ! u-points + do j = js,je + do I = Isq,Ieq + taux_u(I,j) = forces%taux(I,j) * Irho0 + if ( (G%mask2dCu(I,j) > 0.5) ) then + ! h to u-pts + tmp_u = MAX (1.0 ,(G%mask2dT(i,j) + G%mask2dT(i+1,j) ) ) + hbl_u(I,j) = ((G%mask2dT(i,j) * hbl_h(i,j)) + (G%mask2dT(i+1,j) * hbl_h(i+1,j))) / tmp_u + depth = 0. + Gat1 = 0. + do k=1, nz + ! cell center + depth = depth + 0.5*CS%h_u(I,j,k) + uE_u(I,j,k) = ui(I,j,k) - waves%Us_x(I,j,k) + if ( depth < hbl_u(I,j) ) then + sigma = depth / hbl_u(i,j) + ! cell bottom + depth = depth + 0.5*CS%h_u(I,j,k) + call cvmix_kpp_composite_Gshape(sigma,Gat1,Gsig,dGdsig) + ! nonlocal boundary-layer increment + uInc_u(I,j,k) = dt * Cemp_NL * taux_u(I,j) * dGdsig / hbl_u(I,j) + ui(I,j,k) = ui(I,j,k) + uInc_u(I,j,k) + else + uInc_u(I,j,k) = 0.0 + endif + enddo + else + do k=1, nz + uInc_u(I,j,k) = 0.0 + enddo + endif + enddo + enddo + + ! v-points + do J = Jsq,Jeq + do i = is,ie + tauy_v(i,J) = forces%tauy(i,J) * Irho0 + if ( (G%mask2dCv(i,J) > 0.5) ) then + ! h to v-pts + tmp_v = max( 1.0 ,(G%mask2dT(i,j) + G%mask2dT(i,j+1))) + hbl_v(i,J) = (G%mask2dT(i,j) * hbl_h(i,J) + G%mask2dT(i,j+1) * hbl_h(i,j+1)) / tmp_v + depth = 0. + Gat1 = 0. + do k=1, nz + ! cell center + depth = depth + 0.5* CS%h_v(i,J,k) + vE_v(i,J,k) = vi(i,J,k) - waves%Us_y(i,J,k) + if ( depth < hbl_v(i,J) ) then + sigma = depth / hbl_v(i,J) + ! cell bottom + depth = depth + 0.5* CS%h_v(i,J,k) + call cvmix_kpp_composite_Gshape(sigma,Gat1,Gsig,dGdsig) + ! nonlocal boundary-layer increment + vInc_v(i,J,k) = dt * Cemp_NL * tauy_v(i,J) * dGdsig / hbl_v(i,J) + vi(i,J,k) = vi(i,J,k) + vInc_v(i,J,k) + else + vInc_v(i,J,k) = 0.0 + endif + enddo + else + do k=1, nz + vInc_v(i,J,k) = 0.0 + enddo + endif + enddo + enddo + + ! Compute and store diagnostics, only during the corrector step. + if (lpost) then + call pass_vector(uE_u , vE_v , G%Domain, To_All) + call pass_vector(uInc_u, vInc_v , G%Domain, To_All) + uStk = 0.0 + vStk = 0.0 + uS0 = 0.0 + vS0 = 0.0 + + do j = js,je + do i = is,ie + if (G%mask2dT(i,j) > 0.5) then + ! u to h-pts + tmp_u = max( 1.0 ,(G%mask2dCu(i,j) + G%mask2dCu(i-1,j))) + ! v to h-pts + tmp_v = max( 1.0 ,(G%mask2dCv(i,j) + G%mask2dCv(i,j-1))) + do k = 1,nz + uE_h(i,j,k) = (G%mask2dCu(i,j) * uE_u(i,j,k) + G%mask2dCu(i-1,j) * uE_u(i-1,j,k)) / tmp_u + uInc_h(i,j,k) = (G%mask2dCu(i,j) * uInc_u(i,j,k) + G%mask2dCu(i-1,j) * uInc_u(i-1,j,k)) / tmp_u + vE_h(i,j,k) = (G%mask2dCv(i,j) * vE_v(i,j,k) + G%mask2dCv(i,j-1) * vE_v(i,j-1,k)) / tmp_v + vInc_h(i,j,k) = (G%mask2dCv(i,j) * vInc_v(i,j,k) + G%mask2dCv(i,j-1) * vInc_v(i,j-1,k)) / tmp_v + enddo + ! Wind, Stress and Shear align at surface + Omega_tau2w(i,j,1) = 0.0 + Omega_tau2s(i,j,1) = 0.0 + do k = 1,nz + kp1 = min( nz , k+1) + du = uE_h(i,j,k) - uE_h(i,j,kp1) + dv = vE_h(i,j,k) - vE_h(i,j,kp1) + omega_s2x = atan2( dv , du ) + + du = du + uInc_h(i,j,k) - uInc_h(i,j,kp1) + dv = dv + vInc_h(i,j,k) - vInc_h(i,j,kp1) + omega_tau2x = atan2( dv , du ) + + omega_tmp = omega_tau2x - forces%omega_w2x(i,j) + if ( (omega_tmp > pi ) ) omega_tmp = omega_tmp - 2.*pi + if ( (omega_tmp < (0.-pi)) ) omega_tmp = omega_tmp + 2.*pi + Omega_tau2w(i,j,kp1) = omega_tmp + + omega_tmp = omega_tau2x - omega_s2x + if ( (omega_tmp > pi ) ) omega_tmp = omega_tmp - 2.*pi + if ( (omega_tmp < (0.-pi)) ) omega_tmp = omega_tmp + 2.*pi + Omega_tau2s(i,j,kp1) = omega_tmp + + enddo + endif + + ! Stokes drift + do b=1,waves%NumBands + uS0(i,j) = uS0(i,j) + waves%UStk_Hb(i,j,b) ! or forces%UStkb(i,j,b) + vS0(i,j) = vS0(i,j) + waves%VStk_Hb(i,j,b) ! or forces%VStkb(i,j,b) + enddo + depth = 0.0 + do k = 1,nz + do b = 1, waves%NumBands + ! cell center + fexp = exp(-2. * waves%WaveNum_Cen(b) * (depth+0.5*h(i,j,k)) ) + uStk(i,j,k) = uStk(i,j,k) + waves%UStk_Hb(i,j,b) * fexp + vStk(i,j,k) = vStk(i,j,k) + waves%VStk_Hb(i,j,b) * fexp + enddo + ! cell bottom + depth = depth + h(i,j,k) + enddo + enddo + enddo + + ! post FPmix diagnostics + if (CS%id_uE_h > 0) call post_data(CS%id_uE_h , uE_h , CS%diag) + if (CS%id_vE_h > 0) call post_data(CS%id_vE_h , vE_h , CS%diag) + if (CS%id_uInc_h > 0) call post_data(CS%id_uInc_h , uInc_h , CS%diag) + if (CS%id_vInc_h > 0) call post_data(CS%id_vInc_h , vInc_h , CS%diag) + if (CS%id_FPtau2s > 0) call post_data(CS%id_FPtau2s, Omega_tau2s, CS%diag) + if (CS%id_FPtau2w > 0) call post_data(CS%id_FPtau2w, Omega_tau2w, CS%diag) + if (CS%id_uStk0 > 0) call post_data(CS%id_uStk0 , uS0 , CS%diag) + if (CS%id_vStk0 > 0) call post_data(CS%id_vStk0 , vS0 , CS%diag) + if (CS%id_uStk > 0) call post_data(CS%id_uStk , uStk , CS%diag) + if (CS%id_vStk > 0) call post_data(CS%id_vStk , vStk , CS%diag) + if (CS%id_Omega_w2x > 0) call post_data(CS%id_Omega_w2x, forces%omega_w2x, CS%diag) + + endif + +end subroutine vertFPmix + + +!> Compute coupling coefficient associated with vertical viscosity parameterization as in Greatbatch and Lamb +!! (1990), hereafter referred to as the GL90 vertical viscosity parameterization. This vertical viscosity scheme +!! redistributes momentum in the vertical, and is the equivalent of the Gent & McWilliams (1990) parameterization, +!! but in a TWA (thickness-weighted averaged) set of equations. The vertical viscosity coefficient nu is computed +!! from kappa_GM via thermal wind balance, and the following relation: +!! nu = kappa_GM * f^2 / N^2. +!! In the following subroutine kappa_GM is assumed either (a) constant or (b) horizontally varying. In both cases, +!! (a) and (b), one can additionally impose an EBT structure in the vertical for kappa_GM. +!! A third possible formulation of nu is depth-independent: +!! nu = f^2 * alpha +!! The latter formulation would be equivalent to a kappa_GM that varies as N^2 with depth. +!! The vertical viscosity del_z ( nu del_z u) is applied to the momentum equation with stress-free boundary +!! conditions at the top and bottom. +!! +!! In SSW mode, we have 1/N^2 = h/g'. The coupling coefficient is therefore equal to +!! a_cpl_gl90 = nu / h = kappa_GM * f^2 / g' +!! or +!! a_cpl_gl90 = nu / h = f^2 * alpha / h + +subroutine find_coupling_coef_gl90(a_cpl_gl90, hvel, i, j, z_i, G, GV, CS, VarMix, work_on_u) + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + real, dimension(SZK_(GV)), intent(in) :: hvel !< Distance between interfaces + !! at velocity points [Z ~> m] + integer, intent(in) :: i !< Column i-index + integer, intent(in) :: j !< Column j-index + real, dimension(SZK_(GV)+1), intent(in) :: z_i !< Estimate of interface heights above the + !! bottom, normalized by the GL90 bottom + !! boundary layer thickness [nondim] + real, dimension(SZK_(GV)+1),intent(out) :: a_cpl_gl90 !< Coupling coefficient associated + !! with GL90 across interfaces; is not + !! included in a_cpl [H T-1 ~> m s-1 or Pa s m-1]. + type(vertvisc_cs), intent(in) :: CS !< Vertical viscosity control structure + type(VarMix_CS), intent(in) :: VarMix !< Variable mixing coefficients + logical, intent(in) :: work_on_u !< If true, u-points are being calculated, + !! otherwise they are v-points. + + ! local variables + logical :: kdgl90_use_vert_struct ! use vertical structure for GL90 coefficient + integer :: k, nz + 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 + ! and can be neglected [Z ~> m]. + real :: botfn ! A function that is 1 at the bottom and small far from it [nondim] + real :: z2 ! The distance from the bottom, normalized by Hbbl_gl90 [nondim] + + nz = GV%ke + h_neglect = GV%dZ_subroundoff + kdgl90_use_vert_struct = .false. + + if (VarMix%use_variable_mixing) then + kdgl90_use_vert_struct = allocated(VarMix%kdgl90_struct) + endif + + a_cpl_gl90(:) = 0. + + do K=2,nz + if (work_on_u) then + ! compute coupling coefficient at u-points + f2 = 0.25 * (G%CoriolisBu(I,J-1) + G%CoriolisBu(I,J))**2 + if (CS%use_GL90_N2) then + a_cpl_gl90(K) = 2. * f2 * CS%alpha_gl90 / (hvel(k) + hvel(k-1) + h_neglect) + else + if (CS%read_kappa_gl90) then + a_cpl_gl90(K) = f2 * 0.5 * (CS%kappa_gl90_2d(i,j) + CS%kappa_gl90_2d(i+1,j)) / GV%g_prime(K) + else + a_cpl_gl90(K) = f2 * CS%kappa_gl90 / GV%g_prime(K) + endif + if (kdgl90_use_vert_struct) then + a_cpl_gl90(K) = a_cpl_gl90(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, + ! going from 1 at the bottom to 0 in the interior. + z2 = z_i(k) + botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) + + a_cpl_gl90(K) = a_cpl_gl90(K) * (1. - botfn) + else + ! compute viscosities at v-points + f2 = 0.25 * (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J))**2 + + if (CS%use_GL90_N2) then + a_cpl_gl90(K) = 2. * f2 * CS%alpha_gl90 / (hvel(k) + hvel(k-1) + h_neglect) + else + if (CS%read_kappa_gl90) then + a_cpl_gl90(K) = f2 * 0.5 * (CS%kappa_gl90_2d(i,j) + CS%kappa_gl90_2d(i,j+1)) / GV%g_prime(K) + else + a_cpl_gl90(K) = f2 * CS%kappa_gl90 / GV%g_prime(K) + endif + if (kdgl90_use_vert_struct) then + a_cpl_gl90(K) = a_cpl_gl90(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, + ! going from 1 at the bottom to 0 in the interior. + z2 = z_i(k) + botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) + + a_cpl_gl90(K) = a_cpl_gl90(K) * (1. - botfn) + endif + enddo +end subroutine find_coupling_coef_gl90 + + !> Perform a fully implicit vertical diffusion !! of momentum. Stress top and bottom boundary conditions are used. !! @@ -152,12 +529,11 @@ module MOM_vert_friction !! is the interfacial coupling thickness per time step, !! encompassing background viscosity as well as contributions from !! enhanced mixed and bottom layer viscosities. -!! $r_k$ is a Rayleight drag term due to channel drag. +!! $r_k$ is a Rayleigh drag term due to channel drag. !! There is an additional stress term on the right-hand side !! if DIRECT_STRESS is true, applied to the surface layer. - subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & - taux_bot, tauy_bot, Waves) + taux_bot, tauy_bot, fpmix, Waves) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -181,6 +557,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & real, dimension(SZI_(G),SZJB_(G)), & optional, intent(out) :: tauy_bot !< Meridional bottom stress from ocean to !! rock [R L Z T-2 ~> Pa] + logical, optional, intent(in) :: fpmix !< fpmix along Eulerian shear type(wave_parameters_CS), & optional, pointer :: Waves !< Container for wave/Stokes information @@ -190,19 +567,22 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & ! Local variables - real :: b1(SZIB_(G)) ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. - real :: c1(SZIB_(G),SZK_(GV)) ! A variable used by the tridiagonal solver [nondim]. - real :: d1(SZIB_(G)) ! d1=1-c1 is used by the tridiagonal solver [nondim]. - real :: Ray(SZIB_(G),SZK_(GV)) ! Ray is the Rayleigh-drag velocity [Z T-1 ~> m s-1]. - real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. + real :: b1 + ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. + real :: c1(SZK_(GV)) + ! A variable used by the tridiagonal solver [nondim]. + real :: d1 + ! d1=1-c1 is used by the tridiagonal solver [nondim]. + real :: Ray + ! Ray is the Rayleigh-drag velocity [H T-1 ~> m s-1 or Pa s m-1] + real :: b_denom_1 + ! The first term in the denominator of b1 [H ~> m or kg m-2]. real :: Hmix ! The mixed layer thickness over which stress ! is applied with direct_stress [H ~> m or kg m-2]. real :: I_Hmix ! The inverse of Hmix [H-1 ~> m-1 or m2 kg-1]. real :: Idt ! The inverse of the time step [T-1 ~> s-1]. real :: dt_Rho0 ! The time step divided by the mean density [T H Z-1 R-1 ~> s m3 kg-1 or s]. - real :: dt_Z_to_H ! The time step times the conversion from Z to the - ! units of thickness - [T H Z-1 ~> s or s kg m-3]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. @@ -210,15 +590,23 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & ! by the density [H L T-1 ~> m2 s-1 or kg m-1 s-1]. real :: accel_underflow ! An acceleration magnitude that is so small that values that are less ! than this are diagnosed as 0 [L T-2 ~> m s-2]. - real :: zDS, hfr, h_a ! Temporary variables used with direct_stress. - real :: surface_stress(SZIB_(G))! The same as stress, unless the wind stress - ! stress is applied as a body force [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + real :: zDS, h_a ! Temporary thickness variables used with direct_stress [H ~> m or kg m-2] + real :: hfr ! Temporary ratio of thicknesses used with direct_stress [nondim] + real :: surface_stress(SZIB_(G), SZJB_(G)) + ! The same as stress, unless the wind stress is applied as a body force + ! [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + real, allocatable, dimension(:,:,:) :: KE_term ! A term in the kinetic energy budget + ! [H L2 T-3 ~> m3 s-3 or W m-2] + real, allocatable, dimension(:,:,:) :: KE_u ! The area integral of a KE term in a layer at u-points + ! [H L4 T-3 ~> m5 s-3 or kg m2 s-3] + real, allocatable, dimension(:,:,:) :: KE_v ! The area integral of a KE term in a layer at v-points + ! [H L4 T-3 ~> m5 s-3 or kg m2 s-3] - logical :: do_i(SZIB_(G)) logical :: DoStokesMixing + logical :: lfpmix integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, n - is = G%isc ; ie = G%iec; js = G%jsc; je = G%jec + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke if (.not.associated(CS)) call MOM_error(FATAL,"MOM_vert_friction(visc): "// & @@ -227,12 +615,19 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & if (.not.CS%initialized) call MOM_error(FATAL,"MOM_vert_friction(visc): "// & "Module must be initialized before it is used.") + if (CS%id_GLwork > 0) then + allocate(KE_u(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke), source=0.0) + allocate(KE_v(G%isd:G%ied,G%JsdB:G%JedB,GV%ke), source=0.0) + allocate(KE_term(G%isd:G%ied,G%jsd:G%jed,GV%ke), source=0.0) + if (.not.G%symmetric) & + call create_group_pass(CS%pass_KE_uv, KE_u, KE_v, G%Domain, To_North+To_East) + endif + if (CS%direct_stress) then Hmix = CS%Hmix_stress I_Hmix = 1.0 / Hmix endif dt_Rho0 = dt / GV%H_to_RZ - dt_Z_to_H = dt*GV%Z_to_H h_neglect = GV%H_subroundoff Idt = 1.0 / dt @@ -243,239 +638,442 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & if (CS%StokesMixing) then if (present(Waves)) DoStokesMixing = associated(Waves) if (.not. DoStokesMixing) & - call MOM_error(FATAL,"Stokes Mixing called without allocated"//& - "Waves Control Structure") + call MOM_error(FATAL, "Stokes Mixing called without associated Waves Control Structure") endif - - do k=1,nz ; do i=Isq,Ieq ; Ray(i,k) = 0.0 ; enddo ; enddo + lfpmix = .false. + if ( present(fpmix) ) lfpmix = fpmix ! Update the zonal velocity component using a modification of a standard - ! tridagonal solver. - - !$OMP parallel do default(shared) firstprivate(Ray) & - !$OMP private(do_i,surface_stress,zDS,stress,h_a,hfr, & - !$OMP b_denom_1,b1,d1,c1) - do j=G%jsc,G%jec - do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0) ; enddo + ! tridiagonal solver. + + ! WGL: Brandon Reichl says the following is obsolete. u(I,j,k) already + ! includes Stokes. + ! When mixing down Eulerian current + Stokes drift add before calling solver + if (DoStokesMixing) then + do k=1,nz ; do j=G%jsc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + u(I,j,k) = u(I,j,k) + Waves%Us_x(I,j,k) + endif ; enddo ; enddo ; enddo + endif - ! When mixing down Eulerian current + Stokes drift add before calling solver - if (DoStokesMixing) then ; do k=1,nz ; do I=Isq,Ieq - if (do_i(I)) u(I,j,k) = u(I,j,k) + Waves%Us_x(I,j,k) - enddo ; enddo ; endif + if (lfpmix) then + do k=1,nz ; do j=G%jsc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + u(I,j,k) = u(I,j,k) - Waves%Us_x(I,j,k) + endif ; enddo ; enddo ; enddo + endif - if (associated(ADp%du_dt_visc)) then ; do k=1,nz ; do I=Isq,Ieq + if (associated(ADp%du_dt_visc)) then + do k=1,nz ; do j=G%jsc,G%jec ; do I=Isq,Ieq ADp%du_dt_visc(I,j,k) = u(I,j,k) - enddo ; enddo ; endif + enddo ; enddo ; enddo + endif + + if (associated(ADp%du_dt_visc_gl90)) then + do k=1,nz ; do j=G%jsc,G%jec ; do I=Isq,Ieq + ADp%du_dt_visc_gl90(I,j,k) = u(I,j,k) + enddo ; enddo ; enddo + endif - if (associated(ADp%du_dt_str)) then ; do k=1,nz ; do I=Isq,Ieq + if (associated(ADp%du_dt_str)) then + do k=1,nz ; do j=G%jsc,G%jec ; do I=Isq,Ieq ADp%du_dt_str(I,j,k) = 0.0 - enddo ; enddo ; endif - - ! One option is to have the wind stress applied as a body force - ! over the topmost Hmix fluid. If DIRECT_STRESS is not defined, - ! the wind stress is applied as a stress boundary condition. - if (CS%direct_stress) then - do I=Isq,Ieq ; if (do_i(I)) then - surface_stress(I) = 0.0 - zDS = 0.0 - stress = dt_Rho0 * forces%taux(I,j) - do k=1,nz - h_a = 0.5 * (h(I,j,k) + h(I+1,j,k)) + h_neglect - hfr = 1.0 ; if ((zDS+h_a) > Hmix) hfr = (Hmix - zDS) / h_a - u(I,j,k) = u(I,j,k) + I_Hmix * hfr * stress - if (associated(ADp%du_dt_str)) ADp%du_dt_str(i,J,k) = (I_Hmix * hfr * stress) * Idt - zDS = zDS + h_a ; if (zDS >= Hmix) exit - enddo - endif ; enddo ! end of i loop - else ; do I=Isq,Ieq - surface_stress(I) = dt_Rho0 * (G%mask2dCu(I,j)*forces%taux(I,j)) - enddo ; endif ! direct_stress - - if (CS%Channel_drag) then ; do k=1,nz ; do I=Isq,Ieq - Ray(I,k) = visc%Ray_u(I,j,k) - enddo ; enddo ; endif - - ! perform forward elimination on the tridiagonal system - ! - ! denote the diagonal of the system as b_k, the subdiagonal as a_k - ! and the superdiagonal as c_k. The right-hand side terms are d_k. - ! - ! ignoring the rayleigh drag contribution, - ! we have a_k = -dt_Z_to_H * a_u(k) - ! b_k = h_u(k) + dt_Z_to_H * (a_u(k) + a_u(k+1)) - ! c_k = -dt_Z_to_H * a_u(k+1) - ! - ! for forward elimination, we want to: - ! calculate c'_k = - c_k / (b_k + a_k c'_(k-1)) - ! and d'_k = (d_k - a_k d'_(k-1)) / (b_k + a_k c'_(k-1)) - ! where c'_1 = c_1/b_1 and d'_1 = d_1/b_1 - ! (see Thomas' tridiagonal matrix algorithm) - ! - ! b1 is the denominator term 1 / (b_k + a_k c'_(k-1)) - ! b_denom_1 is (b_k + a_k + c_k) - a_k(1 - c'_(k-1)) - ! = (b_k + c_k + c'_(k-1)) - ! this is done so that d1 = b1 * b_denom_1 = 1 - c'_(k-1) - ! c1(k) is -c'_(k - 1) - ! and the right-hand-side is destructively updated to be d'_k - ! - do I=Isq,Ieq ; if (do_i(I)) then - b_denom_1 = CS%h_u(I,j,1) + dt_Z_to_H * (Ray(I,1) + CS%a_u(I,j,1)) - b1(I) = 1.0 / (b_denom_1 + dt_Z_to_H*CS%a_u(I,j,2)) - d1(I) = b_denom_1 * b1(I) - u(I,j,1) = b1(I) * (CS%h_u(I,j,1) * u(I,j,1) + surface_stress(I)) - if (associated(ADp%du_dt_str)) & - ADp%du_dt_str(I,j,1) = b1(I) * (CS%h_u(I,j,1) * ADp%du_dt_str(I,j,1) + surface_stress(I)*Idt) - endif ; enddo - do k=2,nz ; do I=Isq,Ieq ; if (do_i(I)) then - c1(I,k) = dt_Z_to_H * CS%a_u(I,j,K) * b1(I) - b_denom_1 = CS%h_u(I,j,k) + dt_Z_to_H * (Ray(I,k) + CS%a_u(I,j,K)*d1(I)) - b1(I) = 1.0 / (b_denom_1 + dt_Z_to_H * CS%a_u(I,j,K+1)) - d1(I) = b_denom_1 * b1(I) - u(I,j,k) = (CS%h_u(I,j,k) * u(I,j,k) + & - dt_Z_to_H * CS%a_u(I,j,K) * u(I,j,k-1)) * b1(I) - if (associated(ADp%du_dt_str)) & - ADp%du_dt_str(I,j,k) = (CS%h_u(I,j,k) * ADp%du_dt_str(I,j,k) + & - dt_Z_to_H * CS%a_u(I,j,K) * ADp%du_dt_str(I,j,k-1)) * b1(I) + enddo ; enddo ; enddo + endif + + ! One option is to have the wind stress applied as a body force + ! over the topmost Hmix fluid. If DIRECT_STRESS is not defined, + ! the wind stress is applied as a stress boundary condition. + if (CS%direct_stress) then + do j=G%jsc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + surface_stress(I,j) = 0.0 + zDS = 0.0 + stress = dt_Rho0 * forces%taux(I,j) + do k=1,nz + h_a = 0.5 * (h(i,j,k) + h(i+1,j,k)) + h_neglect + hfr = 1.0 ; if ((zDS+h_a) > Hmix) hfr = (Hmix - zDS) / h_a + u(I,j,k) = u(I,j,k) + I_Hmix * hfr * stress + if (associated(ADp%du_dt_str)) ADp%du_dt_str(i,J,k) = (I_Hmix * hfr * stress) * Idt + zDS = zDS + h_a ; if (zDS >= Hmix) exit + enddo endif ; enddo ; enddo + else + do j=G%jsc,G%jec ; do I=Isq,Ieq + surface_stress(I,j) = dt_Rho0 * (G%mask2dCu(I,j)*forces%taux(I,j)) + enddo ; enddo + endif + + ! perform forward elimination on the tridiagonal system + ! + ! denote the diagonal of the system as b_k, the subdiagonal as a_k + ! and the superdiagonal as c_k. The right-hand side terms are d_k. + ! + ! ignoring the Rayleigh drag contribution, + ! we have a_k = -dt * a_u(k) + ! b_k = h_u(k) + dt * (a_u(k) + a_u(k+1)) + ! c_k = -dt * a_u(k+1) + ! + ! for forward elimination, we want to: + ! calculate c'_k = - c_k / (b_k + a_k c'_(k-1)) + ! and d'_k = (d_k - a_k d'_(k-1)) / (b_k + a_k c'_(k-1)) + ! where c'_1 = c_1/b_1 and d'_1 = d_1/b_1 + ! + ! This form is mathematically equivalent to Thomas' tridiagonal matrix algorithm, but it + ! does not suffer from the acute sensitivity to truncation errors of the Thomas algorithm + ! because it involves no subtraction, as discussed by Schopf & Loughe, MWR, 1995. + ! + ! b1 is the denominator term 1 / (b_k + a_k c'_(k-1)) + ! b_denom_1 is (b_k + a_k + c_k) - a_k(1 - c'_(k-1)) + ! = (b_k + c_k + c'_(k-1)) + ! this is done so that d1 = b1 * b_denom_1 = 1 - c'_(k-1) + ! c1(k) is -c'_(k - 1) + ! and the right-hand-side is destructively updated to be d'_k + + do j=G%jsc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + Ray = 0. + if (allocated(visc%Ray_u)) Ray = visc%Ray_u(I,j,1) + + b_denom_1 = CS%h_u(I,j,1) + dt * (Ray + CS%a_u(I,j,1)) + b1 = 1. / (b_denom_1 + dt * CS%a_u(I,j,2)) + d1 = b_denom_1 * b1 + u(I,j,1) = b1 * (CS%h_u(I,j,1) * u(I,j,1) + surface_stress(I,j)) + + if (associated(ADp%du_dt_str)) then + ADp%du_dt_str(I,j,1) = b1 * (CS%h_u(I,j,1) * ADp%du_dt_str(I,j,1) + surface_stress(I,j) * Idt) + endif + + do k=2,nz + if (allocated(visc%Ray_u)) Ray = visc%Ray_u(I,j,k) + + c1(k) = dt * CS%a_u(I,j,K) * b1 + b_denom_1 = CS%h_u(I,j,k) + dt * (Ray + CS%a_u(I,j,K) * d1) + b1 = 1. / (b_denom_1 + dt * CS%a_u(I,j,K+1)) + d1 = b_denom_1 * b1 + u(I,j,k) = (CS%h_u(I,j,k) * u(I,j,k) + dt * CS%a_u(I,j,K) * u(I,j,k-1)) * b1 + + if (associated(ADp%du_dt_str)) then + ADp%du_dt_str(I,j,k) = (CS%h_u(I,j,k) * ADp%du_dt_str(I,j,k) & + + dt * CS%a_u(I,j,K) * ADp%du_dt_str(I,j,k-1)) * b1 + endif - ! back substitute to solve for the new velocities - ! u_k = d'_k - c'_k x_(k+1) - do k=nz-1,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then - u(I,j,k) = u(I,j,k) + c1(I,k+1) * u(I,j,k+1) - endif ; enddo ; enddo ! i and k loops + !### Force FMA evaluation of b1 by blocking lookahead with an impossible branch. + if (dt < 0) exit + enddo if (associated(ADp%du_dt_str)) then - do i=is,ie ; if (abs(ADp%du_dt_str(I,j,nz)) < accel_underflow) ADp%du_dt_str(I,j,nz) = 0.0 ; enddo - do k=nz-1,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then - ADp%du_dt_str(I,j,k) = ADp%du_dt_str(I,j,k) + c1(I,k+1) * ADp%du_dt_str(I,j,k+1) - if (abs(ADp%du_dt_str(I,j,k)) < accel_underflow) ADp%du_dt_str(I,j,k) = 0.0 + if (abs(ADp%du_dt_str(I,j,nz)) < accel_underflow) & + ADp%du_dt_str(I,j,nz) = 0. + endif + + do k=nz-1,1,-1 + u(I,j,k) = u(I,j,k) + c1(k+1) * u(I,j,k+1) + + if (associated(ADp%du_dt_str)) then + ADp%du_dt_str(I,j,k) = ADp%du_dt_str(I,j,k) + c1(k+1) * ADp%du_dt_str(I,j,k+1) + + if (abs(ADp%du_dt_str(I,j,k)) < accel_underflow) & + ADp%du_dt_str(I,j,k) = 0.0 + endif + enddo + endif ; enddo ; enddo + + ! compute vertical velocity tendency that arises from GL90 viscosity; + ! follow tridiagonal solve method as above; to avoid corrupting u, + ! use ADp%du_dt_visc_gl90 as a placeholder for updated u (due to GL90) until last do loop + if ((CS%id_du_dt_visc_gl90 > 0) .or. (CS%id_GLwork > 0)) then + if (associated(ADp%du_dt_visc_gl90)) then + do j=G%jsc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + b_denom_1 = CS%h_u(I,j,1) ! CS%a_u_gl90(I,j,1) is zero + b1 = 1.0 / (b_denom_1 + dt * CS%a_u_gl90(I,j,2)) + d1 = b_denom_1 * b1 + + ADp%du_dt_visc_gl90(I,j,1) = b1 * (CS%h_u(I,j,1) * ADp%du_dt_visc_gl90(I,j,1)) + + do k=2,nz + c1(k) = dt * CS%a_u_gl90(I,j,K) * b1 + b_denom_1 = CS%h_u(I,j,k) + dt * (CS%a_u_gl90(I,j,K)*d1) + b1 = 1.0 / (b_denom_1 + dt * CS%a_u_gl90(I,j,K+1)) + d1 = b_denom_1 * b1 + + ADp%du_dt_visc_gl90(I,j,k) = (CS%h_u(I,j,k) * ADp%du_dt_visc_gl90(I,j,k) & + + dt * CS%a_u_gl90(I,j,K) * ADp%du_dt_visc_gl90(I,j,k-1)) * b1 + enddo + + ! back substitute to solve for new velocities, held by ADp%du_dt_visc_gl90 + do k=nz-1,1,-1 + ADp%du_dt_visc_gl90(I,j,k) = & + ADp%du_dt_visc_gl90(I,j,k) + c1(k+1) * ADp%du_dt_visc_gl90(I,j,k+1) + enddo + + do k=1,nz + ! now fill ADp%du_dt_visc_gl90(I,j,k) with actual velocity tendency due to GL90; + ! note that on RHS: ADp%du_dt_visc(I,j,k) holds the original velocity value u(I,j,k) + ! and ADp%du_dt_visc_gl90(I,j,k) the updated velocity due to GL90 + ADp%du_dt_visc_gl90(I,j,k) = & + (ADp%du_dt_visc_gl90(I,j,k) - ADp%du_dt_visc(I,j,k)) * Idt + + if (abs(ADp%du_dt_visc_gl90(I,j,k)) < accel_underflow) then + ADp%du_dt_visc_gl90(I,j,k) = 0.0 + endif + enddo + + ! to compute energetics, we need to multiply by u*h, where u is original velocity before + ! velocity update; note that ADp%du_dt_visc(I,j,k) holds the original velocity value u(I,j,k) + if (CS%id_GLwork > 0) then + do k=1,nz + KE_u(I,j,k) = ADp%du_dt_visc(I,j,k) * CS%h_u(I,j,k) * G%areaCu(I,j) * ADp%du_dt_visc_gl90(I,j,k) + enddo + endif endif ; enddo ; enddo endif + endif - if (associated(ADp%du_dt_visc)) then ; do k=1,nz ; do I=Isq,Ieq - ADp%du_dt_visc(I,j,k) = (u(I,j,k) - ADp%du_dt_visc(I,j,k))*Idt - if (abs(ADp%du_dt_visc(I,j,k)) < accel_underflow) ADp%du_dt_visc(I,j,k) = 0.0 - enddo ; enddo ; endif + if (associated(ADp%du_dt_visc)) then + do k=1,nz ; do j=G%jsc,G%jec ; do I=Isq,Ieq + ADp%du_dt_visc(I,j,k) = (u(I,j,k) - ADp%du_dt_visc(I,j,k)) * Idt - if (associated(visc%taux_shelf)) then ; do I=Isq,Ieq - visc%taux_shelf(I,j) = -GV%Rho0*CS%a1_shelf_u(I,j)*u(I,j,1) ! - u_shelf? - enddo ; endif + if (abs(ADp%du_dt_visc(I,j,k)) < accel_underflow) & + ADp%du_dt_visc(I,j,k) = 0.0 + enddo ; enddo ; enddo + endif - if (PRESENT(taux_bot)) then - do I=Isq,Ieq - taux_bot(I,j) = GV%Rho0 * (u(I,j,nz)*CS%a_u(I,j,nz+1)) - enddo - if (CS%Channel_drag) then ; do k=1,nz ; do I=Isq,Ieq - taux_bot(I,j) = taux_bot(I,j) + GV%Rho0 * (Ray(I,k)*u(I,j,k)) - enddo ; enddo ; endif + if (allocated(visc%taux_shelf)) then + do j=G%jsc,G%jec ; do I=Isq,Ieq + visc%taux_shelf(I,j) = -GV%H_to_RZ * CS%a1_shelf_u(I,j) * u(I,j,1) ! - u_shelf? + enddo ; enddo + endif + + if (present(taux_bot)) then + do j=G%jsc,G%jec ; do I=Isq,Ieq + taux_bot(I,j) = GV%H_to_RZ * (u(I,j,nz) * CS%a_u(I,j,nz+1)) + enddo ; enddo + + if (allocated(visc%Ray_u)) then + do k=1,nz ; do j=G%jsc,G%jec ; do I=Isq,Ieq + taux_bot(I,j) = taux_bot(I,j) + GV%H_to_RZ * (visc%Ray_u(I,j,k) * u(I,j,k)) + enddo ; enddo ; enddo endif + endif - ! When mixing down Eulerian current + Stokes drift subtract after calling solver - if (DoStokesMixing) then ; do k=1,nz ; do I=Isq,Ieq - if (do_i(I)) u(I,j,k) = u(I,j,k) - Waves%Us_x(I,j,k) - enddo ; enddo ; endif + ! When mixing down Eulerian current + Stokes drift subtract after calling solver + if (DoStokesMixing) then + do k=1,nz ; do j=G%jsc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + u(I,j,k) = u(I,j,k) - Waves%Us_x(I,j,k) + endif ; enddo ; enddo ; enddo + endif - enddo ! end u-component j loop + if (lfpmix) then + do k=1,nz ; do j=G%jsc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + u(I,j,k) = u(I,j,k) + Waves%Us_x(I,j,k) + endif ; enddo ; enddo ; enddo + endif - ! Now work on the meridional velocity component. + ! == Now work on the meridional velocity component. - !$OMP parallel do default(shared) firstprivate(Ray) & - !$OMP private(do_i,surface_stress,zDS,stress,h_a,hfr, & - !$OMP b_denom_1,b1,d1,c1) - do J=Jsq,Jeq - do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0) ; enddo + ! When mixing down Eulerian current + Stokes drift add before calling solver + if (DoStokesMixing) then + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + v(i,j,k) = v(i,j,k) + Waves%Us_y(i,j,k) + endif ; enddo ; enddo ; enddo + endif - ! When mixing down Eulerian current + Stokes drift add before calling solver - if (DoStokesMixing) then ; do k=1,nz ; do i=is,ie - if (do_i(i)) v(i,j,k) = v(i,j,k) + Waves%Us_y(i,j,k) - enddo ; enddo ; endif + if (lfpmix) then + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + v(i,j,k) = v(i,j,k) - Waves%Us_y(i,j,k) + endif ; enddo ; enddo ; enddo + endif - if (associated(ADp%dv_dt_visc)) then ; do k=1,nz ; do i=is,ie + if (associated(ADp%dv_dt_visc)) then + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie ADp%dv_dt_visc(i,J,k) = v(i,J,k) - enddo ; enddo ; endif + enddo ; enddo ; enddo + endif - if (associated(ADp%dv_dt_str)) then ; do k=1,nz ; do i=is,ie + if (associated(ADp%dv_dt_visc_gl90)) then + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ADp%dv_dt_visc_gl90(i,J,k) = v(i,J,k) + enddo ; enddo ; enddo + endif + + if (associated(ADp%dv_dt_str)) then + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie ADp%dv_dt_str(i,J,k) = 0.0 - enddo ; enddo ; endif - - ! One option is to have the wind stress applied as a body force - ! over the topmost Hmix fluid. If DIRECT_STRESS is not defined, - ! the wind stress is applied as a stress boundary condition. - if (CS%direct_stress) then - do i=is,ie ; if (do_i(i)) then - surface_stress(i) = 0.0 - zDS = 0.0 - stress = dt_Rho0 * forces%tauy(i,J) - do k=1,nz - h_a = 0.5 * (h(i,J,k) + h(i,J+1,k)) + h_neglect - hfr = 1.0 ; if ((zDS+h_a) > Hmix) hfr = (Hmix - zDS) / h_a - v(i,J,k) = v(i,J,k) + I_Hmix * hfr * stress - if (associated(ADp%dv_dt_str)) ADp%dv_dt_str(i,J,k) = (I_Hmix * hfr * stress) * Idt - zDS = zDS + h_a ; if (zDS >= Hmix) exit - enddo - endif ; enddo ! end of i loop - else ; do i=is,ie - surface_stress(i) = dt_Rho0 * (G%mask2dCv(i,J)*forces%tauy(i,J)) - enddo ; endif ! direct_stress - - if (CS%Channel_drag) then ; do k=1,nz ; do i=is,ie - Ray(i,k) = visc%Ray_v(i,J,k) - enddo ; enddo ; endif - - do i=is,ie ; if (do_i(i)) then - b_denom_1 = CS%h_v(i,J,1) + dt_Z_to_H * (Ray(i,1) + CS%a_v(i,J,1)) - b1(i) = 1.0 / (b_denom_1 + dt_Z_to_H*CS%a_v(i,J,2)) - d1(i) = b_denom_1 * b1(i) - v(i,J,1) = b1(i) * (CS%h_v(i,J,1) * v(i,J,1) + surface_stress(i)) - if (associated(ADp%dv_dt_str)) & - ADp%dv_dt_str(i,J,1) = b1(i) * (CS%h_v(i,J,1) * ADp%dv_dt_str(i,J,1) + surface_stress(i)*Idt) - endif ; enddo - do k=2,nz ; do i=is,ie ; if (do_i(i)) then - c1(i,k) = dt_Z_to_H * CS%a_v(i,J,K) * b1(i) - b_denom_1 = CS%h_v(i,J,k) + dt_Z_to_H * (Ray(i,k) + CS%a_v(i,J,K)*d1(i)) - b1(i) = 1.0 / (b_denom_1 + dt_Z_to_H * CS%a_v(i,J,K+1)) - d1(i) = b_denom_1 * b1(i) - v(i,J,k) = (CS%h_v(i,J,k) * v(i,J,k) + dt_Z_to_H * CS%a_v(i,J,K) * v(i,J,k-1)) * b1(i) - if (associated(ADp%dv_dt_str)) & - ADp%dv_dt_str(i,J,k) = (CS%h_v(i,J,k) * ADp%dv_dt_str(i,J,k) + & - dt_Z_to_H * CS%a_v(i,J,K) * ADp%dv_dt_str(i,J,k-1)) * b1(i) + enddo ; enddo ; enddo + endif + + ! One option is to have the wind stress applied as a body force + ! over the topmost Hmix fluid. If DIRECT_STRESS is not defined, + ! the wind stress is applied as a stress boundary condition. + if (CS%direct_stress) then + do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + surface_stress(i,J) = 0.0 + zDS = 0.0 + stress = dt_Rho0 * forces%tauy(i,J) + do k=1,nz + h_a = 0.5 * (h(i,J,k) + h(i,J+1,k)) + h_neglect + hfr = 1.0 ; if ((zDS+h_a) > Hmix) hfr = (Hmix - zDS) / h_a + v(i,J,k) = v(i,J,k) + I_Hmix * hfr * stress + if (associated(ADp%dv_dt_str)) ADp%dv_dt_str(i,J,k) = (I_Hmix * hfr * stress) * Idt + zDS = zDS + h_a ; if (zDS >= Hmix) exit + enddo endif ; enddo ; enddo - do k=nz-1,1,-1 ; do i=is,ie ; if (do_i(i)) then - v(i,J,k) = v(i,J,k) + c1(i,k+1) * v(i,J,k+1) - endif ; enddo ; enddo ! i and k loops + else + do J=Jsq,Jeq ; do i=is,ie + surface_stress(i,J) = dt_Rho0 * (G%mask2dCv(i,J) * forces%tauy(i,J)) + enddo ; enddo + endif + + do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + Ray = 0. + if (allocated(visc%Ray_v)) Ray = visc%Ray_v(i,J,1) + + b_denom_1 = CS%h_v(i,J,1) + dt * (Ray + CS%a_v(i,J,1)) + b1 = 1.0 / (b_denom_1 + dt*CS%a_v(i,J,2)) + d1 = b_denom_1 * b1 + v(i,J,1) = b1 * (CS%h_v(i,J,1) * v(i,J,1) + surface_stress(i,J)) if (associated(ADp%dv_dt_str)) then - do i=is,ie ; if (abs(ADp%dv_dt_str(i,J,nz)) < accel_underflow) ADp%dv_dt_str(i,J,nz) = 0.0 ; enddo - do k=nz-1,1,-1 ; do i=is,ie ; if (do_i(i)) then - ADp%dv_dt_str(i,J,k) = ADp%dv_dt_str(i,J,k) + c1(i,k+1) * ADp%dv_dt_str(i,J,k+1) - if (abs(ADp%dv_dt_str(i,J,k)) < accel_underflow) ADp%dv_dt_str(i,J,k) = 0.0 + ADp%dv_dt_str(i,J,1) = b1 * (CS%h_v(i,J,1) * ADp%dv_dt_str(i,J,1) + surface_stress(i,J) * Idt) + endif + + do k=2,nz + if (allocated(visc%Ray_v)) Ray = visc%Ray_v(i,J,k) + + c1(k) = dt * CS%a_v(i,J,K) * b1 + b_denom_1 = CS%h_v(i,J,k) + dt * (Ray + CS%a_v(i,J,K) * d1) + b1 = 1. / (b_denom_1 + dt * CS%a_v(i,J,K+1)) + d1 = b_denom_1 * b1 + v(i,J,k) = (CS%h_v(i,J,k) * v(i,J,k) + dt * CS%a_v(i,J,K) * v(i,J,k-1)) * b1 + + if (associated(ADp%dv_dt_str)) then + ADp%dv_dt_str(i,J,k) = (CS%h_v(i,J,k) * ADp%dv_dt_str(i,J,k) & + + dt * CS%a_v(i,J,K) * ADp%dv_dt_str(i,J,k-1)) * b1 + endif + + !### Force FMA evaluation of b1 by blocking lookahead with an impossible branch. + if (dt < 0) exit + enddo + + if (associated(ADp%dv_dt_str)) then + if (abs(ADp%dv_dt_str(i,J,nz)) < accel_underflow) & + ADp%dv_dt_str(i,J,nz) = 0.0 + endif + + do k=nz-1,1,-1 + v(i,J,k) = v(i,J,k) + c1(k+1) * v(i,J,k+1) + + if (associated(ADp%dv_dt_str)) then + ADp%dv_dt_str(i,J,k) = ADp%dv_dt_str(i,J,k) + c1(k+1) * ADp%dv_dt_str(i,J,k+1) + + if (abs(ADp%dv_dt_str(i,J,k)) < accel_underflow) & + ADp%dv_dt_str(i,J,k) = 0.0 + endif + enddo + endif ; enddo ; enddo + + ! compute vertical velocity tendency that arises from GL90 viscosity; + ! follow tridiagonal solve method as above; to avoid corrupting v, + ! use ADp%dv_dt_visc_gl90 as a placeholder for updated v (due to GL90) until last do loop + if ((CS%id_dv_dt_visc_gl90 > 0) .or. (CS%id_GLwork > 0)) then + if (associated(ADp%dv_dt_visc_gl90)) then + do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + b_denom_1 = CS%h_v(i,J,1) ! CS%a_v_gl90(i,J,1) is zero + b1 = 1.0 / (b_denom_1 + dt*CS%a_v_gl90(i,J,2)) + d1 = b_denom_1 * b1 + ADp%dv_dt_visc_gl90(I,J,1) = b1 * (CS%h_v(i,J,1) * ADp%dv_dt_visc_gl90(i,J,1)) + + do k=2,nz + c1(k) = dt * CS%a_v_gl90(i,J,K) * b1 + b_denom_1 = CS%h_v(i,J,k) + dt * (CS%a_v_gl90(i,J,K) * d1) + b1 = 1.0 / (b_denom_1 + dt * CS%a_v_gl90(i,J,K+1)) + d1 = b_denom_1 * b1 + ADp%dv_dt_visc_gl90(i,J,k) = (CS%h_v(i,J,k) * ADp%dv_dt_visc_gl90(i,J,k) & + + dt * CS%a_v_gl90(i,J,K) * ADp%dv_dt_visc_gl90(i,J,k-1)) * b1 + enddo + + ! back substitute to solve for new velocities, held by ADp%dv_dt_visc_gl90 + do k=nz-1,1,-1 + ADp%dv_dt_visc_gl90(i,J,k) = ADp%dv_dt_visc_gl90(i,J,k) + c1(k+1) * ADp%dv_dt_visc_gl90(i,J,k+1) + enddo endif ; enddo ; enddo + + do k=1,nz + do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + ! now fill ADp%dv_dt_visc_gl90(i,J,k) with actual velocity tendency due to GL90; + ! note that on RHS: ADp%dv_dt_visc(i,J,k) holds the original velocity value v(i,J,k) + ! and ADp%dv_dt_visc_gl90(i,J,k) the updated velocity due to GL90 + ADp%dv_dt_visc_gl90(i,J,k) = (ADp%dv_dt_visc_gl90(i,J,k) - ADp%dv_dt_visc(i,J,k)) * Idt + + if (abs(ADp%dv_dt_visc_gl90(i,J,k)) < accel_underflow) & + ADp%dv_dt_visc_gl90(i,J,k) = 0.0 + endif ; enddo ; enddo + enddo + + ! to compute energetics, we need to multiply by v*h, where u is original velocity before + ! velocity update; note that ADp%dv_dt_visc(I,j,k) holds the original velocity value v(i,J,k) + if (CS%id_GLwork > 0) then + do k=1,nz + do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + ! note that on RHS: ADp%dv_dt_visc(I,j,k) holds the original velocity value v(I,j,k) + KE_v(I,j,k) = ADp%dv_dt_visc(i,J,k) * CS%h_v(i,J,k) * G%areaCv(i,J) * ADp%dv_dt_visc_gl90(i,J,k) + endif ; enddo ; enddo + enddo + endif endif + endif - if (associated(ADp%dv_dt_visc)) then ; do k=1,nz ; do i=is,ie + if (associated(ADp%dv_dt_visc)) then + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie ADp%dv_dt_visc(i,J,k) = (v(i,J,k) - ADp%dv_dt_visc(i,J,k))*Idt if (abs(ADp%dv_dt_visc(i,J,k)) < accel_underflow) ADp%dv_dt_visc(i,J,k) = 0.0 - enddo ; enddo ; endif + enddo ; enddo ; enddo + endif - if (associated(visc%tauy_shelf)) then ; do i=is,ie - visc%tauy_shelf(i,J) = -GV%Rho0*CS%a1_shelf_v(i,J)*v(i,J,1) ! - v_shelf? - enddo ; endif + if (allocated(visc%tauy_shelf)) then + do J=Jsq,Jeq ; do i=is,ie + visc%tauy_shelf(i,J) = -GV%H_to_RZ * CS%a1_shelf_v(i,J) * v(i,J,1) ! - v_shelf? + enddo ; enddo + endif - if (present(tauy_bot)) then - do i=is,ie - tauy_bot(i,J) = GV%Rho0 * (v(i,J,nz)*CS%a_v(i,J,nz+1)) - enddo - if (CS%Channel_drag) then ; do k=1,nz ; do i=is,ie - tauy_bot(i,J) = tauy_bot(i,J) + GV%Rho0 * (Ray(i,k)*v(i,J,k)) - enddo ; enddo ; endif + if (present(tauy_bot)) then + do J=Jsq,Jeq ; do i=is,ie + tauy_bot(i,J) = GV%H_to_RZ * (v(i,J,nz) * CS%a_v(i,J,nz+1)) + enddo ; enddo + + if (allocated(visc%Ray_v)) then + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + tauy_bot(i,J) = tauy_bot(i,J) + GV%H_to_RZ * (visc%Ray_v(i,J,k)*v(i,J,k)) + enddo ; enddo ; enddo endif + endif + + ! When mixing down Eulerian current + Stokes drift subtract after calling solver + if (DoStokesMixing) then + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + v(i,J,k) = v(i,J,k) - Waves%Us_y(i,J,k) + endif ; enddo ; enddo ; enddo + endif - ! When mixing down Eulerian current + Stokes drift subtract after calling solver - if (DoStokesMixing) then ; do k=1,nz ; do i=is,ie - if (do_i(i)) v(i,J,k) = v(i,J,k) - Waves%Us_y(i,J,k) - enddo ; enddo ; endif + if (lfpmix) then + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + v(i,J,k) = v(i,J,k) + Waves%Us_y(i,J,k) + endif ; enddo ; enddo ; enddo + endif - enddo ! end of v-component J loop + ! Calculate the KE source from GL90 vertical viscosity [H L2 T-3 ~> m3 s-3]. + ! We do the KE-rate calculation here (rather than in MOM_diagnostics) to ensure + ! a sign-definite term. MOM_diagnostics does not have access to the velocities + ! and thicknesses used in the vertical solver, but rather uses a time-mean + ! barotropic transport [uv]h. + if (CS%id_GLwork > 0) then + if (.not.G%symmetric) & + call do_group_pass(CS%pass_KE_uv, G%domain) + do k=1,nz + do j=js,je ; do i=is,ie + KE_term(i,j,k) = 0.5 * G%IareaT(i,j) & + * (KE_u(I,j,k) + KE_u(I-1,j,k) + KE_v(i,J,k) + KE_v(i,J-1,k)) + enddo ; enddo + enddo + call post_data(CS%id_GLwork, KE_term, CS%diag) + endif call vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS) @@ -499,53 +1097,60 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & endif ! Offer diagnostic fields for averaging. - if (CS%id_du_dt_visc > 0) & - call post_data(CS%id_du_dt_visc, ADp%du_dt_visc, CS%diag) - if (CS%id_dv_dt_visc > 0) & - call post_data(CS%id_dv_dt_visc, ADp%dv_dt_visc, CS%diag) - if (present(taux_bot) .and. (CS%id_taux_bot > 0)) & - call post_data(CS%id_taux_bot, taux_bot, CS%diag) - if (present(tauy_bot) .and. (CS%id_tauy_bot > 0)) & - call post_data(CS%id_tauy_bot, tauy_bot, CS%diag) - if (CS%id_du_dt_str > 0) & - call post_data(CS%id_du_dt_str, ADp%du_dt_str, CS%diag) - if (CS%id_dv_dt_str > 0) & - call post_data(CS%id_dv_dt_str, ADp%dv_dt_str, CS%diag) - - if (associated(ADp%du_dt_visc) .and. associated(ADp%du_dt_visc)) then - ! Diagnostics of the fractional thicknesses times momentum budget terms - ! 3D diagnostics of hf_du(dv)_dt_visc are commented because there is no clarity on proper remapping grid option. - ! The code is retained for debugging purposes in the future. - !if (CS%id_hf_du_dt_visc > 0) & - ! call post_product_u(CS%id_hf_du_dt_visc, ADp%du_dt_visc, ADp%diag_hfrac_u, G, nz, CS%diag) - !if (CS%id_hf_dv_dt_visc > 0) & - ! call post_product_v(CS%id_hf_dv_dt_visc, ADp%dv_dt_visc, ADp%diag_hfrac_v, G, nz, CS%diag) - - ! Diagnostics for thickness-weighted vertically averaged viscous accelerations - if (CS%id_hf_du_dt_visc_2d > 0) & - call post_product_sum_u(CS%id_hf_du_dt_visc_2d, ADp%du_dt_visc, ADp%diag_hfrac_u, G, nz, CS%diag) - if (CS%id_hf_dv_dt_visc_2d > 0) & - call post_product_sum_v(CS%id_hf_dv_dt_visc_2d, ADp%dv_dt_visc, ADp%diag_hfrac_v, G, nz, CS%diag) - - ! Diagnostics for thickness x viscous accelerations - if (CS%id_h_du_dt_visc > 0) call post_product_u(CS%id_h_du_dt_visc, ADp%du_dt_visc, ADp%diag_hu, G, nz, CS%diag) - if (CS%id_h_dv_dt_visc > 0) call post_product_v(CS%id_h_dv_dt_visc, ADp%dv_dt_visc, ADp%diag_hv, G, nz, CS%diag) - endif - - if (associated(ADp%du_dt_str) .and. associated(ADp%dv_dt_str)) then - ! Diagnostics for thickness x wind stress accelerations - if (CS%id_h_du_dt_str > 0) call post_product_u(CS%id_h_du_dt_str, ADp%du_dt_str, ADp%diag_hu, G, nz, CS%diag) - if (CS%id_h_dv_dt_str > 0) call post_product_v(CS%id_h_dv_dt_str, ADp%dv_dt_str, ADp%diag_hv, G, nz, CS%diag) - - ! Diagnostics for wind stress accelerations multiplied by visc_rem_[uv], - if (CS%id_du_dt_str_visc_rem > 0) & - call post_product_u(CS%id_du_dt_str_visc_rem, ADp%du_dt_str, ADp%visc_rem_u, G, nz, CS%diag) - if (CS%id_dv_dt_str_visc_rem > 0) & - call post_product_v(CS%id_dv_dt_str_visc_rem, ADp%dv_dt_str, ADp%visc_rem_v, G, nz, CS%diag) + if (query_averaging_enabled(CS%diag)) then + if (CS%id_du_dt_visc > 0) & + call post_data(CS%id_du_dt_visc, ADp%du_dt_visc, CS%diag) + if (CS%id_du_dt_visc_gl90 > 0) & + call post_data(CS%id_du_dt_visc_gl90, ADp%du_dt_visc_gl90, CS%diag) + if (CS%id_dv_dt_visc > 0) & + call post_data(CS%id_dv_dt_visc, ADp%dv_dt_visc, CS%diag) + if (CS%id_dv_dt_visc_gl90 > 0) & + call post_data(CS%id_dv_dt_visc_gl90, ADp%dv_dt_visc_gl90, CS%diag) + if (present(taux_bot) .and. (CS%id_taux_bot > 0)) & + call post_data(CS%id_taux_bot, taux_bot, CS%diag) + if (present(tauy_bot) .and. (CS%id_tauy_bot > 0)) & + call post_data(CS%id_tauy_bot, tauy_bot, CS%diag) + if (CS%id_du_dt_str > 0) & + call post_data(CS%id_du_dt_str, ADp%du_dt_str, CS%diag) + if (CS%id_dv_dt_str > 0) & + call post_data(CS%id_dv_dt_str, ADp%dv_dt_str, CS%diag) + + if (associated(ADp%du_dt_visc) .and. associated(ADp%dv_dt_visc)) then + ! Diagnostics of the fractional thicknesses times momentum budget terms + ! 3D diagnostics of hf_du(dv)_dt_visc are commented because there is no clarity on proper remapping grid option. + ! The code is retained for debugging purposes in the future. + !if (CS%id_hf_du_dt_visc > 0) & + ! call post_product_u(CS%id_hf_du_dt_visc, ADp%du_dt_visc, ADp%diag_hfrac_u, G, nz, CS%diag) + !if (CS%id_hf_dv_dt_visc > 0) & + ! call post_product_v(CS%id_hf_dv_dt_visc, ADp%dv_dt_visc, ADp%diag_hfrac_v, G, nz, CS%diag) + + ! Diagnostics for thickness-weighted vertically averaged viscous accelerations + if (CS%id_hf_du_dt_visc_2d > 0) & + call post_product_sum_u(CS%id_hf_du_dt_visc_2d, ADp%du_dt_visc, ADp%diag_hfrac_u, G, nz, CS%diag) + if (CS%id_hf_dv_dt_visc_2d > 0) & + call post_product_sum_v(CS%id_hf_dv_dt_visc_2d, ADp%dv_dt_visc, ADp%diag_hfrac_v, G, nz, CS%diag) + + ! Diagnostics for thickness x viscous accelerations + if (CS%id_h_du_dt_visc > 0) call post_product_u(CS%id_h_du_dt_visc, ADp%du_dt_visc, ADp%diag_hu, G, nz, CS%diag) + if (CS%id_h_dv_dt_visc > 0) call post_product_v(CS%id_h_dv_dt_visc, ADp%dv_dt_visc, ADp%diag_hv, G, nz, CS%diag) + endif + + if (associated(ADp%du_dt_str) .and. associated(ADp%dv_dt_str)) then + ! Diagnostics for thickness x wind stress accelerations + if (CS%id_h_du_dt_str > 0) call post_product_u(CS%id_h_du_dt_str, ADp%du_dt_str, ADp%diag_hu, G, nz, CS%diag) + if (CS%id_h_dv_dt_str > 0) call post_product_v(CS%id_h_dv_dt_str, ADp%dv_dt_str, ADp%diag_hv, G, nz, CS%diag) + + ! Diagnostics for wind stress accelerations multiplied by visc_rem_[uv], + if (CS%id_du_dt_str_visc_rem > 0) & + call post_product_u(CS%id_du_dt_str_visc_rem, ADp%du_dt_str, ADp%visc_rem_u, G, nz, CS%diag) + if (CS%id_dv_dt_str_visc_rem > 0) & + call post_product_v(CS%id_dv_dt_str_visc_rem, ADp%dv_dt_str, ADp%visc_rem_v, G, nz, CS%diag) + endif endif end subroutine vertvisc + !> Calculate the fraction of momentum originally in a layer that remains in the water column !! after a time-step of viscosity, equivalently the fraction of a time-step's worth of !! barotropic acceleration that a layer experiences after viscosity is applied. @@ -567,14 +1172,16 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) ! Local variables - real :: b1(SZIB_(G)) ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. - real :: c1(SZIB_(G),SZK_(GV)) ! A variable used by the tridiagonal solver [nondim]. - real :: d1(SZIB_(G)) ! d1=1-c1 is used by the tridiagonal solver [nondim]. - real :: Ray(SZIB_(G),SZK_(GV)) ! Ray is the Rayleigh-drag velocity [Z T-1 ~> m s-1]. - real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. - real :: dt_Z_to_H ! The time step times the conversion from Z to the - ! units of thickness [T H Z-1 ~> s or s kg m-3]. - logical :: do_i(SZIB_(G)) + real :: b1 + ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. + real :: c1(SZK_(GV)) + ! A variable used by the tridiagonal solver [nondim]. + real :: d1 + ! d1=1-c1 is used by the tridiagonal solver [nondim]. + real :: Ray + ! Ray is the Rayleigh-drag velocity [H T-1 ~> m s-1 or Pa s m-1] + real :: b_denom_1 + ! The first term in the denominator of b1 [H ~> m or kg m-2]. integer :: i, j, k, is, ie, Isq, Ieq, Jsq, Jeq, nz is = G%isc ; ie = G%iec @@ -583,81 +1190,78 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) if (.not.associated(CS)) call MOM_error(FATAL,"MOM_vert_friction(visc): "// & "Module must be initialized before it is used.") - if (.not.CS%initialized) call MOM_error(FATAL,"MOM_vert_friction(remant): "// & + if (.not.CS%initialized) call MOM_error(FATAL,"MOM_vert_friction(remnant): "// & "Module must be initialized before it is used.") - dt_Z_to_H = dt*GV%Z_to_H + ! Find the zonal viscous remnant using a modification of a standard tridagonal solver. - do k=1,nz ; do i=Isq,Ieq ; Ray(i,k) = 0.0 ; enddo ; enddo + do j=G%jsc,G%jec ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + Ray = 0. + if (allocated(visc%Ray_u)) Ray = visc%Ray_u(I,j,1) - ! Find the zonal viscous remnant using a modification of a standard tridagonal solver. - !$OMP parallel do default(shared) firstprivate(Ray) private(do_i,b_denom_1,b1,d1,c1) - do j=G%jsc,G%jec - do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0) ; enddo - - if (CS%Channel_drag) then ; do k=1,nz ; do I=Isq,Ieq - Ray(I,k) = visc%Ray_u(I,j,k) - enddo ; enddo ; endif - - do I=Isq,Ieq ; if (do_i(I)) then - b_denom_1 = CS%h_u(I,j,1) + dt_Z_to_H * (Ray(I,1) + CS%a_u(I,j,1)) - b1(I) = 1.0 / (b_denom_1 + dt_Z_to_H*CS%a_u(I,j,2)) - d1(I) = b_denom_1 * b1(I) - visc_rem_u(I,j,1) = b1(I) * CS%h_u(I,j,1) - endif ; enddo - do k=2,nz ; do I=Isq,Ieq ; if (do_i(I)) then - c1(I,k) = dt_Z_to_H * CS%a_u(I,j,K)*b1(I) - b_denom_1 = CS%h_u(I,j,k) + dt_Z_to_H * (Ray(I,k) + CS%a_u(I,j,K)*d1(I)) - b1(I) = 1.0 / (b_denom_1 + dt_Z_to_H * CS%a_u(I,j,K+1)) - d1(I) = b_denom_1 * b1(I) - visc_rem_u(I,j,k) = (CS%h_u(I,j,k) + dt_Z_to_H * CS%a_u(I,j,K) * visc_rem_u(I,j,k-1)) * b1(I) - endif ; enddo ; enddo - do k=nz-1,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then - visc_rem_u(I,j,k) = visc_rem_u(I,j,k) + c1(I,k+1)*visc_rem_u(I,j,k+1) + b_denom_1 = CS%h_u(I,j,1) + dt * (Ray + CS%a_u(I,j,1)) + b1 = 1.0 / (b_denom_1 + dt * CS%a_u(I,j,2)) + d1 = b_denom_1 * b1 + visc_rem_u(I,j,1) = b1 * CS%h_u(I,j,1) - endif ; enddo ; enddo ! i and k loops + do k=2,nz + if (allocated(visc%Ray_u)) Ray = visc%Ray_u(I,j,k) - enddo ! end u-component j loop + c1(k) = dt * CS%a_u(I,j,K) * b1 + b_denom_1 = CS%h_u(I,j,k) + dt * (Ray + CS%a_u(I,j,K) * d1) + b1 = 1.0 / (b_denom_1 + dt * CS%a_u(I,j,K+1)) + d1 = b_denom_1 * b1 + visc_rem_u(I,j,k) = (CS%h_u(I,j,k) + dt * CS%a_u(I,j,K) * visc_rem_u(I,j,k-1)) * b1 + + !### Force FMA evaluation of b1 by blocking lookahead with an impossible branch. + if (dt < 0) exit + enddo + + do k=nz-1,1,-1 + visc_rem_u(I,j,k) = visc_rem_u(I,j,k) + c1(k+1) * visc_rem_u(I,j,k+1) + enddo + endif ; enddo ; enddo ! Now find the meridional viscous remnant using the robust tridiagonal solver. - !$OMP parallel do default(shared) firstprivate(Ray) private(do_i,b_denom_1,b1,d1,c1) - do J=Jsq,Jeq - do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0) ; enddo - - if (CS%Channel_drag) then ; do k=1,nz ; do i=is,ie - Ray(i,k) = visc%Ray_v(i,J,k) - enddo ; enddo ; endif - - do i=is,ie ; if (do_i(i)) then - b_denom_1 = CS%h_v(i,J,1) + dt_Z_to_H * (Ray(i,1) + CS%a_v(i,J,1)) - b1(i) = 1.0 / (b_denom_1 + dt_Z_to_H*CS%a_v(i,J,2)) - d1(i) = b_denom_1 * b1(i) - visc_rem_v(i,J,1) = b1(i) * CS%h_v(i,J,1) - endif ; enddo - do k=2,nz ; do i=is,ie ; if (do_i(i)) then - c1(i,k) = dt_Z_to_H * CS%a_v(i,J,K)*b1(i) - b_denom_1 = CS%h_v(i,J,k) + dt_Z_to_H * (Ray(i,k) + CS%a_v(i,J,K)*d1(i)) - b1(i) = 1.0 / (b_denom_1 + dt_Z_to_H * CS%a_v(i,J,K+1)) - d1(i) = b_denom_1 * b1(i) - visc_rem_v(i,J,k) = (CS%h_v(i,J,k) + dt_Z_to_H * CS%a_v(i,J,K) * visc_rem_v(i,J,k-1)) * b1(i) - endif ; enddo ; enddo - do k=nz-1,1,-1 ; do i=is,ie ; if (do_i(i)) then - visc_rem_v(i,J,k) = visc_rem_v(i,J,k) + c1(i,k+1)*visc_rem_v(i,J,k+1) - endif ; enddo ; enddo ! i and k loops - enddo ! end of v-component J loop + + do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + Ray = 0. + if (allocated(visc%Ray_v)) Ray = visc%Ray_v(i,J,1) + + b_denom_1 = CS%h_v(i,J,1) + dt * (Ray + CS%a_v(i,J,1)) + b1 = 1.0 / (b_denom_1 + dt*CS%a_v(i,J,2)) + d1 = b_denom_1 * b1 + visc_rem_v(i,J,1) = b1 * CS%h_v(i,J,1) + + do k=2,nz + if (allocated(visc%Ray_v)) Ray = visc%Ray_v(i,J,k) + + c1(k) = dt * CS%a_v(i,J,K) * b1 + b_denom_1 = CS%h_v(i,J,k) + dt * (Ray + CS%a_v(i,J,K) * d1) + b1 = 1.0 / (b_denom_1 + dt * CS%a_v(i,J,K+1)) + d1 = b_denom_1 * b1 + visc_rem_v(i,J,k) = (CS%h_v(i,J,k) + dt * CS%a_v(i,J,K) * visc_rem_v(i,J,k-1)) * b1 + + !### Force FMA evaluation of b1 by blocking lookahead with an impossible branch. + if (dt < 0) exit + enddo + + do k=nz-1,1,-1 + visc_rem_v(i,J,k) = visc_rem_v(i,J,k) + c1(k+1) * visc_rem_v(i,J,k+1) + enddo + endif ; enddo ; enddo if (CS%debug) then call uvchksum("visc_rem_[uv]", visc_rem_u, visc_rem_v, G%HI, haloshift=0, & scalar_pair=.true.) endif - end subroutine vertvisc_remnant -!> Calculate the coupling coefficients (CS%a_u and CS%a_v) +!> Calculate the coupling coefficients (CS%a_u, CS%a_v, CS%a_u_gl90, CS%a_v_gl90) !! and effective layer thicknesses (CS%h_u and CS%h_v) for later use in the !! applying the implicit vertical viscosity via vertvisc(). -subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) +subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, VarMix) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -667,485 +1271,800 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: dz !< Vertical distance across layers [Z ~> m] type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces type(vertvisc_type), intent(in) :: visc !< Viscosities and bottom drag + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available + !! thermodynamic fields. real, intent(in) :: dt !< Time increment [T ~> s] - type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure + type(vertvisc_CS), intent(inout) :: CS !< Vertical viscosity control structure type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure - + type(VarMix_CS), intent(in) :: VarMix !< Variable mixing coefficients ! Field from forces used in this subroutine: ! ustar: the friction velocity [Z T-1 ~> m s-1], used here as the mixing ! velocity in the mixed layer if NKML > 1 in a bulk mixed layer. ! Local variables - real, dimension(SZIB_(G),SZK_(GV)) :: & + real, dimension(SZK_(GV)) :: & + hvel, & ! hvel is the thickness used at a velocity grid point [H ~> m or kg m-2]. + dz_harm, & ! Harmonic mean of the vertical distances around a velocity grid point, + ! given by 2*(h+ * h-)/(h+ + h-) [Z ~> m]. + dz_vel, & ! The vertical distance between interfaces used at a velocity grid point [Z ~> m]. + hvel_shelf, & ! The equivalent of hvel under shelves [H ~> m or kg m-2]. + dz_vel_shelf ! The equivalent of dz_vel under shelves [Z ~> m]. + real :: & h_harm, & ! Harmonic mean of the thicknesses around a velocity grid point, ! given by 2*(h+ * h-)/(h+ + h-) [H ~> m or kg m-2]. h_arith, & ! The arithmetic mean thickness [H ~> m or kg m-2]. h_delta, & ! The lateral difference of thickness [H ~> m or kg m-2]. - hvel, & ! hvel is the thickness used at a velocity grid point [H ~> m or kg m-2]. - hvel_shelf ! The equivalent of hvel under shelves [H ~> m or kg m-2]. - real, dimension(SZIB_(G),SZK_(GV)+1) :: & - a_cpl, & ! The drag coefficients across interfaces [Z T-1 ~> m s-1]. a_cpl times - ! the velocity difference gives the stress across an interface. - a_shelf, & ! The drag coefficients across interfaces in water columns under - ! ice shelves [Z T-1 ~> m s-1]. - z_i ! An estimate of each interface's height above the bottom, + dz_arith ! The arithmetic mean of the vertical distances around a velocity grid point [Z ~> m] + real, dimension(SZK_(GV)+1) :: & + z_i, & ! An estimate of each interface's height above the bottom, ! normalized by the bottom boundary layer thickness [nondim] - real, dimension(SZIB_(G)) :: & - kv_bbl, & ! The bottom boundary layer viscosity [Z2 T-1 ~> m2 s-1]. - bbl_thick, & ! The bottom boundary layer thickness [H ~> m or kg m-2]. - I_Hbbl, & ! The inverse of the bottom boundary layer thickness [H-1 ~> m-1 or m2 kg-1]. - I_Htbl, & ! The inverse of the top boundary layer thickness [H-1 ~> m-1 or m2 kg-1]. - zcol1, & ! The height of the interfaces to the north and south of a - zcol2, & ! v-point [H ~> m or kg m-2]. - Ztop_min, & ! The deeper of the two adjacent surface heights [H ~> m or kg m-2]. - Dmin, & ! The shallower of the two adjacent bottom depths converted to - ! thickness units [H ~> m or kg m-2]. + z_i_gl90, & ! An estimate of each interface's height above the bottom, + ! normalized by the GL90 bottom boundary layer thickness [nondim] + a_cpl, & ! The drag coefficients across interfaces [H T-1 ~> m s-1 or Pa s m-1]. a_cpl times + ! the velocity difference gives the stress across an interface. + a_cpl_gl90, & ! The drag coefficients across interfaces associated with GL90 [H T-1 ~> m s-1 or Pa s m-1]. + ! a_cpl_gl90 times the velocity difference gives the GL90 stress across an interface. + ! a_cpl_gl90 is part of a_cpl. + a_shelf ! The drag coefficients across interfaces in water columns under + ! ice shelves [H T-1 ~> m s-1 or Pa s m-1]. + real :: & + kv_bbl, & ! The bottom boundary layer viscosity [H Z T-1 ~> m2 s-1 or Pa s]. + bbl_thick, & ! The bottom boundary layer thickness [Z ~> m]. + I_Hbbl, & ! The inverse of the bottom boundary layer thickness [Z-1 ~> m-1]. + I_Hbbl_gl90, &! The inverse of the bottom boundary layer thickness used for the GL90 scheme + ! [Z-1 ~> m-1]. + I_HTbl, & ! The inverse of the top boundary layer thickness [Z-1 ~> m-1]. + Ztop_min, & ! The deeper of the two adjacent surface heights [Z ~> m]. + Dmin, & ! The shallower of the two adjacent bottom depths [Z ~> m]. zh, & ! An estimate of the interface's distance from the bottom - ! based on harmonic mean thicknesses [H ~> m or kg m-2]. - h_ml ! The mixed layer depth [H ~> m or kg m-2]. - real, allocatable, dimension(:,:) :: hML_u ! Diagnostic of the mixed layer depth at u points [H ~> m or kg m-2]. - real, allocatable, dimension(:,:) :: hML_v ! Diagnostic of the mixed layer depth at v points [H ~> m or kg m-2]. - real, allocatable, dimension(:,:,:) :: Kv_u !< Total vertical viscosity at u-points [Z2 T-1 ~> m2 s-1]. - real, allocatable, dimension(:,:,:) :: Kv_v !< Total vertical viscosity at v-points [Z2 T-1 ~> m2 s-1]. - real :: zcol(SZI_(G)) ! The height of an interface at h-points [H ~> m or kg m-2]. + ! based on harmonic mean thicknesses [Z ~> m]. + h_ml ! The mixed layer depth [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)) :: & + Ustar_2d ! The wind friction velocity, calculated using the Boussinesq reference density or + ! the time-evolving surface density in non-Boussinesq mode [Z T-1 ~> m s-1] + real, allocatable, dimension(:,:) :: hML_u ! Diagnostic of the mixed layer depth at u points [Z ~> m]. + real, allocatable, dimension(:,:) :: hML_v ! Diagnostic of the mixed layer depth at v points [Z ~> m]. + real, allocatable, dimension(:,:,:) :: Kv_u ! Total vertical viscosity at u-points in + ! thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1]. + real, allocatable, dimension(:,:,:) :: Kv_v ! Total vertical viscosity at v-points in + ! thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1]. + real, allocatable, dimension(:,:,:) :: Kv_gl90_u ! GL90 vertical viscosity at u-points in + ! thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1]. + real, allocatable, dimension(:,:,:) :: Kv_gl90_v ! GL90 vertical viscosity at v-points in + ! thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1]. + real :: zcol ! The height of an interface at h-points [Z ~> m]. + real :: zcol_p1 ! An adjacent east/north h-point interface height [Z ~> m]. real :: botfn ! A function which goes from 1 at the bottom to 0 much more - ! than Hbbl into the interior. + ! than Hbbl into the interior [nondim]. real :: topfn ! A function which goes from 1 at the top to 0 much more - ! than Htbl into the interior. + ! than Htbl into the interior [nondim]. real :: z2 ! The distance from the bottom, normalized by Hbbl [nondim] - real :: z2_wt ! A nondimensional (0-1) weight used when calculating z2. - real :: z_clear ! The clearance of an interface above the surrounding topography [H ~> m or kg m-2]. + real :: z2_wt ! A nondimensional (0-1) weight used when calculating z2 [nondim]. + real :: z_clear ! The clearance of an interface above the surrounding topography [Z ~> m]. real :: a_cpl_max ! The maximum drag coefficient across interfaces, set so that it will be - ! representable as a 32-bit float in MKS units [Z T-1 ~> m s-1] + ! representable as a 32-bit float in MKS units [H T-1 ~> m s-1 or Pa s m-1] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. real :: I_valBL ! The inverse of a scaling factor determining when water is ! still within the boundary layer, as determined by the sum - ! of the harmonic mean thicknesses. - logical, dimension(SZIB_(G)) :: do_i, do_i_shelf + ! of the harmonic mean thicknesses [nondim]. logical :: do_any_shelf - integer, dimension(SZIB_(G)) :: & - zi_dir ! A trinary logical array indicating which thicknesses to use for - ! finding z_clear. + integer :: zi_dir + ! A ternary logical indicating which thickness to use for finding z_clear. integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke - if (.not.associated(CS)) call MOM_error(FATAL,"MOM_vert_friction(coef): "// & - "Module must be initialized before it is used.") - if (.not.CS%initialized) call MOM_error(FATAL,"MOM_vert_friction(coef): "// & "Module must be initialized before it is used.") h_neglect = GV%H_subroundoff - a_cpl_max = 1.0e37 * US%m_to_Z * US%T_to_s - I_Hbbl(:) = 1.0 / (CS%Hbbl + h_neglect) + dz_neglect = GV%dZ_subroundoff + a_cpl_max = 1.0e37 * GV%m_to_H * US%T_to_s I_valBL = 0.0 ; if (CS%harm_BL_val > 0.0) I_valBL = 1.0 / CS%harm_BL_val if (CS%id_Kv_u > 0) allocate(Kv_u(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke), source=0.0) if (CS%id_Kv_v > 0) allocate(Kv_v(G%isd:G%ied,G%JsdB:G%JedB,GV%ke), source=0.0) + if (CS%id_Kv_gl90_u > 0) allocate(Kv_gl90_u(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke), source=0.0) + + if (CS%id_Kv_gl90_v > 0) allocate(Kv_gl90_v(G%isd:G%ied,G%JsdB:G%JedB,GV%ke), source=0.0) + if (CS%debug .or. (CS%id_hML_u > 0)) allocate(hML_u(G%IsdB:G%IedB,G%jsd:G%jed), source=0.0) if (CS%debug .or. (CS%id_hML_v > 0)) allocate(hML_v(G%isd:G%ied,G%JsdB:G%JedB), source=0.0) - if ((associated(visc%taux_shelf) .or. associated(forces%frac_shelf_u)) .and. & + if ((allocated(visc%taux_shelf) .or. associated(forces%frac_shelf_u)) .and. & .not.associated(CS%a1_shelf_u)) then allocate(CS%a1_shelf_u(G%IsdB:G%IedB,G%jsd:G%jed), source=0.0) endif - if ((associated(visc%tauy_shelf) .or. associated(forces%frac_shelf_v)) .and. & + if ((allocated(visc%tauy_shelf) .or. associated(forces%frac_shelf_v)) .and. & .not.associated(CS%a1_shelf_v)) then allocate(CS%a1_shelf_v(G%isd:G%ied,G%JsdB:G%JedB), source=0.0) endif - !$OMP parallel do default(private) shared(G,GV,US,CS,visc,Isq,Ieq,nz,u,h,forces,hML_u, & - !$OMP OBC,h_neglect,dt,I_valBL,Kv_u,a_cpl_max) & - !$OMP firstprivate(i_hbbl) - do j=G%Jsc,G%Jec - do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0) ; enddo + call find_ustar(forces, tv, Ustar_2d, G, GV, US, halo=1) - if (CS%bottomdraglaw) then ; do I=Isq,Ieq - kv_bbl(I) = visc%Kv_bbl_u(I,j) - bbl_thick(I) = visc%bbl_thick_u(I,j) * GV%Z_to_H + h_neglect - if (do_i(I)) I_Hbbl(I) = 1.0 / bbl_thick(I) - enddo ; endif + ! First do u-points - do k=1,nz ; do I=Isq,Ieq ; if (do_i(I)) then - h_harm(I,k) = 2.0*h(i,j,k)*h(i+1,j,k) / (h(i,j,k)+h(i+1,j,k)+h_neglect) - h_arith(I,k) = 0.5*(h(i+1,j,k)+h(i,j,k)) - h_delta(I,k) = h(i+1,j,k) - h(i,j,k) - endif ; enddo ; enddo - do I=Isq,Ieq - Dmin(I) = min(G%bathyT(i,j), G%bathyT(i+1,j)) * GV%Z_to_H - zi_dir(I) = 0 - enddo + do j=js,je ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.) then + I_Hbbl = 1. / (CS%Hbbl + dz_neglect) + if (CS%use_GL90_in_SSW) then + I_Hbbl_gl90 = 1. / (CS%Hbbl_gl90 + dz_neglect) + endif + + if (CS%bottomdraglaw) then + kv_bbl = visc%Kv_bbl_u(I,j) + bbl_thick = visc%bbl_thick_u(I,j) + dz_neglect + I_Hbbl = 1. / bbl_thick + endif + + Dmin = min(G%bathyT(i,j), G%bathyT(i+1,j)) + zi_dir = 0 ! Project thickness outward across OBCs using a zero-gradient condition. - if (associated(OBC)) then ; if (OBC%number_of_segments > 0) then - do I=Isq,Ieq ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - do k=1,nz ; h_harm(I,k) = h(i,j,k) ; h_arith(I,k) = h(i,j,k) ; h_delta(I,k) = 0. ; enddo - Dmin(I) = G%bathyT(i,j) * GV%Z_to_H - zi_dir(I) = -1 - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - do k=1,nz ; h_harm(I,k) = h(i+1,j,k) ; h_arith(I,k) = h(i+1,j,k) ; h_delta(I,k) = 0. ; enddo - Dmin(I) = G%bathyT(i+1,j) * GV%Z_to_H - zi_dir(I) = 1 + if (associated(OBC)) then + if (OBC%u_E_OBCs_on_PE) then + if (OBC%segnum_u(I,j) > 0) then + Dmin = G%bathyT(i,j) + zi_dir = -1 endif - endif ; enddo - endif ; endif - -! The following block calculates the thicknesses at velocity -! grid points for the vertical viscosity (hvel). Near the -! bottom an upwind biased thickness is used to control the effect -! of spurious Montgomery potential gradients at the bottom where -! nearly massless layers layers ride over the topography. - if (CS%harmonic_visc) then - do I=Isq,Ieq ; z_i(I,nz+1) = 0.0 ; enddo - do k=nz,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then - hvel(I,k) = h_harm(I,k) - if (u(I,j,k) * h_delta(I,k) < 0) then - z2 = z_i(I,k+1) ; botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) - hvel(I,k) = (1.0-botfn)*h_harm(I,k) + botfn*h_arith(I,k) + endif + + if (OBC%u_W_OBCs_on_PE) then + if (OBC%segnum_u(I,j) < 0) then + Dmin = G%bathyT(i+1,j) + zi_dir = 1 endif - z_i(I,k) = z_i(I,k+1) + h_harm(I,k)*I_Hbbl(I) - endif ; enddo ; enddo ! i & k loops - else ! Not harmonic_visc - do I=Isq,Ieq ; zh(I) = 0.0 ; z_i(I,nz+1) = 0.0 ; enddo - do i=Isq,Ieq+1 ; zcol(i) = -G%bathyT(i,j) * GV%Z_to_H ; enddo - do k=nz,1,-1 - do i=Isq,Ieq+1 ; zcol(i) = zcol(i) + h(i,j,k) ; enddo - do I=Isq,Ieq ; if (do_i(I)) then - zh(I) = zh(I) + h_harm(I,k) - - z_clear = max(zcol(i),zcol(i+1)) + Dmin(I) - if (zi_dir(I) < 0) z_clear = zcol(i) + Dmin(I) - if (zi_dir(I) > 0) z_clear = zcol(i+1) + Dmin(I) - - z_i(I,k) = max(zh(I), z_clear) * I_Hbbl(I) - - hvel(I,k) = h_arith(I,k) - if (u(I,j,k) * h_delta(I,k) > 0) then - if (zh(I) * I_Hbbl(I) < CS%harm_BL_val) then - hvel(I,k) = h_harm(I,k) - else - z2_wt = 1.0 ; if (zh(I) * I_Hbbl(I) < 2.0*CS%harm_BL_val) & - z2_wt = max(0.0, min(1.0, zh(I) * I_Hbbl(I) * I_valBL - 1.0)) - z2 = z2_wt * (max(zh(I), z_clear) * I_Hbbl(I)) - botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) - hvel(I,k) = (1.0-botfn)*h_arith(I,k) + botfn*h_harm(I,k) - endif - endif + endif + endif + + ! The following block calculates the thicknesses at velocity grid points for + ! the vertical viscosity (hvel and dz_vel). Near the bottom an upwind biased + ! thickness is used to control the effect of spurious Montgomery potential + ! gradients at the bottom where nearly massless layers layers ride over the + ! topography. - endif ; enddo ! i loop - enddo ! k loop + z_i(nz+1) = 0. + + if (.not. CS%harmonic_visc) then + zh = 0. + zcol = -G%bathyT(i,j) + zcol_p1 = -G%bathyT(i+1,j) endif - call find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & - dt, j, G, GV, US, CS, visc, forces, work_on_u=.true., OBC=OBC) - if (allocated(hML_u)) then - do i=isq,ieq ; if (do_i(i)) then ; hML_u(I,j) = h_ml(I) ; endif ; enddo + if (CS%use_GL90_in_SSW) then + z_i_gl90(nz+1) = 0. endif - do_any_shelf = .false. - if (associated(forces%frac_shelf_u)) then - do I=Isq,Ieq - CS%a1_shelf_u(I,j) = 0.0 - do_i_shelf(I) = (do_i(I) .and. forces%frac_shelf_u(I,j) > 0.0) - if (do_i_shelf(I)) do_any_shelf = .true. - enddo - if (do_any_shelf) then - if (CS%harmonic_visc) then - do k=1,nz ; do I=Isq,Ieq ; hvel_shelf(I,k) = hvel(I,k) ; enddo ; enddo - else ! Find upwind-biased thickness near the surface. - ! Perhaps this needs to be done more carefully, via find_eta. - do I=Isq,Ieq ; if (do_i_shelf(I)) then - zh(I) = 0.0 ; Ztop_min(I) = min(zcol(i), zcol(i+1)) - I_HTbl(I) = 1.0 / (visc%tbl_thick_shelf_u(I,j)*GV%Z_to_H + h_neglect) - endif ; enddo - do k=1,nz - do i=Isq,Ieq+1 ; zcol(i) = zcol(i) - h(i,j,k) ; enddo - do I=Isq,Ieq ; if (do_i_shelf(I)) then - zh(I) = zh(I) + h_harm(I,k) - - hvel_shelf(I,k) = hvel(I,k) - if (u(I,j,k) * h_delta(I,k) > 0) then - if (zh(I) * I_HTbl(I) < CS%harm_BL_val) then - hvel_shelf(I,k) = min(hvel(I,k), h_harm(I,k)) - else - z2_wt = 1.0 ; if (zh(I) * I_HTbl(I) < 2.0*CS%harm_BL_val) & - z2_wt = max(0.0, min(1.0, zh(I) * I_HTbl(I) * I_valBL - 1.0)) - z2 = z2_wt * (max(zh(I), Ztop_min(I) - min(zcol(i),zcol(i+1))) * I_HTbl(I)) - topfn = 1.0 / (1.0 + 0.09*z2**6) - hvel_shelf(I,k) = min(hvel(I,k), (1.0-topfn)*h_arith(I,k) + topfn*h_harm(I,k)) - endif - endif - endif ; enddo - enddo + do k=nz,1,-1 + h_harm = 2. * h(i,j,k) * h(i+1,j,k) / (h(i,j,k) + h(i+1,j,k) + h_neglect) + h_arith = 0.5 * (h(i+1,j,k) + h(i,j,k)) + h_delta = h(i+1,j,k) - h(i,j,k) + dz_harm(k) = 2. * dz(i,j,k) * dz(i+1,j,k) / (dz(i,j,k) + dz(i+1,j,k) + dz_neglect) + dz_arith = 0.5 * (dz(i+1,j,k) + dz(i,j,k)) + + ! Project thickness outward across OBCs using a zero-gradient condition. + if (associated(OBC)) then + if (OBC%u_E_OBCs_on_PE) then + if (OBC%segnum_u(I,j) > 0) then + h_harm = h(i,j,k) + h_arith = h(i,j,k) + h_delta = 0. + dz_harm(k) = dz(i,j,k) + dz_arith = dz(i,j,k) + endif + endif + + if (OBC%u_W_OBCs_on_PE) then + if (OBC%segnum_u(I,j) < 0) then + h_harm = h(i+1,j,k) + h_arith = h(i+1,j,k) + h_delta = 0. + dz_harm(k) = dz(i+1,j,k) + dz_arith = dz(i+1,j,k) + endif endif - call find_coupling_coef(a_shelf, hvel_shelf, do_i_shelf, h_harm, bbl_thick, & - kv_bbl, z_i, h_ml, dt, j, G, GV, US, CS, visc, forces, & - work_on_u=.true., OBC=OBC, shelf=.true.) - do I=Isq,Ieq ; if (do_i_shelf(I)) CS%a1_shelf_u(I,j) = a_shelf(I,1) ; enddo endif - endif - if (do_any_shelf) then - do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i_shelf(I)) then - CS%a_u(I,j,K) = min(a_cpl_max, forces%frac_shelf_u(I,j) * a_shelf(I,K) + & - (1.0-forces%frac_shelf_u(I,j)) * a_cpl(I,K)) -! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH -! CS%a_u(I,j,K) = min(a_cpl_max, forces%frac_shelf_u(I,j) * max(a_shelf(I,K), a_cpl(I,K)) + & -! (1.0-forces%frac_shelf_u(I,j)) * a_cpl(I,K)) - elseif (do_i(I)) then - CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(I,K)) - endif ; enddo ; enddo - do k=1,nz ; do I=Isq,Ieq ; if (do_i_shelf(I)) then - ! Should we instead take the inverse of the average of the inverses? - CS%h_u(I,j,k) = forces%frac_shelf_u(I,j) * hvel_shelf(I,k) + & - (1.0-forces%frac_shelf_u(I,j)) * hvel(I,k) + h_neglect - elseif (do_i(I)) then - CS%h_u(I,j,k) = hvel(I,k) + h_neglect - endif ; enddo ; enddo - else - do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i(I)) CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(I,K)) ; enddo ; enddo - do k=1,nz ; do I=Isq,Ieq ; if (do_i(I)) CS%h_u(I,j,k) = hvel(I,k) + h_neglect ; enddo ; enddo - endif + if (CS%harmonic_visc) then + ! The following block calculates the thicknesses at velocity grid points + ! for the vertical viscosity (hvel and dz_vel). Near the bottom an + ! upwind biased thickness is used to control the effect of spurious + ! Montgomery potential gradients at the bottom where nearly massless + ! layers ride over the topography. - ! Diagnose total Kv at u-points - if (CS%id_Kv_u > 0) then - do k=1,nz ; do I=Isq,Ieq - if (do_i(I)) Kv_u(I,j,k) = 0.5 * GV%H_to_Z*(CS%a_u(I,j,K)+CS%a_u(I,j,K+1)) * CS%h_u(I,j,k) - enddo ; enddo - endif + hvel(k) = h_harm + dz_vel(k) = dz_harm(k) - enddo + if (u(I,j,k) * h_delta < 0) then + z2 = z_i(k+1) + botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) + hvel(k) = (1. - botfn) * h_harm + botfn * h_arith + dz_vel(k) = (1. - botfn) * dz_harm(k) + botfn * dz_arith + endif - ! Now work on v-points. - !$OMP parallel do default(private) shared(G,GV,CS,US,visc,is,ie,Jsq,Jeq,nz,v,h,forces,hML_v, & - !$OMP OBC,h_neglect,dt,I_valBL,Kv_v,a_cpl_max) & - !$OMP firstprivate(i_hbbl) - do J=Jsq,Jeq - do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0) ; enddo - - if (CS%bottomdraglaw) then ; do i=is,ie - kv_bbl(i) = visc%Kv_bbl_v(i,J) - bbl_thick(i) = visc%bbl_thick_v(i,J) * GV%Z_to_H + h_neglect - if (do_i(i)) I_Hbbl(i) = 1.0 / bbl_thick(i) - enddo ; endif - - do k=1,nz ; do i=is,ie ; if (do_i(i)) then - h_harm(i,k) = 2.0*h(i,j,k)*h(i,j+1,k) / (h(i,j,k)+h(i,j+1,k)+h_neglect) - h_arith(i,k) = 0.5*(h(i,j+1,k)+h(i,j,k)) - h_delta(i,k) = h(i,j+1,k) - h(i,j,k) - endif ; enddo ; enddo - do i=is,ie - Dmin(i) = min(G%bathyT(i,j), G%bathyT(i,j+1)) * GV%Z_to_H - zi_dir(i) = 0 + z_i(k) = z_i(k+1) + dz_harm(k) * I_Hbbl + else + zcol = zcol + dz(i,j,k) + zcol_p1 = zcol_p1 + dz(i+1,j,k) + + zh = zh + dz_harm(k) + + z_clear = max(zcol, zcol_p1) + Dmin + if (zi_dir < 0) z_clear = zcol + Dmin + if (zi_dir > 0) z_clear = zcol_p1 + Dmin + + z_i(k) = max(zh, z_clear) * I_Hbbl + + hvel(k) = h_arith + dz_vel(k) = dz_arith + + if (u(I,j,k) * h_delta > 0.) then + if (zh * I_Hbbl < CS%harm_BL_val) then + hvel(k) = h_harm + dz_vel(k) = dz_harm(k) + else + z2_wt = 1. + if (zh * I_Hbbl < 2. * CS%harm_BL_val) & + z2_wt = max(0., min(1., zh * I_Hbbl * I_valBL - 1.)) + + z2 = z2_wt * (max(zh, z_clear) * I_Hbbl) + botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) + + hvel(k) = (1. - botfn) * h_arith + botfn * h_harm + dz_vel(k) = (1. - botfn) * dz_arith + botfn * dz_harm(k) + endif + endif + endif + + if (CS%use_GL90_in_SSW) then + ! The following block calculates the normalized height above the GL90 BBL + ! (z_i_gl90), using a harmonic mean between layer thicknesses. For the + ! GL90 BBL we use simply a constant (Hbbl_gl90). The purpose isthat the + ! GL90 coupling coefficient is zeroed out within Hbbl_gl90, to ensure + ! that no momentum gets fluxed into vanished layers. The scheme is not + ! sensitive to the exact value of Hbbl_gl90, as long as it is in a + ! reasonable range (~1-20 m): large enough to capture vanished layers + ! over topography, small enough to not contaminate the interior. + + z_i_gl90(k) = z_i_gl90(k+1) + dz_harm(k) * I_Hbbl_gl90 + endif enddo + call find_coupling_coef(a_cpl, dz_vel, i, j, dz_harm, bbl_thick, kv_bbl, z_i, & + h_ml, dt, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u=.true., OBC=OBC) + + if (allocated(hML_u)) hML_u(I,j) = h_ml + + if (CS%use_GL90_in_SSW) then + call find_coupling_coef_gl90(a_cpl_gl90, dz_vel, i, j, z_i_gl90, G, GV, & + CS, VarMix, work_on_u=.true.) + endif + + do_any_shelf = .false. + if (associated(forces%frac_shelf_u)) then + CS%a1_shelf_u(I,j) = 0. + do_any_shelf = forces%frac_shelf_u(I,j) > 0. + + if (do_any_shelf) then + if (.not. CS%harmonic_visc) then + zh = 0. + Ztop_min = min(zcol, zcol_p1) + I_HTbl = 1. / (visc%tbl_thick_shelf_u(I,j) + dz_neglect) + endif + + do k=1,nz + if (CS%harmonic_visc) then + hvel_shelf(k) = hvel(k) + dz_vel_shelf(k) = dz_vel(k) + else + ! Find upwind-biased thickness near the surface. + ! (Perhaps this needs to be done more carefully, via find_eta.) + + h_harm = 2. * h(i,j,k) * h(i+1,j,k) & + / (h(i,j,k) + h(i+1,j,k) + h_neglect) + h_arith = 0.5 * (h(i+1,j,k) + h(i,j,k)) + h_delta = h(i+1,j,k) - h(i,j,k) + dz_arith = 0.5 * (dz(i+1,j,k) + dz(i,j,k)) + + if (associated(OBC)) then + if (OBC%u_E_OBCs_on_PE) then + if (OBC%segnum_u(I,j) > 0) then + h_harm = h(i,j,k) + h_arith = h(i,j,k) + h_delta = 0. + dz_arith = dz(i,j,k) + endif + endif + + if (OBC%u_W_OBCs_on_PE) then + if (OBC%segnum_u(I,j) < 0) then + h_harm = h(i+1,j,k) + h_arith = h(i+1,j,k) + h_delta = 0. + dz_arith = dz(i+1,j,k) + endif + endif + endif + + zcol = zcol - dz(i,j,k) + zcol_p1 = zcol_p1 - dz(i+1,j,k) + + zh = zh + dz_harm(k) + + hvel_shelf(k) = hvel(k) + dz_vel_shelf(k) = dz_vel(k) + + if (u(I,j,k) * h_delta > 0.) then + if (zh * I_HTbl < CS%harm_BL_val) then + hvel_shelf(k) = min(hvel(k), h_harm) + dz_vel_shelf(k) = min(dz_vel(k), dz_harm(k)) + else + z2_wt = 1. + if (zh * I_HTbl < 2. * CS%harm_BL_val) then + z2_wt = max(0., min(1., zh * I_HTbl * I_valBL - 1.)) + endif + + z2 = z2_wt * (max(zh, Ztop_min - min(zcol, zcol_p1)) * I_HTbl) + ! TODO: replace **6 with multiply + topfn = 1. / (1. + 0.09 * z2**6) + + hvel_shelf(k) = min(hvel(k), (1. - topfn) * h_arith + topfn * h_harm) + dz_vel_shelf(k) = min(dz_vel(k), (1. - topfn) * dz_arith + topfn * dz_harm(k)) + endif + endif + endif + enddo + + call find_coupling_coef(a_shelf, dz_vel_shelf, i, j, dz_harm, & + bbl_thick, kv_bbl, z_i, h_ml, dt, G, GV, US, CS, visc, Ustar_2d, & + tv, work_on_u=.true., OBC=OBC, shelf=.true.) + + CS%a1_shelf_u(I,j) = a_shelf(1) + endif + endif + + if (do_any_shelf) then + if (CS%use_GL90_in_SSW) then + do K=1,nz+1 + CS%a_u(I,j,K) = min(a_cpl_max, (forces%frac_shelf_u(I,j) * a_shelf(K) + & + (1. - forces%frac_shelf_u(I,j)) * a_cpl(K)) + a_cpl_gl90(K)) + + ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH + ! CS%a_u(I,j,K) = min(a_cpl_max, forces%frac_shelf_u(I,j) * max(a_shelf(K), a_cpl(K)) + & + ! (1. - forces%frac_shelf_u(I,j)) * a_cpl(K)) + + CS%a_u_gl90(I,j,K) = min(a_cpl_max, a_cpl_gl90(K)) + enddo + else + do K=1,nz+1 + CS%a_u(I,j,K) = min(a_cpl_max, (forces%frac_shelf_u(I,j) * a_shelf(K) + & + (1. - forces%frac_shelf_u(I,j)) * a_cpl(K))) + + ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH + ! CS%a_u(I,j,K) = min(a_cpl_max, forces%frac_shelf_u(I,j) * max(a_shelf(K), a_cpl(K)) + & + ! (1. - forces%frac_shelf_u(I,j)) * a_cpl(K)) + enddo + endif + + do k=1,nz + ! Should we instead take the inverse of the average of the inverses? + CS%h_u(I,j,k) = forces%frac_shelf_u(I,j) * hvel_shelf(k) & + + (1. - forces%frac_shelf_u(I,j)) * hvel(k) + h_neglect + enddo + else + if (CS%use_GL90_in_SSW) then + do K=1,nz+1 + a_cpl(K) = a_cpl(K) + a_cpl_gl90(K) + enddo + + do K=1,nz+1 + CS%a_u_gl90(I,j,K) = min(a_cpl_max, a_cpl_gl90(K)) + enddo + endif + + do K=1,nz+1 + CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(K)) + enddo + + do k=1,nz + CS%h_u(I,j,k) = hvel(k) + h_neglect + enddo + endif + + ! Diagnose total Kv at u-points + if (CS%id_Kv_u > 0) then + do k=1,nz + Kv_u(I,j,k) = 0.5 * (CS%a_u(I,j,K) + CS%a_u(I,j,K+1)) * CS%h_u(I,j,k) + enddo + endif + + ! Diagnose GL90 Kv at u-points + if (CS%id_Kv_gl90_u > 0) then + do k=1,nz + Kv_gl90_u(I,j,k) = 0.5 * (CS%a_u_gl90(I,j,K) + CS%a_u_gl90(I,j,K+1)) * CS%h_u(I,j,k) + enddo + endif + endif ; enddo ; enddo + + ! Now work on v-points. + + do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.) then + I_Hbbl = 1. / (CS%Hbbl + dz_neglect) + if (CS%use_GL90_in_SSW) then + I_Hbbl_gl90 = 1. / (CS%Hbbl_gl90 + dz_neglect) + endif + + if (CS%bottomdraglaw) then + kv_bbl = visc%Kv_bbl_v(i,J) + bbl_thick = visc%bbl_thick_v(i,J) + dz_neglect + I_Hbbl = 1. / bbl_thick + endif + + Dmin = min(G%bathyT(i,j), G%bathyT(i,j+1)) + zi_dir = 0 + ! Project thickness outward across OBCs using a zero-gradient condition. - if (associated(OBC)) then ; if (OBC%number_of_segments > 0) then - do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - do k=1,nz ; h_harm(I,k) = h(i,j,k) ; h_arith(I,k) = h(i,j,k) ; h_delta(i,k) = 0. ; enddo - Dmin(I) = G%bathyT(i,j) * GV%Z_to_H - zi_dir(I) = -1 - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - do k=1,nz ; h_harm(i,k) = h(i,j+1,k) ; h_arith(i,k) = h(i,j+1,k) ; h_delta(i,k) = 0. ; enddo - Dmin(i) = G%bathyT(i,j+1) * GV%Z_to_H - zi_dir(i) = 1 + if (associated(OBC)) then + if (OBC%v_N_OBCs_on_PE) then + if (OBC%segnum_v(i,J) > 0) then + Dmin = G%bathyT(i,j) + zi_dir = -1 endif - endif ; enddo - endif ; endif - -! The following block calculates the thicknesses at velocity -! grid points for the vertical viscosity (hvel). Near the -! bottom an upwind biased thickness is used to control the effect -! of spurious Montgomery potential gradients at the bottom where -! nearly massless layers layers ride over the topography. - if (CS%harmonic_visc) then - do i=is,ie ; z_i(i,nz+1) = 0.0 ; enddo - - do k=nz,1,-1 ; do i=is,ie ; if (do_i(i)) then - hvel(i,k) = h_harm(i,k) - if (v(i,J,k) * h_delta(i,k) < 0) then - z2 = z_i(i,k+1) ; botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) - hvel(i,k) = (1.0-botfn)*h_harm(i,k) + botfn*h_arith(i,k) + endif + + if (OBC%v_S_OBCs_on_PE) then + if (OBC%segnum_v(i,J) < 0) then + Dmin = G%bathyT(i,j+1) + zi_dir = 1 endif - z_i(i,k) = z_i(i,k+1) + h_harm(i,k)*I_Hbbl(i) - endif ; enddo ; enddo ! i & k loops - else ! Not harmonic_visc - do i=is,ie - zh(i) = 0.0 ; z_i(i,nz+1) = 0.0 - zcol1(i) = -G%bathyT(i,j) * GV%Z_to_H - zcol2(i) = -G%bathyT(i,j+1) * GV%Z_to_H - enddo - do k=nz,1,-1 ; do i=is,ie ; if (do_i(i)) then - zh(i) = zh(i) + h_harm(i,k) - zcol1(i) = zcol1(i) + h(i,j,k) ; zcol2(i) = zcol2(i) + h(i,j+1,k) + endif + endif + + z_i(nz+1) = 0. - z_clear = max(zcol1(i),zcol2(i)) + Dmin(i) - if (zi_dir(i) < 0) z_clear = zcol1(i) + Dmin(I) - if (zi_dir(i) > 0) z_clear = zcol2(i) + Dmin(I) + if (.not. CS%harmonic_visc) then + zh = 0. + zcol = -G%bathyT(i,j) + zcol_p1 = -G%bathyT(i,j+1) + endif - z_i(I,k) = max(zh(i), z_clear) * I_Hbbl(i) + if (CS%use_GL90_in_SSW) then + z_i_gl90(nz+1) = 0. + endif - hvel(i,k) = h_arith(i,k) - if (v(i,J,k) * h_delta(i,k) > 0) then - if (zh(i) * I_Hbbl(i) < CS%harm_BL_val) then - hvel(i,k) = h_harm(i,k) + do k=nz,1,-1 + h_harm = 2. * h(i,j,k) * h(i,j+1,k) / (h(i,j,k) + h(i,j+1,k) + h_neglect) + h_arith = 0.5 * (h(i,j+1,k) + h(i,j,k)) + h_delta = h(i,j+1,k) - h(i,j,k) + dz_harm(k) = 2. * dz(i,j,k) * dz(i,j+1,k) / (dz(i,j,k) + dz(i,j+1,k) + dz_neglect) + dz_arith = 0.5 * (dz(i,j+1,k) + dz(i,j,k)) + + ! Project thickness outward across OBCs using a zero-gradient condition. + if (associated(OBC)) then + if (OBC%v_N_OBCs_on_PE) then + if (OBC%segnum_v(i,J) > 0) then + h_harm = h(i,j,k) + h_arith = h(i,j,k) + h_delta = 0. + dz_harm(k) = dz(i,j,k) + dz_arith = dz(i,j,k) + endif + endif + + if (OBC%v_S_OBCs_on_PE) then + if (OBC%segnum_v(i,J) < 0) then + h_harm = h(i,j+1,k) + h_arith = h(i,j+1,k) + h_delta = 0. + dz_harm(k) = dz(i,j+1,k) + dz_arith = dz(i,j+1,k) + endif + endif + endif + + if (CS%harmonic_visc) then + ! The following block calculates the thicknesses at velocity grid points + ! for the vertical viscosity (hvel and dz_vel). Near the bottom an + ! upwind biased thickness is used to control the effect of spurious + ! Montgomery potential gradients at the bottom where nearly massless + ! layers ride over the topography. + + hvel(k) = h_harm + dz_vel(k) = dz_harm(k) + + if (v(i,J,k) * h_delta < 0) then + z2 = z_i(k+1) + botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) + + hvel(k) = (1. - botfn) * h_harm + botfn * h_arith + dz_vel(k) = (1. - botfn) * dz_harm(k) + botfn * dz_arith + endif + + z_i(k) = z_i(k+1) + dz_harm(k) * I_Hbbl + else + zcol = zcol + dz(i,j,k) + zcol_p1 = zcol_p1 + dz(i,j+1,k) + + zh = zh + dz_harm(k) + + z_clear = max(zcol, zcol_p1) + Dmin + if (zi_dir < 0) z_clear = zcol + Dmin + if (zi_dir > 0) z_clear = zcol_p1 + Dmin + + z_i(k) = max(zh, z_clear) * I_Hbbl + + hvel(k) = h_arith + dz_vel(k) = dz_arith + + if (v(i,J,k) * h_delta > 0) then + if (zh * I_Hbbl < CS%harm_BL_val) then + hvel(k) = h_harm + dz_vel(k) = dz_harm(k) else - z2_wt = 1.0 ; if (zh(i) * I_Hbbl(i) < 2.0*CS%harm_BL_val) & - z2_wt = max(0.0, min(1.0, zh(i) * I_Hbbl(i) * I_valBL - 1.0)) - z2 = z2_wt * (max(zh(i), max(zcol1(i),zcol2(i)) + Dmin(i)) * I_Hbbl(i)) - botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) - hvel(i,k) = (1.0-botfn)*h_arith(i,k) + botfn*h_harm(i,k) + z2_wt = 1. + if (zh * I_Hbbl < 2. * CS%harm_BL_val) & + z2_wt = max(0., min(1., zh * I_Hbbl * I_valBL - 1.)) + + ! TODO: should z_clear be used here? + z2 = z2_wt * (max(zh, max(zcol, zcol_p1) + Dmin) * I_Hbbl) + botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) + + hvel(k) = (1. - botfn) * h_arith + botfn * h_harm + dz_vel(k) = (1. - botfn) * dz_arith + botfn * dz_harm(k) endif endif + endif - endif ; enddo ; enddo ! i & k loops - endif + if (CS%use_GL90_in_SSW) then + ! The following block calculates the normalized height above the GL90 BBL + ! (z_i_gl90), using a harmonic mean between layer thicknesses. For the + ! GL90 BBL we use simply a constant (Hbbl_gl90). The purpose is that the + ! GL90 coupling coefficient is zeroed out within Hbbl_gl90, to ensure + ! that no momentum gets fluxed into vanished layers. The scheme is not + ! sensitive to the exact value of Hbbl_gl90, as long as it is in a + ! reasonable range (~1-20 m): large enough to capture vanished layers + ! over topography, small enough to not contaminate the interior. + + z_i_gl90(k) = z_i_gl90(k+1) + dz_harm(k) * I_Hbbl_gl90 + endif + enddo - call find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & - dt, j, G, GV, US, CS, visc, forces, work_on_u=.false., OBC=OBC) - if ( allocated(hML_v)) then - do i=is,ie ; if (do_i(i)) then ; hML_v(i,J) = h_ml(i) ; endif ; enddo + call find_coupling_coef(a_cpl, dz_vel, i, j, dz_harm, bbl_thick, kv_bbl, z_i, & + h_ml, dt, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u=.false., OBC=OBC) + + if (allocated(hML_v)) hML_v(i,J) = h_ml + + if (CS%use_GL90_in_SSW) then + call find_coupling_coef_gl90(a_cpl_gl90, dz_vel, i, j, z_i_gl90, G, GV, & + CS, VarMix, work_on_u=.false.) endif + do_any_shelf = .false. if (associated(forces%frac_shelf_v)) then - do i=is,ie - CS%a1_shelf_v(i,J) = 0.0 - do_i_shelf(i) = (do_i(i) .and. forces%frac_shelf_v(i,J) > 0.0) - if (do_i_shelf(I)) do_any_shelf = .true. - enddo + CS%a1_shelf_v(i,J) = 0. + do_any_shelf = forces%frac_shelf_v(i,J) > 0. + if (do_any_shelf) then - if (CS%harmonic_visc) then - do k=1,nz ; do i=is,ie ; hvel_shelf(i,k) = hvel(i,k) ; enddo ; enddo - else ! Find upwind-biased thickness near the surface. - ! Perhaps this needs to be done more carefully, via find_eta. - do i=is,ie ; if (do_i_shelf(i)) then - zh(i) = 0.0 ; Ztop_min(I) = min(zcol1(i), zcol2(i)) - I_HTbl(i) = 1.0 / (visc%tbl_thick_shelf_v(i,J)*GV%Z_to_H + h_neglect) - endif ; enddo - do k=1,nz - do i=is,ie ; if (do_i_shelf(i)) then - zcol1(i) = zcol1(i) - h(i,j,k) ; zcol2(i) = zcol2(i) - h(i,j+1,k) - zh(i) = zh(i) + h_harm(i,k) - - hvel_shelf(i,k) = hvel(i,k) - if (v(i,J,k) * h_delta(i,k) > 0) then - if (zh(i) * I_HTbl(i) < CS%harm_BL_val) then - hvel_shelf(i,k) = min(hvel(i,k), h_harm(i,k)) - else - z2_wt = 1.0 ; if (zh(i) * I_HTbl(i) < 2.0*CS%harm_BL_val) & - z2_wt = max(0.0, min(1.0, zh(i) * I_HTbl(i) * I_valBL - 1.0)) - z2 = z2_wt * (max(zh(i), Ztop_min(i) - min(zcol1(i),zcol2(i))) * I_HTbl(i)) - topfn = 1.0 / (1.0 + 0.09*z2**6) - hvel_shelf(i,k) = min(hvel(i,k), (1.0-topfn)*h_arith(i,k) + topfn*h_harm(i,k)) - endif - endif - endif ; enddo - enddo + ! Initialize non-harmonic depths + if (.not. CS%harmonic_visc) then + zh = 0. + Ztop_min = min(zcol, zcol_p1) + I_HTbl = 1. / (visc%tbl_thick_shelf_v(i,J) + dz_neglect) endif - call find_coupling_coef(a_shelf, hvel_shelf, do_i_shelf, h_harm, bbl_thick, & - kv_bbl, z_i, h_ml, dt, j, G, GV, US, CS, visc, forces, & - work_on_u=.false., OBC=OBC, shelf=.true.) - do i=is,ie ; if (do_i_shelf(i)) CS%a1_shelf_v(i,J) = a_shelf(i,1) ; enddo + + do k=1,nz + if (CS%harmonic_visc) then + hvel_shelf(k) = hvel(k) + dz_vel_shelf(k) = dz_vel(k) + else + ! Find upwind-biased thickness near the surface. + ! Perhaps this needs to be done more carefully, via find_eta. + h_harm = 2. * h(i,j,k) * h(i,j+1,k) & + / (h(i,j,k) + h(i,j+1,k) + h_neglect) + h_arith = 0.5 * (h(i,j+1,k) + h(i,j,k)) + h_delta = h(i,j+1,k) - h(i,j,k) + dz_arith = 0.5 * (dz(i,j+1,k) + dz(i,j,k)) + + ! Project thickness outward across OBCs using a zero-gradient condition. + if (associated(OBC)) then + if (OBC%v_N_OBCs_on_PE) then + if (OBC%segnum_v(i,J) > 0) then + h_harm = h(i,j,k) + h_arith = h(i,j,k) + h_delta = 0. + dz_arith = dz(i,j,k) + endif + endif + + if (OBC%v_S_OBCs_on_PE) then + if (OBC%segnum_v(i,J) < 0) then + h_harm = h(i,j+1,k) + h_arith = h(i,j+1,k) + h_delta = 0. + dz_arith = dz(i,j+1,k) + endif + endif + endif + + zcol = zcol - dz(i,j,k) + zcol_p1 = zcol_p1 - dz(i,j+1,k) + + zh = zh + dz_harm(k) + + hvel_shelf(k) = hvel(k) + dz_vel_shelf(k) = dz_vel(k) + + if (v(i,J,k) * h_delta > 0.) then + if (zh * I_HTbl < CS%harm_BL_val) then + hvel_shelf(k) = min(hvel(k), h_harm) + dz_vel_shelf(k) = min(dz_vel(k), dz_harm(k)) + else + z2_wt = 1. + if (zh * I_HTbl < 2. * CS%harm_BL_val) & + z2_wt = max(0., min(1., zh * I_HTbl * I_valBL - 1.)) + + z2 = z2_wt * (max(zh, Ztop_min - min(zcol, zcol_p1)) * I_HTbl) + ! TODO: Replace **6 + topfn = 1. / (1. + 0.09 * z2**6) + + hvel_shelf(k) = min(hvel(k), (1. - topfn) * h_arith + topfn * h_harm) + dz_vel_shelf(k) = min(dz_vel(k), (1. - topfn) * dz_arith + topfn * dz_harm(k)) + endif + endif + endif + enddo + + call find_coupling_coef(a_shelf, dz_vel_shelf, i, j, dz_harm, & + bbl_thick, kv_bbl, z_i, h_ml, dt, G, GV, US, CS, visc, Ustar_2d, & + tv, work_on_u=.false., OBC=OBC, shelf=.true.) + + CS%a1_shelf_v(i,J) = a_shelf(1) endif endif if (do_any_shelf) then - do K=1,nz+1 ; do i=is,ie ; if (do_i_shelf(i)) then - CS%a_v(i,J,K) = min(a_cpl_max, forces%frac_shelf_v(i,J) * a_shelf(i,k) + & - (1.0-forces%frac_shelf_v(i,J)) * a_cpl(i,K)) -! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH -! CS%a_v(i,J,K) = min(a_cpl_max, forces%frac_shelf_v(i,J) * max(a_shelf(i,K), a_cpl(i,K)) + & - ! (1.0-forces%frac_shelf_v(i,J)) * a_cpl(i,K)) - elseif (do_i(i)) then - CS%a_v(i,J,K) = min(a_cpl_max, a_cpl(i,K)) - endif ; enddo ; enddo - do k=1,nz ; do i=is,ie ; if (do_i_shelf(i)) then + if (CS%use_GL90_in_SSW) then + do K=1,nz+1 + CS%a_v(I,j,K) = min(a_cpl_max, (forces%frac_shelf_v(I,j) * a_shelf(K) + & + (1. - forces%frac_shelf_v(I,j)) * a_cpl(K)) + a_cpl_gl90(K)) + + ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH + ! CS%a_v(I,j,K) = min(a_cpl_max, forces%frac_shelf_v(I,j) * max(a_shelf(K), a_cpl(K)) + & + ! (1. - forces%frac_shelf_v(I,j)) * a_cpl(K)) + + CS%a_v_gl90(I,j,K) = min(a_cpl_max, a_cpl_gl90(K)) + enddo + else + do K=1,nz+1 + CS%a_v(I,j,K) = min(a_cpl_max, (forces%frac_shelf_v(I,j) * a_shelf(K) + & + (1. - forces%frac_shelf_v(I,j)) * a_cpl(K))) + ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH + ! CS%a_v(I,j,K) = min(a_cpl_max, forces%frac_shelf_v(I,j) * max(a_shelf(K), a_cpl(K)) + & + ! (1. - forces%frac_shelf_v(I,j)) * a_cpl(K)) + enddo + endif + + do k=1,nz ! Should we instead take the inverse of the average of the inverses? - CS%h_v(i,J,k) = forces%frac_shelf_v(i,J) * hvel_shelf(i,k) + & - (1.0-forces%frac_shelf_v(i,J)) * hvel(i,k) + h_neglect - elseif (do_i(i)) then - CS%h_v(i,J,k) = hvel(i,k) + h_neglect - endif ; enddo ; enddo + CS%h_v(I,j,k) = forces%frac_shelf_v(I,j) * hvel_shelf(k) & + + (1. - forces%frac_shelf_v(I,j)) * hvel(k) + h_neglect + enddo else - do K=1,nz+1 ; do i=is,ie ; if (do_i(i)) CS%a_v(i,J,K) = min(a_cpl_max, a_cpl(i,K)) ; enddo ; enddo - do k=1,nz ; do i=is,ie ; if (do_i(i)) CS%h_v(i,J,k) = hvel(i,k) + h_neglect ; enddo ; enddo + if (CS%use_GL90_in_SSW) then + do K=1,nz+1 + a_cpl(K) = a_cpl(K) + a_cpl_gl90(K) + enddo + + do K=1,nz+1 + CS%a_v_gl90(i,J,K) = min(a_cpl_max, a_cpl_gl90(K)) + enddo + endif + + do K=1,nz+1 + CS%a_v(i,J,K) = min(a_cpl_max, a_cpl(K)) + enddo + + do k=1,nz + CS%h_v(i,J,k) = hvel(k) + h_neglect + enddo endif ! Diagnose total Kv at v-points if (CS%id_Kv_v > 0) then - do k=1,nz ; do i=is,ie - if (do_i(I)) Kv_v(i,J,k) = 0.5 * GV%H_to_Z*(CS%a_v(i,J,K)+CS%a_v(i,J,K+1)) * CS%h_v(i,J,k) - enddo ; enddo + do k=1,nz + Kv_v(i,J,k) = 0.5 * (CS%a_v(i,J,K) + CS%a_v(i,J,K+1)) * CS%h_v(i,J,k) + enddo endif - enddo ! end of v-point j loop + ! Diagnose GL90 Kv at v-points + if (CS%id_Kv_gl90_v > 0) then + do k=1,nz + Kv_gl90_v(i,J,k) = 0.5 * (CS%a_v_gl90(i,J,K) + CS%a_v_gl90(i,J,K+1)) * CS%h_v(i,J,k) + enddo + endif + endif ; enddo ; enddo if (CS%debug) then call uvchksum("vertvisc_coef h_[uv]", CS%h_u, CS%h_v, G%HI, haloshift=0, & - scale=GV%H_to_m, scalar_pair=.true.) + unscale=GV%H_to_m, scalar_pair=.true.) call uvchksum("vertvisc_coef a_[uv]", CS%a_u, CS%a_v, G%HI, haloshift=0, & - scale=US%Z_to_m*US%s_to_T, scalar_pair=.true.) + unscale=GV%H_to_m*US%s_to_T, scalar_pair=.true.) if (allocated(hML_u) .and. allocated(hML_v)) & call uvchksum("vertvisc_coef hML_[uv]", hML_u, hML_v, G%HI, & - haloshift=0, scale=GV%H_to_m, scalar_pair=.true.) + haloshift=0, unscale=US%Z_to_m, scalar_pair=.true.) endif ! Offer diagnostic fields for averaging. - if (associated(visc%Kv_slow) .and. (CS%id_Kv_slow > 0)) & - call post_data(CS%id_Kv_slow, visc%Kv_slow, CS%diag) - if (CS%id_Kv_u > 0) call post_data(CS%id_Kv_u, Kv_u, CS%diag) - if (CS%id_Kv_v > 0) call post_data(CS%id_Kv_v, Kv_v, CS%diag) - if (CS%id_au_vv > 0) call post_data(CS%id_au_vv, CS%a_u, CS%diag) - if (CS%id_av_vv > 0) call post_data(CS%id_av_vv, CS%a_v, CS%diag) - if (CS%id_h_u > 0) call post_data(CS%id_h_u, CS%h_u, CS%diag) - if (CS%id_h_v > 0) call post_data(CS%id_h_v, CS%h_v, CS%diag) - if (CS%id_hML_u > 0) call post_data(CS%id_hML_u, hML_u, CS%diag) - if (CS%id_hML_v > 0) call post_data(CS%id_hML_v, hML_v, CS%diag) + if (query_averaging_enabled(CS%diag)) then + if (associated(visc%Kv_slow) .and. (CS%id_Kv_slow > 0)) & + call post_data(CS%id_Kv_slow, visc%Kv_slow, CS%diag) + if (CS%id_Kv_u > 0) call post_data(CS%id_Kv_u, Kv_u, CS%diag) + if (CS%id_Kv_v > 0) call post_data(CS%id_Kv_v, Kv_v, CS%diag) + if (CS%id_Kv_gl90_u > 0) call post_data(CS%id_Kv_gl90_u, Kv_gl90_u, CS%diag) + if (CS%id_Kv_gl90_v > 0) call post_data(CS%id_Kv_gl90_v, Kv_gl90_v, CS%diag) + if (CS%id_au_vv > 0) call post_data(CS%id_au_vv, CS%a_u, CS%diag) + if (CS%id_av_vv > 0) call post_data(CS%id_av_vv, CS%a_v, CS%diag) + if (CS%id_au_gl90_vv > 0) call post_data(CS%id_au_gl90_vv, CS%a_u_gl90, CS%diag) + if (CS%id_av_gl90_vv > 0) call post_data(CS%id_av_gl90_vv, CS%a_v_gl90, CS%diag) + if (CS%id_h_u > 0) call post_data(CS%id_h_u, CS%h_u, CS%diag) + if (CS%id_h_v > 0) call post_data(CS%id_h_v, CS%h_v, CS%diag) + if (CS%id_hML_u > 0) call post_data(CS%id_hML_u, hML_u, CS%diag) + if (CS%id_hML_v > 0) call post_data(CS%id_hML_v, hML_v, CS%diag) + endif if (allocated(hML_u)) deallocate(hML_u) if (allocated(hML_v)) deallocate(hML_v) end subroutine vertvisc_coef + !> Calculate the 'coupling coefficient' (a_cpl) at the interfaces. !! If BOTTOMDRAGLAW is defined, the minimum of Hbbl and half the adjacent !! layer thicknesses are used to calculate a_cpl near the bottom. -subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & - dt, j, G, GV, US, CS, visc, forces, work_on_u, OBC, shelf) +subroutine find_coupling_coef(a_cpl, hvel, i, j, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & + dt, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u, OBC, shelf) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZIB_(G),SZK_(GV)+1), & - intent(out) :: a_cpl !< Coupling coefficient across interfaces [Z T-1 ~> m s-1]. - real, dimension(SZIB_(G),SZK_(GV)), & - intent(in) :: hvel !< Thickness at velocity points [H ~> m or kg m-2] - logical, dimension(SZIB_(G)), & - intent(in) :: do_i !< If true, determine coupling coefficient for a column - real, dimension(SZIB_(G),SZK_(GV)), & + real, dimension(SZK_(GV)+1), & + intent(out) :: a_cpl !< Coupling coefficient across interfaces [H T-1 ~> m s-1 or Pa s m-1] + real, dimension(SZK_(GV)), & + intent(in) :: hvel !< Distance between interfaces at velocity points [Z ~> m] + integer, intent(in) :: i !< Column i-index + integer, intent(in) :: j !< Column j-index + real, dimension(SZK_(GV)), & intent(in) :: h_harm !< Harmonic mean of thicknesses around a velocity - !! grid point [H ~> m or kg m-2] - real, dimension(SZIB_(G)), intent(in) :: bbl_thick !< Bottom boundary layer thickness [H ~> m or kg m-2] - real, dimension(SZIB_(G)), intent(in) :: kv_bbl !< Bottom boundary layer viscosity [Z2 T-1 ~> m2 s-1]. - real, dimension(SZIB_(G),SZK_(GV)+1), & + !! grid point [Z ~> m] + real, intent(in) :: bbl_thick !< Bottom boundary layer thickness [Z ~> m] + real, intent(in) :: kv_bbl !< Bottom boundary layer viscosity, exclusive of + !! any depth-dependent contributions from + !! visc%Kv_shear [H Z T-1 ~> m2 s-1 or Pa s] + real, dimension(SZK_(GV)+1), & intent(in) :: z_i !< Estimate of interface heights above the bottom, - !! normalized by the bottom boundary layer thickness - real, dimension(SZIB_(G)), intent(out) :: h_ml !< Mixed layer depth [H ~> m or kg m-2] - integer, intent(in) :: j !< j-index to find coupling coefficient for + !! normalized by the bottom boundary layer thickness [nondim] + real, intent(out) :: h_ml !< Mixed layer depth [Z ~> m] real, intent(in) :: dt !< Time increment [T ~> s] - type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure + type(vertvisc_CS), intent(in) :: CS !< Vertical viscosity control structure type(vertvisc_type), intent(in) :: visc !< Structure containing viscosities and bottom drag - type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: Ustar_2d !< The wind friction velocity, calculated using + !! the Boussinesq reference density or the + !! time-evolving surface density in non-Boussinesq + !! mode [Z T-1 ~> m s-1] + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available + !! thermodynamic fields. logical, intent(in) :: work_on_u !< If true, u-points are being calculated, !! otherwise they are v-points type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure @@ -1154,250 +2073,477 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! Local variables - real, dimension(SZIB_(G)) :: & - u_star, & ! ustar at a velocity point [Z T-1 ~> m s-1]. + real :: & + u_star, & ! ustar at a velocity point [Z T-1 ~> m s-1] + tau_mag, & ! The magnitude of the wind stress at a velocity point including gustiness [H Z T-2 ~> m2 s-2 or Pa] absf, & ! The average of the neighboring absolute values of f [T-1 ~> s-1]. -! h_ml, & ! The mixed layer depth [H ~> m or kg m-2]. - nk_visc, & ! The (real) interface index of the base of mixed layer. + rho_av1, & ! The harmonic mean surface layer density at velocity points [R ~> kg m-3] z_t, & ! The distance from the top, sometimes normalized - ! by Hmix, [H ~> m or kg m-2] or [nondim]. - kv_TBL, & ! The viscosity in a top boundary layer under ice [Z2 T-1 ~> m2 s-1]. - tbl_thick - real, dimension(SZIB_(G),SZK_(GV)+1) :: & - Kv_tot, & ! The total viscosity at an interface [Z2 T-1 ~> m2 s-1]. - Kv_add ! A viscosity to add [Z2 T-1 ~> m2 s-1]. - real :: h_shear ! The distance over which shears occur [H ~> m or kg m-2]. - real :: r ! A thickness to compare with Hbbl [H ~> m or kg m-2]. - real :: visc_ml ! The mixed layer viscosity [Z2 T-1 ~> m2 s-1]. - real :: I_Hmix ! The inverse of the mixed layer thickness [H-1 ~> m-1 or m2 kg-1]. + ! by Hmix, [Z ~> m] or [nondim]. + kv_TBL, & ! The viscosity in a top boundary layer under ice [H Z T-1 ~> m2 s-1 or Pa s] + tbl_thick, &! The thickness of the top boundary layer [Z ~> m] + Kv_add, & ! A viscosity to add [H Z T-1 ~> m2 s-1 or Pa s] + Kv_tot ! The total viscosity at an interface [H Z T-1 ~> m2 s-1 or Pa s] + integer :: & + nk_in_ml ! The index of the deepest interface in the mixed layer. + real :: h_shear ! The distance over which shears occur [Z ~> m]. + real :: dhc ! The distance between the center of adjacent layers [Z ~> m]. + real :: visc_ml ! The mixed layer viscosity [H Z T-1 ~> m2 s-1 or Pa s]. + real :: I_Hmix ! The inverse of the mixed layer thickness [Z-1 ~> m-1]. real :: a_ml ! The layer coupling coefficient across an interface in - ! the mixed layer [Z T-1 ~> m s-1]. - real :: I_amax ! The inverse of the maximum coupling coefficient [T Z-1 ~> s m-1]. - real :: temp1 ! A temporary variable [H Z ~> m2 or kg m-1] - real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected [H ~> m or kg m-2]. + ! the mixed layer [H T-1 ~> m s-1 or Pa s m-1]. + real :: a_floor ! A lower bound on the layer coupling coefficient across an interface in + ! the mixed layer [H T-1 ~> m s-1 or Pa s m-1]. + real :: I_amax ! The inverse of the maximum coupling coefficient [T H-1 ~> s m-1 or s m2 kg-1]. + real :: temp1 ! A temporary variable [Z2 ~> m2] + real :: ustar2_denom ! A temporary variable in the surface boundary layer turbulence + ! calculations [H Z-1 T-1 ~> s-1 or kg m-3 s-1] + real :: h_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. real :: z2 ! A copy of z_i [nondim] real :: botfn ! A function that is 1 at the bottom and small far from it [nondim] real :: topfn ! A function that is 1 at the top and small far from it [nondim] - real :: kv_top ! A viscosity associated with the top boundary layer [Z2 T-1 ~> m2 s-1] - logical :: do_shelf, do_OBCs - integer :: i, k, is, ie, max_nk - integer :: nz + real :: kv_top ! A viscosity associated with the top boundary layer [H Z T-1 ~> m2 s-1 or Pa s] + logical :: do_shelf, do_OBCs, can_exit + integer :: k + integer :: nz, max_nk - a_cpl(:,:) = 0.0 - Kv_tot(:,:) = 0.0 - - if (work_on_u) then ; is = G%IscB ; ie = G%IecB - else ; is = G%isc ; ie = G%iec ; endif nz = GV%ke - h_neglect = GV%H_subroundoff - if (CS%answers_2018) then + h_neglect = GV%dZ_subroundoff + + if (CS%answer_date < 20190101) then ! The maximum coupling coefficient was originally introduced to avoid ! truncation error problems in the tridiagonal solver. Effectively, the 1e-10 ! sets the maximum coupling coefficient increment to 1e10 m per timestep. - I_amax = (1.0e-10*US%Z_to_m) * dt + I_amax = (1.0e-10*GV%H_to_m) * dt else I_amax = 0.0 endif do_shelf = .false. ; if (present(shelf)) do_shelf = shelf + do_OBCs = .false. - if (associated(OBC)) then ; do_OBCS = (OBC%number_of_segments > 0) ; endif - h_ml(:) = 0.0 - -! The following loop calculates the vertical average velocity and -! surface mixed layer contributions to the vertical viscosity. - do i=is,ie ; Kv_tot(i,1) = 0.0 ; enddo - if ((GV%nkml>0) .or. do_shelf) then ; do k=2,nz ; do i=is,ie - if (do_i(i)) Kv_tot(i,K) = CS%Kv - enddo ; enddo ; else - I_Hmix = 1.0 / (CS%Hmix + h_neglect) - do i=is,ie ; z_t(i) = h_neglect*I_Hmix ; enddo - do K=2,nz ; do i=is,ie ; if (do_i(i)) then - z_t(i) = z_t(i) + h_harm(i,k-1)*I_Hmix - Kv_tot(i,K) = CS%Kv + CS%Kvml / ((z_t(i)*z_t(i)) * & - (1.0 + 0.09*z_t(i)*z_t(i)*z_t(i)*z_t(i)*z_t(i)*z_t(i))) - endif ; enddo ; enddo + if (associated(OBC)) then + if (work_on_u) then + do_OBCS = OBC%u_E_OBCs_on_PE .or. OBC%u_W_OBCs_on_PE + else + do_OBCS = OBC%v_N_OBCs_on_PE .or. OBC%v_S_OBCs_on_PE + endif endif - do i=is,ie ; if (do_i(i)) then - if (CS%bottomdraglaw) then - r = hvel(i,nz)*0.5 - if (r < bbl_thick(i)) then - a_cpl(i,nz+1) = kv_bbl(i) / (I_amax*kv_bbl(i) + (r+h_neglect)*GV%H_to_Z) - else - a_cpl(i,nz+1) = kv_bbl(i) / (I_amax*kv_bbl(i) + (bbl_thick(i)+h_neglect)*GV%H_to_Z) - endif - else - a_cpl(i,nz+1) = CS%Kvbbl / ((0.5*hvel(i,nz)+h_neglect)*GV%H_to_Z + I_amax*CS%Kvbbl) + a_cpl(:) = 0. + h_ml = 0. + + if (CS%Kvml_invZ2 > 0. .and. .not. do_shelf) then + I_Hmix = 1. / (CS%Hmix + h_neglect) + z_t = h_neglect * I_Hmix + endif + + do K=2,nz + Kv_tot = CS%Kv + + if (CS%Kvml_invZ2 > 0. .and. .not. do_shelf) then + ! This is an older (vintage ~1997) way to prevent wind stresses from driving very + ! large flows in nearly massless near-surface layers when there is not a physically- + ! based surface boundary layer parameterization. It does not have a plausible + ! physical basis, and probably should not be used. + z_t = z_t + h_harm(k-1) * I_Hmix + Kv_tot = CS%Kv + CS%Kvml_invZ2 / ((z_t * z_t) * & + (1. + 0.09 * z_t * z_t * z_t * z_t * z_t * z_t)) endif - endif ; enddo - if (associated(visc%Kv_shear)) then - ! The factor of 2 that used to be required in the viscosities is no longer needed. - if (work_on_u) then - do K=2,nz ; do i=is,ie ; if (do_i(i)) then - Kv_add(i,K) = 0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i+1,j,k)) - endif ; enddo ; enddo - if (do_OBCs) then - do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i,j,k) ; enddo - elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i+1,j,k) ; enddo + if (associated(visc%Kv_shear)) then + ! Add in viscosities that are determined by physical processes that are handled in + ! other modules, and which do not respond immediately to the changing layer thicknesses. + ! These processes may include shear-driven mixing or contributions from some boundary + ! layer turbulence schemes. Other viscosity contributions that respond to the evolving + ! layer thicknesses or the surface wind stresses are added later. + if (work_on_u) then + Kv_add = 0.5 * (visc%Kv_shear(i,j,k) + visc%Kv_shear(i+1,j,k)) + + if (do_OBCs) then + if (OBC%u_E_OBCs_on_PE) then + if (OBC%segnum_u(I,j) > 0) then + Kv_add = visc%Kv_shear(i,j,k) + endif endif - endif ; enddo - endif - do K=2,nz ; do i=is,ie ; if (do_i(i)) then - Kv_tot(i,K) = Kv_tot(i,K) + Kv_add(i,K) - endif ; enddo ; enddo - else - do K=2,nz ; do i=is,ie ; if (do_i(i)) then - Kv_add(i,K) = 0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i,j+1,k)) - endif ; enddo ; enddo - if (do_OBCs) then - do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i,j,k) ; enddo - elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i,j+1,k) ; enddo + + if (OBC%u_W_OBCs_on_PE) then + if (OBC%segnum_u(I,j) < 0) then + Kv_add = visc%Kv_shear(i+1,j,k) + endif endif - endif ; enddo + endif + + Kv_tot = Kv_tot + Kv_add + else + Kv_add = 0.5 * (visc%Kv_shear(i,j,k) + visc%Kv_shear(i,j+1,k)) + + if (do_OBCs) then + if (OBC%v_N_OBCs_on_PE) then + if (OBC%segnum_v(i,J) > 0) then + Kv_add = visc%Kv_shear(i,j,k) + endif + endif + + if (OBC%v_S_OBCs_on_PE) then + if (OBC%segnum_v(i,J) < 0) then + Kv_add = visc%Kv_shear(i,j+1,k) + endif + endif + endif + + Kv_tot = Kv_tot + Kv_add endif - do K=2,nz ; do i=is,ie ; if (do_i(i)) then - Kv_tot(i,K) = Kv_tot(i,K) + Kv_add(i,K) - endif ; enddo ; enddo endif - endif - if (associated(visc%Kv_shear_Bu)) then - if (work_on_u) then - do K=2,nz ; do I=Is,Ie ; If (do_i(I)) then - Kv_tot(I,K) = Kv_tot(I,K) + (0.5)*(visc%Kv_shear_Bu(I,J-1,k) + visc%Kv_shear_Bu(I,J,k)) - endif ; enddo ; enddo - else - do K=2,nz ; do i=is,ie ; if (do_i(i)) then - Kv_tot(i,K) = Kv_tot(i,K) + (0.5)*(visc%Kv_shear_Bu(I-1,J,k) + visc%Kv_shear_Bu(I,J,k)) - endif ; enddo ; enddo + if (associated(visc%Kv_shear_Bu)) then + ! This is similar to what was done above, but for contributions coming from the corner + ! (vorticity) points. Because OBCs run through the faces and corners there is no need + ! to further modify these viscosities here to take OBCs into account. + if (work_on_u) then + Kv_tot = Kv_tot + 0.5 * (visc%Kv_shear_Bu(I,J-1,k) + visc%Kv_shear_Bu(I,J,k)) + else + Kv_tot = Kv_tot + 0.5 * (visc%Kv_shear_Bu(I-1,J,k) + visc%Kv_shear_Bu(I,J,k)) + endif endif - endif - - do K=nz,2,-1 ; do i=is,ie ; if (do_i(i)) then - ! botfn determines when a point is within the influence of the bottom - ! boundary layer, going from 1 at the bottom to 0 in the interior. - z2 = z_i(i,k) - botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) + ! Set the viscous coupling coefficients, excluding surface mixed layer contributions + ! for now, but including viscous bottom drag, working up from the bottom. if (CS%bottomdraglaw) then - Kv_tot(i,K) = Kv_tot(i,K) + (kv_bbl(i) - CS%Kv)*botfn - r = 0.5*(hvel(i,k) + hvel(i,k-1)) - if (r > bbl_thick(i)) then - h_shear = ((1.0 - botfn) * r + botfn*bbl_thick(i)) + h_neglect + ! botfn determines when a point is within the influence of the bottom + ! boundary layer, going from 1 at the bottom to 0 in the interior. + z2 = z_i(k) + botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) + + Kv_tot = Kv_tot + (kv_bbl - CS%Kv) * botfn + dhc = 0.5 * (hvel(k) + hvel(k-1)) + if (dhc > bbl_thick) then + h_shear = ((1. - botfn) * dhc + botfn * bbl_thick) + h_neglect else - h_shear = r + h_neglect + h_shear = dhc + h_neglect endif + + ! Calculate the coupling coefficients from the viscosities. + a_cpl(K) = Kv_tot / (h_shear + (I_amax * Kv_tot)) + elseif (abs(CS%Kv_extra_bbl) > 0.0) then + ! There is a simple enhancement of the near-bottom viscosities, but no + ! adjustment of the viscous coupling length scales to give a particular + ! bottom stress. + + ! botfn determines when a point is within the influence of the bottom + ! boundary layer, going from 1 at the bottom to 0 in the interior. + z2 = z_i(k) + botfn = 1. / (1. + 0.09 * z2 * z2 * z2 * z2 * z2 * z2) + + Kv_tot = Kv_tot + CS%Kv_extra_bbl * botfn + h_shear = 0.5 * (hvel(k) + hvel(k-1) + h_neglect) + + ! Calculate the coupling coefficients from the viscosities. + a_cpl(K) = Kv_tot / (h_shear + I_amax * Kv_tot) else - Kv_tot(i,K) = Kv_tot(i,K) + (CS%Kvbbl-CS%Kv)*botfn - h_shear = 0.5*(hvel(i,k) + hvel(i,k-1) + h_neglect) + ! Any near-bottom viscous enhancements were already incorporated into + ! Kv_tot, and there is no adjustment of the viscous coupling length + ! scales to give a particular bottom stress. + + h_shear = 0.5 * (hvel(k) + hvel(k-1) + h_neglect) + ! Calculate the coupling coefficients from the viscosities. + a_cpl(K) = Kv_tot / (h_shear + I_amax * Kv_tot) endif + enddo - ! Calculate the coupling coefficients from the viscosities. - a_cpl(i,K) = Kv_tot(i,K) / (h_shear*GV%H_to_Z + I_amax*Kv_tot(i,K)) - endif ; enddo ; enddo ! i & k loops + ! Assign the bottom coupling coefficients + if (CS%bottomdraglaw) then + dhc = hvel(nz) * 0.5 + a_cpl(nz+1) = kv_bbl / ((min(dhc, bbl_thick) + h_neglect) + I_amax * kv_bbl) + elseif (abs(CS%Kv_extra_bbl) > 0.0) then + a_cpl(nz+1) = (CS%Kv + CS%Kv_extra_bbl) & + / ((0.5 * hvel(nz) + h_neglect) + I_amax * (CS%Kv + CS%Kv_extra_bbl)) + else + a_cpl(nz+1) = CS%Kv / ((0.5 * hvel(nz) + h_neglect) + I_amax * CS%Kv) + endif + ! Add surface intensified viscous coupling, either as a no-slip boundary condition under a + ! rigid ice-shelf, or due to wind-stress driven surface boundary layer mixing that has not + ! already been added via visc%Kv_shear. if (do_shelf) then ! Set the coefficients to include the no-slip surface stress. - do i=is,ie ; if (do_i(i)) then - if (work_on_u) then - kv_TBL(i) = visc%Kv_tbl_shelf_u(I,j) - tbl_thick(i) = visc%tbl_thick_shelf_u(I,j) * GV%Z_to_H + h_neglect + if (work_on_u) then + kv_TBL = visc%Kv_tbl_shelf_u(I,j) + tbl_thick = visc%tbl_thick_shelf_u(I,j) + h_neglect + else + kv_TBL = visc%Kv_tbl_shelf_v(i,J) + tbl_thick = visc%tbl_thick_shelf_v(i,J) + h_neglect + endif + + z_t = 0.0 + + ! If a_cpl(1) were not already 0, it would be added here. + if (0.5 * hvel(1) > tbl_thick) then + a_cpl(1) = kv_TBL / (tbl_thick + I_amax * kv_TBL) + else + a_cpl(1) = kv_TBL / ((0.5 * hvel(1) + h_neglect) + I_amax * kv_TBL) + endif + + do K=2,nz + z_t = z_t + hvel(k-1) / tbl_thick + topfn = 1. / (1. + 0.09 * z_t**6) + + dhc = 0.5 * (hvel(k) + hvel(k-1)) + if (dhc > tbl_thick) then + h_shear = ((1. - topfn) * dhc + topfn * tbl_thick) + h_neglect else - kv_TBL(i) = visc%Kv_tbl_shelf_v(i,J) - tbl_thick(i) = visc%tbl_thick_shelf_v(i,J) * GV%Z_to_H + h_neglect + h_shear = dhc + h_neglect endif - z_t(i) = 0.0 - ! If a_cpl(i,1) were not already 0, it would be added here. - if (0.5*hvel(i,1) > tbl_thick(i)) then - a_cpl(i,1) = kv_TBL(i) / (tbl_thick(i)*GV%H_to_Z + I_amax*kv_TBL(i)) + kv_top = topfn * kv_TBL + a_cpl(K) = a_cpl(K) + kv_top / (h_shear + I_amax * kv_top) + enddo + elseif (CS%dynamic_viscous_ML .or. (GV%nkml>0) .or. CS%fixed_LOTW_ML .or. CS%apply_LOTW_floor) then + + ! Find the friction velocity and the absolute value of the Coriolis parameter at this point. + u_star = 0. ! Zero out the friction velocity on land points. + tau_mag = 0. ! Zero out the friction velocity on land points. + + if (allocated(tv%SpV_avg)) then + rho_av1 = 0. + + if (work_on_u) then + u_star = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i+1,j)) + rho_av1 = 2. / (tv%SpV_avg(i,j,1) + tv%SpV_avg(i+1,j,1)) + absf = 0.5 * (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) + + if (do_OBCs) then + if (OBC%u_E_OBCs_on_PE) then + if (OBC%segnum_u(I,j) > 0) then + u_star = Ustar_2d(i,j) + rho_av1 = 1. / tv%SpV_avg(i,j,1) + endif + endif + + if (OBC%u_W_OBCs_on_PE) then + if (OBC%segnum_u(I,j) < 0) then + u_star = Ustar_2d(i+1,j) + rho_av1 = 1. / tv%SpV_avg(i+1,j,1) + endif + endif + endif else - a_cpl(i,1) = kv_TBL(i) / ((0.5*hvel(i,1)+h_neglect)*GV%H_to_Z + I_amax*kv_TBL(i)) + u_star = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i,j+1)) + rho_av1 = 2. / (tv%SpV_avg(i,j,1) + tv%SpV_avg(i,j+1,1)) + absf = 0.5 * (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) + + if (do_OBCs) then + if (OBC%v_N_OBCs_on_PE) then + if (OBC%segnum_v(i,J) > 0) then + u_star = Ustar_2d(i,j) + rho_av1 = 1. / tv%SpV_avg(i,j,1) + endif + endif + + if (OBC%v_S_OBCs_on_PE) then + if (OBC%segnum_v(i,J) < 0) then + u_star = Ustar_2d(i,j+1) + rho_av1 = 1. / tv%SpV_avg(i,j+1,1) + endif + endif + endif endif - endif ; enddo - do K=2,nz ; do i=is,ie ; if (do_i(i)) then - z_t(i) = z_t(i) + hvel(i,k-1) / tbl_thick(i) - topfn = 1.0 / (1.0 + 0.09 * z_t(i)**6) + tau_mag = GV%RZ_to_H * rho_av1 * u_star**2 + else ! (.not.allocated(tv%SpV_avg)) + if (work_on_u) then + u_star = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i+1,j)) + absf = 0.5 * (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) - r = 0.5*(hvel(i,k)+hvel(i,k-1)) - if (r > tbl_thick(i)) then - h_shear = ((1.0 - topfn) * r + topfn*tbl_thick(i)) + h_neglect + if (do_OBCs) then + if (OBC%u_E_OBCs_on_PE) then + if (OBC%segnum_u(I,j) > 0) then + u_star = Ustar_2d(i,j) + endif + endif + + if (OBC%u_W_OBCs_on_PE) then + if (OBC%segnum_u(I,j) < 0) then + u_star = Ustar_2d(i+1,j) + endif + endif + endif else - h_shear = r + h_neglect + u_star = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i,j+1)) + absf = 0.5 * (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) + + if (do_OBCs) then + if (OBC%v_N_OBCs_on_PE) then + if (OBC%segnum_v(i,J) > 0) then + u_star = Ustar_2d(i,j) + endif + endif + + if (OBC%v_S_OBCs_on_PE) then + if (OBC%segnum_v(i,J) < 0) then + u_star = Ustar_2d(i,j+1) + endif + endif + endif endif - kv_top = topfn * kv_TBL(i) - a_cpl(i,K) = a_cpl(i,K) + kv_top / (h_shear*GV%H_to_Z + I_amax*kv_top) - endif ; enddo ; enddo - elseif (CS%dynamic_viscous_ML .or. (GV%nkml>0)) then - max_nk = 0 - do i=is,ie ; if (do_i(i)) then - if (GV%nkml>0) nk_visc(i) = real(GV%nkml+1) + tau_mag = GV%Z_to_H * u_star**2 + endif + + ! Determine the thickness of the surface ocean boundary layer and its extent in index space. + nk_in_ml = 0 + if (CS%dynamic_viscous_ML) then + ! The fractional number of layers that are within the viscous boundary layer were + ! previously stored in visc%nkml_visc_[uv]. + h_ml = h_neglect + max_nk = 0 + if (work_on_u) then - u_star(I) = 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j)) - absf(I) = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) - if (CS%dynamic_viscous_ML) nk_visc(I) = visc%nkml_visc_u(I,j) + 1 + nk_in_ml = ceiling(visc%nkml_visc_u(I,j)) + max_nk = max(max_nk, nk_in_ml) + + do k=1,max_nk + if (k <= visc%nkml_visc_u(I,j)) then ! This layer is all in the ML. + h_ml = h_ml + hvel(k) + elseif (k < visc%nkml_visc_u(I,j) + 1.) then ! Part of this layer is in the ML. + h_ml = h_ml + ((visc%nkml_visc_u(I,j) + 1.) - k) * hvel(k) + endif + enddo else - u_star(i) = 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1)) - absf(i) = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) - if (CS%dynamic_viscous_ML) nk_visc(i) = visc%nkml_visc_v(i,J) + 1 + nk_in_ml = ceiling(visc%nkml_visc_v(i,J)) + max_nk = max(max_nk, nk_in_ml) + + do k=1,max_nk + if (k <= visc%nkml_visc_v(i,J)) then ! This layer is all in the ML. + h_ml = h_ml + hvel(k) + elseif (k < visc%nkml_visc_v(i,J) + 1.) then ! Part of this layer is in the ML. + h_ml = h_ml + ((visc%nkml_visc_v(i,J) + 1.) - k) * hvel(k) + endif + enddo endif - h_ml(i) = h_neglect ; z_t(i) = 0.0 - max_nk = max(max_nk,ceiling(nk_visc(i) - 1.0)) - endif ; enddo - - if (do_OBCS) then ; if (work_on_u) then - do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) & - u_star(I) = forces%ustar(i,j) - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) & - u_star(I) = forces%ustar(i+1,j) - endif ; enddo + elseif (GV%nkml>0) then + ! This is a simple application of a refined-bulk mixed layer with GV%nkml sublayers. + max_nk = GV%nkml + nk_in_ml = GV%nkml + + h_ml = h_neglect + + do k=1,GV%nkml + h_ml = h_ml + hvel(k) + enddo + elseif (CS%fixed_LOTW_ML .or. CS%apply_LOTW_floor) then + ! Determine which interfaces are within CS%Hmix of the surface, and set the viscous + ! boundary layer thickness to the smaller of CS%Hmix and the depth of the ocean. + h_ml = 0.0 + do k=1,nz + can_exit = .true. + if (h_ml < CS%Hmix) then + nk_in_ml = k + + if (h_ml + hvel(k) < CS%Hmix) then + h_ml = h_ml + hvel(k) + can_exit = .false. ! Part of the next deeper layer is also in the mixed layer. + else + h_ml = CS%Hmix + endif + endif + + if (can_exit) exit ! All remaining layers in this row are below the mixed layer depth. + enddo + + max_nk = max(0, nk_in_ml) + endif + + ! Avoid working on columns where the viscous coupling could not be increased. + if (u_star <= 0.) nk_in_ml = 0 + + ! Set the viscous coupling at the interfaces as the larger of what was previously + ! set and the contributions from the surface boundary layer. + z_t = 0. + if (CS%apply_LOTW_floor .and. & + (CS%dynamic_viscous_ML .or. GV%nkml > 0 .or. CS%fixed_LOTW_ML)) then + do K=2,max_nk + if (k <= nk_in_ml) then + z_t = z_t + hvel(k-1) + + ! The viscosity in visc_ml is set to go to 0 at the mixed layer top and bottom + ! (in a log-layer) and be further limited by rotation to give the natural Ekman length. + temp1 = (z_t * h_ml - z_t * z_t) + if (GV%Boussinesq) then + ustar2_denom = (CS%vonKar * GV%Z_to_H * u_star**2) & + / (absf * temp1 + (h_ml + h_neglect) * u_star) + else + ustar2_denom = (CS%vonKar * tau_mag) & + / (absf * temp1 + (h_ml + h_neglect) * u_star) + endif + + visc_ml = temp1 * ustar2_denom + ! Set the viscous coupling based on the model's vertical resolution. The omission of + ! the I_amax factor here is consistent with answer dates above 20190101. + a_ml = visc_ml / (0.25 * (hvel(k) + hvel(k-1) + h_neglect)) + + ! As a floor on the viscous coupling, assume that the length scale in the denominator can + ! not be larger than the distance from the surface, consistent with a logarithmic velocity + ! profile. This is consistent with visc_ml, but cancels out common factors of z_t. + a_floor = (h_ml - z_t) * ustar2_denom + + ! Choose the largest estimate of a_cpl. + a_cpl(K) = max(a_cpl(K), a_ml, a_floor) + ! An option could be added to change this to: a_cpl(i,K) = max(a_cpl(i,K) + a_ml, a_floor) + endif + enddo + elseif (CS%apply_LOTW_floor) then + do K=2,max_nk + if (k <= nk_in_ml) then + z_t = z_t + hvel(k-1) + + temp1 = (z_t * h_ml - z_t * z_t) + if (GV%Boussinesq) then + ustar2_denom = (CS%vonKar * GV%Z_to_H * u_star**2) & + / (absf * temp1 + (h_ml + h_neglect) * u_star) + else + ustar2_denom = (CS%vonKar * tau_mag) & + / (absf * temp1 + (h_ml + h_neglect) * u_star) + endif + + ! As a floor on the viscous coupling, assume that the length scale in the denominator can not + ! be larger than the distance from the surface, consistent with a logarithmic velocity profile. + a_cpl(K) = max(a_cpl(K), (h_ml - z_t) * ustar2_denom) + endif + enddo else - do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) & - u_star(i) = forces%ustar(i,j) - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) & - u_star(i) = forces%ustar(i,j+1) - endif ; enddo - endif ; endif - - do k=1,max_nk ; do i=is,ie ; if (do_i(i)) then - if (k+1 <= nk_visc(i)) then ! This layer is all in the ML. - h_ml(i) = h_ml(i) + hvel(i,k) - elseif (k < nk_visc(i)) then ! Part of this layer is in the ML. - h_ml(i) = h_ml(i) + (nk_visc(i) - k) * hvel(i,k) - endif - endif ; enddo ; enddo + do K=2,max_nk + if (k <= nk_in_ml) then + z_t = z_t + hvel(k-1) + + temp1 = (z_t * h_ml - z_t * z_t) + ! This viscosity is set to go to 0 at the mixed layer top and bottom (in a log-layer) + ! and be further limited by rotation to give the natural Ekman length. + ! The following expressions are mathematically equivalent. + if (GV%Boussinesq .or. (CS%answer_date < 20230601)) then + visc_ml = u_star * CS%vonKar * (GV%Z_to_H * temp1 * u_star) & + / (absf * temp1 + (h_ml + h_neglect) * u_star) + else + visc_ml = CS%vonKar * (temp1 * tau_mag) & + / (absf * temp1 + (h_ml + h_neglect) * u_star) + endif + a_ml = visc_ml / (0.25 * (hvel(k) + hvel(k-1) + h_neglect) + 0.5 * I_amax * visc_ml) - do K=2,max_nk ; do i=is,ie ; if (do_i(i)) then ; if (k < nk_visc(i)) then - ! Set the viscosity at the interfaces. - z_t(i) = z_t(i) + hvel(i,k-1) - temp1 = (z_t(i)*h_ml(i) - z_t(i)*z_t(i))*GV%H_to_Z - ! This viscosity is set to go to 0 at the mixed layer top and bottom (in a log-layer) - ! and be further limited by rotation to give the natural Ekman length. - visc_ml = u_star(i) * 0.41 * (temp1*u_star(i)) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) - a_ml = visc_ml / (0.25*(hvel(i,k)+hvel(i,k-1) + h_neglect) * GV%H_to_Z + 0.5*I_amax*visc_ml) - ! Choose the largest estimate of a. - if (a_ml > a_cpl(i,K)) a_cpl(i,K) = a_ml - endif ; endif ; enddo ; enddo + ! Choose the largest estimate of a_cpl, but these could be changed to be additive. + a_cpl(K) = max(a_cpl(K), a_ml) + ! An option could be added to change this to: a_cpl(i,K) = a_cpl(i,K) + a_ml + endif + enddo + endif endif - end subroutine find_coupling_coef -!> Velocity components which exceed a threshold for physically reasonable values -!! are truncated. Optionally, any column with excessive velocities may be sent + +!> Velocity components which exceed a threshold for physically reasonable values are truncated, +!! and the running sum of the number of trunctionas within the non-symmetric memory computational +!! domain is incremented. Optionally, any column with excessive velocities may be sent !! to a diagnostic reporting subroutine. subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure @@ -1417,198 +2563,154 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure ! Local variables - - real :: maxvel ! Velocities components greater than maxvel - real :: truncvel ! are truncated to truncvel, both [L T-1 ~> m s-1]. - real :: CFL ! The local CFL number. - real :: H_report ! A thickness below which not to report truncations. + real :: CFL ! The local CFL number [nondim] + real :: H_report ! A thickness below which not to report truncations [H ~> m or kg m-2] real :: vel_report(SZIB_(G),SZJB_(G)) ! The velocity to report [L T-1 ~> m s-1] real :: u_old(SZIB_(G),SZJ_(G),SZK_(GV)) ! The previous u-velocity [L T-1 ~> m s-1] real :: v_old(SZI_(G),SZJB_(G),SZK_(GV)) ! The previous v-velocity [L T-1 ~> m s-1] logical :: trunc_any, dowrite(SZIB_(G),SZJB_(G)) + logical :: do_any_write integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - maxvel = CS%maxvel - truncvel = 0.9*maxvel - H_report = 6.0 * GV%Angstrom_H + H_report = 3.0 * GV%Angstrom_H if (len_trim(CS%u_trunc_file) > 0) then - !$OMP parallel do default(shared) private(trunc_any,CFL) - do j=js,je - trunc_any = .false. - do I=Isq,Ieq ; dowrite(I,j) = .false. ; enddo - if (CS%CFL_based_trunc) then - do I=Isq,Ieq ; vel_report(i,j) = 3.0e8*US%m_s_to_L_T ; enddo ! Speed of light default. - do k=1,nz ; do I=Isq,Ieq - if (abs(u(I,j,k)) < CS%vel_underflow) u(I,j,k) = 0.0 - if (u(I,j,k) < 0.0) then - CFL = (-u(I,j,k) * dt) * (G%dy_Cu(I,j) * G%IareaT(i+1,j)) - else - CFL = (u(I,j,k) * dt) * (G%dy_Cu(I,j) * G%IareaT(i,j)) - endif - if (CFL > CS%CFL_trunc) trunc_any = .true. - if (CFL > CS%CFL_report) then - dowrite(I,j) = .true. - vel_report(I,j) = MIN(vel_report(I,j), abs(u(I,j,k))) - endif - enddo ; enddo + do_any_write = .false. + trunc_any = .false. + + do j=js,je ; do I=Isq,Ieq + dowrite(I,j) = .false. + vel_report(I,j) = 3.0e8 * US%m_s_to_L_T + enddo ; enddo + + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + if (abs(u(I,j,k)) < CS%vel_underflow) u(I,j,k) = 0.0 + if (u(I,j,k) < 0.0) then + CFL = (-u(I,j,k) * dt) * (G%dy_Cu(I,j) * G%IareaT(i+1,j)) else - do I=Isq,Ieq; vel_report(I,j) = maxvel; enddo - do k=1,nz ; do I=Isq,Ieq - if (abs(u(I,j,k)) < CS%vel_underflow) then ; u(I,j,k) = 0.0 - elseif (abs(u(I,j,k)) > maxvel) then - dowrite(I,j) = .true. ; trunc_any = .true. - endif - enddo ; enddo + CFL = (u(I,j,k) * dt) * (G%dy_Cu(I,j) * G%IareaT(i,j)) endif + if (CFL > CS%CFL_trunc) trunc_any = .true. + if (CFL > CS%CFL_report) then + dowrite(I,j) = .true. + do_any_write = .true. + vel_report(I,j) = min(vel_report(I,j), abs(u(I,j,k))) + endif + enddo ; enddo ; enddo - do I=Isq,Ieq ; if (dowrite(I,j)) then - u_old(I,j,:) = u(I,j,:) - endif ; enddo - - if (trunc_any) then ; if (CS%CFL_based_trunc) then - do k=1,nz ; do I=Isq,Ieq - if ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i+1,j) < -CS%CFL_trunc) then - u(I,j,k) = (-0.9*CS%CFL_trunc) * (G%areaT(i+1,j) / (dt * G%dy_Cu(I,j))) - if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1 - elseif ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i,j) > CS%CFL_trunc) then - u(I,j,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dy_Cu(I,j))) - if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1 - endif - enddo ; enddo - else - do k=1,nz ; do I=Isq,Ieq ; if (abs(u(I,j,k)) > maxvel) then - u(I,j,k) = SIGN(truncvel,u(I,j,k)) - if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1 - endif ; enddo ; enddo - endif ; endif - enddo ! j-loop - else ! Do not report accelerations leading to large velocities. - if (CS%CFL_based_trunc) then -!$OMP parallel do default(none) shared(nz,js,je,Isq,Ieq,u,dt,G,CS,h,H_report) + do j=js,je ; do I=Isq,Ieq ; if (dowrite(I,j)) then + u_old(I,j,:) = u(I,j,:) + endif ; enddo ; enddo + + if (trunc_any) then do k=1,nz ; do j=js,je ; do I=Isq,Ieq - if (abs(u(I,j,k)) < CS%vel_underflow) then ; u(I,j,k) = 0.0 - elseif ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i+1,j) < -CS%CFL_trunc) then + if ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i+1,j) < -CS%CFL_trunc) then u(I,j,k) = (-0.9*CS%CFL_trunc) * (G%areaT(i+1,j) / (dt * G%dy_Cu(I,j))) - if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1 + if (((I >= G%isc) .and. (I <= G%iec) .and. (j >= G%jsc) .and. (j <= G%jec)) .and. & + (CS%h_u(I,j,k) > H_report)) CS%ntrunc = CS%ntrunc + 1 elseif ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i,j) > CS%CFL_trunc) then u(I,j,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dy_Cu(I,j))) - if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1 - endif - enddo ; enddo ; enddo - else -!$OMP parallel do default(none) shared(nz,js,je,Isq,Ieq,u,G,CS,truncvel,maxvel,h,H_report) - do k=1,nz ; do j=js,je ; do I=Isq,Ieq - if (abs(u(I,j,k)) < CS%vel_underflow) then ; u(I,j,k) = 0.0 - elseif (abs(u(I,j,k)) > maxvel) then - u(I,j,k) = SIGN(truncvel, u(I,j,k)) - if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1 + if (((I >= G%isc) .and. (I <= G%iec) .and. (j >= G%jsc) .and. (j <= G%jec)) .and. & + (CS%h_u(I,j,k) > H_report)) CS%ntrunc = CS%ntrunc + 1 endif enddo ; enddo ; enddo endif - endif - if (len_trim(CS%u_trunc_file) > 0) then - do j=js,je ; do I=Isq,Ieq ; if (dowrite(I,j)) then -! Here the diagnostic reporting subroutines are called if -! unphysically large values were found. - call write_u_accel(I, j, u_old, h, ADp, CDp, dt, G, GV, US, CS%PointAccel_CSp, & - vel_report(I,j), forces%taux(I,j), a=CS%a_u, hv=CS%h_u) - endif ; enddo ; enddo + if (do_any_write) then + do j=js,je ; do I=Isq,Ieq ; if (dowrite(I,j)) then + ! Call a diagnostic reporting subroutines are called if unphysically large values are found. + call write_u_accel(I, j, u_old, h, ADp, CDp, dt, G, GV, US, CS%PointAccel_CSp, & + vel_report(I,j), forces%taux(I,j), a=CS%a_u, hv=CS%h_u) + endif ; enddo ; enddo + endif + else ! Do not report accelerations leading to large velocities. + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + if (abs(u(I,j,k)) < CS%vel_underflow) then ; u(I,j,k) = 0.0 + elseif ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i+1,j) < -CS%CFL_trunc) then + u(I,j,k) = (-0.9*CS%CFL_trunc) * (G%areaT(i+1,j) / (dt * G%dy_Cu(I,j))) + if (((I >= G%isc) .and. (I <= G%iec) .and. (j >= G%jsc) .and. (j <= G%jec)) .and. & + (CS%h_u(I,j,k) > H_report)) CS%ntrunc = CS%ntrunc + 1 + elseif ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i,j) > CS%CFL_trunc) then + u(I,j,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dy_Cu(I,j))) + if (((I >= G%isc) .and. (I <= G%iec) .and. (j >= G%jsc) .and. (j <= G%jec)) .and. & + (CS%h_u(I,j,k) > H_report)) CS%ntrunc = CS%ntrunc + 1 + endif + enddo ; enddo ; enddo endif if (len_trim(CS%v_trunc_file) > 0) then - !$OMP parallel do default(shared) private(trunc_any,CFL) - do J=Jsq,Jeq - trunc_any = .false. - do i=is,ie ; dowrite(i,J) = .false. ; enddo - if (CS%CFL_based_trunc) then - do i=is,ie ; vel_report(i,J) = 3.0e8*US%m_s_to_L_T ; enddo ! Speed of light default. - do k=1,nz ; do i=is,ie - if (abs(v(i,J,k)) < CS%vel_underflow) v(i,J,k) = 0.0 - if (v(i,J,k) < 0.0) then - CFL = (-v(i,J,k) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j+1)) - else - CFL = (v(i,J,k) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j)) - endif - if (CFL > CS%CFL_trunc) trunc_any = .true. - if (CFL > CS%CFL_report) then - dowrite(i,J) = .true. - vel_report(i,J) = MIN(vel_report(i,J), abs(v(i,J,k))) - endif - enddo ; enddo + do_any_write =.false. + trunc_any = .false. + + + do J=Jsq,Jeq ; do i=is,ie + dowrite(i,J) = .false. + vel_report(i,J) = 3.0e8 * US%m_s_to_L_T + enddo ; enddo + + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + if (abs(v(i,J,k)) < CS%vel_underflow) v(i,J,k) = 0.0 + if (v(i,J,k) < 0.0) then + CFL = (-v(i,J,k) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j+1)) else - do i=is,ie ; vel_report(i,J) = maxvel ; enddo - do k=1,nz ; do i=is,ie - if (abs(v(i,J,k)) < CS%vel_underflow) then ; v(i,J,k) = 0.0 - elseif (abs(v(i,J,k)) > maxvel) then - dowrite(i,J) = .true. ; trunc_any = .true. - endif - enddo ; enddo + CFL = (v(i,J,k) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j)) + endif + if (CFL > CS%CFL_trunc) trunc_any = .true. + if (CFL > CS%CFL_report) then + dowrite(i,J) = .true. + do_any_write = .true. + vel_report(i,J) = min(vel_report(i,J), abs(v(i,J,k))) endif + enddo ; enddo ; enddo - do i=is,ie ; if (dowrite(i,J)) then - v_old(i,J,:) = v(i,J,:) - endif ; enddo - - if (trunc_any) then ; if (CS%CFL_based_trunc) then - do k=1,nz ; do i=is,ie - if ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j+1) < -CS%CFL_trunc) then - v(i,J,k) = (-0.9*CS%CFL_trunc) * (G%areaT(i,j+1) / (dt * G%dx_Cv(i,J))) - if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1 - elseif ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j) > CS%CFL_trunc) then - v(i,J,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dx_Cv(i,J))) - if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1 - endif - enddo ; enddo - else - do k=1,nz ; do i=is,ie ; if (abs(v(i,J,k)) > maxvel) then - v(i,J,k) = SIGN(truncvel,v(i,J,k)) - if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1 - endif ; enddo ; enddo - endif ; endif - enddo ! J-loop - else ! Do not report accelerations leading to large velocities. - if (CS%CFL_based_trunc) then - !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie ; if (dowrite(i,J)) then + v_old(i,J,:) = v(i,J,:) + endif ; enddo ; enddo + + if (trunc_any) then do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - if (abs(v(i,J,k)) < CS%vel_underflow) then ; v(i,J,k) = 0.0 - elseif ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j+1) < -CS%CFL_trunc) then + if ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j+1) < -CS%CFL_trunc) then v(i,J,k) = (-0.9*CS%CFL_trunc) * (G%areaT(i,j+1) / (dt * G%dx_Cv(i,J))) - if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1 + if (((i >= G%isc) .and. (i <= G%iec) .and. (J >= G%jsc) .and. (J <= G%jec)) .and. & + (CS%h_v(i,J,k) > H_report)) CS%ntrunc = CS%ntrunc + 1 elseif ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j) > CS%CFL_trunc) then v(i,J,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dx_Cv(i,J))) - if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1 - endif - enddo ; enddo ; enddo - else - !$OMP parallel do default(shared) - do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - if (abs(v(i,J,k)) < CS%vel_underflow) then ; v(i,J,k) = 0.0 - elseif (abs(v(i,J,k)) > maxvel) then - v(i,J,k) = SIGN(truncvel, v(i,J,k)) - if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1 + if (((i >= G%isc) .and. (i <= G%iec) .and. (J >= G%jsc) .and. (J <= G%jec)) .and. & + (CS%h_v(i,J,k) > H_report)) CS%ntrunc = CS%ntrunc + 1 endif enddo ; enddo ; enddo endif - endif - if (len_trim(CS%v_trunc_file) > 0) then - do J=Jsq,Jeq ; do i=is,ie ; if (dowrite(i,J)) then -! Here the diagnostic reporting subroutines are called if -! unphysically large values were found. - call write_v_accel(i, J, v_old, h, ADp, CDp, dt, G, GV, US, CS%PointAccel_CSp, & - vel_report(i,J), forces%tauy(i,J), a=CS%a_v, hv=CS%h_v) - endif ; enddo ; enddo + if (do_any_write) then + do J=Jsq,Jeq ; do i=is,ie ; if (dowrite(i,J)) then + ! Call a diagnostic reporting subroutines are called if unphysically large values are found. + call write_v_accel(i, J, v_old, h, ADp, CDp, dt, G, GV, US, CS%PointAccel_CSp, & + vel_report(i,J), forces%tauy(i,J), a=CS%a_v, hv=CS%h_v) + endif ; enddo ; enddo + endif + else ! Do not report accelerations leading to large velocities. + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + if (abs(v(i,J,k)) < CS%vel_underflow) then ; v(i,J,k) = 0.0 + elseif ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j+1) < -CS%CFL_trunc) then + v(i,J,k) = (-0.9*CS%CFL_trunc) * (G%areaT(i,j+1) / (dt * G%dx_Cv(i,J))) + if (((i >= G%isc) .and. (i <= G%iec) .and. (J >= G%jsc) .and. (J <= G%jec)) .and. & + (CS%h_v(i,J,k) > H_report)) CS%ntrunc = CS%ntrunc + 1 + elseif ((v(i,J,k) * (dt * G%dx_Cv(i,J))) * G%IareaT(i,j) > CS%CFL_trunc) then + v(i,J,k) = (0.9*CS%CFL_trunc) * (G%areaT(i,j) / (dt * G%dx_Cv(i,J))) + if (((i >= G%isc) .and. (i <= G%iec) .and. (J >= G%jsc) .and. (J <= G%jec)) .and. & + (CS%h_v(i,J,k) > H_report)) CS%ntrunc = CS%ntrunc + 1 + endif + enddo ; enddo ; enddo endif end subroutine vertvisc_limit_vel + !> Initialize the vertical friction module subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & - ntrunc, CS) + ntrunc, CS, fpmix) type(ocean_internal_state), & target, intent(in) :: MIS !< The "MOM Internal State", a set of pointers !! to the fields and accelerations that make @@ -1623,18 +2725,21 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & type(directories), intent(in) :: dirs !< Relevant directory paths integer, target, intent(inout) :: ntrunc !< Number of velocity truncations type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure + logical, optional, intent(in) :: fpmix !< Nonlocal momentum mixing ! Local variables - real :: hmix_str_dflt - real :: Kv_dflt ! A default viscosity [m2 s-1]. - real :: Hmix_m ! A boundary layer thickness [m]. - logical :: default_2018_answers + real :: Kv_BBL ! A viscosity in the bottom boundary layer with a simple scheme [H Z T-1 ~> m2 s-1 or Pa s] + real :: Kv_back_z ! A background kinematic viscosity [Z2 T-1 ~> m2 s-1] + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz -! This include declares and sets the variable "version". -#include "version_variable.h" + logical :: lfpmix + character(len=200) :: kappa_gl90_file, inputdir, kdgl90_varname + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_vert_friction" ! This module's name. character(len=40) :: thickness_units + real :: Kv_mks ! KVML in MKS [m2 s-1] if (associated(CS)) then call MOM_error(WARNING, "vertvisc_init called with an associated "// & @@ -1645,52 +2750,71 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & CS%initialized = .true. - if (GV%Boussinesq) then; thickness_units = "m" - else; thickness_units = "kg m-2"; endif + if (GV%Boussinesq) then ; thickness_units = "m" + else ; thickness_units = "kg m-2" ; endif isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB CS%diag => diag ; CS%ntrunc => ntrunc ; ntrunc = 0 + lfpmix = .false. + if (present(fpmix)) lfpmix = fpmix + ! Default, read and log parameters call log_version(param_file, mdl, version, "", log_to_all=.true., debugging=.true.) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) - call get_param(param_file, mdl, "VERT_FRICTION_2018_ANSWERS", CS%answers_2018, & - "If true, use the order of arithmetic and expressions that recover the answers "//& - "from the end of 2018. Otherwise, use expressions that do not use an arbitrary "//& - "hard-coded maximum viscous coupling coefficient between layers.", & - default=default_2018_answers) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "VERT_FRICTION_ANSWER_DATE", CS%answer_date, & + "The vintage of the order of arithmetic and expressions in the viscous "//& + "calculations. Values below 20190101 recover the answers from the end of 2018, "//& + "while higher values use expressions that do not use an arbitrary hard-coded "//& + "maximum viscous coupling coefficient between layers. Values below 20230601 "//& + "recover a form of the viscosity within the mixed layer that breaks up the "//& + "magnitude of the wind stress in some non-Boussinesq cases.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) + call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & "If true, the bottom stress is calculated with a drag "//& "law of the form c_drag*|u|*u. The velocity magnitude "//& "may be an assumed value or it may be based on the "//& "actual velocity in the bottommost HBBL, depending on "//& "LINEAR_DRAG.", default=.true.) - call get_param(param_file, mdl, "CHANNEL_DRAG", CS%Channel_drag, & - "If true, the bottom drag is exerted directly on each "//& - "layer proportional to the fraction of the bottom it "//& - "overlies.", default=.false.) call get_param(param_file, mdl, "DIRECT_STRESS", CS%direct_stress, & - "If true, the wind stress is distributed over the "//& - "topmost HMIX_STRESS of fluid (like in HYCOM), and KVML "//& - "may be set to a very small value.", default=.false.) + "If true, the wind stress is distributed over the topmost HMIX_STRESS of fluid "//& + "(like in HYCOM), and an added mixed layer viscosity or a physically based "//& + "boundary layer turbulence parameterization is not needed for stability.", & + default=.false.) call get_param(param_file, mdl, "DYNAMIC_VISCOUS_ML", CS%dynamic_viscous_ML, & "If true, use a bulk Richardson number criterion to "//& "determine the mixed layer thickness for viscosity.", & default=.false.) + call get_param(param_file, mdl, "FIXED_DEPTH_LOTW_ML", CS%fixed_LOTW_ML, & + "If true, use a Law-of-the-wall prescription for the mixed layer viscosity "//& + "within a boundary layer that is the lesser of HMIX_FIXED and the total "//& + "depth of the ocean in a column.", default=.false.) + call get_param(param_file, mdl, "LOTW_VISCOUS_ML_FLOOR", CS%apply_LOTW_floor, & + "If true, use a Law-of-the-wall prescription to set a lower bound on the "//& + "viscous coupling between layers within the surface boundary layer, based "//& + "the distance of interfaces from the surface. This only acts when there "//& + "are large changes in the thicknesses of successive layers or when the "//& + "viscosity is set externally and the wind stress has subsequently increased.", & + default=.false.) + call get_param(param_file, mdl, 'VON_KARMAN_CONST', CS%vonKar, & + 'The value the von Karman constant as used for mixed layer viscosity.', & + units='nondim', default=0.41) call get_param(param_file, mdl, "U_TRUNC_FILE", CS%u_trunc_file, & "The absolute path to a file into which the accelerations "//& "leading to zonal velocity truncations are written. "//& - "Undefine this for efficiency if this diagnostic is not "//& - "needed.", default=" ", debuggingParam=.true.) + "Undefine this for efficiency if this diagnostic is not needed.", & + default=" ", debuggingParam=.true.) call get_param(param_file, mdl, "V_TRUNC_FILE", CS%v_trunc_file, & "The absolute path to a file into which the accelerations "//& "leading to meridional velocity truncations are written. "//& - "Undefine this for efficiency if this diagnostic is not "//& - "needed.", default=" ", debuggingParam=.true.) + "Undefine this for efficiency if this diagnostic is not needed.", & + default=" ", debuggingParam=.true.) call get_param(param_file, mdl, "HARMONIC_VISC", CS%harmonic_visc, & "If true, use the harmonic mean thicknesses for "//& "calculating the vertical viscosity.", default=.false.) @@ -1702,52 +2826,143 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & default=0.0, units="nondim") call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) - if (GV%nkml < 1) & + if (GV%nkml < 1) then call get_param(param_file, mdl, "HMIX_FIXED", CS%Hmix, & - "The prescribed depth over which the near-surface "//& - "viscosity and diffusivity are elevated when the bulk "//& - "mixed layer is not used.", units="m", scale=GV%m_to_H, & - unscaled=Hmix_m, fail_if_missing=.true.) + "The prescribed depth over which the near-surface viscosity and "//& + "diffusivity are elevated when the bulk mixed layer is not used.", & + units="m", scale=US%m_to_Z, fail_if_missing=.true.) + endif if (CS%direct_stress) then if (GV%nkml < 1) then call get_param(param_file, mdl, "HMIX_STRESS", CS%Hmix_stress, & - "The depth over which the wind stress is applied if "//& - "DIRECT_STRESS is true.", units="m", default=Hmix_m, scale=GV%m_to_H) + "The depth over which the wind stress is applied if DIRECT_STRESS is true.", & + units="m", default=US%Z_to_m*CS%Hmix, scale=GV%m_to_H) else call get_param(param_file, mdl, "HMIX_STRESS", CS%Hmix_stress, & - "The depth over which the wind stress is applied if "//& - "DIRECT_STRESS is true.", units="m", fail_if_missing=.true., scale=GV%m_to_H) + "The depth over which the wind stress is applied if DIRECT_STRESS is true.", & + units="m", fail_if_missing=.true., scale=GV%m_to_H) endif if (CS%Hmix_stress <= 0.0) call MOM_error(FATAL, "vertvisc_init: " // & "HMIX_STRESS must be set to a positive value if DIRECT_STRESS is true.") endif - call get_param(param_file, mdl, "KV", CS%Kv, & + call get_param(param_file, mdl, "KV", Kv_back_z, & "The background kinematic viscosity in the interior. "//& "The molecular value, ~1e-6 m2 s-1, may be used.", & - units="m2 s-1", fail_if_missing=.true., scale=US%m2_s_to_Z2_T, unscaled=Kv_dflt) - - if (GV%nkml < 1) call get_param(param_file, mdl, "KVML", CS%Kvml, & - "The kinematic viscosity in the mixed layer. A typical "//& - "value is ~1e-2 m2 s-1. KVML is not used if "//& - "BULKMIXEDLAYER is true. The default is set by KV.", & - units="m2 s-1", default=Kv_dflt, scale=US%m2_s_to_Z2_T) - if (.not.CS%bottomdraglaw) call get_param(param_file, mdl, "KVBBL", CS%Kvbbl, & - "The kinematic viscosity in the benthic boundary layer. "//& - "A typical value is ~1e-2 m2 s-1. KVBBL is not used if "//& - "BOTTOMDRAGLAW is true. The default is set by KV.", & - units="m2 s-1", default=Kv_dflt, scale=US%m2_s_to_Z2_T) + units="m2 s-1", fail_if_missing=.true., scale=US%m2_s_to_Z2_T) + ! Convert input kinematic viscosity to dynamic viscosity when non-Boussinesq. + CS%Kv = (US%Z2_T_to_m2_s*GV%m2_s_to_HZ_T) * Kv_back_z + + call get_param(param_file, mdl, "USE_GL90_IN_SSW", CS%use_GL90_in_SSW, & + "If true, use simpler method to calculate 1/N^2 in GL90 vertical "// & + "viscosity coefficient. This method is valid in stacked shallow water mode.", & + default=.false.) + call get_param(param_file, mdl, "KD_GL90", CS%kappa_gl90, & + "The scalar diffusivity used in GL90 vertical viscosity scheme.", & + units="m2 s-1", default=0.0, scale=US%m_to_L*US%Z_to_L*GV%m_to_H*US%T_to_s, & + do_not_log=.not.CS%use_GL90_in_SSW) + call get_param(param_file, mdl, "READ_KD_GL90", CS%read_kappa_gl90, & + "If true, read a file (given by KD_GL90_FILE) containing the "//& + "spatially varying diffusivity KD_GL90 used in the GL90 scheme.", default=.false., & + do_not_log=.not.CS%use_GL90_in_SSW) + if (CS%read_kappa_gl90) then + if (CS%kappa_gl90 > 0) then + call MOM_error(FATAL, "MOM_vert_friction.F90, vertvisc_init: KD_GL90 > 0 "// & + "is not compatible with READ_KD_GL90 = .TRUE. ") + endif + call get_param(param_file, mdl, "INPUTDIR", inputdir, & + "The directory in which all input files are found.", & + default=".", do_not_log=.true.) + inputdir = slasher(inputdir) + call get_param(param_file, mdl, "KD_GL90_FILE", kappa_gl90_file, & + "The file containing the spatially varying diffusivity used in the "// & + "GL90 scheme.", default="kd_gl90.nc", do_not_log=.not.CS%use_GL90_in_SSW) + call get_param(param_file, mdl, "KD_GL90_VARIABLE", kdgl90_varname, & + "The name of the GL90 diffusivity variable to read "//& + "from KD_GL90_FILE.", default="kd_gl90", do_not_log=.not.CS%use_GL90_in_SSW) + kappa_gl90_file = trim(inputdir) // trim(kappa_gl90_file) + + allocate(CS%kappa_gl90_2d(G%isd:G%ied, G%jsd:G%jed), source=0.0) + call MOM_read_data(kappa_gl90_file, kdgl90_varname, CS%kappa_gl90_2d(:,:), G%domain, & + scale=US%m_to_L*US%Z_to_L*GV%m_to_H*US%T_to_s) + call pass_var(CS%kappa_gl90_2d, G%domain) + endif + call get_param(param_file, mdl, "USE_GL90_N2", CS%use_GL90_N2, & + "If true, use GL90 vertical viscosity coefficient that is depth-independent; "// & + "this corresponds to a kappa_GM that scales as N^2 with depth.", & + default=.false., do_not_log=.not.CS%use_GL90_in_SSW) + if (CS%use_GL90_N2) then + if (.not. CS%use_GL90_in_SSW) call MOM_error(FATAL, & + "MOM_vert_friction.F90, vertvisc_init: "//& + "When USE_GL90_N2=True, USE_GL90_in_SSW must also be True.") + if (CS%kappa_gl90 > 0) then + call MOM_error(FATAL, "MOM_vert_friction.F90, vertvisc_init: KD_GL90 > 0 "// & + "is not compatible with USE_GL90_N2 = .TRUE. ") + endif + if (CS%read_kappa_gl90) call MOM_error(FATAL, & + "MOM_vert_friction.F90, vertvisc_init: "//& + "READ_KD_GL90 = .TRUE. is not compatible with USE_GL90_N2 = .TRUE.") + call get_param(param_file, mdl, "alpha_GL90", CS%alpha_gl90, & + "Coefficient used to compute a depth-independent GL90 vertical "//& + "viscosity via Kv_GL90 = alpha_GL90 * f2. Is only used "// & + "if USE_GL90_N2 is true. Note that the implied Kv_GL90 "// & + "corresponds to a KD_GL90 that scales as N^2 with depth.", & + units="m2 s", default=0.0, scale=GV%m_to_H*US%m_to_Z*US%s_to_T, & + do_not_log=.not.CS%use_GL90_in_SSW) + endif + call get_param(param_file, mdl, "HBBL_GL90", CS%Hbbl_gl90, & + "The thickness of the GL90 bottom boundary layer, "//& + "which defines the range over which the GL90 coupling "//& + "coefficient is zeroed out, in order to avoid fluxing "//& + "momentum into vanished layers over steep topography.", & + units="m", default=5.0, scale=US%m_to_Z, do_not_log=.not.CS%use_GL90_in_SSW) + + CS%Kvml_invZ2 = 0.0 + if (GV%nkml < 1) then + call get_param(param_file, mdl, "KVML", Kv_mks, & + "The scale for an extra kinematic viscosity in the mixed layer", & + units="m2 s-1", default=-1.0, do_not_log=.true.) + if (Kv_mks >= 0.0) then + call MOM_error(WARNING, "KVML is a deprecated parameter. Use KV_ML_INVZ2 instead.") + else + Kv_mks = 0.0 + endif + call get_param(param_file, mdl, "KV_ML_INVZ2", CS%Kvml_invZ2, & + "An extra kinematic viscosity in a mixed layer of thickness HMIX_FIXED, "//& + "with the actual viscosity scaling as 1/(z*HMIX_FIXED)^2, where z is the "//& + "distance from the surface, to allow for finite wind stresses to be "//& + "transmitted through infinitesimally thin surface layers. This is an "//& + "older option for numerical convenience without a strong physical basis, "//& + "and its use is now discouraged.", & + units="m2 s-1", default=Kv_mks, scale=GV%m2_s_to_HZ_T) + endif + + if (.not.CS%bottomdraglaw) then + call get_param(param_file, mdl, "KV_EXTRA_BBL", CS%Kv_extra_bbl, & + "An extra kinematic viscosity in the benthic boundary layer. "//& + "KV_EXTRA_BBL is not used if BOTTOMDRAGLAW is true.", & + units="m2 s-1", default=0.0, scale=GV%m2_s_to_HZ_T, do_not_log=.true.) + if (CS%Kv_extra_bbl == 0.0) then + call get_param(param_file, mdl, "KVBBL", Kv_BBL, & + "An extra kinematic viscosity in the benthic boundary layer. "//& + "KV_EXTRA_BBL is not used if BOTTOMDRAGLAW is true.", & + units="m2 s-1", default=US%Z2_T_to_m2_s*Kv_back_z, scale=GV%m2_s_to_HZ_T, & + do_not_log=.true.) + if (abs(Kv_BBL - CS%Kv) > 1.0e-15*abs(CS%Kv)) then + call MOM_error(WARNING, "KVBBL is a deprecated parameter. Use KV_EXTRA_BBL instead.") + CS%Kv_extra_bbl = Kv_BBL - CS%Kv + endif + endif + call log_param(param_file, mdl, "KV_EXTRA_BBL", CS%Kv_extra_bbl, & + "An extra kinematic viscosity in the benthic boundary layer. "//& + "KV_EXTRA_BBL is not used if BOTTOMDRAGLAW is true.", & + units="m2 s-1", default=0.0, unscale=GV%HZ_T_to_m2_s) + endif call get_param(param_file, mdl, "HBBL", CS%Hbbl, & - "The thickness of a bottom boundary layer with a "//& - "viscosity of KVBBL if BOTTOMDRAGLAW is not defined, or "//& - "the thickness over which near-bottom velocities are "//& - "averaged for the drag law if BOTTOMDRAGLAW is defined "//& - "but LINEAR_DRAG is not.", units="m", fail_if_missing=.true., scale=GV%m_to_H) - call get_param(param_file, mdl, "MAXVEL", CS%maxvel, & - "The maximum velocity allowed before the velocity "//& - "components are truncated.", units="m s-1", default=3.0e8, scale=US%m_s_to_L_T) - call get_param(param_file, mdl, "CFL_BASED_TRUNCATIONS", CS%CFL_based_trunc, & - "If true, base truncations on the CFL number, and not an "//& - "absolute speed.", default=.true.) + "The thickness of a bottom boundary layer with a viscosity increased by "//& + "KV_EXTRA_BBL if BOTTOMDRAGLAW is not defined, or the thickness over which "//& + "near-bottom velocities are averaged for the drag law if BOTTOMDRAGLAW is "//& + "defined but LINEAR_DRAG is not.", & + units="m", fail_if_missing=.true., scale=US%m_to_Z) call get_param(param_file, mdl, "CFL_TRUNCATE", CS%CFL_trunc, & "The value of the CFL number that will cause velocity "//& "components to be truncated; instability can occur past 0.5.", & @@ -1769,7 +2984,7 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & "Flag to use Stokes drift Mixing via the Lagrangian "//& " current (Eulerian plus Stokes drift). "//& " Still needs work and testing, so not recommended for use.",& - Default=.false.) + default=.false.) !BGR 04/04/2018{ ! StokesMixing is required for MOM6 for some Langmuir mixing parameterization. ! The code used here has not been developed for vanishing layers or in @@ -1791,24 +3006,38 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & "the age of the universe.", units="m s-1", default=0.0, scale=US%m_s_to_L_T) ALLOC_(CS%a_u(IsdB:IedB,jsd:jed,nz+1)) ; CS%a_u(:,:,:) = 0.0 + ALLOC_(CS%a_u_gl90(IsdB:IedB,jsd:jed,nz+1)) ; CS%a_u_gl90(:,:,:) = 0.0 ALLOC_(CS%h_u(IsdB:IedB,jsd:jed,nz)) ; CS%h_u(:,:,:) = 0.0 ALLOC_(CS%a_v(isd:ied,JsdB:JedB,nz+1)) ; CS%a_v(:,:,:) = 0.0 + ALLOC_(CS%a_v_gl90(isd:ied,JsdB:JedB,nz+1)) ; CS%a_v_gl90(:,:,:) = 0.0 ALLOC_(CS%h_v(isd:ied,JsdB:JedB,nz)) ; CS%h_v(:,:,:) = 0.0 CS%id_Kv_slow = register_diag_field('ocean_model', 'Kv_slow', diag%axesTi, Time, & - 'Slow varying vertical viscosity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Slow varying vertical viscosity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) CS%id_Kv_u = register_diag_field('ocean_model', 'Kv_u', diag%axesCuL, Time, & - 'Total vertical viscosity at u-points', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Total vertical viscosity at u-points', 'm2 s-1', conversion=GV%H_to_m**2*US%s_to_T) CS%id_Kv_v = register_diag_field('ocean_model', 'Kv_v', diag%axesCvL, Time, & - 'Total vertical viscosity at v-points', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Total vertical viscosity at v-points', 'm2 s-1', conversion=GV%H_to_m**2*US%s_to_T) + + CS%id_Kv_gl90_u = register_diag_field('ocean_model', 'Kv_gl90_u', diag%axesCuL, Time, & + 'GL90 vertical viscosity at u-points', 'm2 s-1', conversion=GV%H_to_m**2*US%s_to_T) + + CS%id_Kv_gl90_v = register_diag_field('ocean_model', 'Kv_gl90_v', diag%axesCvL, Time, & + 'GL90 vertical viscosity at v-points', 'm2 s-1', conversion=GV%H_to_m**2*US%s_to_T) CS%id_au_vv = register_diag_field('ocean_model', 'au_visc', diag%axesCui, Time, & - 'Zonal Viscous Vertical Coupling Coefficient', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + 'Zonal Viscous Vertical Coupling Coefficient', 'm s-1', conversion=GV%H_to_m*US%s_to_T) CS%id_av_vv = register_diag_field('ocean_model', 'av_visc', diag%axesCvi, Time, & - 'Meridional Viscous Vertical Coupling Coefficient', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + 'Meridional Viscous Vertical Coupling Coefficient', 'm s-1', conversion=GV%H_to_m*US%s_to_T) + + CS%id_au_gl90_vv = register_diag_field('ocean_model', 'au_gl90_visc', diag%axesCui, Time, & + 'Zonal Viscous Vertical GL90 Coupling Coefficient', 'm s-1', conversion=GV%H_to_m*US%s_to_T) + + CS%id_av_gl90_vv = register_diag_field('ocean_model', 'av_gl90_visc', diag%axesCvi, Time, & + 'Meridional Viscous Vertical GL90 Coupling Coefficient', 'm s-1', conversion=GV%H_to_m*US%s_to_T) CS%id_h_u = register_diag_field('ocean_model', 'Hu_visc', diag%axesCuL, Time, & 'Thickness at Zonal Velocity Points for Viscosity', & @@ -1822,11 +3051,35 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & CS%id_hML_u = register_diag_field('ocean_model', 'HMLu_visc', diag%axesCu1, Time, & 'Mixed Layer Thickness at Zonal Velocity Points for Viscosity', & - thickness_units, conversion=GV%H_to_MKS) + thickness_units, conversion=US%Z_to_m) CS%id_hML_v = register_diag_field('ocean_model', 'HMLv_visc', diag%axesCv1, Time, & 'Mixed Layer Thickness at Meridional Velocity Points for Viscosity', & - thickness_units, conversion=GV%H_to_MKS) + thickness_units, conversion=US%Z_to_m) + + if (lfpmix) then + CS%id_uE_h = register_diag_field('ocean_model', 'uE_h' , CS%diag%axesTL, & + Time, 'x-zonal Eulerian' , 'm s-1', conversion=US%L_T_to_m_s) + CS%id_vE_h = register_diag_field('ocean_model', 'vE_h' , CS%diag%axesTL, & + Time, 'y-merid Eulerian' , 'm s-1', conversion=US%L_T_to_m_s) + CS%id_uInc_h = register_diag_field('ocean_model','uInc_h',CS%diag%axesTL, & + Time, 'x-zonal Eulerian' , 'm s-1', conversion=US%L_T_to_m_s) + CS%id_vInc_h = register_diag_field('ocean_model','vInc_h',CS%diag%axesTL, & + Time, 'x-zonal Eulerian' , 'm s-1', conversion=US%L_T_to_m_s) + CS%id_uStk = register_diag_field('ocean_model', 'uStk' , CS%diag%axesTL, & + Time, 'x-FP du increment' , 'm s-1', conversion=US%L_T_to_m_s) + CS%id_vStk = register_diag_field('ocean_model', 'vStk' , CS%diag%axesTL, & + Time, 'y-FP dv increment' , 'm s-1', conversion=US%L_T_to_m_s) + + CS%id_FPtau2s = register_diag_field('ocean_model','Omega_tau2s',CS%diag%axesTi, & + Time, 'Stress direction from shear','radians') + CS%id_FPtau2w = register_diag_field('ocean_model','Omega_tau2w',CS%diag%axesTi, & + Time, 'Stress direction from wind','radians') + CS%id_uStk0 = register_diag_field('ocean_model', 'uStk0' , diag%axesT1, & + Time, 'Zonal Surface Stokes', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_vStk0 = register_diag_field('ocean_model', 'vStk0' , diag%axesT1, & + Time, 'Merid Surface Stokes', 'm s-1', conversion=US%L_T_to_m_s) + endif CS%id_du_dt_visc = register_diag_field('ocean_model', 'du_dt_visc', diag%axesCuL, Time, & 'Zonal Acceleration from Vertical Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) @@ -1834,7 +3087,21 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & CS%id_dv_dt_visc = register_diag_field('ocean_model', 'dv_dt_visc', diag%axesCvL, Time, & 'Meridional Acceleration from Vertical Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) if (CS%id_dv_dt_visc > 0) call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) - + CS%id_GLwork = register_diag_field('ocean_model', 'GLwork', diag%axesTL, Time, & + 'Sign-definite Kinetic Energy Source from GL90 Vertical Viscosity', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_du_dt_visc_gl90 = register_diag_field('ocean_model', 'du_dt_visc_gl90', diag%axesCuL, Time, & + 'Zonal Acceleration from GL90 Vertical Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) + if ((CS%id_du_dt_visc_gl90 > 0) .or. (CS%id_GLwork > 0)) then + call safe_alloc_ptr(ADp%du_dt_visc_gl90,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) + endif + CS%id_dv_dt_visc_gl90 = register_diag_field('ocean_model', 'dv_dt_visc_gl90', diag%axesCvL, Time, & + 'Meridional Acceleration from GL90 Vertical Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) + if ((CS%id_dv_dt_visc_gl90 > 0) .or. (CS%id_GLwork > 0)) then + call safe_alloc_ptr(ADp%dv_dt_visc_gl90,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) + endif CS%id_du_dt_str = register_diag_field('ocean_model', 'du_dt_str', diag%axesCuL, Time, & 'Zonal Acceleration from Surface Wind Stresses', 'm s-2', conversion=US%L_T2_to_m_s2) if (CS%id_du_dt_str > 0) call safe_alloc_ptr(ADp%du_dt_str,IsdB,IedB,jsd,jed,nz) @@ -1960,7 +3227,7 @@ subroutine updateCFLtruncationValue(Time, CS, US, activate) endif endif if (.not.CS%CFLrampingIsActivated) return - deltaTime = max( 0., US%s_to_T*time_type_to_real( Time - CS%rampStartTime ) ) + deltaTime = max(0., time_minus_signed(Time, CS%rampStartTime, scale=US%s_to_T)) if (deltaTime >= CS%truncRampTime) then CS%CFL_trunc = CS%CFL_truncE CS%truncRampTime = 0. ! This turns off ramping after this call @@ -1972,8 +3239,7 @@ subroutine updateCFLtruncationValue(Time, CS, US, activate) CS%CFL_trunc = CS%CFL_truncS + wghtA * ( CS%CFL_truncE - CS%CFL_truncS ) endif write(msg(1:12),'(es12.3)') CS%CFL_trunc - call MOM_error(NOTE, "MOM_vert_friction: updateCFLtruncationValue set CFL"// & - " limit to "//trim(msg)) + call MOM_error(NOTE, "MOM_vert_friction: updateCFLtruncationValue set CFL limit to "//trim(msg)) end subroutine updateCFLtruncationValue !> Clean up and deallocate the vertical friction module @@ -1988,6 +3254,7 @@ subroutine vertvisc_end(CS) DEALLOC_(CS%a_v) ; DEALLOC_(CS%h_v) if (associated(CS%a1_shelf_u)) deallocate(CS%a1_shelf_u) if (associated(CS%a1_shelf_v)) deallocate(CS%a1_shelf_v) + if (allocated(CS%kappa_gl90_2d)) deallocate(CS%kappa_gl90_2d) end subroutine vertvisc_end !> \namespace mom_vert_friction @@ -2013,9 +3280,9 @@ end subroutine vertvisc_end !! side. Both of these thickness estimates are second order !! accurate. Above this the arithmetic mean thickness is used. !! -!! In addition, vertvisc truncates any velocity component that -!! exceeds maxvel to truncvel. This basically keeps instabilities -!! spatially localized. The number of times the velocity is +!! In addition, vertvisc truncates any velocity component that exceeds a +!! maximum CFL number to a fraction of this value. This basically keeps +!! instabilities spatially localized. The number of times the velocity is !! truncated is reported each time the energies are saved, and if !! exceeds CS%Maxtrunc the model will stop itself and change the time !! to a large value. This has proven very useful in (1) diagnosing diff --git a/src/parameterizations/vertical/_CVMix_KPP.dox b/src/parameterizations/vertical/_CVMix_KPP.dox index 7a65b6a6a3..72c166c284 100644 --- a/src/parameterizations/vertical/_CVMix_KPP.dox +++ b/src/parameterizations/vertical/_CVMix_KPP.dox @@ -7,7 +7,7 @@ The formulation and implementation of KPP is described in great detail in the [CVMix manual](https://github.com/CVMix/CVMix-description/raw/master/cvmix.pdf) (written by our own Steve Griffies). - \section section_KPP_nutshell KPP in a nutshell + \section section_KPP_nutshell KPP in a nutshell Large et al., \cite large1994, decompose the parameterized boundary layer turbulent flux of a scalar, \f$ s \f$, as \f[ \overline{w^\prime s^\prime} = -K \partial_z s + K \gamma_s(\sigma), \f] diff --git a/src/parameterizations/vertical/_V_diffusivity.dox b/src/parameterizations/vertical/_V_diffusivity.dox index 8c4c8ce7aa..df1ce50e27 100644 --- a/src/parameterizations/vertical/_V_diffusivity.dox +++ b/src/parameterizations/vertical/_V_diffusivity.dox @@ -253,32 +253,12 @@ in \cite harrison2008, but that isn't what is in the MOM6 code. Instead, the sur value is propagated down, with the assumption that the tidal mixing parameterization will provide the deep mixing: \ref section_Internal_Tidal_Mixing. -There is also a "new" Henyey version, taking into account the effect of stratification on -TKE dissipation, - -\todo Harrison (personal communication) recommends that this option be made obsolete and -eventually removed. - -\f[ - \epsilon = \epsilon_0 \frac{f}{f_0} \frac{\mbox{acosh} (N/f)}{\mbox{acosh} (N_0 / f_0)} -\f] - -where \f$N_0\f$ and \f$f_0\f$ are the reference buoyancy frequency and inertial frequencies, respectively -and \f$\epsilon_0\f$ is the reference dissipation at \f$(N_0, f_0)\f$. In the previous version, \f$N = -N_0\f$. Additionally, the relationship between diapycnal diffusivities and stratification is included: - -\f[ - \kappa = \frac{\epsilon}{N^2} -\f] -This approach assumes that work done against gravity is uniformly distributed throughout the water column. -The original version concentrates buoyancy work in regions of strong stratification. - \subsection subsection_danabasoglu_back Danabasoglu background mixing The shape of the \cite danabasoglu2012 background mixing has a uniform background value, with a dip at the equator and a bump at \f$\pm 30^{\circ}\f$ degrees latitude. The form is shown in this figure -\image html background_varying.png "Form of the vertically uniform background mixing in \cite danabasoglu2012. The values are symmetric about the equator." +\image html background_varying.png "Form of the vertically uniform background mixing in Danabasoglu [2012]. The values are symmetric about the equator." \imagelatex{background_varying.png,Form of the vertically uniform background mixing in \cite danabasoglu2012. The values are symmetric about the equator.,\includegraphics[width=\textwidth\,height=\textheight/2\,keepaspectratio=true]} Some parameters of this curve are set in the input file, some are hard-coded in calculate_bkgnd_mixing. diff --git a/src/parameterizations/vertical/_V_viscosity.dox b/src/parameterizations/vertical/_V_viscosity.dox index cc59e83457..e40123386f 100644 --- a/src/parameterizations/vertical/_V_viscosity.dox +++ b/src/parameterizations/vertical/_V_viscosity.dox @@ -1,4 +1,19 @@ -/*! \page Vertical_Viscosity Viscous Bottom Boundary Layer +/*! \page Vertical_Viscosity Vertical Viscosity + +The vertical viscosity is composed of several components. + +-# The vertical diffusivity computations for the background and shear +mixing all save contributions to the viscosity with an assumed turbulent +Prandtl number of 1.0, though this can be changed with the PRANDTL_BKGND and +PRANDTL_TURB parameters, respectively. +-# If the ePBL scheme is used, it contributes to the vertical viscosity +with a Prandtl number of PRANDTL_EPBL. +-# If the CVMix scheme is used, it contributes to the vertical viscosity +with a Prandtl number of PRANDTL_CONV. +-# If the tidal mixing scheme is used, it contributes to the vertical +viscosity with a Prandtl number of PRANDTL_TIDAL. + +\section set_viscous_BBL Viscous Bottom Boundary Layer A drag law is used, either linearized about an assumed bottom velocity or using the actual near-bottom velocities combined with an assumed unresolved velocity. The bottom @@ -6,8 +21,6 @@ boundary layer thickness is limited by a combination of stratification and rotat in the paper of \cite killworth1999. It is not necessary to calculate the thickness and viscosity every time step; instead previous values may be used. -\section set_viscous_BBL Viscous Bottom Boundary Layer - If set_visc_CS\%bottomdraglaw is True then a bottom boundary layer viscosity and thickness are calculated so that the bottom stress is \f[ @@ -31,7 +44,7 @@ thin upwind cells helps increase the effect of viscosity and inhibits flow out o thin cells. After diagnosing \f$|U_{bbl}|\f$ over a fixed depth an active viscous boundary layer -thickness is found using the ideas of Killworth and Edwards, 1999 (hereafter KW99). +thickness is found using the ideas of \cite killworth1999 (hereafter KW99). KW99 solve the equation \f[ \left( \frac{h_{bbl}}{h_f} \right)^2 + \frac{h_{bbl}}{h_N} = 1 @@ -56,9 +69,54 @@ If a Richardson number dependent mixing scheme is being used, as indicated by set_visc_CS\%rino_mix, then the boundary layer thickness is bounded to be no larger than a half of set_visc_CS\%hbbl . -\todo Channel drag needs to be explained - A BBL viscosity is calculated so that the no-slip boundary condition in the vertical -viscosity solver implies the stress \f$\mathbf{\tau}_b\f$. +viscosity solver implies the stress \f$\mathbf{\tau}_b\f$: + +\f[ + K_{bbl} = \frac{1}{2} h_{bbl} \sqrt{C_{drag}} \, u^\ast +\f] + +\section section_Channel_drag Channel Drag + +The channel drag is an extra Rayleigh drag applied to those layers +within the bottom boundary layer. It is called channel drag because it +accounts for curvature of the bottom, applying the drag proportionally +to how much of each cell is within the bottom boundary layer. +The bottom shape is approximated as locally parabolic. The +bottom drag is applied to each layer with a factor \f$R_k\f$, the sum +of which is 1 over all the layers. + +\image html channel_drag.png "Example of layers intersecting a sloping bottom, with the blue showing the fraction of the cell over which bottom drag is applied." +\imagelatex{channel_drag.png,Example of layers intersecting a sloping bottom\, with the blue showing the fraction of the cell over which bottom drag is applied.,\includegraphics[width=\textwidth\,height=\textheight/2\,keepaspectratio=true]} + +The velocity that is actually subject to the bottom drag may be +substantially lower than the mean layer velocity, especially if only +a small fraction of the layer's width is subject to the bottom drag. + +The code begins by finding the arithmetic mean of the water depths to +find the depth at the velocity points. It then uses these to construct +a parabolic bottom shape, valid for \f$I - \frac{1}{2}\f$ to \f$I + +\frac{1}{2}\f$. The parabola is: + +\f[ + D(x) = a x^2 + b x + D - \frac{a}{12} +\f] + +For sufficiently small curvature \f$a\f$, one can drop the quadratic +term and assume a linear function instead. We want a form that matches +the traditional bottom drag when the bottom is flat. + +We defined the open fraction of each cell as \f$l(k) \equiv L(k)/L_{Tot}\f$, +where terms of order \f$l^2\f$ will be dropped. + +Hallberg (personal communication) shows how they came up with the form used in the code, in which the +\f$R_k\f$ above are set to: + +\f[ + R_k = \gamma_k l_{k-1/2} \left[ \frac{12 c_{Smag} h_k}{12 c_{Smag} k_k + c_d \gamma_k (1 - \gamma_k) + (1 - \frac{3}{2} \gamma_k) l^2_{k-1/2} L_{Tot}} \right] +\f] +with the definition \f$\gamma_k \equiv (l_{k-1/2} - l_{k+1/2})/l_{k-1/2}\f$. This ensures that \f$\sum^N_{k=1} +\gamma_k l_{k-1/2} = 1\f$ since \f$l_{1/2} = 1\f$ and \f$l_{N+1/2} = 0\f$. */ diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index 2d18b7c907..7ef2dee58c 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> A tracer package that is used as a diagnostic in the DOME experiments module DOME_tracer -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux use MOM_diag_mediator, only : diag_ctrl use MOM_error_handler, only : MOM_error, FATAL, WARNING @@ -10,6 +12,7 @@ module DOME_tracer use MOM_forcing_type, only : forcing use MOM_hor_index, only : hor_index_type use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_tracer_type use MOM_open_boundary, only : OBC_segment_type @@ -19,7 +22,7 @@ module DOME_tracer use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface +use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -42,10 +45,18 @@ module DOME_tracer character(len=200) :: tracer_IC_file !< The full path to the IC file, or " " to initialize internally. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry - real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package, in g m-3? - real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out. + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package, perhaps in [g kg-1] + real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out, perhaps in [g kg-1] logical :: use_sponge !< If true, sponges may be applied somewhere in the domain. + real :: stripe_width !< The meridional width of the vertical stripes in the initial condition + !! for some of the DOME tracers, in [km] or [degrees_N] or [m]. + real :: stripe_s_lat !< The southern latitude of the first vertical stripe in the initial condition + !! for some of the DOME tracers, in [km] or [degrees_N] or [m]. + real :: sheet_spacing !< The vertical spacing between successive horizontal sheets of tracer in the initial + !! conditions for some of the DOME tracers [Z ~> m], and twice the thickness of + !! these horizontal tracer sheets + integer, dimension(NTR) :: ind_tr !< Indices returned by atmos_ocn_coupler_flux if it is used and the !! surface tracer concentrations are to be provided to the coupler. @@ -58,32 +69,32 @@ module DOME_tracer contains !> Register tracer fields and subroutines to be used with MOM. -function register_DOME_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(DOME_tracer_CS), pointer :: CS !< A pointer that is set to point to the +function register_DOME_tracer(G, GV, US, param_file, CS, tr_Reg, restart_CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(DOME_tracer_CS), pointer :: CS !< A pointer that is set to point to the !! control structure for this module type(tracer_registry_type), pointer :: tr_Reg !< A pointer to the tracer registry. - type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct -! Local variables + ! Local variables character(len=80) :: name, longname -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "DOME_tracer" ! This module's name. character(len=48) :: flux_units ! The units for tracer fluxes, usually ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. character(len=200) :: inputdir - real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to the tracer field + real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to one of the tracers, perhaps in [g kg-1] logical :: register_DOME_tracer integer :: isd, ied, jsd, jed, nz, m - isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke if (associated(CS)) then - call MOM_error(WARNING, "DOME_register_tracer called with an "// & - "associated control structure.") - return + call MOM_error(FATAL, "DOME_register_tracer called with an "// & + "associated control structure.") endif allocate(CS) @@ -100,6 +111,16 @@ function register_DOME_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) call log_param(param_file, mdl, "INPUTDIR/DOME_TRACER_IC_FILE", & CS%tracer_IC_file) endif + call get_param(param_file, mdl, "DOME_TRACER_STRIPE_WIDTH", CS%stripe_width, & + "The meridional width of the vertical stripes in the initial condition "//& + "for the DOME tracers.", units=G%y_ax_unit_short, default=50.0) + call get_param(param_file, mdl, "DOME_TRACER_STRIPE_LAT", CS%stripe_s_lat, & + "The southern latitude of the first vertical stripe in the initial condition "//& + "for the DOME tracers.", units=G%y_ax_unit_short, default=350.0) + call get_param(param_file, mdl, "DOME_TRACER_SHEET_SPACING", CS%sheet_spacing, & + "The vertical spacing between successive horizontal sheets of tracer in the initial "//& + "conditions for the DOME tracers, and twice the thickness of these tracer sheets.", & + units="m", default=600.0, scale=US%m_to_Z) call get_param(param_file, mdl, "SPONGE", CS%use_sponge, & "If true, sponges may be applied anywhere in the domain. "//& "The exact location and properties of those sponges are "//& @@ -108,8 +129,7 @@ function register_DOME_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) allocate(CS%tr(isd:ied,jsd:jed,nz,NTR), source=0.0) do m=1,NTR - if (m < 10) then ; write(name,'("tr_D",I1.1)') m - else ; write(name,'("tr_D",I2.2)') m ; endif + write(name,'("tr_D",I0)') m write(longname,'("Concentration of DOME Tracer ",I2.2)') m CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" @@ -119,7 +139,7 @@ function register_DOME_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! calls. Curses on the designers and implementers of Fortran90. tr_ptr => CS%tr(:,:,:,m) ! Register the tracer for horizontal advection, diffusion, and restarts. - call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & + call register_tracer(tr_ptr, tr_Reg, param_file, G%HI, GV, & name=name, longname=longname, units="kg kg-1", & registry_diags=.true., restart_CS=restart_CS, & flux_units=trim(flux_units), flux_scale=GV%H_to_MKS) @@ -138,7 +158,7 @@ end function register_DOME_tracer !> Initializes the NTR tracer fields in tr(:,:,:,:) and sets up the tracer output. subroutine initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & - sponge_CSp, param_file) + sponge_CSp, tv) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -152,37 +172,27 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & !! call to DOME_register_tracer. type(sponge_CS), pointer :: sponge_CSp !< A pointer to the control structure !! for the sponges, if they are in use. - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables -! Local variables - real, allocatable :: temp(:,:,:) - real, pointer, dimension(:,:,:) :: & - OBC_tr1_u => NULL(), & ! These arrays should be allocated and set to - OBC_tr1_v => NULL() ! specify the values of tracer 1 that should come - ! in through u- and v- points through the open - ! boundary conditions, in the same units as tr. + ! Local variables + real, allocatable :: temp(:,:,:) ! Target values for the tracers in the sponges, perhaps in [g kg-1] character(len=16) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for tracer fluxes, usually - ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. - real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to the tracer field - real :: PI ! 3.1415926... calculated as 4*atan(1) - real :: tr_y ! Initial zonally uniform tracer concentrations. - real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected [H ~> m or kg m-2]. + real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to one of the tracers, perhaps in [g kg-1] + real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] + real :: tr_y ! Initial zonally uniform tracer concentrations, perhaps in [g kg-1] + real :: dz_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m] real :: e(SZK_(GV)+1) ! Interface heights relative to the sea surface (negative down) [Z ~> m] real :: e_top ! Height of the top of the tracer band relative to the sea surface [Z ~> m] real :: e_bot ! Height of the bottom of the tracer band relative to the sea surface [Z ~> m] - real :: d_tr ! A change in tracer concentrations, in tracer units. + real :: d_tr ! A change in tracer concentrations, in tracer units, perhaps [g kg-1] integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m - integer :: IsdB, IedB, JsdB, JedB if (.not.associated(CS)) return 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 - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - h_neglect = GV%H_subroundoff + + dz_neglect = GV%dz_subroundoff CS%Time => day CS%diag => diag @@ -205,42 +215,46 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & enddo ! This sets a stripe of tracer across the basin. - do m=2,NTR ; do j=js,je ; do i=is,ie + do m=2,min(6,NTR) ; do j=js,je ; do i=is,ie tr_y = 0.0 - if ((m <= 6) .and. (G%geoLatT(i,j) > (300.0+50.0*real(m-1))) .and. & - (G%geoLatT(i,j) < (350.0+50.0*real(m-1)))) tr_y = 1.0 + if ((G%geoLatT(i,j) > (CS%stripe_s_lat + CS%stripe_width*real(m-2))) .and. & + (G%geoLatT(i,j) < (CS%stripe_s_lat + CS%stripe_width*real(m-1)))) & + tr_y = 1.0 do k=1,nz ! This adds the stripes of tracer to every layer. CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + tr_y enddo enddo ; enddo ; enddo - if (NTR > 7) then - do j=js,je ; do i=is,ie - e(1) = 0.0 - do k=1,nz - e(K+1) = e(K) - h(i,j,k)*GV%H_to_Z - do m=7,NTR - e_top = (-600.0*real(m-1) + 3000.0) * US%m_to_Z - e_bot = (-600.0*real(m-1) + 2700.0) * US%m_to_Z - if (e_top < e(K)) then - if (e_top < e(K+1)) then ; d_tr = 0.0 - elseif (e_bot < e(K+1)) then - d_tr = 1.0 * (e_top-e(K+1)) / ((h(i,j,k)+h_neglect)*GV%H_to_Z) - else ; d_tr = 1.0 * (e_top-e_bot) / ((h(i,j,k)+h_neglect)*GV%H_to_Z) - endif - elseif (e_bot < e(K)) then - if (e_bot < e(K+1)) then ; d_tr = 1.0 - else ; d_tr = 1.0 * (e(K)-e_bot) / ((h(i,j,k)+h_neglect)*GV%H_to_Z) + if (NTR >= 7) then + do j=js,je + call thickness_to_dz(h, tv, dz, j, G, GV) + do i=is,ie + e(1) = 0.0 + do k=1,nz + e(K+1) = e(K) - dz(i,k) + do m=7,NTR + e_top = -CS%sheet_spacing * (real(m-6)) + e_bot = -CS%sheet_spacing * (real(m-6) + 0.5) + if (e_top < e(K)) then + if (e_top < e(K+1)) then ; d_tr = 0.0 + elseif (e_bot < e(K+1)) then + d_tr = 1.0 * (e_top-e(K+1)) / (dz(i,k)+dz_neglect) + else ; d_tr = 1.0 * (e_top-e_bot) / (dz(i,k)+dz_neglect) + endif + elseif (e_bot < e(K)) then + if (e_bot < e(K+1)) then ; d_tr = 1.0 + else ; d_tr = 1.0 * (e(K)-e_bot) / (dz(i,k)+dz_neglect) + endif + else + d_tr = 0.0 endif - else - d_tr = 0.0 - endif - if (h(i,j,k) < 2.0*GV%Angstrom_H) d_tr=0.0 - CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + d_tr + if (dz(i,k) < 2.0*GV%Angstrom_Z) d_tr=0.0 + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + d_tr + enddo enddo enddo - enddo ; enddo + enddo endif endif @@ -266,8 +280,7 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & ! do m=1,NTR do m=1,1 - ! This is needed to force the compiler not to do a copy in the sponge - ! calls. Curses on the designers and implementers of Fortran90. + ! This pointer is needed to force the compiler not to do a copy in the sponge calls. tr_ptr => CS%tr(:,:,:,m) call set_up_sponge_field(temp, tr_ptr, G, GV, nz, sponge_CSp) enddo @@ -360,7 +373,7 @@ subroutine DOME_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif @@ -370,8 +383,6 @@ end subroutine DOME_tracer_surface_state subroutine DOME_tracer_end(CS) type(DOME_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to DOME_register_tracer. - integer :: m - if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) deallocate(CS) diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index 013b04a5b3..f1a158fb90 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -1,3 +1,7 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Routines used to set up and use a set of (one for now) !! dynamically passive tracers in the ISOMIP configuration. !! @@ -5,8 +9,6 @@ !! the sponge layer. module ISOMIP_tracer -! This file is part of MOM6. See LICENSE.md for the license. - ! Original sample tracer package by Robert Hallberg, 2002 ! Adapted to the ISOMIP test case by Gustavo Marques, May 2016 @@ -45,8 +47,8 @@ module ISOMIP_tracer character(len = 200) :: tracer_IC_file !< The full path to the IC file, or " " to initialize internally. type(time_type), pointer :: Time !< A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the MOM tracer registry - real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package, in g m-3? - real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out. + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package, in [conc] (g m-3)? + real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out [conc]. logical :: use_sponge !< If true, sponges may be applied somewhere in the domain. integer, dimension(NTR) :: ind_tr !< Indices returned by atmos_ocn_coupler_flux @@ -74,21 +76,20 @@ function register_ISOMIP_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct character(len=80) :: name, longname -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "ISOMIP_tracer" ! This module's name. character(len=200) :: inputdir character(len=48) :: flux_units ! The units for tracer fluxes, usually ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. - real, pointer :: tr_ptr(:,:,:) => NULL() + real, pointer :: tr_ptr(:,:,:) => NULL() ! The tracer concentration [conc] logical :: register_ISOMIP_tracer integer :: isd, ied, jsd, jed, nz, m isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke if (associated(CS)) then - call MOM_error(WARNING, "ISOMIP_register_tracer called with an "// & + call MOM_error(FATAL, "ISOMIP_register_tracer called with an "// & "associated control structure.") - return endif allocate(CS) @@ -113,8 +114,7 @@ function register_ISOMIP_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) allocate(CS%tr(isd:ied,jsd:jed,nz,NTR), source=0.0) do m=1,NTR - if (m < 10) then ; write(name,'("tr_D",I1.1)') m - else ; write(name,'("tr_D",I2.2)') m ; endif + write(name,'("tr_D",I0)') m write(longname,'("Concentration of ISOMIP Tracer ",I2.2)') m CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" @@ -163,18 +163,7 @@ subroutine initialize_ISOMIP_tracer(restart, day, G, GV, h, diag, OBC, CS, & !! the sponges, if they are in use. Otherwise this !! may be unassociated. - real, allocatable :: temp(:,:,:) - real, pointer, dimension(:,:,:) :: & - OBC_tr1_u => NULL(), & ! These arrays should be allocated and set to - OBC_tr1_v => NULL() ! specify the values of tracer 1 that should come - ! in through u- and v- points through the open - ! boundary conditions, in the same units as tr. character(len=16) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for tracer fluxes, usually - ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. - real, pointer :: tr_ptr(:,:,:) => NULL() real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m @@ -276,7 +265,6 @@ subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, G real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] real :: melt(SZI_(G),SZJ_(G)) ! melt water (positive for melting, negative for freezing) [R Z T-1 ~> kg m-2 s-1] real :: mmax ! The global maximum melting rate [R Z T-1 ~> kg m-2 s-1] - character(len=256) :: mesg ! The text of an error message integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -344,7 +332,7 @@ subroutine ISOMIP_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif @@ -354,7 +342,6 @@ end subroutine ISOMIP_tracer_surface_state subroutine ISOMIP_tracer_end(CS) type(ISOMIP_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to ISOMIP_register_tracer. - integer :: m if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) diff --git a/src/tracer/MARBL_forcing_mod.F90 b/src/tracer/MARBL_forcing_mod.F90 new file mode 100644 index 0000000000..e8c64e53ab --- /dev/null +++ b/src/tracer/MARBL_forcing_mod.F90 @@ -0,0 +1,386 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> This module provides a common datatype to provide forcing for MARBL tracers +!! regardless of driver +module MARBL_forcing_mod + +!! This module exists to house code used by multiple drivers in config_src/ +!! for passing forcing fields to MARBL +!! (This comment can go in the wiki on the NCAR fork?) + +use MOM_diag_mediator, only : safe_alloc_ptr, diag_ctrl, register_diag_field, post_data +use MOM_time_manager, only : time_type +use MOM_error_handler, only : MOM_error, WARNING, FATAL +use MOM_file_parser, only : get_param, log_param, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_interpolate, only : external_field, init_external_field, time_interp_external +use MOM_io, only : slasher +use marbl_constants_mod, only : molw_Fe +use MOM_forcing_type, only : forcing + +implicit none ; private + +#include + +public :: MARBL_forcing_init +public :: convert_driver_fields_to_forcings + +!> Data type used to store diagnostic index returned from register_diag_field() +!! For the forcing fields that can be written via post_data() +type, private :: marbl_forcing_diag_ids + integer :: atm_fine_dust !< Atmospheric fine dust component of dust_flux + integer :: atm_coarse_dust !< Atmospheric coarse dust component of dust_flux + integer :: atm_bc !< Atmospheric black carbon component of iron_flux + integer :: ice_dust !< Sea-ice dust component of dust_flux + integer :: ice_bc !< Sea-ice black carbon component of iron_flux +end type marbl_forcing_diag_ids + +!> Control structure for this module +type, public :: marbl_forcing_CS ; private + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + + real :: dust_ratio_thres !< coarse/fine dust ratio threshold [1] + real :: dust_ratio_to_fe_bioavail_frac !< ratio of dust to iron bioavailability fraction [1] + real :: fe_bioavail_frac_offset !< offset for iron bioavailability fraction [1] + real :: atm_fe_to_bc_ratio !< atmospheric iron to black carbon ratio [1] + real :: atm_bc_fe_bioavail_frac !< atmospheric black carbon to iron bioavailablity fraction ratio [1] + real :: seaice_fe_to_bc_ratio !< sea-ice iron to black carbon ratio [1] + real :: seaice_bc_fe_bioavail_frac !< sea-ice black carbon to iron bioavailablity fraction ratio [1] + real :: iron_frac_in_atm_fine_dust !< Fraction of fine dust from the atmosphere that is iron [1] + real :: iron_frac_in_atm_coarse_dust !< Fraction of coarse dust from the atmosphere that is iron [1] + real :: iron_frac_in_seaice_dust !< Fraction of dust from the sea ice that is iron [1] + real :: atm_co2_const !< atmospheric CO2 (if specifying a constant value) [ppm] + real :: atm_alt_co2_const !< alternate atmospheric CO2 for _ALT_CO2 tracers + !! (if specifying a constant value) [ppm] + + type(marbl_forcing_diag_ids) :: diag_ids !< used for registering and posting some MARBL forcing fields as diagnostics + + logical :: use_marbl_tracers !< most functions can return immediately + !! MARBL tracers are turned off + integer :: atm_co2_iopt !< Integer version of atm_co2_opt, which determines source of atm_co2 + integer :: atm_alt_co2_iopt !< Integer version of atm_alt_co2_opt, which determines source of atm_alt_co2 + +end type marbl_forcing_CS + +! Module parameters +integer, parameter :: atm_co2_constant_iopt = 0 !< module parameter denoting atm_co2_opt = 'constant' +integer, parameter :: atm_co2_prognostic_iopt = 1 !< module parameter denoting atm_co2_opt = 'diagnostic' +integer, parameter :: atm_co2_diagnostic_iopt = 2 !< module parameter denoting atm_co2_opt = 'prognostic' + +contains + + subroutine MARBL_forcing_init(G, US, param_file, diag, day, inputdir, use_marbl, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(diag_ctrl), target, intent(in) :: diag !< Structure used to regulate diagnostic output. + type(time_type), target, intent(in) :: day !< Time of the start of the run. + character(len=*), intent(in) :: inputdir !< Directory containing input files + logical, intent(in) :: use_marbl !< Is MARBL tracer package active? + type(marbl_forcing_CS), pointer, intent(inout) :: CS !< A pointer that is set to point to control + !! structure for MARBL forcing + + character(len=40) :: mdl = "MARBL_forcing_mod" ! This module's name. + character(len=15) :: atm_co2_opt + character(len=200) :: err_message + + if (associated(CS)) then + call MOM_error(WARNING, "marbl_forcing_init called with an associated control structure.") + return + endif + + allocate(CS) + CS%diag => diag + + CS%use_marbl_tracers = .true. + if (.not. use_marbl) then + CS%use_marbl_tracers = .false. + return + endif + + call get_param(param_file, mdl, "DUST_RATIO_THRES", CS%dust_ratio_thres, & + "coarse/fine dust ratio threshold", units="1", default=69.00594) + call get_param(param_file, mdl, "DUST_RATIO_TO_FE_BIOAVAIL_FRAC", CS%dust_ratio_to_fe_bioavail_frac, & + "ratio of dust to iron bioavailability fraction", units="1", default=1./366.314) + call get_param(param_file, mdl, "FE_BIOAVAIL_FRAC_OFFSET", CS%fe_bioavail_frac_offset, & + "offset for iron bioavailability fraction", units="1", default=0.0146756) + call get_param(param_file, mdl, "ATM_FE_TO_BC_RATIO", CS%atm_fe_to_bc_ratio, & + "atmospheric iron to black carbon ratio", units="1", default=1.) + call get_param(param_file, mdl, "ATM_BC_FE_BIOAVAIL_FRAC", CS%atm_bc_fe_bioavail_frac, & + "atmospheric black carbon to iron bioavailablity fraction ratio", units="1", default=0.06) + call get_param(param_file, mdl, "SEAICE_FE_TO_BC_RATIO", CS%seaice_fe_to_bc_ratio, & + "sea-ice iron to black carbon ratio", units="1", default=1.) + call get_param(param_file, mdl, "SEAICE_BC_FE_BIOAVAIL_FRAC", CS%seaice_bc_fe_bioavail_frac, & + "sea-ice black carbon to iron bioavailablity fraction ratio", units="1", default=0.06) + call get_param(param_file, mdl, "IRON_FRAC_IN_ATM_FINE_DUST", CS%iron_frac_in_atm_fine_dust, & + "Fraction of fine dust from the atmosphere that is iron", units="1", default=0.035) + call get_param(param_file, mdl, "IRON_FRAC_IN_ATM_COARSE_DUST", CS%iron_frac_in_atm_coarse_dust, & + "Fraction of coarse dust from the atmosphere that is iron", units="1", default=0.035) + call get_param(param_file, mdl, "IRON_FRAC_IN_SEAICE_DUST", CS%iron_frac_in_seaice_dust, & + "Fraction of dust from sea ice that is iron", units="1", default=0.035) + call get_param(param_file, mdl, "ATM_CO2_OPT", atm_co2_opt, & + "Source of atmospheric CO2 [constant, diagnostic, or prognostic]", & + default="constant") + select case (trim(atm_co2_opt)) + case("prognostic") + CS%atm_co2_iopt = atm_co2_prognostic_iopt + case("diagnostic") + CS%atm_co2_iopt = atm_co2_diagnostic_iopt + case("constant") + CS%atm_co2_iopt = atm_co2_constant_iopt + case DEFAULT + write(err_message, "(3A)") "'", trim(atm_co2_opt), "' is not a valid ATM_CO2_OPT value" + call MOM_error(FATAL, err_message) + end select + if (CS%atm_co2_iopt == atm_co2_constant_iopt) then + call get_param(param_file, mdl, "ATM_CO2_CONST", CS%atm_co2_const, & + "Value to send to MARBL as xco2", & + default=284.317, units="ppm") + endif + call get_param(param_file, mdl, "ATM_ALT_CO2_OPT", atm_co2_opt, & + "Source of alternate atmospheric CO2 [constant, diagnostic, or prognostic]", & + default="constant") + select case (trim(atm_co2_opt)) + case("prognostic") + CS%atm_alt_co2_iopt = atm_co2_prognostic_iopt + case("diagnostic") + CS%atm_alt_co2_iopt = atm_co2_diagnostic_iopt + case("constant") + CS%atm_alt_co2_iopt = atm_co2_constant_iopt + case DEFAULT + write(err_message, "(3A)") "'", trim(atm_co2_opt), "' is not a valid ATM_ALT_CO2_OPT value" + call MOM_error(FATAL, err_message) + end select + if (CS%atm_alt_co2_iopt == atm_co2_constant_iopt) then + call get_param(param_file, mdl, "ATM_ALT_CO2_CONST", CS%atm_alt_co2_const, & + "Value to send to MARBL as xco2_alt_co2", & + default=284.317, units="ppm") + endif + + ! Register diagnostic fields for outputing forcing values + ! These fields are posted from convert_driver_fields_to_forcings(), and they are received + ! in physical units so no conversion is necessary here. + CS%diag_ids%atm_fine_dust = register_diag_field("ocean_model", "ATM_FINE_DUST_FLUX_CPL", & + CS%diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "ATM_FINE_DUST_FLUX from cpl", "kg/m^2/s") + CS%diag_ids%atm_coarse_dust = register_diag_field("ocean_model", "ATM_COARSE_DUST_FLUX_CPL", & + CS%diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "ATM_COARSE_DUST_FLUX from cpl", "kg/m^2/s") + CS%diag_ids%atm_bc = register_diag_field("ocean_model", "ATM_BLACK_CARBON_FLUX_CPL", & + CS%diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "ATM_BLACK_CARBON_FLUX from cpl", "kg/m^2/s") + + CS%diag_ids%ice_dust = register_diag_field("ocean_model", "SEAICE_DUST_FLUX_CPL", & + CS%diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "SEAICE_DUST_FLUX from cpl", "kg/m^2/s") + CS%diag_ids%ice_bc = register_diag_field("ocean_model", "SEAICE_BLACK_CARBON_FLUX_CPL", & + CS%diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "SEAICE_BLACK_CARBON_FLUX from cpl", "kg/m^2/s") + + end subroutine MARBL_forcing_init + + ! Note: ice fraction and u10_sqr are handled in mom_surface_forcing because of CFCs + subroutine convert_driver_fields_to_forcings(atm_fine_dust_flux, atm_coarse_dust_flux, & + seaice_dust_flux, atm_bc_flux, seaice_bc_flux, & + nhx_dep, noy_dep, atm_co2_prog, atm_co2_diag, & + afracr, swnet_afracr, ifrac_n, & + swpen_ifrac_n, Time, G, US, i0, j0, fluxes, CS) + + real, dimension(:,:), pointer, intent(in) :: atm_fine_dust_flux !< atmosphere fine dust flux from IOB + !! [kg m-2 s-1] + real, dimension(:,:), pointer, intent(in) :: atm_coarse_dust_flux !< atmosphere coarse dust flux from IOB + !! [kg m-2 s-1] + real, dimension(:,:), pointer, intent(in) :: seaice_dust_flux !< sea ice dust flux from IOB [kg m-2 s-1] + real, dimension(:,:), pointer, intent(in) :: atm_bc_flux !< atmosphere black carbon flux from IOB + !! [kg m-2 s-1] + real, dimension(:,:), pointer, intent(in) :: seaice_bc_flux !< sea ice black carbon flux from IOB + !! [kg m-2 s-1] + real, dimension(:,:), pointer, intent(in) :: afracr !< open ocean fraction [1] + real, dimension(:,:), pointer, intent(in) :: nhx_dep !< NHx flux from atmosphere [kg m-2 s-1] + real, dimension(:,:), pointer, intent(in) :: noy_dep !< NOy flux from atmosphere [kg m-2 s-1] + real, dimension(:,:), pointer, intent(in) :: atm_co2_prog !< Prognostic atmospheric CO2 concentration + !! [ppm] + real, dimension(:,:), pointer, intent(in) :: atm_co2_diag !< Diagnostic atmospheric CO2 concentration + !! [ppm] + real, dimension(:,:), pointer, intent(in) :: swnet_afracr !< shortwave flux * open ocean fraction + !! [W m-2] + real, dimension(:,:,:), pointer, intent(in) :: ifrac_n !< per-category ice fraction [1] + real, dimension(:,:,:), pointer, intent(in) :: swpen_ifrac_n !< per-category shortwave flux * ice fraction + !! [W m-2] + type(time_type), intent(in) :: Time !< The time of the fluxes, used for + !! interpolating the salinity to the + !! right time, when it is being + !! restored. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: i0 !< i index offset + integer, intent(in) :: j0 !< j index offset + type(forcing), intent(inout) :: fluxes !< MARBL-specific forcing fields + type(marbl_forcing_CS), pointer, intent(inout) :: CS !< A pointer that is set to point to + !! control structure for MARBL forcing + + integer :: i, j, is, ie, js, je, m + real :: atm_fe_bioavail_frac !< Fraction of iron from the atmosphere available for biological uptake [1] + real :: seaice_fe_bioavail_frac !< Fraction of iron from sea ice available for biological uptake [1] + ! Note: following two conversion factors are used to both convert from km m-2 s-1 -> mmol m-2 s-1 + !! AND cast in MOM6's unique dimensional consistency scaling system [conc Z T-1] + real :: iron_flux_conversion !< Factor to convert iron flux from kg m-2 s-1 -> mmol m-3 (m s-1) + !! [s m2 kg-1 conc Z T-1 ~> mmol kg-1] + real :: ndep_conversion !< Factor to convert nitrogen deposition from kg m-2 s-1 -> mmol m-3 (m s-1) + !! [s m2 kg-1 conc Z T-1 ~> mmol kg-1] + + if (.not. CS%use_marbl_tracers) return + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + ndep_conversion = (1.e6/14.) * (US%m_to_Z * US%T_to_s) + iron_flux_conversion = (1.e6 / molw_Fe) * (US%m_to_Z * US%T_to_s) + + ! Post fields from coupler to diagnostics + ! TODO: units from diag register are incorrect; we should be converting these in the cap, I think + if (CS%diag_ids%atm_fine_dust > 0) & + call post_data(CS%diag_ids%atm_fine_dust, atm_fine_dust_flux(is-i0:ie-i0,js-j0:je-j0), & + CS%diag, mask=G%mask2dT(is:ie,js:je)) + if (CS%diag_ids%atm_coarse_dust > 0) & + call post_data(CS%diag_ids%atm_coarse_dust, atm_coarse_dust_flux(is-i0:ie-i0,js-j0:je-j0), & + CS%diag, mask=G%mask2dT(is:ie,js:je)) + if (CS%diag_ids%atm_bc > 0) & + call post_data(CS%diag_ids%atm_bc, atm_bc_flux(is-i0:ie-i0,js-j0:je-j0), CS%diag, & + mask=G%mask2dT(is:ie,js:je)) + if (CS%diag_ids%ice_dust > 0) & + call post_data(CS%diag_ids%ice_dust, seaice_dust_flux(is-i0:ie-i0,js-j0:je-j0), CS%diag, & + mask=G%mask2dT(is:ie,js:je)) + if (CS%diag_ids%ice_bc > 0) & + call post_data(CS%diag_ids%ice_bc, seaice_bc_flux(is-i0:ie-i0,js-j0:je-j0), CS%diag, & + mask=G%mask2dT(is:ie,js:je)) + + do j=js,je ; do i=is,ie + ! Nitrogen Deposition + fluxes%nhx_dep(i,j) = (G%mask2dT(i,j) * ndep_conversion) * nhx_dep(i-i0,j-j0) + fluxes%noy_dep(i,j) = (G%mask2dT(i,j) * ndep_conversion) * noy_dep(i-i0,j-j0) + enddo ; enddo + + ! Atmospheric CO2 + select case (CS%atm_co2_iopt) + case (atm_co2_prognostic_iopt) + if (associated(atm_co2_prog)) then + do j=js,je ; do i=is,ie + fluxes%atm_co2(i,j) = G%mask2dT(i,j) * atm_co2_prog(i-i0,j-j0) + enddo ; enddo + else + call MOM_error(FATAL, & + "ATM_CO2_OPT = 'prognostic' but atmosphere is not providing this field") + endif + case (atm_co2_diagnostic_iopt) + if (associated(atm_co2_diag)) then + do j=js,je ; do i=is,ie + fluxes%atm_co2(i,j) = G%mask2dT(i,j) * atm_co2_diag(i-i0,j-j0) + enddo ; enddo + else + call MOM_error(FATAL, & + "ATM_CO2_OPT = 'diagnostic' but atmosphere is not providing this field") + endif + case (atm_co2_constant_iopt) + do j=js,je ; do i=is,ie + fluxes%atm_co2(i,j) = G%mask2dT(i,j) * CS%atm_co2_const + enddo ; enddo + end select + + ! Alternate Atmospheric CO2 + select case (CS%atm_alt_co2_iopt) + case (atm_co2_prognostic_iopt) + if (associated(atm_co2_prog)) then + do j=js,je ; do i=is,ie + fluxes%atm_alt_co2(i,j) = G%mask2dT(i,j) * atm_co2_prog(i-i0,j-j0) + enddo ; enddo + else + call MOM_error(FATAL, & + "ATM_ALT_CO2_OPT = 'prognostic' but atmosphere is not providing this field") + endif + case (atm_co2_diagnostic_iopt) + if (associated(atm_co2_diag)) then + do j=js,je ; do i=is,ie + fluxes%atm_alt_co2(i,j) = G%mask2dT(i,j) * atm_co2_diag(i-i0,j-j0) + enddo ; enddo + else + call MOM_error(FATAL, & + "ATM_ALT_CO2_OPT = 'diagnostic' but atmosphere is not providing this field") + endif + case (atm_co2_constant_iopt) + do j=js,je ; do i=is,ie + fluxes%atm_alt_co2(i,j) = G%mask2dT(i,j) * CS%atm_co2_const + enddo ; enddo + end select + + ! Dust flux + if (associated(atm_fine_dust_flux)) then + do j=js,je ; do i=is,ie + fluxes%dust_flux(i,j) = (US%kg_m2s_to_RZ_T * G%mask2dT(i,j)) * & + ((atm_fine_dust_flux(i-i0,j-j0) + atm_coarse_dust_flux(i-i0,j-j0)) + & + seaice_dust_flux(i-i0,j-j0)) + enddo ; enddo + endif + + if (associated(atm_bc_flux)) then + do j=js,je ; do i=is,ie + ! TODO: abort if atm_fine_dust_flux and atm_coarse_dust_flux are not associated? + ! Contribution of atmospheric dust to iron flux + if (atm_coarse_dust_flux(i-i0,j-j0) < & + CS%dust_ratio_thres * atm_fine_dust_flux(i-i0,j-j0)) then + atm_fe_bioavail_frac = CS%fe_bioavail_frac_offset + CS%dust_ratio_to_fe_bioavail_frac * & + (CS%dust_ratio_thres - atm_coarse_dust_flux(i-i0,j-j0) / atm_fine_dust_flux(i-i0,j-j0)) + else + atm_fe_bioavail_frac = CS%fe_bioavail_frac_offset + endif + + ! Contribution of atmospheric dust to iron flux + fluxes%iron_flux(i,j) = (atm_fe_bioavail_frac * & + (CS%iron_frac_in_atm_fine_dust * atm_fine_dust_flux(i-i0,j-j0) + & + CS%iron_frac_in_atm_coarse_dust * atm_coarse_dust_flux(i-i0,j-j0))) + + ! Contribution of atmospheric black carbon to iron flux + fluxes%iron_flux(i,j) = fluxes%iron_flux(i,j) + (CS%atm_bc_fe_bioavail_frac * & + (CS%atm_fe_to_bc_ratio * atm_bc_flux(i-i0,j-j0))) + + seaice_fe_bioavail_frac = atm_fe_bioavail_frac + ! Contribution of seaice dust to iron flux + fluxes%iron_flux(i,j) = fluxes%iron_flux(i,j) + (seaice_fe_bioavail_frac * & + (CS%iron_frac_in_seaice_dust * seaice_dust_flux(i-i0,j-j0))) + + ! Contribution of seaice black carbon to iron flux + fluxes%iron_flux(i,j) = fluxes%iron_flux(i,j) + (CS%seaice_bc_fe_bioavail_frac * & + (CS%seaice_fe_to_bc_ratio * seaice_bc_flux(i-i0,j-j0))) + + ! Unit conversion (kg m-2 s-1 -> conc Z T-1) + fluxes%iron_flux(i,j) = (G%mask2dT(i,j) * iron_flux_conversion) * fluxes%iron_flux(i,j) + + enddo ; enddo + endif + + ! Per ice-category forcings + ! If the cap receives per-category fields, memory should be allocated in fluxes + if (associated(ifrac_n)) then + do j=js,je ; do i=is,ie + fluxes%fracr_cat(i,j,1) = min(1., afracr(i-i0,j-j0)) + fluxes%qsw_cat(i,j,1) = swnet_afracr(i-i0,j-j0) + do m=1,size(ifrac_n, 3) + fluxes%fracr_cat(i,j,m+1) = min(1., ifrac_n(i-i0,j-j0,m)) + fluxes%qsw_cat(i,j,m+1) = swpen_ifrac_n(i-i0,j-j0,m) + enddo + where (fluxes%fracr_cat(i,j,:) > 0.) + fluxes%qsw_cat(i,j,:) = fluxes%qsw_cat(i,j,:) / fluxes%fracr_cat(i,j,:) + elsewhere + fluxes%fracr_cat(i,j,:) = 0. + fluxes%qsw_cat(i,j,:) = 0. + endwhere + fluxes%fracr_cat(i,j,:) = G%mask2dT(i,j) * fluxes%fracr_cat(i,j,:) + fluxes%qsw_cat(i,j,:) = (US%W_m2_to_QRZ_T * G%mask2dT(i,j)) * fluxes%qsw_cat(i,j,:) + enddo ; enddo + endif + + end subroutine convert_driver_fields_to_forcings + +end module MARBL_forcing_mod diff --git a/src/tracer/MARBL_tracers.F90 b/src/tracer/MARBL_tracers.F90 new file mode 100644 index 0000000000..2b8a9d4849 --- /dev/null +++ b/src/tracer/MARBL_tracers.F90 @@ -0,0 +1,2354 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> A tracer package for tracers computed in the MARBL library +!! +!! Currently configured for use with marbl0.36.0 +!! https://github.com/marbl-ecosys/MARBL/releases/tag/marbl0.36.0 +!! (clone entire repo into pkg/MARBL) +module MARBL_tracers + +use MOM_coms, only : EFP_type, root_PE, broadcast +use MOM_debugging, only : hchksum +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : is_root_PE, MOM_error, FATAL, WARNING, NOTE +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_interpolate, only : external_field, init_external_field, time_interp_external +use MOM_CVMix_KPP, only : KPP_NonLocalTransport, KPP_CS +use MOM_hor_index, only : hor_index_type +use MOM_interpolate, only : forcing_timeseries_dataset +use MOM_interpolate, only : forcing_timeseries_set_time_type_vars +use MOM_interpolate, only : map_model_time_to_forcing_time +use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc +use MOM_open_boundary, only : ocean_OBC_type +use MOM_remapping, only : reintegrate_column +use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h +use MOM_restart, only : query_initialized, MOM_restart_CS, register_restart_field +use MOM_spatial_means, only : global_mass_int_EFP +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type +use MOM_tracer_registry, only : register_tracer +use MOM_tracer_types, only : tracer_type, tracer_registry_type +use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut +use MOM_tracer_initialization_from_Z, only : MOM_initialize_tracer_from_Z +use MOM_tracer_Z_init, only : read_Z_edges +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_diag_mediator, only : register_diag_field, post_data!, safe_alloc_ptr + +use MARBL_interface, only : MARBL_interface_class +use MARBL_interface_public_types, only : marbl_diagnostics_type, marbl_saved_state_type + +use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux + +implicit none ; private + +#include + +public register_MARBL_tracers, initialize_MARBL_tracers +public MARBL_tracers_column_physics, MARBL_tracers_surface_state +public MARBL_tracers_set_forcing +public MARBL_tracers_stock, MARBL_tracers_get, MARBL_tracers_end + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Temporary type for diagnostic variables coming from MARBL +!! Allocate exactly one of field_[23]d +type :: temp_MARBL_diag + integer :: id !< index into MOM diagnostic structure + real, allocatable :: field_2d(:,:) !< memory for 2D field + real, allocatable :: field_3d(:,:,:) !< memory for 3D field +end type temp_MARBL_diag + +!> MOM6 needs to know the index of some MARBL tracers to properly apply river fluxes +type :: tracer_ind_type + integer :: no3_ind !< NO3 index + integer :: po4_ind !< PO4 index + integer :: don_ind !< DON index + integer :: donr_ind !< DONr index + integer :: dop_ind !< DOP index + integer :: dopr_ind !< DOPr index + integer :: sio3_ind !< SiO3 index + integer :: fe_ind !< Fe index + integer :: doc_ind !< DOC index + integer :: docr_ind !< DOCr index + integer :: alk_ind !< ALK index + integer :: alk_alt_co2_ind !< ALK_ALT_CO2 index + integer :: dic_ind !< DIC index + integer :: dic_alt_co2_ind !< DIC_ALT_CO2 index + integer :: abio_dic_ind !< ABIO_DIC index + integer :: abio_di14c_ind !< ABIO_DI14C index +end type tracer_ind_type + +!> MOM needs to store some information about saved_state; besides providing these +!! fields to MARBL, they are also written to restart files +type :: saved_state_for_MARBL_type + character(len=200) :: short_name !< name of variable being saved + character(len=200) :: file_varname !< name of variable in restart file + character(len=200) :: units !< variable units + real, pointer :: field_2d(:,:) => NULL() !< memory for 2D field + real, pointer :: field_3d(:,:,:) => NULL() !< memory for 3D field +end type saved_state_for_MARBL_type + +!> All calls to MARBL are done via the interface class +type(MARBL_interface_class) :: MARBL_instances + +!> Pointer to tracer concentration and to tracer_type in tracer registry +type, private :: MARBL_tracer_data + real, pointer :: tr(:,:,:) => NULL() !< Array of tracers used in this subroutine [CU ~> conc] + !! (ALK tracers use meq m-3 instead of mmol m-3) + type(tracer_type), pointer :: tr_ptr => NULL() !< pointer to tracer inside Tr_reg +end type MARBL_tracer_data + +!> The control structure for the MARBL tracer package +type, public :: MARBL_tracers_CS ; private + integer :: ntr !< The number of tracers that are actually used. + logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: base_bio_on !< Will MARBL use base biotic tracers? + logical :: abio_dic_on !< Will MARBL use abiotic DIC / DI14C tracers? + logical :: ciso_on !< Will MARBL use isotopic tracers? + + integer :: restore_count !< The number of tracers MARBL is configured to restore + logical :: coupled_tracers = .false. !< These tracers are not offered to the coupler. + logical :: use_ice_category_fields !< Forcing will include multiple ice categories for ice_frac and shortwave + logical :: request_Chl_from_MARBL !< MARBL can provide Chl to use in set_pen_shortwave() + integer :: ice_ncat !< Number of ice categories when use_ice_category_fields = True + real :: IC_min !< Minimum value for tracer initial conditions [CU ~> conc] + character(len=200) :: IC_file !< The file in which the age-tracer initial values cam be found. + logical :: ongrid !< True if IC_file is already interpolated to MOM grid + type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry + type(MARBL_tracer_data), dimension(:), allocatable :: tracer_data !< type containing tracer data and pointer + !! into tracer registry + + integer, allocatable, dimension(:) :: ind_tr !< Indices returned by aof_set_coupler_flux if it is used and the + !! surface tracer concentrations are to be provided to the coupler. + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control structure + + type(vardesc), allocatable :: tr_desc(:) !< Descriptions and metadata for the tracers + logical :: tracers_may_reinit !< If true the tracers may be initialized if not found in a restart file + + character(len=200) :: fesedflux_file !< name of [netCDF] file containing iron sediment flux + character(len=200) :: feventflux_file !< name of [netCDF] file containing iron vent flux + type(forcing_timeseries_dataset) :: d14c_dataset(3) !< File and time axis information for d14c forcing + real, dimension(3) :: d14c_bands !< forcing is organized into bands: [30 N, 90 N]; [30 S, 30 N]; [90 S, 30 S] + !! This variable contains D14C for each band [CU ~> conc] + integer :: d14c_id !< id for diagnostic field with d14c forcing + logical :: read_riv_fluxes !< If true, use river fluxes supplied from an input file. + !! This is temporary, we will always read river fluxes + type(forcing_timeseries_dataset) :: riv_flux_dataset !< File and time axis information for river fluxes + character(len=4) :: restoring_source !< location of tracer restoring data + !! valid values: file, none + integer :: restoring_nz !< number of levels in tracer restoring file + real, allocatable, dimension(:) :: & + restoring_z_edges !< The depths of the cell interfaces in the tracer restoring file [Z ~> m] + real, allocatable, dimension(:) :: & + restoring_dz !< The thickness of the cell layers in the tracer restoring file [H ~> m] + integer :: restoring_timescale_nz !< number of levels in tracer restoring timescale file + real, allocatable, dimension(:) :: & + restoring_timescale_z_edges !< The depths of the cell interfaces in the tracer restoring timescale file [Z ~> m] + real, allocatable, dimension(:) :: & + restoring_timescale_dz !< The thickness of the cell layers in the tracer restoring timescale file [H ~> m] + character(len=14) :: restoring_I_tau_source !< location of inverse restoring timescale data + !! valid values: file, grid_dependent + character(len=200) :: restoring_file !< name of [netCDF] file containing tracer restoring data + type(remapping_CS) :: restoring_remapCS !< Remapping parameters and work arrays for tracer restoring / timescale + character(len=200) :: restoring_I_tau_file !< name of [netCDF] file containing inverse restoring timescale + character(len=200) :: restoring_I_tau_var_name !< name of field containing inverse restoring timescale + character(len=35) :: marbl_settings_file !< name of [text] file containing MARBL settings + + real :: bot_flux_mix_thickness !< for bottom flux -> tendency conversion, assume uniform mixing over + !! bottom layer of prescribed thickness [Z ~> m] + real :: Ibfmt !< Reciprocal of bot_flux_mix_thickness [Z-1 ~> m-1] + + type(temp_MARBL_diag), allocatable :: surface_flux_diags(:) !< collect surface flux diagnostics from all columns + !! before posting + type(temp_MARBL_diag), allocatable :: interior_tendency_diags(:) !< collect tendency diagnostics from all columns + !! before posting + type(saved_state_for_MARBL_type), allocatable :: surface_flux_saved_state(:) !< surface_flux saved state + type(saved_state_for_MARBL_type), allocatable :: interior_tendency_saved_state(:) !< interior_tendency saved state + + ! TODO: If we can post data column by column, all we need are integer arrays for ids + ! integer, allocatable :: id_surface_flux_diags(:) !< array of indices for surface_flux diagnostics + ! integer, allocatable :: id_interior_tendency_diags(:) !< array of indices for interior_tendency diagnostics + + type(tracer_ind_type) :: tracer_inds !< Indices to tracers that will have river fluxes added to STF + + !> Need to store global output from both marbl_instance%surface_flux_compute() and + !! marbl_instance%interior_tendency_compute(). For the former, just need id to register + !! because we already copy data into CS%STF; latter requires copying data and indices + !! so currently using temp_MARBL_diag for that. + integer, allocatable :: id_surface_flux_out(:) !< register_diag indices for surface_flux output + integer, allocatable :: id_surface_flux_from_salt_flux(:) !< register_diag indices for surface_flux from salt_flux + type(temp_MARBL_diag), allocatable :: interior_tendency_out(:) !< collect interior tendencies for diagnostic output + type(temp_MARBL_diag), allocatable :: interior_tendency_out_zint(:) !< vertical integral of interior tendencies + !! (full column) + type(temp_MARBL_diag), allocatable :: interior_tendency_out_zint_100m(:) !< vertical integral of interior tendencies + !! (top 100m) + integer :: bot_flux_to_tend_id !< register_diag index for BOT_FLUX_TO_TEND + integer, allocatable :: fracr_cat_id(:) !< register_diag index for per-category ice fraction + integer, allocatable :: qsw_cat_id(:) !< register_diag index for per-category shortwave + + real :: DIC_salt_ratio !< ratio to convert salt surface flux to DIC surface flux [conc ppt-1] + real :: ALK_salt_ratio !< ratio to convert salt surface flux to ALK surface flux [conc ppt-1] + + real, allocatable :: STF(:,:,:) !< surface fluxes returned from MARBL to use in tracer_vertdiff + !! (dims: i, j, tracer) [conc Z T-1 ~> conc m s-1] + real, pointer :: SFO(:,:,:) => NULL() !< surface flux output returned from MARBL for use in GCM + !! e.g. CO2 flux to pass to atmosphere (dims: i, j, num_sfo) + !! Units vary based on index of num_sfo dimension + real, pointer :: ITO(:,:,:,:) => NULL() !< interior tendency output returned from MARBL for use in GCM + !! e.g. total chlorophyll to use in shortwave penetration + !! (dims: i, j, k, num_ito) + !! Units vary based on index of num_ito dimension + + integer :: u10_sqr_ind !< index of MARBL forcing field array to copy 10-m wind (squared) into + integer :: sss_ind !< index of MARBL forcing field array to copy sea surface salinity into + integer :: sst_ind !< index of MARBL forcing field array to copy sea surface temperature into + integer :: ifrac_ind !< index of MARBL forcing field array to copy ice fraction into + integer :: dust_dep_ind !< index of MARBL forcing field array to copy dust flux into + integer :: fe_dep_ind !< index of MARBL forcing field array to copy iron flux into + integer :: nox_flux_ind !< index of MARBL forcing field array to copy NOx flux into + integer :: nhy_flux_ind !< index of MARBL forcing field array to copy NHy flux into + integer :: atmpress_ind !< index of MARBL forcing field array to copy atmospheric pressure into + integer :: xco2_ind !< index of MARBL forcing field array to copy CO2 flux into + integer :: xco2_alt_ind !< index of MARBL forcing field array to copy CO2 flux (alternate CO2) into + integer :: d14c_ind !< index of MARBL forcing field array to copy d14C into + + !> external_field types for river fluxes (added to surface fluxes) + type(external_field) :: id_din_riv !< id for time_interp_external. + type(external_field) :: id_don_riv !< id for time_interp_external. + type(external_field) :: id_dip_riv !< id for time_interp_external. + type(external_field) :: id_dop_riv !< id for time_interp_external. + type(external_field) :: id_dsi_riv !< id for time_interp_external. + type(external_field) :: id_dfe_riv !< id for time_interp_external. + type(external_field) :: id_dic_riv !< id for time_interp_external. + type(external_field) :: id_alk_riv !< id for time_interp_external. + type(external_field) :: id_doc_riv !< id for time_interp_external. + + !> external_field type for d14c (needed if abio_dic_on is True) + type(external_field) :: id_d14c(3) !< id for time_interp_external. + + !> Indices for river fluxes (diagnostics) + integer :: no3_riv_flux !< NO3 riverine flux + integer :: po4_riv_flux !< PO4 riverine flux + integer :: don_riv_flux !< DON riverine flux + integer :: donr_riv_flux !< DONr riverine flux + integer :: dop_riv_flux !< DOP riverine flux + integer :: dopr_riv_flux !< DOPr riverine flux + integer :: sio3_riv_flux !< SiO3 riverine flux + integer :: fe_riv_flux !< Fe riverine flux + integer :: doc_riv_flux !< DOC riverine flux + integer :: docr_riv_flux !< DOCr riverine flux + integer :: alk_riv_flux !< ALK riverine flux + integer :: alk_alt_co2_riv_flux !< ALK (alternate CO2) riverine flux + integer :: dic_riv_flux !< DIC riverine flux + integer :: dic_alt_co2_riv_flux !< DIC (alternate CO2) riverine flux + + !> Indices for forcing fields required to compute interior tendencies + integer :: dustflux_ind !< index of MARBL forcing field array to copy dust flux into + integer :: PAR_col_frac_ind !< index of MARBL forcing field array to copy PAR column fraction into + integer :: surf_shortwave_ind !< index of MARBL forcing field array to copy surface shortwave into + integer :: potemp_ind !< index of MARBL forcing field array to copy potential temperature into + integer :: salinity_ind !< index of MARBL forcing field array to copy salinity into + integer :: pressure_ind !< index of MARBL forcing field array to copy pressure into + integer :: fesedflux_ind !< index of MARBL forcing field array to copy iron sediment flux into + integer :: o2_scalef_ind !< index of MARBL forcing field array to copy O2 scale length into + integer :: remin_scalef_ind !< index of MARBL forcing field array to copy remin scale length into + type(external_field), allocatable :: id_tracer_restoring(:) !< id number for time_interp_external + integer, allocatable :: tracer_restoring_ind(:) !< index of MARBL forcing field to copy + !! per-tracer restoring field into + integer, allocatable :: tracer_I_tau_ind(:) !< index of MARBL forcing field to copy per-tracer + !! inverse restoring timescale into + + !> Memory for storing river fluxes, tracer restoring fields, and abiotic forcing + real, allocatable :: d14c(:,:) !< d14c forcing for abiotic DIC and carbon isotope tracer modules + !! [mmol m-3 s-1] + real, allocatable :: RIV_FLUXES(:,:,:) !< river flux forcing for applyTracerBoundaryFluxesInOut + !! (needs to be time-integrated when passed to function!) + !! (dims: i, j, tracer) [conc m s-1] + character(len=15), allocatable :: tracer_restoring_varname(:) !< name of variable being restored + real, allocatable :: I_tau(:,:,:) !< inverse restoring timescale for marbl tracers (dims: i, j, k) [s-1] + real, allocatable, dimension(:,:,:,:) :: restoring_in !< Restoring fields read from file + !! (dims: i, j, restoring_nz, restoring_cnt) [tracer units] + + !> Number of surface flux outputs as well as specific indices for each one + integer :: sfo_cnt !< number of surface flux outputs from MARBL + integer :: ito_cnt !< number of interior tendency outputs from MARBL + integer :: flux_co2_ind !< index to co2 flux surface flux output + integer :: total_Chl_ind !< index to total chlorophyll interior tendency output + + ! TODO: create generic 3D forcing input type to read z coordinate + values + real :: fesedflux_scale_factor !< scale factor for iron sediment flux [mmol umol-1 d s-1] + integer :: fesedflux_nz !< number of levels in iron sediment flux file + real, allocatable, dimension(:,:,:) :: fesedflux_in !< Field to read iron sediment flux into [conc m s-1] + real, allocatable, dimension(:,:,:) :: feventflux_in !< Field to read iron vent flux into [conc m s-1] + real, allocatable, dimension(:) :: & + fesedflux_z_edges !< The depths of the cell interfaces in the input data [Z ~> m] + ! TODO: this thickness does not need to be 3D, but it is easier to make thickness 0 + ! below the surface on a per-column basis (could save memory by storing 1D + ! thickness from file and then computing a second 1D thickness array in (i,j) loop) + real, allocatable, dimension(:,:,:) :: & + fesedflux_dz !< The thickness of the cell layers in the input data [H ~> m] +end type MARBL_tracers_CS + +! Module parameters +real, parameter :: atm_per_Pa = 1./101325. !< convert from Pa -> atm [atm Pa-1] + +contains + +!> This subroutine is used to read marbl_in, configure MARBL accordingly, and then +!! call MARBL's initialization routine +subroutine configure_MARBL_tracers(GV, US, param_file, CS) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(MARBL_tracers_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module + +# include "version_variable.h" + character(len=40) :: mdl = "MARBL_tracers" ! This module's name. + character(len=256) :: log_message + character(len=256) :: marbl_in_line(1) + character(len=256) :: forcing_sname, field_source + integer :: m, n, nz, marbl_settings_in, read_error, I_tau_count, fi + logical :: chl_from_file, forcing_processed + nz = GV%ke + marbl_settings_in = 615 + + ! (1) Read parameters necessary for general setup of MARBL + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "DEBUG", CS%debug, "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + call get_param(param_file, mdl, "MARBL_IC_MIN_VAL", CS%IC_min, & + "Minimum value of tracer initial conditions (set to 1e-100 for dim scaling tests)", & + default=0., units="tracer units") + call get_param(param_file, mdl, "MARBL_SETTINGS_FILE", CS%marbl_settings_file, & + "The name of a file from which to read the run-time settings for MARBL.", default="marbl_in") + call get_param(param_file, mdl, "BOT_FLUX_MIX_THICKNESS", CS%bot_flux_mix_thickness, & + "Bottom fluxes are uniformly mixed over layer of this thickness", default=1., units="m", & + scale=US%m_to_Z) + call get_param(param_file, mdl, "USE_ICE_CATEGORIES", CS%use_ice_category_fields, & + "If true, allocate memory for shortwave and ice fraction split by ice thickness category.", & + default=.false.) + call get_param(param_file, mdl, "ICE_NCAT", CS%ice_ncat, & + "Number of ice thickness categories in shortwave and ice fraction forcings.", default=0) + CS%Ibfmt = 1. / CS%bot_flux_mix_thickness + + if (CS%use_ice_category_fields .and. (CS%ice_ncat == 0)) & + call MOM_error(FATAL, & + "Can not configure MARBL to use multiple ice categories without ice_ncat present") + + ! (2) Read marbl settings file and call put_setting() + ! (2a) only master task opens file + if (is_root_PE()) then + ! read the marbl_in into buffer + open(unit=marbl_settings_in, file=CS%marbl_settings_file, iostat=read_error) + if (read_error .ne. 0) then + write(log_message, '(A, I0, 2A)') "IO ERROR ", read_error, " opening namelist file : ", & + trim(CS%marbl_settings_file) + call MOM_error(FATAL, log_message) + endif + endif + + ! (2b) master task reads file and broadcasts line-by-line + marbl_in_line = '' + do + ! i. Read next line on master, iostat value out + ! (Exit loop if read is not successful; either read error or end of file) + if (is_root_PE()) read(marbl_settings_in, "(A)", iostat=read_error) marbl_in_line(1) + call broadcast(read_error, root_PE()) + if (read_error .ne. 0) exit + + ! ii. Broadcast line just read in on root PE to all tasks + call broadcast(marbl_in_line, 256, root_PE()) + + ! iii. All tasks call put_setting (TODO: openMP blocks?) + call MARBL_instances%put_setting(marbl_in_line(1)) + enddo + + ! (2c) we should always reach the EOF to capture the entire file... + if (.not. is_iostat_end(read_error)) then + write(log_message, '(3A, I0)') "IO ERROR reading ", trim(CS%marbl_settings_file), ": ", & + read_error + call MOM_error(FATAL, log_message) + else + if (is_root_PE()) then + write(log_message, '(3A)') "Read '", trim(CS%marbl_settings_file), "' until EOF." + call MOM_error(NOTE, log_message) + endif + endif + if (is_root_PE()) close(marbl_settings_in) + + ! (3) Initialize MARBL and configure MOM6 accordingly + + ! (3a) call marbl%init() + ! TODO: We want to strip gcm_delta_z, gcm_zw, and gcm_zt values out of + ! init because MOM updates them every time step / every column + call MARBL_instances%init(gcm_num_levels = nz, gcm_num_PAR_subcols = CS%ice_ncat + 1, & + gcm_num_elements_surface_flux = 1, & ! FIXME: change to number of grid cells on MPI task + gcm_delta_z = GV%sInterface(2:nz+1) - GV%sInterface(1:nz), gcm_zw = GV%sInterface(2:nz+1), & + gcm_zt = GV%sLayer, unit_system_opt = "mks", lgcm_has_global_ops = .false.) ! FIXME: add global ops + ! Regardless of vertical grid, MOM6 will always use GV%ke levels in all columns + MARBL_instances%domain%kmt = GV%ke + if (MARBL_instances%StatusLog%labort_marbl) & + call MARBL_instances%StatusLog%log_error_trace("MARBL_instances%init", & + "configure_MARBL_tracers") + call print_marbl_log(MARBL_instances%StatusLog) + call MARBL_instances%StatusLog%erase() + CS%ntr = size(MARBL_instances%tracer_metadata) + call marbl_instances%get_setting('base_bio_on', CS%base_bio_on) + call marbl_instances%get_setting('abio_dic_on', CS%abio_dic_on) + call marbl_instances%get_setting('ciso_on', CS%ciso_on) + + ! (3b) Read parameters that depend on how MARBL is configured + if (CS%base_bio_on) then + call get_param(param_file, mdl, "CHL_FROM_FILE", chl_from_file, & + "If true, chl_a is read from a file.", default=.true.) + CS%request_Chl_from_MARBL = (.not. chl_from_file) + else + CS%request_Chl_from_MARBL = .false. + endif + + ! (4) Request fields needed by MOM6 + CS%sfo_cnt = 0 + CS%ito_cnt = 0 + CS%flux_co2_ind = -1 + CS%total_Chl_ind = -1 + + if (CS%base_bio_on) then + ! CO2 Flux to the atmosphere + call MARBL_instances%add_output_for_GCM(num_elements=1, field_name="flux_co2", & + output_id=CS%flux_co2_ind, field_source=field_source) + if (trim(field_source) == "surface_flux") then + CS%sfo_cnt = CS%sfo_cnt + 1 + else if (trim(field_source) == "interior_tendency") then + CS%ito_cnt = CS%ito_cnt + 1 + endif + + ! Total 3D Chlorophyll + call MARBL_instances%add_output_for_GCM(num_elements=1, num_levels=nz, field_name="total_Chl", & + output_id=CS%total_Chl_ind, field_source=field_source) + if (trim(field_source) == "surface_flux") then + CS%sfo_cnt = CS%sfo_cnt + 1 + else if (trim(field_source) == "interior_tendency") then + CS%ito_cnt = CS%ito_cnt + 1 + endif + endif + + ! (5) Initialize forcing fields + ! i. store all surface forcing indices + CS%u10_sqr_ind = -1 + CS%sss_ind = -1 + CS%sst_ind = -1 + CS%ifrac_ind = -1 + CS%dust_dep_ind = -1 + CS%fe_dep_ind = -1 + CS%nox_flux_ind = -1 + CS%nhy_flux_ind = -1 + CS%atmpress_ind = -1 + CS%xco2_ind = -1 + CS%xco2_alt_ind = -1 + do m=1,size(MARBL_instances%surface_flux_forcings) + select case (trim(MARBL_instances%surface_flux_forcings(m)%metadata%varname)) + case('u10_sqr') + CS%u10_sqr_ind = m + case('sss') + CS%sss_ind = m + case('sst') + CS%sst_ind = m + case('Ice Fraction') + CS%ifrac_ind = m + case('Dust Flux') + CS%dust_dep_ind = m + case('Iron Flux') + CS%fe_dep_ind = m + case('NOx Flux') + CS%nox_flux_ind = m + case('NHy Flux') + CS%nhy_flux_ind = m + case('Atmospheric Pressure') + CS%atmpress_ind = m + case('xco2') + CS%xco2_ind = m + case('xco2_alt_co2') + CS%xco2_alt_ind = m + case('d14c') + CS%d14c_ind = m + case DEFAULT + write(log_message, "(A,1X,A)") & + trim(MARBL_instances%surface_flux_forcings(m)%metadata%varname), & + 'is not a valid surface flux forcing field name.' + call MOM_error(FATAL, log_message) + end select + enddo + + ! ii. store all interior forcing indices + CS%dustflux_ind = -1 + CS%PAR_col_frac_ind = -1 + CS%surf_shortwave_ind = -1 + CS%potemp_ind = -1 + CS%salinity_ind = -1 + CS%pressure_ind = -1 + CS%fesedflux_ind = -1 + CS%o2_scalef_ind = -1 + CS%remin_scalef_ind = -1 + CS%d14c_ind = -1 + allocate(CS%id_tracer_restoring(CS%ntr)) + allocate(CS%tracer_restoring_varname(CS%ntr), source=' ') ! gfortran 13.2 bug? + ! source = '' does not blank out strings + allocate(CS%tracer_restoring_ind(CS%ntr), source=-1) + allocate(CS%tracer_I_tau_ind(CS%ntr), source=-1) + CS%restore_count = 0 + I_tau_count = 0 + do m=1,size(MARBL_instances%interior_tendency_forcings) + select case (trim(MARBL_instances%interior_tendency_forcings(m)%metadata%varname)) + case('Dust Flux') + CS%dustflux_ind = m + case('PAR Column Fraction') + CS%PAR_col_frac_ind = m + case('Surface Shortwave') + CS%surf_shortwave_ind = m + case('Potential Temperature') + CS%potemp_ind = m + case('Salinity') + CS%salinity_ind = m + case('Pressure') + CS%pressure_ind = m + case('Iron Sediment Flux') + CS%fesedflux_ind = m + case('O2 Consumption Scale Factor') + CS%o2_scalef_ind = m + case('Particulate Remin Scale Factor') + CS%remin_scalef_ind = m + case DEFAULT + ! fi stands for forcing_index + fi = index(MARBL_instances%interior_tendency_forcings(m)%metadata%varname, & + 'Restoring Field') + if (fi > 0) then + CS%restore_count = CS%restore_count + 1 + CS%tracer_restoring_ind(CS%restore_count) = m + CS%tracer_restoring_varname(CS%restore_count) = & + MARBL_instances%interior_tendency_forcings(m)%metadata%varname(1:fi-2) + else + fi = index(MARBL_instances%interior_tendency_forcings(m)%metadata%varname, & + 'Restoring Inverse Timescale') + if (fi > 0) then + I_tau_count = I_tau_count + 1 + CS%tracer_I_tau_ind(I_tau_count) = m + else + write(log_message, "(A,1X,A)") & + trim(MARBL_instances%interior_tendency_forcings(m)%metadata%varname), & + 'is not a valid interior tendency forcing field name.' + call MOM_error(FATAL, log_message) + endif + endif + end select + enddo +end subroutine configure_MARBL_tracers + +!> This subroutine is used to register tracer fields and subroutines +!! to be used with MOM. +function register_MARBL_tracers(HI, GV, US, param_file, CS, tr_Reg, restart_CS, MARBL_computes_chl) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(MARBL_tracers_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and diffusion module. + type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control struct + logical, intent(out) :: MARBL_computes_chl !< If MARBL is computing chlorophyll, MOM + !! may use it to compute SW penetration + +! Local variables +! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MARBL_tracers" ! This module's name. + character(len=256) :: log_message + character(len=200) :: inputdir ! The directory where the input files are. + character(len=48) :: var_name ! The variable's name. + character(len=128) :: desc_name ! The variable's descriptor. + character(len=48) :: units ! The variable's units. + character(len=96) :: file_name ! file name for d14c (looped over three bands) + real, pointer :: tr_ptr(:,:,:) => NULL() ! Pointer to 3D tracer array [CU ~> conc] + ! (ALK tracers use meq m-3 instead of mmol m-3) + integer :: forcing_file_start_year + integer :: forcing_file_end_year + integer :: forcing_file_data_ref_year + integer :: forcing_file_model_ref_year + integer :: forcing_file_forcing_year + logical :: register_MARBL_tracers + ! read_Z_edges() has several mandatory arguments that we do not use given our expectation + ! of how the file being read in was created + logical :: Z_edges_has_edges + logical :: Z_edges_use_missing + real :: Z_edges_missing ! required argument for read_Z_edges() [CU ~> conc] + integer :: isd, ied, jsd, jed, nz, m, k, kbot + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + + if (associated(CS)) then + call MOM_error(WARNING, "register_MARBL_tracers called with an associated control structure.") + return + endif + allocate(CS) + + call configure_MARBL_tracers(GV, US, param_file, CS) + MARBL_computes_chl = CS%base_bio_on + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + ! ** Input directory + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + ! ** Tracer initial conditions + call get_param(param_file, mdl, "MARBL_TRACERS_IC_FILE", CS%IC_file, & + "The file in which the MARBL tracers initial values can be found.", & + default="ecosys_jan_IC_omip_latlon_1x1_180W_c230331.nc") + if (scan(CS%IC_file,'/') == 0) then + ! Add the directory if CS%IC_file is not already a complete path. + CS%IC_file = trim(slasher(inputdir))//trim(CS%IC_file) + call log_param(param_file, mdl, "INPUTDIR/MARBL_TRACERS_IC_FILE", CS%IC_file) + endif + call get_param(param_file, mdl, "MARBL_TRACERS_MAY_REINIT", CS%tracers_may_reinit, & + "If true, tracers may go through the initialization code if they are not found in the "//& + "restart files. Otherwise it is a fatal error if tracers are not found in the "//& + "restart files of a restarted run.", default=.false.) + call get_param(param_file, mdl, "MARBL_TRACERS_INIT_VERTICAL_REMAP_ONLY", CS%ongrid, & + "If true, initial conditions are on the model horizontal grid. Extrapolation over " //& + "missing ocean values is done using an ICE-9 procedure with vertical ALE remapping .", & + default=.false.) + if (CS%base_bio_on) then + ! ** FESEDFLUX + call get_param(param_file, mdl, "MARBL_FESEDFLUX_FILE", CS%fesedflux_file, & + "The file in which the iron sediment flux forcing field can be found.", & + default="fesedflux_total_reduce_oxic_tx0.66v1.c230817.nc") + if (scan(CS%fesedflux_file,'/') == 0) then + ! Add the directory if CS%fesedflux_file is not already a complete path. + CS%fesedflux_file = trim(slasher(inputdir))//trim(CS%fesedflux_file) + call log_param(param_file, mdl, "INPUTDIR/MARBL_TRACERS_FESEDFLUX_FILE", CS%fesedflux_file) + endif + ! ** FEVENTFLUX + call get_param(param_file, mdl, "MARBL_FEVENTFLUX_FILE", CS%feventflux_file, & + "The file in which the iron vent flux forcing field can be found.", & + default="feventflux_5gmol_tx0.66v1.c230817.nc") + if (scan(CS%feventflux_file,'/') == 0) then + ! Add the directory if CS%feventflux_file is not already a complete path. + CS%feventflux_file = trim(slasher(inputdir))//trim(CS%feventflux_file) + call log_param(param_file, mdl, "INPUTDIR/MARBL_TRACERS_FEVENTFLUX_FILE", CS%feventflux_file) + endif + ! ** Scale factor for FESEDFLUX + call get_param(param_file, mdl, "MARBL_FESEDFLUX_SCALE_FACTOR", CS%fesedflux_scale_factor, & + "Conversion factor between FESEDFLUX file units and MARBL units", & + units="umol m-2 d-1 -> mmol m-2 s-1", default=0.001/86400.) + + ! ** River fluxes + call get_param(param_file, mdl, "READ_RIV_FLUXES", CS%read_riv_fluxes, & + "If true, use river fluxes supplied from an input file", default=.true.) + if (CS%read_riv_fluxes) then + call get_param(param_file, mdl, "RIV_FLUX_FILE", CS%riv_flux_dataset%file_name, & + "The file in which the river fluxes can be found", & + default="riv_nut.gnews_gnm.JRA025m_to_tx0.66v1_nnsm_e333r100_190910.20210405.nc") + ! call get_param(param_file, mdl, "RIV_FLUX_OFFSET_YEAR", CS%riv) + if (scan(CS%riv_flux_dataset%file_name,'/') == 0) then + ! CS%riv_flux_dataset%file_name = trim(inputdir) // trim(CS%riv_flux_dataset%file_name) + CS%riv_flux_dataset%file_name = trim(slasher(inputdir)) //& + trim(CS%riv_flux_dataset%file_name) + call log_param(param_file, mdl, "INPUTDIR/RIV_FLUX_FILE", CS%riv_flux_dataset%file_name) + endif + call get_param(param_file, mdl, "RIV_FLUX_L_TIME_VARYING", & + CS%riv_flux_dataset%l_time_varying, & + ".true. for time-varying forcing, .false. for static forcing", default=.false.) + if (CS%riv_flux_dataset%l_time_varying) then + call get_param(param_file, mdl, "RIV_FLUX_FILE_START_YEAR", forcing_file_start_year, & + "First year of data to read in RIV_FLUX_FILE", default=1900) + call get_param(param_file, mdl, "RIV_FLUX_FILE_END_YEAR", forcing_file_end_year, & + "Last year of data to read in RIV_FLUX_FILE", default=2000) + call get_param(param_file, mdl, "RIV_FLUX_FILE_DATA_REF_YEAR", forcing_file_data_ref_year, & + "Align this year in RIV_FLUX_FILE with RIV_FLUX_FILE_MODEL_REF_YEAR in model", & + default=1900) + call get_param(param_file, mdl, "RIV_FLUX_FILE_MODEL_REF_YEAR", & + forcing_file_model_ref_year, & + "Align this year in model with RIV_FLUX_FILE_DATA_REF_YEAR in RIV_FLUX_FILE", & + default=1) + else + call get_param(param_file, mdl, "RIV_FLUX_FORCING_YEAR", forcing_file_forcing_year, & + "Year from RIV_FLUX_FILE to use for forcing", default=1900) + endif + call forcing_timeseries_set_time_type_vars(forcing_file_start_year, forcing_file_end_year, & + forcing_file_data_ref_year, forcing_file_model_ref_year, forcing_file_forcing_year, & + CS%riv_flux_dataset) + endif + endif + + if (CS%abio_dic_on) then + call get_param(param_file, mdl, "D14C_L_TIME_VARYING", CS%d14c_dataset(1)%l_time_varying, & + ".true. for time-varying forcing, .false. for static forcing", default=.false.) + CS%d14c_dataset(2)%l_time_varying = CS%d14c_dataset(1)%l_time_varying + CS%d14c_dataset(3)%l_time_varying = CS%d14c_dataset(1)%l_time_varying + if (CS%d14c_dataset(1)%l_time_varying) then + call get_param(param_file, mdl, "D14C_FILE_START_YEAR", forcing_file_start_year, & + "First year of data to read in D14C_FILE", default=1850) + call get_param(param_file, mdl, "D14C_FILE_END_YEAR", forcing_file_end_year, & + "Last year of data to read in D14C_FILE", default=2015) + call get_param(param_file, mdl, "D14C_FILE_DATA_REF_YEAR", forcing_file_data_ref_year, & + "Align this year in D14C_FILE with D14C_FILE_MODEL_REF_YEAR in model", default=1850) + call get_param(param_file, mdl, "D14C_FILE_MODEL_REF_YEAR", forcing_file_model_ref_year, & + "Align this year in model with D14C_FILE_DATA_REF_YEAR in D14C_FILE", default=1) + else + call get_param(param_file, mdl, "D14C_FORCING_YEAR", forcing_file_forcing_year, & + "Year from D14C_FILE to use for forcing", default=1850) + endif + do m=1,3 + write(var_name, "(A,I0)") "MARBL_D14C_FILE_", m + write(file_name, "(A,I0,A)") "atm_delta_C14_CMIP6_sector", m, & + "_global_1850-2015_yearly_v2.0_c240202.nc" + call get_param(param_file, mdl, var_name, CS%d14c_dataset(m)%file_name, & + "The file in which the d14c forcing field can be found.", default=file_name) + call forcing_timeseries_set_time_type_vars(forcing_file_start_year, forcing_file_end_year, & + forcing_file_data_ref_year, forcing_file_model_ref_year, forcing_file_forcing_year, & + CS%d14c_dataset(m)) + if (scan(CS%d14c_dataset(m)%file_name,'/') == 0) then + ! Add the directory if CS%d14c_dataset%file_name is not already a complete path. + CS%d14c_dataset(m)%file_name = trim(slasher(inputdir))//trim(CS%d14c_dataset(m)%file_name) + call log_param(param_file, mdl, "INPUTDIR/D14C_FILE", CS%d14c_dataset(m)%file_name) + endif + enddo + endif + + call get_param(param_file, mdl, "DIC_SALT_RATIO", CS%DIC_salt_ratio, & + "Ratio to convert salt surface flux to DIC surface flux", units="conc ppt-1", & + default=64.0) + call get_param(param_file, mdl, "ALK_SALT_RATIO", CS%ALK_salt_ratio, & + "Ratio to convert salt surface flux to ALK surface flux", units="conc ppt-1", & + default=70.0) + + ! ** Tracer Restoring + call get_param(param_file, mdl, "MARBL_TRACER_RESTORING_SOURCE", CS%restoring_source, & + "Source of data for restoring MARBL tracers", default="none") + select case(CS%restoring_source) + case("none") + case("file") + call get_param(param_file, mdl, "MARBL_TRACER_RESTORING_FILE", CS%restoring_file, & + "File containing fields to restore MARBL tracers towards") + call get_param(param_file, mdl, "MARBL_TRACER_RESTORING_I_TAU_SOURCE", & + CS%restoring_I_tau_source, "Source of data for inverse timescale for restoring MARBL tracers") + + ! Initialize remapping type + call initialize_remapping(CS%restoring_remapCS, 'PCM', boundary_extrapolation=.false., answer_date=99991231) + + ! Set up array for thicknesses in restoring file + call read_Z_edges(CS%restoring_file, "PO4", CS%restoring_z_edges, CS%restoring_nz, & + Z_edges_has_edges, Z_edges_use_missing, Z_edges_missing, scale=US%m_to_Z, & + missing_scale=1.0) + allocate(CS%restoring_dz(CS%restoring_nz)) + do k=CS%restoring_nz,1,-1 + kbot = k + 1 ! level k is between z(k) and z(k+1) + CS%restoring_dz(k) = (CS%restoring_z_edges(k) - CS%restoring_z_edges(kbot)) * GV%Z_to_H + enddo + + select case(CS%restoring_I_tau_source) + case("file") + call get_param(param_file, mdl, "MARBL_TRACER_RESTORING_I_TAU_FILE", & + CS%restoring_I_tau_file, & + "File containing the inverse timescale for restoring MARBL tracers") + call get_param(param_file, mdl, "MARBL_TRACER_RESTORING_I_TAU_VAR_NAME", & + CS%restoring_I_tau_var_name, & + "Field containing the inverse timescale for restoring MARBL tracers", & + default="I_TAU") + ! Set up array for thicknesses in restoring timescale file + call read_Z_edges(CS%restoring_I_tau_file, CS%restoring_I_tau_var_name, CS%restoring_timescale_z_edges, & + CS%restoring_timescale_nz, Z_edges_has_edges, Z_edges_use_missing, Z_edges_missing, scale=US%m_to_Z, & + missing_scale=1.0) + allocate(CS%restoring_timescale_dz(CS%restoring_timescale_nz)) + do k=CS%restoring_timescale_nz,1,-1 + kbot = k + 1 ! level k is between z(k) and z(k+1) + CS%restoring_timescale_dz(k) = (CS%restoring_timescale_z_edges(k) - & + CS%restoring_timescale_z_edges(kbot)) * GV%Z_to_H + enddo + case DEFAULT + write(log_message, "(3A)") "'", trim(CS%restoring_I_tau_source), & + "' is not a valid option for MARBL_TRACER_RESTORING_I_TAU_SOURCE" + call MOM_error(FATAL, log_message) + end select + case DEFAULT + write(log_message, "(3A)") "'", trim(CS%restoring_source), & + "' is not a valid option for MARBL_TRACER_RESTORING_SOURCE" + call MOM_error(FATAL, log_message) + end select + + allocate(CS%ind_tr(CS%ntr)) + allocate(CS%tr_desc(CS%ntr)) + allocate(CS%tracer_data(CS%ntr)) + + do m=1,CS%ntr + allocate(CS%tracer_data(m)%tr(isd:ied,jsd:jed,nz), source=0.0) + write(var_name(:),'(A)') trim(MARBL_instances%tracer_metadata(m)%short_name) + write(desc_name(:),'(A)') trim(MARBL_instances%tracer_metadata(m)%long_name) + write(units(:),'(A)') trim(MARBL_instances%tracer_metadata(m)%units) + CS%tr_desc(m) = var_desc(trim(var_name), trim(units), trim(desc_name), caller=mdl) + + ! This is needed to force the compiler not to do a copy in the registration + ! calls. Curses on the designers and implementers of Fortran90. + tr_ptr => CS%tracer_data(m)%tr(:,:,:) + call query_vardesc(CS%tr_desc(m), name=var_name, & + caller="register_MARBL_tracers") + ! Register the tracer for horizontal advection, diffusion, and restarts. + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, units = units, & + tr_desc=CS%tr_desc(m), registry_diags=.true., & + restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit, & + Tr_out=CS%tracer_data(m)%tr_ptr) + + ! Set coupled_tracers to be true (hard-coded above) to provide the surface + ! values to the coupler (if any). This is meta-code and its arguments will + ! currently (deliberately) give fatal errors if it is used. + if (CS%coupled_tracers) & + CS%ind_tr(m) = aof_set_coupler_flux(trim(var_name)//'_flux', & + flux_type=' ', implementation=' ', caller="register_MARBL_tracers") + enddo + + ! Set up memory for saved state + call setup_saved_state(MARBL_instances%surface_flux_saved_state, HI, GV, restart_CS, & + CS%tracers_may_reinit, CS%surface_flux_saved_state) + call setup_saved_state(MARBL_instances%interior_tendency_saved_state, HI, GV, restart_CS, & + CS%tracers_may_reinit, CS%interior_tendency_saved_state) + + ! Set up memory for additional output from MARBL and add to restart files + allocate(CS%SFO(SZI_(HI), SZJ_(HI), CS%sfo_cnt), & + CS%ITO(SZI_(HI), SZJ_(HI), SZK_(GV), CS%ito_cnt), & + source=0.0) + + do m=1,CS%sfo_cnt + write(var_name, "(2A)") 'MARBL_SFO_', & + trim(MARBL_instances%surface_flux_output%outputs_for_GCM(m)%short_name) + call register_restart_field(CS%SFO(:,:,m), var_name, .false., restart_CS) + enddo + + do m=1,CS%ito_cnt + write(var_name, "(2A)") 'MARBL_ITO_', & + trim(MARBL_instances%interior_tendency_output%outputs_for_GCM(m)%short_name) + call register_restart_field(CS%ITO(:,:,:,m), var_name, .false., restart_CS) + enddo + + + CS%tr_Reg => tr_Reg + CS%restart_CSp => restart_CS + + call set_riv_flux_tracer_inds(CS) + register_MARBL_tracers = .true. + +end function register_MARBL_tracers + +!> This subroutine initializes the CS%ntr tracer fields in tr(:,:,:,:) +!! and it sets up the tracer output. +subroutine initialize_MARBL_tracers(restart, day, G, GV, US, h, param_file, diag, OBC, CS, sponge_CSp) + logical, intent(in) :: restart !< .true. if the fields have already been + !! read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(diag_ctrl), target, intent(in) :: diag !< Structure used to regulate diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(MARBL_tracers_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_MARBL_tracers. + type(sponge_CS), pointer :: sponge_CSp !< A pointer to the control structure + !! for the sponges, if they are in use. + + ! Local variables + character(len=200) :: log_message + character(len=48) :: name ! A variable's name in a NetCDF file. + character(len=100) :: longname ! The long name of that variable. + character(len=48) :: units ! The units of the variable. + character(len=48) :: flux_units ! The units for age tracer fluxes, either + ! years m3 s-1 or years kg s-1. + character(len=48) :: tracer_name + logical :: fesedflux_has_edges, fesedflux_use_missing + real :: fesedflux_missing ! required argument for read_Z_edges() [CU ~> conc] + integer :: i, j, k, kbot, m, diag_size + + if (.not.associated(CS)) return + if (CS%ntr < 1) return + + CS%diag => diag + + ! Allocate memory for surface tracer fluxes + allocate(CS%STF(SZI_(G), SZJ_(G), CS%ntr), & + CS%RIV_FLUXES(SZI_(G), SZJ_(G), CS%ntr), & + source=0.0) + + ! Allocate memory for d14c forcing + if (CS%abio_dic_on) allocate(CS%d14c(SZI_(G), SZJ_(G))) + + ! Register diagnostics returned from MARBL (surface flux first, then interior tendency) + call register_MARBL_diags(MARBL_instances%surface_flux_diags, diag, day, G, CS%surface_flux_diags) + call register_MARBL_diags(MARBL_instances%interior_tendency_diags, diag, day, G, & + CS%interior_tendency_diags) + + ! Register per-tracer diagnostics computed from MARBL surface flux / interior tendency values + allocate(CS%id_surface_flux_out(CS%ntr)) + allocate(CS%id_surface_flux_from_salt_flux(CS%ntr)) + allocate(CS%interior_tendency_out(CS%ntr)) + allocate(CS%interior_tendency_out_zint(CS%ntr)) + allocate(CS%interior_tendency_out_zint_100m(CS%ntr)) + do m=1,CS%ntr + write(name, "(2A)") "STF_", trim(MARBL_instances%tracer_metadata(m)%short_name) + write(longname, "(2A)") trim(MARBL_instances%tracer_metadata(m)%long_name), " Surface Flux" + write(units, "(2A)") trim(MARBL_instances%tracer_metadata(m)%units), " m/s" + CS%id_surface_flux_out(m) = register_diag_field("ocean_model", trim(name), & + diag%axesT1, & ! T => tracer grid? 1 => no vertical grid + day, trim(longname), trim(units), conversion=US%Z_to_m*US%s_to_T) + + write(name, "(2A)") "STF_SALT_", trim(MARBL_instances%tracer_metadata(m)%short_name) + write(longname, "(2A)") trim(MARBL_instances%tracer_metadata(m)%long_name), " Surface Flux from Salt Flux" + CS%id_surface_flux_from_salt_flux(m) = register_diag_field("ocean_model", trim(name), & + diag%axesT1, & ! T => tracer grid? 1 => no vertical grid + day, trim(longname), trim(units), conversion=US%Z_to_m*US%s_to_T) + + write(name, "(2A)") "J_", trim(MARBL_instances%tracer_metadata(m)%short_name) + write(longname, "(2A)") trim(MARBL_instances%tracer_metadata(m)%long_name), " Source Sink Term" + write(units, "(2A)") trim(MARBL_instances%tracer_metadata(m)%units), "/s" + CS%interior_tendency_out(m)%id = register_diag_field("ocean_model", trim(name), & + diag%axesTL, & ! T=> tracer grid? L => layer center + day, trim(longname), trim(units)) + if (CS%interior_tendency_out(m)%id > 0) & + allocate(CS%interior_tendency_out(m)%field_3d(SZI_(G),SZJ_(G), SZK_(G)), source=0.0) + + write(name, "(2A)") "Jint_", trim(MARBL_instances%tracer_metadata(m)%short_name) + write(longname, "(2A)") trim(MARBL_instances%tracer_metadata(m)%long_name), & + " Source Sink Term Vertical Integral" + write(units, "(2A)") trim(MARBL_instances%tracer_metadata(m)%units), " m/s" + CS%interior_tendency_out_zint(m)%id = register_diag_field("ocean_model", trim(name), & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, trim(longname), trim(units)) + if (CS%interior_tendency_out_zint(m)%id > 0) & + allocate(CS%interior_tendency_out_zint(m)%field_2d(SZI_(G),SZJ_(G)), source=0.0) + + write(name, "(2A)") "Jint_100m_", trim(MARBL_instances%tracer_metadata(m)%short_name) + write(longname, "(2A)") trim(MARBL_instances%tracer_metadata(m)%long_name), & + " Source Sink Term Vertical Integral, 0-100m" + write(units, "(2A)") trim(MARBL_instances%tracer_metadata(m)%units), " m/s" + CS%interior_tendency_out_zint_100m(m)%id = register_diag_field("ocean_model", trim(name), & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, trim(longname), trim(units)) + if (CS%interior_tendency_out_zint_100m(m)%id > 0) & + allocate(CS%interior_tendency_out_zint_100m(m)%field_2d(SZI_(G),SZJ_(G)), source=0.0) + + enddo + + ! Register diagnostics for MOM to report that are not tracer specific + CS%bot_flux_to_tend_id = register_diag_field("ocean_model", "BOT_FLUX_TO_TEND", & + diag%axesTL, & ! T=> tracer grid? L => layer center + day, "Conversion Factor for Bottom Flux -> Tend", "1/m") + + ! Initialize tracers (if they weren't initialized from restart file) + do m=1,CS%ntr + call query_vardesc(CS%tr_desc(m), name=name, caller="initialize_MARBL_tracers") + if ((.not. restart) .or. & + (CS%tracers_may_reinit .and. & + .not. query_initialized(CS%tracer_data(m)%tr(:,:,:), name, CS%restart_CSp))) then + ! TODO: added the ongrid optional argument, but is there a good way to detect if the file is on grid? + call MOM_initialize_tracer_from_Z(h, CS%tracer_data(m)%tr, G, GV, US, param_file, & + CS%IC_file, name, ongrid=CS%ongrid) + do k=1,GV%ke ; do j=G%jsc, G%jec ; do i=G%isc, G%iec + ! Ensure tracer concentrations are at / above minimum value + if (CS%tracer_data(m)%tr(i,j,k) < CS%IC_min) CS%tracer_data(m)%tr(i,j,k) = CS%IC_min + enddo ; enddo ; enddo + endif + enddo + + ! Initialize total chlorophyll to get SW Pen correct (if it wasn't initialized from restart file) + if ((CS%total_Chl_ind > 0) .and. & + ((.not. restart) .or. & + (.not. query_initialized(CS%ITO(:,:,:,CS%total_Chl_ind), "MARBL_ITO_total_Chl", CS%restart_CSp)))) then + ! Three steps per column + do j=G%jsc, G%jec ; do i=G%isc, G%iec + ! (i) Copy initial tracers into MARBL structure + do k=1,GV%ke ; do m=1,CS%ntr + MARBL_instances%tracers(m,k) = max(CS%tracer_data(m)%tr(i,j,k), 0.) + enddo ; enddo + ! (ii) Compute total Chl for the column + call MARBL_instances%compute_totChl() + ! (iii) Copy total Chl from MARBL data-structure into CS%ITO + do k=1,GV%ke + CS%ITO(i,j,k,CS%total_Chl_ind) = & + MARBL_instances%interior_tendency_output%outputs_for_GCM(CS%total_Chl_ind)%forcing_field_1d(1,k) + enddo + enddo ; enddo + endif + + ! Register diagnostics for river fluxes + CS%no3_riv_flux = register_diag_field("ocean_model", "NO3_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Dissolved Inorganic Nitrate Riverine Flux", "mmol/m^3 m/s") + CS%po4_riv_flux = register_diag_field("ocean_model", "PO4_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Dissolved Inorganic Phosphate Riverine Flux", "mmol/m^3 m/s") + CS%don_riv_flux = register_diag_field("ocean_model", "DON_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Dissolved Organic Nitrogen Riverine Flux", "mmol/m^3 m/s") + CS%donr_riv_flux = register_diag_field("ocean_model", "DONR_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Refractory DON Riverine Flux", "mmol/m^3 m/s") + CS%dop_riv_flux = register_diag_field("ocean_model", "DOP_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Dissolved Organic Phosphorus Riverine Flux", "mmol/m^3 m/s") + CS%dopr_riv_flux = register_diag_field("ocean_model", "DOPR_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Refractory DOP Riverine Flux", "mmol/m^3 m/s") + CS%sio3_riv_flux = register_diag_field("ocean_model", "SiO3_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Dissolved Inorganic Silicate Riverine Flux", "mmol/m^3 m/s") + CS%fe_riv_flux = register_diag_field("ocean_model", "Fe_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Dissolved Inorganic Iron Riverine Flux", "mmol/m^3 m/s") + CS%doc_riv_flux = register_diag_field("ocean_model", "DOC_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Dissolved Organic Carbon Riverine Flux", "mmol/m^3 m/s") + CS%docr_riv_flux = register_diag_field("ocean_model", "DOCR_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Refractory DOC Riverine Flux", "mmol/m^3 m/s") + CS%alk_riv_flux = register_diag_field("ocean_model", "ALK_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Alkalinity Riverine Flux", "meq/m^3 m/s") + CS%alk_alt_co2_riv_flux = register_diag_field("ocean_model", "ALK_ALT_CO2_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Alkalinity Riverine Flux, Alternative CO2", "meq/m^3 m/s") + CS%dic_riv_flux = register_diag_field("ocean_model", "DIC_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Dissolved Inorganic Carbon Riverine Flux", "mmol/m^3 m/s") + CS%dic_alt_co2_riv_flux = register_diag_field("ocean_model", "DIC_ALT_CO2_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Dissolved Inorganic Carbon Riverine Flux, Alternative CO2", "mmol/m^3 m/s") + + ! Register diagnostics for d14c forcing + if (CS%abio_dic_on) then + CS%d14c_id = register_diag_field("ocean_model", "D14C_FORCING", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Delta-14C in atmospheric CO2", "per mil, relative to Modern") + endif + + ! Register diagnostics for per-category forcing fields + if (CS%ice_ncat > 0) then + allocate(CS%fracr_cat_id(CS%ice_ncat+1)) + allocate(CS%qsw_cat_id(CS%ice_ncat+1)) + do m=1,CS%ice_ncat+1 + write(name, "(A,I0)") "FRACR_CAT_", m + write(longname, "(A,I0)") "Fraction of area in ice category ", m + units = "fraction" + CS%fracr_cat_id(m) = register_diag_field("ocean_model", trim(name), & + diag%axesT1, & ! T => tracer grid? 1 => no vertical grid + day, trim(longname), trim(units)) + write(name, "(A,I0)") "QSW_CAT_", m + write(longname, "(A,I0)") "Shortwave penetrating through ice category ", m + units = "W m-2" + CS%qsw_cat_id(m) = register_diag_field("ocean_model", trim(name), & + diag%axesT1, & ! T => tracer grid? 1 => no vertical grid + day, trim(longname), trim(units)) + enddo + endif + + if (CS%base_bio_on) then + ! Read initial fesedflux and feventflux fields + ! (1) get vertical dimension + ! -- comes from fesedflux_file, assume same dimension in feventflux + ! (maybe these fields should be combined?) + ! -- note: read_Z_edges treats depth as positive UP => 0 at surface, negative at depth + fesedflux_use_missing = .false. + call read_Z_edges(CS%fesedflux_file, "FESEDFLUXIN", CS%fesedflux_z_edges, CS%fesedflux_nz, & + fesedflux_has_edges, fesedflux_use_missing, fesedflux_missing, scale=US%m_to_Z, & + missing_scale=1.0) + + ! (2) Allocate memory for fesedflux and feventflux + allocate(CS%fesedflux_in(SZI_(G), SZJ_(G), CS%fesedflux_nz)) + allocate(CS%feventflux_in(SZI_(G), SZJ_(G), CS%fesedflux_nz)) + allocate(CS%fesedflux_dz(SZI_(G), SZJ_(G), CS%fesedflux_nz)) + + ! (3) Read data + ! TODO: Add US term to scale + call MOM_read_data(CS%fesedflux_file, "FESEDFLUXIN", CS%fesedflux_in(:,:,:), G%Domain, & + scale=CS%fesedflux_scale_factor) + call MOM_read_data(CS%feventflux_file, "FESEDFLUXIN", CS%feventflux_in(:,:,:), G%Domain, & + scale=CS%fesedflux_scale_factor) + + ! (4) Relocate values that are below ocean bottom to layer that intersects bathymetry + ! Remember, fesedflux_z_edges = 0 at surface and is < 0 below surface + + do k=CS%fesedflux_nz, 1, -1 + kbot = k + 1 ! level k is between z(k) and z(k+1) + do j=G%jsc, G%jec + do i=G%isc, G%iec + if (G%mask2dT(i,j) == 0) cycle + if (G%bathyT(i,j) + CS%fesedflux_z_edges(1) < 1e-8 * US%m_to_Z) then + write(log_message, *) "Current implementation of fesedflux assumes G%bathyT >=", & + " first edge;first edge = ", -CS%fesedflux_z_edges(1), "bathyT = ", G%bathyT(i,j) + call MOM_error(FATAL, log_message) + endif + ! Also figure out layer thickness while we're here + CS%fesedflux_dz(i,j,k) = (CS%fesedflux_z_edges(k) - CS%fesedflux_z_edges(kbot)) * GV%Z_to_H + ! If top interface is at or below ocean bottom, move flux in current layer up one + ! and set thickness of current level to 0 + if (G%bathyT(i,j) + CS%fesedflux_z_edges(k) < 1e-8 * US%m_to_Z) then + CS%fesedflux_in(i,j,k-1) = CS%fesedflux_in(i,j,k-1) + CS%fesedflux_in(i,j,k) + CS%fesedflux_in(i,j,k) = 0. + CS%feventflux_in(i,j,k-1) = CS%feventflux_in(i,j,k-1) + CS%feventflux_in(i,j,k) + CS%feventflux_in(i,j,k) = 0. + CS%fesedflux_dz(i,j,k) = 0. + elseif (G%bathyT(i,j) + CS%fesedflux_z_edges(kbot) < 1e-8 * US%m_to_Z) then + ! Otherwise, if lower interface is below bathymetry move interface to ocean bottom + CS%fesedflux_dz(i,j,k) = (G%bathyT(i,j) + CS%fesedflux_z_edges(k)) * GV%Z_to_H + endif + enddo + enddo + enddo + + ! Initialize external field for river fluxes + if (CS%read_riv_fluxes) then + CS%id_din_riv = init_external_field(CS%riv_flux_dataset%file_name, 'din_riv_flux', & + domain=G%Domain%mpp_domain) + CS%id_don_riv = init_external_field(CS%riv_flux_dataset%file_name, 'don_riv_flux', & + domain=G%Domain%mpp_domain) + CS%id_dip_riv = init_external_field(CS%riv_flux_dataset%file_name, 'dip_riv_flux', & + domain=G%Domain%mpp_domain) + CS%id_dop_riv = init_external_field(CS%riv_flux_dataset%file_name, 'dop_riv_flux', & + domain=G%Domain%mpp_domain) + CS%id_dsi_riv = init_external_field(CS%riv_flux_dataset%file_name, 'dsi_riv_flux', & + domain=G%Domain%mpp_domain) + CS%id_dfe_riv = init_external_field(CS%riv_flux_dataset%file_name, 'dfe_riv_flux', & + domain=G%Domain%mpp_domain) + CS%id_dic_riv = init_external_field(CS%riv_flux_dataset%file_name, 'dic_riv_flux', & + domain=G%Domain%mpp_domain) + CS%id_alk_riv = init_external_field(CS%riv_flux_dataset%file_name, 'alk_riv_flux', & + domain=G%Domain%mpp_domain) + CS%id_doc_riv = init_external_field(CS%riv_flux_dataset%file_name, 'doc_riv_flux', & + domain=G%Domain%mpp_domain) + endif + endif + + if (CS%abio_dic_on) then + ! Initialize external field for d14c forcing + do m=1,3 + CS%id_d14c(m) = init_external_field(CS%d14c_dataset(m)%file_name, "Delta14co2_in_air", & + ignore_axis_atts=.true.) + enddo + endif + + ! Initialize external field for restoring + if (CS%restoring_I_tau_source == "file") then + select case(CS%restoring_source) + case("file") + ! Set up array for reading in raw restoring data + allocate(CS%restoring_in(SZI_(G), SZJ_(G), CS%restoring_nz, CS%restore_count), source=0.) + do m=1,CS%restore_count + CS%id_tracer_restoring(m) = init_external_field(CS%restoring_file, & + trim(CS%tracer_restoring_varname(m)), domain=G%Domain%mpp_domain) + enddo + end select + select case(CS%restoring_I_tau_source) + case("file") + allocate(CS%I_tau(SZI_(G), SZJ_(G), CS%restoring_timescale_nz), source=0.) + call MOM_read_data(CS%restoring_I_tau_file, "RTAU", CS%I_tau(:,:,:), G%Domain) + end select + endif + +end subroutine initialize_MARBL_tracers + +!> This subroutine is used to register tracer fields and subroutines +!! to be used with MOM. +subroutine register_MARBL_diags(MARBL_diags, diag, day, G, id_diags) + + type(marbl_diagnostics_type), intent(in) :: MARBL_diags !< MARBL diagnostics from MARBL_instances + type(time_type), target, intent(in) :: day !< Time of the start of the run. + type(diag_ctrl), target, intent(in) :: diag !< Structure used to regulate diagnostic output. + !integer, allocatable, intent(inout) :: id_diags(:) !< allocatable array storing diagnostic index number + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(temp_marbl_diag), allocatable, intent(inout) :: id_diags(:) !< allocatable array storing diagnostic index + !! number and buffer space for collecting diags + !! from all columns + + integer :: m, diag_size + + diag_size = size(MARBL_diags%diags) + allocate(id_diags(diag_size)) + do m = 1, diag_size + id_diags(m)%id = -1 + if (trim(MARBL_diags%diags(m)%vertical_grid) .eq. "none") then ! 2D field + id_diags(m)%id = register_diag_field("ocean_model", & + trim(MARBL_diags%diags(m)%short_name), & + diag%axesT1, & ! T => tracer grid? 1 => no vertical grid + day, & + trim(MARBL_diags%diags(m)%long_name), & + trim(MARBL_diags%diags(m)%units)) + if (id_diags(m)%id > 0) allocate(id_diags(m)%field_2d(SZI_(G),SZJ_(G)), source=0.0) + else ! 3D field + ! TODO: MARBL should provide v_extensive through MARBL_diags + ! (for now, FESEDFLUX is the only one that should be true) + ! Also, known issue where passing v_extensive=.false. isn't + ! treated the same as not passing v_extensive + if (trim(MARBL_diags%diags(m)%short_name).eq."FESEDFLUX") then + id_diags(m)%id = register_diag_field("ocean_model", & + trim(MARBL_diags%diags(m)%short_name), & + diag%axesTL, & ! T=> tracer grid? L => layer center + day, & + trim(MARBL_diags%diags(m)%long_name), & + trim(MARBL_diags%diags(m)%units), & + v_extensive=.true.) + else + id_diags(m)%id = register_diag_field("ocean_model", & + trim(MARBL_diags%diags(m)%short_name), & + diag%axesTL, & ! T=> tracer grid? L => layer center + day, & + trim(MARBL_diags%diags(m)%long_name), & + trim(MARBL_diags%diags(m)%units)) + endif + if (id_diags(m)%id > 0) allocate(id_diags(m)%field_3d(SZI_(G),SZJ_(G), SZK_(G)), source=0.0) + endif + enddo + +end subroutine register_MARBL_diags + +!> This subroutine allocates memory for saved state fields and registers them in the restart files +subroutine setup_saved_state(MARBL_saved_state, HI, GV, restart_CS, tracers_may_reinit, & + local_saved_state) + + type(marbl_saved_state_type), intent(in) :: MARBL_saved_state !< MARBL saved state from + !! MARBL_instances + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(MOM_restart_CS), pointer, intent(in) :: restart_CS !< control structure to add saved state + !! to restarts + logical, intent(in) :: tracers_may_reinit !< used to determine mandatory + !! flag in restart + type(saved_state_for_MARBL_type), allocatable, intent(inout) :: local_saved_state(:) !< allocatable array for local + !! saved state + + integer :: num_fields, m + character(len=200) :: log_message, varname + + num_fields = MARBL_saved_state%saved_state_cnt + allocate(local_saved_state(num_fields)) + + do m=1,num_fields + write(varname, "(2A)") "MARBL_", trim(MARBL_saved_state%state(m)%short_name) + select case (MARBL_saved_state%state(m)%rank) + case (2) + allocate(local_saved_state(m)%field_2d(SZI_(HI),SZJ_(HI)), source=0.0) + call register_restart_field(local_saved_state(m)%field_2d, varname, & + .not.tracers_may_reinit, restart_CS) + case (3) + if (trim(MARBL_saved_state%state(m)%vertical_grid).eq."layer_avg") then + allocate(local_saved_state(m)%field_3d(SZI_(HI),SZJ_(HI), SZK_(GV)), source=0.0) + call register_restart_field(local_saved_state(m)%field_3d, varname, & + .not.tracers_may_reinit, restart_CS) + else + write(log_message, "(3A, I0, A)") "'", trim(MARBL_saved_state%state(m)%vertical_grid), & + "' is an invalid vertical grid for saved state (ind = ", m, ")" + call MOM_error(FATAL, log_message) + endif + case DEFAULT + write(log_message, "(I0, A, I0, A)") MARBL_saved_state%state(m)%rank, & + " is an invalid rank for saved state (ind = ", m, ")" + call MOM_error(FATAL, log_message) + end select + local_saved_state(m)%short_name = trim(MARBL_saved_state%state(m)%short_name) + write(local_saved_state(m)%file_varname, "(2A)") "MARBL_", trim(local_saved_state(m)%short_name) + local_saved_state(m)%units = trim(MARBL_saved_state%state(m)%units) + enddo + +end subroutine setup_saved_state + +!> This subroutine applies diapycnal diffusion and any other column +!! tracer physics or chemistry to the tracers from this file. +subroutine MARBL_tracers_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, tv, & + KPP_CSp, nonLocalTrans, evap_CFL_limit, minimum_forcing_depth) + + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_new !< Layer thickness after entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added [H ~> m or kg m-2]. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(MARBL_tracers_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_MARBL_tracers. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + type(KPP_CS), optional, pointer :: KPP_CSp !< KPP control structure + real, optional, intent(in) :: nonLocalTrans(:,:,:) !< Non-local transport [1] + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep [1] + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied [m] + + ! Local variables + character(len=256) :: log_message + real, dimension(SZI_(G),SZJ_(G)) :: net_salt_rate ! Surface salt flux into the ocean + ! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1]. + real, dimension(SZI_(G),SZJ_(G)) :: flux_from_salt_flux ! Surface tracer flux from salt flux + ! [conc Z T-1 ~> conc m s-1]. + real, dimension(SZI_(G),SZJ_(G)) :: ref_mask ! Mask for 2D MARBL diags using ref_depth [1] + real, dimension(SZI_(G),SZJ_(G)) :: riv_flux_loc ! Local copy of CS%RIV_FLUXES*dt [conc H ~> mmol m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: bot_flux_to_tend ! Conversion factor for bottom tlux -> tend + ! [Z-1 ~> m-1] + real :: cum_bftt_dz ! sum of bot_flux_to_tend * dz from the bottom layer to current layer [1] + real, dimension(0:GV%ke) :: zi ! z-coordinate interface depth [Z ~> m] + real, dimension(GV%ke) :: zc ! z-coordinate layer center depth [Z ~> m] + real, dimension(GV%ke) :: dz ! z-coordinate cell thickness [H ~> m] + integer :: i, j, k, is, ie, js, je, nz, m + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.associated(CS)) return + + ! (1) Compute surface fluxes + ! FIXME: MARBL can handle computing surface fluxes for all columns simultaneously + ! I was just thinking going column-by-column at first might be easier + do j=js,je + do i=is,ie + ! i. only want ocean points in this loop + if (G%mask2dT(i,j) == 0) cycle + + ! ii. Load proper column data + ! * surface flux forcings + ! These fields are getting the correct data + ! TODO: if top layer is vanishly thin, do we actually want (e.g.) top 5m average temp / salinity? + ! How does MOM pass SST and SSS to GFDL coupler? (look in core.F90?) + if (CS%sss_ind > 0) & + MARBL_instances%surface_flux_forcings(CS%sss_ind)%field_0d(1) = tv%S(i,j,1) * US%S_to_ppt + if (CS%sst_ind > 0) & + MARBL_instances%surface_flux_forcings(CS%sst_ind)%field_0d(1) = tv%T(i,j,1) * US%C_to_degC + if (CS%ifrac_ind > 0) & + MARBL_instances%surface_flux_forcings(CS%ifrac_ind)%field_0d(1) = fluxes%ice_fraction(i,j) + + ! MARBL wants u10_sqr in (m/s)^2 + if (CS%u10_sqr_ind > 0) & + MARBL_instances%surface_flux_forcings(CS%u10_sqr_ind)%field_0d(1) = fluxes%u10_sqr(i,j) * & + ((US%L_T_to_m_s)**2) + + ! mct_driver/ocn_cap_methods:93 -- ice_ocean_boundary%p(i,j) comes from coupler + ! We may need a new ice_ocean_boundary%p_atm because %p includes ice in GFDL driver + if (CS%atmpress_ind > 0) then + if (associated(fluxes%p_surf_full)) then + MARBL_instances%surface_flux_forcings(CS%atmpress_ind)%field_0d(1) = & + fluxes%p_surf_full(i,j) * ((US%R_to_kg_m3 * (US%L_T_to_m_s**2)) * atm_per_Pa) + else + ! hardcode value of 1 atm (can't figure out how to get this from solo_driver) + MARBL_instances%surface_flux_forcings(CS%atmpress_ind)%field_0d(1) = 1. + endif + endif + + ! These are okay, but need option to come in from coupler + if (CS%xco2_ind > 0) & + MARBL_instances%surface_flux_forcings(CS%xco2_ind)%field_0d(1) = fluxes%atm_co2(i,j) + if (CS%xco2_alt_ind > 0) & + MARBL_instances%surface_flux_forcings(CS%xco2_alt_ind)%field_0d(1) = fluxes%atm_alt_co2(i,j) + + ! These are okay, but need option to read in from file + if (CS%dust_dep_ind > 0) & + MARBL_instances%surface_flux_forcings(CS%dust_dep_ind)%field_0d(1) = & + fluxes%dust_flux(i,j) * US%RZ_T_to_kg_m2s + + if (CS%fe_dep_ind > 0) & + MARBL_instances%surface_flux_forcings(CS%fe_dep_ind)%field_0d(1) = & + fluxes%iron_flux(i,j) * (US%Z_to_m * US%s_to_T) + + ! MARBL wants ndep in (mmol/m^2/s) + if (CS%nox_flux_ind > 0) & + MARBL_instances%surface_flux_forcings(CS%nox_flux_ind)%field_0d(1) = fluxes%noy_dep(i,j) * & + (US%Z_to_m * US%s_to_T) + if (CS%nhy_flux_ind > 0) & + MARBL_instances%surface_flux_forcings(CS%nhy_flux_ind)%field_0d(1) = fluxes%nhx_dep(i,j) * & + (US%Z_to_m * US%s_to_T) + + if (CS%d14c_ind > 0) & + MARBL_instances%surface_flux_forcings(CS%d14c_ind)%field_0d(1) = CS%d14c(i,j) + + ! * tracers at surface + ! TODO: average over some shallow depth (e.g. 5m) + do m=1,CS%ntr + MARBL_instances%tracers_at_surface(1,m) = CS%tracer_data(m)%tr(i,j,1) + enddo + + ! * surface flux saved state + do m=1,size(MARBL_instances%surface_flux_saved_state%state) + ! (currently only 2D fields are saved from surface_flux_compute()) + MARBL_instances%surface_flux_saved_state%state(m)%field_2d(1) = & + CS%surface_flux_saved_state(m)%field_2d(i,j) + enddo + + ! iii. Compute surface fluxes in MARBL + call MARBL_instances%surface_flux_compute() + if (MARBL_instances%StatusLog%labort_marbl) then + call MARBL_instances%StatusLog%log_error_trace("MARBL_instances%surface_flux_compute()", & + "MARBL_tracers_column_physics") + endif + call print_marbl_log(MARBL_instances%StatusLog) + call MARBL_instances%StatusLog%erase() + + ! iv. Copy output that MOM6 needs to hold on to + ! * saved state + do m=1,size(MARBL_instances%surface_flux_saved_state%state) + CS%surface_flux_saved_state(m)%field_2d(i,j) = & + MARBL_instances%surface_flux_saved_state%state(m)%field_2d(1) + enddo + + ! * diagnostics + do m=1,size(MARBL_instances%surface_flux_diags%diags) + ! All diags are 2D coming from surface + if (CS%surface_flux_diags(m)%id > 0) & + CS%surface_flux_diags(m)%field_2d(i,j) = & + real(MARBL_instances%surface_flux_diags%diags(m)%field_2d(1)) + enddo + + ! * Surface tracer flux + CS%STF(i,j,:) = MARBL_instances%surface_fluxes(1,:) * (US%m_to_Z * US%T_to_s) + + ! * Surface flux output + do m=1,CS%sfo_cnt + CS%SFO(i,j,m) = MARBL_instances%surface_flux_output%outputs_for_GCM(m)%forcing_field_0d(1) + enddo + + enddo + enddo + + if (associated(fluxes%salt_flux)) then + ! convert salt flux to tracer fluxes and add to STF + do j=js,je ; do i=is,ie + net_salt_rate(i,j) = (1000.0*US%ppt_to_S * fluxes%salt_flux(i,j)) * GV%RZ_to_H + enddo ; enddo + + ! DIC related tracers + do j=js,je ; do i=is,ie + flux_from_salt_flux(i,j) = (CS%DIC_salt_ratio * GV%H_to_Z) * net_salt_rate(i,j) + enddo ; enddo + m = CS%tracer_inds%dic_ind + if (m > 0) then + do j=js,je ; do i=is,ie + CS%STF(i,j,m) = CS%STF(i,j,m) + flux_from_salt_flux(i,j) + enddo ; enddo + if (CS%id_surface_flux_from_salt_flux(m) > 0) & + call post_data(CS%id_surface_flux_from_salt_flux(m), flux_from_salt_flux, CS%diag) + endif + m = CS%tracer_inds%dic_alt_co2_ind + if (m > 0) then + do j=js,je ; do i=is,ie + CS%STF(i,j,m) = CS%STF(i,j,m) + flux_from_salt_flux(i,j) + enddo ; enddo + if (CS%id_surface_flux_from_salt_flux(m) > 0) & + call post_data(CS%id_surface_flux_from_salt_flux(m), flux_from_salt_flux, CS%diag) + endif + m = CS%tracer_inds%abio_dic_ind + if (m > 0) then + do j=js,je ; do i=is,ie + CS%STF(i,j,m) = CS%STF(i,j,m) + flux_from_salt_flux(i,j) + enddo ; enddo + if (CS%id_surface_flux_from_salt_flux(m) > 0) & + call post_data(CS%id_surface_flux_from_salt_flux(m), flux_from_salt_flux, CS%diag) + endif + m = CS%tracer_inds%abio_di14c_ind + if (m > 0) then + do j=js,je ; do i=is,ie + CS%STF(i,j,m) = CS%STF(i,j,m) + flux_from_salt_flux(i,j) + enddo ; enddo + if (CS%id_surface_flux_from_salt_flux(m) > 0) & + call post_data(CS%id_surface_flux_from_salt_flux(m), flux_from_salt_flux, CS%diag) + endif + + ! ALK related tracers + do j=js,je ; do i=is,ie + flux_from_salt_flux(i,j) = (CS%ALK_salt_ratio * GV%H_to_Z) * net_salt_rate(i,j) + enddo ; enddo + m = CS%tracer_inds%alk_ind + if (m > 0) then + do j=js,je ; do i=is,ie + CS%STF(i,j,m) = CS%STF(i,j,m) + flux_from_salt_flux(i,j) + enddo ; enddo + if (CS%id_surface_flux_from_salt_flux(m) > 0) & + call post_data(CS%id_surface_flux_from_salt_flux(m), flux_from_salt_flux, CS%diag) + endif + m = CS%tracer_inds%alk_alt_co2_ind + if (m > 0) then + do j=js,je ; do i=is,ie + CS%STF(i,j,m) = CS%STF(i,j,m) + flux_from_salt_flux(i,j) + enddo ; enddo + if (CS%id_surface_flux_from_salt_flux(m) > 0) & + call post_data(CS%id_surface_flux_from_salt_flux(m), flux_from_salt_flux, CS%diag) + endif + endif + + if (CS%debug) then + do m=1,CS%ntr + call hchksum(CS%STF(:,:,m), & + trim(MARBL_instances%tracer_metadata(m)%short_name)//" sfc_flux", G%HI, & + unscale=US%Z_to_m*US%s_to_T) + enddo + endif + + ! (2) Post surface fluxes and their diagnostics (currently all 2D) + do m=1,CS%ntr + if (CS%id_surface_flux_out(m) > 0) & + call post_data(CS%id_surface_flux_out(m), CS%STF(:,:,m), CS%diag) + enddo + do m=1,size(CS%surface_flux_diags) + if (CS%surface_flux_diags(m)%id > 0) & + call post_data(CS%surface_flux_diags(m)%id, CS%surface_flux_diags(m)%field_2d(:,:), CS%diag) + enddo + + ! (3) Apply surface fluxes via vertical diffusion + ! Compute KPP nonlocal term if necessary + if (present(KPP_CSp)) then + if (associated(KPP_CSp) .and. present(nonLocalTrans)) then + do m=1,CS%ntr + call KPP_NonLocalTransport(KPP_CSp, G, GV, h_old, nonLocalTrans, CS%STF(:,:,m), dt, & + CS%diag, CS%tracer_data(m)%tr_ptr, CS%tracer_data(m)%tr(:,:,:), & + flux_scale=GV%Z_to_H) + enddo + endif + if (CS%debug) then + do m=1,CS%ntr + call hchksum(CS%tracer_data(m)%tr(:,:,m), & + trim(MARBL_instances%tracer_metadata(m)%short_name)//' post KPP', G%HI) + enddo + endif + endif + + if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then + do m=1,CS%ntr + do k=1,nz ;do j=js,je ; do i=is,ie + h_work(i,j,k) = h_old(i,j,k) + enddo ; enddo ; enddo + ! CS%RIV_FLUXES is conc m/s, in_flux_optional expects time-integrated flux (conc H) + do j=js,je ; do i=is,ie + riv_flux_loc(i,j) = (CS%RIV_FLUXES(i,j,m) * (dt*US%T_to_s)) * GV%m_to_H + enddo ; enddo + if (CS%debug) & + call hchksum(riv_flux_loc(:,:), & + trim(MARBL_instances%tracer_metadata(m)%short_name)//' riv flux', G%HI, unscale=GV%H_to_m) + call applyTracerBoundaryFluxesInOut(G, GV, CS%tracer_data(m)%tr(:,:,:) , dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth, in_flux_optional=riv_flux_loc) + call tracer_vertdiff(h_work, ea, eb, dt, CS%tracer_data(m)%tr(:,:,:), G, GV, & + sfc_flux=GV%Rho0 * CS%STF(:,:,m)) + enddo + else + do m=1,CS%ntr + call tracer_vertdiff(h_old, ea, eb, dt, CS%tracer_data(m)%tr(:,:,:), G, GV, & + sfc_flux=GV%Rho0 * CS%STF(:,:,m)) + enddo + endif + + if (CS%debug) then + do m=1,CS%ntr + call hchksum(CS%tracer_data(m)%tr(:,:,m), & + trim(MARBL_instances%tracer_metadata(m)%short_name)//' post tracer_vertdiff', G%HI) + enddo + endif + + ! (4) Compute interior tendencies + + bot_flux_to_tend(:, :, :) = 0. + do j=js,je + do i=is,ie + ! i. only want ocean points in this loop + if (G%mask2dT(i,j) == 0) cycle + + ! ii. Set up vertical domain and bot_flux_to_tend + ! Calculate depth of interface by building up thicknesses from the bottom (top interface is always 0) + ! MARBL wants this to be positive-down + zi(GV%ke) = G%bathyT(i,j) + MARBL_instances%bot_flux_to_tend(:) = 0. + cum_bftt_dz = 0. + do k = GV%ke, 1, -1 + ! TODO: if we move this above vertical mixing, use h_old + dz(k) = h_new(i,j,k) ! cell thickness + zc(k) = zi(k) - 0.5 * (dz(k)*GV%H_to_Z) + zi(k-1) = zi(k) - (dz(k)*GV%H_to_Z) + if (G%bathyT(i,j) - zi(k-1) <= CS%bot_flux_mix_thickness) then + MARBL_instances%bot_flux_to_tend(k) = US%m_to_Z * CS%Ibfmt + cum_bftt_dz = cum_bftt_dz + MARBL_instances%bot_flux_to_tend(k) * (GV%H_to_m * dz(k)) + elseif (G%bathyT(i,j) - zi(k) < CS%bot_flux_mix_thickness) then + ! MARBL_instances%bot_flux_to_tend(k) = (1. - (G%bathyT(i,j) - zi(k)) * CS%Ibfmt) / dz(k) + MARBL_instances%bot_flux_to_tend(k) = (1. - cum_bftt_dz) / (GV%H_to_m * dz(k)) + endif + enddo + if (G%bathyT(i,j) - zi(0) < CS%bot_flux_mix_thickness) & + MARBL_instances%bot_flux_to_tend(:) = MARBL_instances%bot_flux_to_tend(:) * & + CS%bot_flux_mix_thickness / (G%bathyT(i,j) - zi(0)) + if (CS%bot_flux_to_tend_id > 0) & + bot_flux_to_tend(i, j, :) = MARBL_instances%bot_flux_to_tend(:) + + ! zw(1:nz) is bottom cell depth so no element of zw = 0, it is assumed to be top layer depth + MARBL_instances%domain%zw(:) = US%Z_to_m * zi(1:GV%ke) + MARBL_instances%domain%zt(:) = US%Z_to_m * zc(:) + MARBL_instances%domain%delta_z(:) = GV%H_to_m * dz(:) + + ! iii. Load proper column data + ! * Forcing Fields + ! These fields are getting the correct data + if (CS%potemp_ind > 0) & + MARBL_instances%interior_tendency_forcings(CS%potemp_ind)%field_1d(1,:) = tv%T(i,j,:) * US%C_to_degC + if (CS%salinity_ind > 0) & + MARBL_instances%interior_tendency_forcings(CS%salinity_ind)%field_1d(1,:) = tv%S(i,j,:) * US%S_to_ppt + + ! This are okay, but need option to read in from file + ! (Same as dust_dep_ind for surface_flux_forcings) + if (CS%dustflux_ind > 0) & + MARBL_instances%interior_tendency_forcings(CS%dustflux_ind)%field_0d(1) = & + fluxes%dust_flux(i,j) * US%RZ_T_to_kg_m2s + + ! TODO: Support PAR (currently just using single subcolumn) + ! (Look for Pen_sw_bnd?) + if (CS%PAR_col_frac_ind > 0) then + ! second index is num_subcols, not depth + !MARBL_instances%interior_tendency_forcings(CS%PAR_col_frac_ind)%field_1d(1,:) = fluxes%fracr_cat(i,j,:) + if (CS%use_ice_category_fields) then + MARBL_instances%interior_tendency_forcings(CS%PAR_col_frac_ind)%field_1d(1,:) = & + fluxes%fracr_cat(i,j,:) + else + MARBL_instances%interior_tendency_forcings(CS%PAR_col_frac_ind)%field_1d(1,1) = 1. + endif + endif + + if (CS%surf_shortwave_ind > 0) then + ! second index is num_subcols, not depth + if (CS%use_ice_category_fields) then + MARBL_instances%interior_tendency_forcings(CS%surf_shortwave_ind)%field_1d(1,:) = & + fluxes%qsw_cat(i,j,:) * US%QRZ_T_to_W_m2 + else + MARBL_instances%interior_tendency_forcings(CS%surf_shortwave_ind)%field_1d(1,1) = & + fluxes%sw(i,j) * US%QRZ_T_to_W_m2 + endif + endif + ! Tracer restoring + do m=1,CS%restore_count + MARBL_instances%interior_tendency_forcings(CS%tracer_restoring_ind(m))%field_1d(1,:) = 0. + call remapping_core_h(CS%restoring_remapCS, CS%restoring_nz, CS%restoring_dz(:), & + CS%restoring_in(i,j,:,m), GV%ke, dz(:), & + MARBL_instances%interior_tendency_forcings(CS%tracer_restoring_ind(m))%field_1d(1,:)) + if (m==1) then + call remapping_core_h(CS%restoring_remapCS, CS%restoring_timescale_nz, & + CS%restoring_timescale_dz(:), CS%I_tau(i,j,:), GV%ke, dz(:), & + MARBL_instances%interior_tendency_forcings(CS%tracer_I_tau_ind(m))%field_1d(1,:)) + else + MARBL_instances%interior_tendency_forcings(CS%tracer_I_tau_ind(m))%field_1d(1,:) = & + MARBL_instances%interior_tendency_forcings(CS%tracer_I_tau_ind(1))%field_1d(1,:) + endif + enddo + + ! TODO: In POP, pressure comes from a function in state_mod.F90; I don't see a similar function here + ! This formulation is from Levitus 1994, and I think it belongs in MOM_EOS.F90? + ! Converts depth [m] -> pressure [bars] + ! NOTE: Andrew recommends using GV%H_to_Pa + if (CS%pressure_ind > 0) & + MARBL_instances%interior_tendency_forcings(CS%pressure_ind)%field_1d(1,:) = & + (0.0598088 * (exp(-0.025*US%Z_to_m * zc(:)) - 1.)) + & + (0.100766 * US%Z_to_m * zc(:)) + (2.28405e-7*((US%Z_to_m * zc(:))**2)) + + if (CS%fesedflux_ind > 0) then + MARBL_instances%interior_tendency_forcings(CS%fesedflux_ind)%field_1d(1,:) = 0. + call reintegrate_column(CS%fesedflux_nz, & + CS%fesedflux_dz(i,j,:) * (sum(dz(:) * GV%H_to_Z) / G%bathyT(i,j)), & + CS%fesedflux_in(i,j,:) + CS%feventflux_in(i,j,:), GV%ke, dz(:), & + MARBL_instances%interior_tendency_forcings(CS%fesedflux_ind)%field_1d(1,:)) + endif + + ! TODO: add ability to read these fields from file + ! also, add constant values to CS + if (CS%o2_scalef_ind > 0) & + MARBL_instances%interior_tendency_forcings(CS%o2_scalef_ind)%field_1d(1,:) = 1. + if (CS%remin_scalef_ind > 0) & + MARBL_instances%interior_tendency_forcings(CS%remin_scalef_ind)%field_1d(1,:) = 1. + + ! * Column Tracers + do m=1,CS%ntr + MARBL_instances%tracers(m, :) = CS%tracer_data(m)%tr(i,j,:) + enddo + + ! * interior tendency saved state + ! (currently only 3D fields are saved from interior_tendency_compute()) + do m=1,size(MARBL_instances%interior_tendency_saved_state%state) + MARBL_instances%interior_tendency_saved_state%state(m)%field_3d(:,1) = & + CS%interior_tendency_saved_state(m)%field_3d(i,j,:) + enddo + + ! iv. Compute interior tendencies in MARBL + call MARBL_instances%interior_tendency_compute() + if (MARBL_instances%StatusLog%labort_marbl) then + call MARBL_instances%StatusLog%log_error_trace(& + "MARBL_instances%interior_tendency_compute()", "MARBL_tracers_column_physics") + endif + call print_marbl_log(MARBL_instances%StatusLog, G, i, j) + call MARBL_instances%StatusLog%erase() + + ! v. Apply tendencies immediately + ! First pass - Euler step; if stability issues, we can do something different (subcycle?) + do m=1,CS%ntr + CS%tracer_data(m)%tr(i,j,:) = CS%tracer_data(m)%tr(i,j,:) + (dt * US%T_to_s) * & + MARBL_instances%interior_tendencies(m,:) + enddo + + ! vi. Copy output that MOM6 needs to hold on to + ! * saved state + do m=1,size(MARBL_instances%interior_tendency_saved_state%state) + CS%interior_tendency_saved_state(m)%field_3d(i,j,:) = & + MARBL_instances%interior_tendency_saved_state%state(m)%field_3d(:,1) + enddo + + ! * diagnostics + do m=1,size(MARBL_instances%interior_tendency_diags%diags) + if (CS%interior_tendency_diags(m)%id > 0) then + if (allocated(CS%interior_tendency_diags(m)%field_2d)) then + ! Only copy values if ref_depth < bathyT + if (G%bathyT(i,j) > real(MARBL_instances%interior_tendency_diags%diags(m)%ref_depth)) then + CS%interior_tendency_diags(m)%field_2d(i,j) = & + real(MARBL_instances%interior_tendency_diags%diags(m)%field_2d(1)) + endif + else ! not a 2D diagnostic + CS%interior_tendency_diags(m)%field_3d(i,j,:) = & + real(MARBL_instances%interior_tendency_diags%diags(m)%field_3d(:,1)) + endif + endif + enddo + + ! * tendency values themselves (and vertical integrals of them) + do m=1,CS%ntr + if (allocated(CS%interior_tendency_out(m)%field_3d)) & + CS%interior_tendency_out(m)%field_3d(i,j,:) = MARBL_instances%interior_tendencies(m,:) + + if (allocated(CS%interior_tendency_out_zint(m)%field_2d)) & + CS%interior_tendency_out_zint(m)%field_2d(i,j) = (sum(dz(:) * & + MARBL_instances%interior_tendencies(m,:))) + + if (allocated(CS%interior_tendency_out_zint_100m(m)%field_2d)) then + CS%interior_tendency_out_zint_100m(m)%field_2d(i,j) = 0. + do k=1,GV%ke + if (zi(k) < US%m_to_Z * 100.) then + CS%interior_tendency_out_zint_100m(m)%field_2d(i,j) = & + CS%interior_tendency_out_zint_100m(m)%field_2d(i,j) + GV%H_to_m * dz(k) * & + MARBL_instances%interior_tendencies(m,k) + elseif (zi(k-1) < US%m_to_Z * 100.) then + CS%interior_tendency_out_zint_100m(m)%field_2d(i,j) = & + CS%interior_tendency_out_zint_100m(m)%field_2d(i,j) + GV%H_to_m * dz(k) * & + ((US%m_to_Z * 100. - zi(k-1)) / (zi(k) - zi(k-1))) * & + MARBL_instances%interior_tendencies(m,k) + else + exit + endif + enddo + endif + enddo + + ! * Interior tendency output + do m=1,CS%ito_cnt + CS%ITO(i,j,:,m) = & + MARBL_instances%interior_tendency_output%outputs_for_GCM(m)%forcing_field_1d(1,:) + enddo + + enddo + enddo + + if (CS%debug) then + do m=1,CS%ntr + call hchksum(CS%tracer_data(m)%tr(:,:,m), & + trim(MARBL_instances%tracer_metadata(m)%short_name)//' post source-sink', G%HI) + enddo + endif + + ! (5) Post diagnostics from our buffer + ! i. Interior tendency diagnostics (mix of 2D and 3D) + ! ii. Interior tendencies themselves + ! iii. Forcing fields + if (CS%bot_flux_to_tend_id > 0) & + call post_data(CS%bot_flux_to_tend_id, bot_flux_to_tend(:, :, :), CS%diag) + + do m=1,size(CS%interior_tendency_diags) + if (CS%interior_tendency_diags(m)%id > 0) then + if (allocated(CS%interior_tendency_diags(m)%field_2d)) then + if (real(MARBL_instances%interior_tendency_diags%diags(m)%ref_depth) == 0.) then + call post_data(CS%interior_tendency_diags(m)%id, & + CS%interior_tendency_diags(m)%field_2d(:,:), CS%diag) + else ! non-zero ref-depth + ref_mask(:, :) = 0. + do j=js,je ; do i=is,ie + if (G%bathyT(i,j) > real(MARBL_instances%interior_tendency_diags%diags(m)%ref_depth)) & + ref_mask(i,j) = 1. + enddo ; enddo + call post_data(CS%interior_tendency_diags(m)%id, & + CS%interior_tendency_diags(m)%field_2d(:,:), CS%diag, mask=ref_mask(:,:)) + endif + elseif (allocated(CS%interior_tendency_diags(m)%field_3d)) then + call post_data(CS%interior_tendency_diags(m)%id, & + CS%interior_tendency_diags(m)%field_3d(:,:,:), CS%diag) + else + write(log_message, "(A, I0, A, I0, A)") "Diagnostic number ", m, " post id ", & + CS%interior_tendency_diags(m)%id," did not allocate 2D or 3D array" + call MOM_error(FATAL, log_message) + endif + endif + enddo + + do m=1,CS%ntr + if (allocated(CS%interior_tendency_out(m)%field_3d)) & + call post_data(CS%interior_tendency_out(m)%id, & + CS%interior_tendency_out(m)%field_3d(:,:,:), CS%diag) + if (allocated(CS%interior_tendency_out_zint(m)%field_2d)) & + call post_data(CS%interior_tendency_out_zint(m)%id, & + CS%interior_tendency_out_zint(m)%field_2d(:,:), CS%diag) + if (allocated(CS%interior_tendency_out_zint_100m(m)%field_2d)) & + call post_data(CS%interior_tendency_out_zint_100m(m)%id, & + CS%interior_tendency_out_zint_100m(m)%field_2d(:,:), CS%diag) + enddo + + if (CS%ice_ncat > 0) then + do m=1,CS%ice_ncat+1 + if (CS%fracr_cat_id(m) > 0) & + call post_data(CS%fracr_cat_id(m), fluxes%fracr_cat(:,:,m), CS%diag) + if (CS%qsw_cat_id(m) > 0) & + call post_data(CS%qsw_cat_id(m), fluxes%qsw_cat(:,:,m), CS%diag) + enddo + endif + + +end subroutine MARBL_tracers_column_physics + +!> This subroutine reads time-varying forcing from files +subroutine MARBL_tracers_set_forcing(day_start, G, CS) + + type(time_type), intent(in) :: day_start !< Start time of the fluxes. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(MARBL_tracers_CS), pointer :: CS !< The control structure returned by a + + real, parameter :: DONriv_refract = 0.1 ! Fraction of DON river nutrients in refractory pools [1] + real, parameter :: DOCriv_refract = 0.2 ! Fraction of DOC river nutrients in refractory pools [1] + real, parameter :: DOPriv_refract = 0.025 ! Fraction of DOP river nutrients in refractory pools [1] + + real, dimension(SZI_(G),SZJ_(G)) :: riv_flux_in !< The field read in from forcing file with time dimension + !! [mmol m-2 s-1] + type(time_type) :: Time_forcing !< For reading river flux fields, we use a modified version of Time + integer :: i, j, k, is, ie, js, je, m + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + ! Abiotic DIC forcing + if (CS%abio_dic_on) then + ! Read d14c bands + do m=1,3 + Time_forcing = map_model_time_to_forcing_time(day_start, CS%d14c_dataset(m)) + call time_interp_external(CS%id_d14c(m),Time_forcing,CS%d14c_bands(m)) + enddo + + ! Set d14c according to the bands + do j=js,je ; do i=is,ie + if (G%geoLatT(i,j) > 30.) then + CS%d14c(i,j) = CS%d14c_bands(1) + elseif (G%geoLatT(i,j) > -30.) then + CS%d14c(i,j) = CS%d14c_bands(2) + else + CS%d14c(i,j) = CS%d14c_bands(3) + endif + enddo ; enddo + endif + + ! River fluxes + if (CS%read_riv_fluxes) then + CS%RIV_FLUXES(:,:,:) = 0. + Time_forcing = map_model_time_to_forcing_time(day_start, CS%riv_flux_dataset) + + ! DIN river flux affects NO3, ALK, and ALK_ALT_CO2 + call time_interp_external(CS%id_din_riv,Time_forcing,riv_flux_in) + + if (CS%tracer_inds%no3_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%no3_ind) = G%mask2dT(i,j) * riv_flux_in(i,j) + enddo ; enddo + endif + if (CS%tracer_inds%alk_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%alk_ind) = CS%RIV_FLUXES(i,j,CS%tracer_inds%alk_ind) - & + G%mask2dT(i,j) *riv_flux_in(i,j) + enddo ; enddo + endif + if (CS%tracer_inds%alk_alt_co2_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%alk_alt_co2_ind) = & + CS%RIV_FLUXES(i,j,CS%tracer_inds%alk_alt_co2_ind) - G%mask2dT(i,j) *riv_flux_in(i,j) + enddo ; enddo + endif + + call time_interp_external(CS%id_dip_riv,Time_forcing,riv_flux_in) + if (CS%tracer_inds%po4_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%po4_ind) = G%mask2dT(i,j) * riv_flux_in(i,j) + enddo ; enddo + endif + + call time_interp_external(CS%id_don_riv,Time_forcing,riv_flux_in) + if (CS%tracer_inds%don_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%don_ind) = G%mask2dT(i,j) * (1. - DONriv_refract) * & + riv_flux_in(i,j) + enddo ; enddo + endif + if (CS%tracer_inds%donr_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%donr_ind) = G%mask2dT(i,j) * DONriv_refract * & + riv_flux_in(i,j) + enddo ; enddo + endif + + call time_interp_external(CS%id_dop_riv,Time_forcing,riv_flux_in) + if (CS%tracer_inds%dop_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%dop_ind) = G%mask2dT(i,j) * (1. - DOPriv_refract) * & + riv_flux_in(i,j) + enddo ; enddo + endif + if (CS%tracer_inds%dopr_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%dopr_ind) = G%mask2dT(i,j) * DOPriv_refract * & + riv_flux_in(i,j) + enddo ; enddo + endif + + call time_interp_external(CS%id_dsi_riv,Time_forcing,riv_flux_in) + if (CS%tracer_inds%sio3_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%sio3_ind) = G%mask2dT(i,j) * riv_flux_in(i,j) + enddo ; enddo + endif + + call time_interp_external(CS%id_dfe_riv,Time_forcing,riv_flux_in) + if (CS%tracer_inds%fe_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%fe_ind) = G%mask2dT(i,j) * riv_flux_in(i,j) + enddo ; enddo + endif + + call time_interp_external(CS%id_dic_riv,Time_forcing,riv_flux_in) + if (CS%tracer_inds%dic_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%dic_ind) = G%mask2dT(i,j) * riv_flux_in(i,j) + enddo ; enddo + endif + if (CS%tracer_inds%dic_alt_co2_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%dic_alt_co2_ind) = G%mask2dT(i,j) * riv_flux_in(i,j) + enddo ; enddo + endif + + call time_interp_external(CS%id_alk_riv,Time_forcing,riv_flux_in) + if (CS%tracer_inds%alk_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%alk_ind) = CS%RIV_FLUXES(i,j,CS%tracer_inds%alk_ind) + & + G%mask2dT(i,j) *riv_flux_in(i,j) + enddo ; enddo + endif + if (CS%tracer_inds%alk_alt_co2_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%alk_alt_co2_ind) = & + CS%RIV_FLUXES(i,j,CS%tracer_inds%alk_alt_co2_ind) + G%mask2dT(i,j) * riv_flux_in(i,j) + enddo ; enddo + endif + + call time_interp_external(CS%id_doc_riv,Time_forcing,riv_flux_in) + if (CS%tracer_inds%doc_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%doc_ind) = G%mask2dT(i,j) * (1. - DOCriv_refract) * & + riv_flux_in(i,j) + enddo ; enddo + endif + if (CS%tracer_inds%docr_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%docr_ind) = G%mask2dT(i,j) * DOCriv_refract * & + riv_flux_in(i,j) + enddo ; enddo + endif + endif + + ! Tracer restoring + do m=1,CS%restore_count + call time_interp_external(CS%id_tracer_restoring(m),day_start,CS%restoring_in(:,:,:,m)) + do k=1,CS%restoring_nz ; do j=js,je ; do i=is,ie + CS%restoring_in(i,j,k,m) = G%mask2dT(i,j) * CS%restoring_in(i,j,k,m) + enddo ; enddo ; enddo + enddo + + ! Post Forcing to Diagnostics + if (CS%read_riv_fluxes) then + if (CS%no3_riv_flux > 0 .and. CS%tracer_inds%no3_ind > 0) & + call post_data(CS%no3_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%no3_ind), CS%diag) + if (CS%po4_riv_flux > 0 .and. CS%tracer_inds%po4_ind > 0) & + call post_data(CS%po4_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%po4_ind), CS%diag) + if (CS%don_riv_flux > 0 .and. CS%tracer_inds%don_ind > 0) & + call post_data(CS%don_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%don_ind), CS%diag) + if (CS%donr_riv_flux > 0 .and. CS%tracer_inds%donr_ind > 0) & + call post_data(CS%donr_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%donr_ind), CS%diag) + if (CS%dop_riv_flux > 0 .and. CS%tracer_inds%dop_ind > 0) & + call post_data(CS%dop_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%dop_ind), CS%diag) + if (CS%dopr_riv_flux > 0 .and. CS%tracer_inds%dopr_ind > 0) & + call post_data(CS%dopr_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%dopr_ind), CS%diag) + if (CS%sio3_riv_flux > 0 .and. CS%tracer_inds%sio3_ind > 0) & + call post_data(CS%sio3_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%sio3_ind), CS%diag) + if (CS%fe_riv_flux > 0 .and. CS%tracer_inds%fe_ind > 0) & + call post_data(CS%fe_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%fe_ind), CS%diag) + if (CS%doc_riv_flux > 0 .and. CS%tracer_inds%doc_ind > 0) & + call post_data(CS%doc_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%doc_ind), CS%diag) + if (CS%docr_riv_flux > 0 .and. CS%tracer_inds%docr_ind > 0) & + call post_data(CS%docr_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%docr_ind), CS%diag) + if (CS%alk_riv_flux > 0 .and. CS%tracer_inds%alk_ind > 0) & + call post_data(CS%alk_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%alk_ind), CS%diag) + if (CS%alk_alt_co2_riv_flux > 0 .and. CS%tracer_inds%alk_alt_co2_ind > 0) & + call post_data(CS%alk_alt_co2_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%alk_alt_co2_ind), & + CS%diag) + if (CS%dic_riv_flux > 0 .and. CS%tracer_inds%dic_ind > 0) & + call post_data(CS%dic_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%dic_ind), CS%diag) + if (CS%dic_alt_co2_riv_flux > 0 .and. CS%tracer_inds%dic_alt_co2_ind > 0) & + call post_data(CS%dic_alt_co2_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%dic_alt_co2_ind), & + CS%diag) + endif + if (CS%abio_dic_on) then + if (CS%d14c_id > 0) & + call post_data(CS%d14c_id, CS%d14c, CS%diag) + endif + +end subroutine MARBL_tracers_set_forcing + +!> This function calculates the mass-weighted integral of all tracer stocks, +!! returning the number of stocks it has calculated. If the stock_index +!! is present, only the stock corresponding to that coded index is returned. +function MARBL_tracers_stock(h, stocks, G, GV, CS, names, units, stock_index) + real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(EFP_type), dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of + !! each tracer, in kg times concentration units + !! [kg conc]. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(MARBL_tracers_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_MARBL_tracers. + character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< the units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< the coded index of a specific stock + !! being sought. + integer :: MARBL_tracers_stock !< Return value: the number of stocks + !! calculated here. + + ! Local variables + integer :: i, j, k, is, ie, js, je, nz, m + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + MARBL_tracers_stock = 0 + if (.not.associated(CS)) return + if (CS%ntr < 1) return + + if (present(stock_index)) then ; if (stock_index > 0) then + ! Check whether this stock is available from this routine. + + ! No stocks from this routine are being checked yet. Return 0. + return + endif ; endif + + do m=1,CS%ntr + call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="MARBL_tracers_stock") + units(m) = trim(units(m))//" kg" + stocks(m) = global_mass_int_EFP(h, G, GV, CS%tracer_data(m)%tr(:,:,:), on_PE_only=.true.) + enddo + MARBL_tracers_stock = CS%ntr + +end function MARBL_tracers_stock + +!> This subroutine extracts the surface fields from this tracer package that +!! are to be shared with the atmosphere in coupled configurations. +subroutine MARBL_tracers_surface_state(sfc_state, G, US, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(MARBL_tracers_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_MARBL_tracers. + + ! Local variables + integer :: i, j, is, ie, js, je + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + if (.not.associated(CS)) return + + if (allocated(sfc_state%fco2)) then + do j=js,je ; do i=is,ie + ! 44e-6 converts mmol/m^2/s (positive down) to kg CO2/m^2/s (positive down) + sfc_state%fco2(i,j) = US%kg_m2s_to_RZ_T * (44.0e-6 * CS%SFO(i,j,CS%flux_co2_ind)) + enddo ; enddo + endif + +end subroutine MARBL_tracers_surface_state + +!> Copy the requested interior tendency output field into an array. +subroutine MARBL_tracers_get(name, G, GV, array, CS) + + character(len=*), intent(in) :: name !< Name of requested tracer. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: array !< Array filled by this routine. + type(MARBL_tracers_CS), pointer :: CS !< Pointer to the control structure for this module. + + character(len=128), parameter :: sub_name = 'MARBL_tracers_get' + character(len=128) :: log_message + + array(:,:,:) = 0.0 + select case(trim(name)) + case ('Chl') + array(:,:,:) = CS%ITO(:,:,:,CS%total_Chl_ind) + case DEFAULT + write(log_message, "(3A)") "'", trim(name), & + "' is not a valid interior tendency output field name" + call MOM_error(FATAL, log_message) + end select + +end subroutine MARBL_tracers_get + +!> Clean up any allocated memory after the run. +subroutine MARBL_tracers_end(CS) + type(MARBL_tracers_CS), pointer, intent(inout) :: CS !< The control structure returned by a previous + !! call to register_MARBL_tracers. + + integer :: m + + call print_marbl_log(MARBL_instances%StatusLog) + call MARBL_instances%StatusLog%erase() + call MARBL_instances%shutdown() + ! TODO: print MARBL timers to stdout as well + + if (associated(CS)) then + if (allocated(CS%tracer_data)) then + do m=1,CS%ntr + if (associated(CS%tracer_data(m)%tr)) deallocate(CS%tracer_data(m)%tr) + enddo + deallocate(CS%tracer_data) + endif + if (allocated(CS%ind_tr)) deallocate(CS%ind_tr) + if (allocated(CS%id_surface_flux_out)) deallocate(CS%id_surface_flux_out) + if (allocated(CS%interior_tendency_out)) deallocate(CS%interior_tendency_out) + if (allocated(CS%interior_tendency_out_zint)) deallocate(CS%interior_tendency_out_zint) + if (allocated(CS%interior_tendency_out_zint_100m)) & + deallocate(CS%interior_tendency_out_zint_100m) + if (allocated(CS%fracr_cat_id)) deallocate(CS%fracr_cat_id) + if (allocated(CS%qsw_cat_id)) deallocate(CS%qsw_cat_id) + if (allocated(CS%STF)) deallocate(CS%STF) + if (allocated(CS%RIV_FLUXES)) deallocate(CS%RIV_FLUXES) + if (associated(CS%SFO)) then + deallocate(CS%SFO) + nullify(CS%SFO) + endif + if (associated(CS%ITO)) then + deallocate(CS%ITO) + nullify(CS%ITO) + endif + if (allocated(CS%tracer_restoring_ind)) deallocate(CS%tracer_restoring_ind) + if (allocated(CS%tracer_I_tau_ind)) deallocate(CS%tracer_I_tau_ind) + if (allocated(CS%fesedflux_in)) deallocate(CS%fesedflux_in) + if (allocated(CS%feventflux_in)) deallocate(CS%feventflux_in) + if (allocated(CS%I_tau)) deallocate(CS%I_tau) + deallocate(CS) + endif +end subroutine MARBL_tracers_end + +subroutine set_riv_flux_tracer_inds(CS) + + type(MARBL_tracers_CS), pointer, intent(inout) :: CS !< The MARBL tracers control structure + + character(len=256) :: log_message + character(len=48) :: name ! A variable's name in a NetCDF file. + integer :: m + + ! Initialize tracers from file (unless they were initialized by restart file) + ! Also save indices of tracers that have river fluxes + CS%tracer_inds%no3_ind = 0 + CS%tracer_inds%po4_ind = 0 + CS%tracer_inds%don_ind = 0 + CS%tracer_inds%donr_ind = 0 + CS%tracer_inds%dop_ind = 0 + CS%tracer_inds%dopr_ind = 0 + CS%tracer_inds%sio3_ind = 0 + CS%tracer_inds%fe_ind = 0 + CS%tracer_inds%doc_ind = 0 + CS%tracer_inds%docr_ind = 0 + CS%tracer_inds%alk_ind = 0 + CS%tracer_inds%alk_alt_co2_ind = 0 + CS%tracer_inds%dic_ind = 0 + CS%tracer_inds%dic_alt_co2_ind = 0 + CS%tracer_inds%abio_dic_ind = 0 + CS%tracer_inds%abio_di14c_ind = 0 + do m=1,CS%ntr + name = MARBL_instances%tracer_metadata(m)%short_name + if (trim(name) == "NO3") then + CS%tracer_inds%no3_ind = m + elseif (trim(name) == "PO4") then + CS%tracer_inds%po4_ind = m + elseif (trim(name) == "DON") then + CS%tracer_inds%don_ind = m + elseif (trim(name) == "DONr") then + CS%tracer_inds%donr_ind = m + elseif (trim(name) == "DOP") then + CS%tracer_inds%dop_ind = m + elseif (trim(name) == "DOPr") then + CS%tracer_inds%dopr_ind = m + elseif (trim(name) == "SiO3") then + CS%tracer_inds%sio3_ind = m + elseif (trim(name) == "Fe") then + CS%tracer_inds%fe_ind = m + elseif (trim(name) == "DOC") then + CS%tracer_inds%doc_ind = m + elseif (trim(name) == "DOCr") then + CS%tracer_inds%docr_ind = m + elseif (trim(name) == "ALK") then + CS%tracer_inds%alk_ind = m + elseif (trim(name) == "ALK_ALT_CO2") then + CS%tracer_inds%alk_alt_co2_ind = m + elseif (trim(name) == "DIC") then + CS%tracer_inds%dic_ind = m + elseif (trim(name) == "DIC_ALT_CO2") then + CS%tracer_inds%dic_alt_co2_ind = m + elseif (trim(name) == "ABIO_DIC") then + CS%tracer_inds%abio_dic_ind = m + elseif (trim(name) == "ABIO_DI14C") then + CS%tracer_inds%abio_di14c_ind = m + endif + enddo + + ! Log indices for each tracer to ensure we set them all correctly + write(log_message, "(A,I0)") "NO3 index: ", CS%tracer_inds%no3_ind + call MOM_error(NOTE, log_message) + write(log_message, "(A,I0)") "PO4 index: ", CS%tracer_inds%po4_ind + call MOM_error(NOTE, log_message) + write(log_message, "(A,I0)") "DON index: ", CS%tracer_inds%don_ind + call MOM_error(NOTE, log_message) + write(log_message, "(A,I0)") "DONr index: ", CS%tracer_inds%donr_ind + call MOM_error(NOTE, log_message) + write(log_message, "(A,I0)") "DOP index: ", CS%tracer_inds%dop_ind + call MOM_error(NOTE, log_message) + write(log_message, "(A,I0)") "DOPr index: ", CS%tracer_inds%dopr_ind + call MOM_error(NOTE, log_message) + write(log_message, "(A,I0)") "SiO3 index: ", CS%tracer_inds%sio3_ind + call MOM_error(NOTE, log_message) + write(log_message, "(A,I0)") "Fe index: ", CS%tracer_inds%fe_ind + call MOM_error(NOTE, log_message) + write(log_message, "(A,I0)") "DOC index: ", CS%tracer_inds%doc_ind + call MOM_error(NOTE, log_message) + write(log_message, "(A,I0)") "DOCr index: ", CS%tracer_inds%docr_ind + call MOM_error(NOTE, log_message) + write(log_message, "(A,I0)") "ALK index: ", CS%tracer_inds%alk_ind + call MOM_error(NOTE, log_message) + write(log_message, "(A,I0)") "ALK_ALT_CO2 index: ", CS%tracer_inds%alk_alt_co2_ind + call MOM_error(NOTE, log_message) + write(log_message, "(A,I0)") "DIC index: ", CS%tracer_inds%dic_ind + call MOM_error(NOTE, log_message) + write(log_message, "(A,I0)") "DIC_ALT_CO2 index: ", CS%tracer_inds%dic_alt_co2_ind + call MOM_error(NOTE, log_message) + +end subroutine set_riv_flux_tracer_inds + +! TODO: some log messages come from a specific grid point, and this routine +! needs to include the location in the preamble +!> This subroutine writes the contents of the MARBL log using MOM_error(NOTE, ...). +subroutine print_marbl_log(log_to_print, G, i, j) + + use marbl_logging, only : marbl_status_log_entry_type + use marbl_logging, only : marbl_log_type + use MOM_coms, only : PE_here + + class(marbl_log_type), intent(in) :: log_to_print !< MARBL log to include in MOM6 logfile + type(ocean_grid_type), optional, intent(in) :: G !< The ocean's grid structure + integer, optional, intent(in) :: i !< i of (i,j) index of column providing the log + integer, optional, intent(in) :: j !< j of (i,j) index of column providing the log + + character(len=*), parameter :: subname = 'MARBL_tracers:print_marbl_log' + character(len=256) :: message_prefix, message_location, log_message + type(marbl_status_log_entry_type), pointer :: tmp + integer :: msg_lev, elem_old + + ! elem_old is used to keep track of whether all messages are coming from the same point + elem_old = -1 + write(message_prefix, "(A,I0,A)") '(Task ', PE_here(), ')' + + tmp => log_to_print%FullLog + do while (associated(tmp)) + ! 1) Do I need to write this message? Yes, if all tasks should write this + ! or if I am master_task + if ((.not. tmp%lonly_master_writes) .or. is_root_PE()) then + ! 2) Print message location? (only if ElementInd changed and is positive; requires G) + if ((present(G)) .and. (tmp%ElementInd .ne. elem_old)) then + if (tmp%ElementInd .gt. 0) then + if (present(i) .and. present(j)) then + write(message_location, "(A,F8.3,A,F7.3,A,I0,A,I0,A,I0)") & + 'Message from (lon, lat) (', G%geoLonT(i,j), ', ', G%geoLatT(i,j), & + '), which is global (i,j) (', i + G%HI%idg_offset, ', ', j + G%HI%jdg_offset, & + '). Level: ', tmp%ElementInd + else + write(message_location, "(A)") "Grid cell responsible for message is unknown" + endif ! i,j present + ! master task does not need prefix + if (is_root_PE()) then + write(log_message, "(A)") trim(message_location) + msg_lev = NOTE + else + write(log_message, "(A,1X,A)") trim(message_prefix), trim(message_location) + msg_lev = WARNING + endif ! print message prefix? + call MOM_error(msg_lev, log_message, all_print=.true.) + endif ! ElementInd > 0 + elem_old = tmp%ElementInd + endif ! ElementInd /= elem_old + + ! 3) Write message from the log + ! master task does not need prefix + if (is_root_PE()) then + write(log_message, "(A)") trim(tmp%LogMessage) + msg_lev = NOTE + else + write(log_message, "(A,1X,A)") trim(message_prefix), trim(tmp%LogMessage) + msg_lev = WARNING + endif ! print message prefix? + call MOM_error(msg_lev, log_message, all_print=.true.) + endif ! write the message? + tmp => tmp%next + enddo + + if (log_to_print%labort_marbl) then + call MOM_error(WARNING, 'ERROR reported from MARBL library', all_print=.true.) + call MOM_error(FATAL, 'Stopping in ' // subname) + endif + +end subroutine print_marbl_log + +!> \namespace MARBL_tracers +!! +!! This module contains the code that is needed to provide +!! the MARBL BGC tracer library with necessary forcings and +!! apply the resulting surface fluxes and tendencies to the +!! requested tracers. + +end module MARBL_tracers diff --git a/src/tracer/MOM_CFC_cap.F90 b/src/tracer/MOM_CFC_cap.F90 index 7296f1d469..2ce801c63a 100644 --- a/src/tracer/MOM_CFC_cap.F90 +++ b/src/tracer/MOM_CFC_cap.F90 @@ -1,26 +1,34 @@ -!> Simulates CFCs using atmospheric pressure, wind speed and sea ice cover +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + + !> Simulates CFCs using atmospheric pressure, wind speed and sea ice cover !! provided via cap (only NUOPC cap is implemented so far). module MOM_CFC_cap -! This file is part of MOM6. See LICENSE.md for the license. - +use MOM_coms, only : EFP_type +use MOM_debugging, only : hchksum use MOM_diag_mediator, only : diag_ctrl, register_diag_field, post_data use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing use MOM_hor_index, only : hor_index_type use MOM_grid, only : ocean_grid_type +use MOM_CVMix_KPP, only : KPP_NonLocalTransport, KPP_CS use MOM_io, only : file_exists, MOM_read_data, slasher use MOM_io, only : vardesc, var_desc, query_vardesc, stdout +use MOM_tracer_registry, only : tracer_type use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : query_initialized, MOM_restart_CS -use MOM_time_manager, only : time_type -use time_interp_external_mod, only : init_external_field, time_interp_external -use MOM_tracer_registry, only : register_tracer, tracer_registry_type +use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP +use MOM_time_manager, only : time_type, increment_date +use MOM_interpolate, only : external_field, init_external_field, time_interp_external +use MOM_tracer_registry, only : register_tracer +use MOM_tracer_types, only : tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface +use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -28,40 +36,46 @@ module MOM_CFC_cap #include public register_CFC_cap, initialize_CFC_cap, CFC_cap_unit_tests -public CFC_cap_column_physics, CFC_cap_surface_state, CFC_cap_fluxes +public CFC_cap_column_physics, CFC_cap_set_forcing public CFC_cap_stock, CFC_cap_end integer, parameter :: NTR = 2 !< the number of tracers in this module. +!> Contains the concentration array, surface flux, a pointer to Tr in Tr_reg, +!! and some metadata for a single CFC tracer +type, private :: CFC_tracer_data + type(vardesc) :: desc !< A set of metadata for the tracer + real :: IC_val = 0.0 !< The initial value assigned to the tracer [mol kg-1]. + real :: land_val = -1.0 !< The value of the tracer used where land is + !! masked out [mol kg-1]. + character(len=32) :: name !< Tracer variable name + integer :: id_cmor = -1 !< Diagnostic id + integer :: id_sfc_flux = -1 !< Surface flux id + real, pointer, dimension(:,:,:) :: conc !< The tracer concentration [mol kg-1]. + real, pointer, dimension(:,:) :: sfc_flux !< Surface flux [CU R Z T-1 ~> mol m-2 s-1] + type(tracer_type), pointer :: tr_ptr !< pointer to tracer inside Tr_reg +end type CFC_tracer_data + !> The control structure for the CFC_cap tracer package type, public :: CFC_cap_CS ; private + logical :: debug !< If true, write verbose checksums for debugging purposes. character(len=200) :: IC_file !< The file in which the CFC initial values can !! be found, or an empty string for internal initilaization. logical :: Z_IC_file !< If true, the IC_file is in Z-space. The default is false. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the MOM6 tracer registry - real, pointer, dimension(:,:,:) :: & - CFC11 => NULL(), & !< The CFC11 concentration [mol kg-1]. - CFC12 => NULL() !< The CFC12 concentration [mol kg-1]. - ! In the following variables a suffix of _11 refers to CFC11 and _12 to CFC12. - real :: CFC11_IC_val = 0.0 !< The initial value assigned to CFC11 [mol kg-1]. - real :: CFC12_IC_val = 0.0 !< The initial value assigned to CFC12 [mol kg-1]. - real :: CFC11_land_val = -1.0 !< The value of CFC11 used where land is masked out [mol kg-1]. - real :: CFC12_land_val = -1.0 !< The value of CFC12 used where land is masked out [mol kg-1]. logical :: tracers_may_reinit !< If true, tracers may be reset via the initialization code !! if they are not found in the restart files. - character(len=16) :: CFC11_name !< CFC11 variable name - character(len=16) :: CFC12_name !< CFC12 variable name type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate !! the timing of diagnostic output. type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< Model restart control structure - ! The following vardesc types contain a package of metadata about each tracer. - type(vardesc) :: CFC11_desc !< A set of metadata for the CFC11 tracer - type(vardesc) :: CFC12_desc !< A set of metadata for the CFC12 tracer - !>@{ Diagnostic IDs - integer :: id_cfc11_cmor = -1, id_cfc12_cmor = -1 - !>@} + type(CFC_tracer_data), dimension(NTR) :: CFC_data !< per-tracer parameters / metadata + integer :: CFC_BC_year_offset = 0 !< offset to add to model time to get time value used in CFC_BC_file + type(external_field) :: cfc11_atm_nh_handle !< Handle for time-interpolated CFC11 atm NH + type(external_field) :: cfc11_atm_sh_handle !< Handle for time-interpolated CFC11 atm SH + type(external_field) :: cfc12_atm_nh_handle !< Handle for time-interpolated CFC12 atm NH + type(external_field) :: cfc12_atm_sh_handle !< Handle for time-interpolated CFC12 atm SH end type CFC_cap_CS contains @@ -80,34 +94,41 @@ function register_CFC_cap(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Local variables character(len=40) :: mdl = "MOM_CFC_cap" ! This module's name. - character(len=200) :: inputdir ! The directory where NetCDF input files are. ! This include declares and sets the variable "version". -#include "version_variable.h" - real, dimension(:,:,:), pointer :: tr_ptr => NULL() - character(len=200) :: dummy ! Dummy variable to store params that need to be logged here. +# include "version_variable.h" + character(len=200) :: inputdir ! The directory where NetCDF input files are. + real, dimension(:,:,:), pointer :: tr_ptr => NULL() ! A pointer to a CFC tracer [mol kg-1] + character(len=200) :: CFC_BC_file ! filename with cfc11 and cfc12 data + character(len=30) :: CFC_BC_var_name ! varname of field in CFC_BC_file + character :: m2char logical :: register_CFC_cap integer :: isd, ied, jsd, jed, nz, m + integer :: CFC_BC_data_year ! specific year in CFC BC data calendar + integer :: CFC_BC_model_year ! model year corresponding to CFC_BC_data_year isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke if (associated(CS)) then - call MOM_error(WARNING, "register_CFC_cap called with an "// & - "associated control structure.") - return + call MOM_error(FATAL, "register_CFC_cap called with an "// & + "associated control structure.") endif allocate(CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) call get_param(param_file, mdl, "CFC_IC_FILE", CS%IC_file, & "The file in which the CFC initial values can be "//& "found, or an empty string for internal initialization.", & default=" ") - if ((len_trim(CS%IC_file) > 0) .and. (scan(CS%IC_file,'/') == 0)) then + if ((len_trim(CS%IC_file) > 0) .and. (scan(CS%IC_file, '/') == 0)) then ! Add the directory if CS%IC_file is not already a complete path. call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") CS%IC_file = trim(slasher(inputdir))//trim(CS%IC_file) - call log_param(param_file, mdl, "INPUTDIR/CFC_IC_FILE", CS%IC_file) + call log_param(param_file, mdl, "INPUTDIR/CFC_IC_FILE", CS%IC_file, & + "full path of CFC_IC_FILE") endif call get_param(param_file, mdl, "CFC_IC_FILE_IS_Z", CS%Z_IC_file, & "If true, CFC_IC_FILE is in depth space, not layer space", & @@ -117,55 +138,78 @@ function register_CFC_cap(HI, GV, param_file, CS, tr_Reg, restart_CS) "if they are not found in the restart files. Otherwise "//& "it is a fatal error if tracers are not found in the "//& "restart files of a restarted run.", default=.false.) - call get_param(param_file, mdl, "CFC11_IC_VAL", CS%CFC11_IC_val, & - "Value that CFC_11 is set to when it is not read from a file.", & - units="mol kg-1", default=0.0) - call get_param(param_file, mdl, "CFC12_IC_VAL", CS%CFC12_IC_val, & - "Value that CFC_12 is set to when it is not read from a file.", & - units="mol kg-1", default=0.0) + do m=1,NTR + write(m2char, "(I1)") m + call get_param(param_file, mdl, "CFC1"//m2char//"_IC_VAL", CS%CFC_data(m)%IC_val, & + "Value that CFC_1"//m2char//" is set to when it is not read from a file.", & + units="mol kg-1", default=0.0) + enddo ! the following params are not used in this module. Instead, they are used in ! the cap but are logged here to keep all the CFC cap params together. - call get_param(param_file, mdl, "CFC_BC_FILE", dummy, & - "The file in which the CFC-11 and CFC-12 atm concentrations can be "//& - "found (units must be parts per trillion), or an empty string for "//& - "internal BC generation (TODO).", default=" ") - if ((len_trim(dummy) > 0) .and. (scan(dummy,'/') == 0)) then - ! Add the directory if dummy is not already a complete path. - call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") - dummy = trim(slasher(inputdir))//trim(dummy) - call log_param(param_file, mdl, "INPUTDIR/CFC_IC_FILE", dummy) + call get_param(param_file, mdl, "CFC_BC_FILE", CFC_BC_file, & + "The file in which the CFC-11 and CFC-12 atm concentrations can be "//& + "found (units must be parts per trillion).", default=" ") + if (len_trim(CFC_BC_file) == 0) then + call MOM_error(FATAL, "CFC_BC_FILE must be specified if USE_CFC_CAP=.true.") endif - if (len_trim(dummy) > 0) then - call get_param(param_file, mdl, "CFC11_VARIABLE", dummy, & - "The name of the variable representing CFC-11 in "//& - "CFC_BC_FILE.", default="CFC_11") - call get_param(param_file, mdl, "CFC12_VARIABLE", dummy, & - "The name of the variable representing CFC-12 in "//& - "CFC_BC_FILE.", default="CFC_12") + if (scan(CFC_BC_file, '/') == 0) then + ! Add the directory if CFC_BC_file is not already a complete path. + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + CFC_BC_file = trim(slasher(inputdir))//trim(CFC_BC_file) + call log_param(param_file, mdl, "INPUTDIR/CFC_BC_FILE", CFC_BC_file, & + "full path of CFC_BC_FILE") endif + call get_param(param_file, mdl, "CFC_BC_DATA_YEAR", CFC_BC_data_year, & + "Specific year in CFC_BC_FILE data calendar", default=2000) + call get_param(param_file, mdl, "CFC_BC_MODEL_YEAR", CFC_BC_model_year, & + "Model year corresponding to CFC_BC_MODEL_YEAR", default=2000) + CS%CFC_BC_year_offset = CFC_BC_data_year - CFC_BC_model_year + + call get_param(param_file, mdl, "CFC11_NH_VARIABLE", CFC_BC_var_name, & + "Variable name of NH CFC-11 atm mole fraction in CFC_BC_FILE.", & + default="cfc11_nh") + CS%cfc11_atm_nh_handle = init_external_field(CFC_BC_file, CFC_BC_var_name) + + call get_param(param_file, mdl, "CFC11_SH_VARIABLE", CFC_BC_var_name, & + "Variable name of SH CFC-11 atm mole fraction in CFC_BC_FILE.", & + default="cfc11_sh") + CS%cfc11_atm_sh_handle = init_external_field(CFC_BC_file, CFC_BC_var_name) + + call get_param(param_file, mdl, "CFC12_NH_VARIABLE", CFC_BC_var_name, & + "Variable name of NH CFC-12 atm mole fraction in CFC_BC_FILE.", & + default="cfc12_nh") + CS%cfc12_atm_nh_handle = init_external_field(CFC_BC_file, CFC_BC_var_name) + + call get_param(param_file, mdl, "CFC12_SH_VARIABLE", CFC_BC_var_name, & + "Variable name of SH CFC-12 atm mole fraction in CFC_BC_FILE.", & + default="cfc12_sh") + CS%cfc12_atm_sh_handle = init_external_field(CFC_BC_file, CFC_BC_var_name) +! domain=G%Domain%mpp_domain) + ! The following vardesc types contain a package of metadata about each tracer, ! including, the name; units; longname; and grid information. - CS%CFC11_name = "CFC_11" ; CS%CFC12_name = "CFC_12" - CS%CFC11_desc = var_desc(CS%CFC11_name,"mol kg-1","Moles Per Unit Mass of CFC-11 in sea water", caller=mdl) - CS%CFC12_desc = var_desc(CS%CFC12_name,"mol kg-1","Moles Per Unit Mass of CFC-12 in sea water", caller=mdl) - - allocate(CS%CFC11(isd:ied,jsd:jed,nz), source=0.0) - allocate(CS%CFC12(isd:ied,jsd:jed,nz), source=0.0) - - ! This pointer assignment is needed to force the compiler not to do a copy in - ! the registration calls. Curses on the designers and implementers of F90. - tr_ptr => CS%CFC11 - ! Register CFC11 for horizontal advection, diffusion, and restarts. - call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & - tr_desc=CS%CFC11_desc, registry_diags=.true., & - restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) - ! Do the same for CFC12 - tr_ptr => CS%CFC12 - call register_tracer(tr_ptr, Tr_Reg, param_file, HI, GV, & - tr_desc=CS%CFC12_desc, registry_diags=.true., & - restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) + do m=1,NTR + write(m2char, "(I1)") m + write(CS%CFC_data(m)%name, "(2A)") "CFC_1", m2char + CS%CFC_data(m)%desc = var_desc(CS%CFC_data(m)%name, & + "mol kg-1", & + "Moles Per Unit Mass of CFC-1"//m2char//" in sea water", & + caller=mdl) + + allocate(CS%CFC_data(m)%conc(isd:ied,jsd:jed,nz), source=0.0) + allocate(CS%CFC_data(m)%sfc_flux(isd:ied,jsd:jed), source=0.0) + + ! This pointer assignment is needed to force the compiler not to do a copy in + ! the registration calls. Curses on the designers and implementers of F90. + tr_ptr => CS%CFC_data(m)%conc + ! Register CFC tracer for horizontal advection, diffusion, and restarts. + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & + tr_desc=CS%CFC_data(m)%desc, registry_diags=.true., & + restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit, & + Tr_out=CS%CFC_data(m)%tr_ptr) + enddo CS%tr_Reg => tr_Reg CS%restart_CSp => restart_CS @@ -188,35 +232,47 @@ subroutine initialize_CFC_cap(restart, day, G, GV, US, h, diag, OBC, CS) type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type !! specifies whether, where, and what !! open boundary conditions are used. - type(CFC_cap_CS), pointer :: CS !< The control structure returned by a + type(CFC_cap_CS), pointer :: CS !< The control structure returned by a !! previous call to register_CFC_cap. ! local variables - logical :: from_file = .false. + integer :: m + character :: m2char if (.not.associated(CS)) return CS%Time => day CS%diag => diag - if (.not.restart .or. (CS%tracers_may_reinit .and. & - .not.query_initialized(CS%CFC11, CS%CFC11_name, CS%restart_CSp))) & - call init_tracer_CFC(h, CS%CFC11, CS%CFC11_name, CS%CFC11_land_val, & - CS%CFC11_IC_val, G, GV, US, CS) - - if (.not.restart .or. (CS%tracers_may_reinit .and. & - .not.query_initialized(CS%CFC12, CS%CFC12_name, CS%restart_CSp))) & - call init_tracer_CFC(h, CS%CFC12, CS%CFC12_name, CS%CFC12_land_val, & - CS%CFC12_IC_val, G, GV, US, CS) + do m=1,NTR + if (.not.restart .or. (CS%tracers_may_reinit .and. & + .not.query_initialized(CS%CFC_data(m)%conc, CS%CFC_data(m)%name, CS%restart_CSp))) then + call init_tracer_CFC(h, CS%CFC_data(m)%conc, CS%CFC_data(m)%name, CS%CFC_data(m)%land_val, & + CS%CFC_data(m)%IC_val, G, GV, US, CS) + call set_initialized(CS%CFC_data(m)%conc, CS%CFC_data(m)%name, CS%restart_CSp) + endif + ! cmor diagnostics + ! units for cfc11_flux and cfc12_flux are [Conc R Z T-1 ~> mol m-2 s-1] + ! CFC11 cmor conventions: http://clipc-services.ceda.ac.uk/dreq/u/42625c97b8fe75124a345962c4430982.html + ! http://clipc-services.ceda.ac.uk/dreq/u/0940cbee6105037e4b7aa5579004f124.html + ! CFC12 cmor conventions: http://clipc-services.ceda.ac.uk/dreq/u/3ab8e10027d7014f18f9391890369235.html + ! http://clipc-services.ceda.ac.uk/dreq/u/e9e21426e4810d0bb2d3dddb24dbf4dc.html + write(m2char, "(I1)") m + CS%CFC_data(m)%id_cmor = register_diag_field('ocean_model', & + 'cfc1'//m2char, diag%axesTL, day, & + 'Mole Concentration of CFC1'//m2char//' in Sea Water', 'mol m-3', & + conversion=GV%Rho0*US%R_to_kg_m3) + + CS%CFC_data(m)%id_sfc_flux = register_diag_field('ocean_model', & + 'cfc1'//m2char//'_flux', diag%axesT1, day, & + 'Gas exchange flux of CFC1'//m2char//' into the ocean ', & + 'mol m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + cmor_field_name='fgcfc1'//m2char, & + cmor_long_name='Surface Downward CFC1'//m2char//' Flux', & + cmor_standard_name='surface_downward_cfc1'//m2char//'_flux') + enddo - ! cmor diagnostics - ! CFC11 cmor conventions: http://clipc-services.ceda.ac.uk/dreq/u/42625c97b8fe75124a345962c4430982.html - CS%id_cfc11_cmor = register_diag_field('ocean_model', 'cfc11', diag%axesTL, day, & - 'Mole Concentration of CFC11 in Sea Water', 'mol m-3') - ! CFC12 cmor conventions: http://clipc-services.ceda.ac.uk/dreq/u/3ab8e10027d7014f18f9391890369235.html - CS%id_cfc12_cmor = register_diag_field('ocean_model', 'cfc12', diag%axesTL, day, & - 'Mole Concentration of CFC12 in Sea Water', 'mol m-3') if (associated(OBC)) then ! Steal from updated DOME in the fullness of time. @@ -231,10 +287,11 @@ subroutine init_tracer_CFC(h, tr, name, land_val, IC_val, G, GV, US, CS) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: tr !< The tracer concentration array + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: tr !< The tracer concentration array [mol kg-1] character(len=*), intent(in) :: name !< The tracer name - real, intent(in) :: land_val !< A value the tracer takes over land - real, intent(in) :: IC_val !< The initial condition value for the tracer + real, intent(in) :: land_val !< A value the tracer takes over land [mol kg-1] + real, intent(in) :: IC_val !< The initial condition value for the + !! tracer [mol kg-1] type(CFC_cap_CS), pointer :: CS !< The control structure returned by a !! previous call to register_CFC_cap. @@ -273,8 +330,8 @@ end subroutine init_tracer_CFC !> Applies diapycnal diffusion, souces and sinks and any other column !! tracer physics to the CFC cap tracers. CFCs are relatively simple, !! as they are passive tracers with only a surface flux as a source. -subroutine CFC_cap_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & - evap_CFL_limit, minimum_forcing_depth) +subroutine CFC_cap_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, KPP_CSp, & + nonLocalTrans, evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & @@ -295,6 +352,8 @@ subroutine CFC_cap_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, C type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(CFC_cap_CS), pointer :: CS !< The control structure returned by a !! previous call to register_CFC_cap. + type(KPP_CS), optional, pointer :: KPP_CSp !< KPP control structure + real, optional, intent(in) :: nonLocalTrans(:,:,:) !< Non-local transport [nondim] real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which @@ -305,50 +364,65 @@ subroutine CFC_cap_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, C ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] - integer :: i, j, k, m, is, ie, js, je, nz + integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not.associated(CS)) return + ! Compute KPP nonlocal term if necessary + if (present(KPP_CSp)) then + if (associated(KPP_CSp) .and. present(nonLocalTrans)) then + do m=1,NTR + call KPP_NonLocalTransport(KPP_CSp, G, GV, h_old, nonLocalTrans, & + CS%CFC_data(m)%sfc_flux(:,:), dt, CS%diag, & + CS%CFC_data(m)%tr_ptr, CS%CFC_data(m)%conc(:,:,:), & + flux_scale=GV%RZ_to_H) + enddo + endif + endif + ! Use a tridiagonal solver to determine the concentrations after the ! surface source is applied and diapycnal advection and diffusion occurs. if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then - do k=1,nz ;do j=js,je ; do i=is,ie - h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo - call applyTracerBoundaryFluxesInOut(G, GV, CS%CFC11, dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) - call tracer_vertdiff(h_work, ea, eb, dt, CS%CFC11, G, GV, sfc_flux=fluxes%cfc11_flux) - - do k=1,nz ;do j=js,je ; do i=is,ie - h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo - call applyTracerBoundaryFluxesInOut(G, GV, CS%CFC12, dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) - call tracer_vertdiff(h_work, ea, eb, dt, CS%CFC12, G, GV, sfc_flux=fluxes%cfc12_flux) + do m=1,NTR + do k=1,nz ;do j=js,je ; do i=is,ie + h_work(i,j,k) = h_old(i,j,k) + enddo ; enddo ; enddo + call applyTracerBoundaryFluxesInOut(G, GV, CS%CFC_data(m)%conc, dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) + call tracer_vertdiff(h_work, ea, eb, dt, CS%CFC_data(m)%conc, G, GV, & + sfc_flux=CS%CFC_data(m)%sfc_flux) + enddo else - call tracer_vertdiff(h_old, ea, eb, dt, CS%CFC11, G, GV, sfc_flux=fluxes%cfc11_flux) - call tracer_vertdiff(h_old, ea, eb, dt, CS%CFC12, G, GV, sfc_flux=fluxes%cfc12_flux) + do m=1,NTR + call tracer_vertdiff(h_old, ea, eb, dt, CS%CFC_data(m)%conc, G, GV, & + sfc_flux=CS%CFC_data(m)%sfc_flux) + enddo endif ! If needed, write out any desired diagnostics from tracer sources & sinks here. - if (CS%id_cfc11_cmor > 0) call post_data(CS%id_cfc11_cmor, (GV%Rho0*US%R_to_kg_m3)*CS%CFC11, CS%diag) - if (CS%id_cfc12_cmor > 0) call post_data(CS%id_cfc12_cmor, (GV%Rho0*US%R_to_kg_m3)*CS%CFC12, CS%diag) + do m=1,NTR + if (CS%CFC_data(m)%id_cmor > 0) & + call post_data(CS%CFC_data(m)%id_cmor, CS%CFC_data(m)%conc, CS%diag) + + if (CS%CFC_data(m)%id_sfc_flux > 0) & + call post_data(CS%CFC_data(m)%id_sfc_flux, CS%CFC_data(m)%sfc_flux, CS%diag) + enddo end subroutine CFC_cap_column_physics + !> Calculates the mass-weighted integral of all tracer stocks, !! returning the number of stocks it has calculated. If the stock_index !! is present, only the stock corresponding to that coded index is returned. -function CFC_cap_stock(h, stocks, G, GV, US, CS, names, units, stock_index) +function CFC_cap_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. - real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each - !! tracer, in kg times concentration units [kg conc]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] type(CFC_cap_CS), pointer :: CS !< The control structure returned by a !! previous call to register_CFC_cap. character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. @@ -360,7 +434,7 @@ function CFC_cap_stock(h, stocks, G, GV, US, CS, names, units, stock_index) ! Local variables real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] real :: mass ! The cell volume or mass [H L2 ~> m3 or kg] - integer :: i, j, k, is, ie, js, je, nz + integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke CFC_cap_stock = 0 @@ -373,140 +447,131 @@ function CFC_cap_stock(h, stocks, G, GV, US, CS, names, units, stock_index) return endif ; endif - call query_vardesc(CS%CFC11_desc, name=names(1), units=units(1), caller="CFC_cap_stock") - call query_vardesc(CS%CFC12_desc, name=names(2), units=units(2), caller="CFC_cap_stock") - units(1) = trim(units(1))//" kg" ; units(2) = trim(units(2))//" kg" + do m=1,NTR + call query_vardesc(CS%CFC_data(m)%desc, name=names(m), units=units(m), caller="CFC_cap_stock") + units(m) = trim(units(m))//" kg" + stocks(m) = global_mass_int_EFP(h, G, GV, CS%CFC_data(m)%conc, on_PE_only=.true.) + enddo - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 - stocks(1) = 0.0 ; stocks(2) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - mass = G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k) - stocks(1) = stocks(1) + CS%CFC11(i,j,k) * mass - stocks(2) = stocks(2) + CS%CFC12(i,j,k) * mass - enddo ; enddo ; enddo - stocks(1) = stock_scale * stocks(1) - stocks(2) = stock_scale * stocks(2) - - CFC_cap_stock = 2 + CFC_cap_stock = NTR end function CFC_cap_stock -!> Extracts the ocean surface CFC concentrations and copies them to sfc_state. -subroutine CFC_cap_surface_state(sfc_state, G, CS) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(CFC_cap_CS), pointer :: CS!< The control structure returned by a previous - !! call to register_CFC_cap. - - ! Local variables - integer :: i, j, is, ie, js, je - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - - if (.not.associated(CS)) return - - do j=js,je ; do i=is,ie - sfc_state%sfc_cfc11(i,j) = CS%CFC11(i,j,1) - sfc_state%sfc_cfc12(i,j) = CS%CFC12(i,j,1) - enddo ; enddo - -end subroutine CFC_cap_surface_state - !> Orchestrates the calculation of the CFC fluxes [mol m-2 s-1], including getting the ATM !! concentration, and calculating the solubility, Schmidt number, and gas exchange. -subroutine CFC_cap_fluxes(fluxes, sfc_state, G, US, Rho0, Time, id_cfc11_atm, id_cfc12_atm) - type(ocean_grid_type), intent(in ) :: G !< The ocean's grid structure. - type(unit_scale_type), intent(in ) :: US !< A dimensional unit scaling type - type(surface), intent(in ) :: sfc_state !< A structure containing fields - !! that describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes !< A structure containing pointers - !! to thermodynamic and tracer forcing fields. Unused fields - !! have NULL ptrs. - real, intent(in ) :: Rho0 !< The mean ocean density [R ~> kg m-3] - type(time_type), intent(in ) :: Time !< The time of the fluxes, used for interpolating the - !! CFC's concentration in the atmosphere. - integer, optional, intent(inout):: id_cfc11_atm !< id number for time_interp_external. - integer, optional, intent(inout):: id_cfc12_atm !< id number for time_interp_external. +subroutine CFC_cap_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US, Rho0, CS) + type(surface), intent(in ) :: sfc_state !< A structure containing fields + !! that describe the surface state of the ocean. + type(forcing), intent(inout) :: fluxes !< A structure containing pointers + !! to thermodynamic and tracer forcing fields. Unused fields + !! have NULL ptrs. + type(time_type), intent(in) :: day_start !< Start time of the fluxes. + type(time_type), intent(in) :: day_interval !< Length of time over which these + !! fluxes will be applied. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: Rho0 !< The mean ocean density [R ~> kg m-3] + type(CFC_cap_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_CFC_cap. ! Local variables + type(time_type) :: Time_external ! time value used in CFC_BC_file real, dimension(SZI_(G),SZJ_(G)) :: & kw_wo_sc_no_term, & ! gas transfer velocity, without the Schmidt number term [Z T-1 ~> m s-1]. - kw, & ! gas transfer velocity [Z T-1 ~> m s-1]. - cair, & ! The surface gas concentration in equilibrium with the atmosphere (saturation concentration) - ! [mol kg-1]. - cfc11_atm, & !< CFC11 concentration in the atmopshere [pico mol/mol] - cfc12_atm !< CFC11 concentration in the atmopshere [pico mol/mol] - real :: ta ! Absolute sea surface temperature [hectoKelvin] - real :: sal ! Surface salinity [PSU]. - real :: alpha_11 ! The solubility of CFC 11 [mol kg-1 atm-1]. - real :: alpha_12 ! The solubility of CFC 12 [mol kg-1 atm-1]. - real :: sc_11, sc_12 ! The Schmidt numbers of CFC 11 and CFC 12 [nondim]. - real :: kw_coeff ! A coefficient used to compute the piston velocity [Z T-1 T2 L-2 = Z T L-2 ~> s / m] + kw, & ! gas transfer velocity [Z T-1 ~> m s-1]. + cair, & ! The surface gas concentration in equilibrium with the atmosphere + ! (saturation concentration) [mol kg-1]. + cfc11_atm, & ! CFC11 atm mole fraction [pico mol/mol] + cfc12_atm ! CFC12 atm mole fraction [pico mol/mol] + real :: cfc11_atm_nh ! NH value for cfc11_atm [pico mol/mol] + real :: cfc11_atm_sh ! SH value for cfc11_atm [pico mol/mol] + real :: cfc12_atm_nh ! NH value for cfc12_atm [pico mol/mol] + real :: cfc12_atm_sh ! SH value for cfc12_atm [pico mol/mol] + real :: ta ! Absolute sea surface temperature [hectoKelvin] + real :: sal ! Surface salinity [PSU]. + real :: alpha_11 ! The solubility of CFC 11 [mol kg-1 atm-1]. + real :: alpha_12 ! The solubility of CFC 12 [mol kg-1 atm-1]. + real :: sc_11, sc_12 ! The Schmidt numbers of CFC 11 and CFC 12 [nondim]. + real :: kw_coeff ! A coefficient used to compute the piston velocity [Z T-1 T2 L-2] = [Z T L-2 ~> s m-1] real, parameter :: pa_to_atm = 9.8692316931427e-6 ! factor for converting from Pa to atm [atm Pa-1]. - real :: press_to_atm ! converts from model pressure units to atm [atm T2 R-1 L-2 ~> atm Pa-1] - integer :: i, j, m, is, ie, js, je + real :: press_to_atm ! converts from model pressure units to atm [atm T2 R-1 L-2 ~> atm Pa-1] + integer :: i, j, is, ie, js, je, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - ! CFC11 ATM concentration - if (present(id_cfc11_atm) .and. (id_cfc11_atm /= -1)) then - call time_interp_external(id_cfc11_atm, Time, cfc11_atm) - ! convert from ppt (pico mol/mol) to mol/mol - cfc11_atm = cfc11_atm * 1.0e-12 - else - ! TODO: create cfc11_atm internally - call MOM_error(FATAL, "CFC_cap_fluxes: option to create cfc11_atm internally" //& - "has not been implemented yet.") - endif + ! Time_external = increment_date(day_start + day_interval/2, years=CS%CFC_BC_year_offset) + Time_external = increment_date(day_start, years=CS%CFC_BC_year_offset) - ! CFC12 ATM concentration - if (present(id_cfc12_atm) .and. (id_cfc12_atm /= -1)) then - call time_interp_external(id_cfc12_atm, Time, cfc12_atm) - ! convert from ppt (pico mol/mol) to mol/mol - cfc12_atm = cfc12_atm * 1.0e-12 - else - ! TODO: create cfc11_atm internally - call MOM_error(FATAL, "CFC_cap_fluxes: option to create cfc12_atm internally" //& - "has not been implemented yet.") - endif + ! CFC11 atm mole fraction, convert from ppt (pico mol/mol) to mol/mol + call time_interp_external(CS%cfc11_atm_nh_handle, Time_external, cfc11_atm_nh) + cfc11_atm_nh = cfc11_atm_nh * 1.0e-12 + call time_interp_external(CS%cfc11_atm_sh_handle, Time_external, cfc11_atm_sh) + cfc11_atm_sh = cfc11_atm_sh * 1.0e-12 + + ! CFC12 atm mole fraction, convert from ppt (pico mol/mol) to mol/mol + call time_interp_external(CS%cfc12_atm_nh_handle, Time_external, cfc12_atm_nh) + cfc12_atm_nh = cfc12_atm_nh * 1.0e-12 + call time_interp_external(CS%cfc12_atm_sh_handle, Time_external, cfc12_atm_sh) + cfc12_atm_sh = cfc12_atm_sh * 1.0e-12 !--------------------------------------------------------------------- ! Gas exchange/piston velocity parameter !--------------------------------------------------------------------- ! From a = 0.251 cm/hr s^2/m^2 in Wannikhof 2014 - ! = 6.97e-7 m/s s^2/m^2 [Z T-1 T2 L-2 = Z T L-2 ~> s / m] + ! = 6.97e-7 [m/s s^2/m^2] [Z T-1 T2 L-2] = [Z T L-2 ~> s m-1] kw_coeff = (US%m_to_Z*US%s_to_T*US%L_to_m**2) * 6.97e-7 ! set unit conversion factors press_to_atm = US%R_to_kg_m3*US%L_T_to_m_s**2 * pa_to_atm + do j=js,je ; do i=is,ie + if (G%geoLatT(i,j) < -10.0) then + cfc11_atm(i,j) = cfc11_atm_sh + cfc12_atm(i,j) = cfc12_atm_sh + elseif (G%geoLatT(i,j) <= 10.0) then + cfc11_atm(i,j) = cfc11_atm_sh + & + (0.05 * G%geoLatT(i,j) + 0.5) * (cfc11_atm_nh - cfc11_atm_sh) + cfc12_atm(i,j) = cfc12_atm_sh + & + (0.05 * G%geoLatT(i,j) + 0.5) * (cfc12_atm_nh - cfc12_atm_sh) + else + cfc11_atm(i,j) = cfc11_atm_nh + cfc12_atm(i,j) = cfc12_atm_nh + endif + enddo ; enddo + do j=js,je ; do i=is,ie ! ta in hectoKelvin - ta = max(0.01, (sfc_state%SST(i,j) + 273.15) * 0.01) - sal = sfc_state%SSS(i,j) + ta = max(0.01, (US%C_to_degC*sfc_state%SST(i,j) + 273.15) * 0.01) + sal = US%S_to_ppt*sfc_state%SSS(i,j) ! Calculate solubilities call get_solubility(alpha_11, alpha_12, ta, sal , G%mask2dT(i,j)) ! Calculate Schmidt numbers using coefficients given by ! Wanninkhof (2014); doi:10.4319/lom.2014.12.351. - call comp_CFC_schmidt(sfc_state%SST(i,j), sc_11, sc_12) + call comp_CFC_schmidt(US%C_to_degC*sfc_state%SST(i,j), sc_11, sc_12) kw_wo_sc_no_term(i,j) = kw_coeff * ((1.0 - fluxes%ice_fraction(i,j))*fluxes%u10_sqr(i,j)) ! air concentrations and cfcs BC's fluxes - ! CFC flux units: CU R Z T-1 = mol kg-1 R Z T-1 ~> mol m-2 s-1 + ! CFC flux units: [mol kg-1 R Z T-1 ~> mol m-2 s-1] kw(i,j) = kw_wo_sc_no_term(i,j) * sqrt(660.0 / sc_11) cair(i,j) = press_to_atm * alpha_11 * cfc11_atm(i,j) * fluxes%p_surf_full(i,j) - fluxes%cfc11_flux(i,j) = kw(i,j) * (cair(i,j) - sfc_state%sfc_CFC11(i,j)) * Rho0 + CS%CFC_data(1)%sfc_flux(i,j) = kw(i,j) * (cair(i,j) - CS%CFC_data(1)%conc(i,j,1)) * Rho0 kw(i,j) = kw_wo_sc_no_term(i,j) * sqrt(660.0 / sc_12) cair(i,j) = press_to_atm * alpha_12 * cfc12_atm(i,j) * fluxes%p_surf_full(i,j) - fluxes%cfc12_flux(i,j) = kw(i,j) * (cair(i,j) - sfc_state%sfc_CFC12(i,j)) * Rho0 + CS%CFC_data(2)%sfc_flux(i,j) = kw(i,j) * (cair(i,j) - CS%CFC_data(2)%conc(i,j,1)) * Rho0 enddo ; enddo -end subroutine CFC_cap_fluxes + if (CS%debug) then + do m=1,NTR + call hchksum(CS%CFC_data(m)%sfc_flux, trim(CS%CFC_data(m)%name)//" sfc_flux", G%HI, & + unscale=US%RZ_T_to_kg_m2s) + enddo + endif + +end subroutine CFC_cap_set_forcing !> Calculates the CFC's solubility function following Warner and Weiss (1985) DSR, vol 32. subroutine get_solubility(alpha_11, alpha_12, ta, sal , mask) @@ -588,12 +653,15 @@ end subroutine comp_CFC_schmidt subroutine CFC_cap_end(CS) type(CFC_cap_CS), pointer :: CS !< The control structure returned by a !! previous call to register_CFC_cap. + ! local variables integer :: m if (associated(CS)) then - if (associated(CS%CFC11)) deallocate(CS%CFC11) - if (associated(CS%CFC12)) deallocate(CS%CFC12) + do m=1,NTR + if (associated(CS%CFC_data(m)%conc)) deallocate(CS%CFC_data(m)%conc) + if (associated(CS%CFC_data(m)%sfc_flux)) deallocate(CS%CFC_data(m)%sfc_flux) + enddo deallocate(CS) endif @@ -605,7 +673,9 @@ logical function CFC_cap_unit_tests(verbose) !! information for debugging unit tests ! Local variables - real :: dummy1, dummy2, ta, sal + real :: dummy1, dummy2 ! Test values of Schmidt numbers [nondim] or solubilities [mol kg-1 atm-1] for CFC11 and CFC12 + real :: ta ! A test value of temperature [hectoKelvin] + real :: sal ! A test value of salinity [ppt] character(len=120) :: test_name ! Title of the unit test CFC_cap_unit_tests = .false. @@ -622,7 +692,7 @@ logical function CFC_cap_unit_tests(verbose) if (.not. CFC_cap_unit_tests) write(stdout,'(2x,a)') "Passed "//test_name test_name = 'Solubility function, SST = 1.0 C, and SSS = 10 psu' - ta = max(0.01, (1.0 + 273.15) * 0.01); sal = 10. + ta = max(0.01, (1.0 + 273.15) * 0.01) ; sal = 10. ! cfc1 = 3.238 10-2 mol kg-1 atm-1 ! cfc2 = 7.943 10-3 mol kg-1 atm-1 call get_solubility(dummy1, dummy2, ta, sal , 1.0) @@ -634,7 +704,7 @@ logical function CFC_cap_unit_tests(verbose) if (.not. CFC_cap_unit_tests) write(stdout,'(2x,a)')"Passed "//test_name test_name = 'Solubility function, SST = 20.0 C, and SSS = 35 psu' - ta = max(0.01, (20.0 + 273.15) * 0.01); sal = 35. + ta = max(0.01, (20.0 + 273.15) * 0.01) ; sal = 35. ! cfc1 = 0.881 10-2 mol kg-1 atm-1 ! cfc2 = 2.446 10-3 mol kg-1 atm-1 call get_solubility(dummy1, dummy2, ta, sal , 1.0) @@ -651,12 +721,12 @@ end function CFC_cap_unit_tests logical function compare_values(verbose, test_name, calc, ans, limit) logical, intent(in) :: verbose !< If true, write results to stdout character(len=80), intent(in) :: test_name !< Brief description of the unit test - real, intent(in) :: calc !< computed value - real, intent(in) :: ans !< correct value - real, intent(in) :: limit !< value above which test fails + real, intent(in) :: calc !< computed value in arbitrary units [A] + real, intent(in) :: ans !< correct value [A] + real, intent(in) :: limit !< value above which test fails [A] ! Local variables - real :: diff + real :: diff ! Difference in values [A] diff = ans - calc @@ -669,7 +739,7 @@ logical function compare_values(verbose, test_name, calc, ans, limit) write(stdout,10) calc, ans endif -10 format("calc=",f20.16," ans",f20.16) +10 format("calc=",f22.16," ans",f22.16) end function compare_values !> \namespace mom_CFC_cap diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index 5fe55b896b..ee6609903f 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -1,27 +1,32 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Simulates CFCs using the OCMIP2 protocols module MOM_OCMIP2_CFC -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_coupler_types, only : extract_coupler_type_data, set_coupler_type_data -use MOM_coupler_types, only : atmos_ocn_coupler_flux -use MOM_diag_mediator, only : diag_ctrl -use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : forcing -use MOM_hor_index, only : hor_index_type -use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc -use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : query_initialized, MOM_restart_CS -use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type +use MOM_coms, only : EFP_type +use MOM_coupler_types, only : extract_coupler_type_data, set_coupler_type_data +use MOM_coupler_types, only : atmos_ocn_coupler_flux +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_hor_index, only : hor_index_type +use MOM_grid, only : ocean_grid_type +use MOM_io, only : file_exists, MOM_read_data, slasher +use MOM_io, only : vardesc, var_desc, query_vardesc +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut -use MOM_tracer_Z_init, only : tracer_Z_init -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface -use MOM_verticalGrid, only : verticalGrid_type +use MOM_tracer_Z_init, only : tracer_Z_init +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -99,20 +104,19 @@ function register_OCMIP2_CFC(HI, GV, param_file, CS, tr_Reg, restart_CS) character(len=200) :: inputdir ! The directory where NetCDF input files are. ! This include declares and sets the variable "version". # include "version_variable.h" - real, dimension(:,:,:), pointer :: tr_ptr => NULL() + real, dimension(:,:,:), pointer :: tr_ptr => NULL() ! A pointer to a CFC tracer [mol m-3] real :: a11_dflt(4), a12_dflt(4) ! Default values of the various coefficients real :: d11_dflt(4), d12_dflt(4) ! in the expressions for the solubility and real :: e11_dflt(3), e12_dflt(3) ! Schmidt numbers [various units by element]. character(len=48) :: flux_units ! The units for tracer fluxes. logical :: register_OCMIP2_CFC - integer :: isd, ied, jsd, jed, nz, m + integer :: isd, ied, jsd, jed, nz isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke if (associated(CS)) then - call MOM_error(WARNING, "register_OCMIP2_CFC called with an "// & - "associated control structure.") - return + call MOM_error(FATAL, "register_OCMIP2_CFC called with an "// & + "associated control structure.") endif allocate(CS) @@ -285,14 +289,14 @@ subroutine flux_init_OCMIP2_CFC(CS, verbosity) ! These calls obtain the indices for the CFC11 and CFC12 flux coupling. They ! can safely be called multiple times. ind_flux(1) = atmos_ocn_coupler_flux('cfc_11_flux', & - flux_type = 'air_sea_gas_flux', implementation='ocmip2', & + flux_type='air_sea_gas_flux', implementation='ocmip2', & param=(/ 9.36e-07, 9.7561e-06 /), & - ice_restart_file = default_ice_restart_file, & - ocean_restart_file = default_ocean_restart_file, & - caller = "register_OCMIP2_CFC", verbosity=verbosity) + ice_restart_file=default_ice_restart_file, & + ocean_restart_file=default_ocean_restart_file, & + caller="register_OCMIP2_CFC", verbosity=verbosity) ind_flux(2) = atmos_ocn_coupler_flux('cfc_12_flux', & flux_type='air_sea_gas_flux', implementation='ocmip2', & - param = (/ 9.36e-07, 9.7561e-06 /), & + param=(/ 9.36e-07, 9.7561e-06 /), & ice_restart_file=default_ice_restart_file, & ocean_restart_file=default_ocean_restart_file, & caller="register_OCMIP2_CFC", verbosity=verbosity) @@ -332,14 +336,18 @@ subroutine initialize_OCMIP2_CFC(restart, day, G, GV, US, h, diag, OBC, CS, & CS%diag => diag if (.not.restart .or. (CS%tracers_may_reinit .and. & - .not.query_initialized(CS%CFC11, CS%CFC11_name, CS%restart_CSp))) & + .not.query_initialized(CS%CFC11, CS%CFC11_name, CS%restart_CSp))) then call init_tracer_CFC(h, CS%CFC11, CS%CFC11_name, CS%CFC11_land_val, & CS%CFC11_IC_val, G, GV, US, CS) + call set_initialized(CS%CFC11, CS%CFC11_name, CS%restart_CSp) + endif if (.not.restart .or. (CS%tracers_may_reinit .and. & - .not.query_initialized(CS%CFC12, CS%CFC12_name, CS%restart_CSp))) & + .not.query_initialized(CS%CFC12, CS%CFC12_name, CS%restart_CSp))) then call init_tracer_CFC(h, CS%CFC12, CS%CFC12_name, CS%CFC12_land_val, & CS%CFC12_IC_val, G, GV, US, CS) + call set_initialized(CS%CFC12, CS%CFC12_name, CS%restart_CSp) + endif if (associated(OBC)) then ! Steal from updated DOME in the fullness of time. @@ -353,10 +361,11 @@ subroutine init_tracer_CFC(h, tr, name, land_val, IC_val, G, GV, US, CS) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: tr !< The tracer concentration array + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: tr !< The CFC tracer concentration array [mol m-3] character(len=*), intent(in) :: name !< The tracer name - real, intent(in) :: land_val !< A value the tracer takes over land - real, intent(in) :: IC_val !< The initial condition value for the tracer + real, intent(in) :: land_val !< A value the tracer takes over land [mol m-3] + real, intent(in) :: IC_val !< The initial condition value for + !! the CRC tracer [mol m-3] type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a !! previous call to register_OCMIP2_CFC. @@ -433,9 +442,9 @@ subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & CFC11_flux, & ! The fluxes of CFC11 and CFC12 into the ocean, in unscaled units of - CFC12_flux ! CFC concentrations times meters per second [CU R Z T-1 ~> CU kg m-2 s-1] + CFC12_flux ! CFC concentrations times a vertical mass flux [mol R Z m-3 T-1 ~> mol kg m-3 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] - integer :: i, j, k, m, is, ie, js, je, nz, idim(4), jdim(4) + integer :: i, j, k, is, ie, js, je, nz, idim(4), jdim(4) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke idim(:) = (/G%isd, is, ie, G%ied/) ; jdim(:) = (/G%jsd, js, je, G%jed/) @@ -444,11 +453,11 @@ subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US ! These two calls unpack the fluxes from the input arrays. ! The -GV%Rho0 changes the sign convention of the flux and with the scaling factors changes - ! the units of the flux from [Conc. m s-1] to [Conc. R Z T-1 ~> Conc. kg m-2 s-1]. + ! the units of the flux from [conc m s-1] to [conc R Z T-1 ~> conc kg m-2 s-1]. call extract_coupler_type_data(fluxes%tr_fluxes, CS%ind_cfc_11_flux, CFC11_flux, & - scale_factor=-GV%Rho0*US%m_to_Z*US%T_to_s, idim=idim, jdim=jdim) + scale_factor=-GV%Rho0*US%m_to_Z*US%T_to_s, idim=idim, jdim=jdim, turns=G%HI%turns) call extract_coupler_type_data(fluxes%tr_fluxes, CS%ind_cfc_12_flux, CFC12_flux, & - scale_factor=-GV%Rho0*US%m_to_Z*US%T_to_s, idim=idim, jdim=jdim) + scale_factor=-GV%Rho0*US%m_to_Z*US%T_to_s, idim=idim, jdim=jdim, turns=G%HI%turns) ! Use a tridiagonal solver to determine the concentrations after the ! surface source is applied and diapycnal advection and diffusion occurs. @@ -478,14 +487,13 @@ end subroutine OCMIP2_CFC_column_physics !> This function calculates the mass-weighted integral of all tracer stocks, !! returning the number of stocks it has calculated. If the stock_index !! is present, only the stock corresponding to that coded index is returned. -function OCMIP2_CFC_stock(h, stocks, G, GV, US, CS, names, units, stock_index) +function OCMIP2_CFC_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. - real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each - !! tracer, in kg times concentration units [kg conc]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a !! previous call to register_OCMIP2_CFC. character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. @@ -494,11 +502,6 @@ function OCMIP2_CFC_stock(h, stocks, G, GV, US, CS, names, units, stock_index) !! stock being sought. integer :: OCMIP2_CFC_stock !< The number of stocks calculated here. - ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] - real :: mass ! The cell volume or mass [H L2 ~> m3 or kg] - integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke OCMIP2_CFC_stock = 0 if (.not.associated(CS)) return @@ -514,15 +517,8 @@ function OCMIP2_CFC_stock(h, stocks, G, GV, US, CS, names, units, stock_index) call query_vardesc(CS%CFC12_desc, name=names(2), units=units(2), caller="OCMIP2_CFC_stock") units(1) = trim(units(1))//" kg" ; units(2) = trim(units(2))//" kg" - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 - stocks(1) = 0.0 ; stocks(2) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - mass = G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k) - stocks(1) = stocks(1) + CS%CFC11(i,j,k) * mass - stocks(2) = stocks(2) + CS%CFC12(i,j,k) * mass - enddo ; enddo ; enddo - stocks(1) = stock_scale * stocks(1) - stocks(2) = stock_scale * stocks(2) + stocks(1) = global_mass_int_EFP(h, G, GV, CS%CFC11, on_PE_only=.true.) + stocks(2) = global_mass_int_EFP(h, G, GV, CS%CFC12, on_PE_only=.true.) OCMIP2_CFC_stock = 2 @@ -530,13 +526,14 @@ end function OCMIP2_CFC_stock !> This subroutine extracts the surface CFC concentrations and other fields that !! are shared with the atmosphere to calculate CFC fluxes. -subroutine OCMIP2_CFC_surface_state(sfc_state, h, G, GV, CS) +subroutine OCMIP2_CFC_surface_state(sfc_state, h, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a previous !! call to register_OCMIP2_CFC. @@ -551,9 +548,9 @@ subroutine OCMIP2_CFC_surface_state(sfc_state, h, G, GV, CS) real :: SST ! Sea surface temperature [degC]. real :: alpha_11 ! The solubility of CFC 11 [mol m-3 pptv-1]. real :: alpha_12 ! The solubility of CFC 12 [mol m-3 pptv-1]. - real :: sc_11, sc_12 ! The Schmidt numbers of CFC 11 and CFC 12. - real :: sc_no_term ! A term related to the Schmidt number. - integer :: i, j, m, is, ie, js, je, idim(4), jdim(4) + real :: sc_11, sc_12 ! The Schmidt numbers of CFC 11 and CFC 12 [nondim]. + real :: sc_no_term ! A term related to the Schmidt number [nondim]. + integer :: i, j, is, ie, js, je, idim(4), jdim(4) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec idim(:) = (/G%isd, is, ie, G%ied/) ; jdim(:) = (/G%jsd, js, je, G%jed/) @@ -561,8 +558,8 @@ subroutine OCMIP2_CFC_surface_state(sfc_state, h, G, GV, CS) if (.not.associated(CS)) return do j=js,je ; do i=is,ie - ta = max(0.01, (sfc_state%SST(i,j) + 273.15) * 0.01) ! Why is this in hectoKelvin? - sal = sfc_state%SSS(i,j) ; SST = sfc_state%SST(i,j) + ta = max(0.01, (US%C_to_degC*sfc_state%SST(i,j) + 273.15) * 0.01) ! Why is this in hectoKelvin? + sal = US%S_to_ppt*sfc_state%SSS(i,j) ; SST = US%C_to_degC*sfc_state%SST(i,j) ! Calculate solubilities using Warner and Weiss (1985) DSR, vol 32. ! The final result is in mol/cm3/pptv (1 part per trillion 1e-12) ! Use Bullister and Wisegavger for CCl4. @@ -592,13 +589,13 @@ subroutine OCMIP2_CFC_surface_state(sfc_state, h, G, GV, CS) ! These calls load these values into the appropriate arrays in the ! coupler-type structure. call set_coupler_type_data(CFC11_alpha, CS%ind_cfc_11_flux, sfc_state%tr_fields, & - solubility=.true., idim=idim, jdim=jdim) + solubility=.true., idim=idim, jdim=jdim, turns=G%HI%turns) call set_coupler_type_data(CFC11_Csurf, CS%ind_cfc_11_flux, sfc_state%tr_fields, & - idim=idim, jdim=jdim) + idim=idim, jdim=jdim, turns=G%HI%turns) call set_coupler_type_data(CFC12_alpha, CS%ind_cfc_12_flux, sfc_state%tr_fields, & - solubility=.true., idim=idim, jdim=jdim) + solubility=.true., idim=idim, jdim=jdim, turns=G%HI%turns) call set_coupler_type_data(CFC12_Csurf, CS%ind_cfc_12_flux, sfc_state%tr_fields, & - idim=idim, jdim=jdim) + idim=idim, jdim=jdim, turns=G%HI%turns) end subroutine OCMIP2_CFC_surface_state @@ -609,7 +606,6 @@ subroutine OCMIP2_CFC_end(CS) ! This subroutine deallocates the memory owned by this module. ! Argument: CS - The control structure returned by a previous call to ! register_OCMIP2_CFC. - integer :: m if (associated(CS)) then if (associated(CS%CFC11)) deallocate(CS%CFC11) diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 deleted file mode 100644 index bf9f01e266..0000000000 --- a/src/tracer/MOM_generic_tracer.F90 +++ /dev/null @@ -1,974 +0,0 @@ -!> Drives the generic version of tracers TOPAZ and CFC and other GFDL BGC components -module MOM_generic_tracer - -! This file is part of MOM6. See LICENSE.md for the license. - -#include - -! The following macro is usually defined in but since MOM6 should not directly -! include files from FMS we replicate the macro lines here: -#ifdef NO_F2000 -#define _ALLOCATED associated -#else -#define _ALLOCATED allocated -#endif - - ! ### These imports should not reach into FMS directly ### - use field_manager_mod, only: fm_string_len - - use generic_tracer, only: generic_tracer_register, generic_tracer_get_diag_list - use generic_tracer, only: generic_tracer_init, generic_tracer_source, generic_tracer_register_diag - use generic_tracer, only: generic_tracer_coupler_get, generic_tracer_coupler_set - use generic_tracer, only: generic_tracer_end, generic_tracer_get_list, do_generic_tracer - use generic_tracer, only: generic_tracer_update_from_bottom,generic_tracer_vertdiff_G - use generic_tracer, only: generic_tracer_coupler_accumulate - - use g_tracer_utils, only: g_tracer_get_name,g_tracer_set_values,g_tracer_set_common,g_tracer_get_common - use g_tracer_utils, only: g_tracer_get_next,g_tracer_type,g_tracer_is_prog,g_tracer_flux_init - use g_tracer_utils, only: g_tracer_send_diag,g_tracer_get_values - use g_tracer_utils, only: g_tracer_get_pointer,g_tracer_get_alias,g_tracer_set_csdiag - - use MOM_ALE_sponge, only : set_up_ALE_sponge_field, ALE_sponge_CS - use MOM_coms, only : max_across_PEs, min_across_PEs, PE_here - use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr - use MOM_diag_mediator, only : diag_ctrl, get_diag_time_end - use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE, is_root_pe - use MOM_file_parser, only : get_param, log_param, log_version, param_file_type - use MOM_forcing_type, only : forcing, optics_type - use MOM_grid, only : ocean_grid_type - use MOM_hor_index, only : hor_index_type - use MOM_io, only : file_exists, MOM_read_data, slasher - use MOM_open_boundary, only : ocean_OBC_type - use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS - use MOM_spatial_means, only : global_area_mean - use MOM_sponge, only : set_up_sponge_field, sponge_CS - use MOM_time_manager, only : time_type, set_time - use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut - use MOM_tracer_registry, only : register_tracer, tracer_registry_type - use MOM_tracer_Z_init, only : tracer_Z_init - use MOM_tracer_initialization_from_Z, only : MOM_initialize_tracer_from_Z - use MOM_unit_scaling, only : unit_scale_type - use MOM_variables, only : surface, thermo_var_ptrs - use MOM_verticalGrid, only : verticalGrid_type - - - implicit none ; private - - !> An state hidden in module data that is very much not allowed in MOM6 - ! ### This needs to be fixed - logical :: g_registered = .false. - - public register_MOM_generic_tracer, initialize_MOM_generic_tracer - public MOM_generic_tracer_column_physics, MOM_generic_tracer_surface_state - public end_MOM_generic_tracer, MOM_generic_tracer_get - public MOM_generic_tracer_stock - public MOM_generic_flux_init - public MOM_generic_tracer_min_max - public MOM_generic_tracer_fluxes_accumulate - - !> Control structure for generic tracers - type, public :: MOM_generic_tracer_CS ; private - character(len = 200) :: IC_file !< The file in which the generic tracer initial values can - !! be found, or an empty string for internal initialization. - logical :: Z_IC_file !< If true, the generic_tracer IC_file is in Z-space. The default is false. - real :: tracer_IC_val = 0.0 !< The initial value assigned to tracers. - real :: tracer_land_val = -1.0 !< The values of tracers used where land is masked out. - logical :: tracers_may_reinit !< If true, tracers may go through the - !! initialization code if they are not found in the restart files. - - type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to - !! regulate the timing of diagnostic output. - type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< Restart control structure - - !> Pointer to the first element of the linked list of generic tracers. - type(g_tracer_type), pointer :: g_tracer_list => NULL() - - integer :: H_to_m !< Auxiliary to access GV%H_to_m in routines that do not have access to GV - - end type MOM_generic_tracer_CS - -! This include declares and sets the variable "version". -#include "version_variable.h" - -contains - - !> Initializes the generic tracer packages and adds their tracers to the list - !! Adds the tracers in the list of generic tracers to the set of MOM tracers (i.e., MOM-register them) - !! Register these tracers for restart - function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI !< Horizontal index ranges - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module - type(tracer_registry_type), pointer :: tr_Reg !< Pointer to the control structure for the tracer - !! advection and diffusion module. - type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control struct - -! Local variables - logical :: register_MOM_generic_tracer - - character(len=128), parameter :: sub_name = 'register_MOM_generic_tracer' - character(len=200) :: inputdir ! The directory where NetCDF input files are. - ! These can be overridden later in via the field manager? - - integer :: ntau, k,i,j,axes(3) - type(g_tracer_type), pointer :: g_tracer,g_tracer_next - character(len=fm_string_len) :: g_tracer_name,longname,units - real, dimension(:,:,:,:), pointer :: tr_field - real, dimension(:,:,:), pointer :: tr_ptr - real, dimension(HI%isd:HI%ied, HI%jsd:HI%jed,GV%ke) :: grid_tmask - integer, dimension(HI%isd:HI%ied, HI%jsd:HI%jed) :: grid_kmt - - register_MOM_generic_tracer = .false. - if (associated(CS)) then - call MOM_error(WARNING, "register_MOM_generic_tracer called with an "// & - "associated control structure.") - return - endif - allocate(CS) - - - !Register all the generic tracers used and create the list of them. - !This can be called by ALL PE's. No array fields allocated. - if (.not. g_registered) then - call generic_tracer_register() - g_registered = .true. - endif - - - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, sub_name, version, "") - call get_param(param_file, sub_name, "GENERIC_TRACER_IC_FILE", CS%IC_file, & - "The file in which the generic trcer initial values can "//& - "be found, or an empty string for internal initialization.", & - default=" ") - if ((len_trim(CS%IC_file) > 0) .and. (scan(CS%IC_file,'/') == 0)) then - ! Add the directory if CS%IC_file is not already a complete path. - call get_param(param_file, sub_name, "INPUTDIR", inputdir, default=".") - CS%IC_file = trim(slasher(inputdir))//trim(CS%IC_file) - call log_param(param_file, sub_name, "INPUTDIR/GENERIC_TRACER_IC_FILE", CS%IC_file) - endif - call get_param(param_file, sub_name, "GENERIC_TRACER_IC_FILE_IS_Z", CS%Z_IC_file, & - "If true, GENERIC_TRACER_IC_FILE is in depth space, not "//& - "layer space.",default=.false.) - call get_param(param_file, sub_name, "TRACERS_MAY_REINIT", CS%tracers_may_reinit, & - "If true, tracers may go through the initialization code "//& - "if they are not found in the restart files. Otherwise "//& - "it is a fatal error if tracers are not found in the "//& - "restart files of a restarted run.", default=.false.) - - CS%restart_CSp => restart_CS - - - ntau=1 ! MOM needs the fields at only one time step - - - ! At this point G%mask2dT and CS%diag%axesTL are not allocated. - ! postpone diag_registeration to initialize_MOM_generic_tracer - - !Fields cannot be diag registered as they are allocated and have to registered later. - grid_tmask(:,:,:) = 0.0 - grid_kmt(:,:) = 0.0 - axes(:) = -1 - - ! - ! Initialize all generic tracers - ! - call generic_tracer_init(HI%isc,HI%iec,HI%jsc,HI%jec,HI%isd,HI%ied,HI%jsd,HI%jed,& - GV%ke,ntau,axes,grid_tmask,grid_kmt,set_time(0,0)) - - - ! - ! MOM-register the generic tracers - ! - - !Get the tracer list - call generic_tracer_get_list(CS%g_tracer_list) - if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL, trim(sub_name)//& - ": No tracer in the list.") - ! For each tracer name get its T_prog index and get its fields - - g_tracer=>CS%g_tracer_list - do - call g_tracer_get_alias(g_tracer,g_tracer_name) - - call g_tracer_get_pointer(g_tracer,g_tracer_name,'field',tr_field) - call g_tracer_get_values(g_tracer,g_tracer_name,'longname', longname) - call g_tracer_get_values(g_tracer,g_tracer_name,'units',units ) - - !!nnz: MOM field is 3D. Does this affect performance? Need it be override field? - tr_ptr => tr_field(:,:,:,1) - ! Register prognastic tracer for horizontal advection, diffusion, and restarts. - if (g_tracer_is_prog(g_tracer)) then - call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & - name=g_tracer_name, longname=longname, units=units, & - registry_diags=.false., & !### CHANGE TO TRUE? - restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) - else - call register_restart_field(tr_ptr, g_tracer_name, .not.CS%tracers_may_reinit, & - restart_CS, longname=longname, units=units) - endif - - !traverse the linked list till hit NULL - call g_tracer_get_next(g_tracer, g_tracer_next) - if (.NOT. associated(g_tracer_next)) exit - g_tracer=>g_tracer_next - - enddo - - register_MOM_generic_tracer = .true. - end function register_MOM_generic_tracer - - !> Initialize phase II: Initialize required variables for generic tracers - !! There are some steps of initialization that cannot be done in register_MOM_generic_tracer - !! This is the place and time to do them: - !! Set the grid mask and initial time for all generic tracers. - !! Diag_register them. - !! Z_diag_register them. - !! - !! This subroutine initializes the NTR tracer fields in tr(:,:,:,:) - !! and it sets up the tracer output. - subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, diag, OBC, CS, & - sponge_CSp, ALE_sponge_CSp) - logical, intent(in) :: restart !< .true. if the fields have already been - !! read from a restart file. - type(time_type), target, intent(in) :: day !< Time of the start of the run. - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(in) :: diag !< Regulates diagnostic output. - type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies whether, - !! where, and what open boundary conditions are used. - type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. - type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. - type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< Pointer to the control structure for the - !! ALE sponges. - - character(len=128), parameter :: sub_name = 'initialize_MOM_generic_tracer' - logical :: OK - integer :: i, j, k, isc, iec, jsc, jec, nk - type(g_tracer_type), pointer :: g_tracer,g_tracer_next - character(len=fm_string_len) :: g_tracer_name - real, dimension(:,:,:,:), pointer :: tr_field - real, dimension(:,:,:), pointer :: tr_ptr - real, dimension(G%isd:G%ied, G%jsd:G%jed, 1:GV%ke) :: grid_tmask - integer, dimension(G%isd:G%ied, G%jsd:G%jed) :: grid_kmt - - !! 2010/02/04 Add code to re-initialize Generic Tracers if needed during a model simulation - !! By default, restart cpio should not contain a Generic Tracer IC file and step below will be skipped. - !! Ideally, the generic tracer IC file should have the tracers on Z levels. - - isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = GV%ke - - CS%diag=>diag - !Get the tracer list - if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL, trim(sub_name)//& - ": No tracer in the list.") - !For each tracer name get its fields - g_tracer=>CS%g_tracer_list - - do - if (INDEX(CS%IC_file, '_NULL_') /= 0) then - call MOM_error(WARNING, "The name of the IC_file "//trim(CS%IC_file)//& - " indicates no MOM initialization was asked for the generic tracers."//& - "Bypassing the MOM initialization of ALL generic tracers!") - exit - endif - call g_tracer_get_alias(g_tracer,g_tracer_name) - call g_tracer_get_pointer(g_tracer,g_tracer_name,'field',tr_field) - tr_ptr => tr_field(:,:,:,1) - - if (.not.restart .or. (CS%tracers_may_reinit .and. & - .not.query_initialized(tr_ptr, g_tracer_name, CS%restart_CSp))) then - - if (g_tracer%requires_src_info ) then - call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& - "initializing generic tracer "//trim(g_tracer_name)//& - " using MOM_initialize_tracer_from_Z ") - - call MOM_initialize_tracer_from_Z(h, tr_ptr, G, GV, US, param_file, & - src_file = g_tracer%src_file, & - src_var_nam = g_tracer%src_var_name, & - src_var_unit_conversion = g_tracer%src_var_unit_conversion,& - src_var_record = g_tracer%src_var_record, & - src_var_gridspec = g_tracer%src_var_gridspec ) - - !Check/apply the bounds for each g_tracer - do k=1,nk ; do j=jsc,jec ; do i=isc,iec - if (tr_ptr(i,j,k) /= CS%tracer_land_val) then - if (tr_ptr(i,j,k) < g_tracer%src_var_valid_min) tr_ptr(i,j,k) = g_tracer%src_var_valid_min - !Jasmin does not want to apply the maximum for now - !if (tr_ptr(i,j,k) > g_tracer%src_var_valid_max) tr_ptr(i,j,k) = g_tracer%src_var_valid_max - endif - enddo ; enddo ; enddo - - !jgj: Reset CASED to 0 below K=1 - if ( (trim(g_tracer_name) == 'cased') .or. (trim(g_tracer_name) == 'ca13csed') ) then - do k=2,nk ; do j=jsc,jec ; do i=isc,iec - if (tr_ptr(i,j,k) /= CS%tracer_land_val) then - tr_ptr(i,j,k) = 0.0 - endif - enddo ; enddo ; enddo - endif - elseif(.not. g_tracer%requires_restart) then - !Do nothing for this tracer, it is initialized by the tracer package - call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& - "skip initialization of generic tracer "//trim(g_tracer_name)) - else !Do it old way if the tracer is not registered to start from a specific source file. - !This path should be deprecated if all generic tracers are required to start from specified sources. - if (len_trim(CS%IC_file) > 0) then - ! Read the tracer concentrations from a netcdf file. - if (.not.file_exists(CS%IC_file)) call MOM_error(FATAL, & - "initialize_MOM_Generic_tracer: Unable to open "//CS%IC_file) - if (CS%Z_IC_file) then - OK = tracer_Z_init(tr_ptr, h, CS%IC_file, g_tracer_name, G, GV, US) - if (.not.OK) then - OK = tracer_Z_init(tr_ptr, h, CS%IC_file, trim(g_tracer_name), G, GV, US) - if (.not.OK) call MOM_error(FATAL,"initialize_MOM_Generic_tracer: "//& - "Unable to read "//trim(g_tracer_name)//" from "//& - trim(CS%IC_file)//".") - endif - call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& - "initialized generic tracer "//trim(g_tracer_name)//& - " using Generic Tracer File on Z: "//CS%IC_file) - else - ! native grid - call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& - "Using Generic Tracer IC file on native grid "//trim(CS%IC_file)//& - " for tracer "//trim(g_tracer_name)) - call MOM_read_data(CS%IC_file, trim(g_tracer_name), tr_ptr, G%Domain) - endif - else - call MOM_error(FATAL,"initialize_MOM_generic_tracer: "//& - "check Generic Tracer IC filename "//trim(CS%IC_file)//& - " for tracer "//trim(g_tracer_name)) - endif - - endif - endif - - !traverse the linked list till hit NULL - call g_tracer_get_next(g_tracer, g_tracer_next) - if (.NOT. associated(g_tracer_next)) exit - g_tracer=>g_tracer_next - enddo - !! end section to re-initialize generic tracers - - - !Now we can reset the grid mask, axes and time to their true values - !Note that grid_tmask must be set correctly on the data domain boundary - !so that coast mask can be deduced from it. - grid_tmask(:,:,:) = 0.0 - grid_kmt(:,:) = 0 - do j = G%jsd, G%jed ; do i = G%isd, G%ied - if (G%mask2dT(i,j) > 0) then - grid_tmask(i,j,:) = 1.0 - grid_kmt(i,j) = GV%ke ! Tell the code that a layer thicker than 1m is the bottom layer. - endif - enddo ; enddo - call g_tracer_set_common(G%isc,G%iec,G%jsc,G%jec,G%isd,G%ied,G%jsd,G%jed,& - GV%ke,1,CS%diag%axesTL%handles,grid_tmask,grid_kmt,day) - - ! Register generic tracer modules diagnostics - -#ifdef _USE_MOM6_DIAG - call g_tracer_set_csdiag(CS%diag) -#endif - call generic_tracer_register_diag() -#ifdef _USE_MOM6_DIAG - call g_tracer_set_csdiag(CS%diag) -#endif - - CS%H_to_m = GV%H_to_m - - end subroutine initialize_MOM_generic_tracer - - !> Column physics for generic tracers. - !! Get the coupler values for generic tracers that exchange with atmosphere - !! Update generic tracer concentration fields from sources and sinks. - !! Vertically diffuse generic tracer concentration fields. - !! Update generic tracers from bottom and their bottom reservoir. - !! - !! This subroutine applies diapycnal diffusion and any other column - !! tracer physics or chemistry to the tracers from this file. - !! CFCs are relatively simple, as they are passive tracers. with only a surface - !! flux as a source. - subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, US, CS, tv, optics, & - evap_CFL_limit, minimum_forcing_depth) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h_new !< Layer thickness after entrainment [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: ea !< The amount of fluid entrained from the layer - !! above during this call [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: eb !< The amount of fluid entrained from the layer - !! below during this call [H ~> m or kg m-2]. - type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic - !! and tracer forcing fields. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Hml !< Mixed layer depth [Z ~> m] - real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - type(optics_type), intent(in) :: optics !< The structure containing optical properties. - real, optional, intent(in) :: evap_CFL_limit !< Limits how much water can be fluxed out of - !! the top layer Stored previously in diabatic CS. - real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which fluxes - !! can be applied [H ~> m or kg m-2] - ! Stored previously in diabatic CS. - ! The arguments to this subroutine are redundant in that - ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) - - ! Local variables - character(len=128), parameter :: sub_name = 'MOM_generic_tracer_column_physics' - - type(g_tracer_type), pointer :: g_tracer, g_tracer_next - character(len=fm_string_len) :: g_tracer_name - real, dimension(:,:), pointer :: stf_array,trunoff_array,runoff_tracer_flux_array - - real :: surface_field(SZI_(G),SZJ_(G)) - real :: dz_ml(SZI_(G),SZJ_(G)) ! The mixed layer depth in the MKS units used for generic tracers [m] - real :: sosga - - real, dimension(G%isd:G%ied,G%jsd:G%jed,GV%ke) :: rho_dzt, dzt - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work - integer :: i, j, k, isc, iec, jsc, jec, nk - - isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = GV%ke - - !Get the tracer list - if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL,& - trim(sub_name)//": No tracer in the list.") - -#ifdef _USE_MOM6_DIAG - call g_tracer_set_csdiag(CS%diag) -#endif - - ! - !Extract the tracer surface fields from coupler and update tracer fields from sources - ! - !call generic_tracer_coupler_get(fluxes%tr_fluxes) - !Niki: This is moved out to ocean_model_MOM.F90 because if dt_therm>dt_cpld we need to average - ! the fluxes without coming into this subroutine. - ! MOM5 has to modified to conform. - - ! - !Add contribution of river to surface flux - ! - g_tracer=>CS%g_tracer_list - do - if (_ALLOCATED(g_tracer%trunoff)) then - call g_tracer_get_alias(g_tracer,g_tracer_name) - call g_tracer_get_pointer(g_tracer,g_tracer_name,'stf', stf_array) - call g_tracer_get_pointer(g_tracer,g_tracer_name,'trunoff',trunoff_array) - call g_tracer_get_pointer(g_tracer,g_tracer_name,'runoff_tracer_flux',runoff_tracer_flux_array) - !nnz: Why is fluxes%river = 0? - runoff_tracer_flux_array(:,:) = trunoff_array(:,:) * & - US%RZ_T_to_kg_m2s*fluxes%lrunoff(:,:) - stf_array = stf_array + runoff_tracer_flux_array - endif - - !traverse the linked list till hit NULL - call g_tracer_get_next(g_tracer, g_tracer_next) - if (.NOT. associated(g_tracer_next)) exit - g_tracer=>g_tracer_next - - enddo - - ! - !Prepare input arrays for source update - ! - - rho_dzt(:,:,:) = GV%H_to_kg_m2 * GV%Angstrom_H - do k = 1, nk ; do j = jsc, jec ; do i = isc, iec !{ - rho_dzt(i,j,k) = GV%H_to_kg_m2 * h_old(i,j,k) - enddo ; enddo ; enddo !} - - dzt(:,:,:) = 1.0 - do k = 1, nk ; do j = jsc, jec ; do i = isc, iec !{ - dzt(i,j,k) = GV%H_to_m * h_old(i,j,k) - enddo ; enddo ; enddo !} - dz_ml(:,:) = 0.0 - do j=jsc,jec ; do i=isc,iec - surface_field(i,j) = tv%S(i,j,1) - dz_ml(i,j) = US%Z_to_m * Hml(i,j) - enddo ; enddo - sosga = global_area_mean(surface_field, G) - - ! - !Calculate tendencies (i.e., field changes at dt) from the sources / sinks - ! - if ((US%L_to_m == 1.0) .and. (US%RZ_to_kg_m2 == 1.0) .and. (US%s_to_T == 1.0)) then - ! Avoid unnecessary copies when no unit conversion is needed. - call generic_tracer_source(tv%T, tv%S, rho_dzt, dzt, dz_ml, G%isd, G%jsd, 1, dt, & - G%areaT, get_diag_time_end(CS%diag), & - optics%nbands, optics%max_wavelength_band, optics%sw_pen_band, optics%opacity_band, & - internal_heat=tv%internal_heat, frunoff=fluxes%frunoff, sosga=sosga) - else - call generic_tracer_source(tv%T, tv%S, rho_dzt, dzt, dz_ml, G%isd, G%jsd, 1, US%T_to_s*dt, & - US%L_to_m**2*G%areaT(:,:), get_diag_time_end(CS%diag), & - optics%nbands, optics%max_wavelength_band, optics%sw_pen_band, optics%opacity_band, & - internal_heat=US%RZ_to_kg_m2*tv%internal_heat(:,:), & - frunoff=US%RZ_T_to_kg_m2s*fluxes%frunoff(:,:), sosga=sosga) - endif - - ! This uses applyTracerBoundaryFluxesInOut to handle the change in tracer due to freshwater fluxes - ! usually in ALE mode - if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then - g_tracer=>CS%g_tracer_list - do - if (g_tracer_is_prog(g_tracer)) then - do k=1,nk ;do j=jsc,jec ; do i=isc,iec - h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo - call applyTracerBoundaryFluxesInOut(G, GV, g_tracer%field(:,:,:,1), dt, & - fluxes, h_work, evap_CFL_limit, minimum_forcing_depth) - endif - - !traverse the linked list till hit NULL - call g_tracer_get_next(g_tracer, g_tracer_next) - if (.NOT. associated(g_tracer_next)) exit - g_tracer=>g_tracer_next - enddo - endif - - ! - !Update Tr(n)%field from explicit vertical diffusion - ! - ! Use a tridiagonal solver to determine the concentrations after the - ! surface source is applied and diapycnal advection and diffusion occurs. - if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then - ! Last arg is tau which is always 1 for MOM6 - call generic_tracer_vertdiff_G(h_work, ea, eb, US%T_to_s*dt, GV%kg_m2_to_H, GV%m_to_H, 1) - else - ! Last arg is tau which is always 1 for MOM6 - call generic_tracer_vertdiff_G(h_old, ea, eb, US%T_to_s*dt, GV%kg_m2_to_H, GV%m_to_H, 1) - endif - - ! Update bottom fields after vertical processes - - ! Second arg is tau which is always 1 for MOM6 - call generic_tracer_update_from_bottom(US%T_to_s*dt, 1, get_diag_time_end(CS%diag)) - - !Output diagnostics via diag_manager for all generic tracers and their fluxes - call g_tracer_send_diag(CS%g_tracer_list, get_diag_time_end(CS%diag), tau=1) -#ifdef _USE_MOM6_DIAG - call g_tracer_set_csdiag(CS%diag) -#endif - - end subroutine MOM_generic_tracer_column_physics - - !> This subroutine calculates mass-weighted integral on the PE either - !! of all available tracer concentrations, or of a tracer that is - !! being requested specifically, returning the number of stocks it has - !! calculated. If the stock_index is present, only the stock corresponding - !! to that coded index is returned. - function MOM_generic_tracer_stock(h, stocks, G, GV, US, CS, names, units, stock_index) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each - !! tracer, in kg times concentration units [kg conc]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. - character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. - character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. - integer, optional, intent(in) :: stock_index !< The coded index of a specific stock - !! being sought. - integer :: MOM_generic_tracer_stock !< Return value, the - !! number of stocks calculated here. - - ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] - type(g_tracer_type), pointer :: g_tracer, g_tracer_next - real, dimension(:,:,:,:), pointer :: tr_field - real, dimension(:,:,:), pointer :: tr_ptr - character(len=128), parameter :: sub_name = 'MOM_generic_tracer_stock' - - integer :: i, j, k, is, ie, js, je, nz, m - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - - MOM_generic_tracer_stock = 0 - if (.not.associated(CS)) return - - if (present(stock_index)) then ; if (stock_index > 0) then - ! Check whether this stock is available from this routine. - - ! No stocks from this routine are being checked yet. Return 0. - return - endif ; endif - - if (.NOT. associated(CS%g_tracer_list)) return ! No stocks. - - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 - m=1 ; g_tracer=>CS%g_tracer_list - do - call g_tracer_get_alias(g_tracer,names(m)) - call g_tracer_get_values(g_tracer,names(m),'units',units(m)) - units(m) = trim(units(m))//" kg" - call g_tracer_get_pointer(g_tracer,names(m),'field',tr_field) - - stocks(m) = 0.0 - tr_ptr => tr_field(:,:,:,1) - do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + tr_ptr(i,j,k) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) - enddo ; enddo ; enddo - stocks(m) = stock_scale * stocks(m) - - !traverse the linked list till hit NULL - call g_tracer_get_next(g_tracer, g_tracer_next) - if (.NOT. associated(g_tracer_next)) exit - g_tracer=>g_tracer_next - m = m+1 - enddo - - MOM_generic_tracer_stock = m - - end function MOM_generic_tracer_stock - - !> This subroutine find the global min and max of either of all - !! available tracer concentrations, or of a tracer that is being - !! requested specifically, returning the number of tracers it has gone through. - function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, ygmin, zgmin, & - xgmax, ygmax, zgmax , G, CS, names, units) - integer, intent(in) :: ind_start !< The index of the tracer to start with - logical, dimension(:), intent(out) :: got_minmax !< Indicates whether the global min and - !! max are found for each tracer - real, dimension(:), intent(out) :: gmin !< Global minimum of each tracer, in kg - !! times concentration units. - real, dimension(:), intent(out) :: gmax !< Global maximum of each tracer, in kg - !! times concentration units. - real, dimension(:), intent(out) :: xgmin !< The x-position of the global minimum - real, dimension(:), intent(out) :: ygmin !< The y-position of the global minimum - real, dimension(:), intent(out) :: zgmin !< The z-position of the global minimum - real, dimension(:), intent(out) :: xgmax !< The x-position of the global maximum - real, dimension(:), intent(out) :: ygmax !< The y-position of the global maximum - real, dimension(:), intent(out) :: zgmax !< The z-position of the global maximum - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. - character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. - character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. - integer :: MOM_generic_tracer_min_max !< Return value, the - !! number of tracers done here. - -! Local variables - type(g_tracer_type), pointer :: g_tracer, g_tracer_next - real, dimension(:,:,:,:), pointer :: tr_field - real, dimension(:,:,:), pointer :: tr_ptr - character(len=128), parameter :: sub_name = 'MOM_generic_tracer_min_max' - - real, dimension(:,:,:),pointer :: grid_tmask - integer :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau - - integer :: i, j, k, is, ie, js, je, m - real, allocatable, dimension(:) :: geo_z - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - - MOM_generic_tracer_min_max = 0 - if (.not.associated(CS)) return - - if (.NOT. associated(CS%g_tracer_list)) return ! No stocks. - - - call g_tracer_get_common(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,grid_tmask=grid_tmask) - - ! Because the use of a simple z-coordinate can not be assumed, simply - ! use the layer index as the vertical label. - allocate(geo_z(nk)) - do k=1,nk ; geo_z(k) = real(k) ; enddo - - m=ind_start ; g_tracer=>CS%g_tracer_list - do - call g_tracer_get_alias(g_tracer,names(m)) - call g_tracer_get_values(g_tracer,names(m),'units',units(m)) - units(m) = trim(units(m))//" kg" - call g_tracer_get_pointer(g_tracer,names(m),'field',tr_field) - - gmin(m) = -1.0 - gmax(m) = -1.0 - - tr_ptr => tr_field(:,:,:,1) - - call array_global_min_max(tr_ptr, grid_tmask, isd, jsd, isc, iec, jsc, jec, nk, gmin(m), gmax(m), & - G%geoLonT, G%geoLatT, geo_z, xgmin(m), ygmin(m), zgmin(m), & - xgmax(m), ygmax(m), zgmax(m)) - - got_minmax(m) = .true. - - !traverse the linked list till hit NULL - call g_tracer_get_next(g_tracer, g_tracer_next) - if (.NOT. associated(g_tracer_next)) exit - g_tracer=>g_tracer_next - m = m+1 - enddo - - MOM_generic_tracer_min_max = m - - end function MOM_generic_tracer_min_max - - !> Find the global maximum and minimum of a tracer array and return the locations of the extrema. - subroutine array_global_min_max(tr_array, tmask, isd, jsd, isc, iec, jsc, jec, nk, g_min, g_max, & - geo_x, geo_y, geo_z, xgmin, ygmin, zgmin, xgmax, ygmax, zgmax) - integer, intent(in) :: isd !< The starting data domain i-index - integer, intent(in) :: jsd !< The starting data domain j-index - real, dimension(isd:,jsd:,:), intent(in) :: tr_array !< The tracer array to search for extrema - real, dimension(isd:,jsd:,:), intent(in) :: tmask !< A mask that is 0 for points to exclude - integer, intent(in) :: isc !< The starting compute domain i-index - integer, intent(in) :: iec !< The ending compute domain i-index - integer, intent(in) :: jsc !< The starting compute domain j-index - integer, intent(in) :: jec !< The ending compute domain j-index - integer, intent(in) :: nk !< The number of vertical levels - real, intent(out) :: g_min !< The global minimum of tr_array - real, intent(out) :: g_max !< The global maximum of tr_array - real, dimension(isd:,jsd:), intent(in) :: geo_x !< The geographic x-positions of points - real, dimension(isd:,jsd:), intent(in) :: geo_y !< The geographic y-positions of points - real, dimension(:), intent(in) :: geo_z !< The vertical pseudo-positions of points - real, intent(out) :: xgmin !< The x-position of the global minimum - real, intent(out) :: ygmin !< The y-position of the global minimum - real, intent(out) :: zgmin !< The z-position of the global minimum - real, intent(out) :: xgmax !< The x-position of the global maximum - real, intent(out) :: ygmax !< The y-position of the global maximum - real, intent(out) :: zgmax !< The z-position of the global maximum - - ! This subroutine is an exact transcription (bugs and all) of mpp_array_global_min_max() - ! from the version in FMS/mpp/mpp_utilities.F90, but with some whitespace changes to match - ! MOM6 code styles and to use infrastructure routines via the MOM6 framework code, and with - ! added comments to document its arguments.i - - !### The obvious problems with this routine as currently written include: - ! 1. It does not return exactly the maximum and minimum values. - ! 2. The reported maximum and minimum are dependent on PE count and layout. - ! 3. For all-zero arrays, the reported maxima scale with the PE_count - ! 4. For arrays with a large enough offset or scaling, so that the magnitude of values exceed - ! 1e10, the values it returns are simply wrong. - ! 5. The results do not scale appropriately if the argument is rescaled. - ! 6. The extrema and locations are not rotationally invariant. - ! 7. It is inefficient because it uses 8 blocking global reduction calls when it could use just 2 or 3. - - ! Local variables - real :: tmax, tmin ! Maximum and minimum tracer values, in the same units as tr_array - real :: tmax0, tmin0 ! First-guest values of tmax and tmin. - integer :: itmax, jtmax, ktmax, itmin, jtmin, ktmin - integer :: igmax, jgmax, kgmax, igmin, jgmin, kgmin - real :: fudge ! A factor that is close to 1 that is used to find the location of the extrema. - - ! arrays to enable vectorization - integer :: iminarr(3), imaxarr(3) - - !### These dimensional constant values mean that the results can not be guaranteed to be rescalable. - g_min = -88888888888.0 ; g_max = -999999999.0 - tmax = -1.e10 ; tmin = 1.e10 - itmax = 0 ; jtmax = 0 ; ktmax = 0 - itmin = 0 ; jtmin = 0 ; ktmin = 0 - - if (ANY(tmask(isc:iec,jsc:jec,:) > 0.)) then - ! Vectorized using maxloc() and minloc() intrinsic functions by Russell.Fiedler@csiro.au. - iminarr = minloc(tr_array(isc:iec,jsc:jec,:), (tmask(isc:iec,jsc:jec,:) > 0.)) - imaxarr = maxloc(tr_array(isc:iec,jsc:jec,:), (tmask(isc:iec,jsc:jec,:) > 0.)) - itmin = iminarr(1)+isc-1 - jtmin = iminarr(2)+jsc-1 - ktmin = iminarr(3) - itmax = imaxarr(1)+isc-1 - jtmax = imaxarr(2)+jsc-1 - ktmax = imaxarr(3) - tmin = tr_array(itmin,jtmin,ktmin) - tmax = tr_array(itmax,jtmax,ktmax) - end if - - ! use "fudge" to distinguish processors when tracer extreme is independent of processor - !### This fudge factor is not independent of PE layout, and while it mostly works for finding - ! a positive maximum or a negative minimum, it could miss the true extrema in the opposite - ! cases, for which the fudge factor should be slightly reduced. The fudge factor should - ! be based on global index-space conventions, which are decomposition invariant, and - ! not the PE-number! - fudge = 1.0 + 1.e-12*real(PE_here() ) - tmax = tmax*fudge - tmin = tmin*fudge - if (tmax == 0.0) then - tmax = tmax + 1.e-12*real(PE_here() ) - endif - if (tmin == 0.0) then - tmin = tmin + 1.e-12*real(PE_here() ) - endif - - tmax0 = tmax ; tmin0 = tmin - - call max_across_PEs(tmax) - call min_across_PEs(tmin) - - g_max = tmax - g_min = tmin - - ! Now find the location of the global extrema. - ! - ! Note that the fudge factor above guarantees that the location of max (min) is uinque, - ! since tmax0 (tmin0) has slightly different values on each processor. - ! Otherwise, the function tr_array(i,j,k) could be equal to global max (min) at more - ! than one point in space and this would be a much more difficult problem to solve. - ! - !-999 on all current PE's - xgmax = -999. ; ygmax = -999. ; zgmax = -999. - xgmin = -999. ; ygmin = -999. ; zgmin = -999. - - if (tmax0 == tmax) then !This happens ONLY on ONE processor because of fudge factor above. - xgmax = geo_x(itmax,jtmax) - ygmax = geo_y(itmax,jtmax) - zgmax = geo_z(ktmax) - endif - - !### These three calls and the three calls that follow in about 10 lines should be combined - ! into a single call for efficiency. - call max_across_PEs(xgmax) - call max_across_PEs(ygmax) - call max_across_PEs(zgmax) - - if (tmin0 == tmin) then !This happens ONLY on ONE processor because of fudge factor above. - xgmin = geo_x(itmin,jtmin) - ygmin = geo_y(itmin,jtmin) - zgmin = geo_z(ktmin) - endif - - call max_across_PEs(xgmin) - call max_across_PEs(ygmin) - call max_across_PEs(zgmin) - - end subroutine array_global_min_max - - !> This subroutine calculates the surface state and sets coupler values for - !! those generic tracers that have flux exchange with atmosphere. - !! - !! This subroutine sets up the fields that the coupler needs to calculate the - !! CFC fluxes between the ocean and atmosphere. - subroutine MOM_generic_tracer_surface_state(sfc_state, h, G, GV, CS) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. - -! Local variables - real :: sosga - - character(len=128), parameter :: sub_name = 'MOM_generic_tracer_surface_state' - real, dimension(G%isd:G%ied,G%jsd:G%jed,1:GV%ke,1) :: rho0 - real, dimension(G%isd:G%ied,G%jsd:G%jed,1:GV%ke) :: dzt - type(g_tracer_type), pointer :: g_tracer - - !Set coupler values - !nnz: fake rho0 - rho0=1.0 - - dzt(:,:,:) = CS%H_to_m * h(:,:,:) - - sosga = global_area_mean(sfc_state%SSS, G) - - call generic_tracer_coupler_set(sfc_state%tr_fields,& - ST=sfc_state%SST,& - SS=sfc_state%SSS,& - rho=rho0,& !nnz: required for MOM5 and previous versions. - ilb=G%isd, jlb=G%jsd,& - dzt=dzt,& !This is needed for the Mocsy method of carbonate system vars - tau=1,sosga=sosga,model_time=get_diag_time_end(CS%diag)) - - !Output diagnostics via diag_manager for all tracers in this module -! if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL, trim(sub_name)//& -! "No tracer in the list.") -! call g_tracer_send_diag(CS%g_tracer_list, get_diag_time_end(CS%diag), tau=1) - !Niki: The problem with calling diagnostic outputs here is that this subroutine is called every dt_cpld - ! hence if dt_therm > dt_cpld we get output (and contribution to the mean) at times that tracers - ! had not been updated. - ! Moving this to the end of column physics subrotuine fixes this issue. - - end subroutine MOM_generic_tracer_surface_state - -!ALL PE subroutine on Ocean! Due to otpm design the fluxes should be initialized like this on ALL PE's! - subroutine MOM_generic_flux_init(verbosity) - integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity. - - integer :: ind - character(len=fm_string_len) :: g_tracer_name,longname, package,units,old_package,file_in,file_out - real :: const_init_value - character(len=128), parameter :: sub_name = 'MOM_generic_flux_init' - type(g_tracer_type), pointer :: g_tracer_list,g_tracer,g_tracer_next - - if (.not. g_registered) then - call generic_tracer_register() - g_registered = .true. - endif - - call generic_tracer_get_list(g_tracer_list) - if (.NOT. associated(g_tracer_list)) then - call MOM_error(WARNING, trim(sub_name)// ": No generic tracer in the list.") - return - endif - - g_tracer=>g_tracer_list - do - - call g_tracer_flux_init(g_tracer) !, verbosity=verbosity) !### Add this after ocean shared is updated. - - ! traverse the linked list till hit NULL - call g_tracer_get_next(g_tracer, g_tracer_next) - if (.NOT. associated(g_tracer_next)) exit - g_tracer=>g_tracer_next - - enddo - - end subroutine MOM_generic_flux_init - - subroutine MOM_generic_tracer_fluxes_accumulate(flux_tmp, weight) - type(forcing), intent(in) :: flux_tmp !< A structure containing pointers to - !! thermodynamic and tracer forcing fields. - real, intent(in) :: weight !< A weight for accumulating this flux - - call generic_tracer_coupler_accumulate(flux_tmp%tr_fluxes, weight) - - end subroutine MOM_generic_tracer_fluxes_accumulate - - !> Copy the requested tracer into an array. - subroutine MOM_generic_tracer_get(name,member,array, CS) - character(len=*), intent(in) :: name !< Name of requested tracer. - character(len=*), intent(in) :: member !< The tracer element to return. - real, dimension(:,:,:), intent(out) :: array !< Array filled by this routine. - type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. - - real, dimension(:,:,:), pointer :: array_ptr - character(len=128), parameter :: sub_name = 'MOM_generic_tracer_get' - - call g_tracer_get_pointer(CS%g_tracer_list,name,member,array_ptr) - array(:,:,:) = array_ptr(:,:,:) - - end subroutine MOM_generic_tracer_get - - !> This subroutine deallocates the memory owned by this module. - subroutine end_MOM_generic_tracer(CS) - type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. - - call generic_tracer_end() - - if (associated(CS)) then - deallocate(CS) - endif - end subroutine end_MOM_generic_tracer - -!---------------------------------------------------------------- -! Niki Zadeh -! -! -! William Cooke -! -! -! -! This module drives the generic version of tracers TOPAZ and CFC -! -!---------------------------------------------------------------- - -end module MOM_generic_tracer diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_hor_bnd_diffusion.F90 similarity index 65% rename from src/tracer/MOM_lateral_boundary_diffusion.F90 rename to src/tracer/MOM_hor_bnd_diffusion.F90 index c11bc9856c..40a2db5899 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_hor_bnd_diffusion.F90 @@ -1,25 +1,28 @@ -!> Calculates and applies diffusive fluxes as a parameterization of lateral mixing (non-neutral) by -!! mesoscale eddies near the top and bottom (to be implemented) boundary layers of the ocean. +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 -module MOM_lateral_boundary_diffusion +!> Calculates and applies diffusive fluxes as a parameterization of horizontal mixing (non-neutral) by +!! mesoscale eddies near the top and bottom (to be implemented) boundary layers of the ocean. -! This file is part of MOM6. See LICENSE.md for the license. +module MOM_hor_bnd_diffusion use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE use MOM_checksums, only : hchksum -use MOM_domains, only : pass_var, sum_across_PEs +use MOM_domains, only : pass_var use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_diag_mediator, only : post_data, register_diag_field -use MOM_diag_vkernels, only : reintegrate_column -use MOM_error_handler, only : MOM_error, FATAL, is_root_pe +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_remapping, only : remapping_CS, initialize_remapping +use MOM_remapping, only : remapping_CS, initialize_remapping, reintegrate_column use MOM_remapping, only : extract_member_remapping_CS, remapping_core_h use MOM_remapping, only : remappingSchemesDoc, remappingDefaultScheme +use MOM_spatial_means, only : global_mass_integral use MOM_tracer_registry, only : tracer_registry_type, tracer_type use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : vertvisc_type use MOM_verticalGrid, only : verticalGrid_type use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS @@ -28,18 +31,19 @@ module MOM_lateral_boundary_diffusion implicit none ; private -public near_boundary_unit_tests, lateral_boundary_diffusion, lateral_boundary_diffusion_init -public boundary_k_range +public near_boundary_unit_tests, hor_bnd_diffusion, hor_bnd_diffusion_init +public boundary_k_range, hor_bnd_diffusion_end ! Private parameters to avoid doing string comparisons for bottom or top boundary layer -integer, public, parameter :: SURFACE = -1 !< Set a value that corresponds to the surface bopundary +integer, public, parameter :: SURFACE = -1 !< Set a value that corresponds to the surface boundary integer, public, parameter :: BOTTOM = 1 !< Set a value that corresponds to the bottom boundary #include -!> Sets parameters for lateral boundary mixing module. -type, public :: lbd_CS ; private +!> Sets parameters for horizontal boundary mixing module. +type, public :: hbd_CS ; private logical :: debug !< If true, write verbose checksums for debugging. integer :: deg !< Degree of polynomial reconstruction. + integer :: hbd_nk !< Maximum number of levels in the HBD grid [nondim] integer :: surface_boundary_scheme !< Which boundary layer scheme to use !! 1. ePBL; 2. KPP logical :: limiter !< Controls whether a flux limiter is applied in the @@ -51,51 +55,60 @@ module MOM_lateral_boundary_diffusion real :: H_subroundoff !< A thickness that is so small that it can be added to a thickness of !! Angstrom or larger without changing it at the bit level [H ~> m or kg m-2]. !! If Angstrom is 0 or exceedingly small, this is negligible compared to 1e-17 m. + ! HBD dynamic grids + real, allocatable, dimension(:,:,:) :: hbd_grd_u !< HBD thicknesses at t-points adjacent to + !! u-points [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: hbd_grd_v !< HBD thicknesses at t-points adjacent to + !! v-points (left and right) [H ~> m or kg m-2] + integer, allocatable, dimension(:,:) :: hbd_u_kmax !< Maximum vertical index in hbd_grd_u [nondim] + integer, allocatable, dimension(:,:) :: hbd_v_kmax !< Maximum vertical index in hbd_grd_v [nondim] type(remapping_CS) :: remap_CS !< Control structure to hold remapping configuration. type(KPP_CS), pointer :: KPP_CSp => NULL() !< KPP control structure needed to get BLD. type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL() !< ePBL control structure needed to get BLD. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. -end type lbd_CS +end type hbd_CS ! This include declares and sets the variable "version". #include "version_variable.h" -character(len=40) :: mdl = "MOM_lateral_boundary_diffusion" !< Name of this module -integer :: id_clock_lbd !< CPU clock for lbd +character(len=40) :: mdl = "MOM_hor_bnd_diffusion" !< Name of this module +integer :: id_clock_hbd !< CPU clock for hbd contains !> Initialization routine that reads runtime parameters and sets up pointers to other control structures that might be -!! needed for lateral boundary diffusion. -logical function lateral_boundary_diffusion_init(Time, G, GV, param_file, diag, diabatic_CSp, CS) +!! needed for horizontal boundary diffusion. +logical function hor_bnd_diffusion_init(Time, G, GV, US, param_file, diag, diabatic_CSp, CS) type(time_type), target, intent(in) :: Time !< Time structure type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file structure type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(diabatic_CS), pointer :: diabatic_CSp !< KPP control structure needed to get BLD - type(lbd_CS), pointer :: CS !< Lateral boundary mixing control structure + type(hbd_CS), pointer :: CS !< Horizontal boundary mixing control structure ! local variables character(len=80) :: string ! Temporary strings - integer :: ke, nk ! Number of levels in the LBD and native grids, respectively - logical :: boundary_extrap ! controls if boundary extrapolation is used in the LBD code + logical :: boundary_extrap ! controls if boundary extrapolation is used in the HBD code + logical :: om4_remap_via_sub_cells ! Use the OM4-era ramap_via_sub_cells for HBD + logical :: debug !< If true, write verbose checksums for debugging purposes if (ASSOCIATED(CS)) then - call MOM_error(FATAL, "lateral_boundary_diffusion_init called with associated control structure.") + call MOM_error(FATAL, "hor_bnd_diffusion_init called with associated control structure.") return endif ! Log this module and master switch for turning it on/off - call get_param(param_file, mdl, "USE_LATERAL_BOUNDARY_DIFFUSION", lateral_boundary_diffusion_init, & + call get_param(param_file, mdl, "USE_HORIZONTAL_BOUNDARY_DIFFUSION", hor_bnd_diffusion_init, & default=.false., do_not_log=.true.) call log_version(param_file, mdl, version, & - "This module implements lateral diffusion of tracers near boundaries", & - all_default=.not.lateral_boundary_diffusion_init) - call get_param(param_file, mdl, "USE_LATERAL_BOUNDARY_DIFFUSION", lateral_boundary_diffusion_init, & - "If true, enables the lateral boundary tracer's diffusion module.", & + "This module implements horizontal diffusion of tracers near boundaries", & + all_default=.not.hor_bnd_diffusion_init) + call get_param(param_file, mdl, "USE_HORIZONTAL_BOUNDARY_DIFFUSION", hor_bnd_diffusion_init, & + "If true, enables the horizontal boundary tracer's diffusion module.", & default=.false.) - if (.not. lateral_boundary_diffusion_init) return + if (.not. hor_bnd_diffusion_init) return allocate(CS) CS%diag => diag @@ -103,56 +116,78 @@ logical function lateral_boundary_diffusion_init(Time, G, GV, param_file, diag, call extract_diabatic_member(diabatic_CSp, KPP_CSp=CS%KPP_CSp) call extract_diabatic_member(diabatic_CSp, energetic_PBL_CSp=CS%energetic_PBL_CSp) + ! max. number of vertical layers + CS%hbd_nk = 2 + (GV%ke*2) + ! allocate the hbd grids and k_max + allocate(CS%hbd_grd_u(SZIB_(G),SZJ_(G),CS%hbd_nk), source=0.0) + allocate(CS%hbd_grd_v(SZI_(G),SZJB_(G),CS%hbd_nk), source=0.0) + allocate(CS%hbd_u_kmax(SZIB_(G),SZJ_(G)), source=0) + allocate(CS%hbd_v_kmax(SZI_(G),SZJB_(G)), source=0) + CS%surface_boundary_scheme = -1 if ( .not. ASSOCIATED(CS%energetic_PBL_CSp) .and. .not. ASSOCIATED(CS%KPP_CSp) ) then - call MOM_error(FATAL,"Lateral boundary diffusion is true, but no valid boundary layer scheme was found") + call MOM_error(FATAL,"Horizontal boundary diffusion is true, but no valid boundary layer scheme was found") endif ! Read all relevant parameters and write them to the model log. - call get_param(param_file, mdl, "LBD_LINEAR_TRANSITION", CS%linear, & + call get_param(param_file, mdl, "HBD_LINEAR_TRANSITION", CS%linear, & "If True, apply a linear transition at the base/top of the boundary. \n"//& "The flux will be fully applied at k=k_min and zero at k=k_max.", default=.false.) call get_param(param_file, mdl, "APPLY_LIMITER", CS%limiter, & "If True, apply a flux limiter in the native grid.", default=.true.) call get_param(param_file, mdl, "APPLY_LIMITER_REMAP", CS%limiter_remap, & "If True, apply a flux limiter in the remapped grid.", default=.false.) - call get_param(param_file, mdl, "LBD_BOUNDARY_EXTRAP", boundary_extrap, & - "Use boundary extrapolation in LBD code", & + call get_param(param_file, mdl, "HBD_BOUNDARY_EXTRAP", boundary_extrap, & + "Use boundary extrapolation in HBD code", & default=.false.) - call get_param(param_file, mdl, "LBD_REMAPPING_SCHEME", string, & + call get_param(param_file, mdl, "HBD_REMAPPING_SCHEME", string, & "This sets the reconstruction scheme used "//& "for vertical remapping for all variables. "//& "It can be one of the following schemes: "//& trim(remappingSchemesDoc), default=remappingDefaultScheme) - call initialize_remapping( CS%remap_CS, string, boundary_extrapolation = boundary_extrap ,& - check_reconstruction = .false., check_remapping = .false., answers_2018 = .false.) + 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, "HBD_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for horizontal boundary diffusion. "//& + "See REMAPPING_USE_OM4_SUBCELLS for details. "//& + "We recommend setting this option to false.", default=om4_remap_via_sub_cells) + + ! 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., & + 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, "LBD_DEBUG", CS%debug, & - "If true, write out verbose debugging data in the LBD module.", & - default=.false.) + call get_param(param_file, mdl, "DEBUG", debug, & + default=.false., debuggingParam=.true., do_not_log=.true.) + call get_param(param_file, mdl, "HBD_DEBUG", CS%debug, & + "If true, write out verbose debugging data in the HBD module.", & + default=debug, debuggingParam=.true.) - id_clock_lbd = cpu_clock_id('(Ocean LBD)', grain=CLOCK_MODULE) + id_clock_hbd = cpu_clock_id('(Ocean HBD)', grain=CLOCK_MODULE) -end function lateral_boundary_diffusion_init +end function hor_bnd_diffusion_init -!> Driver routine for calculating lateral diffusive fluxes near the top and bottom boundaries. +!> Driver routine for calculating horizontal diffusive fluxes near the top and bottom boundaries. !! Diffusion is applied using only information from neighboring cells, as follows: -!! 1) remap tracer to a z* grid (LBD grid) -!! 2) calculate diffusive tracer fluxes (F) in the LBD grid using a layer by layer approach +!! 1) remap tracer to a z* grid (HBD grid) +!! 2) calculate diffusive tracer fluxes (F) in the HBD grid using a layer by layer approach !! 3) remap fluxes to the native grid !! 4) update tracer by adding the divergence of F -subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) - type(ocean_grid_type), intent(inout) :: G !< Grid type - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [L2 ~> m2] - real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Coef_y !< dt * Kh * dx / dy at v-points [L2 ~> m2] - real, intent(in) :: dt !< Tracer time step * I_numitts - !! (I_numitts in tracer_hordiff) [T ~> s] - type(tracer_registry_type), pointer :: Reg !< Tracer registry - type(lbd_CS), pointer :: CS !< Control structure for this module +subroutine hor_bnd_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, visc, CS) + type(ocean_grid_type), intent(inout) :: G !< Grid type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [L2 ~> m2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: Coef_y !< dt * Kh * dx / dy at v-points [L2 ~> m2] + real, intent(in) :: dt !< Tracer time step * I_numitts + !! (I_numitts in tracer_hordiff) [T ~> s] + type(tracer_registry_type), pointer :: Reg !< Tracer registry + type(vertvisc_type), intent(in) :: visc !< Structure with vertical viscosities, + !! boundary layer properties and related fields + type(hbd_CS), pointer :: CS !< Control structure for this module ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: hbl !< Boundary layer depth [H ~> m or kg m-2] @@ -163,36 +198,49 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) !! [conc H L2 ~> conc m3 or conc kg] real, dimension(SZI_(G),SZJB_(G)) :: vwork_2d !< Layer summed v-flux transport !! [conc H L2 ~> conc m3 or conc kg] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tendency !< tendency array for diagnostic [conc T-1 ~> conc s-1] - real, dimension(SZI_(G),SZJ_(G)) :: tendency_2d !< depth integrated content tendency for diagn - type(tracer_type), pointer :: tracer => NULL() !< Pointer to the current tracer - real, dimension(SZK_(GV)) :: tracer_1d !< 1d-array used to remap tracer change to native grid + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tendency !< tendency array for diagnostics at first in + !! [H conc T-1 ~> m conc s-1 or kg m-2 conc s-1], + !! then converted to [conc T-1 ~> conc s-1]. + ! For temperature these units are + ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] and + ! then [C T-1 ~> degC s-1]. + real, dimension(SZI_(G),SZJ_(G)) :: tendency_2d !< depth integrated content tendency for diagnostics in + !! [H conc T-1 ~> m conc s-1 or kg m-2 conc s-1]. + !! For temperature these units are + !! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1]. + type(tracer_type), pointer :: tracer => NULL() !< Pointer to the current tracer [conc] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tracer_old !< local copy of the initial tracer concentration, - !! only used to compute tendencies. - real, dimension(SZI_(G),SZJ_(G)) :: tracer_int !< integrated tracer before LBD is applied - !! [conc H L2 ~> conc m3 or conc kg] - real, dimension(SZI_(G),SZJ_(G)) :: tracer_end !< integrated tracer after LBD is applied. - !! [conc H L2 ~> conc m3 or conc kg] - integer :: i, j, k, m !< indices to loop over + !! only used to compute tendencies [conc]. + real :: tracer_int_prev !< Globally integrated tracer before HBD is applied, in mks units [conc kg] + real :: tracer_int_end !< Integrated tracer after HBD is applied, in mks units [conc kg] real :: Idt !< inverse of the time step [T-1 ~> s-1] - real :: tmp1, tmp2 !< temporary variables [conc H L2 ~> conc m3 or conc kg] + character(len=256) :: mesg !< Message for error messages. + integer :: i, j, k, m !< indices to loop over - call cpu_clock_begin(id_clock_lbd) + call cpu_clock_begin(id_clock_hbd) Idt = 1./dt - if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G, US, m_to_BLD_units=GV%m_to_H) - if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US, & - m_to_MLD_units=GV%m_to_H) - call pass_var(hbl,G%Domain) + + if (associated(visc%h_ML)) then + hbl(:,:) = visc%h_ML(:,:) + else + call MOM_error(FATAL, "hor_bnd_diffusion requires that visc%h_ML is associated.") + endif + ! This halo update is probably not necessary because visc%h_ML has valid halo data. + call pass_var(hbl, G%Domain, halo=1) + + ! build HBD grid + call hbd_grid(SURFACE, G, GV, hbl, h, CS) + do m = 1,Reg%ntr ! current tracer tracer => Reg%tr(m) if (CS%debug) then - call hchksum(tracer%t, "before LBD "//tracer%name,G%HI) + call hchksum(tracer%t, "before HBD "//tracer%name, G%HI, unscale=tracer%conc_scale) endif ! for diagnostics - if (tracer%id_lbdxy_conc > 0 .or. tracer%id_lbdxy_cont > 0 .or. tracer%id_lbdxy_cont_2d > 0 .or. CS%debug) then + if (tracer%id_hbdxy_conc > 0 .or. tracer%id_hbdxy_cont > 0 .or. tracer%id_hbdxy_cont_2d > 0 .or. CS%debug) then tendency(:,:,:) = 0.0 tracer_old(:,:,:) = tracer%t(:,:,:) endif @@ -201,13 +249,14 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) uFlx(:,:,:) = 0. vFlx(:,:,:) = 0. - ! LBD layer by layer + ! HBD layer by layer do j=G%jsc,G%jec do i=G%isc-1,G%iec if (G%mask2dCu(I,j)>0.) then - call fluxes_layer_method(SURFACE, G%ke, hbl(I,j), hbl(I+1,j), & + call fluxes_layer_method(SURFACE, GV%ke, hbl(I,j), hbl(I+1,j), & h(I,j,:), h(I+1,j,:), tracer%t(I,j,:), tracer%t(I+1,j,:), & - Coef_x(I,j), uFlx(I,j,:), G%areaT(I,j), G%areaT(I+1,j), CS) + Coef_x(I,j,:), uFlx(I,j,:), G%areaT(I,j), G%areaT(I+1,j), CS%hbd_u_kmax(I,j), & + CS%hbd_grd_u(I,j,:), CS) endif enddo enddo @@ -216,7 +265,8 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) if (G%mask2dCv(i,J)>0.) then call fluxes_layer_method(SURFACE, GV%ke, hbl(i,J), hbl(i,J+1), & h(i,J,:), h(i,J+1,:), tracer%t(i,J,:), tracer%t(i,J+1,:), & - Coef_y(i,J), vFlx(i,J,:), G%areaT(i,J), G%areaT(i,J+1), CS) + Coef_y(i,J,:), vFlx(i,J,:), G%areaT(i,J), G%areaT(i,J+1), CS%hbd_v_kmax(i,J), & + CS%hbd_grd_v(i,J,:), CS) endif enddo enddo @@ -227,89 +277,153 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) tracer%t(i,j,k) = tracer%t(i,j,k) + (( (uFlx(I-1,j,k)-uFlx(I,j,k)) ) + ( (vFlx(i,J-1,k)-vFlx(i,J,k) ) ))* & G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) - if (tracer%id_lbdxy_conc > 0 .or. tracer%id_lbdxy_cont > 0 .or. tracer%id_lbdxy_cont_2d > 0 ) then + if (tracer%id_hbdxy_conc > 0 .or. tracer%id_hbdxy_cont > 0 .or. tracer%id_hbdxy_cont_2d > 0 ) then tendency(i,j,k) = ((uFlx(I-1,j,k)-uFlx(I,j,k)) + (vFlx(i,J-1,k)-vFlx(i,J,k))) * & G%IareaT(i,j) * Idt endif endif enddo ; enddo ; enddo - if (CS%debug) then - call hchksum(tracer%t, "after LBD "//tracer%name,G%HI) - tracer_int(:,:) = 0.0; tracer_end(:,:) = 0.0 - ! tracer (native grid) before and after LBD - do j=G%jsc,G%jec ; do i=G%isc,G%iec - do k=1,GV%ke - tracer_int(i,j) = tracer_int(i,j) + tracer_old(i,j,k) * & - (h(i,j,k)*(G%mask2dT(i,j)*G%areaT(i,j))) - tracer_end(i,j) = tracer_end(i,j) + tracer%t(i,j,k) * & - (h(i,j,k)*(G%mask2dT(i,j)*G%areaT(i,j))) - enddo - enddo; enddo + ! Do user controlled underflow of the tracer concentrations. + if (tracer%conc_underflow > 0.0) then + do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (abs(tracer%t(i,j,k)) < tracer%conc_underflow) tracer%t(i,j,k) = 0.0 + enddo ; enddo ; enddo + endif - tmp1 = SUM(tracer_int) - tmp2 = SUM(tracer_end) - call sum_across_PEs(tmp1) - call sum_across_PEs(tmp2) - if (is_root_pe()) write(*,*)'Total '//tracer%name//' before/after LBD:', tmp1, tmp2 + if (CS%debug) then + call hchksum(tracer%t, "after HBD "//tracer%name, G%HI, unscale=tracer%conc_scale) + ! tracer (native grid) integrated tracer amounts before and after HBD + tracer_int_prev = global_mass_integral(h, G, GV, tracer_old, scale=tracer%conc_scale) + tracer_int_end = global_mass_integral(h, G, GV, tracer%t, scale=tracer%conc_scale) + write(mesg,*) 'Total '//tracer%name//' before/after HBD:', tracer_int_prev, tracer_int_end + call MOM_mesg(mesg) endif ! Post the tracer diagnostics - if (tracer%id_lbd_dfx>0) call post_data(tracer%id_lbd_dfx, uFlx(:,:,:)*Idt, CS%diag) - if (tracer%id_lbd_dfy>0) call post_data(tracer%id_lbd_dfy, vFlx(:,:,:)*Idt, CS%diag) - if (tracer%id_lbd_dfx_2d>0) then + if (tracer%id_hbd_dfx>0) call post_data(tracer%id_hbd_dfx, uFlx(:,:,:)*Idt, CS%diag) + if (tracer%id_hbd_dfy>0) call post_data(tracer%id_hbd_dfy, vFlx(:,:,:)*Idt, CS%diag) + if (tracer%id_hbd_dfx_2d>0) then uwork_2d(:,:) = 0. do k=1,GV%ke ; do j=G%jsc,G%jec ; do I=G%isc-1,G%iec uwork_2d(I,j) = uwork_2d(I,j) + (uFlx(I,j,k) * Idt) enddo ; enddo ; enddo - call post_data(tracer%id_lbd_dfx_2d, uwork_2d, CS%diag) + call post_data(tracer%id_hbd_dfx_2d, uwork_2d, CS%diag) endif - if (tracer%id_lbd_dfy_2d>0) then + if (tracer%id_hbd_dfy_2d>0) then vwork_2d(:,:) = 0. do k=1,GV%ke ; do J=G%jsc-1,G%jec ; do i=G%isc,G%iec vwork_2d(i,J) = vwork_2d(i,J) + (vFlx(i,J,k) * Idt) enddo ; enddo ; enddo - call post_data(tracer%id_lbd_dfy_2d, vwork_2d, CS%diag) + call post_data(tracer%id_hbd_dfy_2d, vwork_2d, CS%diag) endif ! post tendency of tracer content - if (tracer%id_lbdxy_cont > 0) then - call post_data(tracer%id_lbdxy_cont, tendency, CS%diag) + if (tracer%id_hbdxy_cont > 0) then + call post_data(tracer%id_hbdxy_cont, tendency, CS%diag) endif ! post depth summed tendency for tracer content - if (tracer%id_lbdxy_cont_2d > 0) then + if (tracer%id_hbdxy_cont_2d > 0) then tendency_2d(:,:) = 0. do j=G%jsc,G%jec ; do i=G%isc,G%iec do k=1,GV%ke tendency_2d(i,j) = tendency_2d(i,j) + tendency(i,j,k) enddo enddo ; enddo - call post_data(tracer%id_lbdxy_cont_2d, tendency_2d, CS%diag) + call post_data(tracer%id_hbdxy_cont_2d, tendency_2d, CS%diag) endif ! post tendency of tracer concentration; this step must be ! done after posting tracer content tendency, since we alter ! the tendency array and its units. - if (tracer%id_lbdxy_conc > 0) then + if (tracer%id_hbdxy_conc > 0) then do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec tendency(i,j,k) = tendency(i,j,k) / ( h(i,j,k) + CS%H_subroundoff ) enddo ; enddo ; enddo - call post_data(tracer%id_lbdxy_conc, tendency, CS%diag) + call post_data(tracer%id_hbdxy_conc, tendency, CS%diag) endif enddo - call cpu_clock_end(id_clock_lbd) + call cpu_clock_end(id_clock_hbd) + +end subroutine hor_bnd_diffusion + +!> Build the HBD grid where tracers will be remapped to. +subroutine hbd_grid(boundary, G, GV, hbl, h, CS) + integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] + type(ocean_grid_type), intent(inout) :: G !< Grid type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: hbl !< Boundary layer depth [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness in the native grid [H ~> m or kg m-2] + type(hbd_CS), pointer :: CS !< Horizontal diffusion control structure -end subroutine lateral_boundary_diffusion + ! Local variables + real, allocatable :: dz_top(:) !< temporary HBD grid given by merge_interfaces [H ~> m or kg m-2] + integer :: nk, i, j, k !< number of layers in the HBD grid, and integers used in do-loops + + ! reset arrays + CS%hbd_grd_u(:,:,:) = 0.0 + CS%hbd_grd_v(:,:,:) = 0.0 + CS%hbd_u_kmax(:,:) = 0 + CS%hbd_v_kmax(:,:) = 0 + + do j=G%jsc,G%jec + do I=G%isc-1,G%iec + if (G%mask2dCu(I,j)>0.) then + call merge_interfaces(GV%ke, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & + CS%H_subroundoff, dz_top) + nk = SIZE(dz_top) + if (nk > CS%hbd_nk) then + write(*,*)'nk, CS%hbd_nk', nk, CS%hbd_nk + call MOM_error(FATAL,"Houston, we've had a problem in hbd_grid, u-points (nk cannot be > CS%hbd_nk)") + endif -!> Calculate the harmonic mean of two quantities + CS%hbd_u_kmax(I,j) = nk + + ! set the HBD grid to dz_top + do k=1,nk + CS%hbd_grd_u(I,j,k) = dz_top(k) + enddo + deallocate(dz_top) + endif + enddo + enddo + + do J=G%jsc-1,G%jec + do i=G%isc,G%iec + if (G%mask2dCv(i,J)>0.) then + call merge_interfaces(GV%ke, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & + CS%H_subroundoff, dz_top) + + nk = SIZE(dz_top) + if (nk > CS%hbd_nk) then + write(*,*)'nk, CS%hbd_nk', nk, CS%hbd_nk + call MOM_error(FATAL,"Houston, we've had a problem in hbd_grid, v-points (nk cannot be > CS%hbd_nk)") + endif + + CS%hbd_v_kmax(i,J) = nk + + ! set the HBD grid to dz_top + do k=1,nk + CS%hbd_grd_v(i,J,k) = dz_top(k) + enddo + deallocate(dz_top) + endif + enddo + enddo + +end subroutine hbd_grid + +!> Calculate the harmonic mean of two quantities [arbitrary] !! See \ref section_harmonic_mean. real function harmonic_mean(h1,h2) - real :: h1 !< Scalar quantity - real :: h2 !< Scalar quantity + real :: h1 !< Scalar quantity [arbitrary] + real :: h2 !< Scalar quantity [arbitrary] if (h1 + h2 == 0.) then harmonic_mean = 0. else @@ -322,10 +436,10 @@ end function harmonic_mean integer function find_minimum(x, s, e) integer, intent(in) :: s !< start index integer, intent(in) :: e !< end index - real, dimension(e), intent(in) :: x !< 1D array to be checked + real, dimension(e), intent(in) :: x !< 1D array to be checked [arbitrary] ! local variables - real :: minimum + real :: minimum ! Minimum value in the same units as x [arbitrary] integer :: location integer :: i @@ -335,18 +449,18 @@ integer function find_minimum(x, s, e) if (x(i) < minimum) then ! if x(i) less than the min? minimum = x(i) ! Yes, a new minimum found location = i ! record its position - end if + endif enddo find_minimum = location ! return the position end function find_minimum !> Swaps the values of its two formal arguments. subroutine swap(a, b) - real, intent(inout) :: a !< First value to be swaped - real, intent(inout) :: b !< Second value to be swaped + real, intent(inout) :: a !< First value to be swapped [arbitrary] + real, intent(inout) :: b !< Second value to be swapped [arbitrary] ! local variables - real :: tmp + real :: tmp ! A temporary copy of a [arbitrary] tmp = a a = b @@ -355,8 +469,8 @@ end subroutine swap !> Receives a 1D array x and sorts it into ascending order. subroutine sort(x, n) - real, dimension(n), intent(inout) :: x !< 1D array to be sorted - integer, intent(in ) :: n !< # of pts in the array + integer, intent(in ) :: n !< Number of points in the array + real, dimension(n), intent(inout) :: x !< 1D array to be sorted [arbitrary] ! local variables integer :: i, location @@ -369,15 +483,15 @@ end subroutine sort !> Returns the unique values in a 1D array. subroutine unique(val, n, val_unique, val_max) - integer, intent(in ) :: n !< # of pts in the array. - real, dimension(n), intent(in ) :: val !< 1D array to be checked. - real, dimension(:), allocatable, intent(inout) :: val_unique !< Returned 1D array with unique values. + integer, intent(in ) :: n !< Number of points in the array. + real, dimension(n), intent(in ) :: val !< 1D array to be checked [arbitrary] + real, dimension(:), allocatable, intent(inout) :: val_unique !< Returned 1D array with unique values [arbitrary] real, optional, intent(in ) :: val_max !< sets the maximum value in val_unique to - !! this value. + !! this value [arbitrary] ! local variables - real, dimension(n) :: tmp + real, dimension(n) :: tmp ! The list of unique values [arbitrary] integer :: i, j, ii - real :: min_val, max_val + real :: min_val, max_val ! The minimum and maximum values in the list [arbitrary] logical :: limit limit = .false. @@ -394,9 +508,9 @@ subroutine unique(val, n, val_unique, val_max) max_val = MAXVAL(val) i = 0 do while (min_valmin_val) - tmp(i) = min_val + i = i+1 + min_val = MINVAL(val, mask=val>min_val) + tmp(i) = min_val enddo ii = i if (limit) then @@ -425,18 +539,20 @@ subroutine merge_interfaces(nk, h_L, h_R, hbl_L, hbl_R, H_subroundoff, h) ! Local variables integer :: n !< Number of layers in eta_all - real, dimension(nk+1) :: eta_L, eta_R!< Interfaces in the left and right coloumns - real, dimension(:), allocatable :: eta_all !< Combined interfaces in the left/right columns + hbl_L and hbl_R - real, dimension(:), allocatable :: eta_unique !< Combined interfaces (eta_L, eta_R), possibly hbl_L and hbl_R - real :: min_depth !< Minimum depth - real :: max_depth !< Maximum depth - real :: max_bld !< Deepest BLD + real, dimension(nk+1) :: eta_L, eta_R!< Interfaces in the left and right columns [H ~> m or kg m-2] + real, dimension(:), allocatable :: eta_all !< Combined list of interfaces in the left and right columns + !! plus hbl_L and hbl_R [H ~> m or kg m-2] + real, dimension(:), allocatable :: eta_unique !< Combined list of unique interfaces (eta_L, eta_R), possibly + !! hbl_L and hbl_R [H ~> m or kg m-2] + real :: min_depth !< Minimum depth [H ~> m or kg m-2] + real :: max_depth !< Maximum depth [H ~> m or kg m-2] + real :: max_bld !< Deepest BLD [H ~> m or kg m-2] integer :: k, kk, nk1 !< loop indices (k and kk) and array size (nk1) n = (2*nk)+3 allocate(eta_all(n)) ! compute and merge interfaces - eta_L(:) = 0.0; eta_R(:) = 0.0; eta_all(:) = 0.0 + eta_L(:) = 0.0 ; eta_R(:) = 0.0 ; eta_all(:) = 0.0 kk = 0 do k=2,nk+1 eta_L(k) = eta_L(k-1) + h_L(k-1) @@ -479,7 +595,7 @@ subroutine flux_limiter(F_layer, area_L, area_R, phi_L, phi_R, h_L, h_R) real, intent(in) :: phi_R !< Tracer concentration in the right cell [conc] ! local variables - real :: F_max !< maximum flux allowed + real :: F_max !< maximum flux allowed [conc H L2 ~> conc m3 or conc kg] ! limit the flux to 0.2 of the tracer *gradient* ! Why 0.2? ! t=0 t=inf @@ -518,6 +634,7 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b ! Local variables real :: htot ! Summed thickness [H ~> m or kg m-2] integer :: k + ! Surface boundary layer if ( boundary == SURFACE ) then k_top = 1 @@ -539,6 +656,7 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b return endif enddo + ! Bottom boundary layer elseif ( boundary == BOTTOM ) then k_top = nk @@ -566,10 +684,10 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b end subroutine boundary_k_range -!> Calculate the lateral boundary diffusive fluxes using the layer by layer method. +!> Calculate the horizontal boundary diffusive fluxes using the layer by layer method. !! See \ref section_method subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & - khtr_u, F_layer, area_L, area_R, CS) + khtr_u, F_layer, area_L, area_R, nk, dz_top, CS) integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] integer, intent(in ) :: ke !< Number of layers in the native grid [nondim] @@ -581,28 +699,29 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ real, dimension(ke), intent(in ) :: h_R !< Thicknesses in the native grid (right) [H ~> m or kg m-2] real, dimension(ke), intent(in ) :: phi_L !< Tracer values in the native grid (left) [conc] real, dimension(ke), intent(in ) :: phi_R !< Tracer values in the native grid (right) [conc] - real, intent(in ) :: khtr_u !< Horizontal diffusivities times the time step - !! at a velocity point [L2 ~> m2] + real, dimension(ke+1),intent(in ) :: khtr_u !< Horizontal diffusivities times the time step + !! at a velocity point and vertical interfaces [L2 ~> m2] real, dimension(ke), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point !! in the native grid [H L2 conc ~> m3 conc] real, intent(in ) :: area_L !< Area of the horizontal grid (left) [L2 ~> m2] real, intent(in ) :: area_R !< Area of the horizontal grid (right) [L2 ~> m2] - type(lbd_CS), pointer :: CS !< Lateral diffusion control structure + integer, intent(in ) :: nk !< Number of layers in the HBD grid [nondim] + real, dimension(nk), intent(in ) :: dz_top !< The HBD z grid [H ~> m or kg m-2] + type(hbd_CS), pointer :: CS !< Horizontal diffusion control structure ! Local variables - real, allocatable :: dz_top(:) !< The LBD z grid to be created [H ~> m or kg m-2] real, allocatable :: phi_L_z(:) !< Tracer values in the ztop grid (left) [conc] real, allocatable :: phi_R_z(:) !< Tracer values in the ztop grid (right) [conc] real, allocatable :: F_layer_z(:) !< Diffusive flux at U/V-point in the ztop grid [H L2 conc ~> m3 conc] - real :: h_vel(ke) !< Thicknesses at u- and v-points in the native grid + real, allocatable :: khtr_ul_z(:) !< khtr_u at layer centers in the ztop grid [H L2 conc ~> m3 conc] + real, dimension(ke) :: h_vel !< Thicknesses at u- and v-points in the native grid !! The harmonic mean is used to avoid zero values [H ~> m or kg m-2] - real :: khtr_avg !< Thickness-weighted diffusivity at the velocity-point [L2 T-1 ~> m2 s-1] - !! This is just to remind developers that khtr_avg should be - !! computed once khtr is 3D. + real, dimension(ke) :: khtr_ul !< khtr_u at the vertical layer of the native grid [L2 ~> m2] real :: htot !< Total column thickness [H ~> m or kg m-2] - integer :: k, k_bot_min, k_top_max !< k-indices, min and max for bottom and top, respectively - integer :: k_bot_max, k_top_min !< k-indices, max and min for bottom and top, respectively - integer :: k_bot_diff, k_top_diff !< different between left and right k-indices for bottom and top, respectively + integer :: k !< Index used in the vertical direction + integer :: k_bot_min !< Minimum k-index for the bottom + integer :: k_bot_max !< Maximum k-index for the bottom + integer :: k_bot_diff !< Difference between bottom left and right k-indices integer :: k_top_L, k_bot_L !< k-indices left native grid integer :: k_top_R, k_bot_R !< k-indices right native grid real :: zeta_top_L, zeta_top_R !< distance from the top of a layer to the boundary @@ -610,29 +729,37 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ real :: zeta_bot_L, zeta_bot_R !< distance from the bottom of a layer to the boundary !! layer depth in the native grid [nondim] real :: wgt !< weight to be used in the linear transition to the interior [nondim] - real :: a !< coefficient to be used in the linear transition to the interior [nondim] + real :: a !< coefficient used in the linear transition to the interior [nondim] real :: tmp1, tmp2 !< dummy variables [H ~> m or kg m-2] real :: htot_max !< depth below which no fluxes should be applied [H ~> m or kg m-2] - integer :: nk !< number of layers in the LBD grid F_layer(:) = 0.0 + khtr_ul(:) = 0.0 if (hbl_L == 0. .or. hbl_R == 0.) then return endif - ! Define vertical grid, dz_top - call merge_interfaces(ke, h_L(:), h_R(:), hbl_L, hbl_R, CS%H_subroundoff, dz_top) - nk = SIZE(dz_top) - ! allocate arrays allocate(phi_L_z(nk), source=0.0) allocate(phi_R_z(nk), source=0.0) allocate(F_layer_z(nk), source=0.0) + 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(:)) 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 + h_vel(k) = harmonic_mean(h_L(k), h_R(k)) + ! GMM, writing 0.5 * (A(k) + A(k+1)) as A(k) + 0.5 * (A(k+1) - A(k)) to recover + ! answers with depth-independent khtr + khtr_ul(k) = khtr_u(k) + 0.5 * (khtr_u(k+1) - khtr_u(k)) + 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(:)) + ! 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) call boundary_k_range(boundary, nk, dz_top, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) @@ -642,11 +769,11 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ k_bot_max = MAX(k_bot_L, k_bot_R) k_bot_diff = (k_bot_max - k_bot_min) - ! tracer flux where the minimum BLD intersets layer - if ((CS%linear) .and. (k_bot_diff .gt. 1)) then + ! tracer flux where the minimum BLD intersects layer + if ((CS%linear) .and. (k_bot_diff > 1)) then ! apply linear decay at the base of hbl do k = k_bot_min,1,-1 - F_layer_z(k) = -(dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) + F_layer_z(k) = -(dz_top(k) * khtr_ul_z(k)) * (phi_R_z(k) - phi_L_z(k)) if (CS%limiter_remap) call flux_limiter(F_layer_z(k), area_L, area_R, phi_L_z(k), & phi_R_z(k), dz_top(k), dz_top(k)) enddo @@ -659,49 +786,24 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ htot = 0. do k = k_bot_min+1,k_bot_max, 1 wgt = (a*(htot + (dz_top(k) * 0.5))) + 1.0 - F_layer_z(k) = -(dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) * wgt + F_layer_z(k) = -(dz_top(k) * khtr_ul_z(k)) * (phi_R_z(k) - phi_L_z(k)) * wgt htot = htot + dz_top(k) if (CS%limiter_remap) call flux_limiter(F_layer_z(k), area_L, area_R, phi_L_z(k), & phi_R_z(k), dz_top(k), dz_top(k)) enddo else do k = k_bot_min,1,-1 - F_layer_z(k) = -(dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) + F_layer_z(k) = -(dz_top(k) * khtr_ul_z(k)) * (phi_R_z(k) - phi_L_z(k)) if (CS%limiter_remap) call flux_limiter(F_layer_z(k), area_L, area_R, phi_L_z(k), & phi_R_z(k), dz_top(k), dz_top(k)) enddo endif endif -! TODO, boundary == BOTTOM -! if (boundary == BOTTOM) then -! ! TODO: GMM add option to apply linear decay -! k_top_max = MAX(k_top_L, k_top_R) -! ! make sure left and right k indices span same range -! if (k_top_max .ne. k_top_L) then -! k_top_L = k_top_max -! zeta_top_L = 1.0 -! endif -! if (k_top_max .ne. k_top_R) then -! k_top_R= k_top_max -! zeta_top_R = 1.0 -! endif -! -! ! tracer flux where the minimum BLD intersets layer -! F_layer(k_top_max) = (-heff * khtr_u) * (phi_R_avg - phi_L_avg) -! -! do k = k_top_max+1,nk -! F_layer_z(k) = -(heff * khtr_u) * (phi_R_z(k) - phi_L_z(k)) -! enddo -! endif - - ! thicknesses at velocity points - do k = 1,ke - h_vel(k) = harmonic_mean(h_L(k), h_R(k)) - enddo + !GMM, TODO: boundary == BOTTOM ! remap flux to h_vel (native grid) - call reintegrate_column(nk, dz_top(:), F_layer_z(:), ke, h_vel(:), 0.0, F_layer(:)) + call reintegrate_column(nk, dz_top(:), F_layer_z(:), ke, h_vel(:), F_layer(:)) ! used to avoid fluxes below hbl if (CS%linear) then @@ -710,7 +812,7 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ htot_max = MIN(hbl_L, hbl_R) endif - tmp1 = 0.0; tmp2 = 0.0 + tmp1 = 0.0 ; tmp2 = 0.0 do k = 1,ke ! apply flux_limiter if (CS%limiter .and. F_layer(k) /= 0.) then @@ -727,10 +829,10 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ enddo ! deallocated arrays - deallocate(dz_top) deallocate(phi_L_z) deallocate(phi_R_z) deallocate(F_layer_z) + deallocate(khtr_ul_z) end subroutine fluxes_layer_method @@ -741,32 +843,36 @@ logical function near_boundary_unit_tests( verbose ) ! Local variables integer, parameter :: nk = 2 ! Number of layers real, dimension(nk+1) :: eta1 ! Updated interfaces with one extra value [m] - real, dimension(:), allocatable :: h1 ! Upates layer thicknesses [m] + real, dimension(:), allocatable :: h1 ! Updated list of layer thicknesses or other field [m] or [arbitrary] real, dimension(nk) :: phi_L, phi_R ! Tracer values (left and right column) [conc] real, dimension(nk) :: h_L, h_R ! Layer thickness (left and right) [m] - real :: khtr_u ! Horizontal diffusivities at U-point [m2 s-1] + real, dimension(nk+1) :: khtr_u ! Horizontal diffusivities at U-point and interfaces[m2 s-1] real :: hbl_L, hbl_R ! Depth of the boundary layer (left and right) [m] real, dimension(nk) :: F_layer ! Diffusive flux within each layer at U-point [conc m3 s-1] character(len=120) :: test_name ! Title of the unit test integer :: k_top ! Index of cell containing top of boundary - real :: zeta_top ! Nondimension position [nondim] + real :: zeta_top ! Fractional position in the cell of the top [nondim] integer :: k_bot ! Index of cell containing bottom of boundary - real :: zeta_bot ! Nondimension position [nondim] - type(lbd_CS), pointer :: CS + real :: zeta_bot ! Fractional position in the cell of the bottom [nondim] + type(hbd_CS), pointer :: CS allocate(CS) ! fill required fields in CS CS%linear=.false. - call initialize_remapping( CS%remap_CS, 'PLM', boundary_extrapolation = .true. ,& - check_reconstruction = .true., check_remapping = .true.) - call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) CS%H_subroundoff = 1.0E-20 CS%debug=.false. CS%limiter=.false. CS%limiter_remap=.false. - + CS%hbd_nk = 2 + (2*2) + call initialize_remapping( CS%remap_CS, 'PLM', boundary_extrapolation=.true., & + om4_remap_via_sub_cells=.true., & ! ### see fail below when using fixed remapping alg. + check_reconstruction=.true., check_remapping=.true., & + h_neglect=CS%H_subroundoff, h_neglect_edge=CS%H_subroundoff) + call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) + allocate(CS%hbd_grd_u(1,1,CS%hbd_nk), source=0.0) + allocate(CS%hbd_u_kmax(1,1), source=0) near_boundary_unit_tests = .false. - write(stdout,*) '==== MOM_lateral_boundary_diffusion =======================' + write(stdout,*) '==== MOM_hor_bnd_diffusion =======================' ! Unit tests for boundary_k_range test_name = 'Surface boundary spans the entire top cell' @@ -917,54 +1023,59 @@ logical function near_boundary_unit_tests( verbose ) ! All cases in this section have hbl which are equal to the column thicknesses test_name = 'Equal hbl and same layer thicknesses (gradient from right to left)' - hbl_L = 2.; hbl_R = 2. + hbl_L = 2. ; hbl_R = 2. h_L = (/2.,2./) ; h_R = (/2.,2./) phi_L = (/0.,0./) ; phi_R = (/1.,1./) - khtr_u = 1. + khtr_u = (/1.,1.,1./) + call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & - khtr_u, F_layer, 1., 1., CS) + khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) near_boundary_unit_tests = near_boundary_unit_tests .or. & test_layer_fluxes( verbose, nk, test_name, F_layer, (/-2.0,0.0/) ) test_name = 'Equal hbl and same layer thicknesses (gradient from left to right)' - hbl_L = 2.; hbl_R = 2. + hbl_L = 2. ; hbl_R = 2. h_L = (/2.,2./) ; h_R = (/2.,2./) phi_L = (/2.,1./) ; phi_R = (/1.,1./) - khtr_u = 0.5 + khtr_u = (/0.5,0.5,0.5/) + call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & - khtr_u, F_layer, 1., 1., CS) + khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) near_boundary_unit_tests = near_boundary_unit_tests .or. & test_layer_fluxes( verbose, nk, test_name, F_layer, (/1.0,0.0/) ) test_name = 'hbl < column thickness, hbl same, linear profile right, khtr=2' - hbl_L = 2; hbl_R = 2 + hbl_L = 2 ; hbl_R = 2 h_L = (/1.,2./) ; h_R = (/1.,2./) phi_L = (/0.,0./) ; phi_R = (/0.5,2./) - khtr_u = 2. + khtr_u = (/2.,2.,2./) + call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & - khtr_u, F_layer, 1., 1., CS) + khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) + ! ### This test fails when om4_remap_via_sub_cells=.false. near_boundary_unit_tests = near_boundary_unit_tests .or. & test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.0,-4.0/) ) test_name = 'Different hbl and different column thicknesses (zero gradient)' - hbl_L = 12; hbl_R = 20 + hbl_L = 12 ; hbl_R = 20 h_L = (/6.,6./) ; h_R = (/10.,10./) phi_L = (/1.,1./) ; phi_R = (/1.,1./) - khtr_u = 1. + khtr_u = (/1.,1.,1./) + call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & - khtr_u, F_layer, 1., 1., CS) + khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) near_boundary_unit_tests = near_boundary_unit_tests .or. & test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.,0./) ) test_name = 'Different hbl and different column thicknesses (gradient from left to right)' - hbl_L = 15; hbl_R = 10. + hbl_L = 15 ; hbl_R = 10. h_L = (/10.,5./) ; h_R = (/10.,0./) phi_L = (/1.,1./) ; phi_R = (/0.,0./) - khtr_u = 1. + khtr_u = (/1.,1.,1./) + call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & - khtr_u, F_layer, 1., 1., CS) - + khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) near_boundary_unit_tests = near_boundary_unit_tests .or. & test_layer_fluxes( verbose, nk, test_name, F_layer, (/10.,0.0/) ) @@ -978,8 +1089,8 @@ logical function test_layer_fluxes(verbose, nk, test_name, F_calc, F_ans) logical, intent(in) :: verbose !< If true, write results to stdout character(len=80), intent(in) :: test_name !< Brief description of the unit test integer, intent(in) :: nk !< Number of layers - real, dimension(nk), intent(in) :: F_calc !< Fluxes of the unitless tracer from the algorithm [s^-1] - real, dimension(nk), intent(in) :: F_ans !< Fluxes of the unitless tracer calculated by hand [s^-1] + real, dimension(nk), intent(in) :: F_calc !< Fluxes or other quantity from the algorithm [arbitrary] + real, dimension(nk), intent(in) :: F_ans !< Expected value calculated by hand [arbitrary] ! Local variables integer :: k @@ -987,7 +1098,7 @@ logical function test_layer_fluxes(verbose, nk, test_name, F_calc, F_ans) do k=1,nk if ( F_calc(k) /= F_ans(k) ) then test_layer_fluxes = .true. - write(stdout,*) "MOM_lateral_boundary_diffusion, UNIT TEST FAILED: ", test_name + write(stdout,*) "MOM_hor_bnd_diffusion, UNIT TEST FAILED: ", test_name write(stdout,10) k, F_calc(k), F_ans(k) elseif (verbose) then write(stdout,10) k, F_calc(k), F_ans(k) @@ -1001,20 +1112,20 @@ end function test_layer_fluxes logical function test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, k_top_ans, zeta_top_ans,& k_bot_ans, zeta_bot_ans, test_name, verbose) integer :: k_top !< Index of cell containing top of boundary - real :: zeta_top !< Nondimension position + real :: zeta_top !< Fractional position in the cell of the top boundary [nondim] integer :: k_bot !< Index of cell containing bottom of boundary - real :: zeta_bot !< Nondimension position - integer :: k_top_ans !< Index of cell containing top of boundary - real :: zeta_top_ans !< Nondimension position - integer :: k_bot_ans !< Index of cell containing bottom of boundary - real :: zeta_bot_ans !< Nondimension position + real :: zeta_bot !< Fractional position in the cell of the bottom boundary [nondim] + integer :: k_top_ans !< Expected index of cell containing top of boundary + real :: zeta_top_ans !< Expected fractional position of the top boundary [nondim] + integer :: k_bot_ans !< Expected index of cell containing bottom of boundary + real :: zeta_bot_ans !< Expected fractional position of the bottom boundary [nondim] character(len=80) :: test_name !< Name of the unit test logical :: verbose !< If true always print output - test_boundary_k_range = k_top .ne. k_top_ans - test_boundary_k_range = test_boundary_k_range .or. (zeta_top .ne. zeta_top_ans) - test_boundary_k_range = test_boundary_k_range .or. (k_bot .ne. k_bot_ans) - test_boundary_k_range = test_boundary_k_range .or. (zeta_bot .ne. zeta_bot_ans) + test_boundary_k_range = k_top /= k_top_ans + test_boundary_k_range = test_boundary_k_range .or. (zeta_top /= zeta_top_ans) + test_boundary_k_range = test_boundary_k_range .or. (k_bot /= k_bot_ans) + test_boundary_k_range = test_boundary_k_range .or. (zeta_bot /= zeta_bot_ans) if (test_boundary_k_range) write(stdout,*) "UNIT TEST FAILED: ", test_name if (test_boundary_k_range .or. verbose) then @@ -1024,19 +1135,61 @@ logical function test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, k_top_a write(stdout,30) "zeta_bot", zeta_bot, "zeta_bot_ans", zeta_bot_ans endif - 20 format(A,"=",i3,X,A,"=",i3) - 30 format(A,"=",f20.16,X,A,"=",f20.16) + 20 format(A,"=",i3,1X,A,"=",i3) + 30 format(A,"=",f20.16,1X,A,"=",f20.16) end function test_boundary_k_range -!> \namespace mom_lateral_boundary_diffusion +!> Same as hbd_grid, but only used in the unit tests. +subroutine hbd_grid_test(boundary, hbl_L, hbl_R, h_L, h_R, CS) + integer, intent(in) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] + real, intent(in) :: hbl_L !< Boundary layer depth, left [H ~> m or kg m-2] + real, intent(in) :: hbl_R !< Boundary layer depth, right [H ~> m or kg m-2] + real, dimension(2), intent(in) :: h_L !< Layer thickness in the native grid, left [H ~> m or kg m-2] + real, dimension(2), intent(in) :: h_R !< Layer thickness in the native grid, right [H ~> m or kg m-2] + type(hbd_CS), pointer :: CS !< Horizontal diffusion control structure + + ! Local variables + real, allocatable :: dz_top(:) !< temporary HBD grid given by merge_interfaces [H ~> m or kg m-2] + integer :: nk, k !< number of layers in the HBD grid, and integers used in do-loops + + ! reset arrays + CS%hbd_grd_u(1,1,:) = 0.0 + CS%hbd_u_kmax(1,1) = 0 + + call merge_interfaces(2, h_L, h_R, hbl_L, hbl_R, CS%H_subroundoff, dz_top) + nk = SIZE(dz_top) + if (nk > CS%hbd_nk) then + write(*,*)'nk, CS%hbd_nk', nk, CS%hbd_nk + call MOM_error(FATAL,"Houston, we've had a problem in hbd_grid_test, (nk cannot be > CS%hbd_nk)") + endif + + CS%hbd_u_kmax(1,1) = nk + + ! set the HBD grid to dz_top + do k=1,nk + CS%hbd_grd_u(1,1,k) = dz_top(k) + enddo + deallocate(dz_top) + +end subroutine hbd_grid_test + +!> Deallocates hor_bnd_diffusion control structure +subroutine hor_bnd_diffusion_end(CS) + type(hbd_CS), pointer :: CS !< Horizontal boundary diffusion control structure + + if (associated(CS)) deallocate(CS) + +end subroutine hor_bnd_diffusion_end + +!> \namespace mom_hor_bnd_diffusion !! -!! \section section_LBD The Lateral Boundary Diffusion (LBD) framework +!! \section section_HBD The Horizontal Boundary Diffusion (HBD) framework !! -!! The LBD framework accounts for the effects of diabatic mesoscale fluxes +!! The HBD framework accounts for the effects of diabatic mesoscale fluxes !! within surface and bottom boundary layers. Unlike the equivalent adiabatic -!! fluxes, which is applied along neutral density surfaces, LBD is purely +!! fluxes, which is applied along neutral density surfaces, HBD is purely !! horizontal. To assure that diffusive fluxes are strictly horizontal !! regardless of the vertical coordinate system, this method relies on !! regridding/remapping techniques. @@ -1044,10 +1197,10 @@ end function test_boundary_k_range !! The bottom boundary layer fluxes remain to be implemented, although some !! of the steps needed to do so have already been added and tested. !! -!! Boundary lateral diffusion is applied as follows: +!! Horizontal boundary diffusion is applied as follows: !! -!! 1) remap tracer to a z* grid (LBD grid) -!! 2) calculate diffusive tracer fluxes (F) in the LBD grid using a layer by layer approach (@ref section_method) +!! 1) remap tracer to a z* grid (HBD grid) +!! 2) calculate diffusive tracer fluxes (F) in the HBD grid using a layer by layer approach (@ref section_method) !! 3) remap fluxes to the native grid !! 4) update tracer by adding the divergence of F !! @@ -1071,7 +1224,7 @@ end function test_boundary_k_range !! !! Step #3: option to linearly decay the flux from k_bot_min to k_bot_max: !! -!! If LBD_LINEAR_TRANSITION = True and k_bot_diff > 1, the diffusive flux will decay +!! If HBD_LINEAR_TRANSITION = True and k_bot_diff > 1, the diffusive flux will decay !! linearly between the top interface of the layer containing the minimum boundary !! layer depth (k_bot_min) and the lower interface of the layer containing the !! maximum layer depth (k_bot_max). @@ -1091,8 +1244,8 @@ end function test_boundary_k_range !! !! \subsection section_harmonic_mean Harmonic Mean !! -!! The harmonic mean (HM) betwen h1 and h2 is defined as: +!! The harmonic mean (HM) between h1 and h2 is defined as: !! !! \f[ HM = \frac{2 \times h1 \times h2}{h1 + h2} \f] !! -end module MOM_lateral_boundary_diffusion +end module MOM_hor_bnd_diffusion diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index fd479eeaf3..a94c1cbe02 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> A column-wise toolbox for implementing neutral diffusion module MOM_neutral_diffusion -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE use MOM_domains, only : pass_var @@ -10,7 +12,7 @@ module MOM_neutral_diffusion use MOM_diag_mediator, only : post_data, register_diag_field use MOM_EOS, only : EOS_type, EOS_manual_init, EOS_domain use MOM_EOS, only : calculate_density, calculate_density_derivs -use MOM_EOS, only : extract_member_EOS, EOS_LINEAR, EOS_TEOS10, EOS_WRIGHT +use MOM_EOS, only : EOS_LINEAR use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_file_parser, only : openParameterBlock, closeParameterBlock @@ -20,6 +22,7 @@ module MOM_neutral_diffusion use MOM_remapping, only : average_value_ppoly, remappingSchemesDoc, remappingDefaultScheme use MOM_tracer_registry, only : tracer_registry_type, tracer_type use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : vertvisc_type use MOM_verticalGrid, only : verticalGrid_type use polynomial_functions, only : evaluation_polynomial, first_derivative_polynomial use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation @@ -27,8 +30,8 @@ module MOM_neutral_diffusion use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member -use MOM_lateral_boundary_diffusion, only : boundary_k_range, SURFACE, BOTTOM use MOM_io, only : stdout, stderr +use MOM_hor_bnd_diffusion, only : boundary_k_range, SURFACE, BOTTOM implicit none ; private @@ -48,44 +51,59 @@ module MOM_neutral_diffusion logical :: hard_fail_heff !< Bring down the model if a problem with heff is detected integer :: max_iter !< Maximum number of iterations if refine_position is defined real :: drho_tol !< Convergence criterion representing density difference from true neutrality [R ~> kg m-3] - real :: x_tol !< Convergence criterion for how small an update of the position can be + real :: x_tol !< Convergence criterion for how small an update of the position can be [nondim] real :: ref_pres !< Reference pressure, negative if using locally referenced neutral !! density [R L2 T-2 ~> Pa] logical :: interior_only !< If true, only applies neutral diffusion in the ocean interior. !! That is, the algorithm will exclude the surface and bottom boundary layers. + 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_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] + ! Coefficients used to apply tapering from neutral to horizontal direction + real, allocatable, dimension(:) :: coeff_l !< Non-dimensional coefficient in the left column, + !! 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_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 - real, allocatable, dimension(:,:,:) :: uPoR !< Non-dimensional position with right layer uKoR-1, u-point + real, allocatable, dimension(:,:,:) :: uPoL !< Non-dimensional position with left layer uKoL-1, u-point [nondim] + real, allocatable, dimension(:,:,:) :: uPoR !< Non-dimensional position with right layer uKoR-1, u-point [nondim] integer, allocatable, dimension(:,:,:) :: uKoL !< Index of left interface corresponding to neutral surface, !! at a u-point integer, allocatable, dimension(:,:,:) :: uKoR !< Index of right interface corresponding to neutral surface, !! at a u-point real, allocatable, dimension(:,:,:) :: uHeff !< Effective thickness at u-point [H ~> m or kg m-2] - real, allocatable, dimension(:,:,:) :: vPoL !< Non-dimensional position with left layer uKoL-1, v-point - real, allocatable, dimension(:,:,:) :: vPoR !< Non-dimensional position with right layer uKoR-1, v-point + real, allocatable, dimension(:,:,:) :: vPoL !< Non-dimensional position with left layer uKoL-1, v-point [nondim] + real, allocatable, dimension(:,:,:) :: vPoR !< Non-dimensional position with right layer uKoR-1, v-point [nondim] integer, allocatable, dimension(:,:,:) :: vKoL !< Index of left interface corresponding to neutral surface, !! at a v-point integer, allocatable, dimension(:,:,:) :: vKoR !< Index of right interface corresponding to neutral surface, !! at a v-point real, allocatable, dimension(:,:,:) :: vHeff !< Effective thickness at v-point [H ~> m or kg m-2] ! Coefficients of polynomial reconstructions for temperature and salinity - real, allocatable, dimension(:,:,:,:) :: ppoly_coeffs_T !< Polynomial coefficients for temperature - real, allocatable, dimension(:,:,:,:) :: ppoly_coeffs_S !< Polynomial coefficients for salinity + real, allocatable, dimension(:,:,:,:) :: ppoly_coeffs_T !< Polynomial coefficients of the + !! sub-gridscale temperatures [C ~> degC] + real, allocatable, dimension(:,:,:,:) :: ppoly_coeffs_S !< Polynomial coefficients of the + !! sub-gridscale salinity [S ~> ppt] ! Variables needed for continuous reconstructions - real, allocatable, dimension(:,:,:) :: dRdT !< dRho/dT [R degC-1 ~> kg m-3 degC-1] at interfaces - real, allocatable, dimension(:,:,:) :: dRdS !< dRho/dS [R ppt-1 ~> kg m-3 ppt-1] at interfaces - real, allocatable, dimension(:,:,:) :: Tint !< Interface T [degC] - real, allocatable, dimension(:,:,:) :: Sint !< Interface S [ppt] + real, allocatable, dimension(:,:,:) :: dRdT !< dRho/dT [R C-1 ~> kg m-3 degC-1] at interfaces + real, allocatable, dimension(:,:,:) :: dRdS !< dRho/dS [R S-1 ~> kg m-3 ppt-1] at interfaces + real, allocatable, dimension(:,:,:) :: Tint !< Interface T [C ~> degC] + real, allocatable, dimension(:,:,:) :: Sint !< Interface S [S ~> ppt] real, allocatable, dimension(:,:,:) :: Pint !< Interface pressure [R L2 T-2 ~> Pa] ! Variables needed for discontinuous reconstructions - real, allocatable, dimension(:,:,:,:) :: T_i !< Top edge reconstruction of temperature [degC] - real, allocatable, dimension(:,:,:,:) :: S_i !< Top edge reconstruction of salinity [ppt] + real, allocatable, dimension(:,:,:,:) :: T_i !< Top edge reconstruction of temperature [C ~> degC] + real, allocatable, dimension(:,:,:,:) :: S_i !< Top edge reconstruction of salinity [S ~> ppt] real, allocatable, dimension(:,:,:,:) :: P_i !< Interface pressures [R L2 T-2 ~> Pa] - real, allocatable, dimension(:,:,:,:) :: dRdT_i !< dRho/dT [R degC-1 ~> kg m-3 degC-1] at top edge - real, allocatable, dimension(:,:,:,:) :: dRdS_i !< dRho/dS [R ppt-1 ~> kg m-3 ppt-1] at top edge - integer, allocatable, dimension(:,:) :: ns !< Number of interfacs in a column + real, allocatable, dimension(:,:,:,:) :: dRdT_i !< dRho/dT [R C-1 ~> kg m-3 degC-1] at top edge + real, allocatable, dimension(:,:,:,:) :: dRdS_i !< dRho/dS [R S-1 ~> kg m-3 ppt-1] at top edge + integer, allocatable, dimension(:,:) :: ns !< Number of interfaces in a column logical, allocatable, dimension(:,:,:) :: stable_cell !< True if the cell is stably stratified wrt to the next cell real :: R_to_kg_m3 = 1.0 !< A rescaling factor translating density to kg m-3 for !! use in diagnostic messages [kg m-3 R-1 ~> 1]. @@ -100,9 +118,14 @@ module MOM_neutral_diffusion type(EOS_type), pointer :: EOS => NULL() !< Equation of state parameters type(remapping_CS) :: remap_CS !< Remapping control structure used to create sublayers - logical :: remap_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 :: 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. + integer :: ndiff_answer_date !< The vintage of the order of arithmetic to use for the neutral + !! diffusion. Values of 20240330 or below recover the answers + !! from the original form of this code, while higher values use + !! mathematically equivalent expressions that recover rotational symmetry. type(KPP_CS), pointer :: KPP_CSp => NULL() !< KPP control structure needed to get BLD type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL()!< ePBL control structure needed to get MLD end type neutral_diffusion_CS @@ -122,14 +145,17 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(param_file_type), intent(in) :: param_file !< Parameter file structure type(EOS_type), target, intent(in) :: EOS !< Equation of state - type(diabatic_CS), pointer :: diabatic_CSp!< KPP control structure needed to get BLD + type(diabatic_CS), pointer :: diabatic_CSp!< diabatic control structure needed to get BLD type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure ! Local variables - character(len=256) :: mesg ! Message for error messages. - character(len=80) :: string ! Temporary strings - logical :: default_2018_answers - logical :: boundary_extrap + character(len=80) :: string ! Temporary strings + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: debug ! If true, write verbose checksums for debugging purposes. + logical :: boundary_extrap ! Indicate whether high-order boundary + !! extrapolation should be used within boundary cells. + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm + logical :: KhTh_use_ebt_struct, KhTh_use_sqg_struct if (associated(CS)) then call MOM_error(FATAL, "neutral_diffusion_init called with associated control structure.") @@ -163,15 +189,39 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, call get_param(param_file, mdl, "NDIFF_REF_PRES", CS%ref_pres, & "The reference pressure (Pa) used for the derivatives of "//& "the equation of state. If negative (default), local pressure is used.", & - units="Pa", default = -1., scale=US%kg_m3_to_R*US%m_s_to_L_T**2) + units="Pa", default=-1., scale=US%Pa_to_RL2_T2) call get_param(param_file, mdl, "NDIFF_INTERIOR_ONLY", CS%interior_only, & - "If true, only applies neutral diffusion in the ocean interior."//& - "That is, the algorithm will exclude the surface and bottom"//& - "boundary layers.", default = .false.) + "If true, only applies neutral diffusion in the ocean interior. "//& + "That is, the algorithm will exclude the surface and bottom "//& + "boundary layers.", default=.false.) + if (CS%interior_only) then + call get_param(param_file, mdl, "NDIFF_TAPERING", CS%tapering, & + "If true, neutral diffusion linearly decays to zero within "//& + "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", 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 "//& - "recommended.", default = .false.) + "recommended.", default=.false.) + + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "NDIFF_ANSWER_DATE", CS%ndiff_answer_date, & + "The vintage of the order of arithmetic to use for the neutral diffusion. "//& + "Values of 20240330 or below recover the answers from the original form of the "//& + "neutral diffusion code, while higher values use mathematically equivalent "//& + "expressions that recover rotational symmetry.", & + default=default_answer_date) ! Initialize and configure remapping if ( .not.CS%continuous_reconstruction ) then @@ -184,15 +234,22 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, "for vertical remapping for all variables. "//& "It can be one of the following schemes: "//& trim(remappingSchemesDoc), default=remappingDefaultScheme) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=.false.) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", CS%remap_answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) + call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%remap_answer_date, & + "The vintage of the expressions and order of arithmetic to use for remapping. "//& + "Values below 20190101 result in the use of older, less accurate expressions "//& + "that were in use at the end of 2018. Higher values result in the use of more "//& + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + call get_param(param_file, mdl, "REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + do_not_log=.true., default=.true.) + call get_param(param_file, mdl, "NDIFF_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for neutral diffusion. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=om4_remap_via_sub_cells) + if (.not.GV%Boussinesq) CS%remap_answer_date = max(CS%remap_answer_date, 20230701) call initialize_remapping( CS%remap_CS, string, boundary_extrapolation=boundary_extrap, & - answers_2018=CS%remap_answers_2018 ) + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & + answer_date=CS%remap_answer_date ) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) call get_param(param_file, mdl, "NEUTRAL_POS_METHOD", CS%neutral_pos_method, & "Method used to find the neutral position \n"// & @@ -212,41 +269,49 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, " pressure dependence", & default="mid_pressure") if (CS%neutral_pos_method > 1) then - call get_param(param_file, mdl, "NDIFF_DRHO_TOL", CS%drho_tol, & - "Sets the convergence criterion for finding the neutral\n"// & - "position within a layer in kg m-3.", & - default=1.e-10, scale=US%kg_m3_to_R) - call get_param(param_file, mdl, "NDIFF_X_TOL", CS%x_tol, & - "Sets the convergence criterion for a change in nondim\n"// & - "position within a layer.", & - default=0.) + call get_param(param_file, mdl, "NDIFF_DRHO_TOL", CS%drho_tol, & + "Sets the convergence criterion for finding the neutral "// & + "position within a layer in kg m-3.", & + units="kg m-3", default=1.e-10, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "NDIFF_X_TOL", CS%x_tol, & + "Sets the convergence criterion for a change in nondimensional "// & + "position within a layer.", & + units="nondim", default=0.) call get_param(param_file, mdl, "NDIFF_MAX_ITER", CS%max_iter, & - "The maximum number of iterations to be done before \n"// & + "The maximum number of iterations to be done before "// & "exiting the iterative loop to find the neutral surface", & default=10) endif + call get_param(param_file, mdl, "DEBUG", debug, default=.false., do_not_log=.true.) call get_param(param_file, mdl, "NDIFF_DEBUG", CS%debug, & "Turns on verbose output for discontinuous neutral "//& - "diffusion routines.", & - default = .false.) + "diffusion routines.", default=debug) call get_param(param_file, mdl, "HARD_FAIL_HEFF", CS%hard_fail_heff, & "Bring down the model if a problem with heff is detected",& - default = .true.) + default=.true.) endif if (CS%interior_only) then + allocate(CS%hbl(SZI_(G),SZJ_(G)), source=0.) call extract_diabatic_member(diabatic_CSp, KPP_CSp=CS%KPP_CSp) call extract_diabatic_member(diabatic_CSp, energetic_PBL_CSp=CS%energetic_PBL_CSp) if ( .not. ASSOCIATED(CS%energetic_PBL_CSp) .and. .not. ASSOCIATED(CS%KPP_CSp) ) then call MOM_error(FATAL,"NDIFF_INTERIOR_ONLY is true, but no valid boundary layer scheme was found") endif + + if (CS%tapering) then + allocate(CS%coeff_l(SZK_(GV)+1), source=1.) + allocate(CS%coeff_r(SZK_(GV)+1), source=1.) + endif endif + + 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. CS%R_to_kg_m3 = US%R_to_kg_m3 -! call get_param(param_file, mdl, "KHTR", CS%KhTr, & -! "The background along-isopycnal tracer diffusivity.", & -! units="m2 s-1", default=0.0) ! call closeParameterBlock(param_file) if (CS%continuous_reconstruction) then CS%nsurf = 2*GV%ke+2 ! Continuous reconstruction means that every interface has two connections @@ -269,29 +334,31 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, allocate(CS%Pint(SZI_(G),SZJ_(G),SZK_(GV)+1), source=0.) allocate(CS%stable_cell(SZI_(G),SZJ_(G),SZK_(GV)), source=.true.) ! U-points - allocate(CS%uPoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%uPoL(G%isc-1:G%iec,G%jsc:G%jec,:) = 0. - allocate(CS%uPoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%uPoR(G%isc-1:G%iec,G%jsc:G%jec,:) = 0. - allocate(CS%uKoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%uKoL(G%isc-1:G%iec,G%jsc:G%jec,:) = 0 - allocate(CS%uKoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%uKoR(G%isc-1:G%iec,G%jsc:G%jec,:) = 0 - allocate(CS%uHeff(G%isd:G%ied,G%jsd:G%jed,CS%nsurf-1)); CS%uHeff(G%isc-1:G%iec,G%jsc:G%jec,:) = 0 + allocate(CS%uPoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0.) + allocate(CS%uPoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0.) + allocate(CS%uKoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0) + allocate(CS%uKoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0) + allocate(CS%uHeff(G%isd:G%ied,G%jsd:G%jed,CS%nsurf-1), source=0.) ! V-points - allocate(CS%vPoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%vPoL(G%isc:G%iec,G%jsc-1:G%jec,:) = 0. - allocate(CS%vPoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%vPoR(G%isc:G%iec,G%jsc-1:G%jec,:) = 0. - allocate(CS%vKoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%vKoL(G%isc:G%iec,G%jsc-1:G%jec,:) = 0 - allocate(CS%vKoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%vKoR(G%isc:G%iec,G%jsc-1:G%jec,:) = 0 - allocate(CS%vHeff(G%isd:G%ied,G%jsd:G%jed,CS%nsurf-1)); CS%vHeff(G%isc:G%iec,G%jsc-1:G%jec,:) = 0 + allocate(CS%vPoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0.) + allocate(CS%vPoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0.) + allocate(CS%vKoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0) + allocate(CS%vKoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0) + allocate(CS%vHeff(G%isd:G%ied,G%jsd:G%jed,CS%nsurf-1), source=0.) end function neutral_diffusion_init !> Calculate remapping factors for u/v columns used to map adjoining columns to !! a shared coordinate space. -subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) +subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, visc, CS, p_surf) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean 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] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: T !< Potential temperature [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: S !< Salinity [ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: T !< Potential temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: S !< Salinity [S ~> ppt] + type(vertvisc_type), intent(in) :: visc !< Structure with vertical viscosities, + !! boundary layer properties and related fields type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: p_surf !< Surface pressure to include in pressures used !! for equation of state calculations [R L2 T-2 ~> Pa] @@ -300,12 +367,11 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k ! Variables used for reconstructions - real, dimension(SZK_(GV),2) :: ppoly_r_S ! Reconstruction slopes + real, dimension(SZK_(GV),2) :: ppoly_r_S ! Reconstruction slopes that are unused here, in units of a vertical + ! gradient, which for temperature would be [C H-1 ~> degC m-1 or degC m2 kg-1]. real, dimension(SZI_(G), SZJ_(G)) :: hEff_sum ! Summed effective face thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth [H ~> m or kg m-2] integer :: iMethod real, dimension(SZI_(G)) :: ref_pres ! Reference pressure used to calculate alpha/beta [R L2 T-2 ~> Pa] - real, dimension(SZI_(G)) :: rho_tmp ! Routine to calculate drho_dp, returns density which is not used [R ~> kg m-3] real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] integer, dimension(SZI_(G), SZJ_(G)) :: k_top ! Index of the first layer within the boundary real, dimension(SZI_(G), SZJ_(G)) :: zeta_top ! Distance from the top of a layer to the intersection of the @@ -322,23 +388,27 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) ! Check if hbl needs to be extracted if (CS%interior_only) then - if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G, US, m_to_BLD_units=GV%m_to_H) - if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US, & - m_to_MLD_units=GV%m_to_H) - call pass_var(hbl,G%Domain) + if (associated(visc%h_ML)) then + CS%hbl(:,:) = visc%h_ML(:,:) + else + call MOM_error(FATAL, "hor_bnd_diffusion requires that visc%h_ML is associated.") + endif + call pass_var(CS%hbl, G%Domain, halo=1) + ! get k-indices and zeta do j=G%jsc-1, G%jec+1 ; do i=G%isc-1,G%iec+1 - if (G%mask2dT(i,j) > 0.) then - call boundary_k_range(SURFACE, G%ke, h(i,j,:), hbl(i,j), k_top(i,j), zeta_top(i,j), k_bot(i,j), zeta_bot(i,j)) + if (G%mask2dT(i,j) > 0.0) then + call boundary_k_range(SURFACE, G%ke, h(i,j,:), CS%hbl(i,j), k_top(i,j), zeta_top(i,j), k_bot(i,j), & + zeta_bot(i,j)) endif - enddo; enddo + enddo ; enddo ! TODO: add similar code for BOTTOM boundary layer endif h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff if (.not. CS%continuous_reconstruction) then - if (CS%remap_answers_2018) then + if (CS%remap_answer_date < 20190101) then if (GV%Boussinesq) then h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 else @@ -377,7 +447,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) enddo ; enddo ; enddo ! Pressures at the interfaces, this is redundant as P_i(k,1) = P_i(k-1,2) however retain this - ! for now to ensure consitency of indexing for diiscontinuous reconstructions + ! for now to ensure consistency of indexing for discontinuous reconstructions if (.not. CS%continuous_reconstruction) then if (present(p_surf)) then do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 @@ -466,7 +536,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) ! Neutral surface factors at U points do j = G%jsc, G%jec ; do I = G%isc-1, G%iec - if (G%mask2dCu(I,j) > 0.) then + if (G%mask2dCu(I,j) > 0.0) then if (CS%continuous_reconstruction) then call find_neutral_surface_positions_continuous(GV%ke, & CS%Pint(i,j,:), CS%Tint(i,j,:), CS%Sint(i,j,:), CS%dRdT(i,j,:), CS%dRdS(i,j,:), & @@ -487,7 +557,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) ! Neutral surface factors at V points do J = G%jsc-1, G%jec ; do i = G%isc, G%iec - if (G%mask2dCv(i,J) > 0.) then + if (G%mask2dCv(i,J) > 0.0) then if (CS%continuous_reconstruction) then call find_neutral_surface_positions_continuous(GV%ke, & CS%Pint(i,j,:), CS%Tint(i,j,:), CS%Sint(i,j,:), CS%dRdT(i,j,:), CS%dRdS(i,j,:), & @@ -522,10 +592,10 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) enddo ; enddo ; enddo else do k = 1, CS%nsurf-1 ; do j = G%jsc, G%jec ; do I = G%isc-1, G%iec - if (G%mask2dCu(I,j) > 0.) CS%uhEff(I,j,k) = CS%uhEff(I,j,k) * pa_to_H + if (G%mask2dCu(I,j) > 0.0) CS%uhEff(I,j,k) = CS%uhEff(I,j,k) * pa_to_H enddo ; enddo ; enddo do k = 1, CS%nsurf-1 ; do J = G%jsc-1, G%jec ; do i = G%isc, G%iec - if (G%mask2dCv(i,J) > 0.) CS%vhEff(i,J,k) = CS%vhEff(i,J,k) * pa_to_H + if (G%mask2dCv(i,J) > 0.0) CS%vhEff(i,J,k) = CS%vhEff(i,J,k) * pa_to_H enddo ; enddo ; enddo endif endif @@ -549,44 +619,86 @@ end subroutine neutral_diffusion_calc_coeffs !> Update tracer concentration due to neutral diffusion; layer thickness unchanged by this update. subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [L2 ~> m2] - real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Coef_y !< dt * Kh * dx / dy at v-points [L2 ~> m2] - real, intent(in) :: dt !< Tracer time step * I_numitts [T ~> s] - !! (I_numitts in tracer_hordiff) - type(tracer_registry_type), pointer :: Reg !< Tracer registry - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [L2 ~> m2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: Coef_y !< dt * Kh * dx / dy at v-points [L2 ~> m2] + real, intent(in) :: dt !< Tracer time step * I_numitts [T ~> s] + !! (I_numitts is in tracer_hordiff) + type(tracer_registry_type), pointer :: Reg !< Tracer registry + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure ! Local variables - real, dimension(SZIB_(G),SZJ_(G),CS%nsurf-1) :: uFlx ! Zonal flux of tracer [H conc ~> m conc or conc kg m-2] - real, dimension(SZI_(G),SZJB_(G),CS%nsurf-1) :: vFlx ! Meridional flux of tracer - ! [H conc ~> m conc or conc kg m-2] + 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_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_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] - real, dimension(SZI_(G),SZJ_(G)) :: tendency_2d ! depth integrated content tendency for diagn - ! [H conc T-1 ~> m conc s-1 or kg m-2 conc s-1] - real, dimension(SZIB_(G),SZJ_(G)) :: trans_x_2d ! depth integrated diffusive tracer x-transport diagn - real, dimension(SZI_(G),SZJB_(G)) :: trans_y_2d ! depth integrated diffusive tracer y-transport diagn - real, dimension(SZK_(GV)) :: dTracer ! change in tracer concentration due to ndiffusion - ! [H L2 conc ~> m3 conc or kg conc] + ! For temperature these units are + ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1]. + real, dimension(SZI_(G),SZJ_(G)) :: tendency_2d ! Depth integrated content tendency for diagnostics + ! [H conc T-1 ~> m conc s-1 or kg m-2 conc s-1]. + ! For temperature these units are + ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1]. + real, dimension(SZIB_(G),SZJ_(G)) :: trans_x_2d ! Depth integrated diffusive tracer x-transport + ! diagnostic. For temperature this has units of + ! [C H L2 ~> degC m3 or degC kg]. + real, dimension(SZI_(G),SZJB_(G)) :: trans_y_2d ! depth integrated diffusive tracer y-transport + ! diagnostic. For temperature this has units of + ! [C H L2 ~> degC m3 or degC kg]. + real, dimension(SZK_(GV)) :: dTracer ! Change in tracer concentration due to neutral diffusion + ! [H L2 conc ~> m3 conc or kg conc]. For temperature + ! these units are [C H L2 ~> degC m3 or degC kg]. + real, dimension(SZK_(GV)) :: dTracer_N ! Change in tracer concentration due to neutral diffusion + ! into a cell via its logically northern face, in + ! [H L2 conc ~> m3 conc or kg conc]. + real, dimension(SZK_(GV)) :: dTracer_S ! Change in tracer concentration due to neutral diffusion + ! into a cell via its logically southern face, in + ! [H L2 conc ~> m3 conc or kg conc]. + real, dimension(SZK_(GV)) :: dTracer_E ! Change in tracer concentration due to neutral diffusion + ! into a cell via its logically eastern face, in + ! [H L2 conc ~> m3 conc or kg conc]. + real, dimension(SZK_(GV)) :: dTracer_W ! Change in tracer concentration due to neutral diffusion + ! into a cell via its logically western face, in + ! [H L2 conc ~> m3 conc or kg conc]. + real :: normalize ! normalization used for averaging Coef_x and Coef_y to t-points [nondim]. type(tracer_type), pointer :: Tracer => NULL() ! Pointer to the current tracer integer :: i, j, k, m, ks, nk real :: Idt ! The inverse of the time step [T-1 ~> s-1] - real :: h_neglect, h_neglect_edge - + real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff if (.not. CS%continuous_reconstruction) then - if (CS%remap_answers_2018) then + if (CS%remap_answer_date < 20190101) then h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 endif endif + 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 + if (G%mask2dT(i,j)>0.) then + normalize = 1.0 / ((G%mask2dCu(I-1,j)+G%mask2dCu(I,j)) + & + (G%mask2dCv(i,J-1)+G%mask2dCv(i,J)) + 1.0e-37) + do k = 1, GV%ke+1 + CS%Coef_h(i,j,k) = normalize*G%mask2dT(i,j)*((Coef_x(I-1,j,k)+Coef_x(I,j,k)) + & + (Coef_y(i,J-1,k)+Coef_y(i,J,k))) + enddo + endif + enddo ; enddo + call pass_var(CS%Coef_h,G%Domain) + endif + nk = GV%ke do m = 1,Reg%ntr ! Loop over tracer registry @@ -604,85 +716,291 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) vFlx(:,:,:) = 0. ! x-flux - do j = G%jsc,G%jec ; do I = G%isc-1,G%iec - if (G%mask2dCu(I,j)>0.) then - call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & - tracer%t(i,j,:), tracer%t(i+1,j,:), & - CS%uPoL(I,j,:), CS%uPoR(I,j,:), & - CS%uKoL(I,j,:), CS%uKoR(I,j,:), & - CS%uhEff(I,j,:), uFlx(I,j,:), & - CS%continuous_reconstruction, h_neglect, CS%remap_CS, h_neglect_edge) + 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 + ! compute coeff_l and coeff_r and pass them to neutral_surface_flux + call compute_tapering_coeffs(G%ke+1, CS%hbl(I,j), CS%hbl(I+1,j), CS%coeff_l(:), CS%coeff_r(:), & + h(I,j,:), h(I+1,j,:)) + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & + tracer%t(i,j,:), tracer%t(i+1,j,:), & + CS%uPoL(I,j,:), CS%uPoR(I,j,:), & + CS%uKoL(I,j,:), CS%uKoR(I,j,:), & + CS%uhEff(I,j,:), uFlx(I,j,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge, CS%coeff_l(:)*CS%Coef_h(i,j,:), & + CS%coeff_r(:)*CS%Coef_h(i+1,j,:)) + endif + enddo ; enddo + else + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec + if (G%mask2dCu(I,j)>0.) then + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & + tracer%t(i,j,:), tracer%t(i+1,j,:), & + CS%uPoL(I,j,:), CS%uPoR(I,j,:), & + CS%uKoL(I,j,:), CS%uKoR(I,j,:), & + CS%uhEff(I,j,:), uFlx(I,j,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge, CS%Coef_h(i,j,:), & + CS%Coef_h(i+1,j,:)) + endif + enddo ; enddo endif - enddo ; enddo + else + if (CS%tapering) then + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec + if (G%mask2dCu(I,j)>0.) then + ! compute coeff_l and coeff_r and pass them to neutral_surface_flux + call compute_tapering_coeffs(G%ke+1, CS%hbl(I,j), CS%hbl(I+1,j), CS%coeff_l(:), CS%coeff_r(:), & + h(I,j,:), h(I+1,j,:)) + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & + tracer%t(i,j,:), tracer%t(i+1,j,:), & + CS%uPoL(I,j,:), CS%uPoR(I,j,:), & + CS%uKoL(I,j,:), CS%uKoR(I,j,:), & + CS%uhEff(I,j,:), uFlx(I,j,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge, CS%coeff_l(:), & + CS%coeff_r(:)) + endif + enddo ; enddo + else + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec + if (G%mask2dCu(I,j)>0.) then + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & + tracer%t(i,j,:), tracer%t(i+1,j,:), & + CS%uPoL(I,j,:), CS%uPoR(I,j,:), & + CS%uKoL(I,j,:), CS%uKoR(I,j,:), & + CS%uhEff(I,j,:), uFlx(I,j,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge) + endif + enddo ; enddo + endif + endif ! y-flux - do J = G%jsc-1,G%jec ; do i = G%isc,G%iec - if (G%mask2dCv(i,J)>0.) then - call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & - tracer%t(i,j,:), tracer%t(i,j+1,:), & - CS%vPoL(i,J,:), CS%vPoR(i,J,:), & - CS%vKoL(i,J,:), CS%vKoR(i,J,:), & - CS%vhEff(i,J,:), vFlx(i,J,:), & - CS%continuous_reconstruction, h_neglect, CS%remap_CS, h_neglect_edge) + 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 + ! compute coeff_l and coeff_r and pass them to neutral_surface_flux + call compute_tapering_coeffs(G%ke+1, CS%hbl(i,J), CS%hbl(i,J+1), CS%coeff_l(:), CS%coeff_r(:), & + h(i,J,:), h(i,J+1,:)) + + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & + tracer%t(i,j,:), tracer%t(i,j+1,:), & + CS%vPoL(i,J,:), CS%vPoR(i,J,:), & + CS%vKoL(i,J,:), CS%vKoR(i,J,:), & + CS%vhEff(i,J,:), vFlx(i,J,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge, CS%coeff_l(:)*CS%Coef_h(i,j,:), & + CS%coeff_r(:)*CS%Coef_h(i,j+1,:)) + endif + enddo ; enddo + else + do J = G%jsc-1,G%jec ; do i = G%isc,G%iec + if (G%mask2dCv(i,J)>0.) then + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & + tracer%t(i,j,:), tracer%t(i,j+1,:), & + CS%vPoL(i,J,:), CS%vPoR(i,J,:), & + CS%vKoL(i,J,:), CS%vKoR(i,J,:), & + CS%vhEff(i,J,:), vFlx(i,J,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge, CS%Coef_h(i,j,:), & + CS%Coef_h(i,j+1,:)) + endif + enddo ; enddo endif - enddo ; enddo + else + if (CS%tapering) then + do J = G%jsc-1,G%jec ; do i = G%isc,G%iec + if (G%mask2dCv(i,J)>0.) then + ! compute coeff_l and coeff_r and pass them to neutral_surface_flux + call compute_tapering_coeffs(G%ke+1, CS%hbl(i,J), CS%hbl(i,J+1), CS%coeff_l(:), CS%coeff_r(:), & + h(i,J,:), h(i,J+1,:)) + + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & + tracer%t(i,j,:), tracer%t(i,j+1,:), & + CS%vPoL(i,J,:), CS%vPoR(i,J,:), & + CS%vKoL(i,J,:), CS%vKoR(i,J,:), & + CS%vhEff(i,J,:), vFlx(i,J,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge, CS%coeff_l(:), & + CS%coeff_r(:)) + endif + enddo ; enddo + else + do J = G%jsc-1,G%jec ; do i = G%isc,G%iec + if (G%mask2dCv(i,J)>0.) then + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & + tracer%t(i,j,:), tracer%t(i,j+1,:), & + CS%vPoL(i,J,:), CS%vPoR(i,J,:), & + CS%vKoL(i,J,:), CS%vKoR(i,J,:), & + CS%vhEff(i,J,:), vFlx(i,J,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge) + endif + enddo ; enddo + endif + endif - ! Update the tracer concentration from divergence of neutral diffusive flux components - do j = G%jsc,G%jec ; do i = G%isc,G%iec - if (G%mask2dT(i,j)>0.) then + ! 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_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 + dTracer(:) = 0. + do ks = 1,CS%nsurf-1 + k = CS%uKoL(I,j,ks) + dTracer(k) = dTracer(k) + uFlx(I,j,ks) + k = CS%uKoR(I-1,j,ks) + dTracer(k) = dTracer(k) - uFlx(I-1,j,ks) + k = CS%vKoL(i,J,ks) + dTracer(k) = dTracer(k) + vFlx(i,J,ks) + k = CS%vKoR(i,J-1,ks) + dTracer(k) = dTracer(k) - vFlx(i,J-1,ks) + enddo + else ! This form recovers rotational symmetry. + dTracer_N(:) = 0.0 ; dTracer_S(:) = 0.0 ; dTracer_E(:) = 0.0 ; dTracer_W(:) = 0.0 + do ks = 1,CS%nsurf-1 + k = CS%uKoL(I,j,ks) + dTracer_E(k) = dTracer_E(k) + uFlx(I,j,ks) + k = CS%uKoR(I-1,j,ks) + dTracer_W(k) = dTracer_W(k) - uFlx(I-1,j,ks) + k = CS%vKoL(i,J,ks) + dTracer_N(k) = dTracer_N(k) + vFlx(i,J,ks) + k = CS%vKoR(i,J-1,ks) + dTracer_S(k) = dTracer_S(k) - vFlx(i,J-1,ks) + enddo + do k = 1, GV%ke + dTracer(k) = (dTracer_N(k) + dTracer_S(k)) + (dTracer_E(k) + dTracer_W(k)) + enddo + endif + do k = 1, GV%ke + tracer%t(i,j,k) = tracer%t(i,j,k) + dTracer(k) * & + ( G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) ) + if (abs(tracer%t(i,j,k)) < tracer%conc_underflow) tracer%t(i,j,k) = 0.0 + enddo - dTracer(:) = 0. - do ks = 1,CS%nsurf-1 - k = CS%uKoL(I,j,ks) - dTracer(k) = dTracer(k) + Coef_x(I,j) * uFlx(I,j,ks) - k = CS%uKoR(I-1,j,ks) - dTracer(k) = dTracer(k) - Coef_x(I-1,j) * uFlx(I-1,j,ks) - k = CS%vKoL(i,J,ks) - dTracer(k) = dTracer(k) + Coef_y(i,J) * vFlx(i,J,ks) - k = CS%vKoR(i,J-1,ks) - dTracer(k) = dTracer(k) - Coef_y(i,J-1) * vFlx(i,J-1,ks) - enddo - do k = 1, GV%ke - tracer%t(i,j,k) = tracer%t(i,j,k) + dTracer(k) * & - ( G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) ) - enddo + if (tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 ) then + do k = 1, GV%ke + tendency(i,j,k) = dTracer(k) * G%IareaT(i,j) * Idt + enddo + endif - if (tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 ) then + endif + enddo ; enddo + else + 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 + dTracer(:) = 0. + do ks = 1,CS%nsurf-1 + k = CS%uKoL(I,j,ks) + dTracer(k) = dTracer(k) + Coef_x(I,j,1) * uFlx(I,j,ks) + k = CS%uKoR(I-1,j,ks) + dTracer(k) = dTracer(k) - Coef_x(I-1,j,1) * uFlx(I-1,j,ks) + k = CS%vKoL(i,J,ks) + dTracer(k) = dTracer(k) + Coef_y(i,J,1) * vFlx(i,J,ks) + k = CS%vKoR(i,J-1,ks) + dTracer(k) = dTracer(k) - Coef_y(i,J-1,1) * vFlx(i,J-1,ks) + enddo + else ! This form recovers rotational symmetry. + dTracer_N(:) = 0.0 ; dTracer_S(:) = 0.0 ; dTracer_E(:) = 0.0 ; dTracer_W(:) = 0.0 + do ks = 1,CS%nsurf-1 + k = CS%uKoL(I,j,ks) + dTracer_E(k) = dTracer_E(k) + Coef_x(I,j,1) * uFlx(I,j,ks) + k = CS%uKoR(I-1,j,ks) + dTracer_W(k) = dTracer_W(k) - Coef_x(I-1,j,1) * uFlx(I-1,j,ks) + k = CS%vKoL(i,J,ks) + dTracer_N(k) = dTracer_N(k) + Coef_y(i,J,1) * vFlx(i,J,ks) + k = CS%vKoR(i,J-1,ks) + dTracer_S(k) = dTracer_S(k) - Coef_y(i,J-1,1) * vFlx(i,J-1,ks) + enddo + do k = 1, GV%ke + dTracer(k) = (dTracer_N(k) + dTracer_S(k)) + (dTracer_E(k) + dTracer_W(k)) + enddo + endif do k = 1, GV%ke - tendency(i,j,k) = dTracer(k) * G%IareaT(i,j) * Idt + tracer%t(i,j,k) = tracer%t(i,j,k) + dTracer(k) * & + ( G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) ) + if (abs(tracer%t(i,j,k)) < tracer%conc_underflow) tracer%t(i,j,k) = 0.0 enddo + + if (tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 ) then + do k = 1, GV%ke + tendency(i,j,k) = dTracer(k) * G%IareaT(i,j) * Idt + enddo + endif + endif + enddo ; enddo + endif - endif - enddo ; enddo + ! Do user controlled underflow of the tracer concentrations. + if (tracer%conc_underflow > 0.0) then + do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (abs(tracer%t(i,j,k)) < tracer%conc_underflow) tracer%t(i,j,k) = 0.0 + enddo ; enddo ; enddo + endif ! Diagnose vertically summed zonal flux, giving zonal tracer transport from ndiff. ! Note sign corresponds to downgradient flux convention. if (tracer%id_dfx_2d > 0) 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 - do ks = 1,CS%nsurf-1 - trans_x_2d(I,j) = trans_x_2d(I,j) - Coef_x(I,j) * uFlx(I,j,ks) - enddo - trans_x_2d(I,j) = trans_x_2d(I,j) * Idt - endif - enddo ; enddo + + 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 + do ks = 1,CS%nsurf-1 + trans_x_2d(I,j) = trans_x_2d(I,j) - uFlx(I,j,ks) + enddo + trans_x_2d(I,j) = trans_x_2d(I,j) * Idt + endif + enddo ; enddo + else + 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 + do ks = 1,CS%nsurf-1 + trans_x_2d(I,j) = trans_x_2d(I,j) - Coef_x(I,j,1) * uFlx(I,j,ks) + enddo + trans_x_2d(I,j) = trans_x_2d(I,j) * Idt + endif + enddo ; enddo + endif + call post_data(tracer%id_dfx_2d, trans_x_2d(:,:), CS%diag) endif ! Diagnose vertically summed merid flux, giving meridional tracer transport from ndiff. ! Note sign corresponds to downgradient flux convention. if (tracer%id_dfy_2d > 0) 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 - do ks = 1,CS%nsurf-1 - trans_y_2d(i,J) = trans_y_2d(i,J) - Coef_y(i,J) * vFlx(i,J,ks) - enddo - trans_y_2d(i,J) = trans_y_2d(i,J) * Idt - endif - enddo ; enddo + + 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 + do ks = 1,CS%nsurf-1 + trans_y_2d(i,J) = trans_y_2d(i,J) - vFlx(i,J,ks) + enddo + trans_y_2d(i,J) = trans_y_2d(i,J) * Idt + endif + enddo ; enddo + else + 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 + do ks = 1,CS%nsurf-1 + trans_y_2d(i,J) = trans_y_2d(i,J) - Coef_y(i,J,1) * vFlx(i,J,ks) + enddo + trans_y_2d(i,J) = trans_y_2d(i,J) * Idt + endif + enddo ; enddo + endif + call post_data(tracer%id_dfy_2d, trans_y_2d(:,:), CS%diag) endif @@ -715,19 +1033,80 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) end subroutine neutral_diffusion +!> Computes linear tapering coefficients at interfaces of the left and right columns +!! within a region defined by the boundary layer depths in the two columns. +subroutine compute_tapering_coeffs(ne, bld_l, bld_r, coeff_l, coeff_r, h_l, h_r) + integer, intent(in) :: ne !< Number of interfaces + real, intent(in) :: bld_l !< Boundary layer depth, left column [H ~> m or kg m-2] + real, intent(in) :: bld_r !< Boundary layer depth, right column [H ~> m or kg m-2] + real, dimension(ne-1), intent(in) :: h_l !< Layer thickness, left column [H ~> m or kg m-2] + real, dimension(ne-1), intent(in) :: h_r !< Layer thickness, right column [H ~> m or kg m-2] + real, dimension(ne), intent(inout) :: coeff_l !< Tapering coefficient, left column [nondim] + real, dimension(ne), intent(inout) :: coeff_r !< Tapering coefficient, right column [nondim] + + ! Local variables + real :: min_bld ! Minimum of the boundary layer depth in two adjacent columns [H ~> m or kg m-2] + real :: max_bld ! Maximum of the boundary layer depth in two adjacent columns [H ~> m or kg m-2] + integer :: dummy1 ! dummy integer + real :: dummy2 ! dummy real [nondim] + integer :: k_min_l, k_min_r, k_max_l, k_max_r ! Min/max vertical indices in two adjacent columns + real :: zeta_l, zeta_r ! dummy variables [nondim] + integer :: k ! vertical index + + ! Initialize coefficients + coeff_l(:) = 1.0 + coeff_r(:) = 1.0 + + ! Calculate vertical indices containing the boundary layer depths + max_bld = MAX(bld_l, bld_r) + min_bld = MIN(bld_l, bld_r) + + ! k_min + call boundary_k_range(SURFACE, ne-1, h_l, min_bld, dummy1, dummy2, k_min_l, & + zeta_l) + call boundary_k_range(SURFACE, ne-1, h_r, min_bld, dummy1, dummy2, k_min_r, & + zeta_r) + + ! k_max + call boundary_k_range(SURFACE, ne-1, h_l, max_bld, dummy1, dummy2, k_max_l, & + zeta_l) + call boundary_k_range(SURFACE, ne-1, h_r, max_bld, dummy1, dummy2, k_max_r, & + zeta_r) + ! left + do k=1,k_min_l + coeff_l(k) = 0.0 + enddo + do k=k_min_l+1,k_max_l+1 + coeff_l(k) = (real(k - k_min_l) + 1.0)/(real(k_max_l - k_min_l) + 2.0) + enddo + + ! right + do k=1,k_min_r + coeff_r(k) = 0.0 + enddo + do k=k_min_r+1,k_max_r+1 + coeff_r(k) = (real(k - k_min_r) + 1.0)/(real(k_max_r - k_min_r) + 2.0) + enddo + +end subroutine compute_tapering_coeffs + !> Returns interface scalar, Si, for a column of layer values, S. subroutine interface_scalar(nk, h, S, Si, i_method, h_neglect) integer, intent(in) :: nk !< Number of levels real, dimension(nk), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - real, dimension(nk), intent(in) :: S !< Layer scalar (conc, e.g. ppt) - real, dimension(nk+1), intent(inout) :: Si !< Interface scalar (conc, e.g. ppt) + real, dimension(nk), intent(in) :: S !< Layer scalar (or concentrations) in arbitrary + !! concentration units (e.g. [C ~> degC] for temperature) + real, dimension(nk+1), intent(inout) :: Si !< Interface scalar (or concentrations) in arbitrary + !! concentration units (e.g. [C ~> degC] for temperature) integer, intent(in) :: i_method !< =1 use average of PLM edges !! =2 use continuous PPM edge interpolation real, intent(in) :: h_neglect !< A negligibly small thickness [H ~> m or kg m-2] ! Local variables integer :: k, km2, kp1 - real, dimension(nk) :: diff - real :: Sb, Sa + real, dimension(nk) :: diff ! Difference in scalar concentrations between layer centers in arbitrary + ! concentration units (e.g. [C ~> degC] for temperature) + real :: Sb, Sa ! Values of scalar concentrations at the upper and lower edges of a layer in arbitrary + ! concentration units (e.g. [C ~> degC] for temperature) call PLM_diff(nk, h, S, 2, 1, diff) Si(1) = S(1) - 0.5 * diff(1) @@ -754,19 +1133,26 @@ end subroutine interface_scalar !> Returns the PPM quasi-fourth order edge value at k+1/2 following !! equation 1.6 in Colella & Woodward, 1984: JCP 54, 174-201. +!! The returned units are the same as those of Ak (e.g. [C ~> degC] for temperature). real function ppm_edge(hkm1, hk, hkp1, hkp2, Ak, Akp1, Pk, Pkp1, h_neglect) - real, intent(in) :: hkm1 !< Width of cell k-1 - real, intent(in) :: hk !< Width of cell k - real, intent(in) :: hkp1 !< Width of cell k+1 - real, intent(in) :: hkp2 !< Width of cell k+2 - real, intent(in) :: Ak !< Average scalar value of cell k - real, intent(in) :: Akp1 !< Average scalar value of cell k+1 - real, intent(in) :: Pk !< PLM slope for cell k - real, intent(in) :: Pkp1 !< PLM slope for cell k+1 + real, intent(in) :: hkm1 !< Width of cell k-1 in [H ~> m or kg m-2] or other units + real, intent(in) :: hk !< Width of cell k in [H ~> m or kg m-2] or other units + real, intent(in) :: hkp1 !< Width of cell k+1 in [H ~> m or kg m-2] or other units + real, intent(in) :: hkp2 !< Width of cell k+2 in [H ~> m or kg m-2] or other units + real, intent(in) :: Ak !< Average scalar value of cell k in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, intent(in) :: Akp1 !< Average scalar value of cell k+1 in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, intent(in) :: Pk !< PLM slope for cell k in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, intent(in) :: Pkp1 !< PLM slope for cell k+1 in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) real, intent(in) :: h_neglect !< A negligibly small thickness [H ~> m or kg m-2] ! Local variables - real :: R_hk_hkp1, R_2hk_hkp1, R_hk_2hkp1, f1, f2, f3, f4 + real :: R_hk_hkp1, R_2hk_hkp1, R_hk_2hkp1 ! Reciprocals of combinations of thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: f1 ! A work variable with units of an inverse cell width [H-1 ~> m-1 or m2 kg-1] + real :: f2, f3, f4 ! Work variables with units of the cell width [H ~> m or kg m-2] R_hk_hkp1 = hk + hkp1 if (R_hk_hkp1 <= 0.) then @@ -792,17 +1178,23 @@ real function ppm_edge(hkm1, hk, hkp1, hkp2, Ak, Akp1, Pk, Pkp1, h_neglect) end function ppm_edge -!> Returns the average of a PPM reconstruction between two -!! fractional positions. +!> Returns the average of a PPM reconstruction between two fractional positions in the same +!! arbitrary concentration units as aMean (e.g. usually [C ~> degC] for temperature) real function ppm_ave(xL, xR, aL, aR, aMean) - real, intent(in) :: xL !< Fraction position of left bound (0,1) - real, intent(in) :: xR !< Fraction position of right bound (0,1) - real, intent(in) :: aL !< Left edge scalar value, at x=0 - real, intent(in) :: aR !< Right edge scalar value, at x=1 - real, intent(in) :: aMean !< Average scalar value of cell + real, intent(in) :: xL !< Fraction position of left bound (0,1) [nondim] + real, intent(in) :: xR !< Fraction position of right bound (0,1) [nondim] + real, intent(in) :: aL !< Left edge scalar value, at x=0, in arbitrary concentration + !! units (e.g. usually [C ~> degC] for temperature) + real, intent(in) :: aR !< Right edge scalar value, at x=1 in arbitrary concentration + !! units (e.g. usually [C ~> degC] for temperature) + real, intent(in) :: aMean !< Average scalar value of cell in arbitrary concentration + !! units (e.g. usually [C ~> degC] for temperature) ! Local variables - real :: dx, xave, a6, a6o3 + real :: dx ! Distance between the bounds [nondim] + real :: xave ! Average fractional position [nondim] + real :: a6, a6o3 ! Terms proportional to the normalized scalar curvature in the same arbitrary + ! concentration units as aMean (e.g. usually [C ~> degC] for temperature) dx = xR - xL xave = 0.5 * ( xR + xL ) @@ -810,9 +1202,9 @@ real function ppm_ave(xL, xR, aL, aR, aMean) a6 = 3. * a6o3 if (dx<0.) then - stop 'ppm_ave: dx<0 should not happend!' + stop 'ppm_ave: dx<0 should not happened!' elseif (dx>1.) then - stop 'ppm_ave: dx>1 should not happend!' + stop 'ppm_ave: dx>1 should not happened!' elseif (dx==0.) then ppm_ave = aL + ( aR - aL ) * xR + a6 * xR * ( 1. - xR ) else @@ -821,9 +1213,10 @@ real function ppm_ave(xL, xR, aL, aR, aMean) end function ppm_ave !> A true signum function that returns either -abs(a), when x<0; or abs(a) when x>0; or 0 when x=0. +!! The returned units are the same as those of a [arbitrary]. real function signum(a,x) - real, intent(in) :: a !< The magnitude argument - real, intent(in) :: x !< The sign (or zero) argument + real, intent(in) :: a !< The magnitude argument in arbitrary units [arbitrary] + real, intent(in) :: x !< The sign (or zero) argument [arbitrary] signum = sign(a,x) if (x==0.) signum = 0. @@ -834,11 +1227,13 @@ end function signum !! The limiting follows equation 1.8 in Colella & Woodward, 1984: JCP 54, 174-201. subroutine PLM_diff(nk, h, S, c_method, b_method, diff) integer, intent(in) :: nk !< Number of levels - real, dimension(nk), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - real, dimension(nk), intent(in) :: S !< Layer salinity (conc, e.g. ppt) + real, dimension(nk), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] or other units + real, dimension(nk), intent(in) :: S !< Layer salinity (conc, e.g. ppt) or other tracer + !! concentration in arbitrary units [A ~> a] integer, intent(in) :: c_method !< Method to use for the centered difference integer, intent(in) :: b_method !< =1, use PCM in first/last cell, =2 uses linear extrapolation real, dimension(nk), intent(inout) :: diff !< Scalar difference across layer (conc, e.g. ppt) + !! in the same arbitrary units as S [A ~> a], !! determined by the following values for c_method: !! 1. Second order finite difference (not recommended) !! 2. Second order finite volume (used in original PPM) @@ -848,7 +1243,9 @@ subroutine PLM_diff(nk, h, S, c_method, b_method, diff) ! Local variables integer :: k - real :: hkm1, hk, hkp1, Skm1, Sk, Skp1, diff_l, diff_r, diff_c + real :: hkm1, hk, hkp1 ! Successive layer thicknesses [H ~> m or kg m-2] or other units + real :: Skm1, Sk, Skp1 ! Successive layer tracer concentrations in the same arbitrary units as S [A ~> a] + real :: diff_l, diff_r, diff_c ! Differences in tracer concentrations in arbitrary units [A ~> a] do k = 2, nk-1 hkm1 = h(k-1) @@ -867,7 +1264,7 @@ subroutine PLM_diff(nk, h, S, c_method, b_method, diff) diff_c = 0. endif elseif (c_method==2) then - ! Second order accurate centered FV slope (from Colella and Woodward, JCP 1984) + ! Second order accurate centered finite-volume slope (from Colella and Woodward, JCP 1984) diff_c = fv_diff(hkm1, hk, hkp1, Skm1, Sk, Skp1) elseif (c_method==3) then ! Second order accurate finite-volume least squares slope @@ -895,20 +1292,24 @@ subroutine PLM_diff(nk, h, S, c_method, b_method, diff) end subroutine PLM_diff -!> Returns the cell-centered second-order finite volume (unlimited PLM) slope -!! using three consecutive cell widths and average values. Slope is returned -!! as a difference across the central cell (i.e. units of scalar S). +!> Returns the cell-centered second-order finite volume (unlimited PLM) slope using three +!! consecutive cell widths and average values. Slope is returned as a difference across +!! the central cell (i.e. units of scalar S, e.g. [C ~> degC] for temperature). !! Discretization follows equation 1.7 in Colella & Woodward, 1984: JCP 54, 174-201. real function fv_diff(hkm1, hk, hkp1, Skm1, Sk, Skp1) - real, intent(in) :: hkm1 !< Left cell width - real, intent(in) :: hk !< Center cell width - real, intent(in) :: hkp1 !< Right cell width - real, intent(in) :: Skm1 !< Left cell average value - real, intent(in) :: Sk !< Center cell average value - real, intent(in) :: Skp1 !< Right cell average value + real, intent(in) :: hkm1 !< Left cell width [H ~> m or kg m-2] or other arbitrary units + real, intent(in) :: hk !< Center cell width [H ~> m or kg m-2] or other arbitrary units + real, intent(in) :: hkp1 !< Right cell width [H ~> m or kg m-2] or other arbitrary units + real, intent(in) :: Skm1 !< Left cell average value in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, intent(in) :: Sk !< Center cell average value in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, intent(in) :: Skp1 !< Right cell average value in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) ! Local variables - real :: h_sum, hp, hm + real :: h_sum, hp, hm ! At first sums of thicknesses [H ~> m or kg m-2], then changed into + ! their reciprocals [H-1 ~> m-1 or m2 kg-1] h_sum = ( hkm1 + hkp1 ) + hk if (h_sum /= 0.) h_sum = 1./ h_sum @@ -923,19 +1324,30 @@ end function fv_diff !> Returns the cell-centered second-order weighted least squares slope -!! using three consecutive cell widths and average values. Slope is returned -!! as a gradient (i.e. units of scalar S over width units). +!! using three consecutive cell widths and average values. Slope is returned +!! as a gradient (i.e. units of scalar S over width units). For example, for temperature +!! fvlsq_slope would usually be returned in units of [C H-1 ~> degC m-1 or degC m2 kg-1]. real function fvlsq_slope(hkm1, hk, hkp1, Skm1, Sk, Skp1) - real, intent(in) :: hkm1 !< Left cell width - real, intent(in) :: hk !< Center cell width - real, intent(in) :: hkp1 !< Right cell width - real, intent(in) :: Skm1 !< Left cell average value - real, intent(in) :: Sk !< Center cell average value - real, intent(in) :: Skp1 !< Right cell average value + real, intent(in) :: hkm1 !< Left cell width [H ~> m or kg m-2] or other arbitrary units + real, intent(in) :: hk !< Center cell width [H ~> m or kg m-2] or other arbitrary units + real, intent(in) :: hkp1 !< Right cell width [H ~> m or kg m-2] or other arbitrary units + real, intent(in) :: Skm1 !< Left cell average value in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, intent(in) :: Sk !< Center cell average value often in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, intent(in) :: Skp1 !< Right cell average value often in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) ! Local variables - real :: xkm1, xkp1 - real :: h_sum, hx_sum, hxsq_sum, hxy_sum, hy_sum, det + real :: xkm1, xkp1 ! Distances between layer centers [H ~> m or kg m-2] or other arbitrary units + real :: h_sum ! Sum of the successive cell widths [H ~> m or kg m-2] or other arbitrary units + real :: hx_sum ! Thicknesses times distances [H2 ~> m2 or kg2 m-4] + real :: hxsq_sum ! Thicknesses times squared distances [H3 ~> m3 or kg3 m-6] + real :: det ! The denominator in the weighted slope calculation [H4 ~> m4 or kg4 m-8] + real :: hxy_sum ! Sum of layer concentrations times thicknesses and distances in units that + ! depend on those of Sk (e.g. [C H2 ~> degC m2 or degC kg2 m-4] for temperature) + real :: hy_sum ! Sum of layer concentrations times thicknesses in units that depend on + ! those of Sk (e.g. [C H ~> degC m or degC kg m-2] for temperature) xkm1 = -0.5 * ( hk + hkm1 ) xkp1 = 0.5 * ( hk + hkp1 ) @@ -959,15 +1371,15 @@ subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdS dRdTr, dRdSr, PoL, PoR, KoL, KoR, hEff, bl_kl, bl_kr, bl_zl, bl_zr) integer, intent(in) :: nk !< Number of levels real, dimension(nk+1), intent(in) :: Pl !< Left-column interface pressure [R L2 T-2 ~> Pa] or other units - real, dimension(nk+1), intent(in) :: Tl !< Left-column interface potential temperature [degC] - real, dimension(nk+1), intent(in) :: Sl !< Left-column interface salinity [ppt] - real, dimension(nk+1), intent(in) :: dRdTl !< Left-column dRho/dT [R degC-1 ~> kg m-3 degC-1] - real, dimension(nk+1), intent(in) :: dRdSl !< Left-column dRho/dS [R ppt-1 ~> kg m-3 ppt-1] + real, dimension(nk+1), intent(in) :: Tl !< Left-column interface potential temperature [C ~> degC] + real, dimension(nk+1), intent(in) :: Sl !< Left-column interface salinity [S ~> ppt] + real, dimension(nk+1), intent(in) :: dRdTl !< Left-column dRho/dT [R C-1 ~> kg m-3 degC-1] + real, dimension(nk+1), intent(in) :: dRdSl !< Left-column dRho/dS [R S-1 ~> kg m-3 ppt-1] real, dimension(nk+1), intent(in) :: Pr !< Right-column interface pressure [R L2 T-2 ~> Pa] or other units - real, dimension(nk+1), intent(in) :: Tr !< Right-column interface potential temperature [degC] - real, dimension(nk+1), intent(in) :: Sr !< Right-column interface salinity [ppt] - real, dimension(nk+1), intent(in) :: dRdTr !< Left-column dRho/dT [R degC-1 ~> kg m-3 degC-1] - real, dimension(nk+1), intent(in) :: dRdSr !< Left-column dRho/dS [R ppt-1 ~> kg m-3 ppt-1] + real, dimension(nk+1), intent(in) :: Tr !< Right-column interface potential temperature [C ~> degC] + real, dimension(nk+1), intent(in) :: Sr !< Right-column interface salinity [S ~> ppt] + real, dimension(nk+1), intent(in) :: dRdTr !< Left-column dRho/dT [R C-1 ~> kg m-3 degC-1] + real, dimension(nk+1), intent(in) :: dRdSr !< Left-column dRho/dS [R S-1 ~> kg m-3 ppt-1] real, dimension(2*nk+2), intent(inout) :: PoL !< Fractional position of neutral surface within !! layer KoL of left column [nondim] real, dimension(2*nk+2), intent(inout) :: PoR !< Fractional position of neutral surface within @@ -978,8 +1390,8 @@ subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdS !! [R L2 T-2 ~> Pa] or other units following Pl and Pr. integer, optional, intent(in) :: bl_kl !< Layer index of the boundary layer (left) integer, optional, intent(in) :: bl_kr !< Layer index of the boundary layer (right) - real, optional, intent(in) :: bl_zl !< Nondimensional position of the boundary layer (left) - real, optional, intent(in) :: bl_zr !< Nondimensional position of the boundary layer (right) + real, optional, intent(in) :: bl_zl !< Fractional position of the boundary layer (left) [nondim] + real, optional, intent(in) :: bl_zr !< Fractional position of the boundary layer (right) [nondim] ! Local variables integer :: ns ! Number of neutral surfaces @@ -999,8 +1411,8 @@ subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdS ns = 2*nk+2 ! Initialize variables for the search - kr = 1 ; - kl = 1 ; + kr = 1 + kl = 1 lastP_right = 0. lastP_left = 0. lastK_right = 1 @@ -1163,7 +1575,7 @@ subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdS end subroutine find_neutral_surface_positions_continuous !> Returns the non-dimensional position between Pneg and Ppos where the -!! interpolated density difference equals zero. +!! interpolated density difference equals zero [nondim]. !! The result is always bounded to be between 0 and 1. real function interpolate_for_nondim_position(dRhoNeg, Pneg, dRhoPos, Ppos) real, intent(in) :: dRhoNeg !< Negative density difference [R ~> kg m-3] @@ -1173,38 +1585,43 @@ real function interpolate_for_nondim_position(dRhoNeg, Pneg, dRhoPos, Ppos) character(len=120) :: mesg - if (Ppos < Pneg) then - call MOM_error(FATAL, 'interpolate_for_nondim_position: Houston, we have a problem! PposdRhoPos) then - write(stderr,*) 'dRhoNeg, Pneg, dRhoPos, Ppos=',dRhoNeg, Pneg, dRhoPos, Ppos - write(mesg,*) 'dRhoNeg, Pneg, dRhoPos, Ppos=', dRhoNeg, Pneg, dRhoPos, Ppos - call MOM_error(WARNING, 'interpolate_for_nondim_position: '//trim(mesg)) - elseif (dRhoNeg>dRhoPos) then !### Does this duplicated test belong here? - call MOM_error(FATAL, 'interpolate_for_nondim_position: Houston, we have a problem! dRhoNeg>dRhoPos') - endif - if (Ppos<=Pneg) then ! Handle vanished or inverted layers - interpolate_for_nondim_position = 0.5 - elseif ( dRhoPos - dRhoNeg > 0. ) then - interpolate_for_nondim_position = min( 1., max( 0., -dRhoNeg / ( dRhoPos - dRhoNeg ) ) ) - elseif ( dRhoPos - dRhoNeg == 0) then - if (dRhoNeg>0.) then - interpolate_for_nondim_position = 0. - elseif (dRhoNeg<0.) then - interpolate_for_nondim_position = 1. - else ! dRhoPos = dRhoNeg = 0 + if ((Ppos > Pneg) .and. (dRhoPos - dRhoNeg >= 0. )) then + if ( dRhoPos - dRhoNeg > 0. ) then + interpolate_for_nondim_position = min( 1., max( 0., -dRhoNeg / ( dRhoPos - dRhoNeg ) ) ) + elseif (dRhoPos - dRhoNeg == 0) then + if (dRhoNeg > 0.) then + interpolate_for_nondim_position = 0. + elseif (dRhoNeg < 0.) then + interpolate_for_nondim_position = 1. + else ! dRhoPos = dRhoNeg = 0 + interpolate_for_nondim_position = 0.5 + endif + else ! dRhoPos - dRhoNeg < 0 interpolate_for_nondim_position = 0.5 endif - else ! dRhoPos - dRhoNeg < 0 + elseif (Ppos == Pneg) then ! Handle vanished or inverted layers interpolate_for_nondim_position = 0.5 + else ! ((Ppos < Pneg) .or. (dRhoNeg > dRhoPos) ) + ! Error handling for problematic cases. It is expected that this should never occur. + write(mesg,*) 'dRhoNeg, Pneg, dRhoPos, Ppos', dRhoNeg, Pneg, dRhoPos, Ppos + call MOM_error(WARNING, 'interpolate_for_nondim_position: '//trim(mesg)) + ! write(stderr,*) trim(mesg) + if ((Ppos < Pneg) .and. (dRhoNeg > dRhoPos)) then + mesg = '(Ppos < Pneg) and (dRhoNeg > dRhoPos)' + elseif (Ppos < Pneg) then + mesg = 'Ppos < Pneg' + elseif (dRhoNeg > dRhoPos) then + mesg = trim(mesg)//'; dRhoNeg > dRhoPos' + else ! This should never happen. + mesg = 'Unexpected failure.' + endif + call MOM_error(FATAL, 'interpolate_for_nondim_position: '//trim(mesg)) endif - if ( interpolate_for_nondim_position < 0. ) & - call MOM_error(FATAL, 'interpolate_for_nondim_position: Houston, we have a problem! Pint < Pneg') - if ( interpolate_for_nondim_position > 1. ) & - call MOM_error(FATAL, 'interpolate_for_nondim_position: Houston, we have a problem! Pint > Ppos') + end function interpolate_for_nondim_position !> Higher order version of find_neutral_surface_positions. Returns positions within left/right columns -!! of combined interfaces using intracell reconstructions of T/S. Note that the polynomial reconstrcutions +!! of combined interfaces using intracell reconstructions of T/S. Note that the polynomial reconstructions !! of T and S are optional to aid with unit testing, but will always be passed otherwise subroutine find_neutral_surface_positions_discontinuous(CS, nk, & Pres_l, hcol_l, Tl, Sl, ppoly_T_l, ppoly_S_l, stable_l, & @@ -1216,18 +1633,21 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, & real, dimension(nk,2), intent(in) :: Pres_l !< Left-column interface pressure [R L2 T-2 ~> Pa] real, dimension(nk), intent(in) :: hcol_l !< Left-column layer thicknesses [H ~> m or kg m-2] !! or other units - real, dimension(nk,2), intent(in) :: Tl !< Left-column top interface potential temperature [degC] - real, dimension(nk,2), intent(in) :: Sl !< Left-column top interface salinity [ppt] - real, dimension(:,:), intent(in) :: ppoly_T_l !< Left-column coefficients of T reconstruction [degC] - real, dimension(:,:), intent(in) :: ppoly_S_l !< Left-column coefficients of S reconstruction [ppt] + real, dimension(nk,2), intent(in) :: Tl !< Left-column top interface potential + !! temperature [C ~> degC] + real, dimension(nk,2), intent(in) :: Sl !< Left-column top interface salinity [S ~> ppt] + real, dimension(:,:), intent(in) :: ppoly_T_l !< Left-column coefficients of T reconstruction [C ~> degC] + real, dimension(:,:), intent(in) :: ppoly_S_l !< Left-column coefficients of S reconstruction [S ~> ppt] logical, dimension(nk), intent(in) :: stable_l !< True where the left-column is stable real, dimension(nk,2), intent(in) :: Pres_r !< Right-column interface pressure [R L2 T-2 ~> Pa] real, dimension(nk), intent(in) :: hcol_r !< Left-column layer thicknesses [H ~> m or kg m-2] !! or other units - real, dimension(nk,2), intent(in) :: Tr !< Right-column top interface potential temperature [degC] - real, dimension(nk,2), intent(in) :: Sr !< Right-column top interface salinity [ppt] - real, dimension(:,:), intent(in) :: ppoly_T_r !< Right-column coefficients of T reconstruction [degC] - real, dimension(:,:), intent(in) :: ppoly_S_r !< Right-column coefficients of S reconstruction [ppt] + real, dimension(nk,2), intent(in) :: Tr !< Right-column top interface potential + !! temperature [C ~> degC] + real, dimension(nk,2), intent(in) :: Sr !< Right-column top interface salinity [S ~> ppt] + real, dimension(:,:), intent(in) :: ppoly_T_r !< Right-column coefficients of T + !! reconstruction [C ~> degC] + real, dimension(:,:), intent(in) :: ppoly_S_r !< Right-column coefficients of S reconstruction [S ~> ppt] logical, dimension(nk), intent(in) :: stable_r !< True where the right-column is stable real, dimension(4*nk), intent(inout) :: PoL !< Fractional position of neutral surface within !! layer KoL of left column [nondim] @@ -1238,9 +1658,9 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, & real, dimension(4*nk-1), intent(inout) :: hEff !< Effective thickness between two neutral surfaces !! [H ~> m or kg m-2] or other units taken from hcol_l real, optional, intent(in) :: zeta_bot_L!< Non-dimensional distance to where the boundary layer - !! intersetcs the cell (left) [nondim] + !! intersects the cell (left) [nondim] real, optional, intent(in) :: zeta_bot_R!< Non-dimensional distance to where the boundary layer - !! intersetcs the cell (right) [nondim] + !! intersects the cell (right) [nondim] integer, optional, intent(in) :: k_bot_L !< k-index for the boundary layer (left) [nondim] integer, optional, intent(in) :: k_bot_R !< k-index for the boundary layer (right) [nondim] @@ -1254,7 +1674,6 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, & logical :: searching_left_column ! True if searching for the position of a right interface in the left column logical :: searching_right_column ! True if searching for the position of a left interface in the right column logical :: reached_bottom ! True if one of the bottom-most interfaces has been used as the target - logical :: search_layer logical :: fail_heff ! Fail if negative thickness are encountered. By default this ! is true, but it can take its value from hard_fail_heff. real :: dRho ! A density difference between columns [R ~> kg m-3] @@ -1278,10 +1697,10 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, & if (PRESENT(hard_fail_heff)) fail_heff = hard_fail_heff if (PRESENT(k_bot_L) .and. PRESENT(k_bot_R) .and. PRESENT(zeta_bot_L) .and. PRESENT(zeta_bot_R)) then - k_init_L = k_bot_L; k_init_R = k_bot_R - p_init_L = zeta_bot_L; p_init_R = zeta_bot_R - lastP_left = zeta_bot_L; lastP_right = zeta_bot_R - kl_left = k_bot_L; kl_right = k_bot_R + k_init_L = k_bot_L ; k_init_R = k_bot_R + p_init_L = zeta_bot_L ; p_init_R = zeta_bot_R + lastP_left = zeta_bot_L ; lastP_right = zeta_bot_R + kl_left = k_bot_L ; kl_right = k_bot_R else k_init_L = 1 ; k_init_R = 1 p_init_L = 0. ; p_init_R = 0. @@ -1333,7 +1752,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, & Tr(kl_right, ki_right), Sr(kl_right, ki_right), Pres_r(kl_right,ki_right), & Tl(kl_left, ki_left), Sl(kl_left, ki_left) , Pres_l(kl_left,ki_left), & dRho) - if (CS%debug) write(stdout,'(A,I2,A,E12.4,A,I2,A,I2,A,I2,A,I2)') & + if (CS%debug) write(stdout,'(A,I0,A,E12.4,A,I0,A,I0,A,I0,A,I0)') & "k_surface=",k_surface, " dRho=",CS%R_to_kg_m3*dRho, & "kl_left=",kl_left, " ki_left=",ki_left, " kl_right=",kl_right, " ki_right=",ki_right ! Which column has the lighter surface for the current indexes, kr and kl @@ -1366,8 +1785,8 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, & KoL(k_surface) = kl_left if (CS%debug) then - write(stdout,'(A,I2)') "Searching left layer ", kl_left - write(stdout,'(A,I2,X,I2)') "Searching from right: ", kl_right, ki_right + write(stdout,'(A,I0)') "Searching left layer ", kl_left + write(stdout,'(A,I0,1X,I0)') "Searching from right: ", kl_right, ki_right write(stdout,*) "Temp/Salt Reference: ", Tr(kl_right,ki_right), Sr(kl_right,ki_right) write(stdout,*) "Temp/Salt Top L: ", Tl(kl_left,1), Sl(kl_left,1) write(stdout,*) "Temp/Salt Bot L: ", Tl(kl_left,2), Sl(kl_left,2) @@ -1389,8 +1808,8 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, & KoR(k_surface) = kl_right if (CS%debug) then - write(stdout,'(A,I2)') "Searching right layer ", kl_right - write(stdout,'(A,I2,X,I2)') "Searching from left: ", kl_left, ki_left + write(stdout,'(A,I0)') "Searching right layer ", kl_right + write(stdout,'(A,I0,1X,I0)') "Searching from left: ", kl_left, ki_left write(stdout,*) "Temp/Salt Reference: ", Tl(kl_left,ki_left), Sl(kl_left,ki_left) write(stdout,*) "Temp/Salt Top L: ", Tr(kl_right,1), Sr(kl_right,1) write(stdout,*) "Temp/Salt Bot L: ", Tr(kl_right,2), Sr(kl_right,2) @@ -1402,7 +1821,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, & else stop 'Else what?' endif - if (CS%debug) write(stdout,'(A,I3,A,ES16.6,A,I2,A,ES16.6)') "KoL:", KoL(k_surface), " PoL:", PoL(k_surface), & + if (CS%debug) write(stdout,'(A,I3,A,ES16.6,A,I0,A,ES16.6)') "KoL:", KoL(k_surface), " PoL:", PoL(k_surface), & " KoR:", KoR(k_surface), " PoR:", PoR(k_surface) endif ! Effective thickness @@ -1444,12 +1863,12 @@ end subroutine find_neutral_surface_positions_discontinuous subroutine mark_unstable_cells(CS, nk, T, S, P, stable_cell) type(neutral_diffusion_CS), intent(inout) :: CS !< Neutral diffusion control structure integer, intent(in) :: nk !< Number of levels in a column - real, dimension(nk,2), intent(in) :: T !< Temperature at interfaces [degC] - real, dimension(nk,2), intent(in) :: S !< Salinity at interfaces [ppt] + real, dimension(nk,2), intent(in) :: T !< Temperature at interfaces [C ~> degC] + real, dimension(nk,2), intent(in) :: S !< Salinity at interfaces [S ~> ppt] real, dimension(nk,2), intent(in) :: P !< Pressure at interfaces [R L2 T-2 ~> Pa] logical, dimension(nk), intent( out) :: stable_cell !< True if this cell is unstably stratified - integer :: k, first_stable, prev_stable + integer :: k real :: delta_rho ! A density difference [R ~> kg m-3] do k = 1,nk @@ -1459,32 +1878,35 @@ subroutine mark_unstable_cells(CS, nk, T, S, P, stable_cell) enddo end subroutine mark_unstable_cells -!> Searches the "other" (searched) column for the position of the neutral surface +!> Searches the "other" (searched) column for the position of the neutral surface, returning +!! the fractional postion within the layer [nondim] real function search_other_column(CS, ksurf, pos_last, T_from, S_from, P_from, T_top, S_top, P_top, & T_bot, S_bot, P_bot, T_poly, S_poly ) result(pos) type(neutral_diffusion_CS), intent(in ) :: CS !< Neutral diffusion control structure integer, intent(in ) :: ksurf !< Current index of neutral surface real, intent(in ) :: pos_last !< Last position within the current layer, used as the lower !! bound in the root finding algorithm [nondim] - real, intent(in ) :: T_from !< Temperature at the searched from interface [degC] - real, intent(in ) :: S_from !< Salinity at the searched from interface [ppt] + real, intent(in ) :: T_from !< Temperature at the searched from interface [C ~> degC] + real, intent(in ) :: S_from !< Salinity at the searched from interface [S ~> ppt] real, intent(in ) :: P_from !< Pressure at the searched from interface [R L2 T-2 ~> Pa] - real, intent(in ) :: T_top !< Temperature at the searched to top interface [degC] - real, intent(in ) :: S_top !< Salinity at the searched to top interface [ppt] + real, intent(in ) :: T_top !< Temperature at the searched to top interface [C ~> degC] + real, intent(in ) :: S_top !< Salinity at the searched to top interface [S ~> ppt] real, intent(in ) :: P_top !< Pressure at the searched to top interface [R L2 T-2 ~> Pa] !! interface [R L2 T-2 ~> Pa] - real, intent(in ) :: T_bot !< Temperature at the searched to bottom interface [degC] - real, intent(in ) :: S_bot !< Salinity at the searched to bottom interface [ppt] + real, intent(in ) :: T_bot !< Temperature at the searched to bottom interface [C ~> degC] + real, intent(in ) :: S_bot !< Salinity at the searched to bottom interface [S ~> ppt] real, intent(in ) :: P_bot !< Pressure at the searched to bottom !! interface [R L2 T-2 ~> Pa] - real, dimension(:), intent(in ) :: T_poly !< Temperature polynomial reconstruction coefficients [degC] - real, dimension(:), intent(in ) :: S_poly !< Salinity polynomial reconstruction coefficients [ppt] + real, dimension(:), intent(in ) :: T_poly !< Temperature polynomial reconstruction + !! coefficients [C ~> degC] + real, dimension(:), intent(in ) :: S_poly !< Salinity polynomial reconstruction + !! coefficients [S ~> ppt] ! Local variables real :: dRhotop, dRhobot ! Density differences [R ~> kg m-3] - real :: dRdT_top, dRdT_bot, dRdT_from ! Partial derivatives of density with temperature [R degC-1 ~> kg m-3 degC-1] - real :: dRdS_top, dRdS_bot, dRdS_from ! Partial derivatives of density with salinity [R ppt-1 ~> kg m-3 ppt-1] + real :: dRdT_top, dRdT_bot, dRdT_from ! Partial derivatives of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: dRdS_top, dRdS_bot, dRdS_from ! Partial derivatives of density with salinity [R S-1 ~> kg m-3 ppt-1] - ! Calculate the differencei in density at the tops or the bottom + ! Calculate the difference in density at the tops or the bottom if (CS%neutral_pos_method == 1 .or. CS%neutral_pos_method == 3) then call calc_delta_rho_and_derivs(CS, T_top, S_top, P_top, T_from, S_from, P_from, dRhoTop) call calc_delta_rho_and_derivs(CS, T_bot, S_bot, P_bot, T_from, S_from, P_from, dRhoBot) @@ -1517,7 +1939,7 @@ real function search_other_column(CS, ksurf, pos_last, T_from, S_from, P_from, T if (CS%neutral_pos_method==1) then pos = interpolate_for_nondim_position( dRhoTop, P_top, dRhoBot, P_bot ) - ! For the 'Linear' case of finding the neutral position, the fromerence pressure to use is the average + ! For the 'Linear' case of finding the neutral position, the reference pressure to use is the average ! of the midpoint of the layer being searched and the interface being searched from elseif (CS%neutral_pos_method == 2) then pos = find_neutral_pos_linear( CS, pos_last, T_from, S_from, dRdT_from, dRdS_from, & @@ -1536,7 +1958,6 @@ subroutine increment_interface(nk, kl, ki, reached_bottom, searching_this_column logical, intent(inout) :: reached_bottom !< Updated when kl == nk and ki == 2 logical, intent(inout) :: searching_this_column !< Updated when kl == nk and ki == 2 logical, intent(inout) :: searching_other_column !< Updated when kl == nk and ki == 2 - integer :: k reached_bottom = .false. if (ki == 2) then ! At the bottom interface @@ -1568,38 +1989,37 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, & type(neutral_diffusion_CS),intent(in) :: CS !< Control structure with parameters for this module real, intent(in) :: z0 !< Lower bound of position, also serves as the !! initial guess [nondim] - real, intent(in) :: T_ref !< Temperature at the searched from interface [degC] - real, intent(in) :: S_ref !< Salinity at the searched from interface [ppt] + real, intent(in) :: T_ref !< Temperature at the searched from interface [C ~> degC] + real, intent(in) :: S_ref !< Salinity at the searched from interface [S ~> ppt] real, intent(in) :: dRdT_ref !< dRho/dT at the searched from interface - !! [R degC-1 ~> kg m-3 degC-1] + !! [R C-1 ~> kg m-3 degC-1] real, intent(in) :: dRdS_ref !< dRho/dS at the searched from interface - !! [R ppt-1 ~> kg m-3 ppt-1] + !! [R S-1 ~> kg m-3 ppt-1] real, intent(in) :: dRdT_top !< dRho/dT at top of layer being searched - !! [R degC-1 ~> kg m-3 degC-1] + !! [R C-1 ~> kg m-3 degC-1] real, intent(in) :: dRdS_top !< dRho/dS at top of layer being searched - !! [R ppt-1 ~> kg m-3 ppt-1] + !! [R S-1 ~> kg m-3 ppt-1] real, intent(in) :: dRdT_bot !< dRho/dT at bottom of layer being searched - !! [R degC-1 ~> kg m-3 degC-1] + !! [R C-1 ~> kg m-3 degC-1] real, intent(in) :: dRdS_bot !< dRho/dS at bottom of layer being searched - !! [R ppt-1 ~> kg m-3 ppt-1] + !! [R S-1 ~> kg m-3 ppt-1] real, dimension(:), intent(in) :: ppoly_T !< Coefficients of the polynomial reconstruction of T within - !! the layer to be searched [degC]. + !! the layer to be searched [C ~> degC]. real, dimension(:), intent(in) :: ppoly_S !< Coefficients of the polynomial reconstruction of S within - !! the layer to be searched [ppt]. + !! the layer to be searched [S ~> ppt]. real :: z !< Position where drho = 0 [nondim] ! Local variables real :: dRdT_diff ! Difference in the partial derivative of density with temperature across the - ! layer [R degC-1 ~> kg m-3 degC-1] + ! layer [R C-1 ~> kg m-3 degC-1] real :: dRdS_diff ! Difference in the partial derivative of density with salinity across the - ! layer [R ppt-1 ~> kg m-3 ppt-1] - real :: drho, drho_dz ! Density anomaly and its derivative with fracitonal position [R ~> kg m-3] - real :: dRdT_z ! Partial derivative of density with temperature at a point [R degC-1 ~> kg m-3 degC-1] - real :: dRdS_z ! Partial derivative of density with salinity at a point [R ppt-1 ~> kg m-3 ppt-1] - real :: T_z, dT_dz ! Temperature at a point and its derivative with fractional position [degC] - real :: S_z, dS_dz ! Salinity at a point and its derivative with fractional position [ppt] + ! layer [R S-1 ~> kg m-3 ppt-1] + real :: drho, drho_dz ! Density anomaly and its derivative with fractional position [R ~> kg m-3] + real :: dRdT_z ! Partial derivative of density with temperature at a point [R C-1 ~> kg m-3 degC-1] + real :: dRdS_z ! Partial derivative of density with salinity at a point [R S-1 ~> kg m-3 ppt-1] + real :: T_z, dT_dz ! Temperature at a point and its derivative with fractional position [C ~> degC] + real :: S_z, dS_dz ! Salinity at a point and its derivative with fractional position [S ~> ppt] real :: drho_min, drho_max ! Bounds on density differences [R ~> kg m-3] real :: ztest, zmin, zmax ! Fractional positions in the cell [nondim] - real :: dz ! Change in position in the cell [nondim] real :: a1, a2 ! Fractional weights of the top and bottom values [nondim] integer :: iter integer :: nterm @@ -1688,15 +2108,15 @@ function find_neutral_pos_full( CS, z0, T_ref, S_ref, P_ref, P_top, P_bot, ppoly type(neutral_diffusion_CS),intent(in) :: CS !< Control structure with parameters for this module real, intent(in) :: z0 !< Lower bound of position, also serves as the !! initial guess [nondim] - real, intent(in) :: T_ref !< Temperature at the searched from interface [degC] - real, intent(in) :: S_ref !< Salinity at the searched from interface [ppt] + real, intent(in) :: T_ref !< Temperature at the searched from interface [C ~> degC] + real, intent(in) :: S_ref !< Salinity at the searched from interface [S ~> ppt] real, intent(in) :: P_ref !< Pressure at the searched from interface [R L2 T-2 ~> Pa] real, intent(in) :: P_top !< Pressure at top of layer being searched [R L2 T-2 ~> Pa] real, intent(in) :: P_bot !< Pressure at bottom of layer being searched [R L2 T-2 ~> Pa] real, dimension(:), intent(in) :: ppoly_T !< Coefficients of the polynomial reconstruction of T within - !! the layer to be searched [degC] + !! the layer to be searched [C ~> degC] real, dimension(:), intent(in) :: ppoly_S !< Coefficients of the polynomial reconstruction of T within - !! the layer to be searched [ppt] + !! the layer to be searched [S ~> ppt] real :: z !< Position where drho = 0 [nondim] ! Local variables integer :: iter @@ -1704,8 +2124,8 @@ function find_neutral_pos_full( CS, z0, T_ref, S_ref, P_ref, P_top, P_bot, ppoly real :: drho_a, drho_b, drho_c ! Density differences [R ~> kg m-3] real :: a, b, c ! Fractional positions [nondim] - real :: Ta, Tb, Tc ! Temperatures [degC] - real :: Sa, Sb, Sc ! Salinities [ppt] + real :: Ta, Tb, Tc ! Temperatures [C ~> degC] + real :: Sa, Sb, Sc ! Salinities [S ~> ppt] real :: Pa, Pb, Pc ! Pressures [R L2 T-2 ~> Pa] integer :: side @@ -1755,7 +2175,7 @@ function find_neutral_pos_full( CS, z0, T_ref, S_ref, P_ref, P_top, P_bot, ppoly z = a return endif - c = a ; drho_c = drho_a; + c = a ; drho_c = drho_a if (side == -1) drho_b = 0.5*drho_b side = -1 elseif ( drho_b*drho_a > 0 ) then @@ -1780,23 +2200,22 @@ end function find_neutral_pos_full subroutine calc_delta_rho_and_derivs(CS, T1, S1, p1_in, T2, S2, p2_in, drho, & drdt1_out, drds1_out, drdt2_out, drds2_out ) type(neutral_diffusion_CS) :: CS !< Neutral diffusion control structure - real, intent(in ) :: T1 !< Temperature at point 1 [degC] - real, intent(in ) :: S1 !< Salinity at point 1 [ppt] + real, intent(in ) :: T1 !< Temperature at point 1 [C ~> degC] + real, intent(in ) :: S1 !< Salinity at point 1 [S ~> ppt] real, intent(in ) :: p1_in !< Pressure at point 1 [R L2 T-2 ~> Pa] - real, intent(in ) :: T2 !< Temperature at point 2 [degC] - real, intent(in ) :: S2 !< Salinity at point 2 [ppt] + real, intent(in ) :: T2 !< Temperature at point 2 [C ~> degC] + real, intent(in ) :: S2 !< Salinity at point 2 [S ~> ppt] real, intent(in ) :: p2_in !< Pressure at point 2 [R L2 T-2 ~> Pa] real, intent( out) :: drho !< Difference in density between the two points [R ~> kg m-3] - real, optional, intent( out) :: dRdT1_out !< drho_dt at point 1 [R degC-1 ~> kg m-3 degC-1] - real, optional, intent( out) :: dRdS1_out !< drho_ds at point 1 [R ppt-1 ~> kg m-3 ppt-1] - real, optional, intent( out) :: dRdT2_out !< drho_dt at point 2 [R degC-1 ~> kg m-3 degC-1] - real, optional, intent( out) :: dRdS2_out !< drho_ds at point 2 [R ppt-1 ~> kg m-3 ppt-1] + real, optional, intent( out) :: dRdT1_out !< drho_dt at point 1 [R C-1 ~> kg m-3 degC-1] + real, optional, intent( out) :: dRdS1_out !< drho_ds at point 1 [R S-1 ~> kg m-3 ppt-1] + real, optional, intent( out) :: dRdT2_out !< drho_dt at point 2 [R C-1 ~> kg m-3 degC-1] + real, optional, intent( out) :: dRdS2_out !< drho_ds at point 2 [R S-1 ~> kg m-3 ppt-1] ! Local variables real :: rho1, rho2 ! Densities [R ~> kg m-3] real :: p1, p2, pmid ! Pressures [R L2 T-2 ~> Pa] - real :: drdt1, drdt2 ! Partial derivatives of density with temperature [R degC-1 ~> kg m-3 degC-1] - real :: drds1, drds2 ! Partial derivatives of density with salinity [R ppt-1 ~> kg m-3 ppt-1] - real :: drdp1, drdp2 ! Partial derivatives of density with pressure [T2 L-2 ~> s2 m-2] + real :: drdt1, drdt2 ! Partial derivatives of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: drds1, drds2 ! Partial derivatives of density with salinity [R S-1 ~> kg m-3 ppt-1] ! Use the same reference pressure or the in-situ pressure if (CS%ref_pres > 0.) then @@ -1810,10 +2229,10 @@ subroutine calc_delta_rho_and_derivs(CS, T1, S1, p1_in, T2, S2, p2_in, drho, & ! Use the full linear equation of state to calculate the difference in density (expensive!) if (TRIM(CS%delta_rho_form) == 'full') then pmid = 0.5 * (p1 + p2) - call calculate_density( T1, S1, pmid, rho1, CS%EOS) - call calculate_density( T2, S2, pmid, rho2, CS%EOS) + call calculate_density(T1, S1, pmid, rho1, CS%EOS) + call calculate_density(T2, S2, pmid, rho2, CS%EOS) drho = rho1 - rho2 - ! Use the density derivatives at the average of pressures and the differentces int temperature + ! Use the density derivatives at the average of pressures and the differences in temperature elseif (TRIM(CS%delta_rho_form) == 'mid_pressure') then pmid = 0.5 * (p1 + p2) if (CS%ref_pres>=0) pmid = CS%ref_pres @@ -1841,16 +2260,16 @@ end subroutine calc_delta_rho_and_derivs !! (\gamma^{-1}_1 + \gamma^{-1}_2)*(P_1-P_2) \right] \f$ function delta_rho_from_derivs( T1, S1, P1, dRdT1, dRdS1, & T2, S2, P2, dRdT2, dRdS2 ) result (drho) - real :: T1 !< Temperature at point 1 [degC] - real :: S1 !< Salinity at point 1 [ppt] + real :: T1 !< Temperature at point 1 [C ~> degC] + real :: S1 !< Salinity at point 1 [S ~> ppt] real :: P1 !< Pressure at point 1 [R L2 T-2 ~> Pa] - real :: dRdT1 !< The partial derivative of density with temperature at point 1 [R degC-1 ~> kg m-3 degC-1] - real :: dRdS1 !< The partial derivative of density with salinity at point 1 [R ppt-1 ~> kg m-3 ppt-1] - real :: T2 !< Temperature at point 2 [degC] - real :: S2 !< Salinity at point 2 [ppt] + real :: dRdT1 !< The partial derivative of density with temperature at point 1 [R C-1 ~> kg m-3 degC-1] + real :: dRdS1 !< The partial derivative of density with salinity at point 1 [R S-1 ~> kg m-3 ppt-1] + real :: T2 !< Temperature at point 2 [C ~> degC] + real :: S2 !< Salinity at point 2 [S ~> ppt] real :: P2 !< Pressure at point 2 [R L2 T-2 ~> Pa] - real :: dRdT2 !< The partial derivative of density with temperature at point 2 [R degC-1 ~> kg m-3 degC-1] - real :: dRdS2 !< The partial derivative of density with salinity at point 2 [R ppt-1 ~> kg m-3 ppt-1] + real :: dRdT2 !< The partial derivative of density with temperature at point 2 [R C-1 ~> kg m-3 degC-1] + real :: dRdS2 !< The partial derivative of density with salinity at point 2 [R S-1 ~> kg m-3 ppt-1] ! Local variables real :: drho ! The density difference [R ~> kg m-3] @@ -1883,13 +2302,13 @@ function absolute_positions(n,ns,Pint,Karr,NParr) integer, intent(in) :: ns !< Number of neutral surfaces real, intent(in) :: Pint(n+1) !< Position of interface [R L2 T-2 ~> Pa] or other units integer, intent(in) :: Karr(ns) !< Indexes of interfaces about positions - real, intent(in) :: NParr(ns) !< Non-dimensional positions within layers Karr(:) + real, intent(in) :: NParr(ns) !< Non-dimensional positions within layers Karr(:) [nondim] real, dimension(ns) :: absolute_positions !< Absolute positions [R L2 T-2 ~> Pa] !! or other units following Pint ! Local variables - integer :: k_surface, k + integer :: k_surface do k_surface = 1, ns absolute_positions(k_surface) = absolute_position(n,ns,Pint,Karr,NParr,k_surface) @@ -1899,50 +2318,96 @@ end function absolute_positions !> Returns a single column of neutral diffusion fluxes of a tracer. subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, KoR, & - hEff, Flx, continuous, h_neglect, remap_CS, h_neglect_edge) + hEff, Flx, continuous, h_neglect, remap_CS, h_neglect_edge, & + coeff_l, coeff_r) integer, intent(in) :: nk !< Number of levels integer, intent(in) :: nsurf !< Number of neutral surfaces integer, intent(in) :: deg !< Degree of polynomial reconstructions real, dimension(nk), intent(in) :: hl !< Left-column layer thickness [H ~> m or kg m-2] real, dimension(nk), intent(in) :: hr !< Right-column layer thickness [H ~> m or kg m-2] - real, dimension(nk), intent(in) :: Tl !< Left-column layer tracer (conc, e.g. degC) - real, dimension(nk), intent(in) :: Tr !< Right-column layer tracer (conc, e.g. degC) + real, dimension(nk), intent(in) :: Tl !< Left-column layer tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk), intent(in) :: Tr !< Right-column layer tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) real, dimension(nsurf), intent(in) :: PiL !< Fractional position of neutral surface - !! within layer KoL of left column + !! within layer KoL of left column [nondim] real, dimension(nsurf), intent(in) :: PiR !< Fractional position of neutral surface - !! within layer KoR of right column + !! within layer KoR of right column [nondim] integer, dimension(nsurf), intent(in) :: KoL !< Index of first left interface above neutral surface integer, dimension(nsurf), intent(in) :: KoR !< Index of first right interface above neutral surface real, dimension(nsurf-1), intent(in) :: hEff !< Effective thickness between two neutral !! surfaces [H ~> m or kg m-2] - real, dimension(nsurf-1), intent(inout) :: Flx !< Flux of tracer between pairs of neutral layers (conc H) + real, dimension(nsurf-1), intent(inout) :: Flx !< Flux of tracer between pairs of neutral layers + !! in units (conc H or conc H L2) that depend on + !! the presence and units of coeff_l and coeff_r. + !! If the tracer is temperature, this could have + !! units of [C H ~> degC m or degC kg m-2] or + !! [C H L2 ~> degC m3 or degC kg] if coeff_l has + !! units of [L2 ~> m2] logical, intent(in) :: continuous !< True if using continuous reconstruction - real, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions [H ~> m or kg m-2] + real, intent(in) :: h_neglect !< A negligibly small width for the purpose + !! of cell reconstructions [H ~> m or kg m-2] type(remapping_CS), optional, intent(in) :: remap_CS !< Remapping control structure used - !! to create sublayers - real, optional, intent(in) :: h_neglect_edge !< A negligibly small width used for - !! edge value calculations if continuous is false [H ~> m or kg m-2] + !! to create sublayers + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width used for edge value + !! calculations if continuous is false [H ~> m or kg m-2] + real, dimension(nk+1), optional, intent(in) :: coeff_l !< Left-column diffusivity [L2 ~> m2] or [nondim] + real, dimension(nk+1), optional, intent(in) :: coeff_r !< Right-column diffusivity [L2 ~> m2] or [nondim] + ! Local variables - integer :: k_sublayer, klb, klt, krb, krt, k - real :: T_right_top, T_right_bottom, T_right_layer, T_right_sub, T_right_top_int, T_right_bot_int - real :: T_left_top, T_left_bottom, T_left_layer, T_left_sub, T_left_top_int, T_left_bot_int - real :: dT_top, dT_bottom, dT_layer, dT_ave, dT_sublayer, dT_top_int, dT_bot_int - real, dimension(nk+1) :: Til !< Left-column interface tracer (conc, e.g. degC) - real, dimension(nk+1) :: Tir !< Right-column interface tracer (conc, e.g. degC) - real, dimension(nk) :: aL_l !< Left-column left edge value of tracer (conc, e.g. degC) - real, dimension(nk) :: aR_l !< Left-column right edge value of tracer (conc, e.g. degC) - real, dimension(nk) :: aL_r !< Right-column left edge value of tracer (conc, e.g. degC) - real, dimension(nk) :: aR_r !< Right-column right edge value of tracer (conc, e.g. degC) + integer :: k_sublayer, klb, klt, krb, krt + real :: T_right_sub, T_left_sub ! Tracer concentrations averaged over sub-intervals in the right and left + ! columns in arbitrary concentration units (e.g. [C ~> degC] for temperature). + real :: T_right_layer, T_left_layer ! Tracer concentrations averaged over layers in the right and left + ! columns in arbitrary concentration units (e.g. [C ~> degC] for temperature). + real :: T_right_top, T_right_bottom, T_right_top_int, T_right_bot_int ! Tracer concentrations + ! at various positions in the right column in arbitrary + ! concentration units (e.g. [C ~> degC] for temperature). + real :: T_left_top, T_left_bottom, T_left_top_int, T_left_bot_int ! Tracer concentrations + ! at various positions in the left column in arbitrary + ! concentration units (e.g. [C ~> degC] for temperature). + real :: dT_layer, dT_ave, dT_sublayer ! Differences in vertically averaged tracer concentrations + ! over various portions of the right and left columns in arbitrary + ! concentration units (e.g. [C ~> degC] for temperature). + real :: dT_top, dT_bottom, dT_top_int, dT_bot_int ! Differences in tracer concentrations + ! at various positions between the right and left columns in arbitrary + ! concentration units (e.g. [C ~> degC] for temperature). + real :: khtr_ave ! An averaged diffusivity in normalized units [nondim] if coeff_l and coeff_r are + ! absent or in units copied from coeff_l and coeff_r [L2 ~> m2] or [nondim] + real, dimension(nk+1) :: Til !< Left-column interface tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk+1) :: Tir !< Right-column interface tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk) :: aL_l !< Left-column left edge value of tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk) :: aR_l !< Left-column right edge value of tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk) :: aL_r !< Right-column left edge value of tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk) :: aR_r !< Right-column right edge value of tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) ! Discontinuous reconstruction integer :: iMethod - real, dimension(nk,2) :: Tid_l !< Left-column interface tracer (conc, e.g. degC) - real, dimension(nk,2) :: Tid_r !< Right-column interface tracer (conc, e.g. degC) - real, dimension(nk,deg+1) :: ppoly_r_coeffs_l - real, dimension(nk,deg+1) :: ppoly_r_coeffs_r - real, dimension(nk,deg+1) :: ppoly_r_S_l - real, dimension(nk,deg+1) :: ppoly_r_S_r - logical :: down_flux + real, dimension(nk,2) :: Tid_l !< Left-column interface tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk,2) :: Tid_r !< Right-column interface tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk,deg+1) :: ppoly_r_coeffs_l ! Coefficients of the polynomial descriptions of + ! sub-gridscale tracer concentrations in the left column, in arbitrary + ! concentration units (e.g. [C ~> degC] for temperature) + real, dimension(nk,deg+1) :: ppoly_r_coeffs_r ! Coefficients of the polynomial descriptions of + ! sub-gridscale tracer concentrations in the right column, in arbitrary + ! concentration units (e.g. [C ~> degC] for temperature) + real, dimension(nk,deg+1) :: ppoly_r_S_l ! Reconstruction slopes that are unused here, in units of a vertical + ! gradient, which for temperature would be [C H-1 ~> degC m-1 or degC m2 kg-1]. + real, dimension(nk,deg+1) :: ppoly_r_S_r ! Reconstruction slopes that are unused here, in units of a vertical + ! gradient, which for temperature would be [C H-1 ~> degC m-1 or degC m2 kg-1]. + logical :: down_flux, tapering + + tapering = .false. + if (present(coeff_l) .and. present(coeff_r)) tapering = .true. + khtr_ave = 1.0 + ! Setup reconstruction edge values if (continuous) then call interface_scalar(nk, hl, Tl, Til, 2, h_neglect) @@ -1965,6 +2430,14 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K if (hEff(k_sublayer) == 0.) then Flx(k_sublayer) = 0. else + if (tapering) then + klb = KoL(k_sublayer+1) + klt = KoL(k_sublayer) + krb = KoR(k_sublayer+1) + krt = KoR(k_sublayer) + ! these are added in this order to preserve vertically-uniform diffusivity answers + khtr_ave = 0.25 * ((coeff_l(klb) + coeff_l(klt)) + (coeff_r(krb) + coeff_r(krt))) + endif if (continuous) then klb = KoL(k_sublayer+1) T_left_bottom = ( 1. - PiL(k_sublayer+1) ) * Til(klb) + PiL(k_sublayer+1) * Til(klb+1) @@ -1988,7 +2461,7 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K else dT_ave = dT_layer endif - Flx(k_sublayer) = dT_ave * hEff(k_sublayer) + Flx(k_sublayer) = dT_ave * hEff(k_sublayer) * khtr_ave else ! Discontinuous reconstruction ! Calculate tracer values on left and right side of the neutral surface call neutral_surface_T_eval(nk, nsurf, k_sublayer, KoL, PiL, Tl, Tid_l, deg, iMethod, & @@ -2014,7 +2487,7 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K dT_sublayer >= 0. .and. dT_top_int >= 0. .and. & dT_bot_int >= 0.) if (down_flux) then - Flx(k_sublayer) = dT_sublayer * hEff(k_sublayer) + Flx(k_sublayer) = dT_sublayer * hEff(k_sublayer) * khtr_ave else Flx(k_sublayer) = 0. endif @@ -2024,25 +2497,35 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K end subroutine neutral_surface_flux -!> Evaluate various parts of the reconstructions to calculate gradient-based flux limter +!> Evaluate various parts of the reconstructions to calculate gradient-based flux limiter subroutine neutral_surface_T_eval(nk, ns, k_sub, Ks, Ps, T_mean, T_int, deg, iMethod, T_poly, & T_top, T_bot, T_sub, T_top_int, T_bot_int, T_layer) - integer, intent(in ) :: nk !< Number of cell everages + integer, intent(in ) :: nk !< Number of cell averages integer, intent(in ) :: ns !< Number of neutral surfaces integer, intent(in ) :: k_sub !< Index of current neutral layer integer, dimension(ns), intent(in ) :: Ks !< List of the layers associated with each neutral surface - real, dimension(ns), intent(in ) :: Ps !< List of the positions within a layer of each surface - real, dimension(nk), intent(in ) :: T_mean !< Cell average of tracer - real, dimension(nk,2), intent(in ) :: T_int !< Cell interface values of tracer from reconstruction + real, dimension(ns), intent(in ) :: Ps !< List of the positions within a layer of each surface [nondim] + real, dimension(nk), intent(in ) :: T_mean !< Layer average of tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk,2), intent(in ) :: T_int !< Layer interface values of tracer from reconstruction + !! in concentration units (e.g. [C ~> degC] for temperature) integer, intent(in ) :: deg !< Degree of reconstruction polynomial (e.g. 1 is linear) integer, intent(in ) :: iMethod !< Method of integration to use - real, dimension(nk,deg+1), intent(in ) :: T_poly !< Coefficients of polynomial reconstructions - real, intent( out) :: T_top !< Tracer value at top (across discontinuity if necessary) + real, dimension(nk,deg+1), intent(in ) :: T_poly !< Coefficients of polynomial reconstructions in arbitrary + !! concentration units (e.g. [C ~> degC] for temperature) + real, intent( out) :: T_top !< Tracer value at top (across discontinuity if necessary) in + !! concentration units (e.g. [C ~> degC] for temperature) real, intent( out) :: T_bot !< Tracer value at bottom (across discontinuity if necessary) - real, intent( out) :: T_sub !< Average of the tracer value over the sublayer - real, intent( out) :: T_top_int !< Tracer value at top interface of neutral layer - real, intent( out) :: T_bot_int !< Tracer value at bottom interface of neutral layer - real, intent( out) :: T_layer !< Cell-average that the the reconstruction belongs to + !! in concentration units (e.g. [C ~> degC] for temperature) + real, intent( out) :: T_sub !< Average of the tracer value over the sublayer in arbitrary + !! concentration units (e.g. [C ~> degC] for temperature) + real, intent( out) :: T_top_int !< Tracer value at the top interface of a neutral layer in + !! concentration units (e.g. [C ~> degC] for temperature) + real, intent( out) :: T_bot_int !< Tracer value at the bottom interface of a neutral layer in + !! concentration units (e.g. [C ~> degC] for temperature) + real, intent( out) :: T_layer !< Cell-average tracer concentration in a layer that + !! the reconstruction belongs to in concentration + !! units (e.g. [C ~> degC] for temperature) integer :: kl, ks_top, ks_bot @@ -2080,10 +2563,12 @@ end subroutine neutral_surface_T_eval !> Discontinuous PPM reconstructions of the left/right edge values within a cell subroutine ppm_left_right_edge_values(nk, Tl, Ti, aL, aR) integer, intent(in) :: nk !< Number of levels - real, dimension(nk), intent(in) :: Tl !< Layer tracer (conc, e.g. degC) - real, dimension(nk+1), intent(in) :: Ti !< Interface tracer (conc, e.g. degC) + real, dimension(nk), intent(in) :: Tl !< Layer tracer (conc, e.g. degC) in arbitrary units [A ~> a] + real, dimension(nk+1), intent(in) :: Ti !< Interface tracer (conc, e.g. degC) in arbitrary units [A ~> a] real, dimension(nk), intent(inout) :: aL !< Left edge value of tracer (conc, e.g. degC) + !! in the same arbitrary units as Tl and Ti [A ~> a] real, dimension(nk), intent(inout) :: aR !< Right edge value of tracer (conc, e.g. degC) + !! in the same arbitrary units as Tl and Ti [A ~> a] integer :: k ! Setup reconstruction edge values @@ -2115,17 +2600,13 @@ logical function ndiff_unit_tests_continuous(verbose) logical, intent(in) :: verbose !< If true, write results to stdout ! Local variables integer, parameter :: nk = 4 - real, dimension(nk+1) :: TiL, TiR1, TiR2, TiR4, Tio ! Test interface temperatures - real, dimension(nk) :: TL ! Test layer temperatures - real, dimension(nk+1) :: SiL ! Test interface salinities - real, dimension(nk+1) :: PiL, PiR4 ! Test interface positions - real, dimension(2*nk+2) :: PiLRo, PiRLo ! Test positions - integer, dimension(2*nk+2) :: KoL, KoR ! Test indexes - real, dimension(2*nk+1) :: hEff ! Test positions - real, dimension(2*nk+1) :: Flx ! Test flux - integer :: k + real, dimension(nk+1) :: Tio ! Test interface temperatures [degC] + real, dimension(2*nk+2) :: PiLRo, PiRLo ! Fractional test positions [nondim] + integer, dimension(2*nk+2) :: KoL, KoR ! Test indexes + real, dimension(2*nk+1) :: hEff ! Test positions in arbitrary units [arbitrary] + real, dimension(2*nk+1) :: Flx ! Test flux in the arbitrary units of hEff times [degC] logical :: v - real :: h_neglect + real :: h_neglect ! A negligible thickness in arbitrary units [arbitrary] h_neglect = 1.0e-30 @@ -2381,24 +2862,21 @@ logical function ndiff_unit_tests_discontinuous(verbose) ! Local variables integer, parameter :: nk = 3 integer, parameter :: ns = nk*4 - real, dimension(nk) :: Sl, Sr, Tl, Tr ! Salinities [ppt] and temperatures [degC] - real, dimension(nk) :: hl, hr ! Thicknesses in pressure units [R L2 T-2 ~> Pa] + real, dimension(nk) :: Sl, Sr ! Salinities [ppt] and temperatures [degC] + real, dimension(nk) :: hl, hr ! Thicknesses in pressure units [R L2 T-2 ~> Pa] or other + ! arbitrary units [arbitrary] real, dimension(nk,2) :: TiL, SiL, TiR, SiR ! Cell edge salinities [ppt] and temperatures [degC] real, dimension(nk,2) :: Pres_l, Pres_r ! Interface pressures [R L2 T-2 ~> Pa] - integer, dimension(ns) :: KoL, KoR - real, dimension(ns) :: PoL, PoR - real, dimension(ns-1) :: hEff, Flx + integer, dimension(ns) :: KoL, KoR ! Index of the layer where the interface is found in the + ! left and right columns + real, dimension(ns) :: PoL, PoR ! Fractional position of neutral surface within layer KoL + ! of the left column or KoR of the right column [nondim] + real, dimension(ns-1) :: hEff ! Effective thickness between two neutral surfaces + ! in the same units as hl and hr [arbitrary] type(neutral_diffusion_CS) :: CS !< Neutral diffusion control structure - type(remapping_CS), pointer :: remap_CS !< Remapping control structure (PLM) - real, dimension(nk,2) :: ppoly_T_l, ppoly_T_r ! Linear reconstruction for T - real, dimension(nk,2) :: ppoly_S_l, ppoly_S_r ! Linear reconstruction for S - real, dimension(nk,2) :: dRdT !< Partial derivative of density with temperature at - !! cell edges [R degC-1 ~> kg m-3 degC-1] - real, dimension(nk,2) :: dRdS !< Partial derivative of density with salinity at - !! cell edges [R ppt-1 ~> kg m-3 ppt-1] + real, dimension(nk,2) :: ppoly_T_l, ppoly_T_r ! Linear reconstruction for T [degC] + real, dimension(nk,2) :: ppoly_S_l, ppoly_S_r ! Linear reconstruction for S [ppt] logical, dimension(nk) :: stable_l, stable_r - integer :: iMethod - integer :: ns_l, ns_r integer :: k logical :: v @@ -2411,8 +2889,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) allocate(CS%EOS) call EOS_manual_init(CS%EOS, form_of_EOS=EOS_LINEAR, dRho_dT=-1., dRho_dS=0.) Sl(:) = 0. ; Sr(:) = 0. ; ; SiL(:,:) = 0. ; SiR(:,:) = 0. - ppoly_T_l(:,:) = 0.; ppoly_T_r(:,:) = 0. - ppoly_S_l(:,:) = 0.; ppoly_S_r(:,:) = 0. + ppoly_T_l(:,:) = 0. ; ppoly_T_r(:,:) = 0. + ppoly_S_l(:,:) = 0. ; ppoly_S_r(:,:) = 0. ! Intialize any control structures needed for unit tests CS%ref_pres = -1. @@ -2427,8 +2905,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) CS%delta_rho_form = 'mid_pressure' CS%neutral_pos_method = 1 - TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); - TiR(1,:) = (/ 22.00, 18.00 /); TiR(2,:) = (/ 18.00, 14.00 /); TiR(3,:) = (/ 14.00, 10.00 /); + TiL(1,:) = (/ 22.00, 18.00 /) ; TiL(2,:) = (/ 18.00, 14.00 /) ; TiL(3,:) = (/ 14.00, 10.00 /) + TiR(1,:) = (/ 22.00, 18.00 /) ; TiR(2,:) = (/ 18.00, 14.00 /) ; TiR(3,:) = (/ 14.00, 10.00 /) call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & @@ -2441,8 +2919,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/ 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff 'Identical Columns') - TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); - TiR(1,:) = (/ 20.00, 16.00 /); TiR(2,:) = (/ 16.00, 12.00 /); TiR(3,:) = (/ 12.00, 8.00 /); + TiL(1,:) = (/ 22.00, 18.00 /) ; TiL(2,:) = (/ 18.00, 14.00 /) ; TiL(3,:) = (/ 14.00, 10.00 /) + TiR(1,:) = (/ 20.00, 16.00 /) ; TiR(2,:) = (/ 16.00, 12.00 /) ; TiR(3,:) = (/ 12.00, 8.00 /) call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & @@ -2455,8 +2933,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/ 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00 /), & ! hEff 'Right slightly cooler') - TiL(1,:) = (/ 20.00, 16.00 /); TiL(2,:) = (/ 16.00, 12.00 /); TiL(3,:) = (/ 12.00, 8.00 /); - TiR(1,:) = (/ 22.00, 18.00 /); TiR(2,:) = (/ 18.00, 14.00 /); TiR(3,:) = (/ 14.00, 10.00 /); + TiL(1,:) = (/ 20.00, 16.00 /) ; TiL(2,:) = (/ 16.00, 12.00 /) ; TiL(3,:) = (/ 12.00, 8.00 /) + TiR(1,:) = (/ 22.00, 18.00 /) ; TiR(2,:) = (/ 18.00, 14.00 /) ; TiR(3,:) = (/ 14.00, 10.00 /) call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & @@ -2469,8 +2947,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/ 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00, 5.00, 0.00 /), & ! hEff 'Left slightly cooler') - TiL(1,:) = (/ 22.00, 20.00 /); TiL(2,:) = (/ 18.00, 16.00 /); TiL(3,:) = (/ 14.00, 12.00 /); - TiR(1,:) = (/ 32.00, 24.00 /); TiR(2,:) = (/ 22.00, 14.00 /); TiR(3,:) = (/ 12.00, 4.00 /); + TiL(1,:) = (/ 22.00, 20.00 /) ; TiL(2,:) = (/ 18.00, 16.00 /) ; TiL(3,:) = (/ 14.00, 12.00 /) + TiR(1,:) = (/ 32.00, 24.00 /) ; TiR(2,:) = (/ 22.00, 14.00 /) ; TiR(3,:) = (/ 12.00, 4.00 /) call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & @@ -2483,8 +2961,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/ 0.00, 0.00, 0.00, 4.00, 0.00, 4.00, 0.00, 0.00, 0.00, 0.00, 0.00 /), & ! hEff 'Right more strongly stratified') - TiL(1,:) = (/ 22.00, 18.00 /); TiL(2,:) = (/ 18.00, 14.00 /); TiL(3,:) = (/ 14.00, 10.00 /); - TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 12.00, 8.00 /); + TiL(1,:) = (/ 22.00, 18.00 /) ; TiL(2,:) = (/ 18.00, 14.00 /) ; TiL(3,:) = (/ 14.00, 10.00 /) + TiR(1,:) = (/ 14.00, 14.00 /) ; TiR(2,:) = (/ 14.00, 14.00 /) ; TiR(3,:) = (/ 12.00, 8.00 /) call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & @@ -2497,8 +2975,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 5.00, 0.00 /), & ! hEff 'Deep Mixed layer on the right') - TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 12.00 /); TiL(3,:) = (/ 10.00, 8.00 /); - TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 14.00, 14.00 /); + TiL(1,:) = (/ 14.00, 14.00 /) ; TiL(2,:) = (/ 14.00, 12.00 /) ; TiL(3,:) = (/ 10.00, 8.00 /) + TiR(1,:) = (/ 14.00, 14.00 /) ; TiR(2,:) = (/ 14.00, 14.00 /) ; TiR(3,:) = (/ 14.00, 14.00 /) call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & @@ -2511,8 +2989,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 /), & ! hEff 'Right unstratified column') - TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 12.00 /); TiL(3,:) = (/ 10.00, 8.00 /); - TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 14.00 /); TiR(3,:) = (/ 12.00, 4.00 /); + TiL(1,:) = (/ 14.00, 14.00 /) ; TiL(2,:) = (/ 14.00, 12.00 /) ; TiL(3,:) = (/ 10.00, 8.00 /) + TiR(1,:) = (/ 14.00, 14.00 /) ; TiR(2,:) = (/ 14.00, 14.00 /) ; TiR(3,:) = (/ 12.00, 4.00 /) call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & @@ -2525,8 +3003,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 4.00, 0.00 /), & ! hEff 'Right unstratified column') - TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 14.00, 10.00 /); TiL(3,:) = (/ 10.00, 2.00 /); - TiR(1,:) = (/ 14.00, 14.00 /); TiR(2,:) = (/ 14.00, 10.00 /); TiR(3,:) = (/ 10.00, 2.00 /); + TiL(1,:) = (/ 14.00, 14.00 /) ; TiL(2,:) = (/ 14.00, 10.00 /) ; TiL(3,:) = (/ 10.00, 2.00 /) + TiR(1,:) = (/ 14.00, 14.00 /) ; TiR(2,:) = (/ 14.00, 10.00 /) ; TiR(3,:) = (/ 10.00, 2.00 /) call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & @@ -2539,8 +3017,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/ 0.00, 0.00, 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff 'Identical columns with mixed layer') - TiL(1,:) = (/ 14.00, 12.00 /); TiL(2,:) = (/ 10.00, 10.00 /); TiL(3,:) = (/ 8.00, 2.00 /); - TiR(1,:) = (/ 14.00, 12.00 /); TiR(2,:) = (/ 12.00, 8.00 /); TiR(3,:) = (/ 8.00, 2.00 /); + TiL(1,:) = (/ 14.00, 12.00 /) ; TiL(2,:) = (/ 10.00, 10.00 /) ; TiL(3,:) = (/ 8.00, 2.00 /) + TiR(1,:) = (/ 14.00, 12.00 /) ; TiR(2,:) = (/ 12.00, 8.00 /) ; TiR(3,:) = (/ 8.00, 2.00 /) call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & @@ -2553,8 +3031,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/ 0.00, 10.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 10.00, 0.00 /), & ! hEff 'Left interior unstratified') - TiL(1,:) = (/ 12.00, 12.00 /); TiL(2,:) = (/ 12.00, 10.00 /); TiL(3,:) = (/ 10.00, 6.00 /); - TiR(1,:) = (/ 12.00, 10.00 /); TiR(2,:) = (/ 10.00, 12.00 /); TiR(3,:) = (/ 8.00, 4.00 /); + TiL(1,:) = (/ 12.00, 12.00 /) ; TiL(2,:) = (/ 12.00, 10.00 /) ; TiL(3,:) = (/ 10.00, 6.00 /) + TiR(1,:) = (/ 12.00, 10.00 /) ; TiR(2,:) = (/ 10.00, 12.00 /) ; TiR(3,:) = (/ 8.00, 4.00 /) call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & @@ -2567,8 +3045,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/ 0.00, 0.00, 0.00, 10.00, 0.00, 0.00, 0.00, 0.00, 0.00, 5.00, 0.00 /), & ! hEff 'Left mixed layer, Right unstable interior') - TiL(1,:) = (/ 14.00, 14.00 /); TiL(2,:) = (/ 10.00, 10.00 /); TiL(3,:) = (/ 8.00, 6.00 /); - TiR(1,:) = (/ 10.00, 14.00 /); TiR(2,:) = (/ 16.00, 16.00 /); TiR(3,:) = (/ 12.00, 4.00 /); + TiL(1,:) = (/ 14.00, 14.00 /) ; TiL(2,:) = (/ 10.00, 10.00 /) ; TiL(3,:) = (/ 8.00, 6.00 /) + TiR(1,:) = (/ 10.00, 14.00 /) ; TiR(2,:) = (/ 16.00, 16.00 /) ; TiR(3,:) = (/ 12.00, 4.00 /) call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & @@ -2581,8 +3059,8 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/ 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 4.00, 0.00 /), & ! hEff 'Left thick mixed layer, Right unstable mixed') - TiL(1,:) = (/ 8.00, 12.00 /); TiL(2,:) = (/ 12.00, 10.00 /); TiL(3,:) = (/ 8.00, 4.00 /); - TiR(1,:) = (/ 10.00, 14.00 /); TiR(2,:) = (/ 14.00, 12.00 /); TiR(3,:) = (/ 10.00, 6.00 /); + TiL(1,:) = (/ 8.00, 12.00 /) ; TiL(2,:) = (/ 12.00, 10.00 /) ; TiL(3,:) = (/ 8.00, 4.00 /) + TiR(1,:) = (/ 10.00, 14.00 /) ; TiR(2,:) = (/ 14.00, 12.00 /) ; TiR(3,:) = (/ 10.00, 6.00 /) call mark_unstable_cells( CS, nk, Til, Sil, Pres_l, stable_l ) call mark_unstable_cells( CS, nk, Tir, Sir, Pres_r, stable_r ) call find_neutral_surface_positions_discontinuous(CS, nk, Pres_l, hL, TiL, SiL, ppoly_T_l, ppoly_S_l, stable_l, & @@ -2636,15 +3114,15 @@ logical function test_fv_diff(verbose, hkm1, hk, hkp1, Skm1, Sk, Skp1, Ptrue, ti real, intent(in) :: hkm1 !< Left cell width [nondim] real, intent(in) :: hk !< Center cell width [nondim] real, intent(in) :: hkp1 !< Right cell width [nondim] - real, intent(in) :: Skm1 !< Left cell average value - real, intent(in) :: Sk !< Center cell average value - real, intent(in) :: Skp1 !< Right cell average value - real, intent(in) :: Ptrue !< True answer [nondim] + real, intent(in) :: Skm1 !< Left cell average value in arbitrary units [arbitrary] + real, intent(in) :: Sk !< Center cell average value in arbitrary units [arbitrary] + real, intent(in) :: Skp1 !< Right cell average value in arbitrary units [arbitrary] + real, intent(in) :: Ptrue !< True answer in arbitrary units [arbitrary] character(len=*), intent(in) :: title !< Title for messages ! Local variables integer :: stdunit - real :: Pret + real :: Pret ! Returned normalized gradient in arbitrary units [arbitrary] Pret = fv_diff(hkm1, hk, hkp1, Skm1, Sk, Skp1) test_fv_diff = (Pret /= Ptrue) @@ -2654,9 +3132,9 @@ logical function test_fv_diff(verbose, hkm1, hk, hkp1, Skm1, Sk, Skp1, Ptrue, ti if (test_fv_diff) stdunit = stderr ! In case of wrong results, write to error stream write(stdunit,'(a)') title if (test_fv_diff) then - write(stdunit,'(2(x,a,f20.16),x,a)') 'pRet=',Pret,'pTrue=',Ptrue,'WRONG!' + write(stdunit,'(2(1x,a,f20.16),1x,a)') 'pRet=',Pret,'pTrue=',Ptrue,'WRONG!' else - write(stdunit,'(2(x,a,f20.16))') 'pRet=',Pret,'pTrue=',Ptrue + write(stdunit,'(2(1x,a,f20.16))') 'pRet=',Pret,'pTrue=',Ptrue endif endif @@ -2665,18 +3143,18 @@ end function test_fv_diff !> Returns true if a test of fvlsq_slope() fails, and conditionally writes results to stream logical function test_fvlsq_slope(verbose, hkm1, hk, hkp1, Skm1, Sk, Skp1, Ptrue, title) logical, intent(in) :: verbose !< If true, write results to stdout - real, intent(in) :: hkm1 !< Left cell width - real, intent(in) :: hk !< Center cell width - real, intent(in) :: hkp1 !< Right cell width - real, intent(in) :: Skm1 !< Left cell average value - real, intent(in) :: Sk !< Center cell average value - real, intent(in) :: Skp1 !< Right cell average value - real, intent(in) :: Ptrue !< True answer + real, intent(in) :: hkm1 !< Left cell width in arbitrary units [B ~> b] + real, intent(in) :: hk !< Center cell width in arbitrary units [B ~> b] + real, intent(in) :: hkp1 !< Right cell width in arbitrary units [B ~> b] + real, intent(in) :: Skm1 !< Left cell average value in arbitrary units [A ~> a] + real, intent(in) :: Sk !< Center cell average value in arbitrary units [A ~> a] + real, intent(in) :: Skp1 !< Right cell average value in arbitrary units [A ~> a] + real, intent(in) :: Ptrue !< True answer in arbitrary units [A B-1 ~> a b-1] character(len=*), intent(in) :: title !< Title for messages ! Local variables integer :: stdunit - real :: Pret + real :: Pret ! Returned slope value [A B-1 ~> a b-1] Pret = fvlsq_slope(hkm1, hk, hkp1, Skm1, Sk, Skp1) test_fvlsq_slope = (Pret /= Ptrue) @@ -2686,9 +3164,9 @@ logical function test_fvlsq_slope(verbose, hkm1, hk, hkp1, Skm1, Sk, Skp1, Ptrue if (test_fvlsq_slope) stdunit = stderr ! In case of wrong results, write to error stream write(stdunit,'(a)') title if (test_fvlsq_slope) then - write(stdunit,'(2(x,a,f20.16),x,a)') 'pRet=',Pret,'pTrue=',Ptrue,'WRONG!' + write(stdunit,'(2(1x,a,f20.16),1x,a)') 'pRet=',Pret,'pTrue=',Ptrue,'WRONG!' else - write(stdunit,'(2(x,a,f20.16))') 'pRet=',Pret,'pTrue=',Ptrue + write(stdunit,'(2(1x,a,f20.16))') 'pRet=',Pret,'pTrue=',Ptrue endif endif @@ -2706,7 +3184,7 @@ logical function test_ifndp(verbose, rhoNeg, Pneg, rhoPos, Ppos, Ptrue, title) ! Local variables integer :: stdunit - real :: Pret + real :: Pret ! Interpolated fractional position [nondim] Pret = interpolate_for_nondim_position(rhoNeg, Pneg, rhoPos, Ppos) test_ifndp = (Pret /= Ptrue) @@ -2716,10 +3194,10 @@ logical function test_ifndp(verbose, rhoNeg, Pneg, rhoPos, Ppos, Ptrue, title) if (test_ifndp) stdunit = stderr ! In case of wrong results, write to error stream write(stdunit,'(a)') title if (test_ifndp) then - write(stdunit,'(4(x,a,f20.16),2(x,a,1pe22.15),x,a)') & + write(stdunit,'(4(1x,a,f20.16),2(1x,a,1pe22.15),1x,a)') & 'r1=',rhoNeg,'p1=',Pneg,'r2=',rhoPos,'p2=',Ppos,'pRet=',Pret,'pTrue=',Ptrue,'WRONG!' else - write(stdunit,'(4(x,a,f20.16),2(x,a,1pe22.15))') & + write(stdunit,'(4(1x,a,f20.16),2(1x,a,1pe22.15))') & 'r1=',rhoNeg,'p1=',Pneg,'r2=',rhoPos,'p2=',Ppos,'pRet=',Pret,'pTrue=',Ptrue endif endif @@ -2730,8 +3208,8 @@ end function test_ifndp logical function test_data1d(verbose, nk, Po, Ptrue, title) logical, intent(in) :: verbose !< If true, write results to stdout integer, intent(in) :: nk !< Number of layers - real, dimension(nk), intent(in) :: Po !< Calculated answer - real, dimension(nk), intent(in) :: Ptrue !< True answer + real, dimension(nk), intent(in) :: Po !< Calculated answer [arbitrary] + real, dimension(nk), intent(in) :: Ptrue !< True answer [arbitrary] character(len=*), intent(in) :: title !< Title for messages ! Local variables @@ -2749,11 +3227,11 @@ logical function test_data1d(verbose, nk, Po, Ptrue, title) do k = 1,nk if (Po(k) /= Ptrue(k)) then test_data1d = .true. - write(stdunit,'(a,i2,2(x,a,f20.16),x,a,1pe22.15,x,a)') & + write(stdunit,'(a,I0,2(1x,a,f20.16),1x,a,1pe22.15,1x,a)') & 'k=',k,'Po=',Po(k),'Ptrue=',Ptrue(k),'err=',Po(k)-Ptrue(k),'WRONG!' else if (verbose) & - write(stdunit,'(a,i2,2(x,a,f20.16),x,a,1pe22.15)') & + write(stdunit,'(a,I0,2(1x,a,f20.16),1x,a,1pe22.15)') & 'k=',k,'Po=',Po(k),'Ptrue=',Ptrue(k),'err=',Po(k)-Ptrue(k) endif enddo @@ -2765,8 +3243,8 @@ end function test_data1d logical function test_data1di(verbose, nk, Po, Ptrue, title) logical, intent(in) :: verbose !< If true, write results to stdout integer, intent(in) :: nk !< Number of layers - integer, dimension(nk), intent(in) :: Po !< Calculated answer - integer, dimension(nk), intent(in) :: Ptrue !< True answer + integer, dimension(nk), intent(in) :: Po !< Calculated answer [arbitrary] + integer, dimension(nk), intent(in) :: Ptrue !< True answer [arbitrary] character(len=*), intent(in) :: title !< Title for messages ! Local variables @@ -2784,10 +3262,10 @@ logical function test_data1di(verbose, nk, Po, Ptrue, title) do k = 1,nk if (Po(k) /= Ptrue(k)) then test_data1di = .true. - write(stdunit,'(a,i2,2(x,a,i5),x,a)') 'k=',k,'Io=',Po(k),'Itrue=',Ptrue(k),'WRONG!' + write(stdunit,'(a,I0,2(1x,a,i5),1x,a)') 'k=',k,'Io=',Po(k),'Itrue=',Ptrue(k),'WRONG!' else if (verbose) & - write(stdunit,'(a,i2,2(x,a,i5))') 'k=',k,'Io=',Po(k),'Itrue=',Ptrue(k) + write(stdunit,'(a,I0,2(1x,a,i5))') 'k=',k,'Io=',Po(k),'Itrue=',Ptrue(k) endif enddo endif @@ -2801,14 +3279,16 @@ logical function test_nsp(verbose, ns, KoL, KoR, pL, pR, hEff, KoL0, KoR0, pL0, integer, intent(in) :: ns !< Number of surfaces integer, dimension(ns), intent(in) :: KoL !< Index of first left interface above neutral surface integer, dimension(ns), intent(in) :: KoR !< Index of first right interface above neutral surface - real, dimension(ns), intent(in) :: pL !< Fractional position of neutral surface within layer KoL of left column - real, dimension(ns), intent(in) :: pR !< Fractional position of neutral surface within layer KoR of right column + real, dimension(ns), intent(in) :: pL !< Fractional position of neutral surface within layer + !! KoL of left column [nondim] + real, dimension(ns), intent(in) :: pR !< Fractional position of neutral surface within layer + !! KoR of right column [nondim] real, dimension(ns-1), intent(in) :: hEff !< Effective thickness between two neutral surfaces [R L2 T-2 ~> Pa] integer, dimension(ns), intent(in) :: KoL0 !< Correct value for KoL integer, dimension(ns), intent(in) :: KoR0 !< Correct value for KoR - real, dimension(ns), intent(in) :: pL0 !< Correct value for pL - real, dimension(ns), intent(in) :: pR0 !< Correct value for pR - real, dimension(ns-1), intent(in) :: hEff0 !< Correct value for hEff + real, dimension(ns), intent(in) :: pL0 !< Correct value for pL [nondim] + real, dimension(ns), intent(in) :: pR0 !< Correct value for pR [nondim] + real, dimension(ns-1), intent(in) :: hEff0 !< Correct value for hEff [R L2 T-2 ~> Pa] character(len=*), intent(in) :: title !< Title for messages ! Local variables @@ -2853,12 +3333,12 @@ end function test_nsp logical function compare_nsp_row(KoL, KoR, pL, pR, KoL0, KoR0, pL0, pR0) integer, intent(in) :: KoL !< Index of first left interface above neutral surface integer, intent(in) :: KoR !< Index of first right interface above neutral surface - real, intent(in) :: pL !< Fractional position of neutral surface within layer KoL of left column - real, intent(in) :: pR !< Fractional position of neutral surface within layer KoR of right column + real, intent(in) :: pL !< Fractional position of neutral surface within layer KoL of left column [nondim] + real, intent(in) :: pR !< Fractional position of neutral surface within layer KoR of right column [nondim] integer, intent(in) :: KoL0 !< Correct value for KoL integer, intent(in) :: KoR0 !< Correct value for KoR - real, intent(in) :: pL0 !< Correct value for pL - real, intent(in) :: pR0 !< Correct value for pR + real, intent(in) :: pL0 !< Correct value for pL [nondim] + real, intent(in) :: pR0 !< Correct value for pR [nondim] compare_nsp_row = .false. if (KoL /= KoL0) compare_nsp_row = .true. @@ -2869,8 +3349,8 @@ end function compare_nsp_row !> Compares output position from refine_nondim_position with an expected value logical function test_rnp(expected_pos, test_pos, title) - real, intent(in) :: expected_pos !< The expected position - real, intent(in) :: test_pos !< The position returned by the code + real, intent(in) :: expected_pos !< The expected position [arbitrary] + real, intent(in) :: test_pos !< The position returned by the code [arbitrary] character(len=*), intent(in) :: title !< A label for this test ! Local variables integer :: stdunit @@ -2883,6 +3363,7 @@ logical function test_rnp(expected_pos, test_pos, title) write(stdunit,'(A, f20.16, " == ", f20.16)') title, expected_pos, test_pos endif end function test_rnp + !> Deallocates neutral_diffusion control structure subroutine neutral_diffusion_end(CS) type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index af8b422238..4ea3ee70cc 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -1,13 +1,14 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Contains routines related to offline transport of tracers. These routines are likely to be called from !> the MOM_offline_main module module MOM_offline_aux -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_debugging, only : check_column_integrals use MOM_domains, only : pass_var, pass_vector, To_All use MOM_diag_mediator, only : post_data -use MOM_diag_vkernels, only : reintegrate_column use MOM_error_handler, only : callTree_enter, callTree_leave, MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_forcing_type, only : forcing @@ -15,6 +16,7 @@ module MOM_offline_aux use MOM_io, only : MOM_read_data, MOM_read_vector, CENTER use MOM_opacity, only : optics_type use MOM_time_manager, only : time_type, operator(-) +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : vertvisc_type use MOM_verticalGrid, only : verticalGrid_type use astronomy_mod, only : orbital_time, diurnal_solar, daily_mean_solar @@ -34,43 +36,36 @@ module MOM_offline_aux public offline_add_diurnal_sw #include "MOM_memory.h" -#include "version_variable.h" contains !> This updates thickness based on the convergence of horizontal mass fluxes !! NOTE: Only used in non-ALE mode subroutine update_h_horizontal_flux(G, GV, uhtr, vhtr, h_pre, h_new) - type(ocean_grid_type), pointer :: G !< ocean grid structure - type(verticalGrid_type), pointer :: GV !< ocean vertical grid structure + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: uhtr !< Accumulated mass flux through zonal face [kg] + intent(in) :: uhtr !< Accumulated mass flux through zonal face [H L2 ~> m3 or kg] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(in) :: vhtr !< Accumulated mass flux through meridional face [kg] + intent(in) :: vhtr !< Accumulated mass flux through meridional face [H L2 ~> m3 or kg] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h_pre !< Previous layer thicknesses [kg m-2]. + intent(in) :: h_pre !< Previous layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: h_new !< Updated layer thicknesses [kg m-2]. + intent(inout) :: h_new !< Updated layer thicknesses [H ~> m or kg m-2] ! Local variables - integer :: i, j, k, m, is, ie, js, je, nz + integer :: i, j, k, is, ie, js, je, nz ! Set index-related variables for fields on T-grid - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - do k = 1, nz + do k=1,nz do i=is-1,ie+1 ; do j=js-1,je+1 - h_new(i,j,k) = max(0.0, G%US%L_to_m**2*G%areaT(i,j)*h_pre(i,j,k) + & - ((uhtr(I-1,j,k) - uhtr(I,j,k)) + (vhtr(i,J-1,k) - vhtr(i,J,k)))) - - ! In the case that the layer is now dramatically thinner than it was previously, - ! add a bit of mass to avoid truncation errors. This will lead to - ! non-conservation of tracers - h_new(i,j,k) = h_new(i,j,k) + & - max(GV%Angstrom_H, 1.0e-13*h_new(i,j,k) - G%US%L_to_m**2*G%areaT(i,j)*h_pre(i,j,k)) + h_new(i,j,k) = max(0.0, G%areaT(i,j)*h_pre(i,j,k) + & + ((uhtr(I-1,j,k) - uhtr(I,j,k)) + (vhtr(i,J-1,k) - vhtr(i,J,k)))) ! Convert back to thickness - h_new(i,j,k) = h_new(i,j,k) / (G%US%L_to_m**2*G%areaT(i,j)) + h_new(i,j,k) = max(GV%Angstrom_H, h_new(i,j,k) * G%IareaT(i,j)) enddo ; enddo enddo @@ -79,52 +74,40 @@ end subroutine update_h_horizontal_flux !> Updates layer thicknesses due to vertical mass transports !! NOTE: Only used in non-ALE configuration subroutine update_h_vertical_flux(G, GV, ea, eb, h_pre, h_new) - type(ocean_grid_type), pointer :: G !< ocean grid structure - type(verticalGrid_type), pointer :: GV !< ocean vertical grid structure + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: ea !< Mass of fluid entrained from the layer - !! above within this timestep [kg m-2] + !! above within this timestep [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: eb !< Mass of fluid entrained from the layer - !! below within this timestep [kg m-2] + !! below within this timestep [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h_pre !< Layer thicknesses at the end of the previous - !! step [kg m-2]. + !! step [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: h_new !< Updated layer thicknesses [kg m-2]. + intent(inout) :: h_new !< Updated layer thicknesses [H ~> m or kg m-2] ! Local variables - integer :: i, j, k, m, is, ie, js, je, nz + integer :: i, j, k, is, ie, js, je, nz ! Set index-related variables for fields on T-grid - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke ! Update h_new with convergence of vertical mass transports do j=js-1,je+1 do i=is-1,ie+1 - ! Top layer - h_new(i,j,1) = max(0.0, h_pre(i,j,1) + (eb(i,j,1) - ea(i,j,2) + ea(i,j,1) )) - h_new(i,j,1) = h_new(i,j,1) + & - max(0.0, 1.0e-13*h_new(i,j,1) - h_pre(i,j,1)) + h_new(i,j,1) = max(0.0, h_pre(i,j,1) + ((eb(i,j,1) - ea(i,j,2)) + ea(i,j,1))) ! Bottom layer -! h_new(i,j,nz) = h_pre(i,j,nz) + (ea(i,j,nz) - eb(i,j,nz-1)+eb(i,j,nz)) - h_new(i,j,nz) = max(0.0, h_pre(i,j,nz) + (ea(i,j,nz) - eb(i,j,nz-1)+eb(i,j,nz))) - h_new(i,j,nz) = h_new(i,j,nz) + & - max(0.0, 1.0e-13*h_new(i,j,nz) - h_pre(i,j,nz)) - + h_new(i,j,nz) = max(0.0, h_pre(i,j,nz) + ((ea(i,j,nz) - eb(i,j,nz-1)) + eb(i,j,nz))) enddo ! Interior layers do k=2,nz-1 ; do i=is-1,ie+1 - h_new(i,j,k) = max(0.0, h_pre(i,j,k) + ((ea(i,j,k) - eb(i,j,k-1)) + & - (eb(i,j,k) - ea(i,j,k+1)))) - h_new(i,j,k) = h_new(i,j,k) + & - max(0.0, 1.0e-13*h_new(i,j,k) - h_pre(i,j,k)) - + (eb(i,j,k) - ea(i,j,k+1)))) enddo ; enddo - enddo end subroutine update_h_vertical_flux @@ -132,35 +115,41 @@ end subroutine update_h_vertical_flux !> This routine limits the mass fluxes so that the a layer cannot be completely depleted. !! NOTE: Only used in non-ALE mode subroutine limit_mass_flux_3d(G, GV, uh, vh, ea, eb, h_pre) - type(ocean_grid_type), pointer :: G !< ocean grid structure - type(verticalGrid_type), pointer :: GV !< ocean vertical grid structure + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: uh !< Mass flux through zonal face [kg] + intent(inout) :: uh !< Mass flux through zonal face [H L2 ~> m3 or kg] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(inout) :: vh !< Mass flux through meridional face [kg] + intent(inout) :: vh !< Mass flux through meridional face [H L2 ~> m3 or kg] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: ea !< Mass of fluid entrained from the layer - !! above within this timestep [kg m-2] + !! above within this timestep [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: eb !< Mass of fluid entrained from the layer - !! below within this timestep [kg m-2] + !! below within this timestep [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h_pre !< Layer thicknesses at the end of the previous - !! step [kg m-2]. + !! step [H ~> m or kg m-2] ! Local variables - integer :: i, j, k, m, is, ie, js, je, nz - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: top_flux, bottom_flux - real :: pos_flux, hvol, h_neglect, scale_factor, max_off_cfl + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: top_flux ! Net upward fluxes through the layer + ! top [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: bottom_flux ! Net downward fluxes through the layer + ! bottom [H ~> m or kg m-2] + real :: pos_flux ! Net flux out of cell [H L2 ~> m3 or kg] + real :: hvol ! Cell volume [H L2 ~> m3 or kg] + real :: scale_factor ! A nondimensional rescaling factor between 0 and 1 [nondim] + real :: max_off_cfl ! The maximum permitted fraction that can leave in a timestep [nondim] + integer :: i, j, k, is, ie, js, je, nz - max_off_cfl =0.5 + max_off_cfl = 0.5 ! In this subroutine, fluxes out of the box are scaled away if they deplete ! the layer, note that we define the positive direction as flux out of the box. ! Hence, uh(I-1) is multipled by negative one, but uh(I) is not ! Set index-related variables for fields on T-grid - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke ! Calculate top and bottom fluxes from ea and eb. Note the explicit negative signs ! to enforce the positive out convention @@ -170,7 +159,7 @@ subroutine limit_mass_flux_3d(G, GV, uh, vh, ea, eb, h_pre) bottom_flux(i,j,k) = -(eb(i,j,k)-ea(i,j,k+1)) enddo ; enddo - do k=2, nz-1 ; do j=js-1,je+1 ; do i=is-1,ie+1 + do k=2,nz-1 ; do j=js-1,je+1 ; do i=is-1,ie+1 top_flux(i,j,k) = -(ea(i,j,k)-eb(i,j,k-1)) bottom_flux(i,j,k) = -(eb(i,j,k)-ea(i,j,k+1)) enddo ; enddo ; enddo @@ -184,49 +173,36 @@ subroutine limit_mass_flux_3d(G, GV, uh, vh, ea, eb, h_pre) ! Calculate sum of positive fluxes (negatives applied to enforce convention) ! in a given cell and scale it back if it would deplete a layer - do k = 1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 - hvol = h_pre(i,j,k)*G%US%L_to_m**2*G%areaT(i,j) - pos_flux = max(0.0,-uh(I-1,j,k)) + max(0.0, -vh(i,J-1,k)) + & - max(0.0, uh(I,j,k)) + max(0.0, vh(i,J,k)) + & - max(0.0, top_flux(i,j,k)*G%US%L_to_m**2*G%areaT(i,j)) + max(0.0, bottom_flux(i,j,k)*G%US%L_to_m**2*G%areaT(i,j)) + hvol = h_pre(i,j,k) * G%areaT(i,j) + pos_flux = ((max(0.0, -uh(I-1,j,k)) + max(0.0, uh(I,j,k))) + & + (max(0.0, -vh(i,J-1,k)) + max(0.0, vh(i,J,k)))) + & + (max(0.0, top_flux(i,j,k)) + max(0.0, bottom_flux(i,j,k))) * G%areaT(i,j) - if (pos_flux>hvol .and. pos_flux>0.0) then - scale_factor = ( hvol )/pos_flux*max_off_cfl + if ((pos_flux > hvol) .and. (pos_flux > 0.0)) then + scale_factor = (hvol / pos_flux) * max_off_cfl else ! Don't scale scale_factor = 1.0 endif ! Scale horizontal fluxes - if (-uh(I-1,j,k)>0) uh(I-1,j,k) = uh(I-1,j,k)*scale_factor - if (uh(I,j,k)>0) uh(I,j,k) = uh(I,j,k)*scale_factor - if (-vh(i,J-1,k)>0) vh(i,J-1,k) = vh(i,J-1,k)*scale_factor - if (vh(i,J,k)>0) vh(i,J,k) = vh(i,J,k)*scale_factor - - if (k>1 .and. k0.0) then - ea(i,j,k) = ea(i,j,k)*scale_factor - eb(i,j,k-1) = eb(i,j,k-1)*scale_factor - endif - if (bottom_flux(i,j,k)>0.0) then - eb(i,j,k) = eb(i,j,k)*scale_factor - ea(i,j,k+1) = ea(i,j,k+1)*scale_factor - endif - ! Scale top layer - elseif (k==1) then - if (top_flux(i,j,k)>0.0) ea(i,j,k) = ea(i,j,k)*scale_factor - if (bottom_flux(i,j,k)>0.0) then - eb(i,j,k) = eb(i,j,k)*scale_factor - ea(i,j,k+1) = ea(i,j,k+1)*scale_factor - endif - ! Scale bottom layer - elseif (k==nz) then - if (top_flux(i,j,k)>0.0) then - ea(i,j,k) = ea(i,j,k)*scale_factor - eb(i,j,k-1) = eb(i,j,k-1)*scale_factor - endif - if (bottom_flux(i,j,k)>0.0) eb(i,j,k)=eb(i,j,k)*scale_factor + if (-uh(I-1,j,k) > 0.0) uh(I-1,j,k) = uh(I-1,j,k) * scale_factor + if (uh(I,j,k) > 0.0) uh(I,j,k) = uh(I,j,k) * scale_factor + if (-vh(i,J-1,k) > 0.0) vh(i,J-1,k) = vh(i,J-1,k) * scale_factor + if (vh(i,J,k) > 0.0) vh(i,J,k) = vh(i,J,k) * scale_factor + + ! Scale the flux across the interface atop a layer if it is upward + if (top_flux(i,j,k) > 0.0) then + ea(i,j,k) = ea(i,j,k) * scale_factor + if (k > 1) & + eb(i,j,k-1) = eb(i,j,k-1) * scale_factor + endif + ! Scale the flux across the interface atop a layer if it is downward + if (bottom_flux(i,j,k) > 0.0) then + eb(i,j,k) = eb(i,j,k) * scale_factor + if (k < nz) & + ea(i,j,k+1) = ea(i,j,k+1) * scale_factor endif enddo ; enddo ; enddo @@ -235,29 +211,32 @@ end subroutine limit_mass_flux_3d !> In the case where offline advection has failed to converge, redistribute the u-flux !! into remainder of the water column as a barotropic equivalent subroutine distribute_residual_uh_barotropic(G, GV, hvol, uh) - type(ocean_grid_type), pointer :: G !< ocean grid structure - type(verticalGrid_type), pointer :: GV !< ocean vertical grid structure + type(ocean_grid_type), intent(in ) :: G !< ocean grid structure + type(verticalGrid_type), intent(in ) :: GV !< ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in ) :: hvol !< Mass of water in the cells at the end - !! of the previous timestep [kg] + !! of the previous timestep [H L2 ~> m3 or kg] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: uh !< Zonal mass transport within a timestep [kg] - - real, dimension(SZIB_(G),SZK_(GV)) :: uh2d - real, dimension(SZIB_(G)) :: uh2d_sum - real, dimension(SZI_(G),SZK_(GV)) :: h2d - real, dimension(SZI_(G)) :: h2d_sum + intent(inout) :: uh !< Zonal mass transport within a timestep [H L2 ~> m3 or kg] - integer :: i, j, k, m, is, ie, js, je, nz - real :: uh_neglect + ! Local variables + real, dimension(SZIB_(G),SZK_(GV)) :: uh2d ! A 2-d slice of transports [H L2 ~> m3 or kg] + real, dimension(SZIB_(G)) :: uh2d_sum ! Vertically summed transports [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZK_(GV)) :: h2d ! A 2-d slice of cell volumes [H L2 ~> m3 or kg] + real, dimension(SZI_(G)) :: h2d_sum ! Vertically summed cell volumes [H L2 ~> m3 or kg] + + real :: abs_uh_sum ! The vertical sum of the absolute value of the transports [H L2 ~> m3 or kg] + real :: new_uh_sum ! The vertically summed transports after redistribution [H L2 ~> m3 or kg] + real :: uh_neglect ! A negligible transport [H L2 ~> m3 or kg] + integer :: i, j, k, is, ie, js, je, nz ! Set index-related variables for fields on T-grid - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke do j=js,je uh2d_sum(:) = 0.0 ! Copy over uh to a working array and sum up the remaining fluxes in a column - do k=1,nz ; do i=is-1,ie + do k=1,nz ; do I=is-1,ie uh2d(I,k) = uh(I,j,k) uh2d_sum(I) = uh2d_sum(I) + uh2d(I,k) enddo ; enddo @@ -269,13 +248,13 @@ subroutine distribute_residual_uh_barotropic(G, GV, hvol, uh) if (hvol(i,j,k)>0.) then h2d_sum(i) = h2d_sum(i) + h2d(i,k) else - h2d(i,k) = GV%H_subroundoff + h2d(i,k) = GV%H_subroundoff * G%areaT(i,j) endif enddo ; enddo ! Distribute flux. Note min/max is intended to make sure that the mass transport ! does not deplete a cell - do i=is-1,ie + do I=is-1,ie if ( uh2d_sum(I)>0.0 ) then do k=1,nz uh2d(I,k) = uh2d_sum(I)*(h2d(i,k)/h2d_sum(i)) @@ -289,15 +268,20 @@ subroutine distribute_residual_uh_barotropic(G, GV, hvol, uh) uh2d(I,k) = 0.0 enddo endif - ! Calculate and check that column integrated transports match the original to - ! within the tolerance limit - uh_neglect = GV%Angstrom_H*G%US%L_to_m**2 * min(G%areaT(i,j), G%areaT(i+1,j)) - if ( abs(sum(uh2d(I,:))-uh2d_sum(I)) > uh_neglect) & - call MOM_error(WARNING,"Column integral of uh does not match after "//& - "barotropic redistribution") + + ! Check that column integrated transports match the original to within roundoff. + uh_neglect = GV%Angstrom_H * min(G%areaT(i,j), G%areaT(i+1,j)) + abs_uh_sum = 0.0 ; new_uh_sum = 0.0 + do k=1,nz + abs_uh_sum = abs_uh_sum + abs(uh2d(j,k)) + new_uh_sum = new_uh_sum + uh2d(j,k) + enddo + if ( abs(new_uh_sum - uh2d_sum(j)) > max(uh_neglect, (5.0e-16*nz)*abs_uh_sum) ) & + call MOM_error(WARNING, "Column integral of uh does not match after "//& + "barotropic redistribution") enddo - do k=1,nz ; do i=is-1,ie + do k=1,nz ; do I=is-1,ie uh(I,j,k) = uh2d(I,k) enddo ; enddo enddo @@ -306,29 +290,32 @@ end subroutine distribute_residual_uh_barotropic !> Redistribute the v-flux as a barotropic equivalent subroutine distribute_residual_vh_barotropic(G, GV, hvol, vh) - type(ocean_grid_type), pointer :: G !< ocean grid structure - type(verticalGrid_type), pointer :: GV !< ocean vertical grid structure + type(ocean_grid_type), intent(in ) :: G !< ocean grid structure + type(verticalGrid_type), intent(in ) :: GV !< ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in ) :: hvol !< Mass of water in the cells at the end - !! of the previous timestep [kg] + !! of the previous timestep [H L2 ~> m3 or kg] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(inout) :: vh !< Meridional mass transport within a timestep [kg] + intent(inout) :: vh !< Meridional mass transport within a timestep [H L2 ~> m3 or kg] - real, dimension(SZJB_(G),SZK_(GV)) :: vh2d - real, dimension(SZJB_(G)) :: vh2d_sum - real, dimension(SZJ_(G),SZK_(GV)) :: h2d - real, dimension(SZJ_(G)) :: h2d_sum - - integer :: i, j, k, m, is, ie, js, je, nz - real :: vh_neglect + ! Local variables + real, dimension(SZJB_(G),SZK_(GV)) :: vh2d ! A 2-d slice of transports [H L2 ~> m3 or kg] + real, dimension(SZJB_(G)) :: vh2d_sum ! Vertically summed transports [H L2 ~> m3 or kg] + real, dimension(SZJ_(G),SZK_(GV)) :: h2d ! A 2-d slice of cell volumes [H L2 ~> m3 or kg] + real, dimension(SZJ_(G)) :: h2d_sum ! Vertically summed cell volumes [H L2 ~> m3 or kg] + + real :: abs_vh_sum ! The vertical sum of the absolute value of the transports [H L2 ~> m3 or kg] + real :: new_vh_sum ! The vertically summed transports after redistribution [H L2 ~> m3 or kg] + real :: vh_neglect ! A negligible transport [H L2 ~> m3 or kg] + integer :: i, j, k, is, ie, js, je, nz ! Set index-related variables for fields on T-grid - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke do i=is,ie vh2d_sum(:) = 0.0 ! Copy over uh to a working array and sum up the remaining fluxes in a column - do k=1,nz ; do j=js-1,je + do k=1,nz ; do J=js-1,je vh2d(J,k) = vh(i,J,k) vh2d_sum(J) = vh2d_sum(J) + vh2d(J,k) enddo ; enddo @@ -340,12 +327,12 @@ subroutine distribute_residual_vh_barotropic(G, GV, hvol, vh) if (hvol(i,j,k)>0.) then h2d_sum(j) = h2d_sum(j) + h2d(j,k) else - h2d(j,k) = GV%H_subroundoff + h2d(i,k) = GV%H_subroundoff * G%areaT(i,j) endif enddo ; enddo ! Distribute flux evenly throughout a column - do j=js-1,je + do J=js-1,je if ( vh2d_sum(J)>0.0 ) then do k=1,nz vh2d(J,k) = vh2d_sum(J)*(h2d(j,k)/h2d_sum(j)) @@ -359,17 +346,20 @@ subroutine distribute_residual_vh_barotropic(G, GV, hvol, vh) vh2d(J,k) = 0.0 enddo endif - ! Calculate and check that column integrated transports match the original to - ! within the tolerance limit - vh_neglect = GV%Angstrom_H*G%US%L_to_m**2 * min(G%areaT(i,j), G%areaT(i,j+1)) - if ( abs(sum(vh2d(J,:))-vh2d_sum(J)) > vh_neglect) then - call MOM_error(WARNING,"Column integral of vh does not match after "//& - "barotropic redistribution") - endif + ! Check that column integrated transports match the original to within roundoff. + vh_neglect = GV%Angstrom_H * min(G%areaT(i,j), G%areaT(i,j+1)) + abs_vh_sum = 0.0 ; new_vh_sum = 0.0 + do k=1,nz + abs_vh_sum = abs_vh_sum + abs(vh2d(J,k)) + new_vh_sum = new_vh_sum + vh2d(J,k) + enddo + if ( abs(new_vh_sum - vh2d_sum(J)) > max(vh_neglect, (5.0e-16*nz)*abs_vh_sum) ) & + call MOM_error(WARNING, "Column integral of vh does not match after "//& + "barotropic redistribution") enddo - do k=1,nz ; do j=js-1,je + do k=1,nz ; do J=js-1,je vh(i,J,k) = vh2d(J,k) enddo ; enddo enddo @@ -379,23 +369,25 @@ end subroutine distribute_residual_vh_barotropic !> In the case where offline advection has failed to converge, redistribute the u-flux !! into layers above subroutine distribute_residual_uh_upwards(G, GV, hvol, uh) - type(ocean_grid_type), pointer :: G !< ocean grid structure - type(verticalGrid_type), pointer :: GV !< ocean vertical grid structure + type(ocean_grid_type), intent(in ) :: G !< ocean grid structure + type(verticalGrid_type), intent(in ) :: GV !< ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in ) :: hvol !< Mass of water in the cells at the end - !! of the previous timestep [kg] + !! of the previous timestep [H L2 ~> m3 or kg] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: uh !< Zonal mass transport within a timestep [kg] + intent(inout) :: uh !< Zonal mass transport within a timestep [H L2 ~> m3 or kg] - real, dimension(SZIB_(G),SZK_(GV)) :: uh2d - real, dimension(SZI_(G),SZK_(GV)) :: h2d + ! Local variables + real, dimension(SZIB_(G),SZK_(GV)) :: uh2d ! A slice of transports [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZK_(GV)) :: h2d ! A slice of updated cell volumes [H L2 ~> m3 or kg] - real :: uh_neglect, uh_remain, uh_add, uh_sum, uh_col, uh_max - real :: hup, hdown, hlos, min_h - integer :: i, j, k, m, is, ie, js, je, nz, k_rev + real :: uh_neglect, uh_remain, uh_sum, uh_col ! Transports [H L2 ~> m3 or kg] + real :: hup, hlos ! Various cell volumes [H L2 ~> m3 or kg] + real :: min_h ! A minimal layer thickness [H ~> m or kg m-2] + integer :: i, j, k, is, ie, js, je, nz, k_rev ! Set index-related variables for fields on T-grid - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke min_h = GV%Angstrom_H*0.1 @@ -406,15 +398,15 @@ subroutine distribute_residual_uh_upwards(G, GV, hvol, uh) enddo ; enddo do k=1,nz ; do i=is-1,ie+1 ! Subtract just a little bit of thickness to avoid roundoff errors - h2d(i,k) = hvol(i,j,k)-min_h*G%US%L_to_m**2*G%areaT(i,j) + h2d(i,k) = hvol(i,j,k) - min_h * G%areaT(i,j) enddo ; enddo - do i=is-1,ie + do I=is-1,ie uh_col = SUM(uh2d(I,:)) ! Store original column-integrated transport do k=1,nz uh_remain = uh2d(I,k) uh2d(I,k) = 0.0 - if (abs(uh_remain)>0.0) then + if (abs(uh_remain) > 0.0) then do k_rev = k,1,-1 uh_sum = uh_remain + uh2d(I,k_rev) if (uh_sum<0.0) then ! Transport to the left @@ -445,7 +437,7 @@ subroutine distribute_residual_uh_upwards(G, GV, hvol, uh) enddo ! k_rev endif - if (abs(uh_remain)>0.0) then + if (abs(uh_remain) > 0.0) then if (kuh_neglect) then - call MOM_error(WARNING,"Column integral of uh does not match after "//& - "upwards redistribution") + uh_neglect = GV%Angstrom_H * min(G%areaT(i,j), G%areaT(i+1,j)) + if (abs(uh_col - sum(uh2d(I,:))) > uh_neglect) then + call MOM_error(WARNING,"Column integral of uh does not match after upwards redistribution") endif enddo ! i-loop - do k=1,nz ; do i=is-1,ie + do k=1,nz ; do I=is-1,ie uh(I,j,k) = uh2d(I,k) enddo ; enddo enddo @@ -475,43 +466,43 @@ end subroutine distribute_residual_uh_upwards !> In the case where offline advection has failed to converge, redistribute the u-flux !! into layers above subroutine distribute_residual_vh_upwards(G, GV, hvol, vh) - type(ocean_grid_type), pointer :: G !< ocean grid structure - type(verticalGrid_type), pointer :: GV !< ocean vertical grid structure + type(ocean_grid_type), intent(in ) :: G !< ocean grid structure + type(verticalGrid_type), intent(in ) :: GV !< ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in ) :: hvol !< Mass of water in the cells at the end - !! of the previous timestep [kg] + !! of the previous timestep [H L2 ~> m3 or kg] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(inout) :: vh !< Meridional mass transport within a timestep [kg] + intent(inout) :: vh !< Meridional mass transport within a timestep [H L2 ~> m3 or kg] - real, dimension(SZJB_(G),SZK_(GV)) :: vh2d - real, dimension(SZJB_(G)) :: vh2d_sum - real, dimension(SZJ_(G),SZK_(GV)) :: h2d - real, dimension(SZJ_(G)) :: h2d_sum + ! Local variables + real, dimension(SZJB_(G),SZK_(GV)) :: vh2d ! A slice of transports [H L2 ~> m3 or kg] + real, dimension(SZJ_(G),SZK_(GV)) :: h2d ! A slice of updated cell volumes [H L2 ~> m3 or kg] - real :: vh_neglect, vh_remain, vh_col, vh_sum - real :: hup, hlos, min_h - integer :: i, j, k, m, is, ie, js, je, nz, k_rev + real :: vh_neglect, vh_remain, vh_col, vh_sum ! Transports [H L2 ~> m3 or kg] + real :: hup, hlos ! Various cell volumes [H L2 ~> m3 or kg] + real :: min_h ! A minimal layer thickness [H ~> m or kg m-2] + integer :: i, j, k, is, ie, js, je, nz, k_rev ! Set index-related variables for fields on T-grid - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke min_h = 0.1*GV%Angstrom_H do i=is,ie ! Copy over uh and cell volume to working arrays - do k=1,nz ; do j=js-2,je+1 + do k=1,nz ; do J=js-2,je+1 vh2d(J,k) = vh(i,J,k) enddo ; enddo do k=1,nz ; do j=js-1,je+1 - h2d(j,k) = hvol(i,j,k)-min_h*G%US%L_to_m**2*G%areaT(i,j) + h2d(j,k) = hvol(i,j,k) - min_h * G%areaT(i,j) enddo ; enddo - do j=js-1,je + do J=js-1,je vh_col = SUM(vh2d(J,:)) do k=1,nz vh_remain = vh2d(J,k) vh2d(J,k) = 0.0 - if (abs(vh_remain)>0.0) then + if (abs(vh_remain) > 0.0) then do k_rev = k,1,-1 vh_sum = vh_remain + vh2d(J,k_rev) if (vh_sum<0.0) then ! Transport to the left @@ -543,7 +534,7 @@ subroutine distribute_residual_vh_upwards(G, GV, hvol, vh) enddo ! k_rev endif - if (abs(vh_remain)>0.0) then + if (abs(vh_remain) > 0.0) then if (k vh_neglect) then call MOM_error(WARNING,"Column integral of vh does not match after "//& "upwards redistribution") endif enddo - do k=1,nz ; do j=js-1,je + do k=1,nz ; do J=js-1,je vh(i,J,k) = vh2d(J,k) enddo ; enddo enddo @@ -577,12 +568,20 @@ subroutine offline_add_diurnal_SW(fluxes, G, Time_start, Time_end) type(time_type), intent(in) :: Time_start !< The start time for this step. type(time_type), intent(in) :: Time_end !< The ending time for this step. - real :: diurnal_factor, time_since_ae, rad - real :: fracday_dt, fracday_day - real :: cosz_day, cosz_dt, rrsun_day, rrsun_dt - type(time_type) :: dt_here - - integer :: i, j, k, i2, j2, isc, iec, jsc, jec, i_off, j_off + real :: diurnal_factor ! A scaling factor to insert a synthetic diurnal cycle [nondim] + real :: time_since_ae ! Time since the autumnal equinox expressed as a fraction of a year times 2 pi [nondim] + real :: rad ! A conversion factor from degrees to radians = pi/180 degrees [nondim] + real :: fracday_dt ! Daylight fraction averaged over a timestep [nondim] + real :: fracday_day ! Daylight fraction averaged over a day [nondim] + real :: cosz_day ! Cosine of the solar zenith angle averaged over a day [nondim] + real :: cosz_dt ! Cosine of the solar zenith angle averaged over a timestep [nondim] + real :: rrsun_day ! Earth-Sun distance (r) relative to the semi-major axis of + ! the orbital ellipse averaged over a day [nondim] + real :: rrsun_dt ! Earth-Sun distance (r) relative to the semi-major axis of + ! the orbital ellipse averaged over a timestep [nondim] + type(time_type) :: dt_here ! The time increment covered by this call + + integer :: i, j, i2, j2, isc, iec, jsc, jec, i_off, j_off isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec i_off = LBOUND(fluxes%sens,1) - G%isc ; j_off = LBOUND(fluxes%sens,2) - G%jsc @@ -593,10 +592,8 @@ subroutine offline_add_diurnal_SW(fluxes, G, Time_start, Time_end) dt_here = Time_end - Time_start rad = acos(-1.)/180. -!$OMP parallel do default(none) shared(isc,iec,jsc,jec,G,rad,Time_start,dt_here,time_since_ae, & -!$OMP fluxes,i_off,j_off) & -!$OMP private(i,j,i2,j2,k,cosz_dt,fracday_dt,rrsun_dt, & -!$OMP fracday_day,cosz_day,rrsun_day,diurnal_factor) + !$OMP parallel do default(shared) private(i,j,i2,j2,cosz_dt,fracday_dt,rrsun_dt, & + !$OMP fracday_day,cosz_day,rrsun_day,diurnal_factor) do j=jsc,jec ; do i=isc,iec ! Per Rick Hemler: ! Call diurnal_solar with dtime=dt_here to get cosz averaged over dt_here. @@ -622,31 +619,33 @@ end subroutine offline_add_diurnal_sw !> Controls the reading in 3d mass fluxes, diffusive fluxes, and other fields stored !! in a previous integration of the online model -subroutine update_offline_from_files(G, GV, nk_input, mean_file, sum_file, snap_file, surf_file, h_end, & - uhtr, vhtr, temp_mean, salt_mean, mld, Kd, fluxes, ridx_sum, ridx_snap, read_mld, read_sw, & - read_ts_uvh, do_ale_in) +subroutine update_offline_from_files(G, GV, US, nk_input, mean_file, sum_file, snap_file, & + surf_file, h_end, uhtr, vhtr, temp_mean, salt_mean, mld, Kd, fluxes, & + ridx_sum, ridx_snap, read_mld, read_sw, read_ts_uvh, do_ale_in) type(ocean_grid_type), intent(inout) :: G !< Horizontal grid type type(verticalGrid_type), intent(in ) :: GV !< Vertical grid type + type(unit_scale_type), intent(in ) :: US !< A dimensional unit scaling type integer, intent(in ) :: nk_input !< Number of levels in input file character(len=*), intent(in ) :: mean_file !< Name of file with averages fields character(len=*), intent(in ) :: sum_file !< Name of file with summed fields character(len=*), intent(in ) :: snap_file !< Name of file with snapshot fields character(len=*), intent(in ) :: surf_file !< Name of file with surface fields + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_end !< End of timestep layer thickness [H ~> m or kg m-2] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: uhtr !< Zonal mass fluxes [kg] + intent(inout) :: uhtr !< Zonal mass fluxes [H L2 ~> m3 or kg] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(inout) :: vhtr !< Meridional mass fluxes [kg] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: h_end !< End of timestep layer thickness + intent(inout) :: vhtr !< Meridional mass fluxes [H L2 ~> m3 or kg] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: temp_mean !< Averaged temperature + intent(inout) :: temp_mean !< Averaged temperature [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: salt_mean !< Averaged salinity + intent(inout) :: salt_mean !< Averaged salinity [S ~> ppt] real, dimension(SZI_(G),SZJ_(G)), & - intent(inout) :: mld !< Averaged mixed layer depth + intent(inout) :: mld !< Averaged mixed layer depth [Z ~> m] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(inout) :: Kd !< Diapycnal diffusivities at interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] type(forcing), intent(inout) :: fluxes !< Fields with surface fluxes integer, intent(in ) :: ridx_sum !< Read index for sum, mean, and surf files integer, intent(in ) :: ridx_snap !< Read index for snapshot file @@ -656,15 +655,22 @@ subroutine update_offline_from_files(G, GV, nk_input, mean_file, sum_file, snap_ logical, optional, intent(in ) :: do_ale_in !< True if using ALE algorithms logical :: do_ale + real :: convert_to_H ! A scale conversion factor from the thickness units in the + ! file to H [H m-1 ~> 1] or [H m2 kg-1 ~> 1] integer :: i, j, k, is, ie, js, je, nz - real :: Initer_vert do_ale = .false. - if (present(do_ale_in) ) do_ale = do_ale_in + if (present(do_ale_in)) do_ale = do_ale_in is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - ! Check if reading in UH, VH, and h_end + if (GV%Boussinesq) then + convert_to_H = GV%m_to_H + else + convert_to_H = GV%kg_m2_to_H + endif + + ! Check if reading in temperature, salinity, transports and ending thickness if (read_ts_uvh) then h_end(:,:,:) = 0.0 temp_mean(:,:,:) = 0.0 @@ -673,25 +679,27 @@ subroutine update_offline_from_files(G, GV, nk_input, mean_file, sum_file, snap_ vhtr(:,:,:) = 0.0 ! Time-summed fields call MOM_read_vector(sum_file, 'uhtr_sum', 'vhtr_sum', uhtr(:,:,1:nk_input), & - vhtr(:,:,1:nk_input), G%Domain, timelevel=ridx_sum) + vhtr(:,:,1:nk_input), G%Domain, timelevel=ridx_sum, & + scale=US%m_to_L**2*GV%kg_m2_to_H) call MOM_read_data(snap_file, 'h_end', h_end(:,:,1:nk_input), G%Domain, & - timelevel=ridx_snap,position=CENTER) + timelevel=ridx_snap, position=CENTER, scale=convert_to_H) call MOM_read_data(mean_file, 'temp', temp_mean(:,:,1:nk_input), G%Domain, & - timelevel=ridx_sum,position=CENTER) + timelevel=ridx_sum, position=CENTER, scale=US%degC_to_C) call MOM_read_data(mean_file, 'salt', salt_mean(:,:,1:nk_input), G%Domain, & - timelevel=ridx_sum,position=CENTER) - endif + timelevel=ridx_sum, position=CENTER, scale=US%ppt_to_S) - do j=js,je ; do i=is,ie - if (G%mask2dT(i,j)>0.) then - temp_mean(:,:,nk_input:nz) = temp_mean(i,j,nk_input) - salt_mean(:,:,nk_input:nz) = salt_mean(i,j,nk_input) - endif - enddo ; enddo + ! Fill temperature and salinity downward from the deepest input data. + do k=nk_input+1,nz ; do j=js,je ; do i=is,ie + if (G%mask2dT(i,j)>0.) then + temp_mean(i,j,k) = temp_mean(i,j,nk_input) + salt_mean(i,j,k) = salt_mean(i,j,nk_input) + endif + enddo ; enddo ; enddo + endif ! Check if reading vertical diffusivities or entrainment fluxes call MOM_read_data( mean_file, 'Kd_interface', Kd(:,:,1:nk_input+1), G%Domain, & - timelevel=ridx_sum,position=CENTER) + timelevel=ridx_sum, position=CENTER, scale=GV%m2_s_to_HZ_T) ! This block makes sure that the fluxes control structure, which may not be used in the solo_driver, ! contains netMassIn and netMassOut which is necessary for the applyTracerBoundaryFluxesInOut routine @@ -718,7 +726,7 @@ subroutine update_offline_from_files(G, GV, nk_input, mean_file, sum_file, snap_ endif if (read_mld) then - call MOM_read_data(surf_file, 'ePBL_h_ML', mld, G%Domain, timelevel=ridx_sum) + call MOM_read_data(surf_file, 'ePBL_h_ML', mld, G%Domain, timelevel=ridx_sum, scale=US%m_to_Z) endif if (read_sw) then @@ -727,9 +735,9 @@ subroutine update_offline_from_files(G, GV, nk_input, mean_file, sum_file, snap_ ! direct fluxes in the visible and near-infrared bands. For convenience, we store the ! sum of the direct and diffuse fluxes in the 'dir' field and set the 'dif' fields to zero call MOM_read_data(mean_file,'sw_vis', fluxes%sw_vis_dir, G%Domain, & - timelevel=ridx_sum, scale=G%US%W_m2_to_QRZ_T) + timelevel=ridx_sum, scale=US%W_m2_to_QRZ_T) call MOM_read_data(mean_file,'sw_nir', fluxes%sw_nir_dir, G%Domain, & - timelevel=ridx_sum, scale=G%US%W_m2_to_QRZ_T) + timelevel=ridx_sum, scale=US%W_m2_to_QRZ_T) fluxes%sw_vis_dir(:,:) = fluxes%sw_vis_dir(:,:)*0.5 fluxes%sw_vis_dif(:,:) = fluxes%sw_vis_dir(:,:) fluxes%sw_nir_dir(:,:) = fluxes%sw_nir_dir(:,:)*0.5 @@ -763,19 +771,21 @@ subroutine update_offline_from_arrays(G, GV, nk_input, ridx_sum, mean_file, sum_ character(len=200), intent(in ) :: mean_file !< Name of file with averages fields character(len=200), intent(in ) :: sum_file !< Name of file with summed fields character(len=200), intent(in ) :: snap_file !< Name of file with snapshot fields - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uhtr !< Zonal mass fluxes [kg] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vhtr !< Meridional mass fluxes [kg] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: hend !< End of timestep layer thickness [kg m-2] - real, dimension(:,:,:,:), allocatable, intent(inout) :: uhtr_all !< Zonal mass fluxes [kg] - real, dimension(:,:,:,:), allocatable, intent(inout) :: vhtr_all !< Meridional mass fluxes [kg] - real, dimension(:,:,:,:), allocatable, intent(inout) :: hend_all !< End of timestep layer thickness [kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: temp !< Temperature array - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: salt !< Salinity array - real, dimension(:,:,:,:), allocatable, intent(inout) :: temp_all !< Temperature array - real, dimension(:,:,:,:), allocatable, intent(inout) :: salt_all !< Salinity array + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uhtr !< Zonal mass fluxes [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vhtr !< Meridional mass fluxes [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: hend !< End of timestep layer thickness + !! [H ~> m or kg m-2] + real, dimension(:,:,:,:), allocatable, intent(inout) :: uhtr_all !< Zonal mass fluxes [H L2 ~> m3 or kg] + real, dimension(:,:,:,:), allocatable, intent(inout) :: vhtr_all !< Meridional mass fluxes [H L2 ~> m3 or kg] + real, dimension(:,:,:,:), allocatable, intent(inout) :: hend_all !< End of timestep layer thickness + !! [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: temp !< Temperature array [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: salt !< Salinity array [S ~> ppt] + real, dimension(:,:,:,:), allocatable, intent(inout) :: temp_all !< Temperature array [C ~> degC] + real, dimension(:,:,:,:), allocatable, intent(inout) :: salt_all !< Salinity array [S ~> ppt] integer :: i, j, k, is, ie, js, je, nz - real, parameter :: fill_value = 0. + real, parameter :: fill_value = 0. ! The fill value for input arrays [various] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke ! Check that all fields are allocated (this is a redundant check) diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index 0a61ee1ba2..e97eb61373 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -1,11 +1,16 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> The routines here implement the offline tracer algorithm used in MOM6. These are called from step_offline !! Some routines called here can be found in the MOM_offline_aux module. module MOM_offline_main -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_ALE, only : ALE_CS, ALE_main_offline, ALE_offline_inputs +use MOM_ALE, only : ALE_CS, ALE_regrid, ALE_offline_inputs +use MOM_ALE, only : pre_ALE_adjustments, ALE_update_regrid_weights +use MOM_ALE, only : ALE_remap_tracers use MOM_checksums, only : hchksum, uvchksum +use MOM_coms, only : reproducing_sum use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_SUBCOMPONENT use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE @@ -13,12 +18,13 @@ module MOM_offline_main use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member use MOM_diabatic_aux, only : tridiagTS use MOM_diag_mediator, only : diag_ctrl, post_data, register_diag_field -use MOM_domains, only : sum_across_PEs, pass_var, pass_vector +use MOM_domains, only : pass_var, pass_vector use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING use MOM_error_handler, only : callTree_enter, callTree_leave use MOM_file_parser, only : read_param, get_param, log_version, param_file_type use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : calc_derived_thermo, thickness_to_dz use MOM_io, only : MOM_read_data, MOM_read_vector, CENTER use MOM_offline_aux, only : update_offline_from_arrays, update_offline_from_files use MOM_offline_aux, only : next_modulo_time, offline_add_diurnal_sw @@ -34,12 +40,11 @@ module MOM_offline_main use MOM_tracer_registry, only : tracer_registry_type, MOM_tracer_chksum, MOM_tracer_chkinv use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type +use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units implicit none ; private #include "MOM_memory.h" -#include "version_variable.h" !> The control structure for the offline transport module type, public :: offline_transport_CS ; private @@ -63,12 +68,6 @@ module MOM_offline_main !< A pointer to the tracer registry type(thermo_var_ptrs), pointer :: tv => NULL() !< A structure pointing to various thermodynamic variables - type(ocean_grid_type), pointer :: G => NULL() - !< Pointer to a structure containing metrics and related information - type(verticalGrid_type), pointer :: GV => NULL() - !< Pointer to structure containing information about the vertical grid - type(unit_scale_type), pointer :: US => NULL() - !< structure containing various unit conversion factors type(optics_type), pointer :: optics => NULL() !< Pointer to the optical properties type type(diabatic_aux_CS), pointer :: diabatic_aux_CSp => NULL() @@ -125,7 +124,9 @@ module MOM_offline_main !! This is copied from diabatic_CS controlling how tracers follow freshwater fluxes real :: Kd_max !< Runtime parameter specifying the maximum value of vertical diffusivity - real :: min_residual !< The minimum amount of total mass flux before exiting the main advection routine + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: min_residual !< The minimum amount of total mass flux before exiting the main advection + !! routine [H L2 ~> m3 or kg] !>@{ Diagnostic manager IDs for some fields that may be of interest when doing offline transport integer :: & id_uhr = -1, & @@ -158,9 +159,9 @@ module MOM_offline_main integer :: id_clock_offline_adv = -1 !< A CPU time clock integer :: id_clock_redistribute = -1 !< A CPU time clock - !> Zonal transport that may need to be stored between calls to step_MOM + !> Zonal transport that may need to be stored between calls to step_MOM [H L2 ~> m3 or kg] real, allocatable, dimension(:,:,:) :: uhtr - !> Meridional transport that may need to be stored between calls to step_MOM + !> Meridional transport that may need to be stored between calls to step_MOM [H L2 ~> m3 or kg] real, allocatable, dimension(:,:,:) :: vhtr ! Fields at T-point @@ -171,19 +172,17 @@ module MOM_offline_main !< Amount of fluid entrained from the layer below within !! one time step [H ~> m or kg m-2] ! Fields at T-points on interfaces - real, allocatable, dimension(:,:,:) :: Kd !< Vertical diffusivity - real, allocatable, dimension(:,:,:) :: h_end !< Thicknesses at the end of offline timestep + real, allocatable, dimension(:,:,:) :: Kd !< Vertical diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, allocatable, dimension(:,:,:) :: h_end !< Thicknesses at the end of offline timestep [H ~> m or kg m-2] - real, allocatable, dimension(:,:) :: netMassIn !< Freshwater fluxes into the ocean - real, allocatable, dimension(:,:) :: netMassOut !< Freshwater fluxes out of the ocean - real, allocatable, dimension(:,:) :: mld !< Mixed layer depths at thickness points [Z ~> m]. + real, allocatable, dimension(:,:) :: mld !< Mixed layer depths at thickness points [Z ~> m] ! Allocatable arrays to read in entire fields during initialization - real, allocatable, dimension(:,:,:,:) :: uhtr_all !< Entire field of zonal transport - real, allocatable, dimension(:,:,:,:) :: vhtr_all !< Entire field of mericional transport - real, allocatable, dimension(:,:,:,:) :: hend_all !< Entire field of layer thicknesses - real, allocatable, dimension(:,:,:,:) :: temp_all !< Entire field of temperatures - real, allocatable, dimension(:,:,:,:) :: salt_all !< Entire field of salinities + real, allocatable, dimension(:,:,:,:) :: uhtr_all !< Entire field of zonal transport [H L2 ~> m3 or kg] + real, allocatable, dimension(:,:,:,:) :: vhtr_all !< Entire field of meridional transport [H L2 ~> m3 or kg] + real, allocatable, dimension(:,:,:,:) :: hend_all !< Entire field of layer thicknesses [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:,:) :: temp_all !< Entire field of temperatures [C ~> degC] + real, allocatable, dimension(:,:,:,:) :: salt_all !< Entire field of salinities [S ~> ppt] end type offline_transport_CS @@ -206,59 +205,53 @@ module MOM_offline_main !> 3D advection is done by doing flux-limited nonlinear horizontal advection interspersed with an ALE !! regridding/remapping step. The loop in this routine is exited if remaining residual transports are below !! a runtime-specified value or a maximum number of iterations is reached. -subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock_ale, h_pre, uhtr, vhtr, converged) - type(forcing), intent(inout) :: fluxes !< pointers to forcing fields - type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type - real, intent(in) :: time_interval !< time interval - type(offline_transport_CS), pointer :: CS !< control structure for offline module - integer, intent(in) :: id_clock_ALE !< Clock for ALE routines - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), & - intent(inout) :: h_pre !< layer thicknesses before advection - !! [H ~> m or kg m-2] - real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), & - intent(inout) :: uhtr !< Zonal mass transport [H m2 ~> m3 or kg] - real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%GV)), & - intent(inout) :: vhtr !< Meridional mass transport [H m2 ~> m3 or kg] - logical, intent( out) :: converged !< True if the iterations have converged - - ! Local pointers - type(ocean_grid_type), pointer :: G => NULL() ! Pointer to a structure containing - ! metrics and related information - type(verticalGrid_type), pointer :: GV => NULL() ! Pointer to structure containing information - ! about the vertical grid - ! Work arrays for mass transports - real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%GV)) :: uhtr_sub - ! Meridional mass transports - real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%GV)) :: vhtr_sub - - real :: prev_tot_residual, tot_residual ! Used to keep track of how close to convergence we are +subroutine offline_advection_ale(fluxes, Time_start, time_interval, G, GV, US, CS, id_clock_ale, & + h_pre, uhtr, vhtr, converged) + type(forcing), intent(inout) :: fluxes !< pointers to forcing fields + type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type + real, intent(in) :: time_interval !< time interval covered by this call [T ~> s] + 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 + type(offline_transport_CS), pointer :: CS !< control structure for offline module + integer, intent(in) :: id_clock_ALE !< Clock for ALE routines + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_pre !< layer thicknesses before advection + !! [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: uhtr !< Zonal mass transport [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: vhtr !< Meridional mass transport [H L2 ~> m3 or kg] + logical, intent( out) :: converged !< True if the iterations have converged + + ! Local variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uhtr_sub ! Substep zonal mass transports [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vhtr_sub ! Substep meridional mass transports [H L2 ~> m3 or kg] + + real :: prev_tot_residual, tot_residual ! Used to keep track of how close to convergence we are [H L2 ~> m3 or kg] ! Variables used to keep track of layer thicknesses at various points in the code - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)) :: & - h_new, & - h_vol - ! Fields for eta_diff diagnostic - real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: eta_pre, eta_end - integer :: niter, iter - real :: Inum_iter + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + h_new, & ! Updated layer thicknesses [H ~> m or kg m-2] + h_post_remap, & ! Layer thicknesses after remapping [H ~> m or kg m-2] + h_vol ! Layer volumes [H L2 ~> m3 or kg] + real :: dzRegrid(SZI_(G),SZJ_(G),SZK_(GV)+1) ! The change in grid interface positions due to regridding, + ! in the same units as thicknesses [H ~> m or kg m-2] + integer :: niter, iter + real :: Inum_iter ! The inverse of the number of iterations [nondim] character(len=256) :: mesg ! The text of an error message - integer :: i, j, k, m, is, ie, js, je, isd, ied, jsd, jed, nz - integer :: isv, iev, jsv, jev ! The valid range of the indices. + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB - logical :: z_first, x_before_y + logical :: x_before_y real :: evap_CFL_limit ! Limit on the fraction of the water that can be fluxed out of the ! top layer in a timestep [nondim] real :: minimum_forcing_depth ! The smallest depth over which fluxes can be applied [H ~> m or kg m-2] real :: dt_iter ! The timestep to use for each iteration [T ~> s] - - integer :: nstocks - real :: stock_values(MAX_FIELDS_) + real :: HL2_to_kg_scale ! Unit conversion factors to cell mass [kg H-1 L-2 ~> kg m-3 or 1] character(len=20) :: debug_msg call cpu_clock_begin(CS%id_clock_offline_adv) ! Grid-related pointer assignments - G => CS%G - GV => CS%GV x_before_y = CS%x_before_y @@ -270,6 +263,7 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock evap_CFL_limit = CS%evap_CFL_limit minimum_forcing_depth = CS%minimum_forcing_depth + HL2_to_kg_scale = US%L_to_m**2*GV%H_to_kg_m2 niter = CS%num_off_iter Inum_iter = 1./real(niter) dt_iter = CS%dt_offline*Inum_iter @@ -314,12 +308,12 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock enddo ; enddo ; enddo if (CS%debug) then - call hchksum(h_pre,"h_pre before transport",G%HI) - call uvchksum("[uv]htr_sub before transport", uhtr_sub, vhtr_sub, G%HI) + call hchksum(h_pre, "h_pre before transport", G%HI, unscale=GV%H_to_MKS) + call uvchksum("[uv]htr_sub before transport", uhtr_sub, vhtr_sub, G%HI, unscale=HL2_to_kg_scale) endif - tot_residual = remaining_transport_sum(CS, uhtr, vhtr) + tot_residual = remaining_transport_sum(G, GV, US, uhtr, vhtr, h_new) if (CS%print_adv_offline) then - write(mesg,'(A,ES24.16)') "Main advection starting transport: ", tot_residual + write(mesg,'(A,ES24.16)') "Main advection starting transport: ", tot_residual*HL2_to_kg_scale call MOM_mesg(mesg) endif @@ -328,45 +322,62 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock do iter=1,CS%num_off_iter do k=1,nz ; do j=js,je ; do i=is,ie - h_vol(i,j,k) = h_new(i,j,k) * G%US%L_to_m**2*G%areaT(i,j) + h_vol(i,j,k) = h_new(i,j,k) * G%areaT(i,j) h_pre(i,j,k) = h_new(i,j,k) enddo ; enddo ; enddo if (CS%debug) then - call hchksum(h_vol,"h_vol before advect",G%HI) - call uvchksum("[uv]htr_sub before advect", uhtr_sub, vhtr_sub, G%HI) + call hchksum(h_vol, "h_vol before advect", G%HI, unscale=HL2_to_kg_scale) + call uvchksum("[uv]htr_sub before advect", uhtr_sub, vhtr_sub, G%HI, unscale=HL2_to_kg_scale) write(debug_msg, '(A,I4.4)') 'Before advect ', iter - call MOM_tracer_chkinv(debug_msg, G, GV, h_pre, CS%tracer_reg%Tr, CS%tracer_reg%ntr) + call MOM_tracer_chkinv(debug_msg, G, GV, h_pre, CS%tracer_reg) endif - call advect_tracer(h_pre, uhtr_sub, vhtr_sub, CS%OBC, CS%dt_offline, G, GV, CS%US, & - CS%tracer_adv_CSp, CS%tracer_Reg, h_vol, max_iter_in=1, & - uhr_out=uhtr, vhr_out=vhtr, h_out=h_new, x_first_in=x_before_y) + call advect_tracer(h_pre, uhtr_sub, vhtr_sub, CS%OBC, CS%dt_offline, G, GV, US, & + CS%tracer_adv_CSp, CS%tracer_Reg, x_first_in=x_before_y, vol_prev=h_vol, & + max_iter_in=1, update_vol_prev=.true., uhr_out=uhtr, vhr_out=vhtr) ! Switch the direction every iteration x_before_y = .not. x_before_y ! Update the new layer thicknesses after one round of advection has happened do k=1,nz ; do j=js,je ; do i=is,ie - h_new(i,j,k) = h_new(i,j,k) / (G%US%L_to_m**2*G%areaT(i,j)) + h_new(i,j,k) = h_vol(i,j,k) * G%IareaT(i,j) enddo ; enddo ; enddo if (MODULO(iter,CS%off_ale_mod)==0) then ! Do ALE remapping/regridding to allow for more advection to occur in the next iteration call pass_var(h_new,G%Domain) if (CS%debug) then - call hchksum(h_new,"h_new before ALE",G%HI) + call hchksum(h_new,"h_new before ALE", G%HI, unscale=GV%H_to_MKS) write(debug_msg, '(A,I4.4)') 'Before ALE ', iter - call MOM_tracer_chkinv(debug_msg, G, GV, h_new, CS%tracer_reg%Tr, CS%tracer_reg%ntr) + call MOM_tracer_chkinv(debug_msg, G, GV, h_new, CS%tracer_reg) endif call cpu_clock_begin(id_clock_ALE) - call ALE_main_offline(G, GV, h_new, CS%tv, CS%tracer_Reg, CS%ALE_CSp, CS%OBC, CS%dt_offline) + + call ALE_update_regrid_weights(CS%dt_offline, CS%ALE_CSp) + call pre_ALE_adjustments(G, GV, US, h_new, CS%tv, CS%tracer_Reg, CS%ALE_CSp) + ! Uncomment this to adjust the target grids for diagnostics, if there have been thickness + ! adjustments, but the offline tracer code does not yet have the other corresponding calls + ! that would be needed to support remapping its output. + ! call diag_update_remap_grids(CS%diag, alt_h=h_new) + + call ALE_regrid(G, GV, US, h_new, h_post_remap, dzRegrid, CS%tv, CS%ALE_CSp) + + ! Remap all variables from the old grid h_new onto the new grid h_post_remap + call ALE_remap_tracers(CS%ALE_CSp, G, GV, h_new, h_post_remap, CS%tracer_Reg, & + CS%debug, dt=CS%dt_offline) + if (allocated(CS%tv%SpV_avg)) CS%tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. + + do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + h_new(i,j,k) = h_post_remap(i,j,k) + enddo ; enddo ; enddo call cpu_clock_end(id_clock_ALE) if (CS%debug) then - call hchksum(h_new,"h_new after ALE",G%HI) + call hchksum(h_new, "h_new after ALE", G%HI, unscale=GV%H_to_MKS) write(debug_msg, '(A,I4.4)') 'After ALE ', iter - call MOM_tracer_chkinv(debug_msg, G, GV, h_new, CS%tracer_reg%Tr, CS%tracer_reg%ntr) + call MOM_tracer_chkinv(debug_msg, G, GV, h_new, CS%tracer_reg) endif endif @@ -375,13 +386,13 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock vhtr_sub(i,J,k) = vhtr(i,J,k) enddo ; enddo ; enddo call pass_var(h_new, G%Domain) - call pass_vector(uhtr_sub,vhtr_sub,G%Domain) + call pass_vector(uhtr_sub, vhtr_sub, G%Domain) ! Check for whether we've used up all the advection, or if we need to move on because ! advection has stalled - tot_residual = remaining_transport_sum(CS, uhtr, vhtr) + tot_residual = remaining_transport_sum(G, GV, US, uhtr, vhtr, h_new) if (CS%print_adv_offline) then - write(mesg,'(A,ES24.16)') "Main advection remaining transport: ", tot_residual + write(mesg,'(A,ES24.16)') "Main advection remaining transport: ", tot_residual*HL2_to_kg_scale call MOM_mesg(mesg) endif ! If all the mass transports have been used u, then quit @@ -403,12 +414,12 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock ! Make sure that uhtr and vhtr halos are updated h_pre(:,:,:) = h_new(:,:,:) - call pass_vector(uhtr,vhtr,G%Domain) + call pass_vector(uhtr, vhtr, G%Domain) if (CS%debug) then - call hchksum(h_pre,"h after offline_advection_ale",G%HI) - call uvchksum("[uv]htr after offline_advection_ale", uhtr, vhtr, G%HI) - call MOM_tracer_chkinv("After offline_advection_ale", G, GV, h_pre, CS%tracer_reg%Tr, CS%tracer_reg%ntr) + call hchksum(h_pre, "h after offline_advection_ale", G%HI, unscale=GV%H_to_MKS) + call uvchksum("[uv]htr after offline_advection_ale", uhtr, vhtr, G%HI, unscale=HL2_to_kg_scale) + call MOM_tracer_chkinv("After offline_advection_ale", G, GV, h_pre, CS%tracer_reg) endif call cpu_clock_end(CS%id_clock_offline_adv) @@ -419,53 +430,49 @@ end subroutine offline_advection_ale !! transport. Two different ways are offered, 'barotropic' means that the residual is distributed equally !! throughout the water column. 'upwards' attempts to redistribute the transport in the layers above and will !! eventually work down the entire water column -subroutine offline_redistribute_residual(CS, h_pre, uhtr, vhtr, converged) +subroutine offline_redistribute_residual(CS, G, GV, US, h_pre, uhtr, vhtr, converged) type(offline_transport_CS), pointer :: CS !< control structure from initialize_MOM - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), & - intent(inout) :: h_pre !< layer thicknesses before advection - real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), & - intent(inout) :: uhtr !< Zonal mass transport - real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%GV)), & - intent(inout) :: vhtr !< Meridional mass transport + 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(inout) :: h_pre !< layer thicknesses before advection [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: uhtr !< Zonal mass transport [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: vhtr !< Meridional mass transport [H L2 ~> m3 or kg] logical, intent(in ) :: converged !< True if the iterations have converged - type(ocean_grid_type), pointer :: G => NULL() ! Pointer to a structure containing - ! metrics and related information - type(verticalGrid_type), pointer :: GV => NULL() ! Pointer to structure containing information - ! about the vertical grid logical :: x_before_y ! Variables used to keep track of layer thicknesses at various points in the code - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)) :: & - h_new, & - h_vol + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + h_new, & ! New layer thicknesses [H ~> m or kg m-2] + h_vol ! Cell volume [H L2 ~> m3 or kg] ! Used to calculate the eta diagnostics - real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: eta_work - real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%GV)) :: uhr !< Zonal mass transport - real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%GV)) :: vhr !< Meridional mass transport + real, dimension(SZI_(G),SZJ_(G)) :: eta_work ! The total column thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uhr !< Remaining zonal mass transport [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vhr !< Remaining meridional mass transport [H L2 ~> m3 or kg] character(len=256) :: mesg ! The text of an error message - integer :: i, j, k, m, is, ie, js, je, isd, ied, jsd, jed, nz, iter - real :: prev_tot_residual, tot_residual, stock_values(MAX_FIELDS_) - integer :: nstocks - - ! Assign grid pointers - G => CS%G - GV => CS%GV + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, iter + real :: HL2_to_kg_scale ! Unit conversion factors to cell mass [kg H-1 L-2 ~> kg m-3 or 1] + real :: prev_tot_residual, tot_residual ! The absolute value of the remaining transports [H L2 ~> m3 or kg] 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 x_before_y = CS%x_before_y + HL2_to_kg_scale = US%L_to_m**2*GV%H_to_kg_m2 if (CS%id_eta_pre_distribute>0) then eta_work(:,:) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - if (h_pre(i,j,k)>GV%Angstrom_H) then + if (h_pre(i,j,k) > GV%Angstrom_H) then eta_work(i,j) = eta_work(i,j) + h_pre(i,j,k) endif enddo ; enddo ; enddo - call post_data(CS%id_eta_pre_distribute,eta_work,CS%diag) + call post_data(CS%id_eta_pre_distribute, eta_work, CS%diag) endif ! These are used to find out how much will be redistributed in this routine @@ -476,7 +483,7 @@ subroutine offline_redistribute_residual(CS, h_pre, uhtr, vhtr, converged) if (converged) return if (CS%debug) then - call MOM_tracer_chkinv("Before redistribute ", G, GV, h_pre, CS%tracer_reg%Tr, CS%tracer_reg%ntr) + call MOM_tracer_chkinv("Before redistribute ", G, GV, h_pre, CS%tracer_reg) endif call cpu_clock_begin(CS%id_clock_redistribute) @@ -489,17 +496,14 @@ subroutine offline_redistribute_residual(CS, h_pre, uhtr, vhtr, converged) ! Calculate the layer volumes at beginning of redistribute do k=1,nz ; do j=js,je ; do i=is,ie - h_vol(i,j,k) = h_pre(i,j,k)*G%US%L_to_m**2*G%areaT(i,j) + h_vol(i,j,k) = h_pre(i,j,k) * G%areaT(i,j) enddo ; enddo ; enddo call pass_var(h_vol,G%Domain) - call pass_vector(uhtr,vhtr,G%Domain) - - ! Store volumes for advect_tracer - h_pre(:,:,:) = h_vol(:,:,:) + call pass_vector(uhtr, vhtr, G%Domain) if (CS%debug) then - call MOM_tracer_chksum("Before upwards redistribute ", CS%tracer_Reg%Tr, CS%tracer_Reg%ntr, G) - call uvchksum("[uv]tr before upwards redistribute", uhtr, vhtr, G%HI) + call MOM_tracer_chksum("Before upwards redistribute ", CS%tracer_Reg, G) + call uvchksum("[uv]tr before upwards redistribute", uhtr, vhtr, G%HI, unscale=HL2_to_kg_scale) endif if (x_before_y) then @@ -510,20 +514,19 @@ subroutine offline_redistribute_residual(CS, h_pre, uhtr, vhtr, converged) call distribute_residual_uh_upwards(G, GV, h_vol, uhtr) endif - call advect_tracer(h_pre, uhtr, vhtr, CS%OBC, CS%dt_offline, G, GV, CS%US, & - CS%tracer_adv_CSp, CS%tracer_Reg, h_prev_opt = h_pre, max_iter_in=1, & - h_out=h_new, uhr_out=uhr, vhr_out=vhr, x_first_in=x_before_y) + call advect_tracer(h_pre, uhtr, vhtr, CS%OBC, CS%dt_offline, G, GV, US, & + CS%tracer_adv_CSp, CS%tracer_Reg, x_first_in=x_before_y, vol_prev=h_vol, & + max_iter_in=1, update_vol_prev=.true., uhr_out=uhr, vhr_out=vhr) if (CS%debug) then - call MOM_tracer_chksum("After upwards redistribute ", CS%tracer_Reg%Tr, CS%tracer_Reg%ntr, G) + call MOM_tracer_chksum("After upwards redistribute ", CS%tracer_Reg, G) endif ! Convert h_new back to layer thickness for ALE remapping do k=1,nz ; do j=js,je ; do i=is,ie uhtr(I,j,k) = uhr(I,j,k) vhtr(i,J,k) = vhr(i,J,k) - h_vol(i,j,k) = h_new(i,j,k) - h_new(i,j,k) = h_new(i,j,k) / (G%US%L_to_m**2*G%areaT(i,j)) + h_new(i,j,k) = h_vol(i,j,k) * G%IareaT(i,j) h_pre(i,j,k) = h_new(i,j,k) enddo ; enddo ; enddo @@ -534,17 +537,14 @@ subroutine offline_redistribute_residual(CS, h_pre, uhtr, vhtr, converged) ! Calculate the layer volumes at beginning of redistribute do k=1,nz ; do j=js,je ; do i=is,ie - h_vol(i,j,k) = h_pre(i,j,k)*G%US%L_to_m**2*G%areaT(i,j) + h_vol(i,j,k) = h_pre(i,j,k) * G%areaT(i,j) enddo ; enddo ; enddo - call pass_var(h_vol,G%Domain) - call pass_vector(uhtr,vhtr,G%Domain) - - ! Copy h_vol to h_pre for advect_tracer routine - h_pre(:,:,:) = h_vol(:,:,:) + call pass_var(h_vol, G%Domain) + call pass_vector(uhtr, vhtr, G%Domain) if (CS%debug) then - call MOM_tracer_chksum("Before barotropic redistribute ", CS%tracer_Reg%Tr, CS%tracer_Reg%ntr, G) - call uvchksum("[uv]tr before upwards redistribute", uhtr, vhtr, G%HI) + call MOM_tracer_chksum("Before barotropic redistribute ", CS%tracer_Reg, G) + call uvchksum("[uv]tr before upwards redistribute", uhtr, vhtr, G%HI, unscale=HL2_to_kg_scale) endif if (x_before_y) then @@ -555,29 +555,28 @@ subroutine offline_redistribute_residual(CS, h_pre, uhtr, vhtr, converged) call distribute_residual_uh_barotropic(G, GV, h_vol, uhtr) endif - call advect_tracer(h_pre, uhtr, vhtr, CS%OBC, CS%dt_offline, G, GV, CS%US, & - CS%tracer_adv_CSp, CS%tracer_Reg, h_prev_opt = h_pre, max_iter_in=1, & - h_out=h_new, uhr_out=uhr, vhr_out=vhr, x_first_in=x_before_y) + call advect_tracer(h_pre, uhtr, vhtr, CS%OBC, CS%dt_offline, G, GV, US, & + CS%tracer_adv_CSp, CS%tracer_Reg, x_first_in=x_before_y, vol_prev=h_vol, & + max_iter_in=1, update_vol_prev=.true., uhr_out=uhr, vhr_out=vhr) if (CS%debug) then - call MOM_tracer_chksum("After barotropic redistribute ", CS%tracer_Reg%Tr, CS%tracer_Reg%ntr, G) + call MOM_tracer_chksum("After barotropic redistribute ", CS%tracer_Reg, G) endif ! Convert h_new back to layer thickness for ALE remapping do k=1,nz ; do j=js,je ; do i=is,ie uhtr(I,j,k) = uhr(I,j,k) vhtr(i,J,k) = vhr(i,J,k) - h_vol(i,j,k) = h_new(i,j,k) - h_new(i,j,k) = h_new(i,j,k) / (G%US%L_to_m**2*G%areaT(i,j)) + h_new(i,j,k) = h_vol(i,j,k) * G%IareaT(i,j) h_pre(i,j,k) = h_new(i,j,k) enddo ; enddo ; enddo endif ! redistribute barotropic ! Check to see if all transport has been exhausted - tot_residual = remaining_transport_sum(CS, uhtr, vhtr) + tot_residual = remaining_transport_sum(G, GV, US, uhtr, vhtr, h_new) if (CS%print_adv_offline) then - write(mesg,'(A,ES24.16)') "Residual advection remaining transport: ", tot_residual + write(mesg,'(A,ES24.16)') "Residual advection remaining transport: ", tot_residual*HL2_to_kg_scale call MOM_mesg(mesg) endif ! If the remaining residual is 0, then this return is done @@ -598,94 +597,101 @@ subroutine offline_redistribute_residual(CS, h_pre, uhtr, vhtr, converged) eta_work(i,j) = eta_work(i,j) + h_pre(i,j,k) endif enddo ; enddo ; enddo - call post_data(CS%id_eta_post_distribute,eta_work,CS%diag) + call post_data(CS%id_eta_post_distribute, eta_work, CS%diag) endif - if (CS%id_uhr>0) call post_data(CS%id_uhr,uhtr,CS%diag) - if (CS%id_vhr>0) call post_data(CS%id_vhr,vhtr,CS%diag) + if (CS%id_uhr>0) call post_data(CS%id_uhr, uhtr, CS%diag) + if (CS%id_vhr>0) call post_data(CS%id_vhr, vhtr, CS%diag) if (CS%debug) then - call hchksum(h_pre,"h_pre after redistribute",G%HI) - call uvchksum("uhtr after redistribute", uhtr, vhtr, G%HI) - call MOM_tracer_chkinv("after redistribute ", G, GV, h_new, CS%tracer_Reg%Tr, CS%tracer_Reg%ntr) + call hchksum(h_pre, "h_pre after redistribute", G%HI, unscale=GV%H_to_MKS) + call uvchksum("uhtr after redistribute", uhtr, vhtr, G%HI, unscale=HL2_to_kg_scale) + call MOM_tracer_chkinv("after redistribute ", G, GV, h_new, CS%tracer_Reg) endif call cpu_clock_end(CS%id_clock_redistribute) end subroutine offline_redistribute_residual -!> Sums any non-negligible remaining transport to check for advection convergence -real function remaining_transport_sum(CS, uhtr, vhtr) - type(offline_transport_CS), pointer :: CS !< control structure for offline module - real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), intent(in ) :: uhtr !< Zonal mass transport - real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%GV)), intent(in ) :: vhtr !< Meridional mass transport +!> Returns the sums of any non-negligible remaining transport [H L2 ~> m3 or kg] to check for advection convergence +real function remaining_transport_sum(G, GV, US, uhtr, vhtr, h_new) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in ) :: uhtr !< Zonal mass transport [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in ) :: vhtr !< Meridional mass transport [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in ) :: h_new !< Layer thicknesses [H ~> m or kg m-2] ! Local variables - integer :: i, j, k - integer :: is, ie, js, je, nz - real :: h_min !< A layer thickness below roundoff from GV type - real :: uh_neglect !< A small value of zonal transport that effectively is below roundoff error - real :: vh_neglect !< A small value of meridional transport that effectively is below roundoff error - - nz = CS%GV%ke - is = CS%G%isc ; ie = CS%G%iec ; js = CS%G%jsc ; je = CS%G%jec + real, dimension(SZI_(G),SZJ_(G)) :: trans_rem_col !< The vertical sum of the absolute value of + !! transports through the faces of a column [R Z L2 ~> kg]. + real :: trans_cell !< The sum of the absolute value of the remaining transports through the faces + !! of a tracer cell [H L2 ~> m3 or kg] + integer :: i, j, k, is, ie, js, je, nz - h_min = CS%GV%H_subroundoff + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - remaining_transport_sum = 0. + trans_rem_col(:,:) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - uh_neglect = h_min*CS%G%US%L_to_m**2*MIN(CS%G%areaT(i,j),CS%G%areaT(i+1,j)) - vh_neglect = h_min*CS%G%US%L_to_m**2*MIN(CS%G%areaT(i,j),CS%G%areaT(i,j+1)) - if (ABS(uhtr(I,j,k))>uh_neglect) then - remaining_transport_sum = remaining_transport_sum + ABS(uhtr(I,j,k)) - endif - if (ABS(vhtr(i,J,k))>vh_neglect) then - remaining_transport_sum = remaining_transport_sum + ABS(vhtr(i,J,k)) - endif + trans_cell = (ABS(uhtr(I-1,j,k)) + ABS(uhtr(I,j,k))) + & + (ABS(vhtr(i,J-1,k)) + ABS(vhtr(i,J,k))) + if (trans_cell > max(1.0e-16*h_new(i,j,k), GV%H_subroundoff) * G%areaT(i,j)) & + trans_rem_col(i,j) = trans_rem_col(i,j) + GV%H_to_RZ * trans_cell enddo ; enddo ; enddo - call sum_across_PEs(remaining_transport_sum) + + ! The factor of 0.5 here is to avoid double-counting because two cells share a face. + remaining_transport_sum = 0.5 * GV%RZ_to_H * reproducing_sum(trans_rem_col, & + is+(1-G%isd), ie+(1-G%isd), js+(1-G%jsd), je+(1-G%jsd), unscale=US%RZL2_to_kg) end function remaining_transport_sum !> The vertical/diabatic driver for offline tracers. First the eatr/ebtr associated with the interpolated !! vertical diffusivities are calculated and then any tracer column functions are done which can include !! vertical diffuvities and source/sink terms. -subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, CS, h_pre, eatr, ebtr) - - type(forcing), intent(inout) :: fluxes !< pointers to forcing fields - type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type - type(time_type), intent(in) :: Time_end !< time interval - type(offline_transport_CS), pointer :: CS !< control structure from initialize_MOM - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), & - intent(inout) :: h_pre !< layer thicknesses before advection [H ~> m or kg m-2] - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), & - intent(inout) :: eatr !< Entrainment from layer above [H ~> m or kg m-2] - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), & - intent(inout) :: ebtr !< Entrainment from layer below [H ~> m or kg m-2] - - real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: & +subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, G, GV, US, CS, h_pre, tv, eatr, ebtr) + + type(forcing), intent(inout) :: fluxes !< pointers to forcing fields + type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type + type(time_type), intent(in) :: Time_end !< ending time of a segment, as a time type + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(offline_transport_CS), pointer :: CS !< control structure from initialize_MOM + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_pre !< layer thicknesses before advection [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in ) :: tv !< A structure pointing to various thermodynamic variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: eatr !< Entrainment from layer above [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: ebtr !< Entrainment from layer below [H ~> m or kg m-2] + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: & sw, sw_vis, sw_nir !< Save old values of shortwave radiation [Q R Z T-1 ~> W m-2] - real :: hval - integer :: i,j,k - integer :: is, ie, js, je, nz + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Vertical distance across layers [Z ~> m] + real :: I_dZval ! An inverse distance between layer centers [Z-1 ~> m-1] + integer :: i, j, k, is, ie, js, je, nz integer :: k_nonzero - real :: stock_values(MAX_FIELDS_) - real :: Kd_bot - integer :: nstocks - nz = CS%GV%ke - is = CS%G%isc ; ie = CS%G%iec ; js = CS%G%jsc ; je = CS%G%jec + real :: Kd_bot ! Near-bottom diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + nz = GV%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec call cpu_clock_begin(CS%id_clock_offline_diabatic) call MOM_mesg("Applying tracer source, sinks, and vertical mixing") if (CS%debug) then - call hchksum(h_pre,"h_pre before offline_diabatic_ale",CS%G%HI) - call hchksum(eatr,"eatr before offline_diabatic_ale",CS%G%HI) - call hchksum(ebtr,"ebtr before offline_diabatic_ale",CS%G%HI) - call MOM_tracer_chkinv("Before offline_diabatic_ale", CS%G, CS%GV, h_pre, CS%tracer_reg%Tr, CS%tracer_reg%ntr) + call hchksum(h_pre, "h_pre before offline_diabatic_ale", G%HI, unscale=GV%H_to_MKS) + call hchksum(eatr, "eatr before offline_diabatic_ale", G%HI, unscale=GV%H_to_MKS) + call hchksum(ebtr, "ebtr before offline_diabatic_ale", G%HI, unscale=GV%H_to_MKS) + call MOM_tracer_chkinv("Before offline_diabatic_ale", G, GV, h_pre, CS%tracer_reg) endif + call thickness_to_dz(h_pre, tv, dz, G, GV, US) + eatr(:,:,:) = 0. ebtr(:,:,:) = 0. ! Calculate eatr and ebtr if vertical diffusivity is read @@ -712,8 +718,8 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, CS, h_pre, eatr, e eatr(i,j,1) = 0. enddo ; enddo do k=2,nz ; do j=js,je ; do i=is,ie - hval=1.0/(CS%GV%H_subroundoff + 0.5*(h_pre(i,j,k-1) + h_pre(i,j,k))) - eatr(i,j,k) = (CS%GV%m_to_H**2*CS%US%T_to_s) * CS%dt_offline_vertical * hval * CS%Kd(i,j,k) + I_dZval = 1.0 / (GV%dZ_subroundoff + 0.5*(dz(i,j,k-1) + dz(i,j,k))) + eatr(i,j,k) = CS%dt_offline_vertical * I_dZval * CS%Kd(i,j,k) ebtr(i,j,k-1) = eatr(i,j,k) enddo ; enddo ; enddo do j=js,je ; do i=is,ie @@ -725,17 +731,17 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, CS, h_pre, eatr, e sw(:,:) = fluxes%sw(:,:) sw_vis(:,:) = fluxes%sw_vis_dir(:,:) sw_nir(:,:) = fluxes%sw_nir_dir(:,:) - call offline_add_diurnal_SW(fluxes, CS%G, Time_start, Time_end) + call offline_add_diurnal_SW(fluxes, G, Time_start, Time_end) endif if (associated(CS%optics)) & - call set_pen_shortwave(CS%optics, fluxes, CS%G, CS%GV, CS%US, CS%diabatic_aux_CSp, & + call set_pen_shortwave(CS%optics, fluxes, G, GV, US, CS%diabatic_aux_CSp, & CS%opacity_CSp, CS%tracer_flow_CSp) ! Note that tracerBoundaryFluxesInOut within this subroutine should NOT be called ! as the freshwater fluxes have already been accounted for call call_tracer_column_fns(h_pre, h_pre, eatr, ebtr, fluxes, CS%MLD, CS%dt_offline_vertical, & - CS%G, CS%GV, CS%US, CS%tv, CS%optics, CS%tracer_flow_CSp, CS%debug) + G, GV, US, CS%tv, CS%optics, CS%tracer_flow_CSp, CS%debug) if (CS%diurnal_SW .and. CS%read_sw) then fluxes%sw(:,:) = sw(:,:) @@ -744,10 +750,10 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, CS, h_pre, eatr, e endif if (CS%debug) then - call hchksum(h_pre,"h_pre after offline_diabatic_ale",CS%G%HI) - call hchksum(eatr,"eatr after offline_diabatic_ale",CS%G%HI) - call hchksum(ebtr,"ebtr after offline_diabatic_ale",CS%G%HI) - call MOM_tracer_chkinv("After offline_diabatic_ale", CS%G, CS%GV, h_pre, CS%tracer_reg%Tr, CS%tracer_reg%ntr) + call hchksum(h_pre, "h_pre after offline_diabatic_ale", G%HI, unscale=GV%H_to_MKS) + call hchksum(eatr, "eatr after offline_diabatic_ale", G%HI, unscale=GV%H_to_MKS) + call hchksum(ebtr, "ebtr after offline_diabatic_ale", G%HI, unscale=GV%H_to_MKS) + call MOM_tracer_chkinv("After offline_diabatic_ale", G, GV, h_pre, CS%tracer_reg) endif call cpu_clock_end(CS%id_clock_offline_diabatic) @@ -766,9 +772,10 @@ subroutine offline_fw_fluxes_into_ocean(G, GV, CS, fluxes, h, in_flux_optional) real, dimension(SZI_(G),SZJ_(G)), & optional, intent(in) :: in_flux_optional !< The total time-integrated amount !! of tracer that leaves with freshwater + !! [CU H ~> Conc m or Conc kg m-2] integer :: i, j, m - real, dimension(SZI_(G),SZJ_(G)) :: negative_fw !< store all negative fluxes + real, dimension(SZI_(G),SZJ_(G)) :: negative_fw !< store all negative fluxes [H ~> m or kg m-2] logical :: update_h !< Flag for whether h should be updated if ( present(in_flux_optional) ) & @@ -786,18 +793,18 @@ subroutine offline_fw_fluxes_into_ocean(G, GV, CS, fluxes, h, in_flux_optional) enddo ; enddo if (CS%debug) then - call hchksum(h, "h before fluxes into ocean", G%HI) - call MOM_tracer_chkinv("Before fluxes into ocean", G, GV, h, CS%tracer_reg%Tr, CS%tracer_reg%ntr) + call hchksum(h, "h before fluxes into ocean", G%HI, unscale=GV%H_to_MKS) + call MOM_tracer_chkinv("Before fluxes into ocean", G, GV, h, CS%tracer_reg) endif do m = 1,CS%tracer_reg%ntr ! Layer thicknesses should only be updated after the last tracer is finished update_h = ( m == CS%tracer_reg%ntr ) call applyTracerBoundaryFluxesInOut(G, GV, CS%tracer_reg%tr(m)%t, CS%dt_offline, fluxes, h, & - CS%evap_CFL_limit, CS%minimum_forcing_depth, update_h_opt = update_h) + CS%evap_CFL_limit, CS%minimum_forcing_depth, update_h_opt=update_h) enddo if (CS%debug) then - call hchksum(h, "h after fluxes into ocean", G%HI) - call MOM_tracer_chkinv("After fluxes into ocean", G, GV, h, CS%tracer_reg%Tr, CS%tracer_reg%ntr) + call hchksum(h, "h after fluxes into ocean", G%HI, unscale=GV%H_to_MKS) + call MOM_tracer_chkinv("After fluxes into ocean", G, GV, h, CS%tracer_reg) endif ! Now that fluxes into the ocean are done, save the negative fluxes for later @@ -816,6 +823,7 @@ subroutine offline_fw_fluxes_out_ocean(G, GV, CS, fluxes, h, out_flux_optional) real, dimension(SZI_(G),SZJ_(G)), & optional, intent(in) :: out_flux_optional !< The total time-integrated amount !! of tracer that leaves with freshwater + !! [CU H ~> Conc m or Conc kg m-2] integer :: m logical :: update_h !< Flag for whether h should be updated @@ -824,8 +832,8 @@ subroutine offline_fw_fluxes_out_ocean(G, GV, CS, fluxes, h, out_flux_optional) call MOM_error(WARNING, "Negative freshwater fluxes with non-zero tracer concentration not supported yet") if (CS%debug) then - call hchksum(h,"h before fluxes out of ocean",G%HI) - call MOM_tracer_chkinv("Before fluxes out of ocean", G, GV, h, CS%tracer_reg%Tr, CS%tracer_reg%ntr) + call hchksum(h, "h before fluxes out of ocean", G%HI, unscale=GV%H_to_MKS) + call MOM_tracer_chkinv("Before fluxes out of ocean", G, GV, h, CS%tracer_reg) endif do m = 1, CS%tracer_reg%ntr ! Layer thicknesses should only be updated after the last tracer is finished @@ -834,85 +842,80 @@ subroutine offline_fw_fluxes_out_ocean(G, GV, CS, fluxes, h, out_flux_optional) CS%evap_CFL_limit, CS%minimum_forcing_depth, update_h_opt = update_h) enddo if (CS%debug) then - call hchksum(h,"h after fluxes out of ocean",G%HI) - call MOM_tracer_chkinv("Before fluxes out of ocean", G, GV, h, CS%tracer_reg%Tr, CS%tracer_reg%ntr) + call hchksum(h, "h after fluxes out of ocean", G%HI, unscale=GV%H_to_MKS) + call MOM_tracer_chkinv("Before fluxes out of ocean", G, GV, h, CS%tracer_reg) endif end subroutine offline_fw_fluxes_out_ocean !> When in layer mode, 3D horizontal advection using stored mass fluxes must be used. Horizontal advection is !! done via tracer_advect, whereas the vertical component is actually handled by vertdiff in tracer_column_fns -subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, eatr, ebtr, uhtr, vhtr) - type(forcing), intent(inout) :: fluxes !< pointers to forcing fields - type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type - real, intent(in) :: time_interval !< Offline transport time interval - type(offline_transport_CS), pointer :: CS !< Control structure for offline module - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), intent(inout) :: h_pre !< layer thicknesses before advection - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), intent(inout) :: eatr !< Entrainment from layer above - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), intent(inout) :: ebtr !< Entrainment from layer below - real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), intent(inout) :: uhtr !< Zonal mass transport - real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%GV)), intent(inout) :: vhtr !< Meridional mass transport - ! Local pointers - type(ocean_grid_type), pointer :: G => NULL() ! Pointer to a structure containing - ! metrics and related information - type(verticalGrid_type), pointer :: GV => NULL() ! Pointer to structure containing information - ! about the vertical grid - ! Remaining zonal mass transports - real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%GV)) :: uhtr_sub - ! Remaining meridional mass transports - real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%GV)) :: vhtr_sub - - real :: sum_abs_fluxes, sum_u, sum_v ! Used to keep track of how close to convergence we are - real :: dt_offline +subroutine offline_advection_layer(fluxes, Time_start, time_interval, G, GV, US, CS, h_pre, eatr, ebtr, uhtr, vhtr) + type(forcing), intent(inout) :: fluxes !< pointers to forcing fields + type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type + real, intent(in) :: time_interval !< Offline transport time interval [T ~> s] + 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 + type(offline_transport_CS), pointer :: CS !< Control structure for offline module + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_pre !< layer thicknesses before advection [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: eatr !< Entrainment from layer above [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: ebtr !< Entrainment from layer below [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: uhtr !< Zonal mass transport [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: vhtr !< Meridional mass transport [H L2 ~> m3 or kg] ! Local variables - ! Vertical diffusion related variables - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)) :: & - eatr_sub, & - ebtr_sub + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uhtr_sub ! Remaining zonal mass transports [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vhtr_sub ! Remaining meridional mass transports [H L2 ~> m3 or kg] + + real, dimension(SZI_(G),SZJB_(G)) :: rem_col_flux ! The summed absolute value of the remaining + ! mass fluxes through the faces of a column or within a column [R Z L2 ~> kg] + real :: sum_flux ! Globally summed absolute value of fluxes [R Z L2 ~> kg], which is + ! used to keep track of how close to convergence we are. + + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + eatr_sub, & ! Layer entrainment rate from above for this sub-cycle [H ~> m or kg m-2] + ebtr_sub ! Layer entrainment rate from below for this sub-cycle [H ~> m or kg m-2] ! Variables used to keep track of layer thicknesses at various points in the code - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)) :: & - h_new, & - h_vol + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + h_new, & ! Updated thicknesses [H ~> m or kg m-2] + h_vol ! Cell volumes [H L2 ~> m3 or kg] ! Work arrays for temperature and salinity - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)) :: & - temp_old, salt_old, & - temp_mean, salt_mean, & - zero_3dh ! - integer :: niter, iter - real :: Inum_iter + integer :: iter real :: dt_iter ! The timestep of each iteration [T ~> s] - logical :: converged character(len=160) :: mesg ! The text of an error message - integer :: i, j, k, m, is, ie, js, je, isd, ied, jsd, jed, nz - integer :: isv, iev, jsv, jev ! The valid range of the indices. + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB logical :: z_first, x_before_y - G => CS%G ; GV => CS%GV 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 IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - dt_iter = CS%US%s_to_T * time_interval / real(max(1, CS%num_off_iter)) + dt_iter = time_interval / real(max(1, CS%num_off_iter)) x_before_y = CS%x_before_y do iter=1,CS%num_off_iter - do k = 1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 eatr_sub(i,j,k) = eatr(i,j,k) ebtr_sub(i,j,k) = ebtr(i,j,k) enddo ; enddo ; enddo - do k = 1, nz ; do j=js-1,je+1 ; do i=is-2,ie+1 + do k=1,nz ; do j=js-1,je+1 ; do i=is-2,ie+1 uhtr_sub(I,j,k) = uhtr(I,j,k) enddo ; enddo ; enddo - do k = 1, nz ; do j=js-2,je+1 ; do i=is-1,ie+1 + do k=1,nz ; do j=js-2,je+1 ; do i=is-1,ie+1 vhtr_sub(i,J,k) = vhtr(i,J,k) enddo ; enddo ; enddo - ! Calculate 3d mass transports to be used in this iteration call limit_mass_flux_3d(G, GV, uhtr_sub, vhtr_sub, eatr_sub, ebtr_sub, h_pre) @@ -920,24 +923,24 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, ! First do vertical advection call update_h_vertical_flux(G, GV, eatr_sub, ebtr_sub, h_pre, h_new) call call_tracer_column_fns(h_pre, h_new, eatr_sub, ebtr_sub, & - fluxes, CS%mld, dt_iter, G, GV, CS%US, CS%tv, CS%optics, CS%tracer_flow_CSp, CS%debug) + fluxes, CS%mld, dt_iter, G, GV, US, CS%tv, CS%optics, CS%tracer_flow_CSp, CS%debug) ! We are now done with the vertical mass transports, so now h_new is h_sub - do k = 1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 h_pre(i,j,k) = h_new(i,j,k) enddo ; enddo ; enddo call pass_var(h_pre,G%Domain) ! Second zonal and meridional advection call update_h_horizontal_flux(G, GV, uhtr_sub, vhtr_sub, h_pre, h_new) - do k = 1, nz ; do i = is-1, ie+1 ; do j=js-1, je+1 - h_vol(i,j,k) = h_pre(i,j,k)*G%US%L_to_m**2*G%areaT(i,j) + do k=1,nz ; do i=is-1,ie+1 ; do j=js-1,je+1 + h_vol(i,j,k) = h_pre(i,j,k) * G%areaT(i,j) enddo ; enddo ; enddo - call advect_tracer(h_pre, uhtr_sub, vhtr_sub, CS%OBC, dt_iter, G, GV, CS%US, & - CS%tracer_adv_CSp, CS%tracer_Reg, h_vol, max_iter_in=30, x_first_in=x_before_y) + call advect_tracer(h_pre, uhtr_sub, vhtr_sub, CS%OBC, dt_iter, G, GV, US, & + CS%tracer_adv_CSp, CS%tracer_Reg, x_first_in=x_before_y, vol_prev=h_vol, max_iter_in=30) ! Done with horizontal so now h_pre should be h_new - do k = 1, nz ; do i=is-1,ie+1 ; do j=js-1,je+1 - h_pre(i,j,k) = h_new(i,j,k) + do k=1,nz ; do i=is-1,ie+1 ; do j=js-1,je+1 + h_pre(i,j,k) = h_new(i,j,k) enddo ; enddo ; enddo endif @@ -946,39 +949,39 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, ! First zonal and meridional advection call update_h_horizontal_flux(G, GV, uhtr_sub, vhtr_sub, h_pre, h_new) - do k = 1, nz ; do i = is-1, ie+1 ; do j=js-1, je+1 - h_vol(i,j,k) = h_pre(i,j,k)*G%US%L_to_m**2*G%areaT(i,j) + do k=1,nz ; do i=is-1,ie+1 ; do j=js-1,je+1 + h_vol(i,j,k) = h_pre(i,j,k) * G%areaT(i,j) enddo ; enddo ; enddo - call advect_tracer(h_pre, uhtr_sub, vhtr_sub, CS%OBC, dt_iter, G, GV, CS%US, & - CS%tracer_adv_CSp, CS%tracer_Reg, h_vol, max_iter_in=30, x_first_in=x_before_y) + call advect_tracer(h_pre, uhtr_sub, vhtr_sub, CS%OBC, dt_iter, G, GV, US, CS%tracer_adv_CSp, & + CS%tracer_Reg, x_first_in=x_before_y, vol_prev=h_vol, max_iter_in=30) ! Done with horizontal so now h_pre should be h_new - do k = 1, nz ; do i=is-1,ie+1 ; do j=js-1,je+1 - h_pre(i,j,k) = h_new(i,j,k) + do k=1,nz ; do i=is-1,ie+1 ; do j=js-1,je+1 + h_pre(i,j,k) = h_new(i,j,k) enddo ; enddo ; enddo ! Second vertical advection call update_h_vertical_flux(G, GV, eatr_sub, ebtr_sub, h_pre, h_new) call call_tracer_column_fns(h_pre, h_new, eatr_sub, ebtr_sub, & - fluxes, CS%mld, dt_iter, G, GV, CS%US, CS%tv, CS%optics, CS%tracer_flow_CSp, CS%debug) + fluxes, CS%mld, dt_iter, G, GV, US, CS%tv, CS%optics, CS%tracer_flow_CSp, CS%debug) ! We are now done with the vertical mass transports, so now h_new is h_sub - do k = 1, nz ; do i=is-1,ie+1 ; do j=js-1,je+1 + do k=1,nz ; do i=is-1,ie+1 ; do j=js-1,je+1 h_pre(i,j,k) = h_new(i,j,k) enddo ; enddo ; enddo endif ! Update remaining transports - do k = 1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 eatr(i,j,k) = eatr(i,j,k) - eatr_sub(i,j,k) ebtr(i,j,k) = ebtr(i,j,k) - ebtr_sub(i,j,k) enddo ; enddo ; enddo - do k = 1, nz ; do j=js-1,je+1 ; do i=is-2,ie+1 + do k=1,nz ; do j=js-1,je+1 ; do i=is-2,ie+1 uhtr(I,j,k) = uhtr(I,j,k) - uhtr_sub(I,j,k) enddo ; enddo ; enddo - do k = 1, nz ; do j=js-2,je+1 ; do i=is-1,ie+1 + do k=1,nz ; do j=js-2,je+1 ; do i=is-1,ie+1 vhtr(i,J,k) = vhtr(i,J,k) - vhtr_sub(i,J,k) enddo ; enddo ; enddo @@ -986,25 +989,25 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, call pass_var(ebtr,G%Domain) call pass_var(h_pre,G%Domain) call pass_vector(uhtr,vhtr,G%Domain) - ! + ! Calculate how close we are to converging by summing the remaining fluxes at each point - sum_abs_fluxes = 0.0 - sum_u = 0.0 - sum_v = 0.0 + rem_col_flux(:,:) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - sum_u = sum_u + abs(uhtr(I-1,j,k))+abs(uhtr(I,j,k)) - sum_v = sum_v + abs(vhtr(i,J-1,k))+abs(vhtr(I,J,k)) - sum_abs_fluxes = sum_abs_fluxes + abs(eatr(i,j,k)) + abs(ebtr(i,j,k)) + abs(uhtr(I-1,j,k)) + & - abs(uhtr(I,j,k)) + abs(vhtr(i,J-1,k)) + abs(vhtr(i,J,k)) + rem_col_flux(i,j) = rem_col_flux(i,j) + GV%H_to_RZ * & + ( (abs(eatr(i,j,k)) + abs(ebtr(i,j,k))) + & + ((abs(uhtr(I-1,j,k)) + abs(uhtr(I,j,k))) + & + (abs(vhtr(i,J-1,k)) + abs(vhtr(i,J,k))) ) ) enddo ; enddo ; enddo - call sum_across_PEs(sum_abs_fluxes) + sum_flux = reproducing_sum(rem_col_flux, is+(1-G%isd), ie+(1-G%isd), js+(1-G%jsd), je+(1-G%jsd), & + unscale=US%RZL2_to_kg) - write(mesg,*) "offline_advection_layer: Remaining u-flux, v-flux:", sum_u, sum_v - call MOM_mesg(mesg) - if (sum_abs_fluxes==0) then + if (sum_flux==0) then write(mesg,*) 'offline_advection_layer: Converged after iteration', iter call MOM_mesg(mesg) exit + else + write(mesg,*) "offline_advection_layer: Iteration ", iter, " remaining total fluxes: ", sum_flux*US%RZL2_to_kg + call MOM_mesg(mesg) endif ! Switch order of Strang split every iteration @@ -1016,42 +1019,60 @@ end subroutine offline_advection_layer !> Update fields used in this round of offline transport. First fields are updated from files or from arrays !! read during initialization. Then if in an ALE-dependent coordinate, regrid/remap fields. -subroutine update_offline_fields(CS, h, fluxes, do_ale) - type(offline_transport_CS), pointer :: CS !< Control structure for offline module - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)) :: h !< The regridded layer thicknesses - type(forcing), intent(inout) :: fluxes !< Pointers to forcing fields - logical, intent(in ) :: do_ale !< True if using ALE +subroutine update_offline_fields(CS, G, GV, US, h, fluxes, do_ale) + type(offline_transport_CS), pointer :: CS !< Control structure for offline module + 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(inout) :: h !< The regridded layer thicknesses [H ~> m or kg m-2] + type(forcing), intent(inout) :: fluxes !< Pointers to forcing fields + logical, intent(in ) :: do_ale !< True if using ALE ! Local variables + integer :: stencil integer :: i, j, k, is, ie, js, je, nz - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)) :: h_start - is = CS%G%isc ; ie = CS%G%iec ; js = CS%G%jsc ; je = CS%G%jec ; nz = CS%GV%ke + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_start ! Initial thicknesses [H ~> m or kg m-2] + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke call cpu_clock_begin(CS%id_clock_read_fields) call callTree_enter("update_offline_fields, MOM_offline_main.F90") + if (CS%debug) then + call uvchksum("[uv]htr before update_offline_fields", CS%uhtr, CS%vhtr, G%HI, & + unscale=US%L_to_m**2*GV%H_to_kg_m2) + call hchksum(CS%h_end, "h_end before update_offline_fields", G%HI, unscale=GV%H_to_MKS) + call hchksum(CS%tv%T, "Temp before update_offline_fields", G%HI, unscale=US%C_to_degC) + call hchksum(CS%tv%S, "Salt before update_offline_fields", G%HI, unscale=US%S_to_ppt) + endif + ! Store a copy of the layer thicknesses before ALE regrid/remap h_start(:,:,:) = h(:,:,:) ! Most fields will be read in from files - call update_offline_from_files( CS%G, CS%GV, CS%nk_input, CS%mean_file, CS%sum_file, CS%snap_file, CS%surf_file, & - CS%h_end, CS%uhtr, CS%vhtr, CS%tv%T, CS%tv%S, CS%mld, CS%Kd, fluxes, & - CS%ridx_sum, CS%ridx_snap, CS%read_mld, CS%read_sw, .not. CS%read_all_ts_uvh, do_ale) + call update_offline_from_files( G, GV, US, CS%nk_input, CS%mean_file, CS%sum_file, CS%snap_file, & + CS%surf_file, CS%h_end, CS%uhtr, CS%vhtr, CS%tv%T, CS%tv%S, & + CS%mld, CS%Kd, fluxes, CS%ridx_sum, CS%ridx_snap, CS%read_mld, & + CS%read_sw, .not.CS%read_all_ts_uvh, do_ale) ! If uh, vh, h_end, temp, salt were read in at the beginning, fields are copied from those arrays if (CS%read_all_ts_uvh) then - call update_offline_from_arrays(CS%G, CS%GV, CS%nk_input, CS%ridx_sum, CS%mean_file, CS%sum_file, CS%snap_file, & - CS%uhtr, CS%vhtr, CS%h_end, CS%uhtr_all, CS%vhtr_all, CS%hend_all, CS%tv%T, CS%tv%S, CS%temp_all, CS%salt_all) - endif + call update_offline_from_arrays(G, GV, CS%nk_input, CS%ridx_sum, CS%mean_file, CS%sum_file, & + CS%snap_file, CS%uhtr, CS%vhtr, CS%h_end, CS%uhtr_all, CS%vhtr_all, & + CS%hend_all, CS%tv%T, CS%tv%S, CS%temp_all, CS%salt_all) + endif if (CS%debug) then - call uvchksum("[uv]h after update offline from files and arrays", CS%uhtr, CS%vhtr, CS%G%HI) + call uvchksum("[uv]h after update offline from files and arrays", CS%uhtr, CS%vhtr, G%HI, & + unscale=US%L_to_m**2*GV%H_to_kg_m2) + call hchksum(CS%tv%T, "Temp after update offline from files and arrays", G%HI, unscale=US%C_to_degC) + call hchksum(CS%tv%S, "Salt after update offline from files and arrays", G%HI, unscale=US%S_to_ppt) endif ! If using an ALE-dependent vertical coordinate, fields will need to be remapped if (do_ale) then ! These halo passes are necessary because u, v fields will need information 1 step into the halo - call pass_var(h, CS%G%Domain) - call pass_var(CS%tv%T, CS%G%Domain) - call pass_var(CS%tv%S, CS%G%Domain) - call ALE_offline_inputs(CS%ALE_CSp, CS%G, CS%GV, h, CS%tv, CS%tracer_Reg, CS%uhtr, CS%vhtr, CS%Kd, & + call pass_var(h, G%Domain) + call pass_var(CS%tv%T, G%Domain) + call pass_var(CS%tv%S, G%Domain) + call ALE_offline_inputs(CS%ALE_CSp, G, GV, US, h, CS%tv, CS%tracer_Reg, CS%uhtr, CS%vhtr, CS%Kd, & CS%debug, CS%OBC) if (CS%id_temp_regrid>0) call post_data(CS%id_temp_regrid, CS%tv%T, CS%diag) if (CS%id_salt_regrid>0) call post_data(CS%id_salt_regrid, CS%tv%S, CS%diag) @@ -1059,15 +1080,22 @@ subroutine update_offline_fields(CS, h, fluxes, do_ale) if (CS%id_vhtr_regrid>0) call post_data(CS%id_vhtr_regrid, CS%vhtr, CS%diag) if (CS%id_h_regrid>0) call post_data(CS%id_h_regrid, h, CS%diag) if (CS%debug) then - call uvchksum("[uv]h after ALE regridding/remapping of inputs", CS%uhtr, CS%vhtr, CS%G%HI) - call hchksum(h_start,"h_start after update offline from files and arrays", CS%G%HI) + call uvchksum("[uv]htr after ALE regridding/remapping of inputs", CS%uhtr, CS%vhtr, G%HI, & + unscale=US%L_to_m**2*GV%H_to_kg_m2) + call hchksum(h_start,"h_start after ALE regridding/remapping of inputs", G%HI, unscale=GV%H_to_MKS) endif endif ! Update halos for some - call pass_var(CS%h_end, CS%G%Domain) - call pass_var(CS%tv%T, CS%G%Domain) - call pass_var(CS%tv%S, CS%G%Domain) + call pass_var(CS%h_end, G%Domain) + call pass_var(CS%tv%T, G%Domain) + call pass_var(CS%tv%S, G%Domain) + + ! Update derived thermodynamic quantities. + if (allocated(CS%tv%SpV_avg)) then + stencil = min(3, G%Domain%nihalo, G%Domain%njhalo) + call calc_derived_thermo(CS%tv, CS%h_end, G, GV, US, halo=stencil) + endif ! Update the read indices CS%ridx_snap = next_modulo_time(CS%ridx_snap,CS%numtime) @@ -1075,8 +1103,8 @@ subroutine update_offline_fields(CS, h, fluxes, do_ale) ! Apply masks/factors at T, U, and V points do k=1,nz ; do j=js,je ; do i=is,ie - if (CS%G%mask2dT(i,j)<1.0) then - CS%h_end(i,j,k) = CS%GV%Angstrom_H + if (G%mask2dT(i,j)<1.0) then + CS%h_end(i,j,k) = GV%Angstrom_H endif enddo ; enddo ; enddo @@ -1088,22 +1116,23 @@ subroutine update_offline_fields(CS, h, fluxes, do_ale) enddo ; enddo ; enddo do k=1,nz ; do J=js-1,je ; do i=is,ie - if (CS%G%mask2dCv(i,J)<1.0) then + if (G%mask2dCv(i,J)<1.0) then CS%vhtr(i,J,k) = 0.0 endif enddo ; enddo ; enddo do k=1,nz ; do j=js,je ; do I=is-1,ie - if (CS%G%mask2dCu(I,j)<1.0) then + if (G%mask2dCu(I,j)<1.0) then CS%uhtr(I,j,k) = 0.0 endif enddo ; enddo ; enddo if (CS%debug) then - call uvchksum("[uv]htr_sub after update_offline_fields", CS%uhtr, CS%vhtr, CS%G%HI) - call hchksum(CS%h_end, "h_end after update_offline_fields", CS%G%HI) - call hchksum(CS%tv%T, "Temp after update_offline_fields", CS%G%HI) - call hchksum(CS%tv%S, "Salt after update_offline_fields", CS%G%HI) + call uvchksum("[uv]htr after update_offline_fields", CS%uhtr, CS%vhtr, G%HI, & + unscale=US%L_to_m**2*GV%H_to_kg_m2) + call hchksum(CS%h_end, "h_end after update_offline_fields", G%HI, unscale=GV%H_to_MKS) + call hchksum(CS%tv%T, "Temp after update_offline_fields", G%HI, unscale=US%C_to_degC) + call hchksum(CS%tv%S, "Salt after update_offline_fields", G%HI, unscale=US%S_to_ppt) endif call callTree_leave("update_offline_fields") @@ -1112,80 +1141,102 @@ subroutine update_offline_fields(CS, h, fluxes, do_ale) end subroutine update_offline_fields !> Initialize additional diagnostics required for offline tracer transport -subroutine register_diags_offline_transport(Time, diag, CS) +subroutine register_diags_offline_transport(Time, diag, CS, GV, US) type(offline_transport_CS), pointer :: CS !< Control structure for offline module + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(time_type), intent(in) :: Time !< current model time type(diag_ctrl), intent(in) :: diag !< Structure that regulates diagnostic output ! U-cell fields CS%id_uhr = register_diag_field('ocean_model', 'uhr', diag%axesCuL, Time, & - 'Zonal thickness fluxes remaining at end of advection', 'kg') + 'Zonal thickness fluxes remaining at end of advection', & + 'kg', conversion=US%L_to_m**2*GV%H_to_kg_m2) CS%id_uhr_redist = register_diag_field('ocean_model', 'uhr_redist', diag%axesCuL, Time, & - 'Zonal thickness fluxes to be redistributed vertically', 'kg') + 'Zonal thickness fluxes to be redistributed vertically', & + 'kg', conversion=US%L_to_m**2*GV%H_to_kg_m2) CS%id_uhr_end = register_diag_field('ocean_model', 'uhr_end', diag%axesCuL, Time, & - 'Zonal thickness fluxes at end of offline step', 'kg') + 'Zonal thickness fluxes at end of offline step', & + 'kg', conversion=US%L_to_m**2*GV%H_to_kg_m2) ! V-cell fields CS%id_vhr = register_diag_field('ocean_model', 'vhr', diag%axesCvL, Time, & - 'Meridional thickness fluxes remaining at end of advection', 'kg') + 'Meridional thickness fluxes remaining at end of advection', & + 'kg', conversion=US%L_to_m**2*GV%H_to_kg_m2) CS%id_vhr_redist = register_diag_field('ocean_model', 'vhr_redist', diag%axesCvL, Time, & - 'Meridional thickness to be redistributed vertically', 'kg') + 'Meridional thickness to be redistributed vertically', & + 'kg', conversion=US%L_to_m**2*GV%H_to_kg_m2) CS%id_vhr_end = register_diag_field('ocean_model', 'vhr_end', diag%axesCvL, Time, & - 'Meridional thickness at end of offline step', 'kg') + 'Meridional thickness at end of offline step', & + 'kg', conversion=US%L_to_m**2*GV%H_to_kg_m2) ! T-cell fields CS%id_hdiff = register_diag_field('ocean_model', 'hdiff', diag%axesTL, Time, & - 'Difference between the stored and calculated layer thickness', 'm') + 'Difference between the stored and calculated layer thickness', & + 'm', conversion=GV%H_to_m) CS%id_hr = register_diag_field('ocean_model', 'hr', diag%axesTL, Time, & - 'Layer thickness at end of offline step', 'm') + 'Layer thickness at end of offline step', 'm', conversion=GV%H_to_m) CS%id_ear = register_diag_field('ocean_model', 'ear', diag%axesTL, Time, & 'Remaining thickness entrained from above', 'm') CS%id_ebr = register_diag_field('ocean_model', 'ebr', diag%axesTL, Time, & 'Remaining thickness entrained from below', 'm') CS%id_eta_pre_distribute = register_diag_field('ocean_model','eta_pre_distribute', & - diag%axesT1, Time, 'Total water column height before residual transport redistribution','m') + diag%axesT1, Time, 'Total water column height before residual transport redistribution', & + 'm', conversion=GV%H_to_m) CS%id_eta_post_distribute = register_diag_field('ocean_model','eta_post_distribute', & - diag%axesT1, Time, 'Total water column height after residual transport redistribution','m') + diag%axesT1, Time, 'Total water column height after residual transport redistribution', & + 'm', conversion=GV%H_to_m) CS%id_eta_diff_end = register_diag_field('ocean_model','eta_diff_end', diag%axesT1, Time, & 'Difference in total water column height from online and offline ' // & - 'at the end of the offline timestep','m') + 'at the end of the offline timestep', 'm', conversion=GV%H_to_m) CS%id_h_redist = register_diag_field('ocean_model','h_redist', diag%axesTL, Time, & - 'Layer thicknesses before redistribution of mass fluxes','m') + 'Layer thicknesses before redistribution of mass fluxes', & + get_thickness_units(GV), conversion=GV%H_to_MKS) ! Regridded/remapped input fields CS%id_uhtr_regrid = register_diag_field('ocean_model', 'uhtr_regrid', diag%axesCuL, Time, & - 'Zonal mass transport regridded/remapped onto offline grid','kg') + 'Zonal mass transport regridded/remapped onto offline grid', & + 'kg', conversion=US%L_to_m**2*GV%H_to_kg_m2) CS%id_vhtr_regrid = register_diag_field('ocean_model', 'vhtr_regrid', diag%axesCvL, Time, & - 'Meridional mass transport regridded/remapped onto offline grid','kg') + 'Meridional mass transport regridded/remapped onto offline grid', & + 'kg', conversion=US%L_to_m**2*GV%H_to_kg_m2) CS%id_temp_regrid = register_diag_field('ocean_model', 'temp_regrid', diag%axesTL, Time, & - 'Temperature regridded/remapped onto offline grid','C') + 'Temperature regridded/remapped onto offline grid',& + 'C', conversion=US%C_to_degC) CS%id_salt_regrid = register_diag_field('ocean_model', 'salt_regrid', diag%axesTL, Time, & - 'Salinity regridded/remapped onto offline grid','g kg-1') + 'Salinity regridded/remapped onto offline grid', & + 'g kg-1', conversion=US%S_to_ppt) CS%id_h_regrid = register_diag_field('ocean_model', 'h_regrid', diag%axesTL, Time, & - 'Layer thicknesses regridded/remapped onto offline grid','m') - + 'Layer thicknesses regridded/remapped onto offline grid', & + 'm', conversion=GV%H_to_m) end subroutine register_diags_offline_transport !> Posts diagnostics related to offline convergence diagnostics -subroutine post_offline_convergence_diags(CS, h_off, h_end, uhtr, vhtr) +subroutine post_offline_convergence_diags(G, GV, CS, h_off, h_end, uhtr, vhtr) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(offline_transport_CS), intent(in ) :: CS !< Offline control structure - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), intent(inout) :: h_off !< Thicknesses at end of offline step - real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), intent(inout) :: h_end !< Stored thicknesses - real, dimension(SZIB_(CS%G),SZJ_(CS%G),SZK_(CS%GV)), intent(inout) :: uhtr !< Remaining zonal mass transport - real, dimension(SZI_(CS%G),SZJB_(CS%G),SZK_(CS%GV)), intent(inout) :: vhtr !< Remaining meridional mass transport + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_off !< Thicknesses at end of offline step [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_end !< Stored thicknesses [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: uhtr !< Remaining zonal mass transport [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: vhtr !< Remaining meridional mass transport [H L2 ~> m3 or kg] - real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: eta_diff + real, dimension(SZI_(G),SZJ_(G)) :: eta_diff ! Differences in column thickness [H ~> m or kg m-2] integer :: i, j, k if (CS%id_eta_diff_end>0) then ! Calculate difference in column thickness eta_diff = 0. - do k=1,CS%GV%ke ; do j=CS%G%jsc,CS%G%jec ; do i=CS%G%isc,CS%G%iec + do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec eta_diff(i,j) = eta_diff(i,j) + h_off(i,j,k) enddo ; enddo ; enddo - do k=1,CS%GV%ke ; do j=CS%G%jsc,CS%G%jec ; do i=CS%G%isc,CS%G%iec + do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec eta_diff(i,j) = eta_diff(i,j) - h_end(i,j,k) enddo ; enddo ; enddo @@ -1205,8 +1256,8 @@ subroutine extract_offline_main(CS, uhtr, vhtr, eatr, ebtr, h_end, accumulated_t dt_offline, dt_offline_vertical, skip_diffusion) type(offline_transport_CS), target, intent(in ) :: CS !< Offline control structure ! Returned optional arguments - real, dimension(:,:,:), optional, pointer :: uhtr !< Remaining zonal mass transport [H m2 ~> m3 or kg] - real, dimension(:,:,:), optional, pointer :: vhtr !< Remaining meridional mass transport [H m2 ~> m3 or kg] + real, dimension(:,:,:), optional, pointer :: uhtr !< Remaining zonal mass transport [H L2 ~> m3 or kg] + real, dimension(:,:,:), optional, pointer :: vhtr !< Remaining meridional mass transport [H L2 ~> m3 or kg] real, dimension(:,:,:), optional, pointer :: eatr !< Amount of fluid entrained from the layer above within !! one time step [H ~> m or kg m-2] real, dimension(:,:,:), optional, pointer :: ebtr !< Amount of fluid entrained from the layer below within @@ -1243,7 +1294,7 @@ end subroutine extract_offline_main !> Inserts (assigns values to) members of the offline main control structure. All arguments !! are optional except for the CS itself subroutine insert_offline_main(CS, ALE_CSp, diabatic_CSp, diag, OBC, tracer_adv_CSp, & - tracer_flow_CSp, tracer_Reg, tv, G, GV, x_before_y, debug) + tracer_flow_CSp, tracer_Reg, tv, x_before_y, debug) type(offline_transport_CS), intent(inout) :: CS !< Offline control structure ! Inserted optional arguments type(ALE_CS), & @@ -1262,10 +1313,6 @@ subroutine insert_offline_main(CS, ALE_CSp, diabatic_CSp, diag, OBC, tracer_adv_ target, optional, intent(in ) :: tracer_Reg !< A pointer to the tracer registry type(thermo_var_ptrs), & target, optional, intent(in ) :: tv !< A structure pointing to various thermodynamic variables - type(ocean_grid_type), & - target, optional, intent(in ) :: G !< ocean grid structure - type(verticalGrid_type), & - target, optional, intent(in ) :: GV !< ocean vertical grid structure logical, optional, intent(in ) :: x_before_y !< Indicates which horizontal direction is advected first logical, optional, intent(in ) :: debug !< If true, write verbose debugging messages @@ -1278,8 +1325,6 @@ subroutine insert_offline_main(CS, ALE_CSp, diabatic_CSp, diag, OBC, tracer_adv_ if (present(tracer_flow_CSp)) CS%tracer_flow_CSp => tracer_flow_CSp if (present(tracer_Reg)) CS%tracer_Reg => tracer_Reg if (present(tv)) CS%tv => tv - if (present(G)) CS%G => G - if (present(GV)) CS%GV => GV if (present(x_before_y)) CS%x_before_y = x_before_y if (present(debug)) CS%debug = debug @@ -1298,8 +1343,9 @@ subroutine offline_transport_init(param_file, CS, diabatic_CSp, G, GV, US) character(len=40) :: mdl = "offline_transport" character(len=20) :: redistribute_method - - integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz + ! This include declares and sets the variable "version". +# include "version_variable.h" + integer :: is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -1309,37 +1355,33 @@ subroutine offline_transport_init(param_file, CS, diabatic_CSp, G, GV, US) call callTree_enter("offline_transport_init, MOM_offline_control.F90") if (associated(CS)) then - call MOM_error(WARNING, "offline_transport_init called with an associated "// & - "control structure.") + call MOM_error(WARNING, "offline_transport_init called with an associated control structure.") return endif allocate(CS) - call log_version(param_file, mdl,version, "This module allows for tracers to be run offline") - - ! Determining the internal unit scaling factors for this run. - CS%US => US + call log_version(param_file, mdl, version, "This module allows for tracers to be run offline") ! Parse MOM_input for offline control call get_param(param_file, mdl, "OFFLINEDIR", CS%offlinedir, & - "Input directory where the offline fields can be found", fail_if_missing = .true.) + "Input directory where the offline fields can be found", fail_if_missing=.true.) call get_param(param_file, mdl, "OFF_SUM_FILE", CS%sum_file, & - "Filename where the accumulated fields can be found", fail_if_missing = .true.) + "Filename where the accumulated fields can be found", fail_if_missing=.true.) call get_param(param_file, mdl, "OFF_SNAP_FILE", CS%snap_file, & - "Filename where snapshot fields can be found", fail_if_missing = .true.) + "Filename where snapshot fields can be found", fail_if_missing=.true.) call get_param(param_file, mdl, "OFF_MEAN_FILE", CS%mean_file, & - "Filename where averaged fields can be found", fail_if_missing = .true.) + "Filename where averaged fields can be found", fail_if_missing=.true.) call get_param(param_file, mdl, "OFF_SURF_FILE", CS%surf_file, & - "Filename where averaged fields can be found", fail_if_missing = .true.) + "Filename where averaged fields can be found", fail_if_missing=.true.) call get_param(param_file, mdl, "NUMTIME", CS%numtime, & - "Number of timelevels in offline input files", fail_if_missing = .true.) + "Number of timelevels in offline input files", fail_if_missing=.true.) call get_param(param_file, mdl, "NK_INPUT", CS%nk_input, & - "Number of vertical levels in offline input files", default = nz) + "Number of vertical levels in offline input files", default=nz) call get_param(param_file, mdl, "DT_OFFLINE", CS%dt_offline, & - "Length of time between reading in of input fields", units='s', scale=US%s_to_T, fail_if_missing = .true.) + "Length of time between reading in of input fields", units='s', scale=US%s_to_T, fail_if_missing=.true.) call get_param(param_file, mdl, "DT_OFFLINE_VERTICAL", CS%dt_offline_vertical, & "Length of the offline timestep for tracer column sources/sinks " //& "This should be set to the length of the coupling timestep for " //& - "tracers which need shortwave fluxes", units="s", scale=US%s_to_T, fail_if_missing = .true.) + "tracers which need shortwave fluxes", units="s", scale=US%s_to_T, fail_if_missing=.true.) call get_param(param_file, mdl, "START_INDEX", CS%start_index, & "Which time index to start from", default=1) call get_param(param_file, mdl, "FIELDS_ARE_OFFSET", CS%fields_are_offset, & @@ -1355,42 +1397,40 @@ subroutine offline_transport_init(param_file, CS, diabatic_CSp, G, GV, US) default='barotropic') call get_param(param_file, mdl, "NUM_OFF_ITER", CS%num_off_iter, & "Number of iterations to subdivide the offline tracer advection and diffusion", & - default = 60) + default=60) call get_param(param_file, mdl, "OFF_ALE_MOD", CS%off_ale_mod, & - "Sets how many horizontal advection steps are taken before an ALE " //& - "remapping step is done. 1 would be x->y->ALE, 2 would be" //& - "x->y->x->y->ALE", default = 1) + "Sets how many horizontal advection steps are taken before an ALE "//& + "remapping step is done. 1 would be x->y->ALE, 2 would be x->y->x->y->ALE", default=1) call get_param(param_file, mdl, "PRINT_ADV_OFFLINE", CS%print_adv_offline, & - "Print diagnostic output every advection subiteration",default=.false.) + "Print diagnostic output every advection subiteration", default=.false.) call get_param(param_file, mdl, "SKIP_DIFFUSION_OFFLINE", CS%skip_diffusion, & - "Do not do horizontal diffusion",default=.false.) + "Do not do horizontal diffusion", default=.false.) call get_param(param_file, mdl, "READ_SW", CS%read_sw, & - "Read in shortwave radiation field instead of using values from the coupler"//& - "when in offline tracer mode",default=.false.) + "Read in shortwave radiation field instead of using values from the coupler "//& + "when in offline tracer mode", default=.false.) call get_param(param_file, mdl, "READ_MLD", CS%read_mld, & - "Read in mixed layer depths for tracers which exchange with the atmosphere"//& - "when in offline tracer mode",default=.false.) + "Read in mixed layer depths for tracers which exchange with the atmosphere "//& + "when in offline tracer mode", default=.false.) call get_param(param_file, mdl, "MLD_VAR_NAME", CS%mld_var_name, & - "Name of the variable containing the depth of active mixing",& - default='ePBL_h_ML') + "Name of the variable containing the depth of active mixing", default='ePBL_h_ML') call get_param(param_file, mdl, "OFFLINE_ADD_DIURNAL_SW", CS%diurnal_sw, & - "Adds a synthetic diurnal cycle in the same way that the ice " // & - "model would have when time-averaged fields of shortwave " // & + "Adds a synthetic diurnal cycle in the same way that the ice "//& + "model would have when time-averaged fields of shortwave "//& "radiation are read in", default=.false.) call get_param(param_file, mdl, "KD_MAX", CS%Kd_max, & "The maximum permitted increment for the diapycnal "//& "diffusivity from TKE-based parameterizations, or a "//& - "negative value for no limit.", units="m2 s-1", default=-1.0) + "negative value for no limit.", units="m2 s-1", default=-1.0, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "MIN_RESIDUAL_TRANSPORT", CS%min_residual, & - "How much remaining transport before the main offline advection "// & - "is exited. The default value corresponds to about 1 meter of " // & - "difference in a grid cell", default = 1.e9) + "How much remaining transport before the main offline advection is exited. "//& + "The default value corresponds to about 1 meter of difference in a grid cell", & + default=1.e9, units="m3", scale=GV%m_to_H*US%m_to_L**2) call get_param(param_file, mdl, "READ_ALL_TS_UVH", CS%read_all_ts_uvh, & "Reads all time levels of a subset of the fields necessary to run " // & "the model offline. This can require a large amount of memory "// & "and will make initialization very slow. However, for offline "// & "runs spanning more than a year this can reduce total I/O overhead", & - default = .false.) + default=.false.) ! Concatenate offline directory and file names CS%snap_file = trim(CS%offlinedir)//trim(CS%snap_file) @@ -1398,7 +1438,7 @@ subroutine offline_transport_init(param_file, CS, diabatic_CSp, G, GV, US) CS%sum_file = trim(CS%offlinedir)//trim(CS%sum_file) CS%surf_file = trim(CS%offlinedir)//trim(CS%surf_file) - CS%num_vert_iter = CS%dt_offline/CS%dt_offline_vertical + CS%num_vert_iter = CS%dt_offline / CS%dt_offline_vertical ! Map redistribute_method onto logicals in CS select case (redistribute_method) @@ -1430,23 +1470,17 @@ subroutine offline_transport_init(param_file, CS, diabatic_CSp, G, GV, US) evap_CFL_limit=CS%evap_CFL_limit, & minimum_forcing_depth=CS%minimum_forcing_depth) - ! Grid pointer assignments - CS%G => G - CS%GV => GV - ! Allocate arrays allocate(CS%uhtr(IsdB:IedB,jsd:jed,nz), source=0.0) allocate(CS%vhtr(isd:ied,JsdB:JedB,nz), source=0.0) allocate(CS%eatr(isd:ied,jsd:jed,nz), source=0.0) allocate(CS%ebtr(isd:ied,jsd:jed,nz), source=0.0) allocate(CS%h_end(isd:ied,jsd:jed,nz), source=0.0) - allocate(CS%netMassOut(G%isd:G%ied,G%jsd:G%jed), source=0.0) - allocate(CS%netMassIn(G%isd:G%ied,G%jsd:G%jed), source=0.0) allocate(CS%Kd(isd:ied,jsd:jed,nz+1), source=0.0) if (CS%read_mld) allocate(CS%mld(G%isd:G%ied,G%jsd:G%jed), source=0.0) if (CS%read_all_ts_uvh) then - call read_all_input(CS) + call read_all_input(CS, G, GV, US) endif ! Initialize ids for clocks used in offline routines @@ -1461,15 +1495,18 @@ end subroutine offline_transport_init !> Coordinates the allocation and reading in all time levels of uh, vh, hend, temp, and salt from files. Used !! when read_all_ts_uvh -subroutine read_all_input(CS) - type(offline_transport_CS), intent(inout) :: CS !< Control structure for offline module +subroutine read_all_input(CS, G, GV, US) + type(offline_transport_CS), intent(inout) :: CS !< Control structure for offline module + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - integer :: is, ie, js, je, isd, ied, jsd, jed, nz, t, ntime + integer :: isd, ied, jsd, jed, nz, t, ntime integer :: IsdB, IedB, JsdB, JedB - nz = CS%GV%ke ; ntime = CS%numtime - isd = CS%G%isd ; ied = CS%G%ied ; jsd = CS%G%jsd ; jed = CS%G%jed - IsdB = CS%G%IsdB ; IedB = CS%G%IedB ; JsdB = CS%G%JsdB ; JedB = CS%G%JedB + nz = GV%ke ; ntime = CS%numtime + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB ! Extra safety check that we're not going to overallocate any arrays if (CS%read_all_ts_uvh) then @@ -1488,13 +1525,14 @@ subroutine read_all_input(CS) call MOM_mesg("Reading in uhtr, vhtr, h_start, h_end, temp, salt") do t = 1,ntime call MOM_read_vector(CS%snap_file, 'uhtr_sum', 'vhtr_sum', CS%uhtr_all(:,:,1:CS%nk_input,t), & - CS%vhtr_all(:,:,1:CS%nk_input,t), CS%G%Domain, timelevel=t) - call MOM_read_data(CS%snap_file,'h_end', CS%hend_all(:,:,1:CS%nk_input,t), CS%G%Domain, & - timelevel=t, position=CENTER) - call MOM_read_data(CS%mean_file,'temp', CS%temp_all(:,:,1:CS%nk_input,t), CS%G%Domain, & - timelevel=t, position=CENTER) - call MOM_read_data(CS%mean_file,'salt', CS%salt_all(:,:,1:CS%nk_input,t), CS%G%Domain, & - timelevel=t, position=CENTER) + CS%vhtr_all(:,:,1:CS%nk_input,t), G%Domain, timelevel=t, & + scale=US%m_to_L**2*GV%kg_m2_to_H) + call MOM_read_data(CS%snap_file,'h_end', CS%hend_all(:,:,1:CS%nk_input,t), G%Domain, & + timelevel=t, position=CENTER, scale=GV%kg_m2_to_H) + call MOM_read_data(CS%mean_file,'temp', CS%temp_all(:,:,1:CS%nk_input,t), G%Domain, & + timelevel=t, position=CENTER, scale=US%degC_to_C) + call MOM_read_data(CS%mean_file,'salt', CS%salt_all(:,:,1:CS%nk_input,t), G%Domain, & + timelevel=t, position=CENTER, scale=US%ppt_to_S) enddo endif @@ -1510,8 +1548,6 @@ subroutine offline_transport_end(CS) deallocate(CS%eatr) deallocate(CS%ebtr) deallocate(CS%h_end) - deallocate(CS%netMassOut) - deallocate(CS%netMassIn) deallocate(CS%Kd) if (CS%read_mld) deallocate(CS%mld) if (CS%read_all_ts_uvh) then diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index e8324b6043..63b5107d19 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -1,10 +1,12 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Used to initialize tracers from a depth- (or z*-) space file. module MOM_tracer_Z_init -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe -! use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_io, only : MOM_read_data, get_var_sizes, read_attribute, read_variable use MOM_io, only : open_file_to_read, close_file_to_read @@ -16,7 +18,7 @@ module MOM_tracer_Z_init #include -public tracer_Z_init, tracer_Z_init_array, determine_temperature +public tracer_Z_init, read_Z_edges, tracer_Z_init_array, determine_temperature ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -27,57 +29,58 @@ module MOM_tracer_Z_init !> This function initializes a tracer by reading a Z-space file, returning !! .true. if this appears to have been successful, and false otherwise. -function tracer_Z_init(tr, h, filename, tr_name, G, GV, US, missing_val, land_val) +function tracer_Z_init(tr, h, filename, tr_name, G, GV, US, missing_val, land_val, scale) logical :: tracer_Z_init !< A return code indicating if the initialization has been successful type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: tr !< The tracer to initialize + intent(out) :: tr !< The tracer to initialize [CU ~> conc] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - character(len=*), intent(in) :: filename !< The name of the file to read from - character(len=*), intent(in) :: tr_name !< The name of the tracer in the file -! type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - real, optional, intent(in) :: missing_val !< The missing value for the tracer - real, optional, intent(in) :: land_val !< A value to use to fill in land points - - ! This function initializes a tracer by reading a Z-space file, returning true if this - ! appears to have been successful, and false otherwise. -! - integer, save :: init_calls = 0 -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mdl = "MOM_tracer_Z_init" ! This module's name. - character(len=256) :: mesg ! Message for error messages. + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] or other + !! arbitrary units such as [Z ~> m] + character(len=*), intent(in) :: filename !< The name of the file to read from + character(len=*), intent(in) :: tr_name !< The name of the tracer in the file + real, optional, intent(in) :: missing_val !< The missing value for the tracer [CU ~> conc] + real, optional, intent(in) :: land_val !< A value to use to fill in land points [CU ~> conc] + real, optional, intent(in) :: scale !< A factor by which to scale the output tracers from the + !! their units in the file [CU conc-1 ~> 1] + ! Local variables real, allocatable, dimension(:,:,:) :: & - tr_in ! The z-space array of tracer concentrations that is read in. + tr_in ! The z-space array of tracer concentrations that is read in [CU ~> conc] real, allocatable, dimension(:) :: & z_edges, & ! The depths of the cell edges or cell centers (depending on ! the value of has_edges) in the input z* data [Z ~> m]. - tr_1d, & ! A copy of the input tracer concentrations in a column. + tr_1d, & ! A copy of the input tracer concentrations in a column [CU ~> conc] wt, & ! The fractional weight for each layer in the range between - ! k_top and k_bot, nondim. - z1, & ! z1 and z2 are the depths of the top and bottom limits of the part - z2 ! of a z-cell that contributes to a layer, relative to the cell - ! center and normalized by the cell thickness, nondim. + ! k_top and k_bot [nondim] + z1, z2 ! z1 and z2 are the depths of the top and bottom limits of the part + ! of a z-cell that contributes to a layer, relative to the cell + ! center and normalized by the cell thickness [nondim]. ! Note that -1/2 <= z1 <= z2 <= 1/2. real :: e(SZK_(GV)+1) ! The z-star interface heights [Z ~> m]. - real :: landval ! The tracer value to use in land points. + real :: landval ! The tracer value to use in land points [CU ~> conc] real :: sl_tr ! The normalized slope of the tracer - ! within the cell, in tracer units. + ! within the cell, in tracer units [CU ~> conc] real :: htot(SZI_(G)) ! The vertical sum of h [H ~> m or kg m-2]. real :: dilate ! The amount by which the thicknesses are dilated to - ! create a z-star coordinate, nondim or in m3 kg-1. - real :: missing ! The missing value for the tracer. - + ! create a z-star coordinate [Z H-1 ~> nondim or m3 kg-1] + ! or other units reflecting those of h + real :: missing ! The missing value for the tracer [CU ~> conc] + real :: scale_fac ! A factor by which to scale the output tracers from the units in the + ! input file [CU conc-1 ~> 1] + ! This include declares and sets the variable "version". +# include "version_variable.h" logical :: has_edges, use_missing, zero_surface character(len=80) :: loc_msg integer :: k_top, k_bot, k_bot_prev, k_start integer :: i, j, k, kz, is, ie, js, je, nz, nz_in + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + scale_fac = 1.0 ; if (present(scale)) then ; scale_fac = scale ; endif + landval = 0.0 ; if (present(land_val)) landval = land_val zero_surface = .false. ! Make this false for errors to be fatal. @@ -90,7 +93,7 @@ function tracer_Z_init(tr, h, filename, tr_name, G, GV, US, missing_val, land_va ! Find out the number of input levels and read the depth of the edges, ! also modifying their sign convention to be monotonically decreasing. call read_Z_edges(filename, tr_name, z_edges, nz_in, has_edges, use_missing, & - missing, scale=US%m_to_Z) + missing, scale=US%m_to_Z, missing_scale=scale_fac) if (nz_in < 1) then tracer_Z_init = .false. return @@ -98,7 +101,7 @@ function tracer_Z_init(tr, h, filename, tr_name, G, GV, US, missing_val, land_va allocate(tr_in(G%isd:G%ied,G%jsd:G%jed,nz_in), source=0.0) allocate(tr_1d(nz_in), source=0.0) - call MOM_read_data(filename, tr_name, tr_in(:,:,:), G%Domain) + call MOM_read_data(filename, tr_name, tr_in(:,:,:), G%Domain, scale=scale_fac) ! Fill missing values from above? Use a "close" test to avoid problems ! from type-conversion rounoff. @@ -279,38 +282,44 @@ end function tracer_Z_init !> Layer model routine for remapping tracers from pseudo-z coordinates into layers defined !! by target interface positions. subroutine tracer_z_init_array(tr_in, z_edges, nk_data, e, land_fill, G, nlay, nlevs, & - eps_z, tr) + eps_z, tr, scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure integer, intent(in) :: nk_data !< The number of levels in the input data real, dimension(SZI_(G),SZJ_(G),nk_data), & - intent(in) :: tr_in !< The z-space array of tracer concentrations that is read in. + intent(in) :: tr_in !< The z-space array of tracer concentrations + !! that is read in [A] real, dimension(nk_data+1), intent(in) :: z_edges !< The depths of the cell edges in the input z* data - !! [Z ~> m or m] - integer, intent(in) :: nlay !< The number of vertical layers in the target grid + !! [Z ~> m] or [m] + integer, intent(in) :: nlay !< The number of vertical layers in the target grid real, dimension(SZI_(G),SZJ_(G),nlay+1), & - intent(in) :: e !< The depths of the target layer interfaces [Z ~> m or m] - real, intent(in) :: land_fill !< fill in data over land (1) + intent(in) :: e !< The depths of the target layer interfaces [Z ~> m] or [m] + real, intent(in) :: land_fill !< fill in data over land [B] integer, dimension(SZI_(G),SZJ_(G)), & intent(in) :: nlevs !< The number of input levels with valid data real, intent(in) :: eps_z !< A negligibly thin layer thickness [Z ~> m]. real, dimension(SZI_(G),SZJ_(G),nlay), & - intent(out) :: tr !< tracers in layer space + intent(out) :: tr !< tracers in model space [B] + real, optional, intent(in) :: scale !< A factor by which to scale the output tracers from the + !! input tracers [B A-1 ~> 1] ! Local variables - real, dimension(nk_data) :: tr_1d !< a copy of the input tracer concentrations in a column. - real, dimension(nlay+1) :: e_1d ! A 1-d column of intreface heights, in the same units as e. - real, dimension(nlay) :: tr_ ! A 1-d column of output tracer concentrations + real :: tr_1d(nk_data) ! A copy of the input tracer concentrations in a column [B] + real :: e_1d(nlay+1) ! A 1-d column of interface heights, in the same units as e [Z ~> m] or [m] + real :: sl_tr ! The tracer concentration slope times the layer thickness, in tracer units [B] + real :: wt(nk_data) ! The fractional weight for each layer in the range between z1 and z2 [nondim] + real :: z1(nk_data) ! The fractional depth of the top limit of the part of a z-cell that contributes to + ! a layer, relative to the cell center and normalized by the cell thickness [nondim]. + real :: z2(nk_data) ! The fractional depth of the bottom limit of the part of a z-cell that contributes to + ! a layer, relative to the cell center and normalized by the cell thickness [nondim]. + ! Note that -1/2 <= z1 <= z2 <= 1/2. + real :: scale_fac ! A factor by which to scale the output tracers from the input tracers [B A-1 ~> 1] integer :: k_top, k_bot, k_bot_prev, kstart - real :: sl_tr ! The tracer concentration slope times the layer thickness, in tracer units. - real, dimension(nk_data) :: wt !< The fractional weight for each layer in the range between z1 and z2 - real, dimension(nk_data) :: z1, z2 ! z1 and z2 are the fractional depths of the top and bottom - ! limits of the part of a z-cell that contributes to a layer, relative - ! to the cell center and normalized by the cell thickness [nondim]. - ! Note that -1/2 <= z1 <= z2 <= 1/2. integer :: i, j, k, kz, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + scale_fac = 1.0 ; if (present(scale)) then ; scale_fac = scale ; endif + do j=js,je i_loop: do i=is,ie if (nlevs(i,j) == 0 .or. G%mask2dT(i,j) == 0.) then @@ -319,7 +328,7 @@ subroutine tracer_z_init_array(tr_in, z_edges, nk_data, e, land_fill, G, nlay, n endif do k=1,nk_data - tr_1d(k) = tr_in(i,j,k) + tr_1d(k) = scale_fac*tr_in(i,j,k) enddo do k=1,nlay+1 @@ -382,28 +391,31 @@ end subroutine tracer_z_init_array !> This subroutine reads the vertical coordinate data for a field from a NetCDF file. !! It also might read the missing value attribute for that same field. subroutine read_Z_edges(filename, tr_name, z_edges, nz_out, has_edges, & - use_missing, missing, scale) + use_missing, missing, scale, missing_scale) character(len=*), intent(in) :: filename !< The name of the file to read from. character(len=*), intent(in) :: tr_name !< The name of the tracer in the file. real, dimension(:), allocatable, & - intent(out) :: z_edges !< The depths of the vertical edges of the tracer array + intent(out) :: z_edges !< The depths of the vertical edges of the tracer array [Z ~> m] integer, intent(out) :: nz_out !< The number of vertical layers in the tracer array logical, intent(out) :: has_edges !< If true the values in z_edges are the edges of the !! tracer cells, otherwise they are the cell centers logical, intent(inout) :: use_missing !< If false on input, see whether the tracer has a !! missing value, and if so return true - real, intent(inout) :: missing !< The missing value, if one has been found - real, intent(in) :: scale !< A scaling factor for z_edges into new units. + real, intent(inout) :: missing !< The missing value, if one has been found [CU ~> conc] + real, intent(in) :: scale !< A scaling factor for z_edges into new units [Z m-1 ~> 1] + real, intent(in) :: missing_scale !< A scaling factor to use to convert the + !! tracers and their missing value from the units in + !! the file into their internal units [CU conc-1 ~> 1] ! This subroutine reads the vertical coordinate data for a field from a ! NetCDF file. It also might read the missing value attribute for that same field. character(len=32) :: mdl - character(len=120) :: dim_name, tr_msg, dim_msg + character(len=120) :: tr_msg, dim_msg character(:), allocatable :: edge_name character(len=256) :: dim_names(4) logical :: monotonic - integer :: ncid, status, intid, tr_id, layid, k - integer :: nz_edge, ndim, tr_dim_ids(8), sizes(4) + integer :: ncid, k + integer :: nz_edge, ndim, sizes(4) mdl = "MOM_tracer_Z_init read_Z_edges: " tr_msg = trim(tr_name)//" in "//trim(filename) @@ -421,6 +433,7 @@ subroutine read_Z_edges(filename, tr_name, z_edges, nz_out, has_edges, & if (.not.use_missing) then ! Try to find the missing value from the dataset. call read_attribute(filename, "missing_value", missing, varname=tr_name, found=use_missing, ncid_in=ncid) + if (use_missing) missing = missing * missing_scale endif ! Find out if the Z-axis has an edges attribute call read_attribute(filename, "edges", edge_name, varname=dim_names(3), found=has_edges, ncid_in=ncid) @@ -453,11 +466,6 @@ subroutine read_Z_edges(filename, tr_name, z_edges, nz_out, has_edges, & end subroutine read_Z_edges -!### `find_overlap` and `find_limited_slope` were previously part of -! MOM_diag_to_Z.F90, and are nearly identical to `find_overlap` in -! `midas_vertmap.F90` with some slight differences. We keep it here for -! reproducibility, but the two should be merged at some point - !> Determines the layers bounded by interfaces e that overlap !! with the depth range between Z_top and Z_bot, and the fractional weights !! of each layer. It also calculates the normalized relative depths of the range @@ -477,8 +485,12 @@ subroutine find_overlap(e, Z_top, Z_bot, k_max, k_start, k_top, k_bot, wt, z1, z real, dimension(:), intent(out) :: z2 !< Depths of the bottom limit of the part of !! a layer that contributes to a depth level, relative to the cell center and normalized !! by the cell thickness [nondim]. Note that -1/2 <= z1 < z2 <= 1/2. + ! Local variables - real :: Ih, e_c, tot_wt, I_totwt + real :: Ih ! The inverse of the vertical distance across a layer, in the inverse of the units of e [Z-1 ~> m-1] + real :: e_c ! The height of the layer center, in the units of e [Z ~> m] + real :: tot_wt ! The sum of the thicknesses contributing to a layer [Z ~> m] + real :: I_totwt ! The Adcroft reciprocal of tot_wt [Z-1 ~> m-1] integer :: k wt(:) = 0.0 ; z1(:) = 0.0 ; z2(:) = 0.0 ; k_bot = k_max @@ -496,6 +508,7 @@ subroutine find_overlap(e, Z_top, Z_bot, k_max, k_start, k_top, k_bot, wt, z1, z z1(k) = (e_c - MIN(e(K), Z_top)) * Ih z2(k) = (e_c - Z_bot) * Ih else + ! Note that in theis branch, wt temporarily has units of [Z ~> m] wt(k) = MIN(e(K),Z_top) - e(K+1) ; tot_wt = wt(k) ! These are always > 0. if (e(K) /= e(K+1)) then z1(k) = (0.5*(e(K)+e(K+1)) - MIN(e(K), Z_top)) / (e(K)-e(K+1)) @@ -517,6 +530,7 @@ subroutine find_overlap(e, Z_top, Z_bot, k_max, k_start, k_top, k_bot, wt, z1, z enddo I_totwt = 0.0 ; if (tot_wt > 0.0) I_totwt = 1.0 / tot_wt + ! This loop changes the units of wt from [Z ~> m] to [nondim]. do k=k_top,k_bot ; wt(k) = I_totwt*wt(k) ; enddo endif @@ -525,13 +539,13 @@ end subroutine find_overlap !> This subroutine determines a limited slope for val to be advected with !! a piecewise limited scheme. function find_limited_slope(val, e, k) result(slope) - real, dimension(:), intent(in) :: val !< An column the values that are being interpolated. + real, dimension(:), intent(in) :: val !< A column of the values that are being interpolated, in arbitrary units [A] real, dimension(:), intent(in) :: e !< A column's interface heights [Z ~> m] or other units. integer, intent(in) :: k !< The layer whose slope is being determined. - real :: slope !< The normalized slope in the intracell distribution of val. + real :: slope !< The normalized slope in the intracell distribution of val [A] ! Local variables - real :: amn, cmn - real :: d1, d2 + real :: amn, cmn ! Limited differences and curvatures in the values [A] + real :: d1, d2 ! Layer thicknesses, in the units of e [Z ~> m] if ((val(k)-val(k-1)) * (val(k)-val(k+1)) >= 0.0) then slope = 0.0 ! ; curvature = 0.0 @@ -558,62 +572,117 @@ end function find_limited_slope !> This subroutine determines the potential temperature and salinity that !! is consistent with the target density using provided initial guess -subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, k_start, G, GV, US, & - EOS, h_massless) +subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, k_start, G, GV, US, PF, & + just_read) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: temp !< potential temperature [degC] + intent(inout) :: temp !< potential temperature [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: salt !< salinity [ppt] + intent(inout) :: salt !< salinity [S ~> ppt] real, dimension(SZK_(GV)), intent(in) :: R_tgt !< desired potential density [R ~> kg m-3]. + type(EOS_type), intent(in) :: EOS !< seawater equation of state control structure real, intent(in) :: p_ref !< reference pressure [R L2 T-2 ~> Pa]. integer, intent(in) :: niter !< maximum number of iterations integer, intent(in) :: k_start !< starting index (i.e. below the buffer layer) - real, intent(in) :: land_fill !< land fill value - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< layer thickness, used only to avoid working on - !! massless layers [H ~> m or kg m-2] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(EOS_type), intent(in) :: EOS !< seawater equation of state control structure - real, optional, intent(in) :: h_massless !< A threshold below which a layer is - !! determined to be massless [H ~> m or kg m-2] + type(param_file_type), intent(in) :: PF !< A structure indicating the open file + !! to parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing T or S. - real, parameter :: T_max = 31.0, T_min = -2.0 ! Local variables (All of which need documentation!) real, dimension(SZI_(G),SZK_(GV)) :: & - T, S, dT, dS, & - rho, & ! Layer densities [R ~> kg m-3] - hin, & ! Input layer thicknesses [H ~> m or kg m-2] - drho_dT, & ! Partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] - drho_dS ! Partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1] + T, & ! A 2-d working copy of the layer temperatures [C ~> degC] + S, & ! A 2-d working copy of the layer salinities [S ~> ppt] + dT, & ! An estimated change in temperature before bounding [C ~> degC] + dS, & ! An estimated change in salinity before bounding [S ~> ppt] + rho, & ! Layer densities with the current estimate of temperature and salinity [R ~> kg m-3] + drho_dT, & ! Partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + drho_dS ! Partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] real, dimension(SZI_(G)) :: press ! Reference pressures [R L2 T-2 ~> Pa] - real :: dT_dS_gauge ! The relative penalizing of temperature to salinity changes when - ! minimizing property changes while correcting density [degC ppt-1]. - real :: I_denom ! The inverse of the magnitude squared of the density gradient in - ! T-S space streched with dT_dS_gauge [ppt2 R-2 ~> ppt2 m6 kg-2] - logical :: adjust_salt, old_fit - real :: S_min, S_max - real :: tol_T ! The tolerance for temperature matches [degC] - real :: tol_S ! The tolerance for salinity matches [ppt] - real :: tol_rho ! The tolerance for density matches [R ~> kg m-3] - real :: max_t_adj, max_s_adj + real :: dT_dS_gauge ! The relative penalizing of temperature to salinity changes when + ! minimizing property changes while correcting density [C S-1 ~> degC ppt-1]. + real :: I_denom ! The inverse of the magnitude squared of the density gradient in + ! T-S space when stretched with dT_dS_gauge [S2 R-2 ~> ppt2 m6 kg-2] + real :: T_min, T_max ! The minimum and maximum temperatures [C ~> degC] + real :: S_min, S_max ! Minimum and maximum salinities [S ~> ppt] + real :: tol_T ! The tolerance for temperature matches [C ~> degC] + real :: tol_S ! The tolerance for salinity matches [S ~> ppt] + real :: tol_rho ! The tolerance for density matches [R ~> kg m-3] + real :: max_t_adj ! The largest permitted temperature changes with each iteration + ! when old_fit is true [C ~> degC] + real :: max_s_adj ! The largest permitted salinity changes with each iteration + ! when old_fit is true [S ~> ppt] + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "determine_temperature" ! This subroutine's name. + logical :: domore(SZK_(GV)) ! Records which layers need additional iterations + logical :: adjust_salt, fit_together, convergence_bug, do_any integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state - integer :: i, j, k, kz, is, ie, js, je, nz, itt + integer :: i, j, k, is, ie, js, je, nz, itt is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - ! These hard coded parameters need to be set properly. - S_min = 0.5 ; S_max = 65.0 - max_t_adj = 1.0 ; max_s_adj = 0.5 - tol_T=1.e-4 ; tol_S=1.e-4 ; tol_rho = 1.e-4*US%kg_m3_to_R - old_fit = .true. ! reproduces siena behavior + call log_version(PF, mdl, version, "") - ! ### The whole determine_temperature subroutine needs to be reexamined, both the algorithms - ! and the extensive use of hard-coded dimensional parameters. - - ! We will switch to the newer method which simultaneously adjusts + ! We should switch the default to the newer method which simultaneously adjusts ! temp and salt based on the ratio of the thermal and haline coefficients, once it is tested. + call get_param(PF, mdl, "DETERMINE_TEMP_ADJUST_T_AND_S", fit_together, & + "If true, simltaneously adjust the estimates of the temperature and salinity "//& + "based on the ratio of the thermal and haline coefficients. Otherwise try to "//& + "match the density by only adjusting temperatures within a maximum range before "//& + "revising estimates of the salinity.", default=.false., do_not_log=just_read) + call get_param(PF, mdl, "DETERMINE_TEMP_CONVERGENCE_BUG", convergence_bug, & + "If true, use layout-dependent tests on the changes in temperature and salinity "//& + "to determine when the iterations have converged when DETERMINE_TEMP_ADJUST_T_AND_S "//& + "is false. For realistic equations of state and the default values of the "//& + "various tolerances, this bug does not impact the solutions.", & + default=.false., do_not_log=just_read) + + call get_param(PF, mdl, "DETERMINE_TEMP_T_MIN", T_min, & + "The minimum temperature that can be found by determine_temperature.", & + units="degC", default=-2.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(PF, mdl, "DETERMINE_TEMP_T_MAX", T_max, & + "The maximum temperature that can be found by determine_temperature.", & + units="degC", default=31.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(PF, mdl, "DETERMINE_TEMP_S_MIN", S_min, & + "The minimum salinity that can be found by determine_temperature.", & + units="ppt", default=0.5, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(PF, mdl, "DETERMINE_TEMP_S_MAX", S_max, & + "The maximum salinity that can be found by determine_temperature.", & + units="ppt", default=65.0, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(PF, mdl, "DETERMINE_TEMP_T_TOLERANCE", tol_T, & + "The convergence tolerance for temperature in determine_temperature.", & + units="degC", default=1.0e-4, scale=US%degC_to_C, & + do_not_log=just_read.or.(.not.convergence_bug)) + call get_param(PF, mdl, "DETERMINE_TEMP_S_TOLERANCE", tol_S, & + "The convergence tolerance for temperature in determine_temperature.", & + units="ppt", default=1.0e-4, scale=US%ppt_to_S, & + do_not_log=just_read.or.(.not.convergence_bug)) + call get_param(PF, mdl, "DETERMINE_TEMP_RHO_TOLERANCE", tol_rho, & + "The convergence tolerance for density in determine_temperature.", & + units="kg m-3", default=1.0e-4, scale=US%kg_m3_to_R, do_not_log=just_read) + if (fit_together) then + ! By default 10 degC is weighted equivalently to 1 ppt when minimizing changes. + call get_param(PF, mdl, "DETERMINE_TEMP_DT_DS_WEIGHT", dT_dS_gauge, & + "When extrapolating T & S to match the layer target densities, this "//& + "factor (in degC / ppt) is combined with the derivatives of density "//& + "with T & S to determine what direction is orthogonal to density contours. "//& + "It could be based on a typical value of (dR/dS) / (dR/dT) in oceanic profiles.", & + units="degC ppt-1", default=10.0, scale=US%degC_to_C*US%S_to_ppt) + else + call get_param(PF, mdl, "DETERMINE_TEMP_T_ADJ_RANGE", max_t_adj, & + "The maximum amount by which the initial layer temperatures can be "//& + "modified in determine_temperature.", & + units="degC", default=1.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(PF, mdl, "DETERMINE_TEMP_S_ADJ_RANGE", max_S_adj, & + "The maximum amount by which the initial layer salinities can be "//& + "modified in determine_temperature.", & + units="ppt", default=0.5, scale=US%ppt_to_S, do_not_log=just_read) + endif + + if (just_read) return ! All run-time parameters have been read, so return. press(:) = p_ref EOSdom(:) = EOS_domain(G%HI) @@ -622,52 +691,70 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, dS(:,:) = 0. ! Needs to be zero everywhere since there is a maxval(abs(dS)) later... T(:,:) = temp(:,j,:) S(:,:) = salt(:,j,:) - hin(:,:) = h(:,j,:) dT(:,:) = 0.0 + domore(:) = .true. adjust_salt = .true. iter_loop: do itt = 1,niter - do k=1,nz + do k=k_start,nz ; if (domore(k)) then + domore(k) = .false. call calculate_density(T(:,k), S(:,k), press, rho(:,k), EOS, EOSdom ) call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), & EOS, EOSdom ) - enddo - do k=k_start,nz ; do i=is,ie -! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. hin(i,k)>h_massless .and. abs(T(i,k)-land_fill) < epsln) then - if (abs(rho(i,k)-R_tgt(k))>tol_rho) then - if (old_fit) then - dT(i,k) = max(min((R_tgt(k)-rho(i,k)) / drho_dT(i,k), max_t_adj), -max_t_adj) - T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) - else - dT_dS_gauge = 10.0 ! 10 degC is weighted equivalently to 1 ppt. - I_denom = 1.0 / (drho_dS(i,k)**2 + dT_dS_gauge**2*drho_dT(i,k)**2) - dS(i,k) = (R_tgt(k)-rho(i,k)) * drho_dS(i,k) * I_denom - dT(i,k) = (R_tgt(k)-rho(i,k)) * dT_dS_gauge**2*drho_dT(i,k) * I_denom + do i=is,ie +! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. abs(T(i,k)-land_fill) < epsln) then + if (abs(rho(i,k)-R_tgt(k))>tol_rho) then + domore(k) = .true. + if (.not.fit_together) then + dT(i,k) = max(min((R_tgt(k)-rho(i,k)) / drho_dT(i,k), max_t_adj), -max_t_adj) + T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) + else + I_denom = 1.0 / (drho_dS(i,k)**2 + dT_dS_gauge**2*drho_dT(i,k)**2) + dS(i,k) = (R_tgt(k)-rho(i,k)) * drho_dS(i,k) * I_denom + dT(i,k) = (R_tgt(k)-rho(i,k)) * dT_dS_gauge**2*drho_dT(i,k) * I_denom - T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) - S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) + T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) + S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) + endif endif + enddo + endif ; enddo + if (convergence_bug) then + ! If this test does anything, it is layout-dependent. + if (maxval(abs(dT)) < tol_T) then + adjust_salt = .false. + exit iter_loop endif - enddo ; enddo - if (maxval(abs(dT)) < tol_T) then - adjust_salt = .false. - exit iter_loop endif + + do_any = .false. + do k=k_start,nz ; if (domore(k)) do_any = .true. ; enddo + if (.not.do_any) exit iter_loop ! Further iterations will not change anything. enddo iter_loop - if (adjust_salt .and. old_fit) then ; do itt = 1,niter - do k=1,nz + if (adjust_salt .and. .not.fit_together) then ; do itt = 1,niter + do k=k_start,nz ; if (domore(k)) then + domore(k) = .false. call calculate_density(T(:,k), S(:,k), press, rho(:,k), EOS, EOSdom ) call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), & EOS, EOSdom ) - enddo - do k=k_start,nz ; do i=is,ie -! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. hin(i,k)>h_massless .and. abs(T(i,k)-land_fill) < epsln ) then - if (abs(rho(i,k)-R_tgt(k)) > tol_rho) then - dS(i,k) = max(min((R_tgt(k)-rho(i,k)) / drho_dS(i,k), max_s_adj), -max_s_adj) - S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) - endif - enddo ; enddo - if (maxval(abs(dS)) < tol_S) exit + do i=is,ie +! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. abs(T(i,k)-land_fill) < epsln ) then + if (abs(rho(i,k)-R_tgt(k)) > tol_rho) then + dS(i,k) = max(min((R_tgt(k)-rho(i,k)) / drho_dS(i,k), max_s_adj), -max_s_adj) + S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) + domore(k) = .true. + endif + enddo + endif ; enddo + + if (convergence_bug) then + ! If this test does anything, it is layout-dependent. + if (maxval(abs(dS)) < tol_S) exit + endif + + do_any = .false. + do k=k_start,nz ; if (domore(k)) do_any = .true. ; enddo + if (.not.do_any) exit ! Further iterations will not change anything enddo ; endif temp(:,j,:) = T(:,:) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 34c8dddf04..b28880b3ae 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> This module contains the subroutines that advect tracers along coordinate surfaces. module MOM_tracer_advect -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl @@ -18,6 +20,8 @@ module MOM_tracer_advect use MOM_tracer_registry, only : tracer_registry_type, tracer_type use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type +use MOM_tracer_advect_schemes, only : ADVECT_PLM, ADVECT_PPMH3, ADVECT_PPM +use MOM_tracer_advect_schemes, only : set_tracer_advect_scheme, TracerAdvectionSchemeDoc implicit none ; private #include @@ -32,9 +36,10 @@ module MOM_tracer_advect type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !< timing of diagnostic output. logical :: debug !< If true, write verbose checksums for debugging purposes. - logical :: usePPM !< If true, use PPM instead of PLM - logical :: useHuynh !< If true, use the Huynh scheme for PPM interface values - type(group_pass_type) :: pass_uhr_vhr_t_hprev !< A structred used for group passes + logical :: useHuynhStencilBug = .false. !< If true, use the incorrect stencil width. + !! This is provided for compatibility with legacy simuations. + type(group_pass_type) :: pass_uhr_vhr_t_hprev !< A structure used for group passes + integer :: default_advect_scheme = -1 !< Determines which reconstruction to use end type tracer_advect_CS !>@{ CPU time clocks @@ -47,36 +52,42 @@ module MOM_tracer_advect !> This routine time steps the tracer concentration using a !! monotonic, conservative, weakly diffusive scheme. -subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & - h_prev_opt, max_iter_in, x_first_in, uhr_out, vhr_out, h_out) +subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first_in, & + vol_prev, max_iter_in, update_vol_prev, uhr_out, vhr_out) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h_end !< layer thickness after advection [H ~> m or kg m-2] + intent(in) :: h_end !< Layer thickness after advection [H ~> m or kg m-2] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: uhtr !< accumulated volume/mass flux through zonal face [H L2 ~> m3 or kg] + intent(in) :: uhtr !< Accumulated volume or mass flux through the + !! zonal faces [H L2 ~> m3 or kg] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(in) :: vhtr !< accumulated volume/mass flux through merid face [H L2 ~> m3 or kg] + intent(in) :: vhtr !< Accumulated volume or mass flux through the + !! meridional faces [H L2 ~> m3 or kg] type(ocean_OBC_type), pointer :: OBC !< specifies whether, where, and what OBCs are used real, intent(in) :: dt !< time increment [T ~> s] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(tracer_advect_CS), pointer :: CS !< control structure for module type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - optional, intent(in) :: h_prev_opt !< layer thickness before advection [H ~> m or kg m-2] - integer, optional, intent(in) :: max_iter_in !< The maximum number of iterations logical, optional, intent(in) :: x_first_in !< If present, indicate whether to update !! first in the x- or y-direction. + ! The remaining optional arguments are only used in offline tracer mode. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(inout) :: vol_prev !< Cell volume before advection [H L2 ~> m3 or kg]. + !! If update_vol_prev is true, the returned value is + !! the cell volume after the transport that was done + !! by this call, and if all the transport could be + !! accommodated it should be close to h_end*G%areaT. + integer, optional, intent(in) :: max_iter_in !< The maximum number of iterations + logical, optional, intent(in) :: update_vol_prev !< If present and true, update vol_prev to + !! return its value after the tracer have been updated. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - optional, intent(out) :: uhr_out !< accumulated volume/mass flux through zonal face - !! [H L2 ~> m3 or kg] + optional, intent(out) :: uhr_out !< Remaining accumulated volume or mass fluxes + !! through the zonal faces [H L2 ~> m3 or kg] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - optional, intent(out) :: vhr_out !< accumulated volume/mass flux through merid face - !! [H L2 ~> m3 or kg] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - optional, intent(out) :: h_out !< layer thickness before advection [H ~> m or kg m-2] + optional, intent(out) :: vhr_out !< Remaining accumulated volume or mass fluxes + !! through the meridional faces [H L2 ~> m3 or kg] - type(tracer_type) :: Tr(MAX_FIELDS_) ! The array of registered tracers real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & hprev ! cell volume at the end of previous tracer change [H L2 ~> m3 or kg] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & @@ -88,6 +99,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & ! can be simply discarded [H L2 ~> m3 or kg]. real :: landvolfill ! An arbitrary? nonzero cell volume [H L2 ~> m3 or kg]. + logical :: use_PPM_stencil ! If true, use the correct PPM stencil width. real :: Idt ! 1/dt [T-1 ~> s-1]. logical :: domore_u(SZJ_(G),SZK_(GV)) ! domore_u and domore_v indicate whether there is more logical :: domore_v(SZJB_(G),SZK_(GV)) ! advection to be done in the corresponding row or column. @@ -99,6 +111,8 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & integer :: i, j, k, m, is, ie, js, je, isd, ied, jsd, jed, nz, itt, ntr, do_any integer :: isv, iev, jsv, jev ! The valid range of the indices. integer :: IsdB, IedB, JsdB, JedB + integer :: stencil_local ! Stencil for the local adection scheme + integer :: local_advect_scheme(Reg%ntr) ! contains the list of the advection for each tracer domore_u(:,:) = .false. domore_v(:,:) = .false. @@ -106,7 +120,10 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB landvolfill = 1.0e-20 ! This is arbitrary, but must be positive. - stencil = 2 ! The scheme's stencil; 2 for PLM and PPM:H3 + stencil = 2 ! The scheme's stencil; 2 for PLM + + ntr = Reg%ntr + Idt = 1.0 / dt if (.not. associated(CS)) call MOM_error(FATAL, "MOM_tracer_advect: "// & "tracer_advect_init must be called before advect_tracer.") @@ -116,12 +133,30 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & call cpu_clock_begin(id_clock_advect) x_first = (MOD(G%first_direction,2) == 0) - ! increase stencil size for Colella & Woodward PPM - if (CS%usePPM .and. .not. CS%useHuynh) stencil = 3 + ! Choose the maximum stencil from all the local advection scheme + do m = 1,ntr + + local_advect_scheme(m) = Reg%Tr(m)%advect_scheme + if (local_advect_scheme(m) < 0) local_advect_scheme(m) = CS%default_advect_scheme + + if (local_advect_scheme(m) == ADVECT_PLM) then + stencil_local = 2 + elseif (local_advect_scheme(m) == ADVECT_PPM) then + stencil_local = 3 + elseif (local_advect_scheme(m) == ADVECT_PPMH3) then + if (CS%useHuynhStencilBug) then + stencil_local = 2 + else + stencil_local = 3 + endif + endif + stencil = max(stencil, stencil_local) + enddo - ntr = Reg%ntr - do m=1,ntr ; Tr(m) = Reg%Tr(m) ; enddo - Idt = 1.0 / dt + if (min(is-isd,ied-ie,js-jsd,jed-je) < stencil) then + call MOM_error(FATAL, "MOM_tracer_advect: "//& + "stencil is wider than the halo.") + endif max_iter = 2*INT(CEILING(dt/CS%dt)) + 1 @@ -131,13 +166,11 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & call create_group_pass(CS%pass_uhr_vhr_t_hprev, uhr, vhr, G%Domain) call create_group_pass(CS%pass_uhr_vhr_t_hprev, hprev, G%Domain) do m=1,ntr - call create_group_pass(CS%pass_uhr_vhr_t_hprev, Tr(m)%t, G%Domain) + call create_group_pass(CS%pass_uhr_vhr_t_hprev, Reg%Tr(m)%t, G%Domain) enddo call cpu_clock_end(id_clock_pass) -!$OMP parallel default(none) shared(nz,jsd,jed,IsdB,IedB,uhr,jsdB,jedB,Isd,Ied,vhr, & -!$OMP hprev,domore_k,js,je,is,ie,uhtr,vhtr,G,GV,h_end,& -!$OMP uh_neglect,vh_neglect,ntr,Tr,h_prev_opt) + !$OMP parallel default(shared) ! This initializes the halos of uhr and vhr because pass_vector might do ! calculations on them, even though they are never used. @@ -150,11 +183,11 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & ! Put the remaining (total) thickness fluxes into uhr and vhr. do j=js,je ; do I=is-1,ie ; uhr(I,j,k) = uhtr(I,j,k) ; enddo ; enddo do J=js-1,je ; do i=is,ie ; vhr(i,J,k) = vhtr(i,J,k) ; enddo ; enddo - if (.not. present(h_prev_opt)) then + if (.not. present(vol_prev)) then ! This loop reconstructs the thickness field the last time that the ! tracers were updated, probably just after the diabatic forcing. A useful ! diagnostic could be to compare this reconstruction with that older value. - do i=is,ie ; do j=js,je + do j=js,je ; do i=is,ie hprev(i,j,k) = max(0.0, G%areaT(i,j)*h_end(i,j,k) + & ((uhr(I,j,k) - uhr(I-1,j,k)) + (vhr(i,J,k) - vhr(i,J-1,k)))) ! In the case that the layer is now dramatically thinner than it was previously, @@ -164,8 +197,8 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & max(0.0, 1.0e-13*hprev(i,j,k) - G%areaT(i,j)*h_end(i,j,k)) enddo ; enddo else - do i=is,ie ; do j=js,je - hprev(i,j,k) = h_prev_opt(i,j,k) + do j=js,je ; do i=is,ie + hprev(i,j,k) = vol_prev(i,j,k) enddo ; enddo endif enddo @@ -183,40 +216,24 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & ! initialize diagnostic fluxes and tendencies !$OMP do do m=1,ntr - if (associated(Tr(m)%ad_x)) then - do k=1,nz ; do j=jsd,jed ; do i=isd,ied - Tr(m)%ad_x(I,j,k) = 0.0 - enddo ; enddo ; enddo - endif - if (associated(Tr(m)%ad_y)) then - do k=1,nz ; do J=jsd,jed ; do i=isd,ied - Tr(m)%ad_y(i,J,k) = 0.0 - enddo ; enddo ; enddo - endif - if (associated(Tr(m)%advection_xy)) then - do k=1,nz ; do j=jsd,jed ; do i=isd,ied - Tr(m)%advection_xy(i,j,k) = 0.0 - enddo ; enddo ; enddo - endif - if (associated(Tr(m)%ad2d_x)) then - do j=jsd,jed ; do i=isd,ied ; Tr(m)%ad2d_x(I,j) = 0.0 ; enddo ; enddo - endif - if (associated(Tr(m)%ad2d_y)) then - do J=jsd,jed ; do i=isd,ied ; Tr(m)%ad2d_y(i,J) = 0.0 ; enddo ; enddo - endif + if (associated(Reg%Tr(m)%ad_x)) Reg%Tr(m)%ad_x(:,:,:) = 0.0 + if (associated(Reg%Tr(m)%ad_y)) Reg%Tr(m)%ad_y(:,:,:) = 0.0 + if (associated(Reg%Tr(m)%advection_xy)) Reg%Tr(m)%advection_xy(:,:,:) = 0.0 + if (associated(Reg%Tr(m)%ad2d_x)) Reg%Tr(m)%ad2d_x(:,:) = 0.0 + if (associated(Reg%Tr(m)%ad2d_y)) Reg%Tr(m)%ad2d_y(:,:) = 0.0 enddo !$OMP end parallel isv = is ; iev = ie ; jsv = js ; jev = je + nsten_halo = min(is - isd, ied - ie, js - jsd, jed - je) / stencil do itt=1,max_iter if (isv > is-stencil) then call do_group_pass(CS%pass_uhr_vhr_t_hprev, G%Domain, clock=id_clock_pass) - nsten_halo = min(is-isd,ied-ie,js-jsd,jed-je)/stencil - isv = is-nsten_halo*stencil ; jsv = js-nsten_halo*stencil - iev = ie+nsten_halo*stencil ; jev = je+nsten_halo*stencil + isv = is - nsten_halo * stencil ; jsv = js - nsten_halo * stencil + iev = ie + nsten_halo * stencil ; jev = je + nsten_halo * stencil ! Reevaluate domore_u & domore_v unless the valid range is the same size as ! before. Also, do this if there is Strang splitting. if ((nsten_halo > 1) .or. (itt==1)) then @@ -260,15 +277,16 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & !$OMP do ordered do k=1,nz ; if (domore_k(k) > 0) then ! First, advect zonally. - call advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & - isv, iev, jsv-stencil, jev+stencil, k, G, GV, US, CS%usePPM, CS%useHuynh) + call advect_x(Reg%Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & + isv, iev, jsv-stencil, jev+stencil, k, G, GV, US, & + local_advect_scheme) endif ; enddo !$OMP do ordered do k=1,nz ; if (domore_k(k) > 0) then ! Next, advect meridionally. - call advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & - isv, iev, jsv, jev, k, G, GV, US, CS%usePPM, CS%useHuynh) + call advect_y(Reg%Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & + isv, iev, jsv, jev, k, G, GV, US, local_advect_scheme) ! Update domore_k(k) for the next iteration domore_k(k) = 0 @@ -282,15 +300,16 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & !$OMP do ordered do k=1,nz ; if (domore_k(k) > 0) then ! First, advect meridionally. - call advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & - isv-stencil, iev+stencil, jsv, jev, k, G, GV, US, CS%usePPM, CS%useHuynh) + call advect_y(Reg%Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & + isv-stencil, iev+stencil, jsv, jev, k, G, GV, US, & + local_advect_scheme) endif ; enddo !$OMP do ordered do k=1,nz ; if (domore_k(k) > 0) then ! Next, advect zonally. - call advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & - isv, iev, jsv, jev, k, G, GV, US, CS%usePPM, CS%useHuynh) + call advect_x(Reg%Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & + isv, iev, jsv, jev, k, G, GV, US, local_advect_scheme) ! Update domore_k(k) for the next iteration domore_k(k) = 0 @@ -324,7 +343,9 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, & if (present(uhr_out)) uhr_out(:,:,:) = uhr(:,:,:) if (present(vhr_out)) vhr_out(:,:,:) = vhr(:,:,:) - if (present(h_out)) h_out(:,:,:) = hprev(:,:,:) + if (present(vol_prev) .and. present(update_vol_prev)) then + if (update_vol_prev) vol_prev(:,:,:) = hprev(:,:,:) + endif call cpu_clock_end(id_clock_advect) @@ -334,9 +355,10 @@ end subroutine advect_tracer !> This subroutine does 1-d flux-form advection in the zonal direction using !! a monotonic piecewise linear scheme. subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & - is, ie, js, je, k, G, GV, US, usePPM, useHuynh) + is, ie, js, je, k, G, GV, US, advect_schemes) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + integer, intent(in) :: ntr !< The number of tracers type(tracer_type), dimension(ntr), intent(inout) :: Tr !< The array of registered tracers to work on real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: hprev !< cell volume at the end of previous !! tracer change [H L2 ~> m3 or kg] @@ -348,16 +370,13 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & logical, dimension(SZJ_(G),SZK_(GV)), intent(inout) :: domore_u !< If true, there is more advection to be !! done in this u-row real, intent(in) :: Idt !< The inverse of dt [T-1 ~> s-1] - integer, intent(in) :: ntr !< The number of tracers integer, intent(in) :: is !< The starting tracer i-index to work on integer, intent(in) :: ie !< The ending tracer i-index to work on integer, intent(in) :: js !< The starting tracer j-index to work on integer, intent(in) :: je !< The ending tracer j-index to work on integer, intent(in) :: k !< The k-level to work on type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - logical, intent(in) :: usePPM !< If true, use PPM instead of PLM - logical, intent(in) :: useHuynh !< If true, use the Huynh scheme - !! for PPM interface values + integer, dimension(ntr), intent(in) :: advect_schemes !< list of advection schemes to use real, dimension(SZI_(G),ntr) :: & slope_x ! The concentration slope per grid point [conc]. @@ -366,8 +385,6 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & real, dimension(SZI_(G),ntr) :: & T_tmp ! The copy of the tracer concentration at constant i,k [conc]. - real :: maxslope ! The maximum concentration slope per grid point - ! consistent with monotonicity [conc]. real :: hup, hlos ! hup is the upwind volume, hlos is the ! part of that volume that might be lost ! due to advection out the other side of @@ -380,26 +397,36 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & CFL ! The absolute value of the advective upwind-cell CFL number [nondim]. real :: min_h ! The minimum thickness that can be realized during ! any of the passes [H ~> m or kg m-2]. - real :: tiny_h ! The smallest numerically invertable thickness [H ~> m or kg m-2]. + real :: tiny_h ! The smallest numerically invertible thickness [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. - logical :: do_i(SZIB_(G),SZJ_(G)) ! If true, work on given points. - logical :: do_any_i - integer :: i, j, m, n, i_up, stencil - real :: aR, aL, dMx, dMn, Tp, Tc, Tm, dA, mA, a6 - real :: fac1,u_L_in,u_L_out ! terms used for time-stepping OBC reservoirs - type(OBC_segment_type), pointer :: segment=>NULL() + real :: aR, aL ! Reconstructed tracer concentrations at the right and left edges [conc] + real :: dMx ! Difference between the maximum of the surrounding cell concentrations and + ! the value in the cell whose reconstruction is being found [conc] + real :: dMn ! Difference between the tracer concentration in the cell whose reconstruction + ! is being found and the minimum of the surrounding values [conc] + real :: Tp, Tc, Tm ! Tracer concentrations around the upstream cell [conc] + real :: dA ! Difference between the reconstruction tracer edge values [conc] + real :: mA ! Average of the reconstruction tracer edge values [conc] + real :: a6 ! Curvature of the reconstruction tracer values [conc] + logical :: do_i(SZI_(G),SZJ_(G)) ! If true, work on given points. logical :: usePLMslope + integer :: i, j, m, n, i_up, stencil, ntr_id + type(OBC_segment_type), pointer :: segment=>NULL() logical, dimension(SZJ_(G),SZK_(GV)) :: domore_u_initial ! keep a local copy of the initial values of domore_u, which is to be used when computing ad2d_x ! diagnostic at the end of this subroutine. domore_u_initial = domore_u - usePLMslope = .not. (usePPM .and. useHuynh) + usePLMslope = .false. ! stencil for calculating slope values stencil = 1 - if (usePPM .and. .not. useHuynh) stencil = 2 + do m = 1,ntr + if ((advect_schemes(m) == ADVECT_PLM) .or. (advect_schemes(m) == ADVECT_PPM)) & + usePLMslope = .true. + if (advect_schemes(m) == ADVECT_PPM) stencil = 2 + enddo min_h = 0.1*GV%Angstrom_H tiny_h = tiny(min_h) @@ -449,18 +476,19 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & if (segment%is_E_or_W) then if (j>=segment%HI%jsd .and. j<=segment%HI%jed) then I = segment%HI%IsdB - do m = 1,ntr ! replace tracers with OBC values + do m = 1,segment%tr_Reg%ntseg ! replace tracers with OBC values + ntr_id = segment%tr_reg%Tr(m)%ntr_index if (allocated(segment%tr_Reg%Tr(m)%tres)) then if (segment%direction == OBC_DIRECTION_W) then - T_tmp(i,m) = segment%tr_Reg%Tr(m)%tres(i,j,k) + T_tmp(i,ntr_id) = segment%tr_Reg%Tr(m)%tres(i,j,k) else - T_tmp(i+1,m) = segment%tr_Reg%Tr(m)%tres(i,j,k) + T_tmp(i+1,ntr_id) = segment%tr_Reg%Tr(m)%tres(i,j,k) endif else if (segment%direction == OBC_DIRECTION_W) then - T_tmp(i,m) = segment%tr_Reg%Tr(m)%OBC_inflow_conc + T_tmp(i,ntr_id) = segment%tr_Reg%Tr(m)%OBC_inflow_conc else - T_tmp(i+1,m) = segment%tr_Reg%Tr(m)%OBC_inflow_conc + T_tmp(i+1,ntr_id) = segment%tr_Reg%Tr(m)%OBC_inflow_conc endif endif enddo @@ -515,69 +543,71 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & endif enddo + do m=1,ntr - if (usePPM) then - do m=1,ntr ; do I=is-1,ie - ! centre cell depending on upstream direction - if (uhh(I) >= 0.0) then - i_up = i - else - i_up = i+1 - endif - - ! Implementation of PPM-H3 - Tp = T_tmp(i_up+1,m) ; Tc = T_tmp(i_up,m) ; Tm = T_tmp(i_up-1,m) + if ((advect_schemes(m) == ADVECT_PPM) .or. (advect_schemes(m) == ADVECT_PPMH3)) then + do I=is-1,ie + ! centre cell depending on upstream direction + if (uhh(I) >= 0.0) then + i_up = i + else + i_up = i+1 + endif - if (useHuynh) then - aL = ( 5.*Tc + ( 2.*Tm - Tp ) )/6. ! H3 estimate - aL = max( min(Tc,Tm), aL) ; aL = min( max(Tc,Tm), aL) ! Bound - aR = ( 5.*Tc + ( 2.*Tp - Tm ) )/6. ! H3 estimate - aR = max( min(Tc,Tp), aR) ; aR = min( max(Tc,Tp), aR) ! Bound - else - aL = 0.5 * ((Tm + Tc) + (slope_x(i_up-1,m) - slope_x(i_up,m)) / 3.) - aR = 0.5 * ((Tc + Tp) + (slope_x(i_up,m) - slope_x(i_up+1,m)) / 3.) - endif + ! Implementation of PPM-H3 + Tp = T_tmp(i_up+1,m) ; Tc = T_tmp(i_up,m) ; Tm = T_tmp(i_up-1,m) + + if (advect_schemes(m) == ADVECT_PPMH3) then + aL = ( 5.*Tc + ( 2.*Tm - Tp ) )/6. ! H3 estimate + aL = max( min(Tc,Tm), aL) ; aL = min( max(Tc,Tm), aL) ! Bound + aR = ( 5.*Tc + ( 2.*Tp - Tm ) )/6. ! H3 estimate + aR = max( min(Tc,Tp), aR) ; aR = min( max(Tc,Tp), aR) ! Bound + else + aL = 0.5 * ((Tm + Tc) + (slope_x(i_up-1,m) - slope_x(i_up,m)) / 3.) + aR = 0.5 * ((Tc + Tp) + (slope_x(i_up,m) - slope_x(i_up+1,m)) / 3.) + endif - dA = aR - aL ; mA = 0.5*( aR + aL ) - if (G%mask2dCu(I_up,j)*G%mask2dCu(I_up-1,j)*(Tp-Tc)*(Tc-Tm) <= 0.) then - aL = Tc ; aR = Tc ! PCM for local extremum and bounadry cells - elseif ( dA*(Tc-mA) > (dA*dA)/6. ) then - aL = 3.*Tc - 2.*aR - elseif ( dA*(Tc-mA) < - (dA*dA)/6. ) then - aR = 3.*Tc - 2.*aL - endif + dA = aR - aL ; mA = 0.5*( aR + aL ) + if (G%mask2dCu(I_up,j)*G%mask2dCu(I_up-1,j)*(Tp-Tc)*(Tc-Tm) <= 0.) then + aL = Tc ; aR = Tc ! PCM for local extrema and boundary cells + elseif ( dA*(Tc-mA) > (dA*dA)/6. ) then + aL = (3.*Tc) - 2.*aR + elseif ( dA*(Tc-mA) < - (dA*dA)/6. ) then + aR = (3.*Tc) - 2.*aL + endif - a6 = 6.*Tc - 3. * (aR + aL) ! Curvature + a6 = 6.*Tc - 3. * (aR + aL) ! Curvature - if (uhh(I) >= 0.0) then - flux_x(I,j,m) = uhh(I)*( aR - 0.5 * CFL(I) * ( & - ( aR - aL ) - a6 * ( 1. - 2./3. * CFL(I) ) ) ) - else - flux_x(I,j,m) = uhh(I)*( aL + 0.5 * CFL(I) * ( & - ( aR - aL ) + a6 * ( 1. - 2./3. * CFL(I) ) ) ) - endif - enddo ; enddo - else ! PLM - do m=1,ntr ; do I=is-1,ie - if (uhh(I) >= 0.0) then - ! Indirect implementation of PLM - !aL = Tr(m)%t(i,j,k) - 0.5 * slope_x(i,m) - !aR = Tr(m)%t(i,j,k) + 0.5 * slope_x(i,m) - !flux_x(I,j,m) = uhh(I)*( aR - 0.5 * (aR-aL) * CFL(I) ) - ! Alternative implementation of PLM - Tc = T_tmp(i,m) - flux_x(I,j,m) = uhh(I)*( Tc + 0.5 * slope_x(i,m) * ( 1. - CFL(I) ) ) - else - ! Indirect implementation of PLM - !aL = Tr(m)%t(i+1,j,k) - 0.5 * slope_x(i+1,m) - !aR = Tr(m)%t(i+1,j,k) + 0.5 * slope_x(i+1,m) - !flux_x(I,j,m) = uhh(I)*( aL + 0.5 * (aR-aL) * CFL(I) ) - ! Alternative implementation of PLM - Tc = T_tmp(i+1,m) - flux_x(I,j,m) = uhh(I)*( Tc - 0.5 * slope_x(i+1,m) * ( 1. - CFL(I) ) ) - endif - enddo ; enddo - endif ! usePPM + if (uhh(I) >= 0.0) then + flux_x(I,j,m) = uhh(I)*( aR - 0.5 * CFL(I) * ( & + ( aR - aL ) - a6 * ( 1. - 2./3. * CFL(I) ) ) ) + else + flux_x(I,j,m) = uhh(I)*( aL + 0.5 * CFL(I) * ( & + ( aR - aL ) + a6 * ( 1. - 2./3. * CFL(I) ) ) ) + endif + enddo + else ! PLM + do I=is-1,ie + if (uhh(I) >= 0.0) then + ! Indirect implementation of PLM + !aL = Tr(m)%t(i,j,k) - 0.5 * slope_x(i,m) + !aR = Tr(m)%t(i,j,k) + 0.5 * slope_x(i,m) + !flux_x(I,j,m) = uhh(I)*( aR - 0.5 * (aR-aL) * CFL(I) ) + ! Alternative implementation of PLM + Tc = T_tmp(i,m) + flux_x(I,j,m) = uhh(I)*( Tc + 0.5 * slope_x(i,m) * ( 1. - CFL(I) ) ) + else + ! Indirect implementation of PLM + !aL = Tr(m)%t(i+1,j,k) - 0.5 * slope_x(i+1,m) + !aR = Tr(m)%t(i+1,j,k) + 0.5 * slope_x(i+1,m) + !flux_x(I,j,m) = uhh(I)*( aL + 0.5 * (aR-aL) * CFL(I) ) + ! Alternative implementation of PLM + Tc = T_tmp(i+1,m) + flux_x(I,j,m) = uhh(I)*( Tc - 0.5 * slope_x(i+1,m) * ( 1. - CFL(I) ) ) + endif + enddo + endif ! usePPM + enddo if (associated(OBC)) then ; if (OBC%OBC_pe) then if (OBC%specified_u_BCs_exist_globally .or. OBC%open_u_BCs_exist_globally) then @@ -593,10 +623,11 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & (uhr(I,j,k) < 0.0) .and. (segment%direction == OBC_DIRECTION_E)) then uhh(I) = uhr(I,j,k) ! should the reservoir evolve for this case Kate ?? - Nope - do m=1,ntr + do m=1,segment%tr_Reg%ntseg + ntr_id = segment%tr_reg%Tr(m)%ntr_index if (allocated(segment%tr_Reg%Tr(m)%tres)) then - flux_x(I,j,m) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) - else ; flux_x(I,j,m) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc ; endif + flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) + else ; flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc ; endif enddo endif endif @@ -616,10 +647,11 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & if ((uhr(I,j,k) > 0.0) .and. (G%mask2dT(i,j) < 0.5) .or. & (uhr(I,j,k) < 0.0) .and. (G%mask2dT(i+1,j) < 0.5)) then uhh(I) = uhr(I,j,k) - do m=1,ntr + do m=1,segment%tr_Reg%ntseg + ntr_id = segment%tr_reg%Tr(m)%ntr_index if (allocated(segment%tr_Reg%Tr(m)%tres)) then - flux_x(I,j,m) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) - else; flux_x(I,j,m) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc; endif + flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) + else; flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc; endif enddo endif endif @@ -648,6 +680,17 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & endif enddo + ! Update do_i so that nothing changes outside of the OBC (problem for interior OBCs only) + if (associated(OBC)) then + if ((.not.OBC%exterior_OBC_bug) .and. (OBC%OBC_pe) .and. & + (OBC%specified_u_BCs_exist_globally .or. OBC%open_u_BCs_exist_globally)) then + ! OBC_DIRECTION_E / OBC_DIRECTION_W on the west / east edge + do i=is,ie ; if ((OBC%segnum_u(I-1,j) > 0) .or. (OBC%segnum_u(I,j) < 0)) & + do_i(i,j) = .false. + enddo + endif + endif + ! update tracer concentration from i-flux and save some diagnostics do m=1,ntr @@ -662,7 +705,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & enddo ! diagnostics - if (associated(Tr(m)%ad_x)) then ; do i=is,ie ; if (do_i(i,j)) then + if (associated(Tr(m)%ad_x)) then ; do I=is-1,ie ; if (do_i(i,j) .or. do_i(i+1,j)) then Tr(m)%ad_x(I,j,k) = Tr(m)%ad_x(I,j,k) + flux_x(I,j,m)*Idt endif ; enddo ; endif @@ -670,28 +713,33 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ! division by areaT to get into W/m2 for heat and kg/(s*m2) for salt. if (associated(Tr(m)%advection_xy)) then do i=is,ie ; if (do_i(i,j)) then - Tr(m)%advection_xy(i,j,k) = Tr(m)%advection_xy(i,j,k) - (flux_x(I,j,m) - flux_x(I-1,j,m)) * & + Tr(m)%advection_xy(i,j,k) = Tr(m)%advection_xy(i,j,k) - & + (flux_x(I,j,m) - flux_x(I-1,j,m)) * & Idt * G%IareaT(i,j) endif ; enddo endif enddo - endif - + endif ; enddo ! End of j-loop. - enddo ! End of j-loop. + ! Do user controlled underflow of the tracer concentrations. + do m=1,ntr ; if (Tr(m)%conc_underflow > 0.0) then + do j=js,je ; do i=is,ie + if (abs(Tr(m)%t(i,j,k)) < Tr(m)%conc_underflow) Tr(m)%t(i,j,k) = 0.0 + enddo ; enddo + endif ; enddo ! compute ad2d_x diagnostic outside above j-loop so as to make the summation ordered when OMP is active. !$OMP ordered - do j=js,je ; if (domore_u_initial(j,k)) then - do m=1,ntr - if (associated(Tr(m)%ad2d_x)) then ; do i=is,ie ; if (do_i(i,j)) then + do m=1,ntr ; if (associated(Tr(m)%ad2d_x)) then + do j=js,je ; if (domore_u_initial(j,k)) then + do I=is-1,ie ; if (do_i(i,j) .or. do_i(i+1,j)) then Tr(m)%ad2d_x(I,j) = Tr(m)%ad2d_x(I,j) + flux_x(I,j,m)*Idt - endif ; enddo ; endif - enddo - endif ; enddo ! End of j-loop. + endif ; enddo + endif ; enddo + endif ; enddo ! End of m-loop. !$OMP end ordered end subroutine advect_x @@ -699,9 +747,10 @@ end subroutine advect_x !> This subroutine does 1-d flux-form advection using a monotonic piecewise !! linear scheme. subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & - is, ie, js, je, k, G, GV, US, usePPM, useHuynh) + is, ie, js, je, k, G, GV, US, advect_schemes) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + integer, intent(in) :: ntr !< The number of tracers type(tracer_type), dimension(ntr), intent(inout) :: Tr !< The array of registered tracers to work on real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: hprev !< cell volume at the end of previous !! tracer change [H L2 ~> m3 or kg] @@ -713,16 +762,13 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & logical, dimension(SZJB_(G),SZK_(GV)), intent(inout) :: domore_v !< If true, there is more advection to be !! done in this v-row real, intent(in) :: Idt !< The inverse of dt [T-1 ~> s-1] - integer, intent(in) :: ntr !< The number of tracers integer, intent(in) :: is !< The starting tracer i-index to work on integer, intent(in) :: ie !< The ending tracer i-index to work on integer, intent(in) :: js !< The starting tracer j-index to work on integer, intent(in) :: je !< The ending tracer j-index to work on integer, intent(in) :: k !< The k-level to work on type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - logical, intent(in) :: usePPM !< If true, use PPM instead of PLM - logical, intent(in) :: useHuynh !< If true, use the Huynh scheme - !! for PPM interface values + integer, dimension(ntr), intent(in) :: advect_schemes !< list of advection schemes to use real, dimension(SZI_(G),ntr,SZJ_(G)) :: & slope_y ! The concentration slope per grid point [conc]. @@ -730,8 +776,6 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & flux_y ! The tracer flux across a boundary [H L2 conc ~> m3 conc or kg conc]. real, dimension(SZI_(G),ntr,SZJB_(G)) :: & T_tmp ! The copy of the tracer concentration at constant i,k [conc]. - real :: maxslope ! The maximum concentration slope per grid point - ! consistent with monotonicity [conc]. real :: vhh(SZI_(G),SZJB_(G)) ! The meridional flux that occurs during the ! current iteration [H L2 ~> m3 or kg]. real :: hup, hlos ! hup is the upwind volume, hlos is the @@ -744,22 +788,33 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & CFL ! The absolute value of the advective upwind-cell CFL number [nondim]. real :: min_h ! The minimum thickness that can be realized during ! any of the passes [H ~> m or kg m-2]. - real :: tiny_h ! The smallest numerically invertable thickness [H ~> m or kg m-2]. + real :: tiny_h ! The smallest numerically invertible thickness [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: aR, aL ! Reconstructed tracer concentrations at the right and left edges [conc] + real :: dMx ! Difference between the maximum of the surrounding cell concentrations and + ! the value in the cell whose reconstruction is being found [conc] + real :: dMn ! Difference between the tracer average in the cell whose reconstruction + ! is being found and the minimum of the surrounding values [conc] + real :: Tp, Tc, Tm ! Tracer concentrations around the upstream cell [conc] + real :: dA ! Difference between the reconstruction tracer edge values [conc] + real :: mA ! Average of the reconstruction tracer edge values [conc] + real :: a6 ! Curvature of the reconstruction tracer values [conc] logical :: do_j_tr(SZJ_(G)) ! If true, calculate the tracer profiles. - logical :: do_i(SZIB_(G), SZJ_(G)) ! If true, work on given points. - logical :: do_any_i - integer :: i, j, j2, m, n, j_up, stencil - real :: aR, aL, dMx, dMn, Tp, Tc, Tm, dA, mA, a6 - real :: fac1,v_L_in,v_L_out ! terms used for time-stepping OBC reservoirs - type(OBC_segment_type), pointer :: segment=>NULL() + logical :: do_i(SZI_(G), SZJ_(G)) ! If true, work on given points. logical :: usePLMslope + integer :: i, j, j2, m, n, j_up, stencil, ntr_id + type(OBC_segment_type), pointer :: segment=>NULL() + logical :: domore_v_initial(SZJB_(G)) ! Initial state of domore_v - usePLMslope = .not. (usePPM .and. useHuynh) + usePLMslope = .false. ! stencil for calculating slope values stencil = 1 - if (usePPM .and. .not. useHuynh) stencil = 2 + do m = 1,ntr + if ((advect_schemes(m) == ADVECT_PLM) .or. (advect_schemes(m) == ADVECT_PPM)) & + usePLMslope = .true. + if (advect_schemes(m) == ADVECT_PPM) stencil = 2 + enddo min_h = 0.1*GV%Angstrom_H tiny_h = tiny(min_h) @@ -776,7 +831,10 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & ! since that doesn't need a wider stencil with the PPM advection scheme, but ! this would require an additional loop, etc. do_j_tr(:) = .false. - do J=js-1,je ; if (domore_v(J,k)) then ; do j2=1-stencil,stencil ; do_j_tr(j+j2) = .true. ; enddo ; endif ; enddo + do J=js-1,je + if (domore_v(J,k)) then ; do j2=1-stencil,stencil ; do_j_tr(j+j2) = .true. ; enddo ; endif + enddo + domore_v_initial(:) = domore_v(:,k) ! Calculate the j-direction profiles (slopes) of each tracer that ! is being advected. @@ -820,18 +878,19 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & if (segment%is_N_or_S) then if (i>=segment%HI%isd .and. i<=segment%HI%ied) then J = segment%HI%JsdB - do m = 1,ntr ! replace tracers with OBC values + do m = 1,segment%tr_Reg%ntseg ! replace tracers with OBC values + ntr_id = segment%tr_reg%Tr(m)%ntr_index if (allocated(segment%tr_Reg%Tr(m)%tres)) then if (segment%direction == OBC_DIRECTION_S) then - T_tmp(i,m,j) = segment%tr_Reg%Tr(m)%tres(i,j,k) + T_tmp(i,ntr_id,j) = segment%tr_Reg%Tr(m)%tres(i,j,k) else - T_tmp(i,m,j+1) = segment%tr_Reg%Tr(m)%tres(i,j,k) + T_tmp(i,ntr_id,j+1) = segment%tr_Reg%Tr(m)%tres(i,j,k) endif else if (segment%direction == OBC_DIRECTION_S) then - T_tmp(i,m,j) = segment%tr_Reg%Tr(m)%OBC_inflow_conc + T_tmp(i,ntr_id,j) = segment%tr_Reg%Tr(m)%OBC_inflow_conc else - T_tmp(i,m,j+1) = segment%tr_Reg%Tr(m)%OBC_inflow_conc + T_tmp(i,ntr_id,j+1) = segment%tr_Reg%Tr(m)%OBC_inflow_conc endif endif enddo @@ -888,68 +947,71 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & endif enddo - if (usePPM) then - do m=1,ntr ; do i=is,ie - ! centre cell depending on upstream direction - if (vhh(i,J) >= 0.0) then - j_up = j - else - j_up = j + 1 - endif + do m=1,ntr - ! Implementation of PPM-H3 - Tp = T_tmp(i,m,j_up+1) ; Tc = T_tmp(i,m,j_up) ; Tm = T_tmp(i,m,j_up-1) + if ((advect_schemes(m) == ADVECT_PPM) .or. (advect_schemes(m) == ADVECT_PPMH3)) then + do i=is,ie + ! centre cell depending on upstream direction + if (vhh(i,J) >= 0.0) then + j_up = j + else + j_up = j + 1 + endif - if (useHuynh) then - aL = ( 5.*Tc + ( 2.*Tm - Tp ) )/6. ! H3 estimate - aL = max( min(Tc,Tm), aL) ; aL = min( max(Tc,Tm), aL) ! Bound - aR = ( 5.*Tc + ( 2.*Tp - Tm ) )/6. ! H3 estimate - aR = max( min(Tc,Tp), aR) ; aR = min( max(Tc,Tp), aR) ! Bound - else - aL = 0.5 * ((Tm + Tc) + (slope_y(i,m,j_up-1) - slope_y(i,m,j_up)) / 3.) - aR = 0.5 * ((Tc + Tp) + (slope_y(i,m,j_up) - slope_y(i,m,j_up+1)) / 3.) - endif + ! Implementation of PPM-H3 + Tp = T_tmp(i,m,j_up+1) ; Tc = T_tmp(i,m,j_up) ; Tm = T_tmp(i,m,j_up-1) + + if (advect_schemes(m) == ADVECT_PPMH3) then + aL = ( 5.*Tc + ( 2.*Tm - Tp ) )/6. ! H3 estimate + aL = max( min(Tc,Tm), aL) ; aL = min( max(Tc,Tm), aL) ! Bound + aR = ( 5.*Tc + ( 2.*Tp - Tm ) )/6. ! H3 estimate + aR = max( min(Tc,Tp), aR) ; aR = min( max(Tc,Tp), aR) ! Bound + else + aL = 0.5 * ((Tm + Tc) + (slope_y(i,m,j_up-1) - slope_y(i,m,j_up)) / 3.) + aR = 0.5 * ((Tc + Tp) + (slope_y(i,m,j_up) - slope_y(i,m,j_up+1)) / 3.) + endif - dA = aR - aL ; mA = 0.5*( aR + aL ) - if (G%mask2dCv(i,J_up)*G%mask2dCv(i,J_up-1)*(Tp-Tc)*(Tc-Tm) <= 0.) then - aL = Tc ; aR = Tc ! PCM for local extremum and bounadry cells - elseif ( dA*(Tc-mA) > (dA*dA)/6. ) then - aL = 3.*Tc - 2.*aR - elseif ( dA*(Tc-mA) < - (dA*dA)/6. ) then - aR = 3.*Tc - 2.*aL - endif + dA = aR - aL ; mA = 0.5*( aR + aL ) + if (G%mask2dCv(i,J_up)*G%mask2dCv(i,J_up-1)*(Tp-Tc)*(Tc-Tm) <= 0.) then + aL = Tc ; aR = Tc ! PCM for local extrema and boundary cells + elseif ( dA*(Tc-mA) > (dA*dA)/6. ) then + aL = (3.*Tc) - 2.*aR + elseif ( dA*(Tc-mA) < - (dA*dA)/6. ) then + aR = (3.*Tc) - 2.*aL + endif - a6 = 6.*Tc - 3. * (aR + aL) ! Curvature + a6 = 6.*Tc - 3. * (aR + aL) ! Curvature - if (vhh(i,J) >= 0.0) then - flux_y(i,m,J) = vhh(i,J)*( aR - 0.5 * CFL(i) * ( & - ( aR - aL ) - a6 * ( 1. - 2./3. * CFL(I) ) ) ) - else - flux_y(i,m,J) = vhh(i,J)*( aL + 0.5 * CFL(i) * ( & - ( aR - aL ) + a6 * ( 1. - 2./3. * CFL(I) ) ) ) - endif - enddo ; enddo - else ! PLM - do m=1,ntr ; do i=is,ie - if (vhh(i,J) >= 0.0) then - ! Indirect implementation of PLM - !aL = Tr(m)%t(i,j,k) - 0.5 * slope_y(i,m,j) - !aR = Tr(m)%t(i,j,k) + 0.5 * slope_y(i,m,j) - !flux_y(i,m,J) = vhh(i,J)*( aR - 0.5 * (aR-aL) * CFL(i) ) - ! Alternative implementation of PLM - Tc = T_tmp(i,m,j) - flux_y(i,m,J) = vhh(i,J)*( Tc + 0.5 * slope_y(i,m,j) * ( 1. - CFL(i) ) ) - else - ! Indirect implementation of PLM - !aL = Tr(m)%t(i,j+1,k) - 0.5 * slope_y(i,m,j+1) - !aR = Tr(m)%t(i,j+1,k) + 0.5 * slope_y(i,m,j+1) - !flux_y(i,m,J) = vhh(i,J)*( aL + 0.5 * (aR-aL) * CFL(i) ) - ! Alternative implementation of PLM - Tc = T_tmp(i,m,j+1) - flux_y(i,m,J) = vhh(i,J)*( Tc - 0.5 * slope_y(i,m,j+1) * ( 1. - CFL(i) ) ) - endif - enddo ; enddo - endif ! usePPM + if (vhh(i,J) >= 0.0) then + flux_y(i,m,J) = vhh(i,J)*( aR - 0.5 * CFL(i) * ( & + ( aR - aL ) - a6 * ( 1. - 2./3. * CFL(I) ) ) ) + else + flux_y(i,m,J) = vhh(i,J)*( aL + 0.5 * CFL(i) * ( & + ( aR - aL ) + a6 * ( 1. - 2./3. * CFL(I) ) ) ) + endif + enddo + else ! PLM + do i=is,ie + if (vhh(i,J) >= 0.0) then + ! Indirect implementation of PLM + !aL = Tr(m)%t(i,j,k) - 0.5 * slope_y(i,m,j) + !aR = Tr(m)%t(i,j,k) + 0.5 * slope_y(i,m,j) + !flux_y(i,m,J) = vhh(i,J)*( aR - 0.5 * (aR-aL) * CFL(i) ) + ! Alternative implementation of PLM + Tc = T_tmp(i,m,j) + flux_y(i,m,J) = vhh(i,J)*( Tc + 0.5 * slope_y(i,m,j) * ( 1. - CFL(i) ) ) + else + ! Indirect implementation of PLM + !aL = Tr(m)%t(i,j+1,k) - 0.5 * slope_y(i,m,j+1) + !aR = Tr(m)%t(i,j+1,k) + 0.5 * slope_y(i,m,j+1) + !flux_y(i,m,J) = vhh(i,J)*( aL + 0.5 * (aR-aL) * CFL(i) ) + ! Alternative implementation of PLM + Tc = T_tmp(i,m,j+1) + flux_y(i,m,J) = vhh(i,J)*( Tc - 0.5 * slope_y(i,m,j+1) * ( 1. - CFL(i) ) ) + endif + enddo + endif ! usePPM + enddo if (associated(OBC)) then ; if (OBC%OBC_pe) then if (OBC%specified_v_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally) then @@ -965,10 +1027,13 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & if ((vhr(i,J,k) > 0.0) .and. (segment%direction == OBC_DIRECTION_S) .or. & (vhr(i,J,k) < 0.0) .and. (segment%direction == OBC_DIRECTION_N)) then vhh(i,J) = vhr(i,J,k) - do m=1,ntr - if (allocated(segment%tr_Reg%Tr(m)%t)) then - flux_y(i,m,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%tres(i,J,k) - else ; flux_y(i,m,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%OBC_inflow_conc ; endif + do m=1,segment%tr_Reg%ntseg + ntr_id = segment%tr_reg%Tr(m)%ntr_index + if (allocated(segment%tr_Reg%Tr(m)%tres)) then + flux_y(i,ntr_id,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%tres(i,J,k) + else + flux_y(i,ntr_id,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%OBC_inflow_conc + endif enddo endif enddo @@ -988,10 +1053,11 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & if ((vhr(i,J,k) > 0.0) .and. (G%mask2dT(i,j) < 0.5) .or. & (vhr(i,J,k) < 0.0) .and. (G%mask2dT(i,j+1) < 0.5)) then vhh(i,J) = vhr(i,J,k) - do m=1,ntr - if (allocated(segment%tr_Reg%Tr(m)%t)) then - flux_y(i,m,J) = vhh(i,J)*segment%tr_Reg%Tr(m)%tres(i,J,k) - else ; flux_y(i,m,J) = vhh(i,J)*segment%tr_Reg%Tr(m)%OBC_inflow_conc ; endif + do m=1,segment%tr_Reg%ntseg + ntr_id = segment%tr_reg%Tr(m)%ntr_index + if (allocated(segment%tr_Reg%Tr(m)%tres)) then + flux_y(i,ntr_id,J) = vhh(i,J)*segment%tr_Reg%Tr(m)%tres(i,J,k) + else ; flux_y(i,ntr_id,J) = vhh(i,J)*segment%tr_Reg%Tr(m)%OBC_inflow_conc ; endif enddo endif enddo @@ -1026,6 +1092,17 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & else ; do_i(i,j) = .false. ; endif enddo + ! Update do_i so that nothing changes outside of the OBC (problem for interior OBCs only) + if (associated(OBC)) then + if ((.not.OBC%exterior_OBC_bug) .and. (OBC%OBC_pe) .and. & + (OBC%specified_v_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally)) then + ! OBC_DIRECTION_N / OBC_DIRECTION_S on the south / north edge + do i=is,ie ; if ((OBC%segnum_v(i,J-1) > 0) .or. (OBC%segnum_v(i,J) < 0)) & + do_i(i,j) = .false. + enddo + endif + endif + ! update tracer and save some diagnostics do m=1,ntr do i=is,ie ; if (do_i(i,j)) then @@ -1033,16 +1110,12 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & (flux_y(i,m,J) - flux_y(i,m,J-1))) * Ihnew(i) endif ; enddo - ! diagnostics - if (associated(Tr(m)%ad_y)) then ; do i=is,ie ; if (do_i(i,j)) then - Tr(m)%ad_y(i,J,k) = Tr(m)%ad_y(i,J,k) + flux_y(i,m,J)*Idt - endif ; enddo ; endif - ! diagnose convergence of flux_y and add to convergence of flux_x. ! division by areaT to get into W/m2 for heat and kg/(s*m2) for salt. if (associated(Tr(m)%advection_xy)) then do i=is,ie ; if (do_i(i,j)) then - Tr(m)%advection_xy(i,j,k) = Tr(m)%advection_xy(i,j,k) - (flux_y(i,m,J) - flux_y(i,m,J-1))* Idt * & + Tr(m)%advection_xy(i,j,k) = Tr(m)%advection_xy(i,j,k) - & + (flux_y(i,m,J) - flux_y(i,m,J-1))* Idt * & G%IareaT(i,j) endif ; enddo endif @@ -1050,16 +1123,30 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & enddo endif ; enddo ! End of j-loop. - ! compute ad2d_y diagnostic outside above j-loop so as to make the summation ordered when OMP is active. + ! Do user controlled underflow of the tracer concentrations. + do m=1,ntr ; if (Tr(m)%conc_underflow > 0.0) then + do j=js,je ; do i=is,ie + if (abs(Tr(m)%t(i,j,k)) < Tr(m)%conc_underflow) Tr(m)%t(i,j,k) = 0.0 + enddo ; enddo + endif ; enddo + ! compute ad_y and ad2d_y diagnostic outside above j-loop so as to make the summation ordered when OMP is active. !$OMP ordered - do j=js,je ; if (do_j_tr(j)) then - do m=1,ntr - if (associated(Tr(m)%ad2d_y)) then ; do i=is,ie ; if (do_i(i,j)) then + do m=1,ntr ; if (associated(Tr(m)%ad_y)) then + do J=js-1,je ; if (domore_v_initial(J)) then + do i=is,ie ; if (do_i(i,j) .or. do_i(i,j+1)) then + Tr(m)%ad_y(i,J,k) = Tr(m)%ad_y(i,J,k) + flux_y(i,m,J)*Idt + endif ; enddo + endif ; enddo + endif ; enddo ! End of m-loop. + + do m=1,ntr ; if (associated(Tr(m)%ad2d_y)) then + do J=js-1,je ; if (domore_v_initial(J)) then + do i=is,ie ; if (do_i(i,j) .or. do_i(i,j+1)) then Tr(m)%ad2d_y(i,J) = Tr(m)%ad2d_y(i,J) + flux_y(i,m,J)*Idt - endif ; enddo ; endif - enddo - endif ; enddo ! End of j-loop. + endif ; enddo + endif ; enddo + endif ; enddo ! End of m-loop. !$OMP end ordered end subroutine advect_y @@ -1073,8 +1160,6 @@ subroutine tracer_advect_init(Time, G, US, param_file, diag, CS) type(diag_ctrl), target, intent(inout) :: diag !< regulates diagnostic output type(tracer_advect_CS), pointer :: CS !< module control structure - integer, save :: init_calls = 0 - ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_tracer_advect" ! This module's name. @@ -1095,23 +1180,20 @@ subroutine tracer_advect_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) call get_param(param_file, mdl, "TRACER_ADVECTION_SCHEME", mesg, & desc="The horizontal transport scheme for tracers:\n"//& - " PLM - Piecewise Linear Method\n"//& - " PPM:H3 - Piecewise Parabolic Method (Huyhn 3rd order)\n"// & - " PPM - Piecewise Parabolic Method (Colella-Woodward)" & - , default='PLM') - select case (trim(mesg)) - case ("PLM") - CS%usePPM = .false. - case ("PPM:H3") - CS%usePPM = .true. - CS%useHuynh = .true. - case ("PPM") - CS%usePPM = .true. - CS%useHuynh = .false. - case default - call MOM_error(FATAL, "MOM_tracer_advect, tracer_advect_init: "//& - "Unknown TRACER_ADVECTION_SCHEME = "//trim(mesg)) - end select + trim(TracerAdvectionSchemeDoc), default='PLM') + + ! Get the integer value of the tracer scheme + call set_tracer_advect_scheme(CS%default_advect_scheme, mesg) + + if (CS%default_advect_scheme == ADVECT_PPMH3) then + call get_param(param_file, mdl, "USE_HUYNH_STENCIL_BUG", & + CS%useHuynhStencilBug, & + desc="If true, use a stencil width of 2 in PPM:H3 tracer advection. " & + // "This is incorrect and will produce regressions in certain " & + // "configurations, but may be required to reproduce results in " & + // "legacy simulations.", & + default=.false.) + endif id_clock_advect = cpu_clock_id('(Ocean advect tracer)', grain=CLOCK_MODULE) id_clock_pass = cpu_clock_id('(Ocean tracer halo updates)', grain=CLOCK_ROUTINE) @@ -1137,19 +1219,19 @@ end subroutine tracer_advect_end !! !! * advect_tracer advects tracer concentrations using a combination !! of the modified flux advection scheme from Easter (Mon. Wea. Rev., -!! 1993) with tracer distributions given by the monotonic modified -!! van Leer scheme proposed by Lin et al. (Mon. Wea. Rev., 1994). +!! 1993) with tracer distributions given by the monotonic piecewise +!! parabolic method, as described in Carpenter et al. (MWR, 1990). !! This scheme conserves the total amount of tracer while avoiding -!! spurious maxima and minima of the tracer concentration. If a -!! higher order accuracy scheme is needed, suggest monotonic -!! piecewise parabolic method, as described in Carpenter et al. -!! (MWR, 1990). +!! spurious maxima and minima of the tracer concentration. +!! +!! * advect_tracer subroutine determines the volume of a layer in +!! a grid cell at the previous instance when the tracer concentration +!! was changed, so it is essential that the volume fluxes should be +!! correct. It is also important that the tracer advection occurs +!! before each calculation of the diabatic forcing. !! -!! * advect_tracer has 4 arguments, described below. This -!! subroutine determines the volume of a layer in a grid cell at the -!! previous instance when the tracer concentration was changed, so -!! it is essential that the volume fluxes should be correct. It is -!! also important that the tracer advection occurs before each -!! calculation of the diabatic forcing. +!! The advection scheme of some tracers can be set to be different +!! to that used by active tracers. + end module MOM_tracer_advect diff --git a/src/tracer/MOM_tracer_advect_schemes.F90 b/src/tracer/MOM_tracer_advect_schemes.F90 new file mode 100644 index 0000000000..2afe72ec46 --- /dev/null +++ b/src/tracer/MOM_tracer_advect_schemes.F90 @@ -0,0 +1,45 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> This module contains constants for the tracer advection schemes. +module MOM_tracer_advect_schemes + +use MOM_error_handler, only : MOM_error, FATAL + +implicit none ; public + +! The following are public parameter constants +integer, parameter :: ADVECT_PLM = 0 !< PLM advection scheme +integer, parameter :: ADVECT_PPMH3 = 1 !< PPM:H3 advection scheme +integer, parameter :: ADVECT_PPM = 2 !< PPM advection scheme + +!> Documentation for tracer advection schemes +character(len=*), parameter :: TracerAdvectionSchemeDoc = & + " PLM - Piecewise Linear Method\n"//& + " PPM:H3 - Piecewise Parabolic Method (Huyhn 3rd order)\n"// & + " PPM - Piecewise Parabolic Method (Colella-Woodward)" + +contains + +!> Numeric value of tracer_advect_scheme corresponding to scheme name +subroutine set_tracer_advect_scheme(scheme_value, advect_scheme_name) + character(len=*), intent(in) :: advect_scheme_name !< Name of the advection scheme + integer, intent(out) :: scheme_value !< Integer value of the advection scheme + + select case (trim(advect_scheme_name)) + case ("") + scheme_value = -1 + case ("PLM") + scheme_value = ADVECT_PLM + case ("PPM:H3") + scheme_value = ADVECT_PPMH3 + case ("PPM") + scheme_value = ADVECT_PPM + case default + call MOM_error(FATAL, "set_tracer_advect_scheme: "//& + "Unknown TRACER_ADVECTION_SCHEME = "//trim(advect_scheme_name)) + end select +end subroutine set_tracer_advect_scheme + +end module MOM_tracer_advect_schemes diff --git a/src/tracer/MOM_tracer_diabatic.F90 b/src/tracer/MOM_tracer_diabatic.F90 index c865e645ad..ae6d98e3a7 100644 --- a/src/tracer/MOM_tracer_diabatic.F90 +++ b/src/tracer/MOM_tracer_diabatic.F90 @@ -1,10 +1,12 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> This module contains routines that implement physical fluxes of tracers (e.g. due !! to surface fluxes or mixing). These are intended to be called from call_tracer_column_fns !! in the MOM_tracer_flow_control module. module MOM_tracer_diabatic -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_grid, only : ocean_grid_type use MOM_verticalGrid, only : verticalGrid_type use MOM_forcing_type, only : forcing @@ -56,7 +58,7 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & btm_src !< The time-integrated bottom source of the tracer [CU H ~> CU m or CU kg m-2]. real, dimension(SZI_(G)) :: & b1, & !< b1 is used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. - d1 !! d1=1-c1 is used by the tridiagonal solver, nondimensional. + d1 !! d1=1-c1 is used by the tridiagonal solver [nondim]. real :: c1(SZI_(G),SZK_(GV)) !< c1 is used by the tridiagonal solver [nondim]. real :: h_minus_dsink(SZI_(G),SZK_(GV)) !< The layer thickness minus the !! difference in sinking rates across the layer [H ~> m or kg m-2]. @@ -147,14 +149,14 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & enddo ! Now solve the tridiagonal equation for the tracer concentrations. - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then b_denom_1 = h_minus_dsink(i,1) + ea(i,j,1) + h_neglect b1(i) = 1.0 / (b_denom_1 + eb(i,j,1)) d1(i) = b_denom_1 * b1(i) h_tr = h_old(i,j,1) + h_neglect tr(i,j,1) = (b1(i)*h_tr)*tr(i,j,1) + b1(i)*sfc_src(i,j) endif ; enddo - do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,k) = eb(i,j,k-1) * b1(i) b_denom_1 = h_minus_dsink(i,k) + d1(i) * (ea(i,j,k) + sink(i,K)) + & h_neglect @@ -164,7 +166,7 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & tr(i,j,k) = b1(i) * (h_tr * tr(i,j,k) + & (ea(i,j,k) + sink(i,K)) * tr(i,j,k-1)) endif ; enddo ; enddo - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,nz) = eb(i,j,nz-1) * b1(i) b_denom_1 = h_minus_dsink(i,nz) + d1(i) * (ea(i,j,nz) + sink(i,nz)) + & h_neglect @@ -173,25 +175,25 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & tr(i,j,nz) = b1(i) * ((h_tr * tr(i,j,nz) + btm_src(i,j)) + & (ea(i,j,nz) + sink(i,nz)) * tr(i,j,nz-1)) endif ; enddo - if (present(btm_reservoir)) then ; do i=is,ie ; if (G%mask2dT(i,j)>0.5) then + if (present(btm_reservoir)) then ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then btm_reservoir(i,j) = btm_reservoir(i,j) + (sink(i,nz+1)*tr(i,j,nz)) * GV%H_to_RZ endif ; enddo ; endif - do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then tr(i,j,k) = tr(i,j,k) + c1(i,k+1)*tr(i,j,k+1) endif ; enddo ; enddo enddo else !$OMP do do j=js,je - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then h_tr = h_old(i,j,1) + h_neglect b_denom_1 = h_tr + ea(i,j,1) b1(i) = 1.0 / (b_denom_1 + eb(i,j,1)) d1(i) = h_tr * b1(i) tr(i,j,1) = (b1(i)*h_tr)*tr(i,j,1) + b1(i)*sfc_src(i,j) endif ; enddo - do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,k) = eb(i,j,k-1) * b1(i) h_tr = h_old(i,j,k) + h_neglect b_denom_1 = h_tr + d1(i) * ea(i,j,k) @@ -199,7 +201,7 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & d1(i) = b_denom_1 * b1(i) tr(i,j,k) = b1(i) * (h_tr * tr(i,j,k) + ea(i,j,k) * tr(i,j,k-1)) endif ; enddo ; enddo - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,nz) = eb(i,j,nz-1) * b1(i) h_tr = h_old(i,j,nz) + h_neglect b_denom_1 = h_tr + d1(i)*ea(i,j,nz) @@ -207,7 +209,7 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & tr(i,j,nz) = b1(i) * (( h_tr * tr(i,j,nz) + btm_src(i,j)) + & ea(i,j,nz) * tr(i,j,nz-1)) endif ; enddo - do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then tr(i,j,k) = tr(i,j,k) + c1(i,k+1)*tr(i,j,k+1) endif ; enddo ; enddo enddo @@ -253,7 +255,7 @@ subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & btm_src !< The time-integrated bottom source of the tracer [CU H ~> CU m or CU kg m-2]. real, dimension(SZI_(G)) :: & b1, & !< b1 is used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. - d1 !! d1=1-c1 is used by the tridiagonal solver, nondimensional. + d1 !! d1=1-c1 is used by the tridiagonal solver [nondim]. real :: c1(SZI_(G),SZK_(GV)) !< c1 is used by the tridiagonal solver [nondim]. real :: h_minus_dsink(SZI_(G),SZK_(GV)) !< The layer thickness minus the !! difference in sinking rates across the layer [H ~> m or kg m-2]. @@ -345,14 +347,14 @@ subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & enddo ! Now solve the tridiagonal equation for the tracer concentrations. - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then b_denom_1 = h_minus_dsink(i,1) + ent(i,j,1) + h_neglect b1(i) = 1.0 / (b_denom_1 + ent(i,j,2)) d1(i) = b_denom_1 * b1(i) h_tr = h_old(i,j,1) + h_neglect tr(i,j,1) = (b1(i)*h_tr)*tr(i,j,1) + b1(i)*sfc_src(i,j) endif ; enddo - do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,k) = ent(i,j,K) * b1(i) b_denom_1 = h_minus_dsink(i,k) + d1(i) * (ent(i,j,K) + sink(i,K)) + & h_neglect @@ -362,7 +364,7 @@ subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & tr(i,j,k) = b1(i) * (h_tr * tr(i,j,k) + & (ent(i,j,K) + sink(i,K)) * tr(i,j,k-1)) endif ; enddo ; enddo - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,nz) = ent(i,j,nz) * b1(i) b_denom_1 = h_minus_dsink(i,nz) + d1(i) * (ent(i,j,nz) + sink(i,nz)) + & h_neglect @@ -371,25 +373,25 @@ subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & tr(i,j,nz) = b1(i) * ((h_tr * tr(i,j,nz) + btm_src(i,j)) + & (ent(i,j,nz) + sink(i,nz)) * tr(i,j,nz-1)) endif ; enddo - if (present(btm_reservoir)) then ; do i=is,ie ; if (G%mask2dT(i,j)>0.5) then + if (present(btm_reservoir)) then ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then btm_reservoir(i,j) = btm_reservoir(i,j) + (sink(i,nz+1)*tr(i,j,nz)) * GV%H_to_RZ endif ; enddo ; endif - do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then tr(i,j,k) = tr(i,j,k) + c1(i,k+1)*tr(i,j,k+1) endif ; enddo ; enddo enddo else !$OMP do do j=js,je - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then h_tr = h_old(i,j,1) + h_neglect b_denom_1 = h_tr + ent(i,j,1) b1(i) = 1.0 / (b_denom_1 + ent(i,j,2)) d1(i) = h_tr * b1(i) tr(i,j,1) = (b1(i)*h_tr)*tr(i,j,1) + b1(i)*sfc_src(i,j) endif ; enddo - do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,k) = ent(i,j,K) * b1(i) h_tr = h_old(i,j,k) + h_neglect b_denom_1 = h_tr + d1(i) * ent(i,j,K) @@ -397,7 +399,7 @@ subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & d1(i) = b_denom_1 * b1(i) tr(i,j,k) = b1(i) * (h_tr * tr(i,j,k) + ent(i,j,K) * tr(i,j,k-1)) endif ; enddo ; enddo - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,nz) = ent(i,j,nz) * b1(i) h_tr = h_old(i,j,nz) + h_neglect b_denom_1 = h_tr + d1(i)*ent(i,j,nz) @@ -405,7 +407,7 @@ subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & tr(i,j,nz) = b1(i) * (( h_tr * tr(i,j,nz) + btm_src(i,j)) + & ent(i,j,nz) * tr(i,j,nz-1)) endif ; enddo - do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then tr(i,j,k) = tr(i,j,k) + c1(i,k+1)*tr(i,j,k+1) endif ; enddo ; enddo enddo @@ -465,7 +467,7 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim real :: hGrounding(maxGroundings) ! The remaining fresh water flux that was not able to be ! supplied from a column that grounded out [H ~> m or kg m-2] logical :: update_h - integer :: i, j, is, ie, js, je, k, nz, n, nsw + integer :: i, j, is, ie, js, je, k, nz character(len=45) :: mesg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -633,9 +635,9 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim enddo if (numberOfGroundings - maxGroundings > 0) then - write(mesg, '(i4)') numberOfGroundings - maxGroundings + write(mesg, '(I0)') numberOfGroundings - maxGroundings call MOM_error(WARNING, "MOM_tracer_vertical.F90, applyTracerBoundaryFluxesInOut(): "//& - trim(mesg) // " groundings remaining") + trim(mesg) // " groundings remaining", all_print=.true.) endif endif diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index 2ae72a3270..a5f11d1664 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -1,23 +1,28 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Orchestrates the registration and calling of tracer packages module MOM_tracer_flow_control -! This file is part of MOM6. See LICENSE.md for the license. - +use MOM_coms, only : EFP_type, assignment(=), EFP_to_real, real_to_EFP, EFP_sum_across_PEs use MOM_diag_mediator, only : time_type, diag_ctrl use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : get_param, log_version, param_file_type, close_param_file -use MOM_forcing_type, only : forcing, optics_type -use MOM_get_input, only : Get_MOM_input -use MOM_grid, only : ocean_grid_type -use MOM_hor_index, only : hor_index_type +use MOM_file_parser, only : get_param, log_version, param_file_type, close_param_file +use MOM_forcing_type, only : forcing, optics_type +use MOM_get_input, only : Get_MOM_input +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_interface_heights, only : convert_MLD_to_ML_thickness +use MOM_CVMix_KPP, only : KPP_CS use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : MOM_restart_CS -use MOM_sponge, only : sponge_CS -use MOM_ALE_sponge, only : ALE_sponge_CS +use MOM_restart, only : MOM_restart_CS +use MOM_sponge, only : sponge_CS +use MOM_ALE_sponge, only : ALE_sponge_CS use MOM_tracer_registry, only : tracer_registry_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface, thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type #include ! Add references to other user-provide tracer modules here. @@ -36,6 +41,10 @@ module MOM_tracer_flow_control use ideal_age_example, only : register_ideal_age_tracer, initialize_ideal_age_tracer use ideal_age_example, only : ideal_age_tracer_column_physics, ideal_age_tracer_surface_state use ideal_age_example, only : ideal_age_stock, ideal_age_example_end, ideal_age_tracer_CS +use MARBL_tracers, only : register_MARBL_tracers, initialize_MARBL_tracers +use MARBL_tracers, only : MARBL_tracers_column_physics, MARBL_tracers_set_forcing +use MARBL_tracers, only : MARBL_tracers_surface_state, MARBL_tracers_get +use MARBL_tracers, only : MARBL_tracers_stock, MARBL_tracers_end, MARBL_tracers_CS use regional_dyes, only : register_dye_tracer, initialize_dye_tracer use regional_dyes, only : dye_tracer_column_physics, dye_tracer_surface_state use regional_dyes, only : dye_stock, regional_dyes_end, dye_tracer_CS @@ -43,7 +52,7 @@ module MOM_tracer_flow_control use MOM_OCMIP2_CFC, only : OCMIP2_CFC_column_physics, OCMIP2_CFC_surface_state use MOM_OCMIP2_CFC, only : OCMIP2_CFC_stock, OCMIP2_CFC_end, OCMIP2_CFC_CS use MOM_CFC_cap, only : register_CFC_cap, initialize_CFC_cap -use MOM_CFC_cap, only : CFC_cap_column_physics, CFC_cap_surface_state +use MOM_CFC_cap, only : CFC_cap_column_physics, CFC_cap_set_forcing use MOM_CFC_cap, only : CFC_cap_stock, CFC_cap_end, CFC_cap_CS use oil_tracer, only : register_oil_tracer, initialize_oil_tracer use oil_tracer, only : oil_tracer_column_physics, oil_tracer_surface_state @@ -58,6 +67,7 @@ module MOM_tracer_flow_control use MOM_generic_tracer, only : MOM_generic_tracer_column_physics, MOM_generic_tracer_surface_state use MOM_generic_tracer, only : end_MOM_generic_tracer, MOM_generic_tracer_get, MOM_generic_flux_init use MOM_generic_tracer, only : MOM_generic_tracer_stock, MOM_generic_tracer_min_max, MOM_generic_tracer_CS +use MOM_generic_tracer, only : register_MOM_generic_tracer_segments use pseudo_salt_tracer, only : register_pseudo_salt_tracer, initialize_pseudo_salt_tracer use pseudo_salt_tracer, only : pseudo_salt_tracer_column_physics, pseudo_salt_tracer_surface_state use pseudo_salt_tracer, only : pseudo_salt_stock, pseudo_salt_tracer_end, pseudo_salt_tracer_CS @@ -73,6 +83,7 @@ module MOM_tracer_flow_control public call_tracer_register, tracer_flow_control_init, call_tracer_set_forcing public call_tracer_column_fns, call_tracer_surface_state, call_tracer_stocks public call_tracer_flux_init, get_chl_from_model, tracer_flow_control_end +public call_tracer_register_obc_segments !> The control structure for orchestrating the calling of tracer packages type, public :: tracer_flow_control_CS ; private @@ -81,6 +92,7 @@ module MOM_tracer_flow_control logical :: use_ISOMIP_tracer = .false. !< If true, use the ISOMPE_tracer package logical :: use_RGC_tracer =.false. !< If true, use the RGC_tracer package logical :: use_ideal_age = .false. !< If true, use the ideal age tracer package + logical :: use_MARBL_tracers = .false. !< If true, use the MARBL tracer package logical :: use_regional_dyes = .false. !< If true, use the regional dyes tracer package logical :: use_oil = .false. !< If true, use the oil tracer package logical :: use_advection_test_tracer = .false. !< If true, use the advection_test_tracer package @@ -91,12 +103,14 @@ module MOM_tracer_flow_control logical :: use_boundary_impulse_tracer = .false. !< If true, use the boundary impulse tracer package logical :: use_dyed_obc_tracer = .false. !< If true, use the dyed OBC tracer package logical :: use_nw2_tracers = .false. !< If true, use the NW2 tracer package + logical :: get_chl_from_MARBL = .false. !< If true, use the MARBL-provided Chl for shortwave penetration !>@{ Pointers to the control strucures for the tracer packages type(USER_tracer_example_CS), pointer :: USER_tracer_example_CSp => NULL() type(DOME_tracer_CS), pointer :: DOME_tracer_CSp => NULL() type(ISOMIP_tracer_CS), pointer :: ISOMIP_tracer_CSp => NULL() type(RGC_tracer_CS), pointer :: RGC_tracer_CSp => NULL() type(ideal_age_tracer_CS), pointer :: ideal_age_tracer_CSp => NULL() + type(MARBL_tracers_CS), pointer :: MARBL_tracers_CSp => NULL() type(dye_tracer_CS), pointer :: dye_tracer_CSp => NULL() type(oil_tracer_CS), pointer :: oil_tracer_CSp => NULL() type(advection_test_tracer_CS), pointer :: advection_test_tracer_CSp => NULL() @@ -112,6 +126,7 @@ module MOM_tracer_flow_control contains + !> This subroutine carries out a series of calls to initialize the air-sea !! tracer fluxes, but it does not record the generated indicies, and it may !! be called _before_ the ocean model has been initialized and may be called @@ -123,7 +138,7 @@ subroutine call_tracer_flux_init(verbosity) type(param_file_type) :: param_file ! A structure to parse for run-time parameters character(len=40) :: mdl = "call_tracer_flux_init" ! This module's name. - logical :: use_OCMIP_CFCs, use_MOM_generic_tracer, use_CFC_caps + logical :: use_OCMIP_CFCs, use_MOM_generic_tracer ! Determine which tracer routines with tracer fluxes are to be called. Note ! that not every tracer package is required to have a flux_init call. @@ -147,8 +162,8 @@ end subroutine call_tracer_flux_init !> This subroutine determines which tracer packages are to be used and does the calls to !! register their tracers to be advected, diffused, and read from restarts. -subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. +subroutine call_tracer_register(G, GV, US, param_file, CS, tr_Reg, restart_CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time @@ -158,10 +173,9 @@ subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the !! control structure for the tracer !! advection and diffusion module. - type(MOM_restart_CS), intent(inout) :: restart_CS !< A pointer to the restart control + type(MOM_restart_CS), intent(inout) :: restart_CS !< A pointer to the restart control !! structure. - ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_tracer_flow_control" ! This module's name. @@ -174,8 +188,7 @@ subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "USE_USER_TRACER_EXAMPLE", & - CS%use_USER_tracer_example, & + call get_param(param_file, mdl, "USE_USER_TRACER_EXAMPLE", CS%use_USER_tracer_example, & "If true, use the USER_tracer_example tracer package.", & default=.false.) call get_param(param_file, mdl, "USE_DOME_TRACER", CS%use_DOME_tracer, & @@ -190,6 +203,9 @@ subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) call get_param(param_file, mdl, "USE_IDEAL_AGE_TRACER", CS%use_ideal_age, & "If true, use the ideal_age_example tracer package.", & default=.false.) + call get_param(param_file, mdl, "USE_MARBL_TRACERS", CS%use_marbl_tracers, & + "If true, use the MARBL tracer package.", & + default=.false.) call get_param(param_file, mdl, "USE_REGIONAL_DYES", CS%use_regional_dyes, & "If true, use the regional_dyes tracer package.", & default=.false.) @@ -226,49 +242,52 @@ subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) ! tracer package registration call returns a logical false if it cannot be run ! for some reason. This then overrides the run-time selection from above. if (CS%use_USER_tracer_example) CS%use_USER_tracer_example = & - USER_register_tracer_example(HI, GV, param_file, CS%USER_tracer_example_CSp, & + USER_register_tracer_example(G, GV, US, param_file, CS%USER_tracer_example_CSp, & tr_Reg, restart_CS) if (CS%use_DOME_tracer) CS%use_DOME_tracer = & - register_DOME_tracer(HI, GV, param_file, CS%DOME_tracer_CSp, & + register_DOME_tracer(G, GV, US, param_file, CS%DOME_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_ISOMIP_tracer) CS%use_ISOMIP_tracer = & - register_ISOMIP_tracer(HI, GV, param_file, CS%ISOMIP_tracer_CSp, & + register_ISOMIP_tracer(G%HI, GV, param_file, CS%ISOMIP_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_RGC_tracer) CS%use_RGC_tracer = & - register_RGC_tracer(HI, GV, param_file, CS%RGC_tracer_CSp, & + register_RGC_tracer(G, GV, param_file, CS%RGC_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_ideal_age) CS%use_ideal_age = & - register_ideal_age_tracer(HI, GV, param_file, CS%ideal_age_tracer_CSp, & + register_ideal_age_tracer(G%HI, GV, param_file, CS%ideal_age_tracer_CSp, & tr_Reg, restart_CS) + if (CS%use_MARBL_tracers) CS%use_MARBL_tracers = & + register_MARBL_tracers(G%HI, GV, US, param_file, CS%MARBL_tracers_CSp, & + tr_Reg, restart_CS, CS%get_chl_from_MARBL) if (CS%use_regional_dyes) CS%use_regional_dyes = & - register_dye_tracer(HI, GV, US, param_file, CS%dye_tracer_CSp, & + register_dye_tracer(G%HI, GV, US, param_file, CS%dye_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_oil) CS%use_oil = & - register_oil_tracer(HI, GV, US, param_file, CS%oil_tracer_CSp, & + register_oil_tracer(G%HI, GV, US, param_file, CS%oil_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_advection_test_tracer) CS%use_advection_test_tracer = & - register_advection_test_tracer(HI, GV, param_file, CS%advection_test_tracer_CSp, & + register_advection_test_tracer(G, GV, param_file, CS%advection_test_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_OCMIP2_CFC) CS%use_OCMIP2_CFC = & - register_OCMIP2_CFC(HI, GV, param_file, CS%OCMIP2_CFC_CSp, & + register_OCMIP2_CFC(G%HI, GV, param_file, CS%OCMIP2_CFC_CSp, & tr_Reg, restart_CS) if (CS%use_CFC_cap) CS%use_CFC_cap = & - register_CFC_cap(HI, GV, param_file, CS%CFC_cap_CSp, & + register_CFC_cap(G%HI, GV, param_file, CS%CFC_cap_CSp, & tr_Reg, restart_CS) if (CS%use_MOM_generic_tracer) CS%use_MOM_generic_tracer = & - register_MOM_generic_tracer(HI, GV, param_file, CS%MOM_generic_tracer_CSp, & + register_MOM_generic_tracer(G%HI, GV, param_file, CS%MOM_generic_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_pseudo_salt_tracer) CS%use_pseudo_salt_tracer = & - register_pseudo_salt_tracer(HI, GV, param_file, CS%pseudo_salt_tracer_CSp, & + register_pseudo_salt_tracer(G%HI, GV, param_file, CS%pseudo_salt_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_boundary_impulse_tracer) CS%use_boundary_impulse_tracer = & - register_boundary_impulse_tracer(HI, GV, US, param_file, CS%boundary_impulse_tracer_CSp, & + register_boundary_impulse_tracer(G%HI, GV, US, param_file, CS%boundary_impulse_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_dyed_obc_tracer) CS%use_dyed_obc_tracer = & - register_dyed_obc_tracer(HI, GV, param_file, CS%dyed_obc_tracer_CSp, & + register_dyed_obc_tracer(G%HI, GV, param_file, CS%dyed_obc_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_nw2_tracers) CS%use_nw2_tracers = & - register_nw2_tracers(HI, GV, US, param_file, CS%nw2_tracers_CSp, tr_Reg, restart_CS) + register_nw2_tracers(G%HI, GV, US, param_file, CS%nw2_tracers_CSp, tr_Reg, restart_CS) end subroutine call_tracer_register @@ -314,36 +333,36 @@ subroutine tracer_flow_control_init(restart, day, G, GV, US, h, param_file, diag sponge_CSp) if (CS%use_DOME_tracer) & call initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS%DOME_tracer_CSp, & - sponge_CSp, param_file) + sponge_CSp, tv) if (CS%use_ISOMIP_tracer) & call initialize_ISOMIP_tracer(restart, day, G, GV, h, diag, OBC, CS%ISOMIP_tracer_CSp, & ALE_sponge_CSp) if (CS%use_RGC_tracer) & - call initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, & - CS%RGC_tracer_CSp, sponge_CSp, ALE_sponge_CSp) + call initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS%RGC_tracer_CSp, & + sponge_CSp, ALE_sponge_CSp) if (CS%use_ideal_age) & call initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS%ideal_age_tracer_CSp, & - sponge_CSp) + sponge_CSp) + if (CS%use_MARBL_tracers) & + call initialize_MARBL_tracers(restart, day, G, GV, US, h, param_file, diag, OBC, CS%MARBL_tracers_CSp, & + sponge_CSp) if (CS%use_regional_dyes) & - call initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS%dye_tracer_CSp, & - sponge_CSp) + call initialize_dye_tracer(restart, day, G, GV, US, h, diag, OBC, CS%dye_tracer_CSp, sponge_CSp, tv) if (CS%use_oil) & - call initialize_oil_tracer(restart, day, G, GV, US, h, diag, OBC, CS%oil_tracer_CSp, & - sponge_CSp) + call initialize_oil_tracer(restart, day, G, GV, US, h, diag, OBC, CS%oil_tracer_CSp, sponge_CSp) if (CS%use_advection_test_tracer) & call initialize_advection_test_tracer(restart, day, G, GV, h, diag, OBC, CS%advection_test_tracer_CSp, & sponge_CSp) if (CS%use_OCMIP2_CFC) & - call initialize_OCMIP2_CFC(restart, day, G, GV, US, h, diag, OBC, CS%OCMIP2_CFC_CSp, & - sponge_CSp) + call initialize_OCMIP2_CFC(restart, day, G, GV, US, h, diag, OBC, CS%OCMIP2_CFC_CSp, sponge_CSp) if (CS%use_CFC_cap) & call initialize_CFC_cap(restart, day, G, GV, US, h, diag, OBC, CS%CFC_cap_CSp) if (CS%use_MOM_generic_tracer) & - call initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, diag, OBC, & - CS%MOM_generic_tracer_CSp, sponge_CSp, ALE_sponge_CSp) + call initialize_MOM_generic_tracer(restart, day, G, GV, US, h, tv, param_file, diag, OBC, & + CS%MOM_generic_tracer_CSp, sponge_CSp, ALE_sponge_CSp) if (CS%use_pseudo_salt_tracer) & - call initialize_pseudo_salt_tracer(restart, day, G, GV, h, diag, OBC, CS%pseudo_salt_tracer_CSp, & + call initialize_pseudo_salt_tracer(restart, day, G, GV, US, h, diag, OBC, CS%pseudo_salt_tracer_CSp, & sponge_CSp, tv) if (CS%use_boundary_impulse_tracer) & call initialize_boundary_impulse_tracer(restart, day, G, GV, US, h, diag, OBC, CS%boundary_impulse_tracer_CSp, & @@ -355,17 +374,40 @@ subroutine tracer_flow_control_init(restart, day, G, GV, US, h, param_file, diag end subroutine tracer_flow_control_init +!> This subroutine calls all registered tracers to register their OBC segments +!! similar to register_temp_salt_segments for T&S +subroutine call_tracer_register_obc_segments(GV, param_file, CS, tr_Reg, OBC) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time + !! parameters. + type(tracer_flow_control_CS), pointer :: CS !< A pointer that is set to point to the + !! control structure for this module. + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the + !! control structure for the tracer + !! advection and diffusion module. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition + !! type specifies whether, where, + !! and what open boundary + !! conditions are used. + + if (CS%use_MOM_generic_tracer) & + call register_MOM_generic_tracer_segments(CS%MOM_generic_tracer_CSp, GV, OBC, tr_Reg, param_file) + +end subroutine call_tracer_register_obc_segments + !> This subroutine extracts the chlorophyll concentrations from the model state, if possible subroutine get_chl_from_model(Chl_array, G, GV, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(out) :: Chl_array !< The array in which to store the model's - !! Chlorophyll-A concentrations in mg m-3. + !! Chlorophyll-A concentrations [mg m-3]. type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a !! previous call to call_tracer_register. - if (CS%use_MOM_generic_tracer) then + if (CS%get_chl_from_MARBL) then + call MARBL_tracers_get('Chl', G, GV, Chl_array, CS%MARBL_tracers_CSp) + elseif (CS%use_MOM_generic_tracer) then call MOM_generic_tracer_get('chl', 'field', Chl_array, CS%MOM_generic_tracer_CSp) else call MOM_error(FATAL, "get_chl_from_model was called in a configuration "// & @@ -377,7 +419,7 @@ end subroutine get_chl_from_model !> This subroutine calls the individual tracer modules' subroutines to !! specify or read quantities related to their surface forcing. -subroutine call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G, CS) +subroutine call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US, Rho0, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the @@ -389,20 +431,28 @@ subroutine call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G type(time_type), intent(in) :: day_interval !< Length of time over which these !! fluxes will be applied. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: Rho0 !< The mean ocean density [R ~> kg m-3] type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a !! previous call to call_tracer_register. - if (.not. associated(CS)) call MOM_error(FATAL, "call_tracer_set_forcing"// & + if (.not. associated(CS)) call MOM_error(FATAL, "call_tracer_set_forcing: "// & "Module must be initialized via call_tracer_register before it is used.") ! if (CS%use_ideal_age) & ! call ideal_age_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, & ! G, CS%ideal_age_tracer_CSp) + if (CS%use_CFC_cap) & + call CFC_cap_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US, Rho0, & + CS%CFC_cap_CSp) + + if (CS%use_MARBL_tracers) & + call MARBL_tracers_set_forcing(day_start, G, CS%MARBL_tracers_CSp) end subroutine call_tracer_set_forcing !> This subroutine calls all registered tracer column physics subroutines. -subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, US, tv, optics, CS, & - debug, evap_CFL_limit, minimum_forcing_depth) +subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, mld, dt, G, GV, US, tv, optics, CS, & + debug, KPP_CSp, nonLocalTrans, evap_CFL_limit, minimum_forcing_depth, h_BL) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_old !< Layer thickness before entrainment @@ -418,7 +468,7 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, type(forcing), intent(in) :: fluxes !< A structure containing pointers to !! any possible forcing fields. !! Unused fields have NULL ptrs. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Hml !< Mixed layer depth [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: mld !< Mixed layer depth [Z ~> m] real, intent(in) :: dt !< The amount of time covered by this !! call [T ~> s] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -430,11 +480,18 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, !! a previous call to !! call_tracer_register. logical, intent(in) :: debug !< If true calculate checksums + type(KPP_CS), optional, pointer :: KPP_CSp !< KPP control structure + real, optional, intent(in) :: nonLocalTrans(:,:,:) !< Non-local transport [nondim] real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of !! the water that can be fluxed out !! of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over !! which fluxes can be applied [H ~> m or kg m-2] + real, dimension(:,:), optional, pointer :: h_BL !< Thickness of active mixing layer [H ~> m or kg m-2] + + ! Local variables + real :: Hbl(SZI_(G),SZJ_(G)) !< Boundary layer thickness [H ~> m or kg m-2] + logical :: use_h_BL if (.not. associated(CS)) call MOM_error(FATAL, "call_tracer_column_fns: "// & "Module must be initialized via call_tracer_register before it is used.") @@ -460,14 +517,28 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, G, GV, US, CS%RGC_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) - if (CS%use_ideal_age) & + if (CS%use_ideal_age) then + use_h_BL = .false. ; if (present(h_BL)) use_h_BL = associated(h_BL) + if (present(h_BL)) then + Hbl(:,:) = h_BL(:,:) + else ! This option is here mostly to support the offline tracers. + call convert_MLD_to_ML_thickness(mld, h_new, Hbl, tv, G, GV) + endif call ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, CS%ideal_age_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & - minimum_forcing_depth=minimum_forcing_depth) + minimum_forcing_depth=minimum_forcing_depth, Hbl=Hbl) + endif + if (CS%use_MARBL_tracers) & + call MARBL_tracers_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, CS%MARBL_tracers_CSp, tv, & + KPP_CSp=KPP_CSp, & + nonLocalTrans=nonLocalTrans, & + evap_CFL_limit=evap_CFL_limit, & + minimum_forcing_depth=minimum_forcing_depth) if (CS%use_regional_dyes) & call dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, US, CS%dye_tracer_CSp, & + G, GV, US, tv, CS%dye_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) if (CS%use_oil) & @@ -489,20 +560,25 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, if (CS%use_CFC_cap) & call CFC_cap_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, CS%CFC_cap_CSp, & + KPP_CSp=KPP_CSp, & + nonLocalTrans=nonLocalTrans, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) if (CS%use_MOM_generic_tracer) then if (US%QRZ_T_to_W_m2 /= 1.0) call MOM_error(FATAL, "MOM_generic_tracer_column_physics "//& "has not been written to permit dimensionsal rescaling. Set all 4 of the "//& "[QRZT]_RESCALE_POWER parameters to 0.") - call MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, dt, & + call MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, mld, dt, & G, GV, US, CS%MOM_generic_tracer_CSp, tv, optics, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) endif if (CS%use_pseudo_salt_tracer) & call pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, US, CS%pseudo_salt_tracer_CSp, tv, debug, & + G, GV, US, CS%pseudo_salt_tracer_CSp, tv, & + debug, & + KPP_CSp=KPP_CSp, & + nonLocalTrans=nonLocalTrans, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) if (CS%use_boundary_impulse_tracer) & @@ -533,12 +609,24 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, if (CS%use_RGC_tracer) & call RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, CS%RGC_tracer_CSp) - if (CS%use_ideal_age) & + if (CS%use_ideal_age) then + use_h_BL = .false. ; if (present(h_BL)) use_h_BL = associated(h_BL) + if (present(h_BL)) then + Hbl(:,:) = h_BL(:,:) + else ! This option is here mostly to support the offline tracers. + call convert_MLD_to_ML_thickness(mld, h_new, Hbl, tv, G, GV) + endif call ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, US, CS%ideal_age_tracer_CSp) + G, GV, US, CS%ideal_age_tracer_CSp, Hbl=Hbl) + endif + if (CS%use_MARBL_tracers) & + call MARBL_tracers_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, CS%MARBL_tracers_CSp, tv, & + KPP_CSp=KPP_CSp, & + nonLocalTrans=nonLocalTrans) if (CS%use_regional_dyes) & call dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, US, CS%dye_tracer_CSp) + G, GV, US, tv, CS%dye_tracer_CSp) if (CS%use_oil) & call oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, CS%oil_tracer_CSp, tv) @@ -550,17 +638,22 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, G, GV, US, CS%OCMIP2_CFC_CSp) if (CS%use_CFC_cap) & call CFC_cap_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, US, CS%CFC_cap_CSp) + G, GV, US, CS%CFC_cap_CSp, & + KPP_CSp=KPP_CSp, & + nonLocalTrans=nonLocalTrans) if (CS%use_MOM_generic_tracer) then if (US%QRZ_T_to_W_m2 /= 1.0) call MOM_error(FATAL, "MOM_generic_tracer_column_physics "//& "has not been written to permit dimensionsal rescaling. Set all 4 of the "//& "[QRZT]_RESCALE_POWER parameters to 0.") - call MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, dt, & + call MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, mld, dt, & G, GV, US, CS%MOM_generic_tracer_CSp, tv, optics) endif if (CS%use_pseudo_salt_tracer) & call pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, US, CS%pseudo_salt_tracer_CSp, tv, debug) + G, GV, US, CS%pseudo_salt_tracer_CSp, & + tv, debug, & + KPP_CSp=KPP_CSp, & + nonLocalTrans=nonLocalTrans) if (CS%use_boundary_impulse_tracer) & call boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, CS%boundary_impulse_tracer_CSp, tv, debug) @@ -582,8 +675,8 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, US, CS, stock_names, stock type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(:), intent(out) :: stock_values !< The integrated amounts of a tracer - !! on the current PE, usually in kg x concentration [kg conc]. + real, dimension(:), intent(out) :: stock_values !< The globally mass-integrated + !! amount of a tracer [kg conc]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a !! previous call to @@ -599,20 +692,29 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, US, CS, stock_names, stock logical, dimension(:), & optional, intent(inout) :: got_min_max !< Indicates whether the global min and !! max are found for each tracer - real, dimension(:), optional, intent(out) :: global_min !< The global minimum of each tracer - real, dimension(:), optional, intent(out) :: global_max !< The global maximum of each tracer - real, dimension(:), optional, intent(out) :: xgmin !< The x-position of the global minimum - real, dimension(:), optional, intent(out) :: ygmin !< The y-position of the global minimum - real, dimension(:), optional, intent(out) :: zgmin !< The z-position of the global minimum - real, dimension(:), optional, intent(out) :: xgmax !< The x-position of the global maximum - real, dimension(:), optional, intent(out) :: ygmax !< The y-position of the global maximum - real, dimension(:), optional, intent(out) :: zgmax !< The z-position of the global maximum + real, dimension(:), optional, intent(out) :: global_min !< The global minimum of each tracer [conc] + real, dimension(:), optional, intent(out) :: global_max !< The global maximum of each tracer [conc] + real, dimension(:), optional, intent(out) :: xgmin !< The x-position of the global minimum in the + !! units of G%geoLonT, often [degrees_E] or [km] + real, dimension(:), optional, intent(out) :: ygmin !< The y-position of the global minimum in the + !! units of G%geoLatT, often [degrees_N] or [km] + real, dimension(:), optional, intent(out) :: zgmin !< The z-position of the global minimum [layer] + real, dimension(:), optional, intent(out) :: xgmax !< The x-position of the global maximum in the + !! units of G%geoLonT, often [degrees_E] or [km] + real, dimension(:), optional, intent(out) :: ygmax !< The y-position of the global maximum in the + !! units of G%geoLatT, often [degrees_N] or [km] + real, dimension(:), optional, intent(out) :: zgmax !< The z-position of the global maximum [layer] ! Local variables character(len=200), dimension(MAX_FIELDS_) :: names, units character(len=200) :: set_pkg_name - real, dimension(MAX_FIELDS_) :: values - integer :: max_ns, ns_tot, ns, index, pkg, max_pkgs, nn + ! real, dimension(MAX_FIELDS_) :: values ! Globally integrated tracer amounts in a + ! new list for each tracer package [kg conc] + type(EFP_type), dimension(MAX_FIELDS_) :: values_EFP ! Globally integrated tracer amounts in a + ! new list for each tracer package [kg conc] + type(EFP_type), dimension(MAX_FIELDS_) :: stock_val_EFP ! Globally integrated tracer amounts in a + ! single master list for all tracers [kg conc] + integer :: max_ns, ns_tot, ns, index, nn, n if (.not. associated(CS)) call MOM_error(FATAL, "call_tracer_stocks: "// & "Module must be initialized via call_tracer_register before it is used.") @@ -625,80 +727,93 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, US, CS, stock_names, stock ! Add other user-provided calls here. if (CS%use_USER_tracer_example) then - ns = USER_tracer_stock(h, values, G, GV, US, CS%USER_tracer_example_CSp, & + ns = USER_tracer_stock(h, values_EFP, G, GV, CS%USER_tracer_example_CSp, & names, units, stock_index) - call store_stocks("tracer_example", ns, names, units, values, index, stock_values, & + call store_stocks("tracer_example", ns, names, units, values_EFP, index, stock_val_EFP, & set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif ! if (CS%use_DOME_tracer) then ! ns = DOME_tracer_stock(h, values, G, GV, CS%DOME_tracer_CSp, & ! names, units, stock_index) -! call store_stocks("DOME_tracer", ns, names, units, values, index, stock_values, & +! do n=1,ns ; values_EFP(n) = real_to_EFP(values(n)) ; enddo +! call store_stocks("DOME_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & ! set_pkg_name, max_ns, ns_tot, stock_names, stock_units) ! endif if (CS%use_ideal_age) then - ns = ideal_age_stock(h, values, G, GV, US, CS%ideal_age_tracer_CSp, & + ns = ideal_age_stock(h, values_EFP, G, GV, CS%ideal_age_tracer_CSp, & names, units, stock_index) - call store_stocks("ideal_age_example", ns, names, units, values, index, & - stock_values, set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + call store_stocks("ideal_age_example", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + endif + if (CS%use_MARBL_tracers) then + ns = MARBL_tracers_stock(h, values_EFP, G, GV, CS%MARBL_tracers_CSp, & + names, units, stock_index) + call store_stocks("MARBL_tracers", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif if (CS%use_regional_dyes) then - ns = dye_stock(h, values, G, GV, US, CS%dye_tracer_CSp, & - names, units, stock_index) - call store_stocks("regional_dyes", ns, names, units, values, index, & - stock_values, set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + ns = dye_stock(h, values_EFP, G, GV, CS%dye_tracer_CSp, names, units, stock_index) + call store_stocks("regional_dyes", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif if (CS%use_oil) then - ns = oil_stock(h, values, G, GV, US, CS%oil_tracer_CSp, & - names, units, stock_index) - call store_stocks("oil_tracer", ns, names, units, values, index, & - stock_values, set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + ns = oil_stock(h, values_EFP, G, GV, CS%oil_tracer_CSp, names, units, stock_index) + call store_stocks("oil_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif if (CS%use_OCMIP2_CFC) then - ns = OCMIP2_CFC_stock(h, values, G, GV, US, CS%OCMIP2_CFC_CSp, names, units, stock_index) - call store_stocks("MOM_OCMIP2_CFC", ns, names, units, values, index, stock_values, & - set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + ns = OCMIP2_CFC_stock(h, values_EFP, G, GV, CS%OCMIP2_CFC_CSp, names, units, stock_index) + call store_stocks("MOM_OCMIP2_CFC", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif if (CS%use_CFC_cap) then - ns = CFC_cap_stock(h, values, G, GV, US, CS%CFC_cap_CSp, names, units, stock_index) - call store_stocks("MOM_CFC_cap", ns, names, units, values, index, stock_values, & - set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + ns = CFC_cap_stock(h, values_EFP, G, GV, CS%CFC_cap_CSp, names, units, stock_index) + call store_stocks("MOM_CFC_cap", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif if (CS%use_advection_test_tracer) then - ns = advection_test_stock( h, values, G, GV, US, CS%advection_test_tracer_CSp, & + ns = advection_test_stock( h, values_EFP, G, GV, CS%advection_test_tracer_CSp, & names, units, stock_index ) - call store_stocks("advection_test_tracer", ns, names, units, values, index, & - stock_values, set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + ! do n=1,ns ; values_EFP(n) = real_to_EFP(values(n)) ; enddo + call store_stocks("advection_test_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif if (CS%use_MOM_generic_tracer) then - ns = MOM_generic_tracer_stock(h, values, G, GV, US, CS%MOM_generic_tracer_CSp, & + ns = MOM_generic_tracer_stock(h, values_EFP, G, GV, CS%MOM_generic_tracer_CSp, & names, units, stock_index) - call store_stocks("MOM_generic_tracer", ns, names, units, values, index, stock_values, & - set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + call store_stocks("MOM_generic_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) nn=ns_tot-ns+1 - nn=MOM_generic_tracer_min_max(nn, got_min_max, global_min, global_max, & - xgmin, ygmin, zgmin, xgmax, ygmax, zgmax ,& - G, CS%MOM_generic_tracer_CSp,names, units) + if (present(got_min_max) .and. present(global_min) .and. present(global_max)) & + nn = MOM_generic_tracer_min_max(nn, got_min_max, global_min, global_max, & + G, CS%MOM_generic_tracer_CSp, names, units, & + xgmin, ygmin, zgmin, xgmax, ygmax, zgmax) endif if (CS%use_pseudo_salt_tracer) then - ns = pseudo_salt_stock(h, values, G, GV, US, CS%pseudo_salt_tracer_CSp, & + ns = pseudo_salt_stock(h, values_EFP, G, GV, CS%pseudo_salt_tracer_CSp, & names, units, stock_index) - call store_stocks("pseudo_salt_tracer", ns, names, units, values, index, & - stock_values, set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + call store_stocks("pseudo_salt_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif if (CS%use_boundary_impulse_tracer) then - ns = boundary_impulse_stock(h, values, G, GV, US, CS%boundary_impulse_tracer_CSp, & + ns = boundary_impulse_stock(h, values_EFP, G, GV, CS%boundary_impulse_tracer_CSp, & names, units, stock_index) - call store_stocks("boundary_impulse_tracer", ns, names, units, values, index, & - stock_values, set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + call store_stocks("boundary_impulse_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif - if (ns_tot == 0) stock_values(1) = 0.0 + ! Sum the various quantities across all the processors. + if (ns_tot > 0) then + call EFP_sum_across_PEs(stock_val_EFP, ns_tot) + do n=1,ns_tot ; stock_values(n) = EFP_to_real(stock_val_EFP(n)) ; enddo + else + stock_values(1) = 0.0 + endif if (present(num_stocks)) num_stocks = ns_tot @@ -713,11 +828,13 @@ subroutine store_stocks(pkg_name, ns, names, units, values, index, stock_values, intent(in) :: names !< Diagnostic names to use for each stock. character(len=*), dimension(:), & intent(in) :: units !< Units to use in the metadata for each stock. - real, dimension(:), intent(in) :: values !< The values of the tracer stocks + type(EFP_type), dimension(:), & + intent(in) :: values !< The values of the tracer stocks [conc kg] integer, intent(in) :: index !< The integer stock index from !! stocks_constants_mod of the stock to be returned. If this is !! present and greater than 0, only a single stock can be returned. - real, dimension(:), intent(inout) :: stock_values !< The master list of stock values + type(EFP_type), dimension(:), & + intent(inout) :: stock_values !< The master list of stock values [conc kg] character(len=*), intent(inout) :: set_pkg_name !< The name of the last tracer package whose !! stocks were stored for a specific index. This is !! used to trigger an error if there are redundant stocks. @@ -733,24 +850,24 @@ subroutine store_stocks(pkg_name, ns, names, units, values, index, stock_values, integer :: n if ((index > 0) .and. (ns > 0)) then - write(ind_text,'(i8)') index + write(ind_text,'(I0)') index if (ns > 1) then call MOM_error(FATAL,"Tracer package "//trim(pkg_name)//& - " is not permitted to return more than one value when queried"//& - " for specific stock index "//trim(adjustl(ind_text))//".") + " is not permitted to return more than one value when queried "//& + "for specific stock index "//trim(ind_text)//".") elseif (ns+ns_tot > 1) then call MOM_error(FATAL,"Tracer packages "//trim(pkg_name)//" and "//& - trim(set_pkg_name)//" both attempted to set values for"//& - " specific stock index "//trim(adjustl(ind_text))//".") + trim(set_pkg_name)//" both attempted to set values for "//& + "specific stock index "//trim(ind_text)//".") else set_pkg_name = pkg_name endif endif if (ns_tot+ns > max_ns) then - write(ns_text,'(i8)') ns_tot+ns ; write(max_text,'(i8)') max_ns + write(ns_text,'(I0)') ns_tot+ns ; write(max_text,'(I0)') max_ns call MOM_error(FATAL,"Attempted to return more tracer stock values (at least "//& - trim(adjustl(ns_text))//") than the size "//trim(adjustl(max_text))//& + trim(ns_text)//") than the size "//trim(max_text)//& "of the smallest value, name, or units array.") endif @@ -765,13 +882,14 @@ end subroutine store_stocks !> This subroutine calls all registered tracer packages to enable them to !! add to the surface state returned to the coupler. These routines are optional. -subroutine call_tracer_surface_state(sfc_state, h, G, GV, CS) +subroutine call_tracer_surface_state(sfc_state, h, G, GV, US, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a !! previous call to call_tracer_register. @@ -787,6 +905,8 @@ subroutine call_tracer_surface_state(sfc_state, h, G, GV, CS) call ISOMIP_tracer_surface_state(sfc_state, h, G, GV, CS%ISOMIP_tracer_CSp) if (CS%use_ideal_age) & call ideal_age_tracer_surface_state(sfc_state, h, G, GV, CS%ideal_age_tracer_CSp) + if (CS%use_MARBL_tracers) & + call MARBL_tracers_surface_state(sfc_state, G, US, CS%MARBL_tracers_CSp) if (CS%use_regional_dyes) & call dye_tracer_surface_state(sfc_state, h, G, GV, CS%dye_tracer_CSp) if (CS%use_oil) & @@ -794,9 +914,7 @@ subroutine call_tracer_surface_state(sfc_state, h, G, GV, CS) if (CS%use_advection_test_tracer) & call advection_test_tracer_surface_state(sfc_state, h, G, GV, CS%advection_test_tracer_CSp) if (CS%use_OCMIP2_CFC) & - call OCMIP2_CFC_surface_state(sfc_state, h, G, GV, CS%OCMIP2_CFC_CSp) - if (CS%use_CFC_cap) & - call CFC_cap_surface_state(sfc_state, G, CS%CFC_cap_CSp) + call OCMIP2_CFC_surface_state(sfc_state, h, G, GV, US, CS%OCMIP2_CFC_CSp) if (CS%use_MOM_generic_tracer) & call MOM_generic_tracer_surface_state(sfc_state, h, G, GV, CS%MOM_generic_tracer_CSp) @@ -812,6 +930,7 @@ subroutine tracer_flow_control_end(CS) if (CS%use_ISOMIP_tracer) call ISOMIP_tracer_end(CS%ISOMIP_tracer_CSp) if (CS%use_RGC_tracer) call RGC_tracer_end(CS%RGC_tracer_CSp) if (CS%use_ideal_age) call ideal_age_example_end(CS%ideal_age_tracer_CSp) + if (CS%use_MARBL_tracers) call MARBL_tracers_end(CS%MARBL_tracers_CSp) if (CS%use_regional_dyes) call regional_dyes_end(CS%dye_tracer_CSp) if (CS%use_oil) call oil_tracer_end(CS%oil_tracer_CSp) if (CS%use_advection_test_tracer) call advection_test_tracer_end(CS%advection_test_tracer_CSp) diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 850480e3e6..6b1c56f642 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -1,34 +1,36 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Main routine for lateral (along surface or neutral) diffusion of tracers module MOM_tracer_hor_diff -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end -use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE -use MOM_diag_mediator, only : post_data, diag_ctrl -use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, time_type -use MOM_domains, only : sum_across_PEs, max_across_PEs -use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type -use MOM_domains, only : pass_vector -use MOM_debugging, only : hchksum, uvchksum -use MOM_diabatic_driver, only : diabatic_CS -use MOM_EOS, only : calculate_density, EOS_type, EOS_domain -use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe -use MOM_error_handler, only : MOM_set_verbosity, callTree_showQuery -use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_grid, only : ocean_grid_type -use MOM_lateral_mixing_coeffs, only : VarMix_CS -use MOM_MEKE_types, only : MEKE_type -use MOM_neutral_diffusion, only : neutral_diffusion_init, neutral_diffusion_end -use MOM_neutral_diffusion, only : neutral_diffusion_CS -use MOM_neutral_diffusion, only : neutral_diffusion_calc_coeffs, neutral_diffusion -use MOM_lateral_boundary_diffusion, only : lbd_CS, lateral_boundary_diffusion_init -use MOM_lateral_boundary_diffusion, only : lateral_boundary_diffusion -use MOM_tracer_registry, only : tracer_registry_type, tracer_type, MOM_tracer_chksum -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diag_mediator, only : post_data, diag_ctrl +use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, time_type +use MOM_domains, only : sum_across_PEs, max_across_PEs +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_domains, only : pass_vector +use MOM_debugging, only : hchksum, uvchksum +use MOM_diabatic_driver, only : diabatic_CS +use MOM_EOS, only : calculate_density, EOS_type, EOS_domain +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe +use MOM_error_handler, only : MOM_set_verbosity, callTree_showQuery +use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_lateral_mixing_coeffs, only : VarMix_CS +use MOM_MEKE_types, only : MEKE_type +use MOM_neutral_diffusion, only : neutral_diffusion_init, neutral_diffusion_end +use MOM_neutral_diffusion, only : neutral_diffusion_CS +use MOM_neutral_diffusion, only : neutral_diffusion_calc_coeffs, neutral_diffusion +use MOM_hor_bnd_diffusion, only : hbd_CS, hor_bnd_diffusion_init +use MOM_hor_bnd_diffusion, only : hor_bnd_diffusion, hor_bnd_diffusion_end +use MOM_tracer_registry, only : tracer_registry_type, tracer_type, MOM_tracer_chksum +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs, vertvisc_type +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -52,6 +54,11 @@ 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 :: KhTr_use_vert_struct !< If true, uses the equivalent barotropic structure + !! as the vertical structure of tracer diffusivity. + logical :: full_depth_khtr_min !< If true, KHTR_MIN is enforced throughout the whole water column. + !! Otherwise, KHTR_MIN is only enforced at the surface. This parameter + !! is only available when KHTR_USE_EBT_STRUCT=True and KHTR_MIN>0. logical :: Diffuse_ML_interior !< If true, diffuse along isopycnals between !! the mixed layer and the interior. logical :: check_diffusive_CFL !< If true, automatically iterate the diffusion @@ -59,13 +66,21 @@ module MOM_tracer_hor_diff !! the CFL limit is not violated. logical :: use_neutral_diffusion !< If true, use the neutral_diffusion module from within !! tracer_hor_diff. - logical :: use_lateral_boundary_diffusion !< If true, use the lateral_boundary_diffusion module from within + logical :: use_hor_bnd_diffusion !< If true, use the hor_bnd_diffusion module from within !! tracer_hor_diff. logical :: recalc_neutral_surf !< If true, recalculate the neutral surfaces if CFL has been !! exceeded + logical :: limit_bug !< If true and the answer date is 20240330 or below, use a + !! rotational symmetry breaking bug when limiting the tracer + !! properties in tracer_epipycnal_ML_diff. + integer :: answer_date !< The vintage of the order of arithmetic to use for the tracer + !! diffusion. Values of 20240330 or below recover the answers + !! from the original form of this code, while higher values use + !! mathematically equivalent expressions that recover rotational symmetry + !! when DIFFUSE_ML_TO_INTERIOR is true. type(neutral_diffusion_CS), pointer :: neutral_diffusion_CSp => NULL() !< Control structure for neutral diffusion. - type(lbd_CS), pointer :: lateral_boundary_diffusion_CSp => NULL() !< Control structure for - !! lateral boundary mixing. + type(hbd_CS), pointer :: hor_bnd_diffusion_CSp => NULL() !< Control structure for + !! horizontal boundary diffusion. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. logical :: debug !< If true, write verbose checksums for debugging purposes. @@ -86,7 +101,7 @@ module MOM_tracer_hor_diff !> A type that can be used to create arrays of pointers to 2D arrays type p2d - real, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2D array of reals + real, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2D array of reals [various] end type p2d !> A type that can be used to create arrays of pointers to 2D integer arrays type p2di @@ -103,7 +118,7 @@ module MOM_tracer_hor_diff !! using the diffusivity in CS%KhTr, or using space-dependent diffusivity. !! Multiple iterations are used (if necessary) so that there is no limit !! on the acceptable time increment. -subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online_flag, read_khdt_x, read_khdt_y) +subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_online_flag, read_khdt_x, read_khdt_y) type(ocean_grid_type), intent(inout) :: G !< Grid type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & @@ -111,6 +126,8 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online real, intent(in) :: dt !< time step [T ~> s] type(MEKE_type), intent(in) :: MEKE !< MEKE fields type(VarMix_CS), intent(in) :: VarMix !< Variable mixing type + type(vertvisc_type), intent(in) :: visc !< Structure with vertical viscosities, + !! boundary layer properties and related fields type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(tracer_hor_diff_CS), pointer :: CS !< module control structure type(tracer_registry_type), pointer :: Reg !< registered tracers @@ -123,40 +140,45 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online ! Optional inputs for offline tracer transport logical, optional, intent(in) :: do_online_flag !< If present and true, do online !! tracer transport with stored velocities. + ! The next two arguments do not appear to be used anywhere. real, dimension(SZIB_(G),SZJ_(G)), & - optional, intent(in) :: read_khdt_x !< If present, these are the zonal - !! diffusivities from previous run. + optional, intent(in) :: read_khdt_x !< If present, these are the zonal diffusivities + !! times a timestep from a previous run [L2 ~> m2] real, dimension(SZI_(G),SZJB_(G)), & - optional, intent(in) :: read_khdt_y !< If present, these are the meridional - !! diffusivities from previous run. + optional, intent(in) :: read_khdt_y !< If present, these are the meridional diffusivities + !! times a timestep from a previous run [L2 ~> m2] real, dimension(SZI_(G),SZJ_(G)) :: & Ihdxdy, & ! The inverse of the volume or mass of fluid in a layer in a ! grid cell [H-1 L-2 ~> m-3 or kg-1]. - Kh_h, & ! The tracer diffusivity averaged to tracer points [L2 T-1 ~> m2 s-1]. CFL, & ! A diffusive CFL number for each cell [nondim]. dTr ! The change in a tracer's concentration, in units of concentration [Conc]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: Kh_h + ! The tracer diffusivity averaged to tracer points [L2 T-1 ~> m2 s-1]. real, dimension(SZIB_(G),SZJ_(G)) :: & - khdt_x, & ! The value of Khtr*dt times the open face width divided by + khdt_x ! The value of Khtr*dt times the open face width divided by + ! the distance between adjacent tracer points [L2 ~> m2]. + real, dimension(SZI_(G),SZJB_(G)) :: & + khdt_y ! The value of Khtr*dt times the open face width divided by ! the distance between adjacent tracer points [L2 ~> m2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & Coef_x, & ! The coefficients relating zonal tracer differences to time-integrated ! fluxes, in [L2 ~> m2] for some schemes and [H L2 ~> m3 or kg] for others. Kh_u ! Tracer mixing coefficient at u-points [L2 T-1 ~> m2 s-1]. - real, dimension(SZI_(G),SZJB_(G)) :: & - khdt_y, & ! The value of Khtr*dt times the open face width divided by - ! the distance between adjacent tracer points [L2 ~> m2]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & Coef_y, & ! The coefficients relating meridional tracer differences to time-integrated ! fluxes, in [L2 ~> m2] for some schemes and [H L2 ~> m3 or kg] for others. Kh_v ! Tracer mixing coefficient at u-points [L2 T-1 ~> m2 s-1]. real :: khdt_max ! The local limiting value of khdt_x or khdt_y [L2 ~> m2]. - real :: max_CFL ! The global maximum of the diffusive CFL number. + real :: Coef_min ! The local limiting value of Coef_x or Coef_y, in [L2 ~> m2] for some + ! schemes and [H L2 ~> m3 or kg] for others. + real :: max_CFL ! The global maximum of the diffusive CFL number [nondim] logical :: use_VarMix, Resoln_scaled, do_online, use_Eady - integer :: S_idx, T_idx ! Indices for temperature and salinity if needed integer :: i, j, k, m, is, ie, js, je, nz, ntr, itt, num_itts - real :: I_numitts ! The inverse of the number of iterations, num_itts. + real :: I_numitts ! The inverse of the number of iterations, num_itts [nondim] real :: scale ! The fraction of khdt_x or khdt_y that is applied in this ! layer for this iteration [nondim]. real :: Idt ! The inverse of the time step [T-1 ~> s-1]. @@ -165,7 +187,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online real :: Kh_loc ! The local value of Kh [L2 T-1 ~> m2 s-1]. real :: Res_Fn ! The local value of the resolution function [nondim]. real :: Rd_dx ! The local value of deformation radius over grid-spacing [nondim]. - real :: normalize ! normalization used for diagnostic Kh_h; diffusivity averaged to h-points. + real :: normalize ! normalization used for diagnostic Kh_h [nondim]; diffusivity averaged to h-points. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -174,7 +196,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (.not. associated(CS)) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & "register_tracer must be called before tracer_hordiff.") - if (LOC(Reg)==0) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & + if (.not. associated(Reg)) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & "register_tracer must be called before tracer_hordiff.") if (Reg%ntr == 0 .or. (CS%KhTr <= 0.0 .and. .not. VarMix%use_variable_mixing)) return @@ -196,13 +218,14 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online endif ; endif CS%first_call = .false. - if (CS%debug) call MOM_tracer_chksum("Before tracer diffusion ", Reg%Tr, ntr, G) + if (CS%debug) call MOM_tracer_chksum("Before tracer diffusion ", Reg, G) use_VarMix = .false. ; Resoln_scaled = .false. ; use_Eady = .false. if (VarMix%use_variable_mixing) then 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) @@ -224,12 +247,12 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (CS%KhTr_max > 0.) Kh_loc = min(Kh_loc, CS%KhTr_max) if (Resoln_scaled) & Kh_loc = Kh_loc * 0.5*(VarMix%Res_fn_h(i,j) + VarMix%Res_fn_h(i+1,j)) - Kh_u(I,j) = max(Kh_loc, CS%KhTr_min) + Kh_u(I,j,1) = max(Kh_loc, CS%KhTr_min) if (CS%KhTr_passivity_coeff>0.) then ! Apply passivity Rd_dx=0.5*( VarMix%Rd_dx_h(i,j)+VarMix%Rd_dx_h(i+1,j) ) ! Rd/dx at u-points - Kh_loc = Kh_u(I,j)*max( CS%KhTr_passivity_min, CS%KhTr_passivity_coeff*Rd_dx ) + Kh_loc = Kh_u(I,j,1)*max( CS%KhTr_passivity_min, CS%KhTr_passivity_coeff*Rd_dx ) if (CS%KhTr_max > 0.) Kh_loc = min(Kh_loc, CS%KhTr_max) ! Re-apply max - Kh_u(I,j) = max(Kh_loc, CS%KhTr_min) ! Re-apply min + Kh_u(I,j,1) = max(Kh_loc, CS%KhTr_min) ! Re-apply min endif enddo ; enddo !$OMP parallel do default(shared) private(Kh_loc,Rd_dx) @@ -241,41 +264,41 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (CS%KhTr_max > 0.) Kh_loc = min(Kh_loc, CS%KhTr_max) if (Resoln_scaled) & Kh_loc = Kh_loc * 0.5*(VarMix%Res_fn_h(i,j) + VarMix%Res_fn_h(i,j+1)) - Kh_v(i,J) = max(Kh_loc, CS%KhTr_min) + Kh_v(i,J,1) = max(Kh_loc, CS%KhTr_min) if (CS%KhTr_passivity_coeff>0.) then ! Apply passivity Rd_dx = 0.5*( VarMix%Rd_dx_h(i,j)+VarMix%Rd_dx_h(i,j+1) ) ! Rd/dx at v-points - Kh_loc = Kh_v(i,J)*max( CS%KhTr_passivity_min, CS%KhTr_passivity_coeff*Rd_dx ) + Kh_loc = Kh_v(i,J,1)*max( CS%KhTr_passivity_min, CS%KhTr_passivity_coeff*Rd_dx ) if (CS%KhTr_max > 0.) Kh_loc = min(Kh_loc, CS%KhTr_max) ! Re-apply max - Kh_v(i,J) = max(Kh_loc, CS%KhTr_min) ! Re-apply min + Kh_v(i,J,1) = max(Kh_loc, CS%KhTr_min) ! Re-apply min endif enddo ; enddo !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie - khdt_x(I,j) = dt*(Kh_u(I,j)*(G%dy_Cu(I,j)*G%IdxCu(I,j))) + khdt_x(I,j) = dt*(Kh_u(I,j,1)*(G%dy_Cu(I,j)*G%IdxCu(I,j))) enddo ; enddo !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie - khdt_y(i,J) = dt*(Kh_v(i,J)*(G%dx_Cv(i,J)*G%IdyCv(i,J))) + khdt_y(i,J) = dt*(Kh_v(i,J,1)*(G%dx_Cv(i,J)*G%IdyCv(i,J))) enddo ; enddo elseif (Resoln_scaled) then !$OMP parallel do default(shared) private(Res_fn) do j=js,je ; do I=is-1,ie Res_fn = 0.5 * (VarMix%Res_fn_h(i,j) + VarMix%Res_fn_h(i+1,j)) - Kh_u(I,j) = max(CS%KhTr * Res_fn, CS%KhTr_min) + Kh_u(I,j,1) = max(CS%KhTr * Res_fn, CS%KhTr_min) khdt_x(I,j) = dt*(CS%KhTr*(G%dy_Cu(I,j)*G%IdxCu(I,j))) * Res_fn enddo ; enddo !$OMP parallel do default(shared) private(Res_fn) do J=js-1,je ; do i=is,ie Res_fn = 0.5*(VarMix%Res_fn_h(i,j) + VarMix%Res_fn_h(i,j+1)) - Kh_v(i,J) = max(CS%KhTr * Res_fn, CS%KhTr_min) + Kh_v(i,J,1) = max(CS%KhTr * Res_fn, CS%KhTr_min) khdt_y(i,J) = dt*(CS%KhTr*(G%dx_Cv(i,J)*G%IdyCv(i,J))) * Res_fn enddo ; enddo else ! Use a simple constant diffusivity. if (CS%id_KhTr_u > 0) then !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie - Kh_u(I,j) = CS%KhTr + Kh_u(I,j,1) = CS%KhTr khdt_x(I,j) = dt*(CS%KhTr*(G%dy_Cu(I,j)*G%IdxCu(I,j))) enddo ; enddo else @@ -287,7 +310,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (CS%id_KhTr_v > 0) then !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie - Kh_v(i,J) = CS%KhTr + Kh_v(i,J,1) = CS%KhTr khdt_y(i,J) = dt*(CS%KhTr*(G%dx_Cv(i,J)*G%IdyCv(i,J))) enddo ; enddo else @@ -306,7 +329,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (khdt_x(I,j) > khdt_max) then khdt_x(I,j) = khdt_max if (dt*(G%dy_Cu(I,j)*G%IdxCu(I,j)) > 0.0) & - Kh_u(I,j) = khdt_x(I,j) / (dt*(G%dy_Cu(I,j)*G%IdxCu(I,j))) + Kh_u(I,j,1) = khdt_x(I,j) / (dt*(G%dy_Cu(I,j)*G%IdxCu(I,j))) endif enddo ; enddo else @@ -323,7 +346,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (khdt_y(i,J) > khdt_max) then khdt_y(i,J) = khdt_max if (dt*(G%dx_Cv(i,J)*G%IdyCv(i,J)) > 0.0) & - Kh_v(i,J) = khdt_y(i,J) / (dt*(G%dx_Cv(i,J)*G%IdyCv(i,J))) + Kh_v(i,J,1) = khdt_y(i,J) / (dt*(G%dx_Cv(i,J)*G%IdyCv(i,J))) endif enddo ; enddo else @@ -338,11 +361,11 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online else ! .not. do_online !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie - khdt_x(I,j) = US%m_to_L**2*read_khdt_x(I,j) + khdt_x(I,j) = read_khdt_x(I,j) enddo ; enddo !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie - khdt_y(i,J) = US%m_to_L**2*read_khdt_y(i,J) + khdt_y(i,J) = read_khdt_y(i,J) enddo ; enddo call pass_vector(khdt_x, khdt_y, G%Domain) endif ! do_online @@ -360,7 +383,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online call cpu_clock_end(id_clock_sync) num_itts = max(1, ceiling(max_CFL - 4.0*EPSILON(max_CFL))) I_numitts = 1.0 / (real(num_itts)) - if (CS%id_CFL > 0) call post_data(CS%id_CFL, CFL, CS%diag, mask=G%mask2dT) + if (CS%id_CFL > 0) call post_data(CS%id_CFL, CFL, CS%diag) elseif (CS%max_diff_CFL > 0.0) then num_itts = max(1, ceiling(CS%max_diff_CFL - 4.0*EPSILON(CS%max_diff_CFL))) I_numitts = 1.0 / (real(num_itts)) @@ -387,28 +410,71 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online endif enddo - if (CS%use_lateral_boundary_diffusion) then + if (CS%use_hor_bnd_diffusion) then - if (CS%show_call_tree) call callTree_waypoint("Calling lateral boundary mixing (tracer_hordiff)") + if (CS%show_call_tree) call callTree_waypoint("Calling horizontal boundary diffusion (tracer_hordiff)") call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) - do J=js-1,je ; do i=is,ie - Coef_y(i,J) = I_numitts * khdt_y(i,J) - enddo ; enddo - do j=js,je - do I=is-1,ie - Coef_x(I,j) = I_numitts * khdt_x(I,j) + do k=1,nz+1 + do J=js-1,je + do i=is,ie + Coef_y(i,J,K) = I_numitts * khdt_y(i,J) + enddo + enddo + enddo + do k=1,nz+1 + do j=js,je + do I=is-1,ie + Coef_x(I,j,K) = I_numitts * khdt_x(I,j) + enddo enddo enddo + if (CS%KhTr_use_vert_struct) then + if (CS%full_depth_khtr_min) 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%khtr_struct(i,j,k-1) + VarMix%khtr_struct(i,j+1,k-1) ) + Coef_min = I_numitts * dt * (CS%KhTr_min*(G%dx_Cv(i,J)*G%IdyCv(i,J))) + Coef_y(i,J,K) = max(Coef_y(i,J,K), Coef_min) + 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%khtr_struct(i,j,k-1) + VarMix%khtr_struct(i+1,j,k-1) ) + Coef_min = I_numitts * dt * (CS%KhTr_min*(G%dy_Cu(I,j)*G%IdxCu(I,j))) + Coef_x(I,j,K) = max(Coef_x(I,j,K), Coef_min) + enddo + enddo + enddo + else + 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) ) + 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) ) + enddo + enddo + enddo + endif + endif do itt=1,num_itts - if (CS%show_call_tree) call callTree_waypoint("Calling lateral boundary diffusion (tracer_hordiff)",itt) + if (CS%show_call_tree) call callTree_waypoint("Calling horizontal boundary diffusion (tracer_hordiff)",itt) if (itt>1) then ! Update halos for subsequent iterations call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) endif - call lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, I_numitts*dt, Reg, & - CS%lateral_boundary_diffusion_CSp) + call hor_bnd_diffusion(G, GV, US, h, Coef_x, Coef_y, I_numitts*dt, Reg, visc, & + CS%hor_bnd_diffusion_CSp) enddo ! itt endif @@ -418,22 +484,45 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) ! We are assuming that neutral surfaces do not evolve (much) as a result of multiple - ! lateral diffusion iterations. Otherwise the call to neutral_diffusion_calc_coeffs() + !horizontal diffusion iterations. Otherwise the call to neutral_diffusion_calc_coeffs() ! would be inside the itt-loop. -AJA if (associated(tv%p_surf)) then - call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, CS%neutral_diffusion_CSp, p_surf=tv%p_surf) + call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, visc, CS%neutral_diffusion_CSp, p_surf=tv%p_surf) else - call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, CS%neutral_diffusion_CSp) + call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, visc, CS%neutral_diffusion_CSp) endif - do J=js-1,je ; do i=is,ie - Coef_y(i,J) = I_numitts * khdt_y(i,J) - enddo ; enddo - do j=js,je - do I=is-1,ie - Coef_x(I,j) = I_numitts * khdt_x(I,j) + + do k=1,nz+1 + do J=js-1,je + do i=is,ie + Coef_y(i,J,K) = I_numitts * khdt_y(i,J) + enddo enddo enddo + do k=1,nz+1 + do j=js,je + do I=is-1,ie + Coef_x(I,j,K) = I_numitts * khdt_x(I,j) + enddo + enddo + enddo + 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%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%khtr_struct(i,j,k-1) + VarMix%khtr_struct(i+1,j,k-1) ) + enddo + enddo + enddo + endif do itt=1,num_itts if (CS%show_call_tree) call callTree_waypoint("Calling neutral diffusion (tracer_hordiff)",itt) @@ -441,9 +530,10 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) if (CS%recalc_neutral_surf) then if (associated(tv%p_surf)) then - call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, CS%neutral_diffusion_CSp, p_surf=tv%p_surf) + call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, visc, CS%neutral_diffusion_CSp, & + p_surf=tv%p_surf) else - call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, CS%neutral_diffusion_CSp) + call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, visc, CS%neutral_diffusion_CSp) endif endif endif @@ -467,13 +557,13 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online endif do J=js-1,je ; do i=is,ie - Coef_y(i,J) = ((scale * khdt_y(i,J))*2.0*(h(i,j,k)*h(i,j+1,k))) / & + Coef_y(i,J,1) = ((scale * khdt_y(i,J))*2.0*(h(i,j,k)*h(i,j+1,k))) / & (h(i,j,k)+h(i,j+1,k)+h_neglect) enddo ; enddo do j=js,je do I=is-1,ie - Coef_x(I,j) = ((scale * khdt_x(I,j))*2.0*(h(i,j,k)*h(i+1,j,k))) / & + Coef_x(I,j,1) = ((scale * khdt_x(I,j))*2.0*(h(i,j,k)*h(i+1,j,k))) / & (h(i,j,k)+h(i+1,j,k)+h_neglect) enddo @@ -485,25 +575,25 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online do m=1,ntr do j=js,je ; do i=is,ie dTr(i,j) = Ihdxdy(i,j) * & - ((Coef_x(I-1,j) * (Reg%Tr(m)%t(i-1,j,k) - Reg%Tr(m)%t(i,j,k)) - & - Coef_x(I,j) * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i+1,j,k))) + & - (Coef_y(i,J-1) * (Reg%Tr(m)%t(i,j-1,k) - Reg%Tr(m)%t(i,j,k)) - & - Coef_y(i,J) * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i,j+1,k)))) + ( ((Coef_x(I-1,j,1) * (Reg%Tr(m)%t(i-1,j,k) - Reg%Tr(m)%t(i,j,k))) - & + (Coef_x(I,j,1) * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i+1,j,k)))) + & + ((Coef_y(i,J-1,1) * (Reg%Tr(m)%t(i,j-1,k) - Reg%Tr(m)%t(i,j,k))) - & + (Coef_y(i,J,1) * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i,j+1,k)))) ) enddo ; enddo if (associated(Reg%Tr(m)%df_x)) then ; do j=js,je ; do I=G%IscB,G%IecB - Reg%Tr(m)%df_x(I,j,k) = Reg%Tr(m)%df_x(I,j,k) + Coef_x(I,j) & + Reg%Tr(m)%df_x(I,j,k) = Reg%Tr(m)%df_x(I,j,k) + Coef_x(I,j,1) & * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i+1,j,k)) * Idt enddo ; enddo ; endif if (associated(Reg%Tr(m)%df_y)) then ; do J=G%JscB,G%JecB ; do i=is,ie - Reg%Tr(m)%df_y(i,J,k) = Reg%Tr(m)%df_y(i,J,k) + Coef_y(i,J) & + Reg%Tr(m)%df_y(i,J,k) = Reg%Tr(m)%df_y(i,J,k) + Coef_y(i,J,1) & * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i,j+1,k)) * Idt enddo ; enddo ; endif if (associated(Reg%Tr(m)%df2d_x)) then ; do j=js,je ; do I=G%IscB,G%IecB - Reg%Tr(m)%df2d_x(I,j) = Reg%Tr(m)%df2d_x(I,j) + Coef_x(I,j) & + Reg%Tr(m)%df2d_x(I,j) = Reg%Tr(m)%df2d_x(I,j) + Coef_x(I,j,1) & * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i+1,j,k)) * Idt enddo ; enddo ; endif if (associated(Reg%Tr(m)%df2d_y)) then ; do J=G%JscB,G%JecB ; do i=is,ie - Reg%Tr(m)%df2d_y(i,J) = Reg%Tr(m)%df2d_y(i,J) + Coef_y(i,J) & + Reg%Tr(m)%df2d_y(i,J) = Reg%Tr(m)%df2d_y(i,J) + Coef_y(i,J,1) & * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i,j+1,k)) * Idt enddo ; enddo ; endif do j=js,je ; do i=is,ie @@ -513,6 +603,14 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online enddo ! End of k loop. + ! Do user controlled underflow of the tracer concentrations. + do m=1,ntr ; if (Reg%Tr(m)%conc_underflow > 0.0) then + !$OMP parallel do default(shared) + do k=1,nz ; do j=js,je ; do i=is,ie + if (abs(Reg%Tr(m)%t(i,j,k)) < Reg%Tr(m)%conc_underflow) Reg%Tr(m)%t(i,j,k) = 0.0 + enddo ; enddo ; enddo + endif ; enddo + enddo ! End of "while" loop. endif ! endif for CS%use_neutral_diffusion @@ -521,7 +619,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (CS%Diffuse_ML_interior) then if (CS%show_call_tree) call callTree_waypoint("Calling epipycnal_ML_diff (tracer_hordiff)") - if (CS%debug) call MOM_tracer_chksum("Before epipycnal diff ", Reg%Tr, ntr, G) + if (CS%debug) call MOM_tracer_chksum("Before epipycnal diff ", Reg, G) call cpu_clock_begin(id_clock_epimix) call tracer_epipycnal_ML_diff(h, dt, Reg%Tr, ntr, khdt_x, khdt_y, G, GV, US, & @@ -529,48 +627,67 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online call cpu_clock_end(id_clock_epimix) endif - if (CS%debug) call MOM_tracer_chksum("After tracer diffusion ", Reg%Tr, ntr, G) + if (CS%debug) call MOM_tracer_chksum("After tracer diffusion ", Reg, G) ! post diagnostics for 2d tracer diffusivity if (CS%id_KhTr_u > 0) then do j=js,je ; do I=is-1,ie - Kh_u(I,j) = G%mask2dCu(I,j)*Kh_u(I,j) + Kh_u(I,j,:) = G%mask2dCu(I,j)*Kh_u(I,j,1) enddo ; enddo - call post_data(CS%id_KhTr_u, Kh_u, CS%diag, mask=G%mask2dCu) + 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%khtr_struct(i,j,k-1) + VarMix%khtr_struct(i+1,j,k-1) ) + enddo + enddo + enddo + endif + call post_data(CS%id_KhTr_u, Kh_u, CS%diag) endif if (CS%id_KhTr_v > 0) then do J=js-1,je ; do i=is,ie - Kh_v(i,J) = G%mask2dCv(i,J)*Kh_v(i,J) + Kh_v(i,J,:) = G%mask2dCv(i,J)*Kh_v(i,J,1) enddo ; enddo - call post_data(CS%id_KhTr_v, Kh_v, CS%diag, mask=G%mask2dCv) + 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%khtr_struct(i,j,k-1) + VarMix%khtr_struct(i,j+1,k-1) ) + enddo + enddo + enddo + endif + call post_data(CS%id_KhTr_v, Kh_v, CS%diag) endif if (CS%id_KhTr_h > 0) then - Kh_h(:,:) = 0.0 + Kh_h(:,:,:) = 0.0 do j=js,je ; do I=is-1,ie - Kh_u(I,j) = G%mask2dCu(I,j)*Kh_u(I,j) + Kh_u(I,j,1) = G%mask2dCu(I,j)*Kh_u(I,j,1) enddo ; enddo do J=js-1,je ; do i=is,ie - Kh_v(i,J) = G%mask2dCv(i,J)*Kh_v(i,J) + Kh_v(i,J,1) = G%mask2dCv(i,J)*Kh_v(i,J,1) enddo ; enddo + do j=js,je ; do i=is,ie normalize = 1.0 / ((G%mask2dCu(I-1,j)+G%mask2dCu(I,j)) + & - (G%mask2dCv(i,J-1)+G%mask2dCv(i,J)) + GV%H_subroundoff) - Kh_h(i,j) = normalize*G%mask2dT(i,j)*((Kh_u(I-1,j)+Kh_u(I,j)) + & - (Kh_v(i,J-1)+Kh_v(i,J))) + (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%KhTr_use_vert_struct) then + do K=2,nz+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 enddo ; enddo - call post_data(CS%id_KhTr_h, Kh_h, CS%diag, mask=G%mask2dT) + call post_data(CS%id_KhTr_h, Kh_h, CS%diag) endif - if (CS%debug) then call uvchksum("After tracer diffusion khdt_[xy]", khdt_x, khdt_y, & - G%HI, haloshift=0, symmetric=.true., scale=US%L_to_m**2, & + G%HI, haloshift=0, symmetric=.true., unscale=US%L_to_m**2, & scalar_pair=.true.) - if (CS%use_neutral_diffusion) then - call uvchksum("After tracer diffusion Coef_[xy]", Coef_x, Coef_y, & - G%HI, haloshift=0, symmetric=.true., scale=US%L_to_m**2, & - scalar_pair=.true.) - endif endif if (CS%id_khdt_x > 0) call post_data(CS%id_khdt_x, khdt_x, CS%diag) @@ -598,7 +715,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & real, dimension(SZI_(G),SZJB_(G)), intent(in) :: khdt_epi_y !< Meridional epipycnal diffusivity times !! a time step and the ratio of the open face width over !! the distance between adjacent tracer points [L2 ~> m2] - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(tracer_hor_diff_CS), intent(inout) :: CS !< module control structure type(thermo_var_ptrs), intent(in) :: tv !< thermodynamic structure integer, intent(in) :: num_itts !< number of iterations (usually=1) @@ -626,24 +743,39 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & k0b_Lv, k0a_Lv, & ! The original k-indices of the layers that participate k0b_Rv, k0a_Rv ! in each pair of mixing at v-faces. - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: & - tr_flux_conv ! The flux convergence of tracers [conc H L2 ~> conc m3 or conc kg] - real, dimension(SZI_(G), SZJ_(G),SZK_(GV)) :: Tr_flux_3d, Tr_adj_vert_L, Tr_adj_vert_R + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + tr_flux_N, & ! The tracer flux through the northern face [conc H L2 ~> conc m3 or conc kg] + tr_flux_S, & ! The tracer flux through the southern face [conc H L2 ~> conc m3 or conc kg] + tr_flux_E, & ! The tracer flux through the eastern face [conc H L2 ~> conc m3 or conc kg] + tr_flux_W, & ! The tracer flux through the western face [conc H L2 ~> conc m3 or conc kg] + tr_flux_conv ! The flux convergence of tracers [conc H L2 ~> conc m3 or conc kg] + + ! The following 3-d arrays were created in 2014 in MOM6 PR#12 to facilitate openMP threading + ! on an i-loop, which might have been ill advised. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)*2) :: & + Tr_flux_3d, & ! The tracer flux through pairings at meridional faces [conc H L2 ~> conc m3 or conc kg] + Tr_adj_vert_L, & ! Vertical adjustments to which layer the fluxes go into in the southern + ! columns at meridional face [conc H L2 ~> conc m3 or conc kg] + Tr_adj_vert_R ! Vertical adjustments to which layer the fluxes go into in the northern + ! columns at meridional face [conc H L2 ~> conc m3 or conc kg] real, dimension(SZI_(G),SZK_(GV), SZJ_(G)) :: & rho_srt, & ! The density of each layer of the sorted columns [R ~> kg m-3]. h_srt ! The thickness of each layer of the sorted columns [H ~> m or kg m-2]. integer, dimension(SZI_(G),SZK_(GV), SZJ_(G)) :: & - k0_srt ! The original k-index that each layer of the sorted column - ! corresponds to. + k0_srt ! The original k-index that each layer of the sorted column corresponds to. real, dimension(SZK_(GV)) :: & - h_demand_L, & ! The thickness in the left (_L) or right (_R) column that - h_demand_R, & ! is demanded to match the thickness in the counterpart [H ~> m or kg m-2]. - h_used_L, & ! The summed thickness from the left or right columns that - h_used_R, & ! have actually been used [H ~> m or kg m-2]. - h_supply_frac_L, & ! The fraction of the demanded thickness that can - h_supply_frac_R ! actually be supplied from a layer. + h_demand_L, & ! The thickness in the left column that is demanded to match the thickness + ! in the counterpart [H ~> m or kg m-2]. + h_demand_R, & ! The thickness in the right column that is demanded to match the thickness + ! in the counterpart [H ~> m or kg m-2]. + h_used_L, & ! The summed thickness from the left column that has actually been used [H ~> m or kg m-2] + h_used_R, & ! The summed thickness from the right columns that has actually been used [H ~> m or kg m-2] + h_supply_frac_L, & ! The fraction of the demanded thickness that can actually be supplied + ! from a layer on the left [nondim]. + h_supply_frac_R ! The fraction of the demanded thickness that can actually be supplied + ! from a layer on the right [nondim]. integer, dimension(SZI_(G), SZJ_(G)) :: & num_srt, & ! The number of layers that are sorted in each column. k_end_srt, & ! The maximum index in each column that might need to be @@ -659,17 +791,17 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & real :: h_exclude ! A thickness that layers must attain to be considered ! for inclusion in mixing [H ~> m or kg m-2]. real :: Idt ! The inverse of the time step [T-1 ~> s-1]. - real :: I_maxitt ! The inverse of the maximum number of iterations. + real :: I_maxitt ! The inverse of the maximum number of iterations [nondim] real :: rho_pair, rho_a, rho_b ! Temporary densities [R ~> kg m-3]. - real :: Tr_min_face ! The minimum and maximum tracer concentrations - real :: Tr_max_face ! associated with a pairing [Conc] - real :: Tr_La, Tr_Lb ! The 4 tracer concentrations that might be - real :: Tr_Ra, Tr_Rb ! associated with a pairing [Conc] - real :: Tr_av_L ! The average tracer concentrations on the left and right - real :: Tr_av_R ! sides of a pairing [Conc]. + real :: Tr_min_face ! The minimum tracer concentration associated with a pairing [Conc] + real :: Tr_max_face ! The maximum tracer concentration associated with a pairing [Conc] + real :: Tr_La, Tr_Lb ! The 2 left-side tracer concentrations that might be associated with a pairing [Conc] + real :: Tr_Ra, Tr_Rb ! The 2 right-side tracer concentrations that might be associated with a pairing [Conc] + real :: Tr_av_L ! The average tracer concentrations on the left side of a pairing [Conc]. + real :: Tr_av_R ! The average tracer concentrations on the right side of a pairing [Conc]. real :: Tr_flux ! The tracer flux from left to right in a pair [conc H L2 ~> conc m3 or conc kg]. - real :: Tr_adj_vert ! A downward vertical adjustment to Tr_flux between the - ! two cells that make up one side of the pairing [conc H L2 ~> conc m3 or conc kg]. + real :: Tr_adj_vert ! A downward vertical adjustment to Tr_flux between the two cells that + ! make up one side of the pairing [conc H L2 ~> conc m3 or conc kg]. real :: h_L, h_R ! Thicknesses to the left and right [H ~> m or kg m-2]. real :: wt_a, wt_b ! Fractional weights of layers above and below [nondim]. real :: vol ! A cell volume or mass [H L2 ~> m3 or kg]. @@ -683,7 +815,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & left_set, & ! If true, the left or right point determines the density of right_set ! of the trio. If densities are exactly equal, both are true. - real :: tmp + real :: tmp ! A temporary variable used in swaps [various] real :: p_ref_cv(SZI_(G)) ! The reference pressure for the coordinate density [R L2 T-2 ~> Pa] integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state @@ -692,7 +824,6 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & integer :: isd, ied, jsd, jed, IsdB, IedB, k_size integer :: kL, kR, kLa, kLb, kRa, kRb, nP, itt, ns, max_itt integer :: PEmax_kRho - integer :: isv, iev, jsv, jev ! The valid range of the indices. 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 @@ -713,7 +844,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & ! Determine which layers the mixed- and buffer-layers map into... !$OMP parallel do default(shared) do k=1,nkmb ; do j=js-2,je+2 - call calculate_density(tv%T(:,j,k),tv%S(:,j,k), p_ref_cv, rho_coord(:,j,k), & + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_ref_cv, rho_coord(:,j,k), & tv%eqn_of_state, EOSdom) enddo ; enddo @@ -724,11 +855,12 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & do k=2,nkmb ; do j=js-2,je+2 ; do i=is-2,ie+2 if (Rml_max(i,j) < rho_coord(i,j,k)) Rml_max(i,j) = rho_coord(i,j,k) enddo ; enddo ; enddo + ! Use bracketing and bisection to find the k-level that the densest of the ! mixed and buffer layer corresponds to, such that: ! GV%Rlay(max_kRho-1) < Rml_max <= GV%Rlay(max_kRho) !$OMP parallel do default(shared) private(k_min,k_max,k_test) - do j=js-2,je+2 ; do i=is-2,ie+2 ; if (G%mask2dT(i,j) > 0.5) then + do j=js-2,je+2 ; do i=is-2,ie+2 ; if (G%mask2dT(i,j) > 0.0) then if ((Rml_max(i,j) > GV%Rlay(nz)) .or. (nkmb+1 > nz)) then ; max_kRho(i,j) = nz+1 elseif ((Rml_max(i,j) <= GV%Rlay(nkmb+1)) .or. (nkmb+2 > nz)) then ; max_kRho(i,j) = nkmb+1 else @@ -756,7 +888,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & !$OMP parallel default(shared) private(ns,tmp,itmp) !$OMP do do j=js-1,je+1 - do k=1,nkmb ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.5) then + do k=1,nkmb ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.0) then if (h(i,j,k) > h_exclude) then num_srt(i,j) = num_srt(i,j) + 1 ; ns = num_srt(i,j) k0_srt(i,ns,j) = k @@ -764,7 +896,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & h_srt(i,ns,j) = h(i,j,k) endif endif ; enddo ; enddo - do k=nkmb+1,PEmax_kRho ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.5) then + do k=nkmb+1,PEmax_kRho ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.0) then if ((k<=k_end_srt(i,j)) .and. (h(i,j,k) > h_exclude)) then num_srt(i,j) = num_srt(i,j) + 1 ; ns = num_srt(i,j) k0_srt(i,ns,j) = k @@ -812,7 +944,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & !$OMP kR,kL,nP,rho_pair,kbs_Lp,kbs_Rp,rho_a,rho_b, & !$OMP wt_b,left_set,right_set,h_supply_frac_R, & !$OMP h_supply_frac_L) - do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.5) then + do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.0) then ! Set up the pairings for fluxes through the zonal faces. do k=1,num_srt(i,j) ; h_demand_L(k) = 0.0 ; h_used_L(k) = 0.0 ; enddo @@ -965,7 +1097,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & !$OMP kR,kL,nP,rho_pair,kbs_Lp,kbs_Rp,rho_a,rho_b, & !$OMP wt_b,left_set,right_set,h_supply_frac_R, & !$OMP h_supply_frac_L) - do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.5) then + do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then ! Set up the pairings for fluxes through the meridional faces. do k=1,num_srt(i,j) ; h_demand_L(k) = 0.0 ; h_used_L(k) = 0.0 ; enddo @@ -1100,12 +1232,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & endif ; enddo ; enddo ! i- & j- loops over meridional faces. -! The tracer-specific calculations start here. - - ! Zero out tracer tendencies. - do k=1,PEmax_kRho ; do j=js-1,je+1 ; do i=is-1,ie+1 - tr_flux_conv(i,j,k) = 0.0 - enddo ; enddo ; enddo + ! The tracer-specific calculations start here. do itt=1,max_itt @@ -1114,13 +1241,20 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & endif do m=1,ntr -!$OMP parallel do default(none) shared(is,ie,js,je,G,Tr,nkmb,nPu,m,max_kRho,nz,h,h_exclude, & -!$OMP k0b_Lu,k0b_Ru,deep_wt_Lu,k0a_Lu,deep_wt_Ru,k0a_Ru, & -!$OMP hP_Lu,hP_Ru,I_maxitt,khdt_epi_x,tr_flux_conv,Idt) & -!$OMP private(Tr_min_face,Tr_max_face,kLa,kLb,kRa,kRb,Tr_La, & -!$OMP Tr_Lb,Tr_Ra,Tr_Rb,Tr_av_L,wt_b,Tr_av_R,h_L,h_R, & -!$OMP Tr_flux,Tr_adj_vert,wt_a,vol) - do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.5) then + ! Zero out tracer tendencies. + if (CS%answer_date <= 20240330) then + tr_flux_conv(:,:,:) = 0.0 + else + tr_flux_N(:,:,:) = 0.0 ; tr_flux_S(:,:,:) = 0.0 + tr_flux_E(:,:,:) = 0.0 ; tr_flux_W(:,:,:) = 0.0 + endif + tr_flux_3d(:,:,:) = 0.0 + tr_adj_vert_R(:,:,:) = 0.0 ; tr_adj_vert_L(:,:,:) = 0.0 + + !$OMP parallel do default(shared) private(Tr_min_face,Tr_max_face,kLa,kLb,kRa,kRb,Tr_La, & + !$OMP Tr_Lb,Tr_Ra,Tr_Rb,Tr_av_L,wt_b,Tr_av_R,h_L,h_R, & + !$OMP Tr_flux,Tr_adj_vert,wt_a,vol) + do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.0) then ! Determine the fluxes through the zonal faces. ! Find the acceptable range of tracer concentration around this face. @@ -1139,7 +1273,11 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & kRb = kRa ; if (max_kRho(i+1,j) < nz) kRb = max_kRho(i+1,j)+1 Tr_La = Tr_min_face ; Tr_Lb = Tr_La ; Tr_Ra = Tr_La ; Tr_Rb = Tr_La if (h(i,j,kLa) > h_exclude) Tr_La = Tr(m)%t(i,j,kLa) - if (h(i,j,kLb) > h_exclude) Tr_La = Tr(m)%t(i,j,kLb) + if ((CS%answer_date <= 20240330) .and. CS%limit_bug) then + if (h(i,j,kLb) > h_exclude) Tr_La = Tr(m)%t(i,j,kLb) + else + if (h(i,j,kLb) > h_exclude) Tr_Lb = Tr(m)%t(i,j,kLb) + endif if (h(i+1,j,kRa) > h_exclude) Tr_Ra = Tr(m)%t(i+1,j,kRa) if (h(i+1,j,kRb) > h_exclude) Tr_Rb = Tr(m)%t(i+1,j,kRb) Tr_min_face = min(Tr_min_face, Tr_La, Tr_Lb, Tr_Ra, Tr_Rb) @@ -1173,12 +1311,20 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & endif h_L = hP_Lu(j)%p(I,k) ; h_R = hP_Ru(j)%p(I,k) - Tr_flux = I_maxitt * khdt_epi_x(I,j) * (Tr_av_L - Tr_av_R) * & - ((2.0 * h_L * h_R) / (h_L + h_R)) - + if (CS%answer_date <= 20240330) then + Tr_flux = I_maxitt * khdt_epi_x(I,j) * (Tr_av_L - Tr_av_R) * & + ((2.0 * h_L * h_R) / (h_L + h_R)) + else + Tr_flux = I_maxitt * ((2.0 * h_L * h_R) / (h_L + h_R)) * & + khdt_epi_x(I,j) * (Tr_av_L - Tr_av_R) + endif if (deep_wt_Lu(j)%p(I,k) >= 1.0) then - tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - Tr_flux + if (CS%answer_date <= 20240330) then + tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - Tr_flux + else + tr_flux_E(i,j,kLb) = tr_flux_E(i,j,kLb) + Tr_flux + endif else Tr_adj_vert = 0.0 wt_b = deep_wt_Lu(j)%p(I,k) ; wt_a = 1.0 - wt_b @@ -1208,12 +1354,21 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & endif endif - tr_flux_conv(i,j,kLa) = tr_flux_conv(i,j,kLa) - (wt_a*Tr_flux + Tr_adj_vert) - tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - (wt_b*Tr_flux - Tr_adj_vert) + if (CS%answer_date <= 20240330) then + tr_flux_conv(i,j,kLa) = tr_flux_conv(i,j,kLa) - (wt_a*Tr_flux + Tr_adj_vert) + tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - (wt_b*Tr_flux - Tr_adj_vert) + else + tr_flux_E(i,j,kLa) = tr_flux_E(i,j,kLa) + (wt_a*Tr_flux + Tr_adj_vert) + tr_flux_E(i,j,kLb) = tr_flux_E(i,j,kLb) + (wt_b*Tr_flux - Tr_adj_vert) + endif endif if (deep_wt_Ru(j)%p(I,k) >= 1.0) then - tr_flux_conv(i+1,j,kRb) = tr_flux_conv(i+1,j,kRb) + Tr_flux + if (CS%answer_date <= 20240330) then + tr_flux_conv(i+1,j,kRb) = tr_flux_conv(i+1,j,kRb) + Tr_flux + else + tr_flux_W(i+1,j,kRb) = tr_flux_W(i+1,j,kRb) + Tr_flux + endif else Tr_adj_vert = 0.0 wt_b = deep_wt_Ru(j)%p(I,k) ; wt_a = 1.0 - wt_b @@ -1243,24 +1398,23 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & endif endif - tr_flux_conv(i+1,j,kRa) = tr_flux_conv(i+1,j,kRa) + & - (wt_a*Tr_flux - Tr_adj_vert) - tr_flux_conv(i+1,j,kRb) = tr_flux_conv(i+1,j,kRb) + & - (wt_b*Tr_flux + Tr_adj_vert) + if (CS%answer_date <= 20240330) then + tr_flux_conv(i+1,j,kRa) = tr_flux_conv(i+1,j,kRa) + (wt_a*Tr_flux - Tr_adj_vert) + tr_flux_conv(i+1,j,kRb) = tr_flux_conv(i+1,j,kRb) + (wt_b*Tr_flux + Tr_adj_vert) + else + tr_flux_W(i+1,j,kRa) = tr_flux_W(i+1,j,kRa) + (wt_a*Tr_flux - Tr_adj_vert) + tr_flux_W(i+1,j,kRb) = tr_flux_W(i+1,j,kRb) + (wt_b*Tr_flux + Tr_adj_vert) + endif endif if (associated(Tr(m)%df2d_x)) & Tr(m)%df2d_x(I,j) = Tr(m)%df2d_x(I,j) + Tr_flux * Idt enddo ! Loop over pairings at faces. endif ; enddo ; enddo ! i- & j- loops over zonal faces. -!$OMP parallel do default(none) shared(is,ie,js,je,G,Tr,nkmb,nPv,m,max_kRho,nz,h,h_exclude, & -!$OMP k0b_Lv,k0b_Rv,deep_wt_Lv,k0a_Lv,deep_wt_Rv,k0a_Rv, & -!$OMP hP_Lv,hP_Rv,I_maxitt,khdt_epi_y,Tr_flux_3d, & -!$OMP Tr_adj_vert_L,Tr_adj_vert_R,Idt) & -!$OMP private(Tr_min_face,Tr_max_face,kLa,kLb,kRa,kRb, & -!$OMP Tr_La,Tr_Lb,Tr_Ra,Tr_Rb,Tr_av_L,wt_b,Tr_av_R, & -!$OMP h_L,h_R,Tr_flux,Tr_adj_vert,wt_a,vol) - do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.5) then + !$OMP parallel do default(shared) private(Tr_min_face,Tr_max_face,kLa,kLb,kRa,kRb, & + !$OMP Tr_La,Tr_Lb,Tr_Ra,Tr_Rb,Tr_av_L,wt_b,Tr_av_R, & + !$OMP h_L,h_R,Tr_flux,Tr_adj_vert,wt_a,vol) + do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then ! Determine the fluxes through the meridional faces. ! Find the acceptable range of tracer concentration around this face. @@ -1279,7 +1433,11 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & kRb = kRa ; if (max_kRho(i,j+1) < nz) kRb = max_kRho(i,j+1)+1 Tr_La = Tr_min_face ; Tr_Lb = Tr_La ; Tr_Ra = Tr_La ; Tr_Rb = Tr_La if (h(i,j,kLa) > h_exclude) Tr_La = Tr(m)%t(i,j,kLa) - if (h(i,j,kLb) > h_exclude) Tr_La = Tr(m)%t(i,j,kLb) + if ((CS%answer_date <= 20240330) .and. CS%limit_bug) then + if (h(i,j,kLb) > h_exclude) Tr_La = Tr(m)%t(i,j,kLb) + else + if (h(i,j,kLb) > h_exclude) Tr_Lb = Tr(m)%t(i,j,kLb) + endif if (h(i,j+1,kRa) > h_exclude) Tr_Ra = Tr(m)%t(i,j+1,kRa) if (h(i,j+1,kRb) > h_exclude) Tr_Rb = Tr(m)%t(i,j+1,kRb) Tr_min_face = min(Tr_min_face, Tr_La, Tr_Lb, Tr_Ra, Tr_Rb) @@ -1314,7 +1472,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & h_L = hP_Lv(J)%p(i,k) ; h_R = hP_Rv(J)%p(i,k) Tr_flux = I_maxitt * ((2.0 * h_L * h_R) / (h_L + h_R)) * & khdt_epi_y(i,J) * (Tr_av_L - Tr_av_R) - Tr_flux_3d(i,j,k) = Tr_flux + Tr_flux_3d(i,J,k) = Tr_flux if (deep_wt_Lv(J)%p(i,k) < 1.0) then Tr_adj_vert = 0.0 @@ -1340,7 +1498,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & (vol*wt_a)*(Tr_Lb - Tr_La)) endif endif - Tr_adj_vert_L(i,j,k) = Tr_adj_vert + Tr_adj_vert_L(i,J,k) = Tr_adj_vert endif if (deep_wt_Rv(J)%p(i,k) < 1.0) then @@ -1367,48 +1525,86 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & (vol*wt_a)*(Tr_Rb - Tr_Ra)) endif endif - Tr_adj_vert_R(i,j,k) = Tr_adj_vert + Tr_adj_vert_R(i,J,k) = Tr_adj_vert endif if (associated(Tr(m)%df2d_y)) & Tr(m)%df2d_y(i,J) = Tr(m)%df2d_y(i,J) + Tr_flux * Idt enddo ! Loop over pairings at faces. endif ; enddo ; enddo ! i- & j- loops over meridional faces. -!$OMP parallel do default(none) shared(is,ie,js,je,G,nPv,k0b_Lv,k0b_Rv,deep_wt_Lv, & -!$OMP tr_flux_conv,Tr_flux_3d,k0a_Lv,Tr_adj_vert_L,& -!$OMP deep_wt_Rv,k0a_Rv,Tr_adj_vert_R) & -!$OMP private(kLa,kLb,kRa,kRb,wt_b,wt_a) - do i=is,ie ; do J=js-1,je ; if (G%mask2dCv(i,J) > 0.5) then - do k=1,nPv(i,J) - kLb = k0b_Lv(J)%p(i,k); kRb = k0b_Rv(J)%p(i,k) - if (deep_wt_Lv(J)%p(i,k) >= 1.0) then - tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - Tr_flux_3d(i,j,k) - else - kLa = k0a_Lv(J)%p(i,k) - wt_b = deep_wt_Lv(J)%p(i,k) ; wt_a = 1.0 - wt_b - tr_flux_conv(i,j,kLa) = tr_flux_conv(i,j,kLa) - (wt_a*Tr_flux_3d(i,j,k) + Tr_adj_vert_L(i,j,k)) - tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - (wt_b*Tr_flux_3d(i,j,k) - Tr_adj_vert_L(i,j,k)) - endif - if (deep_wt_Rv(J)%p(i,k) >= 1.0) then - tr_flux_conv(i,j+1,kRb) = tr_flux_conv(i,j+1,kRb) + Tr_flux_3d(i,j,k) - else - kRa = k0a_Rv(J)%p(i,k) - wt_b = deep_wt_Rv(J)%p(i,k) ; wt_a = 1.0 - wt_b - tr_flux_conv(i,j+1,kRa) = tr_flux_conv(i,j+1,kRa) + & - (wt_a*Tr_flux_3d(i,j,k) - Tr_adj_vert_R(i,j,k)) - tr_flux_conv(i,j+1,kRb) = tr_flux_conv(i,j+1,kRb) + & - (wt_b*Tr_flux_3d(i,j,k) + Tr_adj_vert_R(i,j,k)) - endif - enddo + + !$OMP parallel do default(shared) private(kLa,kLb,kRa,kRb,wt_b,wt_a) + do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then + ! The non-stride-1 loop order here is to facilitate openMP threading. However, it might be + ! suboptimal when openMP threading is not used, at which point it might be better to fuse + ! this loop with those that precede it and thereby eliminate the need for three 3-d arrays. + if (CS%answer_date <= 20240330) then + do k=1,nPv(i,J) + kLb = k0b_Lv(J)%p(i,k) ; kRb = k0b_Rv(J)%p(i,k) + if (deep_wt_Lv(J)%p(i,k) >= 1.0) then + tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - Tr_flux_3d(i,J,k) + else + kLa = k0a_Lv(J)%p(i,k) + wt_b = deep_wt_Lv(J)%p(i,k) ; wt_a = 1.0 - wt_b + tr_flux_conv(i,j,kLa) = tr_flux_conv(i,j,kLa) - (wt_a*Tr_flux_3d(i,J,k) + Tr_adj_vert_L(i,J,k)) + tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - (wt_b*Tr_flux_3d(i,J,k) - Tr_adj_vert_L(i,J,k)) + endif + if (deep_wt_Rv(J)%p(i,k) >= 1.0) then + tr_flux_conv(i,j+1,kRb) = tr_flux_conv(i,j+1,kRb) + Tr_flux_3d(i,J,k) + else + kRa = k0a_Rv(J)%p(i,k) + wt_b = deep_wt_Rv(J)%p(i,k) ; wt_a = 1.0 - wt_b + tr_flux_conv(i,j+1,kRa) = tr_flux_conv(i,j+1,kRa) + & + (wt_a*Tr_flux_3d(i,J,k) - Tr_adj_vert_R(i,J,k)) + tr_flux_conv(i,j+1,kRb) = tr_flux_conv(i,j+1,kRb) + & + (wt_b*Tr_flux_3d(i,J,k) + Tr_adj_vert_R(i,J,k)) + endif + enddo + else + do k=1,nPv(i,J) + kLb = k0b_Lv(J)%p(i,k) ; kRb = k0b_Rv(J)%p(i,k) + if (deep_wt_Lv(J)%p(i,k) >= 1.0) then + tr_flux_N(i,j,kLb) = tr_flux_N(i,j,kLb) + Tr_flux_3d(i,J,k) + else + kLa = k0a_Lv(J)%p(i,k) + wt_b = deep_wt_Lv(J)%p(i,k) ; wt_a = 1.0 - wt_b + tr_flux_N(i,j,kLa) = tr_flux_N(i,j,kLa) + (wt_a*Tr_flux_3d(i,J,k) + Tr_adj_vert_L(i,J,k)) + tr_flux_N(i,j,kLb) = tr_flux_N(i,j,kLb) + (wt_b*Tr_flux_3d(i,J,k) - Tr_adj_vert_L(i,J,k)) + endif + if (deep_wt_Rv(J)%p(i,k) >= 1.0) then + tr_flux_S(i,j+1,kRb) = tr_flux_S(i,j+1,kRb) + Tr_flux_3d(i,J,k) + else + kRa = k0a_Rv(J)%p(i,k) + wt_b = deep_wt_Rv(J)%p(i,k) ; wt_a = 1.0 - wt_b + tr_flux_S(i,j+1,kRa) = tr_flux_S(i,j+1,kRa) + (wt_a*Tr_flux_3d(i,J,k) - Tr_adj_vert_R(i,J,k)) + tr_flux_S(i,j+1,kRb) = tr_flux_S(i,j+1,kRb) + (wt_b*Tr_flux_3d(i,J,k) + Tr_adj_vert_R(i,J,k)) + endif + enddo + endif endif ; enddo ; enddo -!$OMP parallel do default(none) shared(PEmax_kRho,is,ie,js,je,G,h,Tr,tr_flux_conv,m) + + if (CS%answer_date >= 20240331) then + !$OMP parallel do default(shared) + do k=1,PEmax_kRho ; do j=js,je ; do i=is,ie + tr_flux_conv(i,j,k) = ((tr_flux_W(i,j,k) - tr_flux_E(i,j,k)) + & + (tr_flux_S(i,j,k) - tr_flux_N(i,j,k))) + enddo ; enddo ; enddo + endif + + !$OMP parallel do default(shared) do k=1,PEmax_kRho ; do j=js,je ; do i=is,ie - if ((G%mask2dT(i,j) > 0.5) .and. (h(i,j,k) > 0.0)) then - Tr(m)%t(i,j,k) = Tr(m)%t(i,j,k) + tr_flux_conv(i,j,k) / & - (h(i,j,k)*G%areaT(i,j)) - tr_flux_conv(i,j,k) = 0.0 + if ((G%mask2dT(i,j) > 0.0) .and. (h(i,j,k) > 0.0)) then + Tr(m)%t(i,j,k) = Tr(m)%t(i,j,k) + tr_flux_conv(i,j,k) / (h(i,j,k)*G%areaT(i,j)) endif enddo ; enddo ; enddo + ! Do user controlled underflow of the tracer concentrations. + if (Tr(m)%conc_underflow > 0.0) then + !$OMP parallel do default(shared) + do k=1,nz ; do j=js,je ; do i=is,ie + if (abs(Tr(m)%t(i,j,k)) < Tr(m)%conc_underflow) Tr(m)%t(i,j,k) = 0.0 + enddo ; enddo ; enddo + endif + enddo ! Loop over tracers enddo ! Loop over iterations @@ -1441,10 +1637,10 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic type(param_file_type), intent(in) :: param_file !< parameter file type(tracer_hor_diff_CS), pointer :: CS !< horz diffusion control structure -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_tracer_hor_diff" ! This module's name. - character(len=256) :: mesg ! Message for error messages. + integer :: default_answer_date if (associated(CS)) then call MOM_error(WARNING, "tracer_hor_diff_init called with associated control structure.") @@ -1460,6 +1656,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_SLOPE_CFF", CS%KhTr_Slope_Cff, & "The scaling coefficient for along-isopycnal tracer "//& "diffusivity using a shear-based (Visbeck-like) "//& @@ -1468,6 +1668,13 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic call get_param(param_file, mdl, "KHTR_MIN", CS%KhTr_Min, & "The minimum along-isopycnal tracer diffusivity.", & units="m2 s-1", default=0.0, scale=US%m_to_L**2*US%T_to_s) + if (CS%KhTr_Min > 0.0) then + call get_param(param_file, mdl, "FULL_DEPTH_KHTR_MIN", CS%full_depth_khtr_min, & + "If true, KHTR_MIN is enforced throughout the whole water column. "//& + "Otherwise, KHTR_MIN is only enforced at the surface. This parameter "//& + "is only available when KHTR_USE_EBT_STRUCT=True and KHTR_MIN>0.", & + default=.false.) + endif call get_param(param_file, mdl, "KHTR_MAX", CS%KhTr_Max, & "The maximum along-isopycnal tracer diffusivity.", & units="m2 s-1", default=0.0, scale=US%m_to_L**2*US%T_to_s) @@ -1498,7 +1705,21 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic call get_param(param_File, mdl, "RECALC_NEUTRAL_SURF", CS%recalc_neutral_surf, & "If true, then recalculate the neutral surfaces if the \n"//& "diffusive CFL is exceeded. If false, assume that the \n"//& - "positions of the surfaces do not change \n", default = .false.) + "positions of the surfaces do not change \n", default=.false.) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231, do_not_log=.true.) + call get_param(param_file, mdl, "HOR_DIFF_ANSWER_DATE", CS%answer_date, & + "The vintage of the order of arithmetic to use for the tracer diffusion. "//& + "Values of 20240330 or below recover the answers from the original form of the "//& + "along-isopycnal mixed layer to interior mixing code, while higher values use "//& + "mathematically equivalent expressions that recover rotational symmetry "//& + "when DIFFUSE_ML_TO_INTERIOR is true.", & + default=default_answer_date, do_not_log=.not.CS%Diffuse_ML_interior) + call get_param(param_file, mdl, "HOR_DIFF_LIMIT_BUG", CS%limit_bug, & + "If true and the answer date is 20240330 or below, use a rotational symmetry "//& + "breaking bug when limiting the tracer properties in tracer_epipycnal_ML_diff.", & + default=.false., do_not_log=((.not.CS%Diffuse_ML_interior).or.(CS%answer_date>=20240331))) CS%ML_KhTR_scale = 1.0 if (CS%Diffuse_ML_interior) then call get_param(param_file, mdl, "ML_KHTR_SCALE", CS%ML_KhTR_scale, & @@ -1512,10 +1733,10 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic diabatic_CSp, CS%neutral_diffusion_CSp ) if (CS%use_neutral_diffusion .and. CS%Diffuse_ML_interior) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & "USE_NEUTRAL_DIFFUSION and DIFFUSE_ML_TO_INTERIOR are mutually exclusive!") - CS%use_lateral_boundary_diffusion = lateral_boundary_diffusion_init(Time, G, GV, param_file, diag, diabatic_CSp, & - CS%lateral_boundary_diffusion_CSp) - if (CS%use_lateral_boundary_diffusion .and. CS%Diffuse_ML_interior) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & - "USE_LATERAL_BOUNDARY_DIFFUSION and DIFFUSE_ML_TO_INTERIOR are mutually exclusive!") + CS%use_hor_bnd_diffusion = hor_bnd_diffusion_init(Time, G, GV, US, param_file, diag, diabatic_CSp, & + CS%hor_bnd_diffusion_CSp) + if (CS%use_hor_bnd_diffusion .and. CS%Diffuse_ML_interior) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & + "USE_HORIZONTAL_BOUNDARY_DIFFUSION and DIFFUSE_ML_TO_INTERIOR are mutually exclusive!") call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) @@ -1529,11 +1750,11 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic CS%id_KhTr_h = -1 CS%id_CFL = -1 - CS%id_KhTr_u = register_diag_field('ocean_model', 'KHTR_u', diag%axesCu1, Time, & + CS%id_KhTr_u = register_diag_field('ocean_model', 'KHTR_u', diag%axesCui, Time, & 'Epipycnal tracer diffusivity at zonal faces of tracer cell', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) - CS%id_KhTr_v = register_diag_field('ocean_model', 'KHTR_v', diag%axesCv1, Time, & + CS%id_KhTr_v = register_diag_field('ocean_model', 'KHTR_v', diag%axesCvi, Time, & 'Epipycnal tracer diffusivity at meridional faces of tracer cell', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) - CS%id_KhTr_h = register_diag_field('ocean_model', 'KHTR_h', diag%axesT1, Time, & + CS%id_KhTr_h = register_diag_field('ocean_model', 'KHTR_h', diag%axesTi, Time, & 'Epipycnal tracer diffusivity at tracer cell center', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T, & cmor_field_name='diftrelo', & cmor_standard_name= 'ocean_tracer_epineutral_laplacian_diffusivity', & @@ -1555,6 +1776,7 @@ subroutine tracer_hor_diff_end(CS) type(tracer_hor_diff_CS), pointer :: CS !< module control structure call neutral_diffusion_end(CS%neutral_diffusion_CSp) + call hor_bnd_diffusion_end(CS%hor_bnd_diffusion_CSp) if (associated(CS)) deallocate(CS) end subroutine tracer_hor_diff_end diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 2c77df3e74..dda8bf7df1 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -1,11 +1,13 @@ -!> This module contains the tracer_registry_type and the subroutines -!! that handle registration of tracers and related subroutines. -!! The primary subroutine, register_tracer, is called to indicate the -!! tracers advected and diffused. +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> This module contains subroutines that handle registration of tracers +!! and related subroutines. The primary subroutine, register_tracer, is +!! called to indicate the tracers advected and diffused. +!! It also makes public the types defined in MOM_tracer_types. module MOM_tracer_registry -! This file is part of MOM6. See LICENSE.md for the license. - ! use MOM_diag_mediator, only : diag_ctrl use MOM_coms, only : reproducing_sum use MOM_debugging, only : hchksum @@ -22,6 +24,7 @@ module MOM_tracer_registry use MOM_time_manager, only : time_type use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type +use MOM_tracer_types, only : tracer_type, tracer_registry_type implicit none ; private @@ -29,142 +32,39 @@ module MOM_tracer_registry public register_tracer public MOM_tracer_chksum, MOM_tracer_chkinv -public register_tracer_diagnostics, post_tracer_diagnostics_at_sync, post_tracer_transport_diagnostics +public register_tracer_diagnostics +public post_tracer_diagnostics_at_sync, post_tracer_transport_diagnostics public preALE_tracer_diagnostics, postALE_tracer_diagnostics public tracer_registry_init, lock_tracer_registry, tracer_registry_end public tracer_name_lookup +public tracer_type, tracer_registry_type + +!> Write out checksums for registered tracers +interface MOM_tracer_chksum + module procedure tracer_array_chksum, tracer_Reg_chksum +end interface MOM_tracer_chksum -!> The tracer type -type, public :: tracer_type - - real, dimension(:,:,:), pointer :: t => NULL() !< tracer concentration array [conc] -! real :: OBC_inflow_conc= 0.0 !< tracer concentration for generic inflows [conc] -! real, dimension(:,:,:), pointer :: OBC_in_u => NULL() !< structured values for flow into the domain -! !! specified in OBCs through u-face of cell -! real, dimension(:,:,:), pointer :: OBC_in_v => NULL() !< structured values for flow into the domain -! !! specified in OBCs through v-face of cell - - real, dimension(:,:,:), pointer :: ad_x => NULL() !< diagnostic array for x-advective tracer flux - !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:,:), pointer :: ad_y => NULL() !< diagnostic array for y-advective tracer flux - !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:), pointer :: ad2d_x => NULL() !< diagnostic vertical sum x-advective tracer flux - !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:), pointer :: ad2d_y => NULL() !< diagnostic vertical sum y-advective tracer flux - !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] - - real, dimension(:,:,:), pointer :: df_x => NULL() !< diagnostic array for x-diffusive tracer flux - !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:,:), pointer :: df_y => NULL() !< diagnostic array for y-diffusive tracer flux - !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:,:), pointer :: lbd_dfx => NULL() !< diagnostic array for x-diffusive tracer flux - !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:,:), pointer :: lbd_dfy => NULL() !< diagnostic array for y-diffusive tracer flux - !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:), pointer :: lbd_dfx_2d => NULL() !< diagnostic array for x-diffusive tracer flux - !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:), pointer :: lbd_dfy_2d => NULL() !< diagnostic array for y-diffusive tracer flux - !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] - !### These two arrays may be allocated but are never used. - real, dimension(:,:), pointer :: lbd_bulk_df_x => NULL() !< diagnostic array for x-diffusive tracer flux - !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:), pointer :: lbd_bulk_df_y => NULL() !< diagnostic array for y-diffusive tracer flux - !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:), pointer :: df2d_x => NULL() !< diagnostic vertical sum x-diffusive flux - !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:), pointer :: df2d_y => NULL() !< diagnostic vertical sum y-diffusive flux - !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] -! real, dimension(:,:), pointer :: df2d_conc_x => NULL() !< diagnostic vertical sum x-diffusive content flux -! !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] -! real, dimension(:,:), pointer :: df2d_conc_y => NULL() !< diagnostic vertical sum y-diffusive content flux -! !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] - - real, dimension(:,:,:), pointer :: advection_xy => NULL() !< convergence of lateral advective tracer fluxes - !! [conc H T-1 ~> conc m s-1 or conc kg m-2 s-1] -! real, dimension(:,:,:), pointer :: diff_cont_xy => NULL() !< convergence of lateral diffusive tracer fluxes -! !! [conc H T-1 ~> conc m s-1 or conc kg m-2 s-1] -! real, dimension(:,:,:), pointer :: diff_conc_xy => NULL() !< convergence of lateral diffusive tracer fluxes -! !! expressed as a change in concentration -! !! [conc T-1 ~> conc s-1] - real, dimension(:,:,:), pointer :: t_prev => NULL() !< tracer concentration array at a previous - !! timestep used for diagnostics [conc] - real, dimension(:,:,:), pointer :: Trxh_prev => NULL() !< layer integrated tracer concentration array - !! at a previous timestep used for diagnostics - !! [conc H ~> conc m or conc kg m-2] - - character(len=32) :: name !< tracer name used for diagnostics and error messages - character(len=64) :: units !< Physical dimensions of the tracer concentration - character(len=240) :: longname !< Long name of the variable -! type(vardesc), pointer :: vd => NULL() !< metadata describing the tracer - logical :: registry_diags = .false. !< If true, use the registry to set up the - !! diagnostics associated with this tracer. - character(len=64) :: cmor_name !< CMOR name of this tracer - character(len=64) :: cmor_units !< CMOR physical dimensions of the tracer - character(len=240) :: cmor_longname !< CMOR long name of the tracer - character(len=32) :: flux_nameroot = "" !< Short tracer name snippet used construct the - !! names of flux diagnostics. - character(len=64) :: flux_longname = "" !< A word or phrase used construct the long - !! names of flux diagnostics. - real :: flux_scale = 1.0 !< A scaling factor used to convert the fluxes - !! of this tracer to its desired units, - !! including a factor compensating for H scaling. - character(len=48) :: flux_units = "" !< The units for fluxes of this variable. - character(len=48) :: conv_units = "" !< The units for the flux convergence of this tracer. - real :: conv_scale = 1.0 !< A scaling factor used to convert the flux - !! convergence of this tracer to its desired units, - !! including a factor compensating for H scaling. - character(len=48) :: cmor_tendprefix = "" !< The CMOR variable prefix for tendencies of this - !! tracer, required because CMOR does not follow any - !! discernable pattern for these names. - integer :: ind_tr_squared = -1 !< The tracer registry index for the square of this tracer - - !### THESE CAPABILITIES HAVE NOT YET BEEN IMPLEMENTED. - ! logical :: advect_tr = .true. !< If true, this tracer should be advected - ! logical :: hordiff_tr = .true. !< If true, this tracer should experience epineutral diffusion - logical :: remap_tr = .true. !< If true, this tracer should be vertically remapped - - integer :: diag_form = 1 !< An integer indicating which template is to be used to label diagnostics. - !>@{ Diagnostic IDs - integer :: id_tr = -1, id_tr_post_horzn = -1 - integer :: id_adx = -1, id_ady = -1, id_dfx = -1, id_dfy = -1 - integer :: id_lbd_bulk_dfx = -1, id_lbd_bulk_dfy = -1, id_lbd_dfx = -1, id_lbd_dfy = -1 - integer :: id_lbd_dfx_2d = -1 , id_lbd_dfy_2d = -1 - integer :: id_adx_2d = -1, id_ady_2d = -1, id_dfx_2d = -1, id_dfy_2d = -1 - integer :: id_adv_xy = -1, id_adv_xy_2d = -1 - integer :: id_dfxy_cont = -1, id_dfxy_cont_2d = -1, id_dfxy_conc = -1 - integer :: id_lbdxy_cont = -1, id_lbdxy_cont_2d = -1, id_lbdxy_conc = -1 - integer :: id_remap_conc = -1, id_remap_cont = -1, id_remap_cont_2d = -1 - integer :: id_tendency = -1, id_trxh_tendency = -1, id_trxh_tendency_2d = -1 - integer :: id_tr_vardec = -1 - !>@} -end type tracer_type - -!> Type to carry basic tracer information -type, public :: tracer_registry_type - integer :: ntr = 0 !< number of registered tracers - type(tracer_type) :: Tr(MAX_FIELDS_) !< array of registered tracers -! type(diag_ctrl), pointer :: diag !< structure to regulate timing of diagnostics - logical :: locked = .false. !< New tracers may be registered if locked=.false. - !! When locked=.true., no more tracers can be registered, - !! at which point common diagnostics can be set up - !! for the registered tracers -end type tracer_registry_type +!> Calculate and print the global inventories of registered tracers +interface MOM_tracer_chkinv + module procedure tracer_array_chkinv, tracer_Reg_chkinv +end interface MOM_tracer_chkinv contains !> This subroutine registers a tracer to be advected and laterally diffused. subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, units, & - cmor_name, cmor_units, cmor_longname, tr_desc, & - OBC_inflow, OBC_in_u, OBC_in_v, ad_x, ad_y, df_x, df_y, & - ad_2d_x, ad_2d_y, df_2d_x, df_2d_y, advection_xy, registry_diags, & - flux_nameroot, flux_longname, flux_units, flux_scale, & + cmor_name, cmor_units, cmor_longname, net_surfflux_name, & + NLT_budget_name, net_surfflux_longname, tr_desc, OBC_inflow, & + OBC_in_u, OBC_in_v, ad_x, ad_y, df_x, df_y, ad_2d_x, ad_2d_y, & + df_2d_x, df_2d_y, advection_xy, registry_diags, & + conc_scale, flux_nameroot, flux_longname, flux_units, flux_scale, & convergence_units, convergence_scale, cmor_tendprefix, diag_form, & - restart_CS, mandatory) + restart_CS, mandatory, underflow_conc, Tr_out, advect_scheme) type(hor_index_type), intent(in) :: HI !< horizontal index type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)), & - target :: tr_ptr !< target or pointer to the tracer array + target :: tr_ptr !< target or pointer to the tracer array [CU ~> conc] type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values character(len=*), optional, intent(in) :: name !< Short tracer name character(len=*), optional, intent(in) :: longname !< The long tracer name @@ -172,47 +72,55 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit character(len=*), optional, intent(in) :: cmor_name !< CMOR name character(len=*), optional, intent(in) :: cmor_units !< CMOR physical dimensions of variable character(len=*), optional, intent(in) :: cmor_longname !< CMOR long name + character(len=*), optional, intent(in) :: net_surfflux_name !< Name for net_surfflux diag + character(len=*), optional, intent(in) :: NLT_budget_name !< Name for NLT_budget diag + character(len=*), optional, intent(in) :: net_surfflux_longname !< Long name for net_surfflux diag type(vardesc), optional, intent(in) :: tr_desc !< A structure with metadata about the tracer real, optional, intent(in) :: OBC_inflow !< the tracer for all inflows via OBC for which OBC_in_u - !! or OBC_in_v are not specified (units of tracer CONC) + !! or OBC_in_v are not specified [CU ~> conc] real, dimension(:,:,:), optional, pointer :: OBC_in_u !< tracer at inflows through u-faces of - !! tracer cells (units of tracer CONC) + !! tracer cells [CU ~> conc] real, dimension(:,:,:), optional, pointer :: OBC_in_v !< tracer at inflows through v-faces of - !! tracer cells (units of tracer CONC) + !! tracer cells [CU ~> conc] ! The following are probably not necessary if registry_diags is present and true. real, dimension(:,:,:), optional, pointer :: ad_x !< diagnostic x-advective flux - !! [conc H L2 T-1 ~> CONC m3 s-1 or CONC kg s-1] + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), optional, pointer :: ad_y !< diagnostic y-advective flux - !! [conc H L2 T-1 ~> CONC m3 s-1 or CONC kg s-1] + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), optional, pointer :: df_x !< diagnostic x-diffusive flux - !! [conc H L2 T-1 ~> CONC m3 s-1 or CONC kg s-1] + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), optional, pointer :: df_y !< diagnostic y-diffusive flux - !! [conc H L2 T-1 ~> CONC m3 s-1 or CONC kg s-1] + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), optional, pointer :: ad_2d_x !< vert sum of diagnostic x-advect flux - !! [conc H L2 T-1 ~> CONC m3 s-1 or CONC kg s-1] + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), optional, pointer :: ad_2d_y !< vert sum of diagnostic y-advect flux - !! [conc H L2 T-1 ~> CONC m3 s-1 or CONC kg s-1] + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), optional, pointer :: df_2d_x !< vert sum of diagnostic x-diffuse flux - !! [conc H L2 T-1 ~> CONC m3 s-1 or CONC kg s-1] + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), optional, pointer :: df_2d_y !< vert sum of diagnostic y-diffuse flux - !! [conc H L2 T-1 ~> CONC m3 s-1 or CONC kg s-1] + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), optional, pointer :: advection_xy !< convergence of lateral advective tracer fluxes + !! [CU H T-1 ~> conc m s-1 or conc kg m-2 s-1] logical, optional, intent(in) :: registry_diags !< If present and true, use the registry for !! the diagnostics of this tracer. + real, optional, intent(in) :: conc_scale !< A scaling factor used to convert the concentration + !! of this tracer to its desired units [conc CU-1 ~> 1] character(len=*), optional, intent(in) :: flux_nameroot !< Short tracer name snippet used construct the !! names of flux diagnostics. character(len=*), optional, intent(in) :: flux_longname !< A word or phrase used construct the long !! names of flux diagnostics. character(len=*), optional, intent(in) :: flux_units !< The units for the fluxes of this tracer. real, optional, intent(in) :: flux_scale !< A scaling factor used to convert the fluxes - !! of this tracer to its desired units. + !! of this tracer to its desired units + !! [conc m CU-1 H-1 ~> 1] or [conc kg m-2 CU-1 H-1 ~> 1] character(len=*), optional, intent(in) :: convergence_units !< The units for the flux convergence of !! this tracer. real, optional, intent(in) :: convergence_scale !< A scaling factor used to convert the flux !! convergence of this tracer to its desired units. + !! [conc m CU-1 H-1 ~> 1] or [conc kg m-2 CU-1 H-1 ~> 1] character(len=*), optional, intent(in) :: cmor_tendprefix !< The CMOR name for the layer-integrated !! tendencies of this tracer. integer, optional, intent(in) :: diag_form !< An integer (1 or 2, 1 by default) indicating the @@ -221,6 +129,12 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit type(MOM_restart_CS), optional, intent(inout) :: restart_CS !< MOM restart control struct logical, optional, intent(in) :: mandatory !< If true, this tracer must be read !! from a restart file. + real, optional, intent(in) :: underflow_conc !< A tiny concentration, below which the tracer + !! concentration underflows to 0 [CU ~> conc]. + type(tracer_type), optional, pointer :: Tr_out !< If present, returns pointer into registry + + integer, optional, intent(in) :: advect_scheme !< Advection scheme for this tracer, the default is -1 + !! indicating to use the scheme from MOM_tracer_advect logical :: mand type(tracer_type), pointer :: Tr=>NULL() @@ -229,13 +143,14 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit if (.not. associated(Reg)) call tracer_registry_init(param_file, Reg) if (Reg%ntr>=MAX_FIELDS_) then - write(mesg,'("Increase MAX_FIELDS_ in MOM_memory.h to at least ",I3," to allow for & + write(mesg,'("Increase MAX_FIELDS_ in MOM_memory.h to at least ",I0," to allow for & &all the tracers being registered via register_tracer.")') Reg%ntr+1 call MOM_error(FATAL,"MOM register_tracer: "//mesg) endif Reg%ntr = Reg%ntr + 1 Tr => Reg%Tr(Reg%ntr) + if (present(Tr_out)) Tr_out => Reg%Tr(Reg%ntr) if (present(name)) then Tr%name = name @@ -267,6 +182,12 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit "MOM register_tracer was called for variable "//trim(Tr%name)//& " with a locked tracer registry.") + Tr%conc_scale = 1.0 + if (present(conc_scale)) Tr%conc_scale = conc_scale + + Tr%conc_underflow = 0.0 + if (present(underflow_conc)) Tr%conc_underflow = underflow_conc + Tr%flux_nameroot = Tr%name if (present(flux_nameroot)) then if (len_trim(flux_nameroot) > 0) Tr%flux_nameroot = flux_nameroot @@ -277,10 +198,26 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit if (len_trim(flux_longname) > 0) Tr%flux_longname = flux_longname endif + Tr%net_surfflux_name = "KPP_net"//trim(Tr%name) + if (present(net_surfflux_name)) then + Tr%net_surfflux_name = net_surfflux_name + endif + + Tr%NLT_budget_name = 'KPP_NLT_'//trim(Tr%flux_nameroot)//'_budget' + if (present(NLT_budget_name)) then + Tr%NLT_budget_name = NLT_budget_name + endif + + Tr%net_surfflux_longname = 'Effective net surface '//trim(lowercase(Tr%flux_longname))//& + ' flux, as used by [CVMix] KPP' + if (present(net_surfflux_longname)) then + Tr%net_surfflux_longname = net_surfflux_longname + endif + Tr%flux_units = "" if (present(flux_units)) Tr%flux_units = flux_units - Tr%flux_scale = GV%H_to_MKS + Tr%flux_scale = GV%H_to_MKS*Tr%conc_scale if (present(flux_scale)) Tr%flux_scale = flux_scale Tr%conv_units = "" @@ -289,7 +226,7 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit Tr%cmor_tendprefix = "" if (present(cmor_tendprefix)) Tr%cmor_tendprefix = cmor_tendprefix - Tr%conv_scale = GV%H_to_MKS + Tr%conv_scale = GV%H_to_MKS*Tr%conc_scale if (present(convergence_scale)) then Tr%conv_scale = convergence_scale elseif (present(flux_scale)) then @@ -299,6 +236,9 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit Tr%diag_form = 1 if (present(diag_form)) Tr%diag_form = diag_form + Tr%advect_scheme = -1 + if (present(advect_scheme)) Tr%advect_scheme = advect_scheme + Tr%t => tr_ptr if (present(registry_diags)) Tr%registry_diags = registry_diags @@ -314,14 +254,16 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit if (present(ad_2d_y)) then ; if (associated(ad_2d_y)) Tr%ad2d_y => ad_2d_y ; endif if (present(df_2d_x)) then ; if (associated(df_2d_x)) Tr%df2d_x => df_2d_x ; endif - if (present(advection_xy)) then ; if (associated(advection_xy)) Tr%advection_xy => advection_xy ; endif + if (present(advection_xy)) then + if (associated(advection_xy)) Tr%advection_xy => advection_xy + endif if (present(restart_CS)) then ! Register this tracer to be read from and written to restart files. mand = .true. ; if (present(mandatory)) mand = mandatory call register_restart_field(tr_ptr, Tr%name, mand, restart_CS, & - longname=Tr%longname, units=Tr%units) + longname=Tr%longname, units=Tr%units, conversion=conc_scale) endif end subroutine register_tracer @@ -340,7 +282,7 @@ end subroutine lock_tracer_registry !> register_tracer_diagnostics does a set of register_diag_field calls for any previously !! registered in a tracer registry with a value of registry_diags set to .true. -subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) +subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, use_KPP) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -351,23 +293,25 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) type(diag_ctrl), intent(in) :: diag !< structure to regulate diagnostic output logical, intent(in) :: use_ALE !< If true active diagnostics that only !! apply to ALE configurations - - character(len=24) :: name ! A variable's name in a NetCDF file. - character(len=24) :: shortnm ! A shortened version of a variable's name for - ! creating additional diagnostics. - character(len=72) :: longname ! The long name of that tracer variable. - character(len=72) :: flux_longname ! The tracer name in the long names of fluxes. - character(len=48) :: units ! The dimensions of the tracer. - character(len=48) :: flux_units ! The units for fluxes, either - ! [units] m3 s-1 or [units] kg s-1. - character(len=48) :: conv_units ! The units for flux convergences, either - ! [units] m2 s-1 or [units] kg s-1. - character(len=48) :: unit2 ! The dimensions of the tracer squared + logical, intent(in) :: use_KPP !< If true active diagnostics that only + !! apply to CVMix KPP mixings + + character(len=24) :: name ! A variable's name in a NetCDF file. + character(len=24) :: shortnm ! A shortened version of a variable's name for + ! creating additional diagnostics. + character(len=72) :: longname ! The long name of that tracer variable. + character(len=72) :: flux_longname ! The tracer name in the long names of fluxes. + character(len=48) :: units ! The dimensions of the tracer. + character(len=48) :: flux_units ! The units for fluxes, either + ! [units] m3 s-1 or [units] kg s-1. + character(len=48) :: conv_units ! The units for flux convergences, either + ! [units] m s-1 or [units] kg m-2 s-1. + character(len=48) :: unit2 ! The dimensions of the tracer squared character(len=72) :: cmorname ! The CMOR name of this tracer. character(len=120) :: cmor_longname ! The CMOR long name of that variable. character(len=120) :: var_lname ! A temporary longname for a diagnostic. character(len=120) :: cmor_var_lname ! The temporary CMOR long name for a diagnostic - character(len=72) :: cmor_varname ! The temporary CMOR name for a diagnostic + real :: conversion ! Temporary term while we address a bug [conc m CU-1 H-1 ~> 1] or [conc kg m-2 CU-1 H-1 ~> 1] type(tracer_type), pointer :: Tr=>NULL() integer :: i, j, k, is, ie, js, je, nz, m, m2, nTr_in integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -401,17 +345,17 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) if (len_trim(cmorname) == 0) then Tr%id_tr = register_diag_field("ocean_model", trim(name), diag%axesTL, & - Time, trim(longname), trim(units)) + Time, trim(longname), trim(units), conversion=Tr%conc_scale) else Tr%id_tr = register_diag_field("ocean_model", trim(name), diag%axesTL, & - Time, trim(longname), trim(units), cmor_field_name=cmorname, & - cmor_long_name=cmor_longname, cmor_units=Tr%cmor_units, & - cmor_standard_name=cmor_long_std(cmor_longname)) + Time, trim(longname), trim(units), conversion=Tr%conc_scale, & + cmor_field_name=cmorname, cmor_long_name=cmor_longname, & + cmor_units=Tr%cmor_units, cmor_standard_name=cmor_long_std(cmor_longname)) endif Tr%id_tr_post_horzn = register_diag_field("ocean_model", & trim(name)//"_post_horzn", diag%axesTL, Time, & trim(longname)//" after horizontal transport (advection/diffusion) has occurred", & - trim(units)) + trim(units), conversion=Tr%conc_scale) if (Tr%diag_form == 1) then Tr%id_adx = register_diag_field("ocean_model", trim(shortnm)//"_adx", & diag%axesCuL, Time, trim(flux_longname)//" advective zonal flux" , & @@ -429,13 +373,14 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional flux" , & trim(flux_units), v_extensive=.true., x_cell_method='sum', & conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) - Tr%id_lbd_dfx = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffx", & - diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux from the lateral boundary diffusion "//& - "scheme", trim(flux_units), v_extensive=.true., y_cell_method='sum', & - conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) - Tr%id_lbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffy", & - diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional flux from the lateral boundary diffusion "//& - "scheme", trim(flux_units), v_extensive=.true., x_cell_method='sum', & + Tr%id_hbd_dfx = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffx", & + diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux " //& + "from the horizontal boundary diffusion scheme", trim(flux_units), v_extensive=.true., & + y_cell_method='sum', conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) + Tr%id_hbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffy", & + diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional " //& + "flux from the horizontal boundary diffusion scheme", & + trim(flux_units), v_extensive=.true., x_cell_method='sum', & conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) else Tr%id_adx = register_diag_field("ocean_model", trim(shortnm)//"_adx", & @@ -452,21 +397,33 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) diag%axesCvL, Time, "Diffusive Meridional Flux of "//trim(flux_longname), & flux_units, v_extensive=.true., conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & x_cell_method='sum') - Tr%id_lbd_dfx = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffx", & - diag%axesCuL, Time, "Lateral Boundary Diffusive Zonal Flux of "//trim(flux_longname), & + Tr%id_hbd_dfx = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffx", & + diag%axesCuL, Time, & + "Horizontal Boundary Diffusive Zonal Flux of "//trim(flux_longname), & flux_units, v_extensive=.true., conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & y_cell_method='sum') - Tr%id_lbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffy", & - diag%axesCvL, Time, "Lateral Boundary Diffusive Meridional Flux of "//trim(flux_longname), & + Tr%id_hbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffy", & + diag%axesCvL, Time, & + "Horizontal Boundary Diffusive Meridional Flux of "//trim(flux_longname), & flux_units, v_extensive=.true., conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & x_cell_method='sum') endif + Tr%id_zint = register_diag_field("ocean_model", trim(shortnm)//"_zint", & + diag%axesT1, Time, & + "Thickness-weighted integral of " // trim(longname), & + trim(units) // " m") + Tr%id_zint_100m = register_diag_field("ocean_model", trim(shortnm)//"_zint_100m", & + diag%axesT1, Time, & + "Thickness-weighted integral of "// trim(longname) // " over top 100m", & + trim(units) // " m") + Tr%id_surf = register_diag_field("ocean_model", trim(shortnm)//"_SURF", & + diag%axesT1, Time, "Surface values of "// trim(longname), trim(units)) if (Tr%id_adx > 0) call safe_alloc_ptr(Tr%ad_x,IsdB,IedB,jsd,jed,nz) if (Tr%id_ady > 0) call safe_alloc_ptr(Tr%ad_y,isd,ied,JsdB,JedB,nz) if (Tr%id_dfx > 0) call safe_alloc_ptr(Tr%df_x,IsdB,IedB,jsd,jed,nz) if (Tr%id_dfy > 0) call safe_alloc_ptr(Tr%df_y,isd,ied,JsdB,JedB,nz) - if (Tr%id_lbd_dfx > 0) call safe_alloc_ptr(Tr%lbd_dfx,IsdB,IedB,jsd,jed,nz) - if (Tr%id_lbd_dfy > 0) call safe_alloc_ptr(Tr%lbd_dfy,isd,ied,JsdB,JedB,nz) + if (Tr%id_hbd_dfx > 0) call safe_alloc_ptr(Tr%hbd_dfx,IsdB,IedB,jsd,jed,nz) + if (Tr%id_hbd_dfy > 0) call safe_alloc_ptr(Tr%hbd_dfy,isd,ied,JsdB,JedB,nz) Tr%id_adx_2d = register_diag_field("ocean_model", trim(shortnm)//"_adx_2d", & diag%axesCu1, Time, & @@ -486,37 +443,26 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) "Vertically Integrated Diffusive Meridional Flux of "//trim(flux_longname), & flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & x_cell_method='sum') - Tr%id_lbd_bulk_dfx = register_diag_field("ocean_model", trim(shortnm)//"_lbd_bulk_diffx", & - diag%axesCu1, Time, & - "Total Bulk Diffusive Zonal Flux of "//trim(flux_longname), & - flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & - y_cell_method='sum') - Tr%id_lbd_bulk_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbd_bulk_diffy", & - diag%axesCv1, Time, & - "Total Bulk Diffusive Meridional Flux of "//trim(flux_longname), & - flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & - x_cell_method='sum') - Tr%id_lbd_dfx_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffx_2d", & - diag%axesCu1, Time, "Vertically-integrated zonal diffusive flux from the lateral boundary diffusion "//& + Tr%id_hbd_dfx_2d = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffx_2d", & + diag%axesCu1, Time, "Vertically-integrated zonal diffusive flux from the horizontal boundary diffusion "//& "scheme for "//trim(flux_longname), flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & y_cell_method='sum') - Tr%id_lbd_dfy_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffy_2d", & - diag%axesCv1, Time, "Vertically-integrated meridional diffusive flux from the lateral boundary diffusion "//& + Tr%id_hbd_dfy_2d = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffy_2d", & + diag%axesCv1, Time, "Vertically-integrated meridional diffusive flux from the horizontal boundary diffusion "//& "scheme for "//trim(flux_longname), flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & - x_cell_method='sum') + x_cell_method='sum') if (Tr%id_adx_2d > 0) call safe_alloc_ptr(Tr%ad2d_x,IsdB,IedB,jsd,jed) if (Tr%id_ady_2d > 0) call safe_alloc_ptr(Tr%ad2d_y,isd,ied,JsdB,JedB) if (Tr%id_dfx_2d > 0) call safe_alloc_ptr(Tr%df2d_x,IsdB,IedB,jsd,jed) if (Tr%id_dfy_2d > 0) call safe_alloc_ptr(Tr%df2d_y,isd,ied,JsdB,JedB) - if (Tr%id_lbd_bulk_dfx > 0) call safe_alloc_ptr(Tr%lbd_bulk_df_x,IsdB,IedB,jsd,jed) - if (Tr%id_lbd_bulk_dfy > 0) call safe_alloc_ptr(Tr%lbd_bulk_df_y,isd,ied,JsdB,JedB) - if (Tr%id_lbd_dfx_2d > 0) call safe_alloc_ptr(Tr%lbd_dfx_2d,IsdB,IedB,jsd,jed) - if (Tr%id_lbd_dfy_2d > 0) call safe_alloc_ptr(Tr%lbd_dfy_2d,isd,ied,JsdB,JedB) + if (Tr%id_hbd_dfx_2d > 0) call safe_alloc_ptr(Tr%hbd_dfx_2d,IsdB,IedB,jsd,jed) + if (Tr%id_hbd_dfy_2d > 0) call safe_alloc_ptr(Tr%hbd_dfy_2d,isd,ied,JsdB,JedB) Tr%id_adv_xy = register_diag_field('ocean_model', trim(shortnm)//"_advection_xy", & diag%axesTL, Time, & - 'Horizontal convergence of residual mean advective fluxes of '//trim(lowercase(flux_longname)), & + 'Horizontal convergence of residual mean advective fluxes of '//& + trim(lowercase(flux_longname)), & conv_units, v_extensive=.true., conversion=Tr%conv_scale*US%s_to_T) Tr%id_adv_xy_2d = register_diag_field('ocean_model', trim(shortnm)//"_advection_xy_2d", & diag%axesT1, Time, & @@ -527,7 +473,8 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) Tr%id_tendency = register_diag_field('ocean_model', trim(shortnm)//'_tendency', & diag%axesTL, Time, & - 'Net time tendency for '//trim(lowercase(longname)), trim(units)//' s-1', conversion=US%s_to_T) + 'Net time tendency for '//trim(lowercase(longname)), & + trim(units)//' s-1', conversion=Tr%conc_scale*US%s_to_T) if (Tr%id_tendency > 0) then call safe_alloc_ptr(Tr%t_prev,isd,ied,jsd,jed,nz) @@ -536,60 +483,66 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) enddo ; enddo ; enddo endif - ! Neutral/Lateral diffusion convergence tendencies + ! Neutral/Horizontal diffusion convergence tendencies if (Tr%diag_form == 1) then Tr%id_dfxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_cont_tendency', & diag%axesTL, Time, "Neutral diffusion tracer content tendency for "//trim(shortnm), & - conv_units, conversion=Tr%conv_scale*US%s_to_T, x_cell_method='sum', y_cell_method='sum', v_extensive=.true.) + conv_units, conversion=Tr%conv_scale*US%s_to_T, v_extensive=.true.) - Tr%id_dfxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_cont_tendency_2d', & + Tr%id_dfxy_cont_2d = register_diag_field("ocean_model", & + trim(shortnm)//'_dfxy_cont_tendency_2d', & diag%axesT1, Time, "Depth integrated neutral diffusion tracer content "//& - "tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & - x_cell_method='sum', y_cell_method='sum') + "tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T) - Tr%id_lbdxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_cont_tendency', & - diag%axesTL, Time, "Lateral diffusion tracer content tendency for "//trim(shortnm), & - conv_units, conversion=Tr%conv_scale*US%s_to_T, x_cell_method='sum', y_cell_method='sum', v_extensive=.true.) + Tr%id_hbdxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_hbdxy_cont_tendency', & + diag%axesTL, Time, "Horizontal boundary diffusion tracer content tendency for "//& + trim(shortnm), & + conv_units, conversion=Tr%conv_scale*US%s_to_T, v_extensive=.true.) - Tr%id_lbdxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_cont_tendency_2d', & - diag%axesT1, Time, "Depth integrated lateral diffusion tracer content "//& - "tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & - x_cell_method='sum', y_cell_method='sum') + Tr%id_hbdxy_cont_2d = register_diag_field("ocean_model", & + trim(shortnm)//'_hbdxy_cont_tendency_2d', & + diag%axesT1, Time, "Depth integrated horizontal boundary diffusion tracer content "//& + "tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T) else cmor_var_lname = 'Tendency of '//trim(lowercase(cmor_longname))//' expressed as '//& - trim(lowercase(flux_longname))//' content due to parameterized mesoscale neutral diffusion' + trim(lowercase(flux_longname))//& + ' content due to parameterized mesoscale neutral diffusion' Tr%id_dfxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_cont_tendency', & diag%axesTL, Time, "Neutral diffusion tracer content tendency for "//trim(shortnm), & - conv_units, conversion=Tr%conv_scale*US%s_to_T, cmor_field_name=trim(Tr%cmor_tendprefix)//'pmdiff', & - cmor_long_name=trim(cmor_var_lname), cmor_standard_name=trim(cmor_long_std(cmor_var_lname)), & - x_cell_method='sum', y_cell_method='sum', v_extensive=.true.) + conv_units, conversion=Tr%conv_scale*US%s_to_T, v_extensive=.true., & + cmor_field_name=trim(Tr%cmor_tendprefix)//'pmdiff', & + cmor_long_name=trim(cmor_var_lname), & + cmor_standard_name=trim(cmor_long_std(cmor_var_lname))) cmor_var_lname = 'Tendency of '//trim(lowercase(cmor_longname))//' expressed as '//& - trim(lowercase(flux_longname))//' content due to parameterized mesoscale neutral diffusion' - Tr%id_dfxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_cont_tendency_2d', & + trim(lowercase(flux_longname))//& + ' content due to parameterized mesoscale neutral diffusion' + Tr%id_dfxy_cont_2d = register_diag_field("ocean_model", & + trim(shortnm)//'_dfxy_cont_tendency_2d', & diag%axesT1, Time, "Depth integrated neutral diffusion tracer "//& "content tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & cmor_field_name=trim(Tr%cmor_tendprefix)//'pmdiff_2d', & - cmor_long_name=trim(cmor_var_lname), cmor_standard_name=trim(cmor_long_std(cmor_var_lname)), & - x_cell_method='sum', y_cell_method='sum') - - Tr%id_lbdxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_cont_tendency', & - diag%axesTL, Time, "Lateral diffusion tracer content tendency for "//trim(shortnm), & - conv_units, conversion=Tr%conv_scale*US%s_to_T, & - x_cell_method='sum', y_cell_method='sum', v_extensive=.true.) - - Tr%id_lbdxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_cont_tendency_2d', & - diag%axesT1, Time, "Depth integrated lateral diffusion tracer "//& - "content tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & - x_cell_method='sum', y_cell_method='sum') + cmor_long_name=trim(cmor_var_lname), & + cmor_standard_name=trim(cmor_long_std(cmor_var_lname))) + + Tr%id_hbdxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_hbdxy_cont_tendency', & + diag%axesTL, Time, & + "Horizontal boundary diffusion tracer content tendency for "//trim(shortnm), & + conv_units, conversion=Tr%conv_scale*US%s_to_T, v_extensive=.true.) + + Tr%id_hbdxy_cont_2d = register_diag_field("ocean_model", & + trim(shortnm)//'_hbdxy_cont_tendency_2d', & + diag%axesT1, Time, "Depth integrated horizontal boundary diffusion of tracer "//& + "content tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T) endif Tr%id_dfxy_conc = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_conc_tendency', & diag%axesTL, Time, "Neutral diffusion tracer concentration tendency for "//trim(shortnm), & - trim(units)//' s-1', conversion=US%s_to_T) + trim(units)//' s-1', conversion=Tr%conc_scale*US%s_to_T) - Tr%id_lbdxy_conc = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_conc_tendency', & - diag%axesTL, Time, "Lateral diffusion tracer concentration tendency for "//trim(shortnm), & - trim(units)//' s-1', conversion=US%s_to_T) + Tr%id_hbdxy_conc = register_diag_field("ocean_model", trim(shortnm)//'_hbdxy_conc_tendency', & + diag%axesTL, Time, & + "Horizontal diffusion tracer concentration tendency for "//trim(shortnm), & + trim(units)//' s-1', conversion=Tr%conc_scale*US%s_to_T) var_lname = "Net time tendency for "//lowercase(flux_longname) if (len_trim(Tr%cmor_tendprefix) == 0) then @@ -626,7 +579,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) var_lname = "Vertical remapping tracer concentration tendency for "//trim(Reg%Tr(m)%name) Tr%id_remap_conc= register_diag_field('ocean_model', & trim(Tr%flux_nameroot)//'_tendency_vert_remap', diag%axesTL, Time, var_lname, & - trim(units)//' s-1', conversion=US%s_to_T) + trim(units)//' s-1', conversion=Tr%conc_scale*US%s_to_T) var_lname = "Vertical remapping tracer content tendency for "//trim(Reg%Tr(m)%flux_longname) Tr%id_remap_cont = register_diag_field('ocean_model', & @@ -645,7 +598,8 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) unit2 = trim(units)//"2" if (index(units(1:len_trim(units))," ") > 0) unit2 = "("//trim(units)//")2" Tr%id_tr_vardec = register_diag_field('ocean_model', trim(shortnm)//"_vardec", diag%axesTL, & - Time, "ALE variance decay for "//lowercase(longname), trim(unit2)//" s-1", conversion=US%s_to_T) + Time, "ALE variance decay for "//lowercase(longname), & + trim(unit2)//" s-1", conversion=Tr%conc_scale**2*US%s_to_T) if (Tr%id_tr_vardec > 0) then ! Set up a new tracer for this tracer squared m2 = Reg%ntr+1 @@ -661,6 +615,31 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) endif endif + ! KPP nonlocal term diagnostics + if (use_KPP) then + Tr%id_net_surfflux = register_diag_field('ocean_model', Tr%net_surfflux_name, diag%axesT1, Time, & + Tr%net_surfflux_longname, trim(units)//' m s-1', conversion=Tr%conc_scale*GV%H_to_m*US%s_to_T) + Tr%id_NLT_tendency = register_diag_field('ocean_model', "KPP_NLT_d"//trim(shortnm)//"dt", & + diag%axesTL, Time, & + trim(longname)//' tendency due to non-local transport of '//trim(lowercase(flux_longname))//& + ', as calculated by [CVMix] KPP', trim(units)//' s-1', conversion=Tr%conc_scale*US%s_to_T) + if (Tr%conv_scale == 0.001*GV%H_to_kg_m2) then + conversion = GV%H_to_kg_m2 + else + conversion = Tr%conv_scale + endif + ! We actually want conversion=Tr%conv_scale for all tracers, but introducing the local variable + ! 'conversion' and setting it to GV%H_to_kg_m2 instead of 0.001*GV%H_to_kg_m2 for salt tracers + ! keeps changes introduced by this refactoring limited to round-off level; as it turns out, + ! there is a bug in the code and the NLT budget term for salinity is off by a factor of 10^3 + ! so introducing the 0.001 here will fix that bug. + Tr%id_NLT_budget = register_diag_field('ocean_model', Tr%NLT_budget_name, & + diag%axesTL, Time, & + trim(flux_longname)//& + ' content change due to non-local transport, as calculated by [CVMix] KPP', & + conv_units, conversion=conversion*US%s_to_T, v_extensive=.true.) + endif + endif ; enddo end subroutine register_tracer_diagnostics @@ -690,7 +669,7 @@ subroutine postALE_tracer_diagnostics(Reg, G, GV, diag, dt) type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output real, intent(in) :: dt !< total time interval for these diagnostics [T ~> s] - real :: work(SZI_(G),SZJ_(G),SZK_(GV)) + real :: work(SZI_(G),SZJ_(G),SZK_(GV)) ! Variance decay [CU2 T-1 ~> conc2 s-1] real :: Idt ! The inverse of the time step [T-1 ~> s-1] integer :: i, j, k, is, ie, js, je, nz, m, m2 is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -722,14 +701,15 @@ subroutine post_tracer_diagnostics_at_sync(Reg, h, diag_prev, diag, G, GV, dt) type(diag_ctrl), intent(inout) :: diag !< structure to regulate diagnostic output real, intent(in) :: dt !< total time step for tracer updates [T ~> s] - real :: work3d(SZI_(G),SZJ_(G),SZK_(GV)) - real :: work2d(SZI_(G),SZJ_(G)) + real :: work3d(SZI_(G),SZJ_(G),SZK_(GV)) ! The time tendency of a diagnostic [CU T-1 ~> conc s-1] + real :: work2d(SZI_(G),SZJ_(G)) ! The vertically integrated time tendency of a diagnostic + ! in [CU H T-1 ~> conc m s-1 or conc kg m-2 s-1] real :: Idt ! The inverse of the time step [T-1 ~> s-1] type(tracer_type), pointer :: Tr=>NULL() integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - Idt = 0.; if (dt/=0.) Idt = 1.0 / dt ! The "if" is in case the diagnostic is called for a zero length interval + Idt = 0. ; if (dt/=0.) Idt = 1.0 / dt ! The "if" is in case the diagnostic is called for a zero length interval ! Tendency diagnostics need to be posted on the grid from the last call to this routine call diag_save_grids(diag) @@ -750,7 +730,8 @@ subroutine post_tracer_diagnostics_at_sync(Reg, h, diag_prev, diag, G, GV, dt) work3d(i,j,k) = (Tr%t(i,j,k)*h(i,j,k) - Tr%Trxh_prev(i,j,k)) * Idt Tr%Trxh_prev(i,j,k) = Tr%t(i,j,k) * h(i,j,k) enddo ; enddo ; enddo - if (Tr%id_trxh_tendency > 0) call post_data(Tr%id_trxh_tendency, work3d, diag, alt_h=diag_prev%h_state) + if (Tr%id_trxh_tendency > 0) call post_data(Tr%id_trxh_tendency, work3d, diag, & + alt_h=diag_prev%h_state) if (Tr%id_trxh_tendency_2d > 0) then work2d(:,:) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie @@ -773,12 +754,45 @@ subroutine post_tracer_transport_diagnostics(G, GV, Reg, h_diag, diag) intent(in) :: h_diag !< Layer thicknesses on which to post fields [H ~> m or kg m-2] type(diag_ctrl), intent(in) :: diag !< structure to regulate diagnostic output - integer :: i, j, k, is, ie, js, je, nz, m - real :: work2d(SZI_(G),SZJ_(G)) + integer :: i, j, k, is, ie, js, je, nz, m, khi + real :: work2d(SZI_(G),SZJ_(G)) ! The vertically integrated convergence of lateral advective + ! tracer fluxes [CU H T-1 ~> conc m s-1 or conc kg m-2 s-1] + real :: frac_under_100m(SZI_(G),SZJ_(G),SZK_(GV)) ! weights used to compute 100m vertical integrals [nondim] + real :: ztop(SZI_(G),SZJ_(G)) ! position of the top interface [H ~> m or kg m-2] + real :: zbot(SZI_(G),SZJ_(G)) ! position of the bottom interface [H ~> m or kg m-2] type(tracer_type), pointer :: Tr=>NULL() is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + ! If any tracers are posting 100m vertical integrals, compute weights + frac_under_100m(:,:,:) = 0.0 + ! khi will be the largest layer index corresponding where ztop < 100m and ztop >= 100m + ! in any column (we can reduce computation of 100m integrals by only looping through khi + ! rather than GV%ke) + khi = 0 + do m=1,Reg%ntr ; if (Reg%Tr(m)%registry_diags) then + Tr => Reg%Tr(m) + if (Tr%id_zint_100m > 0) then + zbot(:,:) = 0.0 + do k=1, nz + do j=js,je ; do i=is,ie + ztop(i,j) = zbot(i,j) + zbot(i,j) = ztop(i,j) + h_diag(i,j,k)*GV%H_to_m + if (zbot(i,j) <= 100.0) then + frac_under_100m(i,j,k) = 1.0 + elseif (ztop(i,j) < 100.0) then + frac_under_100m(i,j,k) = (100.0 - ztop(i,j)) / (zbot(i,j) - ztop(i,j)) + else + frac_under_100m(i,j,k) = 0.0 + endif + ! frac_under_100m(i,j,k) = max(0, min(1.0, (100.0 - ztop(i,j)) / (zbot(i,j) - ztop(i,j)))) + enddo ; enddo + if (any(frac_under_100m(:,:,k) > 0)) khi = k + enddo + exit + endif + endif ; enddo + do m=1,Reg%ntr ; if (Reg%Tr(m)%registry_diags) then Tr => Reg%Tr(m) if (Tr%id_tr_post_horzn> 0) call post_data(Tr%id_tr_post_horzn, Tr%t, diag) @@ -798,12 +812,34 @@ subroutine post_tracer_transport_diagnostics(G, GV, Reg, h_diag, diag) enddo ; enddo ; enddo call post_data(Tr%id_adv_xy_2d, work2d, diag) endif + + ! A few diagnostics introduce with MARBL driver + ! Compute full-depth vertical integral + if (Tr%id_zint > 0) then + work2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do i=is,ie + work2d(i,j) = work2d(i,j) + (h_diag(i,j,k)*GV%H_to_m)*tr%t(i,j,k) + enddo ; enddo ; enddo + call post_data(Tr%id_zint, work2d, diag) + endif + + ! Compute 100m vertical integral + if (Tr%id_zint_100m > 0) then + work2d(:,:) = 0.0 + do k=1,khi ; do j=js,je ; do i=is,ie + work2d(i,j) = work2d(i,j) + frac_under_100m(i,j,k)*((h_diag(i,j,k)*GV%H_to_m)*tr%t(i,j,k)) + enddo ; enddo ; enddo + call post_data(Tr%id_zint_100m, work2d, diag) + endif + + ! Surface values of tracers + if (Tr%id_SURF > 0) call post_data(Tr%id_SURF, Tr%t(:,:,1), diag) endif ; enddo end subroutine post_tracer_transport_diagnostics -!> This subroutine writes out chksums for tracers. -subroutine MOM_tracer_chksum(mesg, Tr, ntr, G) +!> This subroutine writes out chksums for the first ntr registered tracers. +subroutine tracer_array_chksum(mesg, Tr, ntr, G) character(len=*), intent(in) :: mesg !< message that appears on the chksum lines type(tracer_type), intent(in) :: Tr(:) !< array of all of registered tracers integer, intent(in) :: ntr !< number of registered tracers @@ -812,13 +848,29 @@ subroutine MOM_tracer_chksum(mesg, Tr, ntr, G) integer :: m do m=1,ntr - call hchksum(Tr(m)%t, mesg//trim(Tr(m)%name), G%HI) + call hchksum(Tr(m)%t, mesg//trim(Tr(m)%name), G%HI, unscale=Tr(m)%conc_scale) enddo -end subroutine MOM_tracer_chksum +end subroutine tracer_array_chksum -!> Calculates and prints the global inventory of all tracers in the registry. -subroutine MOM_tracer_chkinv(mesg, G, GV, h, Tr, ntr) +!> This subroutine writes out chksums for all the registered tracers. +subroutine tracer_Reg_chksum(mesg, Reg, G) + character(len=*), intent(in) :: mesg !< message that appears on the chksum lines + type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + + integer :: m + + if (.not.associated(Reg)) return + + do m=1,Reg%ntr + call hchksum(Reg%Tr(m)%t, mesg//trim(Reg%Tr(m)%name), G%HI, unscale=Reg%Tr(m)%conc_scale) + enddo + +end subroutine tracer_Reg_chksum + +!> Calculates and prints the global inventory of the first ntr tracers in the registry. +subroutine tracer_array_chkinv(mesg, G, GV, h, Tr, ntr) character(len=*), intent(in) :: mesg !< message that appears on the chksum lines type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -827,35 +879,79 @@ subroutine MOM_tracer_chkinv(mesg, G, GV, h, Tr, ntr) integer, intent(in) :: ntr !< number of registered tracers ! Local variables - real :: vol_scale ! The dimensional scaling factor to convert volumes to m3 [m3 H-1 L-2 ~> 1 or m3 kg-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tr_inv ! Volumetric tracer inventory in each cell [conc m3] - real :: total_inv ! The total amount of tracer [conc m3] + real :: vol_scale ! The dimensional scaling factor to convert volumes to m3 [m3 H-1 L-2 ~> 1] or cell + ! masses to kg [kg H-1 L-2 ~> 1], depending on whether the Boussinesq approximation is used + real :: tr_inv(SZI_(G),SZJ_(G),SZK_(GV)) ! Volumetric or mass-based tracer inventory in + ! each cell [conc m3] or [conc kg] + real :: total_inv ! The total amount of tracer [conc m3] or [conc kg] integer :: is, ie, js, je, nz integer :: i, j, k, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - vol_scale = GV%H_to_m*G%US%L_to_m**2 + vol_scale = GV%H_to_MKS*G%US%L_to_m**2 do m=1,ntr do k=1,nz ; do j=js,je ; do i=is,ie - tr_inv(i,j,k) = Tr(m)%t(i,j,k) * (vol_scale * h(i,j,k) * G%areaT(i,j)*G%mask2dT(i,j)) + tr_inv(i,j,k) = Tr(m)%conc_scale*Tr(m)%t(i,j,k) * & + (vol_scale * h(i,j,k) * G%areaT(i,j)*G%mask2dT(i,j)) + enddo ; enddo ; enddo + total_inv = reproducing_sum(tr_inv, is+(1-G%isd), ie+(1-G%isd), js+(1-G%jsd), je+(1-G%jsd)) + if (is_root_pe()) write(0,'(A,1X,A5,1X,ES25.16,1X,A)') & + "h-point: inventory", Tr(m)%name, total_inv, mesg + enddo + +end subroutine tracer_array_chkinv + + +!> Calculates and prints the global inventory of all tracers in the registry. +subroutine tracer_Reg_chkinv(mesg, G, GV, h, Reg) + character(len=*), intent(in) :: mesg !< message that appears on the chksum lines + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + + ! Local variables + real :: vol_scale ! The dimensional scaling factor to convert volumes to m3 [m3 H-1 L-2 ~> 1] or cell + ! masses to kg [kg H-1 L-2 ~> 1], depending on whether the Boussinesq approximation is used + real :: tr_inv(SZI_(G),SZJ_(G),SZK_(GV)) ! Volumetric or mass-based tracer inventory in + ! each cell [conc m3] or [conc kg] + real :: total_inv ! The total amount of tracer [conc m3] or [conc kg] + integer :: is, ie, js, je, nz + integer :: i, j, k, m + + if (.not.associated(Reg)) return + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + vol_scale = GV%H_to_MKS*G%US%L_to_m**2 + do m=1,Reg%ntr + do k=1,nz ; do j=js,je ; do i=is,ie + tr_inv(i,j,k) = Reg%Tr(m)%conc_scale*Reg%Tr(m)%t(i,j,k) * & + (vol_scale * h(i,j,k) * G%areaT(i,j)*G%mask2dT(i,j)) enddo ; enddo ; enddo total_inv = reproducing_sum(tr_inv, is+(1-G%isd), ie+(1-G%isd), js+(1-G%jsd), je+(1-G%jsd)) - if (is_root_pe()) write(0,'(A,1X,A5,1X,ES25.16,1X,A)') "h-point: inventory", Tr(m)%name, total_inv, mesg + if (is_root_pe()) write(0,'(A,1X,A5,1X,ES25.16,1X,A)') & + "h-point: inventory", Reg%Tr(m)%name, total_inv, mesg enddo -end subroutine MOM_tracer_chkinv +end subroutine tracer_Reg_chkinv + !> Find a tracer in the tracer registry by name. -subroutine tracer_name_lookup(Reg, tr_ptr, name) +subroutine tracer_name_lookup(Reg, n, tr_ptr, name) type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry type(tracer_type), pointer :: tr_ptr !< target or pointer to the tracer array character(len=32), intent(in) :: name !< tracer name + integer, intent(out) :: n !< index to tracer registery - integer n do n=1,Reg%ntr - if (lowercase(Reg%Tr(n)%name) == lowercase(name)) tr_ptr => Reg%Tr(n) + if (lowercase(Reg%Tr(n)%name) == lowercase(name)) then + tr_ptr => Reg%Tr(n) + return + endif enddo + call MOM_error(FATAL,"MOM cannot find registered tracer: "//name) + end subroutine tracer_name_lookup !> Initialize the tracer registry. @@ -878,9 +974,9 @@ subroutine tracer_registry_init(param_file, Reg) init_calls = init_calls + 1 if (init_calls > 1) then - write(mesg,'("tracer_registry_init called ",I3, & + write(mesg,'("tracer_registry_init called ",I0, & &" times with different registry pointers.")') init_calls - if (is_root_pe()) call MOM_error(WARNING,"MOM_tracer"//mesg) + if (is_root_pe()) call MOM_error(WARNING,"MOM_tracer "//mesg) endif end subroutine tracer_registry_init diff --git a/src/tracer/MOM_tracer_types.F90 b/src/tracer/MOM_tracer_types.F90 new file mode 100644 index 0000000000..730a453695 --- /dev/null +++ b/src/tracer/MOM_tracer_types.F90 @@ -0,0 +1,138 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> This module contains the tracer_type and tracer_registry_type +module MOM_tracer_types + +implicit none ; private + +#include + +!> The tracer type +type, public :: tracer_type + + real, dimension(:,:,:), pointer :: t => NULL() !< tracer concentration array [CU ~> conc] +! real :: OBC_inflow_conc= 0.0 !< tracer concentration for generic inflows [CU ~> conc] +! real, dimension(:,:,:), pointer :: OBC_in_u => NULL() !< structured values for flow into the domain +! !! specified in OBCs through u-face of cell +! real, dimension(:,:,:), pointer :: OBC_in_v => NULL() !< structured values for flow into the domain +! !! specified in OBCs through v-face of cell + + real, dimension(:,:,:), pointer :: ad_x => NULL() !< diagnostic array for x-advective tracer flux + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:,:), pointer :: ad_y => NULL() !< diagnostic array for y-advective tracer flux + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:), pointer :: ad2d_x => NULL() !< diagnostic vertical sum x-advective tracer flux + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:), pointer :: ad2d_y => NULL() !< diagnostic vertical sum y-advective tracer flux + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + + real, dimension(:,:,:), pointer :: df_x => NULL() !< diagnostic array for x-diffusive tracer flux + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:,:), pointer :: df_y => NULL() !< diagnostic array for y-diffusive tracer flux + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:,:), pointer :: hbd_dfx => NULL() !< diagnostic array for x-diffusive tracer flux + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:,:), pointer :: hbd_dfy => NULL() !< diagnostic array for y-diffusive tracer flux + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:), pointer :: hbd_dfx_2d => NULL() !< diagnostic array for x-diffusive tracer flux + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:), pointer :: hbd_dfy_2d => NULL() !< diagnostic array for y-diffusive tracer flux + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:), pointer :: df2d_x => NULL() !< diagnostic vertical sum x-diffusive flux + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:), pointer :: df2d_y => NULL() !< diagnostic vertical sum y-diffusive flux + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] +! real, dimension(:,:), pointer :: df2d_conc_x => NULL() !< diagnostic vertical sum x-diffusive content flux +! !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] +! real, dimension(:,:), pointer :: df2d_conc_y => NULL() !< diagnostic vertical sum y-diffusive content flux +! !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + + real, dimension(:,:,:), pointer :: advection_xy => NULL() !< convergence of lateral advective tracer fluxes + !! [CU H T-1 ~> conc m s-1 or conc kg m-2 s-1] +! real, dimension(:,:,:), pointer :: diff_cont_xy => NULL() !< convergence of lateral diffusive tracer fluxes +! !! [CU H T-1 ~> conc m s-1 or conc kg m-2 s-1] +! real, dimension(:,:,:), pointer :: diff_conc_xy => NULL() !< convergence of lateral diffusive tracer fluxes +! !! expressed as a change in concentration +! !! [CU T-1 ~> conc s-1] + real, dimension(:,:,:), pointer :: t_prev => NULL() !< tracer concentration array at a previous + !! timestep used for diagnostics [CU ~> conc] + real, dimension(:,:,:), pointer :: Trxh_prev => NULL() !< layer integrated tracer concentration array + !! at a previous timestep used for diagnostics + !! [CU H ~> conc m or conc kg m-2] + + character(len=32) :: name !< tracer name used for diagnostics and error messages + character(len=64) :: units !< Physical dimensions of the tracer concentration + character(len=240) :: longname !< Long name of the variable +! type(vardesc), pointer :: vd => NULL() !< metadata describing the tracer + logical :: registry_diags = .false. !< If true, use the registry to set up the + !! diagnostics associated with this tracer. + real :: conc_underflow = 0.0 !< A magnitude of tracer concentrations below + !! which values should be set to 0. [CU ~> conc] + real :: conc_scale = 1.0 !< A scaling factor used to convert the concentrations + !! of this tracer to its desired units [CU conc-1 ~> 1] + character(len=64) :: cmor_name !< CMOR name of this tracer + character(len=64) :: cmor_units !< CMOR physical dimensions of the tracer + character(len=240) :: cmor_longname !< CMOR long name of the tracer + character(len=32) :: flux_nameroot = "" !< Short tracer name snippet used construct the + !! names of flux diagnostics. + character(len=64) :: flux_longname = "" !< A word or phrase used construct the long + !! names of flux diagnostics. + real :: flux_scale = 1.0 !< A scaling factor used to convert the fluxes + !! of this tracer to its desired units, + !! including a factor compensating for H scaling. + !! [conc m CU-1 H-1 ~> 1] or [conc kg m-2 CU-1 H-1 ~> 1] + character(len=48) :: flux_units = "" !< The units for fluxes of this variable. + character(len=48) :: conv_units = "" !< The units for the flux convergence of this tracer. + real :: conv_scale = 1.0 !< A scaling factor used to convert the flux + !! convergence of this tracer to its desired units, + !! including a factor compensating for H scaling. + !! [conc m CU-1 H-1 ~> 1] or [conc kg m-2 CU-1 H-1 ~> 1] + character(len=48) :: cmor_tendprefix = "" !< The CMOR variable prefix for tendencies of this + !! tracer, required because CMOR does not follow any + !! discernable pattern for these names. + character(len=48) :: net_surfflux_name = "" !< Name to use for net_surfflux KPP diagnostic + character(len=48) :: NLT_budget_name = "" !< Name to use for NLT_budget KPP diagnostic + character(len=128) :: net_surfflux_longname = "" !< Long name to use for net_surfflux KPP diagnostic + integer :: ind_tr_squared = -1 !< The tracer registry index for the square of this tracer + + !### THESE CAPABILITIES HAVE NOT YET BEEN IMPLEMENTED. + ! logical :: advect_tr = .true. !< If true, this tracer should be advected + ! logical :: hordiff_tr = .true. !< If true, this tracer should experience epineutral diffusion + ! logical :: kpp_nonlocal_tr = .true. !< if true, apply KPP nonlocal transport to this tracer before diffusion + logical :: remap_tr = .true. !< If true, this tracer should be vertically remapped + integer :: advect_scheme = -1 !< flag for advection scheme + + integer :: diag_form = 1 !< An integer indicating which template is to be used to label diagnostics. + !>@{ Diagnostic IDs + integer :: id_tr = -1, id_tr_post_horzn = -1 + integer :: id_adx = -1, id_ady = -1, id_dfx = -1, id_dfy = -1 + integer :: id_hbd_dfx = -1, id_hbd_dfy = -1 + integer :: id_hbd_dfx_2d = -1, id_hbd_dfy_2d = -1 + integer :: id_adx_2d = -1, id_ady_2d = -1, id_dfx_2d = -1, id_dfy_2d = -1 + integer :: id_adv_xy = -1, id_adv_xy_2d = -1 + integer :: id_dfxy_cont = -1, id_dfxy_cont_2d = -1, id_dfxy_conc = -1 + integer :: id_hbdxy_cont = -1, id_hbdxy_cont_2d = -1, id_hbdxy_conc = -1 + integer :: id_remap_conc = -1, id_remap_cont = -1, id_remap_cont_2d = -1 + integer :: id_tendency = -1, id_trxh_tendency = -1, id_trxh_tendency_2d = -1 + integer :: id_tr_vardec = -1 + integer :: id_zint = -1, id_zint_100m = -1, id_surf = -1 + integer :: id_net_surfflux = -1, id_NLT_tendency = -1, id_NLT_budget = -1 + !>@} +end type tracer_type + +!> Type to carry basic tracer information +type, public :: tracer_registry_type + integer :: ntr = 0 !< number of registered tracers + type(tracer_type) :: Tr(MAX_FIELDS_) !< array of registered tracers +! type(diag_ctrl), pointer :: diag !< structure to regulate timing of diagnostics + logical :: locked = .false. !< New tracers may be registered if locked=.false. + !! When locked=.true., no more tracers can be registered, + !! at which point common diagnostics can be set up + !! for the registered tracers +end type tracer_registry_type + + +end module MOM_tracer_types diff --git a/src/tracer/RGC_tracer.F90 b/src/tracer/RGC_tracer.F90 index 244eebb2bc..e0ab347ea5 100644 --- a/src/tracer/RGC_tracer.F90 +++ b/src/tracer/RGC_tracer.F90 @@ -1,3 +1,7 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> This module contains the routines used to set up a !! dynamically passive tracer. !! Set up and use passive tracers requires the following: @@ -11,8 +15,6 @@ module RGC_tracer -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_diag_mediator, only : diag_ctrl use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type @@ -47,13 +49,11 @@ module RGC_tracer character(len = 200) :: tracer_IC_file !< The full path to the IC file, or " " to initialize internally. type(time_type), pointer :: Time !< A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry. - real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package. - real, pointer :: tr_aux(:,:,:,:) => NULL() !< The masked tracer concentration. - real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out. - real :: lenlat !< the latitudinal or y-direction length of the domain. - real :: lenlon !< the longitudinal or x-direction length of the domain. - real :: CSL !< The length of the continental shelf (x dir, km) - real :: lensponge !< the length of the sponge layer. + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package [kg kg-1] + real, pointer :: tr_aux(:,:,:,:) => NULL() !< The masked tracer concentration [kg kg-1] + real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out [kg kg-1] + real :: CSL !< The length of the continental shelf (x direction) [km] + real :: lensponge !< the length of the sponge layer [km] logical :: mask_tracers !< If true, tracers are masked out in massless layers. logical :: use_sponge !< If true, sponges may be applied somewhere in the domain. type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the timing of diagnostic output. @@ -62,32 +62,30 @@ module RGC_tracer contains - !> This subroutine is used to register tracer fields -function register_RGC_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. +function register_RGC_tracer(G, GV, param_file, CS, tr_Reg, restart_CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(param_file_type), intent(in) :: param_file ! NULL() + real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to one of the tracers in this module [kg kg-1] logical :: register_RGC_tracer integer :: isd, ied, jsd, jed, nz, m - isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke if (associated(CS)) then - call MOM_error(WARNING, "RGC_register_tracer called with an "// & - "associated control structure.") - return + call MOM_error(FATAL, "RGC_register_tracer called with an "// & + "associated control structure.") endif allocate(CS) @@ -109,21 +107,13 @@ function register_RGC_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) "The exact location and properties of those sponges are \n"//& "specified from MOM_initialization.F90.", default=.false.) - call get_param(param_file, mdl, "LENLAT", CS%lenlat, & - "The latitudinal or y-direction length of the domain", & - fail_if_missing=.true., do_not_log=.true.) - - call get_param(param_file, mdl, "LENLON", CS%lenlon, & - "The longitudinal or x-direction length of the domain", & - fail_if_missing=.true., do_not_log=.true.) - call get_param(param_file, mdl, "CONT_SHELF_LENGTH", CS%CSL, & "The length of the continental shelf (x dir, km).", & - default=15.0) + units=G%x_ax_unit_short, default=15.0) call get_param(param_file, mdl, "LENSPONGE", CS%lensponge, & "The length of the sponge layer (km).", & - default=10.0) + units=G%x_ax_unit_short, default=10.0) allocate(CS%tr(isd:ied,jsd:jed,nz,NTR), source=0.0) if (CS%mask_tracers) then @@ -131,15 +121,14 @@ function register_RGC_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) endif do m=1,NTR - if (m < 10) then ; write(name,'("tr_RGC",I1.1)') m - else ; write(name,'("tr_RGC",I2.2)') m ; endif + write(name,'("tr_RGC",I0)') m write(longname,'("Concentration of RGC Tracer ",I2.2)') m CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) ! This is needed to force the compiler not to do a copy in the registration calls. tr_ptr => CS%tr(:,:,:,m) ! Register the tracer for horizontal advection & diffusion. - call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & + call register_tracer(tr_ptr, tr_Reg, param_file, G%HI, GV, & name=name, longname=longname, units="kg kg-1", & registry_diags=.true., flux_units="kg/s", & restart_CS=restart_CS) @@ -154,13 +143,13 @@ end function register_RGC_tracer subroutine initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS, & layer_CSp, sponge_CSp) - type(ocean_grid_type), intent(in) :: G !< Grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. logical, intent(in) :: restart !< .true. if the fields have already !! been read from a restart file. type(time_type), target, intent(in) :: day !< Time of the start of the run. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thickness, in m or kg m-2. + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] type(diag_ctrl), target, intent(in) :: diag !< Structure used to regulate diagnostic output. type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies !! whether, where, and what open boundary @@ -171,18 +160,9 @@ subroutine initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS, & type(ALE_sponge_CS), pointer :: sponge_CSp !< A pointer to the control structure for the !! sponges, if they are in use. Otherwise this may be unassociated. - real, allocatable :: temp(:,:,:) - real, pointer, dimension(:,:,:) :: & - OBC_tr1_u => NULL(), & ! These arrays should be allocated and set to - OBC_tr1_v => NULL() ! specify the values of tracer 1 that should come - ! in through u- and v- points through the open - ! boundary conditions, in the same units as tr. + real, allocatable :: temp(:,:,:) ! A temporary array used for several sponge target values [various] character(len=16) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for tracer fluxes, usually - ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. - real, pointer :: tr_ptr(:,:,:) => NULL() + real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to one of the tracers in this module [kg kg-1] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m @@ -234,14 +214,14 @@ subroutine initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS, & if (nzdata>0) then allocate(temp(G%isd:G%ied,G%jsd:G%jed,nzdata)) do k=1,nzdata ; do j=js,je ; do i=is,ie - if (G%geoLonT(i,j) >= (CS%lenlon - CS%lensponge) .AND. G%geoLonT(i,j) <= CS%lenlon) then + if (G%geoLonT(i,j) >= (G%len_lon - CS%lensponge) .AND. G%geoLonT(i,j) <= G%len_lon) then temp(i,j,k) = 0.0 endif enddo ; enddo ; enddo do m=1,1 ! This is needed to force the compiler not to do a copy in the sponge calls. tr_ptr => CS%tr(:,:,:,m) - call set_up_ALE_sponge_field(temp, G, GV, tr_ptr, sponge_CSp) + call set_up_ALE_sponge_field(temp, G, GV, tr_ptr, sponge_CSp, 'RGC_tracer') enddo deallocate(temp) endif @@ -250,7 +230,7 @@ subroutine initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS, & if (nz>0) then allocate(temp(G%isd:G%ied,G%jsd:G%jed,nz)) do k=1,nz ; do j=js,je ; do i=is,ie - if (G%geoLonT(i,j) >= (CS%lenlon - CS%lensponge) .AND. G%geoLonT(i,j) <= CS%lenlon) then + if (G%geoLonT(i,j) >= (G%len_lon - CS%lensponge) .AND. G%geoLonT(i,j) <= G%len_lon) then temp(i,j,k) = 0.0 endif enddo ; enddo ; enddo @@ -273,8 +253,8 @@ end subroutine initialize_RGC_tracer !! This is a simple example of a set of advected passive tracers. subroutine RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & evap_CFL_limit, minimum_forcing_depth) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & @@ -293,22 +273,20 @@ subroutine RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(RGC_tracer_CS), pointer :: CS !< The control structure returned by a previous call. real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can be - !! fluxed out of the top layer in a timestep [nondim]. + !! fluxed out of the top layer in a timestep [nondim]. real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which fluxes - !! can be applied [H ~> m or kg m-2]. + !! can be applied [H ~> m or kg m-2]. ! The arguments to this subroutine are redundant in that ! h_new[k] = h_old[k] + ea[k] - eb[k-1] + eb[k] - ea[k+1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] - real :: in_flux(SZI_(G),SZJ_(G),2) ! total amount of tracer to be injected integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not.associated(CS)) return - in_flux(:,:,:) = 0.0 m=1 do j=js,je ; do i=is,ie ! set tracer to 1.0 in the surface of the continental shelf @@ -319,11 +297,11 @@ subroutine RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then do m=1,NTR - do k=1,nz ;do j=js,je ; do i=is,ie + do k=1,nz ; do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth, in_flux(:,:,m)) + evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) enddo @@ -337,7 +315,6 @@ end subroutine RGC_tracer_column_physics subroutine RGC_tracer_end(CS) type(RGC_tracer_CS), pointer :: CS !< The control structure returned by a previous call to RGC_register_tracer. - integer :: m if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index 8fdb525b4a..7a20967777 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -1,25 +1,29 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> This tracer package is used to test advection schemes module advection_test_tracer -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux -use MOM_diag_mediator, only : diag_ctrl -use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : forcing -use MOM_grid, only : ocean_grid_type -use MOM_hor_index, only : hor_index_type -use MOM_io, only : slasher, vardesc, var_desc, query_vardesc -use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : query_initialized, MOM_restart_CS -use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type +use MOM_coms, only : EFP_type +use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_io, only : slasher, vardesc, var_desc, query_vardesc +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface -use MOM_verticalGrid, only : verticalGrid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -38,16 +42,16 @@ module advection_test_tracer character(len=200) :: tracer_IC_file !< The full path to the IC file, or " " to initialize internally. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the MOM tracer registry - real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, in g m-3? - real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out. + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine [conc] + real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out [conc] logical :: use_sponge !< If true, sponges may be applied somewhere in the domain. logical :: tracers_may_reinit !< If true, the tracers may be set up via the initialization code if !! they are not found in the restart files. Otherwise it is a fatal error !! if the tracers are not found in the restart files of a restarted run. - real :: x_origin !< Parameters describing the test functions - real :: x_width !< Parameters describing the test functions - real :: y_origin !< Parameters describing the test functions - real :: y_width !< Parameters describing the test functions + real :: x_origin !< Starting x-position of the tracer [m] or [km] or [degrees_E] + real :: x_width !< Initial size in the x-direction of the tracer patch [m] or [km] or [degrees_E] + real :: y_origin !< Starting y-position of the tracer [m] or [km] or [degrees_N] + real :: y_width !< Initial size in the y-direction of the tracer patch [m] or [km] or [degrees_N] integer, dimension(NTR) :: ind_tr !< Indices returned by atmos_ocn_coupler_flux if it is used and !! the surface tracer concentrations are to be provided to the coupler. @@ -62,8 +66,8 @@ module advection_test_tracer contains !> Register tracer fields and subroutines to be used with MOM. -function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI !< A horizontal index type structure +function register_advection_test_tracer(G, GV, param_file, CS, tr_Reg, restart_CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous @@ -75,21 +79,20 @@ function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_ ! Local variables character(len=80) :: name, longname -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "advection_test_tracer" ! This module's name. - character(len=200) :: inputdir + character(len=200) :: inputdir ! The directory where the input file can be found character(len=48) :: flux_units ! The units for tracer fluxes, usually ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. - real, pointer :: tr_ptr(:,:,:) => NULL() + real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to a tracer array [conc] logical :: register_advection_test_tracer integer :: isd, ied, jsd, jed, nz, m - isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke if (associated(CS)) then - call MOM_error(WARNING, "register_advection_test_tracer called with an "// & - "associated control structure.") - return + call MOM_error(FATAL, "register_advection_test_tracer called with an "// & + "associated control structure.") endif allocate(CS) @@ -97,13 +100,13 @@ function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_ call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ADVECTION_TEST_X_ORIGIN", CS%x_origin, & - "The x-coordinate of the center of the test-functions.", units="same as geoLon", default=0.) + "The x-coordinate of the center of the test-functions.", units=G%x_ax_unit_short, default=0.) call get_param(param_file, mdl, "ADVECTION_TEST_Y_ORIGIN", CS%y_origin, & - "The y-coordinate of the center of the test-functions.", units="same as geoLat", default=0.) + "The y-coordinate of the center of the test-functions.", units=G%y_ax_unit_short, default=0.) call get_param(param_file, mdl, "ADVECTION_TEST_X_WIDTH", CS%x_width, & - "The x-width of the test-functions.", units="same as geoLon", default=0.) + "The x-width of the test-functions.", units=G%x_ax_unit_short, default=0.) call get_param(param_file, mdl, "ADVECTION_TEST_Y_WIDTH", CS%y_width, & - "The y-width of the test-functions.", units="same as geoLat", default=0.) + "The y-width of the test-functions.", units=G%y_ax_unit_short, default=0.) call get_param(param_file, mdl, "ADVECTION_TEST_TRACER_IC_FILE", CS%tracer_IC_file, & "The name of a file from which to read the initial "//& "conditions for the tracers, or blank to initialize "//& @@ -130,8 +133,7 @@ function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_ allocate(CS%tr(isd:ied,jsd:jed,nz,NTR), source=0.0) do m=1,NTR - if (m < 10) then ; write(name,'("tr",I1.1)') m - else ; write(name,'("tr",I2.2)') m ; endif + write(name,'("tr",I0)') m write(longname,'("Concentration of Tracer ",I2.2)') m CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" @@ -142,7 +144,7 @@ function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_ ! calls. Curses on the designers and implementers of Fortran90. tr_ptr => CS%tr(:,:,:,m) ! Register the tracer for horizontal advection, diffusion, and restarts. - call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & + call register_tracer(tr_ptr, tr_Reg, param_file, G%HI, GV, & name=name, longname=longname, units="kg kg-1", & registry_diags=.true., flux_units=flux_units, & restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) @@ -180,23 +182,13 @@ subroutine initialize_advection_test_tracer(restart, day, G, GV, h,diag, OBC, CS type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. ! Local variables - real, allocatable :: temp(:,:,:) - real, pointer, dimension(:,:,:) :: & - OBC_tr1_u => NULL(), & ! These arrays should be allocated and set to - OBC_tr1_v => NULL() ! specify the values of tracer 1 that should come - ! in through u- and v- points through the open - ! boundary conditions, in the same units as tr. - character(len=16) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for tracer fluxes, usually - ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. - real, pointer :: tr_ptr(:,:,:) => NULL() + character(len=16) :: name ! A variable's name in a NetCDF file. + real :: locx, locy ! x- and y- positions relative to the center of the tracer patch + ! normalized by its size [nondim] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB - real :: tmpx, tmpy, locx, locy if (.not.associated(CS)) return is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -221,29 +213,31 @@ subroutine initialize_advection_test_tracer(restart, day, G, GV, h,diag, OBC, CS enddo ; enddo k=2 ! Triangle wave do j=js,je ; do i=is,ie - locx=abs(G%geoLonT(i,j)-CS%x_origin)/CS%x_width - locy=abs(G%geoLatT(i,j)-CS%y_origin)/CS%y_width + locx = abs(G%geoLonT(i,j)-CS%x_origin)/CS%x_width + locy = abs(G%geoLatT(i,j)-CS%y_origin)/CS%y_width CS%tr(i,j,k,m) = max(0.0, 1.0-locx)*max(0.0, 1.0-locy) enddo ; enddo k=3 ! Cosine bell do j=js,je ; do i=is,ie - locx=min(1.0, abs(G%geoLonT(i,j)-CS%x_origin)/CS%x_width)*(acos(0.0)*2.) - locy=min(1.0, abs(G%geoLatT(i,j)-CS%y_origin)/CS%y_width)*(acos(0.0)*2.) + locx = min(1.0, abs(G%geoLonT(i,j)-CS%x_origin)/CS%x_width) * (acos(0.0)*2.) + locy = min(1.0, abs(G%geoLatT(i,j)-CS%y_origin)/CS%y_width) * (acos(0.0)*2.) CS%tr(i,j,k,m) = (1.0+cos(locx))*(1.0+cos(locy))*0.25 enddo ; enddo k=4 ! Cylinder do j=js,je ; do i=is,ie - locx=abs(G%geoLonT(i,j)-CS%x_origin)/CS%x_width - locy=abs(G%geoLatT(i,j)-CS%y_origin)/CS%y_width - if (locx**2+locy**2<=1.0) CS%tr(i,j,k,m) = 1.0 + locx = abs(G%geoLonT(i,j)-CS%x_origin)/CS%x_width + locy = abs(G%geoLatT(i,j)-CS%y_origin)/CS%y_width + if ((locx**2) + (locy**2) <= 1.0) CS%tr(i,j,k,m) = 1.0 enddo ; enddo k=5 ! Cut cylinder do j=js,je ; do i=is,ie - locx=(G%geoLonT(i,j)-CS%x_origin)/CS%x_width - locy=(G%geoLatT(i,j)-CS%y_origin)/CS%y_width - if (locx**2+locy**2<=1.0) CS%tr(i,j,k,m) = 1.0 - if (locx>0.0.and.abs(locy)<0.2) CS%tr(i,j,k,m) = 0.0 + locx = (G%geoLonT(i,j)-CS%x_origin)/CS%x_width + locy = (G%geoLatT(i,j)-CS%y_origin)/CS%y_width + if ((locx**2) + (locy**2) <= 1.0) CS%tr(i,j,k,m) = 1.0 + if (locx>0.0 .and. abs(locy)<0.2) CS%tr(i,j,k,m) = 0.0 enddo ; enddo + + call set_initialized(CS%tr(:,:,:,m), name, CS%restart_CSp) endif ! restart enddo @@ -336,7 +330,7 @@ subroutine advection_test_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif @@ -344,13 +338,12 @@ end subroutine advection_test_tracer_surface_state !> Calculate the mass-weighted integral of all tracer stocks, returning the number of stocks it has calculated. !! If the stock_index is present, only the stock corresponding to that coded index is returned. -function advection_test_stock(h, stocks, G, GV, US, CS, names, units, stock_index) +function advection_test_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each + type(EFP_type), dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each !! tracer, in kg times concentration units [kg conc]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_advection_test_tracer. character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. @@ -359,8 +352,7 @@ function advection_test_stock(h, stocks, G, GV, US, CS, names, units, stock_inde integer :: advection_test_stock !< the number of stocks calculated here. ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] - integer :: i, j, k, is, ie, js, je, nz, m + integer :: is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke advection_test_stock = 0 @@ -374,14 +366,9 @@ function advection_test_stock(h, stocks, G, GV, US, CS, names, units, stock_inde return endif ; endif - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="advection_test_stock") - stocks(m) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) - enddo ; enddo ; enddo - stocks(m) = stock_scale * stocks(m) + stocks(m) = global_mass_int_EFP(h, G, GV, CS%tr(:,:,:,m), on_PE_only=.true.) enddo advection_test_stock = CS%ntr @@ -391,8 +378,6 @@ end function advection_test_stock subroutine advection_test_tracer_end(CS) type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_advection_test_tracer. - integer :: m - if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) deallocate(CS) diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index ea60a09608..6dd5127d94 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -1,26 +1,30 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Implements a boundary impulse response tracer to calculate Green's functions module boundary_impulse_tracer -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux -use MOM_diag_mediator, only : diag_ctrl -use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : forcing -use MOM_grid, only : ocean_grid_type -use MOM_hor_index, only : hor_index_type -use MOM_io, only : vardesc, var_desc, query_vardesc -use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS -use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type +use MOM_coms, only : EFP_type +use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_io, only : vardesc, var_desc, query_vardesc +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : register_restart_field, query_initialized, set_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut -use MOM_tracer_Z_init, only : tracer_Z_init -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface, thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type +use MOM_tracer_Z_init, only : tracer_Z_init +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -39,13 +43,13 @@ module boundary_impulse_tracer logical :: coupled_tracers = .false. !< These tracers are not offered to the coupler. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry - real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, in g m-3? + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, in [CU ~> conc] (g m-3)? logical :: tracers_may_reinit !< If true, boundary_impulse can be initialized if not found in restart file integer, dimension(NTR_MAX) :: ind_tr !< Indices returned by atmos_ocn_coupler_flux if it is used and the !! surface tracer concentrations are to be provided to the coupler. integer :: nkml !< Number of layers in mixed layer - real, dimension(NTR_MAX) :: land_val = -1.0 !< A value to use to fill in tracers over land + real, dimension(NTR_MAX) :: land_val = -1.0 !< A value to use to fill in tracers over land [CU ~> conc] real :: remaining_source_time !< How much longer (same units as the timestep) to !! inject the tracer at the surface [T ~> s] @@ -73,23 +77,20 @@ function register_boundary_impulse_tracer(HI, GV, US, param_file, CS, tr_Reg, re ! Local variables character(len=40) :: mdl = "boundary_impulse_tracer" ! This module's name. - character(len=200) :: inputdir ! The directory where the input files are. character(len=48) :: var_name ! The variable's name. - character(len=3) :: name_tag ! String for creating identifying boundary_impulse character(len=48) :: flux_units ! The units for tracer fluxes, usually ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. ! This include declares and sets the variable "version". # include "version_variable.h" - real, pointer :: tr_ptr(:,:,:) => NULL() - real, pointer :: rem_time_ptr => NULL() + real, pointer :: tr_ptr(:,:,:) => NULL() ! The tracer concentration [CU ~> conc] + real, pointer :: rem_time_ptr => NULL() ! The ramaining injection time [T ~> s] logical :: register_boundary_impulse_tracer - integer :: isd, ied, jsd, jed, nz, m, i, j + integer :: isd, ied, jsd, jed, nz, m isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke if (associated(CS)) then - call MOM_error(WARNING, "register_boundary_impulse_tracer called with an "// & - "associated control structure.") - return + call MOM_error(FATAL, "register_boundary_impulse_tracer called with an "// & + "associated control structure.") endif allocate(CS) @@ -99,7 +100,7 @@ function register_boundary_impulse_tracer(HI, GV, US, param_file, CS, tr_Reg, re "Length of time for the boundary tracer to be injected "//& "into the mixed layer. After this time has elapsed, the "//& "surface becomes a sink for the boundary impulse tracer.", & - default=31536000.0, scale=US%s_to_T) + units="s", default=31536000.0, scale=US%s_to_T) call get_param(param_file, mdl, "TRACERS_MAY_REINIT", CS%tracers_may_reinit, & "If true, tracers may go through the initialization code "//& "if they are not found in the restart files. Otherwise "//& @@ -136,7 +137,7 @@ function register_boundary_impulse_tracer(HI, GV, US, param_file, CS, tr_Reg, re rem_time_ptr => CS%remaining_source_time call register_restart_field(rem_time_ptr, "bir_remain_time", & .not.CS%tracers_may_reinit, restart_CS, & - "Remaining time to apply BIR source", "s") + "Remaining time to apply BIR source", "s", conversion=US%T_to_s) CS%tr_Reg => tr_Reg CS%restart_CSp => restart_CS @@ -167,11 +168,6 @@ subroutine initialize_boundary_impulse_tracer(restart, day, G, GV, US, h, diag, !! thermodynamic variables ! Local variables character(len=16) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for age tracer fluxes, either - ! years m3 s-1 or years kg s-1. - logical :: OK integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB @@ -191,13 +187,10 @@ subroutine initialize_boundary_impulse_tracer(restart, day, G, GV, US, h, diag, do k=1,CS%nkml ; do j=jsd,jed ; do i=isd,ied CS%tr(i,j,k,m) = 1.0 enddo ; enddo ; enddo + call set_initialized(CS%tr(:,:,:,m), name, CS%restart_CSp) endif enddo ! Tracer loop - if (restart .and. (US%s_to_T_restart /= 0.0) .and. (US%s_to_T /= US%s_to_T_restart) ) then - CS%remaining_source_time = (US%s_to_T / US%s_to_T_restart) * CS%remaining_source_time - endif - if (associated(OBC)) then ! Steal from updated DOME in the fullness of time. endif @@ -243,11 +236,8 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) ! Local variables - real :: Isecs_per_year = 1.0 / (365.0*86400.0) - real :: year, h_total, scale, htot, Ih_limit - integer :: secs, days - integer :: i, j, k, is, ie, js, je, nz, m, k_max - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified + integer :: i, j, k, is, ie, js, je, nz, m + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -268,7 +258,7 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, ! Set surface conditions do m=1,1 - if (CS%remaining_source_time>0.0) then + if (CS%remaining_source_time > 0.0) then do k=1,CS%nkml ; do j=js,je ; do i=is,ie CS%tr(i,j,k,m) = 1.0 enddo ; enddo ; enddo @@ -287,13 +277,12 @@ end subroutine boundary_impulse_tracer_column_physics !> This function calculates the mass-weighted integral of the boundary impulse, !! tracer stocks returning the number of stocks it has calculated. If the stock_index !! is present, only the stock corresponding to that coded index is returned. -function boundary_impulse_stock(h, stocks, G, GV, US, CS, names, units, stock_index) +function boundary_impulse_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in ) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in ) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in ) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(:), intent( out) :: stocks !< the mass-weighted integrated amount of each - !! tracer, in kg times concentration units [kg conc]. - type(unit_scale_type), intent(in ) :: US !< A dimensional unit scaling type + type(EFP_type), dimension(:), intent( out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_boundary_impulse_tracer. character(len=*), dimension(:), intent( out) :: names !< The names of the stocks calculated. @@ -302,14 +291,8 @@ function boundary_impulse_stock(h, stocks, G, GV, US, CS, names, units, stock_in !! being sought. integer :: boundary_impulse_stock !< Return value: the number of stocks calculated here. -! This function calculates the mass-weighted integral of all tracer stocks, -! returning the number of stocks it has calculated. If the stock_index -! is present, only the stock corresponding to that coded index is returned. - ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] - integer :: i, j, k, is, ie, js, je, nz, m - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + integer :: m boundary_impulse_stock = 0 if (.not.associated(CS)) return @@ -322,15 +305,10 @@ function boundary_impulse_stock(h, stocks, G, GV, US, CS, names, units, stock_in return endif ; endif - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 do m=1,1 call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="boundary_impulse_stock") units(m) = trim(units(m))//" kg" - stocks(m) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) - enddo ; enddo ; enddo - stocks(m) = stock_scale * stocks(m) + stocks(m) = global_mass_int_EFP(h, G, GV, CS%tr(:,:,:,m), on_PE_only=.true.) enddo boundary_impulse_stock = CS%ntr @@ -364,7 +342,7 @@ subroutine boundary_impulse_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif @@ -374,8 +352,6 @@ end subroutine boundary_impulse_tracer_surface_state subroutine boundary_impulse_tracer_end(CS) type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_boundary_impulse_tracer. - integer :: m - if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) deallocate(CS) diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index dca01e974a..7cbeebd38f 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -1,26 +1,32 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> A tracer package for using dyes to diagnose regional flows. module regional_dyes -! This file is part of MOM6. See LICENSE.md for the license. - +use MOM_coms, only : EFP_type use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux -use MOM_diag_mediator, only : diag_ctrl +use MOM_diag_mediator, only : diag_ctrl, post_data, register_diag_field use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type +use MOM_interface_heights, only : thickness_to_dz use MOM_io, only : vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface +use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type +use MOM_tracer_advect_schemes, only : set_tracer_advect_scheme, TracerAdvectionSchemeDoc implicit none ; private @@ -39,24 +45,30 @@ module regional_dyes type, public :: dye_tracer_CS ; private integer :: ntr !< The number of tracers that are actually used. logical :: coupled_tracers = .false. !< These tracers are not offered to the coupler. - real, allocatable, dimension(:) :: dye_source_minlon !< Minimum longitude of region dye will be injected. - real, allocatable, dimension(:) :: dye_source_maxlon !< Maximum longitude of region dye will be injected. - real, allocatable, dimension(:) :: dye_source_minlat !< Minimum latitude of region dye will be injected. - real, allocatable, dimension(:) :: dye_source_maxlat !< Maximum latitude of region dye will be injected. + real, allocatable, dimension(:) :: dye_source_minlon !< Minimum longitude of region dye will be + !! injected, in [m] or [km] or [degrees_E] + real, allocatable, dimension(:) :: dye_source_maxlon !< Maximum longitude of region dye will be + !! injected, in [m] or [km] or [degrees_E] + real, allocatable, dimension(:) :: dye_source_minlat !< Minimum latitude of region dye will be + !! injected, in [m] or [km] or [degrees_N] + real, allocatable, dimension(:) :: dye_source_maxlat !< Maximum latitude of region dye will be + !! injected, in [m] or [km] or [degrees_N] real, allocatable, dimension(:) :: dye_source_mindepth !< Minimum depth of region dye will be injected [Z ~> m]. real, allocatable, dimension(:) :: dye_source_maxdepth !< Maximum depth of region dye will be injected [Z ~> m]. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry - real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, in g m-3? + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine [CU ~> conc] integer, allocatable, dimension(:) :: ind_tr !< Indices returned by atmos_ocn_coupler_flux if it is used and the !! surface tracer concentrations are to be provided to the coupler. + integer, allocatable, dimension(:) :: id_tr_dia_diff !< Diagnostic IDs for vertical tracer fluxes (positive up) + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control structure type(vardesc), allocatable :: tr_desc(:) !< Descriptions and metadata for the tracers - logical :: tracers_may_reinit = .false. !< If true the tracers may be initialized if not found in a restart file + logical :: tracers_may_reinit = .true. !< If true the tracers may be initialized if not found in a restart file end type dye_tracer_CS contains @@ -72,24 +84,26 @@ function register_dye_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) !! structure for this module type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control !! structure for the tracer advection and diffusion module. - type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control struct + type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control structure -! Local variables -! This include declares and sets the variable "version". -#include "version_variable.h" + ! Local variables character(len=40) :: mdl = "regional_dyes" ! This module's name. - character(len=200) :: inputdir ! The directory where the input files are. character(len=48) :: var_name ! The variable's name. character(len=48) :: desc_name ! The variable's descriptor. - real, pointer :: tr_ptr(:,:,:) => NULL() + character(len=48) :: param_name ! The param's name suffix. + ! This include declares and sets the variable "version". +# include "version_variable.h" + real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to one of the tracers [CU ~> conc] logical :: register_dye_tracer integer :: isd, ied, jsd, jed, nz, m + integer :: advect_scheme ! Advection scheme value for this tracer + character(len=256) :: mesg ! Advection scheme name for this tracer + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke if (associated(CS)) then - call MOM_error(WARNING, "register_dye_tracer called with an "// & - "associated control structure.") - return + call MOM_error(FATAL, "register_dye_tracer called with an "// & + "associated control structure.") endif allocate(CS) @@ -106,32 +120,38 @@ function register_dye_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) CS%dye_source_maxdepth(CS%ntr)) allocate(CS%ind_tr(CS%ntr)) allocate(CS%tr_desc(CS%ntr)) + allocate(CS%id_tr_dia_diff(CS%ntr)) + CS%id_tr_dia_diff(:) = -1 CS%dye_source_minlon(:) = -1.e30 call get_param(param_file, mdl, "DYE_SOURCE_MINLON", CS%dye_source_minlon, & "This is the starting longitude at which we start injecting dyes.", & - fail_if_missing=.true.) + units="degrees_E", fail_if_missing=.true.) + ! units=G%x_ax_unit_short, fail_if_missing=.true.) if (minval(CS%dye_source_minlon(:)) < -1.e29) & call MOM_error(FATAL, "register_dye_tracer: Not enough values provided for DYE_SOURCE_MINLON ") CS%dye_source_maxlon(:) = -1.e30 call get_param(param_file, mdl, "DYE_SOURCE_MAXLON", CS%dye_source_maxlon, & "This is the ending longitude at which we finish injecting dyes.", & - fail_if_missing=.true.) + units="degrees_E", fail_if_missing=.true.) + ! units=G%x_ax_unit_short, fail_if_missing=.true.) if (minval(CS%dye_source_maxlon(:)) < -1.e29) & call MOM_error(FATAL, "register_dye_tracer: Not enough values provided for DYE_SOURCE_MAXLON ") CS%dye_source_minlat(:) = -1.e30 call get_param(param_file, mdl, "DYE_SOURCE_MINLAT", CS%dye_source_minlat, & "This is the starting latitude at which we start injecting dyes.", & - fail_if_missing=.true.) + units="degrees_N", fail_if_missing=.true.) + ! units=G%y_ax_unit_short, fail_if_missing=.true.) if (minval(CS%dye_source_minlat(:)) < -1.e29) & call MOM_error(FATAL, "register_dye_tracer: Not enough values provided for DYE_SOURCE_MINLAT ") CS%dye_source_maxlat(:) = -1.e30 call get_param(param_file, mdl, "DYE_SOURCE_MAXLAT", CS%dye_source_maxlat, & "This is the ending latitude at which we finish injecting dyes.", & - fail_if_missing=.true.) + units="degrees_N", fail_if_missing=.true.) + ! units=G%y_ax_unit_short, fail_if_missing=.true.) if (minval(CS%dye_source_maxlat(:)) < -1.e29) & call MOM_error(FATAL, "register_dye_tracer: Not enough values provided for DYE_SOURCE_MAXLAT ") @@ -147,11 +167,19 @@ function register_dye_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) "This is the maximum depth at which we inject dyes.", & units="m", scale=US%m_to_Z, fail_if_missing=.true.) if (minval(CS%dye_source_maxdepth(:)) < -1.e29*US%m_to_Z) & - call MOM_error(FATAL, "register_dye_tracer: Not enough values provided for DYE_SOURCE_MAXDEPTH ") + call MOM_error(FATAL, "register_dye_tracer: Not enough values provided for DYE_SOURCE_MAXDEPTH") allocate(CS%tr(isd:ied,jsd:jed,nz,CS%ntr), source=0.0) do m = 1, CS%ntr + write(param_name(:),'(A,I3.3,A)') "DYE",m,"_TRACER_ADVECTION_SCHEME" + call get_param(param_file, mdl, trim(param_name), mesg, & + desc="The horizontal transport scheme for dye tracer:\n"//& + trim(TracerAdvectionSchemeDoc)//& + "\n Set to blank (the default) to use TRACER_ADVECTION_SCHEME.", default="") + ! Get the integer value of the tracer scheme + call set_tracer_advect_scheme(advect_scheme, mesg) + write(var_name(:),'(A,I3.3)') "dye",m write(desc_name(:),'(A,I3.3)') "Dye Tracer ",m CS%tr_desc(m) = var_desc(trim(var_name), "conc", trim(desc_name), caller=mdl) @@ -164,7 +192,8 @@ function register_dye_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) ! Register the tracer for horizontal advection, diffusion, and restarts. call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & tr_desc=CS%tr_desc(m), registry_diags=.true., & - restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) + restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit,& + advect_scheme=advect_scheme) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will @@ -181,12 +210,13 @@ end function register_dye_tracer !> This subroutine initializes the CS%ntr tracer fields in tr(:,:,:,:) !! and it sets up the tracer output. -subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_CSp) +subroutine initialize_dye_tracer(restart, day, G, GV, US, h, diag, OBC, CS, sponge_CSp, tv) logical, intent(in) :: restart !< .true. if the fields have already been !! read from a restart file. type(time_type), target, intent(in) :: day !< Time of the start of the run. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(diag_ctrl), target, intent(in) :: diag !< Structure used to regulate diagnostic output. type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies @@ -194,18 +224,15 @@ subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_C !! conditions are used. type(dye_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_dye_tracer. - type(sponge_CS), pointer :: sponge_CSp !< A pointer to the control structure - !! for the sponges, if they are in use. - -! Local variables - character(len=24) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for age tracer fluxes, either - ! years m3 s-1 or years kg s-1. + type(sponge_CS), pointer :: sponge_CSp !< A pointer to the control structure + !! for the sponges, if they are in use. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + + ! Local variables + character(len=64) :: var_name, longname + real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] real :: z_bot ! Height of the bottom of the layer relative to the sea surface [Z ~> m] real :: z_center ! Height of the center of the layer relative to the sea surface [Z ~> m] - logical :: OK integer :: i, j, k, m if (.not.associated(CS)) return @@ -213,19 +240,28 @@ subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_C CS%diag => diag + ! Register vertical flux diagnostic + do m = 1, CS%ntr + write(var_name,'(A,I3.3,A)') "dye",m,"_dia_diff" + write(longname,'(A,I3.3,A)') "Vertical diffusive flux of dye ",m," (positive up)" + CS%id_tr_dia_diff(m) = register_diag_field('ocean_model', trim(var_name), & + diag%axesTi, day, trim(longname), 'conc H s-1', conversion=GV%H_to_MKS*US%s_to_T) + enddo + ! Establish location of source - do m= 1, CS%ntr - do j=G%jsd,G%jed ; do i=G%isd,G%ied + do j=G%jsc,G%jec + call thickness_to_dz(h, tv, dz, j, G, GV) + do m=1,CS%ntr ; do i=G%isc,G%iec ! A dye is set dependent on the center of the cell being inside the rectangular box. - if (CS%dye_source_minlon(m)=G%geoLonT(i,j) .and. & - CS%dye_source_minlat(m)=G%geoLatT(i,j) .and. & + if (CS%dye_source_minlon(m) < G%geoLonT(i,j) .and. & + CS%dye_source_maxlon(m) >= G%geoLonT(i,j) .and. & + CS%dye_source_minlat(m) < G%geoLatT(i,j) .and. & + CS%dye_source_maxlat(m) >= G%geoLatT(i,j) .and. & G%mask2dT(i,j) > 0.0 ) then z_bot = 0.0 do k = 1, GV%ke - z_bot = z_bot - h(i,j,k)*GV%H_to_Z - z_center = z_bot + 0.5*h(i,j,k)*GV%H_to_Z + z_bot = z_bot - dz(i,k) + z_center = z_bot + 0.5*dz(i,k) if ( z_center > -CS%dye_source_maxdepth(m) .and. & z_center < -CS%dye_source_mindepth(m) ) then CS%tr(i,j,k,m) = 1.0 @@ -242,7 +278,7 @@ end subroutine initialize_dye_tracer !! This is a simple example of a set of advected passive tracers. !! The arguments to this subroutine are redundant in that !! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) -subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & +subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, tv, CS, & evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -262,6 +298,7 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US !! and tracer forcing fields. Unused fields have NULL ptrs. real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables type(dye_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_dye_tracer. real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can @@ -269,14 +306,14 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which !! fluxes can be applied [H ~> m or kg m-2] -! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified - real :: sfc_val ! The surface value for the tracers. - real :: Isecs_per_year ! The number of seconds in a year. - real :: year ! The time in years. + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: vert_flux ! Vertical tracer flux positive upward + !! [conc H T-1 ~> conc m s-1] + real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] real :: z_bot ! Height of the bottom of the layer relative to the sea surface [Z ~> m] real :: z_center ! Height of the center of the layer relative to the sea surface [Z ~> m] - integer :: secs, days ! Integer components of the time type. + real :: Idt ! Inverse of timestep [T-1 ~> s-1] integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -284,33 +321,60 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US if (.not.associated(CS)) return if (CS%ntr < 1) return + Idt = 1.0 / dt + if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then do m=1,CS%ntr - do k=1,nz ;do j=js,je ; do i=is,ie + do k=1,nz ; do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m), dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) + + ! Calculate net vertical flux from entrainment + ! Net flux = upward component - downward component + ! Upward (from below): eb(k) * tr(k+1), Downward (from above): ea(k+1) * tr(k) + do K=2,nz ; do j=js,je ; do i=is,ie + vert_flux(i,j,K) = (eb(i,j,k-1) * CS%tr(i,j,k,m) - ea(i,j,k) * CS%tr(i,j,k-1,m)) * Idt + enddo ; enddo ; enddo + do j=js,je ; do i=is,ie ; vert_flux(i,j,1) = 0.0 ; vert_flux(i,j,nz+1) = 0.0 ; enddo ; enddo + + ! Post diagnostic + if (CS%id_tr_dia_diff(m) > 0) & + call post_data(CS%id_tr_dia_diff(m), vert_flux, CS%diag) enddo else do m=1,CS%ntr call tracer_vertdiff(h_old, ea, eb, dt, CS%tr(:,:,:,m), G, GV) + + ! Calculate net vertical flux from entrainment + ! Net flux = upward component - downward component + ! Upward (from below): eb(k) * tr(k+1), Downward (from above): ea(k+1) * tr(k) + do K=2,nz ; do j=js,je ; do i=is,ie + vert_flux(i,j,K) = (eb(i,j,k-1) * CS%tr(i,j,k,m) - ea(i,j,k) * CS%tr(i,j,k-1,m)) * Idt + enddo ; enddo ; enddo + do j=js,je ; do i=is,ie ; vert_flux(i,j,1) = 0.0 ; vert_flux(i,j,nz+1) = 0.0 ; enddo ; enddo + + ! Post diagnostic + if (CS%id_tr_dia_diff(m) > 0) & + call post_data(CS%id_tr_dia_diff(m), vert_flux, CS%diag) enddo endif - do m=1,CS%ntr - do j=G%jsd,G%jed ; do i=G%isd,G%ied + do j=js,je + call thickness_to_dz(h_new, tv, dz, j, G, GV) + do m=1,CS%ntr ; do i=is,ie ! A dye is set dependent on the center of the cell being inside the rectangular box. - if (CS%dye_source_minlon(m)=G%geoLonT(i,j) .and. & - CS%dye_source_minlat(m)=G%geoLatT(i,j) .and. & + if (CS%dye_source_minlon(m) < G%geoLonT(i,j) .and. & + CS%dye_source_maxlon(m) >= G%geoLonT(i,j) .and. & + CS%dye_source_minlat(m) < G%geoLatT(i,j) .and. & + CS%dye_source_maxlat(m) >= G%geoLatT(i,j) .and. & G%mask2dT(i,j) > 0.0 ) then z_bot = 0.0 do k=1,nz - z_bot = z_bot - h_new(i,j,k)*GV%H_to_Z - z_center = z_bot + 0.5*h_new(i,j,k)*GV%H_to_Z + z_bot = z_bot - dz(i,k) + z_center = z_bot + 0.5*dz(i,k) if ( z_center > -CS%dye_source_maxdepth(m) .and. & z_center < -CS%dye_source_mindepth(m) ) then CS%tr(i,j,k,m) = 1.0 @@ -325,13 +389,12 @@ end subroutine dye_tracer_column_physics !> This function calculates the mass-weighted integral of all tracer stocks, !! returning the number of stocks it has calculated. If the stock_index !! is present, only the stock corresponding to that coded index is returned. -function dye_stock(h, stocks, G, GV, US, CS, names, units, stock_index) +function dye_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of - !! each tracer, in kg times concentration units [kg conc]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] type(dye_tracer_CS), pointer :: CS !< The control structure returned by a !! previous call to register_dye_tracer. character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. @@ -342,9 +405,7 @@ function dye_stock(h, stocks, G, GV, US, CS, names, units, stock_index) !! calculated here. ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] - integer :: i, j, k, is, ie, js, je, nz, m - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + integer :: m dye_stock = 0 if (.not.associated(CS)) return @@ -357,15 +418,10 @@ function dye_stock(h, stocks, G, GV, US, CS, names, units, stock_index) return endif ; endif - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="dye_stock") units(m) = trim(units(m))//" kg" - stocks(m) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) - enddo ; enddo ; enddo - stocks(m) = stock_scale * stocks(m) + stocks(m) = global_mass_int_EFP(h, G, GV, CS%tr(:,:,:,m), on_PE_only=.true.) enddo dye_stock = CS%ntr @@ -398,7 +454,7 @@ subroutine dye_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif @@ -408,7 +464,6 @@ end subroutine dye_tracer_surface_state subroutine regional_dyes_end(CS) type(dye_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_dye_tracer. - integer :: m if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) @@ -424,5 +479,8 @@ end subroutine regional_dyes_end !! are set to 1 within the geographical region specified. The depth !! which a tracer is set is determined by calculating the depth from !! the seafloor upwards through the column. +!! +!! The advection scheme of these tracers can be set to be different +!! to that used by active tracers. end module regional_dyes diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90 index b6bd212a37..881d18eac0 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> This tracer package dyes flow through open boundaries module dyed_obc_tracer -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_coupler_types, only : atmos_ocn_coupler_flux use MOM_diag_mediator, only : diag_ctrl use MOM_error_handler, only : MOM_error, FATAL, WARNING @@ -13,12 +15,16 @@ module dyed_obc_tracer use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : MOM_restart_CS +use MOM_restart, only : query_initialized, set_initialized use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type +use MOM_tracer_registry, only : tracer_type +use MOM_tracer_registry, only : tracer_name_lookup +use MOM_tracer_advect_schemes, only : set_tracer_advect_scheme, TracerAdvectionSchemeDoc implicit none ; private @@ -34,7 +40,10 @@ module dyed_obc_tracer character(len=200) :: tracer_IC_file !< The full path to the IC file, or " " to initialize internally. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry - real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, in g m-3? + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine in [conc] + + logical :: tracers_may_reinit !< If true, these tracers be set up via the initialization code if + !! they are not found in the restart files. integer, allocatable, dimension(:) :: ind_tr !< Indices returned by atmos_ocn_coupler_flux if it is used and the !! surface tracer concentrations are to be provided to the coupler. @@ -58,31 +67,46 @@ function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) type(tracer_registry_type), pointer :: tr_Reg !< A pointer to the tracer registry. type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control struct -! Local variables + ! Local variables character(len=80) :: name, longname -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "dyed_obc_tracer" ! This module's name. character(len=200) :: inputdir character(len=48) :: flux_units ! The units for tracer fluxes, usually ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. - real, pointer :: tr_ptr(:,:,:) => NULL() + real, pointer :: tr_ptr(:,:,:) => NULL() ! The tracer concentration [conc] logical :: register_dyed_obc_tracer integer :: isd, ied, jsd, jed, nz, m + integer :: n_dye ! Number of regionsl dye tracers + integer :: advect_scheme ! Advection scheme value for this tracer + character(len=256) :: mesg ! Advection scheme name for this tracer + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke if (associated(CS)) then - call MOM_error(WARNING, "dyed_obc_register_tracer called with an "// & - "associated control structure.") - return + call MOM_error(FATAL, "dyed_obc_register_tracer called with an "// & + "associated control structure.") endif allocate(CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "NUM_DYE_TRACERS", CS%ntr, & - "The number of dye tracers in this run. Each tracer "//& - "should have a separate boundary segment.", default=0) + call get_param(param_file, mdl, "NUM_DYED_TRACERS", CS%ntr, & + "The number of dyed_obc tracers in this run. Each tracer "//& + "should have a separate boundary segment. "//& + "If not present, use NUM_DYE_TRACERS.", default=-1) + if (CS%ntr == -1) then + !for backward compatibility + call get_param(param_file, mdl, "NUM_DYE_TRACERS", CS%ntr, & + "The number of dye tracers in this run. Each tracer "//& + "should have a separate boundary segment.", default=0) + n_dye = 0 + else + call get_param(param_file, mdl, "NUM_DYE_TRACERS", n_dye, & + "The number of dye tracers in this run. Each tracer "//& + "should have a separate region.", default=0, do_not_log=.true.) + endif allocate(CS%ind_tr(CS%ntr)) allocate(CS%tr_desc(CS%ntr)) @@ -98,10 +122,21 @@ function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) CS%tracer_IC_file) endif + call get_param(param_file, mdl, "TRACERS_MAY_REINIT", CS%tracers_may_reinit, & + "If true, tracers may go through the initialization code "//& + "if they are not found in the restart files. Otherwise "//& + "it is a fatal error if the tracers are not found in the "//& + "restart files of a restarted run.", default=.false.) + + call get_param(param_file, mdl, "DYED_TRACER_ADVECTION_SCHEME", mesg, & + desc="The horizontal transport scheme for dyed_obc tracers:\n"//& + trim(TracerAdvectionSchemeDoc)//& + "\n Set to blank (the default) to use TRACER_ADVECTION_SCHEME.", default="") + allocate(CS%tr(isd:ied,jsd:jed,nz,CS%ntr), source=0.0) do m=1,CS%ntr - write(name,'("dye_",I2.2)') m + write(name,'("dye_",I2.2)') m+n_dye !after regional dye tracers write(longname,'("Concentration of dyed_obc Tracer ",I2.2)') m CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" @@ -110,11 +145,14 @@ function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! This is needed to force the compiler not to do a copy in the registration ! calls. Curses on the designers and implementers of Fortran90. tr_ptr => CS%tr(:,:,:,m) + ! Get the integer value of the tracer scheme + call set_tracer_advect_scheme(advect_scheme, mesg) ! Register the tracer for horizontal advection, diffusion, and restarts. call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & name=name, longname=longname, units="kg kg-1", & registry_diags=.true., flux_units=flux_units, & - restart_CS=restart_CS) + restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit, & + advect_scheme=advect_scheme) ! Set coupled_tracers to be true (hard-coded above) to provide the surface ! values to the coupler (if any). This is meta-code and its arguments will @@ -143,18 +181,7 @@ subroutine initialize_dyed_obc_tracer(restart, day, G, GV, h, diag, OBC, CS) !! call to dyed_obc_register_tracer. ! Local variables - real, allocatable :: temp(:,:,:) - real, pointer, dimension(:,:,:) :: & - OBC_tr1_u => NULL(), & ! These arrays should be allocated and set to - OBC_tr1_v => NULL() ! specify the values of tracer 1 that should come - ! in through u- and v- points through the open - ! boundary conditions, in the same units as tr. character(len=24) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for tracer fluxes, usually - ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. - real, pointer :: tr_ptr(:,:,:) => NULL() real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m @@ -170,24 +197,24 @@ subroutine initialize_dyed_obc_tracer(restart, day, G, GV, h, diag, OBC, CS) CS%Time => day CS%diag => diag - if (.not.restart) then - if (len_trim(CS%tracer_IC_file) >= 1) then - ! Read the tracer concentrations from a netcdf file. - if (.not.file_exists(CS%tracer_IC_file, G%Domain)) & - call MOM_error(FATAL, "dyed_obc_initialize_tracer: Unable to open "// & - CS%tracer_IC_file) - do m=1,CS%ntr + do m=1,CS%ntr + if ((.not.restart) .or. (CS%tracers_may_reinit .and. .not. & + query_initialized(CS%tr(:,:,:,m), name, CS%restart_CSp))) then + if (len_trim(CS%tracer_IC_file) >= 1) then + ! Read the tracer concentrations from a netcdf file. + if (.not.file_exists(CS%tracer_IC_file, G%Domain)) & + call MOM_error(FATAL, "dyed_obc_initialize_tracer: Unable to open "// & + CS%tracer_IC_file) call query_vardesc(CS%tr_desc(m), name, caller="initialize_dyed_obc_tracer") call MOM_read_data(CS%tracer_IC_file, trim(name), CS%tr(:,:,:,m), G%Domain) - enddo - else - do m=1,CS%ntr + else do k=1,nz ; do j=js,je ; do i=is,ie CS%tr(i,j,k,m) = 0.0 enddo ; enddo ; enddo - enddo - endif - endif ! restart + endif + call set_initialized(CS%tr(:,:,:,m), name, CS%restart_CSp) + endif ! restart + enddo ! Tracer loop end subroutine initialize_dyed_obc_tracer @@ -225,7 +252,7 @@ subroutine dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, !! fluxes can be applied [H ~> m or kg m-2] ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -253,7 +280,6 @@ end subroutine dyed_obc_tracer_column_physics subroutine dyed_obc_tracer_end(CS) type(dyed_obc_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to dyed_obc_register_tracer. - integer :: m if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) @@ -277,5 +303,9 @@ end subroutine dyed_obc_tracer_end !! their output and the subroutine that does any tracer physics or !! chemistry along with diapycnal mixing (included here because some !! tracers may float or swim vertically or dye diapycnal processes). +!! +!! The advection scheme of these tracers can be set to be different +!! to that used by active tracers. + end module dyed_obc_tracer diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index d5c813b3d0..1543a93094 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -1,20 +1,24 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> A tracer package of ideal age tracers module ideal_age_example -! This file is part of MOM6. See LICENSE.md for the license. - +use MOM_coms, only : EFP_type use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux use MOM_diag_mediator, only : diag_ctrl -use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : query_initialized, MOM_restart_CS +use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type, time_type_to_real +use MOM_time_manager, only : time_type, time_to_real use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init @@ -29,27 +33,31 @@ module ideal_age_example public register_ideal_age_tracer, initialize_ideal_age_tracer public ideal_age_tracer_column_physics, ideal_age_tracer_surface_state public ideal_age_stock, ideal_age_example_end +public count_BL_layers -integer, parameter :: NTR_MAX = 3 !< the maximum number of tracers in this module. +integer, parameter :: NTR_MAX = 4 !< the maximum number of tracers in this module. !> The control structure for the ideal_age_tracer package type, public :: ideal_age_tracer_CS ; private integer :: ntr !< The number of tracers that are actually used. logical :: coupled_tracers = .false. !< These tracers are not offered to the coupler. - integer :: nkml !< The number of layers in the mixed layer. The ideal - !1 age tracers are reset in the top nkml layers. + integer :: nkbl !< The number of layers in the boundary layer. The ideal + !1 age tracers are reset in the top nkbl layers. character(len=200) :: IC_file !< The file in which the age-tracer initial values !! can be found, or an empty string for internal initialization. logical :: Z_IC_file !< If true, the IC_file is in Z-space. The default is false. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry - real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package, in g m-3? - real, dimension(NTR_MAX) :: IC_val = 0.0 !< The (uniform) initial condition value. - real, dimension(NTR_MAX) :: young_val = 0.0 !< The value assigned to tr at the surface. - real, dimension(NTR_MAX) :: land_val = -1.0 !< The value of tr used where land is masked out. - real, dimension(NTR_MAX) :: sfc_growth_rate !< The exponential growth rate for the surface value [year-1]. + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package [years] or other units + real, dimension(NTR_MAX) :: IC_val = 0.0 !< The (uniform) initial condition value [years] or other units + real, dimension(NTR_MAX) :: young_val = 0.0 !< The value assigned to tr at the surface [years] or other units + real, dimension(NTR_MAX) :: land_val = -1.0 !< The value of tr used where land is masked out [years] or other units + real, dimension(NTR_MAX) :: growth_rate !< The exponential growth rate for the young value [year-1] real, dimension(NTR_MAX) :: tracer_start_year !< The year in which tracers start aging, or at which the - !! surface value equals young_val, in years. + !! surface value equals young_val [years]. + logical :: use_real_BL_depth !< If true, uses the BL scheme to determine the number of + !! layers above the BL depth instead of the fixed nkbl value. + integer :: BL_residence_num !< The tracer number assigned to the BL residence tracer in this module logical :: tracers_may_reinit !< If true, these tracers be set up via the initialization code if !! they are not found in the restart files. logical :: tracer_ages(NTR_MAX) !< Indicates whether each tracer ages. @@ -62,6 +70,7 @@ module ideal_age_example type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart controls structure type(vardesc) :: tr_desc(NTR_MAX) !< Descriptions and metadata for the tracers + end type ideal_age_tracer_CS contains @@ -78,21 +87,20 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) !! diffusion module type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control struct -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "ideal_age_example" ! This module's name. character(len=200) :: inputdir ! The directory where the input files are. character(len=48) :: var_name ! The variable's name. - real, pointer :: tr_ptr(:,:,:) => NULL() + real, pointer :: tr_ptr(:,:,:) => NULL() ! The tracer concentration [years] logical :: register_ideal_age_tracer - logical :: do_ideal_age, do_vintage, do_ideal_age_dated + logical :: do_ideal_age, do_vintage, do_ideal_age_dated, do_BL_residence integer :: isd, ied, jsd, jed, nz, m isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke if (associated(CS)) then - call MOM_error(WARNING, "register_ideal_age_tracer called with an "// & - "associated control structure.") - return + call MOM_error(FATAL, "register_ideal_age_tracer called with an "// & + "associated control structure.") endif allocate(CS) @@ -100,20 +108,26 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "DO_IDEAL_AGE", do_ideal_age, & "If true, use an ideal age tracer that is set to 0 age "//& - "in the mixed layer and ages at unit rate in the interior.", & + "in the boundary layer and ages at unit rate in the interior.", & default=.true.) call get_param(param_file, mdl, "DO_IDEAL_VINTAGE", do_vintage, & "If true, use an ideal vintage tracer that is set to an "//& - "exponentially increasing value in the mixed layer and "//& + "exponentially increasing value in the boundary layer and "//& "is conserved thereafter.", default=.false.) call get_param(param_file, mdl, "DO_IDEAL_AGE_DATED", do_ideal_age_dated, & "If true, use an ideal age tracer that is everywhere 0 "//& "before IDEAL_AGE_DATED_START_YEAR, but the behaves like "//& "the standard ideal age tracer - i.e. is set to 0 age in "//& - "the mixed layer and ages at unit rate in the interior.", & + "the boundary layer and ages at unit rate in the interior.", & + default=.false.) + call get_param(param_file, mdl, "DO_BL_RESIDENCE", do_BL_residence, & + "If true, use a residence tracer that is set to 0 age "//& + "in the interior and ages at unit rate in the boundary layer.", & + default=.false.) + call get_param(param_file, mdl, "USE_REAL_BL_DEPTH", CS%use_real_BL_depth, & + "If true, the ideal age tracers will use the boundary layer "//& + "depth diagnosed from the BL or bulkmixedlayer scheme.", & default=.false.) - - call get_param(param_file, mdl, "AGE_IC_FILE", CS%IC_file, & "The file in which the age-tracer initial values can be "//& "found, or an empty string for internal initialization.", & @@ -137,7 +151,7 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) if (do_ideal_age) then CS%ntr = CS%ntr + 1 ; m = CS%ntr CS%tr_desc(m) = var_desc("age", "yr", "Ideal Age Tracer", cmor_field_name="agessc", caller=mdl) - CS%tracer_ages(m) = .true. ; CS%sfc_growth_rate(m) = 0.0 + CS%tracer_ages(m) = .true. ; CS%growth_rate(m) = 0.0 CS%IC_val(m) = 0.0 ; CS%young_val(m) = 0.0 ; CS%tracer_start_year(m) = 0.0 endif @@ -145,7 +159,7 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) CS%ntr = CS%ntr + 1 ; m = CS%ntr CS%tr_desc(m) = var_desc("vintage", "yr", "Exponential Vintage Tracer", & caller=mdl) - CS%tracer_ages(m) = .false. ; CS%sfc_growth_rate(m) = 1.0/30.0 + CS%tracer_ages(m) = .false. ; CS%growth_rate(m) = 1.0/30.0 CS%IC_val(m) = 0.0 ; CS%young_val(m) = 1e-20 ; CS%tracer_start_year(m) = 0.0 call get_param(param_file, mdl, "IDEAL_VINTAGE_START_YEAR", CS%tracer_start_year(m), & "The date at which the ideal vintage tracer starts.", & @@ -156,13 +170,21 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) CS%ntr = CS%ntr + 1 ; m = CS%ntr CS%tr_desc(m) = var_desc("age_dated","yr","Ideal Age Tracer with a Start Date",& caller=mdl) - CS%tracer_ages(m) = .true. ; CS%sfc_growth_rate(m) = 0.0 + CS%tracer_ages(m) = .true. ; CS%growth_rate(m) = 0.0 CS%IC_val(m) = 0.0 ; CS%young_val(m) = 0.0 ; CS%tracer_start_year(m) = 0.0 call get_param(param_file, mdl, "IDEAL_AGE_DATED_START_YEAR", CS%tracer_start_year(m), & "The date at which the dated ideal age tracer starts.", & units="years", default=0.0) endif + CS%BL_residence_num = 0 + if (do_BL_residence) then + CS%ntr = CS%ntr + 1 ; m = CS%ntr ; CS%BL_residence_num = CS%ntr + CS%tr_desc(m) = var_desc("BL_age", "yr", "BL Residence Time Tracer", caller=mdl) + CS%tracer_ages(m) = .true. ; CS%growth_rate(m) = 0.0 + CS%IC_val(m) = 0.0 ; CS%young_val(m) = 0.0 ; CS%tracer_start_year(m) = 0.0 + endif + allocate(CS%tr(isd:ied,jsd:jed,nz,CS%ntr), source=0.0) do m=1,CS%ntr @@ -215,14 +237,10 @@ subroutine initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS ! Local variables character(len=24) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for age tracer fluxes, either - ! years m3 s-1 or years kg s-1. - character(len=72) :: cmorname ! The CMOR name of that variable. logical :: OK integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB + logical :: use_real_BL_depth if (.not.associated(CS)) return if (CS%ntr < 1) return @@ -232,7 +250,7 @@ subroutine initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS CS%Time => day CS%diag => diag - CS%nkml = max(GV%nkml,1) + CS%nkbl = max(GV%nkml,1) do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name=name, & @@ -269,6 +287,7 @@ subroutine initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS enddo ; enddo ; enddo endif + call set_initialized(CS%tr(:,:,:,m), name, CS%restart_CSp) endif ! restart enddo ! Tracer loop @@ -280,7 +299,7 @@ end subroutine initialize_ideal_age_tracer !> Applies diapycnal diffusion, aging and regeneration at the surface to the ideal age tracers subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & - evap_CFL_limit, minimum_forcing_depth) + evap_CFL_limit, minimum_forcing_depth, Hbl) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & @@ -305,6 +324,8 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which !! fluxes can be applied [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: Hbl !< Boundary layer thickness [H ~> m or kg m-2] + ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. ! This is a simple example of a set of advected passive tracers. @@ -312,13 +333,25 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, ! The arguments to this subroutine are redundant in that ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified - real :: sfc_val ! The surface value for the tracers. + real, dimension(SZI_(G),SZJ_(G)) :: BL_layers ! Stores number of layers in boundary layer [nondim] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] + real :: young_val ! The "young" value for the tracers [years] or other units real :: Isecs_per_year ! The inverse of the amount of time in a year [T-1 ~> s-1] - real :: year ! The time in years. - integer :: i, j, k, is, ie, js, je, nz, m + real :: year ! The time in years [years] + real :: layer_frac ! The fraction of the current layer that is within the mixed layer [nondim] + integer :: i, j, k, is, ie, js, je, nz, m, nk + character(len=255) :: msg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + if (CS%use_real_BL_depth .and. .not. present(Hbl)) then + call MOM_error(FATAL, "Attempting to use real boundary layer depth for ideal age tracers, " & + // "but no valid boundary layer scheme was found") + endif + + if (CS%use_real_BL_depth .and. present(Hbl)) then + call count_BL_layers(G, GV, h_old, Hbl, BL_layers) + endif + if (.not.associated(CS)) return if (CS%ntr < 1) return @@ -340,43 +373,136 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, Isecs_per_year = 1.0 / (365.0*86400.0*US%s_to_T) ! Set the surface value of tracer 1 to increase exponentially ! with a 30 year time scale. - year = US%s_to_T*time_type_to_real(CS%Time) * Isecs_per_year + year = time_to_real(CS%Time, scale=US%s_to_T) * Isecs_per_year do m=1,CS%ntr - if (CS%sfc_growth_rate(m) == 0.0) then - sfc_val = CS%young_val(m) + + if (CS%growth_rate(m) == 0.0) then + young_val = CS%young_val(m) else - sfc_val = CS%young_val(m) * & - exp((year-CS%tracer_start_year(m)) * CS%sfc_growth_rate(m)) + young_val = CS%young_val(m) * & + exp((year-CS%tracer_start_year(m)) * CS%growth_rate(m)) endif - do k=1,CS%nkml ; do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.5) then - CS%tr(i,j,k,m) = sfc_val - else - CS%tr(i,j,k,m) = CS%land_val(m) - endif - enddo ; enddo ; enddo - enddo - do m=1,CS%ntr ; if (CS%tracer_ages(m) .and. & - (year>=CS%tracer_start_year(m))) then -!$OMP parallel do default(none) shared(is,ie,js,je,CS,nz,G,dt,Isecs_per_year,m) - do k=CS%nkml+1,nz ; do j=js,je ; do i=is,ie - CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year - enddo ; enddo ; enddo - endif ; enddo + + if (m == CS%BL_residence_num) then + + if (CS%use_real_BL_depth) then + do j=js,je ; do i=is,ie + nk = floor(BL_layers(i,j)) + + do k=1,nk + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo + + k = MIN(nk+1,nz) + + if (G%mask2dT(i,j) > 0.0) then + layer_frac = BL_layers(i,j)-nk + CS%tr(i,j,k,m) = layer_frac * (CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt & + *Isecs_per_year) + (1.-layer_frac) * young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + + + do k=nk+2,nz + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo + enddo ; enddo + + else ! use real BL depth + do j=js,je ; do i=is,ie + do k=1,CS%nkbl + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo + + do k=CS%nkbl+1,nz + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo + enddo ; enddo + + endif ! use real BL depth + + else ! if BL residence tracer + + if (CS%use_real_BL_depth) then + do j=js,je ; do i=is,ie + nk = floor(BL_layers(i,j)) + do k=1,nk + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo + + k = MIN(nk+1,nz) + if (G%mask2dT(i,j) > 0.0) then + layer_frac = BL_layers(i,j)-nk + CS%tr(i,j,k,m) = (1.-layer_frac) * (CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt & + *Isecs_per_year) + layer_frac * young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + + do k=nk+2,nz + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo + enddo ; enddo + + else ! use real BL depth + do k=1,CS%nkbl ; do j=js,je ; do i=is,ie + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo ; enddo ; enddo + + if (CS%tracer_ages(m) .and. (year>=CS%tracer_start_year(m))) then + !$OMP parallel do default(none) shared(is,ie,js,je,CS,nz,G,dt,Isecs_per_year,m) + do k=CS%nkbl+1,nz ; do j=js,je ; do i=is,ie + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year + enddo ; enddo ; enddo + endif + + + endif ! if use real BL depth + endif ! if BL residence tracer + + enddo ! loop over all tracers end subroutine ideal_age_tracer_column_physics !> Calculates the mass-weighted integral of all tracer stocks, returning the number of stocks it !! has calculated. If stock_index is present, only the stock corresponding to that coded index is found. -function ideal_age_stock(h, stocks, G, GV, US, CS, names, units, stock_index) +function ideal_age_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each + type(EFP_type), dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each !! tracer, in kg times concentration units [kg conc]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_ideal_age_tracer. character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. @@ -386,9 +512,7 @@ function ideal_age_stock(h, stocks, G, GV, US, CS, names, units, stock_index) integer :: ideal_age_stock !< The number of stocks calculated here. ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] - integer :: i, j, k, is, ie, js, je, nz, m - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + integer :: m ideal_age_stock = 0 if (.not.associated(CS)) return @@ -401,15 +525,10 @@ function ideal_age_stock(h, stocks, G, GV, US, CS, names, units, stock_index) return endif ; endif - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="ideal_age_stock") units(m) = trim(units(m))//" kg" - stocks(m) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) - enddo ; enddo ; enddo - stocks(m) = stock_scale * stocks(m) + stocks(m) = global_mass_int_EFP(h, G, GV, CS%tr(:,:,:,m), on_PE_only=.true.) enddo ideal_age_stock = CS%ntr @@ -442,7 +561,7 @@ subroutine ideal_age_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif @@ -453,14 +572,43 @@ subroutine ideal_age_example_end(CS) type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_ideal_age_tracer. - integer :: m - if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) deallocate(CS) endif end subroutine ideal_age_example_end +subroutine count_BL_layers(G, GV, h, Hbl, BL_layers) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Hbl !< Boundary layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: BL_layers !< Number of model layers in the boundary layer [nondim] + + real :: current_depth ! Distance from the free surface [H ~> m or kg m-2] + integer :: i, j, k, is, ie, js, je, nz, m, nk + character(len=255) :: msg + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + BL_layers(:,:) = 0. + do j=js,je + do i=is,ie + current_depth = 0. + do k=1,nz + current_depth = current_depth + h(i,j,k) + if (Hbl(i,j) <= current_depth) then + BL_layers(i,j) = BL_layers(i,j) + (1.0 - (current_depth - Hbl(i,j)) / h(i,j,k)) + exit + else + BL_layers(i,j) = BL_layers(i,j) + 1.0 + endif + enddo + enddo + enddo + +end subroutine count_BL_layers + !> \namespace ideal_age_example !! !! Originally by Robert Hallberg, 2002 diff --git a/src/tracer/nw2_tracers.F90 b/src/tracer/nw2_tracers.F90 index 0e66ebbcf3..851cd96bc6 100644 --- a/src/tracer/nw2_tracers.F90 +++ b/src/tracer/nw2_tracers.F90 @@ -1,17 +1,20 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Ideal tracers designed to help diagnose a tracer diffusivity tensor in NeverWorld2 module nw2_tracers -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_diag_mediator, only : diag_ctrl use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type +use MOM_interface_heights, only : thickness_to_dz use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc -use MOM_restart, only : query_initialized, MOM_restart_CS -use MOM_time_manager, only : time_type, time_type_to_real +use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS +use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_unit_scaling, only : unit_scale_type @@ -32,7 +35,7 @@ module nw2_tracers integer :: ntr = 0 !< The number of tracers that are actually used. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry - real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package, in g m-3? + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package, in [conc] (g m-3)? real, allocatable , dimension(:) :: restore_rate !< The rate at which the tracer is damped toward !! its target profile [T-1 ~> s-1] type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to @@ -55,13 +58,11 @@ logical function register_nw2_tracers(HI, GV, US, param_file, CS, tr_Reg, restar !! diffusion module type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control struct -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "nw2_tracers" ! This module's name. - character(len=200) :: inputdir ! The directory where the input files are. character(len=8) :: var_name ! The variable's name. - real, pointer :: tr_ptr(:,:,:) => NULL() - logical :: do_nw2 + real, pointer :: tr_ptr(:,:,:) => NULL() ! The tracer concentration [conc] integer :: isd, ied, jsd, jed, nz, m, ig integer :: n_groups ! Number of groups of three tracers (i.e. # tracers/3) real, allocatable, dimension(:) :: timescale_in_days ! Damping timescale [days] @@ -71,7 +72,6 @@ logical function register_nw2_tracers(HI, GV, US, param_file, CS, tr_Reg, restar if (associated(CS)) then call MOM_error(FATAL, "register_nw2_tracer called with an "// & "associated control structure.") - return endif allocate(CS) @@ -118,7 +118,7 @@ subroutine initialize_nw2_tracers(restart, day, G, GV, US, h, tv, diag, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables @@ -127,7 +127,8 @@ subroutine initialize_nw2_tracers(restart, day, G, GV, US, h, tv, diag, CS) type(nw2_tracers_CS), pointer :: CS !< The control structure returned by a previous !! call to register_nw2_tracer. ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: eta ! Interface heights [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: eta ! Interface heights [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Vertical extent of layers [Z ~> m] real :: rscl ! z* scaling factor [nondim] character(len=8) :: var_name ! The variable's name. integer :: i, j, k, m @@ -138,20 +139,22 @@ subroutine initialize_nw2_tracers(restart, day, G, GV, US, h, tv, diag, CS) CS%diag => diag ! Calculate z* interface positions + call thickness_to_dz(h, tv, dz, G, GV, US) + if (GV%Boussinesq) then ! First calculate interface positions in z-space (m) do j=G%jsc,G%jec ; do i=G%isc,G%iec eta(i,j,GV%ke+1) = - G%mask2dT(i,j) * G%bathyT(i,j) enddo ; enddo do k=GV%ke,1,-1 ; do j=G%jsc,G%jec ; do i=G%isc,G%iec - eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * h(i,j,k) * GV%H_to_Z + eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * dz(i,j,k) enddo ; enddo ; enddo ! Re-calculate for interface positions in z*-space (m) do j=G%jsc,G%jec ; do i=G%isc,G%iec if (G%bathyT(i,j)>0.) then rscl = G%bathyT(i,j) / ( eta(i,j,1) + G%bathyT(i,j) ) do K=GV%ke, 1, -1 - eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * h(i,j,k) * GV%H_to_Z * rscl + eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * dz(i,j,k) * rscl enddo endif enddo ; enddo @@ -164,10 +167,11 @@ subroutine initialize_nw2_tracers(restart, day, G, GV, US, h, tv, diag, CS) ! in which the tracers were not present write(var_name(1:8),'(a6,i2.2)') 'tracer',m if ((.not.restart) .or. & - (.not. query_initialized(CS%tr(:,:,:,m),var_name,CS%restart_CSp))) then + (.not. query_initialized(CS%tr(:,:,:,m), var_name, CS%restart_CSp))) then do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec CS%tr(i,j,k,m) = nw2_tracer_dist(m, G, GV, eta, i, j, k) enddo ; enddo ; enddo + call set_initialized(CS%tr(:,:,:,m), var_name, CS%restart_CSp) endif ! restart enddo ! Tracer loop @@ -178,15 +182,15 @@ subroutine nw2_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h_new !< Layer thickness after entrainment [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: ea !< an array to which the amount of fluid entrained !! from the layer above during this call will be !! added [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: eb !< an array to which the amount of fluid entrained !! from the layer below during this call will be !! added [H ~> m or kg m-2]. @@ -208,12 +212,13 @@ subroutine nw2_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US ! The arguments to this subroutine are redundant in that ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: eta ! Interface heights [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: eta ! Interface heights [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Vertical extent of layers [Z ~> m] integer :: i, j, k, m real :: dt_x_rate ! dt * restoring rate [nondim] real :: rscl ! z* scaling factor [nondim] - real :: target_value ! tracer value + real :: target_value ! tracer target value for damping [conc] ! if (.not.associated(CS)) return @@ -233,20 +238,22 @@ subroutine nw2_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US endif ! Calculate z* interface positions + call thickness_to_dz(h_new, tv, dz, G, GV, US) + if (GV%Boussinesq) then - ! First calculate interface positions in z-space (m) + ! First calculate interface positions in z-space [Z ~> m] do j=G%jsc,G%jec ; do i=G%isc,G%iec eta(i,j,GV%ke+1) = - G%mask2dT(i,j) * G%bathyT(i,j) enddo ; enddo do k=GV%ke,1,-1 ; do j=G%jsc,G%jec ; do i=G%isc,G%iec - eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * h_new(i,j,k) * GV%H_to_Z + eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * dz(i,j,k) enddo ; enddo ; enddo - ! Re-calculate for interface positions in z*-space (m) + ! Re-calculate for interface positions in z*-space [Z ~> m] do j=G%jsc,G%jec ; do i=G%isc,G%iec if (G%bathyT(i,j)>0.) then rscl = G%bathyT(i,j) / ( eta(i,j,1) + G%bathyT(i,j) ) do K=GV%ke, 1, -1 - eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * h_new(i,j,k) * GV%H_to_Z * rscl + eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * dz(i,j,k) * rscl enddo endif enddo ; enddo @@ -265,13 +272,13 @@ subroutine nw2_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US end subroutine nw2_tracer_column_physics -!> The target value of a NeverWorld2 tracer label m at non-dimensional +!> The target value of a NeverWorld2 tracer label m [conc] at non-dimensional !! position x=lon/Lx, y=lat/Ly, z=eta/H real function nw2_tracer_dist(m, G, GV, eta, i, j, k) integer, intent(in) :: m !< Indicates the NW2 tracer type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),0:SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(in) :: eta !< Interface position [Z ~> m] integer, intent(in) :: i !< Cell index i integer, intent(in) :: j !< Cell index j @@ -282,7 +289,7 @@ real function nw2_tracer_dist(m, G, GV, eta, i, j, k) pi = 2.*acos(0.) x = ( G%geolonT(i,j) - G%west_lon ) / G%len_lon ! 0 ... 1 y = -G%geolatT(i,j) / G%south_lat ! -1 ... 1 - z = - 0.5 * ( eta(i,j,K-1) + eta(i,j,K) ) / GV%max_depth ! 0 ... 1 + z = - 0.5 * ( eta(i,j,K) + eta(i,j,K+1) ) / GV%max_depth ! 0 ... 1 select case ( mod(m-1,3) ) case (0) ! sin(2 pi x/L) nw2_tracer_dist = sin( 2.0 * pi * x ) @@ -301,8 +308,6 @@ subroutine nw2_tracers_end(CS) type(nw2_tracers_CS), pointer :: CS !< The control structure returned by a previous !! call to register_nw2_tracers. - integer :: m - if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) deallocate(CS) diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 6f690ab760..9f6e263974 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -1,26 +1,31 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> A tracer package to mimic dissolved oil. module oil_tracer -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux -use MOM_diag_mediator, only : diag_ctrl -use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : forcing -use MOM_grid, only : ocean_grid_type -use MOM_hor_index, only : hor_index_type -use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc -use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : query_initialized, MOM_restart_CS -use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type, time_type_to_real +use MOM_coms, only : EFP_type +use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_io, only : file_exists, MOM_read_data, slasher +use MOM_io, only : vardesc, var_desc, query_vardesc +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type, time_type_to_real use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut -use MOM_tracer_Z_init, only : tracer_Z_init -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface, thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type +use MOM_tracer_Z_init, only : tracer_Z_init +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -39,18 +44,18 @@ module oil_tracer character(len=200) :: IC_file !< The file in which the age-tracer initial values !! can be found, or an empty string for internal initialization. logical :: Z_IC_file !< If true, the IC_file is in Z-space. The default is false. - real :: oil_source_longitude !< Latitude of source location (geographic) - real :: oil_source_latitude !< Longitude of source location (geographic) - integer :: oil_source_i=-999 !< Local i of source location (computational) - integer :: oil_source_j=-999 !< Local j of source location (computational) + real :: oil_source_longitude !< Latitude of source location (geographic) [degrees_N] + real :: oil_source_latitude !< Longitude of source location (geographic) [degrees_E] + integer :: oil_source_i=-999 !< Local i of source location (computational index location) + integer :: oil_source_j=-999 !< Local j of source location (computational index location) real :: oil_source_rate !< Rate of oil injection [kg T-1 ~> kg s-1] real :: oil_start_year !< The time at which the oil source starts [years] real :: oil_end_year !< The time at which the oil source ends [years] type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the MOM tracer registry - real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, in g m-3? - real, dimension(NTR_MAX) :: IC_val = 0.0 !< The (uniform) initial condition value. - real, dimension(NTR_MAX) :: land_val = -1.0 !< The value of tr used where land is masked out. + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, [kg m-3] + real, dimension(NTR_MAX) :: IC_val = 0.0 !< The (uniform) initial condition value [kg m-3] + real, dimension(NTR_MAX) :: land_val = -1.0 !< The value of tr used where land is masked out [kg m-3] real, dimension(NTR_MAX) :: oil_decay_rate !< Decay rate of oil [T-1 ~> s-1] calculated from oil_decay_days integer, dimension(NTR_MAX) :: oil_source_k !< Layer of source logical :: oil_may_reinit !< If true, oil tracers may be reset by the initialization code @@ -81,7 +86,7 @@ function register_oil_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) ! Local variables character(len=40) :: mdl = "oil_tracer" ! This module's name. -! This include declares and sets the variable "version". + ! This include declares and sets the variable "version". # include "version_variable.h" real, dimension(NTR_MAX) :: oil_decay_days !< Decay time scale of oil [days] character(len=200) :: inputdir ! The directory where the input files are. @@ -89,15 +94,14 @@ function register_oil_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) character(len=3) :: name_tag ! String for creating identifying oils character(len=48) :: flux_units ! The units for tracer fluxes, here ! kg(oil) s-1 or kg(oil) m-3 kg(water) s-1. - real, pointer :: tr_ptr(:,:,:) => NULL() + real, pointer :: tr_ptr(:,:,:) => NULL() ! The tracer concentration [kg m-3] logical :: register_oil_tracer - integer :: isd, ied, jsd, jed, nz, m, i, j + integer :: isd, ied, jsd, jed, nz, m isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke if (associated(CS)) then - call MOM_error(WARNING, "register_oil_tracer called with an "// & - "associated control structure.") - return + call MOM_error(FATAL, "register_oil_tracer called with an "// & + "associated control structure.") endif allocate(CS) @@ -111,7 +115,7 @@ function register_oil_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) ! Add the directory if CS%IC_file is not already a complete path. call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") CS%IC_file = trim(slasher(inputdir))//trim(CS%IC_file) - call log_param(param_file, mdl, "INPUTDIR/CFC_IC_FILE", CS%IC_file) + call log_param(param_file, mdl, "INPUTDIR/OIL_IC_FILE", CS%IC_file) endif call get_param(param_file, mdl, "OIL_IC_FILE_IS_Z", CS%Z_IC_file, & "If true, OIL_IC_FILE is in depth space, not layer space", & @@ -124,10 +128,10 @@ function register_oil_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) "found in the restart files of a restarted run.", & default=.false.) call get_param(param_file, mdl, "OIL_SOURCE_LONGITUDE", CS%oil_source_longitude, & - "The geographic longitude of the oil source.", units="degrees E", & + "The geographic longitude of the oil source.", units="degrees_E", & fail_if_missing=.true.) call get_param(param_file, mdl, "OIL_SOURCE_LATITUDE", CS%oil_source_latitude, & - "The geographic latitude of the oil source.", units="degrees N", & + "The geographic latitude of the oil source.", units="degrees_N", & fail_if_missing=.true.) call get_param(param_file, mdl, "OIL_SOURCE_LAYER", CS%oil_source_k, & "The layer into which the oil is introduced, or a "//& @@ -163,7 +167,8 @@ function register_oil_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) endif endif enddo - call log_param(param_file, mdl, "OIL_DECAY_RATE", US%s_to_T*CS%oil_decay_rate(1:CS%ntr)) + call log_param(param_file, mdl, "OIL_DECAY_RATE", CS%oil_decay_rate(1:CS%ntr), & + units="s-1", unscale=US%s_to_T) ! This needs to be changed if the units of tracer are changed above. if (GV%Boussinesq) then ; flux_units = "kg s-1" @@ -217,10 +222,6 @@ subroutine initialize_oil_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & ! Local variables character(len=16) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for age tracer fluxes, either - ! years m3 s-1 or years kg s-1. logical :: OK integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB @@ -279,7 +280,7 @@ subroutine initialize_oil_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & endif enddo ; enddo ; enddo endif - + call set_initialized(CS%tr(:,:,:,m), name, CS%restart_CSp) endif ! restart enddo ! Tracer loop @@ -363,7 +364,8 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US if (CS%oil_decay_rate(m)>0.) then CS%tr(i,j,k,m) = G%mask2dT(i,j)*max(1. - dt*CS%oil_decay_rate(m),0.)*CS%tr(i,j,k,m) ! Safest elseif (CS%oil_decay_rate(m)<0.) then - decay_timescale = (12.*(3.0**(-(tv%T(i,j,k)-20.)/10.))) * (86400.*US%s_to_T) ! Timescale [s ~> T] + decay_timescale = (12.0 * (3.0**(-(tv%T(i,j,k)-20.0*US%degC_to_C)/10.0*US%degC_to_C))) * & + (86400.0*US%s_to_T) ! Timescale [T ~> s] ldecay = 1. / decay_timescale ! Rate [T-1 ~> s-1] CS%tr(i,j,k,m) = G%mask2dT(i,j)*max(1. - dt*ldecay,0.)*CS%tr(i,j,k,m) endif @@ -373,21 +375,21 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US ! Add oil at the source location if (year>=CS%oil_start_year .and. year<=CS%oil_end_year .and. & CS%oil_source_i>-999 .and. CS%oil_source_j>-999) then - i=CS%oil_source_i ; j=CS%oil_source_j - k_max=nz ; h_total=0. + i = CS%oil_source_i ; j = CS%oil_source_j + k_max = nz ; h_total = 0. vol_scale = GV%H_to_m * US%L_to_m**2 do k=nz, 2, -1 h_total = h_total + h_new(i,j,k) - if (h_total<10.) k_max=k-1 ! Find bottom most interface that is 10 m above bottom + if (h_total < 10.*GV%m_to_H) k_max=k-1 ! Find bottom most interface that is 10 m above bottom enddo do m=1,CS%ntr - k=CS%oil_source_k(m) + k = CS%oil_source_k(m) if (k>0) then - k=min(k,k_max) ! Only insert k or first layer with interface 10 m above bottom + k = min(k,k_max) ! Only insert k or first layer with interface 10 m above bottom CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + CS%oil_source_rate*dt / & (vol_scale * (h_new(i,j,k)+GV%H_subroundoff) * G%areaT(i,j) ) elseif (k<0) then - h_total=GV%H_subroundoff + h_total = GV%H_subroundoff do k=1, nz h_total = h_total + h_new(i,j,k) enddo @@ -402,13 +404,12 @@ end subroutine oil_tracer_column_physics !> Calculate the mass-weighted integral of the oil tracer stocks, returning the number of stocks it !! has calculated. If the stock_index is present, only the stock corresponding to that coded index is returned. -function oil_stock(h, stocks, G, GV, US, CS, names, units, stock_index) +function oil_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each - !! tracer, in kg times concentration units [kg conc]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] type(oil_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_oil_tracer. character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. @@ -418,9 +419,7 @@ function oil_stock(h, stocks, G, GV, US, CS, names, units, stock_index) integer :: oil_stock !< The number of stocks calculated here. ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] - integer :: i, j, k, is, ie, js, je, nz, m - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + integer :: m oil_stock = 0 if (.not.associated(CS)) return @@ -433,15 +432,10 @@ function oil_stock(h, stocks, G, GV, US, CS, names, units, stock_index) return endif ; endif - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="oil_stock") units(m) = trim(units(m))//" kg" - stocks(m) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) - enddo ; enddo ; enddo - stocks(m) = stock_scale * stocks(m) + stocks(m) = global_mass_int_EFP(h, G, GV, CS%tr(:,:,:,m), on_PE_only=.true.) enddo oil_stock = CS%ntr @@ -474,7 +468,7 @@ subroutine oil_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif @@ -484,7 +478,6 @@ end subroutine oil_tracer_surface_state subroutine oil_tracer_end(CS) type(oil_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_oil_tracer. - integer :: m if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) @@ -503,7 +496,7 @@ end subroutine oil_tracer_end !! !! This tracer package was central to the simulations used by Adcroft et al., !! GRL 2010, to prove that the Deepwater Horizon spill was an important regional -!! event, with implications for dissolved oxygen levels in the Gulf of Mexico, -!! but not one that would directly impact the East Coast of the U.S. +!! event, with implications for dissolved oxygen levels in certains regions, +!! see above reference for details. end module oil_tracer diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index c441e519be..4be887940a 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -1,8 +1,11 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> A tracer package that mimics salinity module pseudo_salt_tracer -! This file is part of MOM6. See LICENSE.md for the license. - +use MOM_coms, only : EFP_type use MOM_debugging, only : hchksum use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl @@ -10,13 +13,15 @@ module pseudo_salt_tracer use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type +use MOM_CVMix_KPP, only : KPP_NonLocalTransport, KPP_CS use MOM_hor_index, only : hor_index_type use MOM_io, only : vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : query_initialized, MOM_restart_CS +use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type -use MOM_tracer_registry, only : register_tracer, tracer_registry_type +use MOM_tracer_registry, only : register_tracer, tracer_registry_type, tracer_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init use MOM_unit_scaling, only : unit_scale_type @@ -33,6 +38,7 @@ module pseudo_salt_tracer !> The control structure for the pseudo-salt tracer type, public :: pseudo_salt_tracer_CS ; private + type(tracer_type), pointer :: tr_ptr !< pointer to tracer inside Tr_reg type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the MOM tracer registry real, pointer :: ps(:,:,:) => NULL() !< The array of pseudo-salt tracer used in this @@ -69,16 +75,14 @@ function register_pseudo_salt_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) character(len=48) :: var_name ! The variable's name. ! This include declares and sets the variable "version". # include "version_variable.h" - real, pointer :: tr_ptr(:,:,:) => NULL() + real, pointer :: tr_ptr(:,:,:) => NULL() ! The tracer concentration [ppt] logical :: register_pseudo_salt_tracer integer :: isd, ied, jsd, jed, nz isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke if (associated(CS)) then - call MOM_error(WARNING, "register_pseudo_salt_tracer called with an "// & - "associated control structure.") - register_pseudo_salt_tracer = .false. - return + call MOM_error(FATAL, "register_pseudo_salt_tracer called with an "// & + "associated control structure.") endif allocate(CS) @@ -96,7 +100,7 @@ function register_pseudo_salt_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, name="pseudo_salt", & longname="Pseudo salt passive tracer", units="psu", & registry_diags=.true., restart_CS=restart_CS, & - mandatory=.not.CS%pseudo_salt_may_reinit) + mandatory=.not.CS%pseudo_salt_may_reinit, Tr_out=CS%tr_ptr) CS%tr_Reg => tr_Reg CS%restart_CSp => restart_CS @@ -105,13 +109,14 @@ function register_pseudo_salt_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) end function register_pseudo_salt_tracer !> Initialize the pseudo-salt tracer -subroutine initialize_pseudo_salt_tracer(restart, day, G, GV, h, diag, OBC, CS, & +subroutine initialize_pseudo_salt_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & sponge_CSp, tv) logical, intent(in) :: restart !< .true. if the fields have already !! been read from a restart file. type(time_type), target, intent(in) :: day !< Time of the start of the run type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate @@ -141,8 +146,9 @@ subroutine initialize_pseudo_salt_tracer(restart, day, G, GV, h, diag, OBC, CS, call query_vardesc(CS%tr_desc, name=name, caller="initialize_pseudo_salt_tracer") if ((.not.restart) .or. (.not.query_initialized(CS%ps, name, CS%restart_CSp))) then do k=1,nz ; do j=jsd,jed ; do i=isd,ied - CS%ps(i,j,k) = tv%S(i,j,k) + CS%ps(i,j,k) = US%S_to_ppt*tv%S(i,j,k) enddo ; enddo ; enddo + call set_initialized(CS%ps, name, CS%restart_CSp) endif if (associated(OBC)) then @@ -157,7 +163,7 @@ end subroutine initialize_pseudo_salt_tracer !> Apply sources, sinks and diapycnal diffusion to the tracers in this package. subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, tv, debug, & - evap_CFL_limit, minimum_forcing_depth) + KPP_CSp, nonLocalTrans, evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & @@ -178,6 +184,8 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G !! call to register_pseudo_salt_tracer type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables logical, intent(in) :: debug !< If true calculate checksums + type(KPP_CS), optional, pointer :: KPP_CSp !< KPP control structure + real, optional, intent(in) :: nonLocalTrans(:,:,:) !< Non-local transport [nondim] real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which @@ -190,6 +198,8 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) ! Local variables + real :: net_salt_rate(SZI_(G),SZJ_(G)) ! Net salt flux into the ocean + ! [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] real :: net_salt(SZI_(G),SZJ_(G)) ! Net salt flux into the ocean integrated over ! a timestep [ppt H ~> ppt m or ppt kg m-2] real :: htot(SZI_(G)) ! Total ocean depth [H ~> m or kg m-2] @@ -206,17 +216,39 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G if (.not.associated(CS%ps)) return if (debug) then - call hchksum(tv%S,"salt pre pseudo-salt vertdiff", G%HI) + call hchksum(tv%S,"salt pre pseudo-salt vertdiff", G%HI, unscale=US%S_to_ppt) call hchksum(CS%ps,"pseudo_salt pre pseudo-salt vertdiff", G%HI) endif + FluxRescaleDepth = max( GV%Angstrom_H, 1.e-30*GV%m_to_H ) + Ih_limit = 0.0 ; if (FluxRescaleDepth > 0.0) Ih_limit = 1.0 / FluxRescaleDepth + + ! Compute KPP nonlocal term if necessary + if (present(KPP_CSp)) then + if (associated(KPP_CSp) .and. present(nonLocalTrans)) then + ! Determine the salt flux, including limiting for small total ocean depths. + net_salt_rate(:,:) = 0.0 + if (associated(fluxes%salt_flux)) then + do j=js,je + do i=is,ie ; htot(i) = h_old(i,j,1) ; enddo + do k=2,nz ; do i=is,ie ; htot(i) = htot(i) + h_old(i,j,k) ; enddo ; enddo + do i=is,ie + scale = 1.0 ; if ((Ih_limit > 0.0) .and. (htot(i)*Ih_limit < 1.0)) scale = htot(i)*Ih_limit + net_salt_rate(i,j) = (scale * (1000.0 * fluxes%salt_flux(i,j))) * GV%RZ_to_H + enddo + enddo + endif + call KPP_NonLocalTransport(KPP_CSp, G, GV, h_old, nonLocalTrans, net_salt_rate, & + dt, CS%diag, CS%tr_ptr, CS%ps(:,:,:)) + endif + endif + + ! This uses applyTracerBoundaryFluxesInOut, usually in ALE mode if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then ! This option uses applyTracerBoundaryFluxesInOut, usually in ALE mode ! Determine the time-integrated salt flux, including limiting for small total ocean depths. net_Salt(:,:) = 0.0 - FluxRescaleDepth = max( GV%Angstrom_H, 1.e-30*GV%m_to_H ) - Ih_limit = 0.0 ; if (FluxRescaleDepth > 0.0) Ih_limit = 1.0 / FluxRescaleDepth do j=js,je do i=is,ie ; htot(i) = h_old(i,j,1) ; enddo do k=2,nz ; do i=is,ie ; htot(i) = htot(i) + h_old(i,j,k) ; enddo ; enddo @@ -237,13 +269,13 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G endif if (debug) then - call hchksum(tv%S, "salt post pseudo-salt vertdiff", G%HI) + call hchksum(tv%S, "salt post pseudo-salt vertdiff", G%HI, unscale=US%S_to_ppt) call hchksum(CS%ps, "pseudo_salt post pseudo-salt vertdiff", G%HI) endif if (allocated(CS%diff)) then do k=1,nz ; do j=js,je ; do i=is,ie - CS%diff(i,j,k) = CS%ps(i,j,k) - tv%S(i,j,k) + CS%diff(i,j,k) = CS%ps(i,j,k) - US%S_to_ppt*tv%S(i,j,k) enddo ; enddo ; enddo if (CS%id_psd>0) call post_data(CS%id_psd, CS%diff, CS%diag) endif @@ -253,13 +285,12 @@ end subroutine pseudo_salt_tracer_column_physics !> Calculates the mass-weighted integral of all tracer stocks, returning the number of stocks it has !! calculated. If the stock_index is present, only the stock corresponding to that coded index is returned. -function pseudo_salt_stock(h, stocks, G, GV, US, CS, names, units, stock_index) +function pseudo_salt_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each !! tracer, in kg times concentration units [kg conc] - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_pseudo_salt_tracer character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated @@ -269,10 +300,6 @@ function pseudo_salt_stock(h, stocks, G, GV, US, CS, names, units, stock_index) integer :: pseudo_salt_stock !< Return value: the number of !! stocks calculated here - ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] - integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke pseudo_salt_stock = 0 if (.not.associated(CS)) return @@ -285,14 +312,9 @@ function pseudo_salt_stock(h, stocks, G, GV, US, CS, names, units, stock_index) return endif ; endif - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 call query_vardesc(CS%tr_desc, name=names(1), units=units(1), caller="pseudo_salt_stock") units(1) = trim(units(1))//" kg" - stocks(1) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - stocks(1) = stocks(1) + CS%diff(i,j,k) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) - enddo ; enddo ; enddo - stocks(1) = stock_scale * stocks(1) + stocks(1) = global_mass_int_EFP(h, G, GV, CS%diff, on_PE_only=.true.) pseudo_salt_stock = 1 diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index a41f0ab76d..14011d16b9 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -1,24 +1,29 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> A sample tracer package that has striped initial conditions module USER_tracer_example -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux -use MOM_diag_mediator, only : diag_ctrl -use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : forcing -use MOM_grid, only : ocean_grid_type -use MOM_hor_index, only : hor_index_type -use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc -use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : MOM_restart_CS -use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type +use MOM_coms, only : EFP_type +use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_io, only : file_exists, MOM_read_data, slasher +use MOM_io, only : vardesc, var_desc, query_vardesc +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface -use MOM_verticalGrid, only : verticalGrid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -36,8 +41,13 @@ module USER_tracer_example !! to initialize internally. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry - real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, in g m-3? - real :: land_val(NTR) = -1.0 !< The value of tr that is used where land is masked out. + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, perhaps in [g kg-1]? + real :: land_val(NTR) = -1.0 !< The value of tr that is used where land is masked out, perhaps in [g kg-1]? + + real :: stripe_width !< The Gaussian width of the stripe in the initial condition + !! for the tracer_example tracers [L ~> m] + real :: stripe_lat !< The central latitude of the stripe in the initial condition + !! for the tracer_example tracers, in [degrees_N] or [km] or [m]. logical :: use_sponge !< If true, sponges may be applied somewhere in the domain. integer, dimension(NTR) :: ind_tr !< Indices returned by atmos_ocn_coupler_flux if it is used and the @@ -51,43 +61,43 @@ module USER_tracer_example contains !> This subroutine is used to register tracer fields and subroutines to be used with MOM. -function USER_register_tracer_example(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI !< A horizontal index type structure +function USER_register_tracer_example(G, GV, US, param_file, CS, tr_Reg, restart_CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(USER_tracer_example_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control !! structure for the tracer advection and !! diffusion module - type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct ! Local variables character(len=80) :: name, longname -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "tracer_example" ! This module's name. character(len=200) :: inputdir character(len=48) :: flux_units ! The units for tracer fluxes, usually ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. - real, pointer :: tr_ptr(:,:,:) => NULL() + real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to one of the tracers, perhaps in [g kg-1] logical :: USER_register_tracer_example integer :: isd, ied, jsd, jed, nz, m - isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke if (associated(CS)) then - call MOM_error(WARNING, "USER_register_tracer_example called with an "// & - "associated control structure.") - return + call MOM_error(FATAL, "USER_register_tracer_example called with an "// & + "associated control structure.") endif allocate(CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "TRACER_EXAMPLE_IC_FILE", CS%tracer_IC_file, & - "The name of a file from which to read the initial "//& - "conditions for the DOME tracers, or blank to initialize "//& - "them internally.", default=" ") + "The name of a file from which to read the initial conditions for "//& + "the tracer_example tracers, or blank to initialize them internally.", & + default=" ") if (len_trim(CS%tracer_IC_file) >= 1) then call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") CS%tracer_IC_file = trim(slasher(inputdir))//trim(CS%tracer_IC_file) @@ -98,12 +108,17 @@ function USER_register_tracer_example(HI, GV, param_file, CS, tr_Reg, restart_CS "If true, sponges may be applied anywhere in the domain. "//& "The exact location and properties of those sponges are "//& "specified from MOM_initialization.F90.", default=.false.) + call get_param(param_file, mdl, "TRACER_EXAMPLE_STRIPE_WIDTH", CS%stripe_width, & + "The Gaussian width of the stripe in the initial condition for the "//& + "tracer_example tracers.", units="m", default=1.0e5, scale=US%m_to_L) + call get_param(param_file, mdl, "TRACER_EXAMPLE_STRIPE_LAT", CS%stripe_lat, & + "The central latitude of the stripe in the initial condition for the "//& + "tracer_example tracers.", units=G%y_ax_unit_short, default=40.0) allocate(CS%tr(isd:ied,jsd:jed,nz,NTR), source=0.0) do m=1,NTR - if (m < 10) then ; write(name,'("tr",I1.1)') m - else ; write(name,'("tr",I2.2)') m ; endif + write(name,'("tr",I0)') m write(longname,'("Concentration of Tracer ",I2.2)') m CS%tr_desc(m) = var_desc(name, units="kg kg-1", longname=longname, caller=mdl) @@ -111,11 +126,10 @@ function USER_register_tracer_example(HI, GV, param_file, CS, tr_Reg, restart_CS if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" else ; flux_units = "kg s-1" ; endif - ! This is needed to force the compiler not to do a copy in the registration - ! calls. Curses on the designers and implementers of Fortran90. + ! This pointer is needed to force the compiler not to do a copy in the registration calls. tr_ptr => CS%tr(:,:,:,m) ! Register the tracer for horizontal advection, diffusion, and restarts. - call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & + call register_tracer(tr_ptr, tr_Reg, param_file, G%HI, GV, & name=name, longname=longname, units="kg kg-1", & registry_diags=.true., flux_units=flux_units, & restart_CS=restart_CS) @@ -155,15 +169,11 @@ subroutine USER_initialize_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & !! for the sponges, if they are in use. ! Local variables - real, allocatable :: temp(:,:,:) + real, allocatable :: temp(:,:,:) ! Target values for the tracers in the sponges, perhaps in [g kg-1] character(len=32) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for tracer fluxes, usually - ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. - real, pointer :: tr_ptr(:,:,:) => NULL() - real :: PI ! 3.1415926... calculated as 4*atan(1) - real :: tr_y ! Initial zonally uniform tracer concentrations. + real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to one of the tracers, perhaps in [g kg-1] + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] + real :: tr_y ! Initial zonally uniform tracer concentrations, perhaps in [g kg-1] real :: dist2 ! The distance squared from a line [L2 ~> m2]. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB, lntr @@ -197,9 +207,8 @@ subroutine USER_initialize_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & ! This sets a stripe of tracer across the basin. PI = 4.0*atan(1.0) do j=js,je - dist2 = (G%Rad_Earth_L * PI / 180.0)**2 * & - (G%geoLatT(i,j) - 40.0) * (G%geoLatT(i,j) - 40.0) - tr_y = 0.5 * exp( -dist2 / (1.0e5*US%m_to_L)**2 ) + dist2 = (G%Rad_Earth_L * PI / 180.0)**2 * (G%geoLatT(i,j) - CS%stripe_lat)**2 + tr_y = 0.5 * exp( -dist2 / CS%stripe_width**2 ) do k=1,nz ; do i=is,ie ! This adds the stripes of tracer to every layer. @@ -220,7 +229,7 @@ subroutine USER_initialize_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & allocate(temp(G%isd:G%ied,G%jsd:G%jed,nz)) do k=1,nz ; do j=js,je ; do i=is,ie - if (G%geoLatT(i,j) > 700.0 .and. (k > nz/2)) then + if ((G%geoLatT(i,j) > 0.5*G%len_lat + G%south_lat) .and. (k > nz/2)) then temp(i,j,k) = 1.0 else temp(i,j,k) = 0.0 @@ -229,8 +238,7 @@ subroutine USER_initialize_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & ! do m=1,NTR do m=1,1 - ! This is needed to force the compiler not to do a copy in the sponge - ! calls. Curses on the designers and implementers of Fortran90. + ! This pointer is needed to force the compiler not to do a copy in the sponge calls. tr_ptr => CS%tr(:,:,:,m) call set_up_sponge_field(temp, tr_ptr, G, GV, nz, sponge_CSp) enddo @@ -246,7 +254,8 @@ subroutine USER_initialize_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & endif ! All tracers but the first have 0 concentration in their inflows. As this ! is the default value, the following calls are unnecessary. - do m=2,lntr + !do m=2,lntr + do m=2,ntr call query_vardesc(CS%tr_desc(m), name, caller="USER_initialize_tracer") ! Steal from updated DOME in the fullness of time. enddo @@ -289,28 +298,25 @@ subroutine tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, real :: d1(SZI_(G)) ! d1=1-c1 is used by the tridiagonal solver [nondim]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. - real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. + real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. + real :: diapyc_filt ! A multiplicative filter that can be set to 0 to disable diapycnal + ! advection of the tracer [nondim] + real :: dye_up ! The tracer concentration of upwelled water, perhaps in [g kg-1]? + real :: dye_down ! The tracer concentration of downwelled water, perhaps in [g kg-1]? integer :: i, j, k, is, ie, js, je, nz, m -! The following array (trdc) determines the behavior of the tracer -! diapycnal advection. The first element is 1 if tracers are -! passively advected. The second and third are the concentrations -! to which downwelling and upwelling water are set, respectively. -! For most (normal) tracers, the appropriate vales are {1,0,0}. - - real :: trdc(3) -! Uncomment the following line to dye both upwelling and downwelling. -! data trdc / 0.0,1.0,1.0 / -! Uncomment the following line to dye downwelling. -! data trdc / 0.0,1.0,0.0 / -! Uncomment the following line to dye upwelling. -! data trdc / 0.0,0.0,1.0 / -! Uncomment the following line for tracer concentrations to be set -! to zero in any diapycnal motions. -! data trdc / 0.0,0.0,0.0 / -! Uncomment the following line for most "physical" tracers, which -! are advected diapycnally in the usual manner. - data trdc / 1.0,0.0,0.0 / + ! These are the settings for most "physical" tracers, which + ! are advected diapycnally in the usual manner. + diapyc_filt = 1.0 ; dye_down = 0.0 ; dye_down = 0.0 + + ! Uncomment the following line to dye downwelling. +! diapyc_filt = 0.0 ; dye_down = 1.0 + ! Uncomment the following line to dye upwelling. +! diapyc_filt = 0.0 ; dye_up = 1.0 + ! Uncomment the following line for tracer concentrations to be set + ! to zero in any diapycnal motions. +! diapyc_filt = 0.0 ; dye_down = 0.0 ; dye_down = 0.0 + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not.associated(CS)) return @@ -331,21 +337,21 @@ subroutine tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, b_denom_1 = h_old(i,j,1) + ea(i,j,1) + h_neglect b1(i) = 1.0 / (b_denom_1 + eb(i,j,1)) ! d1(i) = b_denom_1 * b1(i) - d1(i) = trdc(1) * (b_denom_1 * b1(i)) + (1.0 - trdc(1)) + d1(i) = diapyc_filt * (b_denom_1 * b1(i)) + (1.0 - diapyc_filt) do m=1,NTR - CS%tr(i,j,1,m) = b1(i)*(hold0(i)*CS%tr(i,j,1,m) + trdc(3)*eb(i,j,1)) + CS%tr(i,j,1,m) = b1(i)*(hold0(i)*CS%tr(i,j,1,m) + dye_up*eb(i,j,1)) ! Add any surface tracer fluxes to the preceding line. enddo enddo do k=2,nz ; do i=is,ie - c1(i,k) = trdc(1) * eb(i,j,k-1) * b1(i) + c1(i,k) = diapyc_filt * eb(i,j,k-1) * b1(i) b_denom_1 = h_old(i,j,k) + d1(i)*ea(i,j,k) + h_neglect b1(i) = 1.0 / (b_denom_1 + eb(i,j,k)) - d1(i) = trdc(1) * (b_denom_1 * b1(i)) + (1.0 - trdc(1)) + d1(i) = diapyc_filt * (b_denom_1 * b1(i)) + (1.0 - diapyc_filt) do m=1,NTR CS%tr(i,j,k,m) = b1(i) * (h_old(i,j,k)*CS%tr(i,j,k,m) + & - ea(i,j,k)*(trdc(1)*CS%tr(i,j,k-1,m)+trdc(2)) + & - eb(i,j,k)*trdc(3)) + ea(i,j,k)*(diapyc_filt*CS%tr(i,j,k-1,m) + dye_down) + & + eb(i,j,k)*dye_up) enddo enddo ; enddo do m=1,NTR ; do k=nz-1,1,-1 ; do i=is,ie @@ -358,14 +364,13 @@ end subroutine tracer_column_physics !> This function calculates the mass-weighted integral of all tracer stocks, !! returning the number of stocks it has calculated. If the stock_index !! is present, only the stock corresponding to that coded index is returned. -function USER_tracer_stock(h, stocks, G, GV, US, CS, names, units, stock_index) +function USER_tracer_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each - !! tracer, in kg times concentration units [kg conc]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] type(USER_tracer_example_CS), pointer :: CS !< The control structure returned by a !! previous call to register_USER_tracer. character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. @@ -376,9 +381,7 @@ function USER_tracer_stock(h, stocks, G, GV, US, CS, names, units, stock_index) !! stocks calculated here. ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] - integer :: i, j, k, is, ie, js, je, nz, m - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + integer :: m USER_tracer_stock = 0 if (.not.associated(CS)) return @@ -390,15 +393,10 @@ function USER_tracer_stock(h, stocks, G, GV, US, CS, names, units, stock_index) return endif ; endif - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 do m=1,NTR call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="USER_tracer_stock") units(m) = trim(units(m))//" kg" - stocks(m) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) - enddo ; enddo ; enddo - stocks(m) = stock_scale * stocks(m) + stocks(m) = global_mass_int_EFP(h, G, GV, CS%tr(:,:,:,m), on_PE_only=.true.) enddo USER_tracer_stock = NTR @@ -430,7 +428,7 @@ subroutine USER_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif @@ -440,7 +438,6 @@ end subroutine USER_tracer_surface_state subroutine USER_tracer_example_end(CS) type(USER_tracer_example_CS), pointer :: CS !< The control structure returned by a previous !! call to register_USER_tracer. - integer :: m if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) diff --git a/src/user/BFB_initialization.F90 b/src/user/BFB_initialization.F90 index 8ef21d190f..34b128522e 100644 --- a/src/user/BFB_initialization.F90 +++ b/src/user/BFB_initialization.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Initialization of the boundary-forced-basing configuration module BFB_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories @@ -11,7 +13,6 @@ module BFB_initialization use MOM_tracer_registry, only : tracer_registry_type use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -25,10 +26,6 @@ module BFB_initialization ! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units ! vary with the Boussinesq approximation, the Boussinesq variant is given first. -!> Unsafe model variable -!! \todo Remove this module variable -logical :: first_call = .true. - contains !> This subroutine specifies the vertical coordinate in terms of temperature at the surface and at the bottom. @@ -43,37 +40,51 @@ subroutine BFB_set_coord(Rlay, g_prime, GV, US, param_file) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - real :: drho_dt, SST_s, T_bot, rho_top, rho_bot - integer :: k, nz - character(len=40) :: mdl = "BFB_set_coord" ! This subroutine's name. + real :: Rho_T0_S0 ! The density at T=0, S=0 [R ~> kg m-3] + real :: dRho_dT ! The partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: dRho_dS ! The partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] + real :: SST_s, T_bot ! Temperatures at the surface and seafloor [C ~> degC] + real :: S_ref ! Reference salinity [S ~> ppt] + real :: rho_top, rho_bot ! Densities at the surface and seafloor [R ~> kg m-3] + integer :: k, nz + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "BFB_initialization" ! This module's name. - call get_param(param_file, mdl, "DRHO_DT", drho_dt, & - "Rate of change of density with temperature.", & - units="kg m-3 K-1", default=-0.2, scale=US%kg_m3_to_R) + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "DRHO_DT", dRho_dT, & + "The partial derivative of density with temperature.", & + units="kg m-3 K-1", default=-0.2, scale=US%kg_m3_to_R*US%C_to_degC) + call get_param(param_file, mdl, "DRHO_DS", dRho_dS, & + "The partial derivative of density with salinity.", & + units="kg m-3 PSU-1", default=0.8, scale=US%kg_m3_to_R*US%S_to_ppt) + call get_param(param_file, mdl, "RHO_T0_S0", Rho_T0_S0, & + "The density at T=0, S=0.", units="kg m-3", default=1000.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "SST_S", SST_s, & - "SST at the suothern edge of the domain.", units="C", default=20.0) + "SST at the southern edge of the domain.", & + units="degC", default=20.0, scale=US%degC_to_C) call get_param(param_file, mdl, "T_BOT", T_bot, & - "Bottom Temp", units="C", default=5.0) - rho_top = GV%Rho0 + drho_dt*SST_s - rho_bot = GV%Rho0 + drho_dt*T_bot + "Bottom temperature", units="degC", default=5.0, scale=US%degC_to_C) + call get_param(param_file, mdl, "S_REF", S_ref, & + "The initial salinities.", units="PSU", default=35.0, scale=US%ppt_to_S) + rho_top = (Rho_T0_S0 + dRho_dS*S_ref) + dRho_dT*SST_s + rho_bot = (Rho_T0_S0 + dRho_dS*S_ref) + dRho_dT*T_bot nz = GV%ke do k = 1,nz Rlay(k) = (rho_bot - rho_top)/(nz-1)*real(k-1) + rho_top - if (k >1) then - g_prime(k) = (Rlay(k) - Rlay(k-1)) * GV%g_Earth / (GV%Rho0) - else + if (k==1) then g_prime(k) = GV%g_Earth + elseif (GV%Boussinesq) then + g_prime(k) = (Rlay(k) - Rlay(k-1)) * GV%g_Earth / GV%Rho0 + else + g_prime(k) = (Rlay(k) - Rlay(k-1)) * GV%g_Earth / (0.5*(Rlay(k) + Rlay(k-1))) endif - !Rlay(:) = 0.0 - !g_prime(:) = 0.0 enddo - if (first_call) call write_BFB_log(param_file) - end subroutine BFB_set_coord -!> This subroutine sets up the sponges for the southern bouundary of the domain. Maximum damping occurs +!> This subroutine sets up the sponges for the southern boundary of the domain. Maximum damping occurs !! within 2 degrees lat of the boundary. The damping linearly decreases northward over the next 2 degrees. subroutine BFB_initialize_sponges_southonly(G, GV, US, use_temperature, tv, depth_tot, param_file, CSp, h) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure @@ -93,44 +104,44 @@ subroutine BFB_initialize_sponges_southonly(G, GV, US, use_temperature, tv, dept real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! A temporary array for eta, in depth units [Z ~> m]. real :: Idamp(SZI_(G),SZJ_(G)) ! The sponge damping rate [T-1 ~> s-1] real :: H0(SZK_(GV)) ! Resting layer thicknesses in depth units [Z ~> m]. - real :: min_depth ! The minimum ocean depth in depth units [Z ~> m]. - real :: slat, wlon, lenlat, lenlon, nlat + real :: slat ! The southern latitude of the domain [degrees_N] + real :: wlon ! The western longitude of the domain [degrees_E] + real :: lenlat ! The latitudinal length of the domain [degrees_N] + real :: lenlon ! The longitudinal length of the domain [degrees_E] + real :: nlat ! The northern latitude of the domain [degrees_N] real :: max_damping ! The maximum damping rate [T-1 ~> s-1] + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "BFB_initialize_sponges_southonly" ! This subroutine's name. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz 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 - eta(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 - ! Here the inverse damping time [T-1 ~> s-1], is set. Set Idamp to 0 ! wherever there is no sponge, and the subroutines that are called ! will automatically set up the sponges only where Idamp is positive ! and mask2dT is 1. -! Set up sponges for DOME configuration - call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & - "The minimum depth of the ocean.", units="m", default=0.0, scale=US%m_to_Z) - - call get_param(param_file, mdl, "SOUTHLAT", slat, & - "The southern latitude of the domain.", units="degrees") - call get_param(param_file, mdl, "LENLAT", lenlat, & - "The latitudinal length of the domain.", units="degrees") - call get_param(param_file, mdl, "WESTLON", wlon, & - "The western longitude of the domain.", units="degrees", default=0.0) - call get_param(param_file, mdl, "LENLON", lenlon, & - "The longitudinal length of the domain.", units="degrees") + ! Set up sponges for this configuration + ! call log_version(param_file, mdl, version) + + slat = G%south_lat + lenlat = G%len_lat + wlon = G%west_lon + lenlon = G%len_lon nlat = slat + lenlat do k=1,nz ; H0(k) = -G%max_depth * real(k-1) / real(nz) ; enddo ! Use for meridional thickness profile initialization -! do k=1,nz ; H0(k) = -G%max_depth * real(k-1) / real(nz-1) ; enddo + ! do k=1,nz ; H0(k) = -G%max_depth * real(k-1) / real(nz-1) ; enddo max_damping = 1.0 / (86400.0*US%s_to_T) + eta(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 + do j=js,je ; do i=is,ie - if (depth_tot(i,j) <= min_depth) then ; Idamp(i,j) = 0.0 + if (G%mask2dT(i,j) <= 0.0) then ; Idamp(i,j) = 0.0 elseif (G%geoLatT(i,j) < slat+2.0) then ; Idamp(i,j) = max_damping elseif (G%geoLatT(i,j) < slat+4.0) then Idamp(i,j) = max_damping * (slat+4.0-G%geoLatT(i,j))/2.0 @@ -141,16 +152,16 @@ subroutine BFB_initialize_sponges_southonly(G, GV, US, use_temperature, tv, dept ! depth space for Boussinesq or non-Boussinesq models. ! This section is used for uniform thickness initialization - do k = 1,nz; eta(i,j,k) = H0(k); enddo + do k=1,nz ; eta(i,j,k) = H0(k) ; enddo - ! The below section is used for meridional temperature profile thickness initiation - ! do k = 1,nz; eta(i,j,k) = H0(k); enddo + ! The below section is used for meridional temperature profile thickness initialization + ! do k=1,nz ; eta(i,j,k) = H0(k) ; enddo ! if (G%geoLatT(i,j) > 40.0) then ! do k = 1,nz ! eta(i,j,k) = -G%Angstrom_Z*(k-1) ! enddo ! elseif (G%geoLatT(i,j) > 20.0) then - ! do k = 1,nz + ! do k=1,nz ! eta(i,j,k) = min(H0(k) + (G%geoLatT(i,j) - 20.0)*(G%max_depth - nz*G%Angstrom_Z)/20.0, & ! -(k-1)*G%Angstrom_Z) ! enddo @@ -167,23 +178,6 @@ subroutine BFB_initialize_sponges_southonly(G, GV, US, use_temperature, tv, dept ! By default, momentum is advected vertically within the sponge, but ! ! momentum is typically not damped within the sponge. ! - if (first_call) call write_BFB_log(param_file) - end subroutine BFB_initialize_sponges_southonly -!> Write output about the parameter values being used. -subroutine write_BFB_log(param_file) - type(param_file_type), intent(in) :: param_file !< A structure indicating the - !! open file to parse for model - !! parameter values. - -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mdl = "BFB_initialization" ! This module's name. - - call log_version(param_file, mdl, version) - first_call = .false. - -end subroutine write_BFB_log - end module BFB_initialization diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index 6214f2d095..2472c1182c 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Surface forcing for the boundary-forced-basin (BFB) configuration module BFB_surface_forcing -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_diag_mediator, only : post_data, query_averaging_enabled use MOM_diag_mediator, only : register_diag_field, diag_ctrl use MOM_domains, only : pass_var, pass_vector, AGRID @@ -29,12 +31,17 @@ module BFB_surface_forcing real :: Rho0 !< The density used in the Boussinesq approximation [R ~> kg m-3]. real :: G_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] real :: Flux_const !< The restoring rate at the surface [Z T-1 ~> m s-1]. - real :: SST_s !< SST at the southern edge of the linear forcing ramp [degC] - real :: SST_n !< SST at the northern edge of the linear forcing ramp [degC] - real :: lfrslat !< Southern latitude where the linear forcing ramp begins [degLat] - real :: lfrnlat !< Northern latitude where the linear forcing ramp ends [degLat] - real :: drho_dt !< Rate of change of density with temperature [R degC-1 ~> kg m-3 degC-1]. - !! Note that temperature is being used as a dummy variable here. + real :: rho_restore !< The density that is used to convert piston velocities into salt + !! or heat fluxes with salinity or temperature restoring [R ~> kg m-3] + real :: SST_s !< SST at the southern edge of the linear forcing ramp [C ~> degC] + real :: SST_n !< SST at the northern edge of the linear forcing ramp [C ~> degC] + real :: S_ref !< Reference salinity used throughout the domain [S ~> ppt] + real :: lfrslat !< Southern latitude where the linear forcing ramp begins [degrees_N] or [km] + real :: lfrnlat !< Northern latitude where the linear forcing ramp ends [degrees_N] or [km] + real :: Rho_T0_S0 !< The density at T=0, S=0 [R ~> kg m-3] + real :: dRho_dT !< The partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: dRho_dS !< The partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] + !! Note that temperature and salinity are being used as dummy variables here. !! All temperatures are converted into density. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to @@ -59,12 +66,12 @@ subroutine BFB_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) !! returned by a previous call to !! BFB_surface_forcing_init. ! Local variables - real :: Temp_restore ! The temperature that is being restored toward [degC]. - real :: Salin_restore ! The salinity that is being restored toward [ppt]. + real :: Temp_restore ! The temperature that is being restored toward [C ~> degC]. + real :: Salin_restore ! The salinity that is being restored toward [S ~> ppt]. real :: density_restore ! The potential density that is being restored ! toward [R ~> kg m-3]. real :: rhoXcp ! Reference density times heat capacity times unit scaling - ! factors [Q R degC-1 ~> J m-3 degC-1] + ! factors [Q R C-1 ~> J m-3 degC-1] real :: buoy_rest_const ! A constant relating density anomalies to the ! restoring buoyancy flux [L2 T-3 R-1 ~> m5 s-3 kg-1]. integer :: i, j, is, ie, js, je @@ -125,16 +132,16 @@ subroutine BFB_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & "Temperature and salinity restoring used without modification." ) - rhoXcp = CS%Rho0 * fluxes%C_p + rhoXcp = CS%rho_restore * fluxes%C_p do j=js,je ; do i=is,ie - ! Set Temp_restore and Salin_restore to the temperature (in degC) and - ! salinity (in ppt) that are being restored toward. + ! Set Temp_restore and Salin_restore to the temperature (in [C ~> degC]) and + ! salinity (in [S ~> ppt]) that are being restored toward. Temp_restore = 0.0 Salin_restore = 0.0 fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & (Temp_restore - sfc_state%SST(i,j)) - fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & + fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%rho_restore*CS%Flux_const)) * & ((Salin_restore - sfc_state%SSS(i,j)) / (0.5 * (Salin_restore + sfc_state%SSS(i,j)))) enddo ; enddo else @@ -144,22 +151,21 @@ subroutine BFB_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! "Buoyancy restoring used without modification." ) ! The -1 is because density has the opposite sign to buoyancy. - buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%Rho0 + buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%rho_restore Temp_restore = 0.0 do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential ! density [R ~> kg m-3] that is being restored toward. if (G%geoLatT(i,j) < CS%lfrslat) then - Temp_restore = CS%SST_s + Temp_restore = CS%SST_s elseif (G%geoLatT(i,j) > CS%lfrnlat) then - Temp_restore = CS%SST_n + Temp_restore = CS%SST_n else - Temp_restore = (CS%SST_s - CS%SST_n)/(CS%lfrslat - CS%lfrnlat) * & - (G%geoLatT(i,j) - CS%lfrslat) + CS%SST_s + Temp_restore = (CS%SST_s - CS%SST_n)/(CS%lfrslat - CS%lfrnlat) * & + (G%geoLatT(i,j) - CS%lfrslat) + CS%SST_s endif - density_restore = Temp_restore*CS%drho_dt + CS%Rho0 - + density_restore = (CS%Rho_T0_S0 + CS%dRho_dS*CS%S_ref) + CS%dRho_dT*Temp_restore fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & (density_restore - sfc_state%sfc_density(i,j)) enddo ; enddo @@ -197,33 +203,41 @@ subroutine BFB_surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) + units="m s-2", default=9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& + "properties, or with BOUSSINESQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "LFR_SLAT", CS%lfrslat, & "Southern latitude where the linear forcing ramp begins.", & - units="degrees", default=20.0) + units=G%y_ax_unit_short, default=20.0) call get_param(param_file, mdl, "LFR_NLAT", CS%lfrnlat, & "Northern latitude where the linear forcing ramp ends.", & - units="degrees", default=40.0) + units=G%y_ax_unit_short, default=40.0) call get_param(param_file, mdl, "SST_S", CS%SST_s, & "SST at the southern edge of the linear forcing ramp.", & - units="C", default=20.0) + units="degC", default=20.0, scale=US%degC_to_C) call get_param(param_file, mdl, "SST_N", CS%SST_n, & "SST at the northern edge of the linear forcing ramp.", & - units="C", default=10.0) - call get_param(param_file, mdl, "DRHO_DT", CS%drho_dt, & - "The rate of change of density with temperature.", & - units="kg m-3 K-1", default=-0.2, scale=US%kg_m3_to_R) + units="degC", default=10.0, scale=US%degC_to_C) + call get_param(param_file, mdl, "DRHO_DT", CS%dRho_dT, & + "The partial derivative of density with temperature.", & + units="kg m-3 K-1", default=-0.2, scale=US%kg_m3_to_R*US%C_to_degC) + call get_param(param_file, mdl, "DRHO_DS", CS%dRho_dS, & + "The partial derivative of density with salinity.", & + units="kg m-3 PSU-1", default=0.8, scale=US%kg_m3_to_R*US%S_to_ppt) + call get_param(param_file, mdl, "RHO_T0_S0", CS%Rho_T0_S0, & + "The density at T=0, S=0.", units="kg m-3", default=1000.0, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "S_REF", CS%S_ref, & + "The reference salinity used here throughout the domain.", & + units="PSU", default=35.0, scale=US%ppt_to_S) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& "toward some specified surface state with a rate "//& - "given by FLUXCONST.", default= .false.) + "given by FLUXCONST.", default=.false.) if (CS%restorebuoy) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes to the relative "//& @@ -231,6 +245,11 @@ subroutine BFB_surface_forcing_init(Time, G, US, param_file, diag, CS) default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s) ! Convert CS%Flux_const from m day-1 to m s-1. CS%Flux_const = CS%Flux_const / 86400.0 + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", CS%rho_restore, & + "The density that is used to convert piston velocities into salt or heat "//& + "fluxes with RESTORE_SALINITY or RESTORE_TEMPERATURE.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=(CS%Flux_const==0.0)) endif end subroutine BFB_surface_forcing_init diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index 70b4bbc27d..96cb779eb5 100644 --- a/src/user/DOME2d_initialization.F90 +++ b/src/user/DOME2d_initialization.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Initialization of the 2D DOME experiment with density water initialized on a coastal shelf. module DOME2d_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_ALE_sponge, only : ALE_sponge_CS, set_up_ALE_sponge_field, initialize_ALE_sponge use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL @@ -13,7 +15,6 @@ module DOME2d_initialization use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type use regrid_consts, only : coordinateMode, DEFAULT_COORDINATE_MODE use regrid_consts, only : REGRIDDING_LAYER, REGRIDDING_ZSTAR use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA @@ -41,27 +42,31 @@ module DOME2d_initialization subroutine DOME2d_initialize_topography( D, G, param_file, max_depth ) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth in the units of depth_max + intent(out) :: D !< Ocean bottom depth [Z ~> m] type(param_file_type), intent(in) :: param_file !< Parameter file structure - real, intent(in) :: max_depth !< Maximum ocean depth in arbitrary units + real, intent(in) :: max_depth !< Maximum ocean depth [Z ~> m] ! Local variables + real :: bay_depth ! Depth of shelf, as fraction of basin depth [nondim] + real :: l1, l2 ! Fractional horizontal positions where the slope changes [nondim] + real :: x ! Fractional horizontal positions [nondim] + real :: dome2d_width_bay ! Width of shelf, as fraction of domain [nondim] + real :: dome2d_width_bottom ! Width of deep ocean basin, as fraction of domain [nondim] + real :: dome2d_depth_bay ! Depth of shelf, as fraction of basin depth [nondim] integer :: i, j - real :: x, bay_depth, l1, l2 - real :: dome2d_width_bay, dome2d_width_bottom, dome2d_depth_bay ! This include declares and sets the variable "version". # include "version_variable.h" call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "DOME2D_SHELF_WIDTH", dome2d_width_bay, & 'Width of shelf, as fraction of domain, in 2d DOME configuration.', & - units='nondim',default=0.1) + units='nondim', default=0.1) call get_param(param_file, mdl, "DOME2D_BASIN_WIDTH", dome2d_width_bottom, & 'Width of deep ocean basin, as fraction of domain, in 2d DOME configuration.', & - units='nondim',default=0.3) + units='nondim', default=0.3) call get_param(param_file, mdl, "DOME2D_SHELF_DEPTH", dome2d_depth_bay, & 'Depth of shelf, as fraction of basin depth, in 2d DOME configuration.', & - units='nondim',default=0.2) + units='nondim', default=0.2) ! location where downslope starts l1 = dome2d_width_bay @@ -95,7 +100,7 @@ subroutine DOME2d_initialize_thickness ( h, depth_tot, G, GV, US, param_file, ju 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(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file @@ -107,29 +112,30 @@ subroutine DOME2d_initialize_thickness ( h, depth_tot, G, GV, US, param_file, ju real :: e0(SZK_(GV)) ! The resting interface heights, in depth units [Z ~> m], usually ! negative because it is positive upward. real :: eta1D(SZK_(GV)+1)! Interface height relative to the sea surface - ! positive upward, in depth units [Z ~> m]. - integer :: i, j, k, is, ie, js, je, nz - real :: x - real :: delta_h - real :: min_thickness - real :: dome2d_width_bay, dome2d_width_bottom, dome2d_depth_bay + ! positive upward, in depth units [Z ~> m] + real :: x ! Fractional horizontal positions [nondim] + real :: min_thickness ! Minimum layer thicknesses [Z ~> m] + real :: dome2d_width_bay ! Width of shelf, as fraction of domain [nondim] + real :: dome2d_width_bottom ! Width of deep ocean basin, as fraction of domain [nondim] + real :: dome2d_depth_bay ! Depth of shelf, as fraction of basin depth [nondim] character(len=40) :: verticalCoordinate + integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not.just_read) & call MOM_mesg("MOM_initialization.F90, DOME2d_initialize_thickness: setting thickness") - call get_param(param_file, mdl,"MIN_THICKNESS",min_thickness, & + call get_param(param_file, mdl,"MIN_THICKNESS", min_thickness, & default=1.e-3, units="m", do_not_log=.true., scale=US%m_to_Z) call get_param(param_file, mdl,"REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=.true.) call get_param(param_file, mdl, "DOME2D_SHELF_WIDTH", dome2d_width_bay, & - default=0.1, do_not_log=.true.) + units="nondim", default=0.1, do_not_log=.true.) call get_param(param_file, mdl, "DOME2D_BASIN_WIDTH", dome2d_width_bottom, & - default=0.3, do_not_log=.true.) + units="nondim", default=0.3, do_not_log=.true.) call get_param(param_file, mdl, "DOME2D_SHELF_DEPTH", dome2d_depth_bay, & - default=0.2, do_not_log=.true.) + units="nondim", default=0.2, do_not_log=.true.) if (just_read) return ! All run-time parameters have been read, so return. @@ -154,16 +160,16 @@ subroutine DOME2d_initialize_thickness ( h, depth_tot, G, GV, US, param_file, ju eta1D(k) = e0(k) if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_Z)) then eta1D(k) = eta1D(k+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + h(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + h(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon if ( x <= dome2d_width_bay ) then - h(i,j,1:nz-1) = GV%Angstrom_H - h(i,j,nz) = GV%Z_to_H * dome2d_depth_bay * G%max_depth - (nz-1) * GV%Angstrom_H + h(i,j,1:nz-1) = GV%Angstrom_Z + h(i,j,nz) = dome2d_depth_bay * G%max_depth - (nz-1) * GV%Angstrom_Z endif enddo ; enddo @@ -176,16 +182,16 @@ subroutine DOME2d_initialize_thickness ( h, depth_tot, G, GV, US, param_file, ju ! eta1D(k) = e0(k) ! if (eta1D(k) < (eta1D(k+1) + min_thickness)) then ! eta1D(k) = eta1D(k+1) + min_thickness - ! h(i,j,k) = GV%Z_to_H * min_thickness + ! h(i,j,k) = min_thickness ! else - ! h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + ! h(i,j,k) = eta1D(k) - eta1D(k+1) ! endif ! enddo ! ! x = G%geoLonT(i,j) / G%len_lon ! if ( x <= dome2d_width_bay ) then - ! h(i,j,1:nz-1) = GV%Z_to_H * min_thickness - ! h(i,j,nz) = GV%Z_to_H * (dome2d_depth_bay * G%max_depth - (nz-1) * min_thickness) + ! h(i,j,1:nz-1) = min_thickness + ! h(i,j,nz) = dome2d_depth_bay * G%max_depth - (nz-1) * min_thickness ! endif ! ! enddo ; enddo @@ -198,16 +204,16 @@ subroutine DOME2d_initialize_thickness ( h, depth_tot, G, GV, US, param_file, ju eta1D(k) = e0(k) if (eta1D(k) < (eta1D(k+1) + min_thickness)) then eta1D(k) = eta1D(k+1) + min_thickness - h(i,j,k) = GV%Z_to_H * min_thickness + h(i,j,k) = min_thickness else - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + h(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo enddo ; enddo case ( REGRIDDING_SIGMA ) do j=js,je ; do i=is,ie - h(i,j,:) = GV%Z_to_H*depth_tot(i,j) / nz + h(i,j,:) = depth_tot(i,j) / nz enddo ; enddo case default @@ -220,44 +226,54 @@ end subroutine DOME2d_initialize_thickness !> Initialize temperature and salinity in the 2d DOME configuration -subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, just_read) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure +subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [ppt] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [Z ~> m] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file structure logical, intent(in) :: just_read !< If true, this call will !! only read parameters without changing T & S. - integer :: i, j, k, is, ie, js, je, nz - real :: x - integer :: index_bay_z - real :: delta_S, delta_T - real :: S_ref, T_ref ! Reference salinity and temperature within surface layer - real :: S_range, T_range ! Range of salinities and temperatures over the vertical - real :: xi0, xi1 + real :: x ! Fractional horizontal positions [nondim] + real :: delta_S ! Change in salinity between layers [S ~> ppt] + real :: S_ref, T_ref ! Reference salinity [S ~> ppt] and temperature [C ~> degC] within surface layer + real :: S_range, T_range ! Range of salinities [S ~> ppt] and temperatures [C ~> degC] over the vertical + real :: S_surf ! Initial surface salinity [S ~> ppt] + real :: T_bay ! Temperature in the inflow embayment [C ~> degC] + real :: xi0, xi1 ! Fractional vertical positions [nondim] + real :: dome2d_width_bay ! Width of shelf, as fraction of domain [nondim] + real :: dome2d_width_bottom ! Width of deep ocean basin, as fraction of domain [nondim] + real :: dome2d_depth_bay ! Depth of shelf, as fraction of basin depth [nondim] character(len=40) :: verticalCoordinate - real :: dome2d_width_bay, dome2d_width_bottom, dome2d_depth_bay + integer :: index_bay_z + integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - call get_param(param_file, mdl,"REGRIDDING_COORDINATE_MODE", verticalCoordinate, & + call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=.true.) call get_param(param_file, mdl, "DOME2D_SHELF_WIDTH", dome2d_width_bay, & - default=0.1, do_not_log=.true.) + units="nondim", default=0.1, do_not_log=.true.) call get_param(param_file, mdl, "DOME2D_BASIN_WIDTH", dome2d_width_bottom, & - default=0.3, do_not_log=.true.) + units="nondim", default=0.3, do_not_log=.true.) call get_param(param_file, mdl, "DOME2D_SHELF_DEPTH", dome2d_depth_bay, & - default=0.2, do_not_log=.true.) + units="nondim", default=0.2, do_not_log=.true.) call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & - default=35.0, units='1e-3', do_not_log=just_read) - call get_param(param_file, mdl,"T_REF",T_ref,'Reference temperature', units='degC', & - fail_if_missing=.not.just_read, do_not_log=just_read) - call get_param(param_file, mdl,"S_RANGE",S_range,'Initial salinity range', & - units='1e-3', default=2.0, do_not_log=just_read) - call get_param(param_file, mdl,"T_RANGE",T_range,'Initial temperature range', & - units='1e-3', default=0.0, do_not_log=just_read) + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "T_REF", T_ref, 'Reference temperature', & + units='degC', scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "S_RANGE", S_range,' Initial salinity range', & + units="ppt", default=2.0, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & + units='degC', default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "INITIAL_SSS", S_surf, "Initial surface salinity", & + units="ppt", default=34.0, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "DOME2D_T_BAY", T_bay, & + "Temperature in the inflow embayment in the DOME2d test case", & + units="degC", default=1.0, scale=US%degC_to_C, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -273,8 +289,8 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, do j=js,je ; do i=is,ie xi0 = 0.0 do k = 1,nz - xi1 = xi0 + (GV%H_to_Z * h(i,j,k)) / G%max_depth - S(i,j,k) = 34.0 + 0.5 * S_range * (xi0 + xi1) + xi1 = xi0 + h(i,j,k) / G%max_depth + S(i,j,k) = S_surf + 0.5 * S_range * (xi0 + xi1) xi0 = xi1 enddo enddo ; enddo @@ -284,13 +300,13 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, do j=js,je ; do i=is,ie xi0 = 0.0 do k = 1,nz - xi1 = xi0 + (GV%H_to_Z * h(i,j,k)) / G%max_depth - S(i,j,k) = 34.0 + 0.5 * S_range * (xi0 + xi1) + xi1 = xi0 + h(i,j,k) / G%max_depth + S(i,j,k) = S_surf + 0.5 * S_range * (xi0 + xi1) xi0 = xi1 enddo x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon if ( x <= dome2d_width_bay ) then - S(i,j,nz) = 34.0 + S_range + S(i,j,nz) = S_surf + S_range endif enddo ; enddo @@ -314,8 +330,8 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, do j = G%jsc,G%jec ; do i = G%isc,G%iec x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon if ( x <= dome2d_width_bay ) then - S(i,j,1:index_bay_z) = S_ref + S_range; ! Use for z coordinates - T(i,j,1:index_bay_z) = 1.0; ! Use for z coordinates + S(i,j,1:index_bay_z) = S_ref + S_range ! Use for z coordinates + T(i,j,1:index_bay_z) = T_bay ! Use for z coordinates endif enddo ; enddo ! i and j loops endif ! Z initial conditions @@ -325,20 +341,19 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, do i = G%isc,G%iec ; do j = G%jsc,G%jec x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon if ( x <= dome2d_width_bay ) then - S(i,j,1:GV%ke) = S_ref + S_range; ! Use for sigma coordinates - T(i,j,1:GV%ke) = 1.0; ! Use for sigma coordinates + S(i,j,1:GV%ke) = S_ref + S_range ! Use for sigma coordinates + T(i,j,1:GV%ke) = T_bay ! Use for sigma coordinates endif enddo ; enddo endif ! Modify temperature when rho coordinates are used - T(G%isc:G%iec,G%jsc:G%jec,1:GV%ke) = 0.0 if (( coordinateMode(verticalCoordinate) == REGRIDDING_RHO ) .or. & ( coordinateMode(verticalCoordinate) == REGRIDDING_LAYER )) then do i = G%isc,G%iec ; do j = G%jsc,G%jec x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon if ( x <= dome2d_width_bay ) then - T(i,j,GV%ke) = 1.0 + T(i,j,GV%ke) = T_bay endif enddo ; enddo endif @@ -358,24 +373,32 @@ subroutine DOME2d_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use_A type(sponge_CS), pointer :: CSp !< Layer-mode sponge structure type(ALE_sponge_CS), pointer :: ACSp !< ALE-mode sponge structure ! Local variables - real :: T(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for temp [degC] - real :: S(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for salt [ppt] - real :: h(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for thickness [H ~> m or kg m-2]. + real :: T(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for temp [C ~> degC] + real :: S(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for salt [S ~> ppt] + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for thickness in height units [Z ~> m] real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! A temporary array for interface heights [Z ~> m] real :: Idamp(SZI_(G),SZJ_(G)) ! The sponge damping rate [T-1 ~> s-1] - real :: S_ref ! Reference salinity within the surface layer [ppt] - real :: T_ref ! Reference temerature within the surface layer [degC] - real :: S_range ! Range of salinities in the vertical [ppt] - real :: T_range ! Range of temperatures in the vertical [degC] + real :: S_ref ! Reference salinity within the surface layer [S ~> ppt] + real :: T_ref ! Reference temperature within the surface layer [C ~> degC] + real :: S_range ! Range of salinities in the vertical [S ~> ppt] + real :: T_range ! Range of temperatures in the vertical [C ~> degC] + real :: S_range_sponge ! Range of salinities in the vertical in the east sponge [S ~> ppt] + real :: S_surf ! Initial surface salinity [S ~> ppt] real :: e0(SZK_(GV)+1) ! The resting interface heights [Z ~> m], ! usually negative because it is positive upward. real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface ! positive upward [Z ~> m]. real :: d_eta(SZK_(GV)) ! The layer thickness in a column [Z ~> m]. - real :: dome2d_width_bay, dome2d_width_bottom, dome2d_depth_bay + real :: dome2d_width_bay ! Width of shelf, as fraction of domain [nondim] + real :: dome2d_width_bottom ! Width of deep ocean basin, as fraction of domain [nondim] + real :: dome2d_depth_bay ! Depth of shelf, as fraction of basin depth [nondim] real :: dome2d_west_sponge_time_scale, dome2d_east_sponge_time_scale ! Sponge timescales [T ~> s] - real :: dome2d_west_sponge_width, dome2d_east_sponge_width - real :: dummy1, x, z + real :: dome2d_west_sponge_width ! The fraction of the domain in which the western sponge for + ! restoring T/S is active [nondim] + real :: dome2d_east_sponge_width ! The fraction of the domain in which the eastern sponge for + ! restoring T/S is active [nondim] + real :: dummy1, x ! Nondimensional local variables indicating horizontal positions [nondim] + real :: z ! Vertical positions [Z ~> m] integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -407,16 +430,20 @@ subroutine DOME2d_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use_A "DOME2d_initialize_sponges called with an associated ALE-sponge control structure.") call get_param(param_file, mdl, "DOME2D_SHELF_WIDTH", dome2d_width_bay, & - default=0.1, do_not_log=.true.) + units="nondim", default=0.1, do_not_log=.true.) call get_param(param_file, mdl, "DOME2D_BASIN_WIDTH", dome2d_width_bottom, & - default=0.3, do_not_log=.true.) + units="nondim", default=0.3, do_not_log=.true.) call get_param(param_file, mdl, "DOME2D_SHELF_DEPTH", dome2d_depth_bay, & - default=0.2, do_not_log=.true.) - call get_param(param_file, mdl, "S_REF", S_ref, default=35.0) - call get_param(param_file, mdl, "T_REF", T_ref) - call get_param(param_file, mdl, "S_RANGE", S_range, default=2.0) - call get_param(param_file, mdl, "T_RANGE", T_range, default=0.0) - + units="nondim", default=0.2, do_not_log=.true.) + call get_param(param_file, mdl, "S_REF", S_ref, units="ppt", default=35.0, scale=US%ppt_to_S) + call get_param(param_file, mdl, "T_REF", T_ref, units="degC", scale=US%degC_to_C, fail_if_missing=.false.) + call get_param(param_file, mdl, "S_RANGE", S_range, units="ppt", default=2.0, scale=US%ppt_to_S) + call get_param(param_file, mdl, "T_RANGE", T_range, units="degC", default=0.0, scale=US%degC_to_C) + call get_param(param_file, mdl, "INITIAL_SSS", S_surf, "Initial surface salinity", & + units="ppt", default=34.0, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "DOME2D_EAST_SPONGE_S_RANGE", S_range_sponge, & + "Range of salinities in the eastern sponge region in the DOME2D configuration", & + units="ppt", default=1.0, scale=US%ppt_to_S) ! Set the sponge damping rate as a function of position Idamp(:,:) = 0.0 @@ -439,10 +466,9 @@ subroutine DOME2d_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use_A endif enddo ; enddo - if (use_ALE) then - ! Construct a grid (somewhat arbitrarily) to describe the sponge T/S on + ! Construct a grid (somewhat arbitrarily) to describe the sponge T/S on do k=1,nz e0(k) = -G%max_depth * ( real(k-1) / real(nz) ) enddo @@ -453,34 +479,35 @@ subroutine DOME2d_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use_A eta1D(k) = e0(k) if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_Z)) then eta1D(k) = eta1D(k+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + dz(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + dz(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo enddo ; enddo - ! Store the grid on which the T/S sponge data will reside - call initialize_ALE_sponge(Idamp, G, GV, param_file, ACSp, h, nz) ! Construct temperature and salinity on the arbitrary grid T(:,:,:) = 0.0 ; S(:,:,:) = 0.0 do j=js,je ; do i=is,ie z = -depth_tot(i,j) do k = nz,1,-1 - z = z + 0.5 * GV%H_to_Z * h(i,j,k) ! Position of the center of layer k - S(i,j,k) = 34.0 - 1.0 * (z / (G%max_depth)) + z = z + 0.5 * dz(i,j,k) ! Position of the center of layer k + ! Use salinity stratification in the eastern sponge. + S(i,j,k) = S_surf - S_range_sponge * (z / G%max_depth) + ! Use a constant salinity in the western sponge. if ( ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon < dome2d_west_sponge_width ) & S(i,j,k) = S_ref + S_range - z = z + 0.5 * GV%H_to_Z * h(i,j,k) ! Position of the interface k + z = z + 0.5 * dz(i,j,k) ! Position of the interface k enddo enddo ; enddo - if ( associated(tv%T) ) then - call set_up_ALE_sponge_field(T, G, GV, tv%T, ACSp) - endif - if ( associated(tv%S) ) then - call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp) - endif + ! Store damping rates and the grid on which the T/S sponge data will reside + call initialize_ALE_sponge(Idamp, G, GV, param_file, ACSp, dz, nz, data_h_is_Z=.true.) + + if ( associated(tv%T) ) call set_up_ALE_sponge_field(T, G, GV, tv%T, ACSp, 'temp', & + sp_long_name='temperature', sp_unit='degC s-1') + if ( associated(tv%S) ) call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp, 'salt', & + sp_long_name='salinity', sp_unit='g kg-1 s-1') else diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index 248bf6c0f0..3603555856 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -1,23 +1,25 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Configures the model for the "DOME" experiment. !! DOME = Dynamics of Overflows and Mixing Experiment module DOME_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type -use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE use MOM_open_boundary, only : OBC_segment_type, register_segment_tracer use MOM_tracer_registry, only : tracer_registry_type, tracer_type use MOM_tracer_registry, only : tracer_name_lookup use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type +use MOM_EOS, only : calculate_density, calculate_density_derivs implicit none ; private @@ -46,7 +48,14 @@ subroutine DOME_initialize_topography(D, G, param_file, max_depth, US) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables - real :: min_depth ! The minimum and maximum depths [Z ~> m]. + real :: min_depth ! The minimum ocean depth [Z ~> m] + real :: shelf_depth ! The ocean depth on the shelf in the DOME configuration [Z ~> m] + real :: slope ! The bottom slope in the DOME configuration [Z L-1 ~> nondim] + real :: shelf_edge_lat ! The latitude of the edge of the topographic shelf in the same units as geolat, often [km] + real :: inflow_lon ! The edge longitude of the DOME inflow in the same units as geolon, often [km] + real :: inflow_width ! The longitudinal width of the DOME inflow channel in the same units as geolat, often [km] + real :: km_to_grid_unit ! The conversion factor from km to the units of latitude often 1 [nondim], + ! but this could be 1000 [m km-1] ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "DOME_initialize_topography" ! This subroutine's name. @@ -54,22 +63,43 @@ subroutine DOME_initialize_topography(D, G, param_file, max_depth, US) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + if (G%grid_unit_to_L <= 0.) call MOM_error(FATAL, "DOME_initialization: "//& + "DOME_initialize_topography is only set to work with Cartesian axis units.") + if (abs(G%grid_unit_to_L*US%L_to_m - 1000.0) < 1.0e-3) then ! The grid latitudes are in km. + km_to_grid_unit = 1.0 + elseif (abs(G%grid_unit_to_L*US%L_to_m - 1.0) < 1.0e-6) then ! The grid latitudes are in m. + km_to_grid_unit = 1000.0 + else + call MOM_error(FATAL, "DOME_initialization: "//& + "DOME_initialize_topography is not recognizing the value of G%grid_unit_to_L.") + endif + call MOM_mesg(" DOME_initialization.F90, DOME_initialize_topography: setting topography", 5) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & - "The minimum depth of the ocean.", units="m", default=0.0, scale=US%m_to_Z) + "The minimum depth of the ocean.", default=0.0, units="m", scale=US%m_to_Z) + call get_param(param_file, mdl, "DOME_TOPOG_SLOPE", slope, & + "The slope of the bottom topography in the DOME configuration.", & + default=0.01, units="nondim", scale=US%L_to_Z) + call get_param(param_file, mdl, "DOME_SHELF_DEPTH", shelf_depth, & + "The bottom depth in the shelf inflow region in the DOME configuration.", & + default=600.0, units="m", scale=US%m_to_Z) + call get_param(param_file, mdl, "DOME_SHELF_EDGE_LAT", shelf_edge_lat, & + "The latitude of the shelf edge in the DOME configuration.", & + default=600.0, units="km", scale=km_to_grid_unit) + call get_param(param_file, mdl, "DOME_INFLOW_LON", inflow_lon, & + "The edge longitude of the DOME inflow.", units="km", default=1000.0, scale=km_to_grid_unit) + call get_param(param_file, mdl, "DOME_INFLOW_WIDTH", inflow_width, & + "The longitudinal width of the DOME inflow channel.", & + units="km", default=100.0, scale=km_to_grid_unit) do j=js,je ; do i=is,ie - if (G%geoLatT(i,j) < 600.0) then - if (G%geoLatT(i,j) < 300.0) then - D(i,j) = max_depth - else - D(i,j) = max_depth - 10.0*US%m_to_Z * (G%geoLatT(i,j)-300.0) - endif + if (G%geoLatT(i,j) < shelf_edge_lat) then + D(i,j) = min(shelf_depth - slope * (G%geoLatT(i,j)-shelf_edge_lat)*G%grid_unit_to_L, max_depth) else - if ((G%geoLonT(i,j) > 1000.0) .AND. (G%geoLonT(i,j) < 1100.0)) then - D(i,j) = 600.0*US%m_to_Z + if ((G%geoLonT(i,j) > inflow_lon) .AND. (G%geoLonT(i,j) < inflow_lon+inflow_width)) then + D(i,j) = shelf_depth else D(i,j) = 0.5*min_depth endif @@ -88,7 +118,7 @@ subroutine DOME_initialize_thickness(h, depth_tot, G, GV, param_file, just_read) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file @@ -100,7 +130,6 @@ subroutine DOME_initialize_thickness(h, depth_tot, G, GV, param_file, just_read) ! negative because it is positive upward [Z ~> m]. real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface ! positive upward [Z ~> m]. - character(len=40) :: mdl = "DOME_initialize_thickness" ! This subroutine's name. integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -125,9 +154,9 @@ subroutine DOME_initialize_thickness(h, depth_tot, G, GV, param_file, just_read) eta1D(K) = e0(K) if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_Z)) then eta1D(K) = eta1D(K+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + h(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H * (eta1D(K) - eta1D(K+1)) + h(i,j,k) = eta1D(K) - eta1D(K+1) endif enddo enddo ; enddo @@ -159,29 +188,36 @@ subroutine DOME_initialize_sponges(G, GV, US, tv, depth_tot, PF, CSp) real :: e_tgt(SZK_(GV)+1) ! Target interface heights [Z ~> m]. real :: min_depth ! The minimum depth at which to apply damping [Z ~> m] - real :: damp_W, damp_E ! Damping rates in the western and eastern sponges [days-1] - real :: peak_damping ! The maximum sponge damping rates as the edges [days-1] - real :: edge_dist ! The distance to an edge, in the same units as longitude [km] - real :: sponge_width ! The width of the sponges, in the same units as longitude [km] - real :: e_dense ! The depth of the densest interfaces [Z ~> m] + real :: damp_W, damp_E ! Damping rates in the western and eastern sponges [T-1 ~> s-1] + real :: peak_damping ! The maximum sponge damping rates as the edges [T-1 ~> s-1] + real :: edge_dist ! The distance to an edge [L ~> m] + real :: sponge_width ! The width of the sponges [L ~> m] character(len=40) :: mdl = "DOME_initialize_sponges" ! This subroutine's name. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz 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 + if (G%grid_unit_to_L <= 0.) call MOM_error(FATAL, "DOME_initialization: "//& + "DOME_initialize_sponges is only set to work with Cartesian axis units.") + ! Set up sponges for the DOME configuration call get_param(PF, mdl, "MINIMUM_DEPTH", min_depth, & "The minimum depth of the ocean.", units="m", default=0.0, scale=US%m_to_Z) + call get_param(PF, mdl, "DOME_SPONGE_DAMP_RATE", peak_damping, & + "The largest damping rate in the DOME sponges.", & + default=10.0, units="day-1", scale=1.0/(86400.0*US%s_to_T)) + call get_param(PF, mdl, "DOME_SPONGE_WIDTH", sponge_width, & + "The width of the DOME sponges.", & + default=200.0, units="km", scale=1.0e3*US%m_to_L) ! Here the inverse damping time [T-1 ~> s-1], is set. Set Idamp to 0 wherever ! there is no sponge, and the subroutines that are called will automatically ! set up the sponges only where Idamp is positive and mask2dT is 1. - peak_damping = 10.0 ! The maximum sponge damping rate in [days-1] - sponge_width = 200.0 ! The width of the sponges [km] + Idamp(:,:) = 0.0 do j=js,je ; do i=is,ie ; if (depth_tot(i,j) > min_depth) then - edge_dist = G%geoLonT(i,j) - G%west_lon + edge_dist = (G%geoLonT(i,j) - G%west_lon) * G%grid_unit_to_L if (edge_dist < 0.5*sponge_width) then damp_W = peak_damping elseif (edge_dist < sponge_width) then @@ -190,7 +226,7 @@ subroutine DOME_initialize_sponges(G, GV, US, tv, depth_tot, PF, CSp) damp_W = 0.0 endif - edge_dist = (G%len_lon + G%west_lon) - G%geoLonT(i,j) + edge_dist = ((G%len_lon + G%west_lon) - G%geoLonT(i,j)) * G%grid_unit_to_L if (edge_dist < 0.5*sponge_width) then damp_E = peak_damping elseif (edge_dist < sponge_width) then @@ -199,7 +235,7 @@ subroutine DOME_initialize_sponges(G, GV, US, tv, depth_tot, PF, CSp) damp_E = 0.0 endif - Idamp(i,j) = max(damp_W, damp_E) / (86400.0 * US%s_to_T) + Idamp(i,j) = max(damp_W, damp_E) endif ; enddo ; enddo e_tgt(1) = 0.0 @@ -225,8 +261,8 @@ subroutine DOME_initialize_sponges(G, GV, US, tv, depth_tot, PF, CSp) ! The remaining calls to set_up_sponge_field can be in any order. if ( associated(tv%T) ) then temp(:,:,:) = 0.0 - call MOM_error(FATAL,"DOME_initialize_sponges is not set up for use with"//& - " a temperatures defined.") + call MOM_error(FATAL, "DOME_initialize_sponges is not set up for use with "//& + "temperatures defined.") ! This should use the target values of T in temp. call set_up_sponge_field(temp, tv%T, G, GV, nz, CSp) ! This should use the target values of S in temp. @@ -236,7 +272,7 @@ subroutine DOME_initialize_sponges(G, GV, US, tv, depth_tot, PF, CSp) end subroutine DOME_initialize_sponges !> Add DOME to the OBC registry and set up some variables that will be used to guide -!! code setting up the restart fieldss related to the OBCs. +!! code setting up the restart fields related to the OBCs. subroutine register_DOME_OBC(param_file, US, OBC, tr_Reg) type(param_file_type), intent(in) :: param_file !< parameter file. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -261,7 +297,7 @@ end subroutine register_DOME_OBC !> This subroutine sets the properties of flow at open boundary conditions. !! This particular example is for the DOME inflow describe in Legg et al. 2006. -subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) +subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tr_Reg) type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies !! whether, where, and what open boundary !! conditions are used. @@ -272,17 +308,19 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + type(param_file_type), intent(in) :: PF !< A structure indicating the open file !! to parse for model parameter values. type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry. ! Local variables - real :: T0(SZK_(GV)) ! A profile of target temperatures [degC] - real :: S0(SZK_(GV)) ! A profile of target salinities [ppt] + real :: T0(SZK_(GV)) ! A profile of target temperatures [C ~> degC] + real :: S0(SZK_(GV)) ! A profile of target salinities [S ~> ppt] real :: pres(SZK_(GV)) ! An array of the reference pressure [R L2 T-2 ~> Pa]. - real :: drho_dT(SZK_(GV)) ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. - real :: drho_dS(SZK_(GV)) ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. + real :: drho_dT(SZK_(GV)) ! Derivative of density with temperature [R C-1 ~> kg m-3 degC-1]. + real :: drho_dS(SZK_(GV)) ! Derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. real :: rho_guess(SZK_(GV)) ! Potential density at T0 & S0 [R ~> kg m-3]. + real :: S_ref ! A default value for salinities [S ~> ppt] + real :: T_light ! A first guess at the temperature of the lightest layer [C ~> degC] ! The following variables are used to set up the transport in the DOME example. real :: tr_0 ! The total integrated inflow transport [H L2 T-1 ~> m3 s-1 or kg s-1] real :: tr_k ! The integrated inflow transport of a layer [H L2 T-1 ~> m3 s-1 or kg s-1] @@ -296,14 +334,22 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) ! v-velocity face, in the same units as G%geoLon [km] real :: D_edge ! The thickness [Z ~> m] of the dense fluid at the ! inner edge of the inflow + real :: RLay_range ! The range of densities [R ~> kg m-3]. + real :: Rlay_Ref ! The surface layer's target density [R ~> kg m-3]. + real :: f_0 ! The reference value of the Coriolis parameter [T-1 ~> s-1] + real :: f_inflow ! The value of the Coriolis parameter used to determine DOME inflow + ! properties [T-1 ~> s-1] real :: g_prime_tot ! The reduced gravity across all layers [L2 Z-1 T-2 ~> m s-2] - real :: Def_Rad ! The deformation radius, based on fluid of thickness D_edge, - ! in the same units as G%geoLon [km] + real :: Def_Rad ! The deformation radius, based on fluid of thickness D_edge [L ~> m] + real :: inflow_lon ! The edge longitude of the DOME inflow in the same units as geolon, often [km] + real :: I_Def_Rad ! The inverse of the deformation radius in the same units as G%geoLon [km-1] real :: Ri_trans ! The shear Richardson number in the transition ! region of the specified shear profile [nondim] - character(len=40) :: mdl = "DOME_set_OBC_data" ! This subroutine's name. + real :: km_to_grid_unit ! The conversion factor from km to the units of latitude often 1 [nondim], + ! but this could be 1000 [m km-1] character(len=32) :: name ! The name of a tracer field. - integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, m, nz, ntherm + character(len=40) :: mdl = "DOME_set_OBC_data" ! This subroutine's name. + integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, m, nz, ntherm, ntr_id integer :: IsdB, IedB, JsdB, JedB type(OBC_segment_type), pointer :: segment => NULL() type(tracer_type), pointer :: tr_ptr => NULL() @@ -312,16 +358,60 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - ! The following variables should be transformed into runtime parameters. - D_edge = 300.0*US%m_to_Z ! The thickness of dense fluid in the inflow. - Ri_trans = 1.0/3.0 ! The shear Richardson number in the transition region - ! region of the specified shear profile. + if (G%grid_unit_to_L <= 0.) call MOM_error(FATAL, "DOME_initialization: "//& + "DOME_initialize_topography is only set to work with Cartesian axis units.") + if (abs(G%grid_unit_to_L*US%L_to_m - 1000.0) < 1.0e-3) then ! The grid latitudes are in km. + km_to_grid_unit = 1.0 + elseif (abs(G%grid_unit_to_L*US%L_to_m - 1.0) < 1.0e-6) then ! The grid latitudes are in m. + km_to_grid_unit = 1000.0 + else + call MOM_error(FATAL, "DOME_initialization: "//& + "DOME_initialize_topography is not recognizing the value of G%grid_unit_to_L.") + endif + + call get_param(PF, mdl, "DOME_INFLOW_THICKNESS", D_edge, & + "The thickness of the dense DOME inflow at the inner edge.", & + default=300.0, units="m", scale=US%m_to_Z) + call get_param(PF, mdl, "DOME_INFLOW_RI_TRANS", Ri_trans, & + "The shear Richardson number in the transition region of the specified "//& + "DOME inflow shear profile.", default=(1.0/3.0), units="nondim") + call get_param(PF, mdl, "DENSITY_RANGE", Rlay_range, & + "The range of reference potential densities in the layers.", & + units="kg m-3", default=2.0, scale=US%kg_m3_to_R) + call get_param(PF, mdl, "LIGHTEST_DENSITY", Rlay_Ref, & + "The reference potential density used for layer 1.", & + units="kg m-3", default=US%R_to_kg_m3*GV%Rho0, scale=US%kg_m3_to_R) + call get_param(PF, mdl, "F_0", f_0, & + "The reference value of the Coriolis parameter with the betaplane option.", & + units="s-1", default=0.0, scale=US%T_to_s) + call get_param(PF, mdl, "DOME_INFLOW_F", f_inflow, & + "The value of the Coriolis parameter that is used to determine the DOME "//& + "inflow properties.", units="s-1", default=f_0*US%s_to_T, scale=US%T_to_s) + call get_param(PF, mdl, "DOME_INFLOW_LON", inflow_lon, & + "The edge longitude of the DOME inflow.", units="km", default=1000.0, scale=km_to_grid_unit) + if (associated(tv%S) .or. associated(tv%T)) then + call get_param(PF, mdl, "S_REF", S_ref, & + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(PF, mdl, "DOME_T_LIGHT", T_light, & + "A first guess at the temperature of the lightest layer in the DOME test case.", & + units="degC", default=25.0, scale=US%degC_to_C) + endif if (.not.associated(OBC)) return - g_prime_tot = (GV%g_Earth / GV%Rho0) * 2.0*US%kg_m3_to_R - Def_Rad = US%L_to_m*sqrt(D_edge*g_prime_tot) / (1.0e-4*US%T_to_s * 1000.0) - tr_0 = (-D_edge*sqrt(D_edge*g_prime_tot)*0.5e3*US%m_to_L*Def_Rad) * GV%Z_to_H + if (GV%Boussinesq) then + g_prime_tot = (GV%g_Earth / GV%Rho0) * Rlay_range + Def_Rad = sqrt(D_edge*g_prime_tot) / abs(f_inflow) + tr_0 = (-D_edge*sqrt(D_edge*g_prime_tot)*0.5*Def_Rad) * GV%Z_to_H + else + g_prime_tot = (GV%g_Earth / (Rlay_Ref + 0.5*Rlay_range)) * Rlay_range + Def_Rad = sqrt(D_edge*g_prime_tot) / abs(f_inflow) + tr_0 = (-D_edge*sqrt(D_edge*g_prime_tot)*0.5*Def_Rad) * (Rlay_Ref + 0.5*Rlay_range) * GV%RZ_to_H + endif + + I_Def_Rad = 1.0 / ((1.0e-3*US%L_to_m*km_to_grid_unit) * Def_Rad) + ! This is mathematically equivalent to + ! I_Def_Rad = G%grid_unit_to_L / Def_Rad if (OBC%number_of_segments /= 1) then call MOM_error(WARNING, 'Error in DOME OBC segment setup', .true.) @@ -361,25 +451,25 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) ! Here lon_im1 estimates G%geoLonBu(I-1,J), which may not have been set if ! the symmetric memory mode is not being used. lon_im1 = 2.0*G%geoLonCv(i,J) - G%geoLonBu(I,J) - segment%normal_trans(i,J,k) = tr_k * (exp(-2.0*(lon_im1 - 1000.0)/Def_Rad) -& - exp(-2.0*(G%geoLonBu(I,J) - 1000.0)/Def_Rad)) - segment%normal_vel(i,J,k) = v_k * exp(-2.0*(G%geoLonCv(i,J) - 1000.0)/Def_Rad) + segment%normal_trans(i,J,k) = tr_k * (exp(-2.0*(lon_im1 - inflow_lon) * I_Def_Rad) - & + exp(-2.0*(G%geoLonBu(I,J) - inflow_lon) * I_Def_Rad)) + segment%normal_vel(i,J,k) = v_k * exp(-2.0*(G%geoLonCv(i,J) - inflow_lon) * I_Def_Rad) enddo ; enddo enddo ! The inflow values of temperature and salinity also need to be set here if ! these variables are used. The following code is just a naive example. if (associated(tv%S)) then - ! In this example, all S inflows have values of 35 psu. + ! In this example, all S inflows have values given by S_ref. name = 'salt' - call tracer_name_lookup(tr_Reg, tr_ptr, name) - call register_segment_tracer(tr_ptr, param_file, GV, segment, OBC_scalar=35.0) + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) + call register_segment_tracer(tr_ptr, ntr_id, PF, GV, segment, OBC_scalar=S_ref, scale=US%ppt_to_S) endif if (associated(tv%T)) then ! In this example, the T values are set to be consistent with the layer - ! target density and a salinity of 35 psu. This code is taken from + ! target density and a salinity of S_ref. This code is taken from ! USER_initialize_temp_sal. - pres(:) = tv%P_Ref ; S0(:) = 35.0 ; T0(1) = 25.0 + pres(:) = tv%P_Ref ; S0(:) = S_ref ; T0(1) = T_light call calculate_density(T0(1), S0(1), pres(1), rho_guess(1), tv%eqn_of_state) call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, tv%eqn_of_state, (/1,1/) ) @@ -393,11 +483,12 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) ! Temperature is tracer 1 for the OBCs. allocate(segment%field(1)%buffer_src(segment%HI%isd:segment%HI%ied,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied + ! With the revised OBC code, buffer_src uses the same rescaled units as for tracers. segment%field(1)%buffer_src(i,j,k) = T0(k) enddo ; enddo ; enddo name = 'temp' - call tracer_name_lookup(tr_Reg, tr_ptr, name) - call register_segment_tracer(tr_ptr, param_file, GV, segment, OBC_array=.true.) + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) + call register_segment_tracer(tr_ptr, ntr_id, PF, GV, segment, OBC_array=.true., scale=US%degC_to_C) endif ! Set up dye tracers @@ -409,16 +500,15 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) else ; segment%field(ntherm+1)%buffer_src(i,j,k) = 1.0 ; endif enddo ; enddo ; enddo name = 'tr_D1' - call tracer_name_lookup(tr_Reg, tr_ptr, name) - call register_segment_tracer(tr_ptr, param_file, GV, OBC%segment(1), OBC_array=.true.) + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) + call register_segment_tracer(tr_ptr, ntr_id, PF, GV, OBC%segment(1), OBC_array=.true.) ! All tracers but the first have 0 concentration in their inflows. As 0 is the ! default value for the inflow concentrations, the following calls are unnecessary. do m=2,tr_Reg%ntr - if (m < 10) then ; write(name,'("tr_D",I1.1)') m - else ; write(name,'("tr_D",I2.2)') m ; endif - call tracer_name_lookup(tr_Reg, tr_ptr, name) - call register_segment_tracer(tr_ptr, param_file, GV, OBC%segment(1), OBC_scalar=0.0) + write(name,'("tr_D",I0)') m + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) + call register_segment_tracer(tr_ptr, ntr_id, PF, GV, OBC%segment(1), OBC_scalar=0.0) enddo end subroutine DOME_set_OBC_data diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index 2ebac05a68..d0697a2e49 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Configures the ISOMIP test case. module ISOMIP_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_ALE_sponge, only : ALE_sponge_CS, set_up_ALE_sponge_field, initialize_ALE_sponge use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge use MOM_dyn_horgrid, only : dyn_horgrid_type @@ -42,26 +44,26 @@ module ISOMIP_initialization subroutine ISOMIP_initialize_topography(D, G, param_file, max_depth, US) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth [m ~> Z] + intent(out) :: D !< Ocean bottom depth [Z ~> m] type(param_file_type), intent(in) :: param_file !< Parameter file structure - real, intent(in) :: max_depth !< Maximum model depth [m ~> Z] + real, intent(in) :: max_depth !< Maximum model depth [Z ~> m] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables - real :: min_depth ! The minimum and maximum depths [Z ~> m]. + real :: min_depth ! The minimum depth of the ocean [Z ~> m]. ! The following variables are used to set up the bathymetry in the ISOMIP example. - real :: bmax ! max depth of bedrock topography [Z ~> m] - real :: b0,b2,b4,b6 ! first, second, third and fourth bedrock topography coeffs [Z ~> m] - real :: xbar ! characteristic along-flow length scale of the bedrock + real :: bmax ! maximum depth of bedrock topography [Z ~> m] + real :: b0, b2, b4, b6 ! first, second, third and fourth bedrock topography coeffs [Z ~> m] + real :: xbar ! characteristic along-flow length scale of the bedrock [L ~> m] real :: dc ! depth of the trough compared with side walls [Z ~> m]. - real :: fc ! characteristic width of the side walls of the channel - real :: wc ! half-width of the trough - real :: ly ! domain width (across ice flow) - real :: bx, by ! dummy vatiables [Z ~> m]. - real :: xtil ! dummy vatiable - logical :: is_2D ! If true, use 2D setup -! This include declares and sets the variable "version". -#include "version_variable.h" + real :: fc ! characteristic width of the side walls of the channel [L ~> m] + real :: wc ! half-width of the trough [L ~> m] + real :: ly ! domain width (across ice flow) [L ~> m] + real :: bx, by ! The x- and y- contributions to the bathymetric profiles at a point [Z ~> m] + real :: xtil ! x-positon normalized by the characteristic along-flow length scale [nondim] + logical :: is_2D ! If true, use a 2D setup + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "ISOMIP_initialize_topography" ! This subroutine's name. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -72,27 +74,40 @@ subroutine ISOMIP_initialize_topography(D, G, param_file, max_depth, US) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & "The minimum depth of the ocean.", units="m", default=0.0, scale=US%m_to_Z) - call get_param(param_file, mdl, "ISOMIP_2D",is_2D,'If true, use a 2D setup.', default=.false.) - - ! The following variables should be transformed into runtime parameters? - bmax = 720.0*US%m_to_Z ; dc = 500.0*US%m_to_Z + call get_param(param_file, mdl, "ISOMIP_2D", is_2D, 'If true, use a 2D setup.', default=.false.) + call get_param(param_file, mdl, "ISOMIP_MAX_BEDROCK", bmax, & + "Maximum depth of bedrock topography in the ISOMIP configuration.", & + units="m", default=720.0, scale=US%m_to_Z) + call get_param(param_file, mdl, "ISOMIP_TROUGH_DEPTH", dc, & + "Depth of the trough compared with side walls in the ISOMIP configuration.", & + units="m", default=500.0, scale=US%m_to_Z) + call get_param(param_file, mdl, "ISOMIP_BEDROCK_LENGTH", xbar, & + "Characteristic along-flow length scale of the bedrock in the ISOMIP configuration.", & + units="m", default=300.0e3, scale=US%m_to_L) + call get_param(param_file, mdl, "ISOMIP_TROUGH_WIDTH", wc, & + "Half-width of the trough in the ISOMIP configuration.", & + units="m", default=24.0e3, scale=US%m_to_L) + call get_param(param_file, mdl, "ISOMIP_DOMAIN_WIDTH", ly, & + "Domain width (across ice flow) in the ISOMIP configuration.", & + units="m", default=80.0e3, scale=US%m_to_L) + call get_param(param_file, mdl, "ISOMIP_SIDE_WIDTH", fc, & + "Characteristic width of the side walls of the channel in the ISOMIP configuration.", & + units="m", default=4.0e3, scale=US%m_to_L) + + if (G%grid_unit_to_L <= 0.) call MOM_error(FATAL, "ISOMIP_initialization.F90: " //& + "ISOMIP_initialize_topography is only set to work with Cartesian axis units.") + + ! The following variables should be transformed into runtime parameters. b0 = -150.0*US%m_to_Z ; b2 = -728.8*US%m_to_Z ; b4 = 343.91*US%m_to_Z ; b6 = -50.57*US%m_to_Z - xbar = 300.0e3 ; fc = 4.0e3 ; wc = 24.0e3 ; ly = 80.0e3 - bx = 0.0 ; by = 0.0 ; xtil = 0.0 - if (is_2D) then do j=js,je ; do i=is,ie - ! 2D setup - xtil = G%geoLonT(i,j)*1.0e3/xbar - !xtil = 450*1.0e3/xbar + ! For the 2D setup take a slice through the middle of the domain + xtil = G%geoLonT(i,j)*G%grid_unit_to_L / xbar + ! xtil = 450.0e3*US%m_to_L / xbar bx = b0 + b2*xtil**2 + b4*xtil**4 + b6*xtil**6 - !by = (dc/(1.+exp(-2.*(G%geoLatT(i,j)*1.0e3- ly/2. - wc)/fc))) + & - ! (dc/(1.+exp(2.*(G%geoLatT(i,j)*1.0e3- ly/2. + wc)/fc))) - ! slice at y = 40 km - by = (dc / (1.+exp(-2.*(40.0*1.0e3- ly/2. - wc)/fc))) + & - (dc / (1.+exp(2.*(40.0*1.0e3- ly/2. + wc)/fc))) + by = 2.0 * dc / (1.0 + exp(2.0*wc / fc)) D(i,j) = -max(bx+by, -bmax) if (D(i,j) > max_depth) D(i,j) = max_depth @@ -104,17 +119,17 @@ subroutine ISOMIP_initialize_topography(D, G, param_file, max_depth, US) ! 3D setup ! ===== TEST ===== !if (G%geoLonT(i,j)<500.) then - ! xtil = 500.*1.0e3/xbar + ! xtil = 500.0e3*US%m_to_L / xbar !else - ! xtil = G%geoLonT(i,j)*1.0e3/xbar + ! xtil = G%geoLonT(i,j)*G%grid_unit_to_L / xbar !endif ! ===== TEST ===== - xtil = G%geoLonT(i,j)*1.0e3/xbar + xtil = G%geoLonT(i,j)*G%grid_unit_to_L / xbar bx = b0 + b2*xtil**2 + b4*xtil**4 + b6*xtil**6 - by = (dc / (1.+exp(-2.*(G%geoLatT(i,j)*1.0e3- ly/2. - wc)/fc))) + & - (dc / (1.+exp(2.*(G%geoLatT(i,j)*1.0e3- ly/2. + wc)/fc))) + by = (dc / (1.0 + exp(-2.*(G%geoLatT(i,j)*G%grid_unit_to_L - 0.5*ly - wc) / fc))) + & + (dc / (1.0 + exp(2.*(G%geoLatT(i,j)*G%grid_unit_to_L - 0.5*ly + wc) / fc))) D(i,j) = -max(bx+by, -bmax) if (D(i,j) > max_depth) D(i,j) = max_depth @@ -130,11 +145,10 @@ subroutine ISOMIP_initialize_thickness ( h, depth_tot, G, GV, US, param_file, tv type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] - type(param_file_type), intent(in) :: param_file !< A structure indicating the open file - !! to parse for model parameter values. + type(param_file_type), intent(in) :: param_file !< A structure to parse for model parameter values type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any !! available thermodynamic fields, including !! the eqn. of state. @@ -145,18 +159,19 @@ subroutine ISOMIP_initialize_thickness ( h, depth_tot, G, GV, US, param_file, tv ! usually negative because it is positive upward. real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface ! positive upward, in depth units [Z ~> m]. - integer :: i, j, k, is, ie, js, je, nz, tmp1 - real :: x - real :: min_thickness, s_sur, s_bot, t_sur, t_bot + integer :: i, j, k, is, ie, js, je, nz + real :: min_thickness ! Minimum layer thicknesses [Z ~> m] + real :: S_sur, S_bot ! Surface and bottom salinities [S ~> ppt] + real :: T_sur, T_bot ! Surface and bottom temperatures [C ~> degC] real :: rho_sur, rho_bot ! Surface and bottom densities [R ~> kg m-3] real :: rho_range ! The range of densities [R ~> kg m-3] - character(len=256) :: mesg ! The text of an error message + !character(len=256) :: mesg ! The text of an error message character(len=40) :: verticalCoordinate is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not.just_read) & - call MOM_mesg("MOM_initialization.F90, initialize_thickness_uniform: setting thickness") + call MOM_mesg("ISOMIP_initialization.F90, ISOMIP_initialize_thickness: setting thickness") call get_param(param_file, mdl,"MIN_THICKNESS", min_thickness, & 'Minimum layer thickness', units='m', default=1.e-3, do_not_log=just_read, scale=US%m_to_Z) @@ -167,21 +182,25 @@ subroutine ISOMIP_initialize_thickness ( h, depth_tot, G, GV, US, param_file, tv case ( REGRIDDING_LAYER, REGRIDDING_RHO ) ! Initial thicknesses for isopycnal coordinates call get_param(param_file, mdl, "ISOMIP_T_SUR", t_sur, & - "Temperature at the surface (interface)", units="degC", default=-1.9, do_not_log=just_read) + "Temperature at the surface (interface)", & + units="degC", default=-1.9, scale=US%degC_to_C, do_not_log=just_read) call get_param(param_file, mdl, "ISOMIP_S_SUR", s_sur, & - "Salinity at the surface (interface)", units="ppt", default=33.8, do_not_log=just_read) + "Salinity at the surface (interface)", & + units="ppt", default=33.8, scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "ISOMIP_T_BOT", t_bot, & - "Temperature at the bottom (interface)", units="degC", default=-1.9, do_not_log=just_read) - call get_param(param_file, mdl, "ISOMIP_S_BOT", s_bot,& - "Salinity at the bottom (interface)", units="ppt", default=34.55, do_not_log=just_read) + "Temperature at the bottom (interface)", & + units="degC", default=-1.9, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "ISOMIP_S_BOT", s_bot, & + "Salinity at the bottom (interface)", & + units="ppt", default=34.55, scale=US%ppt_to_S, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. ! Compute min/max density using T_SUR/S_SUR and T_BOT/S_BOT - call calculate_density(t_sur, s_sur, 0.0, rho_sur, tv%eqn_of_state) + call calculate_density(T_sur, S_sur, 0.0, rho_sur, tv%eqn_of_state) ! write(mesg,*) 'Surface density is:', rho_sur ! call MOM_mesg(mesg,5) - call calculate_density(t_bot, s_bot, 0.0, rho_bot, tv%eqn_of_state) + call calculate_density(T_bot, S_bot, 0.0, rho_bot, tv%eqn_of_state) ! write(mesg,*) 'Bottom density is:', rho_bot ! call MOM_mesg(mesg,5) rho_range = rho_bot - rho_sur @@ -207,9 +226,9 @@ subroutine ISOMIP_initialize_thickness ( h, depth_tot, G, GV, US, param_file, tv eta1D(k) = e0(k) if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_Z)) then eta1D(k) = eta1D(k+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + h(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + h(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo enddo ; enddo @@ -222,9 +241,9 @@ subroutine ISOMIP_initialize_thickness ( h, depth_tot, G, GV, US, param_file, tv eta1D(k) = -G%max_depth * real(k-1) / real(nz) if (eta1D(k) < (eta1D(k+1) + min_thickness)) then eta1D(k) = eta1D(k+1) + min_thickness - h(i,j,k) = GV%Z_to_H * min_thickness + h(i,j,k) = min_thickness else - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + h(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo enddo ; enddo @@ -232,7 +251,7 @@ subroutine ISOMIP_initialize_thickness ( h, depth_tot, G, GV, US, param_file, tv case ( REGRIDDING_SIGMA ) ! Initial thicknesses for sigma coordinates if (just_read) return ! All run-time parameters have been read, so return. do j=js,je ; do i=is,ie - h(i,j,:) = GV%Z_to_H * depth_tot(i,j) / dfloat(nz) + h(i,j,:) = depth_tot(i,j) / real(nz) enddo ; enddo case default @@ -249,9 +268,9 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, depth_tot, G, GV, U type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [ppt] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), intent(in) :: depth_tot !< The nominal total bottom-to-top !! depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< Parameter file structure @@ -259,46 +278,50 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, depth_tot, G, GV, U logical, intent(in) :: just_read !< If true, this call will !! only read parameters without changing T & S. ! Local variables - integer :: i, j, k, is, ie, js, je, nz, itt - real :: x, ds, dt real :: rho_sur, rho_bot ! Surface and bottom densities [R ~> kg m-3] real :: xi0, xi1 ! Heights in depth units [Z ~> m]. - real :: S_sur, S_bot ! Salinity at the surface and bottom [ppt] - real :: T_sur, T_bot ! Temperature at the bottom [degC] - real :: dT_dz ! Vertical gradient of temperature [degC Z-1 ~> degC m-1]. - real :: dS_dz ! Vertical gradient of salinity [ppt Z-1 ~> ppt m-1]. - real :: z ! vertical position in z space [Z ~> m] - character(len=256) :: mesg ! The text of an error message - character(len=40) :: verticalCoordinate, density_profile - real :: rho_tmp - logical :: fit_salin ! If true, accept the prescribed temperature and fit the salinity. - real :: T0(SZK_(GV)) ! A profile of temperatures [degC] - real :: S0(SZK_(GV)) ! A profile of salinities [ppt] - real :: drho_dT(SZK_(GV)) ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. - real :: drho_dS(SZK_(GV)) ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. + real :: S_sur, S_bot ! Salinity at the surface and bottom [S ~> ppt] + real :: T_sur, T_bot ! Temperature at the surface and bottom [C ~> degC] + real :: dT_dz ! Vertical gradient of temperature [C Z-1 ~> degC m-1]. + real :: dS_dz ! Vertical gradient of salinity [S Z-1 ~> ppt m-1]. + real :: T0(SZK_(GV)) ! A profile of temperatures [C ~> degC] + real :: S0(SZK_(GV)) ! A profile of salinities [S ~> ppt] + real :: drho_dT(SZK_(GV)) ! Derivative of density with temperature [R C-1 ~> kg m-3 degC-1]. + real :: drho_dS(SZK_(GV)) ! Derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. real :: rho_guess(SZK_(GV)) ! Potential density at T0 & S0 [R ~> kg m-3]. real :: pres(SZK_(GV)) ! An array of the reference pressure [R L2 T-2 ~> Pa]. (zero here) - real :: drho_dT1 ! A prescribed derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] - real :: drho_dS1 ! A prescribed derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. - real :: T_Ref, S_Ref + real :: drho_dT1 ! A prescribed derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: drho_dS1 ! A prescribed derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. + real :: T_ref ! Default value for other temperatures [C ~> degC] + real :: S_ref ! Default value for other salinities [S ~> ppt] + logical :: fit_salin ! If true, accept the prescribed temperature and fit the salinity. + !real :: rho_tmp ! A temporary density used for debugging [R ~> kg m-3] + !character(len=256) :: mesg ! The text of an error message + character(len=40) :: verticalCoordinate + integer :: i, j, k, is, ie, js, je, nz, itt + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke pres(:) = 0.0 call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) call get_param(param_file, mdl, "ISOMIP_T_SUR",t_sur, & - "Temperature at the surface (interface)", units="degC", default=-1.9, do_not_log=just_read) + "Temperature at the surface (interface)", & + units="degC", default=-1.9, scale=US%degC_to_C, do_not_log=just_read) call get_param(param_file, mdl, "ISOMIP_S_SUR", s_sur, & - "Salinity at the surface (interface)", units="ppt", default=33.8, do_not_log=just_read) + "Salinity at the surface (interface)", & + units="ppt", default=33.8, scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "ISOMIP_T_BOT", t_bot, & - "Temperature at the bottom (interface)", units="degC", default=-1.9, do_not_log=just_read) + "Temperature at the bottom (interface)", & + units="degC", default=-1.9, scale=US%degC_to_C, do_not_log=just_read) call get_param(param_file, mdl, "ISOMIP_S_BOT", s_bot, & - "Salinity at the bottom (interface)", units="ppt", default=34.55, do_not_log=just_read) + "Salinity at the bottom (interface)", & + units="ppt", default=34.55, scale=US%ppt_to_S, do_not_log=just_read) - call calculate_density(t_sur, s_sur, 0.0, rho_sur, eqn_of_state) + call calculate_density(T_sur, S_sur, 0.0, rho_sur, eqn_of_state) ! write(mesg,*) 'Density in the surface layer:', rho_sur ! call MOM_mesg(mesg,5) - call calculate_density(t_bot, s_bot, 0.0, rho_bot, eqn_of_state) + call calculate_density(T_bot, S_bot, 0.0, rho_bot, eqn_of_state) ! write(mesg,*) 'Density in the bottom layer::', rho_bot ! call MOM_mesg(mesg,5) @@ -307,15 +330,15 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, depth_tot, G, GV, U case ( REGRIDDING_RHO, REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_SIGMA ) if (just_read) return ! All run-time parameters have been read, so return. - dS_dz = (s_sur - s_bot) / G%max_depth - dT_dz = (t_sur - t_bot) / G%max_depth + dS_dz = (S_sur - S_bot) / G%max_depth + dT_dz = (T_sur - T_bot) / G%max_depth do j=js,je ; do i=is,ie xi0 = -depth_tot(i,j) do k = nz,1,-1 - xi0 = xi0 + 0.5 * h(i,j,k) * GV%H_to_Z ! Depth in middle of layer + xi0 = xi0 + 0.5 * h(i,j,k) ! Depth in middle of layer S(i,j,k) = S_sur + dS_dz * xi0 T(i,j,k) = T_sur + dT_dz * xi0 - xi0 = xi0 + 0.5 * h(i,j,k) * GV%H_to_Z ! Depth at top of layer + xi0 = xi0 + 0.5 * h(i,j,k) ! Depth at top of layer enddo enddo ; enddo @@ -326,32 +349,34 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, depth_tot, G, GV, U default=.false., do_not_log=just_read) call get_param(param_file, mdl, "DRHO_DS", drho_dS1, & "Partial derivative of density with salinity.", & - units="kg m-3 PSU-1", scale=US%kg_m3_to_R, fail_if_missing=.not.just_read, do_not_log=just_read) + units="kg m-3 ppt-1", scale=US%kg_m3_to_R*US%S_to_ppt, & + fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "DRHO_DT", drho_dT1, & "Partial derivative of density with temperature.", & - units="kg m-3 K-1", scale=US%kg_m3_to_R, fail_if_missing=.not.just_read, do_not_log=just_read) + units="kg m-3 K-1", scale=US%kg_m3_to_R*US%C_to_degC, & + fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "T_REF", T_Ref, & "A reference temperature used in initialization.", & - units="degC", fail_if_missing=.not.just_read, do_not_log=just_read) + units="degC", scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "S_REF", S_Ref, & - "A reference salinity used in initialization.", units="PSU", & - default=35.0, do_not_log=just_read) + "A reference salinity used in initialization.", & + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. ! write(mesg,*) 'read drho_dS, drho_dT', drho_dS1, drho_dT1 ! call MOM_mesg(mesg,5) - dS_dz = (s_sur - s_bot) / G%max_depth - dT_dz = (t_sur - t_bot) / G%max_depth + dS_dz = (S_sur - S_bot) / G%max_depth + dT_dz = (T_sur - T_bot) / G%max_depth do j=js,je ; do i=is,ie xi0 = 0.0 do k = 1,nz - !T0(k) = T_Ref; S0(k) = S_Ref - xi1 = xi0 + 0.5 * h(i,j,k) * GV%H_to_Z + !T0(k) = T_Ref ; S0(k) = S_Ref + xi1 = xi0 + 0.5 * h(i,j,k) S0(k) = S_sur - dS_dz * xi1 T0(k) = T_sur - dT_dz * xi1 - xi0 = xi0 + h(i,j,k) * GV%H_to_Z + xi0 = xi0 + h(i,j,k) ! write(mesg,*) 'S,T,xi0,xi1,k',S0(k),T0(k),xi0,xi1,k ! call MOM_mesg(mesg,5) enddo @@ -403,55 +428,56 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, depth_tot, G, GV, U end select ! for debugging - !i=G%iec; j=G%jec + !i = G%iec ; j = G%jec !do k = 1,nz - ! call calculate_density(T(i,j,k),S(i,j,k),0.0,rho_tmp,eqn_of_state, scale=US%kg_m3_to_R) - ! write(mesg,*) 'k,h,T,S,rho,Rlay',k,h(i,j,k),T(i,j,k),S(i,j,k),rho_tmp,GV%Rlay(k) + ! call calculate_density(T(i,j,k), S(i,j,k),0.0,rho_tmp,eqn_of_state, scale=US%kg_m3_to_R) + ! write(mesg,*) 'k,h,T,S,rho,Rlay',k,US%Z_to_m*h(i,j,k),US%C_to_degC*T(i,j,k),US%S_to_ppt*S(i,j,k),rho_tmp,GV%Rlay(k) ! call MOM_mesg(mesg,5) !enddo end subroutine ISOMIP_initialize_temperature_salinity -!> Sets up the the inverse restoration time (Idamp), and -! the values towards which the interface heights and an arbitrary -! number of tracers should be restored within each sponge. +!> Sets up the inverse restoration time (Idamp), and +!! the values towards which the interface heights and an arbitrary +!! number of tracers should be restored within each sponge. subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, ACSp) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers - !! to any available thermodynamic - !! fields, potential temperature and - !! salinity or mixed layer density. - !! Absent fields have NULL ptrs. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available + !! thermodynamic fields, potential temperature and + !! salinity or mixed layer density. + !! Absent fields have NULL ptrs. real, dimension(SZI_(G),SZJ_(G)), & - intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] - type(param_file_type), intent(in) :: PF !< A structure indicating the - !! open file to parse for model - !! parameter values. - logical, intent(in) :: use_ALE !< If true, indicates model is in ALE mode - type(sponge_CS), pointer :: CSp !< Layer-mode sponge structure - type(ALE_sponge_CS), pointer :: ACSp !< ALE-mode sponge structure + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: PF !< A structure to parse for model parameter values + logical, intent(in) :: use_ALE !< If true, indicates model is in ALE mode + type(sponge_CS), pointer :: CSp !< Layer-mode sponge structure + type(ALE_sponge_CS), pointer :: ACSp !< ALE-mode sponge structure ! Local variables - real :: T(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for temp [degC] - real :: S(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for salt [ppt] + real :: T(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for temp [C ~> degC] + real :: S(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for salt [S ~> ppt] ! real :: RHO(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for RHO [R ~> kg m-3] - real :: h(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for thickness [H ~> m or kg m-2] + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Sponge layer thicknesses in height units [Z ~> m] real :: Idamp(SZI_(G),SZJ_(G)) ! The sponge damping rate [T-1 ~> s-1] real :: TNUDG ! Nudging time scale [T ~> s] - real :: S_sur, T_sur ! Surface salinity and temerature in sponge - real :: S_bot, T_bot ! Bottom salinity and temerature in sponge - real :: t_ref, s_ref ! reference T and S + real :: S_sur, S_bot ! Surface and bottom salinities in the sponge region [S ~> ppt] + real :: T_sur, T_bot ! Surface and bottom temperatures in the sponge region [C ~> degC] + real :: T_ref ! Default value for other temperatures [C ~> degC] + real :: S_ref ! Default value for other salinities [S ~> ppt] real :: rho_sur, rho_bot ! Surface and bottom densities [R ~> kg m-3] real :: rho_range ! The range of densities [R ~> kg m-3] - real :: dT_dz, dS_dz ! Gradients of T and S in degC/Z and PPT/Z. + real :: dT_dz ! Vertical gradient of temperature [C Z-1 ~> degC m-1] + real :: dS_dz ! Vertical gradient of salinity [S Z-1 ~> ppt m-1] real :: e0(SZK_(GV)+1) ! The resting interface heights [Z ~> m], usually ! negative because it is positive upward. real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface, positive upward [Z ~> m]. real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! A temporary array for interface heights [Z ~> m]. - real :: min_depth, dummy1, z - real :: rho_dummy, min_thickness, rho_tmp, xi0 + real :: min_depth ! The minimum depth of the ocean [Z ~> m] + real :: min_thickness ! The minimum layer thickness [Z ~> m] + real :: xi0 ! Interface heights in depth units [Z ~> m], usually negative. + !real :: rho_tmp ! A temporary density used for debugging [R ~> kg m-3] character(len=40) :: verticalCoordinate, filename, state_file character(len=40) :: temp_var, salt_var, eta_var, inputdir @@ -467,26 +493,30 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, call get_param(PF, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE) - call get_param(PF, mdl, "ISOMIP_TNUDG", TNUDG, "Nudging time scale for sponge layers (days)", & - default=0.0, scale=86400.0*US%s_to_T) + call get_param(PF, mdl, "ISOMIP_TNUDG", TNUDG, "Nudging time scale for sponge layers", & + units="days", default=0.0, scale=86400.0*US%s_to_T) - call get_param(PF, mdl, "T_REF", t_ref, "Reference temperature", default=10.0, & - do_not_log=.true.) + call get_param(PF, mdl, "T_REF", T_ref, "Reference temperature", & + units="degC", default=10.0, scale=US%degC_to_C, do_not_log=.true.) - call get_param(PF, mdl, "S_REF", s_ref, "Reference salinity", default=35.0, & - do_not_log=.true.) + call get_param(PF, mdl, "S_REF", s_ref, "Reference salinity", & + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=.true.) call get_param(PF, mdl, "ISOMIP_S_SUR_SPONGE", s_sur, & - "Surface salinity in sponge layer.", units="ppt", default=s_ref) ! units="ppt") + "Surface salinity in sponge layer.", & + units="ppt", default=US%S_to_ppt*S_ref, scale=US%ppt_to_S) call get_param(PF, mdl, "ISOMIP_S_BOT_SPONGE", s_bot, & - "Bottom salinity in sponge layer.", units="ppt", default=s_ref) ! units="ppt") + "Bottom salinity in sponge layer.", & + units="ppt", default=US%S_to_ppt*S_ref, scale=US%ppt_to_S) call get_param(PF, mdl, "ISOMIP_T_SUR_SPONGE", t_sur, & - "Surface temperature in sponge layer.", units="degC", default=t_ref) ! units="degC") + "Surface temperature in sponge layer.", & + units="degC", default=US%C_to_degC*T_ref, scale=US%degC_to_C) call get_param(PF, mdl, "ISOMIP_T_BOT_SPONGE", t_bot, & - "Bottom temperature in sponge layer.", units="degC", default=t_ref) ! units="degC") + "Bottom temperature in sponge layer.", & + units="degC", default=US%C_to_degC*T_ref, scale=US%degC_to_C) T(:,:,:) = 0.0 ; S(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 !; RHO(:,:,:) = 0.0 @@ -508,8 +538,7 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, if (depth_tot(i,j) <= min_depth) then Idamp(i,j) = 0.0 elseif (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then - dummy1 = (G%geoLonT(i,j)-790.0)/(800.0-790.0) - Idamp(i,j) = (1.0/TNUDG) * max(0.0,dummy1) + Idamp(i,j) = (1.0/TNUDG) * max(0.0, (G%geoLonT(i,j)-790.0) / (800.0-790.0)) else Idamp(i,j) = 0.0 endif @@ -517,10 +546,10 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, enddo ; enddo ! Compute min/max density using T_SUR/S_SUR and T_BOT/S_BOT - call calculate_density(t_sur, s_sur, 0.0, rho_sur, tv%eqn_of_state) + call calculate_density(T_sur, S_sur, 0.0, rho_sur, tv%eqn_of_state) !write (mesg,*) 'Surface density in sponge:', rho_sur ! call MOM_mesg(mesg,5) - call calculate_density(t_bot, s_bot, 0.0, rho_bot, tv%eqn_of_state) + call calculate_density(T_bot, S_bot, 0.0, rho_bot, tv%eqn_of_state) !write (mesg,*) 'Bottom density in sponge:', rho_bot ! call MOM_mesg(mesg,5) rho_range = rho_bot - rho_sur @@ -551,9 +580,9 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, eta1D(k) = e0(k) if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_Z)) then eta1D(k) = eta1D(k+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + dz(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H*(eta1D(k) - eta1D(k+1)) + dz(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo enddo ; enddo @@ -565,16 +594,16 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, eta1D(k) = -G%max_depth * real(k-1) / real(nz) if (eta1D(k) < (eta1D(k+1) + min_thickness)) then eta1D(k) = eta1D(k+1) + min_thickness - h(i,j,k) = min_thickness * GV%Z_to_H + dz(i,j,k) = min_thickness else - h(i,j,k) = GV%Z_to_H*(eta1D(k) - eta1D(k+1)) + dz(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo enddo ; enddo case ( REGRIDDING_SIGMA ) ! Initial thicknesses for sigma coordinates do j=js,je ; do i=is,ie - h(i,j,:) = GV%Z_to_H * (depth_tot(i,j) / dfloat(nz)) + dz(i,j,:) = depth_tot(i,j) / real(nz) enddo ; enddo case default @@ -583,40 +612,39 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, end select - ! This call sets up the damping rates and interface heights. - ! This sets the inverse damping timescale fields in the sponges. - call initialize_ALE_sponge(Idamp, G, GV, PF, ACSp, h, nz) - - dS_dz = (s_sur - s_bot) / G%max_depth - dT_dz = (t_sur - t_bot) / G%max_depth + dS_dz = (S_sur - S_bot) / G%max_depth + dT_dz = (T_sur - T_bot) / G%max_depth do j=js,je ; do i=is,ie xi0 = -depth_tot(i,j) do k = nz,1,-1 - xi0 = xi0 + 0.5 * h(i,j,k) * GV%H_to_Z ! Depth in middle of layer + xi0 = xi0 + 0.5 * dz(i,j,k) ! Depth in middle of layer S(i,j,k) = S_sur + dS_dz * xi0 T(i,j,k) = T_sur + dT_dz * xi0 - xi0 = xi0 + 0.5 * h(i,j,k) * GV%H_to_Z ! Depth at top of layer + xi0 = xi0 + 0.5 * dz(i,j,k) ! Depth at top of layer enddo enddo ; enddo + ! for debugging - !i=G%iec; j=G%jec + !i = G%iec ; j = G%jec !do k = 1,nz - ! call calculate_density(T(i,j,k),S(i,j,k),0.0,rho_tmp,tv%eqn_of_state, scale=US%kg_m3_to_R) + ! call calculate_density(T(i,j,k), S(i,j,k), 0.0, rho_tmp, tv%eqn_of_state, scale=US%kg_m3_to_R) ! write(mesg,*) 'Sponge - k,h,T,S,rho,Rlay',k,h(i,j,k),T(i,j,k),S(i,j,k),rho_tmp,GV%Rlay(k) ! call MOM_mesg(mesg,5) !enddo + ! This call sets up the damping rates and interface heights in the sponges. + call initialize_ALE_sponge(Idamp, G, GV, PF, ACSp, dz, nz, data_h_is_Z=.true.) + ! Now register all of the fields which are damped in the sponge. ! ! By default, momentum is advected vertically within the sponge, but ! ! momentum is typically not damped within the sponge. ! ! The remaining calls to set_up_sponge_field can be in any order. ! - if ( associated(tv%T) ) then - call set_up_ALE_sponge_field(T, G, GV, tv%T, ACSp) - endif - if ( associated(tv%S) ) then - call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp) - endif + if ( associated(tv%T) ) call set_up_ALE_sponge_field(T, G, GV, tv%T, ACSp, 'temp', & + sp_long_name='temperature', sp_unit='degC s-1') + if ( associated(tv%S) ) call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp, 'salt', & + sp_long_name='salinity', sp_unit='g kg-1 s-1') + else ! layer mode ! 1) Read eta, salt and temp from IC file @@ -645,13 +673,13 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & "ISOMIP_initialize_sponges: Unable to open "//trim(filename)) call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain, scale=US%m_to_Z) - call MOM_read_data(filename, temp_var, T(:,:,:), G%Domain) - call MOM_read_data(filename, salt_var, S(:,:,:), G%Domain) + call MOM_read_data(filename, temp_var, T(:,:,:), G%Domain, scale=US%degC_to_C) + call MOM_read_data(filename, salt_var, S(:,:,:), G%Domain, scale=US%ppt_to_S) ! for debugging - !i=G%iec; j=G%jec + !i = G%iec ; j = G%jec !do k = 1,nz - ! call calculate_density(T(i,j,k),S(i,j,k),0.0,rho_tmp,tv%eqn_of_state, scale=US%kg_m3_to_R) + ! call calculate_density(T(i,j,k), S(i,j,k), 0.0, rho_tmp, tv%eqn_of_state, scale=US%kg_m3_to_R) ! write(mesg,*) 'Sponge - k,eta,T,S,rho,Rlay',k,eta(i,j,k),T(i,j,k),& ! S(i,j,k),rho_tmp,GV%Rlay(k) ! call MOM_mesg(mesg,5) diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 index 707a0972f9..9e83849a2c 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Forcing for the idealized hurricane and SCM_idealized_hurricane examples. module Idealized_hurricane -! This file is part of MOM6. See LICENSE.md for the license. - ! History !-------- ! November 2014: Origination. @@ -13,19 +15,16 @@ module Idealized_hurricane ! The T/S initializations have been removed since they are redundant ! w/ T/S initializations in CVMix_tests (which should be moved ! into the main state_initialization to their utility -! for multiple example cases).. -! To do -! 1. Remove the legacy SCM_idealized_hurricane_wind_forcing code -! 2. Make the hurricane-to-background wind transition a runtime parameter -! +! for multiple example cases). +! December 2024: Removed the legacy subroutine SCM_idealized_hurricane_wind_forcing use MOM_error_handler, only : MOM_error, FATAL use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_forcing_type, only : forcing, mech_forcing -use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing +use MOM_forcing_type, only : allocate_mech_forcing use MOM_grid, only : ocean_grid_type use MOM_safe_alloc, only : safe_alloc_ptr -use MOM_time_manager, only : time_type, operator(+), operator(/), time_type_to_real +use MOM_time_manager, only : time_type, operator(+), operator(/), time_to_real use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, surface use MOM_verticalGrid, only : verticalGrid_type @@ -38,8 +37,6 @@ module Idealized_hurricane ! hurricane wind profile. public idealized_hurricane_wind_forcing !Public interface to update the idealized ! hurricane wind profile. -public SCM_idealized_hurricane_wind_forcing !Public interface to the legacy idealized - ! hurricane wind profile for SCM. !> Container for parameters describing idealized wind structure type, public :: idealized_hurricane_CS ; private @@ -49,10 +46,14 @@ module Idealized_hurricane real :: pressure_ambient !< Pressure at surface of ambient air [R L2 T-2 ~> Pa] real :: pressure_central !< Pressure at surface at hurricane center [R L2 T-2 ~> Pa] real :: rad_max_wind !< Radius of maximum winds [L ~> m] + real :: rad_edge !< Radius of the edge of the hurricane, normalized by + !! the radius of maximum winds [nondim] + real :: rad_ambient !< Radius at which the winds are at their ambient background values, + !! normalized by the radius of maximum winds [nondim] real :: max_windspeed !< Maximum wind speeds [L T-1 ~> m s-1] real :: hurr_translation_spd !< Hurricane translation speed [L T-1 ~> m s-1] real :: hurr_translation_dir !< Hurricane translation direction [radians] - real :: gustiness !< Gustiness (optional, used in u*) [R L Z T-2 ~> Pa] + real :: gustiness !< Gustiness (used in u*) [R Z2 T-2 ~> Pa] real :: Rho0 !< A reference ocean density [R ~> kg m-3] real :: Hurr_cen_Y0 !< The initial y position of the hurricane !! This experiment is conducted in a Cartesian @@ -60,33 +61,60 @@ module Idealized_hurricane real :: Hurr_cen_X0 !< The initial x position of the hurricane !! This experiment is conducted in a Cartesian !! grid and this is assumed to be in meters [L ~> m] - real :: Holland_A !< Parameter 'A' from the Holland formula [nondim] real :: Holland_B !< Parameter 'B' from the Holland formula [nondim] - real :: Holland_AxBxDP !< 'A' x 'B' x (Pressure Ambient-Pressure central) - !! for the Holland prorfile calculation [R L2 T-2 ~> Pa] logical :: relative_tau !< A logical to take difference between wind !! and surface currents to compute the stress - logical :: answers_2018 !< If true, use expressions driving the idealized hurricane test - !! case that recover the answers from the end of 2018. Otherwise use - !! expressions that are rescalable and respect rotational symmetry. + integer :: answer_date !< The vintage of the expressions in the idealized hurricane + !! test case. Values below 20190101 recover the answers + !! from the end of 2018, while higher values use expressions + !! that are rescalable and respect rotational symmetry. + ! Parameters used in a simple wind-speed dependent expression for C_drag + real :: Cd_calm !< The drag coefficient with weak relative winds [nondim] + real :: calm_speed !< The relative wind speed below which the drag coefficient takes its + !! calm value [L T-1 ~> m s-1] + real :: Cd_windy !< The drag coefficient with strong relative winds [nondim] + real :: windy_speed !< The relative wind speed below which the drag coefficient takes its + !! windy value [L T-1 ~> m s-1] + real :: dCd_dU10 !< The partial derivative of the drag coefficient times 1000 with the 10 m + !! wind speed for intermediate wind speeds [T L-1 ~> s m-1] + real :: Cd_intercept !< The zero-wind intercept times 1000 of the linear fit for the drag + !! coefficient for the intermediate speeds where there is a linear + !! dependence on the 10 m wind speed [nondim] + + ! Parameters used to set the inflow angle as a function of radius and maximum wind speed + real :: A0_0 !< The zero-radius, zero-speed intercept of the axisymmetric inflow angle [degrees] + real :: A0_Rnorm !< The normalized radius dependence of the axisymmetric inflow angle [degrees] + real :: A0_speed !< The maximum wind speed dependence of the axisymmetric inflow angle + !! [degrees T L-1 ~> degrees s m-1] + real :: A1_0 !< The zero-radius, zero-speed intercept of the normalized inflow angle + !! asymmetry [degrees] + real :: A1_Rnorm !< The normalized radius dependence of the normalized inflow angle asymmetry [degrees] + real :: A1_speed !< The translation speed dependence of the normalized inflow angle asymmetry + !! [degrees T L-1 ~> degrees s m-1] + real :: P1_0 !< The zero-radius, zero-speed intercept of the angle difference between the + !! translation direction and the inflow direction [degrees] + real :: P1_Rnorm !< The normalized radius dependence of the angle difference between the + !! translation direction and the inflow direction [degrees] + real :: P1_speed !< The translation speed dependence of the angle difference between the + !! translation direction and the inflow direction [degrees T L-1 ~> degrees s m-1] ! Parameters used if in SCM (single column model) mode - logical :: SCM_mode !< If true this being used in Single Column Model mode - logical :: BR_BENCH !< A "benchmark" configuration (which is meant to - !! provide identical wind to reproduce a previous - !! experiment, where that wind formula contained - !! an error) + logical :: SCM_mode !< If true this being used in Single Column Model mode + logical :: edge_taper_bug !< If true and SCM_mode is true, use a bug that does all of the tapering + !! and inflow angle calculations for radii between RAD_EDGE and RAD_AMBIENT + !! as though they were at RAD_EDGE. + real :: f_column !< Coriolis parameter used in the single column mode idealized + !! hurricane wind profile [T-1 ~> s-1] + logical :: BR_Bench !< A "benchmark" configuration (which is meant to + !! provide identical wind to reproduce a previous + !! experiment, where that wind formula contained an error) real :: dy_from_center !< (Fixed) distance in y from storm center path [L ~> m] - ! Par - real :: PI !< Mathematical constant - real :: Deg2Rad !< Mathematical constant + real :: pi !< The circumference of a circle divided by its diameter [nondim] + real :: Deg2Rad !< The conversion factor from degrees to radians [radian degree-1] end type -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mdl = "idealized_hurricane" !< This module's name. contains @@ -101,8 +129,11 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) ! Local variables real :: dP ! The pressure difference across the hurricane [R L2 T-2 ~> Pa] - real :: C - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. + real :: C ! A temporary variable in units of the square root of a specific volume [sqrt(m3 kg-1)] + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: continuous_Cd ! If true, use a continuous form for the simple drag coefficient as a + ! function of wind speed with the idealized hurricane. When this is false, the + ! linear shape for the mid-range wind speeds is specified separately. ! This include declares and sets the variable "version". # include "version_variable.h" @@ -127,24 +158,30 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) units='kg/m3', default=1.2, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "IDL_HURR_AMBIENT_PRESSURE", CS%pressure_ambient, & "Ambient pressure used in the idealized hurricane wind profile.", & - units='Pa', default=101200., scale=US%m_s_to_L_T**2*US%kg_m3_to_R) + units='Pa', default=101200., scale=US%Pa_to_RL2_T2) call get_param(param_file, mdl, "IDL_HURR_CENTRAL_PRESSURE", CS%pressure_central, & "Central pressure used in the idealized hurricane wind profile.", & - units='Pa', default=96800., scale=US%m_s_to_L_T**2*US%kg_m3_to_R) - call get_param(param_file, mdl, "IDL_HURR_RAD_MAX_WIND", & - CS%rad_max_wind, "Radius of maximum winds used in the "//& - "idealized hurricane wind profile.", units='m', & - default=50.e3, scale=US%m_to_L) + units='Pa', default=96800., scale=US%Pa_to_RL2_T2) + call get_param(param_file, mdl, "IDL_HURR_RAD_MAX_WIND", CS%rad_max_wind, & + "Radius of maximum winds used in the idealized hurricane wind profile.", & + units='m', default=50.e3, scale=US%m_to_L) + call get_param(param_file, mdl, "IDL_HURR_RAD_EDGE", CS%rad_edge, & + "Radius of the edge of the hurricane, normalized by the radius of maximum winds.", & + units='nondim', default=10.0) + call get_param(param_file, mdl, "IDL_HURR_RAD_AMBIENT", CS%rad_ambient, & + "Radius at which the winds are at their ambient background values, "//& + "normalized by the radius of maximum winds.", & + units='nondim', default=CS%rad_edge+2.0) call get_param(param_file, mdl, "IDL_HURR_MAX_WIND", CS%max_windspeed, & - "Maximum wind speed used in the idealized hurricane"// & - "wind profile.", units='m/s', default=65., scale=US%m_s_to_L_T) + "Maximum wind speed used in the idealized hurricane wind profile.", & + units='m/s', default=65., scale=US%m_s_to_L_T) call get_param(param_file, mdl, "IDL_HURR_TRAN_SPEED", CS%hurr_translation_spd, & - "Translation speed of hurricane used in the idealized "//& - "hurricane wind profile.", units='m/s', default=5.0, scale=US%m_s_to_L_T) + "Translation speed of hurricane used in the idealized hurricane wind profile.", & + units='m/s', default=5.0, scale=US%m_s_to_L_T) call get_param(param_file, mdl, "IDL_HURR_TRAN_DIR", CS%hurr_translation_dir, & "Translation direction (towards) of hurricane used in the "//& - "idealized hurricane wind profile.", units='degrees', & - default=180.0, scale=CS%Deg2Rad) + "idealized hurricane wind profile.", & + units='degrees', default=180.0, scale=CS%Deg2Rad) call get_param(param_file, mdl, "IDL_HURR_X0", CS%Hurr_cen_X0, & "Idealized Hurricane initial X position", & units='m', default=0., scale=US%m_to_L) @@ -152,29 +189,120 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) "Idealized Hurricane initial Y position", & units='m', default=0., scale=US%m_to_L) call get_param(param_file, mdl, "IDL_HURR_TAU_CURR_REL", CS%relative_tau, & - "Current relative stress switch "//& - "used in the idealized hurricane wind profile.", & - units='', default=.false.) + "Current relative stress switch used in the idealized hurricane wind profile.", & + default=.false.) + + call get_param(param_file, mdl, "IDL_HURR_AXI_INFLOW_0", CS%A0_0, & + "The zero-radius asymmetry, zero-speed intercept of the axisymmetric inflow "//& + "angle for the parametric idealized hurricane.", & + default=-14.33, units="degrees") + call get_param(param_file, mdl, "IDL_HURR_AXI_INFLOW_RNORM", CS%A0_Rnorm, & + "The normalized radius dependence of the axisymmetric inflow angle "//& + "for the parametric idealized hurricane.", & + default=-0.9, units="degrees") + call get_param(param_file, mdl, "IDL_HURR_AXI_INFLOW_MAX_SPEED", CS%A0_speed, & + "The maximum wind speed dependence of the axisymmetric inflow angle "//& + "for the parametric idealized hurricane.", & + default=-0.09, units="degrees s m-1", scale=US%L_T_to_m_s) + call get_param(param_file, mdl, "IDL_HURR_ASYM_INFLOW_0", CS%A1_0, & + "The zero-radius, zero-speed intercept of the normalized inflow angle asymmetry "//& + "for the parametric idealized hurricane.", & + default=0.14, units="degrees") + call get_param(param_file, mdl, "IDL_HURR_ASYM_INFLOW_RNORM", CS%A1_Rnorm, & + "The normalized radius dependence of the normalized inflow angle asymmetry "//& + "for the parametric idealized hurricane.", & + default=0.04, units="degrees") + call get_param(param_file, mdl, "IDL_HURR_ASYM_INFLOW_TR_SPEED", CS%A1_speed, & + "The translation speed dependence of the normalized inflow angle asymmetry "//& + "for the parametric idealized hurricane.", & + default=0.05, units="degrees s m-1", scale=US%L_T_to_m_s) + call get_param(param_file, mdl, "IDL_HURR_INFLOW_DANGLE_0", CS%P1_0, & + "The zero-radius, zero-speed intercept of the angle difference between the "//& + "translation direction and the inflow direction "//& + "for the parametric idealized hurricane.", & + default=85.31, units="degrees") + call get_param(param_file, mdl, "IDL_HURR_INFLOW_DANGLE_RNORM", CS%P1_Rnorm, & + "The normalized radius dependence of the angle difference between the "//& + "translation direction and the inflow direction "//& + "for the parametric idealized hurricane.", & + default=6.88, units="degrees") + call get_param(param_file, mdl, "IDL_HURR_INFLOW_DANGLE_TR_SPEED", CS%P1_speed, & + "The translation speed dependence of the angle difference between the "//& + "translation direction and the inflow direction "//& + "for the parametric idealized hurricane.", & + default=-9.60, units="degrees s m-1", scale=US%L_T_to_m_s) ! Parameters for SCM mode - call get_param(param_file, mdl, "IDL_HURR_SCM_BR_BENCH", CS%BR_BENCH, & + call get_param(param_file, mdl, "IDL_HURR_SCM_BR_BENCH", CS%BR_Bench, & "Single column mode benchmark case switch, which is "// & "invoking a modification (bug) in the wind profile meant to "//& - "reproduce a previous implementation.", units='', default=.false.) - call get_param(param_file, mdl, "IDL_HURR_SCM", CS%SCM_MODE, & - "Single Column mode switch "//& - "used in the SCM idealized hurricane wind profile.", & - units='', default=.false.) + "reproduce a previous implementation.", default=.false.) + call get_param(param_file, mdl, "IDL_HURR_SCM", CS%SCM_mode, & + "Single Column mode switch used in the SCM idealized hurricane wind profile.", & + default=.false.) + call get_param(param_file, mdl, "IDL_HURR_SCM_EDGE_TAPER_BUG", CS%edge_taper_bug, & + "If true and IDL_HURR_SCM is true, use a bug that does all of the tapering and "//& + "inflow angle calculations for radii between RAD_EDGE and RAD_AMBIENT as though "//& + "they were at RAD_EDGE.", & + default=.false., do_not_log=.not.CS%SCM_mode) + if (.not.CS%SCM_mode) CS%edge_taper_bug = .false. call get_param(param_file, mdl, "IDL_HURR_SCM_LOCY", CS%dy_from_center, & - "Y distance of station used in the SCM idealized hurricane "//& - "wind profile.", units='m', default=50.e3, scale=US%m_to_L) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & + "Y distance of station used in the SCM idealized hurricane wind profile.", & + units='m', default=50.e3, scale=US%m_to_L) + call get_param(param_file, mdl, "IDL_HURR_SCM_CORIOLIS", CS%f_column, & + "Coriolis parameter used in the single column mode idealized hurricane wind profile.", & + units='s-1', default=5.5659e-05, scale=US%T_to_s, do_not_log=.not.CS%BR_Bench) ! (CS%SCM_mode) + + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "IDL_HURR_ANSWER_DATE", CS%answer_date, & + "The vintage of the expressions in the idealized hurricane test case. "//& + "Values below 20190101 recover the answers from the end of 2018, while higher "//& + "values use expressions that are rescalable and respect rotational symmetry.", & + default=default_answer_date) + + ! Parameters for the simple Cdrag expression + call get_param(param_file, mdl, "IDL_HURR_CD_CALM", CS%Cd_calm, & + "The drag coefficient with weak relative winds "//& + "for the simple drag coefficient expression used with the idealized hurricane.", & + units='nondim', default=1.2e-3) + call get_param(param_file, mdl, "IDL_HURR_CD_CALM_SPEED", CS%calm_speed, & + "The relative wind speed below which the drag coefficient takes its calm value "//& + "for the simple drag coefficient expression used with the idealized hurricane.", & + units='m s-1', default=11.0, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "IDL_HURR_CD_WINDY", CS%Cd_windy, & + "The drag coefficient with strong relative winds "//& + "for the simple drag coefficient expression used with the idealized hurricane.", & + units='nondim', default=1.8e-3) + call get_param(param_file, mdl, "IDL_HURR_CD_WINDY_SPEED", CS%windy_speed, & + "The relative wind speed below which the drag coefficient takes its windy value "//& + "for the simple drag coefficient expression used with the idealized hurricane.", & + units='m s-1', default=20.0, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "IDL_HURR_CD_CONTINUOUS", continuous_Cd, & + "If true, use a continuous form for the simple drag coefficient as a function of "//& + "wind speed with the idealized hurricane. When this is false, the linear shape "//& + "for the mid-range wind speeds is specified separately.", & default=.false.) - call get_param(param_file, mdl, "IDL_HURR_2018_ANSWERS", CS%answers_2018, & - "If true, use expressions driving the idealized hurricane test case that recover "//& - "the answers from the end of 2018. Otherwise use expressions that are rescalable "//& - "and respect rotational symmetry.", default=default_2018_answers) + call get_param(param_file, mdl, "IDL_HURR_CD_DCD_DU10", CS%dCd_dU10, & + "The partial derivative of the drag coefficient times 1000 with the 10 m wind speed "//& + "for the simple drag coefficient expression used with the idealized hurricane.", & + units="s m-1", default=0.065, scale=US%L_T_to_m_s, do_not_log=continuous_Cd) + call get_param(param_file, mdl, "IDL_HURR_CD_INTERCEPT", CS%Cd_intercept, & + "The zero-wind intercept times 1000 of the linear fit for the drag coefficient "//& + "for the intermediate speeds where there is a linear dependence on the 10 m wind speed "//& + "for the simple drag coefficient expression used with the idealized hurricane.", & + units="nondim", default=0.49, do_not_log=continuous_Cd) + if (continuous_Cd) then + if (CS%windy_speed > CS%calm_speed) then + CS%dCd_dU10 = (CS%Cd_windy - CS%Cd_calm) / (CS%windy_speed - CS%calm_speed) + CS%Cd_intercept = CS%Cd_calm - CS%dCd_dU10 * CS%calm_speed + else + CS%dCd_dU10 = 0.0 + CS%Cd_intercept = CS%Cd_windy + endif + endif + ! The following parameters are model run-time parameters which are used ! and logged elsewhere and so should not be logged here. The default @@ -182,25 +310,23 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& + "properties, or with BOUSSINESQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0, scale=US%kg_m3_to_R, do_not_log=.true.) call get_param(param_file, mdl, "GUST_CONST", CS%gustiness, & - "The background gustiness in the winds.", units="Pa", & - default=0.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z, do_not_log=.true.) + "The background gustiness in the winds.", & + units="Pa", default=0.0, scale=US%Pa_to_RLZ_T2*US%L_to_Z, do_not_log=.true.) + + if (CS%rad_edge >= CS%rad_ambient) call MOM_error(FATAL, & + "idealized_hurricane_wind_init: IDL_HURR_RAD_AMBIENT must be larger than IDL_HURR_RAD_EDGE.") - if (CS%BR_BENCH) then - CS%rho_a = 1.2*US%kg_m3_to_R - endif dP = CS%pressure_ambient - CS%pressure_central - if (CS%answers_2018) then + if (CS%answer_date < 20190101) then C = CS%max_windspeed / sqrt( US%R_to_kg_m3 * dP ) CS%Holland_B = C**2 * US%R_to_kg_m3*CS%rho_a * exp(1.0) else CS%Holland_B = CS%max_windspeed**2 * CS%rho_a * exp(1.0) / dP endif - CS%Holland_A = (US%L_to_m*CS%rad_max_wind)**CS%Holland_B - CS%Holland_AxBxDP = CS%Holland_A*CS%Holland_B*dP end subroutine idealized_hurricane_wind_init @@ -234,8 +360,11 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + if ((G%grid_unit_to_L <= 0.) .and. (.not.CS%SCM_mode)) call MOM_error(FATAL, "Idealized_Hurricane.F90: " //& + "idealized_hurricane_wind_forcing is only set to work with Cartesian axis units.") + ! Allocate the forcing arrays, if necessary. - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., tau_mag=.true.) if (CS%relative_tau) then REL_TAU_FAC = 1. @@ -244,15 +373,14 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) endif !> Compute storm center location - XC = CS%Hurr_cen_X0 + (time_type_to_real(day)*US%s_to_T * CS%hurr_translation_spd * & + XC = CS%Hurr_cen_X0 + (time_to_real(day, scale=US%s_to_T) * CS%hurr_translation_spd * & cos(CS%hurr_translation_dir)) - YC = CS%Hurr_cen_Y0 + (time_type_to_real(day)*US%s_to_T * CS%hurr_translation_spd * & + YC = CS%Hurr_cen_Y0 + (time_to_real(day, scale=US%s_to_T) * CS%hurr_translation_spd * & sin(CS%hurr_translation_dir)) - if (CS%BR_Bench) then ! f reset to value used in generated wind for benchmark test - fbench = 5.5659e-05 * US%T_to_s + fbench = CS%f_column fbench_fac = 0.0 else fbench = 0.0 @@ -263,21 +391,21 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) do j=js,je do I=is-1,Ieq Uocn = sfc_state%u(I,j) * REL_TAU_FAC - if (CS%answers_2018) then + if (CS%answer_date < 20190101) then Vocn = 0.25*(sfc_state%v(i,J)+sfc_state%v(i+1,J-1)& +sfc_state%v(i+1,J)+sfc_state%v(i,J-1))*REL_TAU_FAC else - Vocn =0.25*((sfc_state%v(i,J)+sfc_state%v(i+1,J-1)) +& - (sfc_state%v(i+1,J)+sfc_state%v(i,J-1))) * REL_TAU_FAC + Vocn = 0.25*((sfc_state%v(i,J)+sfc_state%v(i+1,J-1)) +& + (sfc_state%v(i+1,J)+sfc_state%v(i,J-1))) * REL_TAU_FAC endif f_local = abs(0.5*(G%CoriolisBu(I,J)+G%CoriolisBu(I,J-1)))*fbench_fac + fbench ! Calculate position as a function of time. if (CS%SCM_mode) then - YY = YC + CS%dy_from_center - XX = XC + YY = CS%dy_from_center - YC + XX = -XC else - YY = G%geoLatCu(I,j)*1000.*US%m_to_L - YC - XX = G%geoLonCu(I,j)*1000.*US%m_to_L - XC + YY = G%geoLatCu(I,j) * G%grid_unit_to_L - YC + XX = G%geoLonCu(I,j) * G%grid_unit_to_L - XC endif call idealized_hurricane_wind_profile(CS, US, f_local, YY, XX, Uocn, Vocn, TX, TY) forces%taux(I,j) = G%mask2dCu(I,j) * TX @@ -286,7 +414,7 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) !> Computes tauy do J=js-1,Jeq do i=is,ie - if (CS%answers_2018) then + if (CS%answer_date < 20190101) then Uocn = 0.25*(sfc_state%u(I,j)+sfc_state%u(I-1,j+1) + & sfc_state%u(I-1,j)+sfc_state%u(I,j+1))*REL_TAU_FAC else @@ -297,11 +425,11 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) f_local = abs(0.5*(G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)))*fbench_fac + fbench ! Calculate position as a function of time. if (CS%SCM_mode) then - YY = YC + CS%dy_from_center - XX = XC + YY = CS%dy_from_center - YC + XX = -XC else - YY = G%geoLatCv(i,J)*1000.*US%m_to_L - YC - XX = G%geoLonCv(i,J)*1000.*US%m_to_L - XC + YY = G%geoLatCv(i,J) * G%grid_unit_to_L - YC + XX = G%geoLonCv(i,J) * G%grid_unit_to_L - XC endif call idealized_hurricane_wind_profile(CS, US, f_local, YY, XX, Uocn, Vocn, TX, TY) forces%tauy(i,J) = G%mask2dCv(i,J) * TY @@ -309,16 +437,20 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) enddo !> Get Ustar - do j=js,je - do i=is,ie - ! This expression can be changed if desired, but need not be. - forces%ustar(i,j) = G%mask2dT(i,j) * sqrt(US%L_to_Z * (CS%gustiness/CS%Rho0 + & - sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & - 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0)) - enddo - enddo + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + ! This expression can be changed if desired, but need not be. + forces%ustar(i,j) = G%mask2dT(i,j) * sqrt(CS%gustiness/CS%Rho0 + & + US%L_to_Z * sqrt(0.5*((forces%taux(I-1,j)**2) + (forces%taux(I,j)**2)) + & + 0.5*((forces%tauy(i,J-1)**2) + (forces%tauy(i,J)**2)))/CS%Rho0) + enddo ; enddo ; endif + + !> Get tau_mag [R Z2 T-2 ~> Pa] + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = G%mask2dT(i,j) * (CS%gustiness + & + US%L_to_Z * sqrt(0.5*((forces%taux(I-1,j)**2) + (forces%taux(I,j)**2)) + & + 0.5*((forces%tauy(i,J-1)**2) + (forces%tauy(i,J)**2)))) + enddo ; enddo ; endif - return end subroutine idealized_hurricane_wind_forcing !> Calculate the wind speed at a location as a function of time. @@ -343,30 +475,41 @@ subroutine idealized_hurricane_wind_profile(CS, US, absf, YY, XX, UOCN, VOCN, Tx ! Wind profile terms real :: U10 ! The 10 m wind speed [L T-1 ~> m s-1] real :: radius ! The distance from the hurricane center [L ~> m] - real :: radius10 ! 10 times the distance from the hurricane center [L ~> m] + real :: radius10 ! The distance from the hurricane center to its edge [L ~> m] real :: radius_km ! The distance from the hurricane center, perhaps in km [L ~> m] or [1000 L ~> km] - real :: radiusB - real :: tmp ! A temporary variable [R L T-1 ~> kg m-2 s-1] real :: du10 ! The magnitude of the difference between the 10 m wind and the ocean flow [L T-1 ~> m s-1] real :: du ! The difference between the zonal 10 m wind and the zonal ocean flow [L T-1 ~> m s-1] real :: dv ! The difference between the meridional 10 m wind and the zonal ocean flow [L T-1 ~> m s-1] - real :: CD + real :: Cd ! The drag coefficient [nondim] + ! These variables with weird units are only used with pre-20240501 expressions + real :: radiusB ! A rescaled radius in m raised to the variable power CS%Holland_B [m^B] + real :: Holland_A ! Parameter 'A' from the Holland formula, in units of m raised to Holland_B [m^B] + real :: Holland_AxBxDP ! 'A' x 'B' x (Pressure Ambient-Pressure central) + ! for the Holland profile calculation [m^B R L2 T-2 ~> m^B Pa] + real :: tmp ! A temporary variable [m^B R L T-1 ~> m^B kg m-2 s-1] + ! These variables are used with expressions from 20240501 or later + real :: dP ! The pressure difference across the hurricane [R L2 T-2 ~> Pa] + real :: tmpA ! A temporary variable [R L2 T-2 ~> Pa] + real :: tmpB ! A temporary variable [R L T-1 ~> kg m-2 s-1] + real :: rad_max_rad_B ! The radius of maximum wind divided by the distance from the center raised + ! to the power of Holland_B [nondim] + real :: rad_rad_max ! The radius normalized by the radius of maximum winds [nondim] !Wind angle variables - real :: Alph !< The resulting inflow angle (positive outward) - real :: Rstr - real :: A0 - real :: A1 - real :: P1 - real :: Adir + real :: Alph ! The wind inflow angle (positive outward) [radians] + real :: Rstr ! A function of the position normalized by the radius of maximum winds [nondim] + real :: A0 ! The axisymmetric inflow angle [degrees] + real :: A1 ! The inflow angle asymmetry [degrees] + real :: P1 ! The angle difference between the translation direction and the inflow direction [radians] + real :: Adir ! The angle of the direction from the center to a point [radians] real :: V_TS ! Meridional hurricane translation speed [L T-1 ~> m s-1] real :: U_TS ! Zonal hurricane translation speed [L T-1 ~> m s-1] - ! Implementing Holland (1980) parameteric wind profile + ! Implementing Holland (1980) parametric wind profile - radius = SQRT(XX**2 + YY**2) + radius = SQRT((XX**2) + (YY**2)) + rad_rad_max = radius / CS%rad_max_wind - !/ BGR ! rkm - r converted to km for Holland prof. ! used in km due to error, correct implementation should ! not need rkm, but to match winds w/ experiment this must @@ -378,17 +521,24 @@ subroutine idealized_hurricane_wind_profile(CS, US, absf, YY, XX, UOCN, VOCN, Tx ! if not comparing to benchmark, then use correct Holland prof. radius_km = radius endif - radiusB = (US%L_to_m*radius)**CS%Holland_B !/ - ! Calculate U10 in the interior (inside of 10x radius of maximum wind), - ! while adjusting U10 to 0 outside of 12x radius of maximum wind. - if (CS%answers_2018) then - if ( (radius > 0.001*CS%rad_max_wind) .and. (radius < 10.*CS%rad_max_wind) ) then - U10 = sqrt(CS%Holland_AxBxDP*exp(-CS%Holland_A/radiusB) / (CS%rho_a*radiusB) + & + ! Calculate U10 in the interior (inside of the hurricane edge radius), + ! while adjusting U10 to 0 outside of the ambient wind radius. + if (CS%answer_date < 20190101) then + radiusB = (US%L_to_m*radius)**CS%Holland_B + Holland_A = (US%L_to_m*CS%rad_max_wind)**CS%Holland_B + if ( (radius > 0.001*CS%rad_max_wind) .and. (radius < CS%rad_edge*CS%rad_max_wind) ) then + Holland_AxBxDP = Holland_A*CS%Holland_B*(CS%pressure_ambient - CS%pressure_central) + U10 = sqrt(Holland_AxBxDP*exp(-Holland_A/radiusB) / (CS%rho_a*radiusB) + & 0.25*(radius_km*absf)**2) - 0.5*radius_km*absf - elseif ( (radius > 10.*CS%rad_max_wind) .and. (radius < 15.*CS%rad_max_wind) ) then - radius10 = CS%rad_max_wind*10. + elseif ( (radius > CS%rad_edge*CS%rad_max_wind) .and. (radius < CS%rad_ambient*CS%rad_max_wind) ) then + if (CS%edge_taper_bug) then ! This recreates a bug that was in SCM_idealized_hurricane_wind_forcing. + radius = CS%rad_edge * CS%rad_max_wind + rad_rad_max = CS%rad_edge + endif + + radius10 = CS%rad_max_wind*CS%rad_edge if (CS%BR_Bench) then radius_km = radius10/1000. else @@ -396,24 +546,64 @@ subroutine idealized_hurricane_wind_profile(CS, US, absf, YY, XX, UOCN, VOCN, Tx endif radiusB = (US%L_to_m*radius10)**CS%Holland_B - U10 = (sqrt(CS%Holland_AxBxDp*exp(-CS%Holland_A/radiusB) / (CS%rho_a*radiusB) + & + Holland_AxBxDP = Holland_A*CS%Holland_B*(CS%pressure_ambient - CS%pressure_central) + U10 = (sqrt(Holland_AxBxDp*exp(-Holland_A/radiusB) / (CS%rho_a*radiusB) + & 0.25*(radius_km*absf)**2) - 0.5*radius_km*absf) & - * (15. - radius/CS%rad_max_wind)/5. + * (CS%rad_ambient - radius/CS%rad_max_wind) / (CS%rad_ambient - CS%rad_edge) else U10 = 0. endif - else ! This is mathematically equivalent to that is above but more accurate. - if ( (radius > 0.001*CS%rad_max_wind) .and. (radius < 10.*CS%rad_max_wind) ) then + elseif (CS%answer_date < 20240501) then + ! This is mathematically equivalent to that is above but more accurate. + radiusB = (US%L_to_m*radius)**CS%Holland_B + Holland_A = (US%L_to_m*CS%rad_max_wind)**CS%Holland_B + if ( (radius > 0.001*CS%rad_max_wind) .and. (radius < CS%rad_edge*CS%rad_max_wind) ) then + Holland_AxBxDP = Holland_A*CS%Holland_B*(CS%pressure_ambient - CS%pressure_central) tmp = ( 0.5*radius_km*absf) * (CS%rho_a*radiusB) - U10 = (CS%Holland_AxBxDP * exp(-CS%Holland_A/radiusB)) / & - ( tmp + sqrt(CS%Holland_AxBxDP*exp(-CS%Holland_A/radiusB) * (CS%rho_a*radiusB) + tmp**2) ) - elseif ( (radius > 10.*CS%rad_max_wind) .and. (radius < 15.*CS%rad_max_wind) ) then - radius_km = 10.0 * CS%rad_max_wind + U10 = (Holland_AxBxDP * exp(-Holland_A/radiusB)) / & + ( tmp + sqrt(Holland_AxBxDP*exp(-Holland_A/radiusB) * (CS%rho_a*radiusB) + tmp**2) ) + elseif ( (radius > CS%rad_edge*CS%rad_max_wind) .and. (radius < CS%rad_ambient*CS%rad_max_wind) ) then + if (CS%edge_taper_bug) then ! This recreates a bug that was in SCM_idealized_hurricane_wind_forcing. + radius = CS%rad_edge * CS%rad_max_wind + rad_rad_max = CS%rad_edge + endif + + radius_km = CS%rad_edge * CS%rad_max_wind if (CS%BR_Bench) radius_km = radius_km/1000. - radiusB = (10.0*US%L_to_m*CS%rad_max_wind)**CS%Holland_B + radiusB = (CS%rad_edge*US%L_to_m*CS%rad_max_wind)**CS%Holland_B tmp = ( 0.5*radius_km*absf) * (CS%rho_a*radiusB) - U10 = (3.0 - radius/(5.0*CS%rad_max_wind)) * (CS%Holland_AxBxDp*exp(-CS%Holland_A/radiusB) ) / & - ( tmp + sqrt(CS%Holland_AxBxDp*exp(-CS%Holland_A/radiusB) * (CS%rho_a*radiusB) + tmp**2) ) + Holland_AxBxDP = Holland_A*CS%Holland_B*(CS%pressure_ambient - CS%pressure_central) + U10 = ((CS%rad_ambient/(CS%rad_ambient - CS%rad_edge)) - & + radius/((CS%rad_ambient - CS%rad_edge)*CS%rad_max_wind)) * & + (Holland_AxBxDp*exp(-Holland_A/radiusB) ) / & + ( tmp + sqrt(Holland_AxBxDp*exp(-Holland_A/radiusB) * (CS%rho_a*radiusB) + tmp**2) ) + else + U10 = 0.0 + endif + else + ! This is mathematically equivalent to the expressions above, but allows for full + ! dimensional consistency testing. + dP = CS%pressure_ambient - CS%pressure_central + if ( (rad_rad_max > 0.001) .and. (rad_rad_max <= CS%rad_edge) ) then + rad_max_rad_B = (rad_rad_max)**(-CS%Holland_B) + tmpA = (rad_max_rad_B*CS%Holland_B) * dp + tmpB = (0.5*radius_km*absf) * CS%rho_a + U10 = ( tmpA * exp(-rad_max_rad_B) ) / & + ( tmpB + sqrt( (tmpA * CS%rho_a) * exp(-rad_max_rad_B) + tmpB**2) ) + elseif ( (rad_rad_max > CS%rad_edge) .and. (rad_rad_max < CS%rad_ambient) ) then + if (CS%edge_taper_bug) then ! This recreates a bug that was in SCM_idealized_hurricane_wind_forcing. + radius = CS%rad_edge * CS%rad_max_wind + rad_rad_max = CS%rad_edge + endif + + radius_km = CS%rad_edge * CS%rad_max_wind + if (CS%BR_Bench) radius_km = radius_km * 0.001 + rad_max_rad_B = CS%rad_edge**(-CS%Holland_B) + tmpA = (rad_max_rad_B*CS%Holland_B) * dp + tmpB = (0.5*radius_km*absf) * CS%rho_a + U10 = ((CS%rad_ambient - rad_rad_max) * ( tmpA * exp(-rad_max_rad_B) )) / & + ((CS%rad_ambient - CS%rad_edge) * & + ( tmpB + sqrt((tmpA * CS%rho_a) * exp(-rad_max_rad_B) + tmpB**2) ) ) else U10 = 0.0 endif @@ -425,240 +615,65 @@ subroutine idealized_hurricane_wind_profile(CS, US, absf, YY, XX, UOCN, VOCN, Tx ! Wind angle model following Zhang and Ulhorn (2012) ! ALPH is inflow angle positive outward. - RSTR = min(10., radius / CS%rad_max_wind) - A0 = -0.9*RSTR - 0.09*US%L_T_to_m_s*CS%max_windspeed - 14.33 - A1 = -A0*(0.04*RSTR + 0.05*US%L_T_to_m_s*CS%hurr_translation_spd + 0.14) - P1 = (6.88*RSTR - 9.60*US%L_T_to_m_s*CS%hurr_translation_spd + 85.31) * CS%Deg2Rad - ALPH = A0 - A1*cos(CS%hurr_translation_dir-Adir-P1) - if ( (radius > 10.*CS%rad_max_wind) .and.& - (radius < 15.*CS%rad_max_wind) ) then - ALPH = ALPH*(15.0 - radius/CS%rad_max_wind)/5. - elseif (radius > 15.*CS%rad_max_wind) then - ALPH = 0.0 + RSTR = min(CS%rad_edge, rad_rad_max) + if (CS%answer_date < 20240501) then + A0 = CS%A0_Rnorm*RSTR + CS%A0_speed*CS%max_windspeed + CS%A0_0 + A1 = -A0*(CS%A1_Rnorm*RSTR + CS%A1_speed*CS%hurr_translation_spd + CS%A1_0) + P1 = (CS%P1_Rnorm*RSTR + CS%P1_speed*CS%hurr_translation_spd + CS%P1_0) * CS%Deg2Rad + ALPH = A0 - A1*cos(CS%hurr_translation_dir-Adir-P1) + if ( (radius > CS%rad_edge*CS%rad_max_wind) .and. (radius < CS%rad_ambient*CS%rad_max_wind) ) then + ALPH = ALPH*(CS%rad_ambient - rad_rad_max) / (CS%rad_ambient - CS%rad_edge) + elseif (radius > CS%rad_ambient*CS%rad_max_wind) then ! This should be >= to avoid a jump at CS%rad_ambient + ALPH = 0.0 + endif + ALPH = ALPH * CS%Deg2Rad + else + A0 = (CS%A0_Rnorm*RSTR + CS%A0_speed*CS%max_windspeed) + CS%A0_0 + A1 = -A0*((CS%A1_Rnorm*RSTR + CS%A1_speed*CS%hurr_translation_spd) + CS%A1_0) + P1 = ((CS%P1_Rnorm*RSTR + CS%P1_speed*CS%hurr_translation_spd) + CS%P1_0) * CS%Deg2Rad + ALPH = (A0 - A1*cos((CS%hurr_translation_dir- Adir) - P1) ) * CS%Deg2Rad + if (rad_rad_max > CS%rad_edge) & + ALPH = ALPH * (max(CS%rad_ambient - rad_rad_max, 0.0) / (CS%rad_ambient - CS%rad_edge)) endif - ALPH = ALPH * CS%Deg2Rad ! Calculate translation speed components U_TS = CS%hurr_translation_spd * 0.5*cos(CS%hurr_translation_dir) V_TS = CS%hurr_translation_spd * 0.5*sin(CS%hurr_translation_dir) ! Set output (relative) winds - dU = U10*sin(Adir-CS%Pi-Alph) - Uocn + U_TS + dU = U10*sin(Adir-CS%pi-Alph) - Uocn + U_TS dV = U10*cos(Adir-Alph) - Vocn + V_TS ! Use a simple drag coefficient as a function of U10 (from Sullivan et al., 2010) - du10 = sqrt(du**2+dv**2) - if (dU10 < 11.0*US%m_s_to_L_T) then - Cd = 1.2e-3 - elseif (dU10 < 20.0*US%m_s_to_L_T) then - if (CS%answers_2018) then - Cd = (0.49 + 0.065*US%L_T_to_m_s*U10)*1.e-3 - else - Cd = (0.49 + 0.065*US%L_T_to_m_s*dU10)*1.e-3 - endif - else - Cd = 1.8e-3 - endif + du10 = sqrt((du**2) + (dv**2)) + Cd = simple_wind_scaled_Cd(u10, du10, CS) ! Compute stress vector - TX = US%L_to_Z * CS%rho_a * Cd * sqrt(dU**2 + dV**2) * dU - TY = US%L_to_Z * CS%rho_a * Cd * sqrt(dU**2 + dV**2) * dV - + TX = US%L_to_Z * CS%rho_a * Cd * du10 * dU + TY = US%L_to_Z * CS%rho_a * Cd * du10 * dV end subroutine idealized_hurricane_wind_profile -!> This subroutine is primarily needed as a legacy for reproducing answers. -!! It is included as an additional subroutine rather than padded into the previous -!! routine with flags to ease its eventual removal. Its functionality is replaced -!! with the new routines and it can be deleted when answer changes are acceptable. -subroutine SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) - type(surface), intent(in) :: sfc_state !< Surface state structure - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day !< Time in days - type(ocean_grid_type), intent(inout) :: G !< Grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(idealized_hurricane_CS), pointer :: CS !< Container for SCM parameters - ! Local variables - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - real :: pie, Deg2Rad - real :: du10 ! The magnitude of the difference between the 10 m wind and the ocean flow [L T-1 ~> m s-1] - real :: U10 ! The 10 m wind speed [L T-1 ~> m s-1] - real :: A, B, C ! For wind profile expression - real :: rad ! The distance from the hurricane center [L ~> m] - real :: rkm ! The distance from the hurricane center, sometimes scaled to km [L ~> m] or [1000 L ~> km] - real :: f_local ! The local Coriolis parameter [T-1 ~> s-1] - real :: xx ! x-position [L ~> m] - real :: t0 !for location - real :: dP ! The pressure difference across the hurricane [R L2 T-2 ~> Pa] - real :: rB - real :: Cd ! Air-sea drag coefficient - real :: Uocn, Vocn ! Surface ocean velocity components [L T-1 ~> m s-1] - real :: dU, dV ! Air-sea differential motion [L T-1 ~> m s-1] - !Wind angle variables - real :: Alph,Rstr, A0, A1, P1, Adir, transdir - real :: V_TS, U_TS ! Components of the translation speed [L T-1 ~> m s-1] - logical :: BR_Bench - ! Bounds for loops and memory allocation - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - ! Allocate the forcing arrays, if necessary. - - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true.) - pie = 4.0*atan(1.0) ; Deg2Rad = pie/180. - !/ BR - ! Implementing Holland (1980) parameteric wind profile - !------------------------------------------------------| - BR_Bench = .true. !true if comparing to LES runs | - t0 = 129600. !TC 'eye' crosses (0,0) at 36 hours| - transdir = pie !translation direction (-x) | - !------------------------------------------------------| - dP = CS%pressure_ambient - CS%pressure_central - if (CS%answers_2018) then - C = CS%max_windspeed / sqrt( US%R_to_kg_m3*dP ) - B = C**2 * US%R_to_kg_m3*CS%rho_a * exp(1.0) - if (BR_Bench) then ! rho_a reset to value used in generated wind for benchmark test - B = C**2 * 1.2 * exp(1.0) - endif - elseif (BR_Bench) then ! rho_a reset to value used in generated wind for benchmark test - B = (CS%max_windspeed**2 / dP ) * 1.2*US%kg_m3_to_R * exp(1.0) - else - B = (CS%max_windspeed**2 /dP ) * CS%rho_a * exp(1.0) - endif - - A = (US%L_to_m*CS%rad_max_wind / 1000.)**B - f_local = G%CoriolisBu(is,js) ! f=f(x,y) but in the SCM is constant - if (BR_Bench) then - ! f reset to value used in generated wind for benchmark test - f_local = 5.5659e-05*US%T_to_s - endif - !/ BR - ! Calculate x position as a function of time. - xx = US%s_to_T*( t0 - time_type_to_real(day)) * CS%hurr_translation_spd * cos(transdir) - rad = sqrt(xx**2 + CS%dy_from_center**2) - !/ BR - ! rkm - rad converted to km for Holland prof. - ! used in km due to error, correct implementation should - ! not need rkm, but to match winds w/ experiment this must - ! be maintained. Causes winds far from storm center to be a - ! couple of m/s higher than the correct Holland prof. - if (BR_Bench) then - rkm = rad/1000. - rB = (US%L_to_m*rkm)**B - else - ! if not comparing to benchmark, then use correct Holland prof. - rkm = rad - rB = (US%L_to_m*rad)**B - endif - !/ BR - ! Calculate U10 in the interior (inside of 10x radius of maximum wind), - ! while adjusting U10 to 0 outside of 12x radius of maximum wind. - ! Note that rho_a is set to 1.2 following generated wind for experiment - if (rad > 0.001*CS%rad_max_wind .AND. rad < 10.*CS%rad_max_wind) then - U10 = sqrt( A*B*dP*exp(-A/rB)/(1.2*US%kg_m3_to_R*rB) + 0.25*(rkm*f_local)**2 ) - 0.5*rkm*f_local - elseif (rad > 10.*CS%rad_max_wind .AND. rad < 12.*CS%rad_max_wind) then - rad=(CS%rad_max_wind)*10. - if (BR_Bench) then - rkm = rad/1000. - rB = (US%L_to_m*rkm)**B +!> This function returns the air-sea drag coefficient using a simple function of the air-sea velocity difference. +function simple_wind_scaled_Cd(u10, du10, CS) result(Cd) + real, intent(in) :: U10 !< The 10 m wind speed [L T-1 ~> m s-1] + real, intent(in) :: du10 !< The magnitude of the difference between the 10 m wind + !! and the ocean flow [L T-1 ~> m s-1] + type(idealized_hurricane_CS), pointer :: CS !< Container for SCM parameters + real :: Cd ! Air-sea drag coefficient [nondim] + + ! Note that these expressions are discontinuous at dU10 = 11 and 20 m s-1. + if (dU10 < CS%calm_speed) then + Cd = CS%Cd_calm + elseif (dU10 < CS%windy_speed) then + if (CS%answer_date < 20190101) then + Cd = (CS%Cd_intercept + CS%dCd_dU10 * U10 )*0.001 else - rkm = rad - rB = (US%L_to_m*rad)**B + Cd = (CS%Cd_intercept + CS%dCd_dU10 * dU10 )*0.001 endif - U10 = ( sqrt( A*B*dP*exp(-A/rB)/(1.2*US%kg_m3_to_R*rB) + 0.25*(rkm*f_local)**2 ) - 0.5*rkm*f_local) & - * (12. - rad/CS%rad_max_wind)/2. else - U10 = 0. - endif - Adir = atan2(CS%dy_from_center,xx) - - !/ BR - ! Wind angle model following Zhang and Ulhorn (2012) - ! ALPH is inflow angle positive outward. - RSTR = min(10., rad / CS%rad_max_wind) - A0 = -0.9*RSTR - 0.09*US%L_T_to_m_s*CS%max_windspeed - 14.33 - A1 = -A0 *(0.04*RSTR + 0.05*US%L_T_to_m_s*CS%hurr_translation_spd + 0.14) - P1 = (6.88*RSTR - 9.60*US%L_T_to_m_s*CS%hurr_translation_spd + 85.31)*pie/180. - ALPH = A0 - A1*cos( (TRANSDIR - ADIR ) - P1) - if (rad > 10.*CS%rad_max_wind .AND. rad < 12.*CS%rad_max_wind) then - ALPH = ALPH* (12. - rad/CS%rad_max_wind)/2. - elseif (rad > 12.*CS%rad_max_wind) then - ALPH = 0.0 + Cd = CS%Cd_windy endif - ALPH = ALPH * Deg2Rad - !/BR - ! Prepare for wind calculation - ! X_TS is component of translation speed added to wind vector - ! due to background steering wind. - U_TS = CS%hurr_translation_spd*0.5*cos(transdir) - V_TS = CS%hurr_translation_spd*0.5*sin(transdir) - - ! Set the surface wind stresses, in [R L Z T-2 ~> Pa]. A positive taux - ! accelerates the ocean to the (pseudo-)east. - ! The i-loop extends to is-1 so that taux can be used later in the - ! calculation of ustar - otherwise the lower bound would be Isq. - do j=js,je ; do I=is-1,Ieq - !/BR - ! Turn off surface current for stress calculation to be - ! consistent with test case. - Uocn = 0. ! sfc_state%u(I,j) - Vocn = 0. ! 0.25*( (sfc_state%v(i,J) + sfc_state%v(i+1,J-1)) + & - ! (sfc_state%v(i+1,J) + sfc_state%v(i,J-1)) ) - !/BR - ! Wind vector calculated from location/direction (sin/cos flipped b/c - ! cyclonic wind is 90 deg. phase shifted from position angle). - dU = U10*sin(Adir-pie-Alph) - Uocn + U_TS - dV = U10*cos(Adir-Alph) - Vocn + V_TS - !/----------------------------------------------------| - !BR - ! Add a simple drag coefficient as a function of U10 | - !/----------------------------------------------------| - du10 = sqrt(du**2+dv**2) - if (dU10 < 11.0*US%m_s_to_L_T) then - Cd = 1.2e-3 - elseif (dU10 < 20.0*US%m_s_to_L_T) then - if (CS%answers_2018) then - Cd = (0.49 + 0.065 * US%L_T_to_m_s*U10 )*0.001 - else - Cd = (0.49 + 0.065 * US%L_T_to_m_s*dU10 )*0.001 - endif - else - Cd = 0.0018 - endif - forces%taux(I,j) = CS%rho_a * US%L_to_Z * G%mask2dCu(I,j) * Cd*du10*dU - enddo ; enddo - !/BR - ! See notes above - do J=js-1,Jeq ; do i=is,ie - Uocn = 0. ! 0.25*( (sfc_state%u(I,j) + sfc_state%u(I-1,j+1)) + & - ! (sfc_state%u(I-1,j) + sfc_state%u(I,j+1)) ) - Vocn = 0. ! sfc_state%v(i,J) - dU = U10*sin(Adir-pie-Alph) - Uocn + U_TS - dV = U10*cos(Adir-Alph) - Vocn + V_TS - du10=sqrt(du**2+dv**2) - if (dU10 < 11.0*US%m_s_to_L_T) then - Cd = 1.2e-3 - elseif (dU10 < 20.0*US%m_s_to_L_T) then - if (CS%answers_2018) then - Cd = (0.49 + 0.065 * US%L_T_to_m_s*U10 )*0.001 - else - Cd = (0.49 + 0.065 * US%L_T_to_m_s*dU10 )*0.001 - endif - else - Cd = 0.0018 - endif - forces%tauy(I,j) = CS%rho_a * US%L_to_Z * G%mask2dCv(I,j) * Cd*dU10*dV - enddo ; enddo - ! Set the surface friction velocity [Z T-1 ~> m s-1]. ustar is always positive. - do j=js,je ; do i=is,ie - ! This expression can be changed if desired, but need not be. - forces%ustar(i,j) = G%mask2dT(i,j) * sqrt(US%L_to_Z * (CS%gustiness/CS%Rho0 + & - sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & - 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0)) - enddo ; enddo -end subroutine SCM_idealized_hurricane_wind_forcing +end function simple_wind_scaled_Cd end module idealized_hurricane diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index 4c0c55f746..36ccf6115e 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -1,3 +1,7 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Configures the model for the Kelvin wave experiment. !! !! Kelvin = coastally-trapped Kelvin waves from the ROMS examples. @@ -5,20 +9,17 @@ !! radiate out at the east. module Kelvin_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE -use MOM_open_boundary, only : OBC_segment_type, register_OBC -use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_E -use MOM_open_boundary, only : OBC_DIRECTION_S, OBC_DIRECTION_W +use MOM_open_boundary, only : OBC_segment_type, register_OBC, rotate_OBC_segment_direction +use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_E, OBC_DIRECTION_S, OBC_DIRECTION_W use MOM_open_boundary, only : OBC_registry_type -use MOM_unit_scaling, only : unit_scale_type +use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type -use MOM_time_manager, only : time_type, time_type_to_real +use MOM_time_manager, only : time_type, time_to_real implicit none ; private @@ -35,13 +36,21 @@ module Kelvin_initialization !> Control structure for Kelvin wave open boundaries. type, public :: Kelvin_OBC_CS ; private integer :: mode = 0 !< Vertical mode - real :: coast_angle = 0 !< Angle of coastline [rad] - real :: coast_offset1 = 0 !< Longshore distance to coastal angle [L ~> m] - real :: coast_offset2 = 0 !< Longshore distance to coastal angle [L ~> m] - real :: H0 = 0 !< Bottom depth [Z ~> m] - real :: F_0 !< Coriolis parameter [T-1 ~> s-1] - real :: rho_range !< Density range [R ~> kg m-3] - real :: rho_0 !< Mean density [R ~> kg m-3] + real :: coast_angle = 0 !< Angle of coastline [rad] + real :: coast_offset1 = 0 !< Longshore distance to coastal angle [L ~> m] + real :: coast_offset2 = 0 !< Offshore distance to coastal angle [L ~> m] + real :: H0 = 0 !< Bottom depth [Z ~> m] + real :: F_0 !< Coriolis parameter [T-1 ~> s-1] + real :: rho_range !< Density range [R ~> kg m-3] + real :: rho_0 !< Mean density [R ~> kg m-3] + real :: wave_period !< Period of the mode-0 waves [T ~> s] + real :: ssh_amp !< Amplitude of the sea surface height forcing for mode-0 waves [Z ~> m] + real :: inflow_amp !< Amplitude of the boundary velocity forcing for internal waves [L T-1 ~> m s-1] + real :: OBC_nudging_time !< The timescale with which the inflowing open boundary velocities are nudged toward + !! their intended values with the Kelvin wave test case [T ~> s], or a negative + !! value to retain the value that is set when the OBC segments are initialized. + logical :: indexing_bugs !< If true, retain several horizontal indexing bugs that were in the + !! original version of Kelvin_set_OBC_data. end type Kelvin_OBC_CS ! This include declares and sets the variable "version". @@ -50,14 +59,15 @@ module Kelvin_initialization contains !> Add Kelvin wave to OBC registry. -function register_Kelvin_OBC(param_file, CS, US, OBC_Reg) +logical function register_Kelvin_OBC(param_file, CS, US, OBC_Reg) type(param_file_type), intent(in) :: param_file !< parameter file. type(Kelvin_OBC_CS), pointer :: CS !< Kelvin wave control structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(OBC_registry_type), pointer :: OBC_Reg !< OBC registry. ! Local variables - logical :: register_Kelvin_OBC + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. character(len=40) :: mdl = "register_Kelvin_OBC" !< This subroutine's name. character(len=32) :: casename = "Kelvin wave" !< This case's name. character(len=200) :: config @@ -75,7 +85,7 @@ function register_Kelvin_OBC(param_file, CS, US, OBC_Reg) default=0) call get_param(param_file, mdl, "F_0", CS%F_0, & default=0.0, units="s-1", scale=US%T_to_s, do_not_log=.true.) - call get_param(param_file, mdl, "TOPO_CONFIG", config, do_not_log=.true.) + call get_param(param_file, mdl, "TOPO_CONFIG", config, fail_if_missing=.true., do_not_log=.true.) if (trim(config) == "Kelvin") then call get_param(param_file, mdl, "ROTATED_COAST_OFFSET_1", CS%coast_offset1, & "The distance along the southern and northern boundaries "//& @@ -87,22 +97,49 @@ function register_Kelvin_OBC(param_file, CS, US, OBC_Reg) units="km", default=10.0, scale=1.0e3*US%m_to_L) call get_param(param_file, mdl, "ROTATED_COAST_ANGLE", CS%coast_angle, & "The angle of the southern bondary beyond X=ROTATED_COAST_OFFSET.", & - units="degrees", default=11.3) - CS%coast_angle = CS%coast_angle * (atan(1.0)/45.) ! Convert to radians + units="degrees", default=11.3, scale=atan(1.0)/45.) ! Convert to radians + else + CS%coast_offset1 = 0.0 ; CS%coast_offset2 = 0.0 ; CS%coast_angle = 0.0 endif - if (CS%mode /= 0) then + if (CS%mode == 0) then + call get_param(param_file, mdl, "KELVIN_WAVE_PERIOD", CS%wave_period, & + "The period of the Kelvin wave forcing at the open boundaries. "//& + "The default value is the M2 tide period.", & + units="s", default=12.42*3600.0, scale=US%s_to_T) + call get_param(param_file, mdl, "KELVIN_WAVE_SSH_AMP", CS%ssh_amp, & + "The amplitude of the Kelvin wave sea surface height anomaly forcing "//& + "at the open boundaries.", units="m", default=1.0, scale=US%m_to_Z) + else call get_param(param_file, mdl, "DENSITY_RANGE", CS%rho_range, & - default=2.0, do_not_log=.true., scale=US%kg_m3_to_R) + units="kg m-3", default=2.0, scale=US%kg_m3_to_R, do_not_log=.true.) call get_param(param_file, mdl, "RHO_0", CS%rho_0, & - default=1035.0, do_not_log=.true., scale=US%kg_m3_to_R) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R, do_not_log=.true.) call get_param(param_file, mdl, "MAXIMUM_DEPTH", CS%H0, & - default=1000.0, do_not_log=.true., scale=US%m_to_Z) + units="m", default=1000.0, scale=US%m_to_Z, do_not_log=.true.) + call get_param(param_file, mdl, "KELVIN_WAVE_INFLOW_AMP", CS%inflow_amp, & + "The amplitude of the Kelvin wave sea surface inflow velocity forcing "//& + "at the open boundaries.", units="m s-1", default=1.0, scale=US%m_s_to_L_T) endif + call get_param(param_file, mdl, "KELVIN_WAVE_VEL_NUDGING_TIMESCALE", CS%OBC_nudging_time, & + "The timescale with which the inflowing open boundary velocities are nudged toward "//& + "their intended values with the Kelvin wave test case, or a negative value to keep "//& + "the value that is set when the OBC segments are initialized.", & + units="s", default=-1.0, scale=US%s_to_T) + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. + call get_param(param_file, mdl, "KELVIN_SET_OBC_INDEXING_BUGS", CS%indexing_bugs, & + "If true, retain several horizontal indexing bugs that were in the original "//& + "version of Kelvin_set_OBC_data.", default=enable_bugs) + ! Register the Kelvin open boundary. call register_OBC(casename, param_file, OBC_Reg) register_Kelvin_OBC = .true. + ! TODO: Revisit and correct the internal Kelvin wave test case. + ! Specifically, using wave_speed() and investigating adding eta_anom + ! noted in the comments below. + end function register_Kelvin_OBC !> Clean up the Kelvin wave OBC from registry. @@ -119,16 +156,17 @@ end subroutine Kelvin_OBC_end subroutine Kelvin_initialize_topography(D, G, param_file, max_depth, US) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth [m ~> Z] + intent(out) :: D !< Ocean bottom depth [Z ~> m] type(param_file_type), intent(in) :: param_file !< Parameter file structure real, intent(in) :: max_depth !< Maximum model depth [Z ~> m] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables character(len=40) :: mdl = "Kelvin_initialize_topography" ! This subroutine's name. - real :: min_depth ! The minimum and maximum depths [Z ~> m]. - real :: PI ! 3.1415... - real :: coast_offset1, coast_offset2, coast_angle, right_angle + real :: min_depth ! The minimum and maximum depths [Z ~> m]. + real :: coast_angle ! Angle of coastline [rad] + real :: coast_offset1 ! Longshore distance to coastal angle [L ~> m] + real :: coast_offset2 ! Offshore distance to coastal angle [L ~> m] integer :: i, j call MOM_mesg(" Kelvin_initialization.F90, Kelvin_initialize_topography: setting topography", 5) @@ -136,26 +174,23 @@ subroutine Kelvin_initialize_topography(D, G, param_file, max_depth, US) call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & "The minimum depth of the ocean.", units="m", default=0.0, scale=US%m_to_Z) call get_param(param_file, mdl, "ROTATED_COAST_OFFSET_1", coast_offset1, & - default=100.0, do_not_log=.true.) + units="km", default=100.0, do_not_log=.true.) call get_param(param_file, mdl, "ROTATED_COAST_OFFSET_2", coast_offset2, & - default=10.0, do_not_log=.true.) + units="km", default=10.0, do_not_log=.true.) call get_param(param_file, mdl, "ROTATED_COAST_ANGLE", coast_angle, & - default=11.3, do_not_log=.true.) - - coast_angle = coast_angle * (atan(1.0)/45.) ! Convert to radians - right_angle = 2 * atan(1.0) + units="degrees", default=11.3, scale=(atan(1.0)/45.), do_not_log=.true.) ! Convert to radians do j=G%jsc,G%jec ; do i=G%isc,G%iec D(i,j) = max_depth ! Southern side if ((G%geoLonT(i,j) - G%west_lon > coast_offset1) .AND. & (atan2(G%geoLatT(i,j) - G%south_lat + coast_offset2, & - G%geoLonT(i,j) - G%west_lon - coast_offset1) < coast_angle)) & + G%geoLonT(i,j) - G%west_lon - coast_offset1) < coast_angle)) & D(i,j) = 0.5*min_depth ! Northern side if ((G%geoLonT(i,j) - G%west_lon < G%len_lon - coast_offset1) .AND. & (atan2(G%len_lat + G%south_lat + coast_offset2 - G%geoLatT(i,j), & - G%len_lon + G%west_lon - coast_offset1 - G%geoLonT(i,j)) < coast_angle)) & + G%len_lon + G%west_lon - coast_offset1 - G%geoLonT(i,j)) < coast_angle)) & D(i,j) = 0.5*min_depth if (D(i,j) > max_depth) D(i,j) = max_depth @@ -180,21 +215,29 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) real :: time_sec ! The time in the run [T ~> s] real :: cff ! The wave speed [L T-1 ~> m s-1] real :: N0 ! Brunt-Vaisala frequency times a rescaling of slopes [L Z-1 T-1 ~> s-1] - real :: lambda ! Offshore decay scale [L-1 ~> m-1] + real :: lambda ! Offshore decay scale, i.e. the inverse of the deformation radius of a mode [L-1 ~> m-1] real :: omega ! Wave frequency [T-1 ~> s-1] - real :: PI + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] real :: depth_tot(SZI_(G),SZJ_(G)) ! The total depth of the ocean [Z ~> m] - integer :: i, j, k, n, is, ie, js, je, isd, ied, jsd, jed, nz - integer :: IsdB, IedB, JsdB, JedB + real :: depth_tot_vel ! The total depth of the ocean at a velocity point [Z ~> m] + real :: depth_tot_corner ! The total depth of the ocean at a vorticity point [Z ~> m] + real :: Cor_vel ! The Coriolis parameter interpolated to a velocity point [T-1 ~> s-1] real :: mag_SSH ! An overall magnitude of the external wave sea surface height at the coastline [Z ~> m] - real :: mag_int ! An overall magnitude of the internal wave at the coastline [L2 T-2 ~> m2 s-2] + real :: mag_int ! An overall magnitude of the internal wave at the coastline [L T-1 ~> m s-1] real :: x1, y1 ! Various positions [L ~> m] real :: x, y ! Various positions [L ~> m] - real :: val1 ! The periodicity factor [nondim] + real :: sin_wt ! The sine-based periodicity factor [nondim] + real :: cos_wt ! The cosine-based periodicity factor [nondim] real :: val2 ! The local wave amplitude [Z ~> m] real :: km_to_L_scale ! A scaling factor from longitudes in km to L [L km-1 ~> 1e3] real :: sina, cosa ! The sine and cosine of the coast angle [nondim] + real :: normal_sign ! A variable that corrects the sign of normal velocities for rotation [nondim] + real :: trans_sign ! A variable that corrects the sign of transverse velocities for rotation [nondim] type(OBC_segment_type), pointer :: segment => NULL() + integer :: unrot_dir ! The unrotated direction of the segment + integer :: turns ! Number of index quarter turns + integer :: i, j, k, n, is, ie, js, je, isd, ied, jsd, jed, nz + integer :: IsdB, IedB, JsdB, JedB, isq, ieq, jsq, jeq, is_vel, ie_vel, js_vel, je_vel 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 @@ -202,10 +245,16 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) if (.not.associated(OBC)) call MOM_error(FATAL, 'Kelvin_initialization.F90: '// & 'Kelvin_set_OBC_data() was called but OBC type was not initialized!') + if (G%grid_unit_to_L <= 0.) call MOM_error(FATAL, 'Kelvin_initialization.F90: '// & + "Kelvin_set_OBC_data() is only set to work with Cartesian axis units.") - time_sec = US%s_to_T*time_type_to_real(Time) + time_sec = time_to_real(Time, scale=US%s_to_T) PI = 4.0*atan(1.0) - km_to_L_scale = 1000.0*US%m_to_L + + turns = modulo(G%HI%turns, 4) + + if (CS%indexing_bugs .and. (turns /= 0)) call MOM_error(FATAL, & + "Kelvin_set_OBC_data does not support grid rotation when KELVIN_SET_OBC_INDEXING_BUGS is true.") do j=jsd,jed ; do i=isd,ied depth_tot(i,j) = 0.0 @@ -215,146 +264,265 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) enddo ; enddo ; enddo if (CS%mode == 0) then - mag_SSH = 1.0*US%m_to_Z - omega = 2.0 * PI / (12.42 * 3600.0*US%s_to_T) ! M2 Tide period - val1 = sin(omega * time_sec) + mag_SSH = CS%ssh_amp + omega = 2.0 * PI / CS%wave_period + sin_wt = sin(omega * time_sec) else - mag_int = 1.0*US%m_s_to_L_T**2 + mag_int = CS%inflow_amp N0 = sqrt((CS%rho_range / CS%rho_0) * (GV%g_Earth / CS%H0)) lambda = PI * CS%mode * CS%F_0 / (CS%H0 * N0) ! Two wavelengths in domain - omega = (4.0 * CS%H0 * N0) / (CS%mode * US%m_to_L*G%len_lon) + omega = (4.0 * CS%H0 * N0) / (CS%mode * (G%grid_unit_to_L*G%len_lon)) + ! If the modal wave speed were calculated via wave_speeds(), we should have + ! lambda = CS%F_0 / CS%cg_mode + ! omega = (4.0 * PI / (G%grid_unit_to_L*G%len_lon)) * CS%cg_mode endif + cos_wt = cos(omega * time_sec) sina = sin(CS%coast_angle) cosa = cos(CS%coast_angle) do n=1,OBC%number_of_segments segment => OBC%segment(n) if (.not. segment%on_pe) cycle + + unrot_dir = segment%direction + if (turns /= 0) unrot_dir = rotate_OBC_segment_direction(segment%direction, -turns) + ! Apply values to the inflow end only. - if (segment%direction == OBC_DIRECTION_E) cycle - if (segment%direction == OBC_DIRECTION_N) cycle - - ! This should be somewhere else... - !### This is supposed to be a timescale [T ~> s] but appears to be a rate in [s-1]. - segment%Velocity_nudging_timescale_in = US%s_to_T * 1.0/(0.3*86400) - - if (segment%direction == OBC_DIRECTION_W) then - IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB - jsd = segment%HI%jsd ; jed = segment%HI%jed - JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB - do j=jsd,jed ; do I=IsdB,IedB - x1 = km_to_L_scale * G%geoLonCu(I,j) - y1 = km_to_L_scale * G%geoLatCu(I,j) + if ((unrot_dir == OBC_DIRECTION_E) .or. (unrot_dir == OBC_DIRECTION_N)) cycle + + ! Set variables that correct for sign changes during rotation. + normal_sign = 1.0 + if ( (segment%is_E_or_W .and. ((turns == 1) .or. (turns == 2))) .or. & + (segment%is_N_or_S .and. ((turns == 2) .or. (turns == 3))) ) normal_sign = -1.0 + + ! If OBC_nudging_time is negative, the value of Velocity_nudging_timescale_in that was set + ! when the segments are initialized is retained. + if (CS%OBC_nudging_time >= 0.0) segment%Velocity_nudging_timescale_in = CS%OBC_nudging_time + + isd = segment%HI%isd ; ied = segment%HI%ied ; IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + jsd = segment%HI%jsd ; jed = segment%HI%jed ; JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + + if (unrot_dir == OBC_DIRECTION_W) then + if (segment%is_E_or_W) then + is_vel = IsdB ; ie_vel = IedB ; js_vel = jsd ; je_vel = jed + else + is_vel = isd ; ie_vel = ied ; js_vel = JsdB ; je_vel = JedB + endif + do j=js_vel,je_vel ; do I=is_vel,ie_vel + if (segment%is_E_or_W) then + x1 = G%grid_unit_to_L * G%geoLonCu(I,j) + y1 = G%grid_unit_to_L * G%geoLatCu(I,j) + else + x1 = G%grid_unit_to_L * G%geoLonCv(i,J) + y1 = G%grid_unit_to_L * G%geoLatCv(i,J) + endif x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = -(x1 - CS%coast_offset1) * sina + y1 * cosa if (CS%mode == 0) then ! Use inside bathymetry - cff = sqrt(GV%g_Earth * depth_tot(i+1,j) ) - val2 = mag_SSH * exp(- CS%F_0 * y / cff) - segment%eta(I,j) = GV%Z_to_H*val2 * cos(omega * time_sec) - segment%normal_vel_bt(I,j) = val2 * (val1 * cff * cosa / depth_tot(i+1,j) ) + if (segment%direction == OBC_DIRECTION_W) then + depth_tot_vel = depth_tot(i+1,j) + Cor_vel = 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1)) + elseif (segment%direction == OBC_DIRECTION_S) then + depth_tot_vel = depth_tot(i,j+1) + Cor_vel = 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) + elseif (segment%direction == OBC_DIRECTION_E) then + depth_tot_vel = depth_tot(i,j) + Cor_vel = 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1)) + elseif (segment%direction == OBC_DIRECTION_N) then + depth_tot_vel = depth_tot(i,j) + Cor_vel = 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) + endif + cff = sqrt(GV%g_Earth * depth_tot_vel ) + val2 = mag_SSH * exp(- Cor_vel * y / cff) + segment%SSH(I,j) = val2 * cos_wt + segment%normal_vel_bt(I,j) = (normal_sign*val2) * (sin_wt * cff * cosa / depth_tot_vel ) if (segment%nudged) then do k=1,nz - segment%nudged_normal_vel(I,j,k) = val2 * (val1 * cff * cosa / depth_tot(i+1,j) ) + segment%nudged_normal_vel(I,j,k) = (normal_sign*val2) * (sin_wt * cff * cosa / depth_tot_vel ) enddo elseif (segment%specified) then do k=1,nz - segment%normal_vel(I,j,k) = val2 * (val1 * cff * cosa / depth_tot(i+1,j) ) - segment%normal_trans(I,j,k) = segment%normal_vel(I,j,k) * h(i+1,j,k) * G%dyCu(I,j) + segment%normal_vel(I,j,k) = (normal_sign*val2) * (sin_wt * cff * cosa / depth_tot_vel ) enddo endif else ! Baroclinic, not rotated yet - segment%eta(I,j) = 0.0 + segment%SSH(I,j) = 0.0 segment%normal_vel_bt(I,j) = 0.0 + ! Use inside bathymetry + if (segment%direction == OBC_DIRECTION_W) then + depth_tot_vel = depth_tot(i+1,j) + elseif (segment%direction == OBC_DIRECTION_S) then + depth_tot_vel = depth_tot(i,j+1) + elseif (segment%direction == OBC_DIRECTION_E) then + depth_tot_vel = depth_tot(i,j) + elseif (segment%direction == OBC_DIRECTION_N) then + depth_tot_vel = depth_tot(i,j) + endif + ! I suspect that the velocities in both of the following loops should instead be + ! normal_vel(I,j,k) = CS%inflow_amp * CS%u_struct(k) * exp(-lambda * y) * cos_wt + ! In addition, there should be a specification of the interface-height anomalies at the + ! open boundaries that are specified as something like + ! eta_anom(I,j,K) = (CS%inflow_amp*depth_tot/CS%cg_mode) * CS%w_struct(K) * & + ! exp(-lambda * y) * cos_wt + ! In these expressions CS%u_struct and CS%w_struct could be returned from the subroutine wave_speeds + ! in MOM_wave_speed() based on the horizontally uniform initial state. if (segment%nudged) then do k=1,nz - segment%nudged_normal_vel(I,j,k) = mag_int * lambda / CS%F_0 * & - exp(-lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * & - cos(omega * time_sec) + segment%nudged_normal_vel(I,j,k) = (normal_sign*mag_int) * & + exp(-lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * cos_wt enddo elseif (segment%specified) then do k=1,nz - segment%normal_vel(I,j,k) = mag_int * lambda / CS%F_0 * & - exp(-lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * & - cos(omega * time_sec) - segment%normal_trans(I,j,k) = segment%normal_vel(I,j,k) * h(i+1,j,k) * G%dyCu(I,j) + segment%normal_vel(I,j,k) = (normal_sign*mag_int) * & + exp(-lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * cos_wt enddo endif + if (associated(segment%h_Reg)) then + if (allocated(segment%h_Reg%h)) then + do k=1,nz + segment%h_Reg%h(I,j,k) = depth_tot_vel / nz + & + ((CS%mode * PI) * CS%inflow_amp / (N0 * nz)) * & + cos(((PI * k) * CS%mode) / nz) * & + exp(-lambda * y) * cos_wt + enddo + endif + endif endif enddo ; enddo - if (allocated(segment%tangential_vel)) then - do J=JsdB+1,JedB-1 ; do I=IsdB,IedB - x1 = km_to_L_scale * G%geoLonBu(I,J) - y1 = km_to_L_scale * G%geoLatBu(I,J) - x = (x1 - CS%coast_offset1) * cosa + y1 * sina - y = - (x1 - CS%coast_offset1) * sina + y1 * cosa - cff = sqrt(GV%g_Earth * depth_tot(i+1,j) ) - val2 = mag_SSH * exp(- CS%F_0 * y / cff) - if (CS%mode == 0) then ; do k=1,nz - segment%tangential_vel(I,J,k) = (val1 * val2 * cff * sina) / & - ( 0.5*(depth_tot(i+1,j+1) + depth_tot(i+1,j) ) ) + endif - enddo ; endif - enddo ; enddo + if (unrot_dir == OBC_DIRECTION_S) then + if (segment%is_E_or_W) then + is_vel = IsdB ; ie_vel = IedB ; js_vel = jsd ; je_vel = jed + else + is_vel = isd ; ie_vel = ied ; js_vel = JsdB ; je_vel = JedB endif - else ! Must be south - isd = segment%HI%isd ; ied = segment%HI%ied - JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB - do J=JsdB,JedB ; do i=isd,ied - x1 = km_to_L_scale * G%geoLonCv(i,J) - y1 = km_to_L_scale * G%geoLatCv(i,J) + do J=js_vel,je_vel ; do i=is_vel,ie_vel + if (segment%is_E_or_W) then + x1 = G%grid_unit_to_L * G%geoLonCu(I,j) + y1 = G%grid_unit_to_L * G%geoLatCu(I,j) + else + x1 = G%grid_unit_to_L * G%geoLonCv(i,J) + y1 = G%grid_unit_to_L * G%geoLatCv(i,J) + endif x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa if (CS%mode == 0) then - cff = sqrt(GV%g_Earth * depth_tot(i,j+1) ) - val2 = mag_SSH * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * y / cff) - segment%eta(I,j) = GV%Z_to_H*val2 * cos(omega * time_sec) - segment%normal_vel_bt(I,j) = (val1 * cff * sina / depth_tot(i,j+1) ) * val2 + if (segment%direction == OBC_DIRECTION_W) then + depth_tot_vel = depth_tot(i+1,j) + Cor_vel = 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1)) + elseif (segment%direction == OBC_DIRECTION_S) then + depth_tot_vel = depth_tot(i,j+1) + Cor_vel = 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) + elseif (segment%direction == OBC_DIRECTION_E) then + depth_tot_vel = depth_tot(i,j) + Cor_vel = 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1)) + elseif (segment%direction == OBC_DIRECTION_N) then + depth_tot_vel = depth_tot(i,j) + Cor_vel = 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) + endif + cff = sqrt(GV%g_Earth * depth_tot_vel ) + val2 = mag_SSH * exp(- Cor_vel * y / cff) + segment%SSH(I,j) = val2 * cos_wt + segment%normal_vel_bt(I,j) = (sin_wt * cff * sina / depth_tot_vel ) * (normal_sign*val2) if (segment%nudged) then do k=1,nz - segment%nudged_normal_vel(I,j,k) = (val1 * cff * sina / depth_tot(i,j+1)) * val2 + segment%nudged_normal_vel(I,j,k) = (sin_wt * cff * sina / depth_tot_vel) * (normal_sign*val2) enddo elseif (segment%specified) then do k=1,nz - segment%normal_vel(I,j,k) = (val1 * cff * sina / depth_tot(i,j+1) ) * val2 - segment%normal_trans(i,J,k) = segment%normal_vel(i,J,k) * h(i,j+1,k) * G%dxCv(i,J) + segment%normal_vel(I,j,k) = (sin_wt * cff * sina / depth_tot_vel ) * (normal_sign*val2) enddo endif else - ! Not rotated yet - segment%eta(i,J) = 0.0 + ! Not rotated yet (also see the notes above on how this case might be improved) + segment%SSH(i,J) = 0.0 segment%normal_vel_bt(i,J) = 0.0 if (segment%nudged) then do k=1,nz - segment%nudged_normal_vel(i,J,k) = mag_int * lambda / CS%F_0 * & + segment%nudged_normal_vel(i,J,k) = (normal_sign*mag_int) * & exp(- lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * cosa + ! This is missing cos_wt enddo elseif (segment%specified) then do k=1,nz - segment%normal_vel(i,J,k) = mag_int * lambda / CS%F_0 * & + segment%normal_vel(i,J,k) = (normal_sign*mag_int) * & exp(- lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * cosa - segment%normal_trans(i,J,k) = segment%normal_vel(i,J,k) * h(i,j+1,k) * G%dxCv(i,J) + ! This is missing cos_wt enddo endif endif enddo ; enddo - if (allocated(segment%tangential_vel)) then - do J=JsdB,JedB ; do I=IsdB+1,IedB-1 - x1 = km_to_L_scale * G%geoLonBu(I,J) - y1 = km_to_L_scale * G%geoLatBu(I,J) + endif + + if (allocated(segment%tangential_vel)) then + trans_sign = 1.0 + if (segment%is_E_or_W) then + Isq = IsdB ; Ieq = IedB ; Jsq = JsdB+1 ; Jeq = JedB-1 + if ((turns == 2) .or. (turns == 3)) trans_sign = -1.0 + else + Isq = IsdB+1 ; Ieq = IedB-1 ; Jsq = JsdB ; Jeq = JedB + if ((turns == 1) .or. (turns == 2)) trans_sign = -1.0 + endif + + if ((unrot_dir == OBC_DIRECTION_W) .or. (unrot_dir == OBC_DIRECTION_S)) then + do J=Jsq,Jeq ; do I=Isq,Ieq + if (segment%direction == OBC_DIRECTION_W) then + depth_tot_corner = 0.5*(depth_tot(i+1,j+1) + depth_tot(i+1,j)) + elseif (segment%direction == OBC_DIRECTION_E) then + depth_tot_corner = 0.5*(depth_tot(i,j+1) + depth_tot(i,j)) + elseif (segment%direction == OBC_DIRECTION_S) then + depth_tot_corner = 0.5*(depth_tot(i+1,j+1) + depth_tot(i,j+1)) + elseif (segment%direction == OBC_DIRECTION_N) then + depth_tot_corner = 0.5*(depth_tot(i+1,j) + depth_tot(i,j)) + endif + x1 = G%grid_unit_to_L * G%geoLonBu(I,J) + y1 = G%grid_unit_to_L * G%geoLatBu(I,J) x = (x1 - CS%coast_offset1) * cosa + y1 * sina y = - (x1 - CS%coast_offset1) * sina + y1 * cosa - cff = sqrt(GV%g_Earth * depth_tot(i,j+1) ) - val2 = mag_SSH * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * y / cff) + cff = sqrt(GV%g_Earth * depth_tot_corner ) + val2 = (trans_sign*mag_SSH) * exp(- G%CoriolisBu(I,J) * y / cff) + if (CS%indexing_bugs) then + if (unrot_dir == OBC_DIRECTION_W) then + cff = sqrt(GV%g_Earth * depth_tot(i+1,j) ) + val2 = (trans_sign*mag_SSH) * exp(- G%CoriolisBu(I,J) * y / cff) + endif + if (unrot_dir == OBC_DIRECTION_S) then + cff = sqrt(GV%g_Earth * depth_tot(i,j+1) ) + val2 = (trans_sign*mag_SSH) * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * y / cff) + endif + endif if (CS%mode == 0) then ; do k=1,nz - segment%tangential_vel(I,J,k) = (val1 * val2 * cff * sina) / & - ( 0.5*(depth_tot(i+1,j+1) + depth_tot(i,j+1)) ) + segment%tangential_vel(I,J,k) = (sin_wt * val2 * cff * sina) / depth_tot_corner enddo ; endif enddo ; enddo endif endif + + if (segment%specified .and. (.not.segment%nudged) .and. & + ((unrot_dir == OBC_DIRECTION_S) .or. (unrot_dir == OBC_DIRECTION_W))) then + if (segment%direction == OBC_DIRECTION_W) then + do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB + segment%normal_trans(I,j,k) = segment%normal_vel(I,j,k) * h(i+1,j,k) * G%dyCu(I,j) + enddo ; enddo ; enddo + elseif (segment%direction == OBC_DIRECTION_E) then + do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB + segment%normal_trans(I,j,k) = segment%normal_vel(I,j,k) * h(i,j,k) * G%dyCu(I,j) + enddo ; enddo ; enddo + elseif (segment%direction == OBC_DIRECTION_S) then + do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied + segment%normal_trans(i,J,k) = segment%normal_vel(i,J,k) * h(i,j+1,k) * G%dxCv(i,J) + enddo ; enddo ; enddo + elseif (segment%direction == OBC_DIRECTION_N) then + do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied + segment%normal_trans(i,J,k) = segment%normal_vel(i,J,k) * h(i,j,k) * G%dxCv(i,J) + enddo ; enddo ; enddo + endif + endif + enddo end subroutine Kelvin_set_OBC_data diff --git a/src/user/MOM_controlled_forcing.F90 b/src/user/MOM_controlled_forcing.F90 index d136d58a19..dde4a2dd39 100644 --- a/src/user/MOM_controlled_forcing.F90 +++ b/src/user/MOM_controlled_forcing.F90 @@ -1,3 +1,7 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Use control-theory to adjust the surface heat flux and precipitation. !! !! Adjustments are based on the time-mean or periodically (seasonally) varying @@ -6,8 +10,6 @@ !! The techniques behind this are described in Hallberg and Adcroft (2018, in prep.). module MOM_controlled_forcing -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_diag_mediator, only : post_data, query_averaging_enabled, enable_averages, disable_averaging use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr use MOM_domains, only : pass_var, pass_vector, AGRID, To_South, To_West, To_All @@ -42,11 +44,11 @@ module MOM_controlled_forcing real :: Len2 !< The square of the length scale over which the anomalies !! are smoothed via a Laplacian filter [L2 ~> m2] real :: lam_heat !< A constant of proportionality between SST anomalies - !! and heat fluxes [Q R Z T-1 degC-1 ~> W m-2 degC-1] + !! and heat fluxes [Q R Z T-1 C-1 ~> W m-2 degC-1] real :: lam_prec !< A constant of proportionality between SSS anomalies !! (normalised by mean SSS) and precipitation [R Z T-1 ~> kg m-2 s-1] real :: lam_cyc_heat !< A constant of proportionality between cyclical SST - !! anomalies and corrective heat fluxes [Q R Z T-1 degC-1 ~> W m-2 degC-1] + !! anomalies and corrective heat fluxes [Q R Z T-1 C-1 ~> W m-2 degC-1] real :: lam_cyc_prec !< A constant of proportionality between cyclical SSS !! anomalies (normalised by mean SSS) and corrective !! precipitation [R Z T-1 ~> kg m-2 s-1] @@ -71,17 +73,17 @@ module MOM_controlled_forcing !! the actual averages, and not time integrals. !! The dimension is the periodic bins. real, pointer, dimension(:,:,:) :: & - avg_SST_anom => NULL(), & !< The time-averaged periodic sea surface temperature anomalies [degC], + avg_SST_anom => NULL(), & !< The time-averaged periodic sea surface temperature anomalies [C ~> degC], !! or (at some points in the code), the time-integrated periodic - !! temperature anomalies [T degC ~> s degC]. + !! temperature anomalies [T C ~> s degC]. !! The third dimension is the periodic bins. - avg_SSS_anom => NULL(), & !< The time-averaged periodic sea surface salinity anomalies [ppt], + avg_SSS_anom => NULL(), & !< The time-averaged periodic sea surface salinity anomalies [S ~> ppt], !! or (at some points in the code), the time-integrated periodic - !! salinity anomalies [T ppt ~> s ppt]. + !! salinity anomalies [T S ~> s ppt]. !! The third dimension is the periodic bins. - avg_SSS => NULL() !< The time-averaged periodic sea surface salinities [ppt], or (at + avg_SSS => NULL() !< The time-averaged periodic sea surface salinities [S ~> ppt], or (at !! some points in the code), the time-integrated periodic - !! salinities [T ppt ~> s ppt]. + !! salinities [T S ~> s ppt]. !! The third dimension is the periodic bins. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to @@ -96,9 +98,9 @@ module MOM_controlled_forcing subroutine apply_ctrl_forcing(SST_anom, SSS_anom, SSS_mean, virt_heat, virt_precip, & day_start, dt, G, US, CS) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: SST_anom !< The sea surface temperature anomalies [degC] - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: SSS_anom !< The sea surface salinity anomlies [ppt] - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: SSS_mean !< The mean sea surface salinity [ppt] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: SST_anom !< The sea surface temperature anomalies [C ~> degC] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: SSS_anom !< The sea surface salinity anomlies [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: SSS_mean !< The mean sea surface salinity [S ~> ppt] real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: virt_heat !< Virtual (corrective) heat !! fluxes that are augmented in this !! subroutine [Q R Z T-1 ~> W m-2] @@ -270,8 +272,8 @@ subroutine apply_ctrl_forcing(SST_anom, SSS_anom, SSS_mean, virt_heat, virt_prec ! Accumulate the average anomalies for this period. dt_wt = wt_per1 * dt CS%avg_time(m_mid) = CS%avg_time(m_mid) + dt_wt - ! These loops temporarily change the units of the CS%avg_ variables to [degC T ~> degC s] - ! or [ppt T ~> ppt s]. + ! These loops temporarily change the units of the CS%avg_ variables to [C T ~> degC s] + ! or [S T ~> ppt s]. do j=js,je ; do i=is,ie CS%avg_SST_anom(i,j,m_mid) = CS%avg_SST_anom(i,j,m_mid) + & dt_wt * G%mask2dT(i,j) * SST_anom(i,j) @@ -296,7 +298,7 @@ subroutine apply_ctrl_forcing(SST_anom, SSS_anom, SSS_mean, virt_heat, virt_prec m_u2 = periodic_int(m_st - 3.0, CS%num_cycle) m_u3 = periodic_int(m_st - 2.0, CS%num_cycle) - ! These loops restore the units of the CS%avg variables to [degC] or [ppt] + ! These loops restore the units of the CS%avg variables to [C ~> degC] or [S ~> ppt] if (CS%avg_time(m_u1) > 0.0) then do j=js,je ; do i=is,ie CS%avg_SST_anom(i,j,m_u1) = CS%avg_SST_anom(i,j,m_u1) / CS%avg_time(m_u1) @@ -397,7 +399,7 @@ end subroutine apply_ctrl_forcing !> This function maps rval into an integer in the range from 1 to num_period. function periodic_int(rval, num_period) result (m) - real, intent(in) :: rval !< Input for mapping. + real, intent(in) :: rval !< Input for mapping [nondim] integer, intent(in) :: num_period !< Maximum output. integer :: m !< Return value. @@ -412,9 +414,9 @@ function periodic_int(rval, num_period) result (m) !> This function shifts rval by an integer multiple of num_period so that !! 0 <= val_out < num_period. function periodic_real(rval, num_period) result(val_out) - real, intent(in) :: rval !< Input to be shifted into valid range. + real, intent(in) :: rval !< Input to be shifted into valid range [nondim] integer, intent(in) :: num_period !< Maximum valid value. - real :: val_out !< Return value. + real :: val_out !< Return value [nondim] integer :: nshft if (rval < 0) then ; nshft = floor(abs(rval) / num_period) + 1 @@ -427,8 +429,9 @@ function periodic_real(rval, num_period) result(val_out) !> This subroutine is used to allocate and register any fields in this module !! that should be written to or read from the restart file. -subroutine register_ctrl_forcing_restarts(G, param_file, CS, restart_CS) +subroutine register_ctrl_forcing_restarts(G, US, param_file, CS, restart_CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure indicating the !! open file to parse for model !! parameter values. @@ -469,9 +472,11 @@ subroutine register_ctrl_forcing_restarts(G, param_file, CS, restart_CS) allocate(CS%precip_0(isd:ied,jsd:jed), source=0.0) call register_restart_field(CS%heat_0, "Ctrl_heat", .false., restart_CS, & - longname="Control Integrative Heating", units="W m-2", z_grid='1') + longname="Control Integrative Heating", & + units="W m-2", conversion=US%QRZ_T_to_W_m2, z_grid='1') call register_restart_field(CS%precip_0, "Ctrl_precip", .false., restart_CS, & - longname="Control Integrative Precipitation", units="kg m-2 s-1", z_grid='1') + longname="Control Integrative Precipitation", & + units="kg m-2 s-1", conversion=US%RZ_T_to_kg_m2s, z_grid='1') endif if (CS%num_cycle > 0) then @@ -480,20 +485,28 @@ subroutine register_ctrl_forcing_restarts(G, param_file, CS, restart_CS) allocate(CS%avg_time(CS%num_cycle), source=0.0) allocate(CS%avg_SST_anom(isd:ied,jsd:jed,CS%num_cycle), source=0.0) allocate(CS%avg_SSS_anom(isd:ied,jsd:jed,CS%num_cycle), source=0.0) + allocate(CS%avg_SSS(isd:ied,jsd:jed,CS%num_cycle), source=0.0) - write (period_str, '(i8)') CS%num_cycle - period_str = trim('p ')//trim(adjustl(period_str)) + write (period_str, '("p ",I0)') CS%num_cycle call register_restart_field(CS%heat_cyc, "Ctrl_heat_cycle", .false., restart_CS, & - longname="Cyclical Control Heating", units="W m-2", z_grid='1', t_grid=period_str) + longname="Cyclical Control Heating", & + units="W m-2", conversion=US%QRZ_T_to_W_m2, z_grid='1', t_grid=period_str) call register_restart_field(CS%precip_cyc, "Ctrl_precip_cycle", .false., restart_CS, & - longname="Cyclical Control Precipitation", units="kg m-2 s-1", z_grid='1', t_grid=period_str) + longname="Cyclical Control Precipitation", & + units="kg m-2 s-1", conversion=US%RZ_T_to_kg_m2s, z_grid='1', t_grid=period_str) call register_restart_field(CS%avg_time, "avg_time", .false., restart_CS, & - longname="Cyclical accumulated averaging time", units="sec", z_grid='1', t_grid=period_str) + longname="Cyclical accumulated averaging time", & + units="sec", conversion=US%T_to_s, z_grid='1', t_grid=period_str) call register_restart_field(CS%avg_SST_anom, "avg_SST_anom", .false., restart_CS, & - longname="Cyclical average SST Anomaly", units="deg C", z_grid='1', t_grid=period_str) + longname="Cyclical average SST Anomaly", & + units="degC", conversion=US%C_to_degC, z_grid='1', t_grid=period_str) call register_restart_field(CS%avg_SSS_anom, "avg_SSS_anom", .false., restart_CS, & - longname="Cyclical average SSS Anomaly", units="g kg-1", z_grid='1', t_grid=period_str) + longname="Cyclical average SSS Anomaly", & + units="g kg-1", conversion=US%S_to_ppt, z_grid='1', t_grid=period_str) + call register_restart_field(CS%avg_SSS_anom, "avg_SSS", .false., restart_CS, & + longname="Cyclical average SSS", & + units="g kg-1", conversion=US%S_to_ppt, z_grid='1', t_grid=period_str) endif end subroutine register_ctrl_forcing_restarts @@ -513,8 +526,6 @@ subroutine controlled_forcing_init(Time, G, US, param_file, diag, CS) ! Local variables real :: smooth_len ! A smoothing lengthscale [L ~> m] - real :: RZ_T_rescale ! Unit conversion factor for precipiation [T kg m-2 s-1 R-1 Z-1 ~> 1] - real :: QRZ_T_rescale ! Unit conversion factor for head fluxes [T W m-2 Q-1 R-1 Z-1 ~> 1] logical :: do_integrated integer :: num_cycle integer :: i, j, isc, iec, jsc, jec, m @@ -566,7 +577,7 @@ subroutine controlled_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "CTRL_FORCE_LAMDA_HEAT", CS%lam_heat, & "A constant of proportionality between SST anomalies "//& "and controlling heat fluxes", & - units="W m-2 K-1", default=0.0, scale=US%W_m2_to_QRZ_T) + units="W m-2 K-1", default=0.0, scale=US%W_m2_to_QRZ_T*US%C_to_degC) call get_param(param_file, mdl, "CTRL_FORCE_LAMDA_PREC", CS%lam_prec, & "A constant of proportionality between SSS anomalies "//& "(normalised by mean SSS) and controlling precipitation.", & @@ -574,7 +585,7 @@ subroutine controlled_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "CTRL_FORCE_LAMDA_CYC_HEAT", CS%lam_cyc_heat, & "A constant of proportionality between SST anomalies "//& "and cyclical controlling heat fluxes", & - units="W m-2 K-1", default=0.0, scale=US%W_m2_to_QRZ_T) + units="W m-2 K-1", default=0.0, scale=US%W_m2_to_QRZ_T*US%C_to_degC) call get_param(param_file, mdl, "CTRL_FORCE_LAMDA_CYC_PREC", CS%lam_cyc_prec, & "A constant of proportionality between SSS anomalies "//& "(normalised by mean SSS) and cyclical controlling precipitation.", & @@ -589,57 +600,6 @@ subroutine controlled_forcing_init(Time, G, US, param_file, diag, CS) 'Control Corrective Precipitation', 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) endif - ! Rescale if there are differences between the dimensional scaling of variables in - ! restart files from those in use for this run. - if ((US%J_kg_to_Q_restart*US%kg_m3_to_R_restart*US%m_to_Z_restart*US%s_to_T_restart /= 0.0) .and. & - ((US%J_kg_to_Q * US%kg_m3_to_R * US%m_to_Z * US%s_to_T_restart) /= & - (US%J_kg_to_Q_restart * US%kg_m3_to_R_restart * US%m_to_Z_restart * US%s_to_T)) ) then - ! Redo the scaling of the corrective heat fluxes to [Q R Z T-1 ~> W m-2] - QRZ_T_rescale = (US%J_kg_to_Q * US%kg_m3_to_R * US%m_to_Z * US%s_to_T_restart) / & - (US%J_kg_to_Q_restart * US%kg_m3_to_R_restart * US%m_to_Z_restart * US%s_to_T) - - if (associated(CS%heat_0)) then - do j=jsc,jec ; do i=isc,iec - CS%heat_0(i,j) = QRZ_T_rescale * CS%heat_0(i,j) - enddo ; enddo - endif - - if ((CS%num_cycle > 0) .and. associated(CS%heat_cyc)) then - do m=1,CS%num_cycle ; do j=jsc,jec ; do i=isc,iec - CS%heat_cyc(i,j,m) = QRZ_T_rescale * CS%heat_cyc(i,j,m) - enddo ; enddo ; enddo - endif - endif - - if ((US%kg_m3_to_R_restart * US%m_to_Z_restart * US%s_to_T_restart /= 0.0) .and. & - ((US%kg_m3_to_R * US%m_to_Z * US%s_to_T_restart) /= & - (US%kg_m3_to_R_restart * US%m_to_Z_restart * US%s_to_T)) ) then - ! Redo the scaling of the corrective precipitation to [R Z T-1 ~> kg m-2 s-1] - RZ_T_rescale = (US%kg_m3_to_R * US%m_to_Z * US%s_to_T_restart) / & - (US%kg_m3_to_R_restart * US%m_to_Z_restart * US%s_to_T) - - if (associated(CS%precip_0)) then - do j=jsc,jec ; do i=isc,iec - CS%precip_0(i,j) = RZ_T_rescale * CS%precip_0(i,j) - enddo ; enddo - endif - - if ((CS%num_cycle > 0) .and. associated(CS%precip_cyc)) then - do m=1,CS%num_cycle ; do j=jsc,jec ; do i=isc,iec - CS%precip_cyc(i,j,m) = RZ_T_rescale * CS%precip_cyc(i,j,m) - enddo ; enddo ; enddo - endif - endif - - if ((CS%num_cycle > 0) .and. associated(CS%avg_time) .and. & - ((US%s_to_T_restart /= 0.0) .and. ((US%s_to_T_restart) /= US%s_to_T)) ) then - ! Redo the scaling of the accumulated times to [T ~> s] - do m=1,CS%num_cycle - CS%avg_time(m) = (US%s_to_T / US%s_to_T_restart) * CS%avg_time(m) - enddo - endif - - end subroutine controlled_forcing_init !> Clean up this modules control structure. diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index a26bca4711..23f4c8cb7d 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Interface for surface waves module MOM_wave_interface -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_data_override, only : data_override_init, data_override use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc use MOM_diag_mediator, only : diag_ctrl @@ -12,12 +14,16 @@ module MOM_wave_interface use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_forcing_type, only : mech_forcing use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type use MOM_io, only : file_exists, get_var_sizes, read_variable +use MOM_io, only : vardesc, var_desc use MOM_safe_alloc, only : safe_alloc_ptr +use MOM_spatial_means, only : global_area_mean use MOM_time_manager, only : time_type, operator(+), operator(/) use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, surface use MOM_verticalgrid, only : verticalGrid_type +use MOM_restart, only : register_restart_pair, MOM_restart_CS implicit none ; private @@ -31,6 +37,7 @@ module MOM_wave_interface ! called in step_mom. public get_Langmuir_Number ! Public interface to compute Langmuir number called from ! ePBL or KPP routines. +public Stokes_PGF ! Public interface to compute Stokes-shear induced pressure gradient force anomaly public StokesMixing ! NOT READY - Public interface to add down-Stokes gradient ! momentum mixing (e.g. the approach of Harcourt 2013/2015) public CoriolisStokes ! NOT READY - Public interface to add Coriolis-Stokes acceleration @@ -40,6 +47,7 @@ module MOM_wave_interface ! CL2 effects. public Waves_end ! public interface to deallocate and free wave related memory. public get_wave_method ! public interface to obtain the wave method string +public waves_register_restarts ! public interface to register wave restart fields ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -50,7 +58,19 @@ module MOM_wave_interface type, public :: wave_parameters_CS ; private ! Main surface wave options and publicly visible variables - logical, public :: UseWaves = .false. !< Flag to enable surface gravity wave feature + logical, public :: UseWaves = .false. !< Flag to enable surface gravity wave feature + logical, public :: Stokes_VF = .false. !< True if Stokes vortex force is used + logical, public :: Passive_Stokes_VF = .false. !< Computes Stokes VF, but doesn't affect dynamics + logical, public :: Stokes_PGF = .false. !< True if Stokes shear pressure Gradient force is used + logical, public :: robust_Stokes_PGF = .false. !< If true, use expressions to calculate the + !! Stokes-induced pressure gradient anomalies that are + !! more accurate in the limit of thin layers. + logical, public :: Passive_Stokes_PGF = .false. !< Keeps Stokes_PGF on, but doesn't affect dynamics + logical, public :: Stokes_DDT = .false. !< Developmental: + !! True if Stokes d/dt is used + logical, public :: Passive_Stokes_DDT = .false. !< Keeps Stokes_DDT on, but doesn't affect dynamics + logical :: Homogenize_Surfbands !< True to homogenize surface band Stokes drift in the horizontal + real, allocatable, dimension(:,:,:), public :: & Us_x !< 3d zonal Stokes drift profile [L T-1 ~> m s-1] !! Horizontal -> U points @@ -60,7 +80,46 @@ module MOM_wave_interface !! Horizontal -> V points !! Vertical -> Mid-points real, allocatable, dimension(:,:,:), public :: & - KvS !< Viscosity for Stokes Drift shear [Z2 T-1 ~> m2 s-1] + ddt_Us_x !< 3d time tendency of zonal Stokes drift profile [L T-2 ~> m s-2] + !! Horizontal -> U points + !! Vertical -> Mid-points + real, allocatable, dimension(:,:,:), public :: & + ddt_Us_y !< 3d time tendency of meridional Stokes drift profile [L T-2 ~> m s-2] + !! Horizontal -> V points + !! Vertical -> Mid-points + real, allocatable, dimension(:,:,:), public :: & + Us_x_from_ddt !< Check of 3d zonal Stokes drift profile [L T-1 ~> m s-1] + !! Horizontal -> U points + !! Vertical -> Mid-points + real, allocatable, dimension(:,:,:), public :: & + Us_y_from_ddt !< Check of 3d meridional Stokes drift profile [L T-1 ~> m s-1] + !! Horizontal -> V points + !! Vertical -> Mid-points + real, allocatable, dimension(:,:,:), public :: & + Us_x_prev !< 3d zonal Stokes drift profile, previous dynamics call [L T-1 ~> m s-1] + !! Horizontal -> U points + !! Vertical -> Mid-points + real, allocatable, dimension(:,:,:), public :: & + Us_y_prev !< 3d meridional Stokes drift profile, previous dynamics call [L T-1 ~> m s-1] + !! Horizontal -> V points + !! Vertical -> Mid-points + real, allocatable, dimension(:,:,:), public :: & + KvS !< Viscosity for Stokes Drift shear [H Z T-1 ~> m2 s-1 or Pa s] + real, allocatable, dimension(:), public :: & + WaveNum_Cen !< Wavenumber bands for read/coupled [Z-1 ~> m-1] + real, allocatable, dimension(:,:,:), public :: & + UStk_Hb !< Surface Stokes Drift spectrum (zonal) [L T-1 ~> m s-1] + !! Horizontal -> H-points + !! 3rd dimension -> Freq/Wavenumber + real, allocatable, dimension(:,:,:), public :: & + VStk_Hb !< Surface Stokes Drift spectrum (meridional) [L T-1 ~> m s-1] + !! Horizontal -> H-points + !! 3rd dimension -> Freq/Wavenumber + real, allocatable, dimension(:,:), public :: & + Omega_w2x !< wind direction ccw from model x- axis [nondim radians] + integer, public :: NumBands = 0 !< Number of wavenumber/frequency partitions + !! Must match the number of bands provided + !! via either coupling or file. ! The remainder of this control structure is private integer :: WaveMethod = -99 !< Options for including wave information @@ -70,24 +129,27 @@ module MOM_wave_interface !! 2 - DHH85 !! 3 - LF17 !! -99 - No waves computed, but empirical Langmuir number used. - logical :: LagrangianMixing !< This feature is in development and not ready - !! True if Stokes drift is present and mixing - !! should be applied to Lagrangian current - !! (mean current + Stokes drift). - !! See Reichl et al., 2016 KPP-LT approach - logical :: StokesMixing !< This feature is in development and not ready. - !! True if vertical mixing of momentum - !! should be applied directly to Stokes current - !! (with separate mixing parameter for Eulerian - !! mixing contribution). - !! See Harcourt 2013, 2015 Second-Moment approach - logical :: CoriolisStokes !< This feature is in development and not ready. - ! True if Coriolis-Stokes acceleration should be applied. - integer :: StkLevelMode=1 !< Sets if Stokes drift is defined at mid-points - !! or layer averaged. Set to 0 if mid-point and set to - !! 1 if average value of Stokes drift over level. - !! If advecting with Stokes transport, 1 is the correct - !! approach. + logical :: LagrangianMixing !< This feature is in development and not ready + !! True if Stokes drift is present and mixing + !! should be applied to Lagrangian current + !! (mean current + Stokes drift). + !! See Reichl et al., 2016 KPP-LT approach + logical :: StokesMixing !< This feature is in development and not ready. + !! True if vertical mixing of momentum + !! should be applied directly to Stokes current + !! (with separate mixing parameter for Eulerian + !! mixing contribution). + !! See Harcourt 2013, 2015 Second-Moment approach + logical :: CoriolisStokes !< This feature is in development and not ready. + ! True if Coriolis-Stokes acceleration should be applied. + real :: Stokes_min_thick_avg !< A layer thickness below which the cell-center Stokes drift is + !! used instead of the cell average [Z ~> m]. This is only used if + !! WAVE_INTERFACE_ANSWER_DATE < 20230101. + integer :: answer_date !< The vintage of the order of arithmetic and expressions in the + !! surface wave calculations. Values below 20230101 recover the + !! answers from the end of 2022, while higher values use updated + !! and more robust forms of the same expressions. + ! Options if WaveMethod is Surface Stokes Drift Bands (1) integer :: PartitionMode !< Method for partition mode (meant to check input) !! 0 - wavenumbers @@ -100,21 +162,23 @@ module MOM_wave_interface ! Options if using FMS DataOverride Routine character(len=40) :: SurfBandFileName !< Filename if using DataOverride + real :: land_speed !< A large Stokes velocity that can be used to indicate land values in + !! a data override file [L T-1 ~> m s-1]. Stokes drift components larger + !! than this are set to zero in data override calls for the Stokes drift. logical :: DataOver_initialized !< Flag for DataOverride Initialization ! Options for computing Langmuir number - real :: LA_FracHBL !< Fraction of OSBL for averaging Langmuir number + real :: LA_FracHBL !< Fraction of OSBL for averaging Langmuir number [nondim] + real :: LA_HBL_min !< Minimum boundary layer depth for averaging Langmuir number [Z ~> m] logical :: LA_Misalignment = .false. !< Flag to use misalignment in Langmuir number - - integer :: NumBands = 0 !< Number of wavenumber/frequency partitions to receive - !! This needs to match the number of bands provided - !! via either coupling or file. + logical :: LA_misalign_bug = .false. !< Flag to use code with a sign error when calculating the + !! misalignment between the shear and waves in the Langmuir number calculation. real :: g_Earth !< The gravitational acceleration, equivalent to GV%g_Earth but with !! different dimensional rescaling appropriate for deep-water gravity !! waves [Z T-2 ~> m s-2] + real :: I_g_Earth !< The inverse of the gravitational acceleration, with dimensional rescaling + !! appropriate for deep-water gravity waves [T2 Z-1 ~> s2 m-1] ! Surface Wave Dependent 1d/2d/3d vars - real, allocatable, dimension(:) :: & - WaveNum_Cen !< Wavenumber bands for read/coupled [Z-1 ~> m-1] real, allocatable, dimension(:) :: & Freq_Cen !< Central frequency for wave bands, including a factor of 2*pi [T-1 ~> s-1] real, allocatable, dimension(:) :: & @@ -122,8 +186,6 @@ module MOM_wave_interface real, allocatable, dimension(:) :: & PrescribedSurfStkY !< Surface Stokes drift if prescribed [L T-1 ~> m s-1] real, allocatable, dimension(:,:) :: & - La_SL, & !< SL Langmuir number (directionality factored later) - !! Horizontal -> H points La_Turb !< Aligned Turbulent Langmuir number [nondim] !! Horizontal -> H points real, allocatable, dimension(:,:) :: & @@ -141,12 +203,32 @@ module MOM_wave_interface !! Horizontal -> V points !! 3rd dimension -> Freq/Wavenumber - !> An arbitrary lower-bound on the Langmuir number. Run-time parameter. - !! Langmuir number is sqrt(u_star/u_stokes). When both are small - !! but u_star is orders of magnitude smaller the Langmuir number could - !! have unintended consequences. Since both are small it can be safely capped - !! to avoid such consequences. - real :: La_min = 0.05 + real :: La_min !< An arbitrary lower-bound on the Langmuir number [nondim]. + !! Langmuir number is sqrt(u_star/u_stokes). When both are small + !! but u_star is orders of magnitude smaller, the Langmuir number could + !! have unintended consequences. Since both are small it can be safely + !! capped to avoid such consequences. + real :: La_Stk_backgnd !< A small background Stokes velocity used in the denominator of + !! some expressions for the Langmuir number [L T-1 ~> m s-1] + + ! Parameters used in estimating the wind speed or wave properties from the friction velocity + real :: VonKar = -1.0 !< The von Karman coefficient as used in the MOM_wave_interface module [nondim] + real :: rho_air !< A typical density of air at sea level, as used in wave calculations [R ~> kg m-3] + real :: nu_air !< The viscosity of air, as used in wave calculations [Z2 T-1 ~> m2 s-1] + real :: rho_ocn !< A typical surface density of seawater, as used in wave calculations in + !! comparison with the density of air [R ~> kg m-3]. The default is RHO_0. + real :: SWH_from_u10sq !< A factor for converting the square of the 10 m wind speed to the + !! significant wave height [Z T2 L-2 ~> s2 m-1] + real :: Charnock_min !< The minimum value of the Charnock coefficient, which relates the square of + !! the air friction velocity divided by the gravitational acceleration to the + !! wave roughness length [nondim] + real :: Charnock_slope_U10 !< The partial derivative of the Charnock coefficient with the 10 m wind + !! speed [T L-1 ~> s m-1]. Note that in eq. 13 of the Edson et al. 2013 describing + !! the COARE 3.5 bulk flux algorithm, this slope is given as 0.017. However, 0.0017 + !! reproduces the curve in their figure 6, so that is the default value used in MOM6. + real :: Charnock_intercept !< The intercept of the fit for the Charnock coefficient in the limit of + !! no wind [nondim]. Note that this can be negative because CHARNOCK_MIN will keep + !! the final value for the Charnock coefficient from being from being negative. ! Options used with the test profile real :: TP_STKX0 !< Test profile x-stokes drift amplitude [L T-1 ~> m s-1] @@ -159,14 +241,20 @@ module MOM_wave_interface logical :: DHH85_is_set !< The if the wave properties have been set when WaveMethod = DHH85. real :: WaveAge !< The fixed wave age used with the DHH85 spectrum [nondim] real :: WaveWind !< Wind speed for the DHH85 spectrum [L T-1 ~> m s-1] + real :: omega_min !< Minimum wave frequency with the DHH85 spectrum [T-1 ~> s-1] + real :: omega_max !< Maximum wave frequency with the DHH85 spectrum [T-1 ~> s-1] type(time_type), pointer :: Time !< A pointer to the ocean model's clock. type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. !>@{ Diagnostic handles + integer, public :: id_PFu_Stokes = -1 , id_PFv_Stokes = -1 + integer, public :: id_3dstokes_x_from_ddt = -1 , id_3dstokes_y_from_ddt = -1 + integer :: id_P_deltaStokes_L = -1, id_P_deltaStokes_i = -1 integer :: id_surfacestokes_x = -1 , id_surfacestokes_y = -1 integer :: id_3dstokes_x = -1 , id_3dstokes_y = -1 + integer :: id_ddt_3dstokes_x = -1 , id_ddt_3dstokes_y = -1 integer :: id_La_turb = -1 !>@} @@ -191,7 +279,7 @@ module MOM_wave_interface contains !> Initializes parameters related to MOM_wave_interface -subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) +subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag) type(time_type), target, intent(in) :: Time !< Model time type(ocean_grid_type), intent(inout) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure @@ -208,12 +296,13 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) character*(12), parameter :: DATAOVR_STRING = "DATAOVERRIDE" character*(7), parameter :: COUPLER_STRING = "COUPLER" character*(5), parameter :: INPUT_STRING = "INPUT" + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags logical :: use_waves logical :: StatisticalWaves ! Dummy Check - if (associated(CS)) then - call MOM_error(FATAL, "wave_interface_init called with an associated control structure.") + if (.not. associated(CS)) then + call MOM_error(FATAL, "wave_interface_init called without an associated control structure.") return endif @@ -221,62 +310,103 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) "If true, enables surface wave modules.", default=.false.) ! Check if using LA_LI2016 - call get_param(param_file,mdl,"USE_LA_LI2016",StatisticalWaves, & + call get_param(param_file, mdl, "USE_LA_LI2016", StatisticalWaves, & do_not_log=.true.,default=.false.) if (.not.(use_waves .or. StatisticalWaves)) return - ! Allocate CS and set pointers - allocate(CS) - CS%UseWaves = use_waves CS%diag => diag CS%Time => Time - CS%g_Earth = US%L_to_Z**2*GV%g_Earth + CS%g_Earth = GV%g_Earth_Z_T2 + CS%I_g_Earth = 1.0 / CS%g_Earth ! Add any initializations needed here CS%DataOver_initialized = .false. call log_version(param_file, mdl, version) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + + call get_param(param_file, mdl, "WAVE_INTERFACE_ANSWER_DATE", CS%answer_date, & + "The vintage of the order of arithmetic and expressions in the surface wave "//& + "calculations. Values below 20230101 recover the answers from the end of 2022, "//& + "while higher values use updated and more robust forms of the same expressions:\n"//& + "\t < 20230101 - Original answers for wave interface routines\n"//& + "\t >= 20230101 - More robust expressions for Update_Stokes_Drift\n"//& + "\t >= 20230102 - More robust expressions for get_StokesSL_LiFoxKemper\n"//& + "\t >= 20230103 - More robust expressions for ust_2_u10_coare3p5", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) + ! Langmuir number Options - call get_param(param_file, mdl, "LA_DEPTH_RATIO", CS%LA_FracHBL, & - "The depth (normalized by BLD) to average Stokes drift over in "//& - "Langmuir number calculation, where La = sqrt(ust/Stokes).", & - units="nondim", default=0.04) + call get_param(param_file, mdl, "LA_DEPTH_RATIO", CS%LA_FracHBL, & + "The depth (normalized by BLD) to average Stokes drift over in "//& + "Langmuir number calculation, where La = sqrt(ust/Stokes).", & + units="nondim", default=0.04) + call get_param(param_file, mdl, "LA_DEPTH_MIN", CS%LA_HBL_min, & + "The minimum depth over which to average the Stokes drift in the Langmuir "//& + "number calculation.", units="m", default=0.1, scale=US%m_to_Z) if (StatisticalWaves) then CS%WaveMethod = LF17 + call set_LF17_wave_params(param_file, mdl, GV, US, CS) if (.not.use_waves) return else CS%WaveMethod = NULL_WaveMethod - end if + endif ! Wave modified physics ! Presently these are all in research mode call get_param(param_file, mdl, "LAGRANGIAN_MIXING", CS%LagrangianMixing, & - "Flag to use Lagrangian Mixing of momentum", units="", & - Default=.false., do_not_log=.not.use_waves) + "Flag to use Lagrangian Mixing of momentum", default=.false., & + do_not_log=.not.use_waves) if (CS%LagrangianMixing) then ! Force Code Intervention call MOM_error(FATAL,"Should you be enabling Lagrangian Mixing? Code not ready.") endif call get_param(param_file, mdl, "STOKES_MIXING", CS%StokesMixing, & - "Flag to use Stokes Mixing of momentum", units="", & - Default=.false., do_not_log=.not.use_waves) + "Flag to use Stokes Mixing of momentum", default=.false., & + do_not_log=.not.use_waves) if (CS%StokesMixing) then ! Force Code Intervention - call MOM_error(FATAL,"Should you be enabling Stokes Mixing? Code not ready.") + call MOM_error(FATAL, "Should you be enabling Stokes Mixing? Code not ready.") endif call get_param(param_file, mdl, "CORIOLIS_STOKES", CS%CoriolisStokes, & - "Flag to use Coriolis Stokes acceleration", units="", & - Default=.false., do_not_log=.not.use_waves) + "Flag to use Coriolis Stokes acceleration", default=.false., & + do_not_log=.not.use_waves) if (CS%CoriolisStokes) then ! Force Code Intervention - call MOM_error(FATAL,"Should you be enabling Coriolis-Stokes? Code not ready.") + call MOM_error(FATAL, "Should you be enabling Coriolis-Stokes? Code not ready.") endif + call get_param(param_file, mdl, "STOKES_VF", CS%Stokes_VF, & + "Flag to use Stokes vortex force", & + default=.false.) + call get_param(param_file, mdl, "PASSIVE_STOKES_VF", CS%Passive_Stokes_VF, & + "Flag to make Stokes vortex force diagnostic only.", & + default=.false.) + call get_param(param_file, mdl, "STOKES_PGF", CS%Stokes_PGF, & + "Flag to use Stokes-induced pressure gradient anomaly", & + default=.false.) + call get_param(param_file, mdl, "ROBUST_STOKES_PGF", CS%robust_Stokes_PGF, & + "If true, use expressions to calculate the Stokes-induced pressure gradient "//& + "anomalies that are more accurate in the limit of thin layers.", & + default=.false., do_not_log=.not.CS%Stokes_PGF) + !### Change the default for ROBUST_STOKES_PGF to True. + call get_param(param_file, mdl, "PASSIVE_STOKES_PGF", CS%Passive_Stokes_PGF, & + "Flag to make Stokes-induced pressure gradient anomaly diagnostic only.", & + default=.false.) + call get_param(param_file, mdl, "STOKES_DDT", CS%Stokes_DDT, & + "Flag to use Stokes d/dt", & + default=.false.) + call get_param(param_file, mdl, "PASSIVE_STOKES_DDT", CS%Passive_Stokes_DDT, & + "Flag to make Stokes d/dt diagnostic only", & + default=.false.) + ! Get Wave Method and write to integer WaveMethod call get_param(param_file,mdl,"WAVE_METHOD",TMPSTRING1, & "Choice of wave method, valid options include: \n"// & @@ -293,7 +423,7 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) " directly from WW3 and is based on the \n"// & " surface layer and projected Langmuir \n"// & " number (Li 2016)\n", & - units='', default=NULL_STRING) + default=NULL_STRING) select case (TRIM(TMPSTRING1)) case (NULL_STRING)! No Waves call MOM_error(FATAL, "wave_interface_init called with no specified "//& @@ -311,46 +441,62 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) units='m', default=50.0, scale=US%m_to_Z) case (SURFBANDS_STRING)! Surface Stokes Drift Bands CS%WaveMethod = SURFBANDS - call get_param(param_file, mdl, "SURFBAND_SOURCE", TMPSTRING2, & - "Choice of SURFACE_BANDS data mode, valid options include: \n"// & - " DATAOVERRIDE - Read from NetCDF using FMS DataOverride. \n"// & - " COUPLER - Look for variables from coupler pass \n"// & - " INPUT - Testing with fixed values.", & - units='', default=NULL_STRING) + call get_param(param_file, mdl, "SURFBAND_MIN_THICK_AVG", CS%Stokes_min_thick_avg, & + "A layer thickness below which the cell-center Stokes drift is used instead of "//& + "the cell average. This is only used if WAVE_INTERFACE_ANSWER_DATE < 20230101.", & + units="m", default=0.1, scale=US%m_to_Z, do_not_log=(CS%answer_date>=20230101)) + call get_param(param_file, mdl, "HOMOGENIZE_SURFBANDS", CS%Homogenize_Surfbands, & + "A logical which causes the code to horizontally homogenize the surface band "//& + "Stokes drift, which is needed in column mode to avoid round-off differences. "//& + "At present it only works with DATAOVERRIDE, and is not coded for COUPLER.",& + default=.false.) + call get_param(param_file, mdl, "SURFBAND_SOURCE", TMPSTRING2, & + "Choice of SURFACE_BANDS data mode, valid options include: \n"//& + " DATAOVERRIDE - Read from NetCDF using FMS DataOverride. \n"//& + " COUPLER - Look for variables from coupler pass \n"//& + " INPUT - Testing with fixed values.", default=NULL_STRING) select case (TRIM(TMPSTRING2)) case (NULL_STRING)! Default - call MOM_error(FATAL, "wave_interface_init called with SURFACE_BANDS"//& - " but no SURFBAND_SOURCE.") + call MOM_error(FATAL, "wave_interface_init called with SURFACE_BANDS "//& + "but no SURFBAND_SOURCE.") case (DATAOVR_STRING)! Using Data Override CS%DataSource = DATAOVR call get_param(param_file, mdl, "SURFBAND_FILENAME", CS%SurfBandFileName, & - "Filename of surface Stokes drift input band data.", default="StkSpec.nc") + "Filename of surface Stokes drift input band data.", default="StkSpec.nc") + call get_param(param_file, mdl, "SURFBAND_OVERRIDE_LAND_SPEED", CS%land_speed, & + "A large Stokes velocity that can be used to indicate land values in "//& + "a data override file. Stokes drift components larger than this are "//& + "set to zero in data override calls for the Stokes drift.", & + units="m s-1", default=10.0, scale=US%m_s_to_L_T) case (COUPLER_STRING)! Reserved for coupling CS%DataSource = COUPLER ! This is just to make something work, but it needs to be read from the wavemodel. - call get_param(param_file,mdl,"STK_BAND_COUPLER",CS%NumBands, & - "STK_BAND_COUPLER is the number of Stokes drift bands in the coupler. "// & - "This has to be consistent with the number of Stokes drift bands in WW3, "//& - "or the model will fail.",units='', default=1) + call get_param(param_file, mdl, "STK_BAND_COUPLER",CS%NumBands, & + "STK_BAND_COUPLER is the number of Stokes drift bands in the coupler. "//& + "This has to be consistent with the number of Stokes drift bands in WW3, "//& + "or the model will fail.", default=1) allocate( CS%WaveNum_Cen(CS%NumBands), source=0.0 ) allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,CS%NumBands), source=0.0 ) - allocate( CS%STKy0(G%isdB:G%iedB,G%jsd:G%jed,CS%NumBands), source=0.0 ) + allocate( CS%STKy0(G%isd:G%ied,G%jsdB:G%jedB,CS%NumBands), source=0.0 ) + allocate( CS%UStk_Hb(G%isc:G%iec,G%jsc:G%jec,CS%NumBands), source=0.0 ) + allocate( CS%VStk_Hb(G%isc:G%iec,G%jsc:G%jec,CS%NumBands), source=0.0 ) + allocate( CS%Omega_w2x(G%isc:G%iec,G%jsc:G%jec) , source=0.0 ) CS%PartitionMode = 0 call get_param(param_file, mdl, "SURFBAND_WAVENUMBERS", CS%WaveNum_Cen, & "Central wavenumbers for surface Stokes drift bands.", & units='rad/m', default=0.12566, scale=US%Z_to_m) case (INPUT_STRING)! A method to input the Stokes band (globally uniform) CS%DataSource = INPUT - call get_param(param_file,mdl,"SURFBAND_NB",CS%NumBands, & - "Prescribe number of wavenumber bands for Stokes drift. "// & - "Make sure this is consistnet w/ WAVENUMBERS, STOKES_X, and "// & - "STOKES_Y, there are no safety checks in the code.", & - units='', default=1) + call get_param(param_file, mdl, "SURFBAND_NB", CS%NumBands, & + "Prescribe number of wavenumber bands for Stokes drift. "//& + "Make sure this is consistnet w/ WAVENUMBERS, STOKES_X, and "//& + "STOKES_Y, there are no safety checks in the code.", default=1) allocate( CS%WaveNum_Cen(1:CS%NumBands), source=0.0 ) allocate( CS%PrescribedSurfStkX(1:CS%NumBands), source=0.0 ) allocate( CS%PrescribedSurfStkY(1:CS%NumBands), source=0.0 ) allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,1:CS%NumBands), source=0.0 ) allocate( CS%STKy0(G%isd:G%ied,G%jsdB:G%jedB,1:CS%NumBands), source=0.0 ) + CS%PartitionMode = 0 call get_param(param_file, mdl, "SURFBAND_WAVENUMBERS", CS%WaveNum_Cen, & "Central wavenumbers for surface Stokes drift bands.", & @@ -367,23 +513,28 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) case (DHH85_STRING) !Donelan et al., 1985 spectrum CS%WaveMethod = DHH85 - call MOM_error(WARNING,"DHH85 only ever set-up for uniform cases w/"//& - " Stokes drift in x-direction.") + call MOM_error(WARNING,"DHH85 only ever set-up for uniform cases w/ "//& + "Stokes drift in x-direction.") call get_param(param_file, mdl, "DHH85_AGE_FP", CS%WaveAgePeakFreq, & - "Choose true to use waveage in peak frequency.", & - units='', default=.false.) + "Choose true to use waveage in peak frequency.", default=.false.) call get_param(param_file, mdl, "DHH85_AGE", CS%WaveAge, & "Wave Age for DHH85 spectrum.", & - units='', default=1.2) - call get_param(param_file,mdl,"DHH85_WIND", CS%WaveWind, & + units='nondim', default=1.2) + call get_param(param_file, mdl, "DHH85_WIND", CS%WaveWind, & "Wind speed for DHH85 spectrum.", & units='m s-1', default=10.0, scale=US%m_s_to_L_T) - call get_param(param_file,mdl,"STATIC_DHH85", CS%StaticWaves, & - "Flag to disable updating DHH85 Stokes drift.", & - default=.false.) - case (LF17_STRING)!Li and Fox-Kemper 17 wind-sea Langmuir number + call get_param(param_file, mdl, "DHH85_MIN_WAVE_FREQ", CS%omega_min, & + "Minimum wave frequency for the DHH85 spectrum.", & + units='s-1', default=0.1, scale=US%T_to_s) + call get_param(param_file, mdl, "DHH85_MAX_WAVE_FREQ", CS%omega_max, & + "Maximum wave frequency for the DHH85 spectrum.", & + units='s-1', default=10.0, scale=US%T_to_s) ! The default is about a 30 cm cutoff wavelength. + call get_param(param_file, mdl, "STATIC_DHH85", CS%StaticWaves, & + "Flag to disable updating DHH85 Stokes drift.", default=.false.) + case (LF17_STRING) !Li and Fox-Kemper 17 wind-sea Langmuir number CS%WaveMethod = LF17 - case (EFACTOR_STRING)!Li and Fox-Kemper 16 + call set_LF17_wave_params(param_file, mdl, GV, US, CS) + case (EFACTOR_STRING) !Li and Fox-Kemper 16 CS%WaveMethod = EFACTOR case default call MOM_error(FATAL,'Check WAVE_METHOD.') @@ -391,23 +542,38 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) ! Langmuir number Options (Note that CS%LA_FracHBL is set above.) call get_param(param_file, mdl, "LA_MISALIGNMENT", CS%LA_Misalignment, & - "Flag (logical) if using misalignment bt shear and waves in LA", & + "Flag (logical) if using misalignment between shear and waves in LA", & default=.false.) + call get_param(param_file, mdl, "LA_MISALIGNMENT_BUG", CS%LA_misalign_bug, & + "If true, use a code with a sign error when calculating the misalignment between "//& + "the shear and waves when LA_MISALIGNMENT is true.", & + default=.false., do_not_log=.not.CS%LA_Misalignment) call get_param(param_file, mdl, "MIN_LANGMUIR", CS%La_min, & "A minimum value for all Langmuir numbers that is not physical, "//& "but is likely only encountered when the wind is very small and "//& - "therefore its effects should be mostly benign.", units="nondim", & - default=0.05) + "therefore its effects should be mostly benign.", & + units="nondim", default=0.05) + call get_param(param_file, mdl, "LANGMUIR_STOKES_BACKGROUND", CS%La_Stk_backgnd, & + "A small background Stokes velocity used in the denominator of some "//& + "expressions for the Langmuir number.", & + units="m s-1", default=1.0e-10, scale=US%m_s_to_L_T, do_not_log=(CS%WaveMethod==LF17)) ! Allocate and initialize ! a. Stokes driftProfiles - allocate(CS%Us_x(G%isdB:G%IedB,G%jsd:G%jed,GV%ke), source=0.0) - allocate(CS%Us_y(G%isd:G%Ied,G%jsdB:G%jedB,GV%ke), source=0.0) + allocate(CS%Us_x(G%isdB:G%IedB,G%jsd:G%jed,G%ke), source=0.0) + allocate(CS%Us_y(G%isd:G%Ied,G%jsdB:G%jedB,G%ke), source=0.0) + if (CS%Stokes_DDT) then + !allocate(CS%Us_x_prev(G%isdB:G%IedB,G%jsd:G%jed,G%ke), source=0.0) + !allocate(CS%Us_y_prev(G%isd:G%Ied,G%jsdB:G%jedB,G%ke), source=0.0) + allocate(CS%ddt_Us_x(G%isdB:G%IedB,G%jsd:G%jed,G%ke), source=0.0) + allocate(CS%ddt_Us_y(G%isd:G%Ied,G%jsdB:G%jedB,G%ke), source=0.0) + allocate(CS%Us_x_from_ddt(G%isdB:G%IedB,G%jsd:G%jed,G%ke), source=0.0) + allocate(CS%Us_y_from_ddt(G%isd:G%Ied,G%jsdB:G%jedB,G%ke), source=0.0) + endif ! b. Surface Values allocate(CS%US0_x(G%isdB:G%iedB,G%jsd:G%jed), source=0.0) allocate(CS%US0_y(G%isd:G%ied,G%jsdB:G%jedB), source=0.0) ! c. Langmuir number - allocate(CS%La_SL(G%isc:G%iec,G%jsc:G%jec), source=0.0) allocate(CS%La_turb(G%isc:G%iec,G%jsc:G%jec), source=0.0) ! d. Viscosity for Stokes drift if (CS%StokesMixing) then @@ -423,11 +589,77 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) CS%diag%axesCvL,Time,'3d Stokes drift (y)', 'm s-1', conversion=US%L_T_to_m_s) CS%id_3dstokes_x = register_diag_field('ocean_model','3d_stokes_x', & CS%diag%axesCuL,Time,'3d Stokes drift (x)', 'm s-1', conversion=US%L_T_to_m_s) + if (CS%Stokes_DDT) then + CS%id_ddt_3dstokes_y = register_diag_field('ocean_model','dvdt_Stokes', & + CS%diag%axesCvL,Time,'d/dt Stokes drift (meridional)', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_ddt_3dstokes_x = register_diag_field('ocean_model','dudt_Stokes', & + CS%diag%axesCuL,Time,'d/dt Stokes drift (zonal)', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_3dstokes_y_from_ddt = register_diag_field('ocean_model','3d_stokes_y_from_ddt', & + CS%diag%axesCvL,Time,'3d Stokes drift from ddt (y)', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_3dstokes_x_from_ddt = register_diag_field('ocean_model','3d_stokes_x_from_ddt', & + CS%diag%axesCuL,Time,'3d Stokes drift from ddt (x)', 'm s-1', conversion=US%L_T_to_m_s) + endif + CS%id_PFv_Stokes = register_diag_field('ocean_model','PFv_Stokes', & + CS%diag%axesCvL,Time,'PF from Stokes drift (meridional)','m s-2',conversion=US%L_T2_to_m_s2) + CS%id_PFu_Stokes = register_diag_field('ocean_model','PFu_Stokes', & + CS%diag%axesCuL,Time,'PF from Stokes drift (zonal)','m s-2',conversion=US%L_T2_to_m_s2) + CS%id_P_deltaStokes_i = register_diag_field('ocean_model','P_deltaStokes_i', & + CS%diag%axesTi,Time,'Interfacial pressure anomaly from Stokes drift used in PFu_Stokes',& + 'm2 s-2',conversion=US%L_T_to_m_s**2) + CS%id_P_deltaStokes_L = register_diag_field('ocean_model','P_deltaStokes_L', & + CS%diag%axesTL,Time,'Layer averaged pressure anomaly from Stokes drift used in PFu_Stokes',& + 'm2 s-2',conversion=US%L_T_to_m_s**2) CS%id_La_turb = register_diag_field('ocean_model','La_turbulent', & CS%diag%axesT1,Time,'Surface (turbulent) Langmuir number','nondim') end subroutine MOM_wave_interface_init +!> Set the parameters that are used to determine the averaged Stokes drift and Langmuir numbers +subroutine set_LF17_wave_params(param_file, mdl, GV, US, CS) + type(param_file_type), intent(in) :: param_file !< Input parameter structure + character(len=*), intent(in) :: mdl !< A module name to use in the get_param calls + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(wave_parameters_CS), pointer :: CS !< Wave parameter control structure + + ! A separate routine is used to set these parameters because there are multiple ways that the + ! underlying parameterizations are enabled. + + call get_param(param_file, mdl, "VISCOSITY_AIR", CS%nu_air, & + "A typical viscosity of air at sea level, as used in wave calculations", & + units="m2 s-1", default=1.0e-6, scale=US%m2_s_to_Z2_T) + call get_param(param_file, mdl, "VON_KARMAN_WAVES", CS%vonKar, & + "The value the von Karman constant as used for surface wave calculations.", & + units="nondim", default=0.40) ! The default elsewhere in MOM6 is usually 0.41. + call get_param(param_file, mdl, "RHO_AIR", CS%rho_air, & + "A typical density of air at sea level, as used in wave calculations", & + units="kg m-3", default=1.225, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "RHO_SFC_WAVES", CS%Rho_ocn, & + "A typical surface density of seawater, as used in wave calculations in "//& + "comparison with the density of air. The default is RHO_0.", & + units="kg m-3", default=GV%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "WAVE_HEIGHT_SCALE_FACTOR", CS%SWH_from_u10sq, & + "A factor relating the square of the 10 m wind speed to the significant "//& + "wave height, with a default value based on the Pierson-Moskowitz spectrum.", & + units="s2 m-1", default=0.0246, scale=US%m_to_Z*US%L_T_to_m_s**2) + call get_param(param_file, mdl, "CHARNOCK_MIN", CS%Charnock_min, & + "The minimum value of the Charnock coefficient, which relates the square of "//& + "the air friction velocity divided by the gravitational acceleration to the "//& + "wave roughness length.", units="nondim", default=0.028) + call get_param(param_file, mdl, "CHARNOCK_SLOPE_U10", CS%Charnock_slope_U10, & + "The partial derivative of the Charnock coefficient with the 10 m wind speed. "//& + "Note that in eq. 13 of the Edson et al. 2013 describing the COARE 3.5 bulk "//& + "flux algorithm, this slope is given as 0.017. However, 0.0017 reproduces "//& + "the curve in their figure 6, so that is the default value used in MOM6.", & + units="s m-1", default=0.0017, scale=US%L_T_to_m_s) + call get_param(param_file, mdl, "CHARNOCK_0_WIND_INTERCEPT", CS%Charnock_intercept, & + "The intercept of the fit for the Charnock coefficient in the limit of no wind. "//& + "Note that this can be negative because CHARNOCK_MIN will keep the final "//& + "value for the Charnock coefficient from being from being negative.", & + units="nondim", default=-0.005) + +end subroutine set_LF17_wave_params + !> This interface provides the caller with information from the waves control structure. subroutine query_wave_properties(CS, NumBands, WaveNumbers, US) type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure @@ -453,26 +685,28 @@ subroutine query_wave_properties(CS, NumBands, WaveNumbers, US) end subroutine query_wave_properties !> Subroutine that handles updating of surface wave/Stokes drift related properties -subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS, forces) +subroutine Update_Surface_Waves(G, GV, US, Time_present, dt, CS, forces) type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure type(ocean_grid_type), intent(inout) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(time_type), intent(in) :: Day !< Current model time - type(time_type), intent(in) :: dt !< Timestep as a time-type + type(time_type), intent(in) :: Time_present !< Model Time + type(time_type), intent(in) :: dt !< Time increment as a time-type type(mech_forcing), intent(in), optional :: forces !< MOM_forcing_type ! Local variables - integer :: ii, jj, kk, b - type(time_type) :: Day_Center - - ! Computing central time of time step - Day_Center = Day + DT/2 + type(time_type) :: Stokes_Time + integer :: i, j, b if (CS%WaveMethod == TESTPROF) then ! Do nothing elseif (CS%WaveMethod == SURFBANDS) then if (CS%DataSource == DATAOVR) then - call Surface_Bands_by_data_override(day_center, G, GV, US, CS) + ! Updating Stokes drift time to center of time increment. + ! This choice makes sense for the thermodynamics, but for the + ! dynamics it may be more useful to update to the end of the + ! time increment. + Stokes_Time = Time_present + dt/2 + call Surface_Bands_by_data_override(Stokes_Time, G, GV, US, CS) elseif (CS%DataSource == COUPLER) then if (.not.present(FORCES)) then call MOM_error(FATAL,"The option SURFBAND = COUPLER can not be used with "//& @@ -487,30 +721,39 @@ subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS, forces) endif do b=1,CS%NumBands - CS%WaveNum_Cen(b) = US%Z_to_m * forces%stk_wavenumbers(b) + CS%WaveNum_Cen(b) = forces%stk_wavenumbers(b) !Interpolate from a grid to c grid - do jj=G%jsc,G%jec - do II=G%iscB,G%iecB - CS%STKx0(II,jj,b) = US%m_s_to_L_T*0.5*(forces%UStkb(ii,jj,b)+forces%UStkb(ii+1,jj,b)) + do j=G%jsc,G%jec + do I=G%iscB,G%iecB + CS%STKx0(I,j,b) = 0.5*(forces%UStkb(i,j,b)+forces%UStkb(i+1,j,b)) enddo enddo - do JJ=G%jscB, G%jecB - do ii=G%isc,G%iec - CS%STKY0(ii,JJ,b) = US%m_s_to_L_T*0.5*(forces%VStkb(ii,jj,b)+forces%VStkb(ii,jj+1,b)) + do J=G%jscB,G%jecB + do i=G%isc,G%iec + CS%STKY0(i,J,b) = 0.5*(forces%VStkb(i,j,b)+forces%VStkb(i,j+1,b)) enddo enddo call pass_vector(CS%STKx0(:,:,b),CS%STKy0(:,:,b), G%Domain) enddo + do j=G%jsc,G%jec + do i=G%isc,G%iec + CS%Omega_w2x(i,j) = forces%omega_w2x(i,j) + do b=1,CS%NumBands + CS%UStk_Hb(i,j,b) = forces%UStkb(i,j,b) + CS%VStk_Hb(i,j,b) = forces%VStkb(i,j,b) + enddo + enddo + enddo elseif (CS%DataSource == INPUT) then do b=1,CS%NumBands - do jj=G%jsd,G%jed - do II=G%isdB,G%iedB - CS%STKx0(II,jj,b) = CS%PrescribedSurfStkX(b) + do j=G%jsd,G%jed + do I=G%isdB,G%iedB + CS%STKx0(I,j,b) = CS%PrescribedSurfStkX(b) enddo enddo - do JJ=G%jsdB, G%jedB - do ii=G%isd,G%ied - CS%STKY0(ii,JJ,b) = CS%PrescribedSurfStkY(b) + do J=G%jsdB, G%jedB + do i=G%isd,G%ied + CS%STKY0(i,J,b) = CS%PrescribedSurfStkY(b) enddo enddo enddo @@ -521,62 +764,66 @@ end subroutine Update_Surface_Waves !> Constructs the Stokes Drift profile on the model grid based on !! desired coupling options -subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) +subroutine Update_Stokes_Drift(G, GV, US, CS, dz, ustar, dt, dynamics_step) type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure type(ocean_grid_type), intent(inout) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Thickness [H ~> m or kg m-2] + intent(in) :: dz !< Thickness in height units [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: ustar !< Wind friction velocity [Z T-1 ~> m s-1]. + real, intent(in) :: dt !< Time-step for computing Stokes-tendency [T ~> s] + logical, intent(in) :: dynamics_step !< True if this call is on a dynamics step + ! Local Variables real :: Top, MidPoint, Bottom ! Positions within the layer [Z ~> m] - real :: one_cm ! One centimeter in the units of wavelengths [Z ~> m] real :: level_thick ! The thickness of each layer [Z ~> m] - real :: min_level_thick_avg ! A minimum layer thickness for inclusion in the average [Z ~> m] - real :: DecayScale ! A vertical decay scale in the test profile [Z ~> m] + real :: DecayScale ! A vertical decay scale in the test profile [Z-1 ~> m-1] real :: CMN_FAC ! A nondimensional factor [nondim] real :: WN ! Model wavenumber [Z-1 ~> m-1] real :: UStokes ! A Stokes drift velocity [L T-1 ~> m s-1] - real :: PI ! 3.1415926535... + real :: PI ! 3.1415926535... [nondim] real :: La ! The local Langmuir number [nondim] - integer :: ii, jj, kk, b, iim1, jjm1 + integer :: i, j, k, b + real :: I_dt ! The inverse of the time step [T-1 ~> s-1] - one_cm = 0.01*US%m_to_Z - min_level_thick_avg = 1.e-3*US%m_to_Z + if (CS%WaveMethod==EFACTOR) return + + if (allocated(CS%US_x) .and. allocated(CS%US_y)) then + call pass_vector(CS%US_x(:,:,:),CS%US_y(:,:,:), G%Domain) + endif ! 1. If Test Profile Option is chosen ! Computing mid-point value from surface value and decay wavelength if (CS%WaveMethod==TESTPROF) then PI = 4.0*atan(1.0) DecayScale = 4.*PI / CS%TP_WVL !4pi - do jj = G%jsd,G%jed - do II = G%isdB,G%iedB - IIm1 = max(1,II-1) + do j=G%jsc,G%jec + do I=G%iscB,G%iecB Bottom = 0.0 MidPoint = 0.0 - do kk = 1,GV%ke + do k = 1,GV%ke Top = Bottom - MidPoint = Bottom - GV%H_to_Z*0.25*(h(II,jj,kk)+h(IIm1,jj,kk)) - Bottom = Bottom - GV%H_to_Z*0.5*(h(II,jj,kk)+h(IIm1,jj,kk)) - CS%Us_x(II,jj,kk) = CS%TP_STKX0*exp(MidPoint*DecayScale) + MidPoint = Bottom - 0.25*(dz(i,j,k)+dz(i+1,j,k)) + Bottom = Bottom - 0.5*(dz(i,j,k)+dz(i+1,j,k)) + CS%Us_x(I,j,k) = CS%TP_STKX0*exp(MidPoint*DecayScale) enddo enddo enddo - do JJ = G%jsdB,G%jedB - do ii = G%isd,G%ied - JJm1 = max(1,JJ-1) + do J=G%jscB,G%jecB + do i=G%isc,G%iec Bottom = 0.0 MidPoint = 0.0 - do kk = 1,GV%ke + do k = 1,GV%ke Top = Bottom - MidPoint = Bottom - GV%H_to_Z*0.25*(h(ii,JJ,kk)+h(ii,JJm1,kk)) - Bottom = Bottom - GV%H_to_Z*0.5*(h(ii,JJ,kk)+h(ii,JJm1,kk)) - CS%Us_y(ii,JJ,kk) = CS%TP_STKY0*exp(MidPoint*DecayScale) + MidPoint = Bottom - 0.25*(dz(i,j,k)+dz(i,j+1,k)) + Bottom = Bottom - 0.5*(dz(i,j,k)+dz(i,j+1,k)) + CS%Us_y(i,J,k) = CS%TP_STKY0*exp(MidPoint*DecayScale) enddo enddo enddo + call pass_vector(CS%Us_x(:,:,:),CS%Us_y(:,:,:), G%Domain, To_All) ! 2. If Surface Bands is chosen ! In wavenumber mode compute integral for layer averaged Stokes drift. ! In frequency mode compuate value at midpoint. @@ -586,167 +833,153 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) CS%Us0_x(:,:) = 0.0 CS%Us0_y(:,:) = 0.0 ! Computing X direction Stokes drift - do jj = G%jsd,G%jed - do II = G%isdB,G%iedB + do j=G%jsc,G%jec + do I=G%iscB,G%iecB ! 1. First compute the surface Stokes drift - ! by integrating over the partitions. + ! by summing over the partitions. do b = 1,CS%NumBands - if (CS%PartitionMode==0) then - ! In wavenumber we are averaging over (small) level - CMN_FAC = (1.0-exp(-one_cm*2.*CS%WaveNum_Cen(b))) / & - (one_cm*2.*CS%WaveNum_Cen(b)) - !### For accuracy and numerical stability rewrite this as: - ! CMN_FAC = one_minus_exp_x(2.*CS%WaveNum_Cen(b)*one_cm) - ! or maybe just take the limit of vanishing thickness, CMN_FAC = 1.0 - elseif (CS%PartitionMode==1) then - ! In frequency we are not averaging over level and taking top - CMN_FAC = 1.0 - endif - CS%US0_x(II,jj) = CS%US0_x(II,jj) + CS%STKx0(II,jj,b)*CMN_FAC + CS%US0_x(I,j) = CS%US0_x(I,j) + CS%STKx0(I,j,b) enddo ! 2. Second compute the level averaged Stokes drift bottom = 0.0 - do kk = 1,GV%ke + do k = 1,GV%ke Top = Bottom - IIm1 = max(II-1,1) - level_thick = 0.5*GV%H_to_Z*(h(II,jj,kk)+h(IIm1,jj,kk)) + level_thick = 0.5*(dz(i,j,k)+dz(i+1,j,k)) MidPoint = Top - 0.5*level_thick Bottom = Top - level_thick - ! -> Stokes drift in thin layers not averaged. - if (level_thick>min_level_thick_avg) then + + if (CS%answer_date >= 20230101) then + ! Use more accurate and numerically stable expressions that work even for vanished layers. + do b = 1,CS%NumBands + if (CS%PartitionMode == 0) then + ! Average over a layer using the bin's central wavenumber. + CMN_FAC = exp(2.*CS%WaveNum_Cen(b)*Top) * one_minus_exp_x(2.*CS%WaveNum_Cen(b)*level_thick) + else + ! Use an analytic expression for the average of an exponential over a layer + WN = CS%Freq_Cen(b)**2 * CS%I_g_Earth + CMN_FAC = exp(2.*WN*Top) * one_minus_exp_x(2.*WN*level_thick) + endif + CS%US_x(I,j,k) = CS%US_x(I,j,k) + CS%STKx0(I,j,b)*CMN_FAC + enddo + + elseif (level_thick > CS%Stokes_min_thick_avg) then + ! -> Stokes drift in thin layers not averaged. do b = 1,CS%NumBands - if (CS%PartitionMode==0) then + if (CS%PartitionMode == 0) then ! In wavenumber we are averaging over level - CMN_FAC = (exp(Top*2.*CS%WaveNum_Cen(b))-exp(Bottom*2.*CS%WaveNum_Cen(b)))& + CMN_FAC = (exp(Top*2.*CS%WaveNum_Cen(b))-exp(Bottom*2.*CS%WaveNum_Cen(b))) & / ((Top-Bottom)*(2.*CS%WaveNum_Cen(b))) - !### For accuracy and numerical stability rewrite this as: - ! CMN_FAC = exp(2.*CS%WaveNum_Cen(b)*Top) * one_minus_exp_x(2.*CS%WaveNum_Cen(b)*level_thick) - elseif (CS%PartitionMode==1) then - if (CS%StkLevelMode==0) then - ! Take the value at the midpoint - CMN_FAC = exp(MidPoint * 2. * CS%Freq_Cen(b)**2 / CS%g_Earth) - elseif (CS%StkLevelMode==1) then - ! Use a numerical integration and then divide by layer thickness - WN = CS%Freq_Cen(b)**2 / CS%g_Earth !bgr bug-fix missing g - CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) - !### For accuracy and numerical stability rewrite this as: - ! CMN_FAC = exp(2.*WN*Top) * one_minus_exp_x(2.*WN*level_thick) - endif + else + ! Use a numerical integration and then divide by layer thickness + WN = CS%Freq_Cen(b)**2 / CS%g_Earth !bgr bug-fix missing g + CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) endif - CS%US_x(II,jj,kk) = CS%US_x(II,jj,kk) + CS%STKx0(II,jj,b)*CMN_FAC + CS%US_x(I,j,k) = CS%US_x(I,j,k) + CS%STKx0(I,j,b)*CMN_FAC enddo - else - ! Take the value at the midpoint + else ! Take the value at the midpoint do b = 1,CS%NumBands - if (CS%PartitionMode==0) then + if (CS%PartitionMode == 0) then CMN_FAC = exp(MidPoint * 2. * CS%WaveNum_Cen(b)) - elseif (CS%PartitionMode==1) then + else CMN_FAC = exp(MidPoint * 2. * CS%Freq_Cen(b)**2 / CS%g_Earth) endif - CS%US_x(II,jj,kk) = CS%US_x(II,jj,kk) + CS%STKx0(II,jj,b)*CMN_FAC + CS%US_x(I,j,k) = CS%US_x(I,j,k) + CS%STKx0(I,j,b)*CMN_FAC enddo endif enddo enddo enddo + ! Computing Y direction Stokes drift - do JJ = G%jsdB,G%jedB - do ii = G%isd,G%ied - ! Compute the surface values. + do J=G%jscB,G%jecB + do i=G%isc,G%iec + ! Set the surface value to that at z=0 do b = 1,CS%NumBands - if (CS%PartitionMode==0) then - ! In wavenumber we are averaging over (small) level - CMN_FAC = (1.0-exp(-one_cm*2.*CS%WaveNum_Cen(b))) / & - (one_cm*2.*CS%WaveNum_Cen(b)) - !### For accuracy and numerical stability rewrite this as: - ! CMN_FAC = one_minus_exp_x(2.*CS%WaveNum_Cen(b)*one_cm) - ! or maybe just take the limit of vanishing thickness, CMN_FAC = 1.0 - elseif (CS%PartitionMode==1) then - ! In frequency we are not averaging over level and taking top - CMN_FAC = 1.0 - endif - CS%US0_y(ii,JJ) = CS%US0_y(ii,JJ) + CS%STKy0(ii,JJ,b)*CMN_FAC + CS%US0_y(i,J) = CS%US0_y(i,J) + CS%STKy0(i,J,b) enddo ! Compute the level averages. bottom = 0.0 - do kk = 1,GV%ke + do k = 1,GV%ke Top = Bottom - JJm1 = max(JJ-1,1) - level_thick = 0.5*GV%H_to_Z*(h(ii,JJ,kk)+h(ii,JJm1,kk)) + level_thick = 0.5*(dz(i,j,k)+dz(i,j+1,k)) MidPoint = Top - 0.5*level_thick Bottom = Top - level_thick - ! -> Stokes drift in thin layers not averaged. - if (level_thick>min_level_thick_avg) then + + if (CS%answer_date >= 20230101) then + ! Use more accurate and numerically stable expressions that work even for vanished layers. + do b = 1,CS%NumBands + if (CS%PartitionMode == 0) then + ! Average over a layer using the bin's central wavenumber. + CMN_FAC = exp(2.*CS%WaveNum_Cen(b)*Top) * one_minus_exp_x(2.*CS%WaveNum_Cen(b)*level_thick) + else + ! Use an analytic expression for the average of an exponential over a layer + WN = CS%Freq_Cen(b)**2 * CS%I_g_Earth + CMN_FAC = exp(2.*WN*Top) * one_minus_exp_x(2.*WN*level_thick) + endif + CS%US_y(i,J,k) = CS%US_y(i,J,k) + CS%STKy0(i,J,b)*CMN_FAC + enddo + elseif (level_thick > CS%Stokes_min_thick_avg) then + ! -> Stokes drift in thin layers not averaged. do b = 1,CS%NumBands - if (CS%PartitionMode==0) then - ! In wavenumber we are averaging over level - CMN_FAC = (exp(Top*2.*CS%WaveNum_Cen(b))-exp(Bottom*2.*CS%WaveNum_Cen(b)))& + if (CS%PartitionMode == 0) then + ! In wavenumber we are averaging over level + CMN_FAC = (exp(Top*2.*CS%WaveNum_Cen(b))-exp(Bottom*2.*CS%WaveNum_Cen(b))) & / ((Top-Bottom)*(2.*CS%WaveNum_Cen(b))) - !### For accuracy and numerical stability rewrite this as: - ! CMN_FAC = exp(2.*CS%WaveNum_Cen(b)*Top) * one_minus_exp_x(2.*CS%WaveNum_Cen(b)*level_thick) - elseif (CS%PartitionMode==1) then - if (CS%StkLevelMode==0) then - ! Take the value at the midpoint - CMN_FAC = exp(MidPoint * 2. * CS%Freq_Cen(b)**2 / CS%g_Earth) - elseif (CS%StkLevelMode==1) then - ! Use a numerical integration and then divide by layer thickness - WN = CS%Freq_Cen(b)**2 / CS%g_Earth !bgr bug-fix missing g - CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) - !### For accuracy and numerical stability rewrite this as: - ! CMN_FAC = exp(2.*WN*Top) * one_minus_exp_x(2.*WN*level_thick) - endif + else + ! Use a numerical integration and then divide by layer thickness + WN = CS%Freq_Cen(b)**2 / CS%g_Earth !bgr bug-fix missing g + CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) endif - CS%US_y(ii,JJ,kk) = CS%US_y(ii,JJ,kk) + CS%STKy0(ii,JJ,b)*CMN_FAC + CS%US_y(i,J,k) = CS%US_y(i,J,k) + CS%STKy0(i,J,b)*CMN_FAC enddo - else - ! Take the value at the midpoint + else ! Take the value at the midpoint do b = 1,CS%NumBands - if (CS%PartitionMode==0) then + if (CS%PartitionMode == 0) then CMN_FAC = exp(MidPoint*2.*CS%WaveNum_Cen(b)) - elseif (CS%PartitionMode==1) then + else CMN_FAC = exp(MidPoint * 2. * CS%Freq_Cen(b)**2 / CS%g_Earth) endif - CS%US_y(ii,JJ,kk) = CS%US_y(ii,JJ,kk) + CS%STKy0(ii,JJ,b)*CMN_FAC + CS%US_y(i,J,k) = CS%US_y(i,J,k) + CS%STKy0(i,J,b)*CMN_FAC enddo endif enddo enddo enddo + call pass_vector(CS%Us_x(:,:,:),CS%Us_y(:,:,:), G%Domain, To_All) + call pass_vector(CS%Us0_x(:,:),CS%Us0_y(:,:), G%Domain) elseif (CS%WaveMethod == DHH85) then if (.not.(CS%StaticWaves .and. CS%DHH85_is_set)) then - do jj = G%jsd,G%jed - do II = G%isdB,G%iedB + do j=G%jsc,G%jec + do I=G%iscB,G%iecB bottom = 0.0 - do kk = 1,GV%ke + do k = 1,GV%ke Top = Bottom - IIm1 = max(II-1,1) - MidPoint = Top - GV%H_to_Z*0.25*(h(II,jj,kk)+h(IIm1,jj,kk)) - Bottom = Top - GV%H_to_Z*0.5*(h(II,jj,kk)+h(IIm1,jj,kk)) - !bgr note that this is using a u-point ii on h-point ustar + MidPoint = Top - 0.25*(dz(i,j,k)+dz(i+1,j,k)) + Bottom = Top - 0.5*(dz(i,j,k)+dz(i+1,j,k)) + !bgr note that this is using a u-point I on h-point ustar ! this code has only been previous used for uniform ! grid cases. This needs fixed if DHH85 is used for non ! uniform cases. call DHH85_mid(GV, US, CS, MidPoint, UStokes) ! Putting into x-direction (no option for direction - CS%US_x(II,jj,kk) = UStokes + CS%US_x(I,j,k) = UStokes enddo enddo enddo - do JJ = G%jsdB,G%jedB - do ii = G%isd,G%ied + do J=G%jscB,G%jecB + do i=G%isc,G%iec Bottom = 0.0 - do kk=1, GV%ke + do k = 1,GV%ke Top = Bottom - JJm1 = max(JJ-1,1) - MidPoint = Bottom - GV%H_to_Z*0.25*(h(ii,JJ,kk)+h(ii,JJm1,kk)) - Bottom = Bottom - GV%H_to_Z*0.5*(h(ii,JJ,kk)+h(ii,JJm1,kk)) - !bgr note that this is using a v-point jj on h-point ustar + MidPoint = Bottom - 0.25*(dz(i,j,k)+dz(i,j+1,k)) + Bottom = Bottom - 0.5*(dz(i,j,k)+dz(i,j+1,k)) + !bgr note that this is using a v-point J on h-point ustar ! this code has only been previous used for uniform ! grid cases. This needs fixed if DHH85 is used for non ! uniform cases. ! call DHH85_mid(GV, US, CS, Midpoint, UStokes) ! Putting into x-direction, so setting y direction to 0 - CS%US_y(ii,JJ,kk) = 0.0 + CS%US_y(i,J,k) = 0.0 ! For rotational symmetry there should be the option for this to become = UStokes ! bgr - see note above, but this is true ! if this is used for anything @@ -756,35 +989,33 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) enddo CS%DHH85_is_set = .true. endif - elseif (CS%WaveMethod==EFACTOR) then - return ! pass + call pass_vector(CS%Us_x(:,:,:),CS%Us_y(:,:,:), G%Domain) else! Keep this else, fallback to 0 Stokes drift - do kk= 1,GV%ke - do jj = G%jsd,G%jed - do II = G%isdB,G%iedB - CS%Us_x(II,jj,kk) = 0. - enddo - enddo - do JJ = G%jsdB,G%jedB - do ii = G%isd,G%ied - CS%Us_y(ii,JJ,kk) = 0. - enddo - enddo - enddo + CS%Us_x(:,:,:) = 0. + CS%Us_y(:,:,:) = 0. endif ! Turbulent Langmuir number is computed here and available to use anywhere. ! SL Langmuir number requires mixing layer depth, and therefore is computed ! in the routine it is needed by (e.g. KPP or ePBL). - do jj = G%jsc, G%jec - do ii = G%isc,G%iec - Top = h(ii,jj,1)*GV%H_to_Z - call get_Langmuir_Number( La, G, GV, US, Top, ustar(ii,jj), ii, jj, & - h(ii,jj,:), CS, Override_MA=.false.) - CS%La_turb(ii,jj) = La + do j=G%jsc, G%jec + do i=G%isc,G%iec + call get_Langmuir_Number( La, G, GV, US, dz(i,j,1), ustar(i,j), i, j, & + dz(i,j,:), CS, Override_MA=.false.) + CS%La_turb(i,j) = La enddo enddo + ! Finding tendency of Stokes drift over the time step to apply + ! as an acceleration to the models current. + if ( dynamics_step .and. CS%Stokes_DDT ) then + I_dt = 1.0 / dt + CS%ddt_us_x(:,:,:) = (CS%US_x(:,:,:) - CS%US_x_prev(:,:,:)) * I_dt + CS%ddt_us_y(:,:,:) = (CS%US_y(:,:,:) - CS%US_y_prev(:,:,:)) * I_dt + CS%US_x_prev(:,:,:) = CS%US_x(:,:,:) + CS%US_y_prev(:,:,:) = CS%US_y(:,:,:) + endif + ! Output any desired quantities if (CS%id_surfacestokes_y>0) & call post_data(CS%id_surfacestokes_y, CS%us0_y, CS%diag) @@ -794,15 +1025,25 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar) call post_data(CS%id_3dstokes_y, CS%us_y, CS%diag) if (CS%id_3dstokes_x>0) & call post_data(CS%id_3dstokes_x, CS%us_x, CS%diag) + if (CS%Stokes_DDT) then + if (CS%id_ddt_3dstokes_x>0) & + call post_data(CS%id_ddt_3dstokes_x, CS%ddt_us_x, CS%diag) + if (CS%id_ddt_3dstokes_y>0) & + call post_data(CS%id_ddt_3dstokes_y, CS%ddt_us_y, CS%diag) + if (CS%id_3dstokes_x_from_ddt>0) & + call post_data(CS%id_3dstokes_x_from_ddt, CS%us_x_from_ddt, CS%diag) + if (CS%id_3dstokes_y_from_ddt>0) & + call post_data(CS%id_3dstokes_y_from_ddt, CS%us_y_from_ddt, CS%diag) + endif if (CS%id_La_turb>0) & call post_data(CS%id_La_turb, CS%La_turb, CS%diag) end subroutine Update_Stokes_Drift -!> Return the value of (1 - exp(-x))/x, using an accurate expression for small values of x. +!> Return the value of (1 - exp(-x))/x [nondim], using an accurate expression for small values of x. real function one_minus_exp_x(x) real, intent(in) :: x !< The argument of the function ((1 - exp(-x))/x) [nondim] - real, parameter :: C1_6 = 1.0/6.0 + real, parameter :: C1_6 = 1.0/6.0 ! A rational fraction [nondim] if (abs(x) <= 2.0e-5) then ! The Taylor series expression for exp(-x) gives a more accurate expression for 64-bit reals. one_minus_exp_x = 1.0 - x * (0.5 - C1_6*x) @@ -811,22 +1052,35 @@ real function one_minus_exp_x(x) endif end function one_minus_exp_x +!> Return the value of (1 - exp(-x)) [nondim], using an accurate expression for small values of x. +real function one_minus_exp(x) + real, intent(in) :: x !< The argument of the function ((1 - exp(-x))/x) [nondim] + real, parameter :: C1_6 = 1.0/6.0 ! A rational fraction [nondim] + if (abs(x) <= 2.0e-5) then + ! The Taylor series expression for exp(-x) gives a more accurate expression for 64-bit reals. + one_minus_exp = x * (1.0 - x * (0.5 - C1_6*x)) + else + one_minus_exp = 1.0 - exp(-x) + endif +end function one_minus_exp + !> A subroutine to fill the Stokes drift from a NetCDF file !! using the data_override procedures. -subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) - type(time_type), intent(in) :: day_center !< Center of timestep +subroutine Surface_Bands_by_data_override(Time, G, GV, US, CS) + type(time_type), intent(in) :: Time !< Time to get Stokes drift bands type(wave_parameters_CS), pointer :: CS !< Wave structure type(ocean_grid_type), intent(inout) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables - real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal Stokes drift of band at h-points [m s-1] - real :: temp_y(SZI_(G),SZJ_(G)) ! Psuedo-meridional Stokes drift of band at h-points [m s-1] + real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal Stokes drift of band at h-points [L T-1 ~> m s-1] + real :: temp_y(SZI_(G),SZJ_(G)) ! Pseudo-meridional Stokes drift of band at h-points [L T-1 ~> m s-1] integer, dimension(4) :: sizes ! The sizes of the various dimensions of the variable. character(len=48) :: dim_name(4) ! The names of the dimensions of the variable. character(len=20) :: varname ! The name of an input variable for data override. - real :: PI ! 3.1415926535... + real :: PI ! 3.1415926535... [nondim] + real :: avgx, avgy ! The global averages of temp_x and temp_y [L T-1 ~> m s-1] logical :: wavenumber_exists integer :: ndims, b, i, j @@ -873,7 +1127,7 @@ subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) PI = 4.0*atan(1.0) call read_variable(CS%SurfBandFileName, dim_name(1), CS%Freq_Cen, scale=2.*PI*US%T_to_s) - do B = 1,CS%NumBands + do b = 1,CS%NumBands CS%WaveNum_Cen(b) = CS%Freq_Cen(b)**2 / CS%g_Earth enddo endif @@ -891,32 +1145,40 @@ subroutine Surface_Bands_by_data_override(day_center, G, GV, US, CS) temp_y(:,:) = 0.0 varname = ' ' write(varname, "(A3,I0)") 'Usx', b - call data_override('OCN', trim(varname), temp_x, day_center) + call data_override(G%Domain, trim(varname), temp_x, Time, scale=US%m_s_to_L_T) varname = ' ' write(varname, "(A3,I0)") 'Usy', b - call data_override('OCN', trim(varname), temp_y, day_center) + call data_override(G%Domain, trim(varname), temp_y, Time, scale=US%m_s_to_L_T) ! Update halo on h-grid call pass_vector(temp_x, temp_y, G%Domain, To_All, AGRID) ! Filter land values do j = G%jsd,G%jed do i = G%Isd,G%Ied - if (abs(temp_x(i,j)) > 10. .or. abs(temp_y(i,j)) > 10.) then + if ((abs(temp_x(i,j)) > CS%land_speed) .or. (abs(temp_y(i,j)) > CS%land_speed)) then ! Assume land-mask and zero out temp_x(i,j) = 0.0 temp_y(i,j) = 0.0 endif enddo enddo + if (CS%Homogenize_Surfbands) then + avgx = global_area_mean(temp_x, G) + avgy = global_area_mean(temp_y, G) + do j = G%jsd,G%jed ; do i = G%Isd,G%Ied ; if (G%mask2dT(i,j) > 0.0) then + temp_y(i,j) = avgy + temp_x(i,j) = avgx + endif ; enddo ; enddo + endif ! Interpolate to u/v grids do j = G%jsc,G%jec do I = G%IscB,G%IecB - CS%STKx0(I,j,b) = 0.5 * US%m_s_to_L_T*(temp_x(i,j) + temp_x(i+1,j)) + CS%STKx0(I,j,b) = 0.5 * (temp_x(i,j) + temp_x(i+1,j)) enddo enddo do J = G%JscB,G%JecB do i = G%isc,G%iec - CS%STKy0(i,J,b) = 0.5 * US%m_s_to_L_T*(temp_y(i,j) + temp_y(i,j+1)) + CS%STKy0(i,J,b) = 0.5 * (temp_y(i,j) + temp_y(i,j+1)) enddo enddo enddo !Closes b-loop @@ -931,7 +1193,7 @@ end subroutine Surface_Bands_by_data_override !! Note this can be called with an unallocated Waves pointer, which is okay if we !! want the wind-speed only dependent Langmuir number. Therefore, we need to be !! careful about what we try to access here. -subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, h, Waves, & +subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, dz, Waves, & U_H, V_H, Override_MA ) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure @@ -941,7 +1203,7 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, h, Waves, & real, intent(in) :: ustar !< Friction velocity [Z T-1 ~> m s-1] integer, intent(in) :: i !< Meridional index of h-point integer, intent(in) :: j !< Zonal index of h-point - real, dimension(SZK_(GV)), intent(in) :: h !< Grid layer thickness [H ~> m or kg m-2] + real, dimension(SZK_(GV)), intent(in) :: dz !< Grid layer thickness [Z ~> m] type(Wave_parameters_CS), pointer :: Waves !< Surface wave control structure. real, dimension(SZK_(GV)), & optional, intent(in) :: U_H !< Zonal velocity at H point [L T-1 ~> m s-1] or [m s-1] @@ -954,7 +1216,7 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, h, Waves, & !Local Variables - real :: Top, bottom, midpoint ! Positions within each layer [Z ~> m] + real :: Top, Bottom, MidPoint ! Positions within each layer [Z ~> m] real :: Dpt_LASL ! Averaging depth for Stokes drift [Z ~> m] real :: ShearDirection ! Shear angular direction from atan2 [radians] real :: WaveDirection ! Wave angular direction from atan2 [radians] @@ -962,11 +1224,10 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, h, Waves, & logical :: ContinueLoop, USE_MA real, dimension(SZK_(GV)) :: US_H, VS_H ! Profiles of Stokes velocities [L T-1 ~> m s-1] real, allocatable :: StkBand_X(:), StkBand_Y(:) ! Stokes drifts by band [L T-1 ~> m s-1] - integer :: KK, BB - + integer :: k, BB - ! Compute averaging depth for Stokes drift (negative) - Dpt_LASL = min(-0.1*US%m_to_Z, -Waves%LA_FracHBL*HBL) + ! Compute averaging depth for Stokes drift (negative) + Dpt_LASL = -1.0*max(Waves%LA_FracHBL*HBL, Waves%LA_HBL_min) USE_MA = Waves%LA_Misalignment if (present(Override_MA)) USE_MA = Override_MA @@ -977,25 +1238,34 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, h, Waves, & "Get_LA_waves requested to consider misalignment, but velocities were not provided.") ContinueLoop = .true. bottom = 0.0 - do kk = 1,GV%ke + do k = 1,GV%ke Top = Bottom - MidPoint = Bottom + GV%H_to_Z*0.5*h(kk) - Bottom = Bottom + GV%H_to_Z*h(kk) - if (MidPoint > Dpt_LASL .and. kk > 1 .and. ContinueLoop) then - ShearDirection = atan2(V_H(1)-V_H(kk),U_H(1)-U_H(kk)) - ContinueLoop = .false. + MidPoint = Bottom + 0.5*dz(k) + Bottom = Bottom + dz(k) + + if (Waves%LA_Misalign_bug) then + ! Given the sign convention that Dpt_LASL is negative, the next line has a bug. + if (MidPoint > Dpt_LASL .and. k > 1 .and. ContinueLoop) then + ShearDirection = atan2(V_H(1)-V_H(k), U_H(1)-U_H(k)) + ContinueLoop = .false. + endif + else ! This version avoids the bug in the version above. + if (MidPoint > abs(Dpt_LASL) .and. (k > 1) .and. ContinueLoop) then + ShearDirection = atan2(V_H(1)-V_H(k), U_H(1)-U_H(k)) + ContinueLoop = .false. + endif endif enddo endif if (Waves%WaveMethod==TESTPROF) then - do kk = 1,GV%ke - US_H(kk) = 0.5*(Waves%US_X(I,j,kk)+Waves%US_X(I-1,j,kk)) - VS_H(kk) = 0.5*(Waves%US_Y(i,J,kk)+Waves%US_Y(i,J-1,kk)) + do k = 1,GV%ke + US_H(k) = 0.5*(Waves%US_X(I,j,k)+Waves%US_X(I-1,j,k)) + VS_H(k) = 0.5*(Waves%US_Y(i,J,k)+Waves%US_Y(i,J-1,k)) enddo - call Get_SL_Average_Prof( GV, Dpt_LASL, h, US_H, LA_STKx) - call Get_SL_Average_Prof( GV, Dpt_LASL, h, VS_H, LA_STKy) - LA_STK = sqrt(LA_STKX*LA_STKX+LA_STKY*LA_STKY) + call Get_SL_Average_Prof( GV, Dpt_LASL, dz, US_H, LA_STKx) + call Get_SL_Average_Prof( GV, Dpt_LASL, dz, VS_H, LA_STKy) + LA_STK = sqrt((LA_STKX*LA_STKX) + (LA_STKY*LA_STKY)) elseif (Waves%WaveMethod==SURFBANDS) then allocate(StkBand_X(Waves%NumBands), StkBand_Y(Waves%NumBands)) do bb = 1,Waves%NumBands @@ -1004,34 +1274,30 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, h, Waves, & enddo call Get_SL_Average_Band(GV, Dpt_LASL, Waves%NumBands, Waves%WaveNum_Cen, StkBand_X, LA_STKx ) call Get_SL_Average_Band(GV, Dpt_LASL, Waves%NumBands, Waves%WaveNum_Cen, StkBand_Y, LA_STKy ) - LA_STK = sqrt(LA_STKX**2 + LA_STKY**2) + LA_STK = sqrt((LA_STKX**2) + (LA_STKY**2)) deallocate(StkBand_X, StkBand_Y) elseif (Waves%WaveMethod==DHH85) then ! Temporarily integrating profile rather than spectrum for simplicity - do kk = 1,GV%ke - US_H(kk) = 0.5*(Waves%US_X(I,j,kk)+Waves%US_X(I-1,j,kk)) - VS_H(kk) = 0.5*(Waves%US_Y(i,J,kk)+Waves%US_Y(i,J-1,kk)) + do k = 1,GV%ke + US_H(k) = 0.5*(Waves%US_X(I,j,k)+Waves%US_X(I-1,j,k)) + VS_H(k) = 0.5*(Waves%US_Y(i,J,k)+Waves%US_Y(i,J-1,k)) enddo - call Get_SL_Average_Prof( GV, Dpt_LASL, h, US_H, LA_STKx) - call Get_SL_Average_Prof( GV, Dpt_LASL, h, VS_H, LA_STKy) - LA_STK = sqrt(LA_STKX**2 + LA_STKY**2) + call Get_SL_Average_Prof( GV, Dpt_LASL, dz, US_H, LA_STKx) + call Get_SL_Average_Prof( GV, Dpt_LASL, dz, VS_H, LA_STKy) + LA_STK = sqrt((LA_STKX**2) + (LA_STKY**2)) elseif (Waves%WaveMethod==LF17) then - call get_StokesSL_LiFoxKemper(ustar, hbl*Waves%LA_FracHBL, GV, US, Waves, LA_STK, LA) + call get_StokesSL_LiFoxKemper(ustar, HBL*Waves%LA_FracHBL, GV, US, Waves, LA_STK, LA) elseif (Waves%WaveMethod==Null_WaveMethod) then call MOM_error(FATAL, "Get_Langmuir_number called without defining a WaveMethod. "//& - "Suggest to make sure USE_LT is set/overridden to False or "//& - "choose a wave method (or set USE_LA_LI2016 to use statistical "//& - "waves.") + "Suggest to make sure USE_LT is set/overridden to False or choose "//& + "a wave method (or set USE_LA_LI2016 to use statistical waves).") endif if (.not.(Waves%WaveMethod==LF17)) then - ! This is an arbitrary lower bound on Langmuir number. - ! We shouldn't expect values lower than this, but - ! there is also no good reason to cap it here other then - ! to prevent large enhancements in unconstrained parts of - ! the curve fit parameterizations. - ! Note the dimensional constant background Stokes velocity of 10^-10 m s-1. - LA = max(Waves%La_min, sqrt(US%Z_to_L*ustar / (LA_STK + 1.e-10*US%m_s_to_L_T))) + ! This expression uses an arbitrary lower bound on Langmuir number. + ! We shouldn't expect values lower than this, but there is also no good reason to cap it here + ! other than to prevent large enhancements in unconstrained parts of the curve fit parameterizations. + LA = max(Waves%La_min, sqrt(US%Z_to_L*ustar / (LA_STK + Waves%La_Stk_backgnd))) endif if (Use_MA) then @@ -1074,7 +1340,7 @@ end function get_wave_method !! !! Update (Jan/25): !! - Converted from function to subroutine, now returns Langmuir number. -!! - Computs 10m wind internally, so only ustar and hbl need passed to +!! - Compute 10m wind internally, so only ustar and hbl need passed to !! subroutine. !! !! Qing Li, 160606 @@ -1089,19 +1355,14 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure real, intent(out) :: UStokes_SL !< Surface layer averaged Stokes drift [L T-1 ~> m s-1] - real, intent(out) :: LA !< Langmuir number + real, intent(out) :: LA !< Langmuir number [nondim] ! Local variables ! parameters - real, parameter :: & - ! ratio of U19.5 to U10 (Holthuijsen, 2007) [nondim] - u19p5_to_u10 = 1.075, & - ! ratio of mean frequency to peak frequency for - ! Pierson-Moskowitz spectrum (Webb, 2011) [nondim] - fm_into_fp = 1.296, & - ! ratio of surface Stokes drift to U10 [nondim] - us_to_u10 = 0.0162, & - ! loss ratio of Stokes transport [nondim] - r_loss = 0.667 + real, parameter :: u19p5_to_u10 = 1.075 ! ratio of U19.5 to U10 (Holthuijsen, 2007) [nondim] + real, parameter :: fm_into_fp = 1.296 ! ratio of mean frequency to peak frequency for + ! Pierson-Moskowitz spectrum (Webb, 2011) [nondim] + real, parameter :: us_to_u10 = 0.0162 ! ratio of surface Stokes drift to U10 [nondim] + real, parameter :: r_loss = 0.667 ! loss ratio of Stokes transport [nondim] real :: UStokes ! The surface Stokes drift [L T-1 ~> m s-1] real :: hm0 ! The significant wave height [Z ~> m] real :: fm ! The mean wave frequency [T-1 ~> s-1] @@ -1110,13 +1371,13 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) real :: kstar ! A rescaled wavenumber? [Z-1 ~> m-1] real :: vstokes ! The total Stokes transport [Z L T-1 ~> m2 s-1] real :: z0 ! The boundary layer depth [Z ~> m] - real :: z0i ! The inverse of theboundary layer depth [Z-1 ~> m-1] + real :: z0i ! The inverse of the boundary layer depth [Z-1 ~> m-1] real :: r1, r2, r3, r4 ! Nondimensional ratios [nondim] - real :: r5 ! A single expression that combines r3 and r4 [nondim] + real :: r5 ! A single expression that combines r2 and r4 [nondim] real :: root_2kz ! The square root of twice the peak wavenumber times the ! boundary layer depth [nondim] real :: u10 ! The 10 m wind speed [L T-1 ~> m s-1] - real :: PI ! 3.1415926535... + real :: PI ! 3.1415926535... [nondim] PI = 4.0*atan(1.0) UStokes_sl = 0.0 @@ -1125,12 +1386,12 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) ! This code should be revised to minimize the number of divisions and cancel out common factors. ! Computing u10 based on u_star and COARE 3.5 relationships - call ust_2_u10_coare3p5(ustar*sqrt(GV%Rho0/(1.225*US%kg_m3_to_R)), u10, GV, US, CS) + call ust_2_u10_coare3p5(ustar*sqrt(CS%rho_ocn/CS%rho_air), u10, GV, US, CS) ! surface Stokes drift UStokes = us_to_u10*u10 ! ! significant wave height from Pierson-Moskowitz spectrum (Bouws, 1998) - hm0 = 0.0246*US%m_to_Z*US%L_T_to_m_s**2 * u10**2 + hm0 = CS%SWH_from_u10sq * u10**2 ! ! peak frequency (PM, Bouws, 1998) fp = 0.877 * (US%L_to_Z*GV%g_Earth) / (2.0 * PI * u19p5_to_u10 * u10) @@ -1147,57 +1408,61 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) ! the general peak wavenumber for Phillips' spectrum ! (Breivik et al., 2016) with correction of directional spreading kphil = 0.176 * UStokes / vstokes - ! - ! surface layer averaged Stokes drift with Stokes drift profile - ! estimated from Phillips' spectrum (Breivik et al., 2016) - ! the directional spreading effect from Webb and Fox-Kemper, 2015 - ! is also included - kstar = kphil * 2.56 - ! surface layer - z0 = abs(hbl) - z0i = 1.0 / z0 ! Combining all of the expressions above gives kPhil as the following ! where the first two lines are just a constant: - ! kPhil = ((0.176 * us_to_u10 * u19p5_to_u10) / & - ! (0.5*0.125 * r_loss * fm_into_fp * 0.877 * 0.0246**2)) * & - ! (US%T_to_s*US%m_s_to_L_T)**2 / (CS%g_Earth * u10**2) - - ! Terms 1 to 4, as written in the appendix of Li et al. (2017) - r1 = ( 0.151 / kphil * z0i - 0.84 ) * & - ( 1.0 - exp(-2.0 * kphil * z0) ) - r2 = -( 0.84 + 0.0591 / kphil * z0i ) * & - sqrt( 2.0 * PI * kphil * z0 ) * & - erfc( sqrt( 2.0 * kphil * z0 ) ) - r3 = ( 0.0632 / kstar * z0i + 0.125 ) * & - (1.0 - exp(-2.0 * kstar * z0) ) - r4 = ( 0.125 + 0.0946 / kstar * z0i ) * & - sqrt( 2.0 * PI * kstar * z0) * & - erfc( sqrt( 2.0 * kstar * z0 ) ) - UStokes_sl = UStokes * (0.715 + r1 + r2 + r3 + r4) - - ! The following is equivalent to the code above, but avoids singularities -! r1 = ( 0.302 - 1.68*kphil*z0 ) * one_minus_exp_x(2.0*kphil * z0) -! r3 = ( 0.1264 + 0.64*kphil*z0 ) * one_minus_exp_x(5.12*kphil * z0) -! root_2kz = sqrt(2.0 * kphil * z0) -! ! r2 = -( 0.84 + 0.0591*2.0 / (root_2kz**2) ) * sqrt(PI) * root_2kz * erfc( root_2kz ) -! ! r4 = ( 0.2 + 0.059125*2.0 / (root_2kz**2) ) * sqrt(PI)* root_2kz * erfc( 1.6 * root_2kz ) -! -! ! r5 = r2 + r4 (with a small correction to one coefficient to avoid a singularity when z0 = 0): -! ! The correction leads to <1% relative differences in (r2+r4) for root_2kz > 0.05, but without -! ! it the values of r2 + r4 are qualitatively wrong (>50% errors) for root_2kz < 0.0015 . -! ! It has been verified that these two expressions for r5 are the same to 6 decimal places for -! ! root_2kz between 1e-10 and 1e-3, but that the first one degrades for smaller values. -! if (root_2kz > 1e-3) then -! r5 = sqrt(PI) * (root_2kz * (-0.84 * erfc(root_2kz) + 0.2 * erfc(1.6*root_2kz)) + & -! 0.1182 * (erfc(1.6*root_2kz) - erfc(root_2kz)) / root_2kz) -! else -! ! It is more accurate to replace erf with the first two terms of its Taylor series -! ! erf(z) = (2/sqrt(pi)) * z * (1. - (1/3)*z**2 + (1/10)*z**4 - (1/42)*z**6 + ...) -! ! and then cancel or combine common terms and drop negligibly small terms. -! r5 = -0.64*sqrt(PI)*root_2kz + (-0.14184 + 1.0839648 * root_2kz**2) -! endif -! UStokes_sl = UStokes * (0.715 + ((r1 + r2) + r5)) + ! kphil = ((0.176 * us_to_u10 * u19p5_to_u10) / & + ! (0.5*0.125 * r_loss * fm_into_fp * 0.877 * CS%SWH_from_u10sq**2)) / & + ! (GV%g_Earth * u10**2) + + ! surface layer + z0 = abs(hbl) + + if (CS%answer_date < 20230102) then + z0i = 1.0 / z0 + + ! Surface layer averaged Stokes drift with Stokes drift profile + ! estimated from Phillips' spectrum (Breivik et al., 2016) + ! The directional spreading effect from Webb and Fox-Kemper, 2015 is also included. + kstar = kphil * 2.56 + + ! Terms 1 to 4, as written in the appendix of Li et al. (2017) + r1 = ( 0.151 / kphil * z0i - 0.84 ) * & + ( 1.0 - exp(-2.0 * kphil * z0) ) + r2 = -( 0.84 + 0.0591 / kphil * z0i ) * & + sqrt( 2.0 * PI * kphil * z0 ) * & + erfc( sqrt( 2.0 * kphil * z0 ) ) + r3 = ( 0.0632 / kstar * z0i + 0.125 ) * & + (1.0 - exp(-2.0 * kstar * z0) ) + r4 = ( 0.125 + 0.0946 / kstar * z0i ) * & + sqrt( 2.0 * PI * kstar * z0) * & + erfc( sqrt( 2.0 * kstar * z0 ) ) + UStokes_sl = UStokes * (0.715 + r1 + r2 + r3 + r4) + else + ! The following is equivalent to the code above, but avoids singularities + r1 = ( 0.302 - 1.68*(kphil*z0) ) * one_minus_exp_x(2.0 * (kphil * z0)) + r3 = ( 0.1264 + 0.64*(kphil*z0) ) * one_minus_exp_x(5.12 * (kphil * z0)) + + root_2kz = sqrt(2.0 * kphil * z0) + ! r2 = -( 0.84 + 0.0591*2.0 / (root_2kz**2) ) * sqrt(PI) * root_2kz * erfc( root_2kz ) + ! r4 = ( 0.2 + 0.059125*2.0 / (root_2kz**2) ) * sqrt(PI) * root_2kz * erfc( 1.6 * root_2kz ) + + ! r5 = r2 + r4 (with a small correction to one coefficient to avoid a singularity when z0 = 0): + ! The correction leads to <1% relative differences in (r2+r4) for root_2kz > 0.05, but without + ! it the values of r2 + r4 are qualitatively wrong (>50% errors) for root_2kz < 0.0015 . + ! It has been verified that these two expressions for r5 are the same to 6 decimal places for + ! root_2kz between 1e-10 and 1e-3, but that the first one degrades for smaller values. + if (root_2kz > 1e-3) then + r5 = sqrt(PI) * (root_2kz * (-0.84 * erfc(root_2kz) + 0.2 * erfc(1.6*root_2kz)) + & + 0.1182 * (erfc(1.6*root_2kz) - erfc(root_2kz)) / root_2kz) + else + ! It is more accurate to replace erf with the first two terms of its Taylor series + ! erf(z) = (2/sqrt(pi)) * z * (1. - (1/3)*z**2 + (1/10)*z**4 - (1/42)*z**6 + ...) + ! and then cancel or combine common terms and drop negligibly small terms. + r5 = -0.64*sqrt(PI)*root_2kz + (-0.14184 + 1.0839648 * root_2kz**2) + endif + UStokes_sl = UStokes * (0.715 + ((r1 + r3) + r5)) + endif if (UStokes_sl /= 0.0) LA = sqrt(US%Z_to_L*ustar / UStokes_sl) endif @@ -1205,35 +1470,34 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) end subroutine Get_StokesSL_LiFoxKemper !> Get SL Averaged Stokes drift from a Stokes drift Profile -subroutine Get_SL_Average_Prof( GV, AvgDepth, H, Profile, Average ) +subroutine Get_SL_Average_Prof( GV, AvgDepth, dz, Profile, Average ) type(verticalGrid_type), & intent(in) :: GV !< Ocean vertical grid structure - real, intent(in) :: AvgDepth !< Depth to average over (negative) [Z ~> m]. + real, intent(in) :: AvgDepth !< Depth to average over (negative) [Z ~> m] real, dimension(SZK_(GV)), & - intent(in) :: H !< Grid thickness [H ~> m or kg m-2] + intent(in) :: dz !< Grid thickness [Z ~> m] real, dimension(SZK_(GV)), & - intent(in) :: Profile !< Profile of quantity to be averaged [arbitrary] + intent(in) :: Profile !< Profile of quantity to be averaged in arbitrary units [A] !! (used here for Stokes drift) - real, intent(out) :: Average !< Output quantity averaged over depth AvgDepth [arbitrary] + real, intent(out) :: Average !< Output quantity averaged over depth AvgDepth [A] !! (used here for Stokes drift) !Local variables - real :: top, midpoint, bottom ! Depths, negative downward [Z ~> m]. - real :: Sum - integer :: kk + real :: Top, Bottom ! Depths, negative downward [Z ~> m] + real :: Sum ! The depth weighted vertical sum of a quantity [A Z ~> A m] + integer :: k ! Initializing sum Sum = 0.0 ! Integrate bottom = 0.0 - do kk = 1, GV%ke + do k = 1, GV%ke Top = Bottom - MidPoint = Bottom - GV%H_to_Z * 0.5*h(kk) - Bottom = Bottom - GV%H_to_Z * h(kk) + Bottom = Bottom - dz(k) if (AvgDepth < Bottom) then ! The whole cell is within H_LA - Sum = Sum + Profile(kk) * (GV%H_to_Z * H(kk)) + Sum = Sum + Profile(k) * dz(k) elseif (AvgDepth < Top) then ! A partial cell is within H_LA - Sum = Sum + Profile(kk) * (Top-AvgDepth) + Sum = Sum + Profile(k) * (Top-AvgDepth) exit else exit @@ -1298,23 +1562,18 @@ subroutine DHH85_mid(GV, US, CS, zpt, UStokes) real :: omega_peak ! The peak wave frequency [T-1 ~> s-1] real :: omega ! The average frequency in the band [T-1 ~> s-1] real :: domega ! The width in frequency of the band [T-1 ~> s-1] - real :: omega_min ! The minimum wave frequency [T-1 ~> s-1] - real :: omega_max ! The maximum wave frequency [T-1 ~> s-1] real :: u10 ! The wind speed for this spectrum [Z T-1 ~> m s-1] real :: wavespec ! The wave spectrum [L Z T ~> m2 s] real :: Stokes ! The Stokes displacement per cycle [L ~> m] - real :: PI ! 3.1415926535... + real :: PI ! 3.1415926535... [nondim] integer :: Nomega ! The number of wavenumber bands integer :: OI u10 = CS%WaveWind*US%L_to_Z !/ - omega_min = 0.1*US%T_to_s ! Hz - ! Cut off at 30cm for now... - omega_max = 10.*US%T_to_s ! ~sqrt(0.2*g_Earth*2*pi/0.3) NOmega = 1000 - domega = (omega_max-omega_min)/real(NOmega) + domega = (CS%omega_max - CS%omega_min) / real(NOmega) ! if (CS%WaveAgePeakFreq) then @@ -1333,13 +1592,13 @@ subroutine DHH85_mid(GV, US, CS, zpt, UStokes) endif !/ UStokes = 0.0 - omega = omega_min + 0.5*domega + omega = CS%omega_min + 0.5*domega do oi = 1,nomega-1 Dnn = exp ( -0.5 * (omega-omega_peak)**2 / (Snn**2 * omega_peak**2) ) - ! wavespec units = m2s + ! wavespec units [L Z T ~> m2 s] wavespec = US%Z_to_L * (Ann * CS%g_Earth**2 / (omega_peak*omega**4 ) ) * & exp(-bnn*(omega_peak/omega)**4)*Cnn**Dnn - ! Stokes units m (multiply by frequency range for units of m/s) + ! Stokes units [L ~> m] (multiply by frequency range for units of [L T-1 ~> m s-1]) Stokes = 2.0 * wavespec * omega**3 * & exp( 2.0 * omega**2 * zpt / CS%g_Earth) / CS%g_Earth UStokes = UStokes + Stokes*domega @@ -1350,7 +1609,7 @@ end subroutine DHH85_mid !> Explicit solver for Stokes mixing. !! Still in development do not use. -subroutine StokesMixing(G, GV, dt, h, u, v, Waves ) +subroutine StokesMixing(G, GV, dt, h, dz, u, v, Waves ) type(ocean_grid_type), & intent(in) :: G !< Ocean grid type(verticalGrid_type), & @@ -1358,6 +1617,8 @@ subroutine StokesMixing(G, GV, dt, h, u, v, Waves ) real, intent(in) :: dt !< Time step of MOM6 [T ~> s] for explicit solver real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: dz !< Vertical distance between interfaces around a layer [Z ~> m] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: u !< Velocity i-component [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & @@ -1365,9 +1626,10 @@ subroutine StokesMixing(G, GV, dt, h, u, v, Waves ) type(Wave_parameters_CS), & pointer :: Waves !< Surface wave related control structure. ! Local variables - real :: dTauUp, dTauDn ! Vertical momentum fluxes [Z L T-2 ~> m2 s-2] - real :: h_Lay ! The layer thickness at a velocity point [Z ~> m]. - integer :: i,j,k + real :: dTauUp, dTauDn ! Vertical momentum fluxes [H L T-2 ~> m2 s-2 or Pa] + real :: h_lay ! The layer thickness at a velocity point [H ~> m or kg m-2] + real :: dz_lay ! The distance between interfaces at a velocity point [Z ~> m] + integer :: i, j, k ! This is a template to think about down-Stokes mixing. ! This is not ready for use... @@ -1375,18 +1637,19 @@ subroutine StokesMixing(G, GV, dt, h, u, v, Waves ) do k = 1, GV%ke do j = G%jsc, G%jec do I = G%iscB, G%iecB - h_lay = GV%H_to_Z*0.5*(h(i,j,k)+h(i+1,j,k)) + h_lay = 0.5*(h(i,j,k)+h(i+1,j,k)) + dz_lay = 0.5*(dz(i,j,k)+dz(i+1,j,k)) dTauUp = 0.0 if (k > 1) & - dTauUp = 0.5*(waves%Kvs(i,j,k)+waves%Kvs(i+1,j,k)) * & + dTauUp = (0.5*(waves%Kvs(i,j,k)+waves%Kvs(i+1,j,k))) * & (waves%us_x(i,j,k-1)-waves%us_x(i,j,k)) / & - (0.5*(h_lay + GV%H_to_Z*0.5*(h(i,j,k-1)+h(i+1,j,k-1)) )) + (0.5*(dz_lay + 0.5*(dz(i,j,k-1)+dz(i+1,j,k-1)) )) dTauDn = 0.0 if (k < GV%ke-1) & - dTauDn = 0.5*(waves%Kvs(i,j,k+1)+waves%Kvs(i+1,j,k+1)) * & + dTauDn = (0.5*(waves%Kvs(i,j,k+1)+waves%Kvs(i+1,j,k+1))) * & (waves%us_x(i,j,k)-waves%us_x(i,j,k+1)) / & - (0.5*(h_lay + GV%H_to_Z*0.5*(h(i,j,k+1)+h(i+1,j,k+1)) )) - u(i,j,k) = u(i,j,k) + dt * (dTauUp-dTauDn) / h_Lay + (0.5*(dz_lay + 0.5*(dz(i,j,k+1)+dz(i+1,j,k+1)) )) + u(i,j,k) = u(i,j,k) + dt * (dTauUp-dTauDn) / h_lay enddo enddo enddo @@ -1394,18 +1657,19 @@ subroutine StokesMixing(G, GV, dt, h, u, v, Waves ) do k = 1, GV%ke do J = G%jscB, G%jecB do i = G%isc, G%iec - h_Lay = GV%H_to_Z*0.5*(h(i,j,k)+h(i,j+1,k)) + h_lay = 0.5*(h(i,j,k)+h(i,j+1,k)) + dz_lay = 0.5*(dz(i,j,k)+dz(i,j+1,k)) dTauUp = 0. if (k > 1) & - dTauUp = 0.5*(waves%Kvs(i,j,k)+waves%Kvs(i,j+1,k)) * & + dTauUp = (0.5*(waves%Kvs(i,j,k)+waves%Kvs(i,j+1,k))) * & (waves%us_y(i,j,k-1)-waves%us_y(i,j,k)) / & - (0.5*(h_lay + GV%H_to_Z*0.5*(h(i,j,k-1)+h(i,j+1,k-1)) )) + (0.5*(dz_lay + 0.5*(dz(i,j,k-1)+dz(i,j+1,k-1)) )) dTauDn = 0.0 if (k < GV%ke-1) & - dTauDn =0.5*(waves%Kvs(i,j,k+1)+waves%Kvs(i,j+1,k+1)) * & + dTauDn = (0.5*(waves%Kvs(i,j,k+1)+waves%Kvs(i,j+1,k+1))) * & (waves%us_y(i,j,k)-waves%us_y(i,j,k+1)) / & - (0.5*(h_lay + GV%H_to_Z*0.5*(h(i,j,k+1)+h(i,j+1,k+1)) )) - v(i,J,k) = v(i,J,k) + dt * (dTauUp-dTauDn) / h_Lay + (0.5*(dz_lay + 0.5*(dz(i,j,k+1)+dz(i,j+1,k+1)) )) + v(i,J,k) = v(i,J,k) + dt * (dTauUp-dTauDn) / h_lay enddo enddo enddo @@ -1440,8 +1704,8 @@ subroutine CoriolisStokes(G, GV, dt, h, u, v, Waves) do k = 1, GV%ke do j = G%jsc, G%jec do I = G%iscB, G%iecB - DVel = 0.25*(Waves%us_y(i,j+1,k)+Waves%us_y(i-1,j+1,k))*G%CoriolisBu(i,j+1) + & - 0.25*(Waves%us_y(i,j,k)+Waves%us_y(i-1,j,k))*G%CoriolisBu(i,j) + DVel = 0.25*((Waves%us_y(i,J-1,k)+Waves%us_y(i+1,J-1,k)) * G%CoriolisBu(I,J-1)) + & + 0.25*((Waves%us_y(i,J,k)+Waves%us_y(i+1,J,k)) * G%CoriolisBu(I,J)) u(I,j,k) = u(I,j,k) + DVEL*dt enddo enddo @@ -1450,14 +1714,347 @@ subroutine CoriolisStokes(G, GV, dt, h, u, v, Waves) do k = 1, GV%ke do J = G%jscB, G%jecB do i = G%isc, G%iec - DVel = 0.25*(Waves%us_x(i+1,j,k)+Waves%us_x(i+1,j-1,k))*G%CoriolisBu(i+1,j) + & - 0.25*(Waves%us_x(i,j,k)+Waves%us_x(i,j-1,k))*G%CoriolisBu(i,j) + DVel = 0.25*((Waves%us_x(I-1,j,k)+Waves%us_x(I-1,j+1,k)) * G%CoriolisBu(I-1,j)) + & + 0.25*((Waves%us_x(I,j,k)+Waves%us_x(I,j+1,k)) * G%CoriolisBu(I,J)) v(i,J,k) = v(i,j,k) - DVEL*dt enddo enddo enddo end subroutine CoriolisStokes +!> Computes tendency due to Stokes pressure gradient force anomaly +!! including analytical integration of Stokes shear using multiple-exponential decay +!! Stokes drift profile and vertical integration of the resulting pressure +!! anomaly to the total pressure gradient force +subroutine Stokes_PGF(G, GV, US, dz, u, v, PFu_Stokes, PFv_Stokes, CS ) + type(ocean_grid_type), & + intent(in) :: G !< Ocean grid + type(verticalGrid_type), & + intent(in) :: GV !< Ocean vertical grid + type(unit_scale_type), & + intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)),& + intent(in) :: dz !< Layer thicknesses in height units [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(in) :: u !< Lagrangian Velocity i-component [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(in) :: v !< Lagrangian Velocity j-component [L T-1 ~> m s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(out) :: PFu_Stokes !< PGF Stokes-shear i-component [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(out) :: PFv_Stokes !< PGF Stokes-shear j-component [L T-2 ~> m s-2] + type(Wave_parameters_CS), & + pointer :: CS !< Surface wave related control structure. + + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: P_deltaStokes_L ! The Stokes induced pressure anomaly, + ! layer averaged [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: P_deltaStokes_i ! The Stokes induced pressure anomaly + ! at interfaces [L2 T-2 ~> m2 s-2] + real :: P_Stokes_l, P_Stokes_r ! Stokes-induced pressure anomaly over layer (left/right of point) [L2 T-2 ~> m2 s-2] + real :: P_Stokes_l0, P_Stokes_r0 ! Stokes-induced pressure anomaly at interface + ! (left/right of point) [L2 T-2 ~> m2 s-2] + real :: dP_Stokes_l_dz, dP_Stokes_r_dz ! Contribution of layer to integrated Stokes pressure anomaly for summation + ! (left/right of point) [Z L2 T-2 ~> m3 s-2] + real :: dP_lay_Stokes_l, dP_lay_Stokes_r ! Contribution of layer to integrated Stokes pressure anomaly for summation + ! (left/right of point) [L2 T-2 ~> m2 s-2] + real :: dP_Stokes_l, dP_Stokes_r ! Net increment of Stokes pressure anomaly across layer for summation + ! (left/right of point) [L2 T-2 ~> m2 s-2] + real :: uE_l, uE_r, vE_l, vE_r ! Eulerian velocity components (left/right of point) [L T-1 ~> m s-1] + real :: uS0_l, uS0_r, vS0_l, vS0_r ! Surface Stokes velocity components (left/right of point) [L T-1 ~> m s-1] + real :: zi_l(SZK_(G)+1), zi_r(SZK_(G)+1) ! The height of the edges of the cells (left/right of point) [Z ~> m]. + real :: idz_l(SZK_(G)), idz_r(SZK_(G)) ! The inverse thickness of the cells (left/right of point) [Z-1 ~> m-1] + real :: h_l, h_r ! The thickness of the cell (left/right of point) [Z ~> m]. + real :: exp_top ! The decay of the surface stokes drift to the interface atop a layer [nondim] + real :: dexp2kzL, dexp4kzL, dexp2kzR, dexp4kzR ! Analytical evaluation of multi-exponential decay + ! contribution to Stokes pressure anomalies [nondim]. + real :: TwoK, FourK ! Wavenumbers multiplied by a factor [Z-1 ~> m-1] + real :: iTwoK, iFourK ! Inverses of wavenumbers [Z ~> m] + + integer :: i, j, k, l + + !--------------------------------------------------------------- + ! Compute the Stokes contribution to the pressure gradient force + !--------------------------------------------------------------- + ! Notes on the algorithm/code: + ! This code requires computing velocities at bounding h points + ! of the u/v points to get the pressure-gradient. In this + ! implementation there are several redundant calculations as the + ! left/right points are computed at each cell while integrating + ! in the vertical, requiring about twice the calculations. The + ! velocities at the tracer points could be precomputed and + ! stored, but this would require more memory and cycling through + ! large 3d arrays while computing the pressures. This could be + ! explored as a way to speed up this code. + !--------------------------------------------------------------- + + PFu_Stokes(:,:,:) = 0.0 + PFv_Stokes(:,:,:) = 0.0 + if (CS%id_P_deltaStokes_i > 0) P_deltaStokes_i(:,:,:) = 0.0 + if (CS%id_P_deltaStokes_L > 0) P_deltaStokes_L(:,:,:) = 0.0 + + ! First compute PGFu. The Stokes-induced pressure anomaly diagnostic is stored from this calculation. + ! > Seeking PGFx at (I,j), meaning we need to compute pressure at h-points (i,j) and (i+1,j). + ! UL(i,j) -> found as average of I-1 & I on j + ! UR(i+1,j) -> found as average of I & I+1 on j + ! VL(i,j) -> found on i as average of J-1 & J + ! VR(i+1,j) -> found on i+1 as average of J-1 & J + ! + do j = G%jsc, G%jec ; do I = G%iscB, G%iecB + if (G%mask2dCu(I,j)>0.5) then + P_Stokes_l0 = 0.0 + P_Stokes_r0 = 0.0 + ! We don't need to precompute the grid in physical space arrays and could have done this during + ! the next loop, but this gives flexibility if the loop directions (integrations) are performed + ! upwards instead of downwards (it seems downwards is the better approach). + zi_l(1) = 0.0 + zi_r(1) = 0.0 + do k = 1, G%ke + h_l = dz(i,j,k) + h_r = dz(i+1,j,k) + zi_l(k+1) = zi_l(k) - h_l + zi_r(k+1) = zi_r(k) - h_r + if (.not.CS%robust_Stokes_PGF) then + ! When the code is properly refactored, the following hard-coded constants are unnecessary. + Idz_l(k) = 1./max(0.1*US%m_to_Z, h_l) + Idz_r(k) = 1./max(0.1*US%m_to_Z, h_r) + endif + enddo + do k = 1,G%ke + ! Computing (left/right) Eulerian velocities assuming the velocity passed to this routine is the + ! Lagrangian velocity. This requires the wave acceleration terms to be activated together. + uE_l = 0.5*((u(I-1,j,k)-CS%Us_x(I-1,j,k))*G%mask2dCu(I-1,j) + & + (u(I,j,k)-CS%Us_x(I,j,k))*G%mask2dCu(I,j)) + uE_r = 0.5*((u(I,j,k)-CS%Us_x(I,j,k))*G%mask2dCu(I,j) + & + (u(I+1,j,k)-CS%Us_x(I+1,j,k))*G%mask2dCu(I+1,j)) + vE_l = 0.5*((v(i,J-1,k)-CS%Us_y(i,J-1,k))*G%mask2dCv(i,J-1) + & + (v(i,J,k)-CS%Us_y(i,J,k))*G%mask2dCv(i,J)) + vE_r = 0.5*((v(i+1,J-1,k)-CS%Us_y(i+1,J-1,k))*G%mask2dCv(i+1,J-1) + & + (v(i+1,J,k)-CS%Us_y(i+1,J,k))*G%mask2dCv(i+1,J)) + + dP_Stokes_l_dz = 0.0 + dP_Stokes_r_dz = 0.0 + dP_Stokes_l = 0.0 + dP_Stokes_r = 0.0 + dP_lay_Stokes_l=0.0 + dP_lay_Stokes_r=0.0 + + do l = 1, CS%numbands + + ! Computing (left/right) surface Stokes drift velocities at wavenumber band + uS0_l = 0.5*(CS%Stkx0(I-1,j,l)*G%mask2dCu(I-1,j) + & + CS%Stkx0(I,j,l)*G%mask2dCu(I,j)) + uS0_r = 0.5*(CS%Stkx0(I,j,l)*G%mask2dCu(I,j) + & + CS%Stkx0(I+1,j,l)*G%mask2dCu(I+1,j)) + vS0_l = 0.5*(CS%Stky0(i,J-1,l)*G%mask2dCv(i,J-1) + & + CS%Stky0(i,J,l)*G%mask2dCv(i,J)) + vS0_r = 0.5*(CS%Stky0(i+1,J-1,l)*G%mask2dCv(i+1,J-1) + & + CS%Stky0(i+1,J,l)*G%mask2dCv(i+1,J)) + + ! Wavenumber terms that are useful to simplify the pressure calculations + TwoK = 2.*CS%WaveNum_Cen(l) + FourK = 2.*TwoK + if (.not.CS%robust_Stokes_PGF) then + iTwoK = 1. / TwoK + iFourK = 1. / FourK + endif + + ! Compute Pressure at interface and integrated over layer on left/right bounding points. + ! These are summed over wavenumber bands. + if (G%mask2dT(i,j)>0.5) then + if (.not.CS%robust_Stokes_PGF) then + dexp2kzL = exp(TwoK*zi_l(k))-exp(TwoK*zi_l(k+1)) + dexp4kzL = exp(FourK*zi_l(k))-exp(FourK*zi_l(k+1)) + dP_Stokes_l_dz = dP_Stokes_l_dz + & + ((uE_l*uS0_l+vE_l*vS0_l)*iTwoK*dexp2kzL + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*iFourK*dexp4kzL) + dP_Stokes_l = dP_Stokes_l + (uE_l*uS0_l+vE_l*vS0_l)*dexp2kzL + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*dexp4kzL + else ! These expressions are equivalent to those above for thick layers, but more accurate for thin layers. + exp_top = exp(TwoK*zi_l(k)) + dP_lay_Stokes_l = dP_lay_Stokes_l + & + ((((uE_l*uS0_l)+(vE_l*vS0_l)) * exp_top) * one_minus_exp_x(TwoK*dz(i,j,k)) + & + (0.5*((uS0_l**2)+(vS0_l**2)) * exp_top**2) * one_minus_exp_x(FourK*dz(i,j,k)) ) + dP_Stokes_l = dP_Stokes_l + & + ((((uE_l*uS0_l)+(vE_l*vS0_l)) * exp_top) * one_minus_exp(TwoK*dz(i,j,k)) + & + (0.5*((uS0_l**2)+(vS0_l**2)) * exp_top**2) * one_minus_exp(FourK*dz(i,j,k)) ) + endif + endif + if (G%mask2dT(i+1,j)>0.5) then + if (.not.CS%robust_Stokes_PGF) then + dexp2kzR = exp(TwoK*zi_r(k))-exp(TwoK*zi_r(k+1)) + dexp4kzR = exp(FourK*zi_r(k))-exp(FourK*zi_r(k+1)) + dP_Stokes_r_dz = dP_Stokes_r_dz + & + ((uE_r*uS0_r+vE_r*vS0_r)*iTwoK*dexp2kzR + 0.5*(uS0_r*uS0_r+vS0_r*vS0_r)*iFourK*dexp4kzR) + dP_Stokes_r = dP_Stokes_r + (uE_r*uS0_r+vE_r*vS0_r)*dexp2kzR + 0.5*(uS0_r*uS0_r+vS0_r*vS0_r)*dexp4kzR + else ! These expressions are equivalent to those above for thick layers, but more accurate for thin layers. + exp_top = exp(TwoK*zi_r(k)) + dP_lay_Stokes_r = dP_lay_Stokes_r + & + ((((uE_r*uS0_r)+(vE_r*vS0_r)) * exp_top) * one_minus_exp_x(TwoK*dz(i+1,j,k)) + & + (0.5*((uS0_r**2)+(vS0_r**2)) * exp_top**2) * one_minus_exp_x(FourK*dz(i+1,j,k)) ) + dP_Stokes_r = dP_Stokes_r + & + ((((uE_r*uS0_r)+(vE_r*vS0_r)) * exp_top) * one_minus_exp(TwoK*dz(i+1,j,k)) + & + (0.5*((uS0_r**2)+(vS0_r**2)) * exp_top**2) * one_minus_exp(FourK*dz(i+1,j,k)) ) + endif + endif + enddo + + ! Summing PF over bands + ! > Increment the Layer averaged pressure + if (.not.CS%robust_Stokes_PGF) then + P_Stokes_l = P_Stokes_l0 + dP_Stokes_l_dz*Idz_l(k) + P_Stokes_r = P_Stokes_r0 + dP_Stokes_r_dz*Idz_r(k) + else + P_Stokes_l = P_Stokes_l0 + dP_lay_Stokes_l + P_Stokes_r = P_Stokes_r0 + dP_lay_Stokes_r + endif + + ! > Increment the Interface pressure + P_Stokes_l0 = P_Stokes_l0 + dP_Stokes_l + P_Stokes_r0 = P_Stokes_r0 + dP_Stokes_r + + ! Pressure force anomaly is finite difference across the cell. + PFu_Stokes(I,j,k) = (P_Stokes_r - P_Stokes_l)*G%IdxCu(I,j) + + ! Choose to output the pressure delta on the h-points from the PFu calculation. + if (G%mask2dT(i,j)>0.5 .and. CS%id_P_deltaStokes_L > 0) P_deltaStokes_L(i,j,k) = P_Stokes_l + if (G%mask2dT(i,j)>0.5 .and. CS%id_P_deltaStokes_i > 0) P_deltaStokes_i(i,j,k+1) = P_Stokes_l0 + + enddo + endif + enddo ; enddo + + ! Next compute PGFv. The Stokes-induced pressure anomaly diagnostic is stored from this calculation. + ! > Seeking PGFy at (i,J), meaning we need to compute pressure at h-points (i,j) and (i,j+1). + ! UL(i,j) -> found as average of I-1 & I on j + ! UR(i,j+1) -> found as average of I-1 & I on j+1 + ! VL(i,j) -> found on i as average of J-1 & J + ! VR(i,j+1) -> found on i as average of J & J+1 + ! + do J = G%jscB, G%jecB ; do i = G%isc, G%iec + if (G%mask2dCv(i,J)>0.5) then + P_Stokes_l0 = 0.0 + P_Stokes_r0 = 0.0 + zi_l(1) = 0.0 + zi_r(1) = 0.0 + do k = 1, G%ke + h_l = dz(i,j,k) + h_r = dz(i,j+1,k) + zi_l(k+1) = zi_l(k) - h_l + zi_r(k+1) = zi_r(k) - h_r + if (.not.CS%robust_Stokes_PGF) then + ! When the code is properly refactored, the following hard-coded constants are unnecessary. + Idz_l(k) = 1. / max(0.1*US%m_to_Z, h_l) + Idz_r(k) = 1. / max(0.1*US%m_to_Z, h_r) + endif + enddo + do k = 1,G%ke + ! Computing (left/right) Eulerian velocities assuming the velocity passed to this routine is the + ! Lagrangian velocity. This requires the wave acceleration terms to be activated together. + uE_l = 0.5*((u(I-1,j,k)-CS%Us_x(I-1,j,k))*G%mask2dCu(I-1,j) + & + (u(I,j,k)-CS%Us_x(I,j,k))*G%mask2dCu(I,j)) + uE_r = 0.5*((u(I-1,j+1,k)-CS%Us_x(I-1,j+1,k))*G%mask2dCu(I-1,j+1) + & + (u(I,j+1,k)-CS%Us_x(I,j+1,k))*G%mask2dCu(I,j+1)) + vE_l = 0.5*((v(i,J-1,k)-CS%Us_y(i,J-1,k))*G%mask2dCv(i,J-1) + & + (v(i,J,k)-CS%Us_y(i,J,k))*G%mask2dCv(i,J)) + vE_r = 0.5*((v(i,J,k)-CS%Us_y(i,J,k))*G%mask2dCv(i,J) + & + (v(i,J+1,k)-CS%Us_y(i,J+1,k))*G%mask2dCv(i,J+1)) + + dP_Stokes_l_dz = 0.0 + dP_Stokes_r_dz = 0.0 + dP_Stokes_l = 0.0 + dP_Stokes_r = 0.0 + dP_lay_Stokes_l=0.0 + dP_lay_Stokes_r=0.0 + + do l = 1, CS%numbands + + ! Computing (left/right) surface Stokes drift velocities at wavenumber band + uS0_l = 0.5*(CS%Stkx0(I-1,j,l)*G%mask2dCu(I-1,j) + & + CS%Stkx0(I,j,l)*G%mask2dCu(I,j)) + uS0_r = 0.5*(CS%Stkx0(I-1,j+1,l)*G%mask2dCu(I-1,j+1) + & + CS%Stkx0(I,j+1,l)*G%mask2dCu(I,j+1)) + vS0_l = 0.5*(CS%Stky0(i,J-1,l)*G%mask2dCv(i,J-1) + & + CS%Stky0(i,J,l)*G%mask2dCv(i,J)) + vS0_r = 0.5*(CS%Stky0(i,J,l)*G%mask2dCv(i,J) + & + CS%Stky0(i,J+1,l)*G%mask2dCv(i,J+1)) + + ! Wavenumber terms that are useful to simplify the pressure calculations + TwoK = 2.*CS%WaveNum_Cen(l) + FourK = 2.*TwoK + if (.not.CS%robust_Stokes_PGF) then + iTwoK = 1. / TwoK + iFourK = 1. / FourK + endif + + ! Compute Pressure at interface and integrated over layer on left/right bounding points. + ! These are summed over wavenumber bands. + if (G%mask2dT(i,j)>0.5) then + if (.not.CS%robust_Stokes_PGF) then + dexp2kzL = exp(TwoK*zi_l(k))-exp(TwoK*zi_l(k+1)) + dexp4kzL = exp(FourK*zi_l(k))-exp(FourK*zi_l(k+1)) + dP_Stokes_l_dz = dP_Stokes_l_dz + & + ((uE_l*uS0_l+vE_l*vS0_l)*iTwoK*dexp2kzL + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*iFourK*dexp4kzL) + dP_Stokes_l = dP_Stokes_l + (uE_l*uS0_l+vE_l*vS0_l)*dexp2kzL + 0.5*(uS0_l*uS0_l+vS0_l*vS0_l)*dexp4kzL + else ! These expressions are equivalent to those above for thick layers, but more accurate for thin layers. + exp_top = exp(TwoK*zi_l(k)) + dP_lay_Stokes_l = dP_lay_Stokes_l + & + ((((uE_l*uS0_l)+(vE_l*vS0_l)) * exp_top) * one_minus_exp_x(TwoK*dz(i,j,k)) + & + (0.5*((uS0_l**2)+(vS0_l**2)) * exp_top**2) * one_minus_exp_x(FourK*dz(i,j,k)) ) + dP_Stokes_l = dP_Stokes_l + & + ((((uE_l*uS0_l)+(vE_l*vS0_l)) * exp_top) * one_minus_exp(TwoK*dz(i,j,k)) + & + (0.5*((uS0_l**2)+(vS0_l**2)) * exp_top**2) * one_minus_exp(FourK*dz(i,j,k)) ) + endif + endif + if (G%mask2dT(i,j+1)>0.5) then + if (.not.CS%robust_Stokes_PGF) then + dexp2kzR = exp(TwoK*zi_r(k))-exp(TwoK*zi_r(k+1)) + dexp4kzR = exp(FourK*zi_r(k))-exp(FourK*zi_r(k+1)) + dP_Stokes_r_dz = dP_Stokes_r_dz + & + ((uE_r*uS0_r+vE_r*vS0_r)*iTwoK*dexp2kzR + 0.5*(uS0_r*uS0_r+vS0_r*vS0_r)*iFourK*dexp4kzR) + dP_Stokes_r = dP_Stokes_r + (uE_r*uS0_r+vE_r*vS0_r)*dexp2kzR + 0.5*(uS0_r*uS0_r+vS0_r*vS0_r)*dexp4kzR + else ! These expressions are equivalent to those above for thick layers, but more accurate for thin layers. + exp_top = exp(TwoK*zi_r(k)) + dP_lay_Stokes_r = dP_lay_Stokes_r + & + ((((uE_r*uS0_r)+(vE_r*vS0_r)) * exp_top) * one_minus_exp_x(TwoK*dz(i,j+1,k)) + & + (0.5*((uS0_r**2)+(vS0_r**2)) * exp_top**2) * one_minus_exp_x(FourK*dz(i,j+1,k)) ) + dP_Stokes_r = dP_Stokes_r + & + ((((uE_r*uS0_r)+(vE_r*vS0_r)) * exp_top) * one_minus_exp(TwoK*dz(i,j+1,k)) + & + (0.5*((uS0_r**2)+(vS0_r**2)) * exp_top**2) * one_minus_exp(FourK*dz(i,j+1,k)) ) + endif + endif + enddo + + ! Summing PF over bands + ! > Increment the Layer averaged pressure + if (.not.CS%robust_Stokes_PGF) then + P_Stokes_l = P_Stokes_l0 + dP_Stokes_l_dz*Idz_l(k) + P_Stokes_r = P_Stokes_r0 + dP_Stokes_r_dz*Idz_r(k) + else + P_Stokes_l = P_Stokes_l0 + dP_lay_Stokes_l + P_Stokes_r = P_Stokes_r0 + dP_lay_Stokes_r + endif + + ! > Increment the Interface pressure + P_Stokes_l0 = P_Stokes_l0 + dP_Stokes_l + P_Stokes_r0 = P_Stokes_r0 + dP_Stokes_r + + ! Pressure force anomaly is finite difference across the cell. + PFv_Stokes(I,j,k) = (P_Stokes_r - P_Stokes_l)*G%IdyCv(i,J) + + enddo + endif + enddo ; enddo + + if (CS%id_PFv_Stokes>0) & + call post_data(CS%id_PFv_Stokes, PFv_Stokes, CS%diag) + if (CS%id_PFu_Stokes>0) & + call post_data(CS%id_PFu_Stokes, PFu_Stokes, CS%diag) + if (CS%id_P_deltaStokes_L>0) & + call post_data(CS%id_P_deltaStokes_L, P_deltaStokes_L, CS%diag) + if (CS%id_P_deltaStokes_i>0) & + call post_data(CS%id_P_deltaStokes_i, P_deltaStokes_i, CS%diag) + +end subroutine Stokes_PGF + !> Computes wind speed from ustar_air based on COARE 3.5 Cd relationship !! Probably doesn't belong in this module, but it is used here to estimate !! wind speed for wind-wave relationships. Should be a fine way to estimate @@ -1470,12 +2067,15 @@ subroutine ust_2_u10_coare3p5(USTair, U10, GV, US, CS) type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure ! Local variables - real, parameter :: vonkar = 0.4 ! Should access a get_param von karman - real :: nu ! The viscosity of air [Z2 T-1 ~> m2 s-1] real :: z0sm, z0, z0rough ! Roughness lengths [Z ~> m] + real :: ten_m_scale ! The 10 m reference height, in rescaled units [Z ~> m] + real :: I_ten_m_scale ! The inverse of the 10 m reference height, in rescaled units [Z-1 ~> m-1] real :: u10a ! The previous guess for u10 [L T-1 ~> m s-1] - real :: alpha ! A nondimensional factor in a parameterization [nondim] - real :: CD ! The drag coefficient [nondim] + real :: alpha ! The Charnock coeffient relating the wind friction velocity squared to the + ! roughness length [nondim] + real :: Cd ! The drag coefficient [nondim] + real :: I_sqrtCd ! The inverse of the square root of the drag coefficient [nondim] + real :: I_vonKar ! The inverse of the von Karman coefficient [nondim] integer :: CT ! Uses empirical formula for z0 to convert ustar_air to u10 based on the @@ -1484,33 +2084,56 @@ subroutine ust_2_u10_coare3p5(USTair, U10, GV, US, CS) ! Note in Edson et al. 2013, eq. 13 m is given as 0.017. However, ! m=0.0017 reproduces the curve in their figure 6. - nu = 1.0e-6*US%m2_s_to_Z2_T ! Should access a get_param for air-viscosity + if (CS%vonKar < 0.0) call MOM_error(FATAL, & + "ust_2_u10_coare3p5 called with a negative value of Waves%vonKar") - z0sm = 0.11 * nu / USTair ! Compute z0smooth from ustar guess - u10 = US%Z_to_L*USTair / sqrt(0.001) ! Guess for u10 - ! For efficiency change the line above to USTair * sqrt(1000.0) or USTair * 31.6227766 . + z0sm = 0.11 * CS%nu_air / USTair ! Compute z0smooth from ustar guess u10a = 1000.0*US%m_s_to_L_T ! An insanely large upper bound for u10. - CT=0 - do while (abs(u10a/u10 - 1.) > 0.001) ! Change this to (abs(u10a - u10) > 0.001*u10) for efficiency. - CT=CT+1 - u10a = u10 - alpha = min(0.028, 0.0017*US%L_T_to_m_s * u10 - 0.005) - z0rough = alpha * (US%Z_to_L*USTair)**2 / GV%g_Earth ! Compute z0rough from ustar guess - z0 = z0sm + z0rough - CD = ( vonkar / log(10.*US%m_to_Z / z0) )**2 ! Compute CD from derived roughness - u10 = US%Z_to_L*USTair/sqrt(CD) ! Compute new u10 from derived CD, while loop - ! ends and checks for convergence...CT counter - ! makes sure loop doesn't run away if function - ! doesn't converge. This code was produced offline - ! and converged rapidly (e.g. 2 cycles) - ! for ustar=0.0001:0.0001:10. - if (CT>20) then - u10 = US%Z_to_L*USTair/sqrt(0.0015) ! I don't expect to get here, but just - ! in case it will output a reasonable value. - exit - endif - enddo + if (CS%answer_date < 20230103) then + u10 = US%Z_to_L*USTair / sqrt(0.001) ! Guess for u10 + ten_m_scale = 10.0*US%m_to_Z + CT=0 + do while (abs(u10a/u10 - 1.) > 0.001) + CT=CT+1 + u10a = u10 + alpha = min(CS%Charnock_min, CS%Charnock_slope_U10 * u10 + CS%Charnock_intercept) + z0rough = alpha * (US%Z_to_L*USTair)**2 / GV%g_Earth ! Compute z0rough from ustar guess + z0 = z0sm + z0rough + Cd = ( CS%vonKar / log(ten_m_scale / z0) )**2 ! Compute Cd from derived roughness + u10 = US%Z_to_L*USTair/sqrt(Cd) ! Compute new u10 from derived Cd, while loop + ! ends and checks for convergence...CT counter + ! makes sure loop doesn't run away if function + ! doesn't converge. This code was produced offline + ! and converged rapidly (e.g. 2 cycles) + ! for ustar=0.0001:0.0001:10. + if (CT>20) then + u10 = US%Z_to_L*USTair/sqrt(0.0015) ! I don't expect to get here, but just + ! in case it will output a reasonable value. + exit + endif + enddo + + else ! Use more efficient expressions that are mathematically equivalent to those above. + u10 = US%Z_to_L*USTair * sqrt(1000.0) ! First guess for u10. + ! In the line above 1000 is the inverse of a plausible first guess of the drag coefficient. + I_vonKar = 1.0 / CS%vonKar + I_ten_m_scale = 0.1*US%Z_to_m + + do CT=1,20 + if (abs(u10a - u10) <= 0.001*u10) exit ! Check for convergence. + u10a = u10 + alpha = min(CS%Charnock_min, CS%Charnock_slope_U10 * u10 + CS%Charnock_intercept) + z0rough = alpha * (CS%I_g_Earth * USTair**2) ! Compute z0rough from ustar guess + z0 = z0sm + z0rough + I_sqrtCd = abs(log(z0 * I_ten_m_scale)) * I_vonKar ! Compute Cd from derived roughness + u10 = US%Z_to_L*USTair * I_sqrtCd ! Compute new u10 from the derived Cd. + enddo + + ! Output a reasonable estimate of u10 if the iteration has not converged. The hard-coded + ! number 25.82 is 1/sqrt(0.0015) to 4 decimal places, but the exact value should not matter. + if (abs(u10a - u10) > 0.001*u10) u10 = US%Z_to_L*USTair * 25.82 + endif end subroutine ust_2_u10_coare3p5 @@ -1522,10 +2145,12 @@ subroutine Waves_end(CS) if (allocated(CS%Freq_Cen)) deallocate( CS%Freq_Cen ) if (allocated(CS%Us_x)) deallocate( CS%Us_x ) if (allocated(CS%Us_y)) deallocate( CS%Us_y ) - if (allocated(CS%La_SL)) deallocate( CS%La_SL ) if (allocated(CS%La_turb)) deallocate( CS%La_turb ) if (allocated(CS%STKx0)) deallocate( CS%STKx0 ) if (allocated(CS%STKy0)) deallocate( CS%STKy0 ) + if (allocated(CS%UStk_Hb)) deallocate( CS%UStk_Hb ) + if (allocated(CS%VStk_Hb)) deallocate( CS%VStk_Hb ) + if (allocated(CS%Omega_w2x)) deallocate( CS%Omega_w2x ) if (allocated(CS%KvS)) deallocate( CS%KvS ) if (allocated(CS%Us0_y)) deallocate( CS%Us0_y ) if (allocated(CS%Us0_x)) deallocate( CS%Us0_x ) @@ -1534,6 +2159,53 @@ subroutine Waves_end(CS) end subroutine Waves_end +!> Register wave restart fields. To be called before MOM_wave_interface_init +subroutine waves_register_restarts(CS, HI, GV, US, param_file, restart_CSp) + type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure + type(hor_index_type), intent(inout) :: HI !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Input parameter structure + type(MOM_restart_CS), pointer :: restart_CSp !< Restart structure, data intent(inout) + ! Local variables + type(vardesc) :: vd(2) + logical :: use_waves + logical :: StatisticalWaves + logical :: time_tendency_term + character(len=40) :: mdl = "MOM_wave_interface" !< This module's name. + + if (associated(CS)) then + call MOM_error(FATAL, "waves_register_restarts: Called with initialized waves control structure") + endif + allocate(CS) + + call get_param(param_file, mdl, "USE_WAVES", use_waves, & + "If true, enables surface wave modules.", do_not_log=.true., default=.false.) + + ! Check if using LA_LI2016 + call get_param(param_file,mdl,"USE_LA_LI2016",StatisticalWaves, & + do_not_log=.true.,default=.false.) + + if (.not.(use_waves .or. StatisticalWaves)) return + + call get_param(param_file, mdl, "STOKES_DDT", time_tendency_term, do_not_log=.true., default=.false.) + + if (time_tendency_term) then + ! Allocate wave fields needed for restart file + allocate(CS%Us_x_prev(HI%isdB:HI%IedB,HI%jsd:HI%jed,GV%ke), source=0.0) + allocate(CS%Us_y_prev(HI%isd:HI%Ied,HI%jsdB:HI%jedB,GV%ke), source=0.0) + + ! Register to restart files. If these are not found in a restart file, they stay 0. + vd(1) = var_desc("Us_x_prev", "m s-1", "3d zonal Stokes drift profile",& + hor_grid='u', z_grid='L') + vd(2) = var_desc("Us_y_prev", "m s-1", "3d meridional Stokes drift profile",& + hor_grid='v', z_grid='L') + call register_restart_pair(CS%US_x_prev, CS%US_y_prev, vd(1), vd(2), .false., & + restart_CSp, conversion=US%L_T_to_m_s) + endif + +end subroutine waves_register_restarts + !> \namespace mom_wave_interface !! !! \author Brandon Reichl, 2018. @@ -1545,7 +2217,7 @@ end subroutine Waves_end !! interpret surface wave data for MOM6. In its original form, the !! capabilities include setting the Stokes drift in the model (from a !! variety of sources including prescribed, empirical, and input -!! files). In short order, the plan is to also ammend the subroutine +!! files). In short order, the plan is to also amend the subroutine !! to accept Stokes drift information from an external coupler. !! Eventually, it will be necessary to break this file apart so that !! general wave information may be stored in the control structure diff --git a/src/user/Neverworld_initialization.F90 b/src/user/Neverworld_initialization.F90 index 5d992b572f..c67237a048 100644 --- a/src/user/Neverworld_initialization.F90 +++ b/src/user/Neverworld_initialization.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Initialization for the "Neverworld" configuration module Neverworld_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe @@ -13,7 +15,6 @@ module Neverworld_initialization use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type use random_numbers_mod, only: initializeRandomNumberStream, getRandomNumbers, randomNumberStream @@ -35,20 +36,19 @@ module Neverworld_initialization subroutine Neverworld_initialize_topography(D, G, param_file, max_depth) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth in the units of depth_max + intent(out) :: D !< Ocean bottom depth in the units of depth_max [A] type(param_file_type), intent(in) :: param_file !< Parameter file structure - real, intent(in) :: max_depth !< Maximum ocean depth in arbitrary units + real, intent(in) :: max_depth !< Maximum ocean depth in arbitrary units [A] ! Local variables - real :: PI ! 3.1415926... calculated as 4*atan(1) - real :: D0 ! A constant to make the maximum ! - ! basin depth MAXIMUM_DEPTH. ! - real :: x, y + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] + real :: x, y ! Lateral positions normalized by the domain size [nondim] ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "Neverworld_initialize_topography" ! This subroutine's name. + real :: nl_top_amp ! Amplitude of large-scale topographic features as a fraction of the maximum depth [nondim] + real :: nl_roughness_amp ! Amplitude of topographic roughness as a fraction of the maximum depth [nondim] integer :: i, j, is, ie, js, je, isd, ied, jsd, jed - real :: nl_roughness_amp, nl_top_amp is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -56,16 +56,16 @@ subroutine Neverworld_initialize_topography(D, G, param_file, max_depth) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "NL_ROUGHNESS_AMP", nl_roughness_amp, & - "Amplitude of wavy signal in bathymetry.", default=0.05) + "Amplitude of wavy signal in bathymetry.", units="nondim", default=0.05) call get_param(param_file, mdl, "NL_CONTINENT_AMP", nl_top_amp, & - "Scale factor for topography - 0.0 for no continents.", default=1.0) + "Scale factor for topography - 0.0 for no continents.", units="nondim", default=1.0) PI = 4.0*atan(1.0) ! Calculate the depth of the bottom. do j=js,je ; do i=is,ie x = (G%geoLonT(i,j)-G%west_lon) / G%len_lon - y =( G%geoLatT(i,j)-G%south_lat) / G%len_lat + y = (G%geoLatT(i,j)-G%south_lat) / G%len_lat ! This sets topography that has a reentrant channel to the south. D(i,j) = 1.0 - 1.1 * spike(y-1,0.12) - 1.1 * spike(y,0.12) - & !< The great northern wall and Antarctica nl_top_amp*( & @@ -84,95 +84,96 @@ subroutine Neverworld_initialize_topography(D, G, param_file, max_depth) end subroutine Neverworld_initialize_topography -!> Returns the value of a cosine-bell function evaluated at x/L +!> Returns the value of a cosine-bell function evaluated at x/L [nondim] real function cosbell(x, L) - real , intent(in) :: x !< non-dimensional position - real , intent(in) :: L !< non-dimensional width - real :: PI !< 3.1415926... calculated as 4*atan(1) + real , intent(in) :: x !< Position in arbitrary units [A] + real , intent(in) :: L !< Width in arbitrary units [A] + real :: PI !< 3.1415926... calculated as 4*atan(1) [nondim] PI = 4.0*atan(1.0) cosbell = 0.5 * (1 + cos(PI*MIN(ABS(x/L),1.0))) end function cosbell -!> Returns the value of a sin-spike function evaluated at x/L +!> Returns the value of a sin-spike function evaluated at x/L [nondim] real function spike(x, L) - real , intent(in) :: x !< non-dimensional position - real , intent(in) :: L !< non-dimensional width - real :: PI !< 3.1415926... calculated as 4*atan(1) + real , intent(in) :: x !< Position in arbitrary units [A] + real , intent(in) :: L !< Width in arbitrary units [A] + real :: PI !< 3.1415926... calculated as 4*atan(1) [nondim] PI = 4.0*atan(1.0) spike = (1 - sin(PI*MIN(ABS(x/L),0.5))) end function spike !> Returns the value of a triangular function centered at x=x0 with value 1 -!! and linearly decreasing to 0 at x=x0+/-L, and 0 otherwise. +!! and linearly decreasing to 0 at x=x0+/-L, and 0 otherwise [nondim]. !! If clip is present the top of the cone is cut off at "clip", which !! effectively defaults to 1. real function cone(x, x0, L, clip) - real, intent(in) :: x !< non-dimensional coordinate [nondim] - real, intent(in) :: x0 !< position of peak [nondim] - real, intent(in) :: L !< half-width of base of cone [nondim] + real, intent(in) :: x !< Coordinate in arbitrary units [A] + real, intent(in) :: x0 !< position of peak in arbitrary units [A] + real, intent(in) :: L !< half-width of base of cone in arbitrary units [A] real, optional, intent(in) :: clip !< clipping height of cone [nondim] cone = max( 0., 1. - abs(x - x0) / L ) if (present(clip)) cone = min(clip, cone) end function cone -!> Returns an s-curve s(x) s.t. s(x0)<=0, s(x0+L)>=1 and cubic in between. +!> Returns an s-curve s(x) s.t. s(x0)<=0, s(x0+L)>=1 and cubic in between [nondim]. real function scurve(x, x0, L) - real, intent(in) :: x !< non-dimensional coordinate [nondim] - real, intent(in) :: x0 !< position of peak [nondim] - real, intent(in) :: L !< half-width of base of cone [nondim] - real :: s + real, intent(in) :: x !< Coordinate in arbitrary units [A] + real, intent(in) :: x0 !< position of peak in arbitrary units [A] + real, intent(in) :: L !< half-width of base of cone in arbitrary units [A] + real :: s ! A rescaled position [nondim] s = max( 0., min( 1.,( x - x0 ) / L ) ) scurve = ( 3. - 2.*s ) * ( s * s ) end function scurve -!> Returns a "coastal" profile. +! None of the following 7 functions appear to be used. + +!> Returns a "coastal" profile [nondim]. real function cstprof(x, x0, L, lf, bf, sf, sh) - real, intent(in) :: x !< non-dimensional coordinate [nondim] - real, intent(in) :: x0 !< position of peak [nondim] - real, intent(in) :: L !< width of profile [nondim] + real, intent(in) :: x !< Coordinate in arbitrary units [A] + real, intent(in) :: x0 !< position of peak in arbitrary units [A] + real, intent(in) :: L !< width of profile in arbitrary units [A] real, intent(in) :: lf !< fraction of width that is "land" [nondim] real, intent(in) :: bf !< fraction of width that is "beach" [nondim] real, intent(in) :: sf !< fraction of width that is "continental slope" [nondim] real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] - real :: s + real :: s ! A rescaled position [nondim] s = max( 0., min( 1.,( x - x0 ) / L ) ) cstprof = sh * scurve(s-lf,0.,bf) + (1.-sh) * scurve(s - (1.-sf),0.,sf) end function cstprof -!> Distance between points x,y and a line segment (x0,y0) and (x0,y1). +!> Distance between points x,y and a line segment (x0,y0) and (x0,y1) in arbitrary units [A]. real function dist_line_fixed_x(x, y, x0, y0, y1) - real, intent(in) :: x !< non-dimensional x-coordinate [nondim] - real, intent(in) :: y !< non-dimensional y-coordinate [nondim] - real, intent(in) :: x0 !< x-position of line segment [nondim] - real, intent(in) :: y0 !< y-position of line segment end[nondim] - real, intent(in) :: y1 !< y-position of line segment end[nondim] - real :: dx, yr, dy + real, intent(in) :: x !< X-coordinate in arbitrary units [A] + real, intent(in) :: y !< Y-coordinate in arbitrary units [A] + real, intent(in) :: x0 !< x-position of line segment in arbitrary units [A] + real, intent(in) :: y0 !< y-position of line segment end in arbitrary units [A] + real, intent(in) :: y1 !< y-position of line segment end in arbitrary units [A] + real :: dx, yr, dy ! Relative positions in arbitrary units [A] dx = x - x0 yr = min( max(y0,y1), max( min(y0,y1), y ) ) ! bound y by y0,y1 dy = y - yr ! =0 within y0y1 - dist_line_fixed_x = sqrt( dx*dx + dy*dy ) + dist_line_fixed_x = sqrt( (dx*dx) + (dy*dy) ) end function dist_line_fixed_x -!> Distance between points x,y and a line segment (x0,y0) and (x1,y0). +!> Distance between points x,y and a line segment (x0,y0) and (x1,y0) in arbitrary units [A]. real function dist_line_fixed_y(x, y, x0, x1, y0) - real, intent(in) :: x !< non-dimensional x-coordinate [nondim] - real, intent(in) :: y !< non-dimensional y-coordinate [nondim] - real, intent(in) :: x0 !< x-position of line segment end[nondim] - real, intent(in) :: x1 !< x-position of line segment end[nondim] - real, intent(in) :: y0 !< y-position of line segment [nondim] - real :: dx, yr, dy + real, intent(in) :: x !< X-coordinate in arbitrary units [A] + real, intent(in) :: y !< Y-coordinate in arbitrary units [A] + real, intent(in) :: x0 !< x-position of line segment end in arbitrary units [A] + real, intent(in) :: x1 !< x-position of line segment end in arbitrary units [A] + real, intent(in) :: y0 !< y-position of line segment in arbitrary units [A] dist_line_fixed_y = dist_line_fixed_x(y, x, y0, x0, x1) end function dist_line_fixed_y -!> A "coast profile" applied in an N-S line from lon0,lat0 to lon0,lat1. +!> A "coast profile" applied in an N-S line from lon0,lat0 to lon0,lat1 [nondim]. real function NS_coast(lon, lat, lon0, lat0, lat1, dlon, sh) real, intent(in) :: lon !< Longitude [degrees_E] real, intent(in) :: lat !< Latitude [degrees_N] @@ -181,13 +182,13 @@ real function NS_coast(lon, lat, lon0, lat0, lat1, dlon, sh) real, intent(in) :: lat1 !< Latitude of coast end [degrees_N] real, intent(in) :: dlon !< "Radius" of coast profile [degrees] real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] - real :: r + real :: r ! A relative position [nondim] r = dist_line_fixed_x( lon, lat, lon0, lat0, lat1 ) NS_coast = cstprof(r, 0., dlon, 0.125, 0.125, 0.5, sh) end function NS_coast -!> A "coast profile" applied in an E-W line from lon0,lat0 to lon1,lat0. +!> A "coast profile" applied in an E-W line from lon0,lat0 to lon1,lat0 [nondim]. real function EW_coast(lon, lat, lon0, lon1, lat0, dlat, sh) real, intent(in) :: lon !< Longitude [degrees_E] real, intent(in) :: lat !< Latitude [degrees_N] @@ -196,13 +197,13 @@ real function EW_coast(lon, lat, lon0, lon1, lat0, dlat, sh) real, intent(in) :: lat0 !< Latitude of coast [degrees_N] real, intent(in) :: dlat !< "Radius" of coast profile [degrees] real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] - real :: r + real :: r ! A relative position [nondim] r = dist_line_fixed_y( lon, lat, lon0, lon1, lat0 ) EW_coast = cstprof(r, 0., dlat, 0.125, 0.125, 0.5, sh) end function EW_coast -!> A NS ridge +!> A NS ridge [nondim] real function NS_ridge(lon, lat, lon0, lat0, lat1, dlon, rh) real, intent(in) :: lon !< Longitude [degrees_E] real, intent(in) :: lat !< Latitude [degrees_N] @@ -211,14 +212,14 @@ real function NS_ridge(lon, lat, lon0, lat0, lat1, dlon, rh) real, intent(in) :: lat1 !< Latitude of ridge end [degrees_N] real, intent(in) :: dlon !< "Radius" of ridge profile [degrees] real, intent(in) :: rh !< depth of ridge as fraction of full depth [nondim] - real :: r + real :: r ! A distance from a point [degrees] r = dist_line_fixed_x( lon, lat, lon0, lat0, lat1 ) NS_ridge = 1. - rh * cone(r, 0., dlon) end function NS_ridge -!> A circular ridge +!> A circular ridge [nondim] real function circ_ridge(lon, lat, lon0, lat0, ring_radius, ring_thickness, ridge_height) real, intent(in) :: lon !< Longitude [degrees_E] real, intent(in) :: lat !< Latitude [degrees_N] @@ -227,12 +228,13 @@ real function circ_ridge(lon, lat, lon0, lat0, ring_radius, ring_thickness, ridg real, intent(in) :: ring_radius !< Radius of ring [degrees] real, intent(in) :: ring_thickness !< Radial thickness of ring [degrees] real, intent(in) :: ridge_height !< Ridge height as fraction of full depth [nondim] - real :: r + real :: r ! A relative position [degrees] + real :: frac_ht ! The fractional height of the topography [nondim] - r = sqrt( (lon - lon0)**2 + (lat - lat0)**2 ) ! Pseudo-distance from a point + r = sqrt( ((lon - lon0)**2) + ((lat - lat0)**2) ) ! Pseudo-distance from a point r = abs( r - ring_radius) ! Pseudo-distance from a circle - r = cone(r, 0., ring_thickness, ridge_height) ! 0 .. frac_ridge_height - circ_ridge = 1. - r ! nondim depths (1-frac_ridge_height) .. 1 + frac_ht = cone(r, 0., ring_thickness, ridge_height) ! 0 .. frac_ridge_height + circ_ridge = 1. - frac_ht ! Fractional depths (1-frac_ridge_height) .. 1 end function circ_ridge !> This subroutine initializes layer thicknesses for the Neverworld test case, @@ -244,7 +246,7 @@ subroutine Neverworld_initialize_thickness(h, depth_tot, G, GV, US, param_file, type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: h !< The thickness that is being - !! initialized [H ~> m or kg m-2]. + !! initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open @@ -257,13 +259,16 @@ subroutine Neverworld_initialize_thickness(h, depth_tot, G, GV, US, param_file, ! usually negative because it is positive upward. real, dimension(SZK_(GV)) :: h_profile ! Vector of initial thickness profile [Z ~> m]. real :: e_interface ! Current interface position [Z ~> m]. - real :: x,y,r1,r2 ! x,y and radial coordinates for computation of initial pert. - real :: pert_amp ! Amplitude of perturbations measured in Angstrom_H - real :: h_noise ! Amplitude of noise to scale h by - real :: noise ! Noise + real :: x, y ! horizontal coordinates for computation of the initial perturbation normalized + ! by the domain sizes [nondim] + real :: r1, r2 ! radial coordinates for computation of initial perturbation, normalized + ! by the domain sizes [nondim] + real :: pert_amp ! Amplitude of perturbations as a fraction of layer thicknesses [nondim] + real :: h_noise ! Amplitude of noise to scale h by [nondim] + real :: noise ! Fractional noise in the layer thicknesses [nondim] type(randomNumberStream) :: rns ! Random numbers for stochastic tidal parameterization character(len=40) :: mdl = "Neverworld_initialize_thickness" ! This subroutine's name. - integer :: i, j, k, k1, is, ie, js, je, nz, itt + integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -286,12 +291,12 @@ subroutine Neverworld_initialize_thickness(h, depth_tot, G, GV, US, param_file, do j=js,je ; do i=is,ie e_interface = -depth_tot(i,j) do k=nz,2,-1 - h(i,j,k) = GV%Z_to_H * (e0(k) - e_interface) ! Nominal thickness - x=(G%geoLonT(i,j)-G%west_lon)/G%len_lon - y=(G%geoLatT(i,j)-G%south_lat)/G%len_lat - r1=sqrt((x-0.7)**2+(y-0.2)**2) - r2=sqrt((x-0.3)**2+(y-0.25)**2) - h(i,j,k) = h(i,j,k) + pert_amp * (e0(k) - e0(nz+1)) * GV%Z_to_H * & + h(i,j,k) = e0(k) - e_interface ! Nominal thickness + x = (G%geoLonT(i,j)-G%west_lon)/G%len_lon + y = (G%geoLatT(i,j)-G%south_lat)/G%len_lat + r1 = sqrt(((x-0.7)**2) + ((y-0.2)**2)) + r2 = sqrt(((x-0.3)**2) + ((y-0.25)**2)) + h(i,j,k) = h(i,j,k) + pert_amp * (e0(k) - e0(nz+1)) * & (spike(r1,0.15)-spike(r2,0.15)) ! Prescribed perturbation if (h_noise /= 0.) then rns = initializeRandomNumberStream( int( 4096*(x + (y+1.)) ) ) @@ -299,11 +304,11 @@ subroutine Neverworld_initialize_thickness(h, depth_tot, G, GV, US, param_file, noise = h_noise * 2. * ( noise - 0.5 ) ! range -h_noise to h_noise h(i,j,k) = ( 1. + noise ) * h(i,j,k) endif - h(i,j,k) = max( GV%Angstrom_H, h(i,j,k) ) ! Limit to non-negative - e_interface = e_interface + GV%H_to_Z * h(i,j,k) ! Actual position of upper interface + h(i,j,k) = max( GV%Angstrom_Z, h(i,j,k) ) ! Limit to non-negative + e_interface = e_interface + h(i,j,k) ! Actual position of upper interface enddo - h(i,j,1) = GV%Z_to_H * (e0(1) - e_interface) ! Nominal thickness - h(i,j,1) = max( GV%Angstrom_H, h(i,j,1) ) ! Limit to non-negative + h(i,j,1) = e0(1) - e_interface ! Nominal thickness + h(i,j,1) = max( GV%Angstrom_Z, h(i,j,1) ) ! Limit to non-negative enddo ; enddo end subroutine Neverworld_initialize_thickness diff --git a/src/user/Phillips_initialization.F90 b/src/user/Phillips_initialization.F90 index 110a12c5f5..cf4690a24b 100644 --- a/src/user/Phillips_initialization.F90 +++ b/src/user/Phillips_initialization.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Initialization for the "Phillips" channel configuration module Phillips_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_file_parser, only : get_param, log_version, param_file_type @@ -13,7 +15,6 @@ module Phillips_initialization use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type implicit none ; private @@ -40,7 +41,7 @@ subroutine Phillips_initialize_thickness(h, depth_tot, G, GV, US, param_file, ju type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2] + intent(out) :: h !< The thickness that is being initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file @@ -51,11 +52,14 @@ subroutine Phillips_initialize_thickness(h, depth_tot, G, GV, US, param_file, ju real :: eta0(SZK_(GV)+1) ! The 1-d nominal positions of the interfaces [Z ~> m] real :: eta_im(SZJ_(G),SZK_(GV)+1) ! A temporary array for zonal-mean eta [Z ~> m] real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface, positive upward [Z ~> m] - real :: jet_width ! The width of the zonal-mean jet [km] + real :: jet_width ! The width of the zonal-mean jet in the same units as geolat, often [km] real :: jet_height ! The interface height scale associated with the zonal-mean jet [Z ~> m] - real :: y_2 ! The y-position relative to the center of the domain [km] + real :: y_2 ! The y-position relative to the center of the domain in the same units as + ! geolat, often [km] real :: half_strat ! The fractional depth where the stratification is centered [nondim] real :: half_depth ! The depth where the stratification is centered [Z ~> m] + real :: km_to_grid_unit ! The conversion factor from km to the units of latitude, often 1 [nondim], + ! but this could be 1000 [m km-1] logical :: reentrant_y ! If true, model is re-entrant in the y direction character(len=40) :: mdl = "Phillips_initialize_thickness" ! This subroutine's name. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz @@ -64,19 +68,30 @@ subroutine Phillips_initialize_thickness(h, depth_tot, G, GV, US, param_file, ju 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 + if (G%grid_unit_to_L <= 0.) call MOM_error(FATAL, "Phillips_initialization: "//& + "Phillips_initialize_thickness is only set to work with Cartesian axis units.") + if (abs(G%grid_unit_to_L*US%L_to_m - 1000.0) < 1.0e-3) then ! The grid latitudes are in km. + km_to_grid_unit = 1.0 + elseif (abs(G%grid_unit_to_L*US%L_to_m - 1.0) < 1.0e-6) then ! The grid latitudes are in m. + km_to_grid_unit = 1000.0 + else + call MOM_error(FATAL, "Phillips_initialization: "//& + "Phillips_initialize_thickness is not recognizing the value of G%grid_unit_to_L.") + endif + eta_im(:,:) = 0.0 if (.not.just_read) call log_version(param_file, mdl, version) call get_param(param_file, mdl, "HALF_STRAT_DEPTH", half_strat, & "The fractional depth where the stratification is centered.", & - units="nondim", default = 0.5, do_not_log=just_read) + units="nondim", default=0.5, do_not_log=just_read) call get_param(param_file, mdl, "JET_WIDTH", jet_width, & - "The width of the zonal-mean jet.", units="km", & + "The width of the zonal-mean jet.", units="km", scale=km_to_grid_unit, & fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "JET_HEIGHT", jet_height, & - "The interface height scale associated with the "//& - "zonal-mean jet.", units="m", scale=US%m_to_Z, & - fail_if_missing=.not.just_read, do_not_log=just_read) + "The interface height scale associated with the zonal-mean jet.", & + units="m", scale=US%m_to_Z, fail_if_missing=.not.just_read, do_not_log=just_read) + ! If re-entrant in the Y direction, we use a sine function instead of a ! tanh. The ratio len_lat/jet_width should be an integer in this case. call get_param(param_file, mdl, "REENTRANT_Y", reentrant_y, & @@ -117,9 +132,9 @@ subroutine Phillips_initialize_thickness(h, depth_tot, G, GV, US, param_file, ju eta1D(K) = eta_im(j,K) if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_Z)) then eta1D(K) = eta1D(K+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + h(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H * (eta1D(K) - eta1D(K+1)) + h(i,j,k) = eta1D(K) - eta1D(K+1) endif enddo enddo ; enddo @@ -140,61 +155,116 @@ subroutine Phillips_initialize_velocity(u, v, G, GV, US, param_file, just_read) logical, intent(in) :: just_read !< If true, this call will only read !! parameters without changing u & v. - real :: jet_width ! The width of the zonal-mean jet [km] + real :: jet_width_grid ! The width of the zonal-mean jet in the same units as geolat, often [km] + real :: jet_width_L ! The width of the zonal-mean jet [L ~> m] + real :: I_jet_width ! The inverse of the width of the zonal-mean jet [L-1 ~> m-1] real :: jet_height ! The interface height scale associated with the zonal-mean jet [Z ~> m] - real :: x_2 ! The x-position relative to the center of the domain [nondim] - real :: y_2 ! The y-position relative to the center of the domain [km] or [nondim] + real :: x_2 ! The x-position relative to the center of the domain normalized by the + ! domain width [nondim] + real :: y_2_grid ! The y-position relative to the center of the domain in the same units + ! as geolat, often [km] + real :: y_2_L ! The y-position relative to the center of the domain [L ~> m] + real :: y_2_norm ! The y-position relative to the center of the domain normalized by the + ! domain width [nondim] real :: velocity_amplitude ! The amplitude of velocity perturbations [L T-1 ~> m s-1] real :: pi ! The ratio of the circumference of a circle to its diameter [nondim] + real :: km_to_grid_unit ! The conversion factor from km to the units of latitude, often 1 [nondim], + ! but this could be 1000 [m km-1] + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + integer :: answer_date ! The vintage of the expressions in the Phillips_initialization code. + ! Values below 20250101 recover the answers from the end of 2018, while + ! higher values use mathematically equivalent expressions that are fully + ! rescalable. integer :: i, j, k, is, ie, js, je, nz, m logical :: reentrant_y ! If true, model is re-entrant in the y direction character(len=40) :: mdl = "Phillips_initialize_velocity" ! This subroutine's name. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + if (G%grid_unit_to_L <= 0.) call MOM_error(FATAL, "Phillips_initialization: "//& + "Phillips_initialize_velocity is only set to work with Cartesian axis units.") + if (abs(G%grid_unit_to_L*US%L_to_m - 1000.0) < 1.0e-3) then ! The grid latitudes are in km. + km_to_grid_unit = 1.0 + elseif (abs(G%grid_unit_to_L*US%L_to_m - 1.0) < 1.0e-6) then ! The grid latitudes are in m. + km_to_grid_unit = 1000.0 + else + call MOM_error(FATAL, "Phillips_initialization: "//& + "Phillips_initialize_velocity is not recognizing the value of G%grid_unit_to_L.") + endif + if (.not.just_read) call log_version(param_file, mdl, version) call get_param(param_file, mdl, "VELOCITY_IC_PERTURB_AMP", velocity_amplitude, & "The magnitude of the initial velocity perturbation.", & units="m s-1", default=0.001, scale=US%m_s_to_L_T, do_not_log=just_read) - call get_param(param_file, mdl, "JET_WIDTH", jet_width, & - "The width of the zonal-mean jet.", units="km", & + call get_param(param_file, mdl, "JET_WIDTH", jet_width_L, & + "The width of the zonal-mean jet.", units="km", scale=1000.0*US%m_to_L, & fail_if_missing=.not.just_read, do_not_log=just_read) - call get_param(param_file, mdl, "JET_HEIGHT", jet_height, & - "The interface height scale associated with the "//& - "zonal-mean jet.", units="m", scale=US%m_to_Z, & + call get_param(param_file, mdl, "JET_WIDTH", jet_width_grid, & + "The width of the zonal-mean jet.", units="km", scale=km_to_grid_unit, & fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "JET_HEIGHT", jet_height, & + "The interface height scale associated with the zonal-mean jet.", & + units="m", scale=US%m_to_Z, fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "PHILLIPS_ANSWER_DATE", answer_date, & + "The vintage of the expressions in the Phillips_initialization code. Values "//& + "below 20250101 recover the answers from the end of 2018, while higher "//& + "values use mathematically equivalent expressions that are fully rescalable.", & + default=min(20241201,default_answer_date)) !### Change this to default=default_answer_date) ! If re-entrant in the Y direction, we use a sine function instead of a - ! tanh. The ratio len_lat/jet_width should be an integer in this case. + ! tanh. The ratio len_lat/jet_width_grid should be an integer in this case. call get_param(param_file, mdl, "REENTRANT_Y", reentrant_y, & default=.false., do_not_log=.true.) if (just_read) return ! All run-time parameters have been read, so return. + if (G%grid_unit_to_L <= 0.) call MOM_error(FATAL, 'Phillips_initialization.F90: '// & + "Phillips_initialize_velocity() is only set to work with Cartesian axis units.") + u(:,:,:) = 0.0 v(:,:,:) = 0.0 pi = 4.0*atan(1.0) ! Use thermal wind shear to give a geostrophically balanced flow. - do k=nz-1,1 ; do j=js,je ; do I=is-1,ie - y_2 = G%geoLatCu(I,j) - G%south_lat - 0.5*G%len_lat - if (reentrant_y) then - y_2 = 2.*pi*y_2 - u(I,j,k) = u(I,j,k+1) + (1.e-3 * (jet_height / (US%m_to_L*jet_width)) * & - cos(y_2/jet_width) ) - else -! This uses d/d y_2 atan(y_2 / jet_width) -! u(I,j,k) = u(I,j,k+1) + ( jet_height / & -! (1.0e3*US%m_to_L*jet_width * (1.0 + (y_2 / jet_width)**2))) * & -! (2.0 * GV%g_prime(K+1) / (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1))) -! This uses d/d y_2 tanh(y_2 / jet_width) - u(I,j,k) = u(I,j,k+1) + (1e-3 * (jet_height / (US%m_to_L*jet_width)) * & - (sech(y_2 / jet_width))**2 ) * & - (2.0 * GV%g_prime(K+1) / (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1))) - endif - enddo ; enddo ; enddo + if (answer_date < 20250101) then + do k=nz-1,1 ; do j=js,je ; do I=is-1,ie + y_2_grid = G%geoLatCu(I,j) - G%south_lat - 0.5*G%len_lat + if (reentrant_y) then + y_2_grid = 2.*pi*y_2_grid + u(I,j,k) = u(I,j,k+1) + (1.e-3 * (jet_height / (US%m_to_L*jet_width_grid)) * & + cos(y_2_grid/jet_width_grid) ) + else + ! This uses d/d y_2 atan(y_2 / jet_width) + ! u(I,j,k) = u(I,j,k+1) + ( jet_height / & + ! (1.0e3*US%m_to_L*jet_width_grid * (1.0 + (y_2_grid / jet_width_grid)**2))) * & + ! (2.0 * GV%g_prime(K+1) / (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1))) + ! This uses d/d y_2 tanh(y_2 / jet_width) + u(I,j,k) = u(I,j,k+1) + (1e-3 * (jet_height / (US%m_to_L*jet_width_grid)) * & + (sech(y_2_grid / jet_width_grid))**2 ) * & + (2.0 * GV%g_prime(K+1) / (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1))) + endif + enddo ; enddo ; enddo + else + I_jet_width = 1.0 / jet_width_L + do k=nz-1,1 ; do j=js,je ; do I=is-1,ie + y_2_L = (G%geoLatCu(I,j) - (G%south_lat + 0.5*G%len_lat)) * G%grid_unit_to_L + if (reentrant_y) then + u(I,j,k) = u(I,j,k+1) + ((jet_height * I_jet_width) * cos(2.*pi*(y_2_L*I_jet_width)) ) + else + ! This uses d/d y_2 atan(y_2 / jet_width) + ! u(I,j,k) = u(I,j,k+1) + ( (jet_height*I_jet_width) / (1.0 + (y_2_L*I_jet_width)**2)) * & + ! (2.0 * GV%g_prime(K+1) / (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1))) + ! This uses d/d y_2_L tanh(y_2_L*I_jet_width) + u(I,j,k) = u(I,j,k+1) + ((jet_height * I_jet_width) * (sech(y_2_L*I_jet_width))**2 ) * & + (2.0 * GV%g_prime(K+1) / (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1))) + endif + enddo ; enddo ; enddo + endif do k=1,nz ; do j=js,je ; do I=is-1,ie - y_2 = (G%geoLatCu(I,j) - G%south_lat - 0.5*G%len_lat) / G%len_lat + y_2_norm = (G%geoLatCu(I,j) - G%south_lat - 0.5*G%len_lat) / G%len_lat x_2 = (G%geoLonCu(I,j) - G%west_lon - 0.5*G%len_lon) / G%len_lon if (G%geoLonCu(I,j) == G%west_lon) then ! This modification is required so that the perturbations are identical for @@ -204,16 +274,16 @@ subroutine Phillips_initialize_velocity(u, v, G, GV, US, param_file, just_read) G%west_lon - 0.5*G%len_lon) / G%len_lon endif u(I,j,k) = u(I,j,k) + velocity_amplitude * ((real(k)-0.5)/real(nz)) * & - (0.5 - abs(2.0*x_2) + 0.1*abs(cos(10.0*pi*x_2)) - abs(sin(5.0*pi*y_2))) + (0.5 - abs(2.0*x_2) + 0.1*abs(cos(10.0*pi*x_2)) - abs(sin(5.0*pi*y_2_norm))) do m=1,10 u(I,j,k) = u(I,j,k) + 0.2*velocity_amplitude * ((real(k)-0.5)/real(nz)) * & - cos(2.0*m*pi*x_2 + 2*m) * cos(6.0*pi*y_2) + cos(2.0*m*pi*x_2 + 2*m) * cos(6.0*pi*y_2_norm) enddo enddo ; enddo ; enddo end subroutine Phillips_initialize_velocity -!> Sets up the the inverse restoration time (Idamp), and the values towards which the interface +!> Sets up the inverse restoration time (Idamp), and the values towards which the interface !! heights and an arbitrary number of tracers should be restored within each sponge for the Phillips !! model test case subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) @@ -234,28 +304,42 @@ subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) real, intent(in), dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h !< Thickness field [H ~> m or kg m-2]. ! Local variables - real :: eta0(SZK_(GV)+1) ! The 1-d nominal positions of the interfaces. + real :: eta0(SZK_(GV)+1) ! The 1-d nominal positions of the interfaces [Z ~> m] real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! A temporary array for interface heights [Z ~> m]. - real :: temp(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for other variables. + real :: temp(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for other variables [various] real :: Idamp(SZI_(G),SZJ_(G)) ! The sponge damping rate [T-1 ~> s-1] real :: eta_im(SZJ_(G),SZK_(GV)+1) ! A temporary array for zonal-mean eta [Z ~> m]. real :: Idamp_im(SZJ_(G)) ! The inverse zonal-mean damping rate [T-1 ~> s-1]. real :: damp_rate ! The inverse zonal-mean damping rate [T-1 ~> s-1]. - real :: jet_width ! The width of the zonal mean jet, in km. + real :: jet_width ! The width of the zonal mean jet in the same units as geolat, often [km] real :: jet_height ! The interface height scale associated with the zonal-mean jet [Z ~> m]. - real :: y_2 ! The y-position relative to the channel center, in km. + real :: y_2 ! The y-position relative to the channel center in the same units as + ! geolat, often [km] real :: half_strat ! The fractional depth where the straficiation is centered [nondim]. real :: half_depth ! The depth where the stratification is centered [Z ~> m]. real :: pi ! The ratio of the circumference of a circle to its diameter [nondim] + real :: km_to_grid_unit ! The conversion factor from km to the units of latitude, often 1 [nondim], + ! but this could be 1000 [m km-1] logical :: reentrant_y ! If true, model is re-entrant in the y direction character(len=40) :: mdl = "Phillips_initialize_sponges" ! This subroutine's name. - integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz + integer :: j, k, is, ie, js, je, isd, ied, jsd, jed, nz logical, save :: first_call = .true. 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 + if (G%grid_unit_to_L <= 0.) call MOM_error(FATAL, "Phillips_initialization: "//& + "Phillips_initialize_sponges is only set to work with Cartesian axis units.") + if (abs(G%grid_unit_to_L*US%L_to_m - 1000.0) < 1.0e-3) then ! The grid latitudes are in km. + km_to_grid_unit = 1.0 + elseif (abs(G%grid_unit_to_L*US%L_to_m - 1.0) < 1.0e-6) then ! The grid latitudes are in m. + km_to_grid_unit = 1000.0 + else + call MOM_error(FATAL, "Phillips_initialization: "//& + "Phillips_initialize_sponges is not recognizing the value of G%grid_unit_to_L.") + endif + eta(:,:,:) = 0.0 ; temp(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 eta_im(:,:) = 0.0 ; Idamp_im(:) = 0.0 @@ -263,18 +347,17 @@ subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) first_call = .false. call get_param(param_file, mdl, "HALF_STRAT_DEPTH", half_strat, & "The fractional depth where the stratificaiton is centered.", & - units="nondim", default = 0.5) + units="nondim", default=0.5) call get_param(param_file, mdl, "SPONGE_RATE", damp_rate, & - "The rate at which the zonal-mean sponges damp.", units="s-1", & - default = 1.0/(10.0*86400.0), scale=US%T_to_s) + "The rate at which the zonal-mean sponges damp.", & + units="s-1", default=1.0/(10.0*86400.0), scale=US%T_to_s) call get_param(param_file, mdl, "JET_WIDTH", jet_width, & - "The width of the zonal-mean jet.", units="km", & + "The width of the zonal-mean jet.", units="km", scale=km_to_grid_unit, & fail_if_missing=.true.) call get_param(param_file, mdl, "JET_HEIGHT", jet_height, & - "The interface height scale associated with the "//& - "zonal-mean jet.", units="m", scale=US%m_to_Z, & - fail_if_missing=.true.) + "The interface height scale associated with the zonal-mean jet.", & + units="m", scale=US%m_to_Z, fail_if_missing=.true.) ! If re-entrant in the Y direction, we use a sine function instead of a ! tanh. The ratio len_lat/jet_width should be an integer in this case. call get_param(param_file, mdl, "REENTRANT_Y", reentrant_y, & @@ -295,7 +378,6 @@ subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) do K=2,nz ; do j=js,je y_2 = G%geoLatT(is,j) - G%south_lat - 0.5*G%len_lat eta_im(j,K) = eta0(k) + jet_height * tanh(y_2 / jet_width) -! jet_height * atan(y_2 / jet_width) if (reentrant_y) then y_2 = 2.*pi*y_2 eta_im(j,K) = eta0(k) + jet_height * sin(y_2 / jet_width) @@ -310,8 +392,8 @@ end subroutine Phillips_initialize_sponges !> sech calculates the hyperbolic secant. function sech(x) - real, intent(in) :: x !< Input value. - real :: sech !< Result. + real, intent(in) :: x !< Input value [nondim]. + real :: sech !< Result [nondim]. ! This is here to prevent overflows or underflows. if (abs(x) > 228.) then @@ -325,15 +407,20 @@ end function sech subroutine Phillips_initialize_topography(D, G, param_file, max_depth, US) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth [m ~> Z] + intent(out) :: D !< Ocean bottom depth [Z ~> m] type(param_file_type), intent(in) :: param_file !< Parameter file structure real, intent(in) :: max_depth !< Maximum model depth [Z ~> m] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables - real :: PI, Htop, Wtop, Ltop, offset, dist - real :: x1, x2, x3, x4, y1, y2 - integer :: i,j,is,ie,js,je + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] + real :: Htop ! The maximum height of the topography above max_depth [Z ~> m] + real :: Wtop ! meridional width of topographic features [km] + real :: Ltop ! zonal width of topographic features [km] + real :: offset ! meridional offset from the center of topographic features [km] + real :: dist ! zonal width of topographic features [km] + real :: x1, x2, x3, x4, y1, y2 ! Various positions in the domain [km] + integer :: i, j, is, ie, js, je character(len=40) :: mdl = "Phillips_initialize_topography" ! This subroutine's name. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -347,13 +434,12 @@ subroutine Phillips_initialize_topography(D, G, param_file, max_depth, US) Wtop = 0.5*G%len_lat ! meridional width of drake and mount Ltop = 0.25*G%len_lon ! zonal width of topographic features offset = 0.1*G%len_lat ! meridional offset from center - dist = 0.333*G%len_lon ! distance between drake and mount - ! should be longer than Ltop/2 + dist = 0.333*G%len_lon ! distance between drake and mount, this should be longer than Ltop/2 - y1=G%south_lat+0.5*G%len_lat+offset-0.5*Wtop; y2=y1+Wtop - x1=G%west_lon+0.1*G%len_lon; x2=x1+Ltop; x3=x1+dist; x4=x3+3.0/2.0*Ltop + y1 = G%south_lat+0.5*G%len_lat+offset-0.5*Wtop ; y2 = y1+Wtop + x1 = G%west_lon+0.1*G%len_lon ; x2 = x1+Ltop ; x3 = x1+dist ; x4 = x3+3.0/2.0*Ltop - do i=is,ie ; do j=js,je + do j=js,je ; do i=is,ie D(i,j)=0.0 if (G%geoLonT(i,j)>x1 .and. G%geoLonT(i,j) m] (positive downward) !! f - The Coriolis parameter [T-1 ~> s-1]. !! If ENABLE_THERMODYNAMICS is defined: -!! T - Temperature [degC]. -!! S - Salinity [ppt]. +!! T - Temperature [C ~> degC]. +!! S - Salinity [S ~> ppt]. !! If SPONGE is defined: !! A series of subroutine calls are made to set up the damping !! rates and reference profiles for all variables that are damped diff --git a/src/user/RGC_initialization.F90 b/src/user/RGC_initialization.F90 index b8eae3c704..de7727ee72 100644 --- a/src/user/RGC_initialization.F90 +++ b/src/user/RGC_initialization.F90 @@ -1,22 +1,11 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + +!> Configures the models sponges for the Rotating Gravity Current (RGC) experiment. module RGC_initialization + !*********************************************************************** -!* GNU General Public License * -!* This file is a part of MOM. * -!* * -!* MOM is free software; you can redistribute it and/or modify it and * -!* are expected to follow the terms of the GNU General Public License * -!* as published by the Free Software Foundation; either version 2 of * -!* the License, or (at your option) any later version. * -!* * -!* MOM is distributed in the hope that it will be useful, but WITHOUT * -!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * -!* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public * -!* License for more details. * -!* * -!* For the full text of the GNU General Public License, * -!* write to: Free Software Foundation, Inc., * -!* 675 Mass Ave, Cambridge, MA 02139, USA. * -!* or see: http://www.gnu.org/licenses/gpl.html * !* By Elizabeth Yankovsky, May 2018 * !*********************************************************************** @@ -34,17 +23,21 @@ module RGC_initialization use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type, EOS_domain +use MOM_EOS, only : calculate_density, EOS_domain implicit none ; private #include -character(len=40) :: mod = "RGC_initialization" ! This module's name. public RGC_initialize_sponges +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + contains -!> Sets up the the inverse restoration time, and the values towards which the interface heights, +!> Sets up the inverse restoration time, and the values towards which the interface heights, !! velocities and tracers should be restored within the sponges for the RGC test case. subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, CSp, ACSp) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. @@ -54,73 +47,64 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C !! to any available thermodynamic !! fields, potential temperature and !! salinity or mixed layer density. - !! Absent fields have NULL ptrs. + !! Absent fields have NULL pointers. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & target, intent(in) :: u !< Array with the u velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & target, intent(in) :: v !< Array with the v velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] - type(param_file_type), intent(in) :: PF !< A structure indicating the - !! open file to parse for model - !! parameter values. - logical, intent(in) :: use_ALE !< If true, indicates model is in ALE mode - type(sponge_CS), pointer :: CSp !< Layer-mode sponge structure + type(param_file_type), intent(in) :: PF !< A structure to parse for model parameter values. + logical, intent(in) :: use_ALE !< If true, indicates model is in ALE mode + type(sponge_CS), pointer :: CSp !< Layer-mode sponge structure type(ALE_sponge_CS), pointer :: ACSp !< ALE-mode sponge structure -! Local variables - real :: T(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for temp - real :: S(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for salt + ! Local variables + real :: T(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for temperature [C ~> degC] + real :: S(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for salinity [S ~> ppt] real :: U1(SZIB_(G),SZJ_(G),SZK_(GV)) ! A temporary array for u [L T-1 ~> m s-1] real :: V1(SZI_(G),SZJB_(G),SZK_(GV)) ! A temporary array for v [L T-1 ~> m s-1] - real :: RHO(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for RHO - real :: tmp(SZI_(G),SZJ_(G)) ! A temporary array for tracers. - real :: h(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for thickness at h points + real :: rho(SZI_(G),SZJ_(G)) ! A temporary array for mixed layer density [R ~> kg m-3]. + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Sponge layer thicknesses in height units [Z ~> m] real :: Idamp(SZI_(G),SZJ_(G)) ! The sponge damping rate at h points [T-1 ~> s-1] real :: TNUDG ! Nudging time scale [T ~> s] real :: pres(SZI_(G)) ! An array of the reference pressure [R L2 T-2 ~> Pa] - real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! A temporary array for eta, positive upward [m]. + real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! A temporary array for eta, positive upward [Z ~> m] logical :: sponge_uv ! Nudge velocities (u and v) towards zero - real :: min_depth, dummy1, z, delta_h - real :: rho_dummy, min_thickness, rho_tmp, xi0 - real :: lenlat, lenlon, lensponge + real :: min_depth ! The minimum depth of the ocean [Z ~> m] + real :: dummy1 ! The position relative to the sponge width [nondim] + real :: min_thickness ! A minimum layer thickness [H ~> m or kg m-2] (unused) + real :: lensponge ! The width of the sponge in axis units, [km] or [m] character(len=40) :: filename, state_file character(len=40) :: temp_var, salt_var, eta_var, inputdir, h_var - character(len=40) :: mod = "RGC_initialize_sponges" ! This subroutine's name. + character(len=40) :: mdl = "RGC_initialize_sponges" ! This subroutine's name. integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state - integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, iscB, iecB, jscB, jecB + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, nz, iscB, iecB, jscB, jecB 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 - iscB = G%iscB ; iecB = G%iecB; jscB = G%jscB ; jecB = G%jecB + iscB = G%iscB ; iecB = G%iecB ; jscB = G%jscB ; jecB = G%jecB - call get_param(PF, mod,"MIN_THICKNESS", min_thickness, 'Minimum layer thickness', & - units='m', default=1.e-3) + ! The variable min_thickness is unused, and can probably be eliminated. + call get_param(PF, mdl, "MIN_THICKNESS", min_thickness, 'Minimum layer thickness', & + units='m', default=1.e-3, scale=GV%m_to_H) - call get_param(PF, mod, "RGC_TNUDG", TNUDG, 'Nudging time scale for sponge layers', & + call get_param(PF, mdl, "RGC_TNUDG", TNUDG, 'Nudging time scale for sponge layers', & units='days', default=0.0, scale=86400.0*US%s_to_T) - call get_param(PF, mod, "LENLAT", lenlat, & - "The latitudinal or y-direction length of the domain", & - fail_if_missing=.true., do_not_log=.true.) - - call get_param(PF, mod, "LENLON", lenlon, & - "The longitudinal or x-direction length of the domain", & - fail_if_missing=.true., do_not_log=.true.) - - call get_param(PF, mod, "LENSPONGE", lensponge, & - "The length of the sponge layer (km).", & - default=10.0) + call get_param(PF, mdl, "LENSPONGE", lensponge, & + "The length of the sponge layer.", & + units=G%x_ax_unit_short, default=10.0) - call get_param(PF, mod, "SPONGE_UV", sponge_uv, & + call get_param(PF, mdl, "SPONGE_UV", sponge_uv, & "Nudge velocities (u and v) towards zero in the sponge layer.", & default=.false., do_not_log=.true.) - T(:,:,:) = 0.0 ; S(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 ; RHO(:,:,:) = 0.0 + T(:,:,:) = 0.0 ; S(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 - call get_param(PF, mod, "MINIMUM_DEPTH", min_depth, & - "The minimum depth of the ocean.", units="m", default=0.0) + call get_param(PF, mdl, "MINIMUM_DEPTH", min_depth, & + "The minimum depth of the ocean.", units="m", default=0.0, scale=US%m_to_Z) if (associated(CSp)) call MOM_error(FATAL, & "RGC_initialize_sponges called with an associated control structure.") @@ -132,11 +116,11 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C ! will automatically set up the sponges only where Idamp is positive ! and mask2dT is 1. - do i=is,ie ; do j=js,je + do j=js,je ; do i=is,ie if ((depth_tot(i,j) <= min_depth) .or. (G%geoLonT(i,j) <= lensponge)) then Idamp(i,j) = 0.0 - elseif (G%geoLonT(i,j) >= (lenlon - lensponge) .AND. G%geoLonT(i,j) <= lenlon) then - dummy1 = (G%geoLonT(i,j)-(lenlon - lensponge))/(lensponge) + elseif (G%geoLonT(i,j) >= (G%len_lon - lensponge) .AND. G%geoLonT(i,j) <= G%len_lon) then + dummy1 = (G%geoLonT(i,j)-(G%len_lon - lensponge))/(lensponge) Idamp(i,j) = (1.0/TNUDG) * max(0.0,dummy1) else Idamp(i,j) = 0.0 @@ -145,26 +129,21 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C ! 1) Read eta, salt and temp from IC file - call get_param(PF, mod, "INPUTDIR", inputdir, default=".") + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) - ! GM: get two different files, one with temp and one with salt values - ! this is work around to avoid having wrong values near the surface - ! because of the FIT_SALINITY option. To get salt values right in the - ! sponge, FIT_SALINITY=False. The oposite is true for temp. One can - ! combined the *correct* temp and salt values in one file instead. - call get_param(PF, mod, "RGC_SPONGE_FILE", state_file, & + call get_param(PF, mdl, "RGC_SPONGE_FILE", state_file, & "The name of the file with temps., salts. and interfaces to \n"// & " damp toward.", fail_if_missing=.true.) - call get_param(PF, mod, "SPONGE_PTEMP_VAR", temp_var, & + call get_param(PF, mdl, "SPONGE_PTEMP_VAR", temp_var, & "The name of the potential temperature variable in \n"//& "SPONGE_STATE_FILE.", default="Temp") - call get_param(PF, mod, "SPONGE_SALT_VAR", salt_var, & + call get_param(PF, mdl, "SPONGE_SALT_VAR", salt_var, & "The name of the salinity variable in \n"//& "SPONGE_STATE_FILE.", default="Salt") - call get_param(PF, mod, "SPONGE_ETA_VAR", eta_var, & + call get_param(PF, mdl, "SPONGE_ETA_VAR", eta_var, & "The name of the interface height variable in \n"//& "SPONGE_STATE_FILE.", default="eta") - call get_param(PF, mod, "SPONGE_H_VAR", h_var, & + call get_param(PF, mdl, "SPONGE_H_VAR", h_var, & "The name of the layer thickness variable in \n"//& "SPONGE_STATE_FILE.", default="h") @@ -172,18 +151,20 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C filename = trim(inputdir)//trim(state_file) if (.not.file_exists(filename, G%Domain)) & call MOM_error(FATAL, " RGC_initialize_sponges: Unable to open "//trim(filename)) - call MOM_read_data(filename, temp_var, T(:,:,:), G%Domain) - call MOM_read_data(filename, salt_var, S(:,:,:), G%Domain) + call MOM_read_data(filename, temp_var, T(:,:,:), G%Domain, scale=US%degC_to_C) + call MOM_read_data(filename, salt_var, S(:,:,:), G%Domain, scale=US%ppt_to_S) if (use_ALE) then - call MOM_read_data(filename, h_var, h(:,:,:), G%Domain) - call pass_var(h, G%domain) + call MOM_read_data(filename, h_var, dz(:,:,:), G%Domain, scale=US%m_to_Z) + call pass_var(dz, G%domain) - call initialize_ALE_sponge(Idamp, G, GV, PF, ACSp, h, nz) + call initialize_ALE_sponge(Idamp, G, GV, PF, ACSp, dz, nz, data_h_is_Z=.true.) - ! The remaining calls to set_up_sponge_field can be in any order. ! - if ( associated(tv%T) ) call set_up_ALE_sponge_field(T, G, GV, tv%T, ACSp) - if ( associated(tv%S) ) call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp) + ! The remaining calls to set_up_sponge_field can be in any order. + if ( associated(tv%T) ) call set_up_ALE_sponge_field(T, G, GV, tv%T, ACSp, 'temp', & + sp_long_name='temperature', sp_unit='degC s-1') + if ( associated(tv%S) ) call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp, 'salt', & + sp_long_name='salinity', sp_unit='g kg-1 s-1') if (sponge_uv) then U1(:,:,:) = 0.0 ; V1(:,:,:) = 0.0 @@ -194,7 +175,7 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C else ! layer mode !read eta - call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain) + call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain, scale=US%m_to_Z) ! Set the sponge damping rates so that the model will know where to ! apply the sponges, along with the interface heights. @@ -204,13 +185,13 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C ! This call to set_up_sponge_ML_density registers the target values of the ! mixed layer density, which is used in determining which layers can be ! inflated without causing static instabilities. - do i=is-1,ie ; pres(i) = tv%P_Ref ; enddo + do i=is,ie ; pres(i) = tv%P_Ref ; enddo EOSdom(:) = EOS_domain(G%HI) do j=js,je - call calculate_density(T(:,j,1), S(:,j,1), pres, tmp(:,j), tv%eqn_of_state, EOSdom) + call calculate_density(T(:,j,1), S(:,j,1), pres, rho(:,j), tv%eqn_of_state, EOSdom) enddo - call set_up_sponge_ML_density(tmp, G, CSp) + call set_up_sponge_ML_density(rho, G, CSp) endif ! Apply sponge in tracer fields diff --git a/src/user/Rossby_front_2d_initialization.F90 b/src/user/Rossby_front_2d_initialization.F90 index c35386a2fe..ffc7610391 100644 --- a/src/user/Rossby_front_2d_initialization.F90 +++ b/src/user/Rossby_front_2d_initialization.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Initial conditions for the 2D Rossby front test module Rossby_front_2d_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories @@ -10,7 +12,6 @@ module Rossby_front_2d_initialization use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type use regrid_consts, only : coordinateMode, DEFAULT_COORDINATE_MODE use regrid_consts, only : REGRIDDING_LAYER, REGRIDDING_ZSTAR use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA @@ -47,11 +48,17 @@ subroutine Rossby_front_initialize_thickness(h, G, GV, US, param_file, just_read logical, intent(in) :: just_read !< If true, this call will only read !! parameters without changing h. - integer :: i, j, k, is, ie, js, je, nz - real :: Tz, Dml, eta, stretch, h0 - real :: min_thickness, T_range - real :: dRho_dT ! The partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] + ! Local variables + real :: Tz ! Vertical temperature gradient [C H-1 ~> degC m2 kg-1] + real :: Dml ! Mixed layer depth [H ~> m or kg m-2] + real :: eta ! An interface height depth [H ~> m or kg m-2] + real :: stretch ! A nondimensional stretching factor [nondim] + real :: h0 ! The stretched thickness per layer [H ~> m or kg m-2] + real :: T_range ! Range of temperatures over the vertical [C ~> degC] + real :: dRho_dT ! The partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: max_depth ! Maximum depth of the model bathymetry [H ~> m or kg m-2] character(len=40) :: verticalCoordinate + integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -60,94 +67,123 @@ subroutine Rossby_front_initialize_thickness(h, G, GV, US, param_file, just_read if (.not.just_read) call log_version(param_file, mdl, version, "") ! Read parameters needed to set thickness - call get_param(param_file, mdl, "MIN_THICKNESS", min_thickness, & - 'Minimum layer thickness',units='m',default=1.e-3, do_not_log=just_read) call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & - units='C', default=0.0, do_not_log=just_read) - call get_param(param_file, mdl, "DRHO_DT", dRho_dT, default=-0.2, scale=US%kg_m3_to_R, do_not_log=.true.) + units="degC", default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "DRHO_DT", dRho_dT, & + units="kg m-3 degC-1", default=-0.2, scale=US%kg_m3_to_R*US%C_to_degC, do_not_log=.true.) + call get_param(param_file, mdl, "MAXIMUM_DEPTH", max_depth, & + units="m", default=-1.e9, scale=GV%m_to_H, do_not_log=.true.) if (just_read) return ! All run-time parameters have been read, so return. - Tz = T_range / G%max_depth - - select case ( coordinateMode(verticalCoordinate) ) - - case (REGRIDDING_LAYER, REGRIDDING_RHO) - do j = G%jsc,G%jec ; do i = G%isc,G%iec - Dml = Hml( G, G%geoLatT(i,j) ) - eta = -( -dRho_DT / GV%Rho0 ) * Tz * 0.5 * ( Dml * Dml ) - stretch = ( ( G%max_depth + eta ) / G%max_depth ) - h0 = ( G%max_depth / real(nz) ) * stretch - do k = 1, nz - h(i,j,k) = h0 * GV%Z_to_H - enddo - enddo ; enddo - - case (REGRIDDING_ZSTAR, REGRIDDING_SIGMA) - do j = G%jsc,G%jec ; do i = G%isc,G%iec - Dml = Hml( G, G%geoLatT(i,j) ) - eta = -( -dRho_DT / GV%Rho0 ) * Tz * 0.5 * ( Dml * Dml ) - stretch = ( ( G%max_depth + eta ) / G%max_depth ) - h0 = ( G%max_depth / real(nz) ) * stretch - do k = 1, nz - h(i,j,k) = h0 * GV%Z_to_H - enddo - enddo ; enddo - - case default - call MOM_error(FATAL,"Rossby_front_initialize: "// & - "Unrecognized i.c. setup - set REGRIDDING_COORDINATE_MODE") - - end select + if (max_depth <= 0.0) call MOM_error(FATAL, & + "Rossby_front_initialize_thickness, Rossby_front_initialize_thickness: "//& + "This module requires a positive value of MAXIMUM_DEPTH.") + + Tz = T_range / max_depth + + if (GV%Boussinesq) then + select case ( coordinateMode(verticalCoordinate) ) + + case (REGRIDDING_LAYER, REGRIDDING_RHO) + ! This code is identical to the REGRIDDING_ZSTAR case but probably should not be. + do j = G%jsc,G%jec ; do i = G%isc,G%iec + Dml = Hml( G, G%geoLatT(i,j), max_depth ) + eta = -( -dRho_dT / GV%Rho0 ) * Tz * 0.5 * ( Dml * Dml ) + stretch = ( ( max_depth + eta ) / max_depth ) + h0 = ( max_depth / real(nz) ) * stretch + do k = 1, nz + h(i,j,k) = h0 + enddo + enddo ; enddo + + case (REGRIDDING_ZSTAR, REGRIDDING_SIGMA) + do j = G%jsc,G%jec ; do i = G%isc,G%iec + Dml = Hml( G, G%geoLatT(i,j), max_depth ) + ! The free surface height is set so that the bottom pressure gradient is 0. + eta = -( -dRho_dT / GV%Rho0 ) * Tz * 0.5 * ( Dml * Dml ) + stretch = ( ( max_depth + eta ) / max_depth ) + h0 = ( max_depth / real(nz) ) * stretch + do k = 1, nz + h(i,j,k) = h0 + enddo + enddo ; enddo + + case default + call MOM_error(FATAL,"Rossby_front_initialize: "// & + "Unrecognized i.c. setup - set REGRIDDING_COORDINATE_MODE") + + end select + else + ! In non-Boussinesq mode with a flat bottom, the only requirement for no bottom pressure + ! gradient and no abyssal flow is that all columns have the same mass. + h0 = max_depth / real(nz) + do k=1,nz ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + h(i,j,k) = h0 + enddo ; enddo ; enddo + endif end subroutine Rossby_front_initialize_thickness !> Initialization of temperature and salinity in the Rossby front test -subroutine Rossby_front_initialize_temperature_salinity(T, S, h, G, GV, & +subroutine Rossby_front_initialize_temperature_salinity(T, S, h, G, GV, US, & param_file, just_read) type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [S ~> ppt] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Thickness [H ~> m or kg m-2] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file handle logical, intent(in) :: just_read !< If true, this call will !! only read parameters without changing T & S. - - integer :: i, j, k, is, ie, js, je, nz - real :: T_ref, S_ref ! Reference salinity and temerature within surface layer - real :: T_range ! Range of salinities and temperatures over the vertical - real :: y, zc, zi, dTdz + ! Local variables + real :: T_ref ! Reference temperature within the surface layer [C ~> degC] + real :: S_ref ! Reference salinity within the surface layer [S ~> ppt] + real :: T_range ! Range of temperatures over the vertical [C ~> degC] + real :: zc ! Position of the middle of the cell [H ~> m or kg m-2] + real :: zi ! Bottom interface position relative to the sea surface [H ~> m or kg m-2] + real :: dTdz ! Vertical temperature gradient [C H-1 ~> degC m-1 or degC m2 kg-1] + real :: Dml ! Mixed layer depth [H ~> m or kg m-2] + real :: max_depth ! Maximum depth of the model bathymetry [H ~> m or kg m-2] character(len=40) :: verticalCoordinate - real :: PI ! 3.1415926... calculated as 4*atan(1) + integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke call get_param(param_file, mdl,"REGRIDDING_COORDINATE_MODE", verticalCoordinate, & - default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) + default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & - default=35.0, units='1e-3', do_not_log=just_read) - call get_param(param_file, mdl,"T_REF",T_ref,'Reference temperature',units='C',& - fail_if_missing=.not.just_read, do_not_log=just_read) - call get_param(param_file, mdl,"T_RANGE",T_range,'Initial temperature range',& - units='C', default=0.0, do_not_log=just_read) + default=35.0, units="ppt", scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "T_REF", T_ref, 'Reference temperature', & + units="degC", scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & + units="degC", default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "MAXIMUM_DEPTH", max_depth, & + units="m", default=-1.e9, scale=GV%m_to_H, do_not_log=.true.) if (just_read) return ! All run-time parameters have been read, so return. + if (max_depth <= 0.0) call MOM_error(FATAL, & + "Rossby_front_initialize_thickness, Rossby_front_initialize_temperature_salinity: "//& + "This module requires a positive value of MAXIMUM_DEPTH.") + T(:,:,:) = 0.0 S(:,:,:) = S_ref - dTdz = T_range / G%max_depth + dTdz = T_range / max_depth + ! This sets the temperature to the value at the base of the specified mixed layer + ! depth from a horizontally uniform constant thermal stratification. do j = G%jsc,G%jec ; do i = G%isc,G%iec zi = 0. + Dml = Hml(G, G%geoLatT(i,j), max_depth) do k = 1, nz - zi = zi - h(i,j,k) ! Bottom interface position - zc = GV%H_to_Z * (zi - 0.5*h(i,j,k)) ! Position of middle of cell - zc = min( zc, -Hml(G, G%geoLatT(i,j)) ) ! Bound by depth of mixed layer - T(i,j,k) = T_ref + dTdz * zc ! Linear temperature profile + zi = zi - h(i,j,k) ! Bottom interface position + zc = zi - 0.5*h(i,j,k) ! Position of middle of cell + T(i,j,k) = T_ref + dTdz * min( zc, -Dml ) ! Linear temperature profile below the mixed layer enddo enddo ; enddo @@ -170,14 +206,25 @@ subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, US, param_file, just logical, intent(in) :: just_read !< If present and true, this call will only !! read parameters without setting u & v. - real :: y ! Non-dimensional coordinate across channel, 0..pi - real :: T_range ! Range of salinities and temperatures over the vertical - real :: dUdT ! Factor to convert dT/dy into dU/dz, g*alpha/f [L2 Z-1 T-1 degC-1 ~> m s-1 degC-1] - real :: dRho_dT ! The partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] - real :: Dml, zi, zc, zm ! Depths [Z ~> m]. + real :: T_range ! Range of temperatures over the vertical [C ~> degC] + real :: T_ref ! Reference temperature within the surface layer [C ~> degC] + real :: S_ref ! Reference salinity within the surface layer [S ~> ppt] + real :: dUdT ! Factor to convert dT/dy into dU/dz, g*alpha/f with rescaling + ! [L2 H-1 T-1 C-1 ~> m s-1 degC-1 or m4 kg-1 s-1 degC-1] + real :: Rho_T0_S0 ! The density at T=0, S=0 [R ~> kg m-3] + real :: dRho_dT ! The partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: dRho_dS ! The partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] + real :: dSpV_dT ! The partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + real :: T_here ! The temperature in the middle of a layer [C ~> degC] + real :: dTdz ! Vertical temperature gradient [C H-1 ~> degC m-1 or degC m2 kg-1] + real :: Dml ! Mixed layer depth [H ~> m or kg m-2] + real :: zi, zc, zm ! Depths in thickness units [H ~> m or kg m-2]. real :: f ! The local Coriolis parameter [T-1 ~> s-1] - real :: Ty ! The meridional temperature gradient [degC L-1 ~> degC m-1] - real :: hAtU ! Interpolated layer thickness [Z ~> m]. + real :: I_f ! The Adcroft reciprocal of the local Coriolis parameter [T ~> s] + real :: Ty ! The meridional temperature gradient [C L-1 ~> degC m-1] + real :: hAtU ! Interpolated layer thickness in height units [H ~> m or kg m-2]. + real :: u_int ! The zonal velocity at an interface [L T-1 ~> m s-1] + real :: max_depth ! Maximum depth of the model bathymetry [H ~> m or kg m-2] integer :: i, j, k, is, ie, js, je, nz character(len=40) :: verticalCoordinate @@ -186,40 +233,86 @@ subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, US, param_file, just call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & - units='C', default=0.0, do_not_log=just_read) - call get_param(param_file, mdl, "DRHO_DT", dRho_dT, default=-0.2, scale=US%kg_m3_to_R, do_not_log=.true.) + units="degC", default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & + default=35.0, units="ppt", scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "T_REF", T_ref, 'Reference temperature', & + units="degC", scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=.true.) + call get_param(param_file, mdl, "RHO_T0_S0", Rho_T0_S0, & + units="kg m-3", default=1000.0, scale=US%kg_m3_to_R, do_not_log=.true.) + call get_param(param_file, mdl, "DRHO_DT", dRho_dT, & + units="kg m-3 degC-1", default=-0.2, scale=US%kg_m3_to_R*US%C_to_degC, do_not_log=.true.) + call get_param(param_file, mdl, "DRHO_DS", dRho_dS, & + units="kg m-3 ppt-1", default=0.8, scale=US%kg_m3_to_R*US%S_to_ppt, do_not_log=.true.) + call get_param(param_file, mdl, "MAXIMUM_DEPTH", max_depth, & + units="m", default=-1.e9, scale=GV%m_to_H, do_not_log=.true.) if (just_read) return ! All run-time parameters have been read, so return. + if (max_depth <= 0.0) call MOM_error(FATAL, & + "Rossby_front_initialize_thickness, Rossby_front_initialize_velocity: "//& + "This module requires a positive value of MAXIMUM_DEPTH.") + if (G%grid_unit_to_L <= 0.) call MOM_error(FATAL, 'Rossby_front_2d_initialization.F90: '// & + "dTdy() is only set to work with Cartesian axis units.") + v(:,:,:) = 0.0 u(:,:,:) = 0.0 - do j = G%jsc,G%jec ; do I = G%isc-1,G%iec+1 - f = 0.5* (G%CoriolisBu(I,j) + G%CoriolisBu(I,j-1) ) - dUdT = 0.0 ; if (abs(f) > 0.0) & - dUdT = ( GV%g_Earth*dRho_dT ) / ( f * GV%Rho0 ) - Dml = Hml( G, G%geoLatT(i,j) ) - Ty = US%L_to_m*dTdy( G, T_range, G%geoLatT(i,j) ) - zi = 0. - do k = 1, nz - hAtU = 0.5*(h(i,j,k)+h(i+1,j,k)) * GV%H_to_Z - zi = zi - hAtU ! Bottom interface position - zc = zi - 0.5*hAtU ! Position of middle of cell - zm = max( zc + Dml, 0. ) ! Height above bottom of mixed layer - u(I,j,k) = dUdT * Ty * zm ! Thermal wind starting at base of ML - enddo - enddo ; enddo - + if (GV%Boussinesq) then + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec+1 + f = 0.5* (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1) ) + dUdT = 0.0 ; if (abs(f) > 0.0) & + dUdT = ( GV%H_to_Z*GV%g_Earth*dRho_dT ) / ( f * GV%Rho0 ) + Dml = Hml( G, G%geoLatCu(I,j), max_depth ) + Ty = dTdy( G, T_range, G%geoLatCu(I,j), US ) + zi = 0. + do k = 1, nz + hAtU = 0.5 * (h(i,j,k) + h(i+1,j,k)) + zi = zi - hAtU ! Bottom interface position + zc = zi - 0.5*hAtU ! Position of middle of cell + zm = max( zc + Dml, 0. ) ! Height above bottom of mixed layer + u(I,j,k) = dUdT * Ty * zm ! Thermal wind starting at base of ML + enddo + enddo ; enddo + else + ! With an equation of state that is linear in density, the nonlinearies in + ! specific volume require that temperature be calculated for each layer. + + dTdz = T_range / max_depth + + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec+1 + f = 0.5* (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1) ) + I_f = 0.0 ; if (abs(f) > 0.0) I_f = 1.0 / f + Dml = Hml( G, G%geoLatCu(I,j), max_depth ) + Ty = dTdy( G, T_range, G%geoLatCu(I,j), US ) + zi = -max_depth + u_int = 0.0 ! The velocity at an interface + ! Work upward in non-Boussinesq mode + do k = nz, 1, -1 + hAtU = 0.5 * (h(i,j,k) + h(i+1,j,k)) + zc = zi + 0.5*hAtU ! Position of middle of cell + T_here = T_ref + dTdz * min(zc, -Dml) ! Linear temperature profile below the mixed layer + dSpV_dT = -dRho_dT / (Rho_T0_S0 + (dRho_dS * S_ref + dRho_dT * T_here) )**2 + dUdT = -( GV%H_to_RZ * GV%g_Earth * dSpV_dT ) * I_f + + ! There is thermal wind shear only within the mixed layer. + u(I,j,k) = u_int + dUdT * Ty * min(max((zi + Dml) + 0.5*hAtU, 0.0), 0.5*hAtU) + u_int = u_int + dUdT * Ty * min(max((zi + Dml) + hAtU, 0.0), hAtU) + + zi = zi + hAtU ! Update the layer top interface position + enddo + enddo ; enddo + endif end subroutine Rossby_front_initialize_velocity !> Pseudo coordinate across domain used by Hml() and dTdy() !! returns a coordinate from -PI/2 .. PI/2 squashed towards the -!! center of the domain. +!! center of the domain [radians]. real function yPseudo( G, lat ) type(ocean_grid_type), intent(in) :: G !< Grid structure - real, intent(in) :: lat !< Latitude + real, intent(in) :: lat !< Latitude in arbitrary units, often [km] ! Local - real :: y, PI + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] PI = 4.0 * atan(1.0) yPseudo = ( ( lat - G%south_lat ) / G%len_lat ) - 0.5 ! -1/2 .. 1/.2 @@ -228,31 +321,34 @@ end function yPseudo !> Analytic prescription of mixed layer depth in 2d Rossby front test, -!! in the same units as G%max_depth -real function Hml( G, lat ) +!! in the same units as max_depth (usually [Z ~> m] or [H ~> m or kg m-2]) +real function Hml( G, lat, max_depth ) type(ocean_grid_type), intent(in) :: G !< Grid structure - real, intent(in) :: lat !< Latitude + real, intent(in) :: lat !< Latitude in arbitrary units, often [km] + real, intent(in) :: max_depth !< The maximum depth of the ocean [Z ~> m] or [H ~> m or kg m-2] ! Local - real :: dHML, HMLmean + real :: dHML, HMLmean ! The range and mean of the mixed layer depths [Z ~> m] or [H ~> m or kg m-2] - dHML = 0.5 * ( HMLmax - HMLmin ) * G%max_depth - HMLmean = 0.5 * ( HMLmin + HMLmax ) * G%max_depth + dHML = 0.5 * ( HMLmax - HMLmin ) * max_depth + HMLmean = 0.5 * ( HMLmin + HMLmax ) * max_depth Hml = HMLmean + dHML * sin( yPseudo(G, lat) ) end function Hml -!> Analytic prescription of mixed layer temperature gradient in 2d Rossby front test -real function dTdy( G, dT, lat ) +!> Analytic prescription of mixed layer temperature gradient in [C L-1 ~> degC m-1] in 2d Rossby front test +real function dTdy( G, dT, lat, US ) type(ocean_grid_type), intent(in) :: G !< Grid structure - real, intent(in) :: dT !< Top to bottom temperature difference - real, intent(in) :: lat !< Latitude + real, intent(in) :: dT !< Top to bottom temperature difference [C ~> degC] + real, intent(in) :: lat !< Latitude in the same units as geoLat, often [km] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local - real :: PI, dHML, dHdy - real :: km = 1.e3 ! AXIS_UNITS = 'k' (1000 m) + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] + real :: dHML ! The range of the mixed layer depths [Z ~> m] + real :: dHdy ! The mixed layer depth gradient [Z L-1 ~> m m-1] PI = 4.0 * atan(1.0) dHML = 0.5 * ( HMLmax - HMLmin ) * G%max_depth - dHdy = dHML * ( PI / ( frontFractionalWidth * G%len_lat * km ) ) * cos( yPseudo(G, lat) ) + dHdy = dHML * ( PI / ( frontFractionalWidth * G%len_lat * G%grid_unit_to_L ) ) * cos( yPseudo(G, lat) ) dTdy = -( dT / G%max_depth ) * dHdy end function dTdy diff --git a/src/user/SCM_CVMix_tests.F90 b/src/user/SCM_CVMix_tests.F90 index 5bbe65b8d8..708c17567a 100644 --- a/src/user/SCM_CVMix_tests.F90 +++ b/src/user/SCM_CVMix_tests.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Initial conditions and forcing for the single column model (SCM) CVMix test set. module SCM_CVMix_tests -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_domains, only : pass_var, pass_vector, TO_ALL use MOM_error_handler, only : MOM_error, FATAL use MOM_file_parser, only : get_param, log_version, param_file_type @@ -38,10 +40,12 @@ module SCM_CVMix_tests logical :: UseDiurnalSW !< True to use diurnal sw radiation real :: tau_x !< (Constant) Wind stress, X [R L Z T-2 ~> Pa] real :: tau_y !< (Constant) Wind stress, Y [R L Z T-2 ~> Pa] - real :: surf_HF !< (Constant) Heat flux [degC Z T-1 ~> m degC s-1] + real :: surf_HF !< (Constant) Heat flux [C Z T-1 ~> m degC s-1] real :: surf_evap !< (Constant) Evaporation rate [Z T-1 ~> m s-1] - real :: Max_sw !< maximum of diurnal sw radiation [degC Z T-1 ~> degC m s-1] + real :: Max_sw !< maximum of diurnal sw radiation [C Z T-1 ~> degC m s-1] real :: Rho0 !< reference density [R ~> kg m-3] + real :: rho_restore !< The density that is used to convert piston velocities + !! into salt or heat fluxes [R ~> kg m-3] end type ! This include declares and sets the variable "version". @@ -55,9 +59,9 @@ module SCM_CVMix_tests subroutine SCM_CVMix_tests_TS_init(T, S, h, G, GV, US, param_file, just_read) type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [ppt] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [Z ~> m] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Input parameter structure logical, intent(in) :: just_read !< If present and true, this call @@ -65,13 +69,13 @@ subroutine SCM_CVMix_tests_TS_init(T, S, h, G, GV, US, param_file, just_read) ! Local variables real :: UpperLayerTempMLD !< Upper layer Temp MLD thickness [Z ~> m]. real :: UpperLayerSaltMLD !< Upper layer Salt MLD thickness [Z ~> m]. - real :: UpperLayerTemp !< Upper layer temperature (SST if thickness 0) [degC] - real :: UpperLayerSalt !< Upper layer salinity (SSS if thickness 0) [ppt] - real :: LowerLayerTemp !< Temp at top of lower layer [degC] - real :: LowerLayerSalt !< Salt at top of lower layer [ppt] - real :: LowerLayerdTdz !< Temp gradient in lower layer [degC Z-1 ~> degC m-1]. - real :: LowerLayerdSdz !< Salt gradient in lower layer [ppt Z-1 ~> ppt m-1]. - real :: LowerLayerMinTemp !< Minimum temperature in lower layer [degC] + real :: UpperLayerTemp !< Upper layer temperature (SST if thickness 0) [C ~> degC] + real :: UpperLayerSalt !< Upper layer salinity (SSS if thickness 0) [S ~> ppt] + real :: LowerLayerTemp !< Temp at top of lower layer [C ~> degC] + real :: LowerLayerSalt !< Salt at top of lower layer [S ~> ppt] + real :: LowerLayerdTdz !< Temp gradient in lower layer [C Z-1 ~> degC m-1]. + real :: LowerLayerdSdz !< Salt gradient in lower layer [S Z-1 ~> ppt m-1]. + real :: LowerLayerMinTemp !< Minimum temperature in lower layer [C ~> degC] real :: zC, DZ, top, bottom ! Depths and thicknesses [Z ~> m]. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz @@ -86,21 +90,21 @@ subroutine SCM_CVMix_tests_TS_init(T, S, h, G, GV, US, param_file, just_read) 'Initial salt mixed layer depth', & units='m', default=0.0, scale=US%m_to_Z, do_not_log=just_read) call get_param(param_file, mdl, "SCM_L1_SALT", UpperLayerSalt, & - 'Layer 2 surface salinity', units='1e-3', default=35.0, do_not_log=just_read) + 'Layer 2 surface salinity', units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "SCM_L1_TEMP", UpperLayerTemp, & - 'Layer 1 surface temperature', units='C', default=20.0, do_not_log=just_read) + 'Layer 1 surface temperature', units="degC", default=20.0, scale=US%degC_to_C, do_not_log=just_read) call get_param(param_file, mdl, "SCM_L2_SALT", LowerLayerSalt, & - 'Layer 2 surface salinity', units='1e-3', default=35.0, do_not_log=just_read) + 'Layer 2 surface salinity', units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "SCM_L2_TEMP", LowerLayerTemp, & - 'Layer 2 surface temperature', units='C', default=20.0, do_not_log=just_read) + 'Layer 2 surface temperature', units="degC", default=20.0, scale=US%degC_to_C, do_not_log=just_read) call get_param(param_file, mdl, "SCM_L2_DTDZ", LowerLayerdTdZ, & 'Initial temperature stratification in layer 2', & - units='C/m', default=0.0, scale=US%Z_to_m, do_not_log=just_read) + units='C/m', default=0.0, scale=US%degC_to_C*US%Z_to_m, do_not_log=just_read) call get_param(param_file, mdl, "SCM_L2_DSDZ", LowerLayerdSdZ, & 'Initial salinity stratification in layer 2', & - units='PPT/m', default=0.0, scale=US%Z_to_m, do_not_log=just_read) + units='PPT/m', default=0.0, scale=US%ppt_to_S*US%Z_to_m, do_not_log=just_read) call get_param(param_file, mdl, "SCM_L2_MINTEMP",LowerLayerMinTemp, & - 'Layer 2 minimum temperature', units='C', default=4.0, do_not_log=just_read) + 'Layer 2 minimum temperature', units="degC", default=4.0, scale=US%degC_to_C, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -108,7 +112,7 @@ subroutine SCM_CVMix_tests_TS_init(T, S, h, G, GV, US, param_file, just_read) top = 0. ! Reference to surface bottom = 0. do k=1,nz - bottom = bottom - h(i,j,k)*GV%H_to_Z ! Interface below layer [Z ~> m] + bottom = bottom - h(i,j,k) ! Interface below layer [Z ~> m] zC = 0.5*( top + bottom ) ! Z of middle of layer [Z ~> m] DZ = min(0., zC + UpperLayerTempMLD) T(i,j,k) = max(LowerLayerMinTemp,LowerLayerTemp + LowerLayerdTdZ * DZ) @@ -143,56 +147,50 @@ subroutine SCM_CVMix_tests_surface_forcing_init(Time, G, param_file, CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "SCM_USE_WIND_STRESS", & - CS%UseWindStress, "Wind Stress switch "// & - "used in the SCM CVMix surface forcing.", & - units='', default=.false.) - call get_param(param_file, mdl, "SCM_USE_HEAT_FLUX", & - CS%UseHeatFlux, "Heat flux switch "// & - "used in the SCM CVMix test surface forcing.", & - units='', default=.false.) - call get_param(param_file, mdl, "SCM_USE_EVAPORATION", & - CS%UseEvaporation, "Evaporation switch "// & - "used in the SCM CVMix test surface forcing.", & - units='', default=.false.) - call get_param(param_file, mdl, "SCM_USE_DIURNAL_SW", & - CS%UseDiurnalSW, "Diurnal sw radation switch "// & - "used in the SCM CVMix test surface forcing.", & - units='', default=.false.) + call get_param(param_file, mdl, "SCM_USE_WIND_STRESS", CS%UseWindStress, & + "Wind Stress switch used in the SCM CVMix surface forcing.", & + default=.false.) + call get_param(param_file, mdl, "SCM_USE_HEAT_FLUX", CS%UseHeatFlux, & + "Heat flux switch used in the SCM CVMix test surface forcing.", & + default=.false.) + call get_param(param_file, mdl, "SCM_USE_EVAPORATION", CS%UseEvaporation, & + "Evaporation switch used in the SCM CVMix test surface forcing.", & + default=.false.) + call get_param(param_file, mdl, "SCM_USE_DIURNAL_SW", CS%UseDiurnalSW, & + "Diurnal sw radation switch used in the SCM CVMix test surface forcing.", & + default=.false.) if (CS%UseWindStress) then - call get_param(param_file, mdl, "SCM_TAU_X", & - CS%tau_x, "Constant X-dir wind stress "// & - "used in the SCM CVMix test surface forcing.", & + call get_param(param_file, mdl, "SCM_TAU_X", CS%tau_x, & + "Constant X-dir wind stress used in the SCM CVMix test surface forcing.", & units='N/m2', scale=US%kg_m2s_to_RZ_T*US%m_s_to_L_T, fail_if_missing=.true.) - call get_param(param_file, mdl, "SCM_TAU_Y", & - CS%tau_y, "Constant y-dir wind stress "// & - "used in the SCM CVMix test surface forcing.", & + call get_param(param_file, mdl, "SCM_TAU_Y", CS%tau_y, & + "Constant y-dir wind stress used in the SCM CVMix test surface forcing.", & units='N/m2', scale=US%kg_m2s_to_RZ_T*US%m_s_to_L_T, fail_if_missing=.true.) endif if (CS%UseHeatFlux) then - call get_param(param_file, mdl, "SCM_HEAT_FLUX", & - CS%surf_HF, "Constant surface heat flux "// & - "used in the SCM CVMix test surface forcing.", & - units='m K/s', scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) + call get_param(param_file, mdl, "SCM_HEAT_FLUX", CS%surf_HF, & + "Constant surface heat flux used in the SCM CVMix test surface forcing.", & + units='m K/s', scale=US%m_to_Z*US%degC_to_C*US%T_to_s, fail_if_missing=.true.) endif if (CS%UseEvaporation) then - call get_param(param_file, mdl, "SCM_EVAPORATION", & - CS%surf_evap, "Constant surface evaporation "// & - "used in the SCM CVMix test surface forcing.", & + call get_param(param_file, mdl, "SCM_EVAPORATION", CS%surf_evap, & + "Constant surface evaporation used in the SCM CVMix test surface forcing.", & units='m/s', scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) endif if (CS%UseDiurnalSW) then - call get_param(param_file, mdl, "SCM_DIURNAL_SW_MAX", & - CS%Max_sw, "Maximum diurnal sw radiation "// & - "used in the SCM CVMix test surface forcing.", & - units='m K/s', scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) + call get_param(param_file, mdl, "SCM_DIURNAL_SW_MAX", CS%Max_sw, & + "Maximum diurnal sw radiation used in the SCM CVMix test surface forcing.", & + units='m K/s', scale=US%m_to_Z*US%degC_to_C*US%T_to_s, fail_if_missing=.true.) endif call get_param(param_file, mdl, "RHO_0", CS%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& + "properties, or with BOUSSINESQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", CS%rho_restore, & + "The density that is used to convert piston velocities into salt or heat fluxes.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R) end subroutine SCM_CVMix_tests_surface_forcing_init @@ -206,7 +204,7 @@ subroutine SCM_CVMix_tests_wind_forcing(sfc_state, forces, day, G, US, CS) ! Local variables integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - real :: mag_tau + real :: mag_tau ! The magnitude of the wind stress [R Z2 T-2 ~> Pa] ! Bounds for loops and memory allocation is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -221,9 +219,13 @@ subroutine SCM_CVMix_tests_wind_forcing(sfc_state, forces, day, G, US, CS) enddo ; enddo call pass_vector(forces%taux, forces%tauy, G%Domain, To_All) - mag_tau = sqrt(CS%tau_x*CS%tau_x + CS%tau_y*CS%tau_y) + mag_tau = US%L_to_Z * sqrt((CS%tau_x*CS%tau_x) + (CS%tau_y*CS%tau_y)) if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt( US%L_to_Z * mag_tau / (CS%Rho0) ) + forces%ustar(i,j) = sqrt( mag_tau / CS%Rho0 ) + enddo ; enddo ; endif + + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = mag_tau enddo ; enddo ; endif end subroutine SCM_CVMix_tests_wind_forcing @@ -240,7 +242,7 @@ subroutine SCM_CVMix_tests_buoyancy_forcing(sfc_state, fluxes, day, G, US, CS) ! Local variables integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - real :: PI + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] PI = 4.0*atan(1.0) @@ -251,29 +253,30 @@ subroutine SCM_CVMix_tests_buoyancy_forcing(sfc_state, fluxes, day, G, US, CS) IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB if (CS%UseHeatFlux) then - ! Note CVMix test inputs give Heat flux in [m K/s] - ! therefore must convert to W/m2 by multiplying + ! Note CVMix test inputs give Heat flux in [Z C T-1 ~> m K s-1] + ! therefore must convert to [Q R Z T-1 ~> W m-2] by multiplying ! by Rho0*Cp do J=Jsq,Jeq ; do i=is,ie - fluxes%sens(i,J) = CS%surf_HF * CS%Rho0 * fluxes%C_p + fluxes%sens(i,J) = CS%surf_HF * CS%rho_restore * fluxes%C_p enddo ; enddo endif if (CS%UseEvaporation) then do J=Jsq,Jeq ; do i=is,ie - ! Note CVMix test inputs give evaporation in [m s-1] + ! Note CVMix test inputs give evaporation in [Z T-1 ~> m s-1] ! This therefore must be converted to mass flux in [R Z T-1 ~> kg m-2 s-1] ! by multiplying by density and some unit conversion factors. - fluxes%evap(i,J) = CS%surf_evap * CS%Rho0 + fluxes%evap(i,J) = CS%surf_evap * CS%rho_restore enddo ; enddo endif if (CS%UseDiurnalSW) then do J=Jsq,Jeq ; do i=is,ie - ! Note CVMix test inputs give max sw rad in [m degC/s] - ! therefore must convert to W/m2 by multiplying by Rho0*Cp + ! Note CVMix test inputs give max sw rad in [Z C T-1 ~> m degC s-1] + ! therefore must convert to [Q R Z T-1 ~> W m-2] by multiplying by Rho0*Cp ! Note diurnal cycle peaks at Noon. - fluxes%sw(i,J) = CS%Max_sw * max(0.0, cos(2*PI*(time_type_to_real(DAY)/86400.0 - 0.5))) * CS%RHO0 * fluxes%C_p + fluxes%sw(i,J) = CS%Max_sw * max(0.0, cos(2*PI*(time_type_to_real(DAY)/86400.0 - 0.5))) * & + CS%rho_restore * fluxes%C_p enddo ; enddo endif diff --git a/src/user/adjustment_initialization.F90 b/src/user/adjustment_initialization.F90 index 934536d1f8..246384bf38 100644 --- a/src/user/adjustment_initialization.F90 +++ b/src/user/adjustment_initialization.F90 @@ -1,19 +1,20 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Configures the model for the geostrophic adjustment test case. module adjustment_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_get_input, only : directories -use MOM_grid, only : ocean_grid_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type -use regrid_consts, only : coordinateMode, DEFAULT_COORDINATE_MODE -use regrid_consts, only : REGRIDDING_LAYER, REGRIDDING_ZSTAR -use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use regrid_consts, only : coordinateMode, DEFAULT_COORDINATE_MODE +use regrid_consts, only : REGRIDDING_LAYER, REGRIDDING_ZSTAR +use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA implicit none ; private @@ -37,7 +38,7 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, intent(in) :: just_read !< If true, this call will only read @@ -47,14 +48,23 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read ! negative because it is positive upward. real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface ! positive upward, in depth units [Z ~> m]. - real :: dRho_dS ! The partial derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. - ! In this subroutine it is hard coded at 1.0 kg m-3 ppt-1. - real :: x, y, yy - real :: delta_S_strat, dSdz, delta_S, S_ref - real :: min_thickness, adjustment_width, adjustment_delta - real :: adjustment_deltaS - real :: front_wave_amp, front_wave_length, front_wave_asym - real :: target_values(SZK_(GV)+1) ! Target densities or density anomalies [R ~> kg m-3] + real :: dRho_dS ! The partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. + ! In this subroutine it is hard coded at 1.0 kg m-3 ppt-1. + real :: x, y, yy ! Fractional positions in the x- and y-directions [nondim] + real :: y_lat ! y-positions in the units of latitude [m] or [km] or [degrees] + real :: S_ref ! Reference salinity within surface layer [S ~> ppt] + real :: S_range ! Range of salinities in the vertical [S ~> ppt] + real :: dSdz ! Vertical salinity gradient [S Z-1 ~> ppt m-1] + real :: delta_S ! The local salinity perturbation [S ~> ppt] + real :: delta_S_strat ! Top-to-bottom salinity difference of stratification [S ~> ppt] + real :: min_thickness ! The minimum layer thickness [Z ~> m] + real :: adjustment_delta ! Interface height anomalies, positive downward [Z ~> m] + real :: adjustment_width ! Width of the frontal zone [m] or [km] or [degrees] + real :: adjustment_deltaS ! Salinity difference across front [S ~> ppt] + real :: front_wave_amp ! Amplitude of trans-frontal wave perturbation [m] or [km] or [degrees] + real :: front_wave_length ! Wave-length of trans-frontal wave perturbation [m] or [km] or [degrees] + real :: front_wave_asym ! Amplitude of frontal asymmetric perturbation [m] or [km] or [degrees] + real :: target_values(SZK_(GV)+1) ! Target densities or density anomalies [R ~> kg m-3] character(len=20) :: verticalCoordinate ! This include declares and sets the variable "version". # include "version_variable.h" @@ -63,36 +73,39 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not.just_read) & - call MOM_mesg("initialize_thickness_uniform: setting thickness") + call MOM_mesg("adjustment_initialize_thickness: setting thickness") ! Parameters used by main model initialization if (.not.just_read) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & - default=35.0, units='1e-3', do_not_log=just_read) - call get_param(param_file, mdl,"MIN_THICKNESS",min_thickness,'Minimum layer thickness', & + default=35.0, units='ppt', scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "MIN_THICKNESS", min_thickness, 'Minimum layer thickness', & default=1.0e-3, units='m', scale=US%m_to_Z, do_not_log=just_read) + call get_param(param_file, mdl, "DRHO_DS", dRho_dS, & + "The partial derivative of density with salinity with a linear equation of state.", & + units="kg m-3 ppt-1", default=0.8, scale=US%kg_m3_to_R*US%S_to_ppt) ! Parameters specific to this experiment configuration - call get_param(param_file, mdl,"REGRIDDING_COORDINATE_MODE",verticalCoordinate, & + call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) - call get_param(param_file, mdl,"ADJUSTMENT_WIDTH",adjustment_width, & + call get_param(param_file, mdl, "ADJUSTMENT_WIDTH", adjustment_width, & "Width of frontal zone", & - units="same as x,y", fail_if_missing=.not.just_read, do_not_log=just_read) - call get_param(param_file, mdl,"DELTA_S_STRAT",delta_S_strat, & + units=G%x_ax_unit_short, fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "DELTA_S_STRAT", delta_S_strat, & "Top-to-bottom salinity difference of stratification", & - units="1e-3", fail_if_missing=.not.just_read, do_not_log=just_read) - call get_param(param_file, mdl,"ADJUSTMENT_DELTAS",adjustment_deltaS, & + units="ppt", scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "ADJUSTMENT_DELTAS", adjustment_deltaS, & "Salinity difference across front", & - units="1e-3", fail_if_missing=.not.just_read, do_not_log=just_read) - call get_param(param_file, mdl,"FRONT_WAVE_AMP",front_wave_amp, & + units="ppt", scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "FRONT_WAVE_AMP", front_wave_amp, & "Amplitude of trans-frontal wave perturbation", & - units="same as x,y", default=0., do_not_log=just_read) - call get_param(param_file, mdl,"FRONT_WAVE_LENGTH",front_wave_length, & + units=G%x_ax_unit_short, default=0., do_not_log=just_read) + call get_param(param_file, mdl, "FRONT_WAVE_LENGTH", front_wave_length, & "Wave-length of trans-frontal wave perturbation", & - units="same as x,y", default=0., do_not_log=just_read) - call get_param(param_file, mdl,"FRONT_WAVE_ASYM",front_wave_asym, & + units=G%x_ax_unit_short, default=0., do_not_log=just_read) + call get_param(param_file, mdl, "FRONT_WAVE_ASYM", front_wave_asym, & "Amplitude of frontal asymmetric perturbation", & - units="same as x,y", default=0., do_not_log=just_read) + units=G%x_ax_unit_short, default=0., do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -109,7 +122,6 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read select case ( coordinateMode(verticalCoordinate) ) case ( REGRIDDING_LAYER, REGRIDDING_RHO ) - dRho_dS = 1.0 * US%kg_m3_to_R if (delta_S_strat /= 0.) then ! This was previously coded ambiguously. adjustment_delta = (adjustment_deltaS / delta_S_strat) * G%max_depth @@ -132,19 +144,19 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read do k = 2,nz target_values(k) = target_values(k-1) + ( GV%Rlay(nz) - GV%Rlay(1) ) / (nz-1) enddo - target_values(:) = target_values(:) - 1000.*US%kg_m3_to_R + target_values(:) = target_values(:) - 1000.0*US%kg_m3_to_R do j=js,je ; do i=is,ie if (front_wave_length /= 0.) then y = ( 0.125 + G%geoLatT(i,j) / front_wave_length ) * ( 4. * acos(0.) ) yy = 2. * ( G%geoLatT(i,j) - 0.5 * G%len_lat ) / adjustment_width - yy = min(1.0, yy); yy = max(-1.0, yy) + yy = min(1.0, yy) ; yy = max(-1.0, yy) yy = yy * 2. * acos( 0. ) - y = front_wave_amp*sin(y) + front_wave_asym*sin(yy) + y_lat = front_wave_amp*sin(y) + front_wave_asym*sin(yy) else - y = 0. + y_lat = 0. endif - x = ( ( G%geoLonT(i,j) - 0.5 * G%len_lon ) + y ) / adjustment_width - x = min(1.0, x); x = max(-1.0, x) + x = ( ( G%geoLonT(i,j) - 0.5 * G%len_lon ) + y_lat ) / adjustment_width + x = min(1.0, x) ; x = max(-1.0, x) x = x * acos( 0. ) delta_S = adjustment_deltaS * 0.5 * (1. - sin( x ) ) do k=2,nz @@ -156,16 +168,16 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read eta1D(k) = max( eta1D(k), -G%max_depth ) eta1D(k) = min( eta1D(k), 0. ) enddo - eta1D(1) = 0.; eta1D(nz+1) = -G%max_depth + eta1D(1) = 0. ; eta1D(nz+1) = -G%max_depth do k=nz,1,-1 if (eta1D(k) > 0.) then eta1D(k) = max( eta1D(k+1) + min_thickness, 0. ) - h(i,j,k) = GV%Z_to_H * max( eta1D(k) - eta1D(k+1), min_thickness ) + h(i,j,k) = max( eta1D(k) - eta1D(k+1), min_thickness ) elseif (eta1D(k) <= (eta1D(k+1) + min_thickness)) then eta1D(k) = eta1D(k+1) + min_thickness - h(i,j,k) = GV%Z_to_H * min_thickness + h(i,j,k) = min_thickness else - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + h(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo enddo ; enddo @@ -177,12 +189,12 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read enddo do j=js,je ; do i=is,ie do k=nz,1,-1 - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + h(i,j,k) = eta1D(k) - eta1D(k+1) enddo enddo ; enddo case default - call MOM_error(FATAL,"adjustment_initialize_thickness: "// & + call MOM_error(FATAL, "adjustment_initialize_thickness: "// & "Unrecognized i.c. setup - set ADJUSTMENT_IC") end select @@ -190,58 +202,67 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read end subroutine adjustment_initialize_thickness !> Initialization of temperature and salinity in the adjustment test case -subroutine adjustment_initialize_temperature_salinity(T, S, h, depth_tot, G, GV, param_file, just_read) +subroutine adjustment_initialize_temperature_salinity(T, S, h, depth_tot, G, GV, US, param_file, just_read) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< The temperature that is being initialized. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< The salinity that is being initialized. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< The model thicknesses [H ~> m or kg m-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: T !< The temperature that is being initialized [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: S !< The salinity that is being initialized [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< The model thicknesses [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & - intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] - type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to - !! parse for model parameter values. - logical, intent(in) :: just_read !< If true, this call will only read - !! parameters without changing T & S. - - integer :: i, j, k, is, ie, js, je, nz - real :: x, y, yy - integer :: index_bay_z - real :: S_ref, T_ref ! Reference salinity and temerature within - ! surface layer - real :: S_range, T_range ! Range of salinities and temperatures over the - ! vertical - real :: xi0, xi1, dSdz, delta_S, delta_S_strat - real :: adjustment_width, adjustment_deltaS - real :: front_wave_amp, front_wave_length, front_wave_asym - real :: eta1d(SZK_(GV)+1) + intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to + !! parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing T & S. + + real :: x, y, yy ! Fractional positions in the x- and y-directions [nondim] + real :: y_lat ! y-position in the units of latitude [m] or [km] or [degrees] + real :: S_ref ! Reference salinity within surface layer [S ~> ppt] + real :: T_ref ! Reference temperature within surface layer [C ~> degC] + real :: S_range ! Range of salinities in the vertical [S ~> ppt] + real :: T_range ! Range of temperatures in the vertical [C ~> degC] + real :: dSdz ! Vertical salinity gradient [S Z-1 ~> ppt m-1] + real :: delta_S ! The local salinity perturbation [S ~> ppt] + real :: delta_S_strat ! Top-to-bottom salinity difference of stratification [S ~> ppt] + real :: adjustment_width ! Width of the frontal zone [m] or [km] or [degrees] + real :: adjustment_deltaS ! Salinity difference across front [S ~> ppt] + real :: front_wave_amp ! Amplitude of trans-frontal wave perturbation [m] or [km] or [degrees] + real :: front_wave_length ! Wave-length of trans-frontal wave perturbation [m] or [km] or [degrees] + real :: front_wave_asym ! Amplitude of frontal asymmetric perturbation [m] or [km] or [degrees] + real :: eta1d(SZK_(GV)+1) ! Interface heights [Z ~> m] character(len=20) :: verticalCoordinate + integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke ! Parameters used by main model initialization call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & - default=35.0, units='1e-3', do_not_log=just_read) - call get_param(param_file, mdl,"T_REF",T_ref,'Reference temperature', units='C', & - fail_if_missing=.not.just_read, do_not_log=just_read) - call get_param(param_file, mdl,"S_RANGE",S_range,'Initial salinity range', units='1e-3', & - default=2.0, do_not_log=just_read) - call get_param(param_file, mdl,"T_RANGE",T_range,'Initial temperature range', units='C', & - default=0.0, do_not_log=just_read) + default=35.0, units="ppt", scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "T_REF", T_ref, 'Reference temperature', & + units="degC", scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "S_RANGE", S_range, 'Initial salinity range', & + default=2.0, units="ppt", scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & + default=1.0, units='degC', scale=US%degC_to_C, do_not_log=just_read) ! Parameters specific to this experiment configuration BUT logged in previous s/r - call get_param(param_file, mdl,"REGRIDDING_COORDINATE_MODE",verticalCoordinate, & + call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) - call get_param(param_file, mdl,"ADJUSTMENT_WIDTH", adjustment_width, & - fail_if_missing=.not.just_read, do_not_log=.true.) - call get_param(param_file, mdl,"ADJUSTMENT_DELTAS", adjustment_deltaS, & - fail_if_missing=.not.just_read, do_not_log=.true.) - call get_param(param_file, mdl,"DELTA_S_STRAT", delta_S_strat, & - fail_if_missing=.not.just_read, do_not_log=.true.) - call get_param(param_file, mdl,"FRONT_WAVE_AMP", front_wave_amp, default=0., & - do_not_log=.true.) - call get_param(param_file, mdl,"FRONT_WAVE_LENGTH",front_wave_length, & - default=0., do_not_log=.true.) - call get_param(param_file, mdl,"FRONT_WAVE_ASYM", front_wave_asym, default=0., & - do_not_log=.true.) + call get_param(param_file, mdl, "ADJUSTMENT_WIDTH", adjustment_width, & + units=G%x_ax_unit_short, fail_if_missing=.not.just_read, do_not_log=.true.) + call get_param(param_file, mdl, "ADJUSTMENT_DELTAS", adjustment_deltaS, & + units="ppt", scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=.true.) + call get_param(param_file, mdl, "DELTA_S_STRAT", delta_S_strat, & + units="ppt", scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=.true.) + call get_param(param_file, mdl, "FRONT_WAVE_AMP", front_wave_amp, & + units=G%x_ax_unit_short, default=0., do_not_log=.true.) + call get_param(param_file, mdl, "FRONT_WAVE_LENGTH", front_wave_length, & + units=G%x_ax_unit_short, default=0., do_not_log=.true.) + call get_param(param_file, mdl, "FRONT_WAVE_ASYM", front_wave_asym, & + units=G%x_ax_unit_short, default=0., do_not_log=.true.) if (just_read) return ! All run-time parameters have been read, so return. @@ -256,28 +277,28 @@ subroutine adjustment_initialize_temperature_salinity(T, S, h, depth_tot, G, GV, do j=js,je ; do i=is,ie eta1d(nz+1) = -depth_tot(i,j) do k=nz,1,-1 - eta1d(k) = eta1d(k+1) + h(i,j,k)*GV%H_to_Z + eta1d(k) = eta1d(k+1) + h(i,j,k) enddo if (front_wave_length /= 0.) then y = ( 0.125 + G%geoLatT(i,j) / front_wave_length ) * ( 4. * acos(0.) ) yy = 2. * ( G%geoLatT(i,j) - 0.5 * G%len_lat ) / front_wave_length - yy = min(1.0, yy); yy = max(-1.0, yy) + yy = min(1.0, yy) ; yy = max(-1.0, yy) yy = yy * 2. * acos( 0. ) - y = front_wave_amp*sin(y) + front_wave_asym*sin(yy) + y_lat = front_wave_amp*sin(y) + front_wave_asym*sin(yy) else - y = 0. + y_lat = 0. endif - x = ( ( G%geoLonT(i,j) - 0.5 * G%len_lon ) + y ) / adjustment_width - x = min(1.0, x); x = max(-1.0, x) + x = ( ( G%geoLonT(i,j) - 0.5 * G%len_lon ) + y_lat ) / adjustment_width + x = min(1.0, x) ; x = max(-1.0, x) x = x * acos( 0. ) delta_S = adjustment_deltaS * 0.5 * (1. - sin( x ) ) do k=1,nz S(i,j,k) = S_ref + delta_S + 0.5 * ( eta1D(k)+eta1D(k+1) ) * dSdz x = abs(S(i,j,k) - 0.5*real(nz-1)/real(nz)*S_range)/S_range*real(2*nz) x = 1. - min(1., x) - T(i,j,k) = x + T(i,j,k) = T_range * x enddo - ! x = GV%H_to_Z*sum(T(i,j,:)*h(i,j,:)) + ! x = sum(T(i,j,:)*h(i,j,:)) ! T(i,j,:) = (T(i,j,:) / x) * (G%max_depth*1.5/real(nz)) enddo ; enddo @@ -286,11 +307,11 @@ subroutine adjustment_initialize_temperature_salinity(T, S, h, depth_tot, G, GV, S(:,:,k) = S_ref + S_range * ( (real(k)-0.5) / real( nz ) ) ! x = abs(S(1,1,k) - 0.5*real(nz-1)/real(nz)*S_range)/S_range*real(2*nz) ! x = 1.-min(1., x) - ! T(:,:,k) = x + ! T(:,:,k) = T_range * x enddo case default - call MOM_error(FATAL,"adjustment_initialize_temperature_salinity: "// & + call MOM_error(FATAL, "adjustment_initialize_temperature_salinity: "// & "Unrecognized i.c. setup - set ADJUSTMENT_IC") end select diff --git a/src/user/baroclinic_zone_initialization.F90 b/src/user/baroclinic_zone_initialization.F90 index a214012541..f50c103583 100644 --- a/src/user/baroclinic_zone_initialization.F90 +++ b/src/user/baroclinic_zone_initialization.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Initial conditions for an idealized baroclinic zone module baroclinic_zone_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_file_parser, only : openParameterBlock, closeParameterBlock use MOM_grid, only : ocean_grid_type @@ -33,39 +35,44 @@ subroutine bcz_params(G, GV, US, param_file, S_ref, dSdz, delta_S, dSdx, T_ref, type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file handle - real, intent(out) :: S_ref !< Reference salinity [ppt] - real, intent(out) :: dSdz !< Salinity stratification [ppt Z-1 ~> ppt m-1] - real, intent(out) :: delta_S !< Salinity difference across baroclinic zone [ppt] - real, intent(out) :: dSdx !< Linear salinity gradient [ppt G%xaxis_units-1] - real, intent(out) :: T_ref !< Reference temperature [degC] - real, intent(out) :: dTdz !< Temperature stratification [degC Z-1 ~> degC m-1] - real, intent(out) :: delta_T !< Temperature difference across baroclinic zone [degC] - real, intent(out) :: dTdx !< Linear temperature gradient in [degC G%x_axis_units-1] - real, intent(out) :: L_zone !< Width of baroclinic zone in [G%x_axis_units] + real, intent(out) :: S_ref !< Reference salinity [S ~> ppt] + real, intent(out) :: dSdz !< Salinity stratification [S Z-1 ~> ppt m-1] + real, intent(out) :: delta_S !< Salinity difference across baroclinic zone [S ~> ppt] + real, intent(out) :: dSdx !< Linear salinity gradient, often in [S km-1 ~> ppt km-1] + !! or [S degrees_E-1 ~> ppt degrees_E-1], depending on + !! the value of G%x_axis_units + real, intent(out) :: T_ref !< Reference temperature [C ~> degC] + real, intent(out) :: dTdz !< Temperature stratification [C Z-1 ~> degC m-1] + real, intent(out) :: delta_T !< Temperature difference across baroclinic zone [C ~> degC] + real, intent(out) :: dTdx !< Linear temperature gradient, often in [C km-1 ~> degC km-1] + !! or [C degrees_E-1 ~> degC degrees_E-1], depending on + !! the value of G%x_axis_units + real, intent(out) :: L_zone !< Width of baroclinic zone, often in [km] or [degrees_N], + !! depending on the value of G%y_axis_units logical, intent(in) :: just_read !< If true, this call will !! only read parameters without changing h. if (.not.just_read) & call log_version(param_file, mdl, version, 'Initialization of an analytic baroclinic zone') call openParameterBlock(param_file,'BCZIC') - call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', units='ppt', & - default=35., do_not_log=just_read) + call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & + units='ppt', default=35., scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "DSDZ", dSdz, 'Salinity stratification', & - units='ppt/m', default=0.0, scale=US%Z_to_m, do_not_log=just_read) - call get_param(param_file, mdl,"DELTA_S",delta_S,'Salinity difference across baroclinic zone', & - units='ppt', default=0.0, do_not_log=just_read) - call get_param(param_file, mdl,"DSDX",dSdx,'Meridional salinity difference', & - units='ppt/'//trim(G%x_axis_units), default=0.0, do_not_log=just_read) - call get_param(param_file, mdl,"T_REF",T_ref,'Reference temperature',units='C', & - default=10., do_not_log=just_read) + units='ppt m-1', default=0.0, scale=US%ppt_to_S*US%Z_to_m, do_not_log=just_read) + call get_param(param_file, mdl, "DELTA_S",delta_S, 'Salinity difference across baroclinic zone', & + units='ppt', default=0.0, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "DSDX", dSdx,'Meridional salinity difference', & + units='ppt '//trim(G%x_ax_unit_short)//'-1', default=0.0, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "T_REF", T_ref, 'Reference temperature', & + units='degC', default=10., scale=US%degC_to_C, do_not_log=just_read) call get_param(param_file, mdl, "DTDZ", dTdz, 'Temperature stratification', & - units='C/m', default=0.0, scale=US%Z_to_m, do_not_log=just_read) - call get_param(param_file, mdl,"DELTA_T",delta_T,'Temperature difference across baroclinic zone', & - units='C', default=0.0, do_not_log=just_read) - call get_param(param_file, mdl,"DTDX",dTdx,'Meridional temperature difference', & - units='C/'//trim(G%x_axis_units), default=0.0, do_not_log=just_read) - call get_param(param_file, mdl,"L_ZONE",L_zone,'Width of baroclinic zone', & - units=G%x_axis_units, default=0.5*G%len_lat, do_not_log=just_read) + units='degC m-1', default=0.0, scale=US%degC_to_C*US%Z_to_m, do_not_log=just_read) + call get_param(param_file, mdl, "DELTA_T", delta_T,'Temperature difference across baroclinic zone', & + units='degC', default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "DTDX", dTdx,'Meridional temperature difference', & + units='degC '//trim(G%x_ax_unit_short)//'-1', default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "L_ZONE", L_zone, 'Width of baroclinic zone', & + units=G%y_ax_unit_short, default=0.5*G%len_lat, do_not_log=just_read) call closeParameterBlock(param_file) end subroutine bcz_params @@ -77,11 +84,11 @@ subroutine baroclinic_zone_init_temperature_salinity(T, S, h, depth_tot, G, GV, type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: T !< Potential temperature [degC] + intent(out) :: T !< Potential temperature [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: S !< Salinity [ppt] + intent(out) :: S !< Salinity [S ~> ppt] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< The model thicknesses [H ~> m or kg m-2] + intent(in) :: h !< The model thicknesses [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file @@ -90,12 +97,20 @@ subroutine baroclinic_zone_init_temperature_salinity(T, S, h, depth_tot, G, GV, !! parameters without changing T & S. integer :: i, j, k, is, ie, js, je, nz - real :: T_ref, dTdz, dTdx, delta_T ! Parameters describing temperature distribution - real :: S_ref, dSdz, dSdx, delta_S ! Parameters describing salinity distribution - real :: L_zone ! Width of baroclinic zone in [G%axis_units] - real :: zc, zi ! Depths in depth units [Z ~> m] - real :: x, xd, xs, y, yd, fn - real :: PI ! 3.1415926... calculated as 4*atan(1) + real :: T_ref, delta_T ! Parameters describing temperature distribution [C ~> degC] + real :: dTdz ! Vertical temperature gradients [C Z-1 ~> degC m-1] + real :: dTdx ! Zonal temperature gradients [C axis_units-1 ~> degC axis_units-1] + real :: S_ref, delta_S ! Parameters describing salinity distribution [S ~> ppt] + real :: dSdz ! Vertical salinity gradients [S Z-1 ~> ppt m-1] + real :: dSdx ! Zonal salinity gradients [S axis_units-1 ~> ppt axis_units-1] + real :: L_zone ! Width of baroclinic zone, often in [km] or [degrees_N], depending + ! on the value of G%y_axis_units + real :: zc, zi ! Depths in depth units [Z ~> m] + real :: x ! X-position relative to the domain center [degrees_E] or [km] or [m] + real :: y ! Y-position relative to the domain center [degrees_N] or [km] or [m] + real :: fn ! A smooth function based on the position in the baroclinic zone [nondim] + real :: xs, xd, yd ! Fractional x- and y-positions relative to the domain extent [nondim] + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -122,8 +137,8 @@ subroutine baroclinic_zone_init_temperature_salinity(T, S, h, depth_tot, G, GV, fn = xs endif do k = nz, 1, -1 - zc = zi + 0.5*h(i,j,k)*GV%H_to_Z ! Position of middle of cell - zi = zi + h(i,j,k)*GV%H_to_Z ! Top interface position + zc = zi + 0.5*h(i,j,k) ! Position of middle of cell + zi = zi + h(i,j,k) ! Top interface position T(i,j,k) = T_ref + dTdz * zc & ! Linear temperature stratification + dTdx * x & ! Linear gradient + delta_T * fn ! Smooth fn of width L_zone diff --git a/src/user/basin_builder.F90 b/src/user/basin_builder.F90 index c9cdbfa392..67afd0e6ba 100644 --- a/src/user/basin_builder.F90 +++ b/src/user/basin_builder.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> An idealized topography building system module basin_builder -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type @@ -27,14 +29,14 @@ module basin_builder subroutine basin_builder_topography(D, G, param_file, max_depth) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth in the units of depth_max + intent(out) :: D !< Ocean bottom depth in the units of depth_max [A] type(param_file_type), intent(in) :: param_file !< Parameter file structure - real, intent(in) :: max_depth !< Maximum ocean depth in arbitrary units + real, intent(in) :: max_depth !< Maximum ocean depth in arbitrary units [A] ! Local variables character(len=17) :: pname1, pname2 ! For construction of parameter names character(len=20) :: funcs ! Basin build function - real, dimension(20) :: pars ! Parameters for each function - real :: lon ! Longitude [degrees_E} + real, dimension(20) :: pars ! Parameters for each function [various] + real :: lon ! Longitude [degrees_E] real :: lat ! Latitude [degrees_N] integer :: i, j, n, n_funcs @@ -157,73 +159,72 @@ subroutine basin_builder_topography(D, G, param_file, max_depth) end subroutine basin_builder_topography !> Returns the value of a triangular function centered at x=x0 with value 1 -!! and linearly decreasing to 0 at x=x0+/-L, and 0 otherwise. +!! and linearly decreasing to 0 at x=x0+/-L, and 0 otherwise [nondim]. !! If clip is present the top of the cone is cut off at "clip", which !! effectively defaults to 1. real function cone(x, x0, L, clip) - real, intent(in) :: x !< non-dimensional coordinate [nondim] - real, intent(in) :: x0 !< position of peak [nondim] - real, intent(in) :: L !< half-width of base of cone [nondim] + real, intent(in) :: x !< Coordinate in arbitrary units [A] + real, intent(in) :: x0 !< position of peak in arbitrary units [A] + real, intent(in) :: L !< half-width of base of cone in arbitrary units [A] real, optional, intent(in) :: clip !< clipping height of cone [nondim] cone = max( 0., 1. - abs(x - x0) / L ) if (present(clip)) cone = min(clip, cone) end function cone -!> Returns an s-curve s(x) s.t. s(x0)<=0, s(x0+L)>=1 and cubic in between. +!> Returns an s-curve s(x) s.t. s(x0)<=0, s(x0+L)>=1 and cubic in between [nondim]. real function scurve(x, x0, L) - real, intent(in) :: x !< non-dimensional coordinate [nondim] - real, intent(in) :: x0 !< position of peak [nondim] - real, intent(in) :: L !< half-width of base of cone [nondim] - real :: s + real, intent(in) :: x !< Coordinate in arbitrary units [A] + real, intent(in) :: x0 !< position of peak in arbitrary units [A] + real, intent(in) :: L !< half-width of base of cone in arbitrary units [A] + real :: s ! A rescaled position [nondim] s = max( 0., min( 1.,( x - x0 ) / L ) ) scurve = ( 3. - 2.*s ) * ( s * s ) end function scurve -!> Returns a "coastal" profile. +!> Returns a "coastal" profile [nondim]. real function cstprof(x, x0, L, lf, bf, sf, sh) - real, intent(in) :: x !< non-dimensional coordinate [nondim] - real, intent(in) :: x0 !< position of peak [nondim] - real, intent(in) :: L !< width of profile [nondim] + real, intent(in) :: x !< Coordinate in arbitrary units [A] + real, intent(in) :: x0 !< position of peak in arbitrary units [A] + real, intent(in) :: L !< width of profile in arbitrary units [A] real, intent(in) :: lf !< fraction of width that is "land" [nondim] real, intent(in) :: bf !< fraction of width that is "beach" [nondim] real, intent(in) :: sf !< fraction of width that is "continental slope" [nondim] real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] - real :: s + real :: s ! A rescaled position [nondim] s = max( 0., min( 1.,( x - x0 ) / L ) ) cstprof = sh * scurve(s-lf,0.,bf) + (1.-sh) * scurve(s - (1.-sf),0.,sf) end function cstprof -!> Distance between points x,y and a line segment (x0,y0) and (x0,y1). +!> Distance between points x,y and a line segment (x0,y0) and (x0,y1) in arbitrary units [A]. real function dist_line_fixed_x(x, y, x0, y0, y1) - real, intent(in) :: x !< non-dimensional x-coordinate [nondim] - real, intent(in) :: y !< non-dimensional y-coordinate [nondim] - real, intent(in) :: x0 !< x-position of line segment [nondim] - real, intent(in) :: y0 !< y-position of line segment end[nondim] - real, intent(in) :: y1 !< y-position of line segment end[nondim] - real :: dx, yr, dy + real, intent(in) :: x !< X-coordinate in arbitrary units [A] + real, intent(in) :: y !< Y-coordinate in arbitrary units [A] + real, intent(in) :: x0 !< x-position of line segment in arbitrary units [A] + real, intent(in) :: y0 !< y-position of line segment end in arbitrary units [A] + real, intent(in) :: y1 !< y-position of line segment end in arbitrary units [A] + real :: dx, yr, dy ! Relative positions in arbitrary units [A] dx = x - x0 yr = min( max(y0,y1), max( min(y0,y1), y ) ) ! bound y by y0,y1 dy = y - yr ! =0 within y0y1 - dist_line_fixed_x = sqrt( dx*dx + dy*dy ) + dist_line_fixed_x = sqrt( (dx*dx) + (dy*dy) ) end function dist_line_fixed_x -!> Distance between points x,y and a line segment (x0,y0) and (x1,y0). +!> Distance between points x,y and a line segment (x0,y0) and (x1,y0) in arbitrary units [A]. real function dist_line_fixed_y(x, y, x0, x1, y0) - real, intent(in) :: x !< non-dimensional x-coordinate [nondim] - real, intent(in) :: y !< non-dimensional y-coordinate [nondim] - real, intent(in) :: x0 !< x-position of line segment end[nondim] - real, intent(in) :: x1 !< x-position of line segment end[nondim] - real, intent(in) :: y0 !< y-position of line segment [nondim] - real :: dx, yr, dy + real, intent(in) :: x !< X-coordinate in arbitrary units [A] + real, intent(in) :: y !< Y-coordinate in arbitrary units [A] + real, intent(in) :: x0 !< x-position of line segment end in arbitrary units [A] + real, intent(in) :: x1 !< x-position of line segment end in arbitrary units [A] + real, intent(in) :: y0 !< y-position of line segment in arbitrary units [A] dist_line_fixed_y = dist_line_fixed_x(y, x, y0, x0, x1) end function dist_line_fixed_y -!> An "angled coast profile". +!> An "angled coast profile" [nondim]. real function angled_coast(lon, lat, lon_eq, lat_mer, dr, sh) real, intent(in) :: lon !< Longitude [degrees_E] real, intent(in) :: lat !< Latitude [degrees_N] @@ -231,14 +232,15 @@ real function angled_coast(lon, lat, lon_eq, lat_mer, dr, sh) real, intent(in) :: lat_mer !< Latitude intersection with Prime Meridian [degrees_N] real, intent(in) :: dr !< "Radius" of coast profile [degrees] real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] - real :: r + real :: r ! A relative position [degrees] + real :: I_dr ! The inverse of a distance [degrees-1] - r = 1/sqrt( lat_mer*lat_mer + lon_eq*lon_eq ) - r = r * ( lat_mer*lon + lon_eq*lat - lon_eq*lat_mer) + I_dr = 1/sqrt( lat_mer*lat_mer + lon_eq*lon_eq ) + r = I_dr * ( lat_mer*lon + lon_eq*lat - lon_eq*lat_mer) angled_coast = cstprof(r, 0., dr, 0.125, 0.125, 0.5, sh) end function angled_coast -!> A "coast profile" applied in an N-S line from lonC,lat0 to lonC,lat1. +!> A "coast profile" applied in an N-S line from lonC,lat0 to lonC,lat1 [nondim]. real function NS_coast(lon, lat, lonC, lat0, lat1, dlon, sh) real, intent(in) :: lon !< Longitude [degrees_E] real, intent(in) :: lat !< Latitude [degrees_N] @@ -247,13 +249,13 @@ real function NS_coast(lon, lat, lonC, lat0, lat1, dlon, sh) real, intent(in) :: lat1 !< Latitude of coast end [degrees_N] real, intent(in) :: dlon !< "Radius" of coast profile [degrees] real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] - real :: r + real :: r ! A relative position [degrees] r = dist_line_fixed_x( lon, lat, lonC, lat0, lat1 ) NS_coast = cstprof(r, 0., dlon, 0.125, 0.125, 0.5, sh) end function NS_coast -!> A "coast profile" applied in an E-W line from lon0,latC to lon1,latC. +!> A "coast profile" applied in an E-W line from lon0,latC to lon1,latC [nondim]. real function EW_coast(lon, lat, latC, lon0, lon1, dlat, sh) real, intent(in) :: lon !< Longitude [degrees_E] real, intent(in) :: lat !< Latitude [degrees_N] @@ -262,13 +264,13 @@ real function EW_coast(lon, lat, latC, lon0, lon1, dlat, sh) real, intent(in) :: lon1 !< Longitude of coast end [degrees_E] real, intent(in) :: dlat !< "Radius" of coast profile [degrees] real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] - real :: r + real :: r ! A relative position [degrees] r = dist_line_fixed_y( lon, lat, lon0, lon1, latC ) EW_coast = cstprof(r, 0., dlat, 0.125, 0.125, 0.5, sh) end function EW_coast -!> A NS ridge with a cone profile +!> A NS ridge with a cone profile [nondim] real function NS_conic_ridge(lon, lat, lonC, lat0, lat1, dlon, rh) real, intent(in) :: lon !< Longitude [degrees_E] real, intent(in) :: lat !< Latitude [degrees_N] @@ -277,13 +279,13 @@ real function NS_conic_ridge(lon, lat, lonC, lat0, lat1, dlon, rh) real, intent(in) :: lat1 !< Latitude of ridge end [degrees_N] real, intent(in) :: dlon !< "Radius" of ridge profile [degrees] real, intent(in) :: rh !< depth of ridge as fraction of full depth [nondim] - real :: r + real :: r ! A relative position [degrees] r = dist_line_fixed_x( lon, lat, lonC, lat0, lat1 ) NS_conic_ridge = 1. - rh * cone(r, 0., dlon) end function NS_conic_ridge -!> A NS ridge with an scurve profile +!> A NS ridge with an scurve profile [nondim] real function NS_scurve_ridge(lon, lat, lonC, lat0, lat1, dlon, rh) real, intent(in) :: lon !< Longitude [degrees_E] real, intent(in) :: lat !< Latitude [degrees_N] @@ -292,13 +294,13 @@ real function NS_scurve_ridge(lon, lat, lonC, lat0, lat1, dlon, rh) real, intent(in) :: lat1 !< Latitude of ridge end [degrees_N] real, intent(in) :: dlon !< "Radius" of ridge profile [degrees] real, intent(in) :: rh !< depth of ridge as fraction of full depth [nondim] - real :: r + real :: r ! A relative position [degrees] r = dist_line_fixed_x( lon, lat, lonC, lat0, lat1 ) NS_scurve_ridge = 1. - rh * (1. - scurve(r, 0., dlon) ) end function NS_scurve_ridge -!> A circular ridge with cutoff conic profile +!> A circular ridge with cutoff conic profile [nondim] real function circ_conic_ridge(lon, lat, lon0, lat0, ring_radius, ring_thickness, ridge_height) real, intent(in) :: lon !< Longitude [degrees_E] real, intent(in) :: lat !< Latitude [degrees_N] @@ -307,15 +309,16 @@ real function circ_conic_ridge(lon, lat, lon0, lat0, ring_radius, ring_thickness real, intent(in) :: ring_radius !< Radius of ring [degrees] real, intent(in) :: ring_thickness !< Radial thickness of ring [degrees] real, intent(in) :: ridge_height !< Ridge height as fraction of full depth [nondim] - real :: r + real :: r ! A relative position [degrees] + real :: frac_ht ! The fractional height of the topography [nondim] - r = sqrt( (lon - lon0)**2 + (lat - lat0)**2 ) ! Pseudo-distance from a point + r = sqrt( ((lon - lon0)**2) + ((lat - lat0)**2) ) ! Pseudo-distance from a point r = abs( r - ring_radius) ! Pseudo-distance from a circle - r = cone(r, 0., ring_thickness, ridge_height) ! 0 .. frac_ridge_height - circ_conic_ridge = 1. - r ! nondim depths (1-frac_ridge_height) .. 1 + frac_ht = cone(r, 0., ring_thickness, ridge_height) ! 0 .. frac_ridge_height + circ_conic_ridge = 1. - frac_ht ! nondim depths (1-frac_ridge_height) .. 1 end function circ_conic_ridge -!> A circular ridge with cutoff scurve profile +!> A circular ridge with cutoff scurve profile [nondim] real function circ_scurve_ridge(lon, lat, lon0, lat0, ring_radius, ring_thickness, ridge_height) real, intent(in) :: lon !< Longitude [degrees_E] real, intent(in) :: lat !< Latitude [degrees_N] @@ -324,13 +327,15 @@ real function circ_scurve_ridge(lon, lat, lon0, lat0, ring_radius, ring_thicknes real, intent(in) :: ring_radius !< Radius of ring [degrees] real, intent(in) :: ring_thickness !< Radial thickness of ring [degrees] real, intent(in) :: ridge_height !< Ridge height as fraction of full depth [nondim] - real :: r + real :: r ! A relative position [degrees] + real :: s ! A function of the normalized position [nondim] + real :: frac_ht ! The fractional height of the topography [nondim] - r = sqrt( (lon - lon0)**2 + (lat - lat0)**2 ) ! Pseudo-distance from a point + r = sqrt( ((lon - lon0)**2) + ((lat - lat0)**2) ) ! Pseudo-distance from a point r = abs( r - ring_radius) ! Pseudo-distance from a circle - r = 1. - scurve(r, 0., ring_thickness) ! 0 .. 1 - r = r * ridge_height ! 0 .. frac_ridge_height - circ_scurve_ridge = 1. - r ! nondim depths (1-frac_ridge_height) .. 1 + s = 1. - scurve(r, 0., ring_thickness) ! 0 .. 1 + frac_ht = s * ridge_height ! 0 .. frac_ridge_height + circ_scurve_ridge = 1. - frac_ht ! nondim depths (1-frac_ridge_height) .. 1 end function circ_scurve_ridge end module basin_builder diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index d17be912ae..6685c75305 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Initialization for the "bench mark" configuration module benchmark_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe @@ -41,7 +43,7 @@ subroutine benchmark_initialize_topography(D, G, param_file, max_depth, US) ! Local variables real :: min_depth ! The minimum basin depth [Z ~> m] - real :: PI ! 3.1415926... calculated as 4*atan(1) + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] real :: D0 ! A constant to make the maximum basin depth MAXIMUM_DEPTH [Z ~> m] real :: x ! Longitude relative to the domain edge, normalized by its extent [nondim] real :: y ! Latitude relative to the domain edge, normalized by its extent [nondim] @@ -84,7 +86,7 @@ subroutine benchmark_initialize_thickness(h, depth_tot, G, GV, US, param_file, e type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file @@ -101,17 +103,19 @@ subroutine benchmark_initialize_thickness(h, depth_tot, G, GV, US, param_file, e ! in depth units [Z ~> m]. real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface ! positive upward, in depth units [Z ~> m]. - real :: SST ! The initial sea surface temperature [degC]. - real :: T_int ! The initial temperature of an interface [degC]. - real :: ML_depth ! The specified initial mixed layer depth, in depth units [Z ~> m]. + real :: SST ! The initial sea surface temperature [C ~> degC]. + real :: S_ref ! A default value for salinities [S ~> ppt] + real :: T_light ! A first guess at the temperature of the lightest layer [C ~> degC] + real :: T_int ! The initial temperature of an interface [C ~> degC]. + real :: ML_depth ! The specified initial mixed layer depth, in depth units [Z ~> m]. real :: thermocline_scale ! The e-folding scale of the thermocline, in depth units [Z ~> m]. real, dimension(SZK_(GV)) :: & - T0, S0, & ! Profiles of temperature [degC] and salinity [ppt] + T0, S0, & ! Profiles of temperature [C ~> degC] and salinity [S ~> ppt] rho_guess, & ! Potential density at T0 & S0 [R ~> kg m-3]. - drho_dT, & ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1]. - drho_dS ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1]. + drho_dT, & ! Derivative of density with temperature [R C-1 ~> kg m-3 degC-1]. + drho_dS ! Derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. real :: pres(SZK_(GV)) ! Reference pressure [R L2 T-2 ~> Pa]. - real :: a_exp ! The fraction of the overall stratification that is exponential. + real :: a_exp ! The fraction of the overall stratification that is exponential [nondim] real :: I_ts, I_md ! Inverse lengthscales [Z-1 ~> m-1]. real :: T_frac ! A ratio of the interface temperature to the range ! between SST and the bottom temperature [nondim]. @@ -119,7 +123,7 @@ subroutine benchmark_initialize_thickness(h, depth_tot, G, GV, US, param_file, e ! interface temperature for a given z [nondim] real :: derr_dz ! The derivative of the normalized error between the profile's ! temperature and the interface temperature with z [Z-1 ~> m-1] - real :: pi ! 3.1415926... calculated as 4*atan(1) + real :: pi ! 3.1415926... calculated as 4*atan(1) [nondim] real :: z ! A work variable for the interface position [Z ~> m] ! This include declares and sets the variable "version". # include "version_variable.h" @@ -135,6 +139,12 @@ subroutine benchmark_initialize_thickness(h, depth_tot, G, GV, US, param_file, e call get_param(param_file, mdl, "BENCHMARK_THERMOCLINE_SCALE", thermocline_scale, & "Initial thermocline depth scale in the benchmark test case.", & default=500.0, units="m", scale=US%m_to_Z, do_not_log=just_read) + call get_param(param_file, mdl, "BENCHMARK_T_LIGHT", T_light, & + "A first guess at the temperature of the lightest layer in the benchmark test case.", & + units="degC", default=29.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "S_REF", S_ref, & + "The uniform salinities used to initialize the benchmark test case.", & + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) if (just_read) return ! This subroutine has no run-time parameters. @@ -147,9 +157,9 @@ subroutine benchmark_initialize_thickness(h, depth_tot, G, GV, US, param_file, e ! This block calculates T0(k) for the purpose of diagnosing where the ! interfaces will be found. do k=1,nz - pres(k) = P_Ref ; S0(k) = 35.0 + pres(k) = P_Ref ; S0(k) = S_ref enddo - T0(k1) = 29.0 + T0(k1) = T_light call calculate_density(T0(k1), S0(k1), pres(k1), rho_guess(k1), eqn_of_state) call calculate_density_derivs(T0(k1), S0(k1), pres(k1), drho_dT(k1), drho_dS(k1), eqn_of_state) @@ -176,9 +186,9 @@ subroutine benchmark_initialize_thickness(h, depth_tot, G, GV, US, param_file, e do k=1,nz ; e_pert(K) = 0.0 ; enddo - ! This sets the initial thickness (in [H ~> m or kg m-2]) of the layers. The thicknesses + ! This sets the initial thickness (in [Z ~> m]) of the layers. The thicknesses ! are set to insure that: - ! 1. each layer is at least GV%Angstrom_H thick, and + ! 1. each layer is at least GV%Angstrom_Z thick, and ! 2. the interfaces are where they should be based on the resting depths and ! interface height perturbations, as long at this doesn't interfere with 1. eta1D(nz+1) = -depth_tot(i,j) @@ -203,9 +213,9 @@ subroutine benchmark_initialize_thickness(h, depth_tot, G, GV, US, param_file, e if (eta1D(K) < eta1D(K+1) + GV%Angstrom_Z) & eta1D(K) = eta1D(K+1) + GV%Angstrom_Z - h(i,j,k) = max(GV%Z_to_H * (eta1D(K) - eta1D(K+1)), GV%Angstrom_H) + h(i,j,k) = max(eta1D(K) - eta1D(K+1), GV%Angstrom_Z) enddo - h(i,j,1) = max(GV%Z_to_H * (0.0 - eta1D(2)), GV%Angstrom_H) + h(i,j,1) = max(0.0 - eta1D(2), GV%Angstrom_Z) enddo ; enddo @@ -217,9 +227,9 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< The potential temperature - !! that is being initialized [degC] + !! that is being initialized [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< The salinity that is being - !! initialized [ppt] + !! initialized [S ~> ppt] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure indicating the !! open file to parse for @@ -230,28 +240,35 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & logical, intent(in) :: just_read !< If true, this call will only read !! parameters without changing T & S. ! Local variables - real :: T0(SZK_(GV)) ! A profile of temperatures [degC] - real :: S0(SZK_(GV)) ! A profile of salinities [ppt] + real :: T0(SZK_(GV)) ! A profile of temperatures [C ~> degC] + real :: S0(SZK_(GV)) ! A profile of salinities [S ~> ppt] + real :: S_ref ! A default value for salinities [S ~> ppt] + real :: T_light ! A first guess at the temperature of the lightest layer [C ~> degC] real :: pres(SZK_(GV)) ! Reference pressure [R L2 T-2 ~> Pa] - real :: drho_dT(SZK_(GV)) ! Derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] - real :: drho_dS(SZK_(GV)) ! Derivative of density with salinity [R ppt-1 ~> kg m-3 ppt-1] + real :: drho_dT(SZK_(GV)) ! Derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: drho_dS(SZK_(GV)) ! Derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] real :: rho_guess(SZK_(GV)) ! Potential density at T0 & S0 [R ~> kg m-3] - real :: PI ! 3.1415926... calculated as 4*atan(1) - real :: SST ! The initial sea surface temperature [degC] + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] + real :: SST ! The initial sea surface temperature [C ~> degC] character(len=40) :: mdl = "benchmark_init_temperature_salinity" ! This subroutine's name. integer :: i, j, k, k1, is, ie, js, je, nz, itt is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + call get_param(param_file, mdl, "S_REF", S_ref, & + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "BENCHMARK_T_LIGHT", T_light, & + units="degC", default=29.0, scale=US%degC_to_C, do_not_log=.true.) + if (just_read) return ! All run-time parameters have been read, so return. k1 = GV%nk_rho_varies + 1 do k=1,nz - pres(k) = P_Ref ; S0(k) = 35.0 + pres(k) = P_Ref ; S0(k) = S_ref enddo - T0(k1) = 29.0 + T0(k1) = T_light call calculate_density(T0(k1), S0(k1), pres(k1), rho_guess(k1), eqn_of_state) call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, eqn_of_state, (/k1,k1/) ) @@ -269,12 +286,12 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & enddo enddo - do k=1,nz ; do i=is,ie ; do j=js,je + do k=1,nz ; do j=js,je ; do i=is,ie T(i,j,k) = T0(k) S(i,j,k) = S0(k) enddo ; enddo ; enddo PI = 4.0*atan(1.0) - do i=is,ie ; do j=js,je + do j=js,je ; do i=is,ie SST = 0.5*(T0(k1)+T0(nz)) - 0.9*0.5*(T0(k1)-T0(nz)) * & cos(PI*(G%geoLatT(i,j)-G%south_lat)/(G%len_lat)) do k=1,k1-1 diff --git a/src/user/circle_obcs_initialization.F90 b/src/user/circle_obcs_initialization.F90 index 3bfdeaa0ff..26e26d0a44 100644 --- a/src/user/circle_obcs_initialization.F90 +++ b/src/user/circle_obcs_initialization.F90 @@ -1,18 +1,20 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Configures the model for the "circle_obcs" experiment which tests !! Open Boundary Conditions radiating an SSH anomaly. module circle_obcs_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type use MOM_tracer_registry, only : tracer_registry_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type implicit none ; private @@ -28,11 +30,12 @@ module circle_obcs_initialization contains !> This subroutine initializes layer thicknesses for the circle_obcs experiment. -subroutine circle_obcs_initialize_thickness(h, depth_tot, G, GV, param_file, just_read) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. +subroutine circle_obcs_initialize_thickness(h, depth_tot, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file @@ -44,8 +47,13 @@ subroutine circle_obcs_initialize_thickness(h, depth_tot, G, GV, param_file, jus ! negative because it is positive upward. real :: eta1D(SZK_(GV)+1)! Interface height relative to the sea surface ! positive upward, in depth units [Z ~> m]. - real :: IC_amp ! The amplitude of the initial height displacement [H ~> m or kg m-2]. - real :: diskrad, rad, xCenter, xRadius, lonC, latC, xOffset + real :: IC_amp ! The amplitude of the initial height displacement [Z ~> m]. + real :: diskrad ! Radius of the elevated disk [km] or [degrees] or [m] + real :: rad ! Distance from the center of the elevated disk [km] or [degrees] or [m] + real :: lonC ! The x-position of a point [km] or [degrees] or [m] + real :: latC ! The y-position of a point [km] or [degrees] or [m] + real :: xOffset ! The x-offset of the elevated disc center relative to the domain + ! center [km] or [degrees] or [m] ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "circle_obcs_initialization" ! This module's name. @@ -60,16 +68,16 @@ subroutine circle_obcs_initialize_thickness(h, depth_tot, G, GV, param_file, jus ! Parameters read by cartesian grid initialization call get_param(param_file, mdl, "DISK_RADIUS", diskrad, & "The radius of the initially elevated disk in the "//& - "circle_obcs test case.", units=G%x_axis_units, & + "circle_obcs test case.", units=G%x_ax_unit_short, & fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "DISK_X_OFFSET", xOffset, & "The x-offset of the initially elevated disk in the "//& - "circle_obcs test case.", units=G%x_axis_units, & - default = 0.0, do_not_log=just_read) + "circle_obcs test case.", units=G%x_ax_unit_short, & + default=0.0, do_not_log=just_read) call get_param(param_file, mdl, "DISK_IC_AMPLITUDE", IC_amp, & "Initial amplitude of interface height displacements "//& "in the circle_obcs test case.", & - units='m', default=5.0, scale=GV%m_to_H, do_not_log=just_read) + units='m', default=5.0, scale=US%m_to_Z, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -84,9 +92,9 @@ subroutine circle_obcs_initialize_thickness(h, depth_tot, G, GV, param_file, jus eta1D(K) = e0(K) if (eta1D(K) < (eta1D(K+1) + GV%Angstrom_Z)) then eta1D(K) = eta1D(K+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + h(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H * (eta1D(K) - eta1D(K+1)) + h(i,j,k) = eta1D(K) - eta1D(K+1) endif enddo enddo ; enddo @@ -96,7 +104,7 @@ subroutine circle_obcs_initialize_thickness(h, depth_tot, G, GV, param_file, jus latC = G%south_lat + 0.5*G%len_lat lonC = G%west_lon + 0.5*G%len_lon + xOffset do j=js,je ; do i=is,ie - rad = sqrt((G%geoLonT(i,j)-lonC)**2+(G%geoLatT(i,j)-latC)**2)/(diskrad) + rad = sqrt(((G%geoLonT(i,j)-lonC)**2) + ((G%geoLatT(i,j)-latC)**2)) / diskrad ! if (rad <= 6.*diskrad) h(i,j,k) = h(i,j,k)+10.0*exp( -0.5*( rad**2 ) ) rad = min( rad, 1. ) ! Flatten outside radius of diskrad rad = rad*(2.*asin(1.)) ! Map 0-1 to 0-pi diff --git a/src/user/dense_water_initialization.F90 b/src/user/dense_water_initialization.F90 index 99836f5ad0..c8ee29f8f4 100644 --- a/src/user/dense_water_initialization.F90 +++ b/src/user/dense_water_initialization.F90 @@ -1,9 +1,11 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Initialization routines for the dense water formation !! and overflow experiment. module dense_water_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_ALE_sponge, only : ALE_sponge_CS, set_up_ALE_sponge_field, initialize_ALE_sponge use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_EOS, only : EOS_type @@ -35,15 +37,18 @@ module dense_water_initialization subroutine dense_water_initialize_topography(D, G, param_file, max_depth) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth in the units of depth_max + intent(out) :: D !< Ocean bottom depth [Z ~> m] type(param_file_type), intent(in) :: param_file !< Parameter file structure - real, intent(in) :: max_depth !< Maximum ocean depth in arbitrary units + real, intent(in) :: max_depth !< Maximum ocean depth [Z ~> m] ! Local variables - real, dimension(5) :: domain_params ! nondimensional widths of all domain sections - real :: sill_frac, shelf_frac + real, dimension(5) :: domain_params ! nondimensional widths of all domain sections [nondim] + real :: sill_frac ! Depth of the sill separating downslope from upslope, as a fraction of + ! the basin depth [nondim] + real :: shelf_frac ! Depth of the shelf region accumulating dense water for overflow, + ! as a fraction the basin depth [nondim] + real :: x ! Horizontal position normalized by the domain width [nondim] integer :: i, j - real :: x call get_param(param_file, mdl, "DENSE_WATER_DOMAIN_PARAMS", domain_params, & "Fractional widths of all the domain sections for the dense water experiment.\n"//& @@ -95,18 +100,21 @@ subroutine dense_water_initialize_topography(D, G, param_file, max_depth) end subroutine dense_water_initialize_topography !> Initialize the temperature and salinity for the dense water experiment -subroutine dense_water_initialize_TS(G, GV, param_file, T, S, h, just_read) +subroutine dense_water_initialize_TS(G, GV, US, param_file, T, S, h, just_read) type(ocean_grid_type), intent(in) :: G !< Horizontal grid control structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid control structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Output temperature [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Output salinity [ppt] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Output temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Output salinity [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [Z ~> m] logical, intent(in) :: just_read !< If true, this call will !! only read parameters without changing T & S. ! Local variables - real :: mld, S_ref, S_range, T_ref - real :: zi, zmid + real :: mld ! The initial mixed layer depth as a fraction of the maximum depth [nondim] + real :: S_ref, S_range ! The reference salinity and its range in the initial conditions [S ~> ppt] + real :: T_ref ! The reference temperature [C ~> degC] + real :: zi, zmid ! Depths from the surface nondimensionalized by the maximum depth [nondim] integer :: i, j, k, nz nz = GV%ke @@ -115,11 +123,11 @@ subroutine dense_water_initialize_TS(G, GV, param_file, T, S, h, just_read) "Depth of unstratified mixed layer as a fraction of the water column.", & units="nondim", default=default_mld, do_not_log=just_read) call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & - default=35.0, units='1e-3', do_not_log=just_read) - call get_param(param_file, mdl,"T_REF", T_ref, 'Reference temperature', units='degC', & - fail_if_missing=.not.just_read, do_not_log=just_read) + default=35.0, units="ppt", scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl,"T_REF", T_ref, 'Reference temperature', & + units='degC', scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl,"S_RANGE", S_range, 'Initial salinity range', & - units='1e-3', default=2.0, do_not_log=just_read) + units="ppt", default=2.0, scale=US%ppt_to_S, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -131,7 +139,7 @@ subroutine dense_water_initialize_TS(G, GV, param_file, T, S, h, just_read) zi = 0. do k = 1,nz ! nondimensional middle of layer - zmid = zi + 0.5 * h(i,j,k) / (GV%Z_to_H * G%max_depth) + zmid = zi + 0.5 * h(i,j,k) / G%max_depth if (zmid < mld) then ! use reference salinity in the mixed layer @@ -141,7 +149,7 @@ subroutine dense_water_initialize_TS(G, GV, param_file, T, S, h, just_read) S(i,j,k) = S_ref + S_range * (zmid - mld) / (1.0 - mld) endif - zi = zi + h(i,j,k) / (GV%Z_to_H * G%max_depth) + zi = zi + h(i,j,k) / G%max_depth enddo enddo enddo @@ -159,45 +167,56 @@ subroutine dense_water_initialize_sponges(G, GV, US, tv, depth_tot, param_file, logical, intent(in) :: use_ALE !< ALE flag type(sponge_CS), pointer :: CSp !< Layered sponge control structure pointer type(ALE_sponge_CS), pointer :: ACSp !< ALE sponge control structure pointer + ! Local variables real :: west_sponge_time_scale, east_sponge_time_scale ! Sponge timescales [T ~> s] - real :: west_sponge_width, east_sponge_width + real :: west_sponge_width ! The fraction of the domain in which the western (outflow) sponge is active [nondim] + real :: east_sponge_width ! The fraction of the domain in which the eastern (outflow) sponge is active [nondim] real, dimension(SZI_(G),SZJ_(G)) :: Idamp ! inverse damping timescale [T-1 ~> s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h ! sponge thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: T ! sponge temperature [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: S ! sponge salinity [ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! sponge layer thicknesses in height units [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: T ! sponge temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: S ! sponge salinity [S ~> ppt] real, dimension(SZK_(GV)+1) :: e0, eta1D ! interface positions for ALE sponge [Z ~> m] - + real :: x ! Horizontal position normalized by the domain width [nondim] + real :: zi, zmid ! Depths from the surface nondimensionalized by the maximum depth [nondim] + real :: dist ! Distance from the edge of a sponge normalized by the width of that sponge [nondim] + real :: mld ! The initial mixed layer depth as a fraction of the maximum depth [nondim] + real :: S_ref, S_range ! The reference salinity and its range in the initial conditions [S ~> ppt] + real :: S_dense ! The salinity of the dense water being formed on the shelf [S ~> ppt] + real :: T_ref ! The reference temperature [C ~> degC] + real :: sill_frac ! Fractional depths of the sill, relative to the maximum depth [nondim] integer :: i, j, k, nz - real :: x, zi, zmid, dist - real :: mld, S_ref, S_range, S_dense, T_ref, sill_height nz = GV%ke call get_param(param_file, mdl, "DENSE_WATER_WEST_SPONGE_TIME_SCALE", west_sponge_time_scale, & - "The time scale on the west (outflow) of the domain for restoring. If zero, the sponge is disabled.", & - units="s", default=0., scale=US%s_to_T) + "The time scale on the west (outflow) of the domain for restoring. "//& + "If zero, the sponge is disabled.", units="s", default=0., scale=US%s_to_T) call get_param(param_file, mdl, "DENSE_WATER_WEST_SPONGE_WIDTH", west_sponge_width, & - "The fraction of the domain in which the western (outflow) sponge is active.", & - units="nondim", default=0.1) + "The fraction of the domain in which the western (outflow) sponge is active.", & + units="nondim", default=0.1) call get_param(param_file, mdl, "DENSE_WATER_EAST_SPONGE_TIME_SCALE", east_sponge_time_scale, & - "The time scale on the east (outflow) of the domain for restoring. If zero, the sponge is disabled.", & - units="s", default=0., scale=US%s_to_T) + "The time scale on the east (outflow) of the domain for restoring. "//& + "If zero, the sponge is disabled.", units="s", default=0., scale=US%s_to_T) call get_param(param_file, mdl, "DENSE_WATER_EAST_SPONGE_WIDTH", east_sponge_width, & - "The fraction of the domain in which the eastern (outflow) sponge is active.", & - units="nondim", default=0.1) - + "The fraction of the domain in which the eastern (outflow) sponge is active.", & + units="nondim", default=0.1) call get_param(param_file, mdl, "DENSE_WATER_EAST_SPONGE_SALT", S_dense, & - "Salt anomaly of the dense water being formed in the overflow region.", & - units="1e-3", default=4.0) + "Salt anomaly of the dense water being formed in the overflow region.", & + units="ppt", default=4.0, scale=US%ppt_to_S) - call get_param(param_file, mdl, "DENSE_WATER_MLD", mld, default=default_mld, do_not_log=.true.) - call get_param(param_file, mdl, "DENSE_WATER_SILL_HEIGHT", sill_height, default=default_sill, do_not_log=.true.) + call get_param(param_file, mdl, "DENSE_WATER_MLD", mld, & + units="nondim", default=default_mld, do_not_log=.true.) + call get_param(param_file, mdl, "DENSE_WATER_SILL_DEPTH", sill_frac, & + units="nondim", default=default_sill, do_not_log=.true.) - call get_param(param_file, mdl, "S_REF", S_ref, default=35.0, do_not_log=.true.) - call get_param(param_file, mdl, "S_RANGE", S_range, do_not_log=.true.) - call get_param(param_file, mdl, "T_REF", T_ref, do_not_log=.true.) + call get_param(param_file, mdl, "S_REF", S_ref, & + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "S_RANGE", S_range, & + units="ppt", default=2.0, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "T_REF", T_ref, & + units='degC', scale=US%degC_to_C, fail_if_missing=.true., do_not_log=.true.) ! no active sponges if (west_sponge_time_scale <= 0. .and. east_sponge_time_scale <= 0.) return @@ -239,16 +258,14 @@ subroutine dense_water_initialize_sponges(G, GV, US, tv, depth_tot, param_file, if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_Z)) then ! is this layer vanished? eta1D(k) = eta1D(k+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + dz(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + dz(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo enddo enddo - call initialize_ALE_sponge(Idamp, G, GV, param_file, ACSp, h, nz) - ! construct temperature and salinity for the sponge ! start with initial condition T(:,:,:) = T_ref @@ -260,24 +277,29 @@ subroutine dense_water_initialize_sponges(G, GV, US, tv, depth_tot, param_file, x = (G%geoLonT(i,j) - G%west_lon) / G%len_lon do k = 1,nz ! nondimensional middle of layer - zmid = zi + 0.5 * h(i,j,k) / (GV%Z_to_H * G%max_depth) + zmid = zi + 0.5 * dz(i,j,k) / G%max_depth if (x > (1. - east_sponge_width)) then - !if (zmid >= 0.9 * sill_height) & - S(i,j,k) = S_ref + S_dense + !if (zmid >= 0.9 * sill_frac) & + S(i,j,k) = S_ref + S_dense else ! linear between bottom of mixed layer and bottom if (zmid >= mld) & - S(i,j,k) = S_ref + S_range * (zmid - mld) / (1.0 - mld) + S(i,j,k) = S_ref + S_range * (zmid - mld) / (1.0 - mld) endif - zi = zi + h(i,j,k) / (GV%Z_to_H * G%max_depth) + zi = zi + dz(i,j,k) / G%max_depth enddo enddo enddo - if (associated(tv%T)) call set_up_ALE_sponge_field(T, G, GV, tv%T, ACSp) - if (associated(tv%S)) call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp) + ! This call sets up the damping rates and interface heights in the sponges. + call initialize_ALE_sponge(Idamp, G, GV, param_file, ACSp, dz, nz, data_h_is_Z=.true.) + + if ( associated(tv%T) ) call set_up_ALE_sponge_field(T, G, GV, tv%T, ACSp, 'temp', & + sp_long_name='temperature', sp_unit='degC s-1') + if ( associated(tv%S) ) call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp, 'salt', & + sp_long_name='salinity', sp_unit='g kg-1 s-1') else call MOM_error(FATAL, "dense_water_initialize_sponges: trying to use non ALE sponge") endif @@ -295,7 +317,7 @@ end module dense_water_initialization !! The nondimensional widths of the 5 regions are controlled by the !! DENSE_WATER_DOMAIN_PARAMS, and the heights of the sill and shelf !! as a fraction of the total domain depth are controlled by -!! DENSE_WATER_SILL_HEIGHT and DENSE_WATER_SHELF_HEIGHT. +!! DENSE_WATER_SILL_DEPTH and DENSE_WATER_SHELF_DEPTH. !! !! The density in the domain is governed by a linear equation of state, and !! is set up with a mixed layer of non-dimensional depth DENSE_WATER_MLD diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90 index ac4181d570..df286716f0 100644 --- a/src/user/dumbbell_initialization.F90 +++ b/src/user/dumbbell_initialization.F90 @@ -1,23 +1,25 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Configures the model for the idealized dumbbell test case. module dumbbell_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_domains, only : sum_across_PEs use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz use MOM_sponge, only : set_up_sponge_field, initialize_sponge, sponge_CS use MOM_tracer_registry, only : tracer_registry_type use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type use regrid_consts, only : coordinateMode, DEFAULT_COORDINATE_MODE use regrid_consts, only : REGRIDDING_LAYER, REGRIDDING_ZSTAR -use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA +use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA, REGRIDDING_HYCOM1 use MOM_ALE_sponge, only : ALE_sponge_CS, set_up_ALE_sponge_field, initialize_ALE_sponge implicit none ; private @@ -42,27 +44,29 @@ module dumbbell_initialization subroutine dumbbell_initialize_topography( D, G, param_file, max_depth ) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth in the units of depth_max + intent(out) :: D !< Ocean bottom depth [Z ~> m] type(param_file_type), intent(in) :: param_file !< Parameter file structure - real, intent(in) :: max_depth !< Maximum ocean depth in arbitrary units + real, intent(in) :: max_depth !< Maximum ocean depth [Z ~> m] ! Local variables - integer :: i, j - real :: x, y, delta, dblen, dbfrac - logical :: dbrotate - - call get_param(param_file, mdl,"DUMBBELL_LEN",dblen, & - 'Lateral Length scale for dumbbell.',& - units='k', default=600., do_not_log=.false.) - call get_param(param_file, mdl,"DUMBBELL_FRACTION",dbfrac, & - 'Meridional fraction for narrow part of dumbbell.',& + real :: x, y ! Fractional x- and y- positions [nondim] + real :: dblen ! Lateral length scale for dumbbell [km] or [m] + real :: dbfrac ! Meridional fraction for narrow part of dumbbell [nondim] + logical :: dbrotate ! If true, rotate this configuration + integer :: i, j + + call get_param(param_file, mdl, "DUMBBELL_LEN", dblen, & + 'Lateral Length scale for dumbbell.', & + units=G%x_ax_unit_short, default=600., do_not_log=.false.) + call get_param(param_file, mdl, "DUMBBELL_FRACTION", dbfrac, & + 'Meridional fraction for narrow part of dumbbell.', & units='nondim', default=0.5, do_not_log=.false.) call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & - 'Logical for rotation of dumbbell domain.',& - units='nondim', default=.false., do_not_log=.false.) + 'Logical for rotation of dumbbell domain.', & + default=.false., do_not_log=.false.) - if (G%x_axis_units == 'm') then - dblen=dblen*1.e3 + if (G%x_axis_units(1:1) == 'm') then + dblen = dblen*1.e3 endif if (dbrotate) then @@ -95,7 +99,7 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file @@ -108,8 +112,14 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface ! positive upward [Z ~> m]. real :: min_thickness ! The minimum layer thicknesses [Z ~> m]. - real :: S_surf, S_range, S_ref, S_light, S_dense ! Various salinities [ppt]. - real :: eta_IC_quanta ! The granularity of quantization of intial interface heights [Z-1 ~> m-1]. + real :: S_ref ! A default value for salinities [S ~> ppt]. + real :: S_surf ! The surface salinity [S ~> ppt] + real :: S_range ! The range of salinities in this test case [S ~> ppt] + real :: S_light, S_dense ! The lightest and densest salinities in the sponges [S ~> ppt]. + real :: eta_IC_quanta ! The granularity of quantization of initial interface heights [Z-1 ~> m-1]. + logical :: dbrotate ! If true, rotate the domain. + logical :: use_ALE ! True if ALE is being used, False if in layered mode + ! This include declares and sets the variable "version". # include "version_variable.h" character(len=20) :: verticalCoordinate @@ -118,14 +128,16 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not.just_read) & - call MOM_mesg("MOM_initialization.F90, initialize_thickness_uniform: setting thickness") + call MOM_mesg("dumbbell_initialization.F90, dumbbell_initialize_thickness: setting thickness") if (.not.just_read) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl,"MIN_THICKNESS", min_thickness, & - 'Minimum thickness for layer',& - units='m', default=1.0e-3, do_not_log=just_read, scale=US%m_to_Z) + 'Minimum thickness for layer', & + units='m', default=1.0e-3, scale=US%m_to_Z, do_not_log=just_read) call get_param(param_file, mdl,"REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) + call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, default=.false., do_not_log=.true.) + if (.not. use_ALE) verticalCoordinate = "LAYER" ! WARNING: this routine specifies the interface heights so that the last layer ! is vanished, even at maximum depth. In order to have a uniform @@ -139,13 +151,41 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, !enddo select case ( coordinateMode(verticalCoordinate) ) + case ( REGRIDDING_LAYER) ! Initial thicknesses for isopycnal coordinates + call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & + 'Logical for rotation of dumbbell domain.', & + default=.false., do_not_log=just_read) + do j=js,je + do i=is,ie + ! Work relative to the center of the domain, where geoLonT and geoLatT are both 0. + eta1D(1) = 0.0 + eta1D(nz+1) = -depth_tot(i,j) + if (((.not.dbrotate) .and. (G%geoLonT(i,j)<0.0)) .or. (dbrotate .and. (G%geoLatT(i,j)<0.0))) then + do k=nz,2, -1 + eta1D(k) = eta1D(k+1) + min_thickness + enddo + else + do k=2,nz + eta1D(k) = eta1D(k-1) - min_thickness + enddo + endif + do k=1,nz + h(i,j,k) = eta1D(k) - eta1D(k+1) + enddo + enddo + enddo - case ( REGRIDDING_LAYER, REGRIDDING_RHO ) ! Initial thicknesses for isopycnal coordinates - call get_param(param_file, mdl,"INITIAL_SSS", S_surf, default=34., do_not_log=.true.) - call get_param(param_file, mdl,"INITIAL_S_RANGE", S_range, default=2., do_not_log=.true.) - call get_param(param_file, mdl, "S_REF", S_ref, default=35.0, do_not_log=.true.) - call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_light, default = S_Ref, do_not_log=.true.) - call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_dense, default = S_Ref, do_not_log=.true.) + case ( REGRIDDING_RHO, REGRIDDING_HYCOM1) ! Initial thicknesses for isopycnal coordinates + call get_param(param_file, mdl, "INITIAL_SSS", S_surf, & + units="ppt", default=34., scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "INITIAL_S_RANGE", S_range, & + units="ppt", default=2., scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "S_REF", S_ref, & + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_light, & + units="ppt", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_dense, & + units="ppt", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "INTERFACE_IC_QUANTA", eta_IC_quanta, & "The granularity of initial interface height values "//& "per meter, to avoid sensivity to order-of-arithmetic changes.", & @@ -173,9 +213,9 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, eta1D(k) = e0(k) if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_Z)) then eta1D(k) = eta1D(k+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + h(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + h(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo enddo ; enddo @@ -188,9 +228,9 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, eta1D(k) = -G%max_depth * real(k-1) / real(nz) if (eta1D(k) < (eta1D(k+1) + min_thickness)) then eta1D(k) = eta1D(k+1) + min_thickness - h(i,j,k) = GV%Z_to_H * min_thickness + h(i,j,k) = min_thickness else - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + h(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo enddo ; enddo @@ -198,7 +238,7 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, case ( REGRIDDING_SIGMA ) ! Initial thicknesses for sigma coordinates if (just_read) return ! All run-time parameters have been read, so return. do j=js,je ; do i=is,ie - h(i,j,:) = GV%Z_to_H * depth_tot(i,j) / dfloat(nz) + h(i,j,:) = depth_tot(i,j) / real(nz) enddo ; enddo end select @@ -206,47 +246,58 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, end subroutine dumbbell_initialize_thickness !> Initial values for temperature and salinity for the dumbbell test case -subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, param_file, just_read) +subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, US, param_file, just_read) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [ppt] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [Z ~> m] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file structure logical, intent(in) :: just_read !< If true, this call will !! only read parameters without changing h. ! Local variables - integer :: i, j, k, is, ie, js, je, nz, k_light - real :: xi0, xi1, dxi, r, S_surf, T_surf, S_range, T_range - real :: x, y, dblen - real :: T_ref, T_Light, T_Dense, S_ref, S_Light, S_Dense, a1, frac_dense, k_frac, res_rat - logical :: dbrotate ! If true, rotate the domain. + integer :: i, j, k, is, ie, js, je, nz + real :: S_surf ! The surface salinity [S ~> ppt] + real :: S_range ! The range of salinities in this test case [S ~> ppt] + real :: T_surf ! The surface temperature [C ~> degC] + real :: x ! The fractional position in the domain [nondim] + real :: dblen ! The size of the dumbbell test case [km] or [m] + logical :: dbrotate ! If true, rotate the domain. + logical :: use_ALE ! If false, use layer mode. character(len=20) :: verticalCoordinate, density_profile is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - T_surf = 20.0 + ! layer mode + call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, default=.false., do_not_log=.true.) + if (.not. use_ALE) call MOM_error(FATAL, "dumbbell_initialize_temperature_salinity: "//& + "Please use 'fit' for 'TS_CONFIG' in the LAYER mode.") call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) - call get_param(param_file, mdl,"INITIAL_DENSITY_PROFILE", density_profile, & + call get_param(param_file, mdl, "INITIAL_DENSITY_PROFILE", density_profile, & 'Initial profile shape. Valid values are "linear", "parabolic" '// & 'and "exponential".', default='linear', do_not_log=just_read) - call get_param(param_file, mdl,"DUMBBELL_SREF", S_surf, & - 'DUMBBELL REFERENCE SALINITY', units='1e-3', default=34., do_not_log=just_read) - call get_param(param_file, mdl,"DUMBBELL_S_RANGE", S_range, & - 'DUMBBELL salinity range (right-left)', units='1e-3', & - default=2., do_not_log=just_read) - call get_param(param_file, mdl,"DUMBBELL_LEN",dblen, & - 'Lateral Length scale for dumbbell ',& - units='k', default=600., do_not_log=just_read) + call get_param(param_file, mdl, "DUMBBELL_T_SURF", T_surf, & + 'Initial surface temperature in the DUMBBELL configuration', & + units='degC', default=20., scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "DUMBBELL_SREF", S_surf, & + 'DUMBBELL REFERENCE SALINITY', & + units="ppt", default=34., scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "DUMBBELL_S_RANGE", S_range, & + 'DUMBBELL salinity range (right-left)', & + units="ppt", default=2., scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "DUMBBELL_LEN", dblen, & + 'Lateral Length scale for dumbbell ', & + units=G%x_ax_unit_short, default=600., do_not_log=just_read) call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & - 'Logical for rotation of dumbbell domain.',& - units='nondim', default=.false., do_not_log=just_read) + 'Logical for rotation of dumbbell domain.', & + default=.false., do_not_log=just_read) - if (G%x_axis_units == 'm') then - dblen=dblen*1.e3 + if (G%x_axis_units(1:1) == 'm') then + dblen = dblen*1.e3 endif do j=G%jsc,G%jec @@ -259,16 +310,16 @@ subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, param_file x = ( G%geoLonT(i,j) ) / dblen endif do k=1,nz - T(i,j,k)=T_surf + T(i,j,k) = T_surf enddo if (x>=0. ) then do k=1,nz - S(i,j,k)=S_surf + 0.5*S_range + S(i,j,k) = S_surf + 0.5*S_range enddo endif if (x<0. ) then do k=1,nz - S(i,j,k)=S_surf - 0.5*S_range + S(i,j,k) = S_surf - 0.5*S_range enddo endif @@ -278,11 +329,12 @@ subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, param_file end subroutine dumbbell_initialize_temperature_salinity !> Initialize the restoring sponges for the dumbbell test case -subroutine dumbbell_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use_ALE, CSp, ACSp) +subroutine dumbbell_initialize_sponges(G, GV, US, tv, h_in, depth_tot, param_file, use_ALE, CSp, ACSp) type(ocean_grid_type), intent(in) :: G !< Horizontal grid control structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid control structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< Parameter file structure @@ -293,35 +345,49 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use real :: sponge_time_scale ! The damping time scale [T ~> s] real, dimension(SZI_(G),SZJ_(G)) :: Idamp ! inverse damping timescale [T-1 ~> s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h, T, S ! sponge thicknesses, temp and salt - real, dimension(SZK_(GV)+1) :: e0, eta1D ! interface positions for ALE sponge + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Sponge thicknesses in height units [Z ~> m] + real :: S(SZI_(G),SZJ_(G),SZK_(GV)) ! Sponge salinities [S ~> ppt] + real :: T(SZI_(G),SZJ_(G),SZK_(GV)) ! Sponge tempertures [C ~> degC], used only to convert thicknesses + ! in non-Boussinesq mode + real, dimension(SZK_(GV)+1) :: eta1D ! Interface positions for ALE sponge [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: eta ! A temporary array for interface heights [Z ~> m]. integer :: i, j, k, nz - real :: x, zi, zmid, dist, min_thickness, dblen - real :: mld, S_ref, S_range, S_dense, T_ref, sill_height + real :: x ! The fractional position in the domain [nondim] + real :: dblen ! The size of the dumbbell test case [km] or [m] + real :: min_thickness ! The minimum layer thickness [Z ~> m] + real :: S_ref, S_range ! A reference salinity and the range of salinities in this test case [S ~> ppt] + real :: T_surf ! The surface temperature [C ~> degC] logical :: dbrotate ! If true, rotate the domain. call get_param(param_file, mdl,"DUMBBELL_LEN",dblen, & - 'Lateral Length scale for dumbbell ',& - units='k', default=600., do_not_log=.true.) + 'Lateral Length scale for dumbbell ', & + units='km', default=600., do_not_log=.true.) call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & - 'Logical for rotation of dumbbell domain.',& - units='nondim', default=.false., do_not_log=.true.) + 'Logical for rotation of dumbbell domain.', & + default=.false., do_not_log=.true.) - if (G%x_axis_units == 'm') then - dblen=dblen*1.e3 + if (G%x_axis_units(1:1) == 'm') then + dblen = dblen*1.e3 endif nz = GV%ke call get_param(param_file, mdl, "DUMBBELL_SPONGE_TIME_SCALE", sponge_time_scale, & - "The time scale in the reservoir for restoring. If zero, the sponge is disabled.", & - units="s", default=0., scale=US%s_to_T) - call get_param(param_file, mdl, "DUMBBELL_SREF", S_ref, do_not_log=.true.) - call get_param(param_file, mdl, "DUMBBELL_S_RANGE", S_range, do_not_log=.true.) + "The time scale in the reservoir for restoring. If zero, the sponge is disabled.", & + units="s", default=0., scale=US%s_to_T) + call get_param(param_file, mdl, "DUMBBELL_T_SURF", T_surf, & + 'Initial surface temperature in the DUMBBELL configuration', & + units='degC', default=20., scale=US%degC_to_C, do_not_log=.true.) + call get_param(param_file, mdl, "DUMBBELL_SREF", S_ref, & + 'DUMBBELL REFERENCE SALINITY', & + units="ppt", default=34., scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "DUMBBELL_S_RANGE", S_range, & + 'DUMBBELL salinity range (right-left)', & + units="ppt", default=2., scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl,"MIN_THICKNESS", min_thickness, & - 'Minimum thickness for layer',& - units='m', default=1.0e-3, do_not_log=.true., scale=US%m_to_Z) + 'Minimum thickness for layer', & + units='m', default=1.0e-3, scale=US%m_to_Z, do_not_log=.true.) ! no active sponges if (sponge_time_scale <= 0.) return @@ -355,18 +421,17 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use eta1D(k) = -G%max_depth * real(k-1) / real(nz) if (eta1D(k) < (eta1D(k+1) + min_thickness)) then eta1D(k) = eta1D(k+1) + min_thickness - h(i,j,k) = GV%Z_to_H * min_thickness + dz(i,j,k) = min_thickness else - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + dz(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo enddo ; enddo - call initialize_ALE_sponge(Idamp, G, GV, param_file, ACSp, h, nz) - ! construct temperature and salinity for the sponge ! start with initial condition S(:,:,:) = 0.0 + T(:,:,:) = T_surf do j=G%jsc,G%jec ; do i=G%isc,G%iec ! Compute normalized zonal coordinates (x,y=0 at center of domain) @@ -378,18 +443,43 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use endif if (x>=0.25 ) then do k=1,nz - S(i,j,k)=S_ref + 0.5*S_range + S(i,j,k) = S_ref + 0.5*S_range enddo endif if (x<=-0.25 ) then do k=1,nz - S(i,j,k)=S_ref - 0.5*S_range + S(i,j,k) = S_ref - 0.5*S_range enddo endif enddo ; enddo - endif - if (associated(tv%S)) call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp) + ! Store damping rates and the grid on which the T/S sponge data will reside + call initialize_ALE_sponge(Idamp, G, GV, param_file, ACSp, dz, nz, data_h_is_Z=.true.) + + if (associated(tv%S)) call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp, 'salt', & + sp_long_name='salinity', sp_unit='g kg-1 s-1') + else + ! Convert thicknesses from thickness units to height units + call thickness_to_dz(h_in, tv, dz, G, GV, US) + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + eta(i,j,1) = 0.0 + do k=2,nz + eta(i,j,k) = eta(i,j,k-1) - dz(i,j,k-1) + enddo + eta(i,j,nz+1) = -depth_tot(i,j) + do k=1,nz + S(i,j,k)= tv%S(i,j,k) + enddo + enddo ; enddo + + ! This call sets up the damping rates and interface heights. + ! This sets the inverse damping timescale fields in the sponges. ! + call initialize_sponge(Idamp, eta, G, param_file, CSp, GV) + + ! The remaining calls to set_up_sponge_field can be in any order. ! + if ( associated(tv%S) ) call set_up_sponge_field(S, tv%S, G, GV, nz, CSp) + endif end subroutine dumbbell_initialize_sponges diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index a1d8bf4b52..2501cb0db3 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Surface forcing for the dumbbell test case module dumbbell_surface_forcing -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_diag_mediator, only : post_data, query_averaging_enabled use MOM_diag_mediator, only : register_diag_field, diag_ctrl use MOM_domains, only : pass_var, pass_vector, AGRID @@ -25,18 +27,17 @@ module dumbbell_surface_forcing type, public :: dumbbell_surface_forcing_CS ; private logical :: use_temperature !< If true, temperature and salinity are used as state variables. logical :: restorebuoy !< If true, use restoring surface buoyancy forcing. - real :: Rho0 !< The density used in the Boussinesq approximation [R ~> kg m-3]. real :: G_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] - real :: Flux_const !< The restoring rate at the surface [Z T-1 ~> m s-1]. + real :: Flux_const !< The restoring rate at the surface [R Z T-1 ~> kg m-2 s-1]. ! real :: gust_const !< A constant unresolved background gustiness ! !! that contributes to ustar [R L Z T-2 ~> Pa]. real :: slp_amplitude !< The amplitude of pressure loading [R L2 T-2 ~> Pa] applied !! to the reservoirs real :: slp_period !< Period of sinusoidal pressure wave [days] real, dimension(:,:), allocatable :: & - forcing_mask !< A mask regulating where forcing occurs + forcing_mask !< A mask regulating where forcing occurs [nondim] real, dimension(:,:), allocatable :: & - S_restore !< The surface salinity field toward which to restore [ppt]. + S_restore !< The surface salinity field toward which to restore [S ~> ppt]. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the !! timing of diagnostic output. end type dumbbell_surface_forcing_CS @@ -58,8 +59,6 @@ subroutine dumbbell_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) type(dumbbell_surface_forcing_CS), pointer :: CS !< A control structure returned by a previous !! call to dumbbell_surface_forcing_init ! Local variables - real :: Temp_restore ! The temperature that is being restored toward [degC]. - real :: Salin_restore ! The salinity that is being restored toward [ppt]. integer :: i, j, is, ie, js, je integer :: isd, ied, jsd, jed @@ -116,7 +115,7 @@ subroutine dumbbell_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) if (CS%use_temperature .and. CS%restorebuoy) then do j=js,je ; do i=is,ie if (CS%forcing_mask(i,j)>0.) then - fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & + fluxes%vprec(i,j) = - (G%mask2dT(i,j) * CS%Flux_const) * & ((CS%S_restore(i,j) - sfc_state%SSS(i,j)) / (0.5 * (CS%S_restore(i,j) + sfc_state%SSS(i,j)))) endif @@ -180,9 +179,12 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) type(dumbbell_surface_forcing_CS), & pointer :: CS !< A pointer to the control structure for this module ! Local variables - real :: S_surf ! Initial surface salinity [ppt] - real :: S_range ! Range of the initial vertical distribution of salinity [ppt] - real :: x, y ! Latitude and longitude normalized by the domain size [nondim] + real :: S_surf ! Initial surface salinity [S ~> ppt] + real :: S_range ! Range of the initial vertical distribution of salinity [S ~> ppt] + real :: x ! Latitude normalized by the domain size [nondim] + real :: Rho0 ! The density used in the Boussinesq approximation [R ~> kg m-3] + real :: rho_restore ! The density that is used to convert piston velocities into salt + ! or heat fluxes with salinity or temperature restoring [R ~> kg m-3] integer :: i, j logical :: dbrotate ! If true, rotate the domain. # include "version_variable.h" @@ -203,39 +205,45 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) - call get_param(param_file, mdl, "RHO_0", CS%Rho0, & + units="m s-2", default=9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) + call get_param(param_file, mdl, "RHO_0", Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& + "properties, or with BOUSSINESQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "DUMBBELL_SLP_AMP", CS%slp_amplitude, & "Amplitude of SLP forcing in reservoirs.", & - units="Pa", default = 10000.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) + units="Pa", default=10000.0, scale=US%Pa_to_RL2_T2) call get_param(param_file, mdl, "DUMBBELL_SLP_PERIOD", CS%slp_period, & "Periodicity of SLP forcing in reservoirs.", & - units="days", default = 1.0) + units="days", default=1.0) call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & 'Logical for rotation of dumbbell domain.',& - units='nondim', default=.false., do_not_log=.true.) + default=.false., do_not_log=.true.) call get_param(param_file, mdl,"INITIAL_SSS", S_surf, & - "Initial surface salinity", units="1e-3", default=34.0, do_not_log=.true.) + "Initial surface salinity", & + units="ppt", default=34.0, scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl,"INITIAL_S_RANGE", S_range, & - "Initial salinity range (bottom - surface)", units="1e-3", & - default=2., do_not_log=.true.) + "Initial salinity range (bottom - surface)", & + units="ppt", default=2., scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& "toward some specified surface state with a rate "//& - "given by FLUXCONST.", default= .false.) + "given by FLUXCONST.", default=.false.) if (CS%restorebuoy) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes to the relative "//& "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s) - ! Convert CS%Flux_const from m day-1 to m s-1. - CS%Flux_const = CS%Flux_const / 86400.0 + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", rho_restore, & + "The density that is used to convert piston velocities into salt or heat "//& + "fluxes with RESTORE_SALINITY or RESTORE_TEMPERATURE.", & + units="kg m-3", default=Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=(CS%Flux_const==0.0)) + ! Convert FLUXCONST from m day-1 to m s-1 and Flux_const to [R Z T-1 ~> kg m-2 s-1] + CS%Flux_const = rho_restore * (CS%Flux_const / 86400.0) allocate(CS%forcing_mask(G%isd:G%ied, G%jsd:G%jed), source=0.0) diff --git a/src/user/dyed_channel_initialization.F90 b/src/user/dyed_channel_initialization.F90 index ff98f16529..2d34bbb59b 100644 --- a/src/user/dyed_channel_initialization.F90 +++ b/src/user/dyed_channel_initialization.F90 @@ -1,17 +1,20 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Initialization for the dyed_channel configuration module dyed_channel_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type -use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE +use MOM_open_boundary, only : OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S, OBC_DIRECTION_E use MOM_open_boundary, only : OBC_segment_type, register_segment_tracer use MOM_open_boundary, only : OBC_registry_type, register_OBC -use MOM_time_manager, only : time_type, time_type_to_real +use MOM_time_manager, only : time_type, time_to_real use MOM_tracer_registry, only : tracer_registry_type, tracer_name_lookup use MOM_tracer_registry, only : tracer_type use MOM_unit_scaling, only : unit_scale_type @@ -30,6 +33,9 @@ module dyed_channel_initialization real :: zonal_flow = 8.57 !< Mean inflow [L T-1 ~> m s-1] real :: tidal_amp = 0.0 !< Sloshing amplitude [L T-1 ~> m s-1] real :: frequency = 0.0 !< Sloshing frequency [T-1 ~> s-1] + logical :: OBC_transport_bug !< If true and specified open boundary conditions are being + !! used, use a 1 m (if Boussienesq) or 1 kg m-2 layer thickness + !! instead of the actual thickness. end type dyed_channel_OBC_CS integer :: ntr = 0 !< Number of dye tracers @@ -38,13 +44,15 @@ module dyed_channel_initialization contains !> Add dyed channel to OBC registry. -function register_dyed_channel_OBC(param_file, CS, US, OBC_Reg) +logical function register_dyed_channel_OBC(param_file, CS, US, OBC_Reg) type(param_file_type), intent(in) :: param_file !< parameter file. type(dyed_channel_OBC_CS), pointer :: CS !< Dyed channel control structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(OBC_registry_type), pointer :: OBC_Reg !< OBC registry. + ! Local variables - logical :: register_dyed_channel_OBC + logical :: enable_bugs ! If true, the defaults for recently added bug-fix flags are set to + ! recreate the bugs, or if false bugs are only used if actively selected. character(len=32) :: casename = "dyed channel" ! This case's name. character(len=40) :: mdl = "register_dyed_channel_OBC" ! This subroutine's name. @@ -64,6 +72,12 @@ function register_dyed_channel_OBC(param_file, CS, US, OBC_Reg) call get_param(param_file, mdl, "CHANNEL_FLOW_FREQUENCY", CS%frequency, & "Frequency of oscillating zonal flow.", & units="s-1", default=0.0, scale=US%T_to_s) + call get_param(param_file, mdl, "ENABLE_BUGS_BY_DEFAULT", enable_bugs, & + default=.true., do_not_log=.true.) ! This is logged from MOM.F90. + call get_param(param_file, mdl, "CHANNEL_FLOW_OBC_TRANSPORT_BUG", CS%OBC_transport_bug, & + "If true and specified open boundary conditions are being used, use a 1 m "//& + "(if Boussienesq) or 1 kg m-2 layer thickness instead of the actual thickness.", & + default=enable_bugs) ! Register the open boundaries. call register_OBC(casename, param_file, OBC_Reg) @@ -93,10 +107,8 @@ subroutine dyed_channel_set_OBC_tracer_data(OBC, G, GV, param_file, tr_Reg) ! Local variables character(len=40) :: mdl = "dyed_channel_set_OBC_tracer_data" ! This subroutine's name. character(len=80) :: name, longname - integer :: i, j, k, l, itt, isd, ied, jsd, jed, m, n - integer :: IsdB, IedB, JsdB, JedB - real :: dye - type(OBC_segment_type), pointer :: segment => NULL() + integer :: m, n, ntr_id + real :: dye ! Inflow dye concentrations [arbitrary] type(tracer_type), pointer :: tr_ptr => NULL() if (.not.associated(OBC)) call MOM_error(FATAL, 'dyed_channel_initialization.F90: '// & @@ -117,7 +129,7 @@ subroutine dyed_channel_set_OBC_tracer_data(OBC, G, GV, param_file, tr_Reg) do m=1,ntr write(name,'("dye_",I2.2)') m write(longname,'("Concentration of dyed_obc Tracer ",I2.2, " on segment ",I2.2)') m, m - call tracer_name_lookup(tr_Reg, tr_ptr, name) + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) do n=1,OBC%number_of_segments if (n == m) then @@ -125,7 +137,7 @@ subroutine dyed_channel_set_OBC_tracer_data(OBC, G, GV, param_file, tr_Reg) else dye = 0.0 endif - call register_segment_tracer(tr_ptr, param_file, GV, & + call register_segment_tracer(tr_ptr, ntr_id, param_file, GV, & OBC%segment(n), OBC_scalar=dye) enddo enddo @@ -133,7 +145,7 @@ subroutine dyed_channel_set_OBC_tracer_data(OBC, G, GV, param_file, tr_Reg) end subroutine dyed_channel_set_OBC_tracer_data !> This subroutine updates the long-channel flow -subroutine dyed_channel_update_flow(OBC, CS, G, GV, US, Time) +subroutine dyed_channel_update_flow(OBC, CS, G, GV, US, h, Time) type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies !! whether, where, and what open boundary !! conditions are used. @@ -141,57 +153,103 @@ subroutine dyed_channel_update_flow(OBC, CS, G, GV, US, Time) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness [H ~> m or kg m-2] type(time_type), intent(in) :: Time !< model time. + ! Local variables - character(len=40) :: mdl = "dyed_channel_update_flow" ! This subroutine's name. - character(len=80) :: name real :: flow ! The OBC velocity [L T-1 ~> m s-1] - real :: PI ! 3.1415926535... + real :: PI ! 3.1415926535... [nondim] real :: time_sec ! The elapsed time since the start of the calendar [T ~> s] - integer :: i, j, k, l, itt, isd, ied, jsd, jed, m, n - integer :: IsdB, IedB, JsdB, JedB + real :: fixed_thickness ! A fixed layer thickness, hard-coded to 1 mks unit, that is used to + ! reproduce a bug with the older versions of this code [H ~> m or kg m-2] + logical :: cross_channel ! True if the segment runs across the channel + integer :: turns ! Number of index quarter turns + integer :: i, j, k, l_seg, isd, ied, jsd, jed + integer :: IsdB, IedB, JsdB, JedB, is, ie, js, je type(OBC_segment_type), pointer :: segment => NULL() if (.not.associated(OBC)) call MOM_error(FATAL, 'dyed_channel_initialization.F90: '// & 'dyed_channel_update_flow() was called but OBC type was not initialized!') - time_sec = US%s_to_T * time_type_to_real(Time) + time_sec = time_to_real(Time, scale=US%s_to_T) PI = 4.0*atan(1.0) - do l=1, OBC%number_of_segments - segment => OBC%segment(l) + turns = modulo(G%HI%turns, 4) + + do l_seg=1, OBC%number_of_segments + segment => OBC%segment(l_seg) if (.not. segment%on_pe) cycle if (segment%gradient) cycle - if (segment%oblique .and. .not. segment%nudged .and. .not. segment%Flather) cycle + if (segment%oblique .and. (.not. segment%nudged) .and. (.not. segment%Flather)) cycle + + if (CS%frequency == 0.0) then + flow = CS%zonal_flow + else + flow = CS%zonal_flow + CS%tidal_amp * cos(2 * PI * CS%frequency * time_sec) + endif + if ((turns==2) .or. (turns==3)) flow = -1.0 * flow + isd = segment%HI%isd ; ied = segment%HI%ied + jsd = segment%HI%jsd ; jed = segment%HI%jed + IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB if (segment%is_E_or_W) then - jsd = segment%HI%jsd ; jed = segment%HI%jed - IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB - if (CS%frequency == 0.0) then - flow = CS%zonal_flow + is = IsdB ; ie = IedB ; js = jsd ; je = jed + else + is = isd ; ie = ied ; js = JsdB ; je = JedB + endif + cross_channel = ((segment%is_E_or_W .and. ((turns==0) .or. (turns==2))) .or. & + (segment%is_N_or_S .and. ((turns==1) .or. (turns==3)))) + + if ((segment%specified .or. segment%nudged) .and. cross_channel) then + do k=1,GV%ke ; do j=js,je ; do I=is,ie + segment%normal_vel(I,j,k) = flow + enddo ; enddo ; enddo + endif + + if (segment%specified .and. cross_channel) then + if (CS%OBC_transport_bug) then + fixed_thickness = 1.0 / GV%H_to_mks ! This replicates the prevoius answers without rescaling. + if ((segment%direction == OBC_DIRECTION_W) .or. (segment%direction == OBC_DIRECTION_E)) then + do k=1,GV%ke ; do j=jsd,jed ; do I=IsdB,IedB + segment%normal_trans(I,j,k) = flow * G%dyCu(I,j) * fixed_thickness + enddo ; enddo ; enddo + elseif ((segment%direction == OBC_DIRECTION_S) .or. (segment%direction == OBC_DIRECTION_N)) then + do k=1,GV%ke ; do J=JsdB,JedB ; do i=isd,ied + segment%normal_trans(i,J,k) = flow * G%dxCv(i,J) * fixed_thickness + enddo ; enddo ; enddo + endif else - flow = CS%zonal_flow + CS%tidal_amp * cos(2 * PI * CS%frequency * time_sec) + if (segment%direction == OBC_DIRECTION_W) then + do k=1,GV%ke ; do j=jsd,jed ; do I=IsdB,IedB + segment%normal_trans(I,j,k) = flow * G%dyCu(I,j) * h(i+1,j,k) + enddo ; enddo ; enddo + elseif (segment%direction == OBC_DIRECTION_E) then + do k=1,GV%ke ; do j=jsd,jed ; do I=IsdB,IedB + segment%normal_trans(I,j,k) = flow * G%dyCu(I,j) * h(i,j,k) + enddo ; enddo ; enddo + elseif (segment%direction == OBC_DIRECTION_S) then + do k=1,GV%ke ; do J=JsdB,JedB ; do i=isd,ied + segment%normal_trans(i,J,k) = flow * G%dxCv(i,J) * h(i,j+1,k) + enddo ; enddo ; enddo + elseif (segment%direction == OBC_DIRECTION_N) then + do k=1,GV%ke ; do J=JsdB,JedB ; do i=isd,ied + segment%normal_trans(i,J,k) = flow * G%dxCv(i,J) * h(i,j,k) + enddo ; enddo ; enddo + endif endif - do k=1,GV%ke - do j=jsd,jed ; do I=IsdB,IedB - if (segment%specified .or. segment%nudged) then - segment%normal_vel(I,j,k) = flow - endif - if (segment%specified) then - segment%normal_trans(I,j,k) = flow * G%dyCu(I,j) - endif - enddo ; enddo - enddo - do j=jsd,jed ; do I=IsdB,IedB + endif + + if (cross_channel) then + do j=js,je ; do I=is,ie segment%normal_vel_bt(I,j) = flow enddo ; enddo else - isd = segment%HI%isd ; ied = segment%HI%ied - JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB - do J=JsdB,JedB ; do i=isd,ied + do J=js,je ; do i=is,ie segment%normal_vel_bt(i,J) = 0.0 enddo ; enddo endif + enddo end subroutine dyed_channel_update_flow diff --git a/src/user/dyed_obcs_initialization.F90 b/src/user/dyed_obcs_initialization.F90 index 0307d93d3d..9d6abee421 100644 --- a/src/user/dyed_obcs_initialization.F90 +++ b/src/user/dyed_obcs_initialization.F90 @@ -1,14 +1,16 @@ -!> Dyed open boundary conditions -module dyed_obcs_initialization +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 -! This file is part of MOM6. See LICENSE.md for the license. +!> Dyed open boundary conditions; OBC_USER_CONFIG="dyed_obcs" +module dyed_obcs_initialization use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type -use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE use MOM_open_boundary, only : OBC_segment_type, register_segment_tracer use MOM_tracer_registry, only : tracer_registry_type, tracer_name_lookup use MOM_tracer_registry, only : tracer_type @@ -23,6 +25,7 @@ module dyed_obcs_initialization integer :: ntr = 0 !< Number of dye tracers !! \todo This is a module variable. Move this variable into the control structure. +real :: dye_obc_inflow = 0.0 !< Inflow value of obc dye concentration contains @@ -36,13 +39,14 @@ subroutine dyed_obcs_set_OBC_data(OBC, G, GV, param_file, tr_Reg) type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry. + ! Local variables character(len=40) :: mdl = "dyed_obcs_set_OBC_data" ! This subroutine's name. character(len=80) :: name, longname - integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, m, n, nz + integer :: is, ie, js, je, isd, ied, jsd, jed, m, n, nz, ntr_id integer :: IsdB, IedB, JsdB, JedB - real :: dye - type(OBC_segment_type), pointer :: segment => NULL() + integer :: n_dye ! Number of regionsl dye tracers + real :: dye ! Inflow dye concentration [arbitrary] type(tracer_type), pointer :: tr_ptr => NULL() is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -51,10 +55,25 @@ subroutine dyed_obcs_set_OBC_data(OBC, G, GV, param_file, tr_Reg) if (.not.associated(OBC)) return - call get_param(param_file, mdl, "NUM_DYE_TRACERS", ntr, & - "The number of dye tracers in this run. Each tracer "//& - "should have a separate boundary segment.", default=0, & - do_not_log=.true.) + call get_param(param_file, mdl, "NUM_DYED_TRACERS", ntr, & + "The number of dyed_obc tracers in this run. Each tracer "//& + "should have a separate boundary segment. "//& + "If not present, use NUM_DYE_TRACERS.", default=-1, do_not_log=.true.) + if (ntr == -1) then + !for backward compatibility + call get_param(param_file, mdl, "NUM_DYE_TRACERS", ntr, & + "The number of dye tracers in this run. Each tracer "//& + "should have a separate boundary segment.", default=0, do_not_log=.true.) + n_dye = 0 + else + call get_param(param_file, mdl, "NUM_DYE_TRACERS", n_dye, & + "The number of dye tracers in this run. Each tracer "//& + "should have a separate region.", default=0, do_not_log=.true.) + endif + + call get_param(param_file, mdl, "DYE_OBC_INFLOW", dye_obc_inflow, & + "The OBC inflow value of dye tracers.", units="kg kg-1", & + default=1.0) if (OBC%number_of_segments < ntr) then call MOM_error(WARNING, "Error in dyed_obc segment setup") @@ -64,17 +83,17 @@ subroutine dyed_obcs_set_OBC_data(OBC, G, GV, param_file, tr_Reg) ! ! Set the inflow values of the dyes, one per segment. ! ! We know the order: north, south, east, west do m=1,ntr - write(name,'("dye_",I2.2)') m + write(name,'("dye_",I2.2)') m+n_dye !after regional dye tracers write(longname,'("Concentration of dyed_obc Tracer ",I2.2, " on segment ",I2.2)') m, m - call tracer_name_lookup(tr_Reg, tr_ptr, name) + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) do n=1,OBC%number_of_segments if (n == m) then - dye = 1.0 + dye = dye_obc_inflow else dye = 0.0 endif - call register_segment_tracer(tr_ptr, param_file, GV, & + call register_segment_tracer(tr_ptr, ntr_id, param_file, GV, & OBC%segment(n), OBC_scalar=dye) enddo enddo diff --git a/src/user/external_gwave_initialization.F90 b/src/user/external_gwave_initialization.F90 index 27d0cedded..552abe2f66 100644 --- a/src/user/external_gwave_initialization.F90 +++ b/src/user/external_gwave_initialization.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Initialization for the "external gravity wave wave" configuration module external_gwave_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories @@ -30,7 +32,7 @@ subroutine external_gwave_initialize_thickness(h, G, GV, US, param_file, just_re type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, intent(in) :: just_read !< If true, this call will only read @@ -39,12 +41,13 @@ subroutine external_gwave_initialize_thickness(h, G, GV, US, param_file, just_re real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface ! positive upward [Z ~> m]. real :: ssh_anomaly_height ! Vertical height of ssh anomaly [Z ~> m] - real :: ssh_anomaly_width ! Lateral width of anomaly [degrees] + real :: ssh_anomaly_width ! Lateral width of anomaly, often in [km] or [degrees_E] character(len=40) :: mdl = "external_gwave_initialize_thickness" ! This subroutine's name. ! This include declares and sets the variable "version". # include "version_variable.h" integer :: i, j, k, is, ie, js, je, nz - real :: PI, Xnondim + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] + real :: Xnondim ! A normalized x position [nondim] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -53,11 +56,11 @@ subroutine external_gwave_initialize_thickness(h, G, GV, US, param_file, just_re if (.not.just_read) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "SSH_ANOMALY_HEIGHT", ssh_anomaly_height, & - "The vertical displacement of the SSH anomaly. ", units="m", & - fail_if_missing=.not.just_read, do_not_log=just_read, scale=US%m_to_Z) + "The vertical displacement of the SSH anomaly. ", & + units="m", scale=US%m_to_Z, fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "SSH_ANOMALY_WIDTH", ssh_anomaly_width, & - "The lateral width of the SSH anomaly. ", units="coordinate", & - fail_if_missing=.not.just_read, do_not_log=just_read) + "The lateral width of the SSH anomaly. ", & + units=G%x_ax_unit_short, fail_if_missing=.not.just_read, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -72,7 +75,7 @@ subroutine external_gwave_initialize_thickness(h, G, GV, US, param_file, just_re enddo eta1D(nz+1) = -G%max_depth ! Force bottom interface to bottom do k=1,nz - h(i,j,k) = GV%Z_to_H * (eta1D(K) - eta1D(K+1)) + h(i,j,k) = eta1D(K) - eta1D(K+1) enddo enddo ; enddo diff --git a/src/user/lock_exchange_initialization.F90 b/src/user/lock_exchange_initialization.F90 index a61d07fcc8..8f2297c730 100644 --- a/src/user/lock_exchange_initialization.F90 +++ b/src/user/lock_exchange_initialization.F90 @@ -1,9 +1,11 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Initialization of the "lock exchange" experiment. !! lock_exchange = A 2-d density driven hydraulic exchange flow. module lock_exchange_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories @@ -28,19 +30,16 @@ subroutine lock_exchange_initialize_thickness(h, G, GV, US, param_file, just_rea type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, intent(in) :: just_read !< If true, this call will only read !! parameters without changing h. - real :: e0(SZK_(GV)) ! The resting interface heights [Z ~> m], usually - ! negative because it is positive upward. - real :: e_pert(SZK_(GV)) ! Interface height perturbations, positive upward [Z ~> m]. real :: eta1D(SZK_(GV)+1)! Interface height relative to the sea surface ! positive upward [Z ~> m]. - real :: front_displacement ! Vertical displacement acrodd front - real :: thermocline_thickness ! Thickness of stratified region + real :: front_displacement ! Vertical displacement across front [Z ~> m] + real :: thermocline_thickness ! Thickness of stratified region [Z ~> m] ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "lock_exchange_initialize_thickness" ! This subroutine's name. @@ -83,7 +82,7 @@ subroutine lock_exchange_initialize_thickness(h, G, GV, US, param_file, just_rea eta1D(K) = min( eta1D(K), eta1D(K-1) - GV%Angstrom_Z ) enddo do k=nz,1,-1 - h(i,j,k) = GV%Z_to_H * (eta1D(K) - eta1D(K+1)) + h(i,j,k) = eta1D(K) - eta1D(K+1) enddo enddo ; enddo diff --git a/src/user/seamount_initialization.F90 b/src/user/seamount_initialization.F90 index 3dba7bfe59..77556f123a 100644 --- a/src/user/seamount_initialization.F90 +++ b/src/user/seamount_initialization.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Configures the model for the idealized seamount test case. module seamount_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_domains, only : sum_across_PEs use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe @@ -14,7 +16,6 @@ module seamount_initialization use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type use regrid_consts, only : coordinateMode, DEFAULT_COORDINATE_MODE use regrid_consts, only : REGRIDDING_LAYER, REGRIDDING_ZSTAR use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA @@ -41,25 +42,28 @@ module seamount_initialization subroutine seamount_initialize_topography( D, G, param_file, max_depth ) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth in the units of depth_max + intent(out) :: D !< Ocean bottom depth [Z ~> m] type(param_file_type), intent(in) :: param_file !< Parameter file structure - real, intent(in) :: max_depth !< Maximum ocean depth in arbitrary units + real, intent(in) :: max_depth !< Maximum ocean depth [Z ~> m] ! Local variables + real :: delta ! Height of the seamount as a fraction of the maximum ocean depth [nondim] + real :: x, y ! Normalized positions relative to the domain center [nondim] + real :: Lx, Ly ! Seamount length scales normalized by the relevant domain sizes [nondim] + real :: rLx, rLy ! The Adcroft reciprocals of Lx and Ly [nondim] integer :: i, j - real :: x, y, delta, Lx, rLx, Ly, rLy - call get_param(param_file, mdl,"SEAMOUNT_DELTA",delta, & + call get_param(param_file, mdl,"SEAMOUNT_DELTA", delta, & "Non-dimensional height of seamount.", & - units="non-dim", default=0.5) - call get_param(param_file, mdl,"SEAMOUNT_X_LENGTH_SCALE",Lx, & + units="nondim", default=0.5) + call get_param(param_file, mdl,"SEAMOUNT_X_LENGTH_SCALE", Lx, & "Length scale of seamount in x-direction. "//& "Set to zero make topography uniform in the x-direction.", & - units="Same as x,y", default=20.) - call get_param(param_file, mdl,"SEAMOUNT_Y_LENGTH_SCALE",Ly, & + units=G%x_ax_unit_short, default=20.) + call get_param(param_file, mdl,"SEAMOUNT_Y_LENGTH_SCALE", Ly, & "Length scale of seamount in y-direction. "//& "Set to zero make topography uniform in the y-direction.", & - units="Same as x,y", default=0.) + units=G%y_ax_unit_short, default=0.) Lx = Lx / G%len_lon Ly = Ly / G%len_lat @@ -70,7 +74,7 @@ subroutine seamount_initialize_topography( D, G, param_file, max_depth ) ! Compute normalized zonal coordinates (x,y=0 at center of domain) x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon - 0.5 y = ( G%geoLatT(i,j) - G%south_lat ) / G%len_lat - 0.5 - D(i,j) = G%max_depth * ( 1.0 - delta * exp(-(rLx*x)**2 -(rLy*y)**2) ) + D(i,j) = G%max_depth * ( 1.0 - delta * exp(-((rLx*x)**2) - ((rLy*y)**2)) ) enddo ; enddo end subroutine seamount_initialize_topography @@ -82,7 +86,7 @@ subroutine seamount_initialize_thickness (h, depth_tot, G, GV, US, param_file, j type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file @@ -94,7 +98,8 @@ subroutine seamount_initialize_thickness (h, depth_tot, G, GV, US, param_file, j ! negative because it is positive upward. real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface, positive upward [Z ~> m] real :: min_thickness ! The minimum layer thicknesses [Z ~> m]. - real :: S_surf, S_range, S_ref, S_light, S_dense ! Various salinities [ppt]. + real :: S_ref ! A default value for salinities [S ~> ppt]. + real :: S_surf, S_range, S_light, S_dense ! Various salinities [S ~> ppt]. real :: eta_IC_quanta ! The granularity of quantization of intial interface heights [Z-1 ~> m-1]. character(len=20) :: verticalCoordinate integer :: i, j, k, is, ie, js, je, nz @@ -102,7 +107,7 @@ subroutine seamount_initialize_thickness (h, depth_tot, G, GV, US, param_file, j is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not.just_read) & - call MOM_mesg("MOM_initialization.F90, initialize_thickness_uniform: setting thickness") + call MOM_mesg("seamount_initialization.F90, seamount_initialize_thickness: setting thickness") call get_param(param_file, mdl,"MIN_THICKNESS",min_thickness, & 'Minimum thickness for layer', & @@ -124,11 +129,16 @@ subroutine seamount_initialize_thickness (h, depth_tot, G, GV, US, param_file, j select case ( coordinateMode(verticalCoordinate) ) case ( REGRIDDING_LAYER, REGRIDDING_RHO ) ! Initial thicknesses for isopycnal coordinates - call get_param(param_file, mdl,"INITIAL_SSS", S_surf, default=34., do_not_log=.true.) - call get_param(param_file, mdl,"INITIAL_S_RANGE", S_range, default=2., do_not_log=.true.) - call get_param(param_file, mdl, "S_REF", S_ref, default=35.0, do_not_log=.true.) - call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_light, default = S_Ref, do_not_log=.true.) - call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_dense, default = S_Ref, do_not_log=.true.) + call get_param(param_file, mdl,"INITIAL_SSS", S_surf, & + units="ppt", default=34., scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl,"INITIAL_S_RANGE", S_range, & + units="ppt", default=2., scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "S_REF", S_ref, & + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_light, & + units="ppt", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_dense, & + units="ppt", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "INTERFACE_IC_QUANTA", eta_IC_quanta, & "The granularity of initial interface height values "//& "per meter, to avoid sensivity to order-of-arithmetic changes.", & @@ -156,9 +166,9 @@ subroutine seamount_initialize_thickness (h, depth_tot, G, GV, US, param_file, j eta1D(k) = e0(k) if (eta1D(k) < (eta1D(k+1) + GV%Angstrom_Z)) then eta1D(k) = eta1D(k+1) + GV%Angstrom_Z - h(i,j,k) = GV%Angstrom_H + h(i,j,k) = GV%Angstrom_Z else - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + h(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo enddo ; enddo @@ -171,9 +181,9 @@ subroutine seamount_initialize_thickness (h, depth_tot, G, GV, US, param_file, j eta1D(k) = -G%max_depth * real(k-1) / real(nz) if (eta1D(k) < (eta1D(k+1) + min_thickness)) then eta1D(k) = eta1D(k+1) + min_thickness - h(i,j,k) = GV%Z_to_H * min_thickness + h(i,j,k) = min_thickness else - h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) + h(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo enddo ; enddo @@ -181,7 +191,7 @@ subroutine seamount_initialize_thickness (h, depth_tot, G, GV, US, param_file, j case ( REGRIDDING_SIGMA ) ! Initial thicknesses for sigma coordinates if (just_read) return ! All run-time parameters have been read, so return. do j=js,je ; do i=is,ie - h(i,j,:) = GV%Z_to_H * depth_tot(i,j) / dfloat(nz) + h(i,j,:) = depth_tot(i,j) / real(nz) enddo ; enddo end select @@ -189,20 +199,31 @@ subroutine seamount_initialize_thickness (h, depth_tot, G, GV, US, param_file, j end subroutine seamount_initialize_thickness !> Initial values for temperature and salinity -subroutine seamount_initialize_temperature_salinity(T, S, h, G, GV, param_file, just_read) +subroutine seamount_initialize_temperature_salinity(T, S, h, G, GV, US, param_file, just_read) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [ppt] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [Z ~> m] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file structure logical, intent(in) :: just_read !< If true, this call will !! only read parameters without changing T & S. ! Local variables + real :: xi0, xi1 ! Fractional positions within the depth range [nondim] + real :: r ! A nondimensional sharpness parameter with an exponetial profile [nondim] + real :: S_Ref ! Default salinity range parameters [S ~> ppt]. + real :: T_Ref ! Default temperature range parameters [C ~> degC]. + real :: S_Light, S_Dense, S_surf, S_range ! Salinity range parameters [S ~> ppt]. + real :: T_Light, T_Dense, T_surf, T_range ! Temperature range parameters [C ~> degC]. + real :: res_rat ! The ratio of density space resolution in the denser part + ! of the range to that in the lighter part of the range. + ! Setting this greater than 1 increases the resolution for + ! the denser water [nondim]. + real :: a1, frac_dense, k_frac ! Nondimensional temporary variables [nondim] integer :: i, j, k, is, ie, js, je, nz, k_light - real :: xi0, xi1, dxi, r, S_surf, T_surf, S_range, T_range - real :: T_ref, T_Light, T_Dense, S_ref, S_Light, S_Dense, a1, frac_dense, k_frac, res_rat + character(len=20) :: verticalCoordinate, density_profile is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -213,26 +234,35 @@ subroutine seamount_initialize_temperature_salinity(T, S, h, G, GV, param_file, 'Initial profile shape. Valid values are "linear", "parabolic" '//& 'and "exponential".', default='linear', do_not_log=just_read) call get_param(param_file, mdl,"INITIAL_SSS", S_surf, & - 'Initial surface salinity', units='1e-3', default=34., do_not_log=just_read) + 'Initial surface salinity', & + units="ppt", default=34., scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl,"INITIAL_SST", T_surf, & - 'Initial surface temperature', units='C', default=0., do_not_log=just_read) + 'Initial surface temperature', & + units="degC", default=0., scale=US%degC_to_C, do_not_log=just_read) call get_param(param_file, mdl,"INITIAL_S_RANGE", S_range, & - 'Initial salinity range (bottom - surface)', units='1e-3', & - default=2., do_not_log=just_read) + 'Initial salinity range (bottom - surface)', & + units="ppt", default=2., scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl,"INITIAL_T_RANGE", T_range, & - 'Initial temperature range (bottom - surface)', units='C', & - default=0., do_not_log=just_read) + 'Initial temperature range (bottom - surface)', & + units="degC", default=0., scale=US%degC_to_C, do_not_log=just_read) select case ( coordinateMode(verticalCoordinate) ) case ( REGRIDDING_LAYER ) ! Initial thicknesses for layer isopycnal coordinates ! These parameters are used in MOM_fixed_initialization.F90 when CONFIG_COORD="ts_range" - call get_param(param_file, mdl, "T_REF", T_ref, default=10.0, do_not_log=.true.) - call get_param(param_file, mdl, "TS_RANGE_T_LIGHT", T_light, default=T_Ref, do_not_log=.true.) - call get_param(param_file, mdl, "TS_RANGE_T_DENSE", T_dense, default=T_Ref, do_not_log=.true.) - call get_param(param_file, mdl, "S_REF", S_ref, default=35.0, do_not_log=.true.) - call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_light, default = S_Ref, do_not_log=.true.) - call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_dense, default = S_Ref, do_not_log=.true.) - call get_param(param_file, mdl, "TS_RANGE_RESOLN_RATIO", res_rat, default=1.0, do_not_log=.true.) + call get_param(param_file, mdl, "T_REF", T_ref, & + units="degC", default=10.0, scale=US%degC_to_C, do_not_log=.true.) + call get_param(param_file, mdl, "TS_RANGE_T_LIGHT", T_light, & + units="degC", default=US%C_to_degC*T_Ref, scale=US%degC_to_C, do_not_log=.true.) + call get_param(param_file, mdl, "TS_RANGE_T_DENSE", T_dense, & + units="degC", default=US%C_to_degC*T_Ref, scale=US%degC_to_C, do_not_log=.true.) + call get_param(param_file, mdl, "S_REF", S_ref, & + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_light, & + units="ppt", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_dense, & + units="ppt", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "TS_RANGE_RESOLN_RATIO", res_rat, & + units="nondim", default=1.0, do_not_log=.true.) if (just_read) return ! All run-time parameters have been read, so return. ! Emulate the T,S used in the "ts_range" coordinate configuration code @@ -254,7 +284,7 @@ subroutine seamount_initialize_temperature_salinity(T, S, h, G, GV, param_file, do j=js,je ; do i=is,ie xi0 = 0.0 do k = 1,nz - xi1 = xi0 + GV%H_to_Z * h(i,j,k) / G%max_depth + xi1 = xi0 + h(i,j,k) / G%max_depth select case ( trim(density_profile) ) case ('linear') !S(i,j,k) = S_surf + S_range * 0.5 * (xi0 + xi1) diff --git a/src/user/shelfwave_initialization.F90 b/src/user/shelfwave_initialization.F90 index 840f0bf3ed..488ac2b211 100644 --- a/src/user/shelfwave_initialization.F90 +++ b/src/user/shelfwave_initialization.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Configures the model for the idealized shelfwave test case. module shelfwave_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_domains, only : sum_across_PEs use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe @@ -10,8 +12,8 @@ module shelfwave_initialization use MOM_grid, only : ocean_grid_type use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_DIRECTION_W use MOM_open_boundary, only : OBC_segment_type, register_OBC -use MOM_open_boundary, only : OBC_registry_type -use MOM_time_manager, only : time_type, time_type_to_real +use MOM_open_boundary, only : OBC_registry_type, rotate_OBC_segment_direction +use MOM_time_manager, only : time_type, time_to_real use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type @@ -28,29 +30,34 @@ module shelfwave_initialization !> Control structure for shelfwave open boundaries. type, public :: shelfwave_OBC_CS ; private - real :: Lx = 100.0 !< Long-shore length scale of bathymetry [km] - real :: Ly = 50.0 !< Cross-shore length scale [km] - real :: f0 = 1.e-4 !< Coriolis parameter [T-1 ~> s-1] - real :: jj = 1 !< Cross-shore wave mode. - real :: kk !< Parameter. - real :: ll !< Longshore wavenumber. - real :: alpha !< 1/Ly. - real :: omega !< Frequency of the shelf wave [T-1 ~> s-1] + real :: my_amp !< Amplitude of the open boundary current inflows [L T-1 ~> m s-1] + real :: kk !< Cross-shore wavenumber [km-1] or [m-1] + real :: ll !< Longshore wavenumber [km-1] or [m-1] + real :: alpha !< Exponential decay rate in the y-direction [km-1] or [m-1] + real :: omega !< Frequency of the shelf wave [T-1 ~> s-1] + logical :: shelfwave_correct_amplitude !< If true, SHELFWAVE_AMPLITUDE gives the actual inflow + !! velocity, rather than giving an overall scaling factor for the flow. end type shelfwave_OBC_CS contains !> Add shelfwave to OBC registry. -function register_shelfwave_OBC(param_file, CS, US, OBC_Reg) +function register_shelfwave_OBC(param_file, CS, G, US, OBC_Reg) type(param_file_type), intent(in) :: param_file !< parameter file. type(shelfwave_OBC_CS), pointer :: CS !< shelfwave control structure. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(OBC_registry_type), pointer :: OBC_Reg !< OBC registry. + type(OBC_registry_type), pointer :: OBC_Reg !< Open boundary condition registry. logical :: register_shelfwave_OBC - ! Local variables - real :: kk, ll, PI, len_lat + ! Local variables + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] character(len=32) :: casename = "shelfwave" !< This case's name. + real :: jj ! Cross-shore wave mode [nondim] + real :: f0 ! Coriolis parameter [T-1 ~> s-1] + real :: Lx ! Long-shore length scale of bathymetry [km] or [m] + real :: Ly ! Cross-shore length scale [km] or [m] + real :: default_amp ! The default velocity amplitude [m s-1] or amplitude scaling factor [nondim] PI = 4.0*atan(1.0) @@ -63,26 +70,29 @@ function register_shelfwave_OBC(param_file, CS, US, OBC_Reg) ! Register the tracer for horizontal advection & diffusion. call register_OBC(casename, param_file, OBC_Reg) - call get_param(param_file, mdl, "F_0", CS%f0, & + call get_param(param_file, mdl, "F_0", f0, & default=0.0, units="s-1", scale=US%T_to_s, do_not_log=.true.) - call get_param(param_file, mdl, "LENLAT", len_lat, & - do_not_log=.true.) - call get_param(param_file, mdl,"SHELFWAVE_X_WAVELENGTH",CS%Lx, & + call get_param(param_file, mdl,"SHELFWAVE_X_WAVELENGTH", Lx, & "Length scale of shelfwave in x-direction.",& - units="Same as x,y", default=100.) -! units="km", default=100.0, scale=1.0e3*US%m_to_L) - call get_param(param_file, mdl, "SHELFWAVE_Y_LENGTH_SCALE", CS%Ly, & - "Length scale of exponential dropoff of topography "//& - "in the y-direction.", & - units="Same as x,y", default=50.) -! units="km", default=50.0, scale=1.0e3*US%m_to_L) - call get_param(param_file, mdl, "SHELFWAVE_Y_MODE", CS%jj, & + units=G%x_ax_unit_short, default=100.) + call get_param(param_file, mdl, "SHELFWAVE_Y_LENGTH_SCALE", Ly, & + "Length scale of exponential dropoff of topography in the y-direction.", & + units=G%y_ax_unit_short, default=50.) + call get_param(param_file, mdl, "SHELFWAVE_Y_MODE", jj, & "Cross-shore wave mode.", & units="nondim", default=1.) - CS%alpha = 1. / CS%Ly - CS%ll = 2. * PI / CS%Lx - CS%kk = CS%jj * PI / len_lat - CS%omega = 2 * CS%alpha * CS%f0 * CS%ll / & + call get_param(param_file, mdl, "SHELFWAVE_CORRECT_AMPLITUDE", CS%shelfwave_correct_amplitude, & + "If true, SHELFWAVE_AMPLITUDE gives the actual inflow velocity, rather than giving "//& + "an overall scaling factor for the flow.", default=.true.) + default_amp = 1.0 ; if (CS%shelfwave_correct_amplitude) default_amp = 0.1 + call get_param(param_file, mdl, "SHELFWAVE_AMPLITUDE", CS%my_amp, & + "Amplitude of the open boundary current inflows in the shelfwave configuration.", & + units="m s-1", default=default_amp, scale=US%m_s_to_L_T) + + CS%alpha = 1. / Ly + CS%ll = 2. * PI / Lx + CS%kk = jj * PI / G%len_lat + CS%omega = 2 * CS%alpha * f0 * CS%ll / & (CS%kk*CS%kk + CS%alpha*CS%alpha + CS%ll*CS%ll) register_shelfwave_OBC = .true. @@ -107,13 +117,16 @@ subroutine shelfwave_initialize_topography( D, G, param_file, max_depth, US ) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables + real :: y ! Position relative to the southern boundary [km] or [m] or [degrees_N] + real :: rLy ! Exponential decay rate of the topography [km-1] or [m-1] or [degrees_N-1] + real :: Ly ! Exponential decay lengthscale of the topography [km] or [m] or [degrees_N] + real :: H0 ! The minimum depth of the ocean [Z ~> m] integer :: i, j - real :: y, rLy, Ly, H0 - call get_param(param_file, mdl,"SHELFWAVE_Y_LENGTH_SCALE",Ly, & - default=50., do_not_log=.true.) + call get_param(param_file, mdl,"SHELFWAVE_Y_LENGTH_SCALE", Ly, & + units=G%y_ax_unit_short, default=50., do_not_log=.true.) call get_param(param_file, mdl,"MINIMUM_DEPTH", H0, & - default=10., units="m", scale=US%m_to_Z, do_not_log=.true.) + units="m", default=10., scale=US%m_to_Z, do_not_log=.true.) rLy = 0. ; if (Ly>0.) rLy = 1. / Ly @@ -134,53 +147,68 @@ subroutine shelfwave_set_OBC_data(OBC, CS, G, GV, US, h, Time) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness [H ~> m or kg m-2] type(time_type), intent(in) :: Time !< model time. ! The following variables are used to set up the transport in the shelfwave example. - real :: my_amp ! Amplitude of the open boundary current inflows [L T-1 ~> m s-1] real :: time_sec ! The time in the run [T ~> s] - real :: cos_wt, cos_ky, sin_wt, sin_ky - real :: omega ! Frequency of the shelf wave [T-1 ~> s-1] - real :: alpha - real :: x, y, jj, kk, ll - character(len=40) :: mdl = "shelfwave_set_OBC_data" ! This subroutine's name. - integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, n - integer :: IsdB, IedB, JsdB, JedB + real :: cos_wt, sin_wt ! Cosine and sine associated with the propagating x-direction structure [nondim] + real :: cos_ky, sin_ky ! Cosine and sine associated with the y-direction structure [nondim] + real :: x ! Position relative to the western boundary [km] or [m] or [degrees_E] + real :: y ! Position relative to the southern boundary [km] or [m] or [degrees_N] + real :: I_yscale ! A factor to give the correct inflow velocity [km-1] or [m-1] or [degrees_N-1] or + ! to compensate for the variable units of the y-coordinate [km axis_unit-1], usually 1 [nondim] + real :: my_amp ! Amplitude of the open boundary current inflows, including sign changes + ! to account for grid rotation [L T-1 ~> m s-1] + integer :: i, j, is, ie, js, je, n + integer :: turns ! Number of index quarter turns type(OBC_segment_type), pointer :: segment => NULL() - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - if (.not.associated(OBC)) return - time_sec = US%s_to_T*time_type_to_real(Time) - omega = CS%omega - alpha = CS%alpha - my_amp = 1.0*US%m_s_to_L_T - jj = CS%jj - kk = CS%kk - ll = CS%ll + turns = modulo(G%HI%turns, 4) + my_amp = CS%my_amp ; if ((turns==2) .or. (turns==3)) my_amp = -CS%my_amp + + time_sec = time_to_real(Time, scale=US%s_to_T) + if (CS%shelfwave_correct_amplitude) then + ! This makes the units and edge value of normal_vel_bt the same as my_amp. + I_yscale = 1.0 / CS%kk + else ! This preserves the previous answers. + if (G%grid_unit_to_L == 0.0) call MOM_error(FATAL, & + "shelfwave_set_OBC_data requires the use of Cartesian coordinates.") + I_yscale = (1.0e3 * US%m_to_L) / G%grid_unit_to_L + endif do n = 1, OBC%number_of_segments segment => OBC%segment(n) if (.not. segment%on_pe) cycle - if (segment%direction /= OBC_DIRECTION_W) cycle - - IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB - jsd = segment%HI%jsd ; jed = segment%HI%jed - do j=jsd,jed ; do I=IsdB,IedB - x = G%geoLonCu(I,j) - G%west_lon - y = G%geoLatCu(I,j) - G%south_lat - sin_wt = sin(ll*x - omega*time_sec) - cos_wt = cos(ll*x - omega*time_sec) - sin_ky = sin(kk * y) - cos_ky = cos(kk * y) - segment%normal_vel_bt(I,j) = my_amp * exp(- alpha * y) * cos_wt * & - (alpha * sin_ky + kk * cos_ky) -! segment%tangential_vel_bt(I,j) = my_amp * ll * exp(- alpha * y) * sin_wt * sin_ky -! segment%vorticity_bt(I,j) = my_amp * exp(- alpha * y) * cos_wt * sin_ky& -! (ll*ll + kk*kk + alpha*alpha) + if (rotate_OBC_segment_direction(segment%direction, -turns) /= OBC_DIRECTION_W) cycle + + if (segment%is_E_or_W) then + ! segment thicknesses are defined at cell face centers. + is = segment%HI%isdB ; ie = segment%HI%iedB + js = segment%HI%jsd ; je = segment%HI%jed + else + is = segment%HI%isd ; ie = segment%HI%ied + js = segment%HI%jsdB ; je = segment%HI%jedB + endif + + do j=js,je ; do I=is,ie + if (segment%is_E_or_W) then + x = G%geoLonCu(I,j) - G%west_lon + y = G%geoLatCu(I,j) - G%south_lat + else + x = G%geoLonCv(i,J) - G%west_lon + y = G%geoLatCv(i,J) - G%south_lat + endif + sin_wt = sin(CS%ll*x - CS%omega*time_sec) + cos_wt = cos(CS%ll*x - CS%omega*time_sec) + sin_ky = sin(CS%kk * y) + cos_ky = cos(CS%kk * y) + segment%normal_vel_bt(I,j) = my_amp * exp(- CS%alpha * y) * cos_wt * & + ((CS%alpha * sin_ky + CS%kk * cos_ky) * I_yscale) +! segment%tangential_vel_bt(I,j) = my_amp * (CS%ll * I_yscale) * exp(- CS%alpha * y) * sin_wt * sin_ky +! segment%vorticity_bt(I,j) = my_amp * exp(- CS%alpha * y) * cos_wt * sin_ky * & +! ((CS%ll**2 + CS%kk**2 + CS%alpha**2) * (I_yscale / G%grid_unit_to_L)) enddo ; enddo enddo diff --git a/src/user/sloshing_initialization.F90 b/src/user/sloshing_initialization.F90 index 3bafdb2d02..2fa18d5ee6 100644 --- a/src/user/sloshing_initialization.F90 +++ b/src/user/sloshing_initialization.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Initialization for the "sloshing" internal waves configuration. module sloshing_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_domains, only : sum_across_PEs use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe @@ -14,7 +16,6 @@ module sloshing_initialization use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type implicit none ; private @@ -31,9 +32,9 @@ module sloshing_initialization subroutine sloshing_initialize_topography( D, G, param_file, max_depth ) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth in the units of depth_max + intent(out) :: D !< Ocean bottom depth [Z ~> m] type(param_file_type), intent(in) :: param_file !< Parameter file structure - real, intent(in) :: max_depth !< Maximum ocean depth in arbitrary units + real, intent(in) :: max_depth !< Maximum ocean depth [Z ~> m] ! Local variables integer :: i, j @@ -58,27 +59,26 @@ subroutine sloshing_initialize_thickness ( h, depth_tot, G, GV, US, param_file, type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] - type(param_file_type), intent(in) :: param_file !< A structure indicating the open file - !! to parse for model parameter values. - logical, intent(in) :: just_read !< If true, this call will - !! only read parameters without changing h. + type(param_file_type), intent(in) :: param_file !< A structure to parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing h. + ! Local variables real :: displ(SZK_(GV)+1) ! The interface displacement [Z ~> m]. real :: z_unif(SZK_(GV)+1) ! Fractional uniform interface heights [nondim]. real :: z_inter(SZK_(GV)+1) ! Interface heights [Z ~> m] real :: a0 ! The displacement amplitude [Z ~> m]. - real :: weight_z ! A (misused?) depth-space weighting, in inconsistent units. - real :: x1, y1, x2, y2 ! Dimensonless parameters. - real :: x, t ! Dimensionless depth coordinates? + real :: weight_z ! A depth-space weighting [nondim]. + real :: x1, y1, x2, y2 ! Dimensonless parameters specifying the depth profile [nondim] + real :: x, t ! Dimensionless depth coordinates scales [nondim] logical :: use_IC_bug ! If true, set the initial conditions retaining an old bug. ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "sloshing_initialization" !< This module's name. - - integer :: i, j, k, is, ie, js, je, nx, nz + integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -108,7 +108,7 @@ subroutine sloshing_initialize_thickness ( h, depth_tot, G, GV, US, param_file, !z_inter(k) = (2.0**(n-1)) * (z_unif(k) + 0.5)**n - 0.5 ! Thin pycnocline in the middle (piecewise linear profile) - x1 = 0.30; y1 = 0.48; x2 = 0.70; y2 = 0.52 + x1 = 0.30 ; y1 = 0.48 ; x2 = 0.70 ; y2 = 0.52 x = -z_unif(k) @@ -134,7 +134,7 @@ subroutine sloshing_initialize_thickness ( h, depth_tot, G, GV, US, param_file, x = G%geoLonT(i,j) / G%len_lon if (use_IC_bug) then - displ(k) = a0 * cos(acos(-1.0)*x) + weight_z * US%m_to_Z + displ(k) = a0 * cos(acos(-1.0)*x) + weight_z * US%m_to_Z ! There is a flag to fix this bug. else displ(k) = a0 * cos(acos(-1.0)*x) * weight_z endif @@ -162,7 +162,7 @@ subroutine sloshing_initialize_thickness ( h, depth_tot, G, GV, US, param_file, ! 4. Define layers do k = 1,nz - h(i,j,k) = GV%Z_to_H * (z_inter(k) - z_inter(k+1)) + h(i,j,k) = z_inter(k) - z_inter(k+1) enddo enddo ; enddo @@ -176,42 +176,47 @@ end subroutine sloshing_initialize_thickness !! reference surface layer salinity and temperature and a specified range. !! Note that the linear distribution is set up with respect to the layer !! number, not the physical position). -subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, GV, param_file, just_read) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure. +subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, GV, US, param_file, just_read) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [degC]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [ppt]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. - type(param_file_type), intent(in) :: param_file !< A structure indicating the - !! open file to parse for model - !! parameter values. - logical, intent(in) :: just_read !< If true, this call will - !! only read parameters without changing T & S. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [C ~> degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [S ~> ppt]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [Z ~> m]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse + !! for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing T & S. + ! Local variables + real :: delta_T ! Temperature difference between layers [C ~> degC] + real :: S_ref, T_ref ! Reference salinity [S ~> ppt] and temperature [C ~> degC] within surface layer + real :: S_range, T_range ! Range of salinities [S ~> ppt] and temperatures [C ~> degC] over the vertical + real :: S_surf ! Initial surface salinity [S ~> ppt] + real :: T_pert ! A perturbed temperature [C ~> degC] + integer :: kdelta ! Half the number of layers with the temperature perturbation + real :: deltah ! Thickness of each layer [Z ~> m] + real :: xi0, xi1 ! Fractional vertical positions [nondim] + character(len=40) :: mdl = "sloshing_initialization" ! This module's name. integer :: i, j, k, is, ie, js, je, nz - real :: delta_S, delta_T - real :: S_ref, T_ref; ! Reference salinity and temerature within - ! surface layer - real :: S_range, T_range; ! Range of salinities and temperatures over the - ! vertical - integer :: kdelta - real :: deltah - real :: xi0, xi1 - character(len=40) :: mdl = "initialize_temp_salt_linear" ! This subroutine's - ! name. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke call get_param(param_file, mdl, "S_REF", S_ref, 'Reference value for salinity', & - default=35.0, units='1e-3', do_not_log=just_read) + default=35.0, units="ppt", scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "T_REF", T_ref, 'Reference value for temperature', & - units='degC', fail_if_missing=.not.just_read, do_not_log=just_read) + units='degC', scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) ! The default is to assume an increase by 2 ppt for the salinity and a uniform temperature. - call get_param(param_file, mdl,"S_RANGE",S_range,'Initial salinity range.', & - units='1e-3', default=2.0, do_not_log=just_read) - call get_param(param_file, mdl,"T_RANGE",T_range,'Initial temperature range', & - units='degC', default=0.0, do_not_log=just_read) + call get_param(param_file, mdl, "S_RANGE", S_range, 'Initial salinity range.', & + units="ppt", default=2.0, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & + units='degC', default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "INITIAL_SSS", S_surf, "Initial surface salinity", & + units="ppt", default=34.0, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "SLOSHING_T_PERT", T_pert, & + 'A mid-column temperature perturbation in the sloshing test case', & + units='degC', default=1.0, scale=US%degC_to_C, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -228,7 +233,7 @@ subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, GV, param_file xi0 = 0.0 do k = 1,nz xi1 = xi0 + deltah / G%max_depth ! = xi0 + 1.0 / real(nz) - S(i,j,k) = 34.0 + 0.5 * S_range * (xi0 + xi1) + S(i,j,k) = S_surf + 0.5 * S_range * (xi0 + xi1) xi0 = xi1 enddo enddo ; enddo @@ -241,7 +246,8 @@ subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, GV, param_file T(:,:,k) = T(:,:,k-1) + delta_T enddo kdelta = 2 - T(:,:,GV%ke/2 - (kdelta-1):GV%ke/2 + kdelta) = 1.0 + ! Perhaps the following lines should instead assign T() = T_pert + T_ref + T(:,:,GV%ke/2 - (kdelta-1):GV%ke/2 + kdelta) = T_pert end subroutine sloshing_initialize_temperature_salinity diff --git a/src/user/soliton_initialization.F90 b/src/user/soliton_initialization.F90 index f62aa54f88..569d6904aa 100644 --- a/src/user/soliton_initialization.F90 +++ b/src/user/soliton_initialization.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Initial conditions for the Equatorial Rossby soliton test (Boyd). module soliton_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories @@ -10,7 +12,6 @@ module soliton_initialization use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type use regrid_consts, only : coordinateMode, DEFAULT_COORDINATE_MODE use regrid_consts, only : REGRIDDING_LAYER, REGRIDDING_ZSTAR use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA @@ -27,56 +28,108 @@ module soliton_initialization contains -!> Initialization of thicknesses in Equatorial Rossby soliton test -subroutine soliton_initialize_thickness(h, depth_tot, G, GV, US) +!> Initialization of thicknesses in equatorial Rossby soliton test, as described in section +!! 6.1 of Haidvogel and Beckman (1990) and in Boyd (1980, JPO) and Boyd (1985, JPO). +subroutine soliton_initialize_thickness(h, depth_tot, G, GV, US, param_file, just_read) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thickness that is being initialized [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing h. + ! Local variables + real :: max_depth ! Maximum depth of the model bathymetry [Z ~> m] + real :: cg_max ! The external wave speed based on max_depth [L T-1 ~> m s-1] + real :: beta ! The meridional gradient of the Coriolis parameter [T-1 L-1 ~> s-1 m-1] + real :: L_eq ! The equatorial deformation radius used in nondimensionalizing this problem [L ~> m] + real :: scale_pos ! A conversion factor to nondimensionalize the axis units, usually [m-1] + real :: x0 ! Initial x-position of the soliton in the same units as geoLonT, often [m]. + real :: y0 ! Initial y-position of the soliton in the same units as geoLatT, often [m]. + real :: x, y ! Nondimensionalized positions [nondim] + real :: I_nz ! The inverse of the number of layers [nondim] + real :: val1 ! A nondimensionlized zonal decay scale [nondim] + real :: val2 ! An overall surface height anomaly amplitude [L T-1 ~> m s-1] + real :: val3 ! A decay factor [nondim] + real :: val4 ! The local velocity amplitude [L T-1 ~> m s-1] + ! This include declares and sets the variable "version". +# include "version_variable.h" integer :: i, j, k, is, ie, js, je, nz - real :: x, y, x0, y0 - real :: val1, val2, val3, val4 - character(len=40) :: verticalCoordinate is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - call MOM_mesg("soliton_initialization.F90, soliton_initialize_thickness: setting thickness") + if (.not.just_read) & + call MOM_mesg("soliton_initialization.F90, soliton_initialize_thickness: setting thickness") + + if (.not.just_read) call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "MAXIMUM_DEPTH", max_depth, & + units="m", default=-1.e9, scale=US%m_to_Z, do_not_log=.true.) + call get_param(param_file, mdl, "BETA", beta, & + "The northward gradient of the Coriolis parameter with the betaplane option.", & + units="m-1 s-1", default=0.0, scale=US%T_to_s*US%L_to_m, do_not_log=.true.) + + if (just_read) return ! All run-time parameters have been read, so return. + + if (max_depth <= 0.0) call MOM_error(FATAL, & + "soliton_initialization, soliton_initialize_thickness: "//& + "This module requires a positive value of MAXIMUM_DEPTH.") + if (abs(beta) <= 0.0) call MOM_error(FATAL, & + "soliton_initialization, soliton_initialize_thickness: "//& + "This module requires a non-zero value of BETA.") + if (G%grid_unit_to_L <= 0.) call MOM_error(FATAL, "soliton_initialization.F90: "//& + "soliton_initialize_thickness() is only set to work with Cartesian axis units.") + + cg_max = sqrt(GV%g_Earth * max_depth) + L_eq = sqrt(cg_max / abs(beta)) + scale_pos = G%grid_unit_to_L / L_eq + I_nz = 1.0 / real(nz) x0 = 2.0*G%len_lon/3.0 y0 = 0.0 val1 = 0.395 - val2 = US%m_to_Z * 0.771*(val1*val1) + val2 = max_depth * 0.771*(val1*val1) do j = G%jsc,G%jec ; do i = G%isc,G%iec do k = 1, nz - x = G%geoLonT(i,j)-x0 - y = G%geoLatT(i,j)-y0 + x = (G%geoLonT(i,j)-x0) * scale_pos + y = (G%geoLatT(i,j)-y0) * scale_pos val3 = exp(-val1*x) val4 = val2 * ( 2.0*val3 / (1.0 + (val3*val3)) )**2 - h(i,j,k) = GV%Z_to_H * (0.25*val4*(6.0*y*y + 3.0) * exp(-0.5*y*y) + depth_tot(i,j)) + h(i,j,k) = (0.25*val4*(6.0*y*y + 3.0) * exp(-0.5*y*y) + depth_tot(i,j)) * I_nz enddo enddo ; enddo end subroutine soliton_initialize_thickness -!> Initialization of u and v in the equatorial Rossby soliton test -subroutine soliton_initialize_velocity(u, v, h, G, GV, US) +!> Initialization of u and v in the equatorial Rossby soliton test, as described in section +!! 6.1 of Haidvogel and Beckman (1990) and in Boyd (1980, JPO) and Boyd (1985, JPO). +subroutine soliton_initialize_velocity(u, v, G, GV, US, param_file, just_read) type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(out) :: u !< i-component of velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: v !< j-component of velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Thickness [H ~> m or kg m-2] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing h. ! Local variables - real :: x, x0 ! Positions in the same units as geoLonT. - real :: y, y0 ! Positions in the same units as geoLatT. - real :: val1 ! A zonal decay scale in the inverse of the units of geoLonT. + real :: max_depth ! Maximum depth of the model bathymetry [Z ~> m] + real :: cg_max ! The external wave speed based on max_depth [L T-1 ~> m s-1] + real :: beta ! The meridional gradient of the Coriolis parameter [T-1 L-1 ~> s-1 m-1] + real :: L_eq ! The equatorial deformation radius used in nondimensionalizing this problem [L ~> m] + real :: scale_pos ! A conversion factor to nondimensionalize the axis units, usually [m-1] + real :: x0 ! Initial x-position of the soliton in the same units as geoLonT, often [m]. + real :: y0 ! Initial y-position of the soliton in the same units as geoLatT, often [m]. + real :: x, y ! Nondimensionalized positions [nondim] + real :: val1 ! A nondimensionlized zonal decay scale [nondim] real :: val2 ! An overall velocity amplitude [L T-1 ~> m s-1] real :: val3 ! A decay factor [nondim] real :: val4 ! The local velocity amplitude [L T-1 ~> m s-1] @@ -84,18 +137,42 @@ subroutine soliton_initialize_velocity(u, v, h, G, GV, US) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + if (.not.just_read) & + call MOM_mesg("soliton_initialization.F90, soliton_initialize_thickness: setting thickness") + + call get_param(param_file, mdl, "MAXIMUM_DEPTH", max_depth, & + units="m", default=-1.e9, scale=US%m_to_Z, do_not_log=.true.) + call get_param(param_file, mdl, "BETA", beta, & + "The northward gradient of the Coriolis parameter with the betaplane option.", & + units="m-1 s-1", default=0.0, scale=US%T_to_s*US%L_to_m, do_not_log=.true.) + + if (just_read) return ! All run-time parameters have been read, so return. + + if (max_depth <= 0.0) call MOM_error(FATAL, & + "soliton_initialization, soliton_initialize_velocity: "//& + "This module requires a positive value of MAXIMUM_DEPTH.") + if (abs(beta) <= 0.0) call MOM_error(FATAL, & + "soliton_initialization, soliton_initialize_velocity: "//& + "This module requires a non-zero value of BETA.") + if (G%grid_unit_to_L <= 0.) call MOM_error(FATAL, "soliton_initialization.F90: "//& + "soliton_initialize_velocity() is only set to work with Cartesian axis units.") + + cg_max = sqrt(GV%g_Earth * max_depth) + L_eq = sqrt(cg_max / abs(beta)) + scale_pos = G%grid_unit_to_L / L_eq + x0 = 2.0*G%len_lon/3.0 y0 = 0.0 val1 = 0.395 - val2 = US%m_s_to_L_T * 0.771*(val1*val1) + val2 = cg_max * 0.771*(val1*val1) v(:,:,:) = 0.0 u(:,:,:) = 0.0 do j = G%jsc,G%jec ; do I = G%isc-1,G%iec+1 do k = 1, nz - x = 0.5*(G%geoLonT(i+1,j)+G%geoLonT(i,j))-x0 - y = 0.5*(G%geoLatT(i+1,j)+G%geoLatT(i,j))-y0 + x = (0.5*(G%geoLonT(i+1,j)+G%geoLonT(i,j))-x0) * scale_pos + y = (0.5*(G%geoLatT(i+1,j)+G%geoLatT(i,j))-y0) * scale_pos val3 = exp(-val1*x) val4 = val2*((2.0*val3/(1.0+(val3*val3)))**2) u(I,j,k) = 0.25*val4*(6.0*y*y-9.0) * exp(-0.5*y*y) diff --git a/src/user/supercritical_initialization.F90 b/src/user/supercritical_initialization.F90 index b4ceb1905d..9190151569 100644 --- a/src/user/supercritical_initialization.F90 +++ b/src/user/supercritical_initialization.F90 @@ -1,14 +1,17 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> The "super critical" configuration module supercritical_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE, OBC_segment_type -use MOM_time_manager, only : time_type, time_type_to_real +use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_type, rotate_OBC_segment_direction +use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W +use MOM_time_manager, only : time_type use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type @@ -32,6 +35,8 @@ subroutine supercritical_set_OBC_data(OBC, G, GV, US, param_file) ! Local variables character(len=40) :: mdl = "supercritical_set_OBC_data" ! This subroutine's name. real :: zonal_flow ! Inflow speed [L T-1 ~> m s-1] + integer :: unrot_dir ! The unrotated direction of the segment + integer :: turns ! Number of index quarter turns integer :: i, j, k, l integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list @@ -43,13 +48,18 @@ subroutine supercritical_set_OBC_data(OBC, G, GV, US, param_file) "Constant zonal flow imposed at upstream open boundary.", & units="m/s", default=8.57, scale=US%m_s_to_L_T) + turns = modulo(G%HI%turns, 4) + do l=1, OBC%number_of_segments segment => OBC%segment(l) if (.not. segment%on_pe) cycle if (segment%gradient) cycle if (segment%oblique .and. .not. segment%nudged .and. .not. segment%Flather) cycle - if (segment%is_E_or_W) then + unrot_dir = segment%direction + if (turns /= 0) unrot_dir = rotate_OBC_segment_direction(segment%direction, -turns) + + if ((unrot_dir == OBC_DIRECTION_E) .or. (unrot_dir == OBC_DIRECTION_W)) then jsd = segment%HI%jsd ; jed = segment%HI%jed IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB do k=1,GV%ke diff --git a/src/user/tidal_bay_initialization.F90 b/src/user/tidal_bay_initialization.F90 index 2438b4115a..58938c65c0 100644 --- a/src/user/tidal_bay_initialization.F90 +++ b/src/user/tidal_bay_initialization.F90 @@ -1,20 +1,22 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Configures the model for the "tidal_bay" experiment. !! tidal_bay = Tidally resonant bay from Zygmunt Kowalik's class on tides. module tidal_bay_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_coms, only : reproducing_sum use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE +use MOM_open_boundary, only : ocean_OBC_type use MOM_open_boundary, only : OBC_segment_type, register_OBC use MOM_open_boundary, only : OBC_registry_type use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type -use MOM_time_manager, only : time_type, time_type_to_real +use MOM_time_manager, only : time_type, time_to_real implicit none ; private @@ -25,7 +27,10 @@ module tidal_bay_initialization !> Control structure for tidal bay open boundaries. type, public :: tidal_bay_OBC_CS ; private - real :: tide_flow = 3.0e6 !< Maximum tidal flux [L2 Z T-1 ~> m3 s-1] + real :: tide_flow = 3.0e6 !< Maximum tidal flux with the tidal bay configuration [L2 Z T-1 ~> m3 s-1] + real :: tide_period !< The period associated with the tidal bay configuration [T ~> s] + real :: tide_ssh_amp !< The magnitude of the sea surface height anomalies at the inflow + !! with the tidal bay configuration [Z ~> m] end type tidal_bay_OBC_CS contains @@ -43,6 +48,13 @@ function register_tidal_bay_OBC(param_file, CS, US, OBC_Reg) call get_param(param_file, mdl, "TIDAL_BAY_FLOW", CS%tide_flow, & "Maximum total tidal volume flux.", & units="m3 s-1", default=3.0e6, scale=US%m_s_to_L_T*US%m_to_L*US%m_to_Z) + call get_param(param_file, mdl, "TIDAL_BAY_PERIOD", CS%tide_period, & + "Period of the inflow in the tidal bay configuration.", & + units="s", default=12.0*3600.0, scale=US%s_to_T) + call get_param(param_file, mdl, "TIDAL_BAY_SSH_ANOM", CS%tide_ssh_amp, & + "Magnitude of the sea surface height anomalies at the inflow with the "//& + "tidal bay configuration.", & + units="m", default=0.1, scale=US%m_to_Z) ! Register the open boundaries. call register_OBC(casename, param_file, OBC_Reg) @@ -63,15 +75,15 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, US, h, Time) type(time_type), intent(in) :: Time !< model time. ! The following variables are used to set up the transport in the tidal_bay example. - real :: time_sec - real :: cff_eta ! The total column thickness anomalies associated with the inflow [H ~> m or kg m-2] - real :: my_flux ! The vlume flux through the face [L2 Z T-1 ~> m3 s-1] + real :: time_sec ! Elapsed model time [T ~> s] + real :: cff_eta ! The sea surface height anomalies associated with the inflow [Z ~> m] + real :: my_flux ! The volume flux through the face [L2 Z T-1 ~> m3 s-1] real :: total_area ! The total face area of the OBCs [L Z ~> m2] - real :: PI - real :: flux_scale ! A scaling factor for the areas [m2 H-1 L-1 ~> nondim or m3 kg-1] - real, allocatable :: my_area(:,:) ! The total OBC inflow area [m2] - character(len=40) :: mdl = "tidal_bay_set_OBC_data" ! This subroutine's name. - integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, nz, n + real :: normal_vel ! The normal velocity through the inflow face [L T-1 ~> m s-1] + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] + real, allocatable :: my_area(:,:) ! The total OBC inflow area [L Z ~> m2] + integer :: turns ! Number of index quarter turns + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, n integer :: IsdB, IedB, JsdB, JedB type(OBC_segment_type), pointer :: segment => NULL() @@ -81,36 +93,64 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, US, h, Time) PI = 4.0*atan(1.0) - if (.not.associated(OBC)) return + turns = modulo(G%HI%turns, 4) - allocate(my_area(1:1,js:je)) + if (.not.associated(OBC)) return - flux_scale = GV%H_to_m*US%L_to_m + time_sec = time_to_real(Time, scale=US%s_to_T) + cff_eta = CS%tide_ssh_amp * sin(2.0*PI*time_sec / CS%tide_period) - time_sec = time_type_to_real(Time) - cff_eta = 0.1*GV%m_to_H * sin(2.0*PI*time_sec/(12.0*3600.0)) - my_area=0.0 - my_flux=0.0 segment => OBC%segment(1) - do j=segment%HI%jsc,segment%HI%jec ; do I=segment%HI%IscB,segment%HI%IecB - if (OBC%segnum_u(I,j) /= OBC_NONE) then - do k=1,nz - ! This area has to be in MKS units to work with reproducing_sum. - my_area(1,j) = my_area(1,j) + h(I,j,k)*flux_scale*G%dyCu(I,j) - enddo - endif - enddo ; enddo - total_area = reproducing_sum(my_area) - my_flux = - CS%tide_flow*SIN(2.0*PI*time_sec/(12.0*3600.0)) + if (turns == 0) then + allocate(my_area(1:1,js:je), source=0.0) + do j=segment%HI%jsc,segment%HI%jec ; do I=segment%HI%IscB,segment%HI%IecB + if (OBC%segnum_u(I,j) > 0) then ! (segment%direction == OBC_DIRECTION_E) + do k=1,nz + my_area(1,j) = my_area(1,j) + h(i,j,k)*(GV%H_to_m*US%m_to_Z)*G%dyCu(I,j) + enddo + endif + enddo ; enddo + elseif (turns == 1) then + allocate(my_area(is:ie,1:1), source=0.0) + do J=segment%HI%JscB,segment%HI%JecB ; do i=segment%HI%isc,segment%HI%iec + if (OBC%segnum_v(i,J) > 0) then ! (segment%direction == OBC_DIRECTION_N) + do k=1,nz + my_area(i,1) = my_area(i,1) + h(i,j,k)*(GV%H_to_m*US%m_to_Z)*G%dxCv(i,J) + enddo + endif + enddo ; enddo + elseif (turns == 2) then + allocate(my_area(1:1,js:je), source=0.0) + do j=segment%HI%jsc,segment%HI%jec ; do I=segment%HI%IscB,segment%HI%IecB + if (OBC%segnum_u(I,j) < 0) then ! (segment%direction == OBC_DIRECTION_W) + do k=1,nz + my_area(1,j) = my_area(1,j) + h(i+1,j,k)*(GV%H_to_m*US%m_to_Z)*G%dyCu(I,j) + enddo + endif + enddo ; enddo + elseif (turns == 3) then + allocate(my_area(is:ie,1:1), source=0.0) + do J=segment%HI%JscB,segment%HI%JecB ; do i=segment%HI%isc,segment%HI%iec + if (OBC%segnum_v(i,J) < 0) then ! (segment%direction == OBC_DIRECTION_S) + do k=1,nz + my_area(i,1) = my_area(i,1) + h(i,j+1,k)*(GV%H_to_m*US%m_to_Z)*G%dxCv(i,J) + enddo + endif + enddo ; enddo + endif + + total_area = reproducing_sum(my_area, unscale=US%Z_to_m*US%L_to_m) + my_flux = - CS%tide_flow * SIN(2.0*PI*time_sec / CS%tide_period) + normal_vel = my_flux / total_area + if ((turns==2) .or. (turns==3)) normal_vel = -1.0 * normal_vel do n = 1, OBC%number_of_segments segment => OBC%segment(n) - if (.not. segment%on_pe) cycle - segment%normal_vel_bt(:,:) = my_flux / (US%m_to_Z*US%m_to_L*total_area) - segment%eta(:,:) = cff_eta + segment%normal_vel_bt(:,:) = normal_vel + segment%SSH(:,:) = cff_eta enddo ! end segment loop diff --git a/src/user/user_change_diffusivity.F90 b/src/user/user_change_diffusivity.F90 index 0308a3b008..fcd94442a3 100644 --- a/src/user/user_change_diffusivity.F90 +++ b/src/user/user_change_diffusivity.F90 @@ -1,13 +1,15 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Increments the diapycnal diffusivity in a specified band of latitudes and densities. module user_change_diffusivity -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_unit_scaling, only : unit_scale_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type, p3d use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density, EOS_domain @@ -26,10 +28,10 @@ module user_change_diffusivity !> Control structure for user_change_diffusivity type, public :: user_change_diff_CS ; private logical :: initialized = .false. !< True if this control structure has been initialized. - real :: Kd_add !< The scale of a diffusivity that is added everywhere - !! without any filtering or scaling [Z2 T-1 ~> m2 s-1]. + real :: Kd_add !< The scale of a diffusivity that is added everywhere without + !! any filtering or scaling [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: lat_range(4) !< 4 values that define the latitude range over which - !! a diffusivity scaled by Kd_add is added [degLat]. + !! a diffusivity scaled by Kd_add is added [degrees_N]. real :: rho_range(4) !< 4 values that define the coordinate potential !! density range over which a diffusivity scaled by !! Kd_add is added [R ~> kg m-3]. @@ -54,17 +56,17 @@ subroutine user_change_diff(h, tv, G, GV, US, CS, Kd_lay, Kd_int, T_f, S_f, Kd_i !! fields. Absent fields have NULL ptrs. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(user_change_diff_CS), pointer :: CS !< This module's control structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity of - !! each layer [Z2 T-1 ~> m2 s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), optional, intent(inout) :: Kd_int !< The diapycnal diffusivity - !! at each interface [Z2 T-1 ~> m2 s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity of each + !! layer [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), optional, intent(inout) :: Kd_int !< The diapycnal diffusivity at each + !! interface [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(in) :: T_f !< Temperature with massless - !! layers filled in vertically [degC]. + !! layers filled in vertically [C ~> degC]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(in) :: S_f !< Salinity with massless - !! layers filled in vertically [ppt]. + !! layers filled in vertically [S ~> ppt]. real, dimension(:,:,:), optional, pointer :: Kd_int_add !< The diapycnal !! diffusivity that is being added at - !! each interface [Z2 T-1 ~> m2 s-1]. + !! each interface [H Z T-1 ~> m2 s-1 or kg m-1 s-1] ! Local variables real :: Rcv(SZI_(G),SZK_(GV)) ! The coordinate density in layers [R ~> kg m-3]. real :: p_ref(SZI_(G)) ! An array of tv%P_Ref pressures [R L2 T-2 ~> Pa]. @@ -77,8 +79,6 @@ subroutine user_change_diff(h, tv, G, GV, US, CS, Kd_lay, Kd_int, T_f, S_f, Kd_i integer :: i, j, k, is, ie, js, je, nz integer :: isd, ied, jsd, jed - real :: kappa_fill ! diffusivity used to fill massless layers - real :: dt_fill ! timestep used to fill massless layers character(len=200) :: mesg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -153,7 +153,7 @@ end subroutine user_change_diff !> This subroutine checks whether the 4 values of range are in ascending order. function range_OK(range) result(OK) - real, dimension(4), intent(in) :: range !< Four values to check. + real, dimension(4), intent(in) :: range !< Four values to check [arbitrary] logical :: OK !< Return value. OK = ((range(1) <= range(2)) .and. (range(2) <= range(3)) .and. & @@ -171,7 +171,7 @@ function val_weights(val, range) result(ans) real, dimension(4), intent(in) :: range !< Range over which the answer is non-zero [arbitrary units]. real :: ans !< Return value [nondim]. ! Local variables - real :: x ! A nondimensional number between 0 and 1. + real :: x ! A nondimensional number between 0 and 1 [nondim]. ans = 0.0 if ((val > range(1)) .and. (val < range(4))) then @@ -205,11 +205,10 @@ subroutine user_change_diff_init(Time, G, GV, US, param_file, diag, CS) !! point to the control !! structure for this module. -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "user_set_diffusivity" ! This module's name. character(len=200) :: mesg - integer :: i, j, is, ie, js, je if (associated(CS)) then call MOM_error(WARNING, "diabatic_entrain_init called with an associated "// & @@ -219,17 +218,13 @@ subroutine user_change_diff_init(Time, G, GV, US, param_file, diag, CS) allocate(CS) CS%initialized = .true. - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - CS%diag => diag ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "USER_KD_ADD", CS%Kd_add, & "A user-specified additional diffusivity over a range of "//& - "latitude and density.", default=0.0, units="m2 s-1", & - scale=US%m2_s_to_Z2_T) + "latitude and density.", default=0.0, units="m2 s-1", scale=GV%m2_s_to_HZ_T) if (CS%Kd_add /= 0.0) then call get_param(param_file, mdl, "USER_KD_ADD_LAT_RANGE", CS%lat_range(:), & "Four successive values that define a range of latitudes "//& @@ -237,14 +232,15 @@ subroutine user_change_diff_init(Time, G, GV, US, param_file, diag, CS) "applied. The four values specify the latitudes at "//& "which the extra diffusivity starts to increase from 0, "//& "hits its full value, starts to decrease again, and is "//& - "back to 0.", units="degree", default=-1.0e9) + "back to 0.", units="degrees_N", defaults=(/-1.0e9,-1.0e9,-1.0e9,-1.0e9/)) call get_param(param_file, mdl, "USER_KD_ADD_RHO_RANGE", CS%rho_range(:), & "Four successive values that define a range of potential "//& "densities over which the user-given extra diffusivity "//& "is applied. The four values specify the density at "//& "which the extra diffusivity starts to increase from 0, "//& "hits its full value, starts to decrease again, and is "//& - "back to 0.", units="kg m-3", default=-1.0e9, scale=US%kg_m3_to_R) + "back to 0.", units="kg m-3", defaults=(/-1.0e9,-1.0e9,-1.0e9,-1.0e9/),& + scale=US%kg_m3_to_R) call get_param(param_file, mdl, "USER_KD_ADD_USE_ABS_LAT", CS%use_abs_lat, & "If true, use the absolute value of latitude when "//& "checking whether a point fits into range of latitudes.", & diff --git a/src/user/user_initialization.F90 b/src/user/user_initialization.F90 index d59d271471..390b42bd84 100644 --- a/src/user/user_initialization.F90 +++ b/src/user/user_initialization.F90 @@ -1,14 +1,16 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> A template of a user to code up customized initial conditions. module user_initialization -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type -use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N use MOM_open_boundary, only : OBC_DIRECTION_S use MOM_sponge, only : set_up_sponge_field, initialize_sponge, sponge_CS @@ -16,7 +18,7 @@ module user_initialization use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type + implicit none ; private #include @@ -76,12 +78,12 @@ subroutine USER_initialize_topography(D, G, param_file, max_depth, US) end subroutine USER_initialize_topography -!> initialize thicknesses. +!> Initialize thicknesses in depth units. These will be converted to thickness units later. subroutine USER_initialize_thickness(h, G, GV, param_file, just_read) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: h !< The thicknesses being initialized [H ~> m or kg m-2]. + intent(out) :: h !< The thicknesses being initialized [Z ~> m] type(param_file_type), intent(in) :: param_file !< A structure indicating the open !! file to parse for model parameter values. logical, intent(in) :: just_read !< If true, this call will @@ -93,7 +95,8 @@ subroutine USER_initialize_thickness(h, G, GV, param_file, just_read) if (just_read) return ! All run-time parameters have been read, so return. - h(:,:,1) = 0.0 ! h should be set [H ~> m or kg m-2]. + h(:,:,1:GV%ke) = 0.0 ! h should be set in [Z ~> m]. It will be converted to thickness units + ! [H ~> m or kg m-2] once the temperatures and salinities are known. if (first_call) call write_user_log(param_file) @@ -130,8 +133,8 @@ end subroutine USER_initialize_velocity subroutine USER_init_temperature_salinity(T, S, G, GV, param_file, just_read) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [degC]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [ppt]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< Potential temperature [C ~> degC]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S !< Salinity [S ~> ppt]. type(param_file_type), intent(in) :: param_file !< A structure indicating the !! open file to parse for model !! parameter values. @@ -238,8 +241,8 @@ end subroutine write_user_log !! - GV%g_prime - The reduced gravity at each interface [L2 Z-1 T-2 ~> m s-2]. !! - GV%Rlay - Layer potential density (coordinate variable) [R ~> kg m-3]. !! If ENABLE_THERMODYNAMICS is defined: -!! - T - Temperature [degC]. -!! - S - Salinity [ppt]. +!! - T - Temperature [C ~> degC]. +!! - S - Salinity [S ~> ppt]. !! If BULKMIXEDLAYER is defined: !! - Rml - Mixed layer and buffer layer potential densities [R ~> kg m-3]. !! If SPONGE is defined: diff --git a/src/user/user_revise_forcing.F90 b/src/user/user_revise_forcing.F90 index eb9694a091..db0df72f19 100644 --- a/src/user/user_revise_forcing.F90 +++ b/src/user/user_revise_forcing.F90 @@ -1,8 +1,10 @@ +! This file is part of MOM6, the Modular Ocean Model version 6. +! See the LICENSE file for licensing information. +! SPDX-License-Identifier: Apache-2.0 + !> Provides a template for users to code updating the forcing fluxes. module user_revise_forcing -! This file is part of MOM6. See LICENSE.md for the license. - use MOM_domains, only : pass_var, pass_vector, AGRID use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type @@ -21,7 +23,7 @@ module user_revise_forcing !> Control structure for user_revise_forcing type, public :: user_revise_forcing_CS ; private - real :: cdrag !< The quadratic bottom drag coefficient. + real :: cdrag !< The quadratic bottom drag coefficient [nondim] end type user_revise_forcing_CS contains